Changeset 11593 in project


Ignore:
Timestamp:
08/10/08 20:54:21 (12 years ago)
Author:
sjamaan
Message:

Add fix for error that didn't get caught by test-error from the test egg
Add convenience procedure for adding headers (not completely done)

Location:
release/4/intarweb/trunk
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/4/intarweb/trunk/intarweb.scm

    r11592 r11593  
    3939(module intarweb
    4040  (read-line-limit update-header-contents update-header-contents!
    41    append-header-contents append-header-contents!
     41   append-header-contents append-header-contents! make-headers
    4242   string->header-name header-name->string header-name=?
    4343   header-parsers get-header-contents
     
    9393(define (header-name->string h) (symbol->string h))
    9494(define header-name=? eq?)
     95
     96;; Each header-to-be looks like (name value) or (name value params),
     97;; where params is an alist.
     98(define (make-headers headers-to-be #!optional (old-headers '()))
     99  (let loop ((h headers-to-be)
     100             (result old-headers))
     101    (if (null? h)
     102        result
     103        (loop (cdr h)
     104              (apply
     105               (lambda (name value #!optional (params '()))
     106                 (append-header-contents name
     107                                         (make-value+params value params)
     108                                         result))
     109               (car h))))))
    95110
    96111(include "../header-parsers")
     
    128143     (last-modified . ,(single rfc822-time-parser))
    129144     (location . ,(single identity))
    130      (max-forwards . ,natnum-parser)
     145     (max-forwards . ,(single natnum-parser))
    131146     (pragma . ,pragma-parser)
    132147     (proxy-authenticate . ,(multiple symbol-parser-ci))
     
    220235
    221236(define (read-request inport)
    222   (let ((line (read-line inport (read-line-limit))))
    223     ; Try each parser in turn to process the request-line.
    224     ; A parser returns either #f or a request object
     237  (let* ((line (read-line inport (read-line-limit)))
     238         ;; A bit ugly, but simpler than the alternatives
     239         (line (if (eof-object? line) "" line)))
     240    ;; Try each parser in turn to process the request-line.
     241    ;; A parser returns either #f or a request object
    225242    (let loop ((parsers (protocol-parsers)))
    226243      (if (null? parsers)
  • release/4/intarweb/trunk/tests/run.scm

    r11592 r11593  
    99    (lambda (in)
    1010      (read-request in))))
     11
     12(define-syntax test-error*
     13  (syntax-rules ()
     14    ((_ ?msg (?error-type ...) ?expr)
     15     (let-syntax ((expression:
     16                   (syntax-rules ()
     17                     ((_ ?expr)
     18                      (condition-case (begin ?expr "<no error thrown>")
     19                                      ((?error-type ...) '(?error-type ...))
     20                                      (exn () (##sys#slot exn 1)))))))
     21       (test ?msg '(?error-type ...) (expression: ?expr))))
     22    ((_ ?msg ?error-type ?expr)
     23     (test-error* ?msg (?error-type) ?expr))
     24    ((_ ?error-type ?expr)
     25     (test-error* (sprintf "~S" '?expr) ?error-type ?expr))))
    1126
    1227(test-group "Request line"
     
    1530                                      ,(lambda (line in)
    1631                                         (and (string=? line "bar") 'bar)))))
    17     (test-error "Unrecognised protocol" (test-read-request "qux"))
     32    (test-error* (http unknown-protocol) (test-read-request "qux"))
     33    (test-error* (http unknown-protocol) (test-read-request ""))
    1834    (test 'foo (test-read-request "foo"))
    1935    (test 'bar (test-read-request "bar")))
Note: See TracChangeset for help on using the changeset viewer.