view release on metacpan or  search on metacpan

lib/Shell/POSIX/Select.pm  view on Meta::CPAN

		$LOGGING and log_files();

		$ENV{Shell_POSIX_Select_reference} and
			$Shell::POSIX::Select::dump_data = 'Ref_Data';

		# Don't assume /dev/tty will work on user's platform!
		if ( $Shell::POSIX::Select::dump_data ) {

			# must ensure all output gets flushed to dumpfile before exiting
			disable_buffering();

			#if ( ! $PRODUCTION ) {
				$Shell::POSIX::Select::_TTY=0;
				# What's the OS-portable equivalent of "/dev/tty" in the above?
				if ( -c '/dev/tty' ) {
					if ( open TTY,	'> /dev/tty' ) {
						$Shell::POSIX::Select::_TTY=1;
					}
					else {
							_WARN "Open of /dev/tty failed, $!\n";	
					}
				}
			#}

                        $sdump = qq/$script.sdump/;
                        if ($Shell::POSIX::Select::dump_data =~ /[a-z]/i)
                          {
                          $sdump = catfile($Shell::POSIX::Select::dump_data, $sdump .'_ref');
                          }
                        else
                          {
                          # TODO: probably should put it in the same
                          # folder as the original program being
                          # analyzed, rather than '.':
                          $sdump = catfile('.', $sdump);
                          }
			($cdump = $sdump) =~ s/$script\.sdump/$script.cdump/;	# make code-dump name too

# HERE next two lines squelch


			# Make reference copies of dumps for distribution, or test copies,
			# depending on ENV{reference} set or testmode=make
			close STDERR or
				die "$PKG-END(): Failed to close 'STDERR', $!\n";
			open STDERR, "> $sdump" or
				die "$PKG-END(): Failed to open '$sdump' for writing, $!\n";

			open STDOUT, ">&STDERR" or
				die "$PKG-END(): Failed to dup STDOUT to STDERR, $!\n";
		}

	( $ON , $OFF , $BOLD ,  $SGR0 , $COLS ) =
		display_control ($Shell::POSIX::Select::dump_data);
		1;
} # import

sub export {	# appropriated from Switch.pm
	my $subname = sub_name();

	# $offset = (caller)[2]+1;
	my $pkg = shift;
	no strict 'refs';
# All exports are scalard vars,  so strip sigils and poke in package name
	foreach ( map {  s/^\$//; $_ } @_ ) {	# must change $Reply to Reply, etc.
		*{"${pkg}::$_"} =
			\${ "Shell::POSIX::Select::$_" };
				# "Shell::POSIX::Select::$_";
	}
	# *{"${pkg}::__"} = \&__ if grep /__/, @_;
	1;
}

sub hash_options {
	my $ref_legal_keys = shift;
	my %options = @_   ;
	my $num_options=keys %options;
	my %options2 ; 

	my $subname = sub_name();



	if ($num_options) {
		my @legit_options =
			grep { "@$ref_legal_keys" =~ /\b $_ \b/x }
				sort ignoring_case keys %options;

		my @illegit_options =
			grep { "@$ref_legal_keys" !~ /\b $_ \b/x }
				sort ignoring_case keys %options;

		@options2{sort ignoring_case @legit_options} =
			@options{sort ignoring_case @legit_options } ;
			{ # scope for local change to $,
		  local $,=' ';
		  if ($num_options > keys %options2) { # options filtered out?
			my $msg= "$PKG\::$subname:\n  Invalid options: " ;
			$msg .= "@illegit_options\n";
			_DIE;	# Can't be conditional on DEBUG setting,
						# because that comes after this sub returns!
			}
		}

	}

	return %options2;
}

sub show_subs {
		# show sub-string in reverse video, primarily for debugging
		my $subname = sub_name();

		 @_ >= 1 or die "${PKG}\::subname: no arguments\n" ;
		 my $msg=shift || '<no msg>';
		 my $string=(shift || '');
		 my $start=(shift || 0);
		 my $length=(shift || 9999);

		 $string =~ s/[^[[:alpha:]\d\s]]/-/g;	# control-chars screw up printing
# warn "Calling substr for parms $string/$start/$length\n";