From: morioka Date: Tue, 27 Oct 1998 16:51:31 +0000 (+0000) Subject: Merge flim-1_11_3. X-Git-Tag: flim-199811302358~1 X-Git-Url: http://git.chise.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=f7230fcb61e32630f6bcf87e6eb8b35c564dd06c;p=elisp%2Fflim.git Merge flim-1_11_3. --- diff --git a/ChangeLog b/ChangeLog index 2d49957..e518a75 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,141 @@ +1998-10-28 MORIOKA Tomohiko + + * FLIM: Version 1.11.3 (Saidaiji) was released. + +1998-10-27 MORIOKA Tomohiko + + * VERSION: New file (Renamed from FLIM-VERSION). + +1998-10-27 MORIOKA Tomohiko + + * eword-encode.el (eword-encode-char-type): Return nil for ?\n. + +1998-10-27 Tanaka Akira + + * eword-encode.el (eword-encode-field-body): Unfold `field-body'. + +1998-10-27 Yoshiki Hayashi + + * README.ja: Update. + + +1998-10-26 MORIOKA Tomohiko + + * FLIM: Version 1.11.2 (Heij-Dò)-A was released. + + * NEWS (Abolish variable `mime-temp-directory'): New subsection. + + * README.en (Installation): Modify for APEL 9.6. + +1998-10-26 MORIOKA Tomohiko + + * eword-encode.el (eword-encode-field-body): Don't eliminate + top-spaces. + +1998-10-25 MORIOKA Tomohiko + + * FLIM-ELS (flim-modules): Don't install mel-b-el for Emacs 20.4. + +1998-10-25 Tanaka Akira + + * eword-decode.el (eword-decode-field-body): Refine implementation. + +1998-10-24 Tanaka Akira + + * mel-b-ccl.el, mel-q-ccl.el, mel.el, FLIM-ELS: Divide mel-ccl.el + into mel-b-ccl.el and mel-q-ccl.el. + +1998-09-11 Tanaka Akira + + * mel.el (base64-encoded-length): New implementation. + +1998-10-25 Tanaka Akira + + * eword-decode.el (eword-decode-field-body): New function. + +1998-10-25 MORIOKA Tomohiko + + * eword-encode.el (eword-encode-field-body): Change interface. + (eword-encode-header): Use `eword-encode-field-body'; abolish + function `eword-encode-field'. + +1998-10-25 Tanaka Akira + + * eword-encode.el (eword-encode-field-body): New function. + (eword-encode-field): Use `eword-encode-field-body'. + +1998-10-24 MORIOKA Tomohiko + + * mel.el, mel-b-el.el, FLIM-ELS: Rename mel-b.el -> mel-b-el.el. + +1998-10-24 MORIOKA Tomohiko + + * mel-u.el (uuencode-external-decode-region): Use + `temporary-file-directory' instead of `mime-temp-directory'. + (mime-write-decoded-region): Likewise. + + * mime-def.el: Abolish variable `mime-temp-directory'. + +1998-10-24 MORIOKA Tomohiko + + * mmgeneric.el (mime-insert-header-from-buffer): New function. + (insert-header): Use `mime-insert-header-from-buffer'. + +1998-10-24 MORIOKA Tomohiko + + * FLIM-ELS: Don't install mel-b-dl.el if the running emacs has + builtin base64 encoder/decoder. + + * mel.el: Set up builtin base64 encoder/decoder if they are + available. + + * mime-def.el (base64-dl-module): Set nil as initial value if the + running emacs has builtin base64 encoder/decoder. + + * mel-b.el: Require `poe' instead of `emu'. + (base64-encode-string): Use `defun-maybe'. + (base64-encode-region): Likewise. + (base64-decode-region): Likewise. + (base64-decode-string): Likewise. + + * mel-b-dl.el: Require `poe' instead of `emu'. + + +1998-10-23 MORIOKA Tomohiko + + * FLIM: Version 1.11.1 (Takanohara) was released. + +1998-10-22 Yoshiki Hayashi + + * README.ja: New file. + +1998-10-20 MORIOKA Tomohiko + + * mime-def.el: Require mcharset. + +1998-10-20 Katsumi Yamaoka + + * mel-u.el (mime-write-decoded-region): Fix typo. + + * mime-def.el: Enclose defining procedure for the constants + `std11-quoted-pair-regexp', `std11-non-qtext-char-list' and + `std11-qtext-regexp' with `eval-and-compile'. + +1998-10-19 MORIOKA Tomohiko + + * NEWS (Behavior change of `mime-insert-header'): New subsection. + + * mmgeneric.el (insert-header): Include `:' in field-name. + +1998-10-19 MORIOKA Tomohiko + + * mime-def.el (std11-qtext-regexp): Use `eval-when-compile'; don't + use `char-list-to-string'. + (std11-quoted-string-regexp): Use `eval-when-compile'. + - Use `def-edebug-spec' to define edebug-form-spec of + mm-define-method; fix definition of edebug-form-spec of + mm-define-method. + 1998-10-18 MORIOKA Tomohiko * mime-en.sgml, mime-ja.sgml (Header encoder/decoder): Add diff --git a/FLIM-ELS b/FLIM-ELS index 3e8e347..c778f88 100644 --- a/FLIM-ELS +++ b/FLIM-ELS @@ -6,20 +6,24 @@ (setq flim-modules '(std11 mime-def - mel mel-b mel-q mel-u mel-g + mel mel-q mel-u mel-g eword-decode eword-encode mime mime-parse mmgeneric mmbuffer mmcooked mailcap)) -(if (fboundp 'dynamic-link) - (setq flim-modules (cons 'mel-b-dl flim-modules)) +(unless (and (fboundp 'base64-encode-string) + (subrp (symbol-function 'base64-encode-string))) + (if (fboundp 'dynamic-link) + (setq flim-modules (cons 'mel-b-dl flim-modules)) + ) + (setq flim-modules (cons 'mel-b-el flim-modules)) ) (if (and (featurep 'mule) (not (or (and (boundp 'MULE) MULE) (and (featurep 'xemacs) (< emacs-major-version 21)) ))) - (setq flim-modules (cons 'mel-ccl flim-modules)) + (setq flim-modules (cons 'mel-b-ccl (cons 'mel-q-ccl flim-modules))) ) ;;; FLIM-ELS ends here diff --git a/FLIM-VERSION b/FLIM-VERSION deleted file mode 100644 index 2eba772..0000000 --- a/FLIM-VERSION +++ /dev/null @@ -1,68 +0,0 @@ -[FLIM Version names] - -1.0.0 ----- - -;;------------------------------------------------------------------------- -;; Kinki Nippon Railway $(B6a5&F|K\E4F;(B http://www.kintetsu.co.jp/ -;; Ky-Dòto-A Line $(B5~ET@~(B -;;------------------------------------------------------------------------- -1.0.1 Ky-Dòto-A $(B5~ET(B ; <=> JR, $(B5~ET;T8rDL6I(B -1.1.0 T-Dòji-A $(BEl;{(B -1.2.0 J-Dþjò-A $(B==>r(B -1.2.1 Kamitobaguchi $(B>eD;1)8}(B -1.2.2 Takeda $(BC]ED(B ; = $(B5~ET;T8rDL6I(B $(B1(4]@~(B -1.3.0 Fushimi $(BIz8+(B -1.4.0 Kintetsu-Tambabashi $(B6aE4C0GH66(B ; <=> $(B5~:e(B $(BC0GH66(B -1.4.1 Momoyama-Gory-Dòmae-A $(BEm;38fNMA0(B -1.5.0 Mukaijima $(B8~Eg(B -1.6.0 Ogura $(B>.AR(B -1.7.0 Iseda $(B0K@*ED(B -1.8.0 -DÒkubo-A $(BBg5WJ](B -1.8.1 Kutsukawa $(B5WDE@n(B -1.9.0 Terada $(B;{ED(B -1.9.1 Tonosh-Dò-A $(BIYLnAq(B -1.9.2 Shin-Tanabe $(B?7EDJU(B -1.10.0 K-Dòdo-A $(B6=8M(B -1.10.1 Miyamaki $(B;0;3LZ(B -1.10.2 Kintetsu-Miyazu $(B6aE45\DE(B -1.10.3 Komada $(B9}ED(B -1.10.4 Shin-H-Dòsono-A $(B?7=K1`(B ; <=> JR $(BJRD.@~(B $(B=K1`(B -1.10.5 Kizugawadai $(BLZDE@nBf(B -1.11.0 Yamadagawa $(B;3ED@n(B ------ Takanohara $(B9b$N86(B ------ Heij-Dò-A $(BJ?>k(B ------ Saidaiji $(B@>Bg;{(B -;;------------------------------------------------------------------------- -;; Kinki Nippon Railway $(B6a5&F|K\E4F;(B http://www.kintetsu.co.jp/ -;; Ky-Dòto-A Line $(B3`86@~(B -;;------------------------------------------------------------------------- - (Saidaiji) ($(B@>Bg;{(B) ------ Amagatsuji $(BFt%vDT(B ------ Nishinoky-Dò-A $(B@>$N5~(B ------ Kuj-Dò-A $(B6e>r(B ------ Kintetsu-K-Dòriyama-A $(B6aE474;3(B - - -[Chao Version names] - -;;------------------------------------------------------------------------- -;; Kyoto Municipal Transfer Bureau -;; $(B5~ET;T8rDL6I(B -;; http://www.city.kyoto.jp/kotsu/main.htm -;; Karasuma Line $(B1(4]@~(B -;;------------------------------------------------------------------------- -1.2.0 Takeda $(BC]ED(B ; = $(B6aE4(B $(B5~ET@~(B -1.3.0 Kuinabashi $(B$/$$$J66(B -1.4.0 J-Dþjò-A $(B==>r(B -1.6.0 Kuj-Dò-A $(B6e>r(B -1.6.1 Ky-Dòto-A $(B5~ET(B ; <=> JR, $(B6aE4(B -1.7.0 Goj-Dò-A $(B8^>r(B -1.8.0 Shij-Dò-A $(B;M>r(B ; <=> $(B:e5^(B $(B5~ET@~(B -1.9.0 Karasuma Oike $(B1(4]8fCS(B ; = $(B5~ET;T8rDL6I(B $(BEl@>@~(B -1.10.0 Marutamach $(B4]B@D.(B -1.11.0 Imadegawa $(B:#=P@n(B -1.11.1 Kuramaguchi $(B0HGO8}(B -1.11.2 Kita-Dòji-A $(BKLBgO)(B -1.11.3 Kitayama $(BKL;3(B -1.11.4 Matugasaki $(B>>%v:j(B -1.11.5 Kokusaikaikan $(B9q:]2q4[(B diff --git a/Makefile b/Makefile index c9ea336..d1565ef 100644 --- a/Makefile +++ b/Makefile @@ -3,7 +3,7 @@ # PACKAGE = flim -VERSION = 1.11.0 +VERSION = 1.11.3 TAR = tar RM = /bin/rm -f diff --git a/NEWS b/NEWS index af32579..7662287 100644 --- a/NEWS +++ b/NEWS @@ -17,6 +17,19 @@ Similarly generic function `mime-insert-decoded-header' was renamed to as an obsolete alias. +** Behavior change of `mime-insert-header' + +Each field-name of second and third argument of function +`mime-insert-header' can include `:'. + + +** Abolish variable `mime-temp-directory' + +Now FLIM uses `temporary-file-directory' instead of +`mime-temp-directory'. So environment variable "MIME_TMP_DIR" and +"TM_TMP_DIR" are not effective to specify temporary directory of FLIM. + + ** Add new function `eword-decode-and-unfold-unstructured-field' diff --git a/README.en b/README.en index 004fbe3..4213653 100644 --- a/README.en +++ b/README.en @@ -36,7 +36,7 @@ What's FLIM Installation ============ -(0) before installing it, please install APEL (9.4 or later) package. +(0) before installing it, please install APEL (9.6 or later) package. APEL package is available at: ftp://ftp.jaist.ac.jp/pub/GNU/elisp/apel/ diff --git a/README.ja b/README.ja new file mode 100644 index 0000000..a3233bb --- /dev/null +++ b/README.ja @@ -0,0 +1,159 @@ +[FLIM $B$N(B README ($BF|K\8lHG(B)] + +FLIM $B$H$O!)(B +=========== + + FLIM $B$O%a%C%;!<%8I=8=$HId9f2=$K4X$9$k4pACE*$J5!G=$rDs6!$9$k%i%$%V%i(B + $B%j!<$G$9!#0J2<$N%b%8%e!<%k$+$i9=@.$5$l$F$$$^$9(B: + + std11.el --- STD 11 (RFC 822) $B$N2r@O4o$H%f!<%F%#%j%F%#!<(B + + mime.el --- MIME $B%i%$%V%i%j!<(B + + mime-def.el --- MIME $B$NMM<0$K4X$9$kDj5A(B + + mime-parse.el --- MIME $B2r@O4o(B + + mel.el --- MIME $BId9f4o(B/$BI|9f4o(B + mel-b-dl.el --- base64 (B-encoding) $BId9f4o(B/$BI|9f4o(B + (Emacs 20 $B$NF0E*FI$_9~$_5!G=IU$-MQ(B) + mel-b.el --- base64 (B-encoding) $BId9f4o(B/$BI|9f4o(B + ($BB>$N(B emacs $B4D6-MQ(B) + mel-q.el --- quoted-printable $B$H(B Q-encoding + $BId9f4o(B/$BI|9f4o(B + mel-ccl.el --- CCL $B$r;H$C$?(B base64 (B-encoding), + quoted-printable $B$H(B Q-encoding $B$NId9f4o(B/$BI|9f4o(B + mel-u.el --- uuencode $B$N$?$a$NHs8x<0%b%8%e!<%k(B + mel-g.el --- gzip64 $B$N$?$a$NHs8x<0%b%8%e!<%k(B + + eword-decode.el --- encoded-word $BI|9f4o(B + eword-encode.el --- encoded-word $BId9f4o(B + + mailcap.el --- mailcap $B2r@O4o$H%f!<%F%#%j%F%#!<(B + + +$B%$%s%9%H!<%k(B +============ + +(0) $B%$%s%9%H!<%k$9$kA0$K!"(BAPEL $B%Q%C%1!<%8(B (9.6 $B0J9_(B) + $B$r%$%s%9%H!<%k$7$F$/$@$5$$!#(BAPEL $B%Q%C%1!<%8$O0J2<$N$H$3$m$Gl=j$G$N%G%#%l%/%H%j!<$K%$%s%9%H!<%k$7$?$/$J$$$J$i!"0J2<$N$3$H$@$1$r$d$C(B + $B$F$/$@$5$$(B: + + % make + + emacs $B$N%3%^%s%IL>$r;XDj$9$k$3$H$,$G$-$^$9!#Nc$($P!"(B + + % make EMACS=xemacs + + `EMACS=...' $B$,>JN,$5$l$k$H!"(BEmacs=emacs $B$,;H$o$l$^$9!#(B + +(b) make install + + $BB>$N%G%#%l%/%H%j!<$K%$%s%9%H!<%k$7$?$$$J$i!"0J2<$N$3$H$r$7$F$/$@$5$$(B: + + % make install + + emacs $B$N%3%^%s%IL>$r;XDj$9$k$3$H$,$G$-$^$9!#Nc$($P!"(B + + % make install EMACS=xemacs + + `EMACS=...' $B$,>JN,$5$l$k$H!"(BEmacs=emacs $B$,;H$o$l$^$9!#(B + + Emacs Lisp $B%W%m%0%i%`$H%7%'%k%9%/%j%W%H$N$?$a$N%G%#%l%/%H%j!JN,$5$l$k$H!";XDj$5$l$?(B emacs $B%3%^%s%I$N%G%#%l%/%H%j!<(B + $BLZ$N@\F,<-$,;HMQ$5$l$^$9(B ($B$*$=$i$/(B /usr/local $B$G$9(B)$B!#(B + + $BNc$($P!"(BPREFIX=/usr/local $B$H(B Emacs 19.34 $B$,;XDj$5$l$l$P!"0J2<$N%G%#%l(B + $B%/%H%j!JN,$5$l$k$H!";XDj$5$l$?(B emacs $B$N%3%^%s%I$N(B + site-lisp $B%G%#%l%/%H%j!<$,;H$o$l$^$9(B ($B$*$=$i$/(B + /usr/local/share/emacs/site-lisp $B$+(B /usr/local/lib/xemacs/site-lisp) + $B$G$9!#(B + + emu $B%b%8%e!<%k(B (APEL $B%Q%C%1!<%8$KF~$C$F$$$^$9(B) $B$,I8=`$G$J$$%G%#%l%/(B + $B%H%j!<$K%$%s%9%H!<%k$5$l$F$$$k>l9g$O!"$=$l$i$N$"$k>l=j$r;XDj$9$kI,MW(B + $B$,$"$j$^$9!#Nc$($P!"(B: + + % make install VERSION_SPECIFIC_LISPDIR=~/elisp + + $B$I$N%U%!%$%k$,(B emu $B%b%8%e!<%k$+(B apel $B%b%8%e!<%k$N0lIt$J$N$+!"$=$l$i(B + $B$,$I$3$K%$%s%9%H!<%k$5$l$k$+$rCN$j$?$$$H$-$O!"$NA*Br<+M3$J@_Dj$r;XDj$9$k$3$H$,(B + $B$G$-$^$9!#$=$NCf$N%3%a%s%H$rFI$s$G$/$@$5$$!#(B + +(1-c) XEmacs $B$N%Q%C%1!<%8$H$7$F%$%s%9%H!<%k$9$k(B + + XEmacs $B$N%Q%C%1!<%8%G%#%l%/%H%j!<$K%$%s%9%H!<%k$9$k>l9g$O!"0J2<$N$3(B + $B$H$r$7$F$/$@$5$$(B: + + % make install-package + + emacs $B$N%3%^%s%IL>$r;XDj$9$k$3$H$,$G$-$^$9!#Nc$($P!"(B + + % make install-package XEMACS=xemacs-21 + + `XEMACS=...' $B$,>JN,$5$l$k$H!"(BXEMACS=xemacs $B$,;HMQ$5$l$^$9!#(B + + $B%Q%C%1!<%8$N%G%#%l%/%H%j!<$r;XDj$9$k$3$H$,$G$-$^$9!#Nc$($P(B: + + % make install PACKAGEDIR=~/.xemacs + + `PACKAGEDIR=...' $B$,>JN,$5$l$k$H!"B8:_$9$k%Q%C%1!<%8%G%#%l%/%H%j!<$N(B + $B:G=i$N$b$N$,;H$o$l$^$9!#(B + + XEmacs $B$N%Q%C%1!<%8%7%9%F%`$O(B XEmacs 21.0 $B$+$=$l0J9_$rMW5a$9$k$3$H$K(B + $BCm0U$7$F$/$@$5$$!#(B + +load-path (Emacs $B$H(B MULE $BMQ(B) +============================= + + Emacs $B$+(B Mule $B$r;H$C$F$$$k$J$i!"(BFLIM $B$N%G%#%l%/%H%j!<$r(B + load-path $B$KDI2C$7$F$/$@$5$$!#=i4|@_Dj$G%$%s%9%H!<%k$7$?$J$i!"-Mh$N3HD%$N5DO@$r$7$?$j$9$k$3$H$,$G$-$^$9!#(Btm ML $B$K(B + $B;22C$9$k$K$O!"6u$NEE;R%a!<%k$r(B + + tm-en-help@chamonix.jaist.ac.jp ($B1Q8l(B) + tm-ja-help@chamonix.jaist.ac.jp ($BF|K\8l(B) + + $B$KAw$C$F$/$@$5$$!#(B diff --git a/VERSION b/VERSION new file mode 100644 index 0000000..136ff91 --- /dev/null +++ b/VERSION @@ -0,0 +1,68 @@ +[FLIM Version names] + +1.0.0 ----- + +;;------------------------------------------------------------------------- +;; Kinki Nippon Railway $(B6a5&F|K\E4F;(B http://www.kintetsu.co.jp/ +;; Ky-Dòto-A Line $(B5~ET@~(B +;;------------------------------------------------------------------------- +1.0.1 Ky-Dòto-A $(B5~ET(B ; <=> JR, $(B5~ET;T8rDL6I(B +1.1.0 T-Dòji-A $(BEl;{(B +1.2.0 J-Dþjò-A $(B==>r(B +1.2.1 Kamitobaguchi $(B>eD;1)8}(B +1.2.2 Takeda $(BC]ED(B ; = $(B5~ET;T8rDL6I(B $(B1(4]@~(B +1.3.0 Fushimi $(BIz8+(B +1.4.0 Kintetsu-Tambabashi $(B6aE4C0GH66(B ; <=> $(B5~:e(B $(BC0GH66(B +1.4.1 Momoyama-Gory-Dòmae-A $(BEm;38fNMA0(B +1.5.0 Mukaijima $(B8~Eg(B +1.6.0 Ogura $(B>.AR(B +1.7.0 Iseda $(B0K@*ED(B +1.8.0 -DÒkubo-A $(BBg5WJ](B +1.8.1 Kutsukawa $(B5WDE@n(B +1.9.0 Terada $(B;{ED(B +1.9.1 Tonosh-Dò-A $(BIYLnAq(B +1.9.2 Shin-Tanabe $(B?7EDJU(B +1.10.0 K-Dòdo-A $(B6=8M(B +1.10.1 Miyamaki $(B;0;3LZ(B +1.10.2 Kintetsu-Miyazu $(B6aE45\DE(B +1.10.3 Komada $(B9}ED(B +1.10.4 Shin-H-Dòsono-A $(B?7=K1`(B ; <=> JR $(BJRD.@~(B $(B=K1`(B +1.10.5 Kizugawadai $(BLZDE@nBf(B +1.11.0 Yamadagawa $(B;3ED@n(B +1.11.1 Takanohara $(B9b$N86(B +1.11.2 Heij-Dò-A $(BJ?>k(B +1.11.3 Saidaiji $(B@>Bg;{(B +;;------------------------------------------------------------------------- +;; Kinki Nippon Railway $(B6a5&F|K\E4F;(B http://www.kintetsu.co.jp/ +;; Ky-Dòto-A Line $(B3`86@~(B +;;------------------------------------------------------------------------- + (Saidaiji) ($(B@>Bg;{(B) +----- Amagatsuji $(BFt%vDT(B +----- Nishinoky-Dò-A $(B@>$N5~(B +----- Kuj-Dò-A $(B6e>r(B +----- Kintetsu-K-Dòriyama-A $(B6aE474;3(B + + +[Chao Version names] + +;;------------------------------------------------------------------------- +;; Kyoto Municipal Transfer Bureau +;; $(B5~ET;T8rDL6I(B +;; http://www.city.kyoto.jp/kotsu/main.htm +;; Karasuma Line $(B1(4]@~(B +;;------------------------------------------------------------------------- +1.2.0 Takeda $(BC]ED(B ; = $(B6aE4(B $(B5~ET@~(B +1.3.0 Kuinabashi $(B$/$$$J66(B +1.4.0 J-Dþjò-A $(B==>r(B +1.6.0 Kuj-Dò-A $(B6e>r(B +1.6.1 Ky-Dòto-A $(B5~ET(B ; <=> JR, $(B6aE4(B +1.7.0 Goj-Dò-A $(B8^>r(B +1.8.0 Shij-Dò-A $(B;M>r(B ; <=> $(B:e5^(B $(B5~ET@~(B +1.9.0 Karasuma Oike $(B1(4]8fCS(B ; = $(B5~ET;T8rDL6I(B $(BEl@>@~(B +1.10.0 Marutamach $(B4]B@D.(B +1.11.0 Imadegawa $(B:#=P@n(B +1.11.1 Kuramaguchi $(B0HGO8}(B +1.11.2 Kita-Dòji-A $(BKLBgO)(B +1.11.3 Kitayama $(BKL;3(B +1.11.4 Matugasaki $(B>>%v:j(B +1.11.5 Kokusaikaikan $(B9q:]2q4[(B diff --git a/eword-decode.el b/eword-decode.el index 2414a7a..d85bce3 100644 --- a/eword-decode.el +++ b/eword-decode.el @@ -4,7 +4,7 @@ ;; Author: ENAMI Tsugutomo ;; MORIOKA Tomohiko -;; Maintainer: MORIOKA Tomohiko +;; TANAKA Akira ;; Created: 1995/10/03 ;; Original: 1992/07/20 ENAMI Tsugutomo's `mime.el'. ;; Renamed: 1993/06/03 to tiny-mime.el @@ -289,6 +289,48 @@ Each field name must be symbol." :group 'eword-decode :type '(repeat symbol)) +(defun eword-decode-field-body + (field-body field-name &optional unfolded max-column) + "Decode FIELD-BODY as FIELD-NAME, and return the result. + +If UNFOLDED is non-nil, it is assumed that FIELD-BODY is +already unfolded. + +If MAX-COLUMN is non-nil, the result is folded with MAX-COLUMN +or `fill-column' if MAX-COLUMN is t. +Otherwise, the result is unfolded. + +MIME encoded-word in FIELD-BODY is recognized according to +`eword-decode-ignored-field-list', +`eword-decode-structured-field-list' and FIELD-NAME. + +Non MIME encoded-word part in FILED-BODY is decoded with +`default-mime-charset'." + (when (eq max-column t) + (setq max-column fill-column)) + (let (field-name-symbol len) + (if (symbolp field-name) + (setq field-name-symbol field-name + len (1+ (string-width (symbol-name field-name)))) + (setq field-name-symbol (intern (capitalize field-name)) + len (1+ (string-width field-name)))) + (if (memq field-name-symbol eword-decode-ignored-field-list) + ;; Don't decode + (if max-column + field-body + (std11-unfold-string field-body)) + (if (memq field-name-symbol eword-decode-structured-field-list) + ;; Decode as structured field + (if max-column + (eword-decode-and-fold-structured-field + field-body len max-column t) + (eword-decode-and-unfold-structured-field field-body)) + ;; Decode as unstructured field + (if max-column + (eword-decode-unstructured-field-body field-body len) + (eword-decode-unstructured-field-body + (std11-unfold-string field-body) len)))))) + (defun eword-decode-header (&optional code-conversion separator) "Decode MIME encoded-words in header fields. If CODE-CONVERSION is nil, it decodes only encoded-words. If it is diff --git a/eword-encode.el b/eword-encode.el index c1603cd..c87d5fa 100644 --- a/eword-encode.el +++ b/eword-encode.el @@ -109,7 +109,7 @@ MODE is allows `text', `comment', `phrase' or nil. Default value is ;;; (defsubst eword-encode-char-type (character) - (if (or (eq character ? )(eq character ?\t)) + (if (memq character '(? ?\t ?\n)) nil (char-charset character) )) @@ -592,48 +592,37 @@ Optional argument COLUMN is start-position of the field." (or column eword-encode-default-start-column) (eword-encode-split-string string 'text)))) -(defun eword-encode-field (string) - "Encode header field STRING, and return the result. +(defun eword-encode-field-body (field-body field-name) + "Encode FIELD-BODY as FIELD-NAME, and return the result. A lexical token includes non-ASCII character is encoded as MIME encoded-word. ASCII token is not encoded." - (setq string (std11-unfold-string string)) - (let ((ret (string-match std11-field-head-regexp string))) - (or (if ret - (let ((field-name (substring string 0 (1- (match-end 0)))) - (field-body (eliminate-top-spaces - (substring string (match-end 0)))) - field-name-symbol) - (if (setq ret - (cond ((string= field-body "") "") - ((memq (setq field-name-symbol - (intern (capitalize field-name))) - '(Reply-To - From Sender - Resent-Reply-To Resent-From - Resent-Sender To Resent-To - Cc Resent-Cc Bcc Resent-Bcc - Dcc)) - (eword-encode-address-list - field-body (+ (length field-name) 2)) - ) - ((eq field-name-symbol 'In-Reply-To) - (eword-encode-in-reply-to - field-body (+ (length field-name) 2)) - ) - ((memq field-name-symbol - '(Mime-Version User-Agent)) - (eword-encode-structured-field-body - field-body (+ (length field-name) 2)) - ) - (t - (eword-encode-unstructured-field-body - field-body (1+ (length field-name))) - )) - ) - (concat field-name ": " ret) - ))) - (eword-encode-string string 0) - ))) + (setq field-body (std11-unfold-string field-body)) + (if (string= field-body "") + "" + (let (start) + (if (symbolp field-name) + (setq start (1+ (length (symbol-name field-name)))) + (setq start (1+ (length field-name)) + field-name (intern (capitalize field-name)))) + (cond ((memq field-name + '(Reply-To + From Sender + Resent-Reply-To Resent-From + Resent-Sender To Resent-To + Cc Resent-Cc Bcc Resent-Bcc + Dcc)) + (eword-encode-address-list field-body start) + ) + ((eq field-name 'In-Reply-To) + (eword-encode-in-reply-to field-body start) + ) + ((memq field-name '(Mime-Version User-Agent)) + (eword-encode-structured-field-body field-body start) + ) + (t + (eword-encode-unstructured-field-body field-body start) + )) + ))) (defun eword-in-subject-p () (let ((str (std11-field-body "Subject"))) @@ -665,27 +654,28 @@ It refer variable `eword-field-encoding-method-alist'." (std11-narrow-to-header mail-header-separator) (goto-char (point-min)) (let ((default-cs (mime-charset-to-coding-system default-mime-charset)) - beg end field-name) + bbeg end field-name) (while (re-search-forward std11-field-head-regexp nil t) - (setq beg (match-beginning 0)) - (setq field-name (buffer-substring beg (1- (match-end 0)))) - (setq end (std11-field-end)) - (and (find-non-ascii-charset-region beg end) + (setq bbeg (match-end 0) + field-name (buffer-substring (match-beginning 0) (1- bbeg)) + end (std11-field-end)) + (and (find-non-ascii-charset-region bbeg end) (let ((method (eword-find-field-encoding-method (downcase field-name)))) (cond ((eq method 'mime) - (let ((field - (buffer-substring-no-properties beg end) + (let ((field-body + (buffer-substring-no-properties bbeg end) )) - (delete-region beg end) - (insert (eword-encode-field field)) + (delete-region bbeg end) + (insert (eword-encode-field-body field-body + field-name)) )) (code-conversion (let ((cs (or (mime-charset-to-coding-system method) default-cs))) - (encode-coding-region beg end cs) + (encode-coding-region bbeg end cs) ))) )) )) diff --git a/mel-b-ccl.el b/mel-b-ccl.el new file mode 100644 index 0000000..b01650c --- /dev/null +++ b/mel-b-ccl.el @@ -0,0 +1,413 @@ +;;; mel-b-ccl.el: CCL based encoder/decoder of Base64 + +;; Copyright (C) 1998 Tanaka Akira + +;; Author: Tanaka Akira +;; Created: 1998/9/17 +;; Keywords: MIME, Base64 + +;; This file is part of FLIM (Faithful Library about Internet Message). + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, 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 +;; 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 +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(require 'ccl) +(require 'pccl) +(require 'mime-def) + + +;;; @ constants +;;; + +(eval-when-compile + +(defconst mel-ccl-4-table + '( 0 1 2 3)) + +(defconst mel-ccl-16-table + '( 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)) + +(defconst mel-ccl-64-table + '( 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 + 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 + 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 + 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63)) + +(defconst mel-ccl-256-table + '( 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 + 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 + 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 + 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 + 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 + 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 + 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 + 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 + 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 + 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 + 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 + 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 + 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 + 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 + 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 + 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255)) + +(defconst mel-ccl-256-to-64-table + '(nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil + nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil + nil nil nil nil nil nil nil nil nil nil nil 62 nil nil nil 63 + 52 53 54 55 56 57 58 59 60 61 nil nil nil t nil nil + nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 + 15 16 17 18 19 20 21 22 23 24 25 nil nil nil nil nil + nil 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 + 41 42 43 44 45 46 47 48 49 50 51 nil nil nil nil nil + nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil + nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil + nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil + nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil + nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil + nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil + nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil + nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) + +(defconst mel-ccl-64-to-256-table + (mapcar + 'char-int + "ABCDEFGHIJKLMNOPQRSTUVWXYZ\ +abcdefghijklmnopqrstuvwxyz\ +0123456789\ ++/")) + +) + + +;;; @ CCL programs +;;; + +(eval-when-compile + +(defun mel-ccl-decode-b-bit-ex (v) + (logior + (lsh (logand v (lsh 255 16)) -16) + (logand v (lsh 255 8)) + (lsh (logand v 255) 16))) + +(defconst mel-ccl-decode-b-0-table + (vconcat + (mapcar + (lambda (v) + (if (integerp v) + (mel-ccl-decode-b-bit-ex (lsh v 18)) + (lsh 1 24))) + mel-ccl-256-to-64-table))) + +(defconst mel-ccl-decode-b-1-table + (vconcat + (mapcar + (lambda (v) + (if (integerp v) + (mel-ccl-decode-b-bit-ex (lsh v 12)) + (lsh 1 25))) + mel-ccl-256-to-64-table))) + +(defconst mel-ccl-decode-b-2-table + (vconcat + (mapcar + (lambda (v) + (if (integerp v) + (mel-ccl-decode-b-bit-ex (lsh v 6)) + (lsh 1 26))) + mel-ccl-256-to-64-table))) + +(defconst mel-ccl-decode-b-3-table + (vconcat + (mapcar + (lambda (v) + (if (integerp v) + (mel-ccl-decode-b-bit-ex v) + (lsh 1 27))) + mel-ccl-256-to-64-table))) + +) + +(define-ccl-program mel-ccl-decode-b + `(1 + (loop + (read r0 r1 r2 r3) + (r4 = r0 ,mel-ccl-decode-b-0-table) + (r5 = r1 ,mel-ccl-decode-b-1-table) + (r4 |= r5) + (r5 = r2 ,mel-ccl-decode-b-2-table) + (r4 |= r5) + (r5 = r3 ,mel-ccl-decode-b-3-table) + (r4 |= r5) + (if (r4 & ,(lognot (1- (lsh 1 24)))) + ((loop + (if (r4 & ,(lsh 1 24)) + ((r0 = r1) (r1 = r2) (r2 = r3) (read r3) + (r4 >>= 1) (r4 &= ,(logior (lsh 7 24))) + (r5 = r3 ,mel-ccl-decode-b-3-table) + (r4 |= r5) + (repeat)) + (break))) + (loop + (if (r4 & ,(lsh 1 25)) + ((r1 = r2) (r2 = r3) (read r3) + (r4 >>= 1) (r4 &= ,(logior (lsh 7 24))) + (r5 = r3 ,mel-ccl-decode-b-3-table) + (r4 |= r5) + (repeat)) + (break))) + (loop + (if (r2 != ?=) + (if (r4 & ,(lsh 1 26)) + ((r2 = r3) (read r3) + (r4 >>= 1) (r4 &= ,(logior (lsh 7 24))) + (r5 = r3 ,mel-ccl-decode-b-3-table) + (r4 |= r5) + (repeat)) + ((r6 = 0) + (break))) + ((r6 = 1) + (break)))) + (loop + (if (r3 != ?=) + (if (r4 & ,(lsh 1 27)) + ((read r3) + (r4 = r3 ,mel-ccl-decode-b-3-table) + (repeat)) + (break)) + ((r6 |= 2) + (break)))) + (r4 = r0 ,mel-ccl-decode-b-0-table) + (r5 = r1 ,mel-ccl-decode-b-1-table) + (r4 |= r5) + (branch + r6 + ;; BBBB + ((r5 = r2 ,mel-ccl-decode-b-2-table) + (r4 |= r5) + (r5 = r3 ,mel-ccl-decode-b-3-table) + (r4 |= r5) + (r4 >8= 0) + (write r7) + (r4 >8= 0) + (write r7) + (write-repeat r4)) + ;; error: BB=B + ((write (r4 & 255)) + (end)) + ;; BBB= + ((r5 = r2 ,mel-ccl-decode-b-2-table) + (r4 |= r5) + (r4 >8= 0) + (write r7) + (write (r4 & 255)) + (end) ; Excessive (end) is workaround for XEmacs 21.0. + ; Without this, "AAA=" is converted to "^@^@^@". + (end)) + ;; BB== + ((write (r4 & 255)) + (end)))) + ((r4 >8= 0) + (write r7) + (r4 >8= 0) + (write r7) + (write-repeat r4)))))) + +(eval-when-compile + +;; Generated CCL program works not properly on 20.2 because CCL_EOF_BLOCK +;; is not executed. +(defun mel-ccl-encode-base64-generic (&optional quantums-per-line output-crlf terminate-with-newline) + `(2 + ((r3 = 0) + (loop + (r2 = 0) + (read-branch + r1 + ,@(mapcar + (lambda (r1) + `((write ,(nth (lsh r1 -2) mel-ccl-64-to-256-table)) + (r0 = ,(logand r1 3)))) + mel-ccl-256-table)) + (r2 = 1) + (read-branch + r1 + ,@(mapcar + (lambda (r1) + `((write r0 ,(vconcat + (mapcar + (lambda (r0) + (nth (logior (lsh r0 4) + (lsh r1 -4)) + mel-ccl-64-to-256-table)) + mel-ccl-4-table))) + (r0 = ,(logand r1 15)))) + mel-ccl-256-table)) + (r2 = 2) + (read-branch + r1 + ,@(mapcar + (lambda (r1) + `((write r0 ,(vconcat + (mapcar + (lambda (r0) + (nth (logior (lsh r0 2) + (lsh r1 -6)) + mel-ccl-64-to-256-table)) + mel-ccl-16-table))))) + mel-ccl-256-table)) + (r1 &= 63) + (write r1 ,(vconcat + (mapcar + (lambda (r1) + (nth r1 mel-ccl-64-to-256-table)) + mel-ccl-64-table))) + (r3 += 1) + ,@(when quantums-per-line + `((if (r3 == ,quantums-per-line) + ((write ,(if output-crlf "\r\n" "\n")) + (r3 = 0))))) + (repeat))) + (branch + r2 + ,(if terminate-with-newline + `(if (r3 > 0) (write ,(if output-crlf "\r\n" "\n"))) + `(r0 = 0)) + ((write r0 ,(vconcat + (mapcar + (lambda (r0) + (nth (lsh r0 4) mel-ccl-64-to-256-table)) + mel-ccl-4-table))) + (write ,(if terminate-with-newline + (if output-crlf "==\r\n" "==\n") + "=="))) + ((write r0 ,(vconcat + (mapcar + (lambda (r0) + (nth (lsh r0 2) mel-ccl-64-to-256-table)) + mel-ccl-16-table))) + (write ,(if terminate-with-newline + (if output-crlf "=\r\n" "=\n") + "=")))) + )) +) + +(define-ccl-program mel-ccl-encode-b + (mel-ccl-encode-base64-generic)) + +;; 19 * 4 = 76 +(define-ccl-program mel-ccl-encode-base64-crlf-crlf + (mel-ccl-encode-base64-generic 19 t)) + +(define-ccl-program mel-ccl-encode-base64-crlf-lf + (mel-ccl-encode-base64-generic 19 nil)) + + +;;; @ coding system +;;; + +(make-ccl-coding-system + 'mel-ccl-b-rev ?B "MIME B-encoding (reversed)" + 'mel-ccl-encode-b 'mel-ccl-decode-b) + +(make-ccl-coding-system + 'mel-ccl-base64-crlf-rev + ?B "MIME Base64-encoding (reversed)" + 'mel-ccl-encode-base64-crlf-crlf + 'mel-ccl-decode-b) + +(make-ccl-coding-system + 'mel-ccl-base64-lf-rev + ?B "MIME Base64-encoding (LF encoding) (reversed)" + 'mel-ccl-encode-base64-crlf-lf + 'mel-ccl-decode-b) + + +;;; @ B +;;; + +(check-broken-facility ccl-execute-eof-block-on-decoding-some) + +(unless-broken ccl-execute-eof-block-on-decoding-some + + (defun base64-ccl-encode-string (string) + "Encode STRING with base64 encoding." + (decode-coding-string string 'mel-ccl-base64-lf-rev)) + + (defun base64-ccl-encode-region (start end) + "Encode region from START to END with base64 encoding." + (interactive "r") + (decode-coding-region start end 'mel-ccl-base64-lf-rev)) + + (defun base64-ccl-insert-encoded-file (filename) + "Encode contents of file FILENAME to base64, and insert the result." + (interactive (list (read-file-name "Insert encoded file: "))) + (let ((coding-system-for-read 'mel-ccl-base64-lf-rev)) + (insert-file-contents filename))) + + (mel-define-method-function (mime-encode-string string (nil "base64")) + 'base64-ccl-encode-string) + (mel-define-method-function (mime-encode-region start end (nil "base64")) + 'base64-ccl-encode-region) + (mel-define-method-function + (mime-insert-encoded-file filename (nil "base64")) + 'base64-ccl-insert-encoded-file) + + (mel-define-method-function (encoded-text-encode-string string (nil "B")) + 'base64-ccl-encode-string) + ) + +(defun base64-ccl-decode-string (string) + "Decode base64 encoded STRING" + (encode-coding-string string 'mel-ccl-b-rev)) + +(defun base64-ccl-decode-region (start end) + "Decode base64 encoded the region from START to END." + (interactive "r") + (encode-coding-region start end 'mel-ccl-b-rev)) + +(defun base64-ccl-write-decoded-region (start end filename) + "Decode the region from START to END 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-b-rev) + jka-compr-compression-info-list) + (write-region start end filename))) + +(mel-define-method-function (mime-decode-string string (nil "base64")) + 'base64-ccl-decode-string) +(mel-define-method-function (mime-decode-region start end (nil "base64")) + 'base64-ccl-decode-region) +(mel-define-method-function + (mime-write-decoded-region start end filename (nil "base64")) + 'base64-ccl-write-decoded-region) + +(mel-define-method encoded-text-decode-string (string (nil "B")) + (if (and (string-match B-encoded-text-regexp string) + (string= string (match-string 0 string))) + (base64-ccl-decode-string string) + (error "Invalid encoded-text %s" string))) + + +;;; @ end +;;; + +(provide 'mel-b-ccl) + +;;; mel-b-ccl.el ends here diff --git a/mel-b-dl.el b/mel-b-dl.el index 3adea3d..411fa74 100644 --- a/mel-b-dl.el +++ b/mel-b-dl.el @@ -24,7 +24,7 @@ ;;; Code: -(require 'emu) +(require 'poe) (require 'mime-def) (eval-and-compile diff --git a/mel-b-el.el b/mel-b-el.el new file mode 100644 index 0000000..7426cc5 --- /dev/null +++ b/mel-b-el.el @@ -0,0 +1,409 @@ +;;; mel-b-el.el: Base64 encoder/decoder for GNU Emacs + +;; Copyright (C) 1992,1995,1996,1997,1998 Free Software Foundation, Inc. + +;; Author: ENAMI Tsugutomo +;; MORIOKA Tomohiko +;; Created: 1995/6/24 +;; Keywords: MIME, Base64 + +;; This file is part of MEL (MIME Encoding Library). + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, 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 +;; 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 +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(require 'poe) +(require 'mime-def) + + +;;; @ variables +;;; + +(defgroup base64 nil + "Base64 encoder/decoder" + :group 'mime) + +(defcustom base64-external-encoder '("mmencode") + "*list of base64 encoder program name and its arguments." + :group 'base64 + :type '(cons (file :tag "Command")(repeat :tag "Arguments" string))) + +(defcustom base64-external-decoder '("mmencode" "-u") + "*list of base64 decoder program name and its arguments." + :group 'base64 + :type '(cons (file :tag "Command")(repeat :tag "Arguments" string))) + +(defcustom base64-external-decoder-option-to-specify-file '("-o") + "*list of options of base64 decoder program to specify file." + :group 'base64 + :type '(repeat :tag "Arguments" string)) + +(defcustom base64-internal-encoding-limit 1000 + "*limit size to use internal base64 encoder. +If size of input to encode is larger than this limit, +external encoder is called." + :group 'base64 + :type '(choice (const :tag "Always use internal encoder" nil) + (integer :tag "Size"))) + +(defcustom base64-internal-decoding-limit (if (and (featurep 'xemacs) + (featurep 'mule)) + 1000 + 7600) + "*limit size to use internal base64 decoder. +If size of input to decode is larger than this limit, +external decoder is called." + :group 'base64 + :type '(choice (const :tag "Always use internal decoder" nil) + (integer :tag "Size"))) + + +;;; @ internal base64 encoder +;;; based on base64 decoder by Enami Tsugutomo + +(eval-and-compile + (defconst base64-characters + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/") + ) + +(defmacro base64-num-to-char (n) + `(aref base64-characters ,n)) + +(defun base64-encode-1 (pack) + (let ((a (car pack)) + (b (nth 1 pack)) + (c (nth 2 pack))) + (concat + (char-to-string (base64-num-to-char (ash a -2))) + (if b + (concat + (char-to-string + (base64-num-to-char (logior (ash (logand a 3) 4) (ash b -4)))) + (if c + (concat + (char-to-string + (base64-num-to-char (logior (ash (logand b 15) 2) (ash c -6)))) + (char-to-string (base64-num-to-char (logand c 63))) + ) + (concat (char-to-string + (base64-num-to-char (ash (logand b 15) 2))) "=") + )) + (concat (char-to-string + (base64-num-to-char (ash (logand a 3) 4))) "==") + )))) + +(defun-maybe base64-encode-string (string) + "Encode STRING to base64, and return the result." + (let ((len (length string)) + (b 0)(e 57) + dest) + (while (< e len) + (setq dest + (concat dest + (mapconcat + (function base64-encode-1) + (pack-sequence (substring string b e) 3) + "") + "\n")) + (setq b e + e (+ e 57) + ) + ) + (let* ((es (mapconcat + (function base64-encode-1) + (pack-sequence (substring string b) 3) + "")) + (m (mod (length es) 4)) + ) + (concat dest es (cond ((= m 3) "=") + ((= m 2) "==") + )) + ))) + +(defun base64-internal-encode-region (beg end) + (save-excursion + (save-restriction + (narrow-to-region beg end) + (let ((str (buffer-substring beg end))) + (delete-region beg end) + (insert (base64-encode-string str)) + ) + (or (bolp) + (insert "\n") + ) + ))) + + +;;; @ internal base64 decoder +;;; + +(defconst base64-numbers + (eval-when-compile + (let ((len (length base64-characters)) + (vec (make-vector 123 nil)) + (i 0)) + (while (< i len) + (aset vec (aref base64-characters i) i) + (setq i (1+ i))) + vec))) + +(defmacro base64-char-to-num (c) + `(aref base64-numbers ,c)) + +(defsubst base64-internal-decode (string buffer) + (let* ((len (length string)) + (i 0) + (j 0) + v1 v2 v3) + (catch 'tag + (while (< i len) + (when (prog1 (setq v1 (base64-char-to-num (aref string i))) + (setq i (1+ i))) + (setq v2 (base64-char-to-num (aref string i)) + i (1+ i) + v3 (base64-char-to-num (aref string i)) + i (1+ i)) + (aset buffer j (logior (lsh v1 2)(lsh v2 -4))) + (setq j (1+ j)) + (if v3 + (let ((v4 (base64-char-to-num (aref string i)))) + (setq i (1+ i)) + (aset buffer j (logior (lsh (logand v2 15) 4)(lsh v3 -2))) + (setq j (1+ j)) + (if v4 + (aset buffer (prog1 j (setq j (1+ j))) + (logior (lsh (logand v3 3) 6) v4)) + (throw 'tag nil) + )) + (throw 'tag nil) + )))) + (substring buffer 0 j) + )) + +(defun base64-internal-decode-string (string) + (base64-internal-decode string (make-string (length string) 0))) + +;; (defsubst base64-decode-string! (string) +;; (setq string (string-as-unibyte string)) +;; (base64-internal-decode string string)) + +(defun base64-internal-decode-region (beg end) + (save-excursion + (let ((str (string-as-unibyte (buffer-substring beg end)))) + (delete-region beg end) + (goto-char beg) + (insert (base64-internal-decode str str))))) + +;; (defun base64-internal-decode-region2 (beg end) +;; (save-excursion +;; (let ((str (buffer-substring beg end))) +;; (delete-region beg end) +;; (goto-char beg) +;; (insert (base64-decode-string! str))))) + +;; (defun base64-internal-decode-region3 (beg end) +;; (save-excursion +;; (let ((str (buffer-substring beg end))) +;; (delete-region beg end) +;; (goto-char beg) +;; (insert (base64-internal-decode-string str))))) + + +;;; @ external encoder/decoder +;;; + +(defun base64-external-encode-region (beg end) + (save-excursion + (save-restriction + (narrow-to-region beg end) + (as-binary-process + (apply (function call-process-region) + beg end (car base64-external-encoder) + t t nil (cdr base64-external-encoder))) + ;; for OS/2 + ;; regularize line break code + (goto-char (point-min)) + (while (re-search-forward "\r$" nil t) + (replace-match "")) + ))) + +(defun base64-external-decode-region (beg end) + (save-excursion + (as-binary-process + (apply (function call-process-region) + beg end (car base64-external-decoder) + t t nil (cdr base64-external-decoder))) + )) + +(defun base64-external-decode-string (string) + (with-temp-buffer + (insert string) + (as-binary-process + (apply (function call-process-region) + (point-min) (point-max) + (car base64-external-decoder) + t t nil (cdr base64-external-decoder))) + (buffer-string))) + + +;;; @ application interfaces +;;; + +(defun-maybe base64-encode-region (start end) + "Encode current region by base64. +START and END are buffer positions. +This function calls internal base64 encoder if size of region is +smaller than `base64-internal-encoding-limit', otherwise it calls +external base64 encoder specified by `base64-external-encoder'. In +this case, you must install the program (maybe mmencode included in +metamail or XEmacs package)." + (interactive "r") + (if (and base64-internal-encoding-limit + (> (- end start) base64-internal-encoding-limit)) + (base64-external-encode-region start end) + (base64-internal-encode-region start end))) + +(defun-maybe base64-decode-region (start end) + "Decode current region by base64. +START and END are buffer positions. +This function calls internal base64 decoder if size of region is +smaller than `base64-internal-decoding-limit', otherwise it calls +external base64 decoder specified by `base64-external-decoder'. In +this case, you must install the program (maybe mmencode included in +metamail or XEmacs package)." + (interactive "r") + (if (and base64-internal-decoding-limit + (> (- end start) base64-internal-decoding-limit)) + (base64-external-decode-region start end) + (base64-internal-decode-region start end))) + +(defun-maybe base64-decode-string (string) + "Decode STRING which is encoded in base64, and return the result. +This function calls internal base64 decoder if size of STRING is +smaller than `base64-internal-decoding-limit', otherwise it calls +external base64 decoder specified by `base64-external-decoder'. In +this case, you must install the program (maybe mmencode included in +metamail or XEmacs package)." + (interactive "r") + (if (and base64-internal-decoding-limit + (> (length string) base64-internal-decoding-limit)) + (base64-external-decode-string string) + (base64-internal-decode-string string))) + + +(mel-define-method-function (mime-encode-string string (nil "base64")) + 'base64-encode-string) +(mel-define-method-function (mime-decode-string string (nil "base64")) + 'base64-decode-string) +(mel-define-method-function (mime-encode-region start end (nil "base64")) + 'base64-encode-region) +(mel-define-method-function (mime-decode-region start end (nil "base64")) + 'base64-decode-region) + +(mel-define-method-function (encoded-text-encode-string string (nil "B")) + 'base64-encode-string) + +(mel-define-method encoded-text-decode-string (string (nil "B")) + (if (and (string-match B-encoded-text-regexp string) + (string= string (match-string 0 string))) + (base64-decode-string string) + (error "Invalid encoded-text %s" string))) + +(defun base64-insert-encoded-file (filename) + "Encode contents of file FILENAME to base64, and insert the result. +It calls external base64 encoder specified by +`base64-external-encoder'. So you must install the program (maybe +mmencode included in metamail or XEmacs package)." + (interactive (list (read-file-name "Insert encoded file: "))) + (if (and base64-internal-encoding-limit + (> (nth 7 (file-attributes filename)) + base64-internal-encoding-limit)) + (apply (function call-process) (car base64-external-encoder) + filename t nil (cdr base64-external-encoder)) + (insert + (base64-encode-string + (with-temp-buffer + (set-buffer-multibyte nil) + (insert-file-contents-as-binary filename) + (buffer-string)))) + (or (bolp) + (insert "\n")) + )) + +(mel-define-method-function (mime-insert-encoded-file filename (nil "base64")) + 'base64-insert-encoded-file) + +(defun base64-write-decoded-region (start end filename) + "Decode and write current region encoded by base64 into FILENAME. +START and END are buffer positions." + (interactive + (list (region-beginning) (region-end) + (read-file-name "Write decoded region to file: "))) + (if (and base64-internal-decoding-limit + (> (- end start) base64-internal-decoding-limit)) + (as-binary-process + (apply (function call-process-region) + start end (car base64-external-decoder) + nil nil nil + (append (cdr base64-external-decoder) + base64-external-decoder-option-to-specify-file + (list filename)))) + (let ((str (buffer-substring start end))) + (with-temp-buffer + (insert (base64-internal-decode-string str)) + (write-region-as-binary (point-min) (point-max) filename) + )))) + +(mel-define-method-function + (mime-write-decoded-region start end filename (nil "base64")) + 'base64-write-decoded-region) + + +;;; @ etc +;;; + +(defun pack-sequence (seq size) + "Split sequence SEQ into SIZE elements packs, +and return list of packs. [mel-b-el; tl-seq function]" + (let ((len (length seq)) (p 0) obj + unit (i 0) + dest) + (while (< p len) + (setq obj (elt seq p)) + (setq unit (cons obj unit)) + (setq i (1+ i)) + (if (= i size) + (progn + (setq dest (cons (reverse unit) dest)) + (setq unit nil) + (setq i 0) + )) + (setq p (1+ p)) + ) + (if unit + (setq dest (cons (reverse unit) dest)) + ) + (reverse dest) + )) + + +;;; @ end +;;; + +(provide 'mel-b-el) + +;;; mel-b-el.el ends here. diff --git a/mel-b.el b/mel-b.el deleted file mode 100644 index ad34a37..0000000 --- a/mel-b.el +++ /dev/null @@ -1,409 +0,0 @@ -;;; mel-b.el: Base64 encoder/decoder for GNU Emacs - -;; Copyright (C) 1992,1995,1996,1997,1998 Free Software Foundation, Inc. - -;; Author: ENAMI Tsugutomo -;; MORIOKA Tomohiko -;; Created: 1995/6/24 -;; Keywords: MIME, Base64 - -;; This file is part of MEL (MIME Encoding Library). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, 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 -;; 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 -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'emu) -(require 'mime-def) - - -;;; @ variables -;;; - -(defgroup base64 nil - "Base64 encoder/decoder" - :group 'mime) - -(defcustom base64-external-encoder '("mmencode") - "*list of base64 encoder program name and its arguments." - :group 'base64 - :type '(cons (file :tag "Command")(repeat :tag "Arguments" string))) - -(defcustom base64-external-decoder '("mmencode" "-u") - "*list of base64 decoder program name and its arguments." - :group 'base64 - :type '(cons (file :tag "Command")(repeat :tag "Arguments" string))) - -(defcustom base64-external-decoder-option-to-specify-file '("-o") - "*list of options of base64 decoder program to specify file." - :group 'base64 - :type '(repeat :tag "Arguments" string)) - -(defcustom base64-internal-encoding-limit 1000 - "*limit size to use internal base64 encoder. -If size of input to encode is larger than this limit, -external encoder is called." - :group 'base64 - :type '(choice (const :tag "Always use internal encoder" nil) - (integer :tag "Size"))) - -(defcustom base64-internal-decoding-limit (if (and (featurep 'xemacs) - (featurep 'mule)) - 1000 - 7600) - "*limit size to use internal base64 decoder. -If size of input to decode is larger than this limit, -external decoder is called." - :group 'base64 - :type '(choice (const :tag "Always use internal decoder" nil) - (integer :tag "Size"))) - - -;;; @ internal base64 encoder -;;; based on base64 decoder by Enami Tsugutomo - -(eval-and-compile - (defconst base64-characters - "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/") - ) - -(defmacro base64-num-to-char (n) - `(aref base64-characters ,n)) - -(defun base64-encode-1 (pack) - (let ((a (car pack)) - (b (nth 1 pack)) - (c (nth 2 pack))) - (concat - (char-to-string (base64-num-to-char (ash a -2))) - (if b - (concat - (char-to-string - (base64-num-to-char (logior (ash (logand a 3) 4) (ash b -4)))) - (if c - (concat - (char-to-string - (base64-num-to-char (logior (ash (logand b 15) 2) (ash c -6)))) - (char-to-string (base64-num-to-char (logand c 63))) - ) - (concat (char-to-string - (base64-num-to-char (ash (logand b 15) 2))) "=") - )) - (concat (char-to-string - (base64-num-to-char (ash (logand a 3) 4))) "==") - )))) - -(defun base64-encode-string (string) - "Encode STRING to base64, and return the result." - (let ((len (length string)) - (b 0)(e 57) - dest) - (while (< e len) - (setq dest - (concat dest - (mapconcat - (function base64-encode-1) - (pack-sequence (substring string b e) 3) - "") - "\n")) - (setq b e - e (+ e 57) - ) - ) - (let* ((es (mapconcat - (function base64-encode-1) - (pack-sequence (substring string b) 3) - "")) - (m (mod (length es) 4)) - ) - (concat dest es (cond ((= m 3) "=") - ((= m 2) "==") - )) - ))) - -(defun base64-internal-encode-region (beg end) - (save-excursion - (save-restriction - (narrow-to-region beg end) - (let ((str (buffer-substring beg end))) - (delete-region beg end) - (insert (base64-encode-string str)) - ) - (or (bolp) - (insert "\n") - ) - ))) - - -;;; @ internal base64 decoder -;;; - -(defconst base64-numbers - (eval-when-compile - (let ((len (length base64-characters)) - (vec (make-vector 123 nil)) - (i 0)) - (while (< i len) - (aset vec (aref base64-characters i) i) - (setq i (1+ i))) - vec))) - -(defmacro base64-char-to-num (c) - `(aref base64-numbers ,c)) - -(defsubst base64-internal-decode (string buffer) - (let* ((len (length string)) - (i 0) - (j 0) - v1 v2 v3) - (catch 'tag - (while (< i len) - (when (prog1 (setq v1 (base64-char-to-num (aref string i))) - (setq i (1+ i))) - (setq v2 (base64-char-to-num (aref string i)) - i (1+ i) - v3 (base64-char-to-num (aref string i)) - i (1+ i)) - (aset buffer j (logior (lsh v1 2)(lsh v2 -4))) - (setq j (1+ j)) - (if v3 - (let ((v4 (base64-char-to-num (aref string i)))) - (setq i (1+ i)) - (aset buffer j (logior (lsh (logand v2 15) 4)(lsh v3 -2))) - (setq j (1+ j)) - (if v4 - (aset buffer (prog1 j (setq j (1+ j))) - (logior (lsh (logand v3 3) 6) v4)) - (throw 'tag nil) - )) - (throw 'tag nil) - )))) - (substring buffer 0 j) - )) - -(defun base64-internal-decode-string (string) - (base64-internal-decode string (make-string (length string) 0))) - -;; (defsubst base64-decode-string! (string) -;; (setq string (string-as-unibyte string)) -;; (base64-internal-decode string string)) - -(defun base64-internal-decode-region (beg end) - (save-excursion - (let ((str (string-as-unibyte (buffer-substring beg end)))) - (delete-region beg end) - (goto-char beg) - (insert (base64-internal-decode str str))))) - -;; (defun base64-internal-decode-region2 (beg end) -;; (save-excursion -;; (let ((str (buffer-substring beg end))) -;; (delete-region beg end) -;; (goto-char beg) -;; (insert (base64-decode-string! str))))) - -;; (defun base64-internal-decode-region3 (beg end) -;; (save-excursion -;; (let ((str (buffer-substring beg end))) -;; (delete-region beg end) -;; (goto-char beg) -;; (insert (base64-internal-decode-string str))))) - - -;;; @ external encoder/decoder -;;; - -(defun base64-external-encode-region (beg end) - (save-excursion - (save-restriction - (narrow-to-region beg end) - (as-binary-process - (apply (function call-process-region) - beg end (car base64-external-encoder) - t t nil (cdr base64-external-encoder))) - ;; for OS/2 - ;; regularize line break code - (goto-char (point-min)) - (while (re-search-forward "\r$" nil t) - (replace-match "")) - ))) - -(defun base64-external-decode-region (beg end) - (save-excursion - (as-binary-process - (apply (function call-process-region) - beg end (car base64-external-decoder) - t t nil (cdr base64-external-decoder))) - )) - -(defun base64-external-decode-string (string) - (with-temp-buffer - (insert string) - (as-binary-process - (apply (function call-process-region) - (point-min) (point-max) - (car base64-external-decoder) - t t nil (cdr base64-external-decoder))) - (buffer-string))) - - -;;; @ application interfaces -;;; - -(defun base64-encode-region (start end) - "Encode current region by base64. -START and END are buffer positions. -This function calls internal base64 encoder if size of region is -smaller than `base64-internal-encoding-limit', otherwise it calls -external base64 encoder specified by `base64-external-encoder'. In -this case, you must install the program (maybe mmencode included in -metamail or XEmacs package)." - (interactive "r") - (if (and base64-internal-encoding-limit - (> (- end start) base64-internal-encoding-limit)) - (base64-external-encode-region start end) - (base64-internal-encode-region start end))) - -(defun base64-decode-region (start end) - "Decode current region by base64. -START and END are buffer positions. -This function calls internal base64 decoder if size of region is -smaller than `base64-internal-decoding-limit', otherwise it calls -external base64 decoder specified by `base64-external-decoder'. In -this case, you must install the program (maybe mmencode included in -metamail or XEmacs package)." - (interactive "r") - (if (and base64-internal-decoding-limit - (> (- end start) base64-internal-decoding-limit)) - (base64-external-decode-region start end) - (base64-internal-decode-region start end))) - -(defun base64-decode-string (string) - "Decode STRING which is encoded in base64, and return the result. -This function calls internal base64 decoder if size of STRING is -smaller than `base64-internal-decoding-limit', otherwise it calls -external base64 decoder specified by `base64-external-decoder'. In -this case, you must install the program (maybe mmencode included in -metamail or XEmacs package)." - (interactive "r") - (if (and base64-internal-decoding-limit - (> (length string) base64-internal-decoding-limit)) - (base64-external-decode-string string) - (base64-internal-decode-string string))) - - -(mel-define-method-function (mime-encode-string string (nil "base64")) - 'base64-encode-string) -(mel-define-method-function (mime-decode-string string (nil "base64")) - 'base64-decode-string) -(mel-define-method-function (mime-encode-region start end (nil "base64")) - 'base64-encode-region) -(mel-define-method-function (mime-decode-region start end (nil "base64")) - 'base64-decode-region) - -(mel-define-method-function (encoded-text-encode-string string (nil "B")) - 'base64-encode-string) - -(mel-define-method encoded-text-decode-string (string (nil "B")) - (if (and (string-match B-encoded-text-regexp string) - (string= string (match-string 0 string))) - (base64-decode-string string) - (error "Invalid encoded-text %s" string))) - -(defun base64-insert-encoded-file (filename) - "Encode contents of file FILENAME to base64, and insert the result. -It calls external base64 encoder specified by -`base64-external-encoder'. So you must install the program (maybe -mmencode included in metamail or XEmacs package)." - (interactive (list (read-file-name "Insert encoded file: "))) - (if (and base64-internal-encoding-limit - (> (nth 7 (file-attributes filename)) - base64-internal-encoding-limit)) - (apply (function call-process) (car base64-external-encoder) - filename t nil (cdr base64-external-encoder)) - (insert - (base64-encode-string - (with-temp-buffer - (set-buffer-multibyte nil) - (insert-file-contents-as-binary filename) - (buffer-string)))) - (or (bolp) - (insert "\n")) - )) - -(mel-define-method-function (mime-insert-encoded-file filename (nil "base64")) - 'base64-insert-encoded-file) - -(defun base64-write-decoded-region (start end filename) - "Decode and write current region encoded by base64 into FILENAME. -START and END are buffer positions." - (interactive - (list (region-beginning) (region-end) - (read-file-name "Write decoded region to file: "))) - (if (and base64-internal-decoding-limit - (> (- end start) base64-internal-decoding-limit)) - (as-binary-process - (apply (function call-process-region) - start end (car base64-external-decoder) - nil nil nil - (append (cdr base64-external-decoder) - base64-external-decoder-option-to-specify-file - (list filename)))) - (let ((str (buffer-substring start end))) - (with-temp-buffer - (insert (base64-internal-decode-string str)) - (write-region-as-binary (point-min) (point-max) filename) - )))) - -(mel-define-method-function - (mime-write-decoded-region start end filename (nil "base64")) - 'base64-write-decoded-region) - - -;;; @ etc -;;; - -(defun pack-sequence (seq size) - "Split sequence SEQ into SIZE elements packs, -and return list of packs. [mel-b; tl-seq function]" - (let ((len (length seq)) (p 0) obj - unit (i 0) - dest) - (while (< p len) - (setq obj (elt seq p)) - (setq unit (cons obj unit)) - (setq i (1+ i)) - (if (= i size) - (progn - (setq dest (cons (reverse unit) dest)) - (setq unit nil) - (setq i 0) - )) - (setq p (1+ p)) - ) - (if unit - (setq dest (cons (reverse unit) dest)) - ) - (reverse dest) - )) - - -;;; @ end -;;; - -(provide 'mel-b) - -;;; mel-b.el ends here. diff --git a/mel-ccl.el b/mel-ccl.el deleted file mode 100644 index 12b18e1..0000000 --- a/mel-ccl.el +++ /dev/null @@ -1,1352 +0,0 @@ -;;; mel-ccl.el: CCL based encoder/decoder of Base64, Quoted-Printable -;;; and Q-encoding - -;; Copyright (C) 1998 Tanaka Akira - -;; Author: Tanaka Akira -;; Created: 1998/9/17 -;; Keywords: MIME, Base64, Quoted-Printable, Q-encoding - -;; This file is part of FLIM (Faithful Library about Internet Message). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, 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 -;; 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 -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'ccl) -(require 'pccl) -(require 'mime-def) - - -;;; @ constants -;;; - -(eval-when-compile - -(defconst mel-ccl-4-table - '( 0 1 2 3)) - -(defconst mel-ccl-16-table - '( 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)) - -(defconst mel-ccl-28-table - '( 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 - 16 17 18 19 20 21 22 23 24 25 26 27)) - -(defconst mel-ccl-64-table - '( 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 - 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 - 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 - 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63)) - -(defconst mel-ccl-256-table - '( 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 - 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 - 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 - 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 - 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 - 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 - 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 - 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 - 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 - 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 - 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 - 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 - 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 - 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 - 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 - 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255)) - -(defconst mel-ccl-256-to-16-table - '(nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil - nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil - nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil - 0 1 2 3 4 5 6 7 8 9 nil nil nil nil nil nil - nil 10 11 12 13 14 15 nil nil nil nil nil nil nil nil nil - nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil - nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil - nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil - nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil - nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil - nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil - nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil - nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil - nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil - nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil - nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) - -(defconst mel-ccl-16-to-256-table - (mapcar 'char-int "0123456789ABCDEF")) - -(defconst mel-ccl-high-table - (vconcat - (mapcar - (lambda (v) (nth (lsh v -4) mel-ccl-16-to-256-table)) - mel-ccl-256-table))) - -(defconst mel-ccl-low-table - (vconcat - (mapcar - (lambda (v) (nth (logand v 15) mel-ccl-16-to-256-table)) - mel-ccl-256-table))) - -(defconst mel-ccl-u-raw - (mapcar - 'char-int - "0123456789\ -ABCDEFGHIJKLMNOPQRSTUVWXYZ\ -abcdefghijklmnopqrstuvwxyz\ -!@#$%&'()*+,-./:;<>@[\\]^`{|}~")) - -(defconst mel-ccl-c-raw - (mapcar - 'char-int - "0123456789\ -ABCDEFGHIJKLMNOPQRSTUVWXYZ\ -abcdefghijklmnopqrstuvwxyz\ -!@#$%&'*+,-./:;<>@[]^`{|}~")) - -(defconst mel-ccl-p-raw - (mapcar - 'char-int - "0123456789\ -ABCDEFGHIJKLMNOPQRSTUVWXYZ\ -abcdefghijklmnopqrstuvwxyz\ -!*+-/")) - -(defconst mel-ccl-256-to-64-table - '(nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil - nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil - nil nil nil nil nil nil nil nil nil nil nil 62 nil nil nil 63 - 52 53 54 55 56 57 58 59 60 61 nil nil nil t nil nil - nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 - 15 16 17 18 19 20 21 22 23 24 25 nil nil nil nil nil - nil 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 - 41 42 43 44 45 46 47 48 49 50 51 nil nil nil nil nil - nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil - nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil - nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil - nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil - nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil - nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil - nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil - nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) - -(defconst mel-ccl-64-to-256-table - (mapcar - 'char-int - "ABCDEFGHIJKLMNOPQRSTUVWXYZ\ -abcdefghijklmnopqrstuvwxyz\ -0123456789\ -+/")) - -(defconst mel-ccl-qp-table - [enc enc enc enc enc enc enc enc enc wsp lf enc enc cr enc enc - enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc - wsp raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw - raw raw raw raw raw raw raw raw raw raw raw raw raw enc raw raw - raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw - raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw - raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw - raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw enc - enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc - enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc - enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc - enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc - enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc - enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc - enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc - enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc]) - -) - - -;;; @ CCL programs -;;; - -;;; 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)))))) - -(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)))) - -;; 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)))))) - -) - -(define-ccl-program mel-ccl-encode-uq - (mel-ccl-encode-q-generic mel-ccl-u-raw)) -(define-ccl-program mel-ccl-encode-cq - (mel-ccl-encode-q-generic mel-ccl-c-raw)) -(define-ccl-program mel-ccl-encode-pq - (mel-ccl-encode-q-generic mel-ccl-p-raw)) - -(define-ccl-program mel-ccl-count-uq - (mel-ccl-count-q-length mel-ccl-u-raw)) -(define-ccl-program mel-ccl-count-cq - (mel-ccl-count-q-length mel-ccl-c-raw)) -(define-ccl-program mel-ccl-count-pq - (mel-ccl-count-q-length mel-ccl-p-raw)) - -;;; B/Base64 - -(eval-when-compile - -(defun mel-ccl-decode-b-bit-ex (v) - (logior - (lsh (logand v (lsh 255 16)) -16) - (logand v (lsh 255 8)) - (lsh (logand v 255) 16))) - -(defconst mel-ccl-decode-b-0-table - (vconcat - (mapcar - (lambda (v) - (if (integerp v) - (mel-ccl-decode-b-bit-ex (lsh v 18)) - (lsh 1 24))) - mel-ccl-256-to-64-table))) - -(defconst mel-ccl-decode-b-1-table - (vconcat - (mapcar - (lambda (v) - (if (integerp v) - (mel-ccl-decode-b-bit-ex (lsh v 12)) - (lsh 1 25))) - mel-ccl-256-to-64-table))) - -(defconst mel-ccl-decode-b-2-table - (vconcat - (mapcar - (lambda (v) - (if (integerp v) - (mel-ccl-decode-b-bit-ex (lsh v 6)) - (lsh 1 26))) - mel-ccl-256-to-64-table))) - -(defconst mel-ccl-decode-b-3-table - (vconcat - (mapcar - (lambda (v) - (if (integerp v) - (mel-ccl-decode-b-bit-ex v) - (lsh 1 27))) - mel-ccl-256-to-64-table))) - -) - -(define-ccl-program mel-ccl-decode-b - `(1 - (loop - (read r0 r1 r2 r3) - (r4 = r0 ,mel-ccl-decode-b-0-table) - (r5 = r1 ,mel-ccl-decode-b-1-table) - (r4 |= r5) - (r5 = r2 ,mel-ccl-decode-b-2-table) - (r4 |= r5) - (r5 = r3 ,mel-ccl-decode-b-3-table) - (r4 |= r5) - (if (r4 & ,(lognot (1- (lsh 1 24)))) - ((loop - (if (r4 & ,(lsh 1 24)) - ((r0 = r1) (r1 = r2) (r2 = r3) (read r3) - (r4 >>= 1) (r4 &= ,(logior (lsh 7 24))) - (r5 = r3 ,mel-ccl-decode-b-3-table) - (r4 |= r5) - (repeat)) - (break))) - (loop - (if (r4 & ,(lsh 1 25)) - ((r1 = r2) (r2 = r3) (read r3) - (r4 >>= 1) (r4 &= ,(logior (lsh 7 24))) - (r5 = r3 ,mel-ccl-decode-b-3-table) - (r4 |= r5) - (repeat)) - (break))) - (loop - (if (r2 != ?=) - (if (r4 & ,(lsh 1 26)) - ((r2 = r3) (read r3) - (r4 >>= 1) (r4 &= ,(logior (lsh 7 24))) - (r5 = r3 ,mel-ccl-decode-b-3-table) - (r4 |= r5) - (repeat)) - ((r6 = 0) - (break))) - ((r6 = 1) - (break)))) - (loop - (if (r3 != ?=) - (if (r4 & ,(lsh 1 27)) - ((read r3) - (r4 = r3 ,mel-ccl-decode-b-3-table) - (repeat)) - (break)) - ((r6 |= 2) - (break)))) - (r4 = r0 ,mel-ccl-decode-b-0-table) - (r5 = r1 ,mel-ccl-decode-b-1-table) - (r4 |= r5) - (branch - r6 - ;; BBBB - ((r5 = r2 ,mel-ccl-decode-b-2-table) - (r4 |= r5) - (r5 = r3 ,mel-ccl-decode-b-3-table) - (r4 |= r5) - (r4 >8= 0) - (write r7) - (r4 >8= 0) - (write r7) - (write-repeat r4)) - ;; error: BB=B - ((write (r4 & 255)) - (end)) - ;; BBB= - ((r5 = r2 ,mel-ccl-decode-b-2-table) - (r4 |= r5) - (r4 >8= 0) - (write r7) - (write (r4 & 255)) - (end) ; Excessive (end) is workaround for XEmacs 21.0. - ; Without this, "AAA=" is converted to "^@^@^@". - (end)) - ;; BB== - ((write (r4 & 255)) - (end)))) - ((r4 >8= 0) - (write r7) - (r4 >8= 0) - (write r7) - (write-repeat r4)))))) - -(eval-when-compile - -;; Generated CCL program works not properly on 20.2 because CCL_EOF_BLOCK -;; is not executed. -(defun mel-ccl-encode-base64-generic (&optional quantums-per-line output-crlf terminate-with-newline) - `(2 - ((r3 = 0) - (loop - (r2 = 0) - (read-branch - r1 - ,@(mapcar - (lambda (r1) - `((write ,(nth (lsh r1 -2) mel-ccl-64-to-256-table)) - (r0 = ,(logand r1 3)))) - mel-ccl-256-table)) - (r2 = 1) - (read-branch - r1 - ,@(mapcar - (lambda (r1) - `((write r0 ,(vconcat - (mapcar - (lambda (r0) - (nth (logior (lsh r0 4) - (lsh r1 -4)) - mel-ccl-64-to-256-table)) - mel-ccl-4-table))) - (r0 = ,(logand r1 15)))) - mel-ccl-256-table)) - (r2 = 2) - (read-branch - r1 - ,@(mapcar - (lambda (r1) - `((write r0 ,(vconcat - (mapcar - (lambda (r0) - (nth (logior (lsh r0 2) - (lsh r1 -6)) - mel-ccl-64-to-256-table)) - mel-ccl-16-table))))) - mel-ccl-256-table)) - (r1 &= 63) - (write r1 ,(vconcat - (mapcar - (lambda (r1) - (nth r1 mel-ccl-64-to-256-table)) - mel-ccl-64-table))) - (r3 += 1) - ,@(when quantums-per-line - `((if (r3 == ,quantums-per-line) - ((write ,(if output-crlf "\r\n" "\n")) - (r3 = 0))))) - (repeat))) - (branch - r2 - ,(if terminate-with-newline - `(if (r3 > 0) (write ,(if output-crlf "\r\n" "\n"))) - `(r0 = 0)) - ((write r0 ,(vconcat - (mapcar - (lambda (r0) - (nth (lsh r0 4) mel-ccl-64-to-256-table)) - mel-ccl-4-table))) - (write ,(if terminate-with-newline - (if output-crlf "==\r\n" "==\n") - "=="))) - ((write r0 ,(vconcat - (mapcar - (lambda (r0) - (nth (lsh r0 2) mel-ccl-64-to-256-table)) - mel-ccl-16-table))) - (write ,(if terminate-with-newline - (if output-crlf "=\r\n" "=\n") - "=")))) - )) -) - -(define-ccl-program mel-ccl-encode-b - (mel-ccl-encode-base64-generic)) - -;; 19 * 4 = 76 -(define-ccl-program mel-ccl-encode-base64-crlf-crlf - (mel-ccl-encode-base64-generic 19 t)) - -(define-ccl-program mel-ccl-encode-base64-crlf-lf - (mel-ccl-encode-base64-generic 19 nil)) - -;; Quoted-Printable - -(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) - (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)))) - -;; 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) - (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) - )) - )) - -(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)) - ;; 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))) - ;; 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))) - (repeat) - )))) - -) - -(define-ccl-program mel-ccl-encode-quoted-printable-crlf-crlf - (mel-ccl-encode-quoted-printable-generic t t)) - -(define-ccl-program mel-ccl-encode-quoted-printable-crlf-lf - (mel-ccl-encode-quoted-printable-generic t nil)) - -(define-ccl-program mel-ccl-encode-quoted-printable-lf-crlf - (mel-ccl-encode-quoted-printable-generic nil t)) - -(define-ccl-program mel-ccl-encode-quoted-printable-lf-lf - (mel-ccl-encode-quoted-printable-generic nil nil)) - -(define-ccl-program mel-ccl-decode-quoted-printable-crlf-crlf - (mel-ccl-decode-quoted-printable-generic t t)) - -(define-ccl-program mel-ccl-decode-quoted-printable-crlf-lf - (mel-ccl-decode-quoted-printable-generic t nil)) - -(define-ccl-program mel-ccl-decode-quoted-printable-lf-crlf - (mel-ccl-decode-quoted-printable-generic nil t)) - -(define-ccl-program mel-ccl-decode-quoted-printable-lf-lf - (mel-ccl-decode-quoted-printable-generic nil nil)) - - -;;; @ coding system -;;; - -(make-ccl-coding-system - 'mel-ccl-uq-rev ?Q "MIME Q-encoding in unstructured field (reversed)" - 'mel-ccl-encode-uq 'mel-ccl-decode-q) - -(make-ccl-coding-system - 'mel-ccl-cq-rev ?Q "MIME Q-encoding in comment (reversed)" - 'mel-ccl-encode-cq 'mel-ccl-decode-q) - -(make-ccl-coding-system - 'mel-ccl-pq-rev ?Q "MIME Q-encoding in phrase (reversed)" - 'mel-ccl-encode-pq 'mel-ccl-decode-q) - -(make-ccl-coding-system - 'mel-ccl-b-rev ?B "MIME B-encoding (reversed)" - 'mel-ccl-encode-b 'mel-ccl-decode-b) - -(make-ccl-coding-system - 'mel-ccl-quoted-printable-crlf-crlf-rev - ?Q "MIME Quoted-Printable-encoding (reversed)" - 'mel-ccl-encode-quoted-printable-crlf-crlf - 'mel-ccl-decode-quoted-printable-crlf-crlf) - -(make-ccl-coding-system - 'mel-ccl-quoted-printable-lf-crlf-rev - ?Q "MIME Quoted-Printable-encoding (LF encoding) (reversed)" - 'mel-ccl-encode-quoted-printable-crlf-lf - 'mel-ccl-decode-quoted-printable-lf-crlf) - -(make-ccl-coding-system - 'mel-ccl-quoted-printable-crlf-lf-rev - ?Q "MIME Quoted-Printable-encoding (LF internal) (reversed)" - 'mel-ccl-encode-quoted-printable-lf-crlf - 'mel-ccl-decode-quoted-printable-crlf-lf) - -(make-ccl-coding-system - 'mel-ccl-quoted-printable-lf-lf-rev - ?Q "MIME Quoted-Printable-encoding (LF encoding) (LF internal) (reversed)" - 'mel-ccl-encode-quoted-printable-lf-lf - 'mel-ccl-decode-quoted-printable-lf-lf) - -(make-ccl-coding-system - 'mel-ccl-base64-crlf-rev - ?B "MIME Base64-encoding (reversed)" - 'mel-ccl-encode-base64-crlf-crlf - 'mel-ccl-decode-b) - -(make-ccl-coding-system - 'mel-ccl-base64-lf-rev - ?B "MIME Base64-encoding (LF encoding) (reversed)" - 'mel-ccl-encode-base64-crlf-lf - 'mel-ccl-decode-b) - - -;;; @ B -;;; - -(unless-broken ccl-execute-eof-block-on-decoding-some - - (defun base64-ccl-encode-string (string) - "Encode STRING with base64 encoding." - (decode-coding-string string 'mel-ccl-base64-lf-rev)) - - (defun base64-ccl-encode-region (start end) - "Encode region from START to END with base64 encoding." - (interactive "r") - (decode-coding-region start end 'mel-ccl-base64-lf-rev)) - - (defun base64-ccl-insert-encoded-file (filename) - "Encode contents of file FILENAME to base64, and insert the result." - (interactive (list (read-file-name "Insert encoded file: "))) - (let ((coding-system-for-read 'mel-ccl-base64-lf-rev)) - (insert-file-contents filename))) - - (mel-define-method-function (mime-encode-string string (nil "base64")) - 'base64-ccl-encode-string) - (mel-define-method-function (mime-encode-region start end (nil "base64")) - 'base64-ccl-encode-region) - (mel-define-method-function - (mime-insert-encoded-file filename (nil "base64")) - 'base64-ccl-insert-encoded-file) - - (mel-define-method-function (encoded-text-encode-string string (nil "B")) - 'base64-ccl-encode-string) - ) - -(defun base64-ccl-decode-string (string) - "Decode base64 encoded STRING" - (encode-coding-string string 'mel-ccl-b-rev)) - -(defun base64-ccl-decode-region (start end) - "Decode base64 encoded the region from START to END." - (interactive "r") - (encode-coding-region start end 'mel-ccl-b-rev)) - -(defun base64-ccl-write-decoded-region (start end filename) - "Decode the region from START to END 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-b-rev) - jka-compr-compression-info-list) - (write-region start end filename))) - -(mel-define-method-function (mime-decode-string string (nil "base64")) - 'base64-ccl-decode-string) -(mel-define-method-function (mime-decode-region start end (nil "base64")) - 'base64-ccl-decode-region) -(mel-define-method-function - (mime-write-decoded-region start end filename (nil "base64")) - 'base64-ccl-write-decoded-region) - -(mel-define-method encoded-text-decode-string (string (nil "B")) - (if (and (string-match B-encoded-text-regexp string) - (string= string (match-string 0 string))) - (base64-ccl-decode-string string) - (error "Invalid encoded-text %s" string))) - - -;;; @ quoted-printable -;;; - -(unless-broken ccl-execute-eof-block-on-decoding-some - - (defun quoted-printable-ccl-encode-string (string) - "Encode STRING with quoted-printable encoding." - (decode-coding-string - string - 'mel-ccl-quoted-printable-lf-lf-rev)) - - (defun quoted-printable-ccl-encode-region (start end) - "Encode the region from START to END with quoted-printable encoding." - (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))) - - (mel-define-method-function - (mime-encode-string string (nil "quoted-printable")) - 'quoted-printable-ccl-encode-string) - (mel-define-method-function - (mime-encode-region start end (nil "quoted-printable")) - 'quoted-printable-ccl-encode-region) - (mel-define-method-function - (mime-insert-encoded-file filename (nil "quoted-printable")) - 'quoted-printable-ccl-insert-encoded-file) - ) - -(defun quoted-printable-ccl-decode-string (string) - "Decode quoted-printable encoded STRING." - (encode-coding-string - string - 'mel-ccl-quoted-printable-lf-lf-rev)) - -(defun quoted-printable-ccl-decode-region (start end) - "Decode the region from START to END with quoted-printable -encoding." - (interactive "r") - (encode-coding-region start end 'mel-ccl-quoted-printable-lf-lf-rev)) - -(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))) - -(mel-define-method-function - (mime-decode-string string (nil "quoted-printable")) - 'quoted-printable-ccl-decode-string) -(mel-define-method-function - (mime-decode-region start end (nil "quoted-printable")) - 'quoted-printable-ccl-decode-region) -(mel-define-method-function - (mime-write-decoded-region start end filename (nil "quoted-printable")) - 'quoted-printable-ccl-write-decoded-region) - - -;;; @ Q -;;; - -(defun q-encoding-ccl-encode-string (string &optional mode) - "Encode STRING to Q-encoding of encoded-word, and return the result. -MODE allows `text', `comment', `phrase' or nil. Default value is -`phrase'." - (decode-coding-string - string - (cond - ((eq mode 'text) 'mel-ccl-uq-rev) - ((eq mode 'comment) 'mel-ccl-cq-rev) - (t 'mel-ccl-pq-rev)))) - -(defun q-encoding-ccl-decode-string (string) - "Decode Q encoded STRING and return the result." - (encode-coding-string - string - 'mel-ccl-uq-rev)) - -(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) - (ccl-execute-on-string - (cond - ((eq mode 'text) 'mel-ccl-count-uq) - ((eq mode 'comment) 'mel-ccl-count-cq) - (t 'mel-ccl-count-pq)) - status - string) - (aref status 0))) - ) - -(mel-define-method-function (encoded-text-encode-string string (nil "Q")) - '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))) - (q-encoding-ccl-decode-string string) - (error "Invalid encoded-text %s" string))) - - -;;; @ end -;;; - -(provide 'mel-ccl) - -;;; mel-ccl.el ends here diff --git a/mel-q-ccl.el b/mel-q-ccl.el new file mode 100644 index 0000000..17b58be --- /dev/null +++ b/mel-q-ccl.el @@ -0,0 +1,1016 @@ +;;; mel-ccl.el: CCL based encoder/decoder of Quoted-Printable +;;; and Q-encoding + +;; Copyright (C) 1998 Tanaka Akira + +;; Author: Tanaka Akira +;; Created: 1998/9/17 +;; Keywords: MIME, Quoted-Printable, Q-encoding + +;; This file is part of FLIM (Faithful Library about Internet Message). + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, 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 +;; 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 +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(require 'ccl) +(require 'pccl) +(require 'mime-def) + + +;;; @ constants +;;; + +(eval-when-compile + +(defconst mel-ccl-16-table + '( 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)) + +(defconst mel-ccl-28-table + '( 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 + 16 17 18 19 20 21 22 23 24 25 26 27)) + +(defconst mel-ccl-256-table + '( 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 + 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 + 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 + 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 + 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 + 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 + 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 + 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 + 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 + 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 + 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 + 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 + 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 + 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 + 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 + 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255)) + +(defconst mel-ccl-256-to-16-table + '(nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil + nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil + nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil + 0 1 2 3 4 5 6 7 8 9 nil nil nil nil nil nil + nil 10 11 12 13 14 15 nil nil nil nil nil nil nil nil nil + nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil + nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil + nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil + nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil + nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil + nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil + nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil + nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil + nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil + nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil + nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) + +(defconst mel-ccl-16-to-256-table + (mapcar 'char-int "0123456789ABCDEF")) + +(defconst mel-ccl-high-table + (vconcat + (mapcar + (lambda (v) (nth (lsh v -4) mel-ccl-16-to-256-table)) + mel-ccl-256-table))) + +(defconst mel-ccl-low-table + (vconcat + (mapcar + (lambda (v) (nth (logand v 15) mel-ccl-16-to-256-table)) + mel-ccl-256-table))) + +(defconst mel-ccl-u-raw + (mapcar + 'char-int + "0123456789\ +ABCDEFGHIJKLMNOPQRSTUVWXYZ\ +abcdefghijklmnopqrstuvwxyz\ +!@#$%&'()*+,-./:;<>@[\\]^`{|}~")) + +(defconst mel-ccl-c-raw + (mapcar + 'char-int + "0123456789\ +ABCDEFGHIJKLMNOPQRSTUVWXYZ\ +abcdefghijklmnopqrstuvwxyz\ +!@#$%&'*+,-./:;<>@[]^`{|}~")) + +(defconst mel-ccl-p-raw + (mapcar + 'char-int + "0123456789\ +ABCDEFGHIJKLMNOPQRSTUVWXYZ\ +abcdefghijklmnopqrstuvwxyz\ +!*+-/")) + +(defconst mel-ccl-qp-table + [enc enc enc enc enc enc enc enc enc wsp lf enc enc cr enc enc + enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc + wsp raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw + raw raw raw raw raw raw raw raw raw raw raw raw raw enc raw raw + raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw + raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw + raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw + raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw enc + enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc + enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc + enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc + enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc + enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc + enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc + enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc + enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc]) + +) + + +;;; @ CCL programs +;;; + +;;; 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)))))) + +(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)))) + +;; 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)))))) + +) + +(define-ccl-program mel-ccl-encode-uq + (mel-ccl-encode-q-generic mel-ccl-u-raw)) +(define-ccl-program mel-ccl-encode-cq + (mel-ccl-encode-q-generic mel-ccl-c-raw)) +(define-ccl-program mel-ccl-encode-pq + (mel-ccl-encode-q-generic mel-ccl-p-raw)) + +(define-ccl-program mel-ccl-count-uq + (mel-ccl-count-q-length mel-ccl-u-raw)) +(define-ccl-program mel-ccl-count-cq + (mel-ccl-count-q-length mel-ccl-c-raw)) +(define-ccl-program mel-ccl-count-pq + (mel-ccl-count-q-length mel-ccl-p-raw)) + +;; Quoted-Printable + +(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) + (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)))) + +;; 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) + (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) + )) + )) + +(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)) + ;; 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))) + ;; 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))) + (repeat) + )))) + +) + +(define-ccl-program mel-ccl-encode-quoted-printable-crlf-crlf + (mel-ccl-encode-quoted-printable-generic t t)) + +(define-ccl-program mel-ccl-encode-quoted-printable-crlf-lf + (mel-ccl-encode-quoted-printable-generic t nil)) + +(define-ccl-program mel-ccl-encode-quoted-printable-lf-crlf + (mel-ccl-encode-quoted-printable-generic nil t)) + +(define-ccl-program mel-ccl-encode-quoted-printable-lf-lf + (mel-ccl-encode-quoted-printable-generic nil nil)) + +(define-ccl-program mel-ccl-decode-quoted-printable-crlf-crlf + (mel-ccl-decode-quoted-printable-generic t t)) + +(define-ccl-program mel-ccl-decode-quoted-printable-crlf-lf + (mel-ccl-decode-quoted-printable-generic t nil)) + +(define-ccl-program mel-ccl-decode-quoted-printable-lf-crlf + (mel-ccl-decode-quoted-printable-generic nil t)) + +(define-ccl-program mel-ccl-decode-quoted-printable-lf-lf + (mel-ccl-decode-quoted-printable-generic nil nil)) + + +;;; @ coding system +;;; + +(make-ccl-coding-system + 'mel-ccl-uq-rev ?Q "MIME Q-encoding in unstructured field (reversed)" + 'mel-ccl-encode-uq 'mel-ccl-decode-q) + +(make-ccl-coding-system + 'mel-ccl-cq-rev ?Q "MIME Q-encoding in comment (reversed)" + 'mel-ccl-encode-cq 'mel-ccl-decode-q) + +(make-ccl-coding-system + 'mel-ccl-pq-rev ?Q "MIME Q-encoding in phrase (reversed)" + 'mel-ccl-encode-pq 'mel-ccl-decode-q) + +(make-ccl-coding-system + 'mel-ccl-quoted-printable-crlf-crlf-rev + ?Q "MIME Quoted-Printable-encoding (reversed)" + 'mel-ccl-encode-quoted-printable-crlf-crlf + 'mel-ccl-decode-quoted-printable-crlf-crlf) + +(make-ccl-coding-system + 'mel-ccl-quoted-printable-lf-crlf-rev + ?Q "MIME Quoted-Printable-encoding (LF encoding) (reversed)" + 'mel-ccl-encode-quoted-printable-crlf-lf + 'mel-ccl-decode-quoted-printable-lf-crlf) + +(make-ccl-coding-system + 'mel-ccl-quoted-printable-crlf-lf-rev + ?Q "MIME Quoted-Printable-encoding (LF internal) (reversed)" + 'mel-ccl-encode-quoted-printable-lf-crlf + 'mel-ccl-decode-quoted-printable-crlf-lf) + +(make-ccl-coding-system + 'mel-ccl-quoted-printable-lf-lf-rev + ?Q "MIME Quoted-Printable-encoding (LF encoding) (LF internal) (reversed)" + 'mel-ccl-encode-quoted-printable-lf-lf + 'mel-ccl-decode-quoted-printable-lf-lf) + + +;;; @ quoted-printable +;;; + +(check-broken-facility ccl-execute-eof-block-on-decoding-some) + +(unless-broken ccl-execute-eof-block-on-decoding-some + + (defun quoted-printable-ccl-encode-string (string) + "Encode STRING with quoted-printable encoding." + (decode-coding-string + string + 'mel-ccl-quoted-printable-lf-lf-rev)) + + (defun quoted-printable-ccl-encode-region (start end) + "Encode the region from START to END with quoted-printable encoding." + (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))) + + (mel-define-method-function + (mime-encode-string string (nil "quoted-printable")) + 'quoted-printable-ccl-encode-string) + (mel-define-method-function + (mime-encode-region start end (nil "quoted-printable")) + 'quoted-printable-ccl-encode-region) + (mel-define-method-function + (mime-insert-encoded-file filename (nil "quoted-printable")) + 'quoted-printable-ccl-insert-encoded-file) + ) + +(defun quoted-printable-ccl-decode-string (string) + "Decode quoted-printable encoded STRING." + (encode-coding-string + string + 'mel-ccl-quoted-printable-lf-lf-rev)) + +(defun quoted-printable-ccl-decode-region (start end) + "Decode the region from START to END with quoted-printable +encoding." + (interactive "r") + (encode-coding-region start end 'mel-ccl-quoted-printable-lf-lf-rev)) + +(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))) + +(mel-define-method-function + (mime-decode-string string (nil "quoted-printable")) + 'quoted-printable-ccl-decode-string) +(mel-define-method-function + (mime-decode-region start end (nil "quoted-printable")) + 'quoted-printable-ccl-decode-region) +(mel-define-method-function + (mime-write-decoded-region start end filename (nil "quoted-printable")) + 'quoted-printable-ccl-write-decoded-region) + + +;;; @ Q +;;; + +(defun q-encoding-ccl-encode-string (string &optional mode) + "Encode STRING to Q-encoding of encoded-word, and return the result. +MODE allows `text', `comment', `phrase' or nil. Default value is +`phrase'." + (decode-coding-string + string + (cond + ((eq mode 'text) 'mel-ccl-uq-rev) + ((eq mode 'comment) 'mel-ccl-cq-rev) + (t 'mel-ccl-pq-rev)))) + +(defun q-encoding-ccl-decode-string (string) + "Decode Q encoded STRING and return the result." + (encode-coding-string + string + 'mel-ccl-uq-rev)) + +(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) + (ccl-execute-on-string + (cond + ((eq mode 'text) 'mel-ccl-count-uq) + ((eq mode 'comment) 'mel-ccl-count-cq) + (t 'mel-ccl-count-pq)) + status + string) + (aref status 0))) + ) + +(mel-define-method-function (encoded-text-encode-string string (nil "Q")) + '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))) + (q-encoding-ccl-decode-string string) + (error "Invalid encoded-text %s" string))) + + +;;; @ end +;;; + +(provide 'mel-q-ccl) + +;;; mel-q-ccl.el ends here diff --git a/mel-u.el b/mel-u.el index 5a756aa..3328e56 100644 --- a/mel-u.el +++ b/mel-u.el @@ -78,7 +78,7 @@ variable `uuencode-external-decoder'." (buffer-substring (match-beginning 0) (match-end 0)) ))))) - (default-directory mime-temp-directory)) + (default-directory temporary-file-directory)) (if filename (as-binary-process (apply (function call-process-region) @@ -131,7 +131,7 @@ variable `uuencode-external-encoder'." ) (mel-define-method mime-write-decoded-region (start end filename - (nil "x-gzip64")) + (nil "x-uue")) "Decode and write current region encoded by uuencode into FILENAME. START and END are buffer positions." (interactive @@ -147,7 +147,7 @@ START and END are buffer positions." (buffer-substring (match-beginning 0) (match-end 0)) ))))) - (default-directory mime-temp-directory)) + (default-directory temporary-file-directory)) (if file (as-binary-process (apply (function call-process-region) diff --git a/mel.el b/mel.el index 51d611c..ccfc072 100644 --- a/mel.el +++ b/mel.el @@ -79,26 +79,6 @@ Content-Transfer-Encoding for it." ;;; @ setting for modules ;;; -(defvar mel-ccl-module - (and (featurep 'mule) - (progn - (require 'path-util) - (module-installed-p 'mel-ccl) - ))) - -(mel-use-module 'mel-b '("base64" "B")) -(mel-use-module 'mel-q '("quoted-printable" "Q")) -(mel-use-module 'mel-g '("x-gzip64")) -(mel-use-module 'mel-u '("x-uue" "x-uuencode")) - -(if mel-ccl-module - (mel-use-module 'mel-ccl '("base64" "quoted-printable" "B" "Q")) - ) - -(if base64-dl-module - (mel-use-module 'mel-b-dl '("base64" "B")) - ) - (mel-define-backend "7bit") (mel-define-method-function (mime-encode-string string (nil "7bit")) 'identity) @@ -116,6 +96,72 @@ Content-Transfer-Encoding for it." (mel-define-backend "binary" ("8bit")) +(when (and (fboundp 'base64-encode-string) + (subrp (symbol-function 'base64-encode-string))) + (mel-define-backend "base64") + (mel-define-method-function (mime-encode-string string (nil "base64")) + 'base64-encode-string) + (mel-define-method-function (mime-decode-string string (nil "base64")) + 'base64-decode-string) + (mel-define-method-function (mime-encode-region start end (nil "base64")) + 'base64-encode-region) + (mel-define-method-function (mime-decode-region start end (nil "base64")) + 'base64-decode-region) + (mel-define-method mime-insert-encoded-file (filename (nil "base64")) + "Encode contents of file FILENAME to base64, and insert the result. +It calls external base64 encoder specified by +`base64-external-encoder'. So you must install the program (maybe +mmencode included in metamail or XEmacs package)." + (interactive (list (read-file-name "Insert encoded file: "))) + (insert (base64-encode-string + (with-temp-buffer + (set-buffer-multibyte nil) + (insert-file-contents-as-binary filename) + (buffer-string)))) + (or (bolp) + (insert "\n")) + ) + + (mel-define-method-function (encoded-text-encode-string string (nil "B")) + 'base64-encode-string) + (mel-define-method encoded-text-decode-string (string (nil "B")) + (if (and (string-match B-encoded-text-regexp string) + (string= string (match-string 0 string))) + (base64-decode-string string) + (error "Invalid encoded-text %s" string))) + ) + +(mel-use-module 'mel-b-el '("base64" "B")) +(mel-use-module 'mel-q '("quoted-printable" "Q")) +(mel-use-module 'mel-g '("x-gzip64")) +(mel-use-module 'mel-u '("x-uue" "x-uuencode")) + +(defvar mel-b-ccl-module + (and (featurep 'mule) + (progn + (require 'path-util) + (module-installed-p 'mel-b-ccl) + ))) + +(defvar mel-q-ccl-module + (and (featurep 'mule) + (progn + (require 'path-util) + (module-installed-p 'mel-q-ccl) + ))) + +(if mel-b-ccl-module + (mel-use-module 'mel-b-ccl '("base64" "B")) + ) + +(if mel-q-ccl-module + (mel-use-module 'mel-q-ccl '("quoted-printable" "Q")) + ) + +(if base64-dl-module + (mel-use-module 'mel-b-dl '("base64" "B")) + ) + ;;; @ region ;;; @@ -168,11 +214,7 @@ ENCODING must be string.") ENCODING must be string.") (defun base64-encoded-length (string) - (let ((len (length string))) - (* (+ (/ len 3) - (if (= (mod len 3) 0) 0 1) - ) 4) - )) + (* (/ (+ (length string) 2) 3) 4)) (defsubst Q-encoding-printable-char-p (chr mode) (and (not (memq chr '(?= ?? ?_))) diff --git a/mime-def.el b/mime-def.el index f4bfe65..d4a994f 100644 --- a/mime-def.el +++ b/mime-def.el @@ -24,8 +24,10 @@ ;;; Code: +(require 'mcharset) + (eval-and-compile - (defconst mime-library-product ["FLIM" (1 11 0) "Yamadagawa"] + (defconst mime-library-product ["FLIM" (1 11 3) "Saidaiji"] "Product name, version number and code name of MIME-library package.") ) @@ -61,16 +63,6 @@ (custom-handle-keyword 'default-mime-charset :group 'mime 'custom-variable) -(defcustom mime-temp-directory (or (getenv "MIME_TMP_DIR") - (getenv "TM_TMP_DIR") - (getenv "TMPDIR") - (getenv "TMP") - (getenv "TEMP") - "/tmp/") - "*Directory for temporary files." - :group 'mime - :type 'directory) - (defcustom mime-uuencode-encoding-name-list '("x-uue" "x-uuencode") "*List of encoding names for uuencode format." :group 'mime @@ -96,15 +88,18 @@ ;;; @ about STD 11 ;;; -(defconst std11-quoted-pair-regexp "\\\\.") -(defconst std11-non-qtext-char-list '(?\" ?\\ ?\r ?\n)) -(defconst std11-qtext-regexp - (concat "[^" (char-list-to-string std11-non-qtext-char-list) "]")) +(eval-and-compile + (defconst std11-quoted-pair-regexp "\\\\.") + (defconst std11-non-qtext-char-list '(?\" ?\\ ?\r ?\n)) + (defconst std11-qtext-regexp + (eval-when-compile + (concat "[^" (apply #'string std11-non-qtext-char-list) "]")))) (defconst std11-quoted-string-regexp - (concat "\"" - (regexp-* - (regexp-or std11-qtext-regexp std11-quoted-pair-regexp)) - "\"")) + (eval-when-compile + (concat "\"" + (regexp-* + (regexp-or std11-qtext-regexp std11-quoted-pair-regexp)) + "\""))) ;;; @ about MIME @@ -407,8 +402,13 @@ specialized parameter. (car (car ARGS)) is name of variable and (nth )))) (put 'mm-define-method 'lisp-indent-function 'defun) -(put 'mm-define-method 'edebug-form-spec - '(&define name ((arg symbolp) &rest arg) def-body)) +(def-edebug-spec mm-define-method + (&define name ((arg symbolp) + [&rest arg] + [&optional ["&optional" arg &rest arg]] + &optional ["&rest" arg] + ) + def-body)) (defsubst mm-arglist-to-arguments (arglist) (let (dest) @@ -527,10 +527,14 @@ variable and (nth 1 (car (last ARGS))) is name of backend (encoding)." ))) (defvar base64-dl-module - (and (fboundp 'dynamic-link) - (let ((path (expand-file-name "base64.so" exec-directory))) - (and (file-exists-p path) - path)))) + (if (and (fboundp 'base64-encode-string) + (subrp (symbol-function 'base64-encode-string))) + nil + (if (fboundp 'dynamic-link) + (let ((path (expand-file-name "base64.so" exec-directory))) + (and (file-exists-p path) + path) + )))) ;;; @ end diff --git a/mmgeneric.el b/mmgeneric.el index 634c80a..6d67b99 100644 --- a/mmgeneric.el +++ b/mmgeneric.el @@ -144,56 +144,50 @@ ) t))) +(defun mime-insert-header-from-buffer (buffer start end + &optional invisible-fields + visible-fields) + (let ((the-buf (current-buffer)) + f-b p f-e field-name len field field-body) + (save-excursion + (set-buffer buffer) + (save-restriction + (narrow-to-region start end) + (goto-char start) + (while (re-search-forward std11-field-head-regexp nil t) + (setq f-b (match-beginning 0) + p (match-end 0) + field-name (buffer-substring f-b p) + len (string-width field-name) + f-e (std11-field-end)) + (when (mime-visible-field-p field-name + visible-fields invisible-fields) + (setq field (intern + (capitalize (buffer-substring f-b (1- p)))) + field-body (buffer-substring p f-e)) + (with-current-buffer the-buf + (insert field-name) + (insert + (if (memq field eword-decode-ignored-field-list) + ;; Don't decode + field-body + (if (memq field eword-decode-structured-field-list) + ;; Decode as structured field + (eword-decode-and-fold-structured-field field-body len) + ;; Decode as unstructured field + (eword-decode-unstructured-field-body field-body len) + ))) + (insert "\n") + ))))))) + (mm-define-method insert-header ((entity generic) &optional invisible-fields visible-fields) - (save-restriction - (narrow-to-region (point)(point)) - (let ((the-buf (current-buffer)) - (src-buf (mime-entity-buffer entity)) - (h-end (mime-entity-header-end-internal entity)) - beg p end field-name len field) - (save-excursion - (set-buffer src-buf) - (goto-char (mime-entity-header-start-internal entity)) - (save-restriction - (narrow-to-region (point) h-end) - (while (re-search-forward std11-field-head-regexp nil t) - (setq beg (match-beginning 0) - p (match-end 0) - field-name (buffer-substring beg (1- p)) - len (string-width field-name) - end (std11-field-end)) - (when (mime-visible-field-p field-name - visible-fields invisible-fields) - (setq field (intern (capitalize field-name))) - (save-excursion - (set-buffer the-buf) - (insert field-name) - (insert ":") - (cond ((memq field eword-decode-ignored-field-list) - ;; Don't decode - (insert-buffer-substring src-buf p end) - ) - ((memq field eword-decode-structured-field-list) - ;; Decode as structured field - (let ((body (save-excursion - (set-buffer src-buf) - (buffer-substring p end) - ))) - (insert (eword-decode-and-fold-structured-field - body (1+ len))) - )) - (t - ;; Decode as unstructured field - (let ((body (save-excursion - (set-buffer src-buf) - (buffer-substring p end) - ))) - (insert (eword-decode-unstructured-field-body - body (1+ len))) - ))) - (insert "\n") - )))))))) + (mime-insert-header-from-buffer + (mime-entity-buffer entity) + (mime-entity-header-start-internal entity) + (mime-entity-header-end-internal entity) + invisible-fields visible-fields) + ) (mm-define-method insert-text-content ((entity generic)) (insert