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