u-appt.el 0.3

[Ulf Jasper]

u-appt.el provides commands for extracting appointments from a buffer,
converting them and adding them to an Emacs diary file.  

This version recognizes Norwegian Outlook (i.e. US Outlook with Norwegian
locale) -- code by Steinar Bang.

Enjoy

 ulf

;;; u-appt.el --- Appointment parser

;;  Copyright (C) 2002, 2004 by Ulf Jasper

;;  Author:     Ulf Jasper <address@hidden>
;;  Keywords:   diary calendar outlook lotus
;;  Time-stamp: "16. Oktober 2004, 16:36:22 (ulf)"
;;  Version:    0.3
;;  CVS:        $Id: u-appt.el,v 2.12 2004/10/16 14:37:12 ulf 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 of the License, 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, write to the Free Software Foundation, Inc.,
;;  59 Temple Place, Suite 330, Boston, MA 02111-1307 USA

;; ======================================================================
;;; Commentary:

;;  This package contains commands for extracting appointments from a
;;  buffer, converting them and adding them to an Emacs diary file.  If
;;  an appointment is found, you will be asked, whether you want to add
;;  it to your diary file.  Currently these commands will recognize
;;  appointments that were sent by

;;  - MS Outlo*k (English, German, Norwegian)
;;  - L*tus N*tes (German only)
;;  - a very proprietary Spanish appointment transmitter

;;  In order to use the commands, add the following to your .emacs file:

;;  (autoload 'u-appt-check-outlook "u-appt" "Check for outlook invitations" t)
;;  (autoload 'u-appt-check-notes "u-appt" "Check for notes invitations" t)

;;  Say `M-x u-appt-check-outlook' whenever you run across an
;;  appointment which you want to add to your diary.

;;  VM users want to put this into their VM config file:

;;   (add-hook 'vm-select-new-message-hook 'u-appt-check-outlook)
;;   (add-hook 'vm-select-new-message-hook 'u-appt-check-notes)

;;  Unfortunately this does not work for mime-encoded messages.  They
;;  are decoded *after* that hook is run.  So you have to call these
;;  functions by hand, or you could use

;;  (defadvice vm-decode-mime-message (after u-appt activate)
;;         (u-appt-check-outlook))
;;  (defadvice vm-decode-mime-message (after u-appt activate)
;;         (u-appt-check-notes))

;;  but that would call the functions each time you look at a
;;  message.  Bad idea.

;;  Gnus users might want to use the following.

;;  (defun my-gnus-check-outlook ()
;;    "Run from a hook to check new messages in Gnus for Outlook appointment 
;;  invitations, and offer to save them in the diary."
;;    (save-excursion
;;      (let ((mark (gnus-summary-article-mark)))
;;        (when (gnus-unread-mark-p mark)
;;       (set-buffer gnus-article-buffer)
;;       (u-appt-check-outlook)))))
;;  (add-hook 'gnus-mark-article-hook 'my-gnus-check-outlook)
;;  ;; Add the original value of gnus-mark-article-hook, since this 
;;  ;; is overwritten by the above add-hook.
;;  ;; Add it at the end, since it sets the mark to read.
;;  (add-hook 'gnus-mark-article-hook
;;  'gnus-summary-mark-read-and-unread-as-read t)

;; ======================================================================
;;; History:

;;  0.3: Norwegian Outlook (i.e. US Outlook with Norwegian locale), from
;;       Steinar Bang (2004-10-09)

;;  0.2: Bugfixes, thanks to Colin Marquardt

;;  0.1: First version

;; ======================================================================
;;; Code:

(require 'appt)
(require 'mailheader)

(defconst u-appt-monthnumber-table
  '(("^jan\\(uar\\)?y?$"          . 1)
    ("^feb\\(ruar\\)?y?$"         . 2)
    ("^mar\\(ch\\|s\\)?\\|märz?$" . 3)
    ("^apr\\(il\\)?$"             . 4)
    ("^ma[iy]$"                   . 5)
    ("^jun[ie]?$"                 . 6)
    ("^jul[iy]?$"                 . 7)
    ("^aug\\(ust\\)?$"            . 8)
    ("^sep\\(tember\\)?$"         . 9)
    ("^o[ck]t\\(ober\\)?$"        . 10)
    ("^nov\\(ember\\)?$"          . 11)
    ("^de[czs]\\(ember\\)?$"      . 12))
  "Regexps for month names.  Currently only German, English, and Norwegian.")

(defun u-appt-handle (subject string)
  "Asks user whether to add an appointment.
SUBJECT is the appointment-subject
STRING is the formatted diary entry"
  (if (y-or-n-p (format "Add appointment for `%s' to diary? " subject))
      (save-window-excursion
        (make-diary-entry string)
        (save-excursion
          (set-buffer (find-buffer-visiting diary-file))
          (save-buffer))
        ;; hmmm... FIXME!
        (if (fboundp 'appt-initialize)
            (appt-initialize))
        (if (fboundp 'appt-activate)
            (appt-activate 1))
        (message "Addded %s to diary" string))))

(defun u-appt-date-string (date &optional abbreviate nodayname)
  "Return properly formatted DATE.
Takes care of optional arguments ABBREVIATE and NODAYNAME."
  (let ((calendar-date-display-form (if european-calendar-style
                                        '(day " " monthname " " year)
                                      '(monthname " " day " " year))))
    (calendar-date-string date abbreviate nodayname)))

(defsubst u-appt-get-month-number (monthname)
  "Return the month number for the given MONTHNAME."
  (save-match-data
    (let ((case-fold-search t))
      (assoc-default monthname u-appt-monthnumber-table 'string-match))))


(defun u-appt-check-outlook (&rest args)
  "Search a buffer for an Outlook-style appointment and add a diary entry.
Optional argument ARGS is unused!"
  (interactive)
  (let (subject day month year time am-pm string type header-list
                (appt-found nil))
    (save-excursion
      (goto-char (point-min))
      (setq header-list (mail-header-extract))
      (when header-list
        (setq subject (mail-header 'subject header-list))
        (setq type    (mail-header 'content-type header-list)))
      (if (or (not type) (not (string-match "message" type)))
          (progn
            (cond (;; German
                   ;; Example:
                   ;; Zeit: Freitag, 6. Dezember 2002 00:07 Stiefel rausstellen!
                   ;; Also seen:
                   ;; When: Freitag, 4. Juni 2004 00:00 Termin!
                   (re-search-forward
                    (concat "^\\(Zeit\\|When\\): [^ ]+, +\\([0-9]+\\)\. +"
                            "\\([A-Z][a-zäöü][äöüa-z]\\)[^ ]* +\\([0-9]+\\) +"
                            "\\([^ ]+\\)\\s-+\\(.*\\)$") nil t)
                   (setq day   (match-string-no-properties 2))
                   (setq month (match-string-no-properties 3))
                   (setq year  (match-string-no-properties 4))
                   (setq time  (match-string-no-properties 5))
                   ;; This is probably NOT the subject:
                   ;;(if (> (length (match-string-no-properties 6)) 0)
                   ;;  (setq subject (match-string-no-properties 6)))
                   (setq string (format "%s %s %s"
                                        (u-appt-date-string
                                         (list (u-appt-get-month-number month)
                                               (string-to-number day)
                                               (string-to-number year)) t t)
                                        time subject))
                   (setq appt-found t))
                  (;; English
                   ;; Example: FIXME
                   (re-search-forward
                    (concat "^\\(Start Date\\):\\s-+\\([0-9]+\\)/\\([0-9]+\\)/"
                            "\\([0-9]+\\)\\s-+"
                            "\\([0-9]+:[0-9]+\\)\\s-*\\([ap]m\\)"
                            "\\(.*\\)$") nil t)
                   (setq
                    month (string-to-number (match-string-no-properties 2))
                    day   (string-to-number (match-string-no-properties 3))
                    year  (string-to-number (match-string-no-properties 4))
                    time  (match-string-no-properties 5)
                    am-pm (match-string-no-properties 6))
                   (if (> (length (match-string-no-properties 7)) 0)
                       (setq subject (match-string-no-properties 7)))
                   (setq string (format "%s %s %s %s"
                                        (u-appt-date-string
                                         (list month day year) t t)
                                        time am-pm subject))
                   (setq appt-found t))
                  (;; US Outlook2003 with Norwegian date setting
                   ;; Example (note linebreak):
                   ;; When: 2. september 2004 10:00-11:30 (GMT+01:00) 
Amsterdam, Berlin, Bern,
                   ;; Rome, Stockholm, Vienna.
                   (re-search-forward
                    (concat "^\\(When\\):\\s-+\\([0-9]+\\)\\.\\s-+"
                            "\\([A-Za-z]+\\)\\s-+"
                            "\\([0-9]+\\)\\s-+"
                            "\\([0-9]+:[0-9]+\\)"
                            "\\(.*\\)$") nil t)
                   (setq
                    day   (match-string-no-properties 2)
                    month (match-string-no-properties 3)
                    year  (match-string-no-properties 4)
                    time  (match-string-no-properties 5))
                   (setq string (format "%s %s %s"
                                        (u-appt-date-string
                                         (list (u-appt-get-month-number month)
                                               (string-to-number day)
                                               (string-to-number year)) t t)
                                        time subject))
                   (setq appt-found t))
                  (;; US Outlook2003 with US long date and no am/pm
                   ;; US long date is dddd, MMMM dd, yyyy
                   ;; Example (note linebreak):
                   ;; When: Monday, October 11, 2004 16:00-16:05 (GMT+01:00) 
Amsterdam, Berlin, Bern,
                   ;; Rome, Stockholm, Vienna.
                   (re-search-forward
                    (concat "^\\(When\\):\\s-+\\([A-Za-z]+\\),\\s-+"
                            "\\([A-Za-z]+\\)\\s-+"
                            "\\([0-9]+\\),\\s-+"
                            "\\([0-9]+\\)\\s-+"
                            "\\([0-9]+:[0-9]+\\)"
                            "\\(.*\\)$") nil t)
                   (setq
                    month (match-string-no-properties 3)
                    day   (match-string-no-properties 4)
                    year  (match-string-no-properties 5)
                    time  (match-string-no-properties 6))
                   (setq string (format "%s %s %s"
                                        (u-appt-date-string
                                         (list (u-appt-get-month-number month)
                                               (string-to-number day)
                                               (string-to-number year)) t t)
                                        time subject))
                   (setq appt-found t))
                  (;; Spanish -- not really outlook but similar
                   ;; Example:
                   ;; Fecha: miércoles 16 de octubre 2002 10:00am  convocatoria
                   (re-search-forward
                    (concat "^\\(Fecha\\): [^ ]+ +\\([0-9]+\\) +[^ ]+ +"
                            "\\([A-Za-z][a-z][a-z]\\)[^ ]* +\\([0-9]+\\) +"
                            "\\([0-9]+:[0-9]+\\)\\s-*\\([ap]m\\)\\s-+"
                            "\\(.*\\)$") nil t)
                   (setq day   (match-string-no-properties 2))
                   (setq month (capitalize (match-string-no-properties 3)))
                   (setq year  (match-string-no-properties 4))
                   (setq time  (match-string-no-properties 5))
                   (setq am-pm (match-string-no-properties 6))
                   (if (> (length (match-string-no-properties 7)) 0)
                       (setq subject (match-string-no-properties 7)))
                   ;; CHECKME: does this work?
                   (setq string (format "%s %s %s"
                                        (u-appt-date-string
                                         (list (u-appt-get-month-number month)
                                               (string-to-number day)
                                               (string-to-number year)) t t)
                                        time subject))
                   ;;(setq string (format "%s %s %s %s%s %s"
                   ;;day month year time am-pm subject))
                   (setq appt-found t))))))
    (when appt-found
      (u-appt-handle subject string))))

(defun u-appt-check-notes (&rest args)
  "Search a buffer for a Lotus-Notes-style appointment and add to diary.
Optional argument ARGS is unused!"
  (interactive)
  (let (subject start-day start-month start-year start-time end-day
                end-month end-year end-time string type header-list
                (appt-found nil)
                (has-end nil))
    (save-excursion
      (goto-char (point-min))
      (setq header-list (mail-header-extract))
      (when header-list
        (setq subject (mail-header 'subject header-list))
        (setq type    (mail-header 'content-type header-list)))
      (when (or (not type) (not (string-match "message" type)))
        (when (re-search-forward "^\\s-*Calendar Entry:\\s-*" nil t)
          (when (re-search-forward
                 (concat "^\\s-*Begins:\\s-+\\([0-9]+\\).\\([0-9]+\\)."
                         "\\([0-9]+\\)\\s-+\\([0-9]+:[0-9]+\\)\\s-*"
                         ".*$") nil t)
            (setq
             start-day   (string-to-number (match-string-no-properties 1))
             start-month (string-to-number (match-string-no-properties 2))
             start-year  (string-to-number (match-string-no-properties 3))
             start-time  (match-string-no-properties 4))
            (setq string (format "%s %s %s"
                                 (u-appt-date-string
                                  (list start-month start-day start-year)
                                  t t)
                                 start-time subject))
            (setq appt-found t))
          (when (re-search-forward
                 (concat "^\\s-*Ends:\\s-+\\([0-9]+\\).\\([0-9]+\\)."
                         "\\([0-9]+\\)\\s-+\\([0-9]+:[0-9]+\\)\\s-*"
                         ".*$") nil t)
            (setq
             end-day   (string-to-number (match-string-no-properties 1))
             end-month (string-to-number (match-string-no-properties 2))
             end-year  (string-to-number (match-string-no-properties 3))
             end-time  (match-string-no-properties 4))
            (if (and (eq start-day end-day)
                     (eq start-month end-month)
                     (eq start-year end-year))
                (setq string (format "%s %s-%s %s"
                                     (u-appt-date-string
                                      (list start-month start-day start-year)
                                      t t)
                                     start-time end-time subject))
              (setq string (format "%%%%(diary-block %s %s) %s"
                                   (u-appt-date-string
                                    (list start-month start-day start-year)
                                    t t)
                                   (u-appt-date-string
                                    (list end-month end-day end-year)
                                    t t)
                                   subject)))
            (setq has-end t)))))
    (when appt-found
      (u-appt-handle subject string))))

(provide 'u-appt)
;;; u-appt.el ends here

-- 
http://de.geocities.com/ulf_jasper/