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 ;; Needs to come after mm-uu-configure.
 115 (defcustom mm-uu-configure-list nil
 116   "Alist of mm-uu configurations to disable.
 117 To disable dissecting shar codes, for instance, add
 118 `(shar . disabled)' to this list."
 119   :type '(repeat (choice (const :tag "postscript" (postscript . disabled))
 120                          (const :tag "uu" (uu . disabled))
 121                          (const :tag "binhax" (binhex . disabled))
 122                          (const :tag "shar" (shar . disabled))
 123                          (const :tag "forward" (forward . disabled))))
 124   :group 'gnus-article-mime
 125   :set 'mm-uu-configure)
 126
 127 (mm-uu-configure)
 128
 129 ;;;### autoload
 130
 131 (defun mm-uu-dissect ()
 132   "Dissect the current buffer and return a list of uu handles."
 133   (let (text-start start-char end-char
 134                    type file-name end-line result text-plain-type
 135                    start-char-1 end-char-1
 136                    (case-fold-search t))
 137     (save-excursion
 138       (save-restriction
 139         (mail-narrow-to-head)
 140         (goto-char (point-max)))
 141       (forward-line)
 142       ;;; gnus-decoded is a fake charset, which means no further
 143       ;;; decoding.
 144       (setq text-start (point)
 145             text-plain-type '("text/plain"  (charset . gnus-decoded)))
 146       (while (re-search-forward mm-uu-begin-line nil t)
 147         (setq start-char (match-beginning 0))
 148         (setq type (cdr (assq (aref (match-string 0) 0)
 149                               mm-uu-identifier-alist)))
 150         (setq file-name
 151               (if (and (eq type 'uu)
 152                        (looking-at "\\(.+\\)$"))
 153                   (and (match-string 1)
 154                        (let ((nnheader-file-name-translation-alist
 155                               '((?/ . ?,) (? . ?_) (?* . ?_) (?$ . ?_))))
 156                          (nnheader-translate-file-chars (match-string 1))))))
 157         (forward-line);; in case of failure
 158         (setq start-char-1 (point))
 159         (setq end-line (symbol-value
 160                         (intern (concat "mm-uu-" (symbol-name type)
 161                                         "-end-line"))))
 162         (when (and (re-search-forward end-line nil t)
 163                    (not (eq (match-beginning 0) (match-end 0))))
 164           (setq end-char-1 (match-beginning 0))
 165           (forward-line)
 166           (setq end-char (point))
 167           (when (cond
 168                  ((eq type 'binhex)
 169                   (setq file-name
 170                         (ignore-errors
 171                           (binhex-decode-region start-char end-char t))))
 172                  ((eq type 'forward)
 173                   (save-excursion
 174                     (goto-char start-char-1)
 175                     (looking-at "[\r\n]*[a-zA-Z][a-zA-Z0-9-]*:")))
 176                  (t t))
 177             (if (> start-char text-start)
 178                 (push
 179                  (mm-make-handle (mm-uu-copy-to-buffer text-start start-char)
 180                                  text-plain-type)
 181                  result))
 182             (push
 183              (cond
 184               ((eq type 'postscript)
 185                (mm-make-handle (mm-uu-copy-to-buffer start-char end-char)
 186                                '("application/postscript")))
 187               ((eq type 'forward)
 188                (mm-make-handle (mm-uu-copy-to-buffer start-char-1 end-char-1)
 189                                '("message/rfc822" (charset . gnus-decoded))))
 190               ((eq type 'uu)
 191                (mm-make-handle (mm-uu-copy-to-buffer start-char end-char)
 192                                (list (or (and file-name
 193                                               (string-match "\\.[^\\.]+$"
 194                                                             file-name)
 195                                               (mailcap-extension-to-mime
 196                                                (match-string 0 file-name)))
 197                                          "application/octet-stream"))
 198                                'x-uuencode nil
 199                                (if (and file-name (not (equal file-name "")))
 200                                    (list mm-dissect-disposition
 201                                          (cons 'filename file-name)))))
 202               ((eq type 'binhex)
 203                (mm-make-handle (mm-uu-copy-to-buffer start-char end-char)
 204                                (list (or (and file-name
 205                                               (string-match "\\.[^\\.]+$" file-name)
 206                                               (mailcap-extension-to-mime
 207                                                (match-string 0 file-name)))
 208                                          "application/octet-stream"))
 209                                'x-binhex nil
 210                                (if (and file-name (not (equal file-name "")))
 211                                    (list mm-dissect-disposition
 212                                          (cons 'filename file-name)))))
 213               ((eq type 'shar)
 214                (mm-make-handle (mm-uu-copy-to-buffer start-char end-char)
 215                                '("application/x-shar"))))
 216              result)
 217             (setq text-start end-char))))
 218       (when result
 219         (if (> (point-max) (1+ text-start))
 220             (push
 221              (mm-make-handle (mm-uu-copy-to-buffer text-start (point-max))
 222                              text-plain-type)
 223              result))
 224         (setq result (cons "multipart/mixed" (nreverse result))))
 225       result)))
 226
 227 ;;;### autoload
 228 (defun mm-uu-test ()
 229   "Check whether the current buffer contains uu stuff."
 230   (save-excursion
 231     (goto-char (point-min))
 232     (let (type end-line result
 233                (case-fold-search t))
 234       (while (and mm-uu-begin-line
 235                   (not result) (re-search-forward mm-uu-begin-line nil t))
 236         (forward-line)
 237         (setq type (cdr (assq (aref (match-string 0) 0)
 238                               mm-uu-identifier-alist)))
 239         (setq end-line (symbol-value
 240                         (intern (concat "mm-uu-" (symbol-name type)
 241                                         "-end-line"))))
 242         (if (and (re-search-forward end-line nil t)
 243                  (not (eq (match-beginning 0) (match-end 0))))
 244             (setq result t)))
 245       result)))
 246
 247 (provide 'mm-uu)
 248
 249 ;;; mm-uu.el ends here