http://qs1969.pair.com?node_id=5464
Category: CLI modules
Author/Contact Info lanzz <lanzz@graffiti.net>
Description:
 usage:
use importopt (namespace=>"NS", options=>{opt1=>"type", opt2=>"type[]", opt3=>"=opt1"}); types: i (integer) /^[+-]?[0-9]+$/ f (float) /^[+-]?[0-9.]+(e[+-]?[0-9]+)?$/ s (string) /./ v (void) /^$/ new types can be defined by simply adding their regexp in %type. name=>"i[]" will define @NS::name holding all the values for all instances of --name. name=>"i" will define $NS::name holding the last given value if there are multiple instances (no error/warning given). name=>"=other" will make the option "name" an alias for the option "other". if "other" is defined to be an array (other=>"i[]"), then @NS::name will be an alias for @NS::other, else $NS::name will be an alias for $NS::other. your script won't be able to tell which one was used on the command line. options syntaxes (equivalent): -option[=value] --option[=value]
if value is ommited, 1 is assumed (for boolean options). all non-option @ARGV's will be copied to @NS::_args. if there are any errors (unknown option or invalid value), $NS::_err will be set to an error code and an error message will be displayed. error codes: 1: invalid value (didn't match regexp for type) 2: unknown option 3: reference to nonexistent option (aliasing)
package importopt;

use strict;

my %type = (i => "^[+-]?[0-9]+\$",
            s => ".",
            f => "^[+-]?[0-9.]+(e[+-][0-9]+)?\$",
            v => "^\$");

sub import (@) {
  no strict 'refs';
  shift (@_);
  my %arg = @_;
  if (!defined ($arg {options})) { return(); }
  my $ns = $arg {namespace} || "";
  my %opt = %{$arg {options}};
  my $args = \@{"$ns\::_args"};
  my $err = \${"$ns\::_err"};  
  foreach my $o (keys (%opt)) {
    if ($opt{$o} =~ /^([a-zA-Z])(\[\])?$|^=(.*)/) {
      my ($t, $a, $r) = ($1 || "", $2 || "", $3 || "");
      
      if ($r) { # option is an alias for another option
        unless ($opt{$r}) {
          print STDERR ("$o: reference to nonexistent option $r\n");
          $$err = 3;
        }
        $opt{$o} = $opt{$r};
        if (defined (@{"$ns\::$r"})) {
          *{"$ns\::$o"} = \@{"$ns\::$r"};
        } else {
          *{"$ns\::$o"} = \${"$ns\::$r"};
        }
      } else { # assigning twice to avoid "used only once" warning - p
+erhaps not the cleanest solution
        if ($a) {
          @{"$ns\::$o"} = ();
          @{"$ns\::$o"} = ();
        } else {
          ${"$ns\::$o"} = "";
          ${"$ns\::$o"} = "";
        }
        $opt{$o} = $t;
      }
    }
  }
  
  @$args = ();
  $$err = 0;

  while (@ARGV) {
    if ($ARGV[0] =~ /^--?(.*?)(?:=(.*))?$/o) {
      my ($n, $v) = ($1, $2);
      if (defined ($opt{$n})) {
        if (($type{$opt{$n}}) && (($v || "") =~ /$type{$opt{$n}}/i)) {
          unless (defined ($v)) { $v = ""; }
          if (defined (${"$ns\::$n"})) {
            ${"$ns\::$n"} = $v;
          } else {
            push (@{"$ns\::$n"}, $v);
          }
        } else {
          print STDERR ("\"$v\": invalid value for $n ($opt{$n})\n");
          $$err = 1;
        }
      } else {
        print STDERR ("$n: unknown option\n");
        $$err = 2;
      }
    } else {
      push (@$args, $ARGV[0]);
    }
    shift (@ARGV);
  }
  @ARGV = @$args;
}

1;