On Jun 23, 2008, at 4:16 PM, Edi Weitz wrote:
On Mon, 23 Jun 2008 15:50:27 -0700, Cyrus Harmon <ch-tbnl@bobobeach.com
wrote:
I'm getting some errors attempting to build the latest cl-webdav with the latest ediware/sbcl combo.
Yes, that's to be expected. I haven't looked at cl-webdav in the last months.
Hmm... ok.
are we attempting to do something out of the CL spec here or is SBCL choking on legal code?
I think SBCL is right. (CONSTANTLY NIL) should be replaced by the name of a function which does the same.
Alright, I'm taking a stab at getting this to work then. It sort builds now, but doesn't work.
In an effort to figure out why not, I've discovered that tbnl:*catch- errors-p* is still exported but doesn't exist anymore.
Here's my first cut at things:
diff --git a/handlers.lisp b/handlers.lisp index 8f00ea6..2facb08 100755 --- a/handlers.lisp +++ b/handlers.lisp @@ -91,7 +91,7 @@ determined by *ALLOWED-METHODS* and *DAV-COMPLIANCE- CLASSES*." content body (if there is one) and returns a corresponding "multistatus" XML element using the methods for live and dead properties." - (let* ((depth-header (header-in :depth)) + (let* ((depth-header (header-in* :depth)) (depth-value (cond ((or (null depth-header) (string-equal depth-header "infinity")) nil) ((string= depth-header "0") 0) @@ -177,7 +177,7 @@ HEAD-REQUEST-P is true." (setf (header-out :content-language) content-language)) (catch 'handler-done (handle-if-modified-since write-date) - (when (equal etag (header-in :if-none-match)) + (when (equal etag (header-in* :if-none-match)) (setf (return-code) +http-not-modified+))) (when (eql (return-code) +http-not-modified+) (throw 'handler-done nil)) @@ -219,7 +219,7 @@ instead." (defun delete-handler () "The handler for DELETE requests. Uses REMOVE-RESOURCE* to do the actual work." - (let ((depth-header (header-in :depth))) + (let ((depth-header (header-in* :depth))) (unless (or (null depth-header) (string-equal depth-header "infinity")) (warn "Depth header is ~S." depth-header) @@ -243,7 +243,7 @@ new resource from the contents sent by the client." (let ((parent (resource-parent resource))) (when (or (null parent) (not (resource-exists parent))) (conflict))) - (let* ((content-length-header (cdr (assoc :content-length (headers-in)))) + (let* ((content-length-header (cdr (assoc :content-length (headers-in*)))) (content-length (and content-length-header (parse-integer content-length- header :junk-allowed t)))) (unless content-length @@ -255,21 +255,21 @@ new resource from the contents sent by the client." "The handler for COPY requests which internally uses COPY-OR-MOVE-RESOURCE* to do the actual work. Also doubles as a handler for MOVE requests if MOVEP is true." - (let* ((depth-header (header-in :depth)) + (let* ((depth-header (header-in* :depth)) (depth-value (cond ((or (null depth-header) (string-equal depth-header "infinity")) nil) ((and (string= depth-header "0") (not movep)) 0) (t (warn "Depth header is ~S." depth- header) (bad-request)))) - (overwrite (equal (header-in :overwrite) "T")) + (overwrite (equal (header-in* :overwrite) "T")) (source (get-resource))) ;; note that we ignore a possible request body and thus the ;; "propertybehaviour" XML element for now - we just try to use ;; best effort to copy/move all properties (unless (resource-exists source) (not-found)) - (let ((destination-header (header-in :destination))) + (let ((destination-header (header-in* :destination))) (unless destination-header (warn "No 'Destination' header.") (bad-request)) diff --git a/properties.lisp b/properties.lisp index f0b0b28..49489c2 100755 --- a/properties.lisp +++ b/properties.lisp @@ -80,10 +80,10 @@ found) the property itself." (let ((property (handler-case (get-property resource property-designator) (error (condition) - (log-message* "While trying to get property ~S for resource ~S: ~A" - (local-name property-designator) - (resource-script-name resource) - condition) + (log-message "While trying to get property ~S for resource ~S: ~A" + (local-name property-designator) + (resource-script-name resource) + condition) +http-internal-server-error+)))) (etypecase property (null (values +http-ok+ property-designator)) diff --git a/resources.lisp b/resources.lisp index 55cffdf..613667d 100755 --- a/resources.lisp +++ b/resources.lisp @@ -390,7 +390,7 @@ name SCRIPT-NAME (which is already URL-decoded).") (make-instance resource-class-name :script-name script-name)))
-(defun get-resource (&optional (script-name (url-decode* (script- name)))) +(defun get-resource (&optional (script-name (url-decode* (script- name*)))) "Creates and returns an object of the type stored in *RESOURCE-CLASS* corresponding to the script name SCRIPT-NAME." (create-resource *resource-class* script-name)) diff --git a/specials.lisp b/specials.lisp index f4fefc7..2bfb12f 100755 --- a/specials.lisp +++ b/specials.lisp @@ -36,6 +36,10 @@ `(cl:defconstant ,name (if (boundp ',name) (symbol-value ',name) ,value) ,@(when doc (list doc)))))
+(defun constantly-nil (&rest args) + (declare (ignore args)) + nil) + (defconstant +dav-property-alist+ `(("creationdate" . creation-date) ("displayname" . resource-display-name) @@ -46,8 +50,8 @@ ("getcontentlanguage" . resource-content-language) ("resourcetype" . resource-type) ("source" . resource-source) - ("lockdiscovery" . ,(constantly nil)) - ("supportedlock" . ,(constantly nil))) + ("lockdiscovery" . constantly-nil) + ("supportedlock" . constantly-nil)) "An alist mapping the (names of the) standard DAV properties to functions handling them.")
diff --git a/util.lisp b/util.lisp index 85b3afd..4f85165 100755 --- a/util.lisp +++ b/util.lisp @@ -90,5 +90,5 @@ then uses LATIN-1 if that fails." ;; LATIN-1... (handler-case (url-decode string +utf-8+) - (flex:flexi-stream-encoding-error () + (flex:external-format-encoding-error () (url-decode string +latin-1+))))