77 lines
1.9 KiB
Perl
77 lines
1.9 KiB
Perl
package EPICS::Getopts;
|
|
require 5.000;
|
|
require Exporter;
|
|
|
|
@ISA = qw(Exporter);
|
|
@EXPORT = qw(getopts);
|
|
|
|
# EPICS::Getopts.pm - An EPICS-specific version of getopts
|
|
#
|
|
# This version of getopts is modified from the Perl original in the
|
|
# following ways:
|
|
#
|
|
# 1. The perl routine in GetOpt::Std allows a perl hash to be passed
|
|
# in as a third argument and used for storing option values. This
|
|
# functionality has been deleted.
|
|
# 2. Arguments without a ':' modifier are now counted, rather than
|
|
# being binary. This means that multiple copies of the same option
|
|
# can be detected by the program.
|
|
# 3. A new '@' modifier is provided which collects the option arguments
|
|
# in an array @opt_X. Multiple copies of this option are permitted,
|
|
# which push the argument values onto the end of the list.
|
|
|
|
sub getopts ( $;$ ) {
|
|
my ($argumentative) = @_;
|
|
my (@args,$first,$rest);
|
|
my $errs = 0;
|
|
local $_;
|
|
local @EXPORT;
|
|
|
|
@args = split( / */, $argumentative );
|
|
while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
|
|
($first,$rest) = ($1,$2);
|
|
if (/^--$/) { # early exit if --
|
|
shift @ARGV;
|
|
last;
|
|
}
|
|
$pos = index($argumentative,$first);
|
|
if ($pos >= 0) {
|
|
if (defined($args[$pos+1]) and (index(':@', $args[$pos+1]) >= 0)) {
|
|
shift(@ARGV);
|
|
if ($rest eq '') {
|
|
++$errs unless @ARGV;
|
|
$rest = shift(@ARGV);
|
|
}
|
|
if ($args[$pos+1] eq ':') {
|
|
${"opt_$first"} = $rest;
|
|
push @EXPORT, "\$opt_$first";
|
|
} elsif ($args[$pos+1] eq '@') {
|
|
push @{"opt_$first"}, $rest;
|
|
push @EXPORT, "\@opt_$first";
|
|
}
|
|
} else {
|
|
${"opt_$first"} += 1;
|
|
push @EXPORT, "\$opt_$first";
|
|
if ($rest eq '') {
|
|
shift(@ARGV);
|
|
} else {
|
|
$ARGV[0] = "-$rest";
|
|
}
|
|
}
|
|
} else {
|
|
warn "Unknown option: $first\n";
|
|
++$errs;
|
|
if ($rest ne '') {
|
|
$ARGV[0] = "-$rest";
|
|
} else {
|
|
shift(@ARGV);
|
|
}
|
|
}
|
|
}
|
|
local $Exporter::ExportLevel = 1;
|
|
import EPICS::Getopts;
|
|
$errs == 0;
|
|
}
|
|
|
|
1;
|