|
- #|
-
- src/models/registered-table-mixin.lisp
-
- Model Object Class. Instead of writing new code every time for every
- new Model (Model, View, Component), encapsulate the behavior here.
-
- Now using mixins!
-
- |#
-
- (in-package #:cl-deck-builder2.models.registered-table)
-
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;; Thanks mariari! https://lispcookbook.github.io/cl-cookbook/clos.html#metaclasses
- (defclass model-registry ()
- ((registry :allocation :class
- :accessor model-registry
- :initform (make-hash-table))))
-
- (defmethod registered-classes ((registry model-registry) &optional package)
- (if package
- (gethash (find-package package) (model-registry registry))
- ;; If no package was provided return a LIST of all packages tracked by the MODEL-REGISTRY.
- (apply #'concatenate 'list
- (alexandria:hash-table-values (model-registry registry)))))
-
- (defparameter *registry* (make-instance 'model-registry)
- "Global model registry instance.")
-
- (defun registry (&optional (registry *registry*))
- "Get the MODEL-REGISTRY associated with REGISTRY. Default is *REGISTRY*."
- registry)
-
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;; Inherit from MITO:DAO-TABLE-CLASS because MITO:DAO-TABLE-MIXIN
- ;; doesn't have the additional PRIMARY-KEY or TIMESTAMP mechanisms or
- ;; anything.
- (defclass registered-table-class (mito:dao-table-class) ())
-
- (defmethod closer-mop:validate-superclass ((class registered-table-class)
- (superclass mito:dao-table-class))
- t)
-
- (defmethod initialize-instance :after ((class registered-table-class) &rest initargs &key &allow-other-keys)
- (declare (ignore initargs))
- (pushnew (class-name class)
- (gethash (symbol-package (class-name class))
- (model-registry (registry)))))
-
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;; Tables
- (defmethod create-tables ((registry model-registry) &optional package)
- "Create tables for CLASS-LIST by wrapping DBD:CREATE-TABLE."
- (apply #'create-table
- (registered-classes registry package)))
-
- (defmethod drop-tables ((registry model-registry) &optional package)
- "Drop tables for CLASS-LIST by wrapping DB:DROP-TABLE."
- (apply #'drop-table
- (registered-classes registry package)))
-
- (defmethod recreate-tables ((registry model-registry) &optional package)
- (drop-tables registry package)
- (create-tables registry package))
-
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- (defmethod migration-expressions ((registry model-registry) &optional package)
- (with-connection (db)
- (with-transaction
- (mapcar #'mito:migration-expressions
- (registered-classes registry package)))))
-
- (defmethod migrate-table ((registry model-registry) &optional package)
- (with-connection (db)
- (with-transaction
- (mapcar #'mito:migrate-table
- (registered-classes registry package)))))
-
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- (defun ensure-tables-exist (&optional package)
- (create-tables (registry) package))
-
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- (defmethod export-registered-classes ((registry model-registry) &key package (stream *standard-output*))
- "Export REGISTERED-CLASSES for REGISTRY to STREAM, which by default, is *STANDARD-OUTPUT*."
- (with-connection (db)
- (with-transaction
- (format stream "~{~a~^;~%~};"
- (mapcar (lambda (class) (sxql:yield (car (mito:table-definition class))))
- (registered-classes registry package))))))
-
- (defun export-registered-classes-to-file (&key (output (relative-pathname "db/schema.sql")) package)
- (with-open-file (stream output
- :direction :output
- :if-exists :supersede
- :if-does-not-exist :create)
- (export-registered-classes (registry) :package package :stream stream)
- (probe-file output)))
|