base/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 ;;;; $Id$
  11 ;;;;
  12 ;;;; This file, part of CLSQL, is Copyright (c) 2002-2004 by Kevin M. Rosenberg
  13 ;;;;
  14 ;;;; CLSQL users are granted the rights to distribute and use this software
  15 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  16 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  17 ;;;; *************************************************************************
  18
  19 (in-package #:clsql-base)
  20
  21 (defun number-to-sql-string (num)
  22   (etypecase num
  23     (integer
  24      num)
  25     (rational
  26      (float-to-sql-string (coerce num 'double-float)))
  27     (number
  28      (float-to-sql-string num))))
  29
  30 (defun float-to-sql-string (num)
  31   "Convert exponent character for SQL"
  32   (let ((str (write-to-string num :readably t)))
  33     (cond
  34      ((find #\f str)
  35       (substitute #\e #\f str))
  36      ((find #\d str)
  37       (substitute #\e #\d str))
  38      ((find #\l str)
  39       (substitute #\e #\l str))
  40      ((find #\s str)
  41       (substitute #\e #\S str))
  42      ((find #\F str)
  43       (substitute #\e #\F str))
  44      ((find #\D str)
  45       (substitute #\e #\D str))
  46      ((find #\L str)
  47       (substitute #\e #\L str))
  48      ((find #\S str)
  49       (substitute #\e #\S str))
  50      (t
  51       str))))
  52
  53 (defun sql-escape (identifier)
  54   "Change hyphens to underscores, ensure string"
  55   (let* ((unescaped (etypecase identifier
  56                       (symbol (symbol-name identifier))
  57                       (string identifier)))
  58          (escaped (make-string (length unescaped))))
  59     (dotimes (i (length unescaped))
  60       (setf (char escaped i)
  61             (cond ((equal (char unescaped i) #\-)
  62                    #\_)
  63                   ;; ...
  64                   (t
  65                    (char unescaped i)))))
  66     escaped))
  67
  68 (defmacro without-interrupts (&body body)
  69   #+lispworks `(mp:without-preemption ,@body)
  70   #+allegro `(mp:without-scheduling ,@body)
  71   #+cmu `(system:without-interrupts ,@body)
  72   #+sbcl `(sb-sys::without-interrupts ,@body)
  73   #+openmcl `(ccl:without-interrupts ,@body))
  74
  75 (defun make-process-lock (name)
  76   #+allegro (mp:make-process-lock :name name)
  77   #+cmu (mp:make-lock name)
  78   #+lispworks (mp:make-lock :name name)
  79   #+openmcl (ccl:make-lock name)
  80   #+sb-thread (sb-thread:make-mutex :name name)
  81   #+scl (thread:make-lock name)
  82   #-(or allegro cmu lispworks openmcl sb-thread scl) (declare (ignore name))
  83   #-(or allegro cmu lispworks openmcl sb-thread scl) nil)
  84
  85 (defmacro with-process-lock ((lock desc) &body body)
  86   #+(or cmu allegro lispworks openmcl sb-thread)
  87   (declare (ignore desc))
  88   #+(or allegro cmu lispworks openmcl sb-thread)
  89   (let ((l (gensym)))
  90     `(let ((,l ,lock))
  91       #+allegro (mp:with-process-lock (,l) ,@body)
  92       #+cmu (mp:with-lock-held (,l) ,@body)
  93       #+openmcl (ccl:with-lock-grabbed (,l) ,@body)
  94       #+lispworks (mp:with-lock (,l) ,@body)
  95       #+sb-thread (sb-thread:with-recursive-lock (,l) ,@body)
  96       ))
  97   #+scl `(thread:with-lock-held (,lock ,desc) ,@body)
  98   #-(or cmu allegro lispworks openmcl sb-thread scl) (declare
  99                                                       (ignore lock desc))
 100   #-(or cmu allegro lispworks openmcl sb-thread scl) `(progn ,@body))
 101
 102 (defun sql-escape-quotes (s)
 103   "Escape quotes for SQL string writing"
 104   (substitute-string-for-char s #\' "''"))
 105
 106 (defun substitute-string-for-char (procstr match-char subst-str)
 107 "Substitutes a string for a single matching character of a string"
 108   (let ((pos (position match-char procstr)))
 109     (if pos
 110         (concatenate 'string
 111           (subseq procstr 0 pos) subst-str
 112           (substitute-string-for-char
 113            (subseq procstr (1+ pos)) match-char subst-str))
 114       procstr)))
 115
 116
 117 (defun position-char (char string start max)
 118   "From KMRCL."
 119   (declare (optimize (speed 3) (safety 0) (space 0))
 120            (fixnum start max) (simple-string string))
 121   (do* ((i start (1+ i)))
 122        ((= i max) nil)
 123     (declare (fixnum i))
 124     (when (char= char (schar string i)) (return i))))
 125
 126 (defun delimited-string-to-list (string &optional (separator #\space)
 127                                                   skip-terminal)
 128   "Split a string with delimiter, from KMRCL."
 129   (declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0))
 130            (type string string)
 131            (type character separator))
 132   (do* ((len (length string))
 133         (output '())
 134         (pos 0)
 135         (end (position-char separator string pos len)
 136              (position-char separator string pos len)))
 137        ((null end)
 138         (if (< pos len)
 139             (push (subseq string pos) output)
 140             (when (or (not skip-terminal) (zerop len))
 141               (push "" output)))
 142         (nreverse output))
 143     (declare (type fixnum pos len)
 144              (type (or null fixnum) end))
 145     (push (subseq string pos end) output)
 146     (setq pos (1+ end))))
 147
 148 (defun string-to-list-connection-spec (str)
 149   (let ((at-pos (position-char #\@ str 0 (length str))))
 150     (cond
 151       ((and at-pos (> (length str) at-pos))
 152        ;; Connection spec is SQL*NET format
 153        (cons (subseq str (1+ at-pos))
 154              (delimited-string-to-list (subseq str 0 at-pos) #\/)))
 155       (t
 156        (delimited-string-to-list str #\/)))))
 157
 158 #+allegro
 159 (eval-when (:compile-toplevel :load-toplevel :execute)
 160   (unless (find-package '#:excl.osi)
 161     (require 'osi)))
 162
 163 (defun command-output (control-string &rest args)
 164   ;; Concatenates output and error since Lispworks combines
 165   ;; these, thus CLSQL can't depend upon separate results
 166   (multiple-value-bind (output error status)
 167       (apply #'%command-output control-string args)
 168     (values
 169      (concatenate 'string (if output output "")
 170                   (if error error ""))
 171      status)))
 172
 173 (defun read-stream-to-string (in)
 174   (with-output-to-string (out)
 175     (let ((eof (gensym)))
 176       (do ((line (read-line in nil eof)
 177                  (read-line in nil eof)))
 178           ((eq line eof))
 179         (format out "~A~%" line)))))
 180
 181 ;; From KMRCL
 182 (defun %command-output (control-string &rest args)
 183   "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
 184 synchronously execute the result using a Bourne-compatible shell,
 185 returns (VALUES string-output error-output exit-status)"
 186   (let ((command (apply #'format nil control-string args)))
 187     #+sbcl
 188     (let* ((process (sb-ext:run-program
 189                     "/bin/sh"
 190                     (list "-c" command)
 191                     :input nil :output :stream :error :stream))
 192            (output (read-stream-to-string (sb-impl::process-output process)))
 193            (error (read-stream-to-string (sb-impl::process-error process))))
 194       (close (sb-impl::process-output process))
 195       (close (sb-impl::process-error process))
 196       (values
 197        output
 198        error
 199        (sb-impl::process-exit-code process)))
 200
 201
 202     #+(or cmu scl)
 203     (let* ((process (ext:run-program
 204                      "/bin/sh"
 205                      (list "-c" command)
 206                      :input nil :output :stream :error :stream))
 207            (output (read-stream-to-string (ext::process-output process)))
 208            (error (read-stream-to-string (ext::process-error process))))
 209       (close (ext::process-output process))
 210       (close (ext::process-error process))
 211
 212       (values
 213        output
 214        error
 215        (ext::process-exit-code process)))
 216
 217     #+allegro
 218     (multiple-value-bind (output error status)
 219         (excl.osi:command-output command :whole t)
 220       (values output error status))
 221
 222     #+lispworks
 223     ;; BUG: Lispworks combines output and error streams
 224     (let ((output (make-string-output-stream)))
 225       (unwind-protect
 226           (let ((status
 227                  (system:call-system-showing-output
 228                   command
 229                   :shell-type "/bin/sh"
 230                   :output-stream output)))
 231             (values (get-output-stream-string output) nil status))
 232         (close output)))
 233
 234     #+clisp
 235     ;; BUG: CLisp doesn't allow output to user-specified stream
 236     (values
 237      nil
 238      nil
 239      (ext:run-shell-command  command :output :terminal :wait t))
 240
 241     #+openmcl
 242     (let* ((process (ccl:run-program
 243                      "/bin/sh"
 244                      (list "-c" command)
 245                      :input nil :output :stream :error :stream
 246                      :wait t))
 247            (output (read-stream-to-string (ccl::external-process-output-stream process)))
 248            (error (read-stream-to-string (ccl::external-process-error-stream process))))
 249       (close (ccl::external-process-output-stream process))
 250       (close (ccl::external-process-error-stream process))
 251       (values output
 252               error
 253               (nth-value 1 (ccl::external-process-status process))))
 254
 255     #-(or openmcl clisp lispworks allegro scl cmu sbcl)
 256     (error "COMMAND-OUTPUT not implemented for this Lisp")
 257
 258     ))
 259
 260
 261 ;; From KMRCL
 262 (defmacro in (obj &rest choices)
 263   (let ((insym (gensym)))
 264     `(let ((,insym ,obj))
 265        (or ,@(mapcar #'(lambda (c) `(eql ,insym ,c))
 266                      choices)))))
 267
 268 ;; From KMRCL
 269 (defun substitute-char-string (procstr match-char subst-str)
 270   "Substitutes a string for a single matching character of a string"
 271   (substitute-chars-strings procstr (list (cons match-char subst-str))))
 272
 273 (defun replaced-string-length (str repl-alist)
 274   (declare (simple-string str)
 275            (optimize (speed 3) (safety 0) (space 0)))
 276     (do* ((i 0 (1+ i))
 277           (orig-len (length str))
 278           (new-len orig-len))
 279          ((= i orig-len) new-len)
 280       (declare (fixnum i orig-len new-len))
 281       (let* ((c (char str i))
 282              (match (assoc c repl-alist :test #'char=)))
 283         (declare (character c))
 284         (when match
 285           (incf new-len (1- (length
 286                              (the simple-string (cdr match)))))))))
 287
 288
 289 (defun substitute-chars-strings (str repl-alist)
 290   "Replace all instances of a chars with a string. repl-alist is an assoc
 291 list of characters and replacement strings."
 292   (declare (simple-string str)
 293            (optimize (speed 3) (safety 0) (space 0)))
 294   (do* ((orig-len (length str))
 295         (new-string (make-string (replaced-string-length str repl-alist)))
 296         (spos 0 (1+ spos))
 297         (dpos 0))
 298       ((>= spos orig-len)
 299        new-string)
 300     (declare (fixnum spos dpos) (simple-string new-string))
 301     (let* ((c (char str spos))
 302            (match (assoc c repl-alist :test #'char=)))
 303       (declare (character c))
 304       (if match
 305           (let* ((subst (cdr match))
 306                  (len (length subst)))
 307             (declare (fixnum len)
 308                      (simple-string subst))
 309             (dotimes (j len)
 310               (declare (fixnum j))
 311               (setf (char new-string dpos) (char subst j))
 312               (incf dpos)))
 313         (progn
 314           (setf (char new-string dpos) c)
 315           (incf dpos))))))
 316
 317
 318 (eval-when (:compile-toplevel :load-toplevel :execute)
 319   (when (char= #\a (schar (symbol-name '#:a) 0))
 320     (pushnew :lowercase-reader *features*)))
 321
 322 (defun symbol-name-default-case (str)
 323   #-lowercase-reader
 324   (string-upcase str)
 325   #+lowercase-reader
 326   (string-downcase str))
 327
 328 (defun convert-to-db-default-case (str database)
 329   (if database
 330       (case (db-type-default-case (database-underlying-type database))
 331         (:upper (string-upcase str))
 332         (:lower (string-downcase str))
 333         (t str))
 334     ;; Default CommonSQL behavior is to upcase strings
 335     (string-upcase str)))
 336
 337
 338 (defun ensure-keyword (name)
 339   "Returns keyword for a name"
 340   (etypecase name
 341     (keyword name)
 342     (string (nth-value 0 (intern (symbol-name-default-case name) :keyword)))
 343     (symbol (nth-value 0 (intern (symbol-name name) :keyword)))))