cgit.sxemacs.org Git - gnus/blob - lisp/spam-wash.el

   1 ;;; spam-wash.el --- wash spam before analysis
   2
   3 ;; Copyright (C) 2004, 2007, 2008  Free Software Foundation, Inc.
   4
   5 ;; Author: Andrew Cohen <cohen@andy.bu.edu>
   6 ;; Keywords: mail
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 3, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  23 ;; Boston, MA 02110-1301, USA.
  24
  25 ;;; Commentary:
  26
  27 ;; This library decodes MIME encodings such as base64 and
  28 ;; quoted-printable to allow for better spam analysis.
  29 ;;
  30 ;; `spam-wash' should be called in a buffer containing the message.
  31
  32 ;;; Code:
  33
  34 (require 'gnus-art)
  35
  36 (defun spam-wash ()
  37   "Treat the current buffer prior to spam analysis."
  38   (interactive)
  39   (run-hooks 'gnus-article-decode-hook)
  40   (save-excursion
  41     (save-restriction
  42       (let* ((buffer-read-only  nil)
  43              (gnus-inhibit-treatment t)
  44              (gnus-article-buffer (current-buffer))
  45              (handles (or (mm-dissect-buffer nil gnus-article-loose-mime)
  46                           (and gnus-article-emulate-mime
  47                                (mm-uu-dissect))))
  48              handle)
  49           (when gnus-article-mime-handles
  50             (mm-destroy-parts gnus-article-mime-handles)
  51             (setq gnus-article-mime-handle-alist nil))
  52           (setq gnus-article-mime-handles handles)
  53           (when (and handles
  54                    (or (not (stringp (car handles)))
  55                        (cdr handles)))
  56                 (article-goto-body)
  57                 (delete-region (point) (point-max))
  58                 (spam-treat-parts handles))))))
  59
  60 (defun spam-treat-parts (handle)
  61   (if (stringp (car handle))
  62       (mapcar 'spam-treat-parts (cdr handle))
  63     (if (bufferp (car handle))
  64         (save-restriction
  65           (narrow-to-region (point) (point))
  66         (when (let ((case-fold-search t))
  67                 (string-match "text" (car (mm-handle-type handle))))
  68           (mm-insert-part handle))
  69           (goto-char (point-max)))
  70       (mapcar 'spam-treat-parts handle))))
  71
  72 (provide 'spam-wash)
  73
  74 ;; arch-tag: 3c7f94a7-c96d-4c77-bb59-950df12bc85f
  75 ;;; spam-wash.el ends here