aboutsummaryrefslogtreecommitdiff
path: root/Perl
diff options
context:
space:
mode:
Diffstat (limited to 'Perl')
-rw-r--r--Perl/trace/Makefile.PL7
-rw-r--r--Perl/trace/Tk.pm784
2 files changed, 791 insertions, 0 deletions
diff --git a/Perl/trace/Makefile.PL b/Perl/trace/Makefile.PL
new file mode 100644
index 0000000..a1df3e4
--- /dev/null
+++ b/Perl/trace/Makefile.PL
@@ -0,0 +1,7 @@
+use Tk::MMutil;
+
+Tk::MMutil::TkExtMakefile(
+ 'NAME' => 'ZincTrace::Tk',
+ );
+
+
diff --git a/Perl/trace/Tk.pm b/Perl/trace/Tk.pm
new file mode 100644
index 0000000..dba2274
--- /dev/null
+++ b/Perl/trace/Tk.pm
@@ -0,0 +1,784 @@
+#
+# Copyright (c) 1992-1994 The Regents of the University of California.
+# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1995-1999 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.
+#
+# Copyright (c) 2002 CENA, C.Mertz <mert@cena.fr> to trace all
+# Tk::Zinc methods calls as well as the args in a human readable
+# form.
+# By adding the directory of this file in the perl list of directories
+# in which to look for Perl library files, this file will replace the standard
+# Tk.pm and it will trace every Tk::Zinc method call in your application.
+#
+# This may be very usefull when your application segfaults or encounters
+# errors such as "blabla...bla at /usr/lib/perl5/Tk.pm line 228" and
+# when you have no idea where this happens in your code
+#
+# for using this file do some thing like :
+# perl -I/.../thedir/ myappli.pl
+# or
+# add /.../thedir to the environment variable PERL5LIB (or PERLIB)
+# or
+# modify the code of your main script with
+# BEGIN { unshift (@INC, "/.../thedir") }
+#
+# /.../thedir may vary from one installation to another!
+
+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 and $tk_patchLevel are reset by pTk when a mainwindow
+# is created, $VERSION is checked by bootstrap
+$Tk::version = '8.0';
+$Tk::patchLevel = '8.0';
+$Tk::VERSION = '800.024';
+$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)]
+ );
+
+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;
+ 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
+{
+ 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;
+}
+
+# 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;
+}
+
+my ($lastMethod, $package, $filename, $line);
+sub Methods
+{
+ my ($package) = caller;
+ no strict 'refs';
+ foreach my $meth (@_)
+ {
+ my $name = $meth;
+ *{$package."::$meth"} = sub { $lastMethod=$package."::$meth";
+ ($package, $filename, $line) = caller;
+ $package="" unless defined $package;
+ $filename="" unless defined $filename;
+ $line="" unless defined $line;
+ my $obj = shift;
+ if ($obj =~ /^Tk::Zinc/) {
+ print "$name at $filename line $line ";
+ &printList (@_);
+ print "\n";
+ }
+ $obj->WidgetMethod($name,@_) };
+ }
+}
+
+### to print something
+sub printItem {
+ my ($value) = @_;
+ my $ref = ref($value);
+# print "VALUE=$value REF=$ref\n";
+ if ($ref eq 'ARRAY') {
+ printArray ( @{$value} );
+ }
+ elsif ($ref eq 'CODE') {
+ print "{CODE}";
+ }
+ elsif ($ref eq 'Tk::Photo') {
+ print "Tk::Photo(\"". scalar $value->cget(-file) . "\)";
+ }
+ elsif ($ref eq '') { # scalar
+ if (defined $value) {
+ if ($value eq '') {
+ print "''";
+ }
+ else {
+ print $value;
+ }
+ }
+ else {
+ print "undef";
+ }
+ }
+ else { # some class instance
+ return $value;
+ }
+} # end printitem
+
+### to print a list of something
+sub printArray {
+ my (@values) = @_;
+ if (! scalar @values) {
+ print "[]";
+ }
+ else { # the list is not empty
+ my @res;
+ print "[ ";
+ foreach my $value (@values) {
+ &printItem ($value);
+ print " ";
+ }
+ print "]" ;
+ }
+} # end printarray
+
+sub printList {
+ print "( ";
+ foreach (@_) {
+ printItem $_;
+ print " ";
+ }
+ print ")";
+} # end printList
+
+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;
+ }
+} # end messageBox
+
+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(@_) }
+
+# 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'} || ($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 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 in $lastMethod at $filename line $line\n";#, join("\n ",@_)."\n";
+# carp "Tk::Error:CM:: $error\n " . join("\n ",@_)."\n";
+}
+
+1;
+
+__END__
+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');
+ $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;
+ 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');
+}
+
+# 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;
+}
+
+