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