File Coverage

blib/lib/Tickit/Widget/Entry.pm
Criterion Covered Total %
statement 9 9 100.0
branch n/a
condition n/a
subroutine 3 3 100.0
pod n/a
total 12 12 100.0


line stmt bran cond sub pod time code
1             # You may distribute under the terms of either the GNU General Public License
2             # or the Artistic License (the same terms as Perl itself)
3             #
4             # (C) Paul Evans, 2011-2014 -- leonerd@leonerd.org.uk
5              
6             package Tickit::Widget::Entry;
7              
8 1     1   949 use strict;
  1         1  
  1         23  
9 1     1   3 use warnings;
  1         1  
  1         20  
10 1     1   3 use base qw( Tickit::Widget );
  1         1  
  1         54  
11             use Tickit::Style;
12             Tickit::Window->VERSION( '0.39' ); # expose_after_scroll default on
13              
14             our $VERSION = '0.27';
15              
16             use Tickit::Utils qw( textwidth chars2cols cols2chars substrwidth );
17              
18             use constant CAN_FOCUS => 1;
19              
20             # Positions in this code can get complicated. The following conventions apply:
21             # $pos_ch = a position in CHaracters within a Unicode string (length, substr,..)
22             # $pos_co = a position in screen COlumns counted from the start of the string
23             # $pos_x = a position in screen columns from the start of the window ($win positions)
24              
25             =head1 NAME
26              
27             C - a widget for entering text
28              
29             =head1 SYNOPSIS
30              
31             use Tickit;
32             use Tickit::Widget::Entry;
33              
34             my $entry = Tickit::Widget::Entry->new(
35             on_enter => sub {
36             my ( $self, $line ) = @_;
37              
38             # process $line somehow
39              
40             $self->set_text( "" );
41             },
42             );
43              
44             Tickit->new( root => $entry )->run;
45              
46             =head1 DESCRIPTION
47              
48             This class provides a widget which allows the user to enter a line of text.
49              
50             =head1 STYLE
51              
52             The default style pen is used as the widget pen. The following style pen
53             prefixes are also used:
54              
55             =over 4
56              
57             =item more => PEN
58              
59             The pen used for the "more" scroll markers
60              
61             =back
62              
63             The following style keys are used:
64              
65             =over 4
66              
67             =item more_left => STRING
68              
69             =item more_right => STRING
70              
71             The text used to indicate that there is more content scrolled to the left or
72             right, respectively
73              
74             =back
75              
76             =cut
77              
78             style_definition base =>
79             more_fg => "cyan",
80             more_left => "<..",
81             more_right => "..>";
82              
83             use constant WIDGET_PEN_FROM_STYLE => 1;
84              
85             =head1 KEYBINDINGS
86              
87             The following keys are bound by default
88              
89             =over 2
90              
91             =item * Ctrl-K
92              
93             Delete the entire line
94              
95             =item * Ctrl-U
96              
97             Delete to the start of the line
98              
99             =item * Ctrl-W
100              
101             Delete one word backwards
102              
103             =item * Backspace
104              
105             Delete one character backwards
106              
107             =item * Delete
108              
109             Delete one character forwards
110              
111             =item * Ctrl-Delete
112              
113             Delete one word forwards
114              
115             =item * End or Ctrl-E
116              
117             Move the cursor to the end of the input line
118              
119             =item * Enter
120              
121             Accept a line of input by running the C action
122              
123             =item * Home or Ctrl-A
124              
125             Move the cursor to the beginning of the input line
126              
127             =item * Insert
128              
129             Toggle between overwrite and insert mode
130              
131             =item * Left
132              
133             Move the cursor one character left
134              
135             =item * Ctrl-Left or Alt-B
136              
137             Move the cursor one word left
138              
139             =item * Right
140              
141             Move the cursor one character right
142              
143             =item * Ctrl-Right or Alt-F
144              
145             Move the cursor one word right
146              
147             =back
148              
149             =cut
150              
151             =head1 CONSTRUCTOR
152              
153             =cut
154              
155             =head2 $entry = Tickit::Widget::Entry->new( %args )
156              
157             Constructs a new C object.
158              
159             Takes the following named arguments:
160              
161             =over 8
162              
163             =item text => STR
164              
165             Optional. Initial text to display in the box
166              
167             =item position => INT
168              
169             Optional. Initial position of the cursor within the text.
170              
171             =item on_enter => CODE
172              
173             Optional. Callback function to invoke when the C<< >> key is pressed.
174              
175             =back
176              
177             =cut
178              
179             sub new
180             {
181             my $class = shift;
182             my %params = @_;
183              
184             my $self = $class->SUPER::new( %params );
185              
186             $self->{text} = defined $params{text} ? $params{text} : "";
187             $self->{pos_ch} = defined $params{position} ? $params{position} : 0;
188              
189             my $textlen = length $self->{text};
190             $self->{pos_ch} = $textlen if $self->{pos_ch} > $textlen;
191              
192             $self->{scrolloffs_co} = 0;
193             $self->{overwrite} = 0;
194              
195             $self->{keybindings} = {
196             'C-a' => "key_beginning_of_line",
197             'C-e' => "key_end_of_line",
198             'C-k' => "key_delete_line",
199             'C-u' => "key_backward_delete_line",
200             'C-w' => "key_backward_delete_word",
201              
202             'M-b' => "key_backward_word",
203             'M-f' => "key_forward_word",
204              
205             'Backspace' => "key_backward_delete_char",
206             'Delete' => "key_forward_delete_char",
207             'C-Delete' => "key_forward_delete_word",
208             'End' => "key_end_of_line",
209             'Enter' => "key_enter_line",
210             'Home' => "key_beginning_of_line",
211             'Insert' => "key_overwrite_mode",
212             'Left' => "key_backward_char",
213             'C-Left' => "key_backward_word",
214             'Right' => "key_forward_char",
215             'C-Right' => "key_forward_word",
216             };
217              
218             $self->set_on_enter( $params{on_enter} ) if defined $params{on_enter};
219              
220             # Since we take keyboard input we almost certainly want to take focus here
221             $self->take_focus;
222              
223             return $self;
224             }
225              
226             sub lines { 1 }
227             sub cols { 5 }
228              
229             sub char2col
230             {
231             my $self = shift;
232             my ( $ch ) = @_;
233              
234             return scalar chars2cols $self->{text}, $ch;
235             }
236              
237             sub pretext_width
238             {
239             my $self = shift;
240              
241             return 0 if $self->{scrolloffs_co} == 0;
242             return textwidth( $self->get_style_values( "more_left" ) );
243             }
244              
245             sub pretext_render
246             {
247             my $self = shift;
248             my ( $rb ) = @_;
249              
250             $rb->text_at( 0, 0, $self->get_style_values( "more_left" ), $self->get_style_pen( "more" ) );
251             }
252              
253             sub posttext_width
254             {
255             my $self = shift;
256              
257             return 0 if textwidth( $self->text ) <= $self->{scrolloffs_co} + $self->window->cols;
258             return textwidth( $self->get_style_values( "more_right" ) );
259             }
260              
261             sub posttext_render
262             {
263             my $self = shift;
264             my ( $rb ) = @_;
265              
266             $rb->text_at( 0, 0, $self->get_style_values( "more_right" ), $self->get_style_pen( "more" ) );
267             }
268              
269             sub render_to_rb
270             {
271             my $self = shift;
272             my ( $rb, $rect ) = @_;
273              
274             my $cols = $self->window->cols;
275              
276             if( $rect->top == 0 ) {
277             my $text = substrwidth( $self->text, $self->{scrolloffs_co}, $cols );
278              
279             $rb->goto( 0, 0 );
280             $rb->text( $text ) if length $text;
281             $rb->erase_to( $cols );
282              
283             if( my $pretext_width = $self->pretext_width ) {
284             $rb->save;
285             $rb->clip( Tickit::Rect->new( top => 0, left => 0, lines => 1, cols => $pretext_width ) );
286              
287             $self->pretext_render( $rb );
288              
289             $rb->restore;
290             }
291              
292             if( my $posttext_width = $self->posttext_width ) {
293             $rb->save;
294             $rb->translate( 0, $cols - $posttext_width );
295             $rb->clip( Tickit::Rect->new( top => 0, left => 0, lines => 1, cols => $posttext_width ) );
296              
297             $self->posttext_render( $rb );
298              
299             $rb->restore;
300             }
301             }
302              
303             foreach my $line ( $rect->linerange( 1, undef ) ) {
304             $rb->erase_at( $line, 0, $cols );
305             }
306              
307             $self->reposition_cursor;
308             }
309              
310             sub _recalculate_scroll
311             {
312             my $self = shift;
313             my ( $pos_ch ) = @_;
314              
315             my $pos_co = $self->char2col( $pos_ch );
316             my $off_co = $self->{scrolloffs_co};
317              
318             my $pos_x = $pos_co - $off_co;
319              
320             my $width = $self->window->cols;
321             my $halfwidth = int( $width / 2 );
322              
323             # Don't even try unless we have at least 2 columns
324             return unless $halfwidth;
325              
326             # Try to keep the cursor within 5 columns of the window edge
327             while( $pos_x < 5 and $off_co >= 5 ) {
328             $off_co -= $halfwidth;
329             $off_co = 0 if $off_co < 0;
330             $pos_x = $pos_co - $off_co;
331             }
332             while( $pos_x > ( $width - 5 ) ) {
333             $off_co += $halfwidth;
334             $pos_x = $pos_co - $off_co;
335             }
336              
337             return $off_co if $off_co != $self->{scrolloffs_co};
338             return undef;
339             }
340              
341             sub reposition_cursor
342             {
343             my $self = shift;
344             my ( $pos_ch ) = @_;
345              
346             my $win = $self->window or return;
347              
348             $self->{pos_ch} = $pos_ch if defined $pos_ch;
349              
350             my $new_scrolloffs = $self->_recalculate_scroll( $self->{pos_ch} );
351             if( defined $new_scrolloffs ) {
352             $self->{scrolloffs_co} = $new_scrolloffs;
353             $self->redraw;
354             }
355              
356             my $pos_x = $self->char2col( $self->{pos_ch} ) - $self->{scrolloffs_co};
357              
358             $win->cursor_at( 0, $pos_x );
359             }
360              
361             sub _text_spliced
362             {
363             my $self = shift;
364             my ( $pos_ch, $deleted, $inserted, $at_end ) = @_;
365              
366             my $win = $self->window;
367             my $width = $win->cols;
368              
369             my $insertedlen_co = textwidth $inserted;
370             my $deletedlen_co = textwidth $deleted;
371              
372             my $delta_co = $insertedlen_co - $deletedlen_co;
373              
374             my $pos_co = $self->char2col( $pos_ch );
375             my $pos_x = $pos_co - $self->{scrolloffs_co};
376              
377             # Don't bother at all if the affected range is scrolled off the right
378             return if $pos_x >= $width;
379              
380             if( $pos_x < 0 ) {
381             die "TODO: text_splice before window - what to do??\n";
382             }
383              
384             my $need_reprint = 0;
385              
386             # No point doing a scrollrect if there's nothing after here
387             if( $delta_co != 0 and !$at_end ) {
388             $win->scrollrect( 0, $pos_x, 1, $win->cols - $pos_x, 0, -$delta_co ) or
389             $need_reprint = 1;
390             }
391              
392             if( $need_reprint ) {
393             # ICH/DCH failed; we'll have to reprint the entire rest of the line from
394             # here
395             $win->expose(
396             Tickit::Rect->new( top => 0, left => $pos_x, lines => 1, right => $width )
397             );
398             return;
399             }
400              
401             if( $insertedlen_co > 0 ) {
402             $win->expose(
403             Tickit::Rect->new( top => 0, left => $pos_x, lines => 1, cols => $insertedlen_co )
404             );
405              
406             if( my $posttext_width = $self->posttext_width ) {
407             $win->expose(
408             Tickit::Rect->new( top => 0, left => $width - $posttext_width, lines => 1, right => $width )
409             );
410             }
411             }
412              
413             if( $delta_co < 0 and $self->{scrolloffs_co} + $width < textwidth $self->text ) {
414             # Add extra damage to redraw the trashed posttext marker
415             my $rhs_x = -$delta_co + $self->posttext_width;
416              
417             $win->expose(
418             Tickit::Rect->new( top => 0, left => $width - $rhs_x, lines => 1, right => $width )
419             );
420             }
421             }
422              
423             sub on_key
424             {
425             my $self = shift;
426             my ( $args ) = @_;
427              
428             return 0 unless $self->window->is_focused;
429              
430             my $type = $args->type;
431             my $str = $args->str;
432              
433             if( $type eq "key" and my $code = $self->{keybindings}{$str} ) {
434             $self->$code( $str );
435             return 1;
436             }
437             if( $type eq "text" ) {
438             $self->on_text( $str );
439             return 1;
440             }
441              
442             return 0;
443             }
444              
445             sub on_text
446             {
447             my $self = shift;
448             my ( $text ) = @_;
449              
450             $self->text_splice( $self->{pos_ch}, $self->{overwrite} ? 1 : 0, $text );
451             }
452              
453             sub on_mouse
454             {
455             my $self = shift;
456             my ( $args ) = @_;
457              
458             return unless $args->type eq "press" and $args->button == 1;
459              
460             my $pos_ch = scalar cols2chars $self->{text}, $args->col + $self->{scrolloffs_co};
461             $self->set_position( $pos_ch );
462             }
463              
464             =head1 ACCESSORS
465              
466             =cut
467              
468             =head2 $on_enter = $entry->on_enter
469              
470             =cut
471              
472             sub on_enter
473             {
474             my $self = shift;
475             return $self->{on_enter};
476             }
477              
478             =head2 $entry->set_on_enter( $on_enter )
479              
480             Return or set the CODE reference to be called when the C
481             action is invoked; usually bound to the C key.
482              
483             $on_enter->( $entry, $line )
484              
485             =cut
486              
487             sub set_on_enter
488             {
489             my $self = shift;
490             ( $self->{on_enter} ) = @_;
491             }
492              
493             =head2 $offset = $entry->position
494              
495             Returns the current entry position, in terms of characters within the text.
496              
497             =cut
498              
499             sub position
500             {
501             my $self = shift;
502             return $self->{pos_ch};
503             }
504              
505             =head2 $entry->set_position( $position )
506              
507             Set the text entry position, moving the cursor
508              
509             =cut
510              
511             sub set_position
512             {
513             my $self = shift;
514             my ( $pos_ch ) = @_;
515              
516             $pos_ch = 0 if $pos_ch < 0;
517             $pos_ch = length $self->{text} if $pos_ch > length $self->{text};
518              
519             $self->reposition_cursor( $pos_ch );
520             }
521              
522             =head1 METHODS
523              
524             =cut
525              
526             =head2 $entry->bind_keys( $keystr => $value, ... )
527              
528             Associate methods or CODE references with keypresses. On receipt of a the key
529             the method or CODE reference will be invoked, being passed the stringified key
530             representation and the underlying C structure.
531              
532             $ret = $entry->method( $keystr, $key )
533             $ret = $coderef->( $entry, $keystr, $key )
534              
535             This method takes a hash of keystring/value pairs. Binding a value of C
536             will remove it.
537              
538             =cut
539              
540             sub bind_keys
541             {
542             my $self = shift;
543             while( @_ ) {
544             my $str = shift;
545             my $value = shift;
546              
547             if( defined $value ) {
548             $self->{keybindings}{$str} = $value;
549             }
550             else {
551             delete $self->{keybindings}{$str};
552             }
553             }
554             }
555              
556             =head1 TEXT MODEL METHODS
557              
558             These methods operate on the text input buffer directly, updating the stored
559             text and changing the rendered display to reflect the changes. They can be
560             used by a program to directly manipulate the text.
561              
562             =cut
563              
564             =head2 $text = $entry->text
565              
566             Returns the currently entered text.
567              
568             =cut
569              
570             sub text
571             {
572             my $self = shift;
573             return $self->{text};
574             }
575              
576             =head2 $entry->set_text( $text )
577              
578             Replace the text in the entry box. This completely redraws the widget's
579             window. It is largely provided for initialisation; for normal edits (such as
580             from keybindings), it is preferrable to use C, C or
581             C.
582              
583             =cut
584              
585             sub set_text
586             {
587             my $self = shift;
588             my ( $text ) = @_;
589              
590             $self->{text} = $text;
591             $self->{pos_ch} = length $text if $self->{pos_ch} > length $text;
592              
593             $self->redraw;
594             }
595              
596             =head2 $entry->text_insert( $text, $pos_ch )
597              
598             Insert the given text at the given character position.
599              
600             =cut
601              
602             sub text_insert
603             {
604             my $self = shift;
605             my ( $text, $pos_ch ) = @_;
606              
607             $self->text_splice( $pos_ch, 0, $text );
608             }
609              
610             =head2 $deleted = $entry->text_delete( $pos_ch, $len_ch )
611              
612             Delete the given section of text. Returns the deleted text.
613              
614             =cut
615              
616             sub text_delete
617             {
618             my $self = shift;
619             my ( $pos_ch, $len_ch ) = @_;
620              
621             return $self->text_splice( $pos_ch, $len_ch, "" );
622             }
623              
624             =head2 $deleted = $entry->text_splice( $pos_ch, $len_ch, $text )
625              
626             Replace the given section of text with the given replacement. Returns the
627             text deleted from the section.
628              
629             =cut
630              
631             sub text_splice
632             {
633             my $self = shift;
634             my ( $pos_ch, $len_ch, $text ) = @_;
635              
636             my $textlen_ch = length($text);
637              
638             my $delta_ch = $textlen_ch - $len_ch;
639              
640             my $at_end = ( $pos_ch == length $self->{text} );
641              
642             my $deleted = substr( $self->{text}, $pos_ch, $len_ch, $text );
643              
644             my $new_pos_ch;
645              
646             if( $self->{pos_ch} >= $pos_ch + $len_ch ) {
647             # Cursor after splice; move to suit
648             $new_pos_ch = $self->position + $delta_ch;
649             }
650             elsif( $self->{pos_ch} >= $pos_ch ) {
651             # Cursor within splice; move to end
652             $new_pos_ch = $pos_ch + $textlen_ch;
653             }
654             # else { ignore }
655              
656             # No point incrementally updating as we'll have to scroll anyway
657             unless( defined $new_pos_ch and defined $self->_recalculate_scroll( $new_pos_ch ) ) {
658             $self->_text_spliced( $pos_ch, $deleted, $text, $at_end );
659             }
660              
661             $self->reposition_cursor( $new_pos_ch ) if defined $new_pos_ch and $new_pos_ch != $self->{pos_ch};
662              
663             return $deleted;
664             }
665              
666             =head2 $pos = $entry->find_bow_forward( $initial, $else )
667              
668             Search forward in the string, returning the character position of the next
669             beginning of word from the initial position. If none is found, returns
670             C<$else>.
671              
672             =cut
673              
674             sub find_bow_forward
675             {
676             my $self = shift;
677             my ( $pos, $else ) = @_;
678              
679             my $posttext = substr( $self->text, $pos );
680              
681             return $posttext =~ m/(?<=\s)\S/ ? $pos + $-[0] : $else;
682             }
683              
684             =head2 $pos = $entry->find_eow_forward( $initial )
685              
686             Search forward in the string, returning the character position of the next
687             end of word from the initial position. If none is found, returns the length of
688             the string.
689              
690             =cut
691              
692             sub find_eow_forward
693             {
694             my $self = shift;
695             my ( $pos ) = @_;
696              
697             my $posttext = substr( $self->text, $pos );
698              
699             $posttext =~ m/(?<=\S)\s|$/;
700             return $pos + $-[0];
701             }
702              
703             =head2 $pos = $entry->find_bow_backward( $initial )
704              
705             Search backward in the string, returning the character position of the
706             previous beginning of word from the initial position. If none is found,
707             returns 0.
708              
709             =cut
710              
711             sub find_bow_backward
712             {
713             my $self = shift;
714             my ( $pos ) = @_;
715              
716             my $pretext = substr( $self->text, 0, $pos );
717              
718             return $pretext =~ m/.*\s(?=\S)/ ? $+[0] : 0;
719             }
720              
721             =head2 $pos = $entry->find_eow_backward( $initial )
722              
723             Search backward in the string, returning the character position of the
724             previous end of word from the initial position. If none is found, returns
725             C.
726              
727             =cut
728              
729             sub find_eow_backward
730             {
731             my $self = shift;
732             my ( $pos ) = @_;
733              
734             my $pretext = substr( $self->text, 0, $pos + 1 ); # +1 to allow if cursor is on the space
735              
736             return $pretext =~ m/.*\S(?=\s)/ ? $+[0] : undef;
737             }
738              
739             ## Key binding methods
740              
741             sub key_backward_char
742             {
743             my $self = shift;
744              
745             if( $self->{pos_ch} > 0 ) {
746             $self->set_position( $self->{pos_ch} - 1 );
747             }
748             }
749              
750             sub key_backward_delete_char
751             {
752             my $self = shift;
753              
754             if( $self->{pos_ch} > 0 ) {
755             $self->text_delete( $self->{pos_ch} - 1, 1 );
756             }
757             }
758              
759             sub key_backward_delete_line
760             {
761             my $self = shift;
762              
763             $self->text_delete( 0, $self->{pos_ch} );
764             }
765              
766             sub key_backward_delete_word
767             {
768             my $self = shift;
769              
770             my $bow = $self->find_bow_backward( $self->{pos_ch} );
771             $self->text_delete( $bow, $self->{pos_ch} - $bow );
772             }
773              
774             sub key_backward_word
775             {
776             my $self = shift;
777              
778             if( $self->{pos_ch} > 0 ) {
779             $self->set_position( $self->find_bow_backward( $self->{pos_ch} ) );
780             }
781             }
782              
783             sub key_beginning_of_line
784             {
785             my $self = shift;
786              
787             $self->set_position( 0 );
788             }
789              
790             sub key_delete_line
791             {
792             my $self = shift;
793              
794             $self->text_delete( 0, length $self->text );
795             }
796              
797             sub key_end_of_line
798             {
799             my $self = shift;
800              
801             $self->set_position( length $self->{text} );
802             }
803              
804             sub key_enter_line
805             {
806             my $self = shift;
807              
808             my $text = $self->text;
809             return unless length $text;
810              
811             my $on_enter = $self->{on_enter} or return;
812             $on_enter->( $self, $text );
813             }
814              
815             sub key_forward_char
816             {
817             my $self = shift;
818              
819             if( $self->{pos_ch} < length $self->{text} ) {
820             $self->set_position( $self->{pos_ch} + 1 );
821             }
822             }
823              
824             # Renamed from readline's "delete-char" because this one doesn't have the EOF
825             # behaviour if input line is empty
826             sub key_forward_delete_char
827             {
828             my $self = shift;
829              
830             if( $self->{pos_ch} < length $self->{text} ) {
831             $self->text_delete( $self->{pos_ch}, 1 );
832             }
833             }
834              
835             sub key_forward_delete_word
836             {
837             my $self = shift;
838              
839             my $bow = $self->find_bow_forward( $self->{pos_ch}, length $self->text );
840             $self->text_delete( $self->{pos_ch}, $bow - $self->{pos_ch} );
841             }
842              
843             sub key_forward_word
844             {
845             my $self = shift;
846              
847             my $bow = $self->find_bow_forward( $self->{pos_ch}, length $self->text );
848             $self->set_position( $bow );
849             }
850              
851             sub key_overwrite_mode
852             {
853             my $self = shift;
854              
855             $self->{overwrite} = !$self->{overwrite};
856             }
857              
858             =head1 TODO
859              
860             =over 4
861              
862             =item * Plugin ability
863              
864             Try to find a nice way to allow loaded plugins, possibly per-instance if not
865             just globally or per-class. See how many of these TODO items can be done using
866             plugins.
867              
868             =item * More readline behaviours
869              
870             History. Isearch. History replay. Transpose. Transcase. Yank ring. Numeric
871             prefixes.
872              
873             =item * Visual selection behaviour
874              
875             Shift-movement, or vim-style. Mouse.
876              
877             =back
878              
879             =head1 AUTHOR
880              
881             Paul Evans
882              
883             =cut
884              
885             0x55AA;