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