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