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