diff options
| author | Stefan Monnier | 2019-09-30 15:08:41 -0400 |
|---|---|---|
| committer | Stefan Monnier | 2019-09-30 15:08:41 -0400 |
| commit | 2e08014859773a8989d785e2b3f6c16294eb0190 (patch) | |
| tree | 237112d0399874bc322ed719f6ed79f389647a12 | |
| parent | 9e9bd502ad8ec4e8156f823b048c0b3366ed16b4 (diff) | |
| download | emacs-2e08014859773a8989d785e2b3f6c16294eb0190.tar.gz emacs-2e08014859773a8989d785e2b3f6c16294eb0190.zip | |
* lisp/gnus/mm-uu.el: Use lexical-binding and cl-defstruct
(mm-uu-type-alist): Make functions visible to byte-compiler.
(mm-uu-entry): New defstruct.
(mm-uu-configure): Use mapconcat.
(mm-uu-dissect): Avoid setq on `func`.
| -rw-r--r-- | lisp/gnus/mm-uu.el | 131 |
1 files changed, 62 insertions, 69 deletions
diff --git a/lisp/gnus/mm-uu.el b/lisp/gnus/mm-uu.el index 981bf8ea3ea..fec3986dedd 100644 --- a/lisp/gnus/mm-uu.el +++ b/lisp/gnus/mm-uu.el | |||
| @@ -1,4 +1,4 @@ | |||
| 1 | ;;; mm-uu.el --- Return uu stuff as mm handles | 1 | ;;; mm-uu.el --- Return uu stuff as mm handles -*- lexical-binding:t -*- |
| 2 | 2 | ||
| 3 | ;; Copyright (C) 1998-2019 Free Software Foundation, Inc. | 3 | ;; Copyright (C) 1998-2019 Free Software Foundation, Inc. |
| 4 | 4 | ||
| @@ -29,6 +29,7 @@ | |||
| 29 | (require 'mm-decode) | 29 | (require 'mm-decode) |
| 30 | (require 'mailcap) | 30 | (require 'mailcap) |
| 31 | (require 'mml2015) | 31 | (require 'mml2015) |
| 32 | (eval-when-compile (require 'cl-lib)) | ||
| 32 | 33 | ||
| 33 | (autoload 'uudecode-decode-region "uudecode") | 34 | (autoload 'uudecode-decode-region "uudecode") |
| 34 | (autoload 'uudecode-decode-region-external "uudecode") | 35 | (autoload 'uudecode-decode-region-external "uudecode") |
| @@ -90,124 +91,126 @@ This can be either \"inline\" or \"attachment\".") | |||
| 90 | :group 'gnus-article-mime) | 91 | :group 'gnus-article-mime) |
| 91 | 92 | ||
| 92 | (defvar mm-uu-type-alist | 93 | (defvar mm-uu-type-alist |
| 93 | '((postscript | 94 | `((postscript |
| 94 | "^%!PS-" | 95 | "^%!PS-" |
| 95 | "^%%EOF$" | 96 | "^%%EOF$" |
| 96 | mm-uu-postscript-extract | 97 | ,#'mm-uu-postscript-extract |
| 97 | nil) | 98 | nil) |
| 98 | (uu ;; Maybe we should have a more strict test here. | 99 | (uu ;; Maybe we should have a more strict test here. |
| 99 | "^begin[ \t]+0?[0-7][0-7][0-7][ \t]+" | 100 | "^begin[ \t]+0?[0-7][0-7][0-7][ \t]+" |
| 100 | "^end[ \t]*$" | 101 | "^end[ \t]*$" |
| 101 | mm-uu-uu-extract | 102 | ,#'mm-uu-uu-extract |
| 102 | mm-uu-uu-filename) | 103 | ,#'mm-uu-uu-filename) |
| 103 | (binhex | 104 | (binhex |
| 104 | "^:.\\{63,63\\}$" | 105 | "^:.\\{63,63\\}$" |
| 105 | ":$" | 106 | ":$" |
| 106 | mm-uu-binhex-extract | 107 | ,#'mm-uu-binhex-extract |
| 107 | nil | 108 | nil |
| 108 | mm-uu-binhex-filename) | 109 | ,#'mm-uu-binhex-filename) |
| 109 | (yenc | 110 | (yenc |
| 110 | "^=ybegin.*size=[0-9]+.*name=.*$" | 111 | "^=ybegin.*size=[0-9]+.*name=.*$" |
| 111 | "^=yend.*size=[0-9]+" | 112 | "^=yend.*size=[0-9]+" |
| 112 | mm-uu-yenc-extract | 113 | ,#'mm-uu-yenc-extract |
| 113 | mm-uu-yenc-filename) | 114 | ,#'mm-uu-yenc-filename) |
| 114 | (shar | 115 | (shar |
| 115 | "^#! */bin/sh" | 116 | "^#! */bin/sh" |
| 116 | "^exit 0$" | 117 | "^exit 0$" |
| 117 | mm-uu-shar-extract) | 118 | ,#'mm-uu-shar-extract) |
| 118 | (forward | 119 | (forward |
| 119 | ;; Thanks to Edward J. Sabol <sabol@alderaan.gsfc.nasa.gov> and | 120 | ;; Thanks to Edward J. Sabol <sabol@alderaan.gsfc.nasa.gov> and |
| 120 | ;; Peter von der Ahé <pahe@daimi.au.dk> | 121 | ;; Peter von der Ahé <pahe@daimi.au.dk> |
| 121 | "^-+ \\(Start of \\)?Forwarded message" | 122 | "^-+ \\(Start of \\)?Forwarded message" |
| 122 | "^-+ End \\(of \\)?forwarded message" | 123 | "^-+ End \\(of \\)?forwarded message" |
| 123 | mm-uu-forward-extract | 124 | ,#'mm-uu-forward-extract |
| 124 | nil | 125 | nil |
| 125 | mm-uu-forward-test) | 126 | ,#'mm-uu-forward-test) |
| 126 | (gnatsweb | 127 | (gnatsweb |
| 127 | "^----gnatsweb-attachment----" | 128 | "^----gnatsweb-attachment----" |
| 128 | nil | 129 | nil |
| 129 | mm-uu-gnatsweb-extract) | 130 | ,#'mm-uu-gnatsweb-extract) |
| 130 | (pgp-signed | 131 | (pgp-signed |
| 131 | "^-----BEGIN PGP SIGNED MESSAGE-----" | 132 | "^-----BEGIN PGP SIGNED MESSAGE-----" |
| 132 | "^-----END PGP SIGNATURE-----" | 133 | "^-----END PGP SIGNATURE-----" |
| 133 | mm-uu-pgp-signed-extract | 134 | ,#'mm-uu-pgp-signed-extract |
| 134 | nil | 135 | nil |
| 135 | nil) | 136 | nil) |
| 136 | (pgp-encrypted | 137 | (pgp-encrypted |
| 137 | "^-----BEGIN PGP MESSAGE-----" | 138 | "^-----BEGIN PGP MESSAGE-----" |
| 138 | "^-----END PGP MESSAGE-----" | 139 | "^-----END PGP MESSAGE-----" |
| 139 | mm-uu-pgp-encrypted-extract | 140 | ,#'mm-uu-pgp-encrypted-extract |
| 140 | nil | 141 | nil |
| 141 | nil) | 142 | nil) |
| 142 | (pgp-key | 143 | (pgp-key |
| 143 | "^-----BEGIN PGP PUBLIC KEY BLOCK-----" | 144 | "^-----BEGIN PGP PUBLIC KEY BLOCK-----" |
| 144 | "^-----END PGP PUBLIC KEY BLOCK-----" | 145 | "^-----END PGP PUBLIC KEY BLOCK-----" |
| 145 | mm-uu-pgp-key-extract | 146 | ,#'mm-uu-pgp-key-extract |
| 146 | mm-uu-gpg-key-skip-to-last | 147 | ,#'mm-uu-gpg-key-skip-to-last |
| 147 | nil) | 148 | nil) |
| 148 | (emacs-sources | 149 | (emacs-sources |
| 149 | "^;;;?[ \t]*[^ \t]+\\.el[ \t]*--" | 150 | "^;;;?[ \t]*[^ \t]+\\.el[ \t]*--" |
| 150 | "^;;;?[ \t]*\\([^ \t]+\\.el\\)[ \t]+ends here" | 151 | "^;;;?[ \t]*\\([^ \t]+\\.el\\)[ \t]+ends here" |
| 151 | mm-uu-emacs-sources-extract | 152 | ,#'mm-uu-emacs-sources-extract |
| 152 | nil | 153 | nil |
| 153 | mm-uu-emacs-sources-test) | 154 | ,#'mm-uu-emacs-sources-test) |
| 154 | (diff | 155 | (diff |
| 155 | "^Index: " | 156 | "^Index: " |
| 156 | nil | 157 | nil |
| 157 | mm-uu-diff-extract | 158 | ,#'mm-uu-diff-extract |
| 158 | nil | 159 | nil |
| 159 | mm-uu-diff-test) | 160 | ,#'mm-uu-diff-test) |
| 160 | (diff | 161 | (diff |
| 161 | "^=== modified file " | 162 | "^=== modified file " |
| 162 | nil | 163 | nil |
| 163 | mm-uu-diff-extract | 164 | ,#'mm-uu-diff-extract |
| 164 | nil | 165 | nil |
| 165 | mm-uu-diff-test) | 166 | ,#'mm-uu-diff-test) |
| 166 | (git-format-patch | 167 | (git-format-patch |
| 167 | "^diff --git " | 168 | "^diff --git " |
| 168 | "^-- " | 169 | "^-- " |
| 169 | mm-uu-diff-extract | 170 | ,#'mm-uu-diff-extract |
| 170 | nil | 171 | nil |
| 171 | mm-uu-diff-test) | 172 | ,#'mm-uu-diff-test) |
| 172 | (message-marks | 173 | (message-marks |
| 173 | ;; Text enclosed with tags similar to `message-mark-insert-begin' and | 174 | ;; Text enclosed with tags similar to `message-mark-insert-begin' and |
| 174 | ;; `message-mark-insert-end'. Don't use those variables to avoid | 175 | ;; `message-mark-insert-end'. Don't use those variables to avoid |
| 175 | ;; dependency on `message.el'. | 176 | ;; dependency on `message.el'. |
| 176 | "^-+[8<>]*-\\{9,\\}[a-z ]+-\\{9,\\}[a-z ]+-\\{9,\\}[8<>]*-+$" | 177 | "^-+[8<>]*-\\{9,\\}[a-z ]+-\\{9,\\}[a-z ]+-\\{9,\\}[8<>]*-+$" |
| 177 | "^-+[8<>]*-\\{9,\\}[a-z ]+-\\{9,\\}[a-z ]+-\\{9,\\}[8<>]*-+$" | 178 | "^-+[8<>]*-\\{9,\\}[a-z ]+-\\{9,\\}[a-z ]+-\\{9,\\}[8<>]*-+$" |
| 178 | (lambda () (mm-uu-verbatim-marks-extract 0 0 1 -1)) | 179 | ,(lambda () (mm-uu-verbatim-marks-extract 0 0 1 -1)) |
| 179 | nil) | 180 | nil) |
| 180 | ;; Omitting [a-z8<] leads to false positives (bogus signature separators | 181 | ;; Omitting [a-z8<] leads to false positives (bogus signature separators |
| 181 | ;; and mailing list banners). | 182 | ;; and mailing list banners). |
| 182 | (insert-marks | 183 | (insert-marks |
| 183 | "^ *\\(-\\|_\\)\\{30,\\}.*[a-z8<].*\\(-\\|_\\)\\{30,\\} *$" | 184 | "^ *\\(-\\|_\\)\\{30,\\}.*[a-z8<].*\\(-\\|_\\)\\{30,\\} *$" |
| 184 | "^ *\\(-\\|_\\)\\{30,\\}.*[a-z8<].*\\(-\\|_\\)\\{30,\\} *$" | 185 | "^ *\\(-\\|_\\)\\{30,\\}.*[a-z8<].*\\(-\\|_\\)\\{30,\\} *$" |
| 185 | (lambda () (mm-uu-verbatim-marks-extract 0 0 1 -1)) | 186 | ,(lambda () (mm-uu-verbatim-marks-extract 0 0 1 -1)) |
| 186 | nil) | 187 | nil) |
| 187 | (verbatim-marks | 188 | (verbatim-marks |
| 188 | ;; slrn-style verbatim marks, see | 189 | ;; slrn-style verbatim marks, see |
| 189 | ;; http://slrn.sourceforge.net/docs/slrn-manual-6.html#process_verbatim_marks | 190 | ;; http://slrn.sourceforge.net/docs/slrn-manual-6.html#process_verbatim_marks |
| 190 | "^#v\\+" | 191 | "^#v\\+" |
| 191 | "^#v\\-$" | 192 | "^#v\\-$" |
| 192 | (lambda () (mm-uu-verbatim-marks-extract 0 0)) | 193 | ,(lambda () (mm-uu-verbatim-marks-extract 0 0)) |
| 193 | nil) | 194 | nil) |
| 194 | (LaTeX | 195 | (LaTeX |
| 195 | "^\\([\\\\%][^\n]+\n\\)*\\\\documentclass.*[[{%]" | 196 | "^\\([\\\\%][^\n]+\n\\)*\\\\documentclass.*[[{%]" |
| 196 | "^\\\\end{document}" | 197 | "^\\\\end{document}" |
| 197 | mm-uu-latex-extract | 198 | ,#'mm-uu-latex-extract |
| 198 | nil | 199 | nil |
| 199 | mm-uu-latex-test) | 200 | ,#'mm-uu-latex-test) |
| 200 | (org-src-code-block | 201 | (org-src-code-block |
| 201 | "^[ \t]*#\\+begin_" | 202 | "^[ \t]*#\\+begin_" |
| 202 | "^[ \t]*#\\+end_" | 203 | "^[ \t]*#\\+end_" |
| 203 | mm-uu-org-src-code-block-extract) | 204 | ,#'mm-uu-org-src-code-block-extract) |
| 204 | (org-meta-line | 205 | (org-meta-line |
| 205 | "^[ \t]*#\\+[[:alpha:]]+: " | 206 | "^[ \t]*#\\+[[:alpha:]]+: " |
| 206 | "$" | 207 | "$" |
| 207 | mm-uu-org-src-code-block-extract)) | 208 | ,#'mm-uu-org-src-code-block-extract)) |
| 208 | "A list of specifications for non-MIME attachments. | 209 | "A list of specifications for non-MIME attachments. |
| 209 | Each element consist of the following entries: label, | 210 | Each element consist of a `mm-uu-entry'. |
| 210 | start-regexp, end-regexp, extract-function, test-function. | 211 | The functions in the last 3 slots of this type can make use of the following |
| 212 | dynamically-scoped variables: | ||
| 213 | `file-name', `start-point', and `end-point'. | ||
| 211 | 214 | ||
| 212 | After modifying this list you must run \\[mm-uu-configure]. | 215 | After modifying this list you must run \\[mm-uu-configure]. |
| 213 | 216 | ||
| @@ -230,23 +233,11 @@ To disable dissecting shar codes, for instance, add | |||
| 230 | 233 | ||
| 231 | ;; functions | 234 | ;; functions |
| 232 | 235 | ||
| 233 | (defsubst mm-uu-type (entry) | 236 | (cl-defstruct (mm-uu-entry |
| 234 | (car entry)) | 237 | (:conc-name mm-uu-) |
| 235 | 238 | (:constructor nil) | |
| 236 | (defsubst mm-uu-beginning-regexp (entry) | 239 | (:type list)) |
| 237 | (nth 1 entry)) | 240 | type beginning-regexp end-regexp function-extract function-1 function-2) |
| 238 | |||
| 239 | (defsubst mm-uu-end-regexp (entry) | ||
| 240 | (nth 2 entry)) | ||
| 241 | |||
| 242 | (defsubst mm-uu-function-extract (entry) | ||
| 243 | (nth 3 entry)) | ||
| 244 | |||
| 245 | (defsubst mm-uu-function-1 (entry) | ||
| 246 | (nth 4 entry)) | ||
| 247 | |||
| 248 | (defsubst mm-uu-function-2 (entry) | ||
| 249 | (nth 5 entry)) | ||
| 250 | 241 | ||
| 251 | (defcustom mm-uu-hide-markers (< 16 (length (defined-colors))) | 242 | (defcustom mm-uu-hide-markers (< 16 (length (defined-colors))) |
| 252 | "If non-nil, hide verbatim markers. | 243 | "If non-nil, hide verbatim markers. |
| @@ -309,15 +300,15 @@ apply the face `mm-uu-extract'." | |||
| 309 | "Configure detection of non-MIME attachments." | 300 | "Configure detection of non-MIME attachments." |
| 310 | (interactive) | 301 | (interactive) |
| 311 | (if symbol (set-default symbol value)) | 302 | (if symbol (set-default symbol value)) |
| 312 | (setq mm-uu-beginning-regexp nil) | 303 | (setq mm-uu-beginning-regexp |
| 313 | (mapcar (lambda (mm-uu-entry) | 304 | (mapconcat #'mm-uu-beginning-regexp |
| 314 | (if (mm-uu-configure-p (mm-uu-type mm-uu-entry) 'disabled) | 305 | (delq nil (mapcar |
| 315 | nil | 306 | (lambda (entry) |
| 316 | (setq mm-uu-beginning-regexp | 307 | (if (mm-uu-configure-p (mm-uu-type entry) |
| 317 | (concat mm-uu-beginning-regexp | 308 | 'disabled) |
| 318 | (if mm-uu-beginning-regexp "\\|") | 309 | nil entry)) |
| 319 | (mm-uu-beginning-regexp mm-uu-entry))))) | 310 | mm-uu-type-alist)) |
| 320 | mm-uu-type-alist)) | 311 | "\\|"))) |
| 321 | 312 | ||
| 322 | (mm-uu-configure) | 313 | (mm-uu-configure) |
| 323 | 314 | ||
| @@ -481,7 +472,7 @@ apply the face `mm-uu-extract'." | |||
| 481 | (narrow-to-region (point) end-point) | 472 | (narrow-to-region (point) end-point) |
| 482 | (mm-dissect-buffer t))) | 473 | (mm-dissect-buffer t))) |
| 483 | 474 | ||
| 484 | (defun mm-uu-pgp-signed-test (&rest rest) | 475 | (defun mm-uu-pgp-signed-test (&rest _) |
| 485 | (and | 476 | (and |
| 486 | mml2015-use | 477 | mml2015-use |
| 487 | (mml2015-clear-verify-function) | 478 | (mml2015-clear-verify-function) |
| @@ -495,7 +486,7 @@ apply the face `mm-uu-extract'." | |||
| 495 | 486 | ||
| 496 | (defvar gnus-newsgroup-charset) | 487 | (defvar gnus-newsgroup-charset) |
| 497 | 488 | ||
| 498 | (defun mm-uu-pgp-signed-extract-1 (handles ctl) | 489 | (defun mm-uu-pgp-signed-extract-1 (_handles _ctl) |
| 499 | (let ((buf (mm-uu-copy-to-buffer (point-min) (point-max)))) | 490 | (let ((buf (mm-uu-copy-to-buffer (point-min) (point-max)))) |
| 500 | (with-current-buffer buf | 491 | (with-current-buffer buf |
| 501 | (if (mm-uu-pgp-signed-test) | 492 | (if (mm-uu-pgp-signed-test) |
| @@ -530,7 +521,7 @@ apply the face `mm-uu-extract'." | |||
| 530 | mm-security-handle))) | 521 | mm-security-handle))) |
| 531 | mm-security-handle)) | 522 | mm-security-handle)) |
| 532 | 523 | ||
| 533 | (defun mm-uu-pgp-encrypted-test (&rest rest) | 524 | (defun mm-uu-pgp-encrypted-test (&rest _) |
| 534 | (and | 525 | (and |
| 535 | mml2015-use | 526 | mml2015-use |
| 536 | (mml2015-clear-decrypt-function) | 527 | (mml2015-clear-decrypt-function) |
| @@ -542,7 +533,7 @@ apply the face `mm-uu-extract'." | |||
| 542 | (y-or-n-p "Decrypt pgp encrypted part? ") | 533 | (y-or-n-p "Decrypt pgp encrypted part? ") |
| 543 | (message "")))))) | 534 | (message "")))))) |
| 544 | 535 | ||
| 545 | (defun mm-uu-pgp-encrypted-extract-1 (handles ctl) | 536 | (defun mm-uu-pgp-encrypted-extract-1 (_handles _ctl) |
| 546 | (let ((buf (mm-uu-copy-to-buffer (point-min) (point-max))) | 537 | (let ((buf (mm-uu-copy-to-buffer (point-min) (point-max))) |
| 547 | (first t) | 538 | (first t) |
| 548 | charset) | 539 | charset) |
| @@ -599,6 +590,9 @@ apply the face `mm-uu-extract'." | |||
| 599 | mm-security-handle)) | 590 | mm-security-handle)) |
| 600 | 591 | ||
| 601 | (defun mm-uu-gpg-key-skip-to-last () | 592 | (defun mm-uu-gpg-key-skip-to-last () |
| 593 | ;; FIXME: Don't use mm-uu-entry (we know which entry it is anyway!). | ||
| 594 | ;; FIXME: Move it to function-2 so it doesn't need to check | ||
| 595 | ;; mm-uu-configure-p. | ||
| 602 | (let ((point (point)) | 596 | (let ((point (point)) |
| 603 | (end-regexp (mm-uu-end-regexp mm-uu-entry)) | 597 | (end-regexp (mm-uu-end-regexp mm-uu-entry)) |
| 604 | (beginning-regexp (mm-uu-beginning-regexp mm-uu-entry))) | 598 | (beginning-regexp (mm-uu-beginning-regexp mm-uu-entry))) |
| @@ -623,7 +617,7 @@ MIME-TYPE specifies a MIME type and parameters, which defaults to the | |||
| 623 | value of `mm-uu-text-plain-type'." | 617 | value of `mm-uu-text-plain-type'." |
| 624 | (let ((case-fold-search t) | 618 | (let ((case-fold-search t) |
| 625 | (mm-uu-text-plain-type (or mime-type mm-uu-text-plain-type)) | 619 | (mm-uu-text-plain-type (or mime-type mm-uu-text-plain-type)) |
| 626 | text-start start-point end-point file-name result mm-uu-entry func) | 620 | text-start start-point end-point file-name result mm-uu-entry) |
| 627 | (save-excursion | 621 | (save-excursion |
| 628 | (goto-char (point-min)) | 622 | (goto-char (point-min)) |
| 629 | (cond | 623 | (cond |
| @@ -644,8 +638,7 @@ value of `mm-uu-text-plain-type'." | |||
| 644 | beginning-regexp) | 638 | beginning-regexp) |
| 645 | (setq mm-uu-entry (car alist)) | 639 | (setq mm-uu-entry (car alist)) |
| 646 | (pop alist)))) | 640 | (pop alist)))) |
| 647 | (if (setq func (mm-uu-function-1 mm-uu-entry)) | 641 | (funcall (or (mm-uu-function-1 mm-uu-entry) #'ignore)) |
| 648 | (funcall func)) | ||
| 649 | (forward-line);; in case of failure | 642 | (forward-line);; in case of failure |
| 650 | (when (and (not (mm-uu-configure-p (mm-uu-type mm-uu-entry) 'disabled)) | 643 | (when (and (not (mm-uu-configure-p (mm-uu-type mm-uu-entry) 'disabled)) |
| 651 | (let ((end-regexp (mm-uu-end-regexp mm-uu-entry))) | 644 | (let ((end-regexp (mm-uu-end-regexp mm-uu-entry))) |
| @@ -655,8 +648,8 @@ value of `mm-uu-text-plain-type'." | |||
| 655 | (re-search-forward end-regexp nil t) | 648 | (re-search-forward end-regexp nil t) |
| 656 | (forward-line) | 649 | (forward-line) |
| 657 | (setq end-point (point))))) | 650 | (setq end-point (point))))) |
| 658 | (or (not (setq func (mm-uu-function-2 mm-uu-entry))) | 651 | (funcall (or (mm-uu-function-2 mm-uu-entry) |
| 659 | (funcall func))) | 652 | (lambda () t)))) |
| 660 | (if (and (> start-point text-start) | 653 | (if (and (> start-point text-start) |
| 661 | (progn | 654 | (progn |
| 662 | (goto-char text-start) | 655 | (goto-char text-start) |