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 'gnus-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 `(repeat (cons
 136                   ,(cons 'choice
 137                          (mapcar
 138                           (lambda (entry)
 139                             (cons 'item (car entry)))
 140                           mm-uu-type-alist))
 141                   (choice (item disabled))))
 142   :group 'gnus-article-mime)
 143
 144 ;; functions
 145
 146 (defsubst mm-uu-type (entry)
 147   (car entry))
 148
 149 (defsubst mm-uu-beginning-regexp (entry)
 150   (nth 1 entry))
 151
 152 (defsubst mm-uu-end-regexp (entry)
 153   (nth 2 entry))
 154
 155 (defsubst mm-uu-function-extract (entry)
 156   (nth 3 entry))
 157
 158 (defsubst mm-uu-function-1 (entry)
 159   (nth 4 entry))
 160
 161 (defsubst mm-uu-function-2 (entry)
 162   (nth 5 entry))
 163
 164 (defun mm-uu-copy-to-buffer (&optional from to)
 165   "Copy the contents of the current buffer to a fresh buffer.
 166 Return that buffer."
 167   (save-excursion
 168     (let ((obuf (current-buffer)))
 169       (set-buffer (generate-new-buffer " *mm-uu*"))
 170       (insert-buffer-substring obuf from to)
 171       (current-buffer))))
 172
 173 (defun mm-uu-configure-p  (key val)
 174   (member (cons key val) mm-uu-configure-list))
 175
 176 (defun mm-uu-configure (&optional symbol value)
 177   (if symbol (set-default symbol value))
 178   (setq mm-uu-beginning-regexp nil)
 179   (mapcar (lambda (entry)
 180              (if (mm-uu-configure-p (mm-uu-type entry) 'disabled)
 181                  nil
 182                (setq mm-uu-beginning-regexp
 183                      (concat mm-uu-beginning-regexp
 184                              (if mm-uu-beginning-regexp "\\|")
 185                              (mm-uu-beginning-regexp entry)))))
 186           mm-uu-type-alist))
 187
 188 (mm-uu-configure)
 189
 190 (eval-when-compile
 191   (defvar file-name)
 192   (defvar start-point)
 193   (defvar end-point)
 194   (defvar entry))
 195
 196 (defun mm-uu-uu-filename ()
 197   (if (looking-at ".+")
 198       (setq file-name
 199             (let ((nnheader-file-name-translation-alist
 200                    '((?/ . ?,) (? . ?_) (?* . ?_) (?$ . ?_))))
 201               (nnheader-translate-file-chars (match-string 0))))))
 202
 203 (defun mm-uu-binhex-filename ()
 204   (setq file-name
 205         (ignore-errors
 206           (binhex-decode-region start-point end-point t))))
 207
 208 (defun mm-uu-forward-test ()
 209   (save-excursion
 210     (goto-char start-point)
 211     (forward-line)
 212     (looking-at "[\r\n]*[a-zA-Z][a-zA-Z0-9-]*:")))
 213
 214 (defun mm-uu-postscript-extract ()
 215   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
 216                   '("application/postscript")))
 217
 218 (defun mm-uu-emacs-sources-extract ()
 219   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
 220                   '("application/emacs-lisp")
 221                   nil nil
 222                   (list mm-dissect-disposition
 223                         (cons 'filename file-name))))
 224
 225 (eval-when-compile
 226   (defvar gnus-newsgroup-name))
 227
 228 (defun mm-uu-emacs-sources-test ()
 229   (setq file-name (match-string 1))
 230   (and gnus-newsgroup-name
 231        mm-uu-emacs-sources-regexp
 232        (string-match mm-uu-emacs-sources-regexp gnus-newsgroup-name)))
 233
 234 (defun mm-uu-forward-extract ()
 235   (mm-make-handle (mm-uu-copy-to-buffer
 236                    (progn (goto-char start-point) (forward-line) (point))
 237                    (progn (goto-char end-point) (forward-line -1) (point)))
 238                   '("message/rfc822" (charset . gnus-decoded))))
 239
 240 (defun mm-uu-uu-extract ()
 241   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
 242                   (list (or (and file-name
 243                                  (string-match "\\.[^\\.]+$"
 244                                                file-name)
 245                                  (mailcap-extension-to-mime
 246                                   (match-string 0 file-name)))
 247                             "application/octet-stream"))
 248                   'x-uuencode nil
 249                   (if (and file-name (not (equal file-name "")))
 250                       (list mm-dissect-disposition
 251                             (cons 'filename file-name)))))
 252
 253 (defun mm-uu-binhex-extract ()
 254   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
 255                   (list (or (and file-name
 256                                  (string-match "\\.[^\\.]+$" file-name)
 257                                  (mailcap-extension-to-mime
 258                                   (match-string 0 file-name)))
 259                             "application/octet-stream"))
 260                   'x-binhex nil
 261                   (if (and file-name (not (equal file-name "")))
 262                       (list mm-dissect-disposition
 263                             (cons 'filename file-name)))))
 264
 265 (defun mm-uu-shar-extract ()
 266   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
 267                   '("application/x-shar")))
 268
 269 (defun mm-uu-gnatsweb-extract ()
 270   (save-restriction
 271     (goto-char start-point)
 272     (forward-line)
 273     (narrow-to-region (point) end-point)
 274     (mm-dissect-buffer t)))
 275
 276 (defun mm-uu-pgp-signed-test (&rest rest)
 277   (and
 278    mml2015-use
 279    (mml2015-clear-verify-function)
 280    (cond
 281     ((eq mm-verify-option 'never) nil)
 282     ((eq mm-verify-option 'always) t)
 283     ((eq mm-verify-option 'known) t)
 284     (t (y-or-n-p "Verify pgp signed part?")))))
 285
 286 (eval-when-compile
 287   (defvar gnus-newsgroup-charset))
 288
 289 (defun mm-uu-pgp-signed-extract-1 (handles ctl)
 290   (let ((buf (mm-uu-copy-to-buffer (point-min) (point-max))))
 291     (with-current-buffer buf
 292       (if (mm-uu-pgp-signed-test)
 293           (progn
 294             (mml2015-clean-buffer)
 295             (let ((coding-system-for-write (or gnus-newsgroup-charset
 296                                                'iso-8859-1)))
 297               (funcall (mml2015-clear-verify-function))))
 298         (when (and mml2015-use (null (mml2015-clear-verify-function)))
 299           (mm-set-handle-multipart-parameter
 300            mm-security-handle 'gnus-details
 301            (format "Clear verification not supported by `%s'.\n" mml2015-use))))
 302       (goto-char (point-min))
 303       (if (search-forward "\n\n" nil t)
 304           (delete-region (point-min) (point)))
 305       (if (re-search-forward mm-uu-pgp-beginning-signature nil t)
 306           (delete-region (match-beginning 0) (point-max)))
 307       (goto-char (point-min))
 308       (while (re-search-forward "^- " nil t)
 309         (replace-match "" t t)
 310         (forward-line 1)))
 311     (list (mm-make-handle buf '("text/plain" (charset . gnus-decoded))))))
 312
 313 (defun mm-uu-pgp-signed-extract ()
 314   (let ((mm-security-handle (list (format "multipart/signed"))))
 315     (mm-set-handle-multipart-parameter
 316      mm-security-handle 'protocol "application/x-gnus-pgp-signature")
 317     (save-restriction
 318       (narrow-to-region start-point end-point)
 319       (add-text-properties 0 (length (car mm-security-handle))
 320                            (list 'buffer (mm-uu-copy-to-buffer))
 321                            (car mm-security-handle))
 322       (setcdr mm-security-handle
 323               (mm-uu-pgp-signed-extract-1 nil
 324                                           mm-security-handle)))
 325     mm-security-handle))
 326
 327 (defun mm-uu-pgp-encrypted-test (&rest rest)
 328   (and
 329    mml2015-use
 330    (mml2015-clear-decrypt-function)
 331    (cond
 332     ((eq mm-decrypt-option 'never) nil)
 333     ((eq mm-decrypt-option 'always) t)
 334     ((eq mm-decrypt-option 'known) t)
 335     (t (y-or-n-p "Decrypt pgp encrypted part?")))))
 336
 337 (defun mm-uu-pgp-encrypted-extract-1 (handles ctl)
 338   (let ((buf (mm-uu-copy-to-buffer (point-min) (point-max))))
 339     (if (mm-uu-pgp-encrypted-test)
 340         (with-current-buffer buf
 341           (mml2015-clean-buffer)
 342           (funcall (mml2015-clear-decrypt-function))))
 343     (list
 344      (mm-make-handle buf
 345                      '("text/plain"  (charset . gnus-decoded))))))
 346
 347 (defun mm-uu-pgp-encrypted-extract ()
 348   (let ((mm-security-handle (list (format "multipart/encrypted"))))
 349     (mm-set-handle-multipart-parameter
 350      mm-security-handle 'protocol "application/x-gnus-pgp-encrypted")
 351     (save-restriction
 352       (narrow-to-region start-point end-point)
 353       (add-text-properties 0 (length (car mm-security-handle))
 354                            (list 'buffer (mm-uu-copy-to-buffer))
 355                            (car mm-security-handle))
 356       (setcdr mm-security-handle
 357               (mm-uu-pgp-encrypted-extract-1 nil
 358                                              mm-security-handle)))
 359     mm-security-handle))
 360
 361 (defun mm-uu-gpg-key-skip-to-last ()
 362   (let ((point (point))
 363         (end-regexp (mm-uu-end-regexp entry))
 364         (beginning-regexp (mm-uu-beginning-regexp entry)))
 365     (when (and end-regexp
 366                (not (mm-uu-configure-p (mm-uu-type entry) 'disabled)))
 367       (while (re-search-forward end-regexp nil t)
 368         (skip-chars-forward " \t\n\r")
 369         (if (looking-at beginning-regexp)
 370             (setq point (match-end 0)))))
 371     (goto-char point)))
 372
 373 (defun mm-uu-pgp-key-extract ()
 374   (let ((buf (mm-uu-copy-to-buffer start-point end-point)))
 375     (mm-make-handle buf
 376                     '("application/pgp-keys"))))
 377
 378 ;;;### autoload
 379 (defun mm-uu-dissect ()
 380   "Dissect the current buffer and return a list of uu handles."
 381   (let ((case-fold-search t)
 382         text-start start-point end-point file-name result
 383         text-plain-type entry func)
 384     (save-excursion
 385       (goto-char (point-min))
 386       (cond
 387        ((looking-at "\n")
 388         (forward-line))
 389        ((search-forward "\n\n" nil t)
 390         t)
 391        (t (goto-char (point-max))))
 392       ;;; gnus-decoded is a fake charset, which means no further
 393       ;;; decoding.
 394       (setq text-start (point)
 395             text-plain-type '("text/plain"  (charset . gnus-decoded)))
 396       (while (re-search-forward mm-uu-beginning-regexp nil t)
 397         (setq start-point (match-beginning 0))
 398         (let ((alist mm-uu-type-alist)
 399               (beginning-regexp (match-string 0)))
 400           (while (not entry)
 401             (if (string-match (mm-uu-beginning-regexp (car alist))
 402                               beginning-regexp)
 403                 (setq entry (car alist))
 404               (pop alist))))
 405         (if (setq func (mm-uu-function-1 entry))
 406             (funcall func))
 407         (forward-line);; in case of failure
 408         (when (and (not (mm-uu-configure-p (mm-uu-type entry) 'disabled))
 409                    (let ((end-regexp (mm-uu-end-regexp entry)))
 410                      (if (not end-regexp)
 411                          (or (setq end-point (point-max)) t)
 412                        (prog1
 413                            (re-search-forward end-regexp nil t)
 414                          (forward-line)
 415                          (setq end-point (point)))))
 416                    (or (not (setq func (mm-uu-function-2 entry)))
 417                        (funcall func)))
 418           (if (and (> start-point text-start)
 419                    (progn
 420                      (goto-char text-start)
 421                      (re-search-forward "." start-point t)))
 422               (push
 423                (mm-make-handle (mm-uu-copy-to-buffer text-start start-point)
 424                                text-plain-type)
 425                result))
 426           (push
 427            (funcall (mm-uu-function-extract entry))
 428            result)
 429           (goto-char (setq text-start end-point))))
 430       (when result
 431         (if (and (> (point-max) (1+ text-start))
 432                  (save-excursion
 433                    (goto-char text-start)
 434                    (re-search-forward "." nil t)))
 435             (push
 436              (mm-make-handle (mm-uu-copy-to-buffer text-start (point-max))
 437                              text-plain-type)
 438              result))
 439         (setq result (cons "multipart/mixed" (nreverse result))))
 440       result)))
 441
 442 (provide 'mm-uu)
 443
 444 ;;; mm-uu.el ends here