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 (defcustom mm-uu-decode-function 'uudecode-decode-region
  44   "*Function to uudecode.
  45 Internal function is done in Lisp by default, therefore decoding may
  46 appear to be horribly slow.  You can make Gnus use an external
  47 decoder, such as uudecode."
  48   :type '(choice
  49           (function-item :tag "Auto detect" uudecode-decode-region)
  50           (function-item :tag "Internal" uudecode-decode-region-internal)
  51           (function-item :tag "External" uudecode-decode-region-external))
  52   :group 'gnus-article-mime)
  53
  54 (defcustom mm-uu-binhex-decode-function 'binhex-decode-region
  55   "*Function to binhex decode.
  56 Internal function is done in elisp by default, therefore decoding may
  57 appear to be horribly slow . You can make Gnus use the external Unix
  58 decoder, such as hexbin."
  59   :type '(choice (function-item :tag "Auto detect" binhex-decode-region)
  60                  (function-item :tag "Internal" binhex-decode-region-internal)
  61                  (function-item :tag "External" binhex-decode-region-external))
  62   :group 'gnus-article-mime)
  63
  64 (defvar mm-uu-pgp-beginning-signature
  65      "^-----BEGIN PGP SIGNATURE-----")
  66
  67 (defvar mm-uu-beginning-regexp nil)
  68
  69 (defvar mm-dissect-disposition "inline"
  70   "The default disposition of uu parts.
  71 This can be either \"inline\" or \"attachment\".")
  72
  73 (defvar mm-uu-emacs-sources-regexp "gnu\\.emacs\\.sources"
  74   "The regexp of emacs sources groups.")
  75
  76 (defvar mm-uu-type-alist
  77   '((postscript
  78      "^%!PS-"
  79      "^%%EOF$"
  80      mm-uu-postscript-extract
  81      nil)
  82     (uu
  83      "^begin[ \t]+0?[0-7][0-7][0-7][ \t]+"
  84      "^end[ \t]*$"
  85      mm-uu-uu-extract
  86      mm-uu-uu-filename)
  87     (binhex
  88      "^:...............................................................$"
  89      ":$"
  90      mm-uu-binhex-extract
  91      nil
  92      mm-uu-binhex-filename)
  93     (shar
  94      "^#! */bin/sh"
  95      "^exit 0$"
  96      mm-uu-shar-extract)
  97     (forward
  98 ;;; Thanks to Edward J. Sabol <sabol@alderaan.gsfc.nasa.gov> and
  99 ;;; Peter von der Ah\'e <pahe@daimi.au.dk>
 100      "^-+ \\(Start of \\)?Forwarded message"
 101      "^-+ End \\(of \\)?forwarded message"
 102      mm-uu-forward-extract
 103      nil
 104      mm-uu-forward-test)
 105     (gnatsweb
 106      "^----gnatsweb-attachment----"
 107      nil
 108      mm-uu-gnatsweb-extract)
 109     (pgp-signed
 110      "^-----BEGIN PGP SIGNED MESSAGE-----"
 111      "^-----END PGP SIGNATURE-----"
 112      mm-uu-pgp-signed-extract
 113      nil
 114      nil)
 115     (pgp-encrypted
 116      "^-----BEGIN PGP MESSAGE-----"
 117      "^-----END PGP MESSAGE-----"
 118      mm-uu-pgp-encrypted-extract
 119      nil
 120      nil)
 121     (pgp-key
 122      "^-----BEGIN PGP PUBLIC KEY BLOCK-----"
 123      "^-----END PGP PUBLIC KEY BLOCK-----"
 124      mm-uu-pgp-key-extract
 125      mm-uu-gpg-key-skip-to-last
 126      nil)
 127     (emacs-sources
 128      "^;;;?[ \t]*[^ \t]+\\.el[ \t]*--"
 129      "^;;;?[ \t]*\\([^ \t]+\\.el\\)[ \t]+ends here"
 130      mm-uu-emacs-sources-extract
 131      nil
 132      mm-uu-emacs-sources-test)))
 133
 134 (defcustom mm-uu-configure-list nil
 135   "A list of mm-uu configuration.
 136 To disable dissecting shar codes, for instance, add
 137 `(shar . disabled)' to this list."
 138   :type 'alist
 139   :options (mapcar (lambda (entry)
 140                      (list (car entry) '(const disabled)))
 141                    mm-uu-type-alist)
 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