1# ----------------------------------------------------------------------
2# Curses::UI::Common
3#
4# (c) 2001-2002 by Maurice Makaay. All rights reserved.
5# (c) 2003-2005 by Marcus Thiesen et al.
6# This file is part of Curses::UI. Curses::UI is free software.
7# You can redistribute it and/or modify it under the same terms
8# as perl itself.
9#
10# Currently maintained by Marcus Thiesen
11# e-mail: marcus@cpan.thiesenweb.de
12# ----------------------------------------------------------------------
13
14# TODO: fix dox
15
16package Curses::UI::Common;
17
18use strict;
19use Term::ReadKey;
20use Curses;
21require Exporter;
22
23use vars qw(
24    @ISA
25    @EXPORT_OK
26    @EXPORT
27    $VERSION
28);
29
30$VERSION = '1.10';
31
32@ISA = qw(
33    Exporter
34);
35
36@EXPORT = qw(
37    keys_to_lowercase
38    text_wrap
39    text_draw
40    text_length
41    text_chop
42    scrlength
43    split_to_lines
44    text_dimension
45    CUI_ESCAPE       CUI_SPACE      CUI_TAB
46    WORDWRAP         NO_WORDWRAP
47);
48
49# ----------------------------------------------------------------------
50# Misc. routines
51# ----------------------------------------------------------------------
52
53sub parent()
54{
55    my $this = shift;
56    $this->{-parent};
57}
58
59sub root()
60{
61    my $this = shift;
62    my $root = $this;
63    while (defined $root->{-parent}) {
64        $root = $root->{-parent};
65    }
66    return $root;
67}
68
69sub accessor($;$)
70{
71    my $this  = shift;
72    my $key   = shift;
73    my $value = shift;
74
75    $this->{$key} = $value if defined $value;
76    return $this->{$key};
77}
78
79sub keys_to_lowercase($;)
80{
81    my $hash = shift;
82
83    my $copy = {%$hash};
84    while (my ($k,$v) = each %$copy) {
85        $hash->{lc $k} = $v;
86    }
87
88    return $hash;
89}
90
91# ----------------------------------------------------------------------
92# Text processing
93# ----------------------------------------------------------------------
94
95sub split_to_lines($;)
96{
97    # Make $this->split_to_lines() possible.
98    shift if ref $_[0];
99    my $text = shift;
100
101    # Break up the text in lines. IHATEBUGS is
102    # because a split with /\n/ on "\n\n\n" would
103    # return zero result :-(
104    my @lines = split /\n/, $text . "IHATEBUGS";
105    $lines[-1] =~ s/IHATEBUGS$//g;
106
107    return \@lines;
108}
109
110sub scrlength($;)
111{
112    # Make $this->scrlength() possible.
113    shift if ref $_[0];
114    my $line = shift;
115
116    return 0 unless defined $line;
117
118    my $scrlength = 0;
119    for (my $i=0; $i < length($line); $i++)
120    {
121        my $chr = substr($line, $i, 1);
122        $scrlength++;
123        if ($chr eq "\t") {
124            while ($scrlength%8) {
125                $scrlength++;
126            }
127        }
128    }
129    return $scrlength;
130}
131
132# Contstants for text_wrap()
133sub NO_WORDWRAP() { 1 }
134sub WORDWRAP()    { 0 }
135
136sub text_wrap($$;)
137{
138    # Make $this->text_wrap() possible.
139    shift if ref $_[0];
140    my ($line, $maxlen, $wordwrap) = @_;
141    $wordwrap = WORDWRAP unless defined $wordwrap;
142    $maxlen = int $maxlen;
143
144    return [""] if $line eq '';
145
146    my @wrapped = ();
147    my $len = 0;
148    my $wrap = '';
149
150    # Special wrapping is needed if the line contains tab
151    # characters. These should be expanded to the TAB-stops.
152    if ($line =~ /\t/)
153    {
154        CHAR: for (my $i = 0; $i <= length($line); $i++)
155        {
156            my $nextchar = substr($line, $i, 1);
157
158            # Find the length of the string in case the
159            # next character is added.
160            my $newlen = $len + 1;
161            if ($nextchar eq "\t") { while($newlen%8) { $newlen++ } }
162
163            # Would that go beyond the end of the available width?
164            if ($newlen > $maxlen)
165            {
166                if ($wordwrap == WORDWRAP
167                    and $wrap =~ /^(.*)([\s])(\S+)$/)
168		{
169                    push @wrapped, $1 . $2;
170                    $wrap = $3;
171                    $len = scrlength($wrap) + 1;
172                } else {
173                    $len = 1;
174                    push @wrapped, $wrap;
175                    $wrap = '';
176                }
177            } else {
178                $len = $newlen;
179            }
180            $wrap .= $nextchar;
181        }
182        push @wrapped, $wrap if defined $wrap;
183
184    # No tab characters in the line? Then life gets a bit easier. We can
185    # process large chunks at once.
186    } else {
187        my $idx = 0;
188
189        # Line shorter than allowed? Then return immediately.
190        return [$line] if length($line) < $maxlen;
191        return ["internal wrap error: wraplength undefined"]
192            unless defined $maxlen;
193
194        CHUNK: while ($idx < length($line))
195        {
196            my $next = substr($line, $idx, $maxlen);
197            if (length($next) < $maxlen)
198            {
199                push @wrapped, $next;
200                last CHUNK;
201            }
202            elsif ($wordwrap == WORDWRAP)
203            {
204                my $space_idx = rindex($next, " ");
205                if ($space_idx == -1 or $space_idx == 0)
206                {
207                    push @wrapped, $next;
208                    $idx += $maxlen;
209                } else {
210                    push @wrapped, substr($next, 0, $space_idx + 1);
211                    $idx += $space_idx + 1;
212                }
213            } else {
214                push @wrapped, $next;
215                $idx += $maxlen;
216            }
217        }
218    }
219
220    return \@wrapped;
221}
222
223sub text_tokenize {
224    my ($text) = @_;
225
226    my @tokens = ();
227    while ($text ne '') {
228        if ($text =~ m/^<\/?[a-zA-Z0-9_]+>/s) {
229            push(@tokens, $&);
230            $text = $';
231        }
232        elsif ($text =~ m/^.+?(?=<\/?[a-zA-Z0-9_]+>)/s) {
233            push(@tokens, $&);
234            $text = $';
235        }
236        else {
237            push(@tokens, $text);
238            last;
239        }
240    }
241    return @tokens;
242}
243
244sub text_draw($$;)
245{
246    my $this = shift;
247    my ($y, $x, $text) = @_;
248
249    if ($this->{-htmltext}) {
250        my @tokens = &text_tokenize($text);
251        foreach my $token (@tokens) {
252            if ($token =~ m/^<(standout|reverse|bold|underline|blink|dim)>$/s) {
253                my $type = $1;
254                if    ($type eq 'standout')  { $this->{-canvasscr}->attron(A_STANDOUT);  }
255                elsif ($type eq 'reverse')   { $this->{-canvasscr}->attron(A_REVERSE);   }
256                elsif ($type eq 'bold')      { $this->{-canvasscr}->attron(A_BOLD);      }
257                elsif ($type eq 'underline') { $this->{-canvasscr}->attron(A_UNDERLINE); }
258                elsif ($type eq 'blink')     { $this->{-canvasscr}->attron(A_BLINK);     }
259                elsif ($type eq 'dim')       { $this->{-canvasscr}->attron(A_DIM);       }
260            } elsif ($token =~ m/^<\/(standout|reverse|bold|underline|blink|dim)>$/s) {
261                my $type = $1;
262                if    ($type eq 'standout')  { $this->{-canvasscr}->attroff(A_STANDOUT);  }
263                elsif ($type eq 'reverse')   { $this->{-canvasscr}->attroff(A_REVERSE);   }
264                elsif ($type eq 'bold')      { $this->{-canvasscr}->attroff(A_BOLD);      }
265                elsif ($type eq 'underline') { $this->{-canvasscr}->attroff(A_UNDERLINE); }
266                elsif ($type eq 'blink')     { $this->{-canvasscr}->attroff(A_BLINK);     }
267                elsif ($type eq 'dim')       { $this->{-canvasscr}->attroff(A_DIM);       }
268		# Tags: (see, man 5 terminfo)
269		#   |  <4_ACS_VLINE>  --  Vertical line (4 items).
270		#   -- <5_ACS_HLINE>  --  Horizontal line (5 items).
271		#   `  <12_ACS_TTEE>  --  Tee pointing down (12 items).
272		#   ~  <ACS_BTEE>     --  Tee pointing up (1 item).
273		#   +  <ACS_PLUS>     --  Large plus or crossover (1 item).
274		# ------------------------------------------------------------------
275	    } elsif ($token =~ m/^<(\d*)_?(ACS_HLINE|ACS_VLINE|ACS_TTEE|ACS_BTEE|ACS_PLUS)>$/s) {
276		no strict 'refs';
277		my $scrlen = ($1 || 1);
278		my $type = &{ $2 };
279		$this->{-canvasscr}->hline( $y, $x, $type, $scrlen );
280		$x += $scrlen;
281	    } else {
282                $this->{-canvasscr}->addstr($y, $x, $token);
283                $x += length($token);
284            }
285        }
286    }
287    else {
288        $this->{-canvasscr}->addstr($y, $x, $text);
289    }
290}
291
292sub text_length {
293    my $this = shift;
294    my ($text) = @_;
295
296    my $length = 0;
297    if ($this->{-htmltext}) {
298        my @tokens = &text_tokenize($text);
299        foreach my $token (@tokens) {
300            if ($token !~ m/^<\/?(reverse|bold|underline|blink|dim)>$/s) {
301                $length += length($token);
302            }
303        }
304    }
305    else {
306        $length = length($text);
307    }
308    return $length;
309}
310
311sub text_chop {
312    my $this = shift;
313    my ($text, $max_length) = @_;
314
315    if ($this->{-htmltext}) {
316        my @open = ();
317        my @tokens = &text_tokenize($text);
318        my $length = 0;
319        $text = '';
320        foreach my $token (@tokens) {
321            if ($token =~ m/^<(\/?)(reverse|bold|underline|blink|dim)>/s) {
322                my ($type, $name) = ($1, $2);
323                if (defined($type) and $type eq '/') {
324                    pop(@open);
325                }
326                else {
327                    push(@open, $name);
328                }
329                $text .= $token;
330            }
331            else {
332                $text .= $token;
333                $length += length($token);
334                if ($length > $max_length) {
335                    $text = substr($text, 0, $max_length);
336                    $text =~ s/.$/\$/;
337                    while (defined($token = pop(@open))) {
338                        $text .= "</$token>";
339                    }
340                    last;
341                }
342            }
343        }
344    }
345    else {
346        if (length($text) > $max_length) {
347            $text = substr($text, 0, $max_length);
348        }
349    }
350    return $text;
351}
352
353sub text_dimension ($;)
354{
355    # Make $this->text_wrap() possible.
356    shift if ref $_[0];
357    my $text = shift;
358
359    my $lines = split_to_lines($text);
360
361    my $height = scalar @$lines;
362
363    my $width = 0;
364    foreach (@$lines)
365    {
366        my $l = length($_);
367        $width = $l if $l > $width;
368    }
369
370    return ($width, $height);
371}
372
373# ----------------------------------------------------------------------
374# Keyboard input
375# ----------------------------------------------------------------------
376
377# Constants:
378
379# Keys that are not defined in curses.h, but which might come in handy.
380sub CUI_ESCAPE()       { "\x1b" }
381sub CUI_TAB()          { "\t"   }
382sub CUI_SPACE()        { " "    }
383
384# Make ascii representation of a key.
385sub key_to_ascii($;)
386{
387    my $this = shift;
388    my $key  = shift;
389
390    if ($key eq CUI_ESCAPE()) {
391	$key = '<Esc>';
392    }
393    # Control characters. Change them into something printable
394    # via Curses' unctrl function.
395    elsif ($key lt ' ' and $key ne "\n" and $key ne "\t") {
396        $key = '<' . uc(unctrl($key)) . '>';
397    }
398
399    # Extended keys get translated into their names via Curses'
400    # keyname function.
401    elsif ($key =~ /^\d{2,}$/) {
402        $key = '<' . uc(keyname($key)) . '>';
403    }
404
405    return $key;
406}
407
408# For the select() syscall in char_read().
409my $rin = '';
410my $fno = fileno(STDIN);
411$fno = 0 unless $fno >= 0;
412vec($rin, $fno ,  1) = 1;
413
414sub char_read(;$)
415{
416    my $this = shift;
417    my $blocktime = shift;
418
419    # Initialize the toplevel window for
420    # reading a key.
421    my $s = $this->root->{-canvasscr};
422    noecho();
423    raw();
424    $s->keypad(1);
425
426    # Read input on STDIN.
427    my $key = '-1';
428    $blocktime = undef if $blocktime < 0; # Wait infinite
429    my $crin = $rin;
430    $! = 0;
431    my $found = select($crin, undef, undef, $blocktime);
432
433    if ($found < 0 ) {
434	print STDERR "DEBUG: get_key() -> select() -> $!\n"
435	    if $Curses::UI::debug;
436    } elsif ($found) {
437	$key = $s->getch();
438    }
439
440    return $key;
441}
442
443sub get_key(;$)
444{
445    my $this            = shift;
446    my $blocktime       = shift || 0;
447
448    my $key = $this->char_read($blocktime);
449
450    # ------------------------------------ #
451    #  Hacks for broken termcaps / curses  #
452    # ------------------------------------ #
453
454    $key = KEY_BACKSPACE if (
455	ord($key) == 127 or
456	$key eq "\cH"
457    );
458
459    $key = KEY_DC if (
460	$key eq "\c?" or
461	$key eq "\cD"
462    );
463
464    $key = KEY_ENTER if (
465        $key eq "\n" or
466	$key eq "\cM"
467    );
468
469    # Catch ESCape sequences.
470    my $ESC = CUI_ESCAPE();
471    if ($key eq $ESC)
472    {
473        $key .= $this->char_read(0);
474
475        # Only ESC pressed?
476        $key = $ESC if $key eq "${ESC}-1"
477                or $key eq "${ESC}${ESC}";
478        return $key if $key eq $ESC;
479
480        # Not only a single ESC?
481        # Then get extra keypresses.
482        $key .= $this->char_read(0);
483        while ($key =~ /\[\d+$/) {
484            $key .= $this->char_read(0);
485        }
486
487        # Function keys on my Sun Solaris box.
488	# I have no idea of the portability of
489	# this stuff, but it works for me...
490        if ($key =~ /\[(\d+)\~/)
491        {
492            my $digit = $1;
493            if ($digit >= 11 and $digit <= 15) {
494                $key = KEY_F($digit-10);
495            } elsif ($digit >= 17 and $digit <= 21) {
496                $key = KEY_F($digit-11);
497            }
498        }
499
500        $key = KEY_HOME if (
501            $key eq $ESC . "OH"  or
502	    $key eq $ESC . "[7~" or
503	    $key eq $ESC . "[1~"
504        );
505
506	$key = KEY_BTAB if (
507	    $key eq $ESC . "OI"  or   # My xterm under solaris
508	    $key eq $ESC . "[Z"       # My xterm under Redhat Linux
509	);
510
511        $key = KEY_DL if (
512            $key eq $ESC . "[2K"
513        );
514
515        $key = KEY_END if (
516	    $key eq $ESC . "OF"  or
517	    $key eq $ESC . "[4~"
518        );
519
520        $key = KEY_PPAGE if (
521	    $key eq $ESC . "[5~"
522        );
523
524        $key = KEY_NPAGE if (
525	    $key eq $ESC . "[6~"
526        );
527    }
528
529    # ----------#
530    # Debugging #
531    # ----------#
532
533    if ($Curses::UI::debug and $key ne "-1")
534    {
535        my $k = '';
536        my @k = split //, $key;
537        foreach (@k) { $k .= $this->key_to_ascii($_) }
538        print STDERR "DEBUG: get_key() -> [$k]\n"
539    }
540
541    return $key;
542}
543
5441;
545
546
547=pod
548
549=head1 NAME
550
551Curses::UI::Common - Common methods for Curses::UI
552
553=head1 CLASS HIERARCHY
554
555 Curses::UI::Common - base class
556
557
558=head1 SYNOPSIS
559
560    package MyPackage;
561
562    use Curses::UI::Common;
563    use vars qw(@ISA);
564    @ISA = qw(Curses::UI::Common);
565
566=head1 DESCRIPTION
567
568Curses::UI::Common is a collection of methods that is
569shared between Curses::UI classes.
570
571
572
573
574=head1 METHODS
575
576=head2 Various methods
577
578=over 4
579
580=item * B<parent> ( )
581
582Returns the data member $this->{B<-parent>}.
583
584=item * B<root> ( )
585
586Returns the topmost B<-parent> (the Curses::UI instance).
587
588=item * B<delallwin> ( )
589
590This method will walk through all the data members of the
591class intance. Each data member that is a Curses::Window
592descendant will be removed.
593
594=item * B<accessor> ( NAME, [VALUE] )
595
596If VALUE is set, the value for the data member $this->{NAME}
597will be changed. The method will return the current value for
598data member $this->{NAME}.
599
600=item * B<keys_to_lowercase> ( HASHREF )
601
602All keys in the hash referred to by HASHREF will be
603converted to lower case.
604
605=back
606
607
608=head2 Text processing
609
610=over 4
611
612=item B<split_to_lines> ( TEXT )
613
614This method will split TEXT into a list of separate lines.
615It returns a reference to this list.
616
617=item B<scrlength> ( LINE )
618
619Returns the screenlength of the string LINE. The difference
620with the perl function length() is that this method will
621expand TAB characters. It is exported by this class and it may
622be called as a stand-alone routine.
623
624=item B<text_dimension> ( TEXT )
625
626This method will return an array containing the width
627(the length of the longest line) and the height (the
628number of lines) of the TEXT.
629
630=item B<text_wrap> ( LINE, LENGTH, WORDWRAP )
631
632=item B<WORDWRAP> ( )
633
634=item B<NO_WORDWRAP> ( )
635
636This method will wrap a line of text (LINE) to a
637given length (LENGTH). If the WORDWRAP argument is
638true, wordwrap will be enabled (this is the default
639for WORDWRAP). It will return a reference to a list
640of wrapped lines. It is exported by this class and it may
641be called as a stand-alone routine.
642
643The B<WORDWRAP> and B<NO_WORDWRAP> routines will
644return the correct value vor the WORDWRAP argument.
645These routines are exported by this class.
646
647Example:
648
649    $this->text_wrap($line, 50, NO_WORDWRAP);
650
651=back
652
653
654
655=head2 Reading key input
656
657=over 4
658
659=item B<CUI_ESCAPE> ( )
660
661=item B<CUI_TAB> ( )
662
663=item B<CUI_SPACE> ( )
664
665These are a couple of routines that are not defined by the
666L<Curses|Curses> module, but which might be useful anyway.
667These routines are exported by this class.
668
669=item B<get_key> ( BLOCKTIME, CURSOR )
670
671This method will try to read a key from the keyboard.
672It will return the key pressed or -1 if no key was
673pressed. It is exported by this class and it may
674be called as a stand-alone routine.
675
676The BLOCKTIME argument can be used to set
677the curses halfdelay (the time to wait before the
678routine decides that no key was pressed). BLOCKTIME is
679given in tenths of seconds. The default is 0 (non-blocking
680key read).
681
682Example:
683
684    my $key = $this->get_key(5)
685
686=back
687
688
689
690=head1 SEE ALSO
691
692L<Curses::UI|Curses::UI>
693
694
695
696
697=head1 AUTHOR
698
699Copyright (c) 2001-2002 Maurice Makaay. All rights reserved.
700
701Maintained by Marcus Thiesen (marcus@cpan.thiesenweb.de)
702
703
704This package is free software and is provided "as is" without express
705or implied warranty. It may be used, redistributed and/or modified
706under the same terms as perl itself.
707
708