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