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 delimited-string-to-list (string &optional (separator #\space)
  85                                                   skip-terminal)
  86   "Split a string with delimiter, from KMRCL."
  87   (declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0))
  88            (type string string)
  89            (type character separator))
  90   (do* ((len (length string))
  91         (output '())
  92         (pos 0)
  93         (end (position-char separator string pos len)
  94              (position-char separator string pos len)))
  95        ((null end)
  96         (if (< pos len)
  97             (push (subseq string pos) output)
  98             (when (or (not skip-terminal) (zerop len))
  99               (push "" output)))
 100         (nreverse output))
 101     (declare (type fixnum pos len)
 102              (type (or null fixnum) end))
 103     (push (subseq string pos end) output)
 104     (setq pos (1+ end))))
 105
 106 (defun string-to-list-connection-spec (str)
 107   (let ((at-pos (position #\@ str)))
 108     (cond
 109       ((and at-pos (> (length str) at-pos))
 110        ;; Connection spec is SQL*NET format
 111        (append (delimited-string-to-list (subseq str 0 at-pos) #\/)
 112                (list (subseq str (1+ at-pos)))))
 113       (t
 114        (delimited-string-to-list str #\/)))))