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