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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (hide annotations)
Tue Jan 9 00:11:39 2007 UTC (7 years, 3 months ago) by rgoldman
Branch: MAIN
CVS Tags: mcclim-0-9-4, McCLIM-0-9-5, McCLIM-0-9-4, McCLIM-0-9-6, HEAD
Changes since 1.1: +27 -9 lines
This is a version of the file-browser example application that works,
unlike the one that was previously available.
Unfortunately, it doesn't work *well*, because McCLIM's support for
AND and SATISFIES presentation-types is incomplete.
I am unable to work on this more for the near future, so am committing the
working-but-unsatisfactory version.
1 cfruhwirth 1.1 (eval-when (:compile-toplevel)
2     (asdf:oos 'asdf:load-op :clim)
3     (asdf:oos 'asdf:load-op :clim-clx))
4    
5 rgoldman 1.2 (eval-when (:compile-toplevel :load-toplevel :execute)
6     (asdf:oos 'asdf:load-op :cl-fad))
7    
8 cfruhwirth 1.1 (in-package :clim-user)
9    
10     ; LTAG-start:file-browser-all
11     (define-application-frame file-browser ()
12     ((active-files :initform nil :accessor active-files))
13     (:panes
14     (file-browser :application
15     :display-function '(dirlist-display-files)
16     ;; Call the display-function whenever the command
17     ;; loop makes a ``full-cycle''
18     :display-time :command-loop)
19     (interactor :interactor))
20     (:layouts (default (vertically ()
21     file-browser
22     interactor))))
23    
24 rgoldman 1.2 (define-presentation-type dir-pathname ()
25     :inherit-from 'pathname)
26    
27 cfruhwirth 1.1 (defmethod dirlist-display-files ((frame file-browser) pane)
28     ;; Clear old displayed entries
29     (clear-output-record (stream-output-history pane))
30    
31     (dolist (file (active-files frame))
32     ;; Instead of write-string, we use present so that the link to
33     ;; object file and the semantic information that file is
34     ;; pathname is retained.
35 rgoldman 1.2 (present file
36     (if (cl-fad:directory-pathname-p file) 'dir-pathname 'pathname)
37     :stream pane)
38 cfruhwirth 1.1 (terpri pane)))
39    
40     (define-file-browser-command (com-edit-directory :name "Edit Directory")
41 rgoldman 1.2 ((dir 'dir-pathname))
42     ;; the following was a previous attempt to deal with the oddities of
43     ;; CL pathnames. Unfortunately, it does not work properly with all
44     ;; 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 cfruhwirth 1.1 (setf (active-files *application-frame*)
50 rgoldman 1.2 (cl-fad:list-directory dir)))
51 cfruhwirth 1.1
52     (define-presentation-to-command-translator pathname-to-edit-command
53 rgoldman 1.2 (dir-pathname ; source presentation-type
54 cfruhwirth 1.1 com-edit-directory ; target-command
55     file-browser ; command-table
56     :gesture :select ; use this translator for pointer clicks
57     :documentation "Edit this path") ; used in context menu
58     (object) ; argument List
59 rgoldman 1.2 (list object)) ; arguments for target-command
60    
61     (define-file-browser-command (com-quit :name t) ()
62     (frame-exit *application-frame*)
63     )
64 cfruhwirth 1.1
65     (defmethod adopt-frame :after (frame-manager (frame file-browser))
66 rgoldman 1.2 (declare (ignore frame-manager))
67 cfruhwirth 1.1 (execute-frame-command frame
68 rgoldman 1.2 `(com-edit-directory ,(make-pathname :directory '(:absolute)))))
69    
70 cfruhwirth 1.1 ; LTAG-end

  ViewVC Help
Powered by ViewVC 1.1.5