lisp/gnus/mm-uu.el

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