declare.pm

基于稀疏网络的精选机器学习模型

package Getopt::Declare;

use strict;
use vars qw($VERSION);
use vars qw($PROPER_NAME);
use UNIVERSAL qw(isa);

$VERSION = '1.09';


package Getopt::Declare::StartOpt;

sub new        { bless {} }
sub matcher    { '(?:()' }
sub code       { '' }
sub cachecode  { '' }
sub trailer    { undef }
sub ows	       { return $_[1]; }

package Getopt::Declare::EndOpt;

sub new        { bless {} }
sub matcher    { '())?' }
sub code       { '' }
sub cachecode  { '' }
sub trailer    { undef }
sub ows	       { return $_[1]; }

package Getopt::Declare::ScalarArg;

my %stdtype = ();

sub _reset_stdtype
{
	%stdtype = 
	(
		':i'	=> { pattern => '(?:(?:%T[+-]?)%D+)' },
		':n'	=> { pattern => '(?:(?:%T[+-]?)(?:%D+(?:%T\.%D*)?(?:%T[eE]%D+)?'
					. '|%T\.%D+(?:%T[eE]%D+)?))' },
		':s'	=> { pattern => '(?:%T(?:\S|\0))+' },
		':qs'	=> { pattern => q{"(?:\\"|[^"])*"|'(?:\\'|[^"])*|(?:%T(?:\S|\0))+} },
		':id'	=> { pattern => '%T[a-zA-Z_](?:%T\w)*' },
		':if'	=> { pattern => '%F(?:%T(?:\S|\0))+',
			     action => '{reject(!defined $_VAL_ || $_VAL_ ne "-" && ! -r $_VAL_, "in parameter \'$_PARAM_\' (file \"$_VAL_\" is not readable)")}' },
		':of'	=> { pattern => '%F(?:%T(?:\S|\0))+',
			     action => '{reject (!defined $_VAL_ || $_VAL_ ne "-" && -e $_VAL_ && ! -w $_VAL_ , "in parameter \'$_PARAM_\' (file \"$_VAL_\" is not writable)")}' },
		''	=> { pattern => ':s', ind => 1 },

		':+i'	=> { pattern => ':i',
			     action => '{reject (!defined $_VAL_ || $_VAL_<=0, "in parameter \'$_PARAM_\' ($_VAR_ must be an integer greater than zero)")}',
			     ind => 1},

		':+n'	=> { pattern => ':n',
			     action => '{reject (!defined $_VAL_ || $_VAL_<=0, "in parameter \'$_PARAM_\' ($_VAR_ must be a number greater than zero)")}',
			     ind => 1},

		':0+i'	=> { pattern => ':i',
			     action => '{reject (!defined $_VAL_ || $_VAL_<0, "in parameter \'$_PARAM_\' ($_VAR_ must be an positive integer)")}',
			     ind => 1},

		':0+n'	=> { pattern => ':n',
			     action => '{reject (!defined $_VAL_ || $_VAL_<0, "in parameter \'$_PARAM_\' ($_VAR_ must be a positive number)")}',
			     ind => 1},

	);
}

sub stdtype	# ($typename)
{
	my $name = shift;
	my %seen = ();
	while (!$seen{$name} && $stdtype{$name} && $stdtype{$name}->{ind})
		{ $seen{$name} = 1; $name = $stdtype{$name}->{pattern} }

	return undef if $seen{$name} || !$stdtype{$name};
	return $stdtype{$name}->{pattern};
}

sub stdactions	# ($typename)
{
	my $name = shift;
	my %seen = ();
	my @actions = ();
	while (!$seen{$name} && $stdtype{$name} && $stdtype{$name}->{ind})
	{
		$seen{$name} = 1;
		push @actions, $stdtype{$name}->{action}
			if $stdtype{$name}->{action};
		$name = $stdtype{$name}->{pattern}
	}
	push @actions, $stdtype{$name}->{action}
		if $stdtype{$name}->{action};

	return @actions;
}

sub addtype 	# ($abbrev, $pattern, $action, $ref)
{
	my $typeid = ":$_[0]";
	unless ($_[1] =~ /\S/) { $_[1] = ":s" , $_[3] = 1; }
	$stdtype{$typeid} = {};
	$stdtype{$typeid}->{pattern} = "(?:$_[1])" if $_[1] && !$_[3];
	$stdtype{$typeid}->{pattern} = ":$_[1]" if $_[1] && $_[3];
	$stdtype{$typeid}->{action} = $_[2] if $_[2];
	$stdtype{$typeid}->{ind} = $_[3];
}

sub new		# ($self, $name, $type, $nows)
{
	bless
	{	name => $_[1],
		type => $_[2],
		nows => $_[3],
	}, ref($_[0])||$_[0];
}

sub matcher	# ($self, $trailing)
{
	my ($self, $trailing) = @_;
	#WAS: $trailing = $trailing ? '(?!\Q'.$trailing.'\E)' : '';
	$trailing = $trailing ? '(?!'.quotemeta($trailing).')' : '';
	my $stdtype = stdtype($self->{type});

	if (!$stdtype && $self->{type} =~ m#\A:/([^/]+)/\Z#) { $stdtype = $1; }
	if (!$stdtype)
	{
		die "Error: bad type in Getopt::Declare parameter variable specification near '<$self->{name}$self->{type}>'\n";
	}
	$stdtype =~ s/\%D/(?:$trailing\\d)/g;
	$stdtype =~ s/\%T/$trailing/g;
	unless ($stdtype =~ s/\%F//)
	{
		$stdtype = Getopt::Declare::Arg::negflagpat().$stdtype;
	}
	return "(?:$stdtype)";
}

sub code	# ($self, $pos, $package)
{
	my $code = '
		$_VAR_ = q|<' . $_[0]->{name} . '>|;
		$_VAL_ = defined $' . ($_[1]+1) . '? $' . ($_[1]+1) . ': undef;
		$_VAL_ =~ tr/\0/ / if $_VAL_;';

	my @actions = stdactions($_[0]->{type});
	foreach ( @actions )
	{
		s/(\s*\{)/$1 package $_[2]; /;
		$code .= "\n\t\tdo $_;";
	}

	$code .= '
		my $' . $_[0]->{name} . ' = $_VAL_;';

	return $code;
}

sub cachecode	# ($self, $ownerflag, $itemcount)
{
	return "\t\t\$self->{'$_[1]'}{'<$_[0]->{name}>'} = \$$_[0]->{name};\n"
		if $_[2] > 1;
	return "\t\t\$self->{'$_[1]'} = \$$_[0]->{name};\n";
}

sub trailer { '' };	# MEANS TRAILING PARAMETER VARIABLE

sub ows	      
{
	return '(?:\s|\0)*('.$_[1].')' unless $_[0]->{nows};
	return '('.$_[1].')';
}


package Getopt::Declare::ArrayArg;

use vars qw { @ISA };
@ISA = qw ( Getopt::Declare::ScalarArg );

sub matcher	# ($self, $trailing)
{
	my ($self, $trailing) = @_;
	my $suffix = (defined $trailing && !$trailing) ? '\s+' : '';
	my $scalar = $self->SUPER::matcher($trailing);

	return $scalar.'(?:\s+'.$scalar.')*'.$suffix;
}

sub code	# ($self, $pos, $package)
{
	my $code = '
		$_VAR_ = q|<' . $_[0]->{name} . '>|;
		$_VAL_ = undef;
		my @' . $_[0]->{name} . ' =
			map { tr/\0/ /; $_ } split " ", $'.($_[1]+1)."||'';\n";


	my @actions = Getopt::Declare::ScalarArg::stdactions($_[0]->{type});
	if (@actions)
	{
		$code .= '
		foreach $_VAL_ ( @' . $_[0]->{name} . ' )
		{';
		foreach ( @actions )
		{
			s/(\s*\{)/$1 package $_[2]; /;
			$code .= "\t\t\tdo $_;\n";
		}
		$code .= '
		}';
	}
	return $code;
}

sub cachecode	# ($self, $ownerflag, $itemcount)
{
	return "\t\t\$self->{'$_[1]'}{'<$_[0]->{name}>'} = []
			unless \$self->{'$_[1]'}{'<$_[0]->{name}>'};
		push \@{\$self->{'$_[1]'}{'<$_[0]->{name}>'}}, \@$_[0]->{name};\n"
			if $_[2] > 1;
	return "\t\t\$self->{'$_[1]'} = []
			unless \$self->{'$_[1]'};
		push \@{\$self->{'$_[1]'}}, \@$_[0]->{name};\n";
}


package Getopt::Declare::Punctuator;

sub new		# ($self, $text, $nows)
{
	bless { text => $_[1], nows => $_[2] }
}

sub matcher	# ($self, $trailing)
{
	#WAS: Getopt::Declare::Arg::negflagpat() . '\Q' . $_[0]->{text} . '\E';
	Getopt::Declare::Arg::negflagpat() . quotemeta($_[0]->{text});
}

sub code	# ($self, $pos)
{
	"
		\$_PUNCT_{'" . $_[0]->{text} . "'" . '} = $' . ($_[1]+1) . ";\n";
}

sub cachecode	# ($self, $ownerflag, $itemcount)
{
	return "\t\t\$self->{'$_[1]'}{'$_[0]->{text}'} = \$_PUNCT_{'$_[0]->{text}'};\n"
		if $_[2] > 1;
	return "\t\t\$self->{'$_[1]'} = \$_PUNCT_{'$_[0]->{text}'};\n";
}

sub trailer  { $_[0]->{text} };

sub ows	      
{
	return '(?:\s|\0)*('.$_[1].')' unless $_[0]->{nows};
	return '('.$_[1].')';
}


package Getopt::Declare::Arg;

use Text::Balanced qw( extract_bracketed );

my $nextID = 0;

my @helpcmd = qw( -help --help -Help --Help -HELP --HELP -h -H );
my %helpcmd = map { $_ => 1 } @helpcmd;

sub besthelp { foreach ( @helpcmd ) { return $_ if exists $helpcmd{$_}; } }
sub helppat  { return join '|', keys %helpcmd; }

my @versioncmd = qw( -version --version -Version --Version
		     -VERSION --VERSION -v -V );
my %versioncmd = map { $_ => 1 } @versioncmd;

sub bestversion {foreach (@versioncmd) { return $_ if exists $versioncmd{$_}; }}
sub versionpat  { return join '|', keys %versioncmd; }

my @flags;
my $posflagpat = '';
my $negflagpat = '';
sub negflagpat
{
	$negflagpat = join '', map { "(?!".quotemeta($_).")" } @flags
		if !$negflagpat && @flags;
	return $negflagpat;
}

sub posflagpat
{
	$posflagpat = '(?:'.join('|', map { quotemeta($_) } @flags).')'
		if !$posflagpat && @flags;
	return $posflagpat;
}

sub new		# ($class, $spec, $desc, $dittoflag)
{
	my ($class,$spec,$desc,$ditto) = @_;
	my $first = 1;
	my $arg;
	my $nows;

	my $self =
	{
		flag 	     => '',
		args	     => [],
		actions	     => [],
		ditto	     => $ditto,
		required     => 0,
		requires     => '',
		ID	     => $nextID++,
		desc	     => $spec,
		items	     => 0,
	};

	$self->{desc} =~ s/\A\s*(.*?)\s*\Z/$1/;

	while ($spec)
	{
	# OPTIONAL
		if ($spec =~ s/\A(\s*)\[/$1/)
		{
			push @{$self->{args}}, new Getopt::Declare::StartOpt;
			next;
		}
		elsif ($spec =~ s/\A\s*\]//)
		{
			push @{$self->{args}}, new Getopt::Declare::EndOpt;
			next;
		}

	# ARG

		($arg,$spec,$nows) = extract_bracketed($spec,'<>');
		if ($arg)
		{
			$arg =~ m/\A(\s*)(<)([a-zA-Z]\w*)(:[^>]+|)>/ or
				die "Error: bad Getopt::Declare parameter variable specification near '$arg'\n";

			my @details = ( $3, $4, !$first && !length($nows) );  # NAME,TYPE,NOWS

			if ($spec =~ s/\A\.\.\.//)	# ARRAY ARG
			{
				push @{$self->{args}},
					new Getopt::Declare::ArrayArg (@details);
			}
			else	# SCALAR ARG
			{
				push @{$self->{args}},
					new Getopt::Declare::ScalarArg (@details);
			}
			$self->{items}++;
			next;
		}

	# PUNCTUATION

		elsif ( $spec =~ s/\A(\s*)((\\.|[^] \t\n[<])+)// )
		{
			my ($ows, $punct) = ($1,$2);
			$punct =~ s/\\(?!\\)(.)/$1/g;
			if ($first) { $self->{flag} = $punct; push @flags, $punct; }

			else	    { push @{$self->{args}},
					new Getopt::Declare::Punctuator ($punct,!length($ows));
				      $self->{items}++; }

		}

		else { last; }

	}
	continue
	{
		$first = 0;
	}

	delete $helpcmd{$self->{flag}} if exists $helpcmd{$self->{flag}};
	delete $versioncmd{$self->{flag}} if exists $versioncmd{$self->{flag}};

	bless $self;
}

sub code
{
	my ($self, $owner,$package) = @_;

	my $code = "\n";
	my $flag = $self->{flag};
	my $clump = $owner->{_internal}{clump};
	my $i = 0;
	my $nocase = (Getopt::Declare::_nocase() || $self->{nocase} ? 'i' : '');

	$code .= (!$self->{repeatable})
			? q#	    param: while (!$_FOUND_{'# . $self->name . q#'}#
			: q#	    param: while (1#;

	if ($flag && ($clump==1 && $flag !~ /\A[^a-z0-9]+[a-z0-9]\Z/i
		  || ($clump<3 && @{$self->{args}} )))
	{
		$code .= q# && !$_lastprefix#;
	}

	$code .= q#)
	    {
		pos $_args = $_nextpos if defined $_args;
		%_PUNCT_ = ();#;

	if ($flag)
	{
		#WAS: $_args =~ m/\G(?:\s|\0)*\Q# . $flag . q#\E/g# . $nocase
		$code .= q#
	
		$_args && $_args =~ m/\G(?:\s|\0)*# . quotemeta($flag) . q#/g# . $nocase
		. q# or last;
		$_errormsg = q|incorrect specification of '# . $flag . q#' parameter| unless $_errormsg;

		#;
	}
	elsif ((Getopt::Declare::ScalarArg::stdtype($self->{args}[0]{type})||'') !~ /\%F/)
	{
		$code .= q#
	
		last if $_errormsg;

		#;
	}

	$code .= q#
		$_PARAM_ = '# . $self->name . q#';
		#;
	my @trailer;
	$#trailer = @{$self->{args}};
	for ($i=$#{$self->{args}} ; $i>0 ; $i-- )
	{
		$trailer[$i-1] = $self->{args}[$i]->trailer();
		$trailer[$i-1] = $trailer[$i] unless defined $trailer[$i-1];
	}

	if (@{$self->{args}})
	{
		$code .= '
			$_args && $_args =~ m/\G';

		for ($i=0; $i < @{$self->{args}} ; $i++ )
		{
		    $code .=
			$self->{args}[$i]->ows($self->{args}[$i]->matcher($trailer[$i]))
		}

		$code .= '/gx' . $nocase . ' or last;'
	}


	for ($i=0; $i < @{$self->{args}} ; $i++ )
	{
		$code .= $self->{args}[$i]->code($i,$package);	#, $flag ????
	}

	if ($flag)
	{
	    $code .= q#
		if (exists $_invalid{'# . $flag . q#'})
		{
			$_errormsg = q|parameter '# . $flag
				  . q#' not allowed with parameter '|
				  . $_invalid{'# . $flag . q#'} . q|'|;
			last;
		}
		else
		{
			foreach (#
			. ($owner->{_internal}{mutex}{$flag}
			    ? join(',', map {"'$_'"} @{$owner->{_internal}{mutex}{$flag}})
			    : '()')
			. q#)
			{
				$_invalid{$_} = '# . $flag . q#';
			}