← Index
NYTProf Performance Profile   « line view »
For split.pl
  Run on Thu Apr 20 02:05:47 2023
Reported on Thu Apr 20 18:31:09 2023

Filename/home/hejohns/perl5/lib/perl5/IO/Prompter.pm
StatementsExecuted 102 statements in 8.01ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
1116.56ms10.3msIO::Prompter::::BEGIN@9IO::Prompter::BEGIN@9
111347µs505µsIO::Prompter::::BEGIN@334IO::Prompter::BEGIN@334
111206µs239µsIO::Prompter::::BEGIN@6IO::Prompter::BEGIN@6
182114µs14µsIO::Prompter::::CORE:sortIO::Prompter::CORE:sort (opcode)
22113µs13µsIO::Prompter::::CORE:regcompIO::Prompter::CORE:regcomp (opcode)
11111µs11µsmain::::BEGIN@1.4 main::BEGIN@1.4
1118µs17µsIO::Prompter::::BEGIN@1171IO::Prompter::BEGIN@1171
1118µs26µsIO::Prompter::::BEGIN@8IO::Prompter::BEGIN@8
1118µs16µsIO::Prompter::::BEGIN@1059IO::Prompter::BEGIN@1059
1117µs12µsIO::Prompter::::BEGIN@1689IO::Prompter::BEGIN@1689
1117µs16µsIO::Prompter::::BEGIN@268IO::Prompter::BEGIN@268
1117µs14µsIO::Prompter::::importIO::Prompter::import
1117µs19µsIO::Prompter::::BEGIN@743IO::Prompter::BEGIN@743
1117µs12µsmain::::BEGIN@1212 main::BEGIN@1212
1116µs12µsIO::Prompter::::BEGIN@104IO::Prompter::BEGIN@104
1116µs16µsIO::Prompter::::BEGIN@394IO::Prompter::BEGIN@394
1115µs15µsIO::Prompter::::BEGIN@942IO::Prompter::BEGIN@942
1115µs22µsIO::Prompter::::BEGIN@5IO::Prompter::BEGIN@5
1115µs23µsIO::Prompter::::BEGIN@11IO::Prompter::BEGIN@11
1115µs12µsIO::Prompter::::BEGIN@752IO::Prompter::BEGIN@752
1115µs24µsIO::Prompter::::BEGIN@10IO::Prompter::BEGIN@10
1115µs7µsIO::Prompter::::BEGIN@3IO::Prompter::BEGIN@3
1114µs7µsIO::Prompter::::BEGIN@118IO::Prompter::BEGIN@118
1114µs13µsIO::Prompter::::BEGIN@156IO::Prompter::BEGIN@156
1114µs13µsIO::Prompter::::BEGIN@971IO::Prompter::BEGIN@971
7714µs4µsIO::Prompter::::CORE:qrIO::Prompter::CORE:qr (opcode)
1114µs14µsIO::Prompter::::BEGIN@105IO::Prompter::BEGIN@105
1114µs4µsIO::Prompter::::BEGIN@7IO::Prompter::BEGIN@7
0000s0sIO::Prompter::::__ANON__[:1042]IO::Prompter::__ANON__[:1042]
0000s0sIO::Prompter::::__ANON__[:109]IO::Prompter::__ANON__[:109]
0000s0sIO::Prompter::::__ANON__[:1216]IO::Prompter::__ANON__[:1216]
0000s0sIO::Prompter::::__ANON__[:1550]IO::Prompter::__ANON__[:1550]
0000s0sIO::Prompter::::__ANON__[:1697]IO::Prompter::__ANON__[:1697]
0000s0sIO::Prompter::::__ANON__[:1705]IO::Prompter::__ANON__[:1705]
0000s0sIO::Prompter::::__ANON__[:1711]IO::Prompter::__ANON__[:1711]
0000s0sIO::Prompter::::__ANON__[:301]IO::Prompter::__ANON__[:301]
0000s0sIO::Prompter::::__ANON__[:302]IO::Prompter::__ANON__[:302]
0000s0sIO::Prompter::::__ANON__[:303]IO::Prompter::__ANON__[:303]
0000s0sIO::Prompter::::__ANON__[:305]IO::Prompter::__ANON__[:305]
0000s0sIO::Prompter::::__ANON__[:310]IO::Prompter::__ANON__[:310]
0000s0sIO::Prompter::::__ANON__[:311]IO::Prompter::__ANON__[:311]
0000s0sIO::Prompter::::__ANON__[:338]IO::Prompter::__ANON__[:338]
0000s0sIO::Prompter::::__ANON__[:342]IO::Prompter::__ANON__[:342]
0000s0sIO::Prompter::::__ANON__[:343]IO::Prompter::__ANON__[:343]
0000s0sIO::Prompter::::__ANON__[:344]IO::Prompter::__ANON__[:344]
0000s0sIO::Prompter::::__ANON__[:345]IO::Prompter::__ANON__[:345]
0000s0sIO::Prompter::::__ANON__[:346]IO::Prompter::__ANON__[:346]
0000s0sIO::Prompter::::__ANON__[:357]IO::Prompter::__ANON__[:357]
0000s0sIO::Prompter::::__ANON__[:370]IO::Prompter::__ANON__[:370]
0000s0sIO::Prompter::::__ANON__[:381]IO::Prompter::__ANON__[:381]
0000s0sIO::Prompter::::__ANON__[:393]IO::Prompter::__ANON__[:393]
0000s0sIO::Prompter::::__ANON__[:394]IO::Prompter::__ANON__[:394]
0000s0sIO::Prompter::::__ANON__[:422]IO::Prompter::__ANON__[:422]
0000s0sIO::Prompter::::__ANON__[:434]IO::Prompter::__ANON__[:434]
0000s0sIO::Prompter::::__ANON__[:435]IO::Prompter::__ANON__[:435]
0000s0sIO::Prompter::::__ANON__[:436]IO::Prompter::__ANON__[:436]
0000s0sIO::Prompter::::__ANON__[:437]IO::Prompter::__ANON__[:437]
0000s0sIO::Prompter::::__ANON__[:438]IO::Prompter::__ANON__[:438]
0000s0sIO::Prompter::::__ANON__[:547]IO::Prompter::__ANON__[:547]
0000s0sIO::Prompter::::__ANON__[:548]IO::Prompter::__ANON__[:548]
0000s0sIO::Prompter::::__ANON__[:763]IO::Prompter::__ANON__[:763]
0000s0sIO::Prompter::::__ANON__[:807]IO::Prompter::__ANON__[:807]
0000s0sIO::Prompter::::__ANON__[:826]IO::Prompter::__ANON__[:826]
0000s0sIO::Prompter::::_autoflushIO::Prompter::_autoflush
0000s0sIO::Prompter::::_build_menuIO::Prompter::_build_menu
0000s0sIO::Prompter::::_current_completions_forIO::Prompter::_current_completions_for
0000s0sIO::Prompter::::_current_history_forIO::Prompter::_current_history_for
0000s0sIO::Prompter::::_decode_argsIO::Prompter::_decode_args
0000s0sIO::Prompter::::_decode_echoIO::Prompter::_decode_echo
0000s0sIO::Prompter::::_decode_echostyleIO::Prompter::_decode_echostyle
0000s0sIO::Prompter::::_decode_styleIO::Prompter::_decode_style
0000s0sIO::Prompter::::_display_completionsIO::Prompter::_display_completions
0000s0sIO::Prompter::::_gen_wrapper_forIO::Prompter::_gen_wrapper_for
0000s0sIO::Prompter::::_generate_buffered_reader_fromIO::Prompter::_generate_buffered_reader_from
0000s0sIO::Prompter::::_generate_unbuffered_reader_fromIO::Prompter::_generate_unbuffered_reader_from
0000s0sIO::Prompter::::_longest_common_prefix_forIO::Prompter::_longest_common_prefix_for
0000s0sIO::Prompter::::_null_printerIO::Prompter::_null_printer
0000s0sIO::Prompter::::_open_ARGVIO::Prompter::_open_ARGV
0000s0sIO::Prompter::::_opt_errIO::Prompter::_opt_err
0000s0sIO::Prompter::::_shell_expandIO::Prompter::_shell_expand
0000s0sIO::Prompter::::_simulate_typingIO::Prompter::_simulate_typing
0000s0sIO::Prompter::::_standardize_constraintIO::Prompter::_standardize_constraint
0000s0sIO::Prompter::::_std_printer_toIO::Prompter::_std_printer_to
0000s0sIO::Prompter::::_stylizeIO::Prompter::_stylize
0000s0sIO::Prompter::::_term_widthIO::Prompter::_term_width
0000s0sIO::Prompter::::_verify_input_constraintsIO::Prompter::_verify_input_constraints
0000s0sIO::Prompter::::_warnIO::Prompter::_warn
0000s0sIO::Prompter::::_wipe_lineIO::Prompter::_wipe_line
0000s0sIO::Prompter::::promptIO::Prompter::prompt
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1232µs111µs
# spent 11µs within main::BEGIN@1.4 which was called: # once (11µs+0s) by main::BEGIN@24 at line 1
use 5.010;
# spent 11µs making 1 call to main::BEGIN@1.4
2package IO::Prompter;
3215µs210µs
# spent 7µs (5+3) within IO::Prompter::BEGIN@3 which was called: # once (5µs+3µs) by main::BEGIN@24 at line 3
use utf8;
# spent 7µs making 1 call to IO::Prompter::BEGIN@3 # spent 3µs making 1 call to utf8::import
4
5226µs238µs
# spent 22µs (5+17) within IO::Prompter::BEGIN@5 which was called: # once (5µs+17µs) by main::BEGIN@24 at line 5
use warnings;
# spent 22µs making 1 call to IO::Prompter::BEGIN@5 # spent 17µs making 1 call to warnings::import
6299µs2241µs
# spent 239µs (206+34) within IO::Prompter::BEGIN@6 which was called: # once (206µs+34µs) by main::BEGIN@24 at line 6
no if $] >= 5.018000, warnings => 'experimental';
# spent 239µs making 1 call to IO::Prompter::BEGIN@6 # spent 2µs making 1 call to if::unimport
7214µs25µs
# spent 4µs (4+900ns) within IO::Prompter::BEGIN@7 which was called: # once (4µs+900ns) by main::BEGIN@24 at line 7
use strict;
# spent 4µs making 1 call to IO::Prompter::BEGIN@7 # spent 900ns making 1 call to strict::import
8218µs245µs
# spent 26µs (8+18) within IO::Prompter::BEGIN@8 which was called: # once (8µs+18µs) by main::BEGIN@24 at line 8
use Carp;
# spent 26µs making 1 call to IO::Prompter::BEGIN@8 # spent 18µs making 1 call to Exporter::import
9276µs210.8ms
# spent 10.3ms (6.56+3.72) within IO::Prompter::BEGIN@9 which was called: # once (6.56ms+3.72ms) by main::BEGIN@24 at line 9
use Contextual::Return qw< PUREBOOL BOOL SCALAR METHOD VOID LIST RETOBJ >;
# spent 10.3ms making 1 call to IO::Prompter::BEGIN@9 # spent 566µs making 1 call to Contextual::Return::import
10219µs244µs
# spent 24µs (5+20) within IO::Prompter::BEGIN@10 which was called: # once (5µs+20µs) by main::BEGIN@24 at line 10
use Scalar::Util qw< openhandle looks_like_number >;
# spent 24µs making 1 call to IO::Prompter::BEGIN@10 # spent 20µs making 1 call to Exporter::import
112419µs242µs
# spent 23µs (5+18) within IO::Prompter::BEGIN@11 which was called: # once (5µs+18µs) by main::BEGIN@24 at line 11
use Symbol qw< qualify_to_ref >;
# spent 23µs making 1 call to IO::Prompter::BEGIN@11 # spent 18µs making 1 call to Exporter::import
12
131300nsour $VERSION = '0.004015';
14
151100nsmy $fake_input; # Flag that we're faking input from the source
16
171100nsmy $DEFAULT_TERM_WIDTH = 80;
181200nsmy $DEFAULT_VERBATIM_KEY = "\cV";
19
20# Completion control...
2110smy $COMPLETE_DISPLAY_FIELDS = 4; #...per line
221100nsmy $COMPLETE_DISPLAY_GAP = 3; #...spaces
23
2411µsmy $COMPLETE_KEY = $ENV{IO_PROMPTER_COMPLETE_KEY} // qq{\t};
251300nsmy $COMPLETE_HIST = $ENV{IO_PROMPTER_HISTORY_KEY} // qq{\cR};
261100nsmy $COMPLETE_NEXT = qq{\cN};
2710smy $COMPLETE_PREV = qq{\cP};
28
29117µs210µsmy $COMPLETE_INIT = qr{ [\Q$COMPLETE_KEY$COMPLETE_HIST\E] }xms;
# spent 8µs making 1 call to IO::Prompter::CORE:regcomp # spent 2µs making 1 call to IO::Prompter::CORE:qr
3017µs25µsmy $COMPLETE_CYCLE = qr{ [$COMPLETE_NEXT$COMPLETE_PREV] }xms;
# spent 5µs making 1 call to IO::Prompter::CORE:regcomp # spent 300ns making 1 call to IO::Prompter::CORE:qr
31
32my %COMPLETE_MODE = (
33 $COMPLETE_KEY
34 => [split /\s+/, $ENV{IO_PROMPTER_COMPLETE_MODES}//q{list+longest full}],
35 $COMPLETE_HIST
3613µs => [split /\s+/, $ENV{IO_PROMPTER_HISTORY_MODES} // q{full}],
37);
38
391100nsmy $FAKE_ESC = "\e";
401100nsmy $FAKE_INSERT = "\cF";
411100nsmy $MENU_ESC = "\e";
421100nsmy $MENU_MK = '__M_E_N_U__';
43
4412µsmy %EDIT = (
45 BACK => qq{\cB},
46 FORWARD => qq{\cF},
47 START => qq{\cA},
48 END => qq{\cE},
49);
5011µsmy $EDIT_KEY = '['.join(q{},values %EDIT).']';
51
52# Extracting key letters...
5312µs1700nsmy $KL_EXTRACT = qr{ (?| \[ ( [[:alnum:]]++ ) \]
# spent 700ns making 1 call to IO::Prompter::CORE:qr
54 | \( ( [[:alnum:]]++ ) \)
55 | \< ( [[:alnum:]]++ ) \>
56 | \{ ( [[:alnum:]]++ ) \}
57 )
58 }xms;
5911µs1400nsmy $KL_DEF_EXTRACT = qr{ \[ ( [[:alnum:]]++ ) \] }xms;
# spent 400ns making 1 call to IO::Prompter::CORE:qr
60
61
62# Auxiliary prompts for -Yes => N construct...
6311µsmy @YESNO_PROMPTS = (
64 q{Really?},
65 q{You're quite certain?},
66 q{Definitely?},
67 q{You mean it?},
68 q{You truly mean it?},
69 q{You're sure?},
70 q{Have you thought this through?},
71 q{You understand the consequences?},
72);
73
74
75# Remember returned values for history completion...
761100nsmy %history_cache;
77
78# Track lexically-scoped default options and wrapper subs...
791400nsmy @lexical_options = [];
801200nsmy @lexical_wrappers = [];
81
82# Export the prompt() sub...
83
# spent 14µs (7+8) within IO::Prompter::import which was called: # once (7µs+8µs) by main::BEGIN@24 at line 24 of /home/hejohns/documentsNoSync/22f/490/gradescope-utils/bin/split.pl
sub import {
841700ns my (undef, $config_data, @other_args) = @_;
85
86 # Handle -argv requests...
8711µs if (defined $config_data && $config_data eq '-argv') {
88 scalar prompt(-argv, @other_args);
89 }
90
91 # Handle lexical options...
92 elsif (ref $config_data eq 'ARRAY') {
93 push @lexical_options, $config_data;
94 $^H{'IO::Prompter::scope_number'} = $#lexical_options;
95 }
96
97 # Handle lexical wrappers...
98 elsif (ref $config_data eq 'HASH') {
99 push @lexical_options, [];
100 $lexical_wrappers[ $#lexical_options ] = $config_data;
101 $^H{'IO::Prompter::scope_number'} = $#lexical_options;
102 for my $subname (keys %{$config_data}) {
103 my @args = @{$config_data->{$subname}};
104225µs218µs
# spent 12µs (6+6) within IO::Prompter::BEGIN@104 which was called: # once (6µs+6µs) by main::BEGIN@24 at line 104
no strict 'refs';
# spent 12µs making 1 call to IO::Prompter::BEGIN@104 # spent 6µs making 1 call to strict::unimport
105271µs225µs
# spent 14µs (4+11) within IO::Prompter::BEGIN@105 which was called: # once (4µs+11µs) by main::BEGIN@24 at line 105
no warnings 'redefine';
# spent 14µs making 1 call to IO::Prompter::BEGIN@105 # spent 10µs making 1 call to warnings::unimport
106 *{caller().'::'.$subname} = sub {
107 my $scope_number = (caller 0)[10]{'IO::Prompter::scope_number'};
108 return prompt(@{$lexical_wrappers[$scope_number]{$subname}//[]}, @_);
109 };
110 }
111 }
112
113 # Handler faked input specifications...
114 elsif (defined $config_data) {
115 $fake_input = $config_data;
116 }
117
1182152µs210µs
# spent 7µs (4+3) within IO::Prompter::BEGIN@118 which was called: # once (4µs+3µs) by main::BEGIN@24 at line 118
no strict 'refs';
# spent 7µs making 1 call to IO::Prompter::BEGIN@118 # spent 3µs making 1 call to strict::unimport
11914µs18µs *{caller().'::prompt'} = \&prompt;
# spent 8µs making 1 call to Contextual::Return::__ANON__[Contextual/Return.pm:30]
120}
121
122# Prompt for, read, vet, and return input...
123sub prompt {
124 # Reclaim full control of print statements while prompting...
125 local $\ = '';
126
127 # Locate any lexical default options...
128 my $hints_hash = (caller 0)[10] // {};
129 my $scope_num = $hints_hash->{'IO::Prompter::scope_number'} // 0;
130
131 # Extract and sanitize configuration arguments...
132 my $opt_ref = _decode_args(@{$lexical_options[$scope_num]}, @_);
133
134 _warn( void => 'Useless use of prompt() in void context' )
135 if VOID && !$opt_ref->{-void};
136
137 # Set up yesno prompts if required...
138 my @yesno_prompts
139 = ($opt_ref->{-yesno}{count}//0) > 1 ? @YESNO_PROMPTS : ();
140
141 # Work out where the prompts go, and where the input comes from...
142 my $in_filehandle = $opt_ref->{-in} // _open_ARGV();
143 my $out_filehandle = $opt_ref->{-out} // qualify_to_ref(select);
144 if (!openhandle $in_filehandle) {
145 open my $fh, '<', $in_filehandle
146 or _opt_err('Unacceptable', '-in', 'valid filehandle or filename');
147 $in_filehandle = $fh;
148 }
149 if (!openhandle $out_filehandle) {
150 open my $fh, '>', $out_filehandle
151 or _opt_err('Unacceptable', '-out', 'valid filehandle or filename');
152 $out_filehandle = $fh;
153 }
154
155 # Track timeouts...
1562401µs221µs
# spent 13µs (4+8) within IO::Prompter::BEGIN@156 which was called: # once (4µs+8µs) by main::BEGIN@24 at line 156
my $in_pos = do { no warnings; tell $in_filehandle } // 0;
# spent 13µs making 1 call to IO::Prompter::BEGIN@156 # spent 8µs making 1 call to warnings::unimport
157
158 # Short-circuit if not valid handles...
159 return if !openhandle($in_filehandle) || !openhandle($out_filehandle);
160
161 # Work out how they're arriving and departing...
162 my $outputter_ref = -t $in_filehandle && -t $out_filehandle
163 ? _std_printer_to($out_filehandle, $opt_ref)
164 : _null_printer()
165 ;
166 my $inputter_ref = _generate_unbuffered_reader_from(
167 $in_filehandle, $outputter_ref, $opt_ref
168 );
169
170 # Clear the screen if requested to...
171 if ($opt_ref->{-wipe}) {
172 $outputter_ref->(-nostyle => "\n" x 1000);
173 }
174
175 # Handle menu structures...
176 my $input;
177 REPROMPT_YESNO:
178 if ($opt_ref->{-menu}) {
179 # Remember top of (possibly nested) menu...
180 my @menu = ( $opt_ref->{-menu} );
181 my $top_prompt = $opt_ref->{-prompt};
182 $top_prompt =~ s{$MENU_MK}{$opt_ref->{-menu}{prompt}}xms;
183 $menu[-1]{prompt} = $top_prompt;
184
185 MENU:
186 while (1) {
187 # Track the current level...
188 $opt_ref->{-menu_curr_level} = $menu[-1]{value_for};
189
190 # Show menu and retreive choice...
191 $outputter_ref->(-style => $menu[-1]{prompt});
192 my $tag = $inputter_ref->($menu[-1]{constraint});
193
194 # Handle a failure by exiting the loop...
195 last MENU if !defined $tag;
196 $tag =~ s{\A\s*(\S*).*}{$1}xms;
197
198 # Handle <ESC> by moving up menu stack...
199 if ($tag eq $MENU_ESC) {
200 $input = undef;
201 last MENU if @menu <= 1;
202 pop @menu;
203 next MENU;
204 }
205
206 # Handle defaults by selecting and ejecting...
207 if ($tag =~ /\A\R?\Z/ && exists $opt_ref->{-def}) {
208 $input = $tag;
209 last MENU;
210 }
211
212 # Otherwise, retrieve value for selected tag and exit if not a nested menu...
213 $input = $menu[-1]{value_for}{$tag};
214 last MENU if !ref $input;
215
216 # Otherwise, go down the menu one level...
217 push @menu,
218 _build_menu($input,
219 "Select from $menu[-1]{key_for}{$tag}: ",
220 $opt_ref->{-number} || $opt_ref->{-integer}
221 );
222 $menu[-1]{prompt} .= '> ';
223 }
224 }
225
226 # Otherwise, simply ask and ye shall receive...
227 else {
228 $outputter_ref->(-style => $opt_ref->{-prompt});
229 $input = $inputter_ref->();
230 }
231
232 # Provide default value if available and necessary...
233 my $defaulted = 0;
234 if (defined $input && $input =~ /\A\R?\Z/ && exists $opt_ref->{-def}) {
235 $input = $opt_ref->{-def};
236 $defaulted = 1;
237 }
238
239 # The input line is usually chomped before being returned...
240 if (defined $input && !$opt_ref->{-line}) {
241 chomp $input;
242 }
243
244 # Check for a value indicating failure...
245 if (exists $opt_ref->{-fail} && $input ~~ $opt_ref->{-fail}) {
246 $input = undef;
247 }
248
249 # Setting @ARGV is a special case; process it like a command-line...
250 if ($opt_ref->{-argv}) {
251 @ARGV = map { _shell_expand($_) }
252 grep {defined}
253 $input =~ m{
254 ( ' [^'\\]* (?: \\. [^'\\]* )* ' )
255 | ( " [^"\\]* (?: \\. [^"\\]* )* " )
256 | (?: ^ | \s) ( [^\s"'] \S* )
257 }gxms;
258 return 1;
259 }
260
261 # "Those who remember history are enabled to repeat it"...
262 if (defined $input and $opt_ref->{-history} ne 'NONE') {
263 my $history_set = $history_cache{ $opt_ref->{-history} } //= [] ;
264 @{ $history_set } = ($input, grep { $_ ne $input } @{ $history_set });
265 }
266
267 # If input timed out insert the default, if any...
2682360µs224µs
# spent 16µs (7+8) within IO::Prompter::BEGIN@268 which was called: # once (7µs+8µs) by main::BEGIN@24 at line 268
my $timedout = $in_pos == do{ no warnings; tell $in_filehandle } // 0;
# spent 16µs making 1 call to IO::Prompter::BEGIN@268 # spent 8µs making 1 call to warnings::unimport
269 if ($timedout && exists $opt_ref->{-def}) {
270 $input = $opt_ref->{-def};
271 $defaulted = 1;
272 }
273
274 # A defined input is a successful input...
275 my $succeeded = defined $input;
276
277 # The -yesno variants also need a 'y' to be successful...
278 if ($opt_ref->{-yesno}{count}) {
279 $succeeded &&= $input =~ m{\A \s* y}ixms;
280 if ($succeeded && $opt_ref->{-yesno}{count} > 1) {
281 my $count = --$opt_ref->{-yesno}{count};
282 $opt_ref->{-prompt}
283 = @yesno_prompts ? shift(@yesno_prompts) . q{ }
284 : $count > 1 ? qq{Please confirm $count more times }
285 : q{Please confirm one last time }
286 ;
287 goto REPROMPT_YESNO; # Gasp, yes goto is the cleanest way!
288 }
289 }
290
291 # Verbatim return doesn't do fancy tricks...
292 if ($opt_ref->{-verbatim}) {
293 return $input // ();
294 }
295
296 # Failure in a list context returns nothing...
297 return if LIST && !$succeeded;
298
299 # Otherwise, be context sensitive...
300 return
301 PUREBOOL { $_ = RETOBJ; next handler; }
302 BOOL { $succeeded; }
303 SCALAR { $input; }
304 METHOD {
305 defaulted => sub { $defaulted },
306 timedout => sub {
307 return q{} if !$timedout;
308 return "timed out after $opt_ref->{-timeout} second"
309 . ($opt_ref->{-timeout} == 1 ? q{} : q{s});
310 },
311 };
312}
313
314
315# Simulate a command line expansion for the -argv option...
316sub _shell_expand {
317 my ($text) = @_;
318
319 # Single-quoted text is literal...
320 if ($text =~ m{\A ' (.*) ' \z}xms) {
321 return $1;
322 }
323
324 # Everything else has shell variables expanded...
325 my $ENV_PAT = join '|', reverse sort keys %ENV;
326 $text =~ s{\$ ($ENV_PAT)}{$ENV{$1}}gxms;
327
328 # Double-quoted text isn't globbed...
329 if ($text =~ m{\A " (.*) " \z}xms) {
330 return $1;
331 }
332
333 # Everything else is...
3342358µs1505µs
# spent 505µs (347+158) within IO::Prompter::BEGIN@334 which was called: # once (347µs+158µs) by main::BEGIN@24 at line 334
return glob($text);
# spent 505µs making 1 call to IO::Prompter::BEGIN@334
335}
336
337# No completion is the default...
33812µsmy $DEFAULT_COMPLETER = sub { q{} };
339
340# Translate std constraints...
341my %STD_CONSTRAINT = (
342 positive => sub { $_ > 0 },
343 negative => sub { $_ < 0 },
344 zero => sub { $_ == 0 },
345 even => sub { $_ % 2 == 0 },
346 odd => sub { $_ % 2 != 0 },
34715µs);
348
349# Create abbreviations...
3501800ns$STD_CONSTRAINT{pos} = $STD_CONSTRAINT{positive};
3511200ns$STD_CONSTRAINT{neg} = $STD_CONSTRAINT{negative};
352
353# Create antitheses...
35411µsfor my $constraint (keys %STD_CONSTRAINT) {
3557900ns my $implementation = $STD_CONSTRAINT{$constraint};
356 $STD_CONSTRAINT{"non$constraint"}
357717µs = sub { ! $implementation->(@_) };
358}
359
360# Special style specifications require decoding...
361
362sub _decode_echo {
363 my $style = shift;
364
365 # Not a special style...
366 return $style if ref $style || $style !~ m{/};
367
368 # A slash means yes/no echoes...
369 my ($yes, $no) = split m{/}, $style;
370 return sub{ /y/i ? $yes : $no };
371}
372
373sub _decode_echostyle {
374 my $style = shift;
375
376 # Not a special style...
377 return $style if ref $style || $style !~ m{/};
378
379 # A slash means yes/no styles...
380 my ($yes, $no) = split m{/}, $style;
381 return sub{ /y/i ? $yes : $no };
382}
383
384sub _decode_style {
385 # No special prompt styles (yet)...
386 return shift;
387}
388
389# Generate safe closure around active sub...
390sub _gen_wrapper_for {
391 my ($arg) = @_;
392 return ref $arg ne 'CODE'
393 ? sub { $arg }
39421.46ms226µs
# spent 16µs (6+10) within IO::Prompter::BEGIN@394 which was called: # once (6µs+10µs) by main::BEGIN@24 at line 394
: sub { eval { for (shift) { no warnings; return $arg->($_) // $_ } } };
# spent 16µs making 1 call to IO::Prompter::BEGIN@394 # spent 10µs making 1 call to warnings::unimport
395}
396
397# Create recognizer...
39817µs13µsmy $STD_CONSTRAINT
# spent 3µs making 1 call to IO::Prompter::CORE:sort
399 = '^(?:' . join('|', reverse sort keys %STD_CONSTRAINT) . ')';
400
401# Translate name constraints to implementations...
402sub _standardize_constraint {
403 my ($option_type, $constraint_spec) = @_;
404
405 return ("be an acceptable $option_type", $constraint_spec)
406 if ref $constraint_spec;
407
408 my @constraint_names = split /\s+/, $constraint_spec;
409 my @constraints =
410 map { $STD_CONSTRAINT{$_}
411 // _opt_err('invalid',-$option_type,'"pos", "neg", "even", etc.')
412 } @constraint_names;
413
414 return (
415 'be ' . join(' and ', @constraint_names),
416 sub {
417 my ($compare_val) = @_;
418 for my $constraint (@constraints) {
419 return 0 if !$constraint->($compare_val);
420 }
421 return 1;
422 }
423 );
424}
425
426
427# Convert args to prompt + options hash...
428sub _decode_args {
429 my %option = (
430 -prompt => undef,
431 -complete => $DEFAULT_COMPLETER,
432 -must => {},
433 -history => 'DEFAULT',
434 -style => sub{ q{} },
435 -nostyle => sub{ q{} },
436 -echostyle => sub{ q{} },
437 -echo => sub { my $char = shift; $char eq "\t" ? q{ } : $char },
438 -return => sub { "\n" },
439 );
440
441 DECODING:
442 while (defined(my $arg = shift @_)) {
443 if (my $type = ref $arg) {
444 _warn( reserved =>
445 'prompt(): Unexpected argument (' . lc($type) . ' ref) ignored'
446 );
447 }
448 else {
449 my $redo;
450 given ($arg) {
451 # The sound of one hand clapping...
452 when (/^-_/) {
453 $redo = 1;
454 }
455
456 # Non-chomping option...
457 when (/^-line$/) {
458 $option{-line}++;
459 }
460 when (/^-l/) {
461 $option{-line}++;
462 $redo = 1;
463 }
464
465 # The -yesno variants...
466 when (/^-YesNo$/) {
467 my $count = @_ && looks_like_number($_[0]) ? shift @_ : 1;
468 $option{-yesno} = {
469 must => { '[YN]' => qr{\A \s* [YN] }xms },
470 count => $count,
471 };
472 }
473 when (/^-YN/) {
474 $option{-yesno} = {
475 must => { '[YN]' => qr{\A \s* [YN] }xms },
476 count => 1,
477 };
478 $redo = 2;
479 }
480 when (/^-yesno$/) {
481 my $count = @_ && looks_like_number($_[0]) ? shift @_ : 1;
482 $option{-yesno} = {
483 must => { '[yn]' => qr{\A \s* [YN] }ixms },
484 count => $count,
485 };
486 }
487 when (/^-yn/) {
488 $option{-yesno} = {
489 must => { '[yn]' => qr{\A \s* [YN] }ixms },
490 count => 1,
491 };
492 $redo = 2;
493 }
494 when (/^-Yes$/) {
495 my $count = @_ && looks_like_number($_[0]) ? shift @_ : 1;
496 $option{-yesno} = {
497 must => { '[Y for yes]' => qr{\A \s* (?: [^y] | \Z) }xms },
498 count => $count,
499 };
500 }
501 when (/^-Y/) {
502 $option{-yesno} = {
503 must => { '[Y for yes]' => qr{\A \s* (?: [^y] | \Z) }xms },
504 count => 1,
505 };
506 $redo = 1;
507 }
508 when (/^-yes$/) {
509 my $count = @_ && looks_like_number($_[0]) ? shift @_ : 1;
510 $option{-yesno} = { count => $count };
511 }
512 when (/^-y/) {
513 $option{-yesno} = { count => 1 };
514 $redo = 1;
515 }
516
517 # Load @ARGV...
518 when (/^-argv$/) {
519 $option{-argv} = 1;
520 }
521
522 when (/^-a/) {
523 $option{-argv} = 1;
524 $redo = 1;
525 }
526
527 # Clear screen before prompt...
528 state $already_wiped;
529 when (/^-wipe(first)?$/) {
530 $option{-wipe} = $1 ? !$already_wiped : 1;
531 $already_wiped = 1;
532 }
533 when (/^-w/) {
534 $option{-wipe} = 1;
535 $already_wiped = 1;
536 $redo = 1;
537 }
538
539 # Specify a failure condition...
540 when (/^-fail$/) {
541 _opt_err('Missing', -fail, 'failure condition') if !@_;
542 $option{-fail} = shift @_;
543 }
544
545 # Specify a file request...
546 when (/^-f(?:ilenames?)?$/) {
547 $option{-must}{'0: be an existing file'} = sub { -e $_[0] };
548 $option{-must}{'1: be readable'} = sub { -r $_[0] };
549 $option{-complete} = 'filenames';
550 }
551
552 # Specify prompt echoing colour/style...
553 when (/^-style/) {
554 _opt_err('Missing -style specification') if !@_;
555 my $style = _decode_style(shift @_);
556 $option{-style} = _gen_wrapper_for($style);
557 }
558
559 # Specify input colour/style...
560 when (/^-echostyle/) {
561 _opt_err('Missing -echostyle specification') if !@_;
562 my $style = _decode_echostyle(shift @_);
563 $option{-echostyle} = _gen_wrapper_for($style);
564 }
565
566
567 # Specify input and output filehandles...
568 when (/^-stdio$/) { $option{-in} = *STDIN;
569 $option{-out} = *STDOUT;
570 }
571 when (/^-in$/) { $option{-in} = shift @_; }
572 when (/^-out$/) { $option{-out} = shift @_; }
573
574 # Specify integer and number return value...
575 when (/^-integer$/) {
576 $option{-integer} = 1;
577 if (@_ && (ref $_[0] || $_[0] =~ $STD_CONSTRAINT)) {
578 my ($errmsg, $constraint)
579 = _standardize_constraint('integer',shift);
580 $option{-must}{$errmsg} = $constraint;
581 }
582 }
583 when (/^-num(?:ber)?$/) {
584 $option{-number} = 1;
585 if (@_ && (ref $_[0] || $_[0] =~ $STD_CONSTRAINT)) {
586 my ($errmsg, $constraint)
587 = _standardize_constraint('number',shift);
588 $option{-must}{$errmsg} = $constraint;
589 }
590 }
591 when (/^-i/) { $option{-integer} = 1; $redo = 1; }
592 when (/^-n/) { $option{-number} = 1; $redo = 1; }
593
594 # Specify void context is okay...
595 when (/^-void$/) { $option{-void} = 1; }
596
597 # Specify verbatim return value...
598 when (/^-verb(?:atim)?$/) { $option{-verbatim} = 1; }
599 when (/^-v/) { $option{-verbatim} = 1; $redo = 1;}
600
601 # Specify single character return...
602 when (/^-sing(?:le)?$/) { $option{-single} = 1; }
603 when (/^-[s1]/) { $option{-single} = 1; $redo = 1; }
604
605 # Specify a default...
606 when (/^-DEF(?:AULT)?/) {
607 _opt_err('Missing', '-DEFAULT', 'string') if !@_;
608 $option{-def} = shift @_;
609 $option{-def_nocheck} = 1;
610 _opt_err('Invalid', '-DEFAULT', 'string')
611 if ref($option{-def});
612 }
613 when (/^-def(?:ault)?/) {
614 _opt_err('Missing', '-default', 'string') if !@_;
615 $option{-def} = shift @_;
616 _opt_err('Invalid', '-default', 'string')
617 if ref($option{-def});
618 }
619 when (/^-d(.+)$/) { $option{-def} = $1; }
620
621 # Specify a timeout...
622 when (/^-t(\d+)/) {
623 $option{-timeout} = $1;
624 $arg =~ s{\d+}{}xms;
625 $redo = 1;
626 }
627 when (/^-timeout$/) {
628 _opt_err('Missing', -timeout, 'number of seconds') if !@_;
629 $option{-timeout} = shift @_;
630 _opt_err('Invalid', -timeout,'number of seconds')
631 if !looks_like_number($option{-timeout});
632 }
633
634 # Specify a set of input constraints...
635 when (/^-g.*/) {
636 _opt_err('Missing', -guarantee, 'input restriction') if !@_;
637 my $restriction = shift @_;
638 my $restriction_type = ref $restriction;
639
640 $option{-must}{'be a valid input'} = $restriction;
641
642 # Hashes restrict input to their keys...
643 if ($restriction_type eq 'HASH') {
644 $restriction_type = 'ARRAY';
645 $restriction = [ keys %{$restriction} ];
646 }
647 # Arrays of strings matched (and completed) char-by-char...
648 if ($restriction_type eq 'ARRAY') {
649 my @restrictions = @{$restriction};
650 $option{-guarantee}
651 = '\A(?:'
652 . join('|', map {
653 join(q{}, map { "(?:\Q$_\E" } split(q{}, $_))
654 . ')?' x length($_)
655 } @restrictions)
656 . ')\z'
657 ;
658 if ($option{-complete} == $DEFAULT_COMPLETER) {
659 $option{-complete} = \@restrictions;
660 }
661 }
662 # Regexes matched as-is...
663 elsif ($restriction_type eq 'Regexp') {
664 $option{-guarantee} = $restriction;
665 }
666 else {
667 _opt_err( 'Invalid', -guarantee,
668 'array or hash reference, or regex'
669 );
670 }
671 }
672
673 # Specify a set of key letters...
674 when ('-keyletters_implement') {
675 # Extract all keys and default keys...
676 my @keys = ($option{-prompt} =~ m{$KL_EXTRACT}gxms);
677
678 # Convert default to a -default...
679 my @defaults = ($option{-prompt} =~ m{$KL_DEF_EXTRACT}gxms);
680 if (@defaults > 1) {
681 _warn( ambiguous =>
682 "prompt(): -keyletters found too many defaults"
683 )
684 }
685 elsif (@defaults) {
686 push @_, -default => $defaults[0];
687 }
688
689 # Convert key letters to a -guarantee...
690 @keys = ( map({uc} @keys), map({lc} @keys) );
691 if (@defaults == 1) {
692 push @keys, q{};
693 }
694 push @_, -guarantee => \@keys;
695
696 }
697 when (/^-key(?:let(?:ter)?)(?:s)?/) {
698 push @_, '-keyletters_implement';
699 }
700 when (/^-k/) {
701 push @_, '-keyletters_implement';
702 $redo = 1;
703 }
704
705 # Specify a set of return constraints...
706 when (/^-must$/) {
707 _opt_err('Missing', -must, 'constraint hash') if !@_;
708 my $must = shift @_;
709 _opt_err('Invalid', -must, 'hash reference')
710 if ref($must) ne 'HASH';
711 for my $errmsg (keys %{$must}) {
712 $option{-must}{$errmsg} = $must->{$errmsg};
713 }
714 }
715
716 # Specify a history set...
717 when (/^-history/) {
718 $option{-history}
719 = @_ && $_[0] !~ /^-/ ? shift @_
720 : undef;
721 _opt_err('Invalid', -history, 'history set name')
722 if ref($option{-history});
723 }
724 when (/^-h(.*)/) { $option{-history} = length($1) ? $1 : undef; }
725
726 # Specify completions...
727 when (/^-comp(?:lete)?/) {
728 _opt_err('Missing', -complete, 'completions') if !@_;
729 my $comp_spec = shift @_;
730 my $comp_type = ref($comp_spec) || $comp_spec || '???';
731 if ($comp_type =~ m{\A(?: file\w* | dir\w* | ARRAY | HASH | CODE )\Z}xms) {
732 $option{-complete} = $comp_spec;
733 }
734 else {
735 _opt_err( 'Invalid', -complete,
736 '"filenames", "dirnames", or reference to array, hash, or subroutine');
737 }
738 }
739
740 # Specify what to echo when a character is keyed...
741 when (/^-(echo|ret(?:urn)?)$/) {
742 my $flag = $1 eq 'echo' ? '-echo' : '-return';
743283µs231µs
# spent 19µs (7+12) within IO::Prompter::BEGIN@743 which was called: # once (7µs+12µs) by main::BEGIN@24 at line 743
if ($flag eq '-echo' && !eval { no warnings 'deprecated'; require Term::ReadKey }) {
# spent 19µs making 1 call to IO::Prompter::BEGIN@743 # spent 12µs making 1 call to warnings::unimport
744 _warn( bareword => "Warning: next input will be in plaintext\n");
745 }
746 my $arg = @_ && $_[0] !~ /^-/ ? shift(@_)
747 : $flag eq '-echo' ? q{}
748 : qq{\n};
749 $option{$flag} = _gen_wrapper_for(_decode_echo($arg));
750 }
751 when (/^-e(.*)/) {
75221.02ms218µs
# spent 12µs (5+7) within IO::Prompter::BEGIN@752 which was called: # once (5µs+7µs) by main::BEGIN@24 at line 752
if (!eval { no warnings 'deprecated'; require Term::ReadKey }) {
# spent 12µs making 1 call to IO::Prompter::BEGIN@752 # spent 7µs making 1 call to warnings::unimport
753 _warn( bareword => "Warning: next input will be in plaintext\n");
754 }
755 my $arg = $1;
756 $option{-echo} = _gen_wrapper_for(_decode_echo($arg));
757 }
758 when (/^-r(.+)/) {
759 my $arg = $1;
760 $option{-return} = _gen_wrapper_for(_decode_echo($arg));
761 }
762 when (/^-r/) {
763 $option{-return} = sub{ "\n" };
764 }
765
766 # Explicit prompt replaces implicit prompts...
767 when (/^-prompt$/) {
768 _opt_err('Missing', '-prompt', 'prompt string') if !@_;
769 $option{-prompt} = shift @_;
770 _opt_err('Invalid', '-prompt', 'string')
771 if ref($option{-prompt});
772 }
773 when (/^-p(\S*)$/) {
774 $option{-prompt} = $1;
775 }
776
777 # Menus inject a placeholder in the prompt string...
778 when (/^-menu$/) {
779 _opt_err('Missing', '-menu', 'menu specification') if !@_;
780 $option{-menu} = ref $_[0] ? shift(@_) : \shift(@_);
781 $option{-prompt} .= $MENU_MK;
782 $option{-def_nocheck} = 1;
783 }
784
785 # Anything else of the form '-...' is a misspelt option...
786 when (/^-\w+$/) { _warn(misc => "prompt(): Unknown option $arg ignored"); }
787
788 # Anything else is part fo the prompt...
789 default { $option{-prompt} .= $arg; }
790 }
791
792 # Handle option bundling...
793 redo DECODING if $redo && $arg =~ s{\A -.{$redo} (?=.)}{-}xms;
794 }
795 }
796
797 # Precompute top-level menu, if menuing...
798 if (exists $option{-menu}) {
799 $option{-menu} = _build_menu($option{-menu},
800 undef,
801 $option{-number}||$option{-integer}
802 );
803 }
804
805 # Handle return magic on -single...
806 if (defined $option{-single} && length($option{-echo}('X')//'echoself')) {
807 $option{-return} //= sub{ "\n" };
808 }
809
810 # Adjust prompt as necessary...
811 if ($option{-argv}) {
812 my $progname = $option{-prompt} // $0;
813 $progname =~ s{^.*/}{}xms;
814
815 my $HINT = '[enter command line args here]';
816 $option{-prompt} = "> $progname $HINT\r> $progname ";
817
818 $option{-complete} = 'filenames';
819
820 my $not_first;
821 $option{-echo} = sub{
822 my $char = shift;
823 $option{-prompt} = "> $progname "; # Sneaky resetting to handle completions
824 return $char if $not_first++;
825 return "\r> $progname " . (q{ } x length $HINT) . "\r> $progname $char";
826 }
827 }
828 elsif (!defined $option{-prompt}) {
829 $option{-prompt} = '> ';
830 }
831 elsif ($option{-prompt} =~ m{ \S \z}xms) {
832 # If prompt doesn't end in whitespace, make it so...
833 $option{-prompt} .= ' ';
834 }
835 elsif ($option{-prompt} =~ m{ (.*) \n \z}xms) {
836 # If prompt ends in a newline, remove it...
837 $option{-prompt} = $1;
838 }
839
840 # Steal history set name if -h given without a specification...
841 $option{-history} //= $option{-prompt};
842
843 # Verify any default satisfies any constraints...
844 if (exists $option{-def} && !$option{-def_nocheck}) {
845 if (!_verify_input_constraints(\q{},undef,undef,\%option)) {
846 _warn( misc =>
847 'prompt(): -default value does not satisfy -must constraints'
848 );
849 }
850 }
851
852 return \%option;
853}
854
855#====[ Error Handlers ]=========================================
856
857sub _opt_err {
858 my ($problem, $option, $expectation) = @_;
859 Carp::croak "prompt(): $problem value for $option (expected $expectation)";
860}
861
862sub _warn {
863 my ($category, @message) = @_;
864
865 return if !warnings::enabled($category);
866
867 my $message = join(q{},@message);
868 warn $message =~ /\n$/ ? $message : Carp::shortmess($message);
869}
870
871
872#====[ Utility subroutines ]====================================
873
874# Return the *ARGV filehandle, "magic-opening" it if necessary...
875sub _open_ARGV {
876 if (!openhandle \*ARGV) {
877 $ARGV = shift @ARGV // '-';
878 open *ARGV or Carp::croak(qq{prompt(): Can't open *ARGV: $!});
879 }
880 return \*ARGV;
881}
882
88312µs1600nsmy $INTEGER_PAT = qr{ \A \s*+ [+-]?+ \d++ (?: [Ee] \+? \d+ )? \s*+ \Z }xms;
# spent 600ns making 1 call to IO::Prompter::CORE:qr
884
8851900ns1200nsmy $NUMBER_PAT = qr{
# spent 200ns making 1 call to IO::Prompter::CORE:qr
886 \A \s*+ [+-]?+
887 (?:
888 \d++ (?: [.,] \d*+ )?
889 | [.,] \d++
890 )
891 (?: [eE] [+-]?+ \d++ )?
892 \s*+ \Z
893}xms;
894
895# Verify interactive constraints...
896sub _verify_input_constraints {
897 my ($input_ref, $local_fake_input_ref, $outputter_ref, $opt_ref, $extras)
898 = @_;
899
900 # Use default if appropriate (but short-circuit checks if -DEFAULT set)...
901 my $input = ${$input_ref};
902 if (${$input_ref} =~ m{^\R?$}xms && exists $opt_ref->{-def}) {
903 return 1 if $opt_ref->{-def_nocheck};
904 $input = $opt_ref->{-def}
905 }
906 chomp $input;
907
908 my $failed;
909 # Integer constraint is hard-coded...
910 if ($opt_ref->{-integer} && $input !~ $INTEGER_PAT) {
911 $failed = $opt_ref->{-prompt} . "(must be an integer) ";
912 }
913
914 # Numeric constraint is hard-coded...
915 if (!$failed && $opt_ref->{-number} && $input !~ $NUMBER_PAT) {
916 $failed = $opt_ref->{-prompt} . "(must be a number) ";
917 }
918
919 # Sort and clean up -must list...
920 my $must_ref = $opt_ref->{-must} // {};
921 my @must_keys = sort keys %{$must_ref};
922 my %clean_key_for = map { $_ => (/^\d+[.:]?\s*(.*)/s ? $1 : $_) } @must_keys;
923 my @must_kv_list = map { $clean_key_for{$_} => $must_ref->{$_} } @must_keys;
924
925 # Combine -yesno and -must constraints...
926 my %constraint_for = (
927 %{ $extras // {} },
928 %{ $opt_ref->{-yesno}{must} // {} },
929 @must_kv_list,
930 );
931 my @constraints = (
932 keys %{ $extras // {} },
933 keys %{ $opt_ref->{-yesno}{must} // {} },
934 @clean_key_for{@must_keys},
935 );
936
937 # User-specified constraints...
938 if (!$failed && keys %constraint_for) {
939 CONSTRAINT:
940 for my $msg (@constraints) {
941 my $constraint = $constraint_for{$msg};
9422150µs225µs
# spent 15µs (5+10) within IO::Prompter::BEGIN@942 which was called: # once (5µs+10µs) by main::BEGIN@24 at line 942
next CONSTRAINT if eval { no warnings; local $_ = $input; $input ~~ $constraint; };
# spent 15µs making 1 call to IO::Prompter::BEGIN@942 # spent 10µs making 1 call to warnings::unimport
943 $failed = $msg =~ m{\A [[:upper:]] }xms ? "$msg "
944 : $msg =~ m{\A \W }xms ? $opt_ref->{-prompt}
945 . "$msg "
946 : $opt_ref->{-prompt}
947 . "(must $msg) "
948 ;
949 last CONSTRAINT;
950 }
951 }
952
953 # If any constraint not satisfied...
954 if ($failed) {
955 # Return failure if not actually prompting at the moment...
956 return 0 if !$outputter_ref;
957
958 # Redraw post-menu prompt with failure message appended...
959 $failed =~ s{.*$MENU_MK}{}xms;
960 $outputter_ref->(-style => _wipe_line(), $failed);
961
962 # Reset input collector...
963 ${$input_ref} = q{};
964
965 # Reset faked input, if any...
966 if (defined $fake_input && length($fake_input) > 0) {
967 $fake_input =~ s{ \A (.*) \R? }{}xm;
968 ${$local_fake_input_ref} = $1;
969 }
970
9712316µs222µs
# spent 13µs (4+9) within IO::Prompter::BEGIN@971 which was called: # once (4µs+9µs) by main::BEGIN@24 at line 971
no warnings 'exiting';
# spent 13µs making 1 call to IO::Prompter::BEGIN@971 # spent 9µs making 1 call to warnings::unimport
972 next INPUT;
973 }
974
975 # Otherwise succeed...
976 return 1;
977}
978
979# Build a sub to read from specified filehandle, with or without timeout...
980sub _generate_buffered_reader_from {
981 my ($in_fh, $outputter_ref, $opt_ref) = @_;
982
983 # Set-up for timeouts...
984 my $fileno = fileno($in_fh) // -1;
985 my $has_timeout = exists $opt_ref->{-timeout} && $fileno >= 0;
986 my $timeout = $opt_ref->{-timeout};
987 my $readbits = q{};
988 if ($has_timeout && $fileno >= 0) {
989 vec($readbits,$fileno,1) = 1;
990 }
991
992 # Set up local faked input, if any...
993 my $local_fake_input;
994 my $orig_fake_input;
995 if (defined $fake_input && length($fake_input) > 0) {
996 $fake_input =~ s{ \A (.*) \R? }{}xm;
997 $orig_fake_input = $local_fake_input = $1;
998 }
999
1000 return sub {
1001 my ($extra_constraints) = @_;
1002
1003 INPUT:
1004 while (1) {
1005 if (!$has_timeout || select $readbits, undef, undef, $timeout) {
1006 my $input;
1007
1008 # Real input comes from real filehandles...
1009 if (!defined $local_fake_input) {
1010 $input = readline $in_fh;
1011 }
1012 # Fake input has to be typed...
1013 else {
1014 $input = $local_fake_input;
1015 sleep 1;
1016 for ($local_fake_input =~ m/\X/g) {
1017 _simulate_typing();
1018 $outputter_ref->(-echostyle => $opt_ref->{-echo}($_));
1019 }
1020 readline $in_fh;
1021
1022 # Check for simulated EOF...
1023 if ($input =~ m{^ \s* (?: \cD | \cZ ) }xms) {
1024 $input = undef;
1025 }
1026 }
1027
1028 if (defined $input) {
1029 _verify_input_constraints(
1030 \$input, \$local_fake_input, $outputter_ref, $opt_ref, $extra_constraints
1031 );
1032 }
1033
1034 return defined $input && $opt_ref->{-single}
1035 ? substr($input, 0, 1)
1036 : $input;
1037 }
1038 else {
1039 return;
1040 }
1041 }
1042 }
1043}
1044
1045sub _autoflush {
1046 my ($fh) = @_;
1047 my $prev_selected = select $fh;
1048 $| = 1;
1049 select $prev_selected;
1050 return;
1051}
1052
1053sub _simulate_typing {
1054 state $TYPING_SPEED = 0.07; # seconds per character
1055 select undef, undef, undef, rand $TYPING_SPEED;
1056}
1057
1058sub _term_width {
10592482µs224µs
# spent 16µs (8+8) within IO::Prompter::BEGIN@1059 which was called: # once (8µs+8µs) by main::BEGIN@24 at line 1059
my ($term_width) = eval { no warnings 'deprecated'; Term::ReadKey::GetTerminalSize(\*STDERR) };
# spent 16µs making 1 call to IO::Prompter::BEGIN@1059 # spent 8µs making 1 call to warnings::unimport
1060 return $term_width // $DEFAULT_TERM_WIDTH;
1061}
1062
1063sub _wipe_line {
1064 return qq{\r} . q{ } x (_term_width()-1) . qq{\r};
1065}
1066
1067# Convert a specification into a list of possible completions...
1068sub _current_completions_for {
1069 my ($input_text, $opt_ref) = @_;
1070 my $completer = $opt_ref->{-complete};
1071
1072 # Isolate the final whitespace-separated word...
1073 my ($prefix, $lastword)
1074 = $input_text =~ m{
1075 (?| ^ (.*\s+) (.*)
1076 | ^ () (.*)
1077 )
1078 }xms;
1079
1080 # Find candidates...
1081 my @candidates;
1082 given (ref($completer) || $completer // q{}) {
1083 # If completer is sub, recursively call it with input words...
1084 when ('CODE') {
1085 ($prefix, @candidates)
1086 = _current_completions_for(
1087 $input_text,
1088 { %{$opt_ref},
1089 -complete => $completer->(split /\s+/, $input_text, -1)
1090 }
1091 );
1092 }
1093
1094 # If completer is array, grep the appropriate elements...
1095 when ('ARRAY') {
1096 @candidates = grep { /\A\Q$lastword\E/ } @{$completer};
1097 }
1098
1099 # If completer is hash, grep the appropriate keys...
1100 when ('HASH') {
1101 @candidates = grep { /\A\Q$lastword\E/ } keys %{$completer};
1102 }
1103
1104 # If completer is 'file...', glob up the appropriate filenames...
1105 when (/^file\w*$/) {
1106 @candidates = glob($lastword.'*');
1107 }
1108
1109 # If completer is 'dir...', glob up the appropriate directories...
1110 when (/^dir\w*$/) {
1111 @candidates = grep {-d} glob($lastword.'*');
1112 }
1113 }
1114
1115 chomp @candidates;
1116 return ($prefix, @candidates);
1117}
1118
1119
1120sub _current_history_for {
1121 my ($prefix, $opt_ref) = @_;
1122
1123 my $prefix_len = length($prefix);
1124 return q{}, map { /\A (.*?) \R \Z/x ? $1 : $_ }
1125 grep { substr($_,0,$prefix_len) eq $prefix }
1126 @{ $history_cache{$opt_ref->{-history}} };
1127}
1128
1129sub _longest_common_prefix_for {
1130 my $prefix = shift @_;
1131 for my $comparison (@_) {
1132 ($comparison ^ $prefix) =~ m{ \A (\0*) }xms;
1133 my $common_length = length($1);
1134 return q{} if !$common_length;
1135 $prefix = substr($prefix, 0, $common_length);
1136 }
1137 return $prefix;
1138}
1139
1140sub _display_completions {
1141 my ($input, @candidates) = @_;
1142
1143 return q{} if @candidates <= 1;
1144
1145 # How big is each field in the table?
1146 my $field_width
1147 = _term_width() / $COMPLETE_DISPLAY_FIELDS - $COMPLETE_DISPLAY_GAP;
1148
1149 # Crop the possibilities intelligently to that width...
1150 for my $candidate (@candidates) {
1151 substr($candidate, 0, length($input)) =~ s{ \A .* [/\\] }{}xms;
1152 $candidate
1153 = sprintf "%-*s", $field_width, substr($candidate,0,$field_width);
1154 }
1155
1156 # Collect them into rows...
1157 my $display = "\n";
1158 my $gap = q{ } x $COMPLETE_DISPLAY_GAP;
1159 while (@candidates) {
1160 $display .= $gap
1161 . join($gap, splice(@candidates, 0, $COMPLETE_DISPLAY_FIELDS))
1162 . "\n";
1163 }
1164
1165 return $display;
1166}
1167
1168sub _generate_unbuffered_reader_from {
1169 my ($in_fh, $outputter_ref, $opt_ref) = @_;
1170
11712161µs225µs
# spent 17µs (8+9) within IO::Prompter::BEGIN@1171 which was called: # once (8µs+9µs) by main::BEGIN@24 at line 1171
my $has_readkey = eval { no warnings 'deprecated'; require Term::ReadKey };
# spent 17µs making 1 call to IO::Prompter::BEGIN@1171 # spent 9µs making 1 call to warnings::unimport
1172
1173 # If no per-character reads, fall back on buffered input...
1174 if (!-t $in_fh || !$has_readkey) {
1175 return _generate_buffered_reader_from($in_fh, $outputter_ref, $opt_ref);
1176 }
1177
1178 # Adapt to local control characters...
1179 my %ctrl = eval { Term::ReadKey::GetControlChars($in_fh) };
1180 delete $ctrl{$_} for grep { $ctrl{$_} eq "\cA" } keys %ctrl;
1181
1182 $ctrl{EOF} //= "\4";
1183 $ctrl{INTERRUPT} //= "\3";
1184 $ctrl{ERASE} //= $^O eq 'MSWin32' ? "\10" : "0177";
1185
1186 my $ctrl = join '|', values %ctrl;
1187
1188 my $VERBATIM_KEY = $ctrl{QUOTENEXT} // $DEFAULT_VERBATIM_KEY;
1189
1190 # Translate timeout for ReadKey (with 32-bit MAXINT workaround for Windows)...
1191 my $timeout = !defined $opt_ref->{-timeout} ? 0x7FFFFFFF # 68 years
1192 : $opt_ref->{-timeout} == 0 ? -1
1193 : $opt_ref->{-timeout}
1194 ;
1195
1196 return sub {
1197 my ($extra_constraints) = @_;
1198
1199 # Short-circuit on unreadable filehandle...
1200 return if !openhandle($in_fh);
1201
1202 # Set up direct reading, and prepare to clean up on abnormal exit...
1203 Term::ReadKey::ReadMode('raw', $in_fh);
1204 my $prev_SIGINT = $SIG{INT};
1205 local $SIG{INT} = sub { given ($prev_SIGINT) {
1206 when ('IGNORE') { }
1207 Term::ReadKey::ReadMode('restore', $in_fh);
1208 when ('DEFAULT') { exit(1) }
1209 when (undef) { exit(1) }
1210 default {
1211 package main;
121221.85ms217µs
# spent 12µs (7+5) within main::BEGIN@1212 which was called: # once (7µs+5µs) by main::BEGIN@24 at line 1212
no strict 'refs';
# spent 12µs making 1 call to main::BEGIN@1212 # spent 5µs making 1 call to strict::unimport
1213 $prev_SIGINT->()
1214 }
1215 }
1216 };
1217
1218 # Set up local faked input, if any...
1219 my $local_fake_input;
1220 my $orig_fake_input;
1221 if (defined $fake_input && length($fake_input) > 0) {
1222 $fake_input =~ s{ \A (.*) \R? }{}xm;
1223 $orig_fake_input = $local_fake_input = $1;
1224 }
1225
1226 my $input = q{};
1227 my $insert_offset = 0;
1228 INPUT:
1229 while (1) {
1230 state $prev_was_verbatim = 0;
1231 state $completion_level = 0;
1232 state $completion_type = q{};
1233
1234 # Get next character entered...
1235 my $next = Term::ReadKey::ReadKey($timeout, $in_fh);
1236
1237 # Finished with completion mode?
1238 if (($next//q{}) !~ m{ $COMPLETE_INIT | $COMPLETE_CYCLE }xms) {
1239 $completion_level = 0;
1240 $completion_type = q{};
1241 }
1242
1243 # Are we faking input?
1244 my $faking = defined $local_fake_input;
1245
1246 # If not EOF...
1247 if (defined $next) {
1248 # Remember where we were parked...
1249 my $prev_insert_offset = $insert_offset;
1250
1251 # Handle interrupts...
1252 if ($next eq $ctrl{INTERRUPT}) {
1253 $SIG{INT}();
1254 next INPUT;
1255 }
1256
1257 # Handle verbatim quoter...
1258 elsif (!$prev_was_verbatim && $next eq $VERBATIM_KEY) {
1259 $prev_was_verbatim = 1;
1260 next INPUT;
1261 }
1262
1263 # Handle completions...
1264 elsif (!$prev_was_verbatim
1265 && ( $next =~ $COMPLETE_INIT
1266 || $completion_level > 0 && $next =~ $COMPLETE_CYCLE
1267 )
1268 ) {
1269 state @completion_list; # ...all candidates for completion
1270 state @completion_ring; # ..."next" candidate cycle
1271 state $completion_ring_first; # ...special case first time
1272 state $completion_prefix; # ...skipped before completing
1273
1274 # Track completion type and level (switch if necessary)...
1275 if ($next =~ $COMPLETE_INIT && index($completion_type, $next) < 0) {
1276 $completion_type = index($COMPLETE_KEY, $next) >= 0 ? $COMPLETE_KEY : $COMPLETE_HIST;
1277 $completion_level = 1;
1278 }
1279 else {
1280 $completion_level++;
1281 }
1282
1283 # If starting completion, cache completions...
1284 if ($completion_level == 1) {
1285 ($completion_prefix, @completion_list)
1286 = index($COMPLETE_KEY, $next) >= 0
1287 ? _current_completions_for($input, $opt_ref)
1288 : _current_history_for($input, $opt_ref);
1289 @completion_ring = (@completion_list, q{});
1290 $completion_ring_first = 1;
1291 }
1292
1293 # Can only complete if there are completions to be had...
1294 if (@completion_list) {
1295 # Select the appropriate mode...
1296 my $mode = $COMPLETE_MODE{$completion_type}[$completion_level-1]
1297 // $COMPLETE_MODE{$completion_type}[-1];
1298
1299 # 'longest mode' finds longest consistent prefix...
1300 if ($mode =~ /longest/) {
1301 $input
1302 = $completion_prefix
1303 . _longest_common_prefix_for(@completion_list);
1304 }
1305 # 'full mode' suggests next full match...
1306 elsif ($mode =~ /full/) {
1307 if (!$completion_ring_first) {
1308 if ($next eq $COMPLETE_PREV) {
1309 unshift @completion_ring,
1310 pop @completion_ring;
1311 }
1312 else {
1313 push @completion_ring,
1314 shift @completion_ring;
1315 }
1316 }
1317 $input = $completion_prefix . $completion_ring[0];
1318 $completion_ring_first = 0;
1319 }
1320 # 'list mode' lists all possibilities...
1321 my $list_display = $mode =~ /list/
1322 ? _display_completions($input, @completion_list)
1323 : q{};
1324
1325 # Update prompt with selected completion...
1326 $outputter_ref->( -style =>
1327 $list_display,
1328 _wipe_line(),
1329 $opt_ref->{-prompt}, $input
1330 );
1331
1332 # If last completion was unique choice, completed...
1333 if (@completion_list <= 1) {
1334 $completion_level = 0;
1335 }
1336 }
1337 next INPUT;
1338 }
1339
1340 # Handle erasures (including pushbacks if faking)...
1341 elsif (!$prev_was_verbatim && $next eq $ctrl{ERASE}) {
1342 if (!length $input) {
1343 # Do nothing...
1344 }
1345 elsif ($insert_offset) {
1346 # Can't erase past start of input...
1347 next INPUT if $insert_offset >= length($input);
1348
1349 # Erase character just before cursor...
1350 substr($input, -$insert_offset-1, 1, q{});
1351
1352 # Redraw...
1353 my $input_pre = substr($input.' ',0,length($input)-$insert_offset+1);
1354 my $input_post = substr($input.' ',length($input)-$insert_offset);
1355 my $display_pre
1356 = join q{}, map { $opt_ref->{-echo}($_) } $input_pre =~ m/\X/g;
1357 my $display_post
1358 = join q{}, map { $opt_ref->{-echo}($_) } $input_post =~ m/\X/g;
1359 $outputter_ref->( -echostyle =>
1360 "\b" x length($display_pre)
1361 . join(q{}, map { $opt_ref->{-echo}($_) } $input =~ m/\X/g)
1362 . q{ } x length($opt_ref->{-echo}(q{ }))
1363 . "\b" x length($display_post)
1364 );
1365 }
1366 else {
1367 my $erased = substr($input, -1, 1, q{});
1368 if ($faking) {
1369 substr($local_fake_input,0,0,$erased);
1370 }
1371 $outputter_ref->( -nostyle =>
1372 map { $_ x (length($opt_ref->{-echo}($_)//'X')) }
1373 "\b", ' ', "\b"
1374 );
1375 }
1376 next INPUT;
1377 }
1378
1379 # Handle EOF (including cancelling any remaining fake input)...
1380 elsif (!$prev_was_verbatim && $next eq $ctrl{EOF}) {
1381 Term::ReadKey::ReadMode('restore', $in_fh);
1382 close $in_fh;
1383 undef $fake_input;
1384 return length($input) ? $input : undef;
1385 }
1386
1387 # Handle escape from faking...
1388 elsif (!$prev_was_verbatim && $faking && $next eq $FAKE_ESC) {
1389 my $lookahead = Term::ReadKey::ReadKey(0, $in_fh);
1390
1391 # Two <ESC> implies the current faked line is deferred...
1392 if ($lookahead eq $FAKE_ESC) {
1393 $fake_input =~ s{ \A }{$orig_fake_input\n}xm;
1394 }
1395 # Only one <ESC> implies the current faked line is replaced...
1396 else {
1397 $in_fh->ungetc(ord($lookahead));
1398 }
1399 undef $local_fake_input;
1400 $faking = 0;
1401 next INPUT;
1402 }
1403
1404 # Handle returns...
1405 elsif (!$prev_was_verbatim && $next =~ /\A\R\z/) {
1406 # Complete faked line, if faked input incomplete...
1407 if ($faking && length($local_fake_input)) {
1408 for ($local_fake_input =~ m/\X/g) {
1409 _simulate_typing();
1410 $outputter_ref->(-echostyle => $opt_ref->{-echo}($_));
1411 }
1412 $input .= $local_fake_input;
1413 }
1414
1415 # Add newline to the accumulated input string...
1416 $input .= $next;
1417
1418 # Check that input satisfied any constraints...
1419 _verify_input_constraints(
1420 \$input, \$local_fake_input, $outputter_ref,
1421 $opt_ref, $extra_constraints,
1422 );
1423
1424 # Echo a default value if appropriate...
1425 if ($input =~ m{\A\R?\Z}xms && defined $opt_ref->{-def}) {
1426 my $def_val = $opt_ref->{-def};
1427
1428 # Try to find the key, for a menu...
1429 if (exists $opt_ref->{-menu_curr_level}) {
1430 for my $key ( keys %{$opt_ref->{-menu_curr_level}}) {
1431 if ($def_val ~~ $opt_ref->{-menu_curr_level}{$key}) {
1432 $def_val = $key;
1433 last;
1434 }
1435 }
1436 }
1437
1438 # Echo it as if it had been typed...
1439 $outputter_ref->(-echostyle => $opt_ref->{-echo}($def_val));
1440 }
1441
1442 # Echo the return (or otherwise, as specified)...
1443 $outputter_ref->(-echostyle => $opt_ref->{-return}($next));
1444
1445 # Clean up, and return the input...
1446 Term::ReadKey::ReadMode('restore', $in_fh);
1447
1448 # Handle fake EOF...
1449 if ($faking && $input =~ m{^ (?: \cD | \cZ) }xms) {
1450 return undef;
1451 }
1452
1453 return $input;
1454 }
1455
1456 # Handle anything else...
1457 elsif ($prev_was_verbatim || $next !~ /$ctrl/) {
1458 # If so, get the next fake character...
1459 if ($faking) {
1460 $next = length($local_fake_input)
1461 ? substr($local_fake_input,0,1,q{})
1462 : q{};
1463 }
1464
1465 # Handle editing...
1466 if ($next eq $EDIT{BACK}) {
1467 $insert_offset += ($insert_offset < length $input) ? 1 : 0;
1468 }
1469 elsif ($next eq $EDIT{FORWARD}) {
1470 $insert_offset += ($insert_offset > 0) ? -1 : 0;
1471 }
1472 elsif ($next eq $EDIT{START}) {
1473 $insert_offset = length($input);
1474 }
1475 elsif ($next eq $EDIT{END}) {
1476 $insert_offset = 0;
1477 }
1478
1479 # Handle non-editing...
1480 else {
1481 # Check for input restrictions...
1482 if (exists $opt_ref->{-guarantee}) {
1483 next INPUT if ($input.$next) !~ $opt_ref->{-guarantee};
1484 }
1485
1486 # Add the new input char to the accumulated input string...
1487 if ($insert_offset) {
1488 substr($input, -$insert_offset, 0) = $next;
1489 $prev_insert_offset++;
1490 }
1491 else {
1492 $input .= $next;
1493 }
1494 }
1495
1496 # Display the character (or whatever was specified)...
1497
1498 if ($insert_offset || $prev_insert_offset) {
1499 my $input_pre = substr($input,0,length($input)-$prev_insert_offset);
1500 my $input_post = substr($input,length($input)-$insert_offset);
1501 my $display_pre
1502 = join q{}, map { $opt_ref->{-echo}($_) } $input_pre =~ m/\X/g;
1503 my $display_post
1504 = join q{}, map { $opt_ref->{-echo}($_) } $input_post =~ m/\X/g;
1505 $outputter_ref->( -echostyle =>
1506 "\b" x length($display_pre)
1507 . join(q{}, map { $opt_ref->{-echo}($_) } $input =~ m/\X/g)
1508 . "\b" x length($display_post)
1509 );
1510 }
1511 elsif ($next !~ $EDIT_KEY) {
1512 $outputter_ref->(-echostyle => $opt_ref->{-echo}($next));
1513 }
1514
1515 # Not verbatim after this...
1516 $prev_was_verbatim = 0;
1517 }
1518 else {
1519 # Not verbatim after mysterious ctrl input...
1520 $prev_was_verbatim = 0;
1521
1522 next INPUT;
1523 }
1524 }
1525 if ($opt_ref->{-single} || !defined $next || $input =~ m{\Q$/\E$}) {
1526 # Did we get an acceptable value?
1527 if (defined $next) {
1528 _verify_input_constraints(
1529 \$input, \$local_fake_input, $outputter_ref,
1530 $opt_ref, $extra_constraints,
1531 );
1532 }
1533
1534 # Reset terminal...
1535 Term::ReadKey::ReadMode('restore', $in_fh);
1536
1537 # Return failure if failed before input...
1538 return undef if !defined $next && length($input) == 0;
1539
1540 # Otherwise supply a final newline if necessary...
1541 if ( $opt_ref->{-single}
1542 && exists $opt_ref->{-return}
1543 && $input !~ /\A\R\z/ ) {
1544 $outputter_ref->(-echostyle => $opt_ref->{-return}(q{}));
1545 }
1546
1547 return $input;
1548 }
1549 }
1550 }
1551}
1552
1553# Build a menu...
1554sub _build_menu {
1555 my ($source_ref, $initial_prompt, $is_numeric) = @_;
1556 my $prompt = ($initial_prompt//q{}) . qq{\n};
1557 my $final = q{};
1558 my %value_for;
1559 my %key_for;
1560 my @selectors;
1561
1562 given (ref $source_ref) {
1563 when ('HASH') {
1564 my @sorted_keys = sort(keys(%{$source_ref}));
1565 @selectors = $is_numeric ? (1..@sorted_keys) : ('a'..'z','A'..'Z');
1566 @key_for{@selectors} = @sorted_keys;
1567 @value_for{@selectors} = @{$source_ref}{@sorted_keys};
1568 $source_ref = \@sorted_keys;
1569 $_ = 'ARRAY';
1570 continue;
1571 }
1572 when ('SCALAR') {
1573 $source_ref = [ split "\n", ${$source_ref} ];
1574 $_ = 'ARRAY';
1575 continue;
1576 }
1577 when ('ARRAY') {
1578 my @source = @{$source_ref};
1579 @selectors = $is_numeric ? (1..@source) : ('a'..'z','A'..'Z');
1580 if (!keys %value_for) {
1581 @value_for{@selectors} = @source;
1582 }
1583 ITEM:
1584 for my $tag (@selectors) {
1585 my $item = shift(@source) // last ITEM;
1586 chomp $item;
1587 $prompt .= sprintf("%4s. $item\n", $tag);
1588 $final = $tag;
1589 }
1590 if (@source) {
1591 _warn( misc =>
1592 "prompt(): Too many menu items. Ignoring the final " . @source
1593 );
1594 }
1595 }
1596 }
1597
1598 my $constraint = $is_numeric ? '(?:' . join('|',@selectors) .')'
1599 : $final =~ /[A-Z]/ ? "[a-zA-$final]"
1600 : "[a-$final]";
1601 my $constraint_desc = $is_numeric ? "[1-$selectors[-1]]" : $constraint;
1602 $constraint = '\A\s*' . $constraint . '\s*\Z';
1603
1604 return {
1605 data => $source_ref,
1606 key_for => \%key_for,
1607 value_for => \%value_for,
1608 prompt => "$prompt\n",
1609 is_numeric => $is_numeric,
1610 constraint => { "Enter $constraint_desc: " => qr/$constraint|$MENU_ESC/ },
1611 };
1612}
1613
1614# Vocabulary that _stylize understands...
1615110µsmy %synonyms = (
1616 bold => [qw<boldly strong heavy emphasis emphatic highlight highlighted fort forte>],
1617 dark => [qw<darkly dim deep>],
1618 faint => [qw<faintly light soft>],
1619 underline => [qw<underlined underscore underscored italic italics>],
1620 blink => [qw<blinking flicker flickering flash flashing>],
1621 reverse => [qw<reversed inverse inverted>],
1622 concealed => [qw<hidden blank invisible>],
1623 reset => [qw<normal default standard usual ordinary regular>],
1624 bright_ => [qw< bright\s+ vivid\s+ >],
1625 red => [qw< scarlet vermilion crimson ruby cherry cerise cardinal carmine
1626 burgundy claret chestnut copper garnet geranium russet
1627 salmon titian coral cochineal rose cinnamon ginger gules >],
1628 yellow => [qw< gold golden lemon cadmium daffodil mustard primrose tawny
1629 amber aureate canary champagne citrine citron cream goldenrod honey straw >],
1630 green => [qw< olive jade pea emerald lime chartreuse forest sage vert >],
1631 cyan => [qw< aqua aquamarine teal turquoise ultramarine >],
1632 blue => [qw< azure cerulean cobalt indigo navy sapphire >],
1633 magenta => [qw< amaranthine amethyst lavender lilac mauve mulberry orchid periwinkle
1634 plum pomegranate violet purple aubergine cyclamen fuchsia modena puce
1635 purpure >],
1636 black => [qw< charcoal ebon ebony jet obsidian onyx raven sable slate >],
1637 white => [qw< alabaster ash chalk ivory milk pearl silver argent >],
1638);
1639
1640# Back-mapping to standard terms...
1641my %normalize
1642159µs1711µs = map { join('|', map { "$_\\b" } reverse sort @{$synonyms{$_}}) => $_ }
# spent 11µs making 17 calls to IO::Prompter::CORE:sort, avg 635ns/call
1643 keys %synonyms;
1644
164512µs1500nsmy $BACKGROUND = qr{
# spent 500ns making 1 call to IO::Prompter::CORE:qr
1646 (\S+) \s+ (?: behind | beneath | below | under(?:neath)? )\b
1647 | \b (?:upon|over|on) \s+ (?:an?)? \s+ (.*?) \s+ (?:background|bg|field) \b
1648 | \b (?:upon\s+ | over\s+ | (?:(on|upon|over)\s+a\s+)? (?:background|bg|field) \s+ (?:of\s+|in\s+)? | on\s+) (\S+)
1649}ixms;
1650
1651# Convert a description to ANSI colour codes...
1652sub _stylize {
1653 my $spec = shift // q{};
1654
1655 # Handle arrays and hashes as args...
1656 if (ref($spec) eq 'ARRAY') {
1657 $spec = join q{ }, @{$spec};
1658 }
1659 elsif (ref($spec) eq 'HASH') {
1660 $spec = join q{ }, keys %{$spec};
1661 }
1662
1663 # Ignore punctuation...
1664 $spec =~ s/[^\w\s]//g;
1665
1666 # Handle backgrounds...
1667 $spec =~ s/$BACKGROUND/on_$+/g;
1668
1669 # Apply standard translations...
1670 for my $pattern (keys %normalize) {
1671 $spec =~ s{\b(on_|\b) $pattern}{($1//q{}).$normalize{$pattern}}geixms;
1672 }
1673
1674 # Ignore anything unknown...
1675 $spec =~ s{((?:on_)?(\S+))}{ exists $synonyms{$2} ? $1 : q{} }gxmse;
1676
1677 # Build ANSI terminal codes around text...
1678 my $raw_text = join q{}, @_;
1679 my ($prews, $text, $postws) = $raw_text =~ m{\A (\s*) (.*?) (\s*) \Z}xms;
1680 my @style = split /\s+/, $spec;
1681 return $prews
1682 . ( @style ? Term::ANSIColor::colored(\@style, $text) : $text )
1683 . $postws;
1684}
1685
1686# Build a subroutine that prints printable chars to the specified filehandle...
1687sub _std_printer_to {
1688 my ($out_filehandle, $opt_ref) = @_;
16892224µs217µs
# spent 12µs (7+5) within IO::Prompter::BEGIN@1689 which was called: # once (7µs+5µs) by main::BEGIN@24 at line 1689
no strict 'refs';
# spent 12µs making 1 call to IO::Prompter::BEGIN@1689 # spent 5µs making 1 call to strict::unimport
1690 _autoflush($out_filehandle);
1691 if (eval { require Term::ANSIColor}) {
1692 return sub {
1693 my $style = shift;
1694 my @loc = (@_);
1695 s{\e}{^}gxms for @loc;
1696 print {$out_filehandle} _stylize($opt_ref->{$style}(@loc), @loc);
1697 };
1698 }
1699 else {
1700 return sub {
1701 shift; # ...ignore style
1702 my @loc = (@_);
1703 s{\e}{^}gxms for @loc;
1704 print {$out_filehandle} @loc;
1705 };
1706 }
1707}
1708
1709# Build a subroutine that prints to nowhere...
1710sub _null_printer {
1711 return sub {};
1712}
1713
1714126µs1; # Magic true value required at end of module
1715__END__
 
# spent 4µs within IO::Prompter::CORE:qr which was called 7 times, avg 614ns/call: # once (2µs+0s) by main::BEGIN@24 at line 29 # once (700ns+0s) by main::BEGIN@24 at line 53 # once (600ns+0s) by main::BEGIN@24 at line 883 # once (500ns+0s) by main::BEGIN@24 at line 1645 # once (400ns+0s) by main::BEGIN@24 at line 59 # once (300ns+0s) by main::BEGIN@24 at line 30 # once (200ns+0s) by main::BEGIN@24 at line 885
sub IO::Prompter::CORE:qr; # opcode
# spent 13µs within IO::Prompter::CORE:regcomp which was called 2 times, avg 6µs/call: # once (8µs+0s) by main::BEGIN@24 at line 29 # once (5µs+0s) by main::BEGIN@24 at line 30
sub IO::Prompter::CORE:regcomp; # opcode
# spent 14µs within IO::Prompter::CORE:sort which was called 18 times, avg 767ns/call: # 17 times (11µs+0s) by main::BEGIN@24 at line 1642, avg 635ns/call # once (3µs+0s) by main::BEGIN@24 at line 398
sub IO::Prompter::CORE:sort; # opcode
Report produced by the NYTProf 6.12 Perl profiler, developed by Tim Bunce based on work by Adam Kaplan and Salvador Fandiño García.