annotate lisp/gtk-file-dialog.el @ 4885:6772ce4d982b

Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums lisp/ChangeLog addition: 2010-01-24 Aidan Kehoe <kehoea@parhasard.net> Correct the semantics of #'member*, #'eql, #'assoc* in the presence of bignums; change the integerp byte code to fixnump semantics. * bytecomp.el (fixnump, integerp, byte-compile-integerp): Change the integerp byte code to fixnump; add a byte-compile method to integerp using fixnump and numberp and avoiding a funcall most of the time, since in the non-core contexts where integerp is used, it's mostly distinguishing between fixnums and things that are not numbers at all. * byte-optimize.el (side-effect-free-fns, byte-after-unbind-ops) (byte-compile-side-effect-and-error-free-ops): Replace the integerp bytecode with fixnump; add fixnump to the side-effect-free-fns. Add the other extended number type predicates to the list in passing. * obsolete.el (floatp-safe): Mark this as obsolete. * cl.el (eql): Go into more detail in the docstring here. Don't bother checking whether both arguments are numbers; one is enough, #'equal will fail correctly if they have distinct types. (subst): Replace a call to #'integerp (deciding whether to use #'memq or not) with one to #'fixnump. Delete most-positive-fixnum, most-negative-fixnum from this file; they're now always in C, so they can't be modified from Lisp. * cl-seq.el (member*, assoc*, rassoc*): Correct these functions in the presence of bignums. * cl-macs.el (cl-make-type-test): The type test for a fixnum is now fixnump. Ditch floatp-safe, use floatp instead. (eql): Correct this compiler macro in the presence of bignums. (assoc*): Correct this compiler macro in the presence of bignums. * simple.el (undo): Change #'integerp to #'fixnump here, since we use #'delq with the same value as ELT a few lines down. src/ChangeLog addition: 2010-01-24 Aidan Kehoe <kehoea@parhasard.net> Fix problems with #'eql, extended number types, and the hash table implementation; change the Bintegerp bytecode to fixnump semantics even on bignum builds, since #'integerp can have a fast implementation in terms of #'fixnump for most of its extant uses, but not vice-versa. * lisp.h: Always #include number.h; we want the macros provided in it, even if the various number types are not available. * number.h (NON_FIXNUM_NUMBER_P): New macro, giving 1 when its argument is of non-immediate number type. Equivalent to FLOATP if WITH_NUMBER_TYPES is not defined. * elhash.c (lisp_object_eql_equal, lisp_object_eql_hash): Use NON_FIXNUM_NUMBER_P in these functions, instead of FLOATP, giving more correct behaviour in the presence of the extended number types. * bytecode.c (Bfixnump, execute_optimized_program): Rename Bintegerp to Bfixnump; change its semantics to reflect the new name on builds with bignum support. * data.c (Ffixnump, Fintegerp, syms_of_data, vars_of_data): Always make #'fixnump available, even on non-BIGNUM builds; always implement #'integerp in this file, even on BIGNUM builds. Move most-positive-fixnum, most-negative-fixnum here from number.c, so they are Lisp constants even on builds without number types, and attempts to change or bind them error. Use the NUMBERP and INTEGERP macros even on builds without extended number types. * data.c (fixnum_char_or_marker_to_int): Rename this function from integer_char_or_marker_to_int, to better reflect the arguments it accepts. * number.c (Fevenp, Foddp, syms_of_number): Never provide #'integerp in this file. Remove #'oddp, #'evenp; their implementations are overridden by those in cl.el. * number.c (vars_of_number): most-positive-fixnum, most-negative-fixnum are no longer here. man/ChangeLog addition: 2010-01-23 Aidan Kehoe <kehoea@parhasard.net> Generally: be careful to say fixnum, not integer, when talking about fixed-precision integral types. I'm sure I've missed instances, both here and in the docstrings, but this is a decent start. * lispref/text.texi (Columns): Document where only fixnums, not integers generally, are accepted. (Registers): Remove some ancient char-int confoundance here. * lispref/strings.texi (Creating Strings, Creating Strings): Be more exact in describing where fixnums but not integers in general are accepted. (Creating Strings): Use a more contemporary example to illustrate how concat deals with lists including integers about #xFF. Delete some obsolete documentation on same. (Char Table Types): Document that only fixnums are accepted as values in syntax tables. * lispref/searching.texi (String Search, Search and Replace): Be exact in describing where fixnums but not integers in general are accepted. * lispref/range-tables.texi (Range Tables): Be exact in describing them; only fixnums are accepted to describe ranges. * lispref/os.texi (Killing XEmacs, User Identification) (Time of Day, Time Conversion): Be more exact about using fixnum where only fixed-precision integers are accepted. * lispref/objects.texi (Integer Type): Be more exact (and up-to-date) about the possible values for integers. Cross-reference to documentation of the bignum extension. (Equality Predicates): (Range Table Type): (Array Type): Use fixnum, not integer, to describe a fixed-precision integer. (Syntax Table Type): Correct some English syntax here. * lispref/numbers.texi (Numbers): Change the phrasing here to use fixnum to mean the fixed-precision integers normal in emacs. Document that our terminology deviates from that of Common Lisp, and that we're working on it. (Compatibility Issues): Reiterate the Common Lisp versus Emacs Lisp compatibility issues. (Comparison of Numbers, Arithmetic Operations): * lispref/commands.texi (Command Loop Info, Working With Events): * lispref/buffers.texi (Modification Time): Be more exact in describing where fixnums but not integers in general are accepted.
author Aidan Kehoe <kehoea@parhasard.net>
date Sun, 24 Jan 2010 15:21:27 +0000
parents 7039e6323819
children 308d34e9f07d
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
462
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
1 ;;; gtk-file-dialog.el --- A nicer file selection dialog for XEmacs w/GTK primitives
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
2
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
3 ;; Copyright (C) 2000 Free Software Foundation, Inc.
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
4
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
5 ;; Maintainer: William M. Perry <wmperry@gnu.org>
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
6 ;; Keywords: extensions, internal
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
7
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
8 ;; This file is part of XEmacs.
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
9
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
10 ;; XEmacs is free software; you can redistribute it and/or modify it
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
11 ;; under the terms of the GNU General Public License as published by
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
12 ;; the Free Software Foundation; either version 2, or (at your option)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
13 ;; any later version.
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
14
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
15 ;; XEmacs is distributed in the hope that it will be useful, but
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
18 ;; General Public License for more details.
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
19
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
20 ;; You should have received a copy of the GNU General Public License
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
21 ;; along with XEmacs; see the file COPYING. If not, write to the
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
22 ;; Free Software Foundation, 59 Temple Place - Suite 330,
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
23 ;; Boston, MA 02111-1307, USA.
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
24
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
25 ;;; Synched up with: Not in FSF.
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
26
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
27 ;;; Commentary:
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
28
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
29 ;; The default GTK file selection dialog is not sufficient for our
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
30 ;; needs. Limitations include:
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
31 ;;
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
32 ;; - not derived from GtkDialog
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
33 ;; - no support for filters based on file types
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
34 ;; - no support for setting an initial directory
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
35 ;; - no way to tell it 'file must exist'
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
36 ;; - no easy way to tell it to look at directories only
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
37 ;; - ugly as sin
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
38 ;;
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
39 ;; This attempts to rectify the situation.
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
40
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 462
diff changeset
41 (globally-declare-fboundp
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 462
diff changeset
42 '(gtk-clist-clear
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 462
diff changeset
43 gtk-clist-freeze gtk-clist-append
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 462
diff changeset
44 gtk-clist-thaw gtk-combo-set-popdown-strings gtk-dialog-new
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 462
diff changeset
45 gtk-dialog-vbox gtk-dialog-action-area gtk-window-set-title
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 462
diff changeset
46 gtk-button-new-with-label gtk-container-add gtk-signal-connect
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 462
diff changeset
47 gtk-entry-get-text gtk-widget-destroy gtk-combo-new
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 462
diff changeset
48 gtk-combo-disable-activate gtk-box-pack-start gtk-combo-entry
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 462
diff changeset
49 gtk-hbox-new gtk-clist-new-with-titles gtk-scrolled-window-new
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 462
diff changeset
50 gtk-widget-set-usize gtk-clist-get-text gtk-entry-set-text
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 462
diff changeset
51 gtk-button-clicked gtk-option-menu-new gtk-menu-new
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 462
diff changeset
52 gtk-label-new gtk-menu-item-new-with-label gtk-menu-append
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 462
diff changeset
53 gtk-widget-show gtk-option-menu-set-menu gtk-box-pack-end
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 462
diff changeset
54 gtk-entry-new gtk-widget-set-sensitive gtk-widget-realize))
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 462
diff changeset
55
462
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
56 (defun gtk-file-dialog-fill-file-list (dialog dir)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
57 (if (not dir)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
58 (setq dir (get dialog 'x-file-dialog-current-dir nil)))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
59
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
60 (put dialog 'x-file-dialog-current-dir dir)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
61
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
62 (let ((list (get dialog 'x-file-dialog-files-list nil))
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 462
diff changeset
63 ;(remotep (file-remote-p dir))
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 462
diff changeset
64 )
462
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
65 (if (not list)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
66 nil
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
67 (gtk-clist-clear list)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
68 (gtk-clist-freeze list)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
69 ;; NOTE: Current versions of efs / ange-ftp do not honor the
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
70 ;; files-only flag to directory-files, but actually DOING these
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
71 ;; checks is hideously expensive. Leave it turned off for now.
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 462
diff changeset
72 (mapc #'(lambda (f)
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 462
diff changeset
73 (if (or t ; Lets just wait for EFS to
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 462
diff changeset
74 ;(not remotep) ; fix itself, shall we?
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 462
diff changeset
75 ;(not (file-directory-p (expand-file-name f dir)))
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 462
diff changeset
76 )
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 462
diff changeset
77 (gtk-clist-append list (list f))))
462
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
78 (directory-files dir nil
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
79 (get dialog 'x-file-dialog-active-filter nil)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
80 nil t))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
81 (gtk-clist-thaw list))))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
82
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
83 (defun gtk-file-dialog-fill-directory-list (dialog dir)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
84 (let ((subdirs (directory-files dir nil nil nil 5))
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 462
diff changeset
85 ;(remotep (file-remote-p dir))
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 462
diff changeset
86 ;(selected-dir (get dialog 'x-file-dialog-current-dir "/"))
462
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
87 (directory-list (get dialog 'x-file-dialog-directory-list)))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
88
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
89 (gtk-clist-freeze directory-list)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
90 (gtk-clist-clear directory-list)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
91
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
92 (while subdirs
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
93 (if (equal "." (car subdirs))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
94 nil
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
95 ;; NOTE: Current versions of efs / ange-ftp do not honor the
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
96 ;; files-only flag to directory-files, but actually DOING these
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
97 ;; checks is hideously expensive. Leave it turned off for now.
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
98 (if (or t ; Lets just wait for EFS to
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 462
diff changeset
99 ;(not remotep) ; fix itself, shall we?
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 462
diff changeset
100 ;(file-directory-p (expand-file-name (car subdirs) dir))
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 462
diff changeset
101 )
462
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
102 (gtk-clist-append directory-list (list (car subdirs)))))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
103 (pop subdirs))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
104 (gtk-clist-thaw directory-list)))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
105
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
106 (defun gtk-file-dialog-update-dropdown (dialog dir)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
107 (let ((combo-box (get dialog 'x-file-dialog-select-list))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
108 (components (reverse
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
109 (delete ""
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
110 (split-string dir
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
111 (concat "[" (char-to-string directory-sep-char) "]")))))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
112 (entries nil))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
113
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
114 (while components
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
115 (push (concat "/" (mapconcat 'identity (reverse components)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
116 (char-to-string directory-sep-char)))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
117 entries)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
118 (pop components))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
119 (push (expand-file-name "." "~/") entries)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
120 (gtk-combo-set-popdown-strings combo-box (nreverse entries))))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
121
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
122 (defun gtk-file-dialog-select-directory (dialog dir)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
123 (gtk-file-dialog-fill-directory-list dialog dir)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
124 (gtk-file-dialog-fill-file-list dialog dir)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
125 (gtk-file-dialog-update-dropdown dialog dir))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
126
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
127 (defun gtk-file-dialog-new (&rest keywords)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
128 "Create a XEmacs file selection dialog.
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
129 Optional keyword arguments allowed:
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
130
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
131 :title The title of the dialog
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
132 :initial-directory Initial directory to show
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
133 :filter-list List of filter descriptions and filters
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
134 :file-must-exist Whether the file must exist or not
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
135 :directory Look for a directory instead
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
136 :callback Function to call with one arg, the selection
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
137 "
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
138 (let* ((dialog (gtk-dialog-new))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
139 (vbox (gtk-dialog-vbox dialog))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
140 (dir (plist-get keywords :initial-directory default-directory))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
141 (button-area (gtk-dialog-action-area dialog))
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 462
diff changeset
142 ;(initializing-gtk-file-dialog t)
462
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
143 (select-box nil)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
144 button hbox)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
145
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
146 (put dialog 'type 'dialog)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
147
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
148 (gtk-window-set-title dialog (plist-get keywords :title "Select a file..."))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
149
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
150 (setq button (gtk-button-new-with-label "OK"))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
151 (gtk-container-add button-area button)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
152 (gtk-signal-connect button 'clicked
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
153 (lambda (button dialog)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
154 (funcall
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
155 (get dialog 'x-file-dialog-callback 'ignore)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
156 (gtk-entry-get-text
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
157 (get dialog 'x-file-dialog-entry nil)))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
158 (gtk-widget-destroy dialog))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
159 dialog)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
160 (put dialog 'x-file-dialog-ok-button button)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
161
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
162 (setq button (gtk-button-new-with-label "Cancel"))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
163 (gtk-container-add button-area button)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
164 (gtk-signal-connect button 'clicked
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
165 (lambda (button dialog)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
166 (gtk-widget-destroy dialog)) dialog)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
167
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
168 (put dialog 'x-file-dialog-cancel-button button)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
169 (put dialog 'x-file-dialog-callback (plist-get keywords :callback 'ignore))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
170 (put dialog 'x-file-dialog-construct-args keywords)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
171 (put dialog 'x-file-dialog-current-dir dir)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
172
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
173 ;; Dropdown list of directories...
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
174 (setq select-box (gtk-combo-new))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
175 (gtk-combo-disable-activate select-box)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
176 (gtk-box-pack-start vbox select-box nil nil 5)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
177 (put dialog 'x-file-dialog-select-list select-box)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
178
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
179 ;; Hitting return in the entry will change dirs...
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
180 (gtk-signal-connect (gtk-combo-entry select-box) 'activate
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
181 (lambda (entry dialog)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
182 (gtk-file-dialog-select-directory dialog
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
183 (gtk-entry-get-text entry)))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
184 dialog)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
185
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
186 ;; Start laying out horizontally...
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
187 (setq hbox (gtk-hbox-new nil 0))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
188 (gtk-box-pack-start vbox hbox t t 5)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
189
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
190 ;; Directory listing
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
191 (let ((directories (gtk-clist-new-with-titles 1 '("Directories")))
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 462
diff changeset
192 (scrolled (gtk-scrolled-window-new nil nil)))
462
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
193 (gtk-container-add scrolled directories)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
194 (gtk-widget-set-usize scrolled 200 300)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
195 (gtk-box-pack-start hbox scrolled t t 0)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
196 (put dialog 'x-file-dialog-directory-list directories)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
197 (put dialog 'x-file-dialog-directory-scrolled scrolled)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
198
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
199 (gtk-signal-connect directories 'select-row
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
200 (lambda (list row column event dialog)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
201 (let ((dir (expand-file-name
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
202 (gtk-clist-get-text
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
203 (get dialog 'x-file-dialog-directory-list)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
204 row column)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
205 (get dialog 'x-file-dialog-current-dir))))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
206 (if (and (misc-user-event-p event)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
207 (event-function event))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
208 (gtk-file-dialog-select-directory dialog dir)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
209 (gtk-entry-set-text
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
210 (get dialog 'x-file-dialog-entry)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
211 dir))))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
212 dialog)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
213 )
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
214
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
215 (if (plist-get keywords :directory nil)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
216 ;; Directory listings only do not need the file or filters buttons.
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
217 nil
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
218 ;; File listing
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
219 (let ((list (gtk-clist-new-with-titles 1 '("Files")))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
220 (scrolled (gtk-scrolled-window-new nil nil)))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
221 (gtk-container-add scrolled list)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
222 (gtk-widget-set-usize scrolled 200 300)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
223 (gtk-box-pack-start hbox scrolled t t 0)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
224
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
225 (gtk-signal-connect list 'select-row
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
226 (lambda (list row column event dialog)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
227 (gtk-entry-set-text
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
228 (get dialog 'x-file-dialog-entry nil)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
229 (expand-file-name
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
230 (gtk-clist-get-text list row column)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
231 (get dialog 'x-file-dialog-current-dir nil)))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
232 (if (and (misc-user-event-p event)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
233 (event-function event))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
234 ;; Got a double or triple click event...
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
235 (gtk-button-clicked
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
236 (get dialog 'x-file-dialog-ok-button nil))))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
237 dialog)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
238
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
239 (put dialog 'x-file-dialog-files-list list))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
240
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
241 ;; Filters
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
242 (if (not (plist-get keywords :filter-list nil))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
243 ;; Don't need to bother packing this
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
244 nil
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
245 (setq hbox (gtk-hbox-new nil 0))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
246 (gtk-box-pack-start vbox hbox nil nil 0)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
247
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
248 (let ((label nil)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
249 (options (plist-get keywords :filter-list nil))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
250 (omenu nil)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
251 (menu nil)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
252 (item nil))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
253 (setq omenu (gtk-option-menu-new)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
254 menu (gtk-menu-new)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
255 label (gtk-label-new "Filter: "))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
256
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
257 (put dialog 'x-file-dialog-active-filter (cdr (car options)))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
258 (mapc (lambda (o)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
259 (setq item (gtk-menu-item-new-with-label (car o)))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
260 (gtk-signal-connect item 'activate
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
261 (lambda (obj data)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
262 (put (car data) 'x-file-dialog-active-filter (cdr data))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
263 (gtk-file-dialog-fill-file-list (car data) nil))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
264 (cons dialog (cdr o)))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
265 (gtk-menu-append menu item)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
266 (gtk-widget-show item)) options)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
267 (gtk-option-menu-set-menu omenu menu)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
268 (gtk-box-pack-end hbox omenu nil nil 0)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
269 (gtk-box-pack-end hbox label nil nil 0))))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
270
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
271 ;; Entry
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
272 (let ((entry (gtk-entry-new)))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
273 (if (plist-get keywords :directory nil)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
274 nil
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
275 (gtk-box-pack-start vbox entry nil nil 0))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
276 (if (plist-get keywords :file-must-exist nil)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
277 (progn
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
278 (gtk-widget-set-sensitive (get dialog 'x-file-dialog-ok-button nil) nil)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
279 (gtk-signal-connect entry 'changed
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
280 (lambda (entry dialog)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
281 (gtk-widget-set-sensitive
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
282 (get dialog 'x-file-dialog-ok-button)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
283 (file-exists-p (gtk-entry-get-text entry))))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
284 dialog)))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
285 (put dialog 'x-file-dialog-entry entry))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
286
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
287 (gtk-widget-realize dialog)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
288
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
289
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
290 ;; Populate the file list if necessary
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
291 (gtk-file-dialog-select-directory dialog dir)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
292 dialog))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
293
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
294 (provide 'gtk-file-dialog)