1.1--- a/.dir-locals.el Fri May 31 18:18:12 2024 -0400
1.2+++ b/.dir-locals.el Fri May 31 23:28:35 2024 -0400
1.3@@ -3,5 +3,6 @@
1.4 . (:rust-analyzer (:cargo (:buildScripts (:enable t) (:features "all")))))))
1.5 (nushell-mode . ((nushell-indent-offset . 2)))
1.6 (nushell-ts-mode . ((nushell-indent-offset . 2)))
1.7+ (sh-mode . (sh-indentation . 2))
1.8 (makefile-mode . ((indent-tabs-mode . t)))
1.9 (slint-mode . ((slint-indent-level . 2))))
2.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
2.2+++ b/lisp/lib/box/archiso.lisp Fri May 31 23:28:35 2024 -0400
2.3@@ -0,0 +1,194 @@
2.4+;;; box/archiso.lisp --- archiso installation interface
2.5+
2.6+;;
2.7+
2.8+;;; Code:
2.9+(in-package :box/archiso)
2.10+
2.11+#| default config
2.12+{
2.13+ "__separator__": null,
2.14+ "additional-repositories": [],
2.15+ "archinstall-language": "English",
2.16+ "audio_config": null,
2.17+ "bootloader": "Systemd-boot",
2.18+ "config_version": "2.6.0",
2.19+ "debug": false,
2.20+ "disk_config": {
2.21+ "config_type": "manual_partitioning",
2.22+ "device_modifications": [
2.23+ {
2.24+ "device": "/dev/sda",
2.25+ "partitions": [
2.26+ {
2.27+ "btrfs": [],
2.28+ "flags": [
2.29+ "Boot"
2.30+ ],
2.31+ "fs_type": "fat32",
2.32+ "length": {
2.33+ "sector_size": null,
2.34+ "total_size": null,
2.35+ "unit": "B",
2.36+ "value": 99982592
2.37+ },
2.38+ "mount_options": [],
2.39+ "mountpoint": "/boot",
2.40+ "obj_id": "369f31a8-2781-4d6b-96e7-75680552b7c9",
2.41+ "start": {
2.42+ "sector_size": {
2.43+ "sector_size": null,
2.44+ "total_size": null,
2.45+ "unit": "B",
2.46+ "value": 512
2.47+ },
2.48+ "total_size": null,
2.49+ "unit": "sectors",
2.50+ "value": 34
2.51+ },
2.52+ "status": "create",
2.53+ "type": "primary"
2.54+ },
2.55+ {
2.56+ "btrfs": [],
2.57+ "flags": [],
2.58+ "fs_type": "fat32",
2.59+ "length": {
2.60+ "sector_size": null,
2.61+ "total_size": null,
2.62+ "unit": "B",
2.63+ "value": 100000000
2.64+ },
2.65+ "mount_options": [],
2.66+ "mountpoint": "/efi",
2.67+ "obj_id": "13cf2c96-8b0f-4ade-abaa-c530be589aad",
2.68+ "start": {
2.69+ "sector_size": {
2.70+ "sector_size": null,
2.71+ "total_size": null,
2.72+ "unit": "B",
2.73+ "value": 512
2.74+ },
2.75+ "total_size": {
2.76+ "sector_size": null,
2.77+ "total_size": null,
2.78+ "unit": "B",
2.79+ "value": 16106127360
2.80+ },
2.81+ "unit": "MB",
2.82+ "value": 100
2.83+ },
2.84+ "status": "create",
2.85+ "type": "primary"
2.86+ },
2.87+ {
2.88+ "btrfs": [],
2.89+ "flags": [],
2.90+ "fs_type": "ext4",
2.91+ "length": {
2.92+ "sector_size": null,
2.93+ "total_size": null,
2.94+ "unit": "B",
2.95+ "value": 15805127360
2.96+ },
2.97+ "mount_options": [],
2.98+ "mountpoint": "/",
2.99+ "obj_id": "3e75d045-21a4-429d-897e-8ec19a006e8b",
2.100+ "start": {
2.101+ "sector_size": {
2.102+ "sector_size": null,
2.103+ "total_size": null,
2.104+ "unit": "B",
2.105+ "value": 512
2.106+ },
2.107+ "total_size": {
2.108+ "sector_size": null,
2.109+ "total_size": null,
2.110+ "unit": "B",
2.111+ "value": 16106127360
2.112+ },
2.113+ "unit": "MB",
2.114+ "value": 301
2.115+ },
2.116+ "status": "create",
2.117+ "type": "primary"
2.118+ }
2.119+ ],
2.120+ "wipe": false
2.121+ }
2.122+ ]
2.123+ },
2.124+ "disk_encryption": {
2.125+ "encryption_type": "luks",
2.126+ "partitions": [
2.127+ "3e75d045-21a4-429d-897e-8ec19a006e8b"
2.128+ ]
2.129+ },
2.130+ "hostname": "archlinux",
2.131+ "kernels": [
2.132+ "linux"
2.133+ ],
2.134+ "locale_config": {
2.135+ "kb_layout": "us",
2.136+ "sys_enc": "UTF-8",
2.137+ "sys_lang": "en_US"
2.138+ },
2.139+ "mirror_config": {
2.140+ "custom_mirrors": [],
2.141+ "mirror_regions": {
2.142+ "Sweden": [
2.143+ "https://mirror.osbeck.com/archlinux/$repo/os/$arch",
2.144+ "https://mirror.bahnhof.net/pub/archlinux/$repo/os/$arch",
2.145+ "https://ftp.myrveln.se/pub/linux/archlinux/$repo/os/$arch",
2.146+ "https://ftp.lysator.liu.se/pub/archlinux/$repo/os/$arch",
2.147+ "https://ftp.ludd.ltu.se/mirrors/archlinux/$repo/os/$arch",
2.148+ "https://ftp.acc.umu.se/mirror/archlinux/$repo/os/$arch",
2.149+ "http://mirror.bahnhof.net/pub/archlinux/$repo/os/$arch",
2.150+ "http://ftpmirror.infania.net/mirror/archlinux/$repo/os/$arch",
2.151+ "http://ftp.myrveln.se/pub/linux/archlinux/$repo/os/$arch",
2.152+ "http://ftp.lysator.liu.se/pub/archlinux/$repo/os/$arch",
2.153+ "http://ftp.acc.umu.se/mirror/archlinux/$repo/os/$arch"
2.154+ ]
2.155+ }
2.156+ },
2.157+ "network_config": {},
2.158+ "no_pkg_lookups": false,
2.159+ "ntp": true,
2.160+ "offline": false,
2.161+ "packages": [],
2.162+ "parallel downloads": 0,
2.163+ "profile_config": null,
2.164+ "save_config": null,
2.165+ "script": "guided",
2.166+ "silent": false,
2.167+ "swap": true,
2.168+ "timezone": "UTC",
2.169+ "version": "2.6.0"
2.170+}
2.171+|#
2.172+
2.173+#|
2.174+(dat/proto:serialize
2.175+'(("__separator__" NIL) ("additional-repositories" NIL)
2.176+ ("archinstall-language" "English") ("audio_config" NIL)
2.177+ ("bootloader" "Systemd-boot") ("config_version" "2.6.0")
2.178+ ("debug" NIL) ("disk_config" nil)
2.179+ ("disk_encryption" nil)
2.180+ ("hostname" "archlinux") ("kernels" ("linux"))
2.181+ ("locale_config" nil)
2.182+ ("mirror_config" nil)
2.183+ ("network_config" nil)
2.184+ ("no_pkg_lookups" NIL) ("ntp" T) ("offline" NIL) ("packages" NIL)
2.185+ ("parallel downloads" 0) ("profile_config" NIL)
2.186+ ("save_config" NIL) ("script" "guided") ("silent" NIL) ("swap" T)
2.187+ ("timezone" "UTC") ("version" "2.6.0"))
2.188+:json)
2.189+|#
2.190+
2.191+(defvar *archiso-config*)
2.192+
2.193+(defvar *archiso-creds*)
2.194+
2.195+;; TODO 2024-05-31:
2.196+(defcfg archiso-cfg ()
2.197+ ())
3.1--- a/lisp/lib/box/box.asd Fri May 31 18:18:12 2024 -0400
3.2+++ b/lisp/lib/box/box.asd Fri May 31 23:28:35 2024 -0400
3.3@@ -1,10 +1,10 @@
3.4 (defsystem :box
3.5- :description "Kernel virtualization support for Lisp - wraps QEMU, LXC, KVM, Libvirt."
3.6- :depends-on (:std :cli :obj :dat :net)
3.7+ :description "Kernel virtualization support for Lisp - wraps QEMU,archiso,etc."
3.8+ :depends-on (:std :cli :obj :dat :net :log)
3.9 :components ((:file "pkg"))
3.10 :in-order-to ((test-op (test-op :box/tests))))
3.11
3.12 (defsystem :box/tests
3.13- :depends-on (:rt :box)
3.14+ :depends-on (:rt :box :log)
3.15 :components ((:file "tests"))
3.16 :perform (test-op (o c) (symbol-call :rt :do-tests :box)))
4.1--- a/lisp/lib/box/pkg.lisp Fri May 31 18:18:12 2024 -0400
4.2+++ b/lisp/lib/box/pkg.lisp Fri May 31 23:28:35 2024 -0400
4.3@@ -15,3 +15,8 @@
4.4 (:use :cl :std :cli :sb-bsd-sockets :net :dat/json)
4.5 (:export
4.6 :*lxc-version*))
4.7+
4.8+(defpackage :box/archiso
4.9+ (:nicknames :archiso)
4.10+ (:use :cl :std :cli/shell :dat/json :obj/cfg)
4.11+ (:export :*archiso-config* :*archiso-creds*))
5.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
5.2+++ b/lisp/lib/box/test.json Fri May 31 23:28:35 2024 -0400
5.3@@ -0,0 +1,159 @@
5.4+{
5.5+ "__separator__": null,
5.6+ "additional-repositories": [],
5.7+ "archinstall-language": "English",
5.8+ "audio_config": null,
5.9+ "bootloader": "Systemd-boot",
5.10+ "config_version": "2.6.0",
5.11+ "debug": false,
5.12+ "disk_config": {
5.13+ "config_type": "manual_partitioning",
5.14+ "device_modifications": [
5.15+ {
5.16+ "device": "/dev/sda",
5.17+ "partitions": [
5.18+ {
5.19+ "btrfs": [],
5.20+ "flags": [
5.21+ "Boot"
5.22+ ],
5.23+ "fs_type": "fat32",
5.24+ "length": {
5.25+ "sector_size": null,
5.26+ "total_size": null,
5.27+ "unit": "B",
5.28+ "value": 99982592
5.29+ },
5.30+ "mount_options": [],
5.31+ "mountpoint": "/boot",
5.32+ "obj_id": "369f31a8-2781-4d6b-96e7-75680552b7c9",
5.33+ "start": {
5.34+ "sector_size": {
5.35+ "sector_size": null,
5.36+ "total_size": null,
5.37+ "unit": "B",
5.38+ "value": 512
5.39+ },
5.40+ "total_size": null,
5.41+ "unit": "sectors",
5.42+ "value": 34
5.43+ },
5.44+ "status": "create",
5.45+ "type": "primary"
5.46+ },
5.47+ {
5.48+ "btrfs": [],
5.49+ "flags": [],
5.50+ "fs_type": "fat32",
5.51+ "length": {
5.52+ "sector_size": null,
5.53+ "total_size": null,
5.54+ "unit": "B",
5.55+ "value": 100000000
5.56+ },
5.57+ "mount_options": [],
5.58+ "mountpoint": "/efi",
5.59+ "obj_id": "13cf2c96-8b0f-4ade-abaa-c530be589aad",
5.60+ "start": {
5.61+ "sector_size": {
5.62+ "sector_size": null,
5.63+ "total_size": null,
5.64+ "unit": "B",
5.65+ "value": 512
5.66+ },
5.67+ "total_size": {
5.68+ "sector_size": null,
5.69+ "total_size": null,
5.70+ "unit": "B",
5.71+ "value": 16106127360
5.72+ },
5.73+ "unit": "MB",
5.74+ "value": 100
5.75+ },
5.76+ "status": "create",
5.77+ "type": "primary"
5.78+ },
5.79+ {
5.80+ "btrfs": [],
5.81+ "flags": [],
5.82+ "fs_type": "ext4",
5.83+ "length": {
5.84+ "sector_size": null,
5.85+ "total_size": null,
5.86+ "unit": "B",
5.87+ "value": 15805127360
5.88+ },
5.89+ "mount_options": [],
5.90+ "mountpoint": "/",
5.91+ "obj_id": "3e75d045-21a4-429d-897e-8ec19a006e8b",
5.92+ "start": {
5.93+ "sector_size": {
5.94+ "sector_size": null,
5.95+ "total_size": null,
5.96+ "unit": "B",
5.97+ "value": 512
5.98+ },
5.99+ "total_size": {
5.100+ "sector_size": null,
5.101+ "total_size": null,
5.102+ "unit": "B",
5.103+ "value": 16106127360
5.104+ },
5.105+ "unit": "MB",
5.106+ "value": 301
5.107+ },
5.108+ "status": "create",
5.109+ "type": "primary"
5.110+ }
5.111+ ],
5.112+ "wipe": false
5.113+ }
5.114+ ]
5.115+ },
5.116+ "disk_encryption": {
5.117+ "encryption_type": "luks",
5.118+ "partitions": [
5.119+ "3e75d045-21a4-429d-897e-8ec19a006e8b"
5.120+ ]
5.121+ },
5.122+ "hostname": "archlinux",
5.123+ "kernels": [
5.124+ "linux"
5.125+ ],
5.126+ "locale_config": {
5.127+ "kb_layout": "us",
5.128+ "sys_enc": "UTF-8",
5.129+ "sys_lang": "en_US"
5.130+ },
5.131+ "mirror_config": {
5.132+ "custom_mirrors": [],
5.133+ "mirror_regions": {
5.134+ "Sweden": [
5.135+ "https://mirror.osbeck.com/archlinux/$repo/os/$arch",
5.136+ "https://mirror.bahnhof.net/pub/archlinux/$repo/os/$arch",
5.137+ "https://ftp.myrveln.se/pub/linux/archlinux/$repo/os/$arch",
5.138+ "https://ftp.lysator.liu.se/pub/archlinux/$repo/os/$arch",
5.139+ "https://ftp.ludd.ltu.se/mirrors/archlinux/$repo/os/$arch",
5.140+ "https://ftp.acc.umu.se/mirror/archlinux/$repo/os/$arch",
5.141+ "http://mirror.bahnhof.net/pub/archlinux/$repo/os/$arch",
5.142+ "http://ftpmirror.infania.net/mirror/archlinux/$repo/os/$arch",
5.143+ "http://ftp.myrveln.se/pub/linux/archlinux/$repo/os/$arch",
5.144+ "http://ftp.lysator.liu.se/pub/archlinux/$repo/os/$arch",
5.145+ "http://ftp.acc.umu.se/mirror/archlinux/$repo/os/$arch"
5.146+ ]
5.147+ }
5.148+ },
5.149+ "network_config": {},
5.150+ "no_pkg_lookups": false,
5.151+ "ntp": true,
5.152+ "offline": false,
5.153+ "packages": [],
5.154+ "parallel downloads": 0,
5.155+ "profile_config": null,
5.156+ "save_config": null,
5.157+ "script": "guided",
5.158+ "silent": false,
5.159+ "swap": true,
5.160+ "timezone": "UTC",
5.161+ "version": "2.6.0"
5.162+}
6.1--- a/lisp/lib/box/tests.lisp Fri May 31 18:18:12 2024 -0400
6.2+++ b/lisp/lib/box/tests.lisp Fri May 31 23:28:35 2024 -0400
6.3@@ -4,8 +4,12 @@
6.4
6.5 ;;; Code:
6.6 (defpackage :box/tests
6.7- (:use :cl :rt :box :sb-bsd-sockets))
6.8+ (:use :cl :rt :box :box/archiso :sb-bsd-sockets))
6.9
6.10 (in-package :box/tests)
6.11 (defsuite :box)
6.12 (in-suite :box)
6.13+
6.14+(deftest archiso ()
6.15+ (is (with-open-file (file #P"test.json")
6.16+ (inspect (dat/json:json-read file)))))
7.1--- a/lisp/lib/obj/build.lisp Fri May 31 18:18:12 2024 -0400
7.2+++ b/lisp/lib/obj/build.lisp Fri May 31 23:28:35 2024 -0400
7.3@@ -1,9 +1,17 @@
7.4 ;;; obj/build.lisp --- Builder API
7.5
7.6-;;
7.7+;; BUILDER class and methods.
7.8+
7.9+;;; Commentary:
7.10+
7.11+;; This package started during the implementation of FFI/URING when it became
7.12+;; clear that we needed a generic 'CONS-like' protocol and class for objects
7.13+;; capable of constructing complex structures.
7.14
7.15 ;;; Code:
7.16 (in-package :obj/build)
7.17
7.18+(defclass builder () ())
7.19+
7.20 (defgeneric build (self &key &allow-other-keys))
7.21 (defgeneric build-from (self from &key &allow-other-keys))
8.1--- a/lisp/lib/obj/cfg.lisp Fri May 31 18:18:12 2024 -0400
8.2+++ b/lisp/lib/obj/cfg.lisp Fri May 31 23:28:35 2024 -0400
8.3@@ -23,3 +23,8 @@
8.4 (defgeneric cfg-find (obj key &key &allow-other-keys))
8.5 (defgeneric cfg-get (obj key))
8.6 (defgeneric (setf cfg-get) (obj key val))
8.7+
8.8+(defmacro defcfg (name direct-superclasses direct-slots &rest options)
8.9+ `(defclass ,name ,(append direct-superclasses '(obj/cfg::cfg))
8.10+ ,direct-slots
8.11+ ,@options))
9.1--- a/lisp/lib/obj/pkg.lisp Fri May 31 18:18:12 2024 -0400
9.2+++ b/lisp/lib/obj/pkg.lisp Fri May 31 23:28:35 2024 -0400
9.3@@ -299,7 +299,8 @@
9.4 (defpackage :obj/cfg
9.5 (:nicknames :cfg)
9.6 (:use :cl :std)
9.7- (:export :cfg :make-cfg :find-cfg :cfg-find :cfg-get))
9.8+ (:export :cfg :make-cfg :find-cfg
9.9+ :cfg-find :cfg-get :defcfg))
9.10
9.11 (defpackage :obj/db
9.12 (:nicknames :db)
9.13@@ -327,4 +328,3 @@
9.14 (uiop:define-package :obj
9.15 (:use-reexport :list :hash :color
9.16 :seq :tree :graph :id :db :time :uri :url :cfg :music :temperature :direction :shape))
9.17-
10.1--- a/lisp/lib/obj/uri/intern.lisp Fri May 31 18:18:12 2024 -0400
10.2+++ b/lisp/lib/obj/uri/intern.lisp Fri May 31 23:28:35 2024 -0400
10.3@@ -1,10 +1,10 @@
10.4 ;;; obj/uri/intern.lisp --- Support for URI interning
10.5
10.6-;;
10.7+;; support for interning URIs
10.8
10.9 ;;; Code:
10.10 (in-package :obj/uri)
10.11-;; support for interning URIs
10.12+
10.13 (defmethod uri= ((uri1 uri) (uri2 uri))
10.14 (when (not (eq (uri-scheme uri1) (uri-scheme uri2)))
10.15 (return-from uri= nil))
11.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
11.2+++ b/lisp/lib/skel/comp/dir-locals.lisp Fri May 31 23:28:35 2024 -0400
11.3@@ -0,0 +1,8 @@
11.4+;;; skel/comp/dir-locals.lisp --- Support for Emacs dir-locals.el
11.5+
11.6+;; https://www.gnu.org/software/emacs/manual/html_node/elisp/Directory-Local-Variables.html
11.7+
11.8+;;; Code:
11.9+(in-package :skel/comp/dir-locals)
11.10+(defvar *dir-locals-file* ".dir-locals.el")
11.11+(deftype dir-local-var-designator () '(or symbol string))
12.1--- a/lisp/lib/skel/comp/pkg.lisp Fri May 31 18:18:12 2024 -0400
12.2+++ b/lisp/lib/skel/comp/pkg.lisp Fri May 31 23:28:35 2024 -0400
12.3@@ -17,3 +17,7 @@
12.4 (defpackage :skel/comp/asd
12.5 (:use :cl :std :skel/core/obj)
12.6 (:export :sk-asd))
12.7+
12.8+(defpackage :skel/comp/dir-locals
12.9+ (:use :cl :std :skel/core/obj :skel/core/proto)
12.10+ (:export :*dir-locals-file* :dir-local-var-designator))
13.1--- a/lisp/lib/vc/err.lisp Fri May 31 18:18:12 2024 -0400
13.2+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
13.3@@ -1,7 +0,0 @@
13.4-(in-package :vc)
13.5-
13.6-(define-condition vc-error (std-error) ())
13.7-
13.8-(deferror git-error (vc-error) () (:auto t))
13.9-
13.10-(deferror hg-error (vc-error) () (:auto t))
14.1--- a/lisp/lib/vc/git.lisp Fri May 31 18:18:12 2024 -0400
14.2+++ b/lisp/lib/vc/git.lisp Fri May 31 23:28:35 2024 -0400
14.3@@ -1,10 +1,12 @@
14.4-(in-package :vc)
14.5+(in-package :vc/git)
14.6+
14.7+(deferror git-error (vc-error) () (:auto t))
14.8
14.9 (defvar *git-program* (cli:find-exe "git"))
14.10
14.11 (defun run-git-command (cmd &optional args output (wait t))
14.12 (unless (listp args) (setf args (list args)))
14.13- (setf args (mapcar #'namestring-or args)) ;; TODO 2024-05-10: slow
14.14+ (setf args (mapcar #'vc/proto::namestring-or args)) ;; TODO 2024-05-10: slow
14.15 (sb-ext:run-program *git-program* (push cmd args) :output output :wait wait :input nil))
14.16
14.17 (defun git-url-p (url)
14.18@@ -12,7 +14,7 @@
14.19 (let ((url-str (if (typep url 'pathname)
14.20 (namestring url)
14.21 url)))
14.22- (scan '(:alternation
14.23+ (ppcre:scan '(:alternation
14.24 (:regex "\\.git$")
14.25 (:regex "^git://")
14.26 (:regex "^https://git\\.")
14.27@@ -20,7 +22,7 @@
14.28 url-str)))
14.29
14.30 (defun gitignore (&optional (path ".gitignore"))
14.31- (make-vc-ignore :path path :patterns (map-lines #'glob-path-match path)))
14.32+ (vc/proto::make-vc-ignore :path path :patterns (vc/proto::map-lines #'vc/proto::glob-path-match path)))
14.33
14.34 (defclass git-repo (vc-repo)
14.35 ((index))) ;; working-directory
14.36@@ -55,33 +57,33 @@
14.37
14.38 (defmethod vc-pull ((self git-repo) remote &key &allow-other-keys)
14.39 (with-slots (path) self
14.40- (with-current-directory (path)
14.41+ (uiop:with-current-directory (path)
14.42 (sb-ext:process-exit-code (run-git-command "pull" remote)))))
14.43
14.44 (defmethod vc-push ((self git-repo) remote &key &allow-other-keys)
14.45 (with-slots (path) self
14.46- (with-current-directory (path)
14.47+ (uiop:with-current-directory (path)
14.48 (sb-ext:process-exit-code (run-git-command "push" remote)))))
14.49
14.50 (defmethod vc-commit ((self git-repo) msg &key &allow-other-keys)
14.51 (with-slots (path) self
14.52- (with-current-directory (path)
14.53+ (uiop:with-current-directory (path)
14.54 (sb-ext:process-exit-code (run-git-command "commit" "-m" msg)))))
14.55
14.56 (defmethod vc-add ((self git-repo) &rest files)
14.57 (with-slots (path) self
14.58- (with-current-directory (path)
14.59+ (uiop:with-current-directory (path)
14.60 (sb-ext:process-exit-code (apply #'run-git-command "add" files)))))
14.61
14.62 (defmethod vc-remove ((self git-repo) &rest files)
14.63 (with-slots (path) self
14.64- (with-current-directory (path)
14.65+ (uiop:with-current-directory (path)
14.66 (sb-ext:process-exit-code (apply #'run-git-command "remove" files)))))
14.67
14.68 ;; TODO
14.69 (defmethod vc-addremove ((self git-repo) &rest files)
14.70 (with-slots (path) self
14.71- (with-current-directory (path)
14.72+ (uiop:with-current-directory (path)
14.73 (sb-ext:process-exit-code (apply #'run-git-command "addremove" files)))))
14.74
14.75 (defmethod vc-status ((self git-repo) &key &allow-other-keys) (vc-run self "status"))
14.76@@ -89,11 +91,11 @@
14.77 (defmethod vc-branch ((self git-repo)) (vc-run self "branch"))
14.78
14.79 (defmethod vc-diff ((a git-repo) (b git-repo) &key &allow-other-keys)
14.80- (vc-run a "diff" (vc-repo-head a) (vc-repo-head b)))
14.81+ (vc-run a "diff" (vc/proto::vc-repo-head a) (vc/proto::vc-repo-head b)))
14.82
14.83 (defmethod vc-id ((self git-repo))
14.84 (with-slots (path) self
14.85- (with-current-directory (path)
14.86+ (uiop:with-current-directory (path)
14.87 (with-open-stream (s (sb-ext:process-output (run-git-command "id")))
14.88 (with-output-to-string (str)
14.89 (loop for c = (read-char s nil nil)
15.1--- a/lisp/lib/vc/hg.lisp Fri May 31 18:18:12 2024 -0400
15.2+++ b/lisp/lib/vc/hg.lisp Fri May 31 23:28:35 2024 -0400
15.3@@ -32,7 +32,9 @@
15.4 ;; hg serve --no-profile --cmdserver chgunix --address @INITSOCKNAME --daemon-postexec chdir:/ @DIR
15.5
15.6 ;;; Code:
15.7-(in-package :vc)
15.8+(in-package :vc/hg)
15.9+
15.10+(deferror hg-error (vc-error) () (:auto t))
15.11
15.12 (defvar *default-hg-client-buffer-size* 4096)
15.13 (defvar *hg-program* (or (cli:find-exe "rhg") (cli:find-exe "hg")))
15.14@@ -40,7 +42,7 @@
15.15 (defun run-hg-command (cmd &optional args output (wait t))
15.16 "Run an hg command."
15.17 (unless (listp args) (setf args (list args)))
15.18- (setf args (mapcar #'namestring-or args)) ;; TODO 2024-05-10: slow
15.19+ (setf args (mapcar #'vc/proto::namestring-or args)) ;; TODO 2024-05-10: slow
15.20 (sb-ext:run-program *hg-program* (push cmd args) :output output :wait wait :input nil))
15.21
15.22 (defun hg-url-p (url)
15.23@@ -48,15 +50,15 @@
15.24 (let ((url-str (if (typep url 'pathname)
15.25 (namestring url)
15.26 url)))
15.27- (scan '(:alternation
15.28- (:regex "\\.hg$")
15.29- (:regex "^hg://")
15.30- (:regex "^https://hg\\.")
15.31- (:regex "^hg@"))
15.32- url-str)))
15.33+ (ppcre:scan '(:alternation
15.34+ (:regex "\\.hg$")
15.35+ (:regex "^hg://")
15.36+ (:regex "^https://hg\\.")
15.37+ (:regex "^hg@"))
15.38+ url-str)))
15.39
15.40 (defun hgignore (&optional (path ".hgignore"))
15.41- (make-vc-ignore :path path :patterns (map-lines #'ppcre:create-scanner path)))
15.42+ (vc/proto::make-vc-ignore :path path :patterns (vc/proto::map-lines #'ppcre:create-scanner path)))
15.43
15.44 ;; (describe (make-instance 'hg-repo))
15.45 ;; https://repo.mercurial-scm.org/hg/file/tip/mercurial/interfaces/repository.py
15.46@@ -67,7 +69,7 @@
15.47
15.48 (defmethod vc-run ((self hg-repo) (cmd string) &rest args)
15.49 (with-slots (path) self
15.50- (with-current-directory (path)
15.51+ (uiop:with-current-directory (path)
15.52 (let ((proc (apply #'run-hg-command cmd args)))
15.53 (let ((ok (eq 0 (sb-ext:process-exit-code proc)))
15.54 (res (make-array 0 :element-type 'character :fill-pointer 0 :adjustable t)))
15.55@@ -123,11 +125,11 @@
15.56 (defmethod vc-branch ((self hg-repo)) (vc-run self "branch"))
15.57
15.58 (defmethod vc-diff ((a hg-repo) (b hg-repo) &key &allow-other-keys)
15.59- (vc-run a "diff" (vc-repo-head a) (vc-repo-head b)))
15.60+ (vc-run a "diff" (vc/proto::vc-repo-head a) (vc/proto::vc-repo-head b)))
15.61
15.62 (defmethod vc-id ((self hg-repo))
15.63 (with-slots (path) self
15.64- (with-current-directory (path)
15.65+ (uiop:with-current-directory (path)
15.66 (let ((proc (apply #'run-hg-command '("id"))))
15.67 (let ((ok (eq 0 (sb-ext:process-exit-code proc)))
15.68 (res (make-array 0 :element-type 'character :fill-pointer 0 :adjustable t)))
16.1--- a/lisp/lib/vc/pkg.lisp Fri May 31 18:18:12 2024 -0400
16.2+++ b/lisp/lib/vc/pkg.lisp Fri May 31 23:28:35 2024 -0400
16.3@@ -1,18 +1,25 @@
16.4-(defpackage :vc
16.5- (:use :cl :std :cli :log :obj :sb-bsd-sockets :cl-ppcre :parse/lex)
16.6+(defpackage :vc/proto
16.7+ (:use :cl :std :log :obj :cl-ppcre :parse/lex)
16.8 (:import-from :uiop :with-current-directory)
16.9- (:export :*default-vc*
16.10- :vc-error :git-error :hg-error :vc-status
16.11+ (:export
16.12+ :vc-error :vc-status
16.13 :vc-clone :vc-push :vc-pull :vc-commit
16.14 :vc-init :vc-id :vc-add :vc-remove
16.15 :vc-addremove :vc-diff
16.16- :vc-branch :*hg-program* :*git-program* :run-git-command
16.17- :run-hg-command :repo :hg-repo :git-repo
16.18- :vc-meta :hg-meta :git-meta :make-hg-client
16.19- :hg-client :*repo-roots* :*repo-registry* :find-repo
16.20+ :vc-branch :repo
16.21+ :vc-meta :find-repo
16.22 :make-repo :register-repo
16.23- :vc-ignore :hgignore :gitignore))
16.24+ :vc-ignore))
16.25+
16.26+(pkg:defpkg :vc/hg
16.27+ (:use :cl :std :cli :sb-bsd-sockets :vc/proto)
16.28+ (:export :*hg-program* :hg-repo :hg-error :run-hg-command :hg-meta :make-hg-client :hg-client :hgignore))
16.29
16.30-(in-package :vc)
16.31+(defpackage :vc/git
16.32+ (:use :cl :std :cli :vc/proto)
16.33+ (:export :*git-program* :git-repo :git-error :run-git-command :git-meta :gitignore))
16.34
16.35-(defparameter *default-vc* :hg)
16.36+(pkg:defpkg :vc
16.37+ (:use :cl :std)
16.38+ (:use-reexport :vc/proto :vc/hg :vc/git)
16.39+ (:export :*default-vc-kind* :*repo-roots* :*repo-registry*))
17.1--- a/lisp/lib/vc/proto.lisp Fri May 31 18:18:12 2024 -0400
17.2+++ b/lisp/lib/vc/proto.lisp Fri May 31 23:28:35 2024 -0400
17.3@@ -3,7 +3,23 @@
17.4 ;;
17.5
17.6 ;;; Code:
17.7-(in-package :vc)
17.8+(in-package :vc/proto)
17.9+
17.10+;;; Conditions
17.11+(define-condition vc-error (std-error) ())
17.12+
17.13+;;; Utils
17.14+(defun namestring-or (obj)
17.15+ (if (pathnamep obj)
17.16+ (namestring obj)
17.17+ obj))
17.18+
17.19+(defun rel-pathname (path)
17.20+ (pathname (string-left-trim '(#\/) path)))
17.21+
17.22+(defun glob-path-match (glob)
17.23+ (lambda (p start end)
17.24+ (member (subseq p start end) (directory (rel-pathname glob)) :test 'equal)))
17.25
17.26 ;;; Functions
17.27 (defgeneric vc-init (self)
18.1--- a/lisp/lib/vc/tests.lisp Fri May 31 18:18:12 2024 -0400
18.2+++ b/lisp/lib/vc/tests.lisp Fri May 31 23:28:35 2024 -0400
18.3@@ -1,19 +1,20 @@
18.4 (defpackage :vc/tests
18.5- (:use :cl :rt :vc))
18.6+ (:use :cl :std :rt :vc/proto :vc/git :vc/hg))
18.7
18.8 (in-package :vc/tests)
18.9 (defsuite :vc)
18.10 (in-suite :vc)
18.11+(eval-always
18.12 (defmacro with-temp-repo (kind &body body)
18.13- `(let ((repo ,(make-instance 'vc::vc-repo)))
18.14- (setf (vc::vc-repo-path repo) (merge-pathnames (format nil "~A" (gensym "repo")) "/tmp/"))
18.15+ `(let ((repo ,(make-repo ".")))
18.16+ (setf (vc-repo-path repo) (merge-pathnames (format nil "~A" (gensym "repo")) "/tmp/"))
18.17 (case ,kind
18.18 (:hg (sb-mop::change-class repo 'hg-repo))
18.19 (:git (sb-mop::change-class repo 'git-repo))
18.20 (t nil))
18.21 (vc-init repo)
18.22 (let ((*default-pathname-defaults* (vc::vc-repo-path repo)))
18.23- ,@body)))
18.24+ ,@body))))
18.25
18.26 (deftest git ()
18.27 (with-temp-repo :git
18.28@@ -22,3 +23,6 @@
18.29 (deftest hg ()
18.30 (with-temp-repo :hg
18.31 (is (streamp (sb-ext:process-output (run-hg-command "status" nil :stream))))))
18.32+
18.33+(deftest vc ()
18.34+ (with-temp-repo vc::*default-vc-kind* (is repo)))
19.1--- a/lisp/lib/vc/util.lisp Fri May 31 18:18:12 2024 -0400
19.2+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
19.3@@ -1,13 +0,0 @@
19.4-(in-package :vc)
19.5-
19.6-(defun namestring-or (obj)
19.7- (if (pathnamep obj)
19.8- (namestring obj)
19.9- obj))
19.10-
19.11-(defun rel-pathname (path)
19.12- (pathname (string-left-trim '(#\/) path)))
19.13-
19.14-(defun glob-path-match (glob)
19.15- (lambda (p start end)
19.16- (member (subseq p start end) (directory (rel-pathname glob)) :test 'equal)))
20.1--- a/lisp/lib/vc/vc.asd Fri May 31 18:18:12 2024 -0400
20.2+++ b/lisp/lib/vc/vc.asd Fri May 31 23:28:35 2024 -0400
20.3@@ -1,15 +1,19 @@
20.4 (defsystem :vc
20.5 :depends-on (:std :cli :obj :net :log :parse)
20.6 :components ((:file "pkg")
20.7- (:file "util")
20.8- (:file "err")
20.9 (:file "proto")
20.10 (:file "hg")
20.11+ ;; (:module "hg"
20.12+ ;; :components
20.13+ ;; ())
20.14 (:file "git")
20.15+ ;; (:module "git"
20.16+ ;; :components
20.17+ ;; ())
20.18 (:file "vc"))
20.19 :in-order-to ((test-op (test-op :vc/tests))))
20.20
20.21 (defsystem :vc/tests
20.22- :depends-on (:rt :vc)
20.23+ :depends-on (:std :rt :vc)
20.24 :components ((:file "tests"))
20.25 :perform (test-op (o c) (symbol-call :rt :do-tests :vc)))
21.1--- a/lisp/lib/xdb/disk.lisp Fri May 31 18:18:12 2024 -0400
21.2+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
21.3@@ -1,838 +0,0 @@
21.4-(in-package :xdb)
21.5-;;; Disk
21.6-(defclass collection ()
21.7- ((name :initarg :name
21.8- :accessor name)
21.9- (path :initarg :path
21.10- :accessor path)
21.11- (docs :initarg :docs
21.12- :accessor docs)
21.13- (packages :initform (make-s-packages)
21.14- :accessor packages)
21.15- (classes :initform (make-class-cache)
21.16- :accessor classes)
21.17- (last-id :initform 0
21.18- :accessor last-id)
21.19- (object-cache :initarg :object-cache
21.20- :initform (make-hash-table :size 1000
21.21- :test 'eq)
21.22- :accessor object-cache)
21.23- (id-cache :initarg :id-cache
21.24- :initform (make-hash-table :size 1000)
21.25- :accessor id-cache)))
21.26-
21.27-(eval-when (:compile-toplevel :load-toplevel :execute)
21.28- (defparameter *codes*
21.29- #(ascii-string
21.30- id
21.31- cons
21.32- string
21.33- null
21.34- storable-class
21.35- storable-object
21.36- standard-class
21.37- standard-object
21.38- standard-link
21.39- fixnum
21.40- bignum
21.41- ratio
21.42- double-float
21.43- single-float
21.44- complex
21.45- symbol
21.46- intern-package-and-symbol
21.47- intern-symbol
21.48- character
21.49- simple-vector
21.50- array
21.51- hash-table
21.52- pathname
21.53- collection)))
21.54-
21.55-(defvar *statistics* ())
21.56-(defun collect-stats (code)
21.57- (let* ((type (aref *codes* code))
21.58- (cons (assoc type *statistics*)))
21.59- (if cons
21.60- (incf (cdr cons))
21.61- (push (cons type 1) *statistics*))
21.62- type))
21.63-
21.64-(defvar *collection* nil)
21.65-
21.66-(defvar *classes*)
21.67-(defvar *packages*)
21.68-(declaim (vector *classes* *packages*))
21.69-
21.70-(defvar *indexes*)
21.71-(declaim (hash-table *indexes*))
21.72-
21.73-(defvar *written-objects*)
21.74-(declaim (hash-table *indexes*))
21.75-
21.76-(eval-when (:compile-toplevel :load-toplevel :execute)
21.77- (defun type-code (type)
21.78- (position type *codes*)))
21.79-
21.80-(defparameter *readers* (make-array (length *codes*)))
21.81-(declaim (type (simple-array function (*)) *readers*))
21.82-
21.83-(defmacro defreader (type (stream) &body body)
21.84- (let ((name (intern (format nil "~a-~a" type '#:reader))))
21.85- `(progn
21.86- (defun ,name (,stream)
21.87- ,@body)
21.88- (setf (aref *readers* ,(type-code type))
21.89- #',name))))
21.90-
21.91-(declaim (inline call-reader))
21.92-(defun call-reader (code stream)
21.93- ;; (collect-stats code)
21.94- (funcall (aref *readers* code) stream))
21.95-
21.96-(defconstant +sequence-length+ 2)
21.97-(eval-when (:compile-toplevel :load-toplevel :execute)
21.98- (defconstant +fixnum-length+ 4))
21.99-(defconstant +char-length+ 2)
21.100-(defconstant +id-length+ 4)
21.101-(defconstant +class-id-length+ 2)
21.102-(defconstant +hash-table-length+ 3)
21.103-
21.104-(defconstant +unbound-slot+ 254)
21.105-(defconstant +end+ 255)
21.106-
21.107-(defconstant +ascii-char-limit+ (code-char 128))
21.108-
21.109-(deftype ascii-string ()
21.110- '(or
21.111- #+sb-unicode simple-base-string ; on #-sb-unicode the limit is 255
21.112- (satisfies ascii-string-p)))
21.113-
21.114-(defun ascii-string-p (string)
21.115- (declare (simple-string string))
21.116- (loop for char across string
21.117- always (char< char +ascii-char-limit+)))
21.118-
21.119-(deftype storage-fixnum ()
21.120- `(signed-byte ,(* +fixnum-length+ 8)))
21.121-
21.122-(defun make-class-cache ()
21.123- (make-array 10 :adjustable t :fill-pointer 0))
21.124-
21.125-(defmacro with-collection (collection &body body)
21.126- (let ((collection-sym (gensym)))
21.127- `(let* ((,collection-sym ,collection)
21.128- (*collection* ,collection-sym)
21.129- (*packages* (packages ,collection-sym))
21.130- (*classes* (classes ,collection-sym))
21.131- (*indexes* (id-cache ,collection-sym)))
21.132- ,@body)))
21.133-
21.134-;;;
21.135-(defun slot-effective-definition (class slot-name)
21.136- (find slot-name (class-slots class) :key #'slot-definition-name))
21.137-
21.138-(defun dump-data (stream)
21.139- (map-docs
21.140- nil
21.141- (lambda (document)
21.142- (write-top-level-object document stream))
21.143- *collection*))
21.144-
21.145-(defun write-top-level-object (object stream)
21.146- (if (typep object 'id)
21.147- (write-storable-object object stream)
21.148- (write-object object stream)))
21.149-
21.150-(declaim (inline read-next-object))
21.151-(defun read-next-object (stream)
21.152- (call-reader (read-n-bytes 1 stream) stream))
21.153-
21.154-;;; NIL
21.155-
21.156-(defmethod write-object ((object null) stream)
21.157- (write-n-bytes #.(type-code 'null) 1 stream))
21.158-
21.159-(defreader null (stream)
21.160- (declare (ignore stream))
21.161- nil)
21.162-
21.163-;;; Symbol
21.164-
21.165-(defun make-s-packages ()
21.166- (make-array 10 :adjustable t :fill-pointer 0))
21.167-
21.168-(defun make-s-package (package)
21.169- (let ((symbols (make-array 100 :adjustable t :fill-pointer 0)))
21.170- (values (vector-push-extend (cons package symbols) *packages*)
21.171- symbols
21.172- t)))
21.173-
21.174-(defun find-s-package (package)
21.175- (loop for i below (length *packages*)
21.176- for (stored-package . symbols) = (aref *packages* i)
21.177- when (eq package stored-package)
21.178- return (values i symbols)
21.179- finally (return (make-s-package package))))
21.180-
21.181-(defun s-intern (symbol)
21.182- (multiple-value-bind (package-id symbols new-package)
21.183- (find-s-package (symbol-package symbol))
21.184- (let* ((existing (and (not new-package)
21.185- (position symbol symbols)))
21.186- (symbol-id (or existing
21.187- (vector-push-extend symbol symbols))))
21.188- (values package-id symbol-id new-package (not existing)))))
21.189-
21.190-(defun s-intern-existing (symbol symbols)
21.191- (vector-push-extend symbol symbols))
21.192-
21.193-(defmethod write-object ((symbol symbol) stream)
21.194- (multiple-value-bind (package-id symbol-id
21.195- new-package new-symbol)
21.196- (s-intern symbol)
21.197- (cond ((and new-package new-symbol)
21.198- (write-n-bytes #.(type-code 'intern-package-and-symbol) 1 stream)
21.199- (write-object (package-name (symbol-package symbol)) stream)
21.200- (write-object (symbol-name symbol) stream))
21.201- (new-symbol
21.202- (write-n-bytes #.(type-code 'intern-symbol) 1 stream)
21.203- (write-n-bytes package-id +sequence-length+ stream)
21.204- (write-object (symbol-name symbol) stream))
21.205- (t
21.206- (write-n-bytes #.(type-code 'symbol) 1 stream)
21.207- (write-n-bytes package-id +sequence-length+ stream)
21.208- (write-n-bytes symbol-id +sequence-length+ stream)))))
21.209-
21.210-(defreader symbol (stream)
21.211- (let* ((package-id (read-n-bytes +sequence-length+ stream))
21.212- (symbol-id (read-n-bytes +sequence-length+ stream))
21.213- (package (or (aref *packages* package-id)
21.214- (error "Package with id ~a not found" package-id)))
21.215- (symbol (aref (cdr package) symbol-id)))
21.216- (or symbol
21.217- (error "Symbol with id ~a in package ~a not found"
21.218- symbol-id (car package)))))
21.219-
21.220-(defreader intern-package-and-symbol (stream)
21.221- (let* ((package-name (read-next-object stream))
21.222- (symbol-name (read-next-object stream))
21.223- (package (or (find-package package-name)
21.224- (error "Package ~a not found" package-name)))
21.225- (symbol (intern symbol-name package))
21.226- (s-package (nth-value 1 (make-s-package package))))
21.227- (s-intern-existing symbol s-package)
21.228- symbol))
21.229-
21.230-(defreader intern-symbol (stream)
21.231- (let* ((package-id (read-n-bytes +sequence-length+ stream))
21.232- (symbol-name (read-next-object stream))
21.233- (package (or (aref *packages* package-id)
21.234- (error "Package with id ~a for symbol ~a not found"
21.235- package-id symbol-name)))
21.236- (symbol (intern symbol-name (car package))))
21.237- (s-intern-existing symbol (cdr package))
21.238- symbol))
21.239-
21.240-;;; Integer
21.241-
21.242-(declaim (inline sign))
21.243-(defun sign (n)
21.244- (if (minusp n)
21.245- 1
21.246- 0))
21.247-
21.248-(defun write-fixnum (n stream)
21.249- (declare (storage-fixnum n))
21.250- (write-n-bytes #.(type-code 'fixnum) 1 stream)
21.251- (write-n-signed-bytes n +fixnum-length+ stream))
21.252-
21.253-(defun write-bignum (n stream)
21.254- (declare ((and integer (not storage-fixnum)) n))
21.255- (write-n-bytes #.(type-code 'bignum) 1 stream)
21.256- (write-n-bytes (sign n) 1 stream)
21.257- (let* ((fixnum-bits (* +fixnum-length+ 8))
21.258- (n (abs n))
21.259- (size (ceiling (integer-length n) fixnum-bits)))
21.260- (write-n-bytes size 1 stream)
21.261- (loop for position by fixnum-bits below (* size fixnum-bits)
21.262- do
21.263- (write-n-bytes (ldb (byte fixnum-bits position) n)
21.264- +fixnum-length+ stream))))
21.265-
21.266-(defmethod write-object ((object integer) stream)
21.267- (typecase object
21.268- (storage-fixnum
21.269- (write-fixnum object stream))
21.270- (t (write-bignum object stream))))
21.271-
21.272-(declaim (inline read-sign))
21.273-(defun read-sign (stream)
21.274- (if (plusp (read-n-bytes 1 stream))
21.275- -1
21.276- 1))
21.277-
21.278-(defreader bignum (stream)
21.279- (let ((fixnum-bits (* +fixnum-length+ 8))
21.280- (sign (read-sign stream))
21.281- (size (read-n-bytes 1 stream))
21.282- (integer 0))
21.283- (loop for position by fixnum-bits below (* size fixnum-bits)
21.284- do
21.285- (setf (ldb (byte fixnum-bits position) integer)
21.286- (read-n-bytes +fixnum-length+ stream)))
21.287- (* sign integer)))
21.288-
21.289-(defreader fixnum (stream)
21.290- (read-n-signed-bytes +fixnum-length+ stream))
21.291-
21.292-;;; Ratio
21.293-
21.294-(defmethod write-object ((object ratio) stream)
21.295- (write-n-bytes #.(type-code 'ratio) 1 stream)
21.296- (write-object (numerator object) stream)
21.297- (write-object (denominator object) stream))
21.298-
21.299-(defreader ratio (stream)
21.300- (/ (read-next-object stream)
21.301- (read-next-object stream)))
21.302-
21.303-;;; Float
21.304-
21.305-(defun write-8-bytes (n stream)
21.306- (write-n-bytes (ldb (byte 32 0) n) 4 stream)
21.307- (write-n-bytes (ldb (byte 64 32) n) 4 stream))
21.308-
21.309-(defun read-8-bytes (stream)
21.310- (logior (read-n-bytes 4 stream)
21.311- (ash (read-n-bytes 4 stream) 32)))
21.312-
21.313-(defmethod write-object ((float float) stream)
21.314- (etypecase float
21.315- (single-float
21.316- (write-n-bytes #.(type-code 'single-float) 1 stream)
21.317- (write-n-bytes (encode-float32 float) 4 stream))
21.318- (double-float
21.319- (write-n-bytes #.(type-code 'double-float) 1 stream)
21.320- (write-8-bytes (encode-float64 float) stream))))
21.321-
21.322-(defreader single-float (stream)
21.323- (decode-float32 (read-n-bytes 4 stream)))
21.324-
21.325-(defreader double-float (stream)
21.326- (decode-float64 (read-8-bytes stream)))
21.327-
21.328-;;; Complex
21.329-
21.330-(defmethod write-object ((complex complex) stream)
21.331- (write-n-bytes #.(type-code 'complex) 1 stream)
21.332- (write-object (realpart complex) stream)
21.333- (write-object (imagpart complex) stream))
21.334-
21.335-(defreader complex (stream)
21.336- (complex (read-next-object stream)
21.337- (read-next-object stream)))
21.338-
21.339-;;; Characters
21.340-
21.341-(defmethod write-object ((character character) stream)
21.342- (write-n-bytes #.(type-code 'character) 1 stream)
21.343- (write-n-bytes (char-code character) +char-length+ stream))
21.344-
21.345-(defreader character (stream)
21.346- (code-char (read-n-bytes +char-length+ stream)))
21.347-
21.348-;;; Strings
21.349-
21.350-(defun write-ascii-string (string stream)
21.351- (declare (simple-string string))
21.352- (loop for char across string
21.353- do (write-n-bytes (char-code char) 1 stream)))
21.354-
21.355-(defun write-multibyte-string (string stream)
21.356- (declare (simple-string string))
21.357- (loop for char across string
21.358- do (write-n-bytes (char-code char) +char-length+ stream)))
21.359-
21.360-(defmethod write-object ((string string) stream)
21.361- (etypecase string
21.362- ((not simple-string)
21.363- (call-next-method))
21.364- #+sb-unicode
21.365- (simple-base-string
21.366- (write-n-bytes #.(type-code 'ascii-string) 1 stream)
21.367- (write-n-bytes (length string) +sequence-length+ stream)
21.368- (write-ascii-string string stream))
21.369- (ascii-string
21.370- (write-n-bytes #.(type-code 'ascii-string) 1 stream)
21.371- (write-n-bytes (length string) +sequence-length+ stream)
21.372- (write-ascii-string string stream))
21.373- (string
21.374- (write-n-bytes #.(type-code 'string) 1 stream)
21.375- (write-n-bytes (length string) +sequence-length+ stream)
21.376- (write-multibyte-string string stream))))
21.377-
21.378-(declaim (inline read-ascii-string))
21.379-(defun read-ascii-string (length stream)
21.380- (let ((string (make-string length :element-type 'base-char)))
21.381- ;#-sbcl
21.382- (loop for i below length
21.383- do (setf (schar string i)
21.384- (code-char (read-n-bytes 1 stream))))
21.385- #+(and nil sbcl (or x86 x86-64))
21.386- (read-ascii-string-optimized length string stream)
21.387- string))
21.388-
21.389-(defreader ascii-string (stream)
21.390- (read-ascii-string (read-n-bytes +sequence-length+ stream) stream))
21.391-
21.392-(defreader string (stream)
21.393- (let* ((length (read-n-bytes +sequence-length+ stream))
21.394- (string (make-string length :element-type 'character)))
21.395- (loop for i below length
21.396- do (setf (schar string i)
21.397- (code-char (read-n-bytes +char-length+ stream))))
21.398- string))
21.399-
21.400-;;; Pathname
21.401-
21.402-(defmethod write-object ((pathname pathname) stream)
21.403- (write-n-bytes #.(type-code 'pathname) 1 stream)
21.404- (write-object (pathname-name pathname) stream)
21.405- (write-object (pathname-directory pathname) stream)
21.406- (write-object (pathname-device pathname) stream)
21.407- (write-object (pathname-type pathname) stream)
21.408- (write-object (pathname-version pathname) stream))
21.409-
21.410-(defreader pathname (stream)
21.411- (make-pathname
21.412- :name (read-next-object stream)
21.413- :directory (read-next-object stream)
21.414- :device (read-next-object stream)
21.415- :type (read-next-object stream)
21.416- :version (read-next-object stream)))
21.417-
21.418-;;; Cons
21.419-
21.420-(defmethod write-object ((list cons) stream)
21.421- (cond ((circular-list-p list)
21.422- (error "Can't store circular lists"))
21.423- (t
21.424- (write-n-bytes #.(type-code 'cons) 1 stream)
21.425- (loop for cdr = list then (cdr cdr)
21.426- do
21.427- (cond ((consp cdr)
21.428- (write-object (car cdr) stream))
21.429- (t
21.430- (write-n-bytes +end+ 1 stream)
21.431- (write-object cdr stream)
21.432- (return)))))))
21.433-
21.434-(defreader cons (stream)
21.435- (let ((first-cons (list (read-next-object stream))))
21.436- (loop for previous-cons = first-cons then new-cons
21.437- for car = (let ((id (read-n-bytes 1 stream)))
21.438- (cond ((eq id +end+)
21.439- (setf (cdr previous-cons) (read-next-object stream))
21.440- (return))
21.441- ((call-reader id stream))))
21.442- for new-cons = (list car)
21.443- do (setf (cdr previous-cons) new-cons))
21.444- first-cons))
21.445-
21.446-;;; Simple-vector
21.447-
21.448-(defmethod write-object ((vector vector) stream)
21.449- (typecase vector
21.450- (simple-vector
21.451- (write-simple-vector vector stream))
21.452- (t
21.453- (call-next-method))))
21.454-
21.455-(defun write-simple-vector (vector stream)
21.456- (declare (simple-vector vector))
21.457- (write-n-bytes #.(type-code 'simple-vector) 1 stream)
21.458- (write-n-bytes (length vector) +sequence-length+ stream)
21.459- (loop for elt across vector
21.460- do (write-object elt stream)))
21.461-
21.462-(defreader simple-vector (stream)
21.463- (let ((vector (make-array (read-n-bytes +sequence-length+ stream))))
21.464- (loop for i below (length vector)
21.465- do (setf (svref vector i) (read-next-object stream)))
21.466- vector))
21.467-
21.468-;;; Array
21.469-
21.470-(defun boolify (x)
21.471- (if x
21.472- 1
21.473- 0))
21.474-
21.475-(defmethod write-object ((array array) stream)
21.476- (write-n-bytes #.(type-code 'array) 1 stream)
21.477- (write-object (array-dimensions array) stream)
21.478- (cond ((array-has-fill-pointer-p array)
21.479- (write-n-bytes 1 1 stream)
21.480- (write-n-bytes (fill-pointer array) +sequence-length+ stream))
21.481- (t
21.482- (write-n-bytes 0 2 stream)))
21.483- (write-object (array-element-type array) stream)
21.484- (write-n-bytes (boolify (adjustable-array-p array)) 1 stream)
21.485- (loop for i below (array-total-size array)
21.486- do (write-object (row-major-aref array i) stream)))
21.487-
21.488-(defun read-array-fill-pointer (stream)
21.489- (if (plusp (read-n-bytes 1 stream))
21.490- (read-n-bytes +sequence-length+ stream)
21.491- (not (read-n-bytes 1 stream))))
21.492-
21.493-(defreader array (stream)
21.494- (let ((array (make-array (read-next-object stream)
21.495- :fill-pointer (read-array-fill-pointer stream)
21.496- :element-type (read-next-object stream)
21.497- :adjustable (plusp (read-n-bytes 1 stream)))))
21.498- (loop for i below (array-total-size array)
21.499- do (setf (row-major-aref array i) (read-next-object stream)))
21.500- array))
21.501-
21.502-;;; Hash-table
21.503-
21.504-(defvar *hash-table-tests* #(eql equal equalp eq))
21.505-(declaim (simple-vector *hash-table-tests*))
21.506-
21.507-(defun check-hash-table-test (hash-table)
21.508- (let* ((test (hash-table-test hash-table))
21.509- (test-id (position test *hash-table-tests*)))
21.510- (unless test-id
21.511- (error "Only standard hashtable tests are supported, ~a has ~a"
21.512- hash-table test))
21.513- test-id))
21.514-
21.515-(defmethod write-object ((hash-table hash-table) stream)
21.516- (write-n-bytes #.(type-code 'hash-table) 1 stream)
21.517- (write-n-bytes (check-hash-table-test hash-table) 1 stream)
21.518- (write-n-bytes (hash-table-size hash-table) +hash-table-length+ stream)
21.519- (loop for key being the hash-keys of hash-table
21.520- using (hash-value value)
21.521- do
21.522- (write-object key stream)
21.523- (write-object value stream))
21.524- (write-n-bytes +end+ 1 stream))
21.525-
21.526-(defreader hash-table (stream)
21.527- (let* ((test (svref *hash-table-tests* (read-n-bytes 1 stream)))
21.528- (size (read-n-bytes +hash-table-length+ stream))
21.529- (table (make-hash-table :test test :size size)))
21.530- (loop for id = (read-n-bytes 1 stream)
21.531- until (eq id +end+)
21.532- do (setf (gethash (call-reader id stream) table)
21.533- (read-next-object stream)))
21.534- table))
21.535-
21.536-;;; storable-class
21.537-
21.538-(defun cache-class (class id)
21.539- (when (< (length *classes*) id)
21.540- (adjust-array *classes* (1+ id)))
21.541- (when (> (1+ id) (fill-pointer *classes*))
21.542- (setf (fill-pointer *classes*) (1+ id)))
21.543- (setf (aref *classes* id) class))
21.544-
21.545-(defmethod write-object ((class storable-class) stream)
21.546- (cond ((position class *classes* :test #'eq))
21.547- (t
21.548- (unless (class-finalized-p class)
21.549- (finalize-inheritance class))
21.550- (let ((id (vector-push-extend class *classes*))
21.551- (slots (slots-to-store class)))
21.552- (write-n-bytes #.(type-code 'storable-class) 1 stream)
21.553- (write-object (class-name class) stream)
21.554- (write-n-bytes id +class-id-length+ stream)
21.555- (write-n-bytes (length slots) +sequence-length+ stream)
21.556- (loop for slot across slots
21.557- do (write-object (slot-definition-name slot)
21.558- stream))
21.559- id))))
21.560-
21.561-(defreader storable-class (stream)
21.562- (let ((class (find-class (read-next-object stream))))
21.563- (cache-class class
21.564- (read-n-bytes +class-id-length+ stream))
21.565- (unless (class-finalized-p class)
21.566- (finalize-inheritance class))
21.567- (let* ((length (read-n-bytes +sequence-length+ stream))
21.568- (vector (make-array length)))
21.569- (loop for i below length
21.570- for slot-d =
21.571- (slot-effective-definition class (read-next-object stream))
21.572- when slot-d
21.573- do (setf (aref vector i)
21.574- (cons (slot-definition-location slot-d)
21.575- (slot-definition-initform slot-d))))
21.576- (setf (slot-locations-and-initforms class) vector))
21.577- (read-next-object stream)))
21.578-
21.579-;;; Storable ID
21.580-
21.581-(defmethod write-object ((object id) stream)
21.582- (cond ((written object)
21.583- (let* ((class (class-of object))
21.584- (class-id (write-object class stream)))
21.585- (write-n-bytes #.(type-code 'id) 1 stream)
21.586- (write-n-bytes class-id +class-id-length+ stream)
21.587- (write-n-bytes (id object) +id-length+ stream)))
21.588- (t
21.589- (write-storable-object object stream))))
21.590-
21.591-(defun get-class (id)
21.592- (aref *classes* id))
21.593-
21.594-(declaim (inline get-instance))
21.595-(defun get-instance (class-id id)
21.596- (let* ((class (get-class class-id))
21.597- (index (if (typep class 'storable-class)
21.598- (id-cache class)
21.599- *indexes*)))
21.600- (or (gethash id index)
21.601- (setf (gethash id index)
21.602- (fast-allocate-instance class)))))
21.603-
21.604-(defreader id (stream)
21.605- (get-instance (read-n-bytes +class-id-length+ stream)
21.606- (read-n-bytes +id-length+ stream)))
21.607-
21.608-;;; storable-object
21.609-;; Can't use write-object method, because it would conflict with
21.610-;; writing a pointer to a standard object
21.611-(defun write-storable-object (object stream)
21.612- (let* ((class (class-of object))
21.613- (slots (slot-locations-and-initforms class))
21.614- (class-id (write-object class stream)))
21.615- (declare (simple-vector slots))
21.616- (write-n-bytes #.(type-code 'storable-object) 1 stream)
21.617- (write-n-bytes class-id +class-id-length+ stream)
21.618- (unless (id object)
21.619- (setf (id object) (last-id *collection*))
21.620- (incf (last-id *collection*)))
21.621- (write-n-bytes (id object) +id-length+ stream)
21.622- (setf (written object) t)
21.623- (loop for id below (length slots)
21.624- for (location . initform) = (aref slots id)
21.625- for value = (standard-instance-access object location)
21.626- unless (eql value initform)
21.627- do
21.628- (write-n-bytes id 1 stream)
21.629- (if (eq value '+slot-unbound+)
21.630- (write-n-bytes +unbound-slot+ 1 stream)
21.631- (write-object value stream)))
21.632- (write-n-bytes +end+ 1 stream)))
21.633-
21.634-(defreader storable-object (stream)
21.635- (let* ((class-id (read-n-bytes +class-id-length+ stream))
21.636- (id (read-n-bytes +id-length+ stream))
21.637- (instance (get-instance class-id id))
21.638- (class (class-of instance))
21.639- (slots (slot-locations-and-initforms class)))
21.640- (declare (simple-vector slots))
21.641- (setf (id instance) id)
21.642- (if (>= id (last-id *collection*))
21.643- (setf (last-id *collection*) (1+ id)))
21.644- (loop for slot-id = (read-n-bytes 1 stream)
21.645- until (= slot-id +end+)
21.646- do
21.647- (setf (standard-instance-access instance
21.648- (car (aref slots slot-id)))
21.649- (let ((code (read-n-bytes 1 stream)))
21.650- (if (= code +unbound-slot+)
21.651- '+slot-unbound+
21.652- (call-reader code stream)))))
21.653- instance))
21.654-
21.655-;;; standard-class
21.656-
21.657-(defmethod write-object ((class standard-class) stream)
21.658- (cond ((position class *classes* :test #'eq))
21.659- (t
21.660- (unless (class-finalized-p class)
21.661- (finalize-inheritance class))
21.662- (let ((id (vector-push-extend class *classes*))
21.663- (slots (class-slots class)))
21.664- (write-n-bytes #.(type-code 'standard-class) 1 stream)
21.665- (write-object (class-name class) stream)
21.666- (write-n-bytes id +class-id-length+ stream)
21.667- (write-n-bytes (length slots) +sequence-length+ stream)
21.668- (loop for slot in slots
21.669- do (write-object (slot-definition-name slot)
21.670- stream))
21.671- id))))
21.672-
21.673-(defreader standard-class (stream)
21.674- (let ((class (find-class (read-next-object stream))))
21.675- (cache-class class
21.676- (read-n-bytes +class-id-length+ stream))
21.677- (unless (class-finalized-p class)
21.678- (finalize-inheritance class))
21.679- (let ((length (read-n-bytes +sequence-length+ stream)))
21.680- (loop for i below length
21.681- do (slot-effective-definition class (read-next-object stream))
21.682- ;;do (setf (aref vector i)
21.683- ;; (cons (slot-definition-location slot-d)
21.684- ;; (slot-definition-initform slot-d)))
21.685- ))
21.686- (read-next-object stream)))
21.687-
21.688-;;; standard-link
21.689-
21.690-(defun write-standard-link (object stream)
21.691- (let* ((class (class-of object))
21.692- (class-id (write-object class stream)))
21.693- (write-n-bytes #.(type-code 'standard-link) 1 stream)
21.694- (write-n-bytes class-id +class-id-length+ stream)
21.695- (write-n-bytes (get-object-id object) +id-length+ stream)))
21.696-
21.697-(defreader standard-link (stream)
21.698- (get-instance (read-n-bytes +class-id-length+ stream)
21.699- (read-n-bytes +id-length+ stream)))
21.700-
21.701-;;; standard-object
21.702-
21.703-(defun get-object-id (object)
21.704- (let ((cache (object-cache *collection*)))
21.705- (or (gethash object cache)
21.706- (prog1
21.707- (setf (gethash object cache)
21.708- (last-id *collection*))
21.709- (incf (last-id *collection*))))))
21.710-
21.711-(defmethod write-object ((object standard-object) stream)
21.712- (if (gethash object *written-objects*)
21.713- (write-standard-link object stream)
21.714- (let* ((class (class-of object))
21.715- (slots (class-slots class))
21.716- (class-id (write-object class stream)))
21.717- (write-n-bytes #.(type-code 'standard-object) 1 stream)
21.718- (write-n-bytes class-id +class-id-length+ stream)
21.719- (write-n-bytes (get-object-id object) +id-length+ stream)
21.720- (setf (gethash object *written-objects*) t)
21.721- (loop for id from 0
21.722- for slot in slots
21.723- for location = (slot-definition-location slot)
21.724- for initform = (slot-definition-initform slot)
21.725- for value = (standard-instance-access object location)
21.726- do
21.727- (write-n-bytes id 1 stream)
21.728- (if (eq value '+slot-unbound+)
21.729- (write-n-bytes +unbound-slot+ 1 stream)
21.730- (write-object value stream)))
21.731- (write-n-bytes +end+ 1 stream))))
21.732-
21.733-(defreader standard-object (stream)
21.734- (let* ((class-id (read-n-bytes +class-id-length+ stream))
21.735- (id (read-n-bytes +id-length+ stream))
21.736- (instance (get-instance class-id id))
21.737- (class (class-of instance))
21.738- (slots (class-slots class)))
21.739- (flet ((read-slot ()
21.740- (let ((code (read-n-bytes 1 stream)))
21.741- (if (= code +unbound-slot+)
21.742- '+slot-unbound+
21.743- (call-reader code stream)))))
21.744- (loop for slot-id = (read-n-bytes 1 stream)
21.745- until (= slot-id +end+)
21.746- do
21.747- (let ((slot (nth slot-id slots)))
21.748- (if slot
21.749- (setf (standard-instance-access instance
21.750- (slot-definition-location slot))
21.751- (read-slot))
21.752- (read-slot)))))
21.753- instance))
21.754-
21.755-;;; collection
21.756-
21.757-(defmethod write-object ((collection collection) stream)
21.758- (write-n-bytes #.(type-code 'collection) 1 stream))
21.759-
21.760-(defreader collection (stream)
21.761- (declare (ignore stream))
21.762- *collection*)
21.763-
21.764-;;;
21.765-#+sbcl (declaim (inline %fast-allocate-instance))
21.766-
21.767-#+sbcl
21.768-(defun %fast-allocate-instance (wrapper initforms)
21.769- (declare (simple-vector initforms))
21.770- (let ((instance (sb-pcl::make-instance->constructor-call
21.771- (copy-seq initforms) (sb-pcl::safe-code-p))))
21.772- (setf (sb-pcl::std-instance-slots instance)
21.773- wrapper)
21.774- instance))
21.775-
21.776-#+sbcl
21.777-(defun fast-allocate-instance (class)
21.778- (declare (optimize speed))
21.779- (if (typep class 'storable-class)
21.780- (let ((initforms (class-initforms class))
21.781- (wrapper (sb-pcl::class-wrapper class)))
21.782- (%fast-allocate-instance wrapper initforms))
21.783- (allocate-instance class)))
21.784-
21.785-(defun clear-cache (collection)
21.786- (setf (classes collection) (make-class-cache)
21.787- (packages collection) (make-s-packages)))
21.788-
21.789-(defun read-file (function file)
21.790- (with-io-file (stream file)
21.791- (loop until (stream-end-of-file-p stream)
21.792- do (let ((object (read-next-object stream)))
21.793- (when (and (not (typep object 'class))
21.794- (typep object 'standard-object))
21.795- (funcall function object))))))
21.796-
21.797-(defun load-data (collection file function)
21.798- (with-collection collection
21.799- (read-file function file)))
21.800-
21.801-(defun save-data (collection &optional file)
21.802- (let ((*written-objects* (make-hash-table :test 'eq)))
21.803- (clear-cache collection)
21.804- (with-collection collection
21.805- (with-io-file (stream file
21.806- :direction :output)
21.807- (dump-data stream)))
21.808- (clear-cache collection)
21.809- (values)))
21.810-
21.811-(defun save-doc (collection document &optional file)
21.812- (let ((*written-objects* (make-hash-table :test 'eq)))
21.813- (with-collection collection
21.814- (with-io-file (stream file
21.815- :direction :output
21.816- :append t)
21.817- (write-top-level-object document stream)))))
21.818-
21.819-;;; DB Functions
21.820-
21.821-(defmethod sum ((collection collection) &key function element)
21.822- (let* ((sum 0)
21.823- (function (or function
21.824- (lambda (doc)
21.825- (incf sum (get-val doc element))))))
21.826- (map-docs nil
21.827- function
21.828- collection)
21.829- sum))
21.830-
21.831-(defmethod max-val ((collection collection) &key function element)
21.832- (let* ((max 0)
21.833- (function (or function
21.834- (lambda (doc)
21.835- (if (get-val doc element)
21.836- (if (> (get-val doc element) max)
21.837- (setf max (get-val doc element))))))))
21.838- (map-docs nil
21.839- function
21.840- collection)
21.841- max))
22.1--- a/lisp/lib/xdb/document.lisp Fri May 31 18:18:12 2024 -0400
22.2+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
22.3@@ -1,67 +0,0 @@
22.4-;;; obj/db/document.lisp --- Database Document Objects
22.5-
22.6-;; Spliced from XDB, currently not in use outside of it
22.7-
22.8-;;; Code:
22.9-(in-package :xdb)
22.10-;;; Document
22.11-(defclass document ()
22.12- ((collection :initarg :collection
22.13- :accessor collection)
22.14- (key :initarg :key
22.15- :accessor key)
22.16- (doc-type :initarg :doc-type
22.17- :initform nil
22.18- :accessor doc-type)))
22.19-
22.20-(defmethod duplicate-doc-p ((doc document) test-doc)
22.21- (or (eq doc test-doc)
22.22- (equal (key doc) (key test-doc))))
22.23-
22.24-(defmethod add ((doc document) &key collection duplicate-doc-p-func)
22.25- (when doc
22.26- (if (slot-boundp doc 'collection)
22.27- (add-doc (or (collection doc) collection) (or duplicate-doc-p-func #'duplicate-doc-p))
22.28- (error "Must specify collection to add document to."))))
22.29-
22.30-(defmethod get-val ((doc document) element &optional data-type)
22.31- (declare (ignore data-type))
22.32- (if (slot-boundp doc element)
22.33- (slot-val doc element)))
22.34-
22.35-(defmethod (setf get-val) (new-value (doc document) element &optional data-type)
22.36- (declare (ignore data-type))
22.37- (if doc
22.38- (setf (slot-value doc element) new-value)))
22.39-
22.40-(defclass document-join (join-docs)
22.41- ())
22.42-
22.43-(defclass document-join-result (join-result)
22.44- ())
22.45-
22.46-(defmethod get-val ((composite-doc document-join-result) element &optional data-type)
22.47- (declare (ignore data-type))
22.48- (map 'list
22.49- (lambda (doc)
22.50- (cons (doc-type doc) (get-val doc element)))
22.51- (docs composite-doc)))
22.52-
22.53-
22.54-(defmethod get-doc ((collection document-join) value &key (element 'key) (test #'equal))
22.55- (map-docs
22.56- nil
22.57- (lambda (doc)
22.58- (when (apply test (get-val doc element) value)
22.59- (return-from get-doc doc)))
22.60- collection))
22.61-
22.62-
22.63-(defmethod find-doc ((collection document-join) &key test)
22.64- (if test
22.65- (map-docs
22.66- nil
22.67- (lambda (doc)
22.68- (when (apply test doc)
22.69- (return-from find-doc doc)))
22.70- collection)))
23.1--- a/lisp/lib/xdb/io.lisp Fri May 31 18:18:12 2024 -0400
23.2+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
23.3@@ -1,265 +0,0 @@
23.4-;;; io/blob.lisp --- Blob Database IO
23.5-
23.6-;;
23.7-
23.8-;;; Code:
23.9-(in-package :xdb)
23.10-
23.11-;;; IO
23.12-(defvar *fsync-data* nil)
23.13-
23.14-(defconstant +buffer-size+ 8192)
23.15-
23.16-(deftype word () 'sb-ext:word)
23.17-
23.18-(defstruct (input-stream
23.19- (:predicate nil))
23.20- (fd nil :type word)
23.21- (left 0 :type word)
23.22- (buffer-start (sb-sys:sap-int
23.23- (sb-alien::%make-alien (* sb-vm:n-byte-bits
23.24- (+ +buffer-size+ 3))))
23.25- :type word)
23.26- (buffer-end 0 :type word)
23.27- (buffer-position 0 :type word))
23.28-
23.29-(defstruct (output-stream
23.30- (:predicate nil))
23.31- (fd nil :type word)
23.32- (buffer-start (sb-sys:sap-int
23.33- (sb-alien::%make-alien (* sb-vm:n-byte-bits
23.34- (+ +buffer-size+ 3))))
23.35- :type word)
23.36- (buffer-end 0 :type word)
23.37- (buffer-position 0 :type word))
23.38-
23.39-(defun open-file (file-stream
23.40- &key direction)
23.41- (if (eql direction :output)
23.42- (let ((output (make-output-stream
23.43- :fd (sb-sys:fd-stream-fd file-stream))))
23.44- (setf (output-stream-buffer-position output)
23.45- (output-stream-buffer-start output)
23.46- (output-stream-buffer-end output)
23.47- (+ (output-stream-buffer-start output)
23.48- +buffer-size+))
23.49- output)
23.50- (make-input-stream
23.51- :fd (sb-sys:fd-stream-fd file-stream)
23.52- :left (file-length file-stream))))
23.53-
23.54-(defun close-input-stream (stream)
23.55- (sb-alien:alien-funcall
23.56- (sb-alien:extern-alien "free"
23.57- (function (values) sb-alien:long))
23.58- (input-stream-buffer-start stream)))
23.59-
23.60-(defun close-output-stream (stream)
23.61- (flush-buffer stream)
23.62- (sb-alien:alien-funcall
23.63- (sb-alien:extern-alien "free"
23.64- (function (values) sb-alien:long))
23.65- (output-stream-buffer-start stream)))
23.66-
23.67-(declaim (inline stream-end-of-file-p))
23.68-(defun stream-end-of-file-p (stream)
23.69- (and (>= (input-stream-buffer-position stream)
23.70- (input-stream-buffer-end stream))
23.71- (zerop (input-stream-left stream))))
23.72-
23.73-(declaim (inline sap-ref-24))
23.74-(defun sap-ref-24 (sap offset)
23.75- (declare (optimize speed (safety 0))
23.76- (fixnum offset))
23.77- (mask-field (byte 24 0) (sb-sys:sap-ref-32 sap offset)))
23.78-
23.79-(declaim (inline n-sap-ref))
23.80-(defun n-sap-ref (n sap &optional (offset 0))
23.81- (funcall (ecase n
23.82- (1 #'sb-sys:sap-ref-8)
23.83- (2 #'sb-sys:sap-ref-16)
23.84- (3 #'sap-ref-24)
23.85- (4 #'sb-sys:sap-ref-32))
23.86- sap
23.87- offset))
23.88-
23.89-(declaim (inline unix-read))
23.90-(defun unix-read (fd buf len)
23.91- (declare (optimize (sb-c::float-accuracy 0)
23.92- (space 0)))
23.93- (declare (type sb-unix::unix-fd fd)
23.94- (type word len))
23.95- (sb-alien:alien-funcall
23.96- (sb-alien:extern-alien "read"
23.97- (function sb-alien:int
23.98- sb-alien:int sb-alien:long sb-alien:int))
23.99- fd buf len))
23.100-
23.101-(declaim (inline unix-read))
23.102-(defun unix-write (fd buf len)
23.103- (declare (optimize (sb-c::float-accuracy 0)
23.104- (space 0)))
23.105- (declare (type sb-unix::unix-fd fd)
23.106- (type word len))
23.107- (sb-alien:alien-funcall
23.108- (sb-alien:extern-alien "write"
23.109- (function sb-alien:int
23.110- sb-alien:int sb-alien:long sb-alien:int))
23.111- fd buf len))
23.112-
23.113-(defun fill-buffer (stream offset)
23.114- (let ((length (unix-read (input-stream-fd stream)
23.115- (+ (input-stream-buffer-start stream) offset)
23.116- (- +buffer-size+ offset))))
23.117- (setf (input-stream-buffer-end stream)
23.118- (+ (input-stream-buffer-start stream) (+ length offset)))
23.119- (decf (input-stream-left stream) length))
23.120- t)
23.121-
23.122-(defun refill-buffer (n stream)
23.123- (declare (type word n)
23.124- (input-stream stream))
23.125- (let ((left-n-bytes (- (input-stream-buffer-end stream)
23.126- (input-stream-buffer-position stream))))
23.127- (when (> (- n left-n-bytes)
23.128- (input-stream-left stream))
23.129- (error "End of file ~a" stream))
23.130- (unless (zerop left-n-bytes)
23.131- (setf (sb-sys:sap-ref-word (sb-sys:int-sap (input-stream-buffer-start stream)) 0)
23.132- (n-sap-ref left-n-bytes (sb-sys:int-sap (input-stream-buffer-position stream)))))
23.133- (fill-buffer stream left-n-bytes))
23.134- (let ((start (input-stream-buffer-start stream)))
23.135- (setf (input-stream-buffer-position stream)
23.136- (+ start n)))
23.137- t)
23.138-
23.139-(declaim (inline advance-input-stream))
23.140-(defun advance-input-stream (n stream)
23.141- (declare (optimize (space 0))
23.142- (type word n)
23.143- (type input-stream stream))
23.144- (let* ((sap (input-stream-buffer-position stream))
23.145- (new-sap (sb-ext:truly-the word (+ sap n))))
23.146- (declare (word sap new-sap))
23.147- (cond ((> new-sap (input-stream-buffer-end stream))
23.148- (refill-buffer n stream)
23.149- (sb-sys:int-sap (input-stream-buffer-start stream)))
23.150- (t
23.151- (setf (input-stream-buffer-position stream)
23.152- new-sap)
23.153- (sb-sys:int-sap sap)))))
23.154-
23.155-(declaim (inline read-n-bytes))
23.156-(defun read-n-bytes (n stream)
23.157- (declare (optimize (space 0))
23.158- (type word n))
23.159- (n-sap-ref n (advance-input-stream n stream)))
23.160-
23.161-(declaim (inline read-n-signed-bytes))
23.162-(defun read-n-signed-bytes (n stream)
23.163- (declare (optimize speed)
23.164- (sb-ext:muffle-conditions sb-ext:compiler-note)
23.165- (type (integer 1 4) n))
23.166- (funcall (ecase n
23.167- (1 #'sb-sys:signed-sap-ref-8)
23.168- (2 #'sb-sys:signed-sap-ref-16)
23.169- ;; (3 )
23.170- (4 #'sb-sys:signed-sap-ref-32))
23.171- (advance-input-stream n stream)
23.172- 0))
23.173-
23.174-(declaim (inline write-n-signed-bytes))
23.175-(defun write-n-signed-bytes (value n stream)
23.176- (declare (optimize speed)
23.177- (sb-ext:muffle-conditions sb-ext:compiler-note)
23.178- (fixnum n))
23.179- (ecase n
23.180- (1 (setf (sb-sys:signed-sap-ref-8 (advance-output-stream n stream) 0)
23.181- value))
23.182- (2 (setf (sb-sys:signed-sap-ref-16 (advance-output-stream n stream) 0)
23.183- value))
23.184- ;; (3 )
23.185- (4 (setf (sb-sys:signed-sap-ref-32 (advance-output-stream n stream) 0)
23.186- value)))
23.187- t)
23.188-
23.189-(defun flush-buffer (stream)
23.190- (unix-write (output-stream-fd stream)
23.191- (output-stream-buffer-start stream)
23.192- (- (output-stream-buffer-position stream)
23.193- (output-stream-buffer-start stream))))
23.194-
23.195-(declaim (inline advance-output-stream))
23.196-(defun advance-output-stream (n stream)
23.197- (declare (optimize (space 0) (safety 0))
23.198- (type word n)
23.199- (type output-stream stream)
23.200- ((integer 1 4) n))
23.201- (let* ((sap (output-stream-buffer-position stream))
23.202- (new-sap (sb-ext:truly-the word (+ sap n))))
23.203- (declare (word sap new-sap))
23.204- (cond ((> new-sap (output-stream-buffer-end stream))
23.205- (flush-buffer stream)
23.206- (setf (output-stream-buffer-position stream)
23.207- (+ (output-stream-buffer-start stream)
23.208- n))
23.209- (sb-sys:int-sap (output-stream-buffer-start stream)))
23.210- (t
23.211- (setf (output-stream-buffer-position stream)
23.212- new-sap)
23.213- (sb-sys:int-sap sap)))))
23.214-
23.215-(declaim (inline write-n-bytes))
23.216-(defun write-n-bytes (value n stream)
23.217- (declare (optimize (space 0))
23.218- (type word n))
23.219- (setf (sb-sys:sap-ref-32
23.220- (advance-output-stream n stream)
23.221- 0)
23.222- value))
23.223-;;;
23.224-
23.225-(declaim (inline copy-mem))
23.226-(defun copy-mem (from to length)
23.227- (let ((words-end (- length (rem length sb-vm:n-word-bytes))))
23.228- (loop for i by sb-vm:n-word-bytes below words-end
23.229- do (setf (sb-sys:sap-ref-word to i)
23.230- (sb-sys:sap-ref-word from i)))
23.231- (loop for i from words-end below length
23.232- do (setf (sb-sys:sap-ref-8 to i)
23.233- (sb-sys:sap-ref-8 from i)))))
23.234-
23.235-(declaim (inline read-ascii-string-optimized))
23.236-(defun read-ascii-string-optimized (length string stream)
23.237- (declare (type fixnum length)
23.238- (optimize (speed 3))
23.239- )
23.240- (sb-sys:with-pinned-objects (string)
23.241- (let ((sap (advance-input-stream length stream))
23.242- (string-sap (sb-sys:vector-sap string)))
23.243- (copy-mem sap string-sap length)))
23.244- string)
23.245-(defmacro with-io-file ((stream file
23.246- &key append (direction :input))
23.247- &body body)
23.248- (let ((fd-stream (gensym)))
23.249- `(with-open-file (,fd-stream ,file
23.250- :element-type '(unsigned-byte 8)
23.251- :direction ,direction
23.252- ,@(and (eql direction :output)
23.253- `(:if-exists ,(if append
23.254- :append
23.255- :supersede)))
23.256- ,@(and append
23.257- `(:if-does-not-exist :create)))
23.258- (let ((,stream (open-file ,fd-stream :direction ,direction)))
23.259- (unwind-protect
23.260- (progn ,@body)
23.261- ,@(ecase direction
23.262- (:output
23.263- `((close-output-stream ,stream)
23.264- (when *fsync-data*
23.265- (sb-posix:fdatasync
23.266- (sb-sys:fd-stream-fd ,fd-stream)))))
23.267- (:input
23.268- `((close-input-stream ,stream)))))))))
24.1--- a/lisp/lib/xdb/pkg.lisp Fri May 31 18:18:12 2024 -0400
24.2+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
24.3@@ -1,3 +0,0 @@
24.4-(defpackage :xdb
24.5- (:use :cl :std :seq :db :obj/meta/storable :obj/id)
24.6- (:export :xdb :dbs :add-collection))
25.1--- a/lisp/lib/xdb/proto.lisp Fri May 31 18:18:12 2024 -0400
25.2+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
25.3@@ -1,86 +0,0 @@
25.4-(in-package :xdb)
25.5-
25.6-(defgeneric initialize-doc-container (collection)
25.7- (:documentation
25.8- "Create the docs container and set the collection's docs to the container.
25.9-If you specialize this then you have to specialize add-doc, store-doc,
25.10-sort-collection, sort-collection-temporary and union-collection. "))
25.11-
25.12-(defgeneric map-docs (result-type function collection &rest more-collections)
25.13- (:documentation
25.14- "Applies the function accross all the documents in the collection"))
25.15-
25.16-(defgeneric duplicate-doc-p (doc test-doc)
25.17- (:method ((a t) (b t))))
25.18-
25.19-(defgeneric find-duplicate-doc (collection doc &key function)
25.20- (:documentation "Load collection from a file."))
25.21-
25.22-(defgeneric add-doc (collection doc &key duplicate-doc-p-func)
25.23- (:documentation "Add a document to the docs container."))
25.24-
25.25-(defgeneric store-doc (collection doc &key duplicate-doc-p-func)
25.26- (:documentation "Serialize the doc to file and add it to the collection."))
25.27-
25.28-(defgeneric serialize-doc (collection doc &key)
25.29- (:documentation "Serialize the doc to file."))
25.30-
25.31-(defgeneric serialize-docs (collection &key duplicate-doc-p-func)
25.32- (:documentation "Store all the docs in the collection on file and add it to the collection."))
25.33-
25.34-(defgeneric load-from-file (collection file)
25.35- (:documentation "Load collection from a file."))
25.36-
25.37-(defgeneric get-collection (db name)
25.38- (:documentation "Returns the collection by name."))
25.39-
25.40-(defgeneric add-collection (db name &key load-from-file-p)
25.41- (:documentation "Adds a collection to the db."))
25.42-
25.43-(defgeneric snapshot (collection)
25.44- (:documentation "Write out a snapshot."))
25.45-
25.46-(defgeneric load-db (db &key load-from-file-p)
25.47- (:documentation "Loads all the collections in a location."))
25.48-
25.49-(defgeneric get-docs (db collection-name &key return-type &allow-other-keys)
25.50- (:documentation "Returns the docs that belong to a collection."))
25.51-
25.52-(defgeneric get-doc (collection value &key element test)
25.53- (:documentation "Returns the docs that belong to a collection."))
25.54-
25.55-(defgeneric get-doc-complex (test element value collection &rest more-collections)
25.56- (:documentation "Returns the docs that belong to a collection."))
25.57-
25.58-(defgeneric get-doc-simple (element value collection &rest more-collections)
25.59- (:documentation "Returns the docs that belong to a collection."))
25.60-
25.61-(defgeneric find-doc (collection &key test)
25.62- (:documentation "Returns the docs that belong to a collection."))
25.63-
25.64-(defgeneric find-doc-complex (test collection &rest more-collections)
25.65- (:documentation "Returns the first doc that matches the test."))
25.66-
25.67-(defgeneric find-docs (return-type test collection))
25.68-
25.69-(defgeneric union-collection (return-type collection &rest more-collections))
25.70-
25.71-(defgeneric sort-collection (collection &key return-sort sort-value-func sort-test-func)
25.72- (:documentation "This sorts the collection 'permanantly'."))
25.73-
25.74-(defgeneric sort-collection-temporary (collection &key sort-value-func sort-test-func)
25.75- (:documentation "This does not sort the actual collection but returns an array
25.76-of sorted docs."))
25.77-
25.78-(defgeneric sum (collection &key function &allow-other-keys)
25.79- (:documentation "Applies the function to all the docs in the collection and returns the sum of
25.80-the return values."))
25.81-
25.82-(defgeneric max-val (collection &key function element))
25.83-
25.84-;;; Document
25.85-(defgeneric add (doc &key collection duplicate-doc-p-func)
25.86- (:documentation "Add a document to the docs container."))
25.87-
25.88-;;; Disk
25.89-(defgeneric write-object (object stream))
26.1--- a/lisp/lib/xdb/tests.lisp Fri May 31 18:18:12 2024 -0400
26.2+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
26.3@@ -1,231 +0,0 @@
26.4-(defpackage :xdb/tests
26.5- (:use :cl :rt :obj/db :obj/id :xdb :obj/meta/storable))
26.6-
26.7-(in-package :xdb/tests)
26.8-(defsuite :xdb)
26.9-(in-suite :xdb)
26.10-
26.11-(defparameter *tree* nil)
26.12-
26.13-(defclass test-doc-non-storable (id)
26.14- ((eid :initarg :eid)
26.15- (aa :initarg :aa)
26.16- (bb :initarg :bb)
26.17- (cc :initarg :cc)
26.18- (dd :initarg :dd)
26.19- (ee :initarg :ee)
26.20- (ff :initarg :ff)
26.21- (hh :initarg :hh)
26.22- (data :initarg :data
26.23- :initform (make-hash-table)
26.24- :accessor data)
26.25- (key :initarg :key
26.26- :initform nil
26.27- :accessor key)
26.28- (type :initarg :type
26.29- :initform nil)))
26.30-
26.31-(defclass test-doc-storable ()
26.32- ((eid :initarg :eid)
26.33- (aa :initarg :aa)
26.34- (bb :initarg :bb)
26.35- (cc :initarg :cc)
26.36- (dd :initarg :dd)
26.37- (ee :initarg :ee)
26.38- (ff :initarg :ff)
26.39- (hh :initarg :hh)
26.40- (data :initarg :data
26.41- :initform (make-hash-table)
26.42- :accessor data)
26.43- (key :initarg :key
26.44- :initform nil
26.45- :accessor key)
26.46- (type :initarg :type
26.47- :initform nil))
26.48- (:metaclass storable-class))
26.49-
26.50-(defun make-doc-test (type key data)
26.51- (let ((doc-obj (make-instance 'test-doc-storable :key key :type type)))
26.52- (dolist (pair data)
26.53- (setf (gethash (first pair) (data doc-obj)) (second pair)))
26.54- doc-obj))
26.55-
26.56-(defun test-store-doc (collection times)
26.57- (dotimes (i times)
26.58- (xdb::store-doc collection
26.59- (make-doc-test
26.60- "Test Doc"
26.61- i
26.62- (list
26.63- (list "id" i)
26.64- (list "eid" i)
26.65- (list "aa" (format nil "~R" (random 51234)))
26.66- (list "bb" (format nil "~R" (random 1234)))
26.67- (list "cc" (format nil "~R" (random 1234)))
26.68- (list "dd" (format nil "~R" (random 1234)))
26.69- (list "ee" (format nil "~R" (random 1234)))
26.70- (list "ff" (format nil "~R" (random 1234)))
26.71- (list "gg" (format nil "~R" (random 1234)))
26.72- (list "hh" (format nil "~R" (random 1234))))))))
26.73-
26.74-(defun db-test (n)
26.75- (let* ((db (make-instance 'xdb :location "/tmp/db-test/"))
26.76- (col (add-collection db "test" :load-from-file-p nil)))
26.77- (time (test-store-doc col n))
26.78- ;; (time (snapshot db))
26.79- ;; (time (sum col "eid"))
26.80- ;; (time (find-doc col "eid" 50))
26.81- ;; (time (sort-collection col))
26.82- ))
26.83-
26.84-(defun test-store-docx (collection times)
26.85- (dotimes (i times)
26.86-
26.87- (xdb::store-doc collection
26.88-
26.89- (make-doc-test
26.90- "Test Doc"
26.91- i
26.92- (list
26.93- (list "id" i)
26.94- (list "eid" i)
26.95- (list "aa" (random 51234))
26.96- (list "bb" (format nil "~R" (random 1234)))
26.97- (list "cc" (format nil "~R" (random 1234)))
26.98- (list "dd" (format nil "~R" (random 1234)))
26.99- (list "ee" (format nil "~R" (random 1234)))
26.100- (list "ff" (format nil "~R" (random 1234)))
26.101- (list "gg" (format nil "~R" (random 1234)))
26.102- (list "hh" (get-universal-time))))
26.103- )
26.104-
26.105- (if (equal (mod i 100000) 0)
26.106- (sb-ext:gc :full t))))
26.107-
26.108-(defun test-store-doc-storable-object (collection times)
26.109- (dotimes (i times)
26.110- (xdb::store-doc collection
26.111- (make-instance 'test-doc-storable :key i :type "Test Doc"
26.112- :id i
26.113- :eid i
26.114- :aa (random 51234)
26.115- :bb (format nil "~R" (random 1234))
26.116- :cc (format nil "~R" (random 1234))
26.117- :dd (format nil "~R" (random 1234))
26.118- :ee (format nil "~R" (random 1234))
26.119- :ff (format nil "~R" (random 1234))
26.120- :hh (get-universal-time))
26.121-
26.122- )
26.123-
26.124- (if (equal (mod i 100000) 0)
26.125- (sb-ext:gc :full t))))
26.126-
26.127-(defun test-store-doc-non-storable-object (collection times)
26.128- (dotimes (i times)
26.129- (xdb::store-doc collection
26.130- (make-instance 'test-doc-non-storable :key i :type "Test Doc"
26.131- :id i
26.132- :eid i
26.133- :aa (random 51234)
26.134- :bb (format nil "~R" (random 1234))
26.135- :cc (format nil "~R" (random 1234))
26.136- :dd (format nil "~R" (random 1234))
26.137- :ee (format nil "~R" (random 1234))
26.138- :ff (format nil "~R" (random 1234))
26.139- :hh (get-universal-time))
26.140-
26.141- )
26.142-
26.143- (if (equal (mod i 100000) 0)
26.144- (sb-ext:gc :full t))))
26.145-
26.146-(defun test-store-doc-hash (collection times)
26.147- (dotimes (i times)
26.148- (let ((hash (make-hash-table :test 'equal)))
26.149- (setf (gethash 'key hash) i)
26.150- (setf (gethash "id" hash) i)
26.151- (setf (gethash "eid" hash) i)
26.152- (setf (gethash "bb" hash) (format nil "~R" (random 1234)))
26.153- (setf (gethash "cc" hash) (format nil "~R" (random 1234)))
26.154- (setf (gethash "dd" hash) (format nil "~R" (random 1234)))
26.155- (setf (gethash "ee" hash) (format nil "~R" (random 1234)))
26.156- (setf (gethash "ff" hash) (format nil "~R" (random 1234)))
26.157- (setf (gethash "stamp" hash) (get-universal-time))
26.158- (xdb::store-doc collection hash))
26.159-
26.160- (if (equal (mod i 100000) 0)
26.161- (sb-ext:gc :full t))))
26.162-
26.163-
26.164-(defun test-store-doc-list (collection times)
26.165- (dotimes (i times)
26.166- (xdb::store-doc collection (list
26.167- (list 'key i)
26.168- (list "id" i)
26.169- (list "eid" i)
26.170- (list "aa" (random 51234))
26.171- (list "bb" (format nil "~R" (random 1234)))
26.172- (list "cc" (format nil "~R" (random 1234)))
26.173- (list "dd" (format nil "~R" (random 1234)))
26.174- (list "ee" (format nil "~R" (random 1234)))
26.175- (list "ff" (format nil "~R" (random 1234)))
26.176- (list "gg" (format nil "~R" (random 1234)))
26.177- (list "stamp" (get-universal-time))))
26.178-
26.179- (if (equal (mod i 100000) 0)
26.180- (sb-ext:gc :full t))))
26.181-
26.182-(defparameter db (make-instance 'xdb :location "/tmp/db-test/"))
26.183-
26.184-(defparameter col-hash (add-collection db "test-hash" :load-from-file-p nil))
26.185-
26.186-(defparameter col-list (add-collection db "test-list" :load-from-file-p nil))
26.187-(defparameter col-object (add-collection db "test-object" :load-from-file-p nil))
26.188-(defparameter col-object-storable (add-collection db "test-object-storable" :load-from-file-p nil))
26.189-
26.190-;;; DB
26.191-(deftest db ()
26.192- "Test database protocol."
26.193- (format t "Hash Test~%")
26.194- (format t "Store~%")
26.195- (time (test-store-doc-hash col-hash 10000))
26.196- (format t "Sum~%")
26.197- (time (xdb::sum col-hash :element "id"))
26.198- (format t "Find~%")
26.199- (time (xdb::find-doc col-hash :test (lambda (doc) (equal (get-val doc "id") 500))))
26.200- (format t "Sort~%")
26.201- (time (xdb::sort-collection col-hash))
26.202- (format t "List Test~%")
26.203- (format t "Store~%")
26.204- (time (test-store-doc-list col-list 10000))
26.205- (format t "Sum~%")
26.206- (time (xdb::sum col-list :element "id"))
26.207- (format t "Find~%")
26.208- (time (xdb::find-doc col-list :test (lambda (doc) (equal (get-val doc "id") 500))))
26.209- (format t "Sort~%")
26.210- (time (xdb::sort-collection col-list))
26.211-
26.212-
26.213- (format t "Object non storable Test~%")
26.214- (format t "Store~%")
26.215- (time (test-store-doc-non-storable-object col-object 10000))
26.216- (format t "Sum~%")
26.217- (time (xdb::sum col-object :element 'id))
26.218- (format t "Find~%")
26.219- (time (xdb::find-doc col-object :test (lambda (doc) (equal (get-val doc 'id) 500))))
26.220- (format t "Sort~%")
26.221- (time (xdb::sort-collection col-object))
26.222-
26.223-
26.224- (setf xdb::*fsync-data* nil)
26.225- (format t "Object storable Test~%")
26.226- (format t "Store~%")
26.227- (time (test-store-doc-storable-object col-object-storable 10000))
26.228- (format t "Sum~%")
26.229- (time (xdb::sum col-object-storable :element 'id))
26.230- (format t "Find~%")
26.231- (time (xdb::find-doc col-object-storable :test (lambda (doc) (equal (get-val doc 'id) 500))))
26.232- (format t "Sort~%")
26.233- (time (xdb::sort-collection col-object-storable)))
26.234-
27.1--- a/lisp/lib/xdb/xdb.asd Fri May 31 18:18:12 2024 -0400
27.2+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
27.3@@ -1,14 +0,0 @@
27.4-(defsystem :xdb
27.5- :depends-on (:std :obj)
27.6- :serial t
27.7- :components ((:file "pkg")
27.8- (:file "io")
27.9- (:file "disk")
27.10- (:file "document")
27.11- (:file "xdb"))
27.12- :in-order-to ((test-op (test-op "xdb/tests"))))
27.13-
27.14-(defsystem :xdb/tests
27.15- :depends-on (:rt :obj :xdb)
27.16- :components ((:file "tests"))
27.17- :perform (test-op (o c) (symbol-call :rt :do-tests :xdb)))
28.1--- a/lisp/lib/xdb/xdb.lisp Fri May 31 18:18:12 2024 -0400
28.2+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
28.3@@ -1,292 +0,0 @@
28.4-(in-package :xdb)
28.5-
28.6-;;; XDB
28.7-(defclass xdb ()
28.8- ((location :initarg :location
28.9- :accessor location
28.10- :initform (required-argument "Location is required"))
28.11- (collections :initarg :collections
28.12- :accessor collections
28.13- :initform (make-hash-table :test 'equal))))
28.14-
28.15-(defclass dbs ()
28.16- ((databases :initarg :databases
28.17- :accessor databases
28.18- :initform (make-hash-table :test 'equal))
28.19- (base-path :initarg :base-path
28.20- :initform "/tmp/db/"
28.21- :accessor base-path)))
28.22-
28.23-(defmethod get-db ((dbs dbs) name)
28.24- (gethash name (databases dbs)))
28.25-
28.26-(defun parse-db-path (path)
28.27- (make-pathname :directory
28.28- (list* :relative
28.29- (etypecase path
28.30- (cons path
28.31- path)
28.32- (string path
28.33- (list path))))))
28.34-
28.35-(defmethod add-db ((dbs dbs) name &key base-path load-from-file-p)
28.36- (unless (gethash name (databases dbs))
28.37- (let* ((base-path (or base-path (base-path dbs)))
28.38- (db-path (merge-pathnames (parse-db-path name) base-path))
28.39- (db (make-instance 'xdb :location db-path)))
28.40- (ensure-directories-exist db-path)
28.41- (setf (gethash name (databases dbs)) db)
28.42- (if load-from-file-p
28.43- (load-db db :load-from-file-p load-from-file-p)))))
28.44-
28.45-(defparameter *dbs* nil)
28.46-
28.47-(defun dbs ()
28.48- *dbs*)
28.49-
28.50-(defmethod initialize-doc-container ((collection collection))
28.51- (setf (docs collection) (make-array 0 :adjustable t :fill-pointer 0)))
28.52-
28.53-(defmethod map-docs (result-type function (collection collection)
28.54- &rest more-collections)
28.55- (let ((result
28.56- (map result-type function (docs collection))))
28.57- (loop for collection in more-collections
28.58- for results = (map result-type function (docs collection))
28.59- if result-type
28.60- do (setf result (concatenate result-type result results)))
28.61- result))
28.62-
28.63-(defmethod find-duplicate-doc ((collection collection) doc &key function)
28.64- (let ((test (or function #'duplicate-doc-p)))
28.65- (map-docs
28.66- nil
28.67- (lambda (docx)
28.68- (when (funcall test doc docx)
28.69- (return-from find-duplicate-doc docx)))
28.70- collection)))
28.71-
28.72-(defmethod add-doc ((collection collection) doc &key duplicate-doc-p-func)
28.73- (when doc
28.74- (if duplicate-doc-p-func
28.75- (let ((dup (find-duplicate-doc collection doc :function duplicate-doc-p-func)))
28.76- (if (not dup)
28.77- (vector-push-extend doc (docs collection))
28.78- (setf dup doc) ;;doing this because
28.79- ))
28.80- (vector-push-extend doc (docs collection)))))
28.81-
28.82-(defmethod store-doc ((collection collection) doc
28.83- &key (duplicate-doc-p-func #'duplicate-doc-p))
28.84- (let ((dup (and duplicate-doc-p-func
28.85- (find-duplicate-doc collection doc
28.86- :function duplicate-doc-p-func))))
28.87- ;; a document might be considered duplicate based on the data
28.88- ;;contained and not its eql status as lisp object so we have to replace
28.89- ;;it in the array with the new object effectively updating the data.
28.90- (if dup
28.91- (setf dup doc)
28.92- (vector-push-extend doc (docs collection)))
28.93- (serialize-doc collection doc))
28.94- collection)
28.95-
28.96-(defmethod serialize-doc ((collection collection) doc &key)
28.97- (let ((path (make-pathname :type "log" :defaults (db::path collection))))
28.98- (ensure-directories-exist path)
28.99- (db::save-doc collection doc path))
28.100- doc)
28.101-
28.102-(defmethod serialize-docs (collection &key duplicate-doc-p-func)
28.103- (map-docs
28.104- nil
28.105- (lambda (doc)
28.106- (store-doc collection doc
28.107- :duplicate-doc-p-func duplicate-doc-p-func))
28.108- collection))
28.109-
28.110-(defmethod load-from-file ((collection collection) file)
28.111- (when (probe-file file)
28.112- (db::load-data collection file
28.113- (lambda (object)
28.114- (add-doc collection object)))))
28.115-
28.116-(defmethod get-collection ((db xdb) name)
28.117- (gethash name (collections db)))
28.118-
28.119-(defun make-new-collection (name db &key collection-class)
28.120- (let ((collection
28.121- (make-instance collection-class
28.122- :name name
28.123- :path (merge-pathnames name (location db)))))
28.124- (initialize-doc-container collection)
28.125- collection))
28.126-
28.127-(defmethod add-collection ((db xdb) name
28.128- &key (collection-class 'collection) load-from-file-p)
28.129- (let ((collection (or (gethash name (collections db))
28.130- (setf (gethash name (collections db))
28.131- (make-new-collection name db
28.132- :collection-class collection-class)))))
28.133- (ensure-directories-exist (db::path collection))
28.134- (when load-from-file-p
28.135- (load-from-file collection
28.136- (make-pathname :defaults (db::path collection)
28.137- :type "snap"))
28.138- (load-from-file collection
28.139- (make-pathname :defaults (db::path collection)
28.140- :type "log")))
28.141- collection))
28.142-
28.143-(defun append-date (name)
28.144- (format nil "~a-~a" name (file-date)))
28.145-
28.146-(defmethod snapshot ((collection collection))
28.147- (let* ((backup (merge-pathnames "backup/" (db::path collection)))
28.148- (log (make-pathname :type "log" :defaults (db::path collection)))
28.149- (snap (make-pathname :type "snap" :defaults (db::path collection)))
28.150- (backup-name (append-date (db::name collection)))
28.151- (log-backup (make-pathname :name backup-name
28.152- :type "log"
28.153- :defaults backup))
28.154- (snap-backup (make-pathname :name backup-name
28.155- :type "snap"
28.156- :defaults backup)))
28.157- (ensure-directories-exist backup)
28.158- (when (probe-file snap)
28.159- (rename-file snap snap-backup))
28.160- (when (probe-file log)
28.161- (rename-file log log-backup))
28.162- (db::save-data collection snap)))
28.163-
28.164-(defmethod snapshot ((db xdb))
28.165- (maphash (lambda (key value)
28.166- (declare (ignore key))
28.167- (snapshot value))
28.168- (collections db)))
28.169-
28.170-(defmethod load-db ((db xdb) &key load-from-file-p)
28.171- (let ((unique-collections (make-hash-table :test 'equal)))
28.172- (dolist (path (directory (format nil "~A/*.*" (location db))))
28.173- (when (pathname-name path)
28.174- (setf (gethash (pathname-name path) unique-collections)
28.175- (pathname-name path))))
28.176- (maphash #'(lambda (key value)
28.177- (declare (ignore key))
28.178- (add-collection db value :load-from-file-p load-from-file-p))
28.179- unique-collections)))
28.180-
28.181-(defmethod get-docs ((db xdb) collection-name &key return-type)
28.182- (let ((col (gethash collection-name (collections db))))
28.183- (if return-type
28.184- (coerce return-type
28.185- (docs col))
28.186- (docs col))))
28.187-
28.188-(defmethod get-doc (collection value &key (element 'key) (test #'equal))
28.189- (map-docs
28.190- nil
28.191- (lambda (doc)
28.192- (when (funcall test (get-val doc element) value)
28.193- (return-from get-doc doc)))
28.194- collection))
28.195-
28.196-(defmethod get-doc-complex (test element value collection &rest more-collections)
28.197- (apply #'map-docs
28.198- nil
28.199- (lambda (doc)
28.200- (when (apply test (list (get-val doc element) value))
28.201- (return-from get-doc-complex doc)))
28.202- collection
28.203- more-collections))
28.204-
28.205-(defmethod find-doc (collection &key test)
28.206- (if test
28.207- (map-docs
28.208- nil
28.209- (lambda (doc)
28.210- (when (funcall test doc)
28.211- (return-from find-doc doc)))
28.212- collection)))
28.213-
28.214-(defmethod find-doc-complex (test collection &rest more-collections)
28.215- (apply #'map-docs
28.216- (lambda (doc)
28.217- (when (funcall test doc)
28.218- (return-from find-doc-complex doc)))
28.219- collection
28.220- (cdr more-collections)))
28.221-
28.222-(defmethod find-docs (return-type test collection)
28.223- (coerce (loop for doc across (docs collection)
28.224- when (funcall test doc)
28.225- collect doc)
28.226- return-type))
28.227-
28.228-(defclass union-docs ()
28.229- ((docs :initarg :docs
28.230- :accessor :docs)))
28.231-
28.232-(defmethod union-collection (return-type (collection collection) &rest more-collections)
28.233- (make-instance
28.234- 'union-docs
28.235- :docs (apply #'map-docs (list return-type collection more-collections))))
28.236-
28.237-(defclass join-docs ()
28.238- ((docs :initarg :docs
28.239- :accessor :docs)))
28.240-
28.241-(defclass join-result ()
28.242- ((docs :initarg :docs
28.243- :accessor :docs)))
28.244-
28.245-(defun sort-key (doc)
28.246- (get-val doc 'key))
28.247-
28.248-;; TODO: How to update log if collection is sorted? Make a snapshot?
28.249-(defmethod sort-collection ((collection collection)
28.250- &key return-sort
28.251- (sort-value-func #'sort-key) (sort-test-func #'>))
28.252- (setf (docs collection)
28.253- (sort (docs collection)
28.254- sort-test-func
28.255- :key sort-value-func))
28.256- (if return-sort
28.257- (docs collection)
28.258- t))
28.259-
28.260-(defmethod db::sort-collection-temporary ((collection collection)
28.261- &key (sort-value-func #'sort-key) (sort-test-func #'>))
28.262- (let ((sorted-array (copy-array (docs collection))))
28.263- (setf sorted-array
28.264- (sort sorted-array
28.265- sort-test-func
28.266- :key sort-value-func))
28.267- sorted-array))
28.268-
28.269-(defun sort-docs (docs &key (sort-value-func #'sort-key) (sort-test-func #'>))
28.270- :documentation "Sorts array/list of docs and returns the sorted array."
28.271- (sort docs
28.272- sort-test-func
28.273- :key sort-value-func))
28.274-
28.275-;;Add method for validation when updating a collection.
28.276-
28.277-(defclass xdb-sequence ()
28.278- ((key :initarg :key
28.279- :accessor key)
28.280- (value :initarg :value
28.281- :accessor value)))
28.282-
28.283-(defmethod enable-sequences ((xdb xdb))
28.284- (add-collection xdb "sequences"
28.285- :collection-class 'collection
28.286- :load-from-file-p t))
28.287-
28.288-(defmethod next-sequence ((xdb xdb) key)
28.289- (let ((doc (get-doc (get-collection xdb "sequences") key)))
28.290- (unless doc
28.291- (setf doc (make-instance 'xdb-sequence :key key :value 0)))
28.292- (incf (get-val doc 'value))
28.293- (store-doc (get-collection xdb "sequences")
28.294- doc)
28.295- (get-val doc 'value)))
29.1--- a/lisp/lisp.sk Fri May 31 18:18:12 2024 -0400
29.2+++ b/lisp/lisp.sk Fri May 31 23:28:35 2024 -0400
29.3@@ -1,4 +1,4 @@
29.4 ;;; lisp.sk --- lisp skelfile -*- mode: skel; -*-
29.5 :name "core/lisp"
29.6 :description "The CC Lisp Core"
29.7-:components ((:asd "prelude.asd"))
29.8+:components ((:asd "prelude.asd") (:asd "user.asd"))
30.1--- a/lisp/prelude.asd Fri May 31 18:18:12 2024 -0400
30.2+++ b/lisp/prelude.asd Fri May 31 23:28:35 2024 -0400
30.3@@ -2,10 +2,9 @@
30.4 (defsystem :prelude
30.5 :depends-on (:std :cli
30.6 :rocksdb :btrfs :uring
30.7- :doc
30.8+ :doc :alsa
30.9 :nlp :obj
30.10 :skel :syn
30.11- :xdb :alsa
30.12 :organ :packy
30.13 :tree-sitter :xkb :ssh2 :sndfile ;; magick
30.14 :zstd :uring :blake3 :ublk
31.1--- a/lisp/std/pkg.lisp Fri May 31 18:18:12 2024 -0400
31.2+++ b/lisp/std/pkg.lisp Fri May 31 23:28:35 2024 -0400
31.3@@ -7,7 +7,7 @@
31.4 (defpackage :std-user
31.5 (:use :cl :std)
31.6 (:shadowing-import-from :std/defpkg :defpkg :define-lisp-package)
31.7- (:export :defpkg :in-readtable :define-lisp-package))
31.8+ (:export :defpkg :define-lisp-package))
31.9
31.10 (in-package :std-user)
31.11
