mel-b.el

   1 ;;; mel-b.el: Base64 encoder/decoder for GNU Emacs
   2
   3 ;; Copyright (C) 1992,1995,1996,1997,1998 Free Software Foundation, Inc.
   4
   5 ;; Author: ENAMI Tsugutomo <enami@sys.ptg.sony.co.jp>
   6 ;;         MORIOKA Tomohiko <morioka@jaist.ac.jp>
   7 ;; Created: 1995/6/24
   8 ;; Keywords: MIME, Base64
   9
  10 ;; This file is part of MEL (MIME Encoding Library).
  11
  12 ;; This program is free software; you can redistribute it and/or
  13 ;; modify it under the terms of the GNU General Public License as
  14 ;; published by the Free Software Foundation; either version 2, or (at
  15 ;; your option) any later version.
  16
  17 ;; This program is distributed in the hope that it will be useful, but
  18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  20 ;; General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  25 ;; Boston, MA 02111-1307, USA.
  26
  27 ;;; Code:
  28
  29 (require 'emu)
  30
  31
  32 ;;; @ variables
  33 ;;;
  34
  35 (defvar base64-external-encoder '("mmencode")
  36   "*list of base64 encoder program name and its arguments.")
  37
  38 (defvar base64-external-decoder '("mmencode" "-u")
  39   "*list of base64 decoder program name and its arguments.")
  40
  41 (defvar base64-external-decoder-option-to-specify-file '("-o")
  42   "*list of options of base64 decoder program to specify file.")
  43
  44
  45 ;;; @ internal base64 decoder/encoder
  46 ;;;     based on base64 decoder by Enami Tsugutomo
  47
  48 ;;; @@ convert from/to base64 char
  49 ;;;
  50
  51 (defun base64-num-to-char (n)
  52   (cond ((eq n nil) ?=)
  53         ((< n 26) (+ ?A n))
  54         ((< n 52) (+ ?a (- n 26)))
  55         ((< n 62) (+ ?0 (- n 52)))
  56         ((= n 62) ?+)
  57         ((= n 63) ?/)
  58         (t (error "not a base64 integer %d" n))))
  59
  60 (defun base64-char-to-num (c)
  61   (cond ((and (<= ?A c) (<= c ?Z)) (- c ?A))
  62         ((and (<= ?a c) (<= c ?z)) (+ (- c ?a) 26))
  63         ((and (<= ?0 c) (<= c ?9)) (+ (- c ?0) 52))
  64         ((= c ?+) 62)
  65         ((= c ?/) 63)
  66         ((= c ?=) nil)
  67         (t (error "not a base64 character %c" c))))
  68
  69
  70 ;;; @@ encode/decode one base64 unit
  71 ;;;
  72
  73 (defun base64-encode-1 (pack)
  74   (let ((a (car pack))
  75         (b (nth 1 pack))
  76         (c (nth 2 pack)))
  77     (concat
  78      (char-to-string (base64-num-to-char (ash a -2)))
  79      (if b
  80          (concat
  81           (char-to-string
  82            (base64-num-to-char (logior (ash (logand a 3) 4) (ash b -4))))
  83           (if c
  84               (concat
  85                (char-to-string
  86                 (base64-num-to-char (logior (ash (logand b 15) 2) (ash c -6))))
  87                (char-to-string (base64-num-to-char (logand c 63)))
  88                )
  89             (concat (char-to-string
  90                      (base64-num-to-char (ash (logand b 15) 2))) "=")
  91             ))
  92        (concat (char-to-string
  93                 (base64-num-to-char (ash (logand a 3) 4))) "==")
  94        ))))
  95
  96 (defun base64-decode-unit (a b &optional c d)
  97   (condition-case err
  98       (concat
  99        (char-to-string (logior (ash (base64-char-to-num a) 2)
 100                                (ash (setq b (base64-char-to-num b)) -4)))
 101        (if (and c (setq c (base64-char-to-num c)))
 102            (concat (char-to-string
 103                     (logior (ash (logand b 15) 4) (ash c -2)))
 104                    (if (and d (setq d (base64-char-to-num d)))
 105                        (char-to-string (logior (ash (logand c 3) 6) d))
 106                      ))))
 107     (error (message (nth 1 err))
 108            "")))
 109
 110
 111 ;;; @@ base64 encoder/decoder for string
 112 ;;;
 113
 114 (defun base64-internal-encode-string (string)
 115   "Encode STRING to base64, and return the result."
 116   (let ((len (length string))
 117         (b 0)(e 57)
 118         dest)
 119     (while (< e len)
 120       (setq dest
 121             (concat dest
 122                     (mapconcat
 123                      (function base64-encode-1)
 124                      (pack-sequence (substring string b e) 3)
 125                      "")
 126                     "\n"))
 127       (setq b e
 128             e (+ e 57)
 129             )
 130       )
 131     (let* ((es (mapconcat
 132                 (function base64-encode-1)
 133                 (pack-sequence (substring string b) 3)
 134                 ""))
 135            (m (mod (length es) 4))
 136            )
 137       (concat dest es (cond ((= m 3) "=")
 138                             ((= m 2) "==")
 139                             ))
 140       )))
 141
 142 (defun base64-internal-decode-string (string)
 143   (let ((len (length string))
 144         (i 0)
 145         dest)
 146     (while (< i len)
 147       (let ((a (aref string i)))
 148         (setq i (1+ i))
 149         (unless (eq a ?\n)
 150           (let ((b (aref string i)))
 151             (setq i (1+ i))
 152             (cond
 153              ((eq b ?\n)
 154               ;; invalid
 155               )
 156              ((>= i len)
 157               (setq dest (concat dest (base64-decode-unit a b) ))
 158               )
 159              (t
 160               (let ((c (aref string i)))
 161                 (setq i (1+ i))
 162                 (cond
 163                  ((eq c ?\n)
 164                   (setq dest (concat dest (base64-decode-unit a b)))
 165                   )
 166                  ((>= i len)
 167                   (setq dest (concat dest (base64-decode-unit a b c)))
 168                   )
 169                  (t
 170                   (let ((d (aref string i)))
 171                     (setq i (1+ i))
 172                     (setq dest
 173                           (concat dest
 174                                   (if (eq c ?\n)
 175                                       (base64-decode-unit a b c)
 176                                     (base64-decode-unit a b c d))))
 177                     ))))))))))
 178     dest))
 179
 180
 181 ;;; @ base64 encoder/decoder for region
 182 ;;;
 183
 184 (defun base64-internal-encode-region (beg end)
 185   (save-excursion
 186     (save-restriction
 187       (narrow-to-region beg end)
 188       (let ((str (buffer-substring beg end)))
 189         (delete-region beg end)
 190         (insert (base64-internal-encode-string str))
 191         )
 192       (or (bolp)
 193           (insert "\n")
 194           )
 195       )))
 196
 197 (defun base64-internal-decode-region (beg end)
 198   (save-excursion
 199     (let ((str (buffer-substring beg end)))
 200       (delete-region beg end)
 201       (goto-char beg)
 202       (insert (base64-internal-decode-string str)))))
 203
 204 (defun base64-external-encode-region (beg end)
 205   (save-excursion
 206     (save-restriction
 207       (narrow-to-region beg end)
 208       (as-binary-process (apply (function call-process-region)
 209                                 beg end (car base64-external-encoder)
 210                                 t t nil (cdr base64-external-encoder))
 211                          )
 212       ;; for OS/2
 213       ;;   regularize line break code
 214       (goto-char (point-min))
 215       (while (re-search-forward "\r$" nil t)
 216         (replace-match "")
 217         )
 218       )))
 219
 220 (defun base64-external-decode-region (beg end)
 221   (save-excursion
 222     (as-binary-process (apply (function call-process-region)
 223                               beg end (car base64-external-decoder)
 224                               t t nil (cdr base64-external-decoder))
 225                        )))
 226
 227 (defun base64-external-decode-string (string)
 228   (with-temp-buffer
 229     (insert string)
 230     (as-binary-process (apply (function call-process-region)
 231                               (point-min) (point-max)
 232                               (car base64-external-decoder)
 233                               t t nil (cdr base64-external-decoder))
 234                        )
 235     (buffer-string)))
 236
 237
 238 ;;; @ base64 encoder/decoder for file
 239 ;;;
 240
 241 (defun base64-external-insert-encoded-file (filename)
 242   "Encode contents of file FILENAME to base64, and insert the result.
 243 It calls external base64 encoder specified by
 244 `base64-external-encoder'.  So you must install the program (maybe
 245 mmencode included in metamail or XEmacs package)."
 246   (interactive (list (read-file-name "Insert encoded file: ")))
 247   (apply (function call-process) (car base64-external-encoder)
 248          filename t nil (cdr base64-external-encoder))
 249   )
 250
 251 (defun base64-external-write-decoded-region (start end filename)
 252   "Decode and write current region encoded by base64 into FILENAME.
 253 START and END are buffer positions."
 254   (interactive
 255    (list (region-beginning) (region-end)
 256          (read-file-name "Write decoded region to file: ")))
 257   (as-binary-process
 258    (apply (function call-process-region)
 259           start end (car base64-external-decoder)
 260           nil nil nil
 261           (append (cdr base64-external-decoder)
 262                   base64-external-decoder-option-to-specify-file
 263                   (list filename))
 264           )))
 265
 266
 267 ;;; @ etc
 268 ;;;
 269
 270 (defun base64-internal-encoded-length (string)
 271   (let ((len (length string)))
 272     (* (+ (/ len 3)
 273           (if (= (mod len 3) 0) 0 1)
 274           ) 4)
 275     ))
 276
 277 (defun pack-sequence (seq size)
 278   "Split sequence SEQ into SIZE elements packs,
 279 and return list of packs. [mel-b; tl-seq function]"
 280   (let ((len (length seq)) (p 0) obj
 281         unit (i 0)
 282         dest)
 283     (while (< p len)
 284       (setq obj (elt seq p))
 285       (setq unit (cons obj unit))
 286       (setq i (1+ i))
 287       (if (= i size)
 288           (progn
 289             (setq dest (cons (reverse unit) dest))
 290             (setq unit nil)
 291             (setq i 0)
 292             ))
 293       (setq p (1+ p))
 294       )
 295     (if unit
 296         (setq dest (cons (reverse unit) dest))
 297       )
 298     (reverse dest)
 299     ))
 300
 301
 302 ;;; @ end
 303 ;;;
 304
 305 (provide 'mel-b)
 306
 307 ;;; mel-b.el ends here.