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 (if-broken ccl-cascading-read
 147     (define-ccl-program mel-ccl-decode-b
 148       `(1
 149         (loop
 150          (loop
 151           (read-branch
 152            r1
 153            ,@(mapcar
 154               (lambda (v)
 155                 (cond
 156                  ((or (eq v nil) (eq v t)) '(repeat))
 157                  (t `((r0 = ,(lsh v 2)) (break)))))
 158               mel-ccl-256-to-64-table)))
 159          (loop
 160           (read-branch
 161            r1
 162            ,@(mapcar
 163               (lambda (v)
 164                 (cond
 165                  ((or (eq v nil) (eq v t)) '(repeat))
 166                  ((= (lsh v -4) 0) `((write r0) (r0 = ,(lsh (logand v 15) 4)) (break)))
 167                  (t `((r0 |= ,(lsh v -4)) (write r0) (r0 = ,(lsh (logand v 15) 4)) (break)))))
 168               mel-ccl-256-to-64-table)))
 169          (loop
 170           (read-branch
 171            r1
 172            ,@(mapcar
 173               (lambda (v)
 174                 (cond
 175                  ((eq v nil) '(repeat))
 176                  ((eq v t) '(end))
 177                  ((= (lsh v -2) 0) `((write r0) (r0 = ,(lsh (logand v 3) 6)) (break)))
 178                  (t `((r0 |= ,(lsh v -2)) (write r0) (r0 = ,(lsh (logand v 3) 6)) (break)))))
 179               mel-ccl-256-to-64-table)))
 180          (loop
 181           (read-branch
 182            r1
 183            ,@(mapcar
 184               (lambda (v)
 185                 (cond
 186                  ((eq v nil) '(repeat))
 187                  ((eq v t) '(end))
 188                  (t `((r0 |= ,v) (write r0) (break)))))
 189               mel-ccl-256-to-64-table)))
 190          (repeat))))
 191   (define-ccl-program mel-ccl-decode-b
 192     `(1
 193       (loop
 194        (read r0 r1 r2 r3)
 195        (r4 = r0 ,mel-ccl-decode-b-0-table)
 196        (r5 = r1 ,mel-ccl-decode-b-1-table)
 197        (r4 |= r5)
 198        (r5 = r2 ,mel-ccl-decode-b-2-table)
 199        (r4 |= r5)
 200        (r5 = r3 ,mel-ccl-decode-b-3-table)
 201        (r4 |= r5)
 202        (if (r4 & ,(lognot (1- (lsh 1 24))))
 203            ((loop
 204              (if (r4 & ,(lsh 1 24))
 205                  ((r0 = r1) (r1 = r2) (r2 = r3) (read r3)
 206                   (r4 >>= 1) (r4 &= ,(logior (lsh 7 24)))
 207                   (r5 = r3 ,mel-ccl-decode-b-3-table)
 208                   (r4 |= r5)
 209                   (repeat))
 210                (break)))
 211             (loop
 212              (if (r4 & ,(lsh 1 25))
 213                  ((r1 = r2) (r2 = r3) (read r3)
 214                   (r4 >>= 1) (r4 &= ,(logior (lsh 7 24)))
 215                   (r5 = r3 ,mel-ccl-decode-b-3-table)
 216                   (r4 |= r5)
 217                   (repeat))
 218                (break)))
 219             (loop
 220              (if (r2 != ?=)
 221                  (if (r4 & ,(lsh 1 26))
 222                      ((r2 = r3) (read r3)
 223                       (r4 >>= 1) (r4 &= ,(logior (lsh 7 24)))
 224                       (r5 = r3 ,mel-ccl-decode-b-3-table)
 225                       (r4 |= r5)
 226                       (repeat))
 227                    ((r6 = 0)
 228                     (break)))
 229                ((r6 = 1)
 230                 (break))))
 231             (loop
 232              (if (r3 != ?=)
 233                  (if (r4 & ,(lsh 1 27))
 234                      ((read r3)
 235                       (r4 = r3 ,mel-ccl-decode-b-3-table)
 236                       (repeat))
 237                    (break))
 238                ((r6 |= 2)
 239                 (break))))
 240             (r4 = r0 ,mel-ccl-decode-b-0-table)
 241             (r5 = r1 ,mel-ccl-decode-b-1-table)
 242             (r4 |= r5)
 243             (branch
 244              r6
 245              ;; BBBB
 246              ((r5 = r2 ,mel-ccl-decode-b-2-table)
 247               (r4 |= r5)
 248               (r5 = r3 ,mel-ccl-decode-b-3-table)
 249               (r4 |= r5)
 250               (r4 >8= 0)
 251               (write r7)
 252               (r4 >8= 0)
 253               (write r7)
 254               (write-repeat r4))
 255              ;; error: BB=B
 256              ((write (r4 & 255))
 257               (end))
 258              ;; BBB=
 259              ((r5 = r2 ,mel-ccl-decode-b-2-table)
 260               (r4 |= r5)
 261               (r4 >8= 0)
 262               (write r7)
 263               (write (r4 & 255))
 264               (end)                     ; Excessive (end) is workaround for XEmacs 21.0.
 265                                         ; Without this, "AAA=" is converted to "^@^@^@".
 266               (end))
 267              ;; BB==
 268              ((write (r4 & 255))
 269               (end))))
 270          ((r4 >8= 0)
 271           (write r7)
 272           (r4 >8= 0)
 273           (write r7)
 274           (write-repeat r4))))))
 275   )
 276
 277 (eval-when-compile
 278
 279 ;; Generated CCL program works not properly on 20.2 because CCL_EOF_BLOCK
 280 ;; is not executed.
 281 (defun mel-ccl-encode-base64-generic
 282   (&optional quantums-per-line output-crlf terminate-with-newline)
 283   `(2
 284     ((r3 = 0)
 285      (loop
 286       (r2 = 0)
 287       (read-branch
 288        r1
 289        ,@(mapcar
 290           (lambda (r1)
 291             `((write ,(nth (lsh r1 -2) mel-ccl-64-to-256-table))
 292               (r0 = ,(logand r1 3))))
 293           mel-ccl-256-table))
 294       (r2 = 1)
 295       (read-branch
 296        r1
 297        ,@(mapcar
 298           (lambda (r1)
 299             `((write r0 ,(vconcat
 300                           (mapcar
 301                            (lambda (r0)
 302                              (nth (logior (lsh r0 4)
 303                                           (lsh r1 -4))
 304                                   mel-ccl-64-to-256-table))
 305                            mel-ccl-4-table)))
 306               (r0 = ,(logand r1 15))))
 307           mel-ccl-256-table))
 308       (r2 = 2)
 309       (read-branch
 310        r1
 311        ,@(mapcar
 312           (lambda (r1)
 313             `((write r0 ,(vconcat
 314                           (mapcar
 315                            (lambda (r0)
 316                              (nth (logior (lsh r0 2)
 317                                           (lsh r1 -6))
 318                                   mel-ccl-64-to-256-table))
 319                            mel-ccl-16-table)))))
 320           mel-ccl-256-table))
 321       (r1 &= 63)
 322       (write r1 ,(vconcat
 323                   (mapcar
 324                    (lambda (r1)
 325                      (nth r1 mel-ccl-64-to-256-table))
 326                    mel-ccl-64-table)))
 327       (r3 += 1)
 328       ,@(when quantums-per-line
 329           `((if (r3 == ,quantums-per-line)
 330                 ((write ,(if output-crlf "\r\n" "\n"))
 331                  (r3 = 0)))))
 332       (repeat)))
 333     (branch
 334      r2
 335      ,(if terminate-with-newline
 336           `(if (r3 > 0) (write ,(if output-crlf "\r\n" "\n")))
 337         `(r0 = 0))
 338      ((write r0 ,(vconcat
 339                   (mapcar
 340                    (lambda (r0)
 341                      (nth (lsh r0 4) mel-ccl-64-to-256-table))
 342                    mel-ccl-4-table)))
 343       (write ,(if terminate-with-newline
 344                   (if output-crlf "==\r\n" "==\n")
 345                 "==")))
 346      ((write r0 ,(vconcat
 347                   (mapcar
 348                    (lambda (r0)
 349                      (nth (lsh r0 2) mel-ccl-64-to-256-table))
 350                    mel-ccl-16-table)))
 351       (write ,(if terminate-with-newline
 352                   (if output-crlf "=\r\n" "=\n")
 353                 "="))))
 354     ))
 355 )
 356
 357 (define-ccl-program mel-ccl-encode-b
 358   (mel-ccl-encode-base64-generic))
 359
 360 ;; 19 * 4 = 76
 361 (define-ccl-program mel-ccl-encode-base64-crlf-crlf
 362   (mel-ccl-encode-base64-generic 19 t))
 363
 364 (define-ccl-program mel-ccl-encode-base64-crlf-lf
 365   (mel-ccl-encode-base64-generic 19 nil))
 366
 367
 368 ;;; @ coding system
 369 ;;;
 370
 371 (make-ccl-coding-system
 372  'mel-ccl-b-rev ?B "MIME B-encoding (reversed)"
 373  'mel-ccl-encode-b 'mel-ccl-decode-b)
 374
 375 (make-ccl-coding-system
 376  'mel-ccl-base64-crlf-rev
 377  ?B "MIME Base64-encoding (reversed)"
 378  'mel-ccl-encode-base64-crlf-crlf
 379  'mel-ccl-decode-b)
 380
 381 (make-ccl-coding-system
 382  'mel-ccl-base64-lf-rev
 383  ?B "MIME Base64-encoding (LF encoding) (reversed)"
 384  'mel-ccl-encode-base64-crlf-lf
 385  'mel-ccl-decode-b)
 386
 387
 388 ;;; @ B
 389 ;;;
 390
 391 (check-broken-facility ccl-execute-eof-block-on-decoding-some)
 392
 393 (unless-broken ccl-execute-eof-block-on-decoding-some
 394
 395   (defun base64-ccl-encode-string (string)
 396     "Encode STRING with base64 encoding."
 397     (decode-coding-string string 'mel-ccl-base64-lf-rev))
 398
 399   (defun base64-ccl-encode-region (start end)
 400     "Encode region from START to END with base64 encoding."
 401     (interactive "r")
 402     (decode-coding-region start end 'mel-ccl-base64-lf-rev))
 403
 404   (defun base64-ccl-insert-encoded-file (filename)
 405     "Encode contents of file FILENAME to base64, and insert the result."
 406     (interactive (list (read-file-name "Insert encoded file: ")))
 407     (let ((coding-system-for-read 'mel-ccl-base64-lf-rev))
 408       (insert-file-contents filename)))
 409
 410   (mel-define-method-function (mime-encode-string string (nil "base64"))
 411                               'base64-ccl-encode-string)
 412   (mel-define-method-function (mime-encode-region start end (nil "base64"))
 413                               'base64-ccl-encode-region)
 414   (mel-define-method-function
 415    (mime-insert-encoded-file filename (nil "base64"))
 416    'base64-ccl-insert-encoded-file)
 417
 418   (mel-define-method-function (encoded-text-encode-string string (nil "B"))
 419                               'base64-ccl-encode-string)
 420   )
 421
 422 (defun base64-ccl-decode-string (string)
 423   "Decode base64 encoded STRING"
 424   (encode-coding-string string 'mel-ccl-b-rev))
 425
 426 (defun base64-ccl-decode-region (start end)
 427   "Decode base64 encoded the region from START to END."
 428   (interactive "r")
 429   (encode-coding-region start end 'mel-ccl-b-rev))
 430
 431 (defun base64-ccl-write-decoded-region (start end filename)
 432   "Decode the region from START to END and write out to FILENAME."
 433   (interactive
 434     (list (region-beginning) (region-end)
 435           (read-file-name "Write decoded region to file: ")))
 436   (let ((coding-system-for-write 'mel-ccl-b-rev)
 437         jka-compr-compression-info-list)
 438     (write-region start end filename)))
 439
 440 (mel-define-method-function (mime-decode-string string (nil "base64"))
 441                             'base64-ccl-decode-string)
 442 (mel-define-method-function (mime-decode-region start end (nil "base64"))
 443                             'base64-ccl-decode-region)
 444 (mel-define-method-function
 445  (mime-write-decoded-region start end filename (nil "base64"))
 446  'base64-ccl-write-decoded-region)
 447
 448 (mel-define-method encoded-text-decode-string (string (nil "B"))
 449   (if (and (string-match B-encoded-text-regexp string)
 450            (string= string (match-string 0 string)))
 451       (base64-ccl-decode-string string)
 452     (error "Invalid encoded-text %s" string)))
 453
 454
 455 ;;; @ end
 456 ;;;
 457
 458 (provide 'mel-b-ccl)
 459
 460 ;;; mel-b-ccl.el ends here