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