# # Copyright (c) 1992-1994 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # Copyright (c) 1995-2004 Nick Ing-Simmons. All rights reserved. # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself, subject # to additional disclaimer in Tk/license.terms due to partial # derivation from Tk8.0 sources. # package Tk; require 5.007; use Tk::Event (); use AutoLoader qw(AUTOLOAD); use DynaLoader; use Cwd(); use base qw(Exporter DynaLoader); *fileevent = \&Tk::Event::IO::fileevent; use Encode; $Tk::encodeStopOnError = Encode::FB_QUIET(); $Tk::encodeFallback = Encode::FB_PERLQQ(); # Encode::FB_DEFAULT(); our %font_encoding = ('jis0208' => 'jis0208-raw', 'jis0212' => 'jis0212-raw', 'ksc5601' => 'ksc5601-raw', 'gb2312' => 'gb2312-raw', 'unicode' => 'ucs-2le', ); BEGIN { if($^O eq 'cygwin') { require Tk::Config; $Tk::platform = $Tk::Config::win_arch; $Tk::platform = 'unix' if $Tk::platform eq 'x'; } else { $Tk::platform = ($^O eq 'MSWin32') ? $^O : 'unix'; } }; $Tk::tearoff = 1 if ($Tk::platform eq 'unix'); @EXPORT = qw(Exists Ev exit MainLoop DoOneEvent tkinit); @EXPORT_OK = qw(NoOp after *widget *event lsearch catch $XS_VERSION DONT_WAIT WINDOW_EVENTS FILE_EVENTS TIMER_EVENTS IDLE_EVENTS ALL_EVENTS NORMAL_BG ACTIVE_BG SELECT_BG SELECT_FG TROUGH INDICATOR DISABLED BLACK WHITE); %EXPORT_TAGS = (eventtypes => [qw(DONT_WAIT WINDOW_EVENTS FILE_EVENTS TIMER_EVENTS IDLE_EVENTS ALL_EVENTS)], variables => [qw(*widget *event)], colors => [qw(NORMAL_BG ACTIVE_BG SELECT_BG SELECT_FG TROUGH INDICATOR DISABLED BLACK WHITE)], ); use strict; use Carp; # Record author's perforce depot record $Tk::CHANGE = q$Change: 3279 $; # $tk_version and $tk_patchLevel are reset by pTk when a mainwindow # is created, $VERSION is checked by bootstrap $Tk::version = '8.4'; $Tk::patchLevel = '8.4'; $Tk::VERSION = '804.027'; $Tk::XS_VERSION = $Tk::VERSION; $Tk::strictMotif = 0; {($Tk::library) = __FILE__ =~ /^(.*)\.pm$/;} $Tk::library = Tk->findINC('.') unless (defined($Tk::library) && -d $Tk::library); $Tk::widget = undef; $Tk::event = undef; use vars qw($inMainLoop); bootstrap Tk; my $boot_time = timeofday(); # This is a workround for Solaris X11 locale handling Preload(DynaLoader::dl_findfile('-L/usr/openwin/lib','-lX11')) if (NeedPreload() && -d '/usr/openwin/lib'); use Tk::Submethods ('option' => [qw(add get clear readfile)], 'clipboard' => [qw(clear append)] ); # # Next few routines are here as perl code as doing caller() # in XS code is very complicated - so instead C code calls BackTrace # sub _backTrace { my $w = shift; my $i = 1; my ($pack,$file,$line,$sub) = caller($i++); while (1) { my $loc = "at $file line $line"; ($pack,$file,$line,$sub) = caller($i++); last unless defined($sub); return 1 if $sub eq '(eval)'; $w->AddErrorInfo("$sub $loc"); } return 0; } sub BackTrace { my $w = shift; return unless (@_ || $@); my $mess = (@_) ? shift : "$@"; die "$mess\n" if $w->_backTrace; # if we get here we are not in an eval so report now $w->Fail($mess); $w->idletasks; die "$mess\n"; } # # This is a $SIG{__DIE__} handler which does not change the $@ # string in the way 'croak' does, but rather add to Tk's ErrorInfo. # It stops at 1st enclosing eval on assumption that the eval # is part of Tk call process and will add its own context to ErrorInfo # and then pass on the error. # sub __DIE__ { my $mess = shift; my $w = $Tk::widget; # Note that if a __DIE__ handler returns it re-dies up the chain. return unless defined($w) && Exists($w); # This special message is for exit() as an exception see pTkCallback.c return if $mess =~/^_TK_EXIT_\(\d+\)/; return if $w->_backTrace; # Not in an eval - should not happen } sub XEvent::xy { shift->Info('xy') } sub XEvent::AUTOLOAD { my ($meth) = $XEvent::AUTOLOAD =~ /(\w)$/; no strict 'refs'; *{$XEvent::AUTOLOAD} = sub { shift->Info($meth) }; goto &$XEvent::AUTOLOAD; } sub NoOp { } sub Ev { if (@_ == 1) { my $arg = $_[0]; return bless (((ref $arg) ? $arg : \$arg), 'Tk::Ev'); } else { return bless [@_],'Tk::Ev'; } } sub InitClass { my ($package,$parent) = @_; croak "Unexpected type of parent $parent" unless(ref $parent); croak "$parent is not a widget" unless($parent->IsWidget); my $mw = $parent->MainWindow; my $hash = $mw->TkHash('_ClassInit_'); unless (exists $hash->{$package}) { $package->Install($mw); $hash->{$package} = $package->ClassInit($mw); } } require Tk::Widget; require Tk::Image; require Tk::MainWindow; sub Exists {my $w = shift; return defined($w) && ref($w) && $w->IsWidget && $w->exists; } sub Time_So_Far { return timeofday() - $boot_time; } # Selection* are not autoloaded as names are too long. sub SelectionOwn {my $widget = shift; selection('own',(@_,$widget)); } sub SelectionOwner { selection('own','-displayof',@_); } sub SelectionClear { selection('clear','-displayof',@_); } sub SelectionExists { selection('exists','-displayof',@_); } sub SelectionHandle {my $widget = shift; my $command = pop; selection('handle',@_,$widget,$command); } sub SplitString { local $_ = shift; my (@arr, $tmp); while (/\{([^{}]*)\}|((?:[^\s\\]|\\.)+)/gs) { if (defined $1) { push @arr, $1 } else { $tmp = $2 ; $tmp =~ s/\\([\s\\])/$1/g; push @arr, $tmp } } # carp '('.join(',',@arr).")"; return @arr; } sub Methods { my ($package) = caller; no strict 'refs'; foreach my $meth (@_) { my $name = $meth; *{$package."::$meth"} = sub { shift->WidgetMethod($name,@_) }; } } my %dialog = ( tk_chooseColor => 'ColorDialog', tk_messageBox => 'MessageBox', tk_getOpenFile => 'FDialog', tk_getSaveFile => 'FDialog', tk_chooseDirectory => 'FDialog' # Slaven claims NI-S's version above does not work # and provides this # tk_chooseDirectory => 'DirDialog' ); foreach my $dialog (keys %dialog) { no strict 'refs'; unless (defined &$dialog) { my $kind = $dialog; my $code = \&{"Tk::$dialog{$dialog}"}; *$dialog = sub { &$code($kind,@_) }; } } sub MessageBox { my ($kind,%args) = @_; require Tk::Dialog; my $parent = delete $args{'-parent'}; my $args = \%args; $args->{-bitmap} = delete $args->{-icon} if defined $args->{-icon}; $args->{-text} = delete $args->{-message} if defined $args->{-message}; $args->{-type} = 'OK' unless defined $args->{-type}; my $type; if (defined($type = delete $args->{-type})) { delete $args->{-type}; my @buttons = grep($_,map(ucfirst($_), split(/(abort|retry|ignore|yes|no|cancel|ok)/, lc($type)))); $args->{-buttons} = [@buttons]; $args->{-default_button} = ucfirst(delete $args->{-default}) if defined $args->{-default}; if (not defined $args->{-default_button} and scalar(@buttons) == 1) { $args->{-default_button} = $buttons[0]; } my $md = $parent->Dialog(%$args); my $an = $md->Show; $md->destroy; return $an; } } # end messageBox sub messageBox { my ($widget,%args) = @_; # remove in a later version: if (exists $args{'-text'}) { warn "The -text option is deprecated. Please use -message instead"; if (!exists $args{'-message'}) { $args{'-message'} = delete $args{'-text'}; } } $args{'-type'} = (exists $args{'-type'}) ? lc($args{'-type'}) : 'ok'; $args{'-default'} = lc($args{'-default'}) if (exists $args{'-default'}); ucfirst tk_messageBox(-parent => $widget, %args); } sub getOpenFile { tk_getOpenFile(-parent => shift,@_); } sub getSaveFile { tk_getSaveFile(-parent => shift,@_); } sub chooseColor { tk_chooseColor(-parent => shift,@_); } sub chooseDirectory { tk_chooseDirectory(-parent => shift,@_); } sub DialogWrapper { my ($method,$kind,%args) = @_; my $created = 0; my $w = delete $args{'-parent'}; if (defined $w) { $args{'-popover'} = $w; } else { $w = MainWindow->new; $w->withdraw; $created = 1; } my $mw = $w->toplevel; my $fs = $mw->{$kind}; unless (defined $fs) { $mw->{$kind} = $fs = $mw->$method(%args); } else { $fs->configure(%args); } my $val = $fs->Show; $w->destroy if $created; return $val; } sub ColorDialog { require Tk::ColorEditor; DialogWrapper('ColorDialog',@_); } sub FDialog { require Tk::FBox; my $cmd = shift; if ($cmd =~ /Save/) { push @_, -type => 'save'; } elsif ($cmd =~ /Directory/) { push @_, -type => 'dir'; } DialogWrapper('FBox', $cmd, @_); } sub DirDialog { require Tk::DirTree; DialogWrapper('DirTreeDialog',@_); } *MotifFDialog = \&FDialog; *CORE::GLOBAL::exit = \&exit; sub MainLoop { unless ($inMainLoop) { local $inMainLoop = 1; while (Tk::MainWindow->Count) { DoOneEvent(0); } } } sub tkinit { return MainWindow->new(@_) } # a wrapper on eval which turns off user $SIG{__DIE__} sub catch (&) { my $sub = shift; eval {local $SIG{'__DIE__'}; &$sub }; } my $Home; sub TranslateFileName { local $_ = shift; unless (defined $Home) { $Home = $ENV{'HOME'} || (defined $ENV{'HOMEDRIVE'} && defined $ENV{'HOMEPATH'} ? $ENV{'HOMEDRIVE'}.$ENV{'HOMEPATH'} : ""); $Home =~ s#\\#/#g; $Home .= '/' unless $Home =~ m#/$#; } s#~/#$Home#g; # warn $_; return $_; } sub findINC { my $file = join('/',@_); my $dir; $file =~ s,::,/,g; foreach $dir (@INC) { my $path; return $path if (-e ($path = "$dir/$file")); } return undef; } sub idletasks { shift->update('idletasks'); } sub backtrace { my ($self,$msg,$i) = @_; $i = 1 if @_ < 3; while (1) { my ($pack,$file,$line,$sub) = caller($i++); last unless defined($sub); $msg .= "\n $sub at $file line $line"; } return "$msg\n"; } sub die_with_trace { my ($self,$msg) = @_; die $self->backtrace($msg,1); } 1; __END__ sub Error {my $w = shift; my $error = shift; if (Exists($w)) { my $grab = $w->grab('current'); $grab->Unbusy if (defined $grab); } chomp($error); warn "Tk::Error: $error\n " . join("\n ",@_)."\n"; } sub CancelRepeat { my $w = shift->MainWindow; my $id = delete $w->{_afterId_}; $w->after('cancel',$id) if (defined $id); } sub RepeatId { my ($w,$id) = @_; $w = $w->MainWindow; $w->CancelRepeat; $w->{_afterId_} = $id; } #---------------------------------------------------------------------------- # focus.tcl -- # # This file defines several procedures for managing the input # focus. # # @(#) focus.tcl 1.6 94/12/19 17:06:46 # # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. sub FocusChildren { shift->children } # # focusNext -- # This procedure is invoked to move the input focus to the next window # after a given one. "Next" is defined in terms of the window # stacking order, with all the windows underneath a given top-level # (no matter how deeply nested in the hierarchy) considered except # for frames and toplevels. # # Arguments: # w - Name of a window: the procedure will set the focus # to the next window after this one in the traversal # order. sub focusNext { my $w = shift; my $cur = $w; while (1) { # Descend to just before the first child of the current widget. my $parent = $cur; my @children = $cur->FocusChildren(); my $i = -1; # Look for the next sibling that isn't a top-level. while (1) { $i += 1; if ($i < @children) { $cur = $children[$i]; next if ($cur->toplevel == $cur); last } # No more siblings, so go to the current widget's parent. # If it's a top-level, break out of the loop, otherwise # look for its next sibling. $cur = $parent; last if ($cur->toplevel() == $cur); $parent = $parent->parent(); @children = $parent->FocusChildren(); $i = lsearch(\@children,$cur); } if ($cur == $w || $cur->FocusOK) { $cur->tabFocus; return; } } } # focusPrev -- # This procedure is invoked to move the input focus to the previous # window before a given one. "Previous" is defined in terms of the # window stacking order, with all the windows underneath a given # top-level (no matter how deeply nested in the hierarchy) considered. # # Arguments: # w - Name of a window: the procedure will set the focus # to the previous window before this one in the traversal # order. sub focusPrev { my $w = shift; my $cur = $w; my @children; my $i; my $parent; while (1) { # Collect information about the current window's position # among its siblings. Also, if the window is a top-level, # then reposition to just after the last child of the window. if ($cur->toplevel() == $cur) { $parent = $cur; @children = $cur->FocusChildren(); $i = @children; } else { $parent = $cur->parent(); @children = $parent->FocusChildren(); $i = lsearch(\@children,$cur); } # Go to the previous sibling, then descend to its last descendant # (highest in stacking order. While doing this, ignore top-levels # and their descendants. When we run out of descendants, go up # one level to the parent. while ($i > 0) { $i--; $cur = $children[$i]; next if ($cur->toplevel() == $cur); $parent = $cur; @children = $parent->FocusChildren(); $i = @children; } $cur = $parent; if ($cur == $w || $cur->FocusOK) { $cur->tabFocus; return; } } } sub FocusOK { my $w = shift; my $value; catch { $value = $w->cget('-takefocus') }; if (!$@ && defined($value)) { return 0 if ($value eq '0'); return $w->viewable if ($value eq '1'); if ($value) { $value = $w->$value(); return $value if (defined $value); } } if (!$w->viewable) { return 0; } catch { $value = $w->cget('-state') } ; if (!$@ && defined($value) && $value eq 'disabled') { return 0; } $value = grep(/Key|Focus/,$w->Tk::bind(),$w->Tk::bind(ref($w))); return $value; } # focusFollowsMouse # # If this procedure is invoked, Tk will enter "focus-follows-mouse" # mode, where the focus is always on whatever window contains the # mouse. If this procedure isn't invoked, then the user typically # has to click on a window to give it the focus. # # Arguments: # None. sub EnterFocus { my $w = shift; return unless $w; my $Ev = $w->XEvent; my $d = $Ev->d; $w->Tk::focus() if ($d eq 'NotifyAncestor' || $d eq 'NotifyNonlinear' || $d eq 'NotifyInferior'); } sub tabFocus { shift->Tk::focus; } sub focusFollowsMouse { my $widget = shift; $widget->bind('all','','EnterFocus'); } # tkTraverseToMenu -- # This procedure implements keyboard traversal of menus. Given an # ASCII character "char", it looks for a menubutton with that character # underlined. If one is found, it posts the menubutton's menu # # Arguments: # w - Window in which the key was typed (selects # a toplevel window). # char - Character that selects a menu. The case # is ignored. If an empty string, nothing # happens. sub TraverseToMenu { my $w = shift; my $char = shift; return unless(defined $char && $char ne ''); $w = $w->toplevel->FindMenu($char); } # tkFirstMenu -- # This procedure traverses to the first menubutton in the toplevel # for a given window, and posts that menubutton's menu. # # Arguments: # w - Name of a window. Selects which toplevel # to search for menubuttons. sub FirstMenu { my $w = shift; $w = $w->toplevel->FindMenu(''); } # These wrappers don't use method syntax so need to live # in same package as raw Tk routines are newXS'ed into. sub Selection {my $widget = shift; my $cmd = shift; croak 'Use SelectionOwn/SelectionOwner' if ($cmd eq 'own'); croak "Use Selection\u$cmd()"; } # If we have sub Clipboard in Tk then use base qw(Tk::Clipboard ....) # calls it when it does its eval "require $base" #sub Clipboard #{my $w = shift; # my $cmd = shift; # croak "Use clipboard\u$cmd()"; #} sub Receive { my $w = shift; warn 'Receive(' . join(',',@_) .')'; die 'Tk rejects send(' . join(',',@_) .")\n"; } sub break { die "_TK_BREAK_\n"; } sub updateWidgets { my ($w) = @_; while ($w->DoOneEvent(DONT_WAIT|IDLE_EVENTS|WINDOW_EVENTS)) { } $w; } sub ImageNames { image('names'); } sub ImageTypes { image('types'); } sub interps { my $w = shift; return $w->winfo('interps','-displayof'); } sub lsearch {my $ar = shift; my $x = shift; my $i; for ($i = 0; $i < scalar @$ar; $i++) { return $i if ($$ar[$i] eq $x); } return -1; } sub getEncoding { my ($class,$name) = @_; eval { require Encode }; if ($@) { require Tk::DummyEncode; return Tk::DummyEncode->getEncoding($name); } $name = $Tk::font_encoding{$name} if exists $Tk::font_encoding{$name}; my $enc = Encode::find_encoding($name); unless ($enc) { $enc = Encode::find_encoding($name) if ($name =~ s/[-_]\d+$//) } # if ($enc) # { # print STDERR "Lookup '$name' => ".$enc->name."\n"; # } # else # { # print STDERR "Failed '$name'\n"; # } unless ($enc) { if ($name eq 'X11ControlChars') { require Tk::DummyEncode; $Encode::encoding{$name} = $enc = Tk::DummyEncode->getEncoding($name); } } return $enc; }