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