/[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

Annotation of /ISelect.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26