`(let ((,insym ,obj))
(or ,@(mapcar #'(lambda (c) `(eql ,insym ,c))
choices)))))
+
+;; From KMRCL
+(defun substitute-char-string (procstr match-char subst-str)
+ "Substitutes a string for a single matching character of a string"
+ (substitute-chars-strings procstr (list (cons match-char subst-str))))
+
+(defun replaced-string-length (str repl-alist)
+ (declare (simple-string str)
+ (optimize (speed 3) (safety 0) (space 0)))
+ (do* ((i 0 (1+ i))
+ (orig-len (length str))
+ (new-len orig-len))
+ ((= i orig-len) new-len)
+ (declare (fixnum i orig-len new-len))
+ (let* ((c (char str i))
+ (match (assoc c repl-alist :test #'char=)))
+ (declare (character c))
+ (when match
+ (incf new-len (1- (length
+ (the simple-string (cdr match)))))))))
+
+
+(defun substitute-chars-strings (str repl-alist)
+ "Replace all instances of a chars with a string. repl-alist is an assoc
+list of characters and replacement strings."
+ (declare (simple-string str)
+ (optimize (speed 3) (safety 0) (space 0)))
+ (do* ((orig-len (length str))
+ (new-string (make-string (replaced-string-length str repl-alist)))
+ (spos 0 (1+ spos))
+ (dpos 0))
+ ((>= spos orig-len)
+ new-string)
+ (declare (fixnum spos dpos) (simple-string new-string))
+ (let* ((c (char str spos))
+ (match (assoc c repl-alist :test #'char=)))
+ (declare (character c))
+ (if match
+ (let* ((subst (cdr match))
+ (len (length subst)))
+ (declare (fixnum len)
+ (simple-string subst))
+ (dotimes (j len)
+ (declare (fixnum j))
+ (setf (char new-string dpos) (char subst j))
+ (incf dpos)))
+ (progn
+ (setf (char new-string dpos) c)
+ (incf dpos))))))
+
--- /dev/null
+# FILE IDENTIFICATION
+#
+# Name: Makefile
+# Purpose: Makefile for CLSQL SQL interface
+# Programer: Kevin M. Rosenberg
+# Date Started: Mar 2002
+#
+# CVS Id: $Id: Makefile 8153 2003-11-11 15:28:36Z kevin $
+#
+# This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
+#
+# CLSQL users are granted the rights to distribute and use this software
+# as governed by the terms of the Lisp Lesser GNU Public License
+# (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+SUBDIRS=
+
+include ../Makefile.common
+
+.PHONY: distclean
+distclean: clean
+
;; ------------------------------------------------------------
;; metaclass: view-class
-(defclass view-metaclass (standard-class)
+(defclass standard-db-class (standard-class)
((view-table
:accessor view-table
:initarg :view-table)
#+lispworks
(defmethod clos::canonicalize-defclass-slot :around
- ((prototype view-metaclass) slot)
+ ((prototype standard-db-class) slot)
"\\lw\\ signals an error on unknown slot options; so this method
removes any extra allowed options before calling the default method
and returns the canonicalized extra options concatenated to the result
#+lispworks
(defmethod clos::canonicalize-class-options :around
- ((prototype view-metaclass) class-options)
+ ((prototype standard-db-class) class-options)
"\\lw\\ signals an error on unknown class options; so this method
removes any extra allowed options before calling the default method
and returns the canonicalized extra options concatenated to the result
result))
-(defmethod validate-superclass ((class view-metaclass)
+(defmethod validate-superclass ((class standard-db-class)
(superclass standard-class))
t)
(pop-arg mylist))
newlist))
-(defmethod initialize-instance :around ((class view-metaclass)
+(defmethod initialize-instance :around ((class standard-db-class)
&rest all-keys
&key direct-superclasses base-table
schemas version qualifier
&allow-other-keys)
(let ((root-class (find-class 'standard-db-object nil))
- (vmc (find-class 'view-metaclass)))
+ (vmc (find-class 'standard-db-class)))
(setf (view-class-qualifier class)
(car qualifier))
(if root-class
(register-metaclass class (nth (1+ (position :direct-slots all-keys))
all-keys))))
-(defmethod reinitialize-instance :around ((class view-metaclass)
+(defmethod reinitialize-instance :around ((class standard-db-class)
&rest all-keys
&key base-table schemas version
direct-superclasses qualifier
&allow-other-keys)
(let ((root-class (find-class 'standard-db-object nil))
- (vmc (find-class 'view-metaclass)))
+ (vmc (find-class 'standard-db-class)))
(setf (view-table class)
(table-name-from-arg (sql-escape (or (and base-table
(if (listp base-table)
(ordered-class-slots class)))))
#+(or allegro openmcl)
-(defmethod finalize-inheritance :after ((class view-metaclass))
+(defmethod finalize-inheritance :after ((class standard-db-class))
;; KMRL for slots without a type set, openmcl sets type-predicate to ccl:false
- ;; for view-metaclass
+ ;; for standard-db-class
#+openmcl
(mapcar
#'(lambda (s)
standard-effective-slot-definition)
())
-(defmethod direct-slot-definition-class ((class view-metaclass)
+(defmethod direct-slot-definition-class ((class standard-db-class)
#+kmr-normal-dsdc &rest
initargs)
(declare (ignore initargs))
(find-class 'view-class-direct-slot-definition))
-(defmethod effective-slot-definition-class ((class view-metaclass)
+(defmethod effective-slot-definition-class ((class standard-db-class)
#+kmr-normal-esdc &rest
initargs)
(declare (ignore initargs))
(class-precedence-list class))
#-(or sbcl cmu)
-(defmethod compute-slots ((class view-metaclass))
+(defmethod compute-slots ((class standard-db-class))
"Need to sort order of class slots so they are the same across
implementations."
(let ((slots (call-next-method))
;; what kind of database value (if any) is stored there, generates and
;; verifies the column name.
-(defmethod compute-effective-slot-definition ((class view-metaclass)
+(defmethod compute-effective-slot-definition ((class standard-db-class)
#+kmr-normal-cesd slot-name
direct-slots)
#+kmr-normal-cesd (declare (ignore slot-name))
(in-package #:clsql-sys)
-;; utils
-
-(defun replaced-string-length (str repl-alist)
- (declare (simple-string str)
- (optimize (speed 3) (safety 0) (space 0)))
- (do* ((i 0 (1+ i))
- (orig-len (length str))
- (new-len orig-len))
- ((= i orig-len) new-len)
- (declare (fixnum i orig-len new-len))
- (let* ((c (char str i))
- (match (assoc c repl-alist :test #'char=)))
- (declare (character c))
- (when match
- (incf new-len (1- (length
- (the simple-string (cdr match)))))))))
-
-
-(defun substitute-chars-strings (str repl-alist)
- "Replace all instances of a chars with a string. repl-alist is an assoc
-list of characters and replacement strings."
- (declare (simple-string str)
- (optimize (speed 3) (safety 0) (space 0)))
- (do* ((orig-len (length str))
- (new-string (make-string (replaced-string-length str repl-alist)))
- (spos 0 (1+ spos))
- (dpos 0))
- ((>= spos orig-len)
- new-string)
- (declare (fixnum spos dpos) (simple-string new-string))
- (let* ((c (char str spos))
- (match (assoc c repl-alist :test #'char=)))
- (declare (character c))
- (if match
- (let* ((subst (cdr match))
- (len (length subst)))
- (declare (fixnum len)
- (simple-string subst))
- (dotimes (j len)
- (declare (fixnum j))
- (setf (char new-string dpos) (char subst j))
- (incf dpos)))
- (progn
- (setf (char new-string dpos) c)
- (incf dpos))))))
-
-(defun string-replace (procstr match-char subst-str)
- "Substitutes a string for a single matching character of a string"
- (substitute-chars-strings procstr (list (cons match-char subst-str))))
-
(defclass standard-db-object ()
((stored :db-kind :virtual
:initarg :stored
:initform nil))
- (:metaclass view-metaclass)
+ (:metaclass standard-db-class)
(:documentation "Superclass for all CLSQL View Classes."))
(defvar *deserializing* nil)
#+nil (created-object object)
(update-records-from-instance object))))
-(defmethod slot-value-using-class ((class view-metaclass) instance slot-def)
+(defmethod slot-value-using-class ((class standard-db-class) instance slot-def)
(declare (optimize (speed 3)))
(unless *deserializing*
(let ((slot-name (%slot-def-name slot-def))
(fault-join-slot class instance slot-def))))))
(call-next-method))
-(defmethod (setf slot-value-using-class) :around (new-value (class view-metaclass) instance slot-def)
+(defmethod (setf slot-value-using-class) :around (new-value (class standard-db-class) instance slot-def)
(declare (ignore new-value))
(let* ((slot-name (%slot-def-name slot-def))
(slot-kind (view-class-slot-db-kind slot-def))
;; Build the database tables required to store the given view class
;;
-(defmethod database-pkey-constraint ((class view-metaclass) database)
+(defmethod database-pkey-constraint ((class standard-db-class) database)
(let ((keylist (mapcar #'view-class-slot-column (keyslots-for-class class))))
(when keylist
(format nil "CONSTRAINT ~APK PRIMARY KEY~A"
(error "Class ~s not found." view-class-name)))
(values))
-(defmethod %install-class ((self view-metaclass) database &aux schemadef)
+(defmethod %install-class ((self standard-db-class) database &aux schemadef)
(dolist (slotdef (ordered-class-slots self))
(let ((res (database-generate-column-definition (class-name self)
slotdef database)))
superclass of the newly-defined View Class."
`(progn
(defclass ,class ,supers ,slots ,@options
- (:metaclass view-metaclass))
+ (:metaclass standard-db-class))
(finalize-inheritance (find-class ',class))))
(defun keyslots-for-class (class)
(declare (ignore database))
(progv '(*print-circle* *print-array*) '(t t)
(let ((escaped (prin1-to-string val)))
- (setf escaped (string-replace #\Null " " escaped))
- escaped)))
-
+ (clsql-base-sys::substitute-char-string
+ escaped #\Null " "))))
(defmethod database-output-sql-as-type ((type (eql 'symbol)) val database)
(declare (ignore database))
:initform nil
:initarg :view-database
:db-kind :virtual))
- (:metaclass view-metaclass)
+ (:metaclass standard-db-class)
(:documentation "Superclass for all CLSQL View Classes."))
(defmethod view-database ((self standard-db-object))
(defvar *db-deserializing* nil)
(defvar *db-initializing* nil)
-(defmethod slot-value-using-class ((class view-metaclass) instance slot)
+(defmethod slot-value-using-class ((class standard-db-class) instance slot)
(declare (optimize (speed 3)))
(unless *db-deserializing*
(let ((slot-name (%slot-name slot))
(setf (slot-value instance slot-name) nil))))))
(call-next-method))
-(defmethod (setf slot-value-using-class) (new-value (class view-metaclass)
+(defmethod (setf slot-value-using-class) (new-value (class standard-db-class)
instance slot)
(declare (ignore new-value instance slot))
(call-next-method))
;; Build the database tables required to store the given view class
;;
-(defmethod database-pkey-constraint ((class view-metaclass) database)
+(defmethod database-pkey-constraint ((class standard-db-class) database)
(let ((keylist (mapcar #'view-class-slot-column (keyslots-for-class class))))
(when keylist
(format nil "CONSTRAINT ~APK PRIMARY KEY~A"
(error "Class ~s not found." view-class-name)))
(values))
-(defmethod %install-class ((self view-metaclass) database &aux schemadef)
+(defmethod %install-class ((self standard-db-class) database &aux schemadef)
(dolist (slotdef (ordered-class-slots self))
(let ((res (database-generate-column-definition (class-name self)
slotdef database)))
superclass of the newly-defined View Class."
`(progn
(defclass ,class ,supers ,slots ,@options
- (:metaclass view-metaclass))
+ (:metaclass standard-db-class))
(finalize-inheritance (find-class ',class))))
(defun keyslots-for-class (class)
projects / clsql.git / commitdiff