;;; vm-advices.el --- misc patches to VM using defadvice

;; Copyright (C) 1994, 95, 96, 97, 98, 99, 00, 2001 Noah S. Friedman

;; Author: Noah Friedman <friedman@splode.com>
;; Maintainer: friedman@splode.com

;; $Id: vm-advices.el,v 1.9 2004/02/14 22:51:54 friedman Exp $

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, you can either send email to this
;; program's maintainer or write to: The Free Software Foundation,
;; Inc.; 59 Temple Place, Suite 330; Boston, MA 02111-1307, USA.

;;; Commentary:

;; These patches cannot be autoloaded.
;; To use, require it in ~/.vm.

;;; Code:

(require 'advice)
(require 'vm-addons)
(require 'win-disp-util)


(defadvice vm-decode-mime-message (around fixup-final-boundary activate)
  "Handle missing final mime boundary from noncompliant MUAs."
  (interactive)
  (condition-case err
      ad-do-it
    (error
     (cond
      ((and (stringp (nth 1 err))
            (save-match-data
              (string-match "^Invalid MIME message: final.*boundary missing$"
                            (nth 1 err))))
       (vma-mime-add-final-boundary)
       ad-do-it)
      (t
       (signal (car err) (cdr err)))))))

(defadvice vm-display-buffer (around no-switch-if-displayed activate)
  "Do not switch buffer of selected window if BUFFER is already displayed
in another window."
  (unless (wdu-buffer-window (ad-get-arg 0) nil 'visible)
    ad-do-it))

;; I found that I first needed this in vm 6.68.  Prior to that, this error
;; was caught by the advice around vm-decode-mime-message.
(defadvice vm-mime-parse-entity (around fixup-final-boundary activate)
  "If missing final mime boundary is detected, add one and reparse."
  (condition-case err
      ad-do-it
    (vm-mime-error
     (cond
      ((save-match-data
         (string-match "^final .* boundary missing$" (nth 1 err)))
       (save-excursion
         (save-window-excursion
           (vma-mime-add-final-boundary)))
       ad-do-it)))))


(defadvice vm-forward-message (around prefix-select-type activate)
  "With prefix arg, select a digest type for the forwarded message."
  (let ((vm-forwarding-digest-type vm-forwarding-digest-type))
    (and current-prefix-arg
         (setq vm-forwarding-digest-type
               (vma-read-forward-type "Forwarding using digest type")))
    ad-do-it))

(defadvice vm-make-presentation-copy (around vma-presentation-ro activate)
  "Inhibit read-only text properties while this function is running."
  (let ((inhibit-read-only t))
    ad-do-it))

;; The original definition will signal an error in Emacs 20 because
;; (match-beginning n) for unmatched values of n will signal an error;
;; VM assumes it will return nil, as it did in Emacs 19.
;;
;; Is this alternate definition correct?
;;
;;      (mapcar #'(lambda (n) (if (markerp n) (marker-position n) n))
;;              (match-data))
;;
;; Not sure if it does the right thing about strings vs. buffer offsets.
(defadvice vm-match-data (around safe-match-data activate)
  "Work safely in Emacs 20."
  (let ((n (/ (length (match-data)) 2))
        (list nil))
    (while (>= n 0)
      (setq list (cons (match-beginning n)
                       (cons (match-end n) list))
            n (1- n)))
    (setq ad-return-value list)))

(defadvice vm-mime-can-display-internal (around html-always activate)
  "Always return t for text/html.

In VM 6.92 it appears that, because `vm-mime-can-display-internal' returns
nil for type text/html when w3.el is not loaded, vm will never create
buttons for those attachments so that you can save them to disk, etc.

It seems to be sufficient for this function to return t always because
`vm-mime-display-internal-text/html' already does its own checking."
  (if (vm-mime-types-match "text/html"
                           (car (vm-mm-layout-type (ad-get-arg 0))))
      (setq ad-return-value t)
    ad-do-it))

(defadvice vm-mime-display-internal-text/html (around protect-env activate)
  "VM 6.58 and later inlines the formatting of html in the current buffer,
which upsets some buffer-local settings because of w3-3.0.86's
implementation of w3-region.  Later versions may behave this way too."
  (let ((inhibit-read-only t)
        (fill-column fill-column)
        (fill-prefix fill-prefix)
        (filladapt-mode filladapt-mode)
        ;; Don't let w3 disable undo in this buffer.
        (buffer-undo-list buffer-undo-list))
    ad-do-it))

(defadvice vm-mime-display-internal-text/html (around no-w3-delay activate)
  "Do not insert a 2-second delay if w3.el is not loaded."
  (if (fboundp 'w3-region)
      ad-do-it
    (setq ad-return-value nil)))

;; MUAs which set "Content-Type: text" are wrong, I think.  But I've seen
;; enough of these to be irritated by them.
(defadvice vm-mime-get-header-contents (after fixup-text-content-type activate)
  "If Content-Type is mangled as just \"text\", return \"text/plain\" instead."
  (and (string= (ad-get-arg 0) "Content-Type:")
       (string= ad-return-value "text")
       (setq ad-return-value "text/plain")))

(defadvice vm-mime-insert-button (around read-only-props-can-blow-me activate)
  "Inhibit read-only text properties while this function is running."
  (let ((inhibit-read-only t))
    ad-do-it))

;; As of vm 7.18, presentation mode will not be used unless both
;; vm-display-using-mime and vm-auto-decode-mime-messages are non-nil;
;; unfortunately that means messages which display in a presentation buffer
;; are also automatically decoded as soon as they're presented, which is
;; not always what I want.
(defadvice vm-preview-current-message (around mimehack activate)
  (let ((vm-auto-decode-mime-messages t))
    ad-do-it))

;; Undo substitution of leading zeros for whitespace in date.
;; Early versions of VM had a different date parsing mechanism.
;; I don't know exactly what version started using vm-su-do-date, but
;; this handles version 5.72 through 6.31, and possibly later.
(defadvice vm-su-monthday (after fixup-whitespace activate)
  (let ((s ad-return-value))
    (cond ((null s))
          ((zerop (length s)))
          ((= ?\  (aref s 0))
           (aset s 0 ?0))
          ;; This can happen in vm 6.x
          ((= (length s) 1)
           (setq s (make-string 2 (aref s 0)))
           (aset s 0 ?0)))
    (setq ad-return-value s)))

(provide 'vm-advices)

;;; vm-advices.el ends here.