# Copyright (c) 1997-2006
# Ewgenij Gawrilow, Michael Joswig (Technische Universitaet Berlin, Germany)
# http://www.math.tu-berlin.de/polymake, mailto:polymake@math.tu-berlin.de
#
# This program is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by the
# Free Software Foundation; either version 2, or (at your option) any
# later version: http://www.gnu.org/licenses/gpl.txt.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#-----------------------------------------------------------------------------
# $Project: polymake $$Id: Switches.pm 6754 2006-01-12 22:41:05Z gawrilow $
use strict 'subs';
use Poly;
use namespaces 'Poly';
package Switches;
use Carp;
declare $ERROR;
sub split_args($) {
my ($delim, $w, @result);
my @words=split /(\\[\s'"]|\s+|["'])/, "$_[0] ";
my ($arg, $quote)=("", "");
while (($w, $delim, @words)=@words) {
$arg.=$w;
if (substr($delim,0,1) eq "\\") {
$arg.=substr($delim,1);
}
elsif ($delim eq "'" or $delim eq '"') {
if ($delim eq $quote) {
$quote="";
}
elsif ($quote) {
$arg.=$delim;
}
else {
$quote=$delim;
}
}
else {
if ($quote) {
$arg.=$delim;
}
else {
push @result, $arg; $arg="";
}
}
}
@result
}
sub import {
shift; # drop the own package name
my ($prog)= $0 =~ m|([^/]+)$|;
my (%type, $key, $type, $group, $default, @groups, %groups, @keylist, @env, $env, @args);
while (defined($key = shift)) {
if ($key eq '{' or $key eq '[') {
croak "nested group" if defined $group;
push @groups, undef;
$group=@groups;
$default=1 if $key eq "{";
next;
} elsif ($key eq '}') {
croak "unmatched group end" unless defined $group and defined $default;
undef $group; undef $default;
next;
} elsif ($key eq ']') {
croak "unmatched group end" unless defined $group and !defined $default;
undef $group;
next;
}
$type=shift;
if ($type eq 'env') {
croak "environment variable within a group" if defined $group;
push @env, $key if exists $ENV{$key} and $ENV{$key} !~ /^\s*$/;
next;
}
if ($default and $type ne 'bool' and $type ne 'cnt') {
croak "option of type '$type' as a default option in a group";
}
$key =~ tr/-/_/;
if ($type =~ m'^(string|bool)-?$') {
declare *$key=\( my $init="" );
} elsif ($type eq 'number' or $type eq 'cnt') {
declare *$key=\( my $init=0 );
} elsif ($type =~ m'^list\*{0,2}$') {
declare *$key=[ ];
} else {
croak "unknown option type '$type'";
}
$type{$key}=$type;
$groups{$key}=$group;
if ($default) {
$groups[$group]="-$key";
$default=0;
}
}
croak "unmatched group begin" if defined $group;
foreach $env (@env, "") {
@args= $env ? split_args($ENV{$env}) : @ARGV;
$ERROR=0;
my $trailer= $env ? " in $env - ignored\n" : "\n";
while (@args) {
if ($args[0] !~ /^-./) {
last if !$env;
$_=shift @args;
print STDERR "$prog: unexpected word '$_'$trailer";
next;
}
$_=shift @args;
if (/^--/) {
if (!$') {
last if !$env;
print STDERR "$prog: unexpected '$_'$trailer";
next;
}
@keylist=($');
}
else {
@keylist=split //,substr($_,1);
}
my $stop;
foreach $key (@keylist) {
$key =~ tr/-/_/;
if (exists $type{$key}) {
if ($type{$key} eq 'bool') {
$$key=1;
} elsif ($type{$key} eq 'cnt') {
++$$key;
} else {
if (!@args) {
print STDERR "$prog: option '$key' needs a value$trailer";
$ERROR=1;
next;
}
if ($type{$key} =~ m'^list\*+') {
my $cnt=0;
++$cnt while ($cnt<=$#args and $args[$cnt] !~ /^-./);
if (substr($type{$key},-2) eq '**') {
push @$key, [ splice @args, 0, $cnt ];
} else {
push @$key, splice @args, 0, $cnt;
}
} else {
my $v=shift @args;
if ($type{$key} eq 'list') {
push @$key, $v;
} else {
if ($type{$key} eq 'number' and $v+0 ne $v) {
print STDERR "$prog: option '$key' needs a numeric value$trailer";
$ERROR=1;
next;
}
$$key=$v;
$stop ||= $type{$key} =~ /-$/;
}
}
}
if (defined ($group=$groups{$key})) {
if (defined $groups[$group] and substr($groups[$group],0,1) ne '-') {
print STDERR "$prog: mutually exclusive options '$groups[$group]' and '$key'$trailer";
$ERROR=1;
} else {
$groups[$group]=$key;
}
}
} else {
print STDERR "$prog: unknown option '$key'$trailer";
$ERROR=1;
}
}
last if $stop && !$env;
}
}
foreach (grep { defined $_ and substr($_,0,1) eq '-' } @groups) {
$key=substr($_,1);
$$key=1;
}
@ARGV=@args;
}
1;
__END__
=head1 NAME
Switches - command line switches parser
=head1 SYNOPSIS
use Switches qw( key type ... );
=head1 DESCRIPTION
The module parses the command line switches, removes them from
@ARGV and sets the variables of the same names in the Switches:: package.
As switches are recognized all words starting with a dash "-", up to the first word
without a dash or consisting of exactly two dashes: "--". A word with a single dash is
split into separate letters, so it is treated as several switches glued together, while
a word with double dash is considered as a long switch name.
Then for each switch filtered out this way its type is retrieved from the import list
and the corresponding variable in package Switches is set as follows:
type effect
---- ------
bool $key=1
cnt $key= number of times the switch occurs in the command line
string $key=shift @ARGV
number the same, but requires that the next word be a valid numeric value
list push @key, (shift @ARGV)
There is also a special type that does not specify any switches but controls the behavior
of the module:
env The name of an environment variable, whose value, if set, will be prepended
to the arguments list before the parsing. This way one can supply additional arguments
to the script being run indirectly, e.g. from another program.
Mutually exclusive switches can be specified by embracing their definitions with { ... } or [ ... ]
in the import list. In the curly braced group, the first switch gets the default value (true or 1)
unless anything in the group occurs among the command line arguments.
=head1 AUTHOR
Ewgenij Gawrilow <gawrilow@math.tu-berlin.de>
=cut
syntax highlighted by Code2HTML, v. 0.9.1