mel.el

   1 ;;; mel.el : a MIME encoding/decoding library
   2
   3 ;; Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.
   4
   5 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   6 ;; modified by Shuhei KOBAYASHI <shuhei-k@jaist.ac.jp>
   7 ;; Created: 1995/6/25
   8 ;; Keywords: MIME, Base64, Quoted-Printable, uuencode, gzip64
   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 ;;; @ encoder/decoder selection framework
  33 ;;;
  34
  35 (defconst mel-stems '(dl ccl int-ext external internal)
  36   "List of encoder/decoder stems. First stem is most prefered.")
  37
  38 (defmacro mel-call-next (fun formal-args)
  39   (let ((caller 'funcall)
  40         actual-args)
  41     (while formal-args
  42       (cond
  43         ((eq (car formal-args) '&optional) nil)
  44         ((eq (car formal-args) '&rest) (setq caller 'apply))
  45         (t (setq actual-args (cons (car formal-args) actual-args))))
  46       (setq formal-args (cdr formal-args)))
  47     `(,caller ',fun ,@(nreverse actual-args))))
  48
  49 (defmacro mel-defgeneric (prefix suffix formal-args &rest docstring-interactive)
  50   "Define a generic function named PREFIX-SUFFIX for mel.
  51 Arguments for the function is specified as FORMAL-ARGS as usual.
  52 Rest of arguments DOCSTRING-INTERACTIVE should be DOCSTRING and/or
  53 interactive specification placed at front of a function body."
  54   (let ((name (intern (format "%s-%s" prefix suffix)))
  55         (stems (make-symbol "stems")))
  56     (put name 'prefix prefix)
  57     (put name 'suffix suffix)
  58     `(progn
  59       (put ',name 'stems mel-stems)
  60       (put ',name 'prefix ',prefix)
  61       (put ',name 'suffix ',suffix)
  62       (defun ,name ,formal-args
  63         ,@docstring-interactive
  64         (catch 'return
  65           (let ((,stems (get ',name 'stems)) method)
  66             (while ,stems
  67               (when (setq method (get ',name (car ,stems)))
  68                 (fset ',name method)
  69                 (throw 'return (mel-call-next ,name ,formal-args)))
  70               (setq ,stems (cdr ,stems))))
  71           (error ,(format "%s: no method" name)))))))
  72
  73 (defmacro mel-defmodule (prefix stem &optional file)
  74   "Declare that FILE defines functions PREFIX-STEM-*.
  75 If FILE is nil, `mel-PREFIX-STEM' is assumed."
  76   (unless file
  77     (setq file (format "mel-%s-%s" prefix stem)))
  78   (put prefix stem file)
  79   `(put ',prefix ',stem ,file))
  80
  81 (defmacro mel-defmethod (name stem &optional file)
  82   "Declare that NAME is implemented by STEM in FILE.
  83 If FILE is nil, module declared with `mel-defmoeudle' is used."
  84   (let* ((prefix (get name 'prefix))
  85          (suffix (get name 'suffix))
  86          (qualified (intern (format "%s-%s-%s" prefix stem suffix))))
  87     (unless file
  88       (setq file (get prefix stem)))
  89     (unless file
  90       (error "No file defines %s." qualified))
  91     `(progn
  92       (autoload ',qualified ,file)
  93       (put ',name ',stem ',qualified))))
  94
  95
  96 ;;; @ generic
  97 ;;;
  98
  99 (mel-defgeneric base64 encode-string (string)
 100   "Encode STRING with base64.")
 101 (mel-defgeneric base64 decode-string (string)
 102   "Decode STRING with base64.")
 103 (mel-defgeneric base64 encode-region (start end)
 104   "Encode current region with base64."
 105   (interactive "r"))
 106 (mel-defgeneric base64 decode-region (start end)
 107   "Decode current region with base64."
 108   (interactive "r"))
 109 (mel-defgeneric base64 insert-encoded-file (filename)
 110   "Insert a file named FILENAME as base64 encoded form."
 111   (interactive (list (read-file-name "Insert encoded file: "))))
 112 (mel-defgeneric base64 write-decoded-region (start end filename)
 113   "Decode and write base64 encoded current region to a file named FILENAME."
 114   (interactive
 115     (list (region-beginning) (region-end)
 116           (read-file-name "Write decoded region to file: "))))
 117 (mel-defgeneric base64 encoded-length (string))
 118
 119 (mel-defgeneric quoted-printable encode-string (string)
 120   "Encode STRING with quoted-printable.")
 121 (mel-defgeneric quoted-printable decode-string (string)
 122   "Decode STRING with quoted-printable.")
 123 (mel-defgeneric quoted-printable encode-region (start end)
 124   "Encode current region with quoted-printable."
 125   (interactive "r"))
 126 (mel-defgeneric quoted-printable decode-region (start end)
 127   "Decode current region with quoted-printable."
 128   (interactive "r"))
 129 (mel-defgeneric quoted-printable insert-encoded-file (filename)
 130   "Insert a file named FILENAME as quoted-printable encoded form."
 131   (interactive (list (read-file-name "Insert encoded file: "))))
 132 (mel-defgeneric quoted-printable write-decoded-region (start end filename)
 133   "Decode and write quoted-printable encoded current region to a file named FILENAME."
 134   (interactive
 135     (list (region-beginning) (region-end)
 136           (read-file-name "Write decoded region to file: "))))
 137
 138 (mel-defgeneric q-encoding encode-string (string &optional mode)
 139   "Encode STRING with Q-encoding.
 140 If MODE is `text', `comment' or `phrase', the result is appropriate for
 141 unstructured field, comment or phrase in structured field.
 142 If MODE is nil, the result is appropriate for phrase.")
 143 (mel-defgeneric q-encoding decode-string (string)
 144   "Decode STRING with Q-encoding.")
 145 (mel-defgeneric q-encoding encoded-length (string mode))
 146
 147 (mel-defgeneric uuencode encode-region (start end)
 148   "Encode current region by unofficial uuencode format."
 149   (interactive "*r"))
 150 (mel-defgeneric uuencode decode-region (start end)
 151   "Decode current region by unofficial uuencode format."
 152   (interactive "*r"))
 153 (mel-defgeneric uuencode insert-encoded-file (filename)
 154   "Insert file encoded by unofficial uuencode format."
 155   (interactive (list (read-file-name "Insert encoded file: "))))
 156 (mel-defgeneric uuencode write-decoded-region (start end filename)
 157   "Decode and write current region encoded by uuencode into FILENAME."
 158   (interactive
 159    (list (region-beginning) (region-end)
 160          (read-file-name "Write decoded region to file: "))))
 161
 162 (mel-defgeneric gzip64 encode-region (start end)
 163   "Encode current region by unofficial gzip64 format."
 164   (interactive "*r"))
 165 (mel-defgeneric gzip64 decode-region (start end)
 166   "Decode current region by unofficial gzip64 format."
 167   (interactive "*r"))
 168 (mel-defgeneric gzip64 insert-encoded-file (filename)
 169   "Insert file encoded by unofficial gzip64 format."
 170   (interactive (list (read-file-name "Insert encoded file: "))))
 171 (mel-defgeneric gzip64 write-decoded-region (start end filename)
 172   "Decode and write current region encoded by gzip64 into FILENAME."
 173   (interactive
 174    (list (region-beginning) (region-end)
 175          (read-file-name "Write decoded region to file: "))))
 176
 177 ;;; @ method
 178 ;;;
 179
 180 ;; mel-dl
 181 (mel-defmodule base64 dl "mel-dl")
 182
 183 (defvar base64-dl-module
 184   (and (fboundp 'dynamic-link)
 185        (let ((path (expand-file-name "base64.so" exec-directory)))
 186          (and (file-exists-p path)
 187               path))))
 188
 189 (when base64-dl-module
 190   (mel-defmethod base64-encode-string dl)
 191   (mel-defmethod base64-decode-string dl)
 192   (mel-defmethod base64-encode-region dl)
 193   (mel-defmethod base64-decode-region dl)
 194   )
 195
 196 ;; mel-b
 197 (mel-defmodule base64 internal "mel-b")
 198 (mel-defmodule base64 external "mel-b")
 199 (mel-defmodule base64 int-ext "mel-b")
 200
 201 (mel-defmethod base64-encode-string internal)
 202 (mel-defmethod base64-decode-string internal)
 203 (mel-defmethod base64-encode-region internal)
 204 (mel-defmethod base64-decode-region internal)
 205 (mel-defmethod base64-insert-encoded-file internal)
 206 (mel-defmethod base64-write-decoded-region internal)
 207
 208 (mel-defmethod base64-encode-string external)
 209 (mel-defmethod base64-decode-string external)
 210 (mel-defmethod base64-encode-region external)
 211 (mel-defmethod base64-decode-region external)
 212 (mel-defmethod base64-insert-encoded-file external)
 213 (mel-defmethod base64-write-decoded-region external)
 214
 215 (mel-defmethod base64-encoded-length internal)
 216
 217 (mel-defmethod base64-decode-string int-ext)
 218 (mel-defmethod base64-encode-region int-ext)
 219 (mel-defmethod base64-decode-region int-ext)
 220 (mel-defmethod base64-insert-encoded-file int-ext)
 221 (mel-defmethod base64-write-decoded-region int-ext)
 222
 223 ;; mel-q
 224 (mel-defmodule quoted-printable internal "mel-q")
 225 (mel-defmodule quoted-printable external "mel-q")
 226 (mel-defmodule quoted-printable int-ext "mel-q")
 227 (mel-defmodule q-encoding internal "mel-q")
 228
 229 (mel-defmethod quoted-printable-encode-string internal)
 230 (mel-defmethod quoted-printable-decode-string internal)
 231 (mel-defmethod quoted-printable-encode-region internal)
 232 (mel-defmethod quoted-printable-decode-region internal)
 233
 234 (mel-defmethod quoted-printable-encode-string external)
 235 (mel-defmethod quoted-printable-decode-string external)
 236 (mel-defmethod quoted-printable-encode-region external)
 237 (mel-defmethod quoted-printable-decode-region external)
 238 (mel-defmethod quoted-printable-insert-encoded-file external)
 239 (mel-defmethod quoted-printable-write-decoded-region external)
 240
 241 (mel-defmethod quoted-printable-encode-region int-ext)
 242 (mel-defmethod quoted-printable-decode-region int-ext)
 243
 244 (mel-defmethod q-encoding-encode-string internal)
 245 (mel-defmethod q-encoding-decode-string internal)
 246 (mel-defmethod q-encoding-encoded-length internal)
 247
 248 ;; mel-u
 249 (mel-defmodule uuencode external "mel-u")
 250
 251 (mel-defmethod uuencode-encode-region external)
 252 (mel-defmethod uuencode-decode-region external)
 253 (mel-defmethod uuencode-insert-encoded-file external)
 254 (mel-defmethod uuencode-write-decoded-region external)
 255
 256 ;; mel-g
 257 (mel-defmodule gzip64 external "mel-g")
 258
 259 (mel-defmethod gzip64-encode-region external)
 260 (mel-defmethod gzip64-decode-region external)
 261 (mel-defmethod gzip64-insert-encoded-file external)
 262 (mel-defmethod gzip64-write-decoded-region external)
 263
 264 ;; mel-ccl
 265 (mel-defmodule base64 ccl "mel-ccl")
 266 (mel-defmodule quoted-printable ccl "mel-ccl")
 267 (mel-defmodule q-encoding ccl "mel-ccl")
 268
 269 (when (fboundp 'make-ccl-coding-system)
 270   (unless (and (boundp 'ccl-encoder-eof-block-is-broken)
 271                ccl-encoder-eof-block-is-broken)
 272     (mel-defmethod base64-encode-string ccl)
 273     (mel-defmethod base64-encode-region ccl)
 274     (mel-defmethod base64-insert-encoded-file ccl)
 275
 276     (mel-defmethod quoted-printable-encode-string ccl)
 277     (mel-defmethod quoted-printable-encode-region ccl)
 278     (mel-defmethod quoted-printable-insert-encoded-file ccl)
 279     )
 280
 281   (mel-defmethod base64-decode-string ccl)
 282   (mel-defmethod base64-decode-region ccl)
 283   (mel-defmethod base64-write-decoded-region ccl)
 284
 285   (mel-defmethod quoted-printable-decode-string ccl)
 286   (mel-defmethod quoted-printable-decode-region ccl)
 287   (mel-defmethod quoted-printable-write-decoded-region ccl)
 288
 289   (mel-defmethod q-encoding-encode-string ccl)
 290   (mel-defmethod q-encoding-decode-string ccl)
 291
 292   (unless running-xemacs
 293     (mel-defmethod q-encoding-encoded-length ccl)
 294     )
 295   )
 296
 297
 298 ;;; @ region
 299 ;;;
 300
 301 ;;;###autoload
 302 (defvar mime-encoding-method-alist
 303   '(("base64"           . base64-encode-region)
 304     ("quoted-printable" . quoted-printable-encode-region)
 305     ;; Not standard, their use is DISCOURAGED.
 306     ;; ("x-uue"            . uuencode-encode-region)
 307     ;; ("x-gzip64"         . gzip64-encode-region)
 308     ("7bit")
 309     ("8bit")
 310     ("binary")
 311     )
 312   "Alist of encoding vs. corresponding method to encode region.
 313 Each element looks like (STRING . FUNCTION) or (STRING . nil).
 314 STRING is content-transfer-encoding.
 315 FUNCTION is region encoder and nil means not to encode.")
 316
 317 ;;;###autoload
 318 (defvar mime-decoding-method-alist
 319   `(("base64"           . base64-decode-region)
 320     ("quoted-printable" . quoted-printable-decode-region)
 321     ("x-uue"            . uuencode-decode-region)
 322     ("x-uuencode"       . uuencode-decode-region)
 323     ("x-gzip64"         . gzip64-decode-region)
 324     ,@(when (fboundp 'base64-dl-decode-region)
 325         '(("base64-dl" . base64-dl-decode-region)))
 326     ,@(when (fboundp 'base64-ccl-decode-region)
 327         '(("base64-ccl" . base64-ccl-decode-region)))
 328     ,@(when (fboundp 'base64-internal-decode-region)
 329         '(("base64-internal" . base64-internal-decode-region)))
 330     ,@(when (fboundp 'base64-external-decode-region)
 331         '(("base64-external" . base64-external-decode-region)))
 332     ,@(when (fboundp 'base64-int-ext-decode-region)
 333         '(("base64-int-ext" . base64-int-ext-decode-region)))
 334     ,@(when (fboundp 'quoted-printable-internal-decode-region)
 335         '(("quoted-printable-internal" . quoted-printable-internal-decode-region)))
 336     ,@(when (fboundp 'quoted-printable-ccl-decode-region)
 337         '(("quoted-printable-ccl" . quoted-printable-ccl-decode-region)))
 338     ,@(when (fboundp 'quoted-printable-external-decode-region)
 339         '(("quoted-printable-external" . quoted-printable-external-decode-region)))
 340     ,@(when (fboundp 'quoted-printable-int-ext-decode-region)
 341         '(("quoted-printable-int-ext" . quoted-printable-int-ext-decode-region)))
 342     )
 343   "Alist of encoding vs. corresponding method to decode region.
 344 Each element looks like (STRING . FUNCTION).
 345 STRING is content-transfer-encoding.
 346 FUNCTION is region decoder.")
 347
 348 ;;;###autoload
 349 (defun mime-encode-region (start end encoding)
 350   "Encode region START to END of current buffer using ENCODING.
 351 ENCODING must be string.  If ENCODING is found in
 352 `mime-encoding-method-alist' as its key, this function encodes the
 353 region by its value."
 354   (interactive
 355    (list (region-beginning) (region-end)
 356          (completing-read "encoding: "
 357                           mime-encoding-method-alist
 358                           nil t "base64"))
 359    )
 360   (let ((f (cdr (assoc encoding mime-encoding-method-alist))))
 361     (if f
 362         (funcall f start end)
 363       )))
 364
 365 ;;;###autoload
 366 (defun mime-decode-region (start end encoding)
 367   "Decode region START to END of current buffer using ENCODING.
 368 ENCODING must be string.  If ENCODING is found in
 369 `mime-decoding-method-alist' as its key, this function decodes the
 370 region by its value."
 371   (interactive
 372    (list (region-beginning) (region-end)
 373          (completing-read "encoding: "
 374                           mime-decoding-method-alist
 375                           nil t "base64"))
 376    )
 377   (let ((f (cdr (assoc encoding mime-decoding-method-alist))))
 378     (if f
 379         (funcall f start end)
 380       )))
 381
 382
 383 ;;; @ string
 384 ;;;
 385
 386 ;;;###autoload
 387 (defvar mime-string-decoding-method-alist
 388   '(("base64"           . base64-decode-string)
 389     ("quoted-printable" . quoted-printable-decode-string)
 390     ("7bit"             . identity)
 391     ("8bit"             . identity)
 392     ("binary"           . identity)
 393     )
 394   "Alist of encoding vs. corresponding method to decode string.
 395 Each element looks like (STRING . FUNCTION).
 396 STRING is content-transfer-encoding.
 397 FUNCTION is string decoder.")
 398
 399 ;;;###autoload
 400 (defun mime-decode-string (string encoding)
 401   "Decode STRING using ENCODING.
 402 ENCODING must be string.  If ENCODING is found in
 403 `mime-string-decoding-method-alist' as its key, this function decodes
 404 the STRING by its value."
 405   (let ((f (cdr (assoc encoding mime-string-decoding-method-alist))))
 406     (if f
 407         (funcall f string)
 408       (with-temp-buffer
 409         (insert string)
 410         (mime-decode-region (point-min)(point-max) encoding)
 411         (buffer-string)
 412         ))))
 413
 414
 415 ;;; @ file
 416 ;;;
 417
 418 ;;;###autoload
 419 (defvar mime-file-encoding-method-alist
 420   '(("base64"           . base64-insert-encoded-file)
 421     ("quoted-printable" . quoted-printable-insert-encoded-file)
 422     ;; Not standard, their use is DISCOURAGED.
 423     ;; ("x-uue"            . uuencode-insert-encoded-file)
 424     ;; ("x-gzip64"         . gzip64-insert-encoded-file)
 425     ("7bit"             . insert-file-contents-as-binary)
 426     ("8bit"             . insert-file-contents-as-binary)
 427     ("binary"           . insert-file-contents-as-binary)
 428     )
 429   "Alist of encoding vs. corresponding method to insert encoded file.
 430 Each element looks like (STRING . FUNCTION).
 431 STRING is content-transfer-encoding.
 432 FUNCTION is function to insert encoded file.")
 433
 434 ;;;###autoload
 435 (defvar mime-file-decoding-method-alist
 436   `(("base64"           . base64-write-decoded-region)
 437     ("quoted-printable" . quoted-printable-write-decoded-region)
 438     ("x-uue"            . uuencode-write-decoded-region)
 439     ("x-gzip64"         . gzip64-write-decoded-region)
 440     ("7bit"             . write-region-as-binary)
 441     ("8bit"             . write-region-as-binary)
 442     ("binary"           . write-region-as-binary)
 443     ,@(when (fboundp 'base64-internal-write-decoded-region)
 444         '(("base64-internal" . base64-internal-write-decoded-region)))
 445     ,@(when (fboundp 'base64-external-write-decoded-region)
 446         '(("base64-external" . base64-external-write-decoded-region)))
 447     ,@(when (fboundp 'base64-int-ext-write-decoded-region)
 448         '(("base64-int-ext" . base64-int-ext-write-decoded-region)))
 449     ,@(when (fboundp 'base64-ccl-write-decoded-region)
 450         '(("base64-ccl" . base64-ccl-write-decoded-region)))
 451     ,@(when (fboundp 'quoted-printable-external-write-decoded-region)
 452         '(("quoted-printable-external" . quoted-printable-external-write-decoded-region)))
 453     ,@(when (fboundp 'quoted-printable-ccl-write-decoded-region)
 454         '(("quoted-printable-ccl" . quoted-printable-ccl-write-decoded-region)))
 455     )
 456   "Alist of encoding vs. corresponding method to write decoded region to file.
 457 Each element looks like (STRING . FUNCTION).
 458 STRING is content-transfer-encoding.
 459 FUNCTION is function to write decoded region to file.")
 460
 461 ;;;###autoload
 462 (defun mime-insert-encoded-file (filename encoding)
 463   "Insert file FILENAME encoded by ENCODING format."
 464   (interactive
 465    (list (read-file-name "Insert encoded file: ")
 466          (completing-read "encoding: "
 467                           mime-encoding-method-alist
 468                           nil t "base64"))
 469    )
 470   (let ((f (cdr (assoc encoding mime-file-encoding-method-alist))))
 471     (if f
 472         (funcall f filename)
 473       )))
 474
 475 ;;;###autoload
 476 (defun mime-write-decoded-region (start end filename encoding)
 477   "Decode and write current region encoded by ENCODING into FILENAME.
 478 START and END are buffer positions."
 479   (interactive
 480    (list (region-beginning) (region-end)
 481          (read-file-name "Write decoded region to file: ")
 482          (completing-read "encoding: "
 483                           mime-file-decoding-method-alist
 484                           nil t "base64")))
 485   (let ((f (cdr (assoc encoding mime-file-decoding-method-alist))))
 486     (if f
 487         (funcall f start end filename)
 488       )))
 489
 490
 491 ;;; @ end
 492 ;;;
 493
 494 (provide 'mel)
 495
 496 ;;; mel.el ends here.