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