;;; -*- Mode: LISP; Package: :cl-user; BASE: 10; Syntax: ANSI-Common-Lisp; -*-
;;;
;;;      {C} 2004 Madhu. All rights *~RESEDA~*
;;;
;;;   Time-stamp: <2008-04-11 18:07:43 madhu>
;;;   Touched: Sun May 16 20:31:42 2004 +0530
;;;   Bugs-To: (enometh@net.meer)
#+nil
(progn (require 'cmime "home:cl/cmime/cmime") (provide 'cmime))
;;;
(defpackage "BABYL"
  (:use "CL")
  (:nicknames "RMAIL")
  #+cmime
  (:import-from "CMIME" "SAVE-PARTS" )
  (:export "SLURP" "INDEXED-BABYL-FILE" "SIMPLE-BABYL-FILE"
	   "FIND-MESSAGE"
	   "READ-BABYL-FILE"
	   "SNARF-MESSAGE-IDS"
	   "DO-MESSAGES"))
(in-package "BABYL")

(defconstant +eooh-line+ "*** EOOH ***")
(defconstant +terminator+ (code-char 31))

;;;
;;;
(defun parse-messages (buf)
  "parse babyl buf into list of (msgno &key :start :end) items"
  (loop with len = (length buf)
	and pos = (position +terminator+ buf)
	for msgno from 1
	while (and (< (incf pos) len) (char= (char buf pos) #\page)
		   (< (incf pos) len) (char= (char buf pos) #\newline)
		   (< (incf pos) len))
	do (ecase (aref buf pos) ((#\0 #\1)))
	collect (list msgno :start pos :end (setf pos (position +terminator+ buf :start pos)))))

(defun parse-message (buf &rest keys &key start end)
  "=> list of (type &key start end) message-indices"
  (declare (ignore keys))
  (let ((bit-char (char buf start)) (pos start) (ret nil))
    (block nil
      (push (list :status-line :start pos :end
		  (setf pos (position #\newline buf :start pos))) ret)
      (unless (< (incf pos) end) (return))
      (let ((eooh (search +eooh-line+ buf :start2 pos :end2 end)))
	(assert eooh)
	(push (list :invisible-headers :start pos :end  #+nil eooh
		    (ecase bit-char (#\0 eooh) (#\1  (1- eooh)))) ret)
	(setf pos (position #\newline buf :start eooh)))
      (unless (< (incf pos) end) (return))
      (let ((eovh (search '(#\newline #\newline) buf :start2 pos :end2 end)))
	(assert eovh)
	(push (list :visible-headers :start pos :end (1+ eovh)) ret)
	(setf pos (+ eovh 1)))
      (unless (< (incf pos) end) (return))
      (push (list :body :start pos :end end) ret))
    (nreverse ret)))

(defmethod parse-headers (buf &key start end)
  "=> list of (key value+) = ((start . end) (start . end)+) header-indices"
  (let (current-header headers delim-pos)
    (loop for pos = start then (1+ e)
	  for e = (position #\Newline buf :start pos :end end)
	  while e do
	  (cond ((case (char buf pos) ((#\Space #\tab) t))
		 (assert current-header)
		 (nconc current-header (list (cons pos e))))
		((setq delim-pos (position #\: buf :start pos :end e))
		 (push (setq current-header
			     (list (cons pos delim-pos)
				   (cons (1+ delim-pos) e)))
		       headers))	;050110 converted to warning
		(t (warn "error in parse-header: start=~D end=~D" start end))))
    (nreverse headers)))

(defun print-msg (buf message-indices &key
		  (bit-char nil bit-char-supplied-p)
		  (stream *standard-output*)
		  status-line
		  invisible-headers
		  visible-headers
		  body)
  "Writes a babyl message onto STREAM. If KEYS are supplied, use
those instead of getting text from BUF"
  ;;
  (write-char #\page stream)
  (terpri stream)
  ;;
  (cond (status-line
	 (cond (bit-char-supplied-p
		;; BIT-CHAR T, #\1, reformed. NIL, #\0, unreformed.
		(ecase bit-char ((#\0 #\1)))
		(ecase (char status-line 0) ((#\0 #\1)))
		(write-char bit-char stream)
		(write-line status-line stream :start 1))
	       (t (ecase (setf bit-char (char status-line 0))
		    ((#\0 #\1)))
		  (write-line status-line stream))))
	(t (destructuring-bind (&key start end)
	       (cdr (assoc :status-line  message-indices))
	     (cond (bit-char-supplied-p
		    (ecase bit-char ((#\0 #\1)))
		    (write-char bit-char stream)
		    (write-line buf stream :start (1+ start) :end end))
		   (t (ecase (setf bit-char (char buf start)) ((#\0 #\1)))
		      (write-line buf stream :start start :end end))))))
  ;;
  (cond (invisible-headers
	 (write-string invisible-headers stream))
	(t
	 (let ((inv-headers (assoc :invisible-headers message-indices)))
	   (when inv-headers
	     (destructuring-bind (&key start end) (cdr inv-headers)
	       (write-string buf stream :start start :end end))))))
  ;;
  (when (char= bit-char #\1) (terpri stream))
  (write-line +eooh-line+ stream)
  ;;
  (cond (visible-headers
	 (write-string visible-headers stream))
	(t
	 (destructuring-bind (&key start end)
	     (cdr (assoc :visible-headers  message-indices))
	   (write-string buf stream :start start :end end))))
  ;;
  (terpri stream)
  ;;
  (cond (body
	 (write-string body stream))
	(t
	 (let ((body (assoc :body  message-indices)))
	   (when body
	     (destructuring-bind (&key start end) (cdr body)
	       (write-string buf stream :start start :end end))))))
  ;;
  (write-char +terminator+ stream))

;;;
;;; gratuitious protocols
;;;
(defclass simple-babyl-file ()
  ((buf :initarg :buf)
   (msgs :initarg :msgs)))

(defun read-babyl-file (file-stream &optional (class 'simple-babyl-file))
  (let* ((length (file-length file-stream))
	 (buf (make-array length :element-type 'character :fill-pointer t))
	 (read (read-sequence buf file-stream)))
    (setf (fill-pointer buf) read)
    (make-instance (find-class class) :buf buf
		   :msgs (parse-messages buf))))

(defmethod print-babyl-options ((babyl-file simple-babyl-file) stream)
  (with-slots (buf) babyl-file
    (let ((options-end (position +terminator+ buf)))
      (write-string buf stream :end (1+ options-end)))))

(defmethod print-babyl-file ((babyl-file simple-babyl-file) stream)
  (print-babyl-options babyl-file stream)
  (with-slots (buf msgs) babyl-file
    (loop for (msgno . indices) in msgs do
	  (write-char #\page stream)
	  (terpri stream)
	  (destructuring-bind (&key start end) indices
	    (write-string buf stream :start start :end end))
	  (write-char +terminator+ stream))))

;;;
;;;
(defmethod find-message ((babyl-file simple-babyl-file) n)
  (with-slots (msgs) babyl-file
    (loop for i from 1
	  for msg in msgs
	  if (= i n) return (prog1 msg (assert (= i (car msg)))))))

(defmethod print-simple-babyl-message ((babyl-file simple-babyl-file) n stream)
  (with-slots (msgs buf) babyl-file
    (let ((args (etypecase n
		  (integer (nth n msgs))
		  (cons n))))
      (assert (eq (cadr args) :start))
      (apply 'write-sequence buf stream (cdr args)))))

;;;
;;;
(defclass plist-mixin ()
  ((plist :initform nil :accessor property-list)))

(defmethod get-property ((plist plist-mixin) indicator &optional default)
  (getf (property-list plist) indicator default))

(defmethod (setf get-property) (value (plist plist-mixin) indicator
				&optional default)
  (declare (ignore default))
  (setf (getf (property-list plist) indicator) value))

;;;
;;;
(defclass indexed-babyl-file (simple-babyl-file)
  ((index :initform (make-hash-table))))

(defclass simple-babyl-message (plist-mixin)
  ((message-indices :initarg :message-indices)
   (visible-header-indices :initform nil)
   (invisible-header-indices :initform nil)
   (babyl-file :initarg :babyl-file :type indexed-babyl-file)
   (bit-char :initarg :bit-char :type boolean
	     :documentation "T if #\1, reformed. NIL if #\0, unreformed.")))

;;;
(defmethod index ((babyl-file indexed-babyl-file) &optional n) ;lazy
  (with-slots (buf msgs index) babyl-file
    (flet ((%make1 (msg)
	     (destructuring-bind (&key start end) (cdr msg)
	       (make-instance 'simple-babyl-message
		 :babyl-file babyl-file
		 :bit-char (ecase (char buf start) (#\0 nil) (#\1 t))
		 :message-indices (parse-message buf :start start :end end)))))
      (cond (n (or (gethash n index nil)
		   (setf (gethash n index) (%make1 (assoc n msgs)))))
	    (t (clrhash index)		;
	       (loop for msg in msgs for i = (car msg)
		     do (setf (gethash i index) (%make1 msg))
		     do (with-slots (message-indices) (gethash i index)
			  (let ((body-cons (assoc :body message-indices )))
			    (when body-cons
			      (assert (= (getf (cdr msg) :end)
					 (getf (cdr body-cons):end)))))))
	       t)))))

(defmethod initialize-instance  :after ((indexed-babyl-file indexed-babyl-file)
					&rest initargs &key allow-other-keys)
  (index indexed-babyl-file))

(defmethod update-instance-for-different-class :after
    ((old simple-babyl-file) (new indexed-babyl-file) &key)
  (index new))

(defmethod delete-message ((babyl-file indexed-babyl-file) (n integer))
  (with-slots (msgs index) babyl-file
    (setf msgs (delete n msgs :key #'car))
    (remhash n index)))

(defgeneric print-babyl-message (message stream))

(defmethod print-babyl-file ((babyl-file indexed-babyl-file) stream)
  (print-babyl-options babyl-file stream)
  (with-slots (buf msgs index) babyl-file
    (loop for (msgno . indices) in msgs do
	  (print-babyl-message (gethash msgno index) stream))))

;;;
;;;
(defmethod visible-header-indices ((babyl-message simple-babyl-message))
  (with-slots (message-indices visible-header-indices babyl-file)
      babyl-message
    (cond (visible-header-indices visible-header-indices)
	  (t (setf visible-header-indices
		   (with-slots (buf) babyl-file
		     (let ((keys (cdr (assoc :visible-headers
					     message-indices))))
		       (and keys (apply #'parse-headers buf keys)))))))))

(defmethod invisible-header-indices ((babyl-message simple-babyl-message))
  (with-slots (message-indices invisible-header-indices babyl-file)
      babyl-message
    (cond (invisible-header-indices invisible-header-indices)
	  (t (setf invisible-header-indices
		   (with-slots (buf) babyl-file
		     (let ((keys (cdr (assoc :invisible-headers
					     message-indices))))
		       (and keys (apply #'parse-headers buf keys)))))))))

(defmethod find-header ((babyl-message simple-babyl-message) (header string))
  (with-slots (message-indices babyl-file bit-char) babyl-message
    (with-slots (buf) babyl-file
      (let ((headers (cond (bit-char (invisible-header-indices babyl-message))
			   (t (visible-header-indices babyl-message)))))
	(loop for ((key-start . key-end) . values) in headers
	      when (loop for c across header for i from key-start
			 unless (and (< i key-end) (char-equal (char buf i) c))
			 return nil
			 finally (return t))
	      return
	      (apply #'concatenate 'string
		     (loop for (line-start . line-end) in values
			   collect (subseq buf line-start line-end))))))))

(defmethod print-babyl-message ((babyl-message simple-babyl-message) stream)
  (with-slots (message-indices babyl-file bit-char) babyl-message
    (with-slots (buf) babyl-file
      (print-msg buf message-indices
		 :bit-char (if bit-char #\1 #\0)
		 :stream stream))))

(defmethod unreform ((babyl-message simple-babyl-message) &optional
		     (purge-rmail-headers-p t))
  (with-slots (message-indices babyl-file bit-char visible-header-indices
			       invisible-header-indices) babyl-message
    (with-slots (buf) babyl-file
      (when bit-char
	(setf bit-char nil)
	(with-slots (buf) babyl-file
	  (destructuring-bind (&key start end)
	      (cdr (assoc :invisible-headers message-indices))
	    (declare (ignore start))
	    (loop with l for ((key-start . key-end) . values)
		  in (invisible-header-indices babyl-message)
		  if (some (lambda (header)
			     (string-equal header buf :start2 key-start
					   :end2 key-end))
			   '("Mail-From"
			     "Summary-Line"
			     "X-coding-System"))
		  do (setf l (cdr (car (last values))))
		  else do
		  (setf (getf (cdr (assoc :visible-headers message-indices))
			      :start) key-start)
		  (setf (getf (cdr (assoc :visible-headers message-indices))
			      :end) end)
		  (if (and l (not purge-rmail-headers-p))
		      (setf (getf (cdr (assoc :invisible-headers
						message-indices)) :end)
			    (1+ l))
		      (setq message-indices
			    (delete :invisible-headers message-indices
				    :key #'car)))
		  (setf visible-header-indices nil
			invisible-header-indices nil)
		  (return))))))))


;;; ----------------------------------------------------------------------
;;;Tue Jan 02 16:30:28 2007 +0530
;;;

;;;
;;;
(defmacro do-messages ((msg-no var babyl-file &optional result) &body body)
  (let ((body-name (gensym)))
    `(block nil
      (flet ((,body-name (,msg-no ,var) ,@body))
	(with-slots (index) ,babyl-file
	  (maphash #',body-name index))
	,result))))

(defun undup (babyl-input-file babyl-output-file)
  "Mark all messages unread and remove duplicates from INPUT
FILE. Sets dates and removes write perms."
  (let ((a (babyl:slurp babyl-input-file 'babyl:indexed-babyl-file)))
    (babyl::delete-duplicate-messages a)
    (babyl:do-messages (msgno msg a)
      (babyl::unreform msg))
    (when (probe-file babyl-output-file)
      (cerror "Delete it"
	      "Output file ~S exists" babyl-output-file)
      (delete-file  babyl-output-file))
    (babyl::dump a babyl-output-file)
    (let ((stats (user::stat2 (truename babyl-input-file))))
      (warn "stats = ~A" stats)
      (user::setdates2 babyl-output-file stats))
    #+cmu
    (unix:unix-chmod babyl-output-file #o0444)))

;;;
;;;
(defmethod char-code-vector ((babyl-message simple-babyl-message)) ; remove
  "get body of message as an array of character codes"
  (or (get-property babyl-message 'vec)
      (setf (get-property babyl-message 'vec)
	    (with-slots (message-indices babyl-file) babyl-message
	      (with-slots (buf) babyl-file
		(destructuring-bind (&key start end)
		    (cdr (assoc :body message-indices))
		  (let ((vec (make-array (- end start)
					 :element-type 'integer)))
		    (loop for j from 0 for i from start below end do
			  (setf (aref vec j) (char-code (char buf i))))
		    vec)))))))

#+clisp
(defmacro with-default-file-encoding ((&key (charset 'charset:iso-8859-1)
					    (line-terminator :unix))
				      &body forms)
  `(let ((.saved-encoding. custom:*default-file-encoding*))
    (unwind-protect
	 (progn (setf custom:*default-file-encoding*
		      (ext:make-encoding :charset ,charset
					 :line-terminator ,line-terminator))
		,@forms)
      (setf custom:*default-file-encoding* .saved-encoding.))))

(defun slurp (filename &rest args)
  "ARGS are passed to READ-BABYL-FILE."
  (with-open-file (stream filename)
    (apply #'read-babyl-file stream args)))

(defun slurp-indexed (filename)
  "ARGS are passed to READ-BABYL-FILE."
  (with-open-file (stream filename)
    (read-babyl-file stream  'indexed-babyl-file)))

(defun dump (babyl-file filename)
  (with-open-file (stream filename :direction :output)
    (print-babyl-file babyl-file stream)))

#+cmime
(defun metamail (filename n)
  "extract and save the mime parts present in Nth message of an RMAIL file"
  (let* ((babyl-file (slurp filename 'indexed-babyl-file))
	 (babyl-mesg (index babyl-file n)))
    (when babyl-mesg
      (let ((content-header (find-header babyl-mesg "content-type")))
	(when content-header
	  (SAVE-PARTS (char-code-vector babyl-mesg)
		      :content-type content-header))))))

(defmethod find-message ((babyl-file indexed-babyl-file) n)
  (do-messages (i msg babyl-file)
    (if (= i n) (return msg))))

(defun rfc822-tokenizer (char-buffer &key (start 0) end collect-fn
			 (specials "()<>@.;:\\.[]"))
  "Return three values: the type, and the start and end positions of the
next token. The type is one of :SPECIAL :QUOTED-STRING :COMMENT or
:DOMAIN-LITERAL. CHAR-BUFFER is an array of characters. SPECIALS is a
sequence of characters which are tokenized literally. COLLECT-FN
if non-nil is a function which takes a single character as argument;
It is mapped across the characters of tokens of type :QUOTED-STRING or
:DOMAIN-LITERAL. (:COMMENTs are ignored)."
  (declare (type string char-buffer specials))
  (unless end (setq end (length char-buffer)))
  (prog ((pos start) (state :init) char (nesting 0)) loop
     (cond ((null (setq char (and (< pos end) (aref char-buffer pos))))
	    (return (values (if (eq state :atom) :atom :eos) start end)))
	   (t (ecase state
		(:init (cond ((or (char= char #\Space) (char= char #\Tab)
				  (char= char #\Newline)) ; XXX
			      (incf start) (incf pos) (go loop))
			     ((char= char #\() (setq state :comment)
			      (incf nesting) (incf pos) (go loop))
			     ((char= char #\")
			      (setq state :quoted-string) (incf pos) (go loop))
			     ((char= char #\[) (setq state :domain-literal)
			      (incf pos) (go loop))
			     ((find char specials)
			      (return (values :special start (1+ pos))))
			     (t (setq state :atom) (incf pos) (go loop))))
		(:comment (cond ((char= char #\))
				 (decf nesting)
				 (cond ((zerop nesting)
					(return (values state start (1+ pos))))
				       (t (incf pos) (go loop))))
				((char= char #\\) (incf pos 2) (go loop))
				(t (incf pos) (go loop))))
		((:quoted-string :domain-literal)
		 (cond ((char= char #\\)
			(when collect-fn
			  (if (< (1+ pos) end)
			      (funcall collect-fn
				       (aref char-buffer (1+ pos)))))
			(incf pos 2) (go loop))
		       ((or (and (eq state :quoted-string)
				 (char= char #\"))
			    (and (eq state :domain-literal)
				 (char= char #\])))
			(return (values state start (1+ pos))))
		       (t (when collect-fn
			    (funcall collect-fn (aref char-buffer pos)))
			  (incf pos) (go loop))))
		(:atom (cond ((or (<= (char-code char) (char-code #\Space))
				  (find char specials))
			      (return (values state start pos)))
			     (t (incf pos) (go loop)))))))))

(defun parse-message-id (string &key (start 0) end)
  (let ((pos start) (eos (or end (length string))) (specials "<>")
	retbeg retend)
    (and (multiple-value-bind (type tokstart tokend)
	     (rfc822-tokenizer string :start pos :end eos :specials specials)
	   (prog1 (and (eq type :special) (char= (aref string tokstart #\<)))
	     (setq pos tokend)))
	 (let (type)
	   (multiple-value-setq (type retbeg retend)
	     (rfc822-tokenizer string :start pos :end eos :specials specials))
	   (prog1 (eq type :atom)
	     (setq pos retend)))
	 (multiple-value-bind (type tokstart tokend)
	     (rfc822-tokenizer string :start pos :end eos :specials specials)
	   (prog1 (and (eq type :special)
		       (char= (aref string tokstart #\<)))
	     (setq pos tokend)))
	 (subseq string retbeg retend))))

(defun snarf-message-ids (babyl-file &optional
			    (hash-table (make-hash-table :test #'equal)))
  (do-messages (i msg babyl-file)
    (let* ((message-id (PARSE-MESSAGE-ID (find-header msg "Message-ID")))
	   (plist (or (gethash message-id hash-table)
		      (setf (gethash message-id hash-table)
			    (make-instance 'plist-mixin)))))
      (incf (get-property plist :count 0))
      (push (cons i msg) (get-property plist :msg))))
  hash-table)

(defun %get-babyl-messages-with-message-ids (hash-table &rest message-ids)
  "obviously HASH-TABLE is a hash-table of message-ids -> msg"
  (loop for message-id in message-ids
	nconc (multiple-value-bind (plist present-p)
		  (gethash message-id hash-table)
		(when present-p		; return multiple copies
		  (loop for (i . msg) in (get-property plist :msg)
			collect msg)))))

(defun delete-duplicate-messages (babyl-file &optional
				   (message-id-hash-table
				    (snarf-message-ids babyl-file)))
  "=> list of messages (with duplicate message-ids) deleted from BABYL-FILE"
  (loop for message-id being each hash-key in message-id-hash-table
	using (hash-value plist) when plist nconc
	(loop while (> (get-property plist :count) 1) collect
	      (destructuring-bind (i . msg) (pop (get-property plist :msg))
		(assert (eq msg (find-message babyl-file i)))
		(delete-message babyl-file i)
		(decf (get-property plist :count))
		msg))))

;;; Utils
;;;
;;;

(defun difference (hash-table-1 hash-table-2)
  "return a list of keys of hash-table-1 that are not present in hash-table-2"
  (loop for key1 being each hash-key in hash-table-1
	if (multiple-value-bind (val present-p)
	       (gethash key1 hash-table-2)
	     (declare (ignore val))
	     (unless present-p key1))
	collect it))

;;;
;;;
;;;

(defmethod write-nnfile ((msg simple-babyl-message) stream)
  (with-slots (babyl-file) msg
      (with-slots (buf) babyl-file
	(macrolet ((write-indices (indices)
		     `(destructuring-bind (type &key start end) ,indices
			(declare (ignore type))
			(write-string buf stream :start start :end  end))))
	  (with-slots (bit-char message-indices) msg
	    (if bit-char
		(write-indices (assoc :invisible-headers message-indices))
		(write-indices (assoc :visible-headers message-indices)))
	    (terpri stream)
	    (write-indices (assoc :body message-indices))))))
  nil)

;; TODO condition system+prompt
(defmethod %get-nndir-output-file-name ((msg simple-babyl-message) &optional
					msgno)
  "Return the XREF string. If XREF header is not found, use MSGNO
if supplied. Otherwise find the MSGNO and return it. Returns a
string. Returns NIL on failure."
  (let ((xref-string (find-header msg "Xref")))
    (cond (xref-string
	   (let ((pos (position #\: xref-string :from-end t)))
	     (assert pos)
	     (assert (numberp (parse-integer xref-string :start (1+ pos))))
	     (values (subseq xref-string (1+ pos)) :xref)))
	  ((stringp msgno) (values msgno :supplied-msgno))
	  ((integerp msgno) (values (write-to-string msgno) :supplied-msgno))
	  ((null msgno)
	   (loop for msgno being each hash-key of (slot-value msg 'index)
		 using (hash-value x) when (eq x msg)
		 do (assert (integerp msgno)) and
		 return (values (write-to-string msgno) :msgno))))))

(defgeneric babyl-file->nndir (babyl-file directory-pathname)
  (:method ((babyl-file-pathname string) directory-pathname)
    (babyl-file->nndir (pathname babyl-file-pathname) directory-pathname))
  (:method ((babyl-file-pathname pathname) directory-pathname)
    (babyl-file->nndir (slurp-indexed babyl-file-pathname) directory-pathname))
    (:documentation "Dump rmail messages, each as a mail file in
DIRECTORY-PATHNAME, Names the nn files with the position index in the BABYL
file"))

;; XXX SLIME BUG reported on 20050227
(defmacro with-pathname-fu ((pathname-var) &body body)
  "On encountering a FILE-ERROR arrange during execution of BODY
arrange for a restart to interactively change the value of
PATHNAME-VAR. Typically BODY is expected to be a WITH-OPEN-FILE."
  `(prog ()
    loop
    (restart-case
	(cl:return (multiple-value-prog1 (progn ,@body)))
      (delete-it ()
; XXX	:test (lambda (c) (typep c 'file-error))
	:report (lambda (stream) (format stream "delete ~S" ,pathname-var))
	(cond ((delete-file ,pathname-var)
	       (warn "deleted ~S" ,pathname-var))
	      (t (warn "deleting ~S failed" ,pathname-var)))
	(go loop))
      (choose-new-pathname ()
; XXX	:test (lambda (c) (typep c 'file-error))
	:report (lambda (stream)
		  (format stream "Use a different pathname."))
	(format t "Enter a new pathname for #'READ: ")
	(let (*read-eval*)
	  (setq ,pathname-var (read)))
	(go loop)))))

(defmethod babyl-file->nndir ((indexed-babyl-file indexed-babyl-file)
			      directory-pathname)
  "Dump rmail messages, each as a mail file in DIRECTORY-PATHNAME,
Names the nn files with the position index in the BABYL file"
  (with-slots (buf) indexed-babyl-file
    (do-messages (i msg indexed-babyl-file)
      (with-simple-restart (cont "Continue")
	(when (slot-value msg 'bit-char)
	  (warn "removing rmail headers from msgno ~D!" i)
	  (unreform msg))
	(multiple-value-bind (filename XXX) (%get-nndir-output-file-name msg)
	  (warn "writing ~A/~D [From ~A]." directory-pathname filename XXX)
	  (let ((output-pathname (make-pathname :name filename :type nil
						:version nil
						:defaults directory-pathname)))
	    (with-pathname-fu (output-pathname)
	      (with-open-file (stream output-pathname
				      :direction :output
				      :if-does-not-exist :create)
		(macrolet ((write-indices (indices)
			     `(destructuring-bind (type &key start end) ,indices
				(declare (ignore type))
				(write-string buf stream :start start :end  end))))
		  (with-slots (bit-char message-indices) msg
		    (if bit-char
			(write-indices
			 (assoc :invisible-headers message-indices))
			(write-indices (assoc :visible-headers message-indices)))
		    (terpri stream)
		    (write-indices (assoc :body message-indices))))))))))))

(defun nndir->babyl-file (nndir-pathname babyl-pathname)
  "NNDIR-PATHNAME is either a pathname designator for a directory, or a list
of pathnames of individual mail messages."
  (with-open-file (stream babyl-pathname :direction :output
		   :if-exists :supersede)
    (write-line "BABYL OPTIONS: -*- rmail -*-" stream)
    (write-line "Version: 5" stream)
    (write-line "Labels:" stream)
    (write-line "Note: Converted automatically by nndir-to-babyl-file" stream)
    (write-char +terminator+ stream)
    (loop for file in
	  (etypecase nndir-pathname
	    ((or string pathname)
	     (directory (make-pathname :name :wild :type :wild :version :wild :defaults nndir-pathname)))
	    (list nndir-pathname))
	  do
	  (write-char #\page stream)
	  (terpri stream)
	  (write-line "0, unseen,," stream)
	  (write-line +eooh-line+ stream)
	  (with-open-file (in file)
	    (loop for line = (read-line in nil nil)
		  while line do
		  (write-line line stream)))
	  (write-char +terminator+ stream))))

(defmacro getf-delete (place indicator  &optional default) ; plist-sans-key
  "Internal. Retrieve value for given KEY in plist. Modfies PLIST
by deleting the KEY and VALUE."
  `(let (prev (plist ,place))
     (loop (if (endp plist)
	       (return ,default)
	       (if (eql (car plist) ,indicator)
		   (return (prog1 (cadr plist)
			     (if (endp prev)
				 (setq ,place (cddr ,place))
				 (setf (cdr prev) (cddr plist)))))
		   (setq prev (cdr plist) plist (cddr plist) ))))))

#+nil
(let ((a '(:baz baz :foo bar :bar car)))
  (values (getf-delete a :bar) a))


;;; ----------------------------------------------------------------------
;;;
;;;
#+cl-ppcre
(defmethod babyl-messages-containing-regexp ((babyl-file simple-babyl-file)
					     (regexp string)
					     &rest rest &key from
					     case-sensitive-mode
					     multi-line-mode)
  "Return a list of numbers, corresponding to messages which
match REGEXP. GF Takes A KEY, `:FROM', which should be NIL for
this method. Other keys are passed to CREATE-SCANNER."
  (let ((scanreg (apply #'cl-ppcre:create-scanner regexp rest))
	collected)
    (ecase from
      ('nil)
      ((:status-line :invisible-headers :visible-headers :body)
       (error "Cannot specify FROM when searching SIMPLE-BABYL-FILE" )))
    (with-slots (buf msgs) babyl-file
      (loop for (msgno . message-indices) in msgs
	    do (destructuring-bind (&key start end) message-indices
		 (multiple-value-bind (match-start match-end reg-starts
						   reg-ends)
		     (cl-ppcre:scan scanreg buf :start start :end end)
		   (when match-start
		     (push msgno collected))))))
    collected))

#+cl-ppcre
(defmethod babyl-messages-containing-regexp
    ((babyl-file indexed-babyl-file) (regexp string) &rest rest &key
     (from :body from-supplied-p)
     case-sensitive-mode multi-line-mode)
  "Return a list of numbers, corresponding to messages whose
bodies match REGEXP. The keyword argument :FROM should correspond
to an indicator in the MESSAGE-INDICES slot of
SIMPLE-BABYL-MESSAGE. Other keyword arguments are passed are
passed to CREATE-SCANNER."
  (ecase from
    ((:status-line :invisible-headers :visible-headers :body)
     (when from-supplied-p
       (let ((x (getf-delete rest :from)))
	 (assert (eq x from) nil
		 "getf :FROM yielded ~S which is not ~S, rest=~S"
		 x from rest)))))
  (let ((scanreg (apply #'cl-ppcre:create-scanner regexp rest))
	collected)
    (with-slots (buf) babyl-file
      (do-messages (msgno babyl-msg babyl-file)
	(with-slots (message-indices) babyl-msg
	  (let ((body-cons (assoc FROM message-indices)))
	    (when body-cons
	      (destructuring-bind (&key start end) (cdr body-cons)
		(multiple-value-bind (match-start match-end reg-starts
						  reg-ends)
		    (cl-ppcre:scan scanreg buf :start start :end end)
		  (when match-start
		    (push msgno collected)))))))))
    collected))


;;; ----------------------------------------------------------------------
;;;
;;;
(defvar +basic-labels+ '("deleted" "unseen" "recent" "answered"))

#+nil
(defun parse-status-line (string &key start end)
  "Return a plist with two keys :basic-labels and user-labels. Values are
lists of strings."
  (unless start (setq start 0))
  (unless end (setq end (length string)))
  (ecase (aref string start)
    ((#\0 #\1)))
  (let ((split (search ",," string :start2 (1+ start) :end2 end))
	(endpos (position #\, string :start (1+ start) :end end :from-end t))
	basic-labels user-labels)
    (assert split)
    (assert endpos)
    (when (> split (1+ start))
      (setq start (1+ start))
      (loop
	 (assert (> split start))
	 (assert (char= (aref string start #\,)))
	 (assert (char= (aref string (+ 1 start) #\Space)))
	 (let ((pos (position #\, string :start (+ 2 start) :end split)))
	   (cond ((null pos)
		  (push (subseq string (+ 2 start) split) basic-labels)
		  (return))
		 (t (push (subseq string (+ 2 start) pos) basic-labels)
		    (setq start pos))))))
    (when basic-labels
      (loop for label in basic-labels
	    unless (find label +basic-labels+ :test #'string=)
	    do (cerror "Continue" "~S not a basic label" label)))
    (when (> endpos (+ 1 split))
      (setq start (1+ split))
      (loop
	 (assert (> endpos start))
	 (assert (char= (aref string start) #\,))
	 (assert (char= (aref string (1+ start)) #\Space))
	 (let ((pos (position #\, string :start (+ 2 start) :end endpos)))
	   (cond ((null pos)
		  (push (subseq string (+ 2 start) end) user-labels)
		  (return))
		 (t (push (subseq string (+ 2 start) pos) user-labels)
		    (setq start pos))))))
    (list :basic-labels  basic-labels :user-labels user-labels)))

#+nil
(parse-status-line "0, unseen,, foo, bar, car,")

(defun write-status-line (bit-char-p &key basic-labels user-labels
			  (stream *standard-output*))
  "Does not add trailing newline."
  (declare (type boolean bit-char-p))
  (if bit-char-p
      (write-char #\1 stream)
      (write-char #\0 stream))
  (write-char #\, stream)
  (loop for x in basic-labels do
	(unless (find x +basic-labels+ :test #'string=)
	  (cerror "OK" "~S not a basic label" x))
	(write-char #\Space stream)
	(write-string x stream)
	(write-char #\, stream))
  (write-char #\, stream)
  (loop for x in user-labels do
	(write-char #\Space stream)
	(write-string x stream)
	(write-char #\, stream)))

#+nil
(with-output-to-string (*standard-output*)
  (write-status-line nil :basic-labels '("unseen")
		     :user-labels '("porn" "mov")))


;;; ----------------------------------------------------------------------
;;;
;;;
(defun parse-options-line (string &key start end)
  "Collects comma separated strings in the line STRING into a
list. Ignores preceeding whitespace. Doesnt collect empty
strings. NOTE STRING should not contain newline."
  (let ((start (or start 0))
	(end (or end (length string))))
    (loop for begpos = start then (1+ endpos)
	  for endpos = (position #\, string :start begpos :end end)
	  do (loop while (and (< begpos end)
			      (let ((c (aref string begpos)))
				(if (or (char= c #\Space)
					(char= c #\Tab))
				    (incf begpos)))))
	  when (> (or endpos end) begpos) ; XXX
	  collect (subseq string begpos (or endpos end))
	  unless endpos do (loop-finish))))

(defun parse-status-line (string &key start end)
  "Return a plist with two keys :basic-labels and user-labels, values
are lists of strings."
  (unless start (setq start 0))
  (unless end (setq end (length string)))
  (ecase (aref string start)
    ((#\0 #\1)))
  (let ((split (search ",," string :start2 (1+ start) :end2 end))
	(endpos (position #\, string :start (1+ start) :end end :from-end t))
	basic-labels user-labels)
    (assert split)
    (assert endpos)
    (when (> split (+ 2 start))
      (setq basic-labels (parse-options-line string :start (+ 2 start)
					     :end split)))
    (when basic-labels
      (loop for label in basic-labels
	    unless (find label +basic-labels+ :test #'string=)
	    do (cerror "Continue" "~S not a basic label" label)))
    (when (> endpos (+ 2 split))
      (setq user-labels (parse-options-line string :start (+ 2 split)
					    :end endpos)))
     (list :basic-labels  basic-labels :user-labels user-labels)))

#||
(parse-options-line " foo, bar, car, var")
(parse-options-line " unseen,")
(parse-options-line "")
(parse-options-line "  ")
(search ",," "0,,")
(parse-status-line "0, unseen,, foo, bar, car,")
(parse-status-line "0,, ")
(parse-status-line "0,, bar,")
||#


;;; ------------------------------------------------------------------------
;;;
;;;
(defmethod babyl-options-section ((simple-babyl-file simple-babyl-file))
   "Returns a new string containing the options section of the
babyl file upto the terminator character"
  (with-slots (buf) simple-babyl-file
    (subseq buf 0 (position +terminator+ buf))))

(defun modify-options-line (string &key (key "Labels:") add delete)
  "STRING is an options section of a babyl file. KEY is a
colon-terminated options key, whose values are comma separated.
ADD and DELETE are lists of strings. Modifies the line in the
options STRING for KEY by removing the values present in DELETE
and adding values present in ADD. Returns a new string."
  (let* ((start 0)
	 (end (length string))
	 (begpos (search key string :start2 start :end2 end))
	 (keylen (length key)))
    (let* ((endl (position #\Newline string :start (+ begpos keylen)
			   :end end))
	   (labels (parse-options-line string :start (+ begpos keylen)
				       :end (or endl end))))
      (loop for x in delete
	    do (setq labels (delete x labels :test #'string=)))
      (loop for x in add
	    do (pushnew x labels :test #'string=))
      (with-output-to-string (stream)
	(write-sequence string stream :end (+ begpos keylen))
	(format stream "~{ ~A~^,~}" labels)
	(write-sequence string stream :start endl)))))

#||
(setq $s  "BABYL OPTIONS: -*- rmail -*-
Version: 5
Labels: double-double
Note:   This is the header of an rmail file.
Note:   If you are seeing it in rmail,
Note:    it means the file has no messages in it.
")
(modify-options-string $s
		       :delete '("double-double")
		       :add '("dd-reader" "dd-branch" "dd-array"))
||#

(defun parse-options (string &key start end)
  "STRING should be the options section of a babyl file. Returns
a list of alternating option key option value pairs. Each option
key is a string. For known option keys the value is a list into
which comma separated option values have been parsed."
  (loop for posbeg = (or start 0) then (1+ posend)
	for posend = (position #\Newline string :start posbeg
				   :end (or end (setq end (length string))))
	nconc (let ((pos (position #\: string :start posbeg :end posend)))
		(assert pos)
		(let* ((option-name (subseq string posbeg pos))
		       (option-value
			(cond ((or (string= option-name "MAIL")
				   (string= option-name "Version") ;XXX
				   (string= option-name "Labels"))
			       (parse-options-line string :start (1+ pos)
						   :end posend))
			      (t (subseq string (1+ pos) posend)))))
		  (list option-name option-value)))
	unless posend do (loop-finish)))

#+nil
(parse-options "BABYL OPTIONS: -*- rmail -*-
Version: 5
Labels:double-double-branch
Note:   This is the header of an rmail file.
Note:   If you are seeing it in rmail,
Note:    it means the file has no messages in it.")