line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package IO::Prompt; |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
our $VERSION = '0.997004'; |
4
|
|
|
|
|
|
|
|
5
|
1
|
|
|
1
|
|
16735
|
use strict; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
28
|
|
6
|
1
|
|
|
1
|
|
3
|
use Carp; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
67
|
|
7
|
|
|
|
|
|
|
|
8
|
1
|
|
|
1
|
|
18
|
use 5.008; |
|
1
|
|
|
|
|
6
|
|
9
|
1
|
|
|
1
|
|
4
|
no warnings 'utf8'; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
56
|
|
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
our @EXPORT = qw( prompt ); |
12
|
|
|
|
|
|
|
our @EXPORT_OK = qw( hand_print get_input ); |
13
|
|
|
|
|
|
|
|
14
|
1
|
|
|
1
|
|
585
|
use IO::Handle; |
|
1
|
|
|
|
|
5668
|
|
|
1
|
|
|
|
|
45
|
|
15
|
1
|
|
|
1
|
|
546
|
use Term::ReadKey; |
|
1
|
|
|
|
|
1725
|
|
|
1
|
|
|
|
|
1444
|
|
16
|
|
|
|
|
|
|
|
17
|
0
|
|
|
0
|
|
0
|
sub _isprint { $_[0] =~ qr/ ^ [[:print:]]+ $ /x } |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
my $clearfirst; |
20
|
|
|
|
|
|
|
my %input; |
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
sub _clear { |
23
|
0
|
0
|
|
0
|
|
0
|
return unless $_[0]; |
24
|
0
|
0
|
|
|
|
0
|
open my $OUT, ">/dev/tty" or croak "Cannot write to terminal: $!"; |
25
|
0
|
|
|
|
|
0
|
print {$OUT} "\n" x 60; |
|
0
|
|
|
|
|
0
|
|
26
|
0
|
|
|
|
|
0
|
$clearfirst = 0; |
27
|
|
|
|
|
|
|
} |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
our %flags_arg = ( |
30
|
|
|
|
|
|
|
p => 'prompt', |
31
|
|
|
|
|
|
|
s => 'speed', |
32
|
|
|
|
|
|
|
e => 'echo', |
33
|
|
|
|
|
|
|
r => 'require', |
34
|
|
|
|
|
|
|
d => 'default', |
35
|
|
|
|
|
|
|
u => 'until', |
36
|
|
|
|
|
|
|
w => 'while', |
37
|
|
|
|
|
|
|
nl => 'newline', |
38
|
|
|
|
|
|
|
m => 'menu', |
39
|
|
|
|
|
|
|
); |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
our %flags_alias = ( |
42
|
|
|
|
|
|
|
'-okayif' => '-while', '-okay_if' => '-while', |
43
|
|
|
|
|
|
|
'-failif' => '-until', '-fail_if' => '-until', |
44
|
|
|
|
|
|
|
); |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
our %flags_noarg = ( |
47
|
|
|
|
|
|
|
y => 'yes', |
48
|
|
|
|
|
|
|
n => 'no', |
49
|
|
|
|
|
|
|
i => 'integer', |
50
|
|
|
|
|
|
|
num => 'number', |
51
|
|
|
|
|
|
|
raw => 'raw_input', |
52
|
|
|
|
|
|
|
1 => 'onechar', |
53
|
|
|
|
|
|
|
c => 'clear', |
54
|
|
|
|
|
|
|
f => 'clearfirst', |
55
|
|
|
|
|
|
|
a => 'argv', |
56
|
|
|
|
|
|
|
l => 'line', |
57
|
|
|
|
|
|
|
t => 'tty', |
58
|
|
|
|
|
|
|
x => 'escape', |
59
|
|
|
|
|
|
|
); |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
my $RECORD; # store filehandle for __PROMPT__ file supporting -record flag |
62
|
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
$flags_arg{$_} = $_ for values %flags_arg; |
64
|
|
|
|
|
|
|
$flags_noarg{$_} = $_ for values %flags_noarg; |
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
my $flag_with_arg = join '|', reverse sort keys %flags_arg; |
67
|
|
|
|
|
|
|
my $flag_no_arg = join '|', reverse sort keys %flags_noarg; |
68
|
|
|
|
|
|
|
|
69
|
|
|
|
|
|
|
my %yespat = ( |
70
|
|
|
|
|
|
|
'y' => qr/^\s*[yY]/, |
71
|
|
|
|
|
|
|
'Y' => qr/^\s*Y/, |
72
|
|
|
|
|
|
|
); |
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
my %nopat = ( |
75
|
|
|
|
|
|
|
'n' => qr/^\s*[nN]/, |
76
|
|
|
|
|
|
|
'N' => qr/^\s*N/, |
77
|
|
|
|
|
|
|
); |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
my %num_pat = ( |
80
|
|
|
|
|
|
|
integer => qr{[+-]? \d+ (?:[Ee]+?\d+ )?}x, |
81
|
|
|
|
|
|
|
number => qr{[+-]? (?:\d+[.]?\d* | [.]\d+) (?:[Ee][+-]?\d+)? }x, |
82
|
|
|
|
|
|
|
); |
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
sub _get_prompt (\%@) { |
85
|
0
|
|
|
0
|
|
0
|
my ($flags, @data) = @_; |
86
|
0
|
|
|
|
|
0
|
my ($OUT); |
87
|
0
|
0
|
0
|
|
|
0
|
@data = map { $flags_alias{$_} || defined($_) ? $_ : "" } @data; |
|
0
|
|
|
|
|
0
|
|
88
|
0
|
|
|
|
|
0
|
for (my $i = 0 ; $i < @data ; $i++) { |
89
|
0
|
|
|
|
|
0
|
local *_ = \$data[$i]; |
90
|
0
|
0
|
0
|
|
|
0
|
if (ref eq 'HASH') { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
91
|
0
|
|
|
|
|
0
|
splice @data, $i + 1, 0, %$_; |
92
|
|
|
|
|
|
|
} |
93
|
|
|
|
|
|
|
elsif (ref eq 'GLOB' or UNIVERSAL::isa($_, 'IO::Handle')) { |
94
|
0
|
0
|
|
|
|
0
|
croak "Can't write prompt to read-only $_" unless -w; |
95
|
0
|
|
|
|
|
0
|
$OUT = $_; |
96
|
|
|
|
|
|
|
} |
97
|
|
|
|
|
|
|
elsif (/^-/) { # a flag |
98
|
0
|
|
|
|
|
0
|
s/_//g; |
99
|
0
|
0
|
|
|
|
0
|
if (s/^-(f|clearfirst)/-/) { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
100
|
0
|
0
|
|
|
|
0
|
$clearfirst = 1 unless defined $clearfirst; |
101
|
|
|
|
|
|
|
} |
102
|
|
|
|
|
|
|
elsif (s/^-(yes|y)/-/i) { |
103
|
0
|
|
|
|
|
0
|
$flags->{-yesno}{yes} = $yespat{ substr $1, 0, 1 }; |
104
|
0
|
|
|
|
|
0
|
$flags->{-yesno}{yesprompt} = substr $1, 0, 1; |
105
|
|
|
|
|
|
|
} |
106
|
|
|
|
|
|
|
elsif (s/^-(?:nl|newline)/-/i) { |
107
|
0
|
|
|
|
|
0
|
$flags->{-nlstr} = $data[ $i + 1 ]; |
108
|
0
|
|
|
|
|
0
|
undef $data[ $i++ ]; |
109
|
|
|
|
|
|
|
} |
110
|
|
|
|
|
|
|
elsif (s/^-escape|-x/-/i) { |
111
|
0
|
|
|
|
|
0
|
$flags->{-escape} = 1; |
112
|
|
|
|
|
|
|
} |
113
|
|
|
|
|
|
|
elsif (s/^-raw_?(?:input)?/-/i) { |
114
|
0
|
|
|
|
|
0
|
$flags->{-raw_input} = 1; |
115
|
|
|
|
|
|
|
} |
116
|
|
|
|
|
|
|
elsif (s/^-number|-num/-/i) { |
117
|
0
|
|
|
|
|
0
|
$flags->{-number} = 'number'; |
118
|
|
|
|
|
|
|
} |
119
|
|
|
|
|
|
|
elsif (s/^-integer|-i/-/i) { |
120
|
0
|
|
|
|
|
0
|
$flags->{-number} = 'integer'; |
121
|
|
|
|
|
|
|
} |
122
|
|
|
|
|
|
|
elsif (s/^-(no|n)/-/i) { |
123
|
0
|
|
|
|
|
0
|
$flags->{-yesno}{no} = $nopat{ substr $1, 0, 1 }; |
124
|
0
|
|
|
|
|
0
|
$flags->{-yesno}{noprompt} = substr $1, 0, 1; |
125
|
|
|
|
|
|
|
} |
126
|
|
|
|
|
|
|
elsif (m/^-($flag_with_arg)/) { |
127
|
0
|
0
|
0
|
|
|
0
|
croak "Missing argument for $_ option" if @data < $i+2 |
128
|
|
|
|
|
|
|
|| !defined $data[$i+1]; |
129
|
0
|
|
|
|
|
0
|
s/^-($flag_with_arg)/-/; |
130
|
0
|
|
|
|
|
0
|
$flags->{ -$flags_arg{$1} } = $data[$i+1]; |
131
|
0
|
|
|
|
|
0
|
undef $data[$i++]; |
132
|
|
|
|
|
|
|
} |
133
|
|
|
|
|
|
|
elsif (s/^-($flag_no_arg)/-/) { |
134
|
0
|
|
|
|
|
0
|
$flags->{ -$flags_noarg{$1} } = 1; |
135
|
|
|
|
|
|
|
} |
136
|
0
|
|
|
|
|
0
|
else { croak "Unknown flag ($_) in prompt" } |
137
|
|
|
|
|
|
|
|
138
|
0
|
0
|
0
|
|
|
0
|
redo if defined $_ && /^-./; |
139
|
|
|
|
|
|
|
} |
140
|
0
|
|
|
|
|
0
|
else { next } |
141
|
0
|
|
|
|
|
0
|
undef $data[$i]; |
142
|
|
|
|
|
|
|
} |
143
|
|
|
|
|
|
|
$_ = |
144
|
|
|
|
|
|
|
!defined() ? undef |
145
|
|
|
|
|
|
|
: ref eq 'Regexp' ? $_ |
146
|
|
|
|
|
|
|
: qr/^\Q$_\E$/ |
147
|
0
|
0
|
|
|
|
0
|
for @{$flags}{qw(-while -until -failif -okayif)}; |
|
0
|
0
|
|
|
|
0
|
|
148
|
|
|
|
|
|
|
|
149
|
0
|
|
|
|
|
0
|
for (grep { defined } $flags->{ -require }) { |
|
0
|
|
|
|
|
0
|
|
150
|
0
|
0
|
|
|
|
0
|
croak "Argument to -require must be hash reference" |
151
|
|
|
|
|
|
|
unless ref eq 'HASH'; |
152
|
0
|
|
|
|
|
0
|
my %reqs = %$_; |
153
|
|
|
|
|
|
|
$_ = sub { |
154
|
0
|
|
|
0
|
|
0
|
my ($input) = @_; |
155
|
0
|
|
|
|
|
0
|
for (keys %reqs) { |
156
|
0
|
0
|
|
|
|
0
|
return $_ unless _smartmatch($input, $reqs{$_}); |
157
|
|
|
|
|
|
|
} |
158
|
0
|
|
|
|
|
0
|
return; |
159
|
0
|
|
|
|
|
0
|
}; |
160
|
|
|
|
|
|
|
} |
161
|
0
|
|
|
|
|
0
|
my @prompt = grep { defined } @data; |
|
0
|
|
|
|
|
0
|
|
162
|
0
|
0
|
0
|
|
|
0
|
if (@prompt && exists $flags->{-default}) { |
163
|
0
|
|
|
|
|
0
|
my $prompt = join "", @prompt; |
164
|
0
|
0
|
|
|
|
0
|
$prompt =~ s/(:?\s*)$/ [$flags->{-default}]$1/ if $prompt !~ /\[.*\]/; |
165
|
0
|
|
|
|
|
0
|
@prompt = $prompt; |
166
|
|
|
|
|
|
|
} |
167
|
0
|
|
|
|
|
0
|
return $OUT, @prompt; |
168
|
|
|
|
|
|
|
} |
169
|
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
my $prompt_req = "(The value entered is not acceptable) "; |
171
|
|
|
|
|
|
|
|
172
|
|
|
|
|
|
|
sub prompt { |
173
|
0
|
|
|
0
|
1
|
0
|
my $caller = caller; |
174
|
|
|
|
|
|
|
|
175
|
0
|
|
|
|
|
0
|
local $\ = q{}; # Make sure no funny business on print statements |
176
|
|
|
|
|
|
|
|
177
|
0
|
|
|
|
|
0
|
my %flags; |
178
|
0
|
|
|
|
|
0
|
my ($OUT, @prompt) = _get_prompt(%flags, @_); |
179
|
0
|
0
|
0
|
|
|
0
|
open $OUT, ">/dev/tty" or croak "Cannot write to terminal: $!" if !$OUT; |
180
|
0
|
|
|
|
|
0
|
$OUT->autoflush(1); |
181
|
0
|
0
|
0
|
|
|
0
|
@prompt = $flags{ -prompt } if !@prompt and $flags{ -prompt }; |
182
|
0
|
|
|
|
|
0
|
my $IN; |
183
|
0
|
0
|
0
|
|
|
0
|
if ($flags{-tty} || $flags{-argv}) { |
184
|
0
|
0
|
|
|
|
0
|
open $IN, "
|
185
|
|
|
|
|
|
|
} |
186
|
|
|
|
|
|
|
else { |
187
|
1
|
|
|
1
|
|
6
|
use Scalar::Util; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
59
|
|
188
|
1
|
|
|
1
|
|
5
|
no strict 'refs'; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
106
|
|
189
|
0
|
|
|
|
|
0
|
my $ARGV = $caller . "::ARGV"; |
190
|
0
|
0
|
|
|
|
0
|
unless (Scalar::Util::openhandle(*$ARGV)) { |
191
|
0
|
|
0
|
|
|
0
|
$$ARGV = shift(@$ARGV) || '-'; |
192
|
0
|
0
|
|
|
|
0
|
open $ARGV or croak "Can't open $$ARGV: $!"; |
193
|
|
|
|
|
|
|
} |
194
|
0
|
|
|
|
|
0
|
$IN = \*$ARGV; |
195
|
0
|
0
|
|
|
|
0
|
@prompt = () unless -t $IN; |
196
|
|
|
|
|
|
|
} |
197
|
0
|
0
|
|
|
|
0
|
$flags{-speed} = 0.075 unless defined $flags{-speed}; |
198
|
1
|
|
|
1
|
|
571
|
use Want qw( want ); |
|
1
|
|
|
|
|
1527
|
|
|
1
|
|
|
|
|
576
|
|
199
|
0
|
|
0
|
|
|
0
|
$flags{-set_underscore} ||= want('BOOL'); |
200
|
|
|
|
|
|
|
|
201
|
0
|
0
|
0
|
|
|
0
|
$clearfirst = 1 if !defined($clearfirst) && $flags{-clearfirst}; |
202
|
0
|
|
0
|
|
|
0
|
_clear($flags{ -clear } || $clearfirst); |
203
|
0
|
|
|
|
|
0
|
my $input; |
204
|
0
|
0
|
0
|
|
|
0
|
if (-t $IN and defined $input{$caller}) { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
205
|
0
|
|
|
|
|
0
|
$input = _fake_from_DATA($caller, $IN, $OUT, \%flags, @prompt); |
206
|
|
|
|
|
|
|
} |
207
|
|
|
|
|
|
|
elsif ($flags{-argv}) { |
208
|
0
|
0
|
|
|
|
0
|
return if @ARGV; |
209
|
0
|
0
|
0
|
|
|
0
|
@prompt = "Args for $0: " if -t $IN and !@prompt; |
210
|
0
|
|
|
|
|
0
|
print {$OUT} @prompt; |
|
0
|
|
|
|
|
0
|
|
211
|
0
|
|
|
|
|
0
|
@ARGV = map glob, split /\s+/, get_input($IN, $OUT, \%flags, @prompt); |
212
|
0
|
|
|
|
|
0
|
return @ARGV; |
213
|
|
|
|
|
|
|
} |
214
|
|
|
|
|
|
|
elsif ($flags{-yesno}) { |
215
|
0
|
|
|
|
|
0
|
return _yesno($IN, $OUT, \%flags, @prompt); |
216
|
|
|
|
|
|
|
} |
217
|
|
|
|
|
|
|
elsif ($flags{-number}) { |
218
|
0
|
|
|
|
|
0
|
return _number($IN, $OUT, \%flags, @prompt); |
219
|
|
|
|
|
|
|
} |
220
|
|
|
|
|
|
|
elsif ($flags{-menu}) { |
221
|
0
|
|
|
|
|
0
|
return _menu($IN, $OUT, \%flags, @prompt); |
222
|
|
|
|
|
|
|
} |
223
|
|
|
|
|
|
|
else { |
224
|
0
|
|
|
|
|
0
|
print {$OUT} @prompt; |
|
0
|
|
|
|
|
0
|
|
225
|
0
|
|
|
|
|
0
|
$input = get_input($IN, $OUT, \%flags, @prompt); |
226
|
|
|
|
|
|
|
} |
227
|
0
|
|
|
|
|
0
|
return _tidy($input, %flags); |
228
|
|
|
|
|
|
|
} |
229
|
|
|
|
|
|
|
|
230
|
|
|
|
|
|
|
sub _tidy { |
231
|
0
|
|
|
0
|
|
0
|
my ($input, %flags) = @_; |
232
|
0
|
|
|
|
|
0
|
my $defined = defined $input; |
233
|
0
|
0
|
0
|
|
|
0
|
chomp $input if $defined && !$flags{-line}; |
234
|
|
|
|
|
|
|
my $success = $defined |
235
|
|
|
|
|
|
|
&& (!$flags{ -while } || $input =~ $flags{ -while }) |
236
|
0
|
|
0
|
|
|
0
|
&& (!$flags{ -until } || $input !~ $flags{ -until }); |
237
|
0
|
0
|
0
|
|
|
0
|
print {$RECORD} $input, "\n" if $success && $RECORD; |
|
0
|
|
|
|
|
0
|
|
238
|
0
|
0
|
|
|
|
0
|
return "$input" if $flags{-raw_input}; |
239
|
|
|
|
|
|
|
return bless { |
240
|
|
|
|
|
|
|
value => $input, |
241
|
|
|
|
|
|
|
success => $success, |
242
|
|
|
|
|
|
|
set_val => $flags{ -set_underscore }, |
243
|
|
|
|
|
|
|
}, |
244
|
0
|
|
|
|
|
0
|
'IO::Prompt::ReturnVal'; |
245
|
|
|
|
|
|
|
} |
246
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
sub _success { |
248
|
0
|
|
|
0
|
|
0
|
my ($val, $no_set, $raw) = @_; |
249
|
0
|
0
|
0
|
|
|
0
|
print {$RECORD} $val, "\n" if $val && $RECORD; |
|
0
|
|
|
|
|
0
|
|
250
|
0
|
0
|
|
|
|
0
|
return "$val" if $raw; |
251
|
0
|
|
|
|
|
0
|
return bless { |
252
|
|
|
|
|
|
|
value => $val, |
253
|
|
|
|
|
|
|
success => 1, |
254
|
|
|
|
|
|
|
set_val => !$no_set, |
255
|
|
|
|
|
|
|
}, |
256
|
|
|
|
|
|
|
'IO::Prompt::ReturnVal'; |
257
|
|
|
|
|
|
|
} |
258
|
|
|
|
|
|
|
|
259
|
|
|
|
|
|
|
sub _failure { |
260
|
0
|
|
|
0
|
|
0
|
my ($val, $raw) = @_; |
261
|
0
|
0
|
|
|
|
0
|
return "$val" if $raw; |
262
|
0
|
|
|
|
|
0
|
return bless { |
263
|
|
|
|
|
|
|
value => $val, |
264
|
|
|
|
|
|
|
success => 0, |
265
|
|
|
|
|
|
|
set_val => 0, |
266
|
|
|
|
|
|
|
}, |
267
|
|
|
|
|
|
|
'IO::Prompt::ReturnVal'; |
268
|
|
|
|
|
|
|
} |
269
|
|
|
|
|
|
|
|
270
|
|
|
|
|
|
|
sub import { |
271
|
1
|
|
|
1
|
|
10
|
my $class = shift; |
272
|
|
|
|
|
|
|
|
273
|
|
|
|
|
|
|
{ |
274
|
1
|
|
|
1
|
|
6
|
no strict 'refs'; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
306
|
|
|
1
|
|
|
|
|
1
|
|
275
|
1
|
|
|
|
|
2
|
*{ caller() . "::$_" } = \&{$_} for @EXPORT; |
|
1
|
|
|
|
|
5
|
|
|
1
|
|
|
|
|
3
|
|
276
|
|
|
|
|
|
|
|
277
|
1
|
|
|
|
|
2
|
foreach my $sym (@_) { |
278
|
0
|
0
|
|
|
|
0
|
grep { $_ eq $sym } @EXPORT_OK or next; |
|
0
|
|
|
|
|
0
|
|
279
|
0
|
|
|
|
|
0
|
*{ caller() . "::$sym" } = \&{$sym}; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
280
|
|
|
|
|
|
|
} |
281
|
|
|
|
|
|
|
} |
282
|
|
|
|
|
|
|
|
283
|
1
|
|
|
|
|
2
|
@_ = grep /^-/, @_; |
284
|
1
|
|
|
|
|
2
|
$input{ caller() } = undef; |
285
|
1
|
50
|
|
|
|
5
|
if ("@_" eq "-clearfirst") { |
286
|
0
|
|
|
|
|
0
|
$clearfirst = 1; |
287
|
0
|
|
|
|
|
0
|
return; |
288
|
|
|
|
|
|
|
} |
289
|
1
|
|
|
|
|
3
|
for my $i (0 .. $#_) { |
290
|
0
|
0
|
|
|
|
0
|
last if $RECORD; |
291
|
0
|
0
|
|
|
|
0
|
if ($_[$i] eq '-record') { |
292
|
0
|
|
|
|
|
0
|
splice @_, $i, 1; |
293
|
0
|
0
|
|
|
|
0
|
open $RECORD, '>', '__PROMPT__' |
294
|
|
|
|
|
|
|
or croak "Can't open __PROMPT__ recording file: $!"; |
295
|
0
|
|
|
|
|
0
|
print {$RECORD} "__DATA__\n__PROMPT__\n"; |
|
0
|
|
|
|
|
0
|
|
296
|
|
|
|
|
|
|
} |
297
|
|
|
|
|
|
|
} |
298
|
1
|
50
|
|
|
|
14
|
prompt @_ if @_; |
299
|
|
|
|
|
|
|
} |
300
|
|
|
|
|
|
|
|
301
|
|
|
|
|
|
|
CHECK { |
302
|
1
|
|
|
1
|
|
918
|
for my $pkg (keys %input) { |
303
|
1
|
50
|
|
|
|
4
|
next if defined $input{$pkg}; |
304
|
|
|
|
|
|
|
|
305
|
1
|
|
|
1
|
|
5
|
no strict 'refs'; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
2717
|
|
306
|
1
|
50
|
|
|
|
2
|
if (my $datahandle = *{"${pkg}::DATA"}{IO}) { |
|
1
|
|
|
|
|
8
|
|
307
|
0
|
|
|
|
|
0
|
local $/; |
308
|
0
|
|
|
|
|
0
|
my $data = <$datahandle>; |
309
|
0
|
0
|
|
|
|
0
|
if ($data =~ s/(\A|\n) __PROMPT__ \s*? \n (.*)/$1/xs) { |
310
|
0
|
|
|
|
|
0
|
$input{$pkg} = "$2"; |
311
|
|
|
|
|
|
|
} |
312
|
|
|
|
|
|
|
else { |
313
|
0
|
|
|
|
|
0
|
delete $input{$pkg}; |
314
|
|
|
|
|
|
|
} |
315
|
0
|
0
|
|
|
|
0
|
open "${pkg}::DATA", "<", \$data or die "Internal error: $!"; |
316
|
|
|
|
|
|
|
} |
317
|
|
|
|
|
|
|
else { |
318
|
1
|
|
|
|
|
701
|
delete $input{$pkg}; |
319
|
|
|
|
|
|
|
} |
320
|
|
|
|
|
|
|
} |
321
|
|
|
|
|
|
|
} |
322
|
|
|
|
|
|
|
|
323
|
|
|
|
|
|
|
my $baseline = ord 'A'; |
324
|
|
|
|
|
|
|
|
325
|
|
|
|
|
|
|
sub _visualize { |
326
|
0
|
|
|
0
|
|
|
local ($_) = @_; |
327
|
0
|
0
|
|
|
|
|
return _isprint($_) ? $_ |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
328
|
|
|
|
|
|
|
: $_ eq "\n" ? $_ |
329
|
|
|
|
|
|
|
: ord($_) == 0 ? '' |
330
|
|
|
|
|
|
|
: ord($_) < $baseline ? '^' . chr($baseline + ord($_) - 1) |
331
|
|
|
|
|
|
|
: '?' |
332
|
|
|
|
|
|
|
} |
333
|
|
|
|
|
|
|
|
334
|
|
|
|
|
|
|
sub hand_print { |
335
|
0
|
|
|
0
|
1
|
|
my $OUT = \*STDOUT; |
336
|
0
|
|
|
|
|
|
my $echo = undef; |
337
|
0
|
|
|
|
|
|
my $speed = 0.05; |
338
|
0
|
|
|
|
|
|
local $| = 1; |
339
|
0
|
|
|
|
|
|
for (@_) { |
340
|
0
|
0
|
|
|
|
|
if (ref eq 'HASH') { |
|
|
0
|
|
|
|
|
|
341
|
0
|
0
|
|
|
|
|
$speed = $_->{-speed} if exists $_->{-speed}; |
342
|
0
|
0
|
|
|
|
|
$OUT = $_->{-to} if exists $_->{-to}; |
343
|
0
|
0
|
|
|
|
|
$echo = $_->{-echo} if exists $_->{-echo}; |
344
|
|
|
|
|
|
|
} |
345
|
|
|
|
|
|
|
elsif (!$speed) { |
346
|
0
|
|
|
|
|
|
print {$OUT} $_; |
|
0
|
|
|
|
|
|
|
347
|
|
|
|
|
|
|
} |
348
|
|
|
|
|
|
|
else { |
349
|
0
|
|
|
|
|
|
print {$OUT} $_ and select undef, undef, undef, rand $speed |
350
|
0
|
0
|
0
|
|
|
|
for map { defined $echo ? $echo : _visualize($_) } split ""; |
|
0
|
|
|
|
|
|
|
351
|
|
|
|
|
|
|
} |
352
|
|
|
|
|
|
|
} |
353
|
0
|
|
|
|
|
|
return scalar @_; |
354
|
|
|
|
|
|
|
} |
355
|
|
|
|
|
|
|
|
356
|
|
|
|
|
|
|
sub _fake_from_DATA { |
357
|
0
|
|
|
0
|
|
|
my ($caller, $IN, $OUT, $flags, @prompt) = @_; |
358
|
0
|
|
|
0
|
|
|
local $SIG{INT} = sub { ReadMode 'restore', $IN; exit }; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
359
|
0
|
|
|
|
|
|
ReadMode 'noecho', $IN; |
360
|
0
|
|
|
|
|
|
ReadMode 'raw', $IN; |
361
|
0
|
|
|
|
|
|
print {$OUT} @prompt; |
|
0
|
|
|
|
|
|
|
362
|
0
|
|
|
|
|
|
my $input = getc $IN; |
363
|
0
|
0
|
|
|
|
|
if ($input =~ /\cD|\cZ/) { print {$OUT} _visualize($input),"\n"; return; } |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
364
|
0
|
0
|
|
|
|
|
if ($input eq "\e") { |
365
|
0
|
|
|
|
|
|
ReadMode 'restore', $IN; |
366
|
0
|
|
|
|
|
|
return get_input($IN, $OUT, $flags, @prompt); |
367
|
|
|
|
|
|
|
} |
368
|
0
|
|
|
|
|
|
$input{$caller} =~ m/\G (?!\cD|\cZ) (.*) (\n?)/xgc; |
369
|
0
|
|
|
|
|
|
my ($line, $nlstr) = ($1, $2); |
370
|
0
|
0
|
|
|
|
|
unless (defined $line) { |
371
|
0
|
|
|
|
|
|
while ($input ne "\n") { $input = getc $IN } |
|
0
|
|
|
|
|
|
|
372
|
0
|
|
|
|
|
|
print {$OUT} "\n"; |
|
0
|
|
|
|
|
|
|
373
|
0
|
|
|
|
|
|
return; |
374
|
|
|
|
|
|
|
} |
375
|
0
|
0
|
|
|
|
|
delete $input{$caller} if pos $input{$caller} == length $input{$caller}; |
376
|
0
|
0
|
|
|
|
|
if ($input eq "\n") { |
377
|
0
|
|
|
|
|
|
hand_print { -to => $OUT, %$flags }, $line; |
378
|
0
|
0
|
|
|
|
|
unless (defined <$IN>) { print {$OUT} "\n"; return; } |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
379
|
|
|
|
|
|
|
} |
380
|
|
|
|
|
|
|
else { |
381
|
0
|
|
|
|
|
|
my $i = 0; |
382
|
0
|
|
|
|
|
|
while (1) { |
383
|
0
|
|
|
|
|
|
my $done = $i >= length $line; |
384
|
0
|
0
|
|
|
|
|
print {$OUT} substr($line, $i++, 1) unless $done; |
|
0
|
|
|
|
|
|
|
385
|
0
|
0
|
|
|
|
|
if (getc $IN eq "\n") { |
386
|
0
|
0
|
|
|
|
|
last if $done; |
387
|
0
|
|
|
|
|
|
hand_print { -to => $OUT, %$flags }, substr($line, $i); |
388
|
0
|
|
|
|
|
|
$i = length $line; |
389
|
|
|
|
|
|
|
} |
390
|
|
|
|
|
|
|
} |
391
|
|
|
|
|
|
|
} |
392
|
0
|
|
|
|
|
|
ReadMode 'restore', $IN; |
393
|
0
|
|
|
|
|
|
print {$OUT} "\n"; |
|
0
|
|
|
|
|
|
|
394
|
0
|
|
|
|
|
|
return $line . $nlstr; |
395
|
|
|
|
|
|
|
} |
396
|
|
|
|
|
|
|
|
397
|
|
|
|
|
|
|
sub get_input { |
398
|
0
|
|
|
0
|
1
|
|
my ($IN, $OUT, $flags, @prompt) = @_; |
399
|
|
|
|
|
|
|
my ($onechar, $nlstr, $echo, $require) = |
400
|
0
|
|
|
|
|
|
@{$flags}{ -onechar, -nlstr, -echo, -'require' }; |
|
0
|
|
|
|
|
|
|
401
|
0
|
0
|
|
|
|
|
$nlstr = "\n" unless defined $nlstr; |
402
|
0
|
0
|
|
|
|
|
if (!-t $IN) { |
403
|
0
|
0
|
|
|
|
|
return scalar <$IN> unless $onechar; |
404
|
0
|
|
|
|
|
|
return getc $IN; |
405
|
|
|
|
|
|
|
} |
406
|
0
|
|
|
|
|
|
$OUT->autoflush(1); |
407
|
0
|
|
|
0
|
|
|
local $SIG{INT} = sub { ReadMode 'restore', $IN; exit }; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
408
|
0
|
|
|
|
|
|
my ($input, $newlines); |
409
|
0
|
|
|
|
|
|
my %cntl = GetControlChars $IN; |
410
|
0
|
|
|
|
|
|
my $cntl = join '|', values %cntl; |
411
|
0
|
|
|
|
|
|
ReadMode 'raw', $IN; |
412
|
|
|
|
|
|
|
|
413
|
0
|
|
|
|
|
|
INPUT: while (1) { |
414
|
0
|
|
|
|
|
|
my $next = getc $IN; |
415
|
0
|
0
|
0
|
|
|
|
if ($next eq $cntl{INTERRUPT}) { |
|
|
0
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
416
|
0
|
|
|
|
|
|
ReadMode 'restore', $IN; |
417
|
0
|
|
|
|
|
|
exit; |
418
|
|
|
|
|
|
|
} |
419
|
|
|
|
|
|
|
elsif ($next eq $cntl{ERASE}) { |
420
|
0
|
0
|
0
|
|
|
|
if (defined $input && length $input) { |
421
|
0
|
|
|
|
|
|
substr($input, -1) = ""; |
422
|
0
|
|
|
|
|
|
print {$OUT} "\b \b"; |
|
0
|
|
|
|
|
|
|
423
|
|
|
|
|
|
|
} |
424
|
0
|
|
|
|
|
|
next; |
425
|
|
|
|
|
|
|
} |
426
|
|
|
|
|
|
|
elsif ($next eq $cntl{EOF}) { |
427
|
0
|
|
|
|
|
|
ReadMode 'restore', $IN; |
428
|
0
|
|
|
|
|
|
close $IN; |
429
|
0
|
|
|
|
|
|
return $input; |
430
|
|
|
|
|
|
|
} |
431
|
|
|
|
|
|
|
elsif ($flags->{-escape} && $next eq "\e") { |
432
|
0
|
|
|
|
|
|
ReadMode 'restore', $IN; |
433
|
0
|
|
|
|
|
|
print {$OUT} ""; |
|
0
|
|
|
|
|
|
|
434
|
0
|
|
|
|
|
|
return "\e"; |
435
|
|
|
|
|
|
|
} |
436
|
|
|
|
|
|
|
elsif ($next !~ /$cntl/ && defined $next) { |
437
|
0
|
|
|
|
|
|
$input .= $next; |
438
|
0
|
0
|
|
|
|
|
if ($next eq "\n") { |
439
|
0
|
0
|
0
|
|
|
|
if ($input eq "\n" && exists $flags->{-default}) { |
440
|
0
|
|
|
|
|
|
print {$OUT} ( |
441
|
|
|
|
|
|
|
defined $echo |
442
|
|
|
|
|
|
|
&& $flags->{-menu} ? $echo |
443
|
|
|
|
|
|
|
: defined $echo ? $echo x length($flags->{-default}) |
444
|
0
|
0
|
0
|
|
|
|
: '['.$flags->{-default}.']' |
|
|
0
|
|
|
|
|
|
445
|
|
|
|
|
|
|
); |
446
|
0
|
|
|
|
|
|
print {$OUT} $nlstr; |
|
0
|
|
|
|
|
|
|
447
|
0
|
|
|
|
|
|
ReadMode 'restore', $IN; |
448
|
|
|
|
|
|
|
return $onechar ? substr($_, 0, 1) : $_ |
449
|
0
|
0
|
|
|
|
|
for $flags->{-default}; |
450
|
|
|
|
|
|
|
} |
451
|
0
|
|
|
|
|
|
$newlines .= $nlstr; |
452
|
|
|
|
|
|
|
} |
453
|
|
|
|
|
|
|
else { |
454
|
0
|
0
|
|
|
|
|
print {$OUT}(defined $echo ? $echo : $next); |
|
0
|
|
|
|
|
|
|
455
|
|
|
|
|
|
|
} |
456
|
|
|
|
|
|
|
} |
457
|
|
|
|
|
|
|
else { |
458
|
0
|
|
|
|
|
|
$input .= $next; |
459
|
|
|
|
|
|
|
} |
460
|
0
|
0
|
0
|
|
|
|
if ($onechar or !defined $next or $input =~ m{\Q$/\E$}) { |
|
|
|
0
|
|
|
|
|
461
|
0
|
0
|
|
|
|
|
chomp $input unless $flags->{-line}; |
462
|
0
|
0
|
0
|
|
|
|
if ($require and my $mesg = $require->($input)) { |
463
|
0
|
|
|
|
|
|
print {$OUT} "\r", " " x 79, "\r", sprintf($mesg, @prompt); |
|
0
|
|
|
|
|
|
|
464
|
0
|
|
|
|
|
|
undef $input; |
465
|
0
|
|
|
|
|
|
undef $newlines; |
466
|
|
|
|
|
|
|
} |
467
|
|
|
|
|
|
|
else { |
468
|
0
|
|
|
|
|
|
ReadMode 'restore', $IN; |
469
|
0
|
0
|
|
|
|
|
print {$OUT} $newlines if defined $newlines; |
|
0
|
|
|
|
|
|
|
470
|
0
|
0
|
|
|
|
|
return $onechar ? substr($input, 0, 1) : $input; |
471
|
|
|
|
|
|
|
} |
472
|
|
|
|
|
|
|
} |
473
|
|
|
|
|
|
|
} |
474
|
|
|
|
|
|
|
} |
475
|
|
|
|
|
|
|
|
476
|
|
|
|
|
|
|
sub _yesno { |
477
|
0
|
|
|
0
|
|
|
my ($IN, $OUT, $flags, @prompt) = @_; |
478
|
|
|
|
|
|
|
my ($yes, $no, $yesprompt, $noprompt) = |
479
|
0
|
|
|
|
|
|
@{ $flags->{ -yesno } }{qw(yes no yesprompt noprompt)}; |
|
0
|
|
|
|
|
|
|
480
|
0
|
0
|
|
|
|
|
$yes = qr/^([^Nn])/ unless defined $yes; |
481
|
0
|
0
|
|
|
|
|
$no = qr/^([^Yy])/ unless defined $no; |
482
|
0
|
0
|
0
|
|
|
|
my $prompt2 = |
|
|
0
|
|
|
|
|
|
483
|
|
|
|
|
|
|
$yesprompt && $noprompt ? "'$yesprompt' or '$noprompt'" |
484
|
|
|
|
|
|
|
: $yesprompt ? "'$yesprompt' for yes" |
485
|
|
|
|
|
|
|
: "'$noprompt' for no"; |
486
|
0
|
|
|
|
|
|
my $raw = $flags->{-raw_input}; |
487
|
0
|
0
|
|
|
|
|
print {$OUT} @prompt if -t $IN; |
|
0
|
|
|
|
|
|
|
488
|
0
|
|
|
|
|
|
while (1) { |
489
|
0
|
|
|
|
|
|
my $response = |
490
|
|
|
|
|
|
|
get_input($IN, $OUT, { %$flags, -nlstr => "" }, @prompt); |
491
|
0
|
0
|
|
|
|
|
chomp $response unless $flags->{-line}; |
492
|
0
|
0
|
0
|
|
|
|
print {$OUT} "\n" and return _success($response, 'no_set', $raw) |
|
0
|
|
0
|
|
|
|
|
493
|
|
|
|
|
|
|
if defined $response and $response =~ /$yes/; |
494
|
0
|
0
|
0
|
|
|
|
print {$OUT} "\n" and return _failure($response, $raw) |
|
0
|
|
0
|
|
|
|
|
495
|
|
|
|
|
|
|
if !defined $response or $response =~ /$no/; |
496
|
0
|
0
|
|
|
|
|
print {$OUT} "\r", " " x 79, "\r", @prompt, |
|
0
|
|
|
|
|
|
|
497
|
|
|
|
|
|
|
"(Please answer $prompt2) " |
498
|
|
|
|
|
|
|
if -t $IN; |
499
|
|
|
|
|
|
|
} |
500
|
|
|
|
|
|
|
} |
501
|
|
|
|
|
|
|
|
502
|
|
|
|
|
|
|
sub _number { |
503
|
0
|
|
|
0
|
|
|
my ($IN, $OUT, $flags, @prompt) = @_; |
504
|
0
|
|
|
|
|
|
my $numtype = $flags->{ -number }; |
505
|
0
|
|
|
|
|
|
my $prompt_num = "(Please enter a valid $numtype) "; |
506
|
0
|
|
|
|
|
|
my $match = $num_pat{$numtype}; |
507
|
0
|
|
|
|
|
|
my $require = $flags->{ -require }; |
508
|
0
|
0
|
|
|
|
|
print {$OUT} @prompt if -t $IN; |
|
0
|
|
|
|
|
|
|
509
|
0
|
|
|
|
|
|
while (1) { |
510
|
0
|
|
|
|
|
|
my $response = |
511
|
|
|
|
|
|
|
get_input($IN, $OUT, { %$flags, -nlstr => "", -require => undef }, |
512
|
|
|
|
|
|
|
@prompt); |
513
|
0
|
0
|
0
|
|
|
|
chomp $response if defined $response && !$flags->{-line}; |
514
|
0
|
0
|
0
|
|
|
|
if (-t $IN and defined $response) { |
515
|
0
|
0
|
0
|
|
|
|
if ($response !~ /\A \s* $match \s* \Z/x) { |
|
|
0
|
|
|
|
|
|
516
|
0
|
|
|
|
|
|
print {$OUT} "\r", " " x 79, "\r", @prompt, $prompt_num; |
|
0
|
|
|
|
|
|
|
517
|
0
|
|
|
|
|
|
next; |
518
|
|
|
|
|
|
|
} |
519
|
|
|
|
|
|
|
elsif ($require and my $mesg = $require->($response)) { |
520
|
0
|
|
|
|
|
|
print {$OUT} "\r", " " x 79, "\r", sprintf($mesg, @prompt); |
|
0
|
|
|
|
|
|
|
521
|
0
|
|
|
|
|
|
next; |
522
|
|
|
|
|
|
|
} |
523
|
|
|
|
|
|
|
} |
524
|
0
|
0
|
|
|
|
|
print {$OUT} "\n" and return _tidy($response); |
|
0
|
|
|
|
|
|
|
525
|
|
|
|
|
|
|
} |
526
|
|
|
|
|
|
|
} |
527
|
|
|
|
|
|
|
|
528
|
0
|
|
|
0
|
|
|
sub _self { $_[0] } |
529
|
|
|
|
|
|
|
|
530
|
|
|
|
|
|
|
sub _menu { |
531
|
0
|
|
|
0
|
|
|
my ($IN, $OUT, $flags, @prompt) = @_; |
532
|
0
|
|
|
|
|
|
my $datatype = ref $flags->{ -menu }; |
533
|
0
|
|
|
|
|
|
my @data = $datatype eq 'ARRAY' ? @{ $flags->{ -menu } } |
534
|
0
|
0
|
|
|
|
|
: $datatype eq 'HASH' ? sort keys %{ $flags->{ -menu } } |
|
0
|
0
|
|
|
|
|
|
535
|
|
|
|
|
|
|
: croak "Argument to -menu must be hash or array reference"; |
536
|
|
|
|
|
|
|
|
537
|
|
|
|
|
|
|
my $val_for = $datatype eq 'ARRAY' |
538
|
|
|
|
|
|
|
? \&_self |
539
|
0
|
0
|
|
0
|
|
|
: sub { $flags->{ -menu }{$_[0]} }; |
|
0
|
|
|
|
|
|
|
540
|
|
|
|
|
|
|
|
541
|
0
|
|
|
|
|
|
my $count = @data; |
542
|
|
|
|
|
|
|
|
543
|
0
|
0
|
|
|
|
|
croak "Too many -menu items" if $count > 26; |
544
|
0
|
0
|
|
|
|
|
croak "Too few -menu items" if $count < 1; |
545
|
|
|
|
|
|
|
|
546
|
0
|
|
|
|
|
|
my $max_char = chr(ord('a') + $count - 1); |
547
|
0
|
|
|
|
|
|
my $menu = q{}; |
548
|
|
|
|
|
|
|
|
549
|
0
|
|
|
|
|
|
my $default_key; |
550
|
0
|
|
|
|
|
|
my $next = 'a'; |
551
|
0
|
|
|
|
|
|
for (@data) { |
552
|
0
|
|
|
|
|
|
my $item = $_; |
553
|
0
|
0
|
0
|
|
|
|
if (defined $flags->{ -default } && !defined $default_key && $item eq $flags->{ -default }) { |
|
|
|
0
|
|
|
|
|
554
|
0
|
|
|
|
|
|
$default_key = $next; |
555
|
|
|
|
|
|
|
} |
556
|
0
|
|
|
|
|
|
$item =~ s/\A/qq{ }.$next++.q{. }/xmse; |
|
0
|
|
|
|
|
|
|
557
|
0
|
|
|
|
|
|
$item =~ s/\n?\z/\n/xms; |
558
|
0
|
|
|
|
|
|
$item =~ s/(?!\Z)\n/\n /gxms; |
559
|
0
|
|
|
|
|
|
$menu .= $item; |
560
|
|
|
|
|
|
|
} |
561
|
|
|
|
|
|
|
|
562
|
0
|
|
|
|
|
|
push @prompt, "\n$menu\n> "; |
563
|
|
|
|
|
|
|
|
564
|
0
|
|
|
|
|
|
my $prompt_range = "(Please enter a-$max_char) > "; |
565
|
0
|
|
|
|
|
|
my $require = $flags->{ -require }; |
566
|
0
|
0
|
|
|
|
|
print {$OUT} @prompt if -t $IN; |
|
0
|
|
|
|
|
|
|
567
|
0
|
|
|
|
|
|
while (1) { |
568
|
0
|
|
|
|
|
|
my $response = |
569
|
|
|
|
|
|
|
get_input($IN, $OUT, { %$flags, -escape => 1, -nlstr => "", -require => undef }, |
570
|
|
|
|
|
|
|
@prompt); |
571
|
0
|
|
|
|
|
|
chomp $response; |
572
|
0
|
0
|
0
|
|
|
|
if (-t $IN and defined $response) { |
573
|
0
|
0
|
0
|
|
|
|
if (length $response == 1 && $response eq "\e") { |
|
|
0
|
0
|
|
|
|
|
|
|
0
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
574
|
0
|
|
|
|
|
|
return $response; |
575
|
|
|
|
|
|
|
} |
576
|
|
|
|
|
|
|
elsif (length $response > 1 || ($response lt 'a' || $response gt $max_char) ) { |
577
|
0
|
0
|
|
|
|
|
if ($response ne $flags->{-default}) { |
578
|
0
|
|
|
|
|
|
print {$OUT} "\r", " " x 79, "\r", $prompt_range; |
|
0
|
|
|
|
|
|
|
579
|
0
|
|
|
|
|
|
next; |
580
|
|
|
|
|
|
|
} |
581
|
0
|
|
|
|
|
|
$response = $default_key; |
582
|
|
|
|
|
|
|
} |
583
|
|
|
|
|
|
|
elsif ($require and my $mesg = $require->($data[ord($response)-ord('a')])) { |
584
|
0
|
|
|
|
|
|
print {$OUT} "\r", " " x 79, "\r", sprintf($mesg, @prompt); |
|
0
|
|
|
|
|
|
|
585
|
0
|
|
|
|
|
|
next; |
586
|
|
|
|
|
|
|
} |
587
|
|
|
|
|
|
|
} |
588
|
0
|
|
|
|
|
|
print {$OUT} "\n"; |
|
0
|
|
|
|
|
|
|
589
|
0
|
|
|
|
|
|
my $selection = $data[ord($response)-ord('a')]; |
590
|
0
|
0
|
|
|
|
|
$response = defined $response ? $val_for->($selection) : $response; |
591
|
0
|
0
|
0
|
|
|
|
if (defined $response && ref($response) =~ m/\A(?:HASH|ARRAY)\z/xms ) { |
592
|
0
|
|
|
|
|
|
$response = _menu($IN, $OUT, {%{$flags}, -menu=>$response}, "$selection: "); |
|
0
|
|
|
|
|
|
|
593
|
0
|
0
|
0
|
|
|
|
if (defined $response && $response eq "\e") { |
594
|
0
|
0
|
|
|
|
|
print {$OUT} "\n", @prompt if -t $IN; |
|
0
|
|
|
|
|
|
|
595
|
0
|
|
|
|
|
|
next; |
596
|
|
|
|
|
|
|
} |
597
|
|
|
|
|
|
|
} |
598
|
0
|
|
|
|
|
|
return _tidy($response); |
599
|
|
|
|
|
|
|
} |
600
|
|
|
|
|
|
|
} |
601
|
|
|
|
|
|
|
|
602
|
|
|
|
|
|
|
sub _smartmatch { |
603
|
0
|
|
|
0
|
|
|
my ($str, $matcher) = @_; |
604
|
0
|
|
|
|
|
|
my $type = ref $matcher; |
605
|
|
|
|
|
|
|
my $res = $type eq 'CODE' |
606
|
0
|
|
|
|
|
|
? do { local $_ = $str; $matcher->() } |
|
0
|
|
|
|
|
|
|
607
|
|
|
|
|
|
|
: $type eq 'Regexp' ? ($str =~ $matcher) |
608
|
0
|
|
|
|
|
|
: $type eq 'ARRAY' ? scalar grep({ _smartmatch($str, $_) } @$matcher) |
609
|
0
|
0
|
|
|
|
|
: $type eq 'HASH' ? $matcher->{$str} |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
610
|
|
|
|
|
|
|
: $str eq $matcher; |
611
|
0
|
|
|
|
|
|
return $res; |
612
|
|
|
|
|
|
|
} |
613
|
|
|
|
|
|
|
|
614
|
|
|
|
|
|
|
package IO::Prompt::ReturnVal; |
615
|
|
|
|
|
|
|
|
616
|
|
|
|
|
|
|
use overload |
617
|
|
|
|
|
|
|
q{bool} => sub { |
618
|
0
|
0
|
|
0
|
|
0
|
$_ = $_[0]{value} if $_[0]{set_val}; |
619
|
0
|
|
|
|
|
0
|
$_[0]{handled} = 1; |
620
|
0
|
|
|
|
|
0
|
$_[0]{success}; |
621
|
|
|
|
|
|
|
}, |
622
|
0
|
|
|
0
|
|
0
|
q{""} => sub { $_[0]{handled} = 1; "$_[0]{value}"; }, |
|
0
|
|
|
|
|
0
|
|
623
|
0
|
|
|
0
|
|
0
|
q{0+} => sub { $_[0]{handled} = 1; 0 + $_[0]{value}; }, |
|
0
|
|
|
|
|
0
|
|
624
|
1
|
|
|
|
|
13
|
fallback => 1, |
625
|
1
|
|
|
1
|
|
1109
|
; |
|
1
|
|
|
|
|
1024
|
|
626
|
|
|
|
|
|
|
|
627
|
|
|
|
|
|
|
sub DESTROY { |
628
|
0
|
0
|
|
0
|
|
|
$_ = $_[0]{value} unless $_[0]{handled}; |
629
|
|
|
|
|
|
|
} |
630
|
|
|
|
|
|
|
|
631
|
|
|
|
|
|
|
1; # Magic true value required at end of module |
632
|
|
|
|
|
|
|
__END__ |