base/utils.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:         utils.cl
   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 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 (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
  20 (in-package :clsql-base-sys)
  21
  22 (defun number-to-sql-string (num)
  23   (etypecase num
  24     (integer
  25      num)
  26     (rational
  27      (float-to-sql-string (coerce num 'double-float)))
  28     (number
  29      (float-to-sql-string num))))
  30
  31 (defun float-to-sql-string (num)
  32   "Convert exponent character for SQL"
  33   (let ((str (write-to-string num :readably t)))
  34     (cond
  35      ((find #\f str)
  36       (substitute #\e #\f str))
  37      ((find #\d str)
  38       (substitute #\e #\d str))
  39      ((find #\l str)
  40       (substitute #\e #\l str))
  41      ((find #\s str)
  42       (substitute #\e #\S str))
  43      ((find #\F str)
  44       (substitute #\e #\F str))
  45      ((find #\D str)
  46       (substitute #\e #\D str))
  47      ((find #\L str)
  48       (substitute #\e #\L str))
  49      ((find #\S str)
  50       (substitute #\e #\S str))
  51      (t
  52       str))))
  53
  54 (defun sql-escape (identifier)
  55   "Change hyphens to underscores, ensure string"
  56   (let* ((unescaped (etypecase identifier
  57                       (symbol (symbol-name identifier))
  58                       (string identifier)))
  59          (escaped (make-string (length unescaped))))
  60     (dotimes (i (length unescaped))
  61       (setf (char escaped i)
  62             (cond ((equal (char unescaped i) #\-)
  63                    #\_)
  64                   ;; ...
  65                   (t
  66                    (char unescaped i)))))
  67     escaped))
  68
  69
  70 (defun sql-escape-quotes (s)
  71   "Escape quotes for SQL string writing"
  72   (substitute-string-for-char s #\' "''"))
  73
  74 (defun substitute-string-for-char (procstr match-char subst-str)
  75 "Substitutes a string for a single matching character of a string"
  76   (let ((pos (position match-char procstr)))
  77     (if pos
  78         (concatenate 'string
  79           (subseq procstr 0 pos) subst-str
  80           (substitute-string-for-char
  81            (subseq procstr (1+ pos)) match-char subst-str))
  82       procstr)))
  83
  84