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