Implement a custom error condition for SQLite.
[cl-sqlite.git] / cache.lisp
blob967327f09c1c504b0ea26171cf8e0d004cecffbe
1 (defpackage :sqlite.cache
2 (:use :cl :iter)
3 (:export :mru-cache
4 :get-from-cache
5 :put-to-cache
6 :purge-cache))
8 (in-package :sqlite.cache)
10 ;(declaim (optimize (speed 3) (safety 0) (debug 0)))
12 (defclass mru-cache ()
13 ((objects-table :accessor objects-table :initform (make-hash-table :test 'equal))
14 (last-access-time-table :accessor last-access-time-table :initform (make-hash-table :test 'equal))
15 (total-cached :type fixnum :accessor total-cached :initform 0)
16 (cache-size :type fixnum :accessor cache-size :initarg :cache-size :initform 100)
17 (destructor :accessor destructor :initarg :destructor :initform #'identity)))
19 (defun get-from-cache (cache id)
20 (let ((available-objects-stack (gethash id (objects-table cache))))
21 (when (and available-objects-stack (> (length (the vector available-objects-stack)) 0))
22 (decf (the fixnum (total-cached cache)))
23 (setf (gethash id (last-access-time-table cache)) (get-internal-run-time))
24 (vector-pop (the vector available-objects-stack)))))
26 (defun remove-empty-objects-stacks (cache)
27 (let ((table (objects-table cache)))
28 (maphash (lambda (key value)
29 (declare (type vector value))
30 (when (zerop (length value))
31 (remhash key table)
32 (remhash key (last-access-time-table cache))))
33 table)))
35 (defun pop-from-cache (cache)
36 (let ((id (iter (for (id time) in-hashtable (last-access-time-table cache))
37 (when (not (zerop (length (the vector (gethash id (objects-table cache))))))
38 (finding id minimizing (the fixnum time))))))
39 (let ((object (vector-pop (gethash id (objects-table cache)))))
40 (funcall (destructor cache) object)))
41 (remove-empty-objects-stacks cache)
42 (decf (the fixnum (total-cached cache))))
44 (defun put-to-cache (cache id object)
45 (when (>= (the fixnum (total-cached cache)) (the fixnum (cache-size cache)))
46 (pop-from-cache cache))
47 (let ((available-objects-stack (or (gethash id (objects-table cache))
48 (setf (gethash id (objects-table cache)) (make-array 0 :adjustable t :fill-pointer t)))))
49 (vector-push-extend object available-objects-stack)
50 (setf (gethash id (last-access-time-table cache)) (get-internal-run-time))
51 (incf (the fixnum (total-cached cache)))
52 object))
54 (defun purge-cache (cache)
55 (iter (for (id items) in-hashtable (objects-table cache))
56 (when items
57 (iter (for item in-vector (the vector items))
58 (funcall (destructor cache) item)))))