4
use vars qw($VERSION @ISA);
6
$VERSION = sprintf("%d.%02d", q$Revision: 5.1 $ =~ /(\d+)\.(\d+)/);
11
@ISA = qw(Tk::Derived Tk::Frame);
13
Construct Tk::Widget 'More';
21
$cw->SUPER::Populate($args);
23
my $Entry = 'LabEntry';
25
if (eval { die "Not yet";
26
require Tk::HistEntry;
27
Tk::HistEntry->VERSION(0.37);
32
@Entry_args = (-labelPack=>[-side =>'left']);
38
-textvariable => \$search,
41
)->pack(-side=>'bottom', -fill => 'x', -expand=>'no');
42
$cw->Advertise('searchentry' => $e);
44
my $t = $cw->ROText(-cursor=>undef)->pack(-fill => 'both' , -expand => 'yes');
45
$cw->Advertise('text' => $t);
46
$t->tagConfigure('search', -foreground => 'red');
48
# reorder bindings: private widget bindings first
49
$t->bindtags([$t, grep { $_ ne $t->PathName } $t->bindtags]);
51
$t->bind('<Key-slash>', [$cw, 'Search', 'Next']);
52
$t->bind('<Key-question>', [$cw, 'Search', 'Prev']);
53
$t->bind('<Key-n>', [$cw, 'ShowMatch', 'Next']);
54
$t->bind('<Key-N>', [$cw, 'ShowMatch', 'Prev']);
56
$t->bind('<Key-g>', $t->bind(ref($t),'<Control-Home>'));
57
$t->bind('<Key-G>', $t->bind(ref($t),'<Control-End>'));
58
$t->bind('<Home>', $t->bind('<Key-g>'));
59
$t->bind('<End>', $t->bind('<Key-G>'));
61
$t->bind('<Key-j>', [$cw, 'scroll', $t, 1, 'line']);
62
$t->bind('<Down>', [$cw, 'scroll', $t, 1, 'line']);
63
$t->bind('<Key-k>', [$cw, 'scroll', $t, -1, 'line']);
64
$t->bind('<Up>', [$cw, 'scroll', $t, -1, 'line']);
66
$t->bind('<Key-f>', [$cw, 'scroll', $t, 1, 'page']);
67
$t->bind('<Next>', [$cw, 'scroll', $t, 1, 'page']);
68
$t->bind('<Key-b>', [$cw, 'scroll', $t, -1, 'page']);
69
$t->bind('<Prior>', [$cw, 'scroll', $t, -1, 'page']);
71
$t->bind('<Right>', [sub {
72
return if ($_[1] =~ /(Alt|Meta)-/);
73
$t->xview('scroll', 1, 'units'); Tk->break;
75
$t->bind('<Left>', [sub {
76
return if ($_[1] =~ /(Alt|Meta)-/);
77
$t->xview('scroll', -1, 'units'); Tk->break;
80
$t->bind('<Return>', ['yview', 'scroll', 1, 'units']);
81
$t->bind('<Key-d>', [$cw, 'scroll', $t, 1, 'halfpage']);
82
$t->bind('<Key-u>', [$cw, 'scroll', $t, -1, 'halfpage']);
84
$t->bind('<Key-h>', sub { $cw->Callback(-helpcommand => $t) });
86
$e->bind('<Return>',[$cw, 'SearchText']);
87
$e->bind('<Escape>',[$cw, 'SearchTextEscape']);
89
foreach my $mod (qw(Alt Meta)) {
90
foreach my $key (qw(n N g G j k f b d u h)) {
91
$t->bind("<$mod-Key-$key>" => \&Tk::NoOp);
95
$cw->Delegates('DEFAULT' => $t,
97
'ShowMatch' => 'SELF',
101
$cw->{DIRECTION} = "Next";
104
-insertofftime => [$t, qw(insertOffTime OffTime 0)], # no blinking
105
-insertwidth => [$t, qw(insertWidth InsertWidth 0)], # invisible
106
-padx => [$t, qw(padX Pad 5p)],
107
-pady => [$t, qw(padY Pad 5p)],
108
-searchcase => ['PASSIVE', 'searchCase', 'SearchCase', 1],
109
-helpcommand => ['CALLBACK', undef, undef, undef],
110
-background => ['PASSIVE'],# XXX ignore -background, so optionAdd works.... still decide
119
my ($cw, $direction) = @_;
120
$cw->{DIRECTION} = $direction;
121
my $e = $cw->Subwidget('searchentry');
122
$e->configure(-label => 'Search ' . ($direction eq 'Next'?'forward:':'backward:') );
123
$e->configure(-relief=>'sunken',-state=>'normal');
124
$e->selectionRange(0, "end");
129
my ($cw, %args) = @_;
130
my($t, $e) = ($cw->Subwidget('text'), $cw->Subwidget('searchentry'));
131
$cw->{DIRECTION} = $args{-direction} if $args{-direction};
133
if (defined $args{-searchterm}) {
134
$searchterm = $args{-searchterm};
135
$ {$e->cget('-textvariable')} = $searchterm;
137
$e->historyAdd if ($e->can('historyAdd'));
138
$searchterm = $e->get;
140
unless ($cw->search_text($t, $searchterm, 'search') ) {
141
$cw->bell unless $args{-quiet};
143
$e->configure(-label=>'');
145
$cw->ShowMatch($cw->{DIRECTION}, -firsttime => 1) unless $args{-onlymatch};
147
$e->configure(-relief=>'flat', -state=>'disabled');
150
sub SearchTextEscape {
151
my ($cw, %args) = @_;
152
my($t, $e) = ($cw->Subwidget('text'), $cw->Subwidget('searchentry'));
153
$e->configure(-label=>'');
155
$e->configure(-relief=>'flat', -state=>'disabled');
159
my ($cw, $method, %args) = @_;
160
my $firsttime = $args{-firsttime};
162
my $t = $cw->Subwidget('text');
163
if ($cw->{DIRECTION} ne 'Next') {
164
$method = 'Next' if $method eq 'Prev';
165
$method = 'Prev' if $method eq 'Next';
167
my $cur = (($method eq 'Prev' && !$firsttime) ||
168
($method eq 'Next' && $firsttime)
170
: $t->index('@0,'.$t->height));
171
$method = "tag". $method . "range"; # $method: Next or Prev
172
my @ins = $t->$method('search',$cur);
174
# hack: Maybe the search was not performed yet? (e.g. after loading
175
# a new page but with the same search term)
176
my $e = $cw->Subwidget('searchentry');
177
if (!defined $ {$e->cget('-textvariable')}) {
180
$cw->SearchText(-searchterm => $ {$e->cget('-textvariable')},
182
@ins = $t->$method('search',$cur);
185
@ins = reverse @ins unless $method eq 'tagNextrange';
190
# Load copied from TextUndo (xxx yy marks changes)
193
my ($text,$file) = @_;
194
if (open(FILE,"<$file"))
196
$text->MainWindow->Busy;
197
$text->SUPER::delete('1.0','end');
198
#yy delete $text->{UNDO};
201
$text->SUPER::insert('end',$_);
204
#yy $text->{FILE} = $file;
205
$text->markSet('insert', '@1,0');
206
$text->MainWindow->Unbusy;
210
$text->messageBox(-message => "Cannot open $file: $!\n");
215
# search_text copied from demo search.pl (modified)
218
# The utility procedure below searches for all instances of a given
219
# string in a text widget and applies a given tag to each instance found.
222
# w - The window in which to search. Must be a text widget.
223
# string - string to search for. The search is done
224
# using exact matching only; no special characters.
225
# tag - Tag to apply to each instance of a matching string.
227
my($w, $t, $string, $tag) = @_;
229
return unless length($string);
231
$w->tag('remove', $tag, qw/0.0 end/);
232
my($current, $length, $found) = ('1.0', 0, 0);
234
my $insert = $w->index('insert');
235
my @search_args = ('-regexp');
236
push @search_args, '-nocase' unless ($w->cget('-searchcase'));
239
$current = $w->search(@search_args, -count => \$length, '--', $string, $current, 'end');
240
last if not $current;
242
$w->tag('add', $tag, $current, "$current + $length char");
243
$current = $w->index("$current + $length char");
245
$w->markSet('insert', $insert);
248
$w->messageBox(-icon => "error",
256
my($w,$t,$no,$unit) = @_;
257
if ($unit =~ /^line/) {
258
$t->yview('scroll', $no, 'units');
260
my($y1,$y2) = $t->yview;
262
if ($unit =~ /^halfpage/) {
263
$amount = ($y2-$y1)/2;
264
} elsif ($unit =~ /^page/) {
266
# # loop until top-most line is invisible
267
# my $inx = $t->index('@0,0');
269
# while ($t->bbox($inx)) {
270
# $t->yviewScroll(-1,'units');
271
# last if ($i++>1000);
277
die "Unknown unit $unit";
279
#warn "$y1 $y2 $amount";
280
$y1 += ($no * $amount);
282
$y1 = 1.0 if ($y1 > 1.0);
284
$y1 = 0.0 if ($y1 < 0.0);
286
$t->yviewMoveto($y1);
293
#package Tk::More::Status;
295
## Implement status bar
304
Tk::More - a 'more' or 'less' like text widget
310
$more = $parent->More(...text widget options ...);
311
$more->Load(FILENAME);
315
B<Tk::More> is a readonly text widget with additional key bindings as
316
found in UNI* command line tools C<more> or C<less>. As in C<more> an
317
additional status/command line is added at the bottom.
319
=head1 ADDITIONAL BINDINGS
325
goto beginning of file
383
Besides that most of more bindings are not implemented. This bugs
384
me most (high to low priority):
386
* better status line implementation
388
* Cursor movement: up/down move displayed area regardless where
391
* add History, Load, Search (also as popup menu)
395
L<Tk::ROText|Tk::ROText>, L<more(1)>, L<tkmore>, L<less(1)>
399
Achim Bohnet <F<ach@mpe.mpg.de>>
401
Currently maintained by Slaven Rezic <F<slaven@rezic.de>>.
403
Copyright (c) 1997-1998 Achim Bohnet. All rights reserved. This program is
404
free software; you can redistribute it and/or modify it under the same
405
terms as Perl itself.
added
removed
0CPAN/Tk-Pod-0.9932/More.pm
