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.09';
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		123	$PKG = __PACKAGE__ ;
36	26					57	$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					1257	};
47	26	50				156	! defined $_import_called and $_import_called = 0;
48	26					1271	( $script = $0 ) =~ s\|^.*/\|\|;
49
50							}
51
52							sub import ; # advance declaration
53
54	26			26		11808	use File::Spec::Functions (':ALL');
	26					23522
	26					4477
55
56	26			26		196	use File::Spec::Functions 0.7;
	26					569
	26					2178
57	26			26		13710	use Filter::Simple 0.84;
	26					637249
	26					174
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		1724	use Text::Balanced 1.97 qw(extract_variable extract_bracketed);
	26					399
	26					1339
62
63	26			26		171	use Carp;
	26					58
	26					11349
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		222	use re 'eval';
	26					60
	26					163827
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	356560	my $subname = sub_name();
177	28					90	my $last_call = 0;
178	28					60	my $orig_string=$_;
179	28					101	my $detect_msg='';
180
181	28					82	++$::_FILTER_CALLS;
182
183	28	50				110	$orig_string ne $_ and die "$_ got trashed";
184
185							#/(..)/ and warn "Matched chars: '$1'\n"; # prime the pos marker
186
187	28					69	my $loopnum;
188							# Probably looping out of control if we get this many:
189	28					51	my $maxloops = 25;
190
191	28					47	my $first_celador;
192	28	50				93	if ( $last_call = ($_ eq "") ) {
193	0					0	return undef ;
194							}
195							else {
196							# TIMJI: Revisit; why is following the default?
197	28					223	$detect_msg="SELECT LOOP DETECTED";
198	28	50				84	$orig_string ne $_ and die "$_ got trashed";
199
200
201	28	50				77	$DEBUG > 1 and show_subs("**** Pre-Pre-WHILE **** \n","");
202	28	0	33			216	$DEBUG > 1 and $LOGGING and print LOG "\$_ is '$_'\n";
203
204	28					67	$loopnum=0;
205	28	50				109	$DEBUG > 1 and show_subs("**** Pre-WHILE **** \n","");
206
207	28					89	while (++$loopnum <= $maxloops) { # keep looping until we can't find any more select loops
208
209	65	100				184	$loopnum == 2 and $first_celador=$_;
210
211	65	50				157	$DEBUG > 1 and show_subs("**** LOOKING FOR LOOP **** #$loopnum\n","");
212	65	50				156	$loopnum > 25 and warn "$subname: Might be stuck in loop\n";
213	65	50				138	$loopnum > 100 and die "$subname: Probably was stuck in loop\n";
214	65	50	33			180	$DEBUG > 3 and pos() and warn "pos is currently: ", pos(), "\n";
215	65					180	pos()=0;
216	65	50	0			390	/\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					154	my ($matched, $can_rewrite) = 0;
222	65	50				215	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					109	my $pos;
233	65					465	my ($match, $start_match);
234	65					0	my ($got_kw,$got_decl, $got_loop_var, $got_list, $got_codeblock);
235	65					152	my $iteration=0;
236	68					156	FIND_LOOP:
237							my ($loop_var, $loop_decl, $loop_list, $loop_block)= ("" x 3);
238
239	68	50				409	$DEBUG_FILT > 0 and warn "Pos initially at ", pos($_), "\n";
240
241	68	50				224	!defined pos() and warn "AT FIND_LOOP, POS IS UNDEF\n";
242
243	68					152	$match=$got_kw=$got_decl=$got_loop_var=$got_list=$got_codeblock="";
244	68					105	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					97	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				1145	if ( m/$RE/g ) { # try to match keyword, "select"
251	40					73	++$matched ;
252	40					106	$match=$1;
253	40					90	$start_match=pos() - length $1;
254	40					67	$got_kw=1;
255	40	50				95	$DEBUG_FILT > 1 and show_progress($match, pos(), $_);
256							}
257							else {
258							# no more select keywords to process! # LOOP EXIT #1
259	28					1620	goto FILTER_EXIT;
260							}
261
262	40					65	$pos=pos(); # remember position
263
264	40	100				886	if (/\G$RE_decl/g) {
265	11					24	++$matched ;
266	11					24	$loop_decl=$1;
267	11					36	$match.=" $1";
268	11					23	$got_decl=1;
269							}
270							else {
271	29					90	pos()=$pos; # reset to where we left off
272							}
273	40	50				199	$DEBUG_FILT > 1 and show_progress($match, pos(), $_);
274
275	40					109	my @rest;
276	40	50				95	$DEBUG_FILT > 0 and warn "POS before ext-var is now ", pos(), "\n";
277
278	40					185	( $loop_var, @rest ) = extract_variable( $_ );
279	40	50				6851	$DEBUG_FILT > 0 and show_subs( "POST- ext-var string is: ", $_, pos(),19);
280
281	40	50				180	$DEBUG_FILT > 0 and warn "POS after ext-var is now ", pos(), "\n";
282
283	40	100	66			244	if (defined $loop_var and $loop_var ne "" ) {
284	26					81	$got_loop_var=1;
285	26	50				82	$DEBUG_FILT > 0 and warn "Got_Loop_Var matched '$loop_var'\n";
286	26					72	$match.=" $loop_var";
287							}
288							else {
289	14					55	pos()=$pos; # reset to where we left off
290	14	50				75	$DEBUG_FILT > 0 and warn "extract_variable failed to match\n";
291							}
292	40	50				108	$DEBUG_FILT > 1 and show_progress($match, pos(), $_);
293
294	40					166	gobble_spaces();
295
296							# $DEBUG_FILT > 0 and warn "Pre-extract_bracketed ()\n";
297	40					151	( $loop_list, @rest ) = extract_bracketed($_, '()');
298	40	50	33			6390	if (defined $loop_list and $loop_list ne "") {
299	40					109	++$matched;
300	40					74	$got_list=1;
301	40					102	$match.=" $loop_list";
302	40	50				159	$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					133	gobble_spaces();
328
329							# $DEBUG > 1 and warn " DDD sending to extract_bracketed() ===$_===\n";
330	40					143	( $loop_block, @rest ) = extract_bracketed($_, '{}');
331							# $DEBUG > 1 and warn " DDD extract_bracketed returned ===$loop_block===\n";
332	40	100	66			9655	if (defined $loop_block and $loop_block ne "") {
333	37					110	++$matched;
334	37					92	$got_codeblock=1;
335	37					124	$match.=" $loop_block";
336	37	50				128	$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				6	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				7	$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				6	$DEBUG_FILT > 0 and warn "giving up on this match; scanning for next keyword (2)";
353	3					20	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					66	my $end_match;
362	37	50				113	if ( $matched == 0 ) {
363	0					0	die" Can it ever get here?";
364	0					0	goto FILTER_EXIT;
365							}
366							else {
367	37					102	$end_match=pos();
368	37					65	$detect_msg='';
369	37	50				104	if ( $matched == 1 ) { # means "select" keyword only
370							;
371							}
372	37	50				216	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				92	if ( $matched > 1 ) { # 1 just means select->foreach conversion
387	37					69	$::_LOOP_COUNT++; # counts # detected select-loops
388	37	50				97	$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				122	$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				116	if ($can_rewrite) {
400	37					112	my $replacer = enloop_codeblock
401							matches2fields ( $loop_decl,
402							$loop_var,
403							$loop_list,
404							$loop_block ),
405							$::_LOOP_COUNT;
406
407	37					878	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				188	$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					53	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				98	$loopnum > 0 and $Shell::POSIX::Select::filter_output=$_;
436							# Restore original string-like parts of the code:
437	28					303	$Shell::POSIX::Select::filter_output =~ s/$Filter::Simple::placeholder/${$Filter::Simple::components[unpack('N',$1)]}/ge;
	180					316
	180					1264
438	28	50				146	$LOGGING and print USERPROG $_; # $_ unset 2nd call; label starts below
439	28	50				144	$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	83	my $subname = sub_name();
473	37					78	my $default_loopvar = 0;
474
475
476	37					62	my ( $debugging_code, $codeblock2, );
477	37					96	my ( $decl, $loop_var, $values, $codeblock, $fullmatch ) = @_;
478
479	37					68	$debugging_code = "";
480	37	50				128	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			296	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					5	$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			424	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				40	$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				43	$LOGGING and print LOG
524							"LOOP: Variable without declaration (okay): $loop_var"
525							}
526							else {
527	11	50				30	$LOGGING and print LOG "LOOP: zero-word declaration\n";
528
529	11					16	my $default_loopvar = 1;
530	11					26	($decl, $loop_var) = qw (local $_); # default loop var; package scope
531							}
532
533	37	100	66			265	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					8	$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			183	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				118	$DEBUG > 1 and warn "Pre-extract_variable 3\n";
550							# Now let's see if Damian likes it:
551	37					126	my ( $loop_var2, @rest ) = extract_variable($loop_var);
552	37	50				7377	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				106	!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					389	( $codeblock2 = $codeblock ) =~ s/\A\s\{\s\|\s\}\s\z//g;
570
571	37	50	33			225	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					200	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	100	my $subname = sub_name();
579
580	37					105	$Shell::POSIX::Select::_ENLOOP_CALL_COUNT++;
581
582	37					104	my ( $decl, $loop_var, $values, $codestring, $dcode, $loopnum ) = @_;
583
584	37	50	33			254	(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			280	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					105	my $arrayname = $PKG . '::looplist';
595	37					85	my $NL = '\n';
596
597							# Now build the code for the user-prog to run
598	37					63	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					192	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			100	$LOGGING and (print PART1 $parts[0] or _DIE "failed to write to PART1\n");
612	37	50				122	$DEBUG > 4 and warn "SETTING $arrayname to $values\n";
613
614	37					258	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			170	$LOGGING and (print PART2 $parts[1] or _DIE "failed to write to PART1\n");
628
629	37	50				164	$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					74	local $^W=0;
	37					282
640	37					1321	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			162	$LOGGING and (print PART3 $parts[2] or _DIE "failed to write to PART3\n");
777
778	37					138	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			115	$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					860	return ( join "", @parts ); # return assembled code, for user to run
790							} # enloop_codeblock
791
792							sub make_menu {
793	22			22	0	85	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					71	my ($heading) = shift;
802	22					66	my ($prompt) = shift;
803	22					73	my (@values) = @_;
804	22	100				85	unless (@values) {
805	4					22	return ( undef, undef ); # can't make menu out of nothing!
806							}
807	18					57	my ( $l, $l_length ) = 0;
808	18					36	my $count = 5;
809	18					54	my ( $sep, $padding ) = "" x 2;
810	18					36	my $choice = "";
811
812
813							# Find longest string value in selection list
814	18					43	my $v_length = 0;
815
816	18					92	for ( my $i = 0 ; $i < @values ; $i++ ) {
817	35	100				165	( $l = length $values[$i] ) > $v_length and $v_length = $l;
818							}
819	18	0	33			111	$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			91	$DEBUG > 3 and $LOGGING and print LOG "Number of values is ", scalar @values, "\n";
823
824
825	18	50				158	@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			78	$DEBUG > 3 and $LOGGING and print LOG "Label length is $l_length\n";
833
834	18	50				71	if ( !defined $l_length ) { return undef; }
	0					0
835
836	18					46	$sep = "\040\040";
837	18					40	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					53	my $one_label = ( $l_length + 2 ) + $v_length + $l_sep;
845	18					79	my $columns = int( $COLS / $one_label );
846	18	50				107	$columns < 1 and $columns = 1;
847							# Do not let the number of columns grow beyond the maximum:
848	18	50				112	if ($MaxColumns < $columns)
849							{
850	0					0	$columns = $MaxColumns;
851							} # if
852
853							# $DEBUG > 3 and
854							#HERE
855	18	50				100	$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			161	$Shell::POSIX::Select::_default_prompt;
		100
865							;
866
867	18	0	33			66	$DEBUG > 3 and $LOGGING and print LOG "Making menu\n";
868
869							{
870	18					35	local $, = "\n";
	18					61
871							}
872
873	18					36	my $menu;
874	18	50				81	$menu = defined $heading ? "${ON}$heading$OFF" : "" ;
875	18					45	$menu.="\n";
876							# $columns == 0 and die "Columns is zero!";
877	18					93	for ( my $i = 0, my $j = 1 ; $i < @values ; $i++, $j++ ) {
878	35					190	$menu .= sprintf "%${l_length}d) %-${v_length}s$sep", $j, $values[$i];
879	35	50				176	$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					133	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	2145	my $callers_name = (caller 1)[3] ;
925	320	50				1027	if ( ! defined $callers_name ) {
926	0					0	$callers_name='Main_program'; # must be call from main
927							}
928							else {
929	320					1810	$callers_name =~ s/^.*:://; # strip package name
930	320					712	$callers_name .= '()'; # sub_name -> sub_name()
931							}
932	320					712	return $callers_name;
933							} # sub_name
934
935							sub _WARN {
936	27			27		75	my $subname = sub_name();
937	27	50				7629	$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	19	my $subname = sub_name();
1203
1204							# $offset = (caller)[2]+1;
1205	8					17	my $pkg = shift;
1206	26			26		2006	no strict 'refs';
	26					64
	26					47652
1207							# All exports are scalard vars, so strip sigils and poke in package name
1208	8					20	foreach ( map { s/^\$//; $_ } @_ ) { # must change $Reply to Reply, etc.
	11					30
	11					34
1209	11					61	*{"${pkg}::$_"} =
1210	11					21	\${ "Shell::POSIX::Select::$_" };
	11					34
1211							# "Shell::POSIX::Select::$_";
1212							}
1213							# *{"${pkg}::__"} = \&__ if grep /__/, @_;
1214	8					20	1;
1215							}
1216
1217							sub hash_options {
1218	27			27	0	49	my $ref_legal_keys = shift;
1219	27					58	my %options = @_ ;
1220	27					59	my $num_options=keys %options;
1221	27					43	my %options2 ;
1222
1223	27					58	my $subname = sub_name();
1224
1225
1226
1227	27	100				81	if ($num_options) {
1228							my @legit_options =
1229	1					12	grep { "@$ref_legal_keys" =~ /\b $_ \b/x }
	1					17
1230							sort ignoring_case keys %options;
1231
1232							my @illegit_options =
1233	1					4	grep { "@$ref_legal_keys" !~ /\b $_ \b/x }
	1					10
1234							sort ignoring_case keys %options;
1235
1236							@options2{sort ignoring_case @legit_options} =
1237	1					5	@options{sort ignoring_case @legit_options } ;
1238							{ # scope for local change to $,
1239	1					2	local $,=' ';
	1					1
1240	1	50				4	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					90	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	209	my $subname = sub_name();
1270
1271	80					183	my $pos=pos(); # remember current position
1272	80	100				260	if (/\G\s+/g) {
1273	74	50				195	$DEBUG_FILT > 1 and
1274							warn "$subname: space gobbler matched '$&' of length ", length $&, "\n" ;
1275							}
1276							else {
1277	6	50				26	$DEBUG_FILT > 1 and warn "$subname: space gobbler matched nothing\n";
1278	6					16	pos()=$pos; # reset to prior position
1279							}
1280	80					157	$pos=pos(); # identify current position
1281							}
1282
1283							sub display_control {
1284	27			27	0	67	my $subname = sub_name();
1285
1286	27					68	my $flag=shift;
1287	27					63	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				73	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			404	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				181	if ( $ENV{Shell_POSIX_Select_reference} ) {
1316							}
1317							else {
1318							}
1319	26					92	my $pwd=curdir();
1320							# $Shell::POSIX::Select::_TTY and
1321							# dump filtered source, for reference or analysis
1322	26	50				2693	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			1094	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					127	$\|=1;
1366	27					91	select ($old_fh);
1367	27					48	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