Ignore:
Timestamp:
09/06/08 23:26:16 (13 years ago)
Author:
sjamaan
Message:

Simplify the parsers a bit, in preparation for comment parsing

File:
1 edited

Legend:

Unmodified
Added
Removed
  • release/4/intarweb/trunk/header-parsers.scm

    r11910 r11912  
    66
    77(define (quality-parser str)
    8   (let* ((num       (or (string->number str) 0))
     8  ;; Anything that's not a number is seen as if the value is missing, hence 1.0
     9  (let* ((num       (or (string->number str) 1.0))
    910         (imprecise (chop-number num 3)))
    1011    (max 0.0 (min 1.0 imprecise))))
     
    4445;;;; Header parsers
    4546
     47;; Find a matching endpoint for a token, ignoring escaped copies of the token
     48(define (escaped-string-end str start stop-char-set)
     49  (let ((len (string-length str)))
     50    (let loop ((start start))
     51      (let ((pos (string-index str (char-set-adjoin stop-char-set #\\) start)))
     52        (if pos
     53            (if (char=? #\\ (string-ref str pos))
     54                ;; Escaped matching closing symbol
     55                (if (= len (add1 pos))
     56                    pos
     57                    (loop (+ pos 2)))
     58                ;; Reached the matching closing symbol
     59                pos)
     60            len))))) ; No matching closing symbol?  "Insert" it at the end
     61
    4662;; RFC 2616 4.2 says multi-headers are a comma-separated list of tokens
    47 (define (split-multi-header value #!optional (parse? #t))
    48   (let loop ((result '())
    49              (start-pos 0))
    50     (receive (str pos)
    51       (read-token value start-pos (char-set #\,) parse?)
    52       (if str
    53           (loop (cons str result) (add1 pos))
    54           (reverse result)))))
    55 
    56 ;; This is ugly, it should be rewritten
    57 (define (read-token value start-pos stop-char-set #!optional (parse? #t))
    58   (let ((length (string-length value))
    59         (escaped? #f)
    60         (in-string? #f))
    61     (if (>= start-pos length)
    62         (values #f start-pos)
    63         (let loop ((start start-pos)
    64                    (stop  start-pos)
    65                    (str   ""))
    66           (cond
    67            ((= stop (sub1 length))
    68             (values (string-append str
    69                                    ((if in-string? identity string-trim-both)
    70                                     (string-copy value start (if (and parse? in-string?)
    71                                                                  (sub1 length)
    72                                                                  length))))
    73                     stop))
    74            (escaped?
    75             (set! escaped? #f)
    76             (loop (add1 stop) (add1 stop)
    77                   (string-append str (string-copy value stop (add1 stop)))))
    78            ((and in-string? (char=? (string-ref value stop) #\\))
    79             (set! escaped? #t)
    80             (loop (add1 stop) (add1 stop)
    81                   (string-append str
    82                                  (string-copy value start stop)
    83                                  (if parse? "" "\\"))))
    84            ((char=? (string-ref value stop) #\")
    85             (set! in-string? (not in-string?))
    86             (loop (add1 stop) (add1 stop)
    87                   (string-append
    88                    (string-trim-both str)
    89                    (if (not in-string?)
    90                        (string-copy value start stop)
    91                        (string-trim-both (string-copy value start stop)))
    92                    (if (not parse?) "\"" ""))))
    93            ((and (not in-string?)
    94                  (char-set-contains? stop-char-set (string-ref value stop)))
    95             (values (string-append
    96                      str
    97                      (string-trim-both (string-copy value start stop)))
    98                     stop))
    99            (else (loop start (add1 stop) str)))))))
     63(define (split-multi-header value)
     64  (let ((len (string-length value)))
     65    (let loop ((result '())
     66               (start-pos 0)   ; Where the current header value starts
     67               (read-pos 0))       ; Where the reading position starts
     68      (or (and-let* (((< read-pos len))
     69                     (pos (string-index value (char-set #\, #\") read-pos)))
     70            (if (char=? #\, (string-ref value pos))
     71                (loop (cons (string-copy value start-pos pos) result) (add1 pos) (add1 pos))
     72                (let ((end-pos (escaped-string-end value (add1 pos) (char-set #\"))))
     73                  (loop result start-pos (add1 end-pos)))))
     74          (reverse (cons (string-drop value start-pos) result))))))
     75
     76;; Remove all escape characters from the input, recognising "escaped escapes"
     77(define (unescape str)
     78  (let ((last-char (sub1 (string-length str))))
     79    (let loop ((result "")
     80               (start-pos 0))
     81      (or (and-let* ((pos (string-index str #\\ start-pos)))
     82            (if (= pos last-char)
     83                (string-append result (string-copy str start-pos))
     84                (loop (string-append result (string-copy str start-pos pos)
     85                                     (string-copy str (add1 pos) (+ pos 2)))
     86                      (+ pos 2))))
     87          (string-append result (string-copy str start-pos))))))
     88
     89;; Try to parse a token, starting at the provided offset, up until the
     90;; char-set where we should stop.  Returns two values: the token or #f if
     91;; there is no token left, and the position on which the token ends.
     92(define (read-token value start-pos stop-char-set)
     93  (if (>= start-pos (string-length value))
     94      (values #f start-pos)
     95      (let ((stop (char-set-adjoin stop-char-set #\")))
     96        (let ((pos (string-index value stop start-pos)))
     97          (if pos
     98              (if (not (char=? #\" (string-ref value pos)))
     99                  (values (string-trim-both (string-copy value start-pos pos))
     100                          pos) ; Stop-char found, but no quoting
     101                  (let ((end-pos (escaped-string-end value (add1 pos)
     102                                                     (char-set #\"))))
     103                    ;; Found the double quote? Recurse on the remainder
     104                    (receive (rest final-pos)
     105                      (read-token value (add1 end-pos) stop-char-set)
     106                      (values (string-append
     107                               (string-trim-both
     108                                (string-copy value start-pos pos))
     109                               (if (= pos end-pos)
     110                                   (unescape (string-copy value (add1 pos)))
     111                                   (unescape (string-copy value (add1 pos) end-pos)))
     112                               (or rest ""))
     113                              final-pos))))
     114              ;; Nothing found?  Then the remainder of the string is the token
     115              (values (string-trim-both (string-copy value start-pos))
     116                      (string-length value)))))))
    100117
    101118;; Just put all header strings in a list, so we can pass it on
     
    106123  (update-header-contents! name (list (vector contents '())) headers))
    107124
    108 (define (read-tokens string start-pos . char-sets)
    109   (let loop ((char-sets char-sets)
    110              (start-pos start-pos)
    111              (result    '()))
    112     (if (null? char-sets)
    113         (values (reverse result) start-pos)
    114         (receive (str pos)
    115                  (read-token string start-pos (car char-sets))
    116                  (if str
    117                      (loop (cdr char-sets) (add1 pos) (cons str result))
    118                      (values (reverse result) pos))))))
    119 
    120125(define (read-parameters string start-pos param-parsers)
    121126  (let loop ((start-pos start-pos)
     
    124129      (read-token string start-pos (char-set #\; #\=))
    125130      (if key
    126           (if (char=? (string-ref string pos) #\=)
     131          (if (and (< pos (string-length string)) (char=? (string-ref string pos) #\=))
    127132              (receive (value pos)
    128133                (read-token string (add1 pos) (char-set #\;))
    129134                (let ((key (string->symbol (string-downcase key))))
    130                   (if value
    131                       (let ((value ((alist-ref key param-parsers eq? identity) value)))
    132                         (loop (add1 pos) (cons (cons key value) params)))
    133                       ;; "foo=" - use the empty string as value
    134                       (values (reverse (cons (cons key "") params)) pos))))
     135                  ;; In case of no value ("foo="), use the empty string as value
     136                  (let ((value ((alist-ref key param-parsers eq? identity) (or value ""))))
     137                    (loop (add1 pos) (cons (cons key value) params)))))
    135138              ;; Missing value is interpreted as "present",
    136139              ;; so #t. If not present, it's #f when looking it up
     
    142145    (read-token string start-pos (char-set #\;))
    143146    (if (not value)
    144         (values #f pos)
     147        (values #f pos) ;; XXX this is wrong and not expected by the caller!
    145148        (receive (params pos)
    146149          (read-parameters string (add1 pos) param-parsers)
     
    161164             headers))
    162165          headers
    163           (split-multi-header entries #f))))
     166          (split-multi-header entries))))
    164167
    165168(define (single other-parser #!optional (parameter-parsers '()))
Note: See TracChangeset for help on using the changeset viewer.