diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Tk')
152 files changed, 36759 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/Tk/Adjuster.pm b/Master/tlpkg/tlperl/lib/Tk/Adjuster.pm new file mode 100644 index 00000000000..382ec6db6f9 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Adjuster.pm @@ -0,0 +1,436 @@ +package Tk::Adjuster; + +use vars qw($VERSION); +$VERSION = '4.007'; # $Id: //depot/Tkutf8/Tk/Adjuster.pm#7 $ + +use base qw(Tk::Frame); + +# We cannot do this : + +# Construct Tk::Widget 'packAdjust'; + +# because if managed object is Derived (e.g. a Scrolled) then our 'new' +# will be delegated and hierachy gets turned inside-out +# So packAdjust is autoloaded in Widget.pm + + +Construct Tk::Widget qw(Adjuster); + +{package Tk::Adjuster::Item; + +use strict; +use base qw(Tk::Frame); + +sub ClassInit +{ + my ($class,$mw) = @_; + $mw->bind($class,'<1>',['BDown', 1]); + $mw->bind($class,'<Shift-1>',['BDown', 0]); + $mw->bind($class,'<B1-Motion>',['Motion',1]); + $mw->bind($class,'<Shift-B1-Motion>',['Motion',0]); + $mw->bind($class,'<ButtonRelease-1>',['Motion',0]); + return $class; +} + +sub BDown +{ + my($w, $delay_mask) = @_; + $w->{'start_x'} = $w->XEvent->x; + $w->{'start_y'} = $w->XEvent->y; + my $adj = $w->Parent; + delete $adj->{'lin_info'}; + my $delay = $delay_mask && $adj->cget('-delay'); + if ($delay) + { + $adj->vert ? $adj->delta_width_bar(0) : $adj->delta_height_bar(0); + } +} + +sub Motion +{ + my($w, $delay_mask) = @_; + my $ev = $w->XEvent; + my $adj = $w->Parent; + + my $delay = $delay_mask && $adj->cget('-delay'); + if ($adj->vert) + { + my $dx = $ev->x - $w->{'start_x'}; + $delay ? $adj->delta_width_bar($dx) : $adj->delta_width($dx); + } + else + { + my $dy = $ev->y - $w->{'start_y'}; + $delay ? $adj->delta_height_bar($dy) : $adj->delta_height($dy); + } +} + +} + + + +sub packAfter +{ + my ($w,$s,%args) = @_; + my $side = $args{'-side'} ? $args{'-side'} : 'top'; + $w->configure(-side => $side, -widget => $s); + $w->packed($s, %args); +} + +sub packForget +{ + my ($w,$forget_slave) = @_; + $w->Tk::Widget::packForget; + $w->slave->packForget if $forget_slave; +} + +# Called by Tk::Widget::packAdjust. It was here before packAfter was added +sub packed +{ + my ($w,$s,%args) = @_; + delete $args{'-before'}; + delete $args{'-in'}; + $args{'-expand'} = 0; + $args{'-after'} = $s; + $args{'-fill'} = (($w->vert) ? 'y' : 'x'); + $w->pack(%args); +} + +sub gridded +{ + my ($w,$s,%args) = @_; + # delete $args{'-before'}; + # $args{'-expand'} = 0; + # $args{'-after'} = $s; + # $args{'-fill'} = (($w->vert) ? 'y' : 'x'); + $w->grid(%args); +} + +sub ClassInit +{ + my ($class,$mw) = @_; + $mw->bind($class,'<Configure>','SizeChange'); + $mw->bind($class,'<Unmap>','Restore'); + $mw->bind($class,'<Map>','Mapped'); + return $class; +} + +sub SizeChange +{ + my $w = shift; + # reqwidth/height of Adjuster is stored here. If it is partially pushed out + # of the window, then $w->width/height returns that of the visible part. + if ($w->vert) + { + my $sx = ($w->Width - $w->{'sep'}->Width)/2; + $w->{'but'}->place('-x' => 0, '-y' => $w->Height-18); + $w->{'sep'}->place('-x' => $sx, '-y' => 0, -relheight => 1); + $w->configure(-width => $w->{'but'}->ReqWidth); + $w->{'reqwidth'} = $w->reqwidth; + } + else + { + my $sy = ($w->Height - $w->{'sep'}->Height)/2; + $w->{'but'}->place('-x' => $w->Width-18, '-y' => 0); + $w->{'sep'}->place('-x' => 0, '-y' => $sy, -relwidth => 1); + $w->configure(-height => $w->{'but'}->ReqHeight); + $w->{'reqheight'} = $w->reqheight; + } + # Turn off geometry propagation in the slave. Do only if necessary, as this + # causes repacking. + my $s = $w->slave; + $s->packPropagate('0') if $s->packSlaves && $s->packPropagate(); + $s->gridPropagate('0') if $s->gridSlaves && $s->gridPropagate(); +} + +sub Mapped +{ + my $w = shift; + $w->idletasks; + my $m = $w->manager; + if ($m =~ /^(?:pack|grid)$/) + { + my %info = $w->$m('info'); + my $master = $info{'-in'}; + $master->$m('propagate',0); + $w->{'master'} = $master; + } + $w->slave_expand_off; +} + +sub Populate +{ + my ($w,$args) = @_; + $w->SUPER::Populate($args); + $w->{'sep'} = Tk::Adjuster::Item->new($w,-bd => 1, -relief => 'sunken'); + $w->{'but'} = Tk::Adjuster::Item->new($w,-bd => 1, -width => 8, -height => 8, -relief => 'raised'); + + # Need to explicitly set frame width to 0 for Win32 + my $l = $w->{'lin'} = $w->toplevel->Frame(-bd => 0); + + my $cs = $w->ConfigSpecs(-widget => ['PASSIVE','widget','Widget',$w->Parent], + -side => ['METHOD','side','Side','top'], + -delay => ['PASSIVE','delay','Delay', 1], + -background => [['SELF',$w->{'sep'},$w->{'but'}],'background','Background',undef], + -foreground => [Tk::Configure->new($w->{'lin'},'-background'),'foreground','Foreground','black'], + -restore => ['PASSIVE','restore', 'Restore', 1], + ); + $w->_OnDestroy(qw(sep but lin master)); +} + +sub side +{ + my ($w,$val) = @_; + if (@_ > 1) + { + $w->{'side'} = $val; + my $cursor; + if ($w->vert) + { + $cursor = 'sb_h_double_arrow'; + $w->{'sep'}->configure(-width => 2, -height => 10000); + } + else + { + $cursor = 'sb_v_double_arrow'; + $w->{'sep'}->configure(-height => 2, -width => 10000); + } + my $x; + foreach $x ($w->{'sep'},$w->{'but'}) + { + $x->configure(-cursor => $cursor); + } + } + return $w->{'side'}; +} + +sub slave +{ + my $w = shift; + my $s = $w->cget('-widget'); + return $s; +} + +sub vert +{ + my $w = shift; + my $side = $w->cget('-side'); + return 1 if $side eq 'left'; + return -1 if $side eq 'right'; + return 0; +} + +# If the Adjuster gets unmapped, it attempts to restore itself. If its +# slave is mapped, then it reduces the size of the slave so that there is +# then room in the master for the Adjuster widget. +sub Restore +{ + my $w = shift; + return if ! $w->toplevel->IsMapped || + ! $w->slave->IsMapped || + ! $w->cget('-restore'); + $w->vert ? $w->delta_width(0) : $w->delta_height(0); +} + +sub delta_width_bar +{ + my ($w,$dx) = @_; + my $l = $w->{'lin'}; + my $r = $w->{'sep'}; + my $t = $w->toplevel; + my $m = $w->{'master'}; + my $s = $w->slave; + my ($min_rootx, $max_rootx, $t_border); + if (! $w->{'lin_info'}) + { + my $m_border = $m->cget('-bd') + $m->cget('-highlightthickness'); + $t_border = $t->cget('-bd') + $t->cget('-highlightthickness'); + if ($w->cget('-side') eq 'right') + { + $min_rootx = $m->rootx + $m_border; + $max_rootx = $s->rootx + $s->width - 1; + } + else + { + $min_rootx = $s->rootx; + $max_rootx = $m->rootx + $m->width - $m_border - 1; + } + $w->{'lin_info'} = [$min_rootx, $max_rootx, $t_border]; + } + else + { + ($min_rootx, $max_rootx, $t_border) = @{$w->{'lin_info'}}; + } + $l->configure(-width => 1, -height => $w->height) unless $l->IsMapped; + + my $new_rootx = $w->rootx + $w->{'reqwidth'}/2 + $dx; + $new_rootx = $min_rootx if $new_rootx < $min_rootx; + $new_rootx = $max_rootx if $new_rootx > $max_rootx; + my $placex = $new_rootx - $t->rootx - $t_border; + my $placey = $w->rooty - $t->rooty - $t_border; + $l->place(-in => $t, -anchor => 'n', '-x' => $placex, '-y' => $placey); + my $this = $w->containing($new_rootx, $w->rooty + 1); + $l->raise($this) if $this && $this ne $t; +} + +sub delta_width +{ + my ($w,$dx) = @_; + my $l = $w->{'lin'}; + $l->placeForget; + my $s = $w->slave; + if ($s) + { + my $m = $w->{'master'}; + my $m_border = $m->cget('-bd') + $m->cget('-highlightthickness'); + my $w_width = $w->{'reqwidth'}; + my $m_width = $m->width; + my $s_width = $s->width; + my $max_width = $m_width - $w_width; + my $max_s_width; + if ($w->cget('-side') eq 'right') + { + $dx = -$dx; + $max_s_width = $max_width - + ($m->rootx + $m_width - ($s->rootx+$s_width)) - $m_border; + } + else + { + $max_s_width = $max_width - ($s->rootx - $m->rootx) - $m_border; + } + my $new_width = $s_width+$dx; + $new_width = $max_s_width if $new_width > $max_s_width; + $new_width = 0 if $new_width < 0; + $s->GeometryRequest($new_width, $s->height); + } +} + +sub delta_height_bar +{ + my ($w,$dy) = @_; + my $l = $w->{'lin'}; + my $r = $w->{'sep'}; + my $t = $w->toplevel; + my $m = $w->{'master'}; + my $s = $w->slave; + my ($min_rooty, $max_rooty, $t_border); + if (! $w->{'lin_info'}) + { + my $m_border = $m->cget('-bd') + $m->cget('-highlightthickness'); + $t_border = $t->cget('-bd') + $t->cget('-highlightthickness'); + if ($w->cget('-side') eq 'bottom') + { + $min_rooty = $m->rooty + $m_border; + $max_rooty = $s->rooty + $s->height - 1; + } + else + { + $min_rooty = $s->rooty; + $max_rooty = $m->rooty + $m->height - $m_border - 1; + } + $w->{'lin_info'} = [$min_rooty, $max_rooty, $t_border]; + } + else + { + ($min_rooty, $max_rooty, $t_border) = @{$w->{'lin_info'}}; + } + $l->configure(-height => 1, -width => $w->width) unless $l->IsMapped; + + my $new_rooty = $w->rooty + $w->{'reqheight'}/2 + $dy; + $new_rooty = $min_rooty if $new_rooty < $min_rooty; + $new_rooty = $max_rooty if $new_rooty > $max_rooty; + my $placey = $new_rooty - $t->rooty - $t_border; + my $placex = $w->rootx - $t->rootx - $t_border; + $l->place(-in => $t, -anchor => 'w', '-x' => $placex, '-y' => $placey); + my $this = $w->containing($w->rootx + 1, $new_rooty); + $l->raise($this) if $this && $this ne $t; +} + +sub delta_height +{ + my ($w,$dy) = @_; + my $l = $w->{'lin'}; + $l->placeForget; + my $s = $w->slave; + if ($s) + { + my $m = $w->{'master'}; + my $m_border = $m->cget('-bd') + $m->cget('-highlightthickness'); + my $w_height = $w->{'reqheight'}; + my $m_height = $m->height; + my $s_height = $s->height; + my $max_height = $m_height - $w_height; + my $max_s_height; + if ($w->cget('-side') eq 'bottom') + { + $dy = -$dy; + $max_s_height = $max_height - + ($m->rooty + $m_height - ($s->rooty+$s_height)) - $m_border; + } + else + { + $max_s_height = $max_height - ($s->rooty - $m->rooty) - $m_border; + } + my $new_height = $s_height+$dy; + + $new_height = $max_s_height if $new_height > $max_s_height; + $new_height = 0 if $new_height < 0; + $s->GeometryRequest($s->width, $new_height); + } +} + +# Turn off expansion in the slave. +# This is done only if necessary, as calls to pack/gridConfigure cause +# repacking. +# Before call to pack/gridConfigure, the reqwidth/reqheight is set to the +# current width/height. This is because the geometry managers use +# the requested values, not the actual, to calculate the new geometry. +sub slave_expand_off +{ + my $w = shift; + my $s = $w->slave; + return if ! $s; + + my $manager = $s->manager; + if ($manager eq 'pack') + { + my %info = $s->packInfo; + my $expand = $info{'-expand'}; + if ($expand) + { + $s->GeometryRequest($s->width, $s->height); + $s->packConfigure(-expand => 0); + } + } + elsif ($manager eq 'grid') + { + my %info = $s->gridInfo; + my $master = $info{'-in'}; + if ($w->vert) + { + my $col = $info{'-column'}; + my $expand = $master->gridColumnconfigure($col, '-weight'); + if ($expand) + { + $s->GeometryRequest($s->width, $s->height); + $master->gridColumnconfigure($col, -weight => 0); + } + } + else + { + my $row = $info{'-row'}; + my $expand = $master->gridRowconfigure($row, '-weight'); + if ($expand) + { + $s->GeometryRequest($s->width, $s->height); + $master->gridRowconfigure($row, -weight => 0); + } + } + } +} + +1; + +__END__ + +=cut #' emacs hilighting... diff --git a/Master/tlpkg/tlperl/lib/Tk/After.pm b/Master/tlpkg/tlperl/lib/Tk/After.pm new file mode 100644 index 00000000000..85a0e406ee5 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/After.pm @@ -0,0 +1,104 @@ +# Copyright (c) 1995-2004 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. +package Tk::After; +use Carp; + +use vars qw($VERSION); +$VERSION = '4.007'; # $Id: //depot/Tkutf8/Tk/After.pm#11 $ + +sub _cancelAll +{ + my $w = shift; + my $h = delete $w->{_After_}; + foreach my $obj (values %$h) + { + # carp "Auto cancel ".$obj->[1]." for ".$obj->[0]->PathName; + $obj->cancel; + bless $obj,"Tk::After::Cancelled"; + } +} + +sub Tk::After::Cancelled::once { } +sub Tk::After::Cancelled::repeat { } + +sub submit +{ + my $obj = shift; + my $w = $obj->[0]; + my $id = $obj->[1]; + my $t = $obj->[2]; + my $method = $obj->[3]; + delete($w->{_After_}{$id}) if (defined $id); + $id = $w->Tk::after($t,[$method => $obj]); + unless (exists $w->{_After_}) + { + $w->{_After_} = {}; + $w->OnDestroy([\&_cancelAll, $w]); + } + $w->{_After_}{$id} = $obj; + $obj->[1] = $id; + return $obj; +} + +sub DESTROY +{ + my $obj = shift; + $obj->cancel; + undef $obj->[0]; + undef $obj->[4]; +} + +sub new +{ + my ($class,$w,$t,$method,@cb) = @_; + my $cb = (@cb == 1) ? shift(@cb) : [@cb]; + my $obj = bless [$w,undef,$t,$method,Tk::Callback->new($cb)],$class; + return $obj->submit; +} + +sub cancel +{ + my $obj = shift; + my $id = $obj->[1]; + my $w = $obj->[0]; + if ($id) + { + $w->Tk::after('cancel'=> $id) if Tk::Exists($w); + delete $w->{_After_}{$id} if exists $w->{_After_}; + $obj->[1] = undef; + } + return $obj; +} + +sub repeat +{ + my $obj = shift; + $obj->submit; + local $Tk::widget = $obj->[0]; + $obj->[4]->Call; +} + +sub once +{ + my $obj = shift; + my $w = $obj->[0]; + my $id = $obj->[1]; + delete $w->{_After_}{$id}; + local $Tk::widget = $w; + $obj->[4]->Call; +} + +sub time { + my $obj = shift; + my $delay = shift; + if (defined $delay) { + $obj->cancel if $delay == 0; + $obj->[2] = $delay; + } + $obj->[2]; +} + +1; +__END__ + diff --git a/Master/tlpkg/tlperl/lib/Tk/Animation.pm b/Master/tlpkg/tlperl/lib/Tk/Animation.pm new file mode 100644 index 00000000000..428f3f1f48f --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Animation.pm @@ -0,0 +1,178 @@ +package Tk::Animation; + +use vars qw($VERSION); +$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Animation.pm#8 $ + +use Tk::Photo; +use base qw(Tk::Photo); + +Construct Tk::Widget 'Animation'; + +sub MainWindow +{ + return shift->{'_MainWIndow_'}; +} + +sub add_frame +{ + my $obj = shift; + $obj->{'_frames_'} = [] unless exists $obj->{'_frames_'}; + push(@{$obj->{'_frames_'}},@_); +} + +sub new +{ + my ($class,$widget,%args) = @_; + my $obj = $class->SUPER::new($widget,%args); + $obj->{'_MainWIndow_'} = $widget->MainWindow; + if ($args{'-format'} eq 'gif') + { + my @images; + local $@; + while (1) + { + my $index = @images; + $args{'-format'} = "gif -index $index"; + my $img; + eval {local $SIG{'__DIE__'}; $img = $class->SUPER::new($widget,%args) }; + last if $@; + push(@images,$img); + } + if (@images > 1) + { + $obj->add_frame(@images); + $obj->{'_frame_index_'} = 0; + } + } + $obj->set_image( 0 ); + $obj->{_delta_} = 1; + $obj->{_blank_} = 0; + return $obj; +} + +sub fast_forward { + + my( $self, $delta) = @_; + + $self->{_delta_} = $delta; + if( not exists $self->{_playing_} ) { + my $playing = exists $self->{'_NextId_'}; + $self->{_playing_} = $playing; + $self->resume_animation if not $playing; + } else { + my $playing = delete $self->{_playing_}; + $self->pause_animation if not $playing; + } + +} # end fast_forward + +*fast_reverse = \&fast_forward; + +sub frame_count { + my $frames = shift->{'_frames_'}; + return -1 unless $frames; + return @$frames; +} + +sub blank { + my( $self, $blank ) = @_; + $blank = 1 if not defined $blank; + $self->{_blank_} = $blank; + $blank; +} + +sub set_image +{ + my ($obj,$index) = @_; + my $frames = $obj->{'_frames_'}; + return unless $frames && @$frames; + $index = 0 unless $index < @$frames; + $obj->blank if $obj->{_blank_}; # helps some make others worse + $obj->copy($frames->[$index]); + $obj->{'_frame_index_'} = $index; +} + +sub next_image +{ + my ($obj, $delta) = @_; + $delta = $obj->{_delta_} unless $delta; + my $frames = $obj->{'_frames_'}; + return unless $frames && @$frames; + $obj->set_image((($obj->{'_frame_index_'} || 0) + $delta) % @$frames); +} + +sub prev_image { shift->next_image( -1 ) } + +sub pause_animation { + my $self = shift; + my $id = delete $self->{'_NextId_'}; + Tk::catch { $id->cancel } if $id; +} + +sub resume_animation { + my( $self, $period ) = @_; + if( not defined $self->{'_period_'} ) { + $self->{'_period_'} = defined( $period ) ? $period : 100; + } + $period = $self->{'_period_'}; + my $w = $self->MainWindow; + $self->{'_NextId_'} = $w->repeat( $period => [ $self => 'next_image' ] ); +} + +sub start_animation +{ + my ($obj,$period) = @_; + $period ||= 100; + my $frames = $obj->{'_frames_'}; + return unless $frames && @$frames; + my $w = $obj->MainWindow; + $obj->stop_animation; + $obj->{'_period_'} = $period; + $obj->{'_NextId_'} = $w->repeat($period,[$obj,'next_image']); +} + +sub stop_animation +{ + my ($obj) = @_; + my $id = delete $obj->{'_NextId_'}; + Tk::catch { $id->cancel } if $id; + $obj->set_image(0); +} + +1; +__END__ + +=cut + +# +# This almost works for changing the animation on the fly +# but does not resize things correctly +# + +sub gif_sequence +{ + my ($obj,%args) = @_; + my $widget = $obj->MainWindow; + my @images; + local $@; + while (1) + { + my $index = @images; + $args{'-format'} = "gif -index $index"; + my $img; + eval + {local $SIG{'__DIE__'}; + my $img = $widget->Photo(%args); + push(@images,$img); + }; + last if $@; + } + if (@images) + { + delete $obj->{'_frames_'}; + $obj->add_frame(@images); + $obj->configure(-width => 0, -height => 0); + $obj->set_frame(0); + } +} + diff --git a/Master/tlpkg/tlperl/lib/Tk/Balloon.pm b/Master/tlpkg/tlperl/lib/Tk/Balloon.pm new file mode 100644 index 00000000000..2ee0f6c3bce --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Balloon.pm @@ -0,0 +1,621 @@ +# +# The help widget that provides both "balloon" and "status bar" +# types of help messages. +# +# This is a patched version of Balloon 3.037 - it adds support +# for different orientations of the balloon widget, depending +# on wether there's enough space for it. The little arrow now +# should always point directly to the client. +# Added by Gerhard Petrowitsch (gerhard.petrowitsch@philips.com) +# +# Nov 1, 2003 - Jack Dunnigan +# Added support for more than one screen in single logical +# screen mode (i.e. xinerama, dual monitors) + +package Tk::Balloon; + +use vars qw($VERSION); +$VERSION = sprintf '4.%03d', q$Revision: #10 $ =~ /\D(\d+)\s*$/; + +use Tk qw(Ev Exists); +use Carp; +require Tk::Toplevel; + +Tk::Widget->Construct('Balloon'); +use base qw(Tk::Toplevel); + +# use UNIVERSAL; avoid the UNIVERSAL.pm file subs are XS in perl core + +use strict; + +my @balloons; +my $button_up = 0; +my %arrows = ( TL => 'R0lGODlhBgAGAJEAANnZ2QAAAP///////yH5BAEAAAAALAAAAAAGAAYAAAINjA0HAEdwLCwMKIQfBQA7', + TR => 'R0lGODlhBgAGAJEAANnZ2QAAAP///////yH5BAEAAAAALAAAAAAGAAYAAAIRBGMDwAEQkgAIAAoCABEEuwAAOw==', + BR => 'R0lGODlhBgAGAJEAANnZ2QAAAP///////yH5BAEAAAAALAAAAAAGAAYAAAIPDOHHhYVRAIgIAEISQLELADs=', + BL => 'R0lGODlhBgAGAJEAANnZ2QAAAP///////yH5BAEAAAAALAAAAAAGAAYAAAIPhB1xAUFALCIMKAaAWQAVADs=', + NO => 'R0lGODlhAQABAJEAANnZ2f///////////yH5BAEAAAAALAAAAAABAAEAAAICRAEAOw==' + ); + + +sub ClassInit { + my ($class, $mw) = @_; + $mw->bind('all', '<Motion>', ['Tk::Balloon::Motion', Ev('X'), Ev('Y'), Ev('s')]); + $mw->bind('all', '<Leave>', ['Tk::Balloon::Motion', Ev('X'), Ev('Y'), Ev('s')]); + $mw->bind('all', '<Button>', 'Tk::Balloon::ButtonDown'); + $mw->bind('all', '<ButtonRelease>', 'Tk::Balloon::ButtonUp'); + return $class; +} + +sub Populate { + my ($w, $args) = @_; + + $w->SUPER::Populate($args); + + $w->overrideredirect(1); + $w->withdraw; + # Only the container frame's background should be black... makes it + # look better. + $w->configure(-background => 'black'); + + # the balloon arrows + $w->{img_tl} = $w->Photo(-data => $arrows{TL}, -format => 'gif'); + $w->{img_tr} = $w->Photo(-data => $arrows{TR}, -format => 'gif'); + $w->{img_bl} = $w->Photo(-data => $arrows{BL}, -format => 'gif'); + $w->{img_br} = $w->Photo(-data => $arrows{BR}, -format => 'gif'); + $w->{img_no} = $w->Photo(-data => $arrows{NO}, -format => 'gif'); + $w->OnDestroy([$w, '_destroyed']); + + $w->{'pointer'} = $w->Label(-bd=>0, -relief=>'flat',-image=>$w->{img_no}); + + # the balloon message + # We give the Label a big borderwidth + # ..enough to slide a 6x6 gif image along the border including some space + + my $ml = $w->Label(-bd => 0, + -padx => 10, + -pady => 3, + -justify => 'left', + -relief=>'flat'); + $w->Advertise('message' => $ml); + + $ml->pack( + -side => 'top', + -anchor => 'nw', + -expand => 1, + -fill => 'both', + -padx => 0, + -pady => 0); + + # append to global list of balloons + push(@balloons, $w); + $w->{'popped'} = 0; + $w->{'buttonDown'} = 0; + $w->{'menu_index'} = 'none'; + $w->{'menu_index_over'} = 'none'; + $w->{'canvas_tag'} = ''; + $w->{'canvas_tag_over'} = ''; + $w->{'current_screen'} = 0; + + $w->ConfigSpecs(-installcolormap => ['PASSIVE', 'installColormap', 'InstallColormap', 0], + -initwait => ['PASSIVE', 'initWait', 'InitWait', 350], + -state => ['PASSIVE', 'state', 'State', 'both'], + -statusbar => ['PASSIVE', 'statusBar', 'StatusBar', undef], + -statusmsg => ['PASSIVE', 'statusMsg', 'StatusMsg', ''], + -balloonmsg => ['PASSIVE', 'balloonMsg', 'BalloonMsg', ''], + -balloonposition => ['PASSIVE', 'balloonPosition', 'BalloonPosition', 'widget'], + -postcommand => ['CALLBACK', 'postCommand', 'PostCommand', undef], + -cancelcommand => ['CALLBACK', 'cancelCommand', 'CancelCommand', undef], + -motioncommand => ['CALLBACK', 'motionCommand', 'MotionCommand', undef], + -background => ['DESCENDANTS', 'background', 'Background', '#C0C080'], + -foreground => ['DESCENDANTS', 'foreground', 'Foreground', undef], + -font => [$ml, 'font', 'Font', '-*-helvetica-medium-r-normal--*-120-*-*-*-*-*-*'], + -borderwidth => ['SELF', 'borderWidth', 'BorderWidth', 1], + -numscreens=>['PASSIVE', 'numScreens','NumScreens',1], + ); +} + +# attach a client to the balloon +sub attach { + my ($w, $client, %args) = @_; + foreach my $key (grep(/command$/,keys %args)) + { + $args{$key} = Tk::Callback->new($args{$key}); + } + my $msg = delete $args{-msg}; + $args{-balloonmsg} = $msg unless exists $args{-balloonmsg}; + $args{-statusmsg} = $msg unless exists $args{-statusmsg}; + $w->{'clients'}{$client} = \%args; + $client->OnDestroy([$w, 'detach', $client]); +} + +# detach a client from the balloon. +sub detach { + my ($w, $client) = @_; + if (Exists($w)) + { + $w->Deactivate if ($client->IS($w->{'client'})); + } + delete $w->{'clients'}{$client}; +} + +sub GetOption +{ + my ($w,$opt,$client) = @_; + $client = $w->{'client'} unless defined $client; + if (defined $client) + { + my $info = $w->{'clients'}{$client}; + return $info->{$opt} if exists $info->{$opt}; + } + return $w->cget($opt); +} + +sub Motion { + my ($ewin, $x, $y, $s) = @_; + + return if not defined $ewin; + + # Find which window we are over + my $over = $ewin->Containing($x, $y); + + return if &grabBad($ewin, $over); + + foreach my $w (@balloons) { + # if cursor has moved over the balloon -- ignore + next if defined $over and $over->toplevel eq $w; + + # find the client window that matches + my $client = $over; + while (defined $client) { + last if (exists $w->{'clients'}{$client}); + $client = $client->Parent; + } + if (defined $client) { + # popping up disabled -- ignore + my $state = $w->GetOption(-state => $client); + next if $state eq 'none'; + # Check if a button was recently released: + my $deactivate = 0; + if ($button_up) { + $deactivate = 1; + $button_up = 0; + } + # Deactivate it if the motioncommand says to: + my $command = $w->GetOption(-motioncommand => $client); + $deactivate = $command->Call($client, $x, $y) if defined $command; + if ($deactivate) + { + $w->Deactivate; + } + else + { + # warn "deact: $client $w->{'client'}"; + $w->Deactivate unless $client->IS($w->{'client'}); + my $msg = $client->BalloonInfo($w,$x,$y,'-statusmsg','-balloonmsg'); + if (defined($msg)) + { + my $delay = delete $w->{'delay'}; + $delay->cancel if defined $delay; + my $initwait = $w->GetOption(-initwait => $client); + $w->{'delay'} = $client->after($initwait, sub {$w->SwitchToClient($client);}); + $w->{'client'} = $client; + } + } + } else { + # cursor is at a position covered by a non client + # pop down the balloon if it is up or scheduled. + $w->Deactivate; + } + } +} + +sub ButtonDown { + my ($ewin) = @_; + + foreach my $w (@balloons) { + $w->Deactivate; + } +} + +sub ButtonUp { + $button_up = 1; +} + +# switch the balloon to a new client +sub SwitchToClient { + my ($w, $client) = @_; + return unless Exists($w); + return unless Exists($client); + return unless $client->IS($w->{'client'}); + return if &grabBad($w, $client); + my $command = $w->GetOption(-postcommand => $client); + if (defined $command) { + # Execute the user's command and return if it returns false: + my $pos = $command->Call($client); + return if not $pos; + if ($pos =~ /^(\d+),(\d+)$/) { + # Save the returned position so the Popup method can use it: + $w->{'clients'}{$client}{'postposition'} = [$1, $2]; + } + } + my $state = $w->GetOption(-state => $client); + $w->Popup if ($state =~ /both|balloon/); + $w->SetStatus if ($state =~ /both|status/); + $w->{'popped'} = 1; + $w->{'delay'} = $w->repeat(200, ['Verify', $w, $client]); +} + +sub grabBad { + + my ($w, $client) = @_; + + return 0 unless Exists($client); + my $g = $w->grabCurrent; + return 0 unless defined $g; + return 0 if $g->isa('Tk::Menu'); + return 0 if $g eq $client; + + # The grab is OK if $client is a decendant of $g. Use the internal Tcl/Tk + # pathname (yes, it's cheating, but it's legal). + + return 0 if $g == $w->MainWindow; + my $wp = $w->PathName; + my $gp = $g->PathName; + return 0 if $wp =~ /^$gp/; + return 1; # bad grab + +} # end grabBad + + +sub Subclient +{ + my ($w,$data) = @_; + if (defined($w->{'subclient'}) && (!defined($data) || $w->{'subclient'} ne $data)) + { + $w->Deactivate; + } + $w->{'subclient'} = $data; +} + +sub Verify { + my $w = shift; + my $client = shift; + my ($X,$Y) = (@_) ? @_ : ($w->pointerxy); + my $over = $w->Containing($X,$Y); + return if not defined $over or ($over->toplevel eq $w); + my $deactivate = # DELETE? or move it to the isa-Menu section?: + # ($over ne $client) or + not $client->IS($w->{'client'}) +# or (!$client->isa('Tk::Menu') && $w->grabCurrent); +# or $w->grabbad($client); + or &grabBad($w, $client); + if ($deactivate) + { + $w->Deactivate; + } + else + { + $client->BalloonInfo($w,$X,$Y,'-statusmsg','-balloonmsg'); + } +} + +sub Deactivate { + my ($w) = @_; + my $delay = delete $w->{'delay'}; + $delay->cancel if defined $delay; + if ($w->{'popped'}) { + my $client = $w->{'client'}; + my $command = $w->GetOption(-cancelcommand => $client); + if (defined $command) { + # Execute the user's command and return if it returns false: + return if not $command->Call($client); + } + $w->withdraw; + $w->ClearStatus; + $w->{'popped'} = 0; + $w->{'menu_index'} = 'none'; + $w->{'canvas_tag'} = ''; + } + $w->{'client'} = undef; + $w->{'subclient'} = undef; + $w->{'location'} = undef; +} + +sub Popup { + my ($w) = @_; + if ($w->cget(-installcolormap)) { + $w->colormapwindows($w->winfo('toplevel')) + } + my $client = $w->{'client'}; + return if not defined $client or not exists $w->{'clients'}{$client}; + my $msg = $client->BalloonInfo($w, $w->pointerxy,'-balloonmsg'); + # Dereference it if it looks like a scalar reference: + $msg = $$msg if UNIVERSAL::isa($msg, 'SCALAR'); + + $w->Subwidget('message')->configure(-text => $msg); + $w->idletasks; + + return unless Exists($w); + return unless Exists($client); + return if $msg eq ''; # Don't popup empty balloons. + + my ($x, $y); + my $pos = $w->GetOption(-balloonposition => $client); + my $postpos = delete $w->{'clients'}{$client}{'postposition'}; + if (defined $postpos) { + # The postcommand must have returned a position for the balloon - I will use that: + ($x,$y) = @{$postpos}; + } elsif ($pos eq 'mouse') { + ($x,$y)=$client->pointerxy; # We adjust the position later + } elsif ($pos eq 'widget') { + $x = int($client->rootx + $client->width/2); + $y = int($client->rooty + int ($client->height/1.3)); + } else { + croak "'$pos' is not a valid position for the balloon - it must be one of: 'widget', 'mouse'."; + } + + $w->idletasks; + + # Explanation of following code. [JD] + # PREMISE: We want to ensure that the balloon is always "on screen". + # To do this we use calculate the size of the + # toplevel before it is mapped. Then we adjust it's position with respect to the + # mouse cursor or widget. Balloons are usually shown below and to the right of the target. + # From extensive KDE experience using Xinerama, and from using dual monitors on WinXP.. + # the balloon will extend across two monitors in single logical screen mode (SLS). + # This is an undesirable characteristic indeed. Trying to read a disjointed balloon + # across monitors is not fun. + # + # The intent of the following code is to fix this problem. We do this by avoiding + # placement of any part of the balloon over,say, the "half screenwidth" mark (for two + # monitors in SLS mode) or "thirds of screenwidth" mark (for 3 monitors) and so on... + # i.e. In SLS mode these *WILL BE* separate screens and as such, should be considered hard + # boundaries to be avoided. + # + # The only drawback of this code, is I know of no way to actually determine this on a + # user by user basis. This means that the developer or administrator will have to know + # the hardware (monitor) setup for which the application is designed. + # + # This code uses Gerhard's GIF images but changes *how* the image gets shown. Instead + # of creating four separate labels, we configure only ONE label with the proper image. + # Then using the place geometry manager, this image/label can be "slid" along the + # appropriate side of the toplevel so that it always points directly at the target widget. + # + # Here we go.. + + my ($width, $height) = ($w->reqwidth, $w->reqheight); + my ($sw, $sh) = ($w->screenwidth, $w->screenheight); + my $numscreen = $w->cget(-numscreens); + my $deltax = $sw/$numscreen; + my $leftedge; + my $rightedge; + my $count = 0; + for (my $i=0; $i<$sw; $i+=$deltax){ + $leftedge = $i; + $rightedge = $i + $deltax; + if ($x >= $leftedge && $x < $rightedge ){ + last; + } + $count++; + } + + # Force another look at balloon location because mouse has switched + # virtual screens. + $w->{'location'} = undef unless ( $count == $w->{'current_screen'} ); + $w->{'current_screen'} = $count; + + my $xx=undef; + my $yy=undef; # to hold final toplevel placement + my $slideOffsetX = 0; + my $slideOffsetY = 0; + my $cornerOffset = 5; #default - keep corner away from pointer + my $testtop = $y - $height - $cornerOffset; + my $testbottom = $y + $height + (2*$cornerOffset); + my $testright = $x + $width + (2*$cornerOffset); + my $testleft = $x - $width - $cornerOffset; + my $vert='bottom'; #default + my $horiz='right'; #default + + + if ( defined $w->{'location'} ){ + # Once balloon is activated, **don't** change the location of the balloon. + # It is annoying to have it jump from one location to another. + ( $w->{'location'}=~/top/ ) ? ( $vert = 'top' ) : ( $vert = 'bottom' ); + ( $w->{'location'}=~/left/ ) ? ( $horiz = 'left' ) : ( $horiz = 'right' ); + + if ($vert eq 'top' && $testtop < 0) { + $yy = 0; + $slideOffsetY = $testtop; + } + elsif ($vert eq 'bottom' && $testbottom > $sh) { + $slideOffsetY = $testbottom - $sh; + } + + if ($horiz eq 'left' && $testleft < $leftedge) { + $xx = $leftedge; + } + elsif ($horiz eq 'right' && $testright > $rightedge) { + $slideOffsetX = $testright - $rightedge; + } + } + else { + #Test balloon positions in the vertical + if ($testbottom > $sh) { + #Then offscreen to bottom, check top + if ($testtop >= 0) { + $vert = 'top'; + } + elsif ($y > $sh/2) { + #still offscreen to top but there is more room above then below + $vert = 'top'; + $yy=0; + $slideOffsetY = $testtop; + } + if ($vert eq 'bottom'){ + #Calculate Yoffset to fit entire balloon onto screen + $slideOffsetY = $testbottom - $sh; + } + } + #Test balloon positions in the horizontal + + if ($testright > $rightedge) { + #The offscreen, check left + if ($testleft >= $leftedge) { + $horiz = 'left'; + } + elsif ($x > ($leftedge+$deltax) ) { + #still offscreen to left but there is more room to left than right + $horiz = 'left'; + $xx=0; + $slideOffsetX = $testleft; + } + if ($horiz eq 'right'){ + #Calculate Xoffset to fit entire balloon onto screen + $slideOffsetX = $testright - $rightedge; + } + } + } + + $w->{'location'} = $vert.$horiz unless (defined $w->{'location'}); + + if ($w->{'location'} eq 'bottomright') { + if ( $slideOffsetX or $slideOffsetY ) { + $w->{'pointer'}->configure(-image => $w->{img_no}); + } + else { + $w->{'pointer'}->configure(-image => $w->{img_tl}); + } + + $w->{'pointer'}->place( + -in=>$w, +# -relx=>0, -x=>$slideOffsetX + 2, +# -rely=>0, -y=>$slideOffsetY + 2, + -relx=>0, -x=>2, + -rely=>0, -y=>2, + -bordermode=>'outside', + -anchor=>'nw'); + + $xx=$x-$slideOffsetX+(2*$cornerOffset) unless (defined $xx); + $yy=$y-$slideOffsetY+(2*$cornerOffset) unless (defined $yy); + + } + elsif ($w->{'location'} eq 'bottomleft') { + if ( $slideOffsetX or $slideOffsetY ) { + $w->{'pointer'}->configure(-image => $w->{img_no}); + } + else { + $w->{'pointer'}->configure(-image => $w->{img_tr}); + } + + $w->{'pointer'}->place(-in=>$w, +# -relx=>1, -x=>$slideOffsetX - 2, +# -rely=>0, -y=>$slideOffsetY + 2, + -relx=>1, -x=>-2, + -rely=>0, -y=>2, + -bordermode=>'outside', + -anchor=>'ne'); + + $xx=$x-$width-$slideOffsetX-$cornerOffset unless (defined $xx); + $yy=$y-$slideOffsetY+(2*$cornerOffset) unless (defined $yy); + + } + elsif ($w->{'location'} eq 'topright') { + if ( $slideOffsetX or $slideOffsetY ) { + $w->{'pointer'}->configure(-image => $w->{img_no}); + } + else { + $w->{'pointer'}->configure(-image => $w->{img_bl}); + } + + $w->{'pointer'}->place(-in=>$w, +# -relx=>0, -x=>$slideOffsetX + 2, +# -rely=>1, -y=>$slideOffsetY - 2, + -relx=>0, -x=>2, + -rely=>1, -y=>-2, + -bordermode=>'outside', + -anchor=>'sw'); + + $xx=$x-$slideOffsetX+$cornerOffset unless (defined $xx); + $yy=$y-$height-$slideOffsetY-$cornerOffset unless (defined $yy); + } + elsif ($w->{'location'} eq 'topleft') { + if ( $slideOffsetX or $slideOffsetY ) { + $w->{'pointer'}->configure(-image => $w->{img_no}); + } + else { + $w->{'pointer'}->configure(-image => $w->{img_br}); + } + + $w->{'pointer'}->place(-in=>$w, +# -relx=>1, -x=>$slideOffsetX - 2, +# -rely=>1, -y=>$slideOffsetY - 2, + -relx=>1, -x=>-2, + -rely=>1, -y=>-2, + -bordermode=>'outside', + -anchor=>'se'); + + $xx=$x-$width-$slideOffsetX-$cornerOffset unless (defined $xx); + $yy=$y-$height-$slideOffsetY-$cornerOffset unless (defined $yy); + } + + $w->{'pointer'}->raise; + $xx = int($xx); + $yy = int($yy); + $w->geometry("+$xx+$yy"); + $w->deiconify(); + $w->raise; +} + +sub SetStatus { + my ($w) = @_; + my $client = $w->{'client'}; + my $s = $w->GetOption(-statusbar => $client); + if (defined $s and $s->winfo('exists')) { + my $vref = $s->cget(-textvariable); + return if not defined $client or not exists $w->{'clients'}{$client}; + my $msg = $client->BalloonInfo($w, $w->pointerxy,'-statusmsg'); + # Dereference it if it looks like a scalar reference: + $msg = $$msg if UNIVERSAL::isa($msg, 'SCALAR'); + if (not defined $vref) { + eval { $s->configure(-text => $msg); }; + } else { + $$vref = $msg; + } + } +} + +sub ClearStatus { + my ($w) = @_; + my $client = $w->{'client'}; + my $s = $w->GetOption(-statusbar => $client); + if (defined $s and $s->winfo('exists')) { + my $vref = $s->cget(-textvariable); + if (defined $vref) { + $$vref = ''; + } else { + eval { $s->configure(-text => ''); } + } + } +} + +sub _destroyed { + my ($w) = @_; + # This is called when widget is destroyed (no matter how!) + # via the ->OnDestroy hook set in Populate. + # remove ourselves from the list of baloons. + @balloons = grep($w != $_, @balloons); + + # FIXME: If @balloons is now empty perhaps remove the 'all' bindings + # to reduce overhead until another balloon is created? + + # Delete the images + for (qw(no tl tr bl br)) { + my $img = delete $w->{"img_$_"}; + $img->delete if defined $img; + } +} + +1; + + diff --git a/Master/tlpkg/tlperl/lib/Tk/Bitmap.pm b/Master/tlpkg/tlperl/lib/Tk/Bitmap.pm new file mode 100644 index 00000000000..d081a393804 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Bitmap.pm @@ -0,0 +1,10 @@ +package Tk::Bitmap; +require Tk; +require Tk::Image; +use vars qw($VERSION); +$VERSION = '4.004'; # $Id: //depot/Tkutf8/Tk/Bitmap.pm#4 $ +use base qw(Tk::Image); +Construct Tk::Image 'Bitmap'; +sub Tk_image { 'bitmap' } +1; +__END__ diff --git a/Master/tlpkg/tlperl/lib/Tk/BrowseEntry.pm b/Master/tlpkg/tlperl/lib/Tk/BrowseEntry.pm new file mode 100644 index 00000000000..5c4b6b782c2 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/BrowseEntry.pm @@ -0,0 +1,510 @@ +# +# BrowseEntry is a stripped down version of ComboBox.tcl from Tix4.0 +# +# Some additions by Slaven Rezic <slaven@rezic.de> to make the widget +# look like the Windows' Combobox. There are also additional options. +# + +package Tk::BrowseEntry; + +use vars qw($VERSION); +$VERSION = sprintf '4.%03d', q$Revision: #13 $ =~ /\D(\d+)\s*$/; + +use Tk qw(Ev); +use Carp; +use strict; + +use base qw(Tk::Frame); +Construct Tk::Widget 'BrowseEntry'; + +require Tk::LabEntry; + +sub LabEntryWidget { "LabEntry" } +sub ButtonWidget { "Button" } +sub ListboxWidget { "Listbox" } + +sub Populate { + my ($w, $args) = @_; + + $w->Tk::Frame::Populate($args); + + # entry widget and arrow button + my $lpack = delete $args->{-labelPack}; + if (not defined $lpack) { + $lpack = [-side => 'left', -anchor => 'e']; + } + $w->{_BE_Style} = delete $args->{-style} || $Tk::platform; + my $LabEntry = $w->LabEntryWidget; + my $Listbox = $w->ListboxWidget; + my $Button = $w->ButtonWidget; + # XXX should this be retained? +# if (defined $args->{-state} and $args->{-state} eq 'readonly') { # XXX works only at construction time +# $LabEntry = "NoSelLabEntry"; +# require Tk::NoSelLabEntry; +# } + my $e; + my $var = ""; + my @LabEntry_args = (-textvariable => \$var); + if (exists $args->{-label}) { + $e = $w->$LabEntry(-labelPack => $lpack, + -label => delete $args->{-label}, + @LabEntry_args, + ); + } else { + $e = $w->$LabEntry(@LabEntry_args); + } + my $b = $w->$Button(-bitmap => '@' . Tk->findINC($w->{_BE_Style} eq 'MSWin32' ? 'arrowdownwin.xbm' : 'cbxarrow.xbm')); + $w->Advertise('entry' => $e); + $w->Advertise('arrow' => $b); + + # Pack the button to align vertically with the entry widget + my @anch; + my $edge = {@$lpack}->{-side}; + push(@anch,-anchor => 's') if ($edge && $edge eq 'top'); + push(@anch,-anchor => 'n') if ($edge && $edge eq 'bottom'); + $b->pack(-side => 'right', -padx => 1, @anch); + + $e->pack(-side => 'right', -fill => 'x', -expand => 1); #XXX, -padx => 1); + + # popup shell for listbox with values. + my $c = $w->Toplevel(-bd => 2, + -relief => ($w->{_BE_Style} eq 'MSWin32' + ? "solid" : "raised")); + $c->overrideredirect(1); + $c->withdraw; + my $sl = $c->Scrolled( $Listbox, qw/-selectmode browse -scrollbars oe/ ); + if ($w->{_BE_Style} eq 'MSWin32' and $Tk::platform eq 'MSWin32') { + $sl->configure(-bg => 'SystemWindow', -relief => "flat"); + } + $w->Advertise('choices' => $c); + $w->Advertise('slistbox' => $sl); + $sl->pack(-expand => 1, -fill => 'both'); + + $sl->Subwidget("scrolled")->bind("<Motion>",sub { + return unless ($w->{_BE_Style} eq 'MSWin32'); + my $e = $_[0]->XEvent; + my $y = $e->y; + my $inx = $sl->nearest($y); + if (defined $inx) { + $sl->selectionClear(0, "end"); + $sl->selectionSet($inx); + } + }); + + # other initializations + $w->SetBindings; + $w->{'_BE_popped'} = 0; + $w->Delegates(get => $sl, DEFAULT => $e); + $w->ConfigSpecs( + -font => [qw/DESCENDANTS font Font/], + -listwidth => [qw/PASSIVE listWidth ListWidth/, undef], + -listheight => [{-height => $sl}, qw/listHeight ListHeight/, undef], + -listcmd => [qw/CALLBACK listCmd ListCmd/, undef], + -autolistwidth => [qw/PASSIVE autoListWidth AutoListWidth/, undef], + -autolimitheight => [qw/PASSIVE autoLimitHeight AutoLimitHeight 0/], + -browsecmd => [qw/CALLBACK browseCmd BrowseCmd/, undef], + -browse2cmd => [qw/CALLBACK browse2Cmd Browse2Cmd/, undef], + -choices => [qw/METHOD choices Choices/, undef], + -state => [qw/METHOD state State normal/], + -arrowimage => [ {-image => $b}, qw/arrowImage ArrowImage/, undef], + -variable => [ {'-textvariable' => $e} ], + -colorstate => [qw/PASSIVE colorState ColorState/, undef], + -command => '-browsecmd', + -options => '-choices', + -label => [qw/PASSIVE label Label/, undef], + -labelPack => [qw/PASSIVE labelPack LabelPack/, undef], + #-background => [$e, qw/background Background/, undef], + #-foreground => [$e, qw/foreground Foreground/, undef], + -buttontakefocus => [{-takefocus => $b}, 'buttonTakefocus', + 'ButtonTakefocus', 1], + DEFAULT => [$e] ); +} + +sub SetBindings { + my ($w) = @_; + + my $e = $w->Subwidget('entry'); + my $b = $w->Subwidget('arrow'); + + # set bind tags + $w->bindtags([$w, 'Tk::BrowseEntry', $w->toplevel, 'all']); + # as we don't bind $e here leave its tags alone ... + # $e->bindtags([$e, ref($e), $e->toplevel, 'all']); + + # bindings for the button and entry + $b->bind('<1>',[$w,'BtnDown']); + $b->toplevel->bind('<ButtonRelease-1>',[$w,'ButtonHack']); + $b->bind('<space>',[$w,'space']); + + # bindings for listbox + my $sl = $w->Subwidget('slistbox'); + my $l = $sl->Subwidget('listbox'); + $l->bind('<ButtonRelease-1>',[$w,'ListboxRelease',Ev('x'),Ev('y')]); + $l->bind('<Escape>' => [$w,'LbClose']); + $l->bind('<Return>' => [$w,'Return',$l]); + + # allow click outside the popped up listbox to pop it down. + $w->bind('<1>','BtnDown'); +} + +sub space +{ + my $w = shift; + $w->BtnDown; + $w->{'_BE_savefocus'} = $w->focusCurrent; + $w->Subwidget('slistbox')->focus; +} + + +sub ListboxRelease +{ + my ($w,$x,$y) = @_; + $w->ButtonHack; + $w->LbChoose($x, $y); +} + +sub Return +{ + my ($w,$l) = @_; + my($x, $y) = $l->bbox($l->curselection); + $w->LbChoose($x, $y) +} + + +sub BtnDown { + my ($w) = @_; + return if $w->cget( '-state' ) eq 'disabled'; + + if ($w->{'_BE_popped'}) { + $w->Popdown; + $w->{'_BE_buttonHack'} = 0; + } else { + $w->PopupChoices; + $w->{'_BE_buttonHack'} = 1; + } +} + +sub PopupChoices { + my ($w) = @_; + + if (!$w->{'_BE_popped'}) { + $w->Callback(-listcmd => $w); + my $e = $w->Subwidget('entry'); + my $c = $w->Subwidget('choices'); + my $s = $w->Subwidget('slistbox'); + my $a = $w->Subwidget('arrow'); + my $y1 = ($w->{_BE_Style} eq 'MSWin32' + ? $a->rooty + $a->height + : $e->rooty + $e->height + 3 + ); + my $bd = $c->cget(-bd) + $c->cget(-highlightthickness); + # using the real listbox reqheight rather than the + # container frame one, which does not change after resizing the + # listbox + my $ht = $s->Subwidget("scrolled")->reqheight + 2 * $bd; + my $x1 = ($w->{_BE_Style} eq 'MSWin32' + ? $e->Subwidget("entry")->rootx + : $e->rootx + ); + my ($width, $x2); + if (defined $w->cget(-listwidth)) { + $width = $w->cget(-listwidth); + $x2 = $x1 + $width; + } else { + $x2 = $a->rootx + $a->width; + $width = $x2 - $x1; + } + my $rw = $c->reqwidth; + if ($rw < $width) { + $rw = $width + } else { + if ($rw > $width * 3) { + $rw = $width * 3; + } + if ($rw > $w->vrootwidth) { + $rw = $w->vrootwidth; + } + } + $width = $rw; + + # if listbox is too far right, pull it back to the left + # + if ($x2 > $w->vrootwidth) { + $x1 = $w->vrootwidth - $width; + } + + # if listbox is too far left, pull it back to the right + # + if ($x1 < 0) { + $x1 = 0; + } + + # if listbox is below bottom of screen, pull it up. + # check the Win32 taskbar, if possible + my $rootheight; + if ($Tk::platform eq 'MSWin32' and $^O eq 'MSWin32') { + eval { + require Win32Util; # XXX should not use a non-CPAN widget + $rootheight = (Win32Util::screen_region($w))[3]; + }; + } + if (!defined $rootheight) { + $rootheight = $w->vrootheight; + } + + my $y2 = $y1 + $ht; + if ($y2 > $rootheight) { + $y1 = $y1 - $ht - ($e->height - 5); + } + $c->geometry(sprintf('%dx%d+%d+%d', $rw, $ht, $x1, $y1)); + $c->deiconify; + $c->raise; + $e->focus; + $w->{'_BE_popped'} = 1; + + # highlight current selection + my $current_sel = $e->get; + if (defined $current_sel) { + my $i = 0; + foreach my $str ($s->get(0, "end")) { + if ($str eq $current_sel) { + $s->selectionClear(0, "end"); + $s->selectionSet($i); + last; + } + $i++; + } + } + + $c->configure(-cursor => 'arrow'); + $w->{'_BE_grabinfo'} = $w->grabSave; + $w->grabGlobal; + } +} + +# choose value from listbox if appropriate +sub LbChoose { + my ($w, $x, $y) = @_; + my $l = $w->Subwidget('slistbox')->Subwidget('listbox'); + if ((($x < 0) || ($x > $l->Width)) || + (($y < 0) || ($y > $l->Height))) { + # mouse was clicked outside the listbox... close the listbox + $w->LbClose; + } else { + # select appropriate entry and close the listbox + $w->LbCopySelection; + $w->Callback(-browsecmd, $w, $w->Subwidget('entry')->get()); + $w->Callback(-browse2cmd => $w, $w->LbIndex); + } +} + +# close the listbox after clearing selection +sub LbClose { + my ($w) = @_; + my $l = $w->Subwidget('slistbox')->Subwidget('listbox'); + $l->selection('clear', 0, 'end'); + $w->Popdown; +} + +# copy the selection to the entry and close listbox +sub LbCopySelection { + my ($w) = @_; + my $index = $w->LbIndex; + if (defined $index) { + $w->{'_BE_curIndex'} = $index; + my $l = $w->Subwidget('slistbox')->Subwidget('listbox'); + my $var_ref = $w->cget( '-textvariable' ); + $$var_ref = $l->get($index); + if ($w->{'_BE_popped'}) { + $w->Popdown; + } + } + $w->Popdown; +} + +sub LbIndex { + my ($w, $flag) = @_; + my ($sel) = $w->Subwidget('slistbox')->Subwidget('listbox')->curselection; + if (defined $sel) { + return int($sel); + } else { + if (defined $flag && ($flag eq 'emptyOK')) { + return undef; + } else { + return 0; + } + } +} + +# pop down the listbox +sub Popdown { + my ($w) = @_; + if ($w->{'_BE_savefocus'} && Tk::Exists($w->{'_BE_savefocus'})) { + $w->{'_BE_savefocus'}->focus; + delete $w->{'_BE_savefocus'}; + } + if ($w->{'_BE_popped'}) { + my $c = $w->Subwidget('choices'); + $c->withdraw; + $w->grabRelease; + if (ref $w->{'_BE_grabinfo'} eq 'CODE') { + $w->{'_BE_grabinfo'}->(); + delete $w->{'_BE_grabinfo'}; + } + $w->{'_BE_popped'} = 0; + } +} + +# This hack is to prevent the ugliness of the arrow being depressed. +# +sub ButtonHack { + my ($w) = @_; + my $b = $w->Subwidget('arrow'); + if ($w->{'_BE_buttonHack'}) { + $b->butUp; + } +} + +sub choices +{ + my ($w,$choices) = @_; + if (@_ > 1) + { + $w->delete( qw/0 end/ ); + my %hash; + my $var = $w->cget('-textvariable'); + my $old = $$var; + foreach my $val (@$choices) + { + $w->insert( 'end', $val); + $hash{$val} = 1; + } + $old = $choices->[0] + if defined $old && not exists $hash{$old} && defined $choices->[0]; + $$var = $old; + } + else + { + return( $w->get( qw/0 end/ ) ); + } +} + +sub _set_edit_state { + my( $w, $state ) = @_; + + my $entry = $w->Subwidget( 'entry' ); + my $button = $w->Subwidget( 'arrow' ); + + if ($w->cget( '-colorstate' )) { + my $color; + if( $state eq 'normal' ) { # Editable + $color = 'gray95'; + } else { # Not Editable + $color = $w->cget( -background ) || 'lightgray'; + } + $entry->Subwidget( 'entry' )->configure( -background => $color ); + } + + if( $state eq 'readonly' ) { + $entry->configure( -state => 'disabled' ); + $button->configure( -state => 'normal' ); + if ($w->{_BE_Style} eq 'MSWin32') { + $entry->bind('<1>',[$w,'BtnDown']); + $w->{_BE_OriginalCursor} = $entry->cget( -cursor ); + $entry->configure( -cursor => 'left_ptr' ); + } + } else { + $entry->configure( -state => $state ); + if (exists $w->{_BE_OriginalCursor}) { + $entry->configure(-cursor => delete $w->{_BE_OriginalCursor}); + } + $button->configure( -state => $state ); + if ($w->{_BE_Style} eq 'MSWin32') { + $entry->bind('<1>',['Button1',Tk::Ev('x')]); + } + } +} + +sub state { + my $w = shift; + unless( @_ ) { + return( $w->{Configure}{-state} ); + } else { + my $state = shift; + $w->{Configure}{-state} = $state; + $w->_set_edit_state( $state ); + } +} + +sub _max { + my $max = shift; + foreach my $val (@_) { + $max = $val if $max < $val; + } + return( $max ); +} + +sub shrinkwrap { + my( $w, $size ) = @_; + + unless( defined $size ) { + $size = _max( map( length, $w->get( qw/0 end/ ) ) ) || 0;; + } + + my $lb = $w->Subwidget( 'slistbox' )->Subwidget( 'listbox' ); + $w->configure( -width => $size ); + $lb->configure( -width => $size ); +} + +sub limitheight { + my $w = shift; + my $choices_number = shift || $w->Subwidget('slistbox')->index("end"); + $choices_number = 10 if $choices_number > 10; + $w->configure(-listheight => $choices_number) if ($choices_number > 0); +} + +sub insert { + my $w = shift; + $w->Subwidget("slistbox")->insert(@_); + if ($w->cget(-autolimitheight)) { + $w->limitheight; + } + if ($w->cget(-autolistwidth)) { + $w->updateListWidth(@_[1..$#_]); + } +} + +sub delete { + my $w = shift; + $w->Subwidget("slistbox")->delete(@_); + if ($w->cget(-autolimitheight)) { + $w->limitheight; + } + if ($w->cget(-autolistwidth)) { + $w->updateListWidth(); + } +} + +sub updateListWidth { + my $w = shift; + my @ins = @_; + if (!@ins) { + @ins = $w->get(0, "end"); + } + + my $max_width = 0; + foreach my $ins (@ins) { + my $new_width = $w->fontMeasure($w->cget(-font), $ins); + if ($new_width > $max_width) { + $max_width = $new_width; + } + } + if ($max_width > 20) { # be sane + $w->configure(-listwidth => $max_width + 32); # XXX for scrollbar + } +} + +1; + +__END__ + diff --git a/Master/tlpkg/tlperl/lib/Tk/Button.pm b/Master/tlpkg/tlperl/lib/Tk/Button.pm new file mode 100644 index 00000000000..efa597dee14 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Button.pm @@ -0,0 +1,148 @@ +package Tk::Button; +# Conversion from Tk4.0 button.tcl competed. +# +# Copyright (c) 1992-1994 The Regents of the University of California. +# Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved. +# This program is free software; you can redistribute it and/or + +use vars qw($VERSION); +$VERSION = '4.008'; # $Id: //depot/Tkutf8/Tk/Button.pm#8 $ + +# modify it under the same terms as Perl itself, subject +# to additional disclaimer in license.terms due to partial +# derivation from Tk4.0 sources. + +use strict; + +require Tk::Widget; +use base qw(Tk::Widget); + +use vars qw($buttonWindow $relief); + +Tk::Methods('deselect','flash','invoke','select','toggle'); + +sub Tk_cmd { \&Tk::button } + +Construct Tk::Widget 'Button'; + +sub ClassInit +{ + my ($class,$mw) = @_; + $mw->bind($class,'<Enter>', 'Enter'); + $mw->bind($class,'<Leave>', 'Leave'); + $mw->bind($class,'<1>', 'butDown'); + $mw->bind($class,'<ButtonRelease-1>', 'butUp'); + $mw->bind($class,'<space>', 'Invoke'); + $mw->bind($class,'<Return>', 'Invoke'); + return $class; +} + +# tkButtonEnter -- +# The procedure below is invoked when the mouse pointer enters a +# button widget. It records the button we're in and changes the +# state of the button to active unless the button is disabled. +# +# Arguments: +# w - The name of the widget. + +sub Enter +{ + my $w = shift; + my $E = shift; + if ($w->cget('-state') ne 'disabled') + { + $w->configure('-state' => 'active'); + $w->configure('-state' => 'active', '-relief' => 'sunken') if (defined($buttonWindow) && $w == $buttonWindow) + } + $Tk::window = $w; +} + +# tkButtonLeave -- +# The procedure below is invoked when the mouse pointer leaves a +# button widget. It changes the state of the button back to +# inactive. If we're leaving the button window with a mouse button +# pressed (tkPriv(buttonWindow) == $w), restore the relief of the +# button too. +# +# Arguments: +# w - The name of the widget. +sub Leave +{ + my $w = shift; + $w->configure('-state'=>'normal') if ($w->cget('-state') ne 'disabled'); + $w->configure('-relief' => $relief) if (defined($buttonWindow) && $w == $buttonWindow); + undef $Tk::window; +} + +# tkButtonDown -- +# The procedure below is invoked when the mouse button is pressed in +# a button widget. It records the fact that the mouse is in the button, +# saves the button's relief so it can be restored later, and changes +# the relief to sunken. +# +# Arguments: +# w - The name of the widget. +sub butDown +{ + my $w = shift; + $relief = $w->cget('-relief'); + if ($w->cget('-state') ne 'disabled') + { + $buttonWindow = $w; + $w->configure('-relief' => 'sunken') + } +} + +# tkButtonUp -- +# The procedure below is invoked when the mouse button is released +# in a button widget. It restores the button's relief and invokes +# the command as long as the mouse hasn't left the button. +# +# Arguments: +# w - The name of the widget. +sub butUp +{ + my $w = shift; + if (defined($buttonWindow) && $buttonWindow == $w) + { + undef $buttonWindow; + $w->configure('-relief' => $relief); + if ($w->IS($Tk::window) && $w->cget('-state') ne 'disabled') + { + $w->invoke; + } + } +} + +# tkButtonInvoke -- +# The procedure below is called when a button is invoked through +# the keyboard. It simulate a press of the button via the mouse. +# +# Arguments: +# w - The name of the widget. +sub Invoke +{ + my $w = shift; + if ($w->cget('-state') ne 'disabled') + { + my $oldRelief = $w->cget('-relief'); + my $oldState = $w->cget('-state'); + $w->configure('-state' => 'active', '-relief' => 'sunken'); + $w->idletasks; + $w->after(100); + $w->configure('-state' => $oldState, '-relief' => $oldRelief); + $w->invoke; + } +} + + + +1; + +__END__ + + + + + diff --git a/Master/tlpkg/tlperl/lib/Tk/Camel.xpm b/Master/tlpkg/tlperl/lib/Tk/Camel.xpm new file mode 100644 index 00000000000..ba33c0149ec --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Camel.xpm @@ -0,0 +1,41 @@ +/* XPM */ +static char *Camel[] = { +/* width height num_colors chars_per_pixel */ +" 32 32 2 1", +/* colors */ +". c #ffffff", +"# c #7f7f00", +/* pixels */ +"................................", +"................................", +"...................###..........", +".......####......######.........", +"....####.##.....########........", +"....########....#########.......", +"......######..###########.......", +"......#####..#############......", +".....######.##############......", +".....######.###############.....", +".....######################.....", +".....#######################....", +".....#######################....", +"......#######################...", +".......####################.#...", +"........###################.#...", +"........###############.###.#...", +"............#######.###.###.#...", +"............###.###.##...##.....", +"............###.###..#...##.....", +"............##.####..#....#.....", +"............##.###...#....#.....", +"............##.##...#.....#.....", +"............#...#...#.....#.....", +"............#....#..#.....#.....", +"............#.....#.#.....#.....", +"............#.....###.....#.....", +"...........##....##.#....#......", +"...........#..............#.....", +".........###.............#......" +"................................", +"................................", +}; diff --git a/Master/tlpkg/tlperl/lib/Tk/Canvas.pm b/Master/tlpkg/tlperl/lib/Tk/Canvas.pm new file mode 100644 index 00000000000..210bc30bfc2 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Canvas.pm @@ -0,0 +1,1436 @@ +package Tk::Canvas; +use vars qw($VERSION); +$VERSION = sprintf '4.%03d', q$Revision: #12 $ =~ /\D(\d+)\s*$/; + +use Tk qw($XS_VERSION); + +use base qw(Tk::Widget); +Construct Tk::Widget 'Canvas'; + +bootstrap Tk::Canvas; + +sub Tk_cmd { \&Tk::canvas } + +Tk::Methods('addtag','bbox','bind','canvasx','canvasy','coords','create', + 'dchars','delete','dtag','find','focus','gettags','icursor', + 'index','insert','itemcget','itemconfigure','lower','move', + 'postscript','raise','scale','scan','select','type','xview','yview'); + +use Tk::Submethods ( 'create' => [qw(arc bitmap grid group image line oval + polygon rectangle text window)], + 'scan' => [qw(mark dragto)], + 'select' => [qw(from clear item to)], + 'xview' => [qw(moveto scroll)], + 'yview' => [qw(moveto scroll)], + ); + +*CanvasBind = \&Tk::bind; +*CanvasFocus = \&Tk::focus; + +sub ClassInit +{ + my ($class,$mw) = @_; + $mw->XYscrollBind($class); + return $class; +} + +sub BalloonInfo +{ + my ($canvas,$balloon,$X,$Y,@opt) = @_; + my @tags = ($canvas->find('withtag', 'current'),$canvas->gettags('current')); + foreach my $opt (@opt) + { + my $info = $balloon->GetOption($opt,$canvas); + if ($opt =~ /^-(statusmsg|balloonmsg)$/ && UNIVERSAL::isa($info,'HASH')) + { + $balloon->Subclient($tags[0]); + foreach my $tag (@tags) + { + return $info->{$tag} if exists $info->{$tag}; + } + return ''; + } + return $info; + } +} + +sub get_corners +{ + my $c = shift; + my(@xview) = $c->xview; + my(@yview) = $c->yview; + my(@scrollregion) = @{$c->cget(-scrollregion)}; + return ( + $xview[0] * ($scrollregion[2]-$scrollregion[0]) + $scrollregion[0], + $yview[0] * ($scrollregion[3]-$scrollregion[1]) + $scrollregion[1], + $xview[1] * ($scrollregion[2]-$scrollregion[0]) + $scrollregion[0], + $yview[1] * ($scrollregion[3]-$scrollregion[1]) + $scrollregion[1], + ); +} + +# List of adobe glyph names. Converted from glyphlist.txt, downloaded +# from Adobe + +$Tk::psglyphs = {qw( + 0020 space + 0021 exclam + 0022 quotedbl + 0023 numbersign + 0024 dollar + 0025 percent + 0026 ampersand + 0027 quotesingle + 0028 parenleft + 0029 parenright + 002A asterisk + 002B plus + 002C comma + 002D hyphen + 002E period + 002F slash + 0030 zero + 0031 one + 0032 two + 0033 three + 0034 four + 0035 five + 0036 six + 0037 seven + 0038 eight + 0039 nine + 003A colon + 003B semicolon + 003C less + 003D equal + 003E greater + 003F question + 0040 at + 0041 A + 0042 B + 0043 C + 0044 D + 0045 E + 0046 F + 0047 G + 0048 H + 0049 I + 004A J + 004B K + 004C L + 004D M + 004E N + 004F O + 0050 P + 0051 Q + 0052 R + 0053 S + 0054 T + 0055 U + 0056 V + 0057 W + 0058 X + 0059 Y + 005A Z + 005B bracketleft + 005C backslash + 005D bracketright + 005E asciicircum + 005F underscore + 0060 grave + 0061 a + 0062 b + 0063 c + 0064 d + 0065 e + 0066 f + 0067 g + 0068 h + 0069 i + 006A j + 006B k + 006C l + 006D m + 006E n + 006F o + 0070 p + 0071 q + 0072 r + 0073 s + 0074 t + 0075 u + 0076 v + 0077 w + 0078 x + 0079 y + 007A z + 007B braceleft + 007C bar + 007D braceright + 007E asciitilde + 00A0 space + 00A1 exclamdown + 00A2 cent + 00A3 sterling + 00A4 currency + 00A5 yen + 00A6 brokenbar + 00A7 section + 00A8 dieresis + 00A9 copyright + 00AA ordfeminine + 00AB guillemotleft + 00AC logicalnot + 00AD hyphen + 00AE registered + 00AF macron + 00B0 degree + 00B1 plusminus + 00B2 twosuperior + 00B3 threesuperior + 00B4 acute + 00B5 mu + 00B6 paragraph + 00B7 periodcentered + 00B8 cedilla + 00B9 onesuperior + 00BA ordmasculine + 00BB guillemotright + 00BC onequarter + 00BD onehalf + 00BE threequarters + 00BF questiondown + 00C0 Agrave + 00C1 Aacute + 00C2 Acircumflex + 00C3 Atilde + 00C4 Adieresis + 00C5 Aring + 00C6 AE + 00C7 Ccedilla + 00C8 Egrave + 00C9 Eacute + 00CA Ecircumflex + 00CB Edieresis + 00CC Igrave + 00CD Iacute + 00CE Icircumflex + 00CF Idieresis + 00D0 Eth + 00D1 Ntilde + 00D2 Ograve + 00D3 Oacute + 00D4 Ocircumflex + 00D5 Otilde + 00D6 Odieresis + 00D7 multiply + 00D8 Oslash + 00D9 Ugrave + 00DA Uacute + 00DB Ucircumflex + 00DC Udieresis + 00DD Yacute + 00DE Thorn + 00DF germandbls + 00E0 agrave + 00E1 aacute + 00E2 acircumflex + 00E3 atilde + 00E4 adieresis + 00E5 aring + 00E6 ae + 00E7 ccedilla + 00E8 egrave + 00E9 eacute + 00EA ecircumflex + 00EB edieresis + 00EC igrave + 00ED iacute + 00EE icircumflex + 00EF idieresis + 00F0 eth + 00F1 ntilde + 00F2 ograve + 00F3 oacute + 00F4 ocircumflex + 00F5 otilde + 00F6 odieresis + 00F7 divide + 00F8 oslash + 00F9 ugrave + 00FA uacute + 00FB ucircumflex + 00FC udieresis + 00FD yacute + 00FE thorn + 00FF ydieresis + 0100 Amacron + 0101 amacron + 0102 Abreve + 0103 abreve + 0104 Aogonek + 0105 aogonek + 0106 Cacute + 0107 cacute + 0108 Ccircumflex + 0109 ccircumflex + 010A Cdotaccent + 010B cdotaccent + 010C Ccaron + 010D ccaron + 010E Dcaron + 010F dcaron + 0110 Dcroat + 0111 dcroat + 0112 Emacron + 0113 emacron + 0114 Ebreve + 0115 ebreve + 0116 Edotaccent + 0117 edotaccent + 0118 Eogonek + 0119 eogonek + 011A Ecaron + 011B ecaron + 011C Gcircumflex + 011D gcircumflex + 011E Gbreve + 011F gbreve + 0120 Gdotaccent + 0121 gdotaccent + 0122 Gcommaaccent + 0123 gcommaaccent + 0124 Hcircumflex + 0125 hcircumflex + 0126 Hbar + 0127 hbar + 0128 Itilde + 0129 itilde + 012A Imacron + 012B imacron + 012C Ibreve + 012D ibreve + 012E Iogonek + 012F iogonek + 0130 Idotaccent + 0131 dotlessi + 0132 IJ + 0133 ij + 0134 Jcircumflex + 0135 jcircumflex + 0136 Kcommaaccent + 0137 kcommaaccent + 0138 kgreenlandic + 0139 Lacute + 013A lacute + 013B Lcommaaccent + 013C lcommaaccent + 013D Lcaron + 013E lcaron + 013F Ldot + 0140 ldot + 0141 Lslash + 0142 lslash + 0143 Nacute + 0144 nacute + 0145 Ncommaaccent + 0146 ncommaaccent + 0147 Ncaron + 0148 ncaron + 0149 napostrophe + 014A Eng + 014B eng + 014C Omacron + 014D omacron + 014E Obreve + 014F obreve + 0150 Ohungarumlaut + 0151 ohungarumlaut + 0152 OE + 0153 oe + 0154 Racute + 0155 racute + 0156 Rcommaaccent + 0157 rcommaaccent + 0158 Rcaron + 0159 rcaron + 015A Sacute + 015B sacute + 015C Scircumflex + 015D scircumflex + 015E Scedilla + 015F scedilla + 0160 Scaron + 0161 scaron + 0162 Tcommaaccent + 0163 tcommaaccent + 0164 Tcaron + 0165 tcaron + 0166 Tbar + 0167 tbar + 0168 Utilde + 0169 utilde + 016A Umacron + 016B umacron + 016C Ubreve + 016D ubreve + 016E Uring + 016F uring + 0170 Uhungarumlaut + 0171 uhungarumlaut + 0172 Uogonek + 0173 uogonek + 0174 Wcircumflex + 0175 wcircumflex + 0176 Ycircumflex + 0177 ycircumflex + 0178 Ydieresis + 0179 Zacute + 017A zacute + 017B Zdotaccent + 017C zdotaccent + 017D Zcaron + 017E zcaron + 017F longs + 0192 florin + 01A0 Ohorn + 01A1 ohorn + 01AF Uhorn + 01B0 uhorn + 01E6 Gcaron + 01E7 gcaron + 01FA Aringacute + 01FB aringacute + 01FC AEacute + 01FD aeacute + 01FE Oslashacute + 01FF oslashacute + 0218 Scommaaccent + 0219 scommaaccent + 021A Tcommaaccent + 021B tcommaaccent + 02BC afii57929 + 02BD afii64937 + 02C6 circumflex + 02C7 caron + 02C9 macron + 02D8 breve + 02D9 dotaccent + 02DA ring + 02DB ogonek + 02DC tilde + 02DD hungarumlaut + 0300 gravecomb + 0301 acutecomb + 0303 tildecomb + 0309 hookabovecomb + 0323 dotbelowcomb + 0384 tonos + 0385 dieresistonos + 0386 Alphatonos + 0387 anoteleia + 0388 Epsilontonos + 0389 Etatonos + 038A Iotatonos + 038C Omicrontonos + 038E Upsilontonos + 038F Omegatonos + 0390 iotadieresistonos + 0391 Alpha + 0392 Beta + 0393 Gamma + 0394 Delta + 0395 Epsilon + 0396 Zeta + 0397 Eta + 0398 Theta + 0399 Iota + 039A Kappa + 039B Lambda + 039C Mu + 039D Nu + 039E Xi + 039F Omicron + 03A0 Pi + 03A1 Rho + 03A3 Sigma + 03A4 Tau + 03A5 Upsilon + 03A6 Phi + 03A7 Chi + 03A8 Psi + 03A9 Omega + 03AA Iotadieresis + 03AB Upsilondieresis + 03AC alphatonos + 03AD epsilontonos + 03AE etatonos + 03AF iotatonos + 03B0 upsilondieresistonos + 03B1 alpha + 03B2 beta + 03B3 gamma + 03B4 delta + 03B5 epsilon + 03B6 zeta + 03B7 eta + 03B8 theta + 03B9 iota + 03BA kappa + 03BB lambda + 03BC mu + 03BD nu + 03BE xi + 03BF omicron + 03C0 pi + 03C1 rho + 03C2 sigma1 + 03C3 sigma + 03C4 tau + 03C5 upsilon + 03C6 phi + 03C7 chi + 03C8 psi + 03C9 omega + 03CA iotadieresis + 03CB upsilondieresis + 03CC omicrontonos + 03CD upsilontonos + 03CE omegatonos + 03D1 theta1 + 03D2 Upsilon1 + 03D5 phi1 + 03D6 omega1 + 0401 afii10023 + 0402 afii10051 + 0403 afii10052 + 0404 afii10053 + 0405 afii10054 + 0406 afii10055 + 0407 afii10056 + 0408 afii10057 + 0409 afii10058 + 040A afii10059 + 040B afii10060 + 040C afii10061 + 040E afii10062 + 040F afii10145 + 0410 afii10017 + 0411 afii10018 + 0412 afii10019 + 0413 afii10020 + 0414 afii10021 + 0415 afii10022 + 0416 afii10024 + 0417 afii10025 + 0418 afii10026 + 0419 afii10027 + 041A afii10028 + 041B afii10029 + 041C afii10030 + 041D afii10031 + 041E afii10032 + 041F afii10033 + 0420 afii10034 + 0421 afii10035 + 0422 afii10036 + 0423 afii10037 + 0424 afii10038 + 0425 afii10039 + 0426 afii10040 + 0427 afii10041 + 0428 afii10042 + 0429 afii10043 + 042A afii10044 + 042B afii10045 + 042C afii10046 + 042D afii10047 + 042E afii10048 + 042F afii10049 + 0430 afii10065 + 0431 afii10066 + 0432 afii10067 + 0433 afii10068 + 0434 afii10069 + 0435 afii10070 + 0436 afii10072 + 0437 afii10073 + 0438 afii10074 + 0439 afii10075 + 043A afii10076 + 043B afii10077 + 043C afii10078 + 043D afii10079 + 043E afii10080 + 043F afii10081 + 0440 afii10082 + 0441 afii10083 + 0442 afii10084 + 0443 afii10085 + 0444 afii10086 + 0445 afii10087 + 0446 afii10088 + 0447 afii10089 + 0448 afii10090 + 0449 afii10091 + 044A afii10092 + 044B afii10093 + 044C afii10094 + 044D afii10095 + 044E afii10096 + 044F afii10097 + 0451 afii10071 + 0452 afii10099 + 0453 afii10100 + 0454 afii10101 + 0455 afii10102 + 0456 afii10103 + 0457 afii10104 + 0458 afii10105 + 0459 afii10106 + 045A afii10107 + 045B afii10108 + 045C afii10109 + 045E afii10110 + 045F afii10193 + 0462 afii10146 + 0463 afii10194 + 0472 afii10147 + 0473 afii10195 + 0474 afii10148 + 0475 afii10196 + 0490 afii10050 + 0491 afii10098 + 04D9 afii10846 + 05B0 afii57799 + 05B1 afii57801 + 05B2 afii57800 + 05B3 afii57802 + 05B4 afii57793 + 05B5 afii57794 + 05B6 afii57795 + 05B7 afii57798 + 05B8 afii57797 + 05B9 afii57806 + 05BB afii57796 + 05BC afii57807 + 05BD afii57839 + 05BE afii57645 + 05BF afii57841 + 05C0 afii57842 + 05C1 afii57804 + 05C2 afii57803 + 05C3 afii57658 + 05D0 afii57664 + 05D1 afii57665 + 05D2 afii57666 + 05D3 afii57667 + 05D4 afii57668 + 05D5 afii57669 + 05D6 afii57670 + 05D7 afii57671 + 05D8 afii57672 + 05D9 afii57673 + 05DA afii57674 + 05DB afii57675 + 05DC afii57676 + 05DD afii57677 + 05DE afii57678 + 05DF afii57679 + 05E0 afii57680 + 05E1 afii57681 + 05E2 afii57682 + 05E3 afii57683 + 05E4 afii57684 + 05E5 afii57685 + 05E6 afii57686 + 05E7 afii57687 + 05E8 afii57688 + 05E9 afii57689 + 05EA afii57690 + 05F0 afii57716 + 05F1 afii57717 + 05F2 afii57718 + 060C afii57388 + 061B afii57403 + 061F afii57407 + 0621 afii57409 + 0622 afii57410 + 0623 afii57411 + 0624 afii57412 + 0625 afii57413 + 0626 afii57414 + 0627 afii57415 + 0628 afii57416 + 0629 afii57417 + 062A afii57418 + 062B afii57419 + 062C afii57420 + 062D afii57421 + 062E afii57422 + 062F afii57423 + 0630 afii57424 + 0631 afii57425 + 0632 afii57426 + 0633 afii57427 + 0634 afii57428 + 0635 afii57429 + 0636 afii57430 + 0637 afii57431 + 0638 afii57432 + 0639 afii57433 + 063A afii57434 + 0640 afii57440 + 0641 afii57441 + 0642 afii57442 + 0643 afii57443 + 0644 afii57444 + 0645 afii57445 + 0646 afii57446 + 0647 afii57470 + 0648 afii57448 + 0649 afii57449 + 064A afii57450 + 064B afii57451 + 064C afii57452 + 064D afii57453 + 064E afii57454 + 064F afii57455 + 0650 afii57456 + 0651 afii57457 + 0652 afii57458 + 0660 afii57392 + 0661 afii57393 + 0662 afii57394 + 0663 afii57395 + 0664 afii57396 + 0665 afii57397 + 0666 afii57398 + 0667 afii57399 + 0668 afii57400 + 0669 afii57401 + 066A afii57381 + 066D afii63167 + 0679 afii57511 + 067E afii57506 + 0686 afii57507 + 0688 afii57512 + 0691 afii57513 + 0698 afii57508 + 06A4 afii57505 + 06AF afii57509 + 06BA afii57514 + 06D2 afii57519 + 06D5 afii57534 + 1E80 Wgrave + 1E81 wgrave + 1E82 Wacute + 1E83 wacute + 1E84 Wdieresis + 1E85 wdieresis + 1EF2 Ygrave + 1EF3 ygrave + 200C afii61664 + 200D afii301 + 200E afii299 + 200F afii300 + 2012 figuredash + 2013 endash + 2014 emdash + 2015 afii00208 + 2017 underscoredbl + 2018 quoteleft + 2019 quoteright + 201A quotesinglbase + 201B quotereversed + 201C quotedblleft + 201D quotedblright + 201E quotedblbase + 2020 dagger + 2021 daggerdbl + 2022 bullet + 2024 onedotenleader + 2025 twodotenleader + 2026 ellipsis + 202C afii61573 + 202D afii61574 + 202E afii61575 + 2030 perthousand + 2032 minute + 2033 second + 2039 guilsinglleft + 203A guilsinglright + 203C exclamdbl + 2044 fraction + 2070 zerosuperior + 2074 foursuperior + 2075 fivesuperior + 2076 sixsuperior + 2077 sevensuperior + 2078 eightsuperior + 2079 ninesuperior + 207D parenleftsuperior + 207E parenrightsuperior + 207F nsuperior + 2080 zeroinferior + 2081 oneinferior + 2082 twoinferior + 2083 threeinferior + 2084 fourinferior + 2085 fiveinferior + 2086 sixinferior + 2087 seveninferior + 2088 eightinferior + 2089 nineinferior + 208D parenleftinferior + 208E parenrightinferior + 20A1 colonmonetary + 20A3 franc + 20A4 lira + 20A7 peseta + 20AA afii57636 + 20AB dong + 20AC Euro + 2105 afii61248 + 2111 Ifraktur + 2113 afii61289 + 2116 afii61352 + 2118 weierstrass + 211C Rfraktur + 211E prescription + 2122 trademark + 2126 Omega + 212E estimated + 2135 aleph + 2153 onethird + 2154 twothirds + 215B oneeighth + 215C threeeighths + 215D fiveeighths + 215E seveneighths + 2190 arrowleft + 2191 arrowup + 2192 arrowright + 2193 arrowdown + 2194 arrowboth + 2195 arrowupdn + 21A8 arrowupdnbse + 21B5 carriagereturn + 21D0 arrowdblleft + 21D1 arrowdblup + 21D2 arrowdblright + 21D3 arrowdbldown + 21D4 arrowdblboth + 2200 universal + 2202 partialdiff + 2203 existential + 2205 emptyset + 2206 Delta + 2207 gradient + 2208 element + 2209 notelement + 220B suchthat + 220F product + 2211 summation + 2212 minus + 2215 fraction + 2217 asteriskmath + 2219 periodcentered + 221A radical + 221D proportional + 221E infinity + 221F orthogonal + 2220 angle + 2227 logicaland + 2228 logicalor + 2229 intersection + 222A union + 222B integral + 2234 therefore + 223C similar + 2245 congruent + 2248 approxequal + 2260 notequal + 2261 equivalence + 2264 lessequal + 2265 greaterequal + 2282 propersubset + 2283 propersuperset + 2284 notsubset + 2286 reflexsubset + 2287 reflexsuperset + 2295 circleplus + 2297 circlemultiply + 22A5 perpendicular + 22C5 dotmath + 2302 house + 2310 revlogicalnot + 2320 integraltp + 2321 integralbt + 2329 angleleft + 232A angleright + 2500 SF100000 + 2502 SF110000 + 250C SF010000 + 2510 SF030000 + 2514 SF020000 + 2518 SF040000 + 251C SF080000 + 2524 SF090000 + 252C SF060000 + 2534 SF070000 + 253C SF050000 + 2550 SF430000 + 2551 SF240000 + 2552 SF510000 + 2553 SF520000 + 2554 SF390000 + 2555 SF220000 + 2556 SF210000 + 2557 SF250000 + 2558 SF500000 + 2559 SF490000 + 255A SF380000 + 255B SF280000 + 255C SF270000 + 255D SF260000 + 255E SF360000 + 255F SF370000 + 2560 SF420000 + 2561 SF190000 + 2562 SF200000 + 2563 SF230000 + 2564 SF470000 + 2565 SF480000 + 2566 SF410000 + 2567 SF450000 + 2568 SF460000 + 2569 SF400000 + 256A SF540000 + 256B SF530000 + 256C SF440000 + 2580 upblock + 2584 dnblock + 2588 block + 258C lfblock + 2590 rtblock + 2591 ltshade + 2592 shade + 2593 dkshade + 25A0 filledbox + 25A1 H22073 + 25AA H18543 + 25AB H18551 + 25AC filledrect + 25B2 triagup + 25BA triagrt + 25BC triagdn + 25C4 triaglf + 25CA lozenge + 25CB circle + 25CF H18533 + 25D8 invbullet + 25D9 invcircle + 25E6 openbullet + 263A smileface + 263B invsmileface + 263C sun + 2640 female + 2642 male + 2660 spade + 2663 club + 2665 heart + 2666 diamond + 266A musicalnote + 266B musicalnotedbl + F6BE dotlessj + F6BF LL + F6C0 ll + F6C1 Scedilla + F6C2 scedilla + F6C3 commaaccent + F6C4 afii10063 + F6C5 afii10064 + F6C6 afii10192 + F6C7 afii10831 + F6C8 afii10832 + F6C9 Acute + F6CA Caron + F6CB Dieresis + F6CC DieresisAcute + F6CD DieresisGrave + F6CE Grave + F6CF Hungarumlaut + F6D0 Macron + F6D1 cyrBreve + F6D2 cyrFlex + F6D3 dblGrave + F6D4 cyrbreve + F6D5 cyrflex + F6D6 dblgrave + F6D7 dieresisacute + F6D8 dieresisgrave + F6D9 copyrightserif + F6DA registerserif + F6DB trademarkserif + F6DC onefitted + F6DD rupiah + F6DE threequartersemdash + F6DF centinferior + F6E0 centsuperior + F6E1 commainferior + F6E2 commasuperior + F6E3 dollarinferior + F6E4 dollarsuperior + F6E5 hypheninferior + F6E6 hyphensuperior + F6E7 periodinferior + F6E8 periodsuperior + F6E9 asuperior + F6EA bsuperior + F6EB dsuperior + F6EC esuperior + F6ED isuperior + F6EE lsuperior + F6EF msuperior + F6F0 osuperior + F6F1 rsuperior + F6F2 ssuperior + F6F3 tsuperior + F6F4 Brevesmall + F6F5 Caronsmall + F6F6 Circumflexsmall + F6F7 Dotaccentsmall + F6F8 Hungarumlautsmall + F6F9 Lslashsmall + F6FA OEsmall + F6FB Ogoneksmall + F6FC Ringsmall + F6FD Scaronsmall + F6FE Tildesmall + F6FF Zcaronsmall + F721 exclamsmall + F724 dollaroldstyle + F726 ampersandsmall + F730 zerooldstyle + F731 oneoldstyle + F732 twooldstyle + F733 threeoldstyle + F734 fouroldstyle + F735 fiveoldstyle + F736 sixoldstyle + F737 sevenoldstyle + F738 eightoldstyle + F739 nineoldstyle + F73F questionsmall + F760 Gravesmall + F761 Asmall + F762 Bsmall + F763 Csmall + F764 Dsmall + F765 Esmall + F766 Fsmall + F767 Gsmall + F768 Hsmall + F769 Ismall + F76A Jsmall + F76B Ksmall + F76C Lsmall + F76D Msmall + F76E Nsmall + F76F Osmall + F770 Psmall + F771 Qsmall + F772 Rsmall + F773 Ssmall + F774 Tsmall + F775 Usmall + F776 Vsmall + F777 Wsmall + F778 Xsmall + F779 Ysmall + F77A Zsmall + F7A1 exclamdownsmall + F7A2 centoldstyle + F7A8 Dieresissmall + F7AF Macronsmall + F7B4 Acutesmall + F7B8 Cedillasmall + F7BF questiondownsmall + F7E0 Agravesmall + F7E1 Aacutesmall + F7E2 Acircumflexsmall + F7E3 Atildesmall + F7E4 Adieresissmall + F7E5 Aringsmall + F7E6 AEsmall + F7E7 Ccedillasmall + F7E8 Egravesmall + F7E9 Eacutesmall + F7EA Ecircumflexsmall + F7EB Edieresissmall + F7EC Igravesmall + F7ED Iacutesmall + F7EE Icircumflexsmall + F7EF Idieresissmall + F7F0 Ethsmall + F7F1 Ntildesmall + F7F2 Ogravesmall + F7F3 Oacutesmall + F7F4 Ocircumflexsmall + F7F5 Otildesmall + F7F6 Odieresissmall + F7F8 Oslashsmall + F7F9 Ugravesmall + F7FA Uacutesmall + F7FB Ucircumflexsmall + F7FC Udieresissmall + F7FD Yacutesmall + F7FE Thornsmall + F7FF Ydieresissmall + F8E5 radicalex + F8E6 arrowvertex + F8E7 arrowhorizex + F8E8 registersans + F8E9 copyrightsans + F8EA trademarksans + F8EB parenlefttp + F8EC parenleftex + F8ED parenleftbt + F8EE bracketlefttp + F8EF bracketleftex + F8F0 bracketleftbt + F8F1 bracelefttp + F8F2 braceleftmid + F8F3 braceleftbt + F8F4 braceex + F8F5 integralex + F8F6 parenrighttp + F8F7 parenrightex + F8F8 parenrightbt + F8F9 bracketrighttp + F8FA bracketrightex + F8FB bracketrightbt + F8FC bracerighttp + F8FD bracerightmid + F8FE bracerightbt + FB00 ff + FB01 fi + FB02 fl + FB03 ffi + FB04 ffl + FB1F afii57705 + FB2A afii57694 + FB2B afii57695 + FB35 afii57723 + FB4B afii57700 +)}; + + +sub CreatePostscriptEncoding +{ + my ($encoding) = @_; + my $result = "/CurrentEncoding \[\n"; + for (my $i = 0; $i < 256; $i += 8) + { + for (my $j = 0; $j < 8; $j++) + { + my $ch; + Tk::catch { $ch = $encoding->decode(chr($i+$j),1) }; + if ($@) + { + $result .= '/space'; + } + else + { + my $hexcode = sprintf("%04X",ord($ch)); + $result .= '/'.((exists $Tk::psglyphs->{$hexcode}) ? $Tk::psglyphs->{$hexcode} : 'space'); + } + } + $result .= "\n"; + } + $result .= "\] def\n"; + return $result; +} + +# precalculate entire prolog when this file is loaded +# (to speed things up) +$Tk::ps_preamable = "%%BeginProlog\n". + CreatePostscriptEncoding(Tk::SystemEncoding()). <<'END'; +50 dict begin +% This is a standard prolog for Postscript generated by Tk's canvas +% widget. +% RCS: @(#) $Id: //depot/Tkutf8/Canvas/Canvas.pm#12 $ + +% The definitions below just define all of the variables used in +% any of the procedures here. This is needed for obscure reasons +% explained on p. 716 of the Postscript manual (Section H.2.7, +% "Initializing Variables," in the section on Encapsulated Postscript). + +/baseline 0 def +/stipimage 0 def +/height 0 def +/justify 0 def +/lineLength 0 def +/spacing 0 def +/stipple 0 def +/strings 0 def +/xoffset 0 def +/yoffset 0 def +/tmpstip null def + + +/cstringshow { + { + dup type /stringtype eq + { show } { glyphshow } + ifelse + } + forall +} bind def + + + +/cstringwidth { + 0 exch 0 exch + { + dup type /stringtype eq + { stringwidth } { + currentfont /Encoding get exch 1 exch put (\001) stringwidth + } + ifelse + exch 3 1 roll add 3 1 roll add exch + } + forall +} bind def + +% font ISOEncode font +% This procedure changes the encoding of a font from the default +% Postscript encoding to current system encoding. It's typically invoked just +% before invoking "setfont". The body of this procedure comes from +% Section 5.6.1 of the Postscript book. + +/ISOEncode { + dup length dict begin + {1 index /FID ne {def} {pop pop} ifelse} forall + /Encoding CurrentEncoding def + currentdict + end + + % I'm not sure why it's necessary to use "definefont" on this new + % font, but it seems to be important; just use the name "Temporary" + % for the font. + + /Temporary exch definefont +} bind def + +% StrokeClip +% +% This procedure converts the current path into a clip area under +% the assumption of stroking. It's a bit tricky because some Postscript +% interpreters get errors during strokepath for dashed lines. If +% this happens then turn off dashes and try again. + +/StrokeClip { + {strokepath} stopped { + (This Postscript printer gets limitcheck overflows when) = + (stippling dashed lines; lines will be printed solid instead.) = + [] 0 setdash strokepath} if + clip +} bind def + +% desiredSize EvenPixels closestSize +% +% The procedure below is used for stippling. Given the optimal size +% of a dot in a stipple pattern in the current user coordinate system, +% compute the closest size that is an exact multiple of the device's +% pixel size. This allows stipple patterns to be displayed without +% aliasing effects. + +/EvenPixels { + % Compute exact number of device pixels per stipple dot. + dup 0 matrix currentmatrix dtransform + dup mul exch dup mul add sqrt + + % Round to an integer, make sure the number is at least 1, and compute + % user coord distance corresponding to this. + dup round dup 1 lt {pop 1} if + exch div mul +} bind def + +% width height string StippleFill -- +% +% Given a path already set up and a clipping region generated from +% it, this procedure will fill the clipping region with a stipple +% pattern. "String" contains a proper image description of the +% stipple pattern and "width" and "height" give its dimensions. Each +% stipple dot is assumed to be about one unit across in the current +% user coordinate system. This procedure trashes the graphics state. + +/StippleFill { + % The following code is needed to work around a NeWSprint bug. + + /tmpstip 1 index def + + % Change the scaling so that one user unit in user coordinates + % corresponds to the size of one stipple dot. + 1 EvenPixels dup scale + + % Compute the bounding box occupied by the path (which is now + % the clipping region), and round the lower coordinates down + % to the nearest starting point for the stipple pattern. Be + % careful about negative numbers, since the rounding works + % differently on them. + + pathbbox + 4 2 roll + 5 index div dup 0 lt {1 sub} if cvi 5 index mul 4 1 roll + 6 index div dup 0 lt {1 sub} if cvi 6 index mul 3 2 roll + + % Stack now: width height string y1 y2 x1 x2 + % Below is a doubly-nested for loop to iterate across this area + % in units of the stipple pattern size, going up columns then + % across rows, blasting out a stipple-pattern-sized rectangle at + % each position + + 6 index exch { + 2 index 5 index 3 index { + % Stack now: width height string y1 y2 x y + + gsave + 1 index exch translate + 5 index 5 index true matrix tmpstip imagemask + grestore + } for + pop + } for + pop pop pop pop pop +} bind def + +% -- AdjustColor -- +% Given a color value already set for output by the caller, adjusts +% that value to a grayscale or mono value if requested by the CL +% variable. + +/AdjustColor { + CL 2 lt { + currentgray + CL 0 eq { + .5 lt {0} {1} ifelse + } if + setgray + } if +} bind def + +% x y strings spacing xoffset yoffset justify stipple DrawText -- +% This procedure does all of the real work of drawing text. The +% color and font must already have been set by the caller, and the +% following arguments must be on the stack: +% +% x, y - Coordinates at which to draw text. +% strings - An array of strings, one for each line of the text item, +% in order from top to bottom. +% spacing - Spacing between lines. +% xoffset - Horizontal offset for text bbox relative to x and y: 0 for +% nw/w/sw anchor, -0.5 for n/center/s, and -1.0 for ne/e/se. +% yoffset - Vertical offset for text bbox relative to x and y: 0 for +% nw/n/ne anchor, +0.5 for w/center/e, and +1.0 for sw/s/se. +% justify - 0 for left justification, 0.5 for center, 1 for right justify. +% stipple - Boolean value indicating whether or not text is to be +% drawn in stippled fashion. If text is stippled, +% procedure StippleText must have been defined to call +% StippleFill in the right way. +% +% Also, when this procedure is invoked, the color and font must already +% have been set for the text. + +/DrawText { + /stipple exch def + /justify exch def + /yoffset exch def + /xoffset exch def + /spacing exch def + /strings exch def + + % First scan through all of the text to find the widest line. + + /lineLength 0 def + strings { + cstringwidth pop + dup lineLength gt {/lineLength exch def} {pop} ifelse + newpath + } forall + + % Compute the baseline offset and the actual font height. + + 0 0 moveto (TXygqPZ) false charpath + pathbbox dup /baseline exch def + exch pop exch sub /height exch def pop + newpath + + % Translate coordinates first so that the origin is at the upper-left + % corner of the text's bounding box. Remember that x and y for + % positioning are still on the stack. + + translate + lineLength xoffset mul + strings length 1 sub spacing mul height add yoffset mul translate + + % Now use the baseline and justification information to translate so + % that the origin is at the baseline and positioning point for the + % first line of text. + + justify lineLength mul baseline neg translate + + % Iterate over each of the lines to output it. For each line, + % compute its width again so it can be properly justified, then + % display it. + + strings { + dup cstringwidth pop + justify neg mul 0 moveto + stipple { + + + % The text is stippled, so turn it into a path and print + % by calling StippledText, which in turn calls StippleFill. + % Unfortunately, many Postscript interpreters will get + % overflow errors if we try to do the whole string at + % once, so do it a character at a time. + + gsave + /char (X) def + { + dup type /stringtype eq { + % This segment is a string. + { + char 0 3 -1 roll put + currentpoint + gsave + char true charpath clip StippleText + grestore + char stringwidth translate + moveto + } forall + } { + % This segment is glyph name + % Temporary override + currentfont /Encoding get exch 1 exch put + currentpoint + gsave (\001) true charpath clip StippleText + grestore + (\001) stringwidth translate + moveto + } ifelse + } forall + grestore + } {cstringshow} ifelse + 0 spacing neg translate + } forall +} bind def + +%%EndProlog +END + +1; +__END__ + diff --git a/Master/tlpkg/tlperl/lib/Tk/Checkbutton.pm b/Master/tlpkg/tlperl/lib/Tk/Checkbutton.pm new file mode 100644 index 00000000000..491d8cd2444 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Checkbutton.pm @@ -0,0 +1,42 @@ +package Tk::Checkbutton; +# Conversion from Tk4.0 button.tcl competed. +# Copyright (c) 1992-1994 The Regents of the University of California. +# Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved. +# This program is free software; you can redistribute it and/or + + +use vars qw($VERSION); +$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Checkbutton.pm#6 $ + +# modify it under the same terms as Perl itself, subject +# to additional disclaimer in license.terms due to partial +# derivation from Tk4.0 sources. + +require Tk::Widget; +require Tk::Button; + +use base qw(Tk::Button); + +Construct Tk::Widget 'Checkbutton'; + +sub Tk_cmd { \&Tk::checkbutton } + + +sub ClassInit +{ + my ($class,$mw) = @_; + $mw->bind($class,'<Enter>', 'Enter'); + $mw->bind($class,'<Leave>', 'Leave'); + $mw->bind($class,'<1>', 'Invoke'); + $mw->bind($class,'<space>', 'Invoke'); + return $class; +} + +sub Invoke +{ + my $w = shift; + $w->invoke() unless($w->cget('-state') eq 'disabled'); +} + +1; diff --git a/Master/tlpkg/tlperl/lib/Tk/Clipboard.pm b/Master/tlpkg/tlperl/lib/Tk/Clipboard.pm new file mode 100644 index 00000000000..b0eb0ea2b07 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Clipboard.pm @@ -0,0 +1,122 @@ +# Copyright (c) 1995-2003 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. +package Tk::Clipboard; +use strict; + +use vars qw($VERSION); +$VERSION = sprintf '4.%03d', q$Revision: #8 $ =~ /\D(\d+)\s*$/; + +use AutoLoader qw(AUTOLOAD); +use Tk qw(catch); + +sub clipEvents +{ + return qw[Copy Cut Paste]; +} + +sub ClassInit +{ + my ($class,$mw) = @_; + foreach my $op ($class->clipEvents) + { + $mw->Tk::bind($class,"<<$op>>","clipboard$op"); + } + return $class; +} + +sub clipboardSet +{ + my $w = shift; + $w->clipboardClear; + $w->clipboardAppend(@_); +} + +sub clipboardCopy +{ + my $w = shift; + my $val = $w->getSelected; + if (defined $val) + { + $w->clipboardSet('--',$val); + } + return $val; +} + +sub clipboardCut +{ + my $w = shift; + my $val = $w->clipboardCopy; + if (defined $val) + { + $w->deleteSelected; + } + return $val; +} + +sub clipboardGet +{ + my $w = shift; + $w->SelectionGet('-selection','CLIPBOARD',@_); +} + +sub clipboardPaste +{ + my $w = shift; + local $@; + catch + { +## Different from Tcl/Tk version: +# if ($w->windowingsystem eq 'x11') +# { +# catch +# { +# $w->deleteSelected; +# }; +# } + $w->insert("insert", $w->clipboardGet); + $w->SeeInsert if $w->can('SeeInsert'); + }; +} + +sub clipboardOperations +{ + my @class = (); + my $mw = shift; + if (ref $mw) + { + $mw = $mw->DelegateFor('bind'); + } + else + { + push(@class,$mw); + $mw = shift; + } + while (@_) + { + my $op = shift; + $mw->Tk::bind(@class,"<<$op>>","clipboard$op"); + } +} + +# These methods work for Entry and Text +# and can be overridden where they don't work + +sub deleteSelected +{ + my $w = shift; + catch { $w->delete('sel.first','sel.last') }; +} + + +1; +__END__ + +sub getSelected +{ + my $w = shift; + my $val = Tk::catch { $w->get('sel.first','sel.last') }; + return $val; +} + + diff --git a/Master/tlpkg/tlperl/lib/Tk/CmdLine.pm b/Master/tlpkg/tlperl/lib/Tk/CmdLine.pm new file mode 100644 index 00000000000..2e821e826ae --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/CmdLine.pm @@ -0,0 +1,954 @@ +package Tk::CmdLine; # -*-Perl-*- + +#/----------------------------------------------------------------------------// +#/ Module: Tk/CmdLine.pm +#/ +#/ Purpose: +#/ +#/ Process standard X11 command line options and set initial resources. +#/ +#/ Author: ???? Date: ???? +#/ +#/ History: SEE POD +#/----------------------------------------------------------------------------// + +use vars qw($VERSION); +$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/CmdLine.pm#6 $ + +use 5.004; + +use strict; + +use Config; + +my $OBJECT = undef; # define the current object + +#/----------------------------------------------------------------------------// +#/ Constructor +#/ Returns the object reference. +#/----------------------------------------------------------------------------// + +sub new # Tk::CmdLine::new() +{ + my $this = shift(@_); + my $class = ref($this) || $this; + + my $name = 'pTk'; + $name = $1 if (($0 =~ m/(?:^|[\/\\])([\w-]+)(?:\.\w+)?$/) && ($1 ne '-e')); + + my $self = { + name => $name, + config => { -name => $name }, + options => {}, + methods => {}, + command => [], + synchronous => 0, + iconic => 0, + motif => ($Tk::strictMotif || 0), + resources => {} }; + + return bless($self, $class); +} + +#/----------------------------------------------------------------------------// +#/ Process the arguments in a given array or in @ARGV. +#/ Returns the object reference. +#/----------------------------------------------------------------------------// + +sub Argument_ # Tk::CmdLine::Argument_($flag) # private method +{ + my $self = shift(@_); + my $flag = shift(@_); + unless ($self->{offset} < @{$self->{argv}}) + { + die 'Usage: ', $self->{name}, ' ... ', $flag, " <argument> ...\n"; + } + return splice(@{$self->{argv}}, $self->{offset}, 1); +} + +sub Config_ # Tk::CmdLine::Config_($flag, $name) # private method +{ + my $self = shift(@_); + my ($flag, $name) = @_; + my $val = $self->Argument_($flag); + push(@{$self->{command}}, $flag, $val); + $self->{config}->{"-$name"} = $val; +} + +sub Flag_ # Tk::CmdLine::Flag_($flag, $name) # private method +{ + my $self = shift(@_); + my ($flag, $name) = @_; + push(@{$self->{command}}, $flag); + $self->{$name} = 1; +} + +sub Option_ # Tk::CmdLine::Option_($flag, $name) # private method +{ + my $self = shift(@_); + my ($flag, $name) = @_; + my $val = $self->Argument_($flag); + push(@{$self->{command}}, $flag, $val); + $self->{options}->{"*$name"} = $val; +} + +sub Method_ # Tk::CmdLine::Method_($flag, $name) # private method +{ + my $self = shift(@_); + my ($flag, $name) = @_; + my $val = $self->Argument_($flag); + push(@{$self->{command}}, $flag, $val); + $self->{methods}->{$name} = $val; +} + +sub Resource_ # Tk::CmdLine::Resource_($flag, $name) # private method +{ + my $self = shift(@_); + my ($flag, $name) = @_; + my $val = $self->Argument_($flag); + if ($val =~ /^([^!:\s]+)*\s*:\s*(.*)$/) + { + push(@{$self->{command}}, $flag, $val); + $self->{options}->{$1} = $2; + } +} + +my %Method = ( + background => 'Option_', + bg => 'background', # alias + class => 'Config_', + display => 'screen', # alias + fg => 'foreground', # alias + fn => 'font', # alias + font => 'Option_', + foreground => 'Option_', + geometry => 'Method_', + iconic => 'Flag_', + iconposition => 'Method_', + motif => 'Flag_', + name => 'Config_', + screen => 'Config_', + synchronous => 'Flag_', + title => 'Config_', + xrm => 'Resource_' +); + +sub SetArguments # Tk::CmdLine::SetArguments([@argument]) +{ + my $self = (@_ # define the object as necessary + ? ((ref($_[0]) eq __PACKAGE__) + ? shift(@_) + : (($_[0] eq __PACKAGE__) ? shift(@_) : 1) && ($OBJECT ||= __PACKAGE__->new())) + : ($OBJECT ||= __PACKAGE__->new())); + $OBJECT = $self; # update the current object + $self->{argv} = (@_ ? [ @_ ] : \@ARGV); + $self->{offset} = 0; # its existence will denote that this method has been called + + my @option = (); + + while ($self->{offset} < @{$self->{argv}}) + { + last if ($self->{argv}->[$self->{offset}] eq '--'); + unless ( + (($self->{argv}->[$self->{offset}] =~ /^-{1,2}(\w+)$/) && (@option = $1)) || + (($self->{argv}->[$self->{offset}] =~ /^--(\w+)=(.*)$/) && (@option = ($1, $2)))) + { + ++$self->{offset}; + next; + } + + next if (!exists($Method{$option[0]}) && ++$self->{offset}); + + $option[0] = $Method{$option[0]} if exists($Method{$Method{$option[0]}}); + + my $method = $Method{$option[0]}; + + if (@option > 1) # replace --<option>=<value> with <value> + { + $self->{argv}->[$self->{offset}] = $option[1]; + } + else # remove the argument + { + splice(@{$self->{argv}}, $self->{offset}, 1); + } + + $self->$method(('-' . $option[0]), $option[0]); + } + + $self->{config}->{-class} ||= ucfirst($self->{config}->{-name}); + + delete($self->{argv}); # no longer needed + + return $self; +} + +use vars qw(&process); *process = \&SetArguments; # alias to keep old code happy + +#/----------------------------------------------------------------------------// +#/ Get a list of the arguments that have been processed by SetArguments(). +#/ Returns an array. +#/----------------------------------------------------------------------------// + +sub GetArguments # Tk::CmdLine::GetArguments() +{ + my $self = (@_ # define the object as necessary + ? ((ref($_[0]) eq __PACKAGE__) + ? shift(@_) + : (($_[0] eq __PACKAGE__) ? shift(@_) : 1) && ($OBJECT ||= __PACKAGE__->new())) + : ($OBJECT ||= __PACKAGE__->new())); + $OBJECT = $self; # update the current object + + $self->SetArguments() unless exists($self->{offset}); # set arguments if not yet done + + return @{$self->{command}}; +} + +#/----------------------------------------------------------------------------// +#/ Get the value of a configuration option (default: -class). +#/ Returns the option value. +#/----------------------------------------------------------------------------// + +sub cget # Tk::CmdLine::cget([$option]) +{ + my $self = (@_ # define the object as necessary + ? ((ref($_[0]) eq __PACKAGE__) + ? shift(@_) + : (($_[0] eq __PACKAGE__) ? shift(@_) : 1) && ($OBJECT ||= __PACKAGE__->new())) + : ($OBJECT ||= __PACKAGE__->new())); + $OBJECT = $self; # update the current object + my $option = shift(@_) || '-class'; + + $self->SetArguments() unless exists($self->{offset}); # set arguments if not yet done + + return (exists($self->{config}->{$option}) ? $self->{config}->{$option} : undef); +} + +#/----------------------------------------------------------------------------// + +sub CreateArgs # Tk::CmdLine::CreateArgs() +{ + my $self = (@_ # define the object as necessary + ? ((ref($_[0]) eq __PACKAGE__) + ? shift(@_) + : (($_[0] eq __PACKAGE__) ? shift(@_) : 1) && ($OBJECT ||= __PACKAGE__->new())) + : ($OBJECT ||= __PACKAGE__->new())); + $OBJECT = $self; # update the current object + + $self->SetArguments() unless exists($self->{offset}); # set arguments if not yet done + + return $self->{config}; +} + +#/----------------------------------------------------------------------------// + +sub Tk::MainWindow::apply_command_line +{ + my $mw = shift(@_); + + my $self = ($OBJECT ||= __PACKAGE__->new()); + + $self->SetArguments() unless exists($self->{offset}); # set arguments if not yet done + + foreach my $priority (keys(%{$self->{resources}})) + { + foreach my $resource (@{$self->{resources}->{$priority}}) + { + $mw->optionAdd(@{$resource}, $priority); + } + } + + foreach my $key (keys(%{$self->{options}})) + { + $mw->optionAdd($key => $self->{options}->{$key}, 'interactive'); + } + + foreach my $key (keys(%{$self->{methods}})) + { + $mw->$key($self->{methods}->{$key}); + } + + if ($self->{methods}->{geometry}) + { + if ($self->{methods}->{geometry} =~ /[+-]\d+[+-]\d+/) + { + $mw->positionfrom('user'); + } + if ($self->{methods}->{geometry} =~ /\d+x\d+/) + { + $mw->sizefrom('user'); + } + delete $self->{methods}->{geometry}; # XXX needed? + } + + $mw->Synchronize() if $self->{synchronous}; + + if ($self->{iconic}) + { + $mw->iconify(); + $self->{iconic} = 0; + } + + $Tk::strictMotif = ($self->{motif} || 0); + + # Both these are needed to reliably save state + # but 'hostname' is tricky to do portably. + # $mw->client(hostname()); + $mw->protocol('WM_SAVE_YOURSELF' => ['WMSaveYourself',$mw]); + $mw->command([ $self->{name}, @{$self->{command}} ]); +} + +#/----------------------------------------------------------------------------// +#/ Set the initial resources. +#/ Returns the object reference. +#/----------------------------------------------------------------------------// + +sub SetResources # Tk::CmdLine::SetResources((\@resource | $resource) [, $priority]) +{ + my $self = (@_ # define the object as necessary + ? ((ref($_[0]) eq __PACKAGE__) + ? shift(@_) + : (($_[0] eq __PACKAGE__) ? shift(@_) : 1) && ($OBJECT ||= __PACKAGE__->new())) + : ($OBJECT ||= __PACKAGE__->new())); + $OBJECT = $self; # update the current object + + $self->SetArguments() unless exists($self->{offset}); # set arguments if not yet done + return $self unless @_; + + my $data = shift(@_); + my $priority = shift(@_) || 'userDefault'; + + $self->{resources}->{$priority} = [] unless exists($self->{resources}->{$priority}); + + foreach my $resource ((ref($data) eq 'ARRAY') ? @{$data} : $data) + { + if (ref($resource) eq 'ARRAY') # resources in [ <pattern>, <value> ] format + { + push(@{$self->{resources}->{$priority}}, [ @{$resource} ]) + if (@{$resource} == 2); + } + else # resources in resource file format + { + push(@{$self->{resources}->{$priority}}, [ $1, $2 ]) + if ($resource =~ /^([^!:\s]+)*\s*:\s*(.*)$/); + } + } + + return $self; +} + +#/----------------------------------------------------------------------------// +#/ Load initial resources from one or more files (default: $XFILESEARCHPATH with +#/ priority 'startupFile' and $XUSERFILESEARCHPATH with priority 'userDefault'). +#/ Returns the object reference. +#/----------------------------------------------------------------------------// + +sub LoadResources # Tk::CmdLine::LoadResources([%options]) +{ + my $self = (@_ # define the object as necessary + ? ((ref($_[0]) eq __PACKAGE__) + ? shift(@_) + : (($_[0] eq __PACKAGE__) ? shift(@_) : 1) && ($OBJECT ||= __PACKAGE__->new())) + : ($OBJECT ||= __PACKAGE__->new())); + $OBJECT = $self; # update the current object + + $self->SetArguments() unless exists($self->{offset}); # set arguments if not yet done + + my %options = @_; + + my @file = (); + my $echo = (exists($options{-echo}) + ? (defined($options{-echo}) ? $options{-echo} : \*STDOUT) : undef); + + unless (%options && (exists($options{-file}) || exists($options{-symbol}))) + { + @file = ( + { -symbol => 'XFILESEARCHPATH', -priority => 'startupFile' }, + { -symbol => 'XUSERFILESEARCHPATH', -priority => 'userDefault' } ); + } + else + { + @file = { %options }; + } + + my $delimiter = (($^O eq 'MSWin32') ? ';' : ':'); + + foreach my $file (@file) + { + my $fileSpec = $file->{-spec} = undef; + if (exists($file->{-symbol})) + { + my $xpath = undef; + if ($file->{-symbol} eq 'XUSERFILESEARCHPATH') + { + $file->{-priority} ||= 'userDefault'; + foreach my $symbol (qw(XUSERFILESEARCHPATH XAPPLRESDIR HOME)) + { + last if (exists($ENV{$symbol}) && ($xpath = $ENV{$symbol})); + } + next unless defined($xpath); + } + else + { + $file->{-priority} ||= (($file->{-symbol} eq 'XFILESEARCHPATH') + ? 'startupFile' : 'userDefault'); + next unless ( + exists($ENV{$file->{-symbol}}) && ($xpath = $ENV{$file->{-symbol}})); + } + + unless (exists($self->{translation})) + { + $self->{translation} = { + '%l' => '', # ignored + '%C' => '', # ignored + '%S' => '', # ignored + '%L' => ($ENV{LANG} || 'C'), # language + '%T' => 'app-defaults', # type + '%N' => $self->{config}->{-class} # filename + }; + } + + my @postfix = map({ $_ . '/' . $self->{config}->{-class} } + ('/' . $self->{translation}->{'%L'}), ''); + + ITEM: foreach $fileSpec (split($Config{path_sep}, $xpath)) + { + if ($fileSpec =~ s/(%[A-Za-z])/$self->{translation}->{$1}/g) # File Pattern + { + if (defined($echo) && ($file->{-symbol} ne 'XFILESEARCHPATH')) + { + print $echo 'Checking ', $fileSpec, "\n"; + } + next unless ((-f $fileSpec) && (-r _) && (-s _)); + $file->{-spec} = $fileSpec; + last; + } + else # Directory - Check for <Directory>/$LANG/<Class>, <Directory>/<CLASS> + { + foreach my $postfix (@postfix) + { + my $fileSpec2 = $fileSpec . $postfix; + if (defined($echo) && ($file->{-symbol} ne 'XFILESEARCHPATH')) + { + print $echo 'Checking ', $fileSpec2, "\n"; + } + next unless ((-f $fileSpec2) && (-r _) && (-s _)); + $file->{-spec} = $fileSpec2; + last ITEM; + } + } + } + } + elsif (exists($file->{-file}) && ($fileSpec = $file->{-file})) + { + print $echo 'Checking ', $fileSpec, "\n" if defined($echo); + next unless ((-f $fileSpec) && (-r _) && (-s _)); + $file->{-spec} = $fileSpec; + } + } + + foreach my $file (@file) + { + next unless defined($file->{-spec}); + local *SPEC; + next unless open(SPEC,$file->{-spec}); + print $echo ' Loading ', $file->{-spec}, "\n" if defined($echo); + + my $resource = undef; + my @resource = (); + my $continuation = 0; + + while (defined(my $line = <SPEC>)) + { + chomp($line); + next if ($line =~ /^\s*$/); # skip blank lines + next if ($line =~ /^\s*!/); # skip comments + $continuation = ($line =~ s/\s*\\$/ /); # search for trailing backslash + unless (defined($resource)) # it is the first line + { + $resource = $line; + } + else # it is a continuation line + { + $line =~ s/^\s*//; # remove leading whitespace + $resource .= $line; + } + next if $continuation; + push(@resource, [ $1, $2 ]) if ($resource =~ /^([^:\s]+)*\s*:\s*(.*)$/); + $resource = undef; + } + + close(SPEC); + + if (defined($resource)) # special case - EOF after line with trailing backslash + { + push(@resource, [ $1, $2 ]) if ($resource =~ /^([^:\s]+)*\s*:\s*(.*)$/); + } + + $self->SetResources(\@resource, $file->{-priority}) if @resource; + } + + return $self; +} + +#/----------------------------------------------------------------------------// + +1; + +__END__ + +=cut + +=head1 NAME + +Tk::CmdLine - Process standard X11 command line options and set initial resources + +=for pm Tk/CmdLine.pm + +=for category Creating and Configuring Widgets + +=head1 SYNOPSIS + + Tk::CmdLine::SetArguments([@argument]); + + my $value = Tk::CmdLine::cget([$option]); + + Tk::CmdLine::SetResources((\@resource | $resource) [, $priority]); + + Tk::CmdLine::LoadResources( + [ -symbol => $symbol ] + [ -file => $fileSpec ] + [ -priority => $priority ] + [ -echo => $fileHandle ] ); + +=head1 DESCRIPTION + +Process standard X11 command line options and set initial resources. + +The X11R5 man page for X11 says: "Most X programs attempt to use the same names +for command line options and arguments. All applications written with the +X Toolkit Intrinsics automatically accept the following options: ...". +This module processes these command line options for perl/Tk applications +using the C<SetArguments>() function. + +This module can optionally be used to load initial resources explicitly via +function C<SetResources>(), or from specified files (default: the standard X11 +application-specific resource files) via function C<LoadResources>(). + +=head2 Command Line Options + +=over 4 + +=item B<-background> I<Color> | B<-bg> I<Color> + +Specifies the color to be used for the window background. + +=item B<-class> I<Class> + +Specifies the class under which resources for the application should be found. +This option is useful in shell aliases to distinguish between invocations +of an application, without resorting to creating links to alter the executable +file name. + +=item B<-display> I<Display> | B<-screen> I<Display> + +Specifies the name of the X server to be used. + +=item B<-font> I<Font> | B<-fn> I<Font> + +Specifies the font to be used for displaying text. + +=item B<-foreground> I<Color> | B<-fg> I<Color> + +Specifies the color to be used for text or graphics. + +=item B<-geometry> I<Geometry> + +Specifies the initial size and location of the I<first> +L<MainWindow|Tk::MainWindow>. + +=item B<-iconic> + +Indicates that the user would prefer that the application's windows initially +not be visible as if the windows had been immediately iconified by the user. +Window managers may choose not to honor the application's request. + +=item B<-motif> + +Specifies that the application should adhere as closely as possible to Motif +look-and-feel standards. For example, active elements such as buttons and +scrollbar sliders will not change color when the pointer passes over them. + +=item B<-name> I<Name> + +Specifies the name under which resources for the application should be found. +This option is useful in shell aliases to distinguish between invocations +of an application, without resorting to creating links to alter the executable +file name. + +=item B<-synchronous> + +Indicates that requests to the X server should be sent synchronously, instead of +asynchronously. Since Xlib normally buffers requests to the server, errors do +do not necessarily get reported immediately after they occur. This option turns +off the buffering so that the application can be debugged. It should never +be used with a working program. + +=item B<-title> I<TitleString> + +This option specifies the title to be used for this window. This information is +sometimes used by a window manager to provide some sort of header identifying +the window. + +=item B<-xrm> I<ResourceString> + +Specifies a resource pattern and value to override any defaults. It is also +very useful for setting resources that do not have explicit command line +arguments. + +The I<ResourceString> is of the form E<lt>I<pattern>E<gt>:E<lt>I<value>E<gt>, +that is (the first) ':' is used to determine which part is pattern and which +part is value. The (E<lt>I<pattern>E<gt>, E<lt>I<value>E<gt>) pair is entered +into the options database with B<optionAdd> (for each +L<MainWindow|Tk::MainWindow> configured), with I<interactive> priority. + +=back + +=head2 Initial Resources + +There are several mechanism for initializing the resource database to be used +by an X11 application. Resources may be defined in a $C<HOME>/.Xdefaults file, +a system application defaults file (e.g. +/usr/lib/X11/app-defaults/E<lt>B<CLASS>E<gt>), +or a user application defaults file (e.g. $C<HOME>/E<lt>B<CLASS>E<gt>). +The Tk::CmdLine functionality for setting initial resources concerns itself +with the latter two. + +Resource files contain data lines of the form +E<lt>I<pattern>E<gt>:E<lt>I<value>E<gt>. +They may also contain blank lines and comment lines (denoted +by a ! character as the first non-blank character). Refer to L<option|Tk::option> +for a description of E<lt>I<pattern>E<gt>:E<lt>I<value>E<gt>. + +=over 4 + +=item System Application Defaults Files + +System application defaults files may be specified via environment variable +$C<XFILESEARCHPATH> which, if set, contains a list of file patterns +(joined using the OS-dependent path delimiter, e.g. colon on B<UNIX>). + +=item User Application Defaults Files + +User application defaults files may be specified via environment variables +$C<XUSERFILESEARCHPATH>, $C<XAPPLRESDIR> or $C<HOME>. + +=back + +=head1 METHODS + +=over 4 + +=item B<SetArguments> - Tk::CmdLine::SetArguments([@argument]) + +Extract the X11 options contained in a specified array (@ARGV by default). + + Tk::CmdLine::SetArguments([@argument]) + +The X11 options may be specified using a single dash I<-> as per the X11 +convention, or using two dashes I<--> as per the POSIX standard (e.g. +B<-geometry> I<100x100>, B<-geometry> I<100x100> or B<-geometry=>I<100x100>). +The options may be interspersed with other options or arguments. +A I<--> by itself terminates option processing. + +By default, command line options are extracted from @ARGV the first time +a MainWindow is created. The Tk::MainWindow constructor indirectly invokes +C<SetArguments>() to do this. + +=item B<GetArguments> - Tk::CmdLine::GetArguments() + +Get a list of the X11 options that have been processed by C<SetArguments>(). +(C<GetArguments>() first invokes C<SetArguments>() if it has not already been invoked.) + +=item B<cget> - Tk::CmdLine::cget([$option]) + +Get the value of a configuration option specified via C<SetArguments>(). +(C<cget>() first invokes C<SetArguments>() if it has not already been invoked.) + + Tk::CmdLine::cget([$option]) + +The valid options are: B<-class>, B<-name>, B<-screen> and B<-title>. +If no option is specified, B<-class> is implied. + +A typical use of C<cget>() might be to obtain the application class in order +to define the name of a resource file to be loaded in via C<LoadResources>(). + + my $class = Tk::CmdLine::cget(); # process command line and return class + +=item B<SetResources> - Tk::CmdLine::SetResources((\@resource | $resource) [, $priority]) + +Set the initial resources. + + Tk::CmdLine::SetResources((\@resource | $resource) [, $priority]) + +A single resource may be specified using a string of the form +'E<lt>I<pattern>E<gt>:E<lt>I<value>E<gt>'. Multiple resources may be specified +by passing an array reference whose elements are either strings of the above +form, and/or anonymous arrays of the form [ E<lt>I<pattern>E<gt>, +E<lt>I<value>E<gt> ]. The optional second argument specifies the priority, +as defined in L<option|Tk::option>, to be associated with the resources +(default: I<userDefault>). + +Note that C<SetResources>() first invokes C<SetArguments>() if it has not already +been invoked. + +=item B<LoadResources> - Tk::CmdLine::LoadResources([%options]) + +Load initial resources from one or more files. + + Tk::CmdLine::LoadResources( + [ -symbol => $symbol ] + [ -file => $fileSpec ] + [ -priority => $priority ] + [ -echo => $fileHandle ] ); + +[ B<-symbol> =E<gt> $symbol ] specifies the name of an environment variable +that, if set, defines a list of one or more directories and/or file patterns +(joined using the OS-dependent path delimiter, e.g. colon on B<UNIX>). +$C<XUSERFILESEARCHPATH> is a special case. +If $C<XUSERFILESEARCHPATH> is not set, $C<XAPPLRESDIR> is checked instead. +If $C<XAPPLRESDIR> is not set, $C<HOME> is checked instead. + +An item is identified as a file pattern if it contains one or more /%[A-Za-z]/ +patterns. Only patterns B<%L>, B<%T> and B<%N> are currently recognized. All +others are replaced with the null string. Pattern B<%L> is translated into +$C<LANG>. Pattern B<%T> is translated into I<app-defaults>. Pattern B<%N> is +translated into the application class name. + +Each file pattern, after substitutions are applied, is assumed to define a +FileSpec to be examined. + +When a directory is specified, FileSpecs +E<lt>B<DIRECTORY>E<gt>/E<lt>B<LANG>E<gt>/E<lt>B<CLASS>E<gt> +and E<lt>B<DIRECTORY>E<gt>/E<lt>B<CLASS>E<gt> are defined, in that order. + +[ B<-file> =E<gt> $fileSpec ] specifies a resource file to be loaded in. +The file is silently skipped if if does not exist, or if it is not readable. + +[ B<-priority> =E<gt> $priority ] specifies the priority, as defined in +L<option|Tk::option>, to be associated with the resources +(default: I<userDefault>). + +[ B<-echo> =E<gt> $fileHandle ] may be used to specify that a line should be +printed to the corresponding FileHandle (default: \*STDOUT) everytime a file +is examined / loaded. + +If no B<-symbol> or B<-file> options are specified, C<LoadResources>() +processes symbol $C<XFILESEARCHPATH> with priority I<startupFile> and +$C<XUSERFILESEARCHPATH> with priority I<userDefault>. +(Note that $C<XFILESEARCHPATH> and $C<XUSERFILESEARCHPATH> are supposed to +contain only patterns. $C<XAPPLRESDIR> and $C<HOME> are supposed to be a single +directory. C<LoadResources>() does not check/care whether this is the case.) + +For each set of FileSpecs, C<LoadResources>() examines each FileSpec to +determine if the file exists and is readable. The first file that meets this +criteria is read in and C<SetResources>() is invoked. + +Note that C<LoadResources>() first invokes C<SetArguments>() if it has not already +been invoked. + +=back + +=head1 NOTES + +This module is an object-oriented module whose methods can be invoked as object +methods, class methods or regular functions. This is accomplished via an +internally-maintained object reference which is created as necessary, and which +always points to the last object used. C<SetArguments>(), C<SetResources>() and +C<LoadResources>() return the object reference. + +=head1 EXAMPLES + +=over + +=item 1 + +@ARGV is processed by Tk::CmdLine at MainWindow creation. + + use Tk; + + # <Process @ARGV - ignoring all X11-specific options> + + my $mw = MainWindow->new(); + + MainLoop(); + +=item 2 + +@ARGV is processed by Tk::CmdLine before MainWindow creation. +An @ARGV of (--geometry=100x100 -opt1 a b c -bg red) +is equal to (-opt1 a b c) after C<SetArguments>() is invoked. + + use Tk; + + Tk::CmdLine::SetArguments(); # Tk::CmdLine->SetArguments() works too + + # <Process @ARGV - not worrying about X11-specific options> + + my $mw = MainWindow->new(); + + MainLoop(); + +=item 3 + +Just like 2) except that default arguments are loaded first. + + use Tk; + + Tk::CmdLine::SetArguments(qw(-name test -iconic)); + Tk::CmdLine::SetArguments(); + + # <Process @ARGV - not worrying about X11-specific options> + + my $mw = MainWindow->new(); + + MainLoop(); + +=item 4 + +@ARGV is processed by Tk::CmdLine before MainWindow creation. +Standard resource files are loaded in before MainWindow creation. + + use Tk; + + Tk::CmdLine::SetArguments(); + + # <Process @ARGV - not worrying about X11-specific options> + + Tk::CmdLine::LoadResources(); + + my $mw = MainWindow->new(); + + MainLoop(); + +=item 5 + +@ARGV is processed by Tk::CmdLine before MainWindow creation. +Standard resource files are loaded in before MainWindow creation +using non-default priorities. + + use Tk; + + Tk::CmdLine::SetArguments(); + + # <Process @ARGV - not worrying about X11-specific options> + + Tk::CmdLine::LoadResources(-echo => \*STDOUT, + -priority => 65, -symbol => 'XFILESEARCHPATH' ); + Tk::CmdLine::LoadResources(-echo => \*STDOUT, + -priority => 75, -symbol => 'XUSERFILESEARCHPATH' ); + + my $mw = MainWindow->new(); + + MainLoop(); + +=item 6 + +@ARGV is processed by Tk::CmdLine before MainWindow creation. +Standard resource files are loaded in before MainWindow creation. +Individual resources are also loaded in before MainWindow creation. + + use Tk; + + Tk::CmdLine::SetArguments(); + + # <Process @ARGV - not worrying about X11-specific options> + + Tk::CmdLine::LoadResources(); + + Tk::CmdLine::SetResources( # set a single resource + '*Button*background: red', + 'widgetDefault' ); + + Tk::CmdLine::SetResources( # set multiple resources + [ '*Button*background: red', '*Button*foreground: blue' ], + 'widgetDefault' ); + + my $mw = MainWindow->new(); + + MainLoop(); + +=back + +=head1 ENVIRONMENT + +=over 4 + +=item B<HOME> (optional) + +Home directory which may contain user application defaults files as +$C<HOME>/$C<LANG>/E<lt>B<CLASS>E<gt> or $C<HOME>/E<lt>B<CLASS>E<gt>. + +=item B<LANG> (optional) + +The current language (default: I<C>). + +=item B<XFILESEARCHPATH> (optional) + +List of FileSpec patterns +(joined using the OS-dependent path delimiter, e.g. colon on B<UNIX>) +used in defining system application defaults files. + +=item B<XUSERFILESEARCHPATH> (optional) + +List of FileSpec patterns +(joined using the OS-dependent path delimiter, e.g. colon on B<UNIX>) +used in defining user application defaults files. + +=item B<XAPPLRESDIR> (optional) + +Directory containing user application defaults files as +$C<XAPPLRESDIR>/$C<LANG>/E<lt>B<CLASS>E<gt> or +$C<XAPPLRESDIR>/E<lt>B<CLASS>E<gt>. + +=back + +=head1 SEE ALSO + +L<MainWindow|Tk::MainWindow> +L<option|Tk::option> + +=head1 HISTORY + +=over 4 + +=item * + +1999.03.04 Ben Pavon E<lt>ben.pavon@hsc.hac.comE<gt> + +Rewritten as an object-oriented module. + +Allow one to process command line options in a specified array (@ARGV by default). +Eliminate restrictions on the format and location of the options within the array +(previously the X11 options could not be specified in POSIX format and had to be +at the beginning of the array). + +Added the C<SetResources>() and C<LoadResources>() functions to allow the definition +of resources prior to MainWindow creation. + +=item * + +2000.08.31 Ben Pavon E<lt>ben.pavon@hsc.hac.comE<gt> + +Added the C<GetArguments>() method which returns the list of arguments that +have been processed by C<SetArguments>(). + +Modified C<LoadResources>() to split the symbols using the OS-dependent +path delimiter defined in the B<Config> module. + +Modified C<LoadResources>() to eliminate a warning message when processing +patterns B<%l>, B<%C>, B<%S>. + +=back + +=cut + diff --git a/Master/tlpkg/tlperl/lib/Tk/ColorEdit.xpm b/Master/tlpkg/tlperl/lib/Tk/ColorEdit.xpm new file mode 100644 index 00000000000..ef3474cd869 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/ColorEdit.xpm @@ -0,0 +1,58 @@ +/* XPM */ +static char * ColorEditor_xpm[] = { +"48 48 6 1", +" c #0000FFFF0000", +". c #FFFFFFFF0000", +"X c #FFFF00000000", +"o c #000000000000", +"O c #0000FFFFFFFF", +"+ c #00000000FFFF", +" . . ......X..XXXXXXXXXXXXXXXX", +" . .X.X. X...XX.XXXXXXXXXXX", +" . . . ... ...XXXXXXXXXXXXXX", +" . . .. .....XX.XXXXXXXXXXXX", +" . .X.X...XXX..XXXXXXXXXXXX", +" .. . ....X...X.XXXXXXXXX", +" .. ..X.. . ..X..XXXXXXXX", +" .... ..X.X..X.XXXXXXX", +" ... .X. X...X...XX.XXX", +" . .. ... XX...XXXX..XXXX", +" ooo o ooo. . .. .X...X..X.XXXXX", +" oo oo oo. . . . .......X.X.XX", +" oo o oo . . .. ........XX.XXXX", +" oo ooo oo ooo Xooo.oo..... X XX.X", +" oo o oo oo o oo ooo o.. . X...X X", +" oo oo oo oo oo oo .oo . X.X.....XX ", +"O oo o oo oo oo oo oo oo. ... X..... .", +"O O oo oo oo o oo ooo o. oo . ... .X..X", +"O OOOooooO ooo ooo ooo oo ... ....... X ", +" O OOO . . .. ... ..", +"OOO OOOO OO O . .... . . .. .", +" + O O O O .. .. . .", +" O OOO OO . .. .... ", +"OOOOO O OO . .. . ... ", +"+OOOO OOOO OO O ... .. ..", +" O+OO OO O . ", +"OOOOOOOOoooooooOOOO ooo oo .... ", +"OO++ OOO ooO OoOO oo oo oo .. ", +"+OOOOOOOOooOOOo O O oo oo .", +"++OOO +oo+oOO O oo oo ooo ooooo ooo ooo oo. ", +"+OO O OOoooooO O o ooo oo oo o oo ooo o ", +"++++ O OooOOoO Ooo Ooo oo oo oo oo oo ", +"+++OOOO ooOOOoOOooOOooO oo oo oo oo oo ", +"++++++ Ooo OOoOOooOooo ooo ooo o oo o oo ", +"+++O+++oooooooOOOooOoooOooo ooo Oooo oo ", +"++++++++O++OOOO O OOOOOOO ", +"++O++++O+O+OOOOOOO O O OOOOOO O ", +"+++O+++OOO+OO OOOO O OO O O O ", +"++++++++O++O OO OO OO OOO OO O O ", +"+++++++++++++ OOOOOO OOOO OO OO ", +"+++++++++++++O+ +O OOOO OOO OOO OOO ", +"++++++++++++++ OOOOO O OOOOOOOOOO ", +"+++++++++++++ ++ OO +O OOOOO O O O ", +"+++++++++++++++O+++O+O+O OOOOOOOOOO O ", +"+++++++++++++O++++O++ O OOO O OOO OO ", +"++++++++++++++++O+++O+O+OOOO OOOO O OO ", +"+++++++++++++++++++O+++ +++O OOOOOO OO O ", +"++++++++++++++++++++++ +++ O OOOOOOOOO "}; + diff --git a/Master/tlpkg/tlperl/lib/Tk/ColorEditor.pm b/Master/tlpkg/tlperl/lib/Tk/ColorEditor.pm new file mode 100644 index 00000000000..e84b0077410 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/ColorEditor.pm @@ -0,0 +1,761 @@ +package Tk::ColorSelect; +use strict; + +use vars qw($VERSION); +$VERSION = sprintf '4.%03d', q$Revision: #8 $ =~ /\D(\d+)\s*$/; + +use Tk qw(Ev); + +require Tk::Frame; + +use base qw(Tk::Frame); +Construct Tk::Widget 'ColorSelect'; + +sub Populate +{ + my ($middle,$args) = @_; + my($i, @a); + require Tk::Config; + my(@xlibpath) = map { s/^-L//; "$_/X11/rgb.txt" } + split /\s+/, $Tk::Config::xlib; + foreach $i (@xlibpath, + '/usr/local/lib/X11/rgb.txt', '/usr/lib/X11/rgb.txt', + '/usr/X11R6/lib/X11/rgb.txt', + '/usr/local/X11R5/lib/X11/rgb.txt', '/X11/R5/lib/X11/rgb.txt', + '/X11/R4/lib/rgb/rgb.txt', '/usr/openwin/lib/X11/rgb.txt') { + local *FOO; + next if ! open FOO, $i; + my $middle_left = $middle->Frame; + $middle_left->pack( + -side => 'left', + -padx => '0.25c', + -pady => '0.25c', + ); + my $names = $middle->Listbox( + -width => 20, + -height => 12, + -relief => 'sunken', + -borderwidth => 2, + -exportselection => 0, + ); + + $names->bind('<Double-1>' => [$middle,'color',Ev(['getSelected'])]); + + my $scroll = $middle->Scrollbar( + -orient => 'vertical', + -command => ['yview', $names], + -relief => 'sunken', + -borderwidth => 2, + ); + $names->configure(-yscrollcommand => ['set',$scroll]); + $names->pack(-in => $middle_left, -side => 'left'); + $scroll->pack(-in => $middle_left, -side => 'right', -fill => 'y'); + + while(<FOO>) { + chomp; + next if /^!/; + my @a = split; + my $color = join(' ', @a[3 .. $#a]); + my $hex; + eval { $hex = $middle->Hex($color); }; + if ($@) { + #print STDERR "unknown color: '$color'\n"; + if ($@ =~ /unknown color name "/) { + next; + } else { + chomp $@; + die $@; + } + } + if (!exists($Tk::ColorEditor::names{$hex}) || + length($Tk::ColorEditor::names{$hex}) > length($color)) { + $Tk::ColorEditor::names{$hex} = $color; + $names->insert('end', $color); + } + } + close FOO; + last; + } + + # Create the three scales for editing the color, and the entry for typing + # in a color value. + + my $middle_middle = $middle->Frame; + $middle_middle->pack(-side => 'left', -expand => 1, -fill => 'y'); + my $mcm1 = $middle_middle->Optionmenu(-variable => \$middle->{'color_space'}, + -command => [ $middle, 'color_space'], + -relief => 'raised', + -options => [ ['HSB color space' => 'hsb'], + ['RGB color space' => 'rgb'], + ['CMY color space' => 'cmy']]); + $mcm1->pack(-side => 'top', -fill => 'x'); + + my(@middle_middle, @label, @scale); + $middle_middle[0] = $middle_middle->Frame; + $middle_middle[1] = $middle_middle->Frame; + $middle_middle[2] = $middle_middle->Frame; + $middle_middle[3] = $middle_middle->Frame; + $middle_middle[0]->pack(-side => 'top', -expand => 1); + $middle_middle[1]->pack(-side => 'top', -expand => 1); + $middle_middle[2]->pack(-side => 'top', -expand => 1); + $middle_middle[3]->pack(-side => 'top', -expand => 1, -fill => 'x'); + $middle->{'Labels'} = ['zero','one','two']; + foreach $i (0..2) { + $label[$i] = $middle->Label(-textvariable => \$middle->{'Labels'}[$i]); + $scale[$i] = $middle->Scale( + -from => 0, + -to => 1000, + '-length' => '6c', + -orient => 'horizontal', + -command => [\&scale_changed, $middle], + ); + $scale[$i]->pack( + -in => $middle_middle[$i], + -side => 'top', + -anchor => 'w', + ); + $label[$i]->pack( + -in => $middle_middle[$i], + -side => 'top', + -anchor => 'w', + ); + } + my $nameLabel = $middle->Label(-text => 'Name:'); + $middle->{'Entry'} = ''; + my $name = $middle->Entry( + -relief => 'sunken', + -borderwidth => 2, + -textvariable => \$middle->{'Entry'}, + -width => 10, +# For some reason giving this font causes problems at end of t/create.t +# -font => '-*-Courier-Medium-R-Normal--*-120-*-*-*-*-*-*' + ); + + $nameLabel->pack(-in => $middle_middle[3], -side => 'left'); + $name->pack( + -in => $middle_middle[3], + -side => 'right', + -expand => 1, + -fill => 'x', + ); + $name->bind('<Return>' => [ $middle, 'color', Ev(['get'])]); + + # Create the color display swatch on the right side of the window. + + my $middle_right = $middle->Frame; + $middle_right->pack( + -side => 'left', + -pady => '.25c', + -padx => '.25c', + -anchor => 's', + ); + my $swatch = $middle->Canvas( + -width => '2.5c', + -height => '5c', + ); + my $swatch_item = $swatch->create('oval', '.5c', '.3c', '2.26c', '4.76c'); + + my $value = $middle->Label( + -textvariable => \$middle->{'color'}, + -width => 13, + -font => '-*-Courier-Medium-R-Normal--*-120-*-*-*-*-*-*' + ); + + $swatch->pack( + -in => $middle_right, + -side => 'top', + -expand => 1, + -fill => 'both', + ); + $value->pack(-in => $middle_right, -side => 'bottom', -pady => '.25c'); + + $middle->ConfigSpecs( + '-color_space' => ['METHOD', undef, undef, 'hsb'], + '-initialcolor' => '-color', + '-color' => ['METHOD', 'background', 'Background', + $middle->cget('-background')] + ); + + $middle->{'swatch'} = $swatch; + $middle->{'swatch_item'} = $swatch_item; + $middle->{'scale'} = [@scale]; + $middle->{'red'} = 0; + $middle->{'blue'} = 0; + $middle->{'green'} = 0; + +} + +sub Hex +{ + my $w = shift; + my @rgb = (@_ == 3) ? @_ : $w->rgb(@_); + sprintf('#%04x%04x%04x',@rgb) +} + +sub color_space { + + my($objref, $space) = @_; + + if (@_ > 1) + { + my %Labels = ( 'rgb' => [qw(Red Green Blue)], + 'cmy' => [qw(Cyan Magenta Yellow)], + 'hsb' => [qw(Hue Saturation Brightness)] ); + + # The procedure below is invoked when a new color space is selected. It + # changes the labels on the scales and re-loads the scales with the + # appropriate values for the current color in the new color space + + $space = 'hsb' unless (exists $Labels{$space}); + my $i; + for $i (0..2) + { + $objref->{'Labels'}[$i] = $Labels{$space}->[$i]; + } + $objref->{'color_space'} = $space; + $objref->afterIdle(['set_scales',$objref]) unless ($objref->{'pending'}++); + } + return $objref->{'color_space'}; +} # color_space + +sub hsvToRgb { + + # The procedure below converts an HSB value to RGB. It takes hue, + # saturation, and value components (floating-point, 0-1.0) as arguments, + # and returns a list containing RGB components (integers, 0-65535) as + # result. The code here is a copy of the code on page 616 of + # "Fundamentals of Interactive Computer Graphics" by Foley and Van Dam. + + my($hue, $sat, $value) = @_; + my($v, $i, $f, $p, $q, $t); + + $v = int(65535 * $value); + return ($v, $v, $v) if $sat == 0; + $hue *= 6; + $hue = 0 if $hue >= 6; + $i = int($hue); + $f = $hue - $i; + $p = int(65535 * $value * (1 - $sat)); + $q = int(65535 * $value * (1 - ($sat * $f))); + $t = int(65535 * $value * (1 - ($sat * (1 - $f)))); + return ($v, $t, $p) if $i == 0; + return ($q, $v, $p) if $i == 1; + return ($p, $v, $t) if $i == 2; + return ($p, $q, $v) if $i == 3; + return ($t, $p, $v) if $i == 4; + return ($v, $p, $q) if $i == 5; + +} # end hsvToRgb + +sub color +{ + my ($objref,$name) = @_; + if (@_ > 1 && defined($name) && length($name)) + { + if ($name eq 'cancel') { + $objref->{color} = undef; + return; + } + my ($format, $shift); + my ($red, $green, $blue); + + if ($name !~ /^#/) + { + ($red, $green, $blue) = $objref->{'swatch'}->rgb($name); + } + else + { + my $len = length $name; + if($len == 4) { $format = '#(.)(.)(.)'; $shift = 12; } + elsif($len == 7) { $format = '#(..)(..)(..)'; $shift = 8; } + elsif($len == 10) { $format = '#(...)(...)(...)'; $shift = 4; } + elsif($len == 13) { $format = '#(....)(....)(....)'; $shift = 0; } + else { + $objref->BackTrace( + "ColorEditor error: syntax error in color name \"$name\""); + return; + } + ($red,$green,$blue) = $name =~ /$format/; + # Looks like a call for 'pack' or similar rather than eval + eval "\$red = 0x$red; \$green = 0x$green; \$blue = 0x$blue;"; + $red = $red << $shift; + $green = $green << $shift; + $blue = $blue << $shift; + } + $objref->{'red'} = $red; + $objref->{'blue'} = $blue; + $objref->{'green'} = $green; + my $hex = sprintf('#%04x%04x%04x', $red, $green, $blue); + $objref->{'color'} = $hex; + $objref->{'Entry'} = $name; + $objref->afterIdle(['set_scales',$objref]) unless ($objref->{'pending'}++); + $objref->{'swatch'}->itemconfigure($objref->{'swatch_item'}, + -fill => $objref->{'color'}); + } + return $objref->{'color'}; +} + +sub rgbToHsv { + + # The procedure below converts an RGB value to HSB. It takes red, green, + # and blue components (0-65535) as arguments, and returns a list + # containing HSB components (floating-point, 0-1) as result. The code + # here is a copy of the code on page 615 of "Fundamentals of Interactive + # Computer Graphics" by Foley and Van Dam. + + my($red, $green, $blue) = @_; + my($max, $min, $sat, $range, $hue, $rc, $gc, $bc); + + $max = ($red > $green) ? (($blue > $red) ? $blue : $red) : + (($blue > $green) ? $blue : $green); + $min = ($red < $green) ? (($blue < $red) ? $blue : $red) : + (($blue < $green) ? $blue : $green); + $range = $max - $min; + if ($max == 0) { + $sat = 0; + } else { + $sat = $range / $max; + } + if ($sat == 0) { + $hue = 0; + } else { + $rc = ($max - $red) / $range; + $gc = ($max - $green) / $range; + $bc = ($max - $blue) / $range; + $hue = ($max == $red)?(0.166667*($bc - $gc)): + (($max == $green)?(0.166667*(2 + $rc - $bc)): + (0.166667*(4 + $gc - $rc))); + } + $hue += 1 if $hue < 0; + return ($hue, $sat, $max/65535); + +} # end rgbToHsv + +sub scale_changed { + + # The procedure below is invoked when one of the scales is adjusted. It + # propagates color information from the current scale readings to + # everywhere else that it is used. + + my($objref) = @_; + + return if $objref->{'updating'}; + my ($red, $green, $blue); + + if($objref->{'color_space'} eq 'rgb') { + $red = int($objref->{'scale'}->[0]->get * 65.535 + 0.5); + $green = int($objref->{'scale'}->[1]->get * 65.535 + 0.5); + $blue = int($objref->{'scale'}->[2]->get * 65.535 + 0.5); + } elsif($objref->{'color_space'} eq 'cmy') { + $red = int(65535 - $objref->{'scale'}->[0]->get * 65.535 + 0.5); + $green = int(65535 - $objref->{'scale'}->[1]->get * 65.535 + 0.5); + $blue = int(65535 - $objref->{'scale'}->[2]->get * 65.535 + 0.5); + } else { + ($red, $green, $blue) = hsvToRgb($objref->{'scale'}->[0]->get/1000.0, + $objref->{'scale'}->[1]->get/1000.0, + $objref->{'scale'}->[2]->get/1000.0); + } + $objref->{'red'} = $red; + $objref->{'blue'} = $blue; + $objref->{'green'} = $green; + $objref->color(sprintf('#%04x%04x%04x', $red, $green, $blue)); + $objref->idletasks; + +} # end scale_changed + +sub set_scales { + + my($objref) = @_; + $objref->{'pending'} = 0; + $objref->{'updating'} = 1; + + # The procedure below is invoked to update the scales from the current red, + # green, and blue intensities. It's invoked after a change in the color + # space and after a named color value has been loaded. + + my($red, $blue, $green) = ($objref->{'red'}, $objref->{'blue'}, + $objref->{'green'}); + + if($objref->{'color_space'} eq 'rgb') { + $objref->{'scale'}->[0]->set(int($red / 65.535 + 0.5)); + $objref->{'scale'}->[1]->set(int($green / 65.535 + 0.5)); + $objref->{'scale'}->[2]->set(int($blue / 65.535 + 0.5)); + } elsif($objref->{'color_space'} eq 'cmy') { + $objref->{'scale'}->[0]->set(int((65535 - $red) / 65.535 + 0.5)); + $objref->{'scale'}->[1]->set(int((65535 - $green) / 65.535 + 0.5)); + $objref->{'scale'}->[2]->set(int((65535 - $blue) / 65.535 + 0.5)); + } else { + my ($s1, $s2, $s3) = rgbToHsv($red, $green, $blue); + $objref->{'scale'}->[0]->set(int($s1 * 1000.0 + 0.5)); + $objref->{'scale'}->[1]->set(int($s2 * 1000.0 + 0.5)); + $objref->{'scale'}->[2]->set(int($s3 * 1000.0 + 0.5)); + } + $objref->{'updating'} = 0; + +} # end set_scales + +package Tk::ColorDialog; +require Tk::Toplevel; +use base qw(Tk::Toplevel); + +Construct Tk::Widget 'ColorDialog'; + +sub Accept +{ + my $cw = shift; + $cw->withdraw; + $cw->{'done'} = 1; +} + +sub Cancel +{ + my $cw = shift; +# $cw->configure(-color => undef); + $cw->configure(-color => 'cancel'); + $cw->Accept; +} + +sub Populate +{ + my ($cw,$args) = @_; + $cw->SUPER::Populate($args); + $cw->protocol('WM_DELETE_WINDOW' => [ 'Cancel' => $cw ]); + $cw->transient($cw->Parent->toplevel); + $cw->withdraw; + my $sel = $cw->ColorSelect; + my $accept = $cw->Button(-text => 'Accept', -command => ['Accept', $cw]); + my $cancel = $cw->Button(-text => 'Cancel', -command => ['Cancel', $cw]); + Tk::grid($sel); + Tk::grid($accept,$cancel); + $cw->ConfigSpecs(DEFAULT => [$sel]); +} + +sub Show +{ + my $cw = shift; + $cw->configure(@_) if @_; + $cw->Popup(); + $cw->waitVariable(\$cw->{'done'}); + $cw->withdraw; + return $cw->cget('-color'); +} + +package Tk::ColorEditor; + +use vars qw($VERSION $SET_PALETTE); +$VERSION = sprintf '4.%03d', q$Revision: #8 $ =~ /\D(\d+)\s*$/; + +use Tk qw(lsearch Ev); +use Tk::Toplevel; +use base qw(Tk::Toplevel); +use Tk::widgets qw(Pixmap); +Construct Tk::Widget 'ColorEditor'; + +%Tk::ColorEditor::names = (); + + +use Tk::Dialog; +use Tk::Pretty; + +BEGIN { $SET_PALETTE = 'Set Palette' }; + +use subs qw(color_space hsvToRgb rgbToHsv); + +# ColorEditor public methods. + +sub add_menu_item +{ + my $objref = shift; + my $value; + foreach $value (@_) + { + if ($value eq 'SEP') + { + $objref->{'mcm2'}->separator; + } + else + { + $objref->{'mcm2'}->command( -label => $value, + -command => [ 'configure', $objref, '-highlight' => $value ] ); + push @{$objref->{'highlight_list'}}, $value; + } + } +} + +sub set_title +{ + my ($w) = @_; + my $t = $w->{Configure}{'-title'} || '' ; + my $h = $w->{Configure}{'-highlight'} || ''; + $w->SUPER::title("$t $h Color Editor"); +} + +sub highlight +{ + my ($w,$h) = @_; + if (@_ > 1) + { + $w->{'update'}->configure( -text => "Apply $h Color" ); + my $state = ($h eq 'background') ? 'normal' : 'disabled'; + $w->{'palette'}->entryconfigure( $SET_PALETTE, -state => $state); + $w->{'highlight'} = $h; + $w->configure(-color => $w->Palette->{$h}); + $w->set_title; + } + return $w->{'highlight'}; +} + +sub title +{ + my ($w,$val) = @_; + $w->set_title if (@_ > 1); + return $w->{Configure}{'-title'}; +} + +sub delete_menu_item +{ + my $objref = shift; + my $value; + foreach $value (@_) + { + $objref->{'mcm2'}->delete($value); + my $list_ord = $value =~ /\d+/ ? $value : lsearch($objref->{'highlight_list'}, $value); + splice(@{$objref->{'highlight_list'}}, $list_ord, 1) if $list_ord != -1; + } +} + +sub delete_widgets { + + # Remove widgets from consideration by the color configurator. + # $widgets_ref points to widgets previously added via `configure'. + + my($objref, $widgets_ref) = @_; + + my($i, $found, $r1, $r2, @wl) = (0, 0, 0, 0, @{$objref->cget(-widgets)}); + foreach $r1 (@{$widgets_ref}) { + $i = -1; + $found = 0; + foreach $r2 (@wl) { + $i++; + next if $r1 != $r2; + $found = 1; + last; + } + splice(@wl, $i, 1) if $found; + } + $objref->configure(-widgets => [@wl]); + +} # end delete_widgets + +sub ApplyDefault +{ + my($objref) = @_; + my $cb = $objref->cget('-command'); + my $h; + foreach $h (@{$objref->{'highlight_list'}}) + { + next if $h =~ /TEAR_SEP|SEP/; + $cb->Call($h); + die unless (defined $cb); + } +} + +sub Populate +{ + + # ColorEditor constructor. + + my($cw, $args) = @_; + + $cw->SUPER::Populate($args); + $cw->withdraw; + + my $color_space = 'hsb'; # rgb, cmy, hsb + my(@highlight_list) = qw( + TEAR_SEP + foreground background SEP + activeForeground activeBackground SEP + highlightColor highlightBackground SEP + selectForeground selectBackground SEP + disabledForeground insertBackground selectColor troughColor + ); + + # Create the Usage Dialog; + + my $usage = $cw->Dialog( '-title' => 'ColorEditor Usage', + -justify => 'left', + -wraplength => '6i', + -text => "The Colors menu allows you to:\n\nSelect a color attribute such as \"background\" that you wish to colorize. Click on \"Apply\" to update that single color attribute.\n\nSelect one of three color spaces. All color spaces display a color value as a hexadecimal number under the oval color swatch that can be directly supplied on widget commands.\n\nApply Tk's default color scheme to the application. Useful if you've made a mess of things and want to start over!\n\nChange the application's color palette. Make sure \"background\" is selected as the color attribute, find a pleasing background color to apply to all current and future application widgets, then select \"Set Palette\".", + ); + + # Create the menu bar at the top of the window for the File, Colors + # and Help menubuttons. + + my $m0 = $cw->Frame(-relief => 'raised', -borderwidth => 2); + $m0->pack(-side => 'top', -fill => 'x'); + my $mf = $m0->Menubutton( + -text => 'File', + -underline => 0, + -bd => 1, + -relief => 'raised', + ); + $mf->pack(-side => 'left'); + my $close_command = [sub {shift->withdraw}, $cw]; + $mf->command( + -label => 'Close', + -underline => 0, + -command => $close_command, + -accelerator => 'Ctrl-w', + ); + $cw->bind('<Control-Key-w>' => $close_command); + $cw->protocol(WM_DELETE_WINDOW => $close_command); + + my $mc = $m0->Menubutton( + -text => 'Colors', + -underline => 0, + -bd => 1, + -relief => 'raised', + ); + $mc->pack(-side => 'left'); + my $color_attributes = 'Color Attributes'; + $mc->cascade(-label => $color_attributes, -underline => 6); + $mc->separator; + + $mc->command( + -label => 'Apply Default Colors', + -underline => 6, + -command => ['ApplyDefault',$cw] + ); + $mc->separator; + $mc->command( + -label => $SET_PALETTE, + -underline => 0, + -command => sub { $cw->setPalette($cw->cget('-color'))} + ); + + my $m1 = $mc->cget(-menu); + + my $mcm2 = $m1->Menu; + $m1->entryconfigure($color_attributes, -menu => $mcm2); + my $mh = $m0->Menubutton( + -text => 'Help', + -underline => 0, + -bd => 1, + -relief => 'raised', + ); + $mh->pack(-side => 'right'); + $mh->command( + -label => 'Usage', + -underline => 0, + -command => [sub {shift->Show}, $usage], + ); + + # Create the Apply button. + + my $bot = $cw->Frame(-relief => 'raised', -bd => 2); + $bot->pack(-side => 'bottom', -fill =>'x'); + my $update = $bot->Button( + -command => [ + sub { + my ($objref) = @_; + $objref->Callback(-command => ($objref->{'highlight'}, $objref->cget('-color'))); + $cw->{'done'} = 1; + }, $cw, + ], + ); + $update->pack(-pady => 1, -padx => '0.25c'); + + # Create the listbox that holds all of the color names in rgb.txt, if an + # rgb.txt file can be found. + + my $middle = $cw->ColorSelect(-relief => 'raised', -borderwidth => 2); + $middle->pack(-side => 'top', -fill => 'both'); + # Create the status window. + + my $status = $cw->Toplevel; + $status->withdraw; + $status->geometry('+0+0'); + my $status_l = $status->Label(-width => 50, -anchor => 'w'); + $status_l->pack(-side => 'top'); + + $cw->{'highlight_list'} = [@highlight_list]; + $cw->{'mcm2'} = $mcm2; + + foreach (@highlight_list) + { + next if /^TEAR_SEP$/; + $cw->add_menu_item($_); + } + + $cw->{'updating'} = 0; + $cw->{'pending'} = 0; + $cw->{'Status'} = $status; + $cw->{'Status_l'} = $status_l; + $cw->{'update'} = $update; + $cw->{'gwt_depth'} = 0; + $cw->{'palette'} = $mc; + + my $pixmap = $cw->Pixmap('-file' => Tk->findINC('ColorEdit.xpm')); + $cw->Icon(-image => $pixmap); + + $cw->ConfigSpecs( + DEFAULT => [$middle], + -widgets => ['PASSIVE', undef, undef, + [$cw->parent->Descendants]], + -display_status => ['PASSIVE', undef, undef, 0], + '-title' => ['METHOD', undef, undef, ''], + -command => ['CALLBACK', undef, undef, ['set_colors',$cw]], + '-highlight' => ['METHOD', undef, undef, 'background'], + -cursor => ['DESCENDANTS', 'cursor', 'Cursor', 'left_ptr'], + ); + +} # end Populate, ColorEditor constructor + +sub Show { + + my($objref, @args) = @_; + + Tk::ColorDialog::Show(@_); + +} # end show + +# ColorEditor default configurator procedure - can be redefined by the +# application. + +sub set_colors { + + # Configure all the widgets in $widgets for attribute $type and color + # $color. If $color is undef then reset all colors + # to the Tk defaults. + + my($objref, $type, $color) = @_; + my $display = $objref->cget('-display_status'); + + $objref->{'Status'}->title("Configure $type"); + $objref->{'Status'}->deiconify if $display; + my $widget; + my $reset = !defined($color); + + foreach $widget (@{$objref->cget('-widgets')}) { + if ($display) { + $objref->{'Status_l'}->configure( + -text => 'WIDGET: ' . $widget->PathName + ); + $objref->update; + } + eval {local $SIG{'__DIE__'}; $color = ($widget->configure("-\L${type}"))[3]} if $reset; + eval {local $SIG{'__DIE__'}; $widget->configure("-\L${type}" => $color)}; + } + + $objref->{'Status'}->withdraw if $display; + +} # end set_colors + +# ColorEditor private methods. + +1; + +__END__ + +=cut + diff --git a/Master/tlpkg/tlperl/lib/Tk/Compound.pm b/Master/tlpkg/tlperl/lib/Tk/Compound.pm new file mode 100644 index 00000000000..9f1ccd64487 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Compound.pm @@ -0,0 +1,40 @@ +package Tk::Compound; +require Tk; +import Tk qw($XS_VERSION); +require Tk::Image; + +use vars qw($VERSION); +$VERSION = '4.004'; # $Id: //depot/Tkutf8/Compound/Compound.pm#4 $ + +use base qw(Tk::Image); + +Construct Tk::Image 'Compound'; + +bootstrap Tk::Compound; + +sub Tk_image { 'compound' } + +Tk::Methods('add'); + +sub new +{ + my $package = shift; + my $widget = shift; + my $leaf = $package->Tk_image; + $package->InitClass($widget); + my $obj = $widget->image(create => $leaf,@_,-window => $widget); + return bless($obj,$package); +} + +BEGIN + { + foreach my $type (qw(line text image bitmap space)) + { + my $meth = ucfirst($type); + no strict qw 'refs'; + *{$meth} = sub { shift->add($type,@_) }; + } + } + +1; +__END__ diff --git a/Master/tlpkg/tlperl/lib/Tk/Config.pm b/Master/tlpkg/tlperl/lib/Tk/Config.pm new file mode 100644 index 00000000000..8346d9ede9a --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Config.pm @@ -0,0 +1,12 @@ +package Tk::Config; +require Exporter; +use base qw(Exporter); +$VERSION = '804.027'; +$inc = '-I$(TKDIR)/pTk/mTk/xlib'; +$define = ''; +$xlib = ''; +$xinc = ''; +$gccopt = ' -Wall -Wno-implicit-int -Wno-comment -Wno-unused -D__USE_FIXED_PROTOTYPES__'; +$win_arch = 'MSWin32'; +@EXPORT = qw($VERSION $inc $define $xlib $xinc $gccopt $win_arch); +1; diff --git a/Master/tlpkg/tlperl/lib/Tk/Configure.pm b/Master/tlpkg/tlperl/lib/Tk/Configure.pm new file mode 100644 index 00000000000..26252ae4958 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Configure.pm @@ -0,0 +1,69 @@ +package Tk::Configure; +use vars qw($VERSION); +$VERSION = '4.008'; # $Id: //depot/Tkutf8/Tk/Configure.pm#8 $ + +use Carp; +use Tk::Pretty; + + +# Class that handles cget/configure for options that +# need translating from public form +# e.g. $cw->configure(-label => 'fred') +# into $cw->subwiget('label')->configure(-text => 'fred') +# Should probably do something clever with regexp's here + + +sub new +{ + my ($class,@args) = @_; + unshift(@args,'configure','cget') if (@args < 3); + return bless \@args,$class; +} + +sub cget +{ + croak('Wrong number of args to cget') unless (@_ == 2); + my ($alias,$key) = @_; + my ($set,$get,$widget,@args) = @$alias; + $widget->$get(@args); +} + +sub configure +{ + my $alias = shift; + shift if (@_); + my ($set,$get,$widget,@args) = @$alias; + if (wantarray) + { + my @results; + eval { @results = $widget->$set(@args,@_) }; + croak($@) if $@; + return @results; + } + else + { + my $results; + eval { $results = $widget->$set(@args,@_) }; + croak($@) if $@; + return $results; + } +} + +*TIESCALAR = \&new; +*TIEHASH = \&new; + +sub FETCH +{ + my $alias = shift; + my ($set,$get,$widget,@args) = @$alias; + return $widget->$get(@args,@_); +} + +sub STORE +{ + my $alias = shift; + my ($set,$get,$widget,@args) = @$alias; + $widget->$set(@args,@_); +} + +1; diff --git a/Master/tlpkg/tlperl/lib/Tk/Credits b/Master/tlpkg/tlperl/lib/Tk/Credits new file mode 100644 index 00000000000..3ea9be43b7d --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Credits @@ -0,0 +1,7 @@ +The two Camel/X 'logo' GIFs were produced by : + +Grafix, Sussex, UK, +44-1293-886725 + +For a very reasonable fee. We have rights to distribute them. + + diff --git a/Master/tlpkg/tlperl/lib/Tk/Derived.pm b/Master/tlpkg/tlperl/lib/Tk/Derived.pm new file mode 100644 index 00000000000..c31c205d2fb --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Derived.pm @@ -0,0 +1,512 @@ +# Copyright (c) 1995-2003 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. +package Tk::Derived; +require Tk::Widget; +require Tk::Configure; +use strict; +use Carp; + +use vars qw($VERSION); +$VERSION = sprintf '4.%03d', q$Revision: #10 $ =~ /\D(\d+)\s*$/; + +$Tk::Derived::Debug = 0; + +my $ENHANCED_CONFIGSPECS = 0; # disable for now + +use Tk qw(NORMAL_BG BLACK); + +sub Subwidget +{ + my $cw = shift; + my @result = (); + if (exists $cw->{SubWidget}) + { + if (@_) + { + foreach my $name (@_) + { + push(@result,$cw->{SubWidget}{$name}) if (exists $cw->{SubWidget}{$name}); + } + } + else + { + @result = values %{$cw->{SubWidget}}; + } + } + return (wantarray) ? @result : $result[0]; +} + +sub _makelist +{ + my $widget = shift; + my (@specs) = (ref $widget && ref $widget eq 'ARRAY') ? (@$widget) : ($widget); + return @specs; +} + +sub Subconfigure +{ + # This finds the widget or widgets to to which to apply a particular + # configure option + my ($cw,$opt) = @_; + my $config = $cw->ConfigSpecs; + my $widget; + my @subwidget = (); + my @arg = (); + if (defined $opt) + { + $widget = $config->{$opt}; + unless (defined $widget) + { + $widget = ($opt =~ /^-(.*)$/) ? $config->{$1} : $config->{-$opt}; + } + # Handle alias entries + if (defined($widget) && !ref($widget)) + { + $opt = $widget; + $widget = $config->{$widget}; + } + push(@arg,$opt) unless ($opt eq 'DEFAULT'); + } + $widget = $config->{DEFAULT} unless (defined $widget); + if (defined $widget) + { + $cw->BackTrace("Invalid ConfigSpecs $widget") unless (ref($widget) && (ref $widget eq 'ARRAY')); + $widget = $widget->[0]; + } + else + { + $widget = 'SELF'; + } + foreach $widget (_makelist($widget)) + { + $widget = 'SELF' if (ref($widget) && $widget == $cw); + if (ref $widget) + { + my $ref = ref $widget; + if ($ref eq 'ARRAY') + { + $widget = Tk::Configure->new(@$widget); + push(@subwidget,$widget) + } + elsif ($ref eq 'HASH') + { + foreach my $key (%$widget) + { + foreach my $sw (_makelist($widget->{$key})) + { + push(@subwidget,Tk::Configure->new($sw,$key)); + } + } + } + else + { + push(@subwidget,$widget) + } + } + elsif ($widget eq 'ADVERTISED') + { + push(@subwidget,$cw->Subwidget) + } + elsif ($widget eq 'DESCENDANTS') + { + push(@subwidget,$cw->Descendants) + } + elsif ($widget eq 'CHILDREN') + { + push(@subwidget,$cw->children) + } + elsif ($widget eq 'METHOD') + { + my ($method) = ($opt =~ /^-?(.*)$/); + push(@subwidget,Tk::Configure->new($method,$method,$cw)) + } + elsif ($widget eq 'SETMETHOD') + { + my ($method) = ($opt =~ /^-?(.*)$/); + push(@subwidget,Tk::Configure->new($method,'_cget',$cw,@arg)) + } + elsif ($widget eq 'SELF') + { + push(@subwidget,Tk::Configure->new('Tk::configure', 'Tk::cget', $cw,@arg)) + } + elsif ($widget eq 'PASSIVE') + { + push(@subwidget,Tk::Configure->new('_configure','_cget',$cw,@arg)) + } + elsif ($widget eq 'CALLBACK') + { + push(@subwidget,Tk::Configure->new('_callback','_cget',$cw,@arg)) + } + else + { + push(@subwidget,$cw->Subwidget($widget)); + } + } + $cw->BackTrace("No delegate subwidget '$widget' for $opt") unless (@subwidget); + return (wantarray) ? @subwidget : $subwidget[0]; +} + +sub _cget +{ + my ($cw,$opt) = @_; + $cw->BackTrace('Wrong number of args to cget') unless (@_ == 2); + return $cw->{Configure}{$opt} +} + +sub _configure +{ + my ($cw,$opt,$val) = @_; + $cw->BackTrace('Wrong number of args to configure') unless (@_ == 3); + $cw->{Configure}{$opt} = $val; +} + +sub _callback +{ + my ($cw,$opt,$val) = @_; + $cw->BackTrace('Wrong number of args to configure') unless (@_ == 3); + $val = Tk::Callback->new($val) if defined($val) && ref($val); + $cw->{Configure}{$opt} = $val; +} + +sub cget +{my ($cw,$opt) = @_; + my @result; + local $SIG{'__DIE__'}; + foreach my $sw ($cw->Subconfigure($opt)) + { + if (wantarray) + { + eval { @result = $sw->cget($opt) }; + } + else + { + eval { $result[0] = $sw->cget($opt) }; + } + last unless $@; + } + return wantarray ? @result : $result[0]; +} + +sub Configured +{ + # Called whenever a derived widget is re-configured + my ($cw,$args,$changed) = @_; + if (@_ > 1) + { + $cw->afterIdle(['ConfigChanged',$cw,$changed]) if (%$changed); + } + return exists $cw->{'Configure'}; +} + +sub configure +{ + # The default composite widget configuration method uses hash stored + # in the widget's hash to map configuration options + # onto subwidgets. + # + my @results = (); + my $cw = shift; + if (@_ <= 1) + { + # Enquiry cases + my $spec = $cw->ConfigSpecs; + if (@_) + { + # Return info on the nominated option + my $opt = $_[0]; + my $info = $spec->{$opt}; + unless (defined $info) + { + $info = ($opt =~ /^-(.*)$/) ? $spec->{$1} : $spec->{-$opt}; + } + if (defined $info) + { + if (ref $info) + { + # If the default slot is undef then ask subwidgets in turn + # for their default value until one accepts it. + if ($ENHANCED_CONFIGSPECS && !defined($info->[3])) + {local $SIG{'__DIE__'}; + my @def; + foreach my $sw ($cw->Subconfigure($opt)) + { + eval { @def = $sw->configure($opt) }; + last unless $@; + } + $info->[3] = $def[3]; + $info->[1] = $def[1] unless defined $info->[1]; + $info->[2] = $def[2] unless defined $info->[2]; + } + push(@results,$opt,$info->[1],$info->[2],$info->[3],$cw->cget($opt)); + } + else + { + # Real (core) Tk widgets return db name rather than option name + # for aliases so recurse to get that ... + my @real = $cw->configure($info); + push(@results,$opt,$real[1]); + } + } + else + { + push(@results,$cw->Subconfigure($opt)->configure($opt)); + } + } + else + { + my $opt; + my %results; + if (exists $spec->{'DEFAULT'}) + { + foreach $opt ($cw->Subconfigure('DEFAULT')->configure) + { + $results{$opt->[0]} = $opt; + } + } + foreach $opt (keys %$spec) + { + $results{$opt} = [$cw->configure($opt)] if ($opt ne 'DEFAULT'); + } + foreach $opt (sort keys %results) + { + push(@results,$results{$opt}); + } + } + } + else + { + my (%args) = @_; + my %changed = (); + my ($opt,$val); + my $config = $cw->TkHash('Configure'); + + while (($opt,$val) = each %args) + { + my $var = \$config->{$opt}; + my $old = $$var; + $$var = $val; + my $accepted = 0; + my $error = "No widget handles $opt"; + foreach my $subwidget ($cw->Subconfigure($opt)) + { + next unless (defined $subwidget); + eval {local $SIG{'__DIE__'}; $subwidget->configure($opt => $val) }; + if ($@) + { + my $val2 = (defined $val) ? $val : 'undef'; + $error = "Can't set $opt to `$val2' for $cw: " . $@; + undef $@; + } + else + { + $accepted = 1; + } + } + $cw->BackTrace($error) unless ($accepted); + $val = $$var; + $changed{$opt} = $val if (!defined $old || !defined $val || "$old" ne "$val"); + } + $cw->Configured(\%args,\%changed); + } + return (wantarray) ? @results : \@results; +} + +sub ConfigDefault +{ + my ($cw,$args) = @_; + + $cw->BackTrace('Bad args') unless (defined $args && ref $args eq 'HASH'); + + my $specs = $cw->ConfigSpecs; + # Should we enforce a Delagates(DEFAULT => ) as well ? + $specs->{'DEFAULT'} = ['SELF'] unless (exists $specs->{'DEFAULT'}); + + # + # This is a pain with Text or Entry as core widget, they don't + # inherit SELF's cursor. So comment it out for Tk402.001 + # + # $specs->{'-cursor'} = ['SELF',undef,undef,undef] unless (exists $specs->{'-cursor'}); + + # Now some hacks that cause colours to propogate down a composite widget + # tree - really needs more thought, other options adding such as active + # colours too and maybe fonts + + my $child = ($cw->children)[0]; # 1st child window (if any) + + unless (exists($specs->{'-background'})) + { + Tk::catch { $cw->Tk::cget('-background') }; + my (@bg) = $@ ? ('PASSIVE') : ('SELF'); + push(@bg,'CHILDREN') if $child; + $specs->{'-background'} = [\@bg,'background','Background',NORMAL_BG]; + } + unless (exists($specs->{'-foreground'})) + { + Tk::catch { $cw->Tk::cget('-foreground') }; + my (@fg) = $@ ? ('PASSIVE') : ('SELF'); + push(@fg,'CHILDREN') if $child; + $specs->{'-foreground'} = [\@fg,'foreground','Foreground',BLACK]; + } + $cw->ConfigAlias(-fg => '-foreground', -bg => '-background'); + + # Pre-scan args for aliases - this avoids defaulting + # options specified via alias + foreach my $opt (keys %$args) + { + my $info = $specs->{$opt}; + if (defined($info) && !ref($info)) + { + $args->{$info} = delete $args->{$opt}; + } + } + + # Now walk %$specs supplying defaults for all the options + # which have a defined default value, potentially looking up .Xdefaults database + # options for the name/class of the 'frame' + + foreach my $opt (keys %$specs) + { + if ($opt ne 'DEFAULT') + { + unless (exists $args->{$opt}) + { + my $info = $specs->{$opt}; + if (ref $info) + { + # Not an alias + if ($ENHANCED_CONFIGSPECS && !defined $info->[3]) + { + # configure inquire to fill in default slot from subwidget + $cw->configure($opt); + } + if (defined $info->[3]) + { + if (defined $info->[1] && defined $info->[2]) + { + # Should we do this on the Subconfigure widget instead? + # to match *Entry.Background + my $db = $cw->optionGet($info->[1],$info->[2]); + $info->[3] = $db if (defined $db); + } + $args->{$opt} = $info->[3]; + } + } + } + } + } +} + +sub ConfigSpecs +{ + my $cw = shift; + my $specs = $cw->TkHash('ConfigSpecs'); + while (@_) + { + my $key = shift; + my $val = shift; + $specs->{$key} = $val; + } + return $specs; +} + +sub _alias +{ + my ($specs,$opt,$main) = @_; + if (exists($specs->{$opt})) + { + unless (exists $specs->{$main}) + { + my $targ = $specs->{$opt}; + if (ref($targ)) + { + # opt is a real option + $specs->{$main} = $opt + } + else + { + # opt is itself an alias + # make main point to same place + $specs->{$main} = $targ unless $targ eq $main; + } + } + return 1; + } + return 0; +} + +sub ConfigAlias +{ + my $cw = shift; + my $specs = $cw->ConfigSpecs; + while (@_ >= 2) + { + my $opt = shift; + my $main = shift; + unless (_alias($specs,$opt,$main) || _alias($specs,$main,$opt)) + { + $cw->BackTrace("Neither $opt nor $main exist"); + } + } + $cw->BackTrace('Odd number of args to ConfigAlias') if (@_); +} + +sub Delegate +{ + my ($cw,$method,@args) = @_; + my $widget = $cw->DelegateFor($method); + if ($widget == $cw) + { + $method = "Tk::Widget::$method" + } + my @result; + if (wantarray) + { + @result = $widget->$method(@args); + } + else + { + $result[0] = $widget->$method(@args); + } + return (wantarray) ? @result : $result[0]; +} + +sub InitObject +{ + my ($cw,$args) = @_; + $cw->Populate($args); + $cw->ConfigDefault($args); +} + +sub ConfigChanged +{ + my ($cw,$args) = @_; +} + +sub Advertise +{ + my ($cw,$name,$widget) = @_; + confess 'No name' unless (defined $name); + croak 'No widget' unless (defined $widget); + my $hash = $cw->TkHash('SubWidget'); + $hash->{$name} = $widget; # advertise it + return $widget; +} + +sub Component +{ + my ($cw,$kind,$name,%args) = @_; + $args{'Name'} = "\l$name" if (defined $name && !exists $args{'Name'}); + # my $pack = delete $args{'-pack'}; + my $delegate = delete $args{'-delegate'}; + my $w = $cw->$kind(%args); # Create it + # $w->pack(@$pack) if (defined $pack); + $cw->Advertise($name,$w) if (defined $name); + $cw->Delegates(map(($_ => $w),@$delegate)) if (defined $delegate); + return $w; # and return it +} + +1; +__END__ + + diff --git a/Master/tlpkg/tlperl/lib/Tk/Dialog.pm b/Master/tlpkg/tlperl/lib/Tk/Dialog.pm new file mode 100644 index 00000000000..8173f4a5acc --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Dialog.pm @@ -0,0 +1,70 @@ +package Tk::Dialog; + +use vars qw($VERSION); +$VERSION = '4.004'; # $Id: //depot/Tkutf8/Tk/Dialog.pm#4 $ + +# Dialog - a translation of `tk_dialog' from Tcl/Tk to TkPerl (based on +# John Stoffel's idea). +# +# Stephen O. Lidie, Lehigh University Computing Center. 94/12/27 +# lusol@Lehigh.EDU + +# Documentation after __END__ + +use Carp; +use strict; +use base qw(Tk::DialogBox); + +Construct Tk::Widget 'Dialog'; + +sub Populate +{ + + # Dialog object constructor. Uses `new' method from base class + # to create object container then creates the dialog toplevel. + + my($cw, $args) = @_; + + $cw->SUPER::Populate($args); + + my ($w_bitmap,$w_but,$pad1,$pad2); + + # Create the Toplevel window and divide it into top and bottom parts. + + my (@pl) = (-side => 'top', -fill => 'both'); + + ($pad1, $pad2) = + ([-padx => '3m', -pady => '3m'], [-padx => '3m', -pady => '2m']); + + + $cw->iconname('Dialog'); + + my $w_top = $cw->Subwidget('top'); + + # Fill the top part with the bitmap and message. + + @pl = (-side => 'left'); + + $w_bitmap = $w_top->Label(Name => 'bitmap'); + $w_bitmap->pack(@pl, @$pad1); + + my $w_msg = $w_top->Label( -wraplength => '3i', -justify => 'left' ); + + $w_msg->pack(-side => 'right', -expand => 1, -fill => 'both', @$pad1); + + $cw->Advertise(message => $w_msg); + $cw->Advertise(bitmap => $w_bitmap ); + + $cw->ConfigSpecs( -image => ['bitmap',undef,undef,undef], + -bitmap => ['bitmap',undef,undef,undef], + -font => ['message','font','Font', '-*-Times-Medium-R-Normal--*-180-*-*-*-*-*-*'], + DEFAULT => ['message',undef,undef,undef] + ); +} + +1; + +__END__ + +=cut + diff --git a/Master/tlpkg/tlperl/lib/Tk/DialogBox.pm b/Master/tlpkg/tlperl/lib/Tk/DialogBox.pm new file mode 100644 index 00000000000..13335404e15 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/DialogBox.pm @@ -0,0 +1,135 @@ +# +# DialogBox is similar to Dialog except that it allows any widget +# in the top frame. Widgets can be added with the add method. Currently +# there exists no way of deleting a widget once it has been added. + +package Tk::DialogBox; + +use strict; +use Carp; + +use vars qw($VERSION); +$VERSION = sprintf '4.%03d', q$Revision: #13 $ =~ /\D(\d+)\s*$/; + +use base qw(Tk::Toplevel); + +Tk::Widget->Construct('DialogBox'); + +sub Populate { + my ($cw, $args) = @_; + + $cw->SUPER::Populate($args); + my $buttons = delete $args->{'-buttons'}; + $buttons = ['OK'] unless defined $buttons; + my $default_button = delete $args->{'-default_button'}; + $default_button = $buttons->[0] unless defined $default_button; + + $cw->{'selected_button'} = ''; + $cw->transient($cw->Parent->toplevel); + $cw->withdraw; + if (@$buttons == 1) { + $cw->protocol('WM_DELETE_WINDOW' => sub { $cw->{'default_button'}->invoke }); + } else { + $cw->protocol('WM_DELETE_WINDOW' => sub {}); + } + + # create the two frames + my $top = $cw->Component('Frame', 'top'); + $top->configure(-relief => 'raised', -bd => 1) unless $Tk::platform eq 'MSWin32'; + my $bot = $cw->Component('Frame', 'bottom'); + $bot->configure(-relief => 'raised', -bd => 1) unless $Tk::platform eq 'MSWin32'; + $bot->pack(qw/-side bottom -fill both -ipady 3 -ipadx 3/); + $top->pack(qw/-side top -fill both -ipady 3 -ipadx 3 -expand 1/); + + # create a row of buttons in the bottom. + my $bl; # foreach my $var: perl > 5.003_08 + foreach $bl (@$buttons) + { + my $b = $bot->Button(-text => $bl, -command => sub { $cw->{'selected_button'} = "$bl" } ); + $b->bind('<Return>' => [ $b, 'Invoke']); + $cw->Advertise("B_$bl" => $b); + if ($Tk::platform eq 'MSWin32') + { + $b->configure(-width => 10, -pady => 0); + } + if ($bl eq $default_button) { + if ($Tk::platform eq 'MSWin32') { + $b->pack(-side => 'left', -expand => 1, -padx => 1, -pady => 1); + } else { + my $db = $bot->Frame(-relief => 'sunken', -bd => 1); + $b->raise($db); + $b->pack(-in => $db, -padx => '2', -pady => '2'); + $db->pack(-side => 'left', -expand => 1, -padx => 1, -pady => 1); + } + $cw->{'default_button'} = $b; + $cw->bind('<Return>' => [ $b, 'Invoke']); + } else { + $b->pack(-side => 'left', -expand => 1, -padx => 1, -pady => 1); + } + } + $cw->ConfigSpecs(-command => ['CALLBACK', undef, undef, undef ], + -foreground => ['DESCENDANTS', 'foreground','Foreground', 'black'], + -background => ['DESCENDANTS', 'background','Background', undef], + -focus => ['PASSIVE', undef, undef, undef], + -showcommand => ['CALLBACK', undef, undef, undef], + ); + $cw->Delegates('Construct',$top); +} + +sub add { + my ($cw, $wnam, @args) = @_; + my $w = $cw->Subwidget('top')->$wnam(@args); + $cw->Advertise("\L$wnam" => $w); + return $w; +} + +sub Wait +{ + my $cw = shift; + $cw->Callback(-showcommand => $cw); + $cw->waitVariable(\$cw->{'selected_button'}); + $cw->grabRelease; + $cw->withdraw; + $cw->Callback(-command => $cw->{'selected_button'}); +} + +sub Show { + + croak 'DialogBox: "Show" method requires at least 1 argument' + if scalar @_ < 1; + my $cw = shift; + my ($grab) = @_; + my $old_focus = $cw->focusSave; + my $old_grab = $cw->grabSave; + + shift if defined $grab && length $grab && ($grab =~ /global/); + $cw->Popup(@_); + + Tk::catch { + if (defined $grab && length $grab && ($grab =~ /global/)) { + $cw->grabGlobal; + } else { + $cw->grab; + } + }; + if (my $focusw = $cw->cget(-focus)) { + $focusw->focus; + } elsif (defined $cw->{'default_button'}) { + $cw->{'default_button'}->focus; + } else { + $cw->focus; + } + $cw->Wait; + &$old_focus; + &$old_grab; + return $cw->{'selected_button'}; +} + +sub Exit +{ + my $cw = shift; + #kill the dialogbox, by faking a 'DONE' + $cw->{'selected_button'} = $cw->{'default_button'}->cget(-text); +} + +1; diff --git a/Master/tlpkg/tlperl/lib/Tk/DirTree.pm b/Master/tlpkg/tlperl/lib/Tk/DirTree.pm new file mode 100644 index 00000000000..b2d996a94d0 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/DirTree.pm @@ -0,0 +1,252 @@ +package Tk::DirTree; +# DirTree -- TixDirTree widget +# +# Derived from DirTree.tcl in Tix 4.1 +# +# Chris Dean <ctdean@cogit.com> + +use vars qw($VERSION); +$VERSION = sprintf '4.%03d', q$Revision: #14 $ =~ /\D(\d+)\s*$/; + +use Tk; +use Tk::Derived; +use Tk::Tree; +use Cwd; +use DirHandle; + +use base qw(Tk::Derived Tk::Tree); +use strict; + +Construct Tk::Widget 'DirTree'; + + +sub Populate { + my( $cw, $args ) = @_; + + $cw->SUPER::Populate( $args ); + + $cw->ConfigSpecs( + -dircmd => [qw/CALLBACK dirCmd DirCmd DirCmd/], + -showhidden => [qw/PASSIVE showHidden ShowHidden 0/], + -image => [qw/PASSIVE image Image folder/], + -directory => [qw/SETMETHOD directory Directory ./], + -value => '-directory' ); + + $cw->configure( -separator => '/', -itemtype => 'imagetext' ); +} + +sub DirCmd { + my( $w, $dir, $showhidden ) = @_; + $dir .= "/" if $dir =~ /^[a-z]:$/i and $^O eq 'MSWin32'; + my $h = DirHandle->new( $dir ) or return(); + my @names = grep( $_ ne '.' && $_ ne '..', $h->read ); + @names = grep( ! /^[.]/, @names ) unless $showhidden; + return( @names ); +} + +*dircmd = \&DirCmd; + +sub fullpath +{ + my ($path) = @_; + my $cwd = getcwd(); + if (CORE::chdir($path)) + { + $path = getcwd(); + CORE::chdir($cwd) || die "Cannot cd back to $cwd:$!"; + } + else + { + warn "Cannot cd to $path:$!" + } + return $path; +} + +sub directory +{ + my ($w,$key,$val) = @_; + # We need a value for -image, so its being undefined + # is probably caused by order of handling config defaults + # so defer it. + $w->afterIdle([$w, 'set_dir' => $val]); +} + +sub set_dir { + my( $w, $val ) = @_; + my $fulldir = fullpath( $val ); + + my $parent = '/'; + if ($^O eq 'MSWin32') + { + if ($fulldir =~ s/^([a-z]:)//i) + { + $parent = $1; + } + } + $w->add_to_tree( $parent, $parent) unless $w->infoExists($parent); + + my @dirs = ($parent); + foreach my $name (split( /[\/\\]/, $fulldir )) { + next unless length $name; + push @dirs, $name; + my $dir = join( '/', @dirs ); + $dir =~ s|^//|/|; + $w->add_to_tree( $dir, $name, $parent ) + unless $w->infoExists( $dir ); + $parent = $dir; + } + + $w->OpenCmd( $parent ); + $w->setmode( $parent, 'close' ); +} +*chdir = \&set_dir; + + +sub OpenCmd { + my( $w, $dir ) = @_; + + my $parent = $dir; + $dir = '' if $dir eq '/'; + foreach my $name ($w->dirnames( $parent )) { + next if ($name eq '.' || $name eq '..'); + my $subdir = "$dir/$name"; + next unless -d $subdir; + if( $w->infoExists( $subdir ) ) { + $w->show( -entry => $subdir ); + } else { + $w->add_to_tree( $subdir, $name, $parent ); + } + } +} + +*opencmd = \&OpenCmd; + +sub add_to_tree { + my( $w, $dir, $name, $parent ) = @_; + + my $image = $w->cget('-image'); + if ( !UNIVERSAL::isa($image, 'Tk::Image') ) { + $image = $w->Getimage( $image ); + } + my $mode = 'none'; + $mode = 'open' if $w->has_subdir( $dir ); + + my @args = (-image => $image, -text => $name); + if( $parent ) { # Add in alphabetical order. + foreach my $sib ($w->infoChildren( $parent )) { + if( $sib gt $dir ) { + push @args, (-before => $sib); + last; + } + } + } + + $w->add( $dir, @args ); + $w->setmode( $dir, $mode ); +} + +sub has_subdir { + my( $w, $dir ) = @_; + foreach my $name ($w->dirnames( $dir )) { + next if ($name eq '.' || $name eq '..'); + next if ($name =~ /^\.+$/); + return( 1 ) if -d "$dir/$name"; + } + return( 0 ); +} + +sub dirnames { + my( $w, $dir ) = @_; + my @names = $w->Callback( '-dircmd', $dir, $w->cget( '-showhidden' ) ); + return( @names ); +} + +{ + package Tk::DirTreeDialog; + use base qw(Tk::Toplevel); + Construct Tk::Widget 'DirTreeDialog'; + + sub Populate { + my($w, $args) = @_; + $w->{curr_dir} = $args->{-initialdir}; + if (!defined $w->{curr_dir}) { + require Cwd; + $w->{curr_dir} = Cwd::cwd(); + } + if (defined $args->{-mustexist}) { + die "-mustexist is not yet implemented"; + } + my $title = $args->{-title} || "Choose directory:"; + delete $args->{-popover}; + + $w->title($title); + $w->{ok} = 0; # flag: "1" means OK, "-1" means cancelled + + # Create Frame widget before the DirTree widget, so it's always visible + # if the window gets resized. + my $f = $w->Frame->pack(-fill => "x", -side => "bottom"); + + my $d; + $d = $f->Scrolled('DirTree', + -scrollbars => 'osoe', + -width => 35, + -height => 20, + -selectmode => 'browse', + -exportselection => 1, + -browsecmd => sub { + $w->{curr_dir} = shift; + if ($^O ne 'MSWin32') { + $w->{curr_dir} =~ s|^//|/|; # bugfix + } + }, + + # With this version of -command a double-click will + # select the directory + -command => sub { $w->{ok} = 1 }, + + # With this version of -command a double-click will + # open a directory. Selection is only possible with + # the Ok button. + #-command => sub { $d->opencmd($_[0]) }, + )->pack(-fill => "both", -expand => 1); + # Set the initial directory + exists &Tk::DirTree::chdir ? $d->chdir($w->{curr_dir}) : $d->set_dir($w->{curr_dir}); + + $f->Button(-text => 'Ok', + -command => sub { $w->{ok} = 1 })->pack(-side => 'left'); + $f->Button(-text => 'Cancel', + -command => sub { $w->{ok} = -1 })->pack(-side => 'left'); + $w->OnDestroy(sub { $w->{ok} = -1 }); + } + + sub Show { + my $w = shift; + my $old_focus = $w->focusSave; + my $old_grab = $w->grabSave; + Tk::catch { + $w->grab; + }; + $w->waitVariable(\$w->{ok}); + my $ret = $w->{ok} == 1 ? $w->{curr_dir} : undef; + $w->grabRelease if Tk::Exists($w); + &$old_focus; + &$old_grab; + $w->destroy if Tk::Exists($w); + $ret; + } +} + +1; + +__END__ + +# Copyright (c) 1996, Expert Interface Technologies +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# The file man.macros and some of the macros used by this file are +# copyrighted: (c) 1990 The Regents of the University of California. +# (c) 1994-1995 Sun Microsystems, Inc. +# The license terms of the Tcl/Tk distrobution are in the file +# license.tcl. + diff --git a/Master/tlpkg/tlperl/lib/Tk/Dirlist.pm b/Master/tlpkg/tlperl/lib/Tk/Dirlist.pm new file mode 100644 index 00000000000..f16ce021f41 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Dirlist.pm @@ -0,0 +1,113 @@ +package Tk::Dirlist; +require Tk::Derived; +require Tk::HList; +require DirHandle; +use Cwd; + +use vars qw($VERSION); +$VERSION = '4.004'; # $Id: //depot/Tkutf8/Tk/Dirlist.pm#5 $ + +use base qw(Tk::Derived Tk::HList); +use strict; +Construct Tk::Widget 'Dirlist'; + +sub getimage +{ + my ($w,$key) = @_; + unless (exists $w->{$key}) + { + $w->{$key} = $w->Pixmap(-id => $key); + unless ($w->{$key}) + { + $w->{$key} = $w->Bitmap($key); + } + } + return $w->{$key}; +} + + +sub Populate +{ + my ($cw,$args) = @_; + $cw->configure(-separator => '/', -itemtype => 'imagetext'); + $cw->ConfigSpecs(-directory => ['SETMETHOD','directory','Directory','.']); +} + +sub fullpath +{ + my ($path) = @_; + my $cwd = getcwd; + if (chdir($path)) + { + $path = getcwd; + chdir($cwd); + } + else + { + warn "Cannot cd to $path:$!" + } +# print "$path\n"; + return $path; +} + +sub AddDir +{ + my ($w,$dir) = @_; + my $path = ''; + my $prefix = ''; + my $first = 0; + my $name; + foreach $name (split m#/#,$dir) + { + $first++; + if ($name eq '') + { + next unless ($first == 1); + $path = '/'; + $name = '/'; + } + else + { + $path .= $prefix; + $path .= $name; + $prefix = '/'; + } + unless ($w->info('exists' => $path)) + { +# print "Add $path\n"; + $w->add($path,-image => $w->getimage('folder'), -text => $name); + } + } +} + +sub choose_image +{ + my ($w,$path) = @_; + return 'folder' if (-d $path); + return 'srcfile' if ($path =~ /\.[ch]$/); + return 'textfile' if (-T $path); + return 'file'; +} + + +sub directory +{ + my ($w,$key,$val) = @_; + my $h = DirHandle->new($val); + $w->AddDir($val = fullpath($val)); + my $f; + $w->entryconfigure($val,-image => $w->getimage('act_fold')); + foreach $f (sort $h->read) + { + next if ($f =~ /^\.+$/); + my $path = "$val/$f"; + unless ($w->info('exists' => $path)) + { + my $image = $w->getimage($w->choose_image($path)); + $w->add($path,-image => $image, -text => $f); + } + } + $h->close; +} + +1; diff --git a/Master/tlpkg/tlperl/lib/Tk/DragDrop.pm b/Master/tlpkg/tlperl/lib/Tk/DragDrop.pm new file mode 100644 index 00000000000..bdc54f74367 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/DragDrop.pm @@ -0,0 +1,332 @@ +package Tk::DragDrop; +require Tk::DragDrop::Common; +require Tk::Toplevel; +require Tk::Label; + +use vars qw($VERSION); +$VERSION = sprintf '4.%03d', q$Revision: #14 $ =~ /\D(\d+)\s*$/; + +use base qw(Tk::DragDrop::Common Tk::Toplevel); + +# This is a little tricky, ISA says 'Toplevel' but we +# define a Tk_cmd to actually build a 'Label', then +# use wmRelease in Populate to make it a toplevel. + +my $useWmRelease = Tk::Wm->can('release'); # ($^O ne 'MSWin32'); + +sub Tk_cmd { ($useWmRelease) ? \&Tk::label : \&Tk::toplevel } + +Construct Tk::Widget 'DragDrop'; + +use strict; +use vars qw(%type @types); +use Carp; + + +# There is a snag with having a token window and moving to +# exactly where cursor is - the cursor is "inside" the token +# window - hence it is not "inside" the dropsite window +# so we offset X,Y by OFFSET pixels. +sub OFFSET () {3} + +sub ClassInit +{ + my ($class,$mw) = @_; + $mw->bind($class,'<Map>','Mapped'); + $mw->bind($class,'<Any-KeyPress>','Done'); + $mw->bind($class,'<Any-ButtonRelease>','Drop'); + $mw->bind($class,'<Any-Motion>','Drag'); + return $class; +} + +sub Populate +{ + my ($token,$args) = @_; + my $parent = $token->parent; + if ($useWmRelease) + { + $token->wmRelease; + $token->ConfigSpecs(-text => ['SELF','text','Text',$parent->class]); + } + else + { + my $lab = $token->Label->pack(-expand => 1, -fill => 'both'); + bless $lab,ref($token); + $lab->bindtags([ref($token), $lab, $token, 'all']); + $token->ConfigSpecs(-text => [$lab,'text','Text',$parent->class], + DEFAULT => [$lab]); + } + $token->withdraw; + $token->overrideredirect(1); + $token->ConfigSpecs(-sitetypes => ['METHOD','siteTypes','SiteTypes',undef], + -startcommand => ['CALLBACK',undef,undef,undef], + -endcommand => ['CALLBACK',undef,undef,undef], + -predropcommand => ['CALLBACK',undef,undef,undef], + -postdropcommand => ['CALLBACK',undef,undef,undef], + -delta => ['PASSIVE','delta','Delta',10], + -cursor => ['SELF','cursor','Cursor','hand2'], + -handlers => ['SETMETHOD','handlers','Handlers',[[[$token,'SendText']]]], + -selection => ['SETMETHOD','selection','Selection','XdndSelection'], + -event => ['SETMETHOD','event','Event','<B1-Motion>'] + ); + $token->{InstallHandlers} = 0; + $args->{-borderwidth} = 3; + $args->{-relief} = 'flat'; + $args->{-takefocus} = 1; +} + +sub sitetypes +{ + my ($w,$val) = @_; + confess "Not a widget $w" unless (ref $w); + my $var = \$w->{Configure}{'-sitetypes'}; + if (@_ > 1) + { + if (defined $val) + { + $val = [$val] unless (ref $val); + my $type; + foreach $type (@$val) + { + Tk::DragDrop->import($type); + } + } + $$var = $val; + } + return (defined $$var) ? $$var : \@types; +} + +sub SendText +{ + my ($w,$offset,$max) = @_; + my $s = substr($w->cget('-text'),$offset); + $s = substr($s,0,$max) if (length($s) > $max); + return $s; +} + +sub handlers +{ + my ($token,$opt,$value) = @_; + $token->{InstallHandlers} = (defined($value) && @$value); + $token->{'handlers'} = $value; +} + +sub selection +{ + my ($token,$opt,$value) = @_; + my $handlers = $token->{'handlers'}; + $token->{InstallHandlers} = (defined($handlers) && @$handlers); +} + +sub event +{ + my ($w,$opt,$value) = @_; + # delete old bindings + $w->parent->Tk::bind($value,[$w,'StartDrag']); +} + +# + +sub FindSite +{ + my ($token,$X,$Y,$e) = @_; + my $site; + my $types = $token->sitetypes; + if (defined $types && @$types) + { + foreach my $type (@$types) + { + my $class = $type{$type}; + last if (defined($class) && ($site = $class->FindSite($token,$X,$Y))); + } + } + else + { + warn 'No sitetypes'; + } + my $new = $site || 'undef'; + my $over = $token->{'Over'}; + if ($over) + { + if (!$over->Match($site)) + { + $over->Leave($token,$e); + delete $token->{'Over'}; + } + } + if ($site) + { + unless ($token->{'Over'}) + { + $site->Enter($token,$e); + $token->{'Over'} = $site; + } + $site->Motion($token,$e) if (defined $site) + } + return $site; +} + +sub Mapped +{ + my ($token) = @_; + my $e = $token->parent->XEvent; + $token = $token->toplevel; + $token->grabGlobal; + $token->focus; + if (defined $e) + { + my $X = $e->X; + my $Y = $e->Y; + $token->MoveToplevelWindow($X+OFFSET,$Y+OFFSET); + $token->NewDrag; + $token->FindSite($X,$Y,$e); + } +} + +sub NewDrag +{ + my ($token) = @_; + my $types = $token->sitetypes; + if (defined $types && @$types) + { + my $type; + foreach $type (@$types) + { + my $class = $type{$type}; + if (defined $class) + { + $class->NewDrag($token); + } + } + } +} + +sub Drag +{ + my $token = shift; + my $e = $token->XEvent; + my $X = $e->X; + my $Y = $e->Y; + $token = $token->toplevel; + $token->MoveToplevelWindow($X+OFFSET,$Y+OFFSET); + $token->FindSite($X,$Y,$e); +} + +sub Done +{ + my $token = shift; + my $e = $token->XEvent; + $token = $token->toplevel; + my $over = delete $token->{'Over'}; + $over->Leave($token,$e) if (defined $over); + my $w = $token->parent; + eval {local $SIG{__DIE__}; $token->grabRelease }; + $token->withdraw; + delete $w->{'Dragging'}; + $w->update; +} + +sub AcceptDrop +{ + my ($token) = @_; + $token->configure(-relief => 'sunken'); + $token->{'Accepted'} = 1; +} + +sub RejectDrop +{ + my ($token) = @_; + $token->configure(-relief => 'flat'); + $token->{'Accepted'} = 0; +} + +sub HandleLoose +{ + my ($w,$seln) = @_; + return ''; +} + +sub InstallHandlers +{ + my ($token,$seln) = @_; + my $w = $token->parent; + $token->configure('-selection' => $seln) if $seln; + $seln = $token->cget('-selection'); + if ($token->{InstallHandlers}) + { + foreach my $h (@{$token->cget('-handlers')}) + { + $w->SelectionHandle('-selection' => $seln,@$h); + } + $token->{InstallHandlers} = 0; + } + if (!$w->IS($w->SelectionOwner('-selection'=>$seln))) + { + $w->SelectionOwn('-selection' => $seln, -command => [\&HandleLoose,$w,$seln]); + } +} + +sub Drop +{ + my $ewin = shift; + my $e = $ewin->XEvent; + my $token = $ewin->toplevel; + my $site = $token->FindSite($e->X,$e->Y,$e); + Tk::catch { $token->grabRelease }; + if (defined $site) + { + my $seln = $token->cget('-selection'); + unless ($token->Callback(-predropcommand => $seln, $site)) + { +# XXX This is ugly if the user restarts a drag within the 2000 ms: +# my $id = $token->after(2000,[$token,'Done']); + my $w = $token->parent; + $token->InstallHandlers; + $site->Drop($token,$seln,$e); + $token->Callback(-postdropcommand => $seln); + $token->Done; + } + } + else + { + $token->Done; + } + $token->Callback('-endcommand'); +} + +sub StartDrag +{ + my $token = shift; + my $w = $token->parent; + unless ($w->{'Dragging'}) + { + my $e = $w->XEvent; + my $X = $e->X; + my $Y = $e->Y; + my $was = $token->{'XY'}; + if ($was) + { + my $dx = $was->[0] - $X; + my $dy = $was->[1] - $Y; + if (sqrt($dx*$dx+$dy*$dy) > $token->cget('-delta')) + { + unless ($token->Callback('-startcommand',$token,$e)) + { + delete $token->{'XY'}; + $w->{'Dragging'} = $token; + $token->MoveToplevelWindow($X+OFFSET,$Y+OFFSET); + $token->raise; + $token->deiconify; + $token->FindSite($X,$Y,$e); + } + } + } + else + { + $token->{'XY'} = [$X,$Y]; + } + } +} + + +1; diff --git a/Master/tlpkg/tlperl/lib/Tk/DragDrop/Common.pm b/Master/tlpkg/tlperl/lib/Tk/DragDrop/Common.pm new file mode 100644 index 00000000000..2f7a33d4fb4 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/DragDrop/Common.pm @@ -0,0 +1,59 @@ +package Tk::DragDrop::Common; + +use strict; +use Carp; + +use vars qw($VERSION); +$VERSION = '4.004'; # $Id: //depot/Tkutf8/DragDrop/DragDrop/Common.pm#4 $ + +sub Type +{ + my ($base,$name,$class) = @_; + no strict 'refs'; + my $hash = \%{"${base}::type"}; + my $array = \@{"${base}::types"}; + unless (exists $hash->{$name}) + { + push(@$array,$name); + $class = (caller(0))[0] unless (@_ > 2); + $hash->{$name} = $class; + # confess "Strange class $class for $base/$name" unless ($class =~ /^Tk/); + # print "$base $name is ",$class,"\n"; + } +} + +sub import +{ + my $class = shift; + no strict 'refs'; + my $types = \%{"${class}::type"}; + while (@_) + { + my $type = shift; + unless (exists $types->{$type}) + { + if ($type eq 'Local') + { + $class->Type($type,$class); + } + else + { + my ($kind) = $class =~ /([A-Z][a-z]+)$/; + my $file = Tk->findINC("DragDrop/${type}${kind}.pm"); + if (defined $file) + { + # print "Loading $file\n"; + require $file; + } + else + { + croak "Cannot find ${type}${kind}"; + } + } + } + } +} + +1; +__END__ + diff --git a/Master/tlpkg/tlperl/lib/Tk/DragDrop/LocalDrop.pm b/Master/tlpkg/tlperl/lib/Tk/DragDrop/LocalDrop.pm new file mode 100644 index 00000000000..0f5028ae64c --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/DragDrop/LocalDrop.pm @@ -0,0 +1,61 @@ +package Tk::DragDrop::Local; +use strict; +use vars qw($VERSION); +$VERSION = '4.004'; # $Id: //depot/Tkutf8/DragDrop/DragDrop/LocalDrop.pm#4 $ + +use base qw(Tk::DragDrop::Rect); +require Tk::DragDrop; + +my @toplevels; + +Tk::DragDrop->Type('Local'); + +sub XY +{ + my ($site,$event) = @_; + return ($event->X - $site->X,$event->Y - $site->Y); +} + +sub Apply +{ + my $site = shift; + my $name = shift; + my $cb = $site->{$name}; + if ($cb) + { + my $event = shift; + $cb->Call(@_,$site->XY($event)); + } +} + +sub Drop +{ + my ($site,$token,$seln,$event) = @_; + $site->Apply(-dropcommand => $event, $seln); + $site->Apply(-entercommand => $event, 0); + $token->Done; +} + +sub Enter +{ + my ($site,$token,$event) = @_; + $token->AcceptDrop; + $site->Apply(-entercommand => $event, 1); +} + +sub Leave +{ + my ($site,$token,$event) = @_; + $token->RejectDrop; + $site->Apply(-entercommand => $event, 0); +} + +sub Motion +{ + my ($site,$token,$event) = @_; + $site->Apply(-motioncommand => $event); +} + +1; + +__END__ diff --git a/Master/tlpkg/tlperl/lib/Tk/DragDrop/Rect.pm b/Master/tlpkg/tlperl/lib/Tk/DragDrop/Rect.pm new file mode 100644 index 00000000000..04cfa8772f2 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/DragDrop/Rect.pm @@ -0,0 +1,110 @@ +package Tk::DragDrop::Rect; +use strict; +use Carp; + +# Proxy class which represents sites to the dropping side + +use vars qw($VERSION); +$VERSION = sprintf '4.%03d', q$Revision: #11 $ =~ /\D(\d+)\s*$/; + +# Some default methods when called site side +# XIDs and viewable-ness from widget + +# XID of ancestor +sub ancestor { ${shift->widget->toplevel->WindowId} } + +# XID of site window +sub win { ${shift->widget->WindowId} } + +# Is site window mapped +sub viewable { shift->widget->viewable } + +sub Over +{ + my ($site,$X,$Y) = @_; + + my $x = $site->X; + my $y = $site->Y; + my $w = $site->width; + my $h = $site->height; + my $val = ($X >= $x && $X < ($x + $w) && $Y >= $y && $Y < ($y + $h)); + + return 0 unless $val; + + my $widget = $site->widget; + + # Now XTranslateCoords from root window to site window's + # ancestor. Ancestors final descendant should be the site window. + # Like $win->containing but avoids a problem that dropper's "token" + # window may be the toplevel (child of root) that contains X,Y + # so if that is in another application ->containing does not + # give us a window. + my $id = $site->ancestor; + while (1) + { + my $cid = $widget->PointToWindow($X,$Y,$id); + last unless $cid; + $id = $cid; + } + return ($id == $site->win); +} + +sub FindSite +{ + my ($class,$widget,$X,$Y) = @_; + foreach my $site ($class->SiteList($widget)) + { + return $site if ($site->viewable && $site->Over($X,$Y)); + } + return undef; +} + +sub NewDrag +{ + my ($class,$widget) = @_; +} + +sub Match +{ + my ($site,$other) = @_; + return 0 unless (defined $other); + return 1 if ($site == $other); + return 0 unless (ref($site) eq ref($other)); + for ("$site") + { + if (/ARRAY/) + { + my $i; + return 0 unless (@$site == @$other); + for ($i = 0; $i < @$site; $i++) + { + return 0 unless ($site->[$i] == $other->[$i]); + } + return 1; + } + elsif (/SCALAR/) + { + return $site == $other; + } + elsif (/HASH/) + { + my $key; + foreach $key (keys %$site) + { + return 0 unless exists $other->{$key}; + return 0 unless ($other->{$key} eq $site->{$key}); + } + foreach $key (keys %$other) + { + return 0 unless exists $site->{$key}; + return 0 unless ($other->{$key} eq $site->{$key}); + } + return 1; + } + return 0; + } + return 0; +} + + +1; diff --git a/Master/tlpkg/tlperl/lib/Tk/DragDrop/SunConst.pm b/Master/tlpkg/tlperl/lib/Tk/DragDrop/SunConst.pm new file mode 100644 index 00000000000..66325466e68 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/DragDrop/SunConst.pm @@ -0,0 +1,34 @@ +package Tk::DragDrop::SunConst; +require Exporter; + +use vars qw($VERSION); +$VERSION = '4.004'; # $Id: //depot/Tkutf8/DragDrop/DragDrop/SunConst.pm#4 $ + +use base qw(Exporter); + +@EXPORT = qw(_enter _leave _motion + ENTERLEAVE MOTION DEFAULT_SITE + MOVE_FLAG ACK_FLAG TRANSIENT_FLAG FORWARDED_FLAG + ); + +# Event types +sub _enter () {7}; +sub _leave () {8}; +sub _motion () {6}; + +# Site flags + +sub ENTERLEAVE () {1<<0} +sub MOTION () {1<<1} +sub DEFAULT_SITE () {1<<2} + +# Trigger flags +sub MOVE_FLAG () {1<<0} +sub ACK_FLAG () {1<<1} +sub TRANSIENT_FLAG () {1<<2} +sub FORWARDED_FLAG () {1<<3} + +1; + +__END__ + diff --git a/Master/tlpkg/tlperl/lib/Tk/DragDrop/SunDrop.pm b/Master/tlpkg/tlperl/lib/Tk/DragDrop/SunDrop.pm new file mode 100644 index 00000000000..422a08196ea --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/DragDrop/SunDrop.pm @@ -0,0 +1,200 @@ +package Tk::DragDrop::SunDrop; +require Tk::DragDrop::Rect; + +use vars qw($VERSION); +$VERSION = sprintf '4.%03d', q$Revision: #5 $ =~ /\D(\d+)\s*$/; + +use base qw(Tk::DragDrop::Rect); +use strict; +use Tk::DragDrop::SunConst; + +Tk::DragDrop->Type('Sun'); + +BEGIN + { + # Define the Rect API as members of the array + my @fields = qw(name win X Y width height flags ancestor widget); + my $i = 0; + no strict 'refs'; + for ($i=0; $i < @fields; $i++) + { + my $j = $i; + *{"$fields[$i]"} = sub { shift->[$j] }; + } + } + + +sub Preview +{ + my ($site,$token,$e,$kind,$flags) = (@_); + $token->BackTrace('No flags') unless defined $flags; + my $sflags = $site->flags; + return if ($kind == _motion && !($sflags & MOTION)); + return if ($kind != _motion && !($sflags & ENTERLEAVE)); + my $data = pack('LLSSLL',$kind,$e->t,$e->X,$e->Y,$site->name,$flags); + $token->SendClientMessage('_SUN_DRAGDROP_PREVIEW',$site->win,32,$data); +} + +sub Enter +{ + my ($site,$token,$e) = @_; + $token->AcceptDrop; + $site->Preview($token,$e,_enter,0); +} + +sub Leave +{ + my ($site,$token,$e) = @_; + $token->RejectDrop; + $site->Preview($token,$e,_leave,0); +} + +sub Motion +{ + my ($site,$token,$e) = @_; + $site->Preview($token,$e,_motion,0); +} + +sub HandleDone +{ + my ($token,$seln,$offset,$max) = @_; + $token->Done; + return ''; +} + +sub HandleAck +{ + my ($w,$seln,$offset,$max) = @_; + return ''; +} + +sub HandleItem +{ + my ($w,$seln,$offset,$max) = @_; + return undef; +} + +sub HandleCount +{ + my ($w,$seln,$offset,$max) = @_; + return 1; +} + +sub Drop +{ + my ($site,$token,$seln,$e) = @_; + my $w = $token->parent; + $w->SelectionHandle('-selection'=>$seln,'-type'=>'_SUN_DRAGDROP_ACK',[\&HandleAck,$token,$seln]); + $w->SelectionHandle('-selection'=>$seln,'-type'=>'_SUN_DRAGDROP_DONE',[\&HandleDone,$token,$seln]); + my $atom = $w->InternAtom($seln); + my $flags = ACK_FLAG | TRANSIENT_FLAG; + my $data = pack('LLSSLL',$atom,$e->t,$e->X,$e->Y,$site->name,$flags); + $w->SendClientMessage('_SUN_DRAGDROP_TRIGGER',$site->win,32,$data); +} + +sub FindSite +{ + my ($class,$token,$X,$Y) = @_; + $token->{'SunDD'} = [] unless exists $token->{'SunDD'}; + my $site = $class->SUPER::FindSite($token,$X,$Y); + if (!defined $site) + { + my $id = $token->PointToWindow($X,$Y); + while ($id) + { + my @prop; + Tk::catch { @prop = $token->property('get','_SUN_DRAGDROP_INTEREST', $id) }; + if (!$@ && shift(@prop) eq '_SUN_DRAGDROP_INTEREST' && shift(@prop) == 0) + { + # This is a "toplevel" which has some sites associated with it. + my ($bx,$by) = $token->WindowXY($id); + $token->{'SunDDSeen'} = {} unless exists $token->{'SunDDSeen'}; + return $site if $token->{'SunDDSeen'}{$id}; + $token->{'SunDDSeen'}{$id} = 1; + my $sites = $token->{'SunDD'}; + my $count = shift(@prop); + while (@prop && $count-- > 0) + { + my ($xid,$sn,$flags,$kind,$n) = splice(@prop,0,5); + if ($kind != 0) + { + warn "Don't understand site type $kind"; + last; + } + while (@prop >= 4 && $n-- > 0) + { + my ($x,$y,$w,$h) = splice(@prop,0,4); + push(@$sites,bless [$sn,$xid,$x+$bx,$y+$by,$w,$h,$flags,$id,$token],$class); + } + } + return $class->SUPER::FindSite($token,$X,$Y); + } + $id = $token->PointToWindow($X,$Y,$id) + } + } + return $site; +} + +my $busy = 0; + +sub NewDrag +{ + my ($class,$token) = @_; + delete $token->{'SunDD'} unless $busy; + delete $token->{'SunDDSeen'}; +} + +sub SiteList +{ + my ($class,$token) = @_; + return @{$token->{'SunDD'}}; +} + +1; +__END__ + +# this code is obsolete now that we look at properties ourselves +# which means we don't need dropsite manager running +# On Sun's running OpenLook the window manager or dropsite mananger +# watches for and caches site info in a special selection +# This code got sites from that +# + +sub SiteList +{ + my ($class,$token) = @_; + unless (1 || $busy || exists $token->{'SunDD'}) + { + Carp::confess('Already doing it!') if ($busy++); + my @data = (); + my @sites = (); + my $mw = $token->MainWindow; + $token->{'SunDD'} = \@sites; + Tk::catch { + @data = $mw->SelectionGet( '-selection'=>'_SUN_DRAGDROP_DSDM', '_SUN_DRAGDROP_SITE_RECTS'); + }; + if ($@) + { + $token->configure('-cursor'=>'hand2'); + $token->grab(-global); + } + else + { + while (@data) + { + my $version = shift(@data); + if ($version != 0) + { + warn "Unexpected site version $version"; + last; + } + push(@sites,bless [splice(@data,0,7)],$class); + } + } + $busy--; + } + return @{$token->{'SunDD'}}; +} + +1; + diff --git a/Master/tlpkg/tlperl/lib/Tk/DragDrop/SunSite.pm b/Master/tlpkg/tlperl/lib/Tk/DragDrop/SunSite.pm new file mode 100644 index 00000000000..ab3f4f9793b --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/DragDrop/SunSite.pm @@ -0,0 +1,107 @@ +package Tk::DragDrop::SunSite; +require Tk::DropSite; + +use vars qw($VERSION); +$VERSION = sprintf '4.%03d', q$Revision: #6 $ =~ /\D(\d+)\s*$/; + +use Tk::DragDrop::SunConst; +use base qw(Tk::DropSite); +use strict; + +Tk::DropSite->Type('Sun'); + +sub SunDrop +{ + my ($w,$site) = @_; + my $e = $w->XEvent; + my ($seln,$t,$x,$y,$id,$flags) = unpack('LLSSLL',$e->A); + $w->MakeAtom($seln); + if ($flags & &ACK_FLAG) + { + Tk::catch { $w->SelectionGet('-selection'=>$seln,'_SUN_DRAGDROP_ACK') }; + } + my @targ = $w->SelectionGet(-selection => $seln,'TARGETS'); + $site->Apply(-dropcommand => $x, $y, $seln, SunDrop => \@targ); + if ($flags & &TRANSIENT_FLAG) + { + Tk::catch { $w->SelectionGet('-selection'=>$seln,'_SUN_DRAGDROP_DONE') }; + } + $w->configure('-relief' => $w->{'_DND_RELIEF_'}) if (defined $w->{'_DND_RELIEF_'}); + $site->Apply(-entercommand => $x, $y, 0); +} + +sub SunPreview +{ + my ($w,$site) = @_; + my $event = $w->XEvent; + my ($kind,$t,$x,$y,$id,$flags) = unpack('LLSSLL',$event->A); + $x -= $site->X; + $y -= $site->Y; + if ($kind == _enter) + { + $site->Callback(-entercommand => 1, $x, $y); + } + elsif ($kind == _leave) + { + $site->Callback(-entercommand => 0, $x, $y); + } + elsif ($kind == _motion) + { + $site->Callback(-motioncommand => $x, $y); + } +} + +sub InitSite +{ + my ($class,$site) = @_; + my $w = $site->widget; + $w->BindClientMessage('_SUN_DRAGDROP_TRIGGER',[\&SunDrop,$site]); + $w->BindClientMessage('_SUN_DRAGDROP_PREVIEW',[\&SunPreview,$site]); +} + +sub NoteSites +{ + my ($class,$t,$sites) = @_; + my $count = @$sites; + my @data = (0,0); + my ($wrapper,$offset) = $t->wrapper; + if ($t->viewable) + { + my $s; + my $i = 0; + my @win; + my $bx = $t->rootx; + my $by = $t->rooty - $offset; + $t->MakeWindowExist; + foreach $s (@$sites) + { + my $w = $s->widget; + if ($w->viewable) + { + $w->MakeWindowExist; + $data[1]++; + push(@data,${$w->WindowId}); # XID + push(@data,$i++); # Our 'tag' + push(@data,ENTERLEAVE|MOTION); # Flags + push(@data,0); # Kind is 'rect' + push(@data,1); # Number of rects + push(@data,$s->X-$bx,$s->Y-$by,$s->width,$s->height); # The rect + } + } + } + if ($data[1]) + { + $t->property('set', + '_SUN_DRAGDROP_INTEREST', # name + '_SUN_DRAGDROP_INTEREST', # type + 32, # format + \@data,$wrapper); # the data + } + else + { + $t->property('delete','_SUN_DRAGDROP_INTEREST',$wrapper); + } +} + + +1; diff --git a/Master/tlpkg/tlperl/lib/Tk/DragDrop/Win32Drop.pm b/Master/tlpkg/tlperl/lib/Tk/DragDrop/Win32Drop.pm new file mode 100644 index 00000000000..08a4656ecce --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/DragDrop/Win32Drop.pm @@ -0,0 +1,8 @@ +package Tk::DragDrop::Win32Drop; +# Dummy placeholder for symetry + +use vars qw($VERSION); +$VERSION = '4.004'; # $Id: //depot/Tkutf8/DragDrop/Win32Site/Win32Drop.pm#4 $ + +use Tk (); +1; diff --git a/Master/tlpkg/tlperl/lib/Tk/DragDrop/Win32Site.pm b/Master/tlpkg/tlperl/lib/Tk/DragDrop/Win32Site.pm new file mode 100644 index 00000000000..f45d06bc92b --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/DragDrop/Win32Site.pm @@ -0,0 +1,50 @@ +package Tk::DragDrop::Win32Site; + +use vars qw($VERSION); +$VERSION = sprintf '4.%03d', q$Revision: #8 $ =~ /\D(\d+)\s*$/; + +use Tk qw($XS_VERSION); +require DynaLoader; +require Tk::DropSite; + +use base qw(Tk::DropSite DynaLoader); + +bootstrap Tk::DragDrop::Win32Site; + +use strict; + +Tk::DropSite->Type('Win32'); + +sub WM_DROPFILES () {563} + +sub InitSite +{ + my ($class,$site) = @_; + my $w = $site->widget; + $w->BindClientMessage(WM_DROPFILES,[\&Win32Drop,$site]); + DragAcceptFiles($w,1); +} + +sub Win32Drop +{ + # print join(',',@_),"\n"; + my ($w,$site,$msg,$wParam,$lParam) = @_; + my ($x,$y,@files) = DropInfo($wParam); + my $cb = $site->{'-dropcommand'}; + $site->Apply(-entercommand => $x, $y, 1); + if ($cb) + { + foreach my $file (@files) + { + # print "$file @ $x,$y\n"; + $w->clipboardClear; + $w->clipboardAppend('--',$file); + $cb->Call('CLIPBOARD',Win32Drop => ['STRING'],$x,$y); + } + } + $site->Apply(-entercommand => $x, $y, 0); + return 0; +} + +1; +__END__ diff --git a/Master/tlpkg/tlperl/lib/Tk/DragDrop/XDNDDrop.pm b/Master/tlpkg/tlperl/lib/Tk/DragDrop/XDNDDrop.pm new file mode 100644 index 00000000000..7376c8d69c5 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/DragDrop/XDNDDrop.pm @@ -0,0 +1,145 @@ +package Tk::DragDrop::XDNDDrop; +use strict; +use vars qw($VERSION); +$VERSION = sprintf '4.%03d', q$Revision: #6 $ =~ /\D(\d+)\s*$/; +use base qw(Tk::DragDrop::Rect); + +sub XDND_PROTOCOL_VERSION () { 4 } + +Tk::DragDrop->Type('XDND'); + +sub NewDrag +{ + my ($class,$token) = @_; + $token->{$class} = {}; +} + +sub new +{ + my ($class,$token,$id,@prop) = @_; + my $ver = $token->InternAtom(shift(@prop)); + # warn "XDND version $ver ".join(' ',@prop)."\n"; + $ver = XDND_PROTOCOL_VERSION if $ver > XDND_PROTOCOL_VERSION; + my $site = bless { id => $id, token => $token, ver => $ver, state => 0, accept => \@prop}, $class; + my $w = $token->parent; + $w->BindClientMessage('XdndStatus',[$site => 'XdndStatus']); + $w->BindClientMessage('XdndFinished',[$site => 'XdndFinished']); + return $site; +} + +sub Drop +{ + my ($site,$token,$seln,$e) = @_; + my $w = $token->parent; + my $data = pack('LLLLL',oct($w->id),0,$e->t,0,0); + $w->SendClientMessage('XdndDrop',$site->{id},32,$data); +} + +sub FindSite +{ + my ($class,$token,$X,$Y) = @_; + my $id = $token->PointToWindow($X,$Y); + while ($id) + { + my @prop; + Tk::catch { @prop = $token->property('get','XdndAware', $id) }; + if (!$@ && shift(@prop) eq 'ATOM') + { + my $hash = $token->{$class}; + my $site = $hash->{$id}; + if (!defined $site) + { + $site = $class->new($token,$id,@prop); + $hash->{$id} = $site; + } + return $site; + } + $id = $token->PointToWindow($X,$Y,$id) + } + return undef; +} + +sub Enter +{ + my ($site,$token,$e) = @_; + my $w = $token->parent; + $token->InstallHandlers('XdndSelection'); + my $seln = $token->cget('-selection'); + my @targets = grep(!/^(TARGETS|MULTIPLE|TIMESTAMP)$/,reverse($token->SelectionGet('-selection'=> 'XdndSelection','TARGETS'))); + # print join(' ',@targets),"\n"; + my $flags = ($site->{ver} << 24); + my @atarg = map($token->InternAtom($_),@targets); + my $ntarg = @atarg; + if ($ntarg > 3) + { + $flags |= 1; + $w->property('set','XdndTypeList','ATOM',32,\@atarg); + splice(@atarg,3); + } + else + { + splice(@atarg,$ntarg,(0 x 3 - $ntarg)); + } + unshift(@atarg,oct($w->id),$flags); + # print join(' ',map(sprintf("%08X",$_),@atarg)),"\n"; + my $data = pack('LLLLL',@atarg); + $w->SendClientMessage('XdndEnter',$site->{id},32,$data); +} + +sub Leave +{ + my ($site,$token,$e) = @_; + my $w = $token->parent; + my $data = pack('LLLLL',oct($w->id), 0, 0, 0, 0); + $w->SendClientMessage('XdndLeave',$site->{id},32,$data); +} + +sub Motion +{ + my ($site,$token,$e) = @_; + my $X = $e->X; + my $Y = $e->Y; + my $w = $token->parent; + my $action = $token->InternAtom($site->{'action'} || 'XdndActionCopy'); + my @atarg = (oct($w->id),0,($X << 16) | $Y, $e->t, $action); + # print join(' ',map(sprintf("%08X",$_),@atarg)),"\n"; + my $data = pack('LLLLL',@atarg); + $w->SendClientMessage('XdndPosition',$site->{id},32,$data); +} + +sub XdndFinished +{ + my ($site) = @_; + my $token = $site->{token}; + # printf "XdndFinished $site\n", + $token->Done; +} + +sub XdndStatus +{ + my ($site) = @_; + my $token = $site->{token}; + my $w = $token->parent; + my $event = $w->XEvent; + my ($tid,$flags,$xy,$wh,$action) = unpack('LLLLL',$event->A); + $action = $w->GetAtomName($action) if $action; + $site->{flags} = $flags; + $site->{'X'} = $xy >> 16; + $site->{'Y'} = $xy & 0xFFFF; + $site->{'width'} = $wh >> 16; + $site->{'height'} = $wh & 0xFFFF; + #printf "XdndStatus $site targ=%x flags=%08X x=%d y=%d w=%d h=%d a=%s\n", + # $tid,$flags,$xy >> 16, $xy & 0xFFFF, $wh >> 16, $wh & 0xFFFF,$action; + if ($flags & 1) + { + $token->AcceptDrop; + } + else + { + $token->RejectDrop; + } +} + + +1; +__END__ diff --git a/Master/tlpkg/tlperl/lib/Tk/DragDrop/XDNDSite.pm b/Master/tlpkg/tlperl/lib/Tk/DragDrop/XDNDSite.pm new file mode 100644 index 00000000000..4ac75d63c40 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/DragDrop/XDNDSite.pm @@ -0,0 +1,159 @@ +package Tk::DragDrop::XDNDSite; +use strict; +use vars qw($VERSION); +$VERSION = sprintf '4.%03d', q$Revision: #6 $ =~ /\D(\d+)\s*$/; +use base qw(Tk::DropSite); + +sub XDND_PROTOCOL_VERSION () { 4 } + +Tk::DropSite->Type('XDND'); + +sub InitSite +{my ($class,$site) = @_; + my $w = $site->widget; +} + +sub XdndEnter +{ + my ($t,$sites) = @_; + my $event = $t->XEvent; + my ($src,$flags,@types) = unpack('LLLLL',$event->A); + my $ver = ($flags >> 24) & 0xFF; + if ($flags & 1) + { + my @prop; + Tk::catch { @prop = $t->property('get','XdndTypeList',$src) }; + @types = @prop if (!$@ && shift(@prop) eq 'ATOM'); + } + else + { + $t->MakeAtom(@types); + } + # print "XdndEnter $src $ver @types\n"; + $t->{"XDND$src"} = { ver => $ver, types => \@types }; +} + +sub XdndLeave +{ + my ($t,$sites) = @_; + my $event = $t->XEvent; + my ($src,$flags,@types) = unpack('LLLLL',$event->A); + # print "XdndLeave $src\n"; + my $info = $t->{"XDND$src"}; + if ($info) + { + my $over = $info->{site}; + if ($over) + { + my $X = $info->{X}; + my $Y = $info->{Y}; + $over->Apply(-entercommand => $X, $Y, 0) + } + } + delete $t->{"XDND$src"}; +} + +sub XdndPosition +{ + my ($t,$sites) = @_; + my $event = $t->XEvent; + my ($src,$flags,$xy,$time,$action) = unpack('LLLLL',$event->A); + $t->MakeAtom($action); + my $X = $xy >> 16; + my $Y = $xy & 0xFFFF; + my $info = $t->{"XDND$src"}; + $info->{X} = $X; + $info->{Y} = $Y; + $info->{action} = $action; + $info->{t} = $time; + my ($id) = $t->wrapper; + my $sxy = 0; + my $swh = 0; + my $sflags = 0; + my $saction = 0; + my $over = $info->{site}; + foreach my $site (@$sites) + { + if ($site->Over($X,$Y)) + { + $sxy = ($site->X << 16) | $site->Y; + $swh = ($site->width << 16) | $site->height; + $saction = $action; + $sflags |= 1; + if ($over) + { + if ($over == $site) + { + $site->Apply(-motioncommand => $X, $Y); + } + else + { + $over->Apply(-entercommand => $X, $Y, 0); + $site->Apply(-entercommand => $X, $Y, 1); + } + } + else + { + $site->Apply(-entercommand => $X, $Y, 1); + } + $info->{site} = $site; + last; + } + } + unless ($sflags & 1) + { + if ($over) + { + $over->Apply(-entercommand => $X, $Y, 0) + } + delete $info->{site}; + } + my $data = pack('LLLLL',$id,$sflags,$sxy,$swh,$action); + $t->SendClientMessage('XdndStatus',$src,32,$data); +} + +sub XdndDrop +{ + my ($t,$sites) = @_; + my $event = $t->XEvent; + my ($src,$flags,$time,$res1,$res2) = unpack('LLLLL',$event->A); + my $info = $t->{"XDND$src"}; + my $sflags = 0; + my $action = 0; + if ($info) + { + $info->{t} = $time; + my $site = $info->{'site'}; + if ($site) + { + my $X = $info->{'X'}; + my $Y = $info->{'Y'}; + $action = $info->{action}; + $site->Apply(-dropcommand => $X, $Y, 'XdndSelection',$action,$info->{types}); + $site->Apply(-entercommand => $X, $Y, 0); + } + } + my ($id) = $t->wrapper; + my $data = pack('LLLLL',$id,$sflags,$action,0,0); + $t->SendClientMessage('XdndFinished',$src,32,$data); +} + +sub NoteSites +{my ($class,$t,$sites) = @_; + my ($wrapper) = $t->wrapper; + if (@$sites) + { + $t->BindClientMessage('XdndLeave',[\&XdndLeave,$sites]); + $t->BindClientMessage('XdndEnter',[\&XdndEnter,$sites]); + $t->BindClientMessage('XdndPosition',[\&XdndPosition,$sites]); + $t->BindClientMessage('XdndDrop',[\&XdndDrop,$sites]); + $t->property('set','XdndAware','ATOM',32,[XDND_PROTOCOL_VERSION],$wrapper); + } + else + { + $t->property('delete','XdndAware',$wrapper); + } +} + +1; +__END__ diff --git a/Master/tlpkg/tlperl/lib/Tk/DropSite.pm b/Master/tlpkg/tlperl/lib/Tk/DropSite.pm new file mode 100644 index 00000000000..3519c108384 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/DropSite.pm @@ -0,0 +1,257 @@ +package Tk::DropSite; +require Tk::DragDrop::Common; +require Tk::DragDrop::Rect; + +use vars qw($VERSION); +$VERSION = sprintf '4.%03d', q$Revision: #7 $ =~ /\D(\d+)\s*$/; + +use base qw(Tk::DragDrop::Common Tk::DragDrop::Rect); + +Construct Tk::Widget 'DropSite'; + +use strict; +use vars qw(%type @types); + +Tk::DragDrop->Tk::DragDrop::Common::Type('Local'); + +my @toplevels; + +BEGIN +{ + # Are these really methods of Tk::DragDrop::Rect ? + no strict 'refs'; + foreach my $name (qw(x y X Y width height widget)) + { + my $key = $name; + *{"$key"} = sub { shift->{$key} }; + } +} + +# Dropping side API - really only here for Local drops +# inheritance is a mess right now. + +sub NewDrag +{ + my ($class,$token) = @_; + # No need to clear cached sites we see live data +} + +sub SiteList +{ + # this should be inheritable - so that receive side of XDND can re-use it. + my ($class,$widget) = @_; + my $t; + my @list; + foreach $t (@toplevels) + { + my $sites = $t->{'DropSites'}; + if ($sites) + { + $sites = $sites->{'Local'}; + push(@list,@{$sites}) if ($sites); + } + } + return @list; +} + +sub Apply +{ + my $site = shift; + my $name = shift; + my $cb = $site->{$name}; + if ($cb) + { + my $X = shift; + my $Y = shift; + $cb->Call(@_,$X - $site->X, $Y - $site->Y); + } +} + +sub Drop +{ + my ($site,$token,$seln,$event) = @_; + my $X = $event->X; + my $Y = $event->Y; + my @targ = $token->SelectionGet(-selection => $seln,'TARGETS'); + $site->Apply(-dropcommand => $X, $Y, $seln,'LocalDrop',\@targ); + $site->Apply(-entercommand => $X, $Y, 0); + $token->Done; +} + +sub Enter +{ + my ($site,$token,$event) = @_; + $token->AcceptDrop; + $site->Apply(-entercommand => $event->X, $event->Y, 1); +} + +sub Leave +{ + my ($site,$token,$event) = @_; + $token->RejectDrop; + $site->Apply(-entercommand => $event->X, $event->Y, 0); +} + +sub Motion +{ + my ($site,$token,$event) = @_; + $site->Apply(-motioncommand => $event->X, $event->Y); +} + +# This is receive side API. + +sub NoteSites +{ + my ($class,$t,$sites) = @_; + unless (grep($_ == $t,@toplevels)) + { + $Tk::DragDrop::types{'Local'} = $class if (@$sites); + push(@toplevels,$t); + $t->OnDestroy(sub { @toplevels = grep($_ != $t,@toplevels) }); + } +} + +sub UpdateDropSites +{ + my ($t) = @_; + $t->{'DropUpdate'} = 0; + foreach my $type (@types) + { + my $sites = $t->{'DropSites'}->{$type}; + if ($sites && @$sites) + { + my $class = $type{$type}; + $class->NoteSites($t,$sites); + } + } +} + +sub QueueDropSiteUpdate +{ + my $obj = shift; + my $class = ref($obj); + my $t = $obj->widget->toplevel; + unless ($t->{'DropUpdate'}) + { + $t->{'DropUpdate'} = 1; + $t->afterIdle(sub { UpdateDropSites($t) }); + } +} + +sub delete +{ + my ($obj) = @_; + my $w = $obj->widget; + $w->bindtags([grep($_ ne $obj,$w->bindtags)]); + my $t = $w->toplevel; + foreach my $type (@{$obj->{'-droptypes'}}) + { + my $a = $t->{'DropSites'}->{$type}; + @$a = grep($_ ne $obj,@$a); + } + $obj->QueueDropSiteUpdate; +} + +sub DropSiteUpdate +{ + # Note size of widget and arrange to update properties etc. + my $obj = shift; + my $w = $obj->widget; + $obj->{'x'} = $w->X; + $obj->{'y'} = $w->Y; + $obj->{'X'} = $w->rootx; + $obj->{'Y'} = $w->rooty; + $obj->{'width'} = $w->Width; + $obj->{'height'} = $w->Height; + $obj->QueueDropSiteUpdate; +} + +sub TopSiteUpdate +{ + my ($t) = @_; + foreach my $type (@types) + { + my $sites = $t->{'DropSites'}->{$type}; + if ($sites && @$sites) + { + my $site; + foreach $site (@$sites) + { + $site->DropSiteUpdate; + } + } + } +} + +sub Callback +{ + my $obj = shift; + my $key = shift; + my $cb = $obj->{$key}; + $cb->Call(@_) if (defined $cb); +} + +sub InitSite +{ + my ($class,$site) = @_; + # Tk::DragDrop->Type('Local'); +} + +sub new +{ + my ($class,$w,%args) = @_; + my $t = $w->toplevel; + $args{'widget'} = $w; + if (exists $args{'-droptypes'}) + { + # Convert single type to array-of-one + $args{'-droptypes'} = [$args{'-droptypes'}] unless (ref $args{'-droptypes'}); + } + else + { + # Default to all known types. + $args{'-droptypes'} = \@types; + } + my ($key,$val); + while (($key,$val) = each %args) + { + if ($key =~ /command$/) + { + $val = Tk::Callback->new($val); + $args{$key} = $val; + } + } + my $obj = bless \%args,$class; + unless (exists $t->{'DropSites'}) + { + $t->{'DropSites'} = {}; + $t->{'DropUpdate'} = 0; + } + my $type; + foreach $type (@{$args{'-droptypes'}}) + { + Tk::DropSite->import($type) unless (exists $type{$type}); + my $class = $type{$type}; + $class->InitSite($obj); + # Should this be indexed by type or class ? + unless (exists $t->{'DropSites'}->{$type}) + { + $t->{'DropSites'}->{$type} = []; + } + push(@{$t->{'DropSites'}->{$type}},$obj); + } + $w->OnDestroy([$obj,'delete']); + $obj->DropSiteUpdate; + $w->bindtags([$w->bindtags,$obj]); + $w->Tk::bind($obj,'<Map>',[$obj,'DropSiteUpdate']); + $w->Tk::bind($obj,'<Unmap>',[$obj,'DropSiteUpdate']); + $w->Tk::bind($obj,'<Configure>',[$obj,'DropSiteUpdate']); + $t->Tk::bind($class,'<Configure>',[\&TopSiteUpdate,$t]); + unless (grep($_ eq $class,$t->bindtags)) + { + $t->bindtags([$t->bindtags,$class]); + } + return $obj; +} + +1; diff --git a/Master/tlpkg/tlperl/lib/Tk/DummyEncode.pm b/Master/tlpkg/tlperl/lib/Tk/DummyEncode.pm new file mode 100644 index 00000000000..5ead808405d --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/DummyEncode.pm @@ -0,0 +1,46 @@ +package Tk::DummyEncode; + +use vars qw($VERSION); +$VERSION = '4.007'; # $Id: //depot/Tkutf8/Tk/DummyEncode.pm#7 $ + +sub getEncoding +{ + my ($class,$name) = @_; + return undef unless ($name =~ /(iso8859-1|X11ControlChars)/); + my $pkg = $name; + $pkg =~ s/\W+/_/g; + return bless {Name => $name},$class.'::'.$pkg; +} + +package Tk::DummyEncode::iso8859_1; +sub encode +{ + my ($obj,$uni,$chk) = @_; + $_[1] = '' if $chk; + return $uni; +} + +sub decode +{ + my ($obj,$byt,$chk) = @_; + $_[1] += '' if $chk; + return $byt; +} + +package Tk::DummyEncode::X11ControlChars; +sub encode +{ + my ($obj,$uni,$chk) = @_; + my $str = ''; + foreach my $ch (split(//,$uni)) + { + $str .= sprintf("\\x{%x}",ord($ch)); + } + $_[1] = '' if $chk; + return $str; +} + +1; + +__END__ diff --git a/Master/tlpkg/tlperl/lib/Tk/English.pm b/Master/tlpkg/tlperl/lib/Tk/English.pm new file mode 100644 index 00000000000..de640376580 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/English.pm @@ -0,0 +1,307 @@ +package Tk::English; + +require Exporter; + +use vars qw($VERSION); +$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/English.pm#6 $ + +use base qw(Exporter); + +# This file is generated automatically by pTk/makeenglish from Tk distribution. + + +@EXPORT = qw( + &ABOVE &ACTIVATE &ACTIVE &ADD &ADDTAG &ADJUST &AFTER &ALL &ANCHOR &APPEND + &APPLY &ARROW1 &ARROW2 &ASCII &ASPECT &AUTO &BASELINE &BBOX &BEFORE &BELOW + &BEVEL &BIND &BITMAP &BLANK &BOTH &BOTTOM &BUTT &CANVASX &CANVASY &CAPTURE + &CASCADE &CENTER &CGET &CHAR &CHARS &CHECKBUTTON &CHILDREN &CLEAR &CLIENT + &CLONE &CLOSEST &COLOR &COLORMAPWINDOWS &COLUMN &COLUMNCONFIGURE &COMMAND + &COMPARE &CONFIGURE &COORDS © &CREATE &CURRENT &CURSELECTION &DATA + &DCHARS &DEACTIVATE &DEBUG &DECORATIONS &DECREASING &DEFAULT &DEICONIFY + &DELETE &DELTA &DESELECT &DLINEINFO &DOWN &DRAGSITE &DRAGTO &DROPSITE &DTAG + &DUMP &ENCLOSED &END &ENTRY &ENTRYCGET &ENTRYCONFIGURE &EVAL &EXISTS &EXPAND + &FILL &FILLX &FILLY &FIND &FIRST &FLASH &FLAT &FOCUS &FOCUSMODEL &FOCUSNEXT + &FOCUSPREV &FORGET &FRACTION &FRAME &FROM &GENERATE &GEOMETRY &GEOMETRYINFO + &GET &GETTAGS &GRAVITY &GRAY &GRID &GROOVE &GROUP &HANDLE &HEAD &HEIGHT + &HIDDEN &HIDE &HORIZONTAL &ICONBITMAP &ICONIFY &ICONMASK &ICONNAME + &ICONPOSITION &ICONWINDOW &ICURSOR &IDENTIFY &IDLETASKS &IGNORE &IMAGE + &INCLUDES &INCREASING &INDEX &INFO &INSERT &INSIDE &INTEGER &INTERACTIVE + &INVOKE &ISMWMRUNNING &ITEM &ITEMCGET &ITEMCONFIGURE &LAST &LEFT &LINE + &LINECONFIGURE &LINEEND &LINES &LINESTART &LIST &LOCATION &LOWER &MARK &MAX + &MAXSIZE &MENUBAR &MINSIZE &MITER &MONOCHROME &MOVE &MOVETO &NAMES &NEAREST + &NEW &NEXT &NEXTRANGE &NONE &NORMAL &NOW &OFFSPRINGS &OUTSIDE &OVERLAPPING + &OVERRIDEREDIRECT &OWN &PADX &PADY &PAGECGET &PAGECONFIGURE &PAGES &PARENT + &PASSIVE &POSITION &POSITIONFROM &POST &POSTCASCADE &POSTSCRIPT &PRESENT + &PREV &PREVIOUS &PREVRANGE &PROGRAM &PROJECTING &PROPAGATE &PROTOCOL &PUT + &RADIOBUTTON &RAISE &RAISED &RANGE &RANGES &READ &READFILE &REAL &RECORD + &REDITHER &REFCOUNT &RELEASE &REMOVE &RESIZABLE &RIDGE &RIGHT &ROOT &ROUND + &ROW &ROWCONFIGURE &ROWS &SAVEUNDER &SCALE &SCAN &SCROLL &SEARCH &SEE + &SELECT &SELECTION &SEPARATOR &SET &SHOW &SIBLINGS &SIZE &SIZEFROM &SLAVES + &SLIDER &SOLID &SPACE &STATE &STATUS &SUNKEN &TAG &TAIL &TEAROFF &TEXT + &TITLE &TO &TOGGLE &TOP &TRACING &TRANSIENT &TRANSIENTFOR &TYPE &TYPES + &UNITS &UNPACK &UNPOST &UNSET &UP &USER &VARIABLE &VERTICAL &VISIBILITY + &WIDTH &WINDOW &WITHDRAW &WITHTAG &WORDEND &WORDSTART &WRITE &XVIEW + &YPOSITION &YVIEW +); +sub ABOVE () { 'above' } +sub ACTIVATE () { 'activate' } +sub ACTIVE () { 'active' } +sub ADD () { 'add' } +sub ADDTAG () { 'addtag' } +sub ADJUST () { 'adjust' } +sub AFTER () { 'after' } +sub ALL () { 'all' } +sub ANCHOR () { 'anchor' } +sub APPEND () { 'append' } +sub APPLY () { 'apply' } +sub ARROW1 () { 'arrow1' } +sub ARROW2 () { 'arrow2' } +sub ASCII () { 'ascii' } +sub ASPECT () { 'aspect' } +sub AUTO () { 'auto' } +sub BASELINE () { 'baseline' } +sub BBOX () { 'bbox' } +sub BEFORE () { 'before' } +sub BELOW () { 'below' } +sub BEVEL () { 'bevel' } +sub BIND () { 'bind' } +sub BITMAP () { 'bitmap' } +sub BLANK () { 'blank' } +sub BOTH () { 'both' } +sub BOTTOM () { 'bottom' } +sub BUTT () { 'butt' } +sub CANVASX () { 'canvasx' } +sub CANVASY () { 'canvasy' } +sub CAPTURE () { 'capture' } +sub CASCADE () { 'cascade' } +sub CENTER () { 'center' } +sub CGET () { 'cget' } +sub CHAR () { 'char' } +sub CHARS () { 'chars' } +sub CHECKBUTTON () { 'checkbutton' } +sub CHILDREN () { 'children' } +sub CLEAR () { 'clear' } +sub CLIENT () { 'client' } +sub CLONE () { 'clone' } +sub CLOSEST () { 'closest' } +sub COLOR () { 'color' } +sub COLORMAPWINDOWS () { 'colormapwindows' } +sub COLUMN () { 'column' } +sub COLUMNCONFIGURE () { 'columnconfigure' } +sub COMMAND () { 'command' } +sub COMPARE () { 'compare' } +sub CONFIGURE () { 'configure' } +sub COORDS () { 'coords' } +sub COPY () { 'copy' } +sub CREATE () { 'create' } +sub CURRENT () { 'current' } +sub CURSELECTION () { 'curselection' } +sub DATA () { 'data' } +sub DCHARS () { 'dchars' } +sub DEACTIVATE () { 'deactivate' } +sub DEBUG () { 'debug' } +sub DECORATIONS () { 'decorations' } +sub DECREASING () { 'decreasing' } +sub DEFAULT () { 'default' } +sub DEICONIFY () { 'deiconify' } +sub DELETE () { 'delete' } +sub DELTA () { 'delta' } +sub DESELECT () { 'deselect' } +sub DLINEINFO () { 'dlineinfo' } +sub DOWN () { 'down' } +sub DRAGSITE () { 'dragsite' } +sub DRAGTO () { 'dragto' } +sub DROPSITE () { 'dropsite' } +sub DTAG () { 'dtag' } +sub DUMP () { 'dump' } +sub ENCLOSED () { 'enclosed' } +sub END () { 'end' } +sub ENTRY () { 'entry' } +sub ENTRYCGET () { 'entrycget' } +sub ENTRYCONFIGURE () { 'entryconfigure' } +sub EVAL () { 'eval' } +sub EXISTS () { 'exists' } +sub EXPAND () { 'expand' } +sub FILL () { 'fill' } +sub FILLX () { 'fillx' } +sub FILLY () { 'filly' } +sub FIND () { 'find' } +sub FIRST () { 'first' } +sub FLASH () { 'flash' } +sub FLAT () { 'flat' } +sub FOCUS () { 'focus' } +sub FOCUSMODEL () { 'focusmodel' } +sub FOCUSNEXT () { 'focusnext' } +sub FOCUSPREV () { 'focusprev' } +sub FORGET () { 'forget' } +sub FRACTION () { 'fraction' } +sub FRAME () { 'frame' } +sub FROM () { 'from' } +sub GENERATE () { 'generate' } +sub GEOMETRY () { 'geometry' } +sub GEOMETRYINFO () { 'geometryinfo' } +sub GET () { 'get' } +sub GETTAGS () { 'gettags' } +sub GRAVITY () { 'gravity' } +sub GRAY () { 'gray' } +sub GRID () { 'grid' } +sub GROOVE () { 'groove' } +sub GROUP () { 'group' } +sub HANDLE () { 'handle' } +sub HEAD () { 'head' } +sub HEIGHT () { 'height' } +sub HIDDEN () { 'hidden' } +sub HIDE () { 'hide' } +sub HORIZONTAL () { 'horizontal' } +sub ICONBITMAP () { 'iconbitmap' } +sub ICONIFY () { 'iconify' } +sub ICONMASK () { 'iconmask' } +sub ICONNAME () { 'iconname' } +sub ICONPOSITION () { 'iconposition' } +sub ICONWINDOW () { 'iconwindow' } +sub ICURSOR () { 'icursor' } +sub IDENTIFY () { 'identify' } +sub IDLETASKS () { 'idletasks' } +sub IGNORE () { 'ignore' } +sub IMAGE () { 'image' } +sub INCLUDES () { 'includes' } +sub INCREASING () { 'increasing' } +sub INDEX () { 'index' } +sub INFO () { 'info' } +sub INSERT () { 'insert' } +sub INSIDE () { 'inside' } +sub INTEGER () { 'integer' } +sub INTERACTIVE () { 'interactive' } +sub INVOKE () { 'invoke' } +sub ISMWMRUNNING () { 'ismwmrunning' } +sub ITEM () { 'item' } +sub ITEMCGET () { 'itemcget' } +sub ITEMCONFIGURE () { 'itemconfigure' } +sub LAST () { 'last' } +sub LEFT () { 'left' } +sub LINE () { 'line' } +sub LINECONFIGURE () { 'lineconfigure' } +sub LINEEND () { 'lineend' } +sub LINES () { 'lines' } +sub LINESTART () { 'linestart' } +sub LIST () { 'list' } +sub LOCATION () { 'location' } +sub LOWER () { 'lower' } +sub MARK () { 'mark' } +sub MAX () { 'max' } +sub MAXSIZE () { 'maxsize' } +sub MENUBAR () { 'menubar' } +sub MINSIZE () { 'minsize' } +sub MITER () { 'miter' } +sub MONOCHROME () { 'monochrome' } +sub MOVE () { 'move' } +sub MOVETO () { 'moveto' } +sub NAMES () { 'names' } +sub NEAREST () { 'nearest' } +sub NEW () { 'new' } +sub NEXT () { 'next' } +sub NEXTRANGE () { 'nextrange' } +sub NONE () { 'none' } +sub NORMAL () { 'normal' } +sub NOW () { 'now' } +sub OFFSPRINGS () { 'offsprings' } +sub OUTSIDE () { 'outside' } +sub OVERLAPPING () { 'overlapping' } +sub OVERRIDEREDIRECT () { 'overrideredirect' } +sub OWN () { 'own' } +sub PADX () { 'padx' } +sub PADY () { 'pady' } +sub PAGECGET () { 'pagecget' } +sub PAGECONFIGURE () { 'pageconfigure' } +sub PAGES () { 'pages' } +sub PARENT () { 'parent' } +sub PASSIVE () { 'passive' } +sub POSITION () { 'position' } +sub POSITIONFROM () { 'positionfrom' } +sub POST () { 'post' } +sub POSTCASCADE () { 'postcascade' } +sub POSTSCRIPT () { 'postscript' } +sub PRESENT () { 'present' } +sub PREV () { 'prev' } +sub PREVIOUS () { 'previous' } +sub PREVRANGE () { 'prevrange' } +sub PROGRAM () { 'program' } +sub PROJECTING () { 'projecting' } +sub PROPAGATE () { 'propagate' } +sub PROTOCOL () { 'protocol' } +sub PUT () { 'put' } +sub RADIOBUTTON () { 'radiobutton' } +sub RAISE () { 'raise' } +sub RAISED () { 'raised' } +sub RANGE () { 'range' } +sub RANGES () { 'ranges' } +sub READ () { 'read' } +sub READFILE () { 'readfile' } +sub REAL () { 'real' } +sub RECORD () { 'record' } +sub REDITHER () { 'redither' } +sub REFCOUNT () { 'refcount' } +sub RELEASE () { 'release' } +sub REMOVE () { 'remove' } +sub RESIZABLE () { 'resizable' } +sub RIDGE () { 'ridge' } +sub RIGHT () { 'right' } +sub ROOT () { 'root' } +sub ROUND () { 'round' } +sub ROW () { 'row' } +sub ROWCONFIGURE () { 'rowconfigure' } +sub ROWS () { 'rows' } +sub SCALE () { 'scale' } +sub SCAN () { 'scan' } +sub SCROLL () { 'scroll' } +sub SEARCH () { 'search' } +sub SEE () { 'see' } +sub SELECT () { 'select' } +sub SELECTION () { 'selection' } +sub SEPARATOR () { 'separator' } +sub SET () { 'set' } +sub SHOW () { 'show' } +sub SIBLINGS () { 'siblings' } +sub SIZE () { 'size' } +sub SIZEFROM () { 'sizefrom' } +sub SLAVES () { 'slaves' } +sub SLIDER () { 'slider' } +sub SOLID () { 'solid' } +sub SPACE () { 'space' } +sub STATE () { 'state' } +sub STATUS () { 'status' } +sub SUNKEN () { 'sunken' } +sub TAG () { 'tag' } +sub TAIL () { 'tail' } +sub TEAROFF () { 'tearoff' } +sub TEXT () { 'text' } +sub TITLE () { 'title' } +sub TO () { 'to' } +sub TOGGLE () { 'toggle' } +sub TOP () { 'top' } +sub TRACING () { 'tracing' } +sub TRANSIENT () { 'transient' } +sub TRANSIENTFOR () { 'transientfor' } +sub TYPE () { 'type' } +sub TYPES () { 'types' } +sub UNITS () { 'units' } +sub UNPACK () { 'unpack' } +sub UNPOST () { 'unpost' } +sub UNSET () { 'unset' } +sub UP () { 'up' } +sub USER () { 'user' } +sub VARIABLE () { 'variable' } +sub VERTICAL () { 'vertical' } +sub VISIBILITY () { 'visibility' } +sub WIDTH () { 'width' } +sub WINDOW () { 'window' } +sub WITHDRAW () { 'withdraw' } +sub WITHTAG () { 'withtag' } +sub WORDEND () { 'wordend' } +sub WORDSTART () { 'wordstart' } +sub WRITE () { 'write' } +sub XVIEW () { 'xview' } +sub YPOSITION () { 'yposition' } +sub YVIEW () { 'yview' } + +1; diff --git a/Master/tlpkg/tlperl/lib/Tk/Entry.pm b/Master/tlpkg/tlperl/lib/Tk/Entry.pm new file mode 100644 index 00000000000..51b3f0c6767 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Entry.pm @@ -0,0 +1,615 @@ +package Tk::Entry; + +# Converted from entry.tcl -- +# +# This file defines the default bindings for Tk entry widgets. +# +# @(#) entry.tcl 1.22 94/12/17 16:05:14 +# +# Copyright (c) 1992-1994 The Regents of the University of California. +# Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved. +# This program is free software; you can redistribute it and/or + +use vars qw($VERSION); +use strict; +$VERSION = sprintf '4.%03d',q$Revision: #17 $ =~ /#(\d+)/; + +# modify it under the same terms as Perl itself, subject +# to additional disclaimer in license.terms due to partial +# derivation from Tk4.0 sources. + +use Tk::Widget (); +use Tk::Clipboard (); +use base qw(Tk::Clipboard Tk::Widget); + +import Tk qw(Ev $XS_VERSION); + +Construct Tk::Widget 'Entry'; + +bootstrap Tk::Entry; + +sub Tk_cmd { \&Tk::entry } + +Tk::Methods('bbox','delete','get','icursor','index','insert','scan', + 'selection','validate','xview'); + +use Tk::Submethods ( 'selection' => [qw(clear range adjust present to from)], + 'xview' => [qw(moveto scroll)], + ); + +sub wordstart +{my ($w,$pos) = @_; + my $string = $w->get; + $pos = $w->index('insert')-1 unless(defined $pos); + $string = substr($string,0,$pos); + $string =~ s/\S*$//; + length $string; +} + +sub wordend +{my ($w,$pos) = @_; + my $string = $w->get; + my $anc = length $string; + $pos = $w->index('insert') unless(defined $pos); + $string = substr($string,$pos); + $string =~ s/^(?:((?=\s)\s*|(?=\S)\S*))//x; + $anc - length($string); +} + +sub deltainsert +{ + my ($w,$d) = @_; + return $w->index('insert')+$d; +} + +# +# Bind -- +# This procedure is invoked the first time the mouse enters an +# entry widget or an entry widget receives the input focus. It creates +# all of the class bindings for entries. +# +# Arguments: +# event - Indicates which event caused the procedure to be invoked +# (Enter or FocusIn). It is used so that we can carry out +# the functions of that event in addition to setting up +# bindings. +sub ClassInit +{ + my ($class,$mw) = @_; + + $class->SUPER::ClassInit($mw); + + # <<Cut>>, <<Copy>> and <<Paste>> defined in Tk::Clipboard + $mw->bind($class,'<<Clear>>' => sub { + my $w = shift; + $w->delete("sel.first", "sel.last"); + }); + $mw->bind($class,'<<PasteSelection>>' => [sub { + my($w, $x) = @_; + # XXX logic in Tcl/Tk version screwed up? + if (!$Tk::strictMotif && !$Tk::mouseMoved) { + $w->Paste($x); + } + }, Ev('x')]); + + # Standard Motif bindings: + # The <Escape> binding is different from the Tcl/Tk version: + $mw->bind($class,'<Escape>','selectionClear'); + + $mw->bind($class,'<1>',['Button1',Ev('x'),Ev('y')]); + $mw->bind($class,'<ButtonRelease-1>',['Button1Release',Ev('x'),Ev('y')]); + $mw->bind($class,'<B1-Motion>',['Motion',Ev('x'),Ev('y')]); + + $mw->bind($class,'<Double-1>',['MouseSelect',Ev('x'),'word','sel.first']); + $mw->bind($class,'<Double-Shift-1>',['MouseSelect',Ev('x'),'word']); + $mw->bind($class,'<Triple-1>',['MouseSelect',Ev('x'),'line',0]); + $mw->bind($class,'<Triple-Shift-1>',['MouseSelect',Ev('x'),'line']); + + $mw->bind($class,'<Shift-1>','Shift_1'); + + + $mw->bind($class,'<B1-Leave>',['AutoScan',Ev('x')]); + $mw->bind($class,'<B1-Enter>','CancelRepeat'); + $mw->bind($class,'<Control-1>','Control_1'); + $mw->bind($class,'<Left>', ['SetCursor',Ev('deltainsert',-1)]); + $mw->bind($class,'<Right>',['SetCursor',Ev('deltainsert',1)]); + $mw->bind($class,'<Shift-Left>',['KeySelect',Ev('deltainsert',-1)]); + $mw->bind($class,'<Shift-Right>',['KeySelect',Ev('deltainsert',1)]); + $mw->bind($class,'<Control-Left>',['SetCursor',Ev(['wordstart'])]); + $mw->bind($class,'<Control-Right>',['SetCursor',Ev(['wordend'])]); + $mw->bind($class,'<Shift-Control-Left>',['KeySelect',Ev(['wordstart'])]); + $mw->bind($class,'<Shift-Control-Right>',['KeySelect',Ev(['wordend'])]); + $mw->bind($class,'<Home>',['SetCursor',0]); + $mw->bind($class,'<Shift-Home>',['KeySelect',0]); + $mw->bind($class,'<End>',['SetCursor','end']); + $mw->bind($class,'<Shift-End>',['KeySelect','end']); + $mw->bind($class,'<Delete>','Delete'); + + $mw->bind($class,'<BackSpace>','Backspace'); + + $mw->bind($class,'<Control-space>',['selectionFrom','insert']); + $mw->bind($class,'<Select>',['selectionFrom','insert']); + $mw->bind($class,'<Control-Shift-space>',['selectionAdjust','insert']); + $mw->bind($class,'<Shift-Select>',['selectionAdjust','insert']); + + $mw->bind($class,'<Control-slash>',['selectionRange',0,'end']); + $mw->bind($class,'<Control-backslash>','selectionClear'); + + # $class->clipboardOperations($mw,qw[Copy Cut Paste]); + + $mw->bind($class,'<KeyPress>', ['Insert',Ev('A')]); + + # Ignore all Alt, Meta, and Control keypresses unless explicitly bound. + # Otherwise, if a widget binding for one of these is defined, the + # <KeyPress> class binding will also fire and insert the character, + # which is wrong. Ditto for Return, and Tab. + + $mw->bind($class,'<Alt-KeyPress>' ,'NoOp'); + $mw->bind($class,'<Meta-KeyPress>' ,'NoOp'); + $mw->bind($class,'<Control-KeyPress>' ,'NoOp'); + $mw->bind($class,'<Return>' ,'NoOp'); + $mw->bind($class,'<KP_Enter>' ,'NoOp'); + $mw->bind($class,'<Tab>' ,'NoOp'); + if ($mw->windowingsystem =~ /^(?:classic|aqua)$/) + { + $mw->bind($class,'<Command-KeyPress>', 'NoOp'); + } + + # On Windows, paste is done using Shift-Insert. Shift-Insert already + # generates the <<Paste>> event, so we don't need to do anything here. + if ($Tk::platform ne 'MSWin32') + { + $mw->bind($class,'<Insert>','InsertSelection'); + } + + if (!$Tk::strictMotif) + { + # Additional emacs-like bindings: + $mw->bind($class,'<Control-a>',['SetCursor',0]); + $mw->bind($class,'<Control-b>',['SetCursor',Ev('deltainsert',-1)]); + $mw->bind($class,'<Control-d>',['delete','insert']); + $mw->bind($class,'<Control-e>',['SetCursor','end']); + $mw->bind($class,'<Control-f>',['SetCursor',Ev('deltainsert',1)]); + $mw->bind($class,'<Control-h>','Backspace'); + $mw->bind($class,'<Control-k>',['delete','insert','end']); + + $mw->bind($class,'<Control-t>','Transpose'); + + # XXX The original Tcl/Tk bindings use NextWord/PreviousWord instead + $mw->bind($class,'<Meta-b>',['SetCursor',Ev(['wordstart'])]); + $mw->bind($class,'<Meta-d>',['delete','insert',Ev(['wordend'])]); + $mw->bind($class,'<Meta-f>',['SetCursor',Ev(['wordend'])]); + $mw->bind($class,'<Meta-BackSpace>',['delete',Ev(['wordstart']),'insert']); + $mw->bind($class,'<Meta-Delete>',['delete',Ev(['wordstart']),'insert']); + + # A few additional bindings from John Ousterhout. +# XXX conflicts with <<Copy>>: $mw->bind($class,'<Control-w>',['delete',Ev(['wordstart']),'insert']); + $mw->bind($class,'<2>','Button_2'); + $mw->bind($class,'<B2-Motion>','B2_Motion'); +# XXX superseded by <<PasteSelection>>: $mw->bind($class,'<ButtonRelease-2>','ButtonRelease_2'); + } + return $class; +} + + +sub Shift_1 +{ + my $w = shift; + my $Ev = $w->XEvent; + $Tk::selectMode = 'char'; + $w->selectionAdjust('@' . $Ev->x) +} + + +sub Control_1 +{ + my $w = shift; + my $Ev = $w->XEvent; + $w->icursor('@' . $Ev->x) +} + + +sub Delete +{ + my $w = shift; + if ($w->selectionPresent) + { + $w->deleteSelected + } + else + { + $w->delete('insert') + } +} + + +sub InsertSelection +{ + my $w = shift; + eval {local $SIG{__DIE__}; $w->Insert($w->GetSelection)} +} + + +# Original is ::tk::EntryScanMark +sub Button_2 +{ + my $w = shift; + my $Ev = $w->XEvent; + $w->scan('mark',$Ev->x); + $Tk::x = $Ev->x; + $Tk::y = $Ev->y; + $Tk::mouseMoved = 0 +} + + +# Original is ::tk::EntryScanDrag +sub B2_Motion +{ + my $w = shift; + my $Ev = $w->XEvent; + # Make sure these exist, as some weird situations can trigger the + # motion binding without the initial press. [Tcl/Tk Bug #220269] + if (!defined $Tk::x) { $Tk::x = $Ev->x } + if (abs(($Ev->x-$Tk::x)) > 2) + { + $Tk::mouseMoved = 1 + } + $w->scan('dragto',$Ev->x) +} + + +# XXX Not needed anymore +sub ButtonRelease_2 +{ + my $w = shift; + my $Ev = $w->XEvent; + if (!$Tk::mouseMoved) + { + eval + {local $SIG{__DIE__}; + $w->insert('insert',$w->SelectionGet); + $w->SeeInsert; + } + } +} + +sub Button1Release +{ + shift->CancelRepeat; +} + +# ::tk::EntryClosestGap -- +# Given x and y coordinates, this procedure finds the closest boundary +# between characters to the given coordinates and returns the index +# of the character just after the boundary. +# +# Arguments: +# w - The entry window. +# x - X-coordinate within the window. +sub ClosestGap +{ + my($w, $x) = @_; + my $pos = $w->index('@'.$x); + my @bbox = $w->bbox($pos); + if ($x - $bbox[0] < $bbox[2] / 2) + { + return $pos; + } + $pos + 1; +} + +# Button1 -- +# This procedure is invoked to handle button-1 presses in entry +# widgets. It moves the insertion cursor, sets the selection anchor, +# and claims the input focus. +# +# Arguments: +# w - The entry window in which the button was pressed. +# x - The x-coordinate of the button press. +sub Button1 +{ + my $w = shift; + my $x = shift; + $Tk::selectMode = 'char'; + $Tk::mouseMoved = 0; + $Tk::pressX = $x; + $w->icursor($w->ClosestGap($x)); + $w->selectionFrom('insert'); + $w->selectionClear; + if ($w->cget('-state') ne 'disabled') + { + $w->focus() + } +} + +sub Motion +{ + my ($w,$x,$y) = @_; + $Tk::x = $x; # XXX ? + $w->MouseSelect($x); +} + +# MouseSelect -- +# This procedure is invoked when dragging out a selection with +# the mouse. Depending on the selection mode (character, word, +# line) it selects in different-sized units. This procedure +# ignores mouse motions initially until the mouse has moved from +# one character to another or until there have been multiple clicks. +# +# Arguments: +# w - The entry window in which the button was pressed. +# x - The x-coordinate of the mouse. +sub MouseSelect +{ + + my $w = shift; + my $x = shift; + return if UNIVERSAL::isa($w, 'Tk::Spinbox') and $w->{_element} ne 'entry'; + $Tk::selectMode = shift if (@_); + my $cur = $w->index($w->ClosestGap($x)); + return unless defined $cur; + my $anchor = $w->index('anchor'); + return unless defined $anchor; + $Tk::pressX ||= $x; # XXX Better use "if !defined $Tk::pressX"? + if (($cur != $anchor) || (abs($Tk::pressX - $x) >= 3)) + { + $Tk::mouseMoved = 1 + } + my $mode = $Tk::selectMode; + return unless $mode; + if ($mode eq 'char') + { + # The Tcl version uses selectionRange here XXX + if ($Tk::mouseMoved) + { + if ($cur < $anchor) + { + $w->selectionTo($cur) + } + else + { + $w->selectionTo($cur+1) + } + } + } + elsif ($mode eq 'word') + { + # The Tcl version uses tcl_wordBreakBefore/After here XXX + if ($cur < $w->index('anchor')) + { + $w->selectionRange($w->wordstart($cur),$w->wordend($anchor-1)) + } + else + { + $w->selectionRange($w->wordstart($anchor),$w->wordend($cur)) + } + } + elsif ($mode eq 'line') + { + $w->selectionRange(0,'end') + } + if (@_) + { + my $ipos = shift; + eval {local $SIG{__DIE__}; $w->icursor($ipos) }; + } + $w->idletasks; +} +# ::tk::EntryPaste -- +# This procedure sets the insertion cursor to the current mouse position, +# pastes the selection there, and sets the focus to the window. +# +# Arguments: +# w - The entry window. +# x - X position of the mouse. +sub Paste +{ + my($w, $x) = @_; + $w->icursor($w->ClosestGap($x)); + eval { local $SIG{__DIE__}; + $w->insert("insert", $w->GetSelection); + $w->SeeInsert; # Perl/Tk extension + }; + if ($w->cget(-state) ne 'disabled') + { + $w->focus; + } +} +# AutoScan -- +# This procedure is invoked when the mouse leaves an entry window +# with button 1 down. It scrolls the window left or right, +# depending on where the mouse is, and reschedules itself as an +# 'after' command so that the window continues to scroll until the +# mouse moves back into the window or the mouse button is released. +# +# Arguments: +# w - The entry window. +# x - The x-coordinate of the mouse when it left the window. +sub AutoScan +{ + my $w = shift; + my $x = shift; + return if !Tk::Exists($w); + if ($x >= $w->width) + { + $w->xview('scroll',2,'units') + } + elsif ($x < 0) + { + $w->xview('scroll',-2,'units') + } + else + { + return; + } + $w->MouseSelect($x); + $w->RepeatId($w->after(50,['AutoScan',$w,$x])) +} +# KeySelect +# This procedure is invoked when stroking out selections using the +# keyboard. It moves the cursor to a new position, then extends +# the selection to that position. +# +# Arguments: +# w - The entry window. +# new - A new position for the insertion cursor (the cursor hasn't +# actually been moved to this position yet). +sub KeySelect +{ + my $w = shift; + my $new = shift; + if (!$w->selectionPresent) + { + $w->selectionFrom('insert'); + $w->selectionTo($new) + } + else + { + $w->selectionAdjust($new) + } + $w->icursor($new); + $w->SeeInsert; +} +# Insert -- +# Insert a string into an entry at the point of the insertion cursor. +# If there is a selection in the entry, and it covers the point of the +# insertion cursor, then delete the selection before inserting. +# +# Arguments: +# w - The entry window in which to insert the string +# s - The string to insert (usually just a single character) +sub Insert +{ + my $w = shift; + my $s = shift; + return unless (defined $s && $s ne ''); + eval + {local $SIG{__DIE__}; + my $insert = $w->index('insert'); + if ($w->index('sel.first') <= $insert && $w->index('sel.last') >= $insert) + { + $w->deleteSelected + } + }; + $w->insert('insert',$s); + $w->SeeInsert +} +# Backspace -- +# Backspace over the character just before the insertion cursor. +# +# Arguments: +# w - The entry window in which to backspace. +sub Backspace +{ + my $w = shift; + if ($w->selectionPresent) + { + $w->deleteSelected + } + else + { + my $x = $w->index('insert')-1; + $w->delete($x) if ($x >= 0); + # XXX Missing repositioning part from Tcl/Tk source + } +} +# SeeInsert +# Make sure that the insertion cursor is visible in the entry window. +# If not, adjust the view so that it is. +# +# Arguments: +# w - The entry window. +sub SeeInsert +{ + my $w = shift; + my $c = $w->index('insert'); +# +# Probably a bug in your version of tcl/tk (I've not this problem +# when I test Entry in the widget demo for tcl/tk) +# index('\@0') give always 0. Consequence : +# if you make <Control-E> or <Control-F> view is adapted +# but with <Control-A> or <Control-B> view is not adapted +# + my $left = $w->index('@0'); + if ($left > $c) + { + $w->xview($c); + return; + } + my $x = $w->width; + while ($w->index('@' . $x) <= $c && $left < $c) + { + $left += 1; + $w->xview($left) + } +} +# SetCursor +# Move the insertion cursor to a given position in an entry. Also +# clears the selection, if there is one in the entry, and makes sure +# that the insertion cursor is visible. +# +# Arguments: +# w - The entry window. +# pos - The desired new position for the cursor in the window. +sub SetCursor +{ + my $w = shift; + my $pos = shift; + $w->icursor($pos); + $w->selectionClear; + $w->SeeInsert; +} +# Transpose +# This procedure implements the 'transpose' function for entry widgets. +# It tranposes the characters on either side of the insertion cursor, +# unless the cursor is at the end of the line. In this case it +# transposes the two characters to the left of the cursor. In either +# case, the cursor ends up to the right of the transposed characters. +# +# Arguments: +# w - The entry window. +sub Transpose +{ + my $w = shift; + my $i = $w->index('insert'); + $i++ if ($i < $w->index('end')); + my $first = $i-2; + return if ($first < 0); + my $str = $w->get; + my $new = substr($str,$i-1,1) . substr($str,$first,1); + $w->delete($first,$i); + $w->insert('insert',$new); + $w->SeeInsert; +} + +sub tabFocus +{ + my $w = shift; + $w->selectionRange(0,'end'); + $w->icursor('end'); + $w->SUPER::tabFocus; +} + +# ::tk::EntryGetSelection -- +# +# Returns the selected text of the entry with respect to the -show option. +# +# Arguments: +# w - The entry window from which the text to get +sub getSelected +{ + my $w = shift; + return undef unless $w->selectionPresent; + my $str = $w->get; + my $show = $w->cget('-show'); + $str = $show x length($str) if (defined $show); + my $s = $w->index('sel.first'); + my $e = $w->index('sel.last'); + return substr($str,$s,$e-$s); +} + + +1; + +__END__ diff --git a/Master/tlpkg/tlperl/lib/Tk/ErrorDialog.pm b/Master/tlpkg/tlperl/lib/Tk/ErrorDialog.pm new file mode 100644 index 00000000000..19377eaeca4 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/ErrorDialog.pm @@ -0,0 +1,125 @@ +package Tk::ErrorDialog; + +use vars qw($VERSION); +$VERSION = sprintf '4.%03d', q$Revision: #7 $ =~ /\D(\d+)\s*$/; + +use Tk (); +require Tk::Dialog; +use base qw(Tk::Toplevel); + + +# ErrorDialog - a translation of bgerror() from Tcl/Tk to Perl/Tk. +# +# Currently TkPerl background errors are sent to stdout/stderr; use this +# module if you want them in a window. You can also "roll your own" by +# supplying the routine Tk::Error. + +use strict; + +Construct Tk::Widget 'ErrorDialog'; + +my %options = ( -buttons => ['OK', 'Skip Messages', 'Stack trace'], + -bitmap => 'error' + ); +my $ED_OBJECT; + +sub import +{ + my $class = shift; + while (@_) + { + my $key = shift; + my $val = shift; + $options{$key} = $val; + } +} + +sub Populate { + + # ErrorDialog constructor. Uses `new' method from base class + # to create object container then creates the dialog toplevel and the + # traceback toplevel. + + my($cw, $args) = @_; + + my $dr = $cw->Dialog( + -title => 'Error in '.$cw->MainWindow->name, + -text => 'on-the-fly-text', + -bitmap => $options{'-bitmap'}, + -buttons => $options{'-buttons'}, + ); + $cw->minsize(1, 1); + $cw->title('Stack Trace for Error'); + $cw->iconname('Stack Trace'); + my $t_ok = $cw->Button( + -text => 'OK', + -command => [ + sub { + shift->withdraw; + }, $cw, + ] + ); + my $t_text = $cw->Text( + -relief => 'sunken', + -bd => 2, + -setgrid => 'true', + -width => 60, + -height => 20, + ); + my $t_scroll = $cw->Scrollbar( + -relief => 'sunken', + -command => ['yview', $t_text], + ); + $t_text->configure(-yscrollcommand => ['set', $t_scroll]); + $t_ok->pack(-side => 'bottom', -padx => '3m', -pady => '2m'); + $t_scroll->pack(-side => 'right', -fill => 'y'); + $t_text->pack(-side => 'left', -expand => 'yes', -fill => 'both'); + $cw->withdraw; + + $cw->Advertise(error_dialog => $dr); # advertise dialog widget + $cw->Advertise(text => $t_text); # advertise text widget + $cw->ConfigSpecs(-cleanupcode => [PASSIVE => undef, undef, undef], + -appendtraceback => [ PASSIVE => undef, undef, 1 ]); + $ED_OBJECT = $cw; + $cw->protocol('WM_DELETE_WINDOW' => sub {$cw->withdraw}); + return $cw; + +} # end Populate + +sub Tk::Error { + + # Post a dialog box with the error message and give the user a chance + # to see a more detailed stack trace. + + my($w, $error, @msgs) = @_; + + my $grab = $w->grab('current'); + $grab->Unbusy if (defined $grab); + + $w->ErrorDialog if not defined $ED_OBJECT; + + my($d, $t) = ($ED_OBJECT->Subwidget('error_dialog'), $ED_OBJECT->Subwidget('text')); +# chop $error; + $d->configure(-text => "Error: $error"); + $d->bell; + my $ans = $d->Show; + + $t->delete('0.0', 'end') if not $ED_OBJECT->{'-appendtraceback'}; + $t->insert('end', "\n"); + $t->mark('set', 'ltb', 'end'); + $t->insert('end', "--- Begin Traceback ---\n$error\n"); + my $msg; + for $msg (@msgs) { + $t->insert('end', "$msg\n"); + } + $t->yview('ltb'); + + $ED_OBJECT->deiconify if ($ans =~ /trace/i); + + my $c = $ED_OBJECT->{Configure}{'-cleanupcode'}; + &$c if defined $c; # execute any cleanup code if it was defined + $w->break if ($ans =~ /skip/i); + +} # end Tk::Error + +1; diff --git a/Master/tlpkg/tlperl/lib/Tk/Event.pm b/Master/tlpkg/tlperl/lib/Tk/Event.pm new file mode 100644 index 00000000000..cecd57c54ae --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Event.pm @@ -0,0 +1,13 @@ +package Tk::Event; +use vars qw($VERSION $XS_VERSION @EXPORT_OK); +END { CleanupGlue() } +$VERSION = sprintf '4.%03d', q$Revision: #15 $ =~ /\D(\d+)\s*$/; +$XS_VERSION = '804.027'; +use base qw(Exporter); +use XSLoader; +@EXPORT_OK = qw($XS_VERSION DONT_WAIT WINDOW_EVENTS FILE_EVENTS + TIMER_EVENTS IDLE_EVENTS ALL_EVENTS); +XSLoader::load 'Tk::Event',$XS_VERSION; +require Tk::Event::IO; +1; +__END__ diff --git a/Master/tlpkg/tlperl/lib/Tk/Event/IO.pm b/Master/tlpkg/tlperl/lib/Tk/Event/IO.pm new file mode 100644 index 00000000000..10b47e246ff --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Event/IO.pm @@ -0,0 +1,132 @@ +package Tk::Event::IO; +use strict; +use Carp; + +use vars qw($VERSION @EXPORT_OK); +$VERSION = sprintf '4.%03d', q$Revision: #8 $ =~ /\D(\d+)\s*$/; + +use base qw(Exporter); +use Symbol (); + +@EXPORT_OK = qw(READABLE WRITABLE); + +sub PrintArgs +{ + my $func = (caller(1))[3]; + print "$func(",join(',',@_),")\n"; +} + +sub PRINT +{ + my $obj = shift; + $obj->wait(WRITABLE); + my $h = $obj->handle; + return print $h @_; +} + +sub PRINTF +{ + my $obj = shift; + $obj->wait(WRITABLE); + my $h = $obj->handle; + return printf $h @_; +} + +sub WRITE +{ + my $obj = $_[0]; + $obj->wait(WRITABLE); + return syswrite($obj->handle,$_[1],$_[2]); +} + +my $depth = 0; +sub READLINE +{ + my $obj = shift; + $obj->wait(READABLE); + my $h = $obj->handle; + my $w = <$h>; + return $w; +} + +sub READ +{ + my $obj = $_[0]; + $obj->wait(READABLE); + my $h = $obj->handle; + return sysread($h,$_[1],$_[2],defined $_[3] ? $_[3] : 0); +} + +sub GETC +{ + my $obj = $_[0]; + $obj->wait(READABLE); + my $h = $obj->handle; + return getc($h); +} + +sub CLOSE +{ + my $obj = shift; + $obj->unwatch; + my $h = $obj->handle; + return close($h); +} + +sub EOF +{ + my $obj = shift; + my $h = $obj->handle; + return eof($h); +} + +sub FILENO +{ + my $obj = shift; + my $h = $obj->handle; + return fileno($h); +} + +sub imode +{ + my $mode = shift; + my $imode = ${{'readable' => READABLE(), + 'writable' => WRITABLE()}}{$mode}; + croak("Invalid handler type '$mode'") unless (defined $imode); + return $imode; +} + +sub fileevent +{ + my ($widget,$file,$mode,$cb) = @_; + my $imode = imode($mode); + unless (ref $file) + { + no strict 'refs'; + $file = Symbol::qualify($file,(caller)[0]); + $file = \*{$file}; + } + my $obj = tied(*$file); + unless ($obj && $obj->isa('Tk::Event::IO')) + { + $obj = tie *$file,'Tk::Event::IO', $file; + } + if (@_ == 3) + { + # query return the handler + return $obj->handler($imode); + } + else + { + # set the handler + my $h = $obj->handler($imode,$cb); + undef $obj; # Prevent warnings about untie with ref to object + unless ($h) + { + untie *$file; + } + } +} + +1; +__END__ diff --git a/Master/tlpkg/tlperl/lib/Tk/FBox.pm b/Master/tlpkg/tlperl/lib/Tk/FBox.pm new file mode 100644 index 00000000000..fed7501aea4 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/FBox.pm @@ -0,0 +1,1043 @@ +# -*- perl -*- +# +# tkfbox.tcl -- +# +# Implements the "TK" standard file selection dialog box. This +# dialog box is used on the Unix platforms whenever the tk_strictMotif +# flag is not set. +# +# The "TK" standard file selection dialog box is similar to the +# file selection dialog box on Win95(TM). The user can navigate +# the directories by clicking on the folder icons or by +# selecting the "Directory" option menu. The user can select +# files by clicking on the file icons or by entering a filename +# in the "Filename:" entry. +# +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# Translated to perl/Tk by Slaven Rezic <slaven@rezic.de>. +# + +#---------------------------------------------------------------------- +# +# F I L E D I A L O G +# +#---------------------------------------------------------------------- +# tkFDialog -- +# +# Implements the TK file selection dialog. This dialog is used when +# the tk_strictMotif flag is set to false. This procedure shouldn't +# be called directly. Call tk_getOpenFile or tk_getSaveFile instead. +# + +package Tk::FBox; +require Tk::Toplevel; + +use strict; +use vars qw($VERSION $updirImage $folderImage $fileImage); + +$VERSION = sprintf '4.%03d', q$Revision: #18 $ =~ /\D(\d+)\s*$/; + +use base qw(Tk::Toplevel); + +Construct Tk::Widget 'FBox'; + +sub import { + if (defined $_[1] and $_[1] eq 'as_default') { + local $^W = 0; + package Tk; + if ($Tk::VERSION < 804) { + *FDialog = \&Tk::FBox::FDialog; + *MotifFDialog = \&Tk::FBox::FDialog; + } else { + *tk_getOpenFile = sub { + Tk::FBox::FDialog("tk_getOpenFile", @_); + }; + *tk_getSaveFile = sub { + Tk::FBox::FDialog("tk_getSaveFile", @_); + }; + } + } +} + +# Note that -sortcmd is experimental and the interface is likely to change. +# Using -sortcmd is really strange :-( +# $top->getOpenFile(-sortcmd => sub { package Tk::FBox; uc $b cmp uc $a}); +# or, un-perlish, but useable (now activated in code): +# $top->getOpenFile(-sortcmd => sub { uc $_[1] cmp uc $_[0]}); + +sub Populate { + my($w, $args) = @_; + + require Tk::IconList; + require File::Basename; + require Cwd; + + $w->SUPER::Populate($args); + + # f1: the frame with the directory option menu + my $f1 = $w->Frame; + my $lab = $f1->Label(-text => 'Directory:', -underline => 0); + $w->{'dirMenu'} = my $dirMenu = + $f1->Optionmenu(-variable => \$w->{'selectPath'}, + -textvariable => \$w->{'selectPath'}, + -command => ['SetPath', $w]); + my $upBtn = $f1->Button; + if (!defined $updirImage->{$w->MainWindow}) { + $updirImage->{$w->MainWindow} = $w->Bitmap(-data => <<EOF); +#define updir_width 28 +#define updir_height 16 +static char updir_bits[] = { + 0x00, 0x00, 0x00, 0x00, 0x80, 0x1f, 0x00, 0x00, 0x40, 0x20, 0x00, 0x00, + 0x20, 0x40, 0x00, 0x00, 0xf0, 0xff, 0xff, 0x01, 0x10, 0x00, 0x00, 0x01, + 0x10, 0x02, 0x00, 0x01, 0x10, 0x07, 0x00, 0x01, 0x90, 0x0f, 0x00, 0x01, + 0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01, + 0x10, 0xfe, 0x07, 0x01, 0x10, 0x00, 0x00, 0x01, 0x10, 0x00, 0x00, 0x01, + 0xf0, 0xff, 0xff, 0x01}; +EOF + } + $upBtn->configure(-image => $updirImage->{$w->MainWindow}); + $dirMenu->configure(-takefocus => 1, -highlightthickness => 2); + $upBtn->pack(-side => 'right', -padx => 4, -fill => 'both'); + $lab->pack(-side => 'left', -padx => 4, -fill => 'both'); + $dirMenu->pack(-expand => 'yes', -fill => 'both', -padx => 4); + + $w->{'icons'} = my $icons = + $w->IconList(-command => ['OkCmd', $w, 'iconlist'], + ); + $icons->bind('<<ListboxSelect>>' => [$w, 'ListBrowse']); + + # f2: the frame with the OK button and the "file name" field + my $f2 = $w->Frame(-bd => 0); +#XXX File name => File names if multiple + my $f2_lab = $f2->Label(-text => 'File name:', -anchor => 'e', + -width => 14, -underline => 5, -pady => 0); + $w->{'ent'} = my $ent = $f2->Entry; + + # The font to use for the icons. The default Canvas font on Unix + # is just deviant. +# $w->{'icons'}{'font'} = $ent->cget(-font); + $w->{'icons'}->configure(-font => $ent->cget(-font)); + + # f3: the frame with the cancel button and the file types field + my $f3 = $w->Frame(-bd => 0); + + # The "File of types:" label needs to be grayed-out when + # -filetypes are not specified. The label widget does not support + # grayed-out text on monochrome displays. Therefore, we have to + # use a button widget to emulate a label widget (by setting its + # bindtags) + $w->{'typeMenuLab'} = my $typeMenuLab = $f3->Button + (-text => 'Files of type:', + -anchor => 'e', + -width => 14, + -underline => 9, + -bd => $f2_lab->cget(-bd), + -highlightthickness => $f2_lab->cget(-highlightthickness), + -relief => $f2_lab->cget(-relief), + -padx => $f2_lab->cget(-padx), + -pady => $f2_lab->cget(-pady), + -takefocus => 0, + ); + $typeMenuLab->bindtags([$typeMenuLab, 'Label', + $typeMenuLab->toplevel, 'all']); + $w->{'typeMenuBtn'} = my $typeMenuBtn = + $f3->Menubutton(-indicatoron => 1, -tearoff => 0); + $typeMenuBtn->configure(-takefocus => 1, + -highlightthickness => 2, + -relief => 'raised', + -bd => 2, + -anchor => 'w', + ); + + # the okBtn is created after the typeMenu so that the keyboard traversal + # is in the right order + $w->{'okBtn'} = my $okBtn = $f2->Button + (-text => 'OK', + -underline => 0, + -width => 6, + -default => 'active', + -pady => 3, + ); + my $cancelBtn = $f3->Button + (-text => 'Cancel', + -underline => 0, + -width => 6, + -default => 'normal', + -pady => 3, + ); + + # pack the widgets in f2 and f3 + $okBtn->pack(-side => 'right', -padx => 4, -anchor => 'e'); + $f2_lab->pack(-side => 'left', -padx => 4); + $ent->pack(-expand => 'yes', -fill => 'x', -padx => 2, -pady => 0); + $cancelBtn->pack(-side => 'right', -padx => 4, -anchor => 'w'); + $typeMenuLab->pack(-side => 'left', -padx => 4); + $typeMenuBtn->pack(-expand => 'yes', -fill => 'x', -side => 'right'); + + # Pack all the frames together. We are done with widget construction. + $f1->pack(-side => 'top', -fill => 'x', -pady => 4); + $f3->pack(-side => 'bottom', -fill => 'x'); + $f2->pack(-side => 'bottom', -fill => 'x'); + $icons->pack(-expand => 'yes', -fill => 'both', -padx => 4, -pady => 1); + + # Set up the event handlers + $ent->bind('<Return>',[$w,'ActivateEnt']); + $upBtn->configure(-command => ['UpDirCmd', $w]); + $okBtn->configure(-command => ['OkCmd', $w]); + $cancelBtn->configure(-command, ['CancelCmd', $w]); + + $w->bind('<Alt-d>',[$dirMenu,'focus']); + $w->bind('<Alt-t>',sub { + if ($typeMenuBtn->cget(-state) eq 'normal') { + $typeMenuBtn->focus; + } }); + $w->bind('<Alt-n>',[$ent,'focus']); + $w->bind('<KeyPress-Escape>',[$cancelBtn,'invoke']); + $w->bind('<Alt-c>',[$cancelBtn,'invoke']); + $w->bind('<Alt-o>',['InvokeBtn','Open']); + $w->bind('<Alt-s>',['InvokeBtn','Save']); + $w->protocol('WM_DELETE_WINDOW', ['CancelCmd', $w]); + $w->OnDestroy(['CancelCmd', $w]); + + # Build the focus group for all the entries + $w->FG_Create; + $w->FG_BindIn($ent, ['EntFocusIn', $w]); + $w->FG_BindOut($ent, ['EntFocusOut', $w]); + + $w->SetPath(_cwd()); + + $w->ConfigSpecs(-defaultextension => ['PASSIVE', undef, undef, undef], + -filetypes => ['PASSIVE', undef, undef, undef], + -initialdir => ['PASSIVE', undef, undef, undef], + -initialfile => ['PASSIVE', undef, undef, undef], +# -sortcmd => ['PASSIVE', undef, undef, sub { lc($a) cmp lc($b) }], + -sortcmd => ['PASSIVE', undef, undef, sub { lc($_[0]) cmp lc($_[1]) }], + -title => ['PASSIVE', undef, undef, undef], + -type => ['PASSIVE', undef, undef, 'open'], + -filter => ['PASSIVE', undef, undef, '*'], + -force => ['PASSIVE', undef, undef, 0], + -multiple => ['PASSIVE', undef, undef, 0], + 'DEFAULT' => [$icons], + ); + # So-far-failed attempt to break reference loops ... + $w->_OnDestroy(qw(dirMenu icons typeMenuLab typeMenuBtn okBtn ent updateId)); + $w; +} + +# -initialdir fix with ResolveFile +sub Show { + my $w = shift; + + $w->configure(@_); + + # Dialog boxes should be transient with respect to their parent, + # so that they will always stay on top of their parent window. However, + # some window managers will create the window as withdrawn if the parent + # window is withdrawn or iconified. Combined with the grab we put on the + # window, this can hang the entire application. Therefore we only make + # the dialog transient if the parent is viewable. + + if (Tk::Exists($w->Parent) && $w->Parent->viewable) { + $w->transient($w->Parent); + } + + # set the default directory and selection according to the -initial + # settings + { + my $initialdir = $w->cget(-initialdir); + if (defined $initialdir) { + my ($flag, $path, $file) = ResolveFile($initialdir, 'junk'); + if ($flag eq 'OK' or $flag eq 'FILE') { + $w->{'selectPath'} = $path; + } else { + $w->Error("\"$initialdir\" is not a valid directory"); + } + } + $w->{'selectFile'} = $w->cget(-initialfile); + } + + # Set -multiple to a one or zero value (not other boolean types + # like "yes") so we can use it in tests more easily. + if ($w->cget('-type') ne 'open') { + $w->configure(-multiple => 0); + } else { + $w->configure(-multiple => !!$w->cget('-multiple')); + } + $w->{'icons'}->configure(-multiple => $w->cget('-multiple')); + + # Initialize the file types menu + my $typeMenuBtn = $w->{'typeMenuBtn'}; + my $typeMenuLab = $w->{'typeMenuLab'}; + if (defined $w->cget('-filetypes')) { + my(@filetypes) = GetFileTypes($w->cget('-filetypes')); + my $typeMenu = $typeMenuBtn->cget(-menu); + $typeMenu->delete(0, 'end'); + foreach my $ft (@filetypes) { + my $title = $ft->[0]; + my $filter = join(' ', @{ $ft->[1] }); + $typeMenuBtn->command + (-label => $title, + -command => ['SetFilter', $w, $title, $filter], + ); + } + $w->SetFilter($filetypes[0]->[0], join(' ', @{ $filetypes[0]->[1] })); + $typeMenuBtn->configure(-state => 'normal'); + $typeMenuLab->configure(-state => 'normal'); + } else { +#XXX $w->configure(-filter => '*'); + $typeMenuBtn->configure(-state => 'disabled', + -takefocus => 0); + $typeMenuLab->configure(-state => 'disabled'); + } + $w->UpdateWhenIdle; + + { + my $title = $w->cget(-title); + if (!defined $title) { + my $type = $w->cget(-type); + $title = ($type eq 'dir') ? 'Choose Directory' + : ($type eq 'save') ? 'Save As' : 'Open'; + } + $w->title($title); + } + + # Withdraw the window, then update all the geometry information + # so we know how big it wants to be, then center the window in the + # display and de-iconify it. + $w->withdraw; + $w->idletasks; + if (0) + { + #XXX use Tk::Wm::Popup? or Tk::PlaceWindow? + my $x = int($w->screenwidth / 2 - $w->reqwidth / 2 - $w->parent->vrootx); + my $y = int($w->screenheight / 2 - $w->reqheight / 2 - $w->parent->vrooty); + $w->geometry("+$x+$y"); + $w->deiconify; + } + else + { + $w->Popup; + } + + # Set a grab and claim the focus too. +#XXX use Tk::setFocusGrab when it's available + my $oldFocus = $w->focusCurrent; + my $oldGrab = $w->grabCurrent; + my $grabStatus = $oldGrab->grabStatus if ($oldGrab); + $w->grab; + my $ent = $w->{'ent'}; + $ent->focus; + $ent->delete(0, 'end'); + if (defined $w->{'selectFile'} && $w->{'selectFile'} ne '') { + $ent->insert(0, $w->{'selectFile'}); + $ent->selectionRange(0,'end'); + $ent->icursor('end'); + } + + # 8. Wait for the user to respond, then restore the focus and + # return the index of the selected button. Restore the focus + # before deleting the window, since otherwise the window manager + # may take the focus away so we can't redirect it. Finally, + # restore any grab that was in effect. + $w->waitVariable(\$w->{'selectFilePath'}); + eval { + $oldFocus->focus if $oldFocus; + }; + if (Tk::Exists($w)) { # widget still exists + $w->grabRelease; + $w->withdraw; + } + if (Tk::Exists($oldGrab) && $oldGrab->viewable) { + if ($grabStatus eq 'global') { + $oldGrab->grabGlobal; + } else { + $oldGrab->grab; + } + } + return $w->{'selectFilePath'}; +} + +# tkFDialog_UpdateWhenIdle -- +# +# Creates an idle event handler which updates the dialog in idle +# time. This is important because loading the directory may take a long +# time and we don't want to load the same directory for multiple times +# due to multiple concurrent events. +# +sub UpdateWhenIdle { + my $w = shift; + if (exists $w->{'updateId'}) { + return; + } else { + $w->{'updateId'} = $w->after('idle', [$w, 'Update']); + } +} + +# tkFDialog_Update -- +# +# Loads the files and directories into the IconList widget. Also +# sets up the directory option menu for quick access to parent +# directories. +# +sub Update { + my $w = shift; + my $dataName = $w->name; + + # This proc may be called within an idle handler. Make sure that the + # window has not been destroyed before this proc is called + if (!Tk::Exists($w) || $w->class ne 'FBox') { + return; + } else { + delete $w->{'updateId'}; + } + unless (defined $folderImage->{$w->MainWindow}) { + require Tk::Pixmap; + $folderImage->{$w->MainWindow} = $w->Pixmap(-file => Tk->findINC('folder.xpm')); + $fileImage->{$w->MainWindow} = $w->Pixmap(-file => Tk->findINC('file.xpm')); + } + my $folder = $folderImage->{$w->MainWindow}; + my $file = $fileImage->{$w->MainWindow}; + my $appPWD = _cwd(); + if (!ext_chdir($w->{'selectPath'})) { + # We cannot change directory to $data(selectPath). $data(selectPath) + # should have been checked before tkFDialog_Update is called, so + # we normally won't come to here. Anyways, give an error and abort + # action. + $w->messageBox(-type => 'OK', + -message => 'Cannot change to the directory "' . + $w->{'selectPath'} . "\".\nPermission denied.", + -icon => 'warning', + ); + ext_chdir($appPWD); + return; + } + + # Turn on the busy cursor. BUG?? We haven't disabled X events, though, + # so the user may still click and cause havoc ... + my $ent = $w->{'ent'}; + my $entCursor = $ent->cget(-cursor); + my $dlgCursor = $w->cget(-cursor); + $ent->configure(-cursor => 'watch'); + $w->configure(-cursor => 'watch'); + $w->idletasks; + my $icons = $w->{'icons'}; + $icons->DeleteAll; + + # Make the dir & file list + my $cwd = _cwd(); + local *FDIR; + if (opendir(FDIR, $cwd)) { + my @files; +# my $sortcmd = $w->cget(-sortcmd); + my $sortcmd = sub { $w->cget(-sortcmd)->($a,$b) }; + my $flt = $w->cget(-filter); + my $fltcb; + if (ref $flt eq 'CODE') { + $fltcb = $flt; + } else { + $flt = _rx_to_glob($flt); + } + my $type_dir = $w->cget(-type) eq 'dir'; + foreach my $f (sort $sortcmd readdir(FDIR)) { + next if $f eq '.' or $f eq '..'; + next if $type_dir && ! -d "$cwd/$f"; # XXX use File::Spec? + if ($fltcb) { + next if !$fltcb->($w, $f, $cwd); + } else { + next if -f $f && $f !~ m!$flt!; + } + if (-d $f) { + $icons->Add($folder, $f); + } else { + push @files, $f; + } + } + closedir(FDIR); + $icons->Add($file, @files); + } + + $icons->Arrange; + + # Update the Directory: option menu + my @list; + my $dir = ''; + foreach my $subdir (TclFileSplit($w->{'selectPath'})) { + $dir = TclFileJoin($dir, $subdir); + push @list, $dir; + } + my $dirMenu = $w->{'dirMenu'}; + $dirMenu->configure(-options => \@list); + + # Restore the PWD to the application's PWD + ext_chdir($appPWD); + + # Restore the Save label + if ($w->cget(-type) eq 'save') { + $w->{'okBtn'}->configure(-text => 'Save'); + } + + # turn off the busy cursor. + $ent->configure(-cursor => $entCursor); + $w->configure(-cursor => $dlgCursor); +} + +# tkFDialog_SetPathSilently -- +# +# Sets data(selectPath) without invoking the trace procedure +# +sub SetPathSilently { + my($w, $path) = @_; + + $w->{'selectPath'} = $path; +} + +# This proc gets called whenever data(selectPath) is set +# +sub SetPath { + my $w = shift; + $w->{'selectPath'} = $_[0] if @_; + $w->UpdateWhenIdle; +} + +# This proc gets called whenever data(filter) is set +# +#XXX here's much more code in the tcl version ... check it out +sub SetFilter { + my($w, $title, $filter) = @_; + $w->configure(-filter => $filter); + $w->{'typeMenuBtn'}->configure(-text => $title, + -indicatoron => 1); + $w->{'icons'}->Subwidget('sbar')->set(0.0, 0.0); + $w->UpdateWhenIdle; +} + +# tkFDialogResolveFile -- +# +# Interpret the user's text input in a file selection dialog. +# Performs: +# +# (1) ~ substitution +# (2) resolve all instances of . and .. +# (3) check for non-existent files/directories +# (4) check for chdir permissions +# +# Arguments: +# context: the current directory you are in +# text: the text entered by the user +# defaultext: the default extension to add to files with no extension +# +# Return value: +# [list $flag $directory $file] +# +# flag = OK : valid input +# = PATTERN : valid directory/pattern +# = PATH : the directory does not exist +# = FILE : the directory exists but the file doesn't +# exist +# = CHDIR : Cannot change to the directory +# = ERROR : Invalid entry +# +# directory : valid only if flag = OK or PATTERN or FILE +# file : valid only if flag = OK or PATTERN +# +# directory may not be the same as context, because text may contain +# a subdirectory name +# +sub ResolveFile { + my($context, $text, $defaultext) = @_; + my $appPWD = _cwd(); + my $path = JoinFile($context, $text); + # If the file has no extension, append the default. Be careful not + # to do this for directories, otherwise typing a dirname in the box + # will give back "dirname.extension" instead of trying to change dir. + if (!-d $path && $path !~ /\..+$/ && defined $defaultext) { + $path = "$path$defaultext"; + } + # Cannot just test for existance here as non-existing files are + # not an error for getSaveFile type dialogs. + # return ('ERROR', $path, "") if (!-e $path); + my($directory, $file, $flag); + if (-e $path) { + if (-d $path) { + if (!ext_chdir($path)) { + return ('CHDIR', $path, ''); + } + $directory = _cwd(); + $file = ''; + $flag = 'OK'; + ext_chdir($appPWD); + } else { + my $dirname = File::Basename::dirname($path); + if (!ext_chdir($dirname)) { + return ('CHDIR', $dirname, ''); + } + $directory = _cwd(); + $file = File::Basename::basename($path); + $flag = 'OK'; + ext_chdir($appPWD); + } + } else { + my $dirname = File::Basename::dirname($path); + if (-e $dirname) { + if (!ext_chdir($dirname)) { + return ('CHDIR', $dirname, ''); + } + $directory = _cwd(); + $file = File::Basename::basename($path); + if ($file =~ /[*?]/) { + $flag = 'PATTERN'; + } else { + $flag = 'FILE'; + } + ext_chdir($appPWD); + } else { + $directory = $dirname; + $file = File::Basename::basename($path); + $flag = 'PATH'; + } + } + return ($flag,$directory,$file); +} + +# Gets called when the entry box gets keyboard focus. We clear the selection +# from the icon list . This way the user can be certain that the input in the +# entry box is the selection. +# +sub EntFocusIn { + my $w = shift; + my $ent = $w->{'ent'}; + if ($ent->get ne '') { + $ent->selectionRange(0, 'end'); + $ent->icursor('end'); + } else { + $ent->selectionClear; + } +#XXX is this missing in the tcl version, too??? $w->{'icons'}->Selection('clear'); + my $okBtn = $w->{'okBtn'}; + if ($w->cget(-type) ne 'save') { + $okBtn->configure(-text => 'Open'); + } else { + $okBtn->configure(-text => 'Save'); + } +} + +sub EntFocusOut { + my $w = shift; + $w->{'ent'}->selectionClear; +} + +# Gets called when user presses Return in the "File name" entry. +# +sub ActivateEnt { + my $w = shift; + my $ent = $w->{'ent'}; + my $text = $ent->get; + if ($w->cget(-multiple)) { + # For the multiple case we have to be careful to get the file + # names as a true list, watching out for a single file with a + # space in the name. Thus we query the IconList directly. + + $w->{'selectFile'} = []; + for my $item ($w->{'icons'}->Curselection) { + $w->VerifyFileName($w->{'icons'}->Get($item)); + } + } else { + $w->VerifyFileName($text); + } +} + +# Verification procedure +# +sub VerifyFileName { + my($w, $text) = @_; +#XXX leave this here? +# $text =~ s/^\s+//; +# $text =~ s/\s+$//; + my($flag, $path, $file) = ResolveFile($w->{'selectPath'}, $text, + $w->cget(-defaultextension)); + my $ent = $w->{'ent'}; + if ($flag eq 'OK') { + if ($file eq '') { + # user has entered an existing (sub)directory + $w->SetPath($path); + $ent->delete(0, 'end'); + } else { + $w->SetPathSilently($path); + if ($w->cget(-multiple)) { + push @{ $w->{'selectFile'} }, $file; + } else { + $w->{'selectFile'} = $file; + } + $w->Done; + } + } elsif ($flag eq 'PATTERN') { + $w->SetPath($path); + $w->configure(-filter => $file); + } elsif ($flag eq 'FILE') { + if ($w->cget(-type) eq 'open') { + $w->messageBox(-icon => 'warning', + -type => 'OK', + -message => 'File "' . TclFileJoin($path, $file) + . '" does not exist.'); + $ent->selectionRange(0, 'end'); + $ent->icursor('end'); + } elsif ($w->cget(-type) eq 'save') { + $w->SetPathSilently($path); + if ($w->cget(-multiple)) { + push @{ $w->{'selectFile'} }, $file; + } else { + $w->{'selectFile'} = $file; + } + $w->Done; + } + } elsif ($flag eq 'PATH') { + $w->messageBox(-icon => 'warning', + -type => 'OK', + -message => "Directory \'$path\' does not exist."); + $ent->selectionRange(0, 'end'); + $ent->icursor('end'); + } elsif ($flag eq 'CHDIR') { + $w->messageBox(-type => 'OK', + -message => "Cannot change to the directory \"$path\".\nPermission denied.", + -icon => 'warning'); + $ent->selectionRange(0, 'end'); + $ent->icursor('end'); + } elsif ($flag eq 'ERROR') { + $w->messageBox(-type => 'OK', + -message => "Invalid file name \"$path\".", + -icon => 'warning'); + $ent->selectionRange(0, 'end'); + $ent->icursor('end'); + } +} + +# Gets called when user presses the Alt-s or Alt-o keys. +# +sub InvokeBtn { + my($w, $key) = @_; + my $okBtn = $w->{'okBtn'}; + $okBtn->invoke if ($okBtn->cget(-text) eq $key); +} + +# Gets called when user presses the "parent directory" button +# +sub UpDirCmd { + my $w = shift; + $w->SetPath(File::Basename::dirname($w->{'selectPath'})) + unless ($w->{'selectPath'} eq '/'); +} + +# Join a file name to a path name. The "file join" command will break +# if the filename begins with ~ +sub JoinFile { + my($path, $file) = @_; + if ($file =~ /^~/ && -e "$path/$file") { + TclFileJoin($path, "./$file"); + } else { + TclFileJoin($path, $file); + } +} + +# XXX replace with File::Spec when perl/Tk depends on 5.005 +sub TclFileJoin { + my $path = ''; + foreach (@_) { + if (m|^/|) { + $path = $_; + } + elsif (m|^[a-z]:/|i) { # DOS-ish + $path = $_; + } elsif ($_ eq '~') { + $path = _get_homedir(); + } elsif (m|^~/(.*)|) { + $path = _get_homedir() . "/" . $1; + } elsif (m|^~([^/]+)(.*)|) { + my($user, $p) = ($1, $2); + my $dir = _get_homedir($user); + if (!defined $dir) { + $path = "~$user$p"; + } else { + $path = $dir . $p; + } + } elsif ($path eq '/' or $path eq '') { + $path .= $_; + } else { + $path .= "/$_"; + } + } + $path; +} + +sub TclFileSplit { + my $path = shift; + my @comp; + $path =~ s|/+|/|g; # strip multiple slashes + if ($path =~ m|^/|) { + push @comp, '/'; + $path = substr($path, 1); + } + push @comp, split /\//, $path; + @comp; +} + +# Gets called when user presses the "OK" button +# +sub OkCmd { + my $w = shift; + my $from = shift || "button"; + + my $filenames = []; + for my $item ($w->{'icons'}->Curselection) { + push @$filenames, $w->{'icons'}->Get($item); + } + + my $filename = $filenames->[0]; + if ($w->cget('-type') eq 'dir' && $from ne "iconlist") { + my $file = $filename eq '' ? $w->{'selectPath'} : JoinFile($w->{'selectPath'}, $filename); + $w->Done($file); + } elsif ((@$filenames && !$w->cget('-multiple')) || + ($w->cget('-multiple') && @$filenames == 1)) { + my $file = JoinFile($w->{'selectPath'}, $filename); + if (-d $file) { + $w->ListInvoke($filename); + return; + } + } + + $w->ActivateEnt; +} + +# Gets called when user presses the "Cancel" button +# +sub CancelCmd { + my $w = shift; + undef $w->{'selectFilePath'}; +} + +# Gets called when user browses the IconList widget (dragging mouse, arrow +# keys, etc) +# +sub ListBrowse { + my($w) = @_; + + my $text = []; + for my $item ($w->{'icons'}->Curselection) { + push @$text, $w->{'icons'}->Get($item); + } + return if @$text == 0; + my $isDir; + if (@$text > 1) { + my $newtext = []; + for my $file (@$text) { + my $fullfile = JoinFile($w->{'selectPath'}, $file); + if (!-d $fullfile) { + push @$newtext, $file; + } + } + $text = $newtext; + $isDir = 0; + } else { + my $file = JoinFile($w->{'selectPath'}, $text->[0]); + $isDir = -d $file; + } + my $ent = $w->{'ent'}; + my $okBtn = $w->{'okBtn'}; + if (!$isDir) { + $ent->delete(qw(0 end)); + $ent->insert(0, "@$text"); # XXX quote! + + if ($w->cget('-type') ne 'save') { + $okBtn->configure(-text => 'Open'); + } else { + $okBtn->configure(-text => 'Save'); + } + } else { + $okBtn->configure(-text => 'Open'); + } +} + +# Gets called when user invokes the IconList widget (double-click, +# Return key, etc) +# +sub ListInvoke { + my($w, @filenames) = @_; + return if !@filenames; + my $file = JoinFile($w->{'selectPath'}, $filenames[0]); + if (-d $file) { + my $appPWD = _cwd(); + if (!ext_chdir($file)) { + $w->messageBox(-type => 'OK', + -message => "Cannot change to the directory \"$file\".\nPermission denied.", + -icon => 'warning'); + } else { + ext_chdir($appPWD); + $w->SetPath($file); + } + } else { + if ($w->cget('-multiple')) { + $w->{'selectFile'} = [@filenames]; + } else { + $w->{'selectFile'} = $file; + } + $w->Done; + } +} + +# tkFDialog_Done -- +# +# Gets called when user has input a valid filename. Pops up a +# dialog box to confirm selection when necessary. Sets the +# tkPriv(selectFilePath) variable, which will break the "tkwait" +# loop in tkFDialog and return the selected filename to the +# script that calls tk_getOpenFile or tk_getSaveFile +# +sub Done { + my $w = shift; + my $selectFilePath = (@_) ? shift : ''; + if ($selectFilePath eq '') { + if ($w->cget('-multiple')) { + $selectFilePath = []; + for my $f (@{ $w->{'selectFile'} }) { + push @$selectFilePath, JoinFile($w->{'selectPath'}, $f); + } + } else { + $selectFilePath = JoinFile($w->{'selectPath'}, + $w->{'selectFile'}); + } + if ($w->cget(-type) eq 'save' and + -e $selectFilePath and + !$w->cget(-force)) { + my $reply = $w->messageBox + (-icon => 'warning', + -type => 'YesNo', + -message => "File \"$selectFilePath\" already exists.\nDo you want to overwrite it?"); + return unless (lc($reply) eq 'yes'); + } + } + $w->{'selectFilePath'} = ($selectFilePath ne '' ? $selectFilePath : undef); +} + +sub FDialog { + my $cmd = shift; + if ($cmd =~ /Save/) { + push @_, -type => 'save'; + } elsif ($cmd =~ /Directory/) { + push @_, -type => 'dir'; + } + Tk::DialogWrapper('FBox', $cmd, @_); +} + +# tkFDGetFileTypes -- +# +# Process the string given by the -filetypes option of the file +# dialogs. Similar to the C function TkGetFileFilters() on the Mac +# and Windows platform. +# +sub GetFileTypes { + my $in = shift; + my %fileTypes; + foreach my $t (@$in) { + if (@$t < 2 || @$t > 3) { + require Carp; + Carp::croak("bad file type \"$t\", should be \"typeName [extension ?extensions ...?] ?[macType ?macTypes ...?]?\""); + } + push @{ $fileTypes{$t->[0]} }, (ref $t->[1] eq 'ARRAY' + ? @{ $t->[1] } + : $t->[1]); + } + + my @types; + my %hasDoneType; + my %hasGotExt; + foreach my $t (@$in) { + my $label = $t->[0]; + my @exts; + + next if (exists $hasDoneType{$label}); + + my $name = "$label ("; + my $sep = ''; + foreach my $ext (@{ $fileTypes{$label} }) { + next if ($ext eq ''); + $ext =~ s/^\./*./; + if (!exists $hasGotExt{$label}->{$ext}) { + $name .= "$sep$ext"; + push @exts, $ext; + $hasGotExt{$label}->{$ext}++; + } + $sep = ','; + } + $name .= ')'; + push @types, [$name, \@exts]; + + $hasDoneType{$label}++; + } + + return @types; +} + +# ext_chdir -- +# +# Change directory with tilde substitution +# +sub ext_chdir { + my $dir = shift; + if ($dir eq '~') { + chdir _get_homedir(); + } elsif ($dir =~ m|^~/(.*)|) { + chdir _get_homedir() . "/" . $1; + } elsif ($dir =~ m|^~([^/]+(.*))|) { + chdir _get_homedir($1) . $2; + } else { + chdir $dir; + } +} + +# _get_homedir -- +# +# Get home directory of the current user +# +sub _get_homedir { + my($user) = @_; + if (!defined $user) { + eval { + local $SIG{__DIE__}; + (getpwuid($<))[7]; + } || $ENV{HOME} || undef; # chdir undef changes to home directory, too + } else { + eval { + local $SIG{__DIE__}; + (getpwnam($user))[7]; + }; + } +} + +sub _cwd { + #Cwd::cwd(); + Cwd::fastcwd(); # this is taint-safe +} + +sub _untaint { + my $s = shift; + $s =~ /^(.*)$/; + $1; +} + +sub _rx_to_glob { + my $arg = shift; + $arg = join('|', split(' ', $arg)); + $arg =~ s!([\.\+])!\\$1!g; + $arg =~ s!\*!.*!g; + $arg = "^" . $arg . "\$"; + if ($] >= 5.005) { + $arg = qr/$arg/; + } + $arg; +} + +1; + diff --git a/Master/tlpkg/tlperl/lib/Tk/FileSelect.pm b/Master/tlpkg/tlperl/lib/Tk/FileSelect.pm new file mode 100644 index 00000000000..d2070049d82 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/FileSelect.pm @@ -0,0 +1,578 @@ +package Tk::FileSelect; + +use vars qw($VERSION @EXPORT_OK); +$VERSION = sprintf '4.%03d', q$Revision: #15 $ =~ /\D(\d+)\s*$/; +@EXPORT_OK = qw(glob_to_re); + +use Tk qw(Ev); +use strict; +use Carp; +use base qw(Tk::Toplevel); +use Tk::widgets qw(LabEntry Button Frame Listbox Scrollbar); +use File::Basename; + +Construct Tk::Widget 'FileSelect'; + +use vars qw(%error_text); +%error_text = ( + '-r' => 'is not readable by effective uid/gid', + '-w' => 'is not writeable by effective uid/gid', + '-x' => 'is not executable by effective uid/gid', + '-R' => 'is not readable by real uid/gid', + '-W' => 'is not writeable by real uid/gid', + '-X' => 'is not executable by real uid/gid', + '-o' => 'is not owned by effective uid/gid', + '-O' => 'is not owned by real uid/gid', + '-e' => 'does not exist', + '-z' => 'is not of size zero', + '-s' => 'does not exists or is of size zero', + '-f' => 'is not a file', + '-d' => 'is not a directory', + '-l' => 'is not a link', + '-S' => 'is not a socket', + '-p' => 'is not a named pipe', + '-b' => 'is not a block special file', + '-c' => 'is not a character special file', + '-u' => 'is not setuid', + '-g' => 'is not setgid', + '-k' => 'is not sticky', + '-t' => 'is not a terminal file', + '-T' => 'is not a text file', + '-B' => 'is not a binary file', + '-M' => 'has no modification date/time', + '-A' => 'has no access date/time', + '-C' => 'has no inode change date/time', + ); + +# Documentation after __END__ + +sub import { + if (defined $_[1] and $_[1] eq 'as_default') { + local $^W = 0; + package Tk; + if ($Tk::VERSION < 804) { + *FDialog = \&Tk::FileSelect::FDialog; + *MotifFDialog = \&Tk::FileSelect::FDialog; + } else { + *tk_getOpenFile = sub { + Tk::FileSelect::FDialog("tk_getOpenFile", @_); + }; + *tk_getSaveFile = sub { + Tk::FileSelect::FDialog("tk_getSaveFile", @_); + }; + } + } +} + +sub Cancel +{ + my ($cw) = @_; + $cw->{Selected} = undef; + $cw->withdraw unless $cw->cget('-transient'); +} + +sub Accept { + + # Accept the file or directory name if possible. + + my ($cw) = @_; + + my($path, $so) = ($cw->cget('-directory'), $cw->SelectionOwner); + my $leaf = undef; + my $leaves; + + if (defined $so and + $so == $cw->Subwidget('dir_list')->Subwidget('listbox')) { + $leaves = [$cw->Subwidget('dir_list')->getSelected]; + $leaves = [$cw->Subwidget('dir_entry')->get] if !scalar(@$leaves); + } else { + $leaves = [$cw->Subwidget('file_list')->getSelected]; + $leaves = [$cw->Subwidget('file_entry')->get] if !scalar(@$leaves); + } + + foreach $leaf (@$leaves) + { + if (defined $leaf and $leaf ne '') { + if (!$cw->cget('-create') || -e "$path/$leaf") + { + foreach (@{$cw->cget('-verify')}) { + my $r = ref $_; + if (defined $r and $r eq 'ARRAY') { + #local $_ = $leaf; # use strict var problem here + return if not &{$_->[0]}($cw, $path, $leaf, @{$_}[1..$#{$_}]); + } else { + my $s = eval "$_ '$path/$leaf'"; + print $@ if $@; + if (not $s) { + my $err; + if (substr($_,0,1) eq '!') + { + my $t = substr($_,1); + if (exists $error_text{$t}) + { + $err = $error_text{$t}; + $err =~ s/\b(?:no|not) //; + } + } + $err = $error_text{$_} unless defined $err; + $err = "failed '$_' test" unless defined $err; + $cw->Error("'$leaf' $err."); + return; + } + } + } # forend + } + else + { + unless (-w $path) + { + $cw->Error("Cannot write to $path"); + return; + } + } + $leaf = $path . '/' . $leaf; + } else { + $leaf = undef; + } + } + if (scalar(@$leaves)) + { + my $sm = $cw->Subwidget('file_list')->cget(-selectmode); + $cw->{Selected} = $leaves; + my $command = $cw->cget('-command'); + $command->Call(@{$cw->{Selected}}) if defined $command; + } + +} # end Accept + +sub Accept_dir +{ + my ($cw,$new) = @_; + my $dir = $cw->cget('-directory'); + $cw->configure(-directory => "$dir/$new"); +} + +sub Populate { + + my ($w, $args) = @_; + + require Tk::Listbox; + require Tk::Button; + require Tk::Dialog; + require Tk::Toplevel; + require Tk::LabEntry; + require Cwd; + + $w->SUPER::Populate($args); + $w->protocol('WM_DELETE_WINDOW' => ['Cancel', $w ]); + + $w->{'reread'} = 0; + $w->withdraw; + + # Create directory/filter entry, place at the top. + my $e = $w->Component( + LabEntry => 'dir_entry', + -textvariable => \$w->{DirectoryString}, + -labelVariable => \$w->{Configure}{-dirlabel}, + ); + $e->pack(-side => 'top', -expand => 0, -fill => 'x'); + $e->bind('<Return>' => [$w => 'validateDir', Ev(['get'])]); + + # Create file entry, place at the bottom. + $e = $w->Component( + LabEntry => 'file_entry', + -textvariable => \$w->{Configure}{-initialfile}, + -labelVariable => \$w->{Configure}{-filelabel}, + ); + $e->pack(-side => 'bottom', -expand => 0, -fill => 'x'); + $e->bind('<Return>' => [$w => 'validateFile', Ev(['get'])]); + $e->bind('<FocusIn>' => [$w => 'SelectionClear']); + + # Create directory scrollbox, place at the left-middle. + my $b = $w->Component( + ScrlListbox => 'dir_list', + -labelVariable => \$w->{Configure}{-dirlistlabel}, + -scrollbars => 'se', + ); + $b->pack(-side => 'left', -expand => 1, -fill => 'both'); + $b->bind('<Double-Button-1>' => [$w => 'Accept_dir', Ev(['getSelected'])]); + + # Add a label. + + my $f = $w->Frame(); + $f->pack(-side => 'right', -fill => 'y', -expand => 0); + $b = $f->Button('-textvariable' => \$w->{'Configure'}{'-acceptlabel'}, + -command => [ 'Accept', $w ], + ); + $b->pack(-side => 'top', -fill => 'x', -expand => 1); + $b = $f->Button('-textvariable' => \$w->{'Configure'}{'-cancellabel'}, + -command => [ 'Cancel', $w ], + ); + $b->pack(-side => 'top', -fill => 'x', -expand => 1); + $b = $f->Button('-textvariable' => \$w->{'Configure'}{'-resetlabel'}, + -command => [$w => 'configure','-directory','.'], + ); + $b->pack(-side => 'top', -fill => 'x', -expand => 1); + $b = $f->Button('-textvariable' => \$w->{'Configure'}{'-homelabel'}, + -command => [$w => 'configure','-directory',$ENV{'HOME'}], + ); + $b->pack(-side => 'top', -fill => 'x', -expand => 1); + + # Create file scrollbox, place at the right-middle. + + $b = $w->Component( + ScrlListbox => 'file_list', + -labelVariable => \$w->{Configure}{-filelistlabel}, + -scrollbars => 'se', + ); + $b->pack(-side => 'right', -expand => 1, -fill => 'both'); + $b->bind('<Double-1>' => [$w => 'Accept']); + + # Create -very dialog. + + my $v = $w->Component( + Dialog => 'dialog', + -title => 'Verify Error', + -bitmap => 'error', + -buttons => ['Dismiss'], + ); + + $w->ConfigSpecs( + -width => [ ['file_list','dir_list'], undef, undef, 14 ], + -height => [ ['file_list','dir_list'], undef, undef, 14 ], + -directory => [ 'METHOD', undef, undef, '.' ], + -initialdir => '-directory', + -filelabel => [ 'PASSIVE', 'fileLabel', 'FileLabel', 'File' ], + -initialfile => [ 'PASSIVE', undef, undef, '' ], + -filelistlabel => [ 'PASSIVE', undef, undef, 'Files' ], + -filter => [ 'METHOD', undef, undef, undef ], + -defaultextension => [ 'METHOD', undef, undef, undef ], + -regexp => [ 'METHOD', undef, undef, undef ], + -dirlistlabel => [ 'PASSIVE', undef, undef, 'Directories'], + -dirlabel => [ 'PASSIVE', undef, undef, 'Directory'], + '-accept' => [ 'CALLBACK',undef,undef, undef ], + -command => [ 'CALLBACK',undef,undef, undef ], + -transient => [ 'PASSIVE', undef, undef, 1 ], + -verify => [ 'PASSIVE', undef, undef, ['!-d'] ], + -create => [ 'PASSIVE', undef, undef, 0 ], + -acceptlabel => [ 'PASSIVE', undef, undef, 'Accept'], + -cancellabel => [ 'PASSIVE', undef, undef, 'Cancel'], + -resetlabel => [ 'PASSIVE', undef, undef, 'Reset'], + -homelabel => [ 'PASSIVE', undef, undef, 'Home'], + DEFAULT => [ 'file_list' ], + ); + $w->Delegates(DEFAULT => 'file_list'); + + return $w; + +} # end Populate + +sub translate + { + my ($bs,$ch) = @_; + return "\\$ch" if (length $bs); + return '.*' if ($ch eq '*'); + return '.' if ($ch eq '?'); + return "\\." if ($ch eq '.'); + return "\\/" if ($ch eq '/'); + return "\\\\" if ($ch eq '\\'); + return $ch; +} + +sub glob_to_re +{ + my $regex = shift; + $regex =~ s/(\\?)(.)/&translate($1,$2)/ge; + return sub { shift =~ /^${regex}$/ }; +} + +sub filter +{ + my ($cw,$val) = @_; + my $var = \$cw->{Configure}{'-filter'}; + if (@_ > 1 || !defined($$var)) + { + $val = '*' unless defined $val; + $$var = $val; + $cw->{'match'} = glob_to_re($val) unless defined $cw->{'match'}; + unless ($cw->{'reread'}++) + { + $cw->Busy; + $cw->afterIdle(['reread',$cw,$cw->cget('-directory')]) + } + } + return $$var; +} + +sub regexp +{ + my ($cw,$val) = @_; + my $var = \$cw->{Configure}{'-regexp'}; + if (@_ > 1) + { + $$var = $val; + $cw->{'match'} = (defined $val) ? sub { shift =~ m|^${val}$| } : sub { 1 }; + unless ($cw->{'reread'}++) + { + $cw->Busy; + $cw->afterIdle(['reread',$cw]) + } + } + return $$var; +} + +sub defaultextension +{ + my ($cw,$val) = @_; + if (@_ > 1) + { + $val = '' unless defined $val; + $val = ".$val" if ($val !~ /^\./); + $cw->filter("*$val"); + } + else + { + $val = $cw->filter; + my ($ext) = $val =~ /(\.[^\.]*)$/; + return $ext; + } +} + +sub directory +{ + my ($cw,$dir) = @_; + my $var = \$cw->{Configure}{'-directory'}; + if (@_ > 1 && defined $dir) + { + if (substr($dir,0,1) eq '~') + { + if (substr($dir,1,1) eq '/') + { + $dir = (defined $ENV{'HOME'} ? $ENV{'HOME'} : '') . substr($dir,1); + } + else + {my ($uid,$rest) = ($dir =~ m#^~([^/]+)(/.*$)#); + $dir = (getpwnam($uid))[7] . $rest; + } + } + my $revert_dir = sub + { + my $message = shift; + $$var = $cw->{OldDirectory}; + $cw->messageBox(-message => $message, -icon => 'error'); + if (!defined $$var) + { + # OldDirectory was never set, so force reread... + $$var = $cw->{OldDirectory} = Cwd::getcwd(); # XXX maybe use check like code below... + unless ($cw->{'reread'}++) + { + $cw->Busy; + $cw->afterIdle(['reread',$cw]) + } + } + $$var; + }; + $dir =~ s#([^/\\])[\\/]+$#$1#; + if (-d $dir) + { + unless (Tk::tainting()) + { + my $pwd = Cwd::getcwd(); + if (chdir( (defined($dir) ? $dir : '') ) ) + { + my $new = Cwd::getcwd(); + if ($new) + { + $dir = $new; + } + else + { + return $revert_dir->("Cannot getcwd in '$dir'"); + } + if (!chdir($pwd)) + { + return $revert_dir->("Cannot change directory to $pwd:\n$!"); + } + $$var = $dir; + } + else + { + return $revert_dir->("Cannot change directory to $dir:\n$!"); + } + $$var = $cw->{OldDirectory} = $dir; + } + unless ($cw->{'reread'}++) + { + $cw->Busy; + $cw->afterIdle(['reread',$cw]) + } + } + } + return $$var; +} + +sub reread +{ + my ($w) = @_; + my $dir = $w->cget('-directory'); + if (defined $dir) + { + if (!defined $w->cget('-filter') or $w->cget('-filter') eq '') + { + $w->configure('-filter', '*'); + } + my $dl = $w->Subwidget('dir_list'); + $dl->delete(0, 'end'); + $dl->selectionClear(0,'end'); + my $fl = $w->Subwidget('file_list'); + $fl->delete(0, 'end'); + local *DIR; + if (opendir(DIR, $dir)) + { + my $file = $w->cget('-initialfile'); + my $seen = 0; + my $accept = $w->cget('-accept'); + foreach my $f (sort(readdir(DIR))) + { + next if ($f eq '.'); + my $path = "$dir/$f"; + if (-d $path) + { + $dl->insert('end', $f); + } + else + { + if (&{$w->{match}}($f)) + { + if (!defined($accept) || $accept->Call($path)) + { + $seen = $fl->index('end') if ($file && $f eq $file); + $fl->insert('end', $f) + } + } + } + } + closedir(DIR); + if ($seen) + { + $fl->selectionSet($seen); + $fl->see($seen); + } + else + { + $w->configure(-initialfile => undef) unless $w->cget('-create'); + } + } + $w->{DirectoryString} = $dir . ($dir ne '/' ? '/' : '') . $w->cget('-filter'); + } + $w->{'reread'} = 0; + $w->Unbusy if $w->{'Busy'}; +} + +sub validateDir +{ + my ($cw,$name) = @_; + my ($leaf,$base) = fileparse($name); + if ($leaf =~ /[*?]/) + { + $cw->configure('-directory' => $base,'-filter' => $leaf); + } + else + { + $cw->configure('-directory' => $name); + } +} + +sub validateFile +{ + my ($cw,$name) = @_; + my $i = 0; + my $n = $cw->index('end'); + # See if it is an existing file + for ($i= 0; $i < $n; $i++) + { + my $f = $cw->get($i); + if ($f eq $name) + { + $cw->selection('set',$i); + $cw->Accept; + } + } + # otherwise allow if -create is set, directory is writable + # and it passes filter and accept criteria + if ($cw->cget('-create')) + { + my $path = $cw->cget('-directory'); + if (-w $path) + { + if (&{$cw->{match}}($name)) + { + my $accept = $cw->cget('-accept'); + my $full = "$path/$name"; + if (!defined($accept) || $accept->Call($full)) + { + $cw->{Selected} = [$full]; + $cw->Callback(-command => @{$cw->{Selected}}); + } + else + { + $cw->Error("$name is not 'acceptable'"); + } + } + else + { + $cw->Error("$name does not match '".$cw->cget('-filter').'\''); + } + } + else + { + $cw->Error("Directory '$path' is not writable"); + return; + } + } +} + +sub Error +{ + my $cw = shift; + my $msg = shift; + my $dlg = $cw->Subwidget('dialog'); + $dlg->configure(-text => $msg); + $dlg->Show; +} + +sub Show +{ + my ($cw,@args) = @_; + if ($cw->cget('-transient')) { + $cw->Popup(@args); + $cw->focus; + $cw->waitVariable(\$cw->{Selected}); + $cw->withdraw; + return defined($cw->{Selected}) + ? (wantarray) ? @{$cw->{Selected}} : $cw->{Selected}[0] + : undef; + } else { + $cw->Popup(@args); + } +} + +sub FDialog +{ + my($cmd, %args) = @_; + if ($cmd =~ /Save/) + { + $args{-create} = 1; + $args{-verify} = [qw(!-d -w)]; + } + delete $args{-filetypes}; + delete $args{-force}; + Tk::DialogWrapper('FileSelect',$cmd, %args); +} + +1; + +__END__ + +=cut + diff --git a/Master/tlpkg/tlperl/lib/Tk/FloatEntry.pm b/Master/tlpkg/tlperl/lib/Tk/FloatEntry.pm new file mode 100644 index 00000000000..eb6465dbe61 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/FloatEntry.pm @@ -0,0 +1,109 @@ +# Tranlation of FloatEnt.tcl in Tix4.1 + +# TODO/IDEA: +# o extract a widget (SimpleEntry?) without post/unpost methods +# and derive FloatEntry fron this widget. + +package Tk::FloatEntry; +use strict; + +BEGIN + { + use vars '$DEBUG'; + $DEBUG = (defined($ENV{USER}) and $ENV{USER} eq 'achx') ? 1 : 0; + print STDERR "tixGrid: debug = $DEBUG\n" if $DEBUG; + } + +require Tk; +require Tk::Widget; +require Tk::Derived; +require Tk::Entry; + +use vars qw($VERSION); +$VERSION = '4.004'; # $Id: //depot/Tkutf8/TixGrid/FloatEntry.pm#4 $ + +use base qw(Tk::Derived Tk::Entry); + +Construct Tk::Widget 'FloatEntry'; + +sub ClassInit + { + my ($class, $mw) = @_; + $class->SUPER::ClassInit($mw); + $mw->bind($class, '<Return>', 'invoke'); + $mw->bind($class, '<FocusIn>', 'FocusIn'); + $class; + } + +sub Populate + { + my ($e, $args) = @_; + $e->ConfigSpecs( + -value => ['METHOD', 'value', 'Value', undef], + -highlightthickness => [$e, 'highlightThickness', 'HighlightThickness', 0 ], + -command => ['CALLBACK', 'command', 'Command', undef], + ); + print "FloatEntry Init: $e\n" if $DEBUG; + $e; + } + +## option method + +sub value + { + my $e = shift; + unless (@_) + { + return $e->get + } + $e->delete(0,'end'); + $e->insert(0,$_[0]); + $e->selection('from', 0); + $e->selection('to', 'end'); + + } + +## public methods + +sub invoke + { + my ($e) = @_; + $e->Callback('-command', $e->get); + } + +sub post + { + my ($e, $x, $y, $dx, $dy) = @_; + + $dx = $e->reqwidth unless defined $dx; + $dy = $e->reqheight unless defined $dy; + + $e->place('-x'=>$x, '-y'=>$y, -width=>$dx, -height=>$dy, -bordermode=>'ignore'); + $e->raise; + $e->focus; + } + +sub unpost + { + my ($e) = @_; + $e->place('forget'); + } + +## bindings + +sub FocusIn + { + my ($e) = @_; + + # FIX: xxx only if entry has not already focus + { + $e->focus; + $e->selection('from', 0); + $e->selection('to', 'end'); + $e->icursor('end'); + } + } + +1; +__END__ + diff --git a/Master/tlpkg/tlperl/lib/Tk/Font.pm b/Master/tlpkg/tlperl/lib/Tk/Font.pm new file mode 100644 index 00000000000..bb1b52cc7c5 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Font.pm @@ -0,0 +1,163 @@ +package Tk::Font; +use vars qw($VERSION); +$VERSION = '4.004'; # $Id: //depot/Tkutf8/Tk/Font.pm#4 $ +require Tk::Widget; +use strict; +use Carp; +use overload '""' => 'as_string'; +sub as_string { return ${$_[0]} } + +*MainWindow = \&Tk::Widget::MainWindow; + +foreach my $key (qw(actual metrics measure configure)) + { + no strict 'refs'; + *{$key} = sub { shift->Tk::font($key,@_) }; + } + +Construct Tk::Widget 'Font'; + +my @xfield = qw(foundry family weight slant swidth adstyle pixel + point xres yres space avgwidth registry encoding); +my @tkfield = qw(family size weight slant underline overstrike); +my %tkfield = map { $_ => "-$_" } @tkfield; + +sub _xonly { my $old = '*'; return $old } + +sub Pixel +{ + my $me = shift; + my $old = $me->configure('-size'); + $old = '*' if ($old > 0); + if (@_) + { + $me->configure(-size => -$_[0]); + } + return $old; +} + +sub Point +{ + my $me = shift; + my $old = 10*$me->configure('-size'); + $old = '*' if ($old < 0); + if (@_) + { + $me->configure(-size => int($_[0]/10)); + } + return $old; +} + +foreach my $f (@tkfield,@xfield) + { + no strict 'refs'; + my $sub = "\u$f"; + unless (defined &{$sub}) + { + my $key = $tkfield{$f}; + if (defined $key) + { + *{$sub} = sub { shift->configure($key,@_) }; + } + else + { + *{$sub} = \&_xonly; + } + } + } + +sub new +{ + my $pkg = shift; + my $w = shift; + my $me; + if (scalar(@_) == 1) + { + $me = $w->Tk::font('create',@_); + } + else + { + croak 'Odd number of args' if @_ & 1; + my %attr; + while (@_) + { + my $k = shift; + my $v = shift; + my $t = (substr($k,0,1) eq '-') ? $k : $tkfield{$k}; + if (defined $t) + { + $attr{$t} = $v; + } + elsif ($k eq 'point') + { + $attr{'-size'} = -int($v/10+0.5); + } + elsif ($k eq 'pixel') + { + $attr{'-size'} = -$v; + } + else + { + carp "$k ignored" if $^W; + } + } + $me = $w->Tk::font('create',%attr); + } + return bless $me,$pkg; +} + +sub Pattern +{ + my $me = shift; + my @str; + foreach my $f (@xfield) + { + my $meth = "\u$f"; + my $str = $me->$meth(); + if ($f eq 'family') + { + $str =~ s/(?:Times\s+New\s+Roman|New York)/Times/i; + $str =~ s/(?:Courier\s+New|Monaco)/Courier/i; + $str =~ s/(?:Arial|Geneva)/Helvetica/i; + } + elsif ($f eq 'slant') + { + $str = substr($str,0,1); + } + elsif ($f eq 'weight') + { + $str = 'medium' if ($str eq 'normal'); + } + push(@str,$str); + } + return join('-', '', @str); +} + +sub Name +{ + my $me = shift; + return $$me if (!wantarray || ($^O eq 'MSWin32')); + my $max = shift || 128; + my $w = $me->MainWindow; + my $d = $w->Display; + return $d->XListFonts($me->Pattern,$max); +} + +sub Clone +{ + my $me = shift; + return ref($me)->new($me,$me->actual,@_); +} + +sub ascent +{ + return shift->metrics('-ascent'); +} + +sub descent +{ + return shift->metrics('-descent'); +} + +1; + diff --git a/Master/tlpkg/tlperl/lib/Tk/Frame.pm b/Master/tlpkg/tlperl/lib/Tk/Frame.pm new file mode 100644 index 00000000000..a5716cdf9bd --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Frame.pm @@ -0,0 +1,378 @@ +# Copyright (c) 1995-2003 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. +package Tk::Frame; +require Tk::Widget; +require Tk::Derived; +use AutoLoader; +use strict qw(vars); +use Carp; + +use base qw(Tk::Derived Tk::Widget); + +Construct Tk::Widget 'Frame'; + +use vars qw($VERSION); +$VERSION = '4.010'; # $Id: //depot/Tkutf8/Tk/Frame.pm#10 $ + +sub Tk_cmd { \&Tk::frame } + +sub CreateOptions +{ + return (shift->SUPER::CreateOptions,'-colormap','-visual','-container') +} + +sub Default +{ + my ($cw,$name,$widget) = @_; + confess 'No name' unless (defined $name); + croak 'No widget' unless (defined $widget); + $cw->Delegates(DEFAULT => $widget); + $cw->ConfigSpecs(DEFAULT => [$widget]); + $widget->pack('-expand' => 1, -fill => 'both') unless ($widget->manager); # Suspect + $cw->Advertise($name,$widget); +} + +sub ConfigDelegate +{ + my ($cw,$name,@skip) = @_; + my $sw = $cw->Subwidget($name); + my $sc; + my %skip = (); + foreach $sc (@skip) + { + $skip{$sc} = 1; + } + foreach $sc ($sw->configure) + { + my (@info) = @$sc; + next if (@info == 2); + my $option = $info[0]; + unless ($skip{$option}) + { + $option =~ s/^-(.*)/-$name\u$1/; + $info[0] = Tk::Configure->new($sw,$info[0]); + pop(@info); + $cw->ConfigSpecs($option => \@info); + } + } +} + +sub bind +{my ($cw,@args) = @_; + $cw->Delegate('bind',@args); +} + +sub menu +{my ($cw,@args) = @_; + $cw->Delegate('menu',@args); +} + +sub focus +{my ($cw,@args) = @_; + $cw->Delegate('focus',@args); +} + +#sub bindtags +#{my ($cw,@args) = @_; +# $cw->Delegate('bindtags',@args); +#} + +sub selection +{my ($cw,@args) = @_; + $cw->Delegate('selection',@args); +} + +sub autoLabel { 1 } + +sub Populate +{ + my ($cw,$args) = @_; + if ($cw->autoLabel) + { + $cw->ConfigSpecs('-labelPack' => [ 'METHOD', undef, undef, undef]); + $cw->ConfigSpecs('-labelVariable' => [ 'METHOD', undef, undef, undef]); + $cw->ConfigSpecs('-label' => [ 'METHOD', undef, undef, undef]); + $cw->labelPack([]) if grep /^-label\w+/, keys %$args; + } +} + +sub Menubar +{ + my $frame = shift; + my $menu = $frame->cget('-menu'); + if (defined $menu) + { + $menu->configure(@_) if @_; + } + else + { + $menu = $frame->Menu(-type => 'menubar',@_); + $frame->configure('-menu' => $menu); + } + $frame->Advertise('menubar' => $menu); + return $menu; +} + +1; + +__END__ + +sub labelPack +{ + my ($cw,$val) = @_; + my $w = $cw->Subwidget('label'); + my @result = (); + if (@_ > 1) + { + if (defined($w) && !defined($val)) + { + $w->packForget; + } + elsif (defined($val) && !defined ($w)) + { + require Tk::Label; + $w = Tk::Label->new($cw,-textvariable => $cw->labelVariable); + $cw->Advertise('label' => $w); + $cw->ConfigDelegate('label',qw(-text -textvariable)); + } + if (defined($val) && defined($w)) + { + my %pack = @$val; + unless (exists $pack{-side}) + { + $pack{-side} = 'top' unless (exists $pack{-side}); + } + unless (exists $pack{-fill}) + { + $pack{-fill} = 'x' if ($pack{-side} =~ /(top|bottom)/); + $pack{-fill} = 'y' if ($pack{-side} =~ /(left|right)/); + } + unless (exists($pack{'-before'}) || exists($pack{'-after'})) + { + my $before = ($cw->packSlaves)[0]; + $pack{'-before'} = $before if (defined $before); + } + $w->pack(%pack); + } + } + @result = $w->packInfo if (defined $w); + return (wantarray) ? @result : \@result; +} + +sub labelVariable +{ + my ($cw,$val) = @_; + my $var = \$cw->{Configure}{'-labelVariable'}; + if (@_ > 1 && defined $val) + { + $$var = $val; + $$val = '' unless (defined $$val); + my $w = $cw->Subwidget('label'); + unless (defined $w) + { + $cw->labelPack([]); + $w = $cw->Subwidget('label'); + } + $w->configure(-textvariable => $val); + } + return $$var; +} + +sub label +{ + my ($cw,$val) = @_; + my $var = $cw->cget('-labelVariable'); + if (@_ > 1 && defined $val) + { + if (!defined $var) + { + $var = \$cw->{Configure}{'-label'}; + $cw->labelVariable($var); + } + $$var = $val; + } + return (defined $var) ? $$var : undef;; +} + +sub queuePack +{ + my ($cw) = @_; + unless ($cw->{'pack_pending'}) + { + $cw->{'pack_pending'} = 1; + $cw->afterIdle([$cw,'packscrollbars']); + } +} + +sub sbset +{ + my ($cw,$sb,$ref,@args) = @_; + $sb->set(@args); + $cw->queuePack if (@args == 2 && $sb->Needed != $$ref); +} + +sub freeze_on_map +{ + my ($w) = @_; + unless ($w->Tk::bind('Freeze','<Map>')) + { + $w->Tk::bind('Freeze','<Map>',['packPropagate' => 0]) + } + $w->AddBindTag('Freeze'); +} + +sub AddScrollbars +{ + require Tk::Scrollbar; + my ($cw,$w) = @_; + my $def = ''; + my ($x,$y) = ('',''); + my $s = 0; + my $c; + $cw->freeze_on_map; + foreach $c ($w->configure) + { + my $opt = $c->[0]; + if ($opt eq '-yscrollcommand') + { + my $slice = Tk::Frame->new($cw,Name => 'ysbslice'); + my $ysb = Tk::Scrollbar->new($slice,-orient => 'vertical', -command => [ 'yview', $w ]); + my $size = $ysb->cget('-width'); + my $corner = Tk::Frame->new($slice,Name=>'corner','-relief' => 'raised', + '-width' => $size, '-height' => $size); + $ysb->pack(-side => 'left', -fill => 'y'); + $cw->Advertise('yscrollbar' => $ysb); + $cw->Advertise('corner' => $corner); + $cw->Advertise('ysbslice' => $slice); + $corner->{'before'} = $ysb->PathName; + $slice->{'before'} = $w->PathName; + $y = 'w'; + $s = 1; + } + elsif ($opt eq '-xscrollcommand') + { + my $xsb = Tk::Scrollbar->new($cw,-orient => 'horizontal', -command => [ 'xview', $w ]); + $cw->Advertise('xscrollbar' => $xsb); + $xsb->{'before'} = $w->PathName; + $x = 's'; + $s = 1; + } + } + if ($s) + { + $cw->Advertise('scrolled' => $w); + $cw->ConfigSpecs('-scrollbars' => ['METHOD','scrollbars','Scrollbars',$x.$y]); + } +} + +sub packscrollbars +{ + my ($cw) = @_; + my $opt = $cw->cget('-scrollbars'); + my $slice = $cw->Subwidget('ysbslice'); + my $xsb = $cw->Subwidget('xscrollbar'); + my $corner = $cw->Subwidget('corner'); + my $w = $cw->Subwidget('scrolled'); + my $xside = (($opt =~ /n/) ? 'top' : 'bottom'); + my $havex = 0; + my $havey = 0; + $opt =~ s/r//; + $cw->{'pack_pending'} = 0; + if (defined $slice) + { + my $reqy; + my $ysb = $cw->Subwidget('yscrollbar'); + if ($opt =~ /(o)?[we]/ && (($reqy = !defined($1)) || $ysb->Needed)) + { + my $yside = (($opt =~ /w/) ? 'left' : 'right'); + $slice->pack(-side => $yside, -fill => 'y',-before => $slice->{'before'}); + $havey = 1; + if ($reqy) + { + $w->configure(-yscrollcommand => ['set', $ysb]); + } + else + { + $w->configure(-yscrollcommand => ['sbset', $cw, $ysb, \$cw->{'packysb'}]); + } + } + else + { + $w->configure(-yscrollcommand => undef) unless $opt =~ s/[we]//; + $slice->packForget; + } + $cw->{'packysb'} = $havey; + } + if (defined $xsb) + { + my $reqx; + if ($opt =~ /(o)?[ns]/ && (($reqx = !defined($1)) || $xsb->Needed)) + { + $xsb->pack(-side => $xside, -fill => 'x',-before => $xsb->{'before'}); + $havex = 1; + if ($reqx) + { + $w->configure(-xscrollcommand => ['set', $xsb]); + } + else + { + $w->configure(-xscrollcommand => ['sbset', $cw, $xsb, \$cw->{'packxsb'}]); + } + } + else + { + $w->configure(-xscrollcommand => undef) unless $opt =~ s/[ns]//; + $xsb->packForget; + } + $cw->{'packxsb'} = $havex; + } + if (defined $corner) + { + if ($havex && $havey && defined $corner->{'before'}) + { + my $anchor = $opt; + $anchor =~ s/o//g; + $corner->configure(-height => $xsb->ReqHeight); + $corner->pack(-before => $corner->{'before'}, -side => $xside, + -anchor => $anchor, -fill => 'x'); + } + else + { + $corner->packForget; + } + } +} + +sub scrollbars +{ + my ($cw,$opt) = @_; + my $var = \$cw->{'-scrollbars'}; + if (@_ > 1) + { + my $old = $$var; + if (!defined $old || $old ne $opt) + { + $$var = $opt; + $cw->queuePack; + } + } + return $$var; +} + +sub FindMenu +{ + my ($w,$char) = @_; + my $child; + my $match; + foreach $child ($w->children) + { + next unless (ref $child); + $match = $child->FindMenu($char); + return $match if (defined $match); + } + return undef; +} + + + diff --git a/Master/tlpkg/tlperl/lib/Tk/HList.pm b/Master/tlpkg/tlperl/lib/Tk/HList.pm new file mode 100644 index 00000000000..02792208243 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/HList.pm @@ -0,0 +1,680 @@ +package Tk::HList; + +use vars qw($VERSION); +$VERSION = 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)], + 'hide' => [qw(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] || ''; + } + + 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; + + diff --git a/Master/tlpkg/tlperl/lib/Tk/IO.pm b/Master/tlpkg/tlperl/lib/Tk/IO.pm new file mode 100644 index 00000000000..771e9f7103a --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/IO.pm @@ -0,0 +1,182 @@ +package Tk::IO; +use strict; +use vars qw($VERSION); +$VERSION = '4.004'; # $Id: //depot/Tkutf8/IO/IO.pm#4 $ + +require 5.002; +use Tk::Event qw($XS_VERSION); + +use Carp; +use base qw(DynaLoader IO::Handle); + +bootstrap Tk::IO; + +my %fh2obj; +my %obj2fh; + +sub new +{ + my ($package,%args) = @_; + # Do whatever IO::Handle does + my $fh = $package->SUPER::new; + %{*$fh} = (); # The hash is used for configure options + ${*$fh} = ''; # The scalar is used as the 'readable' buffer + @{*$fh} = (); # The array + $fh->configure(%args); + return $fh; +} + +sub pending +{ + my $fh = shift; + return ${*$fh}; +} + +sub cget +{ + my ($fh,$key) = @_; + return ${*$fh}{$key}; +} + +sub configure +{ + my ($fh,%args) = @_; + my $key; + foreach $key (keys %args) + { + my $val = $args{$key}; + $val = Tk::Callback->new($val) if ($key =~ /command$/); + ${*$fh}{$key} = $val; + } +} + +sub killpg +{ + my ($fh,$sig) = @_; + my $pid = $fh->pid; + croak 'No child' unless (defined $pid); + kill($sig,-$pid); +} + +sub kill +{ + my ($fh,$sig) = @_; + my $pid = $fh->pid; + croak 'No child' unless (defined $pid); + kill($sig,$pid) || croak "Cannot kill($sig,$pid):$!"; +} + +sub readable +{ + my $fh = shift; + my $count = sysread($fh,${*$fh},1,length(${*$fh})); + if ($count < 0) + { + if (exists ${*$fh}{-errorcommand}) + { + ${*$fh}{-errorcommand}->Call($!); + } + else + { + warn "Cannot read $fh:$!"; + $fh->close; + } + } + elsif ($count) + { + if (exists ${*$fh}{-linecommand}) + { + my $eol = index(${*$fh},"\n"); + if ($eol >= 0) + { + my $line = substr(${*$fh},0,++$eol); + substr(${*$fh},0,$eol) = ''; + ${*$fh}{-linecommand}->Call($line); + } + } + } + else + { + $fh->close; + } +} + +sub pid +{ + my $fh = shift; + return ${*$fh}{-pid}; +} + +sub command +{ + my $fh = shift; + my $cmd = ${*$fh}{'-exec'}; + return (wantarray) ? @$cmd : $cmd; +} + +sub exec +{ + my $fh = shift; + my $pid = open($fh,'-|'); + if ($pid) + { + ${*$fh} = '' unless (defined ${*$fh}); + ${*$fh}{'-exec'} = [@_]; + ${*$fh}{'-pid'} = $pid; + if (exists ${*$fh}{-linecommand}) + { + my $w = ${*$fh}{-widget}; + $w = 'Tk' unless (defined $w); + $w->fileevent($fh,'readable',[$fh,'readable']); + ${*$fh}{_readable} = $w; + } + else + { + croak Tk::Pretty::Pretty(\%{*$fh}); + } + return $pid; + } + else + { + # make STDERR same as STDOUT here + setpgrp; + exec(@_) || die 'Cannot exec ',join(' ',@_),":$!"; + } +} + +sub wait +{ + my $fh = shift; + my $code; + my $ch = delete ${*$fh}{-childcommand}; + ${*$fh}{-childcommand} = Tk::Callback->new(sub { $code = shift }); + Tk::Event::DoOneEvent(0) until (defined $code); + if (defined $ch) + { + ${*$fh}{-childcommand} = $ch; + $ch->Call($code,$fh) + } + return $code; +} + +sub close +{ + my $fh = shift; + my $code; + if (defined fileno($fh)) + { + my $w = delete ${*$fh}{_readable}; + $w->fileevent($fh,'readable','') if (defined $w); + $code = close($fh); + if (exists ${*$fh}{-childcommand}) + { + ${*$fh}{-childcommand}->Call($?,$fh); + } + } + return $code; +} + +1; +__END__ + + diff --git a/Master/tlpkg/tlperl/lib/Tk/IconList.pm b/Master/tlpkg/tlperl/lib/Tk/IconList.pm new file mode 100644 index 00000000000..1972809ea2a --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/IconList.pm @@ -0,0 +1,712 @@ +# -*- perl -*- +# +# tkfbox.tcl -- +# +# Implements the "TK" standard file selection dialog box. This +# dialog box is used on the Unix platforms whenever the tk_strictMotif +# flag is not set. +# +# The "TK" standard file selection dialog box is similar to the +# file selection dialog box on Win95(TM). The user can navigate +# the directories by clicking on the folder icons or by +# selectinf the "Directory" option menu. The user can select +# files by clicking on the file icons or by entering a filename +# in the "Filename:" entry. +# +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# Translated to perk/Tk and modified by Slaven Rezic <slaven@rezic.de>. +# + +#---------------------------------------------------------------------- +# +# I C O N L I S T +# +# This is a pseudo-widget that implements the icon list inside the +# tkFDialog dialog box. +# +#---------------------------------------------------------------------- +# tkIconList -- +# +# Creates an IconList widget. +# + +package Tk::IconList; +require Tk::Frame; + +use vars qw($VERSION); +$VERSION = '4.007'; # $Id: //depot/Tkutf8/Tk/IconList.pm#7 $ + +use Tk qw(Ev); +use strict; +use Carp; + +use base 'Tk::Frame'; + +Construct Tk::Widget 'IconList'; + +# tkIconList_Create -- +# +# Creates an IconList widget by assembling a canvas widget and a +# scrollbar widget. Sets all the bindings necessary for the IconList's +# operations. +# +sub Populate { + my($w, $args) = @_; + $w->SUPER::Populate($args); + + my $sbar = $w->Component('Scrollbar' => 'sbar', + -orient => 'horizontal', + -highlightthickness => 0, + -takefocus => 0, + ); + # make sure that the size does not exceed handhelds' dimensions + my($sw,$sh) = ($w->screenwidth, $w->screenheight); + my $canvas = $w->Component('Canvas' => 'canvas', + -bd => 2, + -relief => 'sunken', + -width => ($sw > 420 ? 400 : $sw-20), + -height => ($sh > 160 ? 120 : $sh-40), + -takefocus => 1, + ); + $sbar->pack(-side => 'bottom', -fill => 'x', -padx => 2); + $canvas->pack(-expand => 'yes', -fill => 'both'); + $sbar->configure(-command => ['xview', $canvas]); + $canvas->configure(-xscrollcommand => ['set', $sbar]); + + # Initializes the max icon/text width and height and other variables + $w->{'maxIW'} = 1; + $w->{'maxIH'} = 1; + $w->{'maxTW'} = 1; + $w->{'maxTH'} = 1; + $w->{'numItems'} = 0; +#XXX curItem never used delete $w->{'curItem'}; + $w->{'noScroll'} = 1; + $w->{'selection'} = []; + $w->{'index,anchor'} = ''; + + # Creates the event bindings. + $canvas->Tk::bind('<Configure>', sub { $w->Arrange } ); + $canvas->Tk::bind('<1>', [$w,'Btn1',Ev('x'),Ev('y')]); + $canvas->Tk::bind('<B1-Motion>', [$w,'Motion1',Ev('x'),Ev('y')]); + $canvas->Tk::bind('<Control-B1-Motion>', 'NoOp'); + $canvas->Tk::bind('<Shift-B1-Motion>', 'NoOp'); + $canvas->Tk::bind('<Control-1>', [$w,'CtrlBtn1',Ev('x'),Ev('y')]); + $canvas->Tk::bind('<Shift-1>', [$w,'ShiftBtn1',Ev('x'),Ev('y')]); + $canvas->Tk::bind('<Double-ButtonRelease-1>', [$w,'Double1',Ev('x'),Ev('y')]); + $canvas->Tk::bind('<Control-Double-ButtonRelease-1>', 'NoOp'); + $canvas->Tk::bind('<Shift-Double-ButtonRelease-1>', 'NoOp'); + $canvas->Tk::bind('<ButtonRelease-1>', [$w,'CancelRepeat']); + $canvas->Tk::bind('<B1-Leave>', [$w,'Leave1',Ev('x'),Ev('y')]); + $canvas->Tk::bind('<B1-Enter>', [$w,'CancelRepeat']); + $canvas->Tk::bind('<Up>', [$w,'UpDown', -1]); + $canvas->Tk::bind('<Down>', [$w,'UpDown', 1]); + $canvas->Tk::bind('<Left>', [$w,'LeftRight',-1]); + $canvas->Tk::bind('<Right>', [$w,'LeftRight', 1]); + $canvas->Tk::bind('<Return>', [$w,'ReturnKey']); + $canvas->Tk::bind('<KeyPress>', [$w,'KeyPress',Ev('A')]); + $canvas->Tk::bind('<Control-KeyPress>', 'NoOp'); + $canvas->Tk::bind('<Alt-KeyPress>', 'NoOp'); + $canvas->Tk::bind('<Meta-KeyPress>', 'NoOp'); +#XXX bad.... +# $canvas->Tk::bind('<FocusIn>', sub { $w->FocusIn }); +# $canvas->Tk::bind('<FocusOut>', sub { $w->FocusOut }); + + # additional bindings not in tkfbox.tcl + $canvas->Tk::bind('<2>',['scan','mark',Ev('x'),Ev('y')]); + $canvas->Tk::bind('<B2-Motion>',['scan','dragto',Ev('x'),Ev('y')]); + # Remove the standard Canvas bindings + $canvas->bindtags([$canvas, $canvas->toplevel, 'all']); + # ... and define some again + $canvas->Tk::bind('<Home>', ['xview','moveto',0]); + $canvas->Tk::bind('<End>', ['xview','moveto',1]); + + $w->ConfigSpecs(-browsecmd => + ['METHOD', 'browseCommand', 'BrowseCommand', undef], + -command => + ['CALLBACK', 'command', 'Command', undef], + -font => + ['PASSIVE', 'font', 'Font', undef], + -foreground => + ['PASSIVE', 'foreground', 'Foreground', undef], + -fg => '-foreground', + -multiple => + ['PASSIVE', 'multiple', 'Multiple', 0], + -selectmode => + ['PASSIVE', 'selectMode', 'SelectMode', 'browse'], + -selectbackground => + ['PASSIVE', 'selectBackground', 'Foreground', '#a0a0ff'], + ); + + $w; +} + +# compatibility for old -browsecmd options +sub browsecmd { + my $w = shift; + if (@_) { + $w->{Configure}{'-browsecmd'} = $_[0]; + $w->bind('<<ListboxSelect>>' => $_[0]); + } + $w->{Configure}{'-browsecmd'}; +} + +sub Index { + my($w, $i) = @_; + if (!$w->{'list'}) { $w->{'list'} = [] } + if ($i =~ /^-?[0-9]+$/) { + if ($i < 0) { + $i = 0; + } + if ($i > @{ $w->{'list'} }) { + $i = @{ $w->{'list'} } - 1; + } + return $i; + } elsif ($i eq 'active') { + return $w->{'index,active'}; + } elsif ($i eq 'anchor') { + return $w->{'index,anchor'}; + } elsif ($i eq 'end') { + return @{ $w->{'list'} }; + } elsif ($i =~ /@(-?[0-9]+),(-?[0-9]+)/) { + my($x, $y) = ($1, $2); + my $canvas = $w->Subwidget('canvas'); + my $item = $canvas->find('closest', $x, $y); + if (defined $item) { + return $canvas->itemcget($item, '-tags')->[1]; + } else { + return ""; + } + } else { + croak "Unrecognized Index parameter `$i', use active, anchor, end, \@x,y, or x"; + } +} + +sub Selection { + my($w, $op, @args) = @_; + if ($op eq 'anchor') { + if (@args == 1) { + $w->{'index,anchor'} = $w->Index($args[0]); + } else { + return $w->{'index,anchor'}; + } + } elsif ($op eq 'clear') { + my($first, $last); + if (@args == 2) { + ($first, $last) = @args; + } elsif (@args == 1) { + $first = $last = $args[0]; + } else { + croak "wrong # args: should be Selection('clear', first, ?last?)" + } + $first = $w->Index($first); + $last = $w->Index($last); + if ($first > $last) { + ($first, $last) = ($last, $first); + } + my $ind = 0; + for my $item (@{ $w->{'selection'} }) { + if ($item >= $first) { + $first = $ind; + last; + } + $ind++; # XXX seems to be missing in the Tcl version + } + $ind = @{ $w->{'selection'} } - 1; + for(; $ind >= 0; $ind--) { + my $item = $w->{'selection'}->[$ind]; + if ($item <= $last) { + $last = $ind; + last; + } + } + if ($first > $last) { + return; + } + splice @{ $w->{'selection'} }, $first, $last-$first+1; + $w->event('generate', '<<ListboxSelect>>'); + $w->DrawSelection; + } elsif ($op eq 'includes') { + my $index; + for (@{ $w->{'selection'} }) { + if ($args[0] eq $_) { + return 1; + } + } + return 0; + } elsif ($op eq 'set') { + my($first, $last); + if (@args == 2) { + ($first, $last) = @args; + } elsif (@args == 1) { + $first = $last = $args[0]; + } else { + croak "wrong # args: should be Selection('set', first, ?last?)"; + } + + $first = $w->Index($first); + $last = $w->Index($last); + if ($first > $last) { + ($first, $last) = ($last, $first); + } + for(my $i = $first; $i <= $last; $i++) { + push @{ $w->{'selection'} }, $i; + } + # lsort -integer -unique + my %sel = map { ($_ => 1) } @{ $w->{'selection'} }; + @{ $w->{'selection'} } = sort { $a <=> $b } keys %sel; + $w->event('generate', '<<ListboxSelect>>'); + $w->DrawSelection; + } else { + croak "Unrecognized Selection parameter `$op', use anchor, clear, includes, or set"; + } +} + +# XXX why lower case 's' here and upper in DrawSelection? +sub Curselection { + my $w = shift; + @{ $w->{'selection'} }; +} + +sub DrawSelection { + my $w = shift; + my $canvas = $w->Subwidget('canvas'); + $canvas->delete('selection'); + my $selBg = $w->cget('-selectbackground'); + for my $item (@{ $w->{'selection'} }) { + my $rTag = $w->{'list'}->[$item][2]; + my($iTag, $tTag, $text, $serial) = @{ $w->{'itemList'}{$rTag} }; + my @bbox = $canvas->bbox($tTag); + # XXX don't hardcode colors + $canvas->createRectangle + (@bbox, -fill => $selBg, -outline => $selBg, -tags => 'selection'); + } + $canvas->lower('selection'); +} + +# Returns the selected item +# +sub Get { + my($w, $item) = @_; + my $rTag = $w->{'list'}->[$item][2]; + my($iTag, $tTag, $text, $serial) = @{ $w->{'itemList'}{$rTag} }; + $text; +} + + +# tkIconList_AutoScan -- +# +# This procedure is invoked when the mouse leaves an entry window +# with button 1 down. It scrolls the window up, down, left, or +# right, depending on where the mouse left the window, and reschedules +# itself as an "after" command so that the window continues to scroll until +# the mouse moves back into the window or the mouse button is released. +# +# Arguments: +# w - The IconList window. +# +sub AutoScan { + my $w = shift; + return unless ($w->exists); + return if ($w->{'noScroll'}); + my($x, $y); + $x = $Tk::x; + $y = $Tk::y; + my $canvas = $w->Subwidget('canvas'); + if ($x >= $canvas->width) { + $canvas->xview('scroll', 1, 'units'); + } elsif ($x < 0) { + $canvas->xview('scroll', -1, 'units'); + } elsif ($y >= $canvas->height) { + # do nothing + } elsif ($y < 0) { + # do nothing + } else { + return; + } + $w->Motion1($x, $y); + $w->RepeatId($w->after(50, ['AutoScan', $w])); +} + +# Deletes all the items inside the canvas subwidget and reset the IconList's +# state. +# +sub DeleteAll { + my $w = shift; + my $canvas = $w->Subwidget('canvas'); + $canvas->delete('all'); + delete $w->{'selected'}; + delete $w->{'rect'}; + delete $w->{'list'}; + delete $w->{'itemList'}; + $w->{'maxIW'} = 1; + $w->{'maxIH'} = 1; + $w->{'maxTW'} = 1; + $w->{'maxTH'} = 1; + $w->{'numItems'} = 0; +#XXX curItem never used delete $w->{'curItem'}; + $w->{'noScroll'} = 1; + $w->{'selection'} = []; + $w->{'index,anchor'} = ''; + $w->Subwidget('sbar')->set(0.0, 1.0); + $canvas->xview('moveto', 0); +} + +# Adds an icon into the IconList with the designated image and items +# +sub Add { + my($w, $image, @items) = @_; + my $canvas = $w->Subwidget('canvas'); + my $font = $w->cget(-font); + my $fg = $w->cget(-foreground); + foreach my $text (@items) { + my $iTag = $canvas->createImage + (0, 0, -image => $image, -anchor => 'nw', + -tags => ['icon', $w->{numItems}, 'item'.$w->{numItems}], + ); + my $tTag = $canvas->createText + (0, 0, -text => $text, -anchor => 'nw', + (defined $fg ? (-fill => $fg) : ()), + (defined $font ? (-font => $font) : ()), + -tags => ['text', $w->{numItems}, 'item'.$w->{numItems}], + ); + my $rTag = $canvas->createRectangle + (0, 0, 0, 0, + -fill => undef, + -outline => undef, + -tags => ['rect', $w->{numItems}, 'item'.$w->{numItems}], + ); + my(@b) = $canvas->bbox($iTag); + my $iW = $b[2] - $b[0]; + my $iH = $b[3] - $b[1]; + $w->{'maxIW'} = $iW if ($w->{'maxIW'} < $iW); + $w->{'maxIH'} = $iH if ($w->{'maxIH'} < $iH); + @b = $canvas->bbox($tTag); + my $tW = $b[2] - $b[0]; + my $tH = $b[3] - $b[1]; + $w->{'maxTW'} = $tW if ($w->{'maxTW'} < $tW); + $w->{'maxTH'} = $tH if ($w->{'maxTH'} < $tH); + push @{ $w->{'list'} }, [$iTag, $tTag, $rTag, $iW, $iH, $tW, $tH, + $w->{'numItems'}]; + $w->{'itemList'}{$rTag} = [$iTag, $tTag, $text, $w->{'numItems'}]; + $w->{'textList'}{$w->{'numItems'}} = lc($text); + ++$w->{'numItems'}; + } +} + +# Places the icons in a column-major arrangement. +# +sub Arrange { + my $w = shift; + my $canvas = $w->Subwidget('canvas'); + my $sbar = $w->Subwidget('sbar'); + unless (exists $w->{'list'}) { + if (defined $canvas && Tk::Exists($canvas)) { + $w->{'noScroll'} = 1; + $sbar->configure(-command => sub { }); + } + return; + } + + my $W = $canvas->width; + my $H = $canvas->height; + my $pad = $canvas->cget(-highlightthickness) + $canvas->cget(-bd); + $pad = 2 if ($pad < 2); + $W -= $pad*2; + $H -= $pad*2; + my $dx = $w->{'maxIW'} + $w->{'maxTW'} + 8; + my $dy; + if ($w->{'maxTH'} > $w->{'maxIH'}) { + $dy = $w->{'maxTH'}; + } else { + $dy = $w->{'maxIH'}; + } + $dy += 2; + my $shift = $w->{'maxIW'} + 4; + my $x = $pad * 2; + my $y = $pad; + my $usedColumn = 0; + foreach my $sublist (@{ $w->{'list'} }) { + $usedColumn = 1; + my($iTag, $tTag, $rTag, $iW, $iH, $tW, $tH) = @$sublist; + my $i_dy = ($dy - $iH) / 2; + my $t_dy = ($dy - $tH) / 2; + $canvas->coords($iTag, $x, $y + $i_dy); + $canvas->coords($tTag, $x + $shift, $y + $t_dy); + $canvas->coords($rTag, $x, $y, $x + $dx, $y + $dy); + $y += $dy; + if ($y + $dy > $H) { + $y = $pad; + $x += $dx; + $usedColumn = 0; + } + } + my $sW; + if ($usedColumn) { + $sW = $x + $dx; + } else { + $sW = $x; + } + if ($sW < $W) { + $canvas->configure(-scrollregion => [$pad, $pad, $sW, $H]); + $sbar->configure(-command => sub { }); + $canvas->xview(moveto => 0); + $w->{'noScroll'} = 1; + } else { + $canvas->configure(-scrollregion => [$pad, $pad, $sW, $H]); + $sbar->configure(-command => ['xview', $canvas]); + $w->{'noScroll'} = 0; + } + $w->{'itemsPerColumn'} = int(($H - $pad) / $dy); + $w->{'itemsPerColumn'} = 1 if ($w->{'itemsPerColumn'} < 1); +#XXX $w->Select($w->{'list'}[$w->{'curItem'}][2], 0) +# if (exists $w->{'curItem'}); + $w->DrawSelection; # missing in Tcl XXX +} + +# Gets called when the user invokes the IconList (usually by double-clicking +# or pressing the Return key). +# +sub Invoke { + my $w = shift; + $w->Callback(-command => $w->{'selected'}) if (@{ $w->{'selection'} }); +} + +# tkIconList_See -- +# +# If the item is not (completely) visible, scroll the canvas so that +# it becomes visible. +sub See { + my($w, $rTag) = @_; + return if ($w->{'noScroll'}); + return if ($rTag < 0 || $rTag >= @{ $w->{'list'} }); + my $canvas = $w->Subwidget('canvas'); + my(@sRegion) = @{ $canvas->cget('-scrollregion') }; + return unless (@sRegion); + my(@bbox) = $canvas->bbox('item'.$rTag); + my $pad = $canvas->cget(-highlightthickness) + $canvas->cget(-bd); + my $x1 = $bbox[0]; + my $x2 = $bbox[2]; + $x1 -= $pad * 2; + $x2 -= $pad; + my $cW = $canvas->width - $pad * 2; + my $scrollW = $sRegion[2] - $sRegion[0] + 1; + my $dispX = int(($canvas->xview)[0] * $scrollW); + my $oldDispX = $dispX; + # check if out of the right edge + $dispX = $x2 - $cW if ($x2 - $dispX >= $cW); + # check if out of the left edge + $dispX = $x1 if ($x1 - $dispX < 0); + if ($oldDispX != $dispX) { + my $fraction = $dispX / $scrollW; + $canvas->xview('moveto', $fraction); + } +} + +sub Btn1 { + my($w, $x, $y) = @_; + + my $canvas = $w->Subwidget('canvas'); + $canvas->CanvasFocus; + $x = int($canvas->canvasx($x)); + $y = int($canvas->canvasy($y)); + my $i = $w->Index('@'.$x.','.$y); + return if ($i eq ''); + $w->Selection('clear', 0, 'end'); + $w->Selection('set', $i); + $w->Selection('anchor', $i); +} + +sub CtrlBtn1 { + my($w, $x, $y) = @_; + + if ($w->cget(-multiple)) { + my $canvas = $w->Subwidget('canvas'); + $canvas->CanvasFocus; + my $x = int($canvas->canvasx($x)); + my $y = int($canvas->canvasy($y)); + my $i = $w->Index('@'.$x.','.$y); + return if ($i eq ''); + if ($w->Selection('includes', $i)) { + $w->Selection('clear', $i); + } else { + $w->Selection('set', $i); + $w->Selection('anchor', $i); + } + } +} + +sub ShiftBtn1 { + my($w, $x, $y) = @_; + + if ($w->cget(-multiple)) { + my $canvas = $w->Subwidget('canvas'); + $canvas->CanvasFocus; + my $x = int($canvas->canvasx($x)); + my $y = int($canvas->canvasy($y)); + my $i = $w->Index('@'.$x.','.$y); + return if ($i eq ''); + my $a = $w->Index('anchor'); + if ($a eq '') { + $a = $i; + } + $w->Selection('clear', 0, 'end'); + $w->Selection('set', $a, $i); + } +} + +# Gets called on button-1 motions +# +sub Motion1 { + my($w, $x, $y) = @_; + $Tk::x = $x; + $Tk::y = $y; + my $canvas = $w->Subwidget('canvas'); + $canvas->CanvasFocus; + $x = int($canvas->canvasx($x)); + $y = int($canvas->canvasy($y)); + my $i = $w->Index('@'.$x.','.$y); + return if ($i eq ''); + $w->Selection('clear', 0, 'end'); + $w->Selection('set', $i); +} + +sub Double1 { + my($w, $x, $y) = @_; + $w->Invoke if (@{ $w->{'selection'} }); +} + +sub ReturnKey { + my $w = shift; + $w->Invoke; +} + +sub Leave1 { + my($w, $x, $y) = @_; + $Tk::x = $x; + $Tk::y = $y; + $w->AutoScan; +} + +sub FocusIn { + my $w = shift; + return unless (exists $w->{'list'}); + if (@{ $w->{'selection'} }) { + $w->DrawSelection; + } +} + +sub FocusOut { + my $w = shift; + $w->Selection('clear', 0, 'end'); +} + +# tkIconList_UpDown -- +# +# Moves the active element up or down by one element +# +# Arguments: +# w - The IconList widget. +# amount - +1 to move down one item, -1 to move back one item. +# +sub UpDown { + my($w, $amount) = @_; + return unless (exists $w->{'list'}); + my $i; + my(@curr) = $w->Curselection; + if (!@curr) { + $i = 0; + } else { + $i = $w->Index('anchor'); + return if ($i eq ''); + $i += $amount; + } + $w->Selection('clear', 0, 'end'); + $w->Selection('set', $i); + $w->Selection('anchor', $i); + $w->See($i); +} + +# tkIconList_LeftRight -- +# +# Moves the active element left or right by one column +# +# Arguments: +# w - The IconList widget. +# amount - +1 to move right one column, -1 to move left one column. +# +sub LeftRight { + my($w, $amount) = @_; + return unless (exists $w->{'list'}); + my $i; + my(@curr) = $w->Curselection; + if (!@curr) { + $i = 0; + } else { + $i = $w->Index('anchor'); + return if ($i eq ''); + $i += $amount*$w->{'itemsPerColumn'}; + } + $w->Selection('clear', 0, 'end'); + $w->Selection('set', $i); + $w->Selection('anchor', $i); + $w->See($i); +} + +#---------------------------------------------------------------------- +# Accelerator key bindings +#---------------------------------------------------------------------- +# tkIconList_KeyPress -- +# +# Gets called when user enters an arbitrary key in the listbox. +# +sub KeyPress { + my($w, $key) = @_; + $w->{'_ILAccel'} .= $key; + $w->Goto($w->{'_ILAccel'}); + eval { + $w->afterCancel($w->{'_ILAccel_afterid'}); + }; + $w->{'_ILAccel_afterid'} = $w->after(500, ['Reset', $w]); +} + +sub Goto { + my($w, $text) = @_; + return unless (exists $w->{'list'}); + return if (not defined $text or $text eq ''); +#XXX curItem never used my $start = (!exists $w->{'curItem'} ? 0 : $w->{'curItem'}); + my $start = 0; + $text = lc($text); + my $theIndex = -1; + my $less = 0; + my $len = length($text); + my $i = $start; + # Search forward until we find a filename whose prefix is an exact match + # with $text + while (1) { + my $sub = substr($w->{'textList'}{$i}, 0, $len); + if ($text eq $sub) { + $theIndex = $i; + last; + } + ++$i; + $i = 0 if ($i == $w->{'numItems'}); + last if ($i == $start); + } + if ($theIndex > -1) { + $w->Selection(qw(clear 0 end)); + $w->Selection('set', $theIndex); + $w->Selection('anchor', $theIndex); + $w->See($theIndex); + } +} + +sub Reset { + my $w = shift; + undef $w->{'_ILAccel'}; +} + +1; diff --git a/Master/tlpkg/tlperl/lib/Tk/Image.pm b/Master/tlpkg/tlperl/lib/Tk/Image.pm new file mode 100644 index 00000000000..0f41c387fc2 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Image.pm @@ -0,0 +1,74 @@ +# Copyright (c) 1995-2003 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. +package Tk::Image; + +# This module does for images what Tk::Widget does for widgets: +# provides a base class for them to inherit from. +require DynaLoader; + +use base qw(DynaLoader Tk); # but are they ? + +use vars qw($VERSION); +$VERSION = '4.011'; # $Id: //depot/Tkutf8/Tk/Image.pm#11 $ + +sub new +{ + my $package = shift; + my $widget = shift; + $package->InitClass($widget); + my $leaf = $package->Tk_image; + my $obj = $widget->Tk::image('create',$leaf,@_); + $obj = $widget->_object($obj) unless (ref $obj); + return bless $obj,$package; +} + +sub Install +{ + # Dynamically loaded image types can install standard images here + my ($class,$mw) = @_; +} + +sub ClassInit +{ + # Carry out class bindings (or whatever) + my ($package,$mw) = @_; + return $package; +} + +require Tk::Submethods; + +Direct Tk::Submethods ('image' => [qw(delete width height type)]); + +sub Tk::Widget::imageNames +{ + my $w = shift; + $w->image('names',@_); +} + +sub Tk::Widget::imageTypes +{ + my $w = shift; + map("\u$_",$w->image('types',@_)); +} + +sub Construct +{ + my ($base,$name) = @_; + my $class = (caller(0))[0]; + + # Hack for broken ->isa in perl5.6.0 + delete ${"$class\::"}{'::ISA::CACHE::'} if $] == 5.006; + + *{"Tk::Widget::$name"} = sub { $class->new(@_) }; +} + +# This is here to prevent AUTOLOAD trying to find it. +sub DESTROY +{ + my $i = shift; + # maybe do image delete ??? +} + + +1; diff --git a/Master/tlpkg/tlperl/lib/Tk/ItemStyle.pm b/Master/tlpkg/tlperl/lib/Tk/ItemStyle.pm new file mode 100644 index 00000000000..85c6c11a76c --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/ItemStyle.pm @@ -0,0 +1,38 @@ +package Tk::ItemStyle; + +use vars qw($VERSION); +$VERSION = '4.004'; # $Id: //depot/Tkutf8/Tk/ItemStyle.pm#4 $ + +require Tk; +use base qw(Tk); +require Tk::Widget; +Construct Tk::Widget 'ItemStyle'; + +Tk::Methods ('delete'); + +sub new +{ + my $package = shift; + my $widget = shift; + my $type = shift; + my %args = @_; + $args{'-refwindow'} = $widget unless exists $args{'-refwindow'}; + $package->InitClass($widget); + my $obj = $widget->itemstyle($type, %args); + return bless $obj,$package; +} + +sub Install +{ + # Dynamically loaded image types can install standard images here + my ($class,$mw) = @_; +} + +sub ClassInit +{ + # Carry out class bindings (or whatever) + my ($package,$mw) = @_; + return $package; +} + +1; diff --git a/Master/tlpkg/tlperl/lib/Tk/JPEG.pm b/Master/tlpkg/tlperl/lib/Tk/JPEG.pm new file mode 100644 index 00000000000..9e0ef771f77 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/JPEG.pm @@ -0,0 +1,50 @@ +package Tk::JPEG; +require DynaLoader; + +use vars qw($VERSION); +$VERSION = sprintf '4.%03d', q$Revision: #2$ =~ /\D(\d+)\s*$/; +use Tk 800.015; +require Tk::Image; +require Tk::Photo; +require DynaLoader; + +use vars qw($VERSION $XS_VERSION); + +@ISA = qw(DynaLoader); + +$XS_VERSION = $Tk::VERSION; +bootstrap Tk::JPEG; + +1; + +__END__ + +=head1 NAME + +Tk::JPEG - JPEG loader for Tk::Photo + +=head1 SYNOPSIS + + use Tk; + use Tk::JPEG; + + my $image = $widget->Photo('-format' => 'jpeg', -file => 'something.jpg'); + + +=head1 DESCRIPTION + +This is an extension for Tk800.015 and later which supplies +JPEG format loader for Photo image type. + +This version also works with Tk804 series. + +JPEG access is via release 5 of the The Independent JPEG Group's (IJG) +free JPEG software. + +=head1 AUTHOR + +Nick Ing-Simmons E<lt>nick@ing-simmons.netE<gt> + +=cut + + diff --git a/Master/tlpkg/tlperl/lib/Tk/LabEntry.pm b/Master/tlpkg/tlperl/lib/Tk/LabEntry.pm new file mode 100644 index 00000000000..64cb392fa8c --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/LabEntry.pm @@ -0,0 +1,31 @@ +# Copyright (c) 1995-2003 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. + +package Tk::LabEntry; + +use vars qw($VERSION); +$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/LabEntry.pm#6 $ + +use base qw(Tk::Frame); +use Tk::widgets qw(Frame Label Entry); + +Construct Tk::Widget 'LabEntry'; + +sub Populate +{ + require Tk::Entry; + # LabeledEntry constructor. + # + my($cw, $args) = @_; + $cw->SUPER::Populate($args); + # Advertised subwidgets: entry. + my $e = $cw->Entry(); + $e->pack('-expand' => 1, '-fill' => 'both'); + $cw->Advertise('entry' => $e ); + $cw->ConfigSpecs(DEFAULT => [$e]); + $cw->Delegates(DEFAULT => $e); + $cw->AddScrollbars($e) if (exists $args->{-scrollbars}); +} + +1; diff --git a/Master/tlpkg/tlperl/lib/Tk/LabFrame.pm b/Master/tlpkg/tlperl/lib/Tk/LabFrame.pm new file mode 100644 index 00000000000..6fcab1acc56 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/LabFrame.pm @@ -0,0 +1,138 @@ +# +# Labeled frame. Derives from Tk::Frame, but intercepts the labeling +# part. + +package Tk::LabFrame; + +use vars qw($VERSION); +$VERSION = '4.010'; # $Id: //depot/Tkutf8/Tixish/LabFrame.pm#11 $ + +use Tk; +use base qw(Tk::Frame); +Tk::Widget->Construct('LabFrame'); + +sub autoLabel { 0 } + +sub Populate { + my ($cw, $args) = @_; + + $cw->{m_geoMgr} = ""; + + my $border = $cw->Component( + Frame => 'border', + -relief => 'groove', + -bd => 2, + ); + + my $pad = $border->Frame; + $cw->Advertise(pad => $pad); + + my $frame = $border->Frame; + $cw->Advertise(frame => $frame); + + my $label = $cw->Component(Label => 'label'); + + $cw->SUPER::Populate($args); + + $cw->Delegates(DEFAULT => $frame); + $cw->ConfigSpecs( + -background => [[qw/SELF ADVERTISED/], + qw/background Background/], + -borderwidth => [$border, qw/borderWidth Border 2/], + -font => [$label, qw/font Font/], + -foreground => [$label, qw/foreground Foreground black/], + -label => [{-text => $label}, qw/label Label/], + -labelside => [qw/METHOD labelSide LabelSide acrosstop/], + -labelvariable => [{-textvariable => $label}], + -relief => [$border, qw/relief Relief groove/], + DEFAULT => [$frame] + ); + return $cw; +} + +use Tk::Submethods( + form => [qw/check forget grid info slaves/], + grid => [qw/bbox columnconfigure configure forget info location + propagate rowconfigure remove size slaves/], + pack => [qw/forget info propagate slaves/], + place => [qw/forget info slaves/] +); + +sub labelside { + my ($cw, $side) = @_; + return $cw->{Configure}{-labelside} unless $side; + + my $border = $cw->Subwidget('border'); + my $pad = $cw->Subwidget('pad'); + my $frame = $cw->Subwidget('frame'); + my $label = $cw->Subwidget('label'); + + ## packForget/formForget as appropriate + foreach ($border, $label, $pad, $frame) { + $_->formForget if $cw->{m_geoMgr} eq "form"; + $_->packForget if ($cw->{m_geoMgr} eq "pack" && $_->ismapped); + } + + if ($side eq "acrosstop") { + + my $y = $label->reqheight / 2; + my $ph = $y - ($border->cget(-bd)); + $ph = 0 if $ph < 0; + + $label->form(qw/-top 0 -left 4 -padx 6 -pady 2/); + $border->form(-top => $y, + qw/-bottom -1 -left 0 -right -1 -padx 2 -pady 2/); + $pad->form(-bottom => $ph, + qw/-top 0 -left 0 -right -1/); + $frame->form(-top => $pad, + qw/-bottom -1 -left 0 -right -1 -fill both/); + $cw->{m_geoMgr} = "form"; + + } else { + + $label->pack(-side => $side); + $frame->pack(-expand => 1, -fill => 'both'); + $border->pack(-side => $side, -expand => 1, -fill => 'both'); + $cw->{m_geoMgr} = "pack"; + } +} + +sub form { + my $cw = shift; + $cw = $cw->Subwidget('frame') + if (@_ && $_[0] =~ /^(?:slaves)$/); + $cw->SUPER::form(@_); +} + +sub grid { + my $cw = shift; + $cw = $cw->Subwidget('frame') if (@_ && $_[0] =~ + /^(?:bbox + |columnconfigure + |location + |propagate + |rowconfigure + |size + |slaves) + $/x); + $cw->SUPER::grid(@_); +} + + +sub pack { + my $cw = shift; + $cw = $cw->Subwidget('frame') + if (@_ && $_[0] =~ /^(?:propagate|slaves)$/); + $cw->SUPER::pack(@_); +} + +sub place { + my $cw = shift; + $cw = $cw->Subwidget('frame') + if (@_ && $_[0] =~ /^(?:slaves)$/); + $cw->SUPER::place(@_); +} + +1; + + diff --git a/Master/tlpkg/tlperl/lib/Tk/LabRadio.pm b/Master/tlpkg/tlperl/lib/Tk/LabRadio.pm new file mode 100644 index 00000000000..69e07b12f01 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/LabRadio.pm @@ -0,0 +1,63 @@ +# Class LabeledRadiobutton + +package Tk::LabRadiobutton; + +use vars qw($VERSION); +$VERSION = '4.004'; # $Id: //depot/Tkutf8/Tk/LabRadio.pm#4 $ + +require Tk::Frame; +use base qw(Tk::Frame); + +Construct Tk::Widget 'LabRadiobutton'; + + +# Although there is no fundamental reason why -radiobuttons +# should be fixed at create time converting to METHOD form +# is extra work an this can serve as an example of CreateArgs +# checking. + +sub CreateArgs +{ + my ($package,$parent,$args) = @_; + $parent->BackTrace("Must specify -radiobuttons for $package") + unless (defined $args->{'-radiobuttons'}); + return $package->SUPER::CreateArgs($parent,$args); +} + +sub Populate +{ + require Tk::Radiobutton; + + my ($cw,$args) = @_; + $cw->SUPER::Populate($args); + + # LabeledRadiobutton(s) constructor. + # + # Advertised subwidgets: the name(s) of your radiobutton(s). + + + + my (@widgets) = (); + + my $rl; + foreach $rl (@{$args->{'-radiobuttons'}}) + { + my $r = $cw->Component( Radiobutton => $rl, + -text => $rl, + -value => $rl ); + $r->pack(-side => 'left', -expand => 1, -fill => 'both'); + push(@widgets,$r); + $cw->{Configure}{-value} = $rl; + } + + $cw->BackTrace('No buttons') unless (@widgets); + + $cw->ConfigSpecs('-variable' => [ \@widgets, undef, undef, \$cw->{Configure}{-value} ], + '-radiobuttons' => [ 'PASSIVE', undef, undef, undef ], + '-value' => [ 'PASSIVE', undef, undef, $cw->{Configure}{-value} ], + 'DEFAULT' => [ \@widgets ] + ); +} + + +1; diff --git a/Master/tlpkg/tlperl/lib/Tk/Label.pm b/Master/tlpkg/tlperl/lib/Tk/Label.pm new file mode 100644 index 00000000000..ebea1741c2f --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Label.pm @@ -0,0 +1,21 @@ +# Copyright (c) 1995-2003 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. + +package Tk::Label; +require Tk; + + +use vars qw($VERSION); +$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Label.pm#6 $ + +use base qw(Tk::Widget); + +Construct Tk::Widget 'Label'; + +sub Tk_cmd { \&Tk::label } + +1; + + + diff --git a/Master/tlpkg/tlperl/lib/Tk/Labelframe.pm b/Master/tlpkg/tlperl/lib/Tk/Labelframe.pm new file mode 100644 index 00000000000..14c577b5e35 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Labelframe.pm @@ -0,0 +1,16 @@ +package Tk::Labelframe; +use strict; + +use vars qw($VERSION); +$VERSION = sprintf '4.%03d', q$Revision: #2 $ =~ /#(\d+)/; + +# New widget which is a kind of Frame with a label ... + +use base qw(Tk::Frame); + +Construct Tk::Widget 'Labelframe'; + +sub Tk_cmd { \&Tk::labelframe } + +1; +__END__ diff --git a/Master/tlpkg/tlperl/lib/Tk/Listbox.pm b/Master/tlpkg/tlperl/lib/Tk/Listbox.pm new file mode 100644 index 00000000000..249a8eed7f4 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Listbox.pm @@ -0,0 +1,910 @@ +# Converted from listbox.tcl -- +# +# This file defines the default bindings for Tk listbox widgets. +# +# @(#) listbox.tcl 1.7 94/12/17 16:05:18 +# +# Copyright (c) 1994 The Regents of the University of California. +# 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. + +# Modifications from standard Listbox.pm +# -------------------------------------- +# 27-JAN-2001 Alasdair Allan +# Modified for local use by adding tied scalar and arrays +# Implemented TIESCALAR, TIEARRAY, FETCH, FETCHSIZE, STORE, CLEAR & EXTEND +# 31-JAN-2001 Alasdair Allan +# Made changes suggested by Tim Jenness +# 03-FEB-2001 Alasdair Allan +# Modified STORE for tied scalars to clear and select elements +# 06-FEB-2001 Alasdair Allan +# Added POD documentation for tied listbox +# 13-FEB-2001 Alasdair Allan +# Implemented EXISTS, DELETE, PUSH, POP, SHIFT & UNSHIFT for tied arrays +# 14-FEB-2001 Alasdair Allan +# Implemented SPLICE for tied arrays, all tied functionality in place +# 16-FEB-2001 Alasdair Allan +# Tweak to STORE interface for tied scalars +# 23-FEB-2001 Alasdair Allan +# Added flag to FETCH for tied scalars, modified to return hashes +# 24-FEB-2001 Alasdair Allan +# Updated Pod documentation +# + +package Tk::Listbox; + +use vars qw($VERSION @Selection $Prev); +use strict; +$VERSION = sprintf '4.%03d', q$Revision: #14 $ =~ /\D(\d+)\s*$/; + +use Tk qw(Ev $XS_VERSION); +use Tk::Clipboard (); +use AutoLoader; + +use base qw(Tk::Clipboard Tk::Widget); + +Construct Tk::Widget 'Listbox'; + +bootstrap Tk::Listbox; + +sub Tk_cmd { \&Tk::listbox } + +Tk::Methods('activate','bbox','curselection','delete','get','index', + 'insert','itemcget','itemconfigure','nearest','scan','see', + 'selection','size','xview','yview'); + +use Tk::Submethods ( 'selection' => [qw(anchor clear includes set)], + 'scan' => [qw(mark dragto)], + 'xview' => [qw(moveto scroll)], + 'yview' => [qw(moveto scroll)], + ); + +*Getselected = \&getSelected; + +sub clipEvents +{ + return qw[Copy]; +} + +sub BalloonInfo +{ + my ($listbox,$balloon,$X,$Y,@opt) = @_; + my $e = $listbox->XEvent; + return if !$e; + my $index = $listbox->index('@' . $e->x . ',' . $e->y); + foreach my $opt (@opt) + { + my $info = $balloon->GetOption($opt,$listbox); + if ($opt =~ /^-(statusmsg|balloonmsg)$/ && UNIVERSAL::isa($info,'ARRAY')) + { + $balloon->Subclient($index); + if (defined $info->[$index]) + { + return $info->[$index]; + } + return ''; + } + return $info; + } +} + +sub ClassInit +{ + my ($class,$mw) = @_; + $class->SUPER::ClassInit($mw); + # Standard Motif bindings: + $mw->bind($class,'<1>',[sub { + my $w = shift; + if (Tk::Exists($w)) { + $w->BeginSelect(@_); + } + }, Ev('index',Ev('@'))]); + $mw->bind($class, '<Double-1>' => \&Tk::NoOp); + $mw->bind($class,'<B1-Motion>',['Motion',Ev('index',Ev('@'))]); + $mw->bind($class,'<ButtonRelease-1>','ButtonRelease_1'); + ; + $mw->bind($class,'<Shift-1>',['BeginExtend',Ev('index',Ev('@'))]); + $mw->bind($class,'<Control-1>',['BeginToggle',Ev('index',Ev('@'))]); + + $mw->bind($class,'<B1-Leave>',['AutoScan',Ev('x'),Ev('y')]); + $mw->bind($class,'<B1-Enter>','CancelRepeat'); + $mw->bind($class,'<Up>',['UpDown',-1]); + $mw->bind($class,'<Shift-Up>',['ExtendUpDown',-1]); + $mw->bind($class,'<Down>',['UpDown',1]); + $mw->bind($class,'<Shift-Down>',['ExtendUpDown',1]); + + $mw->XscrollBind($class); + $mw->bind($class,'<Prior>', sub { + my $w = shift; + $w->yview('scroll',-1,'pages'); + $w->activate('@0,0'); + }); + $mw->bind($class,'<Next>', sub { + my $w = shift; + $w->yview('scroll',1,'pages'); + $w->activate('@0,0'); + }); + $mw->bind($class,'<Control-Prior>', ['xview', 'scroll', -1, 'pages']); + $mw->bind($class,'<Control-Next>', ['xview', 'scroll', 1, 'pages']); + # <Home> and <End> defined in XscrollBind + $mw->bind($class,'<Control-Home>','Cntrl_Home'); + ; + $mw->bind($class,'<Shift-Control-Home>',['DataExtend',0]); + $mw->bind($class,'<Control-End>','Cntrl_End'); + ; + $mw->bind($class,'<Shift-Control-End>',['DataExtend','end']); + # XXX What about <<Copy>>? Already handled in Tk::Clipboard? + # $class->clipboardOperations($mw,'Copy'); + $mw->bind($class,'<space>',['BeginSelect',Ev('index','active')]); + $mw->bind($class,'<Select>',['BeginSelect',Ev('index','active')]); + $mw->bind($class,'<Control-Shift-space>',['BeginExtend',Ev('index','active')]); + $mw->bind($class,'<Shift-Select>',['BeginExtend',Ev('index','active')]); + $mw->bind($class,'<Escape>','Cancel'); + $mw->bind($class,'<Control-slash>','SelectAll'); + $mw->bind($class,'<Control-backslash>','Cntrl_backslash'); + ; + # Additional Tk bindings that aren't part of the Motif look and feel: + $mw->bind($class,'<2>',['scan','mark',Ev('x'),Ev('y')]); + $mw->bind($class,'<B2-Motion>',['scan','dragto',Ev('x'),Ev('y')]); + + $mw->MouseWheelBind($class); # XXX Both needed? + $mw->YMouseWheelBind($class); + return $class; +} + +1; +__END__ + +sub TIEARRAY { + my ( $class, $obj, %options ) = @_; + return bless { + OBJECT => \$obj, + OPTION => \%options }, $class; +} + + + +sub TIESCALAR { + my ( $class, $obj, %options ) = @_; + return bless { + OBJECT => \$obj, + OPTION => \%options }, $class; +} + +# FETCH +# ----- +# Return either the full contents or only the selected items in the +# box depending on whether we tied it to an array or scalar respectively +sub FETCH { + my $class = shift; + + my $self = ${$class->{OBJECT}}; + my %options = %{$class->{OPTION}} if defined $class->{OPTION};; + + # Define the return variable + my $result; + + # Check whether we are have a tied array or scalar quantity + if ( @_ ) { + my $i = shift; + # The Tk:: Listbox has been tied to an array, we are returning + # an array list of the current items in the Listbox + $result = $self->get($i); + } else { + # The Tk::Listbox has been tied to a scalar, we are returning a + # reference to an array or hash containing the currently selected items + my ( @array, %hash ); + + if ( defined $options{ReturnType} ) { + + # THREE-WAY SWITCH + if ( $options{ReturnType} eq "index" ) { + $result = [$self->curselection]; + } elsif ( $options{ReturnType} eq "element" ) { + foreach my $selection ( $self->curselection ) { + push(@array,$self->get($selection)); } + $result = \@array; + } elsif ( $options{ReturnType} eq "both" ) { + foreach my $selection ( $self->curselection ) { + %hash = ( %hash, $selection => $self->get($selection)); } + $result = \%hash; + } + } else { + # return elements (default) + foreach my $selection ( $self->curselection ) { + push(@array,$self->get($selection)); } + $result = \@array; + } + } + return $result; +} + +# FETCHSIZE +# --------- +# Return the number of elements in the Listbox when tied to an array +sub FETCHSIZE { + my $class = shift; + return ${$class->{OBJECT}}->size(); +} + +# STORE +# ----- +# If tied to an array we will modify the Listbox contents, while if tied +# to a scalar we will select and clear elements. +sub STORE { + + if ( scalar(@_) == 2 ) { + # we have a tied scalar + my ( $class, $selected ) = @_; + my $self = ${$class->{OBJECT}}; + my %options = %{$class->{OPTION}} if defined $class->{OPTION};; + + # clear currently selected elements + $self->selectionClear(0,'end'); + + # set selected elements + if ( defined $options{ReturnType} ) { + + # THREE-WAY SWITCH + if ( $options{ReturnType} eq "index" ) { + for ( my $i=0; $i < scalar(@$selected) ; $i++ ) { + for ( my $j=0; $j < $self->size() ; $j++ ) { + if( $j == $$selected[$i] ) { + $self->selectionSet($j); last; } + } + } + } elsif ( $options{ReturnType} eq "element" ) { + for ( my $k=0; $k < scalar(@$selected) ; $k++ ) { + for ( my $l=0; $l < $self->size() ; $l++ ) { + if( $self->get($l) eq $$selected[$k] ) { + $self->selectionSet($l); last; } + } + } + } elsif ( $options{ReturnType} eq "both" ) { + foreach my $key ( keys %$selected ) { + $self->selectionSet($key) + if $$selected{$key} eq $self->get($key); + } + } + } else { + # return elements (default) + for ( my $k=0; $k < scalar(@$selected) ; $k++ ) { + for ( my $l=0; $l < $self->size() ; $l++ ) { + if( $self->get($l) eq $$selected[$k] ) { + $self->selectionSet($l); last; } + } + } + } + + } else { + # we have a tied array + my ( $class, $index, $value ) = @_; + my $self = ${$class->{OBJECT}}; + + # check size of current contents list + my $sizeof = $self->size(); + + if ( $index <= $sizeof ) { + # Change a current listbox entry + $self->delete($index); + $self->insert($index, $value); + } else { + # Add a new value + if ( defined $index ) { + $self->insert($index, $value); + } else { + $self->insert("end", $value); + } + } + } +} + +# CLEAR +# ----- +# Empty the Listbox of contents if tied to an array +sub CLEAR { + my $class = shift; + ${$class->{OBJECT}}->delete(0, 'end'); +} + +# EXTEND +# ------ +# Do nothing and be happy about it +sub EXTEND { } + +# PUSH +# ---- +# Append elements onto the Listbox contents +sub PUSH { + my ( $class, @list ) = @_; + ${$class->{OBJECT}}->insert('end', @list); +} + +# POP +# --- +# Remove last element of the array and return it +sub POP { + my $class = shift; + + my $value = ${$class->{OBJECT}}->get('end'); + ${$class->{OBJECT}}->delete('end'); + return $value; +} + +# SHIFT +# ----- +# Removes the first element and returns it +sub SHIFT { + my $class = shift; + + my $value = ${$class->{OBJECT}}->get(0); + ${$class->{OBJECT}}->delete(0); + return $value +} + +# UNSHIFT +# ------- +# Insert elements at the beginning of the Listbox +sub UNSHIFT { + my ( $class, @list ) = @_; + ${$class->{OBJECT}}->insert(0, @list); +} + +# DELETE +# ------ +# Delete element at specified index +sub DELETE { + my ( $class, @list ) = @_; + + my $value = ${$class->{OBJECT}}->get(@list); + ${$class->{OBJECT}}->delete(@list); + return $value; +} + +# EXISTS +# ------ +# Returns true if the index exist, and undef if not +sub EXISTS { + my ( $class, $index ) = @_; + return undef unless ${$class->{OBJECT}}->get($index); +} + +# SPLICE +# ------ +# Performs equivalent of splice on the listbox contents +sub SPLICE { + my $class = shift; + + my $self = ${$class->{OBJECT}}; + + # check for arguments + my @elements; + if ( scalar(@_) == 0 ) { + # none + @elements = $self->get(0,'end'); + $self->delete(0,'end'); + return wantarray ? @elements : $elements[scalar(@elements)-1];; + + } elsif ( scalar(@_) == 1 ) { + # $offset + my ( $offset ) = @_; + if ( $offset < 0 ) { + my $start = $self->size() + $offset; + if ( $start > 0 ) { + @elements = $self->get($start,'end'); + $self->delete($start,'end'); + return wantarray ? @elements : $elements[scalar(@elements)-1]; + } else { + return undef; + } + } else { + @elements = $self->get($offset,'end'); + $self->delete($offset,'end'); + return wantarray ? @elements : $elements[scalar(@elements)-1]; + } + + } elsif ( scalar(@_) == 2 ) { + # $offset and $length + my ( $offset, $length ) = @_; + if ( $offset < 0 ) { + my $start = $self->size() + $offset; + my $end = $self->size() + $offset + $length - 1; + if ( $start > 0 ) { + @elements = $self->get($start,$end); + $self->delete($start,$end); + return wantarray ? @elements : $elements[scalar(@elements)-1]; + } else { + return undef; + } + } else { + @elements = $self->get($offset,$offset+$length-1); + $self->delete($offset,$offset+$length-1); + return wantarray ? @elements : $elements[scalar(@elements)-1]; + } + + } else { + # $offset, $length and @list + my ( $offset, $length, @list ) = @_; + if ( $offset < 0 ) { + my $start = $self->size() + $offset; + my $end = $self->size() + $offset + $length - 1; + if ( $start > 0 ) { + @elements = $self->get($start,$end); + $self->delete($start,$end); + $self->insert($start,@list); + return wantarray ? @elements : $elements[scalar(@elements)-1]; + } else { + return undef; + } + } else { + @elements = $self->get($offset,$offset+$length-1); + $self->delete($offset,$offset+$length-1); + $self->insert($offset,@list); + return wantarray ? @elements : $elements[scalar(@elements)-1]; + } + } +} + +# ---- + +# +# Bind -- +# This procedure is invoked the first time the mouse enters a listbox +# widget or a listbox widget receives the input focus. It creates +# all of the class bindings for listboxes. +# +# Arguments: +# event - Indicates which event caused the procedure to be invoked +# (Enter or FocusIn). It is used so that we can carry out +# the functions of that event in addition to setting up +# bindings. + +sub xyIndex +{ + my $w = shift; + my $Ev = $w->XEvent; + return $w->index($Ev->xy); +} + +sub ButtonRelease_1 +{ + my $w = shift; + my $Ev = $w->XEvent; + $w->CancelRepeat; + $w->activate($Ev->xy); +} + + +sub Cntrl_Home +{ + my $w = shift; + my $Ev = $w->XEvent; + $w->activate(0); + $w->see(0); + $w->selectionClear(0,'end'); + $w->selectionSet(0); + $w->eventGenerate("<<ListboxSelect>>"); +} + + +sub Cntrl_End +{ + my $w = shift; + my $Ev = $w->XEvent; + $w->activate('end'); + $w->see('end'); + $w->selectionClear(0,'end'); + $w->selectionSet('end'); + $w->eventGenerate("<<ListboxSelect>>"); +} + + +sub Cntrl_backslash +{ + my $w = shift; + my $Ev = $w->XEvent; + if ($w->cget('-selectmode') ne 'browse') + { + $w->selectionClear(0,'end'); + $w->eventGenerate("<<ListboxSelect>>"); + } +} + +# BeginSelect -- +# +# This procedure is typically invoked on button-1 presses. It begins +# the process of making a selection in the listbox. Its exact behavior +# depends on the selection mode currently in effect for the listbox; +# see the Motif documentation for details. +# +# Arguments: +# w - The listbox widget. +# el - The element for the selection operation (typically the +# one under the pointer). Must be in numerical form. +sub BeginSelect +{ + my $w = shift; + my $el = shift; + if ($w->cget('-selectmode') eq 'multiple') + { + if ($w->selectionIncludes($el)) + { + $w->selectionClear($el) + } + else + { + $w->selectionSet($el) + } + } + else + { + $w->selectionClear(0,'end'); + $w->selectionSet($el); + $w->selectionAnchor($el); + @Selection = (); + $Prev = $el + } + $w->focus if ($w->cget('-takefocus')); + $w->eventGenerate("<<ListboxSelect>>"); +} +# Motion -- +# +# This procedure is called to process mouse motion events while +# button 1 is down. It may move or extend the selection, depending +# on the listbox's selection mode. +# +# Arguments: +# w - The listbox widget. +# el - The element under the pointer (must be a number). +sub Motion +{ + my $w = shift; + my $el = shift; + if (defined($Prev) && $el == $Prev) + { + return; + } + my $anchor = $w->index('anchor'); + my $mode = $w->cget('-selectmode'); + if ($mode eq 'browse') + { + $w->selectionClear(0,'end'); + $w->selectionSet($el); + $Prev = $el; + $w->eventGenerate("<<ListboxSelect>>"); + } + elsif ($mode eq 'extended') + { + my $i = $Prev; + if (!defined $i || $i eq '') + { + $i = $el; + $w->selectionSet($el); + } + if ($w->selectionIncludes('anchor')) + { + $w->selectionClear($i,$el); + $w->selectionSet('anchor',$el) + } + else + { + $w->selectionClear($i,$el); + $w->selectionClear('anchor',$el) + } + if (!@Selection) + { + @Selection = $w->curselection; + } + while ($i < $el && $i < $anchor) + { + if (Tk::lsearch(\@Selection,$i) >= 0) + { + $w->selectionSet($i) + } + $i++ + } + while ($i > $el && $i > $anchor) + { + if (Tk::lsearch(\@Selection,$i) >= 0) + { + $w->selectionSet($i) + } + $i-- + } + $Prev = $el; + $w->eventGenerate("<<ListboxSelect>>"); + } +} +# BeginExtend -- +# +# This procedure is typically invoked on shift-button-1 presses. It +# begins the process of extending a selection in the listbox. Its +# exact behavior depends on the selection mode currently in effect +# for the listbox; see the Motif documentation for details. +# +# Arguments: +# w - The listbox widget. +# el - The element for the selection operation (typically the +# one under the pointer). Must be in numerical form. +sub BeginExtend +{ + my $w = shift; + my $el = shift; + if ($w->cget('-selectmode') eq 'extended' && $w->selectionIncludes('anchor')) + { + $w->Motion($el) + } + else + { + # No selection yet; simulate the begin-select operation. + $w->BeginSelect($el); + } +} +# BeginToggle -- +# +# This procedure is typically invoked on control-button-1 presses. It +# begins the process of toggling a selection in the listbox. Its +# exact behavior depends on the selection mode currently in effect +# for the listbox; see the Motif documentation for details. +# +# Arguments: +# w - The listbox widget. +# el - The element for the selection operation (typically the +# one under the pointer). Must be in numerical form. +sub BeginToggle +{ + my $w = shift; + my $el = shift; + if ($w->cget('-selectmode') eq 'extended') + { + @Selection = $w->curselection(); + $Prev = $el; + $w->selectionAnchor($el); + if ($w->selectionIncludes($el)) + { + $w->selectionClear($el) + } + else + { + $w->selectionSet($el) + } + $w->eventGenerate("<<ListboxSelect>>"); + } +} +# AutoScan -- +# This procedure is invoked when the mouse leaves an entry window +# with button 1 down. It scrolls the window up, down, left, or +# right, depending on where the mouse left the window, and reschedules +# itself as an "after" command so that the window continues to scroll until +# the mouse moves back into the window or the mouse button is released. +# +# Arguments: +# w - The entry window. +# x - The x-coordinate of the mouse when it left the window. +# y - The y-coordinate of the mouse when it left the window. +sub AutoScan +{ + my $w = shift; + return if !Tk::Exists($w); + my $x = shift; + my $y = shift; + 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->Motion($w->index("@" . $x . ',' . $y)); + $w->RepeatId($w->after(50,'AutoScan',$w,$x,$y)); +} +# UpDown -- +# +# Moves the location cursor (active element) up or down by one element, +# and changes the selection if we're in browse or extended selection +# mode. +# +# Arguments: +# w - The listbox widget. +# amount - +1 to move down one item, -1 to move back one item. +sub UpDown +{ + my $w = shift; + my $amount = shift; + $w->activate($w->index('active')+$amount); + $w->see('active'); + my $mode = $w->cget('-selectmode'); + if ($mode eq 'browse') + { + $w->selectionClear(0,'end'); + $w->selectionSet('active'); + $w->eventGenerate("<<ListboxSelect>>"); + } + elsif ($mode eq 'extended') + { + $w->selectionClear(0,'end'); + $w->selectionSet('active'); + $w->selectionAnchor('active'); + $Prev = $w->index('active'); + @Selection = (); + $w->eventGenerate("<<ListboxSelect>>"); + } +} +# ExtendUpDown -- +# +# Does nothing unless we're in extended selection mode; in this +# case it moves the location cursor (active element) up or down by +# one element, and extends the selection to that point. +# +# Arguments: +# w - The listbox widget. +# amount - +1 to move down one item, -1 to move back one item. +sub ExtendUpDown +{ + my $w = shift; + my $amount = shift; + if ($w->cget('-selectmode') ne 'extended') + { + return; + } + my $active = $w->index('active'); + if (!@Selection) + { + $w->selectionSet($active); + @Selection = $w->curselection; + } + $w->activate($active + $amount); + $w->see('active'); + $w->Motion($w->index('active')) +} +# DataExtend +# +# This procedure is called for key-presses such as Shift-KEndData. +# If the selection mode isn't multiple or extend then it does nothing. +# Otherwise it moves the active element to el and, if we're in +# extended mode, extends the selection to that point. +# +# Arguments: +# w - The listbox widget. +# el - An integer element number. +sub DataExtend +{ + my $w = shift; + my $el = shift; + my $mode = $w->cget('-selectmode'); + if ($mode eq 'extended') + { + $w->activate($el); + $w->see($el); + if ($w->selectionIncludes('anchor')) + { + $w->Motion($el) + } + } + elsif ($mode eq 'multiple') + { + $w->activate($el); + $w->see($el) + } +} +# Cancel +# +# This procedure is invoked to cancel an extended selection in +# progress. If there is an extended selection in progress, it +# restores all of the items between the active one and the anchor +# to their previous selection state. +# +# Arguments: +# w - The listbox widget. +sub Cancel +{ + my $w = shift; + if ($w->cget('-selectmode') ne 'extended' || !defined $Prev) + { + return; + } + my $first = $w->index('anchor'); + my $last = $Prev; + if ($first > $last) + { + ($first, $last) = ($last, $first); + } + $w->selectionClear($first,$last); + while ($first <= $last) + { + if (Tk::lsearch(\@Selection,$first) >= 0) + { + $w->selectionSet($first) + } + $first++ + } + $w->eventGenerate("<<ListboxSelect>>"); +} +# SelectAll +# +# This procedure is invoked to handle the "select all" operation. +# For single and browse mode, it just selects the active element. +# Otherwise it selects everything in the widget. +# +# Arguments: +# w - The listbox widget. +sub SelectAll +{ + my $w = shift; + my $mode = $w->cget('-selectmode'); + if ($mode eq 'single' || $mode eq 'browse') + { + $w->selectionClear(0,'end'); + $w->selectionSet('active') + } + else + { + $w->selectionSet(0,'end') + } + $w->eventGenerate("<<ListboxSelect>>"); +} + +# Perl/Tk extensions: +sub SetList +{ + my $w = shift; + $w->delete(0,'end'); + $w->insert('end',@_); +} + +sub deleteSelected +{ + my $w = shift; + my $i; + foreach $i (reverse $w->curselection) + { + $w->delete($i); + } +} + +sub clipboardPaste +{ + my $w = shift; + my $index = $w->index('active') || $w->index($w->XEvent->xy); + my $str; + eval {local $SIG{__DIE__}; $str = $w->clipboardGet }; + return if $@; + foreach (split("\n",$str)) + { + $w->insert($index++,$_); + } +} + +sub getSelected +{ + my ($w) = @_; + my $i; + my (@result) = (); + foreach $i ($w->curselection) + { + push(@result,$w->get($i)); + } + return (wantarray) ? @result : $result[0]; +} + + + +1; +__END__ + + diff --git a/Master/tlpkg/tlperl/lib/Tk/MMtry.pm b/Master/tlpkg/tlperl/lib/Tk/MMtry.pm new file mode 100644 index 00000000000..3ef2f8868ab --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/MMtry.pm @@ -0,0 +1,54 @@ +# Copyright (c) 1995-2003 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. +package Tk::MMtry; +use Config; +require Exporter; + +use vars qw($VERSION @EXPORT); +$VERSION = sprintf '4.%03d', q$Revision: #9 $ =~ /\D(\d+)\s*$/; + +use base qw(Exporter); +@EXPORT = qw(try_compile try_run); +use strict; +use File::Basename; +use File::Spec; + +my $stderr_too = ($^O eq 'MSWin32') ? '' : '2>&1'; + +sub try_compile +{ + my ($file,$inc,$lib) = @_; + $inc = [] unless $inc; + $lib = [] unless $lib; + my $out = basename($file,'.c').$Config{'exe_ext'}; + warn "Test Compiling $file\n"; + my $msgs = `$Config{'cc'} -o $out $Config{'ccflags'} @$inc $file @$lib $stderr_too`; + my $ok = ($? == 0); +# warn $msgs if $msgs; + unlink($out) if (-f $out); + return $ok; +} + +sub try_run +{ + my ($file,$inc,$lib) = @_; + $inc = [] unless $inc; + $lib = [] unless $lib; + my $out = basename($file,'.c').$Config{'exe_ext'}; + warn "Test Compile/Run $file\n"; + my $msgs = `$Config{'cc'} -o $out $Config{'ccflags'} @$inc $file @$lib $stderr_too`; + my $ok = ($? == 0); +# warn "$Config{'cc'} -o $out $Config{'ccflags'} @$inc $file @$lib:\n$msgs" if $msgs; + if ($ok) + { + my $path = File::Spec->rel2abs($out); + $msgs = `$path $stderr_too`; + $ok = ($? == 0); +# warn "$path:$msgs" if $msgs; + } + unlink($out) if (-f $out); + return $ok; +} + +1; diff --git a/Master/tlpkg/tlperl/lib/Tk/MMutil.pm b/Master/tlpkg/tlperl/lib/Tk/MMutil.pm new file mode 100644 index 00000000000..84f3aa862f5 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/MMutil.pm @@ -0,0 +1,600 @@ +# Copyright (c) 1995-2003 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. +package Tk::MMutil; +use ExtUtils::MakeMaker; +use Cwd; +use Config; +use Carp; +use File::Basename; + +use vars qw($VERSION); +$VERSION = sprintf '4.%03d', q$Revision: #21 $ =~ /\D(\d+)\s*$/; + +# warn __FILE__." $VERSION\n"; + +use Tk::MakeDepend; + +use Tk::Config qw(!$VERSION); +use vars qw($IsWin32); + +*IsWin32 = \$main::IsWin32; +$IsWin32 = ($^O eq 'MSWin32' || $Config{'ccflags'} =~ /-D_?WIN32_?/) + unless defined $IsWin32; + +@MYEXPORT = qw(pasthru perldepend cflags const_config constants installbin c_o xs_o makefile manifypods); + +sub arch_prune +{ + my $hash = shift; + foreach (keys %$hash) + { + if ($win_arch eq 'x') + { + delete $hash->{$_} if /Win[A-Z0-9]/ or /OS2/ or /ImgUtil/ or /^x/; + } + elsif ($win_arch eq 'open32') + { + delete $hash->{$_} if /Unix|Mwm/ and not /tclUnix/; + delete $hash->{$_} if /winMain|dllMain/; + } + elsif ($win_arch eq 'pm') + { + delete $hash->{$_} + if /Unix|Mwm/ and not + /tclUnix|Unix(3d|Button|Dialog|Color|Embed|Focus|Font|Menu|Scrlbr|Send|Int\.|Scale)/; + delete $hash->{$_} if /os2Main|dllMain|tkOS2Dll|^x(colors\.c|gc\.)/; + delete $hash->{$_} if /ImgUtil|tkWin[A-Z0-9]/ and not /OS2/; + } + elsif ($win_arch eq 'MSWin32') + { + delete $hash->{$_} if /Mwm/ and not /tclUnix/; + delete $hash->{$_} if /winMain|dllMain/; + # delete $hash->{$_} if /^Xrm/; + } + } +} + +sub mTk_postamble +{ + my ($self) = @_; + my $dep = "config :: \$(C_FILES) \$(H_FILES)\n\t$self->{NOECHO}\$(NOOP)\n"; + my $mTk = $self->{'MTK'}; + $dep .= "# Begin Munging dependencies\n"; + foreach my $file (sort keys %$mTk) + { + $dep .= "$file : ".$mTk->{$file}." \$(TKDIR)/pTk/Tcl-pTk\n"; + $dep .= "\t\$(PERL) \$(TKDIR)/pTk/Tcl-pTk ".$mTk->{$file}." $file\n"; + } + $dep .= "# End Munging dependencies\n\n"; + return $dep; +} + +sub mTk_CHO +{ + my $self = shift; + my $mTk = shift; + my $exc = shift; + my %c; + my %h; + foreach (@{$self->{H}}) { $h{$_} = 1 } + foreach (@{$self->{C}}) { $c{$_} = 1 } + foreach (keys %$mTk) + { + if (/\.c$/) + { + $c{$_} = 1; + } + elsif (/\.h$/) + { + $h{$_} = 1; + } + } + foreach (keys %$exc) + { + if (/\.c$/) + { + delete $c{$_}; + } + elsif (/\.h$/) + { + delete $h{$_}; + } + } + while (@_) + { + my $name = shift; + cluck("No $name") unless (exists $c{$name}); + delete $c{$name} + } + arch_prune(\%h); + arch_prune(\%c); + $self->{'H'} = [sort keys %h]; + $self->{'C'} = [sort keys %c]; + my(@o_files) = @{$self->{C}}; + $self->{O_FILES} = [grep s/\.c(pp|xx|c)?$/$self->{OBJ_EXT}/i, @o_files] ; + $self->{'MTK'} = $mTk; + my $tk = installed_tk(); + my $perl = $self->{'PERL'}; + if ($IsWin32 && !-f $perl && -f "$perl.exe") + { + print "perl=$perl X=$^X\n"; + $perl = "$perl.exe"; + $self->{'PERL'} = $perl; + } + foreach my $file (sort keys %$mTk) + { + unless (-f $file && -M $file < -M $mTk->{$file}) + { + warn "Extracting $file\n"; + system($perl,"$tk/pTk/Tcl-pTk",$mTk->{$file},$file); + } + } +} + +my %visited; + +sub abspath +{ + my $dir = shift; + my $here = getcwd() || die "Cannot get current directory:$!"; + if (chdir($dir)) + { + $dir = getcwd(); + chdir($here) || die "Cannot cd back to $here:$!"; + } + return $dir; +} + +sub relpath +{ + my ($path,$dir) = @_; + unless (defined $dir) + { + $dir = (-d $path) ? $path : dirname($path); + } + if (defined $dir and -d $dir) + { + if ($path =~ m#^\Q$dir\E([/\\]?.*)$#) + { + my $base = $1; + my $here = getcwd; + if ($here =~ m#^\Q$dir\E([/\\]?.*)#) + { + my $depth = reverse($1); + if ($depth) + { + $depth =~ s,[^/\\]+,..,g; + } + else + { + $depth = '.' ; + } + $depth =~ s,[/\\]+$,,; + $base =~ s,^[/\\]+,,; + $depth .= "/$base" if ($base); + if (-e $depth) + { + # print "$path is $depth from $here\n"; + return $depth; + } + else + { + warn "Cannot find $depth\n"; + } + } + else + { + unless(exists $visited{$here}) + { + $visited{$here} = 1; + warn "$here does not start with $dir\n"; + warn "i.e. building outside Tk itself\n"; + } + } + } + else + { + die "'$path' not under '$dir'\n"; + } + } + else + { + die "Cannot get directory for $path\n"; + } + return $path; +} + +use strict; + +sub upgrade_pic +{ + my $flags = ''; + die 'upgrade_pic is obsolete'; + return $flags; +} + +sub pasthru +{ + my $self = shift; + my $str = $self->MM::pasthru; + if ($str =~ s/^\s+INC=.*\n//m) + { + $str = "# - Do NOT pasthru INC for Tk - it is computed by subdir\n$str" + } + if ($str =~ s/\bLIB="\$\(LIB\)"//) + { + $str = qq[# - Drop LIB="\$(LIB)" - not used\n$str]; + } + $str = "#Tk::MMutil pasthru\n$str"; + return $str; +} + +sub perldepend +{ + my $self = shift; + my $str = $self->MM::perldepend; + my $name; + my %c; + foreach my $file (@{$self->{'C'}}) + { + $c{$file} = 1; + } + foreach my $file (keys %{$self->{'XS'}}) + { + $c{$file} = 1; + delete $c{$self->{'XS'}{$file}}; + } + my @files = grep(-f $_,sort(keys %c)); + if (@files) + { + my $tk = installed_tk(); + my @inc = split(/\s+/,$self->{'INC'}); + my @def = split(/\s+/,$self->{'DEFINE'}); + push(@def,qw(-DWIN32 -D__WIN32__)) if ($IsWin32); + if ($^O eq 'cygwin') + { + push(@def,qw(-D__CYGWIN__)); + if ($win_arch eq 'MSWin32') + { + push(@def,qw(-D__WIN32__)) unless $self->{'DEFINE'} =~ /-D__WIN32__/; + push(@def,qw(-DWIN32)) if $self->{'NAME'} eq 'Tk::pTk'; + } + elsif ($win_arch eq 'x') + { + push(@def,qw(-U_WIN32)); + } + } + foreach (@inc) + { + s/\$\(TKDIR\)/$tk/g; + warn "Odd:$_" if /\$\(/; + } + $str .= Tk::MakeDepend::command_line(@inc,@def,@files) unless ($ENV{'TKNOMAKEDEPEND'}); + } + return $str; +} + +sub const_config +{ + my $self = shift; + my $name; + foreach $name (grep /(%|\.(old|bak|q4|orig|rej))$/,keys %{$self->{PM}}) + { + delete $self->{PM}->{$name}; + } + my $flags = $self->{'CCCDLFLAGS'}; + $flags =~ s/(-[fK]?\s*)pic\b/${1}PIC/; + $self->{'CCCDLFLAGS'} = $flags; + if ($^O eq 'MSWin32' && $Config{'ccflags'} =~ /-DPERL_OBJECT/) + { + $self->{'LDFLAGS'} =~ s/-(debug|pdb:\w+)\s+//g; + $self->{'LDDLFLAGS'} =~ s/-(debug|pdb:\w+)\s+//g; + } + elsif ($^O eq 'darwin' ) + { + $self->{'LDDLFLAGS'} =~ s/-flat_namespace//; + $self->{'LDDLFLAGS'} =~ s/-undefined\s+suppress//; + if ( -e "$Config{'archlib'}/CORE/$Config{'libperl'}" ) { + $self->{'LDDLFLAGS'} .= " -L\${PERL_ARCHLIB}/CORE -lperl "; + } + elsif ( -e "/System/Library/Perl/darwin/CORE/libperl.dylib" ) { + $self->{'LDDLFLAGS'} .= " -L/System/Library/Perl/darwin/CORE -lperl "; + } + else { + warn "Can't find libperl.dylib"; + } + $self->{'LDFLAGS'} =~ s/-flat_namespace//; + $self->{'LDFLAGS'} =~ s/-undefined\s+suppress//; + } elsif ($^O =~ /(openbsd)/i) + { + # -Bforcearchive is bad news for Tk - we don't want all of libpTk.a in all .so-s. + $self->{'LDDLFLAGS'} =~ s/-Bforcearchive\s*//g; + } + return $self->MM::const_config; +} + +sub constants +{ + my $self = shift; + local $_ = $self->MM::constants; + s/(\.SUFFIXES)/$1:\n$1/; + $_ .= "\nGCCOPT = $Tk::Config::gccopt\n"; + if ($IsWin32) + { + } + $_; +} + +sub cflags +{ + my $self = shift; + local $_ = $self->MM::cflags; + if (0 && $IsWin32) + { + if ($Config::Config{cc} =~ /^bcc/i) { + # s/(CCFLAGS\s*=)/$1/; + } + else { + s/(CCFLAGS\s*=)/$1 \$(cflags) \$(cvarsdll)/; + s/(OPTIMIZE\s*=).*/$1 \$(cdebug)/; + } + } + $_; +} + +sub c_o +{ + my $self = shift; + local $_ = $self->MM::c_o; + s/\$\(DEFINE\)/\$(DEFINE) \$(GCCOPT)/g; + $_; +} + +sub xs_o +{ + my $self = shift; + local $_ = $self->MM::xs_o; + s/\$\(DEFINE\)/\$(DEFINE) \$(GCCOPT)/g; + $_; +} + +sub manifypods +{ + my $self = shift; + # Maybe always call UNIX version - we HTMLize them later + local $_ = $self->MM::manifypods; + if ($] >= 5.00565) + { + s/(POD2MAN_EXE.*pod2man.*)/$1 --center "perl\/Tk Documentation" --release "Tk\$(VERSION)"/; + } + elsif ($] >= 5.003) + { + s/(POD2MAN_EXE.*pod2man.*)/$1 -center "perl\/Tk Documentation" -release "Tk\$(VERSION)"/; + } + else + { + s/(POD2MAN_EXE.*pod2man.*)/$1 -center \\"perl\/Tk Documentation\\" -release \\"Tk\$(VERSION)\\"/; + } + s/\bpod::/Tk::/mg; + s/\bpTk:://mg; + $_; +} + +sub findINC +{ + my $file = shift; + my $dir; + foreach $dir (@INC) + { + my $try = "$dir/$file"; + return $try if (-f $try); + } + die "Cannot find $file in \@INC\n"; +} + + +sub makefile +{ + my $self = shift; + my $str = $self->MM::makefile; + my $mm = findINC('Tk/MMutil.pm'); + my $cf = findINC('Tk/Config.pm'); + $str =~ s/(\$\(CONFIGDEP\))/$1 $cf $mm/; + $str =~ s/\$\(OBJECT\)\s*:.*\n//; + return $str; +} + +sub installed_tk +{ + my $tk; + my $dir; + foreach $dir (@INC) + { + if (-f "$dir/tkGlue.h") + { + $tk = relpath($dir); + last; + } + my $try = "$dir/Tk"; + if (-f "$try/tkGlue.h") + { + $tk = relpath($try,$dir); + last; + } + } + die "Cannot find perl/Tk include files\n" unless (defined $tk); + $tk =~ s,^(\./)+,,; + return $tk; +} + +sub installbin +{ + my ($self) = @_; + my $str = $self->MM::installbin; + my $prog = 'perl'; # $self->{'MAP_TARGET'} || 'perl'; + my $inc = findINC('Tk/MMutil.pm'); + $inc =~ s,/Tk/MMutil.pm$,,; + $inc = relpath($inc); + $str =~ s/^\tcp\s/\t\$(PERL) -I$inc -MTk::install -e installbin $prog /mg; + return $str; +} + +sub findpTk +{ + my $ptk; + my $dir; + foreach $dir (map(abspath($_),@_),@INC) + { + my $try = "$dir/pTk"; + if (-d $try && (-f "$try/Lang.h" || -f "$try/libpTk\$(LIB_EXT)")) + { + $ptk = relpath($try,$dir); + last; + } + } + confess "Cannot locate pTk\n" unless (defined $ptk); + return $ptk; +} + +sub find_subdir +{ + my %dir; + opendir(DIR,'.') || die "Cannot opendir:$!"; + foreach my $dir (readdir(DIR)) + { + next if $dir =~ /^\.\.?$/; + next if -l $dir; + next unless -d $dir; + if (-f "$dir/Makefile.PL") + { + my $exc = ($win_arch eq 'x') ? 'Unix' : 'Win'; + if (-f "$dir/Not${exc}.exc") + { + warn "Skip $dir on $win_arch\n" + } + else + { + $dir{$dir} = 1 + } + } + } + closedir(DIR); + return \%dir; +} + +sub TkExtMakefile +{ + my (%att) = @_; + if ($Config{'ccflags'} =~ /-DPERL_OBJECT/) + { + $att{'CAPI'} = 'TRUE' unless exists $att{'CAPI'}; + } + unless (exists $att{'DIR'}) + { + my $dir = find_subdir(); + $att{'DIR'} = [sort(keys %$dir)]; + } + unless (exists $att{'NAME'}) + { + my $dir = getcwd; + my ($pack) = $dir =~ m#/([^/]+)$#; + if (defined $pack) + { + $att{NAME} = 'Tk::'.$pack; + } + else + { + warn "No Name and cannot deduce from '$dir'"; + } + } + my $tk = installed_tk(); + $att{'macro'} = {} unless (exists $att{'macro'}); + $att{'macro'}{'TKDIR'} = $tk; + my @opt = ('VERSION' => $Tk::Config::VERSION, + 'XS_VERSION' => $Tk::Config::VERSION); + push(@opt,'clean' => {} ) unless (exists $att{'clean'}); + $att{'clean'}->{FILES} = '' unless (exists $att{'clean'}->{FILES}); + $att{'clean'}->{FILES} .= ' *.bak'; + unless (exists($att{'linkext'}) && $att{linkext}{LINKTYPE} eq '') + { + my $ptk = findpTk($tk); + my @tm = (findINC('Tk/typemap')); + unshift(@tm,@{$att{'TYPEMAPS'}}) if (exists $att{'TYPEMAPS'}); + $att{'TYPEMAPS'} = \@tm; + my $i = delete ($att{'INC'}); + $i = (defined $i) ? "$i $inc" : $inc; + if (delete $att{'dynamic_ptk'}) + { + push(@opt, + 'MYEXTLIB' => "$ptk/libpTk\$(LIB_EXT)", +# 'dynamic_lib' => { INST_DYNAMIC_DEP => "$ptk/libpTk\$(LIB_EXT)" } + ); + } + # Several loadable widgets use things from -lm + # if platform does not have a shared -lm need to link against it + if ($Config{libs} =~/-lm\b/) + { + my $libs = $att{'LIBS'}->[0]; + $att{'LIBS'}->[0] = "$libs -lm" unless $libs =~ /-lm\b/; + } + if ($IsWin32 && $Config{'cc'} =~ /^bcc/) + { + # Borland compiler is very dumb at finding files + $i = "-I$tk $i"; + $i = "-I$ptk $i"; + } + if ($IsWin32 && $Config{'cc'} =~ /^gcc/i) + { + my $base = $Config{'libpth'}; + $base =~ s#lib$#i386-mingw32/lib#; + my $extra = "-L$base -lcomdlg32 -lgdi32"; + my $libs = $att{'LIBS'}->[0]; + $att{'LIBS'}->[0] = "$extra $libs"; + } + if ($^O eq 'cygwin') + { + # NOTE: use gcc -shared instead of dllwrap (ld2), + # dllwrap tries to resolve all symbols, even those + # that are brought in from libraries like libpTk.a + push(@opt,'LD' => 'gcc -shared'); + if ($win_arch eq 'MSWin32') + { + my $extra = "-L/lib/w32api -lcomdlg32 -lgdi32"; + my $libs = $att{'LIBS'}->[0]; + $att{'LIBS'}->[0] = "$extra $libs"; + $att{'DEFINE'} .= ' -D__WIN32__ -D_WIN32'; + $att{'DEFINE'} .= ' -DWIN32' if($att{'NAME'} eq 'Tk::pTk'); + } + elsif ($win_arch eq 'x') + { + $att{'DEFINE'} .= ' -U_WIN32'; + } + } + if (delete $att{'ptk_include'}) + { + $i = "-I$ptk $i" unless ($ptk eq '.'); + } + else + { + $i = "-I$tk $i" unless ($tk eq '.'); + } + push(@opt,'DEFINE' => $define, 'INC' => $i); + } + WriteMakefile(@opt, %att); +} + +sub import +{ + no strict 'refs'; + my $class = shift; + my @list = (@_) ? @_ : @{"${class}::MYEXPORT"}; + my $name; + foreach $name (@list) + { + *{"MY::$name"} = \&{"$name"}; + } +} + + +1; diff --git a/Master/tlpkg/tlperl/lib/Tk/MainWindow.pm b/Master/tlpkg/tlperl/lib/Tk/MainWindow.pm new file mode 100644 index 00000000000..5384ccb560b --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/MainWindow.pm @@ -0,0 +1,213 @@ +# Copyright (c) 1995-2003 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. +package Tk::MainWindow; +use base qw(Tk::Toplevel); +BEGIN { @MainWindow::ISA = 'Tk::MainWindow' } + +use strict; + +use vars qw($VERSION); +$VERSION = sprintf '4.%03d', q$Revision: #12 $ =~ /\D(\d+)\s*$/; + +use Tk::CmdLine; +use Tk qw(catch); +require Tk::Toplevel; + +use Carp; + +$| = 1; + +my $pid = $$; + +my %Windows = (); + +sub CreateArgs +{ + my ($class,$args) = @_; + my $cmd = Tk::CmdLine->CreateArgs(); + my $key; + foreach $key (keys %$cmd) + { + $args->{$key} = $cmd->{$key} unless exists $args->{$key}; + } + my %result = $class->SUPER::CreateArgs(undef,$args); + my $name = delete($args->{'-name'}); + unless (Tk::tainting) + { + $ENV{'DISPLAY'} = ':0' unless (exists $ENV{'DISPLAY'}); + $result{'-screen'} = $ENV{'DISPLAY'} unless exists $result{'-screen'}; + } + return (-name => "\l$name",%result); +} + +sub new +{ + my $package = shift; + if (@_ > 0 && $_[0] =~ /:\d+(\.\d+)?$/) + { + carp "Usage $package->new(-screen => '$_[0]' ...)" if $^W; + unshift(@_,'-screen'); + } + croak('Odd number of args'."$package->new(" . join(',',@_) .')') if @_ % 2; + my %args = @_; + + my $top = eval { bless Create($package->CreateArgs(\%args)), $package }; + croak($@ . "$package->new(" . join(',',@_) .')') if ($@); + $top->apply_command_line; + $top->InitBindings; + $top->SetBindtags; + $top->InitObject(\%args); + eval { $top->configure(%args) }; + croak "$@" if ($@); + if (($top->positionfrom||'') ne 'user' and ($top->sizefrom||'') ne 'user') { + my $geometry = $top->optionGet(qw(geometry Geometry)); + if ($geometry) { + $top->geometry($geometry); + } + } + $Windows{$top} = $top; + return $top; +} + +sub _Destroyed +{ + my $top = shift; + $top->SUPER::_Destroyed; + delete $Windows{$top}; +} + +sub InitBindings +{ + my $mw = shift; + $mw->bind('all','<Tab>','focusNext'); + # <<LeftTab>> is named <<PrevWindow>> in Tcl/Tk + $mw->eventAdd(qw[<<LeftTab>> <Shift-Tab>]); + # This is needed for XFree86 systems + catch { $mw->eventAdd(qw[<<LeftTab>> <ISO_Left_Tab>]) }; + # This seems to be correct on *some* HP systems. + catch { $mw->eventAdd(qw[<<LeftTab>> <hpBackTab>]) }; + $mw->bind('all','<<LeftTab>>','focusPrev'); + if ($mw->windowingsystem eq 'x11') + { + $mw->eventAdd(qw[<<Cut>> <Control-Key-x> <Key-F20> <Meta-Key-w>]); + $mw->eventAdd(qw[<<Copy>> <Control-Key-c> <Key-F16> <Control-Key-w>]); + $mw->eventAdd(qw[<<Paste>> <Control-Key-v> <Key-F18> <Control-Key-y>]); + $mw->eventAdd(qw[<<PasteSelection>> <ButtonRelease-2>]); + $mw->eventAdd(qw[<<Undo>> <Control-Key-z> <Key-Undo> <Key-F14> + <Control-Key-underscore>]); + $mw->eventAdd(qw[<<Redo>> <Control-Key-y> <Shift-Key-Undo> <Key-F12> <Shift-Key-F14>]); + } + elsif ($mw->windowingsystem eq 'win32') + { + $mw->eventAdd(qw[<<Cut>> <Control-Key-x> <Shift-Key-Delete>]); + $mw->eventAdd(qw[<<Copy>> <Control-Key-c> <Control-Key-Insert>]); + $mw->eventAdd(qw[<<Paste>> <Control-Key-v> <Shift-Key-Insert>]); + $mw->eventAdd(qw[<<Undo>> <Control-Key-z>]); + $mw->eventAdd(qw[<<Redo>> <Control-Key-y>]); + } + elsif ($mw->windowingsystem eq 'aqua') + { + $mw->eventAdd(qw[<<Cut>> <Command-Key-x> <Key-F2>]); + $mw->eventAdd(qw[<<Copy>> <Command-Key-c> <Key-F3>]); + $mw->eventAdd(qw[<<Paste>> <Command-Key-v> <Key-F4>]); + $mw->eventAdd(qw[<<PasteSelection>> <ButtonRelease-2>]); + $mw->eventAdd(qw[<<Clear>> <Clear>]); + $mw->eventAdd(qw[<<Undo>> <Command-Key-z>]); + $mw->eventAdd(qw[<<Redo>> <Command-Key-y>]); + } + elsif ($mw->windowingsystem eq 'classic') + { + $mw->eventAdd(qw[<<Cut>> <Control-Key-x> <Key-F2>]); + $mw->eventAdd(qw[<<Copy>> <Control-Key-c> <Key-F3>]); + $mw->eventAdd(qw[<<Paste>> <Control-Key-v> <Key-F4>]); + $mw->eventAdd(qw[<<PasteSelection>> <ButtonRelease-2>]); + $mw->eventAdd(qw[<<Clear>> <Clear>]); + $mw->eventAdd(qw[<<Undo>> <Control-Key-z> <Key-F1>]); + $mw->eventAdd(qw[<<Redo>> <Control-Key-Z>]); + } + + # FIXME - Should these move to Menubutton ? + my $c = ($Tk::platform eq 'unix') ? 'all' : 'Tk::Menubutton'; + $mw->bind($c,'<Alt-KeyPress>',['TraverseToMenu',Tk::Ev('K')]); + $mw->bind($c,'<F10>','FirstMenu'); +} + +sub Existing +{ + my @Windows; + foreach my $name (keys %Windows) + { + my $obj = $Windows{$name}; + if (Tk::Exists($obj)) + { + push(@Windows,$obj); + } + else + { + delete $Windows{$name}; + } + } + return @Windows; +} + +END +{ + if (Tk::IsParentProcess()) + { + foreach my $top (values %Windows) + { + if ($top->IsWidget) + { + # Tk data structuctures are still in place + # this can occur if non-callback perl code did a 'die'. + # It will also handle some cases of non-Tk 'exit' being called + # Destroy this mainwindow and hence is descendants ... + $top->destroy; + } + } + } +} + +sub CmdLine { return shift->command } + +sub WMSaveYourself +{ + my $mw = shift; + my @args = @{$mw->command}; +# warn 'preWMSaveYourself:'.join(' ',@args)."\n"; + @args = ($0) unless (@args); + my $i = 1; + while ($i < @args) + { + if ($args[$i] eq '-iconic') + { + splice(@args,$i,1); + } + elsif ($args[$i] =~ /^-(geometry|iconposition)$/) + { + splice(@args,$i,2); + } + } + + my @ip = $mw->wm('iconposition'); +# print 'ip ',join(',',@ip),"\n"; + my $icon = $mw->iconwindow; + if (defined($icon)) + { + @ip = $icon->geometry =~ /\d+x\d+([+-]\d+)([+-]\d+)/; + } + splice(@args,1,0,'-iconposition' => join(',',@ip)) if (@ip == 2); + + splice(@args,1,0,'-iconic') if ($mw->state() eq 'iconic'); + + splice(@args,1,0,'-geometry' => $mw->geometry); +# warn 'postWMSaveYourself:'.join(' ',@args)."\n"; + $mw->command([@args]); +} + +1; + +__END__ + +=cut diff --git a/Master/tlpkg/tlperl/lib/Tk/MakeDepend.pm b/Master/tlpkg/tlperl/lib/Tk/MakeDepend.pm new file mode 100644 index 00000000000..bfb7b43ccbc --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/MakeDepend.pm @@ -0,0 +1,292 @@ +package Tk::MakeDepend; +use strict; +use vars qw(%define); +use Config; + +my @include; + +use Carp; + +$SIG{__DIE__} = \&Carp::confess; + + +use vars qw($VERSION); +$VERSION = sprintf '4.%03d', q$Revision: #13 $ =~ /\D(\d+)\s*$/; + +sub scan_file; + +sub do_include +{ + my ($inc,$dep,@include) = @_; + foreach my $dir (@include) + { + my $path = "$dir/$inc"; + if (-f $path) + { + scan_file($path,$dep) unless exists $dep->{$path}; + return; + } + } + warn "Cannot find '$inc' assume made\n"; + $dep->{$inc} = 1; +} + +sub remove_comment +{ + s#^\s*/\*.*?\*/\s*##g; +} + + +sub term +{ + remove_comment(); + return !term() if s/^\s*!//; + return exists($define{$1}) if s/^\s*defined\s*\(([_A-Za-z][_\w]*)\s*\)//; + return exists($define{$1}) if s/^\s*defined\s*([_A-Za-z][_\w]*)//; + return eval "$1" if s/^\s*(0x[0-9a-f]+)//i; + return $1 if s/^\s*(\d+)//; + return $define{$1} || 0 if s/^\s*([_A-Za-z][_\w]*)//; + if (s/^\s*\(//) + { + my $val = expression(0); + warn "Missing ')'\n" unless s/^\s*\)//; + return $val; + } + warn "Invalid term:$_"; + return undef; +} + +my %pri = ( '&&' => 4, + '||' => 3, + '>=' => 2, '<=' => 2, '<' => 2, '>' => 2, + '==' => 1, '!=' => 1 ); + +sub expression +{ + my $pri = shift; + # printf STDERR "%d# expr . $_\n"; + my $invert = 0; + my $lhs = term() || 0; + remove_comment(); + while (/^\s*(&&|\|\||>=?|<=?|==|!=)/) + { + my $op = $1; + last unless ($pri{$op} >= $pri); + s/^\s*\Q$op\E//; + # printf STDERR "%d# $lhs $op . $_\n"; + my $rhs = expression($pri{$op}) || 0; + my $e = "$lhs $op $rhs"; + $lhs = eval "$e" || 0; + die "'$e' $@" if $@; + remove_comment(); + } + return $lhs; +} + +sub do_if +{ + my ($key,$expr) = @_; + chomp($expr); + if ($key eq 'ifdef' || $key eq 'ifndef') + { + if ($expr =~ /^\s*(\w+)/) + { + my $val = exists $define{$1}; + $val = !$val if ($key eq 'ifndef'); +# printf STDERR "%d from $key $expr\n",$val; + return $val; + } + } + else + { + local $_ = $expr; + my $val = expression(0) != 0; + warn "trailing: $_" if /\S/; + #printf STDERR "%d from $key $expr\n",$val; + return $val; + } +} + +sub scan_file +{ + no strict 'refs'; + my ($file,$dep) = @_; + open($file,"<$file") || die "Cannot open $file:$!"; + local $_; + my ($srcdir) = $file =~ m#^(.*)[\\/][^\\/]*$#; + $srcdir = '.' unless defined $srcdir; + my $live = 1; + $dep->{$file} = 1; + my @stack; + while (<$file>) + { + $_ .= <$file> while (s/\\\n/ /); + if (/^\s*#\s*(\w+)\s*(.*?)\s*$/) + { + my $ol = $live; + my $key = $1; + my $rest = $2; + if ($key =~ /^if(.*)$/) + { + push(@stack,$live); + $live &&= do_if($key,$rest); + } + elsif ($key eq 'elif') + { + $live = ($live) ? 0 : $stack[-1]; + $live &&= do_if('if',$rest); + } + elsif ($key eq 'else') + { + $live = ($live) ? 0 : $stack[-1]; + } + elsif ($key eq 'endif') + { + if (@stack) + { + $live = pop(@stack); + } + else + { + die "$file:$.: Mismatched #endif\n"; + } + } + elsif ($live) + { + if ($key eq 'include') + { + do_include($1,$dep,$srcdir,@include) if $rest =~ /^"(.*)"/; + } + elsif ($key eq 'define') + { + if ($rest =~ /^\s*([_A-Za-z][\w_]*)\s*(.*)$/) + { + my $sym = $1; + my $val = $2 || 1; + $val =~ s#\s*/\*.*?\*/\s*# #g; + $define{$sym} = $val; + } + else + { + warn "ignore '$key $rest'\n"; + } + } + elsif ($key eq 'undef') + { + if ($rest =~ /^\s*([_A-Za-z][\w_]*)/) + { + delete $define{$1}; + } + } + elsif ($key =~ /^(line|pragma)$/) + { + + } + else + { + warn "ignore '$key $rest'\n"; + } + } + # printf STDERR "$file:$.: %d $key $rest\n",$live if ($ol != $live); + } + else + { + # print if $live; + } + } + close($file); + if (@stack) + { + warn "$file:$.: unclosed #if\n"; + } +} + +sub command_line +{ + @include = (); + local %define = ('__STDC__' => 1 ); + my $data = ''; + my @files; + while (@_ && $_[-1] !~ /^-/) + { + unshift(@files,pop(@_)); + } + my $flags = $Config{ccflags}; + $flags =~ s/^\s+|\s+$//g; + my @opt = (@_, split(/\s+/,$flags)); + while (@opt) + { + local $_ = shift(@opt); + if (/^-I(.*)$/) + { + push @include,$1; + } + elsif (/^-D([^=]+)(?:=(.*))?$/) + { + $define{$1} = $2 || 1; + } + elsif (/^-U(.*)$/) + { + delete $define{$1}; + } + elsif (/^(-.*)$/) + { + # Some option + if ($opt[0] !~ /^-/) + { + # next arg does not start with '-' assume it + # belongs to this option and discard it silently + shift(@opt); + } + } + else + { + # We got confused + warn "Ignoring $1\n"; + } + } + # force /usr/include to be last element of @include + push @include, $Config{'usrinc'} + if (defined $Config{'usrinc'} and $Config{'usrinc'} ne ''); + # warn "Include:@include\n"; + while (@files) + { + local $_ = shift(@files); + unless (/^(.*)\.[^\.]+$/) + { + warn "Skip $_"; + next; + } + local %define = %define; + my $base = $1; + my $file = $_; + my %dep; + warn "Finding dependencies for $file\n"; + scan_file($_,\%dep); + my $str = "\n$base\$(OBJ_EXT) : $base.c"; + delete $dep{$file}; + my @dep = (sort(keys %dep)); + while (@dep) + { + my $dep = shift(@dep); + $dep =~ s#^\./##; + if (length($str)+length($dep) > 70) + { + $data .= "$str \\\n"; + $str = ' '; + } + else + { + $str .= ' '; + } + $str .= $dep; + } + $data .= "$str\n"; + } + return $data; +} + +1; +__END__ + + diff --git a/Master/tlpkg/tlperl/lib/Tk/Menu.pm b/Master/tlpkg/tlperl/lib/Tk/Menu.pm new file mode 100644 index 00000000000..91e9aceed61 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Menu.pm @@ -0,0 +1,1145 @@ +# Converted from menu.tcl -- +# +# This file defines the default bindings for Tk menus and menubuttons. +# It also implements keyboard traversal of menus and implements a few +# other utility procedures related to menus. +# +# @(#) menu.tcl 1.34 94/12/19 17:09:09 +# +# Copyright (c) 1992-1994 The Regents of the University of California. +# 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. + +package Tk::Menu; +require Tk; +require Tk::Widget; +require Tk::Wm; +require Tk::Derived; +require Tk::Menu::Item; + + +use vars qw($VERSION); +$VERSION = sprintf '4.%03d', q$Revision: #21 $ =~ /\D(\d+)\s*$/; + +use strict; + +use base qw(Tk::Wm Tk::Derived Tk::Widget); + +Construct Tk::Widget 'Menu'; + +sub Tk_cmd { \&Tk::_menu } + +Tk::Methods('activate','add','clone','delete','entrycget','entryconfigure', + 'index','insert','invoke','post','postcascade','type', + 'unpost','yposition'); + +import Tk qw(Ev); + +sub CreateArgs +{ + my ($package,$parent,$args) = @_; + # Remove from hash %$args any configure-like + # options which only apply at create time (e.g. -class for Frame) + # return these as a list of -key => value pairs + my @result = (); + my $opt; + foreach $opt (qw(-type -screen -visual -colormap)) + { + my $val = delete $args->{$opt}; + push(@result, $opt => $val) if (defined $val); + } + return @result; +} + +sub InitObject +{ + my ($menu,$args) = @_; + my $menuitems = delete $args->{-menuitems}; + $menu->SUPER::InitObject($args); + $menu->ConfigSpecs(-foreground => ['SELF']); + if (defined $menuitems) + { + # If any other args do configure now + if (%$args) + { + $menu->configure(%$args); + %$args = (); + } + $menu->AddItems(@$menuitems) + } +} + +sub AddItems +{ + my $menu = shift; + ITEM: + while (@_) + { + my $item = shift; + if (!ref($item)) + { + $menu->separator; # A separator + } + else + { + my ($kind,$name,%minfo) = ( @$item ); + my $invoke = delete $minfo{'-invoke'}; + if (defined $name) + { + $minfo{-label} = $name unless defined($minfo{-label}); + $menu->$kind(%minfo); + } + else + { + $menu->BackTrace("Don't recognize " . join(' ',@$item)); + } + } # A non-separator + } +} + +# +#------------------------------------------------------------------------- +# Elements of tkPriv that are used in this file: +# +# cursor - Saves the -cursor option for the posted menubutton. +# focus - Saves the focus during a menu selection operation. +# Focus gets restored here when the menu is unposted. +# inMenubutton - The name of the menubutton widget containing +# the mouse, or an empty string if the mouse is +# not over any menubutton. +# popup - If a menu has been popped up via tk_popup, this +# gives the name of the menu. Otherwise this +# value is empty. +# postedMb - Name of the menubutton whose menu is currently +# posted, or an empty string if nothing is posted +# A grab is set on this widget. +# relief - Used to save the original relief of the current +# menubutton. +# window - When the mouse is over a menu, this holds the +# name of the menu; it's cleared when the mouse +# leaves the menu. +#------------------------------------------------------------------------- +#------------------------------------------------------------------------- +# Overall note: +# This file is tricky because there are four different ways that menus +# can be used: +# +# 1. As a pulldown from a menubutton. This is the most common usage. +# In this style, the variable tkPriv(postedMb) identifies the posted +# menubutton. +# 2. As a torn-off menu copied from some other menu. In this style +# tkPriv(postedMb) is empty, and the top-level menu is no +# override-redirect. +# 3. As an option menu, triggered from an option menubutton. In thi +# style tkPriv(postedMb) identifies the posted menubutton. +# 4. As a popup menu. In this style tkPriv(postedMb) is empty and +# the top-level menu is override-redirect. +# +# The various binding procedures use the state described above to +# distinguish the various cases and take different actions in each +# case. +#------------------------------------------------------------------------- +# Bind -- +# This procedure is invoked the first time the mouse enters a menubutton +# widget or a menubutton widget receives the input focus. It creates +# all of the class bindings for both menubuttons and menus. +# +# Arguments: +# w - The widget that was just entered or just received +# the input focus. +# event - Indicates which event caused the procedure to be invoked +# (Enter or FocusIn). It is used so that we can carry out +# the functions of that event in addition to setting up +# bindings. +sub ClassInit +{ + my ($class,$mw) = @_; + # Must set focus when mouse enters a menu, in order to allow + # mixed-mode processing using both the mouse and the keyboard. + $mw->bind($class,'<FocusIn>', 'NoOp'); + $mw->bind($class,'<Enter>', 'Enter'); + $mw->bind($class,'<Leave>', ['Leave',Ev('X'),Ev('Y'),Ev('s')]); + $mw->bind($class,'<Motion>', ['Motion',Ev('x'),Ev('y'),Ev('s')]); + $mw->bind($class,'<ButtonPress>','ButtonDown'); + $mw->bind($class,'<ButtonRelease>',['Invoke',1]); + $mw->bind($class,'<space>',['Invoke',0]); + $mw->bind($class,'<Return>',['Invoke',0]); + $mw->bind($class,'<Escape>','Escape'); + $mw->bind($class,'<Left>','LeftArrow'); + $mw->bind($class,'<Right>','RightArrow'); + $mw->bind($class,'<Up>','UpArrow'); + $mw->bind($class,'<Down>','DownArrow'); + $mw->bind($class,'<KeyPress>', ['TraverseWithinMenu',Ev('K')]); + $mw->bind($class,'<Alt-KeyPress>', ['TraverseWithinMenu',Ev('K')]); + return $class; +} + +sub UpArrow +{ + my $menu = shift; + if ($menu->cget('-type') eq 'menubar') + { + $menu->NextMenu('left'); + } + else + { + $menu->NextEntry(-1); + } +} + +sub DownArrow +{ + my $menu = shift; + if ($menu->cget('-type') eq 'menubar') + { + $menu->NextMenu('right'); + } + else + { + $menu->NextEntry(1); + } +} + +sub LeftArrow +{ + my $menu = shift; + if ($menu->cget('-type') eq 'menubar') + { + $menu->NextEntry(-1); + } + else + { + $menu->NextMenu('left'); + } +} + +sub RightArrow +{ + my $menu = shift; + if ($menu->cget('-type') eq 'menubar') + { + $menu->NextEntry(1); + } + else + { + $menu->NextMenu('right'); + } +} + + + +# Unpost -- +# This procedure unposts a given menu, plus all of its ancestors up +# to (and including) a menubutton, if any. It also restores various +# values to what they were before the menu was posted, and releases +# a grab if there's a menubutton involved. Special notes: +# 1. It's important to unpost all menus before releasing the grab, so +# that any Enter-Leave events (e.g. from menu back to main +# application) have mode NotifyGrab. +# 2. Be sure to enclose various groups of commands in "catch" so that +# the procedure will complete even if the menubutton or the menu +# or the grab window has been deleted. +# +# Arguments: +# menu - Name of a menu to unpost. Ignored if there +# is a posted menubutton. +sub Unpost +{ + my $menu = shift; + my $mb = $Tk::postedMb; + + # Restore focus right away (otherwise X will take focus away when + # the menu is unmapped and under some window managers (e.g. olvwm) + # we'll lose the focus completely). + + eval {local $SIG{__DIE__}; $Tk::focus->focus() } if (defined $Tk::focus); + undef $Tk::focus; + + # Unpost menu(s) and restore some stuff that's dependent on + # what was posted. + eval {local $SIG{__DIE__}; + if (defined $mb) + { + $menu = $mb->cget('-menu'); + $menu->unpost(); + $Tk::postedMb = undef; + $mb->configure('-cursor',$Tk::cursor); + $mb->configure('-relief',$Tk::relief) + } + elsif (defined $Tk::popup) + { + $Tk::popup->unpost(); + my $grab = $Tk::popup->grabCurrent; + $grab->grabRelease if (defined $grab); + + undef $Tk::popup; + } + elsif (defined $menu && ref $menu && + $menu->cget('-type') ne 'menubar' && + $menu->cget('-type') ne 'tearoff' + ) + { + # We're in a cascaded sub-menu from a torn-off menu or popup. + # Unpost all the menus up to the toplevel one (but not + # including the top-level torn-off one) and deactivate the + # top-level torn off menu if there is one. + while (1) + { + my $parent = $menu->parent; + last if (!$parent->IsMenu || !$parent->ismapped); + $parent->postcascade('none'); + $parent->GenerateMenuSelect; + $parent->activate('none'); + my $type = $parent->cget('-type'); + last if ($type eq 'menubar' || $type eq 'tearoff'); + $menu = $parent + } + $menu->unpost() if ($menu->cget('-type') ne 'menubar'); + } + }; + warn "$@" if ($@); + if ($Tk::tearoff || $Tk::menubar) + { + # Release grab, if any. + if (defined $menu && ref $menu) + { + my $grab = $menu->grabCurrent; + $grab->grabRelease if (defined $grab); + } + RestoreOldGrab(); + if ($Tk::menubar) + { + $Tk::menubar->configure(-cursor => $Tk::cursor); + undef $Tk::menubar; + } + if ($Tk::platform ne 'unix') + { + undef $Tk::tearoff; + } + } +} + +sub RestoreOldGrab +{ + if (defined $Tk::oldGrab) + { + eval + { + local $SIG{__DIE__}; + if ($Tk::grabStatus eq 'global') + { + $Tk::oldGrab->grabGlobal; + } + else + { + $Tk::oldGrab->grab; + } + }; + undef $Tk::oldGrab; + } +} + +sub typeIS +{my $w = shift; + my $type = $w->type(shift); + return defined $type && $type eq shift; +} + +# Motion -- +# This procedure is called to handle mouse motion events for menus. +# It does two things. First, it resets the active element in the +# menu, if the mouse is over the menu. Second, if a mouse button +# is down, it posts and unposts cascade entries to match the mouse +# position. +# +# Arguments: +# menu - The menu window. +# y - The y position of the mouse. +# state - Modifier state (tells whether buttons are down). +sub Motion +{ + my $menu = shift; + my $x = shift; + my $y = shift; + my $state = shift; + my $t = $menu->cget('-type'); + + if ($menu->IS($Tk::window)) + { + if ($menu->cget('-type') eq 'menubar') + { +# if (defined($Tk::focus) && $Tk::focus != $menu) + { + $menu->activate("\@$x,$y"); + $menu->GenerateMenuSelect; + } + } + else + { + $menu->activate("\@$x,$y"); + $menu->GenerateMenuSelect; + } + } + if (($state & 0x1f00) != 0) + { + $menu->postcascade('active') + } +} +# ButtonDown -- +# Handles button presses in menus. There are a couple of tricky things +# here: +# 1. Change the posted cascade entry (if any) to match the mouse position. +# 2. If there is a posted menubutton, must grab to the menubutton so +# that it can track mouse motions over other menubuttons and change +# the posted menu. +# 3. If there's no posted menubutton (e.g. because we're a torn-off menu +# or one of its descendants) must grab to the top-level menu so that +# we can track mouse motions across the entire menu hierarchy. + +# +# Arguments: +# menu - The menu window. +sub ButtonDown +{ + my $menu = shift; + $menu->postcascade('active'); + if (defined $Tk::postedMb) + { + $Tk::postedMb->grabGlobal + } + else + { + while ($menu->cget('-type') eq 'normal' + && $menu->parent->IsMenu + && $menu->parent->ismapped + ) + { + $menu = $menu->parent; + } + + if (!defined $Tk::menuBar) + { + $Tk::menuBar = $menu; + $Tk::cursor = $menu->cget('-cursor'); + $menu->configure(-cursor => 'arrow'); + } + + # Don't update grab information if the grab window isn't changing. + # Otherwise, we'll get an error when we unpost the menus and + # restore the grab, since the old grab window will not be viewable + # anymore. + + $menu->SaveGrabInfo unless ($menu->IS($menu->grabCurrent)); + + # Must re-grab even if the grab window hasn't changed, in order + # to release the implicit grab from the button press. + + $menu->grabGlobal if ($Tk::platform eq 'unix'); + } +} + +sub Enter +{ + my $w = shift; + my $ev = $w->XEvent; + $Tk::window = $w; + if ($w->cget('-type') eq 'tearoff') + { + if ($ev->m ne 'NotifyUngrab') + { + $w->SetFocus if ($Tk::platform eq 'unix'); + } + } + $w->Motion($ev->x, $ev->y, $ev->s); +} + +# Leave -- +# This procedure is invoked to handle Leave events for a menu. It +# deactivates everything unless the active element is a cascade element +# and the mouse is now over the submenu. +# +# Arguments: +# menu - The menu window. +# rootx, rooty - Root coordinates of mouse. +# state - Modifier state. +sub Leave +{ + my $menu = shift; + my $rootx = shift; + my $rooty = shift; + my $state = shift; + undef $Tk::window; + return if ($menu->index('active') eq 'none'); + if ($menu->typeIS('active','cascade')) + { + my $c = $menu->Containing($rootx,$rooty); + return if (defined $c && $menu->entrycget('active','-menu')->IS($c)); + } + $menu->activate('none'); + $menu->GenerateMenuSelect; +} + +# Invoke -- +# This procedure is invoked when button 1 is released over a menu. +# It invokes the appropriate menu action and unposts the menu if +# it came from a menubutton. +# +# Arguments: +# w - Name of the menu widget. +sub Invoke +{ + my $w = shift; + my $release = shift; + + if ($release && !defined($Tk::window)) + { + # Mouse was pressed over a menu without a menu button, then + # dragged off the menu (possibly with a cascade posted) and + # released. Unpost everything and quit. + + $w->postcascade('none'); + $w->activate('none'); + $w->eventGenerate('<<MenuSelect>>'); + $w->Unpost; + return; + } + + my $type = $w->type('active'); + if ($w->typeIS('active','cascade')) + { + $w->postcascade('active'); + my $menu = $w->entrycget('active','-menu'); + $menu->FirstEntry() if (defined $menu); + } + elsif ($w->typeIS('active','tearoff')) + { + $w->Unpost(); + $w->tearOffMenu(); + } + elsif ($w->typeIS('active','menubar')) + { + $w->postcascade('none'); + $w->activate('none'); + $w->eventGenerate('<<MenuSelect>>'); + $w->Unpost; + } + else + { + $w->Unpost(); + $w->invoke('active') + } +} +# Escape -- +# This procedure is invoked for the Cancel (or Escape) key. It unposts +# the given menu and, if it is the top-level menu for a menu button, +# unposts the menu button as well. +# +# Arguments: +# menu - Name of the menu window. +sub Escape +{ + my $menu = shift; + my $parent = $menu->parent; + if (!$parent->IsMenu) + { + $menu->Unpost() + } + elsif ($parent->cget('-type') eq 'menubar') + { + $menu->Unpost; + RestoreOldGrab(); + } + else + { + $menu->NextMenu(-1) + } +} +# LeftRight -- +# This procedure is invoked to handle "left" and "right" traversal +# motions in menus. It traverses to the next menu in a menu bar, +# or into or out of a cascaded menu. +# +# Arguments: +# menu - The menu that received the keyboard +# event. +# direction - Direction in which to move: "left" or "right" +sub NextMenu +{ + my $menu = shift; + my $direction = shift; + # First handle traversals into and out of cascaded menus. + my $count; + if ($direction eq 'right') + { + $count = 1; + if ($menu->typeIS('active','cascade')) + { + $menu->postcascade('active'); + my $m2 = $menu->entrycget('active','-menu'); + $m2->FirstEntry if (defined $m2); + return; + } + else + { + my $parent = $menu->parent; + while ($parent->PathName ne '.') + { + if ($parent->IsMenu && $parent->cget('-type') eq 'menubar') + { + $parent->SetFocus; + $parent->NextEntry(1); + return; + } + $parent = $parent->parent; + } + } + } + else + { + $count = -1; + my $m2 = $menu->parent; + if ($m2->IsMenu) + { + if ($m2->cget('-type') ne 'menubar') + { + $menu->activate('none'); + $menu->GenerateMenuSelect; + $m2->SetFocus; + # This code unposts any posted submenu in the parent. + my $tmp = $m2->index('active'); + $m2->activate('none'); + $m2->activate($tmp); + return; + } + } + } + # Can't traverse into or out of a cascaded menu. Go to the next + # or previous menubutton, if that makes sense. + + my $m2 = $menu->parent; + if ($m2->IsMenu) + { + if ($m2->cget('-type') eq 'menubar') + { + $m2->SetFocus; + $m2->NextEntry(-1); + return; + } + } + + my $w = $Tk::postedMb; + return unless defined $w; + my @buttons = $w->parent->children; + my $length = @buttons; + my $i = Tk::lsearch(\@buttons,$w)+$count; + my $mb; + while (1) + { + while ($i < 0) + { + $i += $length + } + while ($i >= $length) + { + $i += -$length + } + $mb = $buttons[$i]; + last if ($mb->IsMenubutton && $mb->cget('-state') ne 'disabled' + && defined($mb->cget('-menu')) + && $mb->cget('-menu')->index('last') ne 'none' + ); + return if ($mb == $w); + $i += $count + } + $mb->PostFirst(); +} +# NextEntry -- +# Activate the next higher or lower entry in the posted menu, +# wrapping around at the ends. Disabled entries are skipped. +# +# Arguments: +# menu - Menu window that received the keystroke. +# count - 1 means go to the next lower entry, +# -1 means go to the next higher entry. +sub NextEntry +{ + my $menu = shift; + my $count = shift; + if ($menu->index('last') eq 'none') + { + return; + } + my $length = $menu->index('last')+1; + my $quitAfter = $length; + my $active = $menu->index('active'); + my $i = ($active eq 'none') ? 0 : $active+$count; + while (1) + { + return if ($quitAfter <= 0); + while ($i < 0) + { + $i += $length + } + while ($i >= $length) + { + $i += -$length + } + my $state = eval {local $SIG{__DIE__}; $menu->entrycget($i,'-state') }; + last if (defined($state) && $state ne 'disabled'); + return if ($i == $active); + $i += $count; + $quitAfter -= 1; + } + $menu->activate($i); + $menu->GenerateMenuSelect; + if ($menu->cget('-type') eq 'menubar' && $menu->type($i) eq 'cascade') + { + my $cascade = $menu->entrycget($i, '-menu'); + $menu->postcascade($i); + $cascade->FirstEntry if (defined $cascade); + } +} + + +# tkTraverseWithinMenu +# This procedure implements keyboard traversal within a menu. It +# searches for an entry in the menu that has "char" underlined. If +# such an entry is found, it is invoked and the menu is unposted. +# +# Arguments: +# w - The name of the menu widget. +# char - The character to look for; case is +# ignored. If the string is empty then +# nothing happens. +sub TraverseWithinMenu +{ + my $w = shift; + my $char = shift; + return unless (defined $char); + $char = "\L$char"; + my $last = $w->index('last'); + return if ($last eq 'none'); + for (my $i = 0;$i <= $last;$i += 1) + { + my $label = eval {local $SIG{__DIE__}; $w->entrycget($i,'-label') }; + next unless defined($label); + my $ul = $w->entrycget($i,'-underline'); + if (defined $ul && $ul >= 0) + { + $label = substr("\L$label",$ul,1); + if (defined($label) && $label eq $char) + { + if ($w->type($i) eq 'cascade') + { + $w->postcascade($i); + $w->activate($i); + my $m2 = $w->entrycget($i,'-menu'); + $m2->FirstEntry if (defined $m2); + } + else + { + $w->Unpost(); + $w->invoke($i); + } + return; + } + } + } +} + +sub FindMenu +{ + my ($menu,$char) = @_; + if ($menu->cget('-type') eq 'menubar') + { + if (!defined($char) || $char eq '') + { + $menu->FirstEntry; + } + else + { + $menu->TraverseWithinMenu($char); + } + return $menu; + } + return undef; +} + + +# FirstEntry -- +# Given a menu, this procedure finds the first entry that isn't +# disabled or a tear-off or separator, and activates that entry. +# However, if there is already an active entry in the menu (e.g., +# because of a previous call to tkPostOverPoint) then the active +# entry isn't changed. This procedure also sets the input focus +# to the menu. +# +# Arguments: +# menu - Name of the menu window (possibly empty). +sub FirstEntry +{ + my $menu = shift; + return if (!defined($menu) || $menu eq '' || !ref($menu)); + $menu->SetFocus; + return if ($menu->index('active') ne 'none'); + my $last = $menu->index('last'); + return if ($last eq 'none'); + for (my $i = 0;$i <= $last;$i += 1) + { + my $state = eval {local $SIG{__DIE__}; $menu->entrycget($i,'-state') }; + if (defined $state && $state ne 'disabled' && !$menu->typeIS($i,'tearoff')) + { + $menu->activate($i); + $menu->GenerateMenuSelect; + if ($menu->type($i) eq 'cascade') + { + my $cascade = $menu->entrycget($i,'-menu'); + if (defined $cascade) + { + $menu->postcascade($i); + $cascade->FirstEntry; + } + } + return; + } + } +} + +# FindName -- +# Given a menu and a text string, return the index of the menu entry +# that displays the string as its label. If there is no such entry, +# return an empty string. This procedure is tricky because some names +# like "active" have a special meaning in menu commands, so we can't +# always use the "index" widget command. +# +# Arguments: +# menu - Name of the menu widget. +# s - String to look for. +sub FindName +{ + my $menu = shift; + my $s = shift; + my $i = undef; + if ($s !~ /^active$|^last$|^none$|^[0-9]|^@/) + { + $i = eval {local $SIG{__DIE__}; $menu->index($s) }; + return $i; + } + my $last = $menu->index('last'); + return if ($last eq 'none'); + for ($i = 0;$i <= $last;$i += 1) + { + my $label = eval {local $SIG{__DIE__}; $menu->entrycget($i,'-label') }; + return $i if (defined $label && $label eq $s); + } + return undef; +} +# PostOverPoint -- +# This procedure posts a given menu such that a given entry in the +# menu is centered over a given point in the root window. It also +# activates the given entry. +# +# Arguments: +# menu - Menu to post. +# x, y - Root coordinates of point. +# entry - Index of entry within menu to center over (x,y). +# If omitted or specified as {}, then the menu's +# upper-left corner goes at (x,y). +sub PostOverPoint +{ + my $menu = shift; + my $x = shift; + my $y = shift; + my $entry = shift; + if (defined $entry) + { + if ($entry == $menu->index('last')) + { + $y -= ($menu->yposition($entry)+$menu->height)/2; + } + else + { + $y -= ($menu->yposition($entry)+$menu->yposition($entry+1))/2; + } + $x -= $menu->reqwidth/2; + } + $menu->post($x,$y); + if (defined($entry) && $menu->entrycget($entry,'-state') ne 'disabled') + { + $menu->activate($entry); + $menu->GenerateMenuSelect; + } +} +# tk_popup -- +# This procedure pops up a menu and sets things up for traversing +# the menu and its submenus. +# +# Arguments: +# menu - Name of the menu to be popped up. +# x, y - Root coordinates at which to pop up the +# menu. +# entry - Index of a menu entry to center over (x,y). +# If omitted or specified as {}, then menu's +# upper-left corner goes at (x,y). +sub Post +{ + my $menu = shift; + return unless (defined $menu); + my $x = shift; + my $y = shift; + my $entry = shift; + Unpost(undef) if (defined($Tk::popup) || defined($Tk::postedMb)); + $menu->PostOverPoint($x,$y,$entry); + $menu->grabGlobal; + $Tk::popup = $menu; + $Tk::focus = $menu->focusCurrent; + $menu->focus(); +} + +sub SetFocus +{ + my $menu = shift; + $Tk::focus = $menu->focusCurrent if (!defined($Tk::focus)); + $menu->focus; +} + +sub GenerateMenuSelect +{ + my $menu = shift; + $Tk::activeMenu = $menu; + $Tk::activeItem = $menu->index('active'); + $menu->eventGenerate('<<MenuSelect>>'); # FIXME +} + +# Converted from tearoff.tcl -- +# +# This file contains procedures that implement tear-off menus. +# +# @(#) tearoff.tcl 1.3 94/12/17 16:05:25 +# +# Copyright (c) 1994 The Regents of the University of California. +# 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. +# +# tkTearoffMenu -- +# Given the name of a menu, this procedure creates a torn-off menu +# that is identical to the given menu (including nested submenus). +# The new torn-off menu exists as a toplevel window managed by the +# window manager. The return value is the name of the new menu. +# +# Arguments: +# w - The menu to be torn-off (duplicated). +sub tearOffMenu +{ + my $w = shift; + my $x = (@_) ? shift : 0; + my $y = (@_) ? shift : 0; + + $x = $w->rootx if $x == 0; + $y = $w->rooty if $y == 0; + + # Find a unique name to use for the torn-off menu. Find the first + # ancestor of w that is a toplevel but not a menu, and use this as + # the parent of the new menu. This guarantees that the torn off + # menu will be on the same screen as the original menu. By making + # it a child of the ancestor, rather than a child of the menu, it + # can continue to live even if the menu is deleted; it will go + # away when the toplevel goes away. + + my $parent = $w->parent; + while ($parent->toplevel != $parent || $parent->IsMenu) + { + $parent = $parent->parent; + } + my $menu = $w->clone($parent->PathName,'tearoff'); + + # Pick a title for the new menu by looking at the parent of the + # original: if the parent is a menu, then use the text of the active + # entry. If it's a menubutton then use its text. + my $title = $w->cget('-title'); + # print ref($w),' ',$w->PathName," $w\n"; + unless (defined $title && length($title)) + { + $parent = $w->parent; + if ($parent) + { + if ($parent->IsMenubutton) + { + $title = $parent->cget('-text'); + } + elsif ($parent->IsMenu) + { + $title = $parent->entrycget('active','-label'); + } + } + } + $menu->title($title) if (defined $title && length($title)); + $menu->post($x,$y); + # Set tkPriv(focus) on entry: otherwise the focus will get lost + # after keyboard invocation of a sub-menu (it will stay on the + # submenu). + + + # This seems to conflict with <Enter> class binding above + # if this fires before the class binding the wrong thing + # will get saved in $Tk::focus + # $menu->bind('<Enter>','EnterFocus'); + $menu->Callback('-tearoffcommand'); + return $menu; +} + +# tkMenuDup -- +# Given a menu (hierarchy), create a duplicate menu (hierarchy) +# in a given window. +# +# Arguments: +# src - Source window. Must be a menu. It and its +# menu descendants will be duplicated at path. +# path - Name to use for topmost menu in duplicate +# hierarchy. + +sub tkMenuDup +{ + my ($src,$path,$type) = @_; + my ($pname,$name) = $path =~ /^(.*)\.([^\.]*)$/; + ($name) = $src->PathName =~ /^.*\.([^\.]*)$/ unless $name; + my $parent = ($pname) ? $src->Widget($pname) : $src->MainWindow; + my %args = (Name => $name, -type => $type); + foreach my $option ($src->configure()) + { + next if (@$option == 2); + $args{$$option[0]} = $$option[4] unless exists $args{$$option[0]}; + } + my $dst = ref($src)->new($parent,%args); + # print "MenuDup $src $path $name $type ->",$dst->PathName,"\n"; + $_[1] = $dst; + if ($type eq 'tearoff') + { + $dst->transient($parent->toplevel); + } + my $last = $src->index('last'); + if ($last ne 'none') + { + for (my $i = $src->cget('-tearoff'); $i <= $last; $i++) + { + my $type = $src->type($i); + if (defined $type) + { + my @args = (); + foreach my $option ($src->entryconfigure($i)) + { + next if (@$option == 2); + push(@args,$$option[0],$$option[4]) if (defined $$option[4]); + } + $dst->add($type,@args); + } + } + } + # Duplicate the binding tags and bindings from the source menu. + my @bindtags = $src->bindtags; + $path = $src->PathName; + foreach (@bindtags) + { + $_ = $dst if ($_ eq $path); + } + $dst->bindtags([@bindtags]); + foreach my $event ($src->bind) + { + my $cb = $src->bind($event); +# print "$event => $cb\n"; + $dst->bind($event,$cb->Substitute($src,$dst)); + } + return $dst; +} + + + +# Some convenience methods + +sub separator { require Tk::Menu::Item; shift->Separator(@_); } +sub cascade { require Tk::Menu::Item; shift->Cascade(@_); } +sub checkbutton { require Tk::Menu::Item; shift->Checkbutton(@_); } +sub radiobutton { require Tk::Menu::Item; shift->Radiobutton(@_); } + +sub command +{ + my ($menu,%args) = @_; + require Tk::Menu::Item; + if (exists $args{-button}) + { + # Backward compatible stuff from 'Menubar' + my $button = delete $args{-button}; + $button = ['Misc', -underline => 0 ] unless (defined $button); + my @bargs = (); + ($button,@bargs) = @$button if (ref($button) && ref $button eq 'ARRAY'); + $menu = $menu->Menubutton(-label => $button, @bargs); + } + $menu->Command(%args); +} + +sub Menubutton +{ + my ($menu,%args) = @_; + my $name = delete($args{'-text'}) || $args{'-label'};; + $args{'-label'} = $name if (defined $name); + my $items = delete $args{'-menuitems'}; + foreach my $opt (qw(-pack -after -before -side -padx -ipadx -pady -ipady -fill)) + { + delete $args{$opt}; + } + if (defined($name) && !defined($args{-underline})) + { + my $underline = ($name =~ s/^(.*)~/$1/) ? length($1): undef; + if (defined($underline) && ($underline >= 0)) + { + $args{-underline} = $underline; + $args{-label} = $name; + } + } + my $hash = $menu->TkHash('MenuButtons'); + my $mb = $hash->{$name}; + if (defined $mb) + { + delete $args{'-tearoff'}; # too late! + $mb->configure(%args) if %args; + } + else + { + $mb = $menu->cascade(%args); + $hash->{$name} = $mb; + } + $mb->menu->AddItems(@$items) if defined($items) && @$items; + return $mb; +} + +sub BalloonInfo +{ + my ($menu,$balloon,$X,$Y,@opt) = @_; + my $i = $menu->index('active'); + if ($i eq 'none') + { + my $y = $Y - $menu->rooty; + $i = $menu->index("\@$y"); + } + foreach my $opt (@opt) + { + my $info = $balloon->GetOption($opt,$menu); + if ($opt =~ /^-(statusmsg|balloonmsg)$/ && UNIVERSAL::isa($info,'ARRAY')) + { + $balloon->Subclient($i); + return '' if $i eq 'none'; + return ${$info}[$i] || ''; + } + return $info; + } +} + +1; + +__END__ + + diff --git a/Master/tlpkg/tlperl/lib/Tk/Menu/Item.pm b/Master/tlpkg/tlperl/lib/Tk/Menu/Item.pm new file mode 100644 index 00000000000..403052ef5bd --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Menu/Item.pm @@ -0,0 +1,180 @@ +package Tk::Menu::Item; + +require Tk::Menu; + +use Carp; +use strict; + +use vars qw($VERSION); +$VERSION = '4.004'; # $Id: //depot/Tkutf8/Tk/Menu/Item.pm#4 $ + +sub PreInit +{ + # Dummy (virtual) method + my ($class,$menu,$minfo) = @_; +} + +sub new +{ + my ($class,$menu,%minfo) = @_; + my $kind = $class->kind; + my $name = $minfo{'-label'}; + if (defined $kind) + { + my $invoke = delete $minfo{'-invoke'}; + if (defined $name) + { + # Use ~ in name/label to set -underline + if (defined($minfo{-label}) && !defined($minfo{-underline})) + { + my $cleanlabel = $minfo{-label}; + my $underline = ($cleanlabel =~ s/^(.*)~/$1/) ? length($1): undef; + if (defined($underline) && ($underline >= 0)) + { + $minfo{-underline} = $underline; + $name = $cleanlabel if ($minfo{-label} eq $name); + $minfo{-label} = $cleanlabel; + } + } + } + else + { + $name = $minfo{'-bitmap'} || $minfo{'-image'}; + croak('No -label') unless defined($name); + $minfo{'-label'} = $name; + } + $class->PreInit($menu,\%minfo); + $menu->add($kind,%minfo); + $menu->invoke('last') if ($invoke); + } + else + { + $menu->add('separator'); + } + return bless [$menu,$name],$class; +} + +sub configure +{ + my $obj = shift; + my ($menu,$name) = @$obj; + my %args = @_; + $obj->[1] = $args{'-label'} if exists $args{'-label'}; + $menu->entryconfigure($name,@_); +} + +sub cget +{ + my $obj = shift; + my ($menu,$name) = @$obj; + $menu->entrycget($name,@_); +} + +sub parentMenu +{ + my $obj = shift; + return $obj->[0]; +} + +# Default "kind" is a command +sub kind { return 'command' } + +# Now the derived packages + +package Tk::Menu::Separator; +use base qw(Tk::Menu::Item); +Construct Tk::Menu 'Separator'; +sub kind { return undef } + +package Tk::Menu::Button; +use base qw(Tk::Menu::Item); +Construct Tk::Menu 'Button'; +Construct Tk::Menu 'Command'; + +#package Tk::Menu::Command; +#use base qw(Tk::Menu::Button); +#Construct Tk::Menu 'Command'; + +package Tk::Menu::Cascade; +use base qw(Tk::Menu::Item); +Construct Tk::Menu 'Cascade'; +sub kind { return 'cascade' } +use Carp; + +sub PreInit +{ + my ($class,$menu,$minfo) = @_; + my $tearoff = delete $minfo->{-tearoff}; + my $items = delete $minfo->{-menuitems}; + my $widgetvar = delete $minfo->{-menuvar}; + my $command = delete $minfo->{-postcommand}; + my $name = delete $minfo->{'Name'}; + $name = $minfo->{'-label'} unless defined $name; + my @args = (); + push(@args, '-tearoff' => $tearoff) if (defined $tearoff); + push(@args, '-menuitems' => $items) if (defined $items); + push(@args, '-postcommand' => $command) if (defined $command); + my $submenu = $minfo->{'-menu'}; + unless (defined $submenu) + { + $minfo->{'-menu'} = $submenu = $menu->Menu(Name => $name, @args); + } + $$widgetvar = $submenu if (defined($widgetvar) && ref($widgetvar)); +} + +sub menu +{ + my ($self,%args) = @_; + my $w = $self->parentMenu; + my $menu = $self->cget('-menu'); + if (!defined $menu) + { + require Tk::Menu; + $w->ColorOptions(\%args); + my $name = $self->cget('-label'); + warn "Had to (re-)reate menu for $name"; + $menu = $w->Menu(Name => $name, %args); + $self->configure('-menu'=>$menu); + } + else + { + $menu->configure(%args) if %args; + } + return $menu; +} + +# Some convenience methods + +sub separator { shift->menu->Separator(@_); } +sub command { shift->menu->Command(@_); } +sub cascade { shift->menu->Cascade(@_); } +sub checkbutton { shift->menu->Checkbutton(@_); } +sub radiobutton { shift->menu->Radiobutton(@_); } + +sub pack +{ + my $w = shift; + if ($^W) + { + require Carp; + Carp::carp("Cannot 'pack' $w - done automatically") + } +} + +package Tk::Menu::Checkbutton; +use base qw(Tk::Menu::Item); +Construct Tk::Menu 'Checkbutton'; +sub kind { return 'checkbutton' } + +package Tk::Menu::Radiobutton; +use base qw(Tk::Menu::Item); +Construct Tk::Menu 'Radiobutton'; +sub kind { return 'radiobutton' } + +package Tk::Menu::Item; + +1; +__END__ + +=cut + diff --git a/Master/tlpkg/tlperl/lib/Tk/Menubar.pm b/Master/tlpkg/tlperl/lib/Tk/Menubar.pm new file mode 100644 index 00000000000..54b745130bf --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Menubar.pm @@ -0,0 +1,15 @@ +# Copyright (c) 1995-2003 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. +package Tk::Menubar; +use strict; + +use vars qw($VERSION); +$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Menubar.pm#6 $ + +use Tk::Frame; +use Tk::Menu; +# use Carp; +# carp "Tk::Menubar is obsolete" if $^W; + +1; diff --git a/Master/tlpkg/tlperl/lib/Tk/Menubutton.pm b/Master/tlpkg/tlperl/lib/Tk/Menubutton.pm new file mode 100644 index 00000000000..59456b2dea2 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Menubutton.pm @@ -0,0 +1,398 @@ +# Converted from menu.tcl -- +# +# This file defines the default bindings for Tk menus and menubuttons. +# It also implements keyboard traversal of menus and implements a few +# other utility procedures related to menus. +# +# @(#) menu.tcl 1.34 94/12/19 17:09:09 +# +# Copyright (c) 1992-1994 The Regents of the University of California. +# 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. + + +package Tk::Menubutton; +require Tk; + +use vars qw($VERSION); +$VERSION = '4.004'; # $Id: //depot/Tkutf8/Menubutton/Menubutton.pm#4 $ + +use base qw(Tk::Widget); + +Construct Tk::Widget 'Menubutton'; + +import Tk qw(&Ev $XS_VERSION); + +bootstrap Tk::Menubutton; + +sub Tk_cmd { \&Tk::menubutton } + +sub InitObject +{ + my ($mb,$args) = @_; + my $menuitems = delete $args->{-menuitems}; + my $tearoff = delete $args->{-tearoff}; + $mb->SUPER::InitObject($args); + if ((defined($menuitems) || defined($tearoff)) && %$args) + { + $mb->configure(%$args); + %$args = (); + } + $mb->menu(-tearoff => $tearoff) if (defined $tearoff); + $mb->AddItems(@$menuitems) if (defined $menuitems) +} + + +# +#------------------------------------------------------------------------- +# Elements of tkPriv that are used in this file: +# +# cursor - Saves the -cursor option for the posted menubutton. +# focus - Saves the focus during a menu selection operation. +# Focus gets restored here when the menu is unposted. +# inMenubutton - The name of the menubutton widget containing +# the mouse, or an empty string if the mouse is +# not over any menubutton. +# popup - If a menu has been popped up via tk_popup, this +# gives the name of the menu. Otherwise this +# value is empty. +# postedMb - Name of the menubutton whose menu is currently +# posted, or an empty string if nothing is posted +# A grab is set on this widget. +# relief - Used to save the original relief of the current +# menubutton. +# window - When the mouse is over a menu, this holds the +# name of the menu; it's cleared when the mouse +# leaves the menu. +#------------------------------------------------------------------------- +#------------------------------------------------------------------------- +# Overall note: +# This file is tricky because there are four different ways that menus +# can be used: +# +# 1. As a pulldown from a menubutton. This is the most common usage. +# In this style, the variable tkPriv(postedMb) identifies the posted +# menubutton. +# 2. As a torn-off menu copied from some other menu. In this style +# tkPriv(postedMb) is empty, and the top-level menu is no +# override-redirect. +# 3. As an option menu, triggered from an option menubutton. In thi +# style tkPriv(postedMb) identifies the posted menubutton. +# 4. As a popup menu. In this style tkPriv(postedMb) is empty and +# the top-level menu is override-redirect. +# +# The various binding procedures use the state described above to +# distinguish the various cases and take different actions in each +# case. +#------------------------------------------------------------------------- +# Menu::Bind -- +# This procedure is invoked the first time the mouse enters a menubutton +# widget or a menubutton widget receives the input focus. It creates +# all of the class bindings for both menubuttons and menus. +# +# Arguments: +# w - The widget that was just entered or just received +# the input focus. +# event - Indicates which event caused the procedure to be invoked +# (Enter or FocusIn). It is used so that we can carry out +# the functions of that event in addition to setting up +# bindings. +sub ClassInit +{ + my ($class,$mw) = @_; + $mw->bind($class,'<FocusIn>','NoOp'); + $mw->bind($class,'<Enter>','Enter'); + $mw->bind($class,'<Leave>','Leave'); + $mw->bind($class,'<1>','ButtonDown'); + $mw->bind($class,'<Motion>',['Motion','up',Ev('X'),Ev('Y')]); + $mw->bind($class,'<B1-Motion>',['Motion','down',Ev('X'),Ev('Y')]); + $mw->bind($class,'<ButtonRelease-1>','ButtonUp'); + $mw->bind($class,'<space>','PostFirst'); + $mw->bind($class,'<Return>','PostFirst'); + return $class; +} + +sub ButtonDown +{my $w = shift; + my $Ev = $w->XEvent; + $Tk::inMenubutton->Post($Ev->X,$Ev->Y) if (defined $Tk::inMenubutton); +} + +sub PostFirst +{ + my $w = shift; + my $menu = $w->cget('-menu'); + $w->Post(); + $menu->FirstEntry() if (defined $menu); +} + + +# Enter -- +# This procedure is invoked when the mouse enters a menubutton +# widget. It activates the widget unless it is disabled. Note: +# this procedure is only invoked when mouse button 1 is *not* down. +# The procedure B1Enter is invoked if the button is down. +# +# Arguments: +# w - The name of the widget. +sub Enter +{ + my $w = shift; + $Tk::inMenubutton->Leave if (defined $Tk::inMenubutton); + $Tk::inMenubutton = $w; + if ($w->cget('-state') ne 'disabled') + { + $w->configure('-state','active') + } +} + +sub Leave +{ + my $w = shift; + $Tk::inMenubutton = undef; + return unless Tk::Exists($w); + if ($w->cget('-state') eq 'active') + { + $w->configure('-state','normal') + } +} +# Post -- +# Given a menubutton, this procedure does all the work of posting +# its associated menu and unposting any other menu that is currently +# posted. +# +# Arguments: +# w - The name of the menubutton widget whose menu +# is to be posted. +# x, y - Root coordinates of cursor, used for positioning +# option menus. If not specified, then the center +# of the menubutton is used for an option menu. +sub Post +{ + my $w = shift; + my $x = shift; + my $y = shift; + return if ($w->cget('-state') eq 'disabled'); + return if (defined $Tk::postedMb && $w == $Tk::postedMb); + my $menu = $w->cget('-menu'); + return unless (defined($menu) && $menu->index('last') ne 'none'); + + my $tearoff = $Tk::platform eq 'unix' || $menu->cget('-type') eq 'tearoff'; + + my $wpath = $w->PathName; + my $mpath = $menu->PathName; + unless (index($mpath,"$wpath.") == 0) + { + die "Cannot post $mpath : not a descendant of $wpath"; + } + + my $cur = $Tk::postedMb; + if (defined $cur) + { + Tk::Menu->Unpost(undef); # fixme + } + $Tk::cursor = $w->cget('-cursor'); + $Tk::relief = $w->cget('-relief'); + $w->configure('-cursor','arrow'); + $w->configure('-relief','raised'); + $Tk::postedMb = $w; + $Tk::focus = $w->focusCurrent; + $menu->activate('none'); + $menu->GenerateMenuSelect; + # If this looks like an option menubutton then post the menu so + # that the current entry is on top of the mouse. Otherwise post + # the menu just below the menubutton, as for a pull-down. + + eval + {local $SIG{'__DIE__'}; + my $dir = $w->cget('-direction'); + if ($dir eq 'above') + { + $menu->post($w->rootx, $w->rooty - $menu->ReqHeight); + } + elsif ($dir eq 'below') + { + $menu->post($w->rootx, $w->rooty + $w->Height); + } + elsif ($dir eq 'left') + { + my $x = $w->rootx - $menu->ReqWidth; + my $y = int((2*$w->rooty + $w->Height) / 2); + if ($w->cget('-indicatoron') == 1 && defined($w->cget('-textvariable'))) + { + $menu->PostOverPoint($x,$y,$menu->FindName($w->cget('-text'))) + } + else + { + $menu->post($x,$y); + } + } + elsif ($dir eq 'right') + { + my $x = $w->rootx + $w->Width; + my $y = int((2*$w->rooty + $w->Height) / 2); + if ($w->cget('-indicatoron') == 1 && defined($w->cget('-textvariable'))) + { + $menu->PostOverPoint($x,$y,$menu->FindName($w->cget('-text'))) + } + else + { + $menu->post($x,$y); + } + } + else + { + if ($w->cget('-indicatoron') == 1 && defined($w->cget('-textvariable'))) + { + if (!defined($y)) + { + $x = $w->rootx+$w->width/2; + $y = $w->rooty+$w->height/2 + } + $menu->PostOverPoint($x,$y,$menu->FindName($w->cget('-text'))) + } + else + { + $menu->post($w->rootx,$w->rooty+$w->height); + } + } + }; + if ($@) + { + Tk::Menu->Unpost; + die $@ + } + + $Tk::tearoff = $tearoff; + if ($tearoff) + { + $menu->focus; + $w->SaveGrabInfo; + $w->grabGlobal; + } +} +# Motion -- +# This procedure handles mouse motion events inside menubuttons, and +# also outside menubuttons when a menubutton has a grab (e.g. when a +# menu selection operation is in progress). +# +# Arguments: +# w - The name of the menubutton widget. +# upDown - "down" means button 1 is pressed, "up" means +# it isn't. +# rootx, rooty - Coordinates of mouse, in (virtual?) root window. +sub Motion +{ + my $w = shift; + my $upDown = shift; + my $rootx = shift; + my $rooty = shift; + return if (defined($Tk::inMenubutton) && $Tk::inMenubutton == $w); + my $new = $w->Containing($rootx,$rooty); + if (defined($Tk::inMenubutton)) + { + if (!defined($new) || ($new != $Tk::inMenubutton && $w->toplevel != $new->toplevel)) + { + $Tk::inMenubutton->Leave(); + } + } + if (defined($new) && $new->IsMenubutton && $new->cget('-indicatoron') == 0 && + $w->cget('-indicatoron') == 0) + { + if ($upDown eq 'down') + { + $new->Post($rootx,$rooty); + } + else + { + $new->Enter(); + } + } +} +# ButtonUp -- +# This procedure is invoked to handle button 1 releases for menubuttons. +# If the release happens inside the menubutton then leave its menu +# posted with element 0 activated. Otherwise, unpost the menu. +# +# Arguments: +# w - The name of the menubutton widget. + +sub ButtonUp { + my $w = shift; + + my $tearoff = $Tk::platform eq 'unix' || (defined($w->cget('-menu')) && + $w->cget('-menu')->cget('-type') eq 'tearoff'); + if ($tearoff && (defined($Tk::postedMb) && $Tk::postedMb == $w) + && (defined($Tk::inMenubutton) && $Tk::inMenubutton == $w)) { + $Tk::postedMb->cget(-menu)->FirstEntry(); + } else { + Tk::Menu->Unpost(undef); + } +} # end ButtonUp + +# Some convenience methods + +sub menu +{ + my ($w,%args) = @_; + my $menu = $w->cget('-menu'); + if (!defined $menu) + { + require Tk::Menu; + $w->ColorOptions(\%args) if ($Tk::platform eq 'unix'); + $menu = $w->Menu(%args); + $w->configure('-menu'=>$menu); + } + else + { + $menu->configure(%args); + } + return $menu; +} + +sub separator { require Tk::Menu::Item; shift->menu->Separator(@_); } +sub command { require Tk::Menu::Item; shift->menu->Command(@_); } +sub cascade { require Tk::Menu::Item; shift->menu->Cascade(@_); } +sub checkbutton { require Tk::Menu::Item; shift->menu->Checkbutton(@_); } +sub radiobutton { require Tk::Menu::Item; shift->menu->Radiobutton(@_); } + +sub AddItems +{ + shift->menu->AddItems(@_); +} + +sub entryconfigure +{ + shift->menu->entryconfigure(@_); +} + +sub entrycget +{ + shift->menu->entrycget(@_); +} + +sub FindMenu +{ + my $child = shift; + my $char = shift; + my $ul = $child->cget('-underline'); + if (defined $ul && $ul >= 0 && $child->cget('-state') ne 'disabled') + { + my $char2 = $child->cget('-text'); + $char2 = substr("\L$char2",$ul,1) if (defined $char2); + if (!defined($char) || $char eq '' || (defined($char2) && "\l$char" eq $char2)) + { + $child->PostFirst; + return $child; + } + } + return undef; +} + +1; + +__END__ + + diff --git a/Master/tlpkg/tlperl/lib/Tk/Message.pm b/Master/tlpkg/tlperl/lib/Tk/Message.pm new file mode 100644 index 00000000000..63b0f170097 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Message.pm @@ -0,0 +1,20 @@ +# Copyright (c) 1995-2003 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. +package Tk::Message; +use strict; + +use vars qw($VERSION); +$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Message.pm#6 $ + +require Tk::Widget; + +use base qw(Tk::Widget); + +Construct Tk::Widget 'Message'; + +sub Tk_cmd { \&Tk::message } + +1; +__END__ + diff --git a/Master/tlpkg/tlperl/lib/Tk/NBFrame.pm b/Master/tlpkg/tlperl/lib/Tk/NBFrame.pm new file mode 100644 index 00000000000..0e45251f852 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/NBFrame.pm @@ -0,0 +1,20 @@ +package Tk::NBFrame; + +use vars qw($VERSION); +$VERSION = '4.004'; # $Id: //depot/Tkutf8/NBFrame/NBFrame.pm#4 $ + +use Tk qw($XS_VERSION); + +use base qw(Tk::Widget); + +Construct Tk::Widget 'NBFrame'; + +bootstrap Tk::NBFrame; + +sub Tk_cmd { \&Tk::nbframe } + +Tk::Methods qw(activate add delete focus info geometryinfo identify + move pagecget pageconfigure); + +1; + diff --git a/Master/tlpkg/tlperl/lib/Tk/NoteBook.pm b/Master/tlpkg/tlperl/lib/Tk/NoteBook.pm new file mode 100644 index 00000000000..64db87a80d3 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/NoteBook.pm @@ -0,0 +1,452 @@ +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*$/; +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($_ !~ /$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->{-dynamicgeometry}) || + ($w->{-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; +} + +1; + +__END__ + +=cut diff --git a/Master/tlpkg/tlperl/lib/Tk/Optionmenu.pm b/Master/tlpkg/tlperl/lib/Tk/Optionmenu.pm new file mode 100644 index 00000000000..7c0e81766db --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Optionmenu.pm @@ -0,0 +1,130 @@ +# Copyright (c) 1995-2003 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. +package Tk::Optionmenu; +require Tk::Menubutton; +require Tk::Menu; +use Carp; + +use vars qw($VERSION); +$VERSION = '4.013'; # $Id: //depot/Tkutf8/Tk/Optionmenu.pm#13 $ + +use base qw(Tk::Derived Tk::Menubutton); + +use strict; + +Construct Tk::Widget 'Optionmenu'; + +sub Populate +{ + my ($w,$args) = @_; + $w->SUPER::Populate($args); + $args->{-indicatoron} = 1; + my $menu = $w->menu(-tearoff => 0); + + # Should we allow -menubackground etc. as in -label* of Frame ? + + $w->ConfigSpecs(-command => ['CALLBACK',undef,undef,undef], + -options => ['METHOD', undef, undef, undef], + -variable=> ['PASSIVE', undef, undef, undef], + -font => [['SELF',$menu], undef, undef, undef], + -foreground => [['SELF', 'CHILDREN'], undef, undef, undef], + + -takefocus => [ qw/SELF takefocus Takefocus 1/ ], + -highlightthickness => [ qw/SELF highlightThickness HighlightThickness 1/ ], + -relief => [ qw/SELF relief Relief raised/ ], + + ); + + # configure -variable and -command now so that when -options + # is set by main-line configure they are there to be set/called. + + my $tvar = delete $args->{-textvariable}; + my $vvar = delete $args->{-variable}; + if (!defined($vvar)) + { + if (defined $tvar) + { + $vvar = $tvar; + } + else + { + my $new; + $vvar = \$new; + } + } + $tvar = $vvar if (!defined($tvar)); + $w->configure(-textvariable => $tvar, -variable => $vvar); + $w->configure(-command => $vvar) if ($vvar = delete $args->{-command}); +} + +sub setOption +{ + my ($w, $label, $val) = @_; + my $tvar = $w->cget(-textvariable); + my $vvar = $w->cget(-variable); + if (@_ == 2) + { + $val = $label; + } + $$tvar = $label if $tvar; + $$vvar = $val if $vvar; + $w->Callback(-command => $val); +} + +sub addOptions +{ + my $w = shift; + my $menu = $w->menu; + my $tvar = $w->cget(-textvariable); + my $vvar = $w->cget(-variable); + my $oldt = $$tvar; + my $width = $w->cget('-width'); + my %hash; + my $first; + while (@_) + { + my $val = shift; + my $label = $val; + if (ref $val) + { + if ($vvar == $tvar) + { + my $new = $label; + $w->configure(-textvariable => ($tvar = \$new)); + } + ($label, $val) = @$val; + } + my $len = length($label); + $width = $len if (!defined($width) || $len > $width); + $menu->command(-label => $label, -command => [ $w , 'setOption', $label, $val ]); + $hash{$label} = $val; + $first = $label unless defined $first; + } + if (!defined($oldt) || !exists($hash{$oldt})) + { + $w->setOption($first, $hash{$first}) if defined $first; + } + $w->configure('-width' => $width); +} + +sub options +{ + my ($w,$opts) = @_; + if (@_ > 1) + { + $w->menu->delete(0,'end'); + $w->addOptions(@$opts); + } + else + { + return $w->_cget('-options'); + } +} + +1; + +__END__ + +=cut + diff --git a/Master/tlpkg/tlperl/lib/Tk/PNG.pm b/Master/tlpkg/tlperl/lib/Tk/PNG.pm new file mode 100644 index 00000000000..1ecb4001d17 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/PNG.pm @@ -0,0 +1,43 @@ +package Tk::PNG; +require DynaLoader; + +use vars qw($VERSION); +$VERSION = sprintf '4.%03d', q$Revision: #3 $ =~ /\D(\d+)\s*$/; + +use Tk 800.005; +require Tk::Image; +require Tk::Photo; + +use base qw(DynaLoader); + +bootstrap Tk::PNG $Tk::VERSION; + +1; + +__END__ + +=head1 NAME + +Tk::PNG - PNG loader for Tk::Photo + +=head1 SYNOPSIS + + use Tk; + use Tk::PNG; + + my $image = $widget->Photo('-format' => 'png', -file => 'something.png'); + + +=head1 DESCRIPTION + +This is an extension for Tk800.* which supplies +PNG format loader for Photo image type. + + +=head1 AUTHOR + +Nick Ing-Simmons E<lt>nick@ing-simmons.netE<gt> + +=cut + + diff --git a/Master/tlpkg/tlperl/lib/Tk/Pane.pm b/Master/tlpkg/tlperl/lib/Tk/Pane.pm new file mode 100644 index 00000000000..36c5203a42d --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Pane.pm @@ -0,0 +1,544 @@ +# Tk::Pane.pm +# +# Copyright (c) 1997-1998 Graham Barr <gbarr@pobox.com>. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +package Tk::Pane; + +use vars qw($VERSION); +$VERSION = '4.007'; # $Id: //depot/Tkutf8/Tk/Pane.pm#7 $ + +use Tk; +use Tk::Widget; +use Tk::Derived; +use Tk::Frame; + +use strict; + +use base qw(Tk::Derived Tk::Frame); + +Construct Tk::Widget 'Pane'; + +use Tk::Submethods( + grid => [qw/bbox columnconfigure location propagate rowconfigure size slaves/], + pack => [qw/propagate slaves/] +); + +sub ClassInit { + my ($class,$mw) = @_; + $mw->bind($class,'<Configure>',['QueueLayout',4]); + $mw->bind($class,'<FocusIn>', 'NoOp'); + return $class; +} + +sub Populate { + my $pan = shift; + + my $frame = $pan->Component(Frame => "frame"); + + $pan->afterIdle(['Manage',$pan,$frame]); + $pan->afterIdle(['QueueLayout',$pan,1]); + + $pan->Delegates( + DEFAULT => $frame, + # FIXME + # These are a hack to avoid an existing bug in Tk::Widget::DelegateFor + # which has been reported and should be fixed in the next Tk release + see => $pan, + xview => $pan, + yview => $pan, + ); + + $pan->ConfigSpecs( + DEFAULT => [$frame], + -sticky => [PASSIVE => undef, undef, undef], + -gridded => [PASSIVE => undef, undef, undef], + -xscrollcommand => [CALLBACK => undef, undef, undef], + -yscrollcommand => [CALLBACK => undef, undef, undef], + ); + + + $pan; +} + + +sub grid { + my $w = shift; + $w = $w->Subwidget('frame') + if (@_ && $_[0] =~ /^(?: bbox + |columnconfigure + |location + |propagate + |rowconfigure + |size + |slaves)$/x); + $w->SUPER::grid(@_); +} + +sub slave { + my $w = shift; + $w->Subwidget('frame'); +} + +sub pack { + my $w = shift; + $w = $w->Subwidget('frame') + if (@_ && $_[0] =~ /^(?:propagate|slaves)$/x); + $w->SUPER::pack(@_); +} + +sub QueueLayout { + shift if ref $_[1]; + my($m,$why) = @_; + $m->afterIdle(['Layout',$m]) unless ($m->{LayoutPending}); + $m->{LayoutPending} |= $why; +} + +sub AdjustXY { + my($w,$Wref,$X,$st,$scrl,$getx) = @_; + my $W = $$Wref; + + if($w >= $W) { + my $v = 0; + if($getx) { + $v |= 1 if $st =~ /[Ww]/; + $v |= 2 if $st =~ /[Ee]/; + } + else { + $v |= 1 if $st =~ /[Nn]/; + $v |= 2 if $st =~ /[Ss]/; + } + + if($v == 0) { + $X = int(($w - $W) / 2); + } + elsif($v == 1) { + $X = 0; + } + elsif($v == 2) { + $X = int($w - $W); + } + else { + $X = 0; + $$Wref = $w; + } + $scrl->Call(0,1) + if $scrl; + } + elsif($scrl) { + $X = 0 + if $X > 0; + $X = $w - $W + if(($X + $W) < $w); + $scrl->Call(-$X / $W,(-$X + $w) / $W); + } + else { + $X = 0; + $$Wref = $w; + } + + return $X; +} + +sub Layout { + my $pan = shift; + my $why = $pan->{LayoutPending}; + + my $slv = $pan->Subwidget('frame'); + + return unless $slv; + + my $H = $slv->ReqHeight; + my $W = $slv->ReqWidth; + my $X = $slv->x; + my $Y = $slv->y; + my $w = $pan->width; + my $h = $pan->height; + my $yscrl = $pan->{Configure}{'-yscrollcommand'}; + my $xscrl = $pan->{Configure}{'-xscrollcommand'}; + + $yscrl = undef + if(defined($yscrl) && UNIVERSAL::isa($yscrl, 'SCALAR') && !defined($$yscrl)); + $xscrl = undef + if(defined($xscrl) && UNIVERSAL::isa($xscrl, 'SCALAR') && !defined($$xscrl)); + + if($why & 1) { + $h = $pan->{Configure}{'-height'} || 0 + unless($h > 1); + $w = $pan->{Configure}{'-width'} || 0 + unless($w > 1); + + $h = $H + unless($h > 1 || defined($yscrl)); + $w = $W + unless($w > 1 || defined($xscrl)); + + $w = 100 if $w <= 1; + $h = 100 if $h <= 1; + + $pan->GeometryRequest($w,$h); + } + + my $st = $pan->{Configure}{'-sticky'} || ''; + + $pan->{LayoutPending} = 0; + + $slv->MoveResizeWindow( + AdjustXY($w,\$W,$X,$st,$xscrl,1), + AdjustXY($h,\$H,$Y,$st,$yscrl,0), + $W,$H + ); +} + +sub SlaveGeometryRequest { + my ($m,$s) = @_; + $m->QueueLayout(1); +} + +sub LostSlave { + my($m,$s) = @_; + $m->{Slave} = undef; +} + +sub Manage { + my $m = shift; + my $s = shift; + + $m->{Slave} = $s; + $m->ManageGeometry($s); + $s->MapWindow; + $m->QueueLayout(2); +} + +sub xview { + my $pan = shift; + + unless(@_) { + my $scrl = $pan->{Configure}{'-xscrollcommand'}; + return (0,1) unless $scrl; + my $slv = $pan->Subwidget('frame'); + my $sw = $slv->ReqWidth; + my $ldx = $pan->rootx - $slv->rootx; + my $rdx = $ldx + $pan->width; + $ldx = $ldx <= 0 ? 0 : $ldx / $sw; + $rdx = $rdx >= $sw ? 1 : $rdx / $sw; + return( $ldx , $rdx); + } + elsif(@_ == 1) { + my $widget = shift; + my $slv = $pan->Subwidget('frame'); + xyview(1,$pan, + moveto => ($widget->rootx - $slv->rootx) / $slv->ReqWidth); + } + else { + xyview(1,$pan,@_); + } +} + +sub yview { + my $pan = shift; + + unless(@_) { + my $scrl = $pan->{Configure}{'-yscrollcommand'}; + return (0,1) unless $scrl; + my $slv = $pan->Subwidget('frame'); + my $sh = $slv->ReqHeight; + my $tdy = $pan->rooty - $slv->rooty; + my $bdy = $tdy + $pan->height; + $tdy = $tdy <= 0 ? 0 : $tdy / $sh; + $bdy = $bdy >= $sh ? 1 : $bdy / $sh; + return( $tdy, $bdy); + } + elsif(@_ == 1) { + my $widget = shift; + my $slv = $pan->Subwidget('frame'); + xyview(0,$pan, + moveto => ($widget->rooty - $slv->rooty) / $slv->ReqHeight); + } + else { + xyview(0,$pan,@_); + } +} + +sub xyview { + my($horz,$pan,$cmd,$val,$mul) = @_; + my $slv = $pan->Subwidget('frame'); + return unless $slv; + + my($XY,$WH,$wh,$scrl,@a); + + if($horz) { + $XY = $slv->x; + $WH = $slv->ReqWidth; + $wh = $pan->width; + $scrl = $pan->{Configure}{'-xscrollcommand'}; + } + else { + $XY = $slv->y; + $WH = $slv->ReqHeight; + $wh = $pan->height; + $scrl = $pan->{Configure}{'-yscrollcommand'}; + } + + $scrl = undef + if(UNIVERSAL::isa($scrl, 'SCALAR') && !defined($$scrl)); + + if($WH < $wh) { + $scrl->Call(0,1); + return; + } + + if($cmd eq 'scroll') { + my $dxy = 0; + + my $gridded = $pan->{Configure}{'-gridded'} || ''; + my $do_gridded = ($gridded eq 'both' + || (!$horz == ($gridded ne 'x'))) ? 1 : 0; + + if($do_gridded && $mul eq 'pages') { + my $ch = ($slv->children)[0]; + if(defined($ch) && $ch->manager eq 'grid') { + @a = $horz + ? (1-$XY,int($slv->width / 2)) + : (int($slv->height / 2),1-$XY); + my $rc = ($slv->gridLocation(@a))[$horz ? 0 : 1]; + my $mrc = ($slv->gridSize)[$horz ? 0 : 1]; + $rc += $val; + $rc = 0 if $rc < 0; + $rc = $mrc if $rc > $mrc; + my $gsl; + while($rc >= 0 && $rc < $mrc) { + $gsl = ($slv->gridSlaves(-row => $rc))[0]; + last + if defined $gsl; + $rc += $val; + } + if(defined $gsl) { + @a = $horz ? ($rc,0) : (0,$rc); + $XY = 0 - ($slv->gridBbox(@a))[$horz ? 0 : 1]; + } + else { + $XY = $val > 0 ? $wh - $WH : 0; + } + $dxy = $val; $val = 0; + } + } + $dxy = $mul eq 'pages' ? ($horz ? $pan->width : $pan->height) : 10 + unless $dxy; + $XY -= $dxy * $val; + } + elsif($cmd eq 'moveto') { + $XY = -int($WH * $val); + } + + $XY = $wh - $WH + if($XY < ($wh - $WH)); + $XY = 0 + if $XY > 0; + + @a = $horz + ? ( $XY, $slv->y) + : ($slv->x, $XY); + + $slv->MoveWindow(@a); + + $scrl->Call(-$XY / $WH,(-$XY + $wh) / $WH); +} + +sub see { + my $pan = shift; + my $widget = shift; + my %opt = @_; + my $slv = $pan->Subwidget('frame'); + + my $anchor = defined $opt{'-anchor'} ? $opt{'-anchor'} : ""; + + if($pan->{Configure}{'-yscrollcommand'}) { + my $yanchor = lc(($anchor =~ /([NnSs]?)/)[0] || ""); + my $pty = $pan->rooty; + my $ph = $pan->height; + my $pby = $pty + $ph; + my $ty = $widget->rooty; + my $wh = $widget->height; + my $by = $ty + $wh; + my $h = $slv->ReqHeight; + + if($yanchor eq 'n' || ($yanchor ne 's' && ($wh >= $h || $ty < $pty))) { + my $y = $ty - $slv->rooty; + $pan->yview(moveto => $y / $h); + } + elsif($yanchor eq 's' || $by > $pby) { + my $y = $by - $ph - $slv->rooty; + $pan->yview(moveto => $y / $h); + } + } + + if($pan->{Configure}{'-xscrollcommand'}) { + my $xanchor = lc(($anchor =~ /([WwEe]?)/)[0] || ""); + my $ptx = $pan->rootx; + my $pw = $pan->width; + my $pbx = $ptx + $pw; + my $tx = $widget->rootx; + my $ww = $widget->width; + my $bx = $tx + $ww; + my $w = $slv->ReqWidth; + + if($xanchor eq 'w' || ( $xanchor ne 'e' && ($ww >= $w || $tx < $ptx))) { + my $x = $tx - $slv->rootx; + $pan->xview(moveto => $x / $w); + } + elsif($xanchor eq 'e' || $bx > $pbx) { + my $x = $bx - $pw - $slv->rootx; + $pan->xview(moveto => $x / $w); + } + } +} + +1; + +__END__ + +=head1 NAME + +Tk::Pane - A window panner + +=for category Derived Widgets + +=head1 SYNOPSIS + + use Tk::Pane; + + $pane = $mw->Scrolled(Pane, Name => 'fred', + -scrollbars => 'soe', + -sticky => 'we', + -gridded => 'y' + ); + + $pane->Frame; + + $pane->pack; + +=head1 DESCRIPTION + +B<Tk::Pane> provides a scrollable frame widget. Once created it can be +treated as a frame, except it is scrollable. + +=head1 OPTIONS + +=over 4 + +=item B<-gridded> =E<gt> I<direction> + +Specifies if the top and left edges of the pane should snap to a +grid column. This option is only useful if the widgets in the pane +are managed by the I<grid> geometry manager. Possible values are +B<x>, B<y> and B<xy>. + +=item B<-sticky> =E<gt> I<style> + +If Pane is larger than its requested dimensions, this option may be used to +position (or stretch) the slave within its cavity. I<Style> is a string that +contains zero or more of the characters n, s, e or w. The string can optionally +contains spaces or commas, but they are ignored. Each letter refers to a side +(north, south, east, or west) that the slave will "stick" to. If both n and s +(or e and w) are specified, the slave will be stretched to fill the entire +height (or width) of its cavity. + +=back + +=head1 METHODS + +=over 4 + +=item I<$pane>-E<gt>B<see>(I<$widget> ?,I<options>?) + +Adjusts the view so that I<$widget> is visable. Aditional parameters in +I<options-value> pairs can be passed, each I<option-value> pair must be +one of the following + +=over 8 + +=item B<-anchor> =E<gt> I<anchor> + +Specifies how to make the widget visable. If not given then as much of +the widget as possible is made visable. + +Possible values are B<n>, B<s>, B<w>, B<e>, B<nw>, B<ne>, B<sw> and B<se>. +This will cause an edge on the widget to be aligned with the corresponding +edge on the pane. for example B<nw> will cause the top left of the widget +to be placed at the top left of the pane. B<s> will cause the bottom of the +widget to be placed at the bottom of the pane, and as much of the widget +as possible made visable in the x direction. + +=back + +=item I<$pane>-E<gt>B<xview> + +Returns a list containing two elements, both of which are real fractions +between 0 and 1. The first element gives the position of the left of the +window, relative to the Pane as a whole (0.5 means it is halfway through the +Pane, for example). The second element gives the position of the right of the +window, relative to the Pane as a whole. + +=item I<$pane>-E<gt>B<xview>(I<$widget>) + +Adjusts the view in the window so that I<widget> is displayed at the left of +the window. + +=item I<$pane>-E<gt>B<xview>(B<moveto> =E<gt> I<fraction>) + +Adjusts the view in the window so that I<fraction> of the total width of the +Pane is off-screen to the left. fraction must be a fraction between 0 and 1. + +=item I<$pane>-E<gt>B<xview>(B<scroll> =E<gt> I<number>, I<what>) + +This command shifts the view in the window left or right according to I<number> +and I<what>. I<Number> must be an integer. I<What> must be either B<units> or +B<pages> or an abbreviation of one of these. If I<what> is B<units>, the view +adjusts left or right by I<number>*10 screen units on the display; if it is +B<pages> then the view adjusts by number screenfuls. If number is negative then +widgets farther to the left become visible; if it is positive then widgets +farther to the right become visible. + +=item I<$pane>-E<gt>B<yview> + +Returns a list containing two elements, both of which are real fractions +between 0 and 1. The first element gives the position of the top of the +window, relative to the Pane as a whole (0.5 means it is halfway through the +Pane, for example). The second element gives the position of the bottom of the +window, relative to the Pane as a whole. + +=item I<$pane>-E<gt>B<yview>(I<$widget>) + +Adjusts the view in the window so that I<widget> is displayed at the top of the +window. + +=item I<$pane>-E<gt>B<yview>(B<moveto> =E<gt> I<fraction>) + +Adjusts the view in the window so that I<fraction> of the total width of the +Pane is off-screen to the top. fraction must be a fraction between 0 and 1. + +=item I<$pane>-E<gt>B<yview>(B<scroll> =E<gt> I<number>, I<what>) + +This command shifts the view in the window up or down according to I<number> +and I<what>. I<Number> must be an integer. I<What> must be either B<units> or +B<pages> or an abbreviation of one of these. If I<what> is B<units>, the view +adjusts up or down by I<number>*10 screen units on the display; if it is +B<pages> then the view adjusts by number screenfuls. If number is negative then +widgets farther up become visible; if it is positive then widgets farther down +become visible. + +=back + +=head1 AUTHOR + +Graham Barr E<lt>F<gbarr@pobox.com>E<gt> + +=head1 COPYRIGHT + +Copyright (c) 1997-1998 Graham Barr. All rights reserved. +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=cut diff --git a/Master/tlpkg/tlperl/lib/Tk/Panedwindow.pm b/Master/tlpkg/tlperl/lib/Tk/Panedwindow.pm new file mode 100644 index 00000000000..d984b648897 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Panedwindow.pm @@ -0,0 +1,221 @@ +package Tk::Panedwindow; +use strict; + +use vars qw/$VERSION/; +$VERSION = sprintf '4.%03d', q$Revision: #3 $ =~ /#(\d+)/; + +# A Panedwindow widget (similar to Adjuster). + +use Tk qw/Ev/; +use base qw/Tk::Widget/; + +Construct Tk::Widget 'Panedwindow'; + +sub Tk_cmd { \&Tk::panedwindow } + +Tk::Methods('add', 'forget', 'identify', 'proxy', 'sash', 'panes'); + +use Tk::Submethods ( + 'proxy' => [qw/coord forget place/], + 'sash' => [qw/coord mark place/], +); + +sub ClassInit { + + my ($class,$mw) = @_; + + $class->SUPER::ClassInit($mw); + + $mw->bind($class, '<Button-1>' => ['MarkSash' => Ev('x'), Ev('y'), 1]); + $mw->bind($class, '<Button-2>' => ['MarkSash' => Ev('x'), Ev('y'), 0]); + $mw->bind($class, '<B1-Motion>' => ['DragSash' => Ev('x'), Ev('y'), 1]); + $mw->bind($class, '<B2-Motion>' => ['DragSash' => Ev('x'), Ev('y'), 0]); + $mw->bind($class, '<ButtonRelease-1>' => ['ReleaseSash' => 1]); + $mw->bind($class, '<ButtonRelease-2>' => ['ReleaseSash' => 0]); + $mw->bind($class, '<Motion>' => ['Motion' => Ev('x'), Ev('y')]); + $mw->bind($class, '<Leave>' => ['Leave']); + + return $class; + +} # end ClassInit + +sub MarkSash { + + # MarkSash + # + # Handle marking the correct sash for possible dragging + # + # Arguments: + # w the widget + # x widget local x coord + # y widget local y coord + # proxy whether this should be a proxy sash + # Results: + # None + + my ($w, $x, $y, $proxy) = @_; + + my @what = $w->identify($x, $y); + if ( @what == 2 ) { + my ($index, $which) = @what[0 .. 1]; + if (not $Tk::strictMotif or $which eq 'handle') { + $w->sashMark($index, $x, $y) if not $proxy; + $w->{_sash} = $index; + my ($sx, $sy) = $w->sashCoord($index); + $w->{_dx} = $sx - $x; + $w->{_dy} = $sy - $y; + } + } + +} # end MarkSash + +sub DragSash { + + # DragSash + # + # Handle dragging of the correct sash + # + # Arguments: + # w the widget + # x widget local x coord + # y widget local y coord + # proxy whether this should be a proxy sash + # Results: + # Moves sash + + my ($w, $x, $y, $proxy) = @_; + + if ( exists $w->{_sash} ) { + if ($proxy) { + $w->proxyPlace($x + $w->{_dx}, $y + $w->{_dy}); + } else { + $w->sashPlace($w->{_sash}, $x + $w->{_dx}, $y + $w->{_dy}); + } + } + +} # end DragSash + +sub ReleaseSash { + + # ReleaseSash + # + # Handle releasing of the sash + # + # Arguments: + # w the widget + # proxy whether this should be a proxy sash + # Results: + # Returns ... + + my ($w, $proxy) = @_; + + if ( exists $w->{_sash} ) { + if ($proxy) { + my ($x, $y) = $w->proxyCoord; + $w->sashPlace($w->{_sash}, $x, $y); + $w->proxyForget; + } + delete $w->{'_sash', '_dx', '_dy'}; + } + +} # end ReleaseSash + +sub Motion { + + # Motion + # + # Handle motion on the widget. This is used to change the cursor + # when the user moves over the sash area. + # + # Arguments: + # w the widget + # x widget local x coord + # y widget local y coord + # Results: + # May change the cursor. Sets up a timer to verify that we are still + # over the widget. + + my ($w, $x, $y) = @_; + + my @id = $w->identify($x, $y); + if ( (@id == 2) and + (not $Tk::strictMotif or $id[1] eq 'handle') ) { + if ( not exists $w->{_panecursor} ) { + $w->{_panecursor} = $w->cget(-cursor); + if ( not defined $w->cget(-sashcursor) ) { + if ( $w->cget(-orient) eq 'horizontal' ) { + $w->configure(-cursor => 'sb_h_double_arrow'); + } else { + $w->configure(-cursor => 'sb_v_double_arrow'); + } + } else { + $w->configure(-cursor => $w->cget(-sashcursor)); + } + if ( exists $w->{_pwAfterId} ) { + $w->afterCancel($w->{_pwAfterId}); + } + $w->{_pwAfterId} = $w->after(150 => ['Cursor' => $w]); + } + return + } + if ( exists $w->{_panecursor} ) { + $w->configure(-cursor => $w->{_panecursor}); + delete $w->{_panecursor}; + } + +} # end Motion + +sub Cursor { + + # Cursor + # + # Handles returning the normal cursor when we are no longer over the + # sash area. This needs to be done this way, because the panedwindow + # won't see Leave events when the mouse moves from the sash to a + # paned child, although the child does receive an Enter event. + # + # Arguments: + # w the widget + # Results: + # May restore the default cursor, or schedule a timer to do it. + + my ($w) = @_; + + if ( exists $w->{_panecursor} ) { + if ( $w->containing($w->pointerx, $w->pointery) == $w ) { + $w->{_pwAfterId} = $w->after(150 => ['Cursor' => $w]); + } else { + $w->configure(-cursor => $w->{_panecursor}); + delete $w->{_panecursor}; + if ( exists $w->{_pwAfterId} ) { + $w->afterCancel($w->{_pwAfterId}); + delete $w->{_pwAfterId}; + } + } + } + +} # end Cursor + +sub Leave { + + # Leave + # + # Return to default cursor when leaving the pw widget. + # + # Arguments: + # w the widget + # Results: + # Restores the default cursor + + my ($w) = @_; + + if ( exists $w->{_panecursor} ) { + $w->configure(-cursor => $w->{_panecursor}); + delete $w->{_panecursor}; + } + +} # end Leave + + +1; +__END__ diff --git a/Master/tlpkg/tlperl/lib/Tk/Photo.pm b/Master/tlpkg/tlperl/lib/Tk/Photo.pm new file mode 100644 index 00000000000..a596dc4d78b --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Photo.pm @@ -0,0 +1,22 @@ +package Tk::Photo; + +use vars qw($VERSION); +$VERSION = sprintf '4.%03d', 4+q$Revision: #4 $ =~ /\D(\d+)\s*$/; + +use Tk qw($XS_VERSION); + +use base qw(Tk::Image); + +Construct Tk::Image 'Photo'; + +sub Tk_image { 'photo' } + +Tk::Methods('blank','copy','data','formats','get','put','read', + 'redither','transparency','write'); + +use Tk::Submethods ( + 'transparency' => [qw/get set/], +); + +1; +__END__ diff --git a/Master/tlpkg/tlperl/lib/Tk/Pixmap.pm b/Master/tlpkg/tlperl/lib/Tk/Pixmap.pm new file mode 100644 index 00000000000..3fbc3179b56 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Pixmap.pm @@ -0,0 +1,19 @@ +package Tk::Pixmap; + +use vars qw($VERSION); +$VERSION = '4.004'; # $Id: //depot/Tkutf8/TixPixmap/Pixmap.pm#4 $ + +use Tk qw($XS_VERSION); + +use Tk::Image (); + +use base qw(Tk::Image); + +Construct Tk::Image 'Pixmap'; + +bootstrap Tk::Pixmap; + +sub Tk_image { 'pixmap' } + +1; + diff --git a/Master/tlpkg/tlperl/lib/Tk/Pretty.pm b/Master/tlpkg/tlperl/lib/Tk/Pretty.pm new file mode 100644 index 00000000000..7e442a4bcbc --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Pretty.pm @@ -0,0 +1,93 @@ +# Copyright (c) 1995-2003 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. +package Tk::Pretty; +require Exporter; + +use vars qw($VERSION @EXPORT); +$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Pretty.pm#6 $ + +use base qw(Exporter); + +@EXPORT = qw(Pretty PrintArgs); + +sub pretty_list +{ + join(',',map(&Pretty($_),@_)); +} + +sub Pretty +{ + return pretty_list(@_) if (@_ > 1); + my $obj = shift; + return 'undef' unless defined($obj); + my $type = "$obj"; + return $type if ($type =~ /=HASH/ && exists($obj->{"_Tcl_CmdInfo_\0"})); + my $result = ''; + if (ref $obj) + { + my $class; + if ($type =~ /^([^=]+)=(.*)$/) + { + $class = $1; + $type = $2; + $result .= 'bless('; + } + if ($type =~ /^ARRAY/) + { + $result .= '['; + $result .= pretty_list(@$obj); + $result .= ']'; + } + elsif ($type =~ /^HASH/) + { + $result .= '{'; + if (%$obj) + { + my ($key, $value); + while (($key,$value) = each %$obj) + { + $result .= $key . '=>' . Pretty($value) . ','; + } + chop($result); + } + $result .= '}'; + } + elsif ($type =~ /^REF/) + { + $result .= "\\" . Pretty($$obj); + } + elsif ($type =~ /^SCALAR/) + { + $result .= Pretty($$obj); + } + else + { + $result .= $type; + } + $result .= ",$class)" if (defined $class); + } + else + { + if ($obj =~ /^-?[0-9]+(.[0-9]*(e[+-][0-9]+)?)?$/ || + $obj =~ /^[A-Z_][A-Za-z_0-9]*$/ || + $obj =~ /^[a-z_][A-Za-z_0-9]*[A-Z_][A-Za-z_0-9]*$/ + ) + { + $result .= $obj; + } + else + { + $result .= "'" . $obj . "'"; + } + } + return $result; +} + +sub PrintArgs +{ + my $name = (caller(1))[3]; + print "$name(",Pretty(@_),")\n"; +} + +1; diff --git a/Master/tlpkg/tlperl/lib/Tk/ProgressBar.pm b/Master/tlpkg/tlperl/lib/Tk/ProgressBar.pm new file mode 100644 index 00000000000..206d843ea13 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/ProgressBar.pm @@ -0,0 +1,498 @@ +package Tk::ProgressBar; + +use vars qw($VERSION); +$VERSION = sprintf '4.%03d', q$Revision: #10 $ =~ /\D(\d+)\s*$/; + +use Tk; +use Tk::Canvas; +use Tk::Trace; +use Carp; +use strict; + +use base qw(Tk::Derived Tk::Canvas); + +Construct Tk::Widget 'ProgressBar'; + +sub ClassInit { + my ($class,$mw) = @_; + + $class->SUPER::ClassInit($mw); + + $mw->bind($class,'<Configure>', ['_layoutRequest',1]); +} + + +sub Populate { + my($c,$args) = @_; + + $c->ConfigSpecs( + -width => [PASSIVE => undef, undef, 0], + '-length' => [PASSIVE => undef, undef, 0], + -from => [PASSIVE => undef, undef, 0], + -to => [PASSIVE => undef, undef, 100], + -blocks => [PASSIVE => undef, undef, 10], + -padx => [PASSIVE => 'padX', 'Pad', 0], + -pady => [PASSIVE => 'padY', 'Pad', 0], + -gap => [PASSIVE => undef, undef, 1], + -colors => [PASSIVE => undef, undef, undef], + -relief => [SELF => 'relief', 'Relief', 'sunken'], + -value => [METHOD => undef, undef, undef], + -variable => [METHOD => undef, undef, undef], + -anchor => [METHOD => 'anchor', 'Anchor', 'w'], + -resolution + => [PASSIVE => undef, undef, 1.0], + -highlightthickness + => [SELF => 'highlightThickness','HighlightThickness',0], + -troughcolor + => [PASSIVE => 'troughColor', 'Background', 'grey55'], + ); + _layoutRequest($c,1); + $c->OnDestroy(['Destroyed' => $c]); +} + +sub anchor { + my $c = shift; + my $var = \$c->{Configure}{'-anchor'}; + my $old = $$var; + + if(@_) { + my $new = shift; + croak "bad anchor position \"$new\": must be n, s, w or e" + unless $new =~ /^[news]$/; + $$var = $new; + } + + $old; +} + +sub _layoutRequest { + my $c = shift; + my $why = shift; + $c->afterIdle(['_arrange',$c]) unless $c->{'layout_pending'}; + $c->{'layout_pending'} |= $why; +} + +sub _arrange { + my $c = shift; + my $why = $c->{'layout_pending'}; + + $c->{'layout_pending'} = 0; + + my $w = $c->Width; + my $h = $c->Height; + my $bw = $c->cget('-borderwidth') + $c->cget('-highlightthickness'); + my $x = abs(int($c->{Configure}{'-padx'})) + $bw; + my $y = abs(int($c->{Configure}{'-pady'})) + $bw; + my $value = $c->value; + my $from = $c->{Configure}{'-from'}; + my $to = $c->{Configure}{'-to'}; + my $horz = $c->{Configure}{'-anchor'} =~ /[ew]/i ? 1 : 0; + my $dir = $c->{Configure}{'-anchor'} =~ /[se]/i ? -1 : 1; + + my($minv,$maxv) = $from < $to ? ($from,$to) : ($to,$from); + + if($w == 1 && $h == 1) { + my $bw = $c->cget('-borderwidth'); + my $defw = 10 + $y*2 + $bw *2; + my $defl = ($maxv - $minv) + $x*2 + $bw*2; + + $h = $c->pixels($c->{Configure}{'-length'}) || $defl; + $w = $c->pixels($c->{Configure}{'-width'}) || $defw; + + ($w,$h) = ($h,$w) if $horz; + $c->GeometryRequest($w,$h); + $c->parent->update; + $c->update; + + $w = $c->Width; + $h = $c->Height; + } + + $w -= $x*2; + $h -= $y*2; + + my $length = $horz ? $w : $h; + my $width = $horz ? $h : $w; + + my $blocks = int($c->{Configure}{'-blocks'}); + my $gap = int($c->{Configure}{'-gap'}); + + $blocks = 1 if $blocks < 1; + + my $gwidth = $gap * ( $blocks - 1); + my $bwidth = ($length - $gwidth) / $blocks; + + if($bwidth < 3 || $blocks <= 1 || $gap <= 0) { + $blocks = 1; + $bwidth = $length; + $gap = 0; + } + + if($why & 1) { + my $colors = $c->{Configure}{'-colors'} || []; + my $bdir = $from < $to ? $dir : 0 - $dir; + + $c->delete($c->find('all')); + + $c->createRectangle(0,0,$w+$x*2,$h+$y*2, + -fill => $c->{Configure}{'-troughcolor'}, + -width => 0, + -outline => undef); + + $c->{'cover'} = $c->createRectangle($x,$y,$w,$h, + -fill => $c->{Configure}{'-troughcolor'}, + -width => 0, + -outline => undef); + + my($x0,$y0,$x1,$y1); + + if($horz) { + if($bdir > 0) { + ($x0,$y0) = ($x - $gap,$y); + } + else { + ($x0,$y0) = ($length + $x + $gap,$y); + } + ($x1,$y1) = ($x0,$y0 + $width); + } + else { + if($bdir > 0) { + ($x0,$y0) = ($x,$y - $gap); + } + else { + ($x0,$y0) = ($x,$length + $y + $gap); + } + ($x1,$y1) = ($x0 + $width,$y0); + } + + my $blks = $blocks; + my $dval = ($maxv - $minv) / $blocks; + my $color = $c->cget('-foreground'); + my $pos = 0; + my $val = $minv; + + while($val < $maxv) { + my($bw,$nval); + + while(($pos < @$colors) && $colors->[$pos] <= $val) { + $color = $colors->[$pos+1]; + $pos += 2; + } + + if($blocks == 1) { + $nval = defined($colors->[$pos]) + ? $colors->[$pos] : $maxv; + $bw = (($nval - $val) / ($maxv - $minv)) * $length; + } + else { + $bw = $bwidth; + $nval = $val + $dval if($blocks > 1); + } + + if($horz) { + if($bdir > 0) { + $x0 = $x1 + $gap; + $x1 = $x0 + $bw; + } + else { + $x1 = $x0 - $gap; + $x0 = $x1 - $bw; + } + } + else { + if($bdir > 0) { + $y0 = $y1 + $gap; + $y1 = $y0 + $bw; + } + else { + $y1 = $y0 - $gap; + $y0 = $y1 - $bw; + } + } + + $c->createRectangle($x0,$y0,$x1,$y1, + -fill => $color, + -width => 0, + -outline => undef + ); + $val = $nval; + } + } + + my $cover = $c->{'cover'}; + my $ddir = $from > $to ? 1 : -1; + + if(($value <=> $to) == (0-$ddir)) { + $c->lower($cover); + } + elsif(($value <=> $from) == $ddir) { + $c->raise($cover); + my $x1 = $horz ? $x + $length : $x + $width; + my $y1 = $horz ? $y + $width : $y + $length; + $c->coords($cover,$x,$y,$x1,$y1); + } + else { + my $step; + $value = int($value / $step) * $step + if(defined($step = $c->{Configure}{'-resolution'}) && $step > 0); + + $maxv = $minv+1 + if $minv == $maxv; + + my $range = $maxv - $minv; + my $bval = $range / $blocks; + my $offset = abs($value - $from); + my $ioff = int($offset / $bval); + my $start = $ioff * ($bwidth + $gap); + $start += ($offset - ($ioff * $bval)) / $bval * $bwidth; + + my($x0,$x1,$y0,$y1); + + if($horz) { + $y0 = $y; + $y1 = $y + $h; + if($dir > 0) { + $x0 = $x + $start; + $x1 = $x + $w; + } + else { + $x0 = $x; + $x1 = $w + $x - $start; + } + } + else { + $x0 = $x; + $x1 = $x + $w; + if($dir > 0) { + $y0 = $y + $start; + $y1 = $y + $h; + } + else { + $y0 = $y; + $y1 = $h + $y - $start; + } + } + + + $c->raise($cover); + $c->coords($cover,$x0,$y0,$x1,$y1); + } +} + +sub value { + my $c = shift; + my $val = defined($c->{'-variable'}) + ? $c->{'-variable'} + : \$c->{'-value'}; + my $old = defined($$val) ? $$val : $c->{Configure}{'-from'}; + + if(@_) { + my $value = shift; + $$val = defined($value) ? $value : $c->{Configure}{'-from'}; + _layoutRequest($c,2); + } + + $old; +} + +sub variable { + my $c = shift; + my $oldvarref = $c->{'-variable'}; + my $oldval = $$oldvarref if $oldvarref; + if(@_) { + my $varref = shift; + if ($oldvarref) + { + $c->traceVdelete($oldvarref); + } + $c->{'-variable'} = $varref; + $c->traceVariable($varref, 'w', sub { $c->value($_[1]) }); + $$varref = $oldval; + _layoutRequest($c,2); + } + $oldval; +} + +sub Destroyed +{ + my $c = shift; + my $var = delete $c->{'-variable'}; + $c->traceVdelete($var); +} + +1; +__END__ + +=head1 NAME + +Tk::ProgressBar - A graphical progress bar + +=for category Derived Widgets + +=head1 SYNOPSIS + + use Tk::ProgressBar; + + $progress = $parent->ProgressBar( + -width => 200, + -length => 20, + -anchor => 's', + -from => 0, + -to => 100, + -blocks => 10, + -colors => [0, 'green', 50, 'yellow' , 80, 'red'], + -variable => \$percent_done + ); + + $progress->value($position); + +=head1 DESCRIPTION + +B<Tk::ProgressBar> provides a widget which will show a graphical representation +of a value, given maximum and minimum reference values. + +=head1 STANDARD OPTIONS + +The following standard widget options are supported: + +=over 4 + +=item B<-borderwidth> + +=item B<-highlightthickness> + +Defaults to 0. + +=item B<-padx> + +Defaults to 0. + +=item B<-pady> + +Defaults to 0. + +=item B<-relief> + +Defaults to C<sunken> + +=item B<-troughcolor> + +The color to be used for the background (trough) of the progress bar. +Default is to use grey55. + +=back + +=head1 WIDGET-SPECIFIC OPTIONS + +=over 4 + +=item B<-anchor> + +This can be used to position the start point of the bar. Default +is 'w' (horizontal bar starting from the left). A vertical bar can be +configured by using either 's' or 'n'. + +=item B<-blocks> + +This controls the number of blocks to be used to construct the progress +bar. The default is to break the bar into 10 blocks. + +=item B<-colors> + +Controls the colors to be used for different positions of the progress bar. +The colors should be supplied as a reference to an array containing pairs +of positions and colors. + + -colors => [ 0, 'green', 50, 'red' ] + +means that for the range 0 to 50 the progress bar should be green +and for higher values it should be red. + + +=item B<-from> + +This sets the lower limit of the progress bar. If the bar is set to a +value below the lower limt no bar will be displayed. Defaults to 0. +See the C<-to> description for more information. + +=item B<-gap> + +This is the spacing (in pixels) between each block. Defaults to 1. +Use 0 to get a continuous bar. + + +=item B<-length> + +Specifies the desired long dimension of the ProgressBar in screen +units (i.e. any of the forms acceptable to Tk_GetPixels). For vertical +ProgressBars this is the ProgressBars height; for horizontal scales it +is the ProgressBars width. The default length is calculated from the +values of C<-padx>, C<-borderwidth>, C<-highlightthickness> and the +difference between C<-from> and C<-to>. + + +=item B<-resolution> + +A real value specifying the resolution for the scale. If this value is greater +than zero then the scale's value will always be rounded to an even multiple of +this value, as will tick marks and the endpoints of the scale. If the value is +less than zero then no rounding occurs. Defaults to 1 (i.e., the value will be +integral). + +=item B<-to> + +This sets the upper limit of the progress bar. If a value is specified +(for example, using the C<value> method) that lies above this value the +full progress bar will be displayed. Defaults to 100. + + + +=item B<-variable> + +Specifies the reference to a scalar variable to link to the ProgressBar. +Whenever the value of the variable changes, the ProgressBar will upate +to reflect this value. (See also the B<value> method below.) + +=item B<-value> + +The can be used to set the current position of the progress bar +when used in conjunction with the standard C<configure>. It is +usually recommended to use the B<value> method instead. + + +=item B<-width> + +Specifies the desired narrow dimension of the ProgressBar in screen +units (i.e. any of the forms acceptable to Tk_GetPixels). For +vertical ProgressBars this is the ProgressBars width; for horizontal +bars this is the ProgressBars height. The default width is derived +from the values of C<-borderwidth> and C<-pady> and C<-highlightthickness>. + +=back + +=head1 WIDGET METHODS + +=over 4 + +=item I<$ProgressBar>-E<gt>B<value>(?I<value>?) + +If I<value> is omitted, returns the current value of the ProgressBar. If +I<value> is given, the value of the ProgressBar is set. If I<$value> is +given but undefined the value of the option B<-from> is used. + +=back + + +=head1 AUTHOR + +Graham Barr E<lt>F<gbarr@pobox.com>E<gt> + +=head1 COPYRIGHT + +Copyright (c) 1997-1998 Graham Barr. All rights reserved. +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=cut + + diff --git a/Master/tlpkg/tlperl/lib/Tk/README.Adjust b/Master/tlpkg/tlperl/lib/Tk/README.Adjust new file mode 100644 index 00000000000..8c3eba45717 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/README.Adjust @@ -0,0 +1,77 @@ +Subject: Adjuster +Date: Wed, 16 Dec 1998 22:23:23 +0100 +From: Stephen Kun <stephen.kun@is.gaertner.de> +To: Nick Ing-Simmons <nick@ni-s.u-net.com> + + + + +3. How do I find out whether slave is a pack or grid master or if it is not a +master (for setting packPropagate(0)) +Currently I set both on the slave. + +4. In setting position of drag bar, I do a lot of calcs for each motion event. +Some could be done one for first, then used again for subsequent calls, eg: +borderwidth of master, etc. +I've now partially done this and store them on the widget. + +5. Do I need XSync and idletasks calls in Adjuster.pm? +XSync causes a bug. idletasks doesn't make any difference in practice, from +what I can see. I've commented both out. +Bug when using XSync: + Run pack_adj_4r + Shorten whole window from right so that left window edge crosses leftmost + adjuster. Buttons on other adjusters disappear + +6. Sometimes the effect given by the Restore method, is undesirable. Eg. +for multi-columns. Then when you expand say the 1st column, the size of the +col at the end gets reduced to 0 width when the Adjuster forces itself in. +Then when you reduce the size of the first column again, the end col is still +0 width. +Better would be: +a) put the restore functionality on a flag OR +b) when a col is reduced because of a Restore, it saves previous width of +its slave, and attempts to restore it when the space becomes availabe. (Sounds +impracticable.) +I've implemented a) with default ON. In the documentation I'll recommend the +default for the 1st Adjuster, then OFF for the remaining. + +8. What about a packAdjustForget? Given that Adjuster doesn't work well for +grid anyway, and doesn't consider other managers, that wouldn't be too bad. +I'm not going to do this, but someone mentioned it a while ago. I can +see me probably wanting it too at some point. +Are you for the idea? + +10. Grid doesn't work well with Adjuster, didn't before either. I think +this has to do with grid, rather than adjuster. You get the same effect +if you grid a row of widgets, then reduce the width of the window. +Bugs demonstrated by grid_adj_4l: +a) there's never an Unmap event for the adjuster. +b) after adjusting, widgets protrude into border on right. +c) grid('Propagate', 0) on MainWindow has no effect - window shrinks/grows + when widgets are adjusted +d) widgets shuffle to correct position on startup +I don't recommend use of grid with Adjust! + +11. Have taken out __END__ temporarily for testing +Will put it back before publishing on the mailing list. + +12. Why do the adjusters in my testcases come out grey? That's not the +default background. + +13. Could packAdjust return ($adj, $w). Could then do: + my $canv = $top->Canvas()->packAdjust(); +OR + my ($adj, $canv) = $top->Canvas()->packAdjust(); +Latter is good if you want to configure or unpack adjuster later. +I realise this is very Kludgy, but there's no other way to get the +Adjuster from packAdjust. +I suppose the workaround of creating the Adjuster yourself is OK. When +you do it by hand though, there's more chance of making mistakes, eg +forgetting the -side (which defaults then to 'top') which would cause havoc. +What's your opinion. + +14. Run the script adj_button_bug: You can't reduce size of button. +Button can be expanded, but as soon as focus enters button, it springs back +to its original size. Why? +It's not important though. diff --git a/Master/tlpkg/tlperl/lib/Tk/ROText.pm b/Master/tlpkg/tlperl/lib/Tk/ROText.pm new file mode 100644 index 00000000000..cc5634f5475 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/ROText.pm @@ -0,0 +1,43 @@ +# Copyright (c) 1995-2003 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. +package Tk::ROText; + +use vars qw($VERSION); +$VERSION = sprintf '4.%03d', q$Revision: #10 $ =~ /\D(\d+)\s*$/; + +use Tk::Text; +use base qw(Tk::Derived Tk::Text); + +Construct Tk::Widget 'ROText'; + +sub clipEvents +{ + return qw[Copy]; +} + +sub ClassInit +{ + my ($class,$mw) = @_; + my $val = $class->bindRdOnly($mw); + my $cb = $mw->bind($class,'<Next>'); + $mw->bind($class,'<space>',$cb) if (defined $cb); + $cb = $mw->bind($class,'<Prior>'); + $mw->bind($class,'<BackSpace>',$cb) if (defined $cb); + $class->clipboardOperations($mw,'Copy'); + return $val; +} + +sub Populate { + my($self,$args) = @_; + $self->SUPER::Populate($args); + my $m = $self->menu->entrycget($self->menu->index('Search'), '-menu'); + $m->delete($m->index('Replace')); +} + +sub Tk::Widget::ScrlROText { shift->Scrolled('ROText' => @_) } + +1; + +__END__ + diff --git a/Master/tlpkg/tlperl/lib/Tk/Radiobutton.pm b/Master/tlpkg/tlperl/lib/Tk/Radiobutton.pm new file mode 100644 index 00000000000..d09d41b4208 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Radiobutton.pm @@ -0,0 +1,45 @@ +# Conversion from Tk4.0 button.tcl competed. +# Copyright (c) 1992-1994 The Regents of the University of California. +# Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved. +# This program is free software; you can redistribute it and/or + +package Tk::Radiobutton; + +use vars qw($VERSION); +$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Radiobutton.pm#6 $ + +# modify it under the same terms as Perl itself, subject +# to additional disclaimer in license.terms due to partial +# derivation from Tk4.0 sources. + +require Tk::Button; + + +use base qw(Tk::Button); +Construct Tk::Widget 'Radiobutton'; + +sub Tk_cmd { \&Tk::radiobutton } + +sub CreateOptions +{ + return (shift->SUPER::CreateOptions,'-variable'); +} + +sub ClassInit +{ + my ($class,$mw) = @_; + $mw->bind($class,'<Enter>', 'Enter'); + $mw->bind($class,'<Leave>', 'Leave'); + $mw->bind($class,'<1>', 'Invoke'); + $mw->bind($class,'<space>', 'Invoke'); + return $class; +} + +sub Invoke +{ + my $w = shift; + $w->invoke() unless($w->cget('-state') eq 'disabled'); +} + +1; diff --git a/Master/tlpkg/tlperl/lib/Tk/Region.pm b/Master/tlpkg/tlperl/lib/Tk/Region.pm new file mode 100644 index 00000000000..3e02bd2ff49 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Region.pm @@ -0,0 +1,182 @@ +package Tk::Region; + +# Ideas in progress do not document ... + +use strict; + +use vars qw($VERSION); +$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Region.pm#6 $ + +use Tk::Widget (); + +Construct Tk::Widget 'Region'; + +my %index = (-widget => 1, '-x' => 2, '-y' => 3, -width => 4, -height => 5); + +sub _attr +{ + my ($obj,$key,$val) = @_; + if (@_ > 2) + { + $obj->{$key} = $val; + } + return $obj->{$key} +} + +foreach my $name (qw(widget x y width height)) + { + my $key = "-$name"; + no strict 'refs'; + *{$name} = sub { shift->_attr($key,@_) }; + } + +sub new +{ + my $class = shift; + my $widget = shift; + my $obj = bless [\%index,$widget,0,0,0,0],$class; + $obj->configure(@_); +} + +sub cfgDefault +{ + my ($class,$key) = @_; + return undef; +} + +sub cfgName +{ + my ($class,$key) = @_; + $key =~ s/^-//; + return lcfirst($key); +} + +sub cfgClass +{ + return ucfirst(shift->cfgName(@_)); +} + +sub configure +{ + my $obj = shift; + my @results; + if (@_ > 1) + { + while (@_) + { + my $key = shift; + my $val = shift; + if (exists $obj->{$key}) + { + $obj->{$key} = $val; + } + else + { + my ($meth) = $key =~ /^-(\w+)$/; + croak("Invalid option $key") unless $obj->can($meth); + $obj->$meth($val); + } + } + } + elsif (@_ == 1) + { + my $key = shift; + my $value = $obj->cget($key); + push(@results,$key,$obj->cfgName($key),$obj->cfgClass($key),$obj->cfgDefault($key),$value); + } + else + { + foreach my $key (sort keys %$obj) + { + push(@results,scalar($obj->configure($key))) + } + } + return wantarray ? @results : \@results; +} + +sub cget +{ + my $obj = shift; + my $key = shift; + return $obj->{$key} if exists $obj->{$key}; + my ($meth) = $key =~ /^-(\w+)$/; + croak("Invalid option $key") unless $obj->can($meth); + return $obj->$meth(); +} + +sub bbox +{ + my $obj = shift; + my @results; + if (@_) + { + my $ref = (@_ == 1) ? shift : \@_; + my ($x1,$y1,$x2,$y2) = (ref $ref) ? @$ref : split(/\s+/,$ref); + ($x2,$x1) = ($x1,$x2) if ($x2 < $x1); + ($y2,$y1) = ($y1,$y2) if ($y2 < $y1); + $obj->width($x2-$x1); + $obj->height($y2-$y1); + $obj->x($x1); + $obj->y($y1); + } + else + { + my $x = $obj->x; + my $y = $obj->x; + push(@results,$x,$y,$x+$obj->width,$y+$obj->height); + } + return wantarray ? @results : \@results; +} + +sub rootx +{ + my $obj = shift; + if (@_) + { + my $x = shift; + $obj->x($x-$obj->widget->rootx); + } + return $obj->widget->rootx + $obj->{'-x'} +} + +sub rooty +{ + my $obj = shift; + if (@_) + { + my $y = shift; + $obj->y($y-$obj->widget->rootx); + } + return $obj->widget->rooty + $obj->{'-y'} +} + +sub rootxy +{ + my $obj = shift; + if (@_) + { + $obj->rootx(shift); + $obj->rooty(shift); + } + my @results = ($obj->rootx,$obj->rooty); + return wantarray ? @results : \@results; +} + +sub rootbbox +{ + my $obj = shift; + my ($x1,$y1) = $obj->rootxy; + my $x2 = $x1+$obj->width; + my $y2 = $y1+$obj->height; + my @results = ($x1,$y1,$x2,$y2); + return wantarray ? @results : \@results; +} + + +*Width = \&width; +*Height = \&height; +*X = \&rootx; +*Y = \&rooty; + +1; +__END__ diff --git a/Master/tlpkg/tlperl/lib/Tk/Reindex.pm b/Master/tlpkg/tlperl/lib/Tk/Reindex.pm new file mode 100644 index 00000000000..05e8e1fc1fc --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Reindex.pm @@ -0,0 +1,225 @@ +package Tk::Reindex; + + +use vars qw($VERSION); +$VERSION = '4.004'; # $Id: //depot/Tkutf8/TextList/Reindex.pm#4 $ + +use Tk; +use base qw(Tk::Derived); + + +sub Populate +{ + my ($w, $args) = @_; + + $w->_callbase('Populate',$args); + + $w->ConfigSpecs(-linestart => ["PASSIVE", "lineStart", "LineStart", 0], + -toindexcmd => ["CALLBACK", "toIndexCmd", "ToIndexCmd" , [\&to_index,$w]], + -fromindexcmd => ["CALLBACK", "fromIndexCmd","FromIndexCmd", [\&from_index,$w]]); +} + +sub import +{ + my($module,$base)=@_; + my $pkg=(caller)[0]; + + no strict 'refs'; + *{"${pkg}::_reindexbase"}=sub{$base}; +} + +sub _callbase +{ + my($w,$sub)=(shift,shift); + my $supersub=$w->_reindexbase()."::$sub"; + $w->$supersub(@_); +} + +BEGIN +{ + # list of subroutines and index argument number (-1 as first element means return value) + my %subs=('bbox' => [0], + 'compare' => [0,2], + 'delete' => [0,1], + 'dlineinfo' => [0], + 'dump' => \&_find_dump_index, + 'get' => [0,1], + 'index' => [-1,0], + 'insert' => [0], + 'mark' => \&_find_mark_index, + 'search' => \&_find_search_index, + 'see' => [0], + 'tag' => \&_find_tag_index, + 'window' => [1], + 'image' => [1], + ); + + foreach my $sub (keys %subs) + { + my $args=$subs{$sub}; + my $argsub=ref $args eq 'CODE'?$args:sub{$args}; + my $newsub=sub + { + my($w)=shift; + my(@iargs)=grep($_<=$#_,@{$argsub->(@_)}); + my $iret=shift @iargs if @iargs && $iargs[0]==-1; + my(@args)=@_; + @args[@iargs]=$w->Callback(-toindexcmd,@args[@iargs]); + my(@ret)=$w->_callbase($sub,@args); + @ret=$w->Callback(-fromindexcmd,@ret) if $iret; + wantarray?@ret:$ret[0]; + }; + no strict 'refs'; + *{$sub}=$newsub; + } +} + +sub to_index +{ + my $w=shift; + my $offset=$w->cget(-linestart)+1; + my(@args)=@_; + foreach (@args) + { + s/^\d+(?=\.)/$&+$offset/e; + } + @args; +} + +sub from_index +{ + my $w=shift; + my $offset=$w->cget(-linestart)+1; + my(@args)=@_; + foreach (@args) + { + s/^\d+(?=\.)/$&-$offset/e + } + @args; +} + +sub _find_dump_index +{ + my $idx=_count_options(@_); + [$idx,$idx+1]; +} + +sub _find_search_index +{ + my $idx=_count_options(@_); + [$idx+1,$idx+2]; +} + +sub _count_options +{ + my $idx=0; + while($_[$idx]=~/^-/g) + { + $idx++; + $idx++ if $' eq 'count' or $' eq 'command'; + last if $' eq '-'; + } + $idx; +} + +sub _find_tag_index +{ + return [1] if $_[0] eq 'names'; + return [2,3] if $_[0]=~/^(add|remove|nextrange|prevrange)$/; + return [-1] if $_[0] eq 'ranges'; + return []; +} + +sub _find_mark_index +{ + return [2] if $_[0] eq 'set'; + return [1] if $_[0] eq 'next' or $_[0] eq 'previous'; + return []; +} + +1; + +=head1 NAME + +Tk::Reindex - change the base index of Text-like widgets + +=for category Derived Widgets + +=head1 SYNOPSIS + + use Tk::ReindexedText; + $t1=$w->ReindexedText(-linestart => 2); + + use Tk::ReindexedROText; + $t2=$w->ReindexedROText(-linestart => 0); + +=head1 DESCRIPTION + +Creates a new widget class based on B<Text>-like widgets that can +redefine the line number base (normally B<Text> widgets start line +numbers at 1), or possibly other manipulations on indexes. + +=head1 STANDARD OPTIONS + +The newly-defined widget takes all the same options as the base +widget, which defaults to B<Text>. + +=head1 WIDGET-SPECIFIC OPTIONS + +=item Name: B<lineStart> + +=item Class: B<LineStart> + +=item Switch: B<-linestart> + +Sets the line number of the first line in the B<Text> widget. The +default B<-toindexcmd> and B<-fromindexcmd> use this configuration +option. + +-item Name: B<toIndexCmd> B<fromIndexCmd> + +-item Class: B<ToIndexCmd> B<FromIndexCmd> + +-item Switch: B<-toindexcmd> B<-fromindexcmd> + +These two options specify callbacks that are called with a list of +indexes and are responsible for translating them to/from indexes that +the base B<Text> widget can understand. The callback is passed the +widget followed by a list of indexes, and should return a list of +translated indexes. B<-toindexcmd> should translate from 'user' +indexes to 'native' B<Text>-compatible indexes, and B<-fromindexcmd> +should translate from 'native' indexes to 'user' indexes. + +The default callbacks simply add/subtract the offset given by the +B<-linestart> option for all indexes in 'line.character' format. + +It would probably be prudent to make these functions inverses of each +other. + +=head1 CLASS METHODS + +=item import + +To make new Reindex widgets, this function should be called via B<use> +with the name of the Text-like base class that you are extending with +"Reindex" capability. 'use base(Tk::Reindex Tk::nameofbasewidget)' +should also be specified for that widget. + +=head1 BUGS + +I've used the word "indexes" instead of "indices" throughout the +documentation. + +All the built-in perl code for widget bindings & methods will use the +new 'user' indexes. Which means all this index manipulation might +might break code that is trying to parse/manipulate indexes. Or even +assume that '1.0' is the beginning index. B<Tk::Text::Contents> comes +to mind. + +=head1 AUTHOR + +Andrew Allen <ada@fc.hp.com> + +This code may be distributed under the same conditions as Perl. + +=cut diff --git a/Master/tlpkg/tlperl/lib/Tk/ReindexedROText.pm b/Master/tlpkg/tlperl/lib/Tk/ReindexedROText.pm new file mode 100644 index 00000000000..8c293f5fa61 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/ReindexedROText.pm @@ -0,0 +1,13 @@ +use strict; +package Tk::ReindexedROText; + +use vars qw($VERSION); +$VERSION = '4.004'; # $Id: //depot/Tkutf8/TextList/ReindexedROText.pm#4 $ + +use Tk::Reindex qw(Tk::ROText); +use base qw(Tk::Reindex Tk::ROText); +Construct Tk::Widget 'ReindexedROText'; + +1; + + diff --git a/Master/tlpkg/tlperl/lib/Tk/ReindexedText.pm b/Master/tlpkg/tlperl/lib/Tk/ReindexedText.pm new file mode 100644 index 00000000000..c16a6fe7fd7 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/ReindexedText.pm @@ -0,0 +1,13 @@ +use strict; +package Tk::ReindexedText; + +use vars qw($VERSION); +$VERSION = '4.004'; # $Id: //depot/Tkutf8/TextList/ReindexedText.pm#4 $ + +use Tk::Reindex qw(Tk::Text); +use base qw(Tk::Reindex Tk::Text); +Construct Tk::Widget 'ReindexedText'; + +1; + + diff --git a/Master/tlpkg/tlperl/lib/Tk/Scale.pm b/Master/tlpkg/tlperl/lib/Tk/Scale.pm new file mode 100644 index 00000000000..57c7bb11aa1 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Scale.pm @@ -0,0 +1,278 @@ +# Converted from scale.tcl -- +# +# This file defines the default bindings for Tk scale widgets. +# +# @(#) scale.tcl 1.3 94/12/17 16:05:23 +# +# Copyright (c) 1994 The Regents of the University of California. +# 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. + +package Tk::Scale; + +use vars qw($VERSION); +$VERSION = '4.004'; # $Id: //depot/Tkutf8/Scale/Scale.pm#4 $ + +use Tk qw($XS_VERSION); +use AutoLoader; + +use base qw(Tk::Widget); + +Construct Tk::Widget 'Scale'; + +bootstrap Tk::Scale; + +sub Tk_cmd { \&Tk::scale } + +Tk::Methods('coords','get','identify','set'); + + +import Tk qw(Ev); + +# +# Bind -- +# This procedure below invoked the first time the mouse enters a +# scale widget or a scale widget receives the input focus. It creates +# all of the class bindings for scales. +# +# Arguments: +# event - Indicates which event caused the procedure to be invoked +# (Enter or FocusIn). It is used so that we can carry out +# the functions of that event in addition to setting up +# bindings. +sub ClassInit +{ + my ($class,$mw) = @_; + + $mw->bind($class,'<Enter>',['Enter',Ev('x'),Ev('y')]); + $mw->bind($class,'<Motion>',['Activate',Ev('x'),Ev('y')]); + $mw->bind($class,'<Leave>','Leave'); + + $mw->bind($class,'<1>',['ButtonDown',Ev('x'),Ev('y')]); + $mw->bind($class,'<B1-Motion>',['Drag',Ev('x'),Ev('y')]); + $mw->bind($class,'<B1-Leave>','NoOp'); + $mw->bind($class,'<B1-Enter>','NoOp'); + $mw->bind($class,'<ButtonRelease-1>',['ButtonUp',Ev('x'),Ev('y')]); + + $mw->bind($class,'<2>',['ButtonDown',Ev('x'),Ev('y')]); + $mw->bind($class,'<B2-Motion>',['Drag',Ev('x'),Ev('y')]); + $mw->bind($class,'<B2-Leave>','NoOp'); + $mw->bind($class,'<B2-Enter>','NoOp'); + $mw->bind($class,'<ButtonRelease-2>',['ButtonUp',Ev('x'),Ev('y')]); + + $mw->bind($class,'<Control-1>',['ControlPress',Ev('x'),Ev('y')]); + + $mw->bind($class,'<Up>',['Increment','up','little','noRepeat']); + $mw->bind($class,'<Down>',['Increment','down','little','noRepeat']); + $mw->bind($class,'<Left>',['Increment','up','little','noRepeat']); + $mw->bind($class,'<Right>',['Increment','down','little','noRepeat']); + + $mw->bind($class,'<Control-Up>',['Increment','up','big','noRepeat']); + $mw->bind($class,'<Control-Down>',['Increment','down','big','noRepeat']); + $mw->bind($class,'<Control-Left>',['Increment','up','big','noRepeat']); + $mw->bind($class,'<Control-Right>',['Increment','down','big','noRepeat']); + + $mw->bind($class,'<Home>',['set',Ev('cget','-from')]); + $mw->bind($class,'<End>',['set',Ev('cget','-to')]); + return $class; +} + +1; + +__END__ + +# Activate -- +# This procedure is invoked to check a given x-y position in the +# scale and activate the slider if the x-y position falls within +# the slider. +# +# Arguments: +# w - The scale widget. +# x, y - Mouse coordinates. +sub Activate +{ + my $w = shift; + my $x = shift; + my $y = shift; + return if ($w->cget('-state') eq 'disabled'); + my $ident = $w->identify($x,$y); + if (defined($ident) && $ident eq 'slider') + { + $w->configure(-state => 'active') + } + else + { + $w->configure(-state => 'normal') + } +} + +sub Leave +{ + my ($w) = @_; + $w->configure('-activebackground',$w->{'activeBg'}) if ($Tk::strictMotif); + $w->configure('-state','normal') if ($w->cget('-state') eq 'active'); +} + +sub Enter +{ + my ($w,$x,$y) = @_; + if ($Tk::strictMotif) + { + $w->{'activeBg'} = $w->cget('-activebackground'); + $w->configure('-activebackground',$w->cget('-background')); + } + $w->Activate($x,$y); +} + +sub ButtonUp +{ + my ($w,$x,$y) = @_; + $w->CancelRepeat(); + $w->EndDrag(); + $w->Activate($x,$y) +} + + +# ButtonDown -- +# This procedure is invoked when a button is pressed in a scale. It +# takes different actions depending on where the button was pressed. +# +# Arguments: +# w - The scale widget. +# x, y - Mouse coordinates of button press. +sub ButtonDown +{ + my $w = shift; + my $x = shift; + my $y = shift; + $Tk::dragging = 0; + $el = $w->identify($x,$y); + return unless ($el); + if ($el eq 'trough1') + { + $w->Increment('up','little','initial') + } + elsif ($el eq 'trough2') + { + $w->Increment('down','little','initial') + } + elsif ($el eq 'slider') + { + $Tk::dragging = 1; + my @coords = $w->coords(); + $Tk::deltaX = $x-$coords[0]; + $Tk::deltaY = $y-$coords[1]; + } +} +# Drag -- +# This procedure is called when the mouse is dragged with +# mouse button 1 down. If the drag started inside the slider +# (i.e. the scale is active) then the scale's value is adjusted +# to reflect the mouse's position. +# +# Arguments: +# w - The scale widget. +# x, y - Mouse coordinates. +sub Drag +{ + my $w = shift; + my $x = shift; + my $y = shift; + if (!$Tk::dragging) + { + return; + } + $w->set($w->get($x-$Tk::deltaX,$y-$Tk::deltaY)) +} +# EndDrag -- +# This procedure is called to end an interactive drag of the +# slider. It just marks the drag as over. +# Arguments: +# w - The scale widget. +sub EndDrag +{ + my $w = shift; + if (!$Tk::dragging) + { + return; + } + $Tk::dragging = 0; +} +# Increment -- +# This procedure is invoked to increment the value of a scale and +# to set up auto-repeating of the action if that is desired. The +# way the value is incremented depends on the "dir" and "big" +# arguments. +# +# Arguments: +# w - The scale widget. +# dir - "up" means move value towards -from, "down" means +# move towards -to. +# big - Size of increments: "big" or "little". +# repeat - Whether and how to auto-repeat the action: "noRepeat" +# means don't auto-repeat, "initial" means this is the +# first action in an auto-repeat sequence, and "again" +# means this is the second repetition or later. +sub Increment +{ + my $w = shift; + my $dir = shift; + my $big = shift; + my $repeat = shift; + my $inc; + if ($big eq 'big') + { + $inc = $w->cget('-bigincrement'); + if ($inc == 0) + { + $inc = abs(($w->cget('-to')-$w->cget('-from')))/10.0 + } + if ($inc < $w->cget('-resolution')) + { + $inc = $w->cget('-resolution') + } + } + else + { + $inc = $w->cget('-resolution') + } + if (($w->cget('-from') > $w->cget('-to')) ^ ($dir eq 'up')) + { + $inc = -$inc + } + $w->set($w->get()+$inc); + if ($repeat eq 'again') + { + $w->RepeatId($w->after($w->cget('-repeatinterval'),'Increment',$w,$dir,$big,'again')); + } + elsif ($repeat eq 'initial') + { + $w->RepeatId($w->after($w->cget('-repeatdelay'),'Increment',$w,$dir,$big,'again')); + } +} +# ControlPress -- +# This procedure handles button presses that are made with the Control +# key down. Depending on the mouse position, it adjusts the scale +# value to one end of the range or the other. +# +# Arguments: +# w - The scale widget. +# x, y - Mouse coordinates where the button was pressed. +sub ControlPress +{ + my ($w,$x,$y) = @_; + my $el = $w->identify($x,$y); + return unless ($el); + if ($el eq 'trough1') + { + $w->set($w->cget('-from')) + } + elsif ($el eq 'trough2') + { + $w->set($w->cget('-to')) + } +} + + diff --git a/Master/tlpkg/tlperl/lib/Tk/Scrollbar.pm b/Master/tlpkg/tlperl/lib/Tk/Scrollbar.pm new file mode 100644 index 00000000000..6b416e04b30 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Scrollbar.pm @@ -0,0 +1,429 @@ +# Conversion from Tk4.0 scrollbar.tcl competed. +package Tk::Scrollbar; + +use vars qw($VERSION); +$VERSION = '4.010'; # $Id: //depot/Tkutf8/Scrollbar/Scrollbar.pm#10 $ + +use Tk qw($XS_VERSION Ev); +use AutoLoader; + +use base qw(Tk::Widget); + +#use strict; +#use vars qw($pressX $pressY @initValues $initPos $activeBg); + +Construct Tk::Widget 'Scrollbar'; + +bootstrap Tk::Scrollbar; + +sub Tk_cmd { \&Tk::scrollbar } + +Tk::Methods('activate','delta','fraction','get','identify','set'); + +sub Needed +{ + my ($sb) = @_; + my @val = $sb->get; + return 1 unless (@val == 2); + return 1 if $val[0] != 0.0; + return 1 if $val[1] != 1.0; + return 0; +} + + +sub ClassInit +{ + my ($class,$mw) = @_; + $mw->bind($class, '<Enter>', 'Enter'); + $mw->bind($class, '<Motion>', 'Motion'); + $mw->bind($class, '<Leave>', 'Leave'); + + $mw->bind($class, '<1>', 'ButtonDown'); + $mw->bind($class, '<B1-Motion>', ['Drag', Ev('x'), Ev('y')]); + $mw->bind($class, '<ButtonRelease-1>', 'ButtonUp'); + $mw->bind($class, '<B1-Leave>', 'NoOp'); # prevent generic <Leave> + $mw->bind($class, '<B1-Enter>', 'NoOp'); # prevent generic <Enter> + $mw->bind($class, '<Control-1>', 'ScrlTopBottom'); + + $mw->bind($class, '<2>', 'ButtonDown'); + $mw->bind($class, '<B2-Motion>', ['Drag', Ev('x'), Ev('y')]); + $mw->bind($class, '<ButtonRelease-2>', 'ButtonUp'); + $mw->bind($class, '<B2-Leave>', 'NoOp'); # prevent generic <Leave> + $mw->bind($class, '<B2-Enter>', 'NoOp'); # prevent generic <Enter> + $mw->bind($class, '<Control-2>', 'ScrlTopBottom'); + + $mw->bind($class, '<Up>', ['ScrlByUnits','v',-1]); + $mw->bind($class, '<Down>', ['ScrlByUnits','v', 1]); + $mw->bind($class, '<Control-Up>', ['ScrlByPages','v',-1]); + $mw->bind($class, '<Control-Down>', ['ScrlByPages','v', 1]); + + $mw->bind($class, '<Left>', ['ScrlByUnits','h',-1]); + $mw->bind($class, '<Right>', ['ScrlByUnits','h', 1]); + $mw->bind($class, '<Control-Left>', ['ScrlByPages','h',-1]); + $mw->bind($class, '<Control-Right>', ['ScrlByPages','h', 1]); + + $mw->bind($class, '<Prior>', ['ScrlByPages','hv',-1]); + $mw->bind($class, '<Next>', ['ScrlByPages','hv', 1]); + + # X11 mousewheel - honour for horizontal too. + $mw->bind($class, '<4>', ['ScrlByUnits','hv',-5]); + $mw->bind($class, '<5>', ['ScrlByUnits','hv', 5]); + + $mw->bind($class, '<Home>', ['ScrlToPos', 0]); + $mw->bind($class, '<End>', ['ScrlToPos', 1]); + + $mw->bind($class, '<4>', ['ScrlByUnits','v',-3]); + $mw->bind($class, '<5>', ['ScrlByUnits','v', 3]); + + return $class; + +} + +1; + +__END__ + +sub Enter +{ + my $w = shift; + my $e = $w->XEvent; + if ($Tk::strictMotif) + { + my $bg = $w->cget('-background'); + $activeBg = $w->cget('-activebackground'); + $w->configure('-activebackground' => $bg); + } + $w->activate($w->identify($e->x,$e->y)); +} + +sub Leave +{ + my $w = shift; + if ($Tk::strictMotif) + { + $w->configure('-activebackground' => $activeBg) if (defined $activeBg) ; + } + $w->activate(''); +} + +sub Motion +{ + my $w = shift; + my $e = $w->XEvent; + $w->activate($w->identify($e->x,$e->y)); +} + +# tkScrollButtonDown -- +# This procedure is invoked when a button is pressed in a scrollbar. +# It changes the way the scrollbar is displayed and takes actions +# depending on where the mouse is. +# +# Arguments: +# w - The scrollbar widget. +# x, y - Mouse coordinates. + +sub ButtonDown +{my $w = shift; + my $e = $w->XEvent; + my $element = $w->identify($e->x,$e->y); + $w->configure('-activerelief' => 'sunken'); + if ($e->b == 1 and + (defined($element) && $element eq 'slider')) + { + $w->StartDrag($e->x,$e->y); + } + elsif ($e->b == 2 and + (defined($element) && $element =~ /^(trough[12]|slider)$/o)) + { + my $pos = $w->fraction($e->x, $e->y); + my($head, $tail) = $w->get; + my $len = $tail - $head; + + $head = $pos - $len/2; + $tail = $pos + $len/2; + if ($head < 0) { + $head = 0; + $tail = $len; + } + elsif ($tail > 1) { + $head = 1 - $len; + $tail = 1; + } + $w->ScrlToPos($head); + $w->set($head, $tail); + + $w->StartDrag($e->x,$e->y); + } + else + { + $w->Select($element,'initial'); + } +} + +# tkScrollButtonUp -- +# This procedure is invoked when a button is released in a scrollbar. +# It cancels scans and auto-repeats that were in progress, and restores +# the way the active element is displayed. +# +# Arguments: +# w - The scrollbar widget. +# x, y - Mouse coordinates. + +sub ButtonUp +{my $w = shift; + my $e = $w->XEvent; + $w->CancelRepeat; + $w->configure('-activerelief' => 'raised'); + $w->EndDrag($e->x,$e->y); + $w->activate($w->identify($e->x,$e->y)); +} + +# tkScrollSelect -- +# This procedure is invoked when button 1 is pressed over the scrollbar. +# It invokes one of several scrolling actions depending on where in +# the scrollbar the button was pressed. +# +# Arguments: +# w - The scrollbar widget. +# element - The element of the scrollbar that was selected, such +# as "arrow1" or "trough2". Shouldn't be "slider". +# repeat - Whether and how to auto-repeat the action: "noRepeat" +# means don't auto-repeat, "initial" means this is the +# first action in an auto-repeat sequence, and "again" +# means this is the second repetition or later. + +sub Select +{ + my $w = shift; + my $element = shift; + my $repeat = shift; + return unless defined ($element); + if ($element eq 'arrow1') + { + $w->ScrlByUnits('hv',-1); + } + elsif ($element eq 'trough1') + { + $w->ScrlByPages('hv',-1); + } + elsif ($element eq 'trough2') + { + $w->ScrlByPages('hv', 1); + } + elsif ($element eq 'arrow2') + { + $w->ScrlByUnits('hv', 1); + } + else + { + return; + } + + if ($repeat eq 'again') + { + $w->RepeatId($w->after($w->cget('-repeatinterval'),['Select',$w,$element,'again'])); + } + elsif ($repeat eq 'initial') + { + $w->RepeatId($w->after($w->cget('-repeatdelay'),['Select',$w,$element,'again'])); + } +} + +# tkScrollStartDrag -- +# This procedure is called to initiate a drag of the slider. It just +# remembers the starting position of the slider. +# +# Arguments: +# w - The scrollbar widget. +# x, y - The mouse position at the start of the drag operation. + +sub StartDrag +{ + my($w,$x,$y) = @_; + return unless (defined ($w->cget('-command'))); + $pressX = $x; + $pressY = $y; + @initValues = $w->get; + my $iv0 = $initValues[0]; + if (@initValues == 2) + { + $initPos = $iv0; + } + elsif ($iv0 == 0) + { + $initPos = 0; + } + else + { + $initPos = $initValues[2]/$initValues[0]; + } +} + +# tkScrollDrag -- +# This procedure is called for each mouse motion even when the slider +# is being dragged. It notifies the associated widget if we're not +# jump scrolling, and it just updates the scrollbar if we are jump +# scrolling. +# +# Arguments: +# w - The scrollbar widget. +# x, y - The current mouse position. + +sub Drag +{ + my($w,$x,$y) = @_; + return if !defined $initPos; + my $delta = $w->delta($x-$pressX, $y-$pressY); + if ($w->cget('-jump')) + { + if (@initValues == 2) + { + $w->set($initValues[0]+$delta, $initValues[1]+$delta); + } + else + { + $delta = sprintf "%d", $delta * $initValues[0]; # round() + $initValues[2] += $delta; + $initValues[3] += $delta; + $w->set(@initValues[2,3]); + } + } + else + { + $w->ScrlToPos($initPos+$delta); + } +} + +# tkScrollEndDrag -- +# This procedure is called to end an interactive drag of the slider. +# It scrolls the window if we're in jump mode, otherwise it does nothing. +# +# Arguments: +# w - The scrollbar widget. +# x, y - The mouse position at the end of the drag operation. + +sub EndDrag +{ + my($w,$x,$y) = @_; + return if (!defined $initPos); + if ($w->cget('-jump')) + { + my $delta = $w->delta($x-$pressX, $y-$pressY); + $w->ScrlToPos($initPos+$delta); + } + undef $initPos; +} + +# tkScrlByUnits -- +# This procedure tells the scrollbar's associated widget to scroll up +# or down by a given number of units. It notifies the associated widget +# in different ways for old and new command syntaxes. +# +# Arguments: +# w - The scrollbar widget. +# orient - Which kinds of scrollbars this applies to: "h" for +# horizontal, "v" for vertical, "hv" for both. +# amount - How many units to scroll: typically 1 or -1. + +sub ScrlByUnits +{my $w = shift; + my $orient = shift; + my $amount = shift; + my $cmd = $w->cget('-command'); + return unless (defined $cmd); + return if (index($orient,substr($w->cget('-orient'),0,1)) < 0); + my @info = $w->get; + if (@info == 2) + { + $cmd->Call('scroll',$amount,'units'); + } + else + { + $cmd->Call($info[2]+$amount); + } +} + +# tkScrlByPages -- +# This procedure tells the scrollbar's associated widget to scroll up +# or down by a given number of screenfuls. It notifies the associated +# widget in different ways for old and new command syntaxes. +# +# Arguments: +# w - The scrollbar widget. +# orient - Which kinds of scrollbars this applies to: "h" for +# horizontal, "v" for vertical, "hv" for both. +# amount - How many screens to scroll: typically 1 or -1. + +sub ScrlByPages +{ + my $w = shift; + my $orient = shift; + my $amount = shift; + my $cmd = $w->cget('-command'); + return unless (defined $cmd); + return if (index($orient,substr($w->cget('-orient'),0,1)) < 0); + my @info = $w->get; + if (@info == 2) + { + $cmd->Call('scroll',$amount,'pages'); + } + else + { + $cmd->Call($info[2]+$amount*($info[1]-1)); + } +} + +# tkScrlToPos -- +# This procedure tells the scrollbar's associated widget to scroll to +# a particular location, given by a fraction between 0 and 1. It notifies +# the associated widget in different ways for old and new command syntaxes. +# +# Arguments: +# w - The scrollbar widget. +# pos - A fraction between 0 and 1 indicating a desired position +# in the document. + +sub ScrlToPos +{ + my $w = shift; + my $pos = shift; + my $cmd = $w->cget('-command'); + return unless (defined $cmd); + my @info = $w->get; + if (@info == 2) + { + $cmd->Call('moveto',$pos); + } + else + { + $cmd->Call(int($info[0]*$pos)); + } +} + +# tkScrlTopBottom +# Scroll to the top or bottom of the document, depending on the mouse +# position. +# +# Arguments: +# w - The scrollbar widget. +# x, y - Mouse coordinates within the widget. + +sub ScrlTopBottom +{ + my $w = shift; + my $e = $w->XEvent; + my $element = $w->identify($e->x,$e->y); + return unless ($element); + if ($element =~ /1$/) + { + $w->ScrlToPos(0); + } + elsif ($element =~ /2$/) + { + $w->ScrlToPos(1); + } +} + + + + diff --git a/Master/tlpkg/tlperl/lib/Tk/Spinbox.pm b/Master/tlpkg/tlperl/lib/Tk/Spinbox.pm new file mode 100644 index 00000000000..673a1e181ce --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Spinbox.pm @@ -0,0 +1,115 @@ +package Tk::Spinbox; +use strict; + +use vars qw($VERSION); +$VERSION = sprintf '4.%03d',q$Revision: #6 $ =~ /#(\d+)/; + +use base 'Tk::Entry'; + +sub Tk_cmd { \&Tk::spinbox } + +# Also inherits Entry's methods +Tk::Methods( "identify", "invoke", "set" ); +use Tk::Submethods ( 'selection' => ["element"] ); + +Construct Tk::Widget 'Spinbox'; + +sub ClassInit +{ + my ($class,$mw) = @_; + + $class->SUPER::ClassInit($mw); + + $mw->bind($class, '<Up>', [invoke => 'buttonup']); + $mw->bind($class, '<4>', [invoke => 'buttonup']); + $mw->bind($class, '<Down>',[invoke => 'buttondown']); + $mw->bind($class, '<5>', [invoke => 'buttondown']); + + return $class; +} + +sub Invoke +{ + my ($w,$elem) = @_; + unless ($w->{_outside}) + { + $w->invoke($elem); + $w->{_repeated}++; + } + my $delay = $w->cget('-repeatinterval'); + if ($delay > 0) + { + $w->RepeatId($w->after($delay,[Invoke => $w,$elem])); + } +} + +sub Button1 +{ + my ($w,$x,$y) = @_; + my $elem = $w->identify($x,$y); + $w->{_element} = $elem || 'entry'; + if ($w->{_element} eq 'entry') + { + $w->SUPER::Button1($x,$y); + } + elsif ($w->cget('-state') ne 'disabled') + { + $w->selectionElement($elem); + $w->{_repeated} = 0; + $w->{_outside} = 0; + $w->{_relief} = $w->cget("-${elem}relief"); + $w->CancelRepeat; + my $delay = $w->cget('-repeatdelay'); + $w->RepeatId($w->after($delay,[Invoke => $w,$elem])) if $delay > 0; + } +} + +sub Motion +{ + my ($w,$x,$y) = @_; + my $elem = $w->identify($x,$y); + $w->{_element} = $elem || 'entry' unless $w->{_element}; + if ($w->{_element} eq 'entry') + { + $w->SUPER::Motion($x,$y); + } + else + { + if (!defined($elem) || $elem ne $w->{_element}) + { + # Moved outside the button + unless ($w->{_outside}) + { + $w->{_outside} = 1; + $w->selectionElement('none'); + } + } + elsif ($w->{_outside}) + { + # Moved back over the button + $w->selectionElement($elem); + $w->{_outside} = 0; + } + } +} + +sub Button1Release +{ + my ($w,$x,$y) = @_; + $w->SUPER::Button1Release($x,$y); + my $elem = $w->{_element}; + if (defined($elem) && $elem ne 'entry') + { + my $repeated = $w->{_repeated}; + if (defined($repeated) && !$repeated) + { + $w->invoke($elem); + } + my $relief = delete $w->{_relief}; + $w->configure("-${elem}relief",$relief) if $relief + } + $w->selectionElement('none'); +} + +1; +__END__ diff --git a/Master/tlpkg/tlperl/lib/Tk/Stats.pm b/Master/tlpkg/tlperl/lib/Tk/Stats.pm new file mode 100644 index 00000000000..39bedfb1a47 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Stats.pm @@ -0,0 +1,26 @@ +package Tk::Stats; + +($lu,$ls) = times; + + +use vars qw($VERSION); +$VERSION = '4.004'; # $Id: //depot/Tkutf8/Tk/Stats.pm#4 $ + +sub stats + { + my ($u,$s) = times; + my $du = $u-$lu; + my $ds = $s-$ls; + $ls = $s; + $lu = $u; + print sprintf(' dt=%4.2f du=%4.2f ds=%4.2f',$du+$ds,$du,$ds); + print sprintf(' t=%4.2f u=%4.2f s=%4.2f',$u+$s,$u,$s); + print ' ',shift,"\n"; + } + +sub import +{ + stats($_[1]); +} + +1; diff --git a/Master/tlpkg/tlperl/lib/Tk/Submethods.pm b/Master/tlpkg/tlperl/lib/Tk/Submethods.pm new file mode 100644 index 00000000000..a2b8e3bd186 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Submethods.pm @@ -0,0 +1,46 @@ +package Tk::Submethods; + +use vars qw($VERSION); +$VERSION = '4.004'; # $Id: //depot/Tkutf8/Tk/Submethods.pm#4 $ + +sub import +{ + my $class = shift; + no strict 'refs'; + my $package = caller(0); + while (@_) + { + my $fn = shift; + my $sm = shift; + foreach my $sub (@{$sm}) + { + my ($suffix) = $sub =~ /(\w+)$/; + my $pfn = $package.'::'.$fn; + *{$pfn."\u$suffix"} = sub { shift->$pfn($sub,@_) }; + } + } +} + +sub Direct +{ + my $class = shift; + no strict 'refs'; + my $package = caller(0); + while (@_) + { + my $fn = shift; + my $sm = shift; + my $sub; + foreach $sub (@{$sm}) + { + # eval "sub ${package}::${sub} { shift->$fn('$sub',\@_) }"; + *{$package.'::'.$sub} = sub { shift->$fn($sub,@_) }; + } + } +} + +1; + +__END__ + +=cut diff --git a/Master/tlpkg/tlperl/lib/Tk/TList.pm b/Master/tlpkg/tlperl/lib/Tk/TList.pm new file mode 100644 index 00000000000..65ce18796bb --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/TList.pm @@ -0,0 +1,416 @@ +package Tk::TList; + +use vars qw($VERSION); +$VERSION = '4.006'; # $Id: //depot/Tkutf8/TList/TList.pm#6 $ + +use Tk qw(Ev $XS_VERSION); + +use base qw(Tk::Widget); + +use strict; + +Construct Tk::Widget 'TList'; + +bootstrap Tk::TList; + +sub Tk_cmd { \&Tk::tlist } + +Tk::Methods qw(insert index anchor delete dragsite dropsite entrycget + entryconfigure info nearest see selection xview yview); + +use Tk::Submethods ( 'delete' => [qw(all entry offsprings siblings)], + 'info' => [qw(anchor dragsite dropsite selection)], + 'selection' => [qw(clear get includes set)], + 'anchor' => [qw(clear set)], + 'dragsite' => [qw(clear set)], + 'dropsite' => [qw(clear set)], + ); + +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,'<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>', ['DirKey', 'up']); + $mw->bind($class,'<Down>',['DirKey', 'down']); + + $mw->bind($class,'<Left>', ['DirKey', 'left']); + $mw->bind($class,'<Right>',['DirKey', 'right']); + + $mw->bind($class,'<Prior>','Prior'); + $mw->bind($class,'<Next>','Next'); + + $mw->bind($class,'<Return>', ['KeyboardActivate']); + $mw->bind($class,'<space>', ['KeyboardBrowse']); + + 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 Prior +{ +shift->yview('scroll', -1, 'pages') +} + + +sub Next +{ +shift->yview('scroll', 1, 'pages') +} + + +sub Button1 +{ + my $w = shift; + my $Ev = $w->XEvent; + + delete $w->{'shiftanchor'}; + + $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->x, $Ev->y); + + return unless defined $ent; + + my $browse = 0; + + if($mode eq 'single') + { + $w->anchor('set', $ent); + } + elsif($mode eq 'browse') + { + $w->anchor('set', $ent); + $w->selection('clear' ); + $w->selection('set', $ent); + $browse = 1; + } + elsif($mode eq 'multiple') + { + $w->selection('clear'); + $w->anchor('set', $ent); + $w->selection('set', $ent); + $browse = 1; + } + elsif($mode eq 'extended') + { + $w->anchor('set', $ent); + $w->selection('clear'); + $w->selection('set', $ent); + $browse = 1; + } + + $w->Callback(-browsecmd => $ent) if ($browse); +} + +sub ShiftButton1 +{ + my $w = shift; + my $Ev = $w->XEvent; + + my $to = $w->GetNearest($Ev->x,$Ev->y); + + delete $w->{'shiftanchor'}; + + return unless defined $to; + + my $mode = $w->cget('-selectmode'); + + if ($mode eq 'extended') + { + my $from = $w->info('anchor'); + if (defined $from) + { + $w->selection('clear'); + $w->selection('set', $from, $to); + } + else + { + $w->anchor('set', $to); + $w->selection('clear'); + $w->selection('set', $to); + } + } +} + +sub GetNearest +{ + my ($w,$x,$y) = @_; + my $ent = $w->nearest($x,$y); + if (defined $ent) + { + 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($x,$y); + + return unless defined $ent; + + if($x < 0 || $y < 0 || $x > $w->width || $y > $w->height) + { + $w->selection('clear'); + + return if($mode eq 'single' || $mode eq 'browse') + + } + else + { + if($mode eq 'single' || $mode eq 'browse') + { + $w->anchor('set', $ent); + $w->selection('clear'); + $w->selection('set', $ent); + + } + elsif($mode eq 'multiple') + { + $w->selection('set', $ent); + } + elsif($mode eq 'extended') + { + $w->selection('set', $ent); + } + } + + $w->Callback(-browsecmd =>$ent); +} + +sub Button1Motion +{ + my $w = shift; + my $Ev = $w->XEvent; + + delete $w->{'shiftanchor'}; + + my $mode = $w->cget('-selectmode'); + + if ($mode eq 'dragdrop') + { +# $w->Send_StartDrag(); + return; + } + + my $ent = $w->GetNearest($Ev->x,$Ev->y); + + return unless defined $ent; + + if($mode eq 'single') + { + $w->anchor('set', $ent); + } + elsif($mode eq 'multiple' || $mode eq 'extended') + { + my $from = $w->info('anchor'); + if (defined $from) + { + $w->selection('clear'); + $w->selection('set', $from, $ent); + } + else + { + $w->anchor('set', $ent); + $w->selection('clear'); + $w->selection('set', $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->x,$Ev->y); + + return unless defined $ent; + + $w->anchor('set', $ent) unless defined($w->info('anchor')); + + $w->selection('set', $ent); + $w->Callback(-command => $ent); +} + +sub CtrlButton1 +{ + my $w = shift; + my $Ev = $w->XEvent; + + delete $w->{'shiftanchor'}; + + my $ent = $w->GetNearest($Ev->x,$Ev->y); + + return unless defined $ent; + + my $mode = $w->cget('-selectmode'); + + if($mode eq 'extended') + { + $w->anchor('set', $ent) unless defined( $w->info('anchor') ); + + if($w->selection('includes', $ent)) + { + $w->selection('clear', $ent); + } + else + { + $w->selection('set', $ent); + } + $w->Callback(-browsecmd =>$ent); + } +} + +sub DirKey +{ + my ($w,$dir) = @_; + my $anchor = $w->info('anchor'); + + my $new = (defined $anchor) ? $w->info($dir,$anchor) : 0; + + $w->anchorSet($new); + $w->see($new); +} + +sub KeyboardActivate +{ + my $w = shift; + + my $anchor = $w->info('anchor'); + + return unless defined $anchor; + + if($w->cget('-selectmode')) + { + $w->selection('clear'); + $w->selection('set', $anchor); + } + $w->Callback(-command => $anchor); +} + +sub KeyboardBrowse +{ + my $w = shift; + + my $anchor = $w->info('anchor'); + + return unless defined $anchor; + + if($w->cget('-selectmode')) + { + $w->selection('clear'); + $w->selection('set', $anchor); + } + $w->Callback(-browsecmd =>$anchor); +} + +sub AutoScan +{ + my $w = shift; + + return if($w->cget('-selectmode') eq 'dragdrop'); + + my $Ev = $w->XEvent; + my $y = $Ev->y; + my $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->after(50,[AutoScan => $w])); + $w->Button1Motion; +} + +1; + diff --git a/Master/tlpkg/tlperl/lib/Tk/Table.pm b/Master/tlpkg/tlperl/lib/Tk/Table.pm new file mode 100644 index 00000000000..8fa9e5af4a9 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Table.pm @@ -0,0 +1,598 @@ +# Copyright (c) 1995-2003 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. +package Tk::Table; +use strict; + +use vars qw($VERSION); +$VERSION = sprintf '4.%03d', q$Revision: #12 $ =~ /\D(\d+)\s*$/; + +use Tk::Pretty; +use AutoLoader; +use base qw(Tk::Frame); + +Construct Tk::Widget 'Table'; + +# Constants for QueueLayout flags +sub _SlaveSize () { 1 } # Slave has asked for change of width or height +sub _SlaveChange () { 2 } # We lost or gained a slave +sub _ViewChange () { 4 } # xview or yview called +sub _ConfigEvent () { 8 } # Table has changed size +sub _ScrollBars () { 32 } # Scrollabrs came or went +sub _RowColCount () { 16 } # rows or columns configured + + +sub ClassInit +{ + my ($class,$mw) = @_; + $mw->bind($class,'<Configure>',['QueueLayout',_ConfigEvent]); + $mw->bind($class,'<FocusIn>', 'NoOp'); + $mw->XYscrollBind($class); + return $class; +} + +sub _view +{ + my ($t,$s,$page,$a,$op,$num,$type) = @_; + if ($op eq 'moveto') + { + $$s = int(@$a*$num); + } + else + { + $num *= ($page/2) if ($type eq 'pages'); + $$s += $num; + } + $$s = 0 if ($$s < 0); + $t->QueueLayout(_ViewChange); +} + +sub xview +{ + my $t = shift; + $t->_view(\$t->{Left},$t->cget('-columns'),$t->{Width},@_); +} + +sub yview +{ + my $t = shift; + $t->_view(\$t->{Top},$t->cget('-rows'),$t->{Height},@_); +} + +sub FocusChildren +{ + my $t = shift; + return () if ($t->cget('-takefocus')); + return $t->SUPER::FocusChildren; +} + +sub Populate +{ + my ($t,$args) = @_; + $t->SUPER::Populate($args); + $t->ConfigSpecs('-scrollbars' => [METHOD => 'scrollbars','Scrollbars','nw'], + '-takefocus' => [SELF => 'takeFocus','TakeFocus',1], + '-rows' => [METHOD => 'rows','Rows',10], + '-fixedrows' => [METHOD => 'fixedRows','FixedRows',0], + '-columns' => [METHOD => 'columns','Columns',10], + '-fixedcolumns' => [METHOD => 'fixedColumn','FixedColumns',0], + '-highlightthickness' => [SELF => 'highlightThickness','HighlightThickness',2] + ); + $t->_init; +} + +sub sizeN +{ + my ($n,$a) = @_; + my $max = 0; + my $i = 0; + my $sum = 0; + while ($i < @$a && $i < $n) + { + my $n = $a->[$i++]; + $a->[$i-1] = $n = 0 unless (defined $n); + $sum += $n; + } + $max = $sum if ($sum > $max); + while ($i < @$a) + { + $sum = $sum-$a->[$i-$n]+$a->[$i]; + $max = $sum if ($sum > $max); + $i++; + } + return $max; +} + +sub total +{ + my ($a) = @_; + my $total = 0; + my $x; + foreach $x (@{$a}) + { + $total += $x; + } + return $total; +} + +sub constrain +{ + my ($sb,$a,$pixels,$fixed) = @_; + my $n = $$sb+$fixed; + my $total = 0; + my $i; + $n = @$a if ($n > @$a); + $n = $fixed if ($n < $fixed); + for ($i= 0; $i < $fixed; $i++) + { + (defined($a->[$i])) && ($total += $a->[$i]); + } + for ($i=$n; $total < $pixels && $i < @$a; $i++) + { + $a->[$i] ||= 0; + $total += $a->[$i]; + } + while ($n > $fixed) + { + if (($total += $a->[--$n]) > $pixels) + { + $n++; + last; + } + } + $$sb = $n-$fixed; +} + +sub Layout +{ + my ($t) = @_; + return unless Tk::Exists($t); + my $rows = @{$t->{Row}}; + my $bw = $t->cget(-highlightthickness); + my $frows = $t->cget(-fixedrows); + my $fcols = $t->cget(-fixedcolumns); + my $sb = $t->cget(-scrollbars); + my $H = $t->Height; + my $W = $t->Width; + my $tadj = $bw; + my $badj = $bw; + my $ladj = $bw; + my $radj = $bw; + my @xs = ($W,0,0,0); + my @ys = (0,$H,0,0); + my $xsb; + my $ysb; + + my $why = $t->{LayoutPending}; + $t->{LayoutPending} = 0; + + if ($sb =~ /[ns]/) + { + $t->{xsb} = $t->Scrollbar(-orient => 'horizontal', -command => ['xview' => $t]) unless (defined $t->{xsb}); + $xsb = $t->{xsb}; + $xs[3] = $xsb->ReqHeight; + if ($sb =~ /n/) + { + $xs[1] = $tadj; + $tadj += $xs[3]; + } + else + { + $badj += $xs[3]; + $xs[1] = $H-$badj; + } + } + else + { + $t->{xsb}->UnmapWindow if (defined $t->{xsb}); + } + + if ($sb =~ /[ew]/) + { + $t->{ysb} = $t->Scrollbar(-orient => 'vertical', -command => ['yview' => $t]) unless (defined $t->{ysb}); + $ysb = $t->{ysb}; + $ys[2] = $ysb->ReqWidth; + if ($sb =~ /w/) + { + $ys[0] = $ladj; + $ladj += $ys[2]; + } + else + { + $radj += $ys[2]; + $ys[0] = $W-$radj; + } + } + else + { + $t->{ysb}->UnmapWindow if (defined $t->{ysb}); + } + + constrain(\$t->{Top}, $t->{Height},$H-($tadj+$badj),$frows); + constrain(\$t->{Left},$t->{Width}, $W-($ladj+$radj),$fcols); + + my $top = $t->{Top}+$frows; + my $left = $t->{Left}+$fcols; + + if ($why & (_ScrollBars|_RowColCount|_SlaveSize)) + { + # Width and/or Height of element or + # number of rows and/or columns or + # scrollbar presence has changed + my $w = sizeN($t->cget('-columns'),$t->{Width})+$radj+$ladj; + my $h = sizeN($t->cget('-rows'),$t->{Height})+$tadj+$badj; + $t->GeometryRequest($w,$h); + } + + if ($rows) + { + my $cols = @{$t->{Width}}; + my $yhwm = $top-$frows; + my $xhwm = $left-$fcols; + my $y = $tadj; + my $r; + for ($r = 0; $r < $rows; $r++) + { + my $h = $t->{Height}[$r]; + next unless defined $h; + if (($r < $top && $r >= $frows) || ($y+$h > $H-$badj)) + { + if (defined $t->{Row}[$r]) + { + my $c; + for ($c = 0; $c < @{$t->{Row}[$r]}; $c++) + { + my $s = $t->{Row}[$r][$c]; + if (defined $s) + { + $s->UnmapWindow; + if ($why & 1) + { + my $w = $t->{Width}[$c]; + $s->ResizeWindow($w,$h); + } + } + } + } + } + else + { + my $hwm = $left-$fcols; + my $sh = 0; + my $x = $ladj; + my $c; + $ys[1] = $y if ($y < $ys[1] && $r >= $frows); + for ($c = 0; $c <$cols; $c++) + { + my $s = $t->{Row}[$r][$c]; + my $w = $t->{Width}[$c]; + if (($c < $left && $c >= $fcols) || ($x+$w > $W-$radj) ) + { + if (defined $s) + { + $s->UnmapWindow; + $s->ResizeWindow($w,$h) if ($why & 1); + } + } + else + { + $xs[0] = $x if ($x < $xs[0] && $c >= $fcols); + if (defined $s) + { + if ($why & 1) + { + $s->MoveResizeWindow($x,$y,$w,$h); + } + else + { + $s->MoveWindow($x,$y); + } + $s->MapWindow; + } + $x += $w; + if ($c >= $fcols) + { + $hwm++; + $sh += $w + } + } + } + $xhwm = $hwm if ($hwm > $xhwm); + $xs[2] = $sh if ($sh > $xs[2]); + $y += $h; + if ($r >= $frows) + { + $ys[3] += $h; + $yhwm++; + } + } + } + $t->{Bottom} = $yhwm; + $t->{Right} = $xhwm; + if (defined $xsb && $xs[2] > 0) + { + $xsb->MoveResizeWindow(@xs); + $cols -= $fcols; + if ($cols > 0) + { + $xsb->set($t->{Left}/$cols,$t->{Right}/$cols); + $xsb->MapWindow; + } + } + if (defined $ysb && $ys[3] > 0) + { + $ysb->MoveResizeWindow(@ys); + $rows -= $frows; + if ($rows > 0) + { + $ysb->set($t->{Top}/$rows,$t->{Bottom}/$rows); + $ysb->MapWindow; + } + } + } +} + +sub QueueLayout +{ + my ($m,$why) = @_; + $m->afterIdle(['Layout',$m]) unless ($m->{LayoutPending}); + $m->{LayoutPending} |= $why; +} + +sub SlaveGeometryRequest +{ + my ($m,$s) = @_; + my ($row,$col) = @{$m->{Slave}{$s->PathName}}; + my $sw = $s->ReqWidth; + my $sh = $s->ReqHeight; + my $sz = 0; + if ($sw > $m->{Width}[$col]) + { + $m->{Width}[$col] = $sw; + $m->QueueLayout(_SlaveSize); + $sz++; + } + if ( (not defined ($m->{Height}[$row])) or $sh > $m->{Height}[$row]) + { + $m->{Height}[$row] = $sh; + $m->QueueLayout(_SlaveSize); + $sz++; + } + if (!$sz) + { + $s->ResizeWindow($m->{Width}[$col],$m->{Height}[$row]); + } +} + +sub get +{ + my ($t,$row,$col) = @_; + return $t->{Row}[$row][$col]; +} + +sub LostSlave +{ + my ($t,$s) = @_; + my $info = delete $t->{Slave}{$s->PathName}; + if (defined $info) + { + my ($row,$col) = @$info; + $t->{Row}[$row][$col] = undef; + $s->UnmapWindow; + } + else + { + $t->BackTrace('Cannot find' . $s->PathName); + } + $t->QueueLayout(_SlaveChange); +} + +sub clear { + my $self = shift; + my $rows = $self->cget(-rows); + my $cols = $self->cget(-columns); + foreach my $r (1 .. $rows) { + foreach my $c (1 .. $cols) { + my $old = $self->get( $r, $c ); + next unless $old; + $self->LostSlave($old); + $old->destroy; + } + } + $self->_init; + $self->QueueLayout(_SlaveSize); +} + +sub _init { + my $self = shift; + $self->{'Width'} = []; + $self->{'Height'} = []; + $self->{'Row'} = []; + $self->{'Slave'} = {}; + $self->{'Top'} = 0; + $self->{'Left'} = 0; + $self->{'Bottom'} = 0; + $self->{'Right'} = 0; + $self->{LayoutPending} = 0; +} + +sub put +{ + my ($t,$row,$col,$w) = @_; + $w = $t->Label(-text => $w) unless (ref $w); + $t->ManageGeometry($w); + unless (defined $t->{Row}[$row]) + { + $t->{Row}[$row] = []; + $t->{Height}[$row] = 0; + } + unless (defined $t->{Width}[$col]) + { + $t->{Width}[$col] = 0; + } + my $old = $t->{Row}[$row][$col]; + if (defined $old) + { + $old->UnmanageGeometry; + $t->LostSlave($old); + } + $t->{Row}[$row][$col] = $w; + $t->{Slave}{$w->PathName} = [$row,$col]; + $t->SlaveGeometryRequest($w); + $t->QueueLayout(_SlaveChange); + return $old; +} + +# +# configure methods +# + +sub scrollbars +{ + my ($t,$v) = @_; + if (@_ > 1) + { + $t->_configure(-scrollbars => $v); + $t->QueueLayout(_ScrollBars); + } + return $t->_cget('-scrollbars'); +} + +sub rows +{ + my ($t,$r) = @_; + if (@_ > 1) + { + $t->_configure(-rows => $r); + if ($t->{Row} && @{$t->{Row}} > $r) + { + for my $y ($r .. $#{$t->{Row}}) + { + for my $s (@{$t->{Row}[$y]}) + { + $s->destroy if $s; + } + } + splice @{ $t->{Row} }, $r; + } + $t->QueueLayout(_RowColCount); + } + return $t->_cget('-rows'); +} + +sub fixedrows +{ + my ($t,$r) = @_; + if (@_ > 1) + { + $t->_configure(-fixedrows => $r); + $t->QueueLayout(_RowColCount); + } + return $t->_cget('-fixedrows'); +} + +sub columns +{ + my ($t,$r) = @_; + if (@_ > 1) + { + $t->_configure(-columns => $r); + if ($t->{Row}) + { + for my $row (@{$t->{Row}}) + { + for my $s (@$row[$r .. $#$row]) + { + $s->destroy if $s; + } + { # FIXME? - Steve was getting warnings : + # splice() offset past end of array + local $^W = 0; + splice @$row, $r; + } + } + } + $t->QueueLayout(_RowColCount); + } + return $t->_cget('-columns'); +} + +sub fixedcolumns +{ + my ($t,$r) = @_; + if (@_ > 1) + { + $t->_configure(-fixedcolumns => $r); + $t->QueueLayout(_RowColCount); + } + return $t->_cget('-fixedcolumns'); +} + +1; +__END__ +sub Create +{ + my $t = shift; + my $r = shift; + my $c = shift; + my $kind = shift; + $t->put($r,$c,$t->$kind(@_)); +} + +sub totalColumns +{ + scalar @{shift->{'Width'}}; +} + +sub totalRows +{ + scalar @{shift->{'Height'}}; +} + +sub Posn +{ + my ($t,$s) = @_; + my $info = $t->{Slave}{$s->PathName}; + return (wantarray) ? @$info : $info; +} + +sub see +{ + my $t = shift; + my ($row,$col) = (@_ == 2) ? @_ : @{$t->{Slave}{$_[0]->PathName}}; + my $see = 1; + if (($row -= $t->cget('-fixedrows')) >= 0) + { + if ($row < $t->{Top}) + { + $t->{Top} = $row; + $t->QueueLayout(_ViewChange); + $see = 0; + } + elsif ($row >= $t->{Bottom}) + { + $t->{Top} += ($row - $t->{Bottom}+1); + $t->QueueLayout(_ViewChange); + $see = 0; + } + } + if (($col -= $t->cget('-fixedcolumns')) >= 0) + { + if ($col < $t->{Left}) + { + $t->{Left} = $col; + $t->QueueLayout(_ViewChange); + $see = 0; + } + elsif ($col >= $t->{Right}) + { + $t->{Left} += ($col - $t->{Right}+1); + $t->QueueLayout(_ViewChange); + $see = 0; + } + } + return $see; +} + +=cut + diff --git a/Master/tlpkg/tlperl/lib/Tk/Text.pm b/Master/tlpkg/tlperl/lib/Tk/Text.pm new file mode 100644 index 00000000000..fe0aa0bf4c1 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Text.pm @@ -0,0 +1,1653 @@ +# text.tcl -- +# +# This file defines the default bindings for Tk text widgets. +# +# @(#) text.tcl 1.18 94/12/17 16:05:26 +# +# Copyright (c) 1992-1994 The Regents of the University of California. +# Copyright (c) 1994 Sun Microsystems, Inc. +# perl/Tk version: +# Copyright (c) 1995-2004 Nick Ing-Simmons +# Copyright (c) 1999 Greg London +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +package Tk::Text; +use AutoLoader; +use Carp; +use strict; + +use Text::Tabs; + +use vars qw($VERSION); +$VERSION = sprintf '4.%03d', q$Revision: #24 $ =~ /\D(\d+)\s*$/; + +use Tk qw(Ev $XS_VERSION); +use base qw(Tk::Clipboard Tk::Widget); + +Construct Tk::Widget 'Text'; + +bootstrap Tk::Text; + +sub Tk_cmd { \&Tk::text } + +sub Tk::Widget::ScrlText { shift->Scrolled('Text' => @_) } + +Tk::Methods('bbox','compare','debug','delete','dlineinfo','dump','edit', + 'get','image','index','insert','mark','scan','search', + 'see','tag','window','xview','yview'); + +use Tk::Submethods ( 'mark' => [qw(gravity names next previous set unset)], + 'scan' => [qw(mark dragto)], + 'tag' => [qw(add bind cget configure delete lower + names nextrange prevrange raise ranges remove)], + 'window' => [qw(cget configure create names)], + 'image' => [qw(cget configure create names)], + 'xview' => [qw(moveto scroll)], + 'yview' => [qw(moveto scroll)], + 'edit' => [qw(modified redo reset separator undo)], + ); + +sub Tag; +sub Tags; + +sub bindRdOnly +{ + + my ($class,$mw) = @_; + + # Standard Motif bindings: + $mw->bind($class,'<Meta-B1-Motion>','NoOp'); + $mw->bind($class,'<Meta-1>','NoOp'); + $mw->bind($class,'<Alt-KeyPress>','NoOp'); + $mw->bind($class,'<Escape>','unselectAll'); + + $mw->bind($class,'<1>',['Button1',Ev('x'),Ev('y')]); + $mw->bind($class,'<B1-Motion>','B1_Motion' ) ; + $mw->bind($class,'<B1-Leave>','B1_Leave' ) ; + $mw->bind($class,'<B1-Enter>','CancelRepeat'); + $mw->bind($class,'<ButtonRelease-1>','CancelRepeat'); + $mw->bind($class,'<Control-1>',['markSet','insert',Ev('@')]); + + $mw->bind($class,'<Double-1>','selectWord' ) ; + $mw->bind($class,'<Triple-1>','selectLine' ) ; + $mw->bind($class,'<Shift-1>','adjustSelect' ) ; + $mw->bind($class,'<Double-Shift-1>',['SelectTo',Ev('@'),'word']); + $mw->bind($class,'<Triple-Shift-1>',['SelectTo',Ev('@'),'line']); + + $mw->bind($class,'<Left>',['SetCursor',Ev('index','insert-1c')]); + $mw->bind($class,'<Shift-Left>',['KeySelect',Ev('index','insert-1c')]); + $mw->bind($class,'<Control-Left>',['SetCursor',Ev('index','insert-1c wordstart')]); + $mw->bind($class,'<Shift-Control-Left>',['KeySelect',Ev('index','insert-1c wordstart')]); + + $mw->bind($class,'<Right>',['SetCursor',Ev('index','insert+1c')]); + $mw->bind($class,'<Shift-Right>',['KeySelect',Ev('index','insert+1c')]); + $mw->bind($class,'<Control-Right>',['SetCursor',Ev('index','insert+1c wordend')]); + $mw->bind($class,'<Shift-Control-Right>',['KeySelect',Ev('index','insert wordend')]); + + $mw->bind($class,'<Up>',['SetCursor',Ev('UpDownLine',-1)]); + $mw->bind($class,'<Shift-Up>',['KeySelect',Ev('UpDownLine',-1)]); + $mw->bind($class,'<Control-Up>',['SetCursor',Ev('PrevPara','insert')]); + $mw->bind($class,'<Shift-Control-Up>',['KeySelect',Ev('PrevPara','insert')]); + + $mw->bind($class,'<Down>',['SetCursor',Ev('UpDownLine',1)]); + $mw->bind($class,'<Shift-Down>',['KeySelect',Ev('UpDownLine',1)]); + $mw->bind($class,'<Control-Down>',['SetCursor',Ev('NextPara','insert')]); + $mw->bind($class,'<Shift-Control-Down>',['KeySelect',Ev('NextPara','insert')]); + + $mw->bind($class,'<Home>',['SetCursor','insert linestart']); + $mw->bind($class,'<Shift-Home>',['KeySelect','insert linestart']); + $mw->bind($class,'<Control-Home>',['SetCursor','1.0']); + $mw->bind($class,'<Control-Shift-Home>',['KeySelect','1.0']); + + $mw->bind($class,'<End>',['SetCursor','insert lineend']); + $mw->bind($class,'<Shift-End>',['KeySelect','insert lineend']); + $mw->bind($class,'<Control-End>',['SetCursor','end-1char']); + $mw->bind($class,'<Control-Shift-End>',['KeySelect','end-1char']); + + $mw->bind($class,'<Prior>',['SetCursor',Ev('ScrollPages',-1)]); + $mw->bind($class,'<Shift-Prior>',['KeySelect',Ev('ScrollPages',-1)]); + $mw->bind($class,'<Control-Prior>',['xview','scroll',-1,'page']); + + $mw->bind($class,'<Next>',['SetCursor',Ev('ScrollPages',1)]); + $mw->bind($class,'<Shift-Next>',['KeySelect',Ev('ScrollPages',1)]); + $mw->bind($class,'<Control-Next>',['xview','scroll',1,'page']); + + $mw->bind($class,'<Shift-Tab>', 'NoOp'); # Needed only to keep <Tab> binding from triggering; does not have to actually do anything. + $mw->bind($class,'<Control-Tab>','focusNext'); + $mw->bind($class,'<Control-Shift-Tab>','focusPrev'); + + $mw->bind($class,'<Control-space>',['markSet','anchor','insert']); + $mw->bind($class,'<Select>',['markSet','anchor','insert']); + $mw->bind($class,'<Control-Shift-space>',['SelectTo','insert','char']); + $mw->bind($class,'<Shift-Select>',['SelectTo','insert','char']); + $mw->bind($class,'<Control-slash>','selectAll'); + $mw->bind($class,'<Control-backslash>','unselectAll'); + + if (!$Tk::strictMotif) + { + $mw->bind($class,'<Control-a>', ['SetCursor','insert linestart']); + $mw->bind($class,'<Control-b>', ['SetCursor','insert-1c']); + $mw->bind($class,'<Control-e>', ['SetCursor','insert lineend']); + $mw->bind($class,'<Control-f>', ['SetCursor','insert+1c']); + $mw->bind($class,'<Meta-b>', ['SetCursor','insert-1c wordstart']); + $mw->bind($class,'<Meta-f>', ['SetCursor','insert wordend']); + $mw->bind($class,'<Meta-less>', ['SetCursor','1.0']); + $mw->bind($class,'<Meta-greater>', ['SetCursor','end-1c']); + + $mw->bind($class,'<Control-n>', ['SetCursor',Ev('UpDownLine',1)]); + $mw->bind($class,'<Control-p>', ['SetCursor',Ev('UpDownLine',-1)]); + + $mw->bind($class,'<2>',['Button2',Ev('x'),Ev('y')]); + $mw->bind($class,'<B2-Motion>',['Motion2',Ev('x'),Ev('y')]); + } + $mw->bind($class,'<Destroy>','Destroy'); + $mw->bind($class, '<3>', ['PostPopupMenu', Ev('X'), Ev('Y')] ); + $mw->YMouseWheelBind($class); + $mw->XMouseWheelBind($class); + + $mw->MouseWheelBind($class); + + return $class; +} + +sub selectAll +{ + my ($w) = @_; + $w->tagAdd('sel','1.0','end'); +} + +sub unselectAll +{ + my ($w) = @_; + $w->tagRemove('sel','1.0','end'); +} + +sub adjustSelect +{ + my ($w) = @_; + my $Ev = $w->XEvent; + $w->ResetAnchor($Ev->xy); + $w->SelectTo($Ev->xy,'char') +} + +sub selectLine +{ + my ($w) = @_; + my $Ev = $w->XEvent; + $w->SelectTo($Ev->xy,'line'); + Tk::catch { $w->markSet('insert','sel.first') }; +} + +sub selectWord +{ + my ($w) = @_; + my $Ev = $w->XEvent; + $w->SelectTo($Ev->xy,'word'); + Tk::catch { $w->markSet('insert','sel.first') } +} + +sub ClassInit +{ + my ($class,$mw) = @_; + $class->SUPER::ClassInit($mw); + + $class->bindRdOnly($mw); + + $mw->bind($class,'<Tab>', 'insertTab'); + $mw->bind($class,'<Control-i>', ['Insert',"\t"]); + $mw->bind($class,'<Return>', ['Insert',"\n"]); + $mw->bind($class,'<Delete>','Delete'); + $mw->bind($class,'<BackSpace>','Backspace'); + $mw->bind($class,'<Insert>', \&ToggleInsertMode ) ; + $mw->bind($class,'<KeyPress>',['InsertKeypress',Ev('A')]); + + $mw->bind($class,'<F1>', 'clipboardColumnCopy'); + $mw->bind($class,'<F2>', 'clipboardColumnCut'); + $mw->bind($class,'<F3>', 'clipboardColumnPaste'); + + # Additional emacs-like bindings: + + if (!$Tk::strictMotif) + { + $mw->bind($class,'<Control-d>',['delete','insert']); + $mw->bind($class,'<Control-k>','deleteToEndofLine') ; + $mw->bind($class,'<Control-o>','openLine'); + $mw->bind($class,'<Control-t>','Transpose'); + $mw->bind($class,'<Meta-d>',['delete','insert','insert wordend']); + $mw->bind($class,'<Meta-BackSpace>',['delete','insert-1c wordstart','insert']); + + # A few additional bindings of my own. + $mw->bind($class,'<Control-h>','deleteBefore'); + $mw->bind($class,'<ButtonRelease-2>','ButtonRelease2'); + } +#JD# $Tk::prevPos = undef; + return $class; +} + +sub insertTab +{ + my ($w) = @_; + $w->Insert("\t"); + $w->focus; + $w->break +} + +sub deleteToEndofLine +{ + my ($w) = @_; + if ($w->compare('insert','==','insert lineend')) + { + $w->delete('insert') + } + else + { + $w->delete('insert','insert lineend') + } +} + +sub openLine +{ + my ($w) = @_; + $w->insert('insert',"\n"); + $w->markSet('insert','insert-1c') +} + +sub Button2 +{ + my ($w,$x,$y) = @_; + $w->scan('mark',$x,$y); + $Tk::x = $x; + $Tk::y = $y; + $Tk::mouseMoved = 0; +} + +sub Motion2 +{ + my ($w,$x,$y) = @_; + $Tk::mouseMoved = 1 if ($x != $Tk::x || $y != $Tk::y); + $w->scan('dragto',$x,$y) if ($Tk::mouseMoved); +} + +sub ButtonRelease2 +{ + my ($w) = @_; + my $Ev = $w->XEvent; + if (!$Tk::mouseMoved) + { + Tk::catch { $w->insert($Ev->xy,$w->SelectionGet) } + } +} + +sub InsertSelection +{ + my ($w) = @_; + Tk::catch { $w->Insert($w->SelectionGet) } +} + +sub Backspace +{ + my ($w) = @_; + my $sel = Tk::catch { $w->tag('nextrange','sel','1.0','end') }; + if (defined $sel) + { + $w->delete('sel.first','sel.last'); + return; + } + $w->deleteBefore; +} + +sub deleteBefore +{ + my ($w) = @_; + if ($w->compare('insert','!=','1.0')) + { + $w->delete('insert-1c'); + $w->see('insert') + } +} + +sub Delete +{ + my ($w) = @_; + my $sel = Tk::catch { $w->tag('nextrange','sel','1.0','end') }; + if (defined $sel) + { + $w->delete('sel.first','sel.last') + } + else + { + $w->delete('insert'); + $w->see('insert') + } +} + +# Button1 -- +# This procedure is invoked to handle button-1 presses in text +# widgets. It moves the insertion cursor, sets the selection anchor, +# and claims the input focus. +# +# Arguments: +# w - The text window in which the button was pressed. +# x - The x-coordinate of the button press. +# y - The x-coordinate of the button press. +sub Button1 +{ + my ($w,$x,$y) = @_; + $Tk::selectMode = 'char'; + $Tk::mouseMoved = 0; + $w->SetCursor('@'.$x.','.$y); + $w->markSet('anchor','insert'); + $w->focus() if ($w->cget('-state') eq 'normal'); +} + +sub B1_Motion +{ + my ($w) = @_; + return unless defined $Tk::mouseMoved; + my $Ev = $w->XEvent; + $Tk::x = $Ev->x; + $Tk::y = $Ev->y; + $w->SelectTo($Ev->xy) +} + +sub B1_Leave +{ + my ($w) = @_; + my $Ev = $w->XEvent; + $Tk::x = $Ev->x; + $Tk::y = $Ev->y; + $w->AutoScan; +} + +# SelectTo -- +# This procedure is invoked to extend the selection, typically when +# dragging it with the mouse. Depending on the selection mode (character, +# word, line) it selects in different-sized units. This procedure +# ignores mouse motions initially until the mouse has moved from +# one character to another or until there have been multiple clicks. +# +# Arguments: +# w - The text window in which the button was pressed. +# index - Index of character at which the mouse button was pressed. +sub SelectTo +{ + my ($w, $index, $mode)= @_; + $Tk::selectMode = $mode if defined ($mode); + my $cur = $w->index($index); + my $anchor = Tk::catch { $w->index('anchor') }; + if (!defined $anchor) + { + $w->markSet('anchor',$anchor = $cur); + $Tk::mouseMoved = 0; + } + elsif ($w->compare($cur,'!=',$anchor)) + { + $Tk::mouseMoved = 1; + } + $Tk::selectMode = 'char' unless (defined $Tk::selectMode); + $mode = $Tk::selectMode; + my ($first,$last); + if ($mode eq 'char') + { + if ($w->compare($cur,'<','anchor')) + { + $first = $cur; + $last = 'anchor'; + } + else + { + $first = 'anchor'; + $last = $cur + } + } + elsif ($mode eq 'word') + { + if ($w->compare($cur,'<','anchor')) + { + $first = $w->index("$cur wordstart"); + $last = $w->index('anchor - 1c wordend') + } + else + { + $first = $w->index('anchor wordstart'); + $last = $w->index("$cur wordend") + } + } + elsif ($mode eq 'line') + { + if ($w->compare($cur,'<','anchor')) + { + $first = $w->index("$cur linestart"); + $last = $w->index('anchor - 1c lineend + 1c') + } + else + { + $first = $w->index('anchor linestart'); + $last = $w->index("$cur lineend + 1c") + } + } + if ($Tk::mouseMoved || $Tk::selectMode ne 'char') + { + $w->tagRemove('sel','1.0',$first); + $w->tagAdd('sel',$first,$last); + $w->tagRemove('sel',$last,'end'); + $w->idletasks; + } +} +# AutoScan -- +# This procedure is invoked when the mouse leaves a text window +# with button 1 down. It scrolls the window up, down, left, or right, +# depending on where the mouse is (this information was saved in +# tkPriv(x) and tkPriv(y)), and reschedules itself as an 'after' +# command so that the window continues to scroll until the mouse +# moves back into the window or the mouse button is released. +# +# Arguments: +# w - The text window. +sub AutoScan +{ + my ($w) = @_; + if ($Tk::y >= $w->height) + { + $w->yview('scroll',2,'units') + } + elsif ($Tk::y < 0) + { + $w->yview('scroll',-2,'units') + } + elsif ($Tk::x >= $w->width) + { + $w->xview('scroll',2,'units') + } + elsif ($Tk::x < 0) + { + $w->xview('scroll',-2,'units') + } + else + { + return; + } + $w->SelectTo('@' . $Tk::x . ','. $Tk::y); + $w->RepeatId($w->after(50,['AutoScan',$w])); +} +# SetCursor +# Move the insertion cursor to a given position in a text. Also +# clears the selection, if there is one in the text, and makes sure +# that the insertion cursor is visible. +# +# Arguments: +# w - The text window. +# pos - The desired new position for the cursor in the window. +sub SetCursor +{ + my ($w,$pos) = @_; + $pos = 'end - 1 chars' if $w->compare($pos,'==','end'); + $w->markSet('insert',$pos); + $w->unselectAll; + $w->see('insert'); +} +# KeySelect +# This procedure is invoked when stroking out selections using the +# keyboard. It moves the cursor to a new position, then extends +# the selection to that position. +# +# Arguments: +# w - The text window. +# new - A new position for the insertion cursor (the cursor has not +# actually been moved to this position yet). +sub KeySelect +{ + my ($w,$new) = @_; + my ($first,$last); + if (!defined $w->tag('ranges','sel')) + { + # No selection yet + $w->markSet('anchor','insert'); + if ($w->compare($new,'<','insert')) + { + $w->tagAdd('sel',$new,'insert') + } + else + { + $w->tagAdd('sel','insert',$new) + } + } + else + { + # Selection exists + if ($w->compare($new,'<','anchor')) + { + $first = $new; + $last = 'anchor' + } + else + { + $first = 'anchor'; + $last = $new + } + $w->tagRemove('sel','1.0',$first); + $w->tagAdd('sel',$first,$last); + $w->tagRemove('sel',$last,'end') + } + $w->markSet('insert',$new); + $w->see('insert'); + $w->idletasks; +} +# ResetAnchor -- +# Set the selection anchor to whichever end is farthest from the +# index argument. One special trick: if the selection has two or +# fewer characters, just leave the anchor where it is. In this +# case it does not matter which point gets chosen for the anchor, +# and for the things like Shift-Left and Shift-Right this produces +# better behavior when the cursor moves back and forth across the +# anchor. +# +# Arguments: +# w - The text widget. +# index - Position at which mouse button was pressed, which determines +# which end of selection should be used as anchor point. +sub ResetAnchor +{ + my ($w,$index) = @_; + if (!defined $w->tag('ranges','sel')) + { + $w->markSet('anchor',$index); + return; + } + my $a = $w->index($index); + my $b = $w->index('sel.first'); + my $c = $w->index('sel.last'); + if ($w->compare($a,'<',$b)) + { + $w->markSet('anchor','sel.last'); + return; + } + if ($w->compare($a,'>',$c)) + { + $w->markSet('anchor','sel.first'); + return; + } + my ($lineA,$chA) = split(/\./,$a); + my ($lineB,$chB) = split(/\./,$b); + my ($lineC,$chC) = split(/\./,$c); + if ($lineB < $lineC+2) + { + my $total = length($w->get($b,$c)); + if ($total <= 2) + { + return; + } + if (length($w->get($b,$a)) < $total/2) + { + $w->markSet('anchor','sel.last') + } + else + { + $w->markSet('anchor','sel.first') + } + return; + } + if ($lineA-$lineB < $lineC-$lineA) + { + $w->markSet('anchor','sel.last') + } + else + { + $w->markSet('anchor','sel.first') + } +} + +######################################################################## +sub markExists +{ + my ($w, $markname)=@_; + my $mark_exists=0; + my @markNames_list = $w->markNames; + foreach my $mark (@markNames_list) + { if ($markname eq $mark) {$mark_exists=1;last;} } + return $mark_exists; +} + +######################################################################## +sub OverstrikeMode +{ + my ($w,$mode) = @_; + + $w->{'OVERSTRIKE_MODE'} =0 unless exists($w->{'OVERSTRIKE_MODE'}); + + $w->{'OVERSTRIKE_MODE'}=$mode if (@_ > 1); + + return $w->{'OVERSTRIKE_MODE'}; +} + +######################################################################## +# pressed the <Insert> key, just above 'Del' key. +# this toggles between insert mode and overstrike mode. +sub ToggleInsertMode +{ + my ($w)=@_; + $w->OverstrikeMode(!$w->OverstrikeMode); +} + +######################################################################## +sub InsertKeypress +{ + my ($w,$char)=@_; + return unless length($char); + if ($w->OverstrikeMode) + { + my $current=$w->get('insert'); + $w->delete('insert') unless($current eq "\n"); + } + $w->Insert($char); +} + +######################################################################## +sub GotoLineNumber +{ + my ($w,$line_number) = @_; + $line_number=~ s/^\s+|\s+$//g; + return if $line_number =~ m/\D/; + my ($last_line,$junk) = split(/\./, $w->index('end')); + if ($line_number > $last_line) {$line_number = $last_line; } + $w->{'LAST_GOTO_LINE'} = $line_number; + $w->markSet('insert', $line_number.'.0'); + $w->see('insert'); +} + +######################################################################## +sub GotoLineNumberPopUp +{ + my ($w)=@_; + my $popup = $w->{'GOTO_LINE_NUMBER_POPUP'}; + + unless (defined($w->{'LAST_GOTO_LINE'})) + { + my ($line,$col) = split(/\./, $w->index('insert')); + $w->{'LAST_GOTO_LINE'} = $line; + } + + ## if anything is selected when bring up the pop-up, put it in entry window. + my $selected; + eval { $selected = $w->SelectionGet(-selection => "PRIMARY"); }; + unless ($@) + { + if (defined($selected) and length($selected)) + { + unless ($selected =~ /\D/) + { + $w->{'LAST_GOTO_LINE'} = $selected; + } + } + } + unless (defined($popup)) + { + require Tk::DialogBox; + $popup = $w->DialogBox(-buttons => [qw[Ok Cancel]],-title => "Goto Line Number", -popover => $w, + -command => sub { $w->GotoLineNumber($w->{'LAST_GOTO_LINE'}) if $_[0] eq 'Ok'}); + $w->{'GOTO_LINE_NUMBER_POPUP'}=$popup; + $popup->resizable('no','no'); + my $frame = $popup->Frame->pack(-fill => 'x'); + $frame->Label(-text=>'Enter line number: ')->pack(-side => 'left'); + my $entry = $frame->Entry(-background=>'white', -width=>25, + -textvariable => \$w->{'LAST_GOTO_LINE'})->pack(-side =>'left',-fill => 'x'); + $popup->Advertise(entry => $entry); + } + $popup->Popup; + $popup->Subwidget('entry')->focus; + $popup->Wait; +} + +######################################################################## + +sub getSelected +{ + shift->GetTextTaggedWith('sel'); +} + +sub deleteSelected +{ + shift->DeleteTextTaggedWith('sel'); +} + +sub GetTextTaggedWith +{ + my ($w,$tag) = @_; + + my @ranges = $w->tagRanges($tag); + my $range_total = @ranges; + my $return_text=''; + + # if nothing selected, then ignore + if ($range_total == 0) {return $return_text;} + + # for every range-pair, get selected text + while(@ranges) + { + my $first = shift(@ranges); + my $last = shift(@ranges); + my $text = $w->get($first , $last); + if(defined($text)) + {$return_text = $return_text . $text;} + # if there is more tagged text, separate with an end of line character + if(@ranges) + {$return_text = $return_text . "\n";} + } + return $return_text; +} + +######################################################################## +sub DeleteTextTaggedWith +{ + my ($w,$tag) = @_; + my @ranges = $w->tagRanges($tag); + my $range_total = @ranges; + + # if nothing tagged with that tag, then ignore + if ($range_total == 0) {return;} + + # insert marks where selections are located + # marks will move with text even as text is inserted and deleted + # in a previous selection. + for (my $i=0; $i<$range_total; $i++) + { $w->markSet('mark_tag_'.$i => $ranges[$i]); } + + # for every selected mark pair, insert new text and delete old text + for (my $i=0; $i<$range_total; $i=$i+2) + { + my $first = $w->index('mark_tag_'.$i); + my $last = $w->index('mark_tag_'.($i+1)); + + my $text = $w->delete($first , $last); + } + + # delete the marks + for (my $i=0; $i<$range_total; $i++) + { $w->markUnset('mark_tag_'.$i); } +} + + +######################################################################## +sub FindAll +{ + my ($w,$mode, $case, $pattern ) = @_; + ### 'sel' tags accumulate, need to remove any previous existing + $w->unselectAll; + + my $match_length=0; + my $start_index; + my $end_index = '1.0'; + + while(defined($end_index)) + { + if ($case eq '-nocase') + { + $start_index = $w->search( + $mode, + $case, + -count => \$match_length, + "--", + $pattern , + $end_index, + 'end'); + } + else + { + $start_index = $w->search( + $mode, + -count => \$match_length, + "--", + $pattern , + $end_index, + 'end'); + } + + unless(defined($start_index) && $start_index) {last;} + + my ($line,$col) = split(/\./, $start_index); + $col = $col + $match_length; + $end_index = $line.'.'.$col; + $w->tagAdd('sel', $start_index, $end_index); + } +} + +######################################################################## +# get current selected text and search for the next occurrence +sub FindSelectionNext +{ + my ($w) = @_; + my $selected; + eval {$selected = $w->SelectionGet(-selection => "PRIMARY"); }; + return if($@); + return unless (defined($selected) and length($selected)); + + $w->FindNext('-forward', '-exact', '-case', $selected); +} + +######################################################################## +# get current selected text and search for the previous occurrence +sub FindSelectionPrevious +{ + my ($w) = @_; + my $selected; + eval {$selected = $w->SelectionGet(-selection => "PRIMARY"); }; + return if($@); + return unless (defined($selected) and length($selected)); + + $w->FindNext('-backward', '-exact', '-case', $selected); +} + + + +######################################################################## +sub FindNext +{ + my ($w,$direction, $mode, $case, $pattern ) = @_; + + ## if searching forward, start search at end of selected block + ## if backward, start search from start of selected block. + ## dont want search to find currently selected text. + ## tag 'sel' may not be defined, use eval loop to trap error + eval { + if ($direction eq '-forward') + { + $w->markSet('insert', 'sel.last'); + $w->markSet('current', 'sel.last'); + } + else + { + $w->markSet('insert', 'sel.first'); + $w->markSet('current', 'sel.first'); + } + }; + + my $saved_index=$w->index('insert'); + + # remove any previous existing tags + $w->unselectAll; + + my $match_length=0; + my $start_index; + + if ($case eq '-nocase') + { + $start_index = $w->search( + $direction, + $mode, + $case, + -count => \$match_length, + "--", + $pattern , + 'insert'); + } + else + { + $start_index = $w->search( + $direction, + $mode, + -count => \$match_length, + "--", + $pattern , + 'insert'); + } + + unless(defined($start_index)) { return 0; } + if(length($start_index) == 0) { return 0; } + + my ($line,$col) = split(/\./, $start_index); + $col = $col + $match_length; + my $end_index = $line.'.'.$col; + $w->tagAdd('sel', $start_index, $end_index); + + $w->see($start_index); + + if ($direction eq '-forward') + { + $w->markSet('insert', $end_index); + $w->markSet('current', $end_index); + } + else + { + $w->markSet('insert', $start_index); + $w->markSet('current', $start_index); + } + + my $compared_index = $w->index('insert'); + + my $ret_val; + if ($compared_index eq $saved_index) + {$ret_val=0;} + else + {$ret_val=1;} + return $ret_val; +} + +######################################################################## +sub FindAndReplaceAll +{ + my ($w,$mode, $case, $find, $replace ) = @_; + $w->markSet('insert', '1.0'); + $w->unselectAll; + while($w->FindNext('-forward', $mode, $case, $find)) + { + $w->ReplaceSelectionsWith($replace); + } +} + +######################################################################## +sub ReplaceSelectionsWith +{ + my ($w,$new_text ) = @_; + + my @ranges = $w->tagRanges('sel'); + my $range_total = @ranges; + + # if nothing selected, then ignore + if ($range_total == 0) {return}; + + # insert marks where selections are located + # marks will move with text even as text is inserted and deleted + # in a previous selection. + for (my $i=0; $i<$range_total; $i++) + {$w->markSet('mark_sel_'.$i => $ranges[$i]); } + + # for every selected mark pair, insert new text and delete old text + my ($first, $last); + for (my $i=0; $i<$range_total; $i=$i+2) + { + $first = $w->index('mark_sel_'.$i); + $last = $w->index('mark_sel_'.($i+1)); + + ########################################################################## + # eventually, want to be able to get selected text, + # support regular expression matching, determine replace_text + # $replace_text = $selected_text=~m/$new_text/ (or whatever would work) + # will have to pass in mode and case flags. + # this would allow a regular expression search and replace to be performed + # example, look for "line (\d+):" and replace with "$1 >" or similar + ########################################################################## + + $w->insert($last, $new_text); + $w->delete($first, $last); + + } + ############################################################ + # set the insert cursor to the end of the last insertion mark + $w->markSet('insert',$w->index('mark_sel_'.($range_total-1))); + + # delete the marks + for (my $i=0; $i<$range_total; $i++) + { $w->markUnset('mark_sel_'.$i); } +} +######################################################################## +sub FindAndReplacePopUp +{ + my ($w)=@_; + $w->findandreplacepopup(0); +} + +######################################################################## +sub FindPopUp +{ + my ($w)=@_; + $w->findandreplacepopup(1); +} + +######################################################################## + +sub findandreplacepopup +{ + my ($w,$find_only)=@_; + + my $pop = $w->Toplevel; + $pop->transient($w->toplevel); + if ($find_only) + { $pop->title("Find"); } + else + { $pop->title("Find and/or Replace"); } + my $frame = $pop->Frame->pack(-anchor=>'nw'); + + $frame->Label(-text=>"Direction:") + ->grid(-row=> 1, -column=>1, -padx=> 20, -sticky => 'nw'); + my $direction = '-forward'; + $frame->Radiobutton( + -variable => \$direction, + -text => 'forward',-value => '-forward' ) + ->grid(-row=> 2, -column=>1, -padx=> 20, -sticky => 'nw'); + $frame->Radiobutton( + -variable => \$direction, + -text => 'backward',-value => '-backward' ) + ->grid(-row=> 3, -column=>1, -padx=> 20, -sticky => 'nw'); + + $frame->Label(-text=>"Mode:") + ->grid(-row=> 1, -column=>2, -padx=> 20, -sticky => 'nw'); + my $mode = '-exact'; + $frame->Radiobutton( + -variable => \$mode, -text => 'exact',-value => '-exact' ) + ->grid(-row=> 2, -column=>2, -padx=> 20, -sticky => 'nw'); + $frame->Radiobutton( + -variable => \$mode, -text => 'regexp',-value => '-regexp' ) + ->grid(-row=> 3, -column=>2, -padx=> 20, -sticky => 'nw'); + + $frame->Label(-text=>"Case:") + ->grid(-row=> 1, -column=>3, -padx=> 20, -sticky => 'nw'); + my $case = '-case'; + $frame->Radiobutton( + -variable => \$case, -text => 'case',-value => '-case' ) + ->grid(-row=> 2, -column=>3, -padx=> 20, -sticky => 'nw'); + $frame->Radiobutton( + -variable => \$case, -text => 'nocase',-value => '-nocase' ) + ->grid(-row=> 3, -column=>3, -padx=> 20, -sticky => 'nw'); + + ###################################################### + my $find_entry = $pop->Entry(-width=>25); + $find_entry->focus; + + my $donext = sub {$w->FindNext ($direction,$mode,$case,$find_entry->get())}; + + $find_entry -> pack(-anchor=>'nw', '-expand' => 'yes' , -fill => 'x'); # autosizing + + ###### if any $w text is selected, put it in the find entry + ###### could be more than one text block selected, get first selection + my @ranges = $w->tagRanges('sel'); + if (@ranges) + { + my $first = shift(@ranges); + my $last = shift(@ranges); + + # limit to one line + my ($first_line, $first_col) = split(/\./,$first); + my ($last_line, $last_col) = split(/\./,$last); + unless($first_line == $last_line) + {$last = $first. ' lineend';} + + $find_entry->insert('insert', $w->get($first , $last)); + } + else + { + my $selected; + eval {$selected=$w->SelectionGet(-selection => "PRIMARY"); }; + if($@) {} + elsif (defined($selected)) + {$find_entry->insert('insert', $selected);} + } + + $find_entry->icursor(0); + + my ($replace_entry,$button_replace,$button_replace_all); + unless ($find_only) + { + $replace_entry = $pop->Entry(-width=>25); + + $replace_entry -> pack(-anchor=>'nw', '-expand' => 'yes' , -fill => 'x'); + } + + + my $button_find = $pop->Button(-text=>'Find', -command => $donext, -default => 'active') + -> pack(-side => 'left'); + + my $button_find_all = $pop->Button(-text=>'Find All', + -command => sub {$w->FindAll($mode,$case,$find_entry->get());} ) + ->pack(-side => 'left'); + + unless ($find_only) + { + $button_replace = $pop->Button(-text=>'Replace', -default => 'normal', + -command => sub {$w->ReplaceSelectionsWith($replace_entry->get());} ) + -> pack(-side =>'left'); + $button_replace_all = $pop->Button(-text=>'Replace All', + -command => sub {$w->FindAndReplaceAll + ($mode,$case,$find_entry->get(),$replace_entry->get());} ) + ->pack(-side => 'left'); + } + + + my $button_cancel = $pop->Button(-text=>'Cancel', + -command => sub {$pop->destroy()} ) + ->pack(-side => 'left'); + + $find_entry->bind("<Return>" => [$button_find, 'invoke']); + $find_entry->bind("<Escape>" => [$button_cancel, 'invoke']); + + $find_entry->bind("<Return>" => [$button_find, 'invoke']); + $find_entry->bind("<Escape>" => [$button_cancel, 'invoke']); + + $pop->resizable('yes','no'); + return $pop; +} + +# paste clipboard into current location +sub clipboardPaste +{ + my ($w) = @_; + local $@; + Tk::catch { $w->Insert($w->clipboardGet) }; +} + +######################################################################## +# Insert -- +# Insert a string into a text at the point of the insertion cursor. +# If there is a selection in the text, and it covers the point of the +# insertion cursor, then delete the selection before inserting. +# +# Arguments: +# w - The text window in which to insert the string +# string - The string to insert (usually just a single character) +sub Insert +{ + my ($w,$string) = @_; + return unless (defined $string && $string ne ''); + #figure out if cursor is inside a selection + my @ranges = $w->tagRanges('sel'); + if (@ranges) + { + while (@ranges) + { + my ($first,$last) = splice(@ranges,0,2); + if ($w->compare($first,'<=','insert') && $w->compare($last,'>=','insert')) + { + $w->ReplaceSelectionsWith($string); + return; + } + } + } + # paste it at the current cursor location + $w->insert('insert',$string); + $w->see('insert'); +} + +# UpDownLine -- +# Returns the index of the character one *display* line above or below the +# insertion cursor. There are two tricky things here. First, +# we want to maintain the original column across repeated operations, +# even though some lines that will get passed through do not have +# enough characters to cover the original column. Second, do not +# try to scroll past the beginning or end of the text. +# +# This may have some weirdness associated with a proportional font. Ie. +# the insertion cursor will zigzag up or down according to the width of +# the character at destination. +# +# Arguments: +# w - The text window in which the cursor is to move. +# n - The number of lines to move: -1 for up one line, +# +1 for down one line. +sub UpDownLine +{ +my ($w,$n) = @_; +$w->see('insert'); +my $i = $w->index('insert'); + +my ($line,$char) = split(/\./,$i); + +my $testX; #used to check the "new" position +my $testY; #used to check the "new" position + +(my $bx, my $by, my $bw, my $bh) = $w->bbox($i); +(my $lx, my $ly, my $lw, my $lh) = $w->dlineinfo($i); + +if ( ($n == -1) and ($by <= $bh) ) + { + #On first display line.. so scroll up and recalculate.. + $w->yview('scroll', -1, 'units'); + unless (($w->yview)[0]) { + #first line of entire text - keep same position. + return $i; + } + ($bx, $by, $bw, $bh) = $w->bbox($i); + ($lx, $ly, $lw, $lh) = $w->dlineinfo($i); + } +elsif ( ($n == 1) and + ($ly + $lh) > ( $w->height - 2*$w->cget(-bd) - 2*$w->cget(-highlightthickness) ) ) + { + #On last display line.. so scroll down and recalculate.. + $w->yview('scroll', 1, 'units'); + ($bx, $by, $bw, $bh) = $w->bbox($i); + ($lx, $ly, $lw, $lh) = $w->dlineinfo($i); + } + +# Calculate the vertical position of the next display line +my $Yoffset = 0; +$Yoffset = $by - $ly + 1 if ($n== -1); +$Yoffset = $ly + $lh + 1 - $by if ($n == 1); +$Yoffset*=$n; +$testY = $by + $Yoffset; + +# Save the original 'x' position of the insert cursor if: +# 1. This is the first time through -- or -- +# 2. The insert cursor position has changed from the previous +# time the up or down key was pressed -- or -- +# 3. The cursor has reached the beginning or end of the widget. + +if (not defined $w->{'origx'} or ($w->{'lastindex'} != $i) ) + { + $w->{'origx'} = $bx; + } + +# Try to keep the same column if possible +$testX = $w->{'origx'}; + +# Get the coordinates of the possible new position +my $testindex = $w->index('@'.$testX.','.$testY ); +$w->see($testindex); +my ($nx,$ny,$nw,$nh) = $w->bbox($testindex); + +# Which side of the character should we position the cursor - +# mainly for a proportional font +if ($testX > $nx+$nw/2) + { + $testX = $nx+$nw+1; + } + +my $newindex = $w->index('@'.$testX.','.$testY ); + +if ( $w->compare($newindex,'==','end - 1 char') and ($ny == $ly ) ) + { + # Then we are trying to the 'end' of the text from + # the same display line - don't do that + return $i; + } + +$w->{'lastindex'} = $newindex; +$w->see($newindex); +return $newindex; +} + +# PrevPara -- +# Returns the index of the beginning of the paragraph just before a given +# position in the text (the beginning of a paragraph is the first non-blank +# character after a blank line). +# +# Arguments: +# w - The text window in which the cursor is to move. +# pos - Position at which to start search. +sub PrevPara +{ + my ($w,$pos) = @_; + $pos = $w->index("$pos linestart"); + while (1) + { + if ($w->get("$pos - 1 line") eq "\n" && $w->get($pos) ne "\n" || $pos eq '1.0' ) + { + my $string = $w->get($pos,"$pos lineend"); + if ($string =~ /^(\s)+/) + { + my $off = length($1); + $pos = $w->index("$pos + $off chars") + } + if ($w->compare($pos,'!=','insert') || $pos eq '1.0') + { + return $pos; + } + } + $pos = $w->index("$pos - 1 line") + } +} +# NextPara -- +# Returns the index of the beginning of the paragraph just after a given +# position in the text (the beginning of a paragraph is the first non-blank +# character after a blank line). +# +# Arguments: +# w - The text window in which the cursor is to move. +# start - Position at which to start search. +sub NextPara +{ + my ($w,$start) = @_; + my $pos = $w->index("$start linestart + 1 line"); + while ($w->get($pos) ne "\n") + { + if ($w->compare($pos,'==','end')) + { + return $w->index('end - 1c'); + } + $pos = $w->index("$pos + 1 line") + } + while ($w->get($pos) eq "\n" ) + { + $pos = $w->index("$pos + 1 line"); + if ($w->compare($pos,'==','end')) + { + return $w->index('end - 1c'); + } + } + my $string = $w->get($pos,"$pos lineend"); + if ($string =~ /^(\s+)/) + { + my $off = length($1); + return $w->index("$pos + $off chars"); + } + return $pos; +} +# ScrollPages -- +# This is a utility procedure used in bindings for moving up and down +# pages and possibly extending the selection along the way. It scrolls +# the view in the widget by the number of pages, and it returns the +# index of the character that is at the same position in the new view +# as the insertion cursor used to be in the old view. +# +# Arguments: +# w - The text window in which the cursor is to move. +# count - Number of pages forward to scroll; may be negative +# to scroll backwards. +sub ScrollPages +{ + my ($w,$count) = @_; + my @bbox = $w->bbox('insert'); + $w->yview('scroll',$count,'pages'); + if (!@bbox) + { + return $w->index('@' . int($w->height/2) . ',' . 0); + } + my $x = int($bbox[0]+$bbox[2]/2); + my $y = int($bbox[1]+$bbox[3]/2); + return $w->index('@' . $x . ',' . $y); +} + +sub Contents +{ + my $w = shift; + if (@_) + { + $w->delete('1.0','end'); + $w->insert('end',shift) while (@_); + } + else + { + return $w->get('1.0','end'); + } +} + +sub Destroy +{ + my ($w) = @_; + delete $w->{_Tags_}; +} + +sub Transpose +{ + my ($w) = @_; + my $pos = 'insert'; + $pos = $w->index("$pos + 1 char") if ($w->compare($pos,'!=',"$pos lineend")); + return if ($w->compare("$pos - 1 char",'==','1.0')); + my $new = $w->get("$pos - 1 char").$w->get("$pos - 2 char"); + $w->delete("$pos - 2 char",$pos); + $w->insert('insert',$new); + $w->see('insert'); +} + +sub Tag +{ + my $w = shift; + my $name = shift; + Carp::confess('No args') unless (ref $w and defined $name); + $w->{_Tags_} = {} unless (exists $w->{_Tags_}); + unless (exists $w->{_Tags_}{$name}) + { + require Tk::Text::Tag; + $w->{_Tags_}{$name} = 'Tk::Text::Tag'->new($w,$name); + } + $w->{_Tags_}{$name}->configure(@_) if (@_); + return $w->{_Tags_}{$name}; +} + +sub Tags +{ + my ($w,$name) = @_; + my @result = (); + foreach $name ($w->tagNames(@_)) + { + push(@result,$w->Tag($name)); + } + return @result; +} + +sub TIEHANDLE +{ + my ($class,$obj) = @_; + return $obj; +} + +sub PRINT +{ + my $w = shift; + # Find out whether 'end' is displayed at the moment + # Retrieve the position of the bottom of the window as + # a fraction of the entire contents of the Text widget + my $yview = ($w->yview)[1]; + + # If $yview is 1.0 this means that 'end' is visible in the window + my $update = 0; + $update = 1 if $yview == 1.0; + + # Loop over all input strings + while (@_) + { + $w->insert('end',shift); + } + # Move the window to see the end of the text if required + $w->see('end') if $update; +} + +sub PRINTF +{ + my $w = shift; + $w->PRINT(sprintf(shift,@_)); +} + +sub WhatLineNumberPopUp +{ + my ($w)=@_; + my ($line,$col) = split(/\./,$w->index('insert')); + $w->messageBox(-type => 'Ok', -title => "What Line Number", + -message => "The cursor is on line $line (column is $col)"); +} + +sub MenuLabels +{ + return qw[~File ~Edit ~Search ~View]; +} + +sub SearchMenuItems +{ + my ($w) = @_; + return [ + ['command'=>'~Find', -command => [$w => 'FindPopUp']], + ['command'=>'Find ~Next', -command => [$w => 'FindSelectionNext']], + ['command'=>'Find ~Previous', -command => [$w => 'FindSelectionPrevious']], + ['command'=>'~Replace', -command => [$w => 'FindAndReplacePopUp']] + ]; +} + +sub EditMenuItems +{ + my ($w) = @_; + my @items = (); + foreach my $op ($w->clipEvents) + { + push(@items,['command' => "~$op", -command => [ $w => "clipboard$op"]]); + } + push(@items, + '-', + ['command'=>'Select All', -command => [$w => 'selectAll']], + ['command'=>'Unselect All', -command => [$w => 'unselectAll']], + ); + return \@items; +} + +sub ViewMenuItems +{ + my ($w) = @_; + my $v; + tie $v,'Tk::Configure',$w,'-wrap'; + return [ + ['command'=>'Goto ~Line...', -command => [$w => 'GotoLineNumberPopUp']], + ['command'=>'~Which Line?', -command => [$w => 'WhatLineNumberPopUp']], + ['cascade'=> 'Wrap', -tearoff => 0, -menuitems => [ + [radiobutton => 'Word', -variable => \$v, -value => 'word'], + [radiobutton => 'Character', -variable => \$v, -value => 'char'], + [radiobutton => 'None', -variable => \$v, -value => 'none'], + ]], + ]; +} + +######################################################################## +sub clipboardColumnCopy +{ + my ($w) = @_; + $w->Column_Copy_or_Cut(0); +} + +sub clipboardColumnCut +{ + my ($w) = @_; + $w->Column_Copy_or_Cut(1); +} + +######################################################################## +sub Column_Copy_or_Cut +{ + my ($w, $cut) = @_; + my @ranges = $w->tagRanges('sel'); + my $range_total = @ranges; + # this only makes sense if there is one selected block + unless ($range_total==2) + { + $w->bell; + return; + } + + my $selection_start_index = shift(@ranges); + my $selection_end_index = shift(@ranges); + + my ($start_line, $start_column) = split(/\./, $selection_start_index); + my ($end_line, $end_column) = split(/\./, $selection_end_index); + + # correct indices for tabs + my $string; + $string = $w->get($start_line.'.0', $start_line.'.0 lineend'); + $string = substr($string, 0, $start_column); + $string = expand($string); + my $tab_start_column = length($string); + + $string = $w->get($end_line.'.0', $end_line.'.0 lineend'); + $string = substr($string, 0, $end_column); + $string = expand($string); + my $tab_end_column = length($string); + + my $length = $tab_end_column - $tab_start_column; + + $selection_start_index = $start_line . '.' . $tab_start_column; + $selection_end_index = $end_line . '.' . $tab_end_column; + + # clear the clipboard + $w->clipboardClear; + my ($clipstring, $startstring, $endstring); + my $padded_string = ' 'x$tab_end_column; + for(my $line = $start_line; $line <= $end_line; $line++) + { + $string = $w->get($line.'.0', $line.'.0 lineend'); + $string = expand($string) . $padded_string; + $clipstring = substr($string, $tab_start_column, $length); + #$clipstring = unexpand($clipstring); + $w->clipboardAppend($clipstring."\n"); + + if ($cut) + { + $startstring = substr($string, 0, $tab_start_column); + $startstring = unexpand($startstring); + $start_column = length($startstring); + + $endstring = substr($string, 0, $tab_end_column ); + $endstring = unexpand($endstring); + $end_column = length($endstring); + + $w->delete($line.'.'.$start_column, $line.'.'.$end_column); + } + } +} + +######################################################################## + +sub clipboardColumnPaste +{ + my ($w) = @_; + my @ranges = $w->tagRanges('sel'); + my $range_total = @ranges; + if ($range_total) + { + warn " there cannot be any selections during clipboardColumnPaste. \n"; + $w->bell; + return; + } + + my $clipboard_text; + eval + { + $clipboard_text = $w->SelectionGet(-selection => "CLIPBOARD"); + }; + + return unless (defined($clipboard_text)); + return unless (length($clipboard_text)); + my $string; + + my $current_index = $w->index('insert'); + my ($current_line, $current_column) = split(/\./,$current_index); + $string = $w->get($current_line.'.0', $current_line.'.'.$current_column); + $string = expand($string); + $current_column = length($string); + + my @clipboard_lines = split(/\n/,$clipboard_text); + my $length; + my $end_index; + my ($delete_start_column, $delete_end_column, $insert_column_index); + foreach my $line (@clipboard_lines) + { + if ($w->OverstrikeMode) + { + #figure out start and end indexes to delete, compensating for tabs. + $string = $w->get($current_line.'.0', $current_line.'.0 lineend'); + $string = expand($string); + $string = substr($string, 0, $current_column); + $string = unexpand($string); + $delete_start_column = length($string); + + $string = $w->get($current_line.'.0', $current_line.'.0 lineend'); + $string = expand($string); + $string = substr($string, 0, $current_column + length($line)); + chomp($string); # dont delete a "\n" on end of line. + $string = unexpand($string); + $delete_end_column = length($string); + + + + $w->delete( + $current_line.'.'.$delete_start_column , + $current_line.'.'.$delete_end_column + ); + } + + $string = $w->get($current_line.'.0', $current_line.'.0 lineend'); + $string = expand($string); + $string = substr($string, 0, $current_column); + $string = unexpand($string); + $insert_column_index = length($string); + + $w->insert($current_line.'.'.$insert_column_index, unexpand($line)); + $current_line++; + } + +} + +# Backward compatibility +sub GetMenu +{ + carp((caller(0))[3]." is deprecated") if $^W; + shift->menu +} + +1; +__END__ + + diff --git a/Master/tlpkg/tlperl/lib/Tk/Text/Tag.pm b/Master/tlpkg/tlperl/lib/Tk/Text/Tag.pm new file mode 100644 index 00000000000..827278eb88c --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Text/Tag.pm @@ -0,0 +1,46 @@ +package Tk::Text::Tag; +require Tk::Text; + +use overload '""' => \&name; + + +use vars qw($VERSION); +$VERSION = '4.004'; # $Id: //depot/Tkutf8/Text/Text/Tag.pm#4 $ + +sub _apply +{ + my $self = shift; + my $meth = shift; + $self->widget->tag($meth => $self->name,@_); +} + +sub name +{ + return shift->[0]; +} + +sub widget +{ + return shift->[1]; +} + +BEGIN +{ + my $meth; + foreach $meth (qw(cget configure bind add)) + { + *{$meth} = sub { shift->_apply($meth,@_) } + } +} + +sub new +{ + my $class = shift; + my $widget = shift; + my $name = shift; + my $obj = bless [$name,$widget],$class; + $obj->configure(@_) if (@_); + return $obj; +} + +1; diff --git a/Master/tlpkg/tlperl/lib/Tk/TextEdit.pm b/Master/tlpkg/tlperl/lib/Tk/TextEdit.pm new file mode 100644 index 00000000000..e1ff20b6149 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/TextEdit.pm @@ -0,0 +1,509 @@ +# Copyright (c) 1999 Greg Bartels. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +# Special thanks to Nick Ing-Simmons for pushing a lot of +# my text edit functionality into Text.pm and TextUndo.pm +# otherwise, this module would have been monstrous. + +# Andy Worhal had it wrong, its "fifteen megabytes of fame" +# -Greg Bartels + +package Tk::TextEdit; + + +use vars qw($VERSION); +$VERSION = '4.004'; # $Id: //depot/Tkutf8/Tk/TextEdit.pm#4 $ + +use Tk qw (Ev); +use AutoLoader; + +use Text::Tabs; + +use base qw(Tk::TextUndo); + +Construct Tk::Widget 'TextEdit'; + +####################################################################### +####################################################################### +sub ClassInit +{ + my ($class,$mw) = @_; + $class->SUPER::ClassInit($mw); + + $mw->bind($class,'<F5>', 'IndentSelectedLines'); + $mw->bind($class,'<F6>', 'UnindentSelectedLines'); + + $mw->bind($class,'<F7>', 'CommentSelectedLines'); + $mw->bind($class,'<F8>', 'UncommentSelectedLines'); + + return $class; +} + +# 8 horizontal pixels in the "space" character in default font. +my $tab_multiplier = 8; + +sub debug_code_f1 +{ + my $w=shift; +} + +sub debug_code_f2 +{ + my $w=shift; +} + +####################################################################### +####################################################################### +sub InitObject +{ + my ($w) = @_; + $w->SUPER::InitObject; + + $w->{'INDENT_STRING'} = "\t"; # Greg mode=>"\t", Nick mode=>" " + $w->{'LINE_COMMENT_STRING'} = "#"; # assuming perl comments + + my %pair_descriptor_hash = + ( + 'PARENS' => [ 'multiline', '(', ')', "[()]" ], + 'CURLIES' => [ 'multiline', '{', '}', "[{}]" ], + 'BRACES' => [ 'multiline', '[', ']', "[][]" ], + 'DOUBLEQUOTE' => [ 'singleline', "\"","\"" ], + 'SINGLEQUOTE' => [ 'singleline', "'","'" ], + ); + + $w->{'HIGHLIGHT_PAIR_DESCRIPTOR_HASH_REF'}=\%pair_descriptor_hash; + + $w->tagConfigure + ('CURSOR_HIGHLIGHT_PARENS', -foreground=>'white', -background=>'violet'); + $w->tagConfigure + ('CURSOR_HIGHLIGHT_CURLIES', -foreground=>'white', -background=>'blue'); + $w->tagConfigure + ('CURSOR_HIGHLIGHT_BRACES', -foreground=>'white', -background=>'purple'); + $w->tagConfigure + ('CURSOR_HIGHLIGHT_DOUBLEQUOTE', -foreground=>'black', -background=>'green'); + $w->tagConfigure + ('CURSOR_HIGHLIGHT_SINGLEQUOTE', -foreground=>'black', -background=>'grey'); + + $w->tagConfigure('BLOCK_HIGHLIGHT_PARENS', -background=>'red'); + $w->tagConfigure('BLOCK_HIGHLIGHT_CURLIES', -background=>'orange'); + $w->tagConfigure('BLOCK_HIGHLIGHT_BRACES', -background=>'red'); + $w->tagConfigure('BLOCK_HIGHLIGHT_DOUBLEQUOTE', -background=>'red'); + $w->tagConfigure('BLOCK_HIGHLIGHT_SINGLEQUOTE', -background=>'red'); + + $w->tagRaise('BLOCK_HIGHLIGHT_PARENS','CURSOR_HIGHLIGHT_PARENS'); + $w->tagRaise('BLOCK_HIGHLIGHT_CURLIES','CURSOR_HIGHLIGHT_CURLIES'); + $w->tagRaise('BLOCK_HIGHLIGHT_BRACES','CURSOR_HIGHLIGHT_BRACES'); + $w->tagRaise('BLOCK_HIGHLIGHT_DOUBLEQUOTE','CURSOR_HIGHLIGHT_DOUBLEQUOTE'); + $w->tagRaise('BLOCK_HIGHLIGHT_SINGLEQUOTE','CURSOR_HIGHLIGHT_SINGLEQUOTE'); + + $w->{'UPDATE_WIDGET_PERIOD'}=300; # how much time between each call. + $w->{'WINDOW_PLUS_AND_MINUS_VALUE'}=80; + $w->SetGUICallbackIndex(0); + $w->schedule_next_callback; + +} + +####################################################################### + +sub cancel_current_gui_callback_and_restart_from_beginning +{ + my ($w)=@_; + if(defined($w->{'UPDATE_WIDGET_AFTER_REFERENCE'})) + {$w->{'UPDATE_WIDGET_AFTER_REFERENCE'}->cancel();} + $w->SetGUICallbackIndex(0); + + $w->schedule_next_callback; +} + +sub schedule_next_callback +{ + my ($w)=@_; + return if $w->NoMoreGUICallbacksToCall; #stops infinite recursive call. + $w->{'UPDATE_WIDGET_AFTER_REFERENCE'} = $w->after + ($w->{'UPDATE_WIDGET_PERIOD'}, + sub + { + $w->CallNextGUICallback; + $w->schedule_next_callback; + } + ); + +} + + +####################################################################### +# use these methods to pass the TextEdit widget an anonymous array +# of code references. +# any time the widget changes that requires the display to be updated, +# then these code references will be scheduled in sequence for calling. +# splitting them up allows them to be prioritized by order, +# and prevents the widget from "freezing" too long if they were +# one large callback. scheduling them apart allows the widget time +# to respond to user inputs. +####################################################################### +sub SetGUICallbacks +{ + my ($w,$callback_array_ref) = @_; + $w->{GUI_CALLBACK_ARRAY_REF}=$callback_array_ref; + $w->SetGUICallbackIndex(0); +} + +sub GetGUICallbacks +{ + return shift->{GUI_CALLBACK_ARRAY_REF}; +} + +sub SetGUICallbackIndex +{ + my ($w, $val)=@_; + $w->{GUI_CALLBACK_ARRAY_INDEX}=$val; +} + +sub GetGUICallbackIndex +{ + return shift->{GUI_CALLBACK_ARRAY_INDEX}; +} + +sub IncrementGUICallbackIndex +{ + shift->{GUI_CALLBACK_ARRAY_INDEX} += 1; +} + +sub NoMoreGUICallbacksToCall +{ + my ($w) = @_; + return 0 unless defined ($w->{GUI_CALLBACK_ARRAY_REF}); + return 0 unless defined ($w->{GUI_CALLBACK_ARRAY_INDEX}); + my $arr_ref = $w->{GUI_CALLBACK_ARRAY_REF}; + my $arr_ind = $w->{GUI_CALLBACK_ARRAY_INDEX}; + return $arr_ind >= @$arr_ref; +} + +sub CallNextGUICallback +{ + my ($w) = @_; + return if $w->NoMoreGUICallbacksToCall; + my $arr_ref = $w->{GUI_CALLBACK_ARRAY_REF}; + my $arr_ind = $w->{GUI_CALLBACK_ARRAY_INDEX}; + &{$arr_ref->[$arr_ind]}; + $w->IncrementGUICallbackIndex; +} + + +####################################################################### +####################################################################### + +sub insert +{ + my $w = shift; + $w->SUPER::insert(@_); + $w->cancel_current_gui_callback_and_restart_from_beginning; +} + +sub delete +{ + my $w = shift; + $w->SUPER::delete(@_); + $w->cancel_current_gui_callback_and_restart_from_beginning; +} + +sub SetCursor +{ + my $w = shift; + $w->SUPER::SetCursor(@_); + $w->cancel_current_gui_callback_and_restart_from_beginning; +} + +sub OverstrikeMode +{ + my ($w,$mode) = @_; + if (defined($mode)) + { + $w->SUPER::OverstrikeMode($mode); + $w->cancel_current_gui_callback_and_restart_from_beginning; + } + return $w->SUPER::OverstrikeMode; +} + + +####################################################################### +# use yview on scrollbar to get fractional coordinates. +# scale this by the total length of the text to find the +# approximate start line of widget and end line of widget. +####################################################################### +sub GetScreenWindowCoordinates +{ + my $w = shift; + my ($top_frac, $bot_frac) = $w->yview; + my $end_index = $w->index('end'); + my ($lines,$columns) = split (/\./,$end_index); + my $window = $w->{'WINDOW_PLUS_AND_MINUS_VALUE'}; + my $top_line = int(($top_frac * $lines) - $window); + $top_line = 0 if ($top_line < 0); + my $bot_line = int(($bot_frac * $lines) + $window); + $bot_line = $lines if ($bot_line > $lines); + my $top_index = $top_line . '.0'; + my $bot_index = $bot_line . '.0'; + + $_[0] = $top_index; + $_[1] = $bot_index; +} + +######################################################################## +# take two indices as inputs. +# if they are on the same line or same column (accounting for tabs) +# then return 1 +# else return 0 +# (assume indices passed in are in line.column format) +######################################################################## +sub IndicesLookGood +{ + my ($w, $start, $end, $singleline) = @_; + + return 0 unless ( (defined($start)) and (defined($end))); + + my ($start_line, $start_column) = split (/\./,$start); + my ($end_line, $end_column) = split (/\./,$end); + + ########################## + # good if on the same line + ########################## + return 1 if ($start_line == $end_line); + + ########################## + # if not on same line and its a singleline, its bad + ########################## + return 0 if $singleline; + + + # get both lines, convert the tabs to spaces, and get the new column. + # see if they line up or not. + my $string; + $string = $w->get($start_line.'.0', $start_line.'.0 lineend'); + $string = substr($string, 0, $start_column+1); + $string = expand($string); + $start_column = length($string); + + $string = $w->get($end_line.'.0', $end_line.'.0 lineend'); + $string = substr($string, 0, $end_column +1); + $string = expand($string); + $end_column = length($string); + + ########################## + # good if on the same column (adjusting for tabs) + ########################## + return 1 if ($start_column == $end_column); + + # otherwise its bad + return 0; +} + +######################################################################## +# if searching backward, count paranthesis until find a start parenthesis +# which does not have a forward match. +# +# (<= search backward will return this index +# () +# START X HERE +# ( ( ) () ) +# )<== search forward will return this index +# +# if searching forward, count paranthesis until find a end parenthesis +# which does not have a rearward match. +######################################################################## +sub searchForBaseCharacterInPair +{ + my + ( + $w, $top_index, $searchfromindex, $bot_index, + $direction, $startchar, $endchar, $charpair + )=@_; + my ($plus_one_char, $search_end_index, $index_offset, $done_index); + if ($direction eq '-forward') + { + $plus_one_char = $endchar; + $search_end_index = $bot_index; + $index_offset = ' +1c'; + $done_index = $w->index('end'); + } + else + { + $plus_one_char = $startchar; + $search_end_index = $top_index; + $index_offset = ''; + $done_index = '1.0'; + } + + my $at_done_index = 0; + my $count = 0; + my $char; + while(1) + { + $searchfromindex = $w->search + ($direction, '-regexp', $charpair, $searchfromindex, $search_end_index ); + + last unless(defined($searchfromindex)); + $char = $w->get($searchfromindex, $w->index($searchfromindex.' +1c')); + if ($char eq $plus_one_char) + {$count += 1;} + else + {$count -= 1;} + last if ($count==1); + # boundary condition exists when first char in widget is the match char + # need to be able to determine if search tried to go past index '1.0' + # if so, set index to undef and return. + if ( $at_done_index ) + { + $searchfromindex = undef; + last; + } + $at_done_index = 1 if ($searchfromindex eq $done_index); + $searchfromindex=$w->index($searchfromindex . $index_offset); + } + return $searchfromindex; +} + +######################################################################## +# highlight a character pair that most closely brackets the cursor. +# allows you to pick and choose which ones you want to do. +######################################################################## + +sub HighlightParenthesisAroundCursor +{ + my ($w)=@_; + $w->HighlightSinglePairBracketingCursor + ( '(', ')', '[()]', 'CURSOR_HIGHLIGHT_PARENS','BLOCK_HIGHLIGHT_PARENS',0); +} + +sub HighlightCurlyBracesAroundCursor +{ + my ($w)=@_; + $w->HighlightSinglePairBracketingCursor + ( '{', '}', '[{}]', 'CURSOR_HIGHLIGHT_CURLIES','BLOCK_HIGHLIGHT_CURLIES',0); +} + +sub HighlightBracesAroundCursor +{ + my ($w)=@_; + $w->HighlightSinglePairBracketingCursor + ( '[', ']','[][]', 'CURSOR_HIGHLIGHT_BRACES','BLOCK_HIGHLIGHT_BRACES',0); +} + +sub HighlightDoubleQuotesAroundCursor +{ + my ($w)=@_; + $w->HighlightSinglePairBracketingCursor + ( "\"", "\"", "\"", 'CURSOR_HIGHLIGHT_DOUBLEQUOTE','BLOCK_HIGHLIGHT_DOUBLEQUOTE',1); +} + +sub HighlightSingleQuotesAroundCursor +{ + my ($w)=@_; + $w->HighlightSinglePairBracketingCursor + ( "'", "'", "'", 'CURSOR_HIGHLIGHT_SINGLEQUOTE','BLOCK_HIGHLIGHT_SINGLEQUOTE',1); +} + +######################################################################## +# highlight all the character pairs that most closely bracket the cursor. +######################################################################## +sub HighlightAllPairsBracketingCursor +{ + my ($w)=@_; + $w->HighlightParenthesisAroundCursor; + $w->HighlightCurlyBracesAroundCursor; + $w->HighlightBracesAroundCursor; + $w->HighlightDoubleQuotesAroundCursor; + $w->HighlightSingleQuotesAroundCursor; +} + +######################################################################## +# search for a pair of matching characters that bracket the +# cursor and tag them with the given tagname. +# startchar might be '[' +# endchar would then be ']' +# tagname is a name of a tag, which has already been +# configured to highlight however the user wants them to behave. +# error tagname is the tag to highlight the chars with if there +# is a problem of some kind. +# singleline indicates whether the character pairs must occur +# on a single line. quotation marks are single line characters usually. +######################################################################## +sub HighlightSinglePairBracketingCursor +{ + my + ( + $w, $startchar, $endchar, $charpair, + $good_tagname, $bad_tagname, $single_line + ) = @_; + $single_line=0 unless defined($single_line); + $w->tagRemove($good_tagname, '1.0','end'); + $w->tagRemove($bad_tagname, '1.0','end'); + my $top_index; my $bot_index; + my $cursor = $w->index('insert'); + if ($single_line) + { + $top_index = $w->index($cursor.' linestart'); + $bot_index = $w->index($cursor.' lineend'); + } + else + { + $w->GetScreenWindowCoordinates($top_index, $bot_index); + } + + # search backward for the startchar + # $top_index, $searchfromindex, $bot_index, + # $direction, $startchar, $endchar, $charpair + + my $startindex = $w->searchForBaseCharacterInPair + ( + $top_index, $cursor, $bot_index, + '-backward', $startchar, $endchar, $charpair + ); + + # search forward for the endchar + my $endindex = $w->searchForBaseCharacterInPair + ( + $top_index, $cursor, $bot_index, + '-forward', $startchar, $endchar, $charpair + ); + return unless ((defined $startindex) and (defined $endindex)); + + my $final_tag = $bad_tagname; + if ($w->IndicesLookGood( $startindex, $endindex, $single_line)) + { + $final_tag = $good_tagname; + } + + $w->tagAdd($final_tag, $startindex, $w->index($startindex.'+1c') ); + $w->tagAdd($final_tag, $endindex, $w->index( $endindex.'+1c') ); +} + +#################################################################### +sub IndentSelectedLines +{ + my($w)=@_; + $w->insertStringAtStartOfSelectedLines($w->{'INDENT_STRING'}); +} + +sub UnindentSelectedLines +{ + my($w)=@_; + $w->deleteStringAtStartOfSelectedLines($w->{'INDENT_STRING'}); +} + +sub CommentSelectedLines +{ + my($w)=@_; + $w->insertStringAtStartOfSelectedLines($w->{'LINE_COMMENT_STRING'}); +} + +sub UncommentSelectedLines +{ + my($w)=@_; + $w->deleteStringAtStartOfSelectedLines($w->{'LINE_COMMENT_STRING'}); +} + + +1; +__END__ diff --git a/Master/tlpkg/tlperl/lib/Tk/TextList.pm b/Master/tlpkg/tlperl/lib/Tk/TextList.pm new file mode 100644 index 00000000000..77a48fdf8ce --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/TextList.pm @@ -0,0 +1,985 @@ +# Copyright (c) 1999 Greg London. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +# code for bindings taken from Listbox.pm + +# comments specifying method functionality taken from +# "Perl/Tk Pocket Reference" by Stephen Lidie. + +####################################################################### +# this module uses a text module as its base class to create a list box. +# this will allow list box functionality to also have all the functionality +# of the Text widget. +# +# note that most methods use an element number to indicate which +# element in the list to work on. +# the exception to this is the tag and mark methods which +# are dual natured. These methods may accept either the +# normal element number, or they will also take a element.char index, +# which would be useful for applying tags to part of a line in the list. +# +####################################################################### + +package Tk::TextList; + +use strict; +use vars qw($VERSION); +$VERSION = '4.005'; # $Id: //depot/Tkutf8/TextList/TextList.pm#5 $ + +#XXXdel: use Tk::Reindex qw(Tk::ROText); #XXXdel: ReindexedROText); + +use base qw(Tk::Derived Tk::ReindexedROText ); + +use Tk qw (Ev); + +#XXX del: use base qw(Tk::ReindexedROText); + +Construct Tk::Widget 'TextList'; + +####################################################################### +# the following line causes Populate to get called +# @ISA = qw(Tk::Derived ... ); +####################################################################### +sub Populate +{ + my ($w,$args)=@_; + my $option=delete $args->{'-selectmode'}; + $w->SUPER::Populate($args); + $w->ConfigSpecs( -selectmode => ['PASSIVE','selectMode','SelectMode','browse'], + -takefocus => ['PASSIVE','takeFocus','TakeFocus',1], + -spacing3 => ['SELF', undef, undef, 3], + -insertwidth => ['SELF', undef, undef, 0], + ); + +} + +####################################################################### +####################################################################### +sub ClassInit +{ + my ($class,$mw) = @_; + + # Standard Motif bindings: + $mw->bind($class,'<1>',['BeginSelect',Ev('index',Ev('@'))]); + $mw->bind($class,'<B1-Motion>',['Motion',Ev('index',Ev('@'))]); + $mw->bind($class,'<ButtonRelease-1>','ButtonRelease_1'); + + $mw->bind($class,'<Shift-1>',['BeginExtend',Ev('index',Ev('@'))]); + $mw->bind($class,'<Control-1>',['BeginToggle',Ev('index',Ev('@'))]); + + $mw->bind($class,'<B1-Leave>',['AutoScan',Ev('x'),Ev('y')]); + $mw->bind($class,'<B1-Enter>','CancelRepeat'); + $mw->bind($class,'<Up>',['UpDown',-1]); + $mw->bind($class,'<Shift-Up>',['ExtendUpDown',-1]); + $mw->bind($class,'<Down>',['UpDown',1]); + $mw->bind($class,'<Shift-Down>',['ExtendUpDown',1]); + + $mw->XscrollBind($class); + $mw->PriorNextBind($class); + + $mw->bind($class,'<Control-Home>','Cntrl_Home'); + + $mw->bind($class,'<Shift-Control-Home>',['DataExtend',0]); + $mw->bind($class,'<Control-End>','Cntrl_End'); + + $mw->bind($class,'<Shift-Control-End>',['DataExtend','end']); + $class->clipboardOperations($mw,'Copy'); + $mw->bind($class,'<space>',['BeginSelect',Ev('index','active')]); + $mw->bind($class,'<Select>',['BeginSelect',Ev('index','active')]); + $mw->bind($class,'<Control-Shift-space>',['BeginExtend',Ev('index','active')]); + $mw->bind($class,'<Shift-Select>',['BeginExtend',Ev('index','active')]); + $mw->bind($class,'<Escape>','Cancel'); + $mw->bind($class,'<Control-slash>','SelectAll'); + $mw->bind($class,'<Control-backslash>','Cntrl_backslash'); + ; + # Additional Tk bindings that aren't part of the Motif look and feel: + $mw->bind($class,'<2>',['scan','mark',Ev('x'),Ev('y')]); + $mw->bind($class,'<B2-Motion>',['scan','dragto',Ev('x'),Ev('y')]); + + $mw->bind($class,'<FocusIn>' , ['tagConfigure','_ACTIVE_TAG', -underline=>1]); + $mw->bind($class,'<FocusOut>', ['tagConfigure','_ACTIVE_TAG', -underline=>0]); + + return $class; +} + +####################################################################### +# set the active element to index +# "active" is a text "mark" which underlines the marked text. +####################################################################### +sub activate +{ + my($w,$element)=@_; + $element= $w->index($element).'.0'; + $w->SUPER::tag('remove', '_ACTIVE_TAG', '1.0','end'); + $w->SUPER::tag('add', '_ACTIVE_TAG', + $element.' linestart', $element.' lineend'); + $w->SUPER::mark('set', 'active', $element); +} + + +####################################################################### +# bbox returns a list (x,y,width,height) giving an approximate +# bounding box of character given by index +####################################################################### +sub bbox +{ + my($w,$element)=@_; + $element=$w->index($element).'.0' unless ($element=~/./); + return $w->SUPER::bbox($element); +} + +####################################################################### +# returns a list of indices of all elements currently selected +####################################################################### +sub curselection +{ + my ($w)=@_; + my @ranges = $w->SUPER::tag('ranges', 'sel'); + my @selection_list; + while (@ranges) + { + my ($first,$firstcol) = split(/\./,shift(@ranges)); + my ($last,$lastcol) = split(/\./,shift(@ranges)); + + ######################################################################### + # if previous selection ended on the same line that this selection starts, + # then fiddle the numbers so that this line number isnt included twice. + ######################################################################### + if (defined($selection_list[-1]) and ($first == $selection_list[-1])) + { + $first++; # count this selection starting from the next line. + } + + if ($lastcol==0) + { + $last-=1; + } + + ######################################################################### + # if incrementing $first causes it to be greater than $last, + # then do nothing, + # else add (first .. last) to list + ######################################################################### + unless ($first>$last) + { + push(@selection_list, $first .. $last); + } + } + return @selection_list; +} + + +####################################################################### +# deletes range of elements from element1 to element2 +# defaults to element1 +####################################################################### +sub delete +{ + my ($w, $element1, $element2)=@_; + $element1=$w->index($element1); + $element2=$element1 unless(defined($element2)); + $element2=$w->index($element2); + $w->SUPER::delete($element1.'.0' , $element2.'.0 lineend'); +} + +####################################################################### +# deletes range of characters from index1 to index2 +# defaults to index1+1c +# index is line.char notation. +####################################################################### +sub deleteChar +{ + my ($w, $index1, $index2)=@_; + $index1=$w->index($index1); + $index2=$index1.' +1c' unless(defined($index2)); + $index2=$w->index($index2); + $w->SUPER::delete($index1, $index2); +} + +####################################################################### +# returns as a list contents of elements from $element1 to $element2 +# defaults to element1. +####################################################################### +sub get +{ + my ($w, $element1, $element2)=@_; + $element1=$w->index($element1); + $element2=$element1 unless(defined($element2)); + $element2=$w->index($element2); + my @getlist; + for(my $i=$element1; $i<=$element2; $i++) + { + push(@getlist, $w->SUPER::get($i.'.0 linestart', $i.'.0 lineend')); + } + + return @getlist; +} + +####################################################################### +# return text between index1 and index2 which are line.char notation. +# return value is a single string. index2 defaults to index1+1c +# index is line.char notation. +###################################################################### +sub getChar +{ + my $w=shift; + return $w->SUPER::get(@_); +} + +####################################################################### +# returns index in number notation +# this method returns an element number, ie the 5th element. +####################################################################### +sub index +{ + my ($w,$element)=@_; + return undef unless(defined($element)); + $element .= '.0' unless $element=~/\D/; + $element = $w->SUPER::index($element); + my($line,$col)=split(/\./,$element); + return $line; +} + +####################################################################### +# returns index in line.char notation +# this method returns an index specific to a character within an element +####################################################################### +sub indexChar +{ + my $w=shift; + return $w->SUPER::index(@_); +} + + +####################################################################### +# inserts specified elements just before element at index +####################################################################### +sub insert +{ + my $w=shift; + my $element=shift; + $element=$w->index($element); + my $item; + while (@_) + { + $item = shift(@_); + $item .= "\n"; + $w->SUPER::insert($element++.'.0', $item); + } +} + +####################################################################### +# inserts string just before character at index. +# index is line.char notation. +####################################################################### +sub insertChar +{ + my $w=shift; + $w->SUPER::insert(@_); +} + + + +####################################################################### +# returns index of element nearest to y-coordinate +# +# currently not defined +####################################################################### +#sub nearest +#{ +# return undef; +#} + +####################################################################### +# Sets the selection anchor to element at index +####################################################################### +sub selectionAnchor +{ + my ($w, $element)=@_; + $element=$w->index($element); + $w->SUPER::mark('set', 'anchor', $element.'.0'); +} + +####################################################################### +# deselects elements between index1 and index2, inclusive +####################################################################### +sub selectionClear +{ + my ($w, $element1, $element2)=@_; + $element1=$w->index($element1); + $element2=$element1 unless(defined($element2)); + $element2=$w->index($element2); + $w->SUPER::tag('remove', 'sel', $element1.'.0', $element2.'.0 lineend +1c'); +} + +####################################################################### +# returns 1 if element at index is selected, 0 otherwise. +####################################################################### +sub selectionIncludes +{ + my ($w, $element)=@_; + $element=$w->index($element); + my @list = $w->curselection; + my $line; + foreach $line (@list) + { + if ($line == $element) {return 1;} + } + return 0; +} + +####################################################################### +# adds all elements between element1 and element2 inclusive to selection +####################################################################### +sub selectionSet +{ + my ($w, $element1, $element2)=@_; + $element1=$w->index($element1); + $element2=$element1 unless(defined($element2)); + $element2=$w->index($element2); + $w->SUPER::tag('add', 'sel', $element1.'.0', $element2.'.0 lineend +1c'); +} + +####################################################################### +# for ->selection(option,args) calling convention +####################################################################### +sub selection +{ +# my ($w,$sub)=(shift,"selection".ucfirst(shift)); +# no strict 'refs'; +# # can't use $w->$sub, since it might call overridden method-- bleh +# &($sub)($w,@_); +} + + +####################################################################### +# adjusts the view in window so element at index is completely visible +####################################################################### +sub see +{ + my ($w, $element)=@_; + $element=$w->index($element); + $w->SUPER::see($element.'.0'); +} + +####################################################################### +# returns number of elements in listbox +####################################################################### +sub size +{ + my ($w)=@_; + my $element = $w->index('end'); + # theres a weird thing with the 'end' mark sometimes being on a line + # with text, and sometimes being on a line all by itself + my ($text) = $w->get($element); + if (length($text) == 0) + {$element -= 1;} + return $element; +} + + + +####################################################################### +# add a tag based on element numbers +####################################################################### +sub tagAdd +{ + my ($w, $tagName, $element1, $element2)=@_; + $element1=$w->index($element1); + $element1.='.0'; + + $element2=$element1.' lineend' unless(defined($element2)); + $element2=$w->index($element2); + $element2.='.0 lineend +1c'; + + $w->SUPER::tag('add', $tagName, $element1, $element2); +} + +####################################################################### +# add a tag based on line.char indexes +####################################################################### +sub tagAddChar +{ + my $w=shift; + $w->SUPER::tag('add',@_); +} + + +####################################################################### +# remove a tag based on element numbers +####################################################################### +sub tagRemove +{ + my ($w, $tagName, $element1, $element2)=@_; + $element1=$w->index($element1); + $element1.='.0'; + + $element2=$element1.' lineend' unless(defined($element2)); + $element2=$w->index($element2); + $element2.='.0 lineend +1c'; + + $w->SUPER::tag('remove', 'sel', $element1, $element2); +} + +####################################################################### +# remove a tag based on line.char indexes +####################################################################### +sub tagRemoveChar +{ + my $w=shift; + $w->SUPER::tag('remove', @_); +} + + + + +####################################################################### +# perform tagNextRange based on element numbers +####################################################################### +sub tagNextRange +{ + my ($w, $tagName, $element1, $element2)=@_; + $element1=$w->index($element1); + $element1.='.0'; + + $element2=$element1 unless(defined($element2)); + $element2=$w->index($element2); + $element2.='.0 lineend +1c'; + + my $index = $w->SUPER::tag('nextrange', 'sel', $element1, $element2); + my ($line,$col)=split(/\./,$index); + return $line; +} + +####################################################################### +# perform tagNextRange based on line.char indexes +####################################################################### +sub tagNextRangeChar +{ + my $w=shift; + $w->SUPER::tag('nextrange', @_); +} + +####################################################################### +# perform tagPrevRange based on element numbers +####################################################################### +sub tagPrevRange +{ + my ($w, $tagName, $element1, $element2)=@_; + $element1=$w->index($element1); + $element1.='.0'; + + $element2=$element1 unless(defined($element2)); + $element2=$w->index($element2); + $element2.='.0 lineend +1c'; + + my $index = $w->SUPER::tag('prevrange', 'sel', $element1, $element2); + my ($line,$col)=split(/\./,$index); + return $line; +} + +####################################################################### +# perform tagPrevRange based on line.char indexes +####################################################################### +sub tagPrevRangeChar +{ + my $w=shift; + $w->SUPER::tag('prevrange', @_); +} + + + +####################################################################### +# perform markSet based on element numbers +####################################################################### +sub markSet +{ + my ($w,$mark,$element1)=@_; + $element1=$w->index($element1); + $element1.='.0'; + $w->SUPER::mark('set', $element1,$mark); +} + +####################################################################### +# perform markSet based on line.char indexes +####################################################################### +sub markSetChar +{ + my $w=shift; + $w->SUPER::mark('set', @_); +} + +####################################################################### +# perform markNext based on element numbers +####################################################################### +sub markNext +{ + my ($w,$element1)=@_; + $element1=$w->index($element1); + $element1.='.0'; + return $w->SUPER::mark('next', $element1); +} + +####################################################################### +# perform markNext based on line.char indexes +####################################################################### +sub markNextChar +{ + my $w=shift; + $w->SUPER::mark('next', @_); +} + + +####################################################################### +# perform markPrevious based on element numbers +####################################################################### +sub markPrevious +{ + my ($w,$element1)=@_; + $element1=$w->index($element1); + $element1.='.0'; + return $w->SUPER::mark('previous', $element1); +} + +####################################################################### +# perform markPrevious based on line.char indexes +####################################################################### +sub markPreviousChar +{ + my $w=shift; + $w->SUPER::mark('previous', @_); +} + + + + +sub ButtonRelease_1 +{ + my $w = shift; + my $Ev = $w->XEvent; + $w->CancelRepeat; + $w->activate($Ev->xy); +} + + +sub Cntrl_Home +{ + my $w = shift; + my $Ev = $w->XEvent; + $w->activate(0); + $w->see(0); + $w->selectionClear(0,'end'); + $w->selectionSet(0) +} + + +sub Cntrl_End +{ + my $w = shift; + my $Ev = $w->XEvent; + $w->activate('end'); + $w->see('end'); + $w->selectionClear(0,'end'); + $w->selectionSet('end') +} + + +sub Cntrl_backslash +{ + my $w = shift; + my $Ev = $w->XEvent; + if ($w->cget('-selectmode') ne 'browse') + { + $w->selectionClear(0,'end'); + } +} + +# BeginSelect -- +# +# This procedure is typically invoked on button-1 presses. It begins +# the process of making a selection in the listbox. Its exact behavior +# depends on the selection mode currently in effect for the listbox; +# see the Motif documentation for details. +# +# Arguments: +# w - The listbox widget. +# el - The element for the selection operation (typically the +# one under the pointer). Must be in numerical form. +sub BeginSelect +{ + my $w = shift; + my $el = shift; + if ($w->cget('-selectmode') eq 'multiple') + { + if ($w->selectionIncludes($el)) + { + $w->selectionClear($el) + } + else + { + $w->selectionSet($el) + } + } + else + { + $w->selectionClear(0,'end'); + $w->selectionSet($el); + $w->selectionAnchor($el); + my @list = (); + $w->{'SELECTION_LIST_REF'} = \@list; + $w->{'PREVIOUS_ELEMENT'} = $el + } + $w->focus if ($w->cget('-takefocus')); +} +# Motion -- +# +# This procedure is called to process mouse motion events while +# button 1 is down. It may move or extend the selection, depending +# on the listbox's selection mode. +# +# Arguments: +# w - The listbox widget. +# el - The element under the pointer (must be a number). +sub Motion +{ + my $w = shift; + my $el = shift; + if (defined($w->{'PREVIOUS_ELEMENT'}) && $el == $w->{'PREVIOUS_ELEMENT'}) + { + return; + } + + # if no selections, select current + if($w->curselection==0) + { + $w->activate($el); + $w->selectionSet($el); + $w->selectionAnchor($el); + $w->{'PREVIOUS_ELEMENT'}=$el; + return; + } + + my $anchor = $w->index('anchor'); + my $mode = $w->cget('-selectmode'); + if ($mode eq 'browse') + { + $w->selectionClear(0,'end'); + $w->selectionSet($el); + $w->{'PREVIOUS_ELEMENT'} = $el; + } + elsif ($mode eq 'extended') + { + my $i = $w->{'PREVIOUS_ELEMENT'}; + if ($w->selectionIncludes('anchor')) + { + $w->selectionClear($i,$el); + $w->selectionSet('anchor',$el) + } + else + { + $w->selectionClear($i,$el); + $w->selectionClear('anchor',$el) + } + while ($i < $el && $i < $anchor) + { + if (Tk::lsearch($w->{'SELECTION_LIST_REF'},$i) >= 0) + { + $w->selectionSet($i) + } + $i += 1 + } + while ($i > $el && $i > $anchor) + { + if (Tk::lsearch($w->{'SELECTION_LIST_REF'},$i) >= 0) + { + $w->selectionSet($i) + } + $i += -1 + } + $w->{'PREVIOUS_ELEMENT'} = $el + } +} +# BeginExtend -- +# +# This procedure is typically invoked on shift-button-1 presses. It +# begins the process of extending a selection in the listbox. Its +# exact behavior depends on the selection mode currently in effect +# for the listbox; see the Motif documentation for details. +# +# Arguments: +# w - The listbox widget. +# el - The element for the selection operation (typically the +# one under the pointer). Must be in numerical form. +sub BeginExtend +{ + my $w = shift; + my $el = shift; + + # if no selections, select current + if($w->curselection==0) + { + $w->activate($el); + $w->selectionSet($el); + $w->selectionAnchor($el); + $w->{'PREVIOUS_ELEMENT'}=$el; + return; + } + + if ($w->cget('-selectmode') eq 'extended' && $w->selectionIncludes('anchor')) + { + $w->Motion($el) + } +} +# BeginToggle -- +# +# This procedure is typically invoked on control-button-1 presses. It +# begins the process of toggling a selection in the listbox. Its +# exact behavior depends on the selection mode currently in effect +# for the listbox; see the Motif documentation for details. +# +# Arguments: +# w - The listbox widget. +# el - The element for the selection operation (typically the +# one under the pointer). Must be in numerical form. +sub BeginToggle +{ + my $w = shift; + my $el = shift; + if ($w->cget('-selectmode') eq 'extended') + { + my @list = $w->curselection(); + $w->{'SELECTION_LIST_REF'} = \@list; + $w->{'PREVIOUS_ELEMENT'} = $el; + $w->selectionAnchor($el); + if ($w->selectionIncludes($el)) + { + $w->selectionClear($el) + } + else + { + $w->selectionSet($el) + } + } +} +# AutoScan -- +# This procedure is invoked when the mouse leaves an entry window +# with button 1 down. It scrolls the window up, down, left, or +# right, depending on where the mouse left the window, and reschedules +# itself as an "after" command so that the window continues to scroll until +# the mouse moves back into the window or the mouse button is released. +# +# Arguments: +# w - The entry window. +# x - The x-coordinate of the mouse when it left the window. +# y - The y-coordinate of the mouse when it left the window. +sub AutoScan +{ + my $w = shift; + my $x = shift; + my $y = shift; + 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->Motion($w->index("@" . $x . ',' . $y)); + $w->RepeatId($w->after(50,'AutoScan',$w,$x,$y)); +} +# UpDown -- +# +# Moves the location cursor (active element) up or down by one element, +# and changes the selection if we're in browse or extended selection +# mode. +# +# Arguments: +# w - The listbox widget. +# amount - +1 to move down one item, -1 to move back one item. +sub UpDown +{ + my $w = shift; + my $amount = shift; + $w->activate($w->index('active')+$amount); + $w->see('active'); + my $selectmode = $w->cget('-selectmode'); + if ($selectmode eq 'browse') + { + $w->selectionClear(0,'end'); + $w->selectionSet('active') + } + elsif ($selectmode eq 'extended') + { + $w->selectionClear(0,'end'); + $w->selectionSet('active'); + $w->selectionAnchor('active'); + $w->{'PREVIOUS_ELEMENT'} = $w->index('active'); + my @list = (); + $w->{'SELECTION_LIST_REF'}=\@list; + } +} +# ExtendUpDown -- +# +# Does nothing unless we're in extended selection mode; in this +# case it moves the location cursor (active element) up or down by +# one element, and extends the selection to that point. +# +# Arguments: +# w - The listbox widget. +# amount - +1 to move down one item, -1 to move back one item. +sub ExtendUpDown +{ + my $w = shift; + my $amount = shift; + if ($w->cget('-selectmode') ne 'extended') + { + return; + } + $w->activate($w->index('active')+$amount); + $w->see('active'); + $w->Motion($w->index('active')) +} +# DataExtend +# +# This procedure is called for key-presses such as Shift-KEndData. +# If the selection mode isn't multiple or extend then it does nothing. +# Otherwise it moves the active element to el and, if we're in +# extended mode, extends the selection to that point. +# +# Arguments: +# w - The listbox widget. +# el - An integer element number. +sub DataExtend +{ + my $w = shift; + my $el = shift; + my $mode = $w->cget('-selectmode'); + if ($mode eq 'extended') + { + $w->activate($el); + $w->see($el); + if ($w->selectionIncludes('anchor')) + { + $w->Motion($el) + } + } + elsif ($mode eq 'multiple') + { + $w->activate($el); + $w->see($el) + } +} +# Cancel +# +# This procedure is invoked to cancel an extended selection in +# progress. If there is an extended selection in progress, it +# restores all of the items between the active one and the anchor +# to their previous selection state. +# +# Arguments: +# w - The listbox widget. +sub Cancel +{ + my $w = shift; + if ($w->cget('-selectmode') ne 'extended' || !defined $w->{'PREVIOUS_ELEMENT'}) + { + return; + } + my $first = $w->index('anchor'); + my $last = $w->{'PREVIOUS_ELEMENT'}; + if ($first > $last) + { + ($first,$last)=($last,$first); + } + $w->selectionClear($first,$last); + while ($first <= $last) + { + if (Tk::lsearch($w->{'SELECTION_LIST_REF'},$first) >= 0) + { + $w->selectionSet($first) + } + $first += 1 + } +} +# SelectAll +# +# This procedure is invoked to handle the "select all" operation. +# For single and browse mode, it just selects the active element. +# Otherwise it selects everything in the widget. +# +# Arguments: +# w - The listbox widget. +sub SelectAll +{ + my $w = shift; + my $mode = $w->cget('-selectmode'); + if ($mode eq 'single' || $mode eq 'browse') + { + $w->selectionClear(0,'end'); + $w->selectionSet('active') + } + else + { + $w->selectionSet(0,'end') + } +} + +sub SetList +{ + my $w = shift; + $w->delete(0,'end'); + $w->insert('end',@_); +} + +sub deleteSelected +{ + my $w = shift; + my $i; + foreach $i (reverse $w->curselection) + { + $w->delete($i); + } +} + +sub clipboardPaste +{ + my $w = shift; + my $element = $w->index('active') || $w->index($w->XEvent->xy); + my $str; + eval {local $SIG{__DIE__}; $str = $w->clipboardGet }; + return if $@; + foreach (split("\n",$str)) + { + $w->insert($element++,$_); + } +} + +sub getSelected +{ + my ($w) = @_; + my $i; + my (@result) = (); + foreach $i ($w->curselection) + { + push(@result,$w->get($i)); + } + return (wantarray) ? @result : $result[0]; +} + + + +1; diff --git a/Master/tlpkg/tlperl/lib/Tk/TextUndo.pm b/Master/tlpkg/tlperl/lib/Tk/TextUndo.pm new file mode 100644 index 00000000000..066e4027a3a --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/TextUndo.pm @@ -0,0 +1,1022 @@ +# Copyright (c) 1995-2004 Nick Ing-Simmons. +# Copyright (c) 1999 Greg London. +# All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +package Tk::TextUndo; + +use vars qw($VERSION $DoDebug); +$VERSION = '4.013'; # $Id: //depot/Tkutf8/Tk/TextUndo.pm#15 $ +$DoDebug = 0; + +use Tk qw (Ev); +use AutoLoader; + +use Tk::Text (); +use base qw(Tk::Text); + +Construct Tk::Widget 'TextUndo'; + +sub ClassInit +{ + my ($class,$mw) = @_; + $mw->bind($class,'<<Undo>>','undo'); + $mw->bind($class,'<<Redo>>','redo'); + + return $class->SUPER::ClassInit($mw); +} + + +#################################################################### +# methods for manipulating the undo and redo stacks. +# no one should directly access the stacks except for these methods. +# everyone else must access the stacks through these methods. +#################################################################### +sub ResetUndo +{ + my ($w) = @_; + delete $w->{UNDO}; + delete $w->{REDO}; +} + +sub PushUndo +{ + my $w = shift; + $w->{UNDO} = [] unless (exists $w->{UNDO}); + push(@{$w->{UNDO}},@_); +} + +sub PushRedo +{ + my $w = shift; + $w->{REDO} = [] unless (exists $w->{REDO}); + push(@{$w->{REDO}},@_); +} + +sub PopUndo +{ + my ($w) = @_; + return pop(@{$w->{UNDO}}) if defined $w->{UNDO}; + return undef; +} + +sub PopRedo +{ + my ($w) = @_; + return pop(@{$w->{REDO}}) if defined $w->{REDO}; + return undef; +} + +sub ShiftRedo +{ + my ($w) = @_; + return shift(@{$w->{REDO}}) if defined $w->{REDO}; + return undef; +} + +sub numberChanges +{ + my ($w) = @_; + return 0 unless (exists $w->{'UNDO'}) and (defined($w->{'UNDO'})); + return scalar(@{$w->{'UNDO'}}); +} + +sub SizeRedo +{ + my ($w) = @_; + return 0 unless exists $w->{'REDO'}; + return scalar(@{$w->{'REDO'}}); +} + +sub getUndoAtIndex +{ + my ($w,$index) = @_; + return undef unless (exists $w->{UNDO}); + return $w->{UNDO}[$index]; +} + +sub getRedoAtIndex +{ + my ($w,$index) = @_; + return undef unless (exists $w->{REDO}); + return $w->{REDO}[$index]; +} + +#################################################################### +# type "hello there" +# hello there_ +# hit UNDO +# hello_ +# type "out" +# hello out_ +# pressing REDO should not do anything +# pressing UNDO should make "out" disappear. +# pressing UNDO should make "there" reappear. +# pressing UNDO should make "there" disappear. +# pressing UNDO should make "hello" disappear. +# +# if there is anything in REDO stack and +# the OperationMode is normal, (i.e. not in the middle of an ->undo or ->redo) +# then before performing the current operation +# take the REDO stack, and put it on UNDO stack +# such that UNDO/REDO keystrokes will still make logical sense. +# +# call this method at the beginning of any overloaded method +# which adds operations to the undo or redo stacks. +# it will perform all the magic needed to handle the redo stack. +#################################################################### +sub CheckForRedoShuffle +{ + my ($w) = @_; + my $size_redo = $w->SizeRedo; + return unless $size_redo && ($w->OperationMode eq 'normal'); + # local $DoDebug = 1; + + # we are about to 'do' something new, but have something in REDO stack. + # The REDOs may conflict with new ops, but we want to preserve them. + # So convert them to UNDOs - effectively do them and their inverses + # so net effect on the widget is no-change. + + $w->dump_array('StartShuffle'); + + $w->OperationMode('REDO_MAGIC'); + $w->MarkSelectionsSavePositions; + + my @pvtundo; + + # go through REDO array from end downto 0, i.e. pseudo pop + # then pretend we did 'redo' get inverse, and push into UNDO array + # and 'do' the op. + for (my $i=$size_redo-1; $i>=0 ; $i--) + { + my ($op,@args) = @{$w->getRedoAtIndex($i)}; + my $op_undo = $op .'_UNDO'; + # save the inverse of the op on the UNDO array + # do this before the re-doing the op - after a 'delete' we cannot see + # text we deleted! + my $undo = $w->$op_undo(@args); + $w->PushUndo($undo); + # We must 'do' the operation now so if this is an insert + # the text and tags are available for inspection in delete_UNDO, and + # indices reflect changes. + $w->$op(@args); + # Save the undo that will reverse what we just did - it is + # on the undo stack but will be tricky to find + push(@pvtundo,$undo); + } + + # Now shift each item off REDO array until empty + # push each item onto UNDO array - this reverses the order + # and we are not altering buffer so we cannot look in the + # buffer to compute inverses - which is why we saved them above + + while ($w->SizeRedo) + { + my $ref = $w->ShiftRedo; + $w->PushUndo($ref); + } + + # Finally undo whatever we did to compensate for doing it + # and get buffer back to state it was before we started. + while (@pvtundo) + { + my ($op,@args) = @{pop(@pvtundo)}; + $w->$op(@args); + } + + $w->RestoreSelectionsMarkedSaved; + $w->OperationMode('normal'); + $w->dump_array('EndShuffle'); +} + +# sets/returns undo/redo/normal operation mode +sub OperationMode +{ + my ($w,$mode) = @_; + $w->{'OPERATION_MODE'} = $mode if (@_ > 1); + $w->{'OPERATION_MODE'} = 'normal' unless exists($w->{'OPERATION_MODE'}); + return $w->{'OPERATION_MODE'}; +} + +#################################################################### +# dump the undo and redo stacks to the screen. +# used for debug purposes. +sub dump_array +{ + return unless $DoDebug; + my ($w,$why) = @_; + print "At $why:\n"; + foreach my $key ('UNDO','REDO') + { + if (defined($w->{$key})) + { + print " $key array is:\n"; + my $array = $w->{$key}; + foreach my $ref (@$array) + { + my @items; + foreach my $item (@$ref) + { + my $loc = $item; + $loc =~ tr/\n/\^/; + push(@items,$loc); + } + print " [",join(',',@items),"]\n"; + } + } + } + print "\n"; +} + + +############################################################ +############################################################ +# these are a group of methods used to indicate the start and end of +# several operations that are to be undo/redo 'ed in a single step. +# +# in other words, "glob" a bunch of operations together. +# +# for example, a search and replace should be undone with a single +# keystroke, rather than one keypress undoes the insert and another +# undoes the delete. +# all other methods should access the count via these methods. +# no other method should directly access the {GLOB_COUNT} value directly +############################################################# +############################################################# + +sub AddOperation +{ + my ($w,@operation) = @_; + my $mode = $w->OperationMode; + + if ($mode eq 'normal') + {$w->PushUndo([@operation]);} + elsif ($mode eq 'undo') + {$w->PushRedo([@operation]);} + elsif ($mode eq 'redo') + {$w->PushUndo([@operation]);} + else + {die "invalid destination '$mode', must be one of 'normal', 'undo' or 'redo'";} +} + +sub addGlobStart # add it to end of undo list +{ + my ($w, $who) = @_; + unless (defined($who)) {$who = (caller(1))[3];} + $w->CheckForRedoShuffle; + $w->dump_array('Start'.$who); + $w->AddOperation('GlobStart', $who) ; +} + +sub addGlobEnd # add it to end of undo list +{ + my ($w, $who) = @_; + unless (defined($who)) {$who = (caller(1))[3];} + my $topundo = $w->getUndoAtIndex(-1); + if ($topundo->[0] eq 'GlobStart') + { + $w->PopUndo; + } + else + { + my $nxtundo = $w->getUndoAtIndex(-2); + if ($nxtundo->[0] eq 'GlobStart') + { + $w->PopUndo; + $w->PopUndo; + $w->PushUndo($topundo); + } + else + { + $w->AddOperation('GlobEnd', $who); + } + } + $w->dump_array('End'.$who); +} + +sub GlobStart +{ + my ($w, $who) = @_; + unless (defined($w->{GLOB_COUNT})) {$w->{GLOB_COUNT}=0;} + if ($w->OperationMode eq 'normal') + { + $w->PushUndo($w->GlobStart_UNDO($who)); + } + $w->{GLOB_COUNT} = $w->{GLOB_COUNT} + 1; +} + +sub GlobStart_UNDO +{ + my ($w, $who) = @_; + $who = 'GlobEnd_UNDO' unless defined($who); + return ['GlobEnd',$who]; +} + +sub GlobEnd +{ + my ($w, $who) = @_; + unless (defined($w->{GLOB_COUNT})) {$w->{GLOB_COUNT}=0;} + if ($w->OperationMode eq 'normal') + { + $w->PushUndo($w->GlobStart_UNDO($who)); + } + $w->{GLOB_COUNT} = $w->{GLOB_COUNT} - 1; +} + +sub GlobEnd_UNDO +{ + my ($w, $who) = @_; + $who = 'GlobStart_UNDO' unless defined($who); + return ['GlobStart',$who]; +} + +sub GlobCount +{ + my ($w,$count) = @_; + unless ( exists($w->{'GLOB_COUNT'}) and defined($w->{'GLOB_COUNT'}) ) + { + $w->{'GLOB_COUNT'}=0; + } + if (defined($count)) + { + $w->{'GLOB_COUNT'}=$count; + } + return $w->{'GLOB_COUNT'}; +} + +#################################################################### +# two methods should be used by applications to access undo and redo +# capability, namely, $w->undo; and $w->redo; methods. +# these methods undo and redo the last operation, respectively. +#################################################################### +sub undo +{ + my ($w) = @_; + $w->dump_array('Start'.'undo'); + unless ($w->numberChanges) {$w->bell; return;} # beep and return if empty + $w->GlobCount(0); #initialize to zero + $w->OperationMode('undo'); + do + { + my ($op,@args) = @{$w->PopUndo}; # get undo operation, convert ref to array + my $undo_op = $op .'_UNDO'; + $w->PushRedo($w->$undo_op(@args)); # find out how to undo it + $w->$op(@args); # do the operation + } while($w->GlobCount and $w->numberChanges); + $w->OperationMode('normal'); + $w->dump_array('End'.'undo'); +} + +sub redo +{ + my ($w) = @_; + unless ($w->SizeRedo) {$w->bell; return;} # beep and return if empty + $w->OperationMode('redo'); + $w->GlobCount(0); #initialize to zero + do + { + my ($op,@args) = @{$w->PopRedo}; # get op from redo stack, convert to list + my $undo_op = $op .'_UNDO'; + $w->PushUndo($w->$undo_op(@args)); # figure out how to undo operation + $w->$op(@args); # do the operation + } while($w->GlobCount and $w->SizeRedo); + $w->OperationMode('normal'); +} + + +############################################################ +# override low level subroutines so that they work with UNDO/REDO capability. +# every overridden subroutine must also have a corresponding *_UNDO subroutine. +# the *_UNDO method takes the same parameters in and returns an array reference +# which is how to undo itself. +# note that the *_UNDO must receive absolute indexes. +# ->insert receives 'markname' as the starting index. +# ->insert must convert 'markname' using $absindex=$w->index('markname') +# and pass $absindex to ->insert_UNDO. +############################################################ + +sub insert +{ + my $w = shift; + $w->markSet('insert', $w->index(shift) ); + while(@_) + { + my $index1 = $w->index('insert'); + my $string = shift; + my $taglist_ref = shift if @_; + + if ($w->OperationMode eq 'normal') + { + $w->CheckForRedoShuffle; + $w->PushUndo($w->insert_UNDO($index1,$string,$taglist_ref)); + } + $w->markSet('notepos' => $index1); + $w->SUPER::insert($index1,$string,$taglist_ref); + $w->markSet('insert', $w->index('notepos')); + } +} + +sub insert_UNDO +{ + my $w = shift; + my $index = shift; + my $string = ''; + # This possible call: ->insert (index, string, tag, string, tag...); + # if more than one string, keep reading strings in (discarding tags) + # until all strings are read in and $string contains entire text inserted. + while (@_) + { + $string .= shift; + my $tags = shift if (@_); + } + # calculate index + # possible things to insert: + # carriage return + # single character (not CR) + # single line of characters (not ending in CR) + # single line of characters ending with a CR + # multi-line characters. last line does not end with CR + # multi-line characters, last line does end with CR. + my ($line,$col) = split(/\./,$index); + if ($string =~ /\n(.*)$/) + { + $line += $string =~ tr/\n/\n/; + $col = length($1); + } + else + { + $col += length($string); + } + return ['delete', $index, $line.'.'.$col]; +} + +sub delete +{ + my ($w, $start, $stop) = @_; + unless(defined($stop)) + { $stop = $start .'+1c'; } + my $index1 = $w->index($start); + my $index2 = $w->index($stop); + if ($w->OperationMode eq 'normal') + { + $w->CheckForRedoShuffle; + $w->PushUndo($w->delete_UNDO($index1,$index2)); + } + $w->SUPER::delete($index1,$index2); + # why call SetCursor - it has side effects + # which cause a whole slew if save/restore hassles ? + $w->SetCursor($index1); +} + +sub delete_UNDO +{ + my ($w, $index1, $index2) = @_; + my %tags; + my @result = ( 'insert' => $index1 ); + my $str = ''; + + ############################################################### + # get tags in range and return them in a format that + # can be inserted. + # $text->insert('1.0', $string1, [tag1,tag2], $string2, [tag2, tag3]); + # note, have to break tags up into sequential order + # in reference to _all_ tags. + ############################################################### + + $w->dump('-text','-tag', -command => sub { + my ($kind,$value,$posn) = @_; + if ($kind eq 'text') + { + $str .= $value; + } + else + { + push(@result,$str,[keys %tags]) if (length $str); + $str = ''; + if ($kind eq 'tagon') + { + $tags{$value} = 1; + } + elsif ($kind eq 'tagoff') + { + delete $tags{$value}; + } + } + }, $index1, $index2); + push(@result,$str,[keys %tags]) if (length $str); + return \@result; +} + +############################################################ +# override subroutines which are collections of low level +# routines executed in sequence. +# wrap a globstart and globend around the SUPER:: version of routine. +############################################################ + +sub ReplaceSelectionsWith +{ + my $w = shift; + $w->addGlobStart; + $w->SUPER::ReplaceSelectionsWith(@_); + $w->addGlobEnd; +} + +sub FindAndReplaceAll +{ + my $w = shift; + $w->addGlobStart; + $w->SUPER::FindAndReplaceAll(@_); + $w->addGlobEnd; +} + +sub clipboardCut +{ + my $w = shift; + $w->addGlobStart; + $w->SUPER::clipboardCut(@_); + $w->addGlobEnd; +} + +sub clipboardPaste +{ + my $w = shift; + $w->addGlobStart; + $w->SUPER::clipboardPaste(@_); + $w->addGlobEnd; +} + +sub clipboardColumnCut +{ + my $w = shift; + $w->addGlobStart; + $w->SUPER::clipboardColumnCut(@_); + $w->addGlobEnd; +} + +sub clipboardColumnPaste +{ + my $w = shift; + $w->addGlobStart; + $w->SUPER::clipboardColumnPaste(@_); + $w->addGlobEnd; +} + +# Greg: this method is more tightly coupled to the base class +# than I would prefer, but I know of no other way to do it. + +sub Insert +{ + my ($w,$char)=@_; + return if $char eq ''; + $w->addGlobStart; + $w->SUPER::Insert($char); + $w->addGlobEnd; + $w->see('insert'); +} + + +sub InsertKeypress +{ + my ($w,$char)=@_; + return if $char eq ''; + if ($char =~ /^\S$/ and !$w->OverstrikeMode and !$w->tagRanges('sel')) + { + my $index = $w->index('insert'); + my $undo_item = $w->getUndoAtIndex(-1); + if (defined($undo_item) && + ($undo_item->[0] eq 'delete') && + ($undo_item->[2] == $index) + ) + { + $w->SUPER::insert($index,$char); + $undo_item->[2] = $w->index('insert'); + return; + } + } + $w->addGlobStart; + $w->SUPER::InsertKeypress($char); + $w->addGlobEnd; +} + +############################################################ +sub TextUndoFileProgress +{ + my ($w,$action,$filename,$count,$val,$total) = @_; + return unless(defined($filename) and defined($count)); + + my $popup = $w->{'FILE_PROGRESS_POP_UP'}; + unless (defined($popup)) + { + $w->update; + $popup = $w->Toplevel(-title => "File Progress",-popover => $w); + $popup->transient($w->toplevel); + $popup->withdraw; + $popup->resizable('no','no'); + $popup->Label(-textvariable => \$popup->{ACTION})->pack; + $popup->Label(-textvariable => \$popup->{FILENAME})->pack; + $popup->Label(-textvariable => \$popup->{COUNT})->pack; + my $f = $popup->Frame(-height => 10, -border => 2, -relief => 'sunken')->pack(-fill => 'x'); + my $i = $f->Frame(-background => 'blue', -relief => 'raised', -border => 2); + $w->{'FILE_PROGRESS_POP_UP'} = $popup; + $popup->{PROGBAR} = $i; + } + $popup->{ACTION} = $action; + $popup->{COUNT} = "lines: $count"; + $popup->{FILENAME} = "Filename: $filename"; + if (defined($val) && defined($total) && $total != 0) + { + $popup->{PROGBAR}->place('-x' => 0, '-y' => 0, -relheight => 1, -relwidth => $val/$total); + } + else + { + $popup->{PROGBAR}->placeForget; + } + + $popup->idletasks; + unless ($popup->viewable) + { + $w->idletasks; + $w->toplevel->deiconify unless $w->viewable; + $popup->Popup; + } + $popup->update; + return $popup; +} + +sub FileName +{ + my ($w,$filename) = @_; + if (@_ > 1) + { + $w->{'FILENAME'}=$filename; + } + return $w->{'FILENAME'}; +} + +sub PerlIO_layers +{ + my ($w,$layers) = @_; + $w->{PERLIO_LAYERS} = $layers if @_ > 1; + return $w->{PERLIO_LAYERS} || '' ; +} + +sub ConfirmDiscard +{ + my ($w)=@_; + if ($w->numberChanges) + { + my $ans = $w->messageBox(-icon => 'warning', + -type => 'YesNoCancel', -default => 'Yes', + -message => +"The text has been modified without being saved. +Save edits?"); + return 0 if $ans eq 'Cancel'; + return 0 if ($ans eq 'Yes' && !$w->Save); + } + return 1; +} + +################################################################################ +# if the file has been modified since being saved, a pop up window will be +# created, asking the user to confirm whether or not to exit. +# this allows the user to return to the application and save the file. +# the code would look something like this: +# +# if ($w->user_wants_to_exit) +# {$w->ConfirmExit;} +# +# it is also possible to trap attempts to delete the main window. +# this allows the ->ConfirmExit method to be called when the main window +# is attempted to be deleted. +# +# $mw->protocol('WM_DELETE_WINDOW'=> +# sub{$w->ConfirmExit;}); +# +# finally, it might be desirable to trap Control-C signals at the +# application level so that ->ConfirmExit is also called. +# +# $SIG{INT}= sub{$w->ConfirmExit;}; +# +################################################################################ + +sub ConfirmExit +{ + my ($w) = @_; + $w->toplevel->destroy if $w->ConfirmDiscard; +} + +sub Save +{ + my ($w,$filename) = @_; + $filename = $w->FileName unless defined $filename; + return $w->FileSaveAsPopup unless defined $filename; + my $layers = $w->PerlIO_layers; + if (open(my $file,">$layers",$filename)) + { + my $status; + my $count=0; + my $index = '1.0'; + my $progress; + my ($lines) = $w->index('end - 1 chars') =~ /^(\d+)\./; + while ($w->compare($index,'<','end')) + { +# my $end = $w->index("$index + 1024 chars"); + my $end = $w->index("$index lineend +1c"); + print $file $w->get($index,$end); + $index = $end; + if (($count++%1000) == 0) + { + $progress = $w->TextUndoFileProgress (Saving => $filename,$count,$count,$lines); + } + } + $progress->withdraw if defined $progress; + if (close($file)) + { + $w->ResetUndo; + $w->FileName($filename); + return 1; + } + } + else + { + $w->BackTrace("Cannot open $filename:$!"); + } + return 0; +} + +sub Load +{ + my ($w,$filename) = @_; + $filename = $w->FileName unless (defined($filename)); + return 0 unless defined $filename; + my $layers = $w->PerlIO_layers; + if (open(my $file,"<$layers",$filename)) + { + $w->MainWindow->Busy; + $w->EmptyDocument; + my $count=1; + my $progress; + while (<$file>) + { + $w->SUPER::insert('end',$_); + if (($count++%1000) == 0) + { + $progress = $w->TextUndoFileProgress (Loading => $filename, + $count,tell($file),-s $filename); + } + } + close($file); + $progress->withdraw if defined $progress; + $w->markSet('insert' => '1.0'); + $w->FileName($filename); + $w->MainWindow->Unbusy; + } + else + { + $w->BackTrace("Cannot open $filename:$!"); + } +} + +sub IncludeFile +{ + my ($w,$filename) = @_; + unless (defined($filename)) + {$w->BackTrace("filename not specified"); return;} + my $layers = $w->PerlIO_layers; + if (open(my $file,"<$layers",$filename)) + { + $w->Busy; + my $count=1; + $w->addGlobStart; + my $progress; + while (<$file>) + { + $w->insert('insert',$_); + if (($count++%1000) == 0) + { + $progress = $w->TextUndoFileProgress(Including => $filename, + $count,tell($file),-s $filename); + } + } + $progress->withdraw if defined $progress; + $w->addGlobEnd; + close($file); + $w->Unbusy; + } + else + { + $w->BackTrace("Cannot open $filename:$!"); + } +} + +# clear document without pushing it into UNDO array, (use SUPER::delete) +# (using plain delete(1.0,end) on a really big document fills up the undo array) +# and then clear the Undo and Redo stacks. +sub EmptyDocument +{ + my ($w) = @_; + $w->SUPER::delete('1.0','end'); + $w->ResetUndo; + $w->FileName(undef); +} + +sub ConfirmEmptyDocument +{ + my ($w)=@_; + $w->EmptyDocument if $w->ConfirmDiscard; +} + +sub FileMenuItems +{ + my ($w) = @_; + return [ + ["command"=>'~Open', -command => [$w => 'FileLoadPopup']], + ["command"=>'~Save', -command => [$w => 'Save' ]], + ["command"=>'Save ~As', -command => [$w => 'FileSaveAsPopup']], + ["command"=>'~Include', -command => [$w => 'IncludeFilePopup']], + ["command"=>'~Clear', -command => [$w => 'ConfirmEmptyDocument']], + "-",@{$w->SUPER::FileMenuItems} + ] +} + +sub EditMenuItems +{ + my ($w) = @_; + + return [ + ["command"=>'Undo', -command => [$w => 'undo']], + ["command"=>'Redo', -command => [$w => 'redo']], + "-",@{$w->SUPER::EditMenuItems} + ]; +} + +sub CreateFileSelect +{ + my $w = shift; + my $k = shift; + my $name = $w->FileName; + my @types = (['All Files', '*']); + my $dir = undef; + if (defined $name) + { + require File::Basename; + my $sfx; + ($name,$dir,$sfx) = File::Basename::fileparse($name,'\..*'); + # + # it should never happen where we have a file suffix and + # no file name... but fileparse() screws this up with dotfiles. + # + if (length($sfx) && !length($name)) { ($name, $sfx) = ($sfx, $name) } + + if (defined($sfx) && length($sfx)) + { + unshift(@types,['Similar Files',[$sfx]]); + $name .= $sfx; + } + } + return $w->$k(-initialdir => $dir, -initialfile => $name, + -filetypes => \@types, @_); +} + +sub FileLoadPopup +{ + my ($w)=@_; + my $name = $w->CreateFileSelect('getOpenFile',-title => 'File Load'); + return $w->Load($name) if defined($name) and length($name); + return 0; +} + +sub IncludeFilePopup +{ + my ($w)=@_; + my $name = $w->CreateFileSelect('getOpenFile',-title => 'File Include'); + return $w->IncludeFile($name) if defined($name) and length($name); + return 0; +} + +sub FileSaveAsPopup +{ + my ($w)=@_; + my $name = $w->CreateFileSelect('getSaveFile',-title => 'File Save As'); + return $w->Save($name) if defined($name) and length($name); + return 0; +} + + +sub MarkSelectionsSavePositions +{ + my ($w)=@_; + $w->markSet('MarkInsertSavePosition','insert'); + my @ranges = $w->tagRanges('sel'); + my $i = 0; + while (@ranges) + { + my ($start,$end) = splice(@ranges,0,2); + $w->markSet( 'MarkSelectionsSavePositions_'.++$i, $start); + $w->markSet( 'MarkSelectionsSavePositions_'.++$i, $end); + $w->tagRemove('sel',$start,$end); + } +} + +sub RestoreSelectionsMarkedSaved +{ + my ($w)=@_; + my $i = 1; + my %mark_hash; + foreach my $mark ($w->markNames) + { + $mark_hash{$mark}=1; + } + while(1) + { + my $markstart = 'MarkSelectionsSavePositions_'.$i++; + last unless(exists($mark_hash{$markstart})); + my $indexstart = $w->index($markstart); + my $markend = 'MarkSelectionsSavePositions_'.$i++; + last unless(exists($mark_hash{$markend})); + my $indexend = $w->index($markend); + $w->tagAdd('sel',$indexstart, $indexend); + $w->markUnset($markstart, $markend); + } + $w->markSet('insert','MarkInsertSavePosition'); +} + +#################################################################### +# selected lines may be discontinous sequence. +sub GetMarkedSelectedLineNumbers +{ + my ($w) = @_; + + my $i = 1; + my %mark_hash; + my @ranges; + foreach my $mark ($w->markNames) + { + $mark_hash{$mark}=1; + } + + while(1) + { + my $markstart = 'MarkSelectionsSavePositions_'.$i++; + last unless(exists($mark_hash{$markstart})); + my $indexstart = $w->index($markstart); + my $markend = 'MarkSelectionsSavePositions_'.$i++; + last unless(exists($mark_hash{$markend})); + my $indexend = $w->index($markend); + + push(@ranges, $indexstart, $indexend); + } + + my @selection_list; + while (@ranges) + { + my ($first) = split(/\./,shift(@ranges)); + my ($last) = split(/\./,shift(@ranges)); + # if previous selection ended on the same line that this selection starts, + # then fiddle the numbers so that this line number isnt included twice. + if (defined($selection_list[-1]) and ($first == $selection_list[-1])) + { + # if this selection ends on the same line its starts, then skip this sel + next if ($first == $last); + $first++; # count this selection starting from the next line. + } + push(@selection_list, $first .. $last); + } + return @selection_list; +} + +sub insertStringAtStartOfSelectedLines +{ + my ($w,$insert_string)=@_; + $w->addGlobStart; + $w->MarkSelectionsSavePositions; + foreach my $line ($w->GetMarkedSelectedLineNumbers) + { + $w->insert($line.'.0', $insert_string); + } + $w->RestoreSelectionsMarkedSaved; + $w->addGlobEnd; +} + +sub deleteStringAtStartOfSelectedLines +{ + my ($w,$insert_string)=@_; + $w->addGlobStart; + $w->MarkSelectionsSavePositions; + my $length = length($insert_string); + foreach my $line ($w->GetMarkedSelectedLineNumbers) + { + my $start = $line.'.0'; + my $end = $line.'.'.$length; + my $current_text = $w->get($start, $end); + next unless ($current_text eq $insert_string); + $w->delete($start, $end); + } + $w->RestoreSelectionsMarkedSaved; + $w->addGlobEnd; +} + + +1; +__END__ + diff --git a/Master/tlpkg/tlperl/lib/Tk/Tiler.pm b/Master/tlpkg/tlperl/lib/Tk/Tiler.pm new file mode 100644 index 00000000000..1256612f801 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Tiler.pm @@ -0,0 +1,203 @@ +# Copyright (c) 1995-2004 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. +# An example of a geometry manager "widget" in perl +package Tk::Tiler; +require Tk; +require Tk::Frame; + +use vars qw($VERSION); +$VERSION = sprintf '4.%03d', q$Revision: #12 $ =~ /\D(\d+)\s*$/; + +use base qw(Tk::Frame); + +Construct Tk::Widget 'Tiler'; +sub Tk::Widget::ScrlTiler { shift->Scrolled('Tiler' => @_) } + +use Tk::Pretty; + +sub FocusChildren +{ + return (wantarray) ? () : 0; +} + +sub Populate +{ + my ($obj,$args) = @_; + $obj->SUPER::Populate($args); + $obj->{Slaves} = []; + $obj->{LayoutPending} = 0; + $obj->{Start} = 0; + $obj->{Sw} = 0; + $obj->{Sh} = 0; + $obj->ConfigSpecs('-takefocus' => ['SELF', 'takeFocus','TakeFocus',1], + '-highlightthickness' => ['SELF', 'highlightThickness','HighlightThickness',2], + '-yscrollcommand' => ['CALLBACK',undef,undef,undef], + '-columns' => ['PASSIVE','columns','Columns',5], + '-rows' => ['PASSIVE','rows','Rows',10] + ); + return $obj; +} + +sub change_size +{ + my ($w) = shift; + my $r = $w->cget('-rows'); + my $c = $w->cget('-columns'); + my $bw = $w->cget(-highlightthickness); + if (defined $r && defined $c) + { + $w->GeometryRequest($c*$w->{Sw}+2*$bw,$r*$w->{Sh}+2*$bw); + } +} + +sub Layout +{ + my $m = shift; + my $bw = $m->cget(-highlightthickness); + my $why = $m->{LayoutPending}; + $m->{LayoutPending} = 0; + my $W = $m->Width; + my $H = $m->Height; + my $w = $m->{Sw} || 1; # max width of slave + my $h = $m->{Sh} || 1; # max height of slave + my $x = $bw; + my $y = $bw; + my $start = 0; + # Set size and position of slaves + my $rows = $m->{Rows} = int(($H-2*$bw)/$h) || 1; + my $cols = $m->{Cols} = int(($W-2*$bw)/$w) || 1; + my $need = $m->{Need} = int( (@{$m->{Slaves}}+$cols-1)/$cols ); + $m->{Start} = ($need - $rows) if ($m->{Start} + $rows > $need); + + $m->{Start} = 0 if ($m->{Start} < 0); + my $row = 0; + my @posn = (); + my $s; + foreach $s (@{$m->{Slaves}}) + { + if ($row < $m->{Start}) + { + $s->UnmapWindow; + $x += $w; + if ($x+$w+$bw > $W) + { + $x = $bw; + $row++; + } + } + elsif ($y+$h+$bw > $H) + { + $s->UnmapWindow; + $s->ResizeWindow($w,$h) if ($why & 1); + } + else + { + push(@posn,[$s,$x,$y]); + $x += $w; + if ($x+$w+$bw > $W) + { + $x = $bw; + $y += $h; + $row++; + } + } + $s->ResizeWindow($w,$h) if ($why & 1); + } + $row++ if ($x > $bw); + if (defined $m->{Prev} && $m->{Prev} > $m->{Start}) + { + @posn = reverse(@posn); + } + while (@posn) + { + my $posn = shift(@posn); + my ($s,$x,$y) = (@$posn); + $s->MoveWindow($x,$y); + $s->MapWindow; + } + $m->{Prev} = $m->{Start}; + $m->Callback(-yscrollcommand => $m->{Start}/$need,$row/$need) if $need; +} + +sub QueueLayout +{ + my ($m,$why) = @_; + $m->afterIdle(['Layout',$m]) unless ($m->{LayoutPending}); + $m->{LayoutPending} |= $why; +} + +sub SlaveGeometryRequest +{ + my ($m,$s) = @_; + my $sw = $s->ReqWidth; + my $sh = $s->ReqHeight; + my $sz = 0; + if ($sw > $m->{Sw}) + { + $m->{Sw} = $sw; + $m->QueueLayout(1); + $sz++; + } + if ($sh > $m->{Sh}) + { + $m->{Sh} = $sh; + $m->QueueLayout(1); + $sz++; + } + $m->change_size if ($sz); +} + +sub LostSlave +{ + my ($m,$s) = @_; + @{$m->{Slaves}} = grep($_ != $s,@{$m->{Slaves}}); + $m->QueueLayout(2); +} + +sub Manage +{ + my $m = shift; + my $s; + foreach $s (@_) + { + $m->ManageGeometry($s); + push(@{$m->{Slaves}},$s); + $m->SlaveGeometryRequest($s); + } + $m->QueueLayout(2 | 1); +} + +sub moveto + { + my ($m,$frac) = (@_); + $m->{Start} = int($m->{Need} * $frac); + $m->QueueLayout(4); + } + +sub scroll + { + my ($m,$delta,$type) = @_; + $delta *= $m->{Rows}/2 if ($type eq 'pages'); + $m->{Start} += $delta; + $m->QueueLayout(4); + } + +sub yview { my $w = shift; my $c = shift; $w->$c(@_) } + +sub FocusIn +{ + my ($w) = @_; +# print 'Focus ',$w->PathName,"\n"; +} + +sub ClassInit +{ + my ($class,$mw) = @_; + $mw->bind($class,'<Configure>',['QueueLayout',8]); + $mw->bind($class,'<FocusIn>', 'NoOp'); + $mw->YscrollBind($class); + return $class; +} + +1; diff --git a/Master/tlpkg/tlperl/lib/Tk/TixGrid.pm b/Master/tlpkg/tlperl/lib/Tk/TixGrid.pm new file mode 100644 index 00000000000..2dd238095f3 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/TixGrid.pm @@ -0,0 +1,1597 @@ + +# TODO: +# +# o How to get into state 's0' 'b0' so cursor keys start +# working (compare with Tk/Widget XYscrollBind +# o the options -browsecmd and -command callback are not +# not implemented (as in Tix) +# o privateData 'state' used only once (check again Grid.tcl) +# o FloatEntry 'sometimes not activeted immediately on selection +# o check also Leave Binding. Looks like entry does get unpost'ed + +package Tk::TixGrid; + +BEGIN + { + use vars '$DEBUG'; + $DEBUG = (defined($ENV{USER}) and $ENV{USER} eq 'ach') ? 1 : 0; + print STDERR "tixGrid: debug = $DEBUG\n" if $DEBUG; + } + +use strict; +use vars qw($VERSION); +$VERSION = sprintf '4.%03d', q$Revision: #9 $ =~ /\D(\d+)\s*$/; + +use Tk qw(Ev $XS_VERSION); +use Tk::Widget; +use Carp; + +# carp "\n".__PACKAGE__.' is deprecated' unless defined($Test::ntest); + +use base 'Tk::Widget'; + +Construct Tk::Widget 'TixGrid'; + +bootstrap Tk::TixGrid; + +sub Tk_cmd { \&Tk::tixGrid } + +sub Tk::Widget::SrclTixGrid { shift->Scrolled('TixGrid' => @_) } + +Tk::Methods qw(anchor bdtype delete entrycget entryconfigure format index + move set size unset xview yview + dragsite dropsite geometryinfo info + nearest see selection sort ); + +use Tk::Submethods + ( + 'anchor' => [ qw(get set) ], + 'delete' => [ qw(column row) ], + 'info' => [ qw(bbox exists anchor) ], + 'move' => [ qw(column row) ], + 'selection' => [ qw(adjust clear includes set) ], + 'size' => [ qw(column row) ], + 'format' => [ qw(grid border) ], + ); + +# edit subcommand is special. It justs invokes tcl code: +# +# edit set x y -> tixGrid:EditCell $w, x, y +# edit apply -> tixGrid:EditApply + +# xxx Create an edit sub? +# sub edit { .... } + +sub editSet + { + die "wrong args. Should be \$w->editSet(x,y)\n" unless @_ == 3; + my ($w, $x, $y) = @_; + $w->EditCell($x, $y); + } + +sub editApply + { + die "wrong args. Should be \$w->editApply()\n" unless @_ == 1; + my ($w) = @_; + $w->EditApply() + } + + +#################################################### +## +## For button 2 scrolling. So TixGrid has 'standard' +## standard scrolling interface +## + +#sub scanMark +# { +# die "wrong # args: \$w->scanMark(x,y)\n" unless @_ == 3; +# my ($w) = @_; +# $w->{__scanMarkXY__} = [ @_[1,2] ]; +# return ""; +# } +# +#sub scanDragto +# { +# die "wrong # args: \$w->scanDragto(x,y)\n" unless @_ == 3; +# my ($w, $x, $y) = @_; +# my ($ox, $oy) = @{ $w->{__scanMarkXY__} }; +# +# #... +# +# return ""; +# } + +### end button 2 scrolling stuff #################### + + +# Grid.tcl -- +# +# This file defines the default bindings for Tix Grid widgets. +# +# Copyright (c) 1996, Expert Interface Technologies +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# Bindings translated to perl/Tk by Achim Bohnet <ach@mpe.mpg.de> + +sub ClassInit + { + my ($class, $mw) = @_; + $class->SUPER::ClassInit($mw); + + $mw->XYscrollBind($class); + + ## + ## Button bindings + ## + + $mw->bind($class, '<ButtonPress-1>', ['Button_1', Ev('x'), Ev('y')]); + $mw->bind($class, '<Shift-ButtonPress-1>', ['Shift_Button_1', Ev('x'), Ev('y')]); + $mw->bind($class, '<Control-ButtonPress-1>',['Control_Button_1', Ev('x'), Ev('y')]); + $mw->bind($class, '<ButtonRelease-1>', ['ButtonRelease_1', Ev('x'), Ev('y')]); + $mw->bind($class, '<Double-ButtonPress-1>', ['Double_1', Ev('x'), Ev('y')]); + $mw->bind($class, '<B1-Motion>','Button_Motion'); + $mw->bind($class, '<Control-B1-Motion>','Control_Button_Motion'); + $mw->bind($class, '<B1-Leave>','Button_Leave'); + $mw->bind($class, '<Double-ButtonPress-1>', ['Double_1', Ev('x'), Ev('y')]); + $mw->bind($class, '<B1-Enter>', ['B1_Enter', Ev('x'), Ev('y')]); + $mw->bind($class, '<Control-B1-Leave>','Control_Button_Leave'); + $mw->bind($class, '<Control-B1-Enter>', ['Control_B1_Enter', Ev('x'), Ev('y')]); + + ## + ## Keyboard bindings + ## + + $mw->bind($class, '<Up>', ['DirKey', 'up' ]); + $mw->bind($class, '<Down>', ['DirKey', 'down' ]); + $mw->bind($class, '<Left>', ['DirKey', 'left' ]); + $mw->bind($class, '<Right>', ['DirKey', 'right' ]); + + $mw->PriorNextBind($class); + + $mw->bind($class, '<Return>', 'Return'); + $mw->bind($class, '<space>', 'Space' ); + + return $class; + } + +#---------------------------------------------------------------------- +# +# +# Mouse bindings +# +# +#---------------------------------------------------------------------- + +sub Button_1 + { + my $w = shift; + + return if $w->cget('-state') eq 'disabled'; + $w->SetFocus; + $w->ChgState(@_, + [ + '0'=>'1', + ] + ); + } + +sub Shift_Button_1 + { + my $w = shift; + + return if $w->cget('-state') eq 'disabled'; + $w->SetFocus; + +# $w->ChgState(@_, +# [ +# ] +# ); + } + +sub Control_Button_1 + { + my $w = shift; + + return if $w->cget('-state') eq 'disabled'; + $w->SetFocus; + + $w->ChgState(@_, + [ + 's0' => 's1', + 'b0' => 'b1', + 'm0' => 'm1', + 'e0' => 'e10', + ] + ); + } + +sub ButtonRelease_1 + { + shift->ChgState(@_, + [ + '2' => '5', + '4' => '3', + ] + ); + } + +sub B1_Motion + { + shift->ChgState(@_, + [ + '2' => '4', + '4' => '4', + ] + ); + } + + +sub Control_B1_Motion + { + shift->ChgState(@_, + [ + 's2' => 's4', + 's4' => 's4', + 'b2' => 'b4', + 'b4' => 'b4', + 'm2' => 'm4', + 'm5' => 'm4', + ] + ); + } + + +sub Double_1 + { + shift->ChgState(@_, + [ + 's0' => 's7', + 'b0' => 'b7', + ] + ); + } + + +sub B1_Leave + { + shift->ChgState(@_, + [ + 's2' => 's5', + 's4' => 's5', + 'b2' => 'b5', + 'b4' => 'b5', + 'm2' => 'm8', + 'm5' => 'm8', + 'e2' => 'e8', + 'e5' => 'e8', + ] + ); + } + + +sub B1_Enter + { + shift->ChgState(@_, + [ + 's5' => 's4', + 's6' => 's4', + 'b5' => 'b4', + 'b6' => 'b4', + 'm8' => 'm4', + 'm9' => 'm4', + 'e8' => 'e4', + 'e9' => 'e4', + ] + ); + } + + +sub Control_B1_Leave + { + shift->ChgState(@_, + [ + 's2' => 's5', + 's4' => 's5', + 'b2' => 'b5', + 'b4' => 'b5', + 'm2' => 'm8', + 'm5' => 'm8', + ] + ); + } + + +sub Control_B1_Enter + { + shift->ChgState(@_, + [ + 's5' => 's4', + 's6' => 's4', + 'b5' => 'b4', + 'b6' => 'b4', + 'm8' => 'm4', + 'm9' => 'm4', + ] + ); + } + + +sub AutoScan + { + shift->ChgState(@_, + [ + 's5' => 's9', + 's6' => 's9', + 'b5' => 'b9', + 'b6' => 'b9', + 'm8' => 'm9', + 'm9' => 'm9', + 'e8' => 'm9', + 'e9' => 'm9', + ] + ); + } + +#---------------------------------------------------------------------- +# +# +# Key bindings +# +# +#---------------------------------------------------------------------- + +sub DirKey + { + my ($w, $key) = @_; + + return if $w->cget('-state') eq 'disabled'; + +print STDERR "$w->DirKey($key)\n" if $DEBUG; + $w->ChgState($key, + [ + 's0' => 's8', + 'b0' => 'b8', + ] + ); + } + + +sub Return + { + my ($w) = @_; + + return if $w->cget('-state') eq 'disabled'; + + $w->ChgState( + [ + 's0' => 's9', + 'b0' => 'b9', + ] + ); + } + + +sub Space + { + my ($w) = @_; + + return if $w->cget('-state') eq 'disabled'; + + $w->ChgState( + [ + 's0' => 's10', + 'b0' => 'b10', + ] + ); + } + + +#---------------------------------------------------------------------- +# +# STATE MANIPULATION +# +# +#---------------------------------------------------------------------- + +sub GetState + { + my ($w) = @_; + my $data = $w->privateData(); + $data->{state} = 0 unless exists $data->{state}; + return $data->{state}; +} + +sub Button_Motion +{ + my $w = shift; + my $Ev = $w->XEvent; + $Tk::x = $Ev->x; + $Tk::y = $Ev->y; + $Tk::X = $Ev->X; + $Tk::Y = $Ev->Y; + $w->B1_Motion($Tk::x, $Tk::y); +} + + +sub Control_Button_Motion +{ + my $w = shift; + my $Ev = $w->XEvent; + $Tk::x = $Ev->x; + $Tk::y = $Ev->y; + $Tk::X = $Ev->X; + $Tk::Y = $Ev->Y; + $w->Control_B1_Motion($Tk::x, $Tk::y); +} + + +sub Button_Leave +{ + my $w = shift; + my $Ev = $w->XEvent; + $Tk::x = $Ev->x; + $Tk::y = $Ev->y; + $Tk::X = $Ev->X; + $Tk::Y = $Ev->Y; + $w->B1_Leave(); +} + + +sub Control_Button_Leave +{ + my $w = shift; + my $Ev = $w->XEvent; + $Tk::x = $Ev->x; + $Tk::y = $Ev->y; + $Tk::X = $Ev->X; + $Tk::Y = $Ev->Y; + $w->Control_B1_Leave(); +} + + +sub SetState + { + my ($w, $state) = @_; + $w->privateData()->{state} = $state; + } + +sub GoState + { + my ($w, $state) = (shift, shift); + print STDERR 'Gostate: ', $w->GetState, " --> $state, " if $DEBUG; + $w->SetState($state); + my $method = "GoState_$state"; + + print STDERR 'args=(', join(',',@_), ')'. + "\t(",$w->cget('-selectmode'). + ',',$w->cget('-selectunit').")\n" if $DEBUG; + + if (0) + { + $@ = ''; + %@ = (); # Workaround to prevent spurious loss of $@ + eval { $w->$method(@_) }; + print STDERR "Error Gostate: '$state': ", $@ if $@; + return undef; + } + + $w->$method(@_); + return undef + } + +## +## ChgState is a fancy case statement +## + +sub ChgState + { + my $w = shift; + my $map = pop; + print STDERR 'ChgState(', join(',',@_,'['), join(',',@$map,),']) ' if $DEBUG; + my $state = $w->GetState; + + my ($match, $to); + while (@$map) + { + $match = shift @$map; + $to = shift @$map; + if ($match eq $state) + { + print STDERR "$state --> $to \n" if $DEBUG; + $w->GoState($to, @_); + return; + } + } + print STDERR "*no* chg for $state\n" if $DEBUG; + } + + +#---------------------------------------------------------------------- +# SELECTION ROUTINES +#---------------------------------------------------------------------- + +#proc tixGrid:SelectSingle {w ent} { +# $w selection set [lindex $ent 0] [lindex $ent 1] +# tixGrid:CallBrowseCmd $w $ent +#} + +sub SelectSingle + { + my ($w, $n1, $n2) = @_; + $w->selection('set', $n1, $n2); + $w->Callback('-browsecmd' => $n1, $n2); + } + +#---------------------------------------------------------------------- +# SINGLE SELECTION +#---------------------------------------------------------------------- + +sub GoState_0 + { + my ($w) = @_; + my $list = $w->privateData()->{list}; + return unless defined $list; + + foreach my $cmd (@$list) + { + # XXX should do more something like $w->Callback'('__pending_cmds__'); + eval $cmd; # XXX why in tcl in global context (binding?) + } + undef(@$list); # XXX should really delete? Maybe on needed in TCL + } + +# XXXX how to translate global context +# what does unset +#proc tixGrid:GoState-0 {w} { +# set list $w:_list +# global $list +# +# if [info exists $list] { +# foreach cmd [set $list] { +# uplevel #0 $cmd +# } +# if [info exists $list] { +# unset $list +# } +# } +#} + +sub GoState_1 + { + my ($w, $x, $y) = @_; + + my @ent = $w->mynearest($x,$y); + if (@ent) + { + $w->SetAnchor(@ent); + } + $w->CheckEdit; + $w->selection('clear', 0, 0, 'max', 'max'); + + if ($w->cget('-selectmode') ne 'single') + { + $w->SelectSingle(@ent); + } + $w->GoState(2); + } + +sub GoState_2 + { + my ($w) = @_; + } + +sub GoState_3 + { + my ($w, $x, $y) = @_; + + my @ent = $w->mynearest($x,$y); + if (@ent) + { + $w->SelectSingle(@ent); + } + $w->GoState(0); + + } + +sub GoState_4 + { + my ($w, $x, $y) = @_; + + my (@ent) = $w->mynearest($x,$y); + my $mode = $w->cget('-selectmode'); + + if ($mode eq 'single') + { + $w->SetAnchor(@ent); + } + elsif ($mode eq 'browse') + { + $w->SetAnchor(@ent); + $w->selection('clear', 0, 0, 'max', 'max'); + $w->SelectSingle(@ent); + } + elsif ($mode eq 'multiple' || + $mode eq 'extended') + { + my (@anchor) = $w->anchor('get'); + $w->selection('adjust', @anchor[0,1], @ent[0,1]); + } + } + +sub GoState_5 + { + my ($w, $x, $y) = @_; + + my @ent = $w->mynearest($x,$y); + if (@ent) + { + $w->SelectSingle(@ent); + $w->SetEdit(@ent); + } + $w->GoState(0); + + } + +############################################## +# BUG xxx +# return scalar instead of errors + +sub mynearest { shift->split_s2a('nearest', @_); } +sub myanchorGet { shift->split_s2a('anchor', 'get', @_); } + +sub split_s2a + { + my $w = shift; + my $method = shift; + my @ent = $w->$method(@_); + if (@ent == 1) + { +my $tmp = $ent[0]; + @ent = split(/ /, $ent[0]) if @ent == 1; +print STDERR join('|',"$method splitted '$tmp' =>",@ent,"\n") if $DEBUG; + } + else + { +#print STDERR join("|","$method splitted is okay :",@ent,"\n") if $DEBUG; + } + return @ent; + } + +############################################## + + +sub GoState_s5 + { + shift->StartScan(); + } + + +sub GoState_s6 + { + shift->DoScan(); + } + + +sub GoState_s7 + { + my ($w, $x, $y) = @_; + + my @ent = $w->mynearest($x, $y); + if (@ent) + { + $w->selection('clear'); + $w->selection('set', @ent); + $w->Callback('-command' => @ent); + } + $w->GoState('s0'); + } + + +sub GoState_s8 + { + my ($w, $key) = @_; + + ## BUGS .... + ## - anchor is bad, only bbox, exists8 + ## - looks like anchor is 1-dim: set anchor 0 + ## - method see unknown (even when defined with Tk::Method) + + my (@anchor) = $w->info('anchor'); + if (@anchor) + { + @anchor = (); + } + else + { + @anchor = $w->info($key, @anchor); + } + + $w->anchor('set', @anchor); + $w->see(@anchor); + + $w->GoState('s0'); + } + +#proc tixGrid:GoState-s8 {w key} { +# set anchor [$w info anchor] +# +# if {$anchor == ""} { +# set anchor 0 +# } else { +# set anchor [$w info $key $anchor] +# } +# +# $w anchor set $anchor +# $w see $anchor +# tixGrid:GoState s0 $w +#} + + +sub GoState_s9 + { + my ($w, $key) = @_; + +#print STDERR "GoState_s9 is not implemented\n"; + + my (@anchor) = $w->info('anchor'); + unless (@anchor) + { + @anchor = (); + $w->anchor('set', @anchor); + $w->see(@anchor); + } + + unless ($w->info('anchor')) + { + # ! may not have any elements + # + $w->Callback('-command' => $w->info('anchor')); + $w->selection('clear'); + $w->selection('set', @anchor); + } + + $w->GoState('s0'); + } + + +sub GoState_s10 + { + my ($w, $key) = @_; + + my (@anchor) = $w->info('anchor'); + if (@anchor) + { + @anchor = (); + $w->anchor('set', @anchor); + $w->see(@anchor); + } + + unless ($w->info('anchor')) + { + # ! may not have any elements + # + $w->Callback('-browsecmd' => $w->info('anchor')); + $w->selection('clear'); + $w->selection('set', @anchor); + } + + $w->GoState('s0'); + } + + +#---------------------------------------------------------------------- +# BROWSE SELECTION +#---------------------------------------------------------------------- + +sub GoState_b0 + { + my ($w) = @_; + } + +sub GoState_b1 + { + my ($w, $x, $y) = @_; + + my (@ent) = $w->mynearest($x, $y); + if (@ent) + { + $w->anchor('set', @ent); + $w->selection('clear'); + $w->selection('set', @ent); + $w->Callback('-browsecmd' => @ent); + } + + $w->GoState('b2'); + } + +sub GoState_b2 + { + my ($w) = @_; + } + +sub GoState_b3 + { + my ($w) = @_; + + my (@ent) = $w->info('anchor'); + if (@ent) + { + $w->selection('clear'); + $w->selection('set', @ent); + $w->selection('set', @ent); + $w->Callback('-browsecmd' => @ent); + } + + $w->GoState('b0'); + } + + +sub GoState_b4 + { + my ($w, $x, $y) = @_; + + my (@ent) = $w->mynearest($x, $y); + if (@ent) + { + $w->anchor('set', @ent); + $w->selection('clear'); + $w->selection('set', @ent); + $w->Callback('-browsecmd' => @ent); + } + } + + +sub GoState_b5 { shift->StartScan(); } + + +sub GoState_b6 { shift->DoScan(); } + + +sub GoState_b7 + { + my ($w, $x, $y) = @_; + + my (@ent) = $w->mynearest($x, $y); + if (@ent) + { + $w->selection('clear'); + $w->selection('set', @ent); + $w->Callback('-command' => @ent); + } + $w->GoState('b0'); + } + + +sub GoState_b8 + { + my ($w, $key) = @_; + + my (@anchor) = $w->info('anchor'); + if (@anchor) + { + @anchor = $w->info('key', @anchor); + } + else + { + @anchor = (0,0); # ????? + } + + $w->anchor('set', @anchor); + $w->selection('clear'); + $w->selection('set', @anchor); + $w->see(@anchor); + + $w->Callback('-browsecmd' => @anchor); + $w->GoState('b0'); + } + + +sub GoState_b9 + { + my ($w) = @_; + + my (@anchor) = $w->info('anchor'); + unless (@anchor) + { + @anchor = (0,0); + $w->anchor('set', @anchor); + $w->see(@anchor); + } + + if ($w->info('anchor')) + { + # ! may not have any elements + # + $w->Callback('-command' => $w->info('anchor')); + $w->selection('clear'); + $w->selection('set', @anchor); + } + + $w->GoState('b0'); + } + + +sub GoState_b10 + { + my ($w) = @_; + + my (@anchor) = $w->info('anchor'); + unless (@anchor) + { + @anchor = (0,0); + $w->anchor('set', @anchor); + $w->see(@anchor); + } + + if ($w->info('anchor')) + { + # ! may not have any elements + # + $w->Callback('-browsecmd' => $w->info('anchor')); + $w->selection('clear'); + $w->selection('set', @anchor); + } + + $w->GoState('b0'); + } + +#---------------------------------------------------------------------- +# MULTIPLE SELECTION +#---------------------------------------------------------------------- + + +sub GoState_m0 + { + my ($w) = @_; + } + +sub GoState_m1 + { + my ($w, $x, $y) = @_; + + my (@ent) = $w->mynearest($x,$y); + if (@ent) + { + $w->anchor('set', @ent); + $w->selection('clear'); + $w->selection('set', @ent); + $w->Callback('-browsecmd' => @ent); + } + + $w->GoState('m2'); + } + +sub GoState_m2 + { + my ($w) = @_; + } + +sub GoState_m3 + { + my ($w) = @_; + + my (@ent) = $w->info('anchor'); + if (@ent) + { + $w->Callback('-browsecmd' => @ent); + } + + $w->GoState('m0'); + } + + +sub GoState_m4 + { + my ($w, $x, $y) = @_; + + my (@from) = $w->info('anchor'); + my (@to) = $w->mynearest($x, $y); + if (@to) + { + $w->selection('clear'); + $w->selection('set', @from, @to); + $w->Callback('-browsecmd' => @to); + } + $w->GoState('m5'); + } + +sub GoState_m5 + { + my ($w) = @_; + } + +sub GoState_m6 + { + my ($w, $x, $y) = @_; + + my (@ent) = $w->mynearest($x, $y); + if (@ent) + { + $w->Callback('-browsecmd' => @ent); + } + $w->GoState('m0'); + } + +sub GoState_m7 + { + my ($w, $x, $y) = @_; + + my (@from) = $w->info('anchor'); + my (@to) = $w->mynearest($x, $y); + unless (@from) + { + @from = @to; + $w->anchor('set', @from); + } + if (@to) + { + $w->selection('clear'); + $w->selection('set', @from, @to); + $w->Callback('-browsecmd' => @to); + } + $w->GoState('m5'); + } + + +sub GoState_m8 { shift->StartScan() } + + +sub GoState_m9 { shift->DoScan() } + + +sub GoState_xm7 + { + my ($w, $x, $y) = @_; + + my (@ent) = $w->mynearest($x, $y); + if (@ent) + { + $w->selection('clear'); + $w->selection('set', @ent); + $w->Callback('-browsecmd' => @ent); + } + $w->GoState('m0'); + } + +#---------------------------------------------------------------------- +# EXTENDED SELECTION +#---------------------------------------------------------------------- + +sub GoState_e0 + { + my ($w) = @_; + } + +sub GoState_e1 + { + my ($w, $x, $y) = @_; + my (@ent) = $w->mynearest($x, $y); + if (@ent) + { + $w->anchor('set', @ent); + $w->selection('clear'); + $w->selection('set', @ent); + $w->Callback('-browsecmd' => @ent); + } + $w->GoState('e2'); + } + + +sub GoState_e2 + { + my ($w) = @_; + } + +sub GoState_e3 + { + my ($w) = @_; + + my (@ent) = $w->info('anchor'); + if (@ent) + { + $w->Callback('-browsecmd' => @ent); + } + $w->GoState('e0'); + } + +sub GoState_e4 + { + my ($w, $x, $y) = @_; + + my (@from) = $w->info('anchor'); + my (@to) = $w->mynearest($x, $y); + if (@to) + { + $w->selection('clear'); + $w->selection('set', @from, @to); + $w->Callback('-browsecmd' => @to); + } + $w->GoState('e5'); + } + +sub GoState_e5 + { + my ($w) = @_; + } + +sub GoState_e6 + { + my ($w, $x, $y) = @_; + + my (@ent) = $w->mynearest($x, $y); + if (@ent) + { + $w->Callback('-browsecmd' => @ent); + } + $w->GoState('e0'); + } + +sub GoState_e7 + { + my ($w, $x, $y) = @_; + + my (@from) = $w->info('anchor'); + my (@to) = $w->mynearest($x, $y); + unless (@from) + { + @from = @to; + $w->anchor('set', @from); + } + if (@to) + { + $w->selection('clear'); + $w->selection('set', @from, @to); + $w->Callback('-browsecmd' => @to); + } + $w->GoState('e5'); + } + +sub GoState_e8 { shift->StartScan(); } + +sub GoState_e9 { shift->DoScan(); } + +sub GoState_e10 + { + my ($w, $x, $y) = @_; + + my (@ent) = $w->mynearest($x, $y); + if (@ent) + { + if ($w->info('anchor')) + { + $w->anchor('set', @ent); + } + if ($w->selection('includes', @ent)) + { + $w->selection('clear', @ent); + } + else + { + $w->selection('set', @ent); + } + $w->Callback('-browsecmd' => @ent); + } + $w->GoState('e2'); + } + +sub GoState_xe7 + { + my ($w, $x, $y) = @_; + + my (@ent) = $w->mynearest($x, $y); + if (@ent) + { + $w->selection('clear'); + $w->selection('set', @ent); + $w->Callback('-command' => @ent); + } + $w->GoState('e0'); + } + + +#---------------------------------------------------------------------- +# HODGE PODGE +#---------------------------------------------------------------------- + +sub GoState_12 + { + my ($w, $x, $y) = @_; + + $w->CancelRepeat; # xxx will not work + $w->GoState(5, $x, $y); + } +#proc tixGrid:GoState-12 {w x y} { +# tkCancelRepeat +# tixGrid:GoState 5 $w $x $y +#} + +sub GoState_13 + { + # FIX: a) $ent or @ent, b) 13 is never called!!? same in Grid.tcl + my ($w, @ent, @oldEnt) = @_; + + my $data = $w->MainWindow->privateData('Tix'); + $data->{indicator} = \@ent; + $data->{oldEntry} = \@oldEnt; + $w->IndicatorCmd('<Arm>', @ent); + } +# set tkPriv(tix,oldEnt) $oldEnt +# tixGrid:IndicatorCmd $w <Arm> $ent +#} + +sub GoState_14 + { + my ($w, $x, $y) = @_; + + my $data = $w->MainWindow->privateData('Tix'); + if ($w->InsideArmedIndicator($x, $y)) + { + $w->anchor('set', @{ $data->{indicator} }); + $w->selection('clear'); + $w->selection('set', @{ $data->{indicator} }); + $w->IndicatorCmd('<Activate>', @{ $data->{indicator} }); + } + else + { + $w->IndicatorCmd('<Disarm>', @{ $data->{indicator} }); + } + delete($data->{indicator}); + $w->GoState(0); + } + +sub GoState_16 + { + my ($w, @ent) = @_; + + return unless (@ent); + if ($w->cget('-selectmode') ne 'single') + { + $w->Select(@ent); + $w->Browse(@ent); + } + } + +sub GoState_18 + { + my ($w) = @_; + + $w->CancelRepeat; ## xxx + $w->GoState(6, $Tk::x, $Tk::y); + } + +sub GoState_20 + { + my ($w, $x, $y) = @_; + + my $data = $w->MainWindow->privateData('Tix'); + if ($w->InsideArmedIndicator($x, $y)) + { + $w->IndicatorCmd('<Arm>', $data->{'indicator'}); + } + else + { + $w->GoState(21, $x, $y); + } + } + +sub GoState_21 + { + my ($w, $x, $y) = @_; + + my $data = $w->MainWindow->privateData('Tix'); + unless ($w->InsideArmedIndicator($x, $y)) + { + $w->IndicatorCmd('<Disarm>', $data->{'indicator'}); + } + else + { + $w->GoState(20, $x, $y); + } + } + +sub GoState_22 + { + my ($w) = @_; + my $data = $w->MainWindow->privateData('Tix'); + if (@{ $data->{oldEntry} }) + { + $w->anchor('set', @{ $data->{oldEntry} }); + } + else + { + $w->anchor('clear'); + } + $w->GoState(0); + } + + +#---------------------------------------------------------------------- +# callback actions +#---------------------------------------------------------------------- + +sub SetAnchor + { + my ($w, @ent) = @_; + + if (@ent) + { + $w->anchor('set', @ent); +# $w->see(@ent); + } + } + +# xxx check @ent of @$ent +sub Select + { + my ($w, @ent) = @_; + $w->selection('clear'); + $w->selection('set', @ent) + } + +# xxx check new After handling +sub StartScan + { + my ($w) = @_; + $Tk::afterId = $w->after(50, [AutoScan, $w]); + } + +sub DoScan + { + my ($w) = @_; + my $x = $Tk::x; + my $y = $Tk::y; + my $X = $Tk::X; + my $Y = $Tk::Y; + + my $out = 0; + if ($y >= $w->height) + { + $w->yview('scroll', 1, 'units'); + $out = 1; + } + if ($y < 0) + { + $w->yview('scroll', -1, 'units'); + $out = 1; + } + if ($x >= $w->width) + { + $w->xview('scroll', 2, 'units'); + $out = 1; + } + if ($x < 0) + { + $w->xview('scroll', -2, 'units'); + $out = 1; + } + if ($out) + { + $Tk::afterId = $w->after(50, ['AutoScan', $w]); + } + } + + +#proc tixGrid:CallBrowseCmd {w ent} { +# return +# +# set browsecmd [$w cget -browsecmd] +# if {$browsecmd != ""} { +# set bind(specs) {%V} +# set bind(%V) $ent +# +# tixEvalCmdBinding $w $browsecmd bind $ent +# } +#} + +#proc tixGrid:CallCommand {w ent} { +# set command [$w cget -command] +# if {$command != ""} { +# set bind(specs) {%V} +# set bind(%V) $ent +# +# tixEvalCmdBinding $w $command bind $ent +# } +#} + +# tixGrid:EditCell -- +# +# This command is called when "$w edit set $x $y" is called. It causes +# an SetEdit call when the grid's state is 0. +# + +sub EditCell + { + my ($w, $x, $y) = @_; + my $list = $w->privateData()->{'list'}; + if ($w->GetState == 0) + { + $w->SetEdit($x, $y); # xxx really correct ? once 2, once 4 args? + } + else + { + push(@$list, [ $w, 'SetEdit', $x, $y]); + } + } +#proc tixGrid:EditCell {w x y} { +# set list $w:_list +# global $list +# +# case [tixGrid:GetState $w] { +# {0} { +# tixGrid:SetEdit $w [list $x $y] +# } +# default { +# lappend $list [list tixGrid:SetEdit $w [list $x $y]] +# } +# } +#} + + +# tixGrid:EditApply -- +# +# This command is called when "$w edit apply $x $y" is called. It causes +# an CheckEdit call when the grid's state is 0. +# + +sub EditApply + { + my ($w) = @_; + my $list = $w->privateData()->{'list'}; + if ($w->GetState eq 0) + { + $w->CheckEdit; # xxx really correct ? once 2, once 4 args? + } + else + { + push(@$list, $w->CheckEdit); + } + } +#proc tixGrid:EditApply {w} { +# set list $w:_list +# global $list +# +# case [tixGrid:GetState $w] { +# {0} { +# tixGrid:CheckEdit $w +# } +# default { +# lappend $list [list tixGrid:CheckEdit $w] +# } +# } +#} + +# tixGrid:CheckEdit -- +# +# This procedure is called when the user sets the focus on a cell. +# If another cell is being edited, apply the changes of that cell. +# + +sub CheckEdit + { + my ($w) = @_; + my $edit = $w->privateData->{editentry}; + if (Tk::Exists($edit)) + { + # If it -command is not empty, it is being used for another cell. + # Invoke it so that the other cell can be updated. + # + if (defined $edit->cget('-command')) + { + $edit->invoke; # xxx no args?? + } + } + } + +sub SetFocus + { + my ($w) = @_; + if ($w->cget('-takefocus')) + { +$w->focus; +# # xxx translation of if ![string match $w.* [focus -displayof $w]] { +# my $hasfocus = $w->focus(-displayof => $w)->pathname; +# my $pathname = $w->pathname; +# if ($hasfocus =~ /\Q$pathname\E.*/) +# { +# $w->focus +# } + } + } + + +# tixGrid:SetEdit -- +# +# Puts a floatentry on top of an editable entry. +# + +sub SetEdit + { + my ($w, $px, $py) = @_; + + $w->CheckEdit; + + my $efc = $w->cget('-editnotifycmd'); + return unless ( defined($efc) && length($efc) ); + + unless ($w->Callback('-editnotifycmd' => $px, $py)) + { + print STDERR "editnotifycmd not defined or returned false\n"; + return; + } + + my $oldvalue; + if ($w->info('exists', $px, $py)) + { + # if entry doesn't support -text option. Can't edit it. + # + # If the application wants to force editing of an entry, it could + # delete or replace the entry in the editnotifyCmd procedure. + # + Tk::catch { $oldvalue = $w->entrycget($px, $py, '-text'); }; + if ($@) + { + return; + } + } + else + { + $oldvalue = ''; + } + + my @bbox = $w->info('bbox', $px, $py); + + my $edit = $w->privateData()->{__EDIT__}; + unless (Tk::Exists($edit)) + { + require Tk::FloatEntry; + $edit = $w->FloatEntry(); + $w->privateData()->{__EDIT__} = $edit; + } + $edit->configure(-command=>[\&DoneEdit, $w, $px, $py]); + $edit->post(@bbox); + $edit->configure(-value=>$oldvalue); +} + + +sub DoneEdit + { + my ($w, $x, $y, @args) = @_; + + my $edit = $w->privateData()->{__EDIT__}; + $edit->configure(-command=>undef); + $edit->unpost; + + # FIX xxx + # set value [tixEvent value] + my $value = $edit->get; + if ($w->info('exists', $x, $y)) + { + Tk::catch { $w->entryconfigure($x, $y, -text=>$value) }; + if ($@) + { + return + } + } + elsif ( length($value) ) + { + # This needs to be catch'ed because the default itemtype may + # not support the -text option + # + Tk::catch { $w->set($x,$y,-text $value); }; + if ($@) + { + return; + } + } + else + { + return; + } + $w->Callback('-editdonecmd' => $x, $y); + } + +1; +__END__ diff --git a/Master/tlpkg/tlperl/lib/Tk/Tk.xbm b/Master/tlpkg/tlperl/lib/Tk/Tk.xbm new file mode 100644 index 00000000000..136d4793037 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Tk.xbm @@ -0,0 +1,44 @@ +#define Tk.xbm_width 61 +#define Tk.xbm_height 61 +static unsigned char Tk.xbm_bits[] = { + 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, + 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, + 0x00, 0x00, 0x00, 0x00, 0x80, 0x07, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, + 0xe0, 0x0f, 0x00, 0x00, 0x00, 0x80, 0x07, 0x00, 0xf8, 0x0e, 0x00, 0x00, + 0x00, 0xe0, 0x1e, 0x00, 0xbe, 0x3e, 0x00, 0x00, 0x00, 0xfb, 0x1e, 0x00, + 0xfe, 0x7f, 0x00, 0x00, 0x80, 0xdf, 0x0f, 0x00, 0xff, 0xbf, 0x00, 0x00, + 0x80, 0xe0, 0x3d, 0x00, 0xff, 0xff, 0x01, 0x00, 0x00, 0x47, 0x7f, 0x80, + 0xff, 0xfd, 0x01, 0x00, 0x00, 0x7f, 0x3e, 0xc0, 0xff, 0xf1, 0x01, 0x00, + 0x00, 0x30, 0x7f, 0xf0, 0xfe, 0xb3, 0x03, 0x00, 0x00, 0xf8, 0x3e, 0x7c, + 0xff, 0xcf, 0x07, 0x00, 0x00, 0x78, 0x37, 0xfc, 0x7b, 0xc3, 0x07, 0x00, + 0x00, 0xfc, 0x3d, 0xfe, 0x3c, 0x25, 0x0e, 0x00, 0x00, 0xfc, 0x3e, 0x5f, + 0x18, 0x41, 0x0b, 0x00, 0x00, 0x5c, 0x3f, 0x5f, 0xf0, 0x59, 0x1b, 0x00, + 0x00, 0xdc, 0x9f, 0x3f, 0xe8, 0xbe, 0x17, 0x00, 0x00, 0xbc, 0x9f, 0x2f, + 0xa8, 0x5b, 0x15, 0x00, 0x00, 0xdc, 0xdf, 0x25, 0x48, 0x7a, 0x34, 0x00, + 0x00, 0x7c, 0xce, 0x1f, 0x20, 0x2c, 0x36, 0x00, 0x00, 0x7c, 0xa7, 0x1f, + 0xcc, 0x09, 0xf0, 0x00, 0x00, 0xfc, 0xae, 0x1f, 0x49, 0x05, 0xf6, 0x00, + 0x00, 0xfc, 0xac, 0x3f, 0xf8, 0x11, 0xf6, 0x00, 0x00, 0xf8, 0x8d, 0x3f, + 0x8e, 0x0e, 0xd6, 0x01, 0x00, 0xf8, 0x9c, 0x7e, 0xd7, 0x5b, 0xff, 0x03, + 0x00, 0x70, 0x83, 0x5f, 0xcf, 0xfd, 0xbf, 0x01, 0x00, 0xe0, 0xc3, 0x3b, + 0xc7, 0xff, 0x3f, 0x03, 0x00, 0xe0, 0xcf, 0xbf, 0xe3, 0xff, 0x97, 0x03, + 0x00, 0x80, 0xfb, 0x7f, 0xfb, 0xff, 0x17, 0x01, 0x00, 0x80, 0xef, 0xff, + 0xb3, 0x6f, 0x17, 0x03, 0x00, 0x00, 0xff, 0xff, 0xdf, 0x3f, 0x17, 0x03, + 0x00, 0x00, 0x88, 0xff, 0xbf, 0x3f, 0x1b, 0x03, 0x00, 0x00, 0x00, 0x7b, + 0x3d, 0x1f, 0x9f, 0x01, 0x00, 0x00, 0x80, 0x1f, 0x7f, 0x1f, 0x9e, 0x00, + 0x00, 0x00, 0x80, 0x1f, 0x3f, 0x0f, 0x1e, 0x00, 0x00, 0x00, 0x80, 0x1f, + 0x1f, 0x0f, 0x1e, 0x00, 0x00, 0x00, 0x80, 0x1f, 0x1f, 0x0e, 0x1e, 0x00, + 0x00, 0xfe, 0x81, 0x8f, 0x1f, 0x0f, 0x1c, 0x00, 0x00, 0x98, 0x81, 0xc7, + 0x1f, 0x0e, 0x18, 0x00, 0x00, 0x98, 0x01, 0xc7, 0x0f, 0x0a, 0x18, 0x00, + 0xfc, 0x98, 0x99, 0xc7, 0x07, 0x0e, 0x18, 0x00, 0x8c, 0x99, 0x8d, 0xc7, + 0x02, 0x0e, 0x18, 0x00, 0x8c, 0x99, 0x07, 0xc3, 0x03, 0x03, 0x18, 0x00, + 0x8c, 0x99, 0x07, 0xc7, 0x01, 0x03, 0x28, 0x00, 0x8c, 0x99, 0x0d, 0x03, + 0x03, 0x01, 0x08, 0x00, 0xfc, 0x98, 0x19, 0x03, 0x86, 0x01, 0x18, 0x00, + 0x0c, 0x00, 0x00, 0x03, 0xc4, 0x01, 0x10, 0x00, 0x0c, 0x00, 0x00, 0x03, + 0x88, 0x00, 0x18, 0x00, 0x00, 0x00, 0x00, 0x03, 0x90, 0x00, 0x18, 0x00, + 0x00, 0x00, 0x00, 0x01, 0x30, 0x00, 0x08, 0x00, 0x00, 0x00, 0x80, 0x01, + 0xf0, 0x01, 0x08, 0x00, 0x00, 0x00, 0x80, 0x01, 0xf8, 0x01, 0x18, 0x00, + 0x00, 0x00, 0xc0, 0x01, 0x9e, 0x03, 0x04, 0x00, 0x00, 0x00, 0xc0, 0x01, + 0xb3, 0x01, 0x04, 0x00, 0x00, 0x00, 0x60, 0x00, 0x00, 0x01, 0x18, 0x00, + 0x00, 0x00, 0x60, 0x00, 0x00, 0x00, 0x1e, 0x00, 0x00, 0x00, 0xdc, 0x00, + 0x00, 0x00, 0x0e, 0x00, 0x00, 0x00, 0x88, 0x00, 0x00, 0x00, 0x00, 0x00, + 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00}; diff --git a/Master/tlpkg/tlperl/lib/Tk/Tk.xpm b/Master/tlpkg/tlperl/lib/Tk/Tk.xpm new file mode 100644 index 00000000000..7880a637f39 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Tk.xpm @@ -0,0 +1,41 @@ +/* XPM */ +static char *Tk[] = { +/* width height num_colors chars_per_pixel */ +" 32 32 2 1", +/* colors */ +"# c #008080", +"a c #ff0000", +/* pixels */ +"################################", +"################################", +"################################", +"################################", +"################################", +"################################", +"##########aaaaaaaa##############", +"#######aaaaaaaaaaaa#######aa####", +"#####aaaaaaaaaaaaaa######aaa####", +"####aaaaaaaaaaaaaaaa####aaaa####", +"####aaaaaaa######aa####aaaa#####", +"###aaaa#########aaa###aaaa######", +"###aaaa#########aa###aaaa#######", +"######aa#######aa####aaa########", +"##############aaa###aaaa########", +"#############aaa###aaaa##aaa####", +"#############aa####aaa#aaaaa####", +"############aaa###aaa#aaaaaa####", +"###########aaa####aa#aa#aaa#####", +"###########aaa###aa#aa#aaa######", +"##########aaa####aaaaaaaa#aa####", +"##########aaa####aaaaaaa##aa####", +"#########aaaa####aaaaaaaaaa#####", +"#########aaa#####aa##aaaaa######", +"#########aaa##########aa########", +"################################", +"################################", +"################################", +"################################", +"################################", +"################################", +"################################" +}; diff --git a/Master/tlpkg/tlperl/lib/Tk/TkXSUB.def b/Master/tlpkg/tlperl/lib/Tk/TkXSUB.def new file mode 100644 index 00000000000..8f60974226e --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/TkXSUB.def @@ -0,0 +1,62 @@ +MkXSUB("Tk::bind", XS_Tk_bind, XStoBind, Tk_BindObjCmd) +MkXSUB("Tk::pack", XS_Tk_pack, XStoAfterSub, Tk_PackObjCmd) +MkXSUB("Tk::grid", XS_Tk_grid, XStoGrid, Tk_GridObjCmd) +MkXSUB("Tk::place", XS_Tk_place, XStoAfterSub, Tk_PlaceObjCmd) +MkXSUB("Tk::form", XS_Tk_form, XStoAfterSub, Tix_FormCmd) +MkXSUB("Tk::itemstyle", XS_Tk_itemstyle, XStoTclCmd, Tix_ItemStyleCmd) +MkXSUB("Tk::winfo", XS_Tk_winfo, XStoSubCmd, Tk_WinfoObjCmd) +MkXSUB("Tk::font", XS_Tk_font, XStoFont, Tk_FontObjCmd) +MkXSUB("Tk::wm", XS_Tk_wm, XStoAfterSub, Tk_WmObjCmd) +MkXSUB("Tk::grab", XS_Tk_grab, XStoSubCmd, Tk_GrabObjCmd) +MkXSUB("Tk::focus", XS_Tk_focus, XStoSubCmd, Tk_FocusObjCmd) +MkXSUB("Tk::event", XS_Tk_event, XStoEvent, Tk_EventObjCmd) +MkXSUB("Tk::property", XS_Tk_property, XStoSubCmd, Tk_PropertyCmd) +MkXSUB("Tk::clipboard", XS_Tk_clipboard, XStoDisplayof, Tk_ClipboardObjCmd) +MkXSUB("Tk::bell", XS_Tk_bell, XStoDisplayof, Tk_BellObjCmd) +MkXSUB("Tk::bindtags", XS_Tk_bindtags, XStoTk, Tk_BindtagsObjCmd) +MkXSUB("Tk::destroy", XS_Tk_destroy, XStoTk, Tk_DestroyObjCmd) +MkXSUB("Tk::raise", XS_Tk_raise, XStoTk, Tk_RaiseObjCmd) +MkXSUB("Tk::lower", XS_Tk_lower, XStoTk, Tk_LowerObjCmd) +MkXSUB("Tk::option", XS_Tk_option, XStoOption, Tk_OptionObjCmd) +MkXSUB("Tk::image", XS_Tk_image, XStoImage, Tk_ImageObjCmd) +MkXSUB("Tk::selection", XS_Tk_selection, XStoTk, Tk_SelectionObjCmd) + +#if defined(__WIN32__) || defined(MAC_TCL) +MkXSUB("Tk::tk_chooseColor", XS_Tk_tk_chooseColor, XStoTk, Tk_ChooseColorObjCmd) +MkXSUB("Tk::tk_chooseDirectory", XS_Tk_tk_chooseDirectory, XStoTk, Tk_ChooseDirectoryObjCmd) +MkXSUB("Tk::tk_getOpenFile", XS_Tk_tk_getOpenFile, XStoTk, Tk_GetOpenFileObjCmd) +MkXSUB("Tk::tk_getSaveFile", XS_Tk_tk_getSaveFile, XStoTk, Tk_GetSaveFileObjCmd) +#endif +#if defined(__WIN32__) +MkXSUB("Tk::tk_messageBox", XS_Tk_tk_messageBox, XStoTk, Tk_MessageBoxObjCmd) +#endif + +MkXSUB("Tk::tk", XS_Tk_tk, XStoTclCmd, Tk_TkObjCmd) + +#if 0 +MkXSUB("Tk::exit", XS_Tk_exit, XStoNoWindow, Tcl_ExitCmd) +MkXSUB("Tk::fileevent", XS_Tk_fileevent, XStoNoWindow, Tcl_FileeventCmd) +#endif +MkXSUB("Tk::after", XS_Tk_after, XStoNoWindow, Tcl_AfterObjCmd) +#ifndef WIN32 +MkXSUB("Tk::send", XS_Tk_send, XStoTclCmd, Tk_SendCmd) +#endif + +MkXSUB("Tk::button", XS_Tk_button, XStoTclCmdNull, Tk_ButtonObjCmd) +MkXSUB("Tk::checkbutton", XS_Tk_checkbutton, XStoTclCmdNull, Tk_CheckbuttonObjCmd) +MkXSUB("Tk::label", XS_Tk_label, XStoTclCmdNull, Tk_LabelObjCmd) +MkXSUB("Tk::radiobutton", XS_Tk_radiobutton, XStoTclCmdNull, Tk_RadiobuttonObjCmd) +MkXSUB("Tk::_menu", XS_Tk__menu, XStoTclCmdNull, 0) + +MkXSUB("Tk::message", XS_Tk_message, XStoTclCmd, Tk_MessageObjCmd) +MkXSUB("Tk::frame", XS_Tk_frame, XStoTclCmd, Tk_FrameObjCmd) +MkXSUB("Tk::labelframe", XS_Tk_labelframe, XStoTclCmd, Tk_LabelframeObjCmd) +MkXSUB("Tk::panedwindow", XS_Tk_panedwindow, XStoTclCmd, Tk_PanedWindowObjCmd) +MkXSUB("Tk::toplevel", XS_Tk_toplevel, XStoTclCmd, Tk_ToplevelObjCmd) +MkXSUB("Tk::update", XS_Tk_update, XStoTclCmd, Tk_UpdateObjCmd) +MkXSUB("Tk::tkwait", XS_Tk_tkwait, XStoTclCmd, Tk_TkwaitObjCmd) +MkXSUB("Tk::configure", XS_Tk_configure, XStoWidget, newSVpv("configure",0)) +MkXSUB("Tk::cget", XS_Tk_cget, XStoWidget, newSVpv("cget",0)) + + + diff --git a/Master/tlpkg/tlperl/lib/Tk/Toplevel.pm b/Master/tlpkg/tlperl/lib/Tk/Toplevel.pm new file mode 100644 index 00000000000..7bcd156d475 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Toplevel.pm @@ -0,0 +1,211 @@ +# Copyright (c) 1995-2003 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. +package Tk::Toplevel; +use AutoLoader; + +use vars qw($VERSION); +$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Toplevel.pm#6 $ + +use base qw(Tk::Wm Tk::Frame); + +Construct Tk::Widget 'Toplevel'; + +sub Tk_cmd { \&Tk::toplevel } + +sub CreateOptions +{ + return (shift->SUPER::CreateOptions,'-screen','-use') +} + +sub Populate +{ + my ($cw,$arg) = @_; + $cw->SUPER::Populate($arg); + $cw->ConfigSpecs('-title',['METHOD',undef,undef,$cw->class]); +} + +sub Icon +{ + my ($top,%args) = @_; + my $icon = $top->iconwindow; + my $state = $top->state; + if ($state ne 'withdrawn') + { + $top->withdraw; + $top->update; # Let attributes propogate + } + unless (defined $icon) + { + $icon = Tk::Toplevel->new($top,'-borderwidth' => 0,'-class'=>'Icon'); + $icon->withdraw; + # Fake Populate + my $lab = $icon->Component('Label' => 'icon'); + $lab->pack('-expand'=>1,'-fill' => 'both'); + $icon->ConfigSpecs(DEFAULT => ['DESCENDANTS']); + # Now do tail of InitObject + $icon->ConfigDefault(\%args); + # And configure that new would have done + $top->iconwindow($icon); + $top->update; + $lab->DisableButtonEvents; + $lab->update; + } + $top->iconimage($args{'-image'}) if (exists $args{'-image'}); + $icon->configure(%args); + $icon->idletasks; # Let size request propogate + $icon->geometry($icon->ReqWidth . 'x' . $icon->ReqHeight); + $icon->update; # Let attributes propogate + $top->deiconify if ($state eq 'normal'); + $top->iconify if ($state eq 'iconic'); +} + +sub menu +{ + my $w = shift; + my $menu; + $menu = $w->cget('-menu'); + unless (defined $menu) + { + $w->configure(-menu => ($menu = $w->SUPER::menu)) + } + $menu->configure(@_) if @_; + return $menu; +} + + +1; +__END__ + +#---------------------------------------------------------------------- +# +# Focus Group +# +# Focus groups are used to handle the user's focusing actions inside a +# toplevel. +# +# One example of using focus groups is: when the user focuses on an +# entry, the text in the entry is highlighted and the cursor is put to +# the end of the text. When the user changes focus to another widget, +# the text in the previously focused entry is validated. +# + +#---------------------------------------------------------------------- +# tkFocusGroup_Create -- +# +# Create a focus group. All the widgets in a focus group must be +# within the same focus toplevel. Each toplevel can have only +# one focus group, which is identified by the name of the +# toplevel widget. +# +sub FG_Create { + my $t = shift; + unless (exists $t->{'_fg'}) { + $t->{'_fg'} = 1; + $t->bind('<FocusIn>', sub { + my $w = shift; + my $Ev = $w->XEvent; + $t->FG_In($w, $Ev->d); + } + ); + $t->bind('<FocusOut>', sub { + my $w = shift; + my $Ev = $w->XEvent; + $t->FG_Out($w, $Ev->d); + } + ); + $t->bind('<Destroy>', sub { + my $w = shift; + my $Ev = $w->XEvent; + $t->FG_Destroy($w); + } + ); + # <Destroy> is not sufficient to break loops if never mapped. + $t->OnDestroy([$t,'FG_Destroy']); + } +} + +# tkFocusGroup_BindIn -- +# +# Add a widget into the "FocusIn" list of the focus group. The $cmd will be +# called when the widget is focused on by the user. +# +sub FG_BindIn { + my($t, $w, $cmd) = @_; + $t->Error("focus group \"$t\" doesn't exist") unless (exists $t->{'_fg'}); + $t->{'_FocusIn'}{$w} = Tk::Callback->new($cmd); +} + +# tkFocusGroup_BindOut -- +# +# Add a widget into the "FocusOut" list of the focus group. The +# $cmd will be called when the widget loses the focus (User +# types Tab or click on another widget). +# +sub FG_BindOut { + my($t, $w, $cmd) = @_; + $t->Error("focus group \"$t\" doesn't exist") unless (exists $t->{'_fg'}); + $t->{'_FocusOut'}{$w} = Tk::Callback->new($cmd); +} + +# tkFocusGroup_Destroy -- +# +# Cleans up when members of the focus group is deleted, or when the +# toplevel itself gets deleted. +# +sub FG_Destroy { + my($t, $w) = @_; + if (!defined($w) || $t == $w) { + delete $t->{'_fg'}; + delete $t->{'_focus'}; + delete $t->{'_FocusOut'}; + delete $t->{'_FocusIn'}; + } else { + if (exists $t->{'_focus'}) { + delete $t->{'_focus'} if ($t->{'_focus'} == $w); + } + delete $t->{'_FocusIn'}{$w}; + delete $t->{'_FocusOut'}{$w}; + } +} + +# tkFocusGroup_In -- +# +# Handles the <FocusIn> event. Calls the FocusIn command for the newly +# focused widget in the focus group. +# +sub FG_In { + my($t, $w, $detail) = @_; + if (defined $t->{'_focus'} and $t->{'_focus'} eq $w) { + # This is already in focus + return; + } else { + $t->{'_focus'} = $w; + $t->{'_FocusIn'}{$w}->Call if exists $t->{'_FocusIn'}{$w}; + } +} + +# tkFocusGroup_Out -- +# +# Handles the <FocusOut> event. Checks if this is really a lose +# focus event, not one generated by the mouse moving out of the +# toplevel window. Calls the FocusOut command for the widget +# who loses its focus. +# +sub FG_Out { + my($t, $w, $detail) = @_; + if ($detail ne 'NotifyNonlinear' and $detail ne 'NotifyNonlinearVirtual') { + # This is caused by mouse moving out of the window + return; + } + unless (exists $t->{'_FocusOut'}{$w}) { + return; + } else { + $t->{'_FocusOut'}{$w}->Call; + delete $t->{'_focus'}; + } +} + +1; + +__END__ diff --git a/Master/tlpkg/tlperl/lib/Tk/Trace.pm b/Master/tlpkg/tlperl/lib/Tk/Trace.pm new file mode 100644 index 00000000000..1e38e79a065 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Trace.pm @@ -0,0 +1,405 @@ +package Tk::Trace; + +use vars qw($VERSION); +$VERSION = sprintf '4.%03d', q$Revision: #7 $ =~ /\D(\d+)\s*$/; + +use Carp; +use Tie::Watch; +use strict; + +# The %TRACE hash is indexed by stringified variable reference. Each hash +# bucket contains an array reference having two elements: +# +# ->[0] = a reference to the variable's Tie::Watch object +# ->[1] = a hash reference with these keys: -fetch, -store, -destroy +# ->{key} = [ active flag, [ callback list ] ] +# where each callback is a normalized callback array reference +# +# Thus, each trace type (r w u ) may have multiple traces. + +my %TRACE; # watchpoints indexed by stringified ref + +my %OP = ( # trace to Tie::Watch operation map + r => '-fetch', + w => '-store', + u => '-destroy', +); + +sub fetch { + + # fetch() wraps the user's callback with necessary tie() bookkeeping + # and invokes the callback with the proper arguments. It expects: + # + # $_[0] = Tie::Watch object + # $_[1] = undef for a scalar, an index/key for an array/hash + # + # The user's callback is passed these arguments: + # + # $_[0] = undef for a scalar, index/key for array/hash + # $_[1] = current value + # $_[2] = operation 'r' + # $_[3 .. $#_] = optional user callback arguments + # + # The user callback returns the final value to assign the variable. + + my $self = shift; # Tie::Watch object + my $val = $self->Fetch(@_); # get variable's current value + my $aref = $self->Args('-fetch'); # argument reference + my $call = $TRACE{$aref->[0]}->[1]->{-fetch}; # active flag/callbacks + return $val unless $call->[0]; # if fetch inactive + + my $final_val; + foreach my $aref (reverse @$call[ 1 .. $#{@$call} ] ) { + my ( @args_copy ) = @$aref; + my $sub = shift @args_copy; # user's callback + unshift @_, undef if scalar @_ == 0; # undef "index" for a scalar + my @args = @_; # save for post-callback work + $args[1] = &$sub(@_, $val, 'r', @args_copy); # invoke user callback + shift @args unless defined $args[0]; # drop scalar "index" + $final_val = $self->Store(@args); # update variable's value + } + $final_val; + +} # end fetch + +sub store { + + # store() wraps the user's callback with necessary tie() bookkeeping + # and invokes the callback with the proper arguments. It expects: + # + # $_[0] = Tie::Watch object + # $_[1] = new value for a scalar, index/key for an array/hash + # $_[2] = undef for a scalar, new value for an array/hash + # + # The user's callback is passed these arguments: + # + # $_[0] = undef for a scalar, index/key for array/hash + # $_[1] = new value + # $_[2] = operation 'w' + # $_[3 .. $#_] = optional user callback arguments + # + # The user callback returns the final value to assign the variable. + + my $self = shift; # Tie::Watch object + my $val = $self->Store(@_); # store variable's new value + my $aref = $self->Args('-store'); # argument reference + my $call = $TRACE{$aref->[0]}->[1]->{-store}; # active flag/callbacks + return $val unless $call->[0]; # if store inactive + + foreach my $aref ( reverse @$call[ 1 .. $#{@$call} ] ) { + my ( @args_copy ) = @$aref; + my $sub = shift @args_copy; # user's callback + unshift @_, undef if scalar @_ == 1; # undef "index" for a scalar + my @args = @_; # save for post-callback work + $args[1] = &$sub(@_, 'w', @args_copy); # invoke user callback + shift @args unless defined $args[0]; # drop scalar "index" + $self->Store(@args); # update variable's value + } + +} # end store + +sub destroy { + + # destroy() wraps the user's callback with necessary tie() bookkeeping + # and invokes the callback with the proper arguments. It expects: + # + # $_[0] = Tie::Watch object + # + # The user's callback is passed these arguments: + # + # $_[0] = undef for a scalar, index/key for array/hash + # $_[1] = final value + # $_[2] = operation 'u' + # $_[3 .. $#_] = optional user callback arguments + + my $self = shift; # Tie::Watch object + my $val = $self->Fetch(@_); # variable's final value + my $aref = $self->Args('-destroy'); # argument reference + my $call = $TRACE{$aref->[0]}->[1]->{-destroy}; # active flag/callbacks + return $val unless $call->[0]; # if destroy inactive + + foreach my $aref ( reverse @$call[ 1 .. $#{@$call} ] ) { + my ( @args_copy ) = @$aref; + my $sub = shift @args_copy; # user's callback + my $val = $self->Fetch(@_); # get final value + &$sub(undef, $val, 'u', @args_copy); # invoke user callback + $self->Destroy(@_); # destroy variable + } + +} # end destroy + +sub Tk::Widget::traceVariable { + + my( $parent, $vref, $op, $callback ) = @_; + + { + $^W = 0; + croak "Illegal parent '$parent', not a widget" unless ref $parent; + croak "Illegal variable '$vref', not a reference" unless ref $vref; + croak "Illegal trace operation '$op'" unless $op; + croak "Illegal trace operation '$op'" if $op =~ /[^rwu]/; + croak "Illegal callback ($callback)" unless $callback; + } + + # Need to add our internal callback to user's callback arg list + # so we can call ours first, followed by the user's callback and + # any user arguments. Trace callbacks are activated as requied. + + my $trace = $TRACE{$vref}; + if ( not defined $trace ) { + my $watch = Tie::Watch->new( + -variable => $vref, + -fetch => [ \&fetch, $vref ], + -store => [ \&store, $vref ], + -destroy => [ \&destroy, $vref ], + ); + $trace = $TRACE{$vref} = + [$watch, + { + -fetch => [ 0 ], + -store => [ 0 ], + -destroy => [ 0 ], + } + ]; + } + + $callback = [ $callback ] if ref $callback eq 'CODE'; + + foreach my $o (split '', $op) { + push @{$trace->[1]->{$OP{$o}}}, $callback; + $trace->[1]->{$OP{$o}}->[0] = 1; # activate + } + + return $trace; # for peeking + +} # end traceVariable + +sub Tk::Widget::traceVdelete { + + my ( $parent, $vref, $op_not_honored, $callabck_not_honored ) = @_; + + if ( defined $TRACE{$vref}->[0] ) { + $$vref = $TRACE{$vref}->[0]->Fetch; + $TRACE{$vref}->[0]->Unwatch; + delete $TRACE{$vref}; + } + +} # end traceVdelete + +sub Tk::Widget::traceVinfo { + + my ( $parent, $vref ) = @_; + + return ( defined $TRACE{$vref}->[0] ) ? $TRACE{$vref}->[0]->Info : undef; + +} # end traceVinfo + +=head1 NAME + +Tk::Trace - emulate Tcl/Tk B<trace> functions. + +=head1 SYNOPSIS + + use Tk::Trace + + $mw->traceVariable(\$v, 'wru' => [\&update_meter, $scale]); + %vinfo = $mw->traceVinfo(\$v); + print "Trace info :\n ", join("\n ", @{$vinfo{-legible}}), "\n"; + $mw->traceVdelete(\$v); + +=head1 DESCRIPTION + +This class module emulates the Tcl/Tk B<trace> family of commands by +binding subroutines of your devising to Perl variables using simple +B<Tie::Watch> features. + +Callback format is patterned after the Perl/Tk scheme: supply either a +code reference, or, supply an array reference and pass the callback +code reference in the first element of the array, followed by callback +arguments. + +User callbacks are passed these arguments: + + $_[0] = undef for a scalar, index/key for array/hash + $_[1] = variable's current (read), new (write), final (undef) value + $_[2] = operation (r, w, or u) + $_[3 .. $#_] = optional user callback arguments + +As a Trace user, you have an important responsibility when writing your +callback, since you control the final value assigned to the variable. +A typical callback might look like: + + sub callback { + my($index, $value, $op, @args) = @_; + return if $op eq 'u'; + # .... code which uses $value ... + return $value; # variable's final value + } + +Note that the callback's return value becomes the variable's final value, +for either read or write traces. + +For write operations, the variable is updated with its new value before +the callback is invoked. + +Multiple read, write and undef callbacks can be attached to a variable, +which are invoked in reverse order of creation. + +=head1 METHODS + +=over 4 + +=item $mw->traceVariable(varRef, op => callback); + +B<varRef> is a reference to the scalar, array or hash variable you +wish to trace. B<op> is the trace operation, and can be any combination +of B<r> for read, B<w> for write, and B<u> for undef. B<callback> is a +standard Perl/Tk callback, and is invoked, depending upon the value of +B<op>, whenever the variable is read, written, or destroyed. + +=item %vinfo = $mw->traceVinfo(varRef); + +Returns a hash detailing the internals of the Trace object, with these +keys: + + %vinfo = ( + -variable => varRef + -debug => '0' + -shadow => '1' + -value => 'HELLO SCALAR' + -destroy => callback + -fetch => callback + -store => callback + -legible => above data formatted as a list of string, for printing + ); + +For array and hash Trace objects, the B<-value> key is replaced with a +B<-ptr> key which is a reference to the parallel array or hash. +Additionally, for an array or hash, there are key/value pairs for +all the variable specific callbacks. + +=item $mw->traceVdelete(\$v); + +Stop tracing the variable. + +=back + +=head1 EXAMPLES + + # Trace a Scale's variable and move a meter in unison. + + use Tk; + use Tk::widgets qw/Trace/; + + $pi = 3.1415926; + $mw = MainWindow->new; + $c = $mw->Canvas( qw/-width 200 -height 110 -bd 2 -relief sunken/ )->grid; + $c->createLine( qw/100 100 10 100 -tag meter -arrow last -width 5/ ); + $s = $mw->Scale( qw/-orient h -from 0 -to 100 -variable/ => \$v )->grid; + $mw->Label( -text => 'Slide Me for 5 Seconds' )->grid; + + $mw->traceVariable( \$v, 'w' => [ \&update_meter, $s ] ); + + $mw->after( 5000 => sub { + print "Untrace time ...\n"; + %vinfo = $s->traceVinfo( \$v ); + print "Watch info :\n ", join("\n ", @{$vinfo{-legible}}), "\n"; + $c->traceVdelete( \$v ); + }); + + MainLoop; + + sub update_meter { + my( $index, $value, $op, @args ) = @_; + return if $op eq 'u'; + $min = $s->cget( -from ); + $max = $s->cget( -to ); + $pos = $value / abs( $max - $min ); + $x = 100.0 - 90.0 * ( cos( $pos * $pi ) ); + $y = 100.0 - 90.0 * ( sin( $pos * $pi ) ); + $c->coords( qw/meter 100 100/, $x, $y ); + return $value; + } + + # Predictive text entry. + + use Tk; + use Tk::widgets qw/ LabEntry Trace /; + use strict; + + my @words = qw/radio television telephone turntable microphone/; + + my $mw = MainWindow->new; + + my $e = $mw->LabEntry( + qw/ -label Thing -width 40 /, + -labelPack => [ qw/ -side left / ], + -textvariable => \my $thing, + ); + my $t = $mw->Text( qw/ -height 10 -width 50 / );; + + $t->pack( $e, qw/ -side top / ); + + $e->focus; + $e->traceVariable( \$thing, 'w', [ \&trace_thing, $e, $t ] ); + + foreach my $k ( 1 .. 12 ) { + $e->bind( "<F${k}>" => [ \&ins, $t, Ev('K') ] ); + } + $e->bind( '<Return>' => + sub { + print "$thing\n"; + $_[0]->delete( 0, 'end' ); + } + ); + + MainLoop; + + sub trace_thing { + + my( $index, $value, $op, $e, $t ) = @_; + + return unless $value; + + $t->delete( qw/ 1.0 end / ); + foreach my $w ( @words ) { + if ( $w =~ /^$value/ ) { + $t->insert( 'end', "$w\n" ); + } + } + + return $value; + + } # end trace_thing + + sub ins { + + my( $e, $t, $K ) = @_; + + my( $index ) = $K =~ /^F(\d+)$/; + + $e->delete( 0, 'end' ); + $e->insert( 'end', $t->get( "$index.0", "$index.0 lineend" ) ); + $t->delete( qw/ 1.0 end / ); + + } # end ins + +=head1 HISTORY + + Stephen.O.Lidie@Lehigh.EDU, Lehigh University Computing Center, 2000/08/01 + . Version 1.0, for Tk800.022. + + sol0@Lehigh.EDU, Lehigh University Computing Center, 2003/09/22 + . Version 1.1, for Tk804.025, add support for multiple traces of the same + type on the same variable. + +=head1 COPYRIGHT + +Copyright (C) 2000 - 2003 Stephen O. Lidie. All rights reserved. + +This program is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. + +=cut + +1; diff --git a/Master/tlpkg/tlperl/lib/Tk/Tree.pm b/Master/tlpkg/tlperl/lib/Tk/Tree.pm new file mode 100644 index 00000000000..6d4f76b0c63 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Tree.pm @@ -0,0 +1,228 @@ +package Tk::Tree; +# Tree -- TixTree widget +# +# Derived from Tree.tcl in Tix 4.1 +# +# Chris Dean <ctdean@cogit.com> + +use vars qw($VERSION); +$VERSION = '4.005'; # $Id: //depot/Tkutf8/Tixish/Tree.pm#5 $ + +use Tk (); +use Tk::Derived; +use Tk::HList; +use base qw(Tk::Derived Tk::HList); +use strict; + +Construct Tk::Widget 'Tree'; + +sub Tk::Widget::ScrlTree { shift->Scrolled('Tree' => @_) } + +sub Populate +{ + my( $w, $args ) = @_; + + $w->SUPER::Populate( $args ); + + $w->ConfigSpecs( + -ignoreinvoke => ['PASSIVE', 'ignoreInvoke', 'IgnoreInvoke', 0], + -opencmd => ['CALLBACK', 'openCmd', 'OpenCmd', 'OpenCmd' ], + -indicatorcmd => ['CALLBACK', 'indicatorCmd', 'IndicatorCmd', 'IndicatorCmd'], + -closecmd => ['CALLBACK', 'closeCmd', 'CloseCmd', 'CloseCmd'], + -indicator => ['SELF', 'indicator', 'Indicator', 1], + -indent => ['SELF', 'indent', 'Indent', 20], + -width => ['SELF', 'width', 'Width', 20], + -itemtype => ['SELF', 'itemtype', 'Itemtype', 'imagetext'], + -foreground => ['SELF'], + ); +} + +sub autosetmode +{ + my( $w ) = @_; + $w->setmode(); +} + +sub IndicatorCmd +{ + my( $w, $ent, $event ) = @_; + + my $mode = $w->getmode( $ent ); + + if ( $event eq '<Arm>' ) + { + if ($mode eq 'open' ) + { + $w->_indicator_image( $ent, 'plusarm' ); + } + else + { + $w->_indicator_image( $ent, 'minusarm' ); + } + } + elsif ( $event eq '<Disarm>' ) + { + if ($mode eq 'open' ) + { + $w->_indicator_image( $ent, 'plus' ); + } + else + { + $w->_indicator_image( $ent, 'minus' ); + } + } + elsif( $event eq '<Activate>' ) + { + $w->Activate( $ent, $mode ); + $w->Callback( -browsecmd => $ent ); + } +} + +sub close +{ + my( $w, $ent ) = @_; + my $mode = $w->getmode( $ent ); + $w->Activate( $ent, $mode ) if( $mode eq 'close' ); +} + +sub open +{ + my( $w, $ent ) = @_; + my $mode = $w->getmode( $ent ); + $w->Activate( $ent, $mode ) if( $mode eq 'open' ); +} + +sub getmode +{ + my( $w, $ent ) = @_; + + return( 'none' ) unless $w->indicatorExists( $ent ); + + my $img = $w->_indicator_image( $ent ); + return( 'open' ) if( $img eq 'plus' || $img eq 'plusarm' ); + return( 'close' ); +} + +sub setmode +{ + my ($w,$ent,$mode) = @_; + unless (defined $mode) + { + $mode = 'none'; + my @args; + push(@args,$ent) if defined $ent; + my @children = $w->infoChildren( @args ); + if ( @children ) + { + $mode = 'close'; + foreach my $c (@children) + { + $mode = 'open' if $w->infoHidden( $c ); + $w->setmode( $c ); + } + } + } + + if (defined $ent) + { + if ( $mode eq 'open' ) + { + $w->_indicator_image( $ent, 'plus' ); + } + elsif ( $mode eq 'close' ) + { + $w->_indicator_image( $ent, 'minus' ); + } + elsif( $mode eq 'none' ) + { + $w->_indicator_image( $ent, undef ); + } + } +} + +sub Activate +{ + my( $w, $ent, $mode ) = @_; + if ( $mode eq 'open' ) + { + $w->Callback( -opencmd => $ent ); + $w->_indicator_image( $ent, 'minus' ); + } + elsif ( $mode eq 'close' ) + { + $w->Callback( -closecmd => $ent ); + $w->_indicator_image( $ent, 'plus' ); + } + else + { + + } +} + +sub OpenCmd +{ + my( $w, $ent ) = @_; + # The default action + foreach my $kid ($w->infoChildren( $ent )) + { + $w->show( -entry => $kid ); + } +} + +sub CloseCmd +{ + my( $w, $ent ) = @_; + + # The default action + foreach my $kid ($w->infoChildren( $ent )) + { + $w->hide( -entry => $kid ); + } +} + +sub Command +{ + my( $w, $ent ) = @_; + + return if $w->{Configure}{-ignoreInvoke}; + + $w->Activate( $ent, $w->getmode( $ent ) ) if $w->indicatorExists( $ent ); +} + +sub _indicator_image +{ + my( $w, $ent, $image ) = @_; + my $data = $w->privateData(); + if (@_ > 2) + { + if (defined $image) + { + $w->indicatorCreate( $ent, -itemtype => 'image' ) + unless $w->indicatorExists($ent); + $data->{$ent} = $image; + $w->indicatorConfigure( $ent, -image => $w->Getimage( $image ) ); + } + else + { + $w->indicatorDelete( $ent ) if $w->indicatorExists( $ent ); + delete $data->{$ent}; + } + } + return $data->{$ent}; +} + +1; + +__END__ + +# Copyright (c) 1996, Expert Interface Technologies +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# The file man.macros and some of the macros used by this file are +# copyrighted: (c) 1990 The Regents of the University of California. +# (c) 1994-1995 Sun Microsystems, Inc. +# The license terms of the Tcl/Tk distrobution are in the file +# license.tcl. + +=cut diff --git a/Master/tlpkg/tlperl/lib/Tk/Widget.pm b/Master/tlpkg/tlperl/lib/Tk/Widget.pm new file mode 100644 index 00000000000..e94c037e6fe --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Widget.pm @@ -0,0 +1,1510 @@ +# Copyright (c) 1995-2004 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. +package Tk::Widget; +use vars qw($VERSION @DefaultMenuLabels); +$VERSION = sprintf '4.%03d', q$Revision: #30 $ =~ /\D(\d+)\s*$/; + +require Tk; +use AutoLoader; +use strict; +use Carp; +use base qw(DynaLoader Tk); + +# stubs for 'autoloaded' widget classes +sub Button; +sub Canvas; +sub Checkbutton; +sub Entry; +sub Frame; +sub Label; +sub Labelframe; +sub Listbox; +sub Menu; +sub Menubutton; +sub Message; +sub Panedwindow; +sub Radiobutton; +sub Scale; +sub Scrollbar; +sub Spinbox; +sub Text; +sub Toplevel; + +sub Pixmap; +sub Bitmap; +sub Photo; + +sub ScrlListbox; +sub Optionmenu; + +sub import +{ + my $package = shift; + carp 'use Tk::Widget () to pre-load widgets is deprecated' if (@_); + my $need; + foreach $need (@_) + { + unless (defined &{$need}) + { + require "Tk/${need}.pm"; + } + croak "Cannot locate $need" unless (defined &{$need}); + } +} + +@DefaultMenuLabels = qw[~File ~Help]; + +# Some tidy-ness functions for winfo stuff + +sub True { 1 } +sub False { 0 } + +use Tk::Submethods( 'grab' => [qw(current status release -global)], + 'focus' => [qw(-force -lastfor)], + 'pack' => [qw(configure forget info propagate slaves)], + 'grid' => [qw(bbox columnconfigure configure forget info location propagate rowconfigure size slaves)], + 'form' => [qw(check configure forget grid info slaves)], + 'event' => [qw(add delete generate info)], + 'place' => [qw(configure forget info slaves)], + 'wm' => [qw(capture release)], + 'font' => [qw(actual configure create delete families measure metrics names subfonts)] + ); + +BEGIN { + # FIXME - these don't work in the compiler + *IsMenu = \&False; + *IsMenubutton = \&False; + *configure_self = \&Tk::configure; + *cget_self = \&Tk::cget; +} + + + +Direct Tk::Submethods ( + 'winfo' => [qw(cells class colormapfull depth exists + geometry height id ismapped manager name parent reqheight + reqwidth rootx rooty screen screencells screendepth screenheight + screenmmheight screenmmwidth screenvisual screenwidth visual + visualsavailable vrootheight viewable vrootwidth vrootx vrooty + width x y toplevel children pixels pointerx pointery pointerxy + server fpixels rgb )], + 'tk' => [qw(appname caret scaling useinputmethods windowingsystem)]); + + +sub DESTROY +{ + my $w = shift; + $w->destroy if ($w->IsWidget); +} + +sub Install +{ + # Dynamically loaded widgets add their core commands + # to the Tk base class here + my ($package,$mw) = @_; +} + +sub ClassInit +{ + # Carry out class bindings (or whatever) + my ($package,$mw) = @_; + return $package; +} + +sub CreateOptions +{ + return (); +} + +sub CreateArgs +{ + my ($package,$parent,$args) = @_; + # Remove from hash %$args any configure-like + # options which only apply at create time (e.g. -colormap for Frame), + # or which may as well be applied right away + # return these as a list of -key => value pairs + # Augment same hash with default values for missing mandatory options, + # allthough this can be done later in InitObject. + + # Honour -class => if present, we have hacked Tk_ConfigureWidget to + # allow -class to be passed to any widget. + my @result = (); + my $class = delete $args->{'-class'}; + ($class) = $package =~ /([A-Z][A-Z0-9_]*)$/i unless (defined $class); + @result = (-class => "\u$class") if (defined $class); + foreach my $opt ($package->CreateOptions) + { + push(@result, $opt => delete $args->{$opt}) if exists $args->{$opt}; + } + return @result; +} + +sub InitObject +{ + my ($obj,$args) = @_; + # per object initialization, for example populating + # with sub-widgets, adding a few object bindings to augment + # inherited class bindings, changing binding tags. + # Also another chance to mess with %$args before configure... +} + +sub SetBindtags +{ + my ($obj) = @_; + $obj->bindtags([ref($obj),$obj,$obj->toplevel,'all']); +} + +sub new +{ + local $SIG{'__DIE__'} = \&Carp::croak; + my $package = shift; + my $parent = shift; + $package->InitClass($parent); + $parent->BackTrace("Odd number of args to $package->new(...)") unless ((@_ % 2) == 0); + my %args = @_; + my @args = $package->CreateArgs($parent,\%args); + my $cmd = $package->Tk_cmd; + my $pname = $parent->PathName; + $pname = '' if ($pname eq '.'); + my $leaf = delete $args{'Name'}; + if (defined $leaf) + { + $leaf =~ s/[^a-z0-9_#]+/_/ig; + $leaf = lcfirst($leaf); + } + else + { + ($leaf) = "\L$package" =~ /([a-z][a-z0-9_]*)$/; + } + my $lname = $pname . '.' . $leaf; + # create a hash indexed by leaf name to speed up + # creation of a lot of sub-widgets of the same type + # e.g. entries in Table + my $nhash = $parent->TkHash('_names_'); + $nhash->{$leaf} = 0 unless (exists $nhash->{$leaf}); + while (defined ($parent->Widget($lname))) + { + $lname = $pname . '.' . $leaf . ++$nhash->{$leaf}; + } + my $obj = eval { &$cmd($parent, $lname, @args) }; + confess $@ if $@; + unless (ref $obj) + { + die "No value from $cmd $lname" unless defined $obj; + warn "$cmd '$lname' returned '$obj'" unless $obj eq $lname; + $obj = $parent->Widget($lname = $obj); + die "$obj from $lname" unless ref $obj; + } + bless $obj,$package; + $obj->SetBindtags; + my $notice = $parent->can('NoticeChild'); + $parent->$notice($obj,\%args) if $notice; + $obj->InitObject(\%args); +# ASkludge(\%args,1); + $obj->configure(%args) if (%args); +# ASkludge(\%args,0); + return $obj; +} + +sub DelegateFor +{ + my ($w,$method) = @_; + while(exists $w->{'Delegates'}) + { + my $delegate = $w->{'Delegates'}; + my $widget = $delegate->{$method}; + $widget = $delegate->{DEFAULT} unless (defined $widget); + $widget = $w->Subwidget($widget) if (defined $widget && !ref $widget); + last unless (defined $widget); + last if $widget == $w; + $w = $widget; + } + return $w; +} + +sub Delegates +{ + my $cw = shift; + my $specs = $cw->TkHash('Delegates'); + while (@_) + { + my $key = shift; + my $val = shift; + $specs->{$key} = $val; + } + return $specs; +} + +sub Construct +{ + my ($base,$name) = @_; + my $class = (caller(0))[0]; + no strict 'refs'; + + # Hack for broken ->isa in perl5.6.0 + delete ${"$class\::"}{'::ISA::CACHE::'} if $] == 5.006; + + # Pre ->isa scheme + *{$base.'::Is'.$name} = \&False; + *{$class.'::Is'.$name} = \&True; + + # DelegateFor trickyness is to allow Frames and other derived things + # to force creation in a delegate e.g. a ScrlText with embeded windows + # need those windows to be children of the Text to get clipping right + # and not of the Frame which contains the Text and the scrollbars. + *{$base.'::'."$name"} = sub { $class->new(shift->DelegateFor('Construct'),@_) }; +} + +sub IS +{ + return (defined $_[1]) && $_[0] == $_[1]; +} + +sub _AutoloadTkWidget +{ + my ($self,$method) = @_; + my $what = "Tk::Widget::$method"; + unless (defined &$what) + { + require "Tk/$method.pm"; + } + return $what; +} + +# require UNIVERSAL; don't load .pm use XS code from perl core though + +sub AUTOLOAD +{ + # Take a copy into a 'my' variable so we can recurse + my $what = $Tk::Widget::AUTOLOAD; + my $save = $@; + my $name; + # warn "AUTOLOAD $what ".(ref($_[0]) || $_[0])."\n"; + # Braces used to preserve $1 et al. + { + my ($pkg,$func) = $what =~ /(.*)::([^:]+)$/; + confess("Attempt to load '$what'") unless defined($pkg) && $func =~ /^[\w:]+$/; + $pkg =~ s#::#/#g; + if (defined($name=$INC{"$pkg.pm"})) + { + $name =~ s#^(.*)$pkg\.pm$#$1auto/$pkg/$func.al#; + } + else + { + $name = "auto/$what.al"; + $name =~ s#::#/#g; + } + } + # This may fail, catch error and prevent user's __DIE__ handler + # from triggering as well... + eval {local $SIG{'__DIE__'}; require $name}; + if ($@) + { + croak $@ unless ($@ =~ /Can't locate\s+(?:file\s+)?'?\Q$name\E'?/); + my($package,$method) = ($what =~ /^(.*)::([^:]*)$/); + if (ref $_[0] && !$_[0]->can($method) + && $_[0]->can('Delegate') + && $method !~ /^(ConfigSpecs|Delegates)/ ) + { + my $delegate = $_[0]->Delegates; + if (%$delegate || tied %$delegate) + { + my $widget = $delegate->{$method}; + $widget = $delegate->{DEFAULT} unless (defined $widget); + if (defined $widget) + { + my $subwidget = (ref $widget) ? $widget : $_[0]->Subwidget($widget); + if (defined $subwidget) + { + no strict 'refs'; + # print "AUTOLOAD: $what\n"; + *{$what} = sub { shift->Delegate($method,@_) }; + } + else + { + croak "No delegate subwidget '$widget' for $what"; + } + } + } + } + if (!defined(&$what) && ref($_[0]) && $method =~ /^[A-Z]\w+$/) + { + # Use ->can as ->isa is broken in perl5.6.0 + my $sub = UNIVERSAL::can($_[0],'_AutoloadTkWidget'); + if ($sub) + { + carp "Assuming 'require Tk::$method;'" unless $_[0]->can($method); + $what = $_[0]->$sub($method) + } + } + } + $@ = $save; + $DB::sub = $what; # Tell debugger what is going on... + unless (defined &$what) + { + no strict 'refs'; + *{$what} = sub { croak("Failed to AUTOLOAD '$what'") }; + } + goto &$what; +} + +sub _Destroyed +{ + my $w = shift; + my $a = delete $w->{'_Destroy_'}; + if (ref($a)) + { + while (@$a) + { + my $ent = pop(@$a); + if (ref $ent) + { + eval {local $SIG{'__DIE__'}; $ent->Call }; + } + else + { + delete $w->{$ent}; + } + } + } +} + +sub _OnDestroy +{ + my $w = shift; + $w->{'_Destroy_'} = [] unless (exists $w->{'_Destroy_'}); + push(@{$w->{'_Destroy_'}},@_); +} + +sub OnDestroy +{ + my $w = shift; + $w->_OnDestroy(Tk::Callback->new(@_)); +} + +sub TkHash +{ + my ($w,$key) = @_; + return $w->{$key} if exists $w->{$key}; + my $hash = $w->{$key} = {}; + $w->_OnDestroy($key); + return $hash; +} + +sub privateData +{ + my $w = shift; + my $p = shift || caller; + $w->{$p} ||= {}; +} + +my @image_types; +my %image_method; + +sub ImageMethod +{ + shift if (@_ & 1); + while (@_) + { + my ($name,$method) = splice(@_,0,2); + push(@image_types,$name); + $image_method{$name} = $method; + } +} + +sub Getimage +{ + my ($w, $name) = @_; + my $mw = $w->MainWindow; + croak "Usage \$widget->Getimage('name')" unless defined($name); + my $images = ($mw->{'__Images__'} ||= {}); + + return $images->{$name} if $images->{$name}; + + ImageMethod(xpm => 'Pixmap', + gif => 'Photo', + ppm => 'Photo', + xbm => 'Bitmap' ) unless @image_types; + + foreach my $type (@image_types) + { + my $method = $image_method{$type}; + my $file = Tk->findINC( "$name.$type" ); + next unless( $file && $method ); + my $sub = $w->can($method); + unless (defined &$sub) + { + require Tk::widgets; + Tk::widgets->import($method); + } + $images->{$name} = $w->$method( -file => $file ); + return $images->{$name}; + } + + # Try built-in bitmaps + $images->{$name} = $w->Pixmap( -id => $name ); + return $images->{$name}; +} + +sub SaveGrabInfo +{ + my $w = shift; + $Tk::oldGrab = $w->grabCurrent; + if (defined $Tk::oldGrab) + { + $Tk::grabStatus = $Tk::oldGrab->grabStatus; + } +} + +sub grabSave +{ + my ($w) = @_; + my $grab = $w->grabCurrent; + return sub {} if (!defined $grab); + my $method = ($grab->grabStatus eq 'global') ? 'grabGlobal' : 'grab'; + return sub { eval {local $SIG{'__DIE__'}; $grab->$method() } }; +} + +sub focusCurrent +{ + my ($w) = @_; + $w->Tk::focus('-displayof'); +} + +sub focusSave +{ + my ($w) = @_; + my $focus = $w->focusCurrent; + return sub {} if (!defined $focus); + return sub { eval {local $SIG{'__DIE__'}; $focus->focus } }; +} + +# This is supposed to replicate Tk::after behaviour, +# but does auto-cancel when widget is deleted. +require Tk::After; + +sub afterCancel +{ + my ($w,$what) = @_; + if (defined $what) + { + return $what->cancel if ref($what); + carp "dubious cancel of $what" if 0 && $^W; + $w->Tk::after('cancel' => $what); + } +} + +sub afterIdle +{ + my $w = shift; + return Tk::After->new($w,'idle','once',@_); +} + +sub afterInfo { + my ($w, $id) = @_; + if (defined $id) { + return ($id->[4], $id->[2], $id->[3]); + } else { + return sort( keys %{$w->{_After_}} ); + } +} + +sub after +{ + my $w = shift; + my $t = shift; + if (@_) + { + if ($t ne 'cancel') + { + require Tk::After; + return Tk::After->new($w,$t,'once',@_) + } + while (@_) + { + my $what = shift; + $w->afterCancel($what); + } + } + else + { + $w->Tk::after($t); + } +} + +sub repeat +{ + require Tk::After; + my $w = shift; + my $t = shift; + return Tk::After->new($w,$t,'repeat',@_); +} + +sub FindMenu +{ + # default FindMenu is that there is no menu. + return undef; +} + +sub XEvent { shift->{'_XEvent_'} } + +sub propertyRoot +{ + my $w = shift; + return $w->property(@_,'root'); +} + +# atom, atomname, containing, interps, pathname +# don't work this way - there is no window arg +# So we pretend there was an call the C versions from Tk.xs + +sub atom { shift->InternAtom(@_) } +sub atomname { shift->GetAtomName(@_) } +sub containing { shift->Containing(@_) } + +# interps not done yet +# pathname not done yet + +# walk and descendants adapted from Stephen's composite +# versions as they only use core features they can go here. +# hierachy is reversed in that descendants calls walk rather +# than vice versa as this avoids building a list. +# Walk should possibly be enhanced so allow early termination +# like '-prune' of find. + +sub Walk +{ + # Traverse a widget hierarchy while executing a subroutine. + my($cw, $proc, @args) = @_; + my $subwidget; + foreach $subwidget ($cw->children) + { + $subwidget->Walk($proc,@args); + &$proc($subwidget, @args); + } +} # end walk + +sub Descendants +{ + # Return a list of widgets derived from a parent widget and all its + # descendants of a particular class. + # If class is not passed returns the entire widget hierarchy. + + my($widget, $class) = @_; + my(@widget_tree) = (); + + $widget->Walk( + sub { my ($widget,$list,$class) = @_; + push(@$list, $widget) if (!defined($class) or $class eq $widget->class); + }, + \@widget_tree, $class + ); + return @widget_tree; +} + +sub Palette +{ + my $w = shift->MainWindow; + unless (exists $w->{_Palette_}) + { + my %Palette = (); + my $c = $w->Checkbutton(); + my $e = $w->Entry(); + my $s = $w->Scrollbar(); + $Palette{'activeBackground'} = ($c->configure('-activebackground'))[3] ; + $Palette{'activeForeground'} = ($c->configure('-activeforeground'))[3]; + $Palette{'background'} = ($c->configure('-background'))[3]; + $Palette{'disabledForeground'} = ($c->configure('-disabledforeground'))[3]; + $Palette{'foreground'} = ($c->configure('-foreground'))[3]; + $Palette{'highlightBackground'} = ($c->configure('-highlightbackground'))[3]; + $Palette{'highlightColor'} = ($c->configure('-highlightcolor'))[3]; + $Palette{'insertBackground'} = ($e->configure('-insertbackground'))[3]; + $Palette{'selectColor'} = ($c->configure('-selectcolor'))[3]; + $Palette{'selectBackground'} = ($e->configure('-selectbackground'))[3]; + $Palette{'selectForeground'} = ($e->configure('-selectforeground'))[3]; + $Palette{'troughColor'} = ($s->configure('-troughcolor'))[3]; + $c->destroy; + $e->destroy; + $s->destroy; + $w->{_Palette_} = \%Palette; + } + return $w->{_Palette_}; +} + +# tk_setPalette -- +# Changes the default color scheme for a Tk application by setting +# default colors in the option database and by modifying all of the +# color options for existing widgets that have the default value. +# +# Arguments: +# The arguments consist of either a single color name, which +# will be used as the new background color (all other colors will +# be computed from this) or an even number of values consisting of +# option names and values. The name for an option is the one used +# for the option database, such as activeForeground, not -activeforeground. +sub setPalette +{ + my $w = shift->MainWindow; + my %new = (@_ == 1) ? (background => $_[0]) : @_; + my $priority = delete($new{'priority'}) || 'widgetDefault'; + + # Create an array that has the complete new palette. If some colors + # aren't specified, compute them from other colors that are specified. + + die 'must specify a background color' if (!exists $new{background}); + $new{'foreground'} = 'black' unless (exists $new{foreground}); + my @bg = $w->rgb($new{'background'}); + my @fg = $w->rgb($new{'foreground'}); + my $darkerBg = sprintf('#%02x%02x%02x',9*$bg[0]/2560,9*$bg[1]/2560,9*$bg[2]/2560); + foreach my $i ('activeForeground','insertBackground','selectForeground','highlightColor') + { + $new{$i} = $new{'foreground'} unless (exists $new{$i}); + } + unless (exists $new{'disabledForeground'}) + { + $new{'disabledForeground'} = sprintf('#%02x%02x%02x',(3*$bg[0]+$fg[0])/1024,(3*$bg[1]+$fg[1])/1024,(3*$bg[2]+$fg[2])/1024); + } + $new{'highlightBackground'} = $new{'background'} unless (exists $new{'highlightBackground'}); + + unless (exists $new{'activeBackground'}) + { + my @light; + # Pick a default active background that is lighter than the + # normal background. To do this, round each color component + # up by 15% or 1/3 of the way to full white, whichever is + # greater. + foreach my $i (0, 1, 2) + { + $light[$i] = $bg[$i]/256; + my $inc1 = $light[$i]*15/100; + my $inc2 = (255-$light[$i])/3; + if ($inc1 > $inc2) + { + $light[$i] += $inc1 + } + else + { + $light[$i] += $inc2 + } + $light[$i] = 255 if ($light[$i] > 255); + } + $new{'activeBackground'} = sprintf('#%02x%02x%02x',@light); + } + $new{'selectBackground'} = $darkerBg unless (exists $new{'selectBackground'}); + $new{'troughColor'} = $darkerBg unless (exists $new{'troughColor'}); + $new{'selectColor'} = '#b03060' unless (exists $new{'selectColor'}); + + # Before doing this, make sure that the Tk::Palette variable holds + # the default values of all options, so that tkRecolorTree can + # be sure to only change options that have their default values. + # If the variable exists, then it is already correct (it was created + # the last time this procedure was invoked). If the variable + # doesn't exist, fill it in using the defaults from a few widgets. + my $Palette = $w->Palette; + + # Walk the widget hierarchy, recoloring all existing windows. + $w->RecolorTree(\%new); + # Change the option database so that future windows will get the + # same colors. + foreach my $option (keys %new) + { + $w->option('add',"*$option",$new{$option},$priority); + # Save the options in the global variable Tk::Palette, for use the + # next time we change the options. + $Palette->{$option} = $new{$option}; + } +} + +# tkRecolorTree -- +# This procedure changes the colors in a window and all of its +# descendants, according to information provided by the colors +# argument. It only modifies colors that have their default values +# as specified by the Tk::Palette variable. +# +# Arguments: +# w - The name of a window. This window and all its +# descendants are recolored. +# colors - The name of an array variable in the caller, +# which contains color information. Each element +# is named after a widget configuration option, and +# each value is the value for that option. +sub RecolorTree +{ + my ($w,$colors) = @_; + local ($@); + my $Palette = $w->Palette; + foreach my $dbOption (keys %$colors) + { + my $option = "-\L$dbOption"; + my $value; + eval {local $SIG{'__DIE__'}; $value = $w->cget($option) }; + if (defined $value) + { + if ($value eq $Palette->{$dbOption}) + { + $w->configure($option,$colors->{$dbOption}); + } + } + } + foreach my $child ($w->children) + { + $child->RecolorTree($colors); + } +} +# tkDarken -- +# Given a color name, computes a new color value that darkens (or +# brightens) the given color by a given percent. +# +# Arguments: +# color - Name of starting color. +# perecent - Integer telling how much to brighten or darken as a +# percent: 50 means darken by 50%, 110 means brighten +# by 10%. +sub Darken +{ + my ($w,$color,$percent) = @_; + my @l = $w->rgb($color); + my $red = $l[0]/256; + my $green = $l[1]/256; + my $blue = $l[2]/256; + $red = int($red*$percent/100); + $red = 255 if ($red > 255); + $green = int($green*$percent/100); + $green = 255 if ($green > 255); + $blue = int($blue*$percent/100); + $blue = 255 if ($blue > 255); + sprintf('#%02x%02x%02x',$red,$green,$blue) +} +# tk_bisque -- +# Reset the Tk color palette to the old "bisque" colors. +# +# Arguments: +# None. +sub bisque +{ + shift->setPalette('activeBackground' => '#e6ceb1', + 'activeForeground' => 'black', + 'background' => '#ffe4c4', + 'disabledForeground' => '#b0b0b0', + 'foreground' => 'black', + 'highlightBackground' => '#ffe4c4', + 'highlightColor' => 'black', + 'insertBackground' => 'black', + 'selectColor' => '#b03060', + 'selectBackground' => '#e6ceb1', + 'selectForeground' => 'black', + 'troughColor' => '#cdb79e' + ); +} + +sub PrintConfig +{ + require Tk::Pretty; + my ($w) = (@_); + my $c; + foreach $c ($w->configure) + { + print Tk::Pretty::Pretty(@$c),"\n"; + } +} + +sub BusyRecurse +{ + my ($restore,$w,$cursor,$recurse,$top) = @_; + my $c = $w->cget('-cursor'); + my @tags = $w->bindtags; + if ($top || defined($c)) + { + push(@$restore, sub { return unless Tk::Exists($w); $w->configure(-cursor => $c); $w->bindtags(\@tags) }); + $w->configure(-cursor => $cursor); + } + else + { + push(@$restore, sub { return unless Tk::Exists($w); $w->bindtags(\@tags) }); + } + $w->bindtags(['Busy',@tags]); + if ($recurse) + { + foreach my $child ($w->children) + { + BusyRecurse($restore,$child,$cursor,1,0); + } + } + return $restore; +} + +sub Busy +{ + my ($w,@args) = @_; + return unless $w->viewable; + my($sub, %args); + for(my $i=0; $i<=$#args; $i++) + { + if (ref $args[$i] eq 'CODE') + { + if (defined $sub) + { + croak "Multiple code definitions not allowed in Tk::Widget::Busy"; + } + $sub = $args[$i]; + } + else + { + $args{$args[$i]} = $args[$i+1]; $i++; + } + } + my $cursor = delete $args{'-cursor'}; + my $recurse = delete $args{'-recurse'}; + $cursor = 'watch' unless defined $cursor; + unless (exists $w->{'Busy'}) + { + my @old = ($w->grabSave); + my $key; + my @config; + foreach $key (keys %args) + { + push(@config,$key => $w->Tk::cget($key)); + } + if (@config) + { + push(@old, sub { $w->Tk::configure(@config) }); + $w->Tk::configure(%args); + } + unless ($w->Tk::bind('Busy')) + { + $w->Tk::bind('Busy','<Any-KeyPress>',[_busy => 1]); + $w->Tk::bind('Busy','<Any-KeyRelease>',[_busy => 0]); + $w->Tk::bind('Busy','<Any-ButtonPress>',[_busy => 1]); + $w->Tk::bind('Busy','<Any-ButtonRelease>',[_busy => 0]); + $w->Tk::bind('Busy','<Any-Motion>',[_busy => 0]); + } + $w->{'Busy'} = BusyRecurse(\@old,$w,$cursor,$recurse,1); + } + my $g = $w->grabCurrent; + if (defined $g) + { + # warn "$g has the grab"; + $g->grabRelease; + } + $w->update; + eval {local $SIG{'__DIE__'}; $w->grab }; + $w->update; + if ($sub) + { + eval { $sub->() }; + my $err = $@; + $w->Unbusy(-recurse => $recurse); + die $err if $err; + } +} + +sub _busy +{ + my ($w,$f) = @_; + $w->bell if $f; + $w->break; +} + +sub Unbusy +{ + my ($w) = @_; + $w->update; + $w->grabRelease if Tk::Exists($w); + my $old = delete $w->{'Busy'}; + if (defined $old) + { + local $SIG{'__DIE__'}; + eval { &{pop(@$old)} } while (@$old); + } + $w->update if Tk::Exists($w); +} + +sub waitVisibility +{ + my ($w) = shift; + $w->tkwait('visibility',$w); +} + +sub waitVariable +{ + my ($w) = shift; + $w->tkwait('variable',@_); +} + +sub waitWindow +{ + my ($w) = shift; + $w->tkwait('window',$w); +} + +sub EventWidget +{ + my ($w) = @_; + return $w->{'_EventWidget_'}; +} + +sub Popwidget +{ + my ($ew,$method,$w,@args) = @_; + $w->{'_EventWidget_'} = $ew; + $w->$method(@args); +} + +sub ColorOptions +{ + my ($w,$args) = @_; + my $opt; + $args = {} unless (defined $args); + foreach $opt (qw(-foreground -background -disabledforeground + -activebackground -activeforeground + )) + { + $args->{$opt} = $w->cget($opt) unless (exists $args->{$opt}) + } + return (wantarray) ? %$args : $args; +} + +sub XscrollBind +{ + my ($mw,$class) = @_; + $mw->bind($class,'<Left>', ['xview','scroll',-1,'units']); + $mw->bind($class,'<Control-Left>', ['xview','scroll',-1,'pages']); + $mw->bind($class,'<Control-Prior>',['xview','scroll',-1,'pages']); + $mw->bind($class,'<Right>', ['xview','scroll',1,'units']); + $mw->bind($class,'<Control-Right>',['xview','scroll',1,'pages']); + $mw->bind($class,'<Control-Next>', ['xview','scroll',1,'pages']); + + $mw->bind($class,'<Home>', ['xview','moveto',0]); + $mw->bind($class,'<End>', ['xview','moveto',1]); + $mw->XMouseWheelBind($class); +} + +sub PriorNextBind +{ + my ($mw,$class) = @_; + $mw->bind($class,'<Next>', ['yview','scroll',1,'pages']); + $mw->bind($class,'<Prior>', ['yview','scroll',-1,'pages']); +} + +sub XMouseWheelBind +{ + my ($mw,$class) = @_; + # <4> and <5> are how mousewheel looks on X + # <4> and <5> are how mousewheel looks on X + $mw->bind($class,'<Shift-4>', ['xview','scroll',-1,'units']); + $mw->bind($class,'<Shift-5>', ['xview','scroll',1,'units']); + $mw->bind($class,'<Button-6>', ['xview','scroll',-1,'units']); + $mw->bind($class,'<Button-7>', ['xview','scroll',1,'units']); +} + +sub YMouseWheelBind +{ + my ($mw,$class) = @_; + # <4> and <5> are how mousewheel looks on X + $mw->bind($class,'<4>', ['yview','scroll',-1,'units']); + $mw->bind($class,'<5>', ['yview','scroll',1,'units']); +} + +sub YscrollBind +{ + my ($mw,$class) = @_; + $mw->PriorNextBind($class); + $mw->bind($class,'<Up>', ['yview','scroll',-1,'units']); + $mw->bind($class,'<Down>', ['yview','scroll',1,'units']); + $mw->YMouseWheelBind($class); +} + +sub XYscrollBind +{ + my ($mw,$class) = @_; + $mw->YscrollBind($class); + $mw->XscrollBind($class); + # <4> and <5> are how mousewheel looks on X +} + +sub MouseWheelBind +{ + my($mw,$class) = @_; + + # The MouseWheel will typically only fire on Windows. However, one + # could use the "event generate" command to produce MouseWheel + # events on other platforms. + + $mw->Tk::bind($class, '<MouseWheel>', + [ sub { $_[0]->yview('scroll',-($_[1]/120)*3,'units') }, Tk::Ev("D")]); + + if ($Tk::platform eq 'unix') + { + # Support for mousewheels on Linux/Unix commonly comes through mapping + # the wheel to the extended buttons. If you have a mousewheel, find + # Linux configuration info at: + # http://www.inria.fr/koala/colas/mouse-wheel-scroll/ + $mw->Tk::bind($class, '<4>', + sub { $_[0]->yview('scroll', -3, 'units') + unless $Tk::strictMotif; + }); + $mw->Tk::bind($class, '<5>', + sub { $_[0]->yview('scroll', 3, 'units') + unless $Tk::strictMotif; + }); + } +} + +sub ScrlListbox +{ + my $parent = shift; + return $parent->Scrolled('Listbox',-scrollbars => 'w', @_); +} + +sub AddBindTag +{ + my ($w,$tag) = @_; + my $t; + my @tags = $w->bindtags; + foreach $t (@tags) + { + return if $t eq $tag; + } + $w->bindtags([@tags,$tag]); +} + +sub Callback +{ + my $w = shift; + my $name = shift; + my $cb = $w->cget($name); + if (defined $cb) + { + return $cb->Call(@_) if (ref $cb); + return $w->$cb(@_); + } + return (wantarray) ? () : undef; +} + +sub packAdjust +{ +# print 'packAdjust(',join(',',@_),")\n"; + require Tk::Adjuster; + my ($w,%args) = @_; + my $delay = delete($args{'-delay'}); + $delay = 1 unless (defined $delay); + $w->pack(%args); + %args = $w->packInfo; + my $adj = Tk::Adjuster->new($args{'-in'}, + -widget => $w, -delay => $delay, -side => $args{'-side'}); + $adj->packed($w,%args); + return $w; +} + +sub gridAdjust +{ + require Tk::Adjuster; + my ($w,%args) = @_; + my $delay = delete($args{'-delay'}); + $delay = 1 unless (defined $delay); + $w->grid(%args); + %args = $w->gridInfo; + my $adj = Tk::Adjuster->new($args{'-in'},-widget => $w, -delay => $delay); + $adj->gridded($w,%args); + return $w; +} + +sub place +{ + local $SIG{'__DIE__'} = \&Carp::croak; + my $w = shift; + if (@_ && $_[0] =~ /^(?:configure|forget|info|slaves)$/x) + { + $w->Tk::place(@_); + } + else + { + # Two things going on here: + # 1. Add configure on the front so that we can drop leading '-' + $w->Tk::place('configure',@_); + # 2. Return the widget rather than nothing + return $w; + } +} + +sub pack +{ + local $SIG{'__DIE__'} = \&Carp::croak; + my $w = shift; + if (@_ && $_[0] =~ /^(?:configure|forget|info|propagate|slaves)$/x) + { + # maybe array/scalar context issue with slaves + $w->Tk::pack(@_); + } + else + { + # Two things going on here: + # 1. Add configure on the front so that we can drop leading '-' + $w->Tk::pack('configure',@_); + # 2. Return the widget rather than nothing + return $w; + } +} + +sub grid +{ + local $SIG{'__DIE__'} = \&Carp::croak; + my $w = shift; + if (@_ && $_[0] =~ /^(?:bbox|columnconfigure|configure|forget|info|location|propagate|rowconfigure|size|slaves)$/x) + { + my $opt = shift; + Tk::grid($opt,$w,@_); + } + else + { + # Two things going on here: + # 1. Add configure on the front so that we can drop leading '-' + Tk::grid('configure',$w,@_); + # 2. Return the widget rather than nothing + return $w; + } +} + +sub form +{ + local $SIG{'__DIE__'} = \&Carp::croak; + my $w = shift; + if (@_ && $_[0] =~ /^(?:configure|check|forget|grid|info|slaves)$/x) + { + $w->Tk::form(@_); + } + else + { + # Two things going on here: + # 1. Add configure on the front so that we can drop leading '-' + $w->Tk::form('configure',@_); + # 2. Return the widget rather than nothing + return $w; + } +} + +sub Scrolled +{ + my ($parent,$kind,%args) = @_; + $kind = 'Pane' if $kind eq 'Frame'; + # Find args that are Frame create time args + my @args = Tk::Frame->CreateArgs($parent,\%args); + my $name = delete $args{'Name'}; + push(@args,'Name' => $name) if (defined $name); + my $cw = $parent->Frame(@args); + @args = (); + # Now remove any args that Frame can handle + foreach my $k ('-scrollbars',map($_->[0],$cw->configure)) + { + push(@args,$k,delete($args{$k})) if (exists $args{$k}) + } + # Anything else must be for target widget - pass at widget create time + my $w = $cw->$kind(%args); + # Now re-set %args to be ones Frame can handle + %args = @args; + $cw->ConfigSpecs('-scrollbars' => ['METHOD','scrollbars','Scrollbars','se'], + '-background' => [$w,'background','Background'], + '-foreground' => [$w,'foreground','Foreground'], + ); + $cw->AddScrollbars($w); + $cw->Default("\L$kind" => $w); + $cw->Delegates('bind' => $w, 'bindtags' => $w, 'menu' => $w); + $cw->ConfigDefault(\%args); + $cw->configure(%args); + return $cw; +} + +sub Populate +{ + my ($cw,$args) = @_; +} + +sub ForwardEvent +{ + my $self = shift; + my $to = shift; + $to->PassEvent($self->XEvent); +} + +# Save / Return abstract event type as in Tix. +sub EventType +{ + my $w = shift; + $w->{'_EventType_'} = $_[0] if @_; + return $w->{'_EventType_'}; +} + +sub PostPopupMenu +{ + my ($w, $X, $Y) = @_; + if (@_ < 3) + { + my $e = $w->XEvent; + $X = $e->X; + $Y = $e->Y; + } + my $menu = $w->menu; + $menu->Post($X,$Y) if defined $menu; +} + +sub FillMenu +{ + my ($w,$menu,@labels) = @_; + foreach my $lab (@labels) + { + my $method = $lab.'MenuItems'; + $method =~ s/~//g; + $method =~ s/[\s-]+/_/g; + if ($w->can($method)) + { + $menu->Menubutton(-label => $lab, -tearoff => 0, -menuitems => $w->$method()); + } + } + return $menu; +} + +sub menu +{ + my ($w,$menu) = @_; + if (@_ > 1) + { + $w->_OnDestroy('_MENU_') unless exists $w->{'_MENU_'}; + $w->{'_MENU_'} = $menu; + } + return unless defined wantarray; + unless (exists $w->{'_MENU_'}) + { + $w->_OnDestroy('_MENU_'); + $w->{'_MENU_'} = $menu = $w->Menu(-tearoff => 0); + $w->FillMenu($menu,$w->MenuLabels); + } + return $w->{'_MENU_'}; +} + +sub MenuLabels +{ + return @DefaultMenuLabels; +} + +sub FileMenuItems +{ + my ($w) = @_; + return [ ["command"=>'E~xit', -command => [ $w, 'WmDeleteWindow']]]; +} + +sub WmDeleteWindow +{ + shift->toplevel->WmDeleteWindow +} + +sub BalloonInfo +{ + my ($widget,$balloon,$X,$Y,@opt) = @_; + foreach my $opt (@opt) + { + my $info = $balloon->GetOption($opt,$widget); + return $info if defined $info; + } +} + +sub ConfigSpecs { + + my $w = shift; + + return map { ( $_->[0], [ $w, @$_[ 1 .. 4 ] ] ) } $w->configure; + +} + +*GetSelection = + ($Tk::platform eq 'unix' + ? sub + { + my $w = shift; + my $sel = @_ ? shift : "PRIMARY"; + my $txt = eval { local $SIG{__DIE__}; + $w->SelectionGet(-selection => $sel, -type => "UTF8_STRING") + }; + if ($@) + { + $txt = eval { local $SIG{__DIE__}; + $w->SelectionGet(-selection => $sel) + }; + if ($@) + { + die "could not find default selection"; + } + } + $txt; + } + : sub + { + my $w = shift; + my $sel = @_ ? shift : "PRIMARY"; + my $txt = eval { local $SIG{__DIE__}; + $w->SelectionGet(-selection => $sel) + }; + if ($@) + { + die "could not find default selection"; + } + $txt; + } + ); + +1; +__END__ + +sub bindDump { + + # Dump lots of good binding information. This pretty-print subroutine + # is, essentially, the following code in disguise: + # + # print "Binding information for $w\n"; + # foreach my $tag ($w->bindtags) { + # printf "\n Binding tag '$tag' has these bindings:\n"; + # foreach my $binding ($w->bind($tag)) { + # printf " $binding\n"; + # } + # } + + my ($w) = @_; + + my (@bindtags) = $w->bindtags; + my $digits = length( scalar @bindtags ); + my ($spc1, $spc2) = ($digits + 33, $digits + 35); + my $format1 = "%${digits}d."; + my $format2 = ' ' x ($digits + 2); + my $n = 0; + + my @out; + push @out, sprintf( "\n## Binding information for '%s', %s ##", $w->PathName, $w ); + + foreach my $tag (@bindtags) { + my (@bindings) = $w->bind($tag); + $n++; # count this bindtag + + if ($#bindings == -1) { + push @out, sprintf( "\n$format1 Binding tag '$tag' has no bindings.\n", $n ); + } else { + push @out, sprintf( "\n$format1 Binding tag '$tag' has these bindings:\n", $n ); + + foreach my $binding ( @bindings ) { + my $callback = $w->bind($tag, $binding); + push @out, sprintf( "$format2%27s : %-40s\n", $binding, $callback ); + + if ($callback =~ /SCALAR/) { + if (ref $$callback) { + push @out, sprintf( "%s %s\n", ' ' x $spc1, $$callback ); + } else { + push @out, sprintf( "%s '%s'\n", ' ' x $spc1, $$callback ); + } + } elsif ($callback =~ /ARRAY/) { + if (ref $callback->[0]) { + push @out, sprintf( "%s %s\n", ' ' x $spc1, $callback->[0], "\n" ); + } else { + push @out, sprintf( "%s '%s'\n", ' ' x $spc1, $callback->[0], "\n" ); + } + foreach my $arg (@$callback[1 .. $#{@$callback}]) { + if (ref $arg) { + push @out, sprintf( "%s %-40s", ' ' x $spc2, $arg ); + } else { + push @out, sprintf( "%s '%s'", ' ' x $spc2, $arg ); + } + + if (ref $arg eq 'Tk::Ev') { + if ($arg =~ /SCALAR/) { + push @out, sprintf( ": '$$arg'" ); + } else { + push @out, sprintf( ": '%s'", join("' '", @$arg) ); + } + } + + push @out, sprintf( "\n" ); + } # forend callback arguments + } # ifend callback + + } # forend all bindings for one tag + + } # ifend have bindings + + } # forend all tags + push @out, sprintf( "\n" ); + return @out; + +} # end bindDump + + +sub ASkludge +{ + my ($hash,$sense) = @_; + foreach my $key (%$hash) + { + if ($key =~ /-.*variable/ && ref($hash->{$key}) eq 'SCALAR') + { + if ($sense) + { + my $val = ${$hash->{$key}}; + require Tie::Scalar; + tie ${$hash->{$key}},'Tie::StdScalar'; + ${$hash->{$key}} = $val; + } + else + { + untie ${$hash->{$key}}; + } + } + } +} + + + +# clipboardKeysyms -- +# This procedure is invoked to identify the keys that correspond to +# the "copy", "cut", and "paste" functions for the clipboard. +# +# Arguments: +# copy - Name of the key (keysym name plus modifiers, if any, +# such as "Meta-y") used for the copy operation. +# cut - Name of the key used for the cut operation. +# paste - Name of the key used for the paste operation. +# +# This method is obsolete use clipboardOperations and abstract +# event types instead. See Clipboard.pm and Mainwindow.pm + +sub clipboardKeysyms +{ + my @class = (); + my $mw = shift; + if (ref $mw) + { + $mw = $mw->DelegateFor('bind'); + } + else + { + push(@class,$mw); + $mw = shift; + } + if (@_) + { + my $copy = shift; + $mw->Tk::bind(@class,"<$copy>",'clipboardCopy') if (defined $copy); + } + if (@_) + { + my $cut = shift; + $mw->Tk::bind(@class,"<$cut>",'clipboardCut') if (defined $cut); + } + if (@_) + { + my $paste = shift; + $mw->Tk::bind(@class,"<$paste>",'clipboardPaste') if (defined $paste); + } +} + +sub pathname +{ + my ($w,$id) = @_; + my $x = $w->winfo('pathname',-displayof => oct($id)); + return $x->PathName; +} diff --git a/Master/tlpkg/tlperl/lib/Tk/Wm.pm b/Master/tlpkg/tlperl/lib/Tk/Wm.pm new file mode 100644 index 00000000000..ffbe4877857 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Wm.pm @@ -0,0 +1,174 @@ +# Copyright (c) 1995-2003 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. +package Tk::Wm; +use AutoLoader; + +require Tk::Widget; +*AUTOLOAD = \&Tk::Widget::AUTOLOAD; + +use strict qw(vars); + +# There are issues with this stuff now we have Tix's wm release/capture +# as toplevel-ness is now dynamic. + + +use vars qw($VERSION); +$VERSION = sprintf '4.%03d', q$Revision: #14 $ =~ /\D(\d+)\s*$/; + +use Tk::Submethods; + +*{Tk::Wm::wmGrid} = sub { shift->wm("grid", @_) }; +*{Tk::Wm::wmTracing} = sub { shift->wm("tracing", @_) }; + +Direct Tk::Submethods ('wm' => [qw(aspect attributes client colormapwindows command + deiconify focusmodel frame geometry group + iconbitmap iconify iconimage iconmask iconname + iconwindow maxsize minsize overrideredirect positionfrom + protocol resizable sizefrom state title transient + withdraw wrapper)]); + +sub SetBindtags +{ + my ($obj) = @_; + $obj->bindtags([ref($obj),$obj,'all']); +} + +sub Populate +{ + my ($cw,$args) = @_; + $cw->ConfigSpecs('-overanchor' => ['PASSIVE',undef,undef,undef], + '-popanchor' => ['PASSIVE',undef,undef,undef], + '-popover' => ['PASSIVE',undef,undef,undef] + ); +} + +sub MoveResizeWindow +{ + my ($w,$x,$y,$width,$height) = @_; + $w->withdraw; + $w->geometry($width.'x'.$height); + $w->MoveToplevelWindow($x,$y); + $w->deiconify; +} + +sub WmDeleteWindow +{ + my ($w) = @_; + my $cb = $w->protocol('WM_DELETE_WINDOW'); + if (defined $cb) + { + $cb->Call; + } + else + { + $w->destroy; + } +} + + +1; + +__END__ + + +sub Post +{ + my ($w,$X,$Y) = @_; + $X = int($X); + $Y = int($Y); + $w->positionfrom('user'); + $w->geometry("+$X+$Y"); + # $w->MoveToplevelWindow($X,$Y); + $w->deiconify; + $w->raise; +} + +sub AnchorAdjust +{ + my ($anchor,$X,$Y,$w,$h) = @_; + $anchor = 'c' unless (defined $anchor); + $Y += ($anchor =~ /s/) ? $h : ($anchor =~ /n/) ? 0 : $h/2; + $X += ($anchor =~ /e/) ? $w : ($anchor =~ /w/) ? 0 : $w/2; + return ($X,$Y); +} + +sub Popup +{ + my $w = shift; + $w->configure(@_) if @_; + $w->idletasks; + my ($mw,$mh) = ($w->reqwidth,$w->reqheight); + my ($rx,$ry,$rw,$rh) = (0,0,0,0); + my $base = $w->cget('-popover'); + my $outside = 0; + if (defined $base) + { + if ($base eq 'cursor') + { + ($rx,$ry) = $w->pointerxy; + } + else + { + $rx = $base->rootx; + $ry = $base->rooty; + $rw = $base->Width; + $rh = $base->Height; + } + } + else + { + my $sc = ($w->parent) ? $w->parent->toplevel : $w; + $rx = -$sc->vrootx; + $ry = -$sc->vrooty; + $rw = $w->screenwidth; + $rh = $w->screenheight; + } + my ($X,$Y) = AnchorAdjust($w->cget('-overanchor'),$rx,$ry,$rw,$rh); + ($X,$Y) = AnchorAdjust($w->cget('-popanchor'),$X,$Y,-$mw,-$mh); + # adjust to not cross screen borders + if ($X < 0) { $X = 0 } + if ($Y < 0) { $Y = 0 } + if ($mw > $w->screenwidth) { $X = 0 } + if ($mh > $w->screenheight) { $Y = 0 } + $w->Post($X,$Y); + $w->waitVisibility; +} + +sub FullScreen +{ + my $w = shift; + my $over = (@_) ? shift : 0; + my $width = $w->screenwidth; + my $height = $w->screenheight; + $w->GeometryRequest($width,$height); + $w->overrideredirect($over & 1); + $w->Post(0,0); + $w->update; + if ($over & 2) + { + my $x = $w->rootx; + my $y = $w->rooty; + $width -= 2*$x; + $height -= $x + $y; + $w->GeometryRequest($width,$height); + $w->update; + } +} + +sub iconposition +{ + my $w = shift; + if (@_ == 1) + { + return $w->wm('iconposition',$1,$2) if $_[0] =~ /^(\d+),(\d+)$/; + if ($_[0] =~ /^([+-])(\d+)([+-])(\d+)$/) + { + my $x = ($1 eq '-') ? $w->screenwidth-$2 : $2; + my $y = ($3 eq '-') ? $w->screenheight-$4 : $4; + return $w->wm('iconposition',$x,$y); + } + } + $w->wm('iconposition',@_); +} + diff --git a/Master/tlpkg/tlperl/lib/Tk/X.pm b/Master/tlpkg/tlperl/lib/Tk/X.pm new file mode 100644 index 00000000000..06eefbf6bd9 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/X.pm @@ -0,0 +1,398 @@ +package Tk::X; + +use strict; +use Carp; +use vars qw($VERSION @EXPORT $AUTOLOAD); +$VERSION = '4.004'; # $Id: //depot/Tkutf8/Xlib/X/X.pm#4 $ +use Tk qw($XS_VERSION); + +require Exporter; +require DynaLoader; +require AutoLoader; + + +use base qw(Exporter DynaLoader); +# Items to export into callers namespace by default. Note: do not export +# names by default without a very good reason. Use EXPORT_OK instead. +# Do not simply export all your public functions/methods/constants. +@EXPORT = qw( + Above + AllTemporary + AllocAll + AllocNone + AllowExposures + AlreadyGrabbed + Always + AnyButton + AnyKey + AnyModifier + AnyPropertyType + ArcChord + ArcPieSlice + AsyncBoth + AsyncKeyboard + AsyncPointer + AutoRepeatModeDefault + AutoRepeatModeOff + AutoRepeatModeOn + BadAccess + BadAlloc + BadAtom + BadColor + BadCursor + BadDrawable + BadFont + BadGC + BadIDChoice + BadImplementation + BadLength + BadMatch + BadName + BadPixmap + BadRequest + BadValue + BadWindow + Below + BottomIf + Button1 + Button1Mask + Button1MotionMask + Button2 + Button2Mask + Button2MotionMask + Button3 + Button3Mask + Button3MotionMask + Button4 + Button4Mask + Button4MotionMask + Button5 + Button5Mask + Button5MotionMask + ButtonMotionMask + ButtonPress + ButtonPressMask + ButtonRelease + ButtonReleaseMask + CWBackPixel + CWBackPixmap + CWBackingPixel + CWBackingPlanes + CWBackingStore + CWBitGravity + CWBorderPixel + CWBorderPixmap + CWBorderWidth + CWColormap + CWCursor + CWDontPropagate + CWEventMask + CWHeight + CWOverrideRedirect + CWSaveUnder + CWSibling + CWStackMode + CWWidth + CWWinGravity + CWX + CWY + CapButt + CapNotLast + CapProjecting + CapRound + CenterGravity + CirculateNotify + CirculateRequest + ClientMessage + ClipByChildren + ColormapChangeMask + ColormapInstalled + ColormapNotify + ColormapUninstalled + Complex + ConfigureNotify + ConfigureRequest + ControlMapIndex + ControlMask + Convex + CoordModeOrigin + CoordModePrevious + CopyFromParent + CreateNotify + CurrentTime + CursorShape + DefaultBlanking + DefaultExposures + DestroyAll + DestroyNotify + DirectColor + DisableAccess + DisableScreenInterval + DisableScreenSaver + DoBlue + DoGreen + DoRed + DontAllowExposures + DontPreferBlanking + EastGravity + EnableAccess + EnterNotify + EnterWindowMask + EvenOddRule + Expose + ExposureMask + FamilyChaos + FamilyDECnet + FamilyInternet + FillOpaqueStippled + FillSolid + FillStippled + FillTiled + FirstExtensionError + FocusChangeMask + FocusIn + FocusOut + FontChange + FontLeftToRight + FontRightToLeft + ForgetGravity + GCArcMode + GCBackground + GCCapStyle + GCClipMask + GCClipXOrigin + GCClipYOrigin + GCDashList + GCDashOffset + GCFillRule + GCFillStyle + GCFont + GCForeground + GCFunction + GCGraphicsExposures + GCJoinStyle + GCLastBit + GCLineStyle + GCLineWidth + GCPlaneMask + GCStipple + GCSubwindowMode + GCTile + GCTileStipXOrigin + GCTileStipYOrigin + GXand + GXandInverted + GXandReverse + GXclear + GXcopy + GXcopyInverted + GXequiv + GXinvert + GXnand + GXnoop + GXnor + GXor + GXorInverted + GXorReverse + GXset + GXxor + GrabFrozen + GrabInvalidTime + GrabModeAsync + GrabModeSync + GrabNotViewable + GrabSuccess + GraphicsExpose + GravityNotify + GrayScale + HostDelete + HostInsert + IncludeInferiors + InputFocus + InputOnly + InputOutput + IsUnmapped + IsUnviewable + IsViewable + JoinBevel + JoinMiter + JoinRound + KBAutoRepeatMode + KBBellDuration + KBBellPercent + KBBellPitch + KBKey + KBKeyClickPercent + KBLed + KBLedMode + KeyPress + KeyPressMask + KeyRelease + KeyReleaseMask + KeymapNotify + KeymapStateMask + LASTEvent + LSBFirst + LastExtensionError + LeaveNotify + LeaveWindowMask + LedModeOff + LedModeOn + LineDoubleDash + LineOnOffDash + LineSolid + LockMapIndex + LockMask + LowerHighest + MSBFirst + MapNotify + MapRequest + MappingBusy + MappingFailed + MappingKeyboard + MappingModifier + MappingNotify + MappingPointer + MappingSuccess + Mod1MapIndex + Mod1Mask + Mod2MapIndex + Mod2Mask + Mod3MapIndex + Mod3Mask + Mod4MapIndex + Mod4Mask + Mod5MapIndex + Mod5Mask + MotionNotify + NoEventMask + NoExpose + NoSymbol + Nonconvex + None + NorthEastGravity + NorthGravity + NorthWestGravity + NotUseful + NotifyAncestor + NotifyDetailNone + NotifyGrab + NotifyHint + NotifyInferior + NotifyNonlinear + NotifyNonlinearVirtual + NotifyNormal + NotifyPointer + NotifyPointerRoot + NotifyUngrab + NotifyVirtual + NotifyWhileGrabbed + Opposite + OwnerGrabButtonMask + ParentRelative + PlaceOnBottom + PlaceOnTop + PointerMotionHintMask + PointerMotionMask + PointerRoot + PointerWindow + PreferBlanking + PropModeAppend + PropModePrepend + PropModeReplace + PropertyChangeMask + PropertyDelete + PropertyNewValue + PropertyNotify + PseudoColor + RaiseLowest + ReparentNotify + ReplayKeyboard + ReplayPointer + ResizeRedirectMask + ResizeRequest + RetainPermanent + RetainTemporary + RevertToNone + RevertToParent + RevertToPointerRoot + ScreenSaverActive + ScreenSaverReset + SelectionClear + SelectionNotify + SelectionRequest + SetModeDelete + SetModeInsert + ShiftMapIndex + ShiftMask + SouthEastGravity + SouthGravity + SouthWestGravity + StaticColor + StaticGravity + StaticGray + StippleShape + StructureNotifyMask + SubstructureNotifyMask + SubstructureRedirectMask + Success + SyncBoth + SyncKeyboard + SyncPointer + TileShape + TopIf + TrueColor + UnmapGravity + UnmapNotify + Unsorted + VisibilityChangeMask + VisibilityFullyObscured + VisibilityNotify + VisibilityPartiallyObscured + VisibilityUnobscured + WestGravity + WhenMapped + WindingRule + XYBitmap + XYPixmap + X_H + X_PROTOCOL + X_PROTOCOL_REVISION + YSorted + YXBanded + YXSorted + ZPixmap +); + +sub AUTOLOAD { + # This AUTOLOAD is used to 'autoload' constants from the constant() + # XS function. If a constant is not found then control is passed + # to the AUTOLOAD in AutoLoader. + + my $constname; + ($constname = $AUTOLOAD) =~ s/.*:://; + my $val = constant($constname, @_ ? $_[0] : 0); + if ($! != 0) { + if ($! =~ /Invalid/) { + $AutoLoader::AUTOLOAD = $AUTOLOAD; + goto &AutoLoader::AUTOLOAD; + } + else { + croak "Your vendor has not defined X macro $constname"; + } + } + eval "sub $AUTOLOAD { $val }"; + goto &$AUTOLOAD; +} + +bootstrap Tk::X; + +# Preloaded methods go here. + +# Autoload methods go after =cut, and are processed by the autosplit program. + +1; +__END__ +# Below is the stub of documentation for your module. You better edit it! + +=cut diff --git a/Master/tlpkg/tlperl/lib/Tk/X11/X.h b/Master/tlpkg/tlperl/lib/Tk/X11/X.h new file mode 100644 index 00000000000..95db07f903f --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/X11/X.h @@ -0,0 +1,677 @@ +/* + * $XConsortium: X.h,v 1.66 88/09/06 15:55:56 jim Exp $ + */ + +/* Definitions for the X window system likely to be used by applications */ + +#ifndef X_H +#define X_H + +/*********************************************************** +Copyright 1987 by Digital Equipment Corporation, Maynard, Massachusetts, +and the Massachusetts Institute of Technology, Cambridge, Massachusetts. + + All Rights Reserved + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, +provided that the above copyright notice appear in all copies and that +both that copyright notice and this permission notice appear in +supporting documentation, and that the names of Digital or MIT not be +used in advertising or publicity pertaining to distribution of the +software without specific, written prior permission. + +DIGITAL DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING +ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL +DIGITAL BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR +ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, +WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, +ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS +SOFTWARE. + +******************************************************************/ +#define X_PROTOCOL 11 /* current protocol version */ +#define X_PROTOCOL_REVISION 0 /* current minor version */ + +#if defined(MAC_TCL) || defined(MAC_OSX_TK) +# define Cursor XCursor +# define Region XRegion +#endif + +/* Resources */ + +#ifdef _WIN64 +typedef __int64 XID; +#else +typedef unsigned long XID; +#endif + +typedef XID Window; +typedef XID Drawable; +typedef XID Font; +typedef XID Pixmap; +typedef XID Cursor; +typedef XID Colormap; +typedef XID GContext; +typedef XID KeySym; + +typedef unsigned long Mask; + +typedef unsigned long Atom; + +typedef unsigned long VisualID; + +typedef unsigned long Time; + +typedef unsigned long KeyCode; /* In order to use IME, the Macintosh needs + * to pack 3 bytes into the keyCode field in + * the XEvent. In the real X.h, a KeyCode is + * defined as a short, which wouldn't be big + * enough. */ + +/***************************************************************** + * RESERVED RESOURCE AND CONSTANT DEFINITIONS + *****************************************************************/ + +#define None 0L /* universal null resource or null atom */ + +#define ParentRelative 1L /* background pixmap in CreateWindow + and ChangeWindowAttributes */ + +#define CopyFromParent 0L /* border pixmap in CreateWindow + and ChangeWindowAttributes + special VisualID and special window + class passed to CreateWindow */ + +#define PointerWindow 0L /* destination window in SendEvent */ +#define InputFocus 1L /* destination window in SendEvent */ + +#define PointerRoot 1L /* focus window in SetInputFocus */ + +#define AnyPropertyType 0L /* special Atom, passed to GetProperty */ + +#define AnyKey 0L /* special Key Code, passed to GrabKey */ + +#define AnyButton 0L /* special Button Code, passed to GrabButton */ + +#define AllTemporary 0L /* special Resource ID passed to KillClient */ + +#define CurrentTime 0L /* special Time */ + +#define NoSymbol 0L /* special KeySym */ + +/***************************************************************** + * EVENT DEFINITIONS + *****************************************************************/ + +/* Input Event Masks. Used as event-mask window attribute and as arguments + to Grab requests. Not to be confused with event names. */ + +#define NoEventMask 0L +#define KeyPressMask (1L<<0) +#define KeyReleaseMask (1L<<1) +#define ButtonPressMask (1L<<2) +#define ButtonReleaseMask (1L<<3) +#define EnterWindowMask (1L<<4) +#define LeaveWindowMask (1L<<5) +#define PointerMotionMask (1L<<6) +#define PointerMotionHintMask (1L<<7) +#define Button1MotionMask (1L<<8) +#define Button2MotionMask (1L<<9) +#define Button3MotionMask (1L<<10) +#define Button4MotionMask (1L<<11) +#define Button5MotionMask (1L<<12) +#define ButtonMotionMask (1L<<13) +#define KeymapStateMask (1L<<14) +#define ExposureMask (1L<<15) +#define VisibilityChangeMask (1L<<16) +#define StructureNotifyMask (1L<<17) +#define ResizeRedirectMask (1L<<18) +#define SubstructureNotifyMask (1L<<19) +#define SubstructureRedirectMask (1L<<20) +#define FocusChangeMask (1L<<21) +#define PropertyChangeMask (1L<<22) +#define ColormapChangeMask (1L<<23) +#define OwnerGrabButtonMask (1L<<24) + +/* Event names. Used in "type" field in XEvent structures. Not to be +confused with event masks above. They start from 2 because 0 and 1 +are reserved in the protocol for errors and replies. */ + +#define KeyPress 2 +#define KeyRelease 3 +#define ButtonPress 4 +#define ButtonRelease 5 +#define MotionNotify 6 +#define EnterNotify 7 +#define LeaveNotify 8 +#define FocusIn 9 +#define FocusOut 10 +#define KeymapNotify 11 +#define Expose 12 +#define GraphicsExpose 13 +#define NoExpose 14 +#define VisibilityNotify 15 +#define CreateNotify 16 +#define DestroyNotify 17 +#define UnmapNotify 18 +#define MapNotify 19 +#define MapRequest 20 +#define ReparentNotify 21 +#define ConfigureNotify 22 +#define ConfigureRequest 23 +#define GravityNotify 24 +#define ResizeRequest 25 +#define CirculateNotify 26 +#define CirculateRequest 27 +#define PropertyNotify 28 +#define SelectionClear 29 +#define SelectionRequest 30 +#define SelectionNotify 31 +#define ColormapNotify 32 +#define ClientMessage 33 +#define MappingNotify 34 +#define LASTEvent 35 /* must be bigger than any event # */ + + +/* Key masks. Used as modifiers to GrabButton and GrabKey, results of QueryPointer, + state in various key-, mouse-, and button-related events. */ + +#define ShiftMask (1<<0) +#define LockMask (1<<1) +#define ControlMask (1<<2) +#define Mod1Mask (1<<3) +#define Mod2Mask (1<<4) +#define Mod3Mask (1<<5) +#define Mod4Mask (1<<6) +#define Mod5Mask (1<<7) + +/* modifier names. Used to build a SetModifierMapping request or + to read a GetModifierMapping request. These correspond to the + masks defined above. */ +#define ShiftMapIndex 0 +#define LockMapIndex 1 +#define ControlMapIndex 2 +#define Mod1MapIndex 3 +#define Mod2MapIndex 4 +#define Mod3MapIndex 5 +#define Mod4MapIndex 6 +#define Mod5MapIndex 7 + + +/* button masks. Used in same manner as Key masks above. Not to be confused + with button names below. */ + +#define Button1Mask (1<<8) +#define Button2Mask (1<<9) +#define Button3Mask (1<<10) +#define Button4Mask (1<<11) +#define Button5Mask (1<<12) + +#define AnyModifier (1<<15) /* used in GrabButton, GrabKey */ + + +/* button names. Used as arguments to GrabButton and as detail in ButtonPress + and ButtonRelease events. Not to be confused with button masks above. + Note that 0 is already defined above as "AnyButton". */ + +#define Button1 1 +#define Button2 2 +#define Button3 3 +#define Button4 4 +#define Button5 5 + +/* Notify modes */ + +#define NotifyNormal 0 +#define NotifyGrab 1 +#define NotifyUngrab 2 +#define NotifyWhileGrabbed 3 + +#define NotifyHint 1 /* for MotionNotify events */ + +/* Notify detail */ + +#define NotifyAncestor 0 +#define NotifyVirtual 1 +#define NotifyInferior 2 +#define NotifyNonlinear 3 +#define NotifyNonlinearVirtual 4 +#define NotifyPointer 5 +#define NotifyPointerRoot 6 +#define NotifyDetailNone 7 + +/* Visibility notify */ + +#define VisibilityUnobscured 0 +#define VisibilityPartiallyObscured 1 +#define VisibilityFullyObscured 2 + +/* Circulation request */ + +#define PlaceOnTop 0 +#define PlaceOnBottom 1 + +/* protocol families */ + +#define FamilyInternet 0 +#define FamilyDECnet 1 +#define FamilyChaos 2 + +/* Property notification */ + +#define PropertyNewValue 0 +#define PropertyDelete 1 + +/* Color Map notification */ + +#define ColormapUninstalled 0 +#define ColormapInstalled 1 + +/* GrabPointer, GrabButton, GrabKeyboard, GrabKey Modes */ + +#define GrabModeSync 0 +#define GrabModeAsync 1 + +/* GrabPointer, GrabKeyboard reply status */ + +#define GrabSuccess 0 +#define AlreadyGrabbed 1 +#define GrabInvalidTime 2 +#define GrabNotViewable 3 +#define GrabFrozen 4 + +/* AllowEvents modes */ + +#define AsyncPointer 0 +#define SyncPointer 1 +#define ReplayPointer 2 +#define AsyncKeyboard 3 +#define SyncKeyboard 4 +#define ReplayKeyboard 5 +#define AsyncBoth 6 +#define SyncBoth 7 + +/* Used in SetInputFocus, GetInputFocus */ + +#define RevertToNone (int)None +#define RevertToPointerRoot (int)PointerRoot +#define RevertToParent 2 + +/***************************************************************** + * ERROR CODES + *****************************************************************/ + +#define Success 0 /* everything's okay */ +#define BadRequest 1 /* bad request code */ +#define BadValue 2 /* int parameter out of range */ +#define BadWindow 3 /* parameter not a Window */ +#define BadPixmap 4 /* parameter not a Pixmap */ +#define BadAtom 5 /* parameter not an Atom */ +#define BadCursor 6 /* parameter not a Cursor */ +#define BadFont 7 /* parameter not a Font */ +#define BadMatch 8 /* parameter mismatch */ +#define BadDrawable 9 /* parameter not a Pixmap or Window */ +#define BadAccess 10 /* depending on context: + - key/button already grabbed + - attempt to free an illegal + cmap entry + - attempt to store into a read-only + color map entry. + - attempt to modify the access control + list from other than the local host. + */ +#define BadAlloc 11 /* insufficient resources */ +#define BadColor 12 /* no such colormap */ +#define BadGC 13 /* parameter not a GC */ +#define BadIDChoice 14 /* choice not in range or already used */ +#define BadName 15 /* font or color name doesn't exist */ +#define BadLength 16 /* Request length incorrect */ +#define BadImplementation 17 /* server is defective */ + +#define FirstExtensionError 128 +#define LastExtensionError 255 + +/***************************************************************** + * WINDOW DEFINITIONS + *****************************************************************/ + +/* Window classes used by CreateWindow */ +/* Note that CopyFromParent is already defined as 0 above */ + +#define InputOutput 1 +#define InputOnly 2 + +/* Window attributes for CreateWindow and ChangeWindowAttributes */ + +#define CWBackPixmap (1L<<0) +#define CWBackPixel (1L<<1) +#define CWBorderPixmap (1L<<2) +#define CWBorderPixel (1L<<3) +#define CWBitGravity (1L<<4) +#define CWWinGravity (1L<<5) +#define CWBackingStore (1L<<6) +#define CWBackingPlanes (1L<<7) +#define CWBackingPixel (1L<<8) +#define CWOverrideRedirect (1L<<9) +#define CWSaveUnder (1L<<10) +#define CWEventMask (1L<<11) +#define CWDontPropagate (1L<<12) +#define CWColormap (1L<<13) +#define CWCursor (1L<<14) + +/* ConfigureWindow structure */ + +#define CWX (1<<0) +#define CWY (1<<1) +#define CWWidth (1<<2) +#define CWHeight (1<<3) +#define CWBorderWidth (1<<4) +#define CWSibling (1<<5) +#define CWStackMode (1<<6) + + +/* Bit Gravity */ + +#define ForgetGravity 0 +#define NorthWestGravity 1 +#define NorthGravity 2 +#define NorthEastGravity 3 +#define WestGravity 4 +#define CenterGravity 5 +#define EastGravity 6 +#define SouthWestGravity 7 +#define SouthGravity 8 +#define SouthEastGravity 9 +#define StaticGravity 10 + +/* Window gravity + bit gravity above */ + +#define UnmapGravity 0 + +/* Used in CreateWindow for backing-store hint */ + +#define NotUseful 0 +#define WhenMapped 1 +#define Always 2 + +/* Used in GetWindowAttributes reply */ + +#define IsUnmapped 0 +#define IsUnviewable 1 +#define IsViewable 2 + +/* Used in ChangeSaveSet */ + +#define SetModeInsert 0 +#define SetModeDelete 1 + +/* Used in ChangeCloseDownMode */ + +#define DestroyAll 0 +#define RetainPermanent 1 +#define RetainTemporary 2 + +/* Window stacking method (in configureWindow) */ + +#define Above 0 +#define Below 1 +#define TopIf 2 +#define BottomIf 3 +#define Opposite 4 + +/* Circulation direction */ + +#define RaiseLowest 0 +#define LowerHighest 1 + +/* Property modes */ + +#define PropModeReplace 0 +#define PropModePrepend 1 +#define PropModeAppend 2 + +/***************************************************************** + * GRAPHICS DEFINITIONS + *****************************************************************/ + +/* graphics functions, as in GC.alu */ + +#define GXclear 0x0 /* 0 */ +#define GXand 0x1 /* src AND dst */ +#define GXandReverse 0x2 /* src AND NOT dst */ +#define GXcopy 0x3 /* src */ +#define GXandInverted 0x4 /* NOT src AND dst */ +#define GXnoop 0x5 /* dst */ +#define GXxor 0x6 /* src XOR dst */ +#define GXor 0x7 /* src OR dst */ +#define GXnor 0x8 /* NOT src AND NOT dst */ +#define GXequiv 0x9 /* NOT src XOR dst */ +#define GXinvert 0xa /* NOT dst */ +#define GXorReverse 0xb /* src OR NOT dst */ +#define GXcopyInverted 0xc /* NOT src */ +#define GXorInverted 0xd /* NOT src OR dst */ +#define GXnand 0xe /* NOT src OR NOT dst */ +#define GXset 0xf /* 1 */ + +/* LineStyle */ + +#define LineSolid 0 +#define LineOnOffDash 1 +#define LineDoubleDash 2 + +/* capStyle */ + +#define CapNotLast 0 +#define CapButt 1 +#define CapRound 2 +#define CapProjecting 3 + +/* joinStyle */ + +#define JoinMiter 0 +#define JoinRound 1 +#define JoinBevel 2 + +/* fillStyle */ + +#define FillSolid 0 +#define FillTiled 1 +#define FillStippled 2 +#define FillOpaqueStippled 3 + +/* fillRule */ + +#define EvenOddRule 0 +#define WindingRule 1 + +/* subwindow mode */ + +#define ClipByChildren 0 +#define IncludeInferiors 1 + +/* SetClipRectangles ordering */ + +#define Unsorted 0 +#define YSorted 1 +#define YXSorted 2 +#define YXBanded 3 + +/* CoordinateMode for drawing routines */ + +#define CoordModeOrigin 0 /* relative to the origin */ +#define CoordModePrevious 1 /* relative to previous point */ + +/* Polygon shapes */ + +#define Complex 0 /* paths may intersect */ +#define Nonconvex 1 /* no paths intersect, but not convex */ +#define Convex 2 /* wholly convex */ + +/* Arc modes for PolyFillArc */ + +#define ArcChord 0 /* join endpoints of arc */ +#define ArcPieSlice 1 /* join endpoints to center of arc */ + +/* GC components: masks used in CreateGC, CopyGC, ChangeGC, OR'ed into + GC.stateChanges */ + +#define GCFunction (1L<<0) +#define GCPlaneMask (1L<<1) +#define GCForeground (1L<<2) +#define GCBackground (1L<<3) +#define GCLineWidth (1L<<4) +#define GCLineStyle (1L<<5) +#define GCCapStyle (1L<<6) +#define GCJoinStyle (1L<<7) +#define GCFillStyle (1L<<8) +#define GCFillRule (1L<<9) +#define GCTile (1L<<10) +#define GCStipple (1L<<11) +#define GCTileStipXOrigin (1L<<12) +#define GCTileStipYOrigin (1L<<13) +#define GCFont (1L<<14) +#define GCSubwindowMode (1L<<15) +#define GCGraphicsExposures (1L<<16) +#define GCClipXOrigin (1L<<17) +#define GCClipYOrigin (1L<<18) +#define GCClipMask (1L<<19) +#define GCDashOffset (1L<<20) +#define GCDashList (1L<<21) +#define GCArcMode (1L<<22) + +#define GCLastBit 22 +/***************************************************************** + * FONTS + *****************************************************************/ + +/* used in QueryFont -- draw direction */ + +#define FontLeftToRight 0 +#define FontRightToLeft 1 + +#define FontChange 255 + +/***************************************************************** + * IMAGING + *****************************************************************/ + +/* ImageFormat -- PutImage, GetImage */ + +#define XYBitmap 0 /* depth 1, XYFormat */ +#define XYPixmap 1 /* depth == drawable depth */ +#define ZPixmap 2 /* depth == drawable depth */ + +/***************************************************************** + * COLOR MAP STUFF + *****************************************************************/ + +/* For CreateColormap */ + +#define AllocNone 0 /* create map with no entries */ +#define AllocAll 1 /* allocate entire map writeable */ + + +/* Flags used in StoreNamedColor, StoreColors */ + +#define DoRed (1<<0) +#define DoGreen (1<<1) +#define DoBlue (1<<2) + +/***************************************************************** + * CURSOR STUFF + *****************************************************************/ + +/* QueryBestSize Class */ + +#define CursorShape 0 /* largest size that can be displayed */ +#define TileShape 1 /* size tiled fastest */ +#define StippleShape 2 /* size stippled fastest */ + +/***************************************************************** + * KEYBOARD/POINTER STUFF + *****************************************************************/ + +#define AutoRepeatModeOff 0 +#define AutoRepeatModeOn 1 +#define AutoRepeatModeDefault 2 + +#define LedModeOff 0 +#define LedModeOn 1 + +/* masks for ChangeKeyboardControl */ + +#define KBKeyClickPercent (1L<<0) +#define KBBellPercent (1L<<1) +#define KBBellPitch (1L<<2) +#define KBBellDuration (1L<<3) +#define KBLed (1L<<4) +#define KBLedMode (1L<<5) +#define KBKey (1L<<6) +#define KBAutoRepeatMode (1L<<7) + +#define MappingSuccess 0 +#define MappingBusy 1 +#define MappingFailed 2 + +#define MappingModifier 0 +#define MappingKeyboard 1 +#define MappingPointer 2 + +/***************************************************************** + * SCREEN SAVER STUFF + *****************************************************************/ + +#define DontPreferBlanking 0 +#define PreferBlanking 1 +#define DefaultBlanking 2 + +#define DisableScreenSaver 0 +#define DisableScreenInterval 0 + +#define DontAllowExposures 0 +#define AllowExposures 1 +#define DefaultExposures 2 + +/* for ForceScreenSaver */ + +#define ScreenSaverReset 0 +#define ScreenSaverActive 1 + +/***************************************************************** + * HOSTS AND CONNECTIONS + *****************************************************************/ + +/* for ChangeHosts */ + +#define HostInsert 0 +#define HostDelete 1 + +/* for ChangeAccessControl */ + +#define EnableAccess 1 +#define DisableAccess 0 + +/* Display classes used in opening the connection + * Note that the statically allocated ones are even numbered and the + * dynamically changeable ones are odd numbered */ + +#define StaticGray 0 +#define GrayScale 1 +#define StaticColor 2 +#define PseudoColor 3 +#define TrueColor 4 +#define DirectColor 5 + + +/* Byte order used in imageByteOrder and bitmapBitOrder */ + +#define LSBFirst 0 +#define MSBFirst 1 + +#if defined(MAC_TCL) || defined(MAC_OSX_TK) +# undef Cursor +# undef Region +#endif + +#endif /* X_H */ diff --git a/Master/tlpkg/tlperl/lib/Tk/X11/Xatom.h b/Master/tlpkg/tlperl/lib/Tk/X11/Xatom.h new file mode 100644 index 00000000000..485a4236db8 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/X11/Xatom.h @@ -0,0 +1,79 @@ +#ifndef XATOM_H +#define XATOM_H 1 + +/* THIS IS A GENERATED FILE + * + * Do not change! Changing this file implies a protocol change! + */ + +#define XA_PRIMARY ((Atom) 1) +#define XA_SECONDARY ((Atom) 2) +#define XA_ARC ((Atom) 3) +#define XA_ATOM ((Atom) 4) +#define XA_BITMAP ((Atom) 5) +#define XA_CARDINAL ((Atom) 6) +#define XA_COLORMAP ((Atom) 7) +#define XA_CURSOR ((Atom) 8) +#define XA_CUT_BUFFER0 ((Atom) 9) +#define XA_CUT_BUFFER1 ((Atom) 10) +#define XA_CUT_BUFFER2 ((Atom) 11) +#define XA_CUT_BUFFER3 ((Atom) 12) +#define XA_CUT_BUFFER4 ((Atom) 13) +#define XA_CUT_BUFFER5 ((Atom) 14) +#define XA_CUT_BUFFER6 ((Atom) 15) +#define XA_CUT_BUFFER7 ((Atom) 16) +#define XA_DRAWABLE ((Atom) 17) +#define XA_FONT ((Atom) 18) +#define XA_INTEGER ((Atom) 19) +#define XA_PIXMAP ((Atom) 20) +#define XA_POINT ((Atom) 21) +#define XA_RECTANGLE ((Atom) 22) +#define XA_RESOURCE_MANAGER ((Atom) 23) +#define XA_RGB_COLOR_MAP ((Atom) 24) +#define XA_RGB_BEST_MAP ((Atom) 25) +#define XA_RGB_BLUE_MAP ((Atom) 26) +#define XA_RGB_DEFAULT_MAP ((Atom) 27) +#define XA_RGB_GRAY_MAP ((Atom) 28) +#define XA_RGB_GREEN_MAP ((Atom) 29) +#define XA_RGB_RED_MAP ((Atom) 30) +#define XA_STRING ((Atom) 31) +#define XA_VISUALID ((Atom) 32) +#define XA_WINDOW ((Atom) 33) +#define XA_WM_COMMAND ((Atom) 34) +#define XA_WM_HINTS ((Atom) 35) +#define XA_WM_CLIENT_MACHINE ((Atom) 36) +#define XA_WM_ICON_NAME ((Atom) 37) +#define XA_WM_ICON_SIZE ((Atom) 38) +#define XA_WM_NAME ((Atom) 39) +#define XA_WM_NORMAL_HINTS ((Atom) 40) +#define XA_WM_SIZE_HINTS ((Atom) 41) +#define XA_WM_ZOOM_HINTS ((Atom) 42) +#define XA_MIN_SPACE ((Atom) 43) +#define XA_NORM_SPACE ((Atom) 44) +#define XA_MAX_SPACE ((Atom) 45) +#define XA_END_SPACE ((Atom) 46) +#define XA_SUPERSCRIPT_X ((Atom) 47) +#define XA_SUPERSCRIPT_Y ((Atom) 48) +#define XA_SUBSCRIPT_X ((Atom) 49) +#define XA_SUBSCRIPT_Y ((Atom) 50) +#define XA_UNDERLINE_POSITION ((Atom) 51) +#define XA_UNDERLINE_THICKNESS ((Atom) 52) +#define XA_STRIKEOUT_ASCENT ((Atom) 53) +#define XA_STRIKEOUT_DESCENT ((Atom) 54) +#define XA_ITALIC_ANGLE ((Atom) 55) +#define XA_X_HEIGHT ((Atom) 56) +#define XA_QUAD_WIDTH ((Atom) 57) +#define XA_WEIGHT ((Atom) 58) +#define XA_POINT_SIZE ((Atom) 59) +#define XA_RESOLUTION ((Atom) 60) +#define XA_COPYRIGHT ((Atom) 61) +#define XA_NOTICE ((Atom) 62) +#define XA_FONT_NAME ((Atom) 63) +#define XA_FAMILY_NAME ((Atom) 64) +#define XA_FULL_NAME ((Atom) 65) +#define XA_CAP_HEIGHT ((Atom) 66) +#define XA_WM_CLASS ((Atom) 67) +#define XA_WM_TRANSIENT_FOR ((Atom) 68) + +#define XA_LAST_PREDEFINED ((Atom) 68) +#endif /* XATOM_H */ diff --git a/Master/tlpkg/tlperl/lib/Tk/X11/Xfuncproto.h b/Master/tlpkg/tlperl/lib/Tk/X11/Xfuncproto.h new file mode 100644 index 00000000000..a59379b3b65 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/X11/Xfuncproto.h @@ -0,0 +1,60 @@ +/* $XConsortium: Xfuncproto.h,v 1.7 91/05/13 20:49:21 rws Exp $ */ +/* + * Copyright 1989, 1991 by the Massachusetts Institute of Technology + * + * Permission to use, copy, modify, and distribute this software and its + * documentation for any purpose and without fee is hereby granted, provided + * that the above copyright notice appear in all copies and that both that + * copyright notice and this permission notice appear in supporting + * documentation, and that the name of M.I.T. not be used in advertising + * or publicity pertaining to distribution of the software without specific, + * written prior permission. M.I.T. makes no representations about the + * suitability of this software for any purpose. It is provided "as is" + * without express or implied warranty. + * + */ + +/* Definitions to make function prototypes manageable */ + +#ifndef _XFUNCPROTO_H_ +#define _XFUNCPROTO_H_ + +#ifndef NeedFunctionPrototypes +#define NeedFunctionPrototypes 1 +#endif /* NeedFunctionPrototypes */ + +#ifndef NeedVarargsPrototypes +#define NeedVarargsPrototypes 0 +#endif /* NeedVarargsPrototypes */ + +#if NeedFunctionPrototypes + +#ifndef NeedNestedPrototypes +#define NeedNestedPrototypes 1 +#endif /* NeedNestedPrototypes */ + +#ifndef _Xconst +#define _Xconst const +#endif /* _Xconst */ + +#ifndef NeedWidePrototypes +#ifdef NARROWPROTO +#define NeedWidePrototypes 0 +#else +#define NeedWidePrototypes 1 /* default to make interropt. easier */ +#endif +#endif /* NeedWidePrototypes */ + +#endif /* NeedFunctionPrototypes */ + +#ifdef __cplusplus +#define _XFUNCPROTOBEGIN extern "C" { +#define _XFUNCPROTOEND } +#endif + +#ifndef _XFUNCPROTOBEGIN +#define _XFUNCPROTOBEGIN +#define _XFUNCPROTOEND +#endif /* _XFUNCPROTOBEGIN */ + +#endif /* _XFUNCPROTO_H_ */ diff --git a/Master/tlpkg/tlperl/lib/Tk/X11/Xlib.h b/Master/tlpkg/tlperl/lib/Tk/X11/Xlib.h new file mode 100644 index 00000000000..0a9e3ddd45d --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/X11/Xlib.h @@ -0,0 +1,1214 @@ +/* $XConsortium: Xlib.h,v 11.221 93/07/02 14:13:28 gildea Exp $ */ +/* + * Copyright 1985, 1986, 1987, 1991 by the Massachusetts Institute of Technology + * + * Permission to use, copy, modify, and distribute this software and its + * documentation for any purpose and without fee is hereby granted, provided + * that the above copyright notice appear in all copies and that both that + * copyright notice and this permission notice appear in supporting + * documentation, and that the name of M.I.T. not be used in advertising + * or publicity pertaining to distribution of the software without specific, + * written prior permission. M.I.T. makes no representations about the + * suitability of this software for any purpose. It is provided "as is" + * without express or implied warranty. + * + * X Window System is a Trademark of MIT. + * + */ + + +/* + * Xlib.h - Header definition and support file for the C subroutine + * interface library (Xlib) to the X Window System Protocol (V11). + * Structures and symbols starting with "_" are private to the library. + */ +#ifndef _XLIB_H_ +#define _XLIB_H_ + +#define XlibSpecificationRelease 5 + +#if !defined(MAC_TCL) && !defined(MAC_OSX_TK) +# include <X11/X.h> +#endif +#ifdef MAC_TCL +# include <X.h> +# define Cursor XCursor +# define Region XRegion +#endif +#ifdef MAC_OSX_TK +# include <X11/X.h> +# define Cursor XCursor +# define Region XRegion +#endif + +/* applications should not depend on these two headers being included! */ +#ifdef MAC_TCL +#include <Xfuncproto.h> +#else +#include <X11/Xfuncproto.h> +#endif + +#ifndef X_WCHAR +#ifdef X_NOT_STDC_ENV +#define X_WCHAR +#endif +#endif + +#ifndef X_WCHAR +#include <stddef.h> +#else +/* replace this with #include or typedef appropriate for your system */ +typedef unsigned long wchar_t; +#endif + +typedef char *XPointer; + +#define Bool int +#if defined(MAC_TCL) || defined(MAC_OSX_TK) +/* Use define rather than typedef, since may need to undefine this later */ +#define Status int +#else +typedef int Status; +#endif +#define True 1 +#define False 0 + +#define QueuedAlready 0 +#define QueuedAfterReading 1 +#define QueuedAfterFlush 2 + +#define ConnectionNumber(dpy) ((dpy)->fd) +#define RootWindow(dpy, scr) (((dpy)->screens[(scr)]).root) +#define DefaultScreen(dpy) ((dpy)->default_screen) +#define DefaultRootWindow(dpy) (((dpy)->screens[(dpy)->default_screen]).root) +#define DefaultVisual(dpy, scr) (((dpy)->screens[(scr)]).root_visual) +#define DefaultGC(dpy, scr) (((dpy)->screens[(scr)]).default_gc) +#define BlackPixel(dpy, scr) (((dpy)->screens[(scr)]).black_pixel) +#define WhitePixel(dpy, scr) (((dpy)->screens[(scr)]).white_pixel) +#define AllPlanes ((unsigned long)~0L) +#define QLength(dpy) ((dpy)->qlen) +#define DisplayWidth(dpy, scr) (((dpy)->screens[(scr)]).width) +#define DisplayHeight(dpy, scr) (((dpy)->screens[(scr)]).height) +#define DisplayWidthMM(dpy, scr)(((dpy)->screens[(scr)]).mwidth) +#define DisplayHeightMM(dpy, scr)(((dpy)->screens[(scr)]).mheight) +#define DisplayPlanes(dpy, scr) (((dpy)->screens[(scr)]).root_depth) +#define DisplayCells(dpy, scr) (DefaultVisual((dpy), (scr))->map_entries) +#define ScreenCount(dpy) ((dpy)->nscreens) +#define ServerVendor(dpy) ((dpy)->vendor) +#define ProtocolVersion(dpy) ((dpy)->proto_major_version) +#define ProtocolRevision(dpy) ((dpy)->proto_minor_version) +#define VendorRelease(dpy) ((dpy)->release) +#define DisplayString(dpy) ((dpy)->display_name) +#define DefaultDepth(dpy, scr) (((dpy)->screens[(scr)]).root_depth) +#define DefaultColormap(dpy, scr)(((dpy)->screens[(scr)]).cmap) +#define BitmapUnit(dpy) ((dpy)->bitmap_unit) +#define BitmapBitOrder(dpy) ((dpy)->bitmap_bit_order) +#define BitmapPad(dpy) ((dpy)->bitmap_pad) +#define ImageByteOrder(dpy) ((dpy)->byte_order) +#define NextRequest(dpy) ((dpy)->request + 1) +#define LastKnownRequestProcessed(dpy) ((dpy)->last_request_read) + +/* macros for screen oriented applications (toolkit) */ +#define ScreenOfDisplay(dpy, scr)(&((dpy)->screens[(scr)])) +#define DefaultScreenOfDisplay(dpy) (&((dpy)->screens[(dpy)->default_screen])) +#define DisplayOfScreen(s) ((s)->display) +#define RootWindowOfScreen(s) ((s)->root) +#define BlackPixelOfScreen(s) ((s)->black_pixel) +#define WhitePixelOfScreen(s) ((s)->white_pixel) +#define DefaultColormapOfScreen(s)((s)->cmap) +#define DefaultDepthOfScreen(s) ((s)->root_depth) +#define DefaultGCOfScreen(s) ((s)->default_gc) +#define DefaultVisualOfScreen(s)((s)->root_visual) +#define WidthOfScreen(s) ((s)->width) +#define HeightOfScreen(s) ((s)->height) +#define WidthMMOfScreen(s) ((s)->mwidth) +#define HeightMMOfScreen(s) ((s)->mheight) +#define PlanesOfScreen(s) ((s)->root_depth) +#define CellsOfScreen(s) (DefaultVisualOfScreen((s))->map_entries) +#define MinCmapsOfScreen(s) ((s)->min_maps) +#define MaxCmapsOfScreen(s) ((s)->max_maps) +#define DoesSaveUnders(s) ((s)->save_unders) +#define DoesBackingStore(s) ((s)->backing_store) +#define EventMaskOfScreen(s) ((s)->root_input_mask) + +/* + * Extensions need a way to hang private data on some structures. + */ +typedef struct _XExtData { + int number; /* number returned by XRegisterExtension */ + struct _XExtData *next; /* next item on list of data for structure */ + int (*free_private)(); /* called to free private storage */ + XPointer private_data; /* data private to this extension. */ +} XExtData; + +/* + * This file contains structures used by the extension mechanism. + */ +typedef struct { /* public to extension, cannot be changed */ + int extension; /* extension number */ + int major_opcode; /* major op-code assigned by server */ + int first_event; /* first event number for the extension */ + int first_error; /* first error number for the extension */ +} XExtCodes; + +/* + * Data structure for retrieving info about pixmap formats. + */ + +typedef struct { + int depth; + int bits_per_pixel; + int scanline_pad; +} XPixmapFormatValues; + + +/* + * Data structure for setting graphics context. + */ +typedef struct { + int function; /* logical operation */ + unsigned long plane_mask;/* plane mask */ + unsigned long foreground;/* foreground pixel */ + unsigned long background;/* background pixel */ + int line_width; /* line width */ + int line_style; /* LineSolid, LineOnOffDash, LineDoubleDash */ + int cap_style; /* CapNotLast, CapButt, + CapRound, CapProjecting */ + int join_style; /* JoinMiter, JoinRound, JoinBevel */ + int fill_style; /* FillSolid, FillTiled, + FillStippled, FillOpaeueStippled */ + int fill_rule; /* EvenOddRule, WindingRule */ + int arc_mode; /* ArcChord, ArcPieSlice */ + Pixmap tile; /* tile pixmap for tiling operations */ + Pixmap stipple; /* stipple 1 plane pixmap for stipping */ + int ts_x_origin; /* offset for tile or stipple operations */ + int ts_y_origin; + Font font; /* default text font for text operations */ + int subwindow_mode; /* ClipByChildren, IncludeInferiors */ + Bool graphics_exposures;/* boolean, should exposures be generated */ + int clip_x_origin; /* origin for clipping */ + int clip_y_origin; + Pixmap clip_mask; /* bitmap clipping; other calls for rects */ + int dash_offset; /* patterned/dashed line information */ + char dashes; +} XGCValues; + +/* + * Graphics context. The contents of this structure are implementation + * dependent. A GC should be treated as opaque by application code. + */ + +typedef XGCValues *GC; + +/* + * Visual structure; contains information about colormapping possible. + */ +typedef struct { + XExtData *ext_data; /* hook for extension to hang data */ + VisualID visualid; /* visual id of this visual */ +#if defined(__cplusplus) || defined(c_plusplus) + int c_class; /* C++ class of screen (monochrome, etc.) */ +#else + int class; /* class of screen (monochrome, etc.) */ +#endif + unsigned long red_mask, green_mask, blue_mask; /* mask values */ + int bits_per_rgb; /* log base 2 of distinct color values */ + int map_entries; /* color map entries */ +} Visual; + +/* + * Depth structure; contains information for each possible depth. + */ +typedef struct { + int depth; /* this depth (Z) of the depth */ + int nvisuals; /* number of Visual types at this depth */ + Visual *visuals; /* list of visuals possible at this depth */ +} Depth; + +/* + * Information about the screen. The contents of this structure are + * implementation dependent. A Screen should be treated as opaque + * by application code. + */ +typedef struct { + XExtData *ext_data; /* hook for extension to hang data */ + struct _XDisplay *display;/* back pointer to display structure */ + Window root; /* Root window id. */ + int width, height; /* width and height of screen */ + int mwidth, mheight; /* width and height of in millimeters */ + int ndepths; /* number of depths possible */ + Depth *depths; /* list of allowable depths on the screen */ + int root_depth; /* bits per pixel */ + Visual *root_visual; /* root visual */ + GC default_gc; /* GC for the root root visual */ + Colormap cmap; /* default color map */ + unsigned long white_pixel; + unsigned long black_pixel; /* White and Black pixel values */ + int max_maps, min_maps; /* max and min color maps */ + int backing_store; /* Never, WhenMapped, Always */ + Bool save_unders; + long root_input_mask; /* initial root input mask */ +} Screen; + +/* + * Format structure; describes ZFormat data the screen will understand. + */ +typedef struct { + XExtData *ext_data; /* hook for extension to hang data */ + int depth; /* depth of this image format */ + int bits_per_pixel; /* bits/pixel at this depth */ + int scanline_pad; /* scanline must padded to this multiple */ +} ScreenFormat; + +/* + * Data structure for setting window attributes. + */ +typedef struct { + Pixmap background_pixmap; /* background or None or ParentRelative */ + unsigned long background_pixel; /* background pixel */ + Pixmap border_pixmap; /* border of the window */ + unsigned long border_pixel; /* border pixel value */ + int bit_gravity; /* one of bit gravity values */ + int win_gravity; /* one of the window gravity values */ + int backing_store; /* NotUseful, WhenMapped, Always */ + unsigned long backing_planes;/* planes to be preseved if possible */ + unsigned long backing_pixel;/* value to use in restoring planes */ + Bool save_under; /* should bits under be saved? (popups) */ + long event_mask; /* set of events that should be saved */ + long do_not_propagate_mask; /* set of events that should not propagate */ + Bool override_redirect; /* boolean value for override-redirect */ + Colormap colormap; /* color map to be associated with window */ + Cursor cursor; /* cursor to be displayed (or None) */ +} XSetWindowAttributes; + +typedef struct { + int x, y; /* location of window */ + int width, height; /* width and height of window */ + int border_width; /* border width of window */ + int depth; /* depth of window */ + Visual *visual; /* the associated visual structure */ + Window root; /* root of screen containing window */ +#if defined(__cplusplus) || defined(c_plusplus) + int c_class; /* C++ InputOutput, InputOnly*/ +#else + int class; /* InputOutput, InputOnly*/ +#endif + int bit_gravity; /* one of bit gravity values */ + int win_gravity; /* one of the window gravity values */ + int backing_store; /* NotUseful, WhenMapped, Always */ + unsigned long backing_planes;/* planes to be preserved if possible */ + unsigned long backing_pixel;/* value to be used when restoring planes */ + Bool save_under; /* boolean, should bits under be saved? */ + Colormap colormap; /* color map to be associated with window */ + Bool map_installed; /* boolean, is color map currently installed*/ + int map_state; /* IsUnmapped, IsUnviewable, IsViewable */ + long all_event_masks; /* set of events all people have interest in*/ + long your_event_mask; /* my event mask */ + long do_not_propagate_mask; /* set of events that should not propagate */ + Bool override_redirect; /* boolean value for override-redirect */ + Screen *screen; /* back pointer to correct screen */ +} XWindowAttributes; + +/* + * Data structure for host setting; getting routines. + * + */ + +typedef struct { + int family; /* for example FamilyInternet */ + int length; /* length of address, in bytes */ + char *address; /* pointer to where to find the bytes */ +} XHostAddress; + +/* + * Data structure for "image" data, used by image manipulation routines. + */ +typedef struct _XImage { + int width, height; /* size of image */ + int xoffset; /* number of pixels offset in X direction */ + int format; /* XYBitmap, XYPixmap, ZPixmap */ + char *data; /* pointer to image data */ + int byte_order; /* data byte order, LSBFirst, MSBFirst */ + int bitmap_unit; /* quant. of scanline 8, 16, 32 */ + int bitmap_bit_order; /* LSBFirst, MSBFirst */ + int bitmap_pad; /* 8, 16, 32 either XY or ZPixmap */ + int depth; /* depth of image */ + int bytes_per_line; /* accelarator to next line */ + int bits_per_pixel; /* bits per pixel (ZPixmap) */ + unsigned long red_mask; /* bits in z arrangment */ + unsigned long green_mask; + unsigned long blue_mask; + XPointer obdata; /* hook for the object routines to hang on */ + struct funcs { /* image manipulation routines */ + struct _XImage *(*create_image)(); +#if NeedFunctionPrototypes + int (*destroy_image) (struct _XImage *); + unsigned long (*get_pixel) (struct _XImage *, int, int); + int (*put_pixel) (struct _XImage *, int, int, unsigned long); + struct _XImage *(*sub_image)(struct _XImage *, int, int, unsigned int, unsigned int); + int (*add_pixel) (struct _XImage *, long); +#else + int (*destroy_image)(); + unsigned long (*get_pixel)(); + int (*put_pixel)(); + struct _XImage *(*sub_image)(); + int (*add_pixel)(); +#endif + } f; +} XImage; + +/* + * Data structure for XReconfigureWindow + */ +typedef struct { + int x, y; + int width, height; + int border_width; + Window sibling; + int stack_mode; +} XWindowChanges; + +/* + * Data structure used by color operations + */ +typedef struct { + unsigned long pixel; + unsigned short red, green, blue; + char flags; /* do_red, do_green, do_blue */ + char pad; +} XColor; + +/* + * Data structures for graphics operations. On most machines, these are + * congruent with the wire protocol structures, so reformatting the data + * can be avoided on these architectures. + */ +typedef struct { + short x1, y1, x2, y2; +} XSegment; + +typedef struct { + short x, y; +} XPoint; + +typedef struct { + short x, y; + unsigned short width, height; +} XRectangle; + +typedef struct { + short x, y; + unsigned short width, height; + short angle1, angle2; +} XArc; + + +/* Data structure for XChangeKeyboardControl */ + +typedef struct { + int key_click_percent; + int bell_percent; + int bell_pitch; + int bell_duration; + int led; + int led_mode; + int key; + int auto_repeat_mode; /* On, Off, Default */ +} XKeyboardControl; + +/* Data structure for XGetKeyboardControl */ + +typedef struct { + int key_click_percent; + int bell_percent; + unsigned int bell_pitch, bell_duration; + unsigned long led_mask; + int global_auto_repeat; + char auto_repeats[32]; +} XKeyboardState; + +/* Data structure for XGetMotionEvents. */ + +typedef struct { + Time time; + short x, y; +} XTimeCoord; + +/* Data structure for X{Set,Get}ModifierMapping */ + +typedef struct { + int max_keypermod; /* The server's max # of keys per modifier */ + KeyCode *modifiermap; /* An 8 by max_keypermod array of modifiers */ +} XModifierKeymap; + + +/* + * Display datatype maintaining display specific data. + * The contents of this structure are implementation dependent. + * A Display should be treated as opaque by application code. + */ +typedef struct _XDisplay { + XExtData *ext_data; /* hook for extension to hang data */ + struct _XFreeFuncs *free_funcs; /* internal free functions */ + int fd; /* Network socket. */ + int conn_checker; /* ugly thing used by _XEventsQueued */ + int proto_major_version;/* maj. version of server's X protocol */ + int proto_minor_version;/* minor version of servers X protocol */ + char *vendor; /* vendor of the server hardware */ + XID resource_base; /* resource ID base */ + XID resource_mask; /* resource ID mask bits */ + XID resource_id; /* allocator current ID */ + int resource_shift; /* allocator shift to correct bits */ + XID (*resource_alloc)(); /* allocator function */ + int byte_order; /* screen byte order, LSBFirst, MSBFirst */ + int bitmap_unit; /* padding and data requirements */ + int bitmap_pad; /* padding requirements on bitmaps */ + int bitmap_bit_order; /* LeastSignificant or MostSignificant */ + int nformats; /* number of pixmap formats in list */ + ScreenFormat *pixmap_format; /* pixmap format list */ + int vnumber; /* Xlib's X protocol version number. */ + int release; /* release of the server */ + struct _XSQEvent *head, *tail; /* Input event queue. */ + int qlen; /* Length of input event queue */ + unsigned long last_request_read; /* seq number of last event read */ + unsigned long request; /* sequence number of last request. */ + char *last_req; /* beginning of last request, or dummy */ + char *buffer; /* Output buffer starting address. */ + char *bufptr; /* Output buffer index pointer. */ + char *bufmax; /* Output buffer maximum+1 address. */ + unsigned max_request_size; /* maximum number 32 bit words in request*/ + struct _XrmHashBucketRec *db; + int (*synchandler)(); /* Synchronization handler */ + char *display_name; /* "host:display" string used on this connect*/ + int default_screen; /* default screen for operations */ + int nscreens; /* number of screens on this server*/ + Screen *screens; /* pointer to list of screens */ + unsigned long motion_buffer; /* size of motion buffer */ + unsigned long flags; /* internal connection flags */ + int min_keycode; /* minimum defined keycode */ + int max_keycode; /* maximum defined keycode */ + KeySym *keysyms; /* This server's keysyms */ + XModifierKeymap *modifiermap; /* This server's modifier keymap */ + int keysyms_per_keycode;/* number of rows */ + char *xdefaults; /* contents of defaults from server */ + char *scratch_buffer; /* place to hang scratch buffer */ + unsigned long scratch_length; /* length of scratch buffer */ + int ext_number; /* extension number on this display */ + struct _XExten *ext_procs; /* extensions initialized on this display */ + /* + * the following can be fixed size, as the protocol defines how + * much address space is available. + * While this could be done using the extension vector, there + * may be MANY events processed, so a search through the extension + * list to find the right procedure for each event might be + * expensive if many extensions are being used. + */ + Bool (*event_vec[128])(); /* vector for wire to event */ + int (*wire_vec[128])(); /* vector for event to wire */ + KeySym lock_meaning; /* for XLookupString */ + struct _XLockInfo *lock; /* multi-thread state, display lock */ + struct _XInternalAsync *async_handlers; /* for internal async */ + unsigned long bigreq_size; /* max size of big requests */ + struct _XLockPtrs *lock_fns; /* pointers to threads functions */ + /* things above this line should not move, for binary compatibility */ + struct _XKeytrans *key_bindings; /* for XLookupString */ + Font cursor_font; /* for XCreateFontCursor */ + struct _XDisplayAtoms *atoms; /* for XInternAtom */ + unsigned int mode_switch; /* keyboard group modifiers */ + struct _XContextDB *context_db; /* context database */ + Bool (**error_vec)(); /* vector for wire to error */ + /* + * Xcms information + */ + struct { + XPointer defaultCCCs; /* pointer to an array of default XcmsCCC */ + XPointer clientCmaps; /* pointer to linked list of XcmsCmapRec */ + XPointer perVisualIntensityMaps; + /* linked list of XcmsIntensityMap */ + } cms; + struct _XIMFilter *im_filters; + struct _XSQEvent *qfree; /* unallocated event queue elements */ + unsigned long next_event_serial_num; /* inserted into next queue elt */ + int (*savedsynchandler)(); /* user synchandler when Xlib usurps */ +} Display; + +#if NeedFunctionPrototypes /* prototypes require event type definitions */ +#undef _XEVENT_ +#endif +#ifndef _XEVENT_ + +#define XMaxTransChars 4 + +/* + * Definitions of specific events. + */ +typedef struct { + int type; /* of event */ + unsigned long serial; /* # of last request processed by server */ + Bool send_event; /* true if this came from a SendEvent request */ + Display *display; /* Display the event was read from */ + Window window; /* "event" window it is reported relative to */ + Window root; /* root window that the event occured on */ + Window subwindow; /* child window */ + Time time; /* milliseconds */ + int x, y; /* pointer x, y coordinates in event window */ + int x_root, y_root; /* coordinates relative to root */ + unsigned int state; /* key or button mask */ + unsigned int keycode; /* detail */ + Bool same_screen; /* same screen flag */ + char trans_chars[XMaxTransChars]; + /* translated characters */ + int nbytes; +} XKeyEvent; +typedef XKeyEvent XKeyPressedEvent; +typedef XKeyEvent XKeyReleasedEvent; + +typedef struct { + int type; /* of event */ + unsigned long serial; /* # of last request processed by server */ + Bool send_event; /* true if this came from a SendEvent request */ + Display *display; /* Display the event was read from */ + Window window; /* "event" window it is reported relative to */ + Window root; /* root window that the event occured on */ + Window subwindow; /* child window */ + Time time; /* milliseconds */ + int x, y; /* pointer x, y coordinates in event window */ + int x_root, y_root; /* coordinates relative to root */ + unsigned int state; /* key or button mask */ + unsigned int button; /* detail */ + Bool same_screen; /* same screen flag */ +} XButtonEvent; +typedef XButtonEvent XButtonPressedEvent; +typedef XButtonEvent XButtonReleasedEvent; + +typedef struct { + int type; /* of event */ + unsigned long serial; /* # of last request processed by server */ + Bool send_event; /* true if this came from a SendEvent request */ + Display *display; /* Display the event was read from */ + Window window; /* "event" window reported relative to */ + Window root; /* root window that the event occured on */ + Window subwindow; /* child window */ + Time time; /* milliseconds */ + int x, y; /* pointer x, y coordinates in event window */ + int x_root, y_root; /* coordinates relative to root */ + unsigned int state; /* key or button mask */ + char is_hint; /* detail */ + Bool same_screen; /* same screen flag */ +} XMotionEvent; +typedef XMotionEvent XPointerMovedEvent; + +typedef struct { + int type; /* of event */ + unsigned long serial; /* # of last request processed by server */ + Bool send_event; /* true if this came from a SendEvent request */ + Display *display; /* Display the event was read from */ + Window window; /* "event" window reported relative to */ + Window root; /* root window that the event occured on */ + Window subwindow; /* child window */ + Time time; /* milliseconds */ + int x, y; /* pointer x, y coordinates in event window */ + int x_root, y_root; /* coordinates relative to root */ + int mode; /* NotifyNormal, NotifyGrab, NotifyUngrab */ + int detail; + /* + * NotifyAncestor, NotifyVirtual, NotifyInferior, + * NotifyNonlinear,NotifyNonlinearVirtual + */ + Bool same_screen; /* same screen flag */ + Bool focus; /* boolean focus */ + unsigned int state; /* key or button mask */ +} XCrossingEvent; +typedef XCrossingEvent XEnterWindowEvent; +typedef XCrossingEvent XLeaveWindowEvent; + +typedef struct { + int type; /* FocusIn or FocusOut */ + unsigned long serial; /* # of last request processed by server */ + Bool send_event; /* true if this came from a SendEvent request */ + Display *display; /* Display the event was read from */ + Window window; /* window of event */ + int mode; /* NotifyNormal, NotifyGrab, NotifyUngrab */ + int detail; + /* + * NotifyAncestor, NotifyVirtual, NotifyInferior, + * NotifyNonlinear,NotifyNonlinearVirtual, NotifyPointer, + * NotifyPointerRoot, NotifyDetailNone + */ +} XFocusChangeEvent; +typedef XFocusChangeEvent XFocusInEvent; +typedef XFocusChangeEvent XFocusOutEvent; + +/* generated on EnterWindow and FocusIn when KeyMapState selected */ +typedef struct { + int type; + unsigned long serial; /* # of last request processed by server */ + Bool send_event; /* true if this came from a SendEvent request */ + Display *display; /* Display the event was read from */ + Window window; + char key_vector[32]; +} XKeymapEvent; + +typedef struct { + int type; + unsigned long serial; /* # of last request processed by server */ + Bool send_event; /* true if this came from a SendEvent request */ + Display *display; /* Display the event was read from */ + Window window; + int x, y; + int width, height; + int count; /* if non-zero, at least this many more */ +} XExposeEvent; + +typedef struct { + int type; + unsigned long serial; /* # of last request processed by server */ + Bool send_event; /* true if this came from a SendEvent request */ + Display *display; /* Display the event was read from */ + Drawable drawable; + int x, y; + int width, height; + int count; /* if non-zero, at least this many more */ + int major_code; /* core is CopyArea or CopyPlane */ + int minor_code; /* not defined in the core */ +} XGraphicsExposeEvent; + +typedef struct { + int type; + unsigned long serial; /* # of last request processed by server */ + Bool send_event; /* true if this came from a SendEvent request */ + Display *display; /* Display the event was read from */ + Drawable drawable; + int major_code; /* core is CopyArea or CopyPlane */ + int minor_code; /* not defined in the core */ +} XNoExposeEvent; + +typedef struct { + int type; + unsigned long serial; /* # of last request processed by server */ + Bool send_event; /* true if this came from a SendEvent request */ + Display *display; /* Display the event was read from */ + Window window; + int state; /* Visibility state */ +} XVisibilityEvent; + +typedef struct { + int type; + unsigned long serial; /* # of last request processed by server */ + Bool send_event; /* true if this came from a SendEvent request */ + Display *display; /* Display the event was read from */ + Window parent; /* parent of the window */ + Window window; /* window id of window created */ + int x, y; /* window location */ + int width, height; /* size of window */ + int border_width; /* border width */ + Bool override_redirect; /* creation should be overridden */ +} XCreateWindowEvent; + +typedef struct { + int type; + unsigned long serial; /* # of last request processed by server */ + Bool send_event; /* true if this came from a SendEvent request */ + Display *display; /* Display the event was read from */ + Window event; + Window window; +} XDestroyWindowEvent; + +typedef struct { + int type; + unsigned long serial; /* # of last request processed by server */ + Bool send_event; /* true if this came from a SendEvent request */ + Display *display; /* Display the event was read from */ + Window event; + Window window; + Bool from_configure; +} XUnmapEvent; + +typedef struct { + int type; + unsigned long serial; /* # of last request processed by server */ + Bool send_event; /* true if this came from a SendEvent request */ + Display *display; /* Display the event was read from */ + Window event; + Window window; + Bool override_redirect; /* boolean, is override set... */ +} XMapEvent; + +typedef struct { + int type; + unsigned long serial; /* # of last request processed by server */ + Bool send_event; /* true if this came from a SendEvent request */ + Display *display; /* Display the event was read from */ + Window parent; + Window window; +} XMapRequestEvent; + +typedef struct { + int type; + unsigned long serial; /* # of last request processed by server */ + Bool send_event; /* true if this came from a SendEvent request */ + Display *display; /* Display the event was read from */ + Window event; + Window window; + Window parent; + int x, y; + Bool override_redirect; +} XReparentEvent; + +typedef struct { + int type; + unsigned long serial; /* # of last request processed by server */ + Bool send_event; /* true if this came from a SendEvent request */ + Display *display; /* Display the event was read from */ + Window event; + Window window; + int x, y; + int width, height; + int border_width; + Window above; + Bool override_redirect; +} XConfigureEvent; + +typedef struct { + int type; + unsigned long serial; /* # of last request processed by server */ + Bool send_event; /* true if this came from a SendEvent request */ + Display *display; /* Display the event was read from */ + Window event; + Window window; + int x, y; +} XGravityEvent; + +typedef struct { + int type; + unsigned long serial; /* # of last request processed by server */ + Bool send_event; /* true if this came from a SendEvent request */ + Display *display; /* Display the event was read from */ + Window window; + int width, height; +} XResizeRequestEvent; + +typedef struct { + int type; + unsigned long serial; /* # of last request processed by server */ + Bool send_event; /* true if this came from a SendEvent request */ + Display *display; /* Display the event was read from */ + Window parent; + Window window; + int x, y; + int width, height; + int border_width; + Window above; + int detail; /* Above, Below, TopIf, BottomIf, Opposite */ + unsigned long value_mask; +} XConfigureRequestEvent; + +typedef struct { + int type; + unsigned long serial; /* # of last request processed by server */ + Bool send_event; /* true if this came from a SendEvent request */ + Display *display; /* Display the event was read from */ + Window event; + Window window; + int place; /* PlaceOnTop, PlaceOnBottom */ +} XCirculateEvent; + +typedef struct { + int type; + unsigned long serial; /* # of last request processed by server */ + Bool send_event; /* true if this came from a SendEvent request */ + Display *display; /* Display the event was read from */ + Window parent; + Window window; + int place; /* PlaceOnTop, PlaceOnBottom */ +} XCirculateRequestEvent; + +typedef struct { + int type; + unsigned long serial; /* # of last request processed by server */ + Bool send_event; /* true if this came from a SendEvent request */ + Display *display; /* Display the event was read from */ + Window window; + Atom atom; + Time time; + int state; /* NewValue, Deleted */ +} XPropertyEvent; + +typedef struct { + int type; + unsigned long serial; /* # of last request processed by server */ + Bool send_event; /* true if this came from a SendEvent request */ + Display *display; /* Display the event was read from */ + Window window; + Atom selection; + Time time; +} XSelectionClearEvent; + +typedef struct { + int type; + unsigned long serial; /* # of last request processed by server */ + Bool send_event; /* true if this came from a SendEvent request */ + Display *display; /* Display the event was read from */ + Window owner; + Window requestor; + Atom selection; + Atom target; + Atom property; + Time time; +} XSelectionRequestEvent; + +typedef struct { + int type; + unsigned long serial; /* # of last request processed by server */ + Bool send_event; /* true if this came from a SendEvent request */ + Display *display; /* Display the event was read from */ + Window requestor; + Atom selection; + Atom target; + Atom property; /* ATOM or None */ + Time time; +} XSelectionEvent; + +typedef struct { + int type; + unsigned long serial; /* # of last request processed by server */ + Bool send_event; /* true if this came from a SendEvent request */ + Display *display; /* Display the event was read from */ + Window window; + Colormap colormap; /* COLORMAP or None */ +#if defined(__cplusplus) || defined(c_plusplus) + Bool c_new; /* C++ */ +#else + Bool new; +#endif + int state; /* ColormapInstalled, ColormapUninstalled */ +} XColormapEvent; + +typedef struct { + int type; + unsigned long serial; /* # of last request processed by server */ + Bool send_event; /* true if this came from a SendEvent request */ + Display *display; /* Display the event was read from */ + Window window; + Atom message_type; + int format; + union { + char b[20]; + short s[10]; + long l[5]; + } data; +} XClientMessageEvent; + +typedef struct { + int type; + unsigned long serial; /* # of last request processed by server */ + Bool send_event; /* true if this came from a SendEvent request */ + Display *display; /* Display the event was read from */ + Window window; /* unused */ + int request; /* one of MappingModifier, MappingKeyboard, + MappingPointer */ + int first_keycode; /* first keycode */ + int count; /* defines range of change w. first_keycode*/ +} XMappingEvent; + +typedef struct { + int type; + Display *display; /* Display the event was read from */ + XID resourceid; /* resource id */ + unsigned long serial; /* serial number of failed request */ + unsigned char error_code; /* error code of failed request */ + unsigned char request_code; /* Major op-code of failed request */ + unsigned char minor_code; /* Minor op-code of failed request */ +} XErrorEvent; + +typedef struct { + int type; + unsigned long serial; /* # of last request processed by server */ + Bool send_event; /* true if this came from a SendEvent request */ + Display *display;/* Display the event was read from */ + Window window; /* window on which event was requested in event mask */ +} XAnyEvent; + +/* + * this union is defined so Xlib can always use the same sized + * event structure internally, to avoid memory fragmentation. + */ +typedef union _XEvent { + int type; /* must not be changed; first element */ + XAnyEvent xany; + XKeyEvent xkey; + XButtonEvent xbutton; + XMotionEvent xmotion; + XCrossingEvent xcrossing; + XFocusChangeEvent xfocus; + XExposeEvent xexpose; + XGraphicsExposeEvent xgraphicsexpose; + XNoExposeEvent xnoexpose; + XVisibilityEvent xvisibility; + XCreateWindowEvent xcreatewindow; + XDestroyWindowEvent xdestroywindow; + XUnmapEvent xunmap; + XMapEvent xmap; + XMapRequestEvent xmaprequest; + XReparentEvent xreparent; + XConfigureEvent xconfigure; + XGravityEvent xgravity; + XResizeRequestEvent xresizerequest; + XConfigureRequestEvent xconfigurerequest; + XCirculateEvent xcirculate; + XCirculateRequestEvent xcirculaterequest; + XPropertyEvent xproperty; + XSelectionClearEvent xselectionclear; + XSelectionRequestEvent xselectionrequest; + XSelectionEvent xselection; + XColormapEvent xcolormap; + XClientMessageEvent xclient; + XMappingEvent xmapping; + XErrorEvent xerror; + XKeymapEvent xkeymap; + long pad[24]; +} XEvent; +#endif + +#define XAllocID(dpy) ((*(dpy)->resource_alloc)((dpy))) + +/* + * per character font metric information. + */ +typedef struct { + short lbearing; /* origin to left edge of raster */ + short rbearing; /* origin to right edge of raster */ + short width; /* advance to next char's origin */ + short ascent; /* baseline to top edge of raster */ + short descent; /* baseline to bottom edge of raster */ + unsigned short attributes; /* per char flags (not predefined) */ +} XCharStruct; + +/* + * To allow arbitrary information with fonts, there are additional properties + * returned. + */ +typedef struct { + Atom name; + unsigned long card32; +} XFontProp; + +typedef struct { + XExtData *ext_data; /* hook for extension to hang data */ + Font fid; /* Font id for this font */ + unsigned direction; /* hint about direction the font is painted */ + unsigned min_char_or_byte2;/* first character */ + unsigned max_char_or_byte2;/* last character */ + unsigned min_byte1; /* first row that exists */ + unsigned max_byte1; /* last row that exists */ + Bool all_chars_exist;/* flag if all characters have non-zero size*/ + unsigned default_char; /* char to print for undefined character */ + int n_properties; /* how many properties there are */ + XFontProp *properties; /* pointer to array of additional properties*/ + XCharStruct min_bounds; /* minimum bounds over all existing char*/ + XCharStruct max_bounds; /* maximum bounds over all existing char*/ + XCharStruct *per_char; /* first_char to last_char information */ + int ascent; /* log. extent above baseline for spacing */ + int descent; /* log. descent below baseline for spacing */ +} XFontStruct; + +/* + * PolyText routines take these as arguments. + */ +typedef struct { + char *chars; /* pointer to string */ + int nchars; /* number of characters */ + int delta; /* delta between strings */ + Font font; /* font to print it in, None don't change */ +} XTextItem; + +typedef struct { /* normal 16 bit characters are two bytes */ + unsigned char byte1; + unsigned char byte2; +} XChar2b; + +typedef struct { + XChar2b *chars; /* two byte characters */ + int nchars; /* number of characters */ + int delta; /* delta between strings */ + Font font; /* font to print it in, None don't change */ +} XTextItem16; + + +typedef union { Display *display; + GC gc; + Visual *visual; + Screen *screen; + ScreenFormat *pixmap_format; + XFontStruct *font; } XEDataObject; + +typedef struct { + XRectangle max_ink_extent; + XRectangle max_logical_extent; +} XFontSetExtents; + +typedef struct _XFontSet *XFontSet; + +typedef struct { + char *chars; + int nchars; + int delta; + XFontSet font_set; +} XmbTextItem; + +typedef struct { + wchar_t *chars; + int nchars; + int delta; + XFontSet font_set; +} XwcTextItem; + +typedef void (*XIMProc)(); + +typedef struct _XIM *XIM; +typedef struct _XIC *XIC; + +typedef unsigned long XIMStyle; + +typedef struct { + unsigned short count_styles; + XIMStyle *supported_styles; +} XIMStyles; + +#define XIMPreeditArea 0x0001L +#define XIMPreeditCallbacks 0x0002L +#define XIMPreeditPosition 0x0004L +#define XIMPreeditNothing 0x0008L +#define XIMPreeditNone 0x0010L +#define XIMStatusArea 0x0100L +#define XIMStatusCallbacks 0x0200L +#define XIMStatusNothing 0x0400L +#define XIMStatusNone 0x0800L + +#define XNVaNestedList "XNVaNestedList" +#define XNClientWindow "clientWindow" +#define XNInputStyle "inputStyle" +#define XNFocusWindow "focusWindow" +#define XNResourceName "resourceName" +#define XNResourceClass "resourceClass" +#define XNGeometryCallback "geometryCallback" +#define XNFilterEvents "filterEvents" +#define XNPreeditStartCallback "preeditStartCallback" +#define XNPreeditDoneCallback "preeditDoneCallback" +#define XNPreeditDrawCallback "preeditDrawCallback" +#define XNPreeditCaretCallback "preeditCaretCallback" +#define XNPreeditAttributes "preeditAttributes" +#define XNStatusStartCallback "statusStartCallback" +#define XNStatusDoneCallback "statusDoneCallback" +#define XNStatusDrawCallback "statusDrawCallback" +#define XNStatusAttributes "statusAttributes" +#define XNArea "area" +#define XNAreaNeeded "areaNeeded" +#define XNSpotLocation "spotLocation" +#define XNColormap "colorMap" +#define XNStdColormap "stdColorMap" +#define XNForeground "foreground" +#define XNBackground "background" +#define XNBackgroundPixmap "backgroundPixmap" +#define XNFontSet "fontSet" +#define XNLineSpace "lineSpace" +#define XNCursor "cursor" + +#define XBufferOverflow -1 +#define XLookupNone 1 +#define XLookupChars 2 +#define XLookupKeySym 3 +#define XLookupBoth 4 + +#if NeedFunctionPrototypes +typedef void *XVaNestedList; +#else +typedef XPointer XVaNestedList; +#endif + +typedef struct { + XPointer client_data; + XIMProc callback; +} XIMCallback; + +typedef unsigned long XIMFeedback; + +#define XIMReverse 1 +#define XIMUnderline (1<<1) +#define XIMHighlight (1<<2) +#define XIMPrimary (1<<5) +#define XIMSecondary (1<<6) +#define XIMTertiary (1<<7) + +typedef struct _XIMText { + unsigned short length; + XIMFeedback *feedback; + Bool encoding_is_wchar; + union { + char *multi_byte; + wchar_t *wide_char; + } string; +} XIMText; + +typedef struct _XIMPreeditDrawCallbackStruct { + int caret; /* Cursor offset within pre-edit string */ + int chg_first; /* Starting change position */ + int chg_length; /* Length of the change in character count */ + XIMText *text; +} XIMPreeditDrawCallbackStruct; + +typedef enum { + XIMForwardChar, XIMBackwardChar, + XIMForwardWord, XIMBackwardWord, + XIMCaretUp, XIMCaretDown, + XIMNextLine, XIMPreviousLine, + XIMLineStart, XIMLineEnd, + XIMAbsolutePosition, + XIMDontChange +} XIMCaretDirection; + +typedef enum { + XIMIsInvisible, /* Disable caret feedback */ + XIMIsPrimary, /* UI defined caret feedback */ + XIMIsSecondary /* UI defined caret feedback */ +} XIMCaretStyle; + +typedef struct _XIMPreeditCaretCallbackStruct { + int position; /* Caret offset within pre-edit string */ + XIMCaretDirection direction; /* Caret moves direction */ + XIMCaretStyle style; /* Feedback of the caret */ +} XIMPreeditCaretCallbackStruct; + +typedef enum { + XIMTextType, + XIMBitmapType +} XIMStatusDataType; + +typedef struct _XIMStatusDrawCallbackStruct { + XIMStatusDataType type; + union { + XIMText *text; + Pixmap bitmap; + } data; +} XIMStatusDrawCallbackStruct; + +typedef int (*XErrorHandler) ( /* WARNING, this type not in Xlib spec */ +#if NeedFunctionPrototypes + Display* /* display */, + XErrorEvent* /* error_event */ +#endif +); + +_XFUNCPROTOBEGIN + + + +#include "../../../pTk/tkIntXlibDecls.h" + +_XFUNCPROTOEND + +#if defined(MAC_TCL) || defined(MAC_OSX_TK) +# undef Cursor +#endif + +#endif /* _XLIB_H_ */ diff --git a/Master/tlpkg/tlperl/lib/Tk/X11/Xutil.h b/Master/tlpkg/tlperl/lib/Tk/X11/Xutil.h new file mode 100644 index 00000000000..af44e0e9c2e --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/X11/Xutil.h @@ -0,0 +1,855 @@ +/* $XConsortium: Xutil.h,v 11.73 91/07/30 16:21:37 rws Exp $ */ + +/*********************************************************** +Copyright 1987 by Digital Equipment Corporation, Maynard, Massachusetts, +and the Massachusetts Institute of Technology, Cambridge, Massachusetts. + + All Rights Reserved + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, +provided that the above copyright notice appear in all copies and that +both that copyright notice and this permission notice appear in +supporting documentation, and that the names of Digital or MIT not be +used in advertising or publicity pertaining to distribution of the +software without specific, written prior permission. + +DIGITAL DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING +ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL +DIGITAL BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR +ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, +WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, +ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS +SOFTWARE. + +******************************************************************/ + +#ifndef _XUTIL_H_ +#define _XUTIL_H_ + +/* You must include <X11/Xlib.h> before including this file */ + +#if defined(MAC_TCL) || defined(MAC_OSX_TK) +# define Region XRegion +#endif + +/* + * Bitmask returned by XParseGeometry(). Each bit tells if the corresponding + * value (x, y, width, height) was found in the parsed string. + */ +#define NoValue 0x0000 +#define XValue 0x0001 +#define YValue 0x0002 +#define WidthValue 0x0004 +#define HeightValue 0x0008 +#define AllValues 0x000F +#define XNegative 0x0010 +#define YNegative 0x0020 + +/* + * new version containing base_width, base_height, and win_gravity fields; + * used with WM_NORMAL_HINTS. + */ +typedef struct { + long flags; /* marks which fields in this structure are defined */ + int x, y; /* obsolete for new window mgrs, but clients */ + int width, height; /* should set so old wm's don't mess up */ + int min_width, min_height; + int max_width, max_height; + int width_inc, height_inc; + struct { + int x; /* numerator */ + int y; /* denominator */ + } min_aspect, max_aspect; + int base_width, base_height; /* added by ICCCM version 1 */ + int win_gravity; /* added by ICCCM version 1 */ +} XSizeHints; + +/* + * The next block of definitions are for window manager properties that + * clients and applications use for communication. + */ + +/* flags argument in size hints */ +#define USPosition (1L << 0) /* user specified x, y */ +#define USSize (1L << 1) /* user specified width, height */ + +#define PPosition (1L << 2) /* program specified position */ +#define PSize (1L << 3) /* program specified size */ +#define PMinSize (1L << 4) /* program specified minimum size */ +#define PMaxSize (1L << 5) /* program specified maximum size */ +#define PResizeInc (1L << 6) /* program specified resize increments */ +#define PAspect (1L << 7) /* program specified min and max aspect ratios */ +#define PBaseSize (1L << 8) /* program specified base for incrementing */ +#define PWinGravity (1L << 9) /* program specified window gravity */ + +/* obsolete */ +#define PAllHints (PPosition|PSize|PMinSize|PMaxSize|PResizeInc|PAspect) + + + +typedef struct { + long flags; /* marks which fields in this structure are defined */ + Bool input; /* does this application rely on the window manager to + get keyboard input? */ + int initial_state; /* see below */ + Pixmap icon_pixmap; /* pixmap to be used as icon */ + Window icon_window; /* window to be used as icon */ + int icon_x, icon_y; /* initial position of icon */ + Pixmap icon_mask; /* icon mask bitmap */ + XID window_group; /* id of related window group */ + /* this structure may be extended in the future */ +} XWMHints; + +/* definition for flags of XWMHints */ + +#define InputHint (1L << 0) +#define StateHint (1L << 1) +#define IconPixmapHint (1L << 2) +#define IconWindowHint (1L << 3) +#define IconPositionHint (1L << 4) +#define IconMaskHint (1L << 5) +#define WindowGroupHint (1L << 6) +#define AllHints (InputHint|StateHint|IconPixmapHint|IconWindowHint| \ +IconPositionHint|IconMaskHint|WindowGroupHint) + +/* definitions for initial window state */ +#define WithdrawnState 0 /* for windows that are not mapped */ +#define NormalState 1 /* most applications want to start this way */ +#define IconicState 3 /* application wants to start as an icon */ + +/* + * Obsolete states no longer defined by ICCCM + */ +#define DontCareState 0 /* don't know or care */ +#define ZoomState 2 /* application wants to start zoomed */ +#define InactiveState 4 /* application believes it is seldom used; */ + /* some wm's may put it on inactive menu */ + + +/* + * new structure for manipulating TEXT properties; used with WM_NAME, + * WM_ICON_NAME, WM_CLIENT_MACHINE, and WM_COMMAND. + */ +typedef struct { + unsigned char *value; /* same as Property routines */ + Atom encoding; /* prop type */ + int format; /* prop data format: 8, 16, or 32 */ + unsigned long nitems; /* number of data items in value */ +} XTextProperty; + +#define XNoMemory -1 +#define XLocaleNotSupported -2 +#define XConverterNotFound -3 + +typedef enum { + XStringStyle, /* STRING */ + XCompoundTextStyle, /* COMPOUND_TEXT */ + XTextStyle, /* text in owner's encoding (current locale)*/ + XStdICCTextStyle /* STRING, else COMPOUND_TEXT */ +} XICCEncodingStyle; + +typedef struct { + int min_width, min_height; + int max_width, max_height; + int width_inc, height_inc; +} XIconSize; + +typedef struct { + char *res_name; + char *res_class; +} XClassHint; + +/* + * These macros are used to give some sugar to the image routines so that + * naive people are more comfortable with them. + */ +#define XDestroyImage(ximage) \ + ((*((ximage)->f.destroy_image))((ximage))) +#define XGetPixel(ximage, x, y) \ + ((*((ximage)->f.get_pixel))((ximage), (x), (y))) +#define XPutPixel(ximage, x, y, pixel) \ + ((*((ximage)->f.put_pixel))((ximage), (x), (y), (pixel))) +#define XSubImage(ximage, x, y, width, height) \ + ((*((ximage)->f.sub_image))((ximage), (x), (y), (width), (height))) +#define XAddPixel(ximage, value) \ + ((*((ximage)->f.add_pixel))((ximage), (value))) + +/* + * Compose sequence status structure, used in calling XLookupString. + */ +typedef struct _XComposeStatus { + XPointer compose_ptr; /* state table pointer */ + int chars_matched; /* match state */ +} XComposeStatus; + +/* + * Keysym macros, used on Keysyms to test for classes of symbols + */ +#define IsKeypadKey(keysym) \ + (((unsigned)(keysym) >= XK_KP_Space) && ((unsigned)(keysym) <= XK_KP_Equal)) + +#define IsCursorKey(keysym) \ + (((unsigned)(keysym) >= XK_Home) && ((unsigned)(keysym) < XK_Select)) + +#define IsPFKey(keysym) \ + (((unsigned)(keysym) >= XK_KP_F1) && ((unsigned)(keysym) <= XK_KP_F4)) + +#define IsFunctionKey(keysym) \ + (((unsigned)(keysym) >= XK_F1) && ((unsigned)(keysym) <= XK_F35)) + +#define IsMiscFunctionKey(keysym) \ + (((unsigned)(keysym) >= XK_Select) && ((unsigned)(keysym) <= XK_Break)) + +#define IsModifierKey(keysym) \ + ((((unsigned)(keysym) >= XK_Shift_L) && ((unsigned)(keysym) <= XK_Hyper_R)) \ + || ((unsigned)(keysym) == XK_Mode_switch) \ + || ((unsigned)(keysym) == XK_Num_Lock)) +/* + * opaque reference to Region data type + */ +typedef struct _XRegion *Region; + +/* Return values from XRectInRegion() */ + +#define RectangleOut 0 +#define RectangleIn 1 +#define RectanglePart 2 + + +/* + * Information used by the visual utility routines to find desired visual + * type from the many visuals a display may support. + */ + +typedef struct { + Visual *visual; + VisualID visualid; + int screen; + int depth; +#if defined(__cplusplus) || defined(c_plusplus) + int c_class; /* C++ */ +#else + int class; +#endif + unsigned long red_mask; + unsigned long green_mask; + unsigned long blue_mask; + int colormap_size; + int bits_per_rgb; +} XVisualInfo; + +#define VisualNoMask 0x0 +#define VisualIDMask 0x1 +#define VisualScreenMask 0x2 +#define VisualDepthMask 0x4 +#define VisualClassMask 0x8 +#define VisualRedMaskMask 0x10 +#define VisualGreenMaskMask 0x20 +#define VisualBlueMaskMask 0x40 +#define VisualColormapSizeMask 0x80 +#define VisualBitsPerRGBMask 0x100 +#define VisualAllMask 0x1FF + +/* + * This defines a window manager property that clients may use to + * share standard color maps of type RGB_COLOR_MAP: + */ +typedef struct { + Colormap colormap; + unsigned long red_max; + unsigned long red_mult; + unsigned long green_max; + unsigned long green_mult; + unsigned long blue_max; + unsigned long blue_mult; + unsigned long base_pixel; + VisualID visualid; /* added by ICCCM version 1 */ + XID killid; /* added by ICCCM version 1 */ +} XStandardColormap; + +#define ReleaseByFreeingColormap ((XID) 1L) /* for killid field above */ + + +/* + * return codes for XReadBitmapFile and XWriteBitmapFile + */ +#define BitmapSuccess 0 +#define BitmapOpenFailed 1 +#define BitmapFileInvalid 2 +#define BitmapNoMemory 3 + +/**************************************************************** + * + * Context Management + * + ****************************************************************/ + + +/* Associative lookup table return codes */ + +#define XCSUCCESS 0 /* No error. */ +#define XCNOMEM 1 /* Out of memory */ +#define XCNOENT 2 /* No entry in table */ + +typedef int XContext; + +#define XUniqueContext() ((XContext) XrmUniqueQuark()) +#define XStringToContext(string) ((XContext) XrmStringToQuark(string)) + +_XFUNCPROTOBEGIN + +/* The following declarations are alphabetized. */ + +extern XClassHint *XAllocClassHint ( +#if NeedFunctionPrototypes + void +#endif +); + +extern XIconSize *XAllocIconSize ( +#if NeedFunctionPrototypes + void +#endif +); + +extern XSizeHints *XAllocSizeHints ( +#if NeedFunctionPrototypes + void +#endif +); + +extern XStandardColormap *XAllocStandardColormap ( +#if NeedFunctionPrototypes + void +#endif +); + +extern XWMHints *XAllocWMHints ( +#if NeedFunctionPrototypes + void +#endif +); + +extern void XClipBox( +#if NeedFunctionPrototypes + Region /* r */, + XRectangle* /* rect_return */ +#endif +); + +extern Region XCreateRegion( +#if NeedFunctionPrototypes + void +#endif +); + +extern char *XDefaultString( +#if NeedFunctionPrototypes + void +#endif +); + +extern int XDeleteContext( +#if NeedFunctionPrototypes + Display* /* display */, + XID /* rid */, + XContext /* context */ +#endif +); + +extern void XDestroyRegion( +#if NeedFunctionPrototypes + Region /* r */ +#endif +); + +extern void XEmptyRegion( +#if NeedFunctionPrototypes + Region /* r */ +#endif +); + +extern void XEqualRegion( +#if NeedFunctionPrototypes + Region /* r1 */, + Region /* r2 */ +#endif +); + +extern int XFindContext( +#if NeedFunctionPrototypes + Display* /* display */, + XID /* rid */, + XContext /* context */, + XPointer* /* data_return */ +#endif +); + +extern int XGetClassHint( +#if NeedFunctionPrototypes + Display* /* display */, + Window /* w */, + XClassHint* /* class_hints_return */ +#endif +); + +extern int XGetIconSizes( +#if NeedFunctionPrototypes + Display* /* display */, + Window /* w */, + XIconSize** /* size_list_return */, + int* /* count_return */ +#endif +); + +extern int XGetNormalHints( +#if NeedFunctionPrototypes + Display* /* display */, + Window /* w */, + XSizeHints* /* hints_return */ +#endif +); + +extern int XGetRGBColormaps( +#if NeedFunctionPrototypes + Display* /* display */, + Window /* w */, + XStandardColormap** /* stdcmap_return */, + int* /* count_return */, + Atom /* property */ +#endif +); + +extern int XGetSizeHints( +#if NeedFunctionPrototypes + Display* /* display */, + Window /* w */, + XSizeHints* /* hints_return */, + Atom /* property */ +#endif +); + +extern int XGetStandardColormap( +#if NeedFunctionPrototypes + Display* /* display */, + Window /* w */, + XStandardColormap* /* colormap_return */, + Atom /* property */ +#endif +); + +extern int XGetTextProperty( +#if NeedFunctionPrototypes + Display* /* display */, + Window /* window */, + XTextProperty* /* text_prop_return */, + Atom /* property */ +#endif +); + + +extern int XGetWMClientMachine( +#if NeedFunctionPrototypes + Display* /* display */, + Window /* w */, + XTextProperty* /* text_prop_return */ +#endif +); + +extern XWMHints *XGetWMHints( +#if NeedFunctionPrototypes + Display* /* display */, + Window /* w */ +#endif +); + +extern int XGetWMIconName( +#if NeedFunctionPrototypes + Display* /* display */, + Window /* w */, + XTextProperty* /* text_prop_return */ +#endif +); + +extern int XGetWMName( +#if NeedFunctionPrototypes + Display* /* display */, + Window /* w */, + XTextProperty* /* text_prop_return */ +#endif +); + +extern int XGetWMNormalHints( +#if NeedFunctionPrototypes + Display* /* display */, + Window /* w */, + XSizeHints* /* hints_return */, + long* /* supplied_return */ +#endif +); + +extern int XGetWMSizeHints( +#if NeedFunctionPrototypes + Display* /* display */, + Window /* w */, + XSizeHints* /* hints_return */, + long* /* supplied_return */, + Atom /* property */ +#endif +); + +extern int XGetZoomHints( +#if NeedFunctionPrototypes + Display* /* display */, + Window /* w */, + XSizeHints* /* zhints_return */ +#endif +); + +extern void XIntersectRegion( +#if NeedFunctionPrototypes + Region /* sra */, + Region /* srb */, + Region /* dr_return */ +#endif +); + +extern int XLookupString( +#if NeedFunctionPrototypes + XKeyEvent* /* event_struct */, + char* /* buffer_return */, + int /* bytes_buffer */, + KeySym* /* keysym_return */, + XComposeStatus* /* status_in_out */ +#endif +); + +extern int XMatchVisualInfo( +#if NeedFunctionPrototypes + Display* /* display */, + int /* screen */, + int /* depth */, + int /* class */, + XVisualInfo* /* vinfo_return */ +#endif +); + +extern void XOffsetRegion( +#if NeedFunctionPrototypes + Region /* r */, + int /* dx */, + int /* dy */ +#endif +); + +extern Bool XPointInRegion( +#if NeedFunctionPrototypes + Region /* r */, + int /* x */, + int /* y */ +#endif +); + +extern Region XPolygonRegion( +#if NeedFunctionPrototypes + XPoint* /* points */, + int /* n */, + int /* fill_rule */ +#endif +); + +extern int XRectInRegion( +#if NeedFunctionPrototypes + Region /* r */, + int /* x */, + int /* y */, + unsigned int /* width */, + unsigned int /* height */ +#endif +); + +extern int XSaveContext( +#if NeedFunctionPrototypes + Display* /* display */, + XID /* rid */, + XContext /* context */, + _Xconst char* /* data */ +#endif +); + +extern void XSetClassHint( +#if NeedFunctionPrototypes + Display* /* display */, + Window /* w */, + XClassHint* /* class_hints */ +#endif +); + +extern void XSetIconSizes( +#if NeedFunctionPrototypes + Display* /* display */, + Window /* w */, + XIconSize* /* size_list */, + int /* count */ +#endif +); + +extern void XSetNormalHints( +#if NeedFunctionPrototypes + Display* /* display */, + Window /* w */, + XSizeHints* /* hints */ +#endif +); + +extern void XSetRGBColormaps( +#if NeedFunctionPrototypes + Display* /* display */, + Window /* w */, + XStandardColormap* /* stdcmaps */, + int /* count */, + Atom /* property */ +#endif +); + +extern void XSetSizeHints( +#if NeedFunctionPrototypes + Display* /* display */, + Window /* w */, + XSizeHints* /* hints */, + Atom /* property */ +#endif +); + +extern void XSetStandardProperties( +#if NeedFunctionPrototypes + Display* /* display */, + Window /* w */, + _Xconst char* /* window_name */, + _Xconst char* /* icon_name */, + Pixmap /* icon_pixmap */, + char** /* argv */, + int /* argc */, + XSizeHints* /* hints */ +#endif +); + +extern void XSetTextProperty( +#if NeedFunctionPrototypes + Display* /* display */, + Window /* w */, + XTextProperty* /* text_prop */, + Atom /* property */ +#endif +); + +extern void XSetWMHints( +#if NeedFunctionPrototypes + Display* /* display */, + Window /* w */, + XWMHints* /* wm_hints */ +#endif +); + +extern void XSetWMIconName( +#if NeedFunctionPrototypes + Display* /* display */, + Window /* w */, + XTextProperty* /* text_prop */ +#endif +); + +extern void XSetWMName( +#if NeedFunctionPrototypes + Display* /* display */, + Window /* w */, + XTextProperty* /* text_prop */ +#endif +); + +extern void XSetWMNormalHints( +#if NeedFunctionPrototypes + Display* /* display */, + Window /* w */, + XSizeHints* /* hints */ +#endif +); + +extern void XSetWMProperties( +#if NeedFunctionPrototypes + Display* /* display */, + Window /* w */, + XTextProperty* /* window_name */, + XTextProperty* /* icon_name */, + char** /* argv */, + int /* argc */, + XSizeHints* /* normal_hints */, + XWMHints* /* wm_hints */, + XClassHint* /* class_hints */ +#endif +); + +extern void XmbSetWMProperties( +#if NeedFunctionPrototypes + Display* /* display */, + Window /* w */, + _Xconst char* /* window_name */, + _Xconst char* /* icon_name */, + char** /* argv */, + int /* argc */, + XSizeHints* /* normal_hints */, + XWMHints* /* wm_hints */, + XClassHint* /* class_hints */ +#endif +); + +extern void XSetWMSizeHints( +#if NeedFunctionPrototypes + Display* /* display */, + Window /* w */, + XSizeHints* /* hints */, + Atom /* property */ +#endif +); + +extern void XSetRegion( +#if NeedFunctionPrototypes + Display* /* display */, + GC /* gc */, + Region /* r */ +#endif +); + +extern void XSetStandardColormap( +#if NeedFunctionPrototypes + Display* /* display */, + Window /* w */, + XStandardColormap* /* colormap */, + Atom /* property */ +#endif +); + +extern void XSetZoomHints( +#if NeedFunctionPrototypes + Display* /* display */, + Window /* w */, + XSizeHints* /* zhints */ +#endif +); + +extern void XShrinkRegion( +#if NeedFunctionPrototypes + Region /* r */, + int /* dx */, + int /* dy */ +#endif +); + +extern void XSubtractRegion( +#if NeedFunctionPrototypes + Region /* sra */, + Region /* srb */, + Region /* dr_return */ +#endif +); + +extern int XmbTextListToTextProperty( +#if NeedFunctionPrototypes + Display* /* display */, + char** /* list */, + int /* count */, + XICCEncodingStyle /* style */, + XTextProperty* /* text_prop_return */ +#endif +); + +extern int XwcTextListToTextProperty( +#if NeedFunctionPrototypes + Display* /* display */, + wchar_t** /* list */, + int /* count */, + XICCEncodingStyle /* style */, + XTextProperty* /* text_prop_return */ +#endif +); + +extern void XwcFreeStringList( +#if NeedFunctionPrototypes + wchar_t** /* list */ +#endif +); + +extern int XTextPropertyToStringList( +#if NeedFunctionPrototypes + XTextProperty* /* text_prop */, + char*** /* list_return */, + int* /* count_return */ +#endif +); + +extern int XmbTextPropertyToTextList( +#if NeedFunctionPrototypes + Display* /* display */, + XTextProperty* /* text_prop */, + char*** /* list_return */, + int* /* count_return */ +#endif +); + +extern int XwcTextPropertyToTextList( +#if NeedFunctionPrototypes + Display* /* display */, + XTextProperty* /* text_prop */, + wchar_t*** /* list_return */, + int* /* count_return */ +#endif +); + +extern void XUnionRectWithRegion( +#if NeedFunctionPrototypes + XRectangle* /* rectangle */, + Region /* src_region */, + Region /* dest_region_return */ +#endif +); + +extern void XUnionRegion( +#if NeedFunctionPrototypes + Region /* sra */, + Region /* srb */, + Region /* dr_return */ +#endif +); + +extern int XWMGeometry( +#if NeedFunctionPrototypes + Display* /* display */, + int /* screen_number */, + _Xconst char* /* user_geometry */, + _Xconst char* /* default_geometry */, + unsigned int /* border_width */, + XSizeHints* /* hints */, + int* /* x_return */, + int* /* y_return */, + int* /* width_return */, + int* /* height_return */, + int* /* gravity_return */ +#endif +); + +extern void XXorRegion( +#if NeedFunctionPrototypes + Region /* sra */, + Region /* srb */, + Region /* dr_return */ +#endif +); + +_XFUNCPROTOEND + +#if defined(MAC_TCL) || defined(MAC_OSX_TK) +# undef Region +#endif + +#endif /* _XUTIL_H_ */ diff --git a/Master/tlpkg/tlperl/lib/Tk/X11/cursorfont.h b/Master/tlpkg/tlperl/lib/Tk/X11/cursorfont.h new file mode 100644 index 00000000000..617274fa806 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/X11/cursorfont.h @@ -0,0 +1,79 @@ +/* $XConsortium: cursorfont.h,v 1.2 88/09/06 16:44:27 jim Exp $ */ +#define XC_num_glyphs 154 +#define XC_X_cursor 0 +#define XC_arrow 2 +#define XC_based_arrow_down 4 +#define XC_based_arrow_up 6 +#define XC_boat 8 +#define XC_bogosity 10 +#define XC_bottom_left_corner 12 +#define XC_bottom_right_corner 14 +#define XC_bottom_side 16 +#define XC_bottom_tee 18 +#define XC_box_spiral 20 +#define XC_center_ptr 22 +#define XC_circle 24 +#define XC_clock 26 +#define XC_coffee_mug 28 +#define XC_cross 30 +#define XC_cross_reverse 32 +#define XC_crosshair 34 +#define XC_diamond_cross 36 +#define XC_dot 38 +#define XC_dotbox 40 +#define XC_double_arrow 42 +#define XC_draft_large 44 +#define XC_draft_small 46 +#define XC_draped_box 48 +#define XC_exchange 50 +#define XC_fleur 52 +#define XC_gobbler 54 +#define XC_gumby 56 +#define XC_hand1 58 +#define XC_hand2 60 +#define XC_heart 62 +#define XC_icon 64 +#define XC_iron_cross 66 +#define XC_left_ptr 68 +#define XC_left_side 70 +#define XC_left_tee 72 +#define XC_leftbutton 74 +#define XC_ll_angle 76 +#define XC_lr_angle 78 +#define XC_man 80 +#define XC_middlebutton 82 +#define XC_mouse 84 +#define XC_pencil 86 +#define XC_pirate 88 +#define XC_plus 90 +#define XC_question_arrow 92 +#define XC_right_ptr 94 +#define XC_right_side 96 +#define XC_right_tee 98 +#define XC_rightbutton 100 +#define XC_rtl_logo 102 +#define XC_sailboat 104 +#define XC_sb_down_arrow 106 +#define XC_sb_h_double_arrow 108 +#define XC_sb_left_arrow 110 +#define XC_sb_right_arrow 112 +#define XC_sb_up_arrow 114 +#define XC_sb_v_double_arrow 116 +#define XC_shuttle 118 +#define XC_sizing 120 +#define XC_spider 122 +#define XC_spraycan 124 +#define XC_star 126 +#define XC_target 128 +#define XC_tcross 130 +#define XC_top_left_arrow 132 +#define XC_top_left_corner 134 +#define XC_top_right_corner 136 +#define XC_top_side 138 +#define XC_top_tee 140 +#define XC_trek 142 +#define XC_ul_angle 144 +#define XC_umbrella 146 +#define XC_ur_angle 148 +#define XC_watch 150 +#define XC_xterm 152 diff --git a/Master/tlpkg/tlperl/lib/Tk/X11/keysym.h b/Master/tlpkg/tlperl/lib/Tk/X11/keysym.h new file mode 100644 index 00000000000..027afe08d5f --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/X11/keysym.h @@ -0,0 +1,39 @@ +/* $XConsortium: keysym.h,v 1.13 91/03/13 20:09:49 rws Exp $ */ + +/*********************************************************** +Copyright 1987 by Digital Equipment Corporation, Maynard, Massachusetts, +and the Massachusetts Institute of Technology, Cambridge, Massachusetts. + + All Rights Reserved + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, +provided that the above copyright notice appear in all copies and that +both that copyright notice and this permission notice appear in +supporting documentation, and that the names of Digital or MIT not be +used in advertising or publicity pertaining to distribution of the +software without specific, written prior permission. + +DIGITAL DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING +ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL +DIGITAL BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR +ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, +WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, +ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS +SOFTWARE. + +******************************************************************/ + +/* default keysyms */ +#define XK_MISCELLANY +#define XK_LATIN1 +#define XK_LATIN2 +#define XK_LATIN3 +#define XK_LATIN4 +#define XK_GREEK + +#ifdef MAC_TCL +#include <keysymdef.h> +#else +#include <X11/keysymdef.h> +#endif diff --git a/Master/tlpkg/tlperl/lib/Tk/X11/keysymdef.h b/Master/tlpkg/tlperl/lib/Tk/X11/keysymdef.h new file mode 100644 index 00000000000..b22d41b3385 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/X11/keysymdef.h @@ -0,0 +1,1169 @@ +/* $XConsortium: keysymdef.h,v 1.15 93/04/02 10:57:36 rws Exp $ */ + +/*********************************************************** +Copyright 1987 by Digital Equipment Corporation, Maynard, Massachusetts, +and the Massachusetts Institute of Technology, Cambridge, Massachusetts. + + All Rights Reserved + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, +provided that the above copyright notice appear in all copies and that +both that copyright notice and this permission notice appear in +supporting documentation, and that the names of Digital or MIT not be +used in advertising or publicity pertaining to distribution of the +software without specific, written prior permission. + +DIGITAL DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING +ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL +DIGITAL BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR +ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, +WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, +ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS +SOFTWARE. + +******************************************************************/ + +#define XK_VoidSymbol 0xFFFFFF /* void symbol */ + +#ifdef XK_MISCELLANY +/* + * TTY Functions, cleverly chosen to map to ascii, for convenience of + * programming, but could have been arbitrary (at the cost of lookup + * tables in client code. + */ + +#define XK_BackSpace 0xFF08 /* back space, back char */ +#define XK_Tab 0xFF09 +#define XK_Linefeed 0xFF0A /* Linefeed, LF */ +#define XK_Clear 0xFF0B +#define XK_Return 0xFF0D /* Return, enter */ +#define XK_Pause 0xFF13 /* Pause, hold */ +#define XK_Scroll_Lock 0xFF14 +#define XK_Sys_Req 0xFF15 +#define XK_Escape 0xFF1B +#define XK_Delete 0xFFFF /* Delete, rubout */ + + + +/* International & multi-key character composition */ + +#define XK_Multi_key 0xFF20 /* Multi-key character compose */ + +/* Japanese keyboard support */ + +#define XK_Kanji 0xFF21 /* Kanji, Kanji convert */ +#define XK_Muhenkan 0xFF22 /* Cancel Conversion */ +#define XK_Henkan_Mode 0xFF23 /* Start/Stop Conversion */ +#define XK_Henkan 0xFF23 /* Alias for Henkan_Mode */ +#define XK_Romaji 0xFF24 /* to Romaji */ +#define XK_Hiragana 0xFF25 /* to Hiragana */ +#define XK_Katakana 0xFF26 /* to Katakana */ +#define XK_Hiragana_Katakana 0xFF27 /* Hiragana/Katakana toggle */ +#define XK_Zenkaku 0xFF28 /* to Zenkaku */ +#define XK_Hankaku 0xFF29 /* to Hankaku */ +#define XK_Zenkaku_Hankaku 0xFF2A /* Zenkaku/Hankaku toggle */ +#define XK_Touroku 0xFF2B /* Add to Dictionary */ +#define XK_Massyo 0xFF2C /* Delete from Dictionary */ +#define XK_Kana_Lock 0xFF2D /* Kana Lock */ +#define XK_Kana_Shift 0xFF2E /* Kana Shift */ +#define XK_Eisu_Shift 0xFF2F /* Alphanumeric Shift */ +#define XK_Eisu_toggle 0xFF30 /* Alphanumeric toggle */ + +/* Cursor control & motion */ + +#define XK_Home 0xFF50 +#define XK_Left 0xFF51 /* Move left, left arrow */ +#define XK_Up 0xFF52 /* Move up, up arrow */ +#define XK_Right 0xFF53 /* Move right, right arrow */ +#define XK_Down 0xFF54 /* Move down, down arrow */ +#define XK_Prior 0xFF55 /* Prior, previous */ +#define XK_Page_Up 0xFF55 +#define XK_Next 0xFF56 /* Next */ +#define XK_Page_Down 0xFF56 +#define XK_End 0xFF57 /* EOL */ +#define XK_Begin 0xFF58 /* BOL */ + +/* Special Windows keyboard keys */ + +#define XK_Win_L 0xFF5B /* Left-hand Windows */ +#define XK_Win_R 0xFF5C /* Right-hand Windows */ +#define XK_App 0xFF5D /* Menu key */ + +/* Misc Functions */ + +#define XK_Select 0xFF60 /* Select, mark */ +#define XK_Print 0xFF61 +#define XK_Execute 0xFF62 /* Execute, run, do */ +#define XK_Insert 0xFF63 /* Insert, insert here */ +#define XK_Undo 0xFF65 /* Undo, oops */ +#define XK_Redo 0xFF66 /* redo, again */ +#define XK_Menu 0xFF67 +#define XK_Find 0xFF68 /* Find, search */ +#define XK_Cancel 0xFF69 /* Cancel, stop, abort, exit */ +#define XK_Help 0xFF6A /* Help, ? */ +#define XK_Break 0xFF6B +#define XK_Mode_switch 0xFF7E /* Character set switch */ +#define XK_script_switch 0xFF7E /* Alias for mode_switch */ +#define XK_Num_Lock 0xFF7F + +/* Keypad Functions, keypad numbers cleverly chosen to map to ascii */ + +#define XK_KP_Space 0xFF80 /* space */ +#define XK_KP_Tab 0xFF89 +#define XK_KP_Enter 0xFF8D /* enter */ +#define XK_KP_F1 0xFF91 /* PF1, KP_A, ... */ +#define XK_KP_F2 0xFF92 +#define XK_KP_F3 0xFF93 +#define XK_KP_F4 0xFF94 +#define XK_KP_Home 0xFF95 +#define XK_KP_Left 0xFF96 +#define XK_KP_Up 0xFF97 +#define XK_KP_Right 0xFF98 +#define XK_KP_Down 0xFF99 +#define XK_KP_Prior 0xFF9A +#define XK_KP_Page_Up 0xFF9A +#define XK_KP_Next 0xFF9B +#define XK_KP_Page_Down 0xFF9B +#define XK_KP_End 0xFF9C +#define XK_KP_Begin 0xFF9D +#define XK_KP_Insert 0xFF9E +#define XK_KP_Delete 0xFF9F +#define XK_KP_Equal 0xFFBD /* equals */ +#define XK_KP_Multiply 0xFFAA +#define XK_KP_Add 0xFFAB +#define XK_KP_Separator 0xFFAC /* separator, often comma */ +#define XK_KP_Subtract 0xFFAD +#define XK_KP_Decimal 0xFFAE +#define XK_KP_Divide 0xFFAF + +#define XK_KP_0 0xFFB0 +#define XK_KP_1 0xFFB1 +#define XK_KP_2 0xFFB2 +#define XK_KP_3 0xFFB3 +#define XK_KP_4 0xFFB4 +#define XK_KP_5 0xFFB5 +#define XK_KP_6 0xFFB6 +#define XK_KP_7 0xFFB7 +#define XK_KP_8 0xFFB8 +#define XK_KP_9 0xFFB9 + + + +/* + * Auxilliary Functions; note the duplicate definitions for left and right + * function keys; Sun keyboards and a few other manufactures have such + * function key groups on the left and/or right sides of the keyboard. + * We've not found a keyboard with more than 35 function keys total. + */ + +#define XK_F1 0xFFBE +#define XK_F2 0xFFBF +#define XK_F3 0xFFC0 +#define XK_F4 0xFFC1 +#define XK_F5 0xFFC2 +#define XK_F6 0xFFC3 +#define XK_F7 0xFFC4 +#define XK_F8 0xFFC5 +#define XK_F9 0xFFC6 +#define XK_F10 0xFFC7 +#define XK_F11 0xFFC8 +#define XK_L1 0xFFC8 +#define XK_F12 0xFFC9 +#define XK_L2 0xFFC9 +#define XK_F13 0xFFCA +#define XK_L3 0xFFCA +#define XK_F14 0xFFCB +#define XK_L4 0xFFCB +#define XK_F15 0xFFCC +#define XK_L5 0xFFCC +#define XK_F16 0xFFCD +#define XK_L6 0xFFCD +#define XK_F17 0xFFCE +#define XK_L7 0xFFCE +#define XK_F18 0xFFCF +#define XK_L8 0xFFCF +#define XK_F19 0xFFD0 +#define XK_L9 0xFFD0 +#define XK_F20 0xFFD1 +#define XK_L10 0xFFD1 +#define XK_F21 0xFFD2 +#define XK_R1 0xFFD2 +#define XK_F22 0xFFD3 +#define XK_R2 0xFFD3 +#define XK_F23 0xFFD4 +#define XK_R3 0xFFD4 +#define XK_F24 0xFFD5 +#define XK_R4 0xFFD5 +#define XK_F25 0xFFD6 +#define XK_R5 0xFFD6 +#define XK_F26 0xFFD7 +#define XK_R6 0xFFD7 +#define XK_F27 0xFFD8 +#define XK_R7 0xFFD8 +#define XK_F28 0xFFD9 +#define XK_R8 0xFFD9 +#define XK_F29 0xFFDA +#define XK_R9 0xFFDA +#define XK_F30 0xFFDB +#define XK_R10 0xFFDB +#define XK_F31 0xFFDC +#define XK_R11 0xFFDC +#define XK_F32 0xFFDD +#define XK_R12 0xFFDD +#define XK_F33 0xFFDE +#define XK_R13 0xFFDE +#define XK_F34 0xFFDF +#define XK_R14 0xFFDF +#define XK_F35 0xFFE0 +#define XK_R15 0xFFE0 + +/* Modifiers */ + +#define XK_Shift_L 0xFFE1 /* Left shift */ +#define XK_Shift_R 0xFFE2 /* Right shift */ +#define XK_Control_L 0xFFE3 /* Left control */ +#define XK_Control_R 0xFFE4 /* Right control */ +#define XK_Caps_Lock 0xFFE5 /* Caps lock */ +#define XK_Shift_Lock 0xFFE6 /* Shift lock */ + +#define XK_Meta_L 0xFFE7 /* Left meta */ +#define XK_Meta_R 0xFFE8 /* Right meta */ +#define XK_Alt_L 0xFFE9 /* Left alt */ +#define XK_Alt_R 0xFFEA /* Right alt */ +#define XK_Super_L 0xFFEB /* Left super */ +#define XK_Super_R 0xFFEC /* Right super */ +#define XK_Hyper_L 0xFFED /* Left hyper */ +#define XK_Hyper_R 0xFFEE /* Right hyper */ +#endif /* XK_MISCELLANY */ + +/* + * Latin 1 + * Byte 3 = 0 + */ +#ifdef XK_LATIN1 +#define XK_space 0x020 +#define XK_exclam 0x021 +#define XK_quotedbl 0x022 +#define XK_numbersign 0x023 +#define XK_dollar 0x024 +#define XK_percent 0x025 +#define XK_ampersand 0x026 +#define XK_apostrophe 0x027 +#define XK_quoteright 0x027 /* deprecated */ +#define XK_parenleft 0x028 +#define XK_parenright 0x029 +#define XK_asterisk 0x02a +#define XK_plus 0x02b +#define XK_comma 0x02c +#define XK_minus 0x02d +#define XK_period 0x02e +#define XK_slash 0x02f +#define XK_0 0x030 +#define XK_1 0x031 +#define XK_2 0x032 +#define XK_3 0x033 +#define XK_4 0x034 +#define XK_5 0x035 +#define XK_6 0x036 +#define XK_7 0x037 +#define XK_8 0x038 +#define XK_9 0x039 +#define XK_colon 0x03a +#define XK_semicolon 0x03b +#define XK_less 0x03c +#define XK_equal 0x03d +#define XK_greater 0x03e +#define XK_question 0x03f +#define XK_at 0x040 +#define XK_A 0x041 +#define XK_B 0x042 +#define XK_C 0x043 +#define XK_D 0x044 +#define XK_E 0x045 +#define XK_F 0x046 +#define XK_G 0x047 +#define XK_H 0x048 +#define XK_I 0x049 +#define XK_J 0x04a +#define XK_K 0x04b +#define XK_L 0x04c +#define XK_M 0x04d +#define XK_N 0x04e +#define XK_O 0x04f +#define XK_P 0x050 +#define XK_Q 0x051 +#define XK_R 0x052 +#define XK_S 0x053 +#define XK_T 0x054 +#define XK_U 0x055 +#define XK_V 0x056 +#define XK_W 0x057 +#define XK_X 0x058 +#define XK_Y 0x059 +#define XK_Z 0x05a +#define XK_bracketleft 0x05b +#define XK_backslash 0x05c +#define XK_bracketright 0x05d +#define XK_asciicircum 0x05e +#define XK_underscore 0x05f +#define XK_grave 0x060 +#define XK_quoteleft 0x060 /* deprecated */ +#define XK_a 0x061 +#define XK_b 0x062 +#define XK_c 0x063 +#define XK_d 0x064 +#define XK_e 0x065 +#define XK_f 0x066 +#define XK_g 0x067 +#define XK_h 0x068 +#define XK_i 0x069 +#define XK_j 0x06a +#define XK_k 0x06b +#define XK_l 0x06c +#define XK_m 0x06d +#define XK_n 0x06e +#define XK_o 0x06f +#define XK_p 0x070 +#define XK_q 0x071 +#define XK_r 0x072 +#define XK_s 0x073 +#define XK_t 0x074 +#define XK_u 0x075 +#define XK_v 0x076 +#define XK_w 0x077 +#define XK_x 0x078 +#define XK_y 0x079 +#define XK_z 0x07a +#define XK_braceleft 0x07b +#define XK_bar 0x07c +#define XK_braceright 0x07d +#define XK_asciitilde 0x07e + +#define XK_nobreakspace 0x0a0 +#define XK_exclamdown 0x0a1 +#define XK_cent 0x0a2 +#define XK_sterling 0x0a3 +#define XK_currency 0x0a4 +#define XK_yen 0x0a5 +#define XK_brokenbar 0x0a6 +#define XK_section 0x0a7 +#define XK_diaeresis 0x0a8 +#define XK_copyright 0x0a9 +#define XK_ordfeminine 0x0aa +#define XK_guillemotleft 0x0ab /* left angle quotation mark */ +#define XK_notsign 0x0ac +#define XK_hyphen 0x0ad +#define XK_registered 0x0ae +#define XK_macron 0x0af +#define XK_degree 0x0b0 +#define XK_plusminus 0x0b1 +#define XK_twosuperior 0x0b2 +#define XK_threesuperior 0x0b3 +#define XK_acute 0x0b4 +#define XK_mu 0x0b5 +#define XK_paragraph 0x0b6 +#define XK_periodcentered 0x0b7 +#define XK_cedilla 0x0b8 +#define XK_onesuperior 0x0b9 +#define XK_masculine 0x0ba +#define XK_guillemotright 0x0bb /* right angle quotation mark */ +#define XK_onequarter 0x0bc +#define XK_onehalf 0x0bd +#define XK_threequarters 0x0be +#define XK_questiondown 0x0bf +#define XK_Agrave 0x0c0 +#define XK_Aacute 0x0c1 +#define XK_Acircumflex 0x0c2 +#define XK_Atilde 0x0c3 +#define XK_Adiaeresis 0x0c4 +#define XK_Aring 0x0c5 +#define XK_AE 0x0c6 +#define XK_Ccedilla 0x0c7 +#define XK_Egrave 0x0c8 +#define XK_Eacute 0x0c9 +#define XK_Ecircumflex 0x0ca +#define XK_Ediaeresis 0x0cb +#define XK_Igrave 0x0cc +#define XK_Iacute 0x0cd +#define XK_Icircumflex 0x0ce +#define XK_Idiaeresis 0x0cf +#define XK_ETH 0x0d0 +#define XK_Eth 0x0d0 /* deprecated */ +#define XK_Ntilde 0x0d1 +#define XK_Ograve 0x0d2 +#define XK_Oacute 0x0d3 +#define XK_Ocircumflex 0x0d4 +#define XK_Otilde 0x0d5 +#define XK_Odiaeresis 0x0d6 +#define XK_multiply 0x0d7 +#define XK_Ooblique 0x0d8 +#define XK_Ugrave 0x0d9 +#define XK_Uacute 0x0da +#define XK_Ucircumflex 0x0db +#define XK_Udiaeresis 0x0dc +#define XK_Yacute 0x0dd +#define XK_THORN 0x0de +#define XK_Thorn 0x0de /* deprecated */ +#define XK_ssharp 0x0df +#define XK_agrave 0x0e0 +#define XK_aacute 0x0e1 +#define XK_acircumflex 0x0e2 +#define XK_atilde 0x0e3 +#define XK_adiaeresis 0x0e4 +#define XK_aring 0x0e5 +#define XK_ae 0x0e6 +#define XK_ccedilla 0x0e7 +#define XK_egrave 0x0e8 +#define XK_eacute 0x0e9 +#define XK_ecircumflex 0x0ea +#define XK_ediaeresis 0x0eb +#define XK_igrave 0x0ec +#define XK_iacute 0x0ed +#define XK_icircumflex 0x0ee +#define XK_idiaeresis 0x0ef +#define XK_eth 0x0f0 +#define XK_ntilde 0x0f1 +#define XK_ograve 0x0f2 +#define XK_oacute 0x0f3 +#define XK_ocircumflex 0x0f4 +#define XK_otilde 0x0f5 +#define XK_odiaeresis 0x0f6 +#define XK_division 0x0f7 +#define XK_oslash 0x0f8 +#define XK_ugrave 0x0f9 +#define XK_uacute 0x0fa +#define XK_ucircumflex 0x0fb +#define XK_udiaeresis 0x0fc +#define XK_yacute 0x0fd +#define XK_thorn 0x0fe +#define XK_ydiaeresis 0x0ff +#endif /* XK_LATIN1 */ + +/* + * Latin 2 + * Byte 3 = 1 + */ + +#ifdef XK_LATIN2 +#define XK_Aogonek 0x1a1 +#define XK_breve 0x1a2 +#define XK_Lstroke 0x1a3 +#define XK_Lcaron 0x1a5 +#define XK_Sacute 0x1a6 +#define XK_Scaron 0x1a9 +#define XK_Scedilla 0x1aa +#define XK_Tcaron 0x1ab +#define XK_Zacute 0x1ac +#define XK_Zcaron 0x1ae +#define XK_Zabovedot 0x1af +#define XK_aogonek 0x1b1 +#define XK_ogonek 0x1b2 +#define XK_lstroke 0x1b3 +#define XK_lcaron 0x1b5 +#define XK_sacute 0x1b6 +#define XK_caron 0x1b7 +#define XK_scaron 0x1b9 +#define XK_scedilla 0x1ba +#define XK_tcaron 0x1bb +#define XK_zacute 0x1bc +#define XK_doubleacute 0x1bd +#define XK_zcaron 0x1be +#define XK_zabovedot 0x1bf +#define XK_Racute 0x1c0 +#define XK_Abreve 0x1c3 +#define XK_Lacute 0x1c5 +#define XK_Cacute 0x1c6 +#define XK_Ccaron 0x1c8 +#define XK_Eogonek 0x1ca +#define XK_Ecaron 0x1cc +#define XK_Dcaron 0x1cf +#define XK_Dstroke 0x1d0 +#define XK_Nacute 0x1d1 +#define XK_Ncaron 0x1d2 +#define XK_Odoubleacute 0x1d5 +#define XK_Rcaron 0x1d8 +#define XK_Uring 0x1d9 +#define XK_Udoubleacute 0x1db +#define XK_Tcedilla 0x1de +#define XK_racute 0x1e0 +#define XK_abreve 0x1e3 +#define XK_lacute 0x1e5 +#define XK_cacute 0x1e6 +#define XK_ccaron 0x1e8 +#define XK_eogonek 0x1ea +#define XK_ecaron 0x1ec +#define XK_dcaron 0x1ef +#define XK_dstroke 0x1f0 +#define XK_nacute 0x1f1 +#define XK_ncaron 0x1f2 +#define XK_odoubleacute 0x1f5 +#define XK_udoubleacute 0x1fb +#define XK_rcaron 0x1f8 +#define XK_uring 0x1f9 +#define XK_tcedilla 0x1fe +#define XK_abovedot 0x1ff +#endif /* XK_LATIN2 */ + +/* + * Latin 3 + * Byte 3 = 2 + */ + +#ifdef XK_LATIN3 +#define XK_Hstroke 0x2a1 +#define XK_Hcircumflex 0x2a6 +#define XK_Iabovedot 0x2a9 +#define XK_Gbreve 0x2ab +#define XK_Jcircumflex 0x2ac +#define XK_hstroke 0x2b1 +#define XK_hcircumflex 0x2b6 +#define XK_idotless 0x2b9 +#define XK_gbreve 0x2bb +#define XK_jcircumflex 0x2bc +#define XK_Cabovedot 0x2c5 +#define XK_Ccircumflex 0x2c6 +#define XK_Gabovedot 0x2d5 +#define XK_Gcircumflex 0x2d8 +#define XK_Ubreve 0x2dd +#define XK_Scircumflex 0x2de +#define XK_cabovedot 0x2e5 +#define XK_ccircumflex 0x2e6 +#define XK_gabovedot 0x2f5 +#define XK_gcircumflex 0x2f8 +#define XK_ubreve 0x2fd +#define XK_scircumflex 0x2fe +#endif /* XK_LATIN3 */ + + +/* + * Latin 4 + * Byte 3 = 3 + */ + +#ifdef XK_LATIN4 +#define XK_kra 0x3a2 +#define XK_kappa 0x3a2 /* deprecated */ +#define XK_Rcedilla 0x3a3 +#define XK_Itilde 0x3a5 +#define XK_Lcedilla 0x3a6 +#define XK_Emacron 0x3aa +#define XK_Gcedilla 0x3ab +#define XK_Tslash 0x3ac +#define XK_rcedilla 0x3b3 +#define XK_itilde 0x3b5 +#define XK_lcedilla 0x3b6 +#define XK_emacron 0x3ba +#define XK_gcedilla 0x3bb +#define XK_tslash 0x3bc +#define XK_ENG 0x3bd +#define XK_eng 0x3bf +#define XK_Amacron 0x3c0 +#define XK_Iogonek 0x3c7 +#define XK_Eabovedot 0x3cc +#define XK_Imacron 0x3cf +#define XK_Ncedilla 0x3d1 +#define XK_Omacron 0x3d2 +#define XK_Kcedilla 0x3d3 +#define XK_Uogonek 0x3d9 +#define XK_Utilde 0x3dd +#define XK_Umacron 0x3de +#define XK_amacron 0x3e0 +#define XK_iogonek 0x3e7 +#define XK_eabovedot 0x3ec +#define XK_imacron 0x3ef +#define XK_ncedilla 0x3f1 +#define XK_omacron 0x3f2 +#define XK_kcedilla 0x3f3 +#define XK_uogonek 0x3f9 +#define XK_utilde 0x3fd +#define XK_umacron 0x3fe +#endif /* XK_LATIN4 */ + +/* + * Katakana + * Byte 3 = 4 + */ + +#ifdef XK_KATAKANA +#define XK_overline 0x47e +#define XK_kana_fullstop 0x4a1 +#define XK_kana_openingbracket 0x4a2 +#define XK_kana_closingbracket 0x4a3 +#define XK_kana_comma 0x4a4 +#define XK_kana_conjunctive 0x4a5 +#define XK_kana_middledot 0x4a5 /* deprecated */ +#define XK_kana_WO 0x4a6 +#define XK_kana_a 0x4a7 +#define XK_kana_i 0x4a8 +#define XK_kana_u 0x4a9 +#define XK_kana_e 0x4aa +#define XK_kana_o 0x4ab +#define XK_kana_ya 0x4ac +#define XK_kana_yu 0x4ad +#define XK_kana_yo 0x4ae +#define XK_kana_tsu 0x4af +#define XK_kana_tu 0x4af /* deprecated */ +#define XK_prolongedsound 0x4b0 +#define XK_kana_A 0x4b1 +#define XK_kana_I 0x4b2 +#define XK_kana_U 0x4b3 +#define XK_kana_E 0x4b4 +#define XK_kana_O 0x4b5 +#define XK_kana_KA 0x4b6 +#define XK_kana_KI 0x4b7 +#define XK_kana_KU 0x4b8 +#define XK_kana_KE 0x4b9 +#define XK_kana_KO 0x4ba +#define XK_kana_SA 0x4bb +#define XK_kana_SHI 0x4bc +#define XK_kana_SU 0x4bd +#define XK_kana_SE 0x4be +#define XK_kana_SO 0x4bf +#define XK_kana_TA 0x4c0 +#define XK_kana_CHI 0x4c1 +#define XK_kana_TI 0x4c1 /* deprecated */ +#define XK_kana_TSU 0x4c2 +#define XK_kana_TU 0x4c2 /* deprecated */ +#define XK_kana_TE 0x4c3 +#define XK_kana_TO 0x4c4 +#define XK_kana_NA 0x4c5 +#define XK_kana_NI 0x4c6 +#define XK_kana_NU 0x4c7 +#define XK_kana_NE 0x4c8 +#define XK_kana_NO 0x4c9 +#define XK_kana_HA 0x4ca +#define XK_kana_HI 0x4cb +#define XK_kana_FU 0x4cc +#define XK_kana_HU 0x4cc /* deprecated */ +#define XK_kana_HE 0x4cd +#define XK_kana_HO 0x4ce +#define XK_kana_MA 0x4cf +#define XK_kana_MI 0x4d0 +#define XK_kana_MU 0x4d1 +#define XK_kana_ME 0x4d2 +#define XK_kana_MO 0x4d3 +#define XK_kana_YA 0x4d4 +#define XK_kana_YU 0x4d5 +#define XK_kana_YO 0x4d6 +#define XK_kana_RA 0x4d7 +#define XK_kana_RI 0x4d8 +#define XK_kana_RU 0x4d9 +#define XK_kana_RE 0x4da +#define XK_kana_RO 0x4db +#define XK_kana_WA 0x4dc +#define XK_kana_N 0x4dd +#define XK_voicedsound 0x4de +#define XK_semivoicedsound 0x4df +#define XK_kana_switch 0xFF7E /* Alias for mode_switch */ +#endif /* XK_KATAKANA */ + +/* + * Arabic + * Byte 3 = 5 + */ + +#ifdef XK_ARABIC +#define XK_Arabic_comma 0x5ac +#define XK_Arabic_semicolon 0x5bb +#define XK_Arabic_question_mark 0x5bf +#define XK_Arabic_hamza 0x5c1 +#define XK_Arabic_maddaonalef 0x5c2 +#define XK_Arabic_hamzaonalef 0x5c3 +#define XK_Arabic_hamzaonwaw 0x5c4 +#define XK_Arabic_hamzaunderalef 0x5c5 +#define XK_Arabic_hamzaonyeh 0x5c6 +#define XK_Arabic_alef 0x5c7 +#define XK_Arabic_beh 0x5c8 +#define XK_Arabic_tehmarbuta 0x5c9 +#define XK_Arabic_teh 0x5ca +#define XK_Arabic_theh 0x5cb +#define XK_Arabic_jeem 0x5cc +#define XK_Arabic_hah 0x5cd +#define XK_Arabic_khah 0x5ce +#define XK_Arabic_dal 0x5cf +#define XK_Arabic_thal 0x5d0 +#define XK_Arabic_ra 0x5d1 +#define XK_Arabic_zain 0x5d2 +#define XK_Arabic_seen 0x5d3 +#define XK_Arabic_sheen 0x5d4 +#define XK_Arabic_sad 0x5d5 +#define XK_Arabic_dad 0x5d6 +#define XK_Arabic_tah 0x5d7 +#define XK_Arabic_zah 0x5d8 +#define XK_Arabic_ain 0x5d9 +#define XK_Arabic_ghain 0x5da +#define XK_Arabic_tatweel 0x5e0 +#define XK_Arabic_feh 0x5e1 +#define XK_Arabic_qaf 0x5e2 +#define XK_Arabic_kaf 0x5e3 +#define XK_Arabic_lam 0x5e4 +#define XK_Arabic_meem 0x5e5 +#define XK_Arabic_noon 0x5e6 +#define XK_Arabic_ha 0x5e7 +#define XK_Arabic_heh 0x5e7 /* deprecated */ +#define XK_Arabic_waw 0x5e8 +#define XK_Arabic_alefmaksura 0x5e9 +#define XK_Arabic_yeh 0x5ea +#define XK_Arabic_fathatan 0x5eb +#define XK_Arabic_dammatan 0x5ec +#define XK_Arabic_kasratan 0x5ed +#define XK_Arabic_fatha 0x5ee +#define XK_Arabic_damma 0x5ef +#define XK_Arabic_kasra 0x5f0 +#define XK_Arabic_shadda 0x5f1 +#define XK_Arabic_sukun 0x5f2 +#define XK_Arabic_switch 0xFF7E /* Alias for mode_switch */ +#endif /* XK_ARABIC */ + +/* + * Cyrillic + * Byte 3 = 6 + */ +#ifdef XK_CYRILLIC +#define XK_Serbian_dje 0x6a1 +#define XK_Macedonia_gje 0x6a2 +#define XK_Cyrillic_io 0x6a3 +#define XK_Ukrainian_ie 0x6a4 +#define XK_Ukranian_je 0x6a4 /* deprecated */ +#define XK_Macedonia_dse 0x6a5 +#define XK_Ukrainian_i 0x6a6 +#define XK_Ukranian_i 0x6a6 /* deprecated */ +#define XK_Ukrainian_yi 0x6a7 +#define XK_Ukranian_yi 0x6a7 /* deprecated */ +#define XK_Cyrillic_je 0x6a8 +#define XK_Serbian_je 0x6a8 /* deprecated */ +#define XK_Cyrillic_lje 0x6a9 +#define XK_Serbian_lje 0x6a9 /* deprecated */ +#define XK_Cyrillic_nje 0x6aa +#define XK_Serbian_nje 0x6aa /* deprecated */ +#define XK_Serbian_tshe 0x6ab +#define XK_Macedonia_kje 0x6ac +#define XK_Byelorussian_shortu 0x6ae +#define XK_Cyrillic_dzhe 0x6af +#define XK_Serbian_dze 0x6af /* deprecated */ +#define XK_numerosign 0x6b0 +#define XK_Serbian_DJE 0x6b1 +#define XK_Macedonia_GJE 0x6b2 +#define XK_Cyrillic_IO 0x6b3 +#define XK_Ukrainian_IE 0x6b4 +#define XK_Ukranian_JE 0x6b4 /* deprecated */ +#define XK_Macedonia_DSE 0x6b5 +#define XK_Ukrainian_I 0x6b6 +#define XK_Ukranian_I 0x6b6 /* deprecated */ +#define XK_Ukrainian_YI 0x6b7 +#define XK_Ukranian_YI 0x6b7 /* deprecated */ +#define XK_Cyrillic_JE 0x6b8 +#define XK_Serbian_JE 0x6b8 /* deprecated */ +#define XK_Cyrillic_LJE 0x6b9 +#define XK_Serbian_LJE 0x6b9 /* deprecated */ +#define XK_Cyrillic_NJE 0x6ba +#define XK_Serbian_NJE 0x6ba /* deprecated */ +#define XK_Serbian_TSHE 0x6bb +#define XK_Macedonia_KJE 0x6bc +#define XK_Byelorussian_SHORTU 0x6be +#define XK_Cyrillic_DZHE 0x6bf +#define XK_Serbian_DZE 0x6bf /* deprecated */ +#define XK_Cyrillic_yu 0x6c0 +#define XK_Cyrillic_a 0x6c1 +#define XK_Cyrillic_be 0x6c2 +#define XK_Cyrillic_tse 0x6c3 +#define XK_Cyrillic_de 0x6c4 +#define XK_Cyrillic_ie 0x6c5 +#define XK_Cyrillic_ef 0x6c6 +#define XK_Cyrillic_ghe 0x6c7 +#define XK_Cyrillic_ha 0x6c8 +#define XK_Cyrillic_i 0x6c9 +#define XK_Cyrillic_shorti 0x6ca +#define XK_Cyrillic_ka 0x6cb +#define XK_Cyrillic_el 0x6cc +#define XK_Cyrillic_em 0x6cd +#define XK_Cyrillic_en 0x6ce +#define XK_Cyrillic_o 0x6cf +#define XK_Cyrillic_pe 0x6d0 +#define XK_Cyrillic_ya 0x6d1 +#define XK_Cyrillic_er 0x6d2 +#define XK_Cyrillic_es 0x6d3 +#define XK_Cyrillic_te 0x6d4 +#define XK_Cyrillic_u 0x6d5 +#define XK_Cyrillic_zhe 0x6d6 +#define XK_Cyrillic_ve 0x6d7 +#define XK_Cyrillic_softsign 0x6d8 +#define XK_Cyrillic_yeru 0x6d9 +#define XK_Cyrillic_ze 0x6da +#define XK_Cyrillic_sha 0x6db +#define XK_Cyrillic_e 0x6dc +#define XK_Cyrillic_shcha 0x6dd +#define XK_Cyrillic_che 0x6de +#define XK_Cyrillic_hardsign 0x6df +#define XK_Cyrillic_YU 0x6e0 +#define XK_Cyrillic_A 0x6e1 +#define XK_Cyrillic_BE 0x6e2 +#define XK_Cyrillic_TSE 0x6e3 +#define XK_Cyrillic_DE 0x6e4 +#define XK_Cyrillic_IE 0x6e5 +#define XK_Cyrillic_EF 0x6e6 +#define XK_Cyrillic_GHE 0x6e7 +#define XK_Cyrillic_HA 0x6e8 +#define XK_Cyrillic_I 0x6e9 +#define XK_Cyrillic_SHORTI 0x6ea +#define XK_Cyrillic_KA 0x6eb +#define XK_Cyrillic_EL 0x6ec +#define XK_Cyrillic_EM 0x6ed +#define XK_Cyrillic_EN 0x6ee +#define XK_Cyrillic_O 0x6ef +#define XK_Cyrillic_PE 0x6f0 +#define XK_Cyrillic_YA 0x6f1 +#define XK_Cyrillic_ER 0x6f2 +#define XK_Cyrillic_ES 0x6f3 +#define XK_Cyrillic_TE 0x6f4 +#define XK_Cyrillic_U 0x6f5 +#define XK_Cyrillic_ZHE 0x6f6 +#define XK_Cyrillic_VE 0x6f7 +#define XK_Cyrillic_SOFTSIGN 0x6f8 +#define XK_Cyrillic_YERU 0x6f9 +#define XK_Cyrillic_ZE 0x6fa +#define XK_Cyrillic_SHA 0x6fb +#define XK_Cyrillic_E 0x6fc +#define XK_Cyrillic_SHCHA 0x6fd +#define XK_Cyrillic_CHE 0x6fe +#define XK_Cyrillic_HARDSIGN 0x6ff +#endif /* XK_CYRILLIC */ + +/* + * Greek + * Byte 3 = 7 + */ + +#ifdef XK_GREEK +#define XK_Greek_ALPHAaccent 0x7a1 +#define XK_Greek_EPSILONaccent 0x7a2 +#define XK_Greek_ETAaccent 0x7a3 +#define XK_Greek_IOTAaccent 0x7a4 +#define XK_Greek_IOTAdiaeresis 0x7a5 +#define XK_Greek_OMICRONaccent 0x7a7 +#define XK_Greek_UPSILONaccent 0x7a8 +#define XK_Greek_UPSILONdieresis 0x7a9 +#define XK_Greek_OMEGAaccent 0x7ab +#define XK_Greek_accentdieresis 0x7ae +#define XK_Greek_horizbar 0x7af +#define XK_Greek_alphaaccent 0x7b1 +#define XK_Greek_epsilonaccent 0x7b2 +#define XK_Greek_etaaccent 0x7b3 +#define XK_Greek_iotaaccent 0x7b4 +#define XK_Greek_iotadieresis 0x7b5 +#define XK_Greek_iotaaccentdieresis 0x7b6 +#define XK_Greek_omicronaccent 0x7b7 +#define XK_Greek_upsilonaccent 0x7b8 +#define XK_Greek_upsilondieresis 0x7b9 +#define XK_Greek_upsilonaccentdieresis 0x7ba +#define XK_Greek_omegaaccent 0x7bb +#define XK_Greek_ALPHA 0x7c1 +#define XK_Greek_BETA 0x7c2 +#define XK_Greek_GAMMA 0x7c3 +#define XK_Greek_DELTA 0x7c4 +#define XK_Greek_EPSILON 0x7c5 +#define XK_Greek_ZETA 0x7c6 +#define XK_Greek_ETA 0x7c7 +#define XK_Greek_THETA 0x7c8 +#define XK_Greek_IOTA 0x7c9 +#define XK_Greek_KAPPA 0x7ca +#define XK_Greek_LAMDA 0x7cb +#define XK_Greek_LAMBDA 0x7cb +#define XK_Greek_MU 0x7cc +#define XK_Greek_NU 0x7cd +#define XK_Greek_XI 0x7ce +#define XK_Greek_OMICRON 0x7cf +#define XK_Greek_PI 0x7d0 +#define XK_Greek_RHO 0x7d1 +#define XK_Greek_SIGMA 0x7d2 +#define XK_Greek_TAU 0x7d4 +#define XK_Greek_UPSILON 0x7d5 +#define XK_Greek_PHI 0x7d6 +#define XK_Greek_CHI 0x7d7 +#define XK_Greek_PSI 0x7d8 +#define XK_Greek_OMEGA 0x7d9 +#define XK_Greek_alpha 0x7e1 +#define XK_Greek_beta 0x7e2 +#define XK_Greek_gamma 0x7e3 +#define XK_Greek_delta 0x7e4 +#define XK_Greek_epsilon 0x7e5 +#define XK_Greek_zeta 0x7e6 +#define XK_Greek_eta 0x7e7 +#define XK_Greek_theta 0x7e8 +#define XK_Greek_iota 0x7e9 +#define XK_Greek_kappa 0x7ea +#define XK_Greek_lamda 0x7eb +#define XK_Greek_lambda 0x7eb +#define XK_Greek_mu 0x7ec +#define XK_Greek_nu 0x7ed +#define XK_Greek_xi 0x7ee +#define XK_Greek_omicron 0x7ef +#define XK_Greek_pi 0x7f0 +#define XK_Greek_rho 0x7f1 +#define XK_Greek_sigma 0x7f2 +#define XK_Greek_finalsmallsigma 0x7f3 +#define XK_Greek_tau 0x7f4 +#define XK_Greek_upsilon 0x7f5 +#define XK_Greek_phi 0x7f6 +#define XK_Greek_chi 0x7f7 +#define XK_Greek_psi 0x7f8 +#define XK_Greek_omega 0x7f9 +#define XK_Greek_switch 0xFF7E /* Alias for mode_switch */ +#endif /* XK_GREEK */ + +/* + * Technical + * Byte 3 = 8 + */ + +#ifdef XK_TECHNICAL +#define XK_leftradical 0x8a1 +#define XK_topleftradical 0x8a2 +#define XK_horizconnector 0x8a3 +#define XK_topintegral 0x8a4 +#define XK_botintegral 0x8a5 +#define XK_vertconnector 0x8a6 +#define XK_topleftsqbracket 0x8a7 +#define XK_botleftsqbracket 0x8a8 +#define XK_toprightsqbracket 0x8a9 +#define XK_botrightsqbracket 0x8aa +#define XK_topleftparens 0x8ab +#define XK_botleftparens 0x8ac +#define XK_toprightparens 0x8ad +#define XK_botrightparens 0x8ae +#define XK_leftmiddlecurlybrace 0x8af +#define XK_rightmiddlecurlybrace 0x8b0 +#define XK_topleftsummation 0x8b1 +#define XK_botleftsummation 0x8b2 +#define XK_topvertsummationconnector 0x8b3 +#define XK_botvertsummationconnector 0x8b4 +#define XK_toprightsummation 0x8b5 +#define XK_botrightsummation 0x8b6 +#define XK_rightmiddlesummation 0x8b7 +#define XK_lessthanequal 0x8bc +#define XK_notequal 0x8bd +#define XK_greaterthanequal 0x8be +#define XK_integral 0x8bf +#define XK_therefore 0x8c0 +#define XK_variation 0x8c1 +#define XK_infinity 0x8c2 +#define XK_nabla 0x8c5 +#define XK_approximate 0x8c8 +#define XK_similarequal 0x8c9 +#define XK_ifonlyif 0x8cd +#define XK_implies 0x8ce +#define XK_identical 0x8cf +#define XK_radical 0x8d6 +#define XK_includedin 0x8da +#define XK_includes 0x8db +#define XK_intersection 0x8dc +#define XK_union 0x8dd +#define XK_logicaland 0x8de +#define XK_logicalor 0x8df +#define XK_partialderivative 0x8ef +#define XK_function 0x8f6 +#define XK_leftarrow 0x8fb +#define XK_uparrow 0x8fc +#define XK_rightarrow 0x8fd +#define XK_downarrow 0x8fe +#endif /* XK_TECHNICAL */ + +/* + * Special + * Byte 3 = 9 + */ + +#ifdef XK_SPECIAL +#define XK_blank 0x9df +#define XK_soliddiamond 0x9e0 +#define XK_checkerboard 0x9e1 +#define XK_ht 0x9e2 +#define XK_ff 0x9e3 +#define XK_cr 0x9e4 +#define XK_lf 0x9e5 +#define XK_nl 0x9e8 +#define XK_vt 0x9e9 +#define XK_lowrightcorner 0x9ea +#define XK_uprightcorner 0x9eb +#define XK_upleftcorner 0x9ec +#define XK_lowleftcorner 0x9ed +#define XK_crossinglines 0x9ee +#define XK_horizlinescan1 0x9ef +#define XK_horizlinescan3 0x9f0 +#define XK_horizlinescan5 0x9f1 +#define XK_horizlinescan7 0x9f2 +#define XK_horizlinescan9 0x9f3 +#define XK_leftt 0x9f4 +#define XK_rightt 0x9f5 +#define XK_bott 0x9f6 +#define XK_topt 0x9f7 +#define XK_vertbar 0x9f8 +#endif /* XK_SPECIAL */ + +/* + * Publishing + * Byte 3 = a + */ + +#ifdef XK_PUBLISHING +#define XK_emspace 0xaa1 +#define XK_enspace 0xaa2 +#define XK_em3space 0xaa3 +#define XK_em4space 0xaa4 +#define XK_digitspace 0xaa5 +#define XK_punctspace 0xaa6 +#define XK_thinspace 0xaa7 +#define XK_hairspace 0xaa8 +#define XK_emdash 0xaa9 +#define XK_endash 0xaaa +#define XK_signifblank 0xaac +#define XK_ellipsis 0xaae +#define XK_doubbaselinedot 0xaaf +#define XK_onethird 0xab0 +#define XK_twothirds 0xab1 +#define XK_onefifth 0xab2 +#define XK_twofifths 0xab3 +#define XK_threefifths 0xab4 +#define XK_fourfifths 0xab5 +#define XK_onesixth 0xab6 +#define XK_fivesixths 0xab7 +#define XK_careof 0xab8 +#define XK_figdash 0xabb +#define XK_leftanglebracket 0xabc +#define XK_decimalpoint 0xabd +#define XK_rightanglebracket 0xabe +#define XK_marker 0xabf +#define XK_oneeighth 0xac3 +#define XK_threeeighths 0xac4 +#define XK_fiveeighths 0xac5 +#define XK_seveneighths 0xac6 +#define XK_trademark 0xac9 +#define XK_signaturemark 0xaca +#define XK_trademarkincircle 0xacb +#define XK_leftopentriangle 0xacc +#define XK_rightopentriangle 0xacd +#define XK_emopencircle 0xace +#define XK_emopenrectangle 0xacf +#define XK_leftsinglequotemark 0xad0 +#define XK_rightsinglequotemark 0xad1 +#define XK_leftdoublequotemark 0xad2 +#define XK_rightdoublequotemark 0xad3 +#define XK_prescription 0xad4 +#define XK_minutes 0xad6 +#define XK_seconds 0xad7 +#define XK_latincross 0xad9 +#define XK_hexagram 0xada +#define XK_filledrectbullet 0xadb +#define XK_filledlefttribullet 0xadc +#define XK_filledrighttribullet 0xadd +#define XK_emfilledcircle 0xade +#define XK_emfilledrect 0xadf +#define XK_enopencircbullet 0xae0 +#define XK_enopensquarebullet 0xae1 +#define XK_openrectbullet 0xae2 +#define XK_opentribulletup 0xae3 +#define XK_opentribulletdown 0xae4 +#define XK_openstar 0xae5 +#define XK_enfilledcircbullet 0xae6 +#define XK_enfilledsqbullet 0xae7 +#define XK_filledtribulletup 0xae8 +#define XK_filledtribulletdown 0xae9 +#define XK_leftpointer 0xaea +#define XK_rightpointer 0xaeb +#define XK_club 0xaec +#define XK_diamond 0xaed +#define XK_heart 0xaee +#define XK_maltesecross 0xaf0 +#define XK_dagger 0xaf1 +#define XK_doubledagger 0xaf2 +#define XK_checkmark 0xaf3 +#define XK_ballotcross 0xaf4 +#define XK_musicalsharp 0xaf5 +#define XK_musicalflat 0xaf6 +#define XK_malesymbol 0xaf7 +#define XK_femalesymbol 0xaf8 +#define XK_telephone 0xaf9 +#define XK_telephonerecorder 0xafa +#define XK_phonographcopyright 0xafb +#define XK_caret 0xafc +#define XK_singlelowquotemark 0xafd +#define XK_doublelowquotemark 0xafe +#define XK_cursor 0xaff +#endif /* XK_PUBLISHING */ + +/* + * APL + * Byte 3 = b + */ + +#ifdef XK_APL +#define XK_leftcaret 0xba3 +#define XK_rightcaret 0xba6 +#define XK_downcaret 0xba8 +#define XK_upcaret 0xba9 +#define XK_overbar 0xbc0 +#define XK_downtack 0xbc2 +#define XK_upshoe 0xbc3 +#define XK_downstile 0xbc4 +#define XK_underbar 0xbc6 +#define XK_jot 0xbca +#define XK_quad 0xbcc +#define XK_uptack 0xbce +#define XK_circle 0xbcf +#define XK_upstile 0xbd3 +#define XK_downshoe 0xbd6 +#define XK_rightshoe 0xbd8 +#define XK_leftshoe 0xbda +#define XK_lefttack 0xbdc +#define XK_righttack 0xbfc +#endif /* XK_APL */ + +/* + * Hebrew + * Byte 3 = c + */ + +#ifdef XK_HEBREW +#define XK_hebrew_doublelowline 0xcdf +#define XK_hebrew_aleph 0xce0 +#define XK_hebrew_bet 0xce1 +#define XK_hebrew_beth 0xce1 /* deprecated */ +#define XK_hebrew_gimel 0xce2 +#define XK_hebrew_gimmel 0xce2 /* deprecated */ +#define XK_hebrew_dalet 0xce3 +#define XK_hebrew_daleth 0xce3 /* deprecated */ +#define XK_hebrew_he 0xce4 +#define XK_hebrew_waw 0xce5 +#define XK_hebrew_zain 0xce6 +#define XK_hebrew_zayin 0xce6 /* deprecated */ +#define XK_hebrew_chet 0xce7 +#define XK_hebrew_het 0xce7 /* deprecated */ +#define XK_hebrew_tet 0xce8 +#define XK_hebrew_teth 0xce8 /* deprecated */ +#define XK_hebrew_yod 0xce9 +#define XK_hebrew_finalkaph 0xcea +#define XK_hebrew_kaph 0xceb +#define XK_hebrew_lamed 0xcec +#define XK_hebrew_finalmem 0xced +#define XK_hebrew_mem 0xcee +#define XK_hebrew_finalnun 0xcef +#define XK_hebrew_nun 0xcf0 +#define XK_hebrew_samech 0xcf1 +#define XK_hebrew_samekh 0xcf1 /* deprecated */ +#define XK_hebrew_ayin 0xcf2 +#define XK_hebrew_finalpe 0xcf3 +#define XK_hebrew_pe 0xcf4 +#define XK_hebrew_finalzade 0xcf5 +#define XK_hebrew_finalzadi 0xcf5 /* deprecated */ +#define XK_hebrew_zade 0xcf6 +#define XK_hebrew_zadi 0xcf6 /* deprecated */ +#define XK_hebrew_qoph 0xcf7 +#define XK_hebrew_kuf 0xcf7 /* deprecated */ +#define XK_hebrew_resh 0xcf8 +#define XK_hebrew_shin 0xcf9 +#define XK_hebrew_taw 0xcfa +#define XK_hebrew_taf 0xcfa /* deprecated */ +#define XK_Hebrew_switch 0xFF7E /* Alias for mode_switch */ +#endif /* XK_HEBREW */ + diff --git a/Master/tlpkg/tlperl/lib/Tk/X11/license.terms b/Master/tlpkg/tlperl/lib/Tk/X11/license.terms new file mode 100644 index 00000000000..03ca6fcb319 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/X11/license.terms @@ -0,0 +1,39 @@ +This software is copyrighted by the Regents of the University of +California, Sun Microsystems, Inc., and other parties. The following +terms apply to all files associated with the software unless explicitly +disclaimed in individual files. + +The authors hereby grant permission to use, copy, modify, distribute, +and license this software and its documentation for any purpose, provided +that existing copyright notices are retained in all copies and that this +notice is included verbatim in any distributions. No written agreement, +license, or royalty fee is required for any of the authorized uses. +Modifications to this software may be copyrighted by their authors +and need not follow the licensing terms described here, provided that +the new terms are clearly indicated on the first page of each file where +they apply. + +IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY +FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES +ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY +DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. + +THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE +IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE +NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR +MODIFICATIONS. + +GOVERNMENT USE: If you are acquiring this software on behalf of the +U.S. government, the Government shall have only "Restricted Rights" +in the software and related documentation as defined in the Federal +Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you +are acquiring the software on behalf of the Department of Defense, the +software shall be classified as "Commercial Computer Software" and the +Government shall have only "Restricted Rights" as defined in Clause +252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the +authors grant the U.S. Government and others acting in its behalf +permission to use and distribute the software in accordance with the +terms specified in this license. diff --git a/Master/tlpkg/tlperl/lib/Tk/X11Font.pm b/Master/tlpkg/tlperl/lib/Tk/X11Font.pm new file mode 100644 index 00000000000..870dfd4b7dc --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/X11Font.pm @@ -0,0 +1,184 @@ +package Tk::X11Font; +use vars qw($VERSION); +$VERSION = '4.007'; # $Id: //depot/Tkutf8/Tk/X11Font.pm#7 $ + +require Tk::Widget; +require Tk::Xlib; +use strict; + +Construct Tk::Widget 'X11Font'; + +my @field = qw(foundry family weight slant swidth adstyle pixel + point xres yres space avgwidth registry encoding); + +map { eval "sub \u$_ { shift->elem('$_', \@_) }" } @field; + +use overload '""' => 'as_string'; + +sub new +{ + my $pkg = shift; + my $w = shift; + + my %me = (); + my $d = $w->Display; + + local $_; + + if(scalar(@_) == 1) + { + my $pattern = shift; + + if($pattern =~ /\A(-[^-]*){14}\Z/) + { + @me{@field} = split(/-/, substr($pattern,1)); + } + else + { + $me{Name} = $pattern; + + if($pattern =~ /^[^-]?-([^-]*-){2,}/) + { + my $f = $d->XListFonts($pattern,1); + + if($f && $f =~ /\A(-[^-]*){14}/) + { + my @f = split(/-/, substr($f,1)); + my @n = split(/-/, $pattern); + my %f = (); + my $i = 0; + + shift @n if($pattern =~ /\A-/); + + while(@n && @f) + { + if($n[0] eq '*') + { + shift @n; + } + elsif($n[0] eq $f[0]) + { + $f{$field[$i]} = shift @n; + } + $i++; + shift @f; + } + + %me = %f + unless(@n); + } + } + } + } + else + { + %me = @_; + } + + map { $me{$_} ||= '*' } @field; + + $me{Display} = $d; + $me{MainWin} = $w->MainWindow; + + bless \%me, $pkg; +} + +sub Pattern +{ + my $me = shift; + return join('-', '',@{$me}{@field}); +} + +sub Name +{ + my $me = shift; + my $max = wantarray ? shift || 128 : 1; + + if ($^O eq 'MSWin32' or ($^O eq 'cygwin' and $Tk::platform eq 'MSWin32')) + { + my $name = $me->{Name}; + if (!defined $name) + { + my $fm = $me->{'family'} || 'system'; + my $sz = -int($me->{'point'}/10) || -($me->{'pixel'}) || 12; + my @opt = (-family => $fm, -size => $sz ); + my $wt = $me->{'weight'}; + if (defined $wt) + { + $wt = 'normal' unless $wt =~ /bold/i; + push(@opt,-weight => lc($wt)); + } + my $sl = $me->{'slant'}; + if (defined $sl) + { + $sl = ($sl =~ /^[io]/) ? 'italic' : 'roman'; + push(@opt,-slant => $sl); + } + $name = join(' ',@opt); + } + return $name; + } + else + { + my $name = $me->{Name} || + join('-', '',@{$me}{@field}); + return $me->{Display}->XListFonts($name,$max); + } +} + +sub as_string +{ + return shift->Name; +} + +sub elem +{ + my $me = shift; + my $elem = shift; + + return undef + if(exists $me->{'Name'}); + + my $old = $me->{$elem}; + + $me->{$elem} = shift + if(@_); + + $old; +} + +sub Clone +{ + my $me = shift; + + $me = bless { %$me }, ref($me); + + unless(exists $me->{'Name'}) + { + while(@_) + { + my $k = shift; + my $v = shift || $me->{MainWin}->BackTrace('Tk::Font->Clone( key => value, ... )'); + $me->{$k} = $v; + } + } + + $me; +} + +sub ascent +{ + my $me = shift; + my $name = $me->Name; + $me->{MainWin}->fontMetrics($name, '-ascent'); +} + +sub descent +{ + my $me = shift; + my $name = $me->Name; + $me->{MainWin}->fontMetrics($name, '-descent'); +} + +1; + diff --git a/Master/tlpkg/tlperl/lib/Tk/Xcamel.gif b/Master/tlpkg/tlperl/lib/Tk/Xcamel.gif Binary files differnew file mode 100644 index 00000000000..cb88bc0afd8 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Xcamel.gif diff --git a/Master/tlpkg/tlperl/lib/Tk/Xlib.pm b/Master/tlpkg/tlperl/lib/Tk/Xlib.pm new file mode 100644 index 00000000000..1432361dc18 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Xlib.pm @@ -0,0 +1,15 @@ +package Tk::Xlib; +require DynaLoader; + +use vars qw($VERSION); +$VERSION = '4.004'; # $Id: //depot/Tkutf8/Xlib/Xlib.pm#4 $ + +use Tk qw($XS_VERSION); +use Exporter; + +use base qw(DynaLoader Exporter); +@EXPORT_OK = qw(XDrawString XLoadFont XDrawRectangle); + +bootstrap Tk::Xlib; + +1; diff --git a/Master/tlpkg/tlperl/lib/Tk/Xrm.pm b/Master/tlpkg/tlperl/lib/Tk/Xrm.pm new file mode 100644 index 00000000000..271ad59a237 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Xrm.pm @@ -0,0 +1,11 @@ +package Tk::Xrm; + +use vars qw($VERSION); +$VERSION = '4.004'; # $Id: //depot/Tkutf8/Tk/Xrm.pm#4 $ + +use Tk (); +1; +__END__ + +=cut + diff --git a/Master/tlpkg/tlperl/lib/Tk/act_folder.xbm b/Master/tlpkg/tlperl/lib/Tk/act_folder.xbm new file mode 100644 index 00000000000..fc82949945b --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/act_folder.xbm @@ -0,0 +1,5 @@ +#define act_folder_width 16 +#define act_folder_height 10 +static unsigned char act_folder_bits[] = { + 0xfc, 0x00, 0xaa, 0x0f, 0x55, 0x15, 0xeb, 0xff, 0x15, 0x80, 0x0b, 0x40, + 0x05, 0x20, 0x03, 0x10, 0x01, 0x08, 0xff, 0x07}; diff --git a/Master/tlpkg/tlperl/lib/Tk/act_folder.xpm b/Master/tlpkg/tlperl/lib/Tk/act_folder.xpm new file mode 100644 index 00000000000..0e7d682713a --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/act_folder.xpm @@ -0,0 +1,22 @@ +/* XPM */ +static char * act_folder_xpm[] = { +/* width height num_colors chars_per_pixel */ +"16 12 4 1", +/* colors */ +" s None c None", +". c black", +"X c yellow", +"o c #5B5B57574646", +/* pixels */ +" .... ", +" .XXXX. ", +" .XXXXXX. ", +"............. ", +".oXoXoXoXoXo. ", +".XoX............", +".oX.XXXXXXXXXXX.", +".Xo.XXXXXXXXXX. ", +".o.XXXXXXXXXXX. ", +".X.XXXXXXXXXXX. ", +"..XXXXXXXXXX.. ", +"............. "}; diff --git a/Master/tlpkg/tlperl/lib/Tk/anim.gif b/Master/tlpkg/tlperl/lib/Tk/anim.gif Binary files differnew file mode 100644 index 00000000000..96a50b701be --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/anim.gif diff --git a/Master/tlpkg/tlperl/lib/Tk/arrowdownwin.xbm b/Master/tlpkg/tlperl/lib/Tk/arrowdownwin.xbm new file mode 100644 index 00000000000..ea43fc75e7a --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/arrowdownwin.xbm @@ -0,0 +1,5 @@ +#define arrowdownwin2_width 9 +#define arrowdownwin2_height 13 +static char arrowdownwin2_bits[] = { + 0x00,0xfe,0x00,0xfe,0x00,0xfe,0x00,0xfe,0x00,0xfe,0x7c,0xfe,0x38,0xfe,0x10, + 0xfe,0x00,0xfe,0x00,0xfe,0x00,0xfe,0x00,0xfe,0x00,0xfe}; diff --git a/Master/tlpkg/tlperl/lib/Tk/balArrow.xbm b/Master/tlpkg/tlperl/lib/Tk/balArrow.xbm new file mode 100644 index 00000000000..ee0664a4727 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/balArrow.xbm @@ -0,0 +1,4 @@ +#define balArrow_width 6 +#define balArrow_height 6 +static char balArrow_bits[] = { + 0x1f, 0x07, 0x07, 0x09, 0x11, 0x20}; diff --git a/Master/tlpkg/tlperl/lib/Tk/cbxarrow.xbm b/Master/tlpkg/tlperl/lib/Tk/cbxarrow.xbm new file mode 100644 index 00000000000..ae4054488b9 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/cbxarrow.xbm @@ -0,0 +1,6 @@ +#define cbxarrow_width 11 +#define cbxarrow_height 14 +static char cbxarrow_bits[] = { + 0x00, 0x00, 0x70, 0x00, 0x70, 0x00, 0x70, 0x00, 0x70, 0x00, 0x70, 0x00, + 0xfe, 0x03, 0xfc, 0x01, 0xf8, 0x00, 0x70, 0x00, 0x20, 0x00, 0x00, 0x00, + 0xfe, 0x03, 0xfe, 0x03}; diff --git a/Master/tlpkg/tlperl/lib/Tk/file.xbm b/Master/tlpkg/tlperl/lib/Tk/file.xbm new file mode 100644 index 00000000000..7bf12bb4c9f --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/file.xbm @@ -0,0 +1,5 @@ +#define file_width 12 +#define file_height 12 +static unsigned char file_bits[] = { + 0xfe, 0x00, 0x02, 0x03, 0x02, 0x02, 0x02, 0x02, 0x02, 0x02, 0x02, 0x02, + 0x02, 0x02, 0x02, 0x02, 0x02, 0x02, 0x02, 0x02, 0x02, 0x02, 0xfe, 0x03}; diff --git a/Master/tlpkg/tlperl/lib/Tk/file.xpm b/Master/tlpkg/tlperl/lib/Tk/file.xpm new file mode 100644 index 00000000000..10cc24f9a1e --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/file.xpm @@ -0,0 +1,18 @@ +/* XPM */ +static char * file_xpm[] = { +"12 12 3 1", +" s None c None", +". c #000000000000", +"X c white", +" ........ ", +" .XXXXXX. ", +" .XXXXXX... ", +" .XXXXXXXX. ", +" .XXXXXXXX. ", +" .XXXXXXXX. ", +" .XXXXXXXX. ", +" .XXXXXXXX. ", +" .XXXXXXXX. ", +" .XXXXXXXX. ", +" .XXXXXXXX. ", +" .......... "}; diff --git a/Master/tlpkg/tlperl/lib/Tk/folder.xbm b/Master/tlpkg/tlperl/lib/Tk/folder.xbm new file mode 100644 index 00000000000..0398f0de777 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/folder.xbm @@ -0,0 +1,5 @@ +#define folder_width 16 +#define folder_height 10 +static unsigned char folder_bits[] = { + 0xfc, 0x00, 0x02, 0x07, 0x01, 0x08, 0x01, 0x08, 0x01, 0x08, 0x01, 0x08, + 0x01, 0x08, 0x01, 0x08, 0x01, 0x08, 0xff, 0x07}; diff --git a/Master/tlpkg/tlperl/lib/Tk/folder.xpm b/Master/tlpkg/tlperl/lib/Tk/folder.xpm new file mode 100644 index 00000000000..fda7c15a549 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/folder.xpm @@ -0,0 +1,21 @@ +/* XPM */ +static char * folder_xpm[] = { +/* width height num_colors chars_per_pixel */ +"16 12 3 1", +/* colors */ +" s None c None", +". c black", +"X c #f0ff80", +/* pixels */ +" .... ", +" .XXXX. ", +" .XXXXXX. ", +"............. ", +".XXXXXXXXXXX. ", +".XXXXXXXXXXX. ", +".XXXXXXXXXXX. ", +".XXXXXXXXXXX. ", +".XXXXXXXXXXX. ", +".XXXXXXXXXXX. ", +".XXXXXXXXXXX. ", +"............. "}; diff --git a/Master/tlpkg/tlperl/lib/Tk/icon.gif b/Master/tlpkg/tlperl/lib/Tk/icon.gif Binary files differnew file mode 100644 index 00000000000..dfe6b6621f2 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/icon.gif diff --git a/Master/tlpkg/tlperl/lib/Tk/install.pm b/Master/tlpkg/tlperl/lib/Tk/install.pm new file mode 100644 index 00000000000..2392dc84fca --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/install.pm @@ -0,0 +1,37 @@ +package Tk::install; +require Exporter; + +use vars qw($VERSION @EXPORT); +$VERSION = '4.004'; # $Id: //depot/Tkutf8/Tk/install.pm#4 $ + +use base qw(Exporter); +@EXPORT = qw(installbin); + +use Config; + +sub installbin +{ + my $prog = shift(@ARGV); + my $start = $Config{'startperl'}; + my $perl = $Config{'perl'} || 'perl'; + $start =~ s/$perl$/$prog/; + while (($src,$dst) = splice(@ARGV,0,2)) + { + open(SRC,"<$src") || die "Cannot open $src:$!"; + my $line = <SRC>; + $line =~ s/^#!\s*\S+/$start/; + warn $line; + chmod(0755,$dst) if (-f $dst); + open(DST,">$dst") || die "Cannot open $dst:$!"; + print "installbin $src => $dst\n"; + do + { + print DST $line; + } while (defined($line = <SRC>)); + close(SRC); + close(DST); + chmod(0555,$dst); + } +} + +1; diff --git a/Master/tlpkg/tlperl/lib/Tk/license.terms b/Master/tlpkg/tlperl/lib/Tk/license.terms new file mode 100644 index 00000000000..6a5d3728366 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/license.terms @@ -0,0 +1,35 @@ +This software is copyrighted by the Regents of the University of +California, Sun Microsystems, Inc., and other parties. The following +terms apply to all files associated with the software unless explicitly +disclaimed in individual files. + +The authors hereby grant permission to use, copy, modify, distribute, +and license this software and its documentation for any purpose, provided +that existing copyright notices are retained in all copies and that this +notice is included verbatim in any distributions. No written agreement, +license, or royalty fee is required for any of the authorized uses. +Modifications to this software may be copyrighted by their authors +and need not follow the licensing terms described here, provided that +the new terms are clearly indicated on the first page of each file where +they apply. + +IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY +FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES +ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY +DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. + +THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE +IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE +NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR +MODIFICATIONS. + +RESTRICTED RIGHTS: Use, duplication or disclosure by the government +is subject to the restrictions as set forth in subparagraph (c) (1) (ii) +of the Rights in Technical Data and Computer Software Clause as DFARS +252.227-7013 and FAR 52.227-19. +0 in license.terms +0 in license.terms +0 in license.terms diff --git a/Master/tlpkg/tlperl/lib/Tk/openfile.xbm b/Master/tlpkg/tlperl/lib/Tk/openfile.xbm new file mode 100644 index 00000000000..859e2e57608 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/openfile.xbm @@ -0,0 +1,5 @@ +#define openfile_width 16 +#define openfile_height 12 +static unsigned char openfile_bits[] = { + 0x00, 0x00, 0xfc, 0x00, 0x02, 0x07, 0x01, 0x08, 0xc1, 0xff, 0xa1, 0xaa, + 0x51, 0x55, 0xa9, 0x2a, 0x55, 0x15, 0xab, 0x0a, 0xff, 0x07, 0x00, 0x00}; diff --git a/Master/tlpkg/tlperl/lib/Tk/openfolder.xbm b/Master/tlpkg/tlperl/lib/Tk/openfolder.xbm new file mode 100644 index 00000000000..59ee624efd0 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/openfolder.xbm @@ -0,0 +1,5 @@ +#define openfolder_width 16 +#define openfolder_height 10 +static unsigned char openfolder_bits[] = { + 0xfc, 0x00, 0x02, 0x07, 0x01, 0x08, 0xc1, 0xff, 0x21, 0x80, 0x11, 0x40, + 0x09, 0x20, 0x05, 0x10, 0x03, 0x08, 0xff, 0x07}; diff --git a/Master/tlpkg/tlperl/lib/Tk/openfolder.xpm b/Master/tlpkg/tlperl/lib/Tk/openfolder.xpm new file mode 100644 index 00000000000..191fe1e72bc --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/openfolder.xpm @@ -0,0 +1,21 @@ +/* XPM */ +static char * openfolder_xpm[] = { +/* width height num_colors chars_per_pixel */ +"16 12 3 1", +/* colors */ +" s None c None", +". c black", +"X c #f0ff80", +/* pixels */ +" .... ", +" .XXXX. ", +" .XXXXXX. ", +"............. ", +".XXXXXXXXXXX. ", +".XXX............", +".XX.XXXXXXXXXXX.", +".XX.XXXXXXXXXX. ", +".X.XXXXXXXXXXX. ", +".X.XXXXXXXXXXX. ", +"..XXXXXXXXXX.. ", +"............. "}; diff --git a/Master/tlpkg/tlperl/lib/Tk/prolog.ps b/Master/tlpkg/tlperl/lib/Tk/prolog.ps new file mode 100644 index 00000000000..409e06a65a0 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/prolog.ps @@ -0,0 +1,284 @@ +%%BeginProlog +50 dict begin + +% This is a standard prolog for Postscript generated by Tk's canvas +% widget. +% SCCS: @(#) prolog.ps 1.5 96/02/17 17:45:11 + +% The definitions below just define all of the variables used in +% any of the procedures here. This is needed for obscure reasons +% explained on p. 716 of the Postscript manual (Section H.2.7, +% "Initializing Variables," in the section on Encapsulated Postscript). + +/baseline 0 def +/stipimage 0 def +/height 0 def +/justify 0 def +/lineLength 0 def +/spacing 0 def +/stipple 0 def +/strings 0 def +/xoffset 0 def +/yoffset 0 def +/tmpstip null def + +% Define the array ISOLatin1Encoding (which specifies how characters are +% encoded for ISO-8859-1 fonts), if it isn't already present (Postscript +% level 2 is supposed to define it, but level 1 doesn't). + +systemdict /ISOLatin1Encoding known not { + /ISOLatin1Encoding [ + /space /space /space /space /space /space /space /space + /space /space /space /space /space /space /space /space + /space /space /space /space /space /space /space /space + /space /space /space /space /space /space /space /space + /space /exclam /quotedbl /numbersign /dollar /percent /ampersand + /quoteright + /parenleft /parenright /asterisk /plus /comma /minus /period /slash + /zero /one /two /three /four /five /six /seven + /eight /nine /colon /semicolon /less /equal /greater /question + /at /A /B /C /D /E /F /G + /H /I /J /K /L /M /N /O + /P /Q /R /S /T /U /V /W + /X /Y /Z /bracketleft /backslash /bracketright /asciicircum /underscore + /quoteleft /a /b /c /d /e /f /g + /h /i /j /k /l /m /n /o + /p /q /r /s /t /u /v /w + /x /y /z /braceleft /bar /braceright /asciitilde /space + /space /space /space /space /space /space /space /space + /space /space /space /space /space /space /space /space + /dotlessi /grave /acute /circumflex /tilde /macron /breve /dotaccent + /dieresis /space /ring /cedilla /space /hungarumlaut /ogonek /caron + /space /exclamdown /cent /sterling /currency /yen /brokenbar /section + /dieresis /copyright /ordfeminine /guillemotleft /logicalnot /hyphen + /registered /macron + /degree /plusminus /twosuperior /threesuperior /acute /mu /paragraph + /periodcentered + /cedillar /onesuperior /ordmasculine /guillemotright /onequarter + /onehalf /threequarters /questiondown + /Agrave /Aacute /Acircumflex /Atilde /Adieresis /Aring /AE /Ccedilla + /Egrave /Eacute /Ecircumflex /Edieresis /Igrave /Iacute /Icircumflex + /Idieresis + /Eth /Ntilde /Ograve /Oacute /Ocircumflex /Otilde /Odieresis /multiply + /Oslash /Ugrave /Uacute /Ucircumflex /Udieresis /Yacute /Thorn + /germandbls + /agrave /aacute /acircumflex /atilde /adieresis /aring /ae /ccedilla + /egrave /eacute /ecircumflex /edieresis /igrave /iacute /icircumflex + /idieresis + /eth /ntilde /ograve /oacute /ocircumflex /otilde /odieresis /divide + /oslash /ugrave /uacute /ucircumflex /udieresis /yacute /thorn + /ydieresis + ] def +} if + +% font ISOEncode font +% This procedure changes the encoding of a font from the default +% Postscript encoding to ISOLatin1. It's typically invoked just +% before invoking "setfont". The body of this procedure comes from +% Section 5.6.1 of the Postscript book. + +/ISOEncode { + dup length dict begin + {1 index /FID ne {def} {pop pop} ifelse} forall + /Encoding ISOLatin1Encoding def + currentdict + end + + % I'm not sure why it's necessary to use "definefont" on this new + % font, but it seems to be important; just use the name "Temporary" + % for the font. + + /Temporary exch definefont +} bind def + +% StrokeClip +% +% This procedure converts the current path into a clip area under +% the assumption of stroking. It's a bit tricky because some Postscript +% interpreters get errors during strokepath for dashed lines. If +% this happens then turn off dashes and try again. + +/StrokeClip { + {strokepath} stopped { + (This Postscript printer gets limitcheck overflows when) = + (stippling dashed lines; lines will be printed solid instead.) = + [] 0 setdash strokepath} if + clip +} bind def + +% desiredSize EvenPixels closestSize +% +% The procedure below is used for stippling. Given the optimal size +% of a dot in a stipple pattern in the current user coordinate system, +% compute the closest size that is an exact multiple of the device's +% pixel size. This allows stipple patterns to be displayed without +% aliasing effects. + +/EvenPixels { + % Compute exact number of device pixels per stipple dot. + dup 0 matrix currentmatrix dtransform + dup mul exch dup mul add sqrt + + % Round to an integer, make sure the number is at least 1, and compute + % user coord distance corresponding to this. + dup round dup 1 lt {pop 1} if + exch div mul +} bind def + +% width height string StippleFill -- +% +% Given a path already set up and a clipping region generated from +% it, this procedure will fill the clipping region with a stipple +% pattern. "String" contains a proper image description of the +% stipple pattern and "width" and "height" give its dimensions. Each +% stipple dot is assumed to be about one unit across in the current +% user coordinate system. This procedure trashes the graphics state. + +/StippleFill { + % The following code is needed to work around a NeWSprint bug. + + /tmpstip 1 index def + + % Change the scaling so that one user unit in user coordinates + % corresponds to the size of one stipple dot. + 1 EvenPixels dup scale + + % Compute the bounding box occupied by the path (which is now + % the clipping region), and round the lower coordinates down + % to the nearest starting point for the stipple pattern. Be + % careful about negative numbers, since the rounding works + % differently on them. + + pathbbox + 4 2 roll + 5 index div dup 0 lt {1 sub} if cvi 5 index mul 4 1 roll + 6 index div dup 0 lt {1 sub} if cvi 6 index mul 3 2 roll + + % Stack now: width height string y1 y2 x1 x2 + % Below is a doubly-nested for loop to iterate across this area + % in units of the stipple pattern size, going up columns then + % across rows, blasting out a stipple-pattern-sized rectangle at + % each position + + 6 index exch { + 2 index 5 index 3 index { + % Stack now: width height string y1 y2 x y + + gsave + 1 index exch translate + 5 index 5 index true matrix tmpstip imagemask + grestore + } for + pop + } for + pop pop pop pop pop +} bind def + +% -- AdjustColor -- +% Given a color value already set for output by the caller, adjusts +% that value to a grayscale or mono value if requested by the CL +% variable. + +/AdjustColor { + CL 2 lt { + currentgray + CL 0 eq { + .5 lt {0} {1} ifelse + } if + setgray + } if +} bind def + +% x y strings spacing xoffset yoffset justify stipple DrawText -- +% This procedure does all of the real work of drawing text. The +% color and font must already have been set by the caller, and the +% following arguments must be on the stack: +% +% x, y - Coordinates at which to draw text. +% strings - An array of strings, one for each line of the text item, +% in order from top to bottom. +% spacing - Spacing between lines. +% xoffset - Horizontal offset for text bbox relative to x and y: 0 for +% nw/w/sw anchor, -0.5 for n/center/s, and -1.0 for ne/e/se. +% yoffset - Vertical offset for text bbox relative to x and y: 0 for +% nw/n/ne anchor, +0.5 for w/center/e, and +1.0 for sw/s/se. +% justify - 0 for left justification, 0.5 for center, 1 for right justify. +% stipple - Boolean value indicating whether or not text is to be +% drawn in stippled fashion. If text is stippled, +% procedure StippleText must have been defined to call +% StippleFill in the right way. +% +% Also, when this procedure is invoked, the color and font must already +% have been set for the text. + +/DrawText { + /stipple exch def + /justify exch def + /yoffset exch def + /xoffset exch def + /spacing exch def + /strings exch def + + % First scan through all of the text to find the widest line. + + /lineLength 0 def + strings { + stringwidth pop + dup lineLength gt {/lineLength exch def} {pop} ifelse + newpath + } forall + + % Compute the baseline offset and the actual font height. + + 0 0 moveto (TXygqPZ) false charpath + pathbbox dup /baseline exch def + exch pop exch sub /height exch def pop + newpath + + % Translate coordinates first so that the origin is at the upper-left + % corner of the text's bounding box. Remember that x and y for + % positioning are still on the stack. + + translate + lineLength xoffset mul + strings length 1 sub spacing mul height add yoffset mul translate + + % Now use the baseline and justification information to translate so + % that the origin is at the baseline and positioning point for the + % first line of text. + + justify lineLength mul baseline neg translate + + % Iterate over each of the lines to output it. For each line, + % compute its width again so it can be properly justified, then + % display it. + + strings { + dup stringwidth pop + justify neg mul 0 moveto + stipple { + + % The text is stippled, so turn it into a path and print + % by calling StippledText, which in turn calls StippleFill. + % Unfortunately, many Postscript interpreters will get + % overflow errors if we try to do the whole string at + % once, so do it a character at a time. + + gsave + /char (X) def + { + char 0 3 -1 roll put + currentpoint + gsave + char true charpath clip StippleText + grestore + char stringwidth translate + moveto + } forall + grestore + } {show} ifelse + 0 spacing neg translate + } forall +} bind def + +%%EndProlog diff --git a/Master/tlpkg/tlperl/lib/Tk/reindex.pl b/Master/tlpkg/tlperl/lib/Tk/reindex.pl new file mode 100644 index 00000000000..7af5cc1d13f --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/reindex.pl @@ -0,0 +1,33 @@ +#!/bin/perl + +use lib qw(/home1/gbartels/textlist); +use Tk; + +use Tk::TextReindex qw(Tk::ROText ROTextReindex); + +$mw=new MainWindow; + +my $idx; + +$w=$mw->ROTextReindex()->pack(-side => "top"); +$t=$mw->Label(-textvariable => \$idx)->pack(-side => "bottom"); + +$w->bind('<Key>',sub{$idx=$w->index("insert")}); + +$w->insert('end',"abcd\n"); +$w->insert('end',"efgh\n"); +$w->insert('end',"mnop\n"); +$w->insert('end',"qrst\n"); +$w->insert('end',"uvwx\n"); + +$w->insert('2.0',"ijkl\n"); + +my $string = $w->get('4.0'); + + +my $result = "reading index 4.0 : expect string to equal >q<, actual value is $string \n"; +$w->insert('end',$result); + +print $result; + +MainLoop; diff --git a/Master/tlpkg/tlperl/lib/Tk/srcfile.xpm b/Master/tlpkg/tlperl/lib/Tk/srcfile.xpm new file mode 100644 index 00000000000..06a40a96c84 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/srcfile.xpm @@ -0,0 +1,18 @@ +/* XPM */ +static char * srcfile_xpm[] = { +"12 12 3 1", +" s None c None", +". c #000000000000", +"X c gray91", +" ........ ", +" .XXXXXX. ", +" .XXXXXX... ", +" .XXXXXXXX. ", +" .XX...XXX. ", +" .X.XXX.XX. ", +" .X.XXXXXX. ", +" .X.XXXXXX. ", +" .XX....XX. ", +" .XXXXXXXX. ", +" .XXXXXXXX. ", +" .......... "}; diff --git a/Master/tlpkg/tlperl/lib/Tk/textfile.xpm b/Master/tlpkg/tlperl/lib/Tk/textfile.xpm new file mode 100644 index 00000000000..8fa8d2f9032 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/textfile.xpm @@ -0,0 +1,18 @@ +/* XPM */ +static char * textfile_xpm[] = { +"12 12 3 1", +" s None c None", +". c #000000000000", +"X c #E0E0FFFFE0E0", +" ........ ", +" .XXXXXX. ", +" .XXXXXX... ", +" .X....XXX. ", +" .XXXXXXXX. ", +" .X...XXXX. ", +" .XXXXXXXX. ", +" .X.....XX. ", +" .XXXXXXXX. ", +" .X.....XX. ", +" .XXXXXXXX. ", +" .......... "}; diff --git a/Master/tlpkg/tlperl/lib/Tk/tkGlue.def b/Master/tlpkg/tlperl/lib/Tk/tkGlue.def new file mode 100644 index 00000000000..2f1662c71c2 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/tkGlue.def @@ -0,0 +1,130 @@ +#ifdef CAN_PROTOTYPE +#define XSdec(x) XS(x) +#else +#define XSdec(x) void x() +#endif + +#define TKXSRETURN(off) \ + STMT_START { \ + IV ptkAdj = (off); \ + XSRETURN(ptkAdj); \ + } STMT_END + +#ifndef PATCHLEVEL +#include <patchlevel.h> +#endif + +#if defined(PATCHLEVEL) && (PATCHLEVEL < 5) +#define PL_sv_undef sv_undef +#define PL_tainting tainting +#define PL_tainted tainted +#define PL_stack_base stack_base +#define PL_stack_sp stack_sp +#define PL_curcop curcop +#endif + +#ifndef CopSTASH +#define CopSTASH(c) c->cop_stash +#define CopSTASH_set(c,h) (CopSTASH(c) = h) +#endif + +#ifndef dTHX +#define dTHR int maybeTHR +#endif + +#ifndef dTHXs +#ifdef PERL_IMPLICIT_SYS +#define dTHXs dTHX +#else +#define dTHR int maybeTHR +#endif +#endif + +#ifndef ERRSV +#define ERRSV GvSV(errgv) +#endif + +#ifndef aTHX_ +#define aTHX_ +#endif + +#ifndef pTHX_ +#define pTHX_ +#endif + +#ifdef dirty +#undef dirty +#endif +#ifdef bufptr +#undef bufptr +#endif +#ifdef colors +#undef colors +#endif +#ifdef JOIN +#undef JOIN +#endif + +#ifdef na +#if PATCHLEVEL >= 5 +#undef na +#endif +#endif + + +#define Tcl_Interp HV +#define LangCallback SV +#define Var SV * +#define LangResultSave AV +struct Lang_CmdInfo; +#define Tcl_Command struct Lang_CmdInfo * +struct WrappedRegExp; +#define Tcl_RegExp struct WrappedRegExp * +#define Tcl_Obj SV +#define Tcl_DString SV * + +#ifndef PerlIO +#define PerlIO FILE +#define PerlIO_stderr() stderr +#define PerlIO_printf fprintf +#define PerlIO_flush(f) Fflush(f) +#define PerlIO_vprintf(f,fmt,a) vfprintf(f,fmt,a) +#define PerlIO_putc(f,c) fputc(c,f) +#define PerlIO_fileno(f) fileno(f) + +/* Now our interface to Configure's FILE_xxx macros */ + +#ifdef USE_STDIO_PTR +#define PerlIO_has_cntptr(f) 1 +#define PerlIO_get_ptr(f) FILE_ptr(f) +#define PerlIO_get_cnt(f) FILE_cnt(f) + +#ifdef FILE_CNT_LVALUE +#define PerlIO_canset_cnt(f) 1 +#ifdef FILE_PTR_LVALUE +#define PerlIO_fast_gets(f) 1 +#endif +#define PerlIO_set_cnt(f,c) (FILE_cnt(f) = (c)) +#else +#define PerlIO_canset_cnt(f) 0 +#define PerlIO_set_cnt(f,c) abort() +#endif + +#ifdef FILE_PTR_LVALUE +#define PerlIO_set_ptrcnt(f,p,c) (FILE_ptr(f) = (p), PerlIO_set_cnt(f,c)) +#else +#define PerlIO_set_ptrcnt(f,p,c) abort() +#endif + +#else /* USE_STDIO_PTR */ + +#define PerlIO_has_cntptr(f) 0 +#define PerlIO_get_cnt(f) (abort(),0) +#define PerlIO_get_ptr(f) (abort(),0) +#define PerlIO_set_cnt(f,c) abort() +#define PerlIO_set_ptrcnt(f,p,c) abort() + +#endif /* USE_STDIO_PTR */ + +#endif + diff --git a/Master/tlpkg/tlperl/lib/Tk/tkGlue.h b/Master/tlpkg/tlperl/lib/Tk/tkGlue.h new file mode 100644 index 00000000000..31a7f861700 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/tkGlue.h @@ -0,0 +1,79 @@ +#ifndef _TKGLUE +#define _TKGLUE + +#ifndef BASEEXT +#define BASEEXT "Tk" +#endif + +#ifndef _TKOPTION +#include "pTk/tkOption.h" +#include "pTk/tkOption_f.h" +#endif + +typedef struct EventAndKeySym + {XEvent event; + KeySym keySym; + Tcl_Interp *interp; + Tk_Window tkwin; + SV *window; + } EventAndKeySym; + +typedef struct Lang_CmdInfo + {Tcl_CmdInfo Tk; + Tcl_Interp *interp; + Tk_Window tkwin; + SV *image; + Tk_Font tkfont; + } Lang_CmdInfo; + +#include "vtab.def" + + +#define VTABLE_INIT() IMPORT_VTABLES + +extern Lang_CmdInfo *WindowCommand _ANSI_ARGS_((SV *win,HV **hptr, int moan)); +extern Tk_Window SVtoWindow _ANSI_ARGS_((SV *win)); +extern Tk_Font SVtoFont _ANSI_ARGS_((SV *win)); +extern int Call_Tk _ANSI_ARGS_((Lang_CmdInfo *info,int argc, SV **args)); +extern HV *InterpHv _ANSI_ARGS_((Tcl_Interp *interp,int fatal)); +extern SV *WidgetRef _ANSI_ARGS_((Tcl_Interp *interp, char *path)); +extern SV *ObjectRef _ANSI_ARGS_((Tcl_Interp *interp, char *path)); +extern SV *TkToWidget _ANSI_ARGS_((Tk_Window tkwin,Tcl_Interp **pinterp)); +extern SV *FindTkVarName _ANSI_ARGS_((CONST char *varName,int flags)); +extern void EnterWidgetMethods _ANSI_ARGS_((char *package, ...)); +extern SV *MakeReference _ANSI_ARGS_((SV * sv)); +extern Tk_Window TkToMainWindow _ANSI_ARGS_((Tk_Window tkwin)); +extern void Lang_TkSubCommand _ANSI_ARGS_ ((char *name, Tcl_ObjCmdProc *proc)); +extern void Lang_TkCommand _ANSI_ARGS_ ((char *name, Tcl_ObjCmdProc *proc)); +extern SV *XEvent_Info _((EventAndKeySym *obj,char *s)); +extern EventAndKeySym *SVtoEventAndKeySym _((SV *arg)); +extern int XSTkCommand _ANSI_ARGS_((CV *cv, int mwcd, Tcl_ObjCmdProc *proc, int items, SV **args)); + +extern XS(XStoWidget); + +EXTERN void ClearErrorInfo _ANSI_ARGS_((SV *interp)); +EXTERN Tk_Window mainWindow; +EXTERN void DumpStack _ANSI_ARGS_((CONST char *who)); +EXTERN void Boot_Glue (pTHX); +EXTERN void Boot_Tix (pTHX); +EXTERN void install_vtab _ANSI_ARGS_((char *name, void *table, size_t size)); +extern SV *TagIt _((SV *sv, char *type)); +extern void Font_DESTROY _((SV *sv)); +struct pTkCheckChain; +extern void Tk_CheckHash _((SV *sv,struct pTkCheckChain *chain)); + +extern int has_highbit(CONST char *s,int l); +extern SV * sv_maybe_utf8(SV *sv); +extern SV * Lang_SystemEncoding(void); + +#ifndef WIN32 +#define HWND void * +#endif +EXTERN HWND SVtoHWND _ANSI_ARGS_((SV *win)); + +#ifdef WIN32 +#include "pTk/tkWinInt.h" +#endif + +#endif + diff --git a/Master/tlpkg/tlperl/lib/Tk/tkGlue.m b/Master/tlpkg/tlperl/lib/Tk/tkGlue.m new file mode 100644 index 00000000000..922d1426a55 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/tkGlue.m @@ -0,0 +1,74 @@ +#ifndef _TKGLUE_VM +#define _TKGLUE_VM +#include "tkGlue_f.h" +#ifndef NO_VTABLES +#ifndef Call_Tk +# define Call_Tk (*TkglueVptr->V_Call_Tk) +#endif + +#ifndef EnterWidgetMethods +# define EnterWidgetMethods (*TkglueVptr->V_EnterWidgetMethods) +#endif + +#ifndef FindTkVarName +# define FindTkVarName (*TkglueVptr->V_FindTkVarName) +#endif + +#ifndef InterpHv +# define InterpHv (*TkglueVptr->V_InterpHv) +#endif + +#ifndef Lang_TkCommand +# define Lang_TkCommand (*TkglueVptr->V_Lang_TkCommand) +#endif + +#ifndef Lang_TkSubCommand +# define Lang_TkSubCommand (*TkglueVptr->V_Lang_TkSubCommand) +#endif + +#ifndef MakeReference +# define MakeReference (*TkglueVptr->V_MakeReference) +#endif + +#ifndef ObjectRef +# define ObjectRef (*TkglueVptr->V_ObjectRef) +#endif + +#ifndef SVtoFont +# define SVtoFont (*TkglueVptr->V_SVtoFont) +#endif + +#ifndef SVtoHWND +# define SVtoHWND (*TkglueVptr->V_SVtoHWND) +#endif + +#ifndef SVtoWindow +# define SVtoWindow (*TkglueVptr->V_SVtoWindow) +#endif + +#ifndef TkToMainWindow +# define TkToMainWindow (*TkglueVptr->V_TkToMainWindow) +#endif + +#ifndef TkToWidget +# define TkToWidget (*TkglueVptr->V_TkToWidget) +#endif + +#ifndef WidgetRef +# define WidgetRef (*TkglueVptr->V_WidgetRef) +#endif + +#ifndef WindowCommand +# define WindowCommand (*TkglueVptr->V_WindowCommand) +#endif + +#ifndef XSTkCommand +# define XSTkCommand (*TkglueVptr->V_XSTkCommand) +#endif + +#ifndef install_vtab +# define install_vtab (*TkglueVptr->V_install_vtab) +#endif + +#endif /* NO_VTABLES */ +#endif /* _TKGLUE_VM */ diff --git a/Master/tlpkg/tlperl/lib/Tk/tkGlue.t b/Master/tlpkg/tlperl/lib/Tk/tkGlue.t new file mode 100644 index 00000000000..ff689ff5539 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/tkGlue.t @@ -0,0 +1,70 @@ +#ifdef _TKGLUE +#ifndef Call_Tk +VFUNC(int,Call_Tk,V_Call_Tk,_ANSI_ARGS_((Lang_CmdInfo *info,int argc, SV **args))) +#endif /* #ifndef Call_Tk */ + +#ifndef EnterWidgetMethods +VFUNC(void,EnterWidgetMethods,V_EnterWidgetMethods,_ANSI_ARGS_((char *package, ...))) +#endif /* #ifndef EnterWidgetMethods */ + +#ifndef FindTkVarName +VFUNC(SV *,FindTkVarName,V_FindTkVarName,_ANSI_ARGS_((CONST char *varName,int flags))) +#endif /* #ifndef FindTkVarName */ + +#ifndef InterpHv +VFUNC(HV *,InterpHv,V_InterpHv,_ANSI_ARGS_((Tcl_Interp *interp,int fatal))) +#endif /* #ifndef InterpHv */ + +#ifndef Lang_TkCommand +VFUNC(void,Lang_TkCommand,V_Lang_TkCommand,_ANSI_ARGS_((char *name, Tcl_ObjCmdProc *proc))) +#endif /* #ifndef Lang_TkCommand */ + +#ifndef Lang_TkSubCommand +VFUNC(void,Lang_TkSubCommand,V_Lang_TkSubCommand,_ANSI_ARGS_((char *name, Tcl_ObjCmdProc *proc))) +#endif /* #ifndef Lang_TkSubCommand */ + +#ifndef MakeReference +VFUNC(SV *,MakeReference,V_MakeReference,_ANSI_ARGS_((SV * sv))) +#endif /* #ifndef MakeReference */ + +#ifndef ObjectRef +VFUNC(SV *,ObjectRef,V_ObjectRef,_ANSI_ARGS_((Tcl_Interp *interp, char *path))) +#endif /* #ifndef ObjectRef */ + +#ifndef SVtoFont +VFUNC(Tk_Font,SVtoFont,V_SVtoFont,_ANSI_ARGS_((SV *win))) +#endif /* #ifndef SVtoFont */ + +#ifndef SVtoHWND +VFUNC(HWND,SVtoHWND,V_SVtoHWND,_ANSI_ARGS_((SV *win))) +#endif /* #ifndef SVtoHWND */ + +#ifndef SVtoWindow +VFUNC(Tk_Window,SVtoWindow,V_SVtoWindow,_ANSI_ARGS_((SV *win))) +#endif /* #ifndef SVtoWindow */ + +#ifndef TkToMainWindow +VFUNC(Tk_Window,TkToMainWindow,V_TkToMainWindow,_ANSI_ARGS_((Tk_Window tkwin))) +#endif /* #ifndef TkToMainWindow */ + +#ifndef TkToWidget +VFUNC(SV *,TkToWidget,V_TkToWidget,_ANSI_ARGS_((Tk_Window tkwin,Tcl_Interp **pinterp))) +#endif /* #ifndef TkToWidget */ + +#ifndef WidgetRef +VFUNC(SV *,WidgetRef,V_WidgetRef,_ANSI_ARGS_((Tcl_Interp *interp, char *path))) +#endif /* #ifndef WidgetRef */ + +#ifndef WindowCommand +VFUNC(Lang_CmdInfo *,WindowCommand,V_WindowCommand,_ANSI_ARGS_((SV *win,HV **hptr, int moan))) +#endif /* #ifndef WindowCommand */ + +#ifndef XSTkCommand +VFUNC(int,XSTkCommand,V_XSTkCommand,_ANSI_ARGS_((CV *cv, int mwcd, Tcl_ObjCmdProc *proc, int items, SV **args))) +#endif /* #ifndef XSTkCommand */ + +#ifndef install_vtab +VFUNC(void,install_vtab,V_install_vtab,_ANSI_ARGS_((char *name, void *table, size_t size))) +#endif /* #ifndef install_vtab */ + +#endif /* _TKGLUE */ diff --git a/Master/tlpkg/tlperl/lib/Tk/tkGlue_f.h b/Master/tlpkg/tlperl/lib/Tk/tkGlue_f.h new file mode 100644 index 00000000000..8255c08dc3f --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/tkGlue_f.h @@ -0,0 +1,14 @@ +#ifndef TKGLUE_VT +#define TKGLUE_VT +typedef struct TkglueVtab +{ + unsigned (*tabSize)(void); +#define VFUNC(type,name,mem,args) type (*mem) args; +#define VVAR(type,name,mem) type (*mem); +#include "tkGlue.t" +#undef VFUNC +#undef VVAR +} TkglueVtab; +extern TkglueVtab *TkglueVptr; +extern TkglueVtab *TkglueVGet(void); +#endif /* TKGLUE_VT */ diff --git a/Master/tlpkg/tlperl/lib/Tk/tranicon.gif b/Master/tlpkg/tlperl/lib/Tk/tranicon.gif Binary files differnew file mode 100644 index 00000000000..dc7d494c572 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/tranicon.gif diff --git a/Master/tlpkg/tlperl/lib/Tk/typemap b/Master/tlpkg/tlperl/lib/Tk/typemap new file mode 100644 index 00000000000..29138850ab3 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/typemap @@ -0,0 +1,96 @@ +TYPEMAP +Tk_Window T_TK_WINDOW +Tk_Image T_TK_IMAGE +TkWindow * T_TKWINDOW +Display * T_IVOBJ +Screen * T_IVOBJ +Visual * T_IVOBJ +Window T_IVOBJ +Colormap T_IVOBJ +GC T_IVOBJ +Font T_IVOBJ +Atom T_IV +HANDLE T_IV +BOOL T_IV +HWND T_TK_HWND +FILE * T_NIO +hash_ptr * T_PTR +Tk_3DBorder T_IVOBJ +Tk_Uid T_TK_UID +Tcl_Interp * T_TK_INTERP +Tk_Font T_TK_FONT +EventAndKeySym * T_TK_XEVENT +LangCallback * T_TK_CALLBACK +LangFontInfo * T_PVOBJ +const char * T_PV + +INPUT +T_PVOBJ + if (sv_isobject($arg)) { + STRLEN sz; + $var = ($type) SvPV((SV*)SvRV($arg),sz); + if (sz != sizeof(*$var)) + croak(\"$arg too small (%d) for $var $type (%d)\",sz,sizeof(*$var)); + } + else + croak(\"$var is not an object\") + +T_TK_WINDOW + $var = SVtoWindow($arg) + +T_TK_CALLBACK + $var = LangMakeCallback($arg) + + +T_TK_HWND + $var = SVtoHWND($arg) + +T_TK_XEVENT + $var = SVtoEventAndKeySym($arg) + +T_TK_FONT + $var = SVtoFont($arg) + +T_TK_IMAGE + $var = SVtoImage($arg) + +T_TKWINDOW + $var = (TkWindow *) SVtoWindow($arg) + +T_TK_INTERP + $var = WindowCommand($arg,NULL,1)->interp + +T_TK_UID + $var = Tk_GetUid(SvPV($arg,na)) + +T_IVOBJ + if (sv_isa($arg, \"${ntype}\")) { + $var = INT2PTR($type, SvIV(SvRV($arg))); + } + else { + $var = ($type) NULL; + croak(\"$var is not of type ${ntype}\"); + } + +T_NIO + if (sv_isa($arg, \"${Package}\")) { + $var = IoIFP(sv_2io(SvRV($arg))); + } + else + croak(\"$var is not of type ${Package}\") + + +OUTPUT +T_IVOBJ + sv_setref_iv($arg, \"${ntype}\", PTR2IV($var)); + +T_TK_UID + sv_setpv($arg,$var); + +T_TK_WINDOW + SvSetMagicSV($arg,TkToWidget($var,NULL)); + +T_TKWINDOW + SvSetMagicSV($arg,TkToWidget((Tk_Window) $var,NULL)); + + diff --git a/Master/tlpkg/tlperl/lib/Tk/vtab.def b/Master/tlpkg/tlperl/lib/Tk/vtab.def new file mode 100644 index 00000000000..7663df7d6f4 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/vtab.def @@ -0,0 +1,90 @@ +#define IMPORT_VTABLE(ptr,type,name) do { \ + ptr = INT2PTR(type *,SvIV(get_sv(name,GV_ADDWARN|GV_ADD))); \ + if ((*ptr->tabSize)() != sizeof(type)) { \ + Perl_warn(aTHX_ "%s wrong size for %s",name,#type); \ + } \ + } while (0) + +#ifdef WIN32 +#define DECLARE_VTABLES \ +LangVtab *LangVptr; \ +TcldeclsVtab *TcldeclsVptr; \ +TkVtab *TkVptr; \ +TkdeclsVtab *TkdeclsVptr; \ +TkeventVtab *TkeventVptr; \ +TkglueVtab *TkglueVptr; \ +TkintVtab *TkintVptr; \ +TkintdeclsVtab *TkintdeclsVptr; \ +TkintplatdeclsVtab *TkintplatdeclsVptr;\ +TkintxlibdeclsVtab *TkintxlibdeclsVptr;\ +TkoptionVtab *TkoptionVptr; \ +TkplatdeclsVtab *TkplatdeclsVptr + +#define IMPORT_VTABLES do { \ +IMPORT_VTABLE(LangVptr , LangVtab,"Tk::LangVtab"); \ +IMPORT_VTABLE(TcldeclsVptr , TcldeclsVtab,"Tk::TcldeclsVtab"); \ +IMPORT_VTABLE(TkVptr , TkVtab,"Tk::TkVtab"); \ +IMPORT_VTABLE(TkdeclsVptr , TkdeclsVtab,"Tk::TkdeclsVtab"); \ +IMPORT_VTABLE(TkeventVptr , TkeventVtab,"Tk::TkeventVtab"); \ +IMPORT_VTABLE(TkglueVptr , TkglueVtab,"Tk::TkglueVtab"); \ +IMPORT_VTABLE(TkintVptr , TkintVtab,"Tk::TkintVtab"); \ +IMPORT_VTABLE(TkintdeclsVptr , TkintdeclsVtab,"Tk::TkintdeclsVtab"); \ +IMPORT_VTABLE(TkintplatdeclsVptr,TkintplatdeclsVtab,"Tk::TkintplatdeclsVtab"); \ +IMPORT_VTABLE(TkintxlibdeclsVptr,TkintxlibdeclsVtab,"Tk::TkintxlibdeclsVtab"); \ +IMPORT_VTABLE(TkoptionVptr , TkoptionVtab,"Tk::TkoptionVtab"); \ +IMPORT_VTABLE(TkplatdeclsVptr , TkplatdeclsVtab,"Tk::TkplatdeclsVtab"); \ +} while (0) +#else +#define DECLARE_VTABLES \ +LangVtab *LangVptr; \ +TcldeclsVtab *TcldeclsVptr; \ +TkVtab *TkVptr; \ +TkdeclsVtab *TkdeclsVptr; \ +TkeventVtab *TkeventVptr; \ +TkglueVtab *TkglueVptr; \ +TkintVtab *TkintVptr; \ +TkintdeclsVtab *TkintdeclsVptr; \ +TkoptionVtab *TkoptionVptr; \ +XlibVtab *XlibVptr + +#define IMPORT_VTABLES do { \ +IMPORT_VTABLE(LangVptr , LangVtab,"Tk::LangVtab"); \ +IMPORT_VTABLE(TcldeclsVptr , TcldeclsVtab,"Tk::TcldeclsVtab"); \ +IMPORT_VTABLE(TkVptr , TkVtab,"Tk::TkVtab"); \ +IMPORT_VTABLE(TkdeclsVptr , TkdeclsVtab,"Tk::TkdeclsVtab"); \ +IMPORT_VTABLE(TkeventVptr , TkeventVtab,"Tk::TkeventVtab"); \ +IMPORT_VTABLE(TkglueVptr , TkglueVtab,"Tk::TkglueVtab"); \ +IMPORT_VTABLE(TkintVptr , TkintVtab,"Tk::TkintVtab"); \ +IMPORT_VTABLE(TkintdeclsVptr , TkintdeclsVtab,"Tk::TkintdeclsVtab"); \ +IMPORT_VTABLE(TkoptionVptr , TkoptionVtab,"Tk::TkoptionVtab"); \ +IMPORT_VTABLE(XlibVptr , XlibVtab,"Tk::XlibVtab"); \ +} while (0) +#endif +#define DECLARE_TIX \ +TixVtab *TixVptr; \ +TixintVtab *TixintVptr + +#define IMPORT_TIX do { \ +IMPORT_VTABLE(TixVptr , TixVtab,"Tk::TixVtab"); \ +IMPORT_VTABLE(TixintVptr , TixintVtab,"Tk::TixintVtab"); \ +} while (0) +#define DECLARE_PHOTO \ +ImgintVtab *ImgintVptr; \ +TkimgphotoVtab *TkimgphotoVptr + +#define IMPORT_PHOTO do { \ +IMPORT_VTABLE(ImgintVptr , ImgintVtab,"Tk::ImgintVtab"); \ +IMPORT_VTABLE(TkimgphotoVptr , TkimgphotoVtab,"Tk::TkimgphotoVtab"); \ +} while (0) +#define DECLARE_EVENT \ +TkeventVtab *TkeventVptr + +#define IMPORT_EVENT do { \ +IMPORT_VTABLE(TkeventVptr , TkeventVtab,"Tk::TkeventVtab"); \ +} while (0) +#define DECLARE_TIXXPM \ +TiximgxpmVtab *TiximgxpmVptr + +#define IMPORT_TIXXPM do { \ +IMPORT_VTABLE(TiximgxpmVptr , TiximgxpmVtab,"Tk::TiximgxpmVtab"); \ +} while (0) diff --git a/Master/tlpkg/tlperl/lib/Tk/widgets.pm b/Master/tlpkg/tlperl/lib/Tk/widgets.pm new file mode 100644 index 00000000000..0d628027810 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/widgets.pm @@ -0,0 +1,21 @@ +package Tk::widgets; +use Carp; + +use vars qw($VERSION); +$VERSION = '4.004'; # $Id: //depot/Tkutf8/Tk/widgets.pm#4 $ + +sub import +{ + my $class = shift; + foreach (@_) + { + local $SIG{__DIE__} = \&Carp::croak; + # carp "$_ already loaded" if (exists $INC{"Tk/$_.pm"}); + require "Tk/$_.pm"; + } +} + +1; +__END__ + +=cut diff --git a/Master/tlpkg/tlperl/lib/Tk/win.xbm b/Master/tlpkg/tlperl/lib/Tk/win.xbm new file mode 100644 index 00000000000..13c05e8c2d7 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/win.xbm @@ -0,0 +1,6 @@ +#define win.xbm_width 16 +#define win.xbm_height 16 +static char win.xbm_bits[] = { + 0xff, 0xff, 0x0d, 0xb0, 0xff, 0xff, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, + 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, + 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0xff, 0xff}; diff --git a/Master/tlpkg/tlperl/lib/Tk/winfolder.xpm b/Master/tlpkg/tlperl/lib/Tk/winfolder.xpm new file mode 100644 index 00000000000..73fe734c6d0 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/winfolder.xpm @@ -0,0 +1,39 @@ +/* XPM */ +static char *winfolder[] = { +/* width height num_colors chars_per_pixel */ +" 17 15 17 1", +/* colors */ +" c none", +". c #000000", +"# c #808080", +"a c #800000", +"b c #808000", +"c c #008000", +"d c #008080", +"e c #000080", +"f c #800080", +"g c #ffffff", +"h c #c0c0c0", +"i c #ff0000", +"j c #ffff00", +"k c #00ff00", +"l c #00ffff", +"m c #0000ff", +"n c #ff00ff", +/* pixels */ +" ", +" ##### ", +" #hjhjh# ", +" #hjhjhjh###### ", +" #gggggggggggg#. ", +" #gjhjhjhjhjhj#. ", +" #ghjhjhjhjhjh#. ", +" #gjhjhjhjhjhj#. ", +" #ghjhjhjhjhjh#. ", +" #gjhjhjhjhjhj#. ", +" #ghjhjhjhjhjh#. ", +" #gjhjhjhjhjhj#. ", +" ##############. ", +" .............. ", +" ", +}; diff --git a/Master/tlpkg/tlperl/lib/Tk/wintext.xpm b/Master/tlpkg/tlperl/lib/Tk/wintext.xpm new file mode 100644 index 00000000000..50b2d5587dd --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/wintext.xpm @@ -0,0 +1,42 @@ +/* XPM */ +static char *wintext[] = { +/* width height num_colors chars_per_pixel */ +" 15 18 17 1", +/* colors */ +" c None", +". c #000000", +"# c #808080", +"a c #800000", +"b c #808000", +"c c #008000", +"d c #008080", +"e c #000080", +"f c #800080", +"g c #ffffff", +"h c #c0c0c0", +"i c #ff0000", +"j c #ffff00", +"k c #00ff00", +"l c #00ffff", +"m c #0000ff", +"n c #ff00ff", +/* pixels */ +" ", +" . . . . . ", +" .g#g#g#g#g. ", +" #g.g.g.g.g.g. ", +" #ggggggggggh. ", +" #ggggggggggh. ", +" #gg...g..ggh. ", +" #ggggggggggh. ", +" #gg......ggh. ", +" #ggggggggggh. ", +" #gg......ggh. ", +" #ggggggggggh. ", +" #gg......ggh. ", +" #ggggggggggh. ", +" #ggggggggggh. ", +" #hhhhhhhhhhh. ", +" ........... ", +" " +}; |
