-;;; mel-ccl.el: CCL based encoder/decoder of Quoted-Printable
-;;; and Q-encoding
+;;; mel-q-ccl.el --- Quoted-Printable encoder/decoder using CCL.
-;; Copyright (C) 1998 Tanaka Akira
+;; Copyright (C) 1998,1999 Tanaka Akira
;; Author: Tanaka Akira <akr@jaist.ac.jp>
;; Created: 1998/9/17
;; General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; along with this program; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Q
(define-ccl-program mel-ccl-decode-q
- `(1
- ((loop
- (read-branch
- r0
- ,@(mapcar
- (lambda (r0)
- (cond
- ((= r0 (char-int ?_))
- `(write-repeat ? ))
- ((= r0 (char-int ?=))
- `((loop
- (read-branch
- r1
- ,@(mapcar
- (lambda (v)
- (if (integerp v)
- `((r0 = ,v) (break))
- '(repeat)))
- mel-ccl-256-to-16-table)))
- (loop
- (read-branch
- r1
- ,@(mapcar
- (lambda (v)
- (if (integerp v)
- `((write r0 ,(vconcat
- (mapcar
- (lambda (r0)
- (logior (lsh r0 4) v))
- mel-ccl-16-table)))
- (break))
- '(repeat)))
- mel-ccl-256-to-16-table)))
- (repeat)))
- (t
- `(write-repeat ,r0))))
- mel-ccl-256-table))))))
+ (` (1
+ ((loop
+ (read-branch
+ r0
+ (,@ (mapcar
+ (lambda (r0)
+ (cond
+ ((= r0 (char-int ?_))
+ (` (write-repeat ? )))
+ ((= r0 (char-int ?=))
+ (` ((loop
+ (read-branch
+ r1
+ (,@ (mapcar
+ (lambda (v)
+ (if (integerp v)
+ (` ((r0 = (, v)) (break)))
+ '(repeat)))
+ mel-ccl-256-to-16-table))))
+ (loop
+ (read-branch
+ r1
+ (,@ (mapcar
+ (lambda (v)
+ (if (integerp v)
+ (` ((write r0 (, (vconcat
+ (mapcar
+ (lambda (r0)
+ (logior (lsh r0 4) v))
+ mel-ccl-16-table))))
+ (break)))
+ '(repeat)))
+ mel-ccl-256-to-16-table))))
+ (repeat))))
+ (t
+ (` (write-repeat (, r0))))))
+ mel-ccl-256-table))))))))
(eval-when-compile
(defun mel-ccl-encode-q-generic (raw)
- `(3
- (loop
- (loop
- (read-branch
- r0
- ,@(mapcar
- (lambda (r0)
- (cond
- ((= r0 32) `(write-repeat ?_))
- ((member r0 raw) `(write-repeat ,r0))
- (t '(break))))
- mel-ccl-256-table)))
- (write ?=)
- (write r0 ,mel-ccl-high-table)
- (write r0 ,mel-ccl-low-table)
- (repeat))))
+ (` (3
+ (loop
+ (loop
+ (read-branch
+ r0
+ (,@ (mapcar
+ (lambda (r0)
+ (cond
+ ((= r0 32) '(write-repeat ?_))
+ ((member r0 raw) (` (write-repeat (, r0))))
+ (t '(break))))
+ mel-ccl-256-table))))
+ (write ?=)
+ (write r0 (, mel-ccl-high-table))
+ (write r0 (, mel-ccl-low-table))
+ (repeat)))))
;; On xemacs, generated program counts iso-8859-1 8bit character as 6bytes.
(defun mel-ccl-count-q-length (raw)
- `(0
- ((r0 = 0)
- (loop
- (read-branch
- r1
- ,@(mapcar
- (lambda (r1)
- (if (or (= r1 32) (member r1 raw))
- '((r0 += 1) (repeat))
- '((r0 += 3) (repeat))))
- mel-ccl-256-table))))))
+ (` (0
+ ((r0 = 0)
+ (loop
+ (read-branch
+ r1
+ (,@ (mapcar
+ (lambda (r1)
+ (if (or (= r1 32) (member r1 raw))
+ '((r0 += 1) (repeat))
+ '((r0 += 3) (repeat))))
+ mel-ccl-256-table))))))))
)
(eval-when-compile
-(defun mel-ccl-try-to-read-crlf (input-crlf reg eof-reg cr-eof lf-eof crlf-eof succ fail-cr fail-lf fail-crlf)
+(defvar eof-block-branches)
+(defvar eof-block-reg)
+(defun mel-ccl-set-eof-block (branch)
+ (let ((p (assoc branch eof-block-branches)))
+ (unless p
+ (setq p (cons branch (length eof-block-branches))
+ eof-block-branches (cons p eof-block-branches)))
+ (` ((, eof-block-reg) = (, (cdr p))))))
+
+)
+
+(eval-when-compile
+
+(defun mel-ccl-try-to-read-crlf (input-crlf reg
+ succ
+ cr-eof cr-fail
+ lf-eof lf-fail
+ crlf-eof crlf-fail)
(if input-crlf
- `((,eof-reg = ,cr-eof) (read-if (,reg == ?\r)
- ((,eof-reg = ,lf-eof) (read-if (,reg == ?\n)
- ,succ
- ,fail-lf))
- ,fail-cr))
- `((,eof-reg = ,crlf-eof) (read-if (,reg == ?\n)
- ,succ
- ,fail-crlf))))
+ (` ((, (mel-ccl-set-eof-block cr-eof))
+ (read-if ((, reg) == ?\r)
+ ((, (mel-ccl-set-eof-block lf-eof))
+ (read-if ((, reg) == ?\n)
+ (, succ)
+ (, lf-fail)))
+ (, cr-fail))))
+ (` ((, (mel-ccl-set-eof-block crlf-eof))
+ (read-if ((, reg) == ?\n)
+ (, succ)
+ (, crlf-fail))))))
+
+)
+
+(eval-when-compile
;; Generated CCL program works not properly on 20.2 because CCL_EOF_BLOCK
;; is not executed.
(defun mel-ccl-encode-quoted-printable-generic (input-crlf output-crlf)
- `(4
- ((r6 = 0) ; column
- (r5 = 0) ; previous character is white space
- (r4 = 0)
- (read r0)
- (loop ; r6 <= 75
- (loop
- (loop
- (branch
- r0
- ,@(mapcar
- (lambda (r0)
- (let ((tmp (aref mel-ccl-qp-table r0)))
- (cond
- ((eq r0 (char-int ?F))
- `(if (r6 == 0)
- ((r4 = 15) (read-if (r0 == ?r)
- ((r4 = 16) (read-if (r0 == ?o)
- ((r4 = 17) (read-if (r0 == ?m)
- ((r4 = 18) (read-if (r0 == ? )
- ((r6 = 7)
- (r5 = 1)
- (write "=46rom ")
- (r4 = 19)
- (read r0)
- (repeat))
- ((r6 = 4)
- (write-repeat "From"))))
- ((r6 = 3)
- (write-repeat "Fro"))))
- ((r6 = 2)
- (write-repeat "Fr"))))
- ((r6 = 1)
- (write-repeat "F"))))
- ((r3 = 0) (break)) ; RAW
- ))
- ((eq r0 (char-int ?.))
- `(if (r6 == 0)
- ,(mel-ccl-try-to-read-crlf
- input-crlf
- 'r0 'r4 20 21 22
- `((write ,(if output-crlf "=2E\r\n" "=2E\n"))
- (r4 = 23)
+ (let ((hard (if output-crlf "\r\n" "\n"))
+ (soft (if output-crlf "=\r\n" "=\n"))
+ (eof-block-branches nil)
+ (eof-block-reg 'r4)
+ (after-wsp 'r5)
+ (column 'r6)
+ (type 'r3)
+ (current 'r0)
+ (type-raw 0)
+ (type-enc 1)
+ (type-wsp 2)
+ (type-brk 3)
+ )
+ (` (4
+ (((, column) = 0)
+ ((, after-wsp) = 0)
+ (, (mel-ccl-set-eof-block '(end)))
+ (read r0)
+ (loop ; invariant: column <= 75
+ (loop
+ (loop
+ (branch
+ r0
+ (,@ (mapcar
+ (lambda (r0)
+ (let ((tmp (aref mel-ccl-qp-table r0)))
+ (cond
+ ((eq r0 (char-int ?F))
+ (` (if ((, column) == 0)
+ ((, (mel-ccl-set-eof-block '((write "F") (end))))
+ (read-if (r0 == ?r)
+ ((, (mel-ccl-set-eof-block '((write "Fr") (end))))
+ (read-if (r0 == ?o)
+ ((, (mel-ccl-set-eof-block '((write "Fro") (end))))
+ (read-if (r0 == ?m)
+ ((, (mel-ccl-set-eof-block '((write "From") (end))))
+ (read-if (r0 == ? )
+ (((, column) = 7)
+ ((, after-wsp) = 1)
+ (, (mel-ccl-set-eof-block '((write "From=20") (end))))
+ (read r0)
+ (write-repeat "=46rom "))
+ (((, column) = 4)
+ (write-repeat "From"))))
+ (((, column) = 3)
+ (write-repeat "Fro"))))
+ (((, column) = 2)
+ (write-repeat "Fr"))))
+ (((, column) = 1)
+ (write-repeat "F"))))
+ (((, type) = (, type-raw)) (break)) ; RAW
+ )))
+ ((eq r0 (char-int ?.))
+ (` (if ((, column) == 0)
+ (, (mel-ccl-try-to-read-crlf
+ input-crlf 'r0
+ ;; "." CR LF (input-crlf: t)
+ ;; "." LF (input-crlf: nil)
+ (` ((write (, (concat "=2E" hard)))
+ (, (mel-ccl-set-eof-block '(end)))
+ (read r0)
+ (repeat)))
+ ;; "." <EOF>
+ '((write ".") (end))
+ ;; "." noCR (input-crlf: t)
+ (` (((, column) = 1)
+ (write-repeat ".")))
+ ;; "." CR <EOF> (input-crlf: t)
+ '((write ".=0D") (end))
+ ;; "." CR noLF (input-crlf: t)
+ (` (((, column) = 4)
+ (write-repeat ".=0D")))
+ ;; "." <EOF> (input-crlf: nil)
+ '((write ".") (end))
+ ;; "." noLF (input-crlf: nil)
+ (` (((, column) = 1)
+ (write-repeat ".")))))
+ (((, type) = (, type-raw)) (break)) ; RAW
+ )))
+ ((eq tmp 'raw) (` (((, type) = (, type-raw)) (break))))
+ ((eq tmp 'enc) (` (((, type) = (, type-enc)) (break))))
+ ((eq tmp 'wsp) (` (((, type) = (, type-wsp)) (break))))
+ ((eq tmp 'cr) (` (((, type) = (, (if input-crlf type-brk type-enc)))
+ (break))))
+ ((eq tmp 'lf) (` (((, type) = (, (if input-crlf type-enc type-brk)))
+ (break))))
+ )))
+ mel-ccl-256-table))))
+ ;; r0:type{raw,enc,wsp,brk}
+ (branch
+ (, type)
+ ;; r0:type-raw
+ (if ((, column) < 75)
+ (((, column) += 1)
+ ((, after-wsp) = 0)
+ (, (mel-ccl-set-eof-block '(end)))
+ (write-read-repeat r0))
+ ((r1 = (r0 + 0))
+ ((, after-wsp) = 0)
+ (,@ (mel-ccl-try-to-read-crlf
+ input-crlf 'r0
+ (` (((, column) = 0)
+ (write r1)
+ (, (mel-ccl-set-eof-block (` ((write (, hard)) (end)))))
+ (read r0)
+ (write-repeat (, hard))))
+ '((write r1) (end))
+ (` (((, column) = 1)
+ (write (, soft)) (write-repeat r1)))
+ (` ((write (, soft)) (write r1) (write "=0D") (end)))
+ (` (((, column) = 4)
+ (write (, soft)) (write r1) (write-repeat "=0D")))
+ '((write r1) (end))
+ (` (((, column) = 1)
+ (write (, soft)) (write-repeat r1)))))))
+ ;; r0:type-enc
+ (((, after-wsp) = 0)
+ (if ((, column) < 73)
+ (((, column) += 3)
+ (write "=")
+ (write r0 (, mel-ccl-high-table))
+ (, (mel-ccl-set-eof-block '(end)))
+ (write-read-repeat r0 (, mel-ccl-low-table)))
+ (if ((, column) < 74)
+ ((r1 = (r0 + 0))
+ ((, after-wsp) = 0)
+ (,@ (mel-ccl-try-to-read-crlf
+ input-crlf 'r0
+ (` (((, column) = 0)
+ (write "=")
+ (write r1 (, mel-ccl-high-table))
+ (write r1 (, mel-ccl-low-table))
+ (write (, hard))
+ (, (mel-ccl-set-eof-block '(end)))
+ (read r0)
+ (repeat)))
+ (` ((write "=")
+ (write r1 (, mel-ccl-high-table))
+ (write r1 (, mel-ccl-low-table))
+ (end)))
+ (` (((, column) = 3)
+ (write (, (concat soft "=")))
+ (write r1 (, mel-ccl-high-table))
+ (write r1 (, mel-ccl-low-table))
+ (repeat)))
+ (` ((write (, (concat soft "=")))
+ (write r1 (, mel-ccl-high-table))
+ (write r1 (, mel-ccl-low-table))
+ (write "=0D")
+ (end)))
+ (` (((, column) = 6)
+ (write (, (concat soft "=")))
+ (write r1 (, mel-ccl-high-table))
+ (write r1 (, mel-ccl-low-table))
+ (write-repeat "=0D")))
+ (` ((write "=")
+ (write r1 (, mel-ccl-high-table))
+ (write r1 (, mel-ccl-low-table))
+ (end)))
+ (` (((, column) = 3)
+ (write (, (concat soft "=")))
+ (write r1 (, mel-ccl-high-table))
+ (write r1 (, mel-ccl-low-table))
+ (repeat))))))
+ (((, column) = 3)
+ (write (, (concat soft "=")))
+ (write r0 (, mel-ccl-high-table))
+ (, (mel-ccl-set-eof-block '(end)))
+ (write-read-repeat r0 (, mel-ccl-low-table))))))
+ ;; r0:type-wsp
+ (if ((, column) < 73)
+ ((r1 = (r0 + 0))
+ (,@ (mel-ccl-try-to-read-crlf
+ input-crlf 'r0
+ (` (((, column) = 0)
+ ((, after-wsp) = 0)
+ (write "=")
+ (write r1 (, mel-ccl-high-table))
+ (write r1 (, mel-ccl-low-table))
+ (write (, hard))
+ (, (mel-ccl-set-eof-block (` (end))))
+ (read r0)
+ (repeat)))
+ (` ((write "=")
+ (write r1 (, mel-ccl-high-table))
+ (write r1 (, mel-ccl-low-table))
+ (end)))
+ (` (((, column) += 1)
+ ((, after-wsp) = 1)
+ (write-repeat r1)))
+ (` ((write r1)
+ (write "=0D")
+ (end)))
+ (` (((, column) += 4)
+ ((, after-wsp) = 0)
+ (write r1)
+ (write-repeat "=0D")))
+ (` ((write "=")
+ (write r1 (, mel-ccl-high-table))
+ (write r1 (, mel-ccl-low-table)) (end)))
+ (` (((, column) += 1)
+ ((, after-wsp) = 1)
+ (write-repeat r1))))))
+ (if ((, column) < 74)
+ ((r1 = (r0 + 0))
+ (,@ (mel-ccl-try-to-read-crlf
+ input-crlf 'r0
+ (` (((, column) = 0)
+ ((, after-wsp) = 0)
+ (write "=")
+ (write r1 (, mel-ccl-high-table))
+ (write r1 (, mel-ccl-low-table))
+ (write (, hard))
+ (, (mel-ccl-set-eof-block (` (end))))
(read r0)
- (repeat))
- '((r6 = 1)
- (write-repeat "."))
- '((r6 = 4)
- (write-repeat ".=0D"))
- '((r6 = 1)
- (write-repeat ".")))
- ((r3 = 0) (break)) ; RAW
- ))
- ((eq tmp 'raw) '((r3 = 0) (break))) ; RAW
- ((eq tmp 'enc) '((r3 = 1) (break))) ; ENC
- ((eq tmp 'wsp) '((r3 = 2) (break))) ; WSP
- ((eq tmp 'cr) (if input-crlf
- '((r3 = 3) (break)) ; CR
- '((r3 = 1) (break)))) ; ENC
- ((eq tmp 'lf) (if input-crlf
- '((r3 = 1) (break)) ; ENC
- '((r3 = 3) (break)))) ; CRLF
- )))
- mel-ccl-256-table)))
- (branch
- r3
- ;; r0:r3=RAW
- (if (r6 < 75)
- ((r6 += 1)
- (r5 = 0)
- (r4 = 1)
- (write-read-repeat r0))
- (break))
- ;; r0:r3=ENC
- ((r5 = 0)
- (if (r6 < 73)
- ((r6 += 3)
- (write "=")
- (write r0 ,mel-ccl-high-table)
- (r4 = 2)
- (write-read-repeat r0 ,mel-ccl-low-table))
- (if (r6 > 73)
- ((r6 = 3)
- (write ,(if output-crlf "=\r\n=" "=\n="))
- (write r0 ,mel-ccl-high-table)
- (r4 = 3)
- (write-read-repeat r0 ,mel-ccl-low-table))
- (break))))
- ;; r0:r3=WSP
- ((r5 = 1)
- (if (r6 < 75)
- ((r6 += 1)
- (r4 = 4)
- (write-read-repeat r0))
- ((r6 = 1)
- (write ,(if output-crlf "=\r\n" "=\n"))
- (r4 = 5)
- (write-read-repeat r0))))
- ;; r0:r3=CR/CRLF
- ,(if input-crlf
- ;; r0:r3=CR
- `((if ((r6 > 73) & r5)
- ((r6 = 0)
- (r5 = 0)
- (write ,(if output-crlf "=\r\n" "=\n"))))
- (break))
- ;; r0:r3=CRLF
- `(if r5
- ;; WSP ; r0:r3=CRLF
- ((r5 = 0)
- (r6 = 0)
- (write ,(if output-crlf "=\r\n" "=\n"))
- ,@(if output-crlf '((write ?\r)) '())
- (r4 = 0)
- (write-read-repeat r0))
- ;; noWSP ; r0:r3=CRLF
- ((r5 = 0)
- (r6 = 0)
- ,@(if output-crlf '((write ?\r)) '())
- (r4 = 0)
- (write-read-repeat r0)))
- )))
- ;; r0:r3={RAW,ENC,CR}
- (loop
- ,(funcall
- (lambda (after-cr after-raw-enc)
- (if input-crlf
- `(if (r0 == ?\r)
- ,after-cr
- ,after-raw-enc)
- after-raw-enc))
- ;; r0=\r:r3=CR
- `((r4 = 6)
- (read r0)
- ;; CR:r3=CR r0
- (if (r0 == ?\n)
- ;; CR:r3=CR r0=LF
- (if r5
- ;; r5=WSP ; CR:r3=CR r0=LF
- ((r6 = 0)
- (r5 = 0)
- (write ,(if output-crlf "=\r\n\r\n" "=\n\n"))
- (r4 = 7)
- (read r0)
- (break))
- ;; r5=noWSP ; CR:r3=CR r0=LF
- ((r6 = 0)
- (r5 = 0)
- (write ,(if output-crlf "\r\n" "\n"))
- (r4 = 8)
- (read r0)
- (break)))
- ;; CR:r3=CR r0=noLF
- (if (r6 < 73)
- ((r6 += 3)
- (r5 = 0)
- (write "=0D")
- (break))
- (if (r6 == 73)
- (if (r0 == ?\r)
- ;; CR:r3=CR r0=CR
- ((r4 = 9)
- (read r0)
- ;; CR:r3=CR CR r0
- (if (r0 == ?\n)
- ;; CR:r3=CR CR LF
- ((r6 = 0)
- (r5 = 0)
- (write ,(if output-crlf "=0D\r\n" "=0D\n"))
- (r4 = 10)
- (read r0)
- (break))
- ;; CR:r3=CR CR noLF
- ((r6 = 6)
- (r5 = 0)
- (write ,(if output-crlf "=\r\n=0D=0D" "=\n=0D=0D"))
- (break))))
- ;; CR:r3=CR r0=noLFnorCR
- ((r6 = 3)
- (r5 = 0)
- (write ,(if output-crlf "=\r\n=0D" "=\n=0D"))
- (break)))
- ((r6 = 3)
- (r5 = 0)
- (write ,(if output-crlf "=\r\n=0D" "=\n=0D"))
- (break))))))
- (funcall
- (lambda (after-newline after-cr-nolf after-nonewline)
- (if input-crlf
- ;; r0:r3={RAW,ENC}
- `((r4 = 11)
- (read r1)
- ;; r0:r3={RAW,ENC} r1
- (if (r1 == ?\r)
- ;; r0:r3={RAW,ENC} r1=CR
- ((r4 = 12)
- (read r1)
- ;; r0:r3={RAW,ENC} CR r1
- (if (r1 == ?\n)
- ;; r0:r3=RAW CR r1=LF
- ,after-newline
- ;; r0:r3=RAW CR r1=noLF
- ,after-cr-nolf))
- ;; r0:r3={RAW,ENC} r1:noCR
- ,after-nonewline))
- ;; r0:r3={RAW,ENC}
- `((r4 = 11)
- (read r1)
- ;; r0:r3={RAW,ENC} r1
- (if (r1 == ?\n)
- ;; r0:r3={RAW,ENC} r1=CRLF
- ,after-newline
- ;; r0:r3={RAW,ENC} r1:noCRLF
- ,after-nonewline))))
- ;; r0:r3={RAW,ENC} CR r1=LF
- ;; r0:r3={RAW,ENC} r1=CRLF
- `((r6 = 0)
- (r5 = 0)
- (branch
- r3
- ;; r0:r3=RAW CR r1=LF
- ;; r0:r3=RAW r1=CRLF
- ((write r0)
- (write ,(if output-crlf "\r\n" "\n"))
- (r4 = 13)
- (read r0)
- (break))
- ;; r0:r3=ENC CR r1=LF
- ;; r0:r3=ENC r1=CRLF
- ((write ?=)
- (write r0 ,mel-ccl-high-table)
- (write r0 ,mel-ccl-low-table)
- (write ,(if output-crlf "\r\n" "\n"))
- (r4 = 14)
- (read r0)
- (break))))
- ;; r0:r3={RAW,ENC} CR r1=noLF
- `((branch
- r3
- ;; r0:r3=RAW CR r1:noLF
- ((r6 = 4)
- (r5 = 0)
- (write ,(if output-crlf "=\r\n" "=\n"))
- (write r0)
- (write "=0D")
- (r0 = r1)
- (break))
- ;; r0:r3=ENC CR r1:noLF
- ((r6 = 6)
- (r5 = 0)
- (write ,(if output-crlf "=\r\n=" "=\n="))
- (write r0 ,mel-ccl-high-table)
- (write r0 ,mel-ccl-low-table)
- (write "=0D")
- (r0 = r1)
- (break))))
- ;; r0:r3={RAW,ENC} r1:noCR
- ;; r0:r3={RAW,ENC} r1:noCRLF
- `((branch
- r3
- ;; r0:r3=RAW r1:noCR
- ;; r0:r3=RAW r1:noCRLF
- ((r6 = 1)
- (r5 = 0)
- (write ,(if output-crlf "=\r\n" "=\n"))
- (write r0)
- (r0 = r1)
- (break))
- ;; r0:r3=ENC r1:noCR
- ;; r0:r3=ENC r1:noCRLF
- ((r6 = 3)
- (r5 = 0)
- (write ,(if output-crlf "=\r\n=" "=\n="))
- (write r0 ,mel-ccl-high-table)
- (write r0 ,mel-ccl-low-table)
- (r0 = r1)
- (break)))))))
- (repeat)))
- ;; EOF
- ( ;(write "[EOF:") (write r4 ,mel-ccl-high-table) (write r4 ,mel-ccl-low-table) (write "]")
- (branch
- r4
- ;; 0: (start) ;
- (end)
- ;; 1: RAW ;
- (end)
- ;; 2: r0:r3=ENC ;
- (end)
- ;; 3: SOFTBREAK r0:r3=ENC ;
- (end)
- ;; 4: r0:r3=WSP ;
- ((write ,(if output-crlf "=\r\n" "=\n")) (end))
- ;; 5: SOFTBREAK r0:r3=WSP ;
- ((write ,(if output-crlf "=\r\n" "=\n")) (end))
- ;; 6: ; r0=\r:r3=CR
- (if (r6 <= 73)
- ((write "=0D") (end))
- ((write ,(if output-crlf "=\r\n=0D" "=\n=0D")) (end)))
- ;; 7: r5=WSP SOFTBREAK CR:r3=CR r0=LF ;
- (end)
- ;; 8: r5=noWSP CR:r3=CR r0=LF ;
- (end)
- ;; 9: (r6=73) ; CR:r3=CR r0=CR
- ((write ,(if output-crlf "=\r\n=0D=0D" "=\n=0D=0D")) (end))
- ;; 10: (r6=73) CR:r3=CR CR LF ;
- (end)
- ;; 11: ; r0:r3={RAW,ENC}
- (branch
- r3
- ((write r0) (end))
- ((write "=")
- (write r0 ,mel-ccl-high-table)
- (write r0 ,mel-ccl-low-table)
- (end)))
- ;; 12: ; r0:r3={RAW,ENC} r1=CR
- (branch
- r3
- ;; ; r0:r3=RAW r1=CR
- ((write ,(if output-crlf "=\r\n" "=\n"))
- (write r0)
- (write "=0D")
- (end))
- ;; ; r0:r3=ENC r1=CR
- ((write ,(if output-crlf "=\r\n=" "=\n="))
- (write r0 ,mel-ccl-high-table)
- (write r0 ,mel-ccl-low-table)
- (write "=0D")
- (end)))
- ;; 13: r0:r3=RAW CR LF ;
- ;; 13: r0:r3=RAW CRLF ;
- (end)
- ;; 14: r0:r3=ENC CR LF ;
- ;; 14: r0:r3=ENC CRLF ;
- (end)
- ;; 15: r6=0 ; "F"
- ((write "F") (end))
- ;; 16: r6=0 ; "Fr"
- ((write "Fr") (end))
- ;; 17: r6=0 ; "Fro"
- ((write "Fro") (end))
- ;; 18: r6=0 ; "From"
- ((write "From") (end))
- ;; 19: r6=0 "From " ;
- (end)
- ;; 20: r6=0 ; "."
- ((write ".") (end))
- ;; 21: r6=0 ; ".\r"
- ((write ".=0D") (end))
- ;; 22: r6=0 ; "."
- ((write ".") (end))
- ;; 23: r6=0 ".\r\n" ;
- (end)
- ))
- ))
+ (repeat)))
+ (` ((write "=")
+ (write r1 (, mel-ccl-high-table))
+ (write r1 (, mel-ccl-low-table)) (end)))
+ (` (((, column) += 1)
+ ((, after-wsp) = 1)
+ (write-repeat r1)))
+ (` ((write r1)
+ (write (, (concat soft "=0D")))
+ (end)))
+ (` (((, column) = 3)
+ ((, after-wsp) = 0)
+ (write r1)
+ (write-repeat (, (concat soft "=0D")))))
+ (` ((write "=")
+ (write r1 (, mel-ccl-high-table))
+ (write r1 (, mel-ccl-low-table))
+ (end)))
+ (` (((, column) += 1)
+ ((, after-wsp) = 1)
+ (write-repeat r1))))))
+ (if ((, column) < 75)
+ (((, column) += 1)
+ ((, after-wsp) = 1)
+ (, (mel-ccl-set-eof-block (` ((write (, soft)) (end)))))
+ (write-read-repeat r0))
+ ((write (, soft))
+ ((, column) = 0)
+ ((, after-wsp) = 0)
+ (repeat)))))
+ ;; r0:type-brk
+ (, (if input-crlf
+ ;; r0{CR}:type-brk
+ (` ((if (((, column) > 73) & (, after-wsp))
+ (((, column) = 0)
+ ((, after-wsp) = 0)
+ (write (, soft))))
+ (, (mel-ccl-set-eof-block (` ((if ((, column) > 73) (write (, soft)))
+ (write "=0D") (end)))))
+ (read-if (r0 == ?\n)
+ (if (, after-wsp)
+ (((, after-wsp) = 0)
+ ((, column) = 0)
+ (write (, (concat soft hard)))
+ (, (mel-ccl-set-eof-block '(end)))
+ (read r0)
+ (repeat))
+ (((, after-wsp) = 0)
+ ((, column) = 0)
+ (write (, hard))
+ (, (mel-ccl-set-eof-block '(end)))
+ (read r0)
+ (repeat)))
+ (if ((, column) < 73)
+ (((, after-wsp) = 0)
+ ((, column) += 3)
+ (write-repeat "=0D"))
+ (if ((, column) < 74)
+ (if (r0 == ?\r)
+ (((, after-wsp) = 0)
+ (, (mel-ccl-set-eof-block
+ (` ((write (, (concat soft "=0D=0D"))) (end)))))
+ (read-if (r0 == ?\n)
+ (((, column) = 0)
+ (, (mel-ccl-set-eof-block
+ (` ((write (, (concat "=0D" hard))) (end)))))
+ (read r0)
+ (write-repeat (, (concat "=0D" hard))))
+ (((, column) = 6)
+ (write-repeat (, (concat soft "=0D=0D"))))))
+ (((, after-wsp) = 0)
+ ((, column) = 3)
+ (write-repeat (, (concat soft "=0D")))))
+ (((, after-wsp) = 0)
+ ((, column) = 3)
+ (write-repeat (, (concat soft "=0D")))))))))
+ ;; r0{LF}:type-brk
+ (` (if (, after-wsp)
+ ;; WSP ; r0{LF}:type-brk
+ (((, after-wsp) = 0)
+ ((, column) = 0)
+ (write (, (concat soft (if output-crlf "\r" ""))))
+ (, (mel-ccl-set-eof-block (` (end)))) (write-read-repeat r0))
+ ;; noWSP ; r0{LF}:type-brk
+ (((, after-wsp) = 0)
+ ((, column) = 0)
+ (,@ (if output-crlf '((write ?\r)) '()))
+ (, (mel-ccl-set-eof-block (` (end))))
+ (write-read-repeat r0))))
+ ))))))
+ (branch
+ (, eof-block-reg)
+ (,@ (reverse (mapcar (quote car) eof-block-branches))))))))
(defun mel-ccl-decode-quoted-printable-generic (input-crlf output-crlf)
- `(1
- ((read r0)
- (loop
- (branch
- r0
- ,@(mapcar
- (lambda (r0)
- (let ((tmp (aref mel-ccl-qp-table r0)))
- (cond
- ((eq tmp 'raw) `(write-read-repeat r0))
- ((eq tmp 'wsp) (if (eq r0 (char-int ? ))
- `(r1 = 1)
- `(r1 = 0)))
- ((eq tmp 'cr)
- (if input-crlf
- ;; r0='\r'
- `((read r0)
- ;; '\r' r0
- (if (r0 == ?\n)
- ;; '\r' r0='\n'
- ;; hard line break found.
- ,(if output-crlf
- '((write ?\r)
- (write-read-repeat r0))
- '(write-read-repeat r0))
- ;; '\r' r0:[^\n]
- ;; invalid control character (bare CR) found.
- ;; -> ignore it and rescan from r0.
- (repeat)))
- ;; r0='\r'
- ;; invalid character (bare CR) found.
- ;; -> ignore.
- `((read r0)
- (repeat))))
- ((eq tmp 'lf)
- (if input-crlf
- ;; r0='\n'
- ;; invalid character (bare LF) found.
- ;; -> ignore.
- `((read r0)
- (repeat))
- ;; r0='\r\n'
- ;; hard line break found.
- (if output-crlf
- '((write ?\r)
- (write-read-repeat r0))
- '(write-read-repeat r0))))
- ((eq r0 (char-int ?=))
- ;; r0='='
- `((read r0)
- ;; '=' r0
- (r1 = (r0 == ?\t))
- (if ((r0 == ? ) | r1)
- ;; '=' r0:[\t ]
- ;; Skip transport-padding.
- ;; It should check CR LF after
- ;; transport-padding.
- (loop
- (read-if (r0 == ?\t)
- (repeat)
- (if (r0 == ? )
- (repeat)
- (break)))))
- ;; '=' [\t ]* r0:[^\t ]
- (branch
- r0
- ,@(mapcar
- (lambda (r0)
- (cond
- ((eq r0 (char-int ?\r))
- (if input-crlf
- ;; '=' [\t ]* r0='\r'
- `((read r0)
- ;; '=' [\t ]* '\r' r0
- (if (r0 == ?\n)
- ;; '=' [\t ]* '\r' r0='\n'
- ;; soft line break found.
- ((read r0)
- (repeat))
- ;; '=' [\t ]* '\r' r0:[^\n]
- ;; invalid input ->
- ;; output "=" and rescan from r0.
- ((write "=")
- (repeat))))
- ;; '=' [\t ]* r0='\r'
- ;; invalid input (bare CR found) ->
- ;; output "=" and rescan from next.
- `((write ?=)
- (read r0)
- (repeat))))
- ((eq r0 (char-int ?\n))
- (if input-crlf
- ;; '=' [\t ]* r0='\n'
- ;; invalid input (bare LF found) ->
- ;; output "=" and rescan from next.
- `((write ?=)
- (read r0)
- (repeat))
- ;; '=' [\t ]* r0='\r\n'
- ;; soft line break found.
- `((read r0)
- (repeat))))
- ((setq tmp (nth r0 mel-ccl-256-to-16-table))
- ;; '=' [\t ]* r0:[0-9A-F]
- ;; upper nibble of hexadecimal digit found.
- `((r1 = r0)
- (r0 = ,tmp)))
- (t
- ;; '=' [\t ]* r0:[^\r0-9A-F]
- ;; invalid input ->
- ;; output "=" and rescan from r0.
- `((write ?=)
- (repeat)))))
- mel-ccl-256-table))
- ;; '=' [\t ]* r1:r0:[0-9A-F]
- (read-branch
- r2
- ,@(mapcar
- (lambda (r2)
- (if (setq tmp (nth r2 mel-ccl-256-to-16-table))
- ;; '=' [\t ]* r1:r0:[0-9A-F] r2:[0-9A-F]
- `(write-read-repeat
- r0
- ,(vconcat
- (mapcar
- (lambda (r0)
- (logior (lsh r0 4) tmp))
- mel-ccl-16-table)))
- ;; '=' [\t ]* r1:r0:[0-9A-F] r2:[^0-9A-F]
- ;; invalid input
- `(r3 = 0) ; nop
- ))
- mel-ccl-256-table))
- ;; '=' [\t ]* r1:r0:[0-9A-F] r2:[^0-9A-F]
- ;; invalid input ->
- ;; output "=" with hex digit and rescan from r2.
- (write ?=)
- (r0 = r2)
- (write-repeat r1)))
- (t
- ;; r0:[^\t\r -~]
- ;; invalid character found.
- ;; -> ignore.
- `((read r0)
- (repeat))))))
- mel-ccl-256-table))
+ (` (1
+ ((read r0)
+ (loop
+ (branch
+ r0
+ (,@ (mapcar
+ (lambda (r0)
+ (let ((tmp (aref mel-ccl-qp-table r0)))
+ (cond
+ ((eq tmp 'raw) (` (write-read-repeat r0)))
+ ((eq tmp 'wsp) (if (eq r0 (char-int ? ))
+ (` (r1 = 1))
+ (` (r1 = 0))))
+ ((eq tmp 'cr)
+ (if input-crlf
+ ;; r0='\r'
+ (` ((read r0)
+ ;; '\r' r0
+ (if (r0 == ?\n)
+ ;; '\r' r0='\n'
+ ;; hard line break found.
+ (, (if output-crlf
+ '((write ?\r)
+ (write-read-repeat r0))
+ '(write-read-repeat r0)))
+ ;; '\r' r0:[^\n]
+ ;; invalid control character (bare CR) found.
+ ;; -> ignore it and rescan from r0.
+ (repeat))))
+ ;; r0='\r'
+ ;; invalid character (bare CR) found.
+ ;; -> ignore.
+ (` ((read r0)
+ (repeat)))))
+ ((eq tmp 'lf)
+ (if input-crlf
+ ;; r0='\n'
+ ;; invalid character (bare LF) found.
+ ;; -> ignore.
+ (` ((read r0)
+ (repeat)))
+ ;; r0='\r\n'
+ ;; hard line break found.
+ (if output-crlf
+ '((write ?\r)
+ (write-read-repeat r0))
+ '(write-read-repeat r0))))
+ ((eq r0 (char-int ?=))
+ ;; r0='='
+ (` ((read r0)
+ ;; '=' r0
+ (r1 = (r0 == ?\t))
+ (if ((r0 == ? ) | r1)
+ ;; '=' r0:[\t ]
+ ;; Skip transport-padding.
+ ;; It should check CR LF after
+ ;; transport-padding.
+ (loop
+ (read-if (r0 == ?\t)
+ (repeat)
+ (if (r0 == ? )
+ (repeat)
+ (break)))))
+ ;; '=' [\t ]* r0:[^\t ]
+ (branch
+ r0
+ (,@ (mapcar
+ (lambda (r0)
+ (cond
+ ((eq r0 (char-int ?\r))
+ (if input-crlf
+ ;; '=' [\t ]* r0='\r'
+ (` ((read r0)
+ ;; '=' [\t ]* '\r' r0
+ (if (r0 == ?\n)
+ ;; '=' [\t ]* '\r' r0='\n'
+ ;; soft line break found.
+ ((read r0)
+ (repeat))
+ ;; '=' [\t ]* '\r' r0:[^\n]
+ ;; invalid input ->
+ ;; output "=" and rescan from r0.
+ ((write "=")
+ (repeat)))))
+ ;; '=' [\t ]* r0='\r'
+ ;; invalid input (bare CR found) ->
+ ;; output "=" and rescan from next.
+ (` ((write ?=)
+ (read r0)
+ (repeat)))))
+ ((eq r0 (char-int ?\n))
+ (if input-crlf
+ ;; '=' [\t ]* r0='\n'
+ ;; invalid input (bare LF found) ->
+ ;; output "=" and rescan from next.
+ (` ((write ?=)
+ (read r0)
+ (repeat)))
+ ;; '=' [\t ]* r0='\r\n'
+ ;; soft line break found.
+ (` ((read r0)
+ (repeat)))))
+ ((setq tmp (nth r0 mel-ccl-256-to-16-table))
+ ;; '=' [\t ]* r0:[0-9A-F]
+ ;; upper nibble of hexadecimal digit found.
+ (` ((r1 = (r0 + 0))
+ (r0 = (, tmp)))))
+ (t
+ ;; '=' [\t ]* r0:[^\r0-9A-F]
+ ;; invalid input ->
+ ;; output "=" and rescan from r0.
+ (` ((write ?=)
+ (repeat))))))
+ mel-ccl-256-table)))
+ ;; '=' [\t ]* r1:r0:[0-9A-F]
+ (read-branch
+ r2
+ (,@ (mapcar
+ (lambda (r2)
+ (if (setq tmp (nth r2 mel-ccl-256-to-16-table))
+ ;; '=' [\t ]* r1:r0:[0-9A-F] r2:[0-9A-F]
+ (` (write-read-repeat
+ r0
+ (, (vconcat
+ (mapcar
+ (lambda (r0)
+ (logior (lsh r0 4) tmp))
+ mel-ccl-16-table)))))
+ ;; '=' [\t ]* r1:r0:[0-9A-F] r2:[^0-9A-F]
+ ;; invalid input
+ (` (r3 = 0)) ; nop
+ ))
+ mel-ccl-256-table)))
+ ;; '=' [\t ]* r1:r0:[0-9A-F] r2:[^0-9A-F]
+ ;; invalid input ->
+ ;; output "=" with hex digit and rescan from r2.
+ (write ?=)
+ (r0 = (r2 + 0))
+ (write-repeat r1))))
+ (t
+ ;; r0:[^\t\r -~]
+ ;; invalid character found.
+ ;; -> ignore.
+ (` ((read r0)
+ (repeat)))))))
+ mel-ccl-256-table)))
;; r1[0]:[\t ]
(loop
- ,@(apply
- 'append
- (mapcar
- (lambda (regnum)
- (let ((reg (aref [r1 r2 r3 r4 r5] regnum)))
- (apply
- 'append
- (mapcar
- (lambda (bit)
- (if (= bit 0)
- (if (= regnum 0)
- nil
- `((read r0)
- (if (r0 == ?\t)
- (,reg = 0)
- (if (r0 == ?\ )
- (,reg = 1)
- ((r6 = ,(+ (* regnum 28) bit))
- (break))))))
- `((read r0)
- (if (r0 == ?\ )
- (,reg |= ,(lsh 1 bit))
- (if (r0 != ?\t)
- ((r6 = ,(+ (* regnum 28) bit))
- (break)))))))
- mel-ccl-28-table))))
- '(0 1 2 3 4)))
+ (,@ (apply
+ 'append
+ (mapcar
+ (lambda (regnum)
+ (let ((reg (aref [r1 r2 r3 r4 r5] regnum)))
+ (apply
+ 'append
+ (mapcar
+ (lambda (bit)
+ (if (= bit 0)
+ (if (= regnum 0)
+ nil
+ (` ((read r0)
+ (if (r0 == ?\t)
+ ((, reg) = 0)
+ (if (r0 == ?\ )
+ ((, reg) = 1)
+ ((r6 = (, (+ (* regnum 28) bit)))
+ (break)))))))
+ (` ((read r0)
+ (if (r0 == ?\ )
+ ((, reg) |= (, (lsh 1 bit)))
+ (if (r0 != ?\t)
+ ((r6 = (, (+ (* regnum 28) bit)))
+ (break))))))))
+ mel-ccl-28-table))))
+ '(0 1 2 3 4))))
;; white space buffer exhaust.
;; error: line length limit (76bytes) violation.
;; -> ignore these white spaces.
(repeat))
- ,(if input-crlf
- `(if (r0 == ?\r)
- ((read r0)
- (if (r0 == ?\n)
- ;; trailing white spaces found.
- ;; -> ignore these white spacs.
- ((write ,(if output-crlf "\r\n" "\n"))
- (read r0)
- (repeat))
- ;; [\t ]* \r r0:[^\n]
- ;; error: bare CR found.
- ;; -> output white spaces and ignore bare CR.
- ))
- ;; [\t ]* r0:[^\r]
- ;; middle white spaces found.
- )
- `(if (r0 == ?\n)
- ;; trailing white spaces found.
- ;; -> ignore these white spacs.
- ((write ,(if output-crlf "\r\n" "\n"))
- (read r0)
- (repeat))
- ;; [\t ]* r0:[^\n]
- ;; middle white spaces found.
- ))
- ,@(apply
- 'append
- (mapcar
- (lambda (regnum)
- (let ((reg (aref [r1 r2 r3 r4 r5] regnum)))
- (apply
- 'append
- (mapcar
- (lambda (bit)
- `((if (,reg & ,(lsh 1 bit))
- (write ?\ )
- (write ?\t))
- (if (r6 == ,(+ (* regnum 28) bit 1))
- (repeat))))
- mel-ccl-28-table))))
- '(0 1 2 3 4)))
+ (, (if input-crlf
+ (` (if (r0 == ?\r)
+ ((read r0)
+ (if (r0 == ?\n)
+ ;; trailing white spaces found.
+ ;; -> ignore these white spacs.
+ ((write (, (if output-crlf "\r\n" "\n")))
+ (read r0)
+ (repeat))
+ ;; [\t ]* \r r0:[^\n]
+ ;; error: bare CR found.
+ ;; -> output white spaces and ignore bare CR.
+ ))
+ ;; [\t ]* r0:[^\r]
+ ;; middle white spaces found.
+ ))
+ (` (if (r0 == ?\n)
+ ;; trailing white spaces found.
+ ;; -> ignore these white spacs.
+ ((write (, (if output-crlf "\r\n" "\n")))
+ (read r0)
+ (repeat))
+ ;; [\t ]* r0:[^\n]
+ ;; middle white spaces found.
+ ))))
+ (,@ (apply
+ 'append
+ (mapcar
+ (lambda (regnum)
+ (let ((reg (aref [r1 r2 r3 r4 r5] regnum)))
+ (apply
+ 'append
+ (mapcar
+ (lambda (bit)
+ (` ((if ((, reg) & (, (lsh 1 bit)))
+ (write ?\ )
+ (write ?\t))
+ (if (r6 == (, (+ (* regnum 28) bit 1)))
+ (repeat)))))
+ mel-ccl-28-table))))
+ '(0 1 2 3 4))))
(repeat)
- ))))
+ )))))
)
(defun quoted-printable-ccl-encode-region (start end)
"Encode the region from START to END with quoted-printable encoding."
- (interactive "r")
+ (interactive "*r")
(decode-coding-region start end 'mel-ccl-quoted-printable-lf-lf-rev))
(defun quoted-printable-ccl-insert-encoded-file (filename)
"Encode contents of the file named as FILENAME, and insert it."
- (interactive (list (read-file-name "Insert encoded file: ")))
- (let ((coding-system-for-read 'mel-ccl-quoted-printable-lf-lf-rev))
- (insert-file-contents filename)))
+ (interactive "*fInsert encoded file: ")
+ (insert-file-contents-as-coding-system
+ 'mel-ccl-quoted-printable-lf-lf-rev filename))
(mel-define-method-function
(mime-encode-string string (nil "quoted-printable"))
(defun quoted-printable-ccl-decode-region (start end)
"Decode the region from START to END with quoted-printable
encoding."
- (interactive "r")
+ (interactive "*r")
(encode-coding-region start end 'mel-ccl-quoted-printable-lf-lf-rev))
-(defun quoted-printable-ccl-write-decoded-region
- (start end filename)
+(defun quoted-printable-ccl-write-decoded-region (start end filename)
"Decode quoted-printable encoded current region and write out to FILENAME."
- (interactive
- (list (region-beginning) (region-end)
- (read-file-name "Write decoded region to file: ")))
- (let ((coding-system-for-write 'mel-ccl-quoted-printable-lf-lf-rev))
- (write-region start end filename)))
+ (interactive "*r\nFWrite decoded region to file: ")
+ (write-region-as-coding-system 'mel-ccl-quoted-printable-lf-lf-rev
+ start end filename))
(mel-define-method-function
(mime-decode-string string (nil "quoted-printable"))
(unless (featurep 'xemacs)
(defun q-encoding-ccl-encoded-length (string &optional mode)
(let ((status [nil nil nil nil nil nil nil nil nil]))
- (fillarray status nil)
+ (fillarray status nil) ; XXX: Is this necessary?
(ccl-execute-on-string
(cond
((eq mode 'text) 'mel-ccl-count-uq)
'q-encoding-ccl-encode-string)
(mel-define-method encoded-text-decode-string (string (nil "Q"))
- (if (and (string-match Q-encoded-text-regexp string)
- (string= string (match-string 0 string)))
+ (if (string-match (eval-when-compile
+ (concat "\\`" Q-encoded-text-regexp "\\'"))
+ string)
(q-encoding-ccl-decode-string string)
(error "Invalid encoded-text %s" string)))
(provide 'mel-q-ccl)
-;;; mel-q-ccl.el ends here
+;;; mel-q-ccl.el ends here.
projects / elisp / flim.git / blobdiff