guile-for-guile-emacs/module/scripts/read-rfc822.scm

;;; read-rfc822 --- Validate RFC822 file by displaying it to stdout

;; 	Copyright (C) 2002, 2004, 2006, 2011 Free Software Foundation, Inc.
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public License
;; as published by the Free Software Foundation; either version 3, 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
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this software; see the file COPYING.LESSER.  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 %include-in-guild-list #f)
(define %summary "Validate an RFC822-style file.")

(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