source: project/content-type/trunk/content-type.scm @ 764

Last change on this file since 764 was 764, checked in by azul, 14 years ago

Support files.

File size: 2.2 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 type   "[0-9A-Za-z-]+")
28(define pars   "\\s*(|;\\s*.*)$")
29(define token  "[^][()<>@,;:\\\\?=\"\\s]+")
30(define quoted "\"[^\"]*\"")
31
32(define-record content-type type subtype params)
33
34(define content-type-make
35  (let ((expr (regexp (format #f "\\s*(~A)\\s*/\\s*(~A)~A" type type pars))))
36    (lambda (line)
37      (and-let* ((match (string-match expr line)))
38        (call-with-current-continuation
39          (lambda (cont)
40            (make-content-type (format #f "~(~A~)" (cadr match)) (format #f "~(~A~)" (caddr match))
41              (make-content-type-params cont (cadddr match)))))))))
42
43(define make-content-type-params
44  (let ((expr (regexp (format #f "^;\\s*(~A)\\s*=\\s*(~A|~A)~A" token token quoted pars))))
45    (lambda (cont line)
46      (if (equal? line "")
47        '()
48        (let ((match (string-match expr line)))
49          (if match (apply make-content-type-params-cont cont (cdr match)) (cont #f)))))))
50
51(define (parameter-unquote str)
52  (if (and (equal? (string-ref str 0) #\") (equal? (string-ref str (- (string-length str) 1)) #\"))
53      (substring str 1 (- (string-length str) 1))
54      str))
55
56(define (make-content-type-params-cont cont name value rest)
57  (cons (cons (format #f "~(~A~)" name) (parameter-unquote value))
58        (make-content-type-params cont rest)))
59
60(define (content-type-param info name default)
61  (let ((value (assoc name (content-type-params info))))
62    (if value (cdr value) default)))
Note: See TracBrowser for help on using the repository browser.