Re: Ejected disks.

[pwtc!cdj@labrea.stanford.edu (Cris Johnson)]

	From: Richard Lynch <labrea!lynch@aristotle.ils.nwu.edu>
	To: info-macl@cambridge.apple.com
	Subject: Ejected disks.

	If you eject a disk and then call (choose-file-dialog), the system will ask for
	it.  But if the icon has been thrown in the trash, you get an error.  Assuming
	you are writing an application for use in MultiFinder, this is a real problem.
	Does anyone know of a way to convince MACL that the ejected disks are ejected?


It turns out that "choose-file-directory" and "choose-new-file-directory"
make use of the global variable *DEFAULT-CHOOSE-FILE-DIRECTORY* to
remember where you last were opening/creating new files, and they get
confused when that variable refers to a no-longer-mounted disk.
I run the following out of my init.lisp file that preceeds each call to
to those functions with a check on the validity and possible
reassignment of the global variable.

As the pull-down menus that use these functions come compiled from the
MACL factory, redefining the functions doesn't help there and I fool
with the menu-items themselves to make things work.

Cris Johnson 
Price Waterhouse Technology Centre 
68 Willow Road, Menlo Park, CA 94025 
(415) 322-0606


(let ((*warn-if-redefine* nil)
      (*warn-if-redefine-kernel* nil))
(declare (special *warn-if-redefine-kernel*)
         (special *warn-if-redefine*))
(macrolet ((find-titled-menu-item (n1 n2)
                                  `(ask (find-menu ,n1)
                                     (find ,n2 (menu-items)
                                           :key #'(lambda (i)
                                                    (ask i (menu-item-title)))
                                           :test #'string-equal)))
           (assure-default-dir ()
                               `'(let ((dcfd (namestring
                                              (expand-logical-pathname
                                               *DEFAULT-CHOOSE-FILE-DIRECTORY*))))
                                   (unless (member
                                            (subseq dcfd 0 (1+ (position #\: dcfd)))
                                            (mapcar #'namestring (devices))
                                            :test #'string-equal)
                                     (setq *DEFAULT-CHOOSE-FILE-DIRECTORY*
                                           (namestring (car (devices))))))))
(let ((os (ask (find-titled-menu-item "File" "OpenI") ; CCL "Open..." ends with a funny char that I bet won't make it though the mails
            (objvar ccl::menu-item-action-iv)))
      (ns (gensym)))  ; ccl 1.2.2 really wants a symbol for passing function values about
  (eval `(setf (symbol-function ',ns) (symbol-function ',os)))
  (eval `(defun ,os ()
           (progn
             ,(assure-default-dir)
             (funcall ',ns)))))
(let ((wsa (gensym)))                 ; relates to "Save As ..."
  (eval `(setf (symbol-function ',wsa)
               (ask *fred-window* (symbol-function 'window-save-as))))
  (eval `(defobfun (window-save-as *fred-window*) ()
           (progn
             ,(assure-default-dir)
             (funcall ',wsa)))))
(let ((mi (find-titled-menu-item "Eval" "LoadI")) ; See above remark for "Open..."
      (mia (gensym)))
  (eval `(ask ,mi
           (setf (symbol-function ',mia) (symbol-function 'menu-item-action))
           (setf (symbol-function 'menu-item-action)
                 #'(lambda ()
                     ,(assure-default-dir)
                     (funcall ',mia))))))
(let ((mi (find-titled-menu-item "Eval" "Compile FileI"))
      (mia (gensym)))
  (eval `(ask ,mi
           (setf (symbol-function ',mia) (symbol-function 'menu-item-action))
           (setf (symbol-function 'menu-item-action)
                 #'(lambda ()
                     ,(assure-default-dir)
                     (funcall ',mia))))))
(let ((cfd (gensym)))
  (eval `(setf (symbol-function ',cfd) (symbol-function 'choose-file-dialog)))
  (eval `(defun choose-file-dialog (&rest args)
           (unless (getf args :directory nil) ,(assure-default-dir))
           (apply ',cfd args))))
(let ((cnfd (gensym)))
  (eval `(setf (symbol-function ',cnfd) (symbol-function 'choose-new-file-dialog)))
  (eval `(defun choose-new-file-dialog (&rest args)
           (unless (getf args :directory nil) ,(assure-default-dir))
           (apply ',cnfd args))))
)) ;end no-warn-if-redefine