Commit 764f45ea authored by  Hayley Patton's avatar Hayley Patton 🐢

I forgot to git pull again

parents f95dc740 63c83f34
......@@ -16,11 +16,7 @@
(define-codec integer
(lambda (number)
(format nil "~d" number))
(lambda (string)
(handler-case
(parse-integer string)
(condition ()
(error "not parseable")))))
#'parse-integer)
(define-codec boolean
(lambda (boolean)
......@@ -38,28 +34,20 @@
(define-codec base64
(lambda (string)
(with-output-to-string (output)
(encode-base64-bytes (string-to-octets string :external-format *encoding*)
output)))
(bytes->base64 (string-to-octets string :external-format *encoding*)))
(lambda (base64)
(with-input-from-string (input base64)
(octets-to-string (decode-base64-bytes input)
:external-format *encoding*))))
(octets-to-string (base64->bytes base64)
:external-format *encoding*)))
(define-codec base64-data
(lambda (vector)
(with-output-to-string (output)
(encode-base64-bytes vector output)))
(lambda (base64)
(with-input-from-string (input base64)
(decode-base64-bytes input))))
#'bytes->base64 #'base64->bytes)
(define-codec ref
(lambda (reference)
(check-type reference reference)
(format nil (reference-hash reference)))
(bytes->base64 (reference-hash reference)))
(lambda (string)
(make-instance 'reference :hash string)))
(make-instance 'reference :hash (base64->bytes string))))
(defun find-codec (name type)
(let ((codec-definition (gethash name *codecs*)))
......
......@@ -47,12 +47,13 @@ Providing the class option (:scripts script ...) will attach the initialisation
(netfarm-class-message-script class)
(eval script)))
;; The initialisation scripts of a class are the direct scripts of itself
;; and the scripts of its superscripts. This isn't very different to how
;; slots are inherited in CLOS.
;; and the scripts of its superscripts, with duplicates removed. This isn't
;; very different to how slots are inherited in CLOS.
(slot-value class 'scripts)
(append (netfarm-class-direct-scripts class)
(loop for class in (closer-mop:class-direct-superclasses class)
appending (netfarm-class-scripts class)))))
(remove-duplicates
(append (netfarm-class-direct-scripts class)
(loop for class in (closer-mop:class-direct-superclasses class)
appending (netfarm-class-scripts class))))))
(defmethod initialize-instance :after ((class netfarm-class) &key)
(force-script-data-evaluation class)
......@@ -73,6 +74,18 @@ Providing the class option (:scripts script ...) will attach the initialisation
(:method ((class netfarm-class))
(hash-object* (class->schema class))))
(defclass netfarm-slot (closer-mop:standard-direct-slot-definition)
((computed :initarg :computed :initform nil)
(documentation :initarg :documentation
:reader slot-documentation)
(netfarm-name :initarg :netfarm-name
:reader slot-netfarm-name)))
(defmethod print-object ((slot netfarm-slot) stream)
(print-unreadable-object (slot stream :type t)
(format stream "~s" (slot-netfarm-name slot))))
(defclass netfarm-computed-slot (netfarm-slot)
())
(defclass object ()
((metadata :initarg :metadata :initform (make-hash-table :test 'equal)
:reader object-metadata)
......
......@@ -151,4 +151,3 @@ string; but RENDER-OBJECT will emit Netfarm standard format text."))
(:method ((vector vector) stream)
(write-string "base64-data:" stream)
(s-base64:encode-base64-bytes vector stream nil)))
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment