;;;;
;;;; This is a rewrite of hyperobjec't to avoid using metaclasses.
;;;;
-;;;; $Id: hyperobject-no-mop.lisp,v 1.1 2002/11/22 15:43:22 kevin Exp $
+;;;; $Id: hyperobject-no-mop.lisp,v 1.6 2002/11/25 07:45:35 kevin Exp $
;;;;
;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
;;;;
;;;; *************************************************************************
-
-(in-package :hyperobject)
+
+
+(defpackage #:hyperobject-no-mop
+ (:nicknames #:ho-no-mop)
+ (:use #:common-lisp #:kmrcl)
+ (:export
+ #:define-hyperobject
+ #:hyperobject
+ #:hyperobject-base-url!
+ #:load-all-subobjects
+ #:print-hyperobject
+ ))
+
+(defpackage #:hyperobject-no-mop-user
+ (:nicknames #:ho-no-mop-user)
+ (:use #:hyperobject-no-mop #:cl #:cl-user))
+
+(in-package :hyperobject-no-mop)
(eval-when (:compile-toplevel :execute)
(defclass field ()
((name :type symbol :initform nil :initarg :name :reader name)
- (format-func :initform nil :initarg :format-func :reader format-func)
+ (print-formatter :initform nil :initarg :print-formatter :reader print-formatter)
(cl-type :initform nil :reader cl-type)
(ho-type :initform nil :reader ho-type)
(subobject :initform nil :reader subobject)
(name &rest rest &key
;; the following list of keywords is reproduced below in the
;; remove-keys form. important to keep them in sync
- type reader writer accessor initform format-func initarg
+ type reader writer accessor initform print-formatter initarg
reference subobject
;; list ends
&allow-other-keys) field
(let ((other-args (remove-keys
- '(type reader writer accessor initform format-func
+ '(type reader writer accessor initform print-formatter
initarg reference subobject)
rest))
(field-obj (make-instance 'field :name name))
(push field-obj fields)
(loop for (k v) in `((:type ,type) (:reader ,reader) (:writer ,writer)
(:accessor ,accessor) (:initform ,initform)
- (:format-func ,format-func) (:initarg ,initarg)
+ (:print-formatter ,print-formatter) (:initarg ,initarg)
(:subobject ,subobject) (:reference ,reference))
do
(case k
(:accessor
(when v
(push (list :accessor v) kv)))
- (:format-func
+ (:print-formatter
(when v
- (setf (slot-value field-obj 'format-func) v)))
+ (setf (slot-value field-obj 'print-formatter) v)))
(:writer
(when v
(push (list :writer v) kv)))
(symbol-name doc)
doc)))
-(defun fmt-comma-integer (i)
- (format nil "~:d" i))
-
;;;; Class initialization function
(defun init-hyperobject-class (name meta)
(let ((fmtstr-text "")
(xml-value-func '())
(package (symbol-package name)))
(dolist (field (slot-value meta 'fields))
- (declare (ignore rest))
(let* ((name (name field))
- (format-func (format-func field))
+ (print-formatter (print-formatter field))
(type (ho-type field))
(reference (reference field))
(namestr (symbol-name name))
(string-append fmtstr-html-ref-labels html-label-str)
(string-append fmtstr-xml-ref-labels xml-label-str)))
- (if format-func
+ (if print-formatter
(setq plain-value-func
- (list `(,format-func (,(intern namestr package) x))))
+ (list `(,print-formatter (,(intern namestr package) x))))
(setq plain-value-func
(list `(,(intern namestr package) x))))
(setq value-func (append value-func plain-value-func))