bknr-cvs July 2008

bknr-cvs@common-lisp.net

1 participants
321 discussions

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

18 Jul '08

Revision: 3503 Author: ksprotte URL: http://bknr.net/trac/changeset/3503 oops, stupid bugin start-contract-tree-image-update-daemon U trunk/projects/bos/web/contract-tree.lisp Modified: trunk/projects/bos/web/contract-tree.lisp =================================================================== --- trunk/projects/bos/web/contract-tree.lisp 2008-07-18 12:28:05 UTC (rev 3502) +++ trunk/projects/bos/web/contract-tree.lisp 2008-07-18 13:29:12 UTC (rev 3503) @@ -296,6 +296,9 @@ (map-nodes #'contract-node-update-image-if-needed *contract-tree* :prune-test (lambda (node) (not (contract-node-update-image-needed-p node)))))) +(defun contract-tree-force-update-images () + (map-nodes #'contract-node-update-image *contract-tree*)) + ;;; image handler (defclass contract-tree-image-handler (page-handler) ()) @@ -328,8 +331,9 @@ (defun start-contract-tree-image-update-daemon () (unless (contract-tree-image-update-daemon-running-p) (setq *contract-tree-image-update-daemon-halt* nil) - (bt:make-thread #'contract-tree-image-update-daemon-loop - :name "contract-tree-image-update-daemon"))) + (setq *contract-tree-image-update-daemon* + (bt:make-thread #'contract-tree-image-update-daemon-loop + :name "contract-tree-image-update-daemon")))) (defun stop-contract-tree-image-update-daemon (&key wait) (when (contract-tree-image-update-daemon-running-p)

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/m2/m2.lisp
by BKNR Commits 18 Jul '08

18 Jul '08

Revision: 3502 Author: ksprotte URL: http://bknr.net/trac/changeset/3502 optimized contract-compute-largest-rectangle that also helped to avoid a screamer fail on a certain contract U trunk/projects/bos/m2/m2.lisp Modified: trunk/projects/bos/m2/m2.lisp =================================================================== --- trunk/projects/bos/m2/m2.lisp 2008-07-18 11:43:24 UTC (rev 3501) +++ trunk/projects/bos/m2/m2.lisp 2008-07-18 12:28:05 UTC (rev 3502) @@ -1,3 +1,4 @@ + (in-package :bos.m2) ;;; @@ -392,49 +393,55 @@ (let* ((m2s (contract-m2s contract)) (area (length m2s)) (scaler (ceiling area 1000.0)) - (bounding-box (contract-bounding-box contract))) - (geometry:with-rectangle bounding-box - (declare (ignore width height)) - (labels ( ;; to-orig - (distance-to-orig (d) - (when-scaling-needed d - (round (* d scaler)))) - (x-coordinate-to-orig (x) - (when-scaling-needed x - (+ left (round (* (- x left) scaler))))) - (y-coordinate-to-orig (y) - (when-scaling-needed y - (+ top (round (* (- y top) scaler))))) - (rectangle-to-orig (r) - (when-scaling-needed r - (geometry:with-rectangle r - (list (x-coordinate-to-orig left) - (y-coordinate-to-orig top) - (distance-to-orig width) - (distance-to-orig height))))) - ;; from-orig - (distance-from-orig (d) - (when-scaling-needed d - (floor d scaler))) - (x-coordinate-from-orig (x) - (when-scaling-needed x - (+ left (floor (- x left) scaler)))) - (y-coordinate-from-orig (y) - (when-scaling-needed y - (+ top (floor (- y top) scaler)))) - (rectangle-from-orig (r) - (when-scaling-needed r - (geometry:with-rectangle r - (list (x-coordinate-from-orig left) - (y-coordinate-from-orig top) - (distance-from-orig width) - (distance-from-orig height)))))) - (rectangle-to-orig - (screamer-user:largest-rectangle - (rectangle-from-orig bounding-box) - (lambda (x y) - (let ((m2 (get-m2 (x-coordinate-to-orig x) (y-coordinate-to-orig y)))) - (and m2 (eql contract (m2-contract m2)))))))))))) + (bounding-box (contract-bounding-box contract)) + (bounding-width (third bounding-box)) + (bounding-height (fourth bounding-box))) + (if (= area (* bounding-width bounding-height)) + ;; no need to run screamer here, since we already know the + ;; answer + bounding-box + (geometry:with-rectangle bounding-box + (declare (ignore width height)) + (labels ( ;; to-orig + (distance-to-orig (d) + (when-scaling-needed d + (round (* d scaler)))) + (x-coordinate-to-orig (x) + (when-scaling-needed x + (+ left (round (* (- x left) scaler))))) + (y-coordinate-to-orig (y) + (when-scaling-needed y + (+ top (round (* (- y top) scaler))))) + (rectangle-to-orig (r) + (when-scaling-needed r + (geometry:with-rectangle r + (list (x-coordinate-to-orig left) + (y-coordinate-to-orig top) + (distance-to-orig width) + (distance-to-orig height))))) + ;; from-orig + (distance-from-orig (d) + (when-scaling-needed d + (floor d scaler))) + (x-coordinate-from-orig (x) + (when-scaling-needed x + (+ left (floor (- x left) scaler)))) + (y-coordinate-from-orig (y) + (when-scaling-needed y + (+ top (floor (- y top) scaler)))) + (rectangle-from-orig (r) + (when-scaling-needed r + (geometry:with-rectangle r + (list (x-coordinate-from-orig left) + (y-coordinate-from-orig top) + (distance-from-orig width) + (distance-from-orig height)))))) + (rectangle-to-orig + (screamer-user:largest-rectangle + (rectangle-from-orig bounding-box) + (lambda (x y) + (let ((m2 (get-m2 (x-coordinate-to-orig x) (y-coordinate-to-orig y)))) + (and m2 (eql contract (m2-contract m2))))))))))))) (defun contract-neighbours (contract) "Return all contracts that have an adjacent m2 to one of CONTRACT's m2s.

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/m2/m2-store.lisp
by BKNR Commits 18 Jul '08

18 Jul '08

Revision: 3501 Author: ksprotte URL: http://bknr.net/trac/changeset/3501 added a restart that allows skipping of a transient init-function U trunk/projects/bos/m2/m2-store.lisp Modified: trunk/projects/bos/m2/m2-store.lisp =================================================================== --- trunk/projects/bos/m2/m2-store.lisp 2008-07-18 11:03:33 UTC (rev 3500) +++ trunk/projects/bos/m2/m2-store.lisp 2008-07-18 11:43:24 UTC (rev 3501) @@ -66,4 +66,6 @@ (defun invoke-store-transient-init-functions () (dolist (function-name *store-transient-init-functions*) - (funcall function-name))) \ No newline at end of file + (with-simple-restart (skip-init-function "Skip transient-init-function ~A" + function-name) + (funcall function-name)))) \ No newline at end of file

1 0

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

18 Jul '08

Revision: 3500 Author: ksprotte URL: http://bknr.net/trac/changeset/3500 contract-tree small change U trunk/projects/bos/web/contract-tree.lisp Modified: trunk/projects/bos/web/contract-tree.lisp =================================================================== --- trunk/projects/bos/web/contract-tree.lisp 2008-07-18 10:53:38 UTC (rev 3499) +++ trunk/projects/bos/web/contract-tree.lisp 2008-07-18 11:03:33 UTC (rev 3500) @@ -247,6 +247,7 @@ (cl-gd:find-color r g b :alpha 40)))) (let ((box (geo-box node)) (image-size *contract-tree-images-size*)) + ;; (warn "will update image for ~a" node) (cl-gd:with-image (cl-gd:*default-image* image-size image-size t) (setf (cl-gd:save-alpha-p) t (cl-gd:alpha-blending-p) nil)

1 0

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

18 Jul '08

Revision: 3499 Author: ksprotte URL: http://bknr.net/trac/changeset/3499 added target POI-micro-site to learn-more link U trunk/projects/bos/web/poi-handlers.lisp Modified: trunk/projects/bos/web/poi-handlers.lisp =================================================================== --- trunk/projects/bos/web/poi-handlers.lisp 2008-07-18 10:33:20 UTC (rev 3498) +++ trunk/projects/bos/web/poi-handlers.lisp 2008-07-18 10:53:38 UTC (rev 3499) @@ -528,6 +528,7 @@ (attribute "align" "center") (with-element "a" (attribute "href" (poi-xml-path)) + (attribute "target" "POI-micro-site") (text (dictionary-entry "learn more" language))))) (with-element "tr" (with-element "td"

1 0

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

18 Jul '08

Revision: 3498 Author: ksprotte URL: http://bknr.net/trac/changeset/3498 fixes for contract-tree, especially contract-node-find-corresponding-store-image U trunk/projects/bos/web/contract-tree.lisp Modified: trunk/projects/bos/web/contract-tree.lisp =================================================================== --- trunk/projects/bos/web/contract-tree.lisp 2008-07-18 05:03:18 UTC (rev 3497) +++ trunk/projects/bos/web/contract-tree.lisp 2008-07-18 10:33:20 UTC (rev 3498) @@ -20,9 +20,17 @@ (defun contract-node-find-corresponding-store-image (node) (let ((store-images (get-keyword-store-images (contract-node-keyword node)))) - (when (< 1 (length store-images)) - (warn "~D store-images for ~S" (length store-images) node)) - (first store-images))) + (if (alexandria:length= 1 store-images) + ;; good, there is only one + (first store-images) + ;; We will just return NIL, if we cannot find one. + ;; If there are too many, we will return the newest one and delete the rest. + (progn + (warn "~D store-images for ~S" (length store-images) node) + (let ((store-images-newest-first + (sort (copy-list store-images) #'> :key #'blob-timestamp))) + (mapc #'delete-object (rest store-images-newest-first)) + (first store-images-newest-first)))))) (defmethod initialize-instance :after ((node contract-node) &key args) (declare (ignore args)) @@ -34,9 +42,8 @@ (defvar *contract-tree* nil) (defparameter *contract-tree-images-size* 128) ; was 256 -;;; XXX soll spaeter von was anderem abhaengen (defmethod leaf-node-p ((node contract-node)) - (= 9 (depth node))) + (= 10 (depth node))) (defun contract-geo-box (contract) (destructuring-bind (x y width height) @@ -296,7 +303,8 @@ (with-query-params (path) (let* ((path (parse-path path)) (node (find-node-with-path *contract-tree* path)) - (image (image node))) + (image (image node))) + (assert image nil "contract-tree node ~{~D~} does not have an image" path) (hunchentoot:handle-if-modified-since (blob-timestamp image)) (with-store-image* (image) (emit-image-to-browser cl-gd:*default-image* :png

1 0

[bknr-cvs] hans changed trunk/thirdparty/usocket/backend/
by BKNR Commits 18 Jul '08

18 Jul '08

Revision: 3497 Author: hans URL: http://bknr.net/trac/changeset/3497 add ignored nodelay argument to all backends U trunk/thirdparty/usocket/backend/allegro.lisp U trunk/thirdparty/usocket/backend/armedbear.lisp U trunk/thirdparty/usocket/backend/clisp.lisp U trunk/thirdparty/usocket/backend/cmucl.lisp U trunk/thirdparty/usocket/backend/lispworks.lisp U trunk/thirdparty/usocket/backend/sbcl.lisp U trunk/thirdparty/usocket/backend/scl.lisp Modified: trunk/thirdparty/usocket/backend/allegro.lisp =================================================================== --- trunk/thirdparty/usocket/backend/allegro.lisp 2008-07-18 04:47:37 UTC (rev 3496) +++ trunk/thirdparty/usocket/backend/allegro.lisp 2008-07-18 05:03:18 UTC (rev 3497) @@ -49,7 +49,8 @@ :text :binary)) -(defun socket-connect (host port &key (element-type 'character) timeout) +(defun socket-connect (host port &key (element-type 'character) timeout nodelay) + (declare (ignore nodelay)) (when timeout (warn "SOCKET-CONNECT timeout not supported in Allegro CL")) (let ((socket)) Modified: trunk/thirdparty/usocket/backend/armedbear.lisp =================================================================== --- trunk/thirdparty/usocket/backend/armedbear.lisp 2008-07-18 04:47:37 UTC (rev 3496) +++ trunk/thirdparty/usocket/backend/armedbear.lisp 2008-07-18 05:03:18 UTC (rev 3497) @@ -185,7 +185,8 @@ (typecase condition (error (error 'unknown-error :socket socket :real-error condition)))) -(defun socket-connect (host port &key (element-type 'character) timeout) +(defun socket-connect (host port &key (element-type 'character) timeout nodelay) + (declare (ignore nodelay)) (when timeout (warn "SOCKET-CONNECT timeout not supported in ABCL")) (let ((usock)) Modified: trunk/thirdparty/usocket/backend/clisp.lisp =================================================================== --- trunk/thirdparty/usocket/backend/clisp.lisp 2008-07-18 04:47:37 UTC (rev 3496) +++ trunk/thirdparty/usocket/backend/clisp.lisp 2008-07-18 05:03:18 UTC (rev 3497) @@ -55,7 +55,8 @@ (error usock-err :socket socket) (signal usock-err :socket socket))))))) -(defun socket-connect (host port &key (element-type 'character) timeout) +(defun socket-connect (host port &key (element-type 'character) timeout nodelay) + (declare (ignore nodelay)) (when timeout (warn "SOCKET-CONNECT timeout not supported in CLISP")) (let ((socket) Modified: trunk/thirdparty/usocket/backend/cmucl.lisp =================================================================== --- trunk/thirdparty/usocket/backend/cmucl.lisp 2008-07-18 04:47:37 UTC (rev 3496) +++ trunk/thirdparty/usocket/backend/cmucl.lisp 2008-07-18 05:03:18 UTC (rev 3497) @@ -50,7 +50,8 @@ :socket socket :condition condition)))) -(defun socket-connect (host port &key (element-type 'character) timeout) +(defun socket-connect (host port &key (element-type 'character) timeout nodelay) + (declare (ignore nodelay)) (when timeout (warn "SOCKET-CONNECT timeout not supported in CMUCL")) (let* ((socket)) Modified: trunk/thirdparty/usocket/backend/lispworks.lisp =================================================================== --- trunk/thirdparty/usocket/backend/lispworks.lisp 2008-07-18 04:47:37 UTC (rev 3496) +++ trunk/thirdparty/usocket/backend/lispworks.lisp 2008-07-18 05:03:18 UTC (rev 3497) @@ -73,7 +73,8 @@ (declare (ignore host port err-msg)) (raise-usock-err errno socket condition))))) -(defun socket-connect (host port &key (element-type 'base-char) timeout) +(defun socket-connect (host port &key (element-type 'base-char) timeout nodelay) + (declare (ignore nodelay)) (when timeout (warn "SOCKET-CONNECT timeout not supported in Lispworks")) (let ((hostname (host-to-hostname host)) Modified: trunk/thirdparty/usocket/backend/sbcl.lisp =================================================================== --- trunk/thirdparty/usocket/backend/sbcl.lisp 2008-07-18 04:47:37 UTC (rev 3496) +++ trunk/thirdparty/usocket/backend/sbcl.lisp 2008-07-18 05:03:18 UTC (rev 3497) @@ -186,7 +186,8 @@ (signal usock-cond :socket socket)))))) -(defun socket-connect (host port &key (element-type 'character) timeout deadline) +(defun socket-connect (host port &key (element-type 'character) timeout deadline nodelay) + (declare (ignore nodelay)) (declare (ignore deadline)) (when timeout (warn "SOCKET-CONNECT timeout not supported in SBCL")) Modified: trunk/thirdparty/usocket/backend/scl.lisp =================================================================== --- trunk/thirdparty/usocket/backend/scl.lisp 2008-07-18 04:47:37 UTC (rev 3496) +++ trunk/thirdparty/usocket/backend/scl.lisp 2008-07-18 05:03:18 UTC (rev 3497) @@ -28,7 +28,8 @@ :socket socket :condition condition)))) -(defun socket-connect (host port &key (element-type 'character) timeout) +(defun socket-connect (host port &key (element-type 'character) timeout nodelay) + (declare (ignore nodelay)) (when timeout (warn "SOCKET-CONNECT timeout not supported in SCL")) (let* ((socket (with-mapped-conditions ()

1 0

[bknr-cvs] hans changed trunk/bknr/datastore/doc/indices.tex
by BKNR Commits 18 Jul '08

18 Jul '08

Revision: 3496 Author: hans URL: http://bknr.net/trac/changeset/3496 Correct typo, thanks to Stan Parman (?) for reporting. U trunk/bknr/datastore/doc/indices.tex Modified: trunk/bknr/datastore/doc/indices.tex =================================================================== --- trunk/bknr/datastore/doc/indices.tex 2008-07-17 16:06:40 UTC (rev 3495) +++ trunk/bknr/datastore/doc/indices.tex 2008-07-18 04:47:37 UTC (rev 3496) @@ -148,7 +148,7 @@ \begin{Verbatim}[fontsize=\small,frame=leftline,framerule=0.9mm,rulecolor=\color{gray},framesep=5.1mm,xleftmargin=5mm,fontfamily=cmtt] (make-instance 'gorilla :name "Lucy" :description :aggressive) (make-instance 'gorilla :name "Robert" :description :playful) -(make-instance 'gorilla :name "John" :description :aggressive))) +(make-instance 'gorilla :name "John" :description :aggressive) (all-gorillas) ; => (#<GORILLA "Lucy"> #<GORILLA "Robert"> #<GORILLA "John">)

1 0

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

17 Jul '08

Revision: 3495 Author: hans URL: http://bknr.net/trac/changeset/3495 Add :NODELAY argument to SOCKET-CONNECT to disable TCP start-up delays. CCL only. U trunk/thirdparty/usocket/backend/openmcl.lisp Modified: trunk/thirdparty/usocket/backend/openmcl.lisp =================================================================== --- trunk/thirdparty/usocket/backend/openmcl.lisp 2008-07-17 16:00:11 UTC (rev 3494) +++ trunk/thirdparty/usocket/backend/openmcl.lisp 2008-07-17 16:06:40 UTC (rev 3495) @@ -72,13 +72,14 @@ :text :binary)) -(defun socket-connect (host port &key (element-type 'character) timeout deadline) +(defun socket-connect (host port &key (element-type 'character) timeout deadline nodelay) (with-mapped-conditions () (let ((mcl-sock (openmcl-socket:make-socket :remote-host (host-to-hostname host) :remote-port port :format (to-format element-type) :deadline deadline + :nodelay nodelay :connect-timeout (and timeout (* timeout internal-time-units-per-second))))) (openmcl-socket:socket-connect mcl-sock)

1 0

[bknr-cvs] hans changed trunk/thirdparty/drakma/request.lisp
by BKNR Commits 17 Jul '08

17 Jul '08

Revision: 3494 Author: hans URL: http://bknr.net/trac/changeset/3494 Add :deadline keyword argument, available only on CCL 1.2+ U trunk/thirdparty/drakma/request.lisp Modified: trunk/thirdparty/drakma/request.lisp =================================================================== --- trunk/thirdparty/drakma/request.lisp 2008-07-17 15:18:01 UTC (rev 3493) +++ trunk/thirdparty/drakma/request.lisp 2008-07-17 16:00:11 UTC (rev 3494) @@ -201,7 +201,9 @@ #+:lispworks (connection-timeout 20) #+:lispworks (read-timeout 20) #+(and :lispworks (not :lw-does-not-have-write-timeout)) - (write-timeout 20 write-timeout-provided-p)) + (write-timeout 20 write-timeout-provided-p) + #+openmcl + deadline) "Sends an HTTP request to a web server and returns its reply. URI is where the request is sent to, and it is either a string denoting a uniform resource identifier or a PURI:URI object. The scheme of URI @@ -376,7 +378,14 @@ arguments can also be NIL \(meaning no timeout), and they don't apply if an existing stream is re-used. All timeout keyword arguments are only available for LispWorks, WRITE-TIMEOUT is only available for -LispWorks 5.0 or higher." +LispWorks 5.0 or higher. + +DEADLINE, a time in the future, specifies the time until which the +request should be finished. The DEADLINE is specified in internal +time units (see (GET-INTERNAL-TIME-UNITS) and +INTERNAL-TIME-UNITS-PER-SECOND). If the server fails to respond until +that time, a COMMUNICATION-DEADLINE-EXPIRED condition is signalled. +DEADLINE is available on CCL 1.2 and later." (unless (member protocol '(:http/1.0 :http/1.1) :test #'eq) (error "Don't know how to handle protocol ~S." protocol)) (setq uri (cond ((uri-p uri) (copy-uri uri)) @@ -445,7 +454,17 @@ :errorp t) #-:lispworks (usocket:socket-stream - (usocket:socket-connect host port :element-type 'octet)))) + (usocket:socket-connect host port + :element-type 'octet + #+openmcl #+openmcl + :deadline deadline + :nodelay t)))) + #+openmcl + (when deadline + ;; It is correct to set the deadline here even though it may have been initialized + ;; by SOCKET-CONNECT already: The stream may have been passed in by the user and + ;; the user may want to adjust the deadline for every request. + (setf (ccl:stream-deadline http-stream) deadline)) (when (and use-ssl ;; don't attach SSL to existing streams (not stream))

1 0

← Newer
1
...
19
20
21
22
23
24
25
...
33
Older →

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

bknr-cvs July 2008