declare.pm

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

		}
		#
	}

	foreach my $action ( @{$self->{actions}} )
	{
		$action =~ s{(\s*\{)}
			    { $1 package $package; };
		$code .= "\n\t\tdo " . $action . ";\n";
	}

	if ($flag && $self->{items}==0)
	{
		$code .= "\n\t\t\$self->{'$flag'} = '$flag';\n";
	}
	foreach my $subarg ( @{$self->{args}} )
	{
		$code .= $subarg->cachecode($self->name,$self->{items});
	}

	if ($flag =~ /\A([^a-z0-9]+)/i)	{ $code .= '$_lastprefix = "'.quotemeta($1).'";'."\n" }
	else				{ $code .= '$_lastprefix = "";' }

	$code .= q#
		$_FOUND_{'# . $self->name . q#'} = 1;
		next arg if pos $_args;
		$_nextpos = length $_args;
		last arg;
	}

		  #;
}

sub name
{
	my $self = shift;
	return $self->{flag} || "<$self->{args}[0]{name}>";
}


package Getopt::Declare;

use Text::Balanced qw( :ALL );
use Text::Tabs	   qw( expand );

# PREDEFINED GRAMMARS

my %_predef_grammar = 
(
	"-PERL" =>
q{	-<varname:id>		Set $<varname> to 1 [repeatable]
				{ no strict "refs"; ${"::$varname"} = 1 }

},
			
	"-AWK" =>
q{	<varname:id>=<val>	Set $<varname> to <val> [repeatable]
				{no strict "refs";  ${"::$varname"} = $val }
  	<varname:id>=		Set $<varname> to '' [repeatable]
				{no strict "refs";  ${"::$varname"} = '' }

},
);
my $_predef_grammar = join '|', keys %_predef_grammar;

sub _quoteat
{
	my $text = shift;
	$text =~ s/\A\@/\\\@/;
	$text =~ s/([^\\])\@/$1\\\@/;
	$text;
}

sub new		# ($self, $grammar; $source)
{
# HANDLE SHORT-CIRCUITS

	return 0 if @_==3 && (!defined($_[2]) || $_[2] eq '-SKIP'); 

# SET-UP

	my ($_class, $_grammar) = @_;

# PREDEFINED GRAMMAR?

	if ($_grammar =~ /\A(-[A-Z]+)+/)
	{
		my $predef = $_grammar;
		my %seen = ();
		$_grammar = '';
		$predef =~ s{($_predef_grammar)}{ do {$_grammar .= $_predef_grammar{$1} unless $seen{$1}; $seen{$1} = 1; ""} }ge;
		return undef if $predef || !$_grammar;
	}

# PRESERVE ESCAPED '['s

	$_grammar =~ s/\\\[/\255/g;

# MAKE SURE GRAMMAR ENDS WITH A NEWLINE

	$_grammar =~ s/([^\n])\Z/$1\n/;

# SET-UP

	local $_ = $_grammar;
	my @_args = ();
	my $_mutex = {};
	my $_action;
	my $_strict = 0;
	my $_all_repeatable = 0;
	my $_lastdesc = undef;
	_nocase(0);
	Getopt::Declare::ScalarArg::_reset_stdtype();

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

	# TYPE DIRECTIVE:

		#WAS: if (m/\A\s*\[pvtype:/ and $_action = extract_codeblock($_,'[{}]'))
		if (m/\A\s*\[pvtype:/ and $_action = extract_codeblock($_,'[]'))
		{
			$_action =~ s/.*?\[pvtype:\s*//;
			_typedef($_action);
			next;
		}

	# ACTION
		if ($_action = extract_codeblock)
		{
			# WAS: eval q{no strict;my $ref = sub }._quoteat($_action).q{;1}
			my $_check_action = $_action;
			$_check_action =~ s{(\s*\{)}
			    { $1 sub defer(&); sub finish(;\$); sub reject(;\$\$); };
			eval q{no strict;my $ref = sub }.$_check_action.q{;1}
			   or die "Error: bad action in Getopt::Declare specification:"
				. "\n\n$_action\n\n$@\n";
			if ($#_args < 0)
			{
				die "Error: unattached action in Getopt::Declare specification:\n$_action\n"
				    . "\t(did you forget the tab after the preceding parameter specification?)\n"
			}
			push @{$_args[$#_args]->{actions}}, $_action;
			next;
		}
		elsif (m/\A(\s*[{].*)/)
		{
			die "Error: incomplete action in Getopt::Declare specification:\n$1.....\n" 
			    . "\t(did you forget a closing '}'?)\n";
		}

	# ARG + DESC:
		if ( s/\A(.*?\S.*?)(\t.*\n)// )
		{
			my $spec = $1;
			my $desc = $2;
			my $ditto;
			$_strict ||= $desc =~ /\Q[strict]/;

			$desc .= $1 while s/\A((?![ 	]*({|\n)|.*?\S.*?\t.*?\S).*?\S.*\n)//;
			
			$_lastdesc and $desc =~ s/\A\s*\[ditto\]/$_lastdesc/
				  and $ditto = 1;
			$_lastdesc = $desc;

			my $arg = new Getopt::Declare::Arg($spec,$desc,$ditto) ;
			push @_args, $arg;

			_infer($desc, $arg, $_mutex);
			next;
		}


	# OTHERWISE: DECORATION

		s/((?:(?!\[pvtype:).)*)(\n|(?=\[pvtype:))//;
		my $decorator = $1;
		$_strict ||= $decorator =~ /\Q[strict]/;
		_infer($decorator, undef, $_mutex);
		$_all_repeatable = 1 if $decorator =~ /\[repeatable\]/;
	}

	my $_lastactions;
	foreach ( @_args )
	{
		if ($_lastactions && $_->{ditto} && !@{$_->{actions}})
			{ $_->{actions} = $_lastactions }
		else
			{ $_lastactions = $_->{actions} }

		if ($_all_repeatable)
		{
			$_->{repeatable} = 1;
		}
	}

	@_args = sort
	{
		length($b->{flag}) <=> length($a->{flag})
				   or
 	  $b->{flag} eq $a->{flag} and $#{$b->{args}} <=> $#{$a->{args}}
				   or
		          $a->{ID} <=> $b->{ID}

	} @_args;

# CONSTRUCT OBJECT ITSELF

	my $clump = ($_grammar =~ /\[cluster:\s*none\s*\]/i)     ? 0
		  : ($_grammar =~ /\[cluster:\s*singles?\s*\]/i) ? 1
		  : ($_grammar =~ /\[cluster:\s*flags?\s*\]/i)   ? 2
		  : ($_grammar =~ /\[cluster:\s*any\s*\]/i)      ? 3
		  : ($_grammar =~ /\[cluster:(.*)\s*\]/i)  	 ?
			die "Error: unknown clustering mode: [cluster:$1]\n"
		  :						   3;

	my $self = bless
	{
		_internal =>
		{
			args	=> [@_args],
			mutex	=> $_mutex,
			usage	=> $_grammar,
			helppat => Getopt::Declare::Arg::helppat(),
			verspat => Getopt::Declare::Arg::versionpat(),
			strict	=> $_strict,
			clump	=> $clump,
			source  => '',
			'caller'  => scalar caller(),
		}
	}, ref($_class)||$_class;


# VESTIGAL DEBUGGING CODE

	 open (CODE, ">.CODE")
	 	and print CODE $self->code($self->{_internal}{'caller'})
	 	and close CODE 
			if $::Declare_debug;

# DO THE PARSE (IF APPROPRIATE)


	if (@_==3) { return undef unless defined $self->parse($_[2]) }
	else	   { return undef unless defined $self->parse(); }

	return $self;
}

sub _get_nextline { scalar <> }

sub _load_sources	# ( \$_get_nextline, @files )
{
	my $text  = '';
	my @found = ();
	my $gnlref = shift;
	foreach ( @_ )
	{
		open FILE, $_ or next;
		if (-t FILE)
		{
			push @found, '<STDIN>';
			$$gnlref = \&_get_nextline;
		}
		else
		{
			push @found, $_;
			$text .= join "\n", <FILE>;
		}
	}
	return undef unless @found;
	$text = <STDIN> unless $text;
	return ( $text, join(" or ",@found));
}


sub parse	# ($self;$source)
{
	my ( $self, $source ) = @_;
	my $_args = ();
	my $_get_nextline = sub { undef };
	if (@_>1)
	{
		if (!defined $source)
		{
			return 0;
		}
		elsif (isa($source,'CODE'))
		{
			$_get_nextline = $source;
			$_args = &{$_get_nextline}($self);
			$source = '[SUB]';
		}
		elsif (isa($source,'GLOB'))
		{
			if (-t *$source)
			{
				$_get_nextline = \&_get_nextline ;
				$_args = <STDIN>;
				$source = '<STDIN>';
			}
			else
			{
				$_args = join ' ', (<$source>);
				$_args =~ tr/\t\n/ /s;
				$source = ref($source);
			}
		}
		elsif (isa($source,'IO::Handle'))
		{
			if (!($source->fileno) && -t)
			{
				$_get_nextline = \&_get_nextline ;
				$_args = <STDIN>;
				$source = '<STDIN>';
			}
			else
			{
				$_args = join ' ', (<$source>);
				$_args =~ tr/\t\n/ /s;
				$source = ref($source);
			}
		}
		elsif (ref($source) eq 'ARRAY')
		{
			if (@$source == 1 && (!defined($source->[0])
					      || $source->[0] eq '-BUILD'
				              || $source->[0] eq '-SKIP') )
			{
				return 0;
			}
			elsif (@$source == 1 && $source->[0] eq '-STDIN')
			{
				$_get_nextline = \&_get_nextline ;
				$_args = <STDIN>;
				$source = '<STDIN>';
			}
			elsif (@$source == 1 && $source->[0] eq '-CONFIG')
			{
				my $progname = "$0rc";
				$progname =~ s#.*/##;
				($_args,$source) = _load_sources(\$_get_nextline,"$ENV{HOME}/.$progname", ".$progname");
			}
			else
			{
				my $stdin;
				($_args,$source) = _load_sources(\$_get_nextline,@$source);
			}
		}
		else  # LITERAL STRING TO PARSE
		{
			$_args = $source;
			substr($source,7) = '...' if length($source)>7;
			$source = "\"$source\"";
		}
		return 0 unless defined $_args;
		$source = " (in $source)";
	}
	else
	{
		foreach (@ARGV) { $_ =~ tr/ \t\n/\0\0\0/; }
		$_args = join(' ', @ARGV);
		$source = '';
	}

	$self->{_internal}{source} = $source;
	
	if (!eval $self->code($self->{_internal}{'caller'}))
	{
		die "Error: in generated parser code:\n$@\n"
			if $@;
		return undef;
	}

	return 1;
}

sub type # ($abbrev, $pattern, $action)
{
	&Getopt::Declare::ScalarArg::addtype;
}

sub _enbool
{
	my $expr = shift;
	$expr =~ s/\s*\|\|\s*/ or /g;
	$expr =~ s/\s*&&\s*/ and /g;
	$expr =~ s/\s*!\s*/ not /g;
	return $expr;
}

sub _enfound
{
	my $expr = shift;
	my $original = $expr;
	$expr =~ s/((?:&&|\|\|)?\s*(?:[!(]\s*)*)([^ \t\n|&\)]+)/$1\$_FOUND_{'$2'}/gx;
	die "Error: bad condition in [requires: $original]\n"
		unless eval 'no strict; my $ref = sub { '.$expr.' }; 1';
	return $expr;
}

my $_nocase = 0;

sub _nocase
{
	$_nocase = $_[0] if $_[0];
	return $_nocase;
}

sub _infer  # ($desc, $arg, $mutex)
{
	my ($desc, $arg, $mutex) = @_;

	_mutex($mutex, split(' ',$1))
		while $desc =~ s/\[mutex:\s*(.*?)\]//i;

	if ( $desc =~ m/\[no\s*case\]/i)
	{
		if ($arg) { $arg->{nocase} = 1 }
		else	  { _nocase(1); }
	}

	if (defined $arg)
	{
		_exclude($mutex, $arg->name, (split(' ',$1)))
			if $desc =~ m/.*\[excludes:\s*(.*?)\]/i;
		$arg->{requires} = $1
			if $desc =~ m/.*\[requires:\s*(.*?)\]/i;

		$arg->{required}   = ( $desc =~ m/\[required\]/i );
		$arg->{repeatable} = ( $desc =~ m/\[repeatable\]/i );
	}

	_typedef($desc) while $desc =~ s/.*?\[pvtype:\s*//;
}

sub _typedef
{
	my $desc = $_[0];
	my ($name,$pat,$action,$ind);

	($name,$desc) = (extract_quotelike($desc))[5,1];
	do { $desc =~ s/\A\s*([^] \t\n]+)// and $name = $1 } unless $name;
	die "Error: bad type directive (missing type name): [pvtype: "
	   . substr($desc,0,index($desc,']')||20). "....\n"
		unless $name;

	($pat,$desc,$ind) = (extract_quotelike($desc,'\s*:?\s*'))[5,1,2];
	do { $desc =~ s/\A\s*(:?)\s*([^] \t\n]+)//
		and $pat = $2 and $ind = $1 } unless $pat;
	$pat = '' unless $pat;

	$action = extract_codeblock($desc) || '';
	die "Error: bad type directive (expected closing ']' but found"
	    . "'$1' instead): [pvtype: $name " . ($pat?"/$pat/":'')
	    . " $action $1$2....\n" if $desc =~ /\A\s*([^] \t\n])(\S*)/;

	Getopt::Declare::ScalarArg::addtype($name,$pat,$action,$ind=~/:/);
}

sub _ditto	# ($originalflag, $orginaldesc, $extra)
{
	my ($originalflag, $originaldesc, $extra) = @_;
	if ($originaldesc =~ /\n.*\n/)
	{
		$originaldesc = "Same as $originalflag ";
	}
	else
	{
		chomp $originaldesc;
		$originaldesc =~ s/\S/"/g;
		1 while $originaldesc =~ s/"("+)"/ $1 /g;
		$originaldesc =~ s/""/" /g;
	}
	return "$originaldesc$extra\n";
}