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
 158 (defcustom mm-uu-configure-list '((shar . disabled))
 159   "A list of mm-uu configuration.
 160 To disable dissecting shar codes, for instance, add
 161 `(shar . disabled)' to this list."
 162   :type 'alist
 163   :options (mapcar (lambda (entry)
 164                      (list (car entry) '(const disabled)))
 165                    mm-uu-type-alist)
 166   :group 'gnus-article-mime)
 167
 168 (defvar mm-uu-text-plain-type '("text/plain" (charset . gnus-decoded))
 169   "MIME type and parameters for text/plain parts.
 170 `gnus-decoded' is a fake charset, which means no further decoding.")
 171
 172 ;; functions
 173
 174 (defsubst mm-uu-type (entry)
 175   (car entry))
 176
 177 (defsubst mm-uu-beginning-regexp (entry)
 178   (nth 1 entry))
 179
 180 (defsubst mm-uu-end-regexp (entry)
 181   (nth 2 entry))
 182
 183 (defsubst mm-uu-function-extract (entry)
 184   (nth 3 entry))
 185
 186 (defsubst mm-uu-function-1 (entry)
 187   (nth 4 entry))
 188
 189 (defsubst mm-uu-function-2 (entry)
 190   (nth 5 entry))
 191
 192 (defun mm-uu-copy-to-buffer (&optional from to)
 193   "Copy the contents of the current buffer to a fresh buffer.
 194 Return that buffer."
 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     (with-current-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