cgit.sxemacs.org Git - gnus/blob - lisp/mm-uu.el

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