From c339a403634db7fc71308bb6da91e81af4cde1bb Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Sun, 11 Apr 2004 11:40:10 +0000 Subject: [PATCH] r8951: class rename, add missing file --- base/utils.lisp | 50 +++++++++++++++++++++++++++++++++ sql/Makefile | 22 +++++++++++++++ sql/metaclasses.lisp | 28 +++++++++--------- sql/new-objects.lisp | 67 ++++++-------------------------------------- sql/objects.lisp | 12 ++++---- 5 files changed, 100 insertions(+), 79 deletions(-) create mode 100644 sql/Makefile diff --git a/base/utils.lisp b/base/utils.lisp index c9590ec..1584104 100644 --- a/base/utils.lisp +++ b/base/utils.lisp @@ -238,3 +238,53 @@ returns (VALUES string-output error-output exit-status)" `(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)))))) + diff --git a/sql/Makefile b/sql/Makefile new file mode 100644 index 0000000..2b79dcb --- /dev/null +++ b/sql/Makefile @@ -0,0 +1,22 @@ +# 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 + diff --git a/sql/metaclasses.lisp b/sql/metaclasses.lisp index 34e6c69..af8e461 100644 --- a/sql/metaclasses.lisp +++ b/sql/metaclasses.lisp @@ -37,7 +37,7 @@ ;; ------------------------------------------------------------ ;; metaclass: view-class -(defclass view-metaclass (standard-class) +(defclass standard-db-class (standard-class) ((view-table :accessor view-table :initarg :view-table) @@ -91,7 +91,7 @@ #+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 @@ -121,7 +121,7 @@ of the default method. The extra allowed options are the value of the #+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 @@ -145,7 +145,7 @@ of the default method. The extra allowed options are the value of the result)) -(defmethod validate-superclass ((class view-metaclass) +(defmethod validate-superclass ((class standard-db-class) (superclass standard-class)) t) @@ -178,13 +178,13 @@ of the default method. The extra allowed options are the value of the (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 @@ -210,13 +210,13 @@ of the default method. The extra allowed options are the value of the (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) @@ -284,9 +284,9 @@ of the default method. The extra allowed options are the value of the (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) @@ -437,13 +437,13 @@ all NULL values retrieved are converted by DATABASE-NULL-VALUE") 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)) @@ -455,7 +455,7 @@ all NULL values retrieved are converted by DATABASE-NULL-VALUE") (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)) @@ -506,7 +506,7 @@ which does type checking before storing a value in a slot." ;; 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)) diff --git a/sql/new-objects.lisp b/sql/new-objects.lisp index e5e0614..c633de9 100644 --- a/sql/new-objects.lisp +++ b/sql/new-objects.lisp @@ -16,62 +16,12 @@ (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) @@ -86,7 +36,7 @@ list of characters and replacement strings." #+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)) @@ -98,7 +48,7 @@ list of characters and replacement strings." (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)) @@ -140,7 +90,7 @@ list of characters and replacement strings." ;; 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" @@ -196,7 +146,7 @@ the view. The argument DATABASE has a default value of (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))) @@ -271,7 +221,7 @@ SUPERS is nil then STANDARD-DB-OBJECT automatically becomes the 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) @@ -780,9 +730,8 @@ DATABASE-NULL-VALUE on the type of the slot.")) (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)) diff --git a/sql/objects.lisp b/sql/objects.lisp index 823df46..e4b0ca1 100644 --- a/sql/objects.lisp +++ b/sql/objects.lisp @@ -20,7 +20,7 @@ :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)) @@ -29,7 +29,7 @@ (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)) @@ -43,7 +43,7 @@ (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)) @@ -92,7 +92,7 @@ ;; 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" @@ -144,7 +144,7 @@ the view. The argument DATABASE has a default value of (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))) @@ -218,7 +218,7 @@ SUPERS is nil then STANDARD-DB-OBJECT automatically becomes the 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) -- 2.34.1