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