#!/bin/sh # aside from this initial boilerplate, this is actually -*- scheme -*- code main='(module-ref (resolve-module '\''(scripts read-rfc822)) '\'main')' exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@" !# ;;; read-rfc822 --- Validate RFC822 file by displaying it to stdout ;; Copyright (C) 2002 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., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA ;;; Author: Thien-Thi Nguyen ;;; 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 (cdr lines) (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