[mcclim-cvs] CVS update: mcclim/Apps/Listener/dev-commands.lisp mcclim/Apps/Listener/file-types.lisp mcclim/Apps/Listener/util.lisp
Max-Gerd Retzlaff
mretzlaff at common-lisp.net
Wed Aug 31 05:50:41 UTC 2005
Update of /project/mcclim/cvsroot/mcclim/Apps/Listener
In directory common-lisp.net:/tmp/cvs-serv17279/Apps/Listener
Modified Files:
dev-commands.lisp file-types.lisp util.lisp
Log Message:
This patch affects the CLIM-Listener.
It adds :
- sort-by for filenames to COM-SHOW-DIRECTORY,
- an icon and a cond-clause in ICON-OF for wild pathnames,
- a wrapper for LIST-DIRECTORY (that NCONCs the direct subdirectories
of the directory to the output of LIST-DIRECTORY if it is called with
a wild pathname),
- and does some minor changes to COM-SHOW-DIRECTORY.
Also it removes the SB-POSIX LIST-DIRECTORY for SBCL as that one
completely ignores the pathname-name and -type, which renders it quite
useless for :wild searches (pune or play on words intended).
There was a short discussion about this patch in #lisp some hourse
ago. As a result the wrapper for LIST-DIRECTORY is now called
LIST-DIRECTORY-WITH-ALL-DIRECT-SUBDIRECTORIES. And it will only used by
COM-SHOW-DIRECTORY if its new keyword parameter
:list-all-direct-subdirectories is specified as t (the default being nil).
The discussion (included because of the removed posix code in the
former SBCL version of LIST-DIRECTORY):
01:18 < mgr> hefner: Did you have a look at my listener patch?
01:19 < hefner> I did, it looked good
01:19 < mgr> hefner: You are not angry because it removes the posix stuff? :)
01:20 < hefner> mgr: did it? :) The posix stuff was horrible, terrible.
01:20 < mgr> hefner: So, you don't object if I commit it to the mcclim repository?
01:20 < hefner> mgr: no, go ahead
01:22 < mgr> hefner: Perhaps there should be a option to COM-SHOW-DIRECTORY to
switch between using LIST-DIRECTORY and LIST-DIRECTORY-WITH-ALL-SUBDIRECTORIES?
Perhaps the latter is not always desired..
01:22 < hefner> mgr: :recursive t ?
01:23 < mgr> hefner: No, it's different. if you list "/tmp/*.list" all direct
subdirectories of "/tmp/" will be listed as well, altough they do not match
"*.lisp".
01:24 < hefner> ah..
01:27 < hefner> mgr: hold on, you're just calling cl:directory? Isn't that going
to explode on broken symlinks?
01:33 < mgr> hefner: Uhm, explode? not really, no. Why? Symlinks are just
"resolved" on sbcl. That is if you select "/foo/bar" that is a symlink to
"/baz/quux", you'll always get the latter even if you select the former one.
01:34 < gilberth> mgr: not so fast. I have major hassle with CMUCL and XEmacs
silly lock symlinks.
01:34 < hefner> mgr: what if /baz/quux doesn't exist? I didn't write the aweful
posix code for my health.
01:35 < gilberth> They point to silly stuff like "gilbert at morganit.local.6092"
01:36 < mgr> gilberth: Well, the listener did always do only #'directory for
cmucl.. So, don't worry this does not affect you. :)
01:36 < gilberth> great.
01:37 < hefner> not only #'directory, but (directory pathname :truenamep nil)
01:39 < gilberth> mgr: It must use the right keyword options to #'directory in
CMUCL or something, since it works with borken symlinks.
01:39 < gilberth> it even shows a particular icon for the broken symlink.
01:39 < hefner> does it? that's a nice touch.
01:40 < gilberth> hefner: I thought you would know?
01:40 < hefner> I guess I forgot.
01:45 < mgr> hefner: there ist no problem with them. they will not be resolved,
that is #p"/foo/bar" will be returned. it will be displayed as an invalid
pathname because probe-file returns nil.
01:46 < hefner> mgr: I guess the behaviour changed. SBCL of 1.5 years ago didn't
do that. Carry on. :)
01:47 < mgr> hefner: Also the posix version completely ignores the pathname-name
and -type, and that's really not nice.
01:47 < hefner> well, pathname-name and pathname-type aren't nice either
01:47 < hefner> pathnames aren't nice
01:47 < mgr> hefner: Well, that's a different problem.
01:48 < mgr> hefner: I'll include this short discussion into the commit message,
okay? :)
01:48 < hefner> okay
Date: Wed Aug 31 07:50:38 2005
Author: mretzlaff
Index: mcclim/Apps/Listener/dev-commands.lisp
diff -u mcclim/Apps/Listener/dev-commands.lisp:1.29 mcclim/Apps/Listener/dev-commands.lisp:1.30
--- mcclim/Apps/Listener/dev-commands.lisp:1.29 Thu Apr 21 05:41:24 2005
+++ mcclim/Apps/Listener/dev-commands.lisp Wed Aug 31 07:50:37 2005
@@ -1028,7 +1028,9 @@
(terpri stream))
(defun sort-pathnames (list sort-by)
- list) ; <--- FIXME
+ (case sort-by ; <--- FIXME
+ ('name (sort list #'string-lessp :key #'file-namestring))
+ (t list)))
(defun split-sort-pathnames (list group-dirs sort-by)
(mapcar (lambda (x) (sort-pathnames x sort-by))
@@ -1064,31 +1066,37 @@
:provide-output-destination-keyword t)
((pathname 'pathname #+nil(or 'string 'pathname) :prompt "pathname")
&key
- #+NIL (sort-by '(member name size modify none) :default 'name)
+ (sort-by '(member name size modify none) :default 'name)
(show-hidden 'boolean :default nil :prompt "show hidden")
(hide-garbage 'boolean :default T :prompt "hide garbage")
(show-all 'boolean :default nil :prompt "show all")
(style '(member items list) :default 'items :prompt "listing style")
(group-directories 'boolean :default T :prompt "group directories?")
- (full-names 'boolean :default nil :prompt "show full name?"))
+ (full-names 'boolean :default nil :prompt "show full name?")
+ (list-all-direct-subdirectories 'boolean :default nil :prompt "list all direct subdirectories?"))
(let* ((pathname (if (wild-pathname-p pathname) ; Forgot why I did this..
(merge-pathnames pathname)
pathname))
- (dir (list-directory (gen-wild-pathname pathname))))
+ (wild-pathname (gen-wild-pathname pathname))
+ (dir (if list-all-direct-subdirectories
+ (list-directory-with-all-direct-subdirectories wild-pathname)
+ (list-directory wild-pathname))))
(with-text-family (T :sans-serif)
(invoke-as-heading
(lambda ()
(format T "Directory contents of ")
- (present pathname)))
+ (present (directory-namestring pathname) 'pathname)
+ (when (pathname-type pathname)
+ (format T " (only files of type ~a)" (pathname-type pathname)))))
(when (parent-directory pathname)
- (with-output-as-presentation (T (parent-directory pathname) 'clim:pathname)
+ (with-output-as-presentation (T (strip-filespec (parent-directory pathname)) 'clim:pathname)
(draw-icon T (standard-icon "up-folder.xpm") :extra-spacing 3)
(format T "Parent Directory~%")))
- (dolist (group (split-sort-pathnames dir group-directories :none #+NIL sort-by))
+ (dolist (group (split-sort-pathnames dir group-directories sort-by))
(unless show-all
(setf group (filter-garbage-pathnames group show-hidden hide-garbage)))
(ecase style
@@ -1105,7 +1113,8 @@
(goatee::reposition-stream-cursor *standard-output*)
(vertical-gap T))
(list (dolist (ent group)
- (let ((ent (merge-pathnames ent pathname))) ; This is for CMUCL, see above. (fixme!)
+ (let ((ent (merge-pathnames ent pathname))) ;; This is for CMUCL, see above. (fixme!)
+ ;; And breaks some things for SBCL.. (mgr)
(pretty-pretty-pathname ent *standard-output* :long-name full-names)))))))))
#+nil ; OBSOLETE
Index: mcclim/Apps/Listener/file-types.lisp
diff -u mcclim/Apps/Listener/file-types.lisp:1.7 mcclim/Apps/Listener/file-types.lisp:1.8
--- mcclim/Apps/Listener/file-types.lisp:1.7 Sun Nov 9 22:12:05 2003
+++ mcclim/Apps/Listener/file-types.lisp Wed Aug 31 07:50:37 2005
@@ -133,7 +133,8 @@
;; ICON-OF is measurably slow here in CMUCL. Interesting..
(defmethod icon-of ((pathname pathname))
- (cond ((not (probe-file pathname)) (standard-icon "invalid.xpm"))
+ (cond ((wild-pathname-p pathname) (standard-icon "wild.xpm"))
+ ((not (probe-file pathname)) (standard-icon "invalid.xpm"))
((directoryp pathname) *folder-icon*) ;; FIXME: use inode mime types
(T (let ((mime-class (find-class (pathname-mime-type pathname) nil)))
(if mime-class
Index: mcclim/Apps/Listener/util.lisp
diff -u mcclim/Apps/Listener/util.lisp:1.17 mcclim/Apps/Listener/util.lisp:1.18
--- mcclim/Apps/Listener/util.lisp:1.17 Tue Feb 22 04:10:27 2005
+++ mcclim/Apps/Listener/util.lisp Wed Aug 31 07:50:37 2005
@@ -118,6 +118,8 @@
#+SBCL
(defun list-directory (pathname)
+ (directory pathname)
+ #+nil ;; ugh. is too ughy. (mgr)
(let* ((pathname (strip-filespec pathname)) ;; ugh.
(dir (sb-posix:opendir pathname))
(list nil))
@@ -141,6 +143,19 @@
(defun list-directory (pathname)
(directory pathname))
+;;; Calls LIST-DIRECTORY and appends the subdirectories of the directory
+;;; PATHNAME to the output of LIST-DIRECTORY if PATHNAME is a wild pathname.
+
+(defun list-directory-with-all-direct-subdirectories (pathname)
+ (let ((file-list (list-directory pathname)))
+ (if (wild-pathname-p pathname)
+ (nconc file-list
+ (delete-if (lambda (directory)
+ (member directory file-list :test #'equal))
+ (delete-if-not #'directoryp
+ (list-directory (gen-wild-pathname
+ (strip-filespec pathname))))))
+ file-list)))
;;; A farce of a "portable" run-program, which grows as I need options from
;;; the CMUCL run-program.
More information about the Mcclim-cvs
mailing list