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

   1 ;;; mm-uu.el -- Return uu stuff 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 (require 'uudecode)
  36 (require 'binhex)
  37
  38 ;; This is not the right place for this.  uudecode.el should decide
  39 ;; whether or not to use a program with a single interface, but I
  40 ;; guess it's too late now.  Also the default should depend on a test
  41 ;; for the program.  -- fx
  42 (defcustom mm-uu-decode-function 'uudecode-decode-region
  43   "*Function to uudecode.
  44 Internal function is done in Lisp by default, therefore decoding may
  45 appear to be horribly slow.  You can make Gnus use an external
  46 decoder, such as uudecode."
  47   :type '(choice
  48           (function-item :tag "Internal" uudecode-decode-region)
  49           (function-item :tag "External" uudecode-decode-region-external))
  50   :group 'gnus-article-mime)
  51
  52 (defcustom mm-uu-binhex-decode-function 'binhex-decode-region
  53   "*Function to binhex decode.
  54 Internal function is done in elisp by default, therefore decoding may
  55 appear to be horribly slow . You can make Gnus use the external Unix
  56 decoder, such as hexbin."
  57   :type '(choice (item :tag "internal" binhex-decode-region)
  58                  (item :tag "external" binhex-decode-region-external))
  59   :group 'gnus-article-mime)
  60
  61 (defvar mm-uu-pgp-beginning-signature
  62      "^-----BEGIN PGP SIGNATURE-----")
  63
  64 (defvar mm-uu-beginning-regexp nil)
  65
  66 (defvar mm-dissect-disposition "inline"
  67   "The default disposition of uu parts.
  68 This can be either \"inline\" or \"attachment\".")
  69
  70 (defvar mm-uu-type-alist
  71   '((postscript
  72      "^%!PS-"
  73      "^%%EOF$"
  74      mm-uu-postscript-extract
  75      nil)
  76     (uu
  77      "^begin[ \t]+[0-7][0-7][0-7][ \t]+"
  78      "^end[ \t]*$"
  79      mm-uu-uu-extract
  80      mm-uu-uu-filename)
  81     (binhex
  82      "^:...............................................................$"
  83      ":$"
  84      mm-uu-binhex-extract
  85      nil
  86      mm-uu-binhex-filename)
  87     (shar
  88      "^#! */bin/sh"
  89      "^exit 0$"
  90      mm-uu-shar-extract)
  91     (forward
  92 ;;; Thanks to Edward J. Sabol <sabol@alderaan.gsfc.nasa.gov> and
  93 ;;; Peter von der Ah\'e <pahe@daimi.au.dk>
  94      "^-+ \\(Start of \\)?Forwarded message"
  95      "^-+ End \\(of \\)?forwarded message"
  96      mm-uu-forward-extract
  97      nil
  98      mm-uu-forward-test)
  99     (gnatsweb
 100      "^----gnatsweb-attachment----"
 101      nil
 102      mm-uu-gnatsweb-extract)
 103     (pgp-signed
 104      "^-----BEGIN PGP SIGNED MESSAGE-----"
 105      "^-----END PGP SIGNATURE-----"
 106      mm-uu-pgp-signed-extract
 107      nil
 108      nil)
 109     (pgp-encrypted
 110      "^-----BEGIN PGP MESSAGE-----"
 111      "^-----END PGP MESSAGE-----"
 112      mm-uu-pgp-encrypted-extract
 113      nil
 114      nil)
 115     (pgp-key
 116      "^-----BEGIN PGP PUBLIC KEY BLOCK-----"
 117      "^-----END PGP PUBLIC KEY BLOCK-----"
 118      mm-uu-pgp-key-extract
 119      mm-uu-gpg-key-skip-to-last
 120      nil)))
 121
 122 (defcustom mm-uu-configure-list nil
 123   "A list of mm-uu configuration.
 124 To disable dissecting shar codes, for instance, add
 125 `(shar . disabled)' to this list."
 126   :type `(repeat (cons
 127                   ,(cons 'choice
 128                          (mapcar
 129                           (lambda (entry)
 130                             (cons 'item (car entry)))
 131                           mm-uu-type-alist))
 132                   (choice (item disabled))))
 133   :group 'gnus-article-mime)
 134
 135 ;; functions
 136
 137 (defsubst mm-uu-type (entry)
 138   (car entry))
 139
 140 (defsubst mm-uu-beginning-regexp (entry)
 141   (nth 1 entry))
 142
 143 (defsubst mm-uu-end-regexp (entry)
 144   (nth 2 entry))
 145
 146 (defsubst mm-uu-function-extract (entry)
 147   (nth 3 entry))
 148
 149 (defsubst mm-uu-function-1 (entry)
 150   (nth 4 entry))
 151
 152 (defsubst mm-uu-function-2 (entry)
 153   (nth 5 entry))
 154
 155 (defun mm-uu-copy-to-buffer (&optional from to)
 156   "Copy the contents of the current buffer to a fresh buffer.
 157 Return that buffer."
 158   (save-excursion
 159     (let ((obuf (current-buffer)))
 160       (set-buffer (generate-new-buffer " *mm-uu*"))
 161       (insert-buffer-substring obuf from to)
 162       (current-buffer))))
 163
 164 (defun mm-uu-configure-p  (key val)
 165   (member (cons key val) mm-uu-configure-list))
 166
 167 (defun mm-uu-configure (&optional symbol value)
 168   (if symbol (set-default symbol value))
 169   (setq mm-uu-beginning-regexp nil)
 170   (mapcar (lambda (entry)
 171              (if (mm-uu-configure-p (mm-uu-type entry) 'disabled)
 172                  nil
 173                (setq mm-uu-beginning-regexp
 174                      (concat mm-uu-beginning-regexp
 175                              (if mm-uu-beginning-regexp "\\|")
 176                              (mm-uu-beginning-regexp entry)))))
 177           mm-uu-type-alist))
 178
 179 (mm-uu-configure)
 180
 181 (eval-when-compile
 182   (defvar file-name)
 183   (defvar start-point)
 184   (defvar end-point)
 185   (defvar entry))
 186
 187 (defun mm-uu-uu-filename ()
 188   (if (looking-at ".+")
 189       (setq file-name
 190             (let ((nnheader-file-name-translation-alist
 191                    '((?/ . ?,) (? . ?_) (?* . ?_) (?$ . ?_))))
 192               (nnheader-translate-file-chars (match-string 0))))))
 193
 194 (defun mm-uu-binhex-filename ()
 195   (setq file-name
 196         (ignore-errors
 197           (binhex-decode-region start-point end-point t))))
 198
 199 (defun mm-uu-forward-test ()
 200   (save-excursion
 201     (goto-char start-point)
 202     (forward-line)
 203     (looking-at "[\r\n]*[a-zA-Z][a-zA-Z0-9-]*:")))
 204
 205 (defun mm-uu-postscript-extract ()
 206   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
 207                   '("application/postscript")))
 208
 209 (defun mm-uu-forward-extract ()
 210   (mm-make-handle (mm-uu-copy-to-buffer
 211                    (progn (goto-char start-point) (forward-line) (point))
 212                    (progn (goto-char end-point) (forward-line -1) (point)))
 213                   '("message/rfc822" (charset . gnus-decoded))))
 214
 215 (defun mm-uu-uu-extract ()
 216   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
 217                   (list (or (and file-name
 218                                  (string-match "\\.[^\\.]+$"
 219                                                file-name)
 220                                  (mailcap-extension-to-mime
 221                                   (match-string 0 file-name)))
 222                             "application/octet-stream"))
 223                   'x-uuencode nil
 224                   (if (and file-name (not (equal file-name "")))
 225                       (list mm-dissect-disposition
 226                             (cons 'filename file-name)))))
 227
 228 (defun mm-uu-binhex-extract ()
 229   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
 230                   (list (or (and file-name
 231                                  (string-match "\\.[^\\.]+$" file-name)
 232                                  (mailcap-extension-to-mime
 233                                   (match-string 0 file-name)))
 234                             "application/octet-stream"))
 235                   'x-binhex nil
 236                   (if (and file-name (not (equal file-name "")))
 237                       (list mm-dissect-disposition
 238                             (cons 'filename file-name)))))
 239
 240 (defun mm-uu-shar-extract ()
 241   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
 242                   '("application/x-shar")))
 243
 244 (defun mm-uu-gnatsweb-extract ()
 245   (save-restriction
 246     (goto-char start-point)
 247     (forward-line)
 248     (narrow-to-region (point) end-point)
 249     (mm-dissect-buffer t)))
 250
 251 (defun mm-uu-pgp-signed-test (&rest rest)
 252   (and
 253    mml2015-use
 254    (mml2015-clear-verify-function)
 255    (cond
 256     ((eq mm-verify-option 'never) nil)
 257     ((eq mm-verify-option 'always) t)
 258     ((eq mm-verify-option 'known) t)
 259     (t (y-or-n-p "Verify pgp signed part?")))))
 260
 261 (defun mm-uu-pgp-signed-extract-1 (handles ctl)
 262   (let ((buf (mm-uu-copy-to-buffer (point-min) (point-max))))
 263     (with-current-buffer buf
 264       (if (mm-uu-pgp-signed-test)
 265           (progn
 266             (mml2015-clean-buffer)
 267             (let ((coding-system-for-write (or gnus-newsgroup-charset
 268                                                'iso-8859-1)))
 269               (funcall (mml2015-clear-verify-function))))
 270         (when (and mml2015-use (null (mml2015-clear-verify-function)))
 271           (mm-set-handle-multipart-parameter
 272            mm-security-handle 'gnus-details
 273            (format "Clear verification not supported by `%s'.\n" mml2015-use))))
 274       (goto-char (point-min))
 275       (if (search-forward "\n\n" nil t)
 276           (delete-region (point-min) (point)))
 277       (if (re-search-forward mm-uu-pgp-beginning-signature nil t)
 278           (delete-region (match-beginning 0) (point-max))))
 279     (list
 280      (mm-make-handle buf
 281                      '("text/plain"  (charset . gnus-decoded))))))
 282
 283 (defun mm-uu-pgp-signed-extract ()
 284   (let ((mm-security-handle (list (format "multipart/signed"))))
 285     (mm-set-handle-multipart-parameter
 286      mm-security-handle 'protocol "application/x-gnus-pgp-signature")
 287     (save-restriction
 288       (narrow-to-region start-point end-point)
 289       (add-text-properties 0 (length (car mm-security-handle))
 290                            (list 'buffer (mm-uu-copy-to-buffer))
 291                            (car mm-security-handle))
 292       (setcdr mm-security-handle
 293               (mm-uu-pgp-signed-extract-1 nil
 294                                           mm-security-handle)))
 295     mm-security-handle))
 296
 297 (defun mm-uu-pgp-encrypted-test (&rest rest)
 298   (and
 299    mml2015-use
 300    (mml2015-clear-decrypt-function)
 301    (cond
 302     ((eq mm-decrypt-option 'never) nil)
 303     ((eq mm-decrypt-option 'always) t)
 304     ((eq mm-decrypt-option 'known) t)
 305     (t (y-or-n-p "Decrypt pgp encrypted part?")))))
 306
 307 (defun mm-uu-pgp-encrypted-extract-1 (handles ctl)
 308   (let ((buf (mm-uu-copy-to-buffer (point-min) (point-max))))
 309     (if (mm-uu-pgp-encrypted-test)
 310         (with-current-buffer buf
 311           (mml2015-clean-buffer)
 312           (funcall (mml2015-clear-decrypt-function))))
 313     (list
 314      (mm-make-handle buf
 315                      '("text/plain"  (charset . gnus-decoded))))))
 316
 317 (defun mm-uu-pgp-encrypted-extract ()
 318   (let ((mm-security-handle (list (format "multipart/encrypted"))))
 319     (mm-set-handle-multipart-parameter
 320      mm-security-handle 'protocol "application/x-gnus-pgp-encrypted")
 321     (save-restriction
 322       (narrow-to-region start-point end-point)
 323       (add-text-properties 0 (length (car mm-security-handle))
 324                            (list 'buffer (mm-uu-copy-to-buffer))
 325                            (car mm-security-handle))
 326       (setcdr mm-security-handle
 327               (mm-uu-pgp-encrypted-extract-1 nil
 328                                              mm-security-handle)))
 329     mm-security-handle))
 330
 331 (defun mm-uu-gpg-key-skip-to-last ()
 332   (let ((point (point))
 333         (end-regexp (mm-uu-end-regexp entry))
 334         (beginning-regexp (mm-uu-beginning-regexp entry)))
 335     (when (and end-regexp
 336                (not (mm-uu-configure-p (mm-uu-type entry) 'disabled)))
 337       (while (re-search-forward end-regexp nil t)
 338         (skip-chars-forward " \t\n\r")
 339         (if (looking-at beginning-regexp)
 340             (setq point (match-end 0)))))
 341     (goto-char point)))
 342
 343 (defun mm-uu-pgp-key-extract ()
 344   (let ((buf (mm-uu-copy-to-buffer start-point end-point)))
 345     (mm-make-handle buf
 346                     '("application/pgp-keys"))))
 347
 348 ;;;### autoload
 349 (defun mm-uu-dissect ()
 350   "Dissect the current buffer and return a list of uu handles."
 351   (let ((case-fold-search t)
 352         text-start start-point end-point file-name result
 353         text-plain-type entry func)
 354     (save-excursion
 355       (goto-char (point-min))
 356       (cond
 357        ((looking-at "\n")
 358         (forward-line))
 359        ((search-forward "\n\n" nil t)
 360         t)
 361        (t (goto-char (point-max))))
 362       ;;; gnus-decoded is a fake charset, which means no further
 363       ;;; decoding.
 364       (setq text-start (point)
 365             text-plain-type '("text/plain"  (charset . gnus-decoded)))
 366       (while (re-search-forward mm-uu-beginning-regexp nil t)
 367         (setq start-point (match-beginning 0))
 368         (let ((alist mm-uu-type-alist)
 369               (beginning-regexp (match-string 0)))
 370           (while (not entry)
 371             (if (string-match (mm-uu-beginning-regexp (car alist))
 372                               beginning-regexp)
 373                 (setq entry (car alist))
 374               (pop alist))))
 375         (if (setq func (mm-uu-function-1 entry))
 376             (funcall func))
 377         (forward-line);; in case of failure
 378         (when (and (not (mm-uu-configure-p (mm-uu-type entry) 'disabled))
 379                    (let ((end-regexp (mm-uu-end-regexp entry)))
 380                      (if (not end-regexp)
 381                          (or (setq end-point (point-max)) t)
 382                        (prog1
 383                            (re-search-forward end-regexp nil t)
 384                          (forward-line)
 385                          (setq end-point (point)))))
 386                    (or (not (setq func (mm-uu-function-2 entry)))
 387                        (funcall func)))
 388           (if (and (> start-point text-start)
 389                    (progn
 390                      (goto-char text-start)
 391                      (re-search-forward "." start-point t)))
 392               (push
 393                (mm-make-handle (mm-uu-copy-to-buffer text-start start-point)
 394                                text-plain-type)
 395                result))
 396           (push
 397            (funcall (mm-uu-function-extract entry))
 398            result)
 399           (goto-char (setq text-start end-point))))
 400       (when result
 401         (if (and (> (point-max) (1+ text-start))
 402                  (save-excursion
 403                    (goto-char text-start)
 404                    (re-search-forward "." nil t)))
 405             (push
 406              (mm-make-handle (mm-uu-copy-to-buffer text-start (point-max))
 407                              text-plain-type)
 408              result))
 409         (setq result (cons "multipart/mixed" (nreverse result))))
 410       result)))
 411
 412 (provide 'mm-uu)
 413
 414 ;;; mm-uu.el ends here