;;;
;;; <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 mzscheme
  (require "qp-sig.ss"
           (lib "unitsig.ss")
           (lib "etc.ss"))

  (provide net:qp@)
  (define net:qp@
    (unit/sig net:qp^
      (import)
      
      ;; 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
