From 4a772392fd77659637f19c6d0b69584974a40074 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Fri, 31 Aug 2007 18:04:31 +0000 Subject: [PATCH] r11859: Canonicalize whitespace --- base-class.lisp | 2 +- connect.lisp | 8 +- examples/person.lisp | 54 +++--- metaclass.lisp | 2 +- mop.lisp | 304 +++++++++++++++--------------- package.lisp | 14 +- rules.lisp | 50 ++--- sql.lisp | 154 +++++++-------- tests.lisp | 64 +++---- views.lisp | 434 +++++++++++++++++++++---------------------- 10 files changed, 543 insertions(+), 543 deletions(-) diff --git a/base-class.lisp b/base-class.lisp index e4becfe..8c2780b 100644 --- a/base-class.lisp +++ b/base-class.lisp @@ -23,5 +23,5 @@ (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))) diff --git a/connect.lisp b/connect.lisp index 7f5238a..e0495fc 100644 --- a/connect.lisp +++ b/connect.lisp @@ -51,8 +51,8 @@ (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" @@ -64,7 +64,7 @@ (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)) @@ -78,7 +78,7 @@ (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) diff --git a/examples/person.lisp b/examples/person.lisp index 5a91b6a..44659db 100644 --- a/examples/person.lisp +++ b/examples/person.lisp @@ -14,61 +14,61 @@ ;;;; 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") @@ -85,16 +85,16 @@ (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~%") diff --git a/metaclass.lisp b/metaclass.lisp index a4d21f4..264afa7 100644 --- a/metaclass.lisp +++ b/metaclass.lisp @@ -12,7 +12,7 @@ ;;;; ;;;; This file is Copyright (c) 2000-2006 by Kevin M. Rosenberg ;;;; ************************************************************************* - + (in-package #:hyperobject) (defparameter *class-options* diff --git a/mop.lisp b/mop.lisp index 9f66bf2..093861f 100644 --- a/mop.lisp +++ b/mop.lisp @@ -23,52 +23,52 @@ (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) @@ -76,9 +76,9 @@ (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.")) @@ -90,7 +90,7 @@ (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) @@ -101,7 +101,7 @@ (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)) @@ -116,7 +116,7 @@ ;; :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) @@ -135,37 +135,37 @@ (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 @@ -212,7 +212,7 @@ (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)) @@ -222,30 +222,30 @@ (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)) @@ -255,10 +255,10 @@ (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)) @@ -267,10 +267,10 @@ (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)) @@ -284,31 +284,31 @@ (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) @@ -335,38 +335,38 @@ (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)) @@ -375,20 +375,20 @@ 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*)) @@ -430,28 +430,28 @@ SQL name" (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 @@ -462,29 +462,29 @@ SQL name" (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) @@ -531,27 +531,27 @@ SQL 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)) diff --git a/package.lisp b/package.lisp index 89aa5cc..509b34e 100644 --- a/package.lisp +++ b/package.lisp @@ -23,7 +23,7 @@ #+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*))) @@ -31,12 +31,12 @@ (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 diff --git a/rules.lisp b/rules.lisp index dad93ad..00d64b5 100644 --- a/rules.lisp +++ b/rules.lisp @@ -11,7 +11,7 @@ ;;;; ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg ;;;; ************************************************************************* - + (in-package #:hyperobject) ;;; Slot accessor and class rules @@ -28,26 +28,26 @@ (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) @@ -55,8 +55,8 @@ (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 @@ -65,15 +65,15 @@ #+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))))))) diff --git a/sql.lisp b/sql.lisp index 224652a..294effe 100644 --- a/sql.lisp +++ b/sql.lisp @@ -18,44 +18,44 @@ (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 @@ -99,18 +99,18 @@ (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)) @@ -134,46 +134,46 @@ (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)))) @@ -181,42 +181,42 @@ (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)) ||# diff --git a/tests.lisp b/tests.lisp index d6a7d2e..ff66b6f 100644 --- a/tests.lisp +++ b/tests.lisp @@ -21,27 +21,27 @@ (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) @@ -50,17 +50,17 @@ (: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)) @@ -72,12 +72,12 @@ (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) @@ -93,18 +93,18 @@ (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) diff --git a/views.lisp b/views.lisp index a90064a..db6bba6 100644 --- a/views.lisp +++ b/views.lisp @@ -17,78 +17,78 @@ (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")) @@ -101,16 +101,16 @@ "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) @@ -119,14 +119,14 @@ (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 @@ -136,10 +136,10 @@ "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" @@ -152,17 +152,17 @@ :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)) @@ -183,20 +183,20 @@ (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))))) @@ -214,12 +214,12 @@ (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 " (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))) @@ -424,7 +424,7 @@ ((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) @@ -452,12 +452,12 @@ (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+) @@ -584,7 +584,7 @@ (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) @@ -601,32 +601,32 @@ (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 @@ -634,38 +634,38 @@ (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 @@ -676,20 +676,20 @@ (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) @@ -698,23 +698,23 @@ (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 '())) @@ -722,11 +722,11 @@ ;; 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) @@ -741,52 +741,52 @@ (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 @@ -794,7 +794,7 @@ (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) -- 2.34.1