cgit.sxemacs.org Git - gnus/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 '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 buffer-file-coding-system))
 191       (set-buffer (generate-new-buffer " *mm-uu*"))
 192       (setq buffer-file-coding-system coding-system)
 193       (insert-buffer-substring obuf from to)
 194       (current-buffer))))
 195
 196 (defun mm-uu-configure-p  (key val)
 197   (member (cons key val) mm-uu-configure-list))
 198
 199 (defun mm-uu-configure (&optional symbol value)
 200   (if symbol (set-default symbol value))
 201   (setq mm-uu-beginning-regexp nil)
 202   (mapcar (lambda (entry)
 203              (if (mm-uu-configure-p (mm-uu-type entry) 'disabled)
 204                  nil
 205                (setq mm-uu-beginning-regexp
 206                      (concat mm-uu-beginning-regexp
 207                              (if mm-uu-beginning-regexp "\\|")
 208                              (mm-uu-beginning-regexp entry)))))
 209           mm-uu-type-alist))
 210
 211 (mm-uu-configure)
 212
 213 (eval-when-compile
 214   (defvar file-name)
 215   (defvar start-point)
 216   (defvar end-point)
 217   (defvar entry))
 218
 219 (defun mm-uu-uu-filename ()
 220   (if (looking-at ".+")
 221       (setq file-name
 222             (let ((nnheader-file-name-translation-alist
 223                    '((?/ . ?,) (?\  . ?_) (?* . ?_) (?$ . ?_))))
 224               (nnheader-translate-file-chars (match-string 0))))))
 225
 226 (defun mm-uu-binhex-filename ()
 227   (setq file-name
 228         (ignore-errors
 229           (binhex-decode-region start-point end-point t))))
 230
 231 (defun mm-uu-yenc-filename ()
 232   (goto-char start-point)
 233   (setq file-name
 234         (ignore-errors
 235           (yenc-extract-filename))))
 236
 237 (defun mm-uu-forward-test ()
 238   (save-excursion
 239     (goto-char start-point)
 240     (forward-line)
 241     (looking-at "[\r\n]*[a-zA-Z][a-zA-Z0-9-]*:")))
 242
 243 (defun mm-uu-postscript-extract ()
 244   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
 245                   '("application/postscript")))
 246
 247 (defun mm-uu-emacs-sources-extract ()
 248   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
 249                   '("application/emacs-lisp")
 250                   nil nil
 251                   (list mm-dissect-disposition
 252                         (cons 'filename file-name))))
 253
 254 (eval-when-compile
 255   (defvar gnus-newsgroup-name))
 256
 257 (defun mm-uu-emacs-sources-test ()
 258   (setq file-name (match-string 1))
 259   (and gnus-newsgroup-name
 260        mm-uu-emacs-sources-regexp
 261        (string-match mm-uu-emacs-sources-regexp gnus-newsgroup-name)))
 262
 263 (defun mm-uu-diff-extract ()
 264   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
 265                   '("text/x-patch")))
 266
 267 (defun mm-uu-diff-test ()
 268   (and gnus-newsgroup-name
 269        mm-uu-diff-groups-regexp
 270        (string-match mm-uu-diff-groups-regexp gnus-newsgroup-name)))
 271
 272 (defun mm-uu-forward-extract ()
 273   (mm-make-handle (mm-uu-copy-to-buffer
 274                    (progn (goto-char start-point) (forward-line) (point))
 275                    (progn (goto-char end-point) (forward-line -1) (point)))
 276                   '("message/rfc822" (charset . gnus-decoded))))
 277
 278 (defun mm-uu-uu-extract ()
 279   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
 280                   (list (or (and file-name
 281                                  (string-match "\\.[^\\.]+$"
 282                                                file-name)
 283                                  (mailcap-extension-to-mime
 284                                   (match-string 0 file-name)))
 285                             "application/octet-stream"))
 286                   'x-uuencode nil
 287                   (if (and file-name (not (equal file-name "")))
 288                       (list mm-dissect-disposition
 289                             (cons 'filename file-name)))))
 290
 291 (defun mm-uu-binhex-extract ()
 292   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
 293                   (list (or (and file-name
 294                                  (string-match "\\.[^\\.]+$" file-name)
 295                                  (mailcap-extension-to-mime
 296                                   (match-string 0 file-name)))
 297                             "application/octet-stream"))
 298                   'x-binhex nil
 299                   (if (and file-name (not (equal file-name "")))
 300                       (list mm-dissect-disposition
 301                             (cons 'filename file-name)))))
 302
 303 (defun mm-uu-yenc-extract ()
 304   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
 305                   (list (or (and file-name
 306                                  (string-match "\\.[^\\.]+$" file-name)
 307                                  (mailcap-extension-to-mime
 308                                   (match-string 0 file-name)))
 309                             "application/octet-stream"))
 310                   'x-yenc nil
 311                   (if (and file-name (not (equal file-name "")))
 312                       (list mm-dissect-disposition
 313                             (cons 'filename file-name)))))
 314
 315
 316 (defun mm-uu-shar-extract ()
 317   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
 318                   '("application/x-shar")))
 319
 320 (defun mm-uu-gnatsweb-extract ()
 321   (save-restriction
 322     (goto-char start-point)
 323     (forward-line)
 324     (narrow-to-region (point) end-point)
 325     (mm-dissect-buffer t)))
 326
 327 (defun mm-uu-pgp-signed-test (&rest rest)
 328   (and
 329    mml2015-use
 330    (mml2015-clear-verify-function)
 331    (cond
 332     ((eq mm-verify-option 'never) nil)
 333     ((eq mm-verify-option 'always) t)
 334     ((eq mm-verify-option 'known) t)
 335     (t (y-or-n-p "Verify pgp signed part?")))))
 336
 337 (eval-when-compile
 338   (defvar gnus-newsgroup-charset))
 339
 340 (defun mm-uu-pgp-signed-extract-1 (handles ctl)
 341   (let ((buf (mm-uu-copy-to-buffer (point-min) (point-max))))
 342     (with-current-buffer buf
 343       (if (mm-uu-pgp-signed-test)
 344           (progn
 345             (mml2015-clean-buffer)
 346             (let ((coding-system-for-write (or gnus-newsgroup-charset
 347                                                'iso-8859-1)))
 348               (funcall (mml2015-clear-verify-function))))
 349         (when (and mml2015-use (null (mml2015-clear-verify-function)))
 350           (mm-set-handle-multipart-parameter
 351            mm-security-handle 'gnus-details
 352            (format "Clear verification not supported by `%s'.\n" mml2015-use))))
 353       (goto-char (point-min))
 354       (if (search-forward "\n\n" nil t)
 355           (delete-region (point-min) (point)))
 356       (if (re-search-forward mm-uu-pgp-beginning-signature nil t)
 357           (delete-region (match-beginning 0) (point-max)))
 358       (goto-char (point-min))
 359       (while (re-search-forward "^- " nil t)
 360         (replace-match "" t t)
 361         (forward-line 1)))
 362     (list (mm-make-handle buf '("text/plain" (charset . gnus-decoded))))))
 363
 364 (defun mm-uu-pgp-signed-extract ()
 365   (let ((mm-security-handle (list (format "multipart/signed"))))
 366     (mm-set-handle-multipart-parameter
 367      mm-security-handle 'protocol "application/x-gnus-pgp-signature")
 368     (save-restriction
 369       (narrow-to-region start-point end-point)
 370       (add-text-properties 0 (length (car mm-security-handle))
 371                            (list 'buffer (mm-uu-copy-to-buffer))
 372                            (car mm-security-handle))
 373       (setcdr mm-security-handle
 374               (mm-uu-pgp-signed-extract-1 nil
 375                                           mm-security-handle)))
 376     mm-security-handle))
 377
 378 (defun mm-uu-pgp-encrypted-test (&rest rest)
 379   (and
 380    mml2015-use
 381    (mml2015-clear-decrypt-function)
 382    (cond
 383     ((eq mm-decrypt-option 'never) nil)
 384     ((eq mm-decrypt-option 'always) t)
 385     ((eq mm-decrypt-option 'known) t)
 386     (t (y-or-n-p "Decrypt pgp encrypted part? ")))))
 387
 388 (defun mm-uu-pgp-encrypted-extract-1 (handles ctl)
 389   (let ((buf (mm-uu-copy-to-buffer (point-min) (point-max))))
 390     (if (mm-uu-pgp-encrypted-test)
 391         (with-current-buffer buf
 392           (mml2015-clean-buffer)
 393           (funcall (mml2015-clear-decrypt-function))))
 394     (list
 395      (mm-make-handle buf
 396                      '("text/plain"  (charset . gnus-decoded))))))
 397
 398 (defun mm-uu-pgp-encrypted-extract ()
 399   (let ((mm-security-handle (list (format "multipart/encrypted"))))
 400     (mm-set-handle-multipart-parameter
 401      mm-security-handle 'protocol "application/x-gnus-pgp-encrypted")
 402     (save-restriction
 403       (narrow-to-region start-point end-point)
 404       (add-text-properties 0 (length (car mm-security-handle))
 405                            (list 'buffer (mm-uu-copy-to-buffer))
 406                            (car mm-security-handle))
 407       (setcdr mm-security-handle
 408               (mm-uu-pgp-encrypted-extract-1 nil
 409                                              mm-security-handle)))
 410     mm-security-handle))
 411
 412 (defun mm-uu-gpg-key-skip-to-last ()
 413   (let ((point (point))
 414         (end-regexp (mm-uu-end-regexp entry))
 415         (beginning-regexp (mm-uu-beginning-regexp entry)))
 416     (when (and end-regexp
 417                (not (mm-uu-configure-p (mm-uu-type entry) 'disabled)))
 418       (while (re-search-forward end-regexp nil t)
 419         (skip-chars-forward " \t\n\r")
 420         (if (looking-at beginning-regexp)
 421             (setq point (match-end 0)))))
 422     (goto-char point)))
 423
 424 (defun mm-uu-pgp-key-extract ()
 425   (let ((buf (mm-uu-copy-to-buffer start-point end-point)))
 426     (mm-make-handle buf
 427                     '("application/pgp-keys"))))
 428
 429 ;;;###autoload
 430 (defun mm-uu-dissect ()
 431   "Dissect the current buffer and return a list of uu handles."
 432   (let ((case-fold-search t)
 433         text-start start-point end-point file-name result
 434         text-plain-type entry func)
 435     (save-excursion
 436       (goto-char (point-min))
 437       (cond
 438        ((looking-at "\n")
 439         (forward-line))
 440        ((search-forward "\n\n" nil t)
 441         t)
 442        (t (goto-char (point-max))))
 443       ;;; gnus-decoded is a fake charset, which means no further
 444       ;;; decoding.
 445       (setq text-start (point)
 446             text-plain-type '("text/plain"  (charset . gnus-decoded)))
 447       (while (re-search-forward mm-uu-beginning-regexp nil t)
 448         (setq start-point (match-beginning 0))
 449         (let ((alist mm-uu-type-alist)
 450               (beginning-regexp (match-string 0)))
 451           (while (not entry)
 452             (if (string-match (mm-uu-beginning-regexp (car alist))
 453                               beginning-regexp)
 454                 (setq entry (car alist))
 455               (pop alist))))
 456         (if (setq func (mm-uu-function-1 entry))
 457             (funcall func))
 458         (forward-line);; in case of failure
 459         (when (and (not (mm-uu-configure-p (mm-uu-type entry) 'disabled))
 460                    (let ((end-regexp (mm-uu-end-regexp entry)))
 461                      (if (not end-regexp)
 462                          (or (setq end-point (point-max)) t)
 463                        (prog1
 464                            (re-search-forward end-regexp nil t)
 465                          (forward-line)
 466                          (setq end-point (point)))))
 467                    (or (not (setq func (mm-uu-function-2 entry)))
 468                        (funcall func)))
 469           (if (and (> start-point text-start)
 470                    (progn
 471                      (goto-char text-start)
 472                      (re-search-forward "." start-point t)))
 473               (push
 474                (mm-make-handle (mm-uu-copy-to-buffer text-start start-point)
 475                                text-plain-type)
 476                result))
 477           (push
 478            (funcall (mm-uu-function-extract entry))
 479            result)
 480           (goto-char (setq text-start end-point))))
 481       (when result
 482         (if (and (> (point-max) (1+ text-start))
 483                  (save-excursion
 484                    (goto-char text-start)
 485                    (re-search-forward "." nil t)))
 486             (push
 487              (mm-make-handle (mm-uu-copy-to-buffer text-start (point-max))
 488                              text-plain-type)
 489              result))
 490         (setq result (cons "multipart/mixed" (nreverse result))))
 491       result)))
 492
 493 (provide 'mm-uu)
 494
 495 ;;; mm-uu.el ends here