sql/utils.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:         utils.lisp
   6 ;;;; Purpose:      SQL utility functions
   7 ;;;; Programmer:   Kevin M. Rosenberg
   8 ;;;; Date Started: Mar 2002
   9 ;;;;
  10 ;;;; This file, part of CLSQL, is Copyright (c) 2002-2010 by Kevin M. Rosenberg
  11 ;;;;
  12 ;;;; CLSQL users are granted the rights to distribute and use this software
  13 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  14 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  15 ;;;; *************************************************************************
  16
  17 (in-package #:clsql-sys)
  18
  19 (defvar +whitespace-chars+
  20   '(#\space #\tab #\newline #\return
  21     ;; Tested: sbcl unicode, allegrocl, and clisp use #\no-break_space
  22     ;; lispworks uses #\no-break-space
  23     ;; sbcl non-unicode doesn't support no break space
  24     ;; AllegroCL 8-bit strings don't fail on reading #\no-break_space,
  25     ;; but can't represent such a character
  26     #+lispworks #\no-break-space
  27     #+(or (and sbcl sb-unicode) (and allegro ics) clisp) #\no-break_space
  28     )
  29   "List of whitespace characters for this lisp implementation.")
  30
  31 (defun number-to-sql-string (num)
  32   (etypecase num
  33     (integer
  34      (princ-to-string num))
  35     (rational
  36      (float-to-sql-string (coerce num 'double-float)))
  37     (number
  38      (float-to-sql-string num))))
  39
  40 (defun float-to-sql-string (num)
  41   "Convert exponent character for SQL"
  42   (let ((str (write-to-string num :readably t)))
  43     (cond
  44      ((find #\f str)
  45       (substitute #\e #\f str))
  46      ((find #\d str)
  47       (substitute #\e #\d str))
  48      ((find #\l str)
  49       (substitute #\e #\l str))
  50      ((find #\s str)
  51       (substitute #\e #\S str))
  52      ((find #\F str)
  53       (substitute #\e #\F str))
  54      ((find #\D str)
  55       (substitute #\e #\D str))
  56      ((find #\L str)
  57       (substitute #\e #\L str))
  58      ((find #\S str)
  59       (substitute #\e #\S str))
  60      (t
  61       str))))
  62
  63 (defun sql-escape (identifier)
  64   "Change hyphens to underscores, ensure string"
  65   (let ((unescaped (etypecase identifier
  66                      (symbol (symbol-name identifier))
  67                      (string identifier))))
  68     (substitute #\_ #\- unescaped)))
  69
  70 #+lispworks
  71 (defvar +lw-has-without-preemption+
  72   #+lispworks6 nil
  73   #-lispworks6 t)
  74 #+lispworks
  75 (defvar +lw-global-lock+
  76   (unless +lw-has-without-preemption+
  77     (mp:make-lock :name "CLSQL" :important-p nil :safep t :recursivep nil
  78                   :sharing t)))
  79
  80 (defmacro without-interrupts (&body body)
  81   #+allegro `(mp:without-scheduling ,@body)
  82   #+clisp `(progn ,@body)
  83   #+cmu `(system:without-interrupts ,@body)
  84   #+lispworks
  85   (if +lw-has-without-preemption+
  86       `(mp:without-preemption ,@body)
  87       `(mp:with-exclusive-lock (+lw-global-lock+)
  88          ,@body))
  89   #+openmcl `(ccl:without-interrupts ,@body)
  90   #+sbcl `(sb-sys::without-interrupts ,@body))
  91
  92 (defun make-process-lock (name)
  93   #+allegro (mp:make-process-lock :name name)
  94   #+cmu (mp:make-lock name)
  95   #+lispworks (mp:make-lock :name name)
  96   #+openmcl (ccl:make-lock name)
  97   #+sb-thread (sb-thread:make-mutex :name name)
  98   #+scl (thread:make-lock name)
  99   #-(or allegro cmu lispworks openmcl sb-thread scl) (declare (ignore name))
 100   #-(or allegro cmu lispworks openmcl sb-thread scl) nil)
 101
 102 (defmacro with-process-lock ((lock desc) &body body)
 103   #+(or cmu allegro lispworks openmcl sb-thread)
 104   (declare (ignore desc))
 105   #+(or allegro cmu lispworks openmcl sb-thread)
 106   (let ((l (gensym)))
 107     `(let ((,l ,lock))
 108       #+allegro (mp:with-process-lock (,l) ,@body)
 109       #+cmu (mp:with-lock-held (,l) ,@body)
 110       #+openmcl (ccl:with-lock-grabbed (,l) ,@body)
 111       #+lispworks (mp:with-lock (,l) ,@body)
 112       #+sb-thread (sb-thread:with-recursive-lock (,l) ,@body)
 113       ))
 114   #+scl `(thread:with-lock-held (,lock ,desc) ,@body)
 115   #-(or cmu allegro lispworks openmcl sb-thread scl) (declare
 116                                                       (ignore lock desc))
 117   #-(or cmu allegro lispworks openmcl sb-thread scl) `(progn ,@body))
 118
 119 (defun sql-escape-quotes (s)
 120   "Escape quotes for SQL string writing"
 121   (substitute-string-for-char s #\' "''"))
 122
 123 (defun substitute-string-for-char (procstr match-char subst-str)
 124 "Substitutes a string for a single matching character of a string"
 125   (let ((pos (position match-char procstr)))
 126     (if pos
 127         (concatenate 'string
 128           (subseq procstr 0 pos) subst-str
 129           (substitute-string-for-char
 130            (subseq procstr (1+ pos)) match-char subst-str))
 131       procstr)))
 132
 133
 134 (defun position-char (char string start max)
 135   "From KMRCL."
 136   (declare (optimize (speed 3) (safety 0) (space 0))
 137            (fixnum start max) (simple-string string))
 138   (do* ((i start (1+ i)))
 139        ((= i max) nil)
 140     (declare (fixnum i))
 141     (when (char= char (schar string i)) (return i))))
 142
 143 (defun delimited-string-to-list (string &optional (separator #\space)
 144                                                   skip-terminal)
 145   "Split a string with delimiter, from KMRCL."
 146   (declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0))
 147            (type string string)
 148            (type character separator))
 149   (do* ((len (length string))
 150         (output '())
 151         (pos 0)
 152         (end (position-char separator string pos len)
 153              (position-char separator string pos len)))
 154        ((null end)
 155         (if (< pos len)
 156             (push (subseq string pos) output)
 157             (when (or (not skip-terminal) (zerop len))
 158               (push "" output)))
 159         (nreverse output))
 160     (declare (type fixnum pos len)
 161              (type (or null fixnum) end))
 162     (push (subseq string pos end) output)
 163     (setq pos (1+ end))))
 164
 165 (defun string-to-list-connection-spec (str)
 166   (let ((at-pos (position-char #\@ str 0 (length str))))
 167     (cond
 168       ((and at-pos (> (length str) at-pos))
 169        ;; Connection spec is SQL*NET format
 170        (cons (subseq str (1+ at-pos))
 171              (delimited-string-to-list (subseq str 0 at-pos) #\/)))
 172       (t
 173        (delimited-string-to-list str #\/)))))
 174
 175 #+allegro
 176 (eval-when (:compile-toplevel :load-toplevel :execute)
 177   (unless (find-package '#:excl.osi)
 178     (require 'osi)))
 179
 180 (defun command-output (control-string &rest args)
 181   ;; Concatenates output and error since Lispworks combines
 182   ;; these, thus CLSQL can't depend upon separate results
 183   (multiple-value-bind (output error status)
 184       (apply #'%command-output control-string args)
 185     (values
 186      (concatenate 'string (if output output "")
 187                   (if error error ""))
 188      status)))
 189
 190 (defun read-stream-to-string (in)
 191   (with-output-to-string (out)
 192     (let ((eof (gensym)))
 193       (do ((line (read-line in nil eof)
 194                  (read-line in nil eof)))
 195           ((eq line eof))
 196         (format out "~A~%" line)))))
 197
 198 ;; From KMRCL
 199 (defun %command-output (control-string &rest args)
 200   "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
 201 synchronously execute the result using a Bourne-compatible shell,
 202 returns (VALUES string-output error-output exit-status)"
 203   (let ((command (apply #'format nil control-string args)))
 204     #+sbcl
 205     (let* ((process (sb-ext:run-program
 206                     "/bin/sh"
 207                     (list "-c" command)
 208                     :input nil :output :stream :error :stream))
 209            (output (read-stream-to-string (sb-impl::process-output process)))
 210            (error (read-stream-to-string (sb-impl::process-error process))))
 211       (close (sb-impl::process-output process))
 212       (close (sb-impl::process-error process))
 213       (values
 214        output
 215        error
 216        (sb-impl::process-exit-code process)))
 217
 218
 219     #+(or cmu scl)
 220     (let* ((process (ext:run-program
 221                      "/bin/sh"
 222                      (list "-c" command)
 223                      :input nil :output :stream :error :stream))
 224            (output (read-stream-to-string (ext::process-output process)))
 225            (error (read-stream-to-string (ext::process-error process))))
 226       (close (ext::process-output process))
 227       (close (ext::process-error process))
 228
 229       (values
 230        output
 231        error
 232        (ext::process-exit-code process)))
 233
 234     #+allegro
 235     (multiple-value-bind (output error status)
 236         (excl.osi:command-output command :whole t)
 237       (values output error status))
 238
 239     #+lispworks
 240     ;; BUG: Lispworks combines output and error streams
 241     (let ((output (make-string-output-stream)))
 242       (unwind-protect
 243           (let ((status
 244                  (system:call-system-showing-output
 245                   command
 246                   :shell-type "/bin/sh"
 247                   :output-stream output)))
 248             (values (get-output-stream-string output) nil status))
 249         (close output)))
 250
 251     #+clisp
 252     ;; BUG: CLisp doesn't allow output to user-specified stream
 253     (values
 254      nil
 255      nil
 256      (ext:run-shell-command  command :output :terminal :wait t))
 257
 258     #+openmcl
 259     (let* ((process (ccl:run-program
 260                      "/bin/sh"
 261                      (list "-c" command)
 262                      :input nil :output :stream :error :stream
 263                      :wait t))
 264            (output (read-stream-to-string (ccl::external-process-output-stream process)))
 265            (error (read-stream-to-string (ccl::external-process-error-stream process))))
 266       (close (ccl::external-process-output-stream process))
 267       (close (ccl::external-process-error-stream process))
 268       (values output
 269               error
 270               (nth-value 1 (ccl::external-process-status process))))
 271
 272     #-(or openmcl clisp lispworks allegro scl cmu sbcl)
 273     (error "COMMAND-OUTPUT not implemented for this Lisp")
 274
 275     ))
 276
 277
 278 ;; From KMRCL
 279 (defmacro in (obj &rest choices)
 280   (let ((insym (gensym)))
 281     `(let ((,insym ,obj))
 282        (or ,@(mapcar #'(lambda (c) `(eql ,insym ,c))
 283                      choices)))))
 284
 285 ;; From KMRCL
 286 (defun substitute-char-string (procstr match-char subst-str)
 287   "Substitutes a string for a single matching character of a string"
 288   (substitute-chars-strings procstr (list (cons match-char subst-str))))
 289
 290 (defun replaced-string-length (str repl-alist)
 291   (declare (simple-string str)
 292            (optimize (speed 3) (safety 0) (space 0)))
 293     (do* ((i 0 (1+ i))
 294           (orig-len (length str))
 295           (new-len orig-len))
 296          ((= i orig-len) new-len)
 297       (declare (fixnum i orig-len new-len))
 298       (let* ((c (char str i))
 299              (match (assoc c repl-alist :test #'char=)))
 300         (declare (character c))
 301         (when match
 302           (incf new-len (1- (length
 303                              (the simple-string (cdr match)))))))))
 304
 305
 306 (defun substitute-chars-strings (str repl-alist)
 307   "Replace all instances of a chars with a string. repl-alist is an assoc
 308 list of characters and replacement strings."
 309   (declare (simple-string str)
 310            (optimize (speed 3) (safety 0) (space 0)))
 311   (do* ((orig-len (length str))
 312         (new-string (make-string (replaced-string-length str repl-alist)))
 313         (spos 0 (1+ spos))
 314         (dpos 0))
 315       ((>= spos orig-len)
 316        new-string)
 317     (declare (fixnum spos dpos) (simple-string new-string))
 318     (let* ((c (char str spos))
 319            (match (assoc c repl-alist :test #'char=)))
 320       (declare (character c))
 321       (if match
 322           (let* ((subst (cdr match))
 323                  (len (length subst)))
 324             (declare (fixnum len)
 325                      (simple-string subst))
 326             (dotimes (j len)
 327               (declare (fixnum j))
 328               (setf (char new-string dpos) (char subst j))
 329               (incf dpos)))
 330         (progn
 331           (setf (char new-string dpos) c)
 332           (incf dpos))))))
 333
 334
 335 (defun getenv (var)
 336   "Return the value of the environment variable."
 337   #+allegro (sys::getenv (string var))
 338   #+clisp (ext:getenv (string var))
 339   #+(or cmu scl)
 340   (cdr (assoc (string var) ext:*environment-list* :test #'equalp
 341               :key #'string))
 342   #+lispworks (lw:environment-variable (string var))
 343   #+mcl (ccl::getenv var)
 344   #+sbcl (sb-ext:posix-getenv var))
 345
 346 (eval-when (:compile-toplevel :load-toplevel :execute)
 347   (when (char= #\a (schar (symbol-name '#:a) 0))
 348     (pushnew :clsql-lowercase-reader *features*)))
 349
 350 (defun symbol-name-default-case (str)
 351   #-clsql-lowercase-reader
 352   (string-upcase str)
 353   #+clsql-lowercase-reader
 354   (string-downcase str))
 355
 356 (defun convert-to-db-default-case (str database)
 357   (if database
 358       (case (db-type-default-case (database-underlying-type database))
 359         (:upper (string-upcase str))
 360         (:lower (string-downcase str))
 361         (t str))
 362     ;; Default CommonSQL behavior is to upcase strings
 363     (string-upcase str)))
 364
 365 (defun ensure-keyword (name)
 366   "Returns keyword for a name."
 367   (etypecase name
 368     (keyword name)
 369     (string (nth-value 0 (intern (symbol-name-default-case name) :keyword)))
 370     (symbol (nth-value 0 (intern (symbol-name name) :keyword)))))
 371
 372 (eval-when (:compile-toplevel :load-toplevel :execute)
 373   (setq cl:*features* (delete :clsql-lowercase-reader cl:*features*)))
 374