ew-bq.el

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