[hunchentoot-devel] cl-webdav errors
Cyrus Harmon
ch-tbnl at bobobeach.com
Mon Jun 23 23:36:10 UTC 2008
On Jun 23, 2008, at 4:16 PM, Edi Weitz wrote:
> On Mon, 23 Jun 2008 15:50:27 -0700, Cyrus Harmon <ch-tbnl at 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+))))
More information about the Tbnl-devel
mailing list