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