git.chise.org Git - elisp/gnus.git-/blob - lisp/mm-uu.el

   1 ;;; mm-uu.el --- Return uu stuff as mm handles
   2 ;; Copyright (c) 1998, 1999, 2000, 2001, 2002, 2003 Free Software Foundation, Inc.
   3
   4 ;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
   5 ;; Keywords: postscript uudecode binhex shar forward gnatsweb pgp
   6
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 2, or (at your option)
  12 ;; any later version.
  13 ;;
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22 ;; Boston, MA 02111-1307, USA.
  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 'gnus-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-pgp-beginning-signature
  70   "^-----BEGIN PGP SIGNATURE-----")
  71
  72 (defvar mm-uu-beginning-regexp nil)
  73
  74 (defvar mm-dissect-disposition "inline"
  75   "The default disposition of uu parts.
  76 This can be either \"inline\" or \"attachment\".")
  77
  78 (defvar mm-uu-emacs-sources-regexp "gnu\\.emacs\\.sources"
  79   "The regexp of Emacs sources groups.")
  80
  81 (defcustom mm-uu-diff-groups-regexp "gnus\\.commits"
  82   "*Regexp matching diff groups."
  83   :type 'regexp
  84   :group 'gnus-article-mime)
  85
  86 (defvar mm-uu-type-alist
  87   '((postscript
  88      "^%!PS-"
  89      "^%%EOF$"
  90      mm-uu-postscript-extract
  91      nil)
  92     (uu
  93      "^begin[ \t]+0?[0-7][0-7][0-7][ \t]+"
  94      "^end[ \t]*$"
  95      mm-uu-uu-extract
  96      mm-uu-uu-filename)
  97     (binhex
  98      "^:...............................................................$"
  99      ":$"
 100      mm-uu-binhex-extract
 101      nil
 102      mm-uu-binhex-filename)
 103     (yenc
 104      "^=ybegin.*size=[0-9]+.*name=.*$"
 105      "^=yend.*size=[0-9]+"
 106      mm-uu-yenc-extract
 107      mm-uu-yenc-filename)
 108     (shar
 109      "^#! */bin/sh"
 110      "^exit 0$"
 111      mm-uu-shar-extract)
 112     (forward
 113 ;;; Thanks to Edward J. Sabol <sabol@alderaan.gsfc.nasa.gov> and
 114 ;;; Peter von der Ah\'e <pahe@daimi.au.dk>
 115      "^-+ \\(Start of \\)?Forwarded message"
 116      "^-+ End \\(of \\)?forwarded message"
 117      mm-uu-forward-extract
 118      nil
 119      mm-uu-forward-test)
 120     (gnatsweb
 121      "^----gnatsweb-attachment----"
 122      nil
 123      mm-uu-gnatsweb-extract)
 124     (pgp-signed
 125      "^-----BEGIN PGP SIGNED MESSAGE-----"
 126      "^-----END PGP SIGNATURE-----"
 127      mm-uu-pgp-signed-extract
 128      nil
 129      nil)
 130     (pgp-encrypted
 131      "^-----BEGIN PGP MESSAGE-----"
 132      "^-----END PGP MESSAGE-----"
 133      mm-uu-pgp-encrypted-extract
 134      nil
 135      nil)
 136     (pgp-key
 137      "^-----BEGIN PGP PUBLIC KEY BLOCK-----"
 138      "^-----END PGP PUBLIC KEY BLOCK-----"
 139      mm-uu-pgp-key-extract
 140      mm-uu-gpg-key-skip-to-last
 141      nil)
 142     (emacs-sources
 143      "^;;;?[ \t]*[^ \t]+\\.el[ \t]*--"
 144      "^;;;?[ \t]*\\([^ \t]+\\.el\\)[ \t]+ends here"
 145      mm-uu-emacs-sources-extract
 146      nil
 147      mm-uu-emacs-sources-test)
 148     (diff
 149      "^Index: "
 150      nil
 151      mm-uu-diff-extract
 152      nil
 153      mm-uu-diff-test)))
 154
 155 (defcustom mm-uu-configure-list '((shar . disabled))
 156   "A list of mm-uu configuration.
 157 To disable dissecting shar codes, for instance, add
 158 `(shar . disabled)' to this list."
 159   :type 'alist
 160   :options (mapcar (lambda (entry)
 161                      (list (car entry) '(const disabled)))
 162                    mm-uu-type-alist)
 163   :group 'gnus-article-mime)
 164
 165 ;; functions
 166
 167 (defsubst mm-uu-type (entry)
 168   (car entry))
 169
 170 (defsubst mm-uu-beginning-regexp (entry)
 171   (nth 1 entry))
 172
 173 (defsubst mm-uu-end-regexp (entry)
 174   (nth 2 entry))
 175
 176 (defsubst mm-uu-function-extract (entry)
 177   (nth 3 entry))
 178
 179 (defsubst mm-uu-function-1 (entry)
 180   (nth 4 entry))
 181
 182 (defsubst mm-uu-function-2 (entry)
 183   (nth 5 entry))
 184
 185 (defun mm-uu-copy-to-buffer (&optional from to)
 186   "Copy the contents of the current buffer to a fresh buffer.
 187 Return that buffer."
 188   (save-excursion
 189     (let ((obuf (current-buffer))
 190           (coding-system
 191            ;; Might not exist in non-MULE XEmacs
 192            (when (boundp 'buffer-file-coding-system)
 193              buffer-file-coding-system)))
 194       (set-buffer (generate-new-buffer " *mm-uu*"))
 195       (setq buffer-file-coding-system coding-system)
 196       (insert-buffer-substring obuf from to)
 197       (current-buffer))))
 198
 199 (defun mm-uu-configure-p  (key val)
 200   (member (cons key val) mm-uu-configure-list))
 201
 202 (defun mm-uu-configure (&optional symbol value)
 203   (if symbol (set-default symbol value))
 204   (setq mm-uu-beginning-regexp nil)
 205   (mapcar (lambda (entry)
 206             (if (mm-uu-configure-p (mm-uu-type entry) 'disabled)
 207                 nil
 208               (setq mm-uu-beginning-regexp
 209                     (concat mm-uu-beginning-regexp
 210                             (if mm-uu-beginning-regexp "\\|")
 211                             (mm-uu-beginning-regexp entry)))))
 212           mm-uu-type-alist))
 213
 214 (mm-uu-configure)
 215
 216 (eval-when-compile
 217   (defvar file-name)
 218   (defvar start-point)
 219   (defvar end-point)
 220   (defvar entry))
 221
 222 (defun mm-uu-uu-filename ()
 223   (if (looking-at ".+")
 224       (setq file-name
 225             (let ((nnheader-file-name-translation-alist
 226                    '((?/ . ?,) (?\  . ?_) (?* . ?_) (?$ . ?_))))
 227               (nnheader-translate-file-chars (match-string 0))))))
 228
 229 (defun mm-uu-binhex-filename ()
 230   (setq file-name
 231         (ignore-errors
 232           (binhex-decode-region start-point end-point t))))
 233
 234 (defun mm-uu-yenc-filename ()
 235   (goto-char start-point)
 236   (setq file-name
 237         (ignore-errors
 238           (yenc-extract-filename))))
 239
 240 (defun mm-uu-forward-test ()
 241   (save-excursion
 242     (goto-char start-point)
 243     (forward-line)
 244     (looking-at "[\r\n]*[a-zA-Z][a-zA-Z0-9-]*:")))
 245
 246 (defun mm-uu-postscript-extract ()
 247   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
 248                   '("application/postscript")))
 249
 250 (defun mm-uu-emacs-sources-extract ()
 251   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
 252                   '("application/emacs-lisp")
 253                   nil nil
 254                   (list mm-dissect-disposition
 255                         (cons 'filename file-name))))
 256
 257 (eval-when-compile
 258   (defvar gnus-newsgroup-name))
 259
 260 (defun mm-uu-emacs-sources-test ()
 261   (setq file-name (match-string 1))
 262   (and gnus-newsgroup-name
 263        mm-uu-emacs-sources-regexp
 264        (string-match mm-uu-emacs-sources-regexp gnus-newsgroup-name)))
 265
 266 (defun mm-uu-diff-extract ()
 267   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
 268                   '("text/x-patch")))
 269
 270 (defun mm-uu-diff-test ()
 271   (and gnus-newsgroup-name
 272        mm-uu-diff-groups-regexp
 273        (string-match mm-uu-diff-groups-regexp gnus-newsgroup-name)))
 274
 275 (defun mm-uu-forward-extract ()
 276   (mm-make-handle (mm-uu-copy-to-buffer
 277                    (progn (goto-char start-point) (forward-line) (point))
 278                    (progn (goto-char end-point) (forward-line -1) (point)))
 279                   '("message/rfc822" (charset . gnus-decoded))))
 280
 281 (defun mm-uu-uu-extract ()
 282   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
 283                   (list (or (and file-name
 284                                  (string-match "\\.[^\\.]+$"
 285                                                file-name)
 286                                  (mailcap-extension-to-mime
 287                                   (match-string 0 file-name)))
 288                             "application/octet-stream"))
 289                   'x-uuencode nil
 290                   (if (and file-name (not (equal file-name "")))
 291                       (list mm-dissect-disposition
 292                             (cons 'filename file-name)))))
 293
 294 (defun mm-uu-binhex-extract ()
 295   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
 296                   (list (or (and file-name
 297                                  (string-match "\\.[^\\.]+$" file-name)
 298                                  (mailcap-extension-to-mime
 299                                   (match-string 0 file-name)))
 300                             "application/octet-stream"))
 301                   'x-binhex nil
 302                   (if (and file-name (not (equal file-name "")))
 303                       (list mm-dissect-disposition
 304                             (cons 'filename file-name)))))
 305
 306 (defun mm-uu-yenc-extract ()
 307   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
 308                   (list (or (and file-name
 309                                  (string-match "\\.[^\\.]+$" file-name)
 310                                  (mailcap-extension-to-mime
 311                                   (match-string 0 file-name)))
 312                             "application/octet-stream"))
 313                   'x-yenc nil
 314                   (if (and file-name (not (equal file-name "")))
 315                       (list mm-dissect-disposition
 316                             (cons 'filename file-name)))))
 317
 318
 319 (defun mm-uu-shar-extract ()
 320   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
 321                   '("application/x-shar")))
 322
 323 (defun mm-uu-gnatsweb-extract ()
 324   (save-restriction
 325     (goto-char start-point)
 326     (forward-line)
 327     (narrow-to-region (point) end-point)
 328     (mm-dissect-buffer t)))
 329
 330 (defun mm-uu-pgp-signed-test (&rest rest)
 331   (and
 332    mml2015-use
 333    (mml2015-clear-verify-function)
 334    (cond
 335     ((eq mm-verify-option 'never) nil)
 336     ((eq mm-verify-option 'always) t)
 337     ((eq mm-verify-option 'known) t)
 338     (t (y-or-n-p "Verify pgp signed part? ")))))
 339
 340 (eval-when-compile
 341   (defvar gnus-newsgroup-charset))
 342
 343 (defun mm-uu-pgp-signed-extract-1 (handles ctl)
 344   (let ((buf (mm-uu-copy-to-buffer (point-min) (point-max))))
 345     (with-current-buffer buf
 346       (if (mm-uu-pgp-signed-test)
 347           (progn
 348             (mml2015-clean-buffer)
 349             (let ((coding-system-for-write (or gnus-newsgroup-charset
 350                                                'iso-8859-1)))
 351               (funcall (mml2015-clear-verify-function))))
 352         (when (and mml2015-use (null (mml2015-clear-verify-function)))
 353           (mm-set-handle-multipart-parameter
 354            mm-security-handle 'gnus-details
 355            (format "Clear verification not supported by `%s'.\n" mml2015-use))))
 356       (goto-char (point-min))
 357       (if (search-forward "\n\n" nil t)
 358           (delete-region (point-min) (point)))
 359       (if (re-search-forward mm-uu-pgp-beginning-signature nil t)
 360           (delete-region (match-beginning 0) (point-max)))
 361       (goto-char (point-min))
 362       (while (re-search-forward "^- " nil t)
 363         (replace-match "" t t)
 364         (forward-line 1)))
 365     (list (mm-make-handle buf '("text/plain" (charset . gnus-decoded))))))
 366
 367 (defun mm-uu-pgp-signed-extract ()
 368   (let ((mm-security-handle (list (format "multipart/signed"))))
 369     (mm-set-handle-multipart-parameter
 370      mm-security-handle 'protocol "application/x-gnus-pgp-signature")
 371     (save-restriction
 372       (narrow-to-region start-point end-point)
 373       (add-text-properties 0 (length (car mm-security-handle))
 374                            (list 'buffer (mm-uu-copy-to-buffer))
 375                            (car mm-security-handle))
 376       (setcdr mm-security-handle
 377               (mm-uu-pgp-signed-extract-1 nil
 378                                           mm-security-handle)))
 379     mm-security-handle))
 380
 381 (defun mm-uu-pgp-encrypted-test (&rest rest)
 382   (and
 383    mml2015-use
 384    (mml2015-clear-decrypt-function)
 385    (cond
 386     ((eq mm-decrypt-option 'never) nil)
 387     ((eq mm-decrypt-option 'always) t)
 388     ((eq mm-decrypt-option 'known) t)
 389     (t (y-or-n-p "Decrypt pgp encrypted part? ")))))
 390
 391 (defun mm-uu-pgp-encrypted-extract-1 (handles ctl)
 392   (let ((buf (mm-uu-copy-to-buffer (point-min) (point-max))))
 393     (if (mm-uu-pgp-encrypted-test)
 394         (with-current-buffer buf
 395           (mml2015-clean-buffer)
 396           (funcall (mml2015-clear-decrypt-function))))
 397     (list
 398      (mm-make-handle buf
 399                      '("text/plain"  (charset . gnus-decoded))))))
 400
 401 (defun mm-uu-pgp-encrypted-extract ()
 402   (let ((mm-security-handle (list (format "multipart/encrypted"))))
 403     (mm-set-handle-multipart-parameter
 404      mm-security-handle 'protocol "application/x-gnus-pgp-encrypted")
 405     (save-restriction
 406       (narrow-to-region start-point end-point)
 407       (add-text-properties 0 (length (car mm-security-handle))
 408                            (list 'buffer (mm-uu-copy-to-buffer))
 409                            (car mm-security-handle))
 410       (setcdr mm-security-handle
 411               (mm-uu-pgp-encrypted-extract-1 nil
 412                                              mm-security-handle)))
 413     mm-security-handle))
 414
 415 (defun mm-uu-gpg-key-skip-to-last ()
 416   (let ((point (point))
 417         (end-regexp (mm-uu-end-regexp entry))
 418         (beginning-regexp (mm-uu-beginning-regexp entry)))
 419     (when (and end-regexp
 420                (not (mm-uu-configure-p (mm-uu-type entry) 'disabled)))
 421       (while (re-search-forward end-regexp nil t)
 422         (skip-chars-forward " \t\n\r")
 423         (if (looking-at beginning-regexp)
 424             (setq point (match-end 0)))))
 425     (goto-char point)))
 426
 427 (defun mm-uu-pgp-key-extract ()
 428   (let ((buf (mm-uu-copy-to-buffer start-point end-point)))
 429     (mm-make-handle buf
 430                     '("application/pgp-keys"))))
 431
 432 ;;;###autoload
 433 (defun mm-uu-dissect ()
 434   "Dissect the current buffer and return a list of uu handles."
 435   (let ((case-fold-search t)
 436         text-start start-point end-point file-name result
 437         text-plain-type entry func)
 438     (save-excursion
 439       (goto-char (point-min))
 440       (cond
 441        ((looking-at "\n")
 442         (forward-line))
 443        ((search-forward "\n\n" nil t)
 444         t)
 445        (t (goto-char (point-max))))
 446       ;;; gnus-decoded is a fake charset, which means no further
 447       ;;; decoding.
 448       (setq text-start (point)
 449             text-plain-type '("text/plain"  (charset . gnus-decoded)))
 450       (while (re-search-forward mm-uu-beginning-regexp nil t)
 451         (setq start-point (match-beginning 0))
 452         (let ((alist mm-uu-type-alist)
 453               (beginning-regexp (match-string 0)))
 454           (while (not entry)
 455             (if (string-match (mm-uu-beginning-regexp (car alist))
 456                               beginning-regexp)
 457                 (setq entry (car alist))
 458               (pop alist))))
 459         (if (setq func (mm-uu-function-1 entry))
 460             (funcall func))
 461         (forward-line);; in case of failure
 462         (when (and (not (mm-uu-configure-p (mm-uu-type entry) 'disabled))
 463                    (let ((end-regexp (mm-uu-end-regexp entry)))
 464                      (if (not end-regexp)
 465                          (or (setq end-point (point-max)) t)
 466                        (prog1
 467                            (re-search-forward end-regexp nil t)
 468                          (forward-line)
 469                          (setq end-point (point)))))
 470                    (or (not (setq func (mm-uu-function-2 entry)))
 471                        (funcall func)))
 472           (if (and (> start-point text-start)
 473                    (progn
 474                      (goto-char text-start)
 475                      (re-search-forward "." start-point t)))
 476               (push
 477                (mm-make-handle (mm-uu-copy-to-buffer text-start start-point)
 478                                text-plain-type)
 479                result))
 480           (push
 481            (funcall (mm-uu-function-extract entry))
 482            result)
 483           (goto-char (setq text-start end-point))))
 484       (when result
 485         (if (and (> (point-max) (1+ text-start))
 486                  (save-excursion
 487                    (goto-char text-start)
 488                    (re-search-forward "." nil t)))
 489             (push
 490              (mm-make-handle (mm-uu-copy-to-buffer text-start (point-max))
 491                              text-plain-type)
 492              result))
 493         (setq result (cons "multipart/mixed" (nreverse result))))
 494       result)))
 495
 496 (provide 'mm-uu)
 497
 498 ;;; mm-uu.el ends here