;; Last edited: Wed Oct 24 17:08:20 1990
;; provide a simple diary facility on top of rmailsum
;; Copyright (C) 1990 Henry S. Thompson

;; This file is part of GNU Emacs.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY.  No author or distributor
;; accepts responsibility to anyone for the consequences of using it
;; or for whether it serves any particular purpose or works at all,
;; unless he says so in writing.  Refer to the GNU Emacs General Public
;; License for full details.

;; Everyone is granted permission to copy, modify and redistribute
;; GNU Emacs, but only under the conditions described in the
;; GNU Emacs General Public License.   A copy of this license is
;; supposed to have been given to you along with GNU Emacs so you
;; can know your rights and responsibilities.  It should be in a
;; file named COPYING.  Among other things, the copyright notice
;; and this notice must be preserved on all copies.

(provide 'diary)
(require 'mail-extras)

(autoload 'sort-subr "sort")

(defvar ht-diary-file-name "~/DIARY.babyl"
  "default name of diary file")

(defvar ht-Calendar-directory "~/Calendar")

(defun xxx-date-lessp (date1 date2)
  "Return T if DATE1 is earlyer than DATE2."
  (string-lessp (gnus-comparable-date date1)
		(gnus-comparable-date date2)))

(defun xxx-comparable-date (date)
  "Make comparable string by string-lessp from DATE."
  (let ((month '(("JAN" . " 1")("FEB" . " 2")("MAR" . " 3")
		 ("APR" . " 4")("MAY" . " 5")("JUN" . " 6")
		 ("JUL" . " 7")("AUG" . " 8")("SEP" . " 9")
		 ("OCT" . "10")("NOV" . "11")("DEC" . "12")))
	(date (or date "")))
    ;; Can understand the following styles:
    ;; (1) 14 Apr 89 03:20:12 GMT
    ;; (2) Fri, 17 March 89 4:01:33 GMT
    (if (string-match
	 "\\([0-9]+\\) \\([^ ,]+\\) \\([0-9]+\\) *\\([0-9:]*\\)" date)
	(let ((year (substring date (match-beginning 3) (match-end 3)))
	      (mn (substring date
			      (match-beginning 2)
			      (+ 3 (match-beginning 2))))
	      (day (substring date
				   (match-beginning 1) (match-end 1)))
	      (time (substring date (match-beginning 4) (match-end 4))))
	(concat
	 ;; Year
	 (if (= (length year) 2)
	     (if (string-match "^9" year)
		 (concat "19" year)
	       (concat "20" year))
	   year)
	 ;; Month
	 (cdr
	  (assoc
	   (upcase mn)
	   month))
	 ;; Day
	 (format "%2d" (string-to-int day))
	 ;; Time
	 time))
      ;; Cannot understand DATE string.
      date
      )
    ))

(defun update-default-diary (arg) "update a diary - with arg, the one for
this file.  Without arg, the default (named in ht-diary-file-name)"
  (interactive "P")
  (if arg
      (update-diary (current-buffer))
    (require-diary)
    (update-diary (get-file-buffer ht-diary-file-name))))

(defun update-diary (buffer)
;; (setq rmail-summary-buffer (get-buffer-create "*Diary*"))
  (let ((obuf (current-buffer)))
    (set-buffer buffer)
    (if (not has-diary-summary)
	(progn (make-local-variable 'has-diary-summary)
	       (setq has-diary-summary t)))
    (rmail-summary)
    (set-buffer obuf)))

(defun do-diary-update () "rmail-summary-mode-hook calls this"
  (if (save-excursion (set-buffer rbuf)
		      has-diary-summary)
      (progn
	(make-local-variable 'diary-summary-buffer)
	(setq diary-summary-buffer t)
	(setq description (concat "Diary " description))
	(setq buffer-read-only nil)
	(sort-diary-hdrs)
	(format-diary-hdrs)
	(setq buffer-read-only t)
	(not-modified)
	(beginning-of-buffer)
	(setq mesg nil)			; to go to earliest, not first in file
	)))

(defun require-diary ()
  (if (not (get-file-buffer ht-diary-file-name))
      (progn (rmail-input ht-diary-file-name)
	     (rmail-show-message 1))
    ))

(defvar diary-summary-buffer nil "flag to identify diary summaries")
(defvar has-diary-summary nil "flag to identify buffers with diary summaries")

(defun sort-diary-hdrs ()
  (interactive)
  (goto-char (point-min))
  (sort-subr nil 'forward-line 'end-of-line 'get-diary-hdr-date nil))

(defun format-diary-hdrs ()
  (goto-char (point-min))
  (while (< (point)(point-max))
    (forward-char 5)
    (delete-char 35)
    (looking-at " *\\([0-9]*\\) *\\([a-zA-Z]*\\) *\\([0-9]*\\) *\\([0-9]*\\)")
    (if (match-beginning 0)
	(let ((day (buffer-substring (match-beginning 1)(match-end 1)))
	      (month (capitalize (buffer-substring (match-beginning 2)
						   (min (+ (match-beginning 2)
							   3)
							(match-end 2)))))
	      (year (buffer-substring (max
				       (- (match-end 3) 2)
				       (match-beginning 3))
				      (match-end 3)))
	      (time (buffer-substring (match-beginning 4)(match-end 4))))
	  (delete-char (+ 1
			  (if (= (match-end 4)
				 (match-beginning 4))
			      0		; fix for no time case
			    1)
			  (- (match-end 4)(match-beginning 1))))
	  (insert (format "  %2s %3s %2s  %4s " day month year time))))
    (forward-line 1))
  (goto-char (point-min)))    

(defun get-diary-hdr-date ()
  (looking-at " *[^ ]* *[^ ]* *[^ ]* *\\(.*\\)$")
  (xxx-comparable-date (buffer-substring (match-beginning 1)(match-end 1))))


(if (not (boundp 'rmail-edit-map))
    (load-library "rmailedit"))
(if (not (boundp 'rmail-summary-mode-map))
    (progn (load-library "rmailsum")
	   (rmail-summary-mode-fun1)))
(define-key rmail-edit-map "\C-c\C-c" 'ht-rmail-cease-edit)
(define-key rmail-edit-map "\C-c\C-]" 'ht-rmail-abort-edit)
;(defvar diary-mode-map (copy-keymap rmail-summary-mode-map))
;(define-key diary-mode-map "s" 'diary-save)
(define-key rmail-mode-map "h" 'ht-rmail-summarise)
(setq rmail-summary-mode-hook 'do-diary-update)

(defvar editing-diary-entry nil)

(defun diary-save ()
  "save parent file and update"
  (interactive)
  (set-buffer rmail-buffer)
  (rmail-expunge-and-save)
  (if has-diary-summary (update-diary (current-buffer))))

(defun ht-rmail-summarise ()
  "Display a summary of all messages, one line per message.
If file is named as ht-diary-file-name, or the summary buffer is already
a diary summary, make it a Diary summary (see
\\[describe-mode] rmail-summary-mode for info)."
  (interactive)
  (if (eq (current-buffer)
	  (get-file-buffer ht-diary-file-name))       
      (update-default-diary t)
    (rmail-summary)))

(defun edit-and-move-to-diary ()
  "try to add a date to subject field, move to diary on exit"
  (interactive)
  (make-local-variable 'editing-diary-entry)
  (setq editing-diary-entry t)
  (rmail-edit-current-message)
  (goto-char (point-min))
  (search-forward "\n\n")
  (let ((try-date (and
		   (re-search-forward
		   "[0-9][-0-9 ]*[- ][a-zA-Z][a-zA-Z]*[- 0-9]*" nil t)
		   (buffer-substring (match-beginning 0)(match-end 0))))
	sublp)
    (goto-char (point-min))
    (setq sublp (search-forward "Subject: " nil t))
    (if try-date
	(progn (set-mark (point))
	       (insert try-date)))))

(defun gnus-edit-and-move-to-diary (&optional no-delete)
  "try to add a date to subject field, move to diary on exit"
  (interactive "P")
    (let ((flush-shell nil))
    (when (and (not (and no-delete (cdr no-delete)))
	       (gnus-group-read-only-p))
      (error "The current newsgroup does not support article editing"))
    ;; Select article if needed.
    (unless (eq (gnus-summary-article-number)
		gnus-current-article)
      (gnus-summary-select-article t))
    (gnus-article-date-original)
    (message "About to forward. . .")
    (gnus-summary-mail-forward 1)
    (message "Begin forward. . .")
    (goto-char (point-min))
    (re-search-forward "^To: " nil t)
    ;(forward-char 4)
    (insert "htcalendar@markup.co.uk")
    (search-forward "------ Start of forwarded")
    (save-excursion
      (when (and (bufferp (get-buffer "*Shell Command Output*"))
		 (not (re-search-forward
		       "^--0000.*[[:space:]]*Content-Type: text/plain" nil t nil
		       (get-buffer " *Original Article*")))
		 (search-forward "<html" nil t))
	(backward-char 5)
	(push-mark nil t)
	(re-search-forward "</html>[[:space:]]*")
	(exchange-point-and-mark)
	(use-text-not-html t)
	(let ((pos (point)))
	  (when (search-backward "type=text/html" nil t)
	    (replace-match "type=text/plain")
	    (goto-char (+ pos 1))))
	(setq flush-shell t)
	))
    (let (sublp)
      (save-excursion
	(goto-char (point-min))
	(setq sublp (search-forward "Subject: " nil t))
	(delete-region (point)(progn (search-forward "] " nil t)))
	(if (not
	     (looking-at "[123]?[0-9] [JFMASOND][a-z][a-z] (20)?[2-9][0-9] "))
	    (save-excursion
	      (let ((try-date
		     (and
		      (or (re-search-forward "^\r?$" nil 1) t)
		      (re-search-forward
		       "[0-9][-0-9 ]*[- ][jfmasondJFMASOND][a-zA-Z]*[- 0-9]*"
		       (save-excursion (search-forward "\n--\n" nil t))
		       t)
		      (buffer-substring (match-beginning 0)(match-end 0)))))
		(message (format "date: |%s| %s" try-date sublp))
		(if (and sublp
			 try-date)
		    (progn (set-mark (point))
			   (insert try-date)))))))
      (make-local-hook 'message-send-hook)
      (if (and no-delete (equal (car no-delete) 16))
	  (let ((hook '(lambda ()
			 (ht-gnus-cease-edit nil)
			 nil t)))
	    (add-hook 'message-send-hook hook nil t)
	    
	    (message-send-and-exit)
	    (if (cdr no-delete)
		;; called directly from splitting an ht+d message...
		"_doom"
	      (if (not (gnus-summary-next-unread-article))
		  (gnus-summary-exit))))
	(add-hook 'message-send-hook
		  `(lambda ()
		     (ht-gnus-cease-edit ',no-delete ',flush-shell)
					; (gnus-summary-edit-article-done
					; ,(or (mail-header-references gnus-current-headers) "")
					; ,(gnus-group-read-only-p) ,gnus-summary-buffer nil)
					; (switch-to-buffer gnus-summary-buffer)))
					; (goto-char (point-min))
					; (search-forward "\nSubject: " nil t))
		     )
		  nil t)
    	(split-window-vertically 6)
	(other-window 1)
	(search-forward "\n\n" nil t)
	(other-window 1)
	(goto-char sublp)
	(message "Exiting to buffer, we hope")))
    )
  )

(defun ht-gnus-cease-edit (&optional no-delete flush-shell)
  "check if diary edit, move if so"
  (interactive "P")
  (message "ceasing. . .")
  (ht-forward-to-Calendar)
  (let ((rmail-summary-redo '(rmail-summary)))
    (gnus-output-to-rmail ht-diary-file-name)
    )
  (unless no-delete
    (with-current-buffer gnus-summary-buffer
      (gnus-summary-move-article 1 "nnml+ht:_doom")))
  (if (get-buffer "diary.babyl-summary")
      (kill-buffer "diary.babyl-summary"))
  (with-current-buffer "diary.babyl"
    (rmail-mode)
    (save-buffer)
    (ht-rmail-summarise))
  (if flush-shell
      (let ((sb (get-buffer "*Shell Command Output*")))
	(if (bufferp sb)
	    (kill-buffer sb))))      
  (message "ceased"))

(defun ht-gnus-summary-save-in-diary (&optional filename)
  (gnus-eval-in-buffer-window gnus-save-article-buffer
    (save-excursion
      (save-restriction
	(widen)
	(gnus-output-to-rmail ht-diary-file-name)))))

;; private copy to simulate hook
(defun ht-rmail-cease-edit ()
  "check if diary edit, move if so"
  (interactive)
  (rmail-cease-edit)
  (if editing-diary-entry
      (progn (setq editing-diary-entry nil)
	     (ht-forward-to-Calendar)
	     (rmail-output-to-rmail-file ht-diary-file-name 1)
	     (ht-rmail-delete-forward))))

;; try to add a diary subject field line to the appropriate calendar file
(defun ht-forward-to-Calendar ()
  (goto-char (point-min))
  (search-forward "Subject: ")
  (or (looking-at
       "\\([0-9]+\\) \\([A-Za-z]+\\) \\([0-9]+\\) \\([0-9:]*\\) ?\\(.*\\)\n")
      (error "not a recognisable diary line"))
  (let ((day (buffer-substring (match-beginning 1) (match-end 1)))
	(month (buffer-substring (match-beginning 2) (match-end 2)))
	(year (buffer-substring (match-beginning 3) (match-end 3)))
	(time (buffer-substring (match-beginning 4) (match-end 4)))
	(message (buffer-substring (match-beginning 5) (match-end 5)))
	(mb (match-beginning 4))
	(me (match-end 5))
	ends e-day e-month fn)
    (let ((year (if (string-match "^\\(19\\|20\\).." year)
		    year
		  (if (eq (length year) 2)
		      (concat "20" year)
		    (progn (if (and (equal time "")(eq (length year) 4))
			       (setq time year))
			   (format-time-string "%Y")))))
	  (t-month (capitalize
		    (substring month 0 3))))
      (let* ((n-day (read day))
	     (mon-table '((Jan . 1)
			      (Feb . 2)
			      (Mar . 3)
			      (Apr . 4)
			      (May . 5)
			      (Jun . 6)
			      (Jul . 7)
			      (Aug . 8)
			      (Sep . 9)
			      (Oct . 10)
			      (Nov . 11)
			      (Dec . 12)))
	     (a-month (assq (read t-month)
			    mon-table))
	     (n-month (if a-month (cdr a-month) 0))
	     (u-time (if (equal time "") "0" time))
	     (hour (/ (read u-time) 100))
	     (minute (mod (read u-time) 100))
	     (nhour (if (> minute 29)
			(+ 1 hour)
		      hour))
	     (nminute (if (> minute 29)
			  (- minute 30)
			(+ minute 30)))
	     (n-year (read year))
	     (r-subj  (mail-fetch-field "Subject"))
	     (body (save-excursion
		     (buffer-substring
		      (progn
			(goto-char (point-min))
			(if (re-search-forward "^\r?$" nil 1)
			    (match-beginning 0)
			  (point-max)))
		      (point-max))))
	     (subj-matches (string-match "^\\([^(]*\\)\\((\\(.*\\))\\)?"
					 message))
	     (np-subj (match-string 1 message))
	     (p-subj (or (match-string 3 message) ""))
	     (uid (or (mail-fetch-field "Message-id")
		      (let ((ct (current-time)))
			(format "%d-%d-%d"
				(car ct)
				(cadr ct)
				(caddr ct)))))
	     )
	(if (string-match " -- \\(.*\\)$" message)
	    (progn
	      (setq ends (substring message (match-beginning 1)
				    (match-end 1)))
	      (setq message (substring message 0 (match-beginning 0)))
	      (if (string-match "\\([0-9]+\\) \\([A-Za-z]+\\)" ends)
		  (progn
		    (setq e-day (substring ends (match-beginning 1)
					   (match-end 1)))
		    (setq e-month (assq
				   (read (capitalize
					  (substring
					   (substring ends (match-beginning 2)
						      (match-end 2))
					   0 3)))
				   mon-table))))))
	(setq fn (build-vcal-message (my-time-iso8601
				      (encode-time
				       0 minute
				       hour
				       n-day
				       n-month
				       n-year))
				     (my-time-iso8601
				      (if e-day				  
					  (encode-time
					   0 (if (eq hour 0) 30 minute) ;nminute
					   (if (eq hour 0) 23 hour) ; nhour
					   (read e-day)
					   (if e-month (cdr e-month) 0)
					   n-year)
					(encode-time
					 0 minute ; nminute
					 (+ hour 1) ; nhour
					 n-day
					 n-month
					 n-year)))
	     "ORGANIZER;CN=\"Henry S. Thompson\":mailto:htcalendar@markup.co.uk"
				     ;(concat "ORGANIZER:" (mail-fetch-field "From"))
				     p-subj
				     body
				     np-subj
				     (concat "ht-vcal-" uid)))
	(if fn
	    (progn
	      (goto-char (point-min))
	      (if (search-forward "<#multipart " nil t)
		  (progn
		    (if (search-forward "<#multipart type=alternative" nil t)
			(beginning-of-line)
		      (forward-line 2)
		      ;; now at beginning of forwarded text
		      (if (search-forward "<#part " nil t)
			  (progn
			    ;; now at beginning of _attachments_
			    (beginning-of-line))
			;; no attachments, probably never happens
			(search-forward "<#/multipart>"))))
		;; plain text, make it multipart
		(search-forward "-------- Start of forwarded")
		(re-search-forward "^\r?$")
		(forward-line 1)
		(insert "<#multipart type=mixed>\n<#part type=text/plain charset=\"ISO-8859-1\" format=\"flowed\" disposition=inline nofile=yes>\n")
		(search-forward "--------- End of forwarded")
		(forward-line -1)
		(insert "<#/multipart>\n")
		(forward-line -1))
	      (mml-attach-file fn "application/octet-stream" "diary event")
;	      (let ((res (shell-command-to-string
;			  (concat "updateCal.pl < " fn))))
;		(if (not (equal res ""))
;		    (message (format "update losing: %s" res))))
	      )))
      (if (file-exists-p ht-Calendar-directory)
	  (let* ((dfn (concat ht-Calendar-directory
			      "/xy"
			      year
			      "/xc"
			      day
			      t-month
			      year))
		 (buf (find-file-noselect dfn))
		 )
	    (save-excursion
	      (set-buffer buf)
	      (goto-char (point-max))
	      (if (not (bolp))
		  (insert "\n"))
	      (if time
		  (insert time " "))
	      (insert message)
	      (let ((require-final-newline nil))
		(save-buffer)))
	    (if ends
		;; an end date also given
		(if e-day
		    (let (t-e-month msg)
		      (setq msg (concat
				 (substring message 0
					    (string-match " " message))
				 " continues"))
		      (if (string-equal (setq t-e-month
					      (if e-month (car e-month)
						t-month))
					t-month)
			  (fill-dates year t-month (1+ (car
							(read-from-string day)))
				      (car
				       (read-from-string e-day))
				      msg)
			(fill-dates year t-month (1+ (car
						      (read-from-string day)))
				    (cdr (assoc t-month
						'(("Jan" . 31)
						  ("Feb" . 28)
						  ("Mar" . 31)
						  ("Apr" . 30)
						  ("May" . 31)
						  ("Jun" . 30)
						  ("Jul" . 31)
						  ("Aug" . 31)
						  ("Sep" . 30)
						  ("Oct" . 31)
						  ("Nov" . 30)
						  ("Dec" . 31))))
				    msg)
			(fill-dates year t-e-month 1
				    (car (read-from-string e-day))
				    msg)))
		  (message "\C-g\C-gCouldn't parse end date: %s" ends)))
	    )))))

(defun fill-dates (year month start end mesg)
  "fill the dates between start and end with message in the calendar"
  (let ((day start))
    (while (<= day end)
      (let* ((dfn (concat ht-Calendar-directory
			  "/xy"
			  year
			  "/xc"
			  (format "%d" day)
			  (format "%s" month)
			  year))
	     (buf (find-file-noselect dfn)))
	  (save-excursion
	    (set-buffer buf)
	    (goto-char (point-max))
	    (if (not (bolp))
		(insert "\n"))
	    (insert mesg)
	    (let ((require-final-newline nil))
	      (save-buffer))))
      (setq day (1+ day)))))

;; private copy
(defun ht-rmail-abort-edit ()
  "add a hook"
  (interactive)
  (setq editing-diary-entry nil)
  (rmail-abort-edit))

(defun rmail-edit-current-message ()
  "Edit the contents of this message."
  (interactive)
  (rmail-edit-mode)
  (make-local-variable 'rmail-old-text)
  (setq rmail-old-text (buffer-substring (point-min) (point-max)))
  (setq buffer-read-only nil)
  (set-buffer-modified-p (buffer-modified-p))
  ;; Make mode line update.
  (if (and (eq (key-binding "\C-c\C-c") 'ht-rmail-cease-edit)
	   (eq (key-binding "\C-c\C-]") 'ht-rmail-abort-edit))
      (if editing-diary-entry
	  (message "Editing: Type C-c C-c to move to diary and return to Rmail, C-c C-] to abort")
	(message "Editing: Type C-c C-c to return to Rmail, C-c C-] to abort"))
    (message (substitute-command-keys
	      "Editing: Type \\[rmail-cease-edit] to return to Rmail, \\[rmail-abort-edit] to abort"))))


(defun build-vcal-message (start end org location description summary uid)
  (save-excursion
    (let ((fn (concat "/tmp/" (make-temp-name "vcal") ".vcs")))
      (find-file fn)
      (insert "BEGIN:VCALENDAR\nMETHOD:PUBLISH\nPRODID:-//Henry S. Thompson//gnus diary hack//EN\nVERSION:0.1\nBEGIN:VEVENT\n")
      (insert "UID\n :")(insert uid)(insert "\n")
      (insert "SUMMARY")(insert-encoded-maybe summary)(insert "\n")
      (insert "DESCRIPTION")(insert-folded description)(insert "\r\n")
      (insert "LOCATION")(insert-encoded-maybe location)(insert "\n")
      (insert "DTSTART\n :")(insert start)(insert "Z\n")
      (insert "DTEND\n :")(insert end)(insert "Z\n")
      (insert "DTSTAMP\n :")(insert
			  (my-time-iso8601 (current-time)))
      (insert "Z\n")
      ;(insert "ORGANIZER")(insert-encoded-maybe org)
      (insert org)
      (insert "\n")
      (insert "BEGIN:VALARM\nTRIGGER:-PT15M\nACTION:DISPLAY\nDESCRIPTION:Reminder\nEND:VALARM\n")
      (insert "BEGIN:VALARM\nTRIGGER:-PT15M\nACTION:AUDIO\nDESCRIPTION:Reminder\nEND:VALARM\n")
      (insert "END:VEVENT\nEND:VCALENDAR\n")
      (save-buffer)
      fn)))

(defun insert-encoded-maybe (string)
  (if (string-match "[\000-\007\n\013\015-\037\200-\377=]" string)
      (progn
	(insert ";ENCODING=QUOTED-PRINTABLE:")
	(let ((beg (point)))
	  (insert string)
	  (message (format "%d;%d" beg (point)))
	  (quoted-printable-encode-region
	   beg
	   (point)
	   t
	   "^\000-\007\n\013\015-\037\200-\377="))
	(goto-char (point-max)))
	(insert "\n :")
	(insert string)))

(defun insert-folded (string)
  (insert "\n :")
  (let ((beg (point)))
    (insert string)
    (narrow-to-region beg (point))
    (goto-char (point-min))
    (replace-string "\n" "\\n")
    (goto-char (point-min))
    (replace-string "\r" "")
    (goto-char (point-min))
    (replace-string "," "\\,")
    (goto-char (point-min))
    (while (> (- (point-max) (point)) 72)
      (forward-char 70)
      (insert "\n "))
    (goto-char (point-max))
    (insert "\r\n")
    (widen)))

(defun my-time-iso8601 (time)
  (let ((tzo (car (current-time-zone time)))
	(hi (car time))
	(lo (cadr time))
	(ignore (cddr time)))
    (gnus-time-iso8601
     (if (>= lo tzo)
	 (cons hi
	       (cons (- lo tzo)
		     ignore))
       (cons (- hi 1)
	     (cons (- (+ lo 65536) tzo)
		   ignore)))
       )))