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      (loop
 288       (r2 = 0)
 289       (read-branch
 290        r1
 291        ,@(mapcar
 292           (lambda (r1)
 293             `((write ,(nth (lsh r1 -2) mel-ccl-64-to-256-table))
 294               (r0 = ,(logand r1 3))))
 295           mel-ccl-256-table))
 296       (r2 = 1)
 297       (read-branch
 298        r1
 299        ,@(mapcar
 300           (lambda (r1)
 301             `((write r0 ,(vconcat
 302                           (mapcar
 303                            (lambda (r0)
 304                              (nth (logior (lsh r0 4)
 305                                           (lsh r1 -4))
 306                                   mel-ccl-64-to-256-table))
 307                            mel-ccl-4-table)))
 308               (r0 = ,(logand r1 15))))
 309           mel-ccl-256-table))
 310       (r2 = 2)
 311       (read-branch
 312        r1
 313        ,@(mapcar
 314           (lambda (r1)
 315             `((write r0 ,(vconcat
 316                           (mapcar
 317                            (lambda (r0)
 318                              (nth (logior (lsh r0 2)
 319                                           (lsh r1 -6))
 320                                   mel-ccl-64-to-256-table))
 321                            mel-ccl-16-table)))))
 322           mel-ccl-256-table))
 323       (r1 &= 63)
 324       (write r1 ,(vconcat
 325                   (mapcar
 326                    (lambda (r1)
 327                      (nth r1 mel-ccl-64-to-256-table))
 328                    mel-ccl-64-table)))
 329       (r3 += 1)
 330       ,@(when quantums-per-line
 331           `((if (r3 == ,quantums-per-line)
 332                 ((write ,(if output-crlf "\r\n" "\n"))
 333                  (r3 = 0)))))
 334       (repeat)))
 335     (branch
 336      r2
 337      ,(if terminate-with-newline
 338           `(if (r3 > 0) (write ,(if output-crlf "\r\n" "\n")))
 339         `(r0 = 0))
 340      ((write r0 ,(vconcat
 341                   (mapcar
 342                    (lambda (r0)
 343                      (nth (lsh r0 4) mel-ccl-64-to-256-table))
 344                    mel-ccl-4-table)))
 345       (write ,(if terminate-with-newline
 346                   (if output-crlf "==\r\n" "==\n")
 347                 "==")))
 348      ((write r0 ,(vconcat
 349                   (mapcar
 350                    (lambda (r0)
 351                      (nth (lsh r0 2) mel-ccl-64-to-256-table))
 352                    mel-ccl-16-table)))
 353       (write ,(if terminate-with-newline
 354                   (if output-crlf "=\r\n" "=\n")
 355                 "="))))
 356     ))
 357 )
 358
 359 (define-ccl-program mel-ccl-encode-b
 360   (mel-ccl-encode-base64-generic))
 361
 362 ;; 19 * 4 = 76
 363 (define-ccl-program mel-ccl-encode-base64-crlf-crlf
 364   (mel-ccl-encode-base64-generic 19 t))
 365
 366 (define-ccl-program mel-ccl-encode-base64-crlf-lf
 367   (mel-ccl-encode-base64-generic 19 nil))
 368
 369
 370 ;;; @ coding system
 371 ;;;
 372
 373 (make-ccl-coding-system
 374  'mel-ccl-b-rev ?B "MIME B-encoding (reversed)"
 375  'mel-ccl-encode-b 'mel-ccl-decode-b)
 376
 377 (make-ccl-coding-system
 378  'mel-ccl-base64-crlf-rev
 379  ?B "MIME Base64-encoding (reversed)"
 380  'mel-ccl-encode-base64-crlf-crlf
 381  'mel-ccl-decode-b)
 382
 383 (make-ccl-coding-system
 384  'mel-ccl-base64-lf-rev
 385  ?B "MIME Base64-encoding (LF encoding) (reversed)"
 386  'mel-ccl-encode-base64-crlf-lf
 387  'mel-ccl-decode-b)
 388
 389
 390 ;;; @ B
 391 ;;;
 392
 393 (check-broken-facility ccl-execute-eof-block-on-decoding-some)
 394
 395 (unless-broken ccl-execute-eof-block-on-decoding-some
 396
 397   (defun base64-ccl-encode-string (string)
 398     "Encode STRING with base64 encoding."
 399     (decode-coding-string string 'mel-ccl-base64-lf-rev))
 400
 401   (defun base64-ccl-encode-region (start end)
 402     "Encode region from START to END with base64 encoding."
 403     (interactive "r")
 404     (decode-coding-region start end 'mel-ccl-base64-lf-rev))
 405
 406   (defun base64-ccl-insert-encoded-file (filename)
 407     "Encode contents of file FILENAME to base64, and insert the result."
 408     (interactive (list (read-file-name "Insert encoded file: ")))
 409     (insert-file-contents-as-coding-system 'mel-ccl-base64-lf-rev filename))
 410
 411   (mel-define-method-function (mime-encode-string string (nil "base64"))
 412                               'base64-ccl-encode-string)
 413   (mel-define-method-function (mime-encode-region start end (nil "base64"))
 414                               'base64-ccl-encode-region)
 415   (mel-define-method-function
 416    (mime-insert-encoded-file filename (nil "base64"))
 417    'base64-ccl-insert-encoded-file)
 418
 419   (mel-define-method-function (encoded-text-encode-string string (nil "B"))
 420                               'base64-ccl-encode-string)
 421   )
 422
 423 (defun base64-ccl-decode-string (string)
 424   "Decode base64 encoded STRING"
 425   (encode-coding-string string 'mel-ccl-b-rev))
 426
 427 (defun base64-ccl-decode-region (start end)
 428   "Decode base64 encoded the region from START to END."
 429   (interactive "r")
 430   (encode-coding-region start end 'mel-ccl-b-rev))
 431
 432 (defun base64-ccl-write-decoded-region (start end filename)
 433   "Decode the region from START to END and write out to FILENAME."
 434   (interactive
 435     (list (region-beginning) (region-end)
 436           (read-file-name "Write decoded region to file: ")))
 437   (write-region-as-coding-system 'mel-ccl-b-rev start end filename))
 438
 439 (mel-define-method-function (mime-decode-string string (nil "base64"))
 440                             'base64-ccl-decode-string)
 441 (mel-define-method-function (mime-decode-region start end (nil "base64"))
 442                             'base64-ccl-decode-region)
 443 (mel-define-method-function
 444  (mime-write-decoded-region start end filename (nil "base64"))
 445  'base64-ccl-write-decoded-region)
 446
 447 (mel-define-method encoded-text-decode-string (string (nil "B"))
 448   (if (and (string-match B-encoded-text-regexp string)
 449            (string= string (match-string 0 string)))
 450       (base64-ccl-decode-string string)
 451     (error "Invalid encoded-text %s" string)))
 452
 453
 454 ;;; @ end
 455 ;;;
 456
 457 (provide 'mel-b-ccl)
 458
 459 ;;; mel-b-ccl.el ends here