659 lines
26 KiB
EmacsLisp
659 lines
26 KiB
EmacsLisp
|
;;; closql.el --- Store EIEIO objects using EmacSQL -*- lexical-binding:t -*-
|
||
|
|
|
||
|
|
;; Copyright (C) 2016-2026 Jonas Bernoulli
|
||
|
|
|
||
|
|
;; Author: Jonas Bernoulli <emacs.closql@jonas.bernoulli.dev>
|
||
|
|
;; Homepage: https://github.com/emacscollective/closql
|
||
|
|
;; Keywords: extensions
|
||
|
|
|
||
|
|
;; Package-Version: 20260601.1540
|
||
|
|
;; Package-Revision: d382e7427f5d
|
||
|
|
;; Package-Requires: (
|
||
|
|
;; (emacs "28.1")
|
||
|
|
;; (compat "31.0")
|
||
|
|
;; (cond-let "1.1")
|
||
|
|
;; (emacsql "4.4")
|
||
|
|
;; (llama "1.0"))
|
||
|
|
|
||
|
|
;; SPDX-License-Identifier: GPL-3.0-or-later
|
||
|
|
|
||
|
|
;; This file is free software: you can redistribute it and/or modify
|
||
|
|
;; it under the terms of the GNU General Public License as published
|
||
|
|
;; by the Free Software Foundation, either version 3 of the License,
|
||
|
|
;; or (at your option) any later version.
|
||
|
|
;;
|
||
|
|
;; This file is distributed in the hope that it will be useful,
|
||
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
|
|
;; GNU General Public License for more details.
|
||
|
|
;;
|
||
|
|
;; You should have received a copy of the GNU General Public License
|
||
|
|
;; along with this file. If not, see <https://www.gnu.org/licenses/>.
|
||
|
|
|
||
|
|
;;; Commentary:
|
||
|
|
|
||
|
|
;; Store uniform EIEIO objects in an EmacSQL database. SQLite is used
|
||
|
|
;; as backend. This library imposes some restrictions on what kind of
|
||
|
|
;; objects can be stored; it isn't intended to store arbitrary objects.
|
||
|
|
;; All objects have to share a common superclass and subclasses cannot
|
||
|
|
;; add any additional instance slots.
|
||
|
|
|
||
|
|
;;; Code:
|
||
|
|
|
||
|
|
(require 'compat)
|
||
|
|
(require 'cond-let)
|
||
|
|
(require 'eieio)
|
||
|
|
(require 'eieio-base)
|
||
|
|
(require 'emacsql)
|
||
|
|
(require 'emacsql-sqlite)
|
||
|
|
(require 'llama)
|
||
|
|
|
||
|
|
(eval-when-compile (require 'subr-x))
|
||
|
|
|
||
|
|
(eval-when-compile
|
||
|
|
(cl-pushnew 'connection eieio--known-slot-names))
|
||
|
|
|
||
|
|
(defmacro closql-with-transaction (db &rest body)
|
||
|
|
(declare (indent 1))
|
||
|
|
`(emacsql-with-transaction (oref ,db connection)
|
||
|
|
,@body))
|
||
|
|
|
||
|
|
;;; Objects
|
||
|
|
|
||
|
|
(defclass closql-object ()
|
||
|
|
((closql-class-prefix :initform nil :allocation :class)
|
||
|
|
(closql-class-suffix :initform nil :allocation :class)
|
||
|
|
(closql-table :initform nil :allocation :class)
|
||
|
|
(closql-primary-key :initform nil :allocation :class)
|
||
|
|
(closql-foreign-key :initform nil :allocation :class)
|
||
|
|
(closql-order-by :initform nil :allocation :class)
|
||
|
|
(closql-database :initform nil :initarg :closql-database))
|
||
|
|
:abstract t)
|
||
|
|
|
||
|
|
(defun closql--closql-object-p (obj)
|
||
|
|
;; Prevent a recursive load when the class object is autoloaded.
|
||
|
|
;; See c1a9b816ec. Don't #'quote; doesn't exist in older releases.
|
||
|
|
(cl-letf (((symbol-function 'eieio--full-class-object)
|
||
|
|
#'eieio--class-object))
|
||
|
|
(closql-object--eieio-childp obj)))
|
||
|
|
|
||
|
|
;;;; Oref
|
||
|
|
|
||
|
|
(define-advice eieio-oref (:around (fn obj slot) closql-object)
|
||
|
|
"If OBJ is a `closql-object', delegate to `closql-oref'."
|
||
|
|
(if (closql--closql-object-p obj)
|
||
|
|
(closql-oref obj slot)
|
||
|
|
(funcall fn obj slot)))
|
||
|
|
|
||
|
|
(defun closql--oref (obj slot)
|
||
|
|
(aref obj (eieio--slot-name-index (eieio--object-class obj) slot)))
|
||
|
|
|
||
|
|
(defun closql--oref-default (class slot)
|
||
|
|
(let ((class (if (symbolp class)
|
||
|
|
(cl--find-class class)
|
||
|
|
(eieio--object-class class))))
|
||
|
|
(aref (eieio--class-class-allocation-values class)
|
||
|
|
(eieio--class-slot-name-index class slot))))
|
||
|
|
|
||
|
|
(defun closql-oref (obj slot)
|
||
|
|
(cl-check-type slot symbol)
|
||
|
|
(let ((class (eieio--object-class obj)))
|
||
|
|
(cond-let
|
||
|
|
([c (eieio--slot-name-index class slot)]
|
||
|
|
(let ((value (aref obj c)))
|
||
|
|
(if (eq value eieio--unbound)
|
||
|
|
(closql-dref obj slot)
|
||
|
|
value)))
|
||
|
|
([c (eieio--class-slot-name-index class slot)]
|
||
|
|
(aref (eieio--class-class-allocation-values class) c))
|
||
|
|
((slot-missing obj slot 'oref)))))
|
||
|
|
|
||
|
|
(cl-defgeneric closql-dref (obj slot)
|
||
|
|
(let ((c (eieio--slot-name-index (eieio--object-class obj) slot))
|
||
|
|
(db (closql--oref obj 'closql-database))
|
||
|
|
(props (closql--slot-properties obj slot)))
|
||
|
|
(cond-let
|
||
|
|
([class (alist-get :closql-class props)]
|
||
|
|
(aset obj c
|
||
|
|
(closql--remake-instances class db
|
||
|
|
(emacsql
|
||
|
|
db `[:select * :from $i1
|
||
|
|
:where (= $i2 $s3)
|
||
|
|
:order-by ,(or (closql--oref-default class 'closql-order-by)
|
||
|
|
[(asc $i4)])]
|
||
|
|
(closql--oref-default class 'closql-table)
|
||
|
|
(closql--oref-default class 'closql-foreign-key)
|
||
|
|
(closql--oref obj (closql--oref-default obj 'closql-primary-key))
|
||
|
|
(closql--oref-default class 'closql-primary-key)))))
|
||
|
|
([table (alist-get :closql-table props)]
|
||
|
|
(let ((columns (closql--table-columns db table)))
|
||
|
|
(aset obj c
|
||
|
|
(mapcar
|
||
|
|
(if (length= columns 2) #'cadr #'cdr)
|
||
|
|
(emacsql
|
||
|
|
db [:select * :from $i1
|
||
|
|
:where (= $i2 $s3)
|
||
|
|
:order-by [(asc $i4)]]
|
||
|
|
table
|
||
|
|
(car columns)
|
||
|
|
(closql--oref obj (closql--oref-default obj 'closql-primary-key))
|
||
|
|
(cadr columns))))))
|
||
|
|
([tables (alist-get :closql-tables props)]
|
||
|
|
(pcase-let ((`(,slot-table ,data-table) tables))
|
||
|
|
(aset obj c
|
||
|
|
(mapcar
|
||
|
|
#'cdr
|
||
|
|
(emacsql
|
||
|
|
db [:select $i1 :from $i2
|
||
|
|
:join $i3 :on (= $i4 $i5)
|
||
|
|
:where (= $i6 $s7)
|
||
|
|
:order-by [(asc id)]]
|
||
|
|
(intern (format "%s:*" data-table))
|
||
|
|
data-table slot-table
|
||
|
|
(intern (format "%s:id" slot-table))
|
||
|
|
(intern (format "%s:id" data-table))
|
||
|
|
(intern (format "%s:%s" slot-table
|
||
|
|
(closql--oref-default obj 'closql-table)))
|
||
|
|
(closql--oref obj (closql--oref-default obj 'closql-primary-key))
|
||
|
|
(closql--oref obj 'id))))))
|
||
|
|
((slot-unbound obj (eieio--object-class obj) slot 'oref)))))
|
||
|
|
|
||
|
|
;;;; Oset
|
||
|
|
|
||
|
|
(define-advice eieio-oset (:around (fn obj slot value) closql-object)
|
||
|
|
"If OBJ is a `closql-object', delegate to `closql-oset'."
|
||
|
|
(if (closql--closql-object-p obj)
|
||
|
|
(closql-oset obj slot value)
|
||
|
|
(funcall fn obj slot value)))
|
||
|
|
|
||
|
|
(defun closql--oset (obj slot value)
|
||
|
|
(aset obj (eieio--slot-name-index (eieio--object-class obj) slot) value))
|
||
|
|
|
||
|
|
(defun closql-oset (obj slot value)
|
||
|
|
(cl-check-type slot symbol)
|
||
|
|
(let ((class (eieio--object-class obj)))
|
||
|
|
(cond-let
|
||
|
|
([c (eieio--slot-name-index class slot)]
|
||
|
|
(eieio--validate-slot-value class c value slot)
|
||
|
|
(when (and (not (eq slot 'closql-database))
|
||
|
|
(closql--oref obj 'closql-database))
|
||
|
|
(closql-dset obj slot value))
|
||
|
|
(aset obj c value))
|
||
|
|
([c (eieio--class-slot-name-index class slot)]
|
||
|
|
(eieio--validate-class-slot-value class c value slot)
|
||
|
|
(aset (eieio--class-class-allocation-values class) c value))
|
||
|
|
((slot-missing obj slot 'oset value)))))
|
||
|
|
|
||
|
|
(cl-defgeneric closql-dset (obj slot value &optional drop-unknown)
|
||
|
|
(let* ((db (closql--oref obj 'closql-database))
|
||
|
|
(key (oref-default obj closql-primary-key))
|
||
|
|
(id (closql--oref obj key))
|
||
|
|
(props (closql--slot-properties obj slot)))
|
||
|
|
(cond-let
|
||
|
|
((alist-get :closql-class props)
|
||
|
|
(error "Not implemented for closql-class slots: oset"))
|
||
|
|
[[tables (alist-get :closql-tables props)]]
|
||
|
|
([table (or (alist-get :closql-table props)
|
||
|
|
(car tables))]
|
||
|
|
(closql-with-transaction db
|
||
|
|
(let ((columns (closql--table-columns db table)))
|
||
|
|
;; Caller might have modified value in place.
|
||
|
|
(closql--oset obj slot eieio--unbound)
|
||
|
|
(let ((list1 (closql-oref obj slot))
|
||
|
|
(list2 value)
|
||
|
|
elt1 elt2)
|
||
|
|
(cond (tables
|
||
|
|
(setq list1 (mapcar (##list (car %)) list1))
|
||
|
|
(setq list2 (mapcar (if (atom (car list2))
|
||
|
|
#'list
|
||
|
|
(##list (car %)))
|
||
|
|
list2)))
|
||
|
|
((length= columns 2)
|
||
|
|
(setq list1 (mapcar #'list list1))
|
||
|
|
(setq list2 (mapcar #'list list2))))
|
||
|
|
;; `list2' may not be sorted at all and `list1' has to
|
||
|
|
;; be sorted because Elisp and SQLite sort differently.
|
||
|
|
(setq list1 (compat-call sort list1 :lessp #'string< :key #'car))
|
||
|
|
(setq list2 (compat-call sort list2 :lessp #'string< :key #'car))
|
||
|
|
(while (progn (setq elt1 (car list1))
|
||
|
|
(setq elt2 (car list2))
|
||
|
|
(or elt1 elt2))
|
||
|
|
(let ((key1 (car elt1))
|
||
|
|
(key2 (car elt2)))
|
||
|
|
(cond
|
||
|
|
((and elt1 (or (not elt2) (string< key1 key2)))
|
||
|
|
(apply #'emacsql db
|
||
|
|
`[:delete-from $i1
|
||
|
|
:where ,(closql--where-equal (cons id elt1) 1)]
|
||
|
|
table
|
||
|
|
(cl-mapcan #'list columns (cons id elt1)))
|
||
|
|
(pop list1))
|
||
|
|
((string= key1 key2)
|
||
|
|
(unless (equal elt1 elt2)
|
||
|
|
(cl-mapc
|
||
|
|
(lambda (col val1 val2)
|
||
|
|
(unless (equal val1 val2)
|
||
|
|
(emacsql db [:update $i1 :set (= $i2 $s3)
|
||
|
|
:where (and (= $i4 $s5) (= $i6 $s7))]
|
||
|
|
table col val2
|
||
|
|
(car columns) id
|
||
|
|
(cadr columns) key2)))
|
||
|
|
(cddr columns)
|
||
|
|
(cdr elt1)
|
||
|
|
(cdr elt2)))
|
||
|
|
(pop list1)
|
||
|
|
(pop list2))
|
||
|
|
(drop-unknown
|
||
|
|
(ignore-errors
|
||
|
|
(emacsql db [:insert-into $i1 :values $v2]
|
||
|
|
table (vconcat (cons id elt2))))
|
||
|
|
(pop list2))
|
||
|
|
(t
|
||
|
|
(emacsql db [:insert-into $i1 :values $v2]
|
||
|
|
table (vconcat (cons id elt2)))
|
||
|
|
(pop list2)))))))))
|
||
|
|
((emacsql db [:update $i1 :set (= $i2 $s3) :where (= $i4 $s5)]
|
||
|
|
(oref-default obj closql-table)
|
||
|
|
slot
|
||
|
|
(if (eq value eieio--unbound) 'eieio-unbound value)
|
||
|
|
key id)))))
|
||
|
|
|
||
|
|
;;;; Slot Properties
|
||
|
|
|
||
|
|
(defun closql--slot-properties (object-or-class slot)
|
||
|
|
(and-let ((desc (cl-find slot
|
||
|
|
(closql--object-slots object-or-class)
|
||
|
|
:key #'cl--slot-descriptor-name)))
|
||
|
|
(cl--slot-descriptor-props desc)))
|
||
|
|
|
||
|
|
(defun closql--object-slots (object-or-class)
|
||
|
|
(eieio-class-slots
|
||
|
|
(cond
|
||
|
|
((eieio-object-p object-or-class) (eieio--object-class object-or-class))
|
||
|
|
((eieio--class-p object-or-class) object-or-class)
|
||
|
|
((find-class object-or-class 'error)))))
|
||
|
|
|
||
|
|
(defconst closql--slot-properties '(:closql-class :closql-table :closql-tables))
|
||
|
|
|
||
|
|
(define-advice eieio-defclass-internal
|
||
|
|
(:after (cname _superclasses slots _options) closql-object)
|
||
|
|
"Handle additional slot properties used by `closql-object' derived classes."
|
||
|
|
(when-let* ((class (cl--find-class cname))
|
||
|
|
(_(child-of-class-p class 'closql-object)))
|
||
|
|
(pcase-dolist (`(,name . ,slot) slots)
|
||
|
|
(let ((desc (cl-find name
|
||
|
|
(cl-coerce (eieio--class-slots class) 'list)
|
||
|
|
:key (lambda (elt) (aref elt 1)))))
|
||
|
|
(dolist (prop closql--slot-properties)
|
||
|
|
(when-let
|
||
|
|
((v (plist-get slot prop)))
|
||
|
|
(setf (alist-get prop (cl--slot-descriptor-props desc)) v)))))))
|
||
|
|
|
||
|
|
(define-advice eieio--slot-override
|
||
|
|
(:after (old new _skipnil) closql-object)
|
||
|
|
"Handle additional slot properties used by `closql-object' derived classes."
|
||
|
|
(dolist (prop closql--slot-properties)
|
||
|
|
(when-let
|
||
|
|
((v (alist-get prop (cl--slot-descriptor-props new))))
|
||
|
|
(setf (alist-get prop (cl--slot-descriptor-props old)) v))))
|
||
|
|
|
||
|
|
;;; Database
|
||
|
|
|
||
|
|
(defclass closql-database (eieio-singleton)
|
||
|
|
((name :initform nil :allocation :class)
|
||
|
|
(object-class :initform nil :allocation :class)
|
||
|
|
(file :initform nil :allocation :class)
|
||
|
|
(schemata :initform nil :allocation :class)
|
||
|
|
(version :initform nil :allocation :class)
|
||
|
|
(disabled :initform nil :allocation :class)
|
||
|
|
(connection :initform nil :initarg :connection))
|
||
|
|
:abstract t)
|
||
|
|
|
||
|
|
(cl-defmethod closql-db ((class (subclass closql-database))
|
||
|
|
&optional livep connection-class)
|
||
|
|
(cond-let*
|
||
|
|
([db (oref-default class singleton)]
|
||
|
|
[conn (and (not (eq db eieio--unbound))
|
||
|
|
(oref db connection))]
|
||
|
|
[_(emacsql-live-p conn)]
|
||
|
|
db)
|
||
|
|
((not livep)
|
||
|
|
(let* ((file (closql--db-prepare-storage class))
|
||
|
|
(connection-class (or connection-class
|
||
|
|
(emacsql-sqlite-default-connection)))
|
||
|
|
(conn (make-instance connection-class :file file))
|
||
|
|
(db (make-instance class))) ; ignores slot arguments
|
||
|
|
(oset db connection conn)
|
||
|
|
(emacsql conn [:pragma (= foreign-keys on)])
|
||
|
|
(cond-let
|
||
|
|
((not (emacsql-sqlite-list-tables db))
|
||
|
|
(closql--db-create-schema db))
|
||
|
|
[[code-version (oref-default db version)]
|
||
|
|
[data-version (closql--db-get-version db)]]
|
||
|
|
((< code-version data-version)
|
||
|
|
(message "Please update %s package (database schema version %s < %s)"
|
||
|
|
(oref-default db name) code-version data-version)
|
||
|
|
(oset-default class disabled t)
|
||
|
|
(emacsql-close db)
|
||
|
|
(setq db nil))
|
||
|
|
((closql--db-update-schema db)))
|
||
|
|
db))))
|
||
|
|
|
||
|
|
(cl-defmethod closql--db-prepare-storage ((class (subclass closql-database)))
|
||
|
|
(when-let ((file (oref-default class file)))
|
||
|
|
(when (symbolp file)
|
||
|
|
(setq file (symbol-value file)))
|
||
|
|
(make-directory (file-name-directory file) t)
|
||
|
|
file))
|
||
|
|
|
||
|
|
(cl-defmethod closql--db-create-schema ((db closql-database))
|
||
|
|
(closql-with-transaction db
|
||
|
|
(pcase-dolist (`(,table . ,schema)
|
||
|
|
(symbol-value (oref-default db schemata)))
|
||
|
|
(emacsql db [:create-table $i1 $S2] table schema))
|
||
|
|
(closql--db-set-version db (oref-default db version))))
|
||
|
|
|
||
|
|
(cl-defmethod closql--db-update-schema ((db closql-database))
|
||
|
|
(let ((code-version (oref-default db version))
|
||
|
|
(data-version (closql--db-get-version db)))
|
||
|
|
(when (< data-version code-version)
|
||
|
|
(oset-default db disabled t)
|
||
|
|
(emacsql-close db)
|
||
|
|
(error "Please update %s database (schema version %s < %s)"
|
||
|
|
(oref-default db name) data-version code-version))))
|
||
|
|
|
||
|
|
(cl-defmethod emacsql-live-p ((db closql-database))
|
||
|
|
(and-let ((conn (oref db connection)))
|
||
|
|
(emacsql-live-p conn)))
|
||
|
|
|
||
|
|
(cl-defmethod emacsql-enable-debugging ((db closql-database))
|
||
|
|
(emacsql-enable-debugging (oref db connection)))
|
||
|
|
|
||
|
|
(cl-defmethod emacsql-close ((db closql-database))
|
||
|
|
(emacsql-close (oref db connection))
|
||
|
|
(oset db connection nil))
|
||
|
|
|
||
|
|
(cl-defmethod emacsql ((db closql-database) sql &rest args)
|
||
|
|
(mapcar #'closql--extern-unbound
|
||
|
|
(apply #'emacsql (oref db connection) sql
|
||
|
|
(mapcar (lambda (arg)
|
||
|
|
(if (stringp arg)
|
||
|
|
(let ((copy (copy-sequence arg)))
|
||
|
|
(set-text-properties 0 (length copy) nil copy)
|
||
|
|
copy)
|
||
|
|
arg))
|
||
|
|
args))))
|
||
|
|
|
||
|
|
(cl-defmethod closql-insert ((db closql-database) obj &optional replace)
|
||
|
|
(closql--oset obj 'closql-database db)
|
||
|
|
(let (alist)
|
||
|
|
(dolist (slot (eieio-class-slots (eieio--object-class obj)))
|
||
|
|
(setq slot (cl--slot-descriptor-name slot))
|
||
|
|
(when (alist-get :closql-table (closql--slot-properties obj slot))
|
||
|
|
(push (cons slot (closql-oref obj slot)) alist)
|
||
|
|
(closql--oset obj slot eieio--unbound)))
|
||
|
|
(closql-with-transaction db
|
||
|
|
(emacsql db
|
||
|
|
(if replace
|
||
|
|
[:insert-or-replace-into $i1 :values $v2]
|
||
|
|
[:insert-into $i1 :values $v2])
|
||
|
|
(oref-default obj closql-table)
|
||
|
|
(pcase-let ((`(,class ,_db . ,values)
|
||
|
|
(closql--intern-unbound
|
||
|
|
(closql--coerce obj 'list))))
|
||
|
|
(vconcat (cons (closql--abbrev-class class) values))))
|
||
|
|
(pcase-dolist (`(,slot . ,value) alist)
|
||
|
|
(closql-dset obj slot value))))
|
||
|
|
obj)
|
||
|
|
|
||
|
|
(cl-defmethod closql-delete ((obj closql-object))
|
||
|
|
(let ((key (oref-default obj closql-primary-key)))
|
||
|
|
(emacsql (closql--oref obj 'closql-database)
|
||
|
|
[:delete-from $i1 :where (= $i2 $s3)]
|
||
|
|
(oref-default obj closql-table)
|
||
|
|
key
|
||
|
|
(closql--oref obj key))))
|
||
|
|
|
||
|
|
(cl-defmethod closql-reload ((obj closql-object))
|
||
|
|
(or (closql-get (closql--oref obj 'closql-database)
|
||
|
|
(closql--oref obj (oref-default obj closql-primary-key))
|
||
|
|
(eieio-object-class obj))
|
||
|
|
(error "Cannot reload object")))
|
||
|
|
|
||
|
|
(cl-defmethod closql-get ((db closql-database) ident &optional class resolve)
|
||
|
|
(unless class
|
||
|
|
(setq class (oref-default db object-class)))
|
||
|
|
(and-let ((row (car (emacsql db [:select * :from $i1
|
||
|
|
:where (= $i2 $s3)]
|
||
|
|
(oref-default class closql-table)
|
||
|
|
(oref-default class closql-primary-key)
|
||
|
|
ident))))
|
||
|
|
(closql--remake-instance class db row resolve)))
|
||
|
|
|
||
|
|
(cl-defmethod closql-query ((db closql-database) &optional select pred class)
|
||
|
|
(if select
|
||
|
|
(let ((value (closql-select db select pred class)))
|
||
|
|
(if (and select (symbolp select))
|
||
|
|
(mapcar #'car value)
|
||
|
|
value))
|
||
|
|
(closql-entries db pred class)))
|
||
|
|
|
||
|
|
(cl-defmethod closql-entries ((db closql-database) &optional pred class)
|
||
|
|
(unless class
|
||
|
|
(setq class (oref-default db object-class)))
|
||
|
|
(mapcar (lambda (row)
|
||
|
|
(closql--remake-instance class db row))
|
||
|
|
(closql-select db '* pred class)))
|
||
|
|
|
||
|
|
(cl-defmethod closql-select ((db closql-database) select &optional pred class)
|
||
|
|
(unless class
|
||
|
|
(setq class (oref-default db object-class)))
|
||
|
|
(emacsql db
|
||
|
|
`[:select $i1 :from $i2
|
||
|
|
,@(and pred [:where class :in $v3])
|
||
|
|
,@(if-let ((order (oref-default class closql-order-by)))
|
||
|
|
(list :order-by order)
|
||
|
|
'(:order-by [(asc $i4)]))]
|
||
|
|
select
|
||
|
|
(oref-default class closql-table)
|
||
|
|
(and pred (closql-where-class-in pred db))
|
||
|
|
(oref-default class closql-primary-key)))
|
||
|
|
|
||
|
|
(defun closql--table-columns (db table)
|
||
|
|
(mapcar #'cadr (emacsql db [:pragma (funcall table-info $i1)] table)))
|
||
|
|
|
||
|
|
(defun closql--db-get-version (db)
|
||
|
|
(caar (emacsql db [:pragma user-version])))
|
||
|
|
|
||
|
|
(defun closql--db-set-version (db version)
|
||
|
|
(cl-assert (integerp version))
|
||
|
|
(emacsql db [:pragma (= user-version $s1)] version))
|
||
|
|
|
||
|
|
;;; Object/Row Conversion
|
||
|
|
|
||
|
|
(cl-defmethod closql--remake-instance ((class (subclass closql-object))
|
||
|
|
db row &optional resolve)
|
||
|
|
(pcase-let*
|
||
|
|
((`(,abbrev . ,values) (closql--extern-unbound row))
|
||
|
|
(class-sym (closql--expand-abbrev class abbrev))
|
||
|
|
(class-obj (eieio--class-object class-sym))
|
||
|
|
(obj (copy-sequence (eieio--class-default-object-cache class-obj)))
|
||
|
|
(values (apply #'vector (cons db values))))
|
||
|
|
(dotimes (i (length (eieio--class-slots class-obj)))
|
||
|
|
(aset obj (1+ i) (aref values i)))
|
||
|
|
(when resolve
|
||
|
|
(closql--resolve-slots obj))
|
||
|
|
(when eieio-backward-compatibility
|
||
|
|
(aset obj 0 class-sym))
|
||
|
|
obj))
|
||
|
|
|
||
|
|
(defun closql--remake-instances (class db rows)
|
||
|
|
(declare (indent defun))
|
||
|
|
(mapcar (lambda (row)
|
||
|
|
(closql--remake-instance class db row))
|
||
|
|
rows))
|
||
|
|
|
||
|
|
(cl-defmethod closql--resolve-slots ((obj closql-object))
|
||
|
|
(dolist (slot (eieio-class-slots (eieio--object-class obj)))
|
||
|
|
(setq slot (cl--slot-descriptor-name slot))
|
||
|
|
(when (and (not (slot-boundp obj slot))
|
||
|
|
(let ((props (closql--slot-properties obj slot)))
|
||
|
|
(or (alist-get :closql-class props)
|
||
|
|
(alist-get :closql-table props))))
|
||
|
|
(closql--oset obj slot (closql-oref obj slot)))))
|
||
|
|
|
||
|
|
(defun closql--intern-unbound (row)
|
||
|
|
(mapcar (lambda (elt)
|
||
|
|
(if (eq elt eieio--unbound) 'eieio-unbound elt))
|
||
|
|
row))
|
||
|
|
|
||
|
|
(defun closql--extern-unbound (row)
|
||
|
|
(mapcar (lambda (elt)
|
||
|
|
(if (eq elt 'eieio-unbound) eieio--unbound elt))
|
||
|
|
row))
|
||
|
|
|
||
|
|
(defun closql--coerce (object type)
|
||
|
|
(cl-coerce (let* ((length (length object))
|
||
|
|
(vector (make-vector length -1)))
|
||
|
|
(dotimes (i length)
|
||
|
|
(aset vector i (aref object i)))
|
||
|
|
;; Do not assume eieio-backward-compatibility is enabled.
|
||
|
|
(when (eieio--class-p (aref vector 0))
|
||
|
|
(aset vector 0 (eieio--class-name (aref vector 0))))
|
||
|
|
vector)
|
||
|
|
type))
|
||
|
|
|
||
|
|
(cl-defmethod closql--abbrev-class ((class (subclass closql-object)))
|
||
|
|
(let ((name (symbol-name class))
|
||
|
|
(prefix (oref-default class closql-class-prefix))
|
||
|
|
(suffix (oref-default class closql-class-suffix)))
|
||
|
|
(intern (substring name
|
||
|
|
(if prefix (length prefix) 0)
|
||
|
|
(if suffix (- (length suffix)) nil)))))
|
||
|
|
|
||
|
|
(cl-defmethod closql--expand-abbrev ((class (subclass closql-object)) abbrev)
|
||
|
|
(intern (concat (oref-default class closql-class-prefix)
|
||
|
|
(symbol-name abbrev)
|
||
|
|
(oref-default class closql-class-suffix))))
|
||
|
|
|
||
|
|
(defun closql--where-equal (value offset)
|
||
|
|
(vector
|
||
|
|
(cons 'and
|
||
|
|
(mapcar (lambda (v)
|
||
|
|
(if v
|
||
|
|
(list '=
|
||
|
|
(intern (format "$i%i" (incf offset)))
|
||
|
|
(intern (format "$s%i" (incf offset))))
|
||
|
|
(list 'isnull
|
||
|
|
(intern (format "$i%i" (1- (incf offset 2)))))))
|
||
|
|
value))))
|
||
|
|
|
||
|
|
(defun closql-where-class-in (args &optional db)
|
||
|
|
(when (symbolp args)
|
||
|
|
(setq args (list args)))
|
||
|
|
(cond
|
||
|
|
((vectorp args)
|
||
|
|
(unless db
|
||
|
|
(error "closql-where-class-in: DB cannot be nil if ARGS is a vector"))
|
||
|
|
(let ((class (oref-default db object-class))
|
||
|
|
(abbrevs nil))
|
||
|
|
(mapc (lambda (arg)
|
||
|
|
(let ((str (symbol-name arg)))
|
||
|
|
(unless (string-match "\\`\\(!\\)?\\([^*]+\\)\\(\\*\\)?\\'" str)
|
||
|
|
(error "`closql-where-class-in': invalid type: %s" arg))
|
||
|
|
(let* ((exclude (match-beginning 1))
|
||
|
|
(a (intern (match-string 2 str)))
|
||
|
|
(a (cond ((match-beginning 3)
|
||
|
|
(closql--list-subabbrevs
|
||
|
|
(closql--expand-abbrev class a)))
|
||
|
|
((not (class-abstract-p
|
||
|
|
(closql--expand-abbrev class a)))
|
||
|
|
(list a)))))
|
||
|
|
(setq abbrevs
|
||
|
|
(if exclude
|
||
|
|
(cl-set-difference abbrevs a)
|
||
|
|
(nconc abbrevs a))))))
|
||
|
|
args)
|
||
|
|
(vconcat abbrevs)))
|
||
|
|
((vconcat
|
||
|
|
(mapcar #'closql--abbrev-class
|
||
|
|
(mapcan (lambda (sym)
|
||
|
|
(let ((str (symbol-name sym)))
|
||
|
|
(cond ((string-suffix-p "--eieio-childp" str)
|
||
|
|
(closql--list-subclasses
|
||
|
|
(intern (substring str 0 -14)) nil))
|
||
|
|
((string-suffix-p "-p" str)
|
||
|
|
(list (intern (substring str 0 -2))))
|
||
|
|
((list sym)))))
|
||
|
|
args))))))
|
||
|
|
|
||
|
|
(defun closql--list-subclasses (class &optional result)
|
||
|
|
(unless (class-abstract-p class)
|
||
|
|
(cl-pushnew class result))
|
||
|
|
(dolist (child (eieio--class-children (cl--find-class class)))
|
||
|
|
(setq result (closql--list-subclasses child result)))
|
||
|
|
result)
|
||
|
|
|
||
|
|
(cl-defmethod closql--list-subabbrevs ((class (subclass closql-object))
|
||
|
|
&optional wildcards)
|
||
|
|
(sort (named-let types ((class class))
|
||
|
|
(let ((children (eieio--class-children (cl--find-class class)))
|
||
|
|
;; An abstract base-class may violate its own naming rules.
|
||
|
|
(abbrev (ignore-errors (closql--abbrev-class class))))
|
||
|
|
(nconc (and (not (class-abstract-p class)) (list abbrev))
|
||
|
|
(and wildcards children
|
||
|
|
(list (if abbrev (intern (format "%s*" abbrev)) '*)))
|
||
|
|
(mapcan #'types children))))
|
||
|
|
#'string<))
|
||
|
|
|
||
|
|
(cl-defmethod closql--set-object-class ((db closql-database) obj class)
|
||
|
|
(let* ((table (oref-default obj closql-table))
|
||
|
|
(key (oref-default obj closql-primary-key))
|
||
|
|
(id (closql--oref obj key)))
|
||
|
|
(aset obj 0
|
||
|
|
(aref (copy-sequence
|
||
|
|
(eieio--class-default-object-cache
|
||
|
|
(eieio--class-object class)))
|
||
|
|
0))
|
||
|
|
(emacsql db [:update $i1 :set (= class $s2) :where (= $i3 $s4)]
|
||
|
|
table
|
||
|
|
(closql--abbrev-class class)
|
||
|
|
key id)))
|
||
|
|
|
||
|
|
;;; Utilities
|
||
|
|
|
||
|
|
(defun closql-format (object string &rest slots)
|
||
|
|
"Format a string out of a format STRING and an OBJECT's SLOTS.
|
||
|
|
|
||
|
|
STRING is a format-string like for `format'. OBJECT is an Eieio
|
||
|
|
object and SLOTS are slots of that object, their values are used
|
||
|
|
like `format' uses its OBJECTS arguments (which are unrelated to
|
||
|
|
this function's OBJECT argument, they just have similar names).
|
||
|
|
|
||
|
|
While this function does not have much to do with the purpose of
|
||
|
|
`closql', it is being defined here anyway because Eieio does not
|
||
|
|
define a similar function under a more appropriate name such as
|
||
|
|
`eieio-format'."
|
||
|
|
(apply #'format string
|
||
|
|
(mapcar (lambda (slot) (eieio-oref object slot)) slots)))
|
||
|
|
|
||
|
|
;;; _
|
||
|
|
(provide 'closql)
|
||
|
|
;; Local Variables:
|
||
|
|
;; indent-tabs-mode: nil
|
||
|
|
;; lisp-indent-local-overrides: ((cond . 0) (interactive . 0))
|
||
|
|
;; read-symbol-shorthands: (
|
||
|
|
;; ("and$" . "cond-let--and$")
|
||
|
|
;; ("thread$" . "cond-let--thread$")
|
||
|
|
;; ("when$" . "cond-let--when$")
|
||
|
|
;; ("and-let*" . "cond-let--and-let*")
|
||
|
|
;; ("and-let" . "cond-let--and-let")
|
||
|
|
;; ("if-let*" . "cond-let--if-let*")
|
||
|
|
;; ("if-let" . "cond-let--if-let")
|
||
|
|
;; ("when-let*" . "cond-let--when-let*")
|
||
|
|
;; ("when-let" . "cond-let--when-let")
|
||
|
|
;; ("while-let*" . "cond-let--while-let*")
|
||
|
|
;; ("while-let" . "cond-let--while-let"))
|
||
|
|
;; End:
|
||
|
|
;;; closql.el ends here
|