Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | package Tk::Tree; |
2 | # Tree -- TixTree widget | |
3 | # | |
4 | # Derived from Tree.tcl in Tix 4.1 | |
5 | # | |
6 | # Chris Dean <ctdean@cogit.com> | |
7 | ||
8 | use vars qw($VERSION); | |
9 | $VERSION = '3.019'; # $Id: //depot/Tk8/Tixish/Tree.pm#19 $ | |
10 | ||
11 | use Tk (); | |
12 | use Tk::Derived; | |
13 | use Tk::HList; | |
14 | use base qw(Tk::Derived Tk::HList); | |
15 | use strict; | |
16 | ||
17 | Construct Tk::Widget 'Tree'; | |
18 | ||
19 | sub Tk::Widget::ScrlTree { shift->Scrolled('Tree' => @_) } | |
20 | ||
21 | sub Populate | |
22 | { | |
23 | my( $w, $args ) = @_; | |
24 | ||
25 | $w->SUPER::Populate( $args ); | |
26 | ||
27 | $w->ConfigSpecs( | |
28 | -ignoreinvoke => ['PASSIVE', 'ignoreInvoke', 'IgnoreInvoke', 0], | |
29 | -opencmd => ['CALLBACK', 'openCmd', 'OpenCmd', 'OpenCmd' ], | |
30 | -indicatorcmd => ['CALLBACK', 'indicatorCmd', 'IndicatorCmd', 'IndicatorCmd'], | |
31 | -closecmd => ['CALLBACK', 'closeCmd', 'CloseCmd', 'CloseCmd'], | |
32 | -indicator => ['SELF', 'indicator', 'Indicator', 1], | |
33 | -indent => ['SELF', 'indent', 'Indent', 20], | |
34 | -width => ['SELF', 'width', 'Width', 20], | |
35 | -itemtype => ['SELF', 'itemtype', 'Itemtype', 'imagetext'], | |
36 | ); | |
37 | } | |
38 | ||
39 | sub autosetmode | |
40 | { | |
41 | my( $w ) = @_; | |
42 | $w->setmode(); | |
43 | } | |
44 | ||
45 | sub IndicatorCmd | |
46 | { | |
47 | my( $w, $ent, $event ) = @_; | |
48 | ||
49 | my $mode = $w->getmode( $ent ); | |
50 | ||
51 | if ( $event eq '<Arm>' ) | |
52 | { | |
53 | if ($mode eq 'open' ) | |
54 | { | |
55 | $w->_indicator_image( $ent, 'plusarm' ); | |
56 | } | |
57 | else | |
58 | { | |
59 | $w->_indicator_image( $ent, 'minusarm' ); | |
60 | } | |
61 | } | |
62 | elsif ( $event eq '<Disarm>' ) | |
63 | { | |
64 | if ($mode eq 'open' ) | |
65 | { | |
66 | $w->_indicator_image( $ent, 'plus' ); | |
67 | } | |
68 | else | |
69 | { | |
70 | $w->_indicator_image( $ent, 'minus' ); | |
71 | } | |
72 | } | |
73 | elsif( $event eq '<Activate>' ) | |
74 | { | |
75 | $w->Activate( $ent, $mode ); | |
76 | $w->Callback( -browsecmd => $ent ); | |
77 | } | |
78 | } | |
79 | ||
80 | sub close | |
81 | { | |
82 | my( $w, $ent ) = @_; | |
83 | my $mode = $w->getmode( $ent ); | |
84 | $w->Activate( $ent, $mode ) if( $mode eq 'close' ); | |
85 | } | |
86 | ||
87 | sub open | |
88 | { | |
89 | my( $w, $ent ) = @_; | |
90 | my $mode = $w->getmode( $ent ); | |
91 | $w->Activate( $ent, $mode ) if( $mode eq 'open' ); | |
92 | } | |
93 | ||
94 | sub getmode | |
95 | { | |
96 | my( $w, $ent ) = @_; | |
97 | ||
98 | return( 'none' ) unless $w->indicatorExists( $ent ); | |
99 | ||
100 | my $img = $w->_indicator_image( $ent ); | |
101 | return( 'open' ) if( $img eq 'plus' || $img eq 'plusarm' ); | |
102 | return( 'close' ); | |
103 | } | |
104 | ||
105 | sub setmode | |
106 | { | |
107 | my ($w,$ent,$mode) = @_; | |
108 | unless (defined $mode) | |
109 | { | |
110 | $mode = 'none'; | |
111 | my @args; | |
112 | push(@args,$ent) if defined $ent; | |
113 | my @children = $w->infoChildren( @args ); | |
114 | if ( @children ) | |
115 | { | |
116 | $mode = 'close'; | |
117 | foreach my $c (@children) | |
118 | { | |
119 | $mode = 'open' if $w->infoHidden( $c ); | |
120 | $w->setmode( $c ); | |
121 | } | |
122 | } | |
123 | } | |
124 | ||
125 | if (defined $ent) | |
126 | { | |
127 | if ( $mode eq 'open' ) | |
128 | { | |
129 | $w->_indicator_image( $ent, 'plus' ); | |
130 | } | |
131 | elsif ( $mode eq 'close' ) | |
132 | { | |
133 | $w->_indicator_image( $ent, 'minus' ); | |
134 | } | |
135 | elsif( $mode eq 'none' ) | |
136 | { | |
137 | $w->_indicator_image( $ent, undef ); | |
138 | } | |
139 | } | |
140 | } | |
141 | ||
142 | sub Activate | |
143 | { | |
144 | my( $w, $ent, $mode ) = @_; | |
145 | if ( $mode eq 'open' ) | |
146 | { | |
147 | $w->Callback( -opencmd => $ent ); | |
148 | $w->_indicator_image( $ent, 'minus' ); | |
149 | } | |
150 | elsif ( $mode eq 'close' ) | |
151 | { | |
152 | $w->Callback( -closecmd => $ent ); | |
153 | $w->_indicator_image( $ent, 'plus' ); | |
154 | } | |
155 | else | |
156 | { | |
157 | ||
158 | } | |
159 | } | |
160 | ||
161 | sub OpenCmd | |
162 | { | |
163 | my( $w, $ent ) = @_; | |
164 | # The default action | |
165 | foreach my $kid ($w->infoChildren( $ent )) | |
166 | { | |
167 | $w->show( -entry => $kid ); | |
168 | } | |
169 | } | |
170 | ||
171 | sub CloseCmd | |
172 | { | |
173 | my( $w, $ent ) = @_; | |
174 | ||
175 | # The default action | |
176 | foreach my $kid ($w->infoChildren( $ent )) | |
177 | { | |
178 | $w->hide( -entry => $kid ); | |
179 | } | |
180 | } | |
181 | ||
182 | sub Command | |
183 | { | |
184 | my( $w, $ent ) = @_; | |
185 | ||
186 | return if $w->{Configure}{-ignoreInvoke}; | |
187 | ||
188 | $w->Activate( $ent, $w->getmode( $ent ) ) if $w->indicatorExists( $ent ); | |
189 | } | |
190 | ||
191 | sub _indicator_image | |
192 | { | |
193 | my( $w, $ent, $image ) = @_; | |
194 | my $data = $w->privateData(); | |
195 | if (@_ > 2) | |
196 | { | |
197 | if (defined $image) | |
198 | { | |
199 | $w->indicatorCreate( $ent, -itemtype => 'image' ) | |
200 | unless $w->indicatorExists($ent); | |
201 | $data->{$ent} = $image; | |
202 | $w->indicatorConfigure( $ent, -image => $w->Getimage( $image ) ); | |
203 | } | |
204 | else | |
205 | { | |
206 | $w->indicatorDelete( $ent ) if $w->indicatorExists( $ent ); | |
207 | delete $data->{$ent}; | |
208 | } | |
209 | } | |
210 | return $data->{$ent}; | |
211 | } | |
212 | ||
213 | 1; | |
214 | ||
215 | __END__ | |
216 | ||
217 | # Copyright (c) 1996, Expert Interface Technologies | |
218 | # See the file "license.terms" for information on usage and redistribution | |
219 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. | |
220 | # | |
221 | # The file man.macros and some of the macros used by this file are | |
222 | # copyrighted: (c) 1990 The Regents of the University of California. | |
223 | # (c) 1994-1995 Sun Microsystems, Inc. | |
224 | # The license terms of the Tcl/Tk distrobution are in the file | |
225 | # license.tcl. | |
226 | ||
227 | =cut |