diff options
Diffstat (limited to 'Master/tlpkg/tlperl/site/lib/Tk/Reindex.pm')
-rw-r--r-- | Master/tlpkg/tlperl/site/lib/Tk/Reindex.pm | 233 |
1 files changed, 233 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/site/lib/Tk/Reindex.pm b/Master/tlpkg/tlperl/site/lib/Tk/Reindex.pm new file mode 100644 index 00000000000..7be04e7c88e --- /dev/null +++ b/Master/tlpkg/tlperl/site/lib/Tk/Reindex.pm @@ -0,0 +1,233 @@ +package Tk::Reindex; + + +use vars qw($VERSION); +$VERSION = '4.006'; # $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; $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 |