;;;
;;; <qp-unit.ss> ---- Quoted Printable Implementation
;;;
;;; Copyright (C) 2002 by PLT.
;;; Copyright (C) 2001 by Francisco Solsona.
;;;
;;; This file was part of mime-plt.

;;; mime-plt 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 2.1 of the License, or (at your option) any later version.

;;; mime-plt 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 mime-plt; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

;;; Author: Francisco Solsona <solsona@acm.org>
;;
;;
;; Commentary:

(module qp-unit (lib "a-unit.ss")
  (require "qp-sig.ss"
           (lib "etc.ss"))

  (import)
  (export qp^)

  ;; Exceptions:
  ;; String or input-port expected:
  (define-struct qp-error ())
  (define-struct (qp-wrong-input qp-error) ())
  (define-struct (qp-wrong-line-size qp-error) (size))

  ;; qp-encode : bytes -> bytes
  ;; returns the quoted printable representation of STR.
  (define qp-encode
    (lambda (str)
      (let ([out (open-output-bytes)])
        (qp-encode-stream (open-input-bytes str) out #"\r\n")
        (get-output-bytes out))))

  ;; qp-decode : string -> string
  ;; returns STR unqp.
  (define qp-decode
    (lambda (str)
      (let ([out (open-output-bytes)])
        (qp-decode-stream (open-input-bytes str) out)
        (get-output-bytes out))))

  (define qp-decode-stream
    (lambda (in out)
      (let loop ([ch (read-byte in)])
        (unless (eof-object? ch)
          (case ch
            [(61) ;; A "=", which is quoted-printable stuff
             (let ([next (read-byte in)])
               (cond
                 [(eq? next 10)
                  ;; Soft-newline -- drop it
                  (void)]
                 [(eq? next 13)
                  ;; Expect a newline for a soft CRLF...
                  (let ([next-next (read-byte in)])
                    (if (eq? next-next 10)
                      ;; Good.
                      (loop (read-byte in))
                      ;; Not a LF? Well, ok.
                      (loop next-next)))]
                 [(hex-digit? next)
                  (let ([next-next (read-byte in)])
                    (cond [(eof-object? next-next)
                           (warning "Illegal qp sequence: `=~a'" next)
                           (display "=" out)
                           (display next out)]
                          [(hex-digit? next-next)
                           ;; qp-encoded
                           (write-byte (hex-bytes->byte next next-next)
                                       out)]
                          [else
                           (warning "Illegal qp sequence: `=~a~a'" next next-next)
                           (write-byte 61 out)
                           (write-byte next out)
                           (write-byte next-next out)]))]
                 [else
                  ;; Warning: invalid
                  (warning "Illegal qp sequence: `=~a'" next)
                  (write-byte 61 out)
                  (write-byte next out)])
               (loop (read-byte in)))]
            [else
             (write-byte ch out)
             (loop (read-byte in))])))))

  (define warning
    (lambda (msg . args)
      (when #f
        (fprintf (current-error-port)
                 (apply format msg args))
        (newline (current-error-port)))))

  (define (hex-digit? i)
    (vector-ref hex-values i))

  (define hex-bytes->byte
    (lambda (b1 b2)
      (+ (* 16 (vector-ref hex-values b1))
         (vector-ref hex-values b2))))

  (define write-hex-bytes
    (lambda (byte p)
      (write-byte 61 p)
      (write-byte (vector-ref hex-bytes (arithmetic-shift byte -4)) p)
      (write-byte (vector-ref hex-bytes (bitwise-and byte 15)) p)))

  (define re:blanks #rx#"[ \t]+$")

  (define qp-encode-stream
    (opt-lambda (in out [newline-string #"\n"])
      (let loop ([col 0])
        (if (= col 75)
          (begin
            ;; Soft newline:
            (write-byte 61 out)
            (display newline-string out)
            (loop 0))
          (let ([i (read-byte in)])
            (cond
              [(eof-object? i) (void)]
              [(or (= i 10) (= i 13))
               (write-byte i out)
               (loop 0)]
              [(or (<= 33 i 60) (<= 62 i 126)
                   (and (or (= i 32) (= i 9))
                        (not (let ([next (peek-byte in)])
                               (or (eof-object? next) (= next 10) (= next 13))))))
               ;; single-byte mode:
               (write-byte i out)
               (loop (add1 col))]
              [(>= col 73)
               ;; need a soft newline first
               (write-byte 61 out)
               (display newline-string out)
               ;; now the octect
               (write-hex-bytes i out)
               (loop 3)]
              [else
               ;; an octect
               (write-hex-bytes i out)
               (loop (+ col 3))]))))))

  ;; Tables
  (define hex-values (make-vector 256 #f))
  (define hex-bytes (make-vector 16))
  (let loop ([i 0])
    (unless (= i 10)
      (vector-set! hex-values (+ i 48) i)
      (vector-set! hex-bytes i (+ i 48))
      (loop (add1 i))))
  (let loop ([i 0])
    (unless (= i 6)
      (vector-set! hex-values (+ i 65) (+ 10 i))
      (vector-set! hex-values (+ i 97) (+ 10 i))
      (vector-set! hex-bytes (+ 10 i) (+ i 65))
      (loop (add1 i)))))

;;; qp-unit.ss ends here