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-2014 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://slrn.sourceforge.net/docs/slrn-manual-6.html#process_verbatim_marks
 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
 434                      (goto-char start-point)
 435                      (forward-line)
 436                      (skip-chars-forward "\n")
 437                      (point))
 438                    (progn (goto-char end-point) (forward-line -1) (point)))
 439                   '("message/rfc822" (charset . gnus-decoded))))
 440
 441 (defun mm-uu-uu-extract ()
 442   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
 443                   (list (or (and file-name
 444                                  (string-match "\\.[^\\.]+$"
 445                                                file-name)
 446                                  (mailcap-extension-to-mime
 447                                   (match-string 0 file-name)))
 448                             "application/octet-stream"))
 449                   'x-uuencode nil
 450                   (if (and file-name (not (equal file-name "")))
 451                       (list mm-dissect-disposition
 452                             (cons 'filename file-name)))))
 453
 454 (defun mm-uu-binhex-extract ()
 455   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
 456                   (list (or (and file-name
 457                                  (string-match "\\.[^\\.]+$" file-name)
 458                                  (mailcap-extension-to-mime
 459                                   (match-string 0 file-name)))
 460                             "application/octet-stream"))
 461                   'x-binhex nil
 462                   (if (and file-name (not (equal file-name "")))
 463                       (list mm-dissect-disposition
 464                             (cons 'filename file-name)))))
 465
 466 (defvar gnus-original-article-buffer)   ; gnus.el
 467
 468 (defun mm-uu-yenc-extract ()
 469   ;; This might not be exactly correct, but we sure can't get the
 470   ;; binary data from the article buffer, since that's already in a
 471   ;; non-binary charset.  So get it from the original article buffer.
 472   (mm-make-handle (with-current-buffer gnus-original-article-buffer
 473                     (mm-uu-copy-to-buffer start-point end-point))
 474                   (list (or (and file-name
 475                                  (string-match "\\.[^\\.]+$" file-name)
 476                                  (mailcap-extension-to-mime
 477                                   (match-string 0 file-name)))
 478                             "application/octet-stream"))
 479                   'x-yenc nil
 480                   (if (and file-name (not (equal file-name "")))
 481                       (list mm-dissect-disposition
 482                             (cons 'filename file-name)))))
 483
 484
 485 (defun mm-uu-shar-extract ()
 486   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
 487                   '("application/x-shar")))
 488
 489 (defun mm-uu-gnatsweb-extract ()
 490   (save-restriction
 491     (goto-char start-point)
 492     (forward-line)
 493     (narrow-to-region (point) end-point)
 494     (mm-dissect-buffer t)))
 495
 496 (defun mm-uu-pgp-signed-test (&rest rest)
 497   (and
 498    mml2015-use
 499    (mml2015-clear-verify-function)
 500    (cond
 501     ((eq mm-verify-option 'never) nil)
 502     ((eq mm-verify-option 'always) t)
 503     ((eq mm-verify-option 'known) t)
 504     (t (prog1
 505            (y-or-n-p "Verify pgp signed part? ")
 506          (message ""))))))
 507
 508 (defvar gnus-newsgroup-charset)
 509
 510 (defun mm-uu-pgp-signed-extract-1 (handles ctl)
 511   (let ((buf (mm-uu-copy-to-buffer (point-min) (point-max))))
 512     (with-current-buffer buf
 513       (if (mm-uu-pgp-signed-test)
 514           (progn
 515             (mml2015-clean-buffer)
 516             (let ((coding-system-for-write (or buffer-file-coding-system
 517                                                gnus-newsgroup-charset
 518                                                'iso-8859-1))
 519                   (coding-system-for-read (or buffer-file-coding-system
 520                                               gnus-newsgroup-charset
 521                                               'iso-8859-1)))
 522               (funcall (mml2015-clear-verify-function))))
 523         (when (and mml2015-use (null (mml2015-clear-verify-function)))
 524           (mm-set-handle-multipart-parameter
 525            mm-security-handle 'gnus-details
 526            (format "Clear verification not supported by `%s'.\n" mml2015-use)))
 527         (mml2015-extract-cleartext-signature))
 528       (list (mm-make-handle buf mm-uu-text-plain-type)))))
 529
 530 (defun mm-uu-pgp-signed-extract ()
 531   (let ((mm-security-handle (list (format "multipart/signed"))))
 532     (mm-set-handle-multipart-parameter
 533      mm-security-handle 'protocol "application/x-gnus-pgp-signature")
 534     (save-restriction
 535       (narrow-to-region start-point end-point)
 536       (add-text-properties 0 (length (car mm-security-handle))
 537                            (list 'buffer (mm-uu-copy-to-buffer))
 538                            (car mm-security-handle))
 539       (setcdr mm-security-handle
 540               (mm-uu-pgp-signed-extract-1 nil
 541                                           mm-security-handle)))
 542     mm-security-handle))
 543
 544 (defun mm-uu-pgp-encrypted-test (&rest rest)
 545   (and
 546    mml2015-use
 547    (mml2015-clear-decrypt-function)
 548    (cond
 549     ((eq mm-decrypt-option 'never) nil)
 550     ((eq mm-decrypt-option 'always) t)
 551     ((eq mm-decrypt-option 'known) t)
 552     (t (prog1
 553            (y-or-n-p "Decrypt pgp encrypted part? ")
 554          (message ""))))))
 555
 556 (defun mm-uu-pgp-encrypted-extract-1 (handles ctl)
 557   (let ((buf (mm-uu-copy-to-buffer (point-min) (point-max)))
 558         (first t)
 559         charset)
 560     ;; Make sure there's a blank line between header and body.
 561     (with-current-buffer buf
 562       (goto-char (point-min))
 563       (while (prog2
 564                  (forward-line 1)
 565                  (if first
 566                      (looking-at "[^\t\n ]+:")
 567                    (looking-at "[^\t\n ]+:\\|[\t ]"))
 568                (setq first nil)))
 569       (unless (memq (char-after) '(?\n nil))
 570         (insert "\n"))
 571       (save-restriction
 572         (narrow-to-region (point-min) (point))
 573         (setq charset (mail-fetch-field "charset")))
 574       (if (and (mm-uu-pgp-encrypted-test)
 575                (progn
 576                  (mml2015-clean-buffer)
 577                  (funcall (mml2015-clear-decrypt-function))
 578                  (equal (mm-handle-multipart-ctl-parameter mm-security-handle
 579                                                            'gnus-info)
 580                         "OK")))
 581           (progn
 582             ;; Decode charset.
 583             (if (and (or charset
 584                          (setq charset gnus-newsgroup-charset))
 585                      (setq charset (mm-charset-to-coding-system charset))
 586                      (not (eq charset 'ascii)))
 587                 ;; Assume that buffer's multibyteness is turned off.
 588                 ;; See `mml2015-pgg-clear-decrypt'.
 589                 (insert (mm-decode-coding-string (prog1
 590                                                      (buffer-string)
 591                                                    (erase-buffer)
 592                                                    (mm-enable-multibyte))
 593                                                  charset))
 594               (mm-enable-multibyte))
 595             (list (mm-make-handle buf mm-uu-text-plain-type)))
 596         (list (mm-make-handle buf '("application/pgp-encrypted")))))))
 597
 598 (defun mm-uu-pgp-encrypted-extract ()
 599   (let ((mm-security-handle (list (format "multipart/encrypted"))))
 600     (mm-set-handle-multipart-parameter
 601      mm-security-handle 'protocol "application/x-gnus-pgp-encrypted")
 602     (save-restriction
 603       (narrow-to-region start-point end-point)
 604       (add-text-properties 0 (length (car mm-security-handle))
 605                            (list 'buffer (mm-uu-copy-to-buffer))
 606                            (car mm-security-handle))
 607       (setcdr mm-security-handle
 608               (mm-uu-pgp-encrypted-extract-1 nil
 609                                              mm-security-handle)))
 610     mm-security-handle))
 611
 612 (defun mm-uu-gpg-key-skip-to-last ()
 613   (let ((point (point))
 614         (end-regexp (mm-uu-end-regexp entry))
 615         (beginning-regexp (mm-uu-beginning-regexp entry)))
 616     (when (and end-regexp
 617                (not (mm-uu-configure-p (mm-uu-type entry) 'disabled)))
 618       (while (re-search-forward end-regexp nil t)
 619         (skip-chars-forward " \t\n\r")
 620         (if (looking-at beginning-regexp)
 621             (setq point (match-end 0)))))
 622     (goto-char point)))
 623
 624 (defun mm-uu-pgp-key-extract ()
 625   (let ((buf (mm-uu-copy-to-buffer start-point end-point)))
 626     (mm-make-handle buf
 627                     '("application/pgp-keys"))))
 628
 629 ;;;###autoload
 630 (defun mm-uu-dissect (&optional noheader mime-type)
 631   "Dissect the current buffer and return a list of uu handles.
 632 The optional NOHEADER means there's no header in the buffer.
 633 MIME-TYPE specifies a MIME type and parameters, which defaults to the
 634 value of `mm-uu-text-plain-type'."
 635   (let ((case-fold-search t)
 636         (mm-uu-text-plain-type (or mime-type mm-uu-text-plain-type))
 637         text-start start-point end-point file-name result entry func)
 638     (save-excursion
 639       (goto-char (point-min))
 640       (cond
 641        (noheader)
 642        ((looking-at "\n")
 643         (forward-line))
 644        ((search-forward "\n\n" nil t)
 645         t)
 646        (t (goto-char (point-max))))
 647       (setq text-start (point))
 648       (while (re-search-forward mm-uu-beginning-regexp nil t)
 649         (setq start-point (match-beginning 0)
 650               entry nil)
 651         (let ((alist mm-uu-type-alist)
 652               (beginning-regexp (match-string 0)))
 653           (while (not entry)
 654             (if (string-match (mm-uu-beginning-regexp (car alist))
 655                               beginning-regexp)
 656                 (setq entry (car alist))
 657               (pop alist))))
 658         (if (setq func (mm-uu-function-1 entry))
 659             (funcall func))
 660         (forward-line);; in case of failure
 661         (when (and (not (mm-uu-configure-p (mm-uu-type entry) 'disabled))
 662                    (let ((end-regexp (mm-uu-end-regexp entry)))
 663                      (if (not end-regexp)
 664                          (or (setq end-point (point-max)) t)
 665                        (prog1
 666                            (re-search-forward end-regexp nil t)
 667                          (forward-line)
 668                          (setq end-point (point)))))
 669                    (or (not (setq func (mm-uu-function-2 entry)))
 670                        (funcall func)))
 671           (if (and (> start-point text-start)
 672                    (progn
 673                      (goto-char text-start)
 674                      (re-search-forward "." start-point t)))
 675               (push
 676                (mm-make-handle
 677                 (mm-uu-copy-to-buffer
 678                  text-start
 679                  ;; A start-separator is likely accompanied by
 680                  ;; a leading newline.
 681                  (if (and (eq (char-before start-point) ?\n)
 682                           (eq (char-before (1- start-point)) ?\n))
 683                      (1- start-point)
 684                    start-point))
 685                 mm-uu-text-plain-type)
 686                result))
 687           (push
 688            (funcall (mm-uu-function-extract entry))
 689            result)
 690           (goto-char (setq text-start end-point))))
 691       (when result
 692         (goto-char text-start)
 693         (when (re-search-forward "." nil t)
 694           (push (mm-make-handle
 695                  (mm-uu-copy-to-buffer
 696                   ;; An end-separator is likely accompanied by
 697                   ;; a trailing newline.
 698                   (if (eq (char-after text-start) ?\n)
 699                       (1+ text-start)
 700                     text-start)
 701                   (point-max))
 702                  mm-uu-text-plain-type)
 703                 result))
 704         (setq result (cons "multipart/mixed" (nreverse result))))
 705       result)))
 706
 707 ;;;###autoload
 708 (defun mm-uu-dissect-text-parts (handle &optional decoded)
 709   "Dissect text parts and put uu handles into HANDLE.
 710 Assume text has been decoded if DECODED is non-nil."
 711   (let ((buffer (mm-handle-buffer handle)))
 712     (cond ((stringp buffer)
 713            (dolist (elem (cdr handle))
 714              (mm-uu-dissect-text-parts elem decoded)))
 715           ((bufferp buffer)
 716            (let ((type (mm-handle-media-type handle))
 717                  (case-fold-search t) ;; string-match
 718                  children charset encoding)
 719              (when (and
 720                     (stringp type)
 721                     ;; Mutt still uses application/pgp even though
 722                     ;; it has already been withdrawn.
 723                     (string-match "\\`text/\\|\\`application/pgp\\'" type)
 724                     (equal (car (mm-handle-disposition handle))
 725                            "inline")
 726                     (setq
 727                      children
 728                      (with-current-buffer buffer
 729                        (cond
 730                         ((or decoded
 731                              (eq (setq charset (mail-content-type-get
 732                                                 (mm-handle-type handle)
 733                                                 'charset))
 734                                  'gnus-decoded))
 735                          (setq decoded t)
 736                          (mm-uu-dissect
 737                           t (cons type '((charset . gnus-decoded)))))
 738                         (charset
 739                          (setq decoded t)
 740                          (mm-with-multibyte-buffer
 741                            (insert (mm-decode-string (mm-get-part handle)
 742                                                      charset))
 743                            (mm-uu-dissect
 744                             t (cons type '((charset . gnus-decoded))))))
 745                         ((setq encoding (mm-handle-encoding handle))
 746                          (setq decoded nil)
 747                          ;; Inherit the multibyteness of the `buffer'.
 748                          (with-temp-buffer
 749                            (insert-buffer-substring buffer)
 750                            (mm-decode-content-transfer-encoding
 751                             encoding type)
 752                            (mm-uu-dissect t (list type))))
 753                         (t
 754                          (setq decoded nil)
 755                          (mm-uu-dissect t (list type)))))))
 756                ;; Ignore it if a given part is dissected into a single
 757                ;; part of which the type is the same as the given one.
 758                (if (and (<= (length children) 2)
 759                         (string-equal (mm-handle-media-type (cadr children))
 760                                       type))
 761                    (kill-buffer (mm-handle-buffer (cadr children)))
 762                  (kill-buffer buffer)
 763                  (setcdr handle (cdr children))
 764                  (setcar handle (car children)) ;; "multipart/mixed"
 765                  (dolist (elem (cdr children))
 766                    (mm-uu-dissect-text-parts elem decoded))))))
 767           (t
 768            (dolist (elem handle)
 769              (mm-uu-dissect-text-parts elem decoded))))))
 770
 771 (provide 'mm-uu)
 772
 773 ;;; mm-uu.el ends here