;;; -*- Mode:LISP; Package:USER; Readtable:CL; Base:10 -*-

(defvar *mark-file-property* nil)
(defvar *mark-file-valid-properties*
	'(:dont-delete :dont-reap :author :not-backed-up))

(defun mark-files(pathname &optional (property *mark-file-property*))
  (do ()
      ((or (and property (intern-soft property :keyword))
	   (ignore (beep))))
    (format t "~%Specify a file property keyword to set: ")
    (setq property (string-upcase (readline))))
  (unless (member property *mark-file-valid-properties*)
    (cerror "Proceed anyway (it's your funeral) to set ~a property"
	    "~a is not a standard file property; should you mark files this way?"
	    property))
  (let* ((path (merge-pathnames pathname
				(make-pathname :directory :wild
					       :name :wild :type :wild
					       :version :highest)))
	 (files (directory path))
	 (num (length files))
	 (set-to :init))
    (format t "~&Files for ~a ~:[not found.~;~:*are:~&  ~~{~s~&~}~~]" path files)
    (cond ((= num 0) (return-from mark-files nil))
	  ((= num 1) (setq set-to (fquery '(:type :tyi :choices (((t   "Set to TRUE")  #\T)
								 ((nil "Set to FALSE") #\F)))
					  "Set ~a to: " property)))
	  ((yes-or-no-p "Proceed to mark for ~a?" property)
	   (setq set-to
		 (fquery '(:type :tyi :choices (((t   "Set for all files to TRUE")  #\T)
						((nil "Set for all files to FALSE") #\N)
						((:swap "Swap T/NIL for all files") #\S)
						((:ask "Ask for value per file") #\? #\V)))
			 "How do you want to set ~a?" property)))
	  (t (return-from mark-files nil)))
    (dolist (file files)
      (format t "~&~a -- " file)
      (fs::change-file-properties
	file t property
	(cond ((eq set-to t) t)
	      ((eq set-to nil) nil)
	      (t
	       (let* ((plist (send file :properties))
		      (value (get plist property)))
		 (case set-to
		   (:swap (not value))
		   (:ask
		    (format t "File ~a has a value of ~s for property ~s."
			    file value property)
		    (format t "~&  Type an expression for new value: ")
		    (read)))))))
      (format t "~s" (get (fs:file-properties file) property)))))