X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=ml-class.lisp;fp=ml-class.lisp;h=0000000000000000000000000000000000000000;hb=02f38fa2c971c7300bd1e352d1a242e4f8e6543c;hp=9b5f08520927d14d8edfd91a92b4aa9c29454adc;hpb=5d54e9901ab17fe4c744ef4f68727e89fbd98df5;p=kmrcl.git diff --git a/ml-class.lisp b/ml-class.lisp deleted file mode 100644 index 9b5f085..0000000 --- a/ml-class.lisp +++ /dev/null @@ -1,739 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: ml-class.lisp -;;;; Purpose: Markup Language Metaclass -;;;; Programmer: Kevin M. Rosenberg -;;;; Date Started: Apr 2000 -;;;; -;;;; This metaclass as functions to classes to allow display -;;;; in Text, HTML, and XML formats. This includes hyperlinking -;;;; capability and sub-objects. -;;;; -;;;; $Id: ml-class.lisp,v 1.21 2002/10/18 07:28:57 kevin Exp $ -;;;; -;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; -;;;; KMRCL users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(in-package :kmrcl) - -(declaim (optimize (speed 3) (safety 1))) - -(defun ml-class-of (obj) - #-(or cmu sbcl) (class-of obj) - #+sbcl (sb-pcl:class-of obj) - #+cmu (pcl:class-of obj)) - -(defun ml-class-name (obj) - #-(or cmu sbcl) (class-name obj) - #+sbcl (sb-pcl:class-name obj) - #+cmu (pcl:class-name obj)) - -(defclass ml-class (#-(or cmu sbcl) standard-class - #+cmu pcl::standard-class - #+sbcl sb-pcl::standard-class) - ((title :initarg :title :type string :reader ml-std-title - :documentation -"Print Title for class") - (fields :initarg :fields :reader ml-std-fields - :documentation -"List of field lists for printing. Format is - ((fieldname type optional-formatter) ... )") - (subobjects-lists - :initarg :subobjects-lists :reader ml-std-subobjects-lists - :documentation -"List of fields that contain a list of subobjects objects.") - (ref-fields - :initarg :ref-fields :type list :reader ml-std-ref-field - :documentation - "List of fields that can be referred to by browsers. -Format is ((field-name field-lookup-func other-link-params) ...)") - - ;;; The remainder of these fields are calculated one time - ;;; in finalize-inheritence. - (value-func :initform nil :type function :reader ml-std-value-func) - (xmlvalue-func :initform nil :type function :reader ml-std-xmlvalue-func) - (fmtstr-text :initform nil :type string :reader ml-std-fmtstr-text) - (fmtstr-html :initform nil :type string :reader ml-std-fmtstr-html) - (fmtstr-xml :initform nil :type string :reader ml-std-fmtstr-xml) - (fmtstr-text-labels :initform nil :type string :reader ml-std-fmtstr-text-labels) - (fmtstr-html-labels :initform nil :type string :reader ml-std-fmtstr-html-labels) - (fmtstr-xml-labels :initform nil :type string :reader ml-std-fmtstr-xml-labels) - (fmtstr-html-ref :initform nil :type string :reader ml-std-fmtstr-html-ref) - (fmtstr-xml-ref :initform nil :type string :reader ml-std-fmtstr-xml-ref) - (fmtstr-html-ref-labels :initform nil :type string :reader ml-std-fmtstr-html-ref-labels) - (fmtstr-xml-ref-labels :initform nil :type string :reader ml-std-fmtstr-xml-ref-labels) - ) - (:default-initargs :title nil :fields nil :subobjects-lists nil :ref-fields nil) - (:documentation "Metaclass for Markup Language classes.")) - -#+cmu -(defmethod pcl:finalize-inheritance :after ((cl ml-class)) - (init-ml-class cl)) - -#+scl -(defmethod clos:finalize-inheritance :after ((cl ml-class)) - (init-ml-class cl)) - - -#+sbcl -(defmethod sb-pcl:finalize-inheritance :after ((cl ml-class)) - (init-ml-class cl)) - - -#+cmu -(defmethod pcl:validate-superclass ((class ml-class) (superclass pcl::standard-class)) - t) - -#+scl -(defmethod clos:validate-superclass ((class ml-class) (superclass standard-class)) - t) - -#+sbcl -(defmethod sb-pcl:validate-superclass ((class ml-class) (superclass sb-pcl::standard-class)) - t) - -#+allegro -(defmethod mop:finalize-inheritance :after ((cl ml-class)) - (init-ml-class cl)) - -#+lispworks -(defmethod clos:finalize-inheritance :after ((cl ml-class)) - (init-ml-class cl)) - -#+lispworks -(defmethod clos:process-a-class-option ((class ml-class) - (name (eql :title)) - value) - (unless value - (error "ml-class title must have a value")) - (if (null (cdr value)) - (list name (car value)) - (list name `',value))) - -#+lispworks -(defmethod clos:process-a-class-option ((class ml-class) - (name (eql :fields)) - value) - (unless value - (error "ml-class fields must have a value")) - (list name `',value)) - -#+lispworks -(defmethod clos:process-a-class-option ((class ml-class) - (name (eql :ref-fields)) - value) - (unless value - (error "ml-class ref-fields must have a value")) - (list name `',value)) - -#+lispworks -(defmethod clos:process-a-class-option ((class ml-class) - (name (eql :subobjects-lists)) - value) - (unless value - (error "ml-class subobjects-lists must have a value")) - (list name `',value)) - -;;;; Class initialization function - -(defun init-ml-class (cl) - (let ((fmtstr-text "") - (fmtstr-html "") - (fmtstr-xml "") - (fmtstr-text-labels "") - (fmtstr-html-labels "") - (fmtstr-xml-labels "") - (fmtstr-html-ref "") - (fmtstr-xml-ref "") - (fmtstr-html-ref-labels "") - (fmtstr-xml-ref-labels "") - (first-field t) - (value-func '()) - (xmlvalue-func '()) - (classname (class-name cl)) - (package (symbol-package (ml-class-name cl))) - (ref-fields (slot-value cl 'ref-fields))) - (declare (ignore classname)) - (dolist (f (slot-value cl 'fields)) - (let ((name (car f)) - (namestr (symbol-name (car f))) - (namestr-lower (string-downcase (symbol-name (car f)))) - (type (cadr f)) - (formatter (caddr f)) - (value-fmt "~a") - (plain-value-func nil) - html-str xml-str html-label-str xml-label-str) - - (when (or (eql type :integer) (eql type :fixnum)) - (setq value-fmt "~d")) - - (when (eql type :commainteger) - (setq value-fmt "~:d")) - - (when (eql type :boolean) - (setq value-fmt "~a")) - - (if first-field - (setq first-field nil) - (progn - (string-append fmtstr-text " ") - (string-append fmtstr-html " ") - (string-append fmtstr-xml " ") - (string-append fmtstr-text-labels " ") - (string-append fmtstr-html-labels " ") - (string-append fmtstr-xml-labels " ") - (string-append fmtstr-html-ref " ") - (string-append fmtstr-xml-ref " ") - (string-append fmtstr-html-ref-labels " ") - (string-append fmtstr-xml-ref-labels " "))) - - (setq html-str (concatenate 'string "" value-fmt "")) - (setq xml-str (concatenate 'string "<" namestr-lower ">" value-fmt "" namestr-lower ">")) - (setq html-label-str (concatenate 'string "" namestr-lower " " value-fmt "")) - (setq xml-label-str (concatenate 'string " <" namestr-lower ">" value-fmt "" namestr-lower ">")) - - (string-append fmtstr-text value-fmt) - (string-append fmtstr-html html-str) - (string-append fmtstr-xml xml-str) - (string-append fmtstr-text-labels namestr-lower " " value-fmt) - (string-append fmtstr-html-labels html-label-str) - (string-append fmtstr-xml-labels xml-label-str) - - (if (find name ref-fields :key #'car) - (progn - (string-append fmtstr-html-ref "<~~a>" value-fmt "~~a>") - (string-append fmtstr-xml-ref "<~~a>" value-fmt "~~a>") - (string-append fmtstr-html-ref-labels "" namestr-lower " <~~a>" value-fmt "~~a>") - (string-append fmtstr-xml-ref-labels " <~~a>" value-fmt "~~a>")) - (progn - (string-append fmtstr-html-ref html-str) - (string-append fmtstr-xml-ref xml-str) - (string-append fmtstr-html-ref-labels html-label-str) - (string-append fmtstr-xml-ref-labels xml-label-str))) - - (if formatter - (setq plain-value-func - (list `(,formatter (,(intern namestr package) x)))) - (setq plain-value-func - (list `(,(intern namestr package) x)))) - (setq value-func (append value-func plain-value-func)) - - (if (eql type :cdata) - (setq xmlvalue-func (append xmlvalue-func (list `(xml-cdata ,@plain-value-func)))) - (setq xmlvalue-func (append xmlvalue-func plain-value-func))) - )) - - (if value-func - (setq value-func `(lambda (x) (values ,@value-func))) - (setq value-func `(lambda () (values)))) - (setq value-func (compile nil (eval value-func))) - - (if xmlvalue-func - (setq xmlvalue-func `(lambda (x) (values ,@xmlvalue-func))) - (setq xmlvalue-func `(lambda () (values)))) - (setq xmlvalue-func (compile nil (eval xmlvalue-func))) - - (setf (slot-value cl 'fmtstr-text) fmtstr-text) - (setf (slot-value cl 'fmtstr-html) fmtstr-html) - (setf (slot-value cl 'fmtstr-xml) fmtstr-xml) - (setf (slot-value cl 'fmtstr-text-labels) fmtstr-text-labels) - (setf (slot-value cl 'fmtstr-html-labels) fmtstr-html-labels) - (setf (slot-value cl 'fmtstr-xml-labels) fmtstr-xml-labels) - (setf (slot-value cl 'fmtstr-html-ref) fmtstr-html-ref) - (setf (slot-value cl 'fmtstr-xml-ref) fmtstr-xml-ref) - (setf (slot-value cl 'fmtstr-html-ref-labels) fmtstr-html-ref-labels) - (setf (slot-value cl 'fmtstr-xml-ref-labels) fmtstr-xml-ref-labels) - (setf (slot-value cl 'value-func) value-func) - (setf (slot-value cl 'xmlvalue-func) xmlvalue-func)) - (values)) - - -(defun ml-class-fmtstr-text (obj) - (slot-value (ml-class-of obj) 'fmtstr-text)) - -(defun ml-class-fmtstr-html (obj) - (slot-value (ml-class-of obj) 'fmtstr-html)) - -(defun ml-class-fmtstr-xml (obj) - (slot-value (ml-class-of obj) 'fmtstr-xml)) - -(defun ml-class-fmtstr-text-labels (obj) - (slot-value (ml-class-of obj) 'fmtstr-text-labels)) - -(defun ml-class-fmtstr-html-labels (obj) - (slot-value (ml-class-of obj) 'fmtstr-html-labels)) - -(defun ml-class-fmtstr-xml-labels (obj) - (slot-value (ml-class-of obj) 'fmtstr-xml-labels)) - -(defun ml-class-value-func (obj) - (slot-value (ml-class-of obj) 'value-func)) - -(defun ml-class-xmlvalue-func (obj) - (slot-value (ml-class-of obj) 'xmlvalue-func)) - -(eval-when (:compile-toplevel :load-toplevel :execute) -(defun ml-class-title (obj) - (awhen (slot-value (ml-class-of obj) 'title) - (if (consp it) - (car it) - it)))) - -(defun ml-class-subobjects-lists (obj) - (slot-value (ml-class-of obj) 'subobjects-lists)) - -(defun ml-class-ref-fields (obj) - (slot-value (ml-class-of obj) 'ref-fields)) - -(defun ml-class-fields (obj) - (slot-value (ml-class-of obj) 'fields)) - -(defun ml-class-fmtstr-html-ref (obj) - (slot-value (ml-class-of obj) 'fmtstr-html-ref)) - -(defun ml-class-fmtstr-xml-ref (obj) - (slot-value (ml-class-of obj) 'fmtstr-xml-ref)) - -(defun ml-class-fmtstr-html-ref-labels (obj) - (slot-value (ml-class-of obj) 'fmtstr-html-ref-labels)) - -(defun ml-class-fmtstr-xml-ref-labels (obj) - (slot-value (ml-class-of obj) 'fmtstr-xml-ref-labels)) - -;;; Class name functions - -(defgeneric ml-class-stdname (x)) -(defmethod ml-class-stdname ((name string)) - (string-downcase (subseq name 1))) - -(defmethod ml-class-stdname ((cl standard-object)) - (string-downcase (subseq (ml-class-name (ml-class-of cl)) 1))) - -;;;; Generic Print functions - -(defparameter *default-textformat* nil) -(defparameter *default-htmlformat* nil) -(defparameter *default-htmlrefformat* nil) -(defparameter *default-xhtmlformat* nil) -(defparameter *default-xhtmlrefformat* nil) -(defparameter *default-xmlformat* nil) -(defparameter *default-xmlrefformat* nil) -(defparameter *default-ie-xmlrefformat* nil) -(defparameter *default-nullformat* nil) -(defparameter *default-init-format?* nil) - -(defun make-format-instance (fmt) - (unless *default-init-format?* - (setq *default-textformat* (make-instance 'textformat)) - (setq *default-htmlformat* (make-instance 'htmlformat)) - (setq *default-htmlrefformat* (make-instance 'htmlrefformat)) - (setq *default-xhtmlformat* (make-instance 'xhtmlformat)) - (setq *default-xhtmlrefformat* (make-instance 'xhtmlrefformat)) - (setq *default-xmlformat* (make-instance 'xmlformat)) - (setq *default-xmlrefformat* (make-instance 'xmlrefformat)) - (setq *default-ie-xmlrefformat* (make-instance 'ie-xmlrefformat)) - (setq *default-nullformat* (make-instance 'nullformat)) - (setq *default-init-format?* t)) - - (case fmt - (:text *default-textformat*) - (:html *default-htmlformat*) - (:htmlref *default-htmlrefformat*) - (:xhtml *default-xhtmlformat*) - (:xhtmlref *default-xhtmlrefformat*) - (:xml *default-xmlformat*) - (:xmlref *default-xmlrefformat*) - (:ie-xmlref *default-ie-xmlrefformat*) - (:null *default-nullformat*) - (otherwise *default-textformat*))) - -;;;; Output format classes for print ml-classes - -(defclass dataformat () - ((file-start-str :type string :initarg :file-start-str :reader file-start-str) - (file-end-str :type string :initarg :file-end-str :reader file-end-str) - (list-start-fmtstr :type string :initarg :list-start-fmtstr :reader list-start-fmtstr) - (list-start-value-func :type function :initarg :list-start-value-func :reader list-start-value-func) - (list-start-indent :initarg :list-start-indent :reader list-start-indent) - (list-end-fmtstr :type string :initarg :list-end-fmtstr :reader list-end-fmtstr) - (list-end-value-func :type function :initarg :list-end-value-func :reader list-end-value-func) - (list-end-indent :initarg :list-end-indent :reader list-end-indent) - (obj-start-fmtstr :type string :initarg :obj-start-fmtstr :reader obj-start-fmtstr) - (obj-start-value-func :initarg :obj-start-value-func :reader obj-start-value-func) - (obj-start-indent :initarg :obj-start-indent :reader obj-start-indent) - (obj-end-fmtstr :type string :initarg :obj-end-fmtstr :reader obj-end-fmtstr) - (obj-end-value-func :initarg :obj-end-value-func :reader obj-end-value-func) - (obj-end-indent :initarg :obj-end-indent :reader obj-end-indent) - (obj-data-indent :initarg :obj-data-indent :reader obj-data-indent) - (obj-data-fmtstr :initarg :obj-data-fmtstr :reader obj-data-fmtstr) - (obj-data-fmtstr-labels :initarg :obj-data-fmtstr-labels :reader obj-data-fmtstr-labels) - (obj-data-end-fmtstr :initarg :obj-data-end-fmtstr :reader obj-data-end-fmtstr) - (obj-data-value-func :initarg :obj-data-value-func :reader obj-data-value-func) - (link-ref :initarg :link-ref :reader link-ref)) - (:default-initargs :file-start-str nil :file-end-str nil :list-start-fmtstr nil :list-start-value-func nil - :list-start-indent nil :list-end-fmtstr nil :list-end-value-func nil :list-end-indent nil - :obj-start-fmtstr nil :obj-start-value-func nil :obj-start-indent nil - :obj-end-fmtstr nil :obj-end-value-func nil :obj-end-indent nil - :obj-data-indent nil :obj-data-fmtstr nil :obj-data-fmtstr-labels nil :obj-data-end-fmtstr nil - :obj-data-value-func nil :link-ref nil) - (:documentation "Parent for all dataformat objects")) - -(defclass binaryformat (dataformat) - ()) - -(defclass nullformat (dataformat) - ()) - -(defun text-list-start-value-func (obj nitems) - (values (ml-class-title obj) nitems)) - -(defclass textformat (dataformat) - () - (:default-initargs :list-start-fmtstr "~a~P:~%" - :list-start-value-func #'text-list-start-value-func - :list-start-indent t - :obj-data-indent t - :obj-data-fmtstr #'ml-class-fmtstr-text - :obj-data-fmtstr-labels #'ml-class-fmtstr-text-labels - :obj-data-end-fmtstr "~%" - :obj-data-value-func #'ml-class-value-func)) - - -(defun class-name-of (obj) - (string-downcase (ml-class-name (ml-class-of obj)))) - -(defun htmlformat-list-start-value-func (x nitems) - (values (ml-class-title x) nitems (class-name-of x))) - -(defclass htmlformat (textformat) - () - (:default-initargs :file-start-str "
~%" - :file-end-str "~%" - :list-start-indent t - :list-start-fmtstr "~a~p:
~a~p: