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