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