cgit.sxemacs.org Git - gnus/blob - lisp/mm-uu.el

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