;;; -*- lisp -*-
(eval-when (:compile-toplevel :load-toplevel :execute)
- (unless (find-package :coop.tech.lisp-on-lines.system)
- (defpackage :coop.tech.lisp-on-lines.system
+ (unless (find-package :coop.tech.systems)
+ (defpackage :coop.tech.systems
(:documentation "ASDF System package for meta-model.")
(:use :common-lisp :asdf))))
-(in-package :coop.tech.lisp-on-lines.system)
+(in-package :coop.tech.systems)
-(defsystem :meta-model
- :components (
- (:module :src
- :components ((:file "packages")
- (:file "meta-model" :depends-on ("packages"))))
- (:module :backend
- :depends-on (:src)
- :pathname "src/backend/"
- :components ((:file "clsql"))))
- :depends-on (:clsql :clsql-pg-introspect))
-
-;; this is no longer used
-(defsystem :meta-model-clsql
- :components ()
- :depends-on (:meta-model :clsql ))
(defsystem :mewa
:components ((:module :src
:pathname "src/mewa/"
:components
- ((:file "mewa")
- (:file "presentations" :depends-on ("mewa"))
- (:file "slot-presentations" :depends-on ("presentations")))))
+ ((:file "packages")
+ (:file "static-presentations")
+ (:file "mewa")
+ (:file "presentations" )
+ (:file "slot-presentations"))
+ :serial t))
:depends-on (:ucw :meta-model))
(defsystem :lisp-on-lines
:components ((:static-file "lisp-on-lines.asd")
(:module :src
- :components ((:file "lisp-on-lines")))
+ :components ((:file "packages")
+ (:file "lisp-on-lines"))
+ :serial t)
+
(:module :components
:pathname "src/components/"
:components ((:file "range-list")
+++ /dev/null
-(in-package :meta-model)
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (use-package :clsql))
-
-(export 'def-meta-model-from-table)
-(export 'def-meta-models)
-(export 'def-view-class/meta)
-(export 'list-base-classes)
-
-
-(defmethod sync-instance ((view clsql:standard-db-object) &key (fill-gaps-only-p nil) (database *default-database*))
- (labels ((sym->sql (sym) (string-downcase (substitute #\_ #\- (string sym))))
- (get-def (slot) (caar (query
- (format nil "SELECT DISTINCT adsrc from pg_attrdef join pg_attribute on attnum = adnum where adrelid = (select oid from pg_class where relname = '~A') and attname = '~A'" (sym->sql (class-name (class-of view))) (sym->sql slot)))))
- (get-default-value (slot)
- (let ((def (get-def slot)))
- (if def
- (caar (query (format nil "SELECT ~A" def)))))))
-
- (dolist (slot (list-slots view))
- (when (and (primary-key-p view slot)
- (or (not (slot-boundp view slot))
- (equal (slot-value view slot) nil)))
- (setf (slot-value view slot) (get-default-value slot))
- (when (and (primary-key-p view slot)
- (not (slot-value view slot))
- (not fill-gaps-only-p))
- (error "No default value for primary key : ~A" slot))))
- (when fill-gaps-only-p
- (update-objects-joins (list view))
- (return-from sync-instance))
- (update-records-from-instance view :database database)
- (update-instance-from-records view :database database)
- (update-objects-joins (list view)))
-
- ;; return the modified and hopefully now persistent object
- view)
-
-
-
-(defparameter *clsql-base-classes* (list) )
-
-(defmethod list-base-classes ((type (eql :clsql)))
- *clsql-base-classes*)
-
-(defmethod generate-base-class-definition ((base-type (eql :clsql)) (model meta-model-class) (name t) (args t))
- `(def-view-class ,name ()
- ,(meta-model.metadata model)))
-
-(defmethod generate-base-class-definition :after ((base-type (eql :clsql)) (model meta-model-class) (name t) (args t))
- (unless (member name *clsql-base-classes*)
- (setf *clsql-base-classes* (cons name *clsql-base-classes*))))
-
-(defparameter *sql-type-map* '((:INT4 integer) (:BOOL boolean) (:TEXT string) (:VARCHAR string) (:TIMESTAMP clsql-sys::wall-time) (:NUMERIC number)(:BYTEA string)))
-
-(defun gen-type (table column)
- (cadr (assoc
- (cadr (assoc
- column
- (list-attribute-types table)
- :test #'equalp ))
- *sql-type-map*)))
-
-(defun sql->sym (name &optional (package nil))
- (flet ((xform (x)
- (string-upcase (substitute #\- #\_ x))))
- (if package
- (intern (xform (string name)) package)
- (intern (xform (string name))))))
-
-(defun table->slots (table pkey &optional (accesor-prefix table) (prefix-all-p nil))
- (mapcar
- #'(lambda (col)
- (flet ((accessor-name (col)
- (let ((name (sql->sym col)))
- (if (or prefix-all-p
- (and (fboundp name)
- (eq (type-of (symbol-function name)) 'function)))
- (sql->sym (concatenate 'string
- (string accesor-prefix) "-" col))
- name))))
-
- `(,(sql->sym col)
- :accessor ,(accessor-name col)
- :initarg ,(sql->sym col "KEYWORD")
- :type ,(gen-type table col)
- :db-kind
- ,(if (equalp col pkey)
- `:key
- `:base))))
- (list-attributes table)))
-
-(defun view-class-definition-list ()
- (mapcar #'(lambda (x) `(def-meta-model-from-table ,x))
- (list-tables)))
-
-(defmacro def-meta-models ()
- (let ((defs (view-class-definition-list)))
- `(progn ,@defs)))
-
-
-(defun get-pkeys ()
- (let ((keys '()))
- (dolist (row (get-pkeys-query))
- (setf keys (acons (car row) (list (cadr row)) keys)))
- keys))
-
-(defun get-pkeys-query()
- (query
- "SELECT pg_class.relname, pg_attribute.attname, pg_catalog.quote_ident(conname) AS constraint_n
- , pg_catalog.pg_get_indexdef(d.objid) AS constraint_definition
- , CASE
- WHEN contype = 'p' THEN
- 'PRIMARY KEY'
- ELSE
- 'UNIQUE'
- END as constraint_type
- FROM
- pg_class, pg_attribute,
- pg_catalog.pg_constraint AS c
- JOIN pg_catalog.pg_depend AS d ON (d.refobjid = c.oid)
- WHERE contype IN ('p', 'u')
- AND deptype = 'i'
- and conrelid = pg_class.oid
- and pg_attribute.attnum = ANY (c.conkey)
- and pg_attribute.attrelid = pg_class.oid"))
-
-;;here is how this works
-;;from the postgres system tables we get
-;;list of all the has-a relationships.
-;;the inverse of a has-a is an implicit has-many
-;;and any relation having more than one foreign key
-;;is a join table hosting a many-to-many relationship
-
-(defun get-fkey-explosions ()
- (let ((key-table (get-fkey-explosions-query))
- (keys '()))
- (dolist (row key-table)
- (setf row (mapcar #'(lambda (x)
- (sql->sym x))
- row))
- ;;this one does the has-a
- (setf keys (acons (car row) (gen-has-a row)
- keys))
- ;;the inverse of the previous represents a has-many.
- (setf keys
- (acons (fourth row) (gen-has-many row)
- keys))
-
- ;;many-to-many
- (dolist (mrow
- (remove-if #'(lambda (r) (or (not (equal (car row) (car r)))
- (equal (last row) (last r))))
- (mapcar #'(lambda (x)
- (mapcar #'sql->sym x))
- key-table)))
- (setf keys (acons (fourth row)
- (gen-many-to-many mrow (third row) (second row))
- keys))))
- keys ))
-
-
-(defun get-fkey-explosions-query ()
-;;these query's are a mess, i don't even know how they work :)
- (query "
-SELECT pg_class.relname,
- pg_attribute.attname,
- fa.attname ,
- f.relname
-FROM pg_class,
- pg_constraint,
- pg_attribute,
- pg_class as f ,
- pg_attribute as fa
-WHERE pg_class.relname in (select tablename from pg_tables where schemaname = 'public')
-AND pg_class.oid = pg_constraint.conrelid
-AND pg_attribute.attnum = ANY (pg_constraint.conkey)
-AND pg_attribute.attrelid = pg_class.oid
-AND f.oid = confrelid
-AND fa.attrelid = f.oid
-AND fa.attnum = ANY (pg_constraint.confkey)"))
-
-
-;; i chose keyword args here so as to make the code more understandable.
-;; it didn't really work.
-(defun gen-join-slot (&key name home-key foreign-key join-class (set nil))
- `(,(intern name)
- :accessor ,(intern name)
- :db-kind :join
- :db-info (:join-class ,join-class
- :home-key ,home-key
- :foreign-key ,foreign-key
- :set ,set)))
-
-(defun gen-has-a (row)
- (gen-join-slot
- :name
- (format nil "~A->~A" (string (car row))(string (second row)))
- :home-key (second row)
- :foreign-key (third row)
- :join-class (fourth row)))
-
-(defun gen-has-many (row)
- (gen-join-slot
- :name
- (format nil "~A->~A" (string (car row))(string (second row)))
- :home-key (third row)
- :foreign-key (second row)
- :join-class (car row)
- :set t))
-
-(defun gen-many-to-many (row home-key foreign-key)
- (let ((name (sql->sym (string-upcase (format nil "~A<-~A->~A" (string (car row)) (string foreign-key) (string (second row)))))))
- (setf row (mapcar #'sql->sym row))
- `(,name
- :accessor ,name
- :db-kind :join
- :db-info (:join-class ,(car row)
- :home-key ,home-key
- :foreign-key ,foreign-key
- :target-slot ,name
- :set t))))
-
-(defmethod update-records-from-instance :before ((view clsql::standard-db-object) &key database)
- (declare (ignorable database))
- (labels ((sym->sql (sym) (string-downcase (substitute #\_ #\- (string sym))))
- (get-def (slot) (caar (query
- (format nil "SELECT DISTINCT adsrc from pg_attrdef join pg_attribute on attnum = adnum where adrelid = (select oid from pg_class where relname = '~A') and attname = '~A'" (sym->sql (class-name (class-of view))) (sym->sql slot)))))
- (get-default-value (slot) (caar (query (format nil "SELECT ~A" (get-def slot))))))
-
- (dolist (slot (list-slots view))
- (when (and (primary-key-p view slot)
- (or (not (slot-boundp view slot))
- (equal (slot-value view slot) nil)))
- (setf (slot-value view slot) (get-default-value slot))))))
-
-;;;;
-
-(defmacro def-view-class/meta (name supers slots &rest args)
- "Create and instrument CLSQL view-class NAME and
-appropriate meta-model class its default name is %NAME-meta-model."
-
- `(progn
- (let* ((m (define-meta-model ,name ,supers ,slots ,args)))
- (setf (meta-model.base-type m) :clsql)
- (eval (generate-base-class-expander m ',name ',args)))))
-
-(defmacro def-view-class-from-table (table &optional
- (name (clsql-pg-introspect::intern-normalize-for-lisp table)))
- "takes the name of a table as a string and
-creates a clsql view-class"
- `(clsql-pg-introspect:gen-view-class ,table
- :classname ,name
- :generate-joins :all
- :definer def-view-class/meta))
-
-
-(defmethod prepare-slot-name-for-select ((i standard-db-object) slot-name)
- (clsql:sql-expression :attribute slot-name))
-
-(def-compare-expr standard-db-object expr-= sql-=)
-(def-compare-expr standard-db-object expr-< sql-<)
-(def-compare-expr standard-db-object expr-> sql->)
-(def-compare-expr standard-db-object expr-ends-with sql-uplike :value-format "%~A")
-(def-compare-expr standard-db-object expr-starts-with sql-uplike :value-format "~A%")
-(def-compare-expr standard-db-object expr-contains sql-uplike :value-format "%~A%")
-
-(def-logical-expr standard-db-object expr-and #'sql-and)
-
-(def-logical-expr standard-db-object expr-or #'sql-or)
-
-(def-logical-expr standard-db-object expr-not #'sql-not)
-
-(defmethod select-instances ((instance standard-db-object) &rest query)
- (unless (keywordp (car query))
- (setf query (cons :where query)))
- (apply #'select (class-name (class-of instance)) :flatp t query))
+++ /dev/null
-(in-package :it.bese.ucw)
-
-(defslot-presentation clsql-wall-time-slot-presentation ()
- ()
- (:type-name clsql-sys:wall-time))
-
-(defmethod present-slot ((slot clsql-wall-time-slot-presentation) instance)
- (<:as-html (presentation-slot-value slot instance)))
-
-(defslot-presentation mewa-relation-slot-presentation ()
- ((slot-name :accessor slot-name :initarg :slot-name)
- (foreign-instance :accessor foreign-instance)
- (editablep :initarg :editablep :accessor editablep :initform :inherit))
- (:type-name relation))
-
-(defmethod present-relation (( slot mewa-relation-slot-presentation) instance)
- (when (foreign-instance slot)
- (when (eql (editablep slot) :inherit)
- (setf (editablep slot) (editablep (parent slot))))
- (flet ((render-slot ()
- (<ucw:render-component
- :component (mewa::make-presentation (foreign-instance slot) :type :one-line :initargs '(:global-properties (:editablep nil))))))
- (if (editablep slot)
- (render-slot)
- (<ucw:a :action (view-instance slot instance)
- (render-slot))))))
-
-(defmethod present-slot ((slot mewa-relation-slot-presentation) instance)
- (setf (foreign-instance slot) (meta-model:explode-foreign-key instance (slot-name slot)))
- (present-relation slot instance))
-
-(defslot-presentation foreign-key-slot-presentation (mewa-relation-slot-presentation)
- ()
- (:type-name foreign-key)
- (:default-initargs :editablep :inherit))
-
-(defaction view-instance ((self component) instance &rest initargs)
- (call-component (parent self) (apply #'mewa:make-presentation (foreign-instance self) initargs)))
-
-(defmethod present-slot :before ((slot foreign-key-slot-presentation) instance)
- (setf (foreign-instance slot) (meta-model:explode-foreign-key instance (slot-name slot))))
-
-
-(defslot-presentation has-many-slot-presentation (mewa-relation-slot-presentation)
- ()
- (:type-name has-many))
-
-(defmethod present-slot ((slot has-many-slot-presentation) instance)
- (<:ul
- (dolist (s (slot-value instance (slot-name slot)))
- (setf (foreign-instance slot) s)
- (<:li (present-relation slot instance)))))
-
-
-
-(defslot-presentation has-a-slot-presentation (one-of-presentation)
- ((key :initarg :key :accessor key))
- (:type-name has-a))
-
-(defmethod get-foreign-slot-value ((slot has-a-slot-presentation) (object t) (slot-name t))
- (slot-value object slot-name))
-
-(defmethod present-slot ((slot has-a-slot-presentation) instance)
- (<:as-html (presentation-slot-value slot instance))
- (if (editablep slot)
- (<ucw:select :accessor (presentation-slot-value slot instance) :test #'equalp
- (when (allow-nil-p slot)
- (<ucw:option :value nil (<:as-html (none-label slot))))
- (dolist (option (get-foreign-instances (presentation slot) instance))
- (setf (instance (presentation slot)) option)
- (<ucw:option :value (get-foreign-slot-value slot option (key slot)) (present (presentation slot)))))
- (if (presentation-slot-value slot instance)
- (progn
- (setf (instance (presentation slot)) (presentation-slot-value slot instance))
- (present (presentation slot)))
- (<:as-html "--"))))
\ No newline at end of file
(defmacro initialize-lol-for-database ()
"expands to init-i-f-t using the listing of tables provided by meta-model"
- `(initialize-lol-for-table ,@(meta-model::list-tables)))
\ No newline at end of file
+ `(initialize-lol-for-table ,@(meta-model::list-tables)))
+
+;;;; * AJAX stuff
+
+;;;; TODO: This search stuff should probably me refactored elsewhere
+
+(defmethod find-slots-of-type (model &key (type 'string)
+ (types '((string)) types-supplied-p))
+ "returns a list of slots matching TYPE, or matching any of TYPES"
+ (let (ty)
+ (if types-supplied-p
+ (setf ty types)
+ (setf ty (list type)))
+ (remove nil (mapcar #'(lambda (st) (when (member (second st) ty)
+ (first st)))
+ (lisp-on-lines::list-slot-types model)))))
+
+
+(defmethod word-search (class-name slots search-terms
+ &key (limit 10) (where (sql-and t)))
+ (select class-name
+ :where (sql-and
+ where
+ (word-search-where class-name slots search-terms :format-string "~a%"))
+ :flatp t
+ :limit limit))
+
+
+(defmethod word-search (class-name slots (s string) &rest args)
+ (apply #'word-search class-name slots
+ (split-sequence:split-sequence #\Space s) args))
+
+(defmethod word-search-where (class-name slots search-terms &key (format-string "%~a%"))
+ (sql-or
+ (mapcar #'(lambda (term)
+ (apply #'sql-or
+ (mapcar #'(lambda (slot)
+ (sql-uplike
+ (sql-slot-value class-name slot)
+ (format nil format-string term)))
+ slots)))
+ search-terms)))
+
+++ /dev/null
-(in-package :meta-model)
-
-(defvar *meta-models* (make-hash-table))
-
-(defclass meta-model-class ()
- ((name
- :accessor meta-model.name
- :initarg :name
- :initform nil)
- (slots
- :accessor meta-model.slots
- :initarg :slots
- :initform nil)
- (superclasses
- :accessor meta-model.superclasses
- :initarg :superclasses
- :initform nil)
- (options
- :accessor meta-model.options
- :initarg :options
- :initform nil)
- (metadata
- :accessor meta-model.metadata
- :initarg :metadata
- :initform nil)
- (instance
- :accessor meta-model.instance
- :initarg :instance
- :initform nil)
- (base-type
- :accessor meta-model.base-type
- :initarg :base-type
- :initform :clsql)))
-
-(defmethod meta-model.metadata ((self (eql nil)))
- nil)
-
-(defmethod meta-model.metadata ((self symbol))
- (meta-model.metadata (gethash self *meta-models*)))
-
-(defmethod meta-model.metadata ((self standard-object))
- (meta-model.metadata (class-name (class-of self))))
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defmethod make-meta-model (name supers slots options)
- (let ((m (make-instance 'meta-model-class
- :name name
- :superclasses supers
- :slots slots
- :options options
- ;; TODO : the metadata should inherit any superclasses
- :metadata slots)))
- (setf (gethash name *meta-models*) m))))
-
-(defmacro define-meta-model (name supers slots &rest options)
- `(make-meta-model ',name ',supers ',slots ',options))
-
-(defgeneric generate-base-class-definition (base-type model name args))
-
-(defmethod generate-base-class-expander ((model t) name args)
- (generate-base-class-definition (meta-model.base-type model) model name args))
-
-
-(defmethod view-class-metadata ((model t))
- "
-This is what meta-model.metadata used to be called,
-most of the below functions expect this method to exist"
- (meta-model.metadata model))
-
-(defun list-item-helper (type view &key (ret-fun #'car))
- "A helper function for the LIST-* methods"
- (remove nil
- (mapcar #'(lambda (slot)
- (let ((ret-val (funcall ret-fun slot))
- (kind (getf (cdr slot) :db-kind)))
- (when (eql kind type)
- ret-val )))
- (view-class-metadata view))))
-
-(defmethod list-join-attributes ((view t))
- "Returns all slots as an alist of (SLOT-NAME JOIN-ATTRIBUTES) where J-A is the contents of the :JOIN-CLASS portion of a slot definition"
- (remove nil (mapcar #'(lambda (def)(cons (car def) (getf (cdr def) :db-info ))) (view-class-metadata view))))
-
-(defun list-relations-helper (view predicate-method &key (test-key :home-key) (return-key :join-class) (return-full nil))
- "A helper function for the listing join, relations and the like"
- (remove nil (mapcar #'(lambda (x)
- (when (funcall predicate-method view (getf (cdr x) test-key ))
- (if return-full
- x
- (getf (cdr x) return-key ))))
- (list-join-attributes view))))
-
-(defmethod list-slots ((view t))
- "list the non-joined slots of VIEW-CLASS"
- (remove-if #'(lambda (x) (find x (list-joins view)))
- (append (list-item-helper :key view)
- (list-item-helper nil view)
- (list-item-helper :base view))))
-
-(defmethod list-slot-types ((view t))
- "Returns an alist of (slot-name slot-type) where SLOT-TYPE is the CLSQL type"
- (labels ((rfun (slot)
- (cons (car slot)
- (list (getf (cdr slot):type))))
- (lister (type)
- (list-item-helper
- type view
- :ret-fun #'rfun)))
- (append (lister :key) (lister :base) (lister nil))))
-
-(defmethod slot-type ((view t) slot)
- "returns the CLSQL type of SLOT"
- (second (assoc slot (list-slot-types view))))
-
-(defmethod list-joins ((view t))
- "lists slots that represent joins"
- (list-item-helper :join view))
-
-(defmethod list-keys ((view t))
- "lists slots marked as :key"
- (list-item-helper :key view))
-
-(defmethod primary-key-p ((view t) slot)
- "returns slot if it is primary key (NOTE: Currently this returns T if the slot appears in LIST_KEYS and does not take into account the :primary-key option. b0rked, to be sure"
- (find slot (list-keys view)))
-
-(defmethod list-foreign-keys ((view t))
- "returns a list of FOREIGN-KEYS"
- (flet ((my-primary-key-p (slot)
- (primary-key-p view slot)))
- (remove nil (remove-if #'my-primary-key-p
- (mapcar #'(lambda (def)
- (getf (cdr def) :home-key))
- (list-join-attributes view))))))
-
-(defmethod foreign-key-p ((view t) slot)
- "returns SLOT if it's a foreign key, nil otherwise"
- (find slot (list-foreign-keys view)))
-
-
-
-(defmethod list-has-a ((view t))
- "returns a list of view-classes that are in a 1:1 relationship with VIEW"
- (list-relations-helper view #'foreign-key-p))
-
-(defmethod list-has-many ((view t))
- "returns a list of view-classes that are in a 1:Many relationship with VIEW"
- (mapcar #'car
- (remove-if #'(lambda (x) (getf (cdr x) :target-slot))
- (list-relations-helper
- view
- #'primary-key-p :return-full t))))
-
-(defmethod list-many-to-many ((view t))
- "returns a list of view-classes that are in a Many:Many relationship with VIEW"
- (mapcar #'car (list-relations-helper
- view
- #'(lambda (c a)
- (declare (ignore c))a)
- :test-key :target-slot
- :return-full t)))
-
-(defmethod explode-foreign-key ((model clsql:standard-db-object) slot &key (createp t))
- "returns the clsql view-class joined on SLOT"
- (dolist (s (list-join-attributes model))
- (when (equal (getf (cdr s) :home-key) slot)
- (let* ((fkey (getf (cdr s) :foreign-key))
- (new (sync-instance (make-instance (getf (cdr s) :join-class))))
- (val (or (slot-value model (car s))
- (progn
- (when createp
- (setf
- (slot-value model slot)
- (slot-value new fkey))
- (sync-instance model)
- (slot-value model (car s)))))))
-
- (return-from explode-foreign-key
- (values val fkey))))))
-
-(defun find-join-helper (foreign-key)
- (lambda (class slot)
- (declare (ignore class))
- (when (equal slot foreign-key) t)))
-
-(defmethod find-join-class ((view t) foreign-key)
- "Returns the VIEW-CLASS that is joined to VIEW via FOREGN-KEY"
- (car (list-relations-helper view (find-join-helper foreign-key) )))
-
-(defmethod find-join-key ((view t) foreign-key)
- "returns the SLOT in the foreign VIEW-CLASS that joins with FOREIGN-KEY"
- (car (list-relations-helper view (find-join-helper foreign-key) :return-key :foreign-key)))
-
-(defmethod explode-has-many ((view t) join-slot)
- "returns the class of the join as the primary value, the second and third value is the home key and the foreign key"
- (let ((att (assoc join-slot (list-join-attributes view))))
- (values (getf (cdr att) :join-class)
- (getf (cdr att) :home-key)
- (getf (cdr att) :foreign-key))))
-
-(defgeneric expr-= (instance slot-name value)
- (:documentation "Create search expression for appropriate backend."))
-
-(defgeneric expr-> (instance slot-name value)
- (:documentation "Create search expression for appropriate backend."))
-
-(defgeneric expr-< (instance slot-name value)
- (:documentation "Create search expression for appropriate backend."))
-
-(defgeneric expr-ends-with (instance slot-name value)
- (:documentation "Create search expression for appropriate backend."))
-
-(defgeneric expr-starts-with (instance slot-name value)
- (:documentation "Create search expression for appropriate backend."))
-
-(defgeneric expr-contains (instance slot-name value)
- (:documentation "Create search expression for appropriate backend."))
-
-(defgeneric expr-and (instance &rest args)
- (:documentation "Create search expression for appropriate backend."))
-
-(defgeneric expr-or (instance &rest args)
- (:documentation "Create search expression for appropriate backend."))
-
-(defgeneric expr-not (instance &rest args)
- (:documentation "Create search expression for appropriate backend."))
-
-(defgeneric select-instances (instance &rest args)
- (:documentation "Select instances in backend dependent way"))
-
-(defgeneric prepare-slot-name-for-select (instance slot-name)
- (:method (i s) s))
-
-(defmacro def-compare-expr (instance-type name expr &key value-format)
- `(defmethod ,name ((instance ,instance-type) slot-name value)
- (declare (ignore instance))
- (,expr (prepare-slot-name-for-select instance slot-name) ,(typecase value-format
- (null 'value)
- (string `(format nil ,value-format value))
- (t `(,value-format value))))))
-
-
-(defmacro def-logical-expr (instance-type name expr)
- `(defmethod ,name ((instance ,instance-type) &rest args)
- (declare (ignore instance))
- (apply ,expr args)))
\ No newline at end of file
;;; maps meta-model slot-types to slot-presentation
(defparameter *slot-type-map*
- '(boolean ucw::mewa-boolean
- string ucw::mewa-string
- number ucw::mewa-currency
- integer ucw::mewa-integer
- currency ucw::mewa-currency
- ))
+ '(boolean mewa-boolean
+ string mewa-string
+ number mewa-currency
+ integer mewa-integer
+ currency mewa-currency))
;;; an alist of model-class-name . attributes
;;; should really be a hash-table.
(cons (car s)
(gen-pslot
(if (meta-model:foreign-key-p model (car s))
- 'ucw::foreign-key
+ 'foreign-key
(cadr s))
(string (car s)) (car s))))
(meta-model:list-slot-types model))
(mapcar #'(lambda (s)
- (cons s (append (gen-pslot 'ucw::has-many (string s) s)
+ (cons s (append (gen-pslot 'has-many (string s) s)
`(:presentation
(make-presentation
,model
(defcomponent mewa ()
- ((ucw::instance :accessor instance :initarg :instance)
+ ((instance :accessor instance :initarg :instance)
(attributes
:initarg :attributes
:accessor attributes
(let ((class-name
(or (gethash (if (consp (second attribute))
(car (second attribute))
- (second attribute))
- ucw::*slot-type-mapping*)
- (error "Can't find slot type for ~A" (second attribute)))))
+ (second attribute))
+ *presentation-slot-type-mapping*)
+ (error "Can't find slot type for ~A in ~A but ~A" attribute *presentation-slot-type-mapping* (gethash 'mewa:has-very-many *presentation-slot-type-mapping*)))))
- (cons (first attribute) (apply #'make-instance
- class-name
- (append (cddr attribute) (list :parent self :size 30))))))
+ (cons (first attribute) (apply #'make-instance
+ class-name
+ (append (cddr attribute) (list :parent self :size 30))))))
(defmethod find-slot-presentations ((self mewa))
(mapcar #'(lambda (a) (find-slot-presentation-for-attribute self a))
(a (progn (setf (slot-value p 'ucw::instance) object)
(initialize-slots p)
(assoc type (find-all-attributes p))))
- ;;;; TODO: this can be cleaned up, probably CHANGE-CLASS is better here
(i (apply #'make-instance (or (second a)
;; if we didnt find the type,
;; use the symbol as a class.
(or (meta-model:list-keys (instance self))))
;;;objects
-(defcomponent mewa-object-presentation (mewa ucw:object-presentation)
- ((ucw::instance :accessor instance :initarg :instance :initform nil)))
+(defcomponent mewa-object-presentation (mewa object-presentation)
+ ((instance :accessor instance :initarg :instance :initform nil)))
(defmethod present ((pres mewa-object-presentation))
(<:table :class (css-class pres)
(present-slot-as-row pres slot))))
(render-options pres (instance pres)))
-(defmethod present-slot-as-row ((pres mewa-object-presentation) (slot ucw::slot-presentation))
+(defmethod present-slot-as-row ((pres mewa-object-presentation) (slot slot-presentation))
(<:td :class "presentation-slot-label" (<:as-html (label slot)))
(<:td :class "presentation-slot-value" (present-slot slot (instance pres))))
;;;lists
-(defcomponent mewa-list-presentation (mewa ucw:list-presentation)
- ((ucw::instances :accessor instances :initarg :instances :initform nil)
+(defcomponent mewa-list-presentation (mewa list-presentation)
+ ((instances :accessor instances :initarg :instances :initform nil)
(instance :accessor instance)
(select-label :accessor select-label :initform "select" :initarg :select-label)
(selectablep :accessor selectablep :initform t :initarg :selectablep)
- (ucw::deleteablep :accessor deletablep :initarg :deletablep :initform nil)
+ (deleteablep :accessor deletablep :initarg :deletablep :initform nil)
(viewablep :accessor viewablep :initarg :viewablep :initform nil)))
(defaction select-from-listing ((listing mewa-list-presentation) object index)
(defmethod render-list-row ((listing mewa-list-presentation) object index)
(<:tr :class "item-row"
(<:td :align "center" :valign "top"
- (when (ucw::editablep listing)
+ (when (editablep listing)
(let ((object object))
(<ucw:input :type "submit"
:action (edit-from-listing listing object index)
- :value (ucw::edit-label listing))))
+ :value (edit-label listing))))
(<:as-is " ")
- (when (ucw::deleteablep listing)
+ (when (deleteablep listing)
(let ((index index))
(<ucw:input :type "submit"
:action (delete-from-listing listing object index)
- :value (ucw::delete-label listing))))
+ :value (delete-label listing))))
(when (selectablep listing)
(let ((index index))
(<ucw:input :type "submit"
`(defmethod search-expr ((,self ,criteria-type) instance)
(,model-expr
instance
- (ucw::slot-name (ucw::presentation ,self))
+ (slot-name (presentation ,self))
,@body)))
-(defmethod search-expr ((self ucw::negated-criteria) instance)
- (when (ucw::criteria self)
+(defmethod search-expr ((self negated-criteria) instance)
+ (when (criteria self)
(meta-model:expr-not
instance
- (search-expr (ucw::criteria self) instance))))
+ (search-expr (criteria self) instance))))
-(def-search-expr ((self ucw::string-starts-with))
- (meta-model:expr-starts-with (ucw::search-text self)))
+(def-search-expr ((self string-starts-with))
+ (meta-model:expr-starts-with (search-text self)))
-(def-search-expr ((self ucw::string-ends-with))
- (meta-model:expr-ends-with (ucw::search-text self)))
+(def-search-expr ((self string-ends-with))
+ (meta-model:expr-ends-with (search-text self)))
-(def-search-expr ((self ucw::string-contains))
- (meta-model:expr-contains (ucw::search-text self)))
+(def-search-expr ((self string-contains))
+ (meta-model:expr-contains (search-text self)))
-(def-search-expr ((self ucw::number-less-than))
- (meta-model:expr-< (ucw::number-input self)))
+(def-search-expr ((self number-less-than))
+ (meta-model:expr-< (number-input self)))
-(def-search-expr ((self ucw::number-greater-than))
- (meta-model:expr-> (ucw::number-input self)))
+(def-search-expr ((self number-greater-than))
+ (meta-model:expr-> (number-input self)))
-(def-search-expr ((self ucw::number-equal-to))
- (meta-model:expr-= (ucw::number-input self)))
+(def-search-expr ((self number-equal-to))
+ (meta-model:expr-= (number-input self)))
-(defcomponent mewa-presentation-search (ucw::presentation-search)
+(defcomponent mewa-presentation-search (presentation-search)
((display-results-p :accessor display-results-p :initarg :display-results-p :initform nil)
(criteria-input :accessor criteria-input :initform "")
(new-criteria :accessor new-criteria :initform nil)))
(defmethod instance ((self mewa:mewa-presentation-search))
- (instance (ucw::search-presentation self)))
+ (instance (search-presentation self)))
(defmethod search-expr ((self mewa:mewa-presentation-search) instance)
(apply #'meta-model:expr-and instance
(mapcan (lambda (c) (let ((e (search-expr c instance)))
(if (listp e) e (list e))))
- (ucw::criteria self))))
+ (criteria self))))
(defmethod search-query ((self mewa:mewa-presentation-search))
(search-expr self (instance self)))
(defmethod ok ((self mewa-presentation-search) &optional arg)
(declare (ignore arg))
- (setf (ucw::instances (ucw::list-presentation self)) (valid-instances self))
+ (setf (instances (list-presentation self)) (valid-instances self))
(setf (display-results-p self) t))
-(defmethod set-search-input-for-criteria ((criteria ucw::criteria) (input t))
+(defmethod set-search-input-for-criteria ((criteria criteria) (input t))
(error "No search-input-for-criteria method for ~A : ~A" criteria input))
-(defmethod set-search-input-for-criteria ((c ucw::string-criteria) input)
- (setf (ucw::search-text c) input))
+(defmethod set-search-input-for-criteria ((c string-criteria) input)
+ (setf (search-text c) input))
-(defmethod set-search-input-for-criteria ((c ucw::negated-criteria) i)
+(defmethod set-search-input-for-criteria ((c negated-criteria) i)
nil)
-(defmethod mewa-add-criteria ((self component) (criteria ucw::criteria))
+(defmethod mewa-add-criteria ((self component) (criteria criteria))
(set-search-input-for-criteria criteria (criteria-input self))
- (ucw::add-criteria self criteria))
+ (add-criteria self criteria))
-(defmethod find-default-criteria (c ucw::mewa-string-slot-presentation)
- 'ucw::string-contains)
+(defmethod find-default-criteria (c mewa-string-slot-presentation)
+ 'string-contains)
(defmethod render-criteria ((res response) (s mewa-presentation-search))
(setf (criteria-input s) "")
(<:ul
- (dolist (c (ucw::criteria s))
+ (dolist (c (criteria s))
(<:li (render-on res c)
(let ((c c))
- (<ucw:input :action (ucw::drop-criteria s c) :type "submit" :value "eliminate"))))
+ (<ucw:input :action (drop-criteria s c) :type "submit" :value "eliminate"))))
(<:li
"Search For: "
(<ucw:input :type "text" :accessor (criteria-input s))
" Using : "
(<ucw:select :accessor (new-criteria s)
- (dolist (criteria (ucw::applicable-criteria s))
+ (dolist (criteria (applicable-criteria s))
(<ucw:option :value criteria (<:as-html (label criteria)))))
(<ucw:input :type "submit" :action (mewa-add-criteria s (new-criteria s))
:value "add"))))
(render-criteria res self)
(<ucw:input :type "submit" :value "Search" :action (submit-search self))
(when (display-results-p self)
- (let ((listing (ucw::list-presentation self)))
+ (let ((listing (list-presentation self)))
(setf
(slot-value listing 'ucw::calling-component) (slot-value self 'ucw::calling-component)
(slot-value listing 'ucw::place) (slot-value self 'ucw::place)
-(in-package :it.bese.ucw)
+(in-package :mewa)
(defun multiple-value-funcall->list (function &rest args)
"The function to be called by m-v-bf"
;;;; ** Textarea Slot Presentation
-;;;; This should really be in UCW.
(defslot-presentation text-slot-presentation ()
((rows :initarg :rows :accessor rows :initform nil)
(defslot-presentation mewa-relation-slot-presentation (mewa-slot-presentation slot-presentation)
((foreign-instance :accessor foreign-instance)
(linkedp :accessor linkedp :initarg :linkedp :initform t)
- (creator :accessor creator :initarg :creator :initform :editor))
+ (creator :accessor creator :initarg :creator :initform :editor)
+ (new-instance :accessor new-instance :initform nil))
(:type-name relation))
(defaction search-records ((slot mewa-relation-slot-presentation) instance)
(multiple-value-bindf (finstance foreign-slot-name)
(meta-model:explode-foreign-key instance (slot-name slot))
- (let ((new-instance
- (call-component
- (parent slot)
- (make-instance (or (cadr (mewa:find-attribute finstance :presentation-search))
- 'mewa::mewa-presentation-search)
- :search-presentation
- (mewa:make-presentation finstance
- :type :search-presentation)
- :list-presentation
- (mewa:make-presentation finstance
- :type :listing)))))
- (setf (slot-value instance (slot-name slot)) (slot-value new-instance foreign-slot-name))
- (meta-model:sync-instance instance :fill-gaps-only-p (fill-gaps-only-p self)))))
-
+ (let ((new-instance (new-instance self)))
+ (unless new-instance
+ (setf (new-instance self)
+ (call-component
+ (ucw::parent slot)
+ (make-instance (or (cadr (mewa:find-attribute finstance :presentation-search))
+ 'mewa::mewa-presentation-search)
+ :search-presentation
+ (mewa:make-presentation finstance
+ :type :search-presentation)
+ :list-presentation
+ (mewa:make-presentation finstance
+ :type :listing)))))
+ (sync-foreign-instance slot new-instance))))
+
+(defmethod sync-foreign-instance ((slot mewa-relation-slot-presentation) foreign-instance)
+ (let ((instance (instance (ucw::parent slot))))
+ (multiple-value-bind (foo f-slot-name)
+ (meta-model:explode-foreign-key instance (slot-name slot))
+ (setf (slot-value instance (slot-name slot)) (slot-value foreign-instance f-slot-name))
+ (meta-model:sync-instance instance :fill-gaps-only-p (fill-gaps-only-p slot)))))
+
+
(defaction create-record-on-foreign-key ((slot mewa-relation-slot-presentation) instance)
(multiple-value-bindf (finstance foreign-slot-name)
(meta-model:explode-foreign-key instance (slot-name slot))
(let ((new-instance
(call-component
- (parent slot)
+ (ucw::parent slot)
(mewa:make-presentation finstance :type (creator self)))))
;;;; TODO: this next bit is due to a bad design decision.
(:default-initargs))
(defaction view-instance ((self component) instance &rest initargs)
- (call-component (parent self) (apply #'mewa:make-presentation instance initargs))
+ (call-component (ucw::parent self) (apply #'mewa:make-presentation instance initargs))
;; the viewed instance could have been changed/deleted, so we sync this instance
- (meta-model:sync-instance (instance (parent self))))
+ (meta-model:sync-instance (instance (ucw::parent self))))
(defmethod present-slot :around ((slot foreign-key-slot-presentation) instance)
(when (presentation-slot-value slot instance)
(meta-model:explode-foreign-key instance (slot-name slot))))
(flet ((render () (when (foreign-instance slot)(call-next-method))))
- (if (slot-boundp slot 'place)
+ (if (slot-boundp slot 'ucw::place)
(cond
((editablep slot)
(<ucw:submit :action (search-records slot instance) :value "Search" :style "display:inline")
(render))))
-;;;; * AJAX stuff
-
-;;;; TODO: This search stuff should probably me refactored elsewhere
-
-(defmethod find-slots-of-type (model &key (type 'string)
- (types '((string)) types-supplied-p))
- "returns a list of slots matching TYPE, or matching any of TYPES"
- (let (ty)
- (if types-supplied-p
- (setf ty types)
- (setf ty (list type)))
- (remove nil (mapcar #'(lambda (st) (when (member (second st) ty)
- (first st)))
- (lisp-on-lines::list-slot-types model)))))
-
-(defslot-presentation ajax-foreign-key-slot-presentation (foreign-key-slot-presentation)
- ((search-slots :accessor search-slots :initarg :search-slots :initform nil)
- (live-search
- :accessor live-search
- :component (lisp-on-lines:auto-complete
- :values-generator
- (lambda (value)
- (when (< 0 (length value))
- (limited-word-search 'person '(first-name last-name company-name) (list value))))
-
- :render (lambda (x)
- (<:as-html (if (> (length (last-name x)) 0)
- (strcat (last-name x) ", ")
- " ")
- (first-name x)" " (company-name x)))
- :as-value (lambda (x) x)
- :submit-on-click-p nil)))
- (:type-name ajax-foreign-key))
-
-
-(defmethod shared-initialize :after ((slot ajax-foreign-key-slot-presentation) slots &rest args)
- ;; If no search-slots than use the any slots of type string
- (unless (search-slots slot)
- (setf (search-slots slot) t)
- (let ((l (live-search slot)))
- (setf (lisp-on-lines::values-generator l) t))))
-
-
-(defmethod present-slot :around ((slot ajax-foreign-key-slot-presentation) instance)
- (setf (foreign-instance slot)
- (when (presentation-slot-value slot instance)
- (meta-model:explode-foreign-key instance (slot-name slot))))
- (flet ((render () (when (foreign-instance slot)(call-next-method))))
- (if (slot-boundp slot 'place)
- (cond
- ((editablep slot)
-
- (<ucw:submit :action (search-records slot instance) :value "find" :style "display:inline"))
- ((linkedp slot)
- (<ucw:a :action (view-instance slot (foreign-instance slot))
- (render)))
- (t
- (render)))
- ;; presentation is used only for rendering
- (render))))
+
;;;; HAS MANY
(defslot-presentation has-many-slot-presentation (mewa-relation-slot-presentation)
(defaction add-to-has-many ((slot has-many-slot-presentation) instance)
;; if the instance is not stored we must make sure to mark it stored now!
(unless (mewa::instance-is-stored-p instance)
- (setf (mewa::modifiedp (parent self)) t))
+ (setf (mewa::modifiedp (ucw::parent self)) t))
;; sync up the instance
;;(mewa:ensure-instance-sync (parent slot))
- (meta-model:sync-instance (instance (parent slot)))
+ (meta-model:sync-instance (instance (ucw::parent slot)))
(multiple-value-bindf (class home foreign)
(meta-model:explode-has-many instance (slot-name slot))
(let ((new (make-instance class)))
(setf (slot-value new foreign) (slot-value instance home))
(meta-model:sync-instance new :fill-gaps-only-p (fill-gaps-only-p self))
- (call-component (parent slot) (mewa:make-presentation new :type (creator slot)))
+ (call-component (ucw::parent slot) (mewa:make-presentation new :type (creator slot)))
(meta-model:sync-instance instance))))
(defmethod present-slot ((slot has-many-slot-presentation) instance)
- (when (slot-boundp slot 'place)
+ (when (slot-boundp slot 'ucw::place)
(<ucw:submit :action (add-to-has-many slot instance) :value (add-new-label slot)))
(let ((i (get-foreign-instances slot instance)))
(dolist (s i)
(let ((s s))
(setf (foreign-instance slot) s)
- (when (slot-boundp slot 'place)
+ (when (slot-boundp slot 'ucw::place)
(<ucw:a :action (view-instance slot s :initargs `(:global-properties ,(list :linkedp t :editablep nil)))
(<:li (setf (linkedp slot) nil)
(present-relation slot instance)))))))))
(current :accessor current :initform 0)
(len :accessor len )
(instances :accessor instances))
-
(:type-name has-very-many))
(defmethod list-next ((slot has-very-many-slot-presentation))
(defmethod present-slot ((slot has-very-many-slot-presentation) instance)
;;(<:as-html "isance: " instance)
- (if (slot-boundp slot 'place)
+ (if (slot-boundp slot 'ucw::place)
(progn
(<ucw:a :action (list-prev slot) (<:as-html "<<"))
- (let ((self (parent slot)))
+ (let ((self (ucw::parent slot)))
(<ucw:a :action (call-component self (mewa:make-presentation (car (slot-value instance (slot-name slot))) :type :listing :initargs (list :instances (instances slot))))
(<:as-html (label slot) (format nil " ~a-~a " (current slot) (+ (current slot) (number-to-display slot))))))
(<ucw:a :action (list-next slot) (<:as-html ">>"))
-(defpackage :meta-model
- (:use :common-lisp :clsql :clsql-pg-introspect)
- (:shadow :primary-key-p)
- (:export
- :meta-model-class
- :meta-model.base-type
- :meta-model.instance
- :meta-model.metadata
- :define-meta-model
- :def-view-class-from-table
- :def-view-class/meta
- :view-class-metadata
- :create-table-from-model
- :list-slots
- :list-slot-types
- :slot-type
- :display-slot
- :list-joins
- :list-join-attributes
- :list-keys
- :list-view-classes
- :display-slot
- :primary-key-p
- :list-foreign-keys
- :foreign-key-p
- :explode-foreign-key
- :find-join-class
- :find-join-key
- :find-default-value
- :explode-foreign-key
- :list-has-many
- :list-many-to-many
- :sync-instance
- :explode-has-many
- :expr-ends-with
- :expr-starts-with
- :expr-contains
- :expr-=
- :expr-<
- :expr->
- :expr-and
- :expr-or
- :expr-not
- :select-instances))
-
-
-(defpackage :mewa
- (:use :ucw :common-lisp)
- (:export
- :mewa
- :mewa-object-presentation
- :mewa-one-line-presentation
- :mewa-list-presentation
- :mewa-presentation-search
- :find-attribute
- :set-default-attributes
- :make-presentation
- :call-presentation
- :label
- :attributes
- :set-attribute
- :set-attribute-properties
- :perform-set-attributes
- :perform-set-attribute-properties
- :find-class-attributes
- :default-attributes
- :ok
- :edit-instance
- :save-instance
- :cancel-save-instance
- :ensure-instance-sync
- :instance-is-stored-p
- :global-properties
- :search-expr
- :search-query))
-
-(defpackage :lisp-on-lines
- (:use :mewa :meta-model :common-lisp :it.bese.ucw :js)
- (:nicknames :lol)
- (:export
- ;;;; LoL
- :initialize-lol-for-table
- :initialize-lol-for-database
-
- ;;;; Ajax
- :auto-complete
- :call-auto-complete
-
- ;;;; Mewa Exports
- :mewa ;the superclass of all mewa-presentations
- :make-presentation
- :call-presentation
- ;;attributes
- :attributes
- :set-default-attributes
- :set-attribute
- :find-attribute
- :perform-set-attributes
- ;;
- :perform-set-attribute-properties
-
- ;; presentation objects
- :mewa-object-presentation
- :mewa-one-line-presentation
- :mewa-list-presentation
-
- ;; CRUD
- :instance-is-stored-p
-
- ;;;; Meta Model Exports))
- :define-meta-model
- :def-view-class-from-table
- :def-view-class/meta
- :list-slot-types
- ))
\ No newline at end of file
+(defpackage :lisp-on-lines
+ (:use :mewa :meta-model :common-lisp :it.bese.ucw :js :clsql)
+ (:nicknames :lol)
+ (:export
+ ;;;; LoL
+ :initialize-lol-for-table
+ :initialize-lol-for-database
+
+ ;;;; Ajax
+ :auto-complete
+ :call-auto-complete
+
+ ;;;; Mewa Exports
+ :mewa ;the superclass of all mewa-presentations
+ :make-presentation
+ :call-presentation
+ ;;attributes
+ :attributes
+ :set-default-attributes
+ :set-attribute
+ :find-attribute
+ :perform-set-attributes
+ ;;
+ :perform-set-attribute-properties
+
+ ;; presentation objects
+ :mewa-object-presentation
+ :mewa-one-line-presentation
+ :mewa-list-presentation
+
+ ;; CRUD
+ :instance-is-stored-p
+
+ ;;;; Meta Model Exports))
+ :define-meta-model
+ :def-view-class-from-table
+ :def-view-class/meta
+ :list-slot-types
+ ))
\ No newline at end of file
HCoop / clinton / lisp-on-lines.git / commitdiff