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