git.chise.org Git - elisp/gnus.git-/blob - lisp/mm-uu.el

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