(lisp-set-implementation "Interleaf Lisp" "1.0")

;; Compile List Lisp

;; Created By William Wagner 13-APR-1990   AiResearch Tucson Division

;; This lisp compiles a list of the pathnames of all the items selected
;; within the current container. The list is then used by a command procedure
;; that is submitted to a batch queue to do the actual archiving.

;; Place this lisp in the Custom Selection Cabinet. Then move cursor into
;; a container with selected documents and use the pull down menu to select
;; Custom > Compile list.

;; define error handling funtion.
;; if the list is currently open by the archive procedure,
;; display a warning and exit.

(defun error(param)
    (display-stickup "An Archive is currently in progress.
Please try again later" :continue)
    (quit)
)

;; if a list already exists, and they have not already received a warning,
(if (and (not (boundp 'notice))
         (probe-file "ddcu:[directory]temp_out.lis")
    )
;; display a warning
    (if (display-stickup "A Compiled list already exists.
Do you wish to add to the existing file ?" :yes-no)
	;; if they answer yes, set notice to true so warning will not be
	;; repeated. Then continue
        (psetq notice t)
	;; else exit
        (quit)
    )
)

;; begin main function
;; set notice to true first time around
(psetq notice t)
;; set up error handling and variables
(let ((new)
      (break-on-error t)
      (break-handler 'error)
      ;; open a file for output, append if it exists, create it if it does not
      ;; change ddcu:[directory] to what ever path you wish.
      (file (open "ddcu:[directory]temp_out.lis" :output :character :append :create))
      (list (dt-children-selected))
     )
     ;; while there are items selected
     (while list
            ;; write the path name of the first object on the list to the file
            (write-line (dt-get-property (car list) :path-name) file)
	    ;; deselect object
            (dt-set-property (car list) :not-selected)
	    ;; hide the object so person can not select it again
            (dt-set-property (car list) :hidden)
	    ;; get next object in list
            (setq list (cdr list))
     )
     (close file)
)