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