lisp/gnus/mm-uu.el

   1 ;;; mm-uu.el --- Return uu stuff as mm handles
   2
   3 ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
   4 ;;   2005 Free Software Foundation, Inc.
   5
   6 ;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
   7 ;; Keywords: postscript uudecode binhex shar forward gnatsweb pgp
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15 ;;
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  24 ;; Boston, MA 02110-1301, USA.
  25
  26 ;;; Commentary:
  27
  28 ;;; Code:
  29
  30 (eval-when-compile (require 'cl))
  31 (require 'mail-parse)
  32 (require 'nnheader)
  33 (require 'mm-decode)
  34 (require 'mailcap)
  35 (require 'mml2015)
  36
  37 (autoload 'uudecode-decode-region "uudecode")
  38 (autoload 'uudecode-decode-region-external "uudecode")
  39 (autoload 'uudecode-decode-region-internal "uudecode")
  40
  41 (autoload 'binhex-decode-region "binhex")
  42 (autoload 'binhex-decode-region-external "binhex")
  43 (autoload 'binhex-decode-region-internal "binhex")
  44
  45 (autoload 'yenc-decode-region "yenc")
  46 (autoload 'yenc-extract-filename "yenc")
  47
  48 (defcustom mm-uu-decode-function 'uudecode-decode-region
  49   "*Function to uudecode.
  50 Internal function is done in Lisp by default, therefore decoding may
  51 appear to be horribly slow.  You can make Gnus use an external
  52 decoder, such as uudecode."
  53   :type '(choice
  54           (function-item :tag "Auto detect" uudecode-decode-region)
  55           (function-item :tag "Internal" uudecode-decode-region-internal)
  56           (function-item :tag "External" uudecode-decode-region-external))
  57   :group 'gnus-article-mime)
  58
  59 (defcustom mm-uu-binhex-decode-function 'binhex-decode-region
  60   "*Function to binhex decode.
  61 Internal function is done in elisp by default, therefore decoding may
  62 appear to be horribly slow . You can make Gnus use the external Unix
  63 decoder, such as hexbin."
  64   :type '(choice (function-item :tag "Auto detect" binhex-decode-region)
  65                  (function-item :tag "Internal" binhex-decode-region-internal)
  66                  (function-item :tag "External" binhex-decode-region-external))
  67   :group 'gnus-article-mime)
  68
  69 (defvar mm-uu-yenc-decode-function 'yenc-decode-region)
  70
  71 (defvar mm-uu-pgp-beginning-signature
  72      "^-----BEGIN PGP SIGNATURE-----")
  73
  74 (defvar mm-uu-beginning-regexp nil)
  75
  76 (defvar mm-dissect-disposition "inline"
  77   "The default disposition of uu parts.
  78 This can be either \"inline\" or \"attachment\".")
  79
  80 (defcustom mm-uu-emacs-sources-regexp "\\.emacs\\.sources"
  81   "The regexp of Emacs sources groups."
  82   :version "22.1"
  83   :type 'regexp
  84   :group 'gnus-article-mime)
  85
  86 (defcustom mm-uu-diff-groups-regexp
  87   "\\(gmane\\|gnu\\)\\..*\\(diff\\|commit\\|cvs\\|bug\\|devel\\)"
  88   "Regexp matching diff groups."
  89   :version "22.1"
  90   :type 'regexp
  91   :group 'gnus-article-mime)
  92
  93 (defvar mm-uu-type-alist
  94   '((postscript
  95      "^%!PS-"
  96      "^%%EOF$"
  97      mm-uu-postscript-extract
  98      nil)
  99     (uu
 100      "^begin[ \t]+0?[0-7][0-7][0-7][ \t]+"
 101      "^end[ \t]*$"
 102      mm-uu-uu-extract
 103      mm-uu-uu-filename)
 104     (binhex
 105      "^:...............................................................$"
 106      ":$"
 107      mm-uu-binhex-extract
 108      nil
 109      mm-uu-binhex-filename)
 110     (yenc
 111      "^=ybegin.*size=[0-9]+.*name=.*$"
 112      "^=yend.*size=[0-9]+"
 113      mm-uu-yenc-extract
 114      mm-uu-yenc-filename)
 115     (shar
 116      "^#! */bin/sh"
 117      "^exit 0$"
 118      mm-uu-shar-extract)
 119     (forward
 120      ;; Thanks to Edward J. Sabol <sabol@alderaan.gsfc.nasa.gov> and
 121      ;; Peter von der Ah\'e <pahe@daimi.au.dk>
 122      "^-+ \\(Start of \\)?Forwarded message"
 123      "^-+ End \\(of \\)?forwarded message"
 124      mm-uu-forward-extract
 125      nil
 126      mm-uu-forward-test)
 127     (gnatsweb
 128      "^----gnatsweb-attachment----"
 129      nil
 130      mm-uu-gnatsweb-extract)
 131     (pgp-signed
 132      "^-----BEGIN PGP SIGNED MESSAGE-----"
 133      "^-----END PGP SIGNATURE-----"
 134      mm-uu-pgp-signed-extract
 135      nil
 136      nil)
 137     (pgp-encrypted
 138      "^-----BEGIN PGP MESSAGE-----"
 139      "^-----END PGP MESSAGE-----"
 140      mm-uu-pgp-encrypted-extract
 141      nil
 142      nil)
 143     (pgp-key
 144      "^-----BEGIN PGP PUBLIC KEY BLOCK-----"
 145      "^-----END PGP PUBLIC KEY BLOCK-----"
 146      mm-uu-pgp-key-extract
 147      mm-uu-gpg-key-skip-to-last
 148      nil)
 149     (emacs-sources
 150      "^;;;?[ \t]*[^ \t]+\\.el[ \t]*--"
 151      "^;;;?[ \t]*\\([^ \t]+\\.el\\)[ \t]+ends here"
 152      mm-uu-emacs-sources-extract
 153      nil
 154      mm-uu-emacs-sources-test)
 155     (diff
 156      "^Index: "
 157      nil
 158      mm-uu-diff-extract
 159      nil
 160      mm-uu-diff-test))
 161   "A list of specifications for non-MIME attachments.
 162 Each element consist of the following entries: label,
 163 start-regexp, end-regexp, extract-function, test-function.
 164
 165 After modifying this list you must run \\[mm-uu-configure].")
 166
 167 (defcustom mm-uu-configure-list '((shar . disabled))
 168   "A list of mm-uu configuration.
 169 To disable dissecting shar codes, for instance, add
 170 `(shar . disabled)' to this list."
 171   :type 'alist
 172   :options (mapcar (lambda (entry)
 173                      (list (car entry) '(const disabled)))
 174                    mm-uu-type-alist)
 175   :group 'gnus-article-mime)
 176
 177 ;; functions
 178
 179 (defsubst mm-uu-type (entry)
 180   (car entry))
 181
 182 (defsubst mm-uu-beginning-regexp (entry)
 183   (nth 1 entry))
 184
 185 (defsubst mm-uu-end-regexp (entry)
 186   (nth 2 entry))
 187
 188 (defsubst mm-uu-function-extract (entry)
 189   (nth 3 entry))
 190
 191 (defsubst mm-uu-function-1 (entry)
 192   (nth 4 entry))
 193
 194 (defsubst mm-uu-function-2 (entry)
 195   (nth 5 entry))
 196
 197 (defun mm-uu-copy-to-buffer (&optional from to)
 198   "Copy the contents of the current buffer to a fresh buffer.
 199 Return that buffer."
 200   (let ((obuf (current-buffer))
 201         (coding-system
 202          ;; Might not exist in non-MULE XEmacs
 203          (when (boundp 'buffer-file-coding-system)
 204            buffer-file-coding-system)))
 205     (with-current-buffer (generate-new-buffer " *mm-uu*")
 206       (setq buffer-file-coding-system coding-system)
 207       (insert-buffer-substring obuf from to)
 208       (current-buffer))))
 209
 210 (defun mm-uu-configure-p  (key val)
 211   (member (cons key val) mm-uu-configure-list))
 212
 213 (defun mm-uu-configure (&optional symbol value)
 214   "Configure detection of non-MIME attachments."
 215   (interactive)
 216   (if symbol (set-default symbol value))
 217   (setq mm-uu-beginning-regexp nil)
 218   (mapcar (lambda (entry)
 219              (if (mm-uu-configure-p (mm-uu-type entry) 'disabled)
 220                  nil
 221                (setq mm-uu-beginning-regexp
 222                      (concat mm-uu-beginning-regexp
 223                              (if mm-uu-beginning-regexp "\\|")
 224                              (mm-uu-beginning-regexp entry)))))
 225           mm-uu-type-alist))
 226
 227 (mm-uu-configure)
 228
 229 (eval-when-compile
 230   (defvar file-name)
 231   (defvar start-point)
 232   (defvar end-point)
 233   (defvar entry))
 234
 235 (defun mm-uu-uu-filename ()
 236   (if (looking-at ".+")
 237       (setq file-name
 238             (let ((nnheader-file-name-translation-alist
 239                    '((?/ . ?,) (?\  . ?_) (?* . ?_) (?$ . ?_))))
 240               (nnheader-translate-file-chars (match-string 0))))))
 241
 242 (defun mm-uu-binhex-filename ()
 243   (setq file-name
 244         (ignore-errors
 245           (binhex-decode-region start-point end-point t))))
 246
 247 (defun mm-uu-yenc-filename ()
 248   (goto-char start-point)
 249   (setq file-name
 250         (ignore-errors
 251           (yenc-extract-filename))))
 252
 253 (defun mm-uu-forward-test ()
 254   (save-excursion
 255     (goto-char start-point)
 256     (forward-line)
 257     (looking-at "[\r\n]*[a-zA-Z][a-zA-Z0-9-]*:")))
 258
 259 (defun mm-uu-postscript-extract ()
 260   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
 261                   '("application/postscript")))
 262
 263 (defun mm-uu-emacs-sources-extract ()
 264   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
 265                   '("application/emacs-lisp")
 266                   nil nil
 267                   (list mm-dissect-disposition
 268                         (cons 'filename file-name))))
 269
 270 (eval-when-compile
 271   (defvar gnus-newsgroup-name))
 272
 273 (defun mm-uu-emacs-sources-test ()
 274   (setq file-name (match-string 1))
 275   (and gnus-newsgroup-name
 276        mm-uu-emacs-sources-regexp
 277        (string-match mm-uu-emacs-sources-regexp gnus-newsgroup-name)))
 278
 279 (defun mm-uu-diff-extract ()
 280   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
 281                   '("text/x-patch")))
 282
 283 (defun mm-uu-diff-test ()
 284   (and gnus-newsgroup-name
 285        mm-uu-diff-groups-regexp
 286        (string-match mm-uu-diff-groups-regexp gnus-newsgroup-name)))
 287
 288 (defun mm-uu-forward-extract ()
 289   (mm-make-handle (mm-uu-copy-to-buffer
 290                    (progn (goto-char start-point) (forward-line) (point))
 291                    (progn (goto-char end-point) (forward-line -1) (point)))
 292                   '("message/rfc822" (charset . gnus-decoded))))
 293
 294 (defun mm-uu-uu-extract ()
 295   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
 296                   (list (or (and file-name
 297                                  (string-match "\\.[^\\.]+$"
 298                                                file-name)
 299                                  (mailcap-extension-to-mime
 300                                   (match-string 0 file-name)))
 301                             "application/octet-stream"))
 302                   'x-uuencode nil
 303                   (if (and file-name (not (equal file-name "")))
 304                       (list mm-dissect-disposition
 305                             (cons 'filename file-name)))))
 306
 307 (defun mm-uu-binhex-extract ()
 308   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
 309                   (list (or (and file-name
 310                                  (string-match "\\.[^\\.]+$" file-name)
 311                                  (mailcap-extension-to-mime
 312                                   (match-string 0 file-name)))
 313                             "application/octet-stream"))
 314                   'x-binhex nil
 315                   (if (and file-name (not (equal file-name "")))
 316                       (list mm-dissect-disposition
 317                             (cons 'filename file-name)))))
 318
 319 (defun mm-uu-yenc-extract ()
 320   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
 321                   (list (or (and file-name
 322                                  (string-match "\\.[^\\.]+$" file-name)
 323                                  (mailcap-extension-to-mime
 324                                   (match-string 0 file-name)))
 325                             "application/octet-stream"))
 326                   'x-yenc nil
 327                   (if (and file-name (not (equal file-name "")))
 328                       (list mm-dissect-disposition
 329                             (cons 'filename file-name)))))
 330
 331
 332 (defun mm-uu-shar-extract ()
 333   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
 334                   '("application/x-shar")))
 335
 336 (defun mm-uu-gnatsweb-extract ()
 337   (save-restriction
 338     (goto-char start-point)
 339     (forward-line)
 340     (narrow-to-region (point) end-point)
 341     (mm-dissect-buffer t)))
 342
 343 (defun mm-uu-pgp-signed-test (&rest rest)
 344   (and
 345    mml2015-use
 346    (mml2015-clear-verify-function)
 347    (cond
 348     ((eq mm-verify-option 'never) nil)
 349     ((eq mm-verify-option 'always) t)
 350     ((eq mm-verify-option 'known) t)
 351     (t (y-or-n-p "Verify pgp signed part? ")))))
 352
 353 (eval-when-compile
 354   (defvar gnus-newsgroup-charset))
 355
 356 (defun mm-uu-pgp-signed-extract-1 (handles ctl)
 357   (let ((buf (mm-uu-copy-to-buffer (point-min) (point-max))))
 358     (with-current-buffer buf
 359       (if (mm-uu-pgp-signed-test)
 360           (progn
 361             (mml2015-clean-buffer)
 362             (let ((coding-system-for-write (or gnus-newsgroup-charset
 363                                                'iso-8859-1)))
 364               (funcall (mml2015-clear-verify-function))))
 365         (when (and mml2015-use (null (mml2015-clear-verify-function)))
 366           (mm-set-handle-multipart-parameter
 367            mm-security-handle 'gnus-details
 368            (format "Clear verification not supported by `%s'.\n" mml2015-use))))
 369       (goto-char (point-min))
 370       (if (search-forward "\n\n" nil t)
 371           (delete-region (point-min) (point)))
 372       (if (re-search-forward mm-uu-pgp-beginning-signature nil t)
 373           (delete-region (match-beginning 0) (point-max)))
 374       (goto-char (point-min))
 375       (while (re-search-forward "^- " nil t)
 376         (replace-match "" t t)
 377         (forward-line 1)))
 378     (list (mm-make-handle buf '("text/plain" (charset . gnus-decoded))))))
 379
 380 (defun mm-uu-pgp-signed-extract ()
 381   (let ((mm-security-handle (list (format "multipart/signed"))))
 382     (mm-set-handle-multipart-parameter
 383      mm-security-handle 'protocol "application/x-gnus-pgp-signature")
 384     (save-restriction
 385       (narrow-to-region start-point end-point)
 386       (add-text-properties 0 (length (car mm-security-handle))
 387                            (list 'buffer (mm-uu-copy-to-buffer))
 388                            (car mm-security-handle))
 389       (setcdr mm-security-handle
 390               (mm-uu-pgp-signed-extract-1 nil
 391                                           mm-security-handle)))
 392     mm-security-handle))
 393
 394 (defun mm-uu-pgp-encrypted-test (&rest rest)
 395   (and
 396    mml2015-use
 397    (mml2015-clear-decrypt-function)
 398    (cond
 399     ((eq mm-decrypt-option 'never) nil)
 400     ((eq mm-decrypt-option 'always) t)
 401     ((eq mm-decrypt-option 'known) t)
 402     (t (y-or-n-p "Decrypt pgp encrypted part? ")))))
 403
 404 (defun mm-uu-pgp-encrypted-extract-1 (handles ctl)
 405   (let ((buf (mm-uu-copy-to-buffer (point-min) (point-max))))
 406     (if (mm-uu-pgp-encrypted-test)
 407         (with-current-buffer buf
 408           (mml2015-clean-buffer)
 409           (funcall (mml2015-clear-decrypt-function))))
 410     (list
 411      (mm-make-handle buf
 412                      '("text/plain"  (charset . gnus-decoded))))))
 413
 414 (defun mm-uu-pgp-encrypted-extract ()
 415   (let ((mm-security-handle (list (format "multipart/encrypted"))))
 416     (mm-set-handle-multipart-parameter
 417      mm-security-handle 'protocol "application/x-gnus-pgp-encrypted")
 418     (save-restriction
 419       (narrow-to-region start-point end-point)
 420       (add-text-properties 0 (length (car mm-security-handle))
 421                            (list 'buffer (mm-uu-copy-to-buffer))
 422                            (car mm-security-handle))
 423       (setcdr mm-security-handle
 424               (mm-uu-pgp-encrypted-extract-1 nil
 425                                              mm-security-handle)))
 426     mm-security-handle))
 427
 428 (defun mm-uu-gpg-key-skip-to-last ()
 429   (let ((point (point))
 430         (end-regexp (mm-uu-end-regexp entry))
 431         (beginning-regexp (mm-uu-beginning-regexp entry)))
 432     (when (and end-regexp
 433                (not (mm-uu-configure-p (mm-uu-type entry) 'disabled)))
 434       (while (re-search-forward end-regexp nil t)
 435         (skip-chars-forward " \t\n\r")
 436         (if (looking-at beginning-regexp)
 437             (setq point (match-end 0)))))
 438     (goto-char point)))
 439
 440 (defun mm-uu-pgp-key-extract ()
 441   (let ((buf (mm-uu-copy-to-buffer start-point end-point)))
 442     (mm-make-handle buf
 443                     '("application/pgp-keys"))))
 444
 445 ;;;###autoload
 446 (defun mm-uu-dissect ()
 447   "Dissect the current buffer and return a list of uu handles."
 448   (let ((case-fold-search t)
 449         text-start start-point end-point file-name result
 450         text-plain-type entry func)
 451     (save-excursion
 452       (goto-char (point-min))
 453       (cond
 454        ((looking-at "\n")
 455         (forward-line))
 456        ((search-forward "\n\n" nil t)
 457         t)
 458        (t (goto-char (point-max))))
 459       ;;; gnus-decoded is a fake charset, which means no further
 460       ;;; decoding.
 461       (setq text-start (point)
 462             text-plain-type '("text/plain"  (charset . gnus-decoded)))
 463       (while (re-search-forward mm-uu-beginning-regexp nil t)
 464         (setq start-point (match-beginning 0))
 465         (let ((alist mm-uu-type-alist)
 466               (beginning-regexp (match-string 0)))
 467           (while (not entry)
 468             (if (string-match (mm-uu-beginning-regexp (car alist))
 469                               beginning-regexp)
 470                 (setq entry (car alist))
 471               (pop alist))))
 472         (if (setq func (mm-uu-function-1 entry))
 473             (funcall func))
 474         (forward-line);; in case of failure
 475         (when (and (not (mm-uu-configure-p (mm-uu-type entry) 'disabled))
 476                    (let ((end-regexp (mm-uu-end-regexp entry)))
 477                      (if (not end-regexp)
 478                          (or (setq end-point (point-max)) t)
 479                        (prog1
 480                            (re-search-forward end-regexp nil t)
 481                          (forward-line)
 482                          (setq end-point (point)))))
 483                    (or (not (setq func (mm-uu-function-2 entry)))
 484                        (funcall func)))
 485           (if (and (> start-point text-start)
 486                    (progn
 487                      (goto-char text-start)
 488                      (re-search-forward "." start-point t)))
 489               (push
 490                (mm-make-handle (mm-uu-copy-to-buffer text-start start-point)
 491                                text-plain-type)
 492                result))
 493           (push
 494            (funcall (mm-uu-function-extract entry))
 495            result)
 496           (goto-char (setq text-start end-point))))
 497       (when result
 498         (if (and (> (point-max) (1+ text-start))
 499                  (save-excursion
 500                    (goto-char text-start)
 501                    (re-search-forward "." nil t)))
 502             (push
 503              (mm-make-handle (mm-uu-copy-to-buffer text-start (point-max))
 504                              text-plain-type)
 505              result))
 506         (setq result (cons "multipart/mixed" (nreverse result))))
 507       result)))
 508
 509 (provide 'mm-uu)
 510
 511 ;; arch-tag: 7db076bf-53db-4320-aa19-ca76a1d2ab2c
 512 ;;; mm-uu.el ends here