This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update Term-UI to CPAN version 0.24
[perl5.git] / cpan / Term-UI / t / 02_ui.t
1 ### Term::UI test suite ###
2
3 use strict;
4 use lib qw[../lib lib];
5 use Test::More tests => 19;
6 use Term::ReadLine;
7
8 use_ok( 'Term::UI' );
9
10 ### make sure we can do this automatically ###
11 $Term::UI::AUTOREPLY    = $Term::UI::AUTOREPLY  = 1;
12 $Term::UI::VERBOSE      = $Term::UI::VERBOSE    = 0;
13
14 # SKIP tests if we aren't on a terminal
15 SKIP: {
16
17 skip 'not on a terminal', 18 unless -t;
18
19 ### enable warnings
20 $^W = 1;
21
22 ### perl core gets upset if we print stuff to STDOUT...
23 if( $ENV{PERL_CORE} ) {
24     *STDOUT_SAVE = *STDOUT_SAVE = *STDOUT;
25     close *STDOUT;
26     open *STDOUT, ">termui.$$" or diag("Could not open tempfile");
27 }
28 END { close *STDOUT && unlink "termui.$$" if $ENV{PERL_CORE} }
29
30
31 ### so T::RL doesn't go nuts over no console
32 BEGIN{ $ENV{LINES}=25; $ENV{COLUMNS}=80; }
33 my $term = Term::ReadLine->new('test')
34                 or diag "Could not create a new term. Dying", die;
35
36 my $tmpl = {
37         prompt  => "What is your favourite colour?",
38         choices => [qw|blue red green|],
39         default => 'blue',
40     };
41
42 {
43     my $args = \%{ $tmpl };
44
45     is( $term->get_reply( %$args ), 'blue', q[Checking reply with defaults and choices] );
46 }
47
48 {
49     my $args = \%{ $tmpl };
50     delete $args->{choices};
51
52     is( $term->get_reply( %$args ), 'blue', q[Checking reply with defaults] );
53 }
54
55 {
56     my $args = {
57         prompt  => 'Do you like cookies?',
58         default => 'y',
59     };
60
61     is( $term->ask_yn( %$args ), 1, q[Asking yes/no with 'yes' as default] );
62 }
63
64 {
65     my $args = {
66         prompt  => 'Do you like Python?',
67         default => 'n',
68     };
69
70     is( $term->ask_yn( %$args ), 0, q[Asking yes/no with 'no' as default] );
71 }
72
73
74 # used to print: Use of uninitialized value in length at Term/UI.pm line 141.
75 # [#13412]
76 {   my $args = {
77         prompt  => 'Uninit warning on empty default',
78     };
79     
80     my $warnings = '';
81     local $SIG{__WARN__} = sub { $warnings .= "@_" };
82     
83     my $res = $term->get_reply( %$args );
84
85     ok( !$res,                  "Empty result on autoreply without default" );
86     is( $warnings, '',          "   No warnings with empty default" );
87     unlike( $warnings, qr|Term.UI|,
88                                 "   No warnings from Term::UI" );
89
90 }
91  
92 # used to print: Use of uninitialized value in string at Params/Check.pm
93 # [#13412]
94 {   my $args = {
95         prompt  => 'Undef warning on failing allow',
96         allow   => sub { 0 },
97     };
98     
99     my $warnings = '';
100     local $SIG{__WARN__} = sub { $warnings .= "@_" };
101     
102     my $res = $term->get_reply( %$args );
103
104     ok( !$res,                  "Empty result on autoreply without default" );
105     is( $warnings, '',          "   No warnings with failing allow" );
106     unlike( $warnings, qr|Params.Check|,
107                                 "   No warnings from Params::Check" );
108
109 }
110
111 #### test parse_options   
112 {
113     my $str =   q[command --no-foo --baz --bar=0 --quux=bleh ] .
114                 q[--option="some'thing" -one-dash -single=blah' foo bar-zot];
115
116     my $munged = 'command foo bar-zot';
117     my $expected = {
118             foo         => 0,
119             baz         => 1,
120             bar         => 0,
121             quux        => 'bleh',
122             option      => q[some'thing],
123             'one-dash'  => 1,
124             single      => q[blah'],
125     };
126
127     my ($href,$rest) = $term->parse_options( $str );
128
129     is_deeply($href, $expected, qq[Parsing options] );
130     is($rest, $munged,          qq[Remaining unparsed string '$munged'] );
131 }
132
133 ### more parse_options tests
134 {   my @map = (
135         [ 'x --update_source'   => 'x', { update_source => 1 } ],
136         [ '--update_source'     => '',  { update_source => 1 } ],
137     );
138     
139     for my $aref ( @map ) {
140         my( $input, $munged, $expect ) = @$aref;
141         
142         my($href,$rest) = $term->parse_options( $input );
143         
144         ok( $href,              "Parsed '$input'" );
145         is_deeply( $href, $expect,
146                                 "   Options parsed correctly" );
147         is( $rest, $munged,     "   Command parsed correctly" );
148     }
149 }
150
151 } # End SKIP block