Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | # |
2 | # Copyright (c) 1992-1994 The Regents of the University of California. | |
3 | # Copyright (c) 1994 Sun Microsystems, Inc. | |
4 | # Copyright (c) 1995-1999 Nick Ing-Simmons. All rights reserved. | |
5 | # This program is free software; you can redistribute it and/or | |
6 | ||
7 | # modify it under the same terms as Perl itself, subject | |
8 | # to additional disclaimer in Tk/license.terms due to partial | |
9 | # derivation from Tk8.0 sources. | |
10 | # | |
11 | package Tk; | |
12 | require 5.00404; | |
13 | use Tk::Event (); | |
14 | use AutoLoader qw(AUTOLOAD); | |
15 | use DynaLoader; | |
16 | use base qw(Exporter DynaLoader); | |
17 | ||
18 | *fileevent = \&Tk::Event::IO::fileevent; | |
19 | ||
20 | BEGIN { | |
21 | if($^O eq 'cygwin') | |
22 | { | |
23 | require Tk::Config; | |
24 | $Tk::platform = $Tk::Config::win_arch; | |
25 | $Tk::platform = 'unix' if $Tk::platform eq 'x'; | |
26 | } | |
27 | else | |
28 | { | |
29 | $Tk::platform = ($^O eq 'MSWin32') ? $^O : 'unix'; | |
30 | } | |
31 | }; | |
32 | ||
33 | $Tk::tearoff = 1 if ($Tk::platform eq 'unix'); | |
34 | ||
35 | @EXPORT = qw(Exists Ev exit MainLoop DoOneEvent tkinit); | |
36 | @EXPORT_OK = qw(NoOp after *widget *event lsearch catch $XS_VERSION | |
37 | DONT_WAIT WINDOW_EVENTS FILE_EVENTS TIMER_EVENTS | |
38 | IDLE_EVENTS ALL_EVENTS | |
39 | NORMAL_BG ACTIVE_BG SELECT_BG | |
40 | SELECT_FG TROUGH INDICATOR DISABLED BLACK WHITE); | |
41 | %EXPORT_TAGS = (eventtypes => [qw(DONT_WAIT WINDOW_EVENTS FILE_EVENTS | |
42 | TIMER_EVENTS IDLE_EVENTS ALL_EVENTS)], | |
43 | variables => [qw(*widget *event)], | |
44 | colors => [qw(NORMAL_BG ACTIVE_BG SELECT_BG SELECT_FG | |
45 | TROUGH INDICATOR DISABLED BLACK WHITE)], | |
46 | ); | |
47 | ||
48 | use strict; | |
49 | ||
50 | use Carp; | |
51 | ||
52 | # $tk_version and $tk_patchLevel are reset by pTk when a mainwindow | |
53 | # is created, $VERSION is checked by bootstrap | |
54 | $Tk::version = '8.0'; | |
55 | $Tk::patchLevel = '8.0'; | |
56 | $Tk::VERSION = '800.023'; | |
57 | $Tk::XS_VERSION = $Tk::VERSION; | |
58 | $Tk::strictMotif = 0; | |
59 | ||
60 | {($Tk::library) = __FILE__ =~ /^(.*)\.pm$/;} | |
61 | $Tk::library = Tk->findINC('.') unless (defined($Tk::library) && -d $Tk::library); | |
62 | ||
63 | $Tk::widget = undef; | |
64 | $Tk::event = undef; | |
65 | ||
66 | use vars qw($inMainLoop); | |
67 | ||
68 | bootstrap Tk; | |
69 | ||
70 | my $boot_time = timeofday(); | |
71 | ||
72 | # This is a workround for Solaris X11 locale handling | |
73 | Preload(DynaLoader::dl_findfile('-L/usr/openwin/lib','-lX11')) | |
74 | if (NeedPreload() && -d '/usr/openwin/lib'); | |
75 | ||
76 | use Tk::Submethods ('option' => [qw(add get clear readfile)], | |
77 | 'clipboard' => [qw(clear append)] | |
78 | ); | |
79 | ||
80 | sub _backTrace | |
81 | { | |
82 | my $w = shift; | |
83 | my $i = 1; | |
84 | my ($pack,$file,$line,$sub) = caller($i++); | |
85 | while (1) | |
86 | { | |
87 | my $loc = "at $file line $line"; | |
88 | ($pack,$file,$line,$sub) = caller($i++); | |
89 | last unless defined($sub); | |
90 | return 1 if $sub eq '(eval)'; | |
91 | $w->AddErrorInfo("$sub $loc"); | |
92 | } | |
93 | return 0; | |
94 | } | |
95 | ||
96 | sub BackTrace | |
97 | { | |
98 | my $w = shift; | |
99 | return unless (@_ || $@); | |
100 | my $mess = (@_) ? shift : "$@"; | |
101 | die "$mess\n" if $w->_backTrace; | |
102 | # if we get here we are not in an eval so report now | |
103 | $w->Fail($mess); | |
104 | $w->idletasks; | |
105 | die "$mess\n"; | |
106 | } | |
107 | ||
108 | # | |
109 | # This is a $SIG{__DIE__} handler which does not change the $@ | |
110 | # string in the way 'croak' does, but rather add to Tk's ErrorInfo. | |
111 | # It stops at 1st enclosing eval on assumption that the eval | |
112 | # is part of Tk call process and will add its own context to ErrorInfo | |
113 | # and then pass on the error. | |
114 | # | |
115 | sub __DIE__ | |
116 | { | |
117 | my $mess = shift; | |
118 | my $w = $Tk::widget; | |
119 | # Note that if a __DIE__ handler returns it re-dies up the chain. | |
120 | return unless defined $w; | |
121 | return if $w->_backTrace; | |
122 | # Not in an eval - should not happen | |
123 | } | |
124 | ||
125 | sub XEvent::xy { shift->Info('xy') } | |
126 | ||
127 | sub XEvent::AUTOLOAD | |
128 | { | |
129 | my ($meth) = $XEvent::AUTOLOAD =~ /(\w)$/; | |
130 | no strict 'refs'; | |
131 | *{$XEvent::AUTOLOAD} = sub { shift->Info($meth) }; | |
132 | goto &$XEvent::AUTOLOAD; | |
133 | } | |
134 | ||
135 | sub NoOp { } | |
136 | ||
137 | sub Ev | |
138 | { | |
139 | my @args = @_; | |
140 | my $obj; | |
141 | if (@args == 1) | |
142 | { | |
143 | my $arg = pop(@args); | |
144 | $obj = (ref $arg) ? $arg : \$arg; | |
145 | } | |
146 | else | |
147 | { | |
148 | $obj = \@args; | |
149 | } | |
150 | return bless $obj,'Tk::Ev'; | |
151 | } | |
152 | ||
153 | sub InitClass | |
154 | { | |
155 | my ($package,$parent) = @_; | |
156 | croak "Unexpected type of parent $parent" unless(ref $parent); | |
157 | croak "$parent is not a widget" unless($parent->IsWidget); | |
158 | my $mw = $parent->MainWindow; | |
159 | my $hash = $mw->TkHash('_ClassInit_'); | |
160 | unless (exists $hash->{$package}) | |
161 | { | |
162 | $package->Install($mw); | |
163 | $hash->{$package} = $package->ClassInit($mw); | |
164 | } | |
165 | } | |
166 | ||
167 | require Tk::Widget; | |
168 | require Tk::Image; | |
169 | require Tk::MainWindow; | |
170 | ||
171 | sub Exists | |
172 | {my $w = shift; | |
173 | return defined($w) && ref($w) && $w->IsWidget && $w->exists; | |
174 | } | |
175 | ||
176 | sub Time_So_Far | |
177 | { | |
178 | return timeofday() - $boot_time; | |
179 | } | |
180 | ||
181 | # Selection* are not autoloaded as names are too long. | |
182 | ||
183 | sub SelectionOwn | |
184 | {my $widget = shift; | |
185 | selection('own',(@_,$widget)); | |
186 | } | |
187 | ||
188 | sub SelectionOwner | |
189 | { | |
190 | selection('own','-displayof',@_); | |
191 | } | |
192 | ||
193 | sub SelectionClear | |
194 | { | |
195 | selection('clear','-displayof',@_); | |
196 | } | |
197 | ||
198 | sub SelectionExists | |
199 | { | |
200 | selection('exists','-displayof',@_); | |
201 | } | |
202 | ||
203 | sub SelectionHandle | |
204 | {my $widget = shift; | |
205 | my $command = pop; | |
206 | selection('handle',@_,$widget,$command); | |
207 | } | |
208 | ||
209 | sub SplitString | |
210 | { | |
211 | local $_ = shift; | |
212 | my (@arr, $tmp); | |
213 | while (/\{([^{}]*)\}|((?:[^\s\\]|\\.)+)/gs) { | |
214 | if (defined $1) { push @arr, $1 } | |
215 | else { $tmp = $2 ; $tmp =~ s/\\([\s\\])/$1/g; push @arr, $tmp } | |
216 | } | |
217 | # carp '('.join(',',@arr).")"; | |
218 | return @arr; | |
219 | } | |
220 | ||
221 | sub Methods | |
222 | { | |
223 | my ($package) = caller; | |
224 | no strict 'refs'; | |
225 | foreach my $meth (@_) | |
226 | { | |
227 | my $name = $meth; | |
228 | *{$package."::$meth"} = sub { shift->WidgetMethod($name,@_) }; | |
229 | } | |
230 | } | |
231 | ||
232 | ||
233 | sub MessageBox { | |
234 | my ($kind,%args) = @_; | |
235 | require Tk::Dialog; | |
236 | my $parent = delete $args{'-parent'}; | |
237 | my $args = \%args; | |
238 | ||
239 | $args->{-bitmap} = delete $args->{-icon} if defined $args->{-icon}; | |
240 | $args->{-text} = delete $args->{-message} if defined $args->{-message}; | |
241 | $args->{-type} = 'OK' unless defined $args->{-type}; | |
242 | ||
243 | my $type; | |
244 | if (defined($type = delete $args->{-type})) { | |
245 | delete $args->{-type}; | |
246 | my @buttons = grep($_,map(ucfirst($_), | |
247 | split(/(abort|retry|ignore|yes|no|cancel|ok)/, | |
248 | lc($type)))); | |
249 | $args->{-buttons} = [@buttons]; | |
250 | $args->{-default_button} = delete $args->{-default} if | |
251 | defined $args->{-default}; | |
252 | if (not defined $args->{-default_button} and scalar(@buttons) == 1) { | |
253 | $args->{-default_button} = $buttons[0]; | |
254 | } | |
255 | my $md = $parent->Dialog(%$args); | |
256 | my $an = $md->Show; | |
257 | $md->destroy; | |
258 | return $an; | |
259 | } | |
260 | } # end messageBox | |
261 | ||
262 | sub messageBox | |
263 | { | |
264 | my ($widget,%args) = @_; | |
265 | $args{'-type'} = (exists $args{'-type'}) ? lc($args{'-type'}) : 'ok'; | |
266 | tk_messageBox(-parent => $widget, %args); | |
267 | } | |
268 | ||
269 | sub getOpenFile | |
270 | { | |
271 | tk_getOpenFile(-parent => shift,@_); | |
272 | } | |
273 | ||
274 | sub getSaveFile | |
275 | { | |
276 | tk_getSaveFile(-parent => shift,@_); | |
277 | } | |
278 | ||
279 | sub chooseColor | |
280 | { | |
281 | tk_chooseColor(-parent => shift,@_); | |
282 | } | |
283 | ||
284 | sub DialogWrapper | |
285 | { | |
286 | my ($method,$kind,%args) = @_; | |
287 | my $created = 0; | |
288 | my $w = delete $args{'-parent'}; | |
289 | if (defined $w) | |
290 | { | |
291 | $args{'-popover'} = $w; | |
292 | } | |
293 | else | |
294 | { | |
295 | $w = MainWindow->new; | |
296 | $w->withdraw; | |
297 | $created = 1; | |
298 | } | |
299 | my $mw = $w->MainWindow; | |
300 | my $fs = $mw->{$kind}; | |
301 | unless (defined $fs) | |
302 | { | |
303 | $mw->{$kind} = $fs = $mw->$method(%args); | |
304 | } | |
305 | else | |
306 | { | |
307 | $fs->configure(%args); | |
308 | } | |
309 | my $val = $fs->Show; | |
310 | $w->destroy if $created; | |
311 | return $val; | |
312 | } | |
313 | ||
314 | sub ColorDialog | |
315 | { | |
316 | require Tk::ColorEditor; | |
317 | DialogWrapper('ColorDialog',@_); | |
318 | } | |
319 | ||
320 | sub FDialog | |
321 | { | |
322 | require Tk::FBox; | |
323 | my $cmd = shift; | |
324 | if ($cmd =~ /Save/) | |
325 | { | |
326 | push @_, -type => 'save'; | |
327 | } | |
328 | DialogWrapper('FBox', $cmd, @_); | |
329 | } | |
330 | ||
331 | *MotifFDialog = \&FDialog; | |
332 | ||
333 | sub MainLoop | |
334 | { | |
335 | unless ($inMainLoop) | |
336 | { | |
337 | local $inMainLoop = 1; | |
338 | while (Tk::MainWindow->Count) | |
339 | { | |
340 | DoOneEvent(0); | |
341 | } | |
342 | } | |
343 | } | |
344 | ||
345 | sub tkinit { return MainWindow->new(@_) } | |
346 | ||
347 | # a wrapper on eval which turns off user $SIG{__DIE__} | |
348 | sub catch (&) | |
349 | { | |
350 | my $sub = shift; | |
351 | eval {local $SIG{'__DIE__'}; &$sub }; | |
352 | } | |
353 | ||
354 | my $Home; | |
355 | ||
356 | sub TranslateFileName | |
357 | { | |
358 | local $_ = shift; | |
359 | unless (defined $Home) | |
360 | { | |
361 | $Home = $ENV{'HOME'} || ($ENV{'HOMEDRIVE'}.$ENV{'HOMEPATH'}); | |
362 | $Home =~ s#\\#/#g; | |
363 | $Home .= '/' unless $Home =~ m#/$#; | |
364 | } | |
365 | s#~/#$Home#g; | |
366 | # warn $_; | |
367 | return $_; | |
368 | } | |
369 | ||
370 | sub findINC | |
371 | { | |
372 | my $file = join('/',@_); | |
373 | my $dir; | |
374 | $file =~ s,::,/,g; | |
375 | foreach $dir (@INC) | |
376 | { | |
377 | my $path; | |
378 | return $path if (-e ($path = "$dir/$file")); | |
379 | } | |
380 | return undef; | |
381 | } | |
382 | ||
383 | sub idletasks | |
384 | { | |
385 | shift->update('idletasks'); | |
386 | } | |
387 | ||
388 | ||
389 | 1; | |
390 | ||
391 | __END__ | |
392 | ||
393 | sub Error | |
394 | {my $w = shift; | |
395 | my $error = shift; | |
396 | if (Exists($w)) | |
397 | { | |
398 | my $grab = $w->grab('current'); | |
399 | $grab->Unbusy if (defined $grab); | |
400 | } | |
401 | chomp($error); | |
402 | warn "Tk::Error: $error\n " . join("\n ",@_)."\n"; | |
403 | } | |
404 | ||
405 | sub CancelRepeat | |
406 | { | |
407 | my $w = shift->MainWindow; | |
408 | my $id = delete $w->{_afterId_}; | |
409 | $w->after('cancel',$id) if (defined $id); | |
410 | } | |
411 | ||
412 | sub RepeatId | |
413 | { | |
414 | my ($w,$id) = @_; | |
415 | $w = $w->MainWindow; | |
416 | $w->CancelRepeat; | |
417 | $w->{_afterId_} = $id; | |
418 | } | |
419 | ||
420 | ||
421 | ||
422 | #---------------------------------------------------------------------------- | |
423 | # focus.tcl -- | |
424 | # | |
425 | # This file defines several procedures for managing the input | |
426 | # focus. | |
427 | # | |
428 | # @(#) focus.tcl 1.6 94/12/19 17:06:46 | |
429 | # | |
430 | # Copyright (c) 1994 Sun Microsystems, Inc. | |
431 | # | |
432 | # See the file "license.terms" for information on usage and redistribution | |
433 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. | |
434 | ||
435 | sub FocusChildren { shift->children } | |
436 | ||
437 | # | |
438 | # focusNext -- | |
439 | # This procedure is invoked to move the input focus to the next window | |
440 | # after a given one. "Next" is defined in terms of the window | |
441 | # stacking order, with all the windows underneath a given top-level | |
442 | # (no matter how deeply nested in the hierarchy) considered except | |
443 | # for frames and toplevels. | |
444 | # | |
445 | # Arguments: | |
446 | # w - Name of a window: the procedure will set the focus | |
447 | # to the next window after this one in the traversal | |
448 | # order. | |
449 | sub focusNext | |
450 | { | |
451 | my $w = shift; | |
452 | my $cur = $w; | |
453 | while (1) | |
454 | { | |
455 | # Descend to just before the first child of the current widget. | |
456 | my $parent = $cur; | |
457 | my @children = $cur->FocusChildren(); | |
458 | my $i = -1; | |
459 | # Look for the next sibling that isn't a top-level. | |
460 | while (1) | |
461 | { | |
462 | $i += 1; | |
463 | if ($i < @children) | |
464 | { | |
465 | $cur = $children[$i]; | |
466 | next if ($cur->toplevel == $cur); | |
467 | last | |
468 | } | |
469 | # No more siblings, so go to the current widget's parent. | |
470 | # If it's a top-level, break out of the loop, otherwise | |
471 | # look for its next sibling. | |
472 | $cur = $parent; | |
473 | last if ($cur->toplevel() == $cur); | |
474 | $parent = $parent->parent(); | |
475 | @children = $parent->FocusChildren(); | |
476 | $i = lsearch(\@children,$cur); | |
477 | } | |
478 | if ($cur == $w || $cur->FocusOK) | |
479 | { | |
480 | $cur->tabFocus; | |
481 | return; | |
482 | } | |
483 | } | |
484 | } | |
485 | # focusPrev -- | |
486 | # This procedure is invoked to move the input focus to the previous | |
487 | # window before a given one. "Previous" is defined in terms of the | |
488 | # window stacking order, with all the windows underneath a given | |
489 | # top-level (no matter how deeply nested in the hierarchy) considered. | |
490 | # | |
491 | # Arguments: | |
492 | # w - Name of a window: the procedure will set the focus | |
493 | # to the previous window before this one in the traversal | |
494 | # order. | |
495 | sub focusPrev | |
496 | { | |
497 | my $w = shift; | |
498 | my $cur = $w; | |
499 | my @children; | |
500 | my $i; | |
501 | my $parent; | |
502 | while (1) | |
503 | { | |
504 | # Collect information about the current window's position | |
505 | # among its siblings. Also, if the window is a top-level, | |
506 | # then reposition to just after the last child of the window. | |
507 | if ($cur->toplevel() == $cur) | |
508 | { | |
509 | $parent = $cur; | |
510 | @children = $cur->FocusChildren(); | |
511 | $i = @children; | |
512 | } | |
513 | else | |
514 | { | |
515 | $parent = $cur->parent(); | |
516 | @children = $parent->FocusChildren(); | |
517 | $i = lsearch(\@children,$cur); | |
518 | } | |
519 | # Go to the previous sibling, then descend to its last descendant | |
520 | # (highest in stacking order. While doing this, ignore top-levels | |
521 | # and their descendants. When we run out of descendants, go up | |
522 | # one level to the parent. | |
523 | while ($i > 0) | |
524 | { | |
525 | $i--; | |
526 | $cur = $children[$i]; | |
527 | next if ($cur->toplevel() == $cur); | |
528 | $parent = $cur; | |
529 | @children = $parent->FocusChildren(); | |
530 | $i = @children; | |
531 | } | |
532 | $cur = $parent; | |
533 | if ($cur == $w || $cur->FocusOK) | |
534 | { | |
535 | $cur->tabFocus; | |
536 | return; | |
537 | } | |
538 | } | |
539 | ||
540 | } | |
541 | ||
542 | sub FocusOK | |
543 | { | |
544 | my $w = shift; | |
545 | my $value; | |
546 | catch { $value = $w->cget('-takefocus') }; | |
547 | if (!$@ && defined($value)) | |
548 | { | |
549 | return 0 if ($value eq '0'); | |
550 | return $w->viewable if ($value eq '1'); | |
551 | $value = $w->$value(); | |
552 | return $value if (defined $value); | |
553 | } | |
554 | if (!$w->viewable) | |
555 | { | |
556 | return 0; | |
557 | } | |
558 | catch { $value = $w->cget('-state') } ; | |
559 | if (!$@ && defined($value) && $value eq 'disabled') | |
560 | { | |
561 | return 0; | |
562 | } | |
563 | $value = grep(/Key|Focus/,$w->Tk::bind(),$w->Tk::bind(ref($w))); | |
564 | return $value; | |
565 | } | |
566 | ||
567 | ||
568 | # focusFollowsMouse | |
569 | # | |
570 | # If this procedure is invoked, Tk will enter "focus-follows-mouse" | |
571 | # mode, where the focus is always on whatever window contains the | |
572 | # mouse. If this procedure isn't invoked, then the user typically | |
573 | # has to click on a window to give it the focus. | |
574 | # | |
575 | # Arguments: | |
576 | # None. | |
577 | ||
578 | sub EnterFocus | |
579 | { | |
580 | my $w = shift; | |
581 | my $Ev = $w->XEvent; | |
582 | my $d = $Ev->d; | |
583 | $w->Tk::focus() if ($d eq 'NotifyAncestor' || $d eq 'NotifyNonlinear' || $d eq 'NotifyInferior'); | |
584 | } | |
585 | ||
586 | sub tabFocus | |
587 | { | |
588 | shift->Tk::focus; | |
589 | } | |
590 | ||
591 | sub focusFollowsMouse | |
592 | { | |
593 | my $widget = shift; | |
594 | $widget->bind('all','<Enter>','EnterFocus'); | |
595 | } | |
596 | ||
597 | # tkTraverseToMenu -- | |
598 | # This procedure implements keyboard traversal of menus. Given an | |
599 | # ASCII character "char", it looks for a menubutton with that character | |
600 | # underlined. If one is found, it posts the menubutton's menu | |
601 | # | |
602 | # Arguments: | |
603 | # w - Window in which the key was typed (selects | |
604 | # a toplevel window). | |
605 | # char - Character that selects a menu. The case | |
606 | # is ignored. If an empty string, nothing | |
607 | # happens. | |
608 | sub TraverseToMenu | |
609 | { | |
610 | my $w = shift; | |
611 | my $char = shift; | |
612 | return unless(defined $char && $char ne ''); | |
613 | $w = $w->toplevel->FindMenu($char); | |
614 | } | |
615 | # tkFirstMenu -- | |
616 | # This procedure traverses to the first menubutton in the toplevel | |
617 | # for a given window, and posts that menubutton's menu. | |
618 | # | |
619 | # Arguments: | |
620 | # w - Name of a window. Selects which toplevel | |
621 | # to search for menubuttons. | |
622 | sub FirstMenu | |
623 | { | |
624 | my $w = shift; | |
625 | $w = $w->toplevel->FindMenu(''); | |
626 | } | |
627 | ||
628 | # These wrappers don't use method syntax so need to live | |
629 | # in same package as raw Tk routines are newXS'ed into. | |
630 | ||
631 | sub Selection | |
632 | {my $widget = shift; | |
633 | my $cmd = shift; | |
634 | croak 'Use SelectionOwn/SelectionOwner' if ($cmd eq 'own'); | |
635 | croak "Use Selection\u$cmd()"; | |
636 | } | |
637 | ||
638 | # If we have sub Clipboard in Tk then use base qw(Tk::Clipboard ....) | |
639 | # calls it when it does its eval "require $base" | |
640 | #sub Clipboard | |
641 | #{my $w = shift; | |
642 | # my $cmd = shift; | |
643 | # croak "Use clipboard\u$cmd()"; | |
644 | #} | |
645 | ||
646 | sub Receive | |
647 | { | |
648 | my $w = shift; | |
649 | warn 'Receive(' . join(',',@_) .')'; | |
650 | die 'Tk rejects send(' . join(',',@_) .")\n"; | |
651 | } | |
652 | ||
653 | sub break | |
654 | { | |
655 | die "_TK_BREAK_\n"; | |
656 | } | |
657 | ||
658 | sub updateWidgets | |
659 | { | |
660 | my ($w) = @_; | |
661 | while ($w->DoOneEvent(DONT_WAIT|IDLE_EVENTS|WINDOW_EVENTS)) | |
662 | { | |
663 | } | |
664 | $w; | |
665 | } | |
666 | ||
667 | sub ImageNames | |
668 | { | |
669 | image('names'); | |
670 | } | |
671 | ||
672 | sub ImageTypes | |
673 | { | |
674 | image('types'); | |
675 | } | |
676 | ||
677 | sub interps | |
678 | { | |
679 | my $w = shift; | |
680 | return $w->winfo('interps','-displayof'); | |
681 | } | |
682 | ||
683 | sub lsearch | |
684 | {my $ar = shift; | |
685 | my $x = shift; | |
686 | my $i; | |
687 | for ($i = 0; $i < scalar @$ar; $i++) | |
688 | { | |
689 | return $i if ($$ar[$i] eq $x); | |
690 | } | |
691 | return -1; | |
692 | } | |
693 | ||
694 | ||
695 | ||
696 |