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-sys)
  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 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       (values
 193        (sb-impl::process-output process)
 194        (sb-impl::process-error process)
 195        (sb-impl::process-exit-code process)))
 196
 197     #+(or cmu scl)
 198     (let ((process (ext:run-program
 199                     "/bin/sh"
 200                     (list "-c" command)
 201                     :input nil :output :stream :error :stream)))
 202       (values
 203        (ext::process-output process)
 204        (ext::process-error process)
 205        (ext::process-exit-code process)))
 206
 207     #+allegro
 208     (multiple-value-bind (output error status)
 209         (excl.osi:command-output command :whole t)
 210       (values output error status))
 211
 212     #+lispworks
 213     ;; BUG: Lispworks combines output and error streams
 214     (let ((output (make-string-output-stream)))
 215       (unwind-protect
 216           (let ((status
 217                  (system:call-system-showing-output
 218                   command
 219                   :shell-type "/bin/sh"
 220                   :output-stream output)))
 221             (values (get-output-stream-string output) nil status))
 222         (close output)))
 223
 224     #+clisp
 225     ;; BUG: CLisp doesn't allow output to user-specified stream
 226     (values
 227      nil
 228      nil
 229      (ext:run-shell-command  command :output :terminal :wait t))
 230
 231     #+openmcl
 232     (let* ((process (ccl:run-program
 233                      "/bin/sh"
 234                      (list "-c" command)
 235                      :input nil :output :stream :error :stream
 236                      :wait t))
 237            (output (read-stream-to-string (ccl::external-process-output-stream process)))
 238            (error (read-stream-to-string (ccl::external-process-error-stream process))))
 239       (close (ccl::external-process-output-stream process))
 240       (close (ccl::external-process-error-stream process))
 241       (values output
 242               error
 243               (nth-value 1 (ccl::external-process-status process))))
 244
 245     #-(or openmcl clisp lispworks allegro scl cmu sbcl)
 246     (error "COMMAND-OUTPUT not implemented for this Lisp")
 247
 248     ))
 249
 250 (eval-when (:compile-toplevel :load-toplevel :execute)
 251   (when (char= #\a (schar (symbol-name '#:a) 0))
 252     (pushnew :lowercase-reader *features*)))
 253
 254 (defun string-default-case (str)
 255   #-lowercase-reader
 256   (string-upcase str)
 257   #+lowercase-reader
 258   (string-downcase str))
 259
 260 ;; From KMRCL
 261 (defun ensure-keyword (name)
 262   "Returns keyword for a name"
 263   (etypecase name
 264     (keyword name)
 265     (string (nth-value 0 (intern (string-default-case name) :keyword)))
 266     (symbol (nth-value 0 (intern (symbol-name name) :keyword)))))
 267
 268 ;; From KMRCL
 269 (defmacro in (obj &rest choices)
 270   (let ((insym (gensym)))
 271     `(let ((,insym ,obj))
 272        (or ,@(mapcar #'(lambda (c) `(eql ,insym ,c))
 273                      choices)))))
 274
 275 ;; From KMRCL
 276 (defun substitute-char-string (procstr match-char subst-str)
 277   "Substitutes a string for a single matching character of a string"
 278   (substitute-chars-strings procstr (list (cons match-char subst-str))))
 279
 280 (defun replaced-string-length (str repl-alist)
 281   (declare (simple-string str)
 282            (optimize (speed 3) (safety 0) (space 0)))
 283     (do* ((i 0 (1+ i))
 284           (orig-len (length str))
 285           (new-len orig-len))
 286          ((= i orig-len) new-len)
 287       (declare (fixnum i orig-len new-len))
 288       (let* ((c (char str i))
 289              (match (assoc c repl-alist :test #'char=)))
 290         (declare (character c))
 291         (when match
 292           (incf new-len (1- (length
 293                              (the simple-string (cdr match)))))))))
 294
 295
 296 (defun substitute-chars-strings (str repl-alist)
 297   "Replace all instances of a chars with a string. repl-alist is an assoc
 298 list of characters and replacement strings."
 299   (declare (simple-string str)
 300            (optimize (speed 3) (safety 0) (space 0)))
 301   (do* ((orig-len (length str))
 302         (new-string (make-string (replaced-string-length str repl-alist)))
 303         (spos 0 (1+ spos))
 304         (dpos 0))
 305       ((>= spos orig-len)
 306        new-string)
 307     (declare (fixnum spos dpos) (simple-string new-string))
 308     (let* ((c (char str spos))
 309            (match (assoc c repl-alist :test #'char=)))
 310       (declare (character c))
 311       (if match
 312           (let* ((subst (cdr match))
 313                  (len (length subst)))
 314             (declare (fixnum len)
 315                      (simple-string subst))
 316             (dotimes (j len)
 317               (declare (fixnum j))
 318               (setf (char new-string dpos) (char subst j))
 319               (incf dpos)))
 320         (progn
 321           (setf (char new-string dpos) c)
 322           (incf dpos))))))
 323