Changeset 15154 in project


Ignore:
Timestamp:
07/04/09 17:41:36 (10 years ago)
Author:
sjamaan
Message:

Get rid of get-quality procedure, add more useful header-param(s) procedures

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

Legend:

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

    r15151 r15154  
    22
    33;; Get the raw contents of a header
    4 (define (header-contents name headers #!optional (default #f))
     4(define (header-contents name headers #!optional default)
    55  (alist-ref name (headers-v headers) eq? default))
    66
     
    1010
    1111;; Get the value of a header, assuming it has only one value
    12 (define (header-value header-name headers #!optional (default #f))
     12(define (header-value header-name headers #!optional default)
    1313  (let ((contents (header-contents header-name headers '())))
    1414    (if (null? contents)
     
    1616        (get-value (car contents)))))
    1717
     18;; Get the parameters of a header, assuming it has only one value
     19(define (header-params header-name headers)
     20  (let ((contents (header-contents header-name headers '())))
     21    (if (null? contents)
     22        '()
     23        (get-params (car contents)))))
     24
     25;; Get a specific parameter of a header, assuming it has only one value
     26(define (header-param header-name param-name headers #!optional default)
     27  (alist-ref param-name (header-params header-name headers) eq? default))
     28
    1829;; Get the value from one header entry
    1930(define get-value (cut vector-ref <> 0))
     
    2536(define (get-param param contents #!optional (default #f))
    2637  (alist-ref param (vector-ref contents 1) eq? default))
    27 
    28 ;; Get-param, except if no quality is present return 1
    29 (define (get-quality header-contents)
    30   (or (get-param 'q header-contents) 1.0))
    3138
    3239;;;; Header parsers
  • release/4/intarweb/trunk/intarweb.scm

    r15151 r15154  
    6363
    6464   ;; http-header-parsers
    65    header-contents header-values header-value
    66    get-value get-params get-param get-quality
     65   header-contents header-values header-value header-params header-param
     66   get-value get-params get-param
    6767
    6868   split-multi-header parse-token parse-comment
  • release/4/intarweb/trunk/tests/run.scm

    r15152 r15154  
    101101     ;; RFC 2616 3.6: "All transfer-coding values are case insensitive".
    102102     ;; This includes the parameter name (attribute) and value.
    103      (test "Explicit quality value (case-insensitive)"
    104            0.5 (get-quality (first accept)))
    105      (test "Explicit quality encoding value"
     103     (test "quality value (case-insensitive)"
     104           0.5 (get-param 'q (first accept) 1.0))
     105     (test "quality encoding value"
    106106           'text/plain (get-value (first accept)))
    107      ;; RFC 2616 3.9
    108      (test "Implicit quality value"
    109            1.0 (get-quality (second accept)))
    110      (test "Implicit quality encoding value"
    111            'text/html (get-value (second accept)))
    112      (test "Quality values have only three digits"
    113            0.123 (get-quality (third accept)))
    114      (test "Quality values maximum is 1.0"
    115            1.0 (get-quality (fourth accept)))
    116      (test "Quality values minimum is 0.0"
    117            0.0 (get-quality (fifth accept)))
    118      (test "Missing quality value ok"
    119            1.0 (get-quality (sixth accept)))))
     107     (test "quality values have only three digits"
     108           0.123 (get-param 'q (third accept) 1.0))
     109     (test "quality values maximum is 1.0"
     110           1.0 (get-param 'q (fourth accept) 1.0))
     111     (test "quality values minimum is 0.0"
     112           0.0 (get-param 'q (fifth accept) 1.0))
     113     (test "missing quality value ok"
     114           1.0 (get-param 'q (sixth accept) 1.0))))
    120115
    121116  (test-group "Symbol-parser-ci"
     
    158153      (test "Acts like a multi-header"
    159154            '(must-revalidate . #t) (assq 'must-revalidate (header-values 'cache-control headers)))))
    160 
     155 
    161156  (test-group "pragma-parser"
    162157    (let ((headers (test-read-headers "Pragma: custom-value=10, no-cache")))
Note: See TracChangeset for help on using the changeset viewer.