From: Kevin M. Rosenberg Date: Fri, 29 Nov 2002 04:10:52 +0000 (+0000) Subject: r3516: *** empty log message *** X-Git-Tag: debian-2.11.0-2~256 X-Git-Url: http://git.kpe.io/?p=hyperobject.git;a=commitdiff_plain;h=aaef96a66c4f9913e88170f241a217a49078e9a9 r3516: *** empty log message *** --- diff --git a/example-no-mop.lisp b/example-no-mop.lisp deleted file mode 100644 index f36fae2..0000000 --- a/example-no-mop.lisp +++ /dev/null @@ -1,80 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: hyperobject-plain-example.lisp -;;;; Purpose: Hyper Object Metaclass -;;;; Programmer: Kevin M. Rosenberg -;;;; Date Started: Apr 2000 -;;;; -;;;; This metaclass as functions to classes to allow display -;;;; in Text, HTML, and XML formats. This includes hyperlinking -;;;; capability and sub-objects. -;;;; -;;;; $Id: example-no-mop.lisp,v 1.1 2002/11/23 22:19:17 kevin Exp $ -;;;; -;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg -;;;; -;;;; ************************************************************************* - -(in-package :hyperobject-no-mop-user) - -(define-hyperobject person () - ((first-name :type string :reference find-person-by-last-name) - (last-name :type string) - (dob :type integer :initform 0 :print-formatter format-date) - (resume :type cdata) - (addresses :subobject t)) - (:title "Person") - (:documentation "Person hyperobject class")) - -(defun format-date (ut) - (when (typep ut 'integer) - (multiple-value-bind (sec min hr day mon year dow daylight-p zone) - (decode-universal-time ut) - (declare (ignore daylight-p zone)) - (format nil "~[Mon~;Tue~;Wed~;Thu~;Fri~;Sat~;Sun~], ~d ~[Jan~;Feb~;Mar~;Apr~;May~;Jun~;Jul~;Aug~;Sep~;Oct~;Nov~;Dec~] ~d ~2,'0d:~2,'0d:~2,'0d" - dow - day - (1- mon) - year - hr min sec)))) - -(define-hyperobject address () - ((title :type string) - (street :type string) - (phones :subobject t)) - (:title "Address") - (:documentation "Address hyperobject")) - -(define-hyperobject phone () - ((phone-number :type string)) - (:title "Phone Number") - (:documentation "Phone hyperobject")) - - -(defparameter home-phone-1 (make-instance 'phone :phone-number "367-9812")) -(defparameter home-phone-2 (make-instance 'phone :phone-number "367-9813")) - -(defparameter office-phone-1 (make-instance 'phone :phone-number "123-0001")) -(defparameter office-phone-2 (make-instance 'phone :phone-number "123-0002")) -(defparameter office-phone-3 (make-instance 'phone :phone-number "123-0005")) - -(defparameter home (make-instance 'address :title "Home" :street "321 Shady Lane" - :phones (list home-phone-1 home-phone-2))) - -(defparameter office (make-instance 'address :title "Office" :street "113 Main St." - :phones (list office-phone-1 office-phone-2 office-phone-3))) - - -(defparameter mary (make-instance 'person :first-name "Mary" :last-name "Jackson" - :dob (get-universal-time) - :addresses (list home office) - :resume "Style & Grace")) - - -(format t "~&Text Format~%") -(print-hyperobject mary :subobjects t) - -(format t "~&XML Format with field labels and hyperlinks~%") -(print-hyperobject mary :subobjects t :label t :format :xmlref) diff --git a/example.lisp b/example.lisp deleted file mode 100644 index e16bba5..0000000 --- a/example.lisp +++ /dev/null @@ -1,90 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: hyperobject-example.lisp -;;;; Purpose: Hyperobject Example file -;;;; Programmer: Kevin M. Rosenberg -;;;; Date Started: Oct 2002 -;;;; -;;;; A simple example file for hyperobjects -;;;; -;;;; $Id: example.lisp,v 1.6 2002/11/24 17:47:50 kevin Exp $ -;;;; -;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg -;;;; -;;;; ************************************************************************* - -(in-package :hyperobject-user) - - -(defclass person (hyperobject) - ((first-name :type string :initarg :first-name :reader first-name) - (last-name :type string :initarg :last-name :reader last-name - :reference find-person-by-last-name) - (dob :type integer :initarg :dob :reader dob :print-formatter format-date) - (resume :type cdata :initarg :resume :reader resume) - (addresses :initarg :addresses :reader addresses :subobject t)) - (:metaclass hyperobject-class) - (:default-initargs :first-name nil :last-name nil :dob 0 :resume nil) - (:print-slots first-name last-name dob resume) - (:title "Person") - (:description "A Person")) - -(defun format-date (ut) - (when (typep ut 'integer) - (multiple-value-bind (sec min hr day mon year dow daylight-p zone) - (decode-universal-time ut) - (declare (ignore daylight-p zone)) - (format nil "~[Mon~;Tue~;Wed~;Thu~;Fri~;Sat~;Sun~], ~d ~[Jan~;Feb~;Mar~;Apr~;May~;Jun~;Jul~;Aug~;Sep~;Oct~;Nov~;Dec~] ~d ~2,'0d:~2,'0d:~2,'0d" - dow - day - (1- mon) - year - hr min sec)))) - -(defclass address (hyperobject) - ((title :type string :initarg :title :reader title) - (street :type string :initarg :street :reader street) - (phones :initarg :phones :reader phones :subobject t)) - (:metaclass hyperobject-class) - (:default-initargs :title nil :street nil) - (:title "Address") - (:print-slots title street) - (:description "An address")) - -(defclass phone (hyperobject) - ((title :type string :initarg :title :reader title) - (phone-number :type string :initarg :phone-number :reader phone-number)) - (:metaclass hyperobject-class) - (:title "Phone Number") - (:default-initargs :title nil :phone-number nil) - (:print-slots title phone-number) - (:description "A phone number")) - - -(defparameter home-phone-1 (make-instance 'phone :title "Voice" :phone-number "367-9812")) -(defparameter home-phone-2 (make-instance 'phone :title "Fax" :phone-number "367-9813")) - -(defparameter office-phone-1 (make-instance 'phone :title "Main line" :phone-number "123-0001")) -(defparameter office-phone-2 (make-instance 'phone :title "Staff line" :phone-number "123-0002")) -(defparameter office-phone-3 (make-instance 'phone :title "Fax" :phone-number "123-0005")) - -(defparameter home (make-instance 'address :title "Home" :street "321 Shady Lane" - :phones (list home-phone-1 home-phone-2))) - -(defparameter office (make-instance 'address :title "Office" :street "113 Main St." - :phones (list office-phone-1 office-phone-2 office-phone-3))) - - -(defparameter mary (make-instance 'person :first-name "Mary" :last-name "Jackson" - :dob (get-universal-time) - :addresses (list home office) - :resume "Style & Grace")) - - -(format t "~&Text Format~%") -(print-hyperobject mary :subobjects t) - -(format t "~&XML Format with field labels and hyperlinks~%") -(print-hyperobject mary :subobjects t :label t :format :xmlref) diff --git a/hyperobject.asd b/hyperobject.asd index 2e0bc22..e26fe0e 100644 --- a/hyperobject.asd +++ b/hyperobject.asd @@ -7,25 +7,22 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: hyperobject.asd,v 1.8 2002/11/25 04:47:23 kevin Exp $ +;;;; $Id: hyperobject.asd,v 1.9 2002/11/29 04:07:52 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; ************************************************************************* (in-package :asdf) +#+(or allegro lispworks sbcl cmu scl) (defsystem :hyperobject :perform (load-op :after (op hyperobject) (pushnew :hyperobject cl:*features*)) :components ((:file "package") - #+(or allegro lispworks sbcl cmu scl) - (:file "hyperobject" :depends-on ("package")) - #+(or allegro lispworks sbcl cmu scl) - (:file "views" :depends-on ("hyperobject")) - #+(or allegro lispworks sbcl cmu scl) + (:file "mop" :depends-on ("package")) + (:file "views" :depends-on ("mop")) (:file "base-class" :depends-on ("views")) - (:file "hyperobject-no-mop" :depends-on ("package")) ) :depends-on (:kmrcl)) diff --git a/hyperobject.lisp b/hyperobject.lisp deleted file mode 100644 index 8f585f0..0000000 --- a/hyperobject.lisp +++ /dev/null @@ -1,449 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: hyperobject.lisp -;;;; Purpose: Hyper Object Metaclass -;;;; Programmer: Kevin M. Rosenberg -;;;; Date Started: Apr 2000 -;;;; -;;;; This metaclass as functions to classes to allow display -;;;; in Text, HTML, and XML formats. This includes hyperlinking -;;;; capability and sub-objects. -;;;; -;;;; $Id: hyperobject.lisp,v 1.17 2002/11/26 21:51:10 kevin Exp $ -;;;; -;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg -;;;; -;;;; ************************************************************************* - -(in-package :hyperobject) - -(eval-when (:compile-toplevel :execute) - (declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3)))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (shadowing-import - #+allegro - `(mop::class-slots mop::slot-definition-name mop:finalize-inheritance - mop::standard-direct-slot-definition mop::standard-effective-slot-definition - mop:direct-slot-definition-class mop:compute-effective-slot-definition - excl::compute-effective-slot-definition-initargs) - #+lispworks - `(clos:class-slots clos::slot-definition-name clos:finalize-inheritance - clos::standard-direct-slot-definition clos::standard-effective-slot-definition - clos:direct-slot-definition-class clos:compute-effective-slot-definition - clos::compute-effective-slot-definition-initargs) - #+sbcl - `(sb-pcl:class-of sb-pcl:class-name sb-pcl:class-slots sb-pcl::standard-class - sb-pcl::slot-definition-name sb-pcl:finalize-inheritance - sb-pcl::standard-direct-slot-definition - sb-pcl::standard-effective-slot-definition sb-pcl::validate-superclass - sb-pcl:direct-slot-definition-class sb-pcl:compute-effective-slot-definition - sb-pcl::compute-effective-slot-definition-initargs) - #+cmu - `(pcl:class-of pcl:class-name pcl:class-slots pcl::standard-class - pcl::slot-definition-name pcl:finalize-inheritance - pcl::standard-direct-slot-definition pcl::standard-effective-slot-definition - pcl::validate-superclass pcl:direct-slot-definition-class - pcl:compute-effective-slot-definition - pcl::compute-effective-slot-definition-initargs) - #+scl - `(class-of class-name clos:class-slots clos::standard-class - clos::slot-definition-name clos:finalize-inheritance - clos::standard-direct-slot-definition clos::standard-effective-slot-definition - clos::validate-superclass clos:direct-slot-definition-class - clos:compute-effective-slot-definition - clos::compute-effective-slot-definition-initargs) - - :hyperobject)) - - -;; Main class - -(defclass hyperobject-class (standard-class) - ( ;; slots initialized in defclass - (title :initarg :title :type string :initform nil - :documentation "Print Title for class") - (print-slots :initarg :print-slots :type list :initform nil - :documentation "List of slots to print") - (description :initarg :description :initform nil - :documentation "Class description") - (version :initarg :version :initform nil - :documentation "Version number for class") - - ;;; The remainder of these fields are calculated one time - ;;; in finalize-inheritence. - - (subobjects :initform nil :documentation - "List of fields that contain a list of subobjects objects.") - (references :type list :initform nil :documentation - "List of fields that have references") - (class-id :type integer :initform nil :documentation - "Unique ID for the class") - - (value-func :initform nil :type function) - (xmlvalue-func :initform nil :type function) - (fmtstr-text :initform nil :type string) - (fmtstr-html :initform nil :type string) - (fmtstr-xml :initform nil :type string) - (fmtstr-text-labels :initform nil :type string) - (fmtstr-html-labels :initform nil :type string) - (fmtstr-xml-labels :initform nil :type string) - (fmtstr-html-ref :initform nil :type string) - (fmtstr-xml-ref :initform nil :type string) - (fmtstr-html-ref-labels :initform nil :type string) - (fmtstr-xml-ref-labels :initform nil :type string) - ) - (:documentation "Metaclass for Markup Language classes.")) - -(defclass subobject () - ((name :type symbol :initform nil :initarg :name :reader name) - (reader :type function :initform nil :initarg :reader :reader reader))) - -(defmethod print-object ((obj subobject) (s stream)) - (print-unreadable-object (obj s :type t :identity t) - (format s "~S" (name obj)))) - -(defclass reference () - ((name :type symbol :initform nil :initarg :name :reader name) - (lookup :type function :initform nil :initarg :lookup :reader lookup) - (link-parameters :type list :initform nil :initarg :link-parameters - :reader link-parameters))) - -(defmethod print-object ((obj reference) (s stream)) - (print-unreadable-object (obj s :type t :identity t) - (format s "~S" (name obj)))) - -#+(or cmu scl sbcl) -(defmethod validate-superclass ((class hyperobject-class) (superclass standard-class)) - t) - -(defmethod finalize-inheritance :after ((cl hyperobject-class)) - (init-hyperobject-class cl)) - -;; Slot definitions -(defmethod direct-slot-definition-class ((cl hyperobject-class) - #+allegro &rest - iargs) - (find-class 'hyperobject-dsd)) - - -; Slot definitions - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defmacro process-class-option (slot-name &optional required) - #+lispworks - `(defmethod clos:process-a-class-option ((class hyperobject-class) - (name (eql ,slot-name)) - value) - (when (and ,required (null value)) - (error "hyperobject class slot ~A must have a value" name)) - (list name `',value)) - #+(or allegro sbcl cmu scl) - (declare (ignore slot-name required)) - ) - - (defmacro process-slot-option (slot-name) - #+lispworks - `(defmethod clos:process-a-slot-option ((class hyperobject-class) - (option (eql ,slot-name)) - value - already-processed-other-options - slot) - (list option `',value)) - #-lispworks - (declare (ignore slot-name)) - ) - - (defparameter *class-options* - '(:title :print-slots :description :version :sql-name) - "List of class options for hyperobjects.") - (defparameter *slot-options* - '(:print-formatter :subobject :reference :description :unique :sql-name) - "List of slot options that can appear as an initarg") - (defparameter *slot-options-no-initarg* - '(:ho-type) - "List of slot options that do not have an initarg") - - (dolist (option *class-options*) - (eval `(process-class-option ,option))) - (dolist (option *slot-options*) - (eval `(process-slot-option ,option))) - - (eval - `(defclass hyperobject-dsd (standard-direct-slot-definition) - (,@(mapcar #'(lambda (x) - `(,(intern (symbol-name x)) - :initform nil)) - *slot-options-no-initarg*) - ,@(mapcar #'(lambda (x) - `(,(intern (symbol-name x)) - :initarg - ,(intern (symbol-name x) (symbol-name :keyword)) - :initform nil)) - *slot-options*)))) - (eval - `(defclass hyperobject-esd (standard-effective-slot-definition) - (,@(mapcar #'(lambda (x) - `(,(intern (symbol-name x)) - :initarg - ,(intern (symbol-name x) (symbol-name :keyword)) - :initform nil)) - (append *slot-options* *slot-options-no-initarg*))))) - ) ;; eval-when - -(defmethod compute-effective-slot-definition :around - ((cl hyperobject-class) #+(or allegro lispworks) name dsds) - #+allergo (declare (ignore name)) - (let* ((dsd (car dsds)) - (ho-type (slot-value dsd 'type))) - (setf (slot-value dsd 'ho-type) ho-type) - (setf (slot-value dsd 'type) (convert-ho-type ho-type)) - (let ((ia (compute-effective-slot-definition-initargs - cl #+lispworks name dsds))) - (apply - #'make-instance 'hyperobject-esd - :ho-type ho-type - :print-formatter (slot-value dsd 'print-formatter) - :subobject (slot-value dsd 'subobject) - :reference (slot-value dsd 'reference) - :description (slot-value dsd 'description) - ia))) - ) - -(defun convert-ho-type (ho-type) - (check-type ho-type symbol) - (case (intern (symbol-name ho-type) (symbol-name :keyword)) - (:string - 'string) - (:fixnum - 'fixnum) - (:boolean - 'boolean) - (:integer - 'integer) - (:cdata - 'string) - (:float - 'float) - (:nil - t) - (otherwise - ho-type))) - -;;;; Class initialization function - -(defun find-slot-by-name (cl name) - (find name (class-slots cl) :key #'slot-definition-name)) - - -(defun process-subobjects (cl) - "Process class subobjects slot" - (setf (slot-value cl 'subobjects) - (let ((subobjects '())) - (dolist (slot (class-slots cl)) - (when (slot-value slot 'subobject) - (push (make-instance 'subobject :name (slot-definition-name slot) - :reader (if (eq t (slot-value slot 'subobject)) - (slot-definition-name slot) - (slot-value slot 'subobject))) - subobjects))) - subobjects))) - -(defun process-documentation (cl) - "Calculate class documentation slot" - (awhen (slot-value cl 'title) - (setf (slot-value cl 'title) (car it))) - (awhen (slot-value cl 'description) - (setf (slot-value cl 'description) (car it))) - - (let ((*print-circle* nil)) - (setf (documentation (class-name cl) 'class) - (format nil "Hyperobject~A~A~A~A" - (aif (slot-value cl 'title) - (format nil ": ~A" it "")) - (aif (slot-value cl 'description) - (format nil "~%Class description: ~A" it) "") - (aif (slot-value cl 'subobjects) - (format nil "~%Subobjects:~{ ~A~}" (mapcar #'name it)) "") - (aif (slot-value cl 'print-slots) - (format nil "~%Print-slots:~{ ~A~}" it) "") - )))) - -(defun process-views (cl) - "Calculate all view slots for a hyperobject class" - (let ((fmtstr-text "") - (fmtstr-html "") - (fmtstr-xml "") - (fmtstr-text-labels "") - (fmtstr-html-labels "") - (fmtstr-xml-labels "") - (fmtstr-html-ref "") - (fmtstr-xml-ref "") - (fmtstr-html-ref-labels "") - (fmtstr-xml-ref-labels "") - (first-field t) - (value-func '()) - (xmlvalue-func '()) - (classname (class-name cl)) - (package (symbol-package (class-name cl))) - (references nil)) - (declare (ignore classname)) - (check-type (slot-value cl 'print-slots) list) - (dolist (slot-name (slot-value cl 'print-slots)) - (let ((slot (find-slot-by-name cl slot-name))) - (unless slot - (error "Slot ~A is not found in class ~S" slot-name cl)) - (let ((name (slot-definition-name slot)) - (namestr (symbol-name (slot-definition-name slot))) - (namestr-lower (string-downcase (symbol-name (slot-definition-name slot)))) - (type (slot-value slot 'ho-type)) - (print-formatter (slot-value slot 'print-formatter)) - (value-fmt "~a") - (plain-value-func nil) - html-str xml-str html-label-str xml-label-str) - - (when (or (eql type :integer) (eql type :fixnum)) - (setq value-fmt "~d")) - - (when (eql type :boolean) - (setq value-fmt "~a")) - - (if first-field - (setq first-field nil) - (progn - (string-append fmtstr-text " ") - (string-append fmtstr-html " ") - (string-append fmtstr-xml " ") - (string-append fmtstr-text-labels " ") - (string-append fmtstr-html-labels " ") - (string-append fmtstr-xml-labels " ") - (string-append fmtstr-html-ref " ") - (string-append fmtstr-xml-ref " ") - (string-append fmtstr-html-ref-labels " ") - (string-append fmtstr-xml-ref-labels " "))) - - (setq html-str (concatenate 'string "" value-fmt "")) - (setq xml-str (concatenate 'string "<" namestr-lower ">" value-fmt "")) - (setq html-label-str (concatenate 'string "" namestr-lower " " value-fmt "")) - (setq xml-label-str (concatenate 'string " <" namestr-lower ">" value-fmt "")) - - (string-append fmtstr-text value-fmt) - (string-append fmtstr-html html-str) - (string-append fmtstr-xml xml-str) - (string-append fmtstr-text-labels namestr-lower " " value-fmt) - (string-append fmtstr-html-labels html-label-str) - (string-append fmtstr-xml-labels xml-label-str) - - (if (slot-value slot 'reference) - (progn - (string-append fmtstr-html-ref "<~~a>" value-fmt "") - (string-append fmtstr-xml-ref "<~~a>" value-fmt "") - (string-append fmtstr-html-ref-labels "" namestr-lower " <~~a>" value-fmt "") - (string-append fmtstr-xml-ref-labels " <~~a>" value-fmt "") - (push (make-instance 'reference :name name - :lookup (slot-value slot 'reference)) - references)) - (progn - (string-append fmtstr-html-ref html-str) - (string-append fmtstr-xml-ref xml-str) - (string-append fmtstr-html-ref-labels html-label-str) - (string-append fmtstr-xml-ref-labels xml-label-str))) - - (if print-formatter - (setq plain-value-func - (list `(,print-formatter (slot-value x ',(intern namestr package))))) - (setq plain-value-func - (list `(slot-value x ',(intern namestr package))))) - (setq value-func (append value-func plain-value-func)) - - (if (eql type :cdata) - (setq xmlvalue-func (append xmlvalue-func (list `(xml-cdata ,@plain-value-func)))) - (setq xmlvalue-func (append xmlvalue-func plain-value-func))) - ))) - - (setf (slot-value cl 'references) references) - - (if value-func - (setq value-func `(lambda (x) (values ,@value-func))) - (setq value-func `(lambda () (values)))) - (setq value-func (compile nil (eval value-func))) - - (if xmlvalue-func - (setq xmlvalue-func `(lambda (x) (values ,@xmlvalue-func))) - (setq xmlvalue-func `(lambda () (values)))) - (setq xmlvalue-func (compile nil (eval xmlvalue-func))) - - (setf (slot-value cl 'fmtstr-text) fmtstr-text) - (setf (slot-value cl 'fmtstr-html) fmtstr-html) - (setf (slot-value cl 'fmtstr-xml) fmtstr-xml) - (setf (slot-value cl 'fmtstr-text-labels) fmtstr-text-labels) - (setf (slot-value cl 'fmtstr-html-labels) fmtstr-html-labels) - (setf (slot-value cl 'fmtstr-xml-labels) fmtstr-xml-labels) - (setf (slot-value cl 'fmtstr-html-ref) fmtstr-html-ref) - (setf (slot-value cl 'fmtstr-xml-ref) fmtstr-xml-ref) - (setf (slot-value cl 'fmtstr-html-ref-labels) fmtstr-html-ref-labels) - (setf (slot-value cl 'fmtstr-xml-ref-labels) fmtstr-xml-ref-labels) - (setf (slot-value cl 'value-func) value-func) - (setf (slot-value cl 'xmlvalue-func) xmlvalue-func)) - (values)) - -(defun init-hyperobject-class (cl) - "Initialize a hyperobject class. Calculates all class slots" - (process-subobjects cl) - (process-views cl) - (process-documentation cl)) - -(defun hyperobject-class-fmtstr-text (obj) - (slot-value (class-of obj) 'fmtstr-text)) - -(defun hyperobject-class-fmtstr-html (obj) - (slot-value (class-of obj) 'fmtstr-html)) - -(defun hyperobject-class-fmtstr-xml (obj) - (slot-value (class-of obj) 'fmtstr-xml)) - -(defun hyperobject-class-fmtstr-text-labels (obj) - (slot-value (class-of obj) 'fmtstr-text-labels)) - -(defun hyperobject-class-fmtstr-html-labels (obj) - (slot-value (class-of obj) 'fmtstr-html-labels)) - -(defun hyperobject-class-fmtstr-xml-labels (obj) - (slot-value (class-of obj) 'fmtstr-xml-labels)) - -(defun hyperobject-class-value-func (obj) - (slot-value (class-of obj) 'value-func)) - -(defun hyperobject-class-xmlvalue-func (obj) - (slot-value (class-of obj) 'xmlvalue-func)) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defun hyperobject-class-title (obj) - (awhen (slot-value (class-of obj) 'title) - (if (consp it) - (car it) - it)))) - -(defun hyperobject-class-subobjects (obj) - (slot-value (class-of obj) 'subobjects)) - -(defun hyperobject-class-references (obj) - (slot-value (class-of obj) 'references)) - -(defun hyperobject-class-fields (obj) - (class-slots (class-of obj))) - -(defun hyperobject-class-fmtstr-html-ref (obj) - (slot-value (class-of obj) 'fmtstr-html-ref)) - -(defun hyperobject-class-fmtstr-xml-ref (obj) - (slot-value (class-of obj) 'fmtstr-xml-ref)) - -(defun hyperobject-class-fmtstr-html-ref-labels (obj) - (slot-value (class-of obj) 'fmtstr-html-ref-labels)) - -(defun hyperobject-class-fmtstr-xml-ref-labels (obj) - (slot-value (class-of obj) 'fmtstr-xml-ref-labels)) - diff --git a/mop.lisp b/mop.lisp new file mode 100644 index 0000000..151baf2 --- /dev/null +++ b/mop.lisp @@ -0,0 +1,449 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: hyperobject.lisp +;;;; Purpose: Hyper Object Metaclass +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Apr 2000 +;;;; +;;;; This metaclass as functions to classes to allow display +;;;; in Text, HTML, and XML formats. This includes hyperlinking +;;;; capability and sub-objects. +;;;; +;;;; $Id: mop.lisp,v 1.1 2002/11/29 04:07:52 kevin Exp $ +;;;; +;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg +;;;; +;;;; ************************************************************************* + +(in-package :hyperobject) + +(eval-when (:compile-toplevel :execute) + (declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3)))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (shadowing-import + #+allegro + `(mop::class-slots mop::slot-definition-name mop:finalize-inheritance + mop::standard-direct-slot-definition mop::standard-effective-slot-definition + mop:direct-slot-definition-class mop:compute-effective-slot-definition + excl::compute-effective-slot-definition-initargs) + #+lispworks + `(clos:class-slots clos::slot-definition-name clos:finalize-inheritance + clos::standard-direct-slot-definition clos::standard-effective-slot-definition + clos:direct-slot-definition-class clos:compute-effective-slot-definition + clos::compute-effective-slot-definition-initargs) + #+sbcl + `(sb-pcl:class-of sb-pcl:class-name sb-pcl:class-slots sb-pcl::standard-class + sb-pcl::slot-definition-name sb-pcl:finalize-inheritance + sb-pcl::standard-direct-slot-definition + sb-pcl::standard-effective-slot-definition sb-pcl::validate-superclass + sb-pcl:direct-slot-definition-class sb-pcl:compute-effective-slot-definition + sb-pcl::compute-effective-slot-definition-initargs) + #+cmu + `(pcl:class-of pcl:class-name pcl:class-slots pcl::standard-class + pcl::slot-definition-name pcl:finalize-inheritance + pcl::standard-direct-slot-definition pcl::standard-effective-slot-definition + pcl::validate-superclass pcl:direct-slot-definition-class + pcl:compute-effective-slot-definition + pcl::compute-effective-slot-definition-initargs) + #+scl + `(class-of class-name clos:class-slots clos::standard-class + clos::slot-definition-name clos:finalize-inheritance + clos::standard-direct-slot-definition clos::standard-effective-slot-definition + clos::validate-superclass clos:direct-slot-definition-class + clos:compute-effective-slot-definition + clos::compute-effective-slot-definition-initargs) + + :hyperobject)) + + +;; Main class + +(defclass hyperobject-class (standard-class) + ( ;; slots initialized in defclass + (title :initarg :title :type string :initform nil + :documentation "Print Title for class") + (print-slots :initarg :print-slots :type list :initform nil + :documentation "List of slots to print") + (description :initarg :description :initform nil + :documentation "Class description") + (version :initarg :version :initform nil + :documentation "Version number for class") + + ;;; The remainder of these fields are calculated one time + ;;; in finalize-inheritence. + + (subobjects :initform nil :documentation + "List of fields that contain a list of subobjects objects.") + (references :type list :initform nil :documentation + "List of fields that have references") + (class-id :type integer :initform nil :documentation + "Unique ID for the class") + + (value-func :initform nil :type function) + (xmlvalue-func :initform nil :type function) + (fmtstr-text :initform nil :type string) + (fmtstr-html :initform nil :type string) + (fmtstr-xml :initform nil :type string) + (fmtstr-text-labels :initform nil :type string) + (fmtstr-html-labels :initform nil :type string) + (fmtstr-xml-labels :initform nil :type string) + (fmtstr-html-ref :initform nil :type string) + (fmtstr-xml-ref :initform nil :type string) + (fmtstr-html-ref-labels :initform nil :type string) + (fmtstr-xml-ref-labels :initform nil :type string) + ) + (:documentation "Metaclass for Markup Language classes.")) + +(defclass subobject () + ((name :type symbol :initform nil :initarg :name :reader name) + (reader :type function :initform nil :initarg :reader :reader reader))) + +(defmethod print-object ((obj subobject) (s stream)) + (print-unreadable-object (obj s :type t :identity t) + (format s "~S" (name obj)))) + +(defclass reference () + ((name :type symbol :initform nil :initarg :name :reader name) + (lookup :type function :initform nil :initarg :lookup :reader lookup) + (link-parameters :type list :initform nil :initarg :link-parameters + :reader link-parameters))) + +(defmethod print-object ((obj reference) (s stream)) + (print-unreadable-object (obj s :type t :identity t) + (format s "~S" (name obj)))) + +#+(or cmu scl sbcl) +(defmethod validate-superclass ((class hyperobject-class) (superclass standard-class)) + t) + +(defmethod finalize-inheritance :after ((cl hyperobject-class)) + (init-hyperobject-class cl)) + +;; Slot definitions +(defmethod direct-slot-definition-class ((cl hyperobject-class) + #+allegro &rest + iargs) + (find-class 'hyperobject-dsd)) + + +; Slot definitions + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defmacro process-class-option (slot-name &optional required) + #+lispworks + `(defmethod clos:process-a-class-option ((class hyperobject-class) + (name (eql ,slot-name)) + value) + (when (and ,required (null value)) + (error "hyperobject class slot ~A must have a value" name)) + (list name `',value)) + #+(or allegro sbcl cmu scl) + (declare (ignore slot-name required)) + ) + + (defmacro process-slot-option (slot-name) + #+lispworks + `(defmethod clos:process-a-slot-option ((class hyperobject-class) + (option (eql ,slot-name)) + value + already-processed-other-options + slot) + (list option `',value)) + #-lispworks + (declare (ignore slot-name)) + ) + + (defparameter *class-options* + '(:title :print-slots :description :version :sql-name) + "List of class options for hyperobjects.") + (defparameter *slot-options* + '(:print-formatter :subobject :reference :description :unique :sql-name) + "List of slot options that can appear as an initarg") + (defparameter *slot-options-no-initarg* + '(:ho-type) + "List of slot options that do not have an initarg") + + (dolist (option *class-options*) + (eval `(process-class-option ,option))) + (dolist (option *slot-options*) + (eval `(process-slot-option ,option))) + + (eval + `(defclass hyperobject-dsd (standard-direct-slot-definition) + (,@(mapcar #'(lambda (x) + `(,(intern (symbol-name x)) + :initform nil)) + *slot-options-no-initarg*) + ,@(mapcar #'(lambda (x) + `(,(intern (symbol-name x)) + :initarg + ,(intern (symbol-name x) (symbol-name :keyword)) + :initform nil)) + *slot-options*)))) + (eval + `(defclass hyperobject-esd (standard-effective-slot-definition) + (,@(mapcar #'(lambda (x) + `(,(intern (symbol-name x)) + :initarg + ,(intern (symbol-name x) (symbol-name :keyword)) + :initform nil)) + (append *slot-options* *slot-options-no-initarg*))))) + ) ;; eval-when + +(defmethod compute-effective-slot-definition :around + ((cl hyperobject-class) #+(or allegro lispworks) name dsds) + #+allergo (declare (ignore name)) + (let* ((dsd (car dsds)) + (ho-type (slot-value dsd 'type))) + (setf (slot-value dsd 'ho-type) ho-type) + (setf (slot-value dsd 'type) (convert-ho-type ho-type)) + (let ((ia (compute-effective-slot-definition-initargs + cl #+lispworks name dsds))) + (apply + #'make-instance 'hyperobject-esd + :ho-type ho-type + :print-formatter (slot-value dsd 'print-formatter) + :subobject (slot-value dsd 'subobject) + :reference (slot-value dsd 'reference) + :description (slot-value dsd 'description) + ia))) + ) + +(defun convert-ho-type (ho-type) + (check-type ho-type symbol) + (case (intern (symbol-name ho-type) (symbol-name :keyword)) + (:string + 'string) + (:fixnum + 'fixnum) + (:boolean + 'boolean) + (:integer + 'integer) + (:cdata + 'string) + (:float + 'float) + (:nil + t) + (otherwise + ho-type))) + +;;;; Class initialization function + +(defun find-slot-by-name (cl name) + (find name (class-slots cl) :key #'slot-definition-name)) + + +(defun process-subobjects (cl) + "Process class subobjects slot" + (setf (slot-value cl 'subobjects) + (let ((subobjects '())) + (dolist (slot (class-slots cl)) + (when (slot-value slot 'subobject) + (push (make-instance 'subobject :name (slot-definition-name slot) + :reader (if (eq t (slot-value slot 'subobject)) + (slot-definition-name slot) + (slot-value slot 'subobject))) + subobjects))) + subobjects))) + +(defun process-documentation (cl) + "Calculate class documentation slot" + (awhen (slot-value cl 'title) + (setf (slot-value cl 'title) (car it))) + (awhen (slot-value cl 'description) + (setf (slot-value cl 'description) (car it))) + + (let ((*print-circle* nil)) + (setf (documentation (class-name cl) 'class) + (format nil "Hyperobject~A~A~A~A" + (aif (slot-value cl 'title) + (format nil ": ~A" it "")) + (aif (slot-value cl 'description) + (format nil "~%Class description: ~A" it) "") + (aif (slot-value cl 'subobjects) + (format nil "~%Subobjects:~{ ~A~}" (mapcar #'name it)) "") + (aif (slot-value cl 'print-slots) + (format nil "~%Print-slots:~{ ~A~}" it) "") + )))) + +(defun process-views (cl) + "Calculate all view slots for a hyperobject class" + (let ((fmtstr-text "") + (fmtstr-html "") + (fmtstr-xml "") + (fmtstr-text-labels "") + (fmtstr-html-labels "") + (fmtstr-xml-labels "") + (fmtstr-html-ref "") + (fmtstr-xml-ref "") + (fmtstr-html-ref-labels "") + (fmtstr-xml-ref-labels "") + (first-field t) + (value-func '()) + (xmlvalue-func '()) + (classname (class-name cl)) + (package (symbol-package (class-name cl))) + (references nil)) + (declare (ignore classname)) + (check-type (slot-value cl 'print-slots) list) + (dolist (slot-name (slot-value cl 'print-slots)) + (let ((slot (find-slot-by-name cl slot-name))) + (unless slot + (error "Slot ~A is not found in class ~S" slot-name cl)) + (let ((name (slot-definition-name slot)) + (namestr (symbol-name (slot-definition-name slot))) + (namestr-lower (string-downcase (symbol-name (slot-definition-name slot)))) + (type (slot-value slot 'ho-type)) + (print-formatter (slot-value slot 'print-formatter)) + (value-fmt "~a") + (plain-value-func nil) + html-str xml-str html-label-str xml-label-str) + + (when (or (eql type :integer) (eql type :fixnum)) + (setq value-fmt "~d")) + + (when (eql type :boolean) + (setq value-fmt "~a")) + + (if first-field + (setq first-field nil) + (progn + (string-append fmtstr-text " ") + (string-append fmtstr-html " ") + (string-append fmtstr-xml " ") + (string-append fmtstr-text-labels " ") + (string-append fmtstr-html-labels " ") + (string-append fmtstr-xml-labels " ") + (string-append fmtstr-html-ref " ") + (string-append fmtstr-xml-ref " ") + (string-append fmtstr-html-ref-labels " ") + (string-append fmtstr-xml-ref-labels " "))) + + (setq html-str (concatenate 'string "" value-fmt "")) + (setq xml-str (concatenate 'string "<" namestr-lower ">" value-fmt "")) + (setq html-label-str (concatenate 'string "" namestr-lower " " value-fmt "")) + (setq xml-label-str (concatenate 'string " <" namestr-lower ">" value-fmt "")) + + (string-append fmtstr-text value-fmt) + (string-append fmtstr-html html-str) + (string-append fmtstr-xml xml-str) + (string-append fmtstr-text-labels namestr-lower " " value-fmt) + (string-append fmtstr-html-labels html-label-str) + (string-append fmtstr-xml-labels xml-label-str) + + (if (slot-value slot 'reference) + (progn + (string-append fmtstr-html-ref "<~~a>" value-fmt "") + (string-append fmtstr-xml-ref "<~~a>" value-fmt "") + (string-append fmtstr-html-ref-labels "" namestr-lower " <~~a>" value-fmt "") + (string-append fmtstr-xml-ref-labels " <~~a>" value-fmt "") + (push (make-instance 'reference :name name + :lookup (slot-value slot 'reference)) + references)) + (progn + (string-append fmtstr-html-ref html-str) + (string-append fmtstr-xml-ref xml-str) + (string-append fmtstr-html-ref-labels html-label-str) + (string-append fmtstr-xml-ref-labels xml-label-str))) + + (if print-formatter + (setq plain-value-func + (list `(,print-formatter (slot-value x ',(intern namestr package))))) + (setq plain-value-func + (list `(slot-value x ',(intern namestr package))))) + (setq value-func (append value-func plain-value-func)) + + (if (eql type :cdata) + (setq xmlvalue-func (append xmlvalue-func (list `(xml-cdata ,@plain-value-func)))) + (setq xmlvalue-func (append xmlvalue-func plain-value-func))) + ))) + + (setf (slot-value cl 'references) references) + + (if value-func + (setq value-func `(lambda (x) (values ,@value-func))) + (setq value-func `(lambda () (values)))) + (setq value-func (compile nil (eval value-func))) + + (if xmlvalue-func + (setq xmlvalue-func `(lambda (x) (values ,@xmlvalue-func))) + (setq xmlvalue-func `(lambda () (values)))) + (setq xmlvalue-func (compile nil (eval xmlvalue-func))) + + (setf (slot-value cl 'fmtstr-text) fmtstr-text) + (setf (slot-value cl 'fmtstr-html) fmtstr-html) + (setf (slot-value cl 'fmtstr-xml) fmtstr-xml) + (setf (slot-value cl 'fmtstr-text-labels) fmtstr-text-labels) + (setf (slot-value cl 'fmtstr-html-labels) fmtstr-html-labels) + (setf (slot-value cl 'fmtstr-xml-labels) fmtstr-xml-labels) + (setf (slot-value cl 'fmtstr-html-ref) fmtstr-html-ref) + (setf (slot-value cl 'fmtstr-xml-ref) fmtstr-xml-ref) + (setf (slot-value cl 'fmtstr-html-ref-labels) fmtstr-html-ref-labels) + (setf (slot-value cl 'fmtstr-xml-ref-labels) fmtstr-xml-ref-labels) + (setf (slot-value cl 'value-func) value-func) + (setf (slot-value cl 'xmlvalue-func) xmlvalue-func)) + (values)) + +(defun init-hyperobject-class (cl) + "Initialize a hyperobject class. Calculates all class slots" + (process-subobjects cl) + (process-views cl) + (process-documentation cl)) + +(defun hyperobject-class-fmtstr-text (obj) + (slot-value (class-of obj) 'fmtstr-text)) + +(defun hyperobject-class-fmtstr-html (obj) + (slot-value (class-of obj) 'fmtstr-html)) + +(defun hyperobject-class-fmtstr-xml (obj) + (slot-value (class-of obj) 'fmtstr-xml)) + +(defun hyperobject-class-fmtstr-text-labels (obj) + (slot-value (class-of obj) 'fmtstr-text-labels)) + +(defun hyperobject-class-fmtstr-html-labels (obj) + (slot-value (class-of obj) 'fmtstr-html-labels)) + +(defun hyperobject-class-fmtstr-xml-labels (obj) + (slot-value (class-of obj) 'fmtstr-xml-labels)) + +(defun hyperobject-class-value-func (obj) + (slot-value (class-of obj) 'value-func)) + +(defun hyperobject-class-xmlvalue-func (obj) + (slot-value (class-of obj) 'xmlvalue-func)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun hyperobject-class-title (obj) + (awhen (slot-value (class-of obj) 'title) + (if (consp it) + (car it) + it)))) + +(defun hyperobject-class-subobjects (obj) + (slot-value (class-of obj) 'subobjects)) + +(defun hyperobject-class-references (obj) + (slot-value (class-of obj) 'references)) + +(defun hyperobject-class-fields (obj) + (class-slots (class-of obj))) + +(defun hyperobject-class-fmtstr-html-ref (obj) + (slot-value (class-of obj) 'fmtstr-html-ref)) + +(defun hyperobject-class-fmtstr-xml-ref (obj) + (slot-value (class-of obj) 'fmtstr-xml-ref)) + +(defun hyperobject-class-fmtstr-html-ref-labels (obj) + (slot-value (class-of obj) 'fmtstr-html-ref-labels)) + +(defun hyperobject-class-fmtstr-xml-ref-labels (obj) + (slot-value (class-of obj) 'fmtstr-xml-ref-labels)) +