lisp/gnus/mm-uu.el

   1 ;;; mm-uu.el --- Return uu stuff as mm handles
   2
   3 ;; Copyright (C) 1998-2015 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            (gnus-format-message
 527             "Clear verification not supported by `%s'.\n" mml2015-use)))
 528         (mml2015-extract-cleartext-signature))
 529       (list (mm-make-handle buf mm-uu-text-plain-type)))))
 530
 531 (defun mm-uu-pgp-signed-extract ()
 532   (let ((mm-security-handle (list (format "multipart/signed"))))
 533     (mm-set-handle-multipart-parameter
 534      mm-security-handle 'protocol "application/x-gnus-pgp-signature")
 535     (save-restriction
 536       (narrow-to-region start-point end-point)
 537       (add-text-properties 0 (length (car mm-security-handle))
 538                            (list 'buffer (mm-uu-copy-to-buffer))
 539                            (car mm-security-handle))
 540       (setcdr mm-security-handle
 541               (mm-uu-pgp-signed-extract-1 nil
 542                                           mm-security-handle)))
 543     mm-security-handle))
 544
 545 (defun mm-uu-pgp-encrypted-test (&rest rest)
 546   (and
 547    mml2015-use
 548    (mml2015-clear-decrypt-function)
 549    (cond
 550     ((eq mm-decrypt-option 'never) nil)
 551     ((eq mm-decrypt-option 'always) t)
 552     ((eq mm-decrypt-option 'known) t)
 553     (t (prog1
 554            (y-or-n-p "Decrypt pgp encrypted part? ")
 555          (message ""))))))
 556
 557 (defun mm-uu-pgp-encrypted-extract-1 (handles ctl)
 558   (let ((buf (mm-uu-copy-to-buffer (point-min) (point-max)))
 559         (first t)
 560         charset)
 561     ;; Make sure there's a blank line between header and body.
 562     (with-current-buffer buf
 563       (goto-char (point-min))
 564       (while (prog2
 565                  (forward-line 1)
 566                  (if first
 567                      (looking-at "[^\t\n ]+:")
 568                    (looking-at "[^\t\n ]+:\\|[\t ]"))
 569                (setq first nil)))
 570       (unless (memq (char-after) '(?\n nil))
 571         (insert "\n"))
 572       (save-restriction
 573         (narrow-to-region (point-min) (point))
 574         (setq charset (mail-fetch-field "charset")))
 575       (if (and (mm-uu-pgp-encrypted-test)
 576                (progn
 577                  (mml2015-clean-buffer)
 578                  (funcall (mml2015-clear-decrypt-function))
 579                  (equal (mm-handle-multipart-ctl-parameter mm-security-handle
 580                                                            'gnus-info)
 581                         "OK")))
 582           (progn
 583             ;; Decode charset.
 584             (if (and (or charset
 585                          (setq charset gnus-newsgroup-charset))
 586                      (setq charset (mm-charset-to-coding-system charset))
 587                      (not (eq charset 'ascii)))
 588                 ;; Assume that buffer's multibyteness is turned off.
 589                 ;; See `mml2015-pgg-clear-decrypt'.
 590                 (insert (mm-decode-coding-string (prog1
 591                                                      (buffer-string)
 592                                                    (erase-buffer)
 593                                                    (mm-enable-multibyte))
 594                                                  charset))
 595               (mm-enable-multibyte))
 596             (list (mm-make-handle buf mm-uu-text-plain-type)))
 597         (list (mm-make-handle buf '("application/pgp-encrypted")))))))
 598
 599 (defun mm-uu-pgp-encrypted-extract ()
 600   (let ((mm-security-handle (list (format "multipart/encrypted"))))
 601     (mm-set-handle-multipart-parameter
 602      mm-security-handle 'protocol "application/x-gnus-pgp-encrypted")
 603     (save-restriction
 604       (narrow-to-region start-point end-point)
 605       (add-text-properties 0 (length (car mm-security-handle))
 606                            (list 'buffer (mm-uu-copy-to-buffer))
 607                            (car mm-security-handle))
 608       (setcdr mm-security-handle
 609               (mm-uu-pgp-encrypted-extract-1 nil
 610                                              mm-security-handle)))
 611     mm-security-handle))
 612
 613 (defun mm-uu-gpg-key-skip-to-last ()
 614   (let ((point (point))
 615         (end-regexp (mm-uu-end-regexp entry))
 616         (beginning-regexp (mm-uu-beginning-regexp entry)))
 617     (when (and end-regexp
 618                (not (mm-uu-configure-p (mm-uu-type entry) 'disabled)))
 619       (while (re-search-forward end-regexp nil t)
 620         (skip-chars-forward " \t\n\r")
 621         (if (looking-at beginning-regexp)
 622             (setq point (match-end 0)))))
 623     (goto-char point)))
 624
 625 (defun mm-uu-pgp-key-extract ()
 626   (let ((buf (mm-uu-copy-to-buffer start-point end-point)))
 627     (mm-make-handle buf
 628                     '("application/pgp-keys"))))
 629
 630 ;;;###autoload
 631 (defun mm-uu-dissect (&optional noheader mime-type)
 632   "Dissect the current buffer and return a list of uu handles.
 633 The optional NOHEADER means there's no header in the buffer.
 634 MIME-TYPE specifies a MIME type and parameters, which defaults to the
 635 value of `mm-uu-text-plain-type'."
 636   (let ((case-fold-search t)
 637         (mm-uu-text-plain-type (or mime-type mm-uu-text-plain-type))
 638         text-start start-point end-point file-name result entry func)
 639     (save-excursion
 640       (goto-char (point-min))
 641       (cond
 642        (noheader)
 643        ((looking-at "\n")
 644         (forward-line))
 645        ((search-forward "\n\n" nil t)
 646         t)
 647        (t (goto-char (point-max))))
 648       (setq text-start (point))
 649       (while (re-search-forward mm-uu-beginning-regexp nil t)
 650         (setq start-point (match-beginning 0)
 651               entry nil)
 652         (let ((alist mm-uu-type-alist)
 653               (beginning-regexp (match-string 0)))
 654           (while (not entry)
 655             (if (string-match (mm-uu-beginning-regexp (car alist))
 656                               beginning-regexp)
 657                 (setq entry (car alist))
 658               (pop alist))))
 659         (if (setq func (mm-uu-function-1 entry))
 660             (funcall func))
 661         (forward-line);; in case of failure
 662         (when (and (not (mm-uu-configure-p (mm-uu-type entry) 'disabled))
 663                    (let ((end-regexp (mm-uu-end-regexp entry)))
 664                      (if (not end-regexp)
 665                          (or (setq end-point (point-max)) t)
 666                        (prog1
 667                            (re-search-forward end-regexp nil t)
 668                          (forward-line)
 669                          (setq end-point (point)))))
 670                    (or (not (setq func (mm-uu-function-2 entry)))
 671                        (funcall func)))
 672           (if (and (> start-point text-start)
 673                    (progn
 674                      (goto-char text-start)
 675                      (re-search-forward "." start-point t)))
 676               (push
 677                (mm-make-handle
 678                 (mm-uu-copy-to-buffer
 679                  text-start
 680                  ;; A start-separator is likely accompanied by
 681                  ;; a leading newline.
 682                  (if (and (eq (char-before start-point) ?\n)
 683                           (eq (char-before (1- start-point)) ?\n))
 684                      (1- start-point)
 685                    start-point))
 686                 mm-uu-text-plain-type)
 687                result))
 688           (push
 689            (funcall (mm-uu-function-extract entry))
 690            result)
 691           (goto-char (setq text-start end-point))))
 692       (when result
 693         (goto-char text-start)
 694         (when (re-search-forward "." nil t)
 695           (push (mm-make-handle
 696                  (mm-uu-copy-to-buffer
 697                   ;; An end-separator is likely accompanied by
 698                   ;; a trailing newline.
 699                   (if (eq (char-after text-start) ?\n)
 700                       (1+ text-start)
 701                     text-start)
 702                   (point-max))
 703                  mm-uu-text-plain-type)
 704                 result))
 705         (setq result (cons "multipart/mixed" (nreverse result))))
 706       result)))
 707
 708 ;;;###autoload
 709 (defun mm-uu-dissect-text-parts (handle &optional decoded)
 710   "Dissect text parts and put uu handles into HANDLE.
 711 Assume text has been decoded if DECODED is non-nil."
 712   (let ((buffer (mm-handle-buffer handle)))
 713     (cond ((stringp buffer)
 714            (dolist (elem (cdr handle))
 715              (mm-uu-dissect-text-parts elem decoded)))
 716           ((bufferp buffer)
 717            (let ((type (mm-handle-media-type handle))
 718                  (case-fold-search t) ;; string-match
 719                  children charset encoding)
 720              (when (and
 721                     (stringp type)
 722                     ;; Mutt still uses application/pgp even though
 723                     ;; it has already been withdrawn.
 724                     (string-match "\\`text/\\|\\`application/pgp\\'" type)
 725                     (equal (car (mm-handle-disposition handle))
 726                            "inline")
 727                     (setq
 728                      children
 729                      (with-current-buffer buffer
 730                        (cond
 731                         ((or decoded
 732                              (eq (setq charset (mail-content-type-get
 733                                                 (mm-handle-type handle)
 734                                                 'charset))
 735                                  'gnus-decoded))
 736                          (setq decoded t)
 737                          (mm-uu-dissect
 738                           t (cons type '((charset . gnus-decoded)))))
 739                         (charset
 740                          (setq decoded t)
 741                          (mm-with-multibyte-buffer
 742                            (insert (mm-decode-string (mm-get-part handle)
 743                                                      charset))
 744                            (mm-uu-dissect
 745                             t (cons type '((charset . gnus-decoded))))))
 746                         ((setq encoding (mm-handle-encoding handle))
 747                          (setq decoded nil)
 748                          ;; Inherit the multibyteness of the `buffer'.
 749                          (with-temp-buffer
 750                            (insert-buffer-substring buffer)
 751                            (mm-decode-content-transfer-encoding
 752                             encoding type)
 753                            (mm-uu-dissect t (list type))))
 754                         (t
 755                          (setq decoded nil)
 756                          (mm-uu-dissect t (list type)))))))
 757                ;; Ignore it if a given part is dissected into a single
 758                ;; part of which the type is the same as the given one.
 759                (if (and (<= (length children) 2)
 760                         (string-equal (mm-handle-media-type (cadr children))
 761                                       type))
 762                    (kill-buffer (mm-handle-buffer (cadr children)))
 763                  (kill-buffer buffer)
 764                  (setcdr handle (cdr children))
 765                  (setcar handle (car children)) ;; "multipart/mixed"
 766                  (dolist (elem (cdr children))
 767                    (mm-uu-dissect-text-parts elem decoded))))))
 768           (t
 769            (dolist (elem handle)
 770              (mm-uu-dissect-text-parts elem decoded))))))
 771
 772 (provide 'mm-uu)
 773
 774 ;;; mm-uu.el ends here