1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
|
package Tk::Reindex;
use vars qw($VERSION);
$VERSION = '3.002'; # $Id: //depot/Tk8/TextList/Reindex.pm#2 $
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
|