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