November 2008 - bknr-cvs@common-lisp.net - mailman3.common-lisp.net

[bknr-cvs] hans changed trunk/build.lisp
by BKNR Commits 13 Nov '08

13 Nov '08

Revision: 4042 Author: hans URL: http://bknr.net/trac/changeset/4042 Remove cl-json from buildbot build list U trunk/build.lisp Modified: trunk/build.lisp =================================================================== --- trunk/build.lisp 2008-11-13 22:23:06 UTC (rev 4041) +++ trunk/build.lisp 2008-11-13 23:02:28 UTC (rev 4042) @@ -77,8 +77,6 @@ :html-match.test :cl-gd-test :cl-ppcre-test - :cl-json - :cl-json.test :kmrcl-tests :flexi-streams :flexi-streams-test

1 0

[bknr-cvs] hans changed trunk/thirdparty/cffi/uffi-compat/uffi
by BKNR Commits 13 Nov '08

13 Nov '08

Revision: 4041 Author: hans URL: http://bknr.net/trac/changeset/4041 rename file as it confuses buildbot (?) A trunk/thirdparty/cffi/uffi-compat/uffi-compat.asd D trunk/thirdparty/cffi/uffi-compat/uffi.asd Copied: trunk/thirdparty/cffi/uffi-compat/uffi-compat.asd (from rev 4030, trunk/thirdparty/cffi/uffi-compat/uffi.asd) =================================================================== --- trunk/thirdparty/cffi/uffi-compat/uffi-compat.asd (rev 0) +++ trunk/thirdparty/cffi/uffi-compat/uffi-compat.asd 2008-11-13 22:23:06 UTC (rev 4041) @@ -0,0 +1,3 @@ +;;;; uffi.asd -*- Mode: Lisp -*- + +(defsystem uffi :depends-on (cffi-uffi-compat)) Deleted: trunk/thirdparty/cffi/uffi-compat/uffi.asd =================================================================== --- trunk/thirdparty/cffi/uffi-compat/uffi.asd 2008-11-12 11:19:32 UTC (rev 4040) +++ trunk/thirdparty/cffi/uffi-compat/uffi.asd 2008-11-13 22:23:06 UTC (rev 4041) @@ -1,3 +0,0 @@ -;;;; uffi.asd -*- Mode: Lisp -*- - -(defsystem uffi :depends-on (cffi-uffi-compat))

1 0

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

12 Nov '08

Revision: 4040 Author: hans URL: http://bknr.net/trac/changeset/4040 Fixes to make Quickhoney work with yason. Yason fixes to bknr-web. Make clixdoc compile. U trunk/bknr/web/src/web/web-utils.lisp U trunk/libraries/clixdoc/clixdoc.asd U trunk/libraries/clixdoc/edi-docutil.lisp U trunk/libraries/clixdoc/make-doc.lisp U trunk/projects/quickhoney/src/handlers.lisp Modified: trunk/bknr/web/src/web/web-utils.lisp =================================================================== --- trunk/bknr/web/src/web/web-utils.lisp 2008-11-12 11:00:57 UTC (rev 4039) +++ trunk/bknr/web/src/web/web-utils.lisp 2008-11-12 11:19:32 UTC (rev 4040) @@ -240,6 +240,6 @@ (defmacro with-json-response (() &body body) `(with-http-response (:content-type "application/json") - (with-output-to-string () + (json:with-output-to-string* () (json:with-object () ,@body)))) \ No newline at end of file Modified: trunk/libraries/clixdoc/clixdoc.asd =================================================================== --- trunk/libraries/clixdoc/clixdoc.asd 2008-11-12 11:00:57 UTC (rev 4039) +++ trunk/libraries/clixdoc/clixdoc.asd 2008-11-12 11:19:32 UTC (rev 4040) @@ -3,7 +3,6 @@ :depends-on (:cxml :swank :cl-ppcre) :serial t :components ((:file "packages") - (:file "specials") (:file "edi-docutil") (:file "check-doc") (:file "make-doc"))) \ No newline at end of file Modified: trunk/libraries/clixdoc/edi-docutil.lisp =================================================================== --- trunk/libraries/clixdoc/edi-docutil.lisp 2008-11-12 11:00:57 UTC (rev 4039) +++ trunk/libraries/clixdoc/edi-docutil.lisp 2008-11-12 11:19:32 UTC (rev 4040) @@ -32,6 +32,11 @@ (in-package "CLIXDOC") +(defvar *maybe-skip-methods-p* nil + "This is the default value for the :MAYBE-SKIP-METHODS-P keyword +argument of CREATE-TEMPLATE and its initial value is NIL. It is also +used internally.") + ;;; For the purpose of this file, an "entry" is a list of four or five ;;; symbols - a name, a keyword for the kind of the entry, a lambda ;;; list (for functions and macros), a documentation string, and Modified: trunk/libraries/clixdoc/make-doc.lisp =================================================================== --- trunk/libraries/clixdoc/make-doc.lisp 2008-11-12 11:00:57 UTC (rev 4039) +++ trunk/libraries/clixdoc/make-doc.lisp 2008-11-12 11:19:32 UTC (rev 4040) @@ -1,7 +1,8 @@ (in-package "CLIXDOC") +#+(or) (defun make-doc (package &optional (output *standard-output*)) (with-xml-output (make-character-stream-sink *output*) (with-namespace ("clix" "http://bknr.net/clixdoc") - (with-namespace ( \ No newline at end of file + (with-namespace ())))) \ No newline at end of file Modified: trunk/projects/quickhoney/src/handlers.lisp =================================================================== --- trunk/projects/quickhoney/src/handlers.lisp 2008-11-12 11:00:57 UTC (rev 4039) +++ trunk/projects/quickhoney/src/handlers.lisp 2008-11-12 11:19:32 UTC (rev 4040) @@ -45,34 +45,39 @@ () (:default-initargs :query-function #'store-image-with-name)) +(defmethod json:encode ((object symbol) stream) + (json:encode (string-downcase (symbol-name object)) + stream)) + (defmethod image-to-json ((image quickhoney-image)) (json:with-object () - (encode-object-element "class" (string-downcase (cl-ppcre:regex-replace "^QUICKHONEY-" - (symbol-name (class-name (class-of image))) - ""))) - (encode-object-element "name" (store-image-name image)) + (json:encode-object-element "class" + (string-downcase (cl-ppcre:regex-replace "^QUICKHONEY-" + (symbol-name (class-name (class-of image))) + ""))) + (json:encode-object-element "name" (store-image-name image)) (when (quickhoney-image-category image) - (encode-object-element "category" (quickhoney-image-category image)) + (json:encode-object-element "category" (quickhoney-image-category image)) (when (quickhoney-image-subcategory image) - (encode-object-element "subcategory" (quickhoney-image-subcategory image)))) - (encode-object-element "id" (store-object-id image)) - (encode-object-element "type" (image-content-type (blob-mime-type image))) - (encode-object-element "width" (store-image-width image)) - (encode-object-element "height" (store-image-height image)) - (encode-object-element "client" (or (quickhoney-image-client image) "")) + (json:encode-object-element "subcategory" (quickhoney-image-subcategory image)))) + (json:encode-object-element "id" (store-object-id image)) + (json:encode-object-element "type" (image-content-type (blob-mime-type image))) + (json:encode-object-element "width" (store-image-width image)) + (json:encode-object-element "height" (store-image-height image)) + (json:encode-object-element "client" (or (quickhoney-image-client image) "")) (when (typep image 'quickhoney-animation-image) - (encode-object-element "animation_type" + (json:encode-object-element "animation_type" (image-content-type (blob-mime-type (quickhoney-animation-image-animation image))))) (when (quickhoney-image-spider-keywords image) - (encode-object-element "spider_keywords" (quickhoney-image-spider-keywords image))) - (with-object-element ("keywords") + (json:encode-object-element "spider_keywords" (quickhoney-image-spider-keywords image))) + (json:with-object-element ("keywords") (json:with-object () (dolist (keyword (intersection *editable-keywords* (store-image-keywords image))) - (encode-object-element (string-downcase (symbol-name keyword)) t)))))) + (json:encode-object-element (string-downcase (symbol-name keyword)) t)))))) (defmethod handle-object ((handler json-image-info-handler) image) - (json:with-response () - (with-object-element ("image") + (with-json-response () + (json:with-object-element ("image") (image-to-json image)))) (defclass json-image-query-handler (object-handler quickhoney-image-dependent-handler) @@ -91,14 +96,14 @@ (json:with-array () (dolist (row (page-rows page)) (json:with-array () - (encode-array-element (row-cell-width row)) - (encode-array-element (row-cell-height row)) + (json:encode-array-element (row-cell-width row)) + (json:encode-array-element (row-cell-height row)) (dolist (image (row-images row)) (image-to-json image)))))))) (defmethod handle-object ((handler json-image-query-handler) images) - (json:with-response () - (with-object-element ("queryResult") + (with-json-response () + (json:with-object-element ("queryResult") (with-query-params (layout) (layout-to-json (make-instance (case (make-keyword-from-string layout) (:smallworld 'quickhoney-name-layout) @@ -109,40 +114,40 @@ ()) (defmethod handle ((handler json-login-handler)) - (json:with-response () - (encode-object-element "admin" (admin-p (bknr-session-user))) + (with-json-response () + (json:encode-object-element "admin" (admin-p (bknr-session-user))) (when (and (anonymous-p (bknr-session-user)) (query-param "__username")) - (encode-object-element "login_failed" t)) - (encode-object-element "login" (user-login (bknr-session-user))))) + (json:encode-object-element "login_failed" t)) + (json:encode-object-element "login" (user-login (bknr-session-user))))) (defclass json-logout-handler (page-handler) ()) (defmethod handle ((handler json-logout-handler)) (setf (session-value 'bknr-session) nil) - (json:with-response () - (encode-object-element "logged_out" t))) + (with-json-response () + (json:encode-object-element "logged_out" t))) (defclass json-clients-handler (page-handler) ()) (defmethod handle ((handler json-clients-handler)) - (json:with-response () - (with-object-element ("clients") + (with-json-response () + (json:with-object-element ("clients") (json:with-array () (dolist (client (sort (remove "" (all-clients) :test #'equal) #'string-lessp)) - (encode-array-element client)))))) + (json:encode-array-element client)))))) (defclass json-edit-image-handler (admin-only-handler edit-object-handler) () (:default-initargs :object-class 'quickhoney-image)) (defmethod handle-object-form ((handler json-edit-image-handler) action image) - (json:with-response () - (encode-object-element "result" "error") - (encode-object-element "message" (format nil "; invalid action ~A or invalid object ~A~%" action image)))) + (with-json-response () + (json:encode-object-element "result" "error") + (json:encode-object-element "message" (format nil "; invalid action ~A or invalid object ~A~%" action image)))) (defun image-keywords-from-request-parameters () (let (retval) @@ -159,14 +164,14 @@ (store-image-keywords image) (append (set-difference (store-image-keywords image) *editable-keywords*) (image-keywords-from-request-parameters))))) (setf *last-image-upload-timestamp* (get-universal-time)) - (json:with-response () - (encode-object-element "result" "edited"))) + (with-json-response () + (json:encode-object-element "result" "edited"))) (defmethod handle-object-form ((handler json-edit-image-handler) (action (eql :delete)) (image quickhoney-image)) (delete-object image) (setf *last-image-upload-timestamp* (get-universal-time)) - (json:with-response () - (encode-object-element "result" "deleted"))) + (with-json-response () + (json:encode-object-element "result" "deleted"))) (defclass json-edit-news-item-handler (json-edit-image-handler) () @@ -178,8 +183,8 @@ (setf (quickhoney-news-item-title item) title (quickhoney-news-item-text item) text))) (setf *last-image-upload-timestamp* (get-universal-time)) - (json:with-response () - (encode-object-element "result" "edited"))) + (with-json-response () + (json:encode-object-element "result" "edited"))) (defclass digg-image-handler (object-handler) () @@ -264,13 +269,13 @@ collect image))))) (defmethod handle ((handler json-buttons-handler)) - (json:with-response () - (with-object-element ("buttons") + (with-json-response () + (json:with-object-element ("buttons") (json:with-object () (loop for (category subcategories-string) on (decoded-handler-path handler) by #'cddr do (dolist (subcategory (split "," subcategories-string)) - (with-object-element ((format nil "~(~A/~A~)" category subcategory)) + (json:with-object-element ((format nil "~(~A/~A~)" category subcategory)) (json:with-array () ;; For each subcategory, an array of buttons is ;; generated. The first element of the array is @@ -286,10 +291,10 @@ (or (preproduced-buttons category subcategory) (newest-images category subcategory) (warn "No images for ~A ~A found" category subcategory)) - (encode-array-element type) + (json:encode-array-element type) (dolist (image (or images (list (store-image-with-name "button-dummy")))) - (encode-array-element (store-object-id image))))))))))))) + (json:encode-array-element (store-object-id image))))))))))))) (defclass upload-image-handler (admin-only-handler prefix-handler) ()) @@ -536,30 +541,30 @@ ; do nothing ) (:method :before ((item store-object)) - (encode-object-element "id" (store-object-id item))) + (json:encode-object-element "id" (store-object-id item))) (:method :before ((image quickhoney-image)) (when (owned-object-owner image) - (encode-object-element "owner" (user-login (owned-object-owner image)))) - (encode-object-element "date" (format-date-time (blob-timestamp image) :vms-style t :show-time nil)) - (encode-object-element "name" (store-image-name image))) + (json:encode-object-element "owner" (user-login (owned-object-owner image)))) + (json:encode-object-element "date" (format-date-time (blob-timestamp image) :vms-style t :show-time nil)) + (json:encode-object-element "name" (store-image-name image))) (:method ((image quickhoney-image)) - (encode-object-element "type" "upload") - (encode-object-element "category" (quickhoney-image-category image)) - (encode-object-element "subcategory" (quickhoney-image-subcategory image)) - (with-object-element ("keywords") + (json:encode-object-element "type" "upload") + (json:encode-object-element "category" (quickhoney-image-category image)) + (json:encode-object-element "subcategory" (quickhoney-image-subcategory image)) + (json:with-object-element ("keywords") (json:with-array () (dolist (keyword (store-image-keywords image)) - (encode-array-element (string-downcase (symbol-name keyword))))))) + (json:encode-array-element (string-downcase (symbol-name keyword))))))) (:method ((item quickhoney-news-item)) - (encode-object-element "type" "news") - (encode-object-element "title" (quickhoney-news-item-title item)) - (encode-object-element "text" (quickhoney-news-item-text item)) - (encode-object-element "width" (store-image-width item)) - (encode-object-element "height" (store-image-height item)))) + (json:encode-object-element "type" "news") + (json:encode-object-element "title" (quickhoney-news-item-title item)) + (json:encode-object-element "text" (quickhoney-news-item-text item)) + (json:encode-object-element "width" (store-image-width item)) + (json:encode-object-element "height" (store-image-height item)))) (defun json-encode-news-items (items) - (json:with-response () - (with-object-element ("items") + (with-json-response () + (json:with-object-element ("items") (json:with-array () (dolist (item items) (json:with-object () @@ -576,8 +581,8 @@ (:default-initargs :object-class 'rss-channel :query-function #'find-rss-channel)) (defmethod handle-object ((handler json-news-archive-handler) (channel rss-channel)) - (json:with-response () - (with-object-element ("months") + (with-json-response () + (json:with-object-element ("months") (json:with-array () (dolist (month (sort (rss-channel-archived-months channel) (lambda (a b) @@ -585,8 +590,8 @@ (> (second a) (second b)) (> (first a) (first b)))))) (json:with-array () - (encode-array-element (first month)) - (encode-array-element (second month)))))))) + (json:encode-array-element (first month)) + (json:encode-array-element (second month)))))))) (defclass shutdown-handler (admin-only-handler page-handler) ())

1 0

[bknr-cvs] hans changed trunk/libraries/yason/package.lisp
by BKNR Commits 12 Nov '08

12 Nov '08

Revision: 4039 Author: hans URL: http://bknr.net/trac/changeset/4039 fix indentation U trunk/libraries/yason/package.lisp Modified: trunk/libraries/yason/package.lisp =================================================================== --- trunk/libraries/yason/package.lisp 2008-11-12 11:00:34 UTC (rev 4038) +++ trunk/libraries/yason/package.lisp 2008-11-12 11:00:57 UTC (rev 4039) @@ -13,8 +13,8 @@ (:export ;; Parser - #:parse - #:*parse-object-key-fn* + #:parse + #:*parse-object-key-fn* ;; Basic encoder interface #:encode

1 0

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

12 Nov '08

Revision: 4038 Author: hans URL: http://bknr.net/trac/changeset/4038 Add license, copyright notes. A trunk/libraries/yason/LICENSE U trunk/libraries/yason/encode.lisp U trunk/libraries/yason/package.lisp U trunk/libraries/yason/parse.lisp U trunk/libraries/yason/yason.asd Added: trunk/libraries/yason/LICENSE =================================================================== --- trunk/libraries/yason/LICENSE (rev 0) +++ trunk/libraries/yason/LICENSE 2008-11-12 11:00:34 UTC (rev 4038) @@ -0,0 +1,30 @@ +Copyright (c) 2008 Hans HÃŒbner +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + - Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + - Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + + - Neither the name BKNR nor the names of its contributors may be + used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Modified: trunk/libraries/yason/encode.lisp =================================================================== --- trunk/libraries/yason/encode.lisp 2008-11-12 10:27:20 UTC (rev 4037) +++ trunk/libraries/yason/encode.lisp 2008-11-12 11:00:34 UTC (rev 4038) @@ -1,3 +1,10 @@ +;; This file is part of yason, a Common Lisp JSON parser/encoder +;; +;; Copyright (c) 2008 Hans HÃŒbner +;; All rights reserved. +;; +;; Please see the file LICENSE in the distribution. + (in-package :yason) (defvar *json-output*) Modified: trunk/libraries/yason/package.lisp =================================================================== --- trunk/libraries/yason/package.lisp 2008-11-12 10:27:20 UTC (rev 4037) +++ trunk/libraries/yason/package.lisp 2008-11-12 11:00:34 UTC (rev 4038) @@ -1,3 +1,10 @@ +;; This file is part of yason, a Common Lisp JSON parser/encoder +;; +;; Copyright (c) 2008 Hans HÃŒbner +;; All rights reserved. +;; +;; Please see the file LICENSE in the distribution. + (defpackage :yason (:use :cl) @@ -5,7 +12,6 @@ (:nicknames :json) (:export - ;; Parser #:parse #:*parse-object-key-fn* Modified: trunk/libraries/yason/parse.lisp =================================================================== --- trunk/libraries/yason/parse.lisp 2008-11-12 10:27:20 UTC (rev 4037) +++ trunk/libraries/yason/parse.lisp 2008-11-12 11:00:34 UTC (rev 4038) @@ -1,3 +1,10 @@ +;; This file is part of yason, a Common Lisp JSON parser/encoder +;; +;; Copyright (c) 2008 Hans HÃŒbner +;; All rights reserved. +;; +;; Please see the file LICENSE in the distribution. + (in-package :yason) (defconstant +default-string-length+ 20 Modified: trunk/libraries/yason/yason.asd =================================================================== --- trunk/libraries/yason/yason.asd 2008-11-12 10:27:20 UTC (rev 4037) +++ trunk/libraries/yason/yason.asd 2008-11-12 11:00:34 UTC (rev 4038) @@ -1,3 +1,10 @@ +;; This file is part of yason, a Common Lisp JSON parser/encoder +;; +;; Copyright (c) 2008 Hans Hübner +;; All rights reserved. +;; +;; Please see the file LICENSE in the distribution. + ;;;; -*- Mode: LISP -*- (in-package :cl-user) @@ -8,9 +15,9 @@ (in-package :yason.system) (defsystem :yason - :name "YASON" + :name "yason" :author "Hans Huebner <hans(a)huebner.org>" - :version "0" + :version "1" :maintainer "Hans Huebner <hans(a)huebner.org>" :licence "BSD" :description "JSON parser/encoder"

1 0

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

12 Nov '08

Revision: 4037 Author: hans URL: http://bknr.net/trac/changeset/4037 Add new YASON library. A trunk/libraries/yason/ A trunk/libraries/yason/encode.lisp A trunk/libraries/yason/package.lisp A trunk/libraries/yason/parse.lisp A trunk/libraries/yason/yason.asd D trunk/projects/quickhoney/src/json-parser.lisp D trunk/projects/quickhoney/src/json.lisp U trunk/projects/quickhoney/src/packages.lisp U trunk/projects/quickhoney/src/quickhoney.asd Change set too large, please see URL above

1 0

[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