mel-b-ccl.el

   1 ;;; mel-b-ccl.el: CCL based encoder/decoder of Base64
   2
   3 ;; Copyright (C) 1998 Tanaka Akira
   4
   5 ;; Author: Tanaka Akira <akr@jaist.ac.jp>
   6 ;; Created: 1998/9/17
   7 ;; Keywords: MIME, Base64
   8
   9 ;; This file is part of FLIM (Faithful Library about Internet Message).
  10
  11 ;; This program is free software; you can redistribute it and/or
  12 ;; modify it under the terms of the GNU General Public License as
  13 ;; published by the Free Software Foundation; either version 2, or (at
  14 ;; your option) any later version.
  15
  16 ;; This program is distributed in the hope that it will be useful, but
  17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19 ;; General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Code:
  27
  28 (require 'ccl)
  29 (require 'pccl)
  30 (require 'mime-def)
  31
  32
  33 ;;; @ constants
  34 ;;;
  35
  36 (eval-when-compile
  37
  38 (defconst mel-ccl-4-table
  39   '(  0   1   2   3))
  40
  41 (defconst mel-ccl-16-table
  42   '(  0   1   2   3   4   5   6   7   8   9  10  11  12  13  14  15))
  43
  44 (defconst mel-ccl-64-table
  45   '(  0   1   2   3   4   5   6   7   8   9  10  11  12  13  14  15
  46      16  17  18  19  20  21  22  23  24  25  26  27  28  29  30  31
  47      32  33  34  35  36  37  38  39  40  41  42  43  44  45  46  47
  48      48  49  50  51  52  53  54  55  56  57  58  59  60  61  62  63))
  49
  50 (defconst mel-ccl-256-table
  51   '(  0   1   2   3   4   5   6   7   8   9  10  11  12  13  14  15
  52      16  17  18  19  20  21  22  23  24  25  26  27  28  29  30  31
  53      32  33  34  35  36  37  38  39  40  41  42  43  44  45  46  47
  54      48  49  50  51  52  53  54  55  56  57  58  59  60  61  62  63
  55      64  65  66  67  68  69  70  71  72  73  74  75  76  77  78  79
  56      80  81  82  83  84  85  86  87  88  89  90  91  92  93  94  95
  57      96  97  98  99 100 101 102 103 104 105 106 107 108 109 110 111
  58     112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127
  59     128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143
  60     144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159
  61     160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175
  62     176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191
  63     192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207
  64     208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223
  65     224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239
  66     240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255))
  67
  68 (defconst mel-ccl-256-to-64-table
  69   '(nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
  70     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
  71     nil nil nil nil nil nil nil nil nil nil nil  62 nil nil nil  63
  72      52  53  54  55  56  57  58  59  60  61 nil nil nil   t nil nil
  73     nil   0   1   2   3   4   5   6   7   8   9  10  11  12  13  14
  74      15  16  17  18  19  20  21  22  23  24  25 nil nil nil nil nil
  75     nil  26  27  28  29  30  31  32  33  34  35  36  37  38  39  40
  76      41  42  43  44  45  46  47  48  49  50  51 nil nil nil nil nil
  77     nil nil nil nil nil nil nil 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
  86 (defconst mel-ccl-64-to-256-table
  87   (mapcar
  88    'char-int
  89    "ABCDEFGHIJKLMNOPQRSTUVWXYZ\
  90 abcdefghijklmnopqrstuvwxyz\
  91 0123456789\
  92 +/"))
  93
  94 )
  95
  96
  97 ;;; @ CCL programs
  98 ;;;
  99
 100 (eval-when-compile
 101
 102 (defun mel-ccl-decode-b-bit-ex (v)
 103   (logior
 104    (lsh (logand v (lsh 255 16)) -16)
 105    (logand v (lsh 255 8))
 106    (lsh (logand v 255) 16)))
 107
 108 (defconst mel-ccl-decode-b-0-table
 109   (vconcat
 110    (mapcar
 111     (lambda (v)
 112       (if (integerp v)
 113           (mel-ccl-decode-b-bit-ex (lsh v 18))
 114         (lsh 1 24)))
 115     mel-ccl-256-to-64-table)))
 116
 117 (defconst mel-ccl-decode-b-1-table
 118   (vconcat
 119    (mapcar
 120     (lambda (v)
 121       (if (integerp v)
 122           (mel-ccl-decode-b-bit-ex (lsh v 12))
 123         (lsh 1 25)))
 124     mel-ccl-256-to-64-table)))
 125
 126 (defconst mel-ccl-decode-b-2-table
 127   (vconcat
 128    (mapcar
 129     (lambda (v)
 130       (if (integerp v)
 131           (mel-ccl-decode-b-bit-ex (lsh v 6))
 132         (lsh 1 26)))
 133     mel-ccl-256-to-64-table)))
 134
 135 (defconst mel-ccl-decode-b-3-table
 136   (vconcat
 137    (mapcar
 138     (lambda (v)
 139       (if (integerp v)
 140           (mel-ccl-decode-b-bit-ex v)
 141         (lsh 1 27)))
 142     mel-ccl-256-to-64-table)))
 143
 144 )
 145
 146 (define-ccl-program mel-ccl-decode-b
 147   `(1
 148     (loop
 149      (read r0 r1 r2 r3)
 150      (r4 = r0 ,mel-ccl-decode-b-0-table)
 151      (r5 = r1 ,mel-ccl-decode-b-1-table)
 152      (r4 |= r5)
 153      (r5 = r2 ,mel-ccl-decode-b-2-table)
 154      (r4 |= r5)
 155      (r5 = r3 ,mel-ccl-decode-b-3-table)
 156      (r4 |= r5)
 157      (if (r4 & ,(lognot (1- (lsh 1 24))))
 158          ((loop
 159            (if (r4 & ,(lsh 1 24))
 160                ((r0 = r1) (r1 = r2) (r2 = r3) (read r3)
 161                 (r4 >>= 1) (r4 &= ,(logior (lsh 7 24)))
 162                 (r5 = r3 ,mel-ccl-decode-b-3-table)
 163                 (r4 |= r5)
 164                 (repeat))
 165              (break)))
 166           (loop
 167            (if (r4 & ,(lsh 1 25))
 168                ((r1 = r2) (r2 = r3) (read r3)
 169                 (r4 >>= 1) (r4 &= ,(logior (lsh 7 24)))
 170                 (r5 = r3 ,mel-ccl-decode-b-3-table)
 171                 (r4 |= r5)
 172                 (repeat))
 173              (break)))
 174           (loop
 175            (if (r2 != ?=)
 176                (if (r4 & ,(lsh 1 26))
 177                    ((r2 = r3) (read r3)
 178                     (r4 >>= 1) (r4 &= ,(logior (lsh 7 24)))
 179                     (r5 = r3 ,mel-ccl-decode-b-3-table)
 180                     (r4 |= r5)
 181                     (repeat))
 182                  ((r6 = 0)
 183                   (break)))
 184              ((r6 = 1)
 185               (break))))
 186           (loop
 187            (if (r3 != ?=)
 188                (if (r4 & ,(lsh 1 27))
 189                    ((read r3)
 190                     (r4 = r3 ,mel-ccl-decode-b-3-table)
 191                     (repeat))
 192                  (break))
 193              ((r6 |= 2)
 194               (break))))
 195           (r4 = r0 ,mel-ccl-decode-b-0-table)
 196           (r5 = r1 ,mel-ccl-decode-b-1-table)
 197           (r4 |= r5)
 198           (branch
 199            r6
 200            ;; BBBB
 201            ((r5 = r2 ,mel-ccl-decode-b-2-table)
 202             (r4 |= r5)
 203             (r5 = r3 ,mel-ccl-decode-b-3-table)
 204             (r4 |= r5)
 205             (r4 >8= 0)
 206             (write r7)
 207             (r4 >8= 0)
 208             (write r7)
 209             (write-repeat r4))
 210            ;; error: BB=B
 211            ((write (r4 & 255))
 212             (end))
 213            ;; BBB=
 214            ((r5 = r2 ,mel-ccl-decode-b-2-table)
 215             (r4 |= r5)
 216             (r4 >8= 0)
 217             (write r7)
 218             (write (r4 & 255))
 219             (end)                       ; Excessive (end) is workaround for XEmacs 21.0.
 220                                         ; Without this, "AAA=" is converted to "^@^@^@".
 221             (end))
 222            ;; BB==
 223            ((write (r4 & 255))
 224             (end))))
 225        ((r4 >8= 0)
 226         (write r7)
 227         (r4 >8= 0)
 228         (write r7)
 229         (write-repeat r4))))))
 230
 231 (eval-when-compile
 232
 233 ;; Generated CCL program works not properly on 20.2 because CCL_EOF_BLOCK
 234 ;; is not executed.
 235 (defun mel-ccl-encode-base64-generic (&optional quantums-per-line output-crlf terminate-with-newline)
 236   `(2
 237     ((r3 = 0)
 238      (loop
 239       (r2 = 0)
 240       (read-branch
 241        r1
 242        ,@(mapcar
 243           (lambda (r1)
 244             `((write ,(nth (lsh r1 -2) mel-ccl-64-to-256-table))
 245               (r0 = ,(logand r1 3))))
 246           mel-ccl-256-table))
 247       (r2 = 1)
 248       (read-branch
 249        r1
 250        ,@(mapcar
 251           (lambda (r1)
 252             `((write r0 ,(vconcat
 253                           (mapcar
 254                            (lambda (r0)
 255                              (nth (logior (lsh r0 4)
 256                                           (lsh r1 -4))
 257                                   mel-ccl-64-to-256-table))
 258                            mel-ccl-4-table)))
 259               (r0 = ,(logand r1 15))))
 260           mel-ccl-256-table))
 261       (r2 = 2)
 262       (read-branch
 263        r1
 264        ,@(mapcar
 265           (lambda (r1)
 266             `((write r0 ,(vconcat
 267                           (mapcar
 268                            (lambda (r0)
 269                              (nth (logior (lsh r0 2)
 270                                           (lsh r1 -6))
 271                                   mel-ccl-64-to-256-table))
 272                            mel-ccl-16-table)))))
 273           mel-ccl-256-table))
 274       (r1 &= 63)
 275       (write r1 ,(vconcat
 276                   (mapcar
 277                    (lambda (r1)
 278                      (nth r1 mel-ccl-64-to-256-table))
 279                    mel-ccl-64-table)))
 280       (r3 += 1)
 281       ,@(when quantums-per-line
 282           `((if (r3 == ,quantums-per-line)
 283                 ((write ,(if output-crlf "\r\n" "\n"))
 284                  (r3 = 0)))))
 285       (repeat)))
 286     (branch
 287      r2
 288      ,(if terminate-with-newline
 289           `(if (r3 > 0) (write ,(if output-crlf "\r\n" "\n")))
 290         `(r0 = 0))
 291      ((write r0 ,(vconcat
 292                   (mapcar
 293                    (lambda (r0)
 294                      (nth (lsh r0 4) mel-ccl-64-to-256-table))
 295                    mel-ccl-4-table)))
 296       (write ,(if terminate-with-newline
 297                   (if output-crlf "==\r\n" "==\n")
 298                 "==")))
 299      ((write r0 ,(vconcat
 300                   (mapcar
 301                    (lambda (r0)
 302                      (nth (lsh r0 2) mel-ccl-64-to-256-table))
 303                    mel-ccl-16-table)))
 304       (write ,(if terminate-with-newline
 305                   (if output-crlf "=\r\n" "=\n")
 306                 "="))))
 307     ))
 308 )
 309
 310 (define-ccl-program mel-ccl-encode-b
 311   (mel-ccl-encode-base64-generic))
 312
 313 ;; 19 * 4 = 76
 314 (define-ccl-program mel-ccl-encode-base64-crlf-crlf
 315   (mel-ccl-encode-base64-generic 19 t))
 316
 317 (define-ccl-program mel-ccl-encode-base64-crlf-lf
 318   (mel-ccl-encode-base64-generic 19 nil))
 319
 320
 321 ;;; @ coding system
 322 ;;;
 323
 324 (make-ccl-coding-system
 325  'mel-ccl-b-rev ?B "MIME B-encoding (reversed)"
 326  'mel-ccl-encode-b 'mel-ccl-decode-b)
 327
 328 (make-ccl-coding-system
 329  'mel-ccl-base64-crlf-rev
 330  ?B "MIME Base64-encoding (reversed)"
 331  'mel-ccl-encode-base64-crlf-crlf
 332  'mel-ccl-decode-b)
 333
 334 (make-ccl-coding-system
 335  'mel-ccl-base64-lf-rev
 336  ?B "MIME Base64-encoding (LF encoding) (reversed)"
 337  'mel-ccl-encode-base64-crlf-lf
 338  'mel-ccl-decode-b)
 339
 340
 341 ;;; @ B
 342 ;;;
 343
 344 (check-broken-facility ccl-execute-eof-block-on-decoding-some)
 345
 346 (unless-broken ccl-execute-eof-block-on-decoding-some
 347
 348   (defun base64-ccl-encode-string (string)
 349     "Encode STRING with base64 encoding."
 350     (decode-coding-string string 'mel-ccl-base64-lf-rev))
 351
 352   (defun base64-ccl-encode-region (start end)
 353     "Encode region from START to END with base64 encoding."
 354     (interactive "r")
 355     (decode-coding-region start end 'mel-ccl-base64-lf-rev))
 356
 357   (defun base64-ccl-insert-encoded-file (filename)
 358     "Encode contents of file FILENAME to base64, and insert the result."
 359     (interactive (list (read-file-name "Insert encoded file: ")))
 360     (let ((coding-system-for-read 'mel-ccl-base64-lf-rev))
 361       (insert-file-contents filename)))
 362
 363   (mel-define-method-function (mime-encode-string string (nil "base64"))
 364                               'base64-ccl-encode-string)
 365   (mel-define-method-function (mime-encode-region start end (nil "base64"))
 366                               'base64-ccl-encode-region)
 367   (mel-define-method-function
 368    (mime-insert-encoded-file filename (nil "base64"))
 369    'base64-ccl-insert-encoded-file)
 370
 371   (mel-define-method-function (encoded-text-encode-string string (nil "B"))
 372                               'base64-ccl-encode-string)
 373   )
 374
 375 (defun base64-ccl-decode-string (string)
 376   "Decode base64 encoded STRING"
 377   (encode-coding-string string 'mel-ccl-b-rev))
 378
 379 (defun base64-ccl-decode-region (start end)
 380   "Decode base64 encoded the region from START to END."
 381   (interactive "r")
 382   (encode-coding-region start end 'mel-ccl-b-rev))
 383
 384 (defun base64-ccl-write-decoded-region (start end filename)
 385   "Decode the region from START to END and write out to FILENAME."
 386   (interactive
 387     (list (region-beginning) (region-end)
 388           (read-file-name "Write decoded region to file: ")))
 389   (let ((coding-system-for-write 'mel-ccl-b-rev)
 390         jka-compr-compression-info-list)
 391     (write-region start end filename)))
 392
 393 (mel-define-method-function (mime-decode-string string (nil "base64"))
 394                             'base64-ccl-decode-string)
 395 (mel-define-method-function (mime-decode-region start end (nil "base64"))
 396                             'base64-ccl-decode-region)
 397 (mel-define-method-function
 398  (mime-write-decoded-region start end filename (nil "base64"))
 399  'base64-ccl-write-decoded-region)
 400
 401 (mel-define-method encoded-text-decode-string (string (nil "B"))
 402   (if (and (string-match B-encoded-text-regexp string)
 403            (string= string (match-string 0 string)))
 404       (base64-ccl-decode-string string)
 405     (error "Invalid encoded-text %s" string)))
 406
 407
 408 ;;; @ end
 409 ;;;
 410
 411 (provide 'mel-b-ccl)
 412
 413 ;;; mel-b-ccl.el ends here