From 384290f4271aa9acef79d39ba86deb49ae828cbf Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Fri, 20 Jun 2003 08:35:22 +0000 Subject: [PATCH] r5167: *** empty log message *** --- metaclass.lisp | 11 ++-- mop.lisp | 133 +++++++++++++++++++++++++++++-------------------- rules.lisp | 3 +- sql.lisp | 106 ++++++++++++++------------------------- views.lisp | 40 +++++++++------ 5 files changed, 149 insertions(+), 144 deletions(-) diff --git a/metaclass.lisp b/metaclass.lisp index 814e5d9..41bd0ee 100644 --- a/metaclass.lisp +++ b/metaclass.lisp @@ -8,7 +8,7 @@ ;;;; Date Started: Apr 2000 ;;;; ;;;; -;;;; $Id: metaclass.lisp,v 1.9 2003/06/17 17:50:45 kevin Exp $ +;;;; $Id: metaclass.lisp,v 1.10 2003/06/20 08:35:21 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg ;;;; ************************************************************************* @@ -17,15 +17,16 @@ (defparameter *class-options* '(:user-name :default-print-slots :description :version :sql-name - :direct-rules) + :direct-rules :guid :version :direct-functions :direct-views) "List of class options for hyperobjects.") (defparameter *slot-options* '(:value-type :print-formatter :description :short-description :user-name - :subobject :hyperlink :hyperlink-parameters :index :inverse :unique + :subobject :hyperlink :hyperlink-parameters :indexed :inverse :unique :sql-name :null-allowed :stored :input-filter :unbound-lookup - :value-constraint :void-text) + :value-constraint :void-text :read-only-groups :hidden-groups :unit + :disable-predicate :view-type :list-of-values) "Slot options that can appear as an initarg") (defparameter *slot-options-no-initarg* - '(:ho-type :sql-type :length) + '(:ho-type :sql-type :sql-length) "Slot options that do not have an initarg") diff --git a/mop.lisp b/mop.lisp index 19e2743..3c9ac2e 100644 --- a/mop.lisp +++ b/mop.lisp @@ -11,7 +11,7 @@ ;;;; in Text, HTML, and XML formats. This includes hyperlinking ;;;; capability and sub-objects. ;;;; -;;;; $Id: mop.lisp,v 1.76 2003/06/06 21:59:29 kevin Exp $ +;;;; $Id: mop.lisp,v 1.77 2003/06/20 08:35:21 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg ;;;; ************************************************************************* @@ -37,7 +37,16 @@ (version :initarg :version :initform nil :accessor version :documentation "Version number for class") - (sql-name :initarg :sql-name :initform nil) + (direct-rules :initarg :direct-rules :initform nil + :accessor dirst-rules + :documentation "Rules to fire on slot changes") + (closures :initarg :closures :initform nil + :accessor closures + :documentation "Closures to call on slot chnages") + (sql-name :initarg :sql-name :accessor sql-name :initform nil + :documentation "SQL Name for this class") + (guid :initarg :guid :accessor guid :initform nil + :documentation "ID string for this class") ;;; The remainder of these fields are calculated one time ;;; in finalize-inheritence. @@ -212,55 +221,62 @@ (atom (ensure-keyword vt)) (cons - (cons (ensure-keyword (car vt)) (cdr vt))) + (list (ensure-keyword (car vt)) (cadr vt))) (t t))) -#+ignore -(defmethod compute-effective-slot-definition :around ((cl hyperobject-class) #+ho-normal-cesd name dsds) - #+allegro (declare (ignore name)) - (let* ((dsd (car dsds)) - (value-type (canonicalize-value-type (slot-value dsd 'value-type)))) - (multiple-value-bind (sql-type length) (value-type-to-sql-type value-type) - (setf (slot-value dsd 'sql-type) sql-type) - (setf (slot-value dsd 'type) (value-type-to-lisp-type value-type)) - (let ((ia (compute-effective-slot-definition-initargs cl #+lispworks name dsds))) - (apply - #'make-instance 'hyperobject-esd - :value-type value-type - :sql-type sql-type - :length length - :print-formatter (slot-value dsd 'print-formatter) - :subobject (slot-value dsd 'subobject) - :hyperlink (slot-value dsd 'hyperlink) - :hyperlink-parameters (slot-value dsd 'hyperlink-parameters) - :description (slot-value dsd 'description) - :user-name (slot-value dsd 'user-name) - :user-name-plural (slot-value dsd 'user-name-plural) - :index (slot-value dsd 'index) - :value-constraint (slot-value dsd 'value-constraint) - :null-allowed (slot-value dsd 'null-allowed) - ia))))) - -(defmethod compute-effective-slot-definition :around ((cl hyperobject-class) #+ho-normal-cesd name dsds) +(defmethod compute-effective-slot-definition :around ((cl hyperobject-class) + #+ho-normal-cesd name + dsds) #+ho-normal-cesd (declare (ignore name)) (let* ((esd (call-next-method)) (dsd (car dsds)) (value-type (canonicalize-value-type (slot-value dsd 'value-type)))) - (multiple-value-bind (sql-type length) (value-type-to-sql-type value-type) + (multiple-value-bind (sql-type sql-length) + (value-type-to-sql-type value-type) (setf (slot-value esd 'sql-type) sql-type) - (setf (slot-value esd 'length) length) - (setf (slot-value esd 'type) (value-type-to-lisp-type value-type)) - (setf (slot-value esd 'value-type) value-type) - (setf (slot-value esd 'user-name) - (aif (slot-value dsd 'user-name) - it - (string-downcase (symbol-name (slot-definition-name dsd))))) - (dolist (name '(print-formatter subobject hyperlink hyperlink-parameters - description value-constraint index null-allowed)) - (setf (slot-value esd name) (slot-value dsd name))) - esd))) - + (setf (slot-value esd 'sql-length) sql-length)) + (setf (slot-value esd 'type) (value-type-to-lisp-type value-type)) + (setf (slot-value esd 'value-type) value-type) + (setf (slot-value esd 'user-name) + (aif (slot-value dsd 'user-name) + it + (string-downcase (symbol-name (slot-definition-name dsd))))) + (setf (slot-value esd 'sql-name) + (aif (slot-value dsd 'sql-name) + it + (lisp-name-to-sql-name (slot-definition-name dsd)))) + (setf (slot-value esd 'sql-name) + (aif (slot-value dsd 'sql-name) + it + (lisp-name-to-sql-name (slot-definition-name dsd)))) + (dolist (name '(print-formatter subobject hyperlink hyperlink-parameters + description value-constraint indexed null-allowed + unique short-description void-text read-only-groups + hidden-groups unit disable-predicate view-type + list-of-values stored)) + (setf (slot-value esd name) (slot-value dsd name))) + esd)) + +(defun lisp-name-to-sql-name (lisp) + "Convert a lisp name (atom or list, string or symbol) into a canonical +SQL name" + (unless (stringp lisp) + (setq lisp + (typecase lisp + (symbol (symbol-name lisp)) + (t (write-to-string lisp))))) + (do* ((len (length lisp)) + (sql (make-string len)) + (i 0 (1+ i))) + ((= i len) (string-upcase sql)) + (declare (fixnum i) + (simple-string sql)) + (setf (schar sql i) + (let ((c (char lisp i))) + (case c + ((#\- #\$ #\+ #\#) #\_) + (otherwise c)))))) #+ho-normal-cesd (setq cl:*features* (delete :ho-normal-cesd cl:*features*)) @@ -273,10 +289,13 @@ (or (eq type 'string) (and (listp type) (some #'(lambda (x) (eq x 'string)) type)))) +(defun base-value-type (value-type) + (if (atom value-type) + value-type + (car value-type))) + (defun value-type-to-lisp-type (value-type) - (case (if (atom value-type) - value-type - (car value-type)) + (case (base-value-type value-type) ((:string :cdata :varchar :char) '(or null string)) (:character @@ -285,7 +304,7 @@ '(or null fixnum)) (:boolean '(or null boolean)) - (:integer + ((:integer :long-integer) '(or null integer)) ((:float :single-float) '(or null single-float)) @@ -296,17 +315,19 @@ (defun value-type-to-sql-type (value-type) "Return two values, the sql type and field length." - (let ((type (if (atom value-type) - value-type - (car value-type))) + (let ((type (base-value-type value-type)) (length (when (consp value-type) (cadr value-type)))) (values (case type - ((:string :cdata) - :string) + ((:char :character) + :char) + (:varchar + :varchar) ((:fixnum :integer) :integer) + (:long-integer + :long-integer) (:boolean :boolean) ((:float :single-float) @@ -452,12 +473,16 @@ (user-name cl)) 2))) - (dolist (name '(user-name description)) + (dolist (name '(user-name description version guid sql-name)) (awhen (slot-value cl name) (setf (slot-value cl name) (etypecase (slot-value cl name) (cons (car it)) - ((or string symbol) it)))))) + ((or string symbol) it))))) + + (unless (sql-name cl) + (setf (sql-name cl) (lisp-name-to-sql-name (class-name cl)))) + ) (defun finalize-documentation (cl) "Calculate class documentation slot" diff --git a/rules.lisp b/rules.lisp index 6a07452..336c86f 100644 --- a/rules.lisp +++ b/rules.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: rules.lisp,v 1.46 2003/06/06 21:59:29 kevin Exp $ +;;;; $Id: rules.lisp,v 1.47 2003/06/20 08:35:21 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg ;;;; ************************************************************************* @@ -25,6 +25,7 @@ (func :initform nil :initarg :func :accessor func))) (defun compile-rule (source-code dependants volatile cl) + (declare (ignore cl)) (let ((access (appendnew dependants volatile))) (compile nil (eval diff --git a/sql.lisp b/sql.lisp index 179a452..d529f67 100644 --- a/sql.lisp +++ b/sql.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: sql.lisp,v 1.6 2003/06/06 21:59:29 kevin Exp $ +;;;; $Id: sql.lisp,v 1.7 2003/06/20 08:35:21 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg ;;;; ************************************************************************* @@ -17,55 +17,20 @@ ;;;; Metaclass initialization commands (defun finalize-sql (cl) - (setf (slot-value cl 'sql-name) (sql-name cl)) (setf (slot-value cl 'drop-table-cmd) (generate-drop-table-cmd (slot-value cl 'sql-name))) (let ((esds (class-slots cl))) - (dolist (esd esds) - (setf (slot-value esd 'sql-name) (sql-name esd))) (setf (slot-value cl 'create-table-cmd) - (generate-create-table-cmd cl esds)) + (generate-create-table-cmd + cl + (remove-if #'(lambda (esd) (null (esd-stored esd))) esds))) (setf (slot-value cl 'create-indices-cmds) - (generate-create-indices-cmds (slot-value cl 'sql-name) esds)) + (generate-create-indices-cmds (sql-name cl) esds)) (dolist (esd esds) (when (slot-value esd 'inverse) (define-inverse cl esd)))) ) -(defgeneric sql-name (cl) - ) - -(defmethod sql-name ((cl hyperobject-class)) - "Return name of SQL table for a class" - (let* ((sql-name-slot (slot-value cl 'sql-name)) - (name (if (consp sql-name-slot) (car sql-name-slot) sql-name-slot)) - (lisp-name (if name name (class-name cl)))) - (lisp-name-to-sql-name lisp-name))) - -(defmethod sql-name ((esd hyperobject-esd)) - (let* ((name (slot-value esd 'sql-name)) - (lisp-name (if name name (slot-definition-name esd)))) - (lisp-name-to-sql-name lisp-name))) - -(defun lisp-name-to-sql-name (lisp) - "Convert a lisp name (atom or list, string or symbol) into a canonical -SQL name" - (unless (stringp lisp) - (setq lisp - (typecase lisp - (symbol (symbol-name lisp)) - (t (write-to-string lisp))))) - (do* ((len (length lisp)) - (sql (make-string len)) - (i 0 (1+ i))) - ((= i len) (string-upcase sql)) - (declare (fixnum i) - (simple-string sql)) - (setf (schar sql i) - (let ((c (char lisp i))) - (case c - ((#\- #\$ #\+ #\#) #\_) - (otherwise c)))))) (defun define-inverse (class esd) "Define an inverse function for a slot" @@ -80,42 +45,47 @@ SQL name" ) (defun generate-create-table-cmd (cl esds) - (let ((cmd (format nil "CREATE TABLE ~A" (slot-value cl 'sql-name))) - (subobjects (slot-value cl 'subobjects))) - (dolist (esd esds) - (unless (find (slot-definition-name esd) subobjects :key #'name-slot) - (if (eq esd (car esds)) - (string-append cmd " (") - (string-append cmd ", ")) - (string-append cmd (lisp-name-to-sql-name (slot-definition-name esd)) - " ") - (let ((length (slot-value esd 'length)) - (sql-type (slot-value esd 'sql-type))) - (string-append cmd (sql-field-cmd sql-type length))))) - (string-append cmd ")"))) - - -(defun sql-field-cmd (type length) - (case (intern (symbol-name type) (symbol-name :keyword)) + (with-output-to-string (s) + (format s "CREATE TABLE ~A (~{~A~^, ~})" + (slot-value cl 'sql-name) + (loop for esd in esds + collect + (concatenate + 'string + (slot-value esd 'sql-name) + " " + (sql-type-to-field-string (slot-value esd 'sql-type) + (slot-value esd 'sql-length))))))) + +(defun sql-type-to-field-string (type length) + (ecase type (:string (cond - ((null length) - "LONGTEXT") - ((< length 8) - (format nil "CHAR(~d)" length)) - (t - (format nil "VARCHAR(~d)" length)))) + ((null length) + "LONGTEXT") + ((< length 8) + (format nil "CHAR(~d)" length)) + (t + (format nil "VARCHAR(~d)" length)))) + (:varchar + (cond + ((null length) + "LONGTEXT") + (t + (format nil "VARCHAR(~d)" length)))) (:text "LONGTEXT") + (:datetime + "VARCHAR(20)") (:char (unless length (setq length 1)) (format nil "CHAR(~D)" length)) - (:character - "CHAR(1)") ((or :fixnum :integer) "INTEGER") - (:bigint + (:boolean + "CHAR(1)") + (:long-integer "BIGINT") ((or :short-float :float) "SINGLE") @@ -128,7 +98,7 @@ SQL name" (defun generate-create-indices-cmds (table-name slots) (let (indices) (dolist (slot slots) - (when (slot-value slot 'index) + (when (slot-value slot 'indexed) (let ((sql-name (slot-value slot 'sql-name))) (push (sql-cmd-index table-name sql-name (slot-value slot 'unique)) indices)))) @@ -233,7 +203,7 @@ SQL name" 'string) (:fixnum 'fixnum) - (:bigint + (:long-integer 'integer) (:short-float 'short-float) diff --git a/views.lisp b/views.lisp index 6776e39..ef116ac 100644 --- a/views.lisp +++ b/views.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: views.lisp,v 1.56 2003/06/17 17:50:45 kevin Exp $ +;;;; $Id: views.lisp,v 1.57 2003/06/20 08:35:21 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg ;;;; ************************************************************************* @@ -176,9 +176,8 @@ `(typecase ,v (string (write-string ,v ,s)) - #+allegro (fixnum - (excl::print-fixnum ,s 10 ,v)) + (write-fixnum ,v ,s)) (symbol (write-string (symbol-name ,v) ,s)) (t @@ -406,6 +405,7 @@ (setf (list-start-printer view) (compile nil (eval '(lambda (obj nitems indent strm) + (declare (ignore indent)) (write-user-name-maybe-plural obj nitems strm) (write-char #\: strm) (write-char #\Newline strm))))) @@ -415,7 +415,9 @@ (setf (indenter view) #'indent-spaces)) (defun html-list-start-func (obj nitems indent strm) - (write-string "
" strm) + (write-string "
" strm) (write-user-name-maybe-plural obj nitems strm) (write-string "
" strm) (write-char #\newline strm) @@ -424,7 +426,7 @@ (defun initialize-html-view (view) (initialize-text-view view) - (setf (indenter view) #'indent-html-spaces) + (setf (indenter view) #'indent-spaces) (setf (file-start-str view) (format nil "~%")) (setf (file-end-str view) (format nil "~%")) (setf (list-start-indent view) t) @@ -439,28 +441,33 @@ (setf (obj-data-indent view) nil)) (defun xhtml-list-start-func (obj nitems indent strm) - (write-string "
" strm) - (indent-html-spaces indent strm) + (write-string "
" strm) (write-user-name-maybe-plural obj nitems strm) (write-string "
" strm) + (write-string "
" strm) (write-char #\newline strm)) +(defun html-obj-start (obj indent strm) + (declare (ignore obj indent)) + (write-string "
~%")) (setf (file-end-str view) (format nil "~%")) (setf (list-start-indent view) nil) (setf (list-start-printer view) #'xhtml-list-start-func) - (setf (list-end-printer view) (format nil "~%")) + (setf (list-end-printer view) (format nil "
~%")) (setf (list-end-indent view) nil) (setf (obj-start-indent view) nil) - (setf (obj-start-printer view) nil) + (setf (obj-start-printer view) #'html-obj-start) (setf (obj-end-printer view) (format nil "
~%")) - (setf (obj-data-start-printer view) "
") - (setf (obj-data-end-printer view) nil) - (setf (obj-end-indent view) nil) - (setf (obj-data-indent view) t)) + (setf (obj-data-indent view) nil)) (defun xmlformat-list-end-func (x strm) (write-string "" strm) @@ -532,7 +540,7 @@ (awhen (obj-start-printer view) (if (stringp it) (write-string it strm) - (funcall it obj strm)))) + (funcall it obj indent strm)))) (defun fmt-obj-end (obj view strm indent) (when (obj-end-indent view) @@ -550,7 +558,7 @@ (awhen (subobj-start-printer view) (if (stringp it) (write-string it strm) - (funcall it obj strm)))) + (funcall it obj indent strm)))) (defun fmt-subobj-end (obj view strm indent) (when (subobj-end-indent view) -- 2.34.1