;;;
;;; file-functions
;;;
;;; This module provides functions for storing and retrieving
;;; object data from files.
;;;
;;; 23-Feb-2005 I. Kalet taken from Prism and simplified
;;;

;;;-------------------------------------------------------
;;; these are required because the MOP is not standard yet
;;;-------------------------------------------------------

(defun slot-names (obj)

  "slot-names obj

returns a list of slot names defined for the class of which object obj
is a member, using the MOP."

  #+allegro (mapcar #'clos:slot-definition-name
		    (clos:class-slots (class-of obj)))
  #+clisp (mapcar #'clos::slotdef-name
		  (clos::class-slots (class-of obj)))
  )

;;;-----------------------------------------

(defun slot-initargs (slot)

  "from PORT, returns a list of initarg symbols for the slot named
  slot"

  #+allegro (clos:slot-definition-initargs slot)
  #+(and clisp (not mop)) (clos::slotdef-initargs slot)
  #+(and clisp mop) (clos::slot-definition-initargs slot)
  #+cmu (slot-value slot 'pcl::initargs)

  )

;;;------------------------------------------
;;; These are the least specific methods for
;;; generic functions slot-type and not-saved.
;;;------------------------------------------

(defmethod slot-type ((object t) slotname)

  "slot-type object slotname

This is a default method for the generic function that returns the
slot type of a slot.  Individual classes must provide their own
methods to return one of the keywords, :object or :object-list,
if any slots are different from :simple.  If all slots are of type
:simple then the class needs no method and this default method will
suffice."

  (declare (ignore slotname))
  :simple)

;;;-------------------------------------------

(defmethod not-saved ((object t))

  "not-saved object

The default method for the generic function that returns a list of
slot names which should NOT be saved in an external file.  An example
of this method for class foo which does not want to save slot c would
look like (defmethod not-saved ((object foo)) '(c))"

  nil)

;;;-------------------------------------------

(defun get-object (in-stream)

  "get-object in-stream

reads forms from in-stream, filling in slots of a new instance of the
class for the first symbol read from the stream.  The data are assumed
to be in the form <slot name> <slot value>, except if the slot is a
list of other objects,in which case, get-object is called recursively
to construct the list.  The data for an object are terminated with a
keyword :END.  It returns the newly created instance along with any
component objects, or nil if the first keyword read from in-stream is
the keyword :END. So, :END means either end of an object list, or end
of an object."

  (let* ((current-key (read in-stream))
	 (object (if (eq current-key :end) nil ; end of object list
		   (make-instance current-key))))
    (unless (null object)
      (loop
	(setq current-key (read in-stream))
	(when (eq current-key :end)	; end of object
	  (return object))
	(if (eq (slot-type object current-key) :ignore)
	    (read in-stream)		; throw away the value - usually nil
	  (setf (slot-value object current-key) ; otherwise process it
	    (case (slot-type object current-key)
	      (:simple (read in-stream))
	      (:object (get-object in-stream))
	      (:object-list
	       (let ((slotlist '())
		     (next-object nil))
		 (loop
		   (setq next-object (get-object in-stream))
		   (cond (next-object (push next-object slotlist))
			 (t (return (nreverse slotlist)))))))
	      )))))))

;;;----------------------------------

(defun tab-print (item stream tab &optional (cr nil))

  "tab-print item stream tab &optional (cr nil)

Given an item (eg symbol), a stream, a tab value (an integer), and
optionally instructions to format a carriage return, a string
representation of the item is printed after the appropriate number of
blank spaces, as specified by tab value."

  (format stream "~a"
	  (concatenate 'string
		       (make-string tab :initial-element #\space)
		       (write-to-string item :pretty t)
		       (make-string 2 :initial-element #\space)))
  (when cr (format stream "~%")))

;;;----------------------------------

(defun put-object (object out-stream &optional (tab 0))

  "put-object object out-stream &optional (tab 0)

writes a printed representation of object to the stream out-stream, in
a form suitable to be read in by get-object.  It needs two generic
functions, slot-type and not-saved.  For each slot except those
returned by not-saved, it writes the slot name, then a form that
depends on the type of data supposed to be in that slot, as specified
by the value of (slot-type object slotname).  Tabs are optionally used
to indent object names and slot-values hierarchically to make files
more readable by humans."

  (tab-print (class-name (class-of object)) out-stream tab t)
  (mapc #'(lambda (slotname)
	    (when (slot-boundp object slotname)
	      (tab-print slotname out-stream (+ 2 tab))
	      (case (slot-type object slotname)
		(:simple (tab-print (slot-value object slotname)
				    out-stream 0 t))
		(:object (fresh-line out-stream)
			 (put-object (slot-value object slotname)
				     out-stream (+ 4 tab)))
		(:object-list
		 (fresh-line out-stream)
		 (mapc #'(lambda (obj)
			   (put-object obj out-stream (+ 4 tab)))
		       (slot-value object slotname))
		 (tab-print :end out-stream (+ 2 tab) t)) ; terminates list
		)))
	(set-difference (slot-names object) (not-saved object)))
  (tab-print :end out-stream tab t))	; terminates object

;;;----------------------------------

(defun get-all-objects (filename)

  "get-all-objects filename

opens file named filename, iteratively calls get-object to accumulate
a list of all the objects found in the file, until end of file is
reached.  Returns the list of object instances.  If the file does not
exist, returns nil."

  (with-open-file (stream filename
			  :direction :input
			  :if-does-not-exist nil)
    (when (streamp stream)
      (let ((object-list '()))
	(loop
	  (cond ((eq (peek-char t stream nil :eof) :eof)
		 (return object-list))
		(t (push (get-object stream) object-list))))))))

;;;----------------------------------

(defun put-all-objects (object-list filename)

  "put-all-objects object-list filename

opens file named filename, iteratively calls put-object on successive
elements of the list object-list.  If a file named filename already
exists, a new version is created."

  (with-open-file (stream filename
			  :direction :output
			  :if-exists :new-version)
    (dolist (obj object-list)
      (put-object obj stream))))

;;;----------------------------------
;;; End.