lib/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 => 13;
   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 { 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];
 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 }