diff options
Diffstat (limited to 'Perl/trace')
| -rw-r--r-- | Perl/trace/Makefile.PL | 7 | ||||
| -rw-r--r-- | Perl/trace/Tk.pm | 784 |
2 files changed, 0 insertions, 791 deletions
diff --git a/Perl/trace/Makefile.PL b/Perl/trace/Makefile.PL deleted file mode 100644 index a1df3e4..0000000 --- a/Perl/trace/Makefile.PL +++ /dev/null @@ -1,7 +0,0 @@ -use Tk::MMutil; - -Tk::MMutil::TkExtMakefile( - 'NAME' => 'ZincTrace::Tk', - ); - - diff --git a/Perl/trace/Tk.pm b/Perl/trace/Tk.pm deleted file mode 100644 index dba2274..0000000 --- a/Perl/trace/Tk.pm +++ /dev/null @@ -1,784 +0,0 @@ -# -# 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; -} - - |