diff options
Diffstat (limited to 'src/record.lisp')
| -rw-r--r-- | src/record.lisp | 269 |
1 files changed, 269 insertions, 0 deletions
diff --git a/src/record.lisp b/src/record.lisp new file mode 100644 index 0000000..31d7f50 --- /dev/null +++ b/src/record.lisp @@ -0,0 +1,269 @@ + ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :org-ckons-sql) + +(defclass record (org-ckons-serializable::serializable) + ((*project :initarg :*project + :initform nil + :accessor *project) + (*table :initarg :*table + :initform (error "Subclasses of RECORD must supply an initform for the *TABLE slot.") + :accessor *table) + (*where-expression :initarg :*where-expression + :initform (error "Subclasses of RECORD must supply an initform for the *WHERE-EXPRESSION slot.") + :accessor *where-expression + :documentation "A string that specifies a WHERE +clause that is the proper format to feed through +`expand-where-expression'. `nil' if the `record' subclass is +read-only, as would be the case if the backing table is a view, or a +table that you do not ever want to write to.")) + (:documentation "Superclass for all sql record objects. Since some +`record' subclasses are also `session' subclasses, `record' is +sometimes involved in multiple inheritance. + +`record' is not 100% ready to be used directly as a superclass of a +concrete entity object. We need a few more methods than what `record' +alone supplies: + +`sysdate' +`to-date' +`sanitize' + +See `postgres-record' as an example of their implementations. All +`record' subclasses are really direct subclasses of one of these +database-specific variants.")) + +(defmacro with-record-slots-to-string (record &rest body) + "Iterates over all the slots of `record', and builds a string based +on those slots. The action taken on each slot is completely +customizable; this macro only provides the loop. It is assumed that +the fencepost problem will creep into your string, so this macro trims +the last character." + `(let ((record-slot-string (make-array '(0) :element-type 'character :fill-pointer 0 :adjustable t))) + (with-output-to-string (stream record-slot-string) + (loop for slot in (org-ckons-core::map-slot-names ,record) do + (when (slot-is-field-p slot) ,@body))) + (org-ckons-core::trim-last-char record-slot-string))) + +(defmacro with-record-slots-to-list (record &rest body) + "Iterates over all the slots of `record', and builds an alist based +on those slots." + `(remove-if 'null (mapcar (lambda (slot) + (when (slot-is-field-p slot) + ,@body)) + (org-ckons-core::map-slot-names ,record)))) + +;; (defmethod id ((record record)) +;; (car (remove-if 'null (mapcar (lambda (slot) +;; (when (string= (org-ckons-core::parse-slot slot) "ID") +;; (slot-value record slot))) +;; (org-ckons-core::map-slot-names record))))) + +;; (defmethod (setf id) (value (record record)) +;; (loop for slot in (org-ckons-core::map-slot-names record) do +;; (when (string= (org-ckons-core::parse-slot slot) "ID") +;; (setf (slot-value record slot) value)))) + +(defmethod field-names-string ((record record)) + (with-record-slots-to-string record (format stream "~a," slot))) + +(defmethod field-values-string ((record record)) + (with-record-slots-to-string record (format stream "~a," (sanitize record (slot-value record slot))))) + +(defmethod field-value-pairs ((record record)) + (with-record-slots-to-string record (format stream "~a = ~a," slot (sanitize record (slot-value record slot))))) + +(defmethod field-value-pairs-no-nulls ((record record)) + (with-record-slots-to-string record (when (slot-value record slot) + (format stream "~a = ~a," slot (sanitize record (slot-value record slot)))))) + +(defmethod field-value-list ((record record)) + (with-record-slots-to-list record `(,slot . ,(slot-value record slot)))) + +(defmethod field-value-list-no-nulls ((record record)) + (with-record-slots-to-list record (when (slot-value record slot) + `(,slot . ,(slot-value record slot))))) + +(defmethod field-plist-no-nulls ((record record)) + (let ((field-plist ())) + (loop for field in (field-value-list-no-nulls record) do + (setf field-plist (append field-plist `(,(intern (format nil "~a" (car field)) "KEYWORD") ,(cdr field))))) + field-plist)) + +(defmethod build-where-clause ((record record)) + (if (field-value-list-no-nulls record) + (reduce (lambda (x y) + (format nil "~a AND ~a" x y)) + (mapcar (lambda (slot-cons) + (format nil "~a = ~a" (car slot-cons) (sanitize record (cdr slot-cons)))) + (field-value-list-no-nulls record))) + nil)) + +(defmethod intersect-slots ((record record) slots) + (let ((intersect-slots ())) + (loop for class-slot in (org-ckons-core::map-slot-names record) do + (let ((class-slot-string (org-ckons-core::parse-slot class-slot))) + (loop for arg-slot in slots do + (let ((arg-slot-string (org-ckons-core::parse-slot arg-slot))) + (when (string= class-slot-string arg-slot-string) + (push class-slot intersect-slots)))))) + (nreverse intersect-slots))) + +(defmethod expand-where-expression ((record record) where-expression) + (if (org-ckons-core::null-or-empty-p where-expression) + "" + (let ((field-names (nreverse (remove-if (lambda (x) + (or (org-ckons-core::null-or-empty-p x) + (equal x "LIKE") + (equal x "NOT"))) + (ppcre:split "[ ()!=<>,]" where-expression)))) + (slots ()) + (slot-values ())) + (let ((field-name-impending-p nil)) + (loop for field-name in field-names do + (cond (field-name-impending-p + (push (intern (string-upcase field-name)) slots) + (setf field-name-impending-p nil)) + (t + (when (ppcre:all-matches-as-strings "~a" field-name) + (setf field-name-impending-p t)))))) + (loop for slot in (intersect-slots record slots) do + (when (slot-is-field-p slot) + (push (sanitize record (slot-value record slot)) slot-values))) + (org-ckons-core::format-list (concatenate 'string " WHERE " where-expression) (reverse slot-values))))) + +(defmethod insert-query ((record record)) + (let* ((field-value-alist (field-value-list-no-nulls record))) + (format nil + "INSERT INTO ~a (~a) VALUES (~a)" + (org-ckons-core::format-list (if (slot-exists-p record '*write-table) (slot-value record '*write-table) (slot-value record '*table)) `(,(*project record))) + (org-ckons-core::reduce-to-comma-separated-string (mapcar (lambda (pair) + (car pair)) + field-value-alist)) + (org-ckons-core::reduce-to-comma-separated-string (mapcar (lambda (pair) + (sanitize record (cdr pair))) + field-value-alist))))) + +(defmethod currval-query ((record record)) + (format nil "SELECT * from currval(pg_get_serial_sequence('~a', 'id'))" (*table record))) + +(defmethod update-query ((record record)) + (if (null (*where-expression record)) + (error 'org-ckons-condition::handled-error (format nil "Attempting to update a record of type ~a, but it has no *WHERE-EXPRESSION" (type-of record))) + (format nil + "UPDATE ~a SET ~a~a" + (org-ckons-core::format-list (if (slot-exists-p record '*write-table) (slot-value record '*write-table) (slot-value record '*table)) `(,(*project record))) + (field-value-pairs record) + (expand-where-expression record (*where-expression record))))) + +(defmethod select-query ((record record)) + (format nil + "SELECT ~a FROM ~a" + (field-names-string record) + (org-ckons-core::format-list (*table record) `(,(*project record))))) + +(defmethod delete-query ((record record)) + (format nil + "DELETE FROM ~a" + (org-ckons-core::format-list (if (slot-exists-p record '*write-table) + (slot-value record '*write-table) + (slot-value record '*table)) + `(,(*project record))))) + +(defmethod insert-record* ((record record)) + (execute-command (insert-query record)) + (setf (id record) (caar (execute-query (currval-query record))))) + +(defmethod update-record* ((record record)) + (execute-command (update-query record))) + +(defmethod select-records-impl* ((record record) where-expression order-by-clause) + (let* ((where-string (expand-where-expression record where-expression)) + (order-by-string (if (org-ckons-core::null-or-empty-p order-by-clause) + "" + (format nil " ORDER BY ~a" order-by-clause))) + (sql-query (format nil + "~a~a~a" + (select-query record) + where-string + order-by-string))) + (execute-query sql-query))) + +(defmethod select-records* ((record record) order-by-clause) + (select-records-where* record (build-where-clause record) order-by-clause)) + +(defmethod select-records-where* ((record record) where-expression order-by-clause) + (let* ((result-set (select-records-impl* record where-expression order-by-clause)) + (records ())) + (loop for row in result-set do + (let ((my-record (make-instance (type-of record)))) + (load-record my-record row) + (push my-record records))) + (nreverse records))) + +(defmethod delete-records-impl* ((record record) where-expression) + (let* ((where-string (expand-where-expression record where-expression)) + (sql-query (format nil "~a~a" (delete-query record) where-string))) + (execute-command sql-query))) + +(defmethod delete-record* ((record record)) + (delete-records-where* record (format nil (*where-expression record) (id record)))) + +(defmethod delete-records* ((record record)) + (delete-records-where* record (build-where-clause record))) + +(defmethod delete-records-where* ((record record) where-expression) + (delete-records-impl* record where-expression)) + +(defmethod load-record ((record record) row) + (loop for slot in (org-ckons-core::map-slot-names record) do + (when (slot-is-field-p slot) + (eval `(setf (,slot ,record) ,(pop row)))))) + +(defmethod sanitize-json ((record record)) + (setf (*project record) nil) + (setf (*table record) nil) + (setf (*where-expression record) nil)) + +(defun slot-is-field-p (slot) + (equal (symbol-name slot) (ppcre:regex-replace "^\\*" (symbol-name slot) ""))) + +(defun execute-command (sql-query) + "Given a SQL query in a string, runs the query. No result set is +returned. Use this for INSERT, UPDATE, DELETE, etc." + ;;(print sql-query) + (postmodern:execute sql-query)) + +(defun execute-query (sql-query) + "Given a SQL query in a string, runs the query and returns the +result set. Use this for SELECT." + ;;(print sql-query) + (postmodern:query sql-query)) + +(defun timestamp-to-date (timestamp) + (let ((dateparts (ppcre:split "-" (local-time:to-rfc3339-timestring timestamp)))) + (ppcre:regex-replace-all "T" (format nil "~a-~a-~a" (pop dateparts) (pop dateparts) (pop dateparts)) " "))) + +(defun universal-to-date (universal) + (timestamp-to-date (local-time:universal-to-timestamp universal))) + +(defun simple-date-to-date (simple-date) + (universal-to-date (simple-date:timestamp-to-universal-time simple-date))) + +(defun get-date (full-sql-date) + (car (ppcre:split "\\." full-sql-date))) + +(defun notime (full-sql-date) + (car (ppcre:split " " full-sql-date))) + +(defun quote-string (field) + "Puts single ticks around `field'." + (format nil "'~a'" (ppcre:regex-replace-all "'" field "''"))) + +(defun get-slot-names-list (record-type) + "Returns a list of field slots in `record-type'. `record-type' is a +symbol, not a `record' instance." + (remove-if-not (lambda (x) + (slot-is-field-p x)) + (org-ckons-core::map-slot-names (make-instance (find-class record-type))))) |