mel-q-ccl.el

   1 ;;; mel-q-ccl.el --- Quoted-Printable encoder/decoder using CCL.
   2
   3 ;; Copyright (C) 1998 Tanaka Akira
   4
   5 ;; Author: Tanaka Akira <akr@jaist.ac.jp>
   6 ;; Created: 1998/9/17
   7 ;; Keywords: MIME, Quoted-Printable, Q-encoding
   8
   9 ;; This file is part of FLIM (Faithful Library about Internet Message).
  10
  11 ;; This program is free software; you can redistribute it and/or
  12 ;; modify it under the terms of the GNU General Public License as
  13 ;; published by the Free Software Foundation; either version 2, or (at
  14 ;; your option) any later version.
  15
  16 ;; This program is distributed in the hope that it will be useful, but
  17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19 ;; General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with this program; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Code:
  27
  28 (require 'ccl)
  29 (require 'pccl)
  30 (require 'mime-def)
  31
  32
  33 ;;; @ constants
  34 ;;;
  35
  36 (eval-when-compile
  37
  38 (defconst mel-ccl-16-table
  39   '(  0   1   2   3   4   5   6   7   8   9  10  11  12  13  14  15))
  40
  41 (defconst mel-ccl-28-table
  42   '(  0   1   2   3   4   5   6   7   8   9  10  11  12  13  14  15
  43      16  17  18  19  20  21  22  23  24  25  26  27))
  44
  45 (defconst mel-ccl-256-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  28  29  30  31
  48      32  33  34  35  36  37  38  39  40  41  42  43  44  45  46  47
  49      48  49  50  51  52  53  54  55  56  57  58  59  60  61  62  63
  50      64  65  66  67  68  69  70  71  72  73  74  75  76  77  78  79
  51      80  81  82  83  84  85  86  87  88  89  90  91  92  93  94  95
  52      96  97  98  99 100 101 102 103 104 105 106 107 108 109 110 111
  53     112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127
  54     128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143
  55     144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159
  56     160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175
  57     176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191
  58     192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207
  59     208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223
  60     224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239
  61     240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255))
  62
  63 (defconst mel-ccl-256-to-16-table
  64   '(nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
  65     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
  66     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
  67       0   1   2   3   4   5   6   7   8   9 nil nil nil nil nil nil
  68     nil  10  11  12  13  14  15 nil nil nil nil nil nil nil nil nil
  69     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
  70     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
  71     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
  72     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
  73     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
  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     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
  78     nil nil nil nil nil nil nil 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
  81 (defconst mel-ccl-16-to-256-table
  82   (mapcar 'char-int "0123456789ABCDEF"))
  83
  84 (defconst mel-ccl-high-table
  85   (vconcat
  86    (mapcar
  87     (lambda (v) (nth (lsh v -4) mel-ccl-16-to-256-table))
  88     mel-ccl-256-table)))
  89
  90 (defconst mel-ccl-low-table
  91   (vconcat
  92    (mapcar
  93     (lambda (v) (nth (logand v 15) mel-ccl-16-to-256-table))
  94     mel-ccl-256-table)))
  95
  96 (defconst mel-ccl-u-raw
  97   (mapcar
  98    'char-int
  99    "0123456789\
 100 ABCDEFGHIJKLMNOPQRSTUVWXYZ\
 101 abcdefghijklmnopqrstuvwxyz\
 102 !@#$%&'()*+,-./:;<>@[\\]^`{|}~"))
 103
 104 (defconst mel-ccl-c-raw
 105   (mapcar
 106    'char-int
 107    "0123456789\
 108 ABCDEFGHIJKLMNOPQRSTUVWXYZ\
 109 abcdefghijklmnopqrstuvwxyz\
 110 !@#$%&'*+,-./:;<>@[]^`{|}~"))
 111
 112 (defconst mel-ccl-p-raw
 113   (mapcar
 114    'char-int
 115    "0123456789\
 116 ABCDEFGHIJKLMNOPQRSTUVWXYZ\
 117 abcdefghijklmnopqrstuvwxyz\
 118 !*+-/"))
 119
 120 (defconst mel-ccl-qp-table
 121   [enc enc enc enc enc enc enc enc enc wsp lf  enc enc cr  enc enc
 122    enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc
 123    wsp raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw
 124    raw raw raw raw raw raw raw raw raw raw raw raw raw enc raw raw
 125    raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw
 126    raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw
 127    raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw
 128    raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw enc
 129    enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc
 130    enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc
 131    enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc
 132    enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc
 133    enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc
 134    enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc
 135    enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc
 136    enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc])
 137
 138 )
 139
 140
 141 ;;; @ CCL programs
 142 ;;;
 143
 144 ;;; Q
 145
 146 (define-ccl-program mel-ccl-decode-q
 147   `(1
 148     ((loop
 149       (read-branch
 150        r0
 151        ,@(mapcar
 152           (lambda (r0)
 153             (cond
 154              ((= r0 (char-int ?_))
 155               `(write-repeat ? ))
 156              ((= r0 (char-int ?=))
 157               `((loop
 158                  (read-branch
 159                   r1
 160                   ,@(mapcar
 161                      (lambda (v)
 162                        (if (integerp v)
 163                            `((r0 = ,v) (break))
 164                          '(repeat)))
 165                      mel-ccl-256-to-16-table)))
 166                 (loop
 167                  (read-branch
 168                   r1
 169                   ,@(mapcar
 170                      (lambda (v)
 171                        (if (integerp v)
 172                            `((write r0 ,(vconcat
 173                                          (mapcar
 174                                           (lambda (r0)
 175                                             (logior (lsh r0 4) v))
 176                                           mel-ccl-16-table)))
 177                              (break))
 178                          '(repeat)))
 179                      mel-ccl-256-to-16-table)))
 180                 (repeat)))
 181              (t
 182               `(write-repeat ,r0))))
 183           mel-ccl-256-table))))))
 184
 185 (eval-when-compile
 186
 187 (defun mel-ccl-encode-q-generic (raw)
 188   `(3
 189     (loop
 190      (loop
 191       (read-branch
 192        r0
 193        ,@(mapcar
 194           (lambda (r0)
 195             (cond
 196              ((= r0 32) `(write-repeat ?_))
 197              ((member r0 raw) `(write-repeat ,r0))
 198              (t '(break))))
 199           mel-ccl-256-table)))
 200      (write ?=)
 201      (write r0 ,mel-ccl-high-table)
 202      (write r0 ,mel-ccl-low-table)
 203      (repeat))))
 204
 205 ;; On xemacs, generated program counts iso-8859-1 8bit character as 6bytes.
 206 (defun mel-ccl-count-q-length (raw)
 207   `(0
 208     ((r0 = 0)
 209      (loop
 210       (read-branch
 211        r1
 212        ,@(mapcar
 213           (lambda (r1)
 214             (if (or (= r1 32) (member r1 raw))
 215                 '((r0 += 1) (repeat))
 216               '((r0 += 3) (repeat))))
 217           mel-ccl-256-table))))))
 218
 219 )
 220
 221 (define-ccl-program mel-ccl-encode-uq
 222   (mel-ccl-encode-q-generic mel-ccl-u-raw))
 223 (define-ccl-program mel-ccl-encode-cq
 224   (mel-ccl-encode-q-generic mel-ccl-c-raw))
 225 (define-ccl-program mel-ccl-encode-pq
 226   (mel-ccl-encode-q-generic mel-ccl-p-raw))
 227
 228 (define-ccl-program mel-ccl-count-uq
 229   (mel-ccl-count-q-length mel-ccl-u-raw))
 230 (define-ccl-program mel-ccl-count-cq
 231   (mel-ccl-count-q-length mel-ccl-c-raw))
 232 (define-ccl-program mel-ccl-count-pq
 233   (mel-ccl-count-q-length mel-ccl-p-raw))
 234
 235 ;; Quoted-Printable
 236
 237 (eval-when-compile
 238
 239 (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)
 240   (if input-crlf
 241       `((,eof-reg = ,cr-eof) (read-if (,reg == ?\r)
 242         ((,eof-reg = ,lf-eof) (read-if (,reg == ?\n)
 243          ,succ
 244          ,fail-lf))
 245         ,fail-cr))
 246     `((,eof-reg = ,crlf-eof) (read-if (,reg == ?\n)
 247       ,succ
 248       ,fail-crlf))))
 249
 250 )
 251
 252 (eval-when-compile
 253
 254 ;; Generated CCL program works not properly on 20.2 because CCL_EOF_BLOCK
 255 ;; is not executed.
 256 (defun mel-ccl-encode-quoted-printable-generic (input-crlf output-crlf)
 257   `(4
 258     ((r6 = 0)                           ; column
 259      (r5 = 0)                           ; previous character is white space
 260      (r4 = 0)
 261      (read r0)
 262      (loop                              ; r6 <= 75
 263       (loop
 264        (loop
 265         (branch
 266          r0
 267          ,@(mapcar
 268             (lambda (r0)
 269               (let ((tmp (aref mel-ccl-qp-table r0)))
 270                 (cond
 271                  ((eq r0 (char-int ?F))
 272                   `(if (r6 == 0)
 273                        ((r4 = 15) (read-if (r0 == ?r)
 274                         ((r4 = 16) (read-if (r0 == ?o)
 275                          ((r4 = 17) (read-if (r0 == ?m)
 276                           ((r4 = 18) (read-if (r0 == ? )
 277                            ((r6 = 7)
 278                             (r5 = 1)
 279                             (write "=46rom ")
 280                             (r4 = 19)
 281                             (read r0)
 282                             (repeat))
 283                            ((r6 = 4)
 284                             (write-repeat "From"))))
 285                           ((r6 = 3)
 286                            (write-repeat "Fro"))))
 287                          ((r6 = 2)
 288                           (write-repeat "Fr"))))
 289                         ((r6 = 1)
 290                          (write-repeat "F"))))
 291                      ((r3 = 0) (break)) ; RAW
 292                      ))
 293                  ((eq r0 (char-int ?.))
 294                   `(if (r6 == 0)
 295                        ,(mel-ccl-try-to-read-crlf
 296                          input-crlf
 297                          'r0 'r4 20 21 22
 298                          `((write ,(if output-crlf "=2E\r\n" "=2E\n"))
 299                            (r4 = 23)
 300                            (read r0)
 301                            (repeat))
 302                          '((r6 = 1)
 303                            (write-repeat "."))
 304                          '((r6 = 4)
 305                            (write-repeat ".=0D"))
 306                          '((r6 = 1)
 307                            (write-repeat ".")))
 308                      ((r3 = 0) (break)) ; RAW
 309                      ))
 310                  ((eq tmp 'raw) '((r3 = 0) (break))) ; RAW
 311                  ((eq tmp 'enc) '((r3 = 1) (break))) ; ENC
 312                  ((eq tmp 'wsp) '((r3 = 2) (break))) ; WSP
 313                  ((eq tmp 'cr) (if input-crlf
 314                                    '((r3 = 3) (break)) ; CR
 315                                  '((r3 = 1) (break)))) ; ENC
 316                  ((eq tmp 'lf) (if input-crlf
 317                                    '((r3 = 1) (break)) ; ENC
 318                                  '((r3 = 3) (break)))) ; CRLF
 319                  )))
 320             mel-ccl-256-table)))
 321        (branch
 322         r3
 323         ;; r0:r3=RAW
 324         (if (r6 < 75)
 325             ((r6 += 1)
 326              (r5 = 0)
 327              (r4 = 1)
 328              (write-read-repeat r0))
 329           (break))
 330         ;; r0:r3=ENC
 331         ((r5 = 0)
 332          (if (r6 < 73)
 333              ((r6 += 3)
 334               (write "=")
 335               (write r0 ,mel-ccl-high-table)
 336               (r4 = 2)
 337               (write-read-repeat r0 ,mel-ccl-low-table))
 338            (if (r6 > 73)
 339                ((r6 = 3)
 340                 (write ,(if output-crlf "=\r\n=" "=\n="))
 341                 (write r0 ,mel-ccl-high-table)
 342                 (r4 = 3)
 343                 (write-read-repeat r0 ,mel-ccl-low-table))
 344              (break))))
 345         ;; r0:r3=WSP
 346         ((r5 = 1)
 347          (if (r6 < 75)
 348              ((r6 += 1)
 349               (r4 = 4)
 350               (write-read-repeat r0))
 351            ((r6 = 1)
 352             (write ,(if output-crlf "=\r\n" "=\n"))
 353             (r4 = 5)
 354             (write-read-repeat r0))))
 355         ;; r0:r3=CR/CRLF
 356         ,(if input-crlf
 357              ;; r0:r3=CR
 358              `((if ((r6 > 73) & r5)
 359                    ((r6 = 0)
 360                     (r5 = 0)
 361                     (write ,(if output-crlf "=\r\n" "=\n"))))
 362                (break))
 363            ;; r0:r3=CRLF
 364            `(if r5
 365                 ;; WSP ; r0:r3=CRLF
 366                 ((r5 = 0)
 367                  (r6 = 0)
 368                  (write ,(if output-crlf "=\r\n" "=\n"))
 369                  ,@(if output-crlf '((write ?\r)) '())
 370                  (r4 = 0)
 371                  (write-read-repeat r0))
 372               ;; noWSP ; r0:r3=CRLF
 373               ((r5 = 0)
 374                (r6 = 0)
 375                ,@(if output-crlf '((write ?\r)) '())
 376                (r4 = 0)
 377                (write-read-repeat r0)))
 378            )))
 379       ;; r0:r3={RAW,ENC,CR}
 380       (loop
 381        ,(funcall
 382          (lambda (after-cr after-raw-enc)
 383            (if input-crlf
 384                `(if (r0 == ?\r)
 385                     ,after-cr
 386                   ,after-raw-enc)
 387              after-raw-enc))
 388          ;; r0=\r:r3=CR
 389          `((r4 = 6)
 390            (read r0)
 391            ;; CR:r3=CR r0
 392            (if (r0 == ?\n)
 393                ;; CR:r3=CR r0=LF
 394                (if r5
 395                    ;; r5=WSP ; CR:r3=CR r0=LF
 396                    ((r6 = 0)
 397                     (r5 = 0)
 398                     (write ,(if output-crlf "=\r\n\r\n" "=\n\n"))
 399                     (r4 = 7)
 400                     (read r0)
 401                     (break))
 402                  ;; r5=noWSP ; CR:r3=CR r0=LF
 403                  ((r6 = 0)
 404                   (r5 = 0)
 405                   (write ,(if output-crlf "\r\n" "\n"))
 406                   (r4 = 8)
 407                   (read r0)
 408                   (break)))
 409              ;; CR:r3=CR r0=noLF
 410              (if (r6 < 73)
 411                  ((r6 += 3)
 412                   (r5 = 0)
 413                   (write "=0D")
 414                   (break))
 415                (if (r6 == 73)
 416                    (if (r0 == ?\r)
 417                        ;; CR:r3=CR r0=CR
 418                        ((r4 = 9)
 419                         (read r0)
 420                         ;; CR:r3=CR CR r0
 421                         (if (r0 == ?\n)
 422                             ;; CR:r3=CR CR LF
 423                             ((r6 = 0)
 424                              (r5 = 0)
 425                              (write ,(if output-crlf "=0D\r\n" "=0D\n"))
 426                              (r4 = 10)
 427                              (read r0)
 428                              (break))
 429                           ;; CR:r3=CR CR noLF
 430                           ((r6 = 6)
 431                            (r5 = 0)
 432                            (write ,(if output-crlf "=\r\n=0D=0D" "=\n=0D=0D"))
 433                            (break))))
 434                      ;; CR:r3=CR r0=noLFnorCR
 435                      ((r6 = 3)
 436                       (r5 = 0)
 437                       (write ,(if output-crlf "=\r\n=0D" "=\n=0D"))
 438                       (break)))
 439                  ((r6 = 3)
 440                   (r5 = 0)
 441                   (write ,(if output-crlf "=\r\n=0D" "=\n=0D"))
 442                   (break))))))
 443          (funcall
 444           (lambda (after-newline after-cr-nolf after-nonewline)
 445             (if input-crlf
 446                 ;; r0:r3={RAW,ENC}
 447                 `((r4 = 11)
 448                   (read r1)
 449                   ;; r0:r3={RAW,ENC} r1
 450                   (if (r1 == ?\r)
 451                       ;; r0:r3={RAW,ENC} r1=CR
 452                       ((r4 = 12)
 453                        (read r1)
 454                        ;; r0:r3={RAW,ENC} CR r1
 455                        (if (r1 == ?\n)
 456                            ;; r0:r3=RAW CR r1=LF
 457                            ,after-newline
 458                          ;; r0:r3=RAW CR r1=noLF
 459                          ,after-cr-nolf))
 460                     ;; r0:r3={RAW,ENC} r1:noCR
 461                     ,after-nonewline))
 462               ;; r0:r3={RAW,ENC}
 463               `((r4 = 11)
 464                 (read r1)
 465                 ;; r0:r3={RAW,ENC} r1
 466                 (if (r1 == ?\n)
 467                     ;; r0:r3={RAW,ENC} r1=CRLF
 468                     ,after-newline
 469                   ;; r0:r3={RAW,ENC} r1:noCRLF
 470                   ,after-nonewline))))
 471           ;; r0:r3={RAW,ENC} CR r1=LF
 472           ;; r0:r3={RAW,ENC} r1=CRLF
 473           `((r6 = 0)
 474             (r5 = 0)
 475             (branch
 476              r3
 477              ;; r0:r3=RAW CR r1=LF
 478              ;; r0:r3=RAW r1=CRLF
 479              ((write r0)
 480               (write ,(if output-crlf "\r\n" "\n"))
 481               (r4 = 13)
 482               (read r0)
 483               (break))
 484              ;; r0:r3=ENC CR r1=LF
 485              ;; r0:r3=ENC r1=CRLF
 486              ((write ?=)
 487               (write r0 ,mel-ccl-high-table)
 488               (write r0 ,mel-ccl-low-table)
 489               (write ,(if output-crlf "\r\n" "\n"))
 490               (r4 = 14)
 491               (read r0)
 492               (break))))
 493           ;; r0:r3={RAW,ENC} CR r1=noLF
 494           `((branch
 495              r3
 496              ;; r0:r3=RAW CR r1:noLF
 497              ((r6 = 4)
 498               (r5 = 0)
 499               (write ,(if output-crlf "=\r\n" "=\n"))
 500               (write r0)
 501               (write "=0D")
 502               (r0 = (r1 + 0)) ; "+ 0" is workaround for mule 2.3@19.34.
 503               (break))
 504              ;; r0:r3=ENC CR r1:noLF
 505              ((r6 = 6)
 506               (r5 = 0)
 507               (write ,(if output-crlf "=\r\n=" "=\n="))
 508               (write r0 ,mel-ccl-high-table)
 509               (write r0 ,mel-ccl-low-table)
 510               (write "=0D")
 511               (r0 = (r1 + 0))
 512               (break))))
 513           ;; r0:r3={RAW,ENC} r1:noCR
 514           ;; r0:r3={RAW,ENC} r1:noCRLF
 515           `((branch
 516              r3
 517              ;; r0:r3=RAW r1:noCR
 518              ;; r0:r3=RAW r1:noCRLF
 519              ((r6 = 1)
 520               (r5 = 0)
 521               (write ,(if output-crlf "=\r\n" "=\n"))
 522               (write r0)
 523               (r0 = (r1 + 0))
 524               (break))
 525              ;; r0:r3=ENC r1:noCR
 526              ;; r0:r3=ENC r1:noCRLF
 527              ((r6 = 3)
 528               (r5 = 0)
 529               (write ,(if output-crlf "=\r\n=" "=\n="))
 530               (write r0 ,mel-ccl-high-table)
 531               (write r0 ,mel-ccl-low-table)
 532               (r0 = (r1 + 0))
 533               (break)))))))
 534       (repeat)))
 535     ;; EOF
 536     (                                   ;(write "[EOF:") (write r4 ,mel-ccl-high-table) (write r4 ,mel-ccl-low-table) (write "]")
 537      (branch
 538       r4
 539       ;; 0: (start) ;
 540       (end)
 541       ;; 1: RAW ;
 542       (end)
 543       ;; 2: r0:r3=ENC ;
 544       (end)
 545       ;; 3: SOFTBREAK r0:r3=ENC ;
 546       (end)
 547       ;; 4: r0:r3=WSP ;
 548       ((write ,(if output-crlf "=\r\n" "=\n")) (end))
 549       ;; 5: SOFTBREAK r0:r3=WSP ;
 550       ((write ,(if output-crlf "=\r\n" "=\n")) (end))
 551       ;; 6: ; r0=\r:r3=CR
 552       (if (r6 <= 73)
 553           ((write "=0D") (end))
 554         ((write ,(if output-crlf "=\r\n=0D" "=\n=0D")) (end)))
 555       ;; 7: r5=WSP SOFTBREAK CR:r3=CR r0=LF ;
 556       (end)
 557       ;; 8: r5=noWSP CR:r3=CR r0=LF ;
 558       (end)
 559       ;; 9: (r6=73) ; CR:r3=CR r0=CR
 560       ((write ,(if output-crlf "=\r\n=0D=0D" "=\n=0D=0D")) (end))
 561       ;; 10: (r6=73) CR:r3=CR CR LF ;
 562       (end)
 563       ;; 11: ; r0:r3={RAW,ENC}
 564       (branch
 565        r3
 566        ((write r0) (end))
 567        ((write "=")
 568         (write r0 ,mel-ccl-high-table)
 569         (write r0 ,mel-ccl-low-table)
 570         (end)))
 571       ;; 12: ; r0:r3={RAW,ENC} r1=CR
 572       (branch
 573        r3
 574        ;; ; r0:r3=RAW r1=CR
 575        ((write ,(if output-crlf "=\r\n" "=\n"))
 576         (write r0)
 577         (write "=0D")
 578         (end))
 579        ;; ; r0:r3=ENC r1=CR
 580        ((write ,(if output-crlf "=\r\n=" "=\n="))
 581         (write r0 ,mel-ccl-high-table)
 582         (write r0 ,mel-ccl-low-table)
 583         (write "=0D")
 584         (end)))
 585       ;; 13: r0:r3=RAW CR LF ;
 586       ;; 13: r0:r3=RAW CRLF ;
 587       (end)
 588       ;; 14: r0:r3=ENC CR LF ;
 589       ;; 14: r0:r3=ENC CRLF ;
 590       (end)
 591       ;; 15: r6=0 ; "F"
 592       ((write "F") (end))
 593       ;; 16: r6=0 ; "Fr"
 594       ((write "Fr") (end))
 595       ;; 17: r6=0 ; "Fro"
 596       ((write "Fro") (end))
 597       ;; 18: r6=0 ; "From"
 598       ((write "From") (end))
 599       ;; 19: r6=0 "From " ;
 600       (end)
 601       ;; 20: r6=0 ; "."
 602       ((write ".") (end))
 603       ;; 21: r6=0 ; ".\r"
 604       ((write ".=0D") (end))
 605       ;; 22: r6=0 ; "."
 606       ((write ".") (end))
 607       ;; 23: r6=0 ".\r\n" ;
 608       (end)
 609       ))
 610     ))
 611
 612 (defun mel-ccl-decode-quoted-printable-generic (input-crlf output-crlf)
 613   `(1
 614     ((read r0)
 615      (loop
 616       (branch
 617        r0
 618        ,@(mapcar
 619           (lambda (r0)
 620             (let ((tmp (aref mel-ccl-qp-table r0)))
 621               (cond
 622                ((eq tmp 'raw) `(write-read-repeat r0))
 623                ((eq tmp 'wsp) (if (eq r0 (char-int ? ))
 624                                   `(r1 = 1)
 625                                 `(r1 = 0)))
 626                ((eq tmp 'cr)
 627                 (if input-crlf
 628                     ;; r0='\r'
 629                     `((read r0)
 630                       ;; '\r' r0
 631                       (if (r0 == ?\n)
 632                           ;; '\r' r0='\n'
 633                           ;; hard line break found.
 634                           ,(if output-crlf
 635                                '((write ?\r)
 636                                  (write-read-repeat r0))
 637                              '(write-read-repeat r0))
 638                         ;; '\r' r0:[^\n]
 639                         ;; invalid control character (bare CR) found.
 640                         ;; -> ignore it and rescan from r0.
 641                         (repeat)))
 642                   ;; r0='\r'
 643                   ;; invalid character (bare CR) found.
 644                   ;; -> ignore.
 645                   `((read r0)
 646                     (repeat))))
 647                ((eq tmp 'lf)
 648                 (if input-crlf
 649                     ;; r0='\n'
 650                     ;; invalid character (bare LF) found.
 651                     ;; -> ignore.
 652                     `((read r0)
 653                       (repeat))
 654                   ;; r0='\r\n'
 655                   ;; hard line break found.
 656                   (if output-crlf
 657                       '((write ?\r)
 658                         (write-read-repeat r0))
 659                     '(write-read-repeat r0))))
 660                ((eq r0 (char-int ?=))
 661                 ;; r0='='
 662                 `((read r0)
 663                   ;; '=' r0
 664                   (r1 = (r0 == ?\t))
 665                   (if ((r0 == ? ) | r1)
 666                       ;; '=' r0:[\t ]
 667                       ;; Skip transport-padding.
 668                       ;; It should check CR LF after
 669                       ;; transport-padding.
 670                       (loop
 671                        (read-if (r0 == ?\t)
 672                                 (repeat)
 673                                 (if (r0 == ? )
 674                                     (repeat)
 675                                   (break)))))
 676                   ;; '=' [\t ]* r0:[^\t ]
 677                   (branch
 678                    r0
 679                    ,@(mapcar
 680                       (lambda (r0)
 681                         (cond
 682                          ((eq r0 (char-int ?\r))
 683                           (if input-crlf
 684                               ;; '=' [\t ]* r0='\r'
 685                               `((read r0)
 686                                 ;; '=' [\t ]* '\r' r0
 687                                 (if (r0 == ?\n)
 688                                     ;; '=' [\t ]* '\r' r0='\n'
 689                                     ;; soft line break found.
 690                                     ((read r0)
 691                                      (repeat))
 692                                   ;; '=' [\t ]* '\r' r0:[^\n]
 693                                   ;; invalid input ->
 694                                   ;; output "=" and rescan from r0.
 695                                   ((write "=")
 696                                    (repeat))))
 697                             ;; '=' [\t ]* r0='\r'
 698                             ;; invalid input (bare CR found) ->
 699                             ;; output "=" and rescan from next.
 700                             `((write ?=)
 701                               (read r0)
 702                               (repeat))))
 703                          ((eq r0 (char-int ?\n))
 704                           (if input-crlf
 705                               ;; '=' [\t ]* r0='\n'
 706                               ;; invalid input (bare LF found) ->
 707                               ;; output "=" and rescan from next.
 708                               `((write ?=)
 709                                 (read r0)
 710                                 (repeat))
 711                             ;; '=' [\t ]* r0='\r\n'
 712                             ;; soft line break found.
 713                             `((read r0)
 714                               (repeat))))
 715                          ((setq tmp (nth r0 mel-ccl-256-to-16-table))
 716                           ;; '=' [\t ]* r0:[0-9A-F]
 717                           ;; upper nibble of hexadecimal digit found.
 718                           `((r1 = (r0 + 0))
 719                             (r0 = ,tmp)))
 720                          (t
 721                           ;; '=' [\t ]* r0:[^\r0-9A-F]
 722                           ;; invalid input ->
 723                           ;; output "=" and rescan from r0.
 724                           `((write ?=)
 725                             (repeat)))))
 726                       mel-ccl-256-table))
 727                   ;; '=' [\t ]* r1:r0:[0-9A-F]
 728                   (read-branch
 729                    r2
 730                    ,@(mapcar
 731                       (lambda (r2)
 732                         (if (setq tmp (nth r2 mel-ccl-256-to-16-table))
 733                             ;; '=' [\t ]* r1:r0:[0-9A-F] r2:[0-9A-F]
 734                             `(write-read-repeat
 735                               r0
 736                               ,(vconcat
 737                                 (mapcar
 738                                  (lambda (r0)
 739                                    (logior (lsh r0 4) tmp))
 740                                  mel-ccl-16-table)))
 741                           ;; '=' [\t ]* r1:r0:[0-9A-F] r2:[^0-9A-F]
 742                           ;; invalid input
 743                           `(r3 = 0)     ; nop
 744                           ))
 745                       mel-ccl-256-table))
 746                   ;; '=' [\t ]* r1:r0:[0-9A-F] r2:[^0-9A-F]
 747                   ;; invalid input ->
 748                   ;; output "=" with hex digit and rescan from r2.
 749                   (write ?=)
 750                   (r0 = (r2 + 0))
 751                   (write-repeat r1)))
 752                (t
 753                 ;; r0:[^\t\r -~]
 754                 ;; invalid character found.
 755                 ;; -> ignore.
 756                 `((read r0)
 757                   (repeat))))))
 758           mel-ccl-256-table))
 759       ;; r1[0]:[\t ]
 760       (loop
 761        ,@(apply
 762           'append
 763           (mapcar
 764            (lambda (regnum)
 765              (let ((reg (aref [r1 r2 r3 r4 r5] regnum)))
 766                (apply
 767                 'append
 768                 (mapcar
 769                  (lambda (bit)
 770                    (if (= bit 0)
 771                        (if (= regnum 0)
 772                            nil
 773                          `((read r0)
 774                            (if (r0 == ?\t)
 775                                (,reg = 0)
 776                              (if (r0 == ?\ )
 777                                  (,reg = 1)
 778                                ((r6 = ,(+ (* regnum 28) bit))
 779                                 (break))))))
 780                      `((read r0)
 781                        (if (r0 == ?\ )
 782                            (,reg |= ,(lsh 1 bit))
 783                          (if (r0 != ?\t)
 784                              ((r6 = ,(+ (* regnum 28) bit))
 785                               (break)))))))
 786                  mel-ccl-28-table))))
 787            '(0 1 2 3 4)))
 788        ;; white space buffer exhaust.
 789        ;; error: line length limit (76bytes) violation.
 790        ;; -> ignore these white spaces.
 791        (repeat))
 792       ,(if input-crlf
 793            `(if (r0 == ?\r)
 794                 ((read r0)
 795                  (if (r0 == ?\n)
 796                      ;; trailing white spaces found.
 797                      ;; -> ignore these white spacs.
 798                      ((write ,(if output-crlf "\r\n" "\n"))
 799                       (read r0)
 800                       (repeat))
 801                    ;; [\t ]* \r r0:[^\n]
 802                    ;; error: bare CR found.
 803                    ;; -> output white spaces and ignore bare CR.
 804                    ))
 805               ;; [\t ]* r0:[^\r]
 806               ;; middle white spaces found.
 807               )
 808          `(if (r0 == ?\n)
 809               ;; trailing white spaces found.
 810               ;; -> ignore these white spacs.
 811               ((write ,(if output-crlf "\r\n" "\n"))
 812                (read r0)
 813                (repeat))
 814             ;; [\t ]* r0:[^\n]
 815             ;; middle white spaces found.
 816             ))
 817       ,@(apply
 818          'append
 819          (mapcar
 820           (lambda (regnum)
 821             (let ((reg (aref [r1 r2 r3 r4 r5] regnum)))
 822               (apply
 823                'append
 824                (mapcar
 825                 (lambda (bit)
 826                   `((if (,reg & ,(lsh 1 bit))
 827                         (write ?\ )
 828                       (write ?\t))
 829                     (if (r6 == ,(+ (* regnum 28) bit 1))
 830                         (repeat))))
 831                 mel-ccl-28-table))))
 832           '(0 1 2 3 4)))
 833       (repeat)
 834       ))))
 835
 836 )
 837
 838 (define-ccl-program mel-ccl-encode-quoted-printable-crlf-crlf
 839   (mel-ccl-encode-quoted-printable-generic t t))
 840
 841 (define-ccl-program mel-ccl-encode-quoted-printable-crlf-lf
 842   (mel-ccl-encode-quoted-printable-generic t nil))
 843
 844 (define-ccl-program mel-ccl-encode-quoted-printable-lf-crlf
 845   (mel-ccl-encode-quoted-printable-generic nil t))
 846
 847 (define-ccl-program mel-ccl-encode-quoted-printable-lf-lf
 848   (mel-ccl-encode-quoted-printable-generic nil nil))
 849
 850 (define-ccl-program mel-ccl-decode-quoted-printable-crlf-crlf
 851   (mel-ccl-decode-quoted-printable-generic t t))
 852
 853 (define-ccl-program mel-ccl-decode-quoted-printable-crlf-lf
 854   (mel-ccl-decode-quoted-printable-generic t nil))
 855
 856 (define-ccl-program mel-ccl-decode-quoted-printable-lf-crlf
 857   (mel-ccl-decode-quoted-printable-generic nil t))
 858
 859 (define-ccl-program mel-ccl-decode-quoted-printable-lf-lf
 860   (mel-ccl-decode-quoted-printable-generic nil nil))
 861
 862
 863 ;;; @ coding system
 864 ;;;
 865
 866 (make-ccl-coding-system
 867  'mel-ccl-uq-rev ?Q "MIME Q-encoding in unstructured field (reversed)"
 868  'mel-ccl-encode-uq 'mel-ccl-decode-q)
 869
 870 (make-ccl-coding-system
 871  'mel-ccl-cq-rev ?Q "MIME Q-encoding in comment (reversed)"
 872  'mel-ccl-encode-cq 'mel-ccl-decode-q)
 873
 874 (make-ccl-coding-system
 875  'mel-ccl-pq-rev ?Q "MIME Q-encoding in phrase (reversed)"
 876  'mel-ccl-encode-pq 'mel-ccl-decode-q)
 877
 878 (make-ccl-coding-system
 879  'mel-ccl-quoted-printable-crlf-crlf-rev
 880  ?Q "MIME Quoted-Printable-encoding (reversed)"
 881  'mel-ccl-encode-quoted-printable-crlf-crlf
 882  'mel-ccl-decode-quoted-printable-crlf-crlf)
 883
 884 (make-ccl-coding-system
 885  'mel-ccl-quoted-printable-lf-crlf-rev
 886  ?Q "MIME Quoted-Printable-encoding (LF encoding) (reversed)"
 887  'mel-ccl-encode-quoted-printable-crlf-lf
 888  'mel-ccl-decode-quoted-printable-lf-crlf)
 889
 890 (make-ccl-coding-system
 891  'mel-ccl-quoted-printable-crlf-lf-rev
 892  ?Q "MIME Quoted-Printable-encoding (LF internal) (reversed)"
 893  'mel-ccl-encode-quoted-printable-lf-crlf
 894  'mel-ccl-decode-quoted-printable-crlf-lf)
 895
 896 (make-ccl-coding-system
 897  'mel-ccl-quoted-printable-lf-lf-rev
 898  ?Q "MIME Quoted-Printable-encoding (LF encoding) (LF internal) (reversed)"
 899  'mel-ccl-encode-quoted-printable-lf-lf
 900  'mel-ccl-decode-quoted-printable-lf-lf)
 901
 902
 903 ;;; @ quoted-printable
 904 ;;;
 905
 906 (check-broken-facility ccl-execute-eof-block-on-decoding-some)
 907
 908 (unless-broken ccl-execute-eof-block-on-decoding-some
 909
 910   (defun quoted-printable-ccl-encode-string (string)
 911     "Encode STRING with quoted-printable encoding."
 912     (decode-coding-string
 913      string
 914      'mel-ccl-quoted-printable-lf-lf-rev))
 915
 916   (defun quoted-printable-ccl-encode-region (start end)
 917     "Encode the region from START to END with quoted-printable encoding."
 918     (interactive "*r")
 919     (decode-coding-region start end 'mel-ccl-quoted-printable-lf-lf-rev))
 920
 921   (defun quoted-printable-ccl-insert-encoded-file (filename)
 922     "Encode contents of the file named as FILENAME, and insert it."
 923     (interactive "*fInsert encoded file: ")
 924     (insert-file-contents-as-coding-system
 925      'mel-ccl-quoted-printable-lf-lf-rev filename))
 926
 927   (mel-define-method-function
 928    (mime-encode-string string (nil "quoted-printable"))
 929    'quoted-printable-ccl-encode-string)
 930   (mel-define-method-function
 931    (mime-encode-region start end (nil "quoted-printable"))
 932    'quoted-printable-ccl-encode-region)
 933   (mel-define-method-function
 934    (mime-insert-encoded-file filename (nil "quoted-printable"))
 935    'quoted-printable-ccl-insert-encoded-file)
 936   )
 937
 938 (defun quoted-printable-ccl-decode-string (string)
 939   "Decode quoted-printable encoded STRING."
 940   (encode-coding-string
 941    string
 942    'mel-ccl-quoted-printable-lf-lf-rev))
 943
 944 (defun quoted-printable-ccl-decode-region (start end)
 945   "Decode the region from START to END with quoted-printable
 946 encoding."
 947   (interactive "*r")
 948   (encode-coding-region start end 'mel-ccl-quoted-printable-lf-lf-rev))
 949
 950 (defun quoted-printable-ccl-write-decoded-region (start end filename)
 951   "Decode quoted-printable encoded current region and write out to FILENAME."
 952   (interactive "*r\nFWrite decoded region to file: ")
 953   (write-region-as-coding-system 'mel-ccl-quoted-printable-lf-lf-rev
 954                                  start end filename))
 955
 956 (mel-define-method-function
 957  (mime-decode-string string (nil "quoted-printable"))
 958  'quoted-printable-ccl-decode-string)
 959 (mel-define-method-function
 960  (mime-decode-region start end (nil "quoted-printable"))
 961  'quoted-printable-ccl-decode-region)
 962 (mel-define-method-function
 963  (mime-write-decoded-region start end filename (nil "quoted-printable"))
 964  'quoted-printable-ccl-write-decoded-region)
 965
 966
 967 ;;; @ Q
 968 ;;;
 969
 970 (defun q-encoding-ccl-encode-string (string &optional mode)
 971   "Encode STRING to Q-encoding of encoded-word, and return the result.
 972 MODE allows `text', `comment', `phrase' or nil.  Default value is
 973 `phrase'."
 974   (decode-coding-string
 975    string
 976    (cond
 977     ((eq mode 'text) 'mel-ccl-uq-rev)
 978     ((eq mode 'comment) 'mel-ccl-cq-rev)
 979     (t 'mel-ccl-pq-rev))))
 980
 981 (defun q-encoding-ccl-decode-string (string)
 982   "Decode Q encoded STRING and return the result."
 983   (encode-coding-string
 984    string
 985    'mel-ccl-uq-rev))
 986
 987 (unless (featurep 'xemacs)
 988   (defun q-encoding-ccl-encoded-length (string &optional mode)
 989     (let ((status [nil nil nil nil nil nil nil nil nil]))
 990       (fillarray status nil)            ; XXX: Is this necessary?
 991       (ccl-execute-on-string
 992        (cond
 993         ((eq mode 'text) 'mel-ccl-count-uq)
 994         ((eq mode 'comment) 'mel-ccl-count-cq)
 995         (t 'mel-ccl-count-pq))
 996        status
 997        string)
 998       (aref status 0)))
 999   )
1000
1001 (mel-define-method-function (encoded-text-encode-string string (nil "Q"))
1002                             'q-encoding-ccl-encode-string)
1003
1004 (mel-define-method encoded-text-decode-string (string (nil "Q"))
1005   (if (string-match (eval-when-compile
1006                       (concat "\\`" Q-encoded-text-regexp "\\'"))
1007                     string)
1008       (q-encoding-ccl-decode-string string)
1009     (error "Invalid encoded-text %s" string)))
1010
1011
1012 ;;; @ end
1013 ;;;
1014
1015 (provide 'mel-q-ccl)
1016
1017 ;;; mel-q-ccl.el ends here.