File Coverage

blib/lib/Shell/POSIX/Select.pm

Criterion	Covered	Total	%
statement	262	366	71.5
branch	110	292	37.6
condition	40	146	27.4
subroutine	20	27	74.0
pod	0	16	0.0
total	432	847	51.0

line	stmt	bran	cond	sub	pod	time	code
1							package Shell::POSIX::Select;
2
3							our $VERSION = '0.08';
4
5							# TODO: Portable-ize tput stuff
6
7							# TODO: Dump user's code-block with same line numbers shown in error
8							# messages for debugging ease
9
10							# TODO: Add option to embolden menu numbers, to distinguish them from
11							# choices that are also numbers
12
13							# See documentation and copyright notice below =pod section below
14
15							# Not using Exporter.pm; doing typeglob-based exporting,
16							# using adapted code from Damian's Switch.pm
17							our ( @EXPORT_OK );
18							our ($Reply, $Heading, $Prompt);
19							@EXPORT_OK = qw( $Heading $Prompt $Reply $Eof );
20
21							our ( $U_WARN, $REPORT, $DEBUG, $DEBUG_default, $_DEBUG, );
22							our ( $U_WARN_default, $_import_called, $U_DEBUG, $DEBUG_FILT );
23							our ( $sdump, $cdump, $script );
24							#
25							our ( @ISA, @EXPORT, $PRODUCTION, $LOGGING, $PKG, $INSTALL_TESTING,$ON,$OFF, $BOLD, $SGR0, $COLS );
26
27							# What is the maximum number of columns that the user wants to see
28							# on-screen? By default, no maximum -- the number of columns will be
29							# determined by the width of the terminal and the length of the meny
30							# item strings.
31							our $MaxColumns = 99;
32							push @EXPORT_OK, '$MaxColumns';
33
34							BEGIN {
35	26			26		138	$PKG = __PACKAGE__ ;
36	26					72	$LOGGING = 0;
37
38							$SIG{TERM}=$SIG{QUIT}=$SIG{INT}= sub {
39	0	0				0	$DEBUG and warn caller(1), "\n";
40							# must disable reverse-video, if it was turned on
41	0	0	0			0	defined $ON and $ON ne "" and do {
42	0	0	0			0	my $reset=($SGR0 \|\| $OFF); defined $reset and warn "$reset\n";
	0					0
43							};
44	0	0				0	$DEBUG and warn "$0: killed by signal\n";
45	0					0	exit 111; # means, killed by signal
46	26					1129	};
47	26	50				180	! defined $_import_called and $_import_called = 0;
48	26					1484	( $script = $0 ) =~ s\|^.*/\|\|;
49
50							}
51
52							sub import ; # advance declaration
53
54	26			26		11828	use File::Spec::Functions (':ALL');
	26					31045
	26					7294
55
56	26			26		252	use File::Spec::Functions 0.7;
	26					818
	26					3373
57	26			26		11812	use Filter::Simple 0.84;
	26					736347
	26					249
58
59							# Damian's been fixing bugs as I report them, so best to have recent version
60							# This is the oldest version that I know works pretty well
61	26			26		2523	use Text::Balanced 1.97 qw(extract_variable extract_bracketed);
	26					634
	26					1873
62
63	26			26		221	use Carp;
	26					86
	26					12663
64
65							$U_DEBUG=1;
66							$U_DEBUG=0;
67
68							$DEBUG_FILT=4;
69							# $DEBUG_FILT=0;
70
71							$DEBUG=1; # force verbosity level for debugging messages
72							# $DEBUG=0; # force verbosity level for debugging messages
73
74							$REPORT=1; # report subroutines when entered
75							# $REPORT=0; # report subroutines when entered
76
77							$DEBUG > 0 and warn "Logging is $LOGGING\n";
78
79							# controls messages and carp vs. warn (but that doesn't do much)
80							$PRODUCTION=1;
81							$PRODUCTION and $REPORT=$DEBUG_FILT=$DEBUG=0;
82
83							$DEBUG and disable_buffering();
84
85							sub _WARN; sub _DIE;
86
87							local $_; # avoid clobbering user's by accident
88
89
90							$Shell::POSIX::Select::_default_style='K'; # default loop-style is Kornish
91							$Shell::POSIX::Select::_default_prompt= "\nEnter number of choice:";
92							# I detest the shell's default prompt!
93							$Shell::POSIX::Select::_bash_prompt ='#?';
94							$Shell::POSIX::Select::_korn_prompt='#?';
95							$Shell::POSIX::Select::_generic ='#?';
96							$Shell::POSIX::Select::_arrows_prompt='>>';
97
98							$U_WARN_default = 1; # for enabling user-warnings for bad interactive input
99
100							# $_import_called > 0 or import(); # ensure initialization of defaults
101
102							my $subname=__PACKAGE__ ; # for identifying messages from outside sub's
103
104							my $select2foreach;
105							$select2foreach=1; # just translate select into foreach, for debugging
106							$select2foreach=0;
107
108							# warn "Setting up video modes\n";
109							# I know about Term::Cap, but this seems more direct and sufficient
110
111							$Shell::POSIX::Select::_FILTER_CALLS= $Shell::POSIX::Select::_ENLOOP_CALL_COUNT= $Shell::POSIX::Select::_LOOP_COUNT=0;
112							# Number of select loops detected
113							$DEBUG > 3 and $LOGGING and warn "About to call log_files\n";
114
115							$LOGGING and log_files(); # open logfiles, depending on DEBUG setting
116
117							$DEBUG >2 and warn "Import_called initially set to: $_import_called\n";
118
119							FILTER_ONLY
120							code_no_comments => \&filter,
121							all => sub { $LOGGING and print SOURCE };
122
123							$DEBUG >2 and warn "Import_called set to: $_import_called\n";
124							$DEBUG >2 and $Shell::POSIX::Select::_testmode and warn "testmode is $Shell::POSIX::Select::_testmode";
125
126	26			26		252	use re 'eval';
	26					81
	26					197259
127
128							# Scope for declaration of pre-compiled REs:
129							{
130							my $RE_kw1 = qr^
131							(\bselect\b)
132							^x; # extended-syntax, allowing comments, etc.
133
134							my $RE_kw2 = qr^
135							\G(\bselect\b)
136							^x; # extended-syntax, allowing comments, etc.
137
138							my $RE_decl = qr^
139							(\s*
140							# grab declarator if there
141							(?: \b my \b\| \b local \b\| \b our \b )
142							\s*)
143							^x; # extended-syntax, allowing comments, etc.
144
145							my $RE_kw_and_decl = qr^
146							\bselect\b
147							\s*
148							( # Next, grab optional declarator and varname if there
149							(?: \b my \b\| \b local \b\| \b our \b )?
150							\s*
151							)?
152							^x; # extended-syntax, allowing comments, etc.
153
154
155							my $RE_list = qr^
156							\s*
157							(
158							# $RE{balanced}{-parens=>'()'}
159							)
160							^x; # extended-syntax, allowing comments, etc.
161
162							my $RE_block = qr^
163							\s*
164							# Is following really beneficial/necessary? I think I needed it in one case - tfm
165							(?= { ) # ensure opposite of } comes next
166							(
167							# now find the code-block
168							# $RE{balanced}{-parens=>'{}'}
169							)
170							^x; # extended-syntax, allowing comments, etc.
171
172							sub matches2fields;
173							sub enloop_codeblock;
174
175							sub filter {
176	28			28	0	487221	my $subname = sub_name();
177	28					102	my $last_call = 0;
178	28					100	my $orig_string=$_;
179	28					93	my $detect_msg='';
180
181	28					90	++$::_FILTER_CALLS;
182
183	28	50				162	$orig_string ne $_ and die "$_ got trashed";
184
185							#/(..)/ and warn "Matched chars: '$1'\n"; # prime the pos marker
186
187	28					106	my $loopnum;
188							# Probably looping out of control if we get this many:
189	28					85	my $maxloops = 25;
190
191	28					74	my $first_celador;
192	28	50				150	if ( $last_call = ($_ eq "") ) {
193	0					0	return undef ;
194							}
195							else {
196							# TIMJI: Revisit; why is following the default?
197	28					90	$detect_msg="SELECT LOOP DETECTED";
198	28	50				139	$orig_string ne $_ and die "$_ got trashed";
199
200
201	28	50				135	$DEBUG > 1 and show_subs("**** Pre-Pre-WHILE **** \n","");
202	28	0	33			124	$DEBUG > 1 and $LOGGING and print LOG "\$_ is '$_'\n";
203
204	28					79	$loopnum=0;
205	28	50				115	$DEBUG > 1 and show_subs("**** Pre-WHILE **** \n","");
206
207	28					147	while (++$loopnum <= $maxloops) { # keep looping until we can't find any more select loops
208
209	65	100				299	$loopnum == 2 and $first_celador=$_;
210
211	65	50				219	$DEBUG > 1 and show_subs("**** LOOKING FOR LOOP **** #$loopnum\n","");
212	65	50				220	$loopnum > 25 and warn "$subname: Might be stuck in loop\n";
213	65	50				220	$loopnum > 100 and die "$subname: Probably was stuck in loop\n";
214	65	50	33			266	$DEBUG > 3 and pos() and warn "pos is currently: ", pos(), "\n";
215	65					254	pos()=0;
216	65	50	0			476	/\S/ or $LOGGING and
217							print LOG "\$_ is all white space or else empty\n";
218
219							# /(..)/ and warn "Matched chars: '$1'\n"; # prime the pos marker
220
221	65					242	my ($matched, $can_rewrite) = 0;
222	65	50				258	if ($select2foreach) {
223							# simple conversion, for debugging basic ops
224							# change one word, and select loops with all pieces
225							# present are magically rendered syntactically acceptable
226							# NOTE: will break select() usage!
227	0	0				0	s/\bselect\b/foreach /g and $matched = -1;
228							# All these can be handled in one pass, so exit loop
229	0					0	goto FILTER_EXIT;
230							}
231							else {
232	65					150	my $pos;
233	65					372	my ($match, $start_match);
234	65					0	my ($got_kw,$got_decl, $got_loop_var, $got_list, $got_codeblock);
235	65					155	my $iteration=0;
236	68					213	FIND_LOOP:
237							my ($loop_var, $loop_decl, $loop_list, $loop_block)= ("" x 3);
238
239	68	50				240	$DEBUG_FILT > 0 and warn "Pos initially at ", pos($_), "\n";
240
241	68	50				315	!defined pos() and warn "AT FIND_LOOP, POS IS UNDEF\n";
242
243	68					239	$match=$got_kw=$got_decl=$got_loop_var=$got_list=$got_codeblock="";
244	68					146	my $matched=0; # means, currently no detected loops that still need replacement
245
246							# my $RE = ( $loopnum == 1 ? $RE_kw1 : $RE_kw2 ) ; # second version uses \G
247	68					145	my $RE = $RE_kw1 ; # always restart from the beginning, of incrementally modified program
248							# Same pattern good now, since pos() will have been reset by mod
249							# my $RE = ( $loopnum == 1 ? $RE_kw1 : $RE_kw1 ) ; # second version uses \G
250	68	100				1542	if ( m/$RE/g ) { # try to match keyword, "select"
251	40					144	++$matched ;
252	40					156	$match=$1;
253	40					166	$start_match=pos() - length $1;
254	40					212	$got_kw=1;
255	40	50				268	$DEBUG_FILT > 1 and show_progress($match, pos(), $_);
256							}
257							else {
258							# no more select keywords to process! # LOOP EXIT #1
259	28					2382	goto FILTER_EXIT;
260							}
261
262	40					144	$pos=pos(); # remember position
263
264	40	100				1291	if (/\G$RE_decl/g) {
265	11					45	++$matched ;
266	11					49	$loop_decl=$1;
267	11					45	$match.=" $1";
268	11					30	$got_decl=1;
269							}
270							else {
271	29					157	pos()=$pos; # reset to where we left off
272							}
273	40	50				209	$DEBUG_FILT > 1 and show_progress($match, pos(), $_);
274
275	40					106	my @rest;
276	40	50				263	$DEBUG_FILT > 0 and warn "POS before ext-var is now ", pos(), "\n";
277
278	40					229	( $loop_var, @rest ) = extract_variable( $_ );
279	40	50				10029	$DEBUG_FILT > 0 and show_subs( "POST- ext-var string is: ", $_, pos(),19);
280
281	40	50				236	$DEBUG_FILT > 0 and warn "POS after ext-var is now ", pos(), "\n";
282
283	40	100	66			297	if (defined $loop_var and $loop_var ne "" ) {
284	26					79	$got_loop_var=1;
285	26	50				197	$DEBUG_FILT > 0 and warn "Got_Loop_Var matched '$loop_var'\n";
286	26					136	$match.=" $loop_var";
287							}
288							else {
289	14					46	pos()=$pos; # reset to where we left off
290	14	50				214	$DEBUG_FILT > 0 and warn "extract_variable failed to match\n";
291							}
292	40	50				159	$DEBUG_FILT > 1 and show_progress($match, pos(), $_);
293
294	40					180	gobble_spaces();
295
296							# $DEBUG_FILT > 0 and warn "Pre-extract_bracketed ()\n";
297	40					202	( $loop_list, @rest ) = extract_bracketed($_, '()');
298	40	50	33			9249	if (defined $loop_list and $loop_list ne "") {
299	40					114	++$matched;
300	40					107	$got_list=1;
301	40					162	$match.=" $loop_list";
302	40	50				161	$DEBUG_FILT > 1 and show_progress($match, pos(), $_);
303							}
304							else { # no loop list; not our kind of select
305							# warn "extract_bracketed failed to match\n";
306							# If we didn't find loop var, they're probably using
307							# select() function or syscall, not select loop
308	0	0				0	if ($got_loop_var) {
309	0	0				0	$DEBUG_FILT > 3 and
310							warn "$PKG: Found keyword and loop variable, but no ( LIST )!\n",
311							;
312							# "If { } really there, try placing 'no $PKG;' after loop to fix.\n";
313							}
314							else {
315	0	0				0	$DEBUG_FILT > 3 and warn "$PKG: Found keyword, but no ( LIST )\n",
316							"Must be some other use of the word\n";
317							}
318	0	0				0	$DEBUG_FILT > 0 and warn "giving up on this match; scanning for next keyword (1)";
319	0	0				0	if (++$iteration < $maxloops) {
320	0					0	goto FIND_LOOP;
321							}
322							else {
323	0					0	_DIE "$PKG: Maximum iterations reached while looking for select loop #$loopnum";
324							}
325							} # else
326
327	40					158	gobble_spaces();
328
329							# $DEBUG > 1 and warn " DDD sending to extract_bracketed() ===$_===\n";
330	40					293	( $loop_block, @rest ) = extract_bracketed($_, '{}');
331							# $DEBUG > 1 and warn " DDD extract_bracketed returned ===$loop_block===\n";
332	40	100	66			14954	if (defined $loop_block and $loop_block ne "") {
333	37					104	++$matched;
334	37					103	$got_codeblock=1;
335	37					156	$match.=" $loop_block";
336	37	50				169	$DEBUG_FILT > 1 and show_progress($match, pos(), $_);
337							}
338							else {
339							# if $var there, can't possibly be select syscall or function use,
340							# so 100% sure there's a problem
341
342	3	50				12	if ($got_loop_var) {
343	0					0	warn "$PKG: Found loop variable and list, but no code-block!\n",
344							;
345							# "If { } really there, try placing 'no $PKG;' after loop to fix.\n";
346							}
347							else {
348	3	50				12	$DEBUG_FILT > 3 and warn "$PKG: Found keyword and list,",
349							" but no code-block\n",
350							"Must be some other use of the word\n";
351							}
352	3	50				11	$DEBUG_FILT > 0 and warn "giving up on this match; scanning for next keyword (2)";
353	3					30	goto FIND_LOOP;
354							}
355
356							# and print "list_and_block matched '$&'\n";
357							# defined $& and $match.=$&;
358							# defined $& and $match.="$1 $2";
359							#defined $& and ($loop_list, $loop_block) = ($1, $2);
360
361	37					96	my $end_match;
362	37	50				139	if ( $matched == 0 ) {
363	0					0	die" Can it ever get here?";
364	0					0	goto FILTER_EXIT;
365							}
366							else {
367	37					103	$end_match=pos();
368	37					100	$detect_msg='';
369	37	50				131	if ( $matched == 1 ) { # means "select" keyword only
370							;
371							}
372	37	50				262	if ( $matched == 2 ) { # means "select" plus decl, var, list, or block
		50
373	0					0	$detect_msg="select loop incomplete; ";
374	0	0				0	$got_list or $detect_msg.= "no (LIST) detected\n";
375	0	0				0	$got_codeblock or $detect_msg.= "no {CODE} detected\n";
376							}
377							elsif ( $matched >= 3 ) {
378							}
379							}
380
381							# print "Entire match: $match\n";
382							# print "Matched Text: ",
383							# substr $_, $start_match,
384							# $end_match-$start_match;
385
386	37	50				151	if ( $matched > 1 ) { # 1 just means select->foreach conversion
387	37					95	$::_LOOP_COUNT++; # counts # detected select-loops
388	37	50				135	$DEBUG > 0 and
389							warn "$PKG: Set debug to: $Shell::POSIX::Select::DEBUG\n";
390							}
391
392							# $can_rewrite indicates whether we matched the crucial
393							# parts that allow replacement of the input -- the list and codeblock
394							# If we got both, the $can_rewrite var shows true now
395	37	50				151	$can_rewrite = $matched >= 2 ? 1 : 0;
396
397							# $DEBUG > 1 and warn "Calling MATCHES2FIELDS with \$loop_list of $loop_list\n";
398							# $DEBUG > 1 and warn "Calling MATCHES2FIELDS with \$loop_block of ===$loop_block===\n";
399	37	50				142	if ($can_rewrite) {
400	37					181	my $replacer = enloop_codeblock
401							matches2fields ( $loop_decl,
402							$loop_var,
403							$loop_list,
404							$loop_block ),
405							$::_LOOP_COUNT;
406
407	37					807	substr($_, $start_match, ($end_match-$start_match), $replacer );
408							# print "\n\nModified \$_ is: \n$_\n";
409							}
410							}
411							} # end while
412							continue {
413	37	50				219	$DEBUG_FILT > 2 and warn "CONTINUING FIND_LOOP\n" ;
414							}
415							#warn "Leaving $subname 1 \n";
416							} # else
417							FILTER_EXIT:
418							# $Shell::POSIX::Select::filter_output="PRE-LOADING DUMP VAR, loopnum was $loopnum";
419	28					98	if (
420							0 # and $DEBUG or $Shell::POSIX::Select::dump_data
421							) {
422							# print TTY "$detect_msg\nCode 222\n" ;
423							# print TTY "Code 222\n" ;
424							if ($loopnum == 1 and
425							$detect_msg !~ /SELECT LOOP DETECTED/ ) {
426							# $DEBUG and print STDERR "copacetic\n";
427							# exit 222;
428							# We still need to run the program!
429							}
430							else {
431							$DEBUG >2 and print TTY "LOOP DETECTED: $detect_msg\n"; exit 222;
432							}
433							} # if 0
434
435	28	50				218	$loopnum > 0 and $Shell::POSIX::Select::filter_output=$_;
436							# Restore original string-like parts of the code:
437	28					388	$Shell::POSIX::Select::filter_output =~ s/$Filter::Simple::placeholder/${$Filter::Simple::components[unpack('N',$1)]}/ge;
	180					671
	180					1328
438	28	50				164	$LOGGING and print USERPROG $_; # $_ unset 2nd call; label starts below
439	28	50				208	$DEBUG_FILT > 2 and _WARN "Leaving $subname on call #$::_FILTER_CALLS\n";
440							} # end sub filter
441							} # Scope for declaration of filters' REs
442
443
444							sub show_progress {
445	0			0	0	0	my $subname = sub_name();
446
447
448	0					0	my ($match, $pos, $string) = @_;
449
450	0	0	0			0	! defined $match or $match eq "" and warn "$subname: \$match is empty\n";
451	0					0	show_subs( "Match so far: ", $match, 0, 99);
452	0	0				0	defined $pos and warn "POS is now $pos\n";
453	0					0	show_subs( "Remaining string: ", $string, $pos, 19);
454							} # show_progress
455
456							sub show_context {
457	0			0	0	0	my $subname = sub_name();
458
459
460	0					0	my ($left, $match, $right) = @_;
461
462	0	0				0	$DEBUG > 0 and warn "left/match/right: $left/$match/$right";
463
464	0					0	show_subs( "Left is", $left, -10);
465	0					0	show_subs( "Right is", $right, 0, 10);
466							} # show_context
467
468							# Following sub converts matched elements of users source into the
469							# fields we need: declaration (optional), loop_varname (optional), codeblock
470
471							sub matches2fields {
472	37			37	0	130	my $subname = sub_name();
473	37					113	my $default_loopvar = 0;
474
475
476	37					119	my ( $debugging_code, $codeblock2, );
477	37					232	my ( $decl, $loop_var, $values, $codeblock, $fullmatch ) = @_;
478
479	37					100	$debugging_code = "";
480	37	50				158	if ($U_DEBUG > 3) {
481	0					0	$debugging_code = "\n# USER-MODE DEBUGGING CODE STARTS HERE\n";
482	0					0	$debugging_code .=
483							'; $,="/"; warn "Caller is now: ", (caller 0), "\n";';
484	0					0	$debugging_code .=
485							'warn "Caller 3 is now: ", ((caller 0)[3]), "\n";';
486	0					0	$debugging_code .= 'warn "\@_ is: @_\n";';
487	0					0	$debugging_code .= 'warn "\@ARGV is: @ARGV\n";';
488
489							# $debugging_code .=
490							# 'warn "\@looplist is : @Shell::POSIX::Select::looplist\n"';
491	0					0	$debugging_code .= "# USER-MODE DEBUGGING CODE ENDS HERE\n\n";
492
493	0					0	$debugging_code .= "";
494							}
495
496	37	100	66			456	if ( !defined $values or $values =~ /^\s$\s$\s*$/ ) { # ( ) is legit syntax
497							# warn "values is undef or vacant";
498							# Code to let user prog figure out if select loop is in sub,
499							# and if so, selects @_ for default LIST
500	2					8	$values = # supply appropriate default list, depending on programmer's context
501							'defined ((( caller 0 )[3]) and ' .
502							' (( caller 0 )[3]) ne "") ? @_ : @ARGV '
503							;
504							}
505
506
507	37	100	66			564	if ( defined $decl and $decl ne "" and
		50	66
		100	33
			33
			0
			33
			66
			33
			66
508							defined $loop_var and $loop_var ne "" ) {
509	11	50				47	$LOGGING and print LOG
510							"LOOP: Two-part declaration,",
511							" scoper is: $decl, varname is $loop_var\n";
512							}
513							elsif ( defined $decl and $decl ne "" and
514							(! defined $loop_var or $loop_var eq "") ) {
515	0	0				0	$LOGGING and print LOG
516							"LOOP: Declaration without variable name: $decl" ;
517	0					0	warn "$PKG: variable declarator ($decl) provided without variable name\n";
518	0					0	warn "giving up on this match; scanning for next keyword (3)";
519	0					0	goto FIND_LOOP;
520							}
521							elsif ( defined $loop_var and $loop_var ne "" and
522							(! defined $decl or $decl eq "") ) {
523	15	50				69	$LOGGING and print LOG
524							"LOOP: Variable without declaration (okay): $loop_var"
525							}
526							else {
527	11	50				45	$LOGGING and print LOG "LOOP: zero-word declaration\n";
528
529	11					30	my $default_loopvar = 1;
530	11					42	($decl, $loop_var) = qw (local $_); # default loop var; package scope
531							}
532
533	37	100	66			385	if ( !defined $codeblock or $codeblock =~ /^\s{\s}\s*$/ ) {
534							# default codeblock prints the selection; good for grep()-like filtering
535							# NOTE: Following string must start/end with {}
536	2					13	$codeblock = "{
537							print \"$loop_var\\n\" ; # USING DEFAULT CODEBLOCK
538							}";
539							}
540
541							# I've already extracted what could be a valid variable name,
542							# but the regex was kinda sleazy, so it's time to validate
543							# it using TEXT::BALANCED::extract_variable()
544							# But I found a bug, it rejects $::var*, so exempt that form from check
545
546	37	50	33			467	unless ($default_loopvar or $loop_var =~ /^\$::\w+/) {
547							# don't check if I inserted it myself, or is in form $::stuff,
548							# which extract_variable() doesn't properly extract
549	37	50				216	$DEBUG > 1 and warn "Pre-extract_variable 3\n";
550							# Now let's see if Damian likes it:
551	37					193	my ( $loop_var2, @rest ) = extract_variable($loop_var);
552	37	50				10325	if ( $loop_var2 ne $loop_var ) {
553	0	0	0			0	$DEBUG > 1 and
554							warn "$PKG: extracted var diff from parsed var: ",
555							$DEBUG > 0 and warn
556							"$PKG: varname for select loop failed validation",
557							" #$::_LOOP_COUNT: $loop_var\n";
558							}
559							}
560							else {
561							;
562							}
563
564	37	100				204	!defined $decl and $decl = "";
565							# okay for this to be empty string; means user wants it global, or
566							# declared it before loop
567
568							# make version of \$codeblock without curlies at either end
569	37					559	( $codeblock2 = $codeblock ) =~ s/\A\s\{\s\|\s\}\s\z//g;
570
571	37	50	33			308	defined $decl and $decl eq 'unset' and undef $decl; # pass as undef
572							# $DEBUG > 1 and warn " DDD matches2fields() is returning codeblock2 ===$codeblock2===\n";
573	37					274	return ( $decl, $loop_var, $values, $codeblock2, $debugging_code );
574							} # matches2fields
575
576							sub enloop_codeblock {
577							# Wraps code implementing select-loop around user-supplied codeblock
578	37			37	0	130	my $subname = sub_name();
579
580	37					180	$Shell::POSIX::Select::_ENLOOP_CALL_COUNT++;
581
582	37					167	my ( $decl, $loop_var, $values, $codestring, $dcode, $loopnum ) = @_;
583
584	37	50	33			341	(defined $values and $values ne "") or do {
585	0	0				0	$DEBUG > 1 and _WARN "NO VALUES! Using dummy ones";
586	0					0	$values = '( dummy1, dummy2 )';
587							};
588
589	37	100	66			335	my $declaration =
590							( defined $decl and $decl ne "" ) ? "$decl $loop_var; " .
591							' # LOOP-VAR DECLARATION REQUESTED (perhaps by default)' :
592							" ; # NO DECLARATION OF LOOP-VAR REQUESTED";
593
594	37					143	my $arrayname = $PKG . '::looplist';
595	37					101	my $NL = '\n';
596
597							# Now build the code for the user-prog to run
598	37					85	my @parts;
599							# Start new scope first, so if user has LOOP: label before select,
600							# it applies to the whole encapsulated loop
601							# wrapper scope needed so user can LABEL: select(), and not my label
602	37					300	push @parts, qq(
603							# Code generated by $PKG v$VERSION, by tim(AT)TeachMePerl.com
604							# NOTA BENE: Line 1 of this segment must start with {, so user can LABEL it
605							{ # ** NEW WRAPPER SCOPE FOR SELECTLOOP #$loopnum **
606							\$${PKG}::DEBUG > 1 and $loopnum == 1 and
607							warn "LINE NUMBER FOR START OF USER CODE_BLOCK IS: ", __LINE__, "\\n";
608							_SEL_LOOP$loopnum: { # ** NEW SCOPE FOR SELECTLOOP #$loopnum **
609							);
610							# warn " DDD LOGGING is now $LOGGING\n";
611	37	50	0			148	$LOGGING and (print PART1 $parts[0] or _DIE "failed to write to PART1\n");
612	37	50				146	$DEBUG > 4 and warn "SETTING $arrayname to $values\n";
613
614	37					355	push @parts, qq(
615							# critical for values's contents to be resolved in user's scope
616							local \@$arrayname=$values;
617							local \$${PKG}::num_values=\@$arrayname;
618
619							\$${PKG}::DEBUG > 4 and do {
620							warn "ARRAY VALUES ARE: \@$arrayname\\n";
621							warn "NUM VALUES is \$${PKG}::num_values\\n";
622							warn "user-program debug level is \$${PKG}::U_WARN\\n";
623							};
624							$declaration # loop-var declaration appears here
625							);
626
627	37	50	0			156	$LOGGING and (print PART2 $parts[1] or _DIE "failed to write to PART1\n");
628
629	37	50				133	$DEBUG > 4 and do {
630	0					0	warn "\$codestring is: $codestring\n";
631	0					0	warn "\$dcode is: '$dcode'\n";
632	0					0	warn "\$arrayname is: $arrayname\n";
633	0	0				0	!defined $Shell::POSIX::Select::_autoprompt and warn "autoprompt is unset";
634	0	0				0	!defined $codestring and warn "codestring is unset";
635							};
636
637							{ # local scope for $^W mod
638							# getting one pesky "uninit var" warnings I can't resolve
639	37					85	local $^W=0;
	37					273
640	37					1710	push @parts, qq(
641							$dcode;
642							local (
643							\$${PKG}::Prompt[$loopnum],
644							\$${PKG}::menu
645							) =
646							${PKG}::make_menu(
647							\$${PKG}::Heading \|\| "",
648							\$${PKG}::Prompt \|\| "" , # Might be overridden in make_menu
649							\@$arrayname
650							);
651
652							# no point in prompting a pipe!
653							local \$${PKG}::do_prompt[$loopnum] = (-t) ? 1 : 0 ;
654							$DEBUG > 2 and warn "do_prompt is \$${PKG}::do_prompt[$loopnum]\\n";
655							if ( defined \$${PKG}::menu ) { # No list, no iterations!
656							while (1) { # for repeating prompt for selections
657							# localize, so I don't have to reset $Reply for
658							# outer loop on exit from inner
659							local (\$Reply);
660							while (1) { # for validating user's input
661							local \$${PKG}::bad = 0;
662
663							# local decl suppresses newline on prompt when -l switch turned on
664							{
665							local \$\\;
666							if (\$${PKG}::do_prompt[$loopnum]) {
667
668							# When transferring from INNER to OUTER loop,
669							# extra NL before prompt is visually desirable
670
671							if ( \$${PKG}::_extra_nl) {
672							print STDERR "\\n\\n";
673							\$${PKG}::_extra_nl=0;
674							}
675							print STDERR
676							"\$${PKG}::menu$NL$ON\$${PKG}::Prompt[$loopnum]$OFF$BOLD ";
677							}
678							}
679
680							# \$${PKG}::do_prompt=$Shell::POSIX::Select::_autoprompt;
681							# constant prompting depends on style
682							\$${PKG}::do_prompt[$loopnum]= 0;
683
684							if ( \$${PKG}::dump_data ) {
685							\$Reply = undef;
686							# dump filtered source for comparison against expected
687							print STDERR "copacetic\n"; # ensure some output, and flush pending
688							exit 222; # code for graceful, expected, early exit
689							}
690							else {
691							# \$^W=0;
692							# warn "Waiting for input";
693							\$Eof=0;
694							\$Reply = ;
695							# warn "Got input";
696							# \$^W=1;
697
698							if ( !defined( \$Reply ) ) {
699							defined "$BOLD" and "$BOLD" ne "" and print STDERR "$SGR0";
700
701							# need to undef loop var; user may check it!
702							undef $loop_var;
703
704							# last ${PKG}::_SEL_LOOP$loopnum; # Syntax error!
705							# If returning to outer loop, show the prompt for it
706							# warn "User hit ^D";
707							if ( $loopnum > 1 and -t ) { # reset prompting for outer loop
708							\$${PKG}::do_prompt[$loopnum-1] = 1; \$${PKG}::_extra_nl=1;
709							}
710							$DEBUG > 2 and warn "Lasting out of _SEL_LOOP$loopnum\\n";
711							\$Eof=1;
712							last _SEL_LOOP$loopnum;
713							}
714							!defined \$Reply and die "REPLY accessed, while undefined";
715							chomp \$Reply;
716
717							# undo emboldening of user input
718							defined "$BOLD" and "$BOLD" ne "" and print STDERR "$SGR0";
719
720							#print STDERR "\$${PKG}::menu$NL$ON\$${PKG}::Prompt$OFF$BOLD ";
721							if ( \$Reply eq "" ) { # interpreted as re-print menu request
722							# Empty input is legit, means redisplay menu
723							\$${PKG}::U_WARN > 1 and warn "\\tINPUT IS: empty\\n";
724							\$${PKG}::bad = \$${PKG}::do_prompt[$loopnum] = 1;
725							}
726							elsif ( \$Reply =~ /\\D/ ) { # shouldn't be any non-digit!
727							\$${PKG}::U_WARN > 0
728							and warn "\\tINPUT CONTAINS NON-DIGIT: '\$Reply'\\n";
729							\$${PKG}::bad = 1; # Korn and Bash shell just ignore this case
730							}
731							elsif ( \$Reply < 1 or \$Reply > \$${PKG}::num_values ) {
732							\$${PKG}::U_WARN > 0
733							and warn
734							"\\t'\$Reply' IS NOT IN RANGE: 1 - \$${PKG}::num_values\\n";
735							\$${PKG}::bad = 1; # Korn and Bash shell just ignore this case
736							}
737
738							# warn "BAD is now: \$${PKG}::bad";
739							\$${PKG}::bad or
740							$DEBUG > 2 and warn "About to last out of Reply Validator Loop\n";
741							\$${PKG}::bad or last; # REPLY VALIDATOR EXITED HERE
742							} # if for validating user input
743							} # infinite while for validating user input
744
745							$loop_var = \$$arrayname\[\$Reply - 1]; # set users' variable
746
747							# USER'S LOOP-BLOCK BELOW
748							$codestring;
749
750							# USER'S LOOP-BLOCK ABOVE
751							# Making sure there's colon (maybe
752							# even two) after codestring above,
753							# in case user omitted after last
754							# statement in block. I might add
755							# another statement below it someday!
756							$DEBUG > 2 and warn "At end of prompt-repeating loop \n";
757							} # infinite while for repeating collection of selections
758							$DEBUG and warn "BEYOND end of prompt-repeating loop \n";
759							} # endif (defined \$${PKG}::menu)
760							else {
761							\$${PKG}::DEBUG > 0 and warn "$PKG: Select Loop #$loopnum has no list, so no iterations\\n";
762
763							if ( \$${PKG}::dump_data ) {
764							\$Reply = undef;
765							# dump filtered source for comparison against expected
766							print STDERR "copacetic\n"; # ensure some output, and flush pending
767							exit 222; # code for graceful, expected, early exit
768							}
769							}
770							# return omitted above, to get last expression's value
771							# returned automatically, just like shell's version
772
773							); # push onto parts ender
774							} # local scope for $^W mod
775
776	37	50	0			185	$LOGGING and (print PART3 $parts[2] or _DIE "failed to write to PART3\n");
777
778	37					201	push @parts, qq(
779							} # ** END NEW SCOPE FOR SELECTLOOP #$loopnum **
780							} # ** END WRAPPER SCOPE FOR SELECTLOOP #$loopnum **
781							# vi:ts=2 sw=2:
782							);
783
784	37	50	0			138	$LOGGING and (print PART4 $parts[3] or _DIE "failed to write to PART4\n");
785							# Following is portable PART-divider, used to isolate chunk
786							# with unitialized value causing warning
787							# ); push @parts, qq(
788
789	37					615	return ( join "", @parts ); # return assembled code, for user to run
790							} # enloop_codeblock
791
792							sub make_menu {
793	22			22	0	128	my $subname = sub_name();
794
795
796							# Replacement of empty list by @_ or @ARGV happens in matches2fields
797							# Here we check to see if we got arguments from somewhere
798							# Note that it's not necesssarily an error if there are no values,
799							# that just means we won't do any iterations
800
801	22					93	my ($heading) = shift;
802	22					74	my ($prompt) = shift;
803	22					90	my (@values) = @_;
804	22	100				113	unless (@values) {
805	4					30	return ( undef, undef ); # can't make menu out of nothing!
806							}
807	18					66	my ( $l, $l_length ) = 0;
808	18					57	my $count = 5;
809	18					65	my ( $sep, $padding ) = "" x 2;
810	18					54	my $choice = "";
811
812
813							# Find longest string value in selection list
814	18					51	my $v_length = 0;
815
816	18					150	for ( my $i = 0 ; $i < @values ; $i++ ) {
817	35	100				223	( $l = length $values[$i] ) > $v_length and $v_length = $l;
818							}
819	18	0	33			105	$DEBUG > 3 and $LOGGING and print LOG "Longest value is $v_length chars\n";
820
821							# Figure out lengths of labels (numbers on menu selections)
822	18	0	33			110	$DEBUG > 3 and $LOGGING and print LOG "Number of values is ", scalar @values, "\n";
823
824
825	18	50				217	@values >= 10_000 ? $l_length = 5 :
		50
		50
		50
		50
826							@values >= 1_000 ? $l_length = 4 :
827							@values >= 100 ? $l_length = 3 :
828							@values >= 10 ? $l_length = 2 :
829							@values > 0 ? $l_length = 1 :
830							undef $l_length;
831
832	18	0	33			132	$DEBUG > 3 and $LOGGING and print LOG "Label length is $l_length\n";
833
834	18	50				183	if ( !defined $l_length ) { return undef; }
	0					0
835
836	18					61	$sep = "\040\040";
837	18					54	my $l_sep = length $sep; # separator 'tween pieces
838
839							# Figure out how many columns per line we can print
840							# 2 is for : after label
841
842							# TIMJI: Convert to using YUMPY's Term::Size::Heuristic here, later on
843
844	18					64	my $one_label = ( $l_length + 2 ) + $v_length + $l_sep;
845	18					95	my $columns = int( $COLS / $one_label );
846	18	50				97	$columns < 1 and $columns = 1;
847							# Do not let the number of columns grow beyond the maximum:
848	18	50				126	if ($MaxColumns < $columns)
849							{
850	0					0	$columns = $MaxColumns;
851							} # if
852
853							# $DEBUG > 3 and
854							#HERE
855	18	50				80	$LOGGING and print LOG "T-Cols, Columns, label: $COLS, $columns, $one_label\n";
856
857							# Prompt may have been set in import() according to a submitted option;
858							# if so, keep it. If not, use shell's default
859							$prompt =
860							(defined $Shell::POSIX::Select::Prompt and
861							$Shell::POSIX::Select::Prompt ne "") ?
862							$Shell::POSIX::Select::Prompt :
863							defined $ENV{Select_POSIX_Shell_Prompt} ? $ENV{Select_POSIX_Shell_Prompt} :
864	18	50	66			172	$Shell::POSIX::Select::_default_prompt;
		100
865							;
866
867	18	0	33			91	$DEBUG > 3 and $LOGGING and print LOG "Making menu\n";
868
869							{
870	18					49	local $, = "\n";
	18					69
871							}
872
873	18					50	my $menu;
874	18	50				116	$menu = defined $heading ? "${ON}$heading$OFF" : "" ;
875	18					67	$menu.="\n";
876							# $columns == 0 and die "Columns is zero!";
877	18					127	for ( my $i = 0, my $j = 1 ; $i < @values ; $i++, $j++ ) {
878	35					252	$menu .= sprintf "%${l_length}d) %-${v_length}s$sep", $j, $values[$i];
879	35	50				182	$j % $columns or $menu .= sprintf "\n"; # format $count items per line
880
881							# For 385 line list:
882							# Illegal modulus zero at /pmods/yumpy/Select/Shell/POSIX/Select.pm line 764.
883
884							}
885	18					143	return ( $prompt, $menu );
886							} # make_menu
887
888							sub log_files {
889	0			0	0	0	my $subname = sub_name();
890	0					0	my ($dir, $sep);
891
892
893	0	0				0	if ( $LOGGING == 1 ) {
		0
894	0					0	$dir = tmpdir();
895							#
896							# USERPROG shows my changes, with control-chars
897							# filling in as placeholders for some pieces. For
898							# debugging purposes, I find it helpful to print that
899							# out ASAP so I have something to look at if the
900							# program bombs out before SOURCE gets written out,
901							# which is the same apart from placeholders being
902							# converted to original data.
903							#
904	0	0	0			0	$DEBUG > 1 and $LOGGING > 0 and warn "Opening log files\n";
905	0	0				0	open LOG, '>', catfile($dir, 'SELECT_log') or _DIE "Open LOG failed, $!\n";
906	0	0				0	open SOURCE, '>', catfile($dir, 'SELECT_source') or _DIE "Open SOURCE failed, $!\n";
907	0	0				0	open USERPROG, '>', catfile($dir, 'SELECT_user_program') or _DIE "Open USERPROG failed, $!\n";
908	0	0				0	open PART1, '>', catfile($dir, 'SELECT_part1') or _DIE "Open PART1 failed, $!\n";
909	0	0				0	open PART2, '>', catfile($dir, 'SELECT_part2') or _DIE "Open PART2 failed, $!\n";
910	0	0				0	open PART3, '>', catfile($dir, 'SELECT_part3') or _DIE "Open PART3 failed, $!\n";
911	0	0				0	open PART4, '>', catfile($dir, 'SELECT_part4') or _DIE "Open PART4 failed, $!\n";
912	0					0	$LOGGING++; # to avoid 2nd invocation
913	0	0	0			0	$DEBUG > 1 and $LOGGING > 0 and warn "Finished with log files\n";
914							}
915							elsif ($LOGGING > 1) {
916	0	0				0	$DEBUG > 0 and warn "$subname: Logfiles opened previously\n";
917							}
918							else {
919	0	0				0	$DEBUG > 0 and warn "$subname: Logfiles not opened\n";
920							}
921							} # log_files
922
923							sub sub_name {
924	320			320	0	4057	my $callers_name = (caller 1)[3] ;
925	320	50				4341	if ( ! defined $callers_name ) {
926	0					0	$callers_name='Main_program'; # must be call from main
927							}
928							else {
929	320					2399	$callers_name =~ s/^.*:://; # strip package name
930	320					1009	$callers_name .= '()'; # sub_name -> sub_name()
931							}
932	320					3717	return $callers_name;
933							} # sub_name
934
935							sub _WARN {
936	27			27		97	my $subname = sub_name();
937	27	50				7082	$PRODUCTION ? carp(@_) : warn (@_);
938							}
939
940							sub _DIE {
941	0			0		0	my $subname = sub_name();
942	0	0				0	$DEBUG and warn "$0: In _DIE, with PRODUCTION of $PRODUCTION, arg of @_\n";
943	0	0				0	$PRODUCTION ? croak(@_) : die (@_);
944							}
945
946
947	0			0	0	0	sub ignoring_case { lc $a cmp lc $b }
948
949							sub import {
950							local $_;
951							my $subname = sub_name();
952							my %import;
953							$_import_called++;
954
955							shift; # discard package name
956
957							$Shell::POSIX::Select::U_WARN = $Shell::POSIX::Select::U_WARN_default;
958							$Shell::POSIX::Select::_style = $Shell::POSIX::Select::_default_style;
959							# $Shell::POSIX::Select::_prompt =
960							# Prompt is now established in make_menu, during run-time
961							$Shell::POSIX::Select::_autoprompt=0;
962
963							# First, peel off symbols to import, if any
964							# warn "Caller of $subname is ", scalar caller, "\n";
965							my $user_pkg=caller;
966							# $DEBUG > 2 and
967							for (my $i=0; $i<@_; $i++) {
968							my $found=0;
969							foreach (@EXPORT_OK) { # Handle $Headings, etc.
970							if ($_[$i] eq $_) { $import{$_} = $i; $found++; last; }
971							}
972							# stop as soon as first non-symbol encountered, so as not to
973							# accidentally mess with following hash-style options
974							$found==0 and last;
975							}
976							%import and export($user_pkg, keys %import); # create aliases for user
977
978							# following gets "attempt to delete unreferenced scalar"!
979							# %import and delete @_[values %import];
980							# Delete from @_ each
981							map { delete $_[$_] } values %import; # but this works
982							# warn "Numvals in array is ", scalar @_, "\n";
983
984							@_= grep defined, @_; # reset, to eliminate extracted imports
985							# warn "Numvals in array is now ", scalar @_, "\n";
986							# warnings sets user-program debugging level
987							# debug sets module's debuging level
988							my @legal_options = qw( style prompt testmode warnings debug logging );
989							my %options =
990							hash_options(\@legal_options, @_ ); # style => Korn, etc.
991
992
993							my @styles=qw( bash korn );
994							my @prompts=qw( generic korn bash arrows );
995							my @testmodes=qw( make foreach );
996
997							my $bad;
998
999							# timji: Loopify this section later, once it gets stable
1000
1001							# "logging" enables/disables logging of filter output to file
1002							$_ = $ENV{Shell_POSIX_Select_logging} \|\| $options{logging};
1003							if (defined) {
1004							# unless ( is_unix() ) {
1005							# warn "$PKG\::$subname: logging is only for UNIX-like OSs\n";
1006							# }
1007							if (/^(\d)$/ and 0 <= $1 and $1 <=1 ) {
1008							$LOGGING = $_;
1009							$DEBUG > 0 and warn "$PKG: Set logging to: $LOGGING\n";
1010							}
1011							else {
1012							_WARN "$PKG\::$subname: Invalid logging level '$_'\n";
1013							$DEBUG > 1 and _DIE;
1014							}
1015							}
1016
1017							# "debug" enables/disables informational messages while running user program
1018							$_ = $ENV{Shell_POSIX_Select_warnings} \|\| $options{warnings};
1019							$select2foreach=0;
1020							if (defined) {
1021							if (/^\d+$/) {
1022							$Shell::POSIX::Select::U_WARN = $_;
1023							warn "$PKG: Set warnings to: $Shell::POSIX::Select::U_WARN\n";
1024							}
1025							else {
1026							_WARN "$PKG\::$subname: Invalid warnings level '$_'\n";
1027							$DEBUG > 1 and _DIE;
1028							}
1029							}
1030
1031							# "debug" enables/disables informational messages while running user program
1032							$_ = $ENV{Shell_POSIX_Select_debug} \|\| $options{debug};
1033							if (defined) {
1034							if (/^\d+$/) {
1035							$Shell::POSIX::Select::DEBUG = $_;
1036							}
1037							else {
1038							_WARN "$PKG\::$subname: Invalid debug option '$_'\n";
1039							$DEBUG > 1 and _DIE;
1040							}
1041							}
1042
1043							$_=$ENV{Shell_POSIX_Select_style} \|\| $options{style};
1044							if (defined) {
1045							my $found=0;
1046							foreach my $style (@styles) {
1047							if ($_ =~ /^$style$/i ) { # korn, bash,etc.
1048							# code as K, B, etc.
1049							$Shell::POSIX::Select::_style = uc substr($_,0,1);
1050							$found++; # last one wins
1051							}
1052							}
1053							if (! $found) {
1054							_WARN "$PKG\::$subname: Invalid style option '$_'\n";
1055							$DEBUG > 1 and _DIE;
1056							}
1057							}
1058
1059							# Bash automatically shows prompt every time,
1060							# Ksh only does if user enters input of only
1061							my $autoprompt=0;
1062							if ( $Shell::POSIX::Select::_style eq 'K' ) { $autoprompt=0; }
1063							elsif ( $Shell::POSIX::Select::_style eq 'B' ) { $autoprompt=1; }
1064
1065							$Shell::POSIX::Select::_autoprompt = $autoprompt;
1066							$_ = $ENV{Shell_POSIX_Select_prompt} \|\| $options{prompt} ;
1067							if (defined) {
1068							$_=lc $_;
1069							my $found=0;
1070							foreach my $prompt (sort @prompts) { # sorting, so "generic" choice beats shell-specific ones
1071							if ($_ =~ /^$prompt$/i ) {
1072							$_ eq 'generic' and do {
1073							$DEBUG > 0 and warn "Set generic prompt";
1074							$Shell::POSIX::Select::_prompt =
1075							$Shell::POSIX::Select::_generic;
1076							++$found and last;
1077							die 33;
1078							};
1079							$_ eq "korn" and do {
1080							$Shell::POSIX::Select::_prompt =
1081							$Shell::POSIX::Select::_korn_prompt;
1082							$found++;
1083							last;
1084							};
1085							$_ eq "bash" and do {
1086							$Shell::POSIX::Select::_prompt =
1087							$Shell::POSIX::Select::_bash_prompt;
1088							$found++;
1089							last;
1090							};
1091							$_ eq "arrows" and do {
1092							$Shell::POSIX::Select::_prompt =
1093							$Shell::POSIX::Select::_arrows_prompt;
1094							$found++;
1095							last;
1096							};
1097							}
1098							# If not a prompt keyword, must be literal prompt
1099							do {
1100							$Shell::POSIX::Select::_prompt = $_;
1101							$found++;
1102							last;
1103							};
1104							}
1105							if (! $found) {
1106							_WARN "$PKG\::$subname: Invalid prompt option '$_'\n";
1107							$DEBUG > 1 and _DIE;
1108							}
1109							}
1110
1111							$Shell::POSIX::Select::dump_data=0;
1112							$_= $ENV{Shell_POSIX_Select_testmode} \|\| $options{testmode} ;
1113							if (defined) {
1114							my $found=0;
1115							#foreach my $mode ( @testmodes ) {
1116							if ($_ =~ /^make$/i ) {
1117							$Shell::POSIX::Select::_testmode= 'make';
1118							$Shell::POSIX::Select::dump_data=1;
1119							$found++;
1120							}
1121							elsif ($_ =~ /^foreach$/i ) {
1122							$Shell::POSIX::Select::_testmode= 'foreach';
1123							$select2foreach=1;
1124							$found++;
1125							}
1126							else {
1127							$Shell::POSIX::Select::_testmode= '';
1128							$DEBUG > 2 and _WARN "Unrecognized testmode: $_\n";
1129							}
1130							#}
1131							if (! $found) {
1132							_WARN "$PKG\::$subname: Invalid testmode option '$_'\n";
1133							$DEBUG > 1 and _DIE;
1134							}
1135							}
1136							# ENV variable overrides program spec
1137
1138							( ! defined $Shell::POSIX::Select::_testmode or
1139							$Shell::POSIX::Select::_testmode eq "" ) and
1140							$Shell::POSIX::Select::_testmode = "";
1141
1142							$DEBUG > 2 and warn "37 Testmode set to $Shell::POSIX::Select::_testmode\n";
1143
1144							$LOGGING and log_files();
1145
1146							$ENV{Shell_POSIX_Select_reference} and
1147							$Shell::POSIX::Select::dump_data = 'Ref_Data';
1148
1149							# Don't assume /dev/tty will work on user's platform!
1150							if ( $Shell::POSIX::Select::dump_data ) {
1151
1152							# must ensure all output gets flushed to dumpfile before exiting
1153							disable_buffering();
1154
1155							#if ( ! $PRODUCTION ) {
1156							$Shell::POSIX::Select::_TTY=0;
1157							# What's the OS-portable equivalent of "/dev/tty" in the above?
1158							if ( -c '/dev/tty' ) {
1159							if ( open TTY, '> /dev/tty' ) {
1160							$Shell::POSIX::Select::_TTY=1;
1161							}
1162							else {
1163							_WARN "Open of /dev/tty failed, $!\n";
1164							}
1165							}
1166							#}
1167
1168							$sdump = qq/$script.sdump/;
1169							if ($Shell::POSIX::Select::dump_data =~ /[a-z]/i)
1170							{
1171							$sdump = catfile($Shell::POSIX::Select::dump_data, $sdump .'_ref');
1172							}
1173							else
1174							{
1175							# TODO: probably should put it in the same
1176							# folder as the original program being
1177							# analyzed, rather than '.':
1178							$sdump = catfile('.', $sdump);
1179							}
1180							($cdump = $sdump) =~ s/$script\.sdump/$script.cdump/; # make code-dump name too
1181
1182							# HERE next two lines squelch
1183
1184
1185							# Make reference copies of dumps for distribution, or test copies,
1186							# depending on ENV{reference} set or testmode=make
1187							close STDERR or
1188							die "$PKG-END(): Failed to close 'STDERR', $!\n";
1189							open STDERR, "> $sdump" or
1190							die "$PKG-END(): Failed to open '$sdump' for writing, $!\n";
1191
1192							open STDOUT, ">&STDERR" or
1193							die "$PKG-END(): Failed to dup STDOUT to STDERR, $!\n";
1194							}
1195
1196							( $ON , $OFF , $BOLD , $SGR0 , $COLS ) =
1197							display_control ($Shell::POSIX::Select::dump_data);
1198							1;
1199							} # import
1200
1201							sub export { # appropriated from Switch.pm
1202	8			8	0	23	my $subname = sub_name();
1203
1204							# $offset = (caller)[2]+1;
1205	8					22	my $pkg = shift;
1206	26			26		746	no strict 'refs';
	26					81
	26					47551
1207							# All exports are scalard vars, so strip sigils and poke in package name
1208	8					25	foreach ( map { s/^\$//; $_ } @_ ) { # must change $Reply to Reply, etc.
	11					43
	11					45
1209	11					71	*{"${pkg}::$_"} =
1210	11					22	\${ "Shell::POSIX::Select::$_" };
	11					51
1211							# "Shell::POSIX::Select::$_";
1212							}
1213							# *{"${pkg}::__"} = \&__ if grep /__/, @_;
1214	8					23	1;
1215							}
1216
1217							sub hash_options {
1218	27			27	0	68	my $ref_legal_keys = shift;
1219	27					73	my %options = @_ ;
1220	27					84	my $num_options=keys %options;
1221	27					58	my %options2 ;
1222
1223	27					74	my $subname = sub_name();
1224
1225
1226
1227	27	100				124	if ($num_options) {
1228							my @legit_options =
1229	1					5	grep { "@$ref_legal_keys" =~ /\b $_ \b/x }
	1					18
1230							sort ignoring_case keys %options;
1231
1232							my @illegit_options =
1233	1					5	grep { "@$ref_legal_keys" !~ /\b $_ \b/x }
	1					12
1234							sort ignoring_case keys %options;
1235
1236							@options2{sort ignoring_case @legit_options} =
1237	1					6	@options{sort ignoring_case @legit_options } ;
1238							{ # scope for local change to $,
1239	1					3	local $,=' ';
	1					2
1240	1	50				5	if ($num_options > keys %options2) { # options filtered out?
1241	0					0	my $msg= "$PKG\::$subname:\n Invalid options: " ;
1242	0					0	$msg .= "@illegit_options\n";
1243	0					0	_DIE; # Can't be conditional on DEBUG setting,
1244							# because that comes after this sub returns!
1245							}
1246							}
1247
1248							}
1249
1250	27					125	return %options2;
1251							}
1252
1253							sub show_subs {
1254							# show sub-string in reverse video, primarily for debugging
1255	0			0	0	0	my $subname = sub_name();
1256
1257	0	0				0	@_ >= 1 or die "${PKG}\::subname: no arguments\n" ;
1258	0		0			0	my $msg=shift \|\| '';
1259	0		0			0	my $string=(shift \|\| '');
1260	0		0			0	my $start=(shift \|\| 0);
1261	0		0			0	my $length=(shift \|\| 9999);
1262
1263	0					0	$string =~ s/[^[:alpha:\d\s]]/-/g; # control-chars screw up printing
1264							# warn "Calling substr for parms $string/$start/$length\n";
1265	0					0	warn "$msg", $ON, substr ($string, $start, $length), $OFF, "\n";
1266							}
1267
1268							sub gobble_spaces {
1269	80			80	0	295	my $subname = sub_name();
1270
1271	80					335	my $pos=pos(); # remember current position
1272	80	100				416	if (/\G\s+/g) {
1273	74	50				268	$DEBUG_FILT > 1 and
1274							warn "$subname: space gobbler matched '$&' of length ", length $&, "\n" ;
1275							}
1276							else {
1277	6	50				32	$DEBUG_FILT > 1 and warn "$subname: space gobbler matched nothing\n";
1278	6					23	pos()=$pos; # reset to prior position
1279							}
1280	80					218	$pos=pos(); # identify current position
1281							}
1282
1283							sub display_control {
1284	27			27	0	107	my $subname = sub_name();
1285
1286	27					91	my $flag=shift;
1287	27					79	my ( $on , $off , $bold , $sgr0 , $cols ) ;
1288
1289							# in "make" or "reference" testmodes, mustn't clutter output with coloration
1290							# Disable screen manips for reference source-code dumps
1291	27	50				104	unless ( $flag ) {
1292	0	0	0			0	if ( is_unix() and
			0
1293							defined $ENV{TERM} and
1294							! system 'tput -V >/dev/null 2>&1' ) {
1295							# Always need column count
1296							# for menu sizing
1297	0	0				0	$cols=`tput cols`; defined $COLS and chomp ($COLS) ;
	0					0
1298	0	0				0	if ($flag ne 'make') {
1299	0					0	$on=`tput smso`;
1300	0		0			0	$off=`tput rmso` \|\| `tput sgr0`;
1301	0					0	$bold=`tput bold`; # for prettifying screen captures
1302	0					0	$sgr0=`tput sgr0`; # for prettifying screen captures
1303							}
1304							}
1305							else {
1306							}
1307	0	0				0	$DEBUG > 2 and warn "Returning $on , $off , $bold , sgr0 , $cols \n";
1308							}
1309	27		50			529	return ($on \|\| "", $off \|\| "", $bold \|\| "", $sgr0 \|\| "", $cols \|\| 80);
			50
			50
			50
			50
1310							}
1311
1312							END { # END block
1313							# sdump means screen-dump, cdump means code-dump
1314	26	50		26		187	if ( $Shell::POSIX::Select::dump_data ) {
1315	26	50				198	if ( $ENV{Shell_POSIX_Select_reference} ) {
1316							}
1317							else {
1318							}
1319	26					198	my $pwd=curdir();
1320							# $Shell::POSIX::Select::_TTY and
1321							# dump filtered source, for reference or analysis
1322	26	50				2104	unless (open SOURCE, "> $cdump") {
1323	0	0	0			0	$Shell::POSIX::Select::_TTY and
1324							print TTY "$PKG-END(): Failed to open '$cdump' for writing, $!\n" and
1325							warn "$PKG-END(): Failed to open '$cdump' for writing, $!\n" ;
1326	0					0	die;
1327							}
1328	26	50	50			1089	defined $Shell::POSIX::Select::filter_output and
1329							(print SOURCE $Shell::POSIX::Select::filter_output or
1330							die "$PKG-END(): Failed to write to '$cdump', $!\n");
1331							# system "ls -li $cdump $sdump";
1332							}
1333
1334							# Screen dumping now arranged in sub import()
1335							# open SCREEN, "> $script.sdump" or
1336							# die "$PKG-END(): Failed to open '$script.sdump' for writing, $!\n";
1337
1338							else {
1339	0	0	0			0	defined $SGR0 and $SGR0 ne "" and print STDERR "$SGR0"; # ensure turned off
1340	0	0	0			0	$DEBUG > 1 and $LOGGING and print LOG "\n$PKG finished\n";
1341	0					0	print STDERR "\n"; # ensure shell prompt starts on fresh line
1342							}
1343	26					0	exit 0;
1344							}
1345
1346							sub is_unix {
1347	0	0		0	0	0	if (
1348							# I'm using the $^O from File::Spec, which oughta know
1349							# and guessing at others; help!
1350							$^O =~ /^(MacOS\|MSWin32\|os2\|VMS\|epoc\|NetWare\|dos\|cygwin)$/ix
1351							) {
1352	0	0				0	$DEBUG > 2
1353							and warn "Operating System not UNIX;", $^O, "\n";
1354							}
1355							else {
1356	0	0				0	$DEBUG > 2
1357							and warn "Operating System reported as ", $^O, "\n";
1358							}
1359	0	0				0	return defined $1 ? 0 : 1 ;
1360							}
1361
1362							sub disable_buffering {
1363
1364	27			27	0	133	my $old_fh = select (STDERR);
1365	27					119	$\|=1;
1366	27					113	select ($old_fh);
1367	27					72	return 0;
1368							}
1369
1370							=pod
1371
1372							=head1 NAME
1373
1374							Shell::POSIX::Select - The POSIX Shell's "select" loop for Perl
1375
1376							=head1 PURPOSE
1377
1378							This module implements the C
1379							for Perl.
1380							That loop is unique in two ways: it's by far the friendliest feature of any UNIX shell,
1381							and it's the I UNIX shell loop that's missing from the Perl language. Until now!
1382
1383							What's so great about this loop? It automates the generation of a numbered menu
1384							of choices, prompts for a choice, proofreads that choice and complains if it's invalid
1385							(at least in this enhanced implementation), and executes a code-block with a variable
1386							set to the chosen value. That saves a lot of coding for interactive programs --
1387							especially if the menu consists of many values!
1388
1389							The benefit of bringing this loop to Perl is that it obviates the
1390							need for future programmers
1391							to reinvent the I wheel.
1392
1393							=head1 SYNOPSIS
1394
1395							=for comment
1396							Resist temptation to add more spaces in line below; they cause bad wrapping for text-only document version
1397
1398							=for comment
1399							The damn CPAN html renderer, which doesn't respond to
1400							=for html or =for HTML directives (!), can't get the following
1401							right! It's showing the B<> codes! Postscript and text work fine.
1402							B
1403							[ [ my \| local \| our ] scalar_var ]
1404							B<(> [LIST] B<)>
1405							B<{> [CODE] B<}>
1406
1407							select [ [my\|local\|our] scalar_var ] ( [LIST] ) { [CODE] }
1408
1409							In the above, the enclosing square brackets I<(not typed)> identify optional elements, and vertical bars separate mutually-exclusive choices:
1410
1411							The required elements are the keyword C
1412							the I, and the I.
1413							See L<"SYNTAX"> for details.
1414
1415							=head1 ELEMENTARY EXAMPLES
1416
1417							NOTE: All non-trivial programming examples shown in this document are
1418							distributed with this module, in the B directory.
1419							L<"ADDITIONAL EXAMPLES">, covering more features, are shown below.
1420
1421							=head2 ship2me.plx
1422
1423							use Shell::POSIX::Select;
1424
1425							select $shipper ( 'UPS', 'FedEx' ) {
1426							print "\nYou chose: $shipper\n";
1427							last;
1428							}
1429							ship ($shipper, $ARGV[0]); # prints confirmation message
1430
1431							B
1432
1433							ship2me.plx '42 hemp toothbrushes' # program invocation
1434
1435							1) UPS 2) FedEx
1436
1437							Enter number of choice: 2
1438
1439							You chose: FedEx
1440							Your order has been processed. Thanks for your business!
1441
1442
1443							=head2 ship2me2.plx
1444
1445							This variation on the preceding example shows how to use a custom menu-heading and interactive prompt.
1446							It also presents all menus in one column.
1447
1448							use Shell::POSIX::Select qw($Heading $Prompt $MaxColumns);
1449
1450							$Heading = 'Select a Shipper' ;
1451							$Prompt = 'Enter Vendor Number: ' ;
1452							$MaxColumns = 1;
1453							select $shipper ( 'UPS', 'FedEx' ) {
1454							print "\nYou chose: $shipper\n";
1455							last;
1456							}
1457							ship ($shipper, $ARGV[0]); # prints confirmation message
1458
1459							B
1460
1461							ship2me2.plx '42 hemp toothbrushes'
1462
1463							Select a Shipper
1464
1465							1) UPS 2) FedEx
1466
1467							Enter Vendor Number: 2
1468
1469							You chose: FedEx
1470							Your order has been processed. Thanks for your business!
1471
1472
1473							=head1 SYNTAX
1474
1475							=head2 Loop Structure
1476
1477							Supported invocation formats include the following:
1478
1479							use Shell::POSIX::Select ;
1480
1481							select () { } # Form 0
1482							select () { CODE } # Form 1
1483							select (LIST) { CODE } # Form 2
1484							select $var (LIST) { CODE } # Form 3
1485							select my $var (LIST) { CODE } # Form 4
1486							select our $var (LIST) { CODE } # Form 5
1487							select local $var (LIST) { CODE } # Form 6
1488
1489
1490							If the loop variable is omitted (as in I I<0>, I<1> and I<2> above),
1491							it defaults to C<$_>, Cized to the loop's scope.
1492							If the LIST is omitted (as in I I<0> and I<1>),
1493							C<@ARGV> is used by default, unless the loop occurs within a subroutine, in which case
1494							C<@_> is used instead.
1495							If CODE is omitted (as in I I<0>,
1496							it defaults to a statement that B the loop variable.
1497
1498							The cases shown above are merely examples; all reasonable permutations are permitted, including:
1499
1500							select $var ( ) { CODE }
1501							select local $var (LIST) { }
1502
1503							The only form that's I allowed is one that specifies the loop-variable's declarator without naming the loop variable, as in:
1504
1505							select our () { } # WRONG! Must name variable with declarator!
1506
1507							=head2 The Loop variable
1508
1509							See L<"SCOPING ISSUES"> for full details about the implications
1510							of different types of declarations for the loop variable.
1511
1512							=head2 The $Reply Variable
1513
1514							When the interactive user responds to the C
1515							with a valid input (i.e., a number in the correct range),
1516							the variable C<$Reply> is set within the loop to that number.
1517							Of course, the actual item selected is usually of great interest than
1518							its number in the menu, but there are cases in which access to this
1519							number is useful (see L<"menu_ls.plx"> for an example).
1520
1521							=head1 OVERVIEW
1522
1523							This loop is syntactically similar to Perl's
1524							C loop, and functionally related, so we'll describe it in those terms.
1525
1526							foreach $var ( LIST ) { CODE }
1527
1528							The job of C is to run one iteration of CODE for each LIST-item,
1529							with the current item's value placed in Cized C<$var>
1530							(or if the variable is missing, Cized C<$_>).
1531
1532							select $var ( LIST ) { CODE }
1533
1534							In contrast, the C
1535							LIST-items on the screen, prompts for (numerical) input, and then runs an iteration
1536							with C<$var> being set that number's LIST-item.
1537
1538							In other words, C
1539							C loop.
1540							And that's cool! What's I so cool is that
1541							C
1542							the Perl language. I
1543
1544							This module implements the C
1545							("POSIX") shells for Perl.
1546							It accomplishes this through Filter::Simple's I service,
1547							allowing the programmer to blithely proceed as if this control feature existed natively in Perl.
1548
1549							The Bash and Korn shells differ slightly in their handling
1550							of C
1551							This implementation currently follows the Korn shell version most closely
1552							(but see L<"TODO-LIST"> for notes on planned enhancements).
1553
1554							=head1 ENHANCEMENTS
1555
1556							Although the shell doesn't allow the loop variable to be omitted,
1557							for compliance with Perlish expectations,
1558							the C
1559							(as does the native C loop). See L<"SYNTAX"> for details.
1560
1561							The interface and behavior of the Shell versions has been retained
1562							where deemed desirable,
1563							and sensibly modified along Perlish lines elsewhere.
1564							Accordingly, the (primary) default LIST is B<@ARGV> (paralleling the Shell's B<"$@">),
1565							menu prompts can be customized by having the script import and set B<$Prompt>
1566							(paralleling the Shell's B<$PS3>),
1567							and the user's response to the prompt appears in the
1568							variable B<$Reply> (paralleling the Shell's B<$REPLY>),
1569							Cized to the loop.
1570
1571							A deficiency of the shell implementation is the
1572							inability of the user to provide a I for each C
1573							Sure, the
1574							shell programmer can B a heading before the loop is entered and the
1575							menu is displayed, but that approach doesn't help when an I is
1576							reentered on departure from an I,
1577							because the B preceding the I won't be re-executed.
1578
1579							A similar deficiency surrounds the handling of a custom prompt string, and
1580							the need to automatically display it on moving from an inner loop
1581							to an outer one.
1582
1583							To address these deficiencies, this implementation provides the option of having a heading and prompt bound
1584							to each C
1585
1586							Headings and prompts are displayed in reverse video on the terminal,
1587							if possible, to make them more visually distinct.
1588
1589							Some shell versions simply ignore bad input,
1590							such as the entry of a number outside the menu's valid range,
1591							or alphabetic input. I can't imagine any argument
1592							in favor of this behavior being desirable when input is coming from a terminal,
1593							so this implementation gives clear warning messages for such cases by default
1594							(see L<"Warnings"> for details).
1595
1596							After a menu's initial prompt is issued, some shell versions don't
1597							show it again unless the user enters an empty line.
1598							This is desirable in cases where the menu is sufficiently large as to
1599							cause preceding output to scroll off the screen, and undesirable otherwise.
1600							Accordingly, an option is provided to enable or disable automatic prompting
1601							(see L<"Prompts">).
1602
1603							This implementation always issues a fresh prompt
1604							when a terminal user submits EOF as input to a nested C
1605							In such cases, experience shows it's critical to reissue the
1606							menu of the outer loop before accepting any more input.
1607
1608							=head1 SCOPING ISSUES
1609
1610							If the loop variable is named and provided with a I (C, C, or C),
1611							the variable is scoped within the loop using that type of declaration.
1612							But if the variable is named but lacks a declarator,
1613							no declaration is applied to the variable.
1614
1615							This allows, for example,
1616							a variable declared as private I to be accessible
1617							from within the loop, and beyond it,
1618							and one declared as private I to be confined to it:
1619
1620							select my $loopvar ( ) { }
1621							print "$loopvar DOES NOT RETAIN last value from loop here\n";
1622							-------------------------------------------------------------
1623							my $loopvar;
1624							select $loopvar ( ) { }
1625							print "$loopvar RETAINS last value from loop here\n";
1626
1627							With this design,
1628							C
1629							native C loop, which nowadays employs automatic
1630							localization.
1631
1632							foreach $othervar ( ) { } # variable localized automatically
1633							print "$othervar DOES NOT RETAIN last value from loop here\n";
1634
1635							select $othervar ( ) { } # variable in scope, or global
1636							print "$othervar RETAINS last value from loop here\n";
1637
1638							This difference in the treatment of variables is intentional, and appropriate.
1639							That's because the whole point of C
1640							is to let the user choose a value from a list, so it's often
1641							critically important to be able to see, even outside the loop,
1642							the value assigned to the loop variable.
1643
1644							In contrast, it's usually considered undesirable and unnecessary
1645							for the value of the
1646							C loop's variable to be visible outside the loop, because
1647							in most cases it will simply be that of the last element in the list.
1648
1649							Of course, in situations where the
1650							C-like behavior of implicit Cization is desired,
1651							the programmer has the option of declaring the C
1652							variable as C.
1653
1654							Another deficiency of the Shell versions is that it's difficult for the
1655							programmer to differentiate between a
1656							C
1657							versus the loop detecting EOF on input.
1658							To correct this situation,
1659							the variable C<$Eof> can be imported and checked for a I value
1660							upon exit from a C
1661
1662							=head1 IMPORTS AND OPTIONS
1663
1664							=head2 Syntax
1665
1666							use Shell::POSIX::Select (
1667							'$Prompt', # to customize per-menu prompt
1668							'$Heading', # to customize per-menu heading
1669							'$MaxColumns', # to limit visual number of columns of choices
1670							'$Eof', # T/F for Eof detection
1671							# Variables must come first, then key/value options
1672							prompt => 'Enter number of choice:', # or 'whatever:'
1673							style => 'Bash', # or 'Korn'
1674							warnings => 1, # or 0
1675							debug => 0, # or 1-5
1676							logging => 0, # or 1
1677							testmode => , # or 'make', or 'foreach'
1678							);
1679
1680							I The values shown for options are the defaults, except for C, which doesn't have one.
1681
1682							=head2 Prompts
1683
1684							There are two ways to customize the prompt used to solicit choices from
1685							C
1686							all loops, or the C<$Prompt> variable, which can be set independently for
1687							each loop.
1688
1689							=head3 The prompt option
1690
1691							The C option is intended for use in
1692							programs that either contain a single C
1693							content to use the same prompt for every loop.
1694							It allows a custom interactive prompt to be set in the B statement.
1695
1696							The prompt string should not end in a whitespace character, because
1697							that doesn't look nice when the prompt is highlighted for display
1698							(usually in I).
1699							To offset the cursor from the prompt's end,
1700							I is inserted automatically
1701							after display highlighting has been turned off.
1702
1703							If the environment variable C<$ENV{Shell_POSIX_Select_prompt}>
1704							is present,
1705							its value overrides the one in the B statement.
1706
1707							The default prompt is "Enter number of choice:".
1708							To get the same prompt as provided by the Korn or Bash shell,
1709							use C<< prompt =>> Korn >> or C<< prompt => Bash >>.
1710
1711							=head3 The $Prompt variable
1712
1713							The programmer may also modify the prompt during execution,
1714							which may be desirable with nested loops that require different user instructions.
1715							This is accomplished by
1716							importing the $Prompt variable, and setting it to the desired prompt string
1717							before entering the loop. Note that imported variables have to be listed
1718							as the initial arguments to the C directive, and properly quoted.
1719							See L<"order.plx"> for an example.
1720
1721							NOTE: If the program's input channel is not connected to a terminal,
1722							prompting is automatically disabled
1723							(since there's no point in soliciting input from a I!).
1724
1725							=head2 $Heading
1726
1727							The programmer has the option of binding a heading to each loop's menu,
1728							by importing C<$Heading> and setting it just before entering the associated loop.
1729							See L<"order.plx"> for an example.
1730
1731							=head2 $Eof
1732
1733							A common concern with the Shell's C
1734							cases where a loop ends due to EOF detection, versus the execution of C
1735							(like Perl's C).
1736							Although the Shell programmer can check the C<$REPLY> variable to make
1737							this distinction, this implementation localizes its version of that variable
1738							(C<$Reply>) to the loop,
1739							obviating that possibility.
1740
1741							Therefore, to make EOF detection as convenient and easy as possible,
1742							the programmer may import C<$Eof> and check it for a
1743							I value after a C
1744							See L<"lc_filename.plx"> for a programming example.
1745
1746							=head2 Number of Columns
1747
1748							By default, the visual length of each option is examined,
1749							and the list is spread across as many columns as will reasonably fit in the terminal.
1750							You can override this behavior by importing and setting C<$MaxColumns>
1751							to the maximum number of columns you wish to display.
1752							See Scripts/max_columns_1.plx in the distribution as an example.
1753
1754							=head2 Styles
1755
1756							The C