mel-ccl.el

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