home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2004 July / APC0407D2.iso / workshop / apache / files / ActivePerl-5.6.1.638-MSWin32-x86.msi / _6b3e5226e61f4689fd75b02e2eee16b7 < prev    next >
Encoding:
Text File  |  2004-04-13  |  5.4 KB  |  226 lines

  1. package Tk::Reindex;
  2.  
  3.  
  4. use vars qw($VERSION);
  5. $VERSION = '3.002'; # $Id: //depot/Tk8/TextList/Reindex.pm#2 $
  6.  
  7. use Tk;
  8. use base qw(Tk::Derived);
  9.  
  10.  
  11. sub Populate
  12. {
  13.  my ($w, $args) = @_;
  14.  
  15.  $w->_callbase('Populate',$args);
  16.  
  17.  $w->ConfigSpecs(-linestart    => ["PASSIVE", "lineStart",    "LineStart", 0],
  18.                  -toindexcmd   => ["CALLBACK", "toIndexCmd",  "ToIndexCmd" ,  [\&to_index,$w]],
  19.                  -fromindexcmd => ["CALLBACK", "fromIndexCmd","FromIndexCmd", [\&from_index,$w]]);
  20. }
  21.  
  22. sub import
  23. {
  24.   my($module,$base)=@_;
  25.   my $pkg=(caller)[0];
  26.  
  27.   no strict 'refs';
  28.   *{"${pkg}::_reindexbase"}=sub{$base};
  29. }
  30.  
  31. sub _callbase
  32. {
  33.   my($w,$sub)=(shift,shift);
  34.   my $supersub=$w->_reindexbase()."::$sub";
  35.   $w->$supersub(@_);
  36. }
  37.  
  38. BEGIN
  39. {
  40.   # list of subroutines and index argument number (-1 as first element means return value)
  41.   my %subs=('bbox'      => [0],
  42.             'compare'   => [0,2],
  43.             'delete'    => [0,1],
  44.             'dlineinfo' => [0],
  45.             'dump'      => \&_find_dump_index,
  46.             'get'       => [0,1],
  47.             'index'     => [-1,0],
  48.             'insert'    => [0],
  49.             'mark'      => \&_find_mark_index,
  50.             'search'    => \&_find_search_index,
  51.             'see'       => [0],
  52.             'tag'       => \&_find_tag_index,
  53.             'window'    => [1],
  54.             'image'     => [1],
  55.            );
  56.  
  57.   foreach my $sub (keys %subs)
  58.   {
  59.     my $args=$subs{$sub};
  60.     my $argsub=ref $args eq 'CODE'?$args:sub{$args};
  61.     my $newsub=sub
  62.     {
  63.       my($w)=shift;
  64.       my(@iargs)=grep($_<=$#_,@{$argsub->(@_)});
  65.       my $iret=shift @iargs if @iargs && $iargs[0]==-1;
  66.       my(@args)=@_;
  67.       @args[@iargs]=$w->Callback(-toindexcmd,@args[@iargs]);
  68.       my(@ret)=$w->_callbase($sub,@args);
  69.       @ret=$w->Callback(-fromindexcmd,@ret) if $iret;
  70.       wantarray?@ret:$ret[0];
  71.     };
  72.     no strict 'refs';
  73.     *{$sub}=$newsub;
  74.   }
  75. }
  76.  
  77. sub to_index
  78. {
  79.   my $w=shift;
  80.   my $offset=$w->cget(-linestart)+1;
  81.   my(@args)=@_;
  82.   foreach (@args)
  83.    {
  84.     s/^\d+(?=\.)/$&+$offset/e;
  85.    }
  86.   @args;
  87. }
  88.  
  89. sub from_index
  90. {
  91.   my $w=shift;
  92.   my $offset=$w->cget(-linestart)+1;
  93.   my(@args)=@_;
  94.   foreach (@args)
  95.    {
  96.     s/^\d+(?=\.)/$&-$offset/e
  97.    }
  98.   @args;
  99. }
  100.  
  101. sub _find_dump_index
  102. {
  103.   my $idx=_count_options(@_);
  104.   [$idx,$idx+1];
  105. }
  106.  
  107. sub _find_search_index
  108. {
  109.   my $idx=_count_options(@_);
  110.   [$idx+1,$idx+2];
  111. }
  112.  
  113. sub _count_options
  114. {
  115.   my $idx=0;
  116.   while($_[$idx]=~/^-/g)
  117.   {
  118.     $idx++;
  119.     $idx++ if $' eq 'count' or $' eq 'command';
  120.     last if $' eq '-';
  121.   }
  122.   $idx;
  123. }
  124.  
  125. sub _find_tag_index
  126. {
  127.   return [1]   if $_[0] eq 'names';
  128.   return [2,3] if $_[0]=~/^(add|remove|nextrange|prevrange)$/;
  129.   return [-1]  if $_[0] eq 'ranges';
  130.   return [];
  131. }
  132.  
  133. sub _find_mark_index
  134. {
  135.   return [2] if $_[0] eq 'set';
  136.   return [1] if $_[0] eq 'next' or $_[0] eq 'previous';
  137.   return [];
  138. }
  139.  
  140. 1;
  141.  
  142. =head1 NAME
  143.  
  144. Tk::Reindex - change the base index of Text-like widgets
  145.  
  146. =for category Derived Widgets
  147.  
  148. =head1 SYNOPSIS
  149.  
  150.     use Tk::ReindexedText;
  151.     $t1=$w->ReindexedText(-linestart => 2);
  152.  
  153.     use Tk::ReindexedROText;
  154.     $t2=$w->ReindexedROText(-linestart => 0);
  155.  
  156. =head1 DESCRIPTION
  157.  
  158. Creates a new widget class based on B<Text>-like widgets that can
  159. redefine the line number base (normally B<Text> widgets start line
  160. numbers at 1), or possibly other manipulations on indexes.
  161.  
  162. =head1 STANDARD OPTIONS
  163.  
  164. The newly-defined widget takes all the same options as the base
  165. widget, which defaults to B<Text>.
  166.  
  167. =head1 WIDGET-SPECIFIC OPTIONS
  168.  
  169. =item Name:   B<lineStart>
  170.  
  171. =item Class:  B<LineStart>
  172.  
  173. =item Switch: B<-linestart>
  174.  
  175. Sets the line number of the first line in the B<Text> widget. The
  176. default B<-toindexcmd> and B<-fromindexcmd> use this configuration
  177. option.
  178.  
  179. -item Name:   B<toIndexCmd>  B<fromIndexCmd>
  180.  
  181. -item Class:  B<ToIndexCmd>  B<FromIndexCmd>
  182.  
  183. -item Switch: B<-toindexcmd> B<-fromindexcmd>
  184.  
  185. These two options specify callbacks that are called with a list of
  186. indexes and are responsible for translating them to/from indexes that
  187. the base B<Text> widget can understand. The callback is passed the
  188. widget followed by a list of indexes, and should return a list of
  189. translated indexes. B<-toindexcmd> should translate from 'user'
  190. indexes to 'native' B<Text>-compatible indexes, and B<-fromindexcmd>
  191. should translate from 'native' indexes to 'user' indexes.
  192.  
  193. The default callbacks simply add/subtract the offset given by the
  194. B<-linestart> option for all indexes in 'line.character' format.
  195.  
  196. It would probably be prudent to make these functions inverses of each
  197. other.
  198.  
  199. =head1 CLASS METHODS
  200.  
  201. =item import
  202.  
  203. To make new Reindex widgets, this function should be called via B<use>
  204. with the name of the Text-like base class that you are extending with
  205. "Reindex" capability.  'use base(Tk::Reindex Tk::nameofbasewidget)'
  206. should also be specified for that widget.
  207.  
  208. =head1 BUGS
  209.  
  210. I've used the word "indexes" instead of "indices" throughout the
  211. documentation.
  212.  
  213. All the built-in perl code for widget bindings & methods will use the
  214. new 'user' indexes.  Which means all this index manipulation might
  215. might break code that is trying to parse/manipulate indexes. Or even
  216. assume that '1.0' is the beginning index.  B<Tk::Text::Contents> comes
  217. to mind.
  218.  
  219. =head1 AUTHOR
  220.  
  221. Andrew Allen <ada@fc.hp.com>
  222.  
  223. This code may be distributed under the same conditions as Perl.
  224.  
  225. =cut
  226.