mel-b-ccl.el

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