diff options
author | Andy Wingo <wingo@pobox.com> | 2009-04-17 11:19:42 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2009-04-17 11:19:42 +0200 |
commit | 6d66647d5b2c6649bb4dade734f6d583d10d797c (patch) | |
tree | 3c05d62af67617f0949fbe4a4228ac3564da0be5 /module/scripts/read-rfc822.scm | |
parent | 798244609bfd3b4d2b12f722d9130d47abcfeb1a (diff) | |
download | guile-6d66647d5b2c6649bb4dade734f6d583d10d797c.tar.gz |
guile-tools is a scheme script that loads scheme modules
* meta/guile-tools: Changed to be a scheme script. Instead of looking for
executables in a "scripts dir", we just look for modules in (scripts),
and load the modules directly.
* module/Makefile.am:
* module/scripts/: Move the scripts into module/ so they can be compiled.
Rename scripts from `foo' to `foo.scm'.
* libguile/Makefile.am: Invoke the snarf->texi code via guile-tools.
* configure.in:
* .gitignore: Update for changes.
Diffstat (limited to 'module/scripts/read-rfc822.scm')
-rw-r--r-- | module/scripts/read-rfc822.scm | 128 |
1 files changed, 128 insertions, 0 deletions
diff --git a/module/scripts/read-rfc822.scm b/module/scripts/read-rfc822.scm new file mode 100644 index 000000000..ed3aced7d --- /dev/null +++ b/module/scripts/read-rfc822.scm @@ -0,0 +1,128 @@ +;;; read-rfc822 --- Validate RFC822 file by displaying it to stdout + +;; Copyright (C) 2002, 2004, 2006 Free Software Foundation, Inc. +;; +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or +;; (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this software; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301 USA + +;;; Author: Thien-Thi Nguyen <ttn@gnu.org> + +;;; Commentary: + +;; Usage: read-rfc822 FILE +;; +;; Read FILE, assumed to be in RFC822 format, and display it to stdout. +;; This is not very interesting, admittedly. +;; +;; For Scheme programming, this module exports two procs: +;; (read-rfc822 . args) ; only first arg used +;; (read-rfc822-silently port) +;; +;; Parse FILE (a string) or PORT, respectively, and return a query proc that +;; takes a symbol COMP, and returns the message component COMP. Supported +;; values for COMP (and the associated query return values) are: +;; from -- #f (reserved for future mbox support) +;; headers -- alist of (HEADER-SYMBOL . "VALUE-STRING") pairs, in order +;; body -- rest of the mail message, a string +;; body-lines -- rest of the mail message, as a list of lines +;; Any other query results in a "bad component" error. +;; +;; TODO: Add "-m" option (mbox support). + +;;; Code: + +(define-module (scripts read-rfc822) + :use-module (ice-9 regex) + :use-module (ice-9 rdelim) + :autoload (srfi srfi-13) (string-join) + :export (read-rfc822 read-rfc822-silently)) + +(define from-line-rx (make-regexp "^From ")) +(define header-name-rx (make-regexp "^([^:]+):[ \t]*")) +(define header-cont-rx (make-regexp "^[ \t]+")) + +(define option #f) ; for future "-m" + +(define (drain-message port) + (let loop ((line (read-line port)) (acc '())) + (cond ((eof-object? line) + (reverse acc)) + ((and option (regexp-exec from-line-rx line)) + (for-each (lambda (c) + (unread-char c port)) + (cons #\newline + (reverse (string->list line)))) + (reverse acc)) + (else + (loop (read-line port) (cons line acc)))))) + +(define (parse-message port) + (let* ((from (and option + (match:suffix (regexp-exec from-line-rx + (read-line port))))) + (body-lines #f) + (body #f) + (headers '()) + (add-header! (lambda (reversed-hlines) + (let* ((hlines (reverse reversed-hlines)) + (first (car hlines)) + (m (regexp-exec header-name-rx first)) + (name (string->symbol (match:substring m 1))) + (data (string-join + (cons (substring first (match:end m)) + (cdr hlines)) + " "))) + (set! headers (acons name data headers)))))) + ;; "From " is only one line + (let loop ((line (read-line port)) (current-header #f)) + (cond ((string-null? line) + (and current-header (add-header! current-header)) + (set! body-lines (drain-message port))) + ((regexp-exec header-cont-rx line) + => (lambda (m) + (loop (read-line port) + (cons (match:suffix m) current-header)))) + (else + (and current-header (add-header! current-header)) + (loop (read-line port) (list line))))) + (set! headers (reverse headers)) + (lambda (component) + (case component + ((from) from) + ((body-lines) body-lines) + ((headers) headers) + ((body) (or body + (begin (set! body (string-join body-lines "\n" 'suffix)) + body))) + (else (error "bad component:" component)))))) + +(define (read-rfc822-silently port) + (parse-message port)) + +(define (display-rfc822 parse) + (cond ((parse 'from) => (lambda (from) (format #t "From ~A\n" from)))) + (for-each (lambda (header) + (format #t "~A: ~A\n" (car header) (cdr header))) + (parse 'headers)) + (format #t "\n~A" (parse 'body))) + +(define (read-rfc822 . args) + (let ((parse (read-rfc822-silently (open-file (car args) OPEN_READ)))) + (display-rfc822 parse)) + #t) + +(define main read-rfc822) + +;;; read-rfc822 ends here |