| 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, 2011, 2012 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 | ;; arch-tag: 7db076bf-53db-4320-aa19-ca76a1d2ab2c |
| 733 | ;;; mm-uu.el ends here |