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@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.