view release on metacpan or  search on metacpan

EvaP.pm  view on Meta::CPAN

$Getopt::EvaP::VERSION |= '2.8';

package Getopt::EvaP; 

# EvaP.pm - Evaluate Parameters for Perl (the getopt et.al. replacement)
#
# Stephen.O.Lidie@Lehigh.EDU, 94/10/28
#
# Made to conform, as much as possible, to the C function evap. The C, Perl
# and Tcl versions of evap are patterned after the Control Data procedure
# CLP$EVALUATE_PARAMETERS for the NOS/VE operating system, although none
# approach the richness of CDC's implementation.
#
# Availability is via anonymous FTP from ftp.Lehigh.EDU in the directory
# pub/evap/evap-2.x.
#
# Stephen O. Lidie, Lehigh University Computing Center.
#
# Copyright (C) 1993 - 2014 by Stephen O. Lidie.  All rights reserved.
#
# This program is free software; you can redistribute it and/or modify it under
# the same terms as Perl itself.
#
# For related information see the evap/C header file evap.h.  Complete
# help can be found in the man pages evap(2), evap.c(2), EvaP.pm(2), 
# evap.tcl(2) and evap_pac(2).

require 5.002;
use Text::ParseWords;
use subs qw/evap_fin evap_parse_command_line evap_parse_PDT evap_PDT_error
    evap_set_value/;
use strict qw/refs subs/;
use Exporter;
@ISA = qw/Exporter/;
@EXPORT = qw/EvaP EvaP_PAC/;
@EXPORT_OK = qw/evap evap_pac/;

*EvaP = \&evap;			# new alias for good 'ol Evaluate Parameters
*EvaP_PAC = \&evap_pac;		# new alias for Process Application Commands

sub evap {			# Parameter Description Table, Message Module

    my($ref_PDT, $ref_MM, $ref_Opt) = @_;
    
    $evap_DOS = 0 unless defined $evap_DOS; # 1 iff MS-DOS, else Unix

    local($pdt_reg_exp1) = '^(.)(.)(.?)$';
    local($pdt_reg_exp2) = '^TRUE$|^YES$|^ON$|^1$';
    local($pdt_reg_exp3) = '^FALSE$|^NO$|^OFF$|^0$';
    local($pdt_reg_exp4) = '^\s*no_file_list\s*$';
    local($pdt_reg_exp5) = '^\s*optional_file_list\s*$';
    local($pdt_reg_exp6) = '^\s*required_file_list\s*$';
    local($full_help) = 0;
    local($usage_help) = 0;
    local($file_list) = 'optional_file_list';
    local($error) = 0;
    local($pkg) = (caller)[0];
    local($value, $rt, $type, $required, @P_PARAMETER, %P_INFO, %P_ALIAS,
	  @P_REQUIRED, %P_VALID_VALUES, %P_ENV, %P_SET);
    local($option, $default_value, $list, $parameter, $alias, @keys, 
	  $found, $length, %P_EVALUATE, %P_DEFAULT_VALUE);
    local(@local_pdt);
    local($lref_MM) = $ref_MM;	# maintain a local reference
    local($lref_Opt) = $ref_Opt;
    
    $evap_embed = 0 unless defined $evap_embed; # 1 iff embed evap
    if ($evap_embed) {		# initialize for a new call
	if (defined $lref_Opt) {
	    undef %$lref_Opt;
	} else {
	    no strict 'refs';
	    undef %{"${pkg}::Options"};
	    undef %{"${pkg}::options"};
	}
    }

    evap_parse_PDT $ref_PDT;
    return evap_parse_command_line;

} # end evap
 
sub evap_parse_PDT {
   
    # Verify correctness of the PDT.  Check for duplicate parameter names and
    # aliases.  Extract default values and possible keywords.  Decode the user
    # syntax and convert into a simpler form (ala NGetOpt) for internal use. 
    # Handle 'file list' too.

    my($ref_PDT) = @_;

    @local_pdt = @{$ref_PDT};   # private copy of the PDT
    unshift @local_pdt, 'help, h: switch'; # supply -help automatically
    @P_PARAMETER = ();		# no parameter names
    %P_INFO = ();		# no encoded parameter information
    %P_ALIAS = ();		# no aliases
    @P_REQUIRED = ();		# no required parameters
    %P_VALID_VALUES = ();	# no keywords
    %P_ENV = ();		# no default environment variables
    %P_EVALUATE = ();		# no PDT values evaluated yet
    %P_DEFAULT_VALUE = ();	# no default values yet
    %P_SET = ();        	# no sets yet

  OPTIONS:
    foreach $option (@local_pdt) {

	$option =~ s/\s*$//;	# trim trailing spaces
	next OPTIONS if $option =~ /^#.*|PDT\s+|pdt\s+|PDT$|pdt$/;
	$option =~ s/\s*PDTEND|\s*pdtend//;
	next OPTIONS if $option =~ /^ ?$/;
	
	if ($option =~ /$pdt_reg_exp4|$pdt_reg_exp5|$pdt_reg_exp6/) {
	    $file_list = $option; # remember user specified file_list
	    next OPTIONS;
	}
	
        ($parameter, $alias, $_) = 
	  ($option =~ /^\s*(\S*)\s*,\s*(\S*)\s*:\s*(.*)$/);

EvaP.pm  view on Meta::CPAN

                    $value = '>-';
                } elsif ($path[0] =~ /(^~$|^\$HOME$)/) {
		    $path[0] = $ENV{'HOME'};
                    $value = join '/', @path;
                }
            } # ifend file type

            if ($type =~ /^b$/) {
	        $value = '1' if $value =~ /$pdt_reg_exp2/i;
	        $value = '0' if $value =~ /$pdt_reg_exp3/i;
            } # ifend boolean type
        } # ifend evaluate

        if ($list) {		# extend list with new value
            if (defined $lref_Opt) {
                push @{$lref_Opt->{$hash_index}}, $value;
            } else {
                no strict 'refs';
	        push @{$option}, $value;
                $hash1->{$hash_index} = \@{$option};
                $hash2->{$hash_index} = \@{$option};
            }
        } else {		# store scalar value
            if (defined $lref_Opt) {
                $lref_Opt->{$hash_index} = $value;
            } else {
                no strict 'refs';
	        ${$option} = $value;
                $hash1->{$hash_index} = $value;
                $hash2->{$hash_index} = $value;
                # ${$hash2}{$hash_index} = $value; EQUIVALENT !
            }
        }

    } # forend
	
} # end evap_set_value

sub evap_isatty {

    my $in = shift;
    my $s = -t $in;
    return $s;

}

sub evap_pac {

    eval {
	require Term::ReadLine;
    };
    my $noReadLine = $@;

    # Process Application Commands - an application command can be envoked by entering either its full spelling or the alias.

    my($prompt, $I, %cmds) = @_;

    $noReadLine = 1 if not evap_isatty( $I );

    my($proc, $args, %long, %alias, $name, $long, $alias);
    my $pkg = (caller)[0];
    my $inp = ref($I) ? $I : "${pkg}::${I}";

    $evap_embed = 1;		# enable embedding
    $shell = (defined $ENV{'SHELL'} and $ENV{'SHELL'} ne '') ? 
        $ENV{'SHELL'} : '/bin/sh';
    foreach $name (keys %cmds) {
	$cmds{$name} = $pkg . '::' . $cmds{$name}; # qualify
    }
    $cmds{'display_application_commands|disac'} = 'evap_disac_proc(%cmds)';
    $cmds{'!'} = 'evap_bang_proc';

    # First, create new hash variables with full/alias names.

    foreach $name (keys %cmds) {
        if ($name =~ /\|/) {
            ($long, $alias) = ($name =~ /(.*)\|(.*)/);
	    $long{$long} = $cmds{$name};
	    $alias{$alias} = $cmds{$name};
        } else {
	    $long{$name} = $cmds{$name};
	}
    }

    my ( $term, $out );
    if ( $noReadLine ) {
	print STDOUT "$prompt";
    } else {
	$term = Term::ReadLine->new( $prompt );
	$OUT = $term->OUT || \*STDOUT;
    }
    my $eofCount = $ENV{IGNOREEOF};
    $eofCount = 0 unless defined $eofCount;

    no strict 'refs';
  GET_USER_INPUT:
    while ( 1 ) {
	if ( $noReadLine ) {
	    $_ = <$inp>;
	} else {
	    $_ = $term->readline( $prompt );
	}
	if ( not defined $_ ) {
	    $eofCount--;
	    last if $eofCount < 0;
	    print "\n";
	    next GET_USER_INPUT;
	}
	next GET_USER_INPUT if /^\s*$/;	# ignore empty input lines

	if (/^\s*!(.+)/) {
	    $_ = '! ' . $1;
	}

        ($0, $args) = /\s*(\S+)\s*(.*)/;
	if ( $0 =~ m/^help$|^h$/i ) {
	     $0 = 'disac';
	     $args = '-do f';
	}
	if (defined $long{$0}) {
	    $proc = $long{$0};