summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Tk/HList.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Tk/HList.pm')
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Tk/HList.pm685
1 files changed, 685 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/Tk/HList.pm b/Master/tlpkg/tlperl/lib/Tk/HList.pm
new file mode 100755
index 00000000000..d259ca9ce24
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/HList.pm
@@ -0,0 +1,685 @@
+package Tk::HList;
+
+use vars qw($VERSION);
+$VERSION = '4.015'; # was: sprintf '4.%03d', q$Revision: #14 $ =~ /\D(\d+)\s*$/;
+
+use Tk qw(Ev $XS_VERSION);
+
+use base qw(Tk::Widget);
+
+Construct Tk::Widget 'HList';
+sub Tk::Widget::ScrlHList { shift->Scrolled('HList'=>@_) }
+
+bootstrap Tk::HList;
+
+sub Tk_cmd { \&Tk::hlist }
+
+sub CreateArgs
+{
+ my ($package,$parent,$args) = @_;
+ my @result = $package->SUPER::CreateArgs($parent,$args);
+ my $columns = delete $args->{-columns};
+ push(@result, '-columns' => $columns) if (defined $columns);
+ return @result;
+}
+
+Tk::Methods qw(add addchild anchor column
+ delete dragsite dropsite entrycget
+ entryconfigure geometryinfo indicator header hide item info
+ nearest see select selection show xview yview);
+
+use Tk::Submethods ( 'delete' => [qw(all entry offsprings siblings)],
+ 'header' => [qw(configure cget create delete exists size)],
+ 'indicator' => [qw(configure cget create delete exists size)],
+ 'info' => [qw(anchor bbox children data dragsite
+ dropsite exists hidden item next parent prev
+ selection)],
+ 'item' => [qw(configure cget create delete exists)],
+ 'selection' => [qw(clear get includes set)],
+ 'anchor' => [qw(clear set)],
+ 'column' => [qw(width)],
+ );
+
+# This is undocumented, but worked until 804.027:
+sub hideEntry { shift->hide('entry', @_) }
+
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+
+ $mw->bind($class,'<ButtonPress-1>',[ 'Button1' ] );
+ $mw->bind($class,'<Shift-ButtonPress-1>',[ 'ShiftButton1' ] );
+ $mw->bind($class,'<Control-ButtonRelease-1>','Control_ButtonRelease_1');
+ $mw->bind($class,'<ButtonRelease-1>','ButtonRelease_1');
+ $mw->bind($class,'<Double-ButtonRelease-1>','NoOp');
+ $mw->bind($class,'<B1-Motion>',[ 'Button1Motion' ] );
+ $mw->bind($class,'<B1-Leave>',[ 'AutoScan' ] );
+
+ $mw->bind($class,'<Double-ButtonPress-1>',['Double1']);
+
+ $mw->bind($class,'<Control-B1-Motion>','Control_B1_Motion');
+ $mw->bind($class,'<Control-ButtonPress-1>',['CtrlButton1']);
+ $mw->bind($class,'<Control-Double-ButtonPress-1>',['CtrlButton1']);
+
+ $mw->bind($class,'<B1-Enter>','B1_Enter');
+
+ $mw->bind($class,'<Up>',['UpDown', 'prev']);
+ $mw->bind($class,'<Down>',['UpDown', 'next']);
+
+ $mw->bind($class,'<Shift-Up>',['ShiftUpDown', 'prev']);
+ $mw->bind($class,'<Shift-Down>',['ShiftUpDown', 'next']);
+
+ $mw->bind($class,'<Left>', ['LeftRight', 'left']);
+ $mw->bind($class,'<Right>',['LeftRight', 'right']);
+
+ $mw->PriorNextBind($class);
+ $mw->MouseWheelBind($class);
+
+ $mw->bind($class,'<Return>', ['KeyboardActivate']);
+ $mw->bind($class,'<space>', ['KeyboardBrowse']);
+ $mw->bind($class,'<Home>', ['KeyboardHome']);
+ $mw->bind($class,'<End>', ['KeyboardEnd']);
+
+ $mw->YMouseWheelBind($class);
+ $mw->XMouseWheelBind($class);
+
+ return $class;
+}
+
+sub Control_ButtonRelease_1
+{
+}
+
+sub ButtonRelease_1
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $w->CancelRepeat
+ if($w->cget('-selectmode') ne 'dragdrop');
+ $w->ButtonRelease1($Ev);
+}
+
+sub Control_B1_Motion
+{
+}
+
+sub B1_Enter
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $w->CancelRepeat
+ if($w->cget('-selectmode') ne 'dragdrop');
+}
+
+sub Button1
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+
+ delete $w->{'shiftanchor'};
+ delete $w->{tixindicator};
+
+ $w->focus() if($w->cget('-takefocus'));
+
+ my $mode = $w->cget('-selectmode');
+
+ if ($mode eq 'dragdrop')
+ {
+ # $w->Send_WaitDrag($Ev->y);
+ return;
+ }
+
+ my $ent = $w->GetNearest($Ev->y, 1);
+
+ if (!defined($ent) || !length($ent))
+ {
+ $w->selectionClear;
+ $w->anchorClear;
+ return;
+ }
+
+ my @info = $w->info('item',$Ev->x, $Ev->y);
+ if (@info)
+ {
+ die 'Assert' unless $info[0] eq $ent;
+ }
+ else
+ {
+ @info = $ent;
+ }
+
+ if (defined($info[1]) && $info[1] eq 'indicator')
+ {
+ $w->{tixindicator} = $ent;
+ $w->Callback(-indicatorcmd => $ent, '<Arm>');
+ }
+ else
+ {
+ my $browse = 0;
+
+ if ($mode eq 'single')
+ {
+ $w->anchorSet($ent);
+ }
+ elsif ($mode eq 'browse')
+ {
+ $w->anchorSet($ent);
+ $w->selectionClear;
+ $w->selectionSet($ent);
+ $browse = 1;
+ }
+ elsif ($mode eq 'multiple')
+ {
+ $w->selectionClear;
+ $w->anchorSet($ent);
+ $w->selectionSet($ent);
+ $browse = 1;
+ }
+ elsif ($mode eq 'extended')
+ {
+ $w->anchorSet($ent);
+ $w->selectionClear;
+ $w->selectionSet($ent);
+ $browse = 1;
+ }
+
+ if ($browse)
+ {
+ $w->Callback(-browsecmd => @info);
+ }
+ }
+}
+
+sub ShiftButton1
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+
+ my $to = $w->GetNearest($Ev->y, 1);
+
+ delete $w->{'shiftanchor'};
+ delete $w->{tixindicator};
+
+ return unless (defined($to) and length($to));
+
+ my $mode = $w->cget('-selectmode');
+
+ if($mode eq 'extended' or $mode eq 'multiple')
+ {
+ my $from = $w->info('anchor');
+ if(defined $from)
+ {
+ $w->selectionClear;
+ $w->selectionSet($from, $to);
+ }
+ else
+ {
+ $w->anchorSet($to);
+ $w->selectionClear;
+ $w->selectionSet($to);
+ }
+ }
+}
+
+sub GetNearest
+{
+ my ($w,$y,$undefafterend) = @_;
+ my $ent = $w->nearest($y);
+ if (defined $ent)
+ {
+ if ($undefafterend)
+ {
+ my $borderwidth = $w->cget('-borderwidth');
+ my $highlightthickness = $w->cget('-highlightthickness');
+ my $bottomy = ($w->infoBbox($ent))[3];
+ $bottomy += $borderwidth + $highlightthickness;
+ if ($w->header('exist', 0))
+ {
+ $bottomy += $w->header('height');
+ }
+ if ($y > $bottomy)
+ {
+ #print "$y > $bottomy\n";
+ return undef;
+ }
+ }
+ my $state = $w->entrycget($ent, '-state');
+ return $ent if (!defined($state) || $state ne 'disabled');
+ }
+ return undef;
+}
+
+sub ButtonRelease1
+{
+ my ($w, $Ev) = @_;
+
+ delete $w->{'shiftanchor'};
+
+ my $mode = $w->cget('-selectmode');
+
+ if($mode eq 'dragdrop')
+ {
+# $w->Send_DoneDrag();
+ return;
+ }
+
+ my ($x, $y) = ($Ev->x, $Ev->y);
+ my $ent = $w->GetNearest($y, 1);
+
+ if (!defined($ent) and $mode eq 'single')
+ {
+ my $ent = $w->info('selection');
+ if (defined $ent)
+ {
+ $w->anchorSet($ent);
+ }
+ }
+ return unless (defined($ent) and length($ent));
+
+ if (exists $w->{tixindicator})
+ {
+ return unless delete($w->{tixindicator}) eq $ent;
+ my @info = $w->info('item',$Ev->x, $Ev->y);
+ if(defined($info[1]) && $info[1] eq 'indicator')
+ {
+ $w->Callback(-indicatorcmd => $ent, '<Activate>');
+ }
+ else
+ {
+ $w->Callback(-indicatorcmd => $ent, '<Disarm>');
+ }
+ return;
+ }
+
+ if($mode eq 'single' || $mode eq 'browse')
+ {
+ $w->anchorSet($ent);
+ $w->selectionClear;
+ $w->selectionSet($ent);
+
+ }
+ elsif($mode eq 'multiple')
+ {
+ $w->selectionSet($ent);
+ }
+ elsif($mode eq 'extended')
+ {
+ $w->selectionSet($ent);
+ }
+
+ $w->Callback(-browsecmd =>$ent);
+}
+
+sub Button1Motion
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ return unless defined $Ev;
+
+ delete $w->{'shiftanchor'};
+
+ my $mode = $w->cget('-selectmode');
+
+ if ($mode eq 'dragdrop')
+ {
+# $w->Send_StartDrag();
+ return;
+ }
+
+ my $ent;
+ if (defined $w->info('anchor'))
+ {
+ $ent = $w->GetNearest($Ev->y);
+ }
+ else
+ {
+ $ent = $w->GetNearest($Ev->y, 1);
+ }
+ return unless (defined($ent) and length($ent));
+
+ if(exists $w->{tixindicator})
+ {
+ my $event_type = $w->{tixindicator} eq $ent ? '<Arm>' : '<Disarm>';
+ $w->Callback(-indicatorcmd => $w->{tixindicator}, $event_type );
+ return;
+ }
+
+ if ($mode eq 'single')
+ {
+ $w->anchorSet($ent);
+ }
+ elsif ($mode eq 'multiple' || $mode eq 'extended')
+ {
+ my $from = $w->info('anchor');
+ if(defined $from)
+ {
+ $w->selectionClear;
+ $w->selectionSet($from, $ent);
+ }
+ else
+ {
+ $w->anchorSet($ent);
+ $w->selectionClear;
+ $w->selectionSet($ent);
+ }
+ }
+
+ if ($mode ne 'single')
+ {
+ $w->Callback(-browsecmd =>$ent);
+ }
+}
+
+sub Double1
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+
+ delete $w->{'shiftanchor'};
+
+ my $ent = $w->GetNearest($Ev->y, 1);
+
+ return unless (defined($ent) and length($ent));
+
+ $w->anchorSet($ent)
+ unless(defined $w->info('anchor'));
+
+ $w->selectionSet($ent);
+
+ $w->Callback(-command => $ent);
+}
+
+sub CtrlButton1
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+
+ delete $w->{'shiftanchor'};
+
+ my $ent = $w->GetNearest($Ev->y, 1);
+
+ return unless (defined($ent) and length($ent));
+
+ my $mode = $w->cget('-selectmode');
+
+ if($mode eq 'extended')
+ {
+ $w->anchorSet($ent) unless( defined $w->info('anchor') );
+
+ if($w->select('includes', $ent))
+ {
+ $w->select('clear', $ent);
+ }
+ else
+ {
+ $w->selectionSet($ent);
+ }
+ $w->Callback(-browsecmd =>$ent);
+ }
+}
+
+sub UpDown
+{
+ my $w = shift;
+ my $spec = shift;
+
+ my $done = 0;
+ my $anchor = $w->info('anchor');
+
+ delete $w->{'shiftanchor'};
+
+ unless( defined $anchor )
+ {
+ $anchor = ($w->info('children'))[0];
+
+ return unless (defined($anchor) and length($anchor));
+
+ if($w->entrycget($anchor, '-state') ne 'disabled')
+ {
+ # That's a good anchor
+ $done = 1;
+ }
+ else
+ {
+ # We search for the first non-disabled entry (downward)
+ $spec = 'next';
+ }
+ }
+
+ my $ent = $anchor;
+
+ # Find the prev/next non-disabled entry
+ #
+ while(!$done)
+ {
+ $ent = $w->info($spec, $ent);
+ last unless( defined $ent );
+ next if( $w->entrycget($ent, '-state') eq 'disabled' );
+ next if( $w->info('hidden', $ent) );
+ last;
+ }
+
+ unless( defined $ent )
+ {
+ $w->yview('scroll', $spec eq 'prev' ? -1 : 1, 'unit');
+ return;
+ }
+
+ $w->anchorSet($ent);
+ $w->see($ent);
+
+ if($w->cget('-selectmode') ne 'single')
+ {
+ $w->selectionClear;
+ $w->selection('set', $ent);
+ $w->Callback(-browsecmd =>$ent);
+ }
+}
+
+sub ShiftUpDown
+{
+ my $w = shift;
+ my $spec = shift;
+
+ my $mode = $w->cget('-selectmode');
+
+ return $w->UpDown($spec)
+ if($mode eq 'single' || $mode eq 'browse');
+
+ my $anchor = $w->info('anchor');
+
+ return $w->UpDown($spec) unless (defined($anchor) and length($anchor));
+
+ my $done = 0;
+
+ $w->{'shiftanchor'} = $anchor unless( $w->{'shiftanchor'} );
+
+ my $ent = $w->{'shiftanchor'};
+
+ while( !$done )
+ {
+ $ent = $w->info($spec, $ent);
+ last unless( defined $ent );
+ next if( $w->entrycget($ent, '-state') eq 'disabled' );
+ next if( $w->info('hidden', $ent) );
+ last;
+ }
+
+ unless( $ent )
+ {
+ $w->yview('scroll', $spec eq 'prev' ? -1 : 1, 'unit');
+ return;
+ }
+
+ $w->selectionClear;
+ $w->selection('set', $anchor, $ent);
+ $w->see($ent);
+
+ $w->{'shiftanchor'} = $ent;
+
+ $w->Callback(-browsecmd =>$ent);
+}
+
+sub LeftRight
+{
+ my $w = shift;
+ my $spec = shift;
+
+ delete $w->{'shiftanchor'};
+
+ my $anchor = $w->info('anchor');
+
+ unless(defined $anchor)
+ {
+ $anchor = ($w->info('children'))[0]
+ }
+ unless(defined $anchor)
+ {
+ $anchor = '';
+ }
+
+ my $done = 0;
+ my $ent = $anchor;
+
+ while(!$done)
+ {
+ my $e = $ent;
+
+ if($spec eq 'left')
+ {
+ $ent = $w->info('parent', $e);
+
+ $ent = $w->info('prev', $e)
+ unless(defined $ent && $w->entrycget($ent, '-state') ne 'disabled')
+ }
+ else
+ {
+ $ent = ($w->info('children', $e))[0];
+
+ $ent = $w->info('next', $e)
+ unless(defined $ent && $w->entrycget($ent, '-state') ne 'disabled')
+ }
+
+ last unless( defined $ent );
+ last if($w->entrycget($ent, '-state') ne 'disabled');
+ }
+
+ unless( defined $ent )
+ {
+ $w->xview('scroll', $spec eq 'left' ? -1 : 1, 'unit');
+ return;
+ }
+
+ $w->anchorSet($ent);
+ $w->see($ent);
+
+ if($w->cget('-selectmode') ne 'single')
+ {
+ $w->selectionClear;
+ $w->selectionSet($ent);
+
+ $w->Callback(-browsecmd =>$ent);
+ }
+}
+
+sub KeyboardHome
+{
+ my $w = shift;
+ $w->yview('moveto' => 0);
+ $w->xview('moveto' => 0);
+}
+
+sub KeyboardEnd
+{
+ my $w = shift;
+ $w->yview('moveto' => 1);
+ $w->xview('moveto' => 0);
+}
+
+sub KeyboardActivate
+{
+ my $w = shift;
+
+ my $anchor = $w->info('anchor');
+
+ return unless (defined($anchor) and length($anchor));
+
+ if($w->cget('-selectmode'))
+ {
+ $w->selectionClear;
+ $w->selectionSet($anchor);
+ }
+
+ $w->Callback(-command => $anchor);
+}
+
+sub KeyboardBrowse
+{
+ my $w = shift;
+
+ my $anchor = $w->info('anchor');
+
+ return unless (defined($anchor) and length($anchor));
+
+ if ($w->indicatorExists($anchor))
+ {
+ $w->Callback(-indicatorcmd => $anchor);
+ }
+
+ if($w->cget('-selectmode'))
+ {
+ $w->selectionClear;
+ $w->selectionSet($anchor);
+ }
+ $w->Callback(-browsecmd =>$anchor);
+}
+
+sub AutoScan
+{
+ my ($w,$x,$y) = @_;
+
+ return if ($w->cget('-selectmode') eq 'dragdrop');
+ if (@_ < 3)
+ {
+ my $Ev = $w->XEvent;
+ return unless defined $Ev;
+ $y = $Ev->y;
+ $x = $Ev->x;
+ }
+
+ if($y >= $w->height)
+ {
+ $w->yview('scroll', 1, 'units');
+ }
+ elsif($y < 0)
+ {
+ $w->yview('scroll', -1, 'units');
+ }
+ elsif($x >= $w->width)
+ {
+ $w->xview('scroll', 2, 'units');
+ }
+ elsif($x < 0)
+ {
+ $w->xview('scroll', -2, 'units');
+ }
+ else
+ {
+ return;
+ }
+ $w->RepeatId($w->SUPER::after(50,[ AutoScan => $w, $x, $y ]));
+ $w->Button1Motion;
+}
+
+sub children
+{
+ # Tix has core-tk window(s) which are not a widget(s)
+ # the generic code returns these as an "undef"
+ my $w = shift;
+ my @info = grep(defined($_),$w->winfo('children'));
+ @info;
+}
+
+1;
+
+