mel-q-ccl.el

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