ew-bq.el

   1 (require 'ccl)
   2 (require 'emu)
   3
   4 (provide 'ew-bq)
   5
   6 (eval-when-compile
   7
   8 (defconst ew-ccl-4-table
   9   '(  0   1   2   3))
  10
  11 (defconst ew-ccl-16-table
  12   '(  0   1   2   3   4   5   6   7   8   9  10  11  12  13  14  15))
  13
  14 (defconst ew-ccl-64-table
  15   '(  0   1   2   3   4   5   6   7   8   9  10  11  12  13  14  15
  16      16  17  18  19  20  21  22  23  24  25  26  27  28  29  30  31
  17      32  33  34  35  36  37  38  39  40  41  42  43  44  45  46  47
  18      48  49  50  51  52  53  54  55  56  57  58  59  60  61  62  63))
  19
  20 (defconst ew-ccl-256-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      64  65  66  67  68  69  70  71  72  73  74  75  76  77  78  79
  26      80  81  82  83  84  85  86  87  88  89  90  91  92  93  94  95
  27      96  97  98  99 100 101 102 103 104 105 106 107 108 109 110 111
  28     112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127
  29     128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143
  30     144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159
  31     160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175
  32     176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191
  33     192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207
  34     208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223
  35     224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239
  36     240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255))
  37
  38 (defconst ew-ccl-256-to-16-table
  39   '(nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
  40     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
  41     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
  42       0   1   2   3   4   5   6   7   8   9 nil nil nil nil nil nil
  43     nil  10  11  12  13  14  15 nil nil nil nil nil nil nil nil nil
  44     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
  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     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
  49     nil nil nil nil nil nil nil 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
  56 (defconst ew-ccl-16-to-256-table
  57   '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9 ?A ?B ?C ?D ?E ?F))
  58
  59 (defconst ew-ccl-high-table
  60   (vconcat
  61    (mapcar
  62     (lambda (v) (nth (lsh v -4) ew-ccl-16-to-256-table))
  63     ew-ccl-256-table)))
  64
  65 (defconst ew-ccl-low-table
  66   (vconcat
  67    (mapcar
  68     (lambda (v) (nth (logand v 15) ew-ccl-16-to-256-table))
  69     ew-ccl-256-table)))
  70
  71 (defconst ew-ccl-u-raw
  72   (append
  73    "0123456789"
  74    "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
  75    "abcdefghijklmnopqrstuvwxyz"
  76    "!@#$%&'()*+,-./:;<>@[\\]^`{|}~"
  77    ()))
  78
  79 (defconst ew-ccl-c-raw
  80   (append
  81    "0123456789"
  82    "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
  83    "abcdefghijklmnopqrstuvwxyz"
  84    "!@#$%&'*+,-./:;<>@[]^`{|}~"
  85    ()))
  86
  87 (defconst ew-ccl-p-raw
  88   (append
  89    "0123456789"
  90    "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
  91    "abcdefghijklmnopqrstuvwxyz"
  92    "!*+-/"
  93    ()))
  94
  95 (defconst ew-ccl-256-to-64-table
  96   '(nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
  97     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
  98     nil nil nil nil nil nil nil nil nil nil nil  62 nil nil nil  63
  99      52  53  54  55  56  57  58  59  60  61 nil nil nil   t nil nil
 100     nil   0   1   2   3   4   5   6   7   8   9  10  11  12  13  14
 101      15  16  17  18  19  20  21  22  23  24  25 nil nil nil nil nil
 102     nil  26  27  28  29  30  31  32  33  34  35  36  37  38  39  40
 103      41  42  43  44  45  46  47  48  49  50  51 nil nil nil nil nil
 104     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
 105     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
 106     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
 107     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
 108     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
 109     nil nil nil nil nil nil nil nil nil nil nil 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
 113 (defconst ew-ccl-64-to-256-table
 114   '(?A ?B ?C ?D ?E ?F ?G ?H ?I ?J ?K ?L ?M ?N ?O ?P
 115     ?Q ?R ?S ?T ?U ?V ?W ?X ?Y ?Z ?a ?b ?c ?d ?e ?f
 116     ?g ?h ?i ?j ?k ?l ?m ?n ?o ?p ?q ?r ?s ?t ?u ?v
 117     ?w ?x ?y ?z ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9 ?+ ?/))
 118
 119 (defconst ew-ccl-qp-table
 120   [enc enc enc enc enc enc enc enc enc wsp enc enc enc cr  enc enc
 121    enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc
 122    wsp raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw
 123    raw raw raw raw raw raw raw raw raw raw raw raw raw enc raw raw
 124    raw 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 raw raw raw
 126    raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw
 127    raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw enc
 128    enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc
 129    enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc
 130    enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc
 131    enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc
 132    enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc
 133    enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc
 134    enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc
 135    enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc])
 136
 137 )
 138
 139 (define-ccl-program ew-ccl-decode-q
 140   (eval-when-compile
 141     `(1
 142       ((loop
 143         (read-branch
 144          r0
 145          ,@(mapcar
 146             (lambda (r0)
 147               (cond
 148                ((= r0 ?_)
 149                 `(write-repeat ? ))
 150                ((= r0 ?=)
 151                 `((loop
 152                    (read-branch
 153                     r1
 154                     ,@(mapcar
 155                        (lambda (v)
 156                          (if (integerp v)
 157                              `((r0 = ,v) (break))
 158                            '(repeat)))
 159                        ew-ccl-256-to-16-table)))
 160                   (loop
 161                    (read-branch
 162                     r1
 163                     ,@(mapcar
 164                        (lambda (v)
 165                          (if (integerp v)
 166                              `((write r0 ,(vconcat
 167                                            (mapcar
 168                                             (lambda (r0)
 169                                               (logior (lsh r0 4) v))
 170                                             ew-ccl-16-table)))
 171                                (break))
 172                            '(repeat)))
 173                        ew-ccl-256-to-16-table)))
 174                   (repeat)))
 175                (t
 176                 `(write-repeat ,r0))))
 177             ew-ccl-256-table)))))))
 178
 179 (define-ccl-program ew-ccl-encode-uq
 180   (eval-when-compile
 181     `(3
 182       (loop
 183        (loop
 184         (read-branch
 185          r0
 186          ,@(mapcar
 187             (lambda (r0)
 188               (cond
 189                ((= r0 32) `(write-repeat ?_))
 190                ((member r0 ew-ccl-u-raw) `(write-repeat ,r0))
 191                (t '(break))))
 192             ew-ccl-256-table)))
 193        (write ?=)
 194        (write r0 ,ew-ccl-high-table)
 195        (write r0 ,ew-ccl-low-table)
 196        (repeat)))))
 197
 198 (define-ccl-program ew-ccl-encode-cq
 199   (eval-when-compile
 200     `(3
 201       (loop
 202        (loop
 203         (read-branch
 204          r0
 205          ,@(mapcar
 206             (lambda (r0)
 207               (cond
 208                ((= r0 32) `(write-repeat ?_))
 209                ((member r0 ew-ccl-c-raw) `(write-repeat ,r0))
 210                (t '(break))))
 211             ew-ccl-256-table)))
 212        (write ?=)
 213        (write r0 ,ew-ccl-high-table)
 214        (write r0 ,ew-ccl-low-table)
 215        (repeat)))))
 216
 217 (define-ccl-program ew-ccl-encode-pq
 218   (eval-when-compile
 219     `(3
 220       (loop
 221        (loop
 222         (read-branch
 223          r0
 224          ,@(mapcar
 225             (lambda (r0)
 226               (cond
 227                ((= r0 32) `(write-repeat ?_))
 228                ((member r0 ew-ccl-p-raw) `(write-repeat ,r0))
 229                (t '(break))))
 230             ew-ccl-256-table)))
 231        (write ?=)
 232        (write r0 ,ew-ccl-high-table)
 233        (write r0 ,ew-ccl-low-table)
 234        (repeat)))))
 235
 236 (define-ccl-program ew-ccl-decode-b
 237   (eval-when-compile
 238     `(1
 239       (loop
 240        (loop
 241         (read-branch
 242          r1
 243          ,@(mapcar
 244             (lambda (v)
 245               (cond
 246                ((or (eq v nil) (eq v t)) '(repeat))
 247                (t `((r0 = ,(lsh v 2)) (break)))))
 248             ew-ccl-256-to-64-table)))
 249        (loop
 250         (read-branch
 251          r1
 252          ,@(mapcar
 253             (lambda (v)
 254               (cond
 255                ((or (eq v nil) (eq v t)) '(repeat))
 256                ((= (lsh v -4) 0) `((write r0) (r0 = ,(lsh (logand v 15) 4)) (break)))
 257                (t `((write (r0 | ,(lsh v -4))) (r0 = ,(lsh (logand v 15) 4)) (break)))))
 258             ew-ccl-256-to-64-table)))
 259        (loop
 260         (read-branch
 261          r1
 262          ,@(mapcar
 263             (lambda (v)
 264               (cond
 265                ((eq v nil) '(repeat))
 266                ((eq v t) '(end))
 267                ((= (lsh v -2) 0) `((write r0) (r0 = ,(lsh (logand v 3) 6)) (break)))
 268                (t `((write (r0 | ,(lsh v -2))) (r0 = ,(lsh (logand v 3) 6)) (break)))))
 269             ew-ccl-256-to-64-table)))
 270        (loop
 271         (read-branch
 272          r1
 273          ,@(mapcar
 274             (lambda (v)
 275               (cond
 276                ((eq v nil) '(repeat))
 277                ((eq v t) '(end))
 278                (t `((write (r0 | ,v)) (break)))))
 279             ew-ccl-256-to-64-table)))
 280        (repeat)))))
 281
 282 (eval-and-compile
 283
 284 ;; ew-ccl-encode-b works only 20.3 or later because CCL_EOF_BLOCK
 285 ;; is not executed on 20.2 (or former?).
 286 (define-ccl-program ew-ccl-encode-b
 287   (eval-when-compile
 288     `(2
 289       (loop
 290        (r2 = 0)
 291        (read-branch
 292         r1
 293         ,@(mapcar
 294            (lambda (r1)
 295              `((write ,(nth (lsh r1 -2) ew-ccl-64-to-256-table))
 296                (r0 = ,(logand r1 3))))
 297            ew-ccl-256-table))
 298        (r2 = 1)
 299        (read-branch
 300         r1
 301         ,@(mapcar
 302            (lambda (r1)
 303              `((write r0 ,(vconcat
 304                            (mapcar
 305                             (lambda (r0)
 306                               (nth (logior (lsh r0 4)
 307                                            (lsh r1 -4))
 308                                    ew-ccl-64-to-256-table))
 309                             ew-ccl-4-table)))
 310                (r0 = ,(logand r1 15))))
 311            ew-ccl-256-table))
 312        (r2 = 2)
 313        (read-branch
 314         r1
 315         ,@(mapcar
 316            (lambda (r1)
 317              `((write r0 ,(vconcat
 318                            (mapcar
 319                             (lambda (r0)
 320                               (nth (logior (lsh r0 2)
 321                                            (lsh r1 -6))
 322                                    ew-ccl-64-to-256-table))
 323                             ew-ccl-16-table)))))
 324            ew-ccl-256-table))
 325        (r1 &= 63)
 326        (write r1 ,(vconcat
 327                    (mapcar
 328                     (lambda (r1)
 329                       (nth r1 ew-ccl-64-to-256-table))
 330                     ew-ccl-64-table)))
 331        (repeat))
 332       (branch
 333        r2
 334        (end)
 335        ((write r0 ,(vconcat
 336                     (mapcar
 337                      (lambda (r0)
 338                        (nth (lsh r0 4) ew-ccl-64-to-256-table))
 339                      ew-ccl-4-table)))
 340         (write "=="))
 341        ((write r0 ,(vconcat
 342                     (mapcar
 343                      (lambda (r0)
 344                        (nth (lsh r0 2) ew-ccl-64-to-256-table))
 345                      ew-ccl-16-table)))
 346         (write ?=)))
 347       )))
 348
 349 )
 350
 351 ;;;
 352
 353 ;; ew-ccl-encode-base64 does not works on 20.2 by same reason of ew-ccl-encode-b
 354 (define-ccl-program ew-ccl-encode-base64
 355   (eval-when-compile
 356     `(2
 357       ((r3 = 0)
 358        (loop
 359         (r2 = 0)
 360         (read-branch
 361          r1
 362          ,@(mapcar
 363             (lambda (r1)
 364               `((write ,(nth (lsh r1 -2) ew-ccl-64-to-256-table))
 365                 (r0 = ,(logand r1 3))))
 366             ew-ccl-256-table))
 367         (r2 = 1)
 368         (read-branch
 369          r1
 370          ,@(mapcar
 371             (lambda (r1)
 372               `((write r0 ,(vconcat
 373                             (mapcar
 374                              (lambda (r0)
 375                                (nth (logior (lsh r0 4)
 376                                             (lsh r1 -4))
 377                                     ew-ccl-64-to-256-table))
 378                              ew-ccl-4-table)))
 379                 (r0 = ,(logand r1 15))))
 380             ew-ccl-256-table))
 381         (r2 = 2)
 382         (read-branch
 383          r1
 384          ,@(mapcar
 385             (lambda (r1)
 386               `((write r0 ,(vconcat
 387                             (mapcar
 388                              (lambda (r0)
 389                                (nth (logior (lsh r0 2)
 390                                             (lsh r1 -6))
 391                                     ew-ccl-64-to-256-table))
 392                              ew-ccl-16-table)))))
 393             ew-ccl-256-table))
 394         (r1 &= 63)
 395         (write r1 ,(vconcat
 396                     (mapcar
 397                      (lambda (r1)
 398                        (nth r1 ew-ccl-64-to-256-table))
 399                      ew-ccl-64-table)))
 400         (r3 += 1)
 401         (if (r3 == 19) ; 4 * 19 = 76 --> line break.
 402             ((write "\r\n")
 403              (r3 = 0)))
 404         (repeat)))
 405       (branch
 406        r2
 407        (if (r0 > 0) (write "\r\n"))
 408        ((write r0 ,(vconcat
 409                     (mapcar
 410                      (lambda (r0)
 411                        (nth (lsh r0 4) ew-ccl-64-to-256-table))
 412                      ew-ccl-4-table)))
 413         (write "==\r\n"))
 414        ((write r0 ,(vconcat
 415                     (mapcar
 416                      (lambda (r0)
 417                        (nth (lsh r0 2) ew-ccl-64-to-256-table))
 418                      ew-ccl-16-table)))
 419         (write "=\r\n")))
 420       )))
 421
 422 ;; ew-ccl-encode-quoted-printable does not works on 20.2 by same reason of ew-ccl-encode-b
 423 (define-ccl-program ew-ccl-encode-quoted-printable
 424   (eval-when-compile
 425     `(4
 426       ((r6 = 0) ; column
 427        (r5 = 0) ; previous character is white space
 428        (r4 = 0)
 429        (read r0)
 430        (loop ; r6 <= 75
 431         (loop
 432          (loop
 433           (branch
 434            r0
 435            ,@(mapcar
 436               (lambda (r0)
 437                 (let ((tmp (aref ew-ccl-qp-table r0)))
 438                   (cond
 439                    ((eq tmp 'raw) '((r3 = 0) (break))) ; RAW
 440                    ((eq tmp 'enc) '((r3 = 1) (break))) ; ENC
 441                    ((eq tmp 'wsp) '((r3 = 2) (break))) ; WSP
 442                    ((eq tmp 'cr) '((r3 = 3) (break))) ; CR
 443                    )))
 444               ew-ccl-256-table)))
 445          (branch
 446           r3
 447           ;; r0:r3=RAW
 448           (if (r6 < 75)
 449               ((r6 += 1)
 450                (r5 = 0)
 451                (r4 = 1)
 452                (write-read-repeat r0))
 453             (break))
 454           ;; r0:r3=ENC
 455           ((r5 = 0)
 456            (if (r6 < 73)
 457                ((r6 += 3)
 458                 (write "=")
 459                 (write r0 ,ew-ccl-high-table)
 460                 (r4 = 2)
 461                 (write-read-repeat r0 ,ew-ccl-low-table))
 462              (if (r6 > 73)
 463                  ((r6 = 3)
 464                   (write "=\r\n=")
 465                   (write r0 ,ew-ccl-high-table)
 466                   (r4 = 3)
 467                   (write-read-repeat r0 ,ew-ccl-low-table))
 468                (break))))
 469           ;; r0:r3=WSP
 470           ((r5 = 1)
 471            (if (r6 < 75)
 472                ((r6 += 1)
 473                 (r4 = 4)
 474                 (write-read-repeat r0))
 475              ((r6 = 1)
 476               (write "=\r\n")
 477               (r4 = 5)
 478               (write-read-repeat r0))))
 479           ;; r0:r3=CR
 480           ((if ((r6 > 73) & r5)
 481                ((r6 = 0)
 482                 (r5 = 0)
 483                 (write "=\r\n")))
 484            (break))))
 485         ;; r0:r3={RAW,ENC,CR}
 486         (loop
 487          (if (r0 == ?\r)
 488              ;; r0=\r:r3=CR
 489              ((r4 = 6)
 490               (read r0)
 491               ;; CR:r3=CR r0
 492               (if (r0 == ?\n)
 493                   ;; CR:r3=CR r0=LF
 494                   (if r5
 495                       ;; r5=WSP ; CR:r3=CR r0=LF
 496                       ((r6 = 0)
 497                        (r5 = 0)
 498                        (write "=\r\n\r\n")
 499                        (r4 = 7)
 500                        (read r0)
 501                        (break))
 502                     ;; r5=noWSP ; CR:r3=CR r0=LF
 503                     ((r6 = 0)
 504                      (r5 = 0)
 505                      (write "\r\n")
 506                      (r4 = 8)
 507                      (read r0)
 508                      (break)))
 509                 ;; CR:r3=CR r0=noLF
 510                 (if (r6 < 73)
 511                     ((r6 += 3)
 512                      (r5 = 0)
 513                      (write "=0D")
 514                      (break))
 515                   (if (r6 == 73)
 516                       (if (r0 == ?\r)
 517                           ;; CR:r3=CR r0=CR
 518                           ((r4 = 9)
 519                            (read r0)
 520                            ;; CR:r3=CR CR r0
 521                            (if (r0 == ?\n)
 522                                ;; CR:r3=CR CR LF
 523                                ((r6 = 0)
 524                                 (r5 = 0)
 525                                 (write "=0D\r\n")
 526                                 (r4 = 10)
 527                                 (read r0)
 528                                 (break))
 529                              ;; CR:r3=CR CR noLF
 530                              ((r6 = 6)
 531                               (r5 = 0)
 532                               (write "=\r\n=0D=0D")
 533                               (break))))
 534                         ;; CR:r3=CR r0=noLFnorCR
 535                         ((r6 = 3)
 536                          (r5 = 0)
 537                          (write "=\r\n=0D")
 538                          (break)))
 539                     ((r6 = 3)
 540                      (r5 = 0)
 541                      (write "=\r\n=0D")
 542                      (break))))))
 543            ;; r0:r3={RAW,ENC}
 544            ((r4 = 11)
 545             (read r1)
 546             ;; r0:r3={RAW,ENC} r1
 547             (if (r1 == ?\r)
 548                 ;; r0:r3={RAW,ENC} r1=CR
 549                 ((r4 = 12)
 550                  (read r1)
 551                  ;; r0:r3={RAW,ENC} CR r1
 552                  (if (r1 == ?\n)
 553                      ;; r0:r3={RAW,ENC} CR r1=LF
 554                      ((r6 = 0)
 555                       (r5 = 0)
 556                       (branch
 557                        r3
 558                        ;; r0:r3=RAW CR r1=LF
 559                        ((write r0)
 560                         (write "\r\n")
 561                         (r4 = 13)
 562                         (read r0)
 563                         (break))
 564                        ;; r0:r3=ENC CR r1=LF
 565                        ((write ?=)
 566                         (write r0 ,ew-ccl-high-table)
 567                         (write r0 ,ew-ccl-low-table)
 568                         (write "\r\n")
 569                         (r4 = 14)
 570                         (read r0)
 571                         (break))))
 572                    ;; r0:r3={RAW,ENC} CR r1=noLF
 573                    ((branch
 574                      r3
 575                      ;; r0:r3=RAW CR r1:noLF
 576                      ((r6 = 4)
 577                       (r5 = 0)
 578                       (write "=\r\n")
 579                       (write r0)
 580                       (write "=0D")
 581                       (r0 = r1)
 582                       (break))
 583                      ;; r0:r3=ENC CR r1:noLF
 584                      ((r6 = 6)
 585                       (r5 = 0)
 586                       (write "=\r\n=")
 587                       (write r0 ,ew-ccl-high-table)
 588                       (write r0 ,ew-ccl-low-table)
 589                       (write "=0D")
 590                       (r0 = r1)
 591                       (break))))
 592                    ))
 593               ;; r0:r3={RAW,ENC} r1:noCR
 594               ((branch
 595                 r3
 596                 ;; r0:r3=RAW r1:noCR
 597                 ((r6 = 1)
 598                  (r5 = 0)
 599                  (write "=\r\n")
 600                  (write r0)
 601                  (r0 = r1)
 602                  (break))
 603                 ;; r0:r3=ENC r1:noCR
 604                 ((r6 = 3)
 605                  (r5 = 0)
 606                  (write "=\r\n=")
 607                  (write r0 ,ew-ccl-high-table)
 608                  (write r0 ,ew-ccl-low-table)
 609                  (r0 = r1)
 610                  (break))))))))
 611         (repeat)))
 612       (;(write "[EOF:") (write r4 ,ew-ccl-high-table) (write r4 ,ew-ccl-low-table) (write "]")
 613        (branch
 614         r4
 615         ;; 0: (start) ;
 616         (end)
 617         ;; 1: RAW ;
 618         (end)
 619         ;; 2: r0:r3=ENC ;
 620         (end)
 621         ;; 3: SOFTBREAK r0:r3=ENC ;
 622         (end)
 623         ;; 4: r0:r3=WSP ;
 624         ((write "=\r\n") (end))
 625         ;; 5: SOFTBREAK r0:r3=WSP ;
 626         ((write "=\r\n") (end))
 627         ;; 6: ; r0=\r:r3=CR
 628         (if (r6 <= 73)
 629             ((write "=0D") (end))
 630            ((write "=\r\n=0D") (end)))
 631         ;; 7: r5=WSP SOFTBREAK CR:r3=CR r0=LF ;
 632         (end)
 633         ;; 8: r5=noWSP CR:r3=CR r0=LF ;
 634         (end)
 635         ;; 9: (r6=73) ; CR:r3=CR r0=CR
 636         ((write "=\r\n=0D=0D") (end))
 637         ;; 10: (r6=73) CR:r3=CR CR LF ;
 638         (end)
 639         ;; 11: ; r0:r3={RAW,ENC}
 640         (branch
 641          r3
 642          ((write r0) (end))
 643          ((write "=")
 644           (write r0 ,ew-ccl-high-table)
 645           (write r0 ,ew-ccl-low-table)
 646           (end)))
 647         ;; 12: ; r0:r3={RAW,ENC} r1=CR
 648         (branch
 649          r3
 650          ((write "=\r\n")
 651           (write r0)
 652           (write "=0D")
 653           (end))
 654          ((write "=\r\n=")
 655           (write r0 ,ew-ccl-high-table)
 656           (write r0 ,ew-ccl-low-table)
 657           (write "=0D")
 658           (end)))
 659         ;; 13: r0:r3=RAW CR LF ;
 660         (end)
 661         ;; 14: r0:r3=ENC CR LF ;
 662         (end)
 663         ))
 664       )))
 665
 666 (define-ccl-program ew-ccl-decode-quoted-printable
 667   (eval-when-compile
 668     `(1
 669       ((read r0)
 670        (loop
 671         (branch
 672          r0
 673          ,@(mapcar
 674             (lambda (r0)
 675               (let ((tmp (aref ew-ccl-qp-table r0)))
 676                 (cond
 677                  ((or (eq tmp 'raw) (eq tmp 'wsp)) `(write-read-repeat r0))
 678                  ((eq r0 ?=)
 679                   ;; r0='='
 680                   `((read r0)
 681                     ;; '=' r0
 682                     (r1 = (r0 == ?\t))
 683                     (if ((r0 == ? ) | r1)
 684                         ;; '=' r0:[\t ]
 685                         ;; Skip transport-padding.
 686                         ;; It should check CR LF after
 687                         ;; transport-padding.
 688                         (loop
 689                          (read-if (r0 == ?\t)
 690                                   (repeat)
 691                                   (if (r0 == ? )
 692                                       (repeat)
 693                                     (break)))))
 694                     ;; '=' [\t ]* r0:[^\t ]
 695                     (branch
 696                      r0
 697                      ,@(mapcar
 698                         (lambda (r0)
 699                           (cond
 700                            ((eq r0 ?\r)
 701                             ;; '=' [\t ]* r0='\r'
 702                             `((read r0)
 703                               ;; '=' [\t ]* '\r' r0
 704                               (if (r0 == ?\n)
 705                                   ;; '=' [\t ]* '\r' r0='\n'
 706                                   ;; soft line break found.
 707                                   ((read r0)
 708                                    (repeat))
 709                                 ;; '=' [\t ]* '\r' r0:[^\n]
 710                                 ;; invalid input ->
 711                                 ;; output "=\r" and rescan from r0.
 712                                 ((write "=\r")
 713                                  (repeat)))))
 714                            ((setq tmp (nth r0 ew-ccl-256-to-16-table))
 715                             ;; '=' [\t ]* r0:[0-9A-F]
 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                         ew-ccl-256-table))
 724                     ;; '=' [\t ]* r0:[0-9A-F]
 725                     (read-branch
 726                      r1
 727                      ,@(mapcar
 728                         (lambda (r1)
 729                           (if (setq tmp (nth r1 ew-ccl-256-to-16-table))
 730                               ;; '=' [\t ]* [0-9A-F] r1:[0-9A-F]
 731                               `(write-read-repeat
 732                                 r0
 733                                 ,(vconcat
 734                                   (mapcar
 735                                    (lambda (r0)
 736                                      (logior (lsh r0 4) tmp))
 737                                    ew-ccl-16-table)))
 738                             ;; '=' [\t ]* [0-9A-F] r1:[^0-9A-F]
 739                             ;; invalid input
 740                             `(r2 = 0)   ; nop
 741                             ))
 742                         ew-ccl-256-table))
 743                     (write ?=)
 744                     (write r0 ,(vconcat ew-ccl-16-to-256-table))
 745                     (write r1)
 746                     (read r0)
 747                     (repeat)))
 748                  ((eq tmp 'cr)
 749                   ;; r0='\r'
 750                   `((read r0)
 751                     ;; '\r' r0
 752                     (if (r0 == ?\n)
 753                         ;; '\r' r0='\n'
 754                         ;; hard line break found.
 755                         ((write ?\r)
 756                          (write-read-repeat r0))
 757                       ;; '\r' r0:[^\n]
 758                       ;; invalid control character (bare CR) found.
 759                       ;; -> ignore it and rescan from r0.
 760                       (repeat))))
 761                  (t
 762                   ;; r0:[^\t\r -~]
 763                   ;; invalid character found.
 764                   ;; -> ignore.
 765                   `((read r0)
 766                     (repeat))))))
 767             ew-ccl-256-table)))))))
 768
 769 ;;;
 770
 771 (make-coding-system 'ew-ccl-uq 4 ?Q "MIME Q-encoding in unstructured field"
 772                     (cons ew-ccl-decode-q ew-ccl-encode-uq))
 773
 774 (make-coding-system 'ew-ccl-cq 4 ?Q "MIME Q-encoding in comment"
 775                     (cons ew-ccl-decode-q ew-ccl-encode-cq))
 776
 777 (make-coding-system 'ew-ccl-pq 4 ?Q "MIME Q-encoding in phrase"
 778                     (cons ew-ccl-decode-q ew-ccl-encode-pq))
 779
 780 (make-coding-system 'ew-ccl-b 4 ?B "MIME B-encoding"
 781                     (cons ew-ccl-decode-b ew-ccl-encode-b))
 782
 783 (make-coding-system 'ew-ccl-base64 4 ?B "MIME Base64-encoding"
 784                     (cons ew-ccl-decode-b ew-ccl-encode-base64))
 785
 786 (make-coding-system 'ew-ccl-quoted-printable 4 ?B
 787                     "MIME Quoted-Printable-encoding"
 788                     (cons ew-ccl-decode-quoted-printable
 789                           ew-ccl-encode-quoted-printable))
 790
 791 ;;;
 792
 793 (eval-and-compile
 794
 795 (defconst ew-ccl-encode-b-is-broken
 796   (eval-when-compile
 797     (not (string= (ccl-execute-on-string ew-ccl-encode-b (make-vector 9 nil) "a")
 798                   "YQ=="))))
 799 )
 800
 801 ;;;
 802 (require 'mel)
 803 (defvar ew-bq-use-mel nil)
 804
 805 (defun ew-encode-uq (str)
 806   (encode-coding-string (string-as-unibyte str) 'ew-ccl-uq))
 807
 808 (defun ew-encode-cq (str)
 809   (encode-coding-string (string-as-unibyte str) 'ew-ccl-cq))
 810
 811 (defun ew-encode-pq (str)
 812   (encode-coding-string (string-as-unibyte str) 'ew-ccl-pq))
 813
 814 (if ew-bq-use-mel
 815     (defalias 'ew-decode-q 'q-encoding-decode-string)
 816   (defun ew-decode-q (str)
 817     (string-as-unibyte (decode-coding-string str 'ew-ccl-uq))))
 818
 819 (if (or ew-bq-use-mel base64-dl-module ew-ccl-encode-b-is-broken)
 820     (defalias 'ew-encode-b 'base64-encode-string)
 821   (defun ew-encode-b (str)
 822     (encode-coding-string (string-as-unibyte str) 'ew-ccl-b)))
 823
 824 (if (or ew-bq-use-mel base64-dl-module)
 825     (defalias 'ew-decode-b 'base64-decode-string)
 826   (defun ew-decode-b (str)
 827     (string-as-unibyte (decode-coding-string str 'ew-ccl-b))))
 828
 829 '(
 830
 831 (ew-encode-uq "\000\037 !\"#$%&'()*+,-./09:;<=>?@AZ[\\]^_`az{|}~\177\200\377")
 832 (ew-encode-cq "\000\037 !\"#$%&'()*+,-./09:;<=>?@AZ[\\]^_`az{|}~\177\200\377")
 833 (ew-encode-pq "\000\037 !\"#$%&'()*+,-./09:;<=>?@AZ[\\]^_`az{|}~\177\200\377")
 834 (ew-encode-b "\000\037 !\"#$%&'()*+,-./09:;<=>?@AZ[\\]^_`az{|}~\177\200\377")
 835
 836 (ew-decode-q "a_b=20c")
 837 (ew-decode-q "=92=A4=A2")
 838 (ew-decode-b "SWYgeW91IGNhbiByZWFkIHRoaXMgeW8=")
 839
 840 (let ((i 1000))
 841   (while (< 0 i)
 842     (setq i (1- i))
 843     (ew-decode-b
 844      "AB8gISIjJCUmJygpKissLS4vMDk6Ozw9Pj9AQVpbXF1eX2Bhent8fX5/gP8=")))
 845
 846 (let ((i 1000))
 847   (while (< 0 i)
 848     (setq i (1- i))
 849     (ew-decode-q
 850      "=00=1F_!=22#$%&'=28=29*+,-./09:;<=3D>=3F@AZ[=5C]^=5F`az{|}~=7F=80=FF")))
 851
 852 (require 'mel)
 853
 854 (let ((i 1000))
 855   (while (< 0 i)
 856     (setq i (1- i))
 857     (base64-decode-string
 858      "AB8gISIjJCUmJygpKissLS4vMDk6Ozw9Pj9AQVpbXF1eX2Bhent8fX5/gP8=")))
 859
 860 (let ((i 1000))
 861   (while (< 0 i)
 862     (setq i (1- i))
 863     (q-encoding-decode-string
 864      "=00=1F_!=22#$%&'=28=29*+,-./09:;<=3D>=3F@AZ[=5C]^=5F`az{|}~=7F=80=FF")))
 865 )