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   (when procstr
 130     (locally
 131         (declare (type string procstr))
 132       (let ((pos (position match-char procstr)))
 133         (if pos
 134             (concatenate 'string
 135                          (subseq procstr 0 pos) subst-str
 136                          (substitute-string-for-char
 137                           (subseq procstr (1+ pos)) match-char subst-str))
 138             procstr)))))
 139
 140
 141 (defun position-char (char string start max)
 142   "From KMRCL."
 143   (declare (optimize (speed 3) (safety 0) (space 0))
 144            (fixnum start max) (simple-string string))
 145   (do* ((i start (1+ i)))
 146        ((= i max) nil)
 147     (declare (fixnum i))
 148     (when (char= char (schar string i)) (return i))))
 149
 150 (defun delimited-string-to-list (string &optional (separator #\space)
 151                                                   skip-terminal)
 152   "Split a string with delimiter, from KMRCL."
 153   (declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0))
 154            (type string string)
 155            (type character separator))
 156   (do* ((len (length string))
 157         (output '())
 158         (pos 0)
 159         (end (position-char separator string pos len)
 160              (position-char separator string pos len)))
 161        ((null end)
 162         (if (< pos len)
 163             (push (subseq string pos) output)
 164             (when (or (not skip-terminal) (zerop len))
 165               (push "" output)))
 166         (nreverse output))
 167     (declare (type fixnum pos len)
 168              (type (or null fixnum) end))
 169     (push (subseq string pos end) output)
 170     (setq pos (1+ end))))
 171
 172 (defun string-to-list-connection-spec (str)
 173   (declare (type string str))
 174   (let ((at-pos (position-char #\@ str 0 (length str))))
 175     (cond
 176       ((and at-pos (> (length str) at-pos))
 177        ;; Connection spec is SQL*NET format
 178        (cons (subseq str (1+ at-pos))
 179              (delimited-string-to-list (subseq str 0 at-pos) #\/)))
 180       (t
 181        (delimited-string-to-list str #\/)))))
 182
 183 #+allegro
 184 (eval-when (:compile-toplevel :load-toplevel :execute)
 185   (unless (find-package '#:excl.osi)
 186     (require 'osi)))
 187
 188 (defun command-output (control-string &rest args)
 189   ;; Concatenates output and error since Lispworks combines
 190   ;; these, thus CLSQL can't depend upon separate results
 191   (multiple-value-bind (output error status)
 192       (apply #'%command-output control-string args)
 193     (values
 194      (concatenate 'string (if output output "")
 195                   (if error error ""))
 196      status)))
 197
 198 (defun read-stream-to-string (in)
 199   (with-output-to-string (out)
 200     (let ((eof (gensym)))
 201       (do ((line (read-line in nil eof)
 202                  (read-line in nil eof)))
 203           ((eq line eof))
 204         (format out "~A~%" line)))))
 205
 206 ;; From KMRCL
 207 (defun %command-output (control-string &rest args)
 208   "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
 209 synchronously execute the result using a Bourne-compatible shell,
 210 returns (VALUES string-output error-output exit-status)"
 211   (let ((command (apply #'format nil control-string args)))
 212     #+sbcl
 213     (let* ((process (sb-ext:run-program
 214                     "/bin/sh"
 215                     (list "-c" command)
 216                     :input nil :output :stream :error :stream))
 217            (output (read-stream-to-string (sb-impl::process-output process)))
 218            (error (read-stream-to-string (sb-impl::process-error process))))
 219       (close (sb-impl::process-output process))
 220       (close (sb-impl::process-error process))
 221       (values
 222        output
 223        error
 224        (sb-impl::process-exit-code process)))
 225
 226
 227     #+(or cmu scl)
 228     (let* ((process (ext:run-program
 229                      "/bin/sh"
 230                      (list "-c" command)
 231                      :input nil :output :stream :error :stream))
 232            (output (read-stream-to-string (ext::process-output process)))
 233            (error (read-stream-to-string (ext::process-error process))))
 234       (close (ext::process-output process))
 235       (close (ext::process-error process))
 236
 237       (values
 238        output
 239        error
 240        (ext::process-exit-code process)))
 241
 242     #+allegro
 243     (multiple-value-bind (output error status)
 244         (excl.osi:command-output command :whole t)
 245       (values output error status))
 246
 247     #+lispworks
 248     ;; BUG: Lispworks combines output and error streams
 249     (let ((output (make-string-output-stream)))
 250       (unwind-protect
 251           (let ((status
 252                  (system:call-system-showing-output
 253                   command
 254                   :shell-type "/bin/sh"
 255                   :output-stream output)))
 256             (values (get-output-stream-string output) nil status))
 257         (close output)))
 258
 259     #+clisp
 260     ;; BUG: CLisp doesn't allow output to user-specified stream
 261     (values
 262      nil
 263      nil
 264      (ext:run-shell-command  command :output :terminal :wait t))
 265
 266     #+openmcl
 267     (let* ((process (ccl:run-program
 268                      "/bin/sh"
 269                      (list "-c" command)
 270                      :input nil :output :stream :error :stream
 271                      :wait t))
 272            (output (read-stream-to-string (ccl::external-process-output-stream process)))
 273            (error (read-stream-to-string (ccl::external-process-error-stream process))))
 274       (close (ccl::external-process-output-stream process))
 275       (close (ccl::external-process-error-stream process))
 276       (values output
 277               error
 278               (nth-value 1 (ccl::external-process-status process))))
 279
 280     #-(or openmcl clisp lispworks allegro scl cmu sbcl)
 281     (error "COMMAND-OUTPUT not implemented for this Lisp")
 282
 283     ))
 284
 285
 286 ;; From KMRCL
 287 (defmacro in (obj &rest choices)
 288   (let ((insym (gensym)))
 289     `(let ((,insym ,obj))
 290        (or ,@(mapcar #'(lambda (c) `(eql ,insym ,c))
 291                      choices)))))
 292
 293 ;; From KMRCL
 294 (defun substitute-char-string (procstr match-char subst-str)
 295   "Substitutes a string for a single matching character of a string"
 296   (substitute-chars-strings procstr (list (cons match-char subst-str))))
 297
 298 (defun replaced-string-length (str repl-alist)
 299   (declare (simple-string str)
 300            (optimize (speed 3) (safety 0) (space 0)))
 301     (do* ((i 0 (1+ i))
 302           (orig-len (length str))
 303           (new-len orig-len))
 304          ((= i orig-len) new-len)
 305       (declare (fixnum i orig-len new-len))
 306       (let* ((c (char str i))
 307              (match (assoc c repl-alist :test #'char=)))
 308         (declare (character c))
 309         (when match
 310           (incf new-len (1- (length
 311                              (the simple-string (cdr match)))))))))
 312
 313
 314 (defun substitute-chars-strings (str repl-alist)
 315   "Replace all instances of a chars with a string. repl-alist is an assoc
 316 list of characters and replacement strings."
 317   (declare (simple-string str)
 318            (optimize (speed 3) (safety 0) (space 0)))
 319   (do* ((orig-len (length str))
 320         (new-string (make-string (replaced-string-length str repl-alist)))
 321         (spos 0 (1+ spos))
 322         (dpos 0))
 323       ((>= spos orig-len)
 324        new-string)
 325     (declare (fixnum spos dpos) (simple-string new-string))
 326     (let* ((c (char str spos))
 327            (match (assoc c repl-alist :test #'char=)))
 328       (declare (character c))
 329       (if match
 330           (let* ((subst (cdr match))
 331                  (len (length subst)))
 332             (declare (fixnum len)
 333                      (simple-string subst))
 334             (dotimes (j len)
 335               (declare (fixnum j))
 336               (setf (char new-string dpos) (char subst j))
 337               (incf dpos)))
 338         (progn
 339           (setf (char new-string dpos) c)
 340           (incf dpos))))))
 341
 342
 343 (defun getenv (var)
 344   "Return the value of the environment variable."
 345   #+allegro (sys::getenv (string var))
 346   #+clisp (ext:getenv (string var))
 347   #+(or cmu scl)
 348   (cdr (assoc (string var) ext:*environment-list* :test #'equalp
 349               :key #'string))
 350   #+lispworks (lw:environment-variable (string var))
 351   #+mcl (ccl::getenv var)
 352   #+sbcl (sb-ext:posix-getenv var))
 353
 354 (eval-when (:compile-toplevel :load-toplevel :execute)
 355   (when (char= #\a (schar (symbol-name '#:a) 0))
 356     (pushnew :clsql-lowercase-reader *features*)))
 357
 358 (defun symbol-name-default-case (str)
 359   #-clsql-lowercase-reader
 360   (string-upcase str)
 361   #+clsql-lowercase-reader
 362   (string-downcase str))
 363
 364 (defun convert-to-db-default-case (str database)
 365   (if database
 366       (case (db-type-default-case (database-underlying-type database))
 367         (:upper (string-upcase str))
 368         (:lower (string-downcase str))
 369         (t str))
 370     ;; Default CommonSQL behavior is to upcase strings
 371     (string-upcase str)))
 372
 373 (defun ensure-keyword (name)
 374   "Returns keyword for a name."
 375   (etypecase name
 376     (keyword name)
 377     (string (nth-value 0 (intern (symbol-name-default-case name) :keyword)))
 378     (symbol (nth-value 0 (intern (symbol-name name) :keyword)))))
 379
 380 (eval-when (:compile-toplevel :load-toplevel :execute)
 381   (setq cl:*features* (delete :clsql-lowercase-reader cl:*features*)))
 382
 383 (defun replace-all (string part replacement &key (test #'char=) stream)
 384   "Returns a new string in which all the occurences of the part
 385 is replaced with replacement. [FROM http://cl-cookbook.sourceforge.net/strings.html#manip]"
 386   (let ((out (or stream (make-string-output-stream))))
 387     (loop with part-length = (length part)
 388           for old-pos = 0 then (+ pos part-length)
 389           for pos = (search part string
 390                             :start2 old-pos
 391                             :test test)
 392           do (write-string string out
 393                    :start old-pos
 394                    :end (or pos (length string)))
 395           when pos do (write-string replacement out)
 396             while pos)
 397     (unless stream
 398       (get-output-stream-string out))))
 399
 400
 401 (defun filter-plist (plist &rest keys-to-remove)
 402   "Returns a copy of the given plist with indicated key-value pairs
 403 removed. keys are searched with #'MEMBER"
 404   (declare (dynamic-extent keys-to-remove))
 405   (when plist
 406     (loop for (k v . rest) = plist then rest
 407           unless (member k keys-to-remove)
 408             collect k and collect v
 409           while rest)))
 410
 411 (defmacro make-weak-hash-table (&rest args)
 412   "Creates a weak hash table for use in a cache."
 413   `(progn
 414
 415     ;;NB: These are generally used for caches that may not have an alternate
 416     ;;clearing mechanism. If you are on an implementation that doesn't support
 417     ;;weak hash tables then you're memory may accumulate.
 418
 419     #-(or sbcl allegro clisp lispworks)
 420     (warn "UNSAFE! use of weak hash on implementation without support. (see clsql/sql/utils.lisp to add)")
 421
 422     (make-hash-table
 423       #+allegro   :values    #+allegro :weak
 424       #+clisp     :weak      #+clisp :value
 425       #+lispworks :weak-kind #+lispworks :value
 426       #+sbcl :weakness #+sbcl :value
 427       ,@args)
 428     ))