(defmethod print-object ((obj hyperobject) (s stream))
(print-unreadable-object (obj s :type t :identity nil)
(funcall (obj-data-printer (get-view-id obj :compact-text))
- obj s nil)))
+ obj s nil)))
(defun sql-connect ()
"Connect to HO database, automatically used pooled connections"
- (clsql:connect `(,(ho-sql-host) ,(ho-sql-db) ,(ho-sql-user) ,(ho-sql-passwd))
- :database-type *ho-sql-type* :pool t))
+ (clsql:connect `(,(ho-sql-host) ,(ho-sql-db) ,(ho-sql-user) ,(ho-sql-passwd))
+ :database-type *ho-sql-type* :pool t))
(defun sql-disconnect (conn)
"Disconnect from HO database, but put connection back into pool"
(defmacro with-sql-connection ((conn) &body body)
`(let ((,conn (sql-connect)))
(unwind-protect
- (progn ,@body)
+ (progn ,@body)
(when ,conn (clsql:disconnect :database ,conn)))))
(defun sql-query (cmd conn &key (types :auto))
(defmacro with-mutex-sql ((conn) &body body)
`(let ((,conn (sql-connect)))
(unwind-protect
- (progn ,@body)
+ (progn ,@body)
(when ,conn (sql-disconnect ,conn)))))
(defun mutex-sql-execute (cmd)
;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
;;;;
;;;; *************************************************************************
-
+
(in-package :hyperobject-user)
(defclass person (hyperobject)
((first-name :value-type (varchar 20) :initarg :first-name :accessor first-name
- :value-constraint stringp :null-allowed nil)
+ :value-constraint stringp :null-allowed nil)
(last-name :value-type (varchar 30) :initarg :last-name :accessor last-name
- :value-constraint stringp
- :hyperlink find-person-by-last-name :null-allowed nil)
+ :value-constraint stringp
+ :hyperlink find-person-by-last-name :null-allowed nil)
(full-name :value-type string :stored nil)
(dob :value-type integer :initarg :dob :accessor dob :print-formatter format-date
- :value-constraint integerp :input-filter convert-to-date)
+ :value-constraint integerp :input-filter convert-to-date)
(resume :value-type string :initarg :resume :accessor resume
- :value-constraint stringp)
+ :value-constraint stringp)
;; (addresses :value-type (list-of subobject) :initarg :addresses :accessor addresses))
(addresses :subobject t :initarg :addresses :accessor addresses))
(:metaclass hyperobject-class)
- (:default-initargs :first-name "" :last-name "" :dob 0 :resume nil)
+ (:default-initargs :first-name "" :last-name "" :dob 0 :resume nil)
(:default-print-slots first-name last-name dob resume)
(:user-name "Person")
(:user-name-plural "Persons")
(:description "A Person")
(:direct-rules
(:rule-1 (:dependants (last-name first-name) :volatile full-name)
- (setf full-name (concatenate 'string first-name " " last-name)))))
+ (setf full-name (concatenate 'string first-name " " last-name)))))
(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))))
+ (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 :value-type (varchar 20) :initarg :title :accessor title
- :value-constraint stringp)
+ :value-constraint stringp)
(street :value-type (varchar 30) :initarg :street :accessor street
- :value-constraint stringp)
+ :value-constraint stringp)
(phones :subobject t :initarg :phones :accessor phones))
(:metaclass hyperobject-class)
- (:default-initargs :title nil :street nil)
+ (:default-initargs :title nil :street nil)
(:user-name "Address" "Addresses")
(:default-print-slots title street)
(:description "An address"))
(defclass phone (hyperobject)
((title :value-type (varchar 20) :initarg :title :accessor title
- :value-constraint stringp)
+ :value-constraint stringp)
(phone-number :value-type (varchar 16) :initarg :phone-number :accessor phone-number
- :value-constraint stringp))
+ :value-constraint stringp))
(:metaclass hyperobject-class)
(:user-name "Phone Number")
(:user-name-plural "Phone Numbers")
(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)))
+ :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)))
+ :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"))
+ :dob (get-universal-time)
+ :addresses (list home office)
+ :resume "Style & Grace"))
(format t "~&Text Format~%")
;;;;
;;;; This file is Copyright (c) 2000-2006 by Kevin M. Rosenberg
;;;; *************************************************************************
-
+
(in-package #:hyperobject)
(defparameter *class-options*
(defclass hyperobject-class (standard-class)
( ;; slots initialized in defclass
(user-name :initarg :user-name :type string :initform nil
- :accessor user-name
- :documentation "User name for class")
+ :accessor user-name
+ :documentation "User name for class")
(user-name-plural :initarg :user-name-plural :type string :initform nil
- :accessor user-name-plural
- :documentation "Plural user name for class")
+ :accessor user-name-plural
+ :documentation "Plural user name for class")
(default-print-slots :initarg :default-print-slots :type list :initform nil
- :accessor default-print-slots
- :documentation "Defaults slots for a view")
+ :accessor default-print-slots
+ :documentation "Defaults slots for a view")
(description :initarg :description :initform nil
- :accessor description
- :documentation "Class description")
+ :accessor description
+ :documentation "Class description")
(version :initarg :version :initform nil
- :accessor version
- :documentation "Version number for class")
+ :accessor version
+ :documentation "Version number for class")
(closures :initarg :closures :initform nil
- :accessor closures
- :documentation "Closures to call on slot chnages")
+ :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")
+ :documentation "SQL Name for this class")
(guid :initarg :guid :accessor guid :initform nil
- :documentation "ID string for this class")
+ :documentation "ID string for this class")
;;; The remainder of these fields are calculated one time
;;; in finalize-inheritence.
(subobjects :initform nil :accessor subobjects
- :documentation
- "List of fields that contain a list of subobjects objects.")
+ :documentation
+ "List of fields that contain a list of subobjects objects.")
(compute-cached-values :initform nil :accessor compute-cached-values
:documentation
"List of fields that contain a list of compute-cached-value objects.")
(hyperlinks :type list :initform nil :accessor hyperlinks
- :documentation "List of fields that have hyperlinks")
+ :documentation "List of fields that have hyperlinks")
(direct-rules :type list :initform nil :initarg :direct-rules
- :accessor direct-rules
- :documentation "List of rules to fire on slot changes.")
+ :accessor direct-rules
+ :documentation "List of rules to fire on slot changes.")
(direct-views :type list :initform nil :initarg :direct-views
- :accessor direct-views
- :documentation "List of views")
+ :accessor direct-views
+ :documentation "List of views")
(class-id :type integer :initform (+ (* 1000000 (get-universal-time)) (random 1000000))
- :accessor class-id
- :documentation "Unique ID for the class")
+ :accessor class-id
+ :documentation "Unique ID for the class")
(default-view :initform nil :initarg :default-view :accessor default-view
- :documentation "The default view for a class")
+ :documentation "The default view for a class")
(documementation :initform nil :initarg :documentation
- :documentation "Documentation string for hyperclass.")
+ :documentation "Documentation string for hyperclass.")
;; SQL commands
(create-table-cmd :initform nil :reader create-table-cmd)
(drop-table-cmd :initform nil :reader drop-table-cmd)
(views :type list :initform nil :initarg :views :accessor views
- :documentation "List of views")
+ :documentation "List of views")
(rules :type list :initform nil :initarg :rules :accessor rules
- :documentation "List of rules")
+ :documentation "List of rules")
)
(:documentation "Metaclass for Markup Language classes."))
(lookup-keys :type list :initarg :lookup-keys :reader lookup-keys))
(:documentation "subobject information")
(:default-initargs :name-class nil :name-slot nil :lazy-class nil
- :lookup nil :lookup-keys nil))
+ :lookup nil :lookup-keys nil))
(defclass compute-cached-value ()
((name-class :type symbol :initarg :name-class :reader name-class)
(lookup-keys :type list :initarg :lookup-keys :reader lookup-keys))
(:documentation "subobject information")
(:default-initargs :name-class nil :name-slot nil :lazy-class nil
- :lookup nil :lookup-keys nil))
+ :lookup nil :lookup-keys nil))
(defmethod print-object ((obj subobject) (s stream))
;; :type t
:initform nil :initarg :lookup :reader lookup)
(link-parameters :type list :initform nil :initarg :link-parameters
- :reader link-parameters)))
+ :reader link-parameters)))
(defmethod print-object ((obj hyperlink) (s stream))
(print-unreadable-object (obj s :type t :identity t)
(defun remove-keyword-arg (arglist akey)
(let ((mylist arglist)
- (newlist ()))
+ (newlist ()))
(labels ((pop-arg (alist)
- (let ((arg (pop alist))
- (val (pop alist)))
- (unless (equal arg akey)
- (setf newlist (append (list arg val) newlist)))
- (when alist (pop-arg alist)))))
+ (let ((arg (pop alist))
+ (val (pop alist)))
+ (unless (equal arg akey)
+ (setf newlist (append (list arg val) newlist)))
+ (when alist (pop-arg alist)))))
(pop-arg mylist))
newlist))
(defun remove-keyword-args (arglist akeys)
(let ((mylist arglist)
- (newlist ()))
+ (newlist ()))
(labels ((pop-arg (alist)
- (let ((arg (pop alist))
- (val (pop alist)))
- (unless (find arg akeys)
- (setf newlist (append (list arg val) newlist)))
- (when alist (pop-arg alist)))))
+ (let ((arg (pop alist))
+ (val (pop alist)))
+ (unless (find arg akeys)
+ (setf newlist (append (list arg val) newlist)))
+ (when alist (pop-arg alist)))))
(pop-arg mylist))
newlist))
(defmethod shared-initialize :around ((class hyperobject-class) slot-names
&rest initargs
- &key direct-superclasses
+ &key direct-superclasses
user-name sql-name name description
- &allow-other-keys)
+ &allow-other-keys)
;(format t "ii ~S ~S ~S ~S ~S~%" initargs base-table direct-superclasses user-name sql-name)
(let ((root-class (find-class 'hyperobject nil))
- (vmc 'hyperobject-class)
+ (vmc 'hyperobject-class)
user-name-plural user-name-str sql-name-str)
;; when does CLSQL pass :qualifier to initialize instance?
(setq user-name-str
(do-call-next-method direct-superclasses)
(do-call-next-method direct-superclasses #+nil (append (list root-class)
direct-superclasses)))
- (do-call-next-method direct-superclasses)))))
+ (do-call-next-method direct-superclasses)))))
(defmethod finalize-inheritance :after ((cl hyperobject-class))
(eval-when (:compile-toplevel :load-toplevel :execute)
(when (>= (length (generic-function-lambda-list
- (ensure-generic-function
- 'compute-effective-slot-definition)))
- 3)
+ (ensure-generic-function
+ 'compute-effective-slot-definition)))
+ 3)
(pushnew :ho-normal-cesd cl:*features*))
(when (>= (length (generic-function-lambda-list
- (ensure-generic-function
- 'direct-slot-definition-class)))
- 3)
+ (ensure-generic-function
+ 'direct-slot-definition-class)))
+ 3)
(pushnew :ho-normal-dsdc cl:*features*))
(when (>= (length (generic-function-lambda-list
- (ensure-generic-function
- 'effective-slot-definition-class)))
- 3)
+ (ensure-generic-function
+ 'effective-slot-definition-class)))
+ 3)
(pushnew :ho-normal-esdc cl:*features*)))
(defmethod direct-slot-definition-class ((cl hyperobject-class)
- #+ho-normal-dsdc &rest iargs)
+ #+ho-normal-dsdc &rest iargs)
(declare (ignore iargs))
(find-class 'hyperobject-dsd))
(defmethod effective-slot-definition-class ((cl hyperobject-class)
- #+ho-normal-esdc &rest iargs)
+ #+ho-normal-esdc &rest iargs)
(declare (ignore iargs))
(find-class 'hyperobject-esd))
(defmacro process-class-option (slot-name &optional required)
#+lispworks
`(defmethod clos:process-a-class-option ((class hyperobject-class)
- (name (eql ,slot-name))
- value)
+ (name (eql ,slot-name))
+ value)
(when (and ,required (null value))
- (error "hyperobject class slot ~A must have a value" name))
+ (error "hyperobject class slot ~A must have a value" name))
(list name `',value))
#+(or allegro sbcl cmu scl openmcl)
(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-options
- slot)
+ (option (eql ,slot-name))
+ value
+ already-processed-options
+ slot)
(list* option `',value already-processed-options))
#-lispworks
(declare (ignore slot-name))
(eval
`(defclass hyperobject-dsd (standard-direct-slot-definition)
(,@(mapcar #'(lambda (x)
- `(,(intern (symbol-name x))
- :initform nil))
- *slot-options-no-initarg*)
+ `(,(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
- :accessor
- ,(intern (concatenate 'string
- (symbol-name :dsd-)
- (symbol-name x)))))
- *slot-options*))))
+ `(,(intern (symbol-name x))
+ :initarg
+ ,(intern (symbol-name x) (symbol-name :keyword))
+ :initform nil
+ :accessor
+ ,(intern (concatenate 'string
+ (symbol-name :dsd-)
+ (symbol-name x)))))
+ *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
- :accessor
- ,(intern (concatenate 'string
- (symbol-name :esd-)
- (symbol-name x)))))
- (append *slot-options* *slot-options-no-initarg*)))))
+ `(,(intern (symbol-name x))
+ :initarg
+ ,(intern (symbol-name x) (symbol-name :keyword))
+ :initform nil
+ :accessor
+ ,(intern (concatenate 'string
+ (symbol-name :esd-)
+ (symbol-name x)))))
+ (append *slot-options* *slot-options-no-initarg*)))))
) ;; eval-when
(defun intern-in-keyword (obj)
(defmethod compute-effective-slot-definition :around ((cl hyperobject-class)
- #+ho-normal-cesd name
- dsds)
+ #+ho-normal-cesd name
+ dsds)
(declare (ignore #+ho-normal-cesd name))
(let ((esd (call-next-method)))
(if (typep esd 'hyperobject-esd)
- (compute-hyperobject-esd esd dsds)
- esd)))
+ (compute-hyperobject-esd esd dsds)
+ esd)))
(defun compute-hyperobject-esd (esd dsds)
(let* ((dsd (car dsds)))
(multiple-value-bind (sql-type sql-length)
- (value-type-to-sql-type (dsd-value-type dsd))
+ (value-type-to-sql-type (dsd-value-type dsd))
(setf (esd-sql-type esd) sql-type)
(setf (esd-sql-length esd) sql-length))
(setf (esd-user-name esd)
- (aif (dsd-user-name dsd)
+ (aif (dsd-user-name dsd)
it
- (string-downcase (symbol-name (slot-definition-name dsd)))))
+ (string-downcase (symbol-name (slot-definition-name dsd)))))
(setf (esd-sql-name esd)
- (aif (dsd-sql-name dsd)
- it
- (lisp-name-to-sql-name (slot-definition-name dsd))))
+ (aif (dsd-sql-name dsd)
+ it
+ (lisp-name-to-sql-name (slot-definition-name dsd))))
(setf (esd-sql-name esd)
- (aif (dsd-sql-name dsd)
- it
- (lisp-name-to-sql-name (slot-definition-name dsd))))
+ (aif (dsd-sql-name dsd)
+ it
+ (lisp-name-to-sql-name (slot-definition-name dsd))))
(dolist (name '(value-type print-formatter subobject hyperlink
hyperlink-parameters unbound-lookup
- description value-constraint indexed null-allowed
- unique short-description void-text read-only-groups
- hidden-groups unit disable-predicate view-type
- list-of-values compute-cached-value stored))
+ description value-constraint indexed null-allowed
+ unique short-description void-text read-only-groups
+ hidden-groups unit disable-predicate view-type
+ list-of-values compute-cached-value stored))
(setf (slot-value esd name) (slot-value dsd name)))
esd))
SQL name"
(unless (stringp lisp)
(setq lisp
- (typecase lisp
- (symbol (symbol-name lisp))
- (t (write-to-string lisp)))))
+ (typecase lisp
+ (symbol (symbol-name lisp))
+ (t (write-to-string lisp)))))
(do* ((len (length lisp))
- (sql (make-string len))
- (i 0 (1+ i)))
+ (sql (make-string len))
+ (i 0 (1+ i)))
((= i len) (string-upcase sql))
(declare (fixnum i)
- (simple-string sql))
+ (simple-string sql))
(setf (schar sql i)
- (let ((c (char lisp i)))
- (case c
- ((#\- #\$ #\+ #\#) #\_)
- (otherwise c))))))
+ (let ((c (char lisp i)))
+ (case c
+ ((#\- #\$ #\+ #\#) #\_)
+ (otherwise c))))))
#+ho-normal-cesd
(setq cl:*features* (delete :ho-normal-cesd cl:*features*))
(defun value-type-to-sql-type (value-type)
"Return two values, the sql type and field length."
(let ((type (base-value-type value-type))
- (length (when (consp value-type)
- (cadr value-type))))
+ (length (when (consp value-type)
+ (cadr value-type))))
(values
(case type
((:char :character)
- :char)
+ :char)
(:varchar
- :varchar)
+ :varchar)
((:fixnum :integer)
- :integer)
+ :integer)
(:long-integer
- :long-integer)
+ :long-integer)
(:boolean
- :boolean)
+ :boolean)
((:float :single-float)
- :single-float)
+ :single-float)
(:double-float
- :double-float)
+ :double-float)
(:datetime
:long-integer)
(otherwise
- :text))
+ :text))
length)))
;;;; Class initialization function
(defmethod slot-unbound ((class hyperobject-class) instance slot-name)
(let ((lazy-reader
- (loop for super in (class-precedence-list class)
- as lazy-reader = (getf (gethash super *lazy-readers*) slot-name)
- when lazy-reader return it)))
+ (loop for super in (class-precedence-list class)
+ as lazy-reader = (getf (gethash super *lazy-readers*) slot-name)
+ when lazy-reader return it)))
(if lazy-reader
- (setf (slot-value instance slot-name)
- (if (atom lazy-reader)
- (make-instance lazy-reader)
- (apply (car lazy-reader)
- (loop for arg-slot-name in (cdr lazy-reader)
- collect (slot-value instance arg-slot-name)))))
- ;; No lazy reader -- defer to regular slot-unbound handling.
- (call-next-method))))
+ (setf (slot-value instance slot-name)
+ (if (atom lazy-reader)
+ (make-instance lazy-reader)
+ (apply (car lazy-reader)
+ (loop for arg-slot-name in (cdr lazy-reader)
+ collect (slot-value instance arg-slot-name)))))
+ ;; No lazy reader -- defer to regular slot-unbound handling.
+ (call-next-method))))
;; The reader is a function and the reader-keys are slot names. The slot is lazily set to
;; the result of applying the function to the slot-values of those slots, and that value
;; is also returned.
(defun ensure-lazy-reader (cl class-name slot-name lazy-class reader
- &rest reader-keys)
+ &rest reader-keys)
(declare (ignore class-name))
(setf (getf (gethash cl *lazy-readers*) slot-name)
(aif lazy-class
- it
- (list* reader (copy-list reader-keys)))))
+ it
+ (list* reader (copy-list reader-keys)))))
(defun remove-lazy-reader (class-name slot-name)
(setf (getf (gethash (find-class class-name) *lazy-readers*) slot-name)
"Calculate class documentation slot"
(let ((*print-circle* nil))
(setf (documentation cl 'type)
- (format nil "Hyperobject~A~A~A~A"
- (aif (user-name cl)
- (format nil ": ~A" it ""))
- (aif (description cl)
- (format nil "~%Class description: ~A" it) "")
- (aif (subobjects cl)
- (format nil "~%Subobjects:~{ ~A~}" (mapcar #'name-slot it)) "")
- (aif (default-print-slots cl)
- (format nil "~%Default print slots:~{ ~A~}" it) "")
- ))))
+ (format nil "Hyperobject~A~A~A~A"
+ (aif (user-name cl)
+ (format nil ": ~A" it ""))
+ (aif (description cl)
+ (format nil "~%Class description: ~A" it) "")
+ (aif (subobjects cl)
+ (format nil "~%Subobjects:~{ ~A~}" (mapcar #'name-slot it)) "")
+ (aif (default-print-slots cl)
+ (format nil "~%Default print slots:~{ ~A~}" it) "")
+ ))))
(defun finalize-hyperlinks (cl)
(let ((hyperlinks '()))
(dolist (esd (class-slots cl))
(awhen (slot-value esd 'hyperlink)
- (push
- (make-instance 'hyperlink
- :name (slot-definition-name esd)
- :lookup it
- :link-parameters (slot-value esd 'hyperlink-parameters))
- hyperlinks)))
+ (push
+ (make-instance 'hyperlink
+ :name (slot-definition-name esd)
+ :lookup it
+ :link-parameters (slot-value esd 'hyperlink-parameters))
+ hyperlinks)))
;; cmu/sbcl reverse class-slots compared to the defclass form
;; hyperlinks is already reversed from the dolist/push loop, so re-reverse on sbcl/cmu
#-(or cmu sbcl) (setq hyperlinks (nreverse hyperlinks))
#+cmu
(eval-when (:compile-toplevel :load-toplevel :execute)
(if (eq (symbol-package 'pcl:find-class)
- (find-package 'common-lisp))
+ (find-package 'common-lisp))
(pushnew :kmr-cmucl-mop cl:*features*)
(pushnew :kmr-cmucl-pcl cl:*features*)))
(defpackage #:hyperobject
(:nicknames #:ho)
(:use #:common-lisp #:kmrcl
- #+kmr-sbcl-mop #:sb-mop
- #+kmr-cmucl-mop #:mop
- #+allegro #:mop
- #+lispworks #:clos
- #+scl #:clos
- #+openmcl #:openmcl-mop)
+ #+kmr-sbcl-mop #:sb-mop
+ #+kmr-cmucl-mop #:mop
+ #+allegro #:mop
+ #+lispworks #:clos
+ #+scl #:clos
+ #+openmcl #:openmcl-mop)
(:export
#:package
#:hyperobject
;;;;
;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg
;;;; *************************************************************************
-
+
(in-package #:hyperobject)
;;; Slot accessor and class rules
(declare (ignore cl))
(let ((access (appendnew dependants volatile)))
(compile nil
- (eval
- `(lambda (obj)
- (when (every #'(lambda (x) (slot-boundp obj x))
- (quote ,dependants))
- (with-slots ,access obj
- ,@source-code)))))))
-
+ (eval
+ `(lambda (obj)
+ (when (every #'(lambda (x) (slot-boundp obj x))
+ (quote ,dependants))
+ (with-slots ,access obj
+ ,@source-code)))))))
+
(defun finalize-rules (cl)
(setf (rules cl)
(loop for rule in (direct-rules cl)
- collect
- (destructuring-bind (name (&key dependants volatile) &rest source-code)
- rule
- (setf dependants (mklist dependants)
- volatile (mklist volatile))
- (make-instance 'rule :name name :dependants dependants
- :volatile volatile :source-code source-code
- :access-slots (appendnew dependants volatile)
- :func (compile-rule
- source-code dependants volatile cl))))))
+ collect
+ (destructuring-bind (name (&key dependants volatile) &rest source-code)
+ rule
+ (setf dependants (mklist dependants)
+ volatile (mklist volatile))
+ (make-instance 'rule :name name :dependants dependants
+ :volatile volatile :source-code source-code
+ :access-slots (appendnew dependants volatile)
+ :func (compile-rule
+ source-code dependants volatile cl))))))
(defun fire-class-rules (cl obj slot)
(let ((name (slot-definition-name slot)))
(dolist (rule (rules cl))
(when (find name (dependants rule))
- (cmsg-c :debug "firing rule: ~W" (source-code rule))
- (funcall (func rule) obj)))))
+ (cmsg-c :debug "firing rule: ~W" (source-code rule))
+ (funcall (func rule) obj)))))
#+ho-svuc
#+ignore
(cmsg-c :verbose "Setf slot value: class: ~s, obj: ~s, slot: ~s, value: ~s" cl (class-of obj) slot new-value)
-
+
(let ((func (esd-value-constraint slot)))
(cond
((and func (not (funcall func new-value)))
(warn "Rejected change to value of slot ~a of object ~a"
- (slot-definition-name slot) obj)
+ (slot-definition-name slot) obj)
(slot-value obj (slot-definition-name slot)))
(t
(prog1
- (call-next-method)
- (when (direct-rules cl)
- (fire-class-rules cl obj slot)))))))
+ (call-next-method)
+ (when (direct-rules cl)
+ (fire-class-rules cl obj slot)))))))
(defun finalize-sql (cl)
(setf (slot-value cl 'drop-table-cmd) (generate-drop-table-cmd
- (slot-value cl 'sql-name)))
+ (slot-value cl 'sql-name)))
(let ((esds (class-slots cl)))
(setf (slot-value cl 'create-table-cmd)
- (generate-create-table-cmd
- cl
+ (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 (sql-name cl) esds))
(dolist (esd esds)
(when (slot-value esd 'inverse)
- (define-inverse cl esd))))
+ (define-inverse cl esd))))
)
-
+
(defun define-inverse (class esd)
"Define an inverse function for a slot"
(let ((inverse (slot-value esd 'inverse)))
(when inverse
(eval
`(defun ,inverse (obj)
- (format t "~&Finding key: ~S for class ~S ~%" obj ,class)
- ;; create inverse function
- ))
+ (format t "~&Finding key: ~S for class ~S ~%" obj ,class)
+ ;; create inverse function
+ ))
))
)
(defun generate-create-table-cmd (cl esds)
(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)))))))
+ (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
(let (indices)
(dolist (slot slots)
(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))))
+ (let ((sql-name (slot-value slot 'sql-name)))
+ (push (sql-cmd-index table-name sql-name (slot-value slot 'unique))
+ indices))))
indices))
(defun sql-cmd-index (table field unique)
(let ((*print-circle* nil))
(format nil "CREATE ~AINDEX ~A ON ~A(~A)"
- (if unique "UNIQUE " "")
- (sql-index-name table field)
- table
- field)))
+ (if unique "UNIQUE " "")
+ (sql-index-name table field)
+ table
+ field)))
(defun sql-index-name (table field)
(format nil "~A_~A" table field))
(defmethod sql-insert (obj)
(mutex-sql-execute
(format nil "INSERT INTO ~a (~a) VALUES (~a)"
- (sql-name self) (sql-cmd-field-names self) (format-values self))))
+ (sql-name self) (sql-cmd-field-names self) (format-values self))))
(defmethod sql-select (obj lisp-name key)
- (let ((tuple
- (car
- (mutex-sql-query
- (format nil "SELECT ~a FROM ~a WHERE ~a=~a"
- (sql-cmd-field-names self) (sql-name self)
- (inverse-field-name self) key)))))
+ (let ((tuple
+ (car
+ (mutex-sql-query
+ (format nil "SELECT ~a FROM ~a WHERE ~a=~a"
+ (sql-cmd-field-names self) (sql-name self)
+ (inverse-field-name self) key)))))
(when tuple
(format t "process returned fields"))))
(defun format-values (self)
(let ((values "")
- (fields (fields self)))
+ (fields (fields self)))
(dolist (field fields)
(unless (eq field (car fields))
- (string-append values ","))
+ (string-append values ","))
(let ((name (car field)))
- (with-key-value-list (key value (rest field))
- (when (eq key :type)
- (string-append values
- (ecase value
- ((:fixnum :bigint :short-float :double-float)
- (write-to-string
- (slot-value self name)))
- ((:string :text)
- (format nil "'~a'"
- (add-sql-quotes
- (slot-value self name))))))))))
+ (with-key-value-list (key value (rest field))
+ (when (eq key :type)
+ (string-append values
+ (ecase value
+ ((:fixnum :bigint :short-float :double-float)
+ (write-to-string
+ (slot-value self name)))
+ ((:string :text)
+ (format nil "'~a'"
+ (add-sql-quotes
+ (slot-value self name))))))))))
values))
(defun inverse-field-string (fields)
(let (inverse)
(dolist (field fields)
(let ((name-string (write-to-string (car field))))
- (with-key-value-list (key value (rest field))
- (when (eq key :inverse)
- (setq inverse value)))))
+ (with-key-value-list (key value (rest field))
+ (when (eq key :inverse)
+ (setq inverse value)))))
(when inverse
(write-to-string inverse))))
(let ((names ""))
(dolist (field fields)
(unless (eq field (car fields))
- (string-append names ","))
+ (string-append names ","))
(string-append names (lisp-name-to-sql-name (car field))))
names))
-
+
(defun parse-fields (table-name fields)
(let (class-fields)
(dolist (field fields)
(let* ((fname (car field))
- (name-string (write-to-string fname))
- (initarg (intern name-string :keyword))concat-symbol
- (def (list fname))
- (options (rest field)))
- (with-key-value-list (key value options)
- (case key
- (:type
- (setq def (nconc def (list :type
- (ecase value
- (:string
- 'string)
- (:fixnum
- 'fixnum)
- (:long-integer
- 'integer)
- (:short-float
- 'short-float)
- (:long
- 'long-float)
- (:text
- 'string))))))))
- (setq def (nconc def (list
- :initarg initarg
- :accessor (concat-symbol
- (write-to-string table-name) "-"
- (write-to-string fname)))))
- (push def class-fields)))
+ (name-string (write-to-string fname))
+ (initarg (intern name-string :keyword))concat-symbol
+ (def (list fname))
+ (options (rest field)))
+ (with-key-value-list (key value options)
+ (case key
+ (:type
+ (setq def (nconc def (list :type
+ (ecase value
+ (:string
+ 'string)
+ (:fixnum
+ 'fixnum)
+ (:long-integer
+ 'integer)
+ (:short-float
+ 'short-float)
+ (:long
+ 'long-float)
+ (:text
+ 'string))))))))
+ (setq def (nconc def (list
+ :initarg initarg
+ :accessor (concat-symbol
+ (write-to-string table-name) "-"
+ (write-to-string fname)))))
+ (push def class-fields)))
class-fields))
||#
(defclass person (hyperobject)
((first-name :initarg :first-name :accessor first-name
- :value-type (varchar 20)
- :value-constraint stringp
- :null-allowed nil)
+ :value-type (varchar 20)
+ :value-constraint stringp
+ :null-allowed nil)
(last-name :initarg :last-name :accessor last-name
- :value-type (varchar 30)
- :value-constraint stringp
- :hyperlink find-person-by-last-name
- :hyperlink-parameters (("narrow" . "yes"))
- :null-allowed nil)
+ :value-type (varchar 30)
+ :value-constraint stringp
+ :hyperlink find-person-by-last-name
+ :hyperlink-parameters (("narrow" . "yes"))
+ :null-allowed nil)
(full-name :value-type string :stored nil)
(dob :initarg :dob :accessor dob
- :value-type integer
- :print-formatter date-string
- :value-constraint integerp
- :input-filter convert-to-date)
+ :value-type integer
+ :print-formatter date-string
+ :value-constraint integerp
+ :input-filter convert-to-date)
(resume :initarg :resume :accessor resume
- :value-type string
- :value-constraint stringp)
+ :value-type string
+ :value-constraint stringp)
;; (addresses :value-type (list-of subobject) :initarg :addresses :accessor addresses))
(addresses :initarg :addresses :accessor addresses
- :subobject t)
+ :subobject t)
(create-time :accessor create-time :compute-cached-value (get-now)))
(:metaclass hyperobject-class)
(:default-initargs :first-name "" :last-name "" :dob 0 :resume nil)
(:description "A Person")
(:direct-rules
(:rule-1 (:dependants (last-name first-name) :volatile full-name)
- (setf full-name (concatenate 'string first-name " " last-name)))))
+ (setf full-name (concatenate 'string first-name " " last-name)))))
(defclass address (hyperobject)
((title :initarg :title :accessor title
- :value-type (varchar 20)
- :value-constraint stringp)
+ :value-type (varchar 20)
+ :value-constraint stringp)
(street :initarg :street :accessor street
- :value-type (varchar 30)
- :value-constraint stringp)
+ :value-type (varchar 30)
+ :value-constraint stringp)
(phones :initarg :phones :accessor phones
- :subobject t)
+ :subobject t)
(years-at-address :initarg :years-at-address :value-type fixnum
:accessor years-at-address
:value-constraint integerp))
(defclass phone (hyperobject)
((title :initarg :title :accessor title
- :value-type (varchar 20)
- :value-constraint stringp)
+ :value-type (varchar 20)
+ :value-constraint stringp)
(phone-number :initarg :phone-number :accessor phone-number
- :value-type (varchar 16)
- :value-constraint stringp
- :hyperlink search-phone-number))
+ :value-type (varchar 16)
+ :value-constraint stringp
+ :hyperlink search-phone-number))
(:metaclass hyperobject-class)
(:user-name "Phone Number")
(:default-initargs :title nil :phone-number nil)
(defparameter home (make-instance 'address :title "Home" :street "321 Shady Lane"
:years-at-address 10
- :phones (list home-phone-1 home-phone-2)))
+ :phones (list home-phone-1 home-phone-2)))
(defparameter office (make-instance 'address :title "Office" :street "113 Main St."
:years-at-address 5
- :phones (list office-phone-1 office-phone-2 office-phone-3)))
+ :phones (list office-phone-1 office-phone-2 office-phone-3)))
(defparameter mary (make-instance 'person :first-name "Mary" :last-name "Jackson"
- :dob (encode-universal-time
- 1 2 3 4 5 2000)
- :addresses (list home office)
- :resume "Style & Grace"))
+ :dob (encode-universal-time
+ 1 2 3 4 5 2000)
+ :addresses (list home office)
+ :resume "Style & Grace"))
(defun view-to-string (obj &rest args)
(defclass object-view ()
((object-class :initform nil :initarg :object-class
- :accessor object-class
- :documentation "Class of object to be viewed.")
+ :accessor object-class
+ :documentation "Class of object to be viewed.")
(slots :initform nil :initarg :slots :accessor slots
- :documentation "List of effective slots for object to be viewed.")
+ :documentation "List of effective slots for object to be viewed.")
(id :initform nil :initarg :id :accessor id
:documentation "id for this view.")
(source-code :initform nil :initarg :source-code :accessor source-code
- :documentation "Source code for generating view.")
+ :documentation "Source code for generating view.")
(country-language :initform :en :initarg :country-language
- :documentation "Country's Language for this view.")
+ :documentation "Country's Language for this view.")
(printer :initform nil :initarg :printer :accessor printer
- :documentation "default function that prints the object")
+ :documentation "default function that prints the object")
;;
(file-start-str :type (or string null) :initform nil :initarg :file-start-str
- :accessor file-start-str)
+ :accessor file-start-str)
(file-end-str :type (or string null) :initform nil :initarg :file-end-str
- :accessor file-end-str)
+ :accessor file-end-str)
(list-start-printer :type (or string function null) :initform nil
- :initarg :list-start-printer
- :accessor list-start-printer)
+ :initarg :list-start-printer
+ :accessor list-start-printer)
(list-start-indent :initform nil :initarg :list-start-indent
- :accessor list-start-indent)
+ :accessor list-start-indent)
(list-end-printer :type (or string function null) :initform nil
- :initarg :list-end-printer
- :accessor list-end-printer)
+ :initarg :list-end-printer
+ :accessor list-end-printer)
(list-end-indent :initform nil :initarg :list-end-indent
- :accessor list-end-indent)
+ :accessor list-end-indent)
(obj-start-printer :type (or string function null) :initform nil :initarg :obj-start-printer
- :accessor obj-start-printer)
+ :accessor obj-start-printer)
(obj-start-indent :initform nil :initarg :obj-start-indent
- :accessor obj-start-indent)
+ :accessor obj-start-indent)
(obj-end-printer :type (or string function null) :initform nil :initarg :obj-end-printer
- :accessor obj-end-printer)
+ :accessor obj-end-printer)
(obj-end-indent :initform nil :initarg :obj-end-indent
- :accessor obj-end-indent)
+ :accessor obj-end-indent)
(subobj-start-printer :type (or string function null) :initform nil :initarg :subobj-start-printer
- :accessor subobj-start-printer)
+ :accessor subobj-start-printer)
(subobj-start-indent :initform nil :initarg :subobj-start-indent
- :accessor subobj-start-indent)
+ :accessor subobj-start-indent)
(subobj-end-printer :type (or string function null) :initform nil :initarg :subobj-end-printer
- :accessor subobj-end-printer)
+ :accessor subobj-end-printer)
(subobj-end-indent :initform nil :initarg :subobj-end-indent
- :accessor subobj-end-indent)
+ :accessor subobj-end-indent)
(obj-data-indent :initform nil :initarg :obj-data-indent
- :accessor obj-data-indent)
+ :accessor obj-data-indent)
(obj-data-printer :type (or function null) :initform nil
- :initarg :obj-data-printer
- :accessor obj-data-printer)
+ :initarg :obj-data-printer
+ :accessor obj-data-printer)
(obj-data-print-code :type (or function list null) :initform nil
- :initarg :obj-data-print-code
- :accessor obj-data-print-code)
+ :initarg :obj-data-print-code
+ :accessor obj-data-print-code)
(obj-data-start-printer :type (or function string null) :initform nil
- :initarg :obj-data-start-printer
- :accessor obj-data-start-printer)
+ :initarg :obj-data-start-printer
+ :accessor obj-data-start-printer)
(obj-data-end-printer :type (or string null) :initform nil
- :initarg :obj-data-end-printer
- :accessor obj-data-end-printer)
+ :initarg :obj-data-end-printer
+ :accessor obj-data-end-printer)
(indenter :type (or function null) :initform nil
- :accessor indenter
- :documentation "Function that performs hierarchical indenting")
+ :accessor indenter
+ :documentation "Function that performs hierarchical indenting")
(link-slots :type list :initform nil
- :documentation "List of slot names that have hyperlinks"
- :accessor link-slots)
+ :documentation "List of slot names that have hyperlinks"
+ :accessor link-slots)
(link-page :type (or string null) :initform nil
- :initarg :link-page
- :accessor link-page)
+ :initarg :link-page
+ :accessor link-page)
(link-href-start :type (or string null) :initform nil :initarg :link-href-start
- :accessor link-href-start)
+ :accessor link-href-start)
(link-href-end :type (or string null) :initform nil :initarg :link-href-end
- :accessor link-href-end)
+ :accessor link-href-end)
(link-ampersand :type (or string null) :initform nil :initarg :link-ampersand
- :accessor link-ampersand))
+ :accessor link-ampersand))
(:default-initargs :link-page "meta-search.html")
(:documentation "View class for a hyperobject"))
"Looks for a view in class and parent classes"
(when (typep obj-cl 'hyperobject-class)
(aif (find vid (views obj-cl) :key #'id :test #'eq)
- it
- (let (cpl)
- (handler-case
- (setq cpl (class-precedence-list obj-cl))
- (error (e)
- (declare (ignore e))
- ;; can't get cpl unless class finalized
- (make-instance (class-name obj-cl))
- (setq cpl (class-precedence-list obj-cl))))
- (find-view-id-in-class-precedence (second cpl) vid)))))
+ it
+ (let (cpl)
+ (handler-case
+ (setq cpl (class-precedence-list obj-cl))
+ (error (e)
+ (declare (ignore e))
+ ;; can't get cpl unless class finalized
+ (make-instance (class-name obj-cl))
+ (setq cpl (class-precedence-list obj-cl))))
+ (find-view-id-in-class-precedence (second cpl) vid)))))
(defun get-view-id (obj vid &optional slots)
(unless vid
(setq vid (get-default-view-id obj-cl)))
(aif (find-view-id-in-class-precedence obj-cl vid)
- it
- (let ((view
- (make-instance 'object-view
- :object-class (class-name obj-cl)
- :id vid
- :slots slots)))
- (push view (views obj-cl))
- view))))
+ it
+ (let ((view
+ (make-instance 'object-view
+ :object-class (class-name obj-cl)
+ :id vid
+ :slots slots)))
+ (push view (views obj-cl))
+ view))))
;;;; *************************************************************************
;;;; Metaclass Intialization
"Finalize all views that are given on a objects initialization"
(unless (default-print-slots cl)
(setf (default-print-slots cl)
- (mapcar #'slot-definition-name (class-slots cl))))
+ (mapcar #'slot-definition-name (class-slots cl))))
(setf (views cl)
(loop for view-def in (direct-views cl)
- collect (make-object-view cl view-def))))
+ collect (make-object-view cl view-def))))
(defun make-object-view (cl view-def)
"Make an object view from a definition. Do nothing if a class is passed so that reinitialization will be a no-op"
:id :compact-text))
((consp view-def)
(make-instance 'object-view
- :object-class (class-name cl)
- :id (getf view-def :id)
- :slots (getf view-def :slots)
- :source-code (getf view-def :source-code)))
+ :object-class (class-name cl)
+ :id (getf view-def :id)
+ :slots (getf view-def :slots)
+ :source-code (getf view-def :source-code)))
(t
(error "Invalid parameter to make-object-view: ~S" view-def))))
(defmethod initialize-instance :after ((self object-view)
- &rest initargs
- &key
- &allow-other-keys)
+ &rest initargs
+ &key
+ &allow-other-keys)
(declare (ignore initargs))
(initialize-view self))
(defun initialize-view-by-source-code (view)
"Initialize a view based upon a source code"
(let* ((source-code (source-code view))
- (printer `(lambda
- (,(intern (symbol-name '#:self)
- (symbol-package (object-class view)))
- ,(intern (symbol-name '#:s)
- (symbol-package (object-class view))))
- (declare (ignorable
- ,(intern (symbol-name '#:self)
- (symbol-package (object-class view)))
- ,(intern (symbol-name '#:s)
- (symbol-package (object-class view)))))
- (with-slots ,(slots view)
- ,(intern (symbol-name '#:self)
- (symbol-package (object-class view)))
- ,@source-code))))
+ (printer `(lambda
+ (,(intern (symbol-name '#:self)
+ (symbol-package (object-class view)))
+ ,(intern (symbol-name '#:s)
+ (symbol-package (object-class view))))
+ (declare (ignorable
+ ,(intern (symbol-name '#:self)
+ (symbol-package (object-class view)))
+ ,(intern (symbol-name '#:s)
+ (symbol-package (object-class view)))))
+ (with-slots ,(slots view)
+ ,(intern (symbol-name '#:self)
+ (symbol-package (object-class view)))
+ ,@source-code))))
(setf (printer view)
(compile nil (eval printer)))))
(defun write-ho-value (obj name type formatter cdata strm)
(declare (ignorable type))
(let* ((slot-data (slot-value obj name))
- (fmt-data (if formatter
- (funcall formatter slot-data)
- slot-data)))
+ (fmt-data (if formatter
+ (funcall formatter slot-data)
+ slot-data)))
(if cdata
- (write-cdata fmt-data strm)
- (write-simple fmt-data strm))))
+ (write-cdata fmt-data strm)
+ (write-simple fmt-data strm))))
(defun ppfc-html (title name type formatter cdata print-func)
(vector-push-extend '(write-string "<span class=\"" s) print-func)
(defun push-print-fun-code (vid slot nlink print-func)
(let* ((formatter (esd-print-formatter slot))
- (name (slot-definition-name slot))
- (user-name (esd-user-name slot))
- (xml-user-name (escape-xml-string user-name))
- (xml-tag (escape-xml-string user-name))
- (type (slot-definition-type slot))
-
- (cdata (not (null
- (and (in vid :xml :xhtml :xml-link :xhtml-link
- :xml-labels :ie-xml-labels
- :xhtml-link-labels :xml-link-labels :ie-xml-link
- :ie-xml-link-labels)
- (or formatter
- (lisp-type-is-a-string type))))))
- (hyperlink (esd-hyperlink slot)))
+ (name (slot-definition-name slot))
+ (user-name (esd-user-name slot))
+ (xml-user-name (escape-xml-string user-name))
+ (xml-tag (escape-xml-string user-name))
+ (type (slot-definition-type slot))
+
+ (cdata (not (null
+ (and (in vid :xml :xhtml :xml-link :xhtml-link
+ :xml-labels :ie-xml-labels
+ :xhtml-link-labels :xml-link-labels :ie-xml-link
+ :ie-xml-link-labels)
+ (or formatter
+ (lisp-type-is-a-string type))))))
+ (hyperlink (esd-hyperlink slot)))
(case vid
(:compact-text
(vector-push-extend
- `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func))
+ `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func))
(:compact-text-labels
(vector-push-extend `(write-string ,user-name s) print-func)
(vector-push-extend '(write-char #\space s) print-func)
(vector-push-extend
- `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func))
+ `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func))
((or :html :xhtml)
(ppfc-html user-name name type formatter cdata print-func))
(:xml
(ppfc-xml-labels xml-user-name xml-tag name type formatter cdata print-func))
((or :html-link :xhtml-link)
(if hyperlink
- (ppfc-html-link name type formatter cdata nlink print-func)
- (ppfc-html user-name name type formatter cdata print-func)))
+ (ppfc-html-link name type formatter cdata nlink print-func)
+ (ppfc-html user-name name type formatter cdata print-func)))
((or :xml-link :ie-xml-link)
(if hyperlink
- (ppfc-html-link name type formatter cdata nlink print-func)
- (ppfc-xml xml-tag name type formatter cdata print-func)))
+ (ppfc-html-link name type formatter cdata nlink print-func)
+ (ppfc-xml xml-tag name type formatter cdata print-func)))
(:html-link-labels
(if hyperlink
- (ppfc-html-link-labels user-name name type formatter cdata nlink
- print-func)
- (ppfc-html-labels user-name name type formatter cdata print-func)))
+ (ppfc-html-link-labels user-name name type formatter cdata nlink
+ print-func)
+ (ppfc-html-labels user-name name type formatter cdata print-func)))
(:xhtml-link-labels
(if hyperlink
- (ppfc-html-link-labels xml-user-name name type formatter cdata nlink
- print-func)
- (ppfc-xhtml-labels xml-tag user-name name type formatter cdata
- print-func)))
+ (ppfc-html-link-labels xml-user-name name type formatter cdata nlink
+ print-func)
+ (ppfc-xhtml-labels xml-tag user-name name type formatter cdata
+ print-func)))
((or :xml-link-labels :ie-xml-link-labels)
(if hyperlink
- (ppfc-html-link-labels xml-user-name name type formatter cdata nlink
- print-func)
- (ppfc-xml-labels xml-tag user-name name type formatter cdata
- print-func))))))
+ (ppfc-html-link-labels xml-user-name name type formatter cdata nlink
+ print-func)
+ (ppfc-xml-labels xml-tag user-name name type formatter cdata
+ print-func))))))
(defun view-has-links-p (view)
(unless (slots view) (setf (slots view) (default-print-slots obj-cl)))
(let ((links '())
- (print-func (make-array 20 :fill-pointer 0 :adjustable t)))
+ (print-func (make-array 20 :fill-pointer 0 :adjustable t)))
(do* ((slots (slots view) (cdr slots))
- (slot-name (car slots) (car slots))
- (slot (find-slot-by-name obj-cl slot-name)
- (find-slot-by-name obj-cl slot-name)))
- ((null slots))
+ (slot-name (car slots) (car slots))
+ (slot (find-slot-by-name obj-cl slot-name)
+ (find-slot-by-name obj-cl slot-name)))
+ ((null slots))
(unless slot
- (error "Slot ~A is not found in class ~S" slot-name obj-cl))
+ (error "Slot ~A is not found in class ~S" slot-name obj-cl))
(push-print-fun-code (id view) slot (length links) print-func)
(when (> (length slots) 1)
- (vector-push-extend '(write-char #\space s) print-func))
+ (vector-push-extend '(write-char #\space s) print-func))
(when (and (view-has-links-p view) (esd-hyperlink slot))
- (push (slot-definition-name slot) links)))
+ (push (slot-definition-name slot) links)))
(vector-push-extend 'x print-func) ;; return object
(setf (obj-data-print-code view) `(lambda (x s links)
- (declare (ignorable s links))
- ,@(map 'list #'identity print-func)))
+ (declare (ignorable s links))
+ ,@(map 'list #'identity print-func)))
(setf (obj-data-printer view)
- (compile nil (eval (obj-data-print-code view))))
+ (compile nil (eval (obj-data-print-code view))))
(setf (link-slots view) (nreverse links)))
((or :xml-link :xml-link-labels)
(initialize-xml-view view)
(setf (link-href-start view)
- "xmllink xlink:type=\"simple\" xlink:href=")
+ "xmllink xlink:type=\"simple\" xlink:href=")
(setf (link-href-end view) "xmllink")
(setf (link-ampersand view) "&"))
((or :ie-xml-link :ie-xml-link-labels)
(defun initialize-text-view (view)
(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)))))
+ (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 (list-start-indent view) t)
(setf (obj-data-indent view) t)
(setf (obj-data-end-printer view) +newline-string+)
(defun initialize-xml-view (view)
(let ((name (string-downcase (symbol-name (object-class view)))))
- (setf (file-start-str view) "") ; (std-xml-header)
+ (setf (file-start-str view) "") ; (std-xml-header)
(setf (list-start-indent view) t)
(setf (list-start-printer view) #'xmlformat-list-start-func)
(setf (list-end-indent view) t)
(defun fmt-file-start (view strm)
(awhen (file-start-str view)
- (write-string it strm)))
+ (write-string it strm)))
(defun fmt-file-end (view strm)
(awhen (file-end-str view)
- (write-string it strm)))
+ (write-string it strm)))
;;; List Start and Ends
(defun fmt-list-start (obj view strm indent num-items)
(when (list-start-indent view)
(awhen (indenter view)
- (funcall it indent strm)))
+ (funcall it indent strm)))
(awhen (list-start-printer view)
- (if (stringp it)
- (write-string it strm)
- (funcall it obj num-items indent strm))))
+ (if (stringp it)
+ (write-string it strm)
+ (funcall it obj num-items indent strm))))
(defun fmt-list-end (obj view strm indent num-items)
(declare (ignore num-items))
(when (list-end-indent view)
(awhen (indenter view)
- (funcall it indent strm)))
+ (funcall it indent strm)))
(awhen (list-end-printer view)
- (if (stringp it)
- (write-string it strm)
- (funcall it obj strm))))
+ (if (stringp it)
+ (write-string it strm)
+ (funcall it obj strm))))
;;; Object Start and Ends
(defun fmt-obj-start (obj view strm indent)
(when (obj-start-indent view)
(awhen (indenter view)
- (funcall it indent strm)))
+ (funcall it indent strm)))
(awhen (obj-start-printer view)
- (if (stringp it)
- (write-string it strm)
- (funcall it obj indent strm))))
+ (if (stringp it)
+ (write-string it strm)
+ (funcall it obj indent strm))))
(defun fmt-obj-end (obj view strm indent)
(when (obj-end-indent view)
(awhen (indenter view)
- (funcall it indent strm)))
+ (funcall it indent strm)))
(awhen (obj-end-printer view)
- (if (stringp it)
- (write-string it strm)
- (funcall it obj strm))))
+ (if (stringp it)
+ (write-string it strm)
+ (funcall it obj strm))))
(defun fmt-subobj-start (obj view strm indent)
(when (subobj-start-indent view)
(awhen (indenter view)
- (funcall it indent strm)))
+ (funcall it indent strm)))
(awhen (subobj-start-printer view)
- (if (stringp it)
- (write-string it strm)
- (funcall it obj indent strm))))
+ (if (stringp it)
+ (write-string it strm)
+ (funcall it obj indent strm))))
(defun fmt-subobj-end (obj view strm indent)
(when (subobj-end-indent view)
(awhen (indenter view)
- (funcall it indent strm)))
+ (funcall it indent strm)))
(awhen (subobj-end-printer view)
- (if (stringp it)
- (write-string it strm)
- (funcall it obj strm))))
+ (if (stringp it)
+ (write-string it strm)
+ (funcall it obj strm))))
;;; Object Data
(write-char #\" s)
(let ((link-page (link-page view)))
(cond
- ((null link-printer)
- (write-string (make-url link-page) s)
- (write-string "?func=" s)
- (write-simple fieldfunc s)
- (write-string (link-ampersand view) s)
- (write-string "key=" s)
- (write-simple fieldvalue s)
- (dolist (var refvars)
- (write-string (link-ampersand view) s)
- (write-simple (car var) s)
- (write-char #\= s)
- (write-simple (cdr var) s)))
- (link-printer
- (funcall link-printer link-page fieldfunc fieldvalue refvars s))))
+ ((null link-printer)
+ (write-string (make-url link-page) s)
+ (write-string "?func=" s)
+ (write-simple fieldfunc s)
+ (write-string (link-ampersand view) s)
+ (write-string "key=" s)
+ (write-simple fieldvalue s)
+ (dolist (var refvars)
+ (write-string (link-ampersand view) s)
+ (write-simple (car var) s)
+ (write-char #\= s)
+ (write-simple (cdr var) s)))
+ (link-printer
+ (funcall link-printer link-page fieldfunc fieldvalue refvars s))))
(write-char #\" s)))
(defun make-link-end (obj view fieldname)
(defun fmt-obj-data (obj view strm indent refvars link-printer)
(awhen (obj-data-start-printer view)
- (if (stringp it)
- (write-string it strm)
- (funcall it obj strm)))
+ (if (stringp it)
+ (write-string it strm)
+ (funcall it obj strm)))
(when (obj-data-indent view)
(awhen (indenter view)
- (funcall it indent strm)))
+ (funcall it indent strm)))
(if (link-slots view)
(fmt-obj-data-with-link obj view strm refvars link-printer)
(fmt-obj-data-plain obj view strm))
(awhen (obj-data-end-printer view)
- (if (stringp it)
- (write-string it strm)
- (funcall it obj strm))))
+ (if (stringp it)
+ (write-string it strm)
+ (funcall it obj strm))))
(defun fmt-obj-data-plain (obj view strm)
(awhen (obj-data-printer view)
- (funcall it obj strm nil)))
+ (funcall it obj strm nil)))
(defun fmt-obj-data-with-link (obj view strm refvars link-printer)
(let ((refvalues '()))
;; make list of hyperlink link fields for printing to refstr template
(dolist (name (link-slots view))
(awhen (find name (hyperobject-class-hyperlinks obj) :key #'name)
- (push (make-link-start view (lookup it) (slot-value obj name)
- (append (link-parameters it) refvars)
- link-printer)
- refvalues)
- (push (make-link-end obj view name) refvalues)))
+ (push (make-link-start view (lookup it) (slot-value obj name)
+ (append (link-parameters it) refvars)
+ link-printer)
+ refvalues)
+ (push (make-link-end obj view name) refvalues)))
(funcall (obj-data-printer view) obj strm (nreverse refvalues))))
(defun obj-data (obj view)
(dolist (obj (mklist objs))
(dolist (subobj (hyperobject-class-subobjects obj))
(awhen (slot-value obj (name-slot subobj))
- (load-all-subobjects it))))
+ (load-all-subobjects it))))
objs)
(defun view-subobjects (obj strm &optional vid (indent 0) filter
- subobjects refvars link-printer)
+ subobjects refvars link-printer)
(when (hyperobject-class-subobjects obj)
(dolist (subobj (hyperobject-class-subobjects obj))
(aif (slot-value obj (name-slot subobj))
- (view-hyperobject
- it (get-view-id (car (mklist it)) vid)
- strm vid (1+ indent) filter subobjects refvars
- link-printer)))))
+ (view-hyperobject
+ it (get-view-id (car (mklist it)) vid)
+ strm vid (1+ indent) filter subobjects refvars
+ link-printer)))))
(defun view-hyperobject (objs view strm &optional vid (indent 0) filter
- subobjects refvars link-printer)
+ subobjects refvars link-printer)
"Display a single or list of hyperobject-class instances and their subobjects"
(let-when (objlist (mklist objs))
(let ((nobjs (length objlist))
- (*print-pretty* nil)
- (*print-circle* nil)
- (*print-escape* nil)
- (*print-readably* nil)
- (*print-length* nil)
- (*print-level* nil))
+ (*print-pretty* nil)
+ (*print-circle* nil)
+ (*print-escape* nil)
+ (*print-readably* nil)
+ (*print-length* nil)
+ (*print-level* nil))
(fmt-list-start (car objlist) view strm indent nobjs)
(dolist (obj objlist)
- (awhen (printer view)
- (funcall it obj strm))
- (unless (and filter (not (funcall filter obj)))
- (fmt-obj-start obj view strm indent)
- (fmt-obj-data obj view strm (1+ indent) refvars link-printer)
- (fmt-obj-end obj view strm indent)
- (if subobjects
- (progn
- (fmt-subobj-start obj view strm indent)
- (view-subobjects obj strm vid indent filter subobjects
- refvars link-printer)
- (fmt-subobj-end obj view strm indent))
- (fmt-subobj-start obj view strm indent))))
+ (awhen (printer view)
+ (funcall it obj strm))
+ (unless (and filter (not (funcall filter obj)))
+ (fmt-obj-start obj view strm indent)
+ (fmt-obj-data obj view strm (1+ indent) refvars link-printer)
+ (fmt-obj-end obj view strm indent)
+ (if subobjects
+ (progn
+ (fmt-subobj-start obj view strm indent)
+ (view-subobjects obj strm vid indent filter subobjects
+ refvars link-printer)
+ (fmt-subobj-end obj view strm indent))
+ (fmt-subobj-start obj view strm indent))))
(fmt-list-end (car objlist) view strm indent nobjs)))
objs)
(defun view (objs &key (stream *standard-output*) vid view
- filter subobjects refvars file-wrapper link-printer)
+ filter subobjects refvars file-wrapper link-printer)
"EXPORTED Function: prints hyperobject-class objects. Calls view-hyperobject"
(let-when (objlist (mklist objs))
(unless view
(when file-wrapper
(fmt-file-start view stream))
(view-hyperobject objlist view stream vid 0 filter subobjects refvars
- link-printer)
+ link-printer)
(when file-wrapper
(fmt-file-end view stream)))
objs)
projects / hyperobject.git / commitdiff