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

;; Author: Noah Friedman <friedman@splode.com>
;; Created: 1994
;; Public domain

;; $Id: vm-advices.el,v 1.12 2019/05/12 04:51:27 friedman Exp $

;;; Commentary:
;;; Code:

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


(defadvice vm-decode-mime-message (around vm-adv:fixup-final-boundary disable)
  "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 vm-adv: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 vm-adv:fixup-final-boundary disable)
  "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 vm-adv: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 vm-adv:presentation-inhibit-ro disable)
  "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 vm-adv:safe-match-data disable)
  "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)))

;; 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 vm-adv:fixup-text-content-type disable)
  "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 vm-adv:read-only-props-can-blow-me disable)
  "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 vm-adv:mimehack disable)
  (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 vm-adv: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)))

(defadvice vm-make-multibyte-work-buffer (after sinit:set-multibyte activate)
    (with-current-buffer ad-return-value
      (set-buffer-multibyte t)))

(defadvice vm-make-work-buffer (after sinit:unset-multibyte activate)
    (with-current-buffer ad-return-value
      (set-buffer-multibyte nil)))

(provide 'vm-advices)

;;; vm-advices.el ends here.