viewvc.cgi/iselect/ISelect.pm

package Term::ISelect;

use warnings;
use strict;

use Term::Screen;
use Carp qw/cluck confess/;
use Data::Dump qw/dump/;

use base qw/Class::Accessor/;
__PACKAGE__->mk_accessors( qw/
screen
lines
error_text
status_text

debug
/ );


our $VERSION = '0.02';

=head1 NAME

Term::ISelect - perl only implementation of Interactive Terminal Selection

=head1 METHODS

=head2 new

  my $iselect = Term::ISelect->new({
        lines => [
                'first line',
                '{s}second selectable line',
                '',
                'last line',
        ],                                                           
        debug => 1
  });

=head2 open_screen

  $iselect->open_screen;

=cut

# leave sane terminal if script dies
$SIG{__DIE__} = sub {
    eval { system('stty sane'); };
};

sub open_screen {
        my $self = shift;
        $self->screen( new Term::Screen );
}

my $top_screen_line = 0;        # offset in original text
my $pos = 0;

# default: select first line
my $sel_pos = 0;

my $status_lines = 3;

my $selectable_line;

my $nr_lines = 0;

=head2 full_line

Returns line padded up to screen width

  $iselect->full_line( "foo bar" );

=cut

sub full_line {
        my $self = shift;

        my $cols = $self->screen->cols;

        my $t = shift;

        $t =~ s/{s}//;

        $t = '' unless defined $t;
        $t = substr($t,0,$cols) if length($t) > $cols;
        return $t . (" " x ($cols - length($t)));
}


=head2 redraw_line

  $iselect->redraw_line( $line_on_screen, $content_of_line );

=cut

sub redraw_line {
        my $self = shift;

        my ($l,$line) = @_;

        if ( defined $selectable_line->{ $l + $top_screen_line } ) {
                $self->screen->at($l,0)->bold()->puts( $self->full_line( $line ) )->normal();
        } else {
                $self->screen->at($l,0)->puts( $self->full_line( $line ) )
        }
}

=head2 redraw_screen

  $iselect->redraw_screen

=cut

sub redraw_screen {
        my $self = shift;
        my @lines = @{ $self->lines };
        $nr_lines = $#lines;
        for my $l (0 .. $self->screen->rows - $status_lines) {
                my $line = $lines[ $l + $top_screen_line ];
                $self->redraw_line( $l, $line );
                last if ($l == $#lines);
        }
        $self->selected;
}

=head2 redraw_statusline

Redraw status line

  $iselect->redraw_statusline;

=cut

sub redraw_statusline {
        my $self = shift;

        my $pcnt = int(($pos || 0) * 100 / ( $nr_lines || 1 ) );
        my $pos_txt = sprintf('%d/%s, %d%% ',$pos,$nr_lines,$pcnt);

        my $scr = $self->screen || confess "need screen";

        my $status_text = sprintf("pos: %-3d sel_pos: %-3d top_screen_line: %-3d", $pos, $sel_pos, $top_screen_line );

        $status_text .= ' ' . $self->status_text if $self->status_text;

        $scr->at($scr->rows - $status_lines + 1,0)->reverse()->puts(
                sprintf(' %-'.($scr->cols - length($pos_txt) - 2).'s ',$status_text)
        .$pos_txt)->normal();

        $scr->at($scr->rows - $status_lines + 2,0)->puts(
                sprintf('%-'.$scr->cols.'s', $self->error_text )
        ) if $self->error_text;
}

=head2 selected

Move selection to some line of document

  $iselect->selected( 42 );

=cut

sub selected {
        my $self = shift;

        my $new_pos = shift;

        if ( defined $new_pos ) {

                my $screen_line = $pos - $top_screen_line;
                $self->redraw_line( $screen_line, $self->lines->[$pos] );

                my $last_screen_line = $self->screen->rows - $status_lines;

                if ( $new_pos < $pos && $screen_line == 0 ) {
                        if ( $pos > 0 ) {
                                $top_screen_line--;
                                $pos--;
                                $self->screen->at(0,0)->il;
                                $self->error_text( ' ' );
                        } else {
                                $self->error_text( "Already at Begin." );
                        }
                } elsif ( $new_pos > $pos && $screen_line == $last_screen_line ) {
                        if ( $pos < $nr_lines ) {
                                $top_screen_line++;
                                $pos++;
                                $self->screen->at(0,0)->dl;
                        } else {
                                $self->error_text( "Already at End." );
                        }
                } else {
                        $pos = $new_pos;
                }
        
        }

        my $line = $self->lines->[$pos];
        if ( defined $selectable_line->{ $pos } ) {
                $self->screen->at($pos - $top_screen_line,0)->reverse->bold()->puts( $self->full_line( $line ) )->normal();
                $sel_pos = $pos;
        } else {
                $self->screen->at($pos - $top_screen_line,0)->reverse->puts( $self->full_line( $line ) );
                $sel_pos = -1;
        }
        $self->redraw_statusline;
}


=head2 loop

  $iselect->loop(
        sub {
                my $line = shift;
                warn "got line: $line\n";
        }
  );

=cut

sub loop {
        my $self = shift;

        my $callback = shift;
        confess "expect callback as first arg" unless ref($callback) eq 'CODE';

        my @lines = @{ $self->lines };

        # find which lines are selectable in input file
        for my $l (0 .. $#lines) {
                if ($lines[$l] =~ m/^{s}/) {
                        $selectable_line->{$l}++;
                }
        }

        # select first selectable line
        if ( $selectable_line ) {
                $pos = $sel_pos = (sort { $a <=> $b } keys %$selectable_line)[0];
                warn "selected first selectable line $sel_pos";
        }

        $self->open_screen unless $self->screen;

        $self->screen->clrscr()->noecho();
        $self->redraw_screen;
        $self->selected;

        my $lines_on_screen = $self->screen->rows - $status_lines;

        while(my $key = $self->screen->getch()) {

                $self->error_text('');

                if ($key eq 'ku') {
                        $self->selected( $pos - 1 );
                } elsif ($key eq 'kd') {
                        $self->selected( $pos + 1 );
                } elsif ($key eq 'pgup' ) {
                        # first line on screen?
                        if ( $pos == $top_screen_line ) {
                                $top_screen_line -= $lines_on_screen;
                                $top_screen_line = 0 if $top_screen_line < 0;
                                $self->redraw_screen;
                        }
                        if ( $pos == $top_screen_line ) {
                                $self->error_text( "Already at top." );
                        } else {
                                $self->selected( $top_screen_line );
                        }
                } elsif ($key eq 'pgdn' ) {
                        # last line on screen?
                        if ( $pos - $top_screen_line == $lines_on_screen ) {
                                $top_screen_line += $lines_on_screen;
        
                                my $max_top_screen_line = 
                                        $nr_lines > $lines_on_screen ?  $nr_lines - $lines_on_screen : 0;       

                                $top_screen_line = $max_top_screen_line if $top_screen_line > $max_top_screen_line;
                                warn "max_top_screen_line = $max_top_screen_line top_screen_line = $top_screen_line\n";
                                $self->redraw_screen;
                        }
                        if ( $pos == $nr_lines ) {
                                $self->error_text( "Already at bottom." );
                        } else {
                                $self->selected( $top_screen_line + $lines_on_screen );
                        }
                } elsif ($key eq 'g' ) {
                        if ( $top_screen_line == 0 ) {
                                if ( $pos == 0 ) {
                                        $self->error_text( "Already at top." );
                                } else {
                                        $self->selected( 0 );
                                }
                        } else {
                                $top_screen_line = 0;
                                $pos = 0;
                                $self->redraw_screen;
                        }
                }

                if ( length($key) > 1 ) {
                        $self->status_text("key: $key");
                } else {
                        $self->status_text( sprintf("key: %s [%03d][%02x]", $key =~ m/\w/ ? $key : '?' , ord($key), ord($key) ) );
                }

                # CTRL+L
                $self->redraw_screen if ord($key) eq 0x0c;

                # Enter
                if ( ord($key) eq 0x0d && $sel_pos > 0 ) {
                        $self->error_text( "execute: " . $lines[ $sel_pos ] );
                }

                return if (lc($key) eq 'q');

                $self->redraw_statusline;

        }

        $self->clrscr();
}

=head1 SEE ALSO

L<http://www.ossp.org/pkg/tool/iselect/> - Interactive Terminal Selection
written by Ralf S. Engelschall which is original implementation in C

=head1 AUTHOR

Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>

=head1 COPYRIGHT & LICENSE

Copyright 2006-2007 Dobrica Pavlinusic, All Rights Reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

1;
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;