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