The following patch (along with the patch from the pervious email) fixes the error I was seeing before:
diff --git a/handlers.lisp b/handlers.lisp index 8f00ea6..ccc25b7 100755 --- a/handlers.lisp +++ b/handlers.lisp @@ -78,8 +78,7 @@ is needed to work around problems with some Microsoft DAV clients.") (defun options-handler () "The handler for OPTIONS requests. Output is basically determined by *ALLOWED-METHODS* and *DAV-COMPLIANCE-CLASSES*." - (setf (content-type) nil - (header-out :allow) (format nil "~{~A~^, ~}" *allowed-methods*) + (setf (header-out :allow) (format nil "~{~A~^, ~}" *allowed-methods*) (header-out :dav) (format nil "~{~D~^,~}" *dav-compliance- classes*) ;; Win2k wants this - sigh... (header-out :ms-author-via) "DAV")
This gets cl-webdav (at least for the trivial stuff I tried) working again on the new hunchentoot code.
Cyrus
On Jun 23, 2008, at 4:47 PM, Cyrus Harmon wrote:
Now I get the following:
[2008-06-23 16:38:23 [ERROR]] The value of HUNCHENTOOT::NEW-VALUE is NIL, which is not of type STRING. 0: (SB-DEBUG::MAP-BACKTRACE #<CLOSURE (LAMBDA #) {11DC2185}>) [:EXTERNAL] 1: (BACKTRACE 536870911 #<SB-IMPL::STRING-OUTPUT-STREAM {11DC2121}>) 2: (HUNCHENTOOT:GET-BACKTRACE #<unavailable argument>) 3: ((FLET #:LAMBDA452) #<SIMPLE-TYPE-ERROR {11DC1DA9}>) 4: (SIGNAL #<SIMPLE-TYPE-ERROR {11DC1DA9}>)[:EXTERNAL] 5: (ERROR #<SIMPLE-TYPE-ERROR {11DC1DA9}>)[:EXTERNAL] 6: (SB-KERNEL:CHECK-TYPE-ERROR HUNCHENTOOT::NEW-VALUE NIL STRING NIL) 7: ((SB-PCL::FAST-METHOD (SETF HUNCHENTOOT:HEADER-OUT) :AFTER (T (EQL :CONTENT-TYPE))) #<unused argument> #<unused argument> #<unavailable argument> #<unused argument> #<HUNCHENTOOT::REPLY {11DBEDC1}>) 8: ((LAMBDA (SB-PCL::.PV. SB-PCL::.NEXT-METHOD-CALL. SB-PCL::.ARG0. SB- PCL::.ARG1. SB-INT:&MORE SB-PCL::.DFUN-MORE-CONTEXT. SB-PCL::.DFUN-MORE- COUNT.)) #<unused argument> #<unused argument> NIL :CONTENT-TYPE 32810581
9: (CL-WEBDAV:OPTIONS-HANDLER) 10: ((LAMBDA ())) 11: (HUNCHENTOOT::PROCESS-REQUEST #<HUNCHENTOOT:REQUEST {11DC1AA9}>) 12: ((SB-PCL::FAST-METHOD HUNCHENTOOT::PROCESS-CONNECTION (T T)) #<unavailable argument> #<unavailable argument> #<HUNCHENTOOT::SERVER (host *, port 4242)> #<USOCKET:STREAM-USOCKET {11DB9CA1}>) 13: ((SB-PCL::FAST-METHOD HUNCHENTOOT::PROCESS-CONNECTION :AROUND (T T)) #<unavailable argument> #S(SB-PCL::FAST-METHOD-CALL :FUNCTION #<FUNCTION #> :PV NIL :NEXT-METHOD-CALL NIL :ARG-INFO (2)) #<HUNCHENTOOT::SERVER (host *, port 4242)> #<USOCKET:STREAM-USOCKET {11DB9CA1}>) 14: ((FLET SB-THREAD::WITH-MUTEX-THUNK)) 15: ((FLET #:WITHOUT-INTERRUPTS-BODY-[CALL-WITH-MUTEX]479)) 16: (SB-THREAD::CALL-WITH-MUTEX #<CLOSURE (FLET SB-THREAD::WITH-MUTEX-THUNK) {7D29DA5}> #S(SB-THREAD:MUTEX :NAME "thread result lock" :%OWNER #<SB-THREAD:THREAD "Hunchentoot worker (client: 127.0.0.1:59658)" RUNNING {11DBCE49}> :LUTEX #<unknown pointer object, widetag=#x5E {11DBCE17}>) #<SB-THREAD:THREAD "Hunchentoot worker (client: 127.0.0.1:59658)" RUNNING {11DBCE49}> T) 17: ((LAMBDA ())) 18: ("foreign function: call_into_lisp") 19: ("foreign function: funcall0") 20: ("foreign function: new_thread_trampoline") 21: ("foreign function: _pthread_start") 22: ("foreign function: thread_start")
still digging...
Cyrus
On Jun 23, 2008, at 4:36 PM, Cyrus Harmon wrote:
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+)))@@ -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)))
- (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+))))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+))))
tbnl-devel site list tbnl-devel@common-lisp.net http://common-lisp.net/mailman/listinfo/tbnl-devel
tbnl-devel site list tbnl-devel@common-lisp.net http://common-lisp.net/mailman/listinfo/tbnl-devel