git.chise.org Git - elisp/gnus.git-/blob - lisp/mm-uu.el

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