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