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