summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Tk/NoteBook.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Tk/NoteBook.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/NoteBook.pm480
1 files changed, 0 insertions, 480 deletions
diff --git a/Master/tlpkg/tlperl/lib/Tk/NoteBook.pm b/Master/tlpkg/tlperl/lib/Tk/NoteBook.pm
deleted file mode 100644
index a1f2eedb09e..00000000000
--- a/Master/tlpkg/tlperl/lib/Tk/NoteBook.pm
+++ /dev/null
@@ -1,480 +0,0 @@
-package Tk::NoteBook;
-#
-# Implementation of NoteBook widget.
-# Derived from NoteBook.tcl in Tix 4.0
-
-# Contributed by Rajappa Iyer <rsi@earthling.net>
-# Hacked by Nick for 'menu' traversal.
-# Restructured by Nick
-
-use vars qw($VERSION);
-
-#$VERSION = sprintf '4.%03d', q$Revision: #9 $ =~ /\D(\d+)\s*$/;
-$VERSION = '4.011';
-require Tk::NBFrame;
-
-use base qw(Tk::Derived Tk::NBFrame);
-Tk::Widget->Construct('NoteBook');
-use strict;
-
-use Tk qw(Ev);
-
-use Carp;
-require Tk::Frame;
-
-sub TraverseToNoteBook;
-
-sub ClassInit
-{
- my ($class,$mw) = @_;
- # class binding does not work right due to extra level of
- # widget hierachy
- $mw->bind($class,'<ButtonPress-1>', ['MouseDown',Ev('x'),Ev('y')]);
- $mw->bind($class,'<ButtonRelease-1>', ['MouseUp',Ev('x'),Ev('y')]);
-
- $mw->bind($class,'<B1-Motion>', ['MouseDown',Ev('x'),Ev('y')]);
- $mw->bind($class,'<Left>', ['FocusNext','prev']);
- $mw->bind($class,'<Right>', ['FocusNext','next']);
-
- $mw->bind($class,'<Return>', 'SetFocusByKey');
- $mw->bind($class,'<space>', 'SetFocusByKey');
- return $class;
-}
-
-sub raised
-{
- return shift->{'topchild'};
-}
-
-sub Populate
-{
- my ($w, $args) = @_;
-
- $w->SUPER::Populate($args);
- $w->{'pad-x1'} = undef;
- $w->{'pad-x2'} = undef;
- $w->{'pad-y1'} = undef;
- $w->{'pad-y2'} = undef;
-
- $w->{'windows'} = [];
- $w->{'nWindows'} = 0;
- $w->{'minH'} = 1;
- $w->{'minW'} = 1;
-
- $w->{'counter'} = 0;
- $w->{'resize'} = 0;
-
- $w->ConfigSpecs(-ipadx => ['PASSIVE', 'ipadX', 'Pad', 0],
- -ipady => ['PASSIVE', 'ipadY', 'Pad', 0],
- -takefocus => ['SELF', 'takeFocus', 'TakeFocus', 0],
- -dynamicgeometry => ['PASSIVE', 'dynamicGeometry', 'DynamicGeometry', 0]);
-
- # SetBindings
- $w->bind('<Configure>','MasterGeomProc');
-
- $args->{-slave} = 1;
- $args->{-takefocus} = 1;
- $args->{-relief} = 'raised';
-
- $w->QueueResize;
-}
-
-
-#---------------------------
-# Public methods
-#---------------------------
-
-sub page_widget
-{
- my $w = shift;
- $w->{'_pages_'} = {} unless exists $w->{'_pages_'};
- my $h = $w->{'_pages_'};
- if (@_)
- {
- my $name = shift;
- if (@_)
- {
- my $cw = shift;
- if (defined $cw)
- {
- $h->{$name} = $cw;
- }
- else
- {
- return delete $h->{$name};
- }
- }
- return $h->{$name};
- }
- else
- {
- return (values %$h);
- }
-}
-
-sub add
-{
- my ($w, $child, %args) = @_;
-
- croak("$child already exists") if defined $w->page_widget($child);
-
- my $f = Tk::Frame->new($w,Name => $child,-relief => 'raised');
-
- my $ccmd = delete $args{-createcmd};
- my $rcmd = delete $args{-raisecmd};
- $f->{-createcmd} = Tk::Callback->new($ccmd) if (defined $ccmd);
- $f->{-raisecmd} = Tk::Callback->new($rcmd) if (defined $rcmd);
-
- # manage our geometry
- $w->ManageGeometry($f);
- # create default bindings
- $f->bind('<Configure>',[$w,'ClientGeomProc','-configure', $f]);
- $f->bind('<Destroy>', [$w,'delete',$child,1]);
- $w->page_widget($child,$f);
- $w->{'nWindows'}++;
- push(@{$w->{'windows'}}, $child);
- $w->SUPER::add($child,%args);
- return $f;
-}
-
-sub raise
-{
- my ($w, $child) = @_;
- return unless defined $child;
- if ($w->pagecget($child, -state) eq 'normal')
- {
- $w->activate($child);
- $w->focus($child);
- my $childw = $w->page_widget($child);
- if ($childw)
- {
- if (defined $childw->{-createcmd})
- {
- $childw->{-createcmd}->Call($childw);
- delete $childw->{-createcmd};
- }
- # hide the original visible window
- my $oldtop = $w->{'topchild'};
- if (defined($oldtop) && ($oldtop ne $child))
- {
- $w->page_widget($oldtop)->UnmapWindow;
- }
- $w->{'topchild'} = $child;
- my $myW = $w->Width;
- my $myH = $w->Height;
-
- if (!defined $w->{'pad-x1'}) {
- $w->InitTabSize;
- }
-
- my $cW = $myW - $w->{'pad-x1'} - $w->{'pad-x2'} - 2 * (defined $w->{-ipadx} ? $w->{-ipadx} : 0);
- my $cH = $myH - $w->{'pad-y1'} - $w->{'pad-y2'} - 2 * (defined $w->{-ipady} ? $w->{-ipady} : 0);
- my $cX = $w->{'pad-x1'} + (defined $w->{-ipadx} ? $w->{-ipadx} : 0);
- my $cY = $w->{'pad-y1'} + (defined $w->{-ipady} ? $w->{-ipady} : 0);
-
- if ($cW > 0 && $cH > 0)
- {
- $childw->MoveResizeWindow($cX, $cY, $cW, $cH);
- $childw->MapWindow;
- $childw->raise;
- }
- if ((not defined $oldtop) || ($oldtop ne $child))
- {
- if (defined $childw->{-raisecmd})
- {
- $childw->{-raisecmd}->Call($childw);
- }
- }
- }
- }
-}
-
-sub pageconfigure
-{
- my ($w, $child, %args) = @_;
- my $childw = $w->page_widget($child);
- if (defined $childw)
- {
- my $ccmd = delete $args{-createcmd};
- my $rcmd = delete $args{-raisecmd};
- $childw->{-createcmd} = Tk::Callback->new($ccmd) if (defined $ccmd);
- $childw->{-raisecmd} = Tk::Callback->new($rcmd) if (defined $rcmd);
- $w->SUPER::pageconfigure($child, %args) if (keys %args);
- }
-}
-
-sub pages {
- my ($w) = @_;
- return @{$w->{'windows'}};
-}
-
-sub pagecget
-{
- my ($w, $child, $opt) = @_;
- my $childw = $w->page_widget($child);
- if (defined $childw)
- {
- return $childw->{-createcmd} if ($opt =~ /-createcmd/);
- return $childw->{-raisecmd} if ($opt =~ /-raisecmd/);
- return $w->SUPER::pagecget($child, $opt);
- }
- else
- {
- carp "page $child does not exist";
- }
-}
-
-sub delete
-{
- my ($w, $child, $destroy) = @_;
- my $childw = $w->page_widget($child,undef);
- if (defined $childw)
- {
- $childw->bind('<Destroy>', undef);
- $childw->destroy;
- @{$w->{'windows'}} = grep($_ ne $child, @{$w->{'windows'}});
- $w->{'nWindows'}--;
- $w->SUPER::delete($child);
- # see if the child to be deleted was the top child
- if ((defined $w->{'topchild'}) && ($w->{'topchild'} eq $child))
- {
- delete $w->{'topchild'};
- if ( @{$w->{'windows'}})
- {
- $w->raise($w->{'windows'}[0]);
- }
- }
- }
- else
- {
- carp "page $child does not exist" unless $destroy;
- }
-}
-
-#---------------------------------------
-# Private methods
-#---------------------------------------
-
-sub MouseDown {
- my ($w, $x, $y) = @_;
- my $name = $w->identify($x, $y);
- $w->focus($name);
- $w->{'down'} = $name;
-}
-
-sub MouseUp {
- my ($w, $x, $y) = @_;
- my $name = $w->identify($x, $y);
- if ((defined $name) && (defined $w->{'down'}) &&
- ($name eq $w->{'down'}) &&
- ($w->pagecget($name, -state) eq 'normal')) {
- $w->raise($name);
- } else {
- $w->focus($name);
- }
-}
-
-sub FocusNext {
- my ($w, $dir) = @_;
- my $name;
-
- if (not defined $w->info('focus')) {
- $name = $w->info('active');
- $w->focus($name);
- } else {
- $name = $w->info('focus' . $dir);
- $w->focus($name);
- }
-}
-
-sub SetFocusByKey {
- my ($w) = @_;
-
- my $name = $w->info('focus');
- if (defined $name) {
- if ($w->pagecget($name, -state) eq 'normal') {
- $w->raise($name);
- $w->activate($name);
- }
- }
-}
-
-sub NoteBookFind {
- my ($w, $char) = @_;
-
- my $page;
- foreach $page (@{$w->{'windows'}}) {
- my $i = $w->pagecget($page, -underline);
- my $c = substr($page, $i, 1);
- if ($char =~ /$c/) {
- if ($w->pagecget($page, -state) ne 'disabled') {
- return $page;
- }
- }
- }
- return undef;
-}
-
-# This is called by TraveseToMenu when an <Alt-Keypress> occurs
-# See the code in Tk.pm
-sub FindMenu {
- my ($w, $char) = @_;
-
- my $page;
- foreach $page (@{$w->{'windows'}}) {
- my $i = $w->pagecget($page, -underline);
- my $l = $w->pagecget($page, -label);
- next if (not defined $l);
- my $c = substr($l, $i, 1);
- if ($char =~ /$c/i) {
- if ($w->pagecget($page, -state) ne 'disabled') {
- $w->raise($page);
- return $w;
- }
- }
- }
- return undef;
-}
-
-
-sub MasterGeomProc
-{
- my ($w) = @_;
- if (Tk::Exists($w))
- {
- $w->{'resize'} = 0 unless (defined $w->{'resize'});
- $w->QueueResize;
- }
-}
-
-sub SlaveGeometryRequest
-{
- my $w = shift;
- if (Tk::Exists($w))
- {
- $w->QueueResize;
- }
-}
-
-sub LostSlave {
- my ($w, $s) = @_;
- $s->UnmapWindow;
-}
-
-sub ClientGeomProc
-{
- my ($w, $flag, $client) = @_;
- $w->QueueResize if (Tk::Exists($w));
- if ($flag =~ /-lostslave/)
- {
- carp "Geometry Management Error: Another geometry manager has taken control of $client. This error is usually caused because a widget has been created in the wrong frame: it should have been created inside $client instead of $w";
- }
-}
-
-sub QueueResize
-{
- my $w = shift;
- $w->afterIdle(['Resize', $w]) unless ($w->{'resize'}++);
-}
-
-sub Resize {
-
- my ($w) = @_;
-
- return unless Tk::Exists($w) && $w->{'nWindows'} && $w->{'resize'};
-
- $w->InitTabSize;
-
- $w->{'resize'} = 0;
- my $reqW = $w->{-width} || 0;
- my $reqH = $w->{-height} || 0;
-
- if ($reqW * $reqH == 0)
- {
- if ((not defined $w->cget('-dynamicgeometry')) ||
- ($w->cget('-dynamicgeometry') == 0)) {
- $reqW = 1;
- $reqH = 1;
-
- my $childw;
- foreach $childw ($w->page_widget)
- {
- my $cW = $childw->ReqWidth;
- my $cH = $childw->ReqHeight;
- $reqW = $cW if ($reqW < $cW);
- $reqH = $cH if ($reqH < $cH);
- }
- } else {
- if (defined $w->{'topchild'}) {
- my $topw = $w->page_widget($w->{'topchild'});
- $reqW = $topw->ReqWidth;
- $reqH = $topw->ReqHeight;
- } else {
- $reqW = 1;
- $reqH = 1;
- }
- }
- $reqW += $w->{'pad-x1'} + $w->{'pad-x2'} + 2 * (defined $w->{-ipadx} ? $w->{-ipadx} : 0);
- $reqH += $w->{'pad-y1'} + $w->{'pad-y2'} + 2 * (defined $w->{-ipady} ? $w->{-ipady} : 0);
- $reqW = ($reqW > $w->{'minW'}) ? $reqW : $w->{'minW'};
- $reqH = ($reqH > $w->{'minH'}) ? $reqH : $w->{'minH'};
- }
- if (($w->ReqWidth != $reqW) ||
- ($w->ReqHeight != $reqH)) {
- $w->{'counter'} = 0 if (not defined $w->{'counter'});
- if ($w->{'counter'} < 50) {
- $w->{'counter'}++;
- $w->GeometryRequest($reqW, $reqH);
- $w->afterIdle([$w,'Resize']);
- $w->{'resize'} = 1;
- return;
- }
- }
- $w->{'counter'} = 0;
- $w->raise($w->{'topchild'} || ${$w->{'windows'}}[0]);
- $w->{'resize'} = 0;
-}
-
-sub InitTabSize {
- my ($w) = @_;
- my ($tW, $tH) = $w->geometryinfo;
- $w->{'pad-x1'} = 2;
- $w->{'pad-x2'} = 2;
- $w->{'pad-y1'} = $tH + (defined $w->{'-ipadx'} ? $w->{'-ipadx'} : 0) + 1;
- $w->{'pad-y2'} = 2;
- $w->{'minW'} = $tW;
- $w->{'minH'} = $tH;
-}
-
-sub BalloonInfo
-{
- my ($notebook,$balloon,$X,$Y,@opt) = @_;
- my $page = $notebook->identify($X-$notebook->rootx,$Y-$notebook->rooty);
- foreach my $opt (@opt)
- {
- my $info = $balloon->GetOption($opt,$notebook);
- if ($opt =~ /^-(statusmsg|balloonmsg)$/ && UNIVERSAL::isa($info,'HASH'))
- {
- if (!defined $page)
- {
- $balloon->Deactivate;
- return;
- }
- $balloon->Subclient($page);
- if (exists $info->{$page})
- {
- return $info->{$page}
- }
- else
- {
- return '';
- }
- }
- return $info;
- }
-}
-
-1;
-
-__END__
-
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-22 16:37:15 +0000