code.delx.au - gnu-emacs/blob - lisp/gnus/mm-uu.el

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