From eadd27b8d017ccb334148dd021b68c1d3fdfff52 Mon Sep 17 00:00:00 2001 From: Jon Zeppieri Date: Mon, 29 Aug 2011 21:51:41 -0400 Subject: [PATCH] Moved `net/qp' code from unit to module. original commit: d034297c768145a90f5d7527e557fcb6f892a62e --- collects/net/qp.rkt | 149 ++++++++++++++++++++++++++++-- collects/net/scribblings/qp.scrbl | 4 + 2 files changed, 146 insertions(+), 7 deletions(-) diff --git a/collects/net/qp.rkt b/collects/net/qp.rkt index c5267fb6b1..7522a6c863 100644 --- a/collects/net/qp.rkt +++ b/collects/net/qp.rkt @@ -6,31 +6,166 @@ ;;; ;;; This file is part of mime-plt. -;;; mime-plt is free software; you can redistribute it and/or +;;; qp 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, +;;; qp 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 +;;; License along with qp; if not, write to the Free Software ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA ;;; 02110-1301 USA. ;;; Author: Francisco Solsona ;; -;; ;; Commentary: #lang racket/base -(require racket/unit "qp-sig.rkt" "qp-unit.rkt") -(define-values/invoke-unit/infer qp@) +(provide + ;; -- exceptions raised -- + (struct-out qp-error) + (struct-out qp-wrong-input) + (struct-out qp-wrong-line-size) -(provide-signature-elements qp^) + ;; -- qp methods -- + qp-encode + qp-decode + qp-encode-stream + qp-decode-stream) + +;; 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 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 str) + (let ([out (open-output-bytes)]) + (qp-decode-stream (open-input-bytes str) out) + (get-output-bytes out))) + +(define (qp-decode-stream 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 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 b1 b2) + (+ (* 16 (vector-ref hex-values b1)) + (vector-ref hex-values b2))) + +(define (write-hex-bytes 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 (qp-encode-stream 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.rkt ends here diff --git a/collects/net/scribblings/qp.scrbl b/collects/net/scribblings/qp.scrbl index c5f0a6d608..18ef49e957 100644 --- a/collects/net/scribblings/qp.scrbl +++ b/collects/net/scribblings/qp.scrbl @@ -66,6 +66,10 @@ backward compatibility.} @section{Quoted-Printable Unit} +@margin-note{@racket[qp@] and @racket[qp^] are deprecated. +They exist for backward-compatibility and will likely be removed in +the future. New code should use the @racketmodname[net/qp] module.} + @defmodule[net/qp-unit] @defthing[qp@ unit?]{