This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Close temporary test file before unlinking (for the sake of Win32)
[perl5.git] / lib / Term / UI / t / 02_ui.t
CommitLineData
4f08f5ad
JB
1### Term::UI test suite ###
2
3use strict;
4use lib qw[../lib lib];
5use Test::More tests => 13;
6use Term::ReadLine;
7
8use_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...
18if( $ENV{PERL_CORE} ) {
19 *STDOUT_SAVE = *STDOUT_SAVE = *STDOUT;
20 close *STDOUT;
21 open *STDOUT, ">termui.$$" or diag("Could not open tempfile");
22}
8f9c7671 23END { close *STDOUT && unlink "termui.$$" if $ENV{PERL_CORE} }
4f08f5ad
JB
24
25
26### so T::RL doesn't go nuts over no console
27BEGIN{ $ENV{LINES}=25; $ENV{COLUMNS}=80; }
28my $term = Term::ReadLine->new('test')
29 or diag "Could not create a new term. Dying", die;
30
31my $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];
110
111 my $munged = 'command foo';
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, q[Parsing options] );
125 is($rest,$munged, q[Remaining unparsed string] );
126}