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, 2006, 2007, 2008 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 3, 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-beginning-regexp nil)
  72
  73 (defvar mm-dissect-disposition "inline"
  74   "The default disposition of uu parts.
  75 This can be either \"inline\" or \"attachment\".")
  76
  77 (defcustom mm-uu-emacs-sources-regexp "\\.emacs\\.sources"
  78   "The regexp of Emacs sources groups."
  79   :version "22.1"
  80   :type 'regexp
  81   :group 'gnus-article-mime)
  82
  83 (defcustom mm-uu-diff-groups-regexp
  84   "\\(gmane\\|gnu\\)\\..*\\(diff\\|commit\\|cvs\\|bug\\|devel\\)"
  85   "Regexp matching diff groups."
  86   :version "22.1"
  87   :type 'regexp
  88   :group 'gnus-article-mime)
  89
  90 (defcustom mm-uu-tex-groups-regexp "\\.tex\\>"
  91   "*Regexp matching TeX groups."
  92   :version "23.1"
  93   :type 'regexp
  94   :group 'gnus-article-mime)
  95
  96 (defvar mm-uu-type-alist
  97   '((postscript
  98      "^%!PS-"
  99      "^%%EOF$"
 100      mm-uu-postscript-extract
 101      nil)
 102     (uu ;; Maybe we should have a more strict test here.
 103      "^begin[ \t]+0?[0-7][0-7][0-7][ \t]+"
 104      "^end[ \t]*$"
 105      mm-uu-uu-extract
 106      mm-uu-uu-filename)
 107     (binhex
 108      "^:.\\{63,63\\}$"
 109      ":$"
 110      mm-uu-binhex-extract
 111      nil
 112      mm-uu-binhex-filename)
 113     (yenc
 114      "^=ybegin.*size=[0-9]+.*name=.*$"
 115      "^=yend.*size=[0-9]+"
 116      mm-uu-yenc-extract
 117      mm-uu-yenc-filename)
 118     (shar
 119      "^#! */bin/sh"
 120      "^exit 0$"
 121      mm-uu-shar-extract)
 122     (forward
 123      ;; Thanks to Edward J. Sabol <sabol@alderaan.gsfc.nasa.gov> and
 124      ;; Peter von der Ah\'e <pahe@daimi.au.dk>
 125      "^-+ \\(Start of \\)?Forwarded message"
 126      "^-+ End \\(of \\)?forwarded message"
 127      mm-uu-forward-extract
 128      nil
 129      mm-uu-forward-test)
 130     (gnatsweb
 131      "^----gnatsweb-attachment----"
 132      nil
 133      mm-uu-gnatsweb-extract)
 134     (pgp-signed
 135      "^-----BEGIN PGP SIGNED MESSAGE-----"
 136      "^-----END PGP SIGNATURE-----"
 137      mm-uu-pgp-signed-extract
 138      nil
 139      nil)
 140     (pgp-encrypted
 141      "^-----BEGIN PGP MESSAGE-----"
 142      "^-----END PGP MESSAGE-----"
 143      mm-uu-pgp-encrypted-extract
 144      nil
 145      nil)
 146     (pgp-key
 147      "^-----BEGIN PGP PUBLIC KEY BLOCK-----"
 148      "^-----END PGP PUBLIC KEY BLOCK-----"
 149      mm-uu-pgp-key-extract
 150      mm-uu-gpg-key-skip-to-last
 151      nil)
 152     (emacs-sources
 153      "^;;;?[ \t]*[^ \t]+\\.el[ \t]*--"
 154      "^;;;?[ \t]*\\([^ \t]+\\.el\\)[ \t]+ends here"
 155      mm-uu-emacs-sources-extract
 156      nil
 157      mm-uu-emacs-sources-test)
 158     (diff
 159      "^Index: "
 160      nil
 161      mm-uu-diff-extract
 162      nil
 163      mm-uu-diff-test)
 164     (message-marks
 165      ;; Text enclosed with tags similar to `message-mark-insert-begin' and
 166      ;; `message-mark-insert-end'.  Don't use those variables to avoid
 167      ;; dependency on `message.el'.
 168      "^-+[8<>]*-\\{9,\\}[a-z ]+-\\{9,\\}[a-z ]+-\\{9,\\}[8<>]*-+$"
 169      "^-+[8<>]*-\\{9,\\}[a-z ]+-\\{9,\\}[a-z ]+-\\{9,\\}[8<>]*-+$"
 170      (lambda () (mm-uu-verbatim-marks-extract -1 0 1 -1))
 171      nil)
 172     ;; Omitting [a-z8<] leads to false positives (bogus signature separators
 173     ;; and mailing list banners).
 174     (insert-marks
 175      "^ *\\(-\\|_\\)\\{30,\\}.*[a-z8<].*\\(-\\|_\\)\\{30,\\} *$"
 176      "^ *\\(-\\|_\\)\\{30,\\}.*[a-z8<].*\\(-\\|_\\)\\{30,\\} *$"
 177      (lambda () (mm-uu-verbatim-marks-extract 0 0 1 -1))
 178      nil)
 179     (verbatim-marks
 180      ;; slrn-style verbatim marks, see
 181      ;; http://www.slrn.org/manual/slrn-manual-6.html#ss6.81
 182      "^#v\\+"
 183      "^#v\\-$"
 184      (lambda () (mm-uu-verbatim-marks-extract 0 0))
 185      nil)
 186     (LaTeX
 187      "^\\([\\\\%][^\n]+\n\\)*\\\\documentclass.*[[{%]"
 188      "^\\\\end{document}"
 189      mm-uu-latex-extract
 190      nil
 191      mm-uu-latex-test))
 192   "A list of specifications for non-MIME attachments.
 193 Each element consist of the following entries: label,
 194 start-regexp, end-regexp, extract-function, test-function.
 195
 196 After modifying this list you must run \\[mm-uu-configure].
 197
 198 You can disable elements from this list by customizing
 199 `mm-uu-configure-list'.")
 200
 201 (defcustom mm-uu-configure-list '((shar . disabled))
 202   "A list of mm-uu configuration.
 203 To disable dissecting shar codes, for instance, add
 204 `(shar . disabled)' to this list."
 205   :type 'alist
 206   :options (mapcar (lambda (entry)
 207                      (list (car entry) '(const disabled)))
 208                    mm-uu-type-alist)
 209   :group 'gnus-article-mime)
 210
 211 (defvar mm-uu-text-plain-type '("text/plain" (charset . gnus-decoded))
 212   "MIME type and parameters for text/plain parts.
 213 `gnus-decoded' is a fake charset, which means no further decoding.")
 214
 215 ;; functions
 216
 217 (defsubst mm-uu-type (entry)
 218   (car entry))
 219
 220 (defsubst mm-uu-beginning-regexp (entry)
 221   (nth 1 entry))
 222
 223 (defsubst mm-uu-end-regexp (entry)
 224   (nth 2 entry))
 225
 226 (defsubst mm-uu-function-extract (entry)
 227   (nth 3 entry))
 228
 229 (defsubst mm-uu-function-1 (entry)
 230   (nth 4 entry))
 231
 232 (defsubst mm-uu-function-2 (entry)
 233   (nth 5 entry))
 234
 235 ;; In Emacs 22, we could use `min-colors' in the face definition.  But Emacs
 236 ;; 21 and XEmacs don't support it.
 237 (defcustom mm-uu-hide-markers
 238   (< 16 (or (and (fboundp 'defined-colors)
 239                  (length (defined-colors)))
 240             (and (fboundp 'device-color-cells)
 241                  (device-color-cells))
 242             0))
 243   "If non-nil, hide verbatim markers.
 244 The value should be nil on displays where the face
 245 `mm-uu-extract' isn't distinguishable to the face `default'."
 246   :type '(choice (const :tag "Hide" t)
 247                  (const :tag "Don't hide" nil))
 248   :version "23.1" ;; No Gnus
 249   :group 'gnus-article-mime)
 250
 251 (defface mm-uu-extract '(;; Inspired by `gnus-cite-3'
 252                          (((type tty)
 253                            (class color)
 254                            (background dark))
 255                           (:background "dark blue"))
 256                          (((class color)
 257                            (background dark))
 258                           (:foreground "light yellow"
 259                            :background "dark green"))
 260                          (((type tty)
 261                            (class color)
 262                            (background light))
 263                           (:foreground "dark blue"))
 264                          (((class color)
 265                            (background light))
 266                           (:foreground "dark green"
 267                            :background "light yellow"))
 268                          (t
 269                           ()))
 270   "Face for extracted buffers."
 271   ;; See `mm-uu-verbatim-marks-extract'.
 272   :version "23.1" ;; No Gnus
 273   :group 'gnus-article-mime)
 274
 275 (defun mm-uu-copy-to-buffer (&optional from to properties)
 276   "Copy the contents of the current buffer to a fresh buffer.
 277 Return that buffer.
 278
 279 If PROPERTIES is non-nil, PROPERTIES are applied to the buffer,
 280 see `set-text-properties'.  If PROPERTIES equals t, this means to
 281 apply the face `mm-uu-extract'."
 282   (let ((obuf (current-buffer))
 283         (multi (and (boundp 'enable-multibyte-characters)
 284                     enable-multibyte-characters))
 285         (coding-system
 286          ;; Might not exist in non-MULE XEmacs
 287          (when (boundp 'buffer-file-coding-system)
 288            buffer-file-coding-system)))
 289     (with-current-buffer (generate-new-buffer " *mm-uu*")
 290       (if multi (mm-enable-multibyte) (mm-disable-multibyte))
 291       (setq buffer-file-coding-system coding-system)
 292       (insert-buffer-substring obuf from to)
 293       (cond ((eq properties  t)
 294              (set-text-properties (point-min) (point-max)
 295                                   '(face mm-uu-extract)))
 296             (properties
 297              (set-text-properties (point-min) (point-max) properties)))
 298       (current-buffer))))
 299
 300 (defun mm-uu-configure-p  (key val)
 301   (member (cons key val) mm-uu-configure-list))
 302
 303 (defun mm-uu-configure (&optional symbol value)
 304   "Configure detection of non-MIME attachments."
 305   (interactive)
 306   (if symbol (set-default symbol value))
 307   (setq mm-uu-beginning-regexp nil)
 308   (mapcar (lambda (entry)
 309              (if (mm-uu-configure-p (mm-uu-type entry) 'disabled)
 310                  nil
 311                (setq mm-uu-beginning-regexp
 312                      (concat mm-uu-beginning-regexp
 313                              (if mm-uu-beginning-regexp "\\|")
 314                              (mm-uu-beginning-regexp entry)))))
 315           mm-uu-type-alist))
 316
 317 (mm-uu-configure)
 318
 319 (defvar file-name)
 320 (defvar start-point)
 321 (defvar end-point)
 322 (defvar entry)
 323
 324 (defun mm-uu-uu-filename ()
 325   (if (looking-at ".+")
 326       (setq file-name
 327             (let ((nnheader-file-name-translation-alist
 328                    '((?/ . ?,) (?\  . ?_) (?* . ?_) (?$ . ?_))))
 329               (nnheader-translate-file-chars (match-string 0))))))
 330
 331 (defun mm-uu-binhex-filename ()
 332   (setq file-name
 333         (ignore-errors
 334           (binhex-decode-region start-point end-point t))))
 335
 336 (defun mm-uu-yenc-filename ()
 337   (goto-char start-point)
 338   (setq file-name
 339         (ignore-errors
 340           (yenc-extract-filename))))
 341
 342 (defun mm-uu-forward-test ()
 343   (save-excursion
 344     (goto-char start-point)
 345     (forward-line)
 346     (looking-at "[\r\n]*[a-zA-Z][a-zA-Z0-9-]*:")))
 347
 348 (defun mm-uu-postscript-extract ()
 349   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
 350                   '("application/postscript")))
 351
 352 (defun mm-uu-verbatim-marks-extract (start-offset end-offset
 353                                                   &optional
 354                                                   start-hide
 355                                                   end-hide)
 356   (let ((start (or (and mm-uu-hide-markers
 357                         start-hide)
 358                    start-offset
 359                    1))
 360         (end   (or (and mm-uu-hide-markers
 361                         end-hide)
 362                    end-offset
 363                    -1)))
 364     (mm-make-handle
 365      (mm-uu-copy-to-buffer
 366       (progn (goto-char start-point)
 367              (forward-line start)
 368              (point))
 369       (progn (goto-char end-point)
 370            (forward-line end)
 371            (point))
 372       t)
 373      '("text/x-verbatim" (charset . gnus-decoded)))))
 374
 375 (defun mm-uu-latex-extract ()
 376   (mm-make-handle
 377    (mm-uu-copy-to-buffer start-point end-point t)
 378    ;; application/x-tex?
 379    '("text/x-verbatim" (charset . gnus-decoded))))
 380
 381 (defun mm-uu-emacs-sources-extract ()
 382   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
 383                   '("application/emacs-lisp" (charset . gnus-decoded))
 384                   nil nil
 385                   (list mm-dissect-disposition
 386                         (cons 'filename file-name))))
 387
 388 (defvar gnus-newsgroup-name)
 389
 390 (defun mm-uu-emacs-sources-test ()
 391   (setq file-name (match-string 1))
 392   (and gnus-newsgroup-name
 393        mm-uu-emacs-sources-regexp
 394        (string-match mm-uu-emacs-sources-regexp gnus-newsgroup-name)))
 395
 396 (defun mm-uu-diff-extract ()
 397   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
 398                   '("text/x-patch" (charset . gnus-decoded))))
 399
 400 (defun mm-uu-diff-test ()
 401   (and gnus-newsgroup-name
 402        mm-uu-diff-groups-regexp
 403        (string-match mm-uu-diff-groups-regexp gnus-newsgroup-name)))
 404
 405 (defun mm-uu-latex-test ()
 406   (and gnus-newsgroup-name
 407        mm-uu-tex-groups-regexp
 408        (string-match mm-uu-tex-groups-regexp gnus-newsgroup-name)))
 409
 410 (defun mm-uu-forward-extract ()
 411   (mm-make-handle (mm-uu-copy-to-buffer
 412                    (progn (goto-char start-point) (forward-line) (point))
 413                    (progn (goto-char end-point) (forward-line -1) (point)))
 414                   '("message/rfc822" (charset . gnus-decoded))))
 415
 416 (defun mm-uu-uu-extract ()
 417   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
 418                   (list (or (and file-name
 419                                  (string-match "\\.[^\\.]+$"
 420                                                file-name)
 421                                  (mailcap-extension-to-mime
 422                                   (match-string 0 file-name)))
 423                             "application/octet-stream"))
 424                   'x-uuencode nil
 425                   (if (and file-name (not (equal file-name "")))
 426                       (list mm-dissect-disposition
 427                             (cons 'filename file-name)))))
 428
 429 (defun mm-uu-binhex-extract ()
 430   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
 431                   (list (or (and file-name
 432                                  (string-match "\\.[^\\.]+$" file-name)
 433                                  (mailcap-extension-to-mime
 434                                   (match-string 0 file-name)))
 435                             "application/octet-stream"))
 436                   'x-binhex nil
 437                   (if (and file-name (not (equal file-name "")))
 438                       (list mm-dissect-disposition
 439                             (cons 'filename file-name)))))
 440
 441 (defvar gnus-original-article-buffer)   ; gnus.el
 442
 443 (defun mm-uu-yenc-extract ()
 444   ;; This might not be exactly correct, but we sure can't get the
 445   ;; binary data from the article buffer, since that's already in a
 446   ;; non-binary charset.  So get it from the original article buffer.
 447   (mm-make-handle (with-current-buffer gnus-original-article-buffer
 448                     (mm-uu-copy-to-buffer start-point end-point))
 449                   (list (or (and file-name
 450                                  (string-match "\\.[^\\.]+$" file-name)
 451                                  (mailcap-extension-to-mime
 452                                   (match-string 0 file-name)))
 453                             "application/octet-stream"))
 454                   'x-yenc nil
 455                   (if (and file-name (not (equal file-name "")))
 456                       (list mm-dissect-disposition
 457                             (cons 'filename file-name)))))
 458
 459
 460 (defun mm-uu-shar-extract ()
 461   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
 462                   '("application/x-shar")))
 463
 464 (defun mm-uu-gnatsweb-extract ()
 465   (save-restriction
 466     (goto-char start-point)
 467     (forward-line)
 468     (narrow-to-region (point) end-point)
 469     (mm-dissect-buffer t)))
 470
 471 (defun mm-uu-pgp-signed-test (&rest rest)
 472   (and
 473    mml2015-use
 474    (mml2015-clear-verify-function)
 475    (cond
 476     ((eq mm-verify-option 'never) nil)
 477     ((eq mm-verify-option 'always) t)
 478     ((eq mm-verify-option 'known) t)
 479     (t (prog1
 480            (y-or-n-p "Verify pgp signed part? ")
 481          (message ""))))))
 482
 483 (defvar gnus-newsgroup-charset)
 484
 485 (defun mm-uu-pgp-signed-extract-1 (handles ctl)
 486   (let ((buf (mm-uu-copy-to-buffer (point-min) (point-max))))
 487     (with-current-buffer buf
 488       (if (mm-uu-pgp-signed-test)
 489           (progn
 490             (mml2015-clean-buffer)
 491             (let ((coding-system-for-write (or gnus-newsgroup-charset
 492                                                'iso-8859-1))
 493                   (coding-system-for-read (or gnus-newsgroup-charset
 494                                               'iso-8859-1)))
 495               (funcall (mml2015-clear-verify-function))))
 496         (when (and mml2015-use (null (mml2015-clear-verify-function)))
 497           (mm-set-handle-multipart-parameter
 498            mm-security-handle 'gnus-details
 499            (format "Clear verification not supported by `%s'.\n" mml2015-use)))
 500         (mml2015-extract-cleartext-signature))
 501       (list (mm-make-handle buf mm-uu-text-plain-type)))))
 502
 503 (defun mm-uu-pgp-signed-extract ()
 504   (let ((mm-security-handle (list (format "multipart/signed"))))
 505     (mm-set-handle-multipart-parameter
 506      mm-security-handle 'protocol "application/x-gnus-pgp-signature")
 507     (save-restriction
 508       (narrow-to-region start-point end-point)
 509       (add-text-properties 0 (length (car mm-security-handle))
 510                            (list 'buffer (mm-uu-copy-to-buffer))
 511                            (car mm-security-handle))
 512       (setcdr mm-security-handle
 513               (mm-uu-pgp-signed-extract-1 nil
 514                                           mm-security-handle)))
 515     mm-security-handle))
 516
 517 (defun mm-uu-pgp-encrypted-test (&rest rest)
 518   (and
 519    mml2015-use
 520    (mml2015-clear-decrypt-function)
 521    (cond
 522     ((eq mm-decrypt-option 'never) nil)
 523     ((eq mm-decrypt-option 'always) t)
 524     ((eq mm-decrypt-option 'known) t)
 525     (t (prog1
 526            (y-or-n-p "Decrypt pgp encrypted part? ")
 527          (message ""))))))
 528
 529 (defun mm-uu-pgp-encrypted-extract-1 (handles ctl)
 530   (let ((buf (mm-uu-copy-to-buffer (point-min) (point-max)))
 531         (first t)
 532         charset)
 533     ;; Make sure there's a blank line between header and body.
 534     (with-current-buffer buf
 535       (goto-char (point-min))
 536       (while (prog2
 537                  (forward-line 1)
 538                  (if first
 539                      (looking-at "[^\t\n ]+:")
 540                    (looking-at "[^\t\n ]+:\\|[\t ]"))
 541                (setq first nil)))
 542       (unless (memq (char-after) '(?\n nil))
 543         (insert "\n"))
 544       (save-restriction
 545         (narrow-to-region (point-min) (point))
 546         (setq charset (mail-fetch-field "charset")))
 547       (if (and (mm-uu-pgp-encrypted-test)
 548                (progn
 549                  (mml2015-clean-buffer)
 550                  (funcall (mml2015-clear-decrypt-function))
 551                  (equal (mm-handle-multipart-ctl-parameter mm-security-handle
 552                                                            'gnus-info)
 553                         "OK")))
 554           (progn
 555             ;; Decode charset.
 556             (if (and (or charset
 557                          (setq charset gnus-newsgroup-charset))
 558                      (setq charset (mm-charset-to-coding-system charset))
 559                      (not (eq charset 'ascii)))
 560                 ;; Assume that buffer's multibyteness is turned off.
 561                 ;; See `mml2015-pgg-clear-decrypt'.
 562                 (insert (mm-decode-coding-string (prog1
 563                                                      (buffer-string)
 564                                                    (erase-buffer)
 565                                                    (mm-enable-multibyte))
 566                                                  charset))
 567               (mm-enable-multibyte))
 568             (list (mm-make-handle buf mm-uu-text-plain-type)))
 569         (list (mm-make-handle buf '("application/pgp-encrypted")))))))
 570
 571 (defun mm-uu-pgp-encrypted-extract ()
 572   (let ((mm-security-handle (list (format "multipart/encrypted"))))
 573     (mm-set-handle-multipart-parameter
 574      mm-security-handle 'protocol "application/x-gnus-pgp-encrypted")
 575     (save-restriction
 576       (narrow-to-region start-point end-point)
 577       (add-text-properties 0 (length (car mm-security-handle))
 578                            (list 'buffer (mm-uu-copy-to-buffer))
 579                            (car mm-security-handle))
 580       (setcdr mm-security-handle
 581               (mm-uu-pgp-encrypted-extract-1 nil
 582                                              mm-security-handle)))
 583     mm-security-handle))
 584
 585 (defun mm-uu-gpg-key-skip-to-last ()
 586   (let ((point (point))
 587         (end-regexp (mm-uu-end-regexp entry))
 588         (beginning-regexp (mm-uu-beginning-regexp entry)))
 589     (when (and end-regexp
 590                (not (mm-uu-configure-p (mm-uu-type entry) 'disabled)))
 591       (while (re-search-forward end-regexp nil t)
 592         (skip-chars-forward " \t\n\r")
 593         (if (looking-at beginning-regexp)
 594             (setq point (match-end 0)))))
 595     (goto-char point)))
 596
 597 (defun mm-uu-pgp-key-extract ()
 598   (let ((buf (mm-uu-copy-to-buffer start-point end-point)))
 599     (mm-make-handle buf
 600                     '("application/pgp-keys"))))
 601
 602 ;;;###autoload
 603 (defun mm-uu-dissect (&optional noheader mime-type)
 604   "Dissect the current buffer and return a list of uu handles.
 605 The optional NOHEADER means there's no header in the buffer.
 606 MIME-TYPE specifies a MIME type and parameters, which defaults to the
 607 value of `mm-uu-text-plain-type'."
 608   (let ((case-fold-search t)
 609         (mm-uu-text-plain-type (or mime-type mm-uu-text-plain-type))
 610         text-start start-point end-point file-name result entry func)
 611     (save-excursion
 612       (goto-char (point-min))
 613       (cond
 614        (noheader)
 615        ((looking-at "\n")
 616         (forward-line))
 617        ((search-forward "\n\n" nil t)
 618         t)
 619        (t (goto-char (point-max))))
 620       (setq text-start (point))
 621       (while (re-search-forward mm-uu-beginning-regexp nil t)
 622         (setq start-point (match-beginning 0)
 623               entry nil)
 624         (let ((alist mm-uu-type-alist)
 625               (beginning-regexp (match-string 0)))
 626           (while (not entry)
 627             (if (string-match (mm-uu-beginning-regexp (car alist))
 628                               beginning-regexp)
 629                 (setq entry (car alist))
 630               (pop alist))))
 631         (if (setq func (mm-uu-function-1 entry))
 632             (funcall func))
 633         (forward-line);; in case of failure
 634         (when (and (not (mm-uu-configure-p (mm-uu-type entry) 'disabled))
 635                    (let ((end-regexp (mm-uu-end-regexp entry)))
 636                      (if (not end-regexp)
 637                          (or (setq end-point (point-max)) t)
 638                        (prog1
 639                            (re-search-forward end-regexp nil t)
 640                          (forward-line)
 641                          (setq end-point (point)))))
 642                    (or (not (setq func (mm-uu-function-2 entry)))
 643                        (funcall func)))
 644           (if (and (> start-point text-start)
 645                    (progn
 646                      (goto-char text-start)
 647                      (re-search-forward "." start-point t)))
 648               (push
 649                (mm-make-handle (mm-uu-copy-to-buffer text-start start-point)
 650                                mm-uu-text-plain-type)
 651                result))
 652           (push
 653            (funcall (mm-uu-function-extract entry))
 654            result)
 655           (goto-char (setq text-start end-point))))
 656       (when result
 657         (if (and (> (point-max) (1+ text-start))
 658                  (save-excursion
 659                    (goto-char text-start)
 660                    (re-search-forward "." nil t)))
 661             (push
 662              (mm-make-handle (mm-uu-copy-to-buffer text-start (point-max))
 663                              mm-uu-text-plain-type)
 664              result))
 665         (setq result (cons "multipart/mixed" (nreverse result))))
 666       result)))
 667
 668 ;;;###autoload
 669 (defun mm-uu-dissect-text-parts (handle &optional decoded)
 670   "Dissect text parts and put uu handles into HANDLE.
 671 Assume text has been decoded if DECODED is non-nil."
 672   (let ((buffer (mm-handle-buffer handle)))
 673     (cond ((stringp buffer)
 674            (dolist (elem (cdr handle))
 675              (mm-uu-dissect-text-parts elem decoded)))
 676           ((bufferp buffer)
 677            (let ((type (mm-handle-media-type handle))
 678                  (case-fold-search t) ;; string-match
 679                  children charset encoding)
 680              (when (and
 681                     (stringp type)
 682                     ;; Mutt still uses application/pgp even though
 683                     ;; it has already been withdrawn.
 684                     (string-match "\\`text/\\|\\`application/pgp\\'" type)
 685                     (setq
 686                      children
 687                      (with-current-buffer buffer
 688                        (cond
 689                         ((or decoded
 690                              (eq (setq charset (mail-content-type-get
 691                                                 (mm-handle-type handle)
 692                                                 'charset))
 693                                  'gnus-decoded))
 694                          (setq decoded t)
 695                          (mm-uu-dissect
 696                           t (cons type '((charset . gnus-decoded)))))
 697                         (charset
 698                          (setq decoded t)
 699                          (mm-with-multibyte-buffer
 700                            (insert (mm-decode-string (mm-get-part handle)
 701                                                      charset))
 702                            (mm-uu-dissect
 703                             t (cons type '((charset . gnus-decoded))))))
 704                         ((setq encoding (mm-handle-encoding handle))
 705                          (setq decoded nil)
 706                          ;; Inherit the multibyteness of the `buffer'.
 707                          (with-temp-buffer
 708                            (insert-buffer-substring buffer)
 709                            (mm-decode-content-transfer-encoding
 710                             encoding type)
 711                            (mm-uu-dissect t (list type))))
 712                         (t
 713                          (setq decoded nil)
 714                          (mm-uu-dissect t (list type)))))))
 715                ;; Ignore it if a given part is dissected into a single
 716                ;; part of which the type is the same as the given one.
 717                (if (and (<= (length children) 2)
 718                         (string-equal (mm-handle-media-type (cadr children))
 719                                       type))
 720                    (kill-buffer (mm-handle-buffer (cadr children)))
 721                  (kill-buffer buffer)
 722                  (setcdr handle (cdr children))
 723                  (setcar handle (car children)) ;; "multipart/mixed"
 724                  (dolist (elem (cdr children))
 725                    (mm-uu-dissect-text-parts elem decoded))))))
 726           (t
 727            (dolist (elem handle)
 728              (mm-uu-dissect-text-parts elem decoded))))))
 729
 730 (provide 'mm-uu)
 731
 732 ;; arch-tag: 7db076bf-53db-4320-aa19-ca76a1d2ab2c
 733 ;;; mm-uu.el ends here