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 "!@#$%&'()*+,-./0123456789:;<>@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^`abcdefghijklmnopqrstuvwxyz{|}~" ()))
  73
  74 (defconst ew-ccl-c-raw
  75   (append "!@#$%&'*+,-./0123456789:;<>@ABCDEFGHIJKLMNOPQRSTUVWXYZ[]^`abcdefghijklmnopqrstuvwxyz{|}~" ()))
  76
  77 (defconst ew-ccl-p-raw
  78   (append "!*+-/0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" ()))
  79
  80 (defconst ew-ccl-256-to-64-table
  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  62 nil nil nil  63
  84      52  53  54  55  56  57  58  59  60  61 nil nil nil   t nil nil
  85     nil   0   1   2   3   4   5   6   7   8   9  10  11  12  13  14
  86      15  16  17  18  19  20  21  22  23  24  25 nil nil nil nil nil
  87     nil  26  27  28  29  30  31  32  33  34  35  36  37  38  39  40
  88      41  42  43  44  45  46  47  48  49  50  51 nil nil nil nil nil
  89     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
  90     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
  91     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
  92     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
  93     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
  94     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
  95     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
  96     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil))
  97
  98 (defconst ew-ccl-64-to-256-table
  99   '(?A ?B ?C ?D ?E ?F ?G ?H ?I ?J ?K ?L ?M ?N ?O ?P
 100     ?Q ?R ?S ?T ?U ?V ?W ?X ?Y ?Z ?a ?b ?c ?d ?e ?f
 101     ?g ?h ?i ?j ?k ?l ?m ?n ?o ?p ?q ?r ?s ?t ?u ?v
 102     ?w ?x ?y ?z ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9 ?+ ?/))
 103
 104 )
 105
 106 (define-ccl-program ew-ccl-decode-q
 107   (eval-when-compile
 108     `(1
 109       ((loop
 110         (read-branch
 111          r0
 112          ,@(mapcar
 113             (lambda (r0)
 114               (cond
 115                ((= r0 ?_)
 116                 `(write-repeat ? ))
 117                ((= r0 ?=)
 118                 `((loop
 119                    (read-branch
 120                     r1
 121                     ,@(mapcar
 122                        (lambda (v)
 123                          (if (integerp v)
 124                              `((r0 = ,v) (break))
 125                            '(repeat)))
 126                        ew-ccl-256-to-16-table)))
 127                   (loop
 128                    (read-branch
 129                     r1
 130                     ,@(mapcar
 131                        (lambda (v)
 132                          (if (integerp v)
 133                              `((write r0 ,(vconcat
 134                                            (mapcar
 135                                             (lambda (r0)
 136                                               (logior (lsh r0 4) v))
 137                                             ew-ccl-16-table)))
 138                                (break))
 139                            '(repeat)))
 140                        ew-ccl-256-to-16-table)))
 141                   (repeat)))
 142                (t
 143                 `(write-repeat ,r0))))
 144             ew-ccl-256-table)))))))
 145
 146 (define-ccl-program ew-ccl-encode-uq
 147   (eval-when-compile
 148     `(3
 149       (loop
 150        (loop
 151         (read-branch
 152          r0
 153          ,@(mapcar
 154             (lambda (r0)
 155               (cond
 156                ((= r0 32) `(write-repeat ?_))
 157                ((member r0 ew-ccl-u-raw) `(write-repeat ,r0))
 158                (t '(break))))
 159             ew-ccl-256-table)))
 160        (write ?=)
 161        (write r0 ,ew-ccl-high-table)
 162        (write r0 ,ew-ccl-low-table)
 163        (repeat)))))
 164
 165 (define-ccl-program ew-ccl-encode-cq
 166   (eval-when-compile
 167     `(3
 168       (loop
 169        (loop
 170         (read-branch
 171          r0
 172          ,@(mapcar
 173             (lambda (r0)
 174               (cond
 175                ((= r0 32) `(write-repeat ?_))
 176                ((member r0 ew-ccl-c-raw) `(write-repeat ,r0))
 177                (t '(break))))
 178             ew-ccl-256-table)))
 179        (write ?=)
 180        (write r0 ,ew-ccl-high-table)
 181        (write r0 ,ew-ccl-low-table)
 182        (repeat)))))
 183
 184 (define-ccl-program ew-ccl-encode-pq
 185   (eval-when-compile
 186     `(3
 187       (loop
 188        (loop
 189         (read-branch
 190          r0
 191          ,@(mapcar
 192             (lambda (r0)
 193               (cond
 194                ((= r0 32) `(write-repeat ?_))
 195                ((member r0 ew-ccl-p-raw) `(write-repeat ,r0))
 196                (t '(break))))
 197             ew-ccl-256-table)))
 198        (write ?=)
 199        (write r0 ,ew-ccl-high-table)
 200        (write r0 ,ew-ccl-low-table)
 201        (repeat)))))
 202
 203 (define-ccl-program ew-ccl-decode-b
 204   (eval-when-compile
 205     `(1
 206       (loop
 207        (loop
 208         (read-branch
 209          r1
 210          ,@(mapcar
 211             (lambda (v)
 212               (cond
 213                ((or (eq v nil) (eq v t)) '(repeat))
 214                (t `((r0 = ,(lsh v 2)) (break)))))
 215             ew-ccl-256-to-64-table)))
 216        (loop
 217         (read-branch
 218          r1
 219          ,@(mapcar
 220             (lambda (v)
 221               (cond
 222                ((or (eq v nil) (eq v t)) '(repeat))
 223                ((= (lsh v -4) 0) `((write r0) (r0 = ,(lsh (logand v 15) 4)) (break)))
 224                (t `((write (r0 | ,(lsh v -4))) (r0 = ,(lsh (logand v 15) 4)) (break)))))
 225             ew-ccl-256-to-64-table)))
 226        (loop
 227         (read-branch
 228          r1
 229          ,@(mapcar
 230             (lambda (v)
 231               (cond
 232                ((eq v nil) '(repeat))
 233                ((eq v t) '(end))
 234                ((= (lsh v -2) 0) `((write r0) (r0 = ,(lsh (logand v 3) 6)) (break)))
 235                (t `((write (r0 | ,(lsh v -2))) (r0 = ,(lsh (logand v 3) 6)) (break)))))
 236             ew-ccl-256-to-64-table)))
 237        (loop
 238         (read-branch
 239          r1
 240          ,@(mapcar
 241             (lambda (v)
 242               (cond
 243                ((eq v nil) '(repeat))
 244                ((eq v t) '(end))
 245                (t `((write (r0 | ,v)) (break)))))
 246             ew-ccl-256-to-64-table)))
 247        (repeat)))))
 248
 249 (eval-and-compile
 250
 251 ;; ew-ccl-encode-b works only 20.3 or later because CCL_EOF_BLOCK
 252 ;; is not executed on 20.2 (or former?).
 253 (define-ccl-program ew-ccl-encode-b
 254   (eval-when-compile
 255     `(2
 256       (loop
 257        (r2 = 0)
 258        (read-branch
 259         r1
 260         ,@(mapcar
 261            (lambda (r1)
 262              `((write ,(nth (lsh r1 -2) ew-ccl-64-to-256-table))
 263                (r0 = ,(logand r1 3))))
 264            ew-ccl-256-table))
 265        (r2 = 1)
 266        (read-branch
 267         r1
 268         ,@(mapcar
 269            (lambda (r1)
 270              `((write r0 ,(vconcat
 271                            (mapcar
 272                             (lambda (r0)
 273                               (nth (logior (lsh r0 4)
 274                                            (lsh r1 -4))
 275                                    ew-ccl-64-to-256-table))
 276                             ew-ccl-4-table)))
 277                (r0 = ,(logand r1 15))))
 278            ew-ccl-256-table))
 279        (r2 = 2)
 280        (read-branch
 281         r1
 282         ,@(mapcar
 283            (lambda (r1)
 284              `((write r0 ,(vconcat
 285                            (mapcar
 286                             (lambda (r0)
 287                               (nth (logior (lsh r0 2)
 288                                            (lsh r1 -6))
 289                                    ew-ccl-64-to-256-table))
 290                             ew-ccl-16-table)))))
 291            ew-ccl-256-table))
 292        (r1 &= 63)
 293        (write r1 ,(vconcat
 294                    (mapcar
 295                     (lambda (r1)
 296                       (nth r1 ew-ccl-64-to-256-table))
 297                     ew-ccl-64-table)))
 298        (repeat))
 299       (branch
 300        r2
 301        (end)
 302        ((write r0 ,(vconcat
 303                     (mapcar
 304                      (lambda (r0)
 305                        (nth (lsh r0 4) ew-ccl-64-to-256-table))
 306                      ew-ccl-4-table)))
 307         (write "=="))
 308        ((write r0 ,(vconcat
 309                     (mapcar
 310                      (lambda (r0)
 311                        (nth (lsh r0 2) ew-ccl-64-to-256-table))
 312                      ew-ccl-16-table)))
 313         (write ?=)))
 314       )))
 315
 316 )
 317
 318 ;;;
 319
 320 ;; ew-ccl-encode-base64 does not works on 20.2 by same reason of ew-ccl-encode-b
 321 (define-ccl-program ew-ccl-encode-base64
 322   (eval-when-compile
 323     `(2
 324       ((r3 = 0)
 325        (loop
 326         (r2 = 0)
 327         (read-branch
 328          r1
 329          ,@(mapcar
 330             (lambda (r1)
 331               `((write ,(nth (lsh r1 -2) ew-ccl-64-to-256-table))
 332                 (r0 = ,(logand r1 3))))
 333             ew-ccl-256-table))
 334         (r2 = 1)
 335         (read-branch
 336          r1
 337          ,@(mapcar
 338             (lambda (r1)
 339               `((write r0 ,(vconcat
 340                             (mapcar
 341                              (lambda (r0)
 342                                (nth (logior (lsh r0 4)
 343                                             (lsh r1 -4))
 344                                     ew-ccl-64-to-256-table))
 345                              ew-ccl-4-table)))
 346                 (r0 = ,(logand r1 15))))
 347             ew-ccl-256-table))
 348         (r2 = 2)
 349         (read-branch
 350          r1
 351          ,@(mapcar
 352             (lambda (r1)
 353               `((write r0 ,(vconcat
 354                             (mapcar
 355                              (lambda (r0)
 356                                (nth (logior (lsh r0 2)
 357                                             (lsh r1 -6))
 358                                     ew-ccl-64-to-256-table))
 359                              ew-ccl-16-table)))))
 360             ew-ccl-256-table))
 361         (r1 &= 63)
 362         (write r1 ,(vconcat
 363                     (mapcar
 364                      (lambda (r1)
 365                        (nth r1 ew-ccl-64-to-256-table))
 366                      ew-ccl-64-table)))
 367         (r3 += 1)
 368         (if (r3 == 19) ; 4 * 19 = 76 --> line break.
 369             ((write "\r\n")
 370              (r3 = 0)))
 371         (repeat)))
 372       (branch
 373        r2
 374        (if (r0 > 0) (write "\r\n"))
 375        ((write r0 ,(vconcat
 376                     (mapcar
 377                      (lambda (r0)
 378                        (nth (lsh r0 4) ew-ccl-64-to-256-table))
 379                      ew-ccl-4-table)))
 380         (write "==\r\n"))
 381        ((write r0 ,(vconcat
 382                     (mapcar
 383                      (lambda (r0)
 384                        (nth (lsh r0 2) ew-ccl-64-to-256-table))
 385                      ew-ccl-16-table)))
 386         (write "=\r\n")))
 387       )))
 388
 389 ;;;
 390
 391 (make-coding-system 'ew-ccl-uq 4 ?Q "MIME Q-encoding in unstructured field"
 392                     (cons ew-ccl-decode-q ew-ccl-encode-uq))
 393
 394 (make-coding-system 'ew-ccl-cq 4 ?Q "MIME Q-encoding in comment"
 395                     (cons ew-ccl-decode-q ew-ccl-encode-cq))
 396
 397 (make-coding-system 'ew-ccl-pq 4 ?Q "MIME Q-encoding in phrase"
 398                     (cons ew-ccl-decode-q ew-ccl-encode-pq))
 399
 400 (make-coding-system 'ew-ccl-b 4 ?B "MIME B-encoding"
 401                     (cons ew-ccl-decode-b ew-ccl-encode-b))
 402
 403 (make-coding-system 'ew-ccl-base64 4 ?B "MIME Base64-encoding"
 404                     (cons ew-ccl-decode-b ew-ccl-encode-base64))
 405
 406 ;;;
 407
 408 (eval-and-compile
 409
 410 (defconst ew-ccl-encode-b-is-broken
 411   (eval-when-compile
 412     (not (string= (ccl-execute-on-string ew-ccl-encode-b (make-vector 9 nil) "a")
 413                   "YQ=="))))
 414 )
 415
 416 ;;;
 417
 418 (defun ew-encode-uq (str)
 419   (encode-coding-string (string-as-unibyte str) 'ew-ccl-uq))
 420
 421 (defun ew-encode-cq (str)
 422   (encode-coding-string (string-as-unibyte str) 'ew-ccl-cq))
 423
 424 (defun ew-encode-pq (str)
 425   (encode-coding-string (string-as-unibyte str) 'ew-ccl-pq))
 426
 427 (defun ew-decode-q (str)
 428   (string-as-unibyte (decode-coding-string str 'ew-ccl-uq)))
 429
 430 (require 'mel)
 431 (if (or base64-dl-module ew-ccl-encode-b-is-broken)
 432     (defalias 'ew-encode-b 'base64-encode-string)
 433   (defun ew-encode-b (str)
 434     (encode-coding-string (string-as-unibyte str) 'ew-ccl-b)))
 435
 436 (if base64-dl-module
 437     (defalias 'ew-decode-b 'base64-decode-string)
 438   (defun ew-decode-b (str)
 439     (string-as-unibyte (decode-coding-string str 'ew-ccl-b))))
 440
 441 '(
 442
 443 (ew-encode-uq "\000\037 !\"#$%&'()*+,-./09:;<=>?@AZ[\\]^_`az{|}~\177\200\377")
 444 (ew-encode-cq "\000\037 !\"#$%&'()*+,-./09:;<=>?@AZ[\\]^_`az{|}~\177\200\377")
 445 (ew-encode-pq "\000\037 !\"#$%&'()*+,-./09:;<=>?@AZ[\\]^_`az{|}~\177\200\377")
 446 (ew-encode-b "\000\037 !\"#$%&'()*+,-./09:;<=>?@AZ[\\]^_`az{|}~\177\200\377")
 447
 448 (ew-decode-q "a_b=20c")
 449 (ew-decode-q "=92=A4=A2")
 450 (ew-decode-b "SWYgeW91IGNhbiByZWFkIHRoaXMgeW8=")
 451
 452 (let ((i 1000))
 453   (while (< 0 i)
 454     (setq i (1- i))
 455     (ew-decode-b
 456      "AB8gISIjJCUmJygpKissLS4vMDk6Ozw9Pj9AQVpbXF1eX2Bhent8fX5/gP8=")))
 457
 458 (let ((i 1000))
 459   (while (< 0 i)
 460     (setq i (1- i))
 461     (ew-decode-q
 462      "=00=1F_!=22#$%&'=28=29*+,-./09:;<=3D>=3F@AZ[=5C]^=5F`az{|}~=7F=80=FF")))
 463
 464 (require 'mel)
 465
 466 (let ((i 1000))
 467   (while (< 0 i)
 468     (setq i (1- i))
 469     (base64-decode-string
 470      "AB8gISIjJCUmJygpKissLS4vMDk6Ozw9Pj9AQVpbXF1eX2Bhent8fX5/gP8=")))
 471
 472 (let ((i 1000))
 473   (while (< 0 i)
 474     (setq i (1- i))
 475     (q-encoding-decode-string
 476      "=00=1F_!=22#$%&'=28=29*+,-./09:;<=3D>=3F@AZ[=5C]^=5F`az{|}~=7F=80=FF")))
 477 )