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