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 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 (defvar mm-uu-emacs-sources-regexp "gnu\\.emacs\\.sources"
  81   "The regexp of Emacs sources groups.")
  82
  83 (defcustom mm-uu-diff-groups-regexp "gnus\\.commits"
  84   "*Regexp matching diff groups."
  85   :version "22.1"
  86   :type 'regexp
  87   :group 'gnus-article-mime)
  88
  89 (defvar mm-uu-type-alist
  90   '((postscript
  91      "^%!PS-"
  92      "^%%EOF$"
  93      mm-uu-postscript-extract
  94      nil)
  95     (uu
  96      "^begin[ \t]+0?[0-7][0-7][0-7][ \t]+"
  97      "^end[ \t]*$"
  98      mm-uu-uu-extract
  99      mm-uu-uu-filename)
 100     (binhex
 101      "^:...............................................................$"
 102      ":$"
 103      mm-uu-binhex-extract
 104      nil
 105      mm-uu-binhex-filename)
 106     (yenc
 107      "^=ybegin.*size=[0-9]+.*name=.*$"
 108      "^=yend.*size=[0-9]+"
 109      mm-uu-yenc-extract
 110      mm-uu-yenc-filename)
 111     (shar
 112      "^#! */bin/sh"
 113      "^exit 0$"
 114      mm-uu-shar-extract)
 115     (forward
 116      ;; Thanks to Edward J. Sabol <sabol@alderaan.gsfc.nasa.gov> and
 117      ;; Peter von der Ah\'e <pahe@daimi.au.dk>
 118      "^-+ \\(Start of \\)?Forwarded message"
 119      "^-+ End \\(of \\)?forwarded message"
 120      mm-uu-forward-extract
 121      nil
 122      mm-uu-forward-test)
 123     (gnatsweb
 124      "^----gnatsweb-attachment----"
 125      nil
 126      mm-uu-gnatsweb-extract)
 127     (pgp-signed
 128      "^-----BEGIN PGP SIGNED MESSAGE-----"
 129      "^-----END PGP SIGNATURE-----"
 130      mm-uu-pgp-signed-extract
 131      nil
 132      nil)
 133     (pgp-encrypted
 134      "^-----BEGIN PGP MESSAGE-----"
 135      "^-----END PGP MESSAGE-----"
 136      mm-uu-pgp-encrypted-extract
 137      nil
 138      nil)
 139     (pgp-key
 140      "^-----BEGIN PGP PUBLIC KEY BLOCK-----"
 141      "^-----END PGP PUBLIC KEY BLOCK-----"
 142      mm-uu-pgp-key-extract
 143      mm-uu-gpg-key-skip-to-last
 144      nil)
 145     (emacs-sources
 146      "^;;;?[ \t]*[^ \t]+\\.el[ \t]*--"
 147      "^;;;?[ \t]*\\([^ \t]+\\.el\\)[ \t]+ends here"
 148      mm-uu-emacs-sources-extract
 149      nil
 150      mm-uu-emacs-sources-test)
 151     (diff
 152      "^Index: "
 153      nil
 154      mm-uu-diff-extract
 155      nil
 156      mm-uu-diff-test)
 157     (verbatim-marks
 158      ;; slrn-style verbatim marks, see
 159      ;; http://www.slrn.org/manual/slrn-manual-6.html#ss6.81
 160      "^#v\\+$"
 161      "^#v\\-$"
 162      mm-uu-verbatim-marks-extract
 163      nil)))
 164
 165 (defcustom mm-uu-configure-list '((shar . disabled))
 166   "A list of mm-uu configuration.
 167 To disable dissecting shar codes, for instance, add
 168 `(shar . disabled)' to this list."
 169   :type 'alist
 170   :options (mapcar (lambda (entry)
 171                      (list (car entry) '(const disabled)))
 172                    mm-uu-type-alist)
 173   :group 'gnus-article-mime)
 174
 175 (defvar mm-uu-text-plain-type '("text/plain" (charset . gnus-decoded))
 176   "MIME type and parameters for text/plain parts.
 177 `gnus-decoded' is a fake charset, which means no further decoding.")
 178
 179 ;; functions
 180
 181 (defsubst mm-uu-type (entry)
 182   (car entry))
 183
 184 (defsubst mm-uu-beginning-regexp (entry)
 185   (nth 1 entry))
 186
 187 (defsubst mm-uu-end-regexp (entry)
 188   (nth 2 entry))
 189
 190 (defsubst mm-uu-function-extract (entry)
 191   (nth 3 entry))
 192
 193 (defsubst mm-uu-function-1 (entry)
 194   (nth 4 entry))
 195
 196 (defsubst mm-uu-function-2 (entry)
 197   (nth 5 entry))
 198
 199 (defface mm-uu-extract
 200   '((((class color)
 201       (background dark))
 202      (:background "gray5"))
 203     (((class color)
 204       (background light))
 205      (:background "gray95"))
 206     (t
 207      ()))
 208   "Face for extracted buffers."
 209   ;; See `mm-uu-verbatim-marks-extract'.
 210   :version "23.0" ;; No Gnus
 211   :group 'gnus-article-mime)
 212
 213 (defun mm-uu-copy-to-buffer (&optional from to properties)
 214   "Copy the contents of the current buffer to a fresh buffer.
 215 Return that buffer.
 216
 217 If PROPERTIES is non-nil, PROPERTIES are applied to the buffer,
 218 see `set-text-properties'.  If PROPERTIES equals t, this means to
 219 apply the face `mm-uu-extract'."
 220   (let ((obuf (current-buffer))
 221         (coding-system
 222          ;; Might not exist in non-MULE XEmacs
 223          (when (boundp 'buffer-file-coding-system)
 224            buffer-file-coding-system)))
 225     (with-current-buffer (generate-new-buffer " *mm-uu*")
 226       (setq buffer-file-coding-system coding-system)
 227       (insert-buffer-substring obuf from to)
 228       (cond ((eq properties  t)
 229              (set-text-properties (point-min) (point-max)
 230                                   '(face mm-uu-extract)))
 231             (properties
 232              (set-text-properties (point-min) (point-max) properties)))
 233       (current-buffer))))
 234
 235 (defun mm-uu-configure-p  (key val)
 236   (member (cons key val) mm-uu-configure-list))
 237
 238 (defun mm-uu-configure (&optional symbol value)
 239   (if symbol (set-default symbol value))
 240   (setq mm-uu-beginning-regexp nil)
 241   (mapcar (lambda (entry)
 242              (if (mm-uu-configure-p (mm-uu-type entry) 'disabled)
 243                  nil
 244                (setq mm-uu-beginning-regexp
 245                      (concat mm-uu-beginning-regexp
 246                              (if mm-uu-beginning-regexp "\\|")
 247                              (mm-uu-beginning-regexp entry)))))
 248           mm-uu-type-alist))
 249
 250 (mm-uu-configure)
 251
 252 (eval-when-compile
 253   (defvar file-name)
 254   (defvar start-point)
 255   (defvar end-point)
 256   (defvar entry))
 257
 258 (defun mm-uu-uu-filename ()
 259   (if (looking-at ".+")
 260       (setq file-name
 261             (let ((nnheader-file-name-translation-alist
 262                    '((?/ . ?,) (?\  . ?_) (?* . ?_) (?$ . ?_))))
 263               (nnheader-translate-file-chars (match-string 0))))))
 264
 265 (defun mm-uu-binhex-filename ()
 266   (setq file-name
 267         (ignore-errors
 268           (binhex-decode-region start-point end-point t))))
 269
 270 (defun mm-uu-yenc-filename ()
 271   (goto-char start-point)
 272   (setq file-name
 273         (ignore-errors
 274           (yenc-extract-filename))))
 275
 276 (defun mm-uu-forward-test ()
 277   (save-excursion
 278     (goto-char start-point)
 279     (forward-line)
 280     (looking-at "[\r\n]*[a-zA-Z][a-zA-Z0-9-]*:")))
 281
 282 (defun mm-uu-postscript-extract ()
 283   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
 284                   '("application/postscript")))
 285
 286 (defun mm-uu-verbatim-marks-extract ()
 287   (mm-make-handle
 288    (mm-uu-copy-to-buffer
 289     (progn (goto-char start-point) (forward-line) (point))
 290     (progn (goto-char end-point) (forward-line -1) (point))
 291     t)
 292    '("text/verbatim")))
 293
 294 (defun mm-uu-emacs-sources-extract ()
 295   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
 296                   '("application/emacs-lisp")
 297                   nil nil
 298                   (list mm-dissect-disposition
 299                         (cons 'filename file-name))))
 300
 301 (eval-when-compile
 302   (defvar gnus-newsgroup-name))
 303
 304 (defun mm-uu-emacs-sources-test ()
 305   (setq file-name (match-string 1))
 306   (and gnus-newsgroup-name
 307        mm-uu-emacs-sources-regexp
 308        (string-match mm-uu-emacs-sources-regexp gnus-newsgroup-name)))
 309
 310 (defun mm-uu-diff-extract ()
 311   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
 312                   '("text/x-patch")))
 313
 314 (defun mm-uu-diff-test ()
 315   (and gnus-newsgroup-name
 316        mm-uu-diff-groups-regexp
 317        (string-match mm-uu-diff-groups-regexp gnus-newsgroup-name)))
 318
 319 (defun mm-uu-forward-extract ()
 320   (mm-make-handle (mm-uu-copy-to-buffer
 321                    (progn (goto-char start-point) (forward-line) (point))
 322                    (progn (goto-char end-point) (forward-line -1) (point)))
 323                   '("message/rfc822" (charset . gnus-decoded))))
 324
 325 (defun mm-uu-uu-extract ()
 326   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
 327                   (list (or (and file-name
 328                                  (string-match "\\.[^\\.]+$"
 329                                                file-name)
 330                                  (mailcap-extension-to-mime
 331                                   (match-string 0 file-name)))
 332                             "application/octet-stream"))
 333                   'x-uuencode nil
 334                   (if (and file-name (not (equal file-name "")))
 335                       (list mm-dissect-disposition
 336                             (cons 'filename file-name)))))
 337
 338 (defun mm-uu-binhex-extract ()
 339   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
 340                   (list (or (and file-name
 341                                  (string-match "\\.[^\\.]+$" file-name)
 342                                  (mailcap-extension-to-mime
 343                                   (match-string 0 file-name)))
 344                             "application/octet-stream"))
 345                   'x-binhex nil
 346                   (if (and file-name (not (equal file-name "")))
 347                       (list mm-dissect-disposition
 348                             (cons 'filename file-name)))))
 349
 350 (defun mm-uu-yenc-extract ()
 351   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
 352                   (list (or (and file-name
 353                                  (string-match "\\.[^\\.]+$" file-name)
 354                                  (mailcap-extension-to-mime
 355                                   (match-string 0 file-name)))
 356                             "application/octet-stream"))
 357                   'x-yenc nil
 358                   (if (and file-name (not (equal file-name "")))
 359                       (list mm-dissect-disposition
 360                             (cons 'filename file-name)))))
 361
 362
 363 (defun mm-uu-shar-extract ()
 364   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
 365                   '("application/x-shar")))
 366
 367 (defun mm-uu-gnatsweb-extract ()
 368   (save-restriction
 369     (goto-char start-point)
 370     (forward-line)
 371     (narrow-to-region (point) end-point)
 372     (mm-dissect-buffer t)))
 373
 374 (defun mm-uu-pgp-signed-test (&rest rest)
 375   (and
 376    mml2015-use
 377    (mml2015-clear-verify-function)
 378    (cond
 379     ((eq mm-verify-option 'never) nil)
 380     ((eq mm-verify-option 'always) t)
 381     ((eq mm-verify-option 'known) t)
 382     (t (y-or-n-p "Verify pgp signed part? ")))))
 383
 384 (eval-when-compile
 385   (defvar gnus-newsgroup-charset))
 386
 387 (defun mm-uu-pgp-signed-extract-1 (handles ctl)
 388   (let ((buf (mm-uu-copy-to-buffer (point-min) (point-max))))
 389     (with-current-buffer buf
 390       (if (mm-uu-pgp-signed-test)
 391           (progn
 392             (mml2015-clean-buffer)
 393             (let ((coding-system-for-write (or gnus-newsgroup-charset
 394                                                'iso-8859-1)))
 395               (funcall (mml2015-clear-verify-function))))
 396         (when (and mml2015-use (null (mml2015-clear-verify-function)))
 397           (mm-set-handle-multipart-parameter
 398            mm-security-handle 'gnus-details
 399            (format "Clear verification not supported by `%s'.\n" mml2015-use))))
 400       (goto-char (point-min))
 401       (if (search-forward "\n\n" nil t)
 402           (delete-region (point-min) (point)))
 403       (if (re-search-forward mm-uu-pgp-beginning-signature nil t)
 404           (delete-region (match-beginning 0) (point-max)))
 405       (goto-char (point-min))
 406       (while (re-search-forward "^- " nil t)
 407         (replace-match "" t t)
 408         (forward-line 1)))
 409     (list (mm-make-handle buf mm-uu-text-plain-type))))
 410
 411 (defun mm-uu-pgp-signed-extract ()
 412   (let ((mm-security-handle (list (format "multipart/signed"))))
 413     (mm-set-handle-multipart-parameter
 414      mm-security-handle 'protocol "application/x-gnus-pgp-signature")
 415     (save-restriction
 416       (narrow-to-region start-point end-point)
 417       (add-text-properties 0 (length (car mm-security-handle))
 418                            (list 'buffer (mm-uu-copy-to-buffer))
 419                            (car mm-security-handle))
 420       (setcdr mm-security-handle
 421               (mm-uu-pgp-signed-extract-1 nil
 422                                           mm-security-handle)))
 423     mm-security-handle))
 424
 425 (defun mm-uu-pgp-encrypted-test (&rest rest)
 426   (and
 427    mml2015-use
 428    (mml2015-clear-decrypt-function)
 429    (cond
 430     ((eq mm-decrypt-option 'never) nil)
 431     ((eq mm-decrypt-option 'always) t)
 432     ((eq mm-decrypt-option 'known) t)
 433     (t (y-or-n-p "Decrypt pgp encrypted part? ")))))
 434
 435 (defun mm-uu-pgp-encrypted-extract-1 (handles ctl)
 436   (let ((buf (mm-uu-copy-to-buffer (point-min) (point-max))))
 437     (if (mm-uu-pgp-encrypted-test)
 438         (with-current-buffer buf
 439           (mml2015-clean-buffer)
 440           (funcall (mml2015-clear-decrypt-function))))
 441     (list (mm-make-handle buf mm-uu-text-plain-type))))
 442
 443 (defun mm-uu-pgp-encrypted-extract ()
 444   (let ((mm-security-handle (list (format "multipart/encrypted"))))
 445     (mm-set-handle-multipart-parameter
 446      mm-security-handle 'protocol "application/x-gnus-pgp-encrypted")
 447     (save-restriction
 448       (narrow-to-region start-point end-point)
 449       (add-text-properties 0 (length (car mm-security-handle))
 450                            (list 'buffer (mm-uu-copy-to-buffer))
 451                            (car mm-security-handle))
 452       (setcdr mm-security-handle
 453               (mm-uu-pgp-encrypted-extract-1 nil
 454                                              mm-security-handle)))
 455     mm-security-handle))
 456
 457 (defun mm-uu-gpg-key-skip-to-last ()
 458   (let ((point (point))
 459         (end-regexp (mm-uu-end-regexp entry))
 460         (beginning-regexp (mm-uu-beginning-regexp entry)))
 461     (when (and end-regexp
 462                (not (mm-uu-configure-p (mm-uu-type entry) 'disabled)))
 463       (while (re-search-forward end-regexp nil t)
 464         (skip-chars-forward " \t\n\r")
 465         (if (looking-at beginning-regexp)
 466             (setq point (match-end 0)))))
 467     (goto-char point)))
 468
 469 (defun mm-uu-pgp-key-extract ()
 470   (let ((buf (mm-uu-copy-to-buffer start-point end-point)))
 471     (mm-make-handle buf
 472                     '("application/pgp-keys"))))
 473
 474 ;;;###autoload
 475 (defun mm-uu-dissect (&optional noheader mime-type)
 476   "Dissect the current buffer and return a list of uu handles.
 477 The optional NOHEADER means there's no header in the buffer.
 478 MIME-TYPE specifies a MIME type and parameters, which defaults to the
 479 value of `mm-uu-text-plain-type'."
 480   (let ((case-fold-search t)
 481         (mm-uu-text-plain-type (or mime-type mm-uu-text-plain-type))
 482         text-start start-point end-point file-name result entry func)
 483     (save-excursion
 484       (goto-char (point-min))
 485       (cond
 486        (noheader)
 487        ((looking-at "\n")
 488         (forward-line))
 489        ((search-forward "\n\n" nil t)
 490         t)
 491        (t (goto-char (point-max))))
 492       (setq text-start (point))
 493       (while (re-search-forward mm-uu-beginning-regexp nil t)
 494         (setq start-point (match-beginning 0))
 495         (let ((alist mm-uu-type-alist)
 496               (beginning-regexp (match-string 0)))
 497           (while (not entry)
 498             (if (string-match (mm-uu-beginning-regexp (car alist))
 499                               beginning-regexp)
 500                 (setq entry (car alist))
 501               (pop alist))))
 502         (if (setq func (mm-uu-function-1 entry))
 503             (funcall func))
 504         (forward-line);; in case of failure
 505         (when (and (not (mm-uu-configure-p (mm-uu-type entry) 'disabled))
 506                    (let ((end-regexp (mm-uu-end-regexp entry)))
 507                      (if (not end-regexp)
 508                          (or (setq end-point (point-max)) t)
 509                        (prog1
 510                            (re-search-forward end-regexp nil t)
 511                          (forward-line)
 512                          (setq end-point (point)))))
 513                    (or (not (setq func (mm-uu-function-2 entry)))
 514                        (funcall func)))
 515           (if (and (> start-point text-start)
 516                    (progn
 517                      (goto-char text-start)
 518                      (re-search-forward "." start-point t)))
 519               (push
 520                (mm-make-handle (mm-uu-copy-to-buffer text-start start-point)
 521                                mm-uu-text-plain-type)
 522                result))
 523           (push
 524            (funcall (mm-uu-function-extract entry))
 525            result)
 526           (goto-char (setq text-start end-point))))
 527       (when result
 528         (if (and (> (point-max) (1+ text-start))
 529                  (save-excursion
 530                    (goto-char text-start)
 531                    (re-search-forward "." nil t)))
 532             (push
 533              (mm-make-handle (mm-uu-copy-to-buffer text-start (point-max))
 534                              mm-uu-text-plain-type)
 535              result))
 536         (setq result (cons "multipart/mixed" (nreverse result))))
 537       result)))
 538
 539 (defun mm-uu-dissect-text-parts (handle)
 540   "Dissect text parts and put uu handles into HANDLE."
 541   (let ((buffer (mm-handle-buffer handle))
 542         type children)
 543     (cond ((stringp buffer)
 544            (mapc 'mm-uu-dissect-text-parts (cdr handle)))
 545           ((bufferp buffer)
 546            (when (and (setq type (mm-handle-media-type handle))
 547                       (stringp type)
 548                       (string-match "\\`text/" type)
 549                       (with-current-buffer buffer
 550                         (setq children
 551                               (mm-uu-dissect t (mm-handle-type handle)))))
 552              (kill-buffer buffer)
 553              (setcar handle (car children))
 554              (setcdr handle (cdr children))))
 555           (t
 556            (mapc 'mm-uu-dissect-text-parts handle)))))
 557
 558 (provide 'mm-uu)
 559
 560 ;; arch-tag: 7db076bf-53db-4320-aa19-ca76a1d2ab2c
 561 ;;; mm-uu.el ends here