view release on metacpan or  search on metacpan

Tk.pm  view on Meta::CPAN

   $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::CHANGE      = 'sfsvn-' . q$Change: 27 $;
$Tk::CHANGE      = 'git-controlled';

# $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.036';
$Tk::VERSION     =~ s{_}{};
$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 get)]
                   );

#
# 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) };

Tk.pm  view on Meta::CPAN

 $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');
}

# 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);
  }