better datastore formats and ability to dump datastore to simple cons…

…tructor forms
vii · Jun 20, 2009 · 7752d66 · 7752d66
1 parent 30af7f1
commit 7752d66
Show file tree

Hide file tree

Showing 5 changed files with 57 additions and 13 deletions.
diff --git a/src/blog/blog.lisp b/src/blog/blog.lisp
@@ -36,7 +36,7 @@
   me)
 
 (my-defun blog ready-entries (&key (start 0))
-	  (subseq (remove-if-not 'entry-ready (my entries)) start))
+	  (subseq (remove-if-not #'entry-front-page-p (my entries)) start))
 
 (my-defun blog atom-feed-url ()
 	  (byte-vector-cat (my link-base) "feed.atom"))
@@ -149,5 +149,5 @@
 
 (my-defun blog last-updated ()
 	  (loop for e in (my entries)
-		when (entry-ready e)
+		when (entry-front-page-p e)
 		maximizing (entry-time e)))
diff --git a/src/blog/entry.lisp b/src/blog/entry.lisp
@@ -7,6 +7,16 @@
   (time :initform (get-universal-time))
   trace-details)
 
+(defmethod print-object ((comment comment) stream)
+  (with-shorthand-accessor (my comment)
+    (print-unreadable-object (comment stream :type t)
+      (format stream "~S by ~S/~A at ~A"
+	      (force-string (my text))
+	      (force-string (my author))
+	      (force-string (my trace-details))
+	      (time-string (my time))))))
+
+
 (defun split-into-paragraphs (str)
   (match-split (progn #\Newline (* (or #\Space #\Tab #\Return)) #\Newline)
 	       str))
@@ -27,6 +37,7 @@
   tags
   (title "Untitled")
   time
+  expiry-time
   paragraphs)
 
 (my-defun entry 'simple-channel-body-ml ()
@@ -46,8 +57,10 @@
 (my-defun entry filename ()
   (strcat (its dir (my blog)) (my name)))
 
-(my-defun entry ready ()
-  (>= (get-universal-time) (my time)))
+(my-defun entry front-page-p ()
+	  (let ((now (get-universal-time)))
+	   (and (>= now (my time))
+		(or (not (my expiry-time)) (>= (my expiry-time) now)))))
 
 (my-defun entry url-path ()
   (byte-vector-cat (its link-base (my blog)) (my name)))

diff --git a/src/datastore/datastore.lisp b/src/datastore/datastore.lisp
@@ -1,26 +1,39 @@
 (in-package #:tpd2.datastore)
 
 (defvar *datastore*)
+(defvar *datastore-id-max* 0)
 
 (defun datastore-load (file)
-  (load file :if-does-not-exist nil))
+  ; SBCL struggles as it tries to compile these large files if a simple load is used
+  (with-open-file (stream file :if-does-not-exist nil)
+    (when stream
+      (loop for form = (read stream nil 'eof)
+	    until (eq form 'eof)
+	    do (eval form)))))
+
+(defun datastore-open-p ()
+  (and (boundp '*datastore*) *datastore*))
 
 (defun datastore-use-file (filename)
-  (unless (and (boundp '*datastore*) *datastore*)
+  (unless (datastore-open-p)
     (datastore-load filename)
     (setf *datastore* (open filename :direction :output :if-exists :append :if-does-not-exist :create))))
 
 (defun datastore-ref-form (object)
   `(datastore-retrieve-unique ',(class-name (class-of object)) 'datastore-id ,(slot-value object 'datastore-id)))
 
+(defun datastore-close ()
+  (when (datastore-open-p)
+    (close *datastore*)
+    (setf *datastore-id-max* 0))
+  (makunbound '*datastore*))
+
 (defun datastore-log (list)
-  (when (and (boundp '*datastore*) *datastore*)
+  (when (datastore-open-p)
     (with-standard-io-syntax
       (format *datastore* "~S~&" list))
     (force-output *datastore*)))
 
-(defvar *datastore-id-max* 0)
-
 (defun datastore-id-next ()
   *datastore-id-max*)
 (defun datastore-id-register (id)
@@ -65,11 +78,19 @@
   (make-load-form object))
 (defmethod datastore-save-form ((string string))
   string)
+(defmethod datastore-save-form ((number number))
+  number)
 
 (defmethod datastore-save-form ((array array))
-  `(make-array ',(array-dimensions array)
-	       :element-type ',(array-element-type array)
-	       :initial-contents (list ,@(map 'list 'datastore-save-form array))))
+  (typecase array
+    (byte-vector
+     `(utf8-encode ,(force-string array)))
+    (t
+     `(make-array ',(array-dimensions array)
+		  :element-type ',(array-element-type array)
+		  :initial-contents (list ,@(map 'list 'datastore-save-form array))))))
+
+(defgeneric datastore-record-constructor-form (object))
 
 (defmacro defrecord (name &rest original-slot-defs)
   (labels ((slot-name (slot-def)
@@ -164,6 +185,15 @@
 		  do (incf i (length v))
 		  append v)))
 
+	(defmethod datastore-record-constructor-form ((object ,name))
+	  (list ',(guarded-constructor) 
+		,@(loop for slot-def in slot-defs
+			for slot-name = (slot-name slot-def)
+			unless (eq 'datastore-id slot-name)
+			collect (intern (symbol-name slot-name) :keyword)
+			and
+			collect `(datastore-save-form (,(real-slot-accessor slot-name) object)))))
+
 
 	,@(loop for slot-def in indexed-slots collect
 		`(defmethod datastore-retrieve-indexed ((class (eql ',name)) (index (eql ',(slot-name slot-def))) value)

diff --git a/src/packages.lisp b/src/packages.lisp
@@ -364,6 +364,8 @@
    #:datastore-retrieve-all
    #:datastore-retrieve-indexed
    #:datastore-retrieve-unique
+   #:datastore-record-constructor-form
+   #:datastore-close
    #:defrecord
    #:datastore-use-file))
 

diff --git a/teepeedee2.asd b/teepeedee2.asd
@@ -19,7 +19,6 @@
   (proclaim '(optimize debug))
   (pushnew :tpd2-debug-assert *features*))
 
-
 (asdf:defsystem :teepeedee2
   :name "teepeedee2"
   :author "John Fremlin <[email protected]>"