/[iselect]/ISelect.pm
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Contents of /ISelect.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 23 - (show annotations)
Thu Oct 25 21:27:58 2007 UTC (16 years, 5 months ago) by dpavlin
File size: 7286 byte(s)
last commit also sneaked it implementation for g (top of document) and this
one has G (bottom of document)
1 package Term::ISelect;
2
3 use warnings;
4 use strict;
5
6 use Term::Screen;
7 use Carp qw/cluck confess/;
8 use Data::Dump qw/dump/;
9
10 use base qw/Class::Accessor/;
11 __PACKAGE__->mk_accessors( qw/
12 screen
13 lines
14 error_text
15 status_text
16
17 debug
18 / );
19
20
21 our $VERSION = '0.02';
22
23 =head1 NAME
24
25 Term::ISelect - perl only implementation of Interactive Terminal Selection
26
27 =head1 METHODS
28
29 =head2 new
30
31 my $iselect = Term::ISelect->new({
32 lines => [
33 'first line',
34 '{s}second selectable line',
35 '',
36 'last line',
37 ],
38 debug => 1
39 });
40
41 =head2 open_screen
42
43 $iselect->open_screen;
44
45 =cut
46
47 # leave sane terminal if script dies
48 $SIG{__DIE__} = sub {
49 eval { system('stty sane'); };
50 };
51
52 sub open_screen {
53 my $self = shift;
54 $self->screen( new Term::Screen );
55 }
56
57 my $top_screen_line = 0; # offset in original text
58 my $pos = 0;
59
60 # default: select first line
61 my $sel_pos = 0;
62
63 my $status_lines = 3;
64
65 my $selectable_line;
66
67 my $nr_lines = 0;
68
69 =head2 full_line
70
71 Returns line padded up to screen width
72
73 $iselect->full_line( "foo bar" );
74
75 =cut
76
77 sub full_line {
78 my $self = shift;
79
80 my $cols = $self->screen->cols;
81
82 my $t = shift;
83
84 $t =~ s/{s}//;
85
86 $t = '' unless defined $t;
87 $t = substr($t,0,$cols) if length($t) > $cols;
88 return $t . (" " x ($cols - length($t)));
89 }
90
91
92 =head2 redraw_line
93
94 $iselect->redraw_line( $line_on_screen, $content_of_line );
95
96 =cut
97
98 sub redraw_line {
99 my $self = shift;
100
101 my ($l,$line) = @_;
102
103 if ( defined $selectable_line->{ $l + $top_screen_line } ) {
104 $self->screen->at($l,0)->bold()->puts( $self->full_line( $line ) )->normal();
105 } else {
106 $self->screen->at($l,0)->puts( $self->full_line( $line ) )
107 }
108 }
109
110 =head2 redraw_screen
111
112 $iselect->redraw_screen
113
114 =cut
115
116 sub redraw_screen {
117 my $self = shift;
118 my @lines = @{ $self->lines };
119 $nr_lines = $#lines;
120 for my $l (0 .. $self->screen->rows - $status_lines) {
121 my $line = $lines[ $l + $top_screen_line ];
122 $self->redraw_line( $l, $line );
123 last if ($l == $#lines);
124 }
125 $self->selected;
126 }
127
128 =head2 redraw_statusline
129
130 Redraw status line
131
132 $iselect->redraw_statusline;
133
134 =cut
135
136 sub redraw_statusline {
137 my $self = shift;
138
139 my $pcnt = int(($pos || 0) * 100 / ( $nr_lines || 1 ) );
140 my $pos_txt = sprintf('%d/%s, %d%% ',$pos,$nr_lines,$pcnt);
141
142 my $scr = $self->screen || confess "need screen";
143
144 my $status_text = sprintf("pos: %-3d sel_pos: %-3d top_screen_line: %-3d", $pos, $sel_pos, $top_screen_line );
145
146 $status_text .= ' ' . $self->status_text if $self->status_text;
147
148 $scr->at($scr->rows - $status_lines + 1,0)->reverse()->puts(
149 sprintf(' %-'.($scr->cols - length($pos_txt) - 2).'s ',$status_text)
150 .$pos_txt)->normal();
151
152 $scr->at($scr->rows - $status_lines + 2,0)->puts(
153 sprintf('%-'.$scr->cols.'s', $self->error_text )
154 ) if $self->error_text;
155 }
156
157 =head2 selected
158
159 Move selection to some line of document
160
161 $iselect->selected( 42 );
162
163 =cut
164
165 sub selected {
166 my $self = shift;
167
168 my $new_pos = shift;
169
170 if ( defined $new_pos ) {
171
172 my $screen_line = $pos - $top_screen_line;
173 $self->redraw_line( $screen_line, $self->lines->[$pos] );
174
175 my $last_screen_line = $self->screen->rows - $status_lines;
176
177 if ( $new_pos < $pos && $screen_line == 0 ) {
178 if ( $pos > 0 ) {
179 $top_screen_line--;
180 $pos--;
181 $self->screen->at(0,0)->il;
182 $self->error_text( ' ' );
183 } else {
184 $self->error_text( "Already at Begin." );
185 }
186 } elsif ( $new_pos > $pos && $screen_line == $last_screen_line ) {
187 if ( $pos < $nr_lines ) {
188 $top_screen_line++;
189 $pos++;
190 $self->screen->at(0,0)->dl;
191 } else {
192 $self->error_text( "Already at End." );
193 }
194 } else {
195 $pos = $new_pos;
196 }
197
198 }
199
200 my $line = $self->lines->[$pos];
201 if ( defined $selectable_line->{ $pos } ) {
202 $self->screen->at($pos - $top_screen_line,0)->reverse->bold()->puts( $self->full_line( $line ) )->normal();
203 $sel_pos = $pos;
204 } else {
205 $self->screen->at($pos - $top_screen_line,0)->reverse->puts( $self->full_line( $line ) );
206 $sel_pos = -1;
207 }
208 $self->redraw_statusline;
209 }
210
211
212 =head2 loop
213
214 $iselect->loop(
215 sub {
216 my $line = shift;
217 warn "got line: $line\n";
218 }
219 );
220
221 =cut
222
223 sub loop {
224 my $self = shift;
225
226 my $callback = shift;
227 confess "expect callback as first arg" unless ref($callback) eq 'CODE';
228
229 my @lines = @{ $self->lines };
230
231 # find which lines are selectable in input file
232 for my $l (0 .. $#lines) {
233 if ($lines[$l] =~ m/^{s}/) {
234 $selectable_line->{$l}++;
235 }
236 }
237
238 # select first selectable line
239 if ( $selectable_line ) {
240 $pos = $sel_pos = (sort { $a <=> $b } keys %$selectable_line)[0];
241 warn "selected first selectable line $sel_pos";
242 }
243
244 $self->open_screen unless $self->screen;
245
246 $self->screen->clrscr()->noecho();
247 $self->redraw_screen;
248 $self->selected;
249
250 my $lines_on_screen = $self->screen->rows - $status_lines;
251 my $max_top_screen_line =
252 $nr_lines > $lines_on_screen ? $nr_lines - $lines_on_screen : 0;
253
254 while(my $key = $self->screen->getch()) {
255
256 $self->error_text('');
257
258 if ($key eq 'ku') {
259 $self->selected( $pos - 1 );
260 } elsif ($key eq 'kd') {
261 $self->selected( $pos + 1 );
262 } elsif ($key eq 'pgup' ) {
263 # first line on screen?
264 if ( $pos == $top_screen_line ) {
265 $top_screen_line -= $lines_on_screen;
266 $top_screen_line = 0 if $top_screen_line < 0;
267 $self->redraw_screen;
268 }
269 if ( $pos == $top_screen_line ) {
270 $self->error_text( "Already at top." );
271 } else {
272 $self->selected( $top_screen_line );
273 }
274 } elsif ($key eq 'pgdn' ) {
275 # last line on screen?
276 if ( $pos - $top_screen_line == $lines_on_screen ) {
277 $top_screen_line += $lines_on_screen;
278 $top_screen_line = $max_top_screen_line if $top_screen_line > $max_top_screen_line;
279 $self->redraw_screen;
280 }
281 if ( $pos == $nr_lines ) {
282 $self->error_text( "Already at bottom." );
283 } else {
284 $self->selected( $top_screen_line + $lines_on_screen );
285 }
286 } elsif ($key eq 'g' ) {
287 if ( $top_screen_line == 0 ) {
288 if ( $pos == 0 ) {
289 $self->error_text( "Already at top." );
290 } else {
291 $self->selected( 0 );
292 }
293 } else {
294 $top_screen_line = 0;
295 $pos = 0;
296 $self->redraw_screen;
297 }
298 } elsif ($key eq 'G' ) {
299 if ( $top_screen_line == $max_top_screen_line ) {
300 if ( $pos == $nr_lines ) {
301 $self->error_text( "Already at bottom." );
302 } else {
303 $self->selected( $nr_lines );
304 }
305 } else {
306 $top_screen_line = $max_top_screen_line;
307 $pos = $nr_lines;
308 $self->redraw_screen;
309 }
310 }
311
312 if ( length($key) > 1 ) {
313 $self->status_text("key: $key");
314 } else {
315 $self->status_text( sprintf("key: %s [%03d][%02x]", $key =~ m/\w/ ? $key : '?' , ord($key), ord($key) ) );
316 }
317
318 # CTRL+L
319 $self->redraw_screen if ord($key) eq 0x0c;
320
321 # Enter
322 if ( ord($key) eq 0x0d && $sel_pos > 0 ) {
323 $self->error_text( "execute: " . $lines[ $sel_pos ] );
324 }
325
326 return if (lc($key) eq 'q');
327
328 $self->redraw_statusline;
329
330 }
331
332 $self->clrscr();
333 }
334
335 =head1 SEE ALSO
336
337 L<http://www.ossp.org/pkg/tool/iselect/> - Interactive Terminal Selection
338 written by Ralf S. Engelschall which is original implementation in C
339
340 =head1 AUTHOR
341
342 Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
343
344 =head1 COPYRIGHT & LICENSE
345
346 Copyright 2006-2007 Dobrica Pavlinusic, All Rights Reserved.
347
348 This program is free software; you can redistribute it and/or modify it
349 under the same terms as Perl itself.
350
351 =cut
352
353 1;

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26