*** empty log message ***

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