;;;; 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
;;;; *************************************************************************
(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")
;;;; in Text, HTML, and XML formats. This includes hyperlinking\r
;;;; capability and sub-objects.\r
;;;;\r
-;;;; $Id: mop.lisp,v 1.76 2003/06/06 21:59:29 kevin Exp $\r
+;;;; $Id: mop.lisp,v 1.77 2003/06/20 08:35:21 kevin Exp $\r
;;;;\r
;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg\r
;;;; *************************************************************************\r
(version :initarg :version :initform nil\r
:accessor version\r
:documentation "Version number for class")\r
- (sql-name :initarg :sql-name :initform nil)\r
+ (direct-rules :initarg :direct-rules :initform nil\r
+ :accessor dirst-rules\r
+ :documentation "Rules to fire on slot changes")\r
+ (closures :initarg :closures :initform nil\r
+ :accessor closures\r
+ :documentation "Closures to call on slot chnages")\r
+ (sql-name :initarg :sql-name :accessor sql-name :initform nil\r
+ :documentation "SQL Name for this class")\r
+ (guid :initarg :guid :accessor guid :initform nil\r
+ :documentation "ID string for this class")\r
\r
;;; The remainder of these fields are calculated one time\r
;;; in finalize-inheritence.\r
(atom\r
(ensure-keyword vt))\r
(cons\r
- (cons (ensure-keyword (car vt)) (cdr vt)))\r
+ (list (ensure-keyword (car vt)) (cadr vt)))\r
(t\r
t)))\r
\r
-#+ignore\r
-(defmethod compute-effective-slot-definition :around ((cl hyperobject-class) #+ho-normal-cesd name dsds)\r
- #+allegro (declare (ignore name))\r
- (let* ((dsd (car dsds))\r
- (value-type (canonicalize-value-type (slot-value dsd 'value-type))))\r
- (multiple-value-bind (sql-type length) (value-type-to-sql-type value-type)\r
- (setf (slot-value dsd 'sql-type) sql-type)\r
- (setf (slot-value dsd 'type) (value-type-to-lisp-type value-type))\r
- (let ((ia (compute-effective-slot-definition-initargs cl #+lispworks name dsds)))\r
- (apply\r
- #'make-instance 'hyperobject-esd \r
- :value-type value-type\r
- :sql-type sql-type\r
- :length length\r
- :print-formatter (slot-value dsd 'print-formatter)\r
- :subobject (slot-value dsd 'subobject)\r
- :hyperlink (slot-value dsd 'hyperlink)\r
- :hyperlink-parameters (slot-value dsd 'hyperlink-parameters)\r
- :description (slot-value dsd 'description)\r
- :user-name (slot-value dsd 'user-name)\r
- :user-name-plural (slot-value dsd 'user-name-plural)\r
- :index (slot-value dsd 'index)\r
- :value-constraint (slot-value dsd 'value-constraint)\r
- :null-allowed (slot-value dsd 'null-allowed)\r
- ia)))))\r
-\r
-(defmethod compute-effective-slot-definition :around ((cl hyperobject-class) #+ho-normal-cesd name dsds)\r
+(defmethod compute-effective-slot-definition :around ((cl hyperobject-class)\r
+ #+ho-normal-cesd name\r
+ dsds)\r
#+ho-normal-cesd (declare (ignore name))\r
(let* ((esd (call-next-method))\r
(dsd (car dsds))\r
(value-type (canonicalize-value-type (slot-value dsd 'value-type))))\r
- (multiple-value-bind (sql-type length) (value-type-to-sql-type value-type)\r
+ (multiple-value-bind (sql-type sql-length) \r
+ (value-type-to-sql-type value-type)\r
(setf (slot-value esd 'sql-type) sql-type)\r
- (setf (slot-value esd 'length) length)\r
- (setf (slot-value esd 'type) (value-type-to-lisp-type value-type))\r
- (setf (slot-value esd 'value-type) value-type)\r
- (setf (slot-value esd 'user-name)\r
- (aif (slot-value dsd 'user-name)\r
- it\r
- (string-downcase (symbol-name (slot-definition-name dsd)))))\r
- (dolist (name '(print-formatter subobject hyperlink hyperlink-parameters\r
- description value-constraint index null-allowed))\r
- (setf (slot-value esd name) (slot-value dsd name)))\r
- esd)))\r
-\r
+ (setf (slot-value esd 'sql-length) sql-length))\r
+ (setf (slot-value esd 'type) (value-type-to-lisp-type value-type))\r
+ (setf (slot-value esd 'value-type) value-type)\r
+ (setf (slot-value esd 'user-name)\r
+ (aif (slot-value dsd 'user-name)\r
+ it\r
+ (string-downcase (symbol-name (slot-definition-name dsd)))))\r
+ (setf (slot-value esd 'sql-name)\r
+ (aif (slot-value dsd 'sql-name)\r
+ it\r
+ (lisp-name-to-sql-name (slot-definition-name dsd))))\r
+ (setf (slot-value esd 'sql-name)\r
+ (aif (slot-value dsd 'sql-name)\r
+ it\r
+ (lisp-name-to-sql-name (slot-definition-name dsd))))\r
+ (dolist (name '(print-formatter subobject hyperlink hyperlink-parameters\r
+ description value-constraint indexed null-allowed\r
+ unique short-description void-text read-only-groups\r
+ hidden-groups unit disable-predicate view-type\r
+ list-of-values stored))\r
+ (setf (slot-value esd name) (slot-value dsd name)))\r
+ esd))\r
+\r
+(defun lisp-name-to-sql-name (lisp)\r
+ "Convert a lisp name (atom or list, string or symbol) into a canonical\r
+SQL name"\r
+ (unless (stringp lisp)\r
+ (setq lisp\r
+ (typecase lisp\r
+ (symbol (symbol-name lisp))\r
+ (t (write-to-string lisp)))))\r
+ (do* ((len (length lisp))\r
+ (sql (make-string len))\r
+ (i 0 (1+ i)))\r
+ ((= i len) (string-upcase sql))\r
+ (declare (fixnum i)\r
+ (simple-string sql))\r
+ (setf (schar sql i)\r
+ (let ((c (char lisp i)))\r
+ (case c\r
+ ((#\- #\$ #\+ #\#) #\_)\r
+ (otherwise c))))))\r
\r
#+ho-normal-cesd\r
(setq cl:*features* (delete :ho-normal-cesd cl:*features*))\r
(or (eq type 'string)\r
(and (listp type) (some #'(lambda (x) (eq x 'string)) type))))\r
\r
+(defun base-value-type (value-type)\r
+ (if (atom value-type)\r
+ value-type\r
+ (car value-type)))\r
+\r
(defun value-type-to-lisp-type (value-type)\r
- (case (if (atom value-type)\r
- value-type\r
- (car value-type))\r
+ (case (base-value-type value-type)\r
((:string :cdata :varchar :char)\r
'(or null string))\r
(:character\r
'(or null fixnum))\r
(:boolean\r
'(or null boolean))\r
- (:integer\r
+ ((:integer :long-integer)\r
'(or null integer))\r
((:float :single-float)\r
'(or null single-float))\r
\r
(defun value-type-to-sql-type (value-type)\r
"Return two values, the sql type and field length."\r
- (let ((type (if (atom value-type)\r
- value-type\r
- (car value-type)))\r
+ (let ((type (base-value-type value-type))\r
(length (when (consp value-type)\r
(cadr value-type))))\r
(values\r
(case type\r
- ((:string :cdata)\r
- :string)\r
+ ((:char :character)\r
+ :char)\r
+ (:varchar\r
+ :varchar)\r
((:fixnum :integer)\r
:integer)\r
+ (:long-integer\r
+ :long-integer)\r
(:boolean\r
:boolean)\r
((:float :single-float)\r
(user-name cl))\r
2)))\r
\r
- (dolist (name '(user-name description))\r
+ (dolist (name '(user-name description version guid sql-name))\r
(awhen (slot-value cl name)\r
(setf (slot-value cl name)\r
(etypecase (slot-value cl name)\r
(cons (car it))\r
- ((or string symbol) it))))))\r
+ ((or string symbol) it)))))\r
+ \r
+ (unless (sql-name cl)\r
+ (setf (sql-name cl) (lisp-name-to-sql-name (class-name cl))))\r
+ )\r
\r
(defun finalize-documentation (cl)\r
"Calculate class documentation slot"\r
;;;; 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
;;;; *************************************************************************
(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
;;;; 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
;;;; *************************************************************************
;;;; 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"
)
(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")
(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))))
'string)
(:fixnum
'fixnum)
- (:bigint
+ (:long-integer
'integer)
(:short-float
'short-float)
;;;; 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
;;;; *************************************************************************
`(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
(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)))))
(setf (indenter view) #'indent-spaces))
(defun html-list-start-func (obj nitems indent strm)
- (write-string "<div class=\"ho-username\">" strm)
+ (write-string "<div class=\"ho-username\" :style=\"margin-left:" strm)
+ (write-fixnum (+ indent indent) strm)
+ (write-string "em;\">" strm)
(write-user-name-maybe-plural obj nitems strm)
(write-string "</div>" strm)
(write-char #\newline strm)
(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 "<html><body>~%"))
(setf (file-end-str view) (format nil "</body><html>~%"))
(setf (list-start-indent view) t)
(setf (obj-data-indent view) nil))
(defun xhtml-list-start-func (obj nitems indent strm)
- (write-string "<div class=\"ho-username\">" strm)
- (indent-html-spaces indent strm)
+ (write-string "<div class=\"ho-username\" :style=\"margin-left:" strm)
+ (write-fixnum (+ indent indent) strm)
+ (write-string "em;\">" strm)
(write-user-name-maybe-plural obj nitems strm)
(write-string "</div>" strm)
+ (write-string "<div :style=\"margin-left:" strm)
+ (write-fixnum (+ indent indent) strm)
+ (write-string "em;\">" strm)
(write-char #\newline strm))
+(defun html-obj-start (obj indent strm)
+ (declare (ignore obj indent))
+ (write-string "<div style=\"margin-left:2em;" strm))
+
(defun initialize-xhtml-view (view)
(initialize-text-view view)
- (setf (indenter view) #'indent-html-spaces)
+ (setf (indenter view) #'indent-spaces)
(setf (file-start-str view) (format nil "<html><body>~%"))
(setf (file-end-str view) (format nil "</body><html>~%"))
(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 "</div>~%"))
(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 "</div>~%"))
- (setf (obj-data-start-printer view) "<div>")
- (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)
(write-char #\newline strm))
(defun xmlformat-list-start-func (x nitems indent strm)
+ (declare (ignore indent))
(write-char #\< strm)
(write-string (class-name-of x) strm)
(write-string "list><title>" strm)
(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)
(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)
projects / hyperobject.git / commitdiff