dbgetopt.pm

跑leach需要的

#!/home/johnh/BIN/perl5 -w

#
# DbGetopt.pm
# Copyright (C) 1995-1998 by John Heidemann <[e-mail]>
# $Id: DbGetopt.pm,v 1.1 2001/11/10 16:08:04 kclan Exp $
#
# This program is distributed under terms of the GNU general
# public license, version 2.  See the file COPYING
# in $dblib for details.
#

package DbGetopt;

=head1 NAME

DbGetopt -- the currently preferred method of parsing args in jdb


=head1 SYNOPSIS

    use DbGetopt;
    $opts = new DbGetopts("ab:", \@ARGV);
    while ($opts->getopt()) {
	if ($opts->opt eq 'b') {
	    $b = $opts->optarg;
	}
    };
    @other_args = $opts->rest;

=head1 CREDITS

Taken from:

getoptk.pl -- getopt-like processing for Perl scripts, by
Brian Katzung  12 June 1993
<[e-mail]>,
and much hacked.

Perl5-ized by John Heidemann <[e-mail]>.

=cut
#'


require 5.000;
require Exporter;
@EXPORT = qw();
@EXPORT_OK = qw();
($VERSION) = ('$Revision: 1.1 $' =~ / (\d+.d+) /);

use Carp qw(croak);


=head2 new("optionslist", \@ARGV)

Instantiate a new object.

=cut
#' font-lock hack
sub new {
    my($class) = shift @_;
    my($options, $optlistref) = @_;

    croak("DbGetopt::new: no options.\n") if (!defined($options));
    croak("DbGetopt::new: no option list or wrong type.\n") if (!defined($optlistref) || ref($optlistref) ne 'ARRAY');

    my $self = bless {
	opt => undef,
	opterr => 1,
	optarg => undef,
	_nextopt => '',
	_spec => $options,
	_optlistref => $optlistref,
    }, $class;
    return $self;
}

# from LWP::MemberMixin
sub _elem {
    my($self, $elem, $val) = @_;
    my $old = $self->{$elem};
    $self->{$elem} = $val if defined $val;
    return $old;
}
sub _elem_array {
    my($self) = shift @_;
    my($elem) = shift @_;
    return wantarray ? @{$self->{$elem}} : $self->{$elem}
        if ($#_ == -1);
    if (ref($_[0])) {
        $self->{$elem} = $_[0];
    } else {
	$self->{$elem} = ();
	push @{$self->{$elem}}, @_;
    };
    # always return array refrence
    return $self->{$elem};
}

=head2 opt, optarg, opterr, rest

Return the currently parsed option, that options's argument,
the error status, or any remaining options.

=cut
# '
sub opt { return shift->_elem('opt', @_); }
sub opterr { return shift->_elem('opterr', @_); }
sub optarg { return shift->_elem('optarg', @_); }
sub rest { return shift->_elem_array('_optlistref', @_); }

=head2 getopt

Get the next option, returning undef if out.

=cut
sub getopt {
    my($self) = shift;
    my($withArgs) = $self->{_spec};
    my($next);
    my($option, $i);
    my($argvref) = $self->{_optlistref};

    #
    # Fetch the next option string if necessary.
    #
    if (($next = $self->{'_nextopt'}) eq '') {
	#
	# Stop if there are no more arguments, if we see '--',
	# or if the next argument doesn't look like an option
	# string.
	#
	return undef
	    if (($#{$argvref} < 0) || (${$argvref}[0] eq '-') || (${$argvref}[0] !~ /^-/));
	if (${$argvref}[0] eq '--') {
	    shift(@{$argvref});
	    return undef;
	}
	
	#
	# Grab the next argument and remove it from @ARGV.
	#
	$next = shift @{$argvref};
	$next = substr($next, 1);
    };

    #
    # Peel off the next option.
    #
    $option = substr($next, 0, 1);
    $next = substr($next, 1);

    $i = index($withArgs, $option);
    if ($i == -1) {
	#
	# Unknown option.
	#
	croak("unknown option '$option'") if ($self->{'opterr'});
	# # put the argument back on ARGV
	# unshift (@ARGV, "-$option$next");
	$self->{'opt'} = '?';
	return 1;
    };
    if (substr($withArgs, $i+1, 1) eq ':') {
	#
	# The option takes an argument.  Take the argument
	# from the remainder of the option string, or use
	# the next argument if the option string is empty.
	#
	if ($next ne '') {
	    $self->{'optarg'} = $next;
	    $next = '';
	} else {
	    $self->{'optarg'} = shift(@{$argvref});
	};
    };

    #
    # Save the remainder of the option string and return
    # the current option.
    #
    $self->{'_nextopt'} = $next;
    $self->{'opt'} = $option;
    return 1;
}

=head2 ungetopt

Push the current option back on the options stream.
(May not exactly preserve original option parsing.)

=cut
sub ungetopt {
    my($self) = shift;
    my($opt) = $self->{'opt'};
    $opt .= $self->{_nextopt} if ($self->{_nextopt} ne '');
    unshift @{$self->{'_optlistref'}}, "-$opt";
}

# suppress warnings
my($bogus) = $VERSION;

1;