lisp/gnus/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 news
   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 'uudecode)
  34 (require 'binhex)
  35
  36 (defun mm-uu-copy-to-buffer (from to)
  37   "Copy the contents of the current buffer to a fresh buffer.
  38 Return that buffer."
  39   (save-excursion
  40     (let ((obuf (current-buffer)))
  41       (set-buffer (generate-new-buffer " *mm-uu*"))
  42       (insert-buffer-substring obuf from to)
  43       (current-buffer))))
  44
  45 ;;; postscript
  46
  47 (defconst mm-uu-postscript-begin-line "^%!PS-")
  48 (defconst mm-uu-postscript-end-line "^%%EOF$")
  49
  50 (defconst mm-uu-uu-begin-line "^begin[ \t]+[0-7][0-7][0-7][ \t]+")
  51 (defconst mm-uu-uu-end-line "^end[ \t]*$")
  52
  53 ;; This is not the right place for this.  uudecode.el should decide
  54 ;; whether or not to use a program with a single interface, but I
  55 ;; guess it's too late now.  Also the default should depend on a test
  56 ;; for the program.  -- fx
  57 (defcustom mm-uu-decode-function 'uudecode-decode-region
  58   "*Function to uudecode.
  59 Internal function is done in Lisp by default, therefore decoding may
  60 appear to be horribly slow.  You can make Gnus use an external
  61 decoder, such as uudecode."
  62   :type '(choice
  63           (function-item :tag "Internal" uudecode-decode-region)
  64           (function-item :tag "External" uudecode-decode-region-external))
  65   :group 'gnus-article-mime)
  66
  67 (defconst mm-uu-binhex-begin-line
  68   "^:...............................................................$")
  69 (defconst mm-uu-binhex-end-line ":$")
  70
  71 (defcustom mm-uu-binhex-decode-function 'binhex-decode-region
  72   "*Function to binhex decode.
  73 Internal function is done in Lisp by default, therefore decoding may
  74 appear to be horribly slow.  You can make Gnus use an external
  75 decoder, such as hexbin."
  76   :type '(choice
  77           (function-item :tag "Internal" binhex-decode-region)
  78           (function-item :tag "External" binhex-decode-region-external))
  79   :group 'gnus-article-mime)
  80
  81 (defconst mm-uu-shar-begin-line "^#! */bin/sh")
  82 (defconst mm-uu-shar-end-line "^exit 0\\|^$")
  83
  84 ;;; Thanks to Edward J. Sabol <sabol@alderaan.gsfc.nasa.gov> and
  85 ;;; Peter von der Ah\'e <pahe@daimi.au.dk>
  86 (defconst mm-uu-forward-begin-line "^-+ \\(Start of \\)?Forwarded message")
  87 (defconst mm-uu-forward-end-line "^-+ End \\(of \\)?forwarded message")
  88
  89 (defvar mm-uu-begin-line nil)
  90
  91 (defconst mm-uu-identifier-alist
  92   '((?% . postscript) (?b . uu) (?: . binhex) (?# . shar)
  93     (?- . forward)))
  94
  95 (defvar mm-dissect-disposition "inline"
  96   "The default disposition of uu parts.
  97 This can be either \"inline\" or \"attachment\".")
  98
  99 (defun mm-uu-configure-p  (key val)
 100   (member (cons key val) mm-uu-configure-list))
 101
 102 (defun mm-uu-configure (&optional symbol value)
 103   (if symbol (set-default symbol value))
 104   (setq mm-uu-begin-line nil)
 105   (mapcar (lambda (type)
 106             (if (mm-uu-configure-p type 'disabled)
 107                 nil
 108               (setq mm-uu-begin-line
 109                     (concat mm-uu-begin-line
 110                             (if mm-uu-begin-line "\\|")
 111                             (symbol-value
 112                              (intern (concat "mm-uu-" (symbol-name type)
 113                                              "-begin-line")))))))
 114           '(uu postscript binhex shar forward)))
 115
 116 ;; Needs to come after mm-uu-configure.
 117 (defcustom mm-uu-configure-list nil
 118   "Alist of mm-uu configurations to disable.
 119 To disable dissecting shar codes, for instance, add
 120 `(shar . disabled)' to this list."
 121   :type '(repeat (choice (const :tag "postscript" (postscript . disabled))
 122                          (const :tag "uu" (uu . disabled))
 123                          (const :tag "binhex" (binhex . disabled))
 124                          (const :tag "shar" (shar . disabled))
 125                          (const :tag "forward" (forward . disabled))))
 126   :group 'gnus-article-mime
 127   :set 'mm-uu-configure)
 128
 129 (mm-uu-configure)
 130
 131 ;;;###autoload
 132 (defun mm-uu-dissect ()
 133   "Dissect the current buffer and return a list of uu handles."
 134   (let (text-start start-char end-char
 135                    type file-name end-line result text-plain-type
 136                    start-char-1 end-char-1
 137                    (case-fold-search t))
 138     (save-excursion
 139       (save-restriction
 140         (mail-narrow-to-head)
 141         (goto-char (point-max)))
 142       (forward-line)
 143       ;;; gnus-decoded is a fake charset, which means no further
 144       ;;; decoding.
 145       (setq text-start (point)
 146             text-plain-type '("text/plain"  (charset . gnus-decoded)))
 147       (while (re-search-forward mm-uu-begin-line nil t)
 148         (setq start-char (match-beginning 0))
 149         (setq type (cdr (assq (aref (match-string 0) 0)
 150                               mm-uu-identifier-alist)))
 151         (setq file-name
 152               (if (and (eq type 'uu)
 153                        (looking-at "\\(.+\\)$"))
 154                   (and (match-string 1)
 155                        (let ((nnheader-file-name-translation-alist
 156                               '((?/ . ?,) (?\  . ?_) (?* . ?_) (?$ . ?_))))
 157                          (nnheader-translate-file-chars (match-string 1))))))
 158         (forward-line);; in case of failure
 159         (setq start-char-1 (point))
 160         (setq end-line (symbol-value
 161                         (intern (concat "mm-uu-" (symbol-name type)
 162                                         "-end-line"))))
 163         (when (and (re-search-forward end-line nil t)
 164                    (not (eq (match-beginning 0) (match-end 0))))
 165           (setq end-char-1 (match-beginning 0))
 166           (forward-line)
 167           (setq end-char (point))
 168           (when (cond
 169                  ((eq type 'binhex)
 170                   (setq file-name
 171                         (ignore-errors
 172                           (binhex-decode-region start-char end-char t))))
 173                  ((eq type 'forward)
 174                   (save-excursion
 175                     (goto-char start-char-1)
 176                     (looking-at "[\r\n]*[a-zA-Z][a-zA-Z0-9-]*:")))
 177                  (t t))
 178             (if (> start-char text-start)
 179                 (push
 180                  (mm-make-handle (mm-uu-copy-to-buffer text-start start-char)
 181                                  text-plain-type)
 182                  result))
 183             (push
 184              (cond
 185               ((eq type 'postscript)
 186                (mm-make-handle (mm-uu-copy-to-buffer start-char end-char)
 187                                '("application/postscript")))
 188               ((eq type 'forward)
 189                (mm-make-handle (mm-uu-copy-to-buffer start-char-1 end-char-1)
 190                                '("message/rfc822" (charset . gnus-decoded))))
 191               ((eq type 'uu)
 192                (mm-make-handle (mm-uu-copy-to-buffer start-char end-char)
 193                                (list (or (and file-name
 194                                               (string-match "\\.[^\\.]+$"
 195                                                             file-name)
 196                                               (mailcap-extension-to-mime
 197                                                (match-string 0 file-name)))
 198                                          "application/octet-stream"))
 199                                'x-uuencode nil
 200                                (if (and file-name (not (equal file-name "")))
 201                                    (list mm-dissect-disposition
 202                                          (cons 'filename file-name)))))
 203               ((eq type 'binhex)
 204                (mm-make-handle (mm-uu-copy-to-buffer start-char end-char)
 205                                (list (or (and file-name
 206                                               (string-match "\\.[^\\.]+$" file-name)
 207                                               (mailcap-extension-to-mime
 208                                                (match-string 0 file-name)))
 209                                          "application/octet-stream"))
 210                                'x-binhex nil
 211                                (if (and file-name (not (equal file-name "")))
 212                                    (list mm-dissect-disposition
 213                                          (cons 'filename file-name)))))
 214               ((eq type 'shar)
 215                (mm-make-handle (mm-uu-copy-to-buffer start-char end-char)
 216                                '("application/x-shar"))))
 217              result)
 218             (setq text-start end-char))))
 219       (when result
 220         (if (> (point-max) (1+ text-start))
 221             (push
 222              (mm-make-handle (mm-uu-copy-to-buffer text-start (point-max))
 223                              text-plain-type)
 224              result))
 225         (setq result (cons "multipart/mixed" (nreverse result))))
 226       result)))
 227
 228 ;;;###autoload
 229 (defun mm-uu-test ()
 230   "Check whether the current buffer contains uu stuff."
 231   (save-excursion
 232     (goto-char (point-min))
 233     (let (type end-line result
 234                (case-fold-search t))
 235       (while (and mm-uu-begin-line
 236                   (not result) (re-search-forward mm-uu-begin-line nil t))
 237         (forward-line)
 238         (setq type (cdr (assq (aref (match-string 0) 0)
 239                               mm-uu-identifier-alist)))
 240         (setq end-line (symbol-value
 241                         (intern (concat "mm-uu-" (symbol-name type)
 242                                         "-end-line"))))
 243         (if (and (re-search-forward end-line nil t)
 244                  (not (eq (match-beginning 0) (match-end 0))))
 245             (setq result t)))
 246       result)))
 247
 248 (provide 'mm-uu)
 249
 250 ;;; mm-uu.el ends here