[climacs-cvs] CVS update: climacs/file-commands.lisp

[Dave Murray]

Update of /project/climacs/cvsroot/climacs
In directory common-lisp:/tmp/cvs-serv26169

Modified Files:
	file-commands.lisp 
Log Message:
Added defaults to find-file commands, thanks to
Troels "Athas" Henriksen. Needs a recent mcclim.

Date: Sat Jan 21 14:38:50 2006
Author: dmurray

Index: climacs/file-commands.lisp
diff -u climacs/file-commands.lisp:1.1 climacs/file-commands.lisp:1.2
--- climacs/file-commands.lisp:1.1	Sat Nov 12 03:38:32 2005
+++ climacs/file-commands.lisp	Sat Jan 21 14:38:50 2006
@@ -169,8 +169,21 @@
 		 (redisplay-frame-panes *application-frame*)
 		 buffer))))))
 
+(defun directory-of-buffer (buffer)
+  "Extract the directory part of the filepath to the file in BUFFER.
+   If BUFFER does not have a filepath, the path to the users home 
+   directory will be returned."
+  (make-pathname
+   :directory
+   (pathname-directory
+    (or (filepath buffer)
+	(user-homedir-pathname)))))
+
 (define-command (com-find-file :name t :command-table buffer-table) ()
-  (let* ((filepath (accept 'pathname :prompt "Find File")))
+  (let* ((filepath (accept 'pathname :prompt "Find File"
+			   :default (directory-of-buffer (buffer (current-window)))
+			   :default-type 'pathname
+			   :insert-default t)))
     (find-file filepath)))
 
 (set-key 'com-find-file
@@ -214,7 +227,10 @@
 		     nil)))))))
 
 (define-command (com-find-file-read-only :name t :command-table buffer-table) ()
-  (let ((filepath (accept 'pathname :Prompt "Find file read only")))
+  (let ((filepath (accept 'pathname :Prompt "Find file read only"
+			  :default (directory-of-buffer (buffer (current-window)))
+			  :default-type 'pathname
+			  :insert-default t)))
     (find-file-read-only filepath)))
 
 (set-key 'com-find-file-read-only
@@ -235,11 +251,17 @@
 	(needs-saving buffer) t))
 
 (define-command (com-set-visited-file-name :name t :command-table buffer-table) ()
-  (let ((filename (accept 'pathname :prompt "New file name")))
+  (let ((filename (accept 'pathname :prompt "New file name"
+			  :default (directory-of-buffer (buffer (current-window)))
+			  :default-type 'pathname
+			  :insert-default t)))
     (set-visited-file-name filename (buffer (current-window)))))
 
 (define-command (com-insert-file :name t :command-table buffer-table) ()
-  (let ((filename (accept 'pathname :prompt "Insert File"))
+  (let ((filename (accept 'pathname :prompt "Insert File"
+			  :default (directory-of-buffer (buffer (current-window)))
+			  :default-type 'pathname
+			  :insert-default t))
 	(pane (current-window)))
     (when (probe-file filename)
       (setf (mark pane) (clone-mark (point pane) :left))
@@ -325,7 +347,10 @@
     (call-next-method)))
 
 (define-command (com-write-buffer :name t :command-table buffer-table) ()
-  (let ((filepath (accept 'pathname :prompt "Write Buffer to File"))
+  (let ((filepath (accept 'pathname :prompt "Write Buffer to File"
+			  :default (directory-of-buffer (buffer (current-window)))
+			  :default-type 'pathname
+			  :insert-default t))
 	(buffer (buffer (current-window))))
     (cond
       ((directory-pathname-p filepath)