declare.pm

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

sub _mutex	# (\%mutex, @list)
{
	my ($mref, @mutexlist) = @_;

	foreach my $flag ( @mutexlist )
	{
		$mref->{$flag} = [] unless $mref->{$flag};
		foreach my $otherflag ( @mutexlist )
		{
			next if ($flag eq $otherflag);
			push @{$mref->{$flag}}, $otherflag;
		}
	}
}

sub _exclude	# (\%mutex, $excluded, @list)
{
	my ($mref, $excluded, @mutexlist) = @_;

	foreach my $flag ( @mutexlist )
	{
		unless ($flag eq $excluded)
		{
			$mref->{$flag} = [] unless $mref->{$flag};
			push @{$mref->{$excluded}}, $flag;
			push @{$mref->{$flag}}, $excluded;
		}
	}
}

sub version
{
	# my $filedate = localtime(time - 86400 * -M $0);
	my $filedate = localtime((stat $0)[9]);
	my $proper_name;
	if ($::PROPER_NAME) { $proper_name = $::PROPER_NAME; }
	else { $proper_name = $0; }
	if ($::VERSION) { print "  $proper_name: version $::VERSION  ($filedate)\n\n" }
	else		{ print "  $proper_name: version dated $filedate\n\n" }
	exit $_[1] if defined $_[1];
}

sub usage
{
	my $self = $_[0];
	local $_ = $self->{_internal}{usage};
	
	my $lastflag = undef;
	my $lastdesc = undef;

	my $usage = '';
	my $uoff;
	my $decfirst;
	my $ditto;

	while (length $_ > 0)
	{
	# COMMENT:
		s/\A[ 	]*#.*\n// and next;

	# TYPE DIRECTIVE:

		if (m/\A\s*\[pvtype:/ and extract_codeblock($_,'[{}]'))
		{
			next;
		}

	# ACTION
		extract_codeblock
			and do { s/\A[ 	]*\n//;
				 $decfirst = 0 unless defined $decfirst;
				 next; };

	# ARG + DESC:
		if ( s/\A(.*?\S.*?\t+)(.*?\n)// )
		{
			$decfirst = 0 unless defined $decfirst;

			my ($spec) = expand $1;
			my ($desc) = expand $2;

			$desc .= (expand $1)[0]
				while s/\A((?![ 	]*({|\n)|.*?\S.*?\t.*?\S).*?\S.*\n)//;

			next if $desc =~ /\[undocumented\]/i;

			$uoff = 0;
			$spec =~ s/(<[a-zA-Z]\w*):([^>]+)>/$uoff+=1+length $2 and "$1>"/ge;
			$ditto = $desc =~ /\A\s*\[ditto\]/;
			$desc =~ s/^\s*\[.*?\]\s*\n//gm;
			$desc =~ s/\[.*?\]//g;

			if ($ditto)
				{ $desc = ($lastdesc? _ditto($lastflag,$lastdesc,$desc) : "" ) }
			elsif ($desc =~ /\A\s*\Z/)
				{ next; }
			else
				{ $lastdesc = $desc; }
			$spec =~ /\A\s*(\S+)/ and $lastflag = $1;

			$usage .= $spec . ' ' x $uoff . $desc;

			next;
		};


	# OTHERWISE, DECORATION
		if (s/((?:(?!\[pvtype:).)*)(\n|(?=\[pvtype:))//)
		{
			my $desc = $1.($2||'');
			$desc =~ s/^(\s*\[.*?\])+\s*\n//gm;
			$desc =~ s/\[.*?\]//g;
			$decfirst = 1 unless defined $decfirst
						or $desc =~ m/\A\s*\Z/;
			$usage .= $desc;
		}
	}

	my $required = '';

	foreach my $arg ( @{$self->{_internal}{args}} )
	{
		if ($arg->{required})
		{
			$required .= ' ' . $arg->{desc} . ' ';
		}
	}

	$usage =~ s/\255/[/g;	# REINSTATE ESCAPED '['s

	$required =~ s/<([a-zA-Z]\w*):[^>]+>/<$1>/g;

	my $helpcmd = Getopt::Declare::Arg::besthelp;
	my $versioncmd = Getopt::Declare::Arg::bestversion;

	my $PAGER = \*STDOUT;

	if (eval { require IO::Pager })
	{
		$PAGER = new IO::Pager ( resume => 1 );
	}

	unless ($self->{_internal}{source})
	{
		version;
		print $PAGER  "Usage: $0 [options] $required\n";
		print $PAGER  "       $0 $helpcmd\n" if $helpcmd;
		print $PAGER  "       $0 $versioncmd\n" if $versioncmd;
		print $PAGER  "\n" unless $decfirst && $usage =~ /\A[ \t]*\n/;
	}
	print $PAGER  "Options:\n" unless $decfirst;
	print $PAGER  $usage;

	exit $_[1] if defined $_[1];
}

sub unused {
	return @{$_[0]->{_internal}{unused}} if wantarray;
	return join " ", @{$_[0]->{_internal}{unused}};
}

sub flatten {
	my ($val, $nested) = @_;
	if (ref $val eq 'ARRAY') {
		return join " ", map {flatten($_,1)} @$val;
	}
	elsif (ref $val eq 'HASH') {
		return join " ", map {
				$nested || /^-/ ? ($_, flatten($val->{$_},1))
				                : (flatten($val->{$_},1))
			} keys %$val;
	}
	else {
		return $val;
	}
}

sub used {
	my $self = shift;
	my @used = map { /^_/ ? () : ($_, $self->{$_}) } keys %$self;
	return @used if wantarray;
	return join " ", map { flatten $_ } @used;
}

sub code
{
	my $self = shift;
	my $package = shift||'main';
	my $code = q#

	do
	{
	  my @_deferred = ();
	  my @_unused = ();
	  sub # . $package . q#::defer (&);
	  {
	    package # . $package . q#; local $^W;
	    *defer = sub (&) { push @_deferred, $_[0]; }
	  }
	  my %_FOUND_ = ();
	  my $_errors = 0;
	  my $_nextpos;
	  my %_invalid = ();
	  my $_lastprefix = '';
	  my $_finished = 0;
	  my %_PUNCT_;
	  my $_errormsg;
	  my $_VAL_;
	  my $_VAR_;
	  my $_PARAM_;

	  sub # . $package . q#::reject (;$$);
	  sub # . $package . q#::finish (;$);

	  {
	    package # . $package . q#; local $^W; 
	    *reject = sub (;$$) { local $^W; if (!@_ || $_[0]) { $_errormsg = $_[1] if defined $_[1]; last param; } };
	    *finish = sub (;$) { if (!@_ || $_[0]) { $_finished = 1; } };
	  }

	  $_nextpos = 0;
	  arg: while (!$_finished)
	  {
		$_errormsg = '';
		# . ( $self->{_internal}{clump} ? q#
		while ($_lastprefix)
		{
			my $substr = substr($_args,$_nextpos);
			$substr =~ m/\A(?!\s|\0|\Z)#
				. Getopt::Declare::Arg::negflagpat() . q#/
				or do { $_lastprefix='';last};
			"$_lastprefix$substr" =~ m/\A(#
				.  Getopt::Declare::Arg::posflagpat()
				. q#)/
				or do { $_lastprefix='';last};
			substr($_args,$_nextpos,0) = $_lastprefix;
			last;
		}
		# : '') . q#
		pos $_args = $_nextpos if defined $_args;

		$self->usage(0) if $_args && $_args =~ m/\G(# . $self->{_internal}{helppat} . q#)(\s|\0|\Z)/g;
		$self->version(0) if $_args && $_args =~ m/(# . $self->{_internal}{verspat} . q#)(\s|\0|\Z)/;

	#;

	foreach my $arg ( @{$self->{_internal}{args}} )
	{
		$code .= $arg->code($self,$package);
	}
	
	$code .= q#

	  if ($_lastprefix)
	  {
		  pos $_args = $_nextpos+length($_lastprefix);
		  $_lastprefix = '';
		  next;
	  }
	
	  pos $_args = $_nextpos;
	  $_args && $_args =~ m/\G(?:\s|\0)*(\S+)/g or last;
	  if ($_errormsg) { print STDERR "Error"."$self->{_internal}{source}: $_errormsg\n" }

	  else { push @_unused, $1; }
	  $_errors++ if ($_errormsg);
	  }
	  continue
	  {
		$_nextpos = pos $_args if defined $_args;
		if (defined $_args and $_args =~ m/\G(\s|\0)*\Z/g)
		{
			$_args = &{$_get_nextline}($self);
			last unless defined($_args);
			$_nextpos = 0;
			$_lastprefix = '';
		}
	  }
	  #;

	foreach my $arg ( @{$self->{_internal}{args}} )
	{
		next unless $arg->{required};
		$code .= q#
	  do { print STDERR "Error"."$self->{_internal}{source}".': required parameter # . $arg->name . q# not found.',"\n"; $_errors++ }
		unless $_FOUND_{'# . $arg->name . q#'}#;
		if ($self->{_internal}{mutex}{$arg->name})
		{
			foreach my $mutex (@{$self->{_internal}{mutex}{$arg->name}})
			{
				$code .= q# or $_FOUND_{'# . $mutex . q#'}#;
			}
		}
		$code .= ';';
	}
	
	foreach my $arg ( @{$self->{_internal}{args}} )
	{
		if ($arg->{requires})
		{
			$code .= q#
	  do { print STDERR q|Error|.$self->{_internal}{source}.q|: parameter '# . $arg->name
		  . q#' can only be specified with '# . _enbool($arg->{requires})
		  . q#'|,"\n"; $_errors++ }
		if $_FOUND_{'# . $arg->name . "'} && !(" . _enfound($arg->{requires}) . ');'
		}
	}

	$code .= q#
		push @_unused, split(' ', substr($_args,$_nextpos))
			if $_args && $_nextpos && length($_args) >= $_nextpos;
		#;

	if ($self->{_internal}{strict})
	{
		$code .= q#
		unless ($_nextpos < length($_args||''))
		{
			foreach (@_unused)
			{
				tr/\0/ /;
				print STDERR "Error"."$self->{_internal}{source}: unrecognizable argument ('$_')\n";
				$_errors++;
			}
		}
		#
	}

	$code .= q#

	  if ($_errors && !$self->{_internal}{source})
	  {
		print STDERR "\n(try '$0 ".'# . Getopt::Declare::Arg::besthelp
				. q#'."' for more information)\n";
	  }

	  $self->{_internal}{unused} = [map { tr/\0/ /; $_ } @_unused];
	  @ARGV = @{$self->{_internal}{unused}}
		unless $self->{_internal}{source};

	  unless ($_errors) { foreach (@_deferred) { &$_ } }

	  !$_errors;

	}
	#;
}

1;
__END__

=head1 NAME

Getopt::Declare - Declaratively Expressed Command-Line Arguments via Regular Expressions

=head1 VERSION

This document describes version 1.08 of Getopt::Declare,
released May 21, 1999.

=head1 SYNOPSIS

 use Getopt::Declare;

 $args = new Getopt::Declare ($specification_string, $optional_source);


=head1 DESCRIPTION

=head2 Overview

F<Getopt::Declare> is I<yet another> command-line argument parser,
one which is specifically designed to be powerful but exceptionally
easy to use.

To parse the command-line in C<@ARGV>, one simply creates a
F<Getopt::Declare> object, by passing C<Getopt::Declare::new()> a
specification of the various parameters that may be encountered:

	$args = new Getopt::Declare($specification);

The specification is a single string such as this:

	$specification = q(

		-a		Process all data

		-b <N:n>	Set mean byte length threshold to <N>
					{ bytelen = $N; }

		+c <FILE>	Create new file <FILE>

		--del 		Delete old file
					{ delold() }

		delete 		[ditto]

		e <H:i>x<W:i>	Expand image to height <H> and width <W>
					{ expand($H,$W); }

		-F <file>...	Process named file(s)
					{ defer {for (@file) {process()}} }

		=getrand [<N>]	Get a random number
				(or, optionally, <N> of them)
					{ $N = 1 unless defined $N; }

		--		Traditionally indicates end of arguments
					{ finish }
	);

in which the syntax of each parameter is declared, along with a
description and (optionally) one or more actions to be performed when
the parameter is encountered. The specification string may also
include other usage formatting information (such as group headings or
separators) as well as standard Perl comments (which are ignored).

Calling C<Getopt::Delare::new()> parses the contents of the array C<@ARGV>,
extracting any arguments which match the parameters defined in the
specification string, and storing the parsed values as hash elements
within the new F<Getopt::Declare> object being created.

Other features of the F<Getopt::Declare> package include:

=over 4

=item *

The use of full Perl regular expressions to constrain matching
of parameter components.

=item *

Automatic generation of error, usage and version information.

=item *

Optional conditional execution of embedded actions (i.e. only on
successful parsing of the entire command-line)

=item *

Strict or non-strict parsing (unrecognized command-line elements may either
trigger an error or may simply be left in C<@ARGV>)

=item *

Declarative specification of various inter-parameter relationships (for
example, two parameters may be declared mutually exclusive and this
relationship will then be automatically enforced).

=item *

Intelligent clustering of adjacent flags (for example: the
command-line sequence "S<-a -b -c>" may be abbreviated to "-abc", unless
there is also a C<-abc> flag declared).

=item *

Selective or global case-insensitivity of parameters.

=item *

The ability to parse files (especially configuration files) instead of
the command-line.

=back

=head2 Terminology

The terminology of command-line processing is often confusing, with various
terms (such as "argument", "parameter", "option", "flag", etc.)
frequently being used interchangeably and inconsistently in the various
F<Getopt::> packages available. In this documentation, the following
terms are used consistently: 

=over 4

=item "command-line"