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