File Coverage

blib/lib/Getopt/constant.pm

Criterion	Covered	Total	%
statement	39	58	67.2
branch	16	44	36.3
condition	5	16	31.2
subroutine	4	5	80.0
pod			n/a
total	64	123	52.0

require 5.003_96; # Time-stamp: "2004-12-29 19:27:33 AST"
 # same minimal version required as constant.pm

package Getopt::constant;
$VERSION = '1.03';
use strict;

sub import {
  shift(@_); # We don't care about our own package name

  my(%h) = (@_); # Get default values from there.
  my $pkg    = caller;
  my $pref   = delete( $h{':prefix'} ) || '';
  my $usage  = delete( $h{':usage' } ); # a usage message to throw at people
  my $retain = delete( $h{':retain'} ); # if we should not change @ARGV
  my $permissive = delete( $h{':permissive'} );
    # if we should just skip weird things
  my($x, @unknowns, @orig_ARGV);
  @orig_ARGV = @ARGV if $retain;

  while(@ARGV) {
    $x = $ARGV[0];
    #print "Considering \"$x\"\n";
    if($x eq '-') {
      # Deceptively not part of the options list, so bail.
      last;
    } elsif($x eq '--') {
      # End of options list.
      shift @ARGV;
      last;
    } elsif($x =~ m<--?([^=]+)=([^=]*)>s ) {  # like -foo=123 or --foo=123
      if(!exists $h{$1}) {
	push @unknowns, $1 unless $permissive;
      } elsif(ref($h{$1} || '') eq 'ARRAY') {
	my($name) = $1;
	@{$h{$name}} = split(",", $2, -1);
      } else {
	$h{$1} = $2;
      }
      shift @ARGV;

    } elsif($x =~ m<--?([^=]+)>s ) {  # like -foo or --foo
      if(!exists $h{$1}) {
	push @unknowns, $1 unless $permissive;
      } elsif(ref($h{$1} || '') eq 'ARRAY') {
	@{$h{$1}} = (1); # guh, I guess that's right.
      } else {
	$h{$1} = 1;
      }
      shift @ARGV;

    } elsif(length $x and substr($x,0,1) eq '-') {
      push @unknowns, "\"$x\"" unless $permissive;

    } else {
      last;  # First non-option in @ARGV
    }
  }

  @ARGV = @orig_ARGV if $retain;

  if(@unknowns) {
    if(ref($usage || '') eq 'CODE') {
      $usage->(\@unknowns, [sort grep !m/^:/s, keys %h], \%h);
    } else {
      printf STDERR "Unknown option%s: %s\n",
	(@unknowns == 1) ? '' : 's', join(' ', @unknowns);
      if(defined $usage) {
	print  STDERR $usage
      } else {
	my(@x) = sort grep !m/^:/s, keys %h;
	print STDERR
	   (@x == 1) ?
	   '(The only known option is: ' : '(The known options are: ',
           join(', ', @x), ")\n";
      }
    }

    if($] <= 5.00599) {
      exit;
       # Because if we put a 1 there, those versions of Perl will emit
       #  a nasty "Callback called exit" message.  Ah well.
    } else {
      exit 1;
    }
  }

  while( my($name,$value) = each %h) {
    next unless length($name) and substr($name,0,1) ne ':';
    no strict 'refs';
    if(ref($value || '') eq 'ARRAY') {
      #print "Setting ${pkg}::$pref$name to the list (@$value)\n";
      *{"${pkg}::$pref$name"} = sub () { @$value };
    } else {
      #print "Setting ${pkg}::$pref$name to $value\n";
      *{"${pkg}::$pref$name"} = sub () {  $value };
    }
  }

  return;
}
# Yup, that's it.
###########################################################################
1;

__END__