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

;; Archive Select Lisp

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

;; This procedure selects all files in the current directory that are older
;; than "base" which is time in seconds since last modification.
;; "base" is passed to the function when the function is called.
;; i.e. (archive-select 7776000) would select all files that have not been
;; modified within 90 days. Directories, (which include books, folders,
;; drawers, cabinets, binders and directories) are only selected if everything
;; contained within them have not been modified since "base".

;; Place this lisp in the Leafware Library cabinet. If you do not have leafware
;; you can place it anywhere you wish, but be sure to include the path name
;; in the SELECT_FILE.lsp.


;; begin
(defun archive-select(base)

(let ((test)
      (date)
     )
     ;; create a file to extract the current date (date is in seconds)
     (psetq test (dt-create "temp"))
     ;;extract date
     (psetq date (dt-get-property test :modify-time))
     ;;delete temp file
     (dt-delete test)

;;define the recursive procedure to check directories and sub-directories
          ;; 'cntnr' is the container passed to the function when it is called.
  (defun arc-select-recursive (cntnr)
          ;; save current default
    (let ((save-cntnr (dt-get-container))
          ;;set up empty variables
          (f)
          (file)
          (obj))
 
      ;; set default to cntnr
      (if (not (eql cntnr save-cntnr))
          (dt-set-container cntnr)
      )
      ;; get first object in cntnr
      (setq f (dt-child))  
      ;; continue if there are still objects in the directory and the user
      ;; has not hit cancel
      (while (and f (not (keyboard-cancel)))
        ;; if object is a directory
        (if (member (dt-get-property f :type)
                    '(book folder cabinet drawer directory)) 
                    ;;then
                    ;;recall the function with f as the cntnr
                    (progn (arc-select-recursive f) 

                           ;;function will return to this point.

                           ;;if there are not any documents left in the cntnr
                           ;;that are not selected
                           (if (not (dt-child-not-selected f))
                                    ;;then select the cntnr
                                    (dt-set-property f :selected)
                           )
                           ;;deselect all files within cntnr
                                  ;;set file to a list equal to all children
                                  ;;selected in cntnr
                           (progn (psetq file (dt-children-selected f))
                                  (while file
                                     ;;set obj to first child in the list
                                     (psetq obj (car file))
                                     ;;deselect obj
                                     (dt-set-property obj :not-selected)
                                     ;;set file to the rest of the list
                                     (psetq file (cdr file))           
                                  )
                           )
                    )
                    ;;else (object is not a directory).
                    ;;if the modify time of object is less than the
                    ;;current date minus "base"
                    (if (< (dt-get-property f :modify-time) (- date base))
                        ;;then select the file
                        (dt-set-property f :selected)
                        ;;else make sure it is not selected
                        (dt-set-property f :not-selected)
                    )
        )
        ;;select the next object in the cntnr
        (setq f (dt-sibling f))
      )
      ;;set default back to original cntnr
      (if (not (eql cntnr save-cntnr))
          (dt-set-container save-cntnr)
      )
    )
  )
;;call the function for the first time with the default directory as cntnr
(arc-select-recursive(dt-get-container))
)
)