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