cgit.sxemacs.org Git - gnus/blob - lisp/mm-uu.el

   1 ;;; mm-uu.el -- Return uu stuffs as mm handles
   2 ;; Copyright (c) 1998, 1999, 2000 Free Software Foundation, Inc.
   3
   4 ;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
   5 ;; Keywords: postscript uudecode binhex shar forward gnatsweb pgp
   6
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 2, or (at your option)
  12 ;; any later version.
  13 ;;
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22 ;; Boston, MA 02111-1307, USA.
  23
  24 ;;; Commentary:
  25
  26
  27 ;;; Code:
  28
  29 (eval-when-compile (require 'cl))
  30 (require 'mail-parse)
  31 (require 'nnheader)
  32 (require 'mm-decode)
  33 (require 'mailcap)
  34 (require 'mml2015)
  35
  36 (eval-and-compile
  37   (autoload 'binhex-decode-region "binhex")
  38   (autoload 'binhex-decode-region-external "binhex")
  39   (autoload 'uudecode-decode-region "uudecode")
  40   (autoload 'uudecode-decode-region-external "uudecode"))
  41
  42 (defcustom mm-uu-decode-function 'uudecode-decode-region
  43   "*Function to uudecode.
  44 Internal function is done in elisp by default, therefore decoding may
  45 appear to be horribly slow . You can make Gnus use the external Unix
  46 decoder, such as uudecode."
  47   :type '(choice (item :tag "internal" uudecode-decode-region)
  48                  (item :tag "external" uudecode-decode-region-external))
  49   :group 'gnus-article-mime)
  50
  51 (defcustom mm-uu-binhex-decode-function 'binhex-decode-region
  52   "*Function to binhex decode.
  53 Internal function is done in elisp by default, therefore decoding may
  54 appear to be horribly slow . You can make Gnus use the external Unix
  55 decoder, such as hexbin."
  56   :type '(choice (item :tag "internal" binhex-decode-region)
  57                  (item :tag "external" binhex-decode-region-external))
  58   :group 'gnus-article-mime)
  59
  60 (defvar mm-uu-pgp-beginning-signature
  61      "^-----BEGIN PGP SIGNATURE-----")
  62
  63 (defvar mm-uu-beginning-regexp nil)
  64
  65 (defvar mm-dissect-disposition "inline"
  66   "The default disposition of uu parts.
  67 This can be either \"inline\" or \"attachment\".")
  68
  69 (defvar mm-uu-type-alist
  70   '((postscript
  71      "^%!PS-"
  72      "^%%EOF$"
  73      mm-uu-postscript-extract
  74      nil)
  75     (uu
  76      "^begin[ \t]+[0-7][0-7][0-7][ \t]+"
  77      "^end[ \t]*$"
  78      mm-uu-uu-extract
  79      mm-uu-uu-filename)
  80     (binhex
  81      "^:...............................................................$"
  82      ":$"
  83      mm-uu-binhex-extract
  84      nil
  85      mm-uu-binhex-filename)
  86     (shar
  87      "^#! */bin/sh"
  88      "^exit 0\\|^$"
  89      mm-uu-shar-extract)
  90     (forward
  91 ;;; Thanks to Edward J. Sabol <sabol@alderaan.gsfc.nasa.gov> and
  92 ;;; Peter von der Ah\'e <pahe@daimi.au.dk>
  93      "^-+ \\(Start of \\)?Forwarded message"
  94      "^-+ End \\(of \\)?forwarded message"
  95      mm-uu-forward-extract
  96      nil
  97      mm-uu-forward-test)
  98     (gnatsweb
  99      "^----gnatsweb-attachment----"
 100      nil
 101      mm-uu-gnatsweb-extract)
 102     (pgp-signed
 103      "^-----BEGIN PGP SIGNED MESSAGE-----"
 104      "^-----END PGP SIGNATURE-----"
 105      mm-uu-pgp-signed-extract
 106      nil
 107      mm-uu-pgp-signed-test)
 108     (pgp-encrypted
 109      "^-----BEGIN PGP MESSAGE-----"
 110      "^-----END PGP MESSAGE-----"
 111      mm-uu-pgp-encrypted-extract
 112      nil
 113      mm-uu-pgp-encrypted-test)
 114     (pgp-key
 115      "^-----BEGIN PGP PUBLIC KEY BLOCK-----"
 116      "^-----END PGP PUBLIC KEY BLOCK-----"
 117      mm-uu-pgp-key-extract
 118      mm-uu-gpg-key-skip-to-last
 119      nil)))
 120
 121 (defcustom mm-uu-configure-list nil
 122   "A list of mm-uu configuration.
 123 To disable dissecting shar codes, for instance, add
 124 `(shar . disabled)' to this list."
 125   :type `(repeat (cons
 126                   ,(cons 'choice
 127                          (mapcar
 128                           (lambda (entry)
 129                             (cons 'item (car entry)))
 130                           mm-uu-type-alist))
 131                   (choice (item disabled))))
 132   :group 'gnus-article-mime)
 133
 134 ;; functions
 135
 136 (defsubst mm-uu-type (entry)
 137   (car entry))
 138
 139 (defsubst mm-uu-beginning-regexp (entry)
 140   (nth 1 entry))
 141
 142 (defsubst mm-uu-end-regexp (entry)
 143   (nth 2 entry))
 144
 145 (defsubst mm-uu-function-extract (entry)
 146   (nth 3 entry))
 147
 148 (defsubst mm-uu-function-1 (entry)
 149   (nth 4 entry))
 150
 151 (defsubst mm-uu-function-2 (entry)
 152   (nth 5 entry))
 153
 154 (defun mm-uu-copy-to-buffer (from to)
 155   "Copy the contents of the current buffer to a fresh buffer."
 156   (save-excursion
 157     (let ((obuf (current-buffer)))
 158       (set-buffer (generate-new-buffer " *mm-uu*"))
 159       (insert-buffer-substring obuf from to)
 160       (current-buffer))))
 161
 162 (defun mm-uu-configure-p  (key val)
 163   (member (cons key val) mm-uu-configure-list))
 164
 165 (defun mm-uu-configure (&optional symbol value)
 166   (if symbol (set-default symbol value))
 167   (setq mm-uu-beginning-regexp nil)
 168   (mapcar (lambda (entry)
 169              (if (mm-uu-configure-p (mm-uu-type entry) 'disabled)
 170                  nil
 171                (setq mm-uu-beginning-regexp
 172                      (concat mm-uu-beginning-regexp
 173                              (if mm-uu-beginning-regexp "\\|")
 174                              (mm-uu-beginning-regexp entry)))))
 175           mm-uu-type-alist))
 176
 177 (mm-uu-configure)
 178
 179 (eval-when-compile
 180   (defvar file-name)
 181   (defvar start-point)
 182   (defvar end-point)
 183   (defvar entry))
 184
 185 (defun mm-uu-uu-filename ()
 186   (if (looking-at ".+")
 187       (setq file-name
 188             (let ((nnheader-file-name-translation-alist
 189                    '((?/ . ?,) (? . ?_) (?* . ?_) (?$ . ?_))))
 190               (nnheader-translate-file-chars (match-string 0))))))
 191
 192 (defun mm-uu-binhex-filename ()
 193   (setq file-name
 194         (ignore-errors
 195           (binhex-decode-region start-point end-point t))))
 196
 197 (defun mm-uu-forward-test ()
 198   (save-excursion
 199     (goto-char start-point)
 200     (forward-line)
 201     (looking-at "[\r\n]*[a-zA-Z][a-zA-Z0-9-]*:")))
 202
 203 (defun mm-uu-postscript-extract ()
 204   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
 205                   '("application/postscript")))
 206
 207 (defun mm-uu-forward-extract ()
 208   (mm-make-handle (mm-uu-copy-to-buffer
 209                    (progn (goto-char start-point) (forward-line) (point))
 210                    (progn (goto-char end-point) (forward-line -1) (point)))
 211                   '("message/rfc822" (charset . gnus-decoded))))
 212
 213 (defun mm-uu-uu-extract ()
 214   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
 215                   (list (or (and file-name
 216                                  (string-match "\\.[^\\.]+$"
 217                                                file-name)
 218                                  (mailcap-extension-to-mime
 219                                   (match-string 0 file-name)))
 220                             "application/octet-stream"))
 221                   'x-uuencode nil
 222                   (if (and file-name (not (equal file-name "")))
 223                       (list mm-dissect-disposition
 224                             (cons 'filename file-name)))))
 225
 226 (defun mm-uu-binhex-extract ()
 227   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
 228                   (list (or (and file-name
 229                                  (string-match "\\.[^\\.]+$" file-name)
 230                                  (mailcap-extension-to-mime
 231                                   (match-string 0 file-name)))
 232                             "application/octet-stream"))
 233                   'x-binhex nil
 234                   (if (and file-name (not (equal file-name "")))
 235                       (list mm-dissect-disposition
 236                             (cons 'filename file-name)))))
 237
 238 (defun mm-uu-shar-extract ()
 239   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
 240                   '("application/x-shar")))
 241
 242 (defun mm-uu-gnatsweb-extract ()
 243   (save-restriction
 244     (goto-char start-point)
 245     (forward-line)
 246     (narrow-to-region (point) end-point)
 247     (mm-dissect-buffer t)))
 248
 249 (defun mm-uu-pgp-signed-test ()
 250   (and
 251    mml2015-use
 252    (mml2015-clear-verify-function)
 253    (cond
 254     ((eq mm-verify-option 'never) nil)
 255     ((eq mm-verify-option 'always) t)
 256     ((eq mm-verify-option 'known) t)
 257     (t (y-or-n-p "Verify pgp signed part?")))))
 258
 259 (defun mm-uu-pgp-signed-extract ()
 260   (let ((buf (mm-uu-copy-to-buffer start-point end-point))
 261         (mm-security-handle (list (format "multipart/signed"))))
 262     (mm-set-handle-multipart-parameter
 263      mm-security-handle 'protocol "application/pgp-signature")
 264     (with-current-buffer buf
 265       (funcall (mml2015-clear-verify-function))
 266       (goto-char (point-min))
 267       (if (search-forward "\n\n" nil t)
 268           (delete-region (point-min) (point)))
 269       (if (re-search-forward mm-uu-pgp-beginning-signature nil t)
 270           (delete-region (match-beginning 0) (point-max))))
 271     (setcdr mm-security-handle
 272             (list
 273              (mm-make-handle buf
 274                              '("text/plain"  (charset . gnus-decoded)))))
 275     mm-security-handle))
 276
 277 (defun mm-uu-pgp-encrypted-test ()
 278   (and
 279    mml2015-use
 280    (mml2015-clear-decrypt-function)
 281    (cond
 282     ((eq mm-decrypt-option 'never) nil)
 283     ((eq mm-decrypt-option 'always) t)
 284     ((eq mm-decrypt-option 'known) t)
 285     (t (y-or-n-p "Decrypt pgp encrypted part?")))))
 286
 287 (defun mm-uu-pgp-encrypted-extract ()
 288   (let ((buf (mm-uu-copy-to-buffer start-point end-point))
 289         (mm-security-handle (list (format "multipart/encrypted"))))
 290     (mm-set-handle-multipart-parameter
 291      mm-security-handle 'protocol "application/pgp-encrypted")
 292     (with-current-buffer buf
 293       (funcall (mml2015-clear-decrypt-function)))
 294     (setcdr mm-security-handle
 295             (list
 296              (mm-make-handle buf
 297                              '("text/plain"  (charset . gnus-decoded)))))
 298     mm-security-handle))
 299
 300 (defun mm-uu-gpg-key-skip-to-last ()
 301   (let ((point (point))
 302         (end-regexp (mm-uu-end-regexp entry))
 303         (beginning-regexp (mm-uu-beginning-regexp entry)))
 304     (when (and end-regexp
 305                (not (mm-uu-configure-p (mm-uu-type entry) 'disabled)))
 306       (while (re-search-forward end-regexp nil t)
 307         (skip-chars-forward " \t\n\r")
 308         (if (looking-at beginning-regexp)
 309             (setq point (match-end 0)))))
 310     (goto-char point)))
 311
 312 (defun mm-uu-pgp-key-extract ()
 313   (let ((buf (mm-uu-copy-to-buffer start-point end-point)))
 314     (mm-make-handle buf
 315                     '("application/pgp-keys"))))
 316
 317 ;;;### autoload
 318 (defun mm-uu-dissect ()
 319   "Dissect the current buffer and return a list of uu handles."
 320   (let ((case-fold-search t)
 321         text-start start-point end-point file-name result
 322         text-plain-type entry func)
 323     (save-excursion
 324       (goto-char (point-min))
 325       (cond
 326        ((looking-at "\n")
 327         (forward-line))
 328        ((search-forward "\n\n" nil t)
 329         t)
 330        (t (goto-char (point-max))))
 331       ;;; gnus-decoded is a fake charset, which means no further
 332       ;;; decoding.
 333       (setq text-start (point)
 334             text-plain-type '("text/plain"  (charset . gnus-decoded)))
 335       (while (re-search-forward mm-uu-beginning-regexp nil t)
 336         (setq start-point (match-beginning 0))
 337         (let ((alist mm-uu-type-alist)
 338               (beginning-regexp (match-string 0)))
 339           (while (not entry)
 340             (if (string-match (mm-uu-beginning-regexp (car alist))
 341                               beginning-regexp)
 342                 (setq entry (car alist))
 343               (pop alist))))
 344         (if (setq func (mm-uu-function-1 entry))
 345             (funcall func))
 346         (forward-line);; in case of failure
 347         (when (and (not (mm-uu-configure-p (mm-uu-type entry) 'disabled))
 348                    (let ((end-regexp (mm-uu-end-regexp entry)))
 349                      (if (not end-regexp)
 350                          (or (setq end-point (point-max)) t)
 351                        (prog1
 352                            (re-search-forward end-regexp nil t)
 353                          (forward-line)
 354                          (setq end-point (point)))))
 355                    (or (not (setq func (mm-uu-function-2 entry)))
 356                        (funcall func)))
 357           (if (and (> start-point text-start)
 358                    (progn
 359                      (goto-char text-start)
 360                      (re-search-forward "." start-point t)))
 361               (push
 362                (mm-make-handle (mm-uu-copy-to-buffer text-start start-point)
 363                                text-plain-type)
 364                result))
 365           (push
 366            (funcall (mm-uu-function-extract entry))
 367            result)
 368           (goto-char (setq text-start end-point))))
 369       (when result
 370         (if (and (> (point-max) (1+ text-start))
 371                  (save-excursion
 372                    (goto-char text-start)
 373                    (re-search-forward "." nil t)))
 374             (push
 375              (mm-make-handle (mm-uu-copy-to-buffer text-start (point-max))
 376                              text-plain-type)
 377              result))
 378         (setq result (cons "multipart/mixed" (nreverse result))))
 379       result)))
 380
 381 (provide 'mm-uu)
 382
 383 ;;; mm-uu.el ends here