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