diff options
Diffstat (limited to 'Master/tlpkg/tlperl0/lib/Tk/Reindex.pm')
-rwxr-xr-x | Master/tlpkg/tlperl0/lib/Tk/Reindex.pm | 233 |
1 files changed, 0 insertions, 233 deletions
diff --git a/Master/tlpkg/tlperl0/lib/Tk/Reindex.pm b/Master/tlpkg/tlperl0/lib/Tk/Reindex.pm deleted file mode 100755 index d18ca8b19fc..00000000000 --- a/Master/tlpkg/tlperl0/lib/Tk/Reindex.pm +++ /dev/null @@ -1,233 +0,0 @@ -package Tk::Reindex; - - -use vars qw($VERSION); -$VERSION = '4.005'; # $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 - -=over - -=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. - -=back - -=head1 CLASS METHODS - -=over - -=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. - -=back - -=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 |