/[mcclim]/mcclim/Doc/Guided-Tour/file-browser.lisp
ViewVC logotype

Diff of /mcclim/Doc/Guided-Tour/file-browser.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by cfruhwirth, Mon Jan 30 16:14:01 2006 UTC revision 1.2 by rgoldman, Tue Jan 9 00:11:39 2007 UTC
# Line 2  Line 2 
2    (asdf:oos 'asdf:load-op :clim)    (asdf:oos 'asdf:load-op :clim)
3    (asdf:oos 'asdf:load-op :clim-clx))    (asdf:oos 'asdf:load-op :clim-clx))
4    
5    (eval-when (:compile-toplevel :load-toplevel :execute)
6      (asdf:oos 'asdf:load-op :cl-fad))
7    
8  (in-package :clim-user)  (in-package :clim-user)
9    
10  ; LTAG-start:file-browser-all  ; LTAG-start:file-browser-all
# Line 18  Line 21 
21                                   file-browser                                   file-browser
22                                   interactor))))                                   interactor))))
23    
24    (define-presentation-type dir-pathname ()
25      :inherit-from 'pathname)
26    
27  (defmethod dirlist-display-files ((frame file-browser) pane)  (defmethod dirlist-display-files ((frame file-browser) pane)
28    ;; Clear old displayed entries    ;; Clear old displayed entries
29    (clear-output-record (stream-output-history pane))    (clear-output-record (stream-output-history pane))
# Line 26  Line 32 
32      ;; Instead of write-string, we use present so that the link to      ;; Instead of write-string, we use present so that the link to
33      ;; object file and the semantic information that file is      ;; object file and the semantic information that file is
34      ;; pathname is retained.      ;; pathname is retained.
35      (present file 'pathname :stream pane)      (present file
36                 (if (cl-fad:directory-pathname-p file) 'dir-pathname 'pathname)
37                 :stream pane)
38      (terpri pane)))      (terpri pane)))
39    
40  (define-file-browser-command (com-edit-directory :name "Edit Directory")  (define-file-browser-command (com-edit-directory :name "Edit Directory")
41    ((dir 'pathname))    ((dir 'dir-pathname))
42    (let ((dir (make-pathname :directory (pathname-directory dir)    ;; the following was a previous attempt to deal with the oddities of
43                              :name :wild :type :wild :version :wild    ;; CL pathnames.  Unfortunately, it does not work properly with all
44                              :defaults dir)))    ;; lisp implementations.  Because of these oddities, we really need
45      ;; a layer like cl-fad to keep things straight. [2007/01/05:rpg]
46    ;;;  (let ((dir (make-pathname :directory (pathname-directory dir)
47    ;;;                         :name :wild :type :wild :version :wild
48    ;;;                         :defaults dir)))
49      (setf (active-files *application-frame*)      (setf (active-files *application-frame*)
50            (directory dir))))            (cl-fad:list-directory dir)))
51    
52  (define-presentation-to-command-translator pathname-to-edit-command  (define-presentation-to-command-translator pathname-to-edit-command
53      (pathname                           ; source presentation-type      (dir-pathname                       ; source presentation-type
54       com-edit-directory                 ; target-command       com-edit-directory                 ; target-command
55       file-browser                       ; command-table       file-browser                       ; command-table
56       :gesture :select                   ; use this translator for pointer clicks       :gesture :select                   ; use this translator for pointer clicks
57       :documentation "Edit this path")   ; used in context menu       :documentation "Edit this path")   ; used in context menu
58      (object)                            ; argument List      (object)                            ; argument List
59    (list object))                        ; arguments for target-command      (list object))                        ; arguments for target-command
60    
61    (define-file-browser-command (com-quit :name t) ()
62      (frame-exit *application-frame*)
63      )
64    
65  (defmethod adopt-frame :after (frame-manager (frame file-browser))  (defmethod adopt-frame :after (frame-manager (frame file-browser))
66      (declare (ignore frame-manager))
67    (execute-frame-command frame    (execute-frame-command frame
68      `(com-edit-directory ,(make-pathname :directory '(:absolute)))))          `(com-edit-directory ,(make-pathname :directory '(:absolute)))))
69    
70  ; LTAG-end  ; LTAG-end

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

  ViewVC Help
Powered by ViewVC 1.1.5