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