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