;; -*- emacs-lisp -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; $Id: gnus_message.el,v 1.21 2006-11-06 21:02:42 rscholz Exp $
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Einstellungen für den Message Mode und MIME
;;
;; Die offizielle Quelle dieser Datei ist
;;   <http://www.zonix.de/projects/emacs/config>
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Verhalten beim Senden / Nachfragen (Info-goto-node "(Message)Variables")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; SMTP-Dialog bei Fehlern
(setq message-interactive t)

;; CC's bestätigen lassen
(setq message-wide-reply-confirm-recipients t)

;; Buffer mit geschriebener Mail / News nach Senden löschen
(setq message-kill-buffer-on-exit t)

;; kein Envelope-From durch Gnus setzen
(setq message-sendmail-f-is-evil t)

;; leere Artikel posten können
(setq message-shoot-gnksa-feet '(empty-article))

;; C-a setzt den Cursor an den Anfang der Zeile, nicht an den Anfang
;; des Header-Inhalts (ab Gnus 5.10)
(setq message-beginning-of-line nil)

;; Keine Mails aufsplitten, wenn sie zu groß werden.  Einige MUA haben
;; Probleme, diese mit vernünftigem Aufwand wieder zusammenzusetzen.
(setq message-send-mail-partially-limit nil)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Header
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Header beim Erstellen verstecken
(setq message-hidden-headers '("^X-Face" "^References" "^X-Draft-From"))

;(setq message-hidden-headers
;      '(not "^From" "^Subject" "^To" "^Cc" "^Newsgroups"))

;; User-Agent anpassen (ab Gnus 5.10)
;(setq gnus-user-agent 'gnus)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Mail-Followup-To           (Info-goto-node "(Message)Mailing Lists")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Mail-Followup-To-Header setzen  (ab Gnus 5.10)
(setq message-subscribed-address-functions
      '(gnus-find-subscribed-addresses))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Encoding
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; 8bit-Codierung erzwingen
(add-to-list 'mm-body-charset-encoding-alist '(iso-8859-1 . 8bit))

(if (mm-coding-system-p 'iso-8859-15)
    (add-to-list 'mm-body-charset-encoding-alist '(iso-8859-15 . 8bit)))

;; QP-Codierung für UTF-8 erzwingen
(if (mm-coding-system-p 'utf-8)
    (add-to-list 'mm-body-charset-encoding-alist '(utf-8 . quoted-printable)))

;; dito, aber Unterscheidung von Mail und News bzw. für bestimmte
;; Gruppen (obige Definition muss dann auskommentiert werden)
;(add-to-list 'gnus-group-posting-charset-alist
;             '(message-this-is-mail nil (iso-8859-1)))
;(add-to-list 'gnus-group-posting-charset-alist
;             '(message-this-is-news nil (iso-8859-1)))

;; generelle QP-Codierung und sonst auch sichere Codierung erzwingen
;(setq mm-use-ultra-safe-encoding t)

;; bei mehr als einer möglichen Kodierung beachten
(setq mm-coding-system-priorities
      '(iso-latin-1 iso-latin-9 windows-1252 mule-utf-8))

;; Kai Grossjohann in <vafofo3ys6j.fsf@lucy.cs.uni-dortmund.de> Nur
;; nötig, falls der von Gnus genutzte (X)Emacs kein iso-8859-15 kennt,
;; dann wird iso-8859-15 als iso-8859-1 dargestellt (besser als nix).
(unless (mm-coding-system-p 'iso-8859-15)
  (require 'mm-util)
  (add-to-list 'mm-charset-synonym-alist
               '(iso-8859-15 . iso-8859-1)))

;; Multipart-Mails gegenüber Unicode-Mails bevorzugen
;;(setq mm-use-find-coding-systems-region nil)

;; Multipart-Mails ohne Nachfrage verschicken
;;(setq mml-confirmation-set '(multipart))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Sender- und Message-ID-Header
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Message-ID selbst basteln
;(defun message-make-message-id ()
;  (concat "<"(message-unique-id)"@" (symbol-value 'mail-host-address) ">"))

;; Message-ID nicht erzeugen (macht dann der News-/Mailserver)
;(setq message-required-news-headers
;      (delq 'Message-ID message-required-news-headers))
;(setq message-required-mail-headers
;      (delq 'Message-ID message-required-mail-headers))

;; Sender:-Header nicht erzeugen
;; fuer Cancel oder Supersede mit Gnus < 5.10 notwendig
(add-to-list 'message-syntax-checks '(sender . disabled))

;; für Message-ID-Generierung
(if (string-match "home" zonix-location)
    (setq mail-host-address "hush.zonix.de")
  (setq mail-host-address system-name))

;; Sender selbst basteln
(defun message-make-sender ()
  (concat (user-login-name) "@" mail-host-address))

(defvar zonix-default-group-name nil
  "Gruppe, die als Default verwendet wird, falls die aktuell
  ausgewählte Gruppe nicht ermittelt werden kann.")

(if (string-match "home" zonix-location)
    (setq zonix-default-group-name "nnimap:INBOX"))

(if (string-match "verified" zonix-location)
    (setq zonix-default-group-name "nnmaildir:INBOX"))

(defun zonix-get-group-name ()
  "Returns the name of the current group (or the group the cursor
  resides on) or the value of `zonix-default-group-name' if the former inquiries failed."
  
  (or (gnus-group-group-name)
      gnus-newsgroup-name
      zonix-default-group-name))

;; Kurzname der Gruppe
(defun zonix-short-group-name ()
  (replace-regexp-in-string
   "\\." ""  (gnus-short-group-name (gnus-group-real-name (zonix-get-group-name)) 0)))

;; Message-ID selbst basteln, so dass der Kurzname der Gruppe
;; eingebaut wird.
(defun message-make-message-id ()
  (concat "<" (zonix-short-group-name) "." (message-unique-id) "@"
          (message-make-fqdn) ">"))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Zitieren
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Signatur nicht mitzitieren
(setq message-cite-function 'message-cite-original-without-signature)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Faces
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(set-face-foreground 'message-cited-text-face "DarkSlateBlue")
(set-face-foreground 'message-header-subject-face "firebrick")
(set-face-foreground 'message-header-to-face "MidnightBlue")
(set-face-foreground 'message-header-other-face "DarkGreen")

(modify-face 'message-header-cc-face "DarkGreen" nil nil t nil nil)   
(modify-face 'message-header-name-face "DarkGreen" nil nil t nil nil)   
(modify-face 'message-mml-face "Black" nil nil t nil nil)   


;; Zitierebenen wie im Article Buffer farblich unterscheiden
;; Oliver Scholz in <uk7c8o8bz.fsf@ID-87814.user.dfncis.de>

(eval-when-compile
  (require 'gnus-cite)
  (require 'message))

(defconst egoge-max-citation-depth
  (eval-when-compile
    (length gnus-cite-face-list))
  "Maximum supported level of citation.")

(defun egoge-search-citation-line (limit)
  "Search for a cited line and set match data accordingly.
Returns nil if there is no such line before LIMIT, t otherwise."
  (when (re-search-forward (eval-when-compile
                             (concat "^\\(?:"
                                     message-cite-prefix-regexp
                                     "\\)"))
                           limit t)
    (let ((cdepth
           (length (apply 'concat 
                          (split-string 
                           (match-string-no-properties 0)
                           "[ \t [:alnum:]]+"))))
          (mlist (make-list (* (1+ egoge-max-citation-depth)
                               2)
                            0)))
      (setcar (nthcdr (* cdepth 2) mlist)
              (line-beginning-position))
      (setcar (nthcdr (1+ (* cdepth 2)) mlist)
              (line-end-position))
      (set-match-data mlist))
    t))

(defvar egoge-citation-x-keywords
  (eval-when-compile
    `((egoge-search-citation-line
       ,@(let ((list nil)
               (count 1))
           (require 'gnus-cite)
           (dolist (face gnus-cite-face-list (nreverse list))
             (push (list count (list 'quote face) 'prepend) list)
             (setq count (1+ count)))))))
  "Keywords for highlighting different levels of message citations.")
                 
(defun egoge-add-citation-keywords ()
  "Add font-lock for nested citations to current buffer."
  (font-lock-add-keywords nil egoge-citation-x-keywords))

(defun egoge-remove-citation-keywords ()
  "Remove font-lock for nested citations from current buffer."
  (font-lock-remove-keywords nil egoge-citation-x-keywords))

(define-minor-mode egoge-citation-x-mode
  "Toggle egoge-citation-x-mode' in current buffer.
This buffer local minor mode provides additional font-lock support for
nested citations.
With prefix ARG, turn `egoge-citation-x-mode' on if and only if ARG is
positive." 
  nil "" nil
  (if egoge-citation-x-mode
      (egoge-add-citation-keywords)
    (egoge-remove-citation-keywords))
  (font-lock-fontify-buffer))
      
(defun egoge-turn-on-citation-x ()
  "Turn on `egoge-citation-x-mode'."
  (egoge-citation-x-mode 1))

(add-hook 'message-mode-hook 'egoge-turn-on-citation-x)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Nützliche Funktionen
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Einleitung mit * vor dem Namen
(defun zonix-citation-line ()
  (insert "* " (mail-header-from message-reply-headers) " wrote:\n\n"))

;(setq message-citation-line-function 'zonix-citation-line)

;; Einleitung mit Datum, wenn älter als 3 Tage und nicht länger
;; als 72 Zeichen, sonst wie oben.
;; Daniel Zimmermann in <adcvs7z2.fsf@dzimmerm.myfqdn.de>, leicht
;; modifiziert.
(defun dz/zonix-my-citation-line ()
  (let* ((from (mail-header-from message-reply-headers))
         (name (or (car (gnus-extract-address-components from))
                   from))
         (posting-time (date-to-time
                        (mail-header-date message-reply-headers)))
         (posting-time-for-citation (format-time-string "%b %d %Y"
                                                        posting-time)))
    (cond
     ((and (> (- (time-to-days (current-time))
                 (time-to-days posting-time))
              3)
           (< (length (concat "· On "
                              posting-time-for-citation
                              ", " from " wrote:"))
                72))
      (insert "· On " posting-time-for-citation ", " from " wrote:\n\n"))
     ((< (length (concat "* " from " wrote:")) 72)
      (insert "· " from " wrote:\n\n"))
     (t
      (insert "· " name " wrote:\n\n")))))

(setq message-citation-line-function 'dz/zonix-my-citation-line)

;; deutschsprachige Einleitung
(defun zonix-message-insert-citation-line-de ()
  "Function that inserts a simple citation line. German Version"
  (when message-reply-headers
    (insert (mail-header-from message-reply-headers) " schrieb:\n\n")))
;(setq message-citation-line-function 'zonix-message-insert-citation-line-de)

;; englische Einleitung mit Datum
;; Bill White in <m3zo3zrjz8.fsf@wolfram.com>
(defun bw-message-insert-citation-line-en-date ()
  "Function that inserts a simple citation line."
  (when message-reply-headers
    (insert
     "On "
     (format-time-string "%a %b %d %Y at %R"
      (gnus-date-get-time (mail-header-date message-reply-headers)))
     ", "
     (mail-header-from message-reply-headers)
     " wrote:\n\n")))
;(setq message-citation-line-function 'bw-message-insert-citation-line-en-date)

;; Christoph Garbers in <yw.dcsn.87puatmidv.fsf@gabsi.garbers.org>
(defun cg-citation-line ()
  "Function that inserts svengo a cool citation line."
  (when message-reply-headers
    (insert "* Quoting " (mail-header-from message-reply-headers) ":\n\n")))
;(setq message-citation-line-function 'cg-citation-line)

;; Dirk Meyer in <xt4bskxvbng.fsf@riemen.informatik.uni-bremen.de>
(defun dischi-message-generate-headers-and-save ()
  (interactive)
  (message-generate-headers
   (if (message-news-p)
       message-required-news-headers
     message-required-mail-headers))
  (save-buffer))

(define-key message-mode-map "\C-x\C-h" 'dischi-message-generate-headers-and-save)

;; leere Header beim Senden entfernen
;; Matthias Wiehl in <9hphkb$80v$1@fulmine.dhs.org>
;; modifiziert, so dass X-Header stehen bleiben (z.B. für nndiary)
(defun svengo-message-strip-empty-headers ()
  (message-narrow-to-headers)
  (while (not (eobp))
    (while (looking-at "[^X][^:]*:[ ]*$")
      (message-delete-line))
    (forward-line 1))
  (widen))

(add-hook 'message-send-hook 'svengo-message-strip-empty-headers)

;; Abbrevs im Message-Mode verwenden
(add-hook 'message-mode-hook 'abbrev-mode)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; besonders schöne Attribution
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Matthias Wiehl in <878zmt3rz8.fsf@fulmine.dhs.org>
(defun my-citation-format-date-string (date)
  "Convert a Date header value to `dd.mm.yyyy' format."
  (let ((time (date-to-time date)))
    (format-time-string "%d.%m.%Y" time)))

;; better use gnus-extract-address-components?
(defun my-citation-extract-sender-name (from)
  "Extract the sender's name from FROM."
  ;; We use `mail-extract-address-components' from the mail-lib
  ;; package to fetch the sender's name.
  (let ((names (mail-extract-address-components from)))
    (if names
        ;; If `mail-extr-ignore-single-names' is set to t, (car names)
        ;; will be nil if the sender of the message you're responding
        ;; to didn't provide a full name.  In that case, the second
        ;; string will be returned.
        (or (car names)
            (if (message-news-p)
                "Ein Realnamenloser"
              nil)))))

(defun my-insert-citation-line ()
  "Insert a citation line that includes the original article's date."
  (when message-reply-headers
    (let ((from (my-citation-extract-sender-name
                 (mail-header-from message-reply-headers)))
          (date (my-citation-format-date-string
                 (mail-header-date message-reply-headers)))
          (groups (message-fetch-reply-field "newsgroups")))
      ;; In mail messages, we want to use a somewhat personal
      ;; introduction.
      (if (message-mail-p)
          (insert "Hallo"
                  ;; Insert the name of the person you're replying to.
                  (if from
                      (concat " " from)
                    "")
                  ",\n\n" "am " date " schriebst Du"
                  ;; Include the name of the newsgroup which the
                  ;; original message was posted to.
                  (if groups
                      (progn
                        ;; Shorten `groups' if necessary.
                        (if (string-match "\\(,\\)" groups)
                            (setq groups
                                  (concat
                                   (substring groups 0 (match-beginning 0))
                                   " et al.")))
                        (concat " in " groups))
                    "")
                  ":\n\n")
        ;; This is for news messages.
        (insert from " schrieb am " date ":\n\n")))))

;(setq mail-extr-ignore-single-names t)
;(setq message-citation-line-function 'my-insert-citation-line)

;; http://www.tuxedo.org/~esr/jargon/html/entry/September-that-never-ended.html
(require 'time-date) ;; part of Gnus
(defun september-citation-line ()
  (when message-reply-headers
    (insert "On "
            (int-to-string
             (-
              (time-to-days (mail-header-parse-date
                             (mail-header-date message-reply-headers)))
              (time-to-days (encode-time 0 0 0 31 08 1993))))
            " September 1993, "
            (let* ((email (mail-header-from message-reply-headers))
                   (data (mail-extract-address-components email))
                   (name (car data))
                   (net (car (cdr data))))
              (or name net email))
            " wrote:\n")))

;(setq message-citation-line-function 'september-citation-line)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Quoting-Ratio berechnen
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Matthias Wiehl in <hhlmi5zvpx.fsf@fulmine.dhs.org>

(defun mw-determine-quote-ratio (start end)
  "Print number of cited lines in the region."
  (interactive "r")
  (save-excursion
    (save-restriction
      (narrow-to-region start end)
      (goto-char (point-min))
      (let ((done 0) (cited 0))
        (if (looking-at message-cite-prefix-regexp)
            (setq cited (1+ cited))
        (while (re-search-forward "[\n\C-m]" nil t 1)
          (setq done (1+ done))
          (if (looking-at message-cite-prefix-regexp)
              (setq cited (1+ cited))))
        (goto-char (point-max))
        (if (and (/= start end)
                 (not (bolp)))
            (setq done (1+ done)))
        (message "%d cited lines, %d total" cited done))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; vi zum Editieren nutzen (örks...)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Daniel Pittman in ding (<87ofms2jhp.fsf@inanna.rimspace.net>)
(defun edit-buffer-in-vi ()
  "Put the content of the buffer into an external file and invoke VI on it."
  (let ((filename (expand-file-name (make-temp-name "silly.vi.user.") "~/"))
        (message  (current-buffer)))
    (with-temp-buffer filename
                      (insert (buffer-string message)))
    (let ((editor (start-process-shell-command "message editor"
                                               nil ; no associated buffer...
                                               "xterm"
                                               "-e"
                                               "vim"
                                               filename)))
      (cons editor filename))))

(defun edit-buffer-in-vi-make-closure (buffer filename)
  "Restore the content of buffer from filename when invoked."
  (let ((buffer-name (buffer-name buffer))) ; Oh for closures...
    `(lambda ()
      (let ((buffer (get-buffer ,buffer-name)))
        (when buffer
          (with-current-buffer buffer
            (erase-buffer)
            (insert-file-contents ,filename)))))))
  
;; (add-hook 'message-setup-hook                ; am I the right hook?
;;        (lambda ()
;;          "Invoke an external editor on the content of this buffer..."
;;          (let ((result (edit-buffer-in-vi)))
;;            (set-process-sentinel
;;             (car result)
;;             (edit-buffer-in-vi-make-closure (current-buffer) (cdr result))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; alternatives nowplaying-Feld mit Abfrage
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Holger Schauer in <whwv313jdl.fsf_-_@ipanema.coling.uni-freiburg.de>
(defun insert-np-field ()
  "Call external program `xmms_np' to insert an now-playing line into a buffer,
based on what `xmms' is currently playing."
  (interactive)
  (save-excursion
    (let ((old-point (point))
          (npstring ""))
    ;; try to position cursor in front of signature,
    ;; otherwise stay where we are. 
    (if (message-goto-signature)
        (previous-line 2)
      (goto-char old-point))      
    ;; insert np:-line
    (newline)
    (insert "np: ")
    (shell-command "xmms_np" t)
    (when (string-equal "np: " 
                        (buffer-substring (point-at-bol) (point-at-eol)))
      (setq npstring (read-from-minibuffer "Now playing: "))
      (cond ((string-equal npstring "")
             (undo 0)) ; remove insertion of "np: "
            (t
             (insert npstring)))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Überprüfung auf X-Post _vor_ dem Schreiben eines Artikels
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Reiner Steib in <v9zndpt93b.fsf@marauder.physik.uni-ulm.de>
(defun rs-message-check-crosspost ()
  "Check for crosspost _before_ composing a message."
  ;; Code is borrowed from `message-check-news-header-syntax'.
  (let ((newsgroups (message-fetch-field "newsgroups"))
        (followup-to (message-fetch-field "followup-to"))
        to)
    (when (and newsgroups
               (string-match "," newsgroups)
               (not followup-to)
               (y-or-n-p "Insert Followup-To header now? ")
               (not
                (zerop
                 (length
                  (setq to (completing-read
                            "Followups to (default: no Followup-To header) "
                            (mapcar #'list
                                    (cons "poster"
                                          (message-tokenize-header
                                           newsgroups)))))))))
      (message-position-on-field "Followup-To" "Newsgroups")
      (insert "Followup-To: " to))))

;; Add it to a suitable hook:
;(add-hook 'message-setup-hook 'rs-message-check-crosspost)