Coverage report: /home/runner/work/geb/geb/src/mixins/meta.lisp

KindCoveredAll%
expression4048 83.3
branch12 50.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 (in-package :geb.mixins)
2
 
3
 (defclass meta-mixin ()
4
   ((metadata :initform (tg:make-weak-hash-table :test 'eq :weakness :key)
5
              :allocation :class
6
              :accessor meta))
7
   (:documentation
8
    "Use my service if you want to have metadata capabilities associated
9
 with the given object. @MIXIN-PERFORMANCE covers my performance
10
 characteristics"))
11
 
12
 (-> meta-insert (meta-mixin t t &key (:weak t)) t)
13
 (defun meta-insert (object key value &key weak)
14
   "Inserts a value into storage. If the key is a one time object, then
15
 the insertion is considered to be volatile, which can be reclaimed
16
 when no more references to the data exists.
17
 
18
 If the data is however a constant like a string, then the insertion is
19
 considered to be long lived and will always be accessible
20
 
21
 The :weak keyword specifies if the pointer stored in the value is weak"
22
   (let ((hash (or (gethash object (meta object))
23
                   (setf (gethash object (meta object))
24
                         (tg:make-weak-hash-table :test 'equalp
25
                                                  :weakness :key)))))
26
     (setf (gethash key hash)
27
           (if weak (tg:make-weak-pointer value) value))))
28
 
29
 (-> meta-lookup (meta-mixin t) (values t boolean))
30
 (defun meta-lookup (object key)
31
   "Lookups the requested key in the metadata table of the object. We
32
 look past weak pointers if they exist"
33
   (let ((table (gethash object (meta object))))
34
     (when table
35
       (multiple-value-bind (value in-there) (gethash key table)
36
         (values (if (tg:weak-pointer-p value) (tg:weak-pointer-value value) value)
37
                 in-there)))))
38
 
39
 ;; We need a custom copy for the meta-object
40
 
41
 (defmethod geb.utils:copy-instance ((object meta-mixin) &rest initargs
42
                                     &key &allow-other-keys)
43
   (declare (ignorable initargs))
44
   (let ((new-object (call-next-method))
45
         (table      (gethash object (meta object))))
46
     (when table
47
       (setf (gethash new-object (meta object)) ; should point to the same table
48
             table))
49
     new-object))