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