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       (goto-char (point-min))
 280       (while (re-search-forward "^- " nil t)
 281         (replace-match "" t t)
 282         (forward-line 1)))
 283     (list (mm-make-handle buf '("text/plain" (charset . gnus-decoded))))))
 284
 285 (defun mm-uu-pgp-signed-extract ()
 286   (let ((mm-security-handle (list (format "multipart/signed"))))
 287     (mm-set-handle-multipart-parameter
 288      mm-security-handle 'protocol "application/x-gnus-pgp-signature")
 289     (save-restriction
 290       (narrow-to-region start-point end-point)
 291       (add-text-properties 0 (length (car mm-security-handle))
 292                            (list 'buffer (mm-uu-copy-to-buffer))
 293                            (car mm-security-handle))
 294       (setcdr mm-security-handle
 295               (mm-uu-pgp-signed-extract-1 nil
 296                                           mm-security-handle)))
 297     mm-security-handle))
 298
 299 (defun mm-uu-pgp-encrypted-test (&rest rest)
 300   (and
 301    mml2015-use
 302    (mml2015-clear-decrypt-function)
 303    (cond
 304     ((eq mm-decrypt-option 'never) nil)
 305     ((eq mm-decrypt-option 'always) t)
 306     ((eq mm-decrypt-option 'known) t)
 307     (t (y-or-n-p "Decrypt pgp encrypted part?")))))
 308
 309 (defun mm-uu-pgp-encrypted-extract-1 (handles ctl)
 310   (let ((buf (mm-uu-copy-to-buffer (point-min) (point-max))))
 311     (if (mm-uu-pgp-encrypted-test)
 312         (with-current-buffer buf
 313           (mml2015-clean-buffer)
 314           (funcall (mml2015-clear-decrypt-function))))
 315     (list
 316      (mm-make-handle buf
 317                      '("text/plain"  (charset . gnus-decoded))))))
 318
 319 (defun mm-uu-pgp-encrypted-extract ()
 320   (let ((mm-security-handle (list (format "multipart/encrypted"))))
 321     (mm-set-handle-multipart-parameter
 322      mm-security-handle 'protocol "application/x-gnus-pgp-encrypted")
 323     (save-restriction
 324       (narrow-to-region start-point end-point)
 325       (add-text-properties 0 (length (car mm-security-handle))
 326                            (list 'buffer (mm-uu-copy-to-buffer))
 327                            (car mm-security-handle))
 328       (setcdr mm-security-handle
 329               (mm-uu-pgp-encrypted-extract-1 nil
 330                                              mm-security-handle)))
 331     mm-security-handle))
 332
 333 (defun mm-uu-gpg-key-skip-to-last ()
 334   (let ((point (point))
 335         (end-regexp (mm-uu-end-regexp entry))
 336         (beginning-regexp (mm-uu-beginning-regexp entry)))
 337     (when (and end-regexp
 338                (not (mm-uu-configure-p (mm-uu-type entry) 'disabled)))
 339       (while (re-search-forward end-regexp nil t)
 340         (skip-chars-forward " \t\n\r")
 341         (if (looking-at beginning-regexp)
 342             (setq point (match-end 0)))))
 343     (goto-char point)))
 344
 345 (defun mm-uu-pgp-key-extract ()
 346   (let ((buf (mm-uu-copy-to-buffer start-point end-point)))
 347     (mm-make-handle buf
 348                     '("application/pgp-keys"))))
 349
 350 ;;;### autoload
 351 (defun mm-uu-dissect ()
 352   "Dissect the current buffer and return a list of uu handles."
 353   (let ((case-fold-search t)
 354         text-start start-point end-point file-name result
 355         text-plain-type entry func)
 356     (save-excursion
 357       (goto-char (point-min))
 358       (cond
 359        ((looking-at "\n")
 360         (forward-line))
 361        ((search-forward "\n\n" nil t)
 362         t)
 363        (t (goto-char (point-max))))
 364       ;;; gnus-decoded is a fake charset, which means no further
 365       ;;; decoding.
 366       (setq text-start (point)
 367             text-plain-type '("text/plain"  (charset . gnus-decoded)))
 368       (while (re-search-forward mm-uu-beginning-regexp nil t)
 369         (setq start-point (match-beginning 0))
 370         (let ((alist mm-uu-type-alist)
 371               (beginning-regexp (match-string 0)))
 372           (while (not entry)
 373             (if (string-match (mm-uu-beginning-regexp (car alist))
 374                               beginning-regexp)
 375                 (setq entry (car alist))
 376               (pop alist))))
 377         (if (setq func (mm-uu-function-1 entry))
 378             (funcall func))
 379         (forward-line);; in case of failure
 380         (when (and (not (mm-uu-configure-p (mm-uu-type entry) 'disabled))
 381                    (let ((end-regexp (mm-uu-end-regexp entry)))
 382                      (if (not end-regexp)
 383                          (or (setq end-point (point-max)) t)
 384                        (prog1
 385                            (re-search-forward end-regexp nil t)
 386                          (forward-line)
 387                          (setq end-point (point)))))
 388                    (or (not (setq func (mm-uu-function-2 entry)))
 389                        (funcall func)))
 390           (if (and (> start-point text-start)
 391                    (progn
 392                      (goto-char text-start)
 393                      (re-search-forward "." start-point t)))
 394               (push
 395                (mm-make-handle (mm-uu-copy-to-buffer text-start start-point)
 396                                text-plain-type)
 397                result))
 398           (push
 399            (funcall (mm-uu-function-extract entry))
 400            result)
 401           (goto-char (setq text-start end-point))))
 402       (when result
 403         (if (and (> (point-max) (1+ text-start))
 404                  (save-excursion
 405                    (goto-char text-start)
 406                    (re-search-forward "." nil t)))
 407             (push
 408              (mm-make-handle (mm-uu-copy-to-buffer text-start (point-max))
 409                              text-plain-type)
 410              result))
 411         (setq result (cons "multipart/mixed" (nreverse result))))
 412       result)))
 413
 414 (provide 'mm-uu)
 415
 416 ;;; mm-uu.el ends here