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