lisp/gnus/mm-uu.el

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