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