| 1 | # Copyright (c) 1995-1999 Nick Ing-Simmons. All rights reserved. |
| 2 | # This program is free software; you can redistribute it and/or |
| 3 | # modify it under the same terms as Perl itself. |
| 4 | package Tk::Widget; |
| 5 | use vars qw($VERSION @DefaultMenuLabels); |
| 6 | $VERSION = '3.078'; # $Id: //depot/Tk8/Tk/Widget.pm#78 $ |
| 7 | |
| 8 | require Tk; |
| 9 | use AutoLoader; |
| 10 | use strict; |
| 11 | use Carp; |
| 12 | use base qw(DynaLoader Tk); |
| 13 | |
| 14 | # stubs for 'autoloaded' widget classes |
| 15 | |
| 16 | sub Button; |
| 17 | sub Canvas; |
| 18 | sub Checkbutton; |
| 19 | sub Entry; |
| 20 | sub Frame; |
| 21 | sub Label; |
| 22 | sub Listbox; |
| 23 | sub Menu; |
| 24 | sub Menubutton; |
| 25 | sub Message; |
| 26 | sub Scale; |
| 27 | sub Scrollbar; |
| 28 | sub Radiobutton; |
| 29 | sub Text; |
| 30 | sub Toplevel; |
| 31 | |
| 32 | sub Pixmap; |
| 33 | sub Bitmap; |
| 34 | sub Photo; |
| 35 | |
| 36 | sub ScrlListbox; |
| 37 | sub Optionmenu; |
| 38 | |
| 39 | sub import |
| 40 | { |
| 41 | my $package = shift; |
| 42 | carp 'use Tk::Widget () to pre-load widgets is deprecated' if (@_); |
| 43 | my $need; |
| 44 | foreach $need (@_) |
| 45 | { |
| 46 | unless (defined &{$need}) |
| 47 | { |
| 48 | require "Tk/${need}.pm"; |
| 49 | } |
| 50 | croak "Cannot locate $need" unless (defined &{$need}); |
| 51 | } |
| 52 | } |
| 53 | |
| 54 | @DefaultMenuLabels = qw[~File ~Help]; |
| 55 | |
| 56 | # Some tidy-ness functions for winfo stuff |
| 57 | |
| 58 | sub True { 1 } |
| 59 | sub False { 0 } |
| 60 | |
| 61 | use Tk::Submethods( 'grab' => [qw(current status release -global)], |
| 62 | 'focus' => [qw(-force -lastfor)], |
| 63 | 'pack' => [qw(configure forget info propagate slaves)], |
| 64 | 'grid' => [qw(bbox columnconfigure configure forget info location propagate rowconfigure size slaves)], |
| 65 | 'form' => [qw(check configure forget grid info slaves)], |
| 66 | 'event' => [qw(add delete generate info)], |
| 67 | 'place' => [qw(configure forget info slaves)], |
| 68 | 'wm' => [qw(capture release)], |
| 69 | 'font' => [qw(actual configure create delete families measure metrics names)] |
| 70 | ); |
| 71 | |
| 72 | BEGIN { |
| 73 | # FIXME - these don't work in the compiler |
| 74 | *IsMenu = \&False; |
| 75 | *IsMenubutton = \&False; |
| 76 | *configure_self = \&Tk::configure; |
| 77 | *cget_self = \&Tk::cget; |
| 78 | } |
| 79 | |
| 80 | |
| 81 | |
| 82 | Direct Tk::Submethods ( |
| 83 | 'winfo' => [qw(cells class colormapfull depth exists |
| 84 | geometry height id ismapped manager name parent reqheight |
| 85 | reqwidth rootx rooty screen screencells screendepth screenheight |
| 86 | screenmmheight screenmmwidth screenvisual screenwidth visual |
| 87 | visualsavailable vrootheight viewable vrootwidth vrootx vrooty |
| 88 | width x y toplevel children pixels pointerx pointery pointerxy |
| 89 | server fpixels rgb )], |
| 90 | 'tk' => [qw(appname scaling)]); |
| 91 | |
| 92 | |
| 93 | sub DESTROY |
| 94 | { |
| 95 | my $w = shift; |
| 96 | $w->destroy if ($w->IsWidget); |
| 97 | } |
| 98 | |
| 99 | sub Install |
| 100 | { |
| 101 | # Dynamically loaded widgets add their core commands |
| 102 | # to the Tk base class here |
| 103 | my ($package,$mw) = @_; |
| 104 | } |
| 105 | |
| 106 | sub ClassInit |
| 107 | { |
| 108 | # Carry out class bindings (or whatever) |
| 109 | my ($package,$mw) = @_; |
| 110 | return $package; |
| 111 | } |
| 112 | |
| 113 | sub CreateOptions |
| 114 | { |
| 115 | return (); |
| 116 | } |
| 117 | |
| 118 | sub CreateArgs |
| 119 | { |
| 120 | my ($package,$parent,$args) = @_; |
| 121 | # Remove from hash %$args any configure-like |
| 122 | # options which only apply at create time (e.g. -colormap for Frame), |
| 123 | # or which may as well be applied right away |
| 124 | # return these as a list of -key => value pairs |
| 125 | # Augment same hash with default values for missing mandatory options, |
| 126 | # allthough this can be done later in InitObject. |
| 127 | |
| 128 | # Honour -class => if present, we have hacked Tk_ConfigureWidget to |
| 129 | # allow -class to be passed to any widget. |
| 130 | my @result = (); |
| 131 | my $class = delete $args->{'-class'}; |
| 132 | ($class) = $package =~ /([A-Z][A-Z0-9_]*)$/i unless (defined $class); |
| 133 | push(@result, '-class' => "\u$class") if (defined $class); |
| 134 | foreach my $opt ($package->CreateOptions) |
| 135 | { |
| 136 | push(@result, $opt => delete $args->{$opt}) if exists $args->{$opt}; |
| 137 | } |
| 138 | return @result; |
| 139 | } |
| 140 | |
| 141 | sub InitObject |
| 142 | { |
| 143 | my ($obj,$args) = @_; |
| 144 | # per object initialization, for example populating |
| 145 | # with sub-widgets, adding a few object bindings to augment |
| 146 | # inherited class bindings, changing binding tags. |
| 147 | # Also another chance to mess with %$args before configure... |
| 148 | } |
| 149 | |
| 150 | sub SetBindtags |
| 151 | { |
| 152 | my ($obj) = @_; |
| 153 | $obj->bindtags([ref($obj),$obj,$obj->toplevel,'all']); |
| 154 | } |
| 155 | |
| 156 | sub new |
| 157 | { |
| 158 | local $SIG{'__DIE__'} = \&Carp::croak; |
| 159 | my $package = shift; |
| 160 | my $parent = shift; |
| 161 | $package->InitClass($parent); |
| 162 | $parent->BackTrace("Odd number of args to $package->new(...)") unless ((@_ % 2) == 0); |
| 163 | my %args = @_; |
| 164 | my @args = $package->CreateArgs($parent,\%args); |
| 165 | my $cmd = $package->Tk_cmd; |
| 166 | my $pname = $parent->PathName; |
| 167 | $pname = '' if ($pname eq '.'); |
| 168 | my $leaf = delete $args{'Name'}; |
| 169 | if (defined $leaf) |
| 170 | { |
| 171 | $leaf =~ s/[^a-z0-9_]+/_/ig; |
| 172 | $leaf = lcfirst($leaf); |
| 173 | } |
| 174 | else |
| 175 | { |
| 176 | ($leaf) = "\L$package" =~ /([a-z][a-z0-9_]*)$/; |
| 177 | } |
| 178 | my $lname = $pname . '.' . $leaf; |
| 179 | # create a hash indexed by leaf name to speed up |
| 180 | # creation of a lot of sub-widgets of the same type |
| 181 | # e.g. entries in Table |
| 182 | my $nhash = $parent->TkHash('_names_'); |
| 183 | $nhash->{$leaf} = 0 unless (exists $nhash->{$leaf}); |
| 184 | while (defined ($parent->Widget($lname))) |
| 185 | { |
| 186 | $lname = $pname . '.' . $leaf . ++$nhash->{$leaf}; |
| 187 | } |
| 188 | my $obj = eval { &$cmd($parent, $lname, @args) }; |
| 189 | confess $@ if $@; |
| 190 | bless $obj,$package; |
| 191 | $obj->SetBindtags; |
| 192 | my $notice = $parent->can('NoticeChild'); |
| 193 | $parent->$notice($obj,\%args) if $notice; |
| 194 | $obj->InitObject(\%args); |
| 195 | # ASkludge(\%args,1); |
| 196 | $obj->configure(%args) if (%args); |
| 197 | # ASkludge(\%args,0); |
| 198 | return $obj; |
| 199 | } |
| 200 | |
| 201 | sub DelegateFor |
| 202 | { |
| 203 | my ($w,$method) = @_; |
| 204 | while(exists $w->{'Delegates'}) |
| 205 | { |
| 206 | my $delegate = $w->{'Delegates'}; |
| 207 | my $widget = $delegate->{$method}; |
| 208 | $widget = $delegate->{DEFAULT} unless (defined $widget); |
| 209 | $widget = $w->Subwidget($widget) if (defined $widget && !ref $widget); |
| 210 | last unless (defined $widget); |
| 211 | last if $widget == $w; |
| 212 | $w = $widget; |
| 213 | } |
| 214 | return $w; |
| 215 | } |
| 216 | |
| 217 | sub Delegates |
| 218 | { |
| 219 | my $cw = shift; |
| 220 | my $specs = $cw->TkHash('Delegates'); |
| 221 | while (@_) |
| 222 | { |
| 223 | my $key = shift; |
| 224 | my $val = shift; |
| 225 | $specs->{$key} = $val; |
| 226 | } |
| 227 | return $specs; |
| 228 | } |
| 229 | |
| 230 | sub Construct |
| 231 | { |
| 232 | my ($base,$name) = @_; |
| 233 | my $class = (caller(0))[0]; |
| 234 | no strict 'refs'; |
| 235 | |
| 236 | # Hack for broken ->isa in perl5.6.0 |
| 237 | delete ${"$class\::"}{'::ISA::CACHE::'} if $] == 5.006; |
| 238 | |
| 239 | # Pre ->isa scheme |
| 240 | *{$base.'::Is'.$name} = \&False; |
| 241 | *{$class.'::Is'.$name} = \&True; |
| 242 | |
| 243 | # DelegateFor trickyness is to allow Frames and other derived things |
| 244 | # to force creation in a delegate e.g. a ScrlText with embeded windows |
| 245 | # need those windows to be children of the Text to get clipping right |
| 246 | # and not of the Frame which contains the Text and the scrollbars. |
| 247 | *{$base.'::'."$name"} = sub { $class->new(shift->DelegateFor('Construct'),@_) }; |
| 248 | } |
| 249 | |
| 250 | sub IS |
| 251 | { |
| 252 | return (defined $_[1]) && $_[0] == $_[1]; |
| 253 | } |
| 254 | |
| 255 | sub _AutoloadTkWidget |
| 256 | { |
| 257 | my ($self,$method) = @_; |
| 258 | my $what = "Tk::Widget::$method"; |
| 259 | unless (defined &$what) |
| 260 | { |
| 261 | require "Tk/$method.pm"; |
| 262 | } |
| 263 | return $what; |
| 264 | } |
| 265 | |
| 266 | require UNIVERSAL; |
| 267 | |
| 268 | sub AUTOLOAD |
| 269 | { |
| 270 | # Take a copy into a 'my' variable so we can recurse |
| 271 | my $what = $Tk::Widget::AUTOLOAD; |
| 272 | my $save = $@; |
| 273 | my $name; |
| 274 | # warn "AUTOLOAD $what ".(ref($_[0]) || $_[0])."\n"; |
| 275 | # Braces used to preserve $1 et al. |
| 276 | { |
| 277 | my ($pkg,$func) = $what =~ /(.*)::([^:]+)$/; |
| 278 | confess("Attempt to load '$what'") unless defined($pkg) && $func =~ /^[\w:]+$/; |
| 279 | $pkg =~ s#::#/#g; |
| 280 | if (defined($name=$INC{"$pkg.pm"})) |
| 281 | { |
| 282 | $name =~ s#^(.*)$pkg\.pm$#$1auto/$pkg/$func.al#; |
| 283 | } |
| 284 | else |
| 285 | { |
| 286 | $name = "auto/$what.al"; |
| 287 | $name =~ s#::#/#g; |
| 288 | } |
| 289 | } |
| 290 | # This may fail, catch error and prevent user's __DIE__ handler |
| 291 | # from triggering as well... |
| 292 | eval {local $SIG{'__DIE__'}; require $name}; |
| 293 | if ($@) |
| 294 | { |
| 295 | croak $@ unless ($@ =~ /Can't locate\s+(?:file\s+)?'?\Q$name\E'?/); |
| 296 | my($package,$method) = ($what =~ /^(.*)::([^:]*)$/); |
| 297 | if (ref $_[0] && !$_[0]->can($method) |
| 298 | && $_[0]->can('Delegate') |
| 299 | && $method !~ /^(ConfigSpecs|Delegates)/ ) |
| 300 | { |
| 301 | my $delegate = $_[0]->Delegates; |
| 302 | if (%$delegate || tied %$delegate) |
| 303 | { |
| 304 | my $widget = $delegate->{$method}; |
| 305 | $widget = $delegate->{DEFAULT} unless (defined $widget); |
| 306 | if (defined $widget) |
| 307 | { |
| 308 | my $subwidget = (ref $widget) ? $widget : $_[0]->Subwidget($widget); |
| 309 | if (defined $subwidget) |
| 310 | { |
| 311 | no strict 'refs'; |
| 312 | # print "AUTOLOAD: $what\n"; |
| 313 | *{$what} = sub { shift->Delegate($method,@_) }; |
| 314 | } |
| 315 | else |
| 316 | { |
| 317 | croak "No delegate subwidget '$widget' for $what"; |
| 318 | } |
| 319 | } |
| 320 | } |
| 321 | } |
| 322 | if (!defined(&$what) && $method =~ /^[A-Z]\w+$/) |
| 323 | { |
| 324 | # Use ->can as ->isa is broken in perl5.6.0 |
| 325 | my $sub = UNIVERSAL::can($_[0],'_AutoloadTkWidget'); |
| 326 | if ($sub) |
| 327 | { |
| 328 | carp "Assuming 'require Tk::$method;'" unless $_[0]->can($method); |
| 329 | $what = $_[0]->$sub($method) |
| 330 | } |
| 331 | } |
| 332 | } |
| 333 | $@ = $save; |
| 334 | $DB::sub = $what; # Tell debugger what is going on... |
| 335 | unless (defined &$what) |
| 336 | { |
| 337 | no strict 'refs'; |
| 338 | *{$what} = sub { croak("Failed to AUTOLOAD '$what'") }; |
| 339 | } |
| 340 | goto &$what; |
| 341 | } |
| 342 | |
| 343 | sub _Destroyed |
| 344 | { |
| 345 | my $w = shift; |
| 346 | my $a = delete $w->{'_Destroy_'}; |
| 347 | if (ref($a)) |
| 348 | { |
| 349 | while (@$a) |
| 350 | { |
| 351 | my $ent = pop(@$a); |
| 352 | if (ref $ent) |
| 353 | { |
| 354 | eval {local $SIG{'__DIE__'}; $ent->Call }; |
| 355 | } |
| 356 | else |
| 357 | { |
| 358 | delete $w->{$ent}; |
| 359 | } |
| 360 | } |
| 361 | } |
| 362 | } |
| 363 | |
| 364 | sub _OnDestroy |
| 365 | { |
| 366 | my $w = shift; |
| 367 | $w->{'_Destroy_'} = [] unless (exists $w->{'_Destroy_'}); |
| 368 | push(@{$w->{'_Destroy_'}},@_); |
| 369 | } |
| 370 | |
| 371 | sub OnDestroy |
| 372 | { |
| 373 | my $w = shift; |
| 374 | $w->_OnDestroy(Tk::Callback->new(@_)); |
| 375 | } |
| 376 | |
| 377 | sub TkHash |
| 378 | { |
| 379 | my ($w,$key) = @_; |
| 380 | return $w->{$key} if exists $w->{$key}; |
| 381 | my $hash = $w->{$key} = {}; |
| 382 | $w->_OnDestroy($key); |
| 383 | return $hash; |
| 384 | } |
| 385 | |
| 386 | sub privateData |
| 387 | { |
| 388 | my $w = shift; |
| 389 | my $p = shift || caller; |
| 390 | $w->{$p} ||= {}; |
| 391 | } |
| 392 | |
| 393 | my @image_types; |
| 394 | my %image_method; |
| 395 | |
| 396 | sub ImageMethod |
| 397 | { |
| 398 | shift if (@_ & 1); |
| 399 | while (@_) |
| 400 | { |
| 401 | my ($name,$method) = splice(@_,0,2); |
| 402 | push(@image_types,$name); |
| 403 | $image_method{$name} = $method; |
| 404 | } |
| 405 | } |
| 406 | |
| 407 | sub Getimage |
| 408 | { |
| 409 | my ($w, $name) = @_; |
| 410 | my $mw = $w->MainWindow; |
| 411 | croak "Usage \$widget->Getimage('name')" unless defined($name); |
| 412 | my $images = ($mw->{'__Images__'} ||= {}); |
| 413 | |
| 414 | return $images->{$name} if $images->{$name}; |
| 415 | |
| 416 | ImageMethod(xpm => 'Pixmap', |
| 417 | gif => 'Photo', |
| 418 | ppm => 'Photo', |
| 419 | xbm => 'Bitmap' ) unless @image_types; |
| 420 | |
| 421 | foreach my $type (@image_types) |
| 422 | { |
| 423 | my $method = $image_method{$type}; |
| 424 | my $file = Tk->findINC( "$name.$type" ); |
| 425 | next unless( $file && $method ); |
| 426 | my $sub = $w->can($method); |
| 427 | unless (defined &$sub) |
| 428 | { |
| 429 | require Tk::widgets; |
| 430 | Tk::widgets->import($method); |
| 431 | } |
| 432 | $images->{$name} = $w->$method( -file => $file ); |
| 433 | return $images->{$name}; |
| 434 | } |
| 435 | |
| 436 | # Try built-in bitmaps |
| 437 | $images->{$name} = $w->Pixmap( -id => $name ); |
| 438 | return $images->{$name}; |
| 439 | } |
| 440 | |
| 441 | sub SaveGrabInfo |
| 442 | { |
| 443 | my $w = shift; |
| 444 | $Tk::oldGrab = $w->grabCurrent; |
| 445 | if (defined $Tk::oldGrab) |
| 446 | { |
| 447 | $Tk::grabStatus = $Tk::oldGrab->grabStatus; |
| 448 | } |
| 449 | } |
| 450 | |
| 451 | sub grabSave |
| 452 | { |
| 453 | my ($w) = @_; |
| 454 | my $grab = $w->grabCurrent; |
| 455 | return sub {} if (!defined $grab); |
| 456 | my $method = ($grab->grabStatus eq 'global') ? 'grabGlobal' : 'grab'; |
| 457 | return sub { eval {local $SIG{'__DIE__'}; $grab->$method() } }; |
| 458 | } |
| 459 | |
| 460 | sub focusCurrent |
| 461 | { |
| 462 | my ($w) = @_; |
| 463 | $w->Tk::focus('-displayof'); |
| 464 | } |
| 465 | |
| 466 | sub focusSave |
| 467 | { |
| 468 | my ($w) = @_; |
| 469 | my $focus = $w->focusCurrent; |
| 470 | return sub {} if (!defined $focus); |
| 471 | return sub { eval {local $SIG{'__DIE__'}; $focus->focus } }; |
| 472 | } |
| 473 | |
| 474 | # This is supposed to replicate Tk::after behaviour, |
| 475 | # but does auto-cancel when widget is deleted. |
| 476 | require Tk::After; |
| 477 | |
| 478 | sub afterIdle |
| 479 | { |
| 480 | my $w = shift; |
| 481 | return Tk::After->new($w,'idle','once',@_); |
| 482 | } |
| 483 | |
| 484 | sub afterCancel |
| 485 | { |
| 486 | my ($w,$what) = @_; |
| 487 | if (defined $what) |
| 488 | { |
| 489 | return $what->cancel if ref($what); |
| 490 | carp "dubious cancel of $what" if 0 && $^W; |
| 491 | $w->Tk::after('cancel' => $what); |
| 492 | } |
| 493 | } |
| 494 | |
| 495 | sub after |
| 496 | { |
| 497 | my $w = shift; |
| 498 | my $t = shift; |
| 499 | if (@_) |
| 500 | { |
| 501 | if ($t ne 'cancel') |
| 502 | { |
| 503 | require Tk::After; |
| 504 | return Tk::After->new($w,$t,'once',@_) |
| 505 | } |
| 506 | while (@_) |
| 507 | { |
| 508 | my $what = shift; |
| 509 | $w->afterCancel($what); |
| 510 | } |
| 511 | } |
| 512 | else |
| 513 | { |
| 514 | $w->Tk::after($t); |
| 515 | } |
| 516 | } |
| 517 | |
| 518 | sub repeat |
| 519 | { |
| 520 | require Tk::After; |
| 521 | my $w = shift; |
| 522 | my $t = shift; |
| 523 | return Tk::After->new($w,$t,'repeat',@_); |
| 524 | } |
| 525 | |
| 526 | sub FindMenu |
| 527 | { |
| 528 | # default FindMenu is that there is no menu. |
| 529 | return undef; |
| 530 | } |
| 531 | |
| 532 | sub XEvent { shift->{'_XEvent_'} } |
| 533 | |
| 534 | sub propertyRoot |
| 535 | { |
| 536 | my $w = shift; |
| 537 | return $w->property(@_,'root'); |
| 538 | } |
| 539 | |
| 540 | # atom, atomname, containing, interps, pathname |
| 541 | # don't work this way - there is no window arg |
| 542 | # So we pretend there was an call the C versions from Tk.xs |
| 543 | |
| 544 | sub atom { shift->InternAtom(@_) } |
| 545 | sub atomname { shift->GetAtomName(@_) } |
| 546 | sub containing { shift->Containing(@_) } |
| 547 | |
| 548 | # interps not done yet |
| 549 | # pathname not done yet |
| 550 | |
| 551 | # walk and descendants adapted from Stephen's composite |
| 552 | # versions as they only use core features they can go here. |
| 553 | # hierachy is reversed in that descendants calls walk rather |
| 554 | # than vice versa as this avoids building a list. |
| 555 | # Walk should possibly be enhanced so allow early termination |
| 556 | # like '-prune' of find. |
| 557 | |
| 558 | sub Walk |
| 559 | { |
| 560 | # Traverse a widget hierarchy while executing a subroutine. |
| 561 | my($cw, $proc, @args) = @_; |
| 562 | my $subwidget; |
| 563 | foreach $subwidget ($cw->children) |
| 564 | { |
| 565 | $subwidget->Walk($proc,@args); |
| 566 | &$proc($subwidget, @args); |
| 567 | } |
| 568 | } # end walk |
| 569 | |
| 570 | sub Descendants |
| 571 | { |
| 572 | # Return a list of widgets derived from a parent widget and all its |
| 573 | # descendants of a particular class. |
| 574 | # If class is not passed returns the entire widget hierarchy. |
| 575 | |
| 576 | my($widget, $class) = @_; |
| 577 | my(@widget_tree) = (); |
| 578 | |
| 579 | $widget->Walk( |
| 580 | sub { my ($widget,$list,$class) = @_; |
| 581 | push(@$list, $widget) if (!defined($class) or $class eq $widget->class); |
| 582 | }, |
| 583 | \@widget_tree, $class |
| 584 | ); |
| 585 | return @widget_tree; |
| 586 | } |
| 587 | |
| 588 | sub Palette |
| 589 | { |
| 590 | my $w = shift->MainWindow; |
| 591 | unless (exists $w->{_Palette_}) |
| 592 | { |
| 593 | my %Palette = (); |
| 594 | my $c = $w->Checkbutton(); |
| 595 | my $e = $w->Entry(); |
| 596 | my $s = $w->Scrollbar(); |
| 597 | $Palette{'activeBackground'} = ($c->configure('-activebackground'))[3] ; |
| 598 | $Palette{'activeForeground'} = ($c->configure('-activeforeground'))[3]; |
| 599 | $Palette{'background'} = ($c->configure('-background'))[3]; |
| 600 | $Palette{'disabledForeground'} = ($c->configure('-disabledforeground'))[3]; |
| 601 | $Palette{'foreground'} = ($c->configure('-foreground'))[3]; |
| 602 | $Palette{'highlightBackground'} = ($c->configure('-highlightbackground'))[3]; |
| 603 | $Palette{'highlightColor'} = ($c->configure('-highlightcolor'))[3]; |
| 604 | $Palette{'insertBackground'} = ($e->configure('-insertbackground'))[3]; |
| 605 | $Palette{'selectColor'} = ($c->configure('-selectcolor'))[3]; |
| 606 | $Palette{'selectBackground'} = ($e->configure('-selectbackground'))[3]; |
| 607 | $Palette{'selectForeground'} = ($e->configure('-selectforeground'))[3]; |
| 608 | $Palette{'troughColor'} = ($s->configure('-troughcolor'))[3]; |
| 609 | $c->destroy; |
| 610 | $e->destroy; |
| 611 | $s->destroy; |
| 612 | $w->{_Palette_} = \%Palette; |
| 613 | } |
| 614 | return $w->{_Palette_}; |
| 615 | } |
| 616 | |
| 617 | # tk_setPalette -- |
| 618 | # Changes the default color scheme for a Tk application by setting |
| 619 | # default colors in the option database and by modifying all of the |
| 620 | # color options for existing widgets that have the default value. |
| 621 | # |
| 622 | # Arguments: |
| 623 | # The arguments consist of either a single color name, which |
| 624 | # will be used as the new background color (all other colors will |
| 625 | # be computed from this) or an even number of values consisting of |
| 626 | # option names and values. The name for an option is the one used |
| 627 | # for the option database, such as activeForeground, not -activeforeground. |
| 628 | sub setPalette |
| 629 | { |
| 630 | my $w = shift->MainWindow; |
| 631 | my %new = (@_ == 1) ? (background => $_[0]) : @_; |
| 632 | my $priority = delete($new{'priority'}) || 'widgetDefault'; |
| 633 | |
| 634 | # Create an array that has the complete new palette. If some colors |
| 635 | # aren't specified, compute them from other colors that are specified. |
| 636 | |
| 637 | die 'must specify a background color' if (!exists $new{background}); |
| 638 | $new{'foreground'} = 'black' unless (exists $new{foreground}); |
| 639 | my @bg = $w->rgb($new{'background'}); |
| 640 | my @fg = $w->rgb($new{'foreground'}); |
| 641 | my $darkerBg = sprintf('#%02x%02x%02x',9*$bg[0]/2560,9*$bg[1]/2560,9*$bg[2]/2560); |
| 642 | foreach my $i ('activeForeground','insertBackground','selectForeground','highlightColor') |
| 643 | { |
| 644 | $new{$i} = $new{'foreground'} unless (exists $new{$i}); |
| 645 | } |
| 646 | unless (exists $new{'disabledForeground'}) |
| 647 | { |
| 648 | $new{'disabledForeground'} = sprintf('#%02x%02x%02x',(3*$bg[0]+$fg[0])/1024,(3*$bg[1]+$fg[1])/1024,(3*$bg[2]+$fg[2])/1024); |
| 649 | } |
| 650 | $new{'highlightBackground'} = $new{'background'} unless (exists $new{'highlightBackground'}); |
| 651 | |
| 652 | unless (exists $new{'activeBackground'}) |
| 653 | { |
| 654 | my @light; |
| 655 | # Pick a default active background that is lighter than the |
| 656 | # normal background. To do this, round each color component |
| 657 | # up by 15% or 1/3 of the way to full white, whichever is |
| 658 | # greater. |
| 659 | foreach my $i (0, 1, 2) |
| 660 | { |
| 661 | $light[$i] = $bg[$i]/256; |
| 662 | my $inc1 = $light[$i]*15/100; |
| 663 | my $inc2 = (255-$light[$i])/3; |
| 664 | if ($inc1 > $inc2) |
| 665 | { |
| 666 | $light[$i] += $inc1 |
| 667 | } |
| 668 | else |
| 669 | { |
| 670 | $light[$i] += $inc2 |
| 671 | } |
| 672 | $light[$i] = 255 if ($light[$i] > 255); |
| 673 | } |
| 674 | $new{'activeBackground'} = sprintf('#%02x%02x%02x',@light); |
| 675 | } |
| 676 | $new{'selectBackground'} = $darkerBg unless (exists $new{'selectBackground'}); |
| 677 | $new{'troughColor'} = $darkerBg unless (exists $new{'troughColor'}); |
| 678 | $new{'selectColor'} = '#b03060' unless (exists $new{'selectColor'}); |
| 679 | |
| 680 | # Before doing this, make sure that the Tk::Palette variable holds |
| 681 | # the default values of all options, so that tkRecolorTree can |
| 682 | # be sure to only change options that have their default values. |
| 683 | # If the variable exists, then it is already correct (it was created |
| 684 | # the last time this procedure was invoked). If the variable |
| 685 | # doesn't exist, fill it in using the defaults from a few widgets. |
| 686 | my $Palette = $w->Palette; |
| 687 | |
| 688 | # Walk the widget hierarchy, recoloring all existing windows. |
| 689 | $w->RecolorTree(\%new); |
| 690 | # Change the option database so that future windows will get the |
| 691 | # same colors. |
| 692 | foreach my $option (keys %new) |
| 693 | { |
| 694 | $w->option('add',"*$option",$new{$option},$priority); |
| 695 | # Save the options in the global variable Tk::Palette, for use the |
| 696 | # next time we change the options. |
| 697 | $Palette->{$option} = $new{$option}; |
| 698 | } |
| 699 | } |
| 700 | |
| 701 | # tkRecolorTree -- |
| 702 | # This procedure changes the colors in a window and all of its |
| 703 | # descendants, according to information provided by the colors |
| 704 | # argument. It only modifies colors that have their default values |
| 705 | # as specified by the Tk::Palette variable. |
| 706 | # |
| 707 | # Arguments: |
| 708 | # w - The name of a window. This window and all its |
| 709 | # descendants are recolored. |
| 710 | # colors - The name of an array variable in the caller, |
| 711 | # which contains color information. Each element |
| 712 | # is named after a widget configuration option, and |
| 713 | # each value is the value for that option. |
| 714 | sub RecolorTree |
| 715 | { |
| 716 | my ($w,$colors) = @_; |
| 717 | local ($@); |
| 718 | my $Palette = $w->Palette; |
| 719 | foreach my $dbOption (keys %$colors) |
| 720 | { |
| 721 | my $option = "-\L$dbOption"; |
| 722 | my $value; |
| 723 | eval {local $SIG{'__DIE__'}; $value = $w->cget($option) }; |
| 724 | if (defined $value) |
| 725 | { |
| 726 | if ($value eq $Palette->{$dbOption}) |
| 727 | { |
| 728 | $w->configure($option,$colors->{$dbOption}); |
| 729 | } |
| 730 | } |
| 731 | } |
| 732 | foreach my $child ($w->children) |
| 733 | { |
| 734 | $child->RecolorTree($colors); |
| 735 | } |
| 736 | } |
| 737 | # tkDarken -- |
| 738 | # Given a color name, computes a new color value that darkens (or |
| 739 | # brightens) the given color by a given percent. |
| 740 | # |
| 741 | # Arguments: |
| 742 | # color - Name of starting color. |
| 743 | # perecent - Integer telling how much to brighten or darken as a |
| 744 | # percent: 50 means darken by 50%, 110 means brighten |
| 745 | # by 10%. |
| 746 | sub Darken |
| 747 | { |
| 748 | my ($w,$color,$percent) = @_; |
| 749 | my @l = $w->rgb($color); |
| 750 | my $red = $l[0]/256; |
| 751 | my $green = $l[1]/256; |
| 752 | my $blue = $l[2]/256; |
| 753 | $red = int($red*$percent/100); |
| 754 | $red = 255 if ($red > 255); |
| 755 | $green = int($green*$percent/100); |
| 756 | $green = 255 if ($green > 255); |
| 757 | $blue = int($blue*$percent/100); |
| 758 | $blue = 255 if ($blue > 255); |
| 759 | sprintf('#%02x%02x%02x',$red,$green,$blue) |
| 760 | } |
| 761 | # tk_bisque -- |
| 762 | # Reset the Tk color palette to the old "bisque" colors. |
| 763 | # |
| 764 | # Arguments: |
| 765 | # None. |
| 766 | sub bisque |
| 767 | { |
| 768 | shift->setPalette('activeBackground' => '#e6ceb1', |
| 769 | 'activeForeground' => 'black', |
| 770 | 'background' => '#ffe4c4', |
| 771 | 'disabledForeground' => '#b0b0b0', |
| 772 | 'foreground' => 'black', |
| 773 | 'highlightBackground' => '#ffe4c4', |
| 774 | 'highlightColor' => 'black', |
| 775 | 'insertBackground' => 'black', |
| 776 | 'selectColor' => '#b03060', |
| 777 | 'selectBackground' => '#e6ceb1', |
| 778 | 'selectForeground' => 'black', |
| 779 | 'troughColor' => '#cdb79e' |
| 780 | ); |
| 781 | } |
| 782 | |
| 783 | sub PrintConfig |
| 784 | { |
| 785 | require Tk::Pretty; |
| 786 | my ($w) = (@_); |
| 787 | my $c; |
| 788 | foreach $c ($w->configure) |
| 789 | { |
| 790 | print Tk::Pretty::Pretty(@$c),"\n"; |
| 791 | } |
| 792 | } |
| 793 | |
| 794 | sub BusyRecurse |
| 795 | { |
| 796 | my ($restore,$w,$cursor,$recurse,$top) = @_; |
| 797 | my $c = $w->cget('-cursor'); |
| 798 | my @tags = $w->bindtags; |
| 799 | if ($top || defined($c)) |
| 800 | { |
| 801 | push(@$restore, sub { $w->configure(-cursor => $c); $w->bindtags(\@tags) }); |
| 802 | $w->configure(-cursor => $cursor); |
| 803 | } |
| 804 | else |
| 805 | { |
| 806 | push(@$restore, sub { $w->bindtags(\@tags) }); |
| 807 | } |
| 808 | $w->bindtags(['Busy',@tags]); |
| 809 | if ($recurse) |
| 810 | { |
| 811 | foreach my $child ($w->children) |
| 812 | { |
| 813 | BusyRecurse($restore,$child,$cursor,1,0); |
| 814 | } |
| 815 | } |
| 816 | return $restore; |
| 817 | } |
| 818 | |
| 819 | sub Busy |
| 820 | { |
| 821 | my ($w,%args) = @_; |
| 822 | return unless $w->viewable; |
| 823 | my $cursor = delete $args{'-cursor'}; |
| 824 | my $recurse = delete $args{'-recurse'}; |
| 825 | $cursor = 'watch' unless defined $cursor; |
| 826 | unless (exists $w->{'Busy'}) |
| 827 | { |
| 828 | my @old = ($w->grabSave); |
| 829 | my $key; |
| 830 | my @config; |
| 831 | foreach $key (keys %args) |
| 832 | { |
| 833 | push(@config,$key => $w->Tk::cget($key)); |
| 834 | } |
| 835 | if (@config) |
| 836 | { |
| 837 | push(@old, sub { $w->Tk::configure(@config) }); |
| 838 | $w->Tk::configure(%args); |
| 839 | } |
| 840 | unless ($w->Tk::bind('Busy')) |
| 841 | { |
| 842 | $w->Tk::bind('Busy','<Any-KeyPress>',[_busy => 1]); |
| 843 | $w->Tk::bind('Busy','<Any-KeyRelease>',[_busy => 0]); |
| 844 | $w->Tk::bind('Busy','<Any-ButtonPress>',[_busy => 1]); |
| 845 | $w->Tk::bind('Busy','<Any-ButtonRelease>',[_busy => 0]); |
| 846 | $w->Tk::bind('Busy','<Any-Motion>',[_busy => 0]); |
| 847 | } |
| 848 | $w->{'Busy'} = BusyRecurse(\@old,$w,$cursor,$recurse,1); |
| 849 | } |
| 850 | my $g = $w->grabCurrent; |
| 851 | if (defined $g) |
| 852 | { |
| 853 | # warn "$g has the grab"; |
| 854 | $g->grabRelease; |
| 855 | } |
| 856 | $w->update; |
| 857 | eval {local $SIG{'__DIE__'}; $w->grab }; |
| 858 | $w->update; |
| 859 | } |
| 860 | |
| 861 | sub _busy |
| 862 | { |
| 863 | my ($w,$f) = @_; |
| 864 | $w->bell if $f; |
| 865 | $w->break; |
| 866 | } |
| 867 | |
| 868 | sub Unbusy |
| 869 | { |
| 870 | my ($w) = @_; |
| 871 | $w->update; |
| 872 | $w->grabRelease; |
| 873 | my $old = delete $w->{'Busy'}; |
| 874 | if (defined $old) |
| 875 | { |
| 876 | local $SIG{'__DIE__'}; |
| 877 | eval { &{pop(@$old)} } while (@$old); |
| 878 | } |
| 879 | $w->update; |
| 880 | } |
| 881 | |
| 882 | sub waitVisibility |
| 883 | { |
| 884 | my ($w) = shift; |
| 885 | $w->tkwait('visibility',$w); |
| 886 | } |
| 887 | |
| 888 | sub waitVariable |
| 889 | { |
| 890 | my ($w) = shift; |
| 891 | $w->tkwait('variable',@_); |
| 892 | } |
| 893 | |
| 894 | sub waitWindow |
| 895 | { |
| 896 | my ($w) = shift; |
| 897 | $w->tkwait('window',$w); |
| 898 | } |
| 899 | |
| 900 | sub EventWidget |
| 901 | { |
| 902 | my ($w) = @_; |
| 903 | return $w->{'_EventWidget_'}; |
| 904 | } |
| 905 | |
| 906 | sub Popwidget |
| 907 | { |
| 908 | my ($ew,$method,$w,@args) = @_; |
| 909 | $w->{'_EventWidget_'} = $ew; |
| 910 | $w->$method(@args); |
| 911 | } |
| 912 | |
| 913 | sub ColorOptions |
| 914 | { |
| 915 | my ($w,$args) = @_; |
| 916 | my $opt; |
| 917 | $args = {} unless (defined $args); |
| 918 | foreach $opt (qw(-foreground -background -disabledforeground |
| 919 | -activebackground -activeforeground |
| 920 | )) |
| 921 | { |
| 922 | $args->{$opt} = $w->cget($opt) unless (exists $args->{$opt}) |
| 923 | } |
| 924 | return (wantarray) ? %$args : $args; |
| 925 | } |
| 926 | |
| 927 | sub XscrollBind |
| 928 | { |
| 929 | my ($mw,$class) = @_; |
| 930 | $mw->bind($class,'<Left>', ['xview','scroll',-1,'units']); |
| 931 | $mw->bind($class,'<Control-Left>', ['xview','scroll',-1,'pages']); |
| 932 | $mw->bind($class,'<Control-Prior>',['xview','scroll',-1,'pages']); |
| 933 | $mw->bind($class,'<Right>', ['xview','scroll',1,'units']); |
| 934 | $mw->bind($class,'<Control-Right>',['xview','scroll',1,'pages']); |
| 935 | $mw->bind($class,'<Control-Next>', ['xview','scroll',1,'pages']); |
| 936 | |
| 937 | $mw->bind($class,'<Home>', ['xview','moveto',0]); |
| 938 | $mw->bind($class,'<End>', ['xview','moveto',1]); |
| 939 | } |
| 940 | |
| 941 | sub PriorNextBind |
| 942 | { |
| 943 | my ($mw,$class) = @_; |
| 944 | $mw->bind($class,'<Next>', ['yview','scroll',1,'pages']); |
| 945 | $mw->bind($class,'<Prior>', ['yview','scroll',-1,'pages']); |
| 946 | } |
| 947 | |
| 948 | sub YscrollBind |
| 949 | { |
| 950 | my ($mw,$class) = @_; |
| 951 | $mw->PriorNextBind($class); |
| 952 | $mw->bind($class,'<Up>', ['yview','scroll',-1,'units']); |
| 953 | $mw->bind($class,'<Down>', ['yview','scroll',1,'units']); |
| 954 | } |
| 955 | |
| 956 | sub XYscrollBind |
| 957 | { |
| 958 | my ($mw,$class) = @_; |
| 959 | $mw->YscrollBind($class); |
| 960 | $mw->XscrollBind($class); |
| 961 | } |
| 962 | |
| 963 | sub ScrlListbox |
| 964 | { |
| 965 | my $parent = shift; |
| 966 | return $parent->Scrolled('Listbox',-scrollbars => 'w', @_); |
| 967 | } |
| 968 | |
| 969 | sub AddBindTag |
| 970 | { |
| 971 | my ($w,$tag) = @_; |
| 972 | my $t; |
| 973 | my @tags = $w->bindtags; |
| 974 | foreach $t (@tags) |
| 975 | { |
| 976 | return if $t eq $tag; |
| 977 | } |
| 978 | $w->bindtags([@tags,$tag]); |
| 979 | } |
| 980 | |
| 981 | sub Callback |
| 982 | { |
| 983 | my $w = shift; |
| 984 | my $name = shift; |
| 985 | my $cb = $w->cget($name); |
| 986 | if (defined $cb) |
| 987 | { |
| 988 | return $cb->Call(@_) if (ref $cb); |
| 989 | return $w->$cb(@_); |
| 990 | } |
| 991 | return (wantarray) ? () : undef; |
| 992 | } |
| 993 | |
| 994 | sub packAdjust |
| 995 | { |
| 996 | # print 'packAdjust(',join(',',@_),")\n"; |
| 997 | require Tk::Adjuster; |
| 998 | my ($w,%args) = @_; |
| 999 | my $delay = delete($args{'-delay'}); |
| 1000 | $delay = 1 unless (defined $delay); |
| 1001 | $w->pack(%args); |
| 1002 | %args = $w->packInfo; |
| 1003 | my $adj = Tk::Adjuster->new($args{'-in'}, |
| 1004 | -widget => $w, -delay => $delay, -side => $args{'-side'}); |
| 1005 | $adj->packed($w,%args); |
| 1006 | return $w; |
| 1007 | } |
| 1008 | |
| 1009 | sub gridAdjust |
| 1010 | { |
| 1011 | require Tk::Adjuster; |
| 1012 | my ($w,%args) = @_; |
| 1013 | my $delay = delete($args{'-delay'}); |
| 1014 | $delay = 1 unless (defined $delay); |
| 1015 | $w->grid(%args); |
| 1016 | %args = $w->gridInfo; |
| 1017 | my $adj = Tk::Adjuster->new($args{'-in'},-widget => $w, -delay => $delay); |
| 1018 | $adj->gridded($w,%args); |
| 1019 | return $w; |
| 1020 | } |
| 1021 | |
| 1022 | sub place |
| 1023 | { |
| 1024 | local $SIG{'__DIE__'} = \&Carp::croak; |
| 1025 | my $w = shift; |
| 1026 | if (@_ && $_[0] =~ /^(?:configure|forget|info|slaves)$/x) |
| 1027 | { |
| 1028 | $w->Tk::place(@_); |
| 1029 | } |
| 1030 | else |
| 1031 | { |
| 1032 | # Two things going on here: |
| 1033 | # 1. Add configure on the front so that we can drop leading '-' |
| 1034 | $w->Tk::place('configure',@_); |
| 1035 | # 2. Return the widget rather than nothing |
| 1036 | return $w; |
| 1037 | } |
| 1038 | } |
| 1039 | |
| 1040 | sub pack |
| 1041 | { |
| 1042 | local $SIG{'__DIE__'} = \&Carp::croak; |
| 1043 | my $w = shift; |
| 1044 | if (@_ && $_[0] =~ /^(?:configure|forget|info|propagate|slaves)$/x) |
| 1045 | { |
| 1046 | # maybe array/scalar context issue with slaves |
| 1047 | $w->Tk::pack(@_); |
| 1048 | } |
| 1049 | else |
| 1050 | { |
| 1051 | # Two things going on here: |
| 1052 | # 1. Add configure on the front so that we can drop leading '-' |
| 1053 | $w->Tk::pack('configure',@_); |
| 1054 | # 2. Return the widget rather than nothing |
| 1055 | return $w; |
| 1056 | } |
| 1057 | } |
| 1058 | |
| 1059 | sub grid |
| 1060 | { |
| 1061 | local $SIG{'__DIE__'} = \&Carp::croak; |
| 1062 | my $w = shift; |
| 1063 | if (@_ && $_[0] =~ /^(?:bbox|columnconfigure|configure|forget|info|location|propagate|rowconfigure|size|slaves)$/x) |
| 1064 | { |
| 1065 | my $opt = shift; |
| 1066 | Tk::grid($opt,$w,@_); |
| 1067 | } |
| 1068 | else |
| 1069 | { |
| 1070 | # Two things going on here: |
| 1071 | # 1. Add configure on the front so that we can drop leading '-' |
| 1072 | Tk::grid('configure',$w,@_); |
| 1073 | # 2. Return the widget rather than nothing |
| 1074 | return $w; |
| 1075 | } |
| 1076 | } |
| 1077 | |
| 1078 | sub form |
| 1079 | { |
| 1080 | local $SIG{'__DIE__'} = \&Carp::croak; |
| 1081 | my $w = shift; |
| 1082 | if (@_ && $_[0] =~ /^(?:configure|check|forget|grid|info|slaves)$/x) |
| 1083 | { |
| 1084 | $w->Tk::form(@_); |
| 1085 | } |
| 1086 | else |
| 1087 | { |
| 1088 | # Two things going on here: |
| 1089 | # 1. Add configure on the front so that we can drop leading '-' |
| 1090 | $w->Tk::form('configure',@_); |
| 1091 | # 2. Return the widget rather than nothing |
| 1092 | return $w; |
| 1093 | } |
| 1094 | } |
| 1095 | |
| 1096 | sub Scrolled |
| 1097 | { |
| 1098 | my ($parent,$kind,%args) = @_; |
| 1099 | # Find args that are Frame create time args |
| 1100 | my @args = Tk::Frame->CreateArgs($parent,\%args); |
| 1101 | my $name = delete $args{'Name'}; |
| 1102 | push(@args,'Name' => $name) if (defined $name); |
| 1103 | my $cw = $parent->Frame(@args); |
| 1104 | @args = (); |
| 1105 | # Now remove any args that Frame can handle |
| 1106 | foreach my $k ('-scrollbars',map($_->[0],$cw->configure)) |
| 1107 | { |
| 1108 | push(@args,$k,delete($args{$k})) if (exists $args{$k}) |
| 1109 | } |
| 1110 | # Anything else must be for target widget - pass at widget create time |
| 1111 | my $w = $cw->$kind(%args); |
| 1112 | # Now re-set %args to be ones Frame can handle |
| 1113 | %args = @args; |
| 1114 | $cw->ConfigSpecs('-scrollbars' => ['METHOD','scrollbars','Scrollbars','se'], |
| 1115 | '-background' => [$w,'background','Background'], |
| 1116 | '-foreground' => [$w,'foreground','Foreground'], |
| 1117 | ); |
| 1118 | $cw->AddScrollbars($w); |
| 1119 | $cw->Default("\L$kind" => $w); |
| 1120 | $cw->Delegates('bind' => $w, 'bindtags' => $w, 'menu' => $w); |
| 1121 | $cw->ConfigDefault(\%args); |
| 1122 | $cw->configure(%args); |
| 1123 | return $cw; |
| 1124 | } |
| 1125 | |
| 1126 | sub Populate |
| 1127 | { |
| 1128 | my ($cw,$args) = @_; |
| 1129 | } |
| 1130 | |
| 1131 | sub ForwardEvent |
| 1132 | { |
| 1133 | my $self = shift; |
| 1134 | my $to = shift; |
| 1135 | $to->PassEvent($self->XEvent); |
| 1136 | } |
| 1137 | |
| 1138 | # Save / Return abstract event type as in Tix. |
| 1139 | sub EventType |
| 1140 | { |
| 1141 | my $w = shift; |
| 1142 | $w->{'_EventType_'} = $_[0] if @_; |
| 1143 | return $w->{'_EventType_'}; |
| 1144 | } |
| 1145 | |
| 1146 | sub PostPopupMenu |
| 1147 | { |
| 1148 | my ($w, $X, $Y) = @_; |
| 1149 | if (@_ < 3) |
| 1150 | { |
| 1151 | my $e = $w->XEvent; |
| 1152 | $X = $e->X; |
| 1153 | $Y = $e->Y; |
| 1154 | } |
| 1155 | my $menu = $w->menu; |
| 1156 | $menu->Post($X,$Y) if defined $menu; |
| 1157 | } |
| 1158 | |
| 1159 | sub FillMenu |
| 1160 | { |
| 1161 | my ($w,$menu,@labels) = @_; |
| 1162 | foreach my $lab (@labels) |
| 1163 | { |
| 1164 | my $method = $lab.'MenuItems'; |
| 1165 | $method =~ s/~//g; |
| 1166 | $method =~ s/[\s-]+/_/g; |
| 1167 | if ($w->can($method)) |
| 1168 | { |
| 1169 | $menu->Menubutton(-label => $lab, -tearoff => 0, -menuitems => $w->$method()); |
| 1170 | } |
| 1171 | } |
| 1172 | return $menu; |
| 1173 | } |
| 1174 | |
| 1175 | sub menu |
| 1176 | { |
| 1177 | my ($w,$menu) = @_; |
| 1178 | if (@_ > 1) |
| 1179 | { |
| 1180 | $w->_OnDestroy('_MENU_') unless exists $w->{'_MENU_'}; |
| 1181 | $w->{'_MENU_'} = $menu; |
| 1182 | } |
| 1183 | return unless defined wantarray; |
| 1184 | unless (exists $w->{'_MENU_'}) |
| 1185 | { |
| 1186 | $w->_OnDestroy('_MENU_'); |
| 1187 | $w->{'_MENU_'} = $menu = $w->Menu(-tearoff => 0); |
| 1188 | $w->FillMenu($menu,$w->MenuLabels); |
| 1189 | } |
| 1190 | return $w->{'_MENU_'}; |
| 1191 | } |
| 1192 | |
| 1193 | sub MenuLabels |
| 1194 | { |
| 1195 | return @DefaultMenuLabels; |
| 1196 | } |
| 1197 | |
| 1198 | sub FileMenuItems |
| 1199 | { |
| 1200 | my ($w) = @_; |
| 1201 | return [ ["command"=>'E~xit', -command => [ $w, 'WmDeleteWindow']]]; |
| 1202 | } |
| 1203 | |
| 1204 | sub WmDeleteWindow |
| 1205 | { |
| 1206 | shift->toplevel->WmDeleteWindow |
| 1207 | } |
| 1208 | |
| 1209 | sub BalloonInfo |
| 1210 | { |
| 1211 | my ($widget,$balloon,$X,$Y,@opt) = @_; |
| 1212 | foreach my $opt (@opt) |
| 1213 | { |
| 1214 | my $info = $balloon->GetOption($opt,$widget); |
| 1215 | return $info if defined $info; |
| 1216 | } |
| 1217 | } |
| 1218 | |
| 1219 | |
| 1220 | |
| 1221 | 1; |
| 1222 | __END__ |
| 1223 | |
| 1224 | sub ASkludge |
| 1225 | { |
| 1226 | my ($hash,$sense) = @_; |
| 1227 | foreach my $key (%$hash) |
| 1228 | { |
| 1229 | if ($key =~ /-.*variable/ && ref($hash->{$key}) eq 'SCALAR') |
| 1230 | { |
| 1231 | if ($sense) |
| 1232 | { |
| 1233 | my $val = ${$hash->{$key}}; |
| 1234 | require Tie::Scalar; |
| 1235 | tie ${$hash->{$key}},'Tie::StdScalar'; |
| 1236 | ${$hash->{$key}} = $val; |
| 1237 | } |
| 1238 | else |
| 1239 | { |
| 1240 | untie ${$hash->{$key}}; |
| 1241 | } |
| 1242 | } |
| 1243 | } |
| 1244 | } |
| 1245 | |
| 1246 | |
| 1247 | |
| 1248 | # clipboardKeysyms -- |
| 1249 | # This procedure is invoked to identify the keys that correspond to |
| 1250 | # the "copy", "cut", and "paste" functions for the clipboard. |
| 1251 | # |
| 1252 | # Arguments: |
| 1253 | # copy - Name of the key (keysym name plus modifiers, if any, |
| 1254 | # such as "Meta-y") used for the copy operation. |
| 1255 | # cut - Name of the key used for the cut operation. |
| 1256 | # paste - Name of the key used for the paste operation. |
| 1257 | # |
| 1258 | # This method is obsolete use clipboardOperations and abstract |
| 1259 | # event types instead. See Clipboard.pm and Mainwindow.pm |
| 1260 | |
| 1261 | sub clipboardKeysyms |
| 1262 | { |
| 1263 | my @class = (); |
| 1264 | my $mw = shift; |
| 1265 | if (ref $mw) |
| 1266 | { |
| 1267 | $mw = $mw->DelegateFor('bind'); |
| 1268 | } |
| 1269 | else |
| 1270 | { |
| 1271 | push(@class,$mw); |
| 1272 | $mw = shift; |
| 1273 | } |
| 1274 | if (@_) |
| 1275 | { |
| 1276 | my $copy = shift; |
| 1277 | $mw->Tk::bind(@class,"<$copy>",'clipboardCopy') if (defined $copy); |
| 1278 | } |
| 1279 | if (@_) |
| 1280 | { |
| 1281 | my $cut = shift; |
| 1282 | $mw->Tk::bind(@class,"<$cut>",'clipboardCut') if (defined $cut); |
| 1283 | } |
| 1284 | if (@_) |
| 1285 | { |
| 1286 | my $paste = shift; |
| 1287 | $mw->Tk::bind(@class,"<$paste>",'clipboardPaste') if (defined $paste); |
| 1288 | } |
| 1289 | } |
| 1290 | |
| 1291 | sub pathname |
| 1292 | { |
| 1293 | my ($w,$id) = @_; |
| 1294 | my $x = $w->winfo('pathname',-displayof => oct($id)); |
| 1295 | return $x->PathName; |
| 1296 | } |
| 1297 | |
| 1298 | |