Skip to content

Commit

Permalink
aserve update and webactions 1.8
Browse files Browse the repository at this point in the history
  • Loading branch information
jkf committed Mar 4, 2004
1 parent 09ca94c commit 7b4c043
Show file tree
Hide file tree
Showing 8 changed files with 211 additions and 89 deletions.
6 changes: 6 additions & 0 deletions ChangeLog
View file
Original file line number Diff line number Diff line change
@@ -1,3 +1,9 @@
2004-03-04 John Foderaro <jkf@tiger.franz.com>

* main.cl - ensure that get-request-body always reads from
a stream with the :octets external format so that the
content-length header value is meaningful.

2004-03-03 <jkf@main.verada.com>
1.2.36
* main.cl: add request-variable-value (moved from webactions)
Expand Down
151 changes: 84 additions & 67 deletions main.cl
View file
Original file line number Diff line number Diff line change
Expand Up @@ -24,7 +24,7 @@
;; Suite 330, Boston, MA 02111-1307 USA
;;
;;
;; $Id: main.cl,v 1.158 2004/03/04 01:57:33 jkf Exp $
;; $Id: main.cl,v 1.159 2004/03/04 21:52:38 jkf Exp $

;; Description:
;; aserve's main loop
Expand Down Expand Up @@ -1545,72 +1545,12 @@ by keyword symbols and not by strings"

(defmethod get-request-body ((req http-request)
&key (external-format :octets ef-supplied))
(let ((result
;; return a string that holds the body of the http-request
;; cache it for later too
(or (request-request-body req)
(setf (request-request-body req)
(if* (member (request-method req) '(:put :post))
then (multiple-value-bind (length believe-it)
(header-slot-value-integer req :content-length)
(if* believe-it
then ; we know the length
(prog1 (let ((ret (make-string length)))
(read-sequence-with-timeout
ret length
(request-socket req)
*read-request-body-timeout*))

; netscape (at least) is buggy in that
; it sends a crlf after
; the body. We have to eat that crlf.
; We could check
; which browser is calling us but it's
; not clear what
; is the set of buggy browsers
(let ((ch (read-char-no-hang
(request-socket req)
nil nil)))
(if* (eq ch #\return)
then ; now look for linefeed
(setq ch (read-char-no-hang
(request-socket req)
nil nil))
(if* (eq ch #\linefeed)
thenret
else (unread-char
ch (request-socket req)))
elseif ch
then (unread-char ch (request-socket
req)))))


else ; no content length given

(if* (equalp "keep-alive"
(header-slot-value req
:connection))
then ; must be no body
""
else ; read until the end of file
(with-timeout-local
(*read-request-body-timeout*
nil)
(let ((ans (make-array
2048
:element-type 'character
:fill-pointer 0))
(sock (request-socket req))
(ch))
(loop (if* (eq :eof
(setq ch
(read-char
sock nil :eof)))
then (return ans)
else (vector-push-extend
ch ans))))))))
else "" ; no body
)))))
(let* ((result
;; return a string that holds the body of the http-request
;; cache it for later too
(or (request-request-body req)
(setf (request-request-body req)
(get-request-body-retrieve req)))))
(if* ef-supplied ; spr27296
then (values
(octets-to-string
Expand All @@ -1619,6 +1559,83 @@ by keyword symbols and not by strings"
else result)))


(defun get-request-body-retrieve (req)
;; get the guts of the body into a string.
;; we'll always use the :octets external format to retrieve the string
;; so the characters may not be correct however later external
;; format processing will fix that.
(let ((original-ef (stream-external-format (request-socket req))))

; must read using the octets external format because the
; content length is in terms of octets
(setf (stream-external-format (request-socket req))
(find-external-format :octets))

(unwind-protect
(if* (member (request-method req) '(:put :post))
then (multiple-value-bind (length believe-it)
(header-slot-value-integer req :content-length)
(if* believe-it
then ; we know the length
(prog1 (let ((ret (make-string length)))
(read-sequence-with-timeout
ret length
(request-socket req)
*read-request-body-timeout*))

; netscape (at least) is buggy in that
; it sends a crlf after
; the body. We have to eat that crlf.
; We could check
; which browser is calling us but it's
; not clear what
; is the set of buggy browsers
(let ((ch (read-char-no-hang
(request-socket req)
nil nil)))
(if* (eq ch #\return)
then ; now look for linefeed
(setq ch (read-char-no-hang
(request-socket req)
nil nil))
(if* (eq ch #\linefeed)
thenret
else (unread-char
ch (request-socket req)))
elseif ch
then (unread-char ch (request-socket
req)))))


else ; no content length given

(if* (equalp "keep-alive"
(header-slot-value req
:connection))
then ; must be no body
""
else ; read until the end of file
(with-timeout-local
(*read-request-body-timeout*
nil)
(let ((ans (make-array
2048
:element-type 'character
:fill-pointer 0))
(sock (request-socket req))
(ch))
(loop (if* (eq :eof
(setq ch
(read-char
sock nil :eof)))
then (return ans)
else (vector-push-extend
ch ans))))))))
else "" ; no body
)
; uwp cleanup
(setf (stream-external-format (request-socket req)) original-ef)
)))

;; multipart code
;; used when enctype=multipart/form-data is used
Expand Down
5 changes: 5 additions & 0 deletions webactions/ChangeLog
View file
Original file line number Diff line number Diff line change
@@ -1,3 +1,8 @@
2004-03-04 John Foderaro <jkf@tiger.franz.com>
1.8
* clpage.cl - handle nested instances of the same clp_element
* t-webactions.cl - make tests independent of line ending convention

2004-03-03 <jkf@main.verada.com>
1.7
* clwebact.cl: move request-variable-value to allegroserve
Expand Down
73 changes: 71 additions & 2 deletions webactions/clpage.cl
View file
Original file line number Diff line number Diff line change
Expand Up @@ -24,7 +24,7 @@
;; Suite 330, Boston, MA 02111-1307 USA
;;

;; $Id: clpage.cl,v 1.4 2004/03/04 01:57:33 jkf Exp $
;; $Id: clpage.cl,v 1.5 2004/03/04 21:52:38 jkf Exp $


(eval-when (compile load eval) (require :aserve))
Expand Down Expand Up @@ -600,7 +600,7 @@



(defun scan-for-end-tag (p module fcn)
#+ignore(defun old-scan-for-end-tag (p module fcn)
;; look for </module_fcn>
;; leave the file position after the tag
;;
Expand All @@ -625,6 +625,75 @@
(return)))))))



(defun scan-for-end-tag (p module fcn)
;; look for </module_fcn>
;; leave the file position after the tag
;;
;; return the number of characters read not including
;; the end tag
;;
;; return nil if the end tag wasn't found
;;

;; we define a search obj as a cons holding how far we've
;; matched so far and the string we're matching
(macrolet ((create-search-obj (string)
`(cons 0 ,string))

(init-search-obj (obj)
;; set back to initial state
`(setf (car ,obj) 0))

(end-of-search-p (obj)
;; see if we've matched all characters
`(equal (car ,obj) (length (cdr ,obj))))

(search-string (obj)
`(cdr ,obj))

(search-counter (obj)
`(car ,obj))

(match-search-string (obj ch)
`(if* (eql ,ch (schar (search-string ,obj)
(search-counter ,obj)))
then (incf (search-counter ,obj))
else (init-search-obj ,obj))))

(let ((end-tag (create-search-obj (format nil "</~a_~a>" module fcn)))
(start-tag (create-search-obj (format nil "<~a_~a>" module fcn)))
(nest-level 0)
(ch)
(chcount 0))


(loop

(if* (end-of-search-p end-tag)
then (if* (> nest-level 0)
then (decf nest-level)
(init-search-obj end-tag)
else (return (- chcount (length (search-string end-tag))))))

(if* (end-of-search-p start-tag)
then (incf nest-level)
(init-search-obj start-tag))



; get next character ...
(if* (null (setq ch (read-char p nil nil)))
then ; no end tag found
(return nil))

(incf chcount)

;; and look for matches
(match-search-string end-tag ch)
(match-search-string start-tag ch)))))


(defun collect-comment (p)
;; return a text object holding a whole comment
(let ((state 0)
Expand Down
1 change: 1 addition & 0 deletions webactions/test/sitea/file4.clp
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1 @@
X<tweb_foo>Y<tweb_foo>Z</tweb_foo>W</tweb_foo>
3 changes: 3 additions & 0 deletions webactions/test/sitea/project.cl
View file
Original file line number Diff line number Diff line change
Expand Up @@ -33,6 +33,9 @@

("testctype" "file3.clp")
("file3.clp" (:content-type "text/plain"))

; test nested clp elements
("file4" "file4.clp")
))


Expand Down
Loading

0 comments on commit 7b4c043

Please sign in to comment.