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