/[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 14 - (hide annotations)
Thu Oct 25 17:24:33 2007 UTC (12 years ago) by dpavlin
File size: 6277 byte(s)
continue move to OO land.
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     our $VERSION = '0.01';
22    
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 14 =head2 full_line
68    
69     Returns line padded up to screen width
70    
71     $iselect->full_line( "foo bar" );
72    
73     =cut
74    
75 dpavlin 12 sub full_line {
76 dpavlin 14 my $self = shift;
77    
78     my $cols = $self->screen->cols;
79    
80 dpavlin 12 my $t = shift;
81     $t = '' unless defined $t;
82 dpavlin 14 $t = substr($t,0,$cols) if length($t) > $cols;
83     return $t . (" " x ($cols - length($t)));
84 dpavlin 12 }
85    
86    
87 dpavlin 14 =head2 redraw_line
88    
89     $iselect->redraw_line( $line_on_screen, $content_of_line );
90    
91     =cut
92    
93 dpavlin 12 sub redraw_line {
94 dpavlin 14 my $self = shift;
95    
96 dpavlin 12 my ($l,$line) = @_;
97    
98     if ( defined $selectable_line->{ $l + $top_screen_line } ) {
99 dpavlin 14 $self->screen->at($l,0)->bold()->puts( $self->full_line( $line ) )->normal();
100 dpavlin 12 } else {
101 dpavlin 14 $self->screen->at($l,0)->puts( $self->full_line( $line ) )
102 dpavlin 12 }
103     }
104    
105 dpavlin 14 =head2 redraw_screen
106    
107     $iselect->redraw_screen
108    
109     =cut
110    
111     sub redraw_screen {
112     my $self = shift;
113     my @lines = $self->lines;
114     for my $l (0 .. $self->screen->rows - $status_lines) {
115 dpavlin 12 my $line = $lines[ $l + $top_screen_line ];
116 dpavlin 14 $self->redraw_line( $l, $line );
117 dpavlin 12 last if ($l == $#lines);
118     }
119 dpavlin 14 $self->selected;
120 dpavlin 12 }
121    
122 dpavlin 14 =head2 redraw_statusline
123    
124     Redraw status line
125    
126     $iselect->redraw_statusline;
127    
128     =cut
129    
130     sub redraw_statusline {
131     my $self = shift;
132    
133     my @lines = $self->lines;
134    
135     my $pcnt = int(($pos || 0) * 100 / ( $#lines || 1));
136 dpavlin 12 my $pos_txt = sprintf('%d, %d%% ',$pos,$pcnt);
137 dpavlin 14
138     my $scr = $self->screen || confess "need screen";
139    
140 dpavlin 12 $scr->at($scr->rows - $status_lines + 1,0)->reverse()->puts(
141 dpavlin 14 sprintf(' %-'.($scr->cols - length($pos_txt) - 2).'s ',$self->status_text)
142     .$pos_txt)->normal() if $self->status_text;
143    
144 dpavlin 12 $scr->at($scr->rows - $status_lines + 2,0)->puts(
145 dpavlin 14 sprintf('%-'.$scr->cols.'s', $self->error_text)
146     ) if $self->error_text;
147 dpavlin 12 }
148    
149 dpavlin 14 =head2 selected
150    
151     Move selection (or refresh it)
152    
153     $iselect->selected( +1 );
154     $iselect->selected( -1 );
155     $iselect->selected( 0 );
156    
157     =cut
158    
159 dpavlin 12 sub selected {
160 dpavlin 14 my $self = shift;
161    
162 dpavlin 12 my $d = shift || 0;
163    
164     my $screen_line = $pos - $top_screen_line;
165    
166 dpavlin 14 $self->redraw_line( $screen_line, ($self->lines)[$pos] );
167 dpavlin 12
168 dpavlin 14 my $last_screen_line = $self->screen->rows - $status_lines;
169 dpavlin 12
170     if ( $d < 0 && $screen_line == 0 ) {
171     if ( $pos > 0 ) {
172     $top_screen_line--;
173     $pos--;
174     } else {
175 dpavlin 14 $self->error_text( "Already at Begin." );
176 dpavlin 12 }
177 dpavlin 14 $self->redraw_screen;
178 dpavlin 12 } elsif ( $d > 0 && $screen_line == $last_screen_line ) {
179 dpavlin 14 if ( $pos < scalar($self->lines) ) {
180 dpavlin 12 $top_screen_line++;
181     $pos++;
182     } else {
183 dpavlin 14 $self->error_text( "Already at End." );
184 dpavlin 12 }
185 dpavlin 14 $self->redraw_screen;
186 dpavlin 12 } else {
187     $pos += $d;
188     }
189    
190 dpavlin 14 my $line = ($self->lines)[$pos];
191 dpavlin 12 if ( defined $selectable_line->{ $pos } ) {
192 dpavlin 14 $self->screen->at($pos - $top_screen_line,0)->reverse->bold()->puts( $self->full_line( $line ) )->normal();
193 dpavlin 12 $sel_pos = $pos;
194     } else {
195 dpavlin 14 $self->screen->at($pos - $top_screen_line,0)->reverse->puts( $self->full_line( $line ) );
196 dpavlin 12 $sel_pos = -1;
197     }
198 dpavlin 14 $self->redraw_statusline;
199 dpavlin 12 }
200    
201    
202 dpavlin 14 =head2 loop
203 dpavlin 12
204 dpavlin 14 $iselect->loop(
205 dpavlin 12 sub {
206     my $line = shift;
207     warn "got line: $line\n";
208 dpavlin 14 }
209 dpavlin 12 );
210    
211     =cut
212    
213 dpavlin 14 sub loop {
214     my $self = shift;
215 dpavlin 12
216     my $callback = shift;
217     confess "expect callback as first arg" unless ref($callback) eq 'CODE';
218    
219 dpavlin 14 my @lines = $self->lines;
220 dpavlin 12
221     # find which lines are selectable in input file
222     for my $l (0 .. $#lines) {
223     if ($lines[$l] =~ s/^{s}//) {
224     $selectable_line->{$l}++;
225     }
226     }
227    
228     # select first selectable line
229     if ( $selectable_line ) {
230     $pos = $sel_pos = (sort { $a <=> $b } keys %$selectable_line)[0];
231     warn "selected first selectable line $sel_pos";
232     }
233    
234 dpavlin 14 $self->open_screen unless $self->screen;
235 dpavlin 12
236 dpavlin 14 $self->screen->clrscr()->noecho();
237     $self->redraw_screen;
238     $self->selected;
239 dpavlin 12
240 dpavlin 14 while(my $key = $self->screen->getch()) {
241 dpavlin 12
242 dpavlin 14 my $lines_on_screen = $self->screen->rows - $status_lines;
243 dpavlin 12
244     if ($key eq 'ku') {
245 dpavlin 14 $self->selected( -1 );
246 dpavlin 12 } elsif ($key eq 'kd') {
247 dpavlin 14 $self->selected( +1 );
248 dpavlin 12 } elsif ($key eq 'pgup' ) {
249     # first line on screen?
250     if ( $pos == $top_screen_line ) {
251     $top_screen_line -= $lines_on_screen;
252     $top_screen_line = 0 if $top_screen_line < 0;
253 dpavlin 14 $self->redraw_screen;
254 dpavlin 12 }
255 dpavlin 14 $self->selected( -( $pos - $top_screen_line ) );
256 dpavlin 12 } elsif ($key eq 'pgdn' ) {
257     # last line on screen?
258     if ( $pos - $top_screen_line == $lines_on_screen ) {
259     $top_screen_line += $lines_on_screen;
260     $top_screen_line = $#lines - $lines_on_screen if $top_screen_line >= $#lines - $lines_on_screen;
261 dpavlin 14 $self->redraw_screen;
262 dpavlin 12 }
263 dpavlin 14 $self->selected( $top_screen_line + $lines_on_screen - $pos );
264 dpavlin 12 }
265    
266 dpavlin 14 my $status_text = sprintf("pos: %-3d sel_pos: %-3d top_screen_line: %-3d", $pos, $sel_pos, $top_screen_line );
267 dpavlin 12 if ( length($key) > 1 ) {
268     $status_text .= " key: $key";
269     } else {
270     $status_text .= sprintf("key: %s [%03d][%02x]", $key =~ m/\w/ ? $key : '?' , ord($key), ord($key) );
271     }
272 dpavlin 14 $self->status_text( $status_text );
273 dpavlin 12
274     # CTRL+L
275 dpavlin 14 $self->redraw_screen if ord($key) eq 0x0c;
276 dpavlin 12
277     # Enter
278     if ( ord($key) eq 0x0d && $sel_pos > 0 ) {
279 dpavlin 14 $self->error_text( "execute: " . $lines[ $sel_pos ] );
280 dpavlin 12 }
281    
282 dpavlin 14 return if (lc($key) eq 'q');
283 dpavlin 12
284 dpavlin 14 $self->redraw_statusline;
285 dpavlin 12
286     }
287    
288 dpavlin 14 $self->clrscr();
289 dpavlin 12 }
290    
291 dpavlin 13 =head1 SEE ALSO
292    
293     L<http://www.ossp.org/pkg/tool/iselect/> - Interactive Terminal Selection
294     written by Ralf S. Engelschall which is original implementation in C
295    
296     =head1 AUTHOR
297    
298     Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
299    
300     =head1 COPYRIGHT & LICENSE
301    
302     Copyright 2006-2007 Dobrica Pavlinusic, All Rights Reserved.
303    
304     This program is free software; you can redistribute it and/or modify it
305     under the same terms as Perl itself.
306    
307     =cut
308    
309 dpavlin 12 1;

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26