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