File Coverage

blib/lib/Shell/POSIX/Select.pm

Criterion	Covered	Total	%
statement	256	366	69.9
branch	105	290	36.2
condition	38	144	26.3
subroutine	21	28	75.0
pod	0	16	0.0
total	420	844	49.7

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