package Tk;
require 5.00404;
use     Tk::Event();
use     AutoLoader qw(AUTOLOAD);
use     DynaLoader;
use base qw(Exporter DynaLoader);
*fileevent=\&Tk::Event::IO::fileevent;
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;
$Tk::version='8.0';
$Tk::patchLevel='8.0';
$Tk::VERSION     = '800.023';
$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();
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)]);
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;
$w->Fail($mess);
$w->idletasks;
die"$mess\n";}sub __DIE__{my$mess=shift;
my$w=$Tk::widget;
return unless defined$w;
return if$w->_backTrace;}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{my@args=@_;
my$obj;
if(@args==1){my$arg=pop(@args);
$obj=(ref$arg)?$arg:\$arg;}else{$obj=\@args;}return bless$obj,'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;}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}}return@arr;}sub Methods{my($package)=caller;
no strict 'refs';
foreach my $meth(@_){my$name=$meth;
*{$package."::$meth"}=sub{shift->WidgetMethod($name,@_)};}}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}=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;}}sub messageBox{my($widget,%args)=@_;
$args{'-type'}=(exists$args{'-type'})?lc($args{'-type'}):'ok';
tk_messageBox(-parent=>$widget,%args);}sub getOpenFile{tk_getOpenFile(-parent=>shift,@_);}sub getSaveFile{tk_getSaveFile(-parent=>shift,@_);}sub chooseColor{tk_chooseColor(-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->MainWindow;
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';}DialogWrapper('FBox',$cmd,@_);}*MotifFDialog=\&FDialog;
sub MainLoop{unless($inMainLoop){local$inMainLoop=1;
while(Tk::MainWindow->Count){DoOneEvent(0);}}}sub tkinit{return MainWindow->new(@_)}sub catch (&){my$sub=shift;
eval{local$SIG{'__DIE__'};&$sub};}my$Home;
sub TranslateFileName{local$_=shift;
unless(defined$Home){$Home=$ENV{'HOME'}||($ENV{'HOMEDRIVE'}.$ENV{'HOMEPATH'});
$Home=~s#\\#/#g;
$Home.='/' unless$Home=~m#/$#;}s#~/#$Home#g;
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');}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;}sub FocusChildren{shift->children}sub focusNext{my$w=shift;
my$cur=$w;
while(1){my$parent=$cur;
my@children=$cur->FocusChildren();
my$i=-1;
while(1){$i+=1;
if($i<@children){$cur=$children[$i];
next if($cur->toplevel==$cur);
last}$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;}}}sub focusPrev{my$w=shift;
my$cur=$w;
my@children;
my$i;
my$parent;
while(1){if($cur->toplevel()==$cur){$parent=$cur;
@children=$cur->FocusChildren();
$i=@children;}else{$parent=$cur->parent();
@children=$parent->FocusChildren();
$i=lsearch(\@children,$cur);}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');
$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;}sub EnterFocus{my$w=shift;
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','<Enter>','EnterFocus');}sub TraverseToMenu{my$w=shift;
my$char=shift;
return unless(defined$char&&$char ne '');
$w=$w->toplevel->FindMenu($char);}sub FirstMenu{my$w=shift;
$w=$w->toplevel->FindMenu('');}sub Selection{my$widget=shift;
my$cmd=shift;
croak 'Use SelectionOwn/SelectionOwner' if($cmd eq 'own');
croak"Use Selection\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;}
