mop.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-\r
   2 ;;;; *************************************************************************\r
   3 ;;;; FILE IDENTIFICATION\r
   4 ;;;;\r
   5 ;;;; Name:          mop.lisp\r
   6 ;;;; Purpose:       Metaobject Protocol Interface\r
   7 ;;;; Programmer:    Kevin M. Rosenberg\r
   8 ;;;; Date Started:  Apr 2000\r
   9 ;;;;\r
  10 ;;;; This metaclass as functions to classes to allow display\r
  11 ;;;; in Text, HTML, and XML formats. This includes hyperlinking\r
  12 ;;;; capability and sub-objects.\r
  13 ;;;;\r
  14 ;;;; $Id: mop.lisp,v 1.85 2003/07/29 20:49:05 kevin Exp $\r
  15 ;;;;\r
  16 ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg\r
  17 ;;;; *************************************************************************\r
  18  \r
  19 (in-package #:hyperobject)\r
  20 \r
  21 ;; Main class\r
  22 \r
  23 (defclass hyperobject-class (standard-class)\r
  24   ( ;; slots initialized in defclass\r
  25    (user-name :initarg :user-name :type string :initform nil\r
  26               :accessor user-name\r
  27               :documentation "User name for class")\r
  28    (user-name-plural :initarg :user-name-plural :type string :initform nil\r
  29                      :accessor user-name-plural\r
  30                      :documentation "Plural user name for class")\r
  31    (default-print-slots :initarg :default-print-slots :type list :initform nil\r
  32                         :accessor default-print-slots\r
  33                         :documentation "Defaults slots for a view")\r
  34    (description :initarg :description :initform nil\r
  35                 :accessor description\r
  36                 :documentation "Class description")\r
  37    (version :initarg :version :initform nil\r
  38             :accessor version\r
  39             :documentation "Version number for class")\r
  40    (closures :initarg :closures :initform nil\r
  41              :accessor closures\r
  42              :documentation "Closures to call on slot chnages")\r
  43    (sql-name :initarg :sql-name :accessor sql-name :initform nil\r
  44              :documentation "SQL Name for this class")\r
  45    (guid :initarg :guid :accessor guid :initform nil\r
  46          :documentation "ID string for this class")\r
  47 \r
  48    ;;; The remainder of these fields are calculated one time\r
  49    ;;; in finalize-inheritence.\r
  50    \r
  51    (subobjects :initform nil :accessor subobjects\r
  52                :documentation\r
  53                "List of fields that contain a list of subobjects objects.")\r
  54    (hyperlinks :type list :initform nil :accessor hyperlinks\r
  55                :documentation "List of fields that have hyperlinks")\r
  56    (direct-rules :type list :initform nil :initarg :direct-rules\r
  57                  :accessor direct-rules\r
  58                  :documentation "List of rules to fire on slot changes.")\r
  59    (direct-views :type list :initform nil :initarg :direct-views\r
  60                  :accessor direct-views\r
  61                  :documentation "List of views")\r
  62    (class-id :type integer :initform nil\r
  63              :accessor class-id\r
  64              :documentation "Unique ID for the class")\r
  65    (default-view :initform nil :initarg :default-view :accessor default-view\r
  66                  :documentation "The default view for a class")\r
  67 \r
  68    ;; SQL commands\r
  69    (create-table-cmd :initform nil :reader create-table-cmd)\r
  70    (create-indices-cmds :initform nil :reader create-index-cmds)\r
  71    (drop-table-cmd :initform nil :reader drop-table-cmd)\r
  72 \r
  73    (views :type list :initform nil :initarg :views :accessor views\r
  74           :documentation "List of views")\r
  75    (rules :type list :initform nil :initarg :rules :accessor rules\r
  76           :documentation "List of rules")\r
  77    )\r
  78   (:documentation "Metaclass for Markup Language classes."))\r
  79 \r
  80 (defclass subobject ()\r
  81   ((name-class :type symbol :initarg :name-class :reader name-class)\r
  82    (name-slot :type symbol :initarg :name-slot :reader name-slot)\r
  83    (subobj-class :type symbol :initarg :subobj-class :reader subobj-class)\r
  84    (lookup :type (or function symbol) :initarg :lookup :reader lookup)\r
  85    (lookup-keys :type list :initarg :lookup-keys :reader lookup-keys))\r
  86   (:documentation "subobject information")\r
  87   (:default-initargs :name-class nil :name-slot nil :subobj-class nil\r
  88                      :lookup nil :lookup-keys nil))\r
  89 \r
  90 \r
  91 (defmethod print-object ((obj subobject) (s stream))\r
  92   (print-unreadable-object (obj s :type t)\r
  93     (format s "~S" (name-slot obj))))\r
  94 \r
  95 (defclass hyperlink ()\r
  96   ((name :type symbol :initform nil :initarg :name :reader name)\r
  97    (lookup\r
  98     ;; The type specifier seems to break sbcl\r
  99     :type (or function symbol)\r
 100     ;;    :type t\r
 101     :initform nil :initarg :lookup :reader lookup)\r
 102    (link-parameters :type list :initform nil :initarg :link-parameters\r
 103                     :reader link-parameters)))\r
 104 \r
 105 (defmethod print-object ((obj hyperlink) (s stream))\r
 106   (print-unreadable-object (obj s :type t :identity t)\r
 107     (format s "~S" (name obj))))\r
 108 \r
 109 (defmethod validate-superclass ((class hyperobject-class) (superclass standard-class))\r
 110   t)\r
 111 \r
 112 (defmethod finalize-inheritance :after ((cl hyperobject-class))\r
 113   ;; Work-around needed for OpenMCL\r
 114   #+ignore\r
 115   (unless (find-class (class-name cl))\r
 116     (setf (find-class (class-name cl)) cl))\r
 117   \r
 118   (init-hyperobject-class cl)\r
 119   )\r
 120 \r
 121 (eval-when (:compile-toplevel :load-toplevel :execute)\r
 122   (when (>= (length (generic-function-lambda-list\r
 123                      (ensure-generic-function\r
 124                       'compute-effective-slot-definition)))\r
 125             3)\r
 126     (pushnew :ho-normal-cesd cl:*features*))\r
 127   \r
 128     (when (>= (length (generic-function-lambda-list\r
 129                        (ensure-generic-function\r
 130                         'direct-slot-definition-class)))\r
 131             3)\r
 132       (pushnew :ho-normal-dsdc cl:*features*))\r
 133     \r
 134     (when (>= (length (generic-function-lambda-list\r
 135                        (ensure-generic-function\r
 136                         'effective-slot-definition-class)))\r
 137               3)\r
 138       (pushnew :ho-normal-esdc cl:*features*)))\r
 139 \r
 140 ;; Slot definitions\r
 141 (defmethod direct-slot-definition-class ((cl hyperobject-class)\r
 142                                          #+ho-normal-dsdc &rest iargs)\r
 143   (find-class 'hyperobject-dsd))\r
 144 \r
 145 (defmethod effective-slot-definition-class ((cl hyperobject-class) \r
 146                                             #+ho-normal-esdc &rest iargs)\r
 147   (find-class 'hyperobject-esd))\r
 148 \r
 149 \r
 150 ;;; Slot definitions\r
 151 \r
 152 (eval-when (:compile-toplevel :load-toplevel :execute)\r
 153   (defmacro process-class-option (slot-name &optional required)\r
 154     #+lispworks\r
 155     `(defmethod clos:process-a-class-option ((class hyperobject-class)\r
 156                                              (name (eql ,slot-name))\r
 157                                              value)\r
 158       (when (and ,required (null value))\r
 159         (error "hyperobject class slot ~A must have a value" name))\r
 160       (list name `',value))\r
 161     #+(or allegro sbcl cmu scl openmcl)\r
 162     (declare (ignore slot-name required))\r
 163     )\r
 164 \r
 165   (defmacro process-slot-option (slot-name)\r
 166     #+lispworks\r
 167     `(defmethod clos:process-a-slot-option ((class hyperobject-class)\r
 168                                             (option (eql ,slot-name))\r
 169                                             value\r
 170                                             already-processed-options\r
 171                                             slot)\r
 172       (list* option `',value already-processed-options))\r
 173     #-lispworks\r
 174     (declare (ignore slot-name))\r
 175     )\r
 176   \r
 177   (dolist (option *class-options*)\r
 178     (eval `(process-class-option ,option)))\r
 179   (dolist (option *slot-options*)\r
 180     (eval `(process-slot-option ,option)))\r
 181 \r
 182   (eval\r
 183    `(defclass hyperobject-dsd (standard-direct-slot-definition)\r
 184      (,@(mapcar #'(lambda (x)\r
 185                     `(,(intern (symbol-name x))\r
 186                       :initform nil))\r
 187                 *slot-options-no-initarg*)\r
 188       ,@(mapcar #'(lambda (x)\r
 189                     `(,(intern (symbol-name x))\r
 190                       :initarg\r
 191                       ,(intern (symbol-name x) (symbol-name :keyword))\r
 192                       :initform nil\r
 193                       :accessor\r
 194                       ,(intern (concatenate 'string\r
 195                                             (symbol-name :dsd-)\r
 196                                             (symbol-name x)))))\r
 197                 *slot-options*))))\r
 198   (eval\r
 199    `(defclass hyperobject-esd (standard-effective-slot-definition)\r
 200      (,@(mapcar #'(lambda (x)\r
 201                     `(,(intern (symbol-name x))\r
 202                       :initarg\r
 203                       ,(intern (symbol-name x) (symbol-name :keyword))\r
 204                       :initform nil\r
 205                       :accessor\r
 206                       ,(intern (concatenate 'string\r
 207                                             (symbol-name :esd-)\r
 208                                             (symbol-name x)))))\r
 209                 (append *slot-options* *slot-options-no-initarg*)))))\r
 210   ) ;; eval-when\r
 211 \r
 212 (defun intern-in-keyword (obj)\r
 213   (cond\r
 214     ((null obj)\r
 215      nil)\r
 216     ((eq t obj)\r
 217      t)\r
 218     ((atom obj)\r
 219      (intern (symbol-name obj) (find-package 'keyword)))\r
 220     ((consp obj)\r
 221      (cons (intern-in-keyword (car obj) ) (intern-in-keyword (cdr obj))))\r
 222     (t\r
 223      obj)))\r
 224 \r
 225 (defun canonicalize-value-type (vt)\r
 226   (typecase vt\r
 227     (atom\r
 228      (ensure-keyword vt))\r
 229     (cons\r
 230      (list (ensure-keyword (car vt)) (cadr vt)))\r
 231     (t\r
 232      t)))\r
 233 \r
 234 (defmethod compute-effective-slot-definition :around ((cl hyperobject-class)\r
 235                                                       #+ho-normal-cesd name\r
 236                                                       dsds)\r
 237   (declare (ignore #+ho-normal-cesd name))\r
 238   (let ((esd (call-next-method)))\r
 239     (if (typep esd 'hyperobject-esd)\r
 240         (compute-hyperobject-esd esd dsds)\r
 241         esd)))\r
 242 \r
 243 (defun compute-hyperobject-esd (esd dsds)\r
 244   (let* ((dsd (car dsds))\r
 245          (value-type (canonicalize-value-type (slot-value dsd 'value-type))))\r
 246     (multiple-value-bind (sql-type sql-length) \r
 247         (value-type-to-sql-type value-type)\r
 248       (setf (esd-sql-type esd) sql-type)\r
 249       (setf (esd-sql-length esd) sql-length))\r
 250     (setf (slot-value esd 'type) (value-type-to-lisp-type value-type))\r
 251     (setf (esd-value-type esd) value-type)\r
 252     (setf (esd-user-name esd)\r
 253           (aif (dsd-user-name dsd)\r
 254                it\r
 255                (string-downcase (symbol-name (slot-definition-name dsd)))))\r
 256     (setf (esd-sql-name esd)\r
 257           (aif (dsd-sql-name dsd)\r
 258                it\r
 259                (lisp-name-to-sql-name (slot-definition-name dsd))))\r
 260     (setf (esd-sql-name esd)\r
 261           (aif (dsd-sql-name dsd)\r
 262                it\r
 263                (lisp-name-to-sql-name (slot-definition-name dsd))))\r
 264     (dolist (name '(print-formatter subobject hyperlink hyperlink-parameters\r
 265                     description value-constraint indexed null-allowed\r
 266                     unique short-description void-text read-only-groups\r
 267                     hidden-groups unit disable-predicate view-type\r
 268                     list-of-values stored))\r
 269       (setf (slot-value esd name) (slot-value dsd name)))\r
 270     esd))\r
 271 \r
 272 (defun lisp-name-to-sql-name (lisp)\r
 273   "Convert a lisp name (atom or list, string or symbol) into a canonical\r
 274 SQL name"\r
 275   (unless (stringp lisp)\r
 276     (setq lisp\r
 277           (typecase lisp\r
 278             (symbol (symbol-name lisp))\r
 279             (t (write-to-string lisp)))))\r
 280   (do* ((len (length lisp))\r
 281         (sql (make-string len))\r
 282         (i 0 (1+ i)))\r
 283       ((= i len) (string-upcase sql))\r
 284     (declare (fixnum i)\r
 285              (simple-string sql))\r
 286     (setf (schar sql i)\r
 287           (let ((c (char lisp i)))\r
 288             (case c\r
 289               ((#\- #\$ #\+ #\#) #\_)\r
 290               (otherwise c))))))\r
 291 \r
 292 #+ho-normal-cesd\r
 293 (setq cl:*features* (delete :ho-normal-cesd cl:*features*))\r
 294 #+ho-normal-dsdc\r
 295 (setq cl:*features* (delete :ho-normal-dsdc cl:*features*))\r
 296 #+ho-normal-esdc\r
 297 (setq cl:*features* (delete :ho-normal-esdc cl:*features*))\r
 298 \r
 299 (defun lisp-type-is-a-string (type)\r
 300   (or (eq type 'string)\r
 301       (and (listp type) (some #'(lambda (x) (eq x 'string)) type))))\r
 302 \r
 303 (defun base-value-type (value-type)\r
 304   (if (atom value-type)\r
 305       value-type\r
 306     (car value-type)))\r
 307 \r
 308 (defun value-type-to-lisp-type (value-type)\r
 309   (case (base-value-type value-type)\r
 310     ((:string :cdata :varchar :char)\r
 311      '(or null string))\r
 312     (:character\r
 313      '(or null character))\r
 314     (:fixnum\r
 315      '(or null fixnum))\r
 316     (:boolean\r
 317      '(or null boolean))\r
 318     ((:integer :long-integer)\r
 319      '(or null integer))\r
 320     ((:float :single-float)\r
 321      '(or null single-float))\r
 322     (:double-float\r
 323      '(or null double-float))\r
 324     (otherwise\r
 325      t)))\r
 326 \r
 327 (defun value-type-to-sql-type (value-type)\r
 328   "Return two values, the sql type and field length."\r
 329   (let ((type (base-value-type value-type))\r
 330         (length (when (consp value-type)\r
 331                   (cadr value-type))))\r
 332     (values\r
 333      (case type\r
 334        ((:char :character)\r
 335         :char)\r
 336        (:varchar\r
 337         :varchar)\r
 338        ((:fixnum :integer)\r
 339         :integer)\r
 340        (:long-integer\r
 341         :long-integer)\r
 342        (:boolean\r
 343         :boolean)\r
 344        ((:float :single-float)\r
 345         :single-float)\r
 346        (:double-float\r
 347         :double-float)\r
 348        (otherwise\r
 349         :text))\r
 350      length)))\r
 351 \r
 352 ;;;; Class initialization function\r
 353 \r
 354 ;; One entry for each class with lazy readers defined.  The value is a plist mapping\r
 355 ;; slot-name to a lazy reader, each of which is a list of a function and slot-names.\r
 356 (defvar *lazy-readers* (make-hash-table))\r
 357 \r
 358 (defmethod slot-unbound :around ((class hyperobject-class) instance slot-name)\r
 359   (let ((lazy-reader (loop for super in (class-precedence-list class)\r
 360                          as lazy-reader = (getf (gethash super *lazy-readers*) slot-name)\r
 361                          when lazy-reader return it)))\r
 362     (if lazy-reader\r
 363         (setf (slot-value instance slot-name)\r
 364               (if (atom lazy-reader)\r
 365                   (make-instance lazy-reader)\r
 366                   (apply (car lazy-reader)\r
 367                          (loop for arg-slot-name in (cdr lazy-reader)\r
 368                                collect (slot-value instance arg-slot-name)))))\r
 369         ;; No lazy reader -- defer to regular slot-unbound handling.\r
 370         (call-next-method))))\r
 371 \r
 372 ;; The reader is a function and the reader-keys are slot names.  The slot is lazily set to\r
 373 ;; the result of applying the function to the slot-values of those slots, and that value\r
 374 ;; is also returned.\r
 375 (defun ensure-lazy-reader (cl class-name slot-name subobj-class reader \r
 376                            &rest reader-keys)\r
 377   (setf (getf (gethash cl *lazy-readers*) slot-name)\r
 378     (aif subobj-class\r
 379          it\r
 380          (list* reader (copy-list reader-keys)))))\r
 381 \r
 382 (defun remove-lazy-reader (class-name slot-name)\r
 383   (setf (getf (gethash (find-class class-name) *lazy-readers*) slot-name)\r
 384     nil))\r
 385 \r
 386 \r
 387 (defun finalize-subobjects (cl)\r
 388   "Process class subobjects slot"\r
 389   (setf (subobjects cl)\r
 390         (let ((subobjects '()))\r
 391           (dolist (slot (class-slots cl))\r
 392             (let-when\r
 393              (subobj-def (esd-subobject slot))\r
 394              (let ((subobject\r
 395                     (make-instance 'subobject\r
 396                                    :name-class (class-name cl)\r
 397                                    :name-slot (slot-definition-name slot)\r
 398                                    :subobj-class (when (atom subobj-def)\r
 399                                                    subobj-def)\r
 400                                    :lookup (when (listp subobj-def)\r
 401                                              (car subobj-def))\r
 402                                    :lookup-keys (when (listp subobj-def)\r
 403                                                   (cdr subobj-def)))))\r
 404                (unless (eq (lookup subobject) t)\r
 405                  (apply #'ensure-lazy-reader\r
 406                         cl\r
 407                         (name-class subobject) (name-slot subobject)\r
 408                         (subobj-class subobject)\r
 409                         (lookup subobject) (lookup-keys subobject))\r
 410                  (push subobject subobjects)))))\r
 411           ;; sbcl/cmu reverse class-slots compared to the defclass form\r
 412           ;; so re-reverse on cmu/sbcl\r
 413           #+(or cmu sbcl) subobjects\r
 414           #-(or cmu sbcl) (nreverse subobjects)\r
 415           )))\r
 416 \r
 417 (defun finalize-class-slots (cl)\r
 418   "Make sure all class slots have an expected value"\r
 419   (unless (user-name cl)\r
 420     (setf (user-name cl) (format nil "~:(~A~)" (class-name cl))))\r
 421   \r
 422   (setf (user-name-plural cl)\r
 423         (if (and (consp (user-name cl)) (cadr (user-name cl)))\r
 424             (cadr (user-name cl))\r
 425             (format nil "~A~P" (if (consp (user-name cl))\r
 426                                    (car (user-name cl))\r
 427                                    (user-name cl))\r
 428                     2)))\r
 429 \r
 430   (dolist (name '(user-name description version guid sql-name))\r
 431     (awhen (slot-value cl name)\r
 432            (setf (slot-value cl name)\r
 433              (if (listp it)\r
 434                  (car it)\r
 435                it))))\r
 436   \r
 437   (unless (sql-name cl)\r
 438     (setf (sql-name cl) (lisp-name-to-sql-name (class-name cl))))\r
 439   )\r
 440 \r
 441 (defun finalize-documentation (cl)\r
 442   "Calculate class documentation slot"\r
 443   (let ((*print-circle* nil))\r
 444     (setf (documentation (class-name cl) 'class)\r
 445           (format nil "Hyperobject~A~A~A~A"\r
 446                   (aif (user-name cl)\r
 447                        (format nil ": ~A" it ""))\r
 448                   (aif (description cl)\r
 449                        (format nil "~%Class description: ~A" it) "")\r
 450                   (aif (subobjects cl)\r
 451                        (format nil "~%Subobjects:~{ ~A~}" (mapcar #'name-slot it)) "")\r
 452                   (aif (default-print-slots cl)\r
 453                        (format nil "~%Default print slots:~{ ~A~}" it) "")\r
 454                   ))))\r
 455 \r
 456 (defun finalize-hyperlinks (cl)\r
 457   (let ((hyperlinks '()))\r
 458     (dolist (esd (class-slots cl))\r
 459       (awhen (slot-value esd 'hyperlink)\r
 460              (push\r
 461               (make-instance 'hyperlink\r
 462                              :name (slot-definition-name esd)\r
 463                              :lookup it\r
 464                              :link-parameters (slot-value esd 'hyperlink-parameters))\r
 465               hyperlinks)))\r
 466     ;; cmu/sbcl reverse class-slots compared to the defclass form\r
 467     ;; hyperlinks is already reversed from the dolist/push loop, so re-reverse on sbcl/cmu\r
 468     #-(or cmu sbcl) (setq hyperlinks (nreverse hyperlinks))\r
 469     (setf (slot-value cl 'hyperlinks) hyperlinks)))\r
 470 \r
 471 (defun init-hyperobject-class (cl)\r
 472   "Initialize a hyperobject class. Calculates all class slots"\r
 473   (finalize-subobjects cl)\r
 474   (finalize-views cl)\r
 475   (finalize-hyperlinks cl)\r
 476   (finalize-sql cl)\r
 477   (finalize-rules cl)\r
 478   (finalize-class-slots cl)\r
 479   (finalize-documentation cl))\r
 480 \r
 481 \r
 482 ;;;; *************************************************************************\r
 483 ;;;;  Metaclass Slot Accessors\r
 484 ;;;; *************************************************************************\r
 485 \r
 486 (defun find-slot-by-name (cl name)\r
 487   (find name (class-slots cl) :key #'slot-definition-name))\r
 488 \r
 489 (defun hyperobject-class-user-name (obj)\r
 490   (user-name (class-of obj)))\r
 491 \r
 492 (defun hyperobject-class-user-name-plural (obj)\r
 493   (user-name-plural (class-of obj)))\r
 494 \r
 495 (defun hyperobject-class-subobjects (obj)\r
 496   (subobjects (class-of obj)))\r
 497 \r
 498 (defun hyperobject-class-hyperlinks (obj)\r
 499   (hyperlinks (class-of obj)))\r
 500 \r
 501 (defun hyperobject-class-slots (obj)\r
 502   ;; cmucl/sbcl reverse class-slots\r
 503   #+(or cmu sbcl) (reverse (class-slots (class-of obj)))\r
 504   #-(or cmu sbcl) (class-slots (class-of obj)))\r
 505 \r
 506 (defun all-subobjects (obj)\r
 507   "Returns a list of all subobjects in an object"\r
 508   (let ((so-list '()))\r
 509     (dolist (subobj-obj (subobjects (class-of obj)) (nreverse so-list))\r
 510       (dolist (so (funcall (name-slot subobj-obj) obj))\r
 511         (push so so-list)))))\r