#!/bin/sh
: ; exec klone $0 "$@"
; The above line finds the klone executable in the $PATH
;;Skeleton of a typical klone script
;;(stack-dump-on-error t)
;;(sdb t)

(if (not (setq mail-file (getenv "SAVE_AS_MH_FILE"))) 
  (with (
      filename (+ "/tmp/save-as-mh." (String *current-process-id*))
      fd (open filename :direction :io :if-exists :supersede)
    )
    ;; just gobble as fast as we can, fork and terminate
    (write-chars (String *standard-input*) () fd)
    (close fd)
    (putenv "SAVE_AS_MH_FILE" filename)
    (trap-signal 1 t)
    (system *arguments*)		;; forks sub-process doing the job
    (exit 0)				;and let xrn work
))

(setq args (getopts "USAGE: save-as-mh [options]
takes a mail or news message as argument (or any piece of text), and pops a 
X menu (via the external xmenu

 program) to store the message in a mh folder.
Only some selected folders are presented at first, but more can be selected.
The database of folders is held in the file ~/.save-as-mh-folders
"
    ("-v" () verbose "verbose operation")
))

(setq mhdir (expand-filename "~/Mail"))
(setq main-folders-file (expand-filename "~/.save-as-mh-folders"))
(setq re-first-word (regcomp "^[ \t]*([^ \t]+)"))
(setq re-first-line (regcomp "^([^\n]*)\n?"))
(setq re-subject (regcomp "^[Ss]ubject:[ \t]*([^\n]*)\n?"))
(setq re-empty-line (regcomp "^[ \t]*(\n|$)"))
(setq re-num (regcomp "^[0-9]+$"))
(setq re-prevdir (regcomp "^(.*)[/][^/]+$"))

(defun main (&aux
    mail-contents
  )
  (setq mail-contents (String (open mail-file)))
  (sh rm -f ,mail-file)
  (setq folder (prompt-for-folder mail-contents))
  (add-mh-mail folder mail-contents)    
  (add-folder-to-file folder)
)

;; prompt-for-folder
;; workhouse: forks a popup menu (xmenu) to prompt for folder, optionally
;; exploring all the tree, or cancelling action (returns ()), or creating 
;; folder, or displaying first lines of message (heading is subject)
;; mhdir/main-folders-file contains a list of preferred folders, one per line
;; (if none, it is created with the entry "inbox")
;; optionally a number of used times may be added

(defun prompt-for-folder (mail-contents &aux
    (folders (read-folders))
    (header (get-header mail-contents))
    (result "-show")
    out
    (fork-failed? t)
  )
  (while (= #\- (0 result))
    (wait (system (+ (list "xmenu" "-heading" header) folders) :output 'out))
    (catch 'EOF 
      (setq result (read-line out))
      (setq fork-failed? ())
    )
    (if fork-failed? (progn
	(? "program \"xmenu\" was not found. install it in your PATH, "
	  "it can be found at ftp://koala.inria.fr/pub/xmenu.tgz\n")
	(exit 1)
    ))
    (if 
      (= result "-cancel") (exit 0)
      (= result "-contents") (progn
	(setq mail-contents (edit-contents mail-contents))
	(setq header (get-header mail-contents))
      )
      (= result "-all") (setq folders (browse-all-folders ()))
      (= result "-create") (setq result (create-new-folder))
      (= result "-refresh") ;; check folder existance
      (setq folders (refresh-folders folders))
	
      (= #\- (1 result)) ;; --folder
      (setq folders (browse-all-folders (subseq result 2)))
    )
  )
  result
)

;; add-mh-mail
;; appends the contents as a mail into the folder (do nothing if ())
;; create it first as .save-as-mh-<PID>, then ln it to desired number
;; to avoid race condition with many simultaneous save-as-mh
;; then remove it

(defun add-mh-mail (folder mail-contents &aux
    tempname
    filename
    fd
    (last 0)
    n
    (*current-directory* (+ mhdir "/" folder))
  )
  (setq tempname (+ ".save-as-mh-" (String *current-process-id*)))
  (setq fd (open tempname :direction :io :if-exists :supersede))
  (write-string mail-contents fd)
  (close fd)
  (dolist (filename (directory))
    (if (and (regexec re-num filename)
	(> (Int filename) last)
      )
      (setq last (Int filename))
  ))
  (while (/= 0 (wait (system (list "ln" tempname (String (+ last 1))))))
    (incf last)
  )
  (wait (system (list "rm" tempname)))
  (print-format "save-as-mh: added to %0/%1\n" folder (+ last 1))
)

;; read-folders returns list of folders in file
;; and other buttons that must return a minux-prefixed meta command:
;; -cancel -contents -all -create

(defun read-folders (&aux
    (fd (open main-folders-file :error ()))
    line
    (folders (copy '("inbox" "-line")))
  )
  (if (not fd) (progn
      (setq fd (open main-folders-file :direction :io :if-exists :supersede 
	    :error ()
    )))
    (progn
      (while (setq line (read-line fd ()))
	(if (regexec re-first-word line)
	  (if (/= "inbox" (regsub re-first-word 1))
	    (lappend folders (regsub re-first-word 1))
  )))))
  (setq folders-read (copy folders))
  (prepare-folder-list folders)
)

(defun prepare-folder-list (folders)
  (+ folders '("-line" "-line" "Cancel=-cancel" "Contents=-contents"
      "Check folders existence=-refresh"
      "List All Folders=-all" 
;;"Create New Folder=-create"
  ))
) 

(defun get-header (message &aux 
    line
    first-line
    subject
    (offset 0)
  )
  (regexec re-first-line message 0)
  (setq first-line (regsub re-first-line 1))
  (while (not subject)
    (if (regexec re-subject message offset)
      (setq subject (regsub re-subject 1))
      (regexec re-empty-line message offset)
      (setq subject first-line)
      (progn
	(if (seek message #\newline offset)
	  (setq offset (+ 1 (seek message #\newline offset)))
	  (setq subject first-line)
  ))))
  subject
)

(defun edit-contents (mail-contents &aux
    (filename (+ "/tmp/save-as-mh." (String *current-process-id*)))
    (fd (open filename :direction :io :if-exists :supersede))
  )
  (write-string mail-contents fd)
  (close fd)
  (wait (system (list "xedit" filename)))
  (setq fd (open filename))
  (setq mail-contents (String fd))
  (close fd)
  (wait (system (list "rm" filename)))
  mail-contents
)

;; list of folders, if folder has subfolders, prefix by -- the return value

(defun browse-all-folders (folder &aux
    (*current-directory* (if (and folder (/= "" folder))
	(+ mhdir "/" folder) mhdir))
    (folders (copy '()))
  )
  (if (= folder "") (setq folder ()))
  (dolist (file (directory))
    (if (= 'directory (file-type file)) (progn
	(if (has-subdirs file) (progn
	    (if folder (setq file (+ folder "/" file)))
	    (setq file (+ file " ...=--" file))
	  )
	  (if folder (setq file (+ folder "/" file)))
	)
	(lappend folders file)
  )))
  (if folder
    (if (seek folder #\/)
      (progn (regexec re-prevdir folder) 
	(lappend folders (+ "..=--" (regsub re-prevdir 1)))
      )
      (lappend folders "..=--")
  ))
  (sort folders compare)
  (+ folders '("-line" "-line" "Cancel=-cancel" "Contents=-contents"
      "List All Folders=-all" "Create New Folder=-create"
  ))
)

(defun has-subdirs (dir &aux
    (*current-directory* dir)
  )
  (catch 'Done
    (dolist (file (directory))
      (if (= 'directory (file-type file))
	(throw 'Done t)
    ))
    ()
  )
)

(defun create-new-folder ()
  ;; TODO
  "inbox"
)

;; insert folder into file listing default folders if wasnt there

(defun add-folder-to-file (folder &aux
    fd
  )
  (if (not (seek folders-read folder)) (progn
      (lappend folders-read folder)
      (sort folders-read compare)
      (setq fd (open main-folders-file :direction :io :if-exists :supersede 
	    :error ()
      ))
      (if fd (progn
	  (dolist (file folders-read)
	    (write-line file fd)
	  )
	  (close fd)
      ))
  ))
)

(defun refresh-folders (folders &aux
    (new (list))
  )
  (dolist (folder folders)
    (if 
      (= #\- (0 folder))
      (lappend new folder)
      (match "=-" folder)
      (lappend new folder)
      (= 'directory (file-type (+ mhdir "/" folder)))
      (lappend new folder)
  ))
  (if (/= new folders) (with (
	fd (open main-folders-file :direction :output :if-exists :supersede)
      )
      (dolist (folder new)
	(print-format fd "%0\n" folder)
  )))
  new
)

(main)


;;; EMACS MODES
;;; Local Variables: ***
;;; mode:lisp ***
;;; End: ***

