mel-ccl.el

   1 ;;; mel-ccl.el: CCL based encoder/decoder of Base64, Quoted-Printable
   2 ;;;             and Q-encoding
   3
   4 ;; Copyright (C) 1998 Tanaka Akira
   5
   6 ;; Author: Tanaka Akira <akr@jaist.ac.jp>
   7 ;; Created: 1998/9/17
   8 ;; Keywords: MIME, Base64, Quoted-Printable, Q-encoding
   9
  10 ;; This file is part of FLIM (Faithful Library about Internet Message).
  11
  12 ;; This program is free software; you can redistribute it and/or
  13 ;; modify it under the terms of the GNU General Public License as
  14 ;; published by the Free Software Foundation; either version 2, or (at
  15 ;; your option) any later version.
  16
  17 ;; This program is distributed in the hope that it will be useful, but
  18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  20 ;; General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  25 ;; Boston, MA 02111-1307, USA.
  26
  27 ;;; Code:
  28
  29 (require 'ccl)
  30 (require 'emu)
  31 (require 'pccl)
  32 (require 'mime-def)
  33
  34
  35 ;;; @ constants
  36 ;;;
  37
  38 (eval-when-compile
  39
  40 (defconst mel-ccl-4-table
  41   '(  0   1   2   3))
  42
  43 (defconst mel-ccl-16-table
  44   '(  0   1   2   3   4   5   6   7   8   9  10  11  12  13  14  15))
  45
  46 (defconst mel-ccl-28-table
  47   '(  0   1   2   3   4   5   6   7   8   9  10  11  12  13  14  15
  48      16  17  18  19  20  21  22  23  24  25  26  27))
  49
  50 (defconst mel-ccl-64-table
  51   '(  0   1   2   3   4   5   6   7   8   9  10  11  12  13  14  15
  52      16  17  18  19  20  21  22  23  24  25  26  27  28  29  30  31
  53      32  33  34  35  36  37  38  39  40  41  42  43  44  45  46  47
  54      48  49  50  51  52  53  54  55  56  57  58  59  60  61  62  63))
  55
  56 (defconst mel-ccl-256-table
  57   '(  0   1   2   3   4   5   6   7   8   9  10  11  12  13  14  15
  58      16  17  18  19  20  21  22  23  24  25  26  27  28  29  30  31
  59      32  33  34  35  36  37  38  39  40  41  42  43  44  45  46  47
  60      48  49  50  51  52  53  54  55  56  57  58  59  60  61  62  63
  61      64  65  66  67  68  69  70  71  72  73  74  75  76  77  78  79
  62      80  81  82  83  84  85  86  87  88  89  90  91  92  93  94  95
  63      96  97  98  99 100 101 102 103 104 105 106 107 108 109 110 111
  64     112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127
  65     128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143
  66     144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159
  67     160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175
  68     176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191
  69     192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207
  70     208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223
  71     224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239
  72     240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255))
  73
  74 (defconst mel-ccl-256-to-16-table
  75   '(nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
  76     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
  77     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
  78       0   1   2   3   4   5   6   7   8   9 nil nil nil nil nil nil
  79     nil  10  11  12  13  14  15 nil nil nil nil nil nil nil nil nil
  80     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
  81     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
  82     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
  83     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
  84     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
  85     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
  86     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
  87     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
  88     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
  89     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
  90     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil))
  91
  92 (defconst mel-ccl-16-to-256-table
  93   (mapcar 'char-int "0123456789ABCDEF"))
  94
  95 (defconst mel-ccl-high-table
  96   (vconcat
  97    (mapcar
  98     (lambda (v) (nth (lsh v -4) mel-ccl-16-to-256-table))
  99     mel-ccl-256-table)))
 100
 101 (defconst mel-ccl-low-table
 102   (vconcat
 103    (mapcar
 104     (lambda (v) (nth (logand v 15) mel-ccl-16-to-256-table))
 105     mel-ccl-256-table)))
 106
 107 (defconst mel-ccl-u-raw
 108   (mapcar
 109    'char-int
 110    "0123456789\
 111 ABCDEFGHIJKLMNOPQRSTUVWXYZ\
 112 abcdefghijklmnopqrstuvwxyz\
 113 !@#$%&'()*+,-./:;<>@[\\]^`{|}~"))
 114
 115 (defconst mel-ccl-c-raw
 116   (mapcar
 117    'char-int
 118    "0123456789\
 119 ABCDEFGHIJKLMNOPQRSTUVWXYZ\
 120 abcdefghijklmnopqrstuvwxyz\
 121 !@#$%&'*+,-./:;<>@[]^`{|}~"))
 122
 123 (defconst mel-ccl-p-raw
 124   (mapcar
 125    'char-int
 126    "0123456789\
 127 ABCDEFGHIJKLMNOPQRSTUVWXYZ\
 128 abcdefghijklmnopqrstuvwxyz\
 129 !*+-/"))
 130
 131 (defconst mel-ccl-256-to-64-table
 132   '(nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
 133     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
 134     nil nil nil nil nil nil nil nil nil nil nil  62 nil nil nil  63
 135      52  53  54  55  56  57  58  59  60  61 nil nil nil   t nil nil
 136     nil   0   1   2   3   4   5   6   7   8   9  10  11  12  13  14
 137      15  16  17  18  19  20  21  22  23  24  25 nil nil nil nil nil
 138     nil  26  27  28  29  30  31  32  33  34  35  36  37  38  39  40
 139      41  42  43  44  45  46  47  48  49  50  51 nil nil nil nil nil
 140     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
 141     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
 142     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
 143     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
 144     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
 145     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
 146     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
 147     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil))
 148
 149 (defconst mel-ccl-64-to-256-table
 150   (mapcar
 151    'char-int
 152    "ABCDEFGHIJKLMNOPQRSTUVWXYZ\
 153 abcdefghijklmnopqrstuvwxyz\
 154 0123456789\
 155 +/"))
 156
 157 (defconst mel-ccl-qp-table
 158   [enc enc enc enc enc enc enc enc enc wsp lf  enc enc cr  enc enc
 159    enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc
 160    wsp raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw
 161    raw raw raw raw raw raw raw raw raw raw raw raw raw enc raw raw
 162    raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw
 163    raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw
 164    raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw
 165    raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw enc
 166    enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc
 167    enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc
 168    enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc
 169    enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc
 170    enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc
 171    enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc
 172    enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc
 173    enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc])
 174
 175 )
 176
 177
 178 ;;; @ CCL programs
 179 ;;;
 180
 181 ;;; Q
 182
 183 (define-ccl-program mel-ccl-decode-q
 184   `(1
 185     ((loop
 186       (read-branch
 187        r0
 188        ,@(mapcar
 189           (lambda (r0)
 190             (cond
 191              ((= r0 (char-int ?_))
 192               `(write-repeat ? ))
 193              ((= r0 (char-int ?=))
 194               `((loop
 195                  (read-branch
 196                   r1
 197                   ,@(mapcar
 198                      (lambda (v)
 199                        (if (integerp v)
 200                            `((r0 = ,v) (break))
 201                          '(repeat)))
 202                      mel-ccl-256-to-16-table)))
 203                 (loop
 204                  (read-branch
 205                   r1
 206                   ,@(mapcar
 207                      (lambda (v)
 208                        (if (integerp v)
 209                            `((write r0 ,(vconcat
 210                                          (mapcar
 211                                           (lambda (r0)
 212                                             (logior (lsh r0 4) v))
 213                                           mel-ccl-16-table)))
 214                              (break))
 215                          '(repeat)))
 216                      mel-ccl-256-to-16-table)))
 217                 (repeat)))
 218              (t
 219               `(write-repeat ,r0))))
 220           mel-ccl-256-table))))))
 221
 222 (eval-when-compile
 223
 224 (defun mel-ccl-encode-q-generic (raw)
 225   `(3
 226     (loop
 227      (loop
 228       (read-branch
 229        r0
 230        ,@(mapcar
 231           (lambda (r0)
 232             (cond
 233              ((= r0 32) `(write-repeat ?_))
 234              ((member r0 raw) `(write-repeat ,r0))
 235              (t '(break))))
 236           mel-ccl-256-table)))
 237      (write ?=)
 238      (write r0 ,mel-ccl-high-table)
 239      (write r0 ,mel-ccl-low-table)
 240      (repeat))))
 241
 242 ;; On xemacs, generated program counts iso-8859-1 8bit character as 6bytes.
 243 (defun mel-ccl-count-q-length (raw)
 244   `(0
 245     ((r0 = 0)
 246      (loop
 247       (read-branch
 248        r1
 249        ,@(mapcar
 250           (lambda (r1)
 251             (if (or (= r1 32) (member r1 raw))
 252                 '((r0 += 1) (repeat))
 253               '((r0 += 3) (repeat))))
 254           mel-ccl-256-table))))))
 255
 256 )
 257
 258 (define-ccl-program mel-ccl-encode-uq
 259   (mel-ccl-encode-q-generic mel-ccl-u-raw))
 260 (define-ccl-program mel-ccl-encode-cq
 261   (mel-ccl-encode-q-generic mel-ccl-c-raw))
 262 (define-ccl-program mel-ccl-encode-pq
 263   (mel-ccl-encode-q-generic mel-ccl-p-raw))
 264
 265 (define-ccl-program mel-ccl-count-uq
 266   (mel-ccl-count-q-length mel-ccl-u-raw))
 267 (define-ccl-program mel-ccl-count-cq
 268   (mel-ccl-count-q-length mel-ccl-c-raw))
 269 (define-ccl-program mel-ccl-count-pq
 270   (mel-ccl-count-q-length mel-ccl-p-raw))
 271
 272 ;;; B/Base64
 273
 274 (eval-when-compile
 275
 276 (defun mel-ccl-decode-b-bit-ex (v)
 277   (logior
 278    (lsh (logand v (lsh 255 16)) -16)
 279    (logand v (lsh 255 8))
 280    (lsh (logand v 255) 16)))
 281
 282 (defconst mel-ccl-decode-b-0-table
 283   (vconcat
 284    (mapcar
 285     (lambda (v)
 286       (if (integerp v)
 287           (mel-ccl-decode-b-bit-ex (lsh v 18))
 288         (lsh 1 24)))
 289     mel-ccl-256-to-64-table)))
 290
 291 (defconst mel-ccl-decode-b-1-table
 292   (vconcat
 293    (mapcar
 294     (lambda (v)
 295       (if (integerp v)
 296           (mel-ccl-decode-b-bit-ex (lsh v 12))
 297         (lsh 1 25)))
 298     mel-ccl-256-to-64-table)))
 299
 300 (defconst mel-ccl-decode-b-2-table
 301   (vconcat
 302    (mapcar
 303     (lambda (v)
 304       (if (integerp v)
 305           (mel-ccl-decode-b-bit-ex (lsh v 6))
 306         (lsh 1 26)))
 307     mel-ccl-256-to-64-table)))
 308
 309 (defconst mel-ccl-decode-b-3-table
 310   (vconcat
 311    (mapcar
 312     (lambda (v)
 313       (if (integerp v)
 314           (mel-ccl-decode-b-bit-ex v)
 315         (lsh 1 27)))
 316     mel-ccl-256-to-64-table)))
 317
 318 )
 319
 320 (define-ccl-program mel-ccl-decode-b
 321   `(1
 322     (loop
 323      (read r0 r1 r2 r3)
 324      (r4 = r0 ,mel-ccl-decode-b-0-table)
 325      (r5 = r1 ,mel-ccl-decode-b-1-table)
 326      (r4 |= r5)
 327      (r5 = r2 ,mel-ccl-decode-b-2-table)
 328      (r4 |= r5)
 329      (r5 = r3 ,mel-ccl-decode-b-3-table)
 330      (r4 |= r5)
 331      (if (r4 & ,(lognot (1- (lsh 1 24))))
 332          ((loop
 333            (if (r4 & ,(lsh 1 24))
 334                ((r0 = r1) (r1 = r2) (r2 = r3) (read r3)
 335                 (r4 >>= 1) (r4 &= ,(logior (lsh 7 24)))
 336                 (r5 = r3 ,mel-ccl-decode-b-3-table)
 337                 (r4 |= r5)
 338                 (repeat))
 339              (break)))
 340           (loop
 341            (if (r4 & ,(lsh 1 25))
 342                ((r1 = r2) (r2 = r3) (read r3)
 343                 (r4 >>= 1) (r4 &= ,(logior (lsh 7 24)))
 344                 (r5 = r3 ,mel-ccl-decode-b-3-table)
 345                 (r4 |= r5)
 346                 (repeat))
 347              (break)))
 348           (loop
 349            (if (r2 != ?=)
 350                (if (r4 & ,(lsh 1 26))
 351                    ((r2 = r3) (read r3)
 352                     (r4 >>= 1) (r4 &= ,(logior (lsh 7 24)))
 353                     (r5 = r3 ,mel-ccl-decode-b-3-table)
 354                     (r4 |= r5)
 355                     (repeat))
 356                  ((r6 = 0)
 357                   (break)))
 358              ((r6 = 1)
 359               (break))))
 360           (loop
 361            (if (r3 != ?=)
 362                (if (r4 & ,(lsh 1 27))
 363                    ((read r3)
 364                     (r4 = r3 ,mel-ccl-decode-b-3-table)
 365                     (repeat))
 366                  (break))
 367              ((r6 |= 2)
 368               (break))))
 369           (r4 = r0 ,mel-ccl-decode-b-0-table)
 370           (r5 = r1 ,mel-ccl-decode-b-1-table)
 371           (r4 |= r5)
 372           (branch
 373            r6
 374            ;; BBBB
 375            ((r5 = r2 ,mel-ccl-decode-b-2-table)
 376             (r4 |= r5)
 377             (r5 = r3 ,mel-ccl-decode-b-3-table)
 378             (r4 |= r5)
 379             (r4 >8= 0)
 380             (write r7)
 381             (r4 >8= 0)
 382             (write r7)
 383             (write-repeat r4))
 384            ;; error: BB=B
 385            ((write (r4 & 255))
 386             (end))
 387            ;; BBB=
 388            ((r5 = r2 ,mel-ccl-decode-b-2-table)
 389             (r4 |= r5)
 390             (r4 >8= 0)
 391             (write r7)
 392             (write (r4 & 255))
 393             (end)                       ; Excessive (end) is workaround for XEmacs 21.0.
 394                                         ; Without this, "AAA=" is converted to "^@^@^@".
 395             (end))
 396            ;; BB==
 397            ((write (r4 & 255))
 398             (end))))
 399        ((r4 >8= 0)
 400         (write r7)
 401         (r4 >8= 0)
 402         (write r7)
 403         (write-repeat r4))))))
 404
 405 (eval-when-compile
 406
 407 ;; Generated CCL program works not properly on 20.2 because CCL_EOF_BLOCK
 408 ;; is not executed.
 409 (defun mel-ccl-encode-base64-generic (&optional quantums-per-line output-crlf terminate-with-newline)
 410   `(2
 411     ((r3 = 0)
 412      (loop
 413       (r2 = 0)
 414       (read-branch
 415        r1
 416        ,@(mapcar
 417           (lambda (r1)
 418             `((write ,(nth (lsh r1 -2) mel-ccl-64-to-256-table))
 419               (r0 = ,(logand r1 3))))
 420           mel-ccl-256-table))
 421       (r2 = 1)
 422       (read-branch
 423        r1
 424        ,@(mapcar
 425           (lambda (r1)
 426             `((write r0 ,(vconcat
 427                           (mapcar
 428                            (lambda (r0)
 429                              (nth (logior (lsh r0 4)
 430                                           (lsh r1 -4))
 431                                   mel-ccl-64-to-256-table))
 432                            mel-ccl-4-table)))
 433               (r0 = ,(logand r1 15))))
 434           mel-ccl-256-table))
 435       (r2 = 2)
 436       (read-branch
 437        r1
 438        ,@(mapcar
 439           (lambda (r1)
 440             `((write r0 ,(vconcat
 441                           (mapcar
 442                            (lambda (r0)
 443                              (nth (logior (lsh r0 2)
 444                                           (lsh r1 -6))
 445                                   mel-ccl-64-to-256-table))
 446                            mel-ccl-16-table)))))
 447           mel-ccl-256-table))
 448       (r1 &= 63)
 449       (write r1 ,(vconcat
 450                   (mapcar
 451                    (lambda (r1)
 452                      (nth r1 mel-ccl-64-to-256-table))
 453                    mel-ccl-64-table)))
 454       (r3 += 1)
 455       ,@(when quantums-per-line
 456           `((if (r3 == ,quantums-per-line)
 457                 ((write ,(if output-crlf "\r\n" "\n"))
 458                  (r3 = 0)))))
 459       (repeat)))
 460     (branch
 461      r2
 462      ,(if terminate-with-newline
 463           `(if (r3 > 0) (write ,(if output-crlf "\r\n" "\n")))
 464         `(r0 = 0))
 465      ((write r0 ,(vconcat
 466                   (mapcar
 467                    (lambda (r0)
 468                      (nth (lsh r0 4) mel-ccl-64-to-256-table))
 469                    mel-ccl-4-table)))
 470       (write ,(if terminate-with-newline
 471                   (if output-crlf "==\r\n" "==\n")
 472                 "==")))
 473      ((write r0 ,(vconcat
 474                   (mapcar
 475                    (lambda (r0)
 476                      (nth (lsh r0 2) mel-ccl-64-to-256-table))
 477                    mel-ccl-16-table)))
 478       (write ,(if terminate-with-newline
 479                   (if output-crlf "=\r\n" "=\n")
 480                 "="))))
 481     ))
 482 )
 483
 484 (define-ccl-program mel-ccl-encode-b
 485   (mel-ccl-encode-base64-generic))
 486
 487 ;; 19 * 4 = 76
 488 (define-ccl-program mel-ccl-encode-base64-crlf-crlf
 489   (mel-ccl-encode-base64-generic 19 t))
 490
 491 (define-ccl-program mel-ccl-encode-base64-crlf-lf
 492   (mel-ccl-encode-base64-generic 19 nil))
 493
 494 ;; Quoted-Printable
 495
 496 (eval-when-compile
 497
 498 (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)
 499   (if input-crlf
 500       `((,eof-reg = ,cr-eof) (read-if (,reg == ?\r)
 501         ((,eof-reg = ,lf-eof) (read-if (,reg == ?\n)
 502          ,succ
 503          ,fail-lf))
 504         ,fail-cr))
 505     `((,eof-reg = ,crlf-eof) (read-if (,reg == ?\n)
 506       ,succ
 507       ,fail-crlf))))
 508
 509 ;; Generated CCL program works not properly on 20.2 because CCL_EOF_BLOCK
 510 ;; is not executed.
 511 (defun mel-ccl-encode-quoted-printable-generic (input-crlf output-crlf)
 512   `(4
 513     ((r6 = 0)                           ; column
 514      (r5 = 0)                           ; previous character is white space
 515      (r4 = 0)
 516      (read r0)
 517      (loop                              ; r6 <= 75
 518       (loop
 519        (loop
 520         (branch
 521          r0
 522          ,@(mapcar
 523             (lambda (r0)
 524               (let ((tmp (aref mel-ccl-qp-table r0)))
 525                 (cond
 526                  ((eq r0 (char-int ?F))
 527                   `(if (r6 == 0)
 528                        ((r4 = 15) (read-if (r0 == ?r)
 529                         ((r4 = 16) (read-if (r0 == ?o)
 530                          ((r4 = 17) (read-if (r0 == ?m)
 531                           ((r4 = 18) (read-if (r0 == ? )
 532                            ((r6 = 7)
 533                             (r5 = 1)
 534                             (write "=46rom ")
 535                             (r4 = 19)
 536                             (read r0)
 537                             (repeat))
 538                            ((r6 = 4)
 539                             (write-repeat "From"))))
 540                           ((r6 = 3)
 541                            (write-repeat "Fro"))))
 542                          ((r6 = 2)
 543                           (write-repeat "Fr"))))
 544                         ((r6 = 1)
 545                          (write-repeat "F"))))
 546                      ((r3 = 0) (break)) ; RAW
 547                      ))
 548                  ((eq r0 (char-int ?.))
 549                   `(if (r6 == 0)
 550                        ,(mel-ccl-try-to-read-crlf
 551                          input-crlf
 552                          'r0 'r4 20 21 22
 553                          `((write ,(if output-crlf "=2E\r\n" "=2E\n"))
 554                            (r4 = 23)
 555                            (read r0)
 556                            (repeat))
 557                          '((r6 = 1)
 558                            (write-repeat "."))
 559                          '((r6 = 4)
 560                            (write-repeat ".=0D"))
 561                          '((r6 = 1)
 562                            (write-repeat ".")))
 563                      ((r3 = 0) (break)) ; RAW
 564                      ))
 565                  ((eq tmp 'raw) '((r3 = 0) (break))) ; RAW
 566                  ((eq tmp 'enc) '((r3 = 1) (break))) ; ENC
 567                  ((eq tmp 'wsp) '((r3 = 2) (break))) ; WSP
 568                  ((eq tmp 'cr) (if input-crlf
 569                                    '((r3 = 3) (break)) ; CR
 570                                  '((r3 = 1) (break)))) ; ENC
 571                  ((eq tmp 'lf) (if input-crlf
 572                                    '((r3 = 1) (break)) ; ENC
 573                                  '((r3 = 3) (break)))) ; CRLF
 574                  )))
 575             mel-ccl-256-table)))
 576        (branch
 577         r3
 578         ;; r0:r3=RAW
 579         (if (r6 < 75)
 580             ((r6 += 1)
 581              (r5 = 0)
 582              (r4 = 1)
 583              (write-read-repeat r0))
 584           (break))
 585         ;; r0:r3=ENC
 586         ((r5 = 0)
 587          (if (r6 < 73)
 588              ((r6 += 3)
 589               (write "=")
 590               (write r0 ,mel-ccl-high-table)
 591               (r4 = 2)
 592               (write-read-repeat r0 ,mel-ccl-low-table))
 593            (if (r6 > 73)
 594                ((r6 = 3)
 595                 (write ,(if output-crlf "=\r\n=" "=\n="))
 596                 (write r0 ,mel-ccl-high-table)
 597                 (r4 = 3)
 598                 (write-read-repeat r0 ,mel-ccl-low-table))
 599              (break))))
 600         ;; r0:r3=WSP
 601         ((r5 = 1)
 602          (if (r6 < 75)
 603              ((r6 += 1)
 604               (r4 = 4)
 605               (write-read-repeat r0))
 606            ((r6 = 1)
 607             (write ,(if output-crlf "=\r\n" "=\n"))
 608             (r4 = 5)
 609             (write-read-repeat r0))))
 610         ;; r0:r3=CR/CRLF
 611         ,(if input-crlf
 612              ;; r0:r3=CR
 613              `((if ((r6 > 73) & r5)
 614                    ((r6 = 0)
 615                     (r5 = 0)
 616                     (write ,(if output-crlf "=\r\n" "=\n"))))
 617                (break))
 618            ;; r0:r3=CRLF
 619            `(if r5
 620                 ;; WSP ; r0:r3=CRLF
 621                 ((r5 = 0)
 622                  (r6 = 0)
 623                  (write ,(if output-crlf "=\r\n" "=\n"))
 624                  ,@(if output-crlf '((write ?\r)) '())
 625                  (r4 = 0)
 626                  (write-read-repeat r0))
 627               ;; noWSP ; r0:r3=CRLF
 628               ((r5 = 0)
 629                (r6 = 0)
 630                ,@(if output-crlf '((write ?\r)) '())
 631                (r4 = 0)
 632                (write-read-repeat r0)))
 633            )))
 634       ;; r0:r3={RAW,ENC,CR}
 635       (loop
 636        ,(funcall
 637          (lambda (after-cr after-raw-enc)
 638            (if input-crlf
 639                `(if (r0 == ?\r)
 640                     ,after-cr
 641                   ,after-raw-enc)
 642              after-raw-enc))
 643          ;; r0=\r:r3=CR
 644          `((r4 = 6)
 645            (read r0)
 646            ;; CR:r3=CR r0
 647            (if (r0 == ?\n)
 648                ;; CR:r3=CR r0=LF
 649                (if r5
 650                    ;; r5=WSP ; CR:r3=CR r0=LF
 651                    ((r6 = 0)
 652                     (r5 = 0)
 653                     (write ,(if output-crlf "=\r\n\r\n" "=\n\n"))
 654                     (r4 = 7)
 655                     (read r0)
 656                     (break))
 657                  ;; r5=noWSP ; CR:r3=CR r0=LF
 658                  ((r6 = 0)
 659                   (r5 = 0)
 660                   (write ,(if output-crlf "\r\n" "\n"))
 661                   (r4 = 8)
 662                   (read r0)
 663                   (break)))
 664              ;; CR:r3=CR r0=noLF
 665              (if (r6 < 73)
 666                  ((r6 += 3)
 667                   (r5 = 0)
 668                   (write "=0D")
 669                   (break))
 670                (if (r6 == 73)
 671                    (if (r0 == ?\r)
 672                        ;; CR:r3=CR r0=CR
 673                        ((r4 = 9)
 674                         (read r0)
 675                         ;; CR:r3=CR CR r0
 676                         (if (r0 == ?\n)
 677                             ;; CR:r3=CR CR LF
 678                             ((r6 = 0)
 679                              (r5 = 0)
 680                              (write ,(if output-crlf "=0D\r\n" "=0D\n"))
 681                              (r4 = 10)
 682                              (read r0)
 683                              (break))
 684                           ;; CR:r3=CR CR noLF
 685                           ((r6 = 6)
 686                            (r5 = 0)
 687                            (write ,(if output-crlf "=\r\n=0D=0D" "=\n=0D=0D"))
 688                            (break))))
 689                      ;; CR:r3=CR r0=noLFnorCR
 690                      ((r6 = 3)
 691                       (r5 = 0)
 692                       (write ,(if output-crlf "=\r\n=0D" "=\n=0D"))
 693                       (break)))
 694                  ((r6 = 3)
 695                   (r5 = 0)
 696                   (write ,(if output-crlf "=\r\n=0D" "=\n=0D"))
 697                   (break))))))
 698          (funcall
 699           (lambda (after-newline after-cr-nolf after-nonewline)
 700             (if input-crlf
 701                 ;; r0:r3={RAW,ENC}
 702                 `((r4 = 11)
 703                   (read r1)
 704                   ;; r0:r3={RAW,ENC} r1
 705                   (if (r1 == ?\r)
 706                       ;; r0:r3={RAW,ENC} r1=CR
 707                       ((r4 = 12)
 708                        (read r1)
 709                        ;; r0:r3={RAW,ENC} CR r1
 710                        (if (r1 == ?\n)
 711                            ;; r0:r3=RAW CR r1=LF
 712                            ,after-newline
 713                          ;; r0:r3=RAW CR r1=noLF
 714                          ,after-cr-nolf))
 715                     ;; r0:r3={RAW,ENC} r1:noCR
 716                     ,after-nonewline))
 717               ;; r0:r3={RAW,ENC}
 718               `((r4 = 11)
 719                 (read r1)
 720                 ;; r0:r3={RAW,ENC} r1
 721                 (if (r1 == ?\n)
 722                     ;; r0:r3={RAW,ENC} r1=CRLF
 723                     ,after-newline
 724                   ;; r0:r3={RAW,ENC} r1:noCRLF
 725                   ,after-nonewline))))
 726           ;; r0:r3={RAW,ENC} CR r1=LF
 727           ;; r0:r3={RAW,ENC} r1=CRLF
 728           `((r6 = 0)
 729             (r5 = 0)
 730             (branch
 731              r3
 732              ;; r0:r3=RAW CR r1=LF
 733              ;; r0:r3=RAW r1=CRLF
 734              ((write r0)
 735               (write ,(if output-crlf "\r\n" "\n"))
 736               (r4 = 13)
 737               (read r0)
 738               (break))
 739              ;; r0:r3=ENC CR r1=LF
 740              ;; r0:r3=ENC r1=CRLF
 741              ((write ?=)
 742               (write r0 ,mel-ccl-high-table)
 743               (write r0 ,mel-ccl-low-table)
 744               (write ,(if output-crlf "\r\n" "\n"))
 745               (r4 = 14)
 746               (read r0)
 747               (break))))
 748           ;; r0:r3={RAW,ENC} CR r1=noLF
 749           `((branch
 750              r3
 751              ;; r0:r3=RAW CR r1:noLF
 752              ((r6 = 4)
 753               (r5 = 0)
 754               (write ,(if output-crlf "=\r\n" "=\n"))
 755               (write r0)
 756               (write "=0D")
 757               (r0 = r1)
 758               (break))
 759              ;; r0:r3=ENC CR r1:noLF
 760              ((r6 = 6)
 761               (r5 = 0)
 762               (write ,(if output-crlf "=\r\n=" "=\n="))
 763               (write r0 ,mel-ccl-high-table)
 764               (write r0 ,mel-ccl-low-table)
 765               (write "=0D")
 766               (r0 = r1)
 767               (break))))
 768           ;; r0:r3={RAW,ENC} r1:noCR
 769           ;; r0:r3={RAW,ENC} r1:noCRLF
 770           `((branch
 771              r3
 772              ;; r0:r3=RAW r1:noCR
 773              ;; r0:r3=RAW r1:noCRLF
 774              ((r6 = 1)
 775               (r5 = 0)
 776               (write ,(if output-crlf "=\r\n" "=\n"))
 777               (write r0)
 778               (r0 = r1)
 779               (break))
 780              ;; r0:r3=ENC r1:noCR
 781              ;; r0:r3=ENC r1:noCRLF
 782              ((r6 = 3)
 783               (r5 = 0)
 784               (write ,(if output-crlf "=\r\n=" "=\n="))
 785               (write r0 ,mel-ccl-high-table)
 786               (write r0 ,mel-ccl-low-table)
 787               (r0 = r1)
 788               (break)))))))
 789       (repeat)))
 790     ;; EOF
 791     (                                   ;(write "[EOF:") (write r4 ,mel-ccl-high-table) (write r4 ,mel-ccl-low-table) (write "]")
 792      (branch
 793       r4
 794       ;; 0: (start) ;
 795       (end)
 796       ;; 1: RAW ;
 797       (end)
 798       ;; 2: r0:r3=ENC ;
 799       (end)
 800       ;; 3: SOFTBREAK r0:r3=ENC ;
 801       (end)
 802       ;; 4: r0:r3=WSP ;
 803       ((write ,(if output-crlf "=\r\n" "=\n")) (end))
 804       ;; 5: SOFTBREAK r0:r3=WSP ;
 805       ((write ,(if output-crlf "=\r\n" "=\n")) (end))
 806       ;; 6: ; r0=\r:r3=CR
 807       (if (r6 <= 73)
 808           ((write "=0D") (end))
 809         ((write ,(if output-crlf "=\r\n=0D" "=\n=0D")) (end)))
 810       ;; 7: r5=WSP SOFTBREAK CR:r3=CR r0=LF ;
 811       (end)
 812       ;; 8: r5=noWSP CR:r3=CR r0=LF ;
 813       (end)
 814       ;; 9: (r6=73) ; CR:r3=CR r0=CR
 815       ((write ,(if output-crlf "=\r\n=0D=0D" "=\n=0D=0D")) (end))
 816       ;; 10: (r6=73) CR:r3=CR CR LF ;
 817       (end)
 818       ;; 11: ; r0:r3={RAW,ENC}
 819       (branch
 820        r3
 821        ((write r0) (end))
 822        ((write "=")
 823         (write r0 ,mel-ccl-high-table)
 824         (write r0 ,mel-ccl-low-table)
 825         (end)))
 826       ;; 12: ; r0:r3={RAW,ENC} r1=CR
 827       (branch
 828        r3
 829        ;; ; r0:r3=RAW r1=CR
 830        ((write ,(if output-crlf "=\r\n" "=\n"))
 831         (write r0)
 832         (write "=0D")
 833         (end))
 834        ;; ; r0:r3=ENC r1=CR
 835        ((write ,(if output-crlf "=\r\n=" "=\n="))
 836         (write r0 ,mel-ccl-high-table)
 837         (write r0 ,mel-ccl-low-table)
 838         (write "=0D")
 839         (end)))
 840       ;; 13: r0:r3=RAW CR LF ;
 841       ;; 13: r0:r3=RAW CRLF ;
 842       (end)
 843       ;; 14: r0:r3=ENC CR LF ;
 844       ;; 14: r0:r3=ENC CRLF ;
 845       (end)
 846       ;; 15: r6=0 ; "F"
 847       ((write "F") (end))
 848       ;; 16: r6=0 ; "Fr"
 849       ((write "Fr") (end))
 850       ;; 17: r6=0 ; "Fro"
 851       ((write "Fro") (end))
 852       ;; 18: r6=0 ; "From"
 853       ((write "From") (end))
 854       ;; 19: r6=0 "From " ;
 855       (end)
 856       ;; 20: r6=0 ; "."
 857       ((write ".") (end))
 858       ;; 21: r6=0 ; ".\r"
 859       ((write ".=0D") (end))
 860       ;; 22: r6=0 ; "."
 861       ((write ".") (end))
 862       ;; 23: r6=0 ".\r\n" ;
 863       (end)
 864       ))
 865     ))
 866
 867 (defun mel-ccl-decode-quoted-printable-generic (input-crlf output-crlf)
 868   `(1
 869     ((read r0)
 870      (loop
 871       (branch
 872        r0
 873        ,@(mapcar
 874           (lambda (r0)
 875             (let ((tmp (aref mel-ccl-qp-table r0)))
 876               (cond
 877                ((eq tmp 'raw) `(write-read-repeat r0))
 878                ((eq tmp 'wsp) (if (eq r0 (char-int ? ))
 879                                   `(r1 = 1)
 880                                 `(r1 = 0)))
 881                ((eq tmp 'cr)
 882                 (if input-crlf
 883                     ;; r0='\r'
 884                     `((read r0)
 885                       ;; '\r' r0
 886                       (if (r0 == ?\n)
 887                           ;; '\r' r0='\n'
 888                           ;; hard line break found.
 889                           ,(if output-crlf
 890                                '((write ?\r)
 891                                  (write-read-repeat r0))
 892                              '(write-read-repeat r0))
 893                         ;; '\r' r0:[^\n]
 894                         ;; invalid control character (bare CR) found.
 895                         ;; -> ignore it and rescan from r0.
 896                         (repeat)))
 897                   ;; r0='\r'
 898                   ;; invalid character (bare CR) found.
 899                   ;; -> ignore.
 900                   `((read r0)
 901                     (repeat))))
 902                ((eq tmp 'lf)
 903                 (if input-crlf
 904                     ;; r0='\n'
 905                     ;; invalid character (bare LF) found.
 906                     ;; -> ignore.
 907                     `((read r0)
 908                       (repeat))
 909                   ;; r0='\r\n'
 910                   ;; hard line break found.
 911                   (if output-crlf
 912                       '((write ?\r)
 913                         (write-read-repeat r0))
 914                     '(write-read-repeat r0))))
 915                ((eq r0 (char-int ?=))
 916                 ;; r0='='
 917                 `((read r0)
 918                   ;; '=' r0
 919                   (r1 = (r0 == ?\t))
 920                   (if ((r0 == ? ) | r1)
 921                       ;; '=' r0:[\t ]
 922                       ;; Skip transport-padding.
 923                       ;; It should check CR LF after
 924                       ;; transport-padding.
 925                       (loop
 926                        (read-if (r0 == ?\t)
 927                                 (repeat)
 928                                 (if (r0 == ? )
 929                                     (repeat)
 930                                   (break)))))
 931                   ;; '=' [\t ]* r0:[^\t ]
 932                   (branch
 933                    r0
 934                    ,@(mapcar
 935                       (lambda (r0)
 936                         (cond
 937                          ((eq r0 (char-int ?\r))
 938                           (if input-crlf
 939                               ;; '=' [\t ]* r0='\r'
 940                               `((read r0)
 941                                 ;; '=' [\t ]* '\r' r0
 942                                 (if (r0 == ?\n)
 943                                     ;; '=' [\t ]* '\r' r0='\n'
 944                                     ;; soft line break found.
 945                                     ((read r0)
 946                                      (repeat))
 947                                   ;; '=' [\t ]* '\r' r0:[^\n]
 948                                   ;; invalid input ->
 949                                   ;; output "=" and rescan from r0.
 950                                   ((write "=")
 951                                    (repeat))))
 952                             ;; '=' [\t ]* r0='\r'
 953                             ;; invalid input (bare CR found) ->
 954                             ;; output "=" and rescan from next.
 955                             `((write ?=)
 956                               (read r0)
 957                               (repeat))))
 958                          ((eq r0 (char-int ?\n))
 959                           (if input-crlf
 960                               ;; '=' [\t ]* r0='\n'
 961                               ;; invalid input (bare LF found) ->
 962                               ;; output "=" and rescan from next.
 963                               `((write ?=)
 964                                 (read r0)
 965                                 (repeat))
 966                             ;; '=' [\t ]* r0='\r\n'
 967                             ;; soft line break found.
 968                             `((read r0)
 969                               (repeat))))
 970                          ((setq tmp (nth r0 mel-ccl-256-to-16-table))
 971                           ;; '=' [\t ]* r0:[0-9A-F]
 972                           ;; upper nibble of hexadecimal digit found.
 973                           `((r1 = r0)
 974                             (r0 = ,tmp)))
 975                          (t
 976                           ;; '=' [\t ]* r0:[^\r0-9A-F]
 977                           ;; invalid input ->
 978                           ;; output "=" and rescan from r0.
 979                           `((write ?=)
 980                             (repeat)))))
 981                       mel-ccl-256-table))
 982                   ;; '=' [\t ]* r1:r0:[0-9A-F]
 983                   (read-branch
 984                    r2
 985                    ,@(mapcar
 986                       (lambda (r2)
 987                         (if (setq tmp (nth r2 mel-ccl-256-to-16-table))
 988                             ;; '=' [\t ]* r1:r0:[0-9A-F] r2:[0-9A-F]
 989                             `(write-read-repeat
 990                               r0
 991                               ,(vconcat
 992                                 (mapcar
 993                                  (lambda (r0)
 994                                    (logior (lsh r0 4) tmp))
 995                                  mel-ccl-16-table)))
 996                           ;; '=' [\t ]* r1:r0:[0-9A-F] r2:[^0-9A-F]
 997                           ;; invalid input
 998                           `(r3 = 0)     ; nop
 999                           ))
1000                       mel-ccl-256-table))
1001                   ;; '=' [\t ]* r1:r0:[0-9A-F] r2:[^0-9A-F]
1002                   ;; invalid input ->
1003                   ;; output "=" with hex digit and rescan from r2.
1004                   (write ?=)
1005                   (r0 = r2)
1006                   (write-repeat r1)))
1007                (t
1008                 ;; r0:[^\t\r -~]
1009                 ;; invalid character found.
1010                 ;; -> ignore.
1011                 `((read r0)
1012                   (repeat))))))
1013           mel-ccl-256-table))
1014       ;; r1[0]:[\t ]
1015       (loop
1016        ,@(apply
1017           'append
1018           (mapcar
1019            (lambda (regnum)
1020              (let ((reg (aref [r1 r2 r3 r4 r5] regnum)))
1021                (apply
1022                 'append
1023                 (mapcar
1024                  (lambda (bit)
1025                    (if (= bit 0)
1026                        (if (= regnum 0)
1027                            nil
1028                          `((read r0)
1029                            (if (r0 == ?\t)
1030                                (,reg = 0)
1031                              (if (r0 == ?\ )
1032                                  (,reg = 1)
1033                                ((r6 = ,(+ (* regnum 28) bit))
1034                                 (break))))))
1035                      `((read r0)
1036                        (if (r0 == ?\ )
1037                            (,reg |= ,(lsh 1 bit))
1038                          (if (r0 != ?\t)
1039                              ((r6 = ,(+ (* regnum 28) bit))
1040                               (break)))))))
1041                  mel-ccl-28-table))))
1042            '(0 1 2 3 4)))
1043        ;; white space buffer exhaust.
1044        ;; error: line length limit (76bytes) violation.
1045        ;; -> ignore these white spaces.
1046        (repeat))
1047       ,(if input-crlf
1048            `(if (r0 == ?\r)
1049                 ((read r0)
1050                  (if (r0 == ?\n)
1051                      ;; trailing white spaces found.
1052                      ;; -> ignore these white spacs.
1053                      ((write ,(if output-crlf "\r\n" "\n"))
1054                       (read r0)
1055                       (repeat))
1056                    ;; [\t ]* \r r0:[^\n]
1057                    ;; error: bare CR found.
1058                    ;; -> output white spaces and ignore bare CR.
1059                    ))
1060               ;; [\t ]* r0:[^\r]
1061               ;; middle white spaces found.
1062               )
1063          `(if (r0 == ?\n)
1064               ;; trailing white spaces found.
1065               ;; -> ignore these white spacs.
1066               ((write ,(if output-crlf "\r\n" "\n"))
1067                (read r0)
1068                (repeat))
1069             ;; [\t ]* r0:[^\n]
1070             ;; middle white spaces found.
1071             ))
1072       ,@(apply
1073          'append
1074          (mapcar
1075           (lambda (regnum)
1076             (let ((reg (aref [r1 r2 r3 r4 r5] regnum)))
1077               (apply
1078                'append
1079                (mapcar
1080                 (lambda (bit)
1081                   `((if (,reg & ,(lsh 1 bit))
1082                         (write ?\ )
1083                       (write ?\t))
1084                     (if (r6 == ,(+ (* regnum 28) bit 1))
1085                         (repeat))))
1086                 mel-ccl-28-table))))
1087           '(0 1 2 3 4)))
1088       (repeat)
1089       ))))
1090
1091 )
1092
1093 (define-ccl-program mel-ccl-encode-quoted-printable-crlf-crlf
1094   (mel-ccl-encode-quoted-printable-generic t t))
1095
1096 (define-ccl-program mel-ccl-encode-quoted-printable-crlf-lf
1097   (mel-ccl-encode-quoted-printable-generic t nil))
1098
1099 (define-ccl-program mel-ccl-encode-quoted-printable-lf-crlf
1100   (mel-ccl-encode-quoted-printable-generic nil t))
1101
1102 (define-ccl-program mel-ccl-encode-quoted-printable-lf-lf
1103   (mel-ccl-encode-quoted-printable-generic nil nil))
1104
1105 (define-ccl-program mel-ccl-decode-quoted-printable-crlf-crlf
1106   (mel-ccl-decode-quoted-printable-generic t t))
1107
1108 (define-ccl-program mel-ccl-decode-quoted-printable-crlf-lf
1109   (mel-ccl-decode-quoted-printable-generic t nil))
1110
1111 (define-ccl-program mel-ccl-decode-quoted-printable-lf-crlf
1112   (mel-ccl-decode-quoted-printable-generic nil t))
1113
1114 (define-ccl-program mel-ccl-decode-quoted-printable-lf-lf
1115   (mel-ccl-decode-quoted-printable-generic nil nil))
1116
1117
1118 ;;; @ coding system
1119 ;;;
1120
1121 (make-ccl-coding-system
1122  'mel-ccl-uq-rev ?Q "MIME Q-encoding in unstructured field (reversed)"
1123  'mel-ccl-encode-uq 'mel-ccl-decode-q)
1124
1125 (make-ccl-coding-system
1126  'mel-ccl-cq-rev ?Q "MIME Q-encoding in comment (reversed)"
1127  'mel-ccl-encode-cq 'mel-ccl-decode-q)
1128
1129 (make-ccl-coding-system
1130  'mel-ccl-pq-rev ?Q "MIME Q-encoding in phrase (reversed)"
1131  'mel-ccl-encode-pq 'mel-ccl-decode-q)
1132
1133 (make-ccl-coding-system
1134  'mel-ccl-b-rev ?B "MIME B-encoding (reversed)"
1135  'mel-ccl-encode-b 'mel-ccl-decode-b)
1136
1137 (make-ccl-coding-system
1138  'mel-ccl-quoted-printable-crlf-crlf-rev
1139  ?Q "MIME Quoted-Printable-encoding (reversed)"
1140  'mel-ccl-encode-quoted-printable-crlf-crlf
1141  'mel-ccl-decode-quoted-printable-crlf-crlf)
1142
1143 (make-ccl-coding-system
1144  'mel-ccl-quoted-printable-lf-crlf-rev
1145  ?Q "MIME Quoted-Printable-encoding (LF encoding) (reversed)"
1146  'mel-ccl-encode-quoted-printable-crlf-lf
1147  'mel-ccl-decode-quoted-printable-lf-crlf)
1148
1149 (make-ccl-coding-system
1150  'mel-ccl-quoted-printable-crlf-lf-rev
1151  ?Q "MIME Quoted-Printable-encoding (LF internal) (reversed)"
1152  'mel-ccl-encode-quoted-printable-lf-crlf
1153  'mel-ccl-decode-quoted-printable-crlf-lf)
1154
1155 (make-ccl-coding-system
1156  'mel-ccl-quoted-printable-lf-lf-rev
1157  ?Q "MIME Quoted-Printable-encoding (LF encoding) (LF internal) (reversed)"
1158  'mel-ccl-encode-quoted-printable-lf-lf
1159  'mel-ccl-decode-quoted-printable-lf-lf)
1160
1161 (make-ccl-coding-system
1162  'mel-ccl-base64-crlf-rev
1163  ?B "MIME Base64-encoding (reversed)"
1164  'mel-ccl-encode-base64-crlf-crlf
1165  'mel-ccl-decode-b)
1166
1167 (make-ccl-coding-system
1168  'mel-ccl-base64-lf-rev
1169  ?B "MIME Base64-encoding (LF encoding) (reversed)"
1170  'mel-ccl-encode-base64-crlf-lf
1171  'mel-ccl-decode-b)
1172
1173
1174 ;;; @ B
1175 ;;;
1176
1177 (unless (and (boundp 'ccl-encoder-eof-block-is-broken)
1178              ccl-encoder-eof-block-is-broken)
1179
1180   (defun base64-ccl-encode-string (string)
1181     "Encode STRING with base64 encoding."
1182     (decode-coding-string string 'mel-ccl-base64-lf-rev))
1183
1184   (defun base64-ccl-encode-region (start end)
1185     "Encode region from START to END with base64 encoding."
1186     (interactive "r")
1187     (decode-coding-region start end 'mel-ccl-base64-lf-rev))
1188
1189   (defun base64-ccl-insert-encoded-file (filename)
1190     "Encode contents of file FILENAME to base64, and insert the result."
1191     (interactive (list (read-file-name "Insert encoded file: ")))
1192     (let ((coding-system-for-read 'mel-ccl-base64-lf-rev))
1193       (insert-file-contents filename)))
1194
1195   (mel-define-method-function (mime-encode-string string (nil "base64"))
1196                               'base64-ccl-encode-string)
1197   (mel-define-method-function (mime-encode-region start end (nil "base64"))
1198                               'base64-ccl-encode-region)
1199   (mel-define-method-function
1200    (mime-insert-encoded-file filename (nil "base64"))
1201    'base64-ccl-insert-encoded-file)
1202
1203   (mel-define-method-function (encoded-text-encode-string string (nil "B"))
1204                               'base64-ccl-encode-string)
1205   )
1206
1207 (defun base64-ccl-decode-string (string)
1208   "Decode base64 encoded STRING"
1209   (encode-coding-string string 'mel-ccl-b-rev))
1210
1211 (defun base64-ccl-decode-region (start end)
1212   "Decode base64 encoded the region from START to END."
1213   (interactive "r")
1214   (encode-coding-region start end 'mel-ccl-b-rev))
1215
1216 (defun base64-ccl-write-decoded-region (start end filename)
1217   "Decode the region from START to END and write out to FILENAME."
1218   (interactive
1219     (list (region-beginning) (region-end)
1220           (read-file-name "Write decoded region to file: ")))
1221   (let ((coding-system-for-write 'mel-ccl-b-rev))
1222     (write-region start end filename)))
1223
1224 (mel-define-method-function (mime-decode-string string (nil "base64"))
1225                             'base64-ccl-decode-string)
1226 (mel-define-method-function (mime-decode-region start end (nil "base64"))
1227                             'base64-ccl-decode-region)
1228 (mel-define-method-function
1229  (mime-write-decoded-region start end filename (nil "base64"))
1230  'base64-ccl-write-decoded-region)
1231
1232 (mel-define-method encoded-text-decode-string (string (nil "B"))
1233   (if (and (string-match B-encoded-text-regexp string)
1234            (string= string (match-string 0 string)))
1235       (base64-ccl-decode-string string)
1236     (error "Invalid encoded-text %s" string)))
1237
1238
1239 ;;; @ quoted-printable
1240 ;;;
1241
1242 (unless (and (boundp 'ccl-encoder-eof-block-is-broken)
1243              ccl-encoder-eof-block-is-broken)
1244
1245   (defun quoted-printable-ccl-encode-string (string)
1246     "Encode STRING with quoted-printable encoding."
1247     (decode-coding-string
1248      string
1249      'mel-ccl-quoted-printable-lf-lf-rev))
1250
1251   (defun quoted-printable-ccl-encode-region (start end)
1252     "Encode the region from START to END with quoted-printable encoding."
1253     (interactive "r")
1254     (decode-coding-region start end 'mel-ccl-quoted-printable-lf-lf-rev))
1255
1256   (defun quoted-printable-ccl-insert-encoded-file (filename)
1257     "Encode contents of the file named as FILENAME, and insert it."
1258     (interactive (list (read-file-name "Insert encoded file: ")))
1259     (let ((coding-system-for-read 'mel-ccl-quoted-printable-lf-lf-rev))
1260       (insert-file-contents filename)))
1261
1262   (mel-define-method-function
1263    (mime-encode-string string (nil "quoted-printable"))
1264    'quoted-printable-ccl-encode-string)
1265   (mel-define-method-function
1266    (mime-encode-region start end (nil "quoted-printable"))
1267    'quoted-printable-ccl-encode-region)
1268   (mel-define-method-function
1269    (mime-insert-encoded-file filename (nil "quoted-printable"))
1270    'quoted-printable-ccl-insert-encoded-file)
1271   )
1272
1273 (defun quoted-printable-ccl-decode-string (string)
1274   "Decode quoted-printable encoded STRING."
1275   (encode-coding-string
1276    string
1277    'mel-ccl-quoted-printable-lf-lf-rev))
1278
1279 (defun quoted-printable-ccl-decode-region (start end)
1280   "Decode the region from START to END with quoted-printable
1281 encoding."
1282   (interactive "r")
1283   (encode-coding-region start end 'mel-ccl-quoted-printable-lf-lf-rev))
1284
1285 (defun quoted-printable-ccl-write-decoded-region
1286   (start end filename)
1287   "Decode quoted-printable encoded current region and write out to FILENAME."
1288   (interactive
1289    (list (region-beginning) (region-end)
1290          (read-file-name "Write decoded region to file: ")))
1291   (let ((coding-system-for-write 'mel-ccl-quoted-printable-lf-lf-rev))
1292     (write-region start end filename)))
1293
1294 (mel-define-method-function
1295  (mime-decode-string string (nil "quoted-printable"))
1296  'quoted-printable-ccl-decode-string)
1297 (mel-define-method-function
1298  (mime-decode-region start end (nil "quoted-printable"))
1299  'quoted-printable-ccl-decode-region)
1300 (mel-define-method-function
1301  (mime-write-decoded-region start end filename (nil "quoted-printable"))
1302  'quoted-printable-ccl-write-decoded-region)
1303
1304
1305 ;;; @ Q
1306 ;;;
1307
1308 (defun q-encoding-ccl-encode-string (string &optional mode)
1309   "Encode STRING to Q-encoding of encoded-word, and return the result.
1310 MODE allows `text', `comment', `phrase' or nil.  Default value is
1311 `phrase'."
1312   (decode-coding-string
1313    string
1314    (cond
1315     ((eq mode 'text) 'mel-ccl-uq-rev)
1316     ((eq mode 'comment) 'mel-ccl-cq-rev)
1317     (t 'mel-ccl-pq-rev))))
1318
1319 (defun q-encoding-ccl-decode-string (string)
1320   "Decode Q encoded STRING and return the result."
1321   (encode-coding-string
1322    string
1323    'mel-ccl-uq-rev))
1324
1325 (unless (featurep 'xemacs)
1326   (defun q-encoding-ccl-encoded-length (string &optional mode)
1327     (let ((status [nil nil nil nil nil nil nil nil nil]))
1328       (fillarray status nil)
1329       (ccl-execute-on-string
1330        (cond
1331         ((eq mode 'text) 'mel-ccl-count-uq)
1332         ((eq mode 'comment) 'mel-ccl-count-cq)
1333         (t 'mel-ccl-count-pq))
1334        status
1335        string)
1336       (aref status 0)))
1337   )
1338
1339 (mel-define-method-function (encoded-text-encode-string string (nil "Q"))
1340                             'q-encoding-ccl-encode-string)
1341
1342 (mel-define-method encoded-text-decode-string (string (nil "Q"))
1343   (if (and (string-match Q-encoded-text-regexp string)
1344            (string= string (match-string 0 string)))
1345       (q-encoding-ccl-decode-string string)
1346     (error "Invalid encoded-text %s" string)))
1347
1348
1349 ;;; @ end
1350 ;;;
1351
1352 (provide 'mel-ccl)
1353
1354 ;;; mel-ccl.el ends here