Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | package Tk::CmdLine; # -*-Perl-*- |
2 | ||
3 | #/----------------------------------------------------------------------------// | |
4 | #/ Module: Tk/CmdLine.pm | |
5 | #/ | |
6 | #/ Purpose: | |
7 | #/ | |
8 | #/ Process standard X11 command line options and set initial resources. | |
9 | #/ | |
10 | #/ Author: ???? Date: ???? | |
11 | #/ | |
12 | #/ History: SEE POD | |
13 | #/----------------------------------------------------------------------------// | |
14 | ||
15 | use vars qw($VERSION); | |
16 | $VERSION = '3.028'; # $Id: //depot/Tk8/Tk/CmdLine.pm#28 $ | |
17 | ||
18 | use 5.004; | |
19 | ||
20 | use strict; | |
21 | my $OBJECT = undef; # define the current object | |
22 | ||
23 | #/----------------------------------------------------------------------------// | |
24 | #/ Constructor | |
25 | #/ Returns the object reference. | |
26 | #/----------------------------------------------------------------------------// | |
27 | ||
28 | sub new # Tk::CmdLine::new() | |
29 | { | |
30 | my $this = shift(@_); | |
31 | my $class = ref($this) || $this; | |
32 | ||
33 | my $name = 'pTk'; | |
34 | $name = $1 if (($0 =~ m/(?:^|[\/\\])([\w-]+)(?:\.\w+)?$/) && ($1 ne '-e')); | |
35 | ||
36 | my $self = { | |
37 | name => $name, | |
38 | config => { -name => $name }, | |
39 | options => {}, | |
40 | methods => {}, | |
41 | command => [], | |
42 | synchronous => 0, | |
43 | iconic => 0, | |
44 | motif => $Tk::strictMotif, | |
45 | resources => {} }; | |
46 | ||
47 | return bless($self, $class); | |
48 | } | |
49 | ||
50 | #/----------------------------------------------------------------------------// | |
51 | #/ Process the arguments in a given array or in @ARGV. | |
52 | #/ Returns the object reference. | |
53 | #/----------------------------------------------------------------------------// | |
54 | ||
55 | sub Argument_ # Tk::CmdLine::Argument_($flag) # private method | |
56 | { | |
57 | my $self = shift(@_); | |
58 | my $flag = shift(@_); | |
59 | unless ($self->{offset} < @{$self->{argv}}) | |
60 | { | |
61 | die 'Usage: ', $self->{name}, ' ... ', $flag, " <argument> ...\n"; | |
62 | } | |
63 | return splice(@{$self->{argv}}, $self->{offset}, 1); | |
64 | } | |
65 | ||
66 | sub Config_ # Tk::CmdLine::Config_($flag, $name) # private method | |
67 | { | |
68 | my $self = shift(@_); | |
69 | my ($flag, $name) = @_; | |
70 | my $val = $self->Argument_($flag); | |
71 | push(@{$self->{command}}, $flag, $val); | |
72 | $self->{config}->{"-$name"} = $val; | |
73 | } | |
74 | ||
75 | sub Flag_ # Tk::CmdLine::Flag_($flag, $name) # private method | |
76 | { | |
77 | my $self = shift(@_); | |
78 | my ($flag, $name) = @_; | |
79 | push(@{$self->{command}}, $flag); | |
80 | $self->{$name} = 1; | |
81 | } | |
82 | ||
83 | sub Option_ # Tk::CmdLine::Option_($flag, $name) # private method | |
84 | { | |
85 | my $self = shift(@_); | |
86 | my ($flag, $name) = @_; | |
87 | my $val = $self->Argument_($flag); | |
88 | push(@{$self->{command}}, $flag, $val); | |
89 | $self->{options}->{"*$name"} = $val; | |
90 | } | |
91 | ||
92 | sub Method_ # Tk::CmdLine::Method_($flag, $name) # private method | |
93 | { | |
94 | my $self = shift(@_); | |
95 | my ($flag, $name) = @_; | |
96 | my $val = $self->Argument_($flag); | |
97 | push(@{$self->{command}}, $flag, $val); | |
98 | $self->{methods}->{$name} = $val; | |
99 | } | |
100 | ||
101 | sub Resource_ # Tk::CmdLine::Resource_($flag, $name) # private method | |
102 | { | |
103 | my $self = shift(@_); | |
104 | my ($flag, $name) = @_; | |
105 | my $val = $self->Argument_($flag); | |
106 | if ($val =~ /^([^!:\s]+)*\s*:\s*(.*)$/) | |
107 | { | |
108 | push(@{$self->{command}}, $flag, $val); | |
109 | $self->{options}->{$1} = $2; | |
110 | } | |
111 | } | |
112 | ||
113 | my %Method = ( | |
114 | background => 'Option_', | |
115 | bg => 'background', # alias | |
116 | class => 'Config_', | |
117 | display => 'screen', # alias | |
118 | fg => 'foreground', # alias | |
119 | fn => 'font', # alias | |
120 | font => 'Option_', | |
121 | foreground => 'Option_', | |
122 | geometry => 'Method_', | |
123 | iconic => 'Flag_', | |
124 | iconposition => 'Method_', | |
125 | motif => 'Flag_', | |
126 | name => 'Config_', | |
127 | screen => 'Config_', | |
128 | synchronous => 'Flag_', | |
129 | title => 'Config_', | |
130 | xrm => 'Resource_' | |
131 | ); | |
132 | ||
133 | sub SetArguments # Tk::CmdLine::SetArguments([@argument]) | |
134 | { | |
135 | my $self = (@_ # define the object as necessary | |
136 | ? ((ref($_[0]) eq __PACKAGE__) | |
137 | ? shift(@_) | |
138 | : (($_[0] eq __PACKAGE__) ? shift(@_) : 1) && ($OBJECT ||= __PACKAGE__->new())) | |
139 | : ($OBJECT ||= __PACKAGE__->new())); | |
140 | $OBJECT = $self; # update the current object | |
141 | $self->{argv} = (@_ ? [ @_ ] : \@ARGV); | |
142 | $self->{offset} = 0; # its existence will denote that this method has been called | |
143 | ||
144 | my @option = (); | |
145 | ||
146 | while ($self->{offset} < @{$self->{argv}}) | |
147 | { | |
148 | last if ($self->{argv}->[$self->{offset}] eq '--'); | |
149 | unless ( | |
150 | (($self->{argv}->[$self->{offset}] =~ /^-{1,2}(\w+)$/) && (@option = $1)) || | |
151 | (($self->{argv}->[$self->{offset}] =~ /^--(\w+)=(.*)$/) && (@option = ($1, $2)))) | |
152 | { | |
153 | ++$self->{offset}; | |
154 | next; | |
155 | } | |
156 | ||
157 | next if (!exists($Method{$option[0]}) && ++$self->{offset}); | |
158 | ||
159 | $option[0] = $Method{$option[0]} if exists($Method{$Method{$option[0]}}); | |
160 | ||
161 | my $method = $Method{$option[0]}; | |
162 | ||
163 | if (@option > 1) # replace --<option>=<value> with <value> | |
164 | { | |
165 | $self->{argv}->[$self->{offset}] = $option[1]; | |
166 | } | |
167 | else # remove the argument | |
168 | { | |
169 | splice(@{$self->{argv}}, $self->{offset}, 1); | |
170 | } | |
171 | ||
172 | $self->$method(('-' . $option[0]), $option[0]); | |
173 | } | |
174 | ||
175 | $self->{config}->{-class} ||= ucfirst($self->{config}->{-name}); | |
176 | ||
177 | delete($self->{argv}); # no longer needed | |
178 | ||
179 | return $self; | |
180 | } | |
181 | ||
182 | use vars qw(&process); *process = \&SetArguments; # alias to keep old code happy | |
183 | ||
184 | #/----------------------------------------------------------------------------// | |
185 | #/ Get the value of a configuration option (default: -class). | |
186 | #/ Returns the option value. | |
187 | #/----------------------------------------------------------------------------// | |
188 | ||
189 | sub cget # Tk::CmdLine::cget([$option]) | |
190 | { | |
191 | my $self = (@_ # define the object as necessary | |
192 | ? ((ref($_[0]) eq __PACKAGE__) | |
193 | ? shift(@_) | |
194 | : (($_[0] eq __PACKAGE__) ? shift(@_) : 1) && ($OBJECT ||= __PACKAGE__->new())) | |
195 | : ($OBJECT ||= __PACKAGE__->new())); | |
196 | $OBJECT = $self; # update the current object | |
197 | my $option = shift(@_) || '-class'; | |
198 | ||
199 | $self->SetArguments() unless exists($self->{offset}); # set arguments if not yet done | |
200 | ||
201 | return (exists($self->{config}->{$option}) ? $self->{config}->{$option} : undef); | |
202 | } | |
203 | ||
204 | #/----------------------------------------------------------------------------// | |
205 | ||
206 | sub CreateArgs # Tk::CmdLine::CreateArgs() | |
207 | { | |
208 | my $self = (@_ # define the object as necessary | |
209 | ? ((ref($_[0]) eq __PACKAGE__) | |
210 | ? shift(@_) | |
211 | : (($_[0] eq __PACKAGE__) ? shift(@_) : 1) && ($OBJECT ||= __PACKAGE__->new())) | |
212 | : ($OBJECT ||= __PACKAGE__->new())); | |
213 | $OBJECT = $self; # update the current object | |
214 | ||
215 | $self->SetArguments() unless exists($self->{offset}); # set arguments if not yet done | |
216 | ||
217 | return $self->{config}; | |
218 | } | |
219 | ||
220 | #/----------------------------------------------------------------------------// | |
221 | ||
222 | sub Tk::MainWindow::apply_command_line | |
223 | { | |
224 | my $mw = shift(@_); | |
225 | ||
226 | my $self = ($OBJECT ||= __PACKAGE__->new()); | |
227 | ||
228 | $self->SetArguments() unless exists($self->{offset}); # set arguments if not yet done | |
229 | ||
230 | foreach my $priority (keys(%{$self->{resources}})) | |
231 | { | |
232 | foreach my $resource (@{$self->{resources}->{$priority}}) | |
233 | { | |
234 | $mw->optionAdd(@{$resource}, $priority); | |
235 | } | |
236 | } | |
237 | ||
238 | foreach my $key (keys(%{$self->{options}})) | |
239 | { | |
240 | $mw->optionAdd($key => $self->{options}->{$key}, 'interactive'); | |
241 | } | |
242 | ||
243 | foreach my $key (keys(%{$self->{methods}})) | |
244 | { | |
245 | $mw->$key($self->{methods}->{$key}); | |
246 | } | |
247 | ||
248 | if ($self->{methods}->{geometry}) | |
249 | { | |
250 | if ($self->{methods}->{geometry} =~ /[+-]\d+[+-]\d+/) | |
251 | { | |
252 | $mw->positionfrom('user'); | |
253 | } | |
254 | if ($self->{methods}->{geometry} =~ /\d+x\d+/) | |
255 | { | |
256 | $mw->sizefrom('user'); | |
257 | } | |
258 | delete $self->{methods}->{geometry}; # XXX needed? | |
259 | } | |
260 | ||
261 | $mw->Synchronize() if $self->{synchronous}; | |
262 | ||
263 | if ($self->{iconic}) | |
264 | { | |
265 | $mw->iconify(); | |
266 | $self->{iconic} = 0; | |
267 | } | |
268 | ||
269 | $Tk::strictMotif = $self->{motif}; | |
270 | ||
271 | # Both these are needed to reliably save state | |
272 | # but 'hostname' is tricky to do portably. | |
273 | # $mw->client(hostname()); | |
274 | $mw->protocol('WM_SAVE_YOURSELF' => ['WMSaveYourself',$mw]); | |
275 | $mw->command([ $self->{name}, @{$self->{command}} ]); | |
276 | } | |
277 | ||
278 | #/----------------------------------------------------------------------------// | |
279 | #/ Set the initial resources. | |
280 | #/ Returns the object reference. | |
281 | #/----------------------------------------------------------------------------// | |
282 | ||
283 | sub SetResources # Tk::CmdLine::SetResources((\@resource | $resource) [, $priority]) | |
284 | { | |
285 | my $self = (@_ # define the object as necessary | |
286 | ? ((ref($_[0]) eq __PACKAGE__) | |
287 | ? shift(@_) | |
288 | : (($_[0] eq __PACKAGE__) ? shift(@_) : 1) && ($OBJECT ||= __PACKAGE__->new())) | |
289 | : ($OBJECT ||= __PACKAGE__->new())); | |
290 | $OBJECT = $self; # update the current object | |
291 | ||
292 | $self->SetArguments() unless exists($self->{offset}); # set arguments if not yet done | |
293 | return $self unless @_; | |
294 | ||
295 | my $data = shift(@_); | |
296 | my $priority = shift(@_) || 'userDefault'; | |
297 | ||
298 | $self->{resources}->{$priority} = [] unless exists($self->{resources}->{$priority}); | |
299 | ||
300 | foreach my $resource ((ref($data) eq 'ARRAY') ? @{$data} : $data) | |
301 | { | |
302 | if (ref($resource) eq 'ARRAY') # resources in [ <pattern>, <value> ] format | |
303 | { | |
304 | push(@{$self->{resources}->{$priority}}, [ @{$resource} ]) | |
305 | if (@{$resource} == 2); | |
306 | } | |
307 | else # resources in resource file format | |
308 | { | |
309 | push(@{$self->{resources}->{$priority}}, [ $1, $2 ]) | |
310 | if ($resource =~ /^([^!:\s]+)*\s*:\s*(.*)$/); | |
311 | } | |
312 | } | |
313 | ||
314 | return $self; | |
315 | } | |
316 | ||
317 | #/----------------------------------------------------------------------------// | |
318 | #/ Load initial resources from one or more files (default: $XFILESEARCHPATH with | |
319 | #/ priority 'startupFile' and $XUSERFILESEARCHPATH with priority 'userDefault'). | |
320 | #/ Returns the object reference. | |
321 | #/----------------------------------------------------------------------------// | |
322 | ||
323 | sub LoadResources # Tk::CmdLine::LoadResources([%options]) | |
324 | { | |
325 | my $self = (@_ # define the object as necessary | |
326 | ? ((ref($_[0]) eq __PACKAGE__) | |
327 | ? shift(@_) | |
328 | : (($_[0] eq __PACKAGE__) ? shift(@_) : 1) && ($OBJECT ||= __PACKAGE__->new())) | |
329 | : ($OBJECT ||= __PACKAGE__->new())); | |
330 | $OBJECT = $self; # update the current object | |
331 | ||
332 | $self->SetArguments() unless exists($self->{offset}); # set arguments if not yet done | |
333 | ||
334 | my %options = @_; | |
335 | ||
336 | my @file = (); | |
337 | my $echo = (exists($options{-echo}) | |
338 | ? (defined($options{-echo}) ? $options{-echo} : \*STDOUT) : undef); | |
339 | ||
340 | unless (%options && (exists($options{-file}) || exists($options{-symbol}))) | |
341 | { | |
342 | @file = ( | |
343 | { -symbol => 'XFILESEARCHPATH', -priority => 'startupFile' }, | |
344 | { -symbol => 'XUSERFILESEARCHPATH', -priority => 'userDefault' } ); | |
345 | } | |
346 | else | |
347 | { | |
348 | @file = { %options }; | |
349 | } | |
350 | ||
351 | foreach my $file (@file) | |
352 | { | |
353 | my $fileSpec = $file->{-spec} = undef; | |
354 | if (exists($file->{-symbol})) | |
355 | { | |
356 | my $xpath = undef; | |
357 | if ($file->{-symbol} eq 'XUSERFILESEARCHPATH') | |
358 | { | |
359 | $file->{-priority} ||= 'userDefault'; | |
360 | foreach my $symbol (qw(XUSERFILESEARCHPATH XAPPLRESDIR HOME)) | |
361 | { | |
362 | last if (exists($ENV{$symbol}) && ($xpath = $ENV{$symbol})); | |
363 | } | |
364 | next unless defined($xpath); | |
365 | } | |
366 | else | |
367 | { | |
368 | $file->{-priority} ||= (($file->{-symbol} eq 'XFILESEARCHPATH') | |
369 | ? 'startupFile' : 'userDefault'); | |
370 | next unless ( | |
371 | exists($ENV{$file->{-symbol}}) && ($xpath = $ENV{$file->{-symbol}})); | |
372 | } | |
373 | ||
374 | unless (exists($self->{translation})) | |
375 | { | |
376 | $self->{translation} = { # %l %C %S currently ignored | |
377 | '%L' => ($ENV{LANG} || 'C'), # language | |
378 | '%T' => 'app-defaults', # type | |
379 | '%N' => $self->{config}->{-class} # filename | |
380 | }; | |
381 | } | |
382 | ||
383 | my @postfix = map({ $_ . '/' . $self->{config}->{-class} } | |
384 | ('/' . $self->{translation}->{'%L'}), ''); | |
385 | ||
386 | ITEM: foreach $fileSpec (split(':', $xpath)) | |
387 | { | |
388 | if ($fileSpec =~ s/(%[A-Za-z])/$self->{translation}->{$1}/g) # File Pattern | |
389 | { | |
390 | if (defined($echo) && ($file->{-symbol} ne 'XFILESEARCHPATH')) | |
391 | { | |
392 | print $echo 'Checking ', $fileSpec, "\n"; | |
393 | } | |
394 | next unless ((-f $fileSpec) && (-r _) && (-s _)); | |
395 | $file->{-spec} = $fileSpec; | |
396 | last; | |
397 | } | |
398 | else # Directory - Check for <Directory>/$LANG/<Class>, <Directory>/<CLASS> | |
399 | { | |
400 | foreach my $postfix (@postfix) | |
401 | { | |
402 | my $fileSpec2 = $fileSpec . $postfix; | |
403 | if (defined($echo) && ($file->{-symbol} ne 'XFILESEARCHPATH')) | |
404 | { | |
405 | print $echo 'Checking ', $fileSpec2, "\n"; | |
406 | } | |
407 | next unless ((-f $fileSpec2) && (-r _) && (-s _)); | |
408 | $file->{-spec} = $fileSpec2; | |
409 | last ITEM; | |
410 | } | |
411 | } | |
412 | } | |
413 | } | |
414 | elsif (exists($file->{-file}) && ($fileSpec = $file->{-file})) | |
415 | { | |
416 | print $echo 'Checking ', $fileSpec, "\n" if defined($echo); | |
417 | next unless ((-f $fileSpec) && (-r _) && (-s _)); | |
418 | $file->{-spec} = $fileSpec; | |
419 | } | |
420 | } | |
421 | ||
422 | foreach my $file (@file) | |
423 | { | |
424 | next unless defined($file->{-spec}); | |
425 | local *SPEC; | |
426 | next unless open(SPEC,$file->{-spec}); | |
427 | print $echo ' Loading ', $file->{-spec}, "\n" if defined($echo); | |
428 | ||
429 | my $resource = undef; | |
430 | my @resource = (); | |
431 | my $continuation = 0; | |
432 | ||
433 | while (defined(my $line = <SPEC>)) | |
434 | { | |
435 | chomp($line); | |
436 | next if ($line =~ /^\s*$/); # skip blank lines | |
437 | next if ($line =~ /^\s*!/); # skip comments | |
438 | $continuation = ($line =~ s/\s*\\$/ /); # search for trailing backslash | |
439 | unless (defined($resource)) # it is the first line | |
440 | { | |
441 | $resource = $line; | |
442 | } | |
443 | else # it is a continuation line | |
444 | { | |
445 | $line =~ s/^\s*//; # remove leading whitespace | |
446 | $resource .= $line; | |
447 | } | |
448 | next if $continuation; | |
449 | push(@resource, [ $1, $2 ]) if ($resource =~ /^([^:\s]+)*\s*:\s*(.*)$/); | |
450 | $resource = undef; | |
451 | } | |
452 | ||
453 | close(SPEC); | |
454 | ||
455 | if (defined($resource)) # special case - EOF after line with trailing backslash | |
456 | { | |
457 | push(@resource, [ $1, $2 ]) if ($resource =~ /^([^:\s]+)*\s*:\s*(.*)$/); | |
458 | } | |
459 | ||
460 | $self->SetResources(\@resource, $file->{-priority}) if @resource; | |
461 | } | |
462 | ||
463 | return $self; | |
464 | } | |
465 | ||
466 | #/----------------------------------------------------------------------------// | |
467 | ||
468 | 1; | |
469 | ||
470 | __END__ | |
471 | ||
472 | =cut |