bknr-cvs

bknr-cvs@common-lisp.net

1964 discussions

[bknr-cvs] hans changed trunk/
by BKNR Commits 12 Nov '08

12 Nov '08

Revision: 4036 Author: hans URL: http://bknr.net/trac/changeset/4036 Add new libraries/ subdirectory to contain self-contained libraries. D trunk/ccl-profiler/ D trunk/clixdoc/ A trunk/libraries/ A trunk/libraries/ccl-profiler/ A trunk/libraries/clixdoc/ A trunk/libraries/xhtmlgen/ D trunk/xhtmlgen/ Copied: trunk/libraries/ccl-profiler (from rev 4023, trunk/ccl-profiler) Copied: trunk/libraries/clixdoc (from rev 4023, trunk/clixdoc) Copied: trunk/libraries/xhtmlgen (from rev 4023, trunk/xhtmlgen)

1 0

[bknr-cvs] hans changed trunk/
by BKNR Commits 12 Nov '08

12 Nov '08

Revision: 4035 Author: hans URL: http://bknr.net/trac/changeset/4035 Save work before extracting JSON library into a separate package. U trunk/bknr/datastore/src/bknr.datastore.asd U trunk/bknr/datastore/src/data/json.lisp U trunk/bknr/web/src/bknr.web.asd U trunk/bknr/web/src/packages.lisp U trunk/bknr/web/src/web/web-utils.lisp U trunk/projects/bos/web/poi-handlers.lisp U trunk/projects/quickhoney/src/handlers.lisp U trunk/projects/quickhoney/src/json-parser.lisp U trunk/projects/quickhoney/src/json.lisp U trunk/projects/quickhoney/src/packages.lisp U trunk/projects/quickhoney/website/static/index.css U trunk/projects/quickhoney/website/static/javascript.js U trunk/projects/quickhoney/website/templates/index.xml U trunk/projects/scrabble/src/scrabble.asd Change set too large, please see URL above

1 0

[bknr-cvs] hans changed trunk/thirdparty/cl-json/
by BKNR Commits 12 Nov '08

12 Nov '08

Revision: 4034 Author: hans URL: http://bknr.net/trac/changeset/4034 remove cl-json D trunk/thirdparty/cl-json/

1 0

[bknr-cvs] hans changed trunk/projects/quickhoney/src/
by BKNR Commits 11 Nov '08

11 Nov '08

Revision: 4033 Author: hans URL: http://bknr.net/trac/changeset/4033 add simple json parser A trunk/projects/quickhoney/src/json-parser.lisp U trunk/projects/quickhoney/src/json.lisp U trunk/projects/quickhoney/src/packages.lisp Added: trunk/projects/quickhoney/src/json-parser.lisp =================================================================== --- trunk/projects/quickhoney/src/json-parser.lisp (rev 0) +++ trunk/projects/quickhoney/src/json-parser.lisp 2008-11-11 13:27:30 UTC (rev 4033) @@ -0,0 +1,145 @@ +(in-package :json-parser) + +(defconstant +default-string-length+ 20 + "Default length of strings that are created while reading json input.") + +(defvar *parse-object-key-fn* #'identity + "Function to call to convert a key string in a JSON array to a key in the CL hash produced.") + +(defun make-adjustable-string () + "Return an adjustable empty string, usable as a buffer for parsing strings and numbers." + (make-array +default-string-length+ + :adjustable t :fill-pointer 0 :element-type 'character)) + +(defun parse-number (input) + ;; would be + ;; (cl-ppcre:scan-to-strings "^-?(?:0|[1-9][0-9]*)(?:\\.[0-9]+|)(?:[eE][-+]?[0-9]+|)" buffer) + ;; but we want to operate on streams + (let ((buffer (make-adjustable-string))) + (loop + while (position (peek-char nil input nil) ".0123456789+-Ee") + do (vector-push-extend (read-char input) buffer)) + (values (read-from-string buffer)))) + +(defun parse-string (input) + (let ((output (make-adjustable-string))) + (labels ((outc (c) + (vector-push-extend c output)) + (next () + (read-char input)) + (peek () + (peek-char nil input))) + (next) + (loop + (cond + ((eql (peek) #\") + (next) + (return-from parse-string output)) + ((eql (peek) #\\) + (next) + (ecase (next) + (#\" (outc #\")) + (#\\ (outc #\\)) + (#\/ (outc #\/)) + (#\b (outc #\Backspace)) + (#\f (outc #\Page)) + (#\n (outc #\Newline)) + (#\r (outc #\Return)) + (#\t (outc #\Tab)) + (#\u (outc (code-char (let ((buffer (make-string 4))) + (read-sequence buffer input) + (parse-integer buffer :radix 16))))))) + (t + (outc (next)))))))) + +(defun whitespace-p (char) + (member char '(#\Space #\Newline #\Tab #\Linefeed))) + +(defun skip-whitespace (input) + (loop + while (and (listen input) + (whitespace-p (peek-char nil input))) + do (read-char input))) + +(defun peek-char-skipping-whitespace (input &optional (eof-error-p t)) + (skip-whitespace input) + (peek-char nil input eof-error-p)) + +(defun parse-constant (input) + (destructuring-bind (expected-string return-value) + (find (peek-char nil input nil) + '(("true" t) + ("false" nil) + ("null" nil)) + :key (lambda (entry) (aref (car entry) 0)) + :test #'eql) + (loop + for char across expected-string + unless (eql (read-char input nil) char) + do (error "invalid constant")) + return-value)) + +(define-condition cannot-convert-key (error) + ((key-string :initarg :key-string + :reader key-string)) + (:report (lambda (c stream) + (format stream "cannot convert key ~S used in JSON object to hash table key" + (key-string c))))) + +(defun parse-object (input) + (let ((return-value (make-hash-table :test #'equal))) + (read-char input) + (loop + (when (eql (peek-char-skipping-whitespace input) + #\}) + (return)) + (skip-whitespace input) + (setf (gethash (prog1 + (let ((key-string (parse-string input))) + (or (funcall *parse-object-key-fn* key-string) + (error 'cannot-convert-key :key-string key-string))) + (skip-whitespace input) + (unless (eql #\: (read-char input)) + (error 'expected-colon)) + (skip-whitespace input)) + return-value) + (parse input)) + (ecase (peek-char-skipping-whitespace input) + (#\, (read-char input)) + (#\} nil))) + (read-char input) + return-value)) + +(defconstant +initial-array-size+ 20 + "Initial size of JSON arrays read, they will grow as needed.") + +(defun parse-array (input) + (let ((return-value (make-array +initial-array-size+ :adjustable t :fill-pointer 0))) + (read-char input) + (loop + (when (eql (peek-char-skipping-whitespace input) + #\]) + (return)) + (vector-push-extend (parse input) return-value) + (ecase (peek-char-skipping-whitespace input) + (#\, (read-char input)) + (#\] nil))) + (read-char input) + return-value)) + +(defgeneric parse (input) + (:method ((input stream)) + (ecase (peek-char-skipping-whitespace input) + (#\" + (parse-string input)) + ((#\- #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) + (parse-number input)) + (#\{ + (parse-object input)) + (#\[ + (parse-array input)) + ((#\t #\f #\n) + (parse-constant input)))) + (:method ((input string)) + (parse (make-string-input-stream input)))) + Modified: trunk/projects/quickhoney/src/json.lisp =================================================================== --- trunk/projects/quickhoney/src/json.lisp 2008-11-10 10:07:00 UTC (rev 4032) +++ trunk/projects/quickhoney/src/json.lisp 2008-11-11 13:27:30 UTC (rev 4033) @@ -65,3 +65,4 @@ (with-json-output-to-string () (with-json-object () ,@body)))) + Modified: trunk/projects/quickhoney/src/packages.lisp =================================================================== --- trunk/projects/quickhoney/src/packages.lisp 2008-11-10 10:07:00 UTC (rev 4032) +++ trunk/projects/quickhoney/src/packages.lisp 2008-11-11 13:27:30 UTC (rev 4033) @@ -87,4 +87,9 @@ (defpackage :twitter (:use :cl :bknr.datastore) - (:export #:update-status)) \ No newline at end of file + (:export #:update-status)) + +(defpackage :json-parser + (:use :cl) + (:export #:parse + #:*parse-object-key-fn*)) \ No newline at end of file

1 0

[bknr-cvs] hans changed trunk/thirdparty/cl-gd-0.5.6/colors.lisp
by BKNR Commits 10 Nov '08

10 Nov '08

Revision: 4032 Author: hans URL: http://bknr.net/trac/changeset/4032 revert previous change U trunk/thirdparty/cl-gd-0.5.6/colors.lisp Modified: trunk/thirdparty/cl-gd-0.5.6/colors.lisp =================================================================== --- trunk/thirdparty/cl-gd-0.5.6/colors.lisp 2008-11-10 10:05:14 UTC (rev 4031) +++ trunk/thirdparty/cl-gd-0.5.6/colors.lisp 2008-11-10 10:07:00 UTC (rev 4032) @@ -200,7 +200,7 @@ (check-type image image) (not (zerop (get-slot-value (img image) 'gd-image 'save-alpha-flag)))) -(defun (setf save-alpha-p) (save &optional (image *default-image*)) +(defun (setf save-alpha-p) (save &key (image *default-image*)) "Determines whether PNG images will be saved with full alpha channel information." (check-type image image)

1 0

[bknr-cvs] hans changed trunk/thirdparty/cl-gd-0.5.6/colors.lisp
by BKNR Commits 10 Nov '08

10 Nov '08

Revision: 4031 Author: hans URL: http://bknr.net/trac/changeset/4031 make save-alpha-p and (setf save-alpha-p) orthogonal U trunk/thirdparty/cl-gd-0.5.6/colors.lisp Modified: trunk/thirdparty/cl-gd-0.5.6/colors.lisp =================================================================== --- trunk/thirdparty/cl-gd-0.5.6/colors.lisp 2008-11-10 09:39:19 UTC (rev 4030) +++ trunk/thirdparty/cl-gd-0.5.6/colors.lisp 2008-11-10 10:05:14 UTC (rev 4031) @@ -200,7 +200,7 @@ (check-type image image) (not (zerop (get-slot-value (img image) 'gd-image 'save-alpha-flag)))) -(defun (setf save-alpha-p) (save &key (image *default-image*)) +(defun (setf save-alpha-p) (save &optional (image *default-image*)) "Determines whether PNG images will be saved with full alpha channel information." (check-type image image)

1 0

[bknr-cvs] hans changed trunk/bknr/web/src/images/image.lisp
by BKNR Commits 10 Nov '08

10 Nov '08

Revision: 4030 Author: hans URL: http://bknr.net/trac/changeset/4030 Always create jpeg images with maximum quality. U trunk/bknr/web/src/images/image.lisp Modified: trunk/bknr/web/src/images/image.lisp =================================================================== --- trunk/bknr/web/src/images/image.lisp 2008-11-10 09:38:22 UTC (rev 4029) +++ trunk/bknr/web/src/images/image.lisp 2008-11-10 09:39:19 UTC (rev 4030) @@ -82,9 +82,12 @@ initargs))) (ensure-directories-exist (blob-pathname store-image)) (ignore-errors (delete-file (blob-pathname store-image))) - (cl-gd:write-image-to-file (blob-pathname store-image) - :image image - :type type) + (apply #'cl-gd:write-image-to-file + (blob-pathname store-image) + :image image + :type type + (when (eq type :jpg) + (list :quality 95))) store-image)) (defmacro with-store-image-from-id ((var id) &rest body)

1 0

[bknr-cvs] hans changed trunk/projects/quickhoney/src/handlers.lisp
by BKNR Commits 10 Nov '08

10 Nov '08

Revision: 4029 Author: hans URL: http://bknr.net/trac/changeset/4029 Improve image quality for uploaded jpg images. U trunk/projects/quickhoney/src/handlers.lisp Modified: trunk/projects/quickhoney/src/handlers.lisp =================================================================== --- trunk/projects/quickhoney/src/handlers.lisp 2008-11-10 08:39:46 UTC (rev 4028) +++ trunk/projects/quickhoney/src/handlers.lisp 2008-11-10 09:38:22 UTC (rev 4029) @@ -303,7 +303,8 @@ (defun maybe-convert-to-palette (&optional (image cl-gd:*default-image*)) (when (and (cl-gd:true-color-p image) (<= (count-colors-used image) 256)) - (cl-gd:true-color-to-palette :image image))) + (cl-gd:true-color-to-palette :image image) + t)) (defmethod handle ((handler upload-image-handler)) (with-query-params (client spider-keywords) @@ -322,7 +323,8 @@ :class-name 'quickhoney-image :keywords (cons :upload (image-keywords-from-request-parameters)) :initargs (list :owner (bknr-session-user) - :cat-sub (mapcar #'make-keyword-from-string (decoded-handler-path handler)) + :cat-sub (mapcar #'make-keyword-from-string + (decoded-handler-path handler)) :client client :spider-keywords spider-keywords)))) (with-http-response () @@ -367,47 +369,49 @@ (defmethod handle ((handler upload-news-handler)) (with-query-params (title text) - (let ((uploaded-file (request-uploaded-file "image-file"))) + (let ((uploaded-file (or (request-uploaded-file "image-file")))) + (unless uploaded-file + (error "no file uploaded")) (handler-case - (progn - (unless uploaded-file - (error "no file uploaded")) - (with-image-from-upload (uploaded-image uploaded-file) - (maybe-convert-to-palette uploaded-image) - (when (> (cl-gd:image-width uploaded-image) +news-image-width+) - (let* ((scaled-height (floor (* (/ +news-image-width+ (cl-gd:image-width uploaded-image)) - (cl-gd:image-height uploaded-image)))) - (scaled-image (cl-gd:create-image +news-image-width+ scaled-height (cl-gd:true-color-p uploaded-image)))) - (cl-gd:copy-image uploaded-image scaled-image - 0 0 0 0 - (cl-gd:image-width uploaded-image) (cl-gd:image-height uploaded-image) - :resample t :resize t - :dest-width +news-image-width+ :dest-height scaled-height) - (cl-gd:destroy-image uploaded-image) - (setf uploaded-image scaled-image))) - (let* ((name (normalize-news-title title)) - (item (make-store-image :name name - :image uploaded-image - :type (if (cl-gd:true-color-p uploaded-image) :jpg :png) - :class-name 'quickhoney-news-item - :keywords (list :upload) - :initargs (list :cat-sub (list :news) - :title title - :text text - :owner (bknr-session-user))))) - (declare (ignore item)) ; for now - (twitter:update-status (bknr-session-user) - (format nil "Posted news item: http://quickhoney.com/news/~A" name)) - (with-http-response () - (with-http-body () - (html (:html - (:head - (:title "News article created") - ((:script :type "text/javascript" :language "JavaScript") - "function done() { window.opener.reload_news(); window.close(); }")) - (:body - (:p "News article created") - (:p ((:a :href "javascript:done()") "ok")))))))))) + (with-image-from-upload (uploaded-image uploaded-file) + (let* ((processed (when (> (cl-gd:image-width uploaded-image) +news-image-width+) + (let* ((scaled-height (floor (* (/ +news-image-width+ (cl-gd:image-width uploaded-image)) + (cl-gd:image-height uploaded-image)))) + (scaled-image (cl-gd:create-image +news-image-width+ scaled-height + (cl-gd:true-color-p uploaded-image)))) + (cl-gd:copy-image uploaded-image scaled-image + 0 0 0 0 + (cl-gd:image-width uploaded-image) (cl-gd:image-height uploaded-image) + :resample t :resize t + :dest-width +news-image-width+ :dest-height scaled-height) + (cl-gd:destroy-image uploaded-image) + (setf uploaded-image scaled-image)) + t)) + (name (normalize-news-title title)) + (args (list :name name + :type (if (cl-gd:true-color-p uploaded-image) :jpg :png) + :class-name 'quickhoney-news-item + :keywords (list :upload) + :initargs (list :cat-sub (list :news) + :title title + :text text + :owner (bknr-session-user)))) + (item (if processed + (apply #'make-store-image :image uploaded-image args) + (apply #'import-image (upload-pathname uploaded-file) args)))) + (declare (ignore item)) ; for now + (twitter:update-status (bknr-session-user) + (format nil "Posted news item: http://quickhoney.com/news/~A" name)) + (with-http-response () + (with-http-body () + (html (:html + (:head + (:title "News article created") + ((:script :type "text/javascript" :language "JavaScript") + "function done() { window.opener.reload_news(); window.close(); }")) + (:body + (:p "News article created") + (:p ((:a :href "javascript:done()") "ok"))))))))) (error (e) (with-http-response () (with-http-body ()

1 0

[bknr-cvs] hans changed trunk/bknr/web/src/web/tags.lisp
by BKNR Commits 10 Nov '08

10 Nov '08

Revision: 4028 Author: hans URL: http://bknr.net/trac/changeset/4028 Comment out code to avoid a "deleting unreachable code" warning U trunk/bknr/web/src/web/tags.lisp Modified: trunk/bknr/web/src/web/tags.lisp =================================================================== --- trunk/bknr/web/src/web/tags.lisp 2008-11-10 08:27:59 UTC (rev 4027) +++ trunk/bknr/web/src/web/tags.lisp 2008-11-10 08:39:46 UTC (rev 4028) @@ -114,6 +114,7 @@ (defun user-template-prefix () (error 'wtf) + #+(or) (user-preference (bknr-session-user) :template-path-prefix "file:///Volumes/web/template/")) ;; xxx new templater

1 0

[bknr-cvs] hans changed trunk/projects/quickhoney/src/
by BKNR Commits 10 Nov '08

10 Nov '08

Revision: 4027 Author: hans URL: http://bknr.net/trac/changeset/4027 work on shopping system U trunk/projects/quickhoney/src/packages.lisp U trunk/projects/quickhoney/src/quickhoney.asd U trunk/projects/quickhoney/src/shop.lisp Modified: trunk/projects/quickhoney/src/packages.lisp =================================================================== --- trunk/projects/quickhoney/src/packages.lisp 2008-11-10 08:25:02 UTC (rev 4026) +++ trunk/projects/quickhoney/src/packages.lisp 2008-11-10 08:27:59 UTC (rev 4027) @@ -21,7 +21,16 @@ (:use :cl :bknr.datastore :bknr.indices - :bknr.user)) + :bknr.user) + (:export #:download-product + #:emailable-product + #:mailable-product + #:product-stock-count + #:shopping-cart + #:put-to-cart + #:insufficient-inventory + #:product-already-in-shopping-cart + #:fulfill)) (defpackage :quickhoney (:use :cl Modified: trunk/projects/quickhoney/src/quickhoney.asd =================================================================== --- trunk/projects/quickhoney/src/quickhoney.asd 2008-11-10 08:25:02 UTC (rev 4026) +++ trunk/projects/quickhoney/src/quickhoney.asd 2008-11-10 08:27:59 UTC (rev 4027) @@ -24,7 +24,8 @@ :bknr.web :bknr.datastore :bknr.modules - :cl-gd) + :cl-gd + :unit-test) :components ((:file "packages") (:file "config" :depends-on ("packages")) Modified: trunk/projects/quickhoney/src/shop.lisp =================================================================== --- trunk/projects/quickhoney/src/shop.lisp 2008-11-10 08:25:02 UTC (rev 4026) +++ trunk/projects/quickhoney/src/shop.lisp 2008-11-10 08:27:59 UTC (rev 4027) @@ -28,7 +28,6 @@ :update :type string :index-type string-unique-index - :index-reader product-with-name :documentation "Short name of the product, must be unique, should be identifier") (description @@ -41,10 +40,13 @@ (:documentation "Sell PRODUCT, adjusting the stock count if needed. Returns the product sold.")) -(defgeneric stock-count (product) +(defgeneric product-stock-count (product) (:documentation "Return the number of instances of PRODUCT available, or NIL if the - product can be sold in infinite amounts.")) + product can be sold in infinite amounts.") + (:method (product) + "By default, assume infinite supply" + nil)) (define-persistent-class download-product (product) () @@ -54,9 +56,6 @@ address. Once paid, the system makes the product available to the customer for download.")) -(defmethod stock-count ((product download-product)) - nil) - (define-persistent-class emailable-product (product) () (:documentation @@ -65,20 +64,40 @@ be supplied by the customer. Once paid, the system sends the order to the store personnel for fulfillment.")) -(defmethod stock-count ((product emailable-product)) - nil) - (define-persistent-class mailable-product (product) ((stock-count :update :type integer - :accessor stock-count + :accessor product-stock-count :documentation - "Number of instances of this product that are available to be sold.")) + "Number of instances of this product that are + available to be sold, including reserved amounts in + shopping carts.") + (reserved-count :update + :type integer + :initform 0)) (:documentation "A product that is sent to the customer by regular mail \(i.e. a t-shirt or poster). Once paid, the system sends the order to the store personell for fulfillment.")) +(defgeneric available-p (product count) + (:documentation "Return a true value if COUNT units of PRODUCT are + currently available. Should be called with the store guard locked.") + (:method (product count) + (or (null (product-stock-count product)) + (<= count (product-stock-count product))))) + +(defmethod product-stock-count ((product mailable-product)) + "The available stock count for a mailable product is reduced by the reserved count and returned." + (- (slot-value product 'stock-count) + (mailable-product-reserved-count product))) + +(defmethod (setf product-stock-count) (newval (product mailable-product)) + "The available sock count for a mailable product is set to NEWVAL." + (when (< newval (mailable-product-reserved-count product)) + (error "cannot reduce the available stock count below the reserved count")) + (setf (slot-value product 'stock-count) newval)) + (define-persistent-class shipping-address () ((country :read)) (:documentation @@ -99,9 +118,28 @@ "List of shipping addresses with the preferred address being the CAR of the list."))) +(define-persistent-class number-generator () + ((name :read + :type symbol + :initform (error "cannot make number-generator instance without name") + :index-type string-unique-index + :index-reader number-generator-with-name) + (next :update + :type integer + :initarg :next + :initform 1))) + +(defun get-next-number (name) + (with-transaction (:get-next-number) + (let* ((number-generator (or (number-generator-with-name name) + (make-instance 'number-generator :name name))) + (number (number-generator-next number-generator))) + (incf (number-generator-next number-generator)) + number))) + (define-persistent-class order () ((number :read - :initform (make-order-number)) + :initform (get-next-number 'orders)) (customer :read) (items :update))) @@ -112,6 +150,161 @@ (define-persistent-class invoice () ((number :read - :initform (make-invoice-number)) + :initform (get-next-number 'invoices)) (items :update))) +(define-persistent-class lease () + ((product :read + :initform (error "missing :product initarg to lease creation") + :documentation "product that has been leased") + (count :read + :initform (error "missing :count initarg to lease creation") + :documentation "number of units of product held by this lease") + (fulfilled :update + :initform nil + :documentation "Set to a true value when the lease has + been fulfilled. Used during lease descruction in order + to determine whether to return the leased inventory to + the product stock.")) + (:documentation "Instance representing a lease for a product.")) + +(defgeneric update-reserved-stock (product count) + (:documentation "Update the reserved counter of PRODUCT by COUNT units") + (:method (product count) + (declare (ignore product count)))) + +(defgeneric note-sale (product count) + (:documentation "Update the stock count of the PRODUCT by COUNT + units after a sale has been done") + (:method (product count) + (declare (ignore product count)))) + +(defmethod initialize-instance :after ((lease lease) &key) + (update-reserved-stock (lease-product lease) (lease-count lease))) + +(defmethod destroy-object :before ((lease lease)) + (unless (lease-fulfilled lease) + (update-reserved-stock (lease-product lease) (- (lease-count lease))))) + +(defmethod update-reserved-stock ((product mailable-product) count) + (incf (mailable-product-reserved-count product) count)) + +(defmethod note-sale ((product mailable-product) count) + (decf (slot-value product 'stock-count) count) + (update-reserved-stock product (- count))) + +(define-persistent-class shopping-cart () + ((leases :update + :initform nil) + (expires :read + :initform (error "missing :expires initarg to shopping cart creation") + :documentation "universal time at which this shopping cart expires")) + (:documentation "Represents the intent to buy goods, in the form of LEASE objects")) + +(defmethod destroy-object :before ((shopping-cart shopping-cart)) + (mapc #'delete-object (shopping-cart-leases shopping-cart))) + +(define-condition insufficient-inventory (error) + ((product :initarg :product + :reader product) + (requested :initarg :requested + :reader requested) + (available :initarg :available + :reader available)) + (:report (lambda (c stream) + (format stream "Insufficient inventory for product ~A - Requested ~A, but~[~; only~]~:* ~A available" + (product c) (requested c) (available c)) + c))) + +(define-condition product-already-in-shopping-cart (error) + ((product :initarg :product + :reader product)) + (:report (lambda (c stream) + (format stream "Product ~A is already in shopping cart" + (product c))))) + +(defun put-to-shopping-cart (count product shopping-cart) + "Reserve COUNT units of PRODUCT, signalling a INSUFFICIENT-INVENTORY + error if not enough inventory of PRODUCT is available. Returns a + LEASE object." + (with-store-guard () + (unless (available-p product count) + (error 'insufficient-inventory + :product product + :requested count + :available (product-stock-count product))) + (when (find product (shopping-cart-leases shopping-cart) + :key #'lease-product) + (error 'product-already-in-shopping-cart + :product product)) + (with-transaction (:make-lease) + (push (make-instance 'lease + :product product + :count count) + (shopping-cart-leases shopping-cart))))) + +(defun fulfill (shopping-cart) + "Fulfill the given shopping cart." + (with-transaction (:fulfill) + (dolist (lease (shopping-cart-leases shopping-cart)) + (let ((product (lease-product lease)) + (count (lease-count lease))) + (setf (lease-fulfilled lease) t) + (note-sale product count))) + (delete-object shopping-cart))) + +;;; TESTING + +(defmacro with-temporary-directory ((pathname) &body body) + `(let ((,pathname (pathname (format nil "/tmp/store-test-~A/" (sb-posix:getpid))))) + (asdf:run-shell-command "rm -rf ~A" ,pathname) + (prog1 + (progn ,@body) + (asdf:run-shell-command "rm -rf ~A" ,pathname)))) + +(defun do-with-test-store (thunk) + (when (and (boundp '*store*) *store*) + (warn "closing open store *store* to run tests") + (close-store)) + (with-temporary-directory (store-directory) + (make-instance 'mp-store + :subsystems (list (make-instance 'store-object-subsystem)) + :directory store-directory) + (funcall thunk) + (close-store))) + +(defmacro with-test-store (() &body body) + `(do-with-test-store (lambda () ,@body))) + +(unit-test:deftest :shop "lease and cart tests" + (with-test-store () + (let* ((t-shirt (make-instance 'mailable-product :name 't-shirt :stock-count 10)) + (file (make-instance 'download-product :name 'file)) + (shopping-cart (make-instance 'shopping-cart :expires (+ (* 60 10) (get-universal-time))))) + (unit-test:test-equal 10 (product-stock-count t-shirt)) + (put-to-shopping-cart 10 t-shirt shopping-cart) + (unit-test:test-equal 0 (product-stock-count t-shirt)) + (unit-test:test-assert (product-stock-count t-shirt)) + (with-transaction (:add-to-inventory) + (incf (slot-value t-shirt 'stock-count) 10)) + (put-to-shopping-cart 5 t-shirt shopping-cart) + (unit-test:test-equal 5 (product-stock-count t-shirt)) + (delete-object shopping-cart) + (unit-test:test-equal 20 (product-stock-count t-shirt)) + (setf shopping-cart (make-instance 'shopping-cart :expires (+ (* 60 10) (get-universal-time)))) + (put-to-shopping-cart 5 t-shirt shopping-cart) + (put-to-shopping-cart 500 file shopping-cart) + (unit-test:test-equal 15 (product-stock-count t-shirt))))) + +(unit-test:deftest :shop "fulfill test" + (with-test-store () + (let* ((t-shirt (make-instance 'mailable-product :name 't-shirt :stock-count 10)) + (file (make-instance 'download-product :name 'file)) + (shopping-cart (make-instance 'shopping-cart :expires (+ (* 60 10) (get-universal-time))))) + (put-to-shopping-cart 3 t-shirt shopping-cart) + (put-to-shopping-cart 7 file shopping-cart) + (fulfill shopping-cart) + (unit-test:test-equal 7 (product-stock-count t-shirt)) + (unit-test:test-equal 0 (length (class-instances 'shopping-cart))) + (unit-test:test-equal 0 (length (class-instances 'lease))) + (unit-test:test-equal 0 (mailable-product-reserved-count t-shirt))))) \ No newline at end of file

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

bknr-cvs