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

[bknr-cvs] ksprotte changed trunk/projects/bos/
by BKNR Commits 10 Jul '08

10 Jul '08

Revision: 3423 Author: ksprotte URL: http://bknr.net/trac/changeset/3423 fixed again sat-layer destroy-object, so that deleting a sat-layer is possible without breaking the store U trunk/projects/bos/test/web/sat-tree.lisp U trunk/projects/bos/web/sat-tree.lisp Modified: trunk/projects/bos/test/web/sat-tree.lisp =================================================================== --- trunk/projects/bos/test/web/sat-tree.lisp 2008-07-10 14:31:04 UTC (rev 3422) +++ trunk/projects/bos/test/web/sat-tree.lisp 2008-07-10 15:41:02 UTC (rev 3423) @@ -6,5 +6,7 @@ (cl-gd:with-image (image 1000 1000) (with-store-reopenings () (bos.web::make-sat-layer image geo-box :test 0) - (delete-object (first (class-instances 'bos.web::sat-layer))) + (progn + (bos.web::remove-sat-layer-from-quad-tree (find-store-object 1)) + (delete-object (first (class-instances 'bos.web::sat-layer)))) (pass))))) Modified: trunk/projects/bos/web/sat-tree.lisp =================================================================== --- trunk/projects/bos/web/sat-tree.lisp 2008-07-10 14:31:04 UTC (rev 3422) +++ trunk/projects/bos/web/sat-tree.lisp 2008-07-10 15:41:02 UTC (rev 3423) @@ -3,9 +3,6 @@ (defclass sat-node (node-extension) ((image :accessor image :initarg :image))) -(defmethod delete-node-extension :before ((obj sat-node)) - (delete-object (image obj))) - (defpersistent-class sat-layer () ((name :reader name :initarg :name :index-type unique-index @@ -18,11 +15,23 @@ (format stream "name: ~s" (name obj)))) (defmethod destroy-object :before ((obj sat-layer)) - ;; (dolist (top-level-node (sat-layer-top-level-nodes obj)) - ;; (delete-node-extension top-level-node)) + (when (boundp '*quad-tree*) + ;; when the transaction log is being loaded, *quad-tree* is still + ;; unbound, because it is only initialized, when the entire store + ;; has been loaded -- an example for the fact that the quad-tree + ;; should have been implemented as a proper store index + (assert (null (sat-layer-top-level-nodes obj)) nil + "Please invoke (remove-sat-layer-from-quad-tree (find-store-object ~D)) before deleting ~s." + (store-object-id obj) obj)) (dolist (sat-image (class-instances 'sat-image)) - (delete-object sat-image))) + (when (eq obj (layer sat-image)) + (delete-object sat-image)))) +(defun remove-sat-layer-from-quad-tree (sat-layer) + (let ((nodes (collect-nodes (constantly t) (first (sat-layer-top-level-nodes sat-layer))))) + (mapc #'delete-node-extension nodes) + (values))) + (defun sat-layer-top-level-nodes (sat-layer) (check-type sat-layer sat-layer) (let ((nodes ()) @@ -160,7 +169,7 @@ (let* ((name (name layer)) (nodes (remove-if-not #'pw-ph-large-enough (layer-quad-nodes))) (max-scaling (max-scaling nodes))) - (format t "; creating ~a at depth ~a~%" name start-depth) + (format t "; creating ~a at depth ~a~%" name start-depth) ; (dolist (node nodes layer) (make-sat-image-tile image geo-box (quad-node node) (tile-geo-box node) name max-scaling))

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/test/
by BKNR Commits 10 Jul '08

10 Jul '08

Revision: 3422 Author: ksprotte URL: http://bknr.net/trac/changeset/3422 quick fix to test delete-sat-layer-and-snapshot U trunk/projects/bos/test/fixtures.lisp U trunk/projects/bos/test/web/sat-tree.lisp Modified: trunk/projects/bos/test/fixtures.lisp =================================================================== --- trunk/projects/bos/test/fixtures.lisp 2008-07-10 13:37:33 UTC (rev 3421) +++ trunk/projects/bos/test/fixtures.lisp 2008-07-10 14:31:04 UTC (rev 3422) @@ -18,24 +18,28 @@ `(let (,@(iter (for id-var in id-vars) (for store-object-var in store-object-vars) - (collect `(,id-var (store-object-id ,store-object-var))))) + (collect `(,id-var (when (and ,store-object-var + (not (object-destroyed-p ,store-object-var))) + (store-object-id ,store-object-var)))))) (%reopen-store :snapshot ,snapshot) (setf ,@(iter (for id-var in id-vars) (for store-object-var in store-object-vars) (collect store-object-var) - (collect `(find-store-object ,id-var))))))) + (collect `(when ,id-var (find-store-object ,id-var)))))))) (defmacro %with-store-reopenings ((&key snapshot bypass) (&rest store-object-vars) &body body) - `(progn - ,@(if bypass - body - (iter - (for form in body) - (unless (first-time-p) - (collect `(reopen-store (:snapshot ,snapshot) ,@store-object-vars))) - (collect form))))) + `(let ((snapshot ,snapshot) + (bypass ,bypass)) + (if bypass + (progn ,@body) + (progn + ,@(iter + (for form in body) + (unless (first-time-p) + (collect `(reopen-store (:snapshot ,snapshot) ,@store-object-vars))) + (collect form)))))) (defmacro with-store-reopenings ((&rest store-object-vars) &body body) `(%with-store-reopenings (:snapshot snapshot :bypass bypass) Modified: trunk/projects/bos/test/web/sat-tree.lisp =================================================================== --- trunk/projects/bos/test/web/sat-tree.lisp 2008-07-10 13:37:33 UTC (rev 3421) +++ trunk/projects/bos/test/web/sat-tree.lisp 2008-07-10 14:31:04 UTC (rev 3422) @@ -1,19 +1,10 @@ (in-package :bos.test) (in-suite :bos.test.web) -(test delete-sat-layer-and-snapshot - (with-fixture initial-bos-store () - (let ((geo-box (bos.web::rectangle-geo-box (bos.web::make-rectangle2 '(10 10 100 100))))) - (cl-gd:with-image (image 1000 1000) +(store-test delete-sat-layer-and-snapshot + (let ((geo-box (bos.web::rectangle-geo-box (bos.web::make-rectangle2 '(10 10 100 100))))) + (cl-gd:with-image (image 1000 1000) + (with-store-reopenings () (bos.web::make-sat-layer image geo-box :test 0) (delete-object (first (class-instances 'bos.web::sat-layer))) - (finishes (snapshot)))))) - -;; (store-test delete-sat-layer-and-snapshot.2 -;; (let ((geo-box (bos.web::rectangle-geo-box (bos.web::make-rectangle2 '(10 10 100 100))))) -;; (cl-gd:with-image (image 1000 1000) -;; (with-store-reopenings () -;; (bos.web::make-sat-layer image geo-box :test 0) -;; (delete-object (first (class-instances 'bos.web::sat-layer))) -;; (pass))))) - + (pass)))))

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/
by BKNR Commits 10 Jul '08

10 Jul '08

Revision: 3421 Author: ksprotte URL: http://bknr.net/trac/changeset/3421 fixed a problem with sat-layer destroy-object, where snapshot would fail afterwards _U trunk/projects/bos/ U trunk/projects/bos/test/bos.test.asd A trunk/projects/bos/test/web/sat-tree.lisp U trunk/projects/bos/web/sat-tree.lisp Property changes on: trunk/projects/bos ___________________________________________________________________ Name: svn:ignore - datastore web.rc m2.rc TAGS bos.core screenrc + datastore web.rc m2.rc TAGS bos.core screenrc hunchentoot-access.log hunchentoot-error.log Modified: trunk/projects/bos/test/bos.test.asd =================================================================== --- trunk/projects/bos/test/bos.test.asd 2008-07-10 09:32:53 UTC (rev 3420) +++ trunk/projects/bos/test/bos.test.asd 2008-07-10 13:37:33 UTC (rev 3421) @@ -14,4 +14,5 @@ :depends-on ("suites" "fixtures") :components ((:file "drakma-requests") - (:file "quad-tree"))))) + (:file "quad-tree") + (:file "sat-tree"))))) Added: trunk/projects/bos/test/web/sat-tree.lisp =================================================================== --- trunk/projects/bos/test/web/sat-tree.lisp (rev 0) +++ trunk/projects/bos/test/web/sat-tree.lisp 2008-07-10 13:37:33 UTC (rev 3421) @@ -0,0 +1,19 @@ +(in-package :bos.test) +(in-suite :bos.test.web) + +(test delete-sat-layer-and-snapshot + (with-fixture initial-bos-store () + (let ((geo-box (bos.web::rectangle-geo-box (bos.web::make-rectangle2 '(10 10 100 100))))) + (cl-gd:with-image (image 1000 1000) + (bos.web::make-sat-layer image geo-box :test 0) + (delete-object (first (class-instances 'bos.web::sat-layer))) + (finishes (snapshot)))))) + +;; (store-test delete-sat-layer-and-snapshot.2 +;; (let ((geo-box (bos.web::rectangle-geo-box (bos.web::make-rectangle2 '(10 10 100 100))))) +;; (cl-gd:with-image (image 1000 1000) +;; (with-store-reopenings () +;; (bos.web::make-sat-layer image geo-box :test 0) +;; (delete-object (first (class-instances 'bos.web::sat-layer))) +;; (pass))))) + Modified: trunk/projects/bos/web/sat-tree.lisp =================================================================== --- trunk/projects/bos/web/sat-tree.lisp 2008-07-10 09:32:53 UTC (rev 3420) +++ trunk/projects/bos/web/sat-tree.lisp 2008-07-10 13:37:33 UTC (rev 3421) @@ -18,8 +18,10 @@ (format stream "name: ~s" (name obj)))) (defmethod destroy-object :before ((obj sat-layer)) - (dolist (top-level-node (sat-layer-top-level-nodes obj)) - (delete-node-extension top-level-node))) + ;; (dolist (top-level-node (sat-layer-top-level-nodes obj)) + ;; (delete-node-extension top-level-node)) + (dolist (sat-image (class-instances 'sat-image)) + (delete-object sat-image))) (defun sat-layer-top-level-nodes (sat-layer) (check-type sat-layer sat-layer)

1 0

[bknr-cvs] hans changed trunk/bknr/web/site/squid.conf
by BKNR Commits 10 Jul '08

10 Jul '08

Revision: 3420 Author: hans URL: http://bknr.net/trac/changeset/3420 Configuration for squid3.0 U trunk/bknr/web/site/squid.conf Modified: trunk/bknr/web/site/squid.conf =================================================================== --- trunk/bknr/web/site/squid.conf 2008-07-09 07:30:39 UTC (rev 3419) +++ trunk/bknr/web/site/squid.conf 2008-07-10 09:32:53 UTC (rev 3420) @@ -1,5 +1,25 @@ acl all src 0.0.0.0/0.0.0.0 -http_access allow all -http_port 80 accel defaultsite=127.0.0.1 vhost vport -cache_peer 127.0.0.1 parent 8088 0 no-query originserver -cache_effective_user daemon +acl manager proto cache_object +acl localhost src 127.0.0.1/255.255.255.255 +acl to_localhost dst 127.0.0.0/8 +acl SSL_ports port 443 +acl Safe_ports port 80 # http +acl Safe_ports port 21 # ftp +acl Safe_ports port 443 # https +acl Safe_ports port 70 # gopher +acl Safe_ports port 210 # wais +acl Safe_ports port 1025-65535 # unregistered ports +acl Safe_ports port 280 # http-mgmt +acl Safe_ports port 488 # gss-http +acl Safe_ports port 591 # filemaker +acl Safe_ports port 777 # multiling http +acl CONNECT method CONNECT + +http_port 80 accel defaultsite=jasmin.headcraft.de +cache_peer 127.0.0.1 parent 8081 0 no-query originserver name=myAccel +acl our_sites dstdomain jasmin.headcraft.de +http_access allow our_sites +cache_peer_access myAccel allow our_sites +cache_peer_access myAccel deny all +access_log /usr/local/squid/logs/access.log squid +pipeline_prefetch on

1 0

[bknr-cvs] edi changed trunk/thirdparty/hunchentoot/server.lisp
by BKNR Commits 09 Jul '08

09 Jul '08

Revision: 3419 Author: edi URL: http://bknr.net/trac/changeset/3419 Fix handling of chunked requests (bug caught by Cyrus Harmon) U trunk/thirdparty/hunchentoot/server.lisp Modified: trunk/thirdparty/hunchentoot/server.lisp =================================================================== --- trunk/thirdparty/hunchentoot/server.lisp 2008-07-09 05:55:22 UTC (rev 3418) +++ trunk/thirdparty/hunchentoot/server.lisp 2008-07-09 07:30:39 UTC (rev 3419) @@ -462,6 +462,15 @@ ;; request - note that *SERVER* was bound above already (let ((*reply* (make-instance 'reply)) (*session* nil)) + (when (server-input-chunking-p *server*) + (let ((transfer-encodings (cdr (assoc* :transfer-encoding headers-in)))) + (when transfer-encodings + (setq transfer-encodings + (split "\\s*,\\*" transfer-encodings))) + (when (member "chunked" transfer-encodings :test #'equalp) + ;; turn chunking on before we read the request body + (setf *hunchentoot-stream* (make-chunked-stream *hunchentoot-stream*) + (chunked-stream-input-chunking-p *hunchentoot-stream*) t)))) (multiple-value-bind (remote-addr remote-port) (get-peer-address-and-port socket) (process-request (make-instance (server-request-class *server*) @@ -491,66 +500,56 @@ using START-OUTPUT. If all goes as planned, the function returns T." (let (*tmp-files* *headers-sent*) (unwind-protect - (progn - (when (server-input-chunking-p *server*) - (let ((transfer-encodings (header-in :transfer-encoding request))) - (when transfer-encodings - (setq transfer-encodings - (split "\\s*,\\*" transfer-encodings))) - (when (member "chunked" transfer-encodings :test #'equalp) - ;; turn chunking on before we read the request body - (setf *hunchentoot-stream* (make-chunked-stream *hunchentoot-stream*) - (chunked-stream-input-chunking-p *hunchentoot-stream*) t)))) - (let* ((*request* request) - backtrace) - (multiple-value-bind (body error) - (catch 'handler-done - (handler-bind ((error - (lambda (cond) - ;; only generate backtrace if needed - (setq backtrace - (and (or (and *show-lisp-errors-p* - *show-lisp-backtraces-p*) - (and *log-lisp-errors-p* - *log-lisp-backtraces-p*)) - (get-backtrace cond))) - (when *log-lisp-errors-p* - (log-message* *lisp-errors-log-level* - "~A~:[~*~;~%~A~]" - cond - *log-lisp-backtraces-p* - backtrace)) - ;; if the headers were already sent - ;; the error happens within the body - ;; and we have to close the stream - (when *headers-sent* - (setq *close-hunchentoot-stream* t)) - (throw 'handler-done - (values nil cond)))) - (warning - (lambda (cond) - (when *log-lisp-warnings-p* - (log-message* *lisp-warnings-log-level* - "~A~:[~*~;~%~A~]" - cond - *log-lisp-backtraces-p* - backtrace))))) - ;; skip dispatch if bad request - (when (eql (return-code) +http-ok+) - ;; now do the work - (dispatch-request *server* *request* *reply*)))) - (when error - (setf (return-code *reply*) - +http-internal-server-error+)) - (start-output :content (cond ((and error *show-lisp-errors-p*) - (format nil "<pre>~A~:[~*~;~%~%~A~]</pre>" - (escape-for-html (format nil "~A" error)) - *show-lisp-backtraces-p* - (escape-for-html (format nil "~A" backtrace)))) - (error - "An error has occured.") - (t body)))) - t)) + (let* ((*request* request) + backtrace) + (multiple-value-bind (body error) + (catch 'handler-done + (handler-bind ((error + (lambda (cond) + ;; only generate backtrace if needed + (setq backtrace + (and (or (and *show-lisp-errors-p* + *show-lisp-backtraces-p*) + (and *log-lisp-errors-p* + *log-lisp-backtraces-p*)) + (get-backtrace cond))) + (when *log-lisp-errors-p* + (log-message* *lisp-errors-log-level* + "~A~:[~*~;~%~A~]" + cond + *log-lisp-backtraces-p* + backtrace)) + ;; if the headers were already sent + ;; the error happens within the body + ;; and we have to close the stream + (when *headers-sent* + (setq *close-hunchentoot-stream* t)) + (throw 'handler-done + (values nil cond)))) + (warning + (lambda (cond) + (when *log-lisp-warnings-p* + (log-message* *lisp-warnings-log-level* + "~A~:[~*~;~%~A~]" + cond + *log-lisp-backtraces-p* + backtrace))))) + ;; skip dispatch if bad request + (when (eql (return-code) +http-ok+) + ;; now do the work + (dispatch-request *server* *request* *reply*)))) + (when error + (setf (return-code *reply*) + +http-internal-server-error+)) + (start-output :content (cond ((and error *show-lisp-errors-p*) + (format nil "<pre>~A~:[~*~;~%~%~A~]</pre>" + (escape-for-html (format nil "~A" error)) + *show-lisp-backtraces-p* + (escape-for-html (format nil "~A" backtrace)))) + (error + "An error has occured.") + (t body)))) + t) (dolist (path *tmp-files*) (when (and (pathnamep path) (probe-file path)) ;; the handler may have chosen to (re)move the uploaded

1 0

[bknr-cvs] hans changed trunk/thirdparty/usocket/backend/openmcl.lisp
by BKNR Commits 09 Jul '08

09 Jul '08

Revision: 3418 Author: hans URL: http://bknr.net/trac/changeset/3418 Convert CCL:INPUT-TIMEOUT to USOCKET:TIMEOUT-ERROR. U trunk/thirdparty/usocket/backend/openmcl.lisp Modified: trunk/thirdparty/usocket/backend/openmcl.lisp =================================================================== --- trunk/thirdparty/usocket/backend/openmcl.lisp 2008-07-09 05:54:03 UTC (rev 3417) +++ trunk/thirdparty/usocket/backend/openmcl.lisp 2008-07-09 05:55:22 UTC (rev 3418) @@ -59,6 +59,8 @@ (openmcl-socket:socket-error (raise-error-from-id (openmcl-socket:socket-error-identifier condition) socket condition)) + (ccl:input-timeout + (error 'timeout-error :socket socket :real-error condition)) (ccl:communication-deadline-expired (error 'timeout-error :socket socket :real-error condition)) (ccl::socket-creation-error #| ugh! |#

1 0

[bknr-cvs] hans changed trunk/thirdparty/hunchentoot/connection-manager.lisp
by BKNR Commits 09 Jul '08

09 Jul '08

Revision: 3417 Author: hans URL: http://bknr.net/trac/changeset/3417 Remove WORKERS slot from ONE-SLOT-PER-CONNECTION-MANAGER. Workers were never removed from the list and it was used only for shutdown in LispWorks. As worker processes synchronously check for server shutdown anyway, losing the WORKERS slot was the best option to remove the leak. U trunk/thirdparty/hunchentoot/connection-manager.lisp Modified: trunk/thirdparty/hunchentoot/connection-manager.lisp =================================================================== --- trunk/thirdparty/hunchentoot/connection-manager.lisp 2008-07-09 05:52:08 UTC (rev 3416) +++ trunk/thirdparty/hunchentoot/connection-manager.lisp 2008-07-09 05:54:03 UTC (rev 3417) @@ -89,18 +89,11 @@ (process-connection (server manager) socket)) (defclass one-thread-per-connection-manager (connection-manager) - ((workers :initform nil - :accessor connection-manager-workers - :documentation "A list of currently active worker -threads.")) + () (:documentation "Connection manager that starts one thread for listening to incoming requests and one thread for each incoming connection.")) -(defmethod print-object ((manager one-thread-per-connection-manager) stream) - (print-unreadable-object (manager stream :type t) - (format stream "~A worker~:P" (length (connection-manager-workers manager))))) - (defmethod execute-listener ((manager one-thread-per-connection-manager)) #+:lispworks (listen-for-connections (server manager)) @@ -119,30 +112,16 @@ (zerop (mod *worker-counter* *cleanup-interval*))) (when *cleanup-function* (funcall *cleanup-function*))) - ;; start a worker thread for this connection and remember it - (push (mp:process-run-function (format nil "Hunchentoot worker \(client: ~{~A:~A~})" - (multiple-value-list - (get-peer-address-and-port handle))) - nil #'process-connection - (server manager) handle) - (connection-manager-workers manager))) + (mp:process-run-function (format nil "Hunchentoot worker \(client: ~{~A:~A~})" + (multiple-value-list + (get-peer-address-and-port handle))) + nil #'process-connection + (server manager) handle)) #-:lispworks (defmethod handle-incoming-connection ((manager one-thread-per-connection-manager) socket) - (push (bt:make-thread (lambda () - (process-connection (server manager) socket)) - :name (format nil "Hunchentoot worker \(client: ~A:~A)" - (usocket:vector-quad-to-dotted-quad (usocket:get-peer-address socket)) - (usocket:get-peer-port socket))) - (connection-manager-workers manager))) - -#+:lispworks -(defmethod shutdown ((manager one-thread-per-connection-manager)) - ;; kill all worker threads - (dolist (worker (connection-manager-workers manager)) - (ignore-errors - (when (mp:process-alive-p worker) - (mp:process-kill worker))) - (mp:process-allow-scheduling)) - ;; finally, kill main listener - (call-next-method)) + (bt:make-thread (lambda () + (process-connection (server manager) socket)) + :name (format nil "Hunchentoot worker \(client: ~A:~A)" + (usocket:vector-quad-to-dotted-quad (usocket:get-peer-address socket)) + (usocket:get-peer-port socket))))

1 0

[bknr-cvs] hans changed trunk/thirdparty/slime/
by BKNR Commits 09 Jul '08

09 Jul '08

Revision: 3416 Author: hans URL: http://bknr.net/trac/changeset/3416 update slime U trunk/thirdparty/slime/CVS/Entries U trunk/thirdparty/slime/ChangeLog U trunk/thirdparty/slime/contrib/CVS/Entries U trunk/thirdparty/slime/contrib/ChangeLog U trunk/thirdparty/slime/contrib/slime-parse.el U trunk/thirdparty/slime/contrib/swank-asdf.lisp U trunk/thirdparty/slime/doc/CVS/Entries U trunk/thirdparty/slime/slime.el U trunk/thirdparty/slime/swank-allegro.lisp U trunk/thirdparty/slime/swank-backend.lisp U trunk/thirdparty/slime/swank-cmucl.lisp U trunk/thirdparty/slime/swank-lispworks.lisp U trunk/thirdparty/slime/swank-sbcl.lisp U trunk/thirdparty/slime/swank.lisp Change set too large, please see URL above

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/web/tags.lisp
by BKNR Commits 02 Jul '08

02 Jul '08

Revision: 3415 Author: ksprotte URL: http://bknr.net/trac/changeset/3415 generate-cert use bknr-session instead of ensure-bknr-session U trunk/projects/bos/web/tags.lisp Modified: trunk/projects/bos/web/tags.lisp =================================================================== --- trunk/projects/bos/web/tags.lisp 2008-07-02 15:59:24 UTC (rev 3414) +++ trunk/projects/bos/web/tags.lisp 2008-07-02 16:07:54 UTC (rev 3415) @@ -36,7 +36,7 @@ (emit-tag-children)) (define-bknr-tag generate-cert () - (ensure-bknr-session) + (bknr-session) (with-template-vars (gift email name address want-print) (let ((contract (find-store-object (parse-integer (get-template-var :contract-id))))) (when (equal want-print "no")

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/tools/squid-access-log2csv
by BKNR Commits 02 Jul '08

02 Jul '08

Revision: 3414 Author: ksprotte URL: http://bknr.net/trac/changeset/3414 squid-access-log2csv outputs more standard cvs format (always using " and ;) U trunk/projects/bos/tools/squid-access-log2csv Modified: trunk/projects/bos/tools/squid-access-log2csv =================================================================== --- trunk/projects/bos/tools/squid-access-log2csv 2008-07-02 15:55:21 UTC (rev 3413) +++ trunk/projects/bos/tools/squid-access-log2csv 2008-07-02 15:59:24 UTC (rev 3414) @@ -47,13 +47,13 @@ *uri-hash*) (setf lists (sort lists #'> :key (lambda (uri) (cdr (assoc :total (cdr uri)))))) - (format t "uri,TOTAL,~{~A~^,~}~%" *action/codes*) + (format t "\"uri\";\"TOTAL\";~{\"~A\"~^;~}~%" *action/codes*) (dolist (list lists) (destructuring-bind (uri . alist) list - (format t "\"~A\"," uri) - (format t "~A," (cdr (assoc :total alist))) - (format t "~{~D~^,~}~%" + (format t "\"~A\";" uri) + (format t "\"~A\";" (cdr (assoc :total alist))) + (format t "~{\"~D\"~^;~}~%" (mapcar (lambda (action/code) (or (cdr (assoc action/code alist)) 0))

1 0