code.delx.au - gnu-emacs/blob - lisp/gnus/mm-uu.el

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