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-begin-signature
  61      "^-----BEGIN PGP SIGNATURE-----")
  62
  63 (defvar mm-uu-begin-line 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
 115 (defcustom mm-uu-configure-list nil
 116   "A list of mm-uu configuration.
 117 To disable dissecting shar codes, for instance, add
 118 `(shar . disabled)' to this list."
 119   :type `(repeat (cons
 120                   ,(cons 'choice
 121                          (mapcar
 122                           (lambda (entry)
 123                             (cons 'item (car entry)))
 124                           mm-uu-type-alist))
 125                   (choice (item disabled))))
 126   :group 'gnus-article-mime)
 127
 128 ;; functions
 129
 130 (defsubst mm-uu-type (entry)
 131   (car entry))
 132
 133 (defsubst mm-uu-begin-regexp (entry)
 134   (nth 1 entry))
 135
 136 (defsubst mm-uu-end-regexp (entry)
 137   (nth 2 entry))
 138
 139 (defsubst mm-uu-function-extract (entry)
 140   (nth 3 entry))
 141
 142 (defsubst mm-uu-function-1 (entry)
 143   (nth 4 entry))
 144
 145 (defsubst mm-uu-function-2 (entry)
 146   (nth 5 entry))
 147
 148 (defun mm-uu-copy-to-buffer (from to)
 149   "Copy the contents of the current buffer to a fresh buffer."
 150   (save-excursion
 151     (let ((obuf (current-buffer)))
 152       (set-buffer (generate-new-buffer " *mm-uu*"))
 153       (insert-buffer-substring obuf from to)
 154       (current-buffer))))
 155
 156 (defun mm-uu-configure-p  (key val)
 157   (member (cons key val) mm-uu-configure-list))
 158
 159 (defun mm-uu-configure (&optional symbol value)
 160   (if symbol (set-default symbol value))
 161   (setq mm-uu-begin-line nil)
 162   (mapcar (lambda (entry)
 163              (if (mm-uu-configure-p (mm-uu-type entry) 'disabled)
 164                  nil
 165                (setq mm-uu-begin-line
 166                      (concat mm-uu-begin-line
 167                              (if mm-uu-begin-line "\\|")
 168                              (mm-uu-begin-regexp entry)))))
 169           mm-uu-type-alist))
 170
 171 (mm-uu-configure)
 172
 173 (eval-when-compile
 174   (defvar file-name)
 175   (defvar start-point)
 176   (defvar end-point)
 177   (defvar entry))
 178
 179 (defun mm-uu-uu-filename ()
 180   (if (looking-at ".+")
 181       (setq file-name
 182             (let ((nnheader-file-name-translation-alist
 183                    '((?/ . ?,) (? . ?_) (?* . ?_) (?$ . ?_))))
 184               (nnheader-translate-file-chars (match-string 0))))))
 185
 186 (defun mm-uu-binhex-filename ()
 187   (setq file-name
 188         (ignore-errors
 189           (binhex-decode-region start-point end-point t))))
 190
 191 (defun mm-uu-forward-test ()
 192   (save-excursion
 193     (goto-char start-point)
 194     (forward-line)
 195     (looking-at "[\r\n]*[a-zA-Z][a-zA-Z0-9-]*:")))
 196
 197 (defun mm-uu-postscript-extract ()
 198   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
 199                   '("application/postscript")))
 200
 201 (defun mm-uu-forward-extract ()
 202   (mm-make-handle (mm-uu-copy-to-buffer
 203                    (progn (goto-char start-point) (forward-line) (point))
 204                    (progn (goto-char end-point) (forward-line -1) (point)))
 205                   '("message/rfc822" (charset . gnus-decoded))))
 206
 207 (defun mm-uu-uu-extract ()
 208   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
 209                   (list (or (and file-name
 210                                  (string-match "\\.[^\\.]+$"
 211                                                file-name)
 212                                  (mailcap-extension-to-mime
 213                                   (match-string 0 file-name)))
 214                             "application/octet-stream"))
 215                   'x-uuencode nil
 216                   (if (and file-name (not (equal file-name "")))
 217                       (list mm-dissect-disposition
 218                             (cons 'filename file-name)))))
 219
 220 (defun mm-uu-binhex-extract ()
 221   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
 222                   (list (or (and file-name
 223                                  (string-match "\\.[^\\.]+$" file-name)
 224                                  (mailcap-extension-to-mime
 225                                   (match-string 0 file-name)))
 226                             "application/octet-stream"))
 227                   'x-binhex nil
 228                   (if (and file-name (not (equal file-name "")))
 229                       (list mm-dissect-disposition
 230                             (cons 'filename file-name)))))
 231
 232 (defun mm-uu-shar-extract ()
 233   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
 234                   '("application/x-shar")))
 235
 236 (defun mm-uu-gnatsweb-extract ()
 237   (save-restriction
 238     (goto-char start-point)
 239     (forward-line)
 240     (narrow-to-region (point) end-point)
 241     (mm-dissect-buffer t)))
 242
 243 (defun mm-uu-pgp-signed-test ()
 244   (and
 245    mml2015-use
 246    (mml2015-clear-verify-function)
 247    (cond
 248     ((eq mm-verify-option 'never) nil)
 249     ((eq mm-verify-option 'always) t)
 250     ((eq mm-verify-option 'known) t)
 251     (t (y-or-n-p "Verify pgp signed part?")))))
 252
 253 (defun mm-uu-pgp-signed-extract ()
 254   (or (memq 'signed gnus-article-wash-types)
 255       (push 'signed gnus-article-wash-types))
 256   (let ((buf (mm-uu-copy-to-buffer start-point end-point)))
 257     (with-current-buffer buf
 258       (condition-case err
 259           (funcall (mml2015-clear-verify-function))
 260         (error
 261          (unless (y-or-n-p (format "%s, continue?" err))
 262            (kill-buffer buf)
 263            (error "Verify failure."))))
 264       (goto-char (point-min))
 265       (if (search-forward "\n\n" nil t)
 266           (delete-region (point-min) (point)))
 267       (if (re-search-forward mm-uu-pgp-begin-signature nil t)
 268           (delete-region (match-beginning 0) (point-max))))
 269     (mm-make-handle buf
 270                     '("text/plain"  (charset . gnus-decoded)))))
 271
 272 (defun mm-uu-pgp-encrypted-test ()
 273   (and
 274    mml2015-use
 275    (mml2015-clear-decrypt-function)
 276    (cond
 277     ((eq mm-decrypt-option 'never) nil)
 278     ((eq mm-decrypt-option 'always) t)
 279     ((eq mm-decrypt-option 'known) t)
 280     (t (y-or-n-p "Decrypt pgp encrypted part?")))))
 281
 282 (defun mm-uu-pgp-encrypted-extract ()
 283   (or (memq 'encrypted gnus-article-wash-types)
 284       (push 'encrypted gnus-article-wash-types))
 285   (let ((buf (mm-uu-copy-to-buffer start-point end-point)))
 286     (with-current-buffer buf
 287       (condition-case err
 288           (funcall (mml2015-clear-decrypt-function))
 289         (error
 290          (unless (y-or-n-p (format "%s, continue?" err))
 291            (kill-buffer buf)
 292            (error "Decrypt failure.")))))
 293     (mm-make-handle buf
 294                     '("text/plain"  (charset . gnus-decoded)))))
 295
 296 ;;;### autoload
 297 (defun mm-uu-dissect ()
 298   "Dissect the current buffer and return a list of uu handles."
 299   (let ((case-fold-search t)
 300         text-start start-point end-point file-name result
 301         text-plain-type entry func)
 302     (save-excursion
 303       (goto-char (point-min))
 304       (cond
 305        ((looking-at "\n")
 306         (forward-line))
 307        ((search-forward "\n\n" nil t)
 308         t)
 309        (t (goto-char (point-max))))
 310       ;;; gnus-decoded is a fake charset, which means no further
 311       ;;; decoding.
 312       (setq text-start (point)
 313             text-plain-type '("text/plain"  (charset . gnus-decoded)))
 314       (while (re-search-forward mm-uu-begin-line nil t)
 315         (setq start-point (match-beginning 0))
 316         (let ((alist mm-uu-type-alist)
 317               (begin-line (match-string 0)))
 318           (while (not entry)
 319             (if (string-match (mm-uu-begin-regexp (car alist)) begin-line)
 320                 (setq entry (car alist))
 321               (pop alist))))
 322         (if (setq func (mm-uu-function-1 entry))
 323             (funcall func))
 324         (forward-line);; in case of failure
 325         (when (and (not (mm-uu-configure-p (mm-uu-type entry) 'disabled))
 326                    (let ((end-line (mm-uu-end-regexp entry)))
 327                      (if (not end-line)
 328                          (or (setq end-point (point-max)) t)
 329                        (prog1
 330                            (re-search-forward end-line nil t)
 331                          (forward-line)
 332                          (setq end-point (point)))))
 333                    (or (not (setq func (mm-uu-function-2 entry)))
 334                        (funcall func)))
 335           (if (and (> start-point text-start)
 336                    (progn
 337                      (goto-char text-start)
 338                      (re-search-forward "." start-point t)))
 339               (push
 340                (mm-make-handle (mm-uu-copy-to-buffer text-start start-point)
 341                                text-plain-type)
 342                result))
 343           (push
 344            (funcall (mm-uu-function-extract entry))
 345            result)
 346           (goto-char (setq text-start end-point))))
 347       (when result
 348         (if (and (> (point-max) (1+ text-start))
 349                  (save-excursion
 350                    (goto-char text-start)
 351                    (re-search-forward "." nil t)))
 352             (push
 353              (mm-make-handle (mm-uu-copy-to-buffer text-start (point-max))
 354                              text-plain-type)
 355              result))
 356         (setq result (cons "multipart/mixed" (nreverse result))))
 357       result)))
 358
 359 (provide 'mm-uu)
 360
 361 ;;; mm-uu.el ends here