File Coverage

blib/lib/Net/SSH2/Cisco.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

package Net::SSH2::Cisco;

##################################################
# Michael Vincent
# www.VinsWorld.com
##################################################

# NOTE:  This module is basically a cut/paste of:
#   70% Net::Telnet
#   20% Net::Telnet::Cisco
#    5% Net::SSH2(::Channel)
#    5% original hack to make it all work together
#
# - I tried to create a child class of Net::SSH2 to no avail due to
#   the C-type inside-out object it returns and my lack of experience.
#
# - I tried to pass a Net::SSH2 connection to Net::Telnet(::Cisco) fhopen()
#   method, but it returned:
#
#     Not a GLOB reference at [...]/perl/vendor/lib/Net/Telnet.pm line 679.
#
# - I tried to use Net::Telnet in my @ISA with AUTOLOAD to leverage the
#   accessors and code already written, but I'm not creating a Net::Telnet
#   object and I couldn't get it to work.
#
# That left me the (?only?) option - to write this Franken-module "liberally
# borrowing" from much smarter, more talented programmers than I.

use strict;
use warnings;

our $VERSION = '0.03';
our @ISA;

use version;
use Net::SSH2 0.51;
use Socket qw(inet_ntoa AF_INET IPPROTO_TCP);
my $HAVE_IO_Socket_IP = 0;
eval "use IO::Socket::IP -register";
if(!$@) {
    $HAVE_IO_Socket_IP = 1;
    push @ISA, "IO::Socket::IP"
} else {
    require IO::Socket::INET;
    push @ISA, "IO::Socket::INET"
}

my $AF_INET6 = eval { Socket::AF_INET6() };
my $AF_UNSPEC = eval { Socket::AF_UNSPEC() };
my $AI_NUMERICHOST = eval { Socket::AI_NUMERICHOST() };
my $NI_NUMERICHOST = eval { Socket::NI_NUMERICHOST() };

$|++;

##################################################
# Start Public Module
##################################################

sub new {
    my $self = shift;
    my $class = ref($self) || $self;

    my ($fh_open, $host);
    my %params = (
        always_waitfor_prompt => 1,
        autopage              => 1,
        bin_mode              => 0,
        blocking              => 0,
        cmd_prompt            => '/(?m:^(?:[\w.\/]+\:)?[\w.-]+\s?(?:\(config[^\)]*\))?\s?[\$#>]\s?(?:\(enable\))?\s*$)/',
        cmd_rm_mode           => "auto",
        dumplog               => '',
        eofile                => 1,
        errormode             => "die",
        errormsg              => "",
        fh_open               => undef,
        host                  => "localhost",
        ignore_warnings       => 0,
        inputlog              => '',
        last_cmd              => '',
        last_prompt           => '',
        maxbufsize            => 1_048_576,
        more_prompt           => '/(?m:^\s*--More--)/',
        normalize_cmd         => 1,
        ofs                   => "",
        opened                => '',
        outputlog             => '',
        ors                   => "\n",
        peer_family           => 'ipv4',
        port                  => 22,
        rs                    => "\n",
        send_wakeup           => 0,
        time_out              => 10,
        timedout              => '',
        waitfor_clear         => 1,
        waitfor_pause         => 0.2,
        warnings              => '/(?mx:^% Unknown VPN
            |^%IP routing table VRF.* does not exist. Create first$
            |^%No CEF interface information
            |^%No matching route to delete$
            |^%Not all config may be removed and may reappear after reactivating/
        )/',
    );

    $params{_SSH_} = Net::SSH2->new() or return;
    $self = bless \%params, $class;

    my %args;
    if (@_ == 1) {
        ($host) = @_
    } else {
        %args = @_;
        for (keys(%args)) {
            if (/^-?always_waitfor_prompt$/i) {
                $self->always_waitfor_prompt($args{$_});
            } elsif (/^-?autopage$/i) {
                $self->autopage($args{$_})
            } elsif (/^-?binmode$/i) {
                $self->binmode($args{$_})
            } elsif (/^-?blocking$/i) {
                $self->blocking($args{$_})
            } elsif (/^-?cmd_remove_mode$/i) {
                $self->cmd_remove_mode($args{$_})
            } elsif (/^-?dump_log$/i) {
                $self->dump_log($args{$_})
                    or return;
            } elsif (/^-?errmode$/i) {
                $self->errmode($args{$_})
            } elsif (/^-?family$/i) {
                $self->family($args{$_})
            } elsif (/^-?fhopen$/i) {
                $fh_open = $args{$_}
            } elsif (/^-?host$/i) {
                $host = $args{$_}
            } elsif (/^-?ignore_warnings$/i) {
                $self->{ignore_warnings} = $args{$_}
            } elsif (/^-?input_log$/i) {
                 $self->input_log($args{$_})
                    or return;
            } elsif (/^-?input_record_separator$/i or /^-?rs$/i) {
                $self->input_record_separator($args{$_})
            } elsif (/^-?max_buffer_length$/i) {
                $self->max_buffer_length($args{$_})
            } elsif (/^-?normalize_cmd$/i) {
                $self->normalize_cmd($args{$_})
            } elsif (/^-?output_field_separator$/i or /^-?ofs$/i) {
                $self->output_field_separator($args{$_})
            } elsif (/^-?output_log$/i) {
                $self->output_log($args{$_})
                    or return;
            } elsif (/^-?output_record_separator$/i or /^-?ors$/i) {
                $self->output_record_separator($args{$_})
            } elsif (/^-?port$/i) {
                $self->port($args{$_})
            } elsif (/^-?prompt$/i) {
                $self->prompt($args{$_})
            } elsif (/^-?send_wakeup$/i) {
                $self->send_wakeup($args{$_})
            } elsif (/^-?timeout$/i) {
                $self->timeout($args{$_})
            } elsif (/^-?waitfor_clear$/i) {
                $self->waitfor_clear($args{$_})
            } elsif (/^-?waitfor_pause$/i) {
                $self->waitfor_pause($args{$_})
            } elsif (/^-?warnings$/i) {
                $self->{warnings} = $args{$_}
            } else {
                # pass through
                #$params{$_} = $args{$_}
                &_croak($self, "bad named parameter \"$_\" given " .
                    "to " . ref($self) . "::new()");
            }
        }
    }

    # $self->open in the if statement so open() not called
    # if neither 'fh' nor 'host' are provided.
    if (defined $fh_open) {
        $self->fhopen($fh_open);
        $self->open or return
    } elsif (defined $host) {
        $self->host($host);
        $self->open or return
    }

    return $self
}

sub always_waitfor_prompt {
    my ($self, $arg) = @_;
    $self->{always_waitfor_prompt} = $arg if defined $arg;
    return $self->{always_waitfor_prompt}
}

sub autopage {
    my ($self, $arg) = @_;
    $self->{autopage} = $arg if defined $arg;
    return $self->{autopage}
}

sub binmode {
    my ($self, $arg) = @_;
    $self->{bin_mode} = $arg if defined $arg;
    return $self->{bin_mode}
}

sub blocking {
    my ($self, $arg) = @_;
    $self->{blocking} = $arg if defined $arg;
    return $self->{blocking}
}

sub close {
    my ($self) = @_;

    $self->{eofile} = 1;
    $self->{opened} = '';
    if (defined $self->{_SSH_CHAN_}) {
        $self->{_SSH_CHAN_}->close
    }
    if (defined $self->{_SSH_}) {
        $self->{_SSH_}->disconnect
    }
    delete $self->{_SSH_CHAN_};
    delete $self->{_SSH_};
    1
}

sub cmd {
    my ($self, @args) = @_;

    my $string  = '';
    my $chan    = $self->{_SSH_CHAN_};
    my $clear   = $self->{waitfor_clear};
    my $normal  = $self->{normalize_cmd};
    my $ors     = $self->{ors};
    my $pause   = $self->{waitfor_pause};
    my $prompt  = $self->{cmd_prompt};
    my $rm      = $self->{cmd_rm_mode};
    my $rs      = $self->{rs};
    my $timeout = $self->{time_out};

    if (!defined $chan) {
        &_croak($self, "no login " .
        "for " . ref($self) . "::cmd()");
    }

    my $ok = 1;
    $self->{timedout} = '';

    my $arg_errmode = &_extract_arg_errmode($self, \@args);
    local $self->{errormode} = $arg_errmode if $arg_errmode;

    my $output = [];
    my $output_ref;
    if (@_ == 2) {
        ($string) = ($_[1])
    } else {
        my %args = @args;
        for (keys(%args)) {
            if (/^-?string$/i) {
                $string = $args{$_}
            } elsif (/^-?cmd_remove_mode$/i) {
                $rm = _parse_cmd_remove_mode($self, $args{$_})
            } elsif (/^-?input_record_separator$/i or /^-?rs$/i) {
                $rs = $args{$_}
            } elsif (/^-?normalize_cmd$/i) {
                $normal = $args{$_}
            } elsif (/^-?output$/i) {
                $output_ref = $args{$_};
                if (defined($output_ref) and ref($output_ref) eq "ARRAY") {
                    $output = $output_ref;
                }
            } elsif (/^-?output_record_separator$/i or /^-?ors$/i) {
                $ors = $args{$_}
            } elsif (/^-?prompt$/i) {
                $prompt = &_parse_prompt($self, $args{$_})
                    or return;
            } elsif (/^-?timeout$/i) {
                $timeout = _parse_timeout($self, $args{$_})
            } elsif (/^-?waitfor_clear$/i) {
                $clear = $args{$_}
            } elsif (/^-?waitfor_pause$/i) {
                $pause = _parse_waitfor_pause($self, $args{$_})
                    or return
            } else {
                # pass through
                #$params{$_} = $args{$_}
                &_croak($self, "bad named parameter \"$_\" given " .
                    "to " . ref($self) . "::cmd()");
            }
        }
    }

    #prep
    local $self->{time_out} = $timeout;
    local $self->{waitfor_clear} = $clear;
    $self->errmsg("");
    chomp $string;
    $self->{last_cmd} = $string;

    my ($lines, $last_prompt);
    {
        local $self->{errormode} = "return";

        #send
        $self->put($string . $ors);

        #wait
        select(undef,undef,undef,$pause); # sleep

        #read
        ($lines, $last_prompt) = $self->waitfor($prompt);
    }

    return $self->error("command timed-out") if $self->timed_out;
    return $self->error($self->errmsg) if $self->errmsg ne "";

    ## Split lines into an array, keeping record separator at end of line.
    my $firstpos = 0;
    my $rs_len = length $rs;
    while ((my $lastpos = index($lines, $rs, $firstpos)) > -1) {
        push(@$output, substr($lines, $firstpos, $lastpos - $firstpos + $rs_len));
        $firstpos = $lastpos + $rs_len
    }
    if ($firstpos < length $lines) {
        push @$output, substr($lines, $firstpos)
    }

    # clean up
    if ($rm eq "auto") {
        if ((defined @$output[0]) and (@$output[0] =~ /^$string(?:\r)?(?:\n)?/)) {
            shift @$output
        }
    } else {
        while ($rm--) {
            shift @$output
        }
    }
    ## Ensure at least a null string when there's no command output - so
    ## "true" is returned in a list context.
    unless (@$output) {
        @$output = ("")
    }

    # Look for errors in output
    for ( my ($i, $lastline) = (0, '');
        $i <= $#{$output};
        $lastline = $output->[$i++] ) {

        # This may have to be a pattern match instead.
        if ( ( substr $output->[$i], 0, 1 ) eq '%' ) {
            if ( $output->[$i] =~ /'\^' marker/ ) { # Typo & bad arg errors
                chomp $lastline;
                $self->error( join "\n",
                    "Last command and router error: ",
                    ( $self->last_prompt . $string ),
                    $lastline,
                    $output->[$i],
                );
                splice @$output, $i - 1, 3;
            } else { # All other errors.
                chomp $output->[$i];
                $self->error( join "\n",
                    "Last command and router error: ",
                    ( $self->last_prompt . $string ),
                    $output->[$i],
                );
                splice @$output, $i, 2;
            }
            $ok = 0;
            last;
        }
    }

    if ($normal) {
        @$output = _normalize (@$output);
    }

    ## Return command output via named arg, if requested.
    if (defined $output_ref) {
        if (ref($output_ref) eq "SCALAR") {
            $$output_ref = join "", @$output;
        } elsif (ref($output_ref) eq "HASH") {
            %$output_ref = @$output;
        }
    }

    wantarray ? @$output : $ok
}

sub cmd_remove_mode {
    my ($self, $arg) = @_;

    if (defined $arg) {
        if (defined (my $r = _parse_cmd_remove_mode($self, $arg))) {
            $self->{cmd_rm_mode} = $r
        }
    }
    return $self->{cmd_rm_mode}
}

sub connect { &open }

sub disable {
    my $self = shift;
    $self->cmd('disable');
    if ($self->is_enabled) {
        return $self->error("Failed to exit enabled mode")
    }
    1
}

sub dump_log {
    my ($self, $name) = @_;

    my $fh = $self->{dumplog};

    if (@_ >= 2) {
        if (!defined($name) or $name eq "") {  # input arg is ""
            ## Turn off logging.
            $fh = "";
        } elsif (&_is_open_fh($name)) {  # input arg is an open fh
            ## Use the open fh for logging.
            $fh = $name;
            select((select($fh), $|=1)[$[]);  # don't buffer writes
        } elsif (!ref $name) {  # input arg is filename
            ## Open the file for logging.
            $fh = &_fname_to_handle($self, $name)
                or return;
            select((select($fh), $|=1)[$[]);  # don't buffer writes
        } else {
            return $self->error("bad Dump_log argument ",
                "\"$name\": not filename or open fh");
        }
        $self->{dumplog} = $fh;
    }
    $fh;
}

sub enable {
    my $self = shift;

    my ($en_username, $en_password, $en_passcode, $en_level) = ('','','','');
    my ($error, $lastline, $orig_errmode, $reset, %seen);
    my $chan    = $self->{_SSH_CHAN_};
    my $ors     = $self->{ors};
    my $timeout = $self->{time_out};

    if (!defined $chan) {
        &_croak($self, "no login " .
        "for " . ref($self) . "::enable()");
    }

    $self->{timedout} = '';

    if (@_ == 1) {  # just passwd given
        ($en_password) = @_
    } else {
        my %args = @_;
        foreach (keys %args) {
            if (/^-?name$|^-?login$|^-?user/i) {
                $en_username = $args{$_}
            } elsif (/^-?passw/i) {
                $en_password = $args{$_}
            } elsif (/^-?passc/i) {
                $en_passcode = $args{$_}
            } elsif (/^-?level$/i) {
                $en_level    = $args{$_}
            } elsif (/^-?timeout$/i) {
                $timeout     = $args{$_}
            } else {
                # pass through
                #$params{$_} = $args{$_}
                &_croak($self, "bad named parameter \"$_\" given " .
                    "to " . ref($self) . "::enable()");
            }
        }
    }

    local $self->{time_out} = $timeout;

    ## Create a subroutine to generate an error for user.
    # $error = sub {
        # my($errmsg) = @_;

        # if ($self->timed_out) {
            # return $self->error($errmsg);
        # } elsif ($self->eof) {
            # ($lastline = $self->lastline) =~ s/\n+//;
            # return $self->error($errmsg, ": ", $lastline);
        # } else {
            # return $self->error($errmsg);
        # }
    # };

    # Store the old prompt without the //s around it.
    my ($old_prompt) = _prep_regex($self->{cmd_prompt});

    # We need to expect either a Password prompt or a
    # typical prompt. If the user doesn't have enough
    # access to run the 'enable' command, the device
    # won't even query for a password, it will just
    # ignore the command and display another [boring] prompt.
    $self->put("enable " . $en_level . $ors);

    select(undef,undef,undef,$self->{waitfor_pause}); # sleep

    {
        my ($prematch, $match) = $self->waitfor(
            -match => '/[Ll]ogin[:\s]*$/',
            -match => '/[Uu]sername[:\s]*$/',
            -match => '/[Pp]assw(?:or)?d[:\s]*$/',
            -match => '/(?i:Passcode)[:\s]*$/',
            -match => "/$old_prompt/",
        ) or do {
            return &$error("read eof waiting for enable login or password prompt")
                if $self->eof;
            return &$error("timed-out waiting for enable login or password prompt");
        };

        if (not defined $match) {
            return $self->error("enable failed: access denied or bad name, passwd, etc")
        } elsif ($match =~ /sername|ogin/) {
            if (!defined $self->put($en_username . $ors)) {
                return $self->error("enable failed")
            }
            $self->{last_prompt} = $match;
            if ($seen{login}++) {
                return $self->error("enable failed: access denied or bad username")
            }
            redo
        } elsif ($match =~ /[Pp]assw/ ) {
            if (!defined $self->put($en_password . $ors)) {
                return $self->error("enable failed")
            }
            $self->{last_prompt} = $match;
            if ($seen{passwd}++) {
                return $self->error("enable failed: access denied or bad password")
            }
            redo
        } elsif ($match =~ /(?i:Passcode)/ ) {
            if (!defined $self->put($en_passcode . $ors)) {
                return $self->error("enable failed")
            }
            $self->{last_prompt} = $match;
            if ($seen{passcode}++) {
                return $self->error("enable failed: access denied or bad passcode")
            }
            redo
        } elsif ($match =~ /$old_prompt/) {
            ## Success! Exit the block.
            $self->{last_prompt} = $match;
            last
        } else {
            return $self->error("enable received unexpected prompt. Aborting.")
        }
    }

    if (not defined $en_level or $en_level =~ /^[1-9]/) {
        # Prompts and levels over 1 give a #/(enable) prompt.
        if ($self->is_enabled) {
            return 1
        } else {
            return $self->error("Failed to enter enable mode")
        }
    } else {
        # Assume success
        return 1
    }
}

sub eof {
    my ($self) = @_;
    exists $self->{_SSH_CHAN_} ? ($self->{_SSH_CHAN_}->eof or $self->{eofile}) : $self->{eofile};
}

sub errmode {
    my ($self, $arg) = @_;

    if (defined $arg) {
        if (defined (my $r = _parse_errmode($self, $arg))) {
            $self->{errormode} = $r
        }
    }
    return $self->{errormode}
}

sub errmsg {
    my ($self, @errmsgs) = @_;

    if (@_ >= 2) {
        $self->{errormsg} = join "", @errmsgs;
    }

    return $self->{errormsg}
}

sub error {
    my ($self, @errmsg) = @_;

    if ($self->ignore_warnings) {
        my $errmsg = join '', @errmsg;
        my $warnings_re = _prep_regex($self->warnings);
        return if $errmsg =~ /$warnings_re/;
    }

    my ($errmsg, $func, $mode, @args);
    local $_;

    if (@_ >= 2) {
        ## Put error message in the object.
        $errmsg = join "", @errmsg;
        $self->{errormsg} = $errmsg;
        ## Do the error action as described by error mode.
        $mode = $self->{errormode};
        if (ref($mode) eq "CODE") {
            &$mode($errmsg);
            return;
        } elsif (ref($mode) eq "ARRAY") {
            ($func, @args) = @$mode;
            &$func(@args);
            return;
        } elsif ($mode =~ /^return$/i) {
            return;
        } else {  # die
            if ($errmsg =~ /\n$/) {
                die $errmsg;
            } else {
                ## Die and append caller's line number to message.
                &_croak($self, $errmsg);
            }
        }
    } else {
        return $self->{errormsg} ne "";
    }
}

sub family {
    my ($self, $arg) = @_;

    if (defined $arg) {
        if (defined (my $r = _parse_family($self, $arg))) {
            $self->{peer_family} = $r
        }
    }
    return $self->{peer_family}
}

sub fhopen{
    my ($self, $arg) = @_;
    $self->{fh_open} = $arg if defined $arg;
    return $self->{fh_open}
}

sub host {
    my ($self, $arg) = @_;
    $self->{host} = $arg if defined $arg;
    return $self->{host}
}

sub ignore_warnings {
    my ($self, $arg) = @_;
    $self->{ignore_warnings} = $arg if defined $arg;
    return $self->{ignore_warnings}
}

sub input_log {
    my ($self, $name) = @_;

    my $fh = $self->{inputlog};

    if (@_ >= 2) {
        if (!defined($name) or $name eq "") {  # input arg is ""
            ## Turn off logging.
            $fh = "";
        } elsif (&_is_open_fh($name)) {  # input arg is an open fh
            ## Use the open fh for logging.
            $fh = $name;
            select((select($fh), $|=1)[$[]);  # don't buffer writes
        } elsif (!ref $name) {  # input arg is filename
            ## Open the file for logging.
            $fh = &_fname_to_handle($self, $name)
                or return;
            select((select($fh), $|=1)[$[]);  # don't buffer writes
        } else {
            return $self->error("bad Input_log argument ",
                "\"$name\": not filename or open fh");
        }
        $self->{inputlog} = $fh;
    }
    $fh;
}

sub input_record_separator {
    my ($self, $arg) = @_;
    $self->{rs} = $arg if (defined $arg and length $arg);
    return $self->{rs}
}

sub ios_break {
    my ($self, $arg) = @_;

    my $chan = $self->{_SSH_CHAN_};
    my $ret;
    if (defined $arg) {
        $ret = $self->put("\c^$arg")
    } else {
        $ret = $self->put("\c^")
    }

    return $ret;
}

sub is_enabled { $_[0]->last_prompt =~ /\#|enable|config/ ? 1 : undef }

sub last_cmd {
    my $self = shift;
    exists $self->{last_cmd} ? $self->{last_cmd} : undef
}

sub last_prompt {
    my $self = shift;
    exists $self->{last_prompt} ? $self->{last_prompt} : undef
}

sub login {
    my ($self, @args) = @_;

    if (!$self->{opened}) {
        &_croak($self, "no connect " .
        "for " . ref($self) . "::login()");
    }

    my $bin     = $self->{bin_mode};
    my $block   = $self->{blocking};
    my $prompt  = $self->{cmd_prompt};
    my $timeout = $self->{time_out};
    my $ssh     = $self->{_SSH_};
    my $sent_wakeup = 0;
    my ($user, $pass);

    $self->{timedout} = '';

    my $arg_errmode = &_extract_arg_errmode($self, \@args);
    local $self->{errormode} = $arg_errmode if $arg_errmode;

    if (@_ == 3) { # just username and passwd given
        ($user, $pass) = (@_[1,2])
    } else {
        my %args = @args;
        for (keys(%args)) {
            if (/^-?(?:user)?name$/i) {
                $user = $args{$_}
            } elsif (/^-?passw(?:ord)?$/i) {
                $pass = $args{$_}
            } elsif (/^-?prompt$/i) {
                $prompt = _parse_prompt($self, $args{$_})
                    or return
            } elsif (/^-?timeout$/i) {
                $timeout = _parse_timeout($self, $args{$_})
            } else {
                # pass through
                #$params{$_} = $args{$_}
                &_croak($self, "bad named parameter \"$_\" given ",
                    "to " . ref($self) . "::login()");
            }
        }
    }

    if (!defined $user) {
        &_croak($self,"username argument not given to " . ref($self) . "::login()")
    }
    if (!defined $pass) {
        &_croak($self,"password argument not given to " . ref($self) . "::login()")
    }

    local $self->{time_out} = $timeout;

    # This is where we'd do 'connect' send_wakeup if Net::SSH2 supported
    if ($self->{send_wakeup} eq 'connect') {
        $sent_wakeup = 1;

        # my $old_sep = $self->output_record_separator;
        # $self->output_record_separator("\n");
        # $self->print('');
        # $self->output_record_separator($old_sep);
    }

    AUTH:
    if ($ssh->auth_password($user, $pass)) {
        my $chan = $ssh->channel();
        $chan->blocking($block); # 0 Needed on Windows
        $chan->shell();
        if ($bin) {
            CORE::binmode ($chan)
        }
        $self->{_SSH_CHAN_} = $chan;

        # flush buffer, read off first prompt
        if ($sent_wakeup == 0 && $self->{send_wakeup} eq 'noflush') {

            # do nothing
            $sent_wakeup = 1;
        } else {
            $sent_wakeup = 1;
            $self->waitfor($self->{cmd_prompt});
        }
    } else {
        # This is where we'd do 'timeout' send_wakeup if Net::SSH2 supported
        if ($sent_wakeup == 0 && $self->{send_wakeup} eq 'timeout') {
            $sent_wakeup = 1;

            # my $old_sep = $self->output_record_separator;
            # $self->output_record_separator("\n");
            # $self->print('');
            # $self->output_record_separator($old_sep);

            # goto AUTH;
        }
        my ($errcode, $errname, $errstr) = $ssh->error;
        return $self->error("Net::SSH2 error $errcode:$errname [$errstr]\nauthentication failed for user - `$user'")
    }
    1
}

sub max_buffer_length {
    my ($self, $arg) = @_;

    my $minbufsize = 512;

    if (defined $arg) {
        if ($arg =~ /^\d+$/) {
            $self->{maxbufsize} = $arg
        } else {
            &_carp($self, "ignoring bad Max_buffer_length " .
                "argument \"$arg\": it's not a positive integer");
        }
    }

    ## Adjust up values that are too small.
    if ($self->{maxbufsize} < $minbufsize) {
        $self->{maxbufsize} = $minbufsize;
    }

    return $self->{maxbufsize}
}

sub more_prompt {
    my ($self, $arg) = @_;

    if (defined $arg) {
        $self->_match_check($arg);
        $self->{more_prompt} = $arg;
    }
    return $self->{more_prompt};
}

sub normalize_cmd {
    my ($self, $arg) = @_;
    $self->{normalize_cmd} = $arg if defined $arg;
    return $self->{normalize_cmd}
}

sub ofs { &output_field_separator; }

sub open {
    my ($self, @args) = @_;

    return 1 if $self->{opened};

    my $ssh     = $self->{_SSH_};
    my $family  = $self->{peer_family};
    my $fh      = $self->{fh_open};
    my $host    = $self->{host};
    my $port    = $self->{port};
    my $timeout = $self->{time_out};

    $self->{timedout} = '';

    my $arg_errmode = &_extract_arg_errmode($self, \@args);
    local $self->{errormode} = $arg_errmode if $arg_errmode;

    if (@_ == 2) {
        ($host) = $_[1]
    } else {
        my %args = @args;
        for (keys(%args)) {
            if (/^-?fhopen$/i) {
                $fh = $args{$_}
            } elsif (/^-?host$/i) {
                $host = $args{$_}
            } elsif (/^-?family$/i) {
                $family = _parse_family($self, $args{$_})
            } elsif (/^-?port$/i) {
                $port = _parse_port($self, $args{$_})
            } elsif (/^-?timeout$/i) {
                $timeout = _parse_timeout($self, $args{$_})
            } else {
                # pass through
                #$params{$_} = $args{$_}
                &_croak($self, "bad named parameter \"$_\" given ",
                    "to " . ref($self) . "::connect()");
            }
        }
    }

    local $self->{time_out} = $timeout;

    my $r;
    # IO::Socket object provided
    if (defined $fh) {
        $r = $ssh->connect($fh)
    # host provided
    } else {
        # resolve
        if (defined(my $res = _resolv($self, $host, _parse_family_to_num($self, $family)))) {
            $host = $res->{addr};
            $port = $res->{port} || $port
        } else {
            return $self->error($self->errmsg)
        }
        # connect if IPv4
        if ($family eq 'ipv4') {
            $ssh->timeout($timeout*1000); # timeout is in millisecs
            $r = $ssh->connect($host, $port)

        # if IPv6, Net::SSH2 doesn't yet support,
        # so need to create our own IO::Socket::IP
        } else {
            my $socket = IO::Socket::IP->new(
                PeerHost => $host,
                PeerPort => $port,
                Timeout  => $timeout,
                Family   => _parse_family_to_num($self, $family)
            );
            if (!$socket) {
                return $self->error("unable to connect to [$family] host - `$host:$port'")
            }
            $r = $ssh->connect($socket);
        }
    }
    if (! $r) {
        my ($errcode, $errname, $errstr) = $ssh->error;
        return $self->error("Net::SSH2 error - $errcode:$errname = $errstr\nunable to connect to host - `$host:$port'")
    }

    $self->{eofile} = '';
    $self->{errormsg} = "";
    $self->{opened} = 1;
    $self->{timedout} = '';
    1
}

sub ors { &output_record_separator }

sub output_field_separator {
    my ($self, $arg) = @_;
    $self->{ofs} = $arg if (defined $arg and length $arg);
    return $self->{ofs}
}

sub output_log {
    my ($self, $name) = @_;

    my $fh = $self->{outputlog};

    if (@_ >= 2) {
        if (!defined($name) or $name eq "") {  # input arg is ""
            ## Turn off logging.
            $fh = "";
        } elsif (&_is_open_fh($name)) {  # input arg is an open fh
            ## Use the open fh for logging.
            $fh = $name;
            select((select($fh), $|=1)[$[]);  # don't buffer writes
        } elsif (!ref $name) {  # input arg is filename
            ## Open the file for logging.
            $fh = &_fname_to_handle($self, $name)
                or return;
            select((select($fh), $|=1)[$[]);  # don't buffer writes
        } else {
            return $self->error("bad Output_log argument ",
                "\"$name\": not filename or open fh");
        }
        $self->{outputlog} = $fh;
    }
    $fh;
}

sub output_record_separator {
    my ($self, $arg) = @_;
    $self->{ors} = $arg if (defined $arg and length $arg);
    return $self->{ors}
}

sub port {
    my ($self, $arg) = @_;

    if (defined $arg) {
        if (defined (my $r = _parse_port($self, $arg))) {
            $self->{port} = $r
        }
    }
    return $self->{port}
}

sub print {
    my ($self) = shift;

    $self->{timedout} = '';

    return $self->error("write error: filehandle isn't open")
        unless $self->{opened};

    ## Add field and record separators.
    my $buf = join($self->{"ofs"}, @_) . $self->{"ors"};

    if ($self->{outputlog}) {
        &_log_print($self->{outputlog}, $buf);
    }

    &_put($self, \$buf, "print");
}

sub prompt {
    my ($self, $arg) = @_;

    if (defined $arg) {
        if (defined (my $r = _parse_prompt($self, $arg))) {
            $self->{cmd_prompt} = $r
        }
    }
    return $self->{cmd_prompt}
}

sub put {
    my ($self, @args) = @_;

    local $_;

    my $binmode = $self->{bin_mode};
    my $timeout = $self->{time_out};
    $self->{timedout} = '';

    my $arg_errmode = &_extract_arg_errmode($self, \@args);
    local $self->{errormode} = $arg_errmode if $arg_errmode;

    my $buf;
    if (@_ == 2) {
        $buf = $_[1];
    } elsif (@_ > 2) {
        my (undef, %args) = @_;
        foreach (keys %args) {
            if (/^-?binmode$/i) {
                $binmode = $args{$_};
            } elsif (/^-?string$/i) {
                $buf = $args{$_};
            } elsif (/^-?timeout$/i) {
                $timeout = &_parse_timeout($self, $args{$_});
            } else {
                &_croak($self, "bad named parameter \"$_\" given ",
                    "to " . ref($self) . "::put()");
            }
        }
    }

    ## If any args given, override corresponding instance data.
    local $self->{bin_mode} = $binmode;
    local $self->{time_out} = $timeout;

    ## Check for errors.
    return $self->error("write error: filehandle isn't open")
        unless $self->{opened};

    if ($self->{outputlog}) {
        &_log_print($self->{outputlog}, $buf);
    }

    &_put($self, \$buf, "put");
}

sub rs { &input_record_separator }

sub send_wakeup {
    my ($self, $arg) = @_;
    $self->{send_wakeup} = $arg if defined $arg;
    return $self->{send_wakeup}
}

sub sock {
    my $self = shift;
    exists $self->{_SSH_} ? $self->{_SSH_}->sock : undef
}

sub ssh2 {
    my $self = shift;
    exists $self->{_SSH_} ? $self->{_SSH_} : undef
}

sub ssh2_chan {
    my $self = shift;
    exists $self->{_SSH_CHAN_} ? $self->{_SSH_CHAN_} : undef
}

sub timed_out {
    my $self = shift;
    exists $self->{timedout} ? $self->{timedout} : undef
}

sub timeout {
    my ($self, $arg) = @_;

    if (defined $arg) {
        if (defined (my $r = _parse_timeout($self, $arg))) {
            $self->{time_out} = $r
        }
    }
    return $self->{time_out}
}

sub waitfor {
    my ($self, @args) = @_;

    my $ap      = $self->{autopage};
    my $awfp    = $self->{always_waitfor_prompt};
    my $binmode = $self->{bin_mode};
    my $chan    = $self->{_SSH_CHAN_};
    my $clear   = $self->{waitfor_clear};
    my $cmd     = $self->{last_cmd};
    my $rm      = $self->{cmd_rm_mode};
    my $timeout = $self->{time_out};

    if (!defined $chan) {
        &_croak($self, "no login " .
        "for " . ref($self) . "::waitfor()");
    }

    local $@;
    local $_;
    my $DONE   = 0;
    my $MORE   = _prep_regex($self->{more_prompt});
    my $PROMPT = _prep_regex($self->{cmd_prompt});
    my ($match, $buffer, $errmode);
    my @matches;
    if ($awfp) {
        push @matches, $PROMPT
    }

    $self->{timedout} = '';
    return if $self->{eofile};
    return unless @args;

    if (@_ == 2) {
        push @matches, _prep_regex($_[1])
    } else {
        my $arg;
        while (($_, $arg) = splice @args, 0, 2 ) {
            if (/^-?binmode$/i) {
                $binmode = $arg
            } elsif (/^-?errmode$/i) {
                $errmode = &_parse_errmode($self, $arg);
            } elsif (/^-?match$/i) {
                push @matches, _prep_regex($arg)
            } elsif (/^-?string$/i) {
                $arg =~ s/'/\\'/g;  # quote ticks
                push @matches, $arg
            } elsif (/^-?timeout$/i) {
                $timeout = _parse_timeout($self, $arg)
            } elsif (/^-?waitfor_clear$/i) {
                $clear = $arg
            } else {
                # pass through
                #$params{$_} = $args{$_}
                &_croak($self, "bad named parameter \"$_\" given " .
                    "to " . ref($self) . "::waitfor()");
            }
        }
    }

    local $self->{errormode} = $errmode if defined $errmode;
    local $self->{waitfor_clear} = $clear;

    eval {
        local $SIG{ALRM} = sub { die "timed-out\n" };
        alarm $timeout;

        if ($self->{waitfor_clear}) {
            $chan->flush;
        }

        # Read until $DONE
        while (1) {
            last if $DONE;
            last if $self->eof;
            my $buf;
            # Read chunk
            while (defined (my $len = $chan->read($buf,$self->{maxbufsize}))) {

                ## Display network traffic if requested.
                if ($self->{dumplog} and ($buf ne '')) {
                    &_log_dump('<', $self->{dumplog}, \$buf, 0, $len);
                }

                # input logging
                if ($self->{inputlog}) {
                    &_log_print($self->{inputlog}, $buf);
                }

                # Found match then $DONE
                for my $m (@matches) {
                    if ($buf =~ /($m)/) {
                        $match = $1;
                        $buf =~ s/$m//;
                        $DONE++
                    }
                }
                # autopage
                if ($ap and ($buf =~ /($MORE)/)) {
                    #$buf =~ s/$MORE//g;
                    $self->put(" ");
                }
                $buffer .= $buf
            }
        }
    };
    alarm 0;
    if ($@ =~ /^timed-out$/) {
        $self->errmsg("timed-out during read");
        $self->{timedout} = 1;
        # If previous call to waitfor timed out, there may still be
        # stuff in the channel - e.g., "show run" takes time to "build
        # configuration" and that may time out, but the output will fill
        # the channel after the return and if term length is a finite
        # value - like the default 24 - a MORE prompt is waiting.  So
        # we need to send a character to cancel that; otherwise, the first
        # character of the subsequent $chan->write() (usually from cmd())
        # will "disappear" from the output - satisfying the MORE prompt
        # and being lost forever.
        # The following is 'Control-Shift-Z', which breaks a MORE and
        # returns the prompt.
        #$chan->write("\cZ")
        if ($self->{waitfor_clear}) {
            $self->ios_break("Z")
        }
    }

    if (defined $match and ($match =~ /$PROMPT/)) {
        $self->{last_prompt} = $match
    }

    wantarray ? ($buffer, $match) : 1;
}

sub waitfor_clear {
    my ($self, $arg) = @_;
    $self->{waitfor_clear} = $arg if defined $arg;
    return $self->{waitfor_clear}
}

sub waitfor_pause {
    my ($self, $arg) = @_;

    if (defined $arg) {
        if (defined (my $r = _parse_waitfor_pause($self, $arg))) {
            $self->{waitfor_pause} = $r
        }
    }
    return $self->{waitfor_pause}
}

sub warnings {
    my ($self, $arg) = @_;
    $self->{warnings} = $arg if defined $arg;
    return $self->{warnings}
}

#### PRIVATE ####

sub _append_lineno {
    my ($obj, @msgs) = @_;

    my ( $file, $line, $pkg);

    ## Find the caller that's not in object's class or one of its base classes.
    ($pkg, $file , $line) = &_user_caller($obj);
    join("", @msgs, " at ", $file, " line ", $line, "\n");
}

sub _carp {
    my ($self) = @_;

    $self->{errormsg} = &_append_lineno(@_);
    warn $self->{errormsg}, "\n";
}

sub _croak {
    my ($self) = @_;

    $self->{errormsg} = &_append_lineno(@_);
    die $self->{errormsg}, "\n";
}

sub _extract_arg_errmode {
    my ($self, $args) = @_;
    my (%args);
    local $_;
    my $errmode = '';

    ## Check for named parameters.
    return '' unless @$args >= 2;

    ## Rebuild args without errmode parameter.
    %args = @$args;
    @$args = ();

    ## Extract errmode arg.
    foreach (keys %args) {
        if (/^-?errmode$/i) {
            $errmode = &_parse_errmode($self, $args{$_});
        } else {
            push @$args, $_, $args{$_};
        }
    }
    $errmode;
}

sub _fname_to_handle {
    my ($self, $filename) = @_;

    no strict "refs";

    my $fh = &_new_handle();
    CORE::open $fh, ">", $filename
        or return $self->error("problem creating $filename: $!");

    $fh;
}

sub _is_open_fh {
    my ($fh) = @_;
    my $is_open = '';
    local $@;

    eval {
        local $SIG{"__DIE__"} = "DEFAULT";
        $is_open = defined(fileno $fh);
    };

    $is_open;
}

sub _log_dump {
    my ($direction, $fh, $data, $offset, $len) = @_;

    my $addr = 0;
    $len = length($$data) - $offset
        if !defined $len;
    return 1 if $len <= 0;

    my ($hexvals, $line);
    ## Print data in dump format.
    while ($len > 0) {
        ## Convert up to the next 16 chars to hex, padding w/ spaces.
        if ($len >= 16) {
            $line = substr $$data, $offset, 16;
        } else {
            $line = substr $$data, $offset, 16;
        }
        $hexvals = unpack("H*", $line);
        $hexvals .= ' ' x (32 - length $hexvals);

        ## Place in 16 columns, each containing two hex digits.
        $hexvals = sprintf("%s %s %s %s  " x 4, unpack("a2" x 16, $hexvals));

        ## For the ASCII column, change unprintable chars to a period.
        $line =~ s/[\000-\037,\177-\237]/./g;

        ## Print the line in dump format.
        &_log_print($fh, sprintf("%s 0x%5.5lx: %s%s\n",
            $direction, $addr, $hexvals, $line));

        $addr += 16;
        $offset += 16;
        $len -= 16;
    }

    &_log_print($fh, "\n");

    1;
}

sub _log_print {
    my ($fh, $buf) = @_;
    local $\ = '';

    if (ref($fh) eq "GLOB") {  # fh is GLOB ref
        print $fh $buf;
    } else {  # fh isn't GLOB ref
        $fh->print($buf);
    }
}

sub _match_check {
    my ($self, $code) = @_;
    my $error;
    my @warns = ();
    local $@;

    ## Use eval to check for syntax errors or warnings.
    {
        local $SIG{"__DIE__"} = "DEFAULT";
        local $SIG{"__WARN__"} = sub { push @warns, @_ };
        local $^W = 1;
        local $_ = '';
        eval "\$_ =~ $code;";
    }
    if ($@) {
        ## Remove useless lines numbers from message.
        ($error = $@) =~ s/ at \(eval \d+\) line \d+.?//;
        chomp $error;
        return $self->error("bad match operator: $error");
    } elsif (@warns) {
        ## Remove useless lines numbers from message.
        ($error = shift @warns) =~ s/ at \(eval \d+\) line \d+.?//;
        $error =~ s/ while "strict subs" in use//;
        chomp $error;
        return $self->error("bad match operator: $error");
    }

    1;
}

sub _new_handle {
    if ($INC{"IO/Handle.pm"}) {
        return IO::Handle->new;
    } else {
        require FileHandle;
        return FileHandle->new;
    }
}

sub _normalize {
    $_ = join "", @_;

    1 while s/[^\cH\c?][\cH\c?]//mg; # ^H ^?
    s/^.*\cU//mg;            # ^U

    return wantarray ? split /$/m, $_ : $_; # ORS instead?
}

sub _parse_cmd_remove_mode {
    my ($self, $arg) = @_;

    my $crm;
    if ($arg =~ /^\d+$/) {
        $crm = $arg
    } elsif ($arg =~ /^\s*auto\s*$/i) {
        $crm = "auto"
    } else {
        &_carp($self, "ignoring bad Cmd_remove_mode " .
            "argument \"$arg\": it's not \"auto\" or a " .
            "non-negative integer");
        $crm = $self->{cmd_rm_mode}
    }
    $crm
}

sub _parse_errmode {
    my ($self, $errmode) = @_;

    ## Set the error mode.
    if (!defined $errmode) {
        &_carp($self, "ignoring undefined Errmode argument");
        $errmode = $self->{errormode};
    } elsif ($errmode =~ /^\s*return\s*$/i) {
        $errmode = "return";
    } elsif ($errmode =~ /^\s*die\s*$/i) {
        $errmode = "die";
    } elsif (ref($errmode) eq "CODE") {
    } elsif (ref($errmode) eq "ARRAY") {
        unless (ref($errmode->[0]) eq "CODE") {
            &_carp($self, "ignoring bad Errmode argument: " .
                "first list item isn't a code ref");
            $errmode = $self->{errormode};
        }
    } else {
        &_carp($self, "ignoring bad Errmode argument \"$errmode\"");
        $errmode = $self->{errormode};
    }
    $errmode;
}

sub _parse_family {
    my ($self, $arg) = @_;

    my $family;
    if ($arg =~ /^(?:(?:(:?ip)?v?(?:4|6))|${\AF_INET}|$AF_INET6)$/) {
        if ($arg =~ /^(?:(?:(:?ip)?v?4)|${\AF_INET})$/) {
            $family = 'ipv4' # AF_INET
        } else {
            if (!$HAVE_IO_Socket_IP) {
                return $self->error("IO::Socket::IP required for IPv6")
            }
            $family = 'ipv6' # $AF_INET6
        }
    } else {
        return $self->error("bad Family argument \"$arg\": " .
            "must be \"ipv4\" or \"ipv6\"");
    }
    $family
}

sub _parse_family_to_num {
    my ($self, $arg) = @_;
    if ($arg eq 'ipv4') {
        return AF_INET
    } elsif ($arg eq 'ipv6') {
        return $AF_INET6
    } else {
        return $self->error("invalid address family - `$arg'");
    }
}

sub _parse_port {
    my ($self, $arg) = @_;

    my $port;
    if ($arg =~ /^\d{1,5}$/) {
        if (($arg > 0) and ($arg < 65536)) {
            $port = $arg
        } else {
            return $self->error("not a valid port - `$arg'")
        }
    } else {
        return $self->error("port not a valid number - `$arg'")
    }
    $port
}

sub _parse_prompt {
    my ($self, $prompt) = @_;

    unless (defined $prompt) {
        $prompt = "";
    }

    return $self->error("bad Prompt argument \"$prompt\": " .
        "missing opening delimiter of match operator")
        unless $prompt =~ m(^\s*/) or $prompt =~ m(^\s*m\s*\W);

    $prompt;
}

sub _parse_timeout {
    my ($self, $arg) = @_;

    my $timeout;
    if ($arg =~ /^\d+$/) {
        $timeout = $arg
    } else {
        return $self->error("not a valid timeout - `$arg'")
    }
    $timeout
}

sub _parse_waitfor_pause {
    my ($self, $arg) = @_;

    my $wfp;
    if ($arg =~ /^[0-9]*\.?[0-9]+$/) {
        $wfp = $arg
    } else {
        return $self->error("not a valid waitfor_pause - `$arg'")
    }
    $wfp
}

sub _put {
    my ($self, $buf, $subname) = @_;

    return $self->error("write error: filehandle isn't open")
        unless $self->{opened};

    if (exists $self->{_SSH_CHAN_}) {
        my $nwrote = $self->{_SSH_CHAN_}->write($$buf);

        ## Display network traffic if requested.
        if ($self->{dumplog}) {
            &_log_dump('>', $self->{dumplog}, $buf, 0, $nwrote);
        }
    } else {
        return $self->error("Net::SSH2::Channel not created")
    }
    1
}

sub _prep_regex {
    my ($regex) = @_;
    # strip leading / if found
    $regex =~ s/^\///;
    # strip trailing / if found
    $regex =~ s/\/$//;

    return $regex
}

##################################################
# DNS hostname resolution
# return:
#   $host->{name}   = host - as passed in
#   $host->{host}   = host - as passed in without :port
#   $host->{port}   = OPTIONAL - if :port, then value of port
#   $host->{addr}   = resolved numeric address
#   $host->{family} = AF_INET/6
############################
sub _resolv {
    my ($self, $name, $family) = @_;

    my %h;
    $h{name} = $name;

    # Default to IPv4 for backward compatiblity
    # THIS MAY CHANGE IN THE FUTURE!!!
    if (!defined $family) {
        $family = AF_INET
    }

# START - host:port
    my $cnt = 0;

    # Count ":"
    $cnt++ while ($name =~ m/:/g);

    # 0 = hostname or IPv4 address
    if ($cnt == 0) {
        $h{host} = $name
    # 1 = IPv4 address with port
    } elsif ($cnt == 1) {
        ($h{host}, $h{port}) = split /:/, $name
    # >=2 = IPv6 address
    } elsif ($cnt >= 2) {
        #IPv6 with port - [2001::1]:port
        if ($name =~ /^\[.*\]:\d{1,5}$/) {
            ($h{host}, $h{port}) = split /:([^:]+)$/, $name # split after last :
        # IPv6 without port
        } else {
            $h{host} = $name
        }
    }

    # Clean up host
    $h{host} =~ s/\[//g;
    $h{host} =~ s/\]//g;
    # Clean up port
    if (defined $h{port} && (($h{port} !~ /^\d{1,5}$/) || ($h{port} < 1) || ($h{port} > 65535))) {
        $self->errmsg("Invalid port `$h{port}' in `$name'");
        return undef
    }
# END - host:port

    # address check
    # new way
    if (version->parse($Socket::VERSION) >= version->parse(1.94)) {
        my %hints = (
            family   => $AF_UNSPEC,
            protocol => IPPROTO_TCP,
            flags => $AI_NUMERICHOST
        );

        # numeric address, return
        my ($err, @getaddr) = Socket::getaddrinfo($h{host}, undef, \%hints);
        if (defined $getaddr[0]) {
            $h{addr}   = $h{host};
            $h{family} = $getaddr[0]->{family};
            return \%h
        }
    # old way
    } else {
        # numeric address, return
        my $ret = gethostbyname($h{host});
        if (defined $ret && (inet_ntoa($ret) eq $h{host})) {
            $h{addr}   = $h{host};
            $h{family} = AF_INET;
            return \%h
        }
    }

    # resolve
    # new way
    if (version->parse($Socket::VERSION) >= version->parse(1.94)) {
        my %hints = (
            family   => $family,
            protocol => IPPROTO_TCP
        );

        my ($err, @getaddr) = Socket::getaddrinfo($h{host}, undef, \%hints);
        if (defined $getaddr[0]) {
            my ($err, $address) = Socket::getnameinfo($getaddr[0]->{addr}, $NI_NUMERICHOST);
            if (defined $address) {
                $h{addr} = $address;
                $h{addr} =~ s/\%(.)*$//; # remove %ifID if IPv6
                $h{family} = $getaddr[0]->{family};
                return \%h
            } else {
                $self->errmsg("getnameinfo($getaddr[0]->{addr}) failed - $err");
                return undef
            }
        } else {
            my $LASTERROR = sprintf "getaddrinfo($h{host},,%s) failed - $err", ($family == AF_INET) ? "AF_INET" : "AF_INET6";
            $self->errmsg($LASTERROR);
            return undef
        }
    # old way
    } else {
        if ($family == $AF_INET6) {
            $self->errmsg("Socket >= 1.94 required for IPv6 - found Socket $Socket::VERSION");
            return undef
        }

        my @gethost = gethostbyname($h{host});
        if (defined $gethost[4]) {
            $h{addr} = inet_ntoa($gethost[4]);
            $h{family} = AF_INET;
            return \%h
        } else {
            $self->errmsg("gethostbyname($h{host}) failed - $^E");
            return undef
        }
    }
}

sub _user_caller {
    my ($obj) = @_;

    my ($class, $curr_pkg, $file, $i, $line, $pkg, %isa, @isa);
    local $@;
    local $_;

    ## Create a boolean hash to test for isa.  Make sure current
    ## package and the object's class are members.
    $class = ref $obj;
    @isa = eval "\@${class}::ISA";
    push @isa, $class;
    ($curr_pkg) = caller 1;
    push @isa, $curr_pkg;
    %isa = map { $_ => 1 } @isa;

    ## Search back in call frames for a package that's not in isa.
    $i = 1;
    while (($pkg, $file, $line) = caller ++$i) {
        next if $isa{$pkg};

        return ($pkg, $file, $line);
    }

    ## If not found, choose outer most call frame.
    ($pkg, $file, $line) = caller --$i;
    return ($pkg, $file, $line);
}

1;

__END__