[mcclim-devel] a new File Selector, patches for the CLIM-Listener, and a general problem with ACCEPT

Max-Gerd Retzlaff m.retzlaff at gmx.net
Tue Aug 30 02:38:13 UTC 2005


Hello,

My File Selector is completed. The source code is attached. New versions
will be available at  http://bl0rg.net/~mgr/flux/file-selector.lisp

You'll *have* to apply the also the following patch for the CLIM-Listener
(attached and at http://bl0rg.net/~mgr/flux/CLIM-Listener.patch ). This
patch mandatory as the File Selector will not work correctly without it.
(More below.)

Also you'll need a quite new CVS version of McCLIM. That is after
00:39:32 CEST of today...


Screenshots:

http://bl0rg.net/~mgr/flux/File-Selector-in-its-own-window-1.0.png
and
http://bl0rg.net/~mgr/flux/File-Selector-embedded-into-the-Clim-Listener-1.0.png

(Note in the second screenshot that, although only "syntax" is specified
as Filename, "syntax.fasl" is selected (i.e. will be returned if one
clicks on OK). This is because "fasl" is the current Filetype and there
is no file "syntax" (without the extension). I hope I've got other minor
details right, as well.)


Problem with ACCEPT:

There is a general problem regarding ACCEPT and its parameter :DEFAULT.
The clim 2.0 spec says in the section about ACCEPT-1:

    If default is supplied, then it and default-type are returned as
    values from accept-1 when the input is empty.

In McCLIM there is currently no way to specify "" in an ACCEPT with
:DEFAULT (that is non-equal to ""), as "" is considered to be "empty".
(If you enter nothing or explicitely "" to a promt of an ACCEPT
outside an ACCEPTING-VALUES the default value will be returned; inside
an ACCEPTING-VALUES dialog a text-field will be displayed in which ""
is normally not displayed, unnecessary to say that in that case the
specified default is also returned.)

Even worse, there is *no way* to distinguish between the cases that
the user left the default untouched and he or she removed the content
of the field completely. No third return value for that. Quite
inconvenient!

It would also be inconvenient to have to enter "" for the empty
string. There is no keyword :ONLY-INSERT-DEFAULT. That would be the
behaviour that I want: The default is only inserted into the field but
whatever is there after the user edited the field will be the return
value of the ACCEPT call, *untouched*. The clim 2.0 specification
seems to supply no way to do this! As a workaround I can only think of
a button "empty the field" right next to each accept text-field.  I
really hope I missed something.


This means for the File Selector that you cannot empty a formerly
speciefied Filename of Filetype again *by editing the text-field*.
To empty those textfields just left-click on a directory for the
Filename, and middle-click for the Filetype. The "Parent Directory"
and the pathname in the title of the directory listing always work for
this.

It would be very nice if somebody had a closer look at
CLIMI::HANDLE-EMPTY-INPUT, CLIMI::INVOKE-HANDLE-EMPTY-INPUT, and
friends.


More information on the patch to the CLIM-Listener

I hope Andy Hefner likes the patch. 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 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).


Comments are welcome, of course. Hope you like it,
Max

-- 
Max-Gerd Retzlaff <m.retzlaff at gmx.net>

For your amusement:
Chance is perhaps the work of God when He did not want to sign.
		-- Anatole France
-------------- next part --------------
diff -Naur Listener_org/dev-commands.lisp Listener_mgr/dev-commands.lisp
--- Listener_org/dev-commands.lisp	2005-04-21 05:41:24.000000000 +0200
+++ Listener_mgr/dev-commands.lisp	2005-08-30 01:41:33.895740000 +0200
@@ -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,7 +1066,7 @@
 				    :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")
@@ -1075,20 +1077,22 @@
   (let* ((pathname (if (wild-pathname-p pathname) ; Forgot why I did this..
                        (merge-pathnames pathname)
                      pathname))
-         (dir (list-directory (gen-wild-pathname pathname))))
+         (dir (list-directory-with-all-subdirectories (gen-wild-pathname 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 +1109,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
diff -Naur Listener_org/file-types.lisp Listener_mgr/file-types.lisp
--- Listener_org/file-types.lisp	2003-11-09 22:12:05.000000000 +0100
+++ Listener_mgr/file-types.lisp	2005-08-29 19:27:12.374781000 +0200
@@ -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
diff -Naur Listener_org/icons/CVS/Root Listener_mgr/icons/CVS/Root
--- Listener_org/icons/CVS/Root	2005-08-30 00:19:14.250680000 +0200
+++ Listener_mgr/icons/CVS/Root	2005-01-12 17:54:07.000000000 +0100
@@ -1 +1 @@
-:ext:mretzlaff at common-lisp.net:/project/mcclim/cvsroot
+:pserver:anonymous at common-lisp.net:/project/mcclim/cvsroot
diff -Naur Listener_org/icons/wild.xpm Listener_mgr/icons/wild.xpm
--- Listener_org/icons/wild.xpm	1970-01-01 01:00:00.000000000 +0100
+++ Listener_mgr/icons/wild.xpm	2005-08-29 16:50:18.287100000 +0200
@@ -0,0 +1,114 @@
+/* XPM */
+static char * wild_xpm[] = {
+"16 16 95 2",
+"  	c None",
+". 	c #484848",
+"+ 	c #4A4A4A",
+"@ 	c #494949",
+"# 	c #474747",
+"$ 	c #4B4B4B",
+"% 	c #E1E1E1",
+"& 	c #E9E9E9",
+"* 	c #E7E7E7",
+"= 	c #DFDFDF",
+"- 	c #D5D5D5",
+"; 	c #505050",
+"> 	c #707070",
+", 	c #D4D4D4",
+"' 	c #E3E3E3",
+") 	c #F0F0F0",
+"! 	c #F2F2F2",
+"~ 	c #F1F1F1",
+"{ 	c #EBEBEB",
+"] 	c #D3D3D3",
+"^ 	c #B1B1B1",
+"/ 	c #5D5D5D",
+"( 	c #D6D6D6",
+"_ 	c #DBDBDB",
+": 	c #EEEEEE",
+"< 	c #F0EDED",
+"[ 	c #F2D7D7",
+"} 	c #EDEDED",
+"| 	c #C0C0C0",
+"1 	c #A1A1A1",
+"2 	c #565656",
+"3 	c #E4E4E4",
+"4 	c #FBF4F4",
+"5 	c #FEFEFE",
+"6 	c #FEE5E5",
+"7 	c #FF3D3D",
+"8 	c #FFFFFF",
+"9 	c #FDFAFA",
+"0 	c #D0D0D0",
+"a 	c #B5B5B5",
+"b 	c #9D9D9D",
+"c 	c #E5E5E5",
+"d 	c #EFEFEF",
+"e 	c #FE7A7A",
+"f 	c #FFB8B8",
+"g 	c #FFE5E5",
+"h 	c #FF7A7A",
+"i 	c #C3C3C3",
+"j 	c #A4A4A4",
+"k 	c #F1EFEF",
+"l 	c #FEADAD",
+"m 	c #FF5050",
+"n 	c #FF5757",
+"o 	c #FDADAD",
+"p 	c #E5E3E3",
+"q 	c #C9C9C9",
+"r 	c #ABABAB",
+"s 	c #FAFAFA",
+"t 	c #FECCCC",
+"u 	c #FF4646",
+"v 	c #FDFDFD",
+"w 	c #ACACAC",
+"x 	c #E0E0E0",
+"y 	c #EDEAEA",
+"z 	c #FE7979",
+"A 	c #FE4444",
+"B 	c #FF8787",
+"C 	c #FF4444",
+"D 	c #DFDDDD",
+"E 	c #C5C5C5",
+"F 	c #D7D7D7",
+"G 	c #FFE9E9",
+"H 	c #FFEAEA",
+"I 	c #FEB0B0",
+"J 	c #BEBEBE",
+"K 	c #A7A7A7",
+"L 	c #DCDCDC",
+"M 	c #FBFBFB",
+"N 	c #FDE9E9",
+"O 	c #FE5D5D",
+"P 	c #FAE6E6",
+"Q 	c #F9F9F9",
+"R 	c #CACACA",
+"S 	c #B3B3B3",
+"T 	c #A0A0A0",
+"U 	c #B2B2B2",
+"V 	c #E8E8E8",
+"W 	c #B9B9B9",
+"X 	c #A3A3A3",
+"Y 	c #BABABA",
+"Z 	c #CBCBCB",
+"` 	c #D2D2D2",
+" .	c #C8C8C8",
+"..	c #B8B8B8",
+"+.	c #A9A9A9",
+"        . + + @ + + @           ",
+"    # $ % & & & * = - ; #       ",
+"  # > , ' ) ! ! ~ { ] ^ / +     ",
+"  @ ( _ { : < [ < } = | 1 2     ",
+"# 3 3 & 4 5 6 7 6 8 9 0 a b @   ",
+"+ c ! d e f g 7 g f h _ i j +   ",
+"+ c ! k l m n 7 n m o p q r +   ",
+"+ ' ! ) s t u 7 u t v 3 q w +   ",
+"# x : y z A B 7 B C z D E w +   ",
+"$ F & * o G 6 7 6 H I ( J K +   ",
+". , 0 L : M N O P Q { R S T +   ",
+"  + U i ( = V * 3 L 0 W X 2     ",
+"  + / X Y Z ` , `  ...j / +     ",
+"    + + T +.^ S ^ r 1 + +       ",
+"        + + + + + + +           ",
+"                                "};
diff -Naur Listener_org/util.lisp Listener_mgr/util.lisp
--- Listener_org/util.lisp	2005-02-22 04:10:27.000000000 +0100
+++ Listener_mgr/util.lisp	2005-08-30 01:43:56.829011000 +0200
@@ -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-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.
-------------- next part --------------
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: FILE-SELECTOR; -*-
;;; ---------------------------------------------------------------------------
;;;     Title: A File Selector for the Common Lisp Interface Manager
;;;   Comment: Written for the CLIM implementation McCLIM and uses some
;;;            at least one function that is not in the CLIM 2.0 specification.
;;;            Needs the CLIM Listener by Andy Hefner (included in McCLIM
;;;            and :com.gigamonkeys.pathnames by Peter Seibel
;;;     Usage: Compile and load the file, and call (file-selector:select-file).
;;;   Created: 2005-08-30, Version 1.0 (same date)
;;;    Author: Max-Gerd Retzlaff <m.retzlaff at gmx.net>, http://bl0rg.net/~mgr
;;; ---------------------------------------------------------------------------
;;;  (c) copyright 2005 by Max-Gerd Retzlaff

(in-package :cl-user)

(eval-when (:load-toplevel :compile-toplevel :execute)
  (asdf:oos 'asdf:load-op :pathnames))

(defpackage :file-selector
  (:use :clim :clim-lisp)
  (:import-from :clim-listener :com-show-directory :draw-icon :icon-of :pathname-printing-name)
  (:import-from :com.gigamonkeys.pathnames :pathname-as-directory) ;; :pathname-as-file :list-directory)
  (:export :select-file))

(in-package :climi)

;;; This is rather ugly. But right now named panes are pushed onto the slot
;;; FRAME-NAMED-PANES of the frame (in an :around method to make-pane-1 in frames.lisp)
;;; and *never* removed. Not nice, as the File Selector makes temporary panes that are
;;; nevertheless named. Even more ugly as they get the same name on every call of the
;;; File Selector. Apart from the accumulation of unused panes, which pane will be
;;; returned if I call (find-pane-named *application-frame* 'files) and there are
;;; several panes with this name? Therefore the panes are right now manually removed
;;; by the following function.

(defun forget-named-pane (pane &optional (frame *application-frame*))
  (setf (frame-named-panes frame)
        (delete pane (frame-named-panes frame))))


(in-package :file-selector)

(defparameter *the-pathname* nil)
(defparameter *the-pathname-type* nil)

;;; custom command-table for the accepting-values dialog
(define-command-table file-selector-commands :inherit-from (climi::accepting-values)
                      );; :inherit-menu t)

;;; present an pathname in textual-dialog-view
(define-presentation-method present (object (type pathname) stream
				     (view textual-dialog-view)
				     &key acceptably for-context-type)
  (declare (ignore acceptably for-context-type))
  (let ((pathname object)
        (long-name t))
    (let ((icon (clim-listener::icon-of pathname)))
      (when icon 
        (clim-listener::draw-icon stream icon :extra-spacing 30)))
    (princ (clim-listener::pathname-printing-name pathname long-name) stream)))


;;;; completion does not work as desired, therefore this isn't used anymore
;;;
;;; (clim:define-presentation-type file-namestring ())
;;;
;;; (define-presentation-method present (object (type file-namestring) stream view &key)
;;;   (write-string object stream))
;;;
;;; (define-presentation-method accept ((type file-namestring) stream view &key)
;;;   (values               ;suppress values after the first
;;;    (multiple-value-bind (object success string)
;;;    (completing-from-suggestions (Stream :partial-completers '(#\- #\. #\Space #\_) :allow-any-input t)
;;;      (mapcar (lambda (args)
;;;                (apply #'suggest args))
;;;              (mapcar (lambda (pathname)
;;;                         (let ((pathname (com.gigamonkeys.pathnames::pathname-as-file pathname)))
;;;                           (list 
;;;                            (file-namestring pathname)
;;;                            (file-namestring pathname))))
;;;                            (com.gigamonkeys.pathnames::list-directory *the-pathname*))))
;;;      (declare (ignore success object))
;;;      string)))
;;;         
;;; (define-presentation-translator pathname-to-file-namestring-translator
;;;     (pathname file-namestring file-selector-commands
;;;               :gesture :describe)
;;;     (object)
;;;   (file-namestring object))


;;; :select gesture (left-click) selects a pathname
(define-presentation-to-command-translator select-pathname-command-translator
    (pathname climi::com-deselect-query file-selector-commands
              :gesture :select
              :documentation "Select this as pathname"
              :pointer-documentation "Select this as pathname")
    (object)
  (setf *the-pathname* object)
  nil)

;;; :describe gesture (middle-click) sets a pathname-type filter
(define-presentation-to-command-translator select-pathname-type-command-translator
    (pathname climi::com-deselect-query file-selector-commands
              :gesture :describe
              :documentation ((object stream)
                                      (let ((type (pathname-type object)))
                                        (if type
                                            (format stream "Show only files with type ~a" type)
                                            (format stream "Show files of any type"))))
              :pointer-documentation ((object stream)
                                      (let ((type (pathname-type object)))
                                        (if type
                                            (format stream "Show only files with type ~a" type)
                                            (format stream "Show files of any type")))))
    (object)
  (setf *the-pathname-type* (pathname-type object))
  nil)

;;;; garbage that I don't want to dispose yet
;;;
;;; (clim:define-presentation-type file-type () :inherit-from 'define)
;;;
;;; (string-presentation-translator pathname-to-file-type-translator
;;;     (pathname file-type file-selector-commands
;;;               :gesture :describe)
;;;     (object)
;;;   (pathname-type object))
;;;
;;;
;;; (define-presentation-method accept ((type pathname) stream (view textua-dialog-view) &key)
;;;   (values               ;suppress values after the first
;;;    ;;; provide completion over the names of the towns
;;;    (completing-from-suggestions (Stream :partial-completers '(#\- #\. #\Space))
;;;      (mapcar (lambda (args)
;;;                (apply #'suggest args))
;;;              (mapcar (lambda (pathname)
;;;                          (list (let ((pathname (com.gigamonkeys.pathnames::pathname-as-file pathname)))
;;;                                  (file-namestring pathname))
;;;                                pathname))
;;;                            (com.gigamonkeys.pathnames::list-directory *default-pathname-defaults*))))))


;;; MAIN FUNCTION
;;;
;;; You can append parameters for the call to CLIM-LISTENER::COM-SHOW-DIRECTORY, as in:
;;;     (file-selector:select-file :own-window t :pathname-type "lisp" :style 'list)

(defun select-file (&rest args-for-com-show-directory ;; Don't forget to update own-args-of-select-file!
                    &key (stream *query-io*)
                    (own-window nil)
                    (pathname *default-pathname-defaults*)
                    pathname-type
                    return-even-a-directory
                    &allow-other-keys)

  (let ((own-args-of-select-file '(:stream :own-window :pathname :pathname-type
                                   :return-even-a-directory))
        parent
        children
        typed-pathname
        (*pointer-documentation-output* *pointer-documentation-output*)
        old-wild-directory)

    (setf *the-pathname* pathname
          *the-pathname-type* pathname-type)

    (unwind-protect
         
         (accepting-values (stream :initially-select-query-identifier 'tag :own-window own-window
                                   :command-table 'file-selector-commands :label "File Selector"
                                   :resynchronize-every-pass t)
           ;; get the gloval values (that might be changed by the presentation to command translators)
           (setf pathname *the-pathname*
                 pathname-type *the-pathname-type*)

           (unless children
             ;; determine the parent sheet
             (setf parent (sheet-parent (if own-window
                                            stream
                                            (let ((scroller-pane (pane-scroller (climi::encapsulating-stream-stream stream))))
                                              ;; if parent is a scroller-pane return the scroller-pane
                                              (if scroller-pane 
                                                  ;; if parent is a border-pane return the border-pane
                                                  (or (climi::pane-border scroller-pane) 
                                                      scroller-pane)
                                                  stream)))))
             ;; remember children
             (setf children (sheet-children parent))

             ;; ... and disown them
             (dolist (child children)
               (sheet-disown-child parent child))

             ;; construct new pane hierarchy
             (let ((fm (frame-manager *application-frame*)))
               (with-look-and-feel-realization (fm *application-frame*)
                 (sheet-adopt-child parent
                                    (make-pane 'vrack-pane :name 'main-container
                                               :contents 
                                               (append (list `(+fill+ ,(make-clim-application-pane
                                                                        ;; :scroll-bars :both
                                                                        :NAME 'files
                                                                        :HEIGHT 150))
                                                             (make-pane 'vrack-pane
                                                                        :name 'children-container
                                                                        :contents children
                                                                        :height 200))
                                                       (when own-window ;; pointer-doc only in own-window
                                                         (list (make-pane 'pointer-documentation-pane
                                                                          :name 'pointer-doc))))))))
             ;; capture *pointer-documentation-output*
             (when own-window
               (setf *pointer-documentation-output*
                     (find-pane-named *application-frame* 'pointer-doc)))

             (change-space-requirements parent))


           ;; add pathname-type as type to the pathname if appropriate
           (setf typed-pathname (if (and (not (and (not (wild-pathname-p pathname))
                                                   (probe-file pathname)))
                                         (pathname-name pathname)
                                         (not (pathname-type pathname)))
                                           (make-pathname :type pathname-type
                                                          :defaults pathname)
                                    pathname))
           
           ;; show listing of the directory in the files pane
           (let* ((*standard-output* (find-pane-named *application-frame* 'files))
                  (directory (directory-namestring pathname))
                  (wild-directory (if pathname-type
                                      (make-pathname :name :wild :type pathname-type
                                                     :defaults (directory-namestring pathname))
                                      (pathname directory))))
             (unless (equal old-wild-directory wild-directory) ;; reprint necessary?
               (window-clear *standard-output*)
               (if (probe-file directory)
                   (let ((args-for-com-show-directory
                          (climi::remove-keywords args-for-com-show-directory own-args-of-select-file)))
                     (apply #'clim-listener::com-show-directory wild-directory
                            args-for-com-show-directory))
                   (progn 
                     (format t "~&The directory ")
                     (present directory 'pathname)
                     (format t " does not exist.")))
               (change-space-requirements *standard-output*))
             (setf old-wild-directory wild-directory))
      
           ;; present the currently selected pathname
           (format stream "~%Currently selected: ")
           ;; (present typed-pathname 'pathname :stream stream) ;; doesn't work for an accepting-values stream :(
           (present (namestring typed-pathname) 'pathname :stream stream :view +textual-view+)
           (princ #\newline stream)
           (princ #\newline stream)
      
           ;; accept text-field for the pathname components
           (setf ;; pathname
                 ;; (accept '((pathname) :default-type pathname-type) :default pathname :stream stream
                 ;; :query-identifier 'tag)
            
                 pathname
                 (let ((file-namestring (parse-namestring
                                         (accept 'string #+nil 'file-namestring :default (file-namestring pathname)
                                                 :prompt "Filename" :stream stream :query-identifier 'tag))))
                   (make-pathname :name (pathname-name file-namestring) ;; merge-pathnames wouldn't work for ""
                                  :type (pathname-type file-namestring)
                                  :defaults pathname))
                 
                 pathname
                 (let ((difference-pathname (com.gigamonkeys.pathnames:pathname-as-directory
                                             (accept 'string :default (directory-namestring pathname)
                                                     :prompt "Directory" :stream stream))))
                   (if (equal #p"" difference-pathname)
                       #p""
                       (merge-pathnames difference-pathname
                                        pathname)))
              
                 pathname-type
                 (let ((type (accept 'string :default (or pathname-type "") :stream stream
                                     :prompt "Filetype")))
                   (if (string= type "")
                       nil
                       type)))
           
           (setf *the-pathname* pathname
                 *the-pathname-type* pathname-type)
           ) ;; of ACCEPTING-VALUES

      ;; reconstruct original pane hierarchy (only if embedded)
      (unless own-window
        ;; disown children
        (dolist (child (sheet-children (find-pane-named *application-frame* 'children-container)))
          (sheet-disown-child (find-pane-named *application-frame* 'children-container) child))
        
        ;; disown the main container of the File Selector
        (sheet-disown-child parent (find-pane-named *application-frame* 'main-container))
        
        ;; adopt remembered children to their former parent
        (let ((fm (frame-manager *application-frame*)))
          (with-look-and-feel-realization (fm *application-frame*)
            (dolist (child children)
              (sheet-adopt-child parent child))))

        (change-space-requirements parent))

      ;; forget the temporery but nevertheless named panes (argh)
      (climi::forget-named-pane (find-pane-named *application-frame* 'children-container))
      (climi::forget-named-pane (find-pane-named *application-frame* 'files))
      (climi::forget-named-pane (find-pane-named *application-frame* 'main-container))
      (when own-window
        (climi::forget-named-pane (find-pane-named *application-frame* 'pointer-doc)))
      ) ;; of UNWIND-PROTECT
    
    ;; return the selected file
    (if (or (pathname-name pathname)
            return-even-a-directory)
        typed-pathname
        (abort))))
-------------- next part --------------
A non-text attachment was scrubbed...
Name: not available
Type: application/pgp-signature
Size: 189 bytes
Desc: not available
URL: <https://mailman.common-lisp.net/pipermail/mcclim-devel/attachments/20050830/e412772e/attachment.sig>


More information about the mcclim-devel mailing list