source: project/release/3/content-type/trunk/content-type.scm @ 13256

Last change on this file since 13256 was 13256, checked in by Ivan Raikov, 11 years ago

Added support for irregex.

File size: 2.6 KB
Line 
1;; $Id$
2;;
3;; This file is in the public domain and may be reproduced or copied without
4;; permission from its author.  Citation of the source is appreciated.
5;;
6;; Alejandro Forero Cuervo <bachue@bachue.com>
7;;
8;; This file implements an egg for Chicken Scheme that allows you to decode
9;; Content-type headers, as specified in RFC 2045.
10;;
11;; Documentation is available in HTML format.
12;;
13;; Newer versions might be available at:
14;;
15;;    http://anonymous:@afc.no-ip.info:8000/svn/home/src/chicken-eggs/content-type
16;;
17;; Version history:
18;;
19;; 1.0 (r?) - First public release
20
21(declare (export content-type-make content-type-type content-type-subtype content-type-params content-type-param))
22(require-extension regex format-modular)
23
24; TODO: Remove comments from the header before parsing, as specified in RFCs
25; 2045 and 822.
26
27(define token)
28(define type   "[0-9A-Za-z-]+")
29(define pars   "\\s*(|;\\s*.*)$")
30(define quoted "\"[^\"]*\"")
31
32(define irregex-feature?  (member 'irregex: (features)))
33(define pcre-feature?     (member 'pcre: (features)))
34
35(cond
36 (irregex-feature? (set! token "[^()<>@,;:\\\\?=\"\\s]+"))
37 (pcre-feature?    (set! token "[^][()<>@,;:\\\\?=\"\\s]+")))
38
39(define-record content-type type subtype params)
40
41(define content-type-make
42  (let* ((rxstr (format #f (cond (irregex-feature? "^(Content-type:)?\\s*(~A)\\s*/\\s*(~A)~A")
43                                 (pcre-feature?    "\\s*(~A)\\s*/\\s*(~A)~A"))
44                        type type pars))
45         (expr  (regexp rxstr #t)))
46    (lambda (line)
47      (and-let* ((match (string-match expr line)))
48        (call-with-current-continuation
49          (lambda (cont)
50            (let ((match1 (cddr match)))
51              (make-content-type (format #f "~(~A~)" (car match1)) (format #f "~(~A~)" (cadr match1))
52                                 (make-content-type-params cont (caddr match1))))))))))
53
54(define make-content-type-params
55  (let* ((rxstr (format #f "^;\\s*(~A)\\s*=\\s*(~A|~A)~A" token token quoted pars))
56         (expr (regexp rxstr)))
57    (lambda (cont line)
58      (if (equal? line "")
59        '()
60        (let ((match (string-match expr line)))
61          (if match (apply make-content-type-params-cont cont (cdr match)) (cont #f)))))))
62
63(define (parameter-unquote str)
64  (if (and (equal? (string-ref str 0) #\") (equal? (string-ref str (- (string-length str) 1)) #\"))
65      (substring str 1 (- (string-length str) 1))
66      str))
67
68(define (make-content-type-params-cont cont name value rest)
69  (cons (cons (format #f "~(~A~)" name) (parameter-unquote value))
70        (make-content-type-params cont rest)))
71
72(define (content-type-param info name default)
73  (let ((value (assoc name (content-type-params info))))
74    (if value (cdr value) default)))
Note: See TracBrowser for help on using the repository browser.