cisco-auditing-tool-1.0/0000755000000000000000000000000012046511414013723 5ustar rootrootcisco-auditing-tool-1.0/plugins/0000755000000000000000000000000012046511414015404 5ustar rootrootcisco-auditing-tool-1.0/plugins/usage0000644000000000000000000000110312046511414016426 0ustar rootrootsub usage { print "\n"; print "Cisco Auditing Tool - g0ne [null0]\n"; print "Usage: \n"; print "\t-h hostname\t(for scanning single hosts)\n"; print "\t-f hostfile\t(for scanning multiple hosts)\n"; print "\t-p port #\t(default port is 23)\n"; print "\t-w wordlist\t(wordlist for community name guessing)\n"; print "\t-a passlist\t(wordlist for password guessing)\n"; print "\t-i [ioshist]\t(Check for IOS History bug)\n"; print "\t-l logfile\t(file to log to, default screen)\n"; print "\t-q quiet mode\t(no screen output)\n"; print "\n"; return(1); } print; cisco-auditing-tool-1.0/plugins/ihist0000644000000000000000000000065012046511414016450 0ustar rootrootuse Net::Telnet(); sub ihist { my ($host, $port) = @_; $telnet = new Net::Telnet ( Port => $port, Host => $host, Timeout => 1, Errmode => 'die'); $telnet->waitfor('/password[: ]*$/i'); $users = `finger \@$host`; $telnet->print("\x16\x00"); for ($i = 0; $i < 97; $i++) { $telnet->print("\x20"); } $telnet->print("\n\n"); $output = $telnet->get; return $users, $output; } print; cisco-auditing-tool-1.0/plugins/snmp0000644000000000000000000000074512046511414016312 0ustar rootrootuse Net::SNMP; sub snmp { my ($hostname, $community) = @_; my $port = 161; my ($session, $error) = Net::SNMP->session( Hostname => $hostname, Community => $community, Port => $port ); if (!defined($session)) { return 0; } my $uptime='1.3.6.1.2.1.1.3.0'; $session->timeout(2); $session->retries(2); my $response=''; if (!defined($response = $session->get_request($uptime))) { $session->close; return 0; } $session->close; return 1; } print; cisco-auditing-tool-1.0/plugins/.svn/0000755000000000000000000000000012046511414016270 5ustar rootrootcisco-auditing-tool-1.0/plugins/.svn/entries0000444000000000000000000000164012046511414017663 0ustar rootroot10 dir 1733 svn+ssh://dookie@10.0.0.12/var/svn/backtrack/microverse/c/cisco-auditing-tool/source-cisco-auditing-tool-1.0-bt1/var/backtrack/sources/cisco-auditing-tool/1.0/bt1/upstream-sources/cisco-auditing-tool/plugins svn+ssh://dookie@10.0.0.12/var/svn/backtrack 2011-04-18T09:02:05.482722Z 327 emgent d9273255-a111-4fa6-bf0a-919607b5ba98 ihist file 2011-08-26T04:18:02.810183Z adf199fdd006967318a95bf617b80396 2011-04-18T09:02:05.482722Z 327 emgent 424 brute file 2011-08-26T04:18:02.810183Z d079514b9b1f07eaf6ed1324af7cb3d6 2011-04-18T09:02:05.482722Z 327 emgent 474 usage file 2011-08-26T04:18:02.810183Z c2f134c2e769f1d65a9817fc48bc0631 2011-04-18T09:02:05.482722Z 327 emgent 579 snmp file 2011-08-26T04:18:02.814183Z 8778c7ccf840224c69725a9d25f49779 2011-04-18T09:02:05.482722Z 327 emgent 485 cisco-auditing-tool-1.0/plugins/.svn/text-base/0000755000000000000000000000000012046511414020164 5ustar rootrootcisco-auditing-tool-1.0/plugins/.svn/text-base/usage.svn-base0000444000000000000000000000110312046511414022721 0ustar rootrootsub usage { print "\n"; print "Cisco Auditing Tool - g0ne [null0]\n"; print "Usage: \n"; print "\t-h hostname\t(for scanning single hosts)\n"; print "\t-f hostfile\t(for scanning multiple hosts)\n"; print "\t-p port #\t(default port is 23)\n"; print "\t-w wordlist\t(wordlist for community name guessing)\n"; print "\t-a passlist\t(wordlist for password guessing)\n"; print "\t-i [ioshist]\t(Check for IOS History bug)\n"; print "\t-l logfile\t(file to log to, default screen)\n"; print "\t-q quiet mode\t(no screen output)\n"; print "\n"; return(1); } print; cisco-auditing-tool-1.0/plugins/.svn/text-base/ihist.svn-base0000444000000000000000000000065012046511414022743 0ustar rootrootuse Net::Telnet(); sub ihist { my ($host, $port) = @_; $telnet = new Net::Telnet ( Port => $port, Host => $host, Timeout => 1, Errmode => 'die'); $telnet->waitfor('/password[: ]*$/i'); $users = `finger \@$host`; $telnet->print("\x16\x00"); for ($i = 0; $i < 97; $i++) { $telnet->print("\x20"); } $telnet->print("\n\n"); $output = $telnet->get; return $users, $output; } print; cisco-auditing-tool-1.0/plugins/.svn/text-base/brute.svn-base0000444000000000000000000000073212046511414022745 0ustar rootrootuse Net::Telnet(); sub brute { my ($host, $port, $password) = @_; $telnet = new Net::Telnet ( Port => $port, Host => $host, Timeout => 1, Errmode => 'die'); $telnet->waitfor('/password[: ]*$/i'); $telnet->print($password); ($prematch, $match) = $telnet->waitfor(-match => '/>$/i', -match => '/password[: ]*$/i'); if ($match =~ />$/i) { $telnet->close; return (1); } else { $telnet->close; return (0); } } print; cisco-auditing-tool-1.0/plugins/.svn/text-base/snmp.svn-base0000444000000000000000000000074512046511414022605 0ustar rootrootuse Net::SNMP; sub snmp { my ($hostname, $community) = @_; my $port = 161; my ($session, $error) = Net::SNMP->session( Hostname => $hostname, Community => $community, Port => $port ); if (!defined($session)) { return 0; } my $uptime='1.3.6.1.2.1.1.3.0'; $session->timeout(2); $session->retries(2); my $response=''; if (!defined($response = $session->get_request($uptime))) { $session->close; return 0; } $session->close; return 1; } print; cisco-auditing-tool-1.0/plugins/.svn/tmp/0000755000000000000000000000000012046511414017070 5ustar rootrootcisco-auditing-tool-1.0/plugins/.svn/tmp/text-base/0000755000000000000000000000000012046511414020764 5ustar rootrootcisco-auditing-tool-1.0/plugins/.svn/tmp/props/0000755000000000000000000000000012046511414020233 5ustar rootrootcisco-auditing-tool-1.0/plugins/.svn/tmp/prop-base/0000755000000000000000000000000012046511414020760 5ustar rootrootcisco-auditing-tool-1.0/plugins/.svn/props/0000755000000000000000000000000012046511414017433 5ustar rootrootcisco-auditing-tool-1.0/plugins/.svn/prop-base/0000755000000000000000000000000012046511414020160 5ustar rootrootcisco-auditing-tool-1.0/plugins/brute0000644000000000000000000000073212046511414016452 0ustar rootrootuse Net::Telnet(); sub brute { my ($host, $port, $password) = @_; $telnet = new Net::Telnet ( Port => $port, Host => $host, Timeout => 1, Errmode => 'die'); $telnet->waitfor('/password[: ]*$/i'); $telnet->print($password); ($prematch, $match) = $telnet->waitfor(-match => '/>$/i', -match => '/password[: ]*$/i'); if ($match =~ />$/i) { $telnet->close; return (1); } else { $telnet->close; return (0); } } print; cisco-auditing-tool-1.0/lib/0000755000000000000000000000000012046511414014471 5ustar rootrootcisco-auditing-tool-1.0/lib/Net/0000755000000000000000000000000012046511414015217 5ustar rootrootcisco-auditing-tool-1.0/lib/Net/SNMP.pm0000644000000000000000000041313312046511414016337 0ustar rootroot# -*- mode: perl -*- # ============================================================================ package Net::SNMP; # $Id: SNMP.pm,v 3.0.1.1 2000/01/01 17:59:46 dtown Exp $ # $Source: /us/dtown/Projects/Net-SNMP/SNMP.pm,v $ # The module Net::SNMP implements an object oriented interface to the Simple # Network Management Protocol. Perl applications can use the module to # retrieve or update information on a remote host using the SNMP protocol. # Both SNMPv1 and SNMPv2c (Community-Based SNMPv2) are supported by the # module. The Net::SNMP module assumes that the user has a basic # understanding of the Simple Network Management Protocol and related # network management concepts. # Copyright (c) 1998-2000 David M. Town . # All rights reserved. # This program is free software; you may redistribute it and/or modify it # under the same terms as Perl itself. # ============================================================================ ## Global variables use vars qw( @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS @ASN1 @ASN1_PDU @GENERICTRAP @SNMP $DEBUG $FSM $REQUEST_ID $SOCKET $VERSION ); ## Version of Net::SNMP module $Net::SNMP::VERSION = 3.01; use strict; ## Required version of Perl require 5.003; ## Handle exporting of symbols use Exporter(); @ISA = qw(Exporter); @ASN1 = qw( INTEGER INTEGER32 OCTET_STRING NULL OBJECT_IDENTIFIER IPADDRESS COUNTER COUNTER32 GAUGE GAUGE32 UNSIGNED32 TIMETICKS OPAQUE COUNTER64 NOSUCHOBJECT NOSUCHINSTANCE ENDOFMIBVIEW ); @ASN1_PDU = qw( GET_REQUEST GET_NEXT_REQUEST GET_RESPONSE SET_REQUEST TRAP GET_BULK_REQUEST INFORM_REQUEST SNMPV2_TRAP ); @GENERICTRAP = qw( COLD_START WARM_START LINK_DOWN LINK_UP AUTHENTICATION_FAILURE EGP_NEIGHBOR_LOSS ENTERPRISE_SPECIFIC ); @SNMP = qw( SNMP_VERSION_1 SNMP_VERSION_2C SNMP_PORT SNMP_TRAP_PORT snmp_debug oid_context_match oid_lex_sort ticks_to_time ); @EXPORT = (@ASN1, 'snmp_event_loop'); @EXPORT_OK = (@ASN1_PDU, @GENERICTRAP, @SNMP, 'SEQUENCE', 'snmp_one_event'); %EXPORT_TAGS = ( asn1 => [@ASN1, @ASN1_PDU, 'SEQUENCE'], generictrap => [@GENERICTRAP], snmp => [@SNMP, 'snmp_event_loop'], ALL => [@EXPORT, @EXPORT_OK] ); ## Import socket() defines and structure manipulators use Socket qw(PF_INET SOCK_DGRAM inet_aton inet_ntoa sockaddr_in); sub IPPROTO_UDP() { 17 } ## ASN.1 Basic Encoding Rules type definitions sub INTEGER() { 0x02 } # INTEGER sub INTEGER32() { 0x02 } # Integer32 - SNMPv2c sub OCTET_STRING() { 0x04 } # OCTET STRING sub NULL() { 0x05 } # NULL sub OBJECT_IDENTIFIER() { 0x06 } # OBJECT IDENTIFIER sub SEQUENCE() { 0x30 } # SEQUENCE sub IPADDRESS() { 0x40 } # IpAddress sub COUNTER() { 0x41 } # Counter sub COUNTER32() { 0x41 } # Counter32 - SNMPv2c sub GAUGE() { 0x42 } # Gauge sub GAUGE32() { 0x42 } # Gauge32 - SNMPv2c sub UNSIGNED32() { 0x42 } # Unsigned32 - SNMPv2c sub TIMETICKS() { 0x43 } # TimeTicks sub OPAQUE() { 0x44 } # Opaque sub COUNTER64() { 0x46 } # Counter64 - SNMPv2c sub NOSUCHOBJECT() { 0x80 } # noSuchObject - SNMPv2c sub NOSUCHINSTANCE() { 0x81 } # noSuchInstance - SNMPv2c sub ENDOFMIBVIEW() { 0x82 } # endOfMibView - SNMPv2c sub GET_REQUEST() { 0xa0 } # GetRequest-PDU sub GET_NEXT_REQUEST() { 0xa1 } # GetNextRequest-PDU sub GET_RESPONSE() { 0xa2 } # GetResponse-PDU sub SET_REQUEST() { 0xa3 } # SetRequest-PDU sub TRAP() { 0xa4 } # Trap-PDU sub GET_BULK_REQUEST() { 0xa5 } # GetBulkRequest-PDU - SNMPv2c sub INFORM_REQUEST() { 0xa6 } # InformRequest-PDU - SNMPv2c sub SNMPV2_TRAP() { 0xa7 } # SNMPv2-Trap-PDU - SNMPv2c ## SNMP generic definitions sub SNMP_VERSION_1() { 0x00 } # RFC 1157 SNMP sub SNMP_VERSION_2C() { 0x01 } # RFCs 1901, 1905, and 1906 SNMPv2c sub SNMP_PORT() { 161 } # RFC 1157 standard UDP port for PDUs sub SNMP_TRAP_PORT() { 162 } # RFC 1157 standard UDP port for Trap-PDUs ## RFC 1157 generic-trap definitions sub COLD_START() { 0 } # coldStart(0) sub WARM_START() { 1 } # warmStart(1) sub LINK_DOWN() { 2 } # linkDown(2) sub LINK_UP() { 3 } # linkUp(3) sub AUTHENTICATION_FAILURE() { 4 } # authenticationFailure(4) sub EGP_NEIGHBOR_LOSS() { 5 } # egpNeighborLoss(5) sub ENTERPRISE_SPECIFIC() { 6 } # enterpriseSpecific(6) ## Default, minimum, and maximum values sub DEFAULT_HOSTNAME() { 'localhost' } sub DEFAULT_COMMUNITY() { 'public' } sub DEFAULT_MTU() { 484 } # RFC 1157 maximum size in octets sub DEFAULT_TIMEOUT() { 5.0 } # Timeout period for UDP in seconds sub DEFAULT_RETRIES() { 1 } # Number of retransmissions sub MINIMUM_MTU() { 30 } sub MINIMUM_TIMEOUT() { 1.0 } sub MINIMUM_RETRIES() { 0 } sub MAXIMUM_MTU() { 65535 } sub MAXIMUM_TIMEOUT() { 60.0 } sub MAXIMUM_RETRIES() { 20 } sub TRUE() { 0x1 } sub FALSE() { 0x0 } ## Intialize global variables sub BEGIN { # Import symbol generating function use Symbol qw(gensym); $DEBUG = FALSE; $FSM = undef; $REQUEST_ID = int(rand 0xff) + (time() & 0xff); $SOCKET = gensym(); } # [public methods] ----------------------------------------------------------- sub new { my ($class, %argv) = @_; # Create a new data structure for the object my $this = bless { '_buffer', => "\0" x DEFAULT_MTU, '_callback' => undef, '_community' => DEFAULT_COMMUNITY, '_error' => undef, '_error_index' => 0, '_error_status' => 0, '_fsm' => undef, '_hostname' => DEFAULT_HOSTNAME, '_leading_dot' => FALSE, '_mtu' => DEFAULT_MTU, '_nonblocking' => FALSE, '_port' => SNMP_PORT, '_request_id' => $REQUEST_ID++, '_retries' => DEFAULT_RETRIES, '_sockaddr' => undef, '_socket' => undef, '_type' => undef, '_timeout' => DEFAULT_TIMEOUT, '_translate' => TRUE, '_var_bind_list' => undef, '_version' => SNMP_VERSION_1 }, $class; # Validate the passed arguments foreach (keys %argv) { if (/^-?community$/i) { if ($argv{$_} eq '') { $this->_object_error('Empty community specified'); } else { $this->{'_community'} = $argv{$_}; } } elsif (/^-?debug$/i) { $this->debug($argv{$_}); } elsif (/^-?hostname$/i) { if ($argv{$_} eq '') { $this->_object_error('Empty hostname specified'); } else { $this->{'_hostname'} = $argv{$_}; } } elsif (/^-?mtu$/i) { $this->mtu($argv{$_}); } elsif (/^-?nonblocking$/i) { if ($argv{$_}) { $this->{'_nonblocking'} = TRUE; } else { $this->{'_nonblocking'} = FALSE; } } elsif (/^-?port$/i) { if ($argv{$_} !~ /^\d+$/) { $this->_object_error('Expected numeric port number'); } else { $this->{'_port'} = $argv{$_}; } } elsif (/^-?retries$/i) { $this->retries($argv{$_}); } elsif (/^-?timeout$/i) { $this->timeout($argv{$_}); } elsif (/^-?translate$/i) { $this->translate($argv{$_}); } elsif (/^-?version$/i) { $this->version($argv{$_}); } else { $this->_object_error("Invalid argument '%s'", $_); } if (defined($this->{'_error'})) { return wantarray ? (undef, $this->{'_error'}) : undef; } } # Create a global Net:SNMP::FSM object (if not created) when the # object has the "non-blocking" flag set, and store a reference # to the Finite State Machine (FSM) within the object. if ($this->{'_nonblocking'}) { if ((!defined($FSM)) || (ref($FSM) ne 'Net::SNMP::FSM')) { if (!defined($FSM = Net::SNMP::FSM->new())) { # You should never see this error! $this->_object_error( "Unable to create Net::SNMP Finite State Machine object" ); return wantarray ? (undef, $this->{'_error'}) : undef; } } $this->{'_fsm'} = $FSM; } # Return the object and empty error message (in list context) wantarray ? ($this, '') : $this; } sub open { my $this = shift; my ($host_addr, $proto) = (undef, undef); # Resolve the hostname to an IP address if (!defined($host_addr = inet_aton($this->hostname))) { return $this->_object_error( "Unable to resolve hostname '%s'", $this->hostname ); } # Pack the address and port information $this->{'_sockaddr'} = sockaddr_in($this->{'_port'}, $host_addr); # Get the protocol number for UDP if (!defined($proto = scalar(getprotobyname('udp')))) { $proto = IPPROTO_UDP; } # Open a global UDP socket for the package (if not open), and store # a reference to the socket within the object. if (!fileno($SOCKET)) { if (!socket($SOCKET, PF_INET, SOCK_DGRAM, $proto)) { return $this->_object_error("socket(): %s", $!); } } $this->{'_socket'} = $SOCKET; TRUE; } sub close { my $this = shift; # Clear all of the buffers and errors $this->_object_clear_buffer; $this->_object_clear_var_bind_list; $this->_object_clear_error; # Clear the socket refence so that we can tell that this particular # object has been closed. $this->{'_socket'} = undef; TRUE; } sub session { my $class = shift; # This is a convenience method (also present for backwards compatiblity), # that just combines the new() and the open() methods into one method. my ($this, $error) = $class->new(@_); if (defined($this)) { if (!defined($this->open)) { return wantarray ? (undef, $this->error) : undef; } } wantarray ? ($this, $error) : $this; } sub snmp_event_loop { ref($FSM) eq 'Net::SNMP::FSM' ? $FSM->event_loop : undef; } sub snmp_one_event { ref($FSM) eq 'Net::SNMP::FSM' ? $FSM->one_event : undef; } sub get_request { my $this = shift; # Handle passed arguments according to "blocking" mode if ($this->{'_nonblocking'}) { my %argv = @_; my @var_bind_list = (); # Validate the passed arguments foreach (keys %argv) { if (/^-?callback$/i) { if (!defined($this->_object_add_callback($argv{$_}))) { return $this->_object_error; } } elsif (/^-?varbindlist$/i) { if (ref($argv{$_}) ne 'ARRAY') { return $this->_object_error( 'Expected array reference for variable-bindings' ); } else { @var_bind_list = @{$argv{$_}}; } } else { return $this->_object_error("Invalid argument '%s'", $_); } } # Encode and queue the message if (!defined($this->_snmp_encode_get_request(@var_bind_list))) { return $this->_object_encode_error; } $this->_object_queue_message; } else { # Encode, send and wait, and decode the message if (!defined($this->_snmp_encode_get_request(@_))) { return $this->_object_encode_error; } if (!defined($this->_udp_send_message)) { return $this->_object_decode_error; } $this->_snmp_validate_get_response; } } sub get_next_request { my $this = shift; # Handle passed arguments according to "blocking" mode if ($this->{'_nonblocking'}) { my %argv = @_; my @var_bind_list = (); # Validate the passed arguments foreach (keys %argv) { if (/^-?callback$/i) { if (!defined($this->_object_add_callback($argv{$_}))) { return $this->_object_error; } } elsif (/^-?varbindlist$/i) { if (ref($argv{$_}) ne 'ARRAY') { return $this->_object_error( 'Expected array reference for variable-bindings' ); } else { @var_bind_list = @{$argv{$_}}; } } else { return $this->_object_error("Invalid argument '%s'", $_); } } # Encode and queue the message if (!defined($this->_snmp_encode_get_next_request(@var_bind_list))) { return $this->_object_encode_error; } $this->_object_queue_message; } else { # Encode, send and wait, and decode the message if (!defined($this->_snmp_encode_get_next_request(@_))) { return $this->_object_encode_error; } if (!defined($this->_udp_send_message)) { return $this->_object_decode_error; } $this->_snmp_validate_get_response; } } sub set_request { my $this = shift; # Handle passed arguments according to "blocking" mode if ($this->{'_nonblocking'}) { my %argv = @_; my @var_bind_list = (); # Validate the passed arguments foreach (keys %argv) { if (/^-?callback$/i) { if (!defined($this->_object_add_callback($argv{$_}))) { return $this->_object_error; } } elsif (/^-?varbindlist$/i) { if (ref($argv{$_}) ne 'ARRAY') { return $this->_object_error( 'Expected array reference for variable-bindings' ); } else { @var_bind_list = @{$argv{$_}}; } } else { return $this->_object_error("Invalid argument '%s'", $_); } } # Encode and queue the message if (!defined($this->_snmp_encode_set_request(@var_bind_list))) { return $this->_object_encode_error; } $this->_object_queue_message; } else { # Encode, send and wait, and decode the message if (!defined($this->_snmp_encode_set_request(@_))) { return $this->_object_encode_error; } if (!defined($this->_udp_send_message)) { return $this->_object_decode_error; } $this->_snmp_validate_get_response; } } sub trap { my ($this, %argv) = @_; # Clear any previous error message $this->_object_clear_error; # Use Sys:Hostname to determine the IP address of the client sending # the trap. Only require the module for Trap-PDUs. use Sys::Hostname(); # Setup default values for the Trap-PDU by creating new entries in # the Net::SNMP object. # Use iso.org.dod.internet.private.enterprises for the default enterprise. $this->{'_enterprise'} = '1.3.6.1.4.1'; # Create an entry for the agent-addr (we will fill it in below if # if the user does not specify an address) $this->{'_agent_addr'} = undef; # Use enterpriseSpecific(6) for the generic-trap type. $this->{'_generic_trap'} = ENTERPRISE_SPECIFIC; # Set the specific-trap type to 0. $this->{'_specific_trap'} = 0; # Use the "uptime" of the script for the time-stamp. $this->{'_time_stamp'} = ((time() - $^T) * 100); # Create a local copy of the VarBindList. my @var_bind_list = (); # Validate the passed arguments foreach (keys %argv) { if (/^-?enterprise$/i) { if ($argv{$_} !~ /^\.?\d+\.\d+(\.\d+)*/) { return $this->_object_error( 'Expected enterprise as OBJECT IDENTIFIER in dotted notation' ); } else { $this->{'_enterprise'} = $argv{$_}; } } elsif (/^-?agentaddr$/i) { if ($argv{$_} !~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/) { return $this->_object_error( 'Expected agent-addr in dotted notation' ); } else { $this->{'_agent_addr'} = $argv{$_}; } } elsif (/^-?generictrap$/i) { if ($argv{$_} !~ /^\d+$/) { return $this->_object_error( 'Expected numeric generic-trap type' ); } else { $this->{'_generic_trap'} = $argv{$_}; } } elsif (/^-?specifictrap$/i) { if ($argv{$_} !~ /^\d+$/) { return $this->_object_error( 'Expected numeric specific-trap type' ); } else { $this->{'_specific_trap'} = $argv{$_}; } } elsif (/^-?timestamp$/i) { if ($argv{$_} !~ /^\d+$/) { return $this->_object_error('Expected numeric time-stamp'); } else { $this->{'_time_stamp'} = $argv{$_}; } } elsif (/^-?varbindlist$/i) { if (ref($argv{$_}) ne 'ARRAY') { return $this->_object_error( 'Expected array reference for variable-bindings' ); } else { @var_bind_list = @{$argv{$_}}; } } else { return $this->_object_error("Invalid argument '%s'", $_); } } # If the user did not specify the agent-addr, get local the address # of the client sending the trap. if (!defined($this->{'_agent_addr'})) { eval { $this->{'_agent_addr'} = inet_ntoa( scalar(gethostbyname(&Sys::Hostname::hostname())) ); }; if ($@ ne '') { return $this->_object_encode_error( 'Unable to resolve local agent-addr' ); } } if (!defined($this->_snmp_encode_trap(@var_bind_list))) { return $this->_object_encode_error; } # Handle the sending of the message according to "blocking" mode if ($this->{'_nonblocking'}) { $this->_object_queue_message; } else { $this->_udp_send_buffer; } } sub get_bulk_request { my ($this, %argv) = @_; # Clear any previous error message which also clears the # '_error_status' and '_error_index' so that we can use them # to hold non-repeaters and max-repetitions. $this->_object_clear_error; # Validate the SNMP version if ($this->version != SNMP_VERSION_2C) { return $this->_object_error( 'GetBulkRequest-PDU only supported with SNMPv2c' ); } # Create a local copy of the VarBindList. my @var_bind_list = (); # Validate the passed arguments foreach (keys %argv) { if (/^-?nonrepeaters$/i) { if ($argv{$_} !~ /^\d+$/) { return $this->_object_error( 'Expected numeric non-repeaters value' ); } elsif ($argv{$_} > 2147483647) { return $this->_object_error( 'Exceeded maximum non-repeaters value [2147483647]' ); } else { # We cheat a little here... $this->{'_error_status'} = $argv{$_}; } } elsif (/^-?maxrepetitions$/i) { if ($argv{$_} !~ /^\d+$/) { return $this->_object_error( 'Expected numeric max-repetitions value' ); } elsif ($argv{$_} > 2147483647) { return $this->_object_error( 'Exceeded maximum max-repetitions value [2147483647]' ); } else { # We cheat a little here... $this->{'_error_index'} = $argv{$_}; } } elsif (/^-?varbindlist$/i) { if (ref($argv{$_}) ne 'ARRAY') { return $this->_object_error( 'Expected array reference for variable-bindings' ); } else { @var_bind_list = @{$argv{$_}}; } } elsif ((/^-?callback$/i) && ($this->{'_nonblocking'})) { if (!defined($this->_object_add_callback($argv{$_}))) { return $this->_object_error; } } else { return $this->_object_error("Invalid argument '%s'", $_); } } if ($this->{'_error_status'} > scalar(@var_bind_list)) { return $this->_object_error( 'Non-repeaters greater than the number of variable-bindings' ); } if (($this->{'_error_status'} == scalar(@var_bind_list)) && ($this->{'_error_index'} != 0)) { return $this->_object_error( 'Non-repeaters equals the number of variable-bindings and ' . 'max-repetitions is not equal to zero' ); } if (!defined($this->_snmp_encode_get_bulk_request(@var_bind_list))) { return $this->_object_encode_error; } # Handle the sending of the message according to "blocking" mode if ($this->{'_nonblocking'}) { $this->_object_queue_message; } else { if (!defined($this->_udp_send_message)) { return $this->_object_decode_error; } $this->_snmp_validate_get_response; } } sub inform_request { my $this = shift; # Clear any previous error message $this->_object_clear_error; # Validate the SNMP version if ($this->version != SNMP_VERSION_2C) { return $this->_object_error( 'InformRequest-PDU only supported with SNMPv2c' ); } # Handle passed arguments according to "blocking" mode if ($this->{'_nonblocking'}) { my %argv = @_; my @var_bind_list = (); # Validate the passed arguments foreach (keys %argv) { if (/^-?callback$/i) { if (!defined($this->_object_add_callback($argv{$_}))) { return $this->_object_error; } } elsif (/^-?varbindlist$/i) { if (ref($argv{$_}) ne 'ARRAY') { return $this->_object_error( 'Expected array reference for variable-bindings' ); } else { @var_bind_list = @{$argv{$_}}; } } else { return $this->_object_error("Invalid argument '%s'", $_); } } # Encode and queue the message if (!defined($this->_snmp_encode_inform_request(@var_bind_list))) { return $this->_object_error; } $this->_object_queue_message; } else { # Encode, send/wait, and decode the message if (!defined($this->_snmp_encode_inform_request(@_))) { return $this->_object_encode_error; } if (!defined($this->_udp_send_message)) { return $this->_object_decode_error; } $this->_snmp_validate_get_response; } } sub snmpv2_trap { my $this = shift; # Clear any previous error message $this->_object_clear_error; # Validate the SNMP version if ($this->version != SNMP_VERSION_2C) { return $this->_object_error( 'SNMPv2-Trap-PDU only supported with SNMPv2c' ); } # Encode the message if (!defined($this->_snmp_encode_v2_trap(@_))) { return $this->_object_encode_error; } if ($this->{'_nonblocking'}) { # Queue the message $this->_object_queue_message; } else { # Send the message $this->_udp_send_buffer; } } sub get_table { my $this = shift; my ($base_oid, $repeat_cnt, $table) = (undef, 0, undef, undef); my ($result, $next_oid) = (undef, undef); # Use get-next-requests until the response is not a subtree of the # base OBJECT IDENTIFIER. Return the table only if there are no # errors other than a noSuchName(2) error since the table could # be at the end of the tree. Also return the table when the value # of the OID equals endOfMibView(2) when using SNMPv2c. # Handle passed argument according to "blocking" mode if ($this->{'_nonblocking'}) { my %argv = @_; # Validate the passed arguments foreach (keys %argv) { if (/^-?callback$/i) { if (!defined($this->_object_add_callback($argv{$_}))) { return $this->_object_error; } } elsif (/^-?baseoid$/i) { if ($argv{$_} !~ /^\.?\d+\.\d+(\.\d+)*/) { return $this->_object_error( 'Expected base OBJECT IDENTIFIER in dotted notation' ); } else { $base_oid = $argv{$_}; } } else { return $this->_object_error("Invalid argument '%s'", $_); } } # Create table of values that need passed along with the # callbacks. This just prevents a big argument list. %argv = ( 'base_oid' => $base_oid, 'callback' => $this->{'_callback'}, 'repeat_cnt' => 0, 'table' => undef, ); # Queue up the get-next-request, overriding the user-specified # callback. We have the original in the arguments. $this->get_next_request( -callback => [\&_object_get_table_cb, \%argv], -varbindlist => [$base_oid] ); } else { $next_oid = $base_oid = shift(@_); do { if (defined($result)) { if (!exists($table->{$next_oid})) { $table->{$next_oid} = $result->{$next_oid}; } elsif ((($result->{$next_oid} eq 'endOfMibView') || # translate ($this->error_status == ENDOFMIBVIEW)) && # !translate ($this->version == SNMP_VERSION_2C)) { if (!defined($table)) { $this->_object_decode_error('Requested table is empty'); } return ($this->{'_var_bind_list'} = $table); } else { $repeat_cnt++; } } # Check to make sure that the remote host does not respond # incorrectly causing the get-next-requests to loop forever. if ($repeat_cnt > 5) { return $this->_object_decode_error( 'Loop detected with table on remote host' ); } if (!defined($result = $this->get_next_request($next_oid))) { # Check for noSuchName(2) error if ($this->error_status == 2) { if (!defined($table)) { $this->_object_decode_error('Requested table is empty'); } return ($this->{'_var_bind_list'} = $table); } else { return $this->_object_decode_error; } } ($next_oid) = keys(%{$result}); } while (_asn1_oid_context_match($base_oid, $next_oid)); if (!defined($table)) { $this->_object_decode_error('Requested table is empty'); } $this->{'_var_bind_list'} = $table; } } sub error { defined($_[0]->{'_error'}) ? $_[0]->{'_error'} : ''; } sub version { my ($this, $version) = @_; # Clear any previous error message $this->_object_clear_error; # Allow the user some flexability my $supported = { '1' => SNMP_VERSION_1, 'v1' => SNMP_VERSION_1, 'snmpv1' => SNMP_VERSION_1, '2' => SNMP_VERSION_2C, '2c' => SNMP_VERSION_2C, 'v2' => SNMP_VERSION_2C, 'v2c' => SNMP_VERSION_2C, 'snmpv2' => SNMP_VERSION_2C, 'snmpv2c' => SNMP_VERSION_2C }; if (@_ == 2) { if (exists($supported->{lc($version)})) { $this->{'_version'} = $supported->{lc($version)}; } else { return $this->_object_error( "Unknown or invalid SNMP version [%s]", $version ); } } $this->{'_version'}; } sub hostname { $_[0]->{'_hostname'}; } sub _request_id { $_[0]->{'_request_id'}; # Semi-private method } sub error_status { $_[0]->{'_error_status'}; } sub error_index { $_[0]->{'_error_index'}; } sub var_bind_list { $_[0]->{'_var_bind_list'}; } sub timeout { my ($this, $timeout) = @_; # Clear any previous error message $this->_object_clear_error; if (@_ == 2) { if (($timeout >= MINIMUM_TIMEOUT) && ($timeout <= MAXIMUM_TIMEOUT)) { $this->{'_timeout'} = $timeout; } else { return $this->_object_encode_error( "Timeout out of range [%03.01f - %03.01f seconds]", MINIMUM_TIMEOUT, MAXIMUM_TIMEOUT ); } } $this->{'_timeout'}; } sub retries { my ($this, $retries) = @_; # Clear any previous error message $this->_object_clear_error; if (@_ == 2) { if (($retries >= MINIMUM_RETRIES) && ($retries <= MAXIMUM_RETRIES)) { $this->{'_retries'} = $retries; } else { return $this->_object_encode_error( "Retries out of range [%d - %d]", MINIMUM_RETRIES, MAXIMUM_RETRIES ); } } $this->{'_retries'}; } sub mtu { my ($this, $mtu) = @_; # Clear any previous error message $this->_object_clear_error; if (@_ == 2) { if (($mtu >= MINIMUM_MTU) && ($mtu <= MAXIMUM_MTU )) { $this->{'_mtu'} = $mtu; } else { return $this->_object_encode_error( "MTU out of range [%d - %d octets]", MINIMUM_MTU, MAXIMUM_MTU ); } } $this->{'_mtu'}; } sub translate { my ($this, $flag) = @_; if (@_ == 2) { if ($flag) { $this->{'_translate'} = TRUE; } else { $this->{'_translate'} = FALSE; } } $this->{'_translate'}; } sub debug { my ($this, $flag) = @_; if (@_ == 2) { if ($flag) { $Net::SNMP::DEBUG = TRUE; } else { $Net::SNMP::DEBUG = FALSE; } } $Net::SNMP::DEBUG; } sub END { if (defined($SOCKET)) { if (fileno($SOCKET)) { CORE::close($SOCKET); } } } ## Utility functions sub snmp_debug($) { &Net::SNMP::debug(undef, $_[0]); } sub oid_context_match($$) { &Net::SNMP::_asn1_oid_context_match($_[0], $_[1]); } sub oid_lex_sort(@) { &Net::SNMP::_asn1_oid_lex_sort(@_); } sub ticks_to_time($) { &Net::SNMP::_asn1_ticks_to_time($_[0]); } # [private methods] ---------------------------------------------------------- ### ## Simple Network Managment Protocol (SNMP) encode methods ### sub _snmp_encode_get_request { my $this = shift; # Clear any previous error message $this->_object_clear_error; # Check for a valid VarBindList if (@_ < 1) { return $this->_snmp_encode_error('VarBindList is empty'); } $this->_snmp_encode(GET_REQUEST, $this->_snmp_create_oid_null_pairs(@_)); } sub _snmp_encode_get_next_request { my $this = shift; # Clear any previous error message $this->_object_clear_error; # Check for a valid VarBindList if (@_ < 1) { return $this->_snmp_encode_error('VarBindList is empty'); } $this->_snmp_encode( GET_NEXT_REQUEST, $this->_snmp_create_oid_null_pairs(@_) ); } sub _snmp_encode_get_response { my $this = shift; # Clear any previous error message $this->_object_clear_error; $this->_snmp_encode_error('GetResponse-PDU not supported'); } sub _snmp_encode_set_request { my $this = shift; # Clear any previous error message $this->_object_clear_error; # Check for a valid VarBindList if (@_ < 1) { return $this->_snmp_encode_error('VarBindList is empty'); } $this->_snmp_encode(SET_REQUEST, $this->_snmp_create_oid_value_pairs(@_)); } sub _snmp_encode_trap { my $this = shift; # Clear any previous error message $this->_object_clear_error; $this->_snmp_encode(TRAP, $this->_snmp_create_oid_value_pairs(@_)); } sub _snmp_encode_get_bulk_request { my $this = shift; # DO NOT clear any previous error message or the non-repeaters # and the max-repetitions will be reset! # Check for a valid VarBindList if (@_ < 1) { return $this->_snmp_encode_error('VarBindList is empty'); } $this->_snmp_encode( GET_BULK_REQUEST, $this->_snmp_create_oid_null_pairs(@_) ); } sub _snmp_encode_inform_request { my $this = shift; # Clear any previous error message $this->_object_clear_error; # Check for a valid VarBindList if (@_ < 1) { return $this->_snmp_encode_error('VarBindList is empty'); } $this->_snmp_encode(INFORM_REQUEST, $this->_snmp_create_oid_value_pairs(@_)); } sub _snmp_encode_v2_trap { my $this = shift; # Clear any previous error message $this->_object_clear_error; # Check for a valid VarBindList (or is that legal with a snmpV2-trap?) if (@_ < 1) { return $this->_snmp_encode_error('VarBindList is empty'); } $this->_snmp_encode(SNMPV2_TRAP, $this->_snmp_create_oid_value_pairs(@_)); } sub _snmp_encode { my ($this, $type, @var_bind_list) = @_; # Do not do anything if there has already been an error if (defined($this->{'_error'})) { return $this->_snmp_encode_error; } # We need to reset the buffer that might have been defined # from a previous message and clear the var_bind_list. $this->_object_clear_buffer; $this->_object_clear_var_bind_list; $this->_object_clear_leading_dot; # Make sure the PDU type was passed if ((scalar(@_) < 2) || (!defined($type))) { return $this->_snmp_encode_error('No SNMP PDU type defined'); } $this->{'_type'} = $type; # Encode the variable-bindings if (!defined($this->_snmp_encode_var_bind_list(@var_bind_list))) { return $this->_snmp_encode_error; } # Encode the PDU or Trap-PDU if ($this->{'_type'} == TRAP) { if (!defined($this->_snmp_encode_trap_pdu)) { return $this->_snmp_encode_error; } } else { if (!defined($this->_snmp_encode_pdu)) { return $this->_snmp_encode_error; } } # Now wrap the message $this->_snmp_encode_message; } sub _snmp_encode_message { my $this = shift; # We need to encode eveything in reverse order so the # objects end up in the correct place. # Encode the PDU type if (!defined( $this->_asn1_encode($this->{'_type'}, $this->_object_get_buffer) )) { return $this->_snmp_encode_error; } # Encode the community name if (!defined($this->_asn1_encode(OCTET_STRING, $this->{'_community'}))) { return $this->_snmp_encode_error; } # Encode the SNMP version if (!defined($this->_asn1_encode(INTEGER, $this->{'_version'}))) { return $this->_snmp_encode_error; } # Encode the SNMP message SEQUENCE if (!defined($this->_asn1_encode(SEQUENCE, $this->_object_get_buffer))) { return $this->_snmp_encode_error; } # Return the buffer $this->{'_buffer'}; } sub _snmp_encode_pdu { my $this = shift; # We need to encode eveything in reverse order so the # objects end up in the correct place. # Encode the error-index or max-repetitions (GetBulkRequest-PDU) if (!defined($this->_asn1_encode(INTEGER, $this->{'_error_index'}))) { return $this->_snmp_encode_error; } # Encode the error-status or non-repeaters (GetBulkRequest-PDU) if (!defined($this->_asn1_encode(INTEGER, $this->{'_error_status'}))) { return $this->_snmp_encode_error; } # Encode the request-id after storing the value and incrementing # the global value by one. $this->{'_request_id'} = $REQUEST_ID++; if (!defined($this->_asn1_encode(INTEGER, $this->{'_request_id'}))) { return $this->_snmp_encode_error; } # Return the buffer $this->{'_buffer'}; } sub _snmp_encode_trap_pdu { my $this = shift; # We need to encode eveything in reverse order so the # objects end up in the correct place. # Encode the time-stamp if (!defined($this->_asn1_encode(TIMETICKS, $this->{'_time_stamp'}))) { return $this->_snmp_encode_error; } # Encode the specific-trap type if (!defined($this->_asn1_encode(INTEGER, $this->{'_specific_trap'}))) { return $this->_snmp_encode_error; } # Encode the generic-trap type if (!defined($this->_asn1_encode(INTEGER, $this->{'_generic_trap'}))) { return $this->_snmp_encode_error; } # Encode the agent-addr if (!defined($this->_asn1_encode(IPADDRESS, $this->{'_agent_addr'}))) { return $this->_snmp_encode_error; } # Encode the enterprise if (!defined( $this->_asn1_encode(OBJECT_IDENTIFIER, $this->{'_enterprise'}) )) { return $this->_snmp_encode_error; } # Return the buffer $this->{'_buffer'}; } sub _snmp_encode_var_bind_list { my ($this, @var_bind) = @_; my ($type, $value) = (undef, ''); # The passed array is expected to consist of groups of four values # consisting of two sets of ASN.1 types and their values. if ((scalar(@var_bind) % 4)) { return $this->_snmp_encode_error( "Invalid number of VarBind parameters [%d]", scalar(@var_bind) ); } # Encode the objects from the end of the list, so they are wrapped # into the packet as expected. Also, check to make sure that the # OBJECT IDENTIFIER is in the correct place. my $buffer = $this->_object_get_buffer; while (@var_bind) { # Encode the ObjectSyntax $value = pop(@var_bind); $type = pop(@var_bind); if (!defined($this->_asn1_encode($type, $value))) { return $this->_snmp_encode_error; } # Encode the ObjectName $value = pop(@var_bind); $type = pop(@var_bind); if ($type != OBJECT_IDENTIFIER) { return $this->_snmp_encode_error( 'Expected OBJECT IDENTIFIER in VarBindList' ); } if (!defined($this->_asn1_encode($type, $value))) { return $this->_snmp_encode_error; } # Encode the VarBind SEQUENCE if (!defined($this->_asn1_encode(SEQUENCE, $this->_object_get_buffer))) { return $this->_snmp_encode_error; } $buffer = join('', $this->_object_get_buffer, $buffer); } # Encode the VarBindList SEQUENCE if (!defined($this->_asn1_encode(SEQUENCE, $buffer))) { return $this->_snmp_encode_error; } # Return the buffer $this->{'_buffer'}; } sub _snmp_create_oid_null_pairs { my ($this, @oids) = @_; my ($oid) = (undef); my @pairs = (); while (@oids) { $oid = shift(@oids); if ($oid !~ /^\.?\d+\.\d+(\.\d+)*/) { return $this->_snmp_encode_error( 'Expected OBJECT IDENTIFIER in dotted notation' ); } push(@pairs, OBJECT_IDENTIFIER, $oid, NULL, ''); } @pairs; } sub _snmp_create_oid_value_pairs { my ($this, @oid_values) = @_; my ($oid) = (undef); my @pairs = (); if ((scalar(@oid_values) % 3)) { return $this->_snmp_encode_error( 'Expected [OBJECT IDENTIFIER, ASN.1 type, object value] combination' ); } while (@oid_values) { $oid = shift(@oid_values); if ($oid !~ /^\.?\d+\.\d+(\.\d+)*/) { return $this->_snmp_encode_error( 'Expected OBJECT IDENTIFIER in dotted notation' ); } push(@pairs, OBJECT_IDENTIFIER, $oid); push(@pairs, shift(@oid_values), shift(@oid_values)); } @pairs; } sub _snmp_encode_error { my $this = shift; # Clear the buffer $this->_object_clear_buffer; $this->_object_error(@_); } ### ## Simple Network Managment Protocol (SNMP) decode methods ### sub _snmp_decode_get_request { $_[0]->_snmp_decode(GET_REQUEST); } sub _snmp_decode_get_next_request { $_[0]->_snmp_decode(GET_NEXT_REQUEST); } sub _snmp_decode_get_response { $_[0]->_snmp_decode(GET_RESPONSE); } sub _snmp_decode_set_request { $_[0]->_snmp_decode(SET_REQUEST); } sub _snmp_decode_trap { $_[0]->_snmp_decode(TRAP); } sub _snmp_decode_get_bulk_request { $_[0]->_snmp_decode(GET_BULK_REQUEST); } sub _snmp_decode_inform_request { $_[0]->_snmp_decode(INFORM_REQUEST); } sub _snmp_decode_v2_trap { $_[0]->_snmp_decode(SNMPV2_TRAP); } sub _snmp_decode { my ($this, $type) = @_; # First we need to reset the var_bind_list and errors that # might have been set from a previous message. $this->_object_clear_snmp_message; $this->_object_clear_var_bind_list; $this->_object_clear_error; # Define the message type to be decoded, if it was provided if (scalar(@_) > 1) { $this->{'_type'} = $type; } # Decode the message if (!defined($this->_snmp_decode_message)) { return $this->_snmp_decode_error; } # Decode the PDU if ($this->{'_type'} != TRAP) { if (!defined($this->_snmp_decode_pdu)) { return $this->_snmp_decode_error; } } else { if (!defined($this->_snmp_decode_trap_pdu)) { return $this->_snmp_decode_error; } } # Decode the VarBindList $this->_snmp_decode_var_bind_list; } sub _snmp_decode_message { my $this = shift; my $value = undef; # Decode the message SEQUENCE if (!defined($value = $this->_asn1_decode(SEQUENCE))) { return $this->_snmp_decode_error; } if ($value != $this->_object_buffer_length) { return $this->_snmp_decode_error( 'Encoded message length not equal to remaining data length' ); } # Decode the version if (!defined($this->{'_version'} = $this->_asn1_decode(INTEGER))) { return $this->_snmp_decode_error; } # Decode the community if (!defined($this->{'_community'} = $this->_asn1_decode(OCTET_STRING))) { return $this->_snmp_decode_error; } # Decode the PDU type if (!defined($this->{'_type'} = $this->_asn1_decode($this->{'_type'}))) { return $this->_snmp_decode_error; } # Return the remaining buffer $this->{'_buffer'}; } sub _snmp_decode_pdu { my $this = shift; # Decode the request-id if (!defined($this->{'_request_id'} = $this->_asn1_decode(INTEGER))) { return $this->_snmp_decode_error; } # Decode the error-status and error-index if (!defined($this->{'_error_status'} = $this->_asn1_decode(INTEGER))) { $this->{'_error_status'} = 0; return $this->_snmp_decode_error; } if (!defined($this->{'_error_index'} = $this->_asn1_decode(INTEGER))) { $this->{'_error_index'} = 0; return $this->_snmp_decode_error; } # Return the remaining buffer $this->{'_buffer'}; } sub _snmp_decode_trap_pdu { my $this = shift; # Decode the enterprise if (!defined( $this->{'_enterprise'} = $this->_asn1_decode(OBJECT_IDENTIFIER) )) { return $this->_snmp_decode_error; } # Decode the agent-addr if (!defined($this->{'_agent_addr'} = $this->_asn1_decode(IPADDRESS))) { return $this->_snmp_decode_error; } # Decode the generic-trap type if (!defined($this->{'_generic_trap'} = $this->_asn1_decode(INTEGER))) { return $this->_snmp_decode_error; } # Decode the specific-trap type if (!defined($this->{'_specific_trap'} = $this->_asn1_decode(INTEGER))) { return $this->_snmp_decode_error; } # Decode the time-stamp if (!defined($this->{'_time_stamp'} = $this->_asn1_decode(TIMETICKS))) { return $this->_snmp_decode_error; } # Return the remaining buffer $this->{'_buffer'}; } sub _snmp_decode_var_bind_list { my $this = shift; my ($value, $oid) = (undef, undef); # Decode the VarBindList SEQUENCE if (!defined($value = $this->_asn1_decode(SEQUENCE))) { return $this->_snmp_decode_error; } if ($value != $this->_object_buffer_length) { return $this->_snmp_decode_error( 'Encoded VarBindList length not equal to remaining data length' ); } $this->{'_var_bind_list'} = {}; while ($this->_object_buffer_length) { # Decode the VarBind SEQUENCE if (!defined($this->_asn1_decode(SEQUENCE))) { return $this->_snmp_decode_error; } # Decode the ObjectName if (!defined($oid = $this->_asn1_decode(OBJECT_IDENTIFIER))) { return $this->_snmp_decode_error; } # Decode the ObjectSyntax if (!defined($value = $this->_asn1_decode)) { return $this->_snmp_decode_error; } # Create a hash consisting of the OBJECT IDENTIFIER as a # key and the ObjectSyntax as the value. DEBUG_INFO("{ %s => %s }", $oid, $value); $this->{'_var_bind_list'}->{$oid} = $value; } # Return the var_bind_list hash $this->{'_var_bind_list'}; } sub _snmp_validate_get_response { my $this = shift; my $value = undef; # First we need to reset the var_bind_list and errors that # might have been set from a previous message. $this->_object_clear_var_bind_list; $this->_object_clear_error; $this->{'_type'} = GET_RESPONSE; # Decode the message SEQUENCE if (!defined($value = $this->_asn1_decode(SEQUENCE))) { return $this->_snmp_decode_error; } if ($value != $this->_object_buffer_length) { return $this->_snmp_decode_error( 'Encoded message length not equal to remaining data length' ); } # Decode and validate the version if (!defined($value = $this->_asn1_decode(INTEGER))) { return $this->_snmp_decode_error; } if ($value != $this->{'_version'}) { return $this->_snmp_decode_error( "Received version [0x%02x] is not equal to transmitted version " . "[0x%02x]", $value, $this->{'_version'} ); } # Decode and validate the community if (!defined($value = $this->_asn1_decode(OCTET_STRING))) { return $this->_snmp_decode_error; } if ($value ne $this->{'_community'}) { return $this->_snmp_decode_error( "Received community [%s] is not equal to transmitted community [%s]", $value, $this->{'_community'} ); } # Decode the PDU type if (!defined($this->_asn1_decode($this->{'_type'}))) { return $this->_snmp_decode_error; } # Decode the request-id if (!defined($value = $this->_asn1_decode(INTEGER))) { return $this->_snmp_decode_error; } if ($value != $this->{'_request_id'}) { return $this->_snmp_decode_error( "Received request-id [%s] is not equal to transmitted request-id [%s]", $value, $this->{'_request_id'} ); } # Decode and validate the error-status and error-index if (!defined($this->{'_error_status'} = $this->_asn1_decode(INTEGER))) { $this->{'_error_status'} = 0; return $this->_snmp_decode_error; } if (!defined($this->{'_error_index'} = $this->_asn1_decode(INTEGER))) { $this->{'_error_index'} = 0; return $this->_snmp_decode_error; } if (($this->{'_error_status'} != 0) || ($this->{'_error_index'} != 0)) { return $this->_snmp_decode_error( "Received SNMP %s error-status at error-index %s", _snmp_error_status_itoa($this->{'_error_status'}), $this->{'_error_index'} ); } # Decode the VarBindList $this->_snmp_decode_var_bind_list; } sub _snmp_compare_get_response { my ($this, $response) = @_; if (ref($response) ne ref($this)) { $this->_snmp_decode_error('Invalid object reference'); } # Validate the version if ($this->{'_version'} != $response->{'_version'}) { return $this->_snmp_decode_error( "Received version [0x%02x] is not equal to transmitted version " . "[0x%02x]", $response->{'_version'}, $this->{'_version'} ); } # Validate the community if ($this->{'_community'} ne $response->{'_community'}) { return $this->_snmp_decode_error( "Received community [%s] is not equal to transmitted community [%s]", $response->{'_community'}, $this->{'_community'} ); } # Validate the request-id if ($this->{'_request_id'} != $response->{'_request_id'}) { return $this->_snmp_decode_error( "Received request-id [%s] is not equal to transmitted request-id [%s]", $response->{'_request_id'}, $this->{'_request_id'} ); } # Validate the error-status and error-index field. if (($response->{'_error_status'} != 0) || ($response->{'_error_index'} != 0)) { # Set the "source" error-status and error-index $this->{'_error_status'} = $response->{'_error_status'}; $this->{'_error_index'} = $response->{'_error_index'}; return $this->_snmp_decode_error( "Received SNMP %s error-status at error-index %s", _snmp_error_status_itoa($response->{'_error_status'}), $response->{'_error_index'} ); } TRUE; } sub _snmp_decode_error { my $this = shift; # Clear var_bind_list $this->_object_clear_var_bind_list; $this->_object_error(@_); } ### ## Simple Network Management Protocol (SNMP) utilties ### sub _snmp_error_status_itoa { my $error = shift; my @error_status = qw( noError tooBig noSuchName badValue readOnly genError noAccess wrongType wrongLength wrongEncoding wrongValue noCreation inconsistentValue resourceUnavailable commitFailed undoFailed authorizationError notWritable inconsistentName ); if (!defined($error)) { return '??'; } if (($error > $#error_status) || ($error < 0)) { return sprintf("??(%d)", $error); } sprintf("%s(%d)", $error_status[$error], $error); } ### ## Abstract Syntax Notation One (ASN.1) encode methods ### my $ASN1_ENCODE_METHODS = { INTEGER, '_asn1_encode_integer', OCTET_STRING, '_asn1_encode_octet_string', NULL, '_asn1_encode_null', OBJECT_IDENTIFIER, '_asn1_encode_object_identifier', SEQUENCE, '_asn1_encode_sequence', IPADDRESS, '_asn1_encode_ipaddress', COUNTER, '_asn1_encode_counter', GAUGE, '_asn1_encode_gauge', TIMETICKS, '_asn1_encode_timeticks', OPAQUE, '_asn1_encode_opaque', COUNTER64, '_asn1_encode_counter64', NOSUCHOBJECT, '_asn1_encode_nosuchobject', NOSUCHINSTANCE, '_asn1_encode_nosuchinstance', ENDOFMIBVIEW, '_asn1_encode_endofmibview', GET_REQUEST, '_asn1_encode_get_request', GET_NEXT_REQUEST, '_asn1_encode_get_next_request', GET_RESPONSE, '_asn1_encode_get_response', SET_REQUEST, '_asn1_encode_set_request', TRAP, '_asn1_encode_trap', GET_BULK_REQUEST, '_asn1_encode_get_bulk_request', INFORM_REQUEST, '_asn1_encode_inform_request', SNMPV2_TRAP, '_asn1_encode_v2_trap' }; sub _asn1_encode { my ($this, $type, $value) = @_; if (!defined($type)) { return $this->_asn1_encode_error('ASN.1 type not defined'); } if (exists($ASN1_ENCODE_METHODS->{$type})) { my $method = $ASN1_ENCODE_METHODS->{$type}; $this->$method($value); } else { $this->_asn1_encode_error("Unknown ASN.1 type [%s]", $type); } } sub _asn1_encode_type_length { my ($this, $type, $value) = @_; my $length = 0; if (defined($this->{'_error'})) { return $this->_asn1_encode_error; } if (!defined($type)) { return $this->_asn1_Error('ASN.1 type not defined'); } if (!defined($value)) { $value = ''; } $length = length($value); if ($length < 0x80) { return $this->_object_put_buffer( join('', pack('C2', $type, $length), $value) ); } elsif ($length <= 0xff) { return $this->_object_put_buffer( join('', pack('C3', $type, (0x80 | 1), $length), $value) ); } elsif ($length <= 0xffff) { return $this->_object_put_buffer( join('', pack('CCn', $type, (0x80 | 2), $length), $value) ); } $this->_asn1_encode_error('Unable to encode ASN.1 length'); } sub _asn1_encode_integer { my ($this, $integer) = @_; if (!defined($integer)) { return $this->_asn1_encode_error('INTEGER value not defined'); } if ($integer !~ /^-?\d+$/) { return $this->_asn1_encode_error('Expected numeric INTEGER value'); } $this->_asn1_encode_integer32(INTEGER, $integer); } sub _asn1_encode_unsigned32 { my ($this, $type, $u_int32) = @_; if (!defined($type)) { $type = INTEGER; } if (!defined($u_int32)) { return $this->_asn1_encode_error( "%s value not defined", _asn1_itoa($type) ); } if ($u_int32 !~ /^\d+$/) { return $this->_asn1_encode_error( "Expected positive numeric %s value", _asn1_itoa($type) ); } $this->_asn1_encode_integer32($type, $u_int32); } sub _asn1_encode_integer32 { my ($this, $type, $integer) = @_; my ($size, $value, $negative, $prefix) = (4, '', FALSE, FALSE); if (!defined($type)) { $type = INTEGER; } if (!defined($integer)) { return $this->_asn1_encode_error( "%s value not defined", _asn1_itoa($type) ); } # Determine if the value is positive or negative if ($integer =~ /^-/) { $negative = TRUE; } # Check to see if the most significant bit is set, if it is we # need to prefix the encoding with a zero byte. if (((($integer & 0xff000000) >> 24) & 0x80) && (!$negative)) { $size++; $prefix = TRUE; } # Remove occurances of nine consecutive ones (if negative) or zeros # from the most significant end of the two's complement integer. while ((((!($integer & 0xff800000))) || ((($integer & 0xff800000) == 0xff800000) && ($negative))) && ($size > 1)) { $size--; $integer <<= 8; } # Add a zero byte so the integer is decoded as a positive value if ($prefix) { $value .= pack('x'); $size--; } # Build the integer while ($size-- > 0) { $value .= pack('C', (($integer & 0xff000000) >> 24)); $integer <<= 8; } # Encode ASN.1 header $this->_asn1_encode_type_length($type, $value); } sub _asn1_encode_octet_string { if (!defined($_[1])) { return $_[0]->_asn1_encode_error('OCTET STRING value not defined'); } $_[0]->_asn1_encode_type_length(OCTET_STRING, $_[1]); } sub _asn1_encode_null { $_[0]->_asn1_encode_type_length(NULL, ''); } sub _asn1_encode_object_identifier { my ($this, $oid) = @_; my ($value, $subid, $mask, $bits, $tmask, $tbits) = ('', 0, 0, 0, 0, 0); if (!defined($oid)) { return $this->_asn1_Error('OBJECT IDENTIFIER value not defined'); } # Input is expected in dotted notation, so break it up into subids my @subids = split(/\./, $oid); # If there was a leading dot on _any_ OBJECT IDENTIFIER passed to # an encode method, return a leading dot on _all_ of the OBJECT # IDENTIFIERs in the decode methods. if ($subids[0] eq '') { DEBUG_INFO("leading dot present"); $this->{'_leading_dot'} = TRUE; shift(@subids); } # The first two subidentifiers are encoded into the first identifier # using the the equation: subid = ((first * 40) + second). We just # return an error if there are not at least two subidentifiers. if (scalar(@subids) < 2) { return $this->_asn1_encode_error('Invalid OBJECT IDENTIFIER length'); } $value = 40 * shift(@subids); $value = pack('C', ($value + shift(@subids))); # Encode each value as seven bits with the most significant bit # indicating the end of a subidentifier. foreach $subid (@subids) { if (($subid < 0x7f) && ($subid >= 0)) { $value .= pack('C', $subid); } else { $mask = 0x7f; $bits = 0; # Determine the number of bits need to encode the subidentifier for ($tmask = 0x7f, $tbits = 0; $tmask != 0x00; $tmask <<= 7, $tbits += 7) { if ($subid & $tmask) { $mask = $tmask; $bits = $tbits; } } # Now encode it, using the number of bits from above for ( ; $mask != 0x7f; $mask >>= 7, $bits -= 7) { # Handle a mask that was truncated above because # the subidentifier was four bytes long. if ((($mask & 0xffffffff) == 0xffe00000) || ($mask == 0x1e00000)) { $mask = 0xfe00000; } $value .= pack('C', ((($subid & $mask) >> $bits) | 0x80)); } $value .= pack('C', ($subid & $mask)); } } # Encode the ASN.1 header $this->_asn1_encode_type_length(OBJECT_IDENTIFIER, $value); } sub _asn1_encode_sequence { $_[0]->_asn1_encode_type_length(SEQUENCE, $_[1]); } sub _asn1_encode_ipaddress { my ($this, $address) = @_; if (!defined($address)) { return $this->_asn1_encode_error('IpAddress not defined'); } if ($address !~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/) { return $this->_asn1_encode_error('Expected IpAddress in dotted notation'); } $this->_asn1_encode_type_length( IPADDRESS, pack('C4', split(/\./, $address)) ); } sub _asn1_encode_counter { $_[0]->_asn1_encode_unsigned32(COUNTER, $_[1]); } sub _asn1_encode_gauge { $_[0]->_asn1_encode_unsigned32(GAUGE, $_[1]); } sub _asn1_encode_timeticks { $_[0]->_asn1_encode_unsigned32(TIMETICKS, $_[1]); } sub _asn1_encode_opaque { if (!defined($_[1])) { return $_[0]->_asn1_encode_error('Opaque value not defined'); } $_[0]->_asn1_encode_type_length(OPAQUE, $_[1]); } sub _asn1_encode_counter64 { my ($this, $u_int64) = @_; my ($quotient, $remainder) = (0, 0); my @bytes = (); # Validate the SNMP version if ($this->version != SNMP_VERSION_2C) { return $this->_asn1_encode_error( 'Counter64 only supported with SNMPv2c' ); } # Validate the passed value if (!defined($u_int64)) { return $this->_asn1_encode_error('Counter64 value not defined'); } if ($u_int64 !~ /^\+?\d+$/) { return $this->_asn1_encode_error( 'Expected positive numeric Counter64 value' ); } # Only load the Math::BigInt module when needed use Math::BigInt; $u_int64 = Math::BigInt->new($u_int64); if ($u_int64 eq 'NaN') { return $this->_asn1_encode_error('Invalid Counter64 value'); } # Make sure the value is no more than 8 bytes long if ($u_int64->bcmp('18446744073709551615') > 0) { return $this->_asn1_encode_error('Counter64 value too high'); } if ($u_int64 == 0) { unshift(@bytes, 0x00); } while ($u_int64 > 0) { ($quotient, $remainder) = $u_int64->bdiv(256); $u_int64 = Math::BigInt->new($quotient); unshift(@bytes, $remainder); } # Make sure that the value is encoded as a positive value if ($bytes[0] & 0x80) { unshift(@bytes, 0x00); } $this->_asn1_encode_type_length(COUNTER64, pack('C*', @bytes)); } sub _asn1_encode_nosuchobject { if ($_[0]->version != SNMP_VERSION_2C) { return $_[0]->_asn1_encode_error( 'noSuchObject only supported with SNMPv2c' ); } $_[0]->_asn1_encode_type_length(NOSUCHOBJECT, ''); } sub _asn1_encode_nosuchinstance { if ($_[0]->version != SNMP_VERSION_2C) { return $_[0]->_asn1_encode_error( 'noSuchInstance only supported with SNMPv2c' ); } $_[0]->_asn1_encode_type_length(NOSUCHINSTANCE, ''); } sub _asn1_encode_endofmibview { if ($_[0]->version != SNMP_VERSION_2C) { return $_[0]->_asn1_encode_error( 'endOfMibView only supported with SNMPv2c' ); } $_[0]->_asn1_encode_type_length(ENDOFMIBVIEW, ''); } sub _asn1_encode_get_request { $_[0]->_asn1_encode_type_length(GET_REQUEST, $_[1]); } sub _asn1_encode_get_next_request { $_[0]->_asn1_encode_type_length(GET_NEXT_REQUEST, $_[1]); } sub _asn1_encode_get_response { $_[0]->_asn1_encode_type_length(GET_RESPONSE, $_[1]); } sub _asn1_encode_set_request { $_[0]->_asn1_encode_type_length(SET_REQUEST, $_[1]); } sub _asn1_encode_trap { $_[0]->_asn1_encode_type_length(TRAP, $_[1]); } sub _asn1_encode_get_bulk_request { if ($_[0]->version != SNMP_VERSION_2C) { return $_[0]->_asn1_encode_error( 'GetBulkRequest-PDU only supported with SNMPv2c' ); } $_[0]->_asn1_encode_type_length(GET_BULK_REQUEST, $_[1]); } sub _asn1_encode_inform_request { if ($_[0]->version != SNMP_VERSION_2C) { return $_[0]->_asn1_encode_error( 'InformRequest-PDU only supported with SNMPv2c' ); } $_[0]->_asn1_encode_type_length(INFORM_REQUEST, $_[1]); } sub _asn1_encode_v2_trap { if ($_[0]->version != SNMP_VERSION_2C) { return $_[0]->_asn1_encode_error( 'SNMPv2-Trap-PDU only supported with SNMPv2c' ); } $_[0]->_asn1_encode_type_length(SNMPV2_TRAP, $_[1]); } sub _asn1_encode_error { my $this = shift; # Clear the buffer $this->_object_clear_buffer; $this->_object_error(@_); } ### ## Abstract Syntax Notation One (ASN.1) decode methods ### my $ASN1_DECODE_METHODS = { INTEGER, '_asn1_decode_integer32', OCTET_STRING, '_asn1_decode_octet_string', NULL, '_asn1_decode_null', OBJECT_IDENTIFIER, '_asn1_decode_object_identifier', SEQUENCE, '_asn1_decode_sequence', IPADDRESS, '_asn1_decode_ipaddress', COUNTER, '_asn1_decode_counter', GAUGE, '_asn1_decode_gauge', TIMETICKS, '_asn1_decode_timeticks', OPAQUE, '_asn1_decode_opaque', COUNTER64, '_asn1_decode_counter64', NOSUCHOBJECT, '_asn1_decode_nosuchobject', NOSUCHINSTANCE, '_asn1_decode_nosuchinstance', ENDOFMIBVIEW, '_asn1_decode_endofmibview', GET_REQUEST, '_asn1_decode_get_request', GET_NEXT_REQUEST, '_asn1_decode_get_next_request', GET_RESPONSE, '_asn1_decode_get_response', SET_REQUEST, '_asn1_decode_set_request', TRAP, '_asn1_decode_trap', GET_BULK_REQUEST, '_asn1_decode_get_bulk_request', INFORM_REQUEST, '_asn1_decode_inform_request', SNMPV2_TRAP, '_asn1_decode_v2_trap' }; sub _asn1_decode { my ($this, $expected) = @_; if (defined($this->{'_error'})) { return $this->_asn1_decode_error; } my $type = $this->_object_get_buffer(1); if (defined($type)) { $type = unpack('C', $type); if (exists($ASN1_DECODE_METHODS->{$type})) { my $method = $ASN1_DECODE_METHODS->{$type}; if (defined($expected)) { if ($type != $expected) { return $this->_asn1_decode_error( "Expected %s, but found %s", _asn1_itoa($expected), _asn1_itoa($type) ); } } return $this->$method($type); } else { return $this->_asn1_decode_error("Unknown ASN.1 type [0x%02x]", $type); } } $this->_asn1_decode_error; } sub _asn1_decode_length { my $this = shift; my ($length, $byte_cnt) = (0, 0); if (defined($this->{'_error'})) { return $this->_asn1_decode_error; } if (!defined($length = $this->_object_get_buffer(1))) { return $this->_asn1_decode_error; } $length = unpack('C', $length); if ($length & 0x80) { $byte_cnt = ($length & 0x7f); if ($byte_cnt == 0) { return $this->_asn1_decode_error( 'Indefinite ASN.1 lengths not supported' ); } elsif ($byte_cnt <= 4) { if (!defined($length = $this->_object_get_buffer($byte_cnt))) { return $this->_asn1_decode_error; } $length = unpack('N', ("\0" x (4 - $byte_cnt) . $length)); } else { return $this->_asn1_decode_error( "ASN.1 length too long (%d bytes)", $byte_cnt ); } } $length; } sub _asn1_decode_integer32 { my ($this, $type) = @_; my ($length, $integer, $negative, $byte) = (undef, 0, FALSE, undef); if (!defined($length = $this->_asn1_decode_length)) { return $this->_asn1_decode_error; } # Return an error if the object length is zero if ($length < 1) { return $this->_asn1_decode_error( "%s length equal to zero", _asn1_itoa($type) ); } if (!defined($byte = $this->_object_get_buffer(1))) { return $this->_asn1_decode_error; } $length--; # If the first bit is set, the integer is negative if (($byte = unpack('C', $byte)) & 0x80) { $integer = -1; $negative = TRUE; } if (($length > 4) || (($length > 3) && ($byte != 0x00))) { return $this->_asn1_decode_error( "%s length too long (%d bytes)", _asn1_itoa($type), ($length + 1) ); } $integer = (($integer << 8) | $byte); while ($length--) { if (!defined($byte = $this->_object_get_buffer(1))) { return $this->_asn1_decode_error; } $integer = (($integer << 8) | unpack('C', $byte)); } if ($negative) { sprintf("%d", $integer); } else { $integer = abs($integer); sprintf("%u", $integer); } } sub _asn1_decode_octet_string { my ($this, $type) = @_; my ($length, $string) = (undef, undef); if (!defined($type)) { $type = OCTET_STRING; } if (!defined($length = $this->_asn1_decode_length)) { return $this->_asn1_decode_error; } if (defined($string = $this->_object_get_buffer($length))) { if (($string =~ /[\x01-\x08\x0b\x0e-\x1f\x7f-\xff]/g) && ($this->translate)) { DEBUG_INFO( "translating %s to printable hex string", _asn1_itoa($type) ); return sprintf("0x%s", unpack('H*', $string)); } else { return $string; } } else { return $this->_asn1_decode_error; } } sub _asn1_decode_null { my $this = shift; my ($length) = (undef); if (!defined($length = $this->_asn1_decode_length)) { return $this->_asn1_decode_error; } if ($length != 0) { return $this->_asn1_decode_error('NULL length not equal to zero'); } if ($this->translate) { DEBUG_INFO("translating NULL to 'NULL' string"); 'NULL'; } else { ''; } } sub _asn1_decode_object_identifier { my $this = shift; my ($length, $subid_cnt, $subid, $byte) = (undef, 1, 0, undef); my (@oid); if (!defined($length = $this->_asn1_decode_length)) { return $this->_asn1_decode_error; } if ($length < 1) { return $this->_asn1_decode_error( 'OBJECT IDENTIFIER length equal to zero' ); } while ($length > 0) { $subid = 0; do { if (!defined($byte = $this->_object_get_buffer(1))) { return $this->_asn1_decode_error; } $byte = unpack('C', $byte); if ($subid >= 0xffffffff) { return $this->_asn1_decode_error( 'OBJECT IDENTIFIER subidentifier too large' ); } $subid = (($subid << 7) + ($byte & 0x7f)); $length--; } while ($byte & 0x80); $oid[$subid_cnt++] = $subid; } # The first two subidentifiers are encoded into the first identifier # using the the equation: subid = ((first * 40) + second). $subid = $oid[1]; $oid[1] = int($subid % 40); $oid[0] = int(($subid - $oid[1]) / 40); # Return the OID in dotted notation (optionally with a leading dot # if one was passed to the encode routine). if ($this->{'_leading_dot'}) { DEBUG_INFO("adding leading dot"); '.' . join('.', @oid); } else { join('.', @oid); } } sub _asn1_decode_sequence { # Return the length, instead of the value $_[0]->_asn1_decode_length; } sub _asn1_decode_ipaddress { my $this = shift; my ($length, $address) = (undef, undef); if (!defined($length = $this->_asn1_decode_length)) { return $this->_asn1_decode_error; } if ($length != 4) { return $this->_asn1_decode_error( "Invalid IpAddress length (% byte%s)", $length, ($length == 1 ? '' : 's') ); } if (defined($address = $this->_object_get_buffer(4))) { join('.', unpack('C4', $address)); } else { $this->_asn1_decode_error; } } sub _asn1_decode_counter { $_[0]->_asn1_decode_integer32(COUNTER); } sub _asn1_decode_gauge { $_[0]->_asn1_decode_integer32(GAUGE); } sub _asn1_decode_timeticks { my $this = shift; my $ticks = undef; if (defined($ticks = $this->_asn1_decode_integer32(TIMETICKS))) { if ($this->translate) { DEBUG_INFO("translating %u TimeTicks to time\n", $ticks); return _asn1_ticks_to_time($ticks); } else { return $ticks; } } else { return $this->_asn1_decode_error; } } sub _asn1_decode_opaque { $_[0]->_asn1_decode_octet_string(OPAQUE); } sub _asn1_decode_counter64 { my $this = shift; my ($length, $byte, $negative) = (undef, undef, FALSE); # Verify the SNMP version if ($this->version != SNMP_VERSION_2C) { return $this->_asn1_decode_error( 'Counter64 only supported with SNMPv2c' ); } if (!defined($length = $this->_asn1_decode_length)) { return $this->_asn1_decode_error; } if ($length < 1) { return $this->_asn1_decode_error('Counter64 length equal to zero'); } if (!defined($byte = $this->_object_get_buffer(1))) { return $this->_asn1_decode_error; } $length--; $byte = unpack('C', $byte); if (($length > 8) || (($length > 7) && ($byte != 0x00))) { return $this->_asn1_decode_error( "Counter64 length too long (%d bytes)", ($length + 1) ); } # Only load the Math::BigInt module when needed use Math::BigInt; if ($byte & 0x80) { $negative = TRUE; $byte = $byte ^ 0xff; } my $u_int64 = Math::BigInt->new($byte); while ($length-- > 0) { if (!defined($byte = $this->_object_get_buffer(1))) { return $this->_asn1_decode_error; } $byte = unpack('C', $byte); if ($negative) { $byte = $byte ^ 0xff; } $u_int64 = $u_int64->bmul(256); $u_int64 = Math::BigInt->new($u_int64); $u_int64 = $u_int64->badd($byte); $u_int64 = Math::BigInt->new($u_int64); }; # If the value is negative the other end incorrectly encoded # the Counter64 since it should always be a positive value. if ($negative) { $byte = Math::BigInt->new('-1'); $u_int64 = $byte->bsub($u_int64); } # Remove the plus sign (or should we leave it to imply Math::BigInt?) $u_int64 =~ s/^\+//; $u_int64; } sub _asn1_decode_nosuchobject { my $this = shift; my ($length) = (undef); if ($this->version != SNMP_VERSION_2C) { return $this->_asn1_decode_error( 'noSuchObject only supported with SNMPv2c' ); } if (!defined($length = $this->_asn1_decode_length)) { return $this->_asn1_decode_error; } if ($length != 0) { return $this->_asn1_decode_error('noSuchObject length not equal to zero'); } if ($this->translate) { DEBUG_INFO("translating noSuchObject to 'noSuchObject' string"); 'noSuchObject'; } else { $this->{'_error_status'} = NOSUCHOBJECT; ''; } } sub _asn1_decode_nosuchinstance { my $this = shift; my ($length) = (undef); if ($this->version != SNMP_VERSION_2C) { return $this->_asn1_decode_error( 'noSuchInstance only supported with SNMPv2c' ); } if (!defined($length = $this->_asn1_decode_length)) { return $this->_asn1_decode_error; } if ($length != 0) { return $this->_asn1_decode_error( 'noSuchInstance length not equal to zero' ); } if ($this->translate) { DEBUG_INFO("translating noSuchInstance to 'noSuchInstance' string"); 'noSuchInstance'; } else { $this->{'_error_status'} = NOSUCHINSTANCE; ''; } } sub _asn1_decode_endofmibview { my $this = shift; my ($length) = (undef); if ($this->version != SNMP_VERSION_2C) { return $this->_asn1_decode_error( 'endOfMibView only supported with SNMPv2c' ); } if (!defined($length = $this->_asn1_decode_length)) { return $this->_asn1_decode_error; } if ($length != 0) { return $this->_asn1_decode_error('endOfMibView length not equal to zero'); } if ($this->translate) { DEBUG_INFO("translating endOfMibView to 'endOfMibView' string"); 'endOfMibView'; } else { $this->{'_error_status'} = ENDOFMIBVIEW; ''; } } sub _asn1_decode_pdu { # Generic methods used to decode the PDU type. The ASN.1 type is # returned by the method as passed by the generic decode routine. if ((defined($_[0]->_asn1_decode_length)) && (defined($_[1]))) { $_[1]; } else { $_[0]->_asn1_decode_error('ASN.1 PDU type not defined'); } } sub _asn1_decode_get_request { $_[0]->_asn1_decode_pdu(GET_REQUEST); } sub _asn1_decode_get_next_request { $_[0]->_asn1_decode_pdu(GET_NEXT_REQUEST); } sub _asn1_decode_get_response { $_[0]->_asn1_decode_pdu(GET_RESPONSE); } sub _asn1_decode_set_request { $_[0]->_asn1_decode_pdu(SET_REQUEST); } sub _asn1_decode_trap { $_[0]->_asn1_decode_pdu(TRAP); } sub _asn1_decode_get_bulk_request { if ($_[0]->version != SNMP_VERSION_2C) { return $_[0]->_asn1_decode_error( 'GetBulkRequest-PDU only supported with SNMPv2c' ); } $_[0]->_asn1_decode_pdu(GET_BULK_REQUEST); } sub _asn1_decode_inform_request { if ($_[0]->version != SNMP_VERSION_2C) { return $_[0]->_asn1_decode_error( 'InformRequest-PDU only supported with SNMPv2c' ); } $_[0]->_asn1_decode_pdu(INFORM_REQUEST); } sub _asn1_decode_v2_trap { if ($_[0]->version != SNMP_VERSION_2C) { return $_[0]->_asn1_decode_error( 'SNMPv2-Trap-PDU only supported with SNMPv2c' ); } $_[0]->_asn1_decode_pdu(SNMPV2_TRAP); } sub _asn1_decode_error { my $this = shift; $this->_object_error(@_); } ### ## Abstract Syntax Notation One (ASN.1) utility functions ### sub _asn1_itoa { my $type = shift; my $types = { INTEGER, 'INTEGER', OCTET_STRING, 'OCTET STRING', NULL, 'NULL', OBJECT_IDENTIFIER, 'OBJECT IDENTIFER', SEQUENCE, 'SEQUENCE', IPADDRESS, 'IpAddress', COUNTER, 'Counter', GAUGE, 'Gauge', TIMETICKS, 'TimeTicks', OPAQUE, 'Opaque', COUNTER64, 'Counter64', NOSUCHOBJECT, 'noSuchObject', NOSUCHINSTANCE, 'noSuchInstance', ENDOFMIBVIEW, 'endOfMibView', GET_REQUEST, 'GetRequest-PDU', GET_NEXT_REQUEST, 'GetNextRequest-PDU', GET_RESPONSE, 'GetResponse-PDU', SET_REQUEST, 'SetRequest-PDU', TRAP, 'Trap-PDU', GET_BULK_REQUEST, 'GetBulkRequest-PDU', INFORM_REQUEST, 'InformRequest-PDU', SNMPV2_TRAP, 'SNMPv2-Trap-PDU' }; if (!defined($type)) { return '??'; } if (exists($types->{$type})) { $types->{$type}; } else { sprintf("?? [0x%02x]", $type); } } sub _asn1_oid_context_match { my ($oid_p, $oid_c) = @_; my ($parent, $child) = (undef, undef); # Compares the parent OID (oid_p) to the child OID (oid_c) # and returns true if the child is equal to or is a subtree # of the parent OID. if (!defined($oid_p)) { return FALSE; } if (!defined($oid_c)) { return FALSE; } # Remove leading dots $oid_p =~ s/^\.//; $oid_c =~ s/^\.//; my @subid_p = split(/\./, $oid_p); my @subid_c = split(/\./, $oid_c); while (@subid_p) { if (!defined($parent = shift(@subid_p))) { return TRUE; } if (!defined($child = shift(@subid_c))) { return FALSE; } if ($parent != $child) { return FALSE; } } TRUE; } sub _asn1_oid_lex_sort { sort _asn1_lexicographical @_; } sub _asn1_lexicographical { my ($aa, $bb); my @a = split(/\./, $a); if ($a[0] eq '') { shift(@a); } my @b = split(/\./, $b); if ($b[0] eq '') { shift(@b); } while (@a) { if (!defined($aa = shift(@a))) { return -1; } if (!defined($bb = shift(@b))) { return 1; } if ($aa < $bb) { return -1; } if ($aa > $bb) { return 1; } } 0; } sub _asn1_ticks_to_time { my $ticks = shift; if (!defined($ticks)) { $ticks = 0; } my $days = int($ticks / (24 * 60 * 60 * 100)); $ticks %= (24 * 60 * 60 * 100); my $hours = int($ticks / (60 * 60 * 100)); $ticks %= (60 * 60 * 100); my $minutes = int($ticks / (60 * 100)); $ticks %= (60 * 100); my $seconds = ($ticks / 100); if ($days != 0){ sprintf("%d day%s, %02d:%02d:%05.02f", $days, ($days == 1 ? '' : 's'), $hours, $minutes, $seconds); } elsif ($hours != 0) { sprintf("%d hour%s, %02d:%05.02f", $hours, ($hours == 1 ? '' : 's'), $minutes, $seconds); } elsif ($minutes != 0) { sprintf("%d minute%s, %05.02f", $minutes, ($minutes == 1 ? '' : 's'), $seconds); } else { sprintf("%04.02f second%s", $seconds, ($seconds == 1 ? '' : 's')); } } ### ## User Datagram Protocol (UDP) methods ### sub _udp_send_message { my $this = shift; my ($retries, $rout, $rin) = (0, '', ''); # Make sure the socket is still open if (!defined($this->{'_socket'})) { return $this->_udp_error('Session is closed'); } # Get the number of retries $retries = $this->{'_retries'}; # Setup a vector to indicate received data on the socket vec($rin, fileno($this->{'_socket'}), 1) = 1; do { if (!defined($this->_udp_send_buffer)) { return $this->_udp_error; } if (select($rout=$rin, undef, undef, $this->{'_timeout'})) { return $this->_udp_recv_buffer; } else { DEBUG_INFO("request timed out, retries = %d", $retries); $retries--; } } while ($retries >= 0); # Exceeded the number of retries $this->_udp_error( "No response from agent on remote host '%s'", $this->hostname ); } sub _udp_send_buffer { my $this = shift; my ($length, $host_port, $host_addr) = (0, undef, undef); # Make sure the socket is still open if (!defined($this->{'_socket'})) { return $this->_udp_error('Session is closed'); } ($host_port, $host_addr) = sockaddr_in($this->{'_sockaddr'}); DEBUG_INFO("address %s, port %d", inet_ntoa($host_addr), $host_port); $this->_debug_dump_buffer; # Transmit the contents of the buffer if (!defined($length = send($this->{'_socket'}, $this->{'_buffer'}, 0, $this->{'_sockaddr'}) )) { return $this->_udp_error("send(): %s", $!); } # Return the number of bytes transmitted $length; } sub _udp_recv_buffer { my $this = shift; my $sockaddr = undef; # Make sure the socket is still open if (!defined($this->{'_socket'})) { return $this->_udp_error('Session is closed'); } # Clear the contents of the buffer $this->_object_clear_buffer; # Fill the buffer if (!defined($sockaddr = recv($this->{'_socket'}, $this->{'_buffer'}, $this->{'_mtu'}, 0) )) { return $this->_udp_error("recv(): %s", $!); } my ($host_port, $host_addr) = sockaddr_in($sockaddr); DEBUG_INFO("address %s, port %d", inet_ntoa($host_addr), $host_port); $this->_debug_dump_buffer; # Return the address structure $sockaddr; } sub _udp_error { my $this = shift; $this->_object_error(@_); } ### ## Object specific methods ### sub _object_copy { my $this = shift; my $copy = bless {}, ref($this); foreach (keys(%{$this})) { $copy->{$_} = $this->{$_}; } $copy; } sub _object_queue_message { my $this = shift; if ((!$this->{'_nonblocking'}) || (!defined($this->{'_fsm'}))) { return $this->_object_encode_error( 'Unable to queue message for a blocking session' ); } if (!defined($this->{'_socket'})) { return $this->_object_encode_error('Session is closed'); } if (!defined($this->{'_fsm'}->queue_message($this))) { $this->_object_encode_error('Failed to queue message'); } TRUE; } sub _object_add_callback { my ($this, $callback) = @_; # Callbacks can be passed in two different ways. If the callback # has options, the callback must be passed as an ARRAY reference # with the first element being a CODE reference and the remaining # elements the arguments. If the callback has not options it # is just passed as a CODE reference. if ((ref($callback) eq 'ARRAY') && (ref($callback->[0]) eq 'CODE')) { $this->{'_callback'} = $callback; } elsif (ref($callback) eq 'CODE') { $this->{'_callback'} = [$callback]; } elsif (!defined($callback)) { $this->{'_callback'} = undef; # Used to clear the callback } else { return $this->_object_error('Invalid callback format'); } TRUE; } sub _object_invoke_callback { my $this = shift; # Callbacks are invoked with a reference to the copy of the original # object followed by the users parameters. if (defined($this->{'_callback'})) { my @argv = @{$this->{'_callback'}}; my $callback = shift(@argv); if (ref($callback) ne 'CODE') { return($this->{'_callback'} = undef); } unshift(@argv, $this); eval { &{$callback}(@argv) }; if ($@ ne '') { DEBUG_INFO("eval error: %s", $@); } return $@; } DEBUG_INFO("callback not defined"); $this->{'_callback'}; } sub _object_get_table_cb { my ($this, $argv) = @_; # Use get-next-requests until the response is not a subtree of the # base OBJECT IDENTIFIER. Return the table only if there are no # errors other than a noSuchName(2) error since the table could # be at the end of the tree. Also return the table when the value # of the OID equals endOfMibView(2) when using SNMPv2c. # Assign the "real" callback to the object $this->{'_callback'} = $argv->{'callback'}; # Check to see if the var_bind_list is defined (was there an error?) if (defined($this->var_bind_list)) { my ($next_oid) = keys(%{$this->var_bind_list}); if (_asn1_oid_context_match($argv->{'base_oid'}, $next_oid)) { if (!exists($argv->{'table'}->{$next_oid})) { $argv->{'table'}->{$next_oid} = $this->var_bind_list->{$next_oid}; } elsif ((($this->var_bind_list->{$next_oid} eq 'endOfMibView') || ($this->error_status == ENDOFMIBVIEW)) && ($this->version == SNMP_VERSION_2C)) { if (!defined($argv->{'table'})) { $this->_object_decode_error('Requested table is empty'); } $this->{'_var_bind_list'} = $argv->{'table'}; return $this->_object_invoke_callback; } else { $argv->{'repeat_cnt'}++; } # Check to make sure that the remote host does not respond # incorrectly causing the get-next-requests to loop forever. if ($argv->{'repeat_cnt'} > 5) { $this->_object_decode_error( 'Loop detected with table on remote host' ); return $this->_object_invoke_callback; } # Queue up the get-next-request $this->get_next_request( -callback => [\&_object_get_table_cb, $argv], -varbindlist => [$next_oid] ); } else { # We have reached the end of the table if (!defined($argv->{'table'})) { $this->_object_decode_error('Requested table is empty'); } $this->{'_var_bind_list'} = $argv->{'table'}; return $this->_object_invoke_callback; } } else { # Check for noSuchName(2) error if ($this->error_status == 2) { if (!defined($argv->{'table'})) { $this->_object_decode_error('Requested table is empty'); } $this->{'_var_bind_list'} = $argv->{'table'}; } $this->_object_invoke_callback; } } sub _object_put_buffer { my ($this, $prefix) = @_; # Do not do anything if there has already been an error if (defined($this->{'_error'})) { return $this->_object_encode_error; } # Make sure we do not exceed our MTU if (($this->_object_buffer_length + length($prefix)) > $this->{'_mtu'}) { return $this->_object_encode_error('PDU size exceeded MTU'); } # Add the prefix to the current buffer if ((defined($prefix)) && ($prefix ne '')) { $this->{'_buffer'} = join('', $prefix, $this->{'_buffer'}); } # Return what was just added in case someone wants it $prefix; } sub _object_get_buffer { my ($this, $offset) = @_; my $substr = ''; # Do not do anything if there has already been an error if (defined($this->{'_error'})) { return $this->_object_decode_error; } # Either return the whole buffer or a sub-string from the # beginning of the buffer and then set the buffer equal to # what is left in the buffer if (defined($offset)) { $offset = abs($offset); if ($offset > length($this->{'_buffer'})) { return $this->_object_decode_error('Unexpected end of buffer'); } else { $substr = substr($this->{'_buffer'}, 0, $offset); $this->{'_buffer'} = substr($this->{'_buffer'}, $offset); } } else { $substr = $this->{'_buffer'}; $this->{'_buffer'} = ''; } $substr; } sub _object_clear_buffer { $_[0]->{'_buffer'} = ''; } sub _object_clear_var_bind_list { $_[0]->{'_var_bind_list'} = undef; } sub _object_clear_error { $_[0]->{'_error_status'} = 0; $_[0]->{'_error_index'} = 0; $_[0]->{'_error'} = undef; } sub _object_clear_snmp_message { my @fields = qw( _version _community _type _request_id _error_status _error_index _enterprise _agent_addr _generic_trap _specific_trap _time_stamp ); foreach (@fields) { if (exists($_[0]->{$_})) { $_[0]->{$_} = undef; } } } sub _object_clear_leading_dot { $_[0]->{'_leading_dot'} = FALSE; } sub _object_buffer_length { length $_[0]->{'_buffer'}; } sub _object_encode_error { my $this = shift; # Clear the buffer $this->_object_clear_buffer; $this->_object_error(@_); } sub _object_decode_error { my $this = shift; $this->_object_error(@_); } sub _object_error { my ($this, $format, @message) = @_; if (!defined($this->{'_error'})) { $this->{'_error'} = sprintf $format, @message; if ($this->debug) { my $index = caller(3) ? 1 : 0; printf("error: [%d] %s(): %s\n", (caller($index))[2], (caller($index + 1))[3], $this->{'_error'} ); } } undef; } ### ## Debug functions/methods ### sub DEBUG_INFO { if (!$Net::SNMP::DEBUG) { return $Net::SNMP::DEBUG; } my $format = sprintf("debug: [%d] %s(): ", (caller(0))[2], (caller(1))[3]); $format = join('', $format, shift(@_), "\n"); printf $format, @_; $Net::SNMP::DEBUG; } sub _debug_dump_buffer { my $this = shift; my ($length, $offset, $line, $hex) = (0, 0, '', ''); if (!$this->debug) { return undef; } $length = length($this->{'_buffer'}); DEBUG_INFO("%d byte%s", $length, ($length == 1 ? '' : 's')); while ($length > 0) { if ($length >= 16) { $line = substr($this->{'_buffer'}, $offset, 16); } else { $line = substr($this->{'_buffer'}, $offset, $length); } $hex = unpack('H*', $line); $hex .= ' ' x (32 - length($hex)); $hex = sprintf("%s %s %s %s " x 4, unpack('a2' x 16, $hex)); $line =~ s/[\x00-\x1f\x7f-\xff]/./g; printf("[%03d] %s %s\n", $offset, uc($hex), $line); $offset += 16; $length -= 16; } print("\n"); $this->{'_buffer'}; } # ============================================================================ 1; # [end Net::SNMP] # ============================================================================ package Net::SNMP::FSM; # $Id: FSM.pm,v 1.1 2000/01/01 17:55:53 dtown Exp $ # $Source: /us/dtown/Projects/Net-SNMP/FSM.pm,v $ # Finite State Machine for the Net::SNMP event loop. # Copyright (c) 1999-2000 David M. Town . # All rights reserved. # This program is free software; you may redistribute it and/or modify it # under the same terms as Perl itself. # ============================================================================ ## Import and initialize global symbols sub BEGIN { require Net::SNMP; *DEBUG_INFO = \&Net::SNMP::DEBUG_INFO; *FALSE = \&Net::SNMP::FALSE; *GET_RESPONSE = \&Net::SNMP::GET_RESPONSE; *MINIMUM_MTU = \&Net::SNMP::MINIMUM_MTU; *SNMPV2_TRAP = \&Net::SNMP::SNMPV2_TRAP; *TRAP = \&Net::SNMP::TRAP; *TRUE = \&Net::SNMP::TRUE; } ## Finite State Machine state definitions sub STATE_STOPPED() { 0 } sub STATE_STARTING() { 1 } sub STATE_SENDING() { 2 } sub STATE_WAITING() { 3 } sub STATE_VALIDATING() { 4 } sub STATE_CLEARING() { 5 } ## Flag to indicate a "dead" queued object sub TTD_DEAD() { 0 } # [public methods] ----------------------------------------------------------- sub new { my ($class, %argv) = @_; my $this = bless { '_decode_object' => undef, '_pending_queue' => [], '_rin' => '', '_sending_queue' => [], '_sockets' => {}, '_state' => STATE_STOPPED }, $class; # Create a Net::SNMP object to use to decode the responses. $this->{'_decode_object'} = Net::SNMP->new(-mtu => MINIMUM_MTU); if (!defined($this->{'_decode_object'})) { DEBUG_INFO('failed to create Net::SNMP object'); return undef; } $this; } sub queue_message { $_[0]->_action_queue($_[1]); } sub event_loop { $_[0]->_event_loop; } sub one_event { $_[0]->_event_handle; } # [private methods] ---------------------------------------------------------- sub _event_loop { my $this = shift; # The action that starts everything... $this->_action_start; while ($this->_object_state != STATE_STOPPED) { $this->_event_handle; } $this->_object_clear; } sub _event_handle { my $this = shift; if ($this->_object_state == STATE_STARTING) { $this->_state_starting; } elsif ($this->_object_state == STATE_SENDING) { $this->_state_sending; } elsif ($this->_object_state == STATE_WAITING) { $this->_state_waiting; } elsif ($this->_object_state == STATE_VALIDATING) { $this->_state_validating; } elsif ($this->_object_state == STATE_CLEARING) { $this->_state_clearing; } else { DEBUG_INFO("state = %d", $this->_object_state); $this->_object_state(STATE_STOPPED); } } ### ## FSM States ### sub _state_starting { my $this = shift; # Need to initialize the "time-to-die" fields on all pending messages foreach (@{$this->{'_pending_queue'}}) { $_->{'_ttd'} = time() + $_->timeout; } if (@{$this->{'_sending_queue'}}) { $this->_action_send; } elsif (@{$this->{'_pending_queue'}}) { $this->_action_wait; } else { $this->_action_stop; } } sub _state_sending { my $this = shift; my $message = undef; DEBUG_INFO("sending %d message(s)", scalar(@{$this->{'_sending_queue'}})); while (defined($message = shift(@{$this->{'_sending_queue'}}))) { if (!defined($message->_udp_send_buffer)) { DEBUG_INFO("error [%s]", $message->error); return $this->_action_stop; } } if (@{$this->{'_pending_queue'}}) { $this->_action_wait; } else { $this->_action_stop; } } sub _state_waiting { my $this = shift; # Sort the pending queue by time-to-die @{$this->{'_pending_queue'}} = sort _by_ttd @{$this->{'_pending_queue'}}; # Calculate a timeout based on the current time and the # lowest time-to-die in the queue. my $timeout = ${$this->{'_pending_queue'}}[0]->{'_ttd'} - time(); # If the timeout is less than 0, this entry has timed out. if ($timeout < 0) { $this->_action_timeout; $timeout = 0; } if (select(my $rout = $this->{'_rin'}, undef, undef, $timeout)) { # Find out which socket has data ready foreach (keys(%{$this->{'_sockets'}})) { if (defined($rout) && vec($rout, $_, 1)) { DEBUG_INFO("socket handle [%d] ready", $_); return $this->_action_read_data($this->{'_sockets'}->{$_}); } } } DEBUG_INFO("no response, timeout = %f", $timeout); # Else handle the timeout $this->_action_timeout; } sub _state_validating { my $this = shift; my $object = $this->{'_decode_object'}; # Decode the packet up to the VarBindList $object->_object_clear_snmp_message; $object->{'_type'} = GET_RESPONSE; if (!defined($object->_snmp_decode_message)) { DEBUG_INFO("message decode error [%s]", $object->error); return $this->_action_clear; } if (!defined($object->_snmp_decode_pdu)) { DEBUG_INFO("pdu decode error [%s]", $object->error); return $this->_action_clear; } # Now look for a matching queued message based on request-id foreach (@{$this->{'_pending_queue'}}) { if ($_->{'_ttd'} == TTD_DEAD) { next; } if ($object->_request_id == $_->_request_id) { DEBUG_INFO("response received: request-id = %s (%s)", $_->_request_id, $_->hostname ); # Set the time-to-die to "dead" so this object is # removed from the queue in the clearing state. $_->{'_ttd'} = TTD_DEAD; # Now compare the response to sent message if (!defined($_->_snmp_compare_get_response($object))) { return $this->_action_callback($_); } # Copy the remaining buffer over to the "real" object # and decode the VarBindList. $_->{'_buffer'} = $object->{'_buffer'}; $_->_snmp_decode_var_bind_list; return $this->_action_callback($_); } } DEBUG_INFO("unknown request-id = %s", $object->_request_id); $this->_action_clear; } sub _state_clearing { my $this = shift; # Sort the pending queue by time-to-die @{$this->{'_pending_queue'}} = sort _by_ttd @{$this->{'_pending_queue'}}; # Now clear out any "dead" objects from the pending queue while ((@{$this->{'_pending_queue'}}) && (${$this->{'_pending_queue'}}[0]->{'_ttd'} == TTD_DEAD)) { DEBUG_INFO("remove request-id = %s (%s)", ${$this->{'_pending_queue'}}[0]->{'_org_req_id'}, ${$this->{'_pending_queue'}}[0]->hostname, ); shift(@{$this->{'_pending_queue'}}); } if (@{$this->{'_sending_queue'}}) { $this->_action_send; } elsif (!@{$this->{'_pending_queue'}}) { $this->_action_stop; } else { $this->_action_wait; } } ### ## FSM actions ### sub _action_queue { my ($this, $message) = @_; # Make sure that a Net::SNMP object was passed if (!defined($message) || ref($message) ne 'Net::SNMP') { DEBUG_INFO('invalid message type'); return undef; } # Validate the socket status if (!defined($message->{'_socket'}) || !fileno($message->{'_socket'})) { DEBUG_INFO('socket is invalid'); return undef; } # Copy the object, so that we can use it for retransmissions my $copy = $message->_object_copy; # Adjust the MTU of the decode object if necessary if ($copy->mtu > $this->{'_decode_object'}->mtu) { $this->{'_decode_object'}->mtu($copy->mtu); } # Add a time-to-die field and a copy of the request-id to the copy $copy->{'_ttd'} = time() + $copy->timeout; $copy->{'_org_req_id'} = $copy->_request_id; # Add the socket to the "readable" vector vec($this->{'_rin'}, fileno($copy->{'_socket'}), 1) = 1; # Add the socket to the list of sockets $this->{'_sockets'}->{fileno($copy->{'_socket'})} = $copy->{'_socket'}; # Queue the copy for transmission $this->_object_queue_sending($copy); # Queue the copy, if the message requires a response if ((defined($copy->{'_type'})) && ($copy->{'_type'} != TRAP) && ($copy->{'_type'} != SNMPV2_TRAP)) { $this->_object_queue_pending($copy); } DEBUG_INFO("add request-id = %s (%s)", $copy->_request_id, $copy->hostname ); if (($this->_object_state == STATE_STOPPED) || ($this->_object_state == STATE_STARTING)) { $this->_object_state(STATE_STARTING); } else { $this->_object_state(STATE_SENDING); } } sub _action_stop { $_[0]->_object_state(STATE_STOPPED); } sub _action_start { $_[0]->_object_state(STATE_STARTING); } sub _action_wait { $_[0]->_object_state(STATE_WAITING); } sub _action_read_data { my ($this, $socket) = @_; if (!fileno($socket)) { DEBUG_INFO('invalid socket'); return $this->_object_state(STATE_STOPPED); } my $object = $this->{'_decode_object'}; # Set the FSM's Net::SNMP object's socket equal to the socket $object->{'_socket'} = $socket; # Read the data if (!defined($object->_udp_recv_buffer)) { DEBUG_INFO("error [%d]", $object->error); return $this->_object_state(STATE_STOPPED); } $_[0]->_object_state(STATE_VALIDATING); } sub _action_timeout { my $this = shift; my $time = time(); foreach (@{$this->{'_pending_queue'}}) { if ($_->{'_ttd'} > $time) { last; } if ($_->{'_ttd'} == TTD_DEAD) { next; } if ($_->{'_retries'}-- > 0) { DEBUG_INFO("retry request-id = %s (%s), skew = %f, retries = %d", $_->_request_id, $_->hostname, ($time - $_->{'_ttd'}), $_->{'_retries'} ); # Update the time-to-die and queue for sending $_->{'_ttd'} += int($_->timeout); $this->_object_queue_sending($_); } else { DEBUG_INFO("timeout: request-id = %s (%s), skew = %f", $_->_request_id, $_->hostname, ($time - $_->{'_ttd'}) ); $_->{'_ttd'} = TTD_DEAD; $_->_snmp_decode_error( "No response from agent on remote host '%s'", $_->hostname ); $this->_action_callback($_); } } if (@{$this->{'_sending_queue'}}) { $this->_object_state(STATE_SENDING); } else { $this->_object_state(STATE_CLEARING); } } sub _action_validate { $_[0]->_object_state(STATE_VALIDATING); } sub _action_clear { $_[0]->_object_state(STATE_CLEARING); } sub _action_send { $_[0]->_object_state(STATE_SENDING); } sub _action_callback { if (@_ == 2) { $_[1]->_object_invoke_callback; } $_[0]->_object_state(STATE_CLEARING); } ### ## Object specific methods/functions ### sub _object_state { if (@_ == 2) { $_[0]->{'_state'} = $_[1]; } $_[0]->{'_state'}; } sub _object_queue_sending { if ((@_ == 2) && (defined($_[1]))) { push(@{$_[0]->{'_sending_queue'}}, $_[1]); return TRUE; } FALSE; } sub _object_queue_pending { if ((@_ == 2) && (defined($_[1]))) { push(@{$_[0]->{'_pending_queue'}}, $_[1]); return TRUE; } FALSE; } sub _object_clear { $_[0]->{'_pending_queue'} = []; $_[0]->{'_rin'} = ''; $_[0]->{'_sending_queue'} = []; $_[0]->{'_sockets'} = {}; $_[0]->{'_state'} = STATE_STOPPED; TRUE; } # Sort by time-to-die sub _by_ttd { $a->{'_ttd'} <=> $b->{'_ttd'}; } # ============================================================================ 1; # [end Net::SNMP::FSM] # ============================================================================ __DATA__ ### ## POD formatted documentation for Perl module Net::SNMP. ## ## $Id: Net-SNMP.pod,v 3.0.1.1 2000/01/01 17:58:04 dtown Exp $ ## $Source: /us/dtown/Projects/Net-SNMP/Net-SNMP.pod,v $ ## ### =head1 NAME Net::SNMP - Simple Network Management Protocol =head1 SYNOPSIS The module Net::SNMP implements an object oriented interface to the Simple Network Management Protocol. Perl applications can use the module to retrieve or update information on a remote host using the SNMP protocol. Net::SNMP is implemented completely in Perl, requires no compiling, and uses only standard Perl modules. Both SNMPv1 and SNMPv2c (Community-Based SNMPv2) are supported by the module. The Net::SNMP module assumes that the user has a basic understanding of the Simple Network Management Protocol and related network management concepts. =head1 DESCRIPTION The module Net::SNMP abstracts the intricate details of the Simple Network Management Protocol by providing a high level programming interface to the protocol. Each Net::SNMP object provides a one-to-one mapping between a Perl object and a remote SNMP agent or manager. Once an object is created, it can be used to perform all of the basic protocol exchange actions defined by SNMP. A Net::SNMP object can be created such that it has either "blocking" or "non-blocking" properties. By default, the methods used to send SNMP messages do not return until the protocol exchange has completed successfully or a timeout period has expired. This behavior gives the object a "blocking" property because the flow of the code is stopped until the method returns. The optional named argument "B<-nonblocking>" can be passed to the object constructor with a true value to give the object "non-blocking" behavior. A method invoked by a non-blocking object queues the SNMP message and returns immediately allowing the flow of the code to continue. The queued SNMP messages are not sent until an event loop is entered by calling the C method. When the SNMP messages are sent, any response to the messages invokes the subroutine defined by the user when the message was originally queued. The event loop exits when all messages have been removed from the queue by either receiving a response or when the number of retries for the object has been exceeded. =head2 Blocking Objects The default behavior of the methods associated with a Net::SNMP object is to block the code flow until the method completes. For methods that initiate a SNMP protocol exchange requiring a response, a hash reference containing the results of the query are returned. The undefined value is returned by all methods when a failure has occurred. The C method can be used to determine the cause of the failure. The hash reference returned by a SNMP protocol exchange points to a hash constructed from the VarBindList contained in the SNMP GetResponse-PDU. The hash is created using the ObjectName and the ObjectSyntax pairs in the VarBindList. The keys of the hash consist of the OBJECT IDENTIFIERs in dotted notation corresponding to each ObjectName in the VarBindList. The value of each hash entry is set equal to the value of the corresponding ObjectSyntax. This hash reference can also be retrieved using the C method. =head2 Non-blocking Objects When a Net::SNMP object is created having non-blocking behavior, the invocation of a method associated with the object returns immediately, allowing the flow of the code to continue. When a method is invoked that would initiate a SNMP protocol exchange requiring a response, either a true value (i.e. 0x1) is returned immediately or the undefined value is returned if there was a failure. The C method can be used to determine the cause of the failure. Most methods associated with a non-blocking object have an optional named argument called "B<-callback>". The B<-callback> argument expects a reference to a subroutine or to an array whose first element must be a reference to a subroutine. The subroutine defined by the B<-callback> option is executed when a response to a SNMP message is received, an error condition has occurred, or the number of retries for the message has been exceeded. When the B<-callback> argument only contains a subroutine reference, the subroutine is evaluated passing a copy of the original Net::SNMP object as the only parameter. The copy of the object has all of the properties that the original object had when the message was queued, and will also contain the results of the SNMP protocol exchange. If the B<-callback> argument was defined as an array reference, all elements in the array are passed to the subroutine after the copy of the Net::SNMP object. The first element, which is required to be a reference to a subroutine, is removed before the remaining arguments are passed to that subroutine. Once one method is invoked with the B<-callback> argument, this argument stays with the object and is used by any further calls to methods using the B<-callback> option if the argument is absent. The undefined value may be passed to the B<-callback> argument to delete the callback subroutine. B The subroutine being passed with the B<-callback> named argument should not cause blocking itself. This will cause all the actions in the event loop to be stopped, defeating the non-blocking property of the Net::SNMP module. The contents of the VarBindList contained in the SNMP GetResponse-PDU can be retrieved by calling the C method associated with the copy of the original object. The value returned by the C method is a hash reference created using the ObjectName and the ObjectSyntax pairs in the VarBindList. The keys of the hash consist of the OBJECT IDENTIFIERs in dotted notation corresponding to each ObjectName in the VarBindList. The value of each hash entry is set equal to the value of the corresponding ObjectSyntax. The undefined value is returned if there has been a failure and the C method may be used to determine the reason. =head1 METHODS Most methods associated with a Net::SNMP object take different parameters based on the "blocking" or "non-blocking" property of the object. When named arguments are used with methods, two different styles are supported. All examples in this documentation use the dashed-option style: $object->method(-argument => $value); However, the IO:: style is also allowed: $object->method(Argument => $value); =head2 session() - create a new Net::SNMP object ($session, $error) = Net::SNMP->session( [-hostname => $hostname,] [-community => $community,] [-port => $port,] [-nonblocking => $nonblocking,] [-version => $version,] [-timeout => $seconds,] [-retries => $count,] [-mtu => $octets,] [-translate => $translate,] [-debug => $debug] ); This is the constructor for Net::SNMP objects. In scalar context, a reference to a new Net::SNMP object is returned if the creation of the object is successful. In list context, a reference to a new Net::SNMP object and an empty error message string is returned. If a failure occurs, the object reference is returned as the undefined value. The error string may be used to determine the cause of the error. The B<-hostname>, B<-community>, B<-port>, and B<-nonblocking> arguments are basic properties of a Net::SNMP object and cannot be changed after the object is created. All other arguments have methods that allow their values to be modified after the Net::SNMP object has been created. See the methods corresponding to these named arguments for their valid ranges and default values. All arguments are optional and will take default values in the absence of a corresponding named argument. =over =item * The default value for the remote B<-hostname> is "localhost". The hostname can either be a network hostname or the dotted IP address of the host. =item * The default value for the SNMP B<-community> name is "public". =item * The default value for the destination UDP B<-port> number is 161. This is the port on which hosts using default values expect to receive all SNMP messages except for traps. Port number 162 is the default port used by hosts expecting to receive SNMP traps. =item * The default value for the B<-nonblocking> property is 0x0 (false). =back =head2 close() - clear the UDP socket reference, buffers, and errors $session->close; This method clears the UDP socket reference, the errors, hash pointers, and buffers associated with the object. Once closed, the Net::SNMP object can no longer be used to send or received SNMP messages. =head2 snmp_event_loop() - enter the non-blocking object event loop $session->snmp_event_loop; This method enters the event loop associated with non-blocking Net::SNMP objects. The method exits when all queued SNMP messages have been responded to or have timed out. This method is also exported as the stand alone function C by default (see L<"EXPORTS">). =head2 get_request() - send a SNMP get-request to the remote agent Blocking $response = $session->get_request(@oids); Non-blocking $ok = $session->get_request( [-callback => sub {},] -varbindlist => \@oids ); This method performs a SNMP get-request query to gather data from the remote agent on the host associated with the Net::SNMP object. The blocking form of the method takes a list of OBJECT IDENTIFIERs in dotted notation. Each OBJECT IDENTIFER is placed into a single SNMP GetRequest-PDU in the same order that it held in the original list. When the object is in non-blocking mode, the list is passed as an array reference to the B<-varbindlist> named argument. A reference to a hash is returned in blocking mode which contains the contents of the VarBindList. In non-blocking mode, a true value is returned when no error has occurred. In either mode the undefined value is returned when an error has occurred. The C method may be used to determine the cause of the failure. =head2 get_next_request() - send a SNMP get-next-request to the remote agent Blocking $response = $session->get_next_request(@oids); Non-blocking $ok = $session->get_next_request( [-callback => sub {},] -varbindlist => \@oids ); This method performs a SNMP get-next-request query to gather data from the remote agent on the host associated with the Net::SNMP object. The blocking form of the method takes a list of OBJECT IDENTIFIERs in dotted notation. Each OBJECT IDENTIFER is placed into a single SNMP GetNextRequest-PDU in the same order that it held in the original list. When the object is in non-blocking mode, the list is passed as an array reference to the B<-varbindlist> named argument. A reference to a hash is returned in blocking mode which contains the contents of the VarBindList. In non-blocking mode, a true value is returned when no error has occurred. In either mode the undefined value is returned when an error has occurred. The C method may be used to determine the cause of the failure. =head2 set_request() - send a SNMP set-request to the remote agent Blocking $response = $session->set_request(@oid_type_value); Non-blocking $ok = $session->set_request( [-callback => sub {},] -varbindlist => \@oid_type_value ); This method is used to modify data on the remote agent that is associated with the Net::SNMP object using a SNMP set-request. The blocking form of the method takes a list of values consisting of groups of an OBJECT IDENTIFIER, an object type, and the actual value to be set. The OBJECT IDENTIFIERs in each trio are to be in dotted notation. The object type is a byte corresponding to the ASN.1 type of value that is to be set. Each of the supported types have been defined and are exported by the package by default (see L<"EXPORTS">). When the object is in non-blocking mode, the list is passed as an array reference to the B<-varbindlist> named argument. A reference to a hash is returned in blocking mode which contains the contents of the VarBindList. In non-blocking mode, a true value is returned when no error has occurred. In either mode the undefined value is returned when an error has occurred. The C method may be used to determine the cause of the failure. =head2 trap() - send a SNMP trap to the remote manager Blocking or non-blocking $value = $session->trap( [-enterprise => $oid,] [-agentaddr => $ipaddress,] [-generictrap => $generic,] [-specifictrap => $specific,] [-timestamp => $timeticks,] [-varbindlist => \@oid_type_value] ); This method sends a SNMP trap to the remote manager associated with the Net::SNMP object. All arguments are optional and will be given the following defaults in the absence of a corresponding named argument: =over =item * The default value for the trap B<-enterprise> is "1.3.6.1.4.1", which corresponds to "iso.org.dod.internet.private.enterprises". The enterprise value is expected to be an OBJECT IDENTIFER in dotted notation. =item * The default value for the trap B<-agentaddr> is the local IP address from the host on which the script is running. The agent-addr is expected to be an IpAddress in dotted notation. =item * The default value for the B<-generictrap> type is 6 which corresponds to "enterpriseSpecific". The generic-trap types are defined and can be exported upon request (see L<"EXPORTS">). =item * The default value for the B<-specifictrap> type is 0. No pre-defined values are available for specific-trap types. =item * The default value for the trap B<-timestamp> is the "uptime" of the script. The "uptime" of the script is the number of hundredths of seconds that have elapsed since the script began running. The time-stamp is expected to be a TimeTicks number in hundredths of seconds. =item * The default value for the trap B<-varbindlist> is an empty array reference. The variable-bindings are expected to be in an array format consisting of groups of an OBJECT IDENTIFIER, an object type, and the actual value of the object. This is identical to the list expected by the C method. The OBJECT IDENTIFIERs in each trio are to be in dotted notation. The object type is a byte corresponding to the ASN.1 type for the value. Each of the supported types have been defined and are exported by default (see L<"EXPORTS">). =back Upon success, the number of bytes transmitted is returned when the object is in blocking mode. A true value is returned when successful in non-blocking mode. The undefined value is returned when a failure has occurred. The C method can be used to determine the cause of the failure. Since there are no acknowledgements for Trap-PDUs, there is no way to determine if the remote host actually received the trap. B When the object is in non-blocking mode, the trap is not sent until the event loop is entered. =head2 get_bulk_request() - send a SNMPv2 get-bulk-request to the remote agent Blocking $response = $session->get_bulk_request( [-nonrepeaters => $nonrepeaters,] [-maxrepetitions => $maxrepetitions,] -varbindlist => \@oids ); Non-blocking $ok = $session->get_bulk_request( [-callback => sub {},] [-nonrepeaters => $nonrepeaters,] [-maxrepetitions => $maxrepetitions,] -varbindlist => \@oids ); This method performs a SNMP get-bulk-request query to gather data from the remote agent on the host associated with the Net::SNMP object. All arguments are optional except B<-varbindlist> and will be given the following defaults in the absence of a corresponding named argument: =over =item * The default value for the get-bulk-request B<-nonrepeaters> is 0. The non-repeaters value specifies the number of variables in the variable-bindings list for which a single successor is to be returned. =item * The default value for the get-bulk-request B<-maxrepetitions> is 0. The max-repetitions value specifies the number of successors to be returned for the remaining variables in the variable-bindings list. =item * The B<-varbindlist> argument expects an array reference consisting of a list of OBJECT IDENTIFIERs in dotted notation. Each OBJECT IDENTIFER is placed into a single SNMP GetBulkRequest-PDU in the same order that it held in the original list. =back A reference to a hash is returned in blocking mode which contains the contents of the VarBindList. In non-blocking mode, a true value is returned when no error has occurred. In either mode the undefined value is returned when an error has occurred. The C method may be used to determine the cause of the failure. B This method can only be used when the version of the object is set to SNMPv2c. =head2 inform_request() - send a SNMPv2 inform-request to the remote manager Blocking $response = $session->inform_request(@oid_type_value); Non-blocking $ok = $session->inform_request( [-callback => sub {},] -varbindlist => \@oid_type_value ); This method is used to provide management information to the remote manager associated with the Net::SNMP object using a SNMPv2 inform-request. In blocking mode, the method takes a list of values consisting of groups of an OBJECT IDENTIFIER, an object type, and the actual value to be defined. The OBJECT IDENTIFIERs in each trio are to be in dotted notation. The object type is a byte corresponding to the ASN.1 type of value that is identified. Each of the supported types have been defined and are exported by the package by default (see L<"EXPORTS">). When the object is in non-blocking mode, the list is passed as an array reference to the B<-varbindlist> named argument. The first two variable-bindings fields in the inform-request are specified by SNMPv2 and should be: =over =item * sysUpTime.0 - ['1.3.6.1.2.1.1.3.0', TIMETICKS, $timeticks] =item * snmpTrapOID.0 - ['1.3.6.1.6.3.1.1.4.1.0', OBJECT_IDENTIFIER, $oid] =back A reference to a hash is returned in blocking mode which contains the contents of the VarBindList. In non-blocking mode, a true value is returned when no error has occurred. In either mode the undefined value is returned when an error has occurred. The C method may be used to determine the cause of the failure. B This method can only be used when the version of the object is set to SNMPv2c. =head2 snmpv2_trap() - send a SNMPv2 snmpV2-trap to the remote manager Blocking or non-blocking $value = $session->snmpv2_trap(@oid_type_value); This method sends a SNMPv2 snmpV2-trap to the remote manager associated with the Net::SNMP object. In either mode, the method takes a list of values consisting of groups of an OBJECT IDENTIFIER, an object type, and the actual value to be defined. The OBJECT IDENTIFIERs in each trio are to be in dotted notation. The object type is a byte corresponding to the ASN.1 type of value that is being identified. Each of the supported types have been defined and are exported by the package by default (see L<"EXPORTS">). The first two variable-bindings fields in the snmpV2-trap are specified by SNMPv2 and should be: =over =item * sysUpTime.0 - ['1.3.6.1.2.1.1.3.0', TIMETICKS, $timeticks] =item * snmpTrapOID.0 - ['1.3.6.1.6.3.1.1.4.1.0', OBJECT_IDENTIFIER, $oid] =back Upon success, the number of bytes transmitted is returned when the object is in blocking mode. A true value is returned when in successful in non-blocking mode. The undefined value is returned when a failure has occurred. The C method can be used to determine the cause of the failure. Since there are no acknowledgements for SNMPv2-Trap-PDUs, there is no way to determine if the remote host actually received the snmpV2-trap. B This method can only be used when the version of the object is set to SNMPv2c. B When the object is in non-blocking mode, the snmpV2-trap is not sent until the event loop is entered. =head2 get_table() - retrieve a table from the remote agent Blocking $response = $session->get_table($oid); Non-blocking $ok = $session->get_table( -baseoid => $oid, [-callback => sub {},] ); This method performs repeated SNMP get-next-request queries to gather data from the remote agent on the host associated with the Net::SNMP object. In blocking mode, the method takes a single OBJECT IDENTIFIER which is used as the base object for the SNMP get-next-requests. Repeated SNMP get-next-requests are issued until the OBJECT IDENTIFER in the response is no longer a subtree of the base OBJECT IDENTIFIER. When the object is in non-blocking mode, the OBJECT IDENTIFIER must be passed to the B<-baseoid> named argument. A reference to a hash is returned in blocking mode which contains the contents of the VarBindList. In non-blocking mode, a true value is returned when no error has occurred. In either mode the undefined value is returned when an error has occurred. The C method may be used to determine the cause of the failure. B Results from this method can become very large if the base OBJECT IDENTIFIER is close to the root of the SNMP MIB tree. =head2 version() - set or get the SNMP version for the object $rfc_version = $session->version([$version]); This method is used to set or get the current SNMP version associated with the Net::SNMP object. The module supports SNMP version-1 (SNMPv1) and SNMP version-2c (SNMPv2c). The default version used by the module is SNMP version-1. The method accepts the digit '1' or the string 'SNMPv1' for SNMP version-1 and the digit '2', or the strings '2c', 'SNMPv2', or 'SNMPv2c' for SNMP version-2c. The undefined value is returned upon an error and the C method may be used to determine the cause. The method returns the current value for the SNMP version. The returned value is the corresponding version number defined by the RFCs for the protocol version field (i.e. SNMPv1 == 0 and SNMPv2c == 1). =head2 error() - get the current error message from the object $error_message = $session->error; This method returns a text string explaining the reason for the last error. An empty string is returned if no error has occurred. =head2 hostname() - get the associated hostname from the object $hostname = $session->hostname; This method returns the hostname string that is associated with the object. =head2 error_status() - get the current SNMP error-status from the object $error_status = $session->error_status; This method returns the numeric value of the error-status contained in the last SNMP GetResponse-PDU. =head2 error_index() - get the current SNMP error-index from the object $error_index = $session->error_index; This method returns the numeric value of the error-index contained in the last SNMP GetResponse-PDU. =head2 var_bind_list() - get the hash reference to the last SNMP response $response = $session->var_bind_list; This method returns a hash reference created using the ObjectName and the ObjectSyntax pairs in the VarBindList of the last SNMP GetResponse-PDU received by the object. The keys of the hash consist of the OBJECT IDENTIFIERs in dotted notation corresponding to each ObjectName in the VarBindList. If any OBJECT IDENTIFIERs passed to the method began with a leading dot, all of the OBJECT IDENTIFIER hash keys will be prefixed with a leading dot. The value of each hash entry is set equal to the value of the corresponding ObjectSyntax. The undefined value is returned if there has been a failure and the C method may be used to determine the reason. =head2 timeout() - set or get the current timeout period for the object $seconds = $session->timeout([$seconds]); This method returns the current value for the UDP timeout for the Net::SNMP object. This value is the number of seconds that the object will wait for a response from the agent on the remote host. The default timeout is 5.0 seconds. If a parameter is specified, the timeout for the object is set to the provided value if it falls within the range 1.0 to 60.0 seconds. The undefined value is returned upon an error and the C method may be used to determine the cause. =head2 retries() - set or get the current retry count for the object $count = $session->retries([$count]); This method returns the current value for the number of times to retry sending a SNMP message to the remote host. The default number of retries is 1. If a parameter is specified, the number of retries for the object is set to the provided value if it falls within the range 0 to 20. The undefined value is returned upon an error and the C method may be used to determine the cause. =head2 mtu() - set or get the current MTU for the object $octets = $session->mtu([$octets]); This method returns the current value for the Maximum Transport Unit for the Net::SNMP object. This value is the largest value in octets for an SNMP message that can be transmitted or received by the object. The default MTU is 484 octets. If a parameter is specified, the Maximum Transport Unit is set to the provided value if it falls within the range 30 to 65535 octets. The undefined value is returned upon an error and the C method may be used to determine the cause. =head2 translate() - enable or disable the translation mode for the object $mode = $session->translate([$mode]); When the object decodes the GetResponse-PDU that is returned in response to a SNMP message, certain values are translated into a more "human readable" form. By default the following translations occur: =over =item * OCTET STRINGs containing non-printable characters are converted into a hexadecimal representation prefixed with "0x". =item * TimeTicks integer values are converted to a time format. =item * NULL values return the string "NULL" instead of an empty string. =item * noSuchObject exception values return the string "noSuchObject" instead of an empty string. If translation is not enabled, the SNMP error-status field is set to 128 which is equal to the exported definition NOSUCHOBJECT (see L<"EXPORTS">). =item * noSuchInstance exception values return the string "noSuchInstance" instead of an empty string. If translation is not enabled, the SNMP error-status field is set to 129 which is equal to the exported definition NOSUCHINSTANCE (see L<"EXPORTS">). =item * endOfMibView exception values return the string "endOfMibView" instead of an empty string. If translation is not enabled, the SNMP error-status field is set to 130 which is equal to the exported definition ENDOFMIBVIEW (see L<"EXPORTS">). =back If a parameter is specified, the translation mode is set to either enabled or disabled depending on the value of the passed parameter. Any value that Perl would treat as a true value will set the mode to be enabled, while a false value will disable translation. The current state of the translation mode is returned by the method. =head2 debug() - set or get the debug mode for the module $mode = $session->debug([$mode]); This method is used to enable or disable debugging for the Net::SNMP module. By default, debugging is off. If a parameter is specified, the debug mode is set to either enabled or disabled depending on the value of the passed parameter. Any value that Perl would treat as a true value will set the mode to be enabled, while a false value will disable debugging. The current state of the debugging mode is returned by the method. Debugging can also be enabled using the stand along function C. This function can be exported by request (see L<"EXPORTS">). =head1 FUNCTIONS =head2 oid_context_match() - determine if an OID has a specified MIB context $value = oid_context_match($base_oid, $oid); This function takes two OBJECT IDENTIFIERs in dotted notation and returns a true value (i.e. 0x1) if the second OBJECT IDENTIFIER is equal to or is a subtree of the first OBJECT IDENTIFIER in the SNMP Management Information Base (MIB). This function can be used in conjunction with the C or C methods to determine when a OBJECT IDENTIFIER in the GetResponse-PDU is no longer in the desired MIB context. =head2 oid_lex_sort() - sort a list of OBJECT IDENTIFIERs lexicographically @sorted_oids = oid_lex_sort(@oids); This function takes a list of OBJECT IDENTIFIERs in dotted notation and returns the listed sorted in lexicographical order. =head2 ticks_to_time() - convert TimeTicks to formatted time $time = ticks_to_time($timeticks); This function takes an ASN.1 TimeTicks value and returns a string representing the time defined by the value. The TimeTicks value is expected to be a non-negative integer value representing the time in hundredths of a second since some epoch. The returned string will display the time in days, hours, and seconds format according to the value of the TimeTicks argument. =head1 EXPORTS =over =item Default INTEGER, INTEGER32, OCTET_STRING, NULL, OBJECT_IDENTIFIER, IPADDRESS, COUNTER, COUNTER32, GAUGE, GAUGE32, UNSIGNED32, TIMETICKS, OPAQUE, COUNTER64, NOSUCHOBJECT, NOSUCHINSTANCE, ENDOFMIBVIEW, snmp_event_loop =item Exportable INTEGER, INTEGER32, OCTET_STRING, NULL, OBJECT_IDENTIFIER, SEQUENCE, IPADDRESS, COUNTER, COUNTER32, GAUGE, GAUGE32, UNSIGNED32, TIMETICKS, OPAQUE, COUNTER64, NOSUCHOBJECT, NOSUCHINSTANCE, ENDOFMIBVIEW, GET_REQUEST, GET_NEXT_REQUEST, GET_RESPONSE, SET_REQUEST, TRAP, GET_BULK_REQUEST, INFORM_REQUEST, SNMPV2_TRAP, COLD_START, WARM_START, LINK_DOWN, LINK_UP, AUTHENTICATION_FAILURE, EGP_NEIGHBOR_LOSS, ENTERPRISE_SPECIFIC, SNMP_VERSION_1, SNMP_VERSION_2C, SNMP_PORT, SNMP_TRAP_PORT, snmp_debug, snmp_event_loop, oid_context_match, oid_lex_sort, ticks_to_time =item Tags =over =item :asn1 INTEGER, INTEGER32, OCTET_STRING, NULL, OBJECT_IDENTIFIER, SEQUENCE, IPADDRESS, COUNTER, COUNTER32, GAUGE, GAUGE32, UNSIGNED32, TIMETICKS, OPAQUE, COUNTER64, NOSUCHOBJECT, NOSUCHINSTANCE, ENDOFMIBVIEW, GET_REQUEST, GET_NEXT_REQUEST, GET_RESPONSE, SET_REQUEST, TRAP, GET_BULK_REQUEST, INFORM_REQUEST, SNMPV2_TRAP =item :generictrap COLD_START, WARM_START, LINK_DOWN, LINK_UP, AUTHENTICATION_FAILURE, EGP_NEIGHBOR_LOSS, ENTERPRISE_SPECIFIC =item :snmp SNMP_VERSION_1, SNMP_VERSION_2C, SNMP_PORT, SNMP_TRAP_PORT, snmp_debug, snmp_event_loop, oid_context_match, oid_lex_sort, ticks_to_time =item :ALL All of the above exportable items. =back =back =head1 EXAMPLES =head2 Blocking get-request for sysUpTime This example gets the sysUpTime from a remote host: #! /usr/local/bin/perl use strict; use vars qw($hostname $community $port $session $error $response); use Net::SNMP; $hostname = shift || 'localhost'; $community = shift || 'public'; $port = shift || 161; ($session, $error) = Net::SNMP->session( -hostname => $hostname, -community => $community, -port => $port ); if (!defined($session)) { printf("ERROR: %s.\n", $error); exit 1; } my $sysUpTime = '1.3.6.1.2.1.1.3.0'; if (!defined($response = $session->get_request($sysUpTime))) { printf("ERROR: %s.\n", $session->error); $session->close; exit 1; } printf("sysUpTime for host '%s' is %s\n", $hostname, $response->{$sysUpTime} ); $session->close; exit 0; =head2 Blocking set-request of sysContact This example sets the sysContact information on the remote host to "Help Desk": #! /usr/local/bin/perl use strict; use vars qw($hostname $community $port $session $error $response); use Net::SNMP; $hostname = shift || 'localhost'; $community = shift || 'private'; $port = shift || 161; ($session, $error) = Net::SNMP->session( -hostname => $hostname, -community => $community, -port => $port ); if (!defined($session)) { printf("ERROR: %s.\n", $error); exit 1; } my $sysContact = '1.3.6.1.2.1.1.4.0'; my $contact = 'Help Desk'; $response = $session->set_request($sysContact, OCTET_STRING, $contact); if (!defined($response)) { printf("ERROR: %s.\n", $session->error); $session->close; exit 1; } printf("sysContact for host '%s' set to '%s'\n", $hostname, $response->{$sysContact} ); $session->close; exit 0; =head2 Non-blocking get-request for sysUpTime on multiple hosts This example polls several hosts for their sysUpTime using non-blocking objects and reports a warning if this value is less than the value from the last poll: #! /usr/local/bin/perl use strict; use vars qw(@hosts @sessions $polls $last_poll_time $sleep); use Net::SNMP qw(snmp_event_loop ticks_to_time); # List of hosts to poll @hosts = qw(1.1.1.1 1.1.1.2 localhost); # Poll interval (in seconds). This value should be greater than # the number of retries times the timeout value. my $interval = 60; # Maximum number of polls my $max_polls = 10; # Create a session for each host foreach (@hosts) { my ($session, $error) = Net::SNMP->session( -hostname => $_, -nonblocking => 0x1, # Create non-blocking objects -translate => 0x0 # Turn off so sysUpTime is numeric ); if (!defined($session)) { printf("ERROR: %s.\n", $error); foreach (@sessions) { $_->[0]->close; } exit 1; } # Create an array of arrays which contain the new object, # and the last sysUpTime. push(@sessions, [$session, 0]); } my $sysUpTime = '1.3.6.1.2.1.1.3.0'; while (++$polls <= $max_polls) { $last_poll_time = time(); # Queue each of the queries for sysUpTime foreach (@sessions) { $_->[0]->get_request( -varbindlist => [$sysUpTime], -callback => [\&validate_sysUpTime_cb, \$_->[1]] ); } # Enter the event loop snmp_event_loop(); # Sleep until the next poll time $sleep = $interval - (time() - $last_poll_time); if (($sleep < 1) || ($polls >= $max_polls)) { next; } sleep($sleep); print "\n"; } # Not necessary, but it is nice to clean up after yourself foreach (@sessions) { $_->[0]->close; } exit 0; sub validate_sysUpTime_cb { my ($this, $last_uptime) = @_; if (!defined($this->var_bind_list)) { printf("%-15s ERROR: %s\n", $this->hostname, $this->error); } else { my $uptime = $this->var_bind_list->{$sysUpTime}; if ($uptime < ${$last_uptime}) { printf("%-15s WARNING: %s is less than %s\n", $this->hostname, ticks_to_time($uptime), ticks_to_time(${$last_uptime}) ); } else { printf("%-15s Ok (%s)\n", $this->hostname, ticks_to_time($uptime) ); } # Store the new sysUpTime ${$last_uptime} = $uptime; } $this->error_status; } =head1 AUTHOR David M. Town =head1 ACKNOWLEDGMENTS The original concept for this module was based on F written by Simon Leinen . The Abstract Syntax Notation One (ASN.1) encode and decode methods were derived by example from the CMU SNMP package whose copyright follows: Copyright (c) 1988, 1989, 1991, 1992 by Carnegie Mellon University. All rights reserved. =head1 COPYRIGHT Copyright (c) 1998-2000 David M. Town. All rights reserved. This program is free software; you may redistribute it and/or modify it under the same terms as Perl itself. cisco-auditing-tool-1.0/lib/Net/.svn/0000755000000000000000000000000012046511414016103 5ustar rootrootcisco-auditing-tool-1.0/lib/Net/.svn/entries0000444000000000000000000000122112046511414017471 0ustar rootroot10 dir 1733 svn+ssh://dookie@10.0.0.12/var/svn/backtrack/microverse/c/cisco-auditing-tool/source-cisco-auditing-tool-1.0-bt1/var/backtrack/sources/cisco-auditing-tool/1.0/bt1/upstream-sources/cisco-auditing-tool/lib/Net svn+ssh://dookie@10.0.0.12/var/svn/backtrack 2011-04-18T09:02:05.482722Z 327 emgent d9273255-a111-4fa6-bf0a-919607b5ba98 Telnet.pm file 2011-08-26T04:18:02.830183Z 66b8bf1b6704207cc066f5d5dd6c8a63 2011-04-18T09:02:05.482722Z 327 emgent 109100 SNMP.pm file 2011-08-26T04:18:02.830183Z 50443297955c1ddac962bec7582ceb8a 2011-04-18T09:02:05.482722Z 327 emgent 136795 cisco-auditing-tool-1.0/lib/Net/.svn/text-base/0000755000000000000000000000000012046511414017777 5ustar rootrootcisco-auditing-tool-1.0/lib/Net/.svn/text-base/SNMP.pm.svn-base0000444000000000000000000041313312046511414022632 0ustar rootroot# -*- mode: perl -*- # ============================================================================ package Net::SNMP; # $Id: SNMP.pm,v 3.0.1.1 2000/01/01 17:59:46 dtown Exp $ # $Source: /us/dtown/Projects/Net-SNMP/SNMP.pm,v $ # The module Net::SNMP implements an object oriented interface to the Simple # Network Management Protocol. Perl applications can use the module to # retrieve or update information on a remote host using the SNMP protocol. # Both SNMPv1 and SNMPv2c (Community-Based SNMPv2) are supported by the # module. The Net::SNMP module assumes that the user has a basic # understanding of the Simple Network Management Protocol and related # network management concepts. # Copyright (c) 1998-2000 David M. Town . # All rights reserved. # This program is free software; you may redistribute it and/or modify it # under the same terms as Perl itself. # ============================================================================ ## Global variables use vars qw( @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS @ASN1 @ASN1_PDU @GENERICTRAP @SNMP $DEBUG $FSM $REQUEST_ID $SOCKET $VERSION ); ## Version of Net::SNMP module $Net::SNMP::VERSION = 3.01; use strict; ## Required version of Perl require 5.003; ## Handle exporting of symbols use Exporter(); @ISA = qw(Exporter); @ASN1 = qw( INTEGER INTEGER32 OCTET_STRING NULL OBJECT_IDENTIFIER IPADDRESS COUNTER COUNTER32 GAUGE GAUGE32 UNSIGNED32 TIMETICKS OPAQUE COUNTER64 NOSUCHOBJECT NOSUCHINSTANCE ENDOFMIBVIEW ); @ASN1_PDU = qw( GET_REQUEST GET_NEXT_REQUEST GET_RESPONSE SET_REQUEST TRAP GET_BULK_REQUEST INFORM_REQUEST SNMPV2_TRAP ); @GENERICTRAP = qw( COLD_START WARM_START LINK_DOWN LINK_UP AUTHENTICATION_FAILURE EGP_NEIGHBOR_LOSS ENTERPRISE_SPECIFIC ); @SNMP = qw( SNMP_VERSION_1 SNMP_VERSION_2C SNMP_PORT SNMP_TRAP_PORT snmp_debug oid_context_match oid_lex_sort ticks_to_time ); @EXPORT = (@ASN1, 'snmp_event_loop'); @EXPORT_OK = (@ASN1_PDU, @GENERICTRAP, @SNMP, 'SEQUENCE', 'snmp_one_event'); %EXPORT_TAGS = ( asn1 => [@ASN1, @ASN1_PDU, 'SEQUENCE'], generictrap => [@GENERICTRAP], snmp => [@SNMP, 'snmp_event_loop'], ALL => [@EXPORT, @EXPORT_OK] ); ## Import socket() defines and structure manipulators use Socket qw(PF_INET SOCK_DGRAM inet_aton inet_ntoa sockaddr_in); sub IPPROTO_UDP() { 17 } ## ASN.1 Basic Encoding Rules type definitions sub INTEGER() { 0x02 } # INTEGER sub INTEGER32() { 0x02 } # Integer32 - SNMPv2c sub OCTET_STRING() { 0x04 } # OCTET STRING sub NULL() { 0x05 } # NULL sub OBJECT_IDENTIFIER() { 0x06 } # OBJECT IDENTIFIER sub SEQUENCE() { 0x30 } # SEQUENCE sub IPADDRESS() { 0x40 } # IpAddress sub COUNTER() { 0x41 } # Counter sub COUNTER32() { 0x41 } # Counter32 - SNMPv2c sub GAUGE() { 0x42 } # Gauge sub GAUGE32() { 0x42 } # Gauge32 - SNMPv2c sub UNSIGNED32() { 0x42 } # Unsigned32 - SNMPv2c sub TIMETICKS() { 0x43 } # TimeTicks sub OPAQUE() { 0x44 } # Opaque sub COUNTER64() { 0x46 } # Counter64 - SNMPv2c sub NOSUCHOBJECT() { 0x80 } # noSuchObject - SNMPv2c sub NOSUCHINSTANCE() { 0x81 } # noSuchInstance - SNMPv2c sub ENDOFMIBVIEW() { 0x82 } # endOfMibView - SNMPv2c sub GET_REQUEST() { 0xa0 } # GetRequest-PDU sub GET_NEXT_REQUEST() { 0xa1 } # GetNextRequest-PDU sub GET_RESPONSE() { 0xa2 } # GetResponse-PDU sub SET_REQUEST() { 0xa3 } # SetRequest-PDU sub TRAP() { 0xa4 } # Trap-PDU sub GET_BULK_REQUEST() { 0xa5 } # GetBulkRequest-PDU - SNMPv2c sub INFORM_REQUEST() { 0xa6 } # InformRequest-PDU - SNMPv2c sub SNMPV2_TRAP() { 0xa7 } # SNMPv2-Trap-PDU - SNMPv2c ## SNMP generic definitions sub SNMP_VERSION_1() { 0x00 } # RFC 1157 SNMP sub SNMP_VERSION_2C() { 0x01 } # RFCs 1901, 1905, and 1906 SNMPv2c sub SNMP_PORT() { 161 } # RFC 1157 standard UDP port for PDUs sub SNMP_TRAP_PORT() { 162 } # RFC 1157 standard UDP port for Trap-PDUs ## RFC 1157 generic-trap definitions sub COLD_START() { 0 } # coldStart(0) sub WARM_START() { 1 } # warmStart(1) sub LINK_DOWN() { 2 } # linkDown(2) sub LINK_UP() { 3 } # linkUp(3) sub AUTHENTICATION_FAILURE() { 4 } # authenticationFailure(4) sub EGP_NEIGHBOR_LOSS() { 5 } # egpNeighborLoss(5) sub ENTERPRISE_SPECIFIC() { 6 } # enterpriseSpecific(6) ## Default, minimum, and maximum values sub DEFAULT_HOSTNAME() { 'localhost' } sub DEFAULT_COMMUNITY() { 'public' } sub DEFAULT_MTU() { 484 } # RFC 1157 maximum size in octets sub DEFAULT_TIMEOUT() { 5.0 } # Timeout period for UDP in seconds sub DEFAULT_RETRIES() { 1 } # Number of retransmissions sub MINIMUM_MTU() { 30 } sub MINIMUM_TIMEOUT() { 1.0 } sub MINIMUM_RETRIES() { 0 } sub MAXIMUM_MTU() { 65535 } sub MAXIMUM_TIMEOUT() { 60.0 } sub MAXIMUM_RETRIES() { 20 } sub TRUE() { 0x1 } sub FALSE() { 0x0 } ## Intialize global variables sub BEGIN { # Import symbol generating function use Symbol qw(gensym); $DEBUG = FALSE; $FSM = undef; $REQUEST_ID = int(rand 0xff) + (time() & 0xff); $SOCKET = gensym(); } # [public methods] ----------------------------------------------------------- sub new { my ($class, %argv) = @_; # Create a new data structure for the object my $this = bless { '_buffer', => "\0" x DEFAULT_MTU, '_callback' => undef, '_community' => DEFAULT_COMMUNITY, '_error' => undef, '_error_index' => 0, '_error_status' => 0, '_fsm' => undef, '_hostname' => DEFAULT_HOSTNAME, '_leading_dot' => FALSE, '_mtu' => DEFAULT_MTU, '_nonblocking' => FALSE, '_port' => SNMP_PORT, '_request_id' => $REQUEST_ID++, '_retries' => DEFAULT_RETRIES, '_sockaddr' => undef, '_socket' => undef, '_type' => undef, '_timeout' => DEFAULT_TIMEOUT, '_translate' => TRUE, '_var_bind_list' => undef, '_version' => SNMP_VERSION_1 }, $class; # Validate the passed arguments foreach (keys %argv) { if (/^-?community$/i) { if ($argv{$_} eq '') { $this->_object_error('Empty community specified'); } else { $this->{'_community'} = $argv{$_}; } } elsif (/^-?debug$/i) { $this->debug($argv{$_}); } elsif (/^-?hostname$/i) { if ($argv{$_} eq '') { $this->_object_error('Empty hostname specified'); } else { $this->{'_hostname'} = $argv{$_}; } } elsif (/^-?mtu$/i) { $this->mtu($argv{$_}); } elsif (/^-?nonblocking$/i) { if ($argv{$_}) { $this->{'_nonblocking'} = TRUE; } else { $this->{'_nonblocking'} = FALSE; } } elsif (/^-?port$/i) { if ($argv{$_} !~ /^\d+$/) { $this->_object_error('Expected numeric port number'); } else { $this->{'_port'} = $argv{$_}; } } elsif (/^-?retries$/i) { $this->retries($argv{$_}); } elsif (/^-?timeout$/i) { $this->timeout($argv{$_}); } elsif (/^-?translate$/i) { $this->translate($argv{$_}); } elsif (/^-?version$/i) { $this->version($argv{$_}); } else { $this->_object_error("Invalid argument '%s'", $_); } if (defined($this->{'_error'})) { return wantarray ? (undef, $this->{'_error'}) : undef; } } # Create a global Net:SNMP::FSM object (if not created) when the # object has the "non-blocking" flag set, and store a reference # to the Finite State Machine (FSM) within the object. if ($this->{'_nonblocking'}) { if ((!defined($FSM)) || (ref($FSM) ne 'Net::SNMP::FSM')) { if (!defined($FSM = Net::SNMP::FSM->new())) { # You should never see this error! $this->_object_error( "Unable to create Net::SNMP Finite State Machine object" ); return wantarray ? (undef, $this->{'_error'}) : undef; } } $this->{'_fsm'} = $FSM; } # Return the object and empty error message (in list context) wantarray ? ($this, '') : $this; } sub open { my $this = shift; my ($host_addr, $proto) = (undef, undef); # Resolve the hostname to an IP address if (!defined($host_addr = inet_aton($this->hostname))) { return $this->_object_error( "Unable to resolve hostname '%s'", $this->hostname ); } # Pack the address and port information $this->{'_sockaddr'} = sockaddr_in($this->{'_port'}, $host_addr); # Get the protocol number for UDP if (!defined($proto = scalar(getprotobyname('udp')))) { $proto = IPPROTO_UDP; } # Open a global UDP socket for the package (if not open), and store # a reference to the socket within the object. if (!fileno($SOCKET)) { if (!socket($SOCKET, PF_INET, SOCK_DGRAM, $proto)) { return $this->_object_error("socket(): %s", $!); } } $this->{'_socket'} = $SOCKET; TRUE; } sub close { my $this = shift; # Clear all of the buffers and errors $this->_object_clear_buffer; $this->_object_clear_var_bind_list; $this->_object_clear_error; # Clear the socket refence so that we can tell that this particular # object has been closed. $this->{'_socket'} = undef; TRUE; } sub session { my $class = shift; # This is a convenience method (also present for backwards compatiblity), # that just combines the new() and the open() methods into one method. my ($this, $error) = $class->new(@_); if (defined($this)) { if (!defined($this->open)) { return wantarray ? (undef, $this->error) : undef; } } wantarray ? ($this, $error) : $this; } sub snmp_event_loop { ref($FSM) eq 'Net::SNMP::FSM' ? $FSM->event_loop : undef; } sub snmp_one_event { ref($FSM) eq 'Net::SNMP::FSM' ? $FSM->one_event : undef; } sub get_request { my $this = shift; # Handle passed arguments according to "blocking" mode if ($this->{'_nonblocking'}) { my %argv = @_; my @var_bind_list = (); # Validate the passed arguments foreach (keys %argv) { if (/^-?callback$/i) { if (!defined($this->_object_add_callback($argv{$_}))) { return $this->_object_error; } } elsif (/^-?varbindlist$/i) { if (ref($argv{$_}) ne 'ARRAY') { return $this->_object_error( 'Expected array reference for variable-bindings' ); } else { @var_bind_list = @{$argv{$_}}; } } else { return $this->_object_error("Invalid argument '%s'", $_); } } # Encode and queue the message if (!defined($this->_snmp_encode_get_request(@var_bind_list))) { return $this->_object_encode_error; } $this->_object_queue_message; } else { # Encode, send and wait, and decode the message if (!defined($this->_snmp_encode_get_request(@_))) { return $this->_object_encode_error; } if (!defined($this->_udp_send_message)) { return $this->_object_decode_error; } $this->_snmp_validate_get_response; } } sub get_next_request { my $this = shift; # Handle passed arguments according to "blocking" mode if ($this->{'_nonblocking'}) { my %argv = @_; my @var_bind_list = (); # Validate the passed arguments foreach (keys %argv) { if (/^-?callback$/i) { if (!defined($this->_object_add_callback($argv{$_}))) { return $this->_object_error; } } elsif (/^-?varbindlist$/i) { if (ref($argv{$_}) ne 'ARRAY') { return $this->_object_error( 'Expected array reference for variable-bindings' ); } else { @var_bind_list = @{$argv{$_}}; } } else { return $this->_object_error("Invalid argument '%s'", $_); } } # Encode and queue the message if (!defined($this->_snmp_encode_get_next_request(@var_bind_list))) { return $this->_object_encode_error; } $this->_object_queue_message; } else { # Encode, send and wait, and decode the message if (!defined($this->_snmp_encode_get_next_request(@_))) { return $this->_object_encode_error; } if (!defined($this->_udp_send_message)) { return $this->_object_decode_error; } $this->_snmp_validate_get_response; } } sub set_request { my $this = shift; # Handle passed arguments according to "blocking" mode if ($this->{'_nonblocking'}) { my %argv = @_; my @var_bind_list = (); # Validate the passed arguments foreach (keys %argv) { if (/^-?callback$/i) { if (!defined($this->_object_add_callback($argv{$_}))) { return $this->_object_error; } } elsif (/^-?varbindlist$/i) { if (ref($argv{$_}) ne 'ARRAY') { return $this->_object_error( 'Expected array reference for variable-bindings' ); } else { @var_bind_list = @{$argv{$_}}; } } else { return $this->_object_error("Invalid argument '%s'", $_); } } # Encode and queue the message if (!defined($this->_snmp_encode_set_request(@var_bind_list))) { return $this->_object_encode_error; } $this->_object_queue_message; } else { # Encode, send and wait, and decode the message if (!defined($this->_snmp_encode_set_request(@_))) { return $this->_object_encode_error; } if (!defined($this->_udp_send_message)) { return $this->_object_decode_error; } $this->_snmp_validate_get_response; } } sub trap { my ($this, %argv) = @_; # Clear any previous error message $this->_object_clear_error; # Use Sys:Hostname to determine the IP address of the client sending # the trap. Only require the module for Trap-PDUs. use Sys::Hostname(); # Setup default values for the Trap-PDU by creating new entries in # the Net::SNMP object. # Use iso.org.dod.internet.private.enterprises for the default enterprise. $this->{'_enterprise'} = '1.3.6.1.4.1'; # Create an entry for the agent-addr (we will fill it in below if # if the user does not specify an address) $this->{'_agent_addr'} = undef; # Use enterpriseSpecific(6) for the generic-trap type. $this->{'_generic_trap'} = ENTERPRISE_SPECIFIC; # Set the specific-trap type to 0. $this->{'_specific_trap'} = 0; # Use the "uptime" of the script for the time-stamp. $this->{'_time_stamp'} = ((time() - $^T) * 100); # Create a local copy of the VarBindList. my @var_bind_list = (); # Validate the passed arguments foreach (keys %argv) { if (/^-?enterprise$/i) { if ($argv{$_} !~ /^\.?\d+\.\d+(\.\d+)*/) { return $this->_object_error( 'Expected enterprise as OBJECT IDENTIFIER in dotted notation' ); } else { $this->{'_enterprise'} = $argv{$_}; } } elsif (/^-?agentaddr$/i) { if ($argv{$_} !~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/) { return $this->_object_error( 'Expected agent-addr in dotted notation' ); } else { $this->{'_agent_addr'} = $argv{$_}; } } elsif (/^-?generictrap$/i) { if ($argv{$_} !~ /^\d+$/) { return $this->_object_error( 'Expected numeric generic-trap type' ); } else { $this->{'_generic_trap'} = $argv{$_}; } } elsif (/^-?specifictrap$/i) { if ($argv{$_} !~ /^\d+$/) { return $this->_object_error( 'Expected numeric specific-trap type' ); } else { $this->{'_specific_trap'} = $argv{$_}; } } elsif (/^-?timestamp$/i) { if ($argv{$_} !~ /^\d+$/) { return $this->_object_error('Expected numeric time-stamp'); } else { $this->{'_time_stamp'} = $argv{$_}; } } elsif (/^-?varbindlist$/i) { if (ref($argv{$_}) ne 'ARRAY') { return $this->_object_error( 'Expected array reference for variable-bindings' ); } else { @var_bind_list = @{$argv{$_}}; } } else { return $this->_object_error("Invalid argument '%s'", $_); } } # If the user did not specify the agent-addr, get local the address # of the client sending the trap. if (!defined($this->{'_agent_addr'})) { eval { $this->{'_agent_addr'} = inet_ntoa( scalar(gethostbyname(&Sys::Hostname::hostname())) ); }; if ($@ ne '') { return $this->_object_encode_error( 'Unable to resolve local agent-addr' ); } } if (!defined($this->_snmp_encode_trap(@var_bind_list))) { return $this->_object_encode_error; } # Handle the sending of the message according to "blocking" mode if ($this->{'_nonblocking'}) { $this->_object_queue_message; } else { $this->_udp_send_buffer; } } sub get_bulk_request { my ($this, %argv) = @_; # Clear any previous error message which also clears the # '_error_status' and '_error_index' so that we can use them # to hold non-repeaters and max-repetitions. $this->_object_clear_error; # Validate the SNMP version if ($this->version != SNMP_VERSION_2C) { return $this->_object_error( 'GetBulkRequest-PDU only supported with SNMPv2c' ); } # Create a local copy of the VarBindList. my @var_bind_list = (); # Validate the passed arguments foreach (keys %argv) { if (/^-?nonrepeaters$/i) { if ($argv{$_} !~ /^\d+$/) { return $this->_object_error( 'Expected numeric non-repeaters value' ); } elsif ($argv{$_} > 2147483647) { return $this->_object_error( 'Exceeded maximum non-repeaters value [2147483647]' ); } else { # We cheat a little here... $this->{'_error_status'} = $argv{$_}; } } elsif (/^-?maxrepetitions$/i) { if ($argv{$_} !~ /^\d+$/) { return $this->_object_error( 'Expected numeric max-repetitions value' ); } elsif ($argv{$_} > 2147483647) { return $this->_object_error( 'Exceeded maximum max-repetitions value [2147483647]' ); } else { # We cheat a little here... $this->{'_error_index'} = $argv{$_}; } } elsif (/^-?varbindlist$/i) { if (ref($argv{$_}) ne 'ARRAY') { return $this->_object_error( 'Expected array reference for variable-bindings' ); } else { @var_bind_list = @{$argv{$_}}; } } elsif ((/^-?callback$/i) && ($this->{'_nonblocking'})) { if (!defined($this->_object_add_callback($argv{$_}))) { return $this->_object_error; } } else { return $this->_object_error("Invalid argument '%s'", $_); } } if ($this->{'_error_status'} > scalar(@var_bind_list)) { return $this->_object_error( 'Non-repeaters greater than the number of variable-bindings' ); } if (($this->{'_error_status'} == scalar(@var_bind_list)) && ($this->{'_error_index'} != 0)) { return $this->_object_error( 'Non-repeaters equals the number of variable-bindings and ' . 'max-repetitions is not equal to zero' ); } if (!defined($this->_snmp_encode_get_bulk_request(@var_bind_list))) { return $this->_object_encode_error; } # Handle the sending of the message according to "blocking" mode if ($this->{'_nonblocking'}) { $this->_object_queue_message; } else { if (!defined($this->_udp_send_message)) { return $this->_object_decode_error; } $this->_snmp_validate_get_response; } } sub inform_request { my $this = shift; # Clear any previous error message $this->_object_clear_error; # Validate the SNMP version if ($this->version != SNMP_VERSION_2C) { return $this->_object_error( 'InformRequest-PDU only supported with SNMPv2c' ); } # Handle passed arguments according to "blocking" mode if ($this->{'_nonblocking'}) { my %argv = @_; my @var_bind_list = (); # Validate the passed arguments foreach (keys %argv) { if (/^-?callback$/i) { if (!defined($this->_object_add_callback($argv{$_}))) { return $this->_object_error; } } elsif (/^-?varbindlist$/i) { if (ref($argv{$_}) ne 'ARRAY') { return $this->_object_error( 'Expected array reference for variable-bindings' ); } else { @var_bind_list = @{$argv{$_}}; } } else { return $this->_object_error("Invalid argument '%s'", $_); } } # Encode and queue the message if (!defined($this->_snmp_encode_inform_request(@var_bind_list))) { return $this->_object_error; } $this->_object_queue_message; } else { # Encode, send/wait, and decode the message if (!defined($this->_snmp_encode_inform_request(@_))) { return $this->_object_encode_error; } if (!defined($this->_udp_send_message)) { return $this->_object_decode_error; } $this->_snmp_validate_get_response; } } sub snmpv2_trap { my $this = shift; # Clear any previous error message $this->_object_clear_error; # Validate the SNMP version if ($this->version != SNMP_VERSION_2C) { return $this->_object_error( 'SNMPv2-Trap-PDU only supported with SNMPv2c' ); } # Encode the message if (!defined($this->_snmp_encode_v2_trap(@_))) { return $this->_object_encode_error; } if ($this->{'_nonblocking'}) { # Queue the message $this->_object_queue_message; } else { # Send the message $this->_udp_send_buffer; } } sub get_table { my $this = shift; my ($base_oid, $repeat_cnt, $table) = (undef, 0, undef, undef); my ($result, $next_oid) = (undef, undef); # Use get-next-requests until the response is not a subtree of the # base OBJECT IDENTIFIER. Return the table only if there are no # errors other than a noSuchName(2) error since the table could # be at the end of the tree. Also return the table when the value # of the OID equals endOfMibView(2) when using SNMPv2c. # Handle passed argument according to "blocking" mode if ($this->{'_nonblocking'}) { my %argv = @_; # Validate the passed arguments foreach (keys %argv) { if (/^-?callback$/i) { if (!defined($this->_object_add_callback($argv{$_}))) { return $this->_object_error; } } elsif (/^-?baseoid$/i) { if ($argv{$_} !~ /^\.?\d+\.\d+(\.\d+)*/) { return $this->_object_error( 'Expected base OBJECT IDENTIFIER in dotted notation' ); } else { $base_oid = $argv{$_}; } } else { return $this->_object_error("Invalid argument '%s'", $_); } } # Create table of values that need passed along with the # callbacks. This just prevents a big argument list. %argv = ( 'base_oid' => $base_oid, 'callback' => $this->{'_callback'}, 'repeat_cnt' => 0, 'table' => undef, ); # Queue up the get-next-request, overriding the user-specified # callback. We have the original in the arguments. $this->get_next_request( -callback => [\&_object_get_table_cb, \%argv], -varbindlist => [$base_oid] ); } else { $next_oid = $base_oid = shift(@_); do { if (defined($result)) { if (!exists($table->{$next_oid})) { $table->{$next_oid} = $result->{$next_oid}; } elsif ((($result->{$next_oid} eq 'endOfMibView') || # translate ($this->error_status == ENDOFMIBVIEW)) && # !translate ($this->version == SNMP_VERSION_2C)) { if (!defined($table)) { $this->_object_decode_error('Requested table is empty'); } return ($this->{'_var_bind_list'} = $table); } else { $repeat_cnt++; } } # Check to make sure that the remote host does not respond # incorrectly causing the get-next-requests to loop forever. if ($repeat_cnt > 5) { return $this->_object_decode_error( 'Loop detected with table on remote host' ); } if (!defined($result = $this->get_next_request($next_oid))) { # Check for noSuchName(2) error if ($this->error_status == 2) { if (!defined($table)) { $this->_object_decode_error('Requested table is empty'); } return ($this->{'_var_bind_list'} = $table); } else { return $this->_object_decode_error; } } ($next_oid) = keys(%{$result}); } while (_asn1_oid_context_match($base_oid, $next_oid)); if (!defined($table)) { $this->_object_decode_error('Requested table is empty'); } $this->{'_var_bind_list'} = $table; } } sub error { defined($_[0]->{'_error'}) ? $_[0]->{'_error'} : ''; } sub version { my ($this, $version) = @_; # Clear any previous error message $this->_object_clear_error; # Allow the user some flexability my $supported = { '1' => SNMP_VERSION_1, 'v1' => SNMP_VERSION_1, 'snmpv1' => SNMP_VERSION_1, '2' => SNMP_VERSION_2C, '2c' => SNMP_VERSION_2C, 'v2' => SNMP_VERSION_2C, 'v2c' => SNMP_VERSION_2C, 'snmpv2' => SNMP_VERSION_2C, 'snmpv2c' => SNMP_VERSION_2C }; if (@_ == 2) { if (exists($supported->{lc($version)})) { $this->{'_version'} = $supported->{lc($version)}; } else { return $this->_object_error( "Unknown or invalid SNMP version [%s]", $version ); } } $this->{'_version'}; } sub hostname { $_[0]->{'_hostname'}; } sub _request_id { $_[0]->{'_request_id'}; # Semi-private method } sub error_status { $_[0]->{'_error_status'}; } sub error_index { $_[0]->{'_error_index'}; } sub var_bind_list { $_[0]->{'_var_bind_list'}; } sub timeout { my ($this, $timeout) = @_; # Clear any previous error message $this->_object_clear_error; if (@_ == 2) { if (($timeout >= MINIMUM_TIMEOUT) && ($timeout <= MAXIMUM_TIMEOUT)) { $this->{'_timeout'} = $timeout; } else { return $this->_object_encode_error( "Timeout out of range [%03.01f - %03.01f seconds]", MINIMUM_TIMEOUT, MAXIMUM_TIMEOUT ); } } $this->{'_timeout'}; } sub retries { my ($this, $retries) = @_; # Clear any previous error message $this->_object_clear_error; if (@_ == 2) { if (($retries >= MINIMUM_RETRIES) && ($retries <= MAXIMUM_RETRIES)) { $this->{'_retries'} = $retries; } else { return $this->_object_encode_error( "Retries out of range [%d - %d]", MINIMUM_RETRIES, MAXIMUM_RETRIES ); } } $this->{'_retries'}; } sub mtu { my ($this, $mtu) = @_; # Clear any previous error message $this->_object_clear_error; if (@_ == 2) { if (($mtu >= MINIMUM_MTU) && ($mtu <= MAXIMUM_MTU )) { $this->{'_mtu'} = $mtu; } else { return $this->_object_encode_error( "MTU out of range [%d - %d octets]", MINIMUM_MTU, MAXIMUM_MTU ); } } $this->{'_mtu'}; } sub translate { my ($this, $flag) = @_; if (@_ == 2) { if ($flag) { $this->{'_translate'} = TRUE; } else { $this->{'_translate'} = FALSE; } } $this->{'_translate'}; } sub debug { my ($this, $flag) = @_; if (@_ == 2) { if ($flag) { $Net::SNMP::DEBUG = TRUE; } else { $Net::SNMP::DEBUG = FALSE; } } $Net::SNMP::DEBUG; } sub END { if (defined($SOCKET)) { if (fileno($SOCKET)) { CORE::close($SOCKET); } } } ## Utility functions sub snmp_debug($) { &Net::SNMP::debug(undef, $_[0]); } sub oid_context_match($$) { &Net::SNMP::_asn1_oid_context_match($_[0], $_[1]); } sub oid_lex_sort(@) { &Net::SNMP::_asn1_oid_lex_sort(@_); } sub ticks_to_time($) { &Net::SNMP::_asn1_ticks_to_time($_[0]); } # [private methods] ---------------------------------------------------------- ### ## Simple Network Managment Protocol (SNMP) encode methods ### sub _snmp_encode_get_request { my $this = shift; # Clear any previous error message $this->_object_clear_error; # Check for a valid VarBindList if (@_ < 1) { return $this->_snmp_encode_error('VarBindList is empty'); } $this->_snmp_encode(GET_REQUEST, $this->_snmp_create_oid_null_pairs(@_)); } sub _snmp_encode_get_next_request { my $this = shift; # Clear any previous error message $this->_object_clear_error; # Check for a valid VarBindList if (@_ < 1) { return $this->_snmp_encode_error('VarBindList is empty'); } $this->_snmp_encode( GET_NEXT_REQUEST, $this->_snmp_create_oid_null_pairs(@_) ); } sub _snmp_encode_get_response { my $this = shift; # Clear any previous error message $this->_object_clear_error; $this->_snmp_encode_error('GetResponse-PDU not supported'); } sub _snmp_encode_set_request { my $this = shift; # Clear any previous error message $this->_object_clear_error; # Check for a valid VarBindList if (@_ < 1) { return $this->_snmp_encode_error('VarBindList is empty'); } $this->_snmp_encode(SET_REQUEST, $this->_snmp_create_oid_value_pairs(@_)); } sub _snmp_encode_trap { my $this = shift; # Clear any previous error message $this->_object_clear_error; $this->_snmp_encode(TRAP, $this->_snmp_create_oid_value_pairs(@_)); } sub _snmp_encode_get_bulk_request { my $this = shift; # DO NOT clear any previous error message or the non-repeaters # and the max-repetitions will be reset! # Check for a valid VarBindList if (@_ < 1) { return $this->_snmp_encode_error('VarBindList is empty'); } $this->_snmp_encode( GET_BULK_REQUEST, $this->_snmp_create_oid_null_pairs(@_) ); } sub _snmp_encode_inform_request { my $this = shift; # Clear any previous error message $this->_object_clear_error; # Check for a valid VarBindList if (@_ < 1) { return $this->_snmp_encode_error('VarBindList is empty'); } $this->_snmp_encode(INFORM_REQUEST, $this->_snmp_create_oid_value_pairs(@_)); } sub _snmp_encode_v2_trap { my $this = shift; # Clear any previous error message $this->_object_clear_error; # Check for a valid VarBindList (or is that legal with a snmpV2-trap?) if (@_ < 1) { return $this->_snmp_encode_error('VarBindList is empty'); } $this->_snmp_encode(SNMPV2_TRAP, $this->_snmp_create_oid_value_pairs(@_)); } sub _snmp_encode { my ($this, $type, @var_bind_list) = @_; # Do not do anything if there has already been an error if (defined($this->{'_error'})) { return $this->_snmp_encode_error; } # We need to reset the buffer that might have been defined # from a previous message and clear the var_bind_list. $this->_object_clear_buffer; $this->_object_clear_var_bind_list; $this->_object_clear_leading_dot; # Make sure the PDU type was passed if ((scalar(@_) < 2) || (!defined($type))) { return $this->_snmp_encode_error('No SNMP PDU type defined'); } $this->{'_type'} = $type; # Encode the variable-bindings if (!defined($this->_snmp_encode_var_bind_list(@var_bind_list))) { return $this->_snmp_encode_error; } # Encode the PDU or Trap-PDU if ($this->{'_type'} == TRAP) { if (!defined($this->_snmp_encode_trap_pdu)) { return $this->_snmp_encode_error; } } else { if (!defined($this->_snmp_encode_pdu)) { return $this->_snmp_encode_error; } } # Now wrap the message $this->_snmp_encode_message; } sub _snmp_encode_message { my $this = shift; # We need to encode eveything in reverse order so the # objects end up in the correct place. # Encode the PDU type if (!defined( $this->_asn1_encode($this->{'_type'}, $this->_object_get_buffer) )) { return $this->_snmp_encode_error; } # Encode the community name if (!defined($this->_asn1_encode(OCTET_STRING, $this->{'_community'}))) { return $this->_snmp_encode_error; } # Encode the SNMP version if (!defined($this->_asn1_encode(INTEGER, $this->{'_version'}))) { return $this->_snmp_encode_error; } # Encode the SNMP message SEQUENCE if (!defined($this->_asn1_encode(SEQUENCE, $this->_object_get_buffer))) { return $this->_snmp_encode_error; } # Return the buffer $this->{'_buffer'}; } sub _snmp_encode_pdu { my $this = shift; # We need to encode eveything in reverse order so the # objects end up in the correct place. # Encode the error-index or max-repetitions (GetBulkRequest-PDU) if (!defined($this->_asn1_encode(INTEGER, $this->{'_error_index'}))) { return $this->_snmp_encode_error; } # Encode the error-status or non-repeaters (GetBulkRequest-PDU) if (!defined($this->_asn1_encode(INTEGER, $this->{'_error_status'}))) { return $this->_snmp_encode_error; } # Encode the request-id after storing the value and incrementing # the global value by one. $this->{'_request_id'} = $REQUEST_ID++; if (!defined($this->_asn1_encode(INTEGER, $this->{'_request_id'}))) { return $this->_snmp_encode_error; } # Return the buffer $this->{'_buffer'}; } sub _snmp_encode_trap_pdu { my $this = shift; # We need to encode eveything in reverse order so the # objects end up in the correct place. # Encode the time-stamp if (!defined($this->_asn1_encode(TIMETICKS, $this->{'_time_stamp'}))) { return $this->_snmp_encode_error; } # Encode the specific-trap type if (!defined($this->_asn1_encode(INTEGER, $this->{'_specific_trap'}))) { return $this->_snmp_encode_error; } # Encode the generic-trap type if (!defined($this->_asn1_encode(INTEGER, $this->{'_generic_trap'}))) { return $this->_snmp_encode_error; } # Encode the agent-addr if (!defined($this->_asn1_encode(IPADDRESS, $this->{'_agent_addr'}))) { return $this->_snmp_encode_error; } # Encode the enterprise if (!defined( $this->_asn1_encode(OBJECT_IDENTIFIER, $this->{'_enterprise'}) )) { return $this->_snmp_encode_error; } # Return the buffer $this->{'_buffer'}; } sub _snmp_encode_var_bind_list { my ($this, @var_bind) = @_; my ($type, $value) = (undef, ''); # The passed array is expected to consist of groups of four values # consisting of two sets of ASN.1 types and their values. if ((scalar(@var_bind) % 4)) { return $this->_snmp_encode_error( "Invalid number of VarBind parameters [%d]", scalar(@var_bind) ); } # Encode the objects from the end of the list, so they are wrapped # into the packet as expected. Also, check to make sure that the # OBJECT IDENTIFIER is in the correct place. my $buffer = $this->_object_get_buffer; while (@var_bind) { # Encode the ObjectSyntax $value = pop(@var_bind); $type = pop(@var_bind); if (!defined($this->_asn1_encode($type, $value))) { return $this->_snmp_encode_error; } # Encode the ObjectName $value = pop(@var_bind); $type = pop(@var_bind); if ($type != OBJECT_IDENTIFIER) { return $this->_snmp_encode_error( 'Expected OBJECT IDENTIFIER in VarBindList' ); } if (!defined($this->_asn1_encode($type, $value))) { return $this->_snmp_encode_error; } # Encode the VarBind SEQUENCE if (!defined($this->_asn1_encode(SEQUENCE, $this->_object_get_buffer))) { return $this->_snmp_encode_error; } $buffer = join('', $this->_object_get_buffer, $buffer); } # Encode the VarBindList SEQUENCE if (!defined($this->_asn1_encode(SEQUENCE, $buffer))) { return $this->_snmp_encode_error; } # Return the buffer $this->{'_buffer'}; } sub _snmp_create_oid_null_pairs { my ($this, @oids) = @_; my ($oid) = (undef); my @pairs = (); while (@oids) { $oid = shift(@oids); if ($oid !~ /^\.?\d+\.\d+(\.\d+)*/) { return $this->_snmp_encode_error( 'Expected OBJECT IDENTIFIER in dotted notation' ); } push(@pairs, OBJECT_IDENTIFIER, $oid, NULL, ''); } @pairs; } sub _snmp_create_oid_value_pairs { my ($this, @oid_values) = @_; my ($oid) = (undef); my @pairs = (); if ((scalar(@oid_values) % 3)) { return $this->_snmp_encode_error( 'Expected [OBJECT IDENTIFIER, ASN.1 type, object value] combination' ); } while (@oid_values) { $oid = shift(@oid_values); if ($oid !~ /^\.?\d+\.\d+(\.\d+)*/) { return $this->_snmp_encode_error( 'Expected OBJECT IDENTIFIER in dotted notation' ); } push(@pairs, OBJECT_IDENTIFIER, $oid); push(@pairs, shift(@oid_values), shift(@oid_values)); } @pairs; } sub _snmp_encode_error { my $this = shift; # Clear the buffer $this->_object_clear_buffer; $this->_object_error(@_); } ### ## Simple Network Managment Protocol (SNMP) decode methods ### sub _snmp_decode_get_request { $_[0]->_snmp_decode(GET_REQUEST); } sub _snmp_decode_get_next_request { $_[0]->_snmp_decode(GET_NEXT_REQUEST); } sub _snmp_decode_get_response { $_[0]->_snmp_decode(GET_RESPONSE); } sub _snmp_decode_set_request { $_[0]->_snmp_decode(SET_REQUEST); } sub _snmp_decode_trap { $_[0]->_snmp_decode(TRAP); } sub _snmp_decode_get_bulk_request { $_[0]->_snmp_decode(GET_BULK_REQUEST); } sub _snmp_decode_inform_request { $_[0]->_snmp_decode(INFORM_REQUEST); } sub _snmp_decode_v2_trap { $_[0]->_snmp_decode(SNMPV2_TRAP); } sub _snmp_decode { my ($this, $type) = @_; # First we need to reset the var_bind_list and errors that # might have been set from a previous message. $this->_object_clear_snmp_message; $this->_object_clear_var_bind_list; $this->_object_clear_error; # Define the message type to be decoded, if it was provided if (scalar(@_) > 1) { $this->{'_type'} = $type; } # Decode the message if (!defined($this->_snmp_decode_message)) { return $this->_snmp_decode_error; } # Decode the PDU if ($this->{'_type'} != TRAP) { if (!defined($this->_snmp_decode_pdu)) { return $this->_snmp_decode_error; } } else { if (!defined($this->_snmp_decode_trap_pdu)) { return $this->_snmp_decode_error; } } # Decode the VarBindList $this->_snmp_decode_var_bind_list; } sub _snmp_decode_message { my $this = shift; my $value = undef; # Decode the message SEQUENCE if (!defined($value = $this->_asn1_decode(SEQUENCE))) { return $this->_snmp_decode_error; } if ($value != $this->_object_buffer_length) { return $this->_snmp_decode_error( 'Encoded message length not equal to remaining data length' ); } # Decode the version if (!defined($this->{'_version'} = $this->_asn1_decode(INTEGER))) { return $this->_snmp_decode_error; } # Decode the community if (!defined($this->{'_community'} = $this->_asn1_decode(OCTET_STRING))) { return $this->_snmp_decode_error; } # Decode the PDU type if (!defined($this->{'_type'} = $this->_asn1_decode($this->{'_type'}))) { return $this->_snmp_decode_error; } # Return the remaining buffer $this->{'_buffer'}; } sub _snmp_decode_pdu { my $this = shift; # Decode the request-id if (!defined($this->{'_request_id'} = $this->_asn1_decode(INTEGER))) { return $this->_snmp_decode_error; } # Decode the error-status and error-index if (!defined($this->{'_error_status'} = $this->_asn1_decode(INTEGER))) { $this->{'_error_status'} = 0; return $this->_snmp_decode_error; } if (!defined($this->{'_error_index'} = $this->_asn1_decode(INTEGER))) { $this->{'_error_index'} = 0; return $this->_snmp_decode_error; } # Return the remaining buffer $this->{'_buffer'}; } sub _snmp_decode_trap_pdu { my $this = shift; # Decode the enterprise if (!defined( $this->{'_enterprise'} = $this->_asn1_decode(OBJECT_IDENTIFIER) )) { return $this->_snmp_decode_error; } # Decode the agent-addr if (!defined($this->{'_agent_addr'} = $this->_asn1_decode(IPADDRESS))) { return $this->_snmp_decode_error; } # Decode the generic-trap type if (!defined($this->{'_generic_trap'} = $this->_asn1_decode(INTEGER))) { return $this->_snmp_decode_error; } # Decode the specific-trap type if (!defined($this->{'_specific_trap'} = $this->_asn1_decode(INTEGER))) { return $this->_snmp_decode_error; } # Decode the time-stamp if (!defined($this->{'_time_stamp'} = $this->_asn1_decode(TIMETICKS))) { return $this->_snmp_decode_error; } # Return the remaining buffer $this->{'_buffer'}; } sub _snmp_decode_var_bind_list { my $this = shift; my ($value, $oid) = (undef, undef); # Decode the VarBindList SEQUENCE if (!defined($value = $this->_asn1_decode(SEQUENCE))) { return $this->_snmp_decode_error; } if ($value != $this->_object_buffer_length) { return $this->_snmp_decode_error( 'Encoded VarBindList length not equal to remaining data length' ); } $this->{'_var_bind_list'} = {}; while ($this->_object_buffer_length) { # Decode the VarBind SEQUENCE if (!defined($this->_asn1_decode(SEQUENCE))) { return $this->_snmp_decode_error; } # Decode the ObjectName if (!defined($oid = $this->_asn1_decode(OBJECT_IDENTIFIER))) { return $this->_snmp_decode_error; } # Decode the ObjectSyntax if (!defined($value = $this->_asn1_decode)) { return $this->_snmp_decode_error; } # Create a hash consisting of the OBJECT IDENTIFIER as a # key and the ObjectSyntax as the value. DEBUG_INFO("{ %s => %s }", $oid, $value); $this->{'_var_bind_list'}->{$oid} = $value; } # Return the var_bind_list hash $this->{'_var_bind_list'}; } sub _snmp_validate_get_response { my $this = shift; my $value = undef; # First we need to reset the var_bind_list and errors that # might have been set from a previous message. $this->_object_clear_var_bind_list; $this->_object_clear_error; $this->{'_type'} = GET_RESPONSE; # Decode the message SEQUENCE if (!defined($value = $this->_asn1_decode(SEQUENCE))) { return $this->_snmp_decode_error; } if ($value != $this->_object_buffer_length) { return $this->_snmp_decode_error( 'Encoded message length not equal to remaining data length' ); } # Decode and validate the version if (!defined($value = $this->_asn1_decode(INTEGER))) { return $this->_snmp_decode_error; } if ($value != $this->{'_version'}) { return $this->_snmp_decode_error( "Received version [0x%02x] is not equal to transmitted version " . "[0x%02x]", $value, $this->{'_version'} ); } # Decode and validate the community if (!defined($value = $this->_asn1_decode(OCTET_STRING))) { return $this->_snmp_decode_error; } if ($value ne $this->{'_community'}) { return $this->_snmp_decode_error( "Received community [%s] is not equal to transmitted community [%s]", $value, $this->{'_community'} ); } # Decode the PDU type if (!defined($this->_asn1_decode($this->{'_type'}))) { return $this->_snmp_decode_error; } # Decode the request-id if (!defined($value = $this->_asn1_decode(INTEGER))) { return $this->_snmp_decode_error; } if ($value != $this->{'_request_id'}) { return $this->_snmp_decode_error( "Received request-id [%s] is not equal to transmitted request-id [%s]", $value, $this->{'_request_id'} ); } # Decode and validate the error-status and error-index if (!defined($this->{'_error_status'} = $this->_asn1_decode(INTEGER))) { $this->{'_error_status'} = 0; return $this->_snmp_decode_error; } if (!defined($this->{'_error_index'} = $this->_asn1_decode(INTEGER))) { $this->{'_error_index'} = 0; return $this->_snmp_decode_error; } if (($this->{'_error_status'} != 0) || ($this->{'_error_index'} != 0)) { return $this->_snmp_decode_error( "Received SNMP %s error-status at error-index %s", _snmp_error_status_itoa($this->{'_error_status'}), $this->{'_error_index'} ); } # Decode the VarBindList $this->_snmp_decode_var_bind_list; } sub _snmp_compare_get_response { my ($this, $response) = @_; if (ref($response) ne ref($this)) { $this->_snmp_decode_error('Invalid object reference'); } # Validate the version if ($this->{'_version'} != $response->{'_version'}) { return $this->_snmp_decode_error( "Received version [0x%02x] is not equal to transmitted version " . "[0x%02x]", $response->{'_version'}, $this->{'_version'} ); } # Validate the community if ($this->{'_community'} ne $response->{'_community'}) { return $this->_snmp_decode_error( "Received community [%s] is not equal to transmitted community [%s]", $response->{'_community'}, $this->{'_community'} ); } # Validate the request-id if ($this->{'_request_id'} != $response->{'_request_id'}) { return $this->_snmp_decode_error( "Received request-id [%s] is not equal to transmitted request-id [%s]", $response->{'_request_id'}, $this->{'_request_id'} ); } # Validate the error-status and error-index field. if (($response->{'_error_status'} != 0) || ($response->{'_error_index'} != 0)) { # Set the "source" error-status and error-index $this->{'_error_status'} = $response->{'_error_status'}; $this->{'_error_index'} = $response->{'_error_index'}; return $this->_snmp_decode_error( "Received SNMP %s error-status at error-index %s", _snmp_error_status_itoa($response->{'_error_status'}), $response->{'_error_index'} ); } TRUE; } sub _snmp_decode_error { my $this = shift; # Clear var_bind_list $this->_object_clear_var_bind_list; $this->_object_error(@_); } ### ## Simple Network Management Protocol (SNMP) utilties ### sub _snmp_error_status_itoa { my $error = shift; my @error_status = qw( noError tooBig noSuchName badValue readOnly genError noAccess wrongType wrongLength wrongEncoding wrongValue noCreation inconsistentValue resourceUnavailable commitFailed undoFailed authorizationError notWritable inconsistentName ); if (!defined($error)) { return '??'; } if (($error > $#error_status) || ($error < 0)) { return sprintf("??(%d)", $error); } sprintf("%s(%d)", $error_status[$error], $error); } ### ## Abstract Syntax Notation One (ASN.1) encode methods ### my $ASN1_ENCODE_METHODS = { INTEGER, '_asn1_encode_integer', OCTET_STRING, '_asn1_encode_octet_string', NULL, '_asn1_encode_null', OBJECT_IDENTIFIER, '_asn1_encode_object_identifier', SEQUENCE, '_asn1_encode_sequence', IPADDRESS, '_asn1_encode_ipaddress', COUNTER, '_asn1_encode_counter', GAUGE, '_asn1_encode_gauge', TIMETICKS, '_asn1_encode_timeticks', OPAQUE, '_asn1_encode_opaque', COUNTER64, '_asn1_encode_counter64', NOSUCHOBJECT, '_asn1_encode_nosuchobject', NOSUCHINSTANCE, '_asn1_encode_nosuchinstance', ENDOFMIBVIEW, '_asn1_encode_endofmibview', GET_REQUEST, '_asn1_encode_get_request', GET_NEXT_REQUEST, '_asn1_encode_get_next_request', GET_RESPONSE, '_asn1_encode_get_response', SET_REQUEST, '_asn1_encode_set_request', TRAP, '_asn1_encode_trap', GET_BULK_REQUEST, '_asn1_encode_get_bulk_request', INFORM_REQUEST, '_asn1_encode_inform_request', SNMPV2_TRAP, '_asn1_encode_v2_trap' }; sub _asn1_encode { my ($this, $type, $value) = @_; if (!defined($type)) { return $this->_asn1_encode_error('ASN.1 type not defined'); } if (exists($ASN1_ENCODE_METHODS->{$type})) { my $method = $ASN1_ENCODE_METHODS->{$type}; $this->$method($value); } else { $this->_asn1_encode_error("Unknown ASN.1 type [%s]", $type); } } sub _asn1_encode_type_length { my ($this, $type, $value) = @_; my $length = 0; if (defined($this->{'_error'})) { return $this->_asn1_encode_error; } if (!defined($type)) { return $this->_asn1_Error('ASN.1 type not defined'); } if (!defined($value)) { $value = ''; } $length = length($value); if ($length < 0x80) { return $this->_object_put_buffer( join('', pack('C2', $type, $length), $value) ); } elsif ($length <= 0xff) { return $this->_object_put_buffer( join('', pack('C3', $type, (0x80 | 1), $length), $value) ); } elsif ($length <= 0xffff) { return $this->_object_put_buffer( join('', pack('CCn', $type, (0x80 | 2), $length), $value) ); } $this->_asn1_encode_error('Unable to encode ASN.1 length'); } sub _asn1_encode_integer { my ($this, $integer) = @_; if (!defined($integer)) { return $this->_asn1_encode_error('INTEGER value not defined'); } if ($integer !~ /^-?\d+$/) { return $this->_asn1_encode_error('Expected numeric INTEGER value'); } $this->_asn1_encode_integer32(INTEGER, $integer); } sub _asn1_encode_unsigned32 { my ($this, $type, $u_int32) = @_; if (!defined($type)) { $type = INTEGER; } if (!defined($u_int32)) { return $this->_asn1_encode_error( "%s value not defined", _asn1_itoa($type) ); } if ($u_int32 !~ /^\d+$/) { return $this->_asn1_encode_error( "Expected positive numeric %s value", _asn1_itoa($type) ); } $this->_asn1_encode_integer32($type, $u_int32); } sub _asn1_encode_integer32 { my ($this, $type, $integer) = @_; my ($size, $value, $negative, $prefix) = (4, '', FALSE, FALSE); if (!defined($type)) { $type = INTEGER; } if (!defined($integer)) { return $this->_asn1_encode_error( "%s value not defined", _asn1_itoa($type) ); } # Determine if the value is positive or negative if ($integer =~ /^-/) { $negative = TRUE; } # Check to see if the most significant bit is set, if it is we # need to prefix the encoding with a zero byte. if (((($integer & 0xff000000) >> 24) & 0x80) && (!$negative)) { $size++; $prefix = TRUE; } # Remove occurances of nine consecutive ones (if negative) or zeros # from the most significant end of the two's complement integer. while ((((!($integer & 0xff800000))) || ((($integer & 0xff800000) == 0xff800000) && ($negative))) && ($size > 1)) { $size--; $integer <<= 8; } # Add a zero byte so the integer is decoded as a positive value if ($prefix) { $value .= pack('x'); $size--; } # Build the integer while ($size-- > 0) { $value .= pack('C', (($integer & 0xff000000) >> 24)); $integer <<= 8; } # Encode ASN.1 header $this->_asn1_encode_type_length($type, $value); } sub _asn1_encode_octet_string { if (!defined($_[1])) { return $_[0]->_asn1_encode_error('OCTET STRING value not defined'); } $_[0]->_asn1_encode_type_length(OCTET_STRING, $_[1]); } sub _asn1_encode_null { $_[0]->_asn1_encode_type_length(NULL, ''); } sub _asn1_encode_object_identifier { my ($this, $oid) = @_; my ($value, $subid, $mask, $bits, $tmask, $tbits) = ('', 0, 0, 0, 0, 0); if (!defined($oid)) { return $this->_asn1_Error('OBJECT IDENTIFIER value not defined'); } # Input is expected in dotted notation, so break it up into subids my @subids = split(/\./, $oid); # If there was a leading dot on _any_ OBJECT IDENTIFIER passed to # an encode method, return a leading dot on _all_ of the OBJECT # IDENTIFIERs in the decode methods. if ($subids[0] eq '') { DEBUG_INFO("leading dot present"); $this->{'_leading_dot'} = TRUE; shift(@subids); } # The first two subidentifiers are encoded into the first identifier # using the the equation: subid = ((first * 40) + second). We just # return an error if there are not at least two subidentifiers. if (scalar(@subids) < 2) { return $this->_asn1_encode_error('Invalid OBJECT IDENTIFIER length'); } $value = 40 * shift(@subids); $value = pack('C', ($value + shift(@subids))); # Encode each value as seven bits with the most significant bit # indicating the end of a subidentifier. foreach $subid (@subids) { if (($subid < 0x7f) && ($subid >= 0)) { $value .= pack('C', $subid); } else { $mask = 0x7f; $bits = 0; # Determine the number of bits need to encode the subidentifier for ($tmask = 0x7f, $tbits = 0; $tmask != 0x00; $tmask <<= 7, $tbits += 7) { if ($subid & $tmask) { $mask = $tmask; $bits = $tbits; } } # Now encode it, using the number of bits from above for ( ; $mask != 0x7f; $mask >>= 7, $bits -= 7) { # Handle a mask that was truncated above because # the subidentifier was four bytes long. if ((($mask & 0xffffffff) == 0xffe00000) || ($mask == 0x1e00000)) { $mask = 0xfe00000; } $value .= pack('C', ((($subid & $mask) >> $bits) | 0x80)); } $value .= pack('C', ($subid & $mask)); } } # Encode the ASN.1 header $this->_asn1_encode_type_length(OBJECT_IDENTIFIER, $value); } sub _asn1_encode_sequence { $_[0]->_asn1_encode_type_length(SEQUENCE, $_[1]); } sub _asn1_encode_ipaddress { my ($this, $address) = @_; if (!defined($address)) { return $this->_asn1_encode_error('IpAddress not defined'); } if ($address !~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/) { return $this->_asn1_encode_error('Expected IpAddress in dotted notation'); } $this->_asn1_encode_type_length( IPADDRESS, pack('C4', split(/\./, $address)) ); } sub _asn1_encode_counter { $_[0]->_asn1_encode_unsigned32(COUNTER, $_[1]); } sub _asn1_encode_gauge { $_[0]->_asn1_encode_unsigned32(GAUGE, $_[1]); } sub _asn1_encode_timeticks { $_[0]->_asn1_encode_unsigned32(TIMETICKS, $_[1]); } sub _asn1_encode_opaque { if (!defined($_[1])) { return $_[0]->_asn1_encode_error('Opaque value not defined'); } $_[0]->_asn1_encode_type_length(OPAQUE, $_[1]); } sub _asn1_encode_counter64 { my ($this, $u_int64) = @_; my ($quotient, $remainder) = (0, 0); my @bytes = (); # Validate the SNMP version if ($this->version != SNMP_VERSION_2C) { return $this->_asn1_encode_error( 'Counter64 only supported with SNMPv2c' ); } # Validate the passed value if (!defined($u_int64)) { return $this->_asn1_encode_error('Counter64 value not defined'); } if ($u_int64 !~ /^\+?\d+$/) { return $this->_asn1_encode_error( 'Expected positive numeric Counter64 value' ); } # Only load the Math::BigInt module when needed use Math::BigInt; $u_int64 = Math::BigInt->new($u_int64); if ($u_int64 eq 'NaN') { return $this->_asn1_encode_error('Invalid Counter64 value'); } # Make sure the value is no more than 8 bytes long if ($u_int64->bcmp('18446744073709551615') > 0) { return $this->_asn1_encode_error('Counter64 value too high'); } if ($u_int64 == 0) { unshift(@bytes, 0x00); } while ($u_int64 > 0) { ($quotient, $remainder) = $u_int64->bdiv(256); $u_int64 = Math::BigInt->new($quotient); unshift(@bytes, $remainder); } # Make sure that the value is encoded as a positive value if ($bytes[0] & 0x80) { unshift(@bytes, 0x00); } $this->_asn1_encode_type_length(COUNTER64, pack('C*', @bytes)); } sub _asn1_encode_nosuchobject { if ($_[0]->version != SNMP_VERSION_2C) { return $_[0]->_asn1_encode_error( 'noSuchObject only supported with SNMPv2c' ); } $_[0]->_asn1_encode_type_length(NOSUCHOBJECT, ''); } sub _asn1_encode_nosuchinstance { if ($_[0]->version != SNMP_VERSION_2C) { return $_[0]->_asn1_encode_error( 'noSuchInstance only supported with SNMPv2c' ); } $_[0]->_asn1_encode_type_length(NOSUCHINSTANCE, ''); } sub _asn1_encode_endofmibview { if ($_[0]->version != SNMP_VERSION_2C) { return $_[0]->_asn1_encode_error( 'endOfMibView only supported with SNMPv2c' ); } $_[0]->_asn1_encode_type_length(ENDOFMIBVIEW, ''); } sub _asn1_encode_get_request { $_[0]->_asn1_encode_type_length(GET_REQUEST, $_[1]); } sub _asn1_encode_get_next_request { $_[0]->_asn1_encode_type_length(GET_NEXT_REQUEST, $_[1]); } sub _asn1_encode_get_response { $_[0]->_asn1_encode_type_length(GET_RESPONSE, $_[1]); } sub _asn1_encode_set_request { $_[0]->_asn1_encode_type_length(SET_REQUEST, $_[1]); } sub _asn1_encode_trap { $_[0]->_asn1_encode_type_length(TRAP, $_[1]); } sub _asn1_encode_get_bulk_request { if ($_[0]->version != SNMP_VERSION_2C) { return $_[0]->_asn1_encode_error( 'GetBulkRequest-PDU only supported with SNMPv2c' ); } $_[0]->_asn1_encode_type_length(GET_BULK_REQUEST, $_[1]); } sub _asn1_encode_inform_request { if ($_[0]->version != SNMP_VERSION_2C) { return $_[0]->_asn1_encode_error( 'InformRequest-PDU only supported with SNMPv2c' ); } $_[0]->_asn1_encode_type_length(INFORM_REQUEST, $_[1]); } sub _asn1_encode_v2_trap { if ($_[0]->version != SNMP_VERSION_2C) { return $_[0]->_asn1_encode_error( 'SNMPv2-Trap-PDU only supported with SNMPv2c' ); } $_[0]->_asn1_encode_type_length(SNMPV2_TRAP, $_[1]); } sub _asn1_encode_error { my $this = shift; # Clear the buffer $this->_object_clear_buffer; $this->_object_error(@_); } ### ## Abstract Syntax Notation One (ASN.1) decode methods ### my $ASN1_DECODE_METHODS = { INTEGER, '_asn1_decode_integer32', OCTET_STRING, '_asn1_decode_octet_string', NULL, '_asn1_decode_null', OBJECT_IDENTIFIER, '_asn1_decode_object_identifier', SEQUENCE, '_asn1_decode_sequence', IPADDRESS, '_asn1_decode_ipaddress', COUNTER, '_asn1_decode_counter', GAUGE, '_asn1_decode_gauge', TIMETICKS, '_asn1_decode_timeticks', OPAQUE, '_asn1_decode_opaque', COUNTER64, '_asn1_decode_counter64', NOSUCHOBJECT, '_asn1_decode_nosuchobject', NOSUCHINSTANCE, '_asn1_decode_nosuchinstance', ENDOFMIBVIEW, '_asn1_decode_endofmibview', GET_REQUEST, '_asn1_decode_get_request', GET_NEXT_REQUEST, '_asn1_decode_get_next_request', GET_RESPONSE, '_asn1_decode_get_response', SET_REQUEST, '_asn1_decode_set_request', TRAP, '_asn1_decode_trap', GET_BULK_REQUEST, '_asn1_decode_get_bulk_request', INFORM_REQUEST, '_asn1_decode_inform_request', SNMPV2_TRAP, '_asn1_decode_v2_trap' }; sub _asn1_decode { my ($this, $expected) = @_; if (defined($this->{'_error'})) { return $this->_asn1_decode_error; } my $type = $this->_object_get_buffer(1); if (defined($type)) { $type = unpack('C', $type); if (exists($ASN1_DECODE_METHODS->{$type})) { my $method = $ASN1_DECODE_METHODS->{$type}; if (defined($expected)) { if ($type != $expected) { return $this->_asn1_decode_error( "Expected %s, but found %s", _asn1_itoa($expected), _asn1_itoa($type) ); } } return $this->$method($type); } else { return $this->_asn1_decode_error("Unknown ASN.1 type [0x%02x]", $type); } } $this->_asn1_decode_error; } sub _asn1_decode_length { my $this = shift; my ($length, $byte_cnt) = (0, 0); if (defined($this->{'_error'})) { return $this->_asn1_decode_error; } if (!defined($length = $this->_object_get_buffer(1))) { return $this->_asn1_decode_error; } $length = unpack('C', $length); if ($length & 0x80) { $byte_cnt = ($length & 0x7f); if ($byte_cnt == 0) { return $this->_asn1_decode_error( 'Indefinite ASN.1 lengths not supported' ); } elsif ($byte_cnt <= 4) { if (!defined($length = $this->_object_get_buffer($byte_cnt))) { return $this->_asn1_decode_error; } $length = unpack('N', ("\0" x (4 - $byte_cnt) . $length)); } else { return $this->_asn1_decode_error( "ASN.1 length too long (%d bytes)", $byte_cnt ); } } $length; } sub _asn1_decode_integer32 { my ($this, $type) = @_; my ($length, $integer, $negative, $byte) = (undef, 0, FALSE, undef); if (!defined($length = $this->_asn1_decode_length)) { return $this->_asn1_decode_error; } # Return an error if the object length is zero if ($length < 1) { return $this->_asn1_decode_error( "%s length equal to zero", _asn1_itoa($type) ); } if (!defined($byte = $this->_object_get_buffer(1))) { return $this->_asn1_decode_error; } $length--; # If the first bit is set, the integer is negative if (($byte = unpack('C', $byte)) & 0x80) { $integer = -1; $negative = TRUE; } if (($length > 4) || (($length > 3) && ($byte != 0x00))) { return $this->_asn1_decode_error( "%s length too long (%d bytes)", _asn1_itoa($type), ($length + 1) ); } $integer = (($integer << 8) | $byte); while ($length--) { if (!defined($byte = $this->_object_get_buffer(1))) { return $this->_asn1_decode_error; } $integer = (($integer << 8) | unpack('C', $byte)); } if ($negative) { sprintf("%d", $integer); } else { $integer = abs($integer); sprintf("%u", $integer); } } sub _asn1_decode_octet_string { my ($this, $type) = @_; my ($length, $string) = (undef, undef); if (!defined($type)) { $type = OCTET_STRING; } if (!defined($length = $this->_asn1_decode_length)) { return $this->_asn1_decode_error; } if (defined($string = $this->_object_get_buffer($length))) { if (($string =~ /[\x01-\x08\x0b\x0e-\x1f\x7f-\xff]/g) && ($this->translate)) { DEBUG_INFO( "translating %s to printable hex string", _asn1_itoa($type) ); return sprintf("0x%s", unpack('H*', $string)); } else { return $string; } } else { return $this->_asn1_decode_error; } } sub _asn1_decode_null { my $this = shift; my ($length) = (undef); if (!defined($length = $this->_asn1_decode_length)) { return $this->_asn1_decode_error; } if ($length != 0) { return $this->_asn1_decode_error('NULL length not equal to zero'); } if ($this->translate) { DEBUG_INFO("translating NULL to 'NULL' string"); 'NULL'; } else { ''; } } sub _asn1_decode_object_identifier { my $this = shift; my ($length, $subid_cnt, $subid, $byte) = (undef, 1, 0, undef); my (@oid); if (!defined($length = $this->_asn1_decode_length)) { return $this->_asn1_decode_error; } if ($length < 1) { return $this->_asn1_decode_error( 'OBJECT IDENTIFIER length equal to zero' ); } while ($length > 0) { $subid = 0; do { if (!defined($byte = $this->_object_get_buffer(1))) { return $this->_asn1_decode_error; } $byte = unpack('C', $byte); if ($subid >= 0xffffffff) { return $this->_asn1_decode_error( 'OBJECT IDENTIFIER subidentifier too large' ); } $subid = (($subid << 7) + ($byte & 0x7f)); $length--; } while ($byte & 0x80); $oid[$subid_cnt++] = $subid; } # The first two subidentifiers are encoded into the first identifier # using the the equation: subid = ((first * 40) + second). $subid = $oid[1]; $oid[1] = int($subid % 40); $oid[0] = int(($subid - $oid[1]) / 40); # Return the OID in dotted notation (optionally with a leading dot # if one was passed to the encode routine). if ($this->{'_leading_dot'}) { DEBUG_INFO("adding leading dot"); '.' . join('.', @oid); } else { join('.', @oid); } } sub _asn1_decode_sequence { # Return the length, instead of the value $_[0]->_asn1_decode_length; } sub _asn1_decode_ipaddress { my $this = shift; my ($length, $address) = (undef, undef); if (!defined($length = $this->_asn1_decode_length)) { return $this->_asn1_decode_error; } if ($length != 4) { return $this->_asn1_decode_error( "Invalid IpAddress length (% byte%s)", $length, ($length == 1 ? '' : 's') ); } if (defined($address = $this->_object_get_buffer(4))) { join('.', unpack('C4', $address)); } else { $this->_asn1_decode_error; } } sub _asn1_decode_counter { $_[0]->_asn1_decode_integer32(COUNTER); } sub _asn1_decode_gauge { $_[0]->_asn1_decode_integer32(GAUGE); } sub _asn1_decode_timeticks { my $this = shift; my $ticks = undef; if (defined($ticks = $this->_asn1_decode_integer32(TIMETICKS))) { if ($this->translate) { DEBUG_INFO("translating %u TimeTicks to time\n", $ticks); return _asn1_ticks_to_time($ticks); } else { return $ticks; } } else { return $this->_asn1_decode_error; } } sub _asn1_decode_opaque { $_[0]->_asn1_decode_octet_string(OPAQUE); } sub _asn1_decode_counter64 { my $this = shift; my ($length, $byte, $negative) = (undef, undef, FALSE); # Verify the SNMP version if ($this->version != SNMP_VERSION_2C) { return $this->_asn1_decode_error( 'Counter64 only supported with SNMPv2c' ); } if (!defined($length = $this->_asn1_decode_length)) { return $this->_asn1_decode_error; } if ($length < 1) { return $this->_asn1_decode_error('Counter64 length equal to zero'); } if (!defined($byte = $this->_object_get_buffer(1))) { return $this->_asn1_decode_error; } $length--; $byte = unpack('C', $byte); if (($length > 8) || (($length > 7) && ($byte != 0x00))) { return $this->_asn1_decode_error( "Counter64 length too long (%d bytes)", ($length + 1) ); } # Only load the Math::BigInt module when needed use Math::BigInt; if ($byte & 0x80) { $negative = TRUE; $byte = $byte ^ 0xff; } my $u_int64 = Math::BigInt->new($byte); while ($length-- > 0) { if (!defined($byte = $this->_object_get_buffer(1))) { return $this->_asn1_decode_error; } $byte = unpack('C', $byte); if ($negative) { $byte = $byte ^ 0xff; } $u_int64 = $u_int64->bmul(256); $u_int64 = Math::BigInt->new($u_int64); $u_int64 = $u_int64->badd($byte); $u_int64 = Math::BigInt->new($u_int64); }; # If the value is negative the other end incorrectly encoded # the Counter64 since it should always be a positive value. if ($negative) { $byte = Math::BigInt->new('-1'); $u_int64 = $byte->bsub($u_int64); } # Remove the plus sign (or should we leave it to imply Math::BigInt?) $u_int64 =~ s/^\+//; $u_int64; } sub _asn1_decode_nosuchobject { my $this = shift; my ($length) = (undef); if ($this->version != SNMP_VERSION_2C) { return $this->_asn1_decode_error( 'noSuchObject only supported with SNMPv2c' ); } if (!defined($length = $this->_asn1_decode_length)) { return $this->_asn1_decode_error; } if ($length != 0) { return $this->_asn1_decode_error('noSuchObject length not equal to zero'); } if ($this->translate) { DEBUG_INFO("translating noSuchObject to 'noSuchObject' string"); 'noSuchObject'; } else { $this->{'_error_status'} = NOSUCHOBJECT; ''; } } sub _asn1_decode_nosuchinstance { my $this = shift; my ($length) = (undef); if ($this->version != SNMP_VERSION_2C) { return $this->_asn1_decode_error( 'noSuchInstance only supported with SNMPv2c' ); } if (!defined($length = $this->_asn1_decode_length)) { return $this->_asn1_decode_error; } if ($length != 0) { return $this->_asn1_decode_error( 'noSuchInstance length not equal to zero' ); } if ($this->translate) { DEBUG_INFO("translating noSuchInstance to 'noSuchInstance' string"); 'noSuchInstance'; } else { $this->{'_error_status'} = NOSUCHINSTANCE; ''; } } sub _asn1_decode_endofmibview { my $this = shift; my ($length) = (undef); if ($this->version != SNMP_VERSION_2C) { return $this->_asn1_decode_error( 'endOfMibView only supported with SNMPv2c' ); } if (!defined($length = $this->_asn1_decode_length)) { return $this->_asn1_decode_error; } if ($length != 0) { return $this->_asn1_decode_error('endOfMibView length not equal to zero'); } if ($this->translate) { DEBUG_INFO("translating endOfMibView to 'endOfMibView' string"); 'endOfMibView'; } else { $this->{'_error_status'} = ENDOFMIBVIEW; ''; } } sub _asn1_decode_pdu { # Generic methods used to decode the PDU type. The ASN.1 type is # returned by the method as passed by the generic decode routine. if ((defined($_[0]->_asn1_decode_length)) && (defined($_[1]))) { $_[1]; } else { $_[0]->_asn1_decode_error('ASN.1 PDU type not defined'); } } sub _asn1_decode_get_request { $_[0]->_asn1_decode_pdu(GET_REQUEST); } sub _asn1_decode_get_next_request { $_[0]->_asn1_decode_pdu(GET_NEXT_REQUEST); } sub _asn1_decode_get_response { $_[0]->_asn1_decode_pdu(GET_RESPONSE); } sub _asn1_decode_set_request { $_[0]->_asn1_decode_pdu(SET_REQUEST); } sub _asn1_decode_trap { $_[0]->_asn1_decode_pdu(TRAP); } sub _asn1_decode_get_bulk_request { if ($_[0]->version != SNMP_VERSION_2C) { return $_[0]->_asn1_decode_error( 'GetBulkRequest-PDU only supported with SNMPv2c' ); } $_[0]->_asn1_decode_pdu(GET_BULK_REQUEST); } sub _asn1_decode_inform_request { if ($_[0]->version != SNMP_VERSION_2C) { return $_[0]->_asn1_decode_error( 'InformRequest-PDU only supported with SNMPv2c' ); } $_[0]->_asn1_decode_pdu(INFORM_REQUEST); } sub _asn1_decode_v2_trap { if ($_[0]->version != SNMP_VERSION_2C) { return $_[0]->_asn1_decode_error( 'SNMPv2-Trap-PDU only supported with SNMPv2c' ); } $_[0]->_asn1_decode_pdu(SNMPV2_TRAP); } sub _asn1_decode_error { my $this = shift; $this->_object_error(@_); } ### ## Abstract Syntax Notation One (ASN.1) utility functions ### sub _asn1_itoa { my $type = shift; my $types = { INTEGER, 'INTEGER', OCTET_STRING, 'OCTET STRING', NULL, 'NULL', OBJECT_IDENTIFIER, 'OBJECT IDENTIFER', SEQUENCE, 'SEQUENCE', IPADDRESS, 'IpAddress', COUNTER, 'Counter', GAUGE, 'Gauge', TIMETICKS, 'TimeTicks', OPAQUE, 'Opaque', COUNTER64, 'Counter64', NOSUCHOBJECT, 'noSuchObject', NOSUCHINSTANCE, 'noSuchInstance', ENDOFMIBVIEW, 'endOfMibView', GET_REQUEST, 'GetRequest-PDU', GET_NEXT_REQUEST, 'GetNextRequest-PDU', GET_RESPONSE, 'GetResponse-PDU', SET_REQUEST, 'SetRequest-PDU', TRAP, 'Trap-PDU', GET_BULK_REQUEST, 'GetBulkRequest-PDU', INFORM_REQUEST, 'InformRequest-PDU', SNMPV2_TRAP, 'SNMPv2-Trap-PDU' }; if (!defined($type)) { return '??'; } if (exists($types->{$type})) { $types->{$type}; } else { sprintf("?? [0x%02x]", $type); } } sub _asn1_oid_context_match { my ($oid_p, $oid_c) = @_; my ($parent, $child) = (undef, undef); # Compares the parent OID (oid_p) to the child OID (oid_c) # and returns true if the child is equal to or is a subtree # of the parent OID. if (!defined($oid_p)) { return FALSE; } if (!defined($oid_c)) { return FALSE; } # Remove leading dots $oid_p =~ s/^\.//; $oid_c =~ s/^\.//; my @subid_p = split(/\./, $oid_p); my @subid_c = split(/\./, $oid_c); while (@subid_p) { if (!defined($parent = shift(@subid_p))) { return TRUE; } if (!defined($child = shift(@subid_c))) { return FALSE; } if ($parent != $child) { return FALSE; } } TRUE; } sub _asn1_oid_lex_sort { sort _asn1_lexicographical @_; } sub _asn1_lexicographical { my ($aa, $bb); my @a = split(/\./, $a); if ($a[0] eq '') { shift(@a); } my @b = split(/\./, $b); if ($b[0] eq '') { shift(@b); } while (@a) { if (!defined($aa = shift(@a))) { return -1; } if (!defined($bb = shift(@b))) { return 1; } if ($aa < $bb) { return -1; } if ($aa > $bb) { return 1; } } 0; } sub _asn1_ticks_to_time { my $ticks = shift; if (!defined($ticks)) { $ticks = 0; } my $days = int($ticks / (24 * 60 * 60 * 100)); $ticks %= (24 * 60 * 60 * 100); my $hours = int($ticks / (60 * 60 * 100)); $ticks %= (60 * 60 * 100); my $minutes = int($ticks / (60 * 100)); $ticks %= (60 * 100); my $seconds = ($ticks / 100); if ($days != 0){ sprintf("%d day%s, %02d:%02d:%05.02f", $days, ($days == 1 ? '' : 's'), $hours, $minutes, $seconds); } elsif ($hours != 0) { sprintf("%d hour%s, %02d:%05.02f", $hours, ($hours == 1 ? '' : 's'), $minutes, $seconds); } elsif ($minutes != 0) { sprintf("%d minute%s, %05.02f", $minutes, ($minutes == 1 ? '' : 's'), $seconds); } else { sprintf("%04.02f second%s", $seconds, ($seconds == 1 ? '' : 's')); } } ### ## User Datagram Protocol (UDP) methods ### sub _udp_send_message { my $this = shift; my ($retries, $rout, $rin) = (0, '', ''); # Make sure the socket is still open if (!defined($this->{'_socket'})) { return $this->_udp_error('Session is closed'); } # Get the number of retries $retries = $this->{'_retries'}; # Setup a vector to indicate received data on the socket vec($rin, fileno($this->{'_socket'}), 1) = 1; do { if (!defined($this->_udp_send_buffer)) { return $this->_udp_error; } if (select($rout=$rin, undef, undef, $this->{'_timeout'})) { return $this->_udp_recv_buffer; } else { DEBUG_INFO("request timed out, retries = %d", $retries); $retries--; } } while ($retries >= 0); # Exceeded the number of retries $this->_udp_error( "No response from agent on remote host '%s'", $this->hostname ); } sub _udp_send_buffer { my $this = shift; my ($length, $host_port, $host_addr) = (0, undef, undef); # Make sure the socket is still open if (!defined($this->{'_socket'})) { return $this->_udp_error('Session is closed'); } ($host_port, $host_addr) = sockaddr_in($this->{'_sockaddr'}); DEBUG_INFO("address %s, port %d", inet_ntoa($host_addr), $host_port); $this->_debug_dump_buffer; # Transmit the contents of the buffer if (!defined($length = send($this->{'_socket'}, $this->{'_buffer'}, 0, $this->{'_sockaddr'}) )) { return $this->_udp_error("send(): %s", $!); } # Return the number of bytes transmitted $length; } sub _udp_recv_buffer { my $this = shift; my $sockaddr = undef; # Make sure the socket is still open if (!defined($this->{'_socket'})) { return $this->_udp_error('Session is closed'); } # Clear the contents of the buffer $this->_object_clear_buffer; # Fill the buffer if (!defined($sockaddr = recv($this->{'_socket'}, $this->{'_buffer'}, $this->{'_mtu'}, 0) )) { return $this->_udp_error("recv(): %s", $!); } my ($host_port, $host_addr) = sockaddr_in($sockaddr); DEBUG_INFO("address %s, port %d", inet_ntoa($host_addr), $host_port); $this->_debug_dump_buffer; # Return the address structure $sockaddr; } sub _udp_error { my $this = shift; $this->_object_error(@_); } ### ## Object specific methods ### sub _object_copy { my $this = shift; my $copy = bless {}, ref($this); foreach (keys(%{$this})) { $copy->{$_} = $this->{$_}; } $copy; } sub _object_queue_message { my $this = shift; if ((!$this->{'_nonblocking'}) || (!defined($this->{'_fsm'}))) { return $this->_object_encode_error( 'Unable to queue message for a blocking session' ); } if (!defined($this->{'_socket'})) { return $this->_object_encode_error('Session is closed'); } if (!defined($this->{'_fsm'}->queue_message($this))) { $this->_object_encode_error('Failed to queue message'); } TRUE; } sub _object_add_callback { my ($this, $callback) = @_; # Callbacks can be passed in two different ways. If the callback # has options, the callback must be passed as an ARRAY reference # with the first element being a CODE reference and the remaining # elements the arguments. If the callback has not options it # is just passed as a CODE reference. if ((ref($callback) eq 'ARRAY') && (ref($callback->[0]) eq 'CODE')) { $this->{'_callback'} = $callback; } elsif (ref($callback) eq 'CODE') { $this->{'_callback'} = [$callback]; } elsif (!defined($callback)) { $this->{'_callback'} = undef; # Used to clear the callback } else { return $this->_object_error('Invalid callback format'); } TRUE; } sub _object_invoke_callback { my $this = shift; # Callbacks are invoked with a reference to the copy of the original # object followed by the users parameters. if (defined($this->{'_callback'})) { my @argv = @{$this->{'_callback'}}; my $callback = shift(@argv); if (ref($callback) ne 'CODE') { return($this->{'_callback'} = undef); } unshift(@argv, $this); eval { &{$callback}(@argv) }; if ($@ ne '') { DEBUG_INFO("eval error: %s", $@); } return $@; } DEBUG_INFO("callback not defined"); $this->{'_callback'}; } sub _object_get_table_cb { my ($this, $argv) = @_; # Use get-next-requests until the response is not a subtree of the # base OBJECT IDENTIFIER. Return the table only if there are no # errors other than a noSuchName(2) error since the table could # be at the end of the tree. Also return the table when the value # of the OID equals endOfMibView(2) when using SNMPv2c. # Assign the "real" callback to the object $this->{'_callback'} = $argv->{'callback'}; # Check to see if the var_bind_list is defined (was there an error?) if (defined($this->var_bind_list)) { my ($next_oid) = keys(%{$this->var_bind_list}); if (_asn1_oid_context_match($argv->{'base_oid'}, $next_oid)) { if (!exists($argv->{'table'}->{$next_oid})) { $argv->{'table'}->{$next_oid} = $this->var_bind_list->{$next_oid}; } elsif ((($this->var_bind_list->{$next_oid} eq 'endOfMibView') || ($this->error_status == ENDOFMIBVIEW)) && ($this->version == SNMP_VERSION_2C)) { if (!defined($argv->{'table'})) { $this->_object_decode_error('Requested table is empty'); } $this->{'_var_bind_list'} = $argv->{'table'}; return $this->_object_invoke_callback; } else { $argv->{'repeat_cnt'}++; } # Check to make sure that the remote host does not respond # incorrectly causing the get-next-requests to loop forever. if ($argv->{'repeat_cnt'} > 5) { $this->_object_decode_error( 'Loop detected with table on remote host' ); return $this->_object_invoke_callback; } # Queue up the get-next-request $this->get_next_request( -callback => [\&_object_get_table_cb, $argv], -varbindlist => [$next_oid] ); } else { # We have reached the end of the table if (!defined($argv->{'table'})) { $this->_object_decode_error('Requested table is empty'); } $this->{'_var_bind_list'} = $argv->{'table'}; return $this->_object_invoke_callback; } } else { # Check for noSuchName(2) error if ($this->error_status == 2) { if (!defined($argv->{'table'})) { $this->_object_decode_error('Requested table is empty'); } $this->{'_var_bind_list'} = $argv->{'table'}; } $this->_object_invoke_callback; } } sub _object_put_buffer { my ($this, $prefix) = @_; # Do not do anything if there has already been an error if (defined($this->{'_error'})) { return $this->_object_encode_error; } # Make sure we do not exceed our MTU if (($this->_object_buffer_length + length($prefix)) > $this->{'_mtu'}) { return $this->_object_encode_error('PDU size exceeded MTU'); } # Add the prefix to the current buffer if ((defined($prefix)) && ($prefix ne '')) { $this->{'_buffer'} = join('', $prefix, $this->{'_buffer'}); } # Return what was just added in case someone wants it $prefix; } sub _object_get_buffer { my ($this, $offset) = @_; my $substr = ''; # Do not do anything if there has already been an error if (defined($this->{'_error'})) { return $this->_object_decode_error; } # Either return the whole buffer or a sub-string from the # beginning of the buffer and then set the buffer equal to # what is left in the buffer if (defined($offset)) { $offset = abs($offset); if ($offset > length($this->{'_buffer'})) { return $this->_object_decode_error('Unexpected end of buffer'); } else { $substr = substr($this->{'_buffer'}, 0, $offset); $this->{'_buffer'} = substr($this->{'_buffer'}, $offset); } } else { $substr = $this->{'_buffer'}; $this->{'_buffer'} = ''; } $substr; } sub _object_clear_buffer { $_[0]->{'_buffer'} = ''; } sub _object_clear_var_bind_list { $_[0]->{'_var_bind_list'} = undef; } sub _object_clear_error { $_[0]->{'_error_status'} = 0; $_[0]->{'_error_index'} = 0; $_[0]->{'_error'} = undef; } sub _object_clear_snmp_message { my @fields = qw( _version _community _type _request_id _error_status _error_index _enterprise _agent_addr _generic_trap _specific_trap _time_stamp ); foreach (@fields) { if (exists($_[0]->{$_})) { $_[0]->{$_} = undef; } } } sub _object_clear_leading_dot { $_[0]->{'_leading_dot'} = FALSE; } sub _object_buffer_length { length $_[0]->{'_buffer'}; } sub _object_encode_error { my $this = shift; # Clear the buffer $this->_object_clear_buffer; $this->_object_error(@_); } sub _object_decode_error { my $this = shift; $this->_object_error(@_); } sub _object_error { my ($this, $format, @message) = @_; if (!defined($this->{'_error'})) { $this->{'_error'} = sprintf $format, @message; if ($this->debug) { my $index = caller(3) ? 1 : 0; printf("error: [%d] %s(): %s\n", (caller($index))[2], (caller($index + 1))[3], $this->{'_error'} ); } } undef; } ### ## Debug functions/methods ### sub DEBUG_INFO { if (!$Net::SNMP::DEBUG) { return $Net::SNMP::DEBUG; } my $format = sprintf("debug: [%d] %s(): ", (caller(0))[2], (caller(1))[3]); $format = join('', $format, shift(@_), "\n"); printf $format, @_; $Net::SNMP::DEBUG; } sub _debug_dump_buffer { my $this = shift; my ($length, $offset, $line, $hex) = (0, 0, '', ''); if (!$this->debug) { return undef; } $length = length($this->{'_buffer'}); DEBUG_INFO("%d byte%s", $length, ($length == 1 ? '' : 's')); while ($length > 0) { if ($length >= 16) { $line = substr($this->{'_buffer'}, $offset, 16); } else { $line = substr($this->{'_buffer'}, $offset, $length); } $hex = unpack('H*', $line); $hex .= ' ' x (32 - length($hex)); $hex = sprintf("%s %s %s %s " x 4, unpack('a2' x 16, $hex)); $line =~ s/[\x00-\x1f\x7f-\xff]/./g; printf("[%03d] %s %s\n", $offset, uc($hex), $line); $offset += 16; $length -= 16; } print("\n"); $this->{'_buffer'}; } # ============================================================================ 1; # [end Net::SNMP] # ============================================================================ package Net::SNMP::FSM; # $Id: FSM.pm,v 1.1 2000/01/01 17:55:53 dtown Exp $ # $Source: /us/dtown/Projects/Net-SNMP/FSM.pm,v $ # Finite State Machine for the Net::SNMP event loop. # Copyright (c) 1999-2000 David M. Town . # All rights reserved. # This program is free software; you may redistribute it and/or modify it # under the same terms as Perl itself. # ============================================================================ ## Import and initialize global symbols sub BEGIN { require Net::SNMP; *DEBUG_INFO = \&Net::SNMP::DEBUG_INFO; *FALSE = \&Net::SNMP::FALSE; *GET_RESPONSE = \&Net::SNMP::GET_RESPONSE; *MINIMUM_MTU = \&Net::SNMP::MINIMUM_MTU; *SNMPV2_TRAP = \&Net::SNMP::SNMPV2_TRAP; *TRAP = \&Net::SNMP::TRAP; *TRUE = \&Net::SNMP::TRUE; } ## Finite State Machine state definitions sub STATE_STOPPED() { 0 } sub STATE_STARTING() { 1 } sub STATE_SENDING() { 2 } sub STATE_WAITING() { 3 } sub STATE_VALIDATING() { 4 } sub STATE_CLEARING() { 5 } ## Flag to indicate a "dead" queued object sub TTD_DEAD() { 0 } # [public methods] ----------------------------------------------------------- sub new { my ($class, %argv) = @_; my $this = bless { '_decode_object' => undef, '_pending_queue' => [], '_rin' => '', '_sending_queue' => [], '_sockets' => {}, '_state' => STATE_STOPPED }, $class; # Create a Net::SNMP object to use to decode the responses. $this->{'_decode_object'} = Net::SNMP->new(-mtu => MINIMUM_MTU); if (!defined($this->{'_decode_object'})) { DEBUG_INFO('failed to create Net::SNMP object'); return undef; } $this; } sub queue_message { $_[0]->_action_queue($_[1]); } sub event_loop { $_[0]->_event_loop; } sub one_event { $_[0]->_event_handle; } # [private methods] ---------------------------------------------------------- sub _event_loop { my $this = shift; # The action that starts everything... $this->_action_start; while ($this->_object_state != STATE_STOPPED) { $this->_event_handle; } $this->_object_clear; } sub _event_handle { my $this = shift; if ($this->_object_state == STATE_STARTING) { $this->_state_starting; } elsif ($this->_object_state == STATE_SENDING) { $this->_state_sending; } elsif ($this->_object_state == STATE_WAITING) { $this->_state_waiting; } elsif ($this->_object_state == STATE_VALIDATING) { $this->_state_validating; } elsif ($this->_object_state == STATE_CLEARING) { $this->_state_clearing; } else { DEBUG_INFO("state = %d", $this->_object_state); $this->_object_state(STATE_STOPPED); } } ### ## FSM States ### sub _state_starting { my $this = shift; # Need to initialize the "time-to-die" fields on all pending messages foreach (@{$this->{'_pending_queue'}}) { $_->{'_ttd'} = time() + $_->timeout; } if (@{$this->{'_sending_queue'}}) { $this->_action_send; } elsif (@{$this->{'_pending_queue'}}) { $this->_action_wait; } else { $this->_action_stop; } } sub _state_sending { my $this = shift; my $message = undef; DEBUG_INFO("sending %d message(s)", scalar(@{$this->{'_sending_queue'}})); while (defined($message = shift(@{$this->{'_sending_queue'}}))) { if (!defined($message->_udp_send_buffer)) { DEBUG_INFO("error [%s]", $message->error); return $this->_action_stop; } } if (@{$this->{'_pending_queue'}}) { $this->_action_wait; } else { $this->_action_stop; } } sub _state_waiting { my $this = shift; # Sort the pending queue by time-to-die @{$this->{'_pending_queue'}} = sort _by_ttd @{$this->{'_pending_queue'}}; # Calculate a timeout based on the current time and the # lowest time-to-die in the queue. my $timeout = ${$this->{'_pending_queue'}}[0]->{'_ttd'} - time(); # If the timeout is less than 0, this entry has timed out. if ($timeout < 0) { $this->_action_timeout; $timeout = 0; } if (select(my $rout = $this->{'_rin'}, undef, undef, $timeout)) { # Find out which socket has data ready foreach (keys(%{$this->{'_sockets'}})) { if (defined($rout) && vec($rout, $_, 1)) { DEBUG_INFO("socket handle [%d] ready", $_); return $this->_action_read_data($this->{'_sockets'}->{$_}); } } } DEBUG_INFO("no response, timeout = %f", $timeout); # Else handle the timeout $this->_action_timeout; } sub _state_validating { my $this = shift; my $object = $this->{'_decode_object'}; # Decode the packet up to the VarBindList $object->_object_clear_snmp_message; $object->{'_type'} = GET_RESPONSE; if (!defined($object->_snmp_decode_message)) { DEBUG_INFO("message decode error [%s]", $object->error); return $this->_action_clear; } if (!defined($object->_snmp_decode_pdu)) { DEBUG_INFO("pdu decode error [%s]", $object->error); return $this->_action_clear; } # Now look for a matching queued message based on request-id foreach (@{$this->{'_pending_queue'}}) { if ($_->{'_ttd'} == TTD_DEAD) { next; } if ($object->_request_id == $_->_request_id) { DEBUG_INFO("response received: request-id = %s (%s)", $_->_request_id, $_->hostname ); # Set the time-to-die to "dead" so this object is # removed from the queue in the clearing state. $_->{'_ttd'} = TTD_DEAD; # Now compare the response to sent message if (!defined($_->_snmp_compare_get_response($object))) { return $this->_action_callback($_); } # Copy the remaining buffer over to the "real" object # and decode the VarBindList. $_->{'_buffer'} = $object->{'_buffer'}; $_->_snmp_decode_var_bind_list; return $this->_action_callback($_); } } DEBUG_INFO("unknown request-id = %s", $object->_request_id); $this->_action_clear; } sub _state_clearing { my $this = shift; # Sort the pending queue by time-to-die @{$this->{'_pending_queue'}} = sort _by_ttd @{$this->{'_pending_queue'}}; # Now clear out any "dead" objects from the pending queue while ((@{$this->{'_pending_queue'}}) && (${$this->{'_pending_queue'}}[0]->{'_ttd'} == TTD_DEAD)) { DEBUG_INFO("remove request-id = %s (%s)", ${$this->{'_pending_queue'}}[0]->{'_org_req_id'}, ${$this->{'_pending_queue'}}[0]->hostname, ); shift(@{$this->{'_pending_queue'}}); } if (@{$this->{'_sending_queue'}}) { $this->_action_send; } elsif (!@{$this->{'_pending_queue'}}) { $this->_action_stop; } else { $this->_action_wait; } } ### ## FSM actions ### sub _action_queue { my ($this, $message) = @_; # Make sure that a Net::SNMP object was passed if (!defined($message) || ref($message) ne 'Net::SNMP') { DEBUG_INFO('invalid message type'); return undef; } # Validate the socket status if (!defined($message->{'_socket'}) || !fileno($message->{'_socket'})) { DEBUG_INFO('socket is invalid'); return undef; } # Copy the object, so that we can use it for retransmissions my $copy = $message->_object_copy; # Adjust the MTU of the decode object if necessary if ($copy->mtu > $this->{'_decode_object'}->mtu) { $this->{'_decode_object'}->mtu($copy->mtu); } # Add a time-to-die field and a copy of the request-id to the copy $copy->{'_ttd'} = time() + $copy->timeout; $copy->{'_org_req_id'} = $copy->_request_id; # Add the socket to the "readable" vector vec($this->{'_rin'}, fileno($copy->{'_socket'}), 1) = 1; # Add the socket to the list of sockets $this->{'_sockets'}->{fileno($copy->{'_socket'})} = $copy->{'_socket'}; # Queue the copy for transmission $this->_object_queue_sending($copy); # Queue the copy, if the message requires a response if ((defined($copy->{'_type'})) && ($copy->{'_type'} != TRAP) && ($copy->{'_type'} != SNMPV2_TRAP)) { $this->_object_queue_pending($copy); } DEBUG_INFO("add request-id = %s (%s)", $copy->_request_id, $copy->hostname ); if (($this->_object_state == STATE_STOPPED) || ($this->_object_state == STATE_STARTING)) { $this->_object_state(STATE_STARTING); } else { $this->_object_state(STATE_SENDING); } } sub _action_stop { $_[0]->_object_state(STATE_STOPPED); } sub _action_start { $_[0]->_object_state(STATE_STARTING); } sub _action_wait { $_[0]->_object_state(STATE_WAITING); } sub _action_read_data { my ($this, $socket) = @_; if (!fileno($socket)) { DEBUG_INFO('invalid socket'); return $this->_object_state(STATE_STOPPED); } my $object = $this->{'_decode_object'}; # Set the FSM's Net::SNMP object's socket equal to the socket $object->{'_socket'} = $socket; # Read the data if (!defined($object->_udp_recv_buffer)) { DEBUG_INFO("error [%d]", $object->error); return $this->_object_state(STATE_STOPPED); } $_[0]->_object_state(STATE_VALIDATING); } sub _action_timeout { my $this = shift; my $time = time(); foreach (@{$this->{'_pending_queue'}}) { if ($_->{'_ttd'} > $time) { last; } if ($_->{'_ttd'} == TTD_DEAD) { next; } if ($_->{'_retries'}-- > 0) { DEBUG_INFO("retry request-id = %s (%s), skew = %f, retries = %d", $_->_request_id, $_->hostname, ($time - $_->{'_ttd'}), $_->{'_retries'} ); # Update the time-to-die and queue for sending $_->{'_ttd'} += int($_->timeout); $this->_object_queue_sending($_); } else { DEBUG_INFO("timeout: request-id = %s (%s), skew = %f", $_->_request_id, $_->hostname, ($time - $_->{'_ttd'}) ); $_->{'_ttd'} = TTD_DEAD; $_->_snmp_decode_error( "No response from agent on remote host '%s'", $_->hostname ); $this->_action_callback($_); } } if (@{$this->{'_sending_queue'}}) { $this->_object_state(STATE_SENDING); } else { $this->_object_state(STATE_CLEARING); } } sub _action_validate { $_[0]->_object_state(STATE_VALIDATING); } sub _action_clear { $_[0]->_object_state(STATE_CLEARING); } sub _action_send { $_[0]->_object_state(STATE_SENDING); } sub _action_callback { if (@_ == 2) { $_[1]->_object_invoke_callback; } $_[0]->_object_state(STATE_CLEARING); } ### ## Object specific methods/functions ### sub _object_state { if (@_ == 2) { $_[0]->{'_state'} = $_[1]; } $_[0]->{'_state'}; } sub _object_queue_sending { if ((@_ == 2) && (defined($_[1]))) { push(@{$_[0]->{'_sending_queue'}}, $_[1]); return TRUE; } FALSE; } sub _object_queue_pending { if ((@_ == 2) && (defined($_[1]))) { push(@{$_[0]->{'_pending_queue'}}, $_[1]); return TRUE; } FALSE; } sub _object_clear { $_[0]->{'_pending_queue'} = []; $_[0]->{'_rin'} = ''; $_[0]->{'_sending_queue'} = []; $_[0]->{'_sockets'} = {}; $_[0]->{'_state'} = STATE_STOPPED; TRUE; } # Sort by time-to-die sub _by_ttd { $a->{'_ttd'} <=> $b->{'_ttd'}; } # ============================================================================ 1; # [end Net::SNMP::FSM] # ============================================================================ __DATA__ ### ## POD formatted documentation for Perl module Net::SNMP. ## ## $Id: Net-SNMP.pod,v 3.0.1.1 2000/01/01 17:58:04 dtown Exp $ ## $Source: /us/dtown/Projects/Net-SNMP/Net-SNMP.pod,v $ ## ### =head1 NAME Net::SNMP - Simple Network Management Protocol =head1 SYNOPSIS The module Net::SNMP implements an object oriented interface to the Simple Network Management Protocol. Perl applications can use the module to retrieve or update information on a remote host using the SNMP protocol. Net::SNMP is implemented completely in Perl, requires no compiling, and uses only standard Perl modules. Both SNMPv1 and SNMPv2c (Community-Based SNMPv2) are supported by the module. The Net::SNMP module assumes that the user has a basic understanding of the Simple Network Management Protocol and related network management concepts. =head1 DESCRIPTION The module Net::SNMP abstracts the intricate details of the Simple Network Management Protocol by providing a high level programming interface to the protocol. Each Net::SNMP object provides a one-to-one mapping between a Perl object and a remote SNMP agent or manager. Once an object is created, it can be used to perform all of the basic protocol exchange actions defined by SNMP. A Net::SNMP object can be created such that it has either "blocking" or "non-blocking" properties. By default, the methods used to send SNMP messages do not return until the protocol exchange has completed successfully or a timeout period has expired. This behavior gives the object a "blocking" property because the flow of the code is stopped until the method returns. The optional named argument "B<-nonblocking>" can be passed to the object constructor with a true value to give the object "non-blocking" behavior. A method invoked by a non-blocking object queues the SNMP message and returns immediately allowing the flow of the code to continue. The queued SNMP messages are not sent until an event loop is entered by calling the C method. When the SNMP messages are sent, any response to the messages invokes the subroutine defined by the user when the message was originally queued. The event loop exits when all messages have been removed from the queue by either receiving a response or when the number of retries for the object has been exceeded. =head2 Blocking Objects The default behavior of the methods associated with a Net::SNMP object is to block the code flow until the method completes. For methods that initiate a SNMP protocol exchange requiring a response, a hash reference containing the results of the query are returned. The undefined value is returned by all methods when a failure has occurred. The C method can be used to determine the cause of the failure. The hash reference returned by a SNMP protocol exchange points to a hash constructed from the VarBindList contained in the SNMP GetResponse-PDU. The hash is created using the ObjectName and the ObjectSyntax pairs in the VarBindList. The keys of the hash consist of the OBJECT IDENTIFIERs in dotted notation corresponding to each ObjectName in the VarBindList. The value of each hash entry is set equal to the value of the corresponding ObjectSyntax. This hash reference can also be retrieved using the C method. =head2 Non-blocking Objects When a Net::SNMP object is created having non-blocking behavior, the invocation of a method associated with the object returns immediately, allowing the flow of the code to continue. When a method is invoked that would initiate a SNMP protocol exchange requiring a response, either a true value (i.e. 0x1) is returned immediately or the undefined value is returned if there was a failure. The C method can be used to determine the cause of the failure. Most methods associated with a non-blocking object have an optional named argument called "B<-callback>". The B<-callback> argument expects a reference to a subroutine or to an array whose first element must be a reference to a subroutine. The subroutine defined by the B<-callback> option is executed when a response to a SNMP message is received, an error condition has occurred, or the number of retries for the message has been exceeded. When the B<-callback> argument only contains a subroutine reference, the subroutine is evaluated passing a copy of the original Net::SNMP object as the only parameter. The copy of the object has all of the properties that the original object had when the message was queued, and will also contain the results of the SNMP protocol exchange. If the B<-callback> argument was defined as an array reference, all elements in the array are passed to the subroutine after the copy of the Net::SNMP object. The first element, which is required to be a reference to a subroutine, is removed before the remaining arguments are passed to that subroutine. Once one method is invoked with the B<-callback> argument, this argument stays with the object and is used by any further calls to methods using the B<-callback> option if the argument is absent. The undefined value may be passed to the B<-callback> argument to delete the callback subroutine. B The subroutine being passed with the B<-callback> named argument should not cause blocking itself. This will cause all the actions in the event loop to be stopped, defeating the non-blocking property of the Net::SNMP module. The contents of the VarBindList contained in the SNMP GetResponse-PDU can be retrieved by calling the C method associated with the copy of the original object. The value returned by the C method is a hash reference created using the ObjectName and the ObjectSyntax pairs in the VarBindList. The keys of the hash consist of the OBJECT IDENTIFIERs in dotted notation corresponding to each ObjectName in the VarBindList. The value of each hash entry is set equal to the value of the corresponding ObjectSyntax. The undefined value is returned if there has been a failure and the C method may be used to determine the reason. =head1 METHODS Most methods associated with a Net::SNMP object take different parameters based on the "blocking" or "non-blocking" property of the object. When named arguments are used with methods, two different styles are supported. All examples in this documentation use the dashed-option style: $object->method(-argument => $value); However, the IO:: style is also allowed: $object->method(Argument => $value); =head2 session() - create a new Net::SNMP object ($session, $error) = Net::SNMP->session( [-hostname => $hostname,] [-community => $community,] [-port => $port,] [-nonblocking => $nonblocking,] [-version => $version,] [-timeout => $seconds,] [-retries => $count,] [-mtu => $octets,] [-translate => $translate,] [-debug => $debug] ); This is the constructor for Net::SNMP objects. In scalar context, a reference to a new Net::SNMP object is returned if the creation of the object is successful. In list context, a reference to a new Net::SNMP object and an empty error message string is returned. If a failure occurs, the object reference is returned as the undefined value. The error string may be used to determine the cause of the error. The B<-hostname>, B<-community>, B<-port>, and B<-nonblocking> arguments are basic properties of a Net::SNMP object and cannot be changed after the object is created. All other arguments have methods that allow their values to be modified after the Net::SNMP object has been created. See the methods corresponding to these named arguments for their valid ranges and default values. All arguments are optional and will take default values in the absence of a corresponding named argument. =over =item * The default value for the remote B<-hostname> is "localhost". The hostname can either be a network hostname or the dotted IP address of the host. =item * The default value for the SNMP B<-community> name is "public". =item * The default value for the destination UDP B<-port> number is 161. This is the port on which hosts using default values expect to receive all SNMP messages except for traps. Port number 162 is the default port used by hosts expecting to receive SNMP traps. =item * The default value for the B<-nonblocking> property is 0x0 (false). =back =head2 close() - clear the UDP socket reference, buffers, and errors $session->close; This method clears the UDP socket reference, the errors, hash pointers, and buffers associated with the object. Once closed, the Net::SNMP object can no longer be used to send or received SNMP messages. =head2 snmp_event_loop() - enter the non-blocking object event loop $session->snmp_event_loop; This method enters the event loop associated with non-blocking Net::SNMP objects. The method exits when all queued SNMP messages have been responded to or have timed out. This method is also exported as the stand alone function C by default (see L<"EXPORTS">). =head2 get_request() - send a SNMP get-request to the remote agent Blocking $response = $session->get_request(@oids); Non-blocking $ok = $session->get_request( [-callback => sub {},] -varbindlist => \@oids ); This method performs a SNMP get-request query to gather data from the remote agent on the host associated with the Net::SNMP object. The blocking form of the method takes a list of OBJECT IDENTIFIERs in dotted notation. Each OBJECT IDENTIFER is placed into a single SNMP GetRequest-PDU in the same order that it held in the original list. When the object is in non-blocking mode, the list is passed as an array reference to the B<-varbindlist> named argument. A reference to a hash is returned in blocking mode which contains the contents of the VarBindList. In non-blocking mode, a true value is returned when no error has occurred. In either mode the undefined value is returned when an error has occurred. The C method may be used to determine the cause of the failure. =head2 get_next_request() - send a SNMP get-next-request to the remote agent Blocking $response = $session->get_next_request(@oids); Non-blocking $ok = $session->get_next_request( [-callback => sub {},] -varbindlist => \@oids ); This method performs a SNMP get-next-request query to gather data from the remote agent on the host associated with the Net::SNMP object. The blocking form of the method takes a list of OBJECT IDENTIFIERs in dotted notation. Each OBJECT IDENTIFER is placed into a single SNMP GetNextRequest-PDU in the same order that it held in the original list. When the object is in non-blocking mode, the list is passed as an array reference to the B<-varbindlist> named argument. A reference to a hash is returned in blocking mode which contains the contents of the VarBindList. In non-blocking mode, a true value is returned when no error has occurred. In either mode the undefined value is returned when an error has occurred. The C method may be used to determine the cause of the failure. =head2 set_request() - send a SNMP set-request to the remote agent Blocking $response = $session->set_request(@oid_type_value); Non-blocking $ok = $session->set_request( [-callback => sub {},] -varbindlist => \@oid_type_value ); This method is used to modify data on the remote agent that is associated with the Net::SNMP object using a SNMP set-request. The blocking form of the method takes a list of values consisting of groups of an OBJECT IDENTIFIER, an object type, and the actual value to be set. The OBJECT IDENTIFIERs in each trio are to be in dotted notation. The object type is a byte corresponding to the ASN.1 type of value that is to be set. Each of the supported types have been defined and are exported by the package by default (see L<"EXPORTS">). When the object is in non-blocking mode, the list is passed as an array reference to the B<-varbindlist> named argument. A reference to a hash is returned in blocking mode which contains the contents of the VarBindList. In non-blocking mode, a true value is returned when no error has occurred. In either mode the undefined value is returned when an error has occurred. The C method may be used to determine the cause of the failure. =head2 trap() - send a SNMP trap to the remote manager Blocking or non-blocking $value = $session->trap( [-enterprise => $oid,] [-agentaddr => $ipaddress,] [-generictrap => $generic,] [-specifictrap => $specific,] [-timestamp => $timeticks,] [-varbindlist => \@oid_type_value] ); This method sends a SNMP trap to the remote manager associated with the Net::SNMP object. All arguments are optional and will be given the following defaults in the absence of a corresponding named argument: =over =item * The default value for the trap B<-enterprise> is "1.3.6.1.4.1", which corresponds to "iso.org.dod.internet.private.enterprises". The enterprise value is expected to be an OBJECT IDENTIFER in dotted notation. =item * The default value for the trap B<-agentaddr> is the local IP address from the host on which the script is running. The agent-addr is expected to be an IpAddress in dotted notation. =item * The default value for the B<-generictrap> type is 6 which corresponds to "enterpriseSpecific". The generic-trap types are defined and can be exported upon request (see L<"EXPORTS">). =item * The default value for the B<-specifictrap> type is 0. No pre-defined values are available for specific-trap types. =item * The default value for the trap B<-timestamp> is the "uptime" of the script. The "uptime" of the script is the number of hundredths of seconds that have elapsed since the script began running. The time-stamp is expected to be a TimeTicks number in hundredths of seconds. =item * The default value for the trap B<-varbindlist> is an empty array reference. The variable-bindings are expected to be in an array format consisting of groups of an OBJECT IDENTIFIER, an object type, and the actual value of the object. This is identical to the list expected by the C method. The OBJECT IDENTIFIERs in each trio are to be in dotted notation. The object type is a byte corresponding to the ASN.1 type for the value. Each of the supported types have been defined and are exported by default (see L<"EXPORTS">). =back Upon success, the number of bytes transmitted is returned when the object is in blocking mode. A true value is returned when successful in non-blocking mode. The undefined value is returned when a failure has occurred. The C method can be used to determine the cause of the failure. Since there are no acknowledgements for Trap-PDUs, there is no way to determine if the remote host actually received the trap. B When the object is in non-blocking mode, the trap is not sent until the event loop is entered. =head2 get_bulk_request() - send a SNMPv2 get-bulk-request to the remote agent Blocking $response = $session->get_bulk_request( [-nonrepeaters => $nonrepeaters,] [-maxrepetitions => $maxrepetitions,] -varbindlist => \@oids ); Non-blocking $ok = $session->get_bulk_request( [-callback => sub {},] [-nonrepeaters => $nonrepeaters,] [-maxrepetitions => $maxrepetitions,] -varbindlist => \@oids ); This method performs a SNMP get-bulk-request query to gather data from the remote agent on the host associated with the Net::SNMP object. All arguments are optional except B<-varbindlist> and will be given the following defaults in the absence of a corresponding named argument: =over =item * The default value for the get-bulk-request B<-nonrepeaters> is 0. The non-repeaters value specifies the number of variables in the variable-bindings list for which a single successor is to be returned. =item * The default value for the get-bulk-request B<-maxrepetitions> is 0. The max-repetitions value specifies the number of successors to be returned for the remaining variables in the variable-bindings list. =item * The B<-varbindlist> argument expects an array reference consisting of a list of OBJECT IDENTIFIERs in dotted notation. Each OBJECT IDENTIFER is placed into a single SNMP GetBulkRequest-PDU in the same order that it held in the original list. =back A reference to a hash is returned in blocking mode which contains the contents of the VarBindList. In non-blocking mode, a true value is returned when no error has occurred. In either mode the undefined value is returned when an error has occurred. The C method may be used to determine the cause of the failure. B This method can only be used when the version of the object is set to SNMPv2c. =head2 inform_request() - send a SNMPv2 inform-request to the remote manager Blocking $response = $session->inform_request(@oid_type_value); Non-blocking $ok = $session->inform_request( [-callback => sub {},] -varbindlist => \@oid_type_value ); This method is used to provide management information to the remote manager associated with the Net::SNMP object using a SNMPv2 inform-request. In blocking mode, the method takes a list of values consisting of groups of an OBJECT IDENTIFIER, an object type, and the actual value to be defined. The OBJECT IDENTIFIERs in each trio are to be in dotted notation. The object type is a byte corresponding to the ASN.1 type of value that is identified. Each of the supported types have been defined and are exported by the package by default (see L<"EXPORTS">). When the object is in non-blocking mode, the list is passed as an array reference to the B<-varbindlist> named argument. The first two variable-bindings fields in the inform-request are specified by SNMPv2 and should be: =over =item * sysUpTime.0 - ['1.3.6.1.2.1.1.3.0', TIMETICKS, $timeticks] =item * snmpTrapOID.0 - ['1.3.6.1.6.3.1.1.4.1.0', OBJECT_IDENTIFIER, $oid] =back A reference to a hash is returned in blocking mode which contains the contents of the VarBindList. In non-blocking mode, a true value is returned when no error has occurred. In either mode the undefined value is returned when an error has occurred. The C method may be used to determine the cause of the failure. B This method can only be used when the version of the object is set to SNMPv2c. =head2 snmpv2_trap() - send a SNMPv2 snmpV2-trap to the remote manager Blocking or non-blocking $value = $session->snmpv2_trap(@oid_type_value); This method sends a SNMPv2 snmpV2-trap to the remote manager associated with the Net::SNMP object. In either mode, the method takes a list of values consisting of groups of an OBJECT IDENTIFIER, an object type, and the actual value to be defined. The OBJECT IDENTIFIERs in each trio are to be in dotted notation. The object type is a byte corresponding to the ASN.1 type of value that is being identified. Each of the supported types have been defined and are exported by the package by default (see L<"EXPORTS">). The first two variable-bindings fields in the snmpV2-trap are specified by SNMPv2 and should be: =over =item * sysUpTime.0 - ['1.3.6.1.2.1.1.3.0', TIMETICKS, $timeticks] =item * snmpTrapOID.0 - ['1.3.6.1.6.3.1.1.4.1.0', OBJECT_IDENTIFIER, $oid] =back Upon success, the number of bytes transmitted is returned when the object is in blocking mode. A true value is returned when in successful in non-blocking mode. The undefined value is returned when a failure has occurred. The C method can be used to determine the cause of the failure. Since there are no acknowledgements for SNMPv2-Trap-PDUs, there is no way to determine if the remote host actually received the snmpV2-trap. B This method can only be used when the version of the object is set to SNMPv2c. B When the object is in non-blocking mode, the snmpV2-trap is not sent until the event loop is entered. =head2 get_table() - retrieve a table from the remote agent Blocking $response = $session->get_table($oid); Non-blocking $ok = $session->get_table( -baseoid => $oid, [-callback => sub {},] ); This method performs repeated SNMP get-next-request queries to gather data from the remote agent on the host associated with the Net::SNMP object. In blocking mode, the method takes a single OBJECT IDENTIFIER which is used as the base object for the SNMP get-next-requests. Repeated SNMP get-next-requests are issued until the OBJECT IDENTIFER in the response is no longer a subtree of the base OBJECT IDENTIFIER. When the object is in non-blocking mode, the OBJECT IDENTIFIER must be passed to the B<-baseoid> named argument. A reference to a hash is returned in blocking mode which contains the contents of the VarBindList. In non-blocking mode, a true value is returned when no error has occurred. In either mode the undefined value is returned when an error has occurred. The C method may be used to determine the cause of the failure. B Results from this method can become very large if the base OBJECT IDENTIFIER is close to the root of the SNMP MIB tree. =head2 version() - set or get the SNMP version for the object $rfc_version = $session->version([$version]); This method is used to set or get the current SNMP version associated with the Net::SNMP object. The module supports SNMP version-1 (SNMPv1) and SNMP version-2c (SNMPv2c). The default version used by the module is SNMP version-1. The method accepts the digit '1' or the string 'SNMPv1' for SNMP version-1 and the digit '2', or the strings '2c', 'SNMPv2', or 'SNMPv2c' for SNMP version-2c. The undefined value is returned upon an error and the C method may be used to determine the cause. The method returns the current value for the SNMP version. The returned value is the corresponding version number defined by the RFCs for the protocol version field (i.e. SNMPv1 == 0 and SNMPv2c == 1). =head2 error() - get the current error message from the object $error_message = $session->error; This method returns a text string explaining the reason for the last error. An empty string is returned if no error has occurred. =head2 hostname() - get the associated hostname from the object $hostname = $session->hostname; This method returns the hostname string that is associated with the object. =head2 error_status() - get the current SNMP error-status from the object $error_status = $session->error_status; This method returns the numeric value of the error-status contained in the last SNMP GetResponse-PDU. =head2 error_index() - get the current SNMP error-index from the object $error_index = $session->error_index; This method returns the numeric value of the error-index contained in the last SNMP GetResponse-PDU. =head2 var_bind_list() - get the hash reference to the last SNMP response $response = $session->var_bind_list; This method returns a hash reference created using the ObjectName and the ObjectSyntax pairs in the VarBindList of the last SNMP GetResponse-PDU received by the object. The keys of the hash consist of the OBJECT IDENTIFIERs in dotted notation corresponding to each ObjectName in the VarBindList. If any OBJECT IDENTIFIERs passed to the method began with a leading dot, all of the OBJECT IDENTIFIER hash keys will be prefixed with a leading dot. The value of each hash entry is set equal to the value of the corresponding ObjectSyntax. The undefined value is returned if there has been a failure and the C method may be used to determine the reason. =head2 timeout() - set or get the current timeout period for the object $seconds = $session->timeout([$seconds]); This method returns the current value for the UDP timeout for the Net::SNMP object. This value is the number of seconds that the object will wait for a response from the agent on the remote host. The default timeout is 5.0 seconds. If a parameter is specified, the timeout for the object is set to the provided value if it falls within the range 1.0 to 60.0 seconds. The undefined value is returned upon an error and the C method may be used to determine the cause. =head2 retries() - set or get the current retry count for the object $count = $session->retries([$count]); This method returns the current value for the number of times to retry sending a SNMP message to the remote host. The default number of retries is 1. If a parameter is specified, the number of retries for the object is set to the provided value if it falls within the range 0 to 20. The undefined value is returned upon an error and the C method may be used to determine the cause. =head2 mtu() - set or get the current MTU for the object $octets = $session->mtu([$octets]); This method returns the current value for the Maximum Transport Unit for the Net::SNMP object. This value is the largest value in octets for an SNMP message that can be transmitted or received by the object. The default MTU is 484 octets. If a parameter is specified, the Maximum Transport Unit is set to the provided value if it falls within the range 30 to 65535 octets. The undefined value is returned upon an error and the C method may be used to determine the cause. =head2 translate() - enable or disable the translation mode for the object $mode = $session->translate([$mode]); When the object decodes the GetResponse-PDU that is returned in response to a SNMP message, certain values are translated into a more "human readable" form. By default the following translations occur: =over =item * OCTET STRINGs containing non-printable characters are converted into a hexadecimal representation prefixed with "0x". =item * TimeTicks integer values are converted to a time format. =item * NULL values return the string "NULL" instead of an empty string. =item * noSuchObject exception values return the string "noSuchObject" instead of an empty string. If translation is not enabled, the SNMP error-status field is set to 128 which is equal to the exported definition NOSUCHOBJECT (see L<"EXPORTS">). =item * noSuchInstance exception values return the string "noSuchInstance" instead of an empty string. If translation is not enabled, the SNMP error-status field is set to 129 which is equal to the exported definition NOSUCHINSTANCE (see L<"EXPORTS">). =item * endOfMibView exception values return the string "endOfMibView" instead of an empty string. If translation is not enabled, the SNMP error-status field is set to 130 which is equal to the exported definition ENDOFMIBVIEW (see L<"EXPORTS">). =back If a parameter is specified, the translation mode is set to either enabled or disabled depending on the value of the passed parameter. Any value that Perl would treat as a true value will set the mode to be enabled, while a false value will disable translation. The current state of the translation mode is returned by the method. =head2 debug() - set or get the debug mode for the module $mode = $session->debug([$mode]); This method is used to enable or disable debugging for the Net::SNMP module. By default, debugging is off. If a parameter is specified, the debug mode is set to either enabled or disabled depending on the value of the passed parameter. Any value that Perl would treat as a true value will set the mode to be enabled, while a false value will disable debugging. The current state of the debugging mode is returned by the method. Debugging can also be enabled using the stand along function C. This function can be exported by request (see L<"EXPORTS">). =head1 FUNCTIONS =head2 oid_context_match() - determine if an OID has a specified MIB context $value = oid_context_match($base_oid, $oid); This function takes two OBJECT IDENTIFIERs in dotted notation and returns a true value (i.e. 0x1) if the second OBJECT IDENTIFIER is equal to or is a subtree of the first OBJECT IDENTIFIER in the SNMP Management Information Base (MIB). This function can be used in conjunction with the C or C methods to determine when a OBJECT IDENTIFIER in the GetResponse-PDU is no longer in the desired MIB context. =head2 oid_lex_sort() - sort a list of OBJECT IDENTIFIERs lexicographically @sorted_oids = oid_lex_sort(@oids); This function takes a list of OBJECT IDENTIFIERs in dotted notation and returns the listed sorted in lexicographical order. =head2 ticks_to_time() - convert TimeTicks to formatted time $time = ticks_to_time($timeticks); This function takes an ASN.1 TimeTicks value and returns a string representing the time defined by the value. The TimeTicks value is expected to be a non-negative integer value representing the time in hundredths of a second since some epoch. The returned string will display the time in days, hours, and seconds format according to the value of the TimeTicks argument. =head1 EXPORTS =over =item Default INTEGER, INTEGER32, OCTET_STRING, NULL, OBJECT_IDENTIFIER, IPADDRESS, COUNTER, COUNTER32, GAUGE, GAUGE32, UNSIGNED32, TIMETICKS, OPAQUE, COUNTER64, NOSUCHOBJECT, NOSUCHINSTANCE, ENDOFMIBVIEW, snmp_event_loop =item Exportable INTEGER, INTEGER32, OCTET_STRING, NULL, OBJECT_IDENTIFIER, SEQUENCE, IPADDRESS, COUNTER, COUNTER32, GAUGE, GAUGE32, UNSIGNED32, TIMETICKS, OPAQUE, COUNTER64, NOSUCHOBJECT, NOSUCHINSTANCE, ENDOFMIBVIEW, GET_REQUEST, GET_NEXT_REQUEST, GET_RESPONSE, SET_REQUEST, TRAP, GET_BULK_REQUEST, INFORM_REQUEST, SNMPV2_TRAP, COLD_START, WARM_START, LINK_DOWN, LINK_UP, AUTHENTICATION_FAILURE, EGP_NEIGHBOR_LOSS, ENTERPRISE_SPECIFIC, SNMP_VERSION_1, SNMP_VERSION_2C, SNMP_PORT, SNMP_TRAP_PORT, snmp_debug, snmp_event_loop, oid_context_match, oid_lex_sort, ticks_to_time =item Tags =over =item :asn1 INTEGER, INTEGER32, OCTET_STRING, NULL, OBJECT_IDENTIFIER, SEQUENCE, IPADDRESS, COUNTER, COUNTER32, GAUGE, GAUGE32, UNSIGNED32, TIMETICKS, OPAQUE, COUNTER64, NOSUCHOBJECT, NOSUCHINSTANCE, ENDOFMIBVIEW, GET_REQUEST, GET_NEXT_REQUEST, GET_RESPONSE, SET_REQUEST, TRAP, GET_BULK_REQUEST, INFORM_REQUEST, SNMPV2_TRAP =item :generictrap COLD_START, WARM_START, LINK_DOWN, LINK_UP, AUTHENTICATION_FAILURE, EGP_NEIGHBOR_LOSS, ENTERPRISE_SPECIFIC =item :snmp SNMP_VERSION_1, SNMP_VERSION_2C, SNMP_PORT, SNMP_TRAP_PORT, snmp_debug, snmp_event_loop, oid_context_match, oid_lex_sort, ticks_to_time =item :ALL All of the above exportable items. =back =back =head1 EXAMPLES =head2 Blocking get-request for sysUpTime This example gets the sysUpTime from a remote host: #! /usr/local/bin/perl use strict; use vars qw($hostname $community $port $session $error $response); use Net::SNMP; $hostname = shift || 'localhost'; $community = shift || 'public'; $port = shift || 161; ($session, $error) = Net::SNMP->session( -hostname => $hostname, -community => $community, -port => $port ); if (!defined($session)) { printf("ERROR: %s.\n", $error); exit 1; } my $sysUpTime = '1.3.6.1.2.1.1.3.0'; if (!defined($response = $session->get_request($sysUpTime))) { printf("ERROR: %s.\n", $session->error); $session->close; exit 1; } printf("sysUpTime for host '%s' is %s\n", $hostname, $response->{$sysUpTime} ); $session->close; exit 0; =head2 Blocking set-request of sysContact This example sets the sysContact information on the remote host to "Help Desk": #! /usr/local/bin/perl use strict; use vars qw($hostname $community $port $session $error $response); use Net::SNMP; $hostname = shift || 'localhost'; $community = shift || 'private'; $port = shift || 161; ($session, $error) = Net::SNMP->session( -hostname => $hostname, -community => $community, -port => $port ); if (!defined($session)) { printf("ERROR: %s.\n", $error); exit 1; } my $sysContact = '1.3.6.1.2.1.1.4.0'; my $contact = 'Help Desk'; $response = $session->set_request($sysContact, OCTET_STRING, $contact); if (!defined($response)) { printf("ERROR: %s.\n", $session->error); $session->close; exit 1; } printf("sysContact for host '%s' set to '%s'\n", $hostname, $response->{$sysContact} ); $session->close; exit 0; =head2 Non-blocking get-request for sysUpTime on multiple hosts This example polls several hosts for their sysUpTime using non-blocking objects and reports a warning if this value is less than the value from the last poll: #! /usr/local/bin/perl use strict; use vars qw(@hosts @sessions $polls $last_poll_time $sleep); use Net::SNMP qw(snmp_event_loop ticks_to_time); # List of hosts to poll @hosts = qw(1.1.1.1 1.1.1.2 localhost); # Poll interval (in seconds). This value should be greater than # the number of retries times the timeout value. my $interval = 60; # Maximum number of polls my $max_polls = 10; # Create a session for each host foreach (@hosts) { my ($session, $error) = Net::SNMP->session( -hostname => $_, -nonblocking => 0x1, # Create non-blocking objects -translate => 0x0 # Turn off so sysUpTime is numeric ); if (!defined($session)) { printf("ERROR: %s.\n", $error); foreach (@sessions) { $_->[0]->close; } exit 1; } # Create an array of arrays which contain the new object, # and the last sysUpTime. push(@sessions, [$session, 0]); } my $sysUpTime = '1.3.6.1.2.1.1.3.0'; while (++$polls <= $max_polls) { $last_poll_time = time(); # Queue each of the queries for sysUpTime foreach (@sessions) { $_->[0]->get_request( -varbindlist => [$sysUpTime], -callback => [\&validate_sysUpTime_cb, \$_->[1]] ); } # Enter the event loop snmp_event_loop(); # Sleep until the next poll time $sleep = $interval - (time() - $last_poll_time); if (($sleep < 1) || ($polls >= $max_polls)) { next; } sleep($sleep); print "\n"; } # Not necessary, but it is nice to clean up after yourself foreach (@sessions) { $_->[0]->close; } exit 0; sub validate_sysUpTime_cb { my ($this, $last_uptime) = @_; if (!defined($this->var_bind_list)) { printf("%-15s ERROR: %s\n", $this->hostname, $this->error); } else { my $uptime = $this->var_bind_list->{$sysUpTime}; if ($uptime < ${$last_uptime}) { printf("%-15s WARNING: %s is less than %s\n", $this->hostname, ticks_to_time($uptime), ticks_to_time(${$last_uptime}) ); } else { printf("%-15s Ok (%s)\n", $this->hostname, ticks_to_time($uptime) ); } # Store the new sysUpTime ${$last_uptime} = $uptime; } $this->error_status; } =head1 AUTHOR David M. Town =head1 ACKNOWLEDGMENTS The original concept for this module was based on F written by Simon Leinen . The Abstract Syntax Notation One (ASN.1) encode and decode methods were derived by example from the CMU SNMP package whose copyright follows: Copyright (c) 1988, 1989, 1991, 1992 by Carnegie Mellon University. All rights reserved. =head1 COPYRIGHT Copyright (c) 1998-2000 David M. Town. All rights reserved. This program is free software; you may redistribute it and/or modify it under the same terms as Perl itself. cisco-auditing-tool-1.0/lib/Net/.svn/text-base/Telnet.pm.svn-base0000444000000000000000000032505412046511414023314 0ustar rootrootpackage Net::Telnet; require 5.002; ## User documentation in POD format is at end of this file. Search for =head use strict; ## Module export. use vars qw(@EXPORT_OK); @EXPORT_OK = qw(TELNET_IAC TELNET_DONT TELNET_DO TELNET_WONT TELNET_WILL TELNET_SB TELNET_GA TELNET_EL TELNET_EC TELNET_AYT TELNET_AO TELNET_IP TELNET_BREAK TELNET_DM TELNET_NOP TELNET_SE TELNET_EOR TELNET_ABORT TELNET_SUSP TELNET_EOF TELNET_SYNCH TELOPT_BINARY TELOPT_ECHO TELOPT_RCP TELOPT_SGA TELOPT_NAMS TELOPT_STATUS TELOPT_TM TELOPT_RCTE TELOPT_NAOL TELOPT_NAOP TELOPT_NAOCRD TELOPT_NAOHTS TELOPT_NAOHTD TELOPT_NAOFFD TELOPT_NAOVTS TELOPT_NAOVTD TELOPT_NAOLFD TELOPT_XASCII TELOPT_LOGOUT TELOPT_BM TELOPT_DET TELOPT_SUPDUP TELOPT_SUPDUPOUTPUT TELOPT_SNDLOC TELOPT_TTYPE TELOPT_EOR TELOPT_TUID TELOPT_OUTMRK TELOPT_TTYLOC TELOPT_3270REGIME TELOPT_X3PAD TELOPT_NAWS TELOPT_TSPEED TELOPT_LFLOW TELOPT_LINEMODE TELOPT_XDISPLOC TELOPT_OLD_ENVIRON TELOPT_AUTHENTICATION TELOPT_ENCRYPT TELOPT_NEW_ENVIRON TELOPT_EXOPL); ## Module import. use Exporter (); use Socket qw(AF_INET SOCK_STREAM inet_aton sockaddr_in); use Symbol qw(qualify); ## Base class. use vars qw(@ISA); @ISA = qw(Exporter); if (eval 'require IO::Socket') { push @ISA, 'IO::Socket::INET'; } else { require FileHandle; push @ISA, 'FileHandle'; } ## Global variables. use vars qw($Default_blocksize $VERSION @Telopts); $Default_blocksize = 8192; $VERSION = "3.01"; @Telopts = ("BINARY", "ECHO", "RCP", "SUPPRESS GO AHEAD", "NAME", "STATUS", "TIMING MARK", "RCTE", "NAOL", "NAOP", "NAOCRD", "NAOHTS", "NAOHTD", "NAOFFD", "NAOVTS", "NAOVTD", "NAOLFD", "EXTEND ASCII", "LOGOUT", "BYTE MACRO", "DATA ENTRY TERMINAL", "SUPDUP", "SUPDUP OUTPUT", "SEND LOCATION", "TERMINAL TYPE", "END OF RECORD", "TACACS UID", "OUTPUT MARKING", "TTYLOC", "3270 REGIME", "X.3 PAD", "NAWS", "TSPEED", "LFLOW", "LINEMODE", "XDISPLOC", "OLD-ENVIRON", "AUTHENTICATION", "ENCRYPT", "NEW-ENVIRON"); ########################### Public Methods ########################### sub new { my($class) = @_; my( $fh_open, $host, $self, %args, ); local $_; ## Create a new object with defaults. $self = $class->SUPER::new; $ {*$self}{net_telnet} = { bin_mode => 0, blksize => $Default_blocksize, buf => "", cmd_prompt => '/[\$%#>] $/', cmd_rm_mode => "auto", dumplog => '', eofile => 1, errormode => 'die', errormsg => "", fdmask => '', host => "localhost", inputlog => '', last_line => "", maxbufsize => 1024 * 1024, num_wrote => 0, ofs => "", opened => '', opt_cback => '', opt_log => '', opts => {}, ors => "\n", outputlog => '', port => 23, pushback_buf => "", rs => "\n", telnet_mode => 1, time_out => 10, timedout => '', unsent_opts => "", }; ## Indicate that we'll accept an offer from remote side for it to echo ## and suppress go aheads. &_opt_accept($self, { option => &TELOPT_ECHO, is_remote => 1, is_enable => 1 }, { option => &TELOPT_SGA, is_remote => 1, is_enable => 1 }, ); ## Parse the args. if (@_ == 2) { # one positional arg given $host = $_[1]; } elsif (@_ > 2) { # named args given ## Get the named args. (undef, %args) = @_; ## Parse the errmode named arg first. foreach (keys %args) { $self->errmode($args{$_}) if /^-?errmode$/i; } ## Parse all other named args. foreach (keys %args) { if (/^-?binmode$/i) { $self->binmode($args{$_}); } elsif (/^-?cmd_remove_mode$/i) { $self->cmd_remove_mode($args{$_}); } elsif (/^-?dump_log$/i) { $self->dump_log($args{$_}); } elsif (/^-?errmode$/i) { next; } elsif (/^-?fhopen$/i) { $fh_open = $args{$_}; } elsif (/^-?host$/i) { $host = $args{$_}; } elsif (/^-?input_log$/i) { $self->input_log($args{$_}); } elsif (/^-?input_record_separator$/i) { $self->input_record_separator($args{$_}); } elsif (/^-?option_log$/i) { $self->option_log($args{$_}); } elsif (/^-?output_log$/i) { $self->output_log($args{$_}); } elsif (/^-?output_record_separator$/i) { $self->output_record_separator($args{$_}); } elsif (/^-?port$/i) { $self->port($args{$_}) or return; } elsif (/^-?prompt$/i) { $self->prompt($args{$_}) or return; } elsif (/^-?telnetmode$/i) { $self->telnetmode($args{$_}); } elsif (/^-?timeout$/i) { $self->timeout($args{$_}); } else { $self->error('usage: Net::Telnet->new(' . '[Binmode => $mode,] ' . '[Cmd_remove_mode => $mode,] ' . '[Dump_Log => $filename,] ' . '[Errmode => $errmode,] ' . '[Fhopen => $filehandle,] ' . '[Host => $host,] ' . '[Input_log => $file,] ' . '[Input_record_separator => $char,] ' . '[Option_log => $file,] ' . '[Output_log => $file,] ' . '[Output_record_separator => $char,] '. '[Port => $port,] ' . '[Prompt => $matchop,] ' . '[Telnetmode => $mode,] ' . '[Timeout => $secs,])'); } } } if (defined $fh_open) { # user wants us to attach to existing filehandle $self->fhopen($fh_open) or return; } elsif (defined $host) { # user wants us to open a connection to host $self->host($host); $self->open or return; } $self; } # end sub new sub DESTROY { } # end sub DESTROY sub binmode { my($self, $mode) = @_; my( $prev, $stream, ); $stream = $ {*$self}{net_telnet}; $prev = $stream->{bin_mode}; if (@_ >= 2) { $mode = 0 unless defined $mode; $stream->{bin_mode} = $mode; } $prev; } # end sub binmode sub break { my($self) = @_; my $stream = $ {*$self}{net_telnet}; $stream->{timedout} = ''; return if $stream->{eofile}; local $stream->{ors} = ''; $self->print("\xff\xf3"); } # end sub break sub buffer { my($self) = @_; my $stream = $ {*$self}{net_telnet}; \$stream->{buf}; } # end sub buffer sub buffer_empty { my($self) = @_; my( $buffer, ); $buffer = $self->buffer; $$buffer = ""; } # end sub buffer_empty sub close { my($self) = @_; my $stream = $ {*$self}{net_telnet}; $stream->{eofile} = 1; $stream->{opened} = ''; close $self if defined fileno($self); 1; } # end sub close sub cmd { my($self, @args) = @_; my( $arg, $buf, $cmd_remove_mode, $firstpos, $lastpos, $lines, $orig_errmode, $orig_prompt, $orig_timeout, $output, $output_ref, $prompt, $remove_echo, $rs, $rs_len, $telopt_echo, $timeout, @cmd, ); local $_; ## Init vars. $output = []; $cmd_remove_mode = $self->cmd_remove_mode; $timeout = $self->timeout; $self->timed_out(''); return if $self->eof; ## Parse args. if (@_ == 2) { # one positional arg given push @cmd, $_[1]; } elsif (@_ > 2) { # named args given ## Parse the named args. while (($_, $arg) = splice @args, 0, 2) { if (/^-?cmd_remove/i) { $cmd_remove_mode = $arg; $cmd_remove_mode = "auto" if $cmd_remove_mode =~ /^auto/i; } elsif (/^-?output$/i) { $output_ref = $arg; if (defined($output_ref) and ref($output_ref) eq "ARRAY") { $output = $output_ref; } } elsif (/^-?prompt$/i) { $prompt = $arg; } elsif (/^-?string$/i) { push @cmd, $arg; } elsif (/^-?timeout$/i) { $timeout = &_parse_timeout($arg); } else { return $self->error('usage: $obj->cmd(', '[Cmd_remove => $boolean,] ', '[Output => $ref,] ', '[Prompt => $match,] ', '[String => $string,] ', '[Timeout => $secs,])'); } } } ## Override some user settings. $orig_errmode = $self->errmode('return'); $orig_timeout = $self->timeout(&_endtime($timeout)); $orig_prompt = $self->prompt($prompt) if defined $prompt; $self->errmsg(''); ## Send command and wait for the prompt. $self->print(@cmd) and ($lines) = $self->waitfor($self->prompt); ## Restore user settings. $self->errmode($orig_errmode); $self->timeout($orig_timeout); $self->prompt($orig_prompt) if defined $orig_prompt; ## Check for failure. return $self->error("command timed-out") if $self->timed_out; return $self->error($self->errmsg) if $self->errmsg ne ''; return if $self->eof; ## Split lines into an array, keeping record separator at end of line. $firstpos = 0; $rs = $self->input_record_separator; $rs_len = length $rs; while (($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); } ## Determine if we should remove the first line of output based ## on the assumption that it's an echoed back command. if ($cmd_remove_mode eq "auto") { ## See if remote side told us they'd echo. $telopt_echo = $self->option_state(&TELOPT_ECHO); $remove_echo = $telopt_echo->{remote_enabled}; } else { # user explicitly told us how many lines to remove. $remove_echo = $cmd_remove_mode; } ## Get rid of possible echo back command. while ($remove_echo--) { 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 = (''); } ## 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 : 1; } # end sub cmd sub cmd_remove_mode { my($self, $mode) = @_; my( $prev, $stream, ); $stream = $ {*$self}{net_telnet}; $prev = $stream->{cmd_rm_mode}; if (@_ >= 2) { if (! defined $mode) { $mode = 0; } elsif ($mode =~ /^auto/i) { $mode = "auto"; } else { ## Ensure it's a non-negative integer. eval { local $^W = 1; local $SIG{'__WARN__'} = sub { die "non-numeric\n" }; local $SIG{'__DIE__'} = 'DEFAULT'; $mode = abs(int $mode); }; if ($@) { $mode = 0; } } $stream->{cmd_rm_mode} = $mode; } $prev; } # end sub cmd_remove_mode sub dump_log { my($self, $name) = @_; my( $fh, $stream, ); $stream = $ {*$self}{net_telnet}; $fh = $stream->{dumplog}; if (@_ >= 2) { $fh = &_fname_to_handle($self, $name); $stream->{dumplog} = $fh; } $fh; } # end sub dump_log sub eof { my($self) = @_; $ {*$self}{net_telnet}{eofile}; } # end sub eof sub errmode { my($self, $mode) = @_; my( $prev, $stream, ); $stream = $ {*$self}{net_telnet}; $prev = $stream->{errormode}; if (@_ >= 2) { ## Set the error mode. defined $mode or $mode = ''; if (ref($mode) eq 'CODE') { $stream->{errormode} = $mode; } elsif (ref($mode) eq 'ARRAY') { unless (ref($mode->[0]) eq 'CODE') { &_carp($self, 'bad errmode: first item in list must be a code ref'); $mode = 'die'; } $stream->{errormode} = $mode; } elsif ($mode =~ /^return$/i) { $stream->{errormode} = 'return'; } else { $stream->{errormode} = 'die'; } } $prev; } # end sub errmode sub errmsg { my($self, @errmsgs) = @_; my( $prev, $stream, ); $stream = $ {*$self}{net_telnet}; $prev = $stream->{errormsg}; if (@_ >= 2) { $stream->{errormsg} = join '', @errmsgs; } $prev; } # end sub errmsg sub error { my($self, @errmsg) = @_; my( $errmsg, $func, $mode, $stream, @args, ); $stream = $ {*$self}{net_telnet}; if (@_ >= 2) { ## Put error message in the object. $errmsg = join '', @errmsg; $stream->{errormsg} = $errmsg; ## Do the error action as described by error mode. $mode = $stream->{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 $stream->{errormsg} ne ''; } } # end sub error sub fhopen { my($self, $fh) = @_; my( $blksize, $globref, $stream, ); ## Convert given filehandle to a typeglob reference, if necessary. $globref = &_qualify_fh($self, $fh); ## Ensure filehandle is already open. return $self->error("fhopen filehandle isn't already open") unless defined($globref) and defined(fileno $globref); ## Ensure we're closed. $self->close; ## Save our private data. $stream = $ {*$self}{net_telnet}; ## Switch ourself with the given filehandle. *$self = *$globref; ## Restore our private data. $ {*$self}{net_telnet} = $stream; ## Re-initialize ourself. $self->autoflush; $stream = $ {*$self}{net_telnet}; $blksize = (stat $self)[11]; $stream->{blksize} = $blksize || $Default_blocksize; $stream->{buf} = ""; $stream->{cmd_rm_mode} = 0; $stream->{eofile} = ''; $stream->{errormsg} = ""; vec($stream->{fdmask}='', fileno($self), 1) = 1; $stream->{host} = ""; $stream->{last_line} = ""; $stream->{num_wrote} = 0; $stream->{opened} = 1; $stream->{port} = ''; $stream->{pushback_buf} = ""; $stream->{telnet_mode} = 0; $stream->{timedout} = ''; $stream->{unsent_opts} = ""; &_reset_options($stream->{opts}); 1; } # end sub fhopen sub get { my($self, %args) = @_; my( $endtime, $line, $stream, $timeout, ); local $_; ## Init vars. $stream = $ {*$self}{net_telnet}; $timeout = $stream->{time_out}; $stream->{timedout} = ''; return if $stream->{eofile}; ## Parse the named args. foreach (keys %args) { if (/^-?timeout$/i) { $timeout = &_parse_timeout($args{$_}); } else { return $self->error('usage: $obj->get([Timeout => $secs,])'); } } ## Set wall time when we time out. $endtime = &_endtime($timeout); ## Try to send any waiting option negotiation. if (length $stream->{unsent_opts}) { &_flush_opts($self, $stream); } ## Try to read just the waiting data using return error mode. { local $stream->{errormode} = 'return'; $stream->{errormsg} = ''; &_fillbuf($self, $stream, 0); } ## We're done if we timed-out and timeout value is set to "poll". return if $stream->{timedout} and defined($timeout) and $timeout == 0; ## We're done if we hit an error other than timing out. return $self->error($stream->{errormsg}) if $stream->{errormsg} and ! $stream->{timedout}; ## If buffer is still empty, try to read according to user's timeout. if (! length $stream->{buf}) { &_fillbuf($self, $stream, $endtime) or do { return if $stream->{timedout}; ## We've reached end-of-file. $self->close; return; }; } ## Extract chars from buffer. $line = $stream->{buf}; $stream->{buf} = ''; $line; } # end sub get sub getline { my($self, %args) = @_; my( $endtime, $len, $line, $offset, $pos, $stream, $timeout, ); local $_; ## Init vars. $stream = $ {*$self}{net_telnet}; $timeout = $stream->{time_out}; $stream->{timedout} = ''; return if $stream->{eofile}; ## Parse the named args. foreach (keys %args) { if (/^-?timeout$/i) { $timeout = &_parse_timeout($args{$_}); } else { return $self->error('usage: $obj->getline([Timeout => $secs,])'); } } ## Set wall time when we time out. $endtime = &_endtime($timeout); ## Try to send any waiting option negotiation. if (length $stream->{unsent_opts}) { &_flush_opts($self, $stream); } ## Keep reading into buffer until end-of-line is read. $offset = 0; while (($pos = index($stream->{buf}, $stream->{rs}, $offset)) == -1) { $offset = length $stream->{buf}; &_fillbuf($self, $stream, $endtime) or do { return if $stream->{timedout}; ## We've reached end-of-file. $self->close; if (length $stream->{buf}) { return $stream->{buf}; } else { return; } }; } ## Extract line from buffer. $len = $pos + length $stream->{rs}; $line = substr($stream->{buf}, 0, $len); substr($stream->{buf}, 0, $len) = ''; $line; } # end sub getline sub getlines { my($self) = @_; my( $len, $line, $pos, $stream, @lines, ); $stream = $ {*$self}{net_telnet}; ## Fill buffer and get first line. $line = getline(@_) or return; push @lines, $line; ## Extract subsequent lines from buffer. while (($pos = index($stream->{buf}, $stream->{rs})) != -1) { $len = $pos + length $stream->{rs}; push @lines, substr($stream->{buf}, 0, $len); substr($stream->{buf}, 0, $len) = ''; } @lines; } # end sub getlines sub host { my($self, $host) = @_; my( $prev, $stream, ); $stream = $ {*$self}{net_telnet}; $prev = $stream->{host}; if (@_ >= 2) { $host = '' unless defined $host and length $host; $stream->{host} = $host; } $prev; } # end sub host sub input_log { my($self, $name) = @_; my( $fh, $prev, $stream, ); $stream = $ {*$self}{net_telnet}; $prev = $stream->{inputlog}; if (@_ >= 2) { $fh = &_fname_to_handle($self, $name); $stream->{inputlog} = $fh; } $prev; } # end sub input_log sub input_record_separator { my($self, $rs) = @_; my( $prev, $stream, ); $stream = $ {*$self}{net_telnet}; $prev = $stream->{rs}; if (@_ >= 2) { defined $rs or $rs = ''; $stream->{rs} = $rs; } $prev; } # end sub input_record_separator sub lastline { my($self, $line) = @_; my( $prev, $stream, ); $stream = $ {*$self}{net_telnet}; $prev = $stream->{last_line}; if (@_ >= 2) { defined $line or $line = ''; $stream->{last_line} = $line; } $prev; } # end sub lastline sub login { my($self) = @_; my( $cmd_prompt, $endtime, $error, $lastline, $match, $orig_errmode, $orig_timeout, $passwd, $prematch, $reset, $timeout, $usage, $username, %args, ); local $_; ## Init vars. $timeout = $self->timeout; $self->timed_out(''); return if $self->eof; $cmd_prompt = $self->prompt; $usage = 'usage: $obj->login(Name => $name, Password => $password, ' . '[Prompt => $match,] [Timeout => $secs,])'; if (@_ == 3) { # just username and passwd given $username = $_[1]; $passwd = $_[2]; } else { # named args given ## Get the named args. (undef, %args) = @_; ## Parse the named args. foreach (keys %args) { if (/^-?name$/i) { $username = $args{$_}; defined($username) or $username = ""; } elsif (/^-?pass/i) { $passwd = $args{$_}; defined($passwd) or $passwd = ""; } elsif (/^-?prompt$/i) { $cmd_prompt = $args{$_}; defined $cmd_prompt or $cmd_prompt = ''; return $self->error("bad match operator: ", "opening delimiter missing: $cmd_prompt") unless ($cmd_prompt =~ m(^\s*/) or $cmd_prompt =~ m(^\s*m\s*\W)); } elsif (/^-?timeout$/i) { $timeout = &_parse_timeout($args{$_}); } else { return $self->error($usage); } } } return $self->error($usage) unless defined($username) and defined($passwd); ## Override these user set-able values. $endtime = &_endtime($timeout); $orig_timeout = $self->timeout($endtime); $orig_errmode = $self->errmode('return'); ## Create a subroutine to reset to original values. $reset = sub { $self->errmode($orig_errmode); $self->timeout($orig_timeout); 1; }; ## Create a subroutine to generate an error for user. $error = sub { my($errmsg) = @_; &$reset; 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($self->errmsg); } }; ## Wait for login prompt. $self->waitfor(-match => '/login[: ]*$/i', -match => '/username[: ]*$/i') or do { return &$error("read eof waiting for login prompt") if $self->eof; return &$error("timed-out waiting for login prompt"); }; ## Send login name. $self->print($username) or return &$error("login disconnected"); ## Wait for password prompt. $self->waitfor(-match => '/password[: ]*$/i') or do { return &$error("read eof waiting for password prompt") if $self->eof; return &$error("timed-out waiting for password prompt"); }; ## Send password. $self->print($passwd) or return &$error("login disconnected"); ## Wait for command prompt or another login prompt. ($prematch, $match) = $self->waitfor(-match => '/login[: ]*$/i', -match => '/username[: ]*$/i', -match => $cmd_prompt) or do { return &$error("read eof waiting for command prompt") if $self->eof; return &$error("timed-out waiting for command prompt"); }; ## Reset object to orig values. &$reset; ## It's a bad login if we got another login prompt. return $self->error("login failed: bad name or password") if $match =~ /login[: ]*$/i or $match =~ /username[: ]*$/i; 1; } # end sub login sub max_buffer_length { my($self, $maxbufsize) = @_; my( $minbufsize, $prev, $stream, ); $stream = $ {*$self}{net_telnet}; $prev = $stream->{maxbufsize}; $minbufsize = 512; if (@_ >= 2) { ## Ensure a valid max length. unless (defined $maxbufsize) { $maxbufsize = $minbufsize; } ## Test for non-numeric or negative values. eval { local $^W = 1; local $SIG{'__WARN__'} = sub { die "non-numeric\n" }; local $SIG{'__DIE__'} = 'DEFAULT'; $maxbufsize *= 1; }; if ($@ or $maxbufsize < $minbufsize) { $maxbufsize = $minbufsize; } $stream->{maxbufsize} = $maxbufsize; } $prev; } # end sub max_buffer_length sub open { my($self) = @_; my( $blksize, $errno, $host, $ip_addr, $port, $stream, $timeout, %args, ); local $_; ## Init vars. $stream = $ {*$self}{net_telnet}; $timeout = $stream->{time_out}; $stream->{timedout} = ''; if (@_ == 2) { # one positional arg given $self->host($_[1]); } elsif (@_ > 2) { # named args given ## Get the named args. (undef, %args) = @_; ## Parse the named args. foreach (keys %args) { if (/^-?host$/i) { $self->host($args{$_}); } elsif (/^-?port$/i) { $self->port($args{$_}) or return; } elsif (/^-?timeout$/i) { $timeout = &_parse_timeout($args{$_}); } else { return $self->error('usage: $obj->open([Host => $host,] ', '[Port => $service,] ', '[Timeout => secs,])'); } } } ## Get host and port. $host = $self->host; $port = $self->port; ## Ensure we're already closed. $self->close; ## Don't use a timeout if we can't use the alarm signal. unless (&_have_alarm) { $timeout = undef; } if (defined $timeout) { # use a timeout ## Ensure a valid timeout value for alarm. if ($timeout < 1) { $timeout = 1; } $timeout = int($timeout + 1.5); ## Connect to server, timing out if it takes too long. eval { ## Turn on timer. local $SIG{'__DIE__'} = 'DEFAULT'; local $SIG{ALRM} = sub { die "timed-out\n" }; alarm $timeout; ## Lookup server's IP address. $ip_addr = inet_aton $host or die "unknown remote host: $host\n"; ## Create a socket and attach the filehandle to it. socket $self, AF_INET, SOCK_STREAM, 0 or die "problem creating socket: $!\n"; ## Open connection to server. connect $self, sockaddr_in($port, $ip_addr) or die "problem connecting to \"$host\", port $port: $!\n"; }; alarm 0; ## Check for error. if ($@ =~ /^timed-out$/) { # time out failure $stream->{timedout} = 1; $self->close; if (! $ip_addr) { return $self->error("unknown remote host: $host: ", "name lookup timed-out"); } else { return $self->error("problem connecting to \"$host\", ", "port $port: connection timed-out"); } } elsif ($@) { # hostname lookup or connect failure $self->close; chomp $@; return $self->error($@); } } else { # don't use a timeout ## Lookup server's IP address. $ip_addr = inet_aton $host or return $self->error("unknown remote host: $host"); ## Create a socket and attach the filehandle to it. socket $self, AF_INET, SOCK_STREAM, 0 or return $self->error("problem creating socket: $!"); ## Open connection to server. connect $self, sockaddr_in($port, $ip_addr) or do { $errno = "$!"; $self->close; return $self->error("problem connecting to \"$host\", ", "port $port: $errno"); }; } $self->autoflush; $blksize = (stat $self)[11]; $stream->{blksize} = $blksize || $Default_blocksize; $stream->{buf} = ""; $stream->{eofile} = ''; $stream->{errormsg} = ""; vec($stream->{fdmask}='', fileno($self), 1) = 1; $stream->{last_line} = ""; $stream->{num_wrote} = 0; $stream->{opened} = 1; $stream->{pushback_buf} = ""; $stream->{timedout} = ''; $stream->{unsent_opts} = ""; &_reset_options($stream->{opts}); 1; } # end sub open sub option_accept { my($self, @args) = @_; my( $arg, $option, $stream, @opt_args, ); local $_; ## Init vars. $stream = $ {*$self}{net_telnet}; ## Parse the named args. while (($_, $arg) = splice @args, 0, 2) { ## Verify and save arguments. if (/^-?do$/i) { ## Make sure a callback is defined. return $self->error("usage: an option callback must already ", "be defined when enabling with $_") unless $stream->{opt_cback}; $option = &_verify_telopt_arg($self, $arg, $_) or return; push @opt_args, { option => $option, is_remote => '', is_enable => 1, }; } elsif (/^-?dont$/i) { $option = &_verify_telopt_arg($self, $arg, $_) or return; push @opt_args, { option => $option, is_remote => '', is_enable => '', }; } elsif (/^-?will$/i) { ## Make sure a callback is defined. return $self->error("usage: an option callback must already ", "be defined when enabling with $_") unless $stream->{opt_cback}; $option = &_verify_telopt_arg($self, $arg, $_) or return; push @opt_args, { option => $option, is_remote => 1, is_enable => 1, }; } elsif (/^-?wont$/i) { $option = &_verify_telopt_arg($self, $arg, $_) or return; push @opt_args, { option => $option, is_remote => 1, is_enable => '', }; } else { return $self->error('usage: $obj->option_accept(' . '[Do => $telopt,] ', '[Dont => $telopt,] ', '[Will => $telopt,] ', '[Wont => $telopt,]'); } } ## Set "receive ok" for options specified. &_opt_accept($self, @opt_args); } # end sub option_accept sub option_callback { my($self, $callback) = @_; my( $prev, $stream, ); $stream = $ {*$self}{net_telnet}; $prev = $stream->{opt_cback}; if (@_ >= 2) { return $self->error("actual argument is not a code ref") unless defined $callback and ref($callback) eq "CODE"; $stream->{opt_cback} = $callback; } $prev; } # end sub option_callback sub option_log { my($self, $name) = @_; my( $fh, $prev, $stream, ); $stream = $ {*$self}{net_telnet}; $prev = $stream->{opt_log}; if (@_ >= 2) { $fh = &_fname_to_handle($self, $name); $stream->{opt_log} = $fh; } $prev; } # end sub option_log sub option_state { my($self, $option) = @_; my( $opt_state, $stream, %opt_state, ); ## Ensure telnet option is non-negative integer. $option = &_verify_telopt_arg($self, $option) or return; ## Init vars. $stream = $ {*$self}{net_telnet}; unless (defined $stream->{opts}{$option}) { &_set_default_option($stream, $option); } ## Return hashref to a copy of the values. $opt_state = $stream->{opts}{$option}; %opt_state = %$opt_state; \%opt_state; } # end sub option_state sub output_field_separator { my($self, $ofs) = @_; my( $prev, $stream, ); $stream = $ {*$self}{net_telnet}; $prev = $stream->{ofs}; if (@_ >= 2) { defined $ofs or $ofs = ''; $stream->{ofs} = $ofs; } $prev; } # end sub output_field_separator sub output_log { my($self, $name) = @_; my( $fh, $prev, $stream, ); $stream = $ {*$self}{net_telnet}; $prev = $stream->{outputlog}; if (@_ >= 2) { $fh = &_fname_to_handle($self, $name); $stream->{outputlog} = $fh; } $prev; } # end sub output_log sub output_record_separator { my($self, $ors) = @_; my( $prev, $stream, ); $stream = $ {*$self}{net_telnet}; $prev = $stream->{ors}; if (@_ >= 2) { defined $ors or $ors = ''; $stream->{ors} = $ors; } $prev; } # end sub output_record_separator sub port { my($self, $port) = @_; my( $prev, $service, $stream, ); $stream = $ {*$self}{net_telnet}; $prev = $stream->{port}; if (@_ >= 2) { return $self->error("bad port number: 0") unless defined $port and $port; ## Convert service to a port number. if ($port !~ /^\d+$/) { # port isn't all digits $service = $port; $port = getservbyname($service, 'tcp') or return $self->error("unknown TCP service: $service"); } $stream->{port} = $port; } $prev; } # end sub port sub print { my($self) = shift; my( $data, $endtime, $fh, $len, $nfound, $nwrote, $offset, $ready, $stream, $timed_out, $timeout, ); $stream = $ {*$self}{net_telnet}; $stream->{timedout} = ''; $stream->{num_wrote} = 0; return $self->error("print failed: handle is closed") unless $stream->{opened}; ## Try to send any waiting option negotiation. if (length $stream->{unsent_opts}) { &_flush_opts($self, $stream); } ## Add field and record separators. $data = join($stream->{ofs}, @_) . $stream->{ors}; ## If requested, log the output. if ($stream->{outputlog}) { local $\ = ''; $fh = $stream->{outputlog}; $fh->print($data); } ## Convert newlines to carriage-return and linefeed. $data =~ s(\n)(\015\012)g unless $stream->{bin_mode}; $offset = 0; $len = length $data; $endtime = &_endtime($stream->{time_out}); while ($len) { ## Set how long to wait for output ready. ($timed_out, $timeout) = &_timeout_interval($endtime); if ($timed_out) { $stream->{timedout} = 1; return $self->error("print timed-out"); } ## Wait for output ready. $nfound = select '', $ready=$stream->{fdmask}, '', $timeout; if ($nfound > 0) { # data can be written if ($nwrote = syswrite $self, $data, $len, $offset) { ## If requested, display network traffic. ($stream->{dumplog}) and &_log_dump('>', $stream->{dumplog}, \$data, $offset, $nwrote); $stream->{num_wrote} += $nwrote; $offset += $nwrote; $len -= $nwrote; next; } elsif (! defined $nwrote) { # write failed next if $! =~ /^Interrupted/; $stream->{opened} = ''; return $self->error("unexpected write error: $!"); } else { # zero chars written $stream->{opened} = ''; return $self->error("unexpected zero length write error: $!"); } } elsif ($nfound < 0) { # select failure next if $! =~ /^Interrupted/; ## Failure equates to eof. $stream->{opened} = ''; return $self->error("unexpected write error: $!"); } else { # timed-out $stream->{timedout} = 1; return $self->error("print timed-out"); } } 1; } # end sub print sub print_length { my($self) = @_; $ {*$self}{net_telnet}{num_wrote}; } # end sub print_length sub prompt { my($self, $prompt) = @_; my( $prev, $stream, ); $stream = $ {*$self}{net_telnet}; $prev = $stream->{cmd_prompt}; ## Parse args. if (@_ == 2) { defined $prompt or $prompt = ''; return $self->error("bad match operator: ", "opening delimiter missing: $prompt") unless $prompt =~ m(^\s*/) or $prompt =~ m(^\s*m\s*\W); $stream->{cmd_prompt} = $prompt; } elsif (@_ > 2) { return $self->error('usage: $obj->prompt($match_op)'); } $prev; } # end sub prompt sub telnetmode { my($self, $mode) = @_; my( $prev, $stream, ); $stream = $ {*$self}{net_telnet}; $prev = $stream->{telnet_mode}; if (@_ >= 2) { $mode = 0 unless defined $mode; $stream->{telnet_mode} = $mode; } $prev; } # end sub telnetmode sub timed_out { my($self, $value) = @_; my( $prev, $stream, ); $stream = $ {*$self}{net_telnet}; $prev = $stream->{timedout}; if (@_ >= 2) { defined $value or $value = ''; $stream->{timedout} = $value; } $prev; } # end sub timed_out sub timeout { my($self, $timeout) = @_; my( $prev, $stream, ); $stream = $ {*$self}{net_telnet}; $prev = $stream->{time_out}; if (@_ >= 2) { $stream->{time_out} = &_parse_timeout($timeout); } $prev; } # end sub timeout sub waitfor { my($self, @args) = @_; my( $arg, $endtime, $len, $match, $match_op, $pos, $prematch, $search, $search_cond, $stream, $string, $timeout, @match_cond, @match_ops, @search_cond, @string_cond, @warns, ); local $_; ## Init vars. $stream = $ {*$self}{net_telnet}; $timeout = $stream->{time_out}; $stream->{timedout} = ''; return if $stream->{eofile}; return unless @args; ## Code template used build conditional to match a string. ## Values between array elements must be supplied later. @string_cond = ('if (($pos = index $stream->{buf}, ', ') > -1) { $len = ', '; $prematch = substr $stream->{buf}, 0, $pos; $match = substr $stream->{buf}, $pos, $len; substr($stream->{buf}, 0, $pos + $len) = ""; last; }'); ## Code template used build conditional to match a pattern. ## Values between array elements must be supplied later. @match_cond = ('if ($stream->{buf} =~ ', ') { $prematch = $`; $match = $&; substr($stream->{buf}, 0, length($`) + length($&)) = ""; last; }'); ## Parse args. if (@_ == 2) { # one positional arg given $arg = $_[1]; return $self->error("bad match operator: ", "opening delimiter missing: $arg") unless $arg =~ m(^\s*/) or $arg =~ m(^\s*m\s*\W); ## Fill in the blanks in the code template. push @match_ops, $arg; push @search_cond, join('', $match_cond[0], $arg, $match_cond[1]); } elsif (@_ > 2) { # named args given ## Parse the named args. while (($_, $arg) = splice @args, 0, 2) { if (/^-?timeout$/i) { $timeout = &_parse_timeout($arg); } elsif (/^-?match$/i) { return $self->error("bad match operator: ", "opening delimiter missing: $arg") unless $arg =~ m(^\s*/) or $arg =~ m(^\s*m\s*\W); ## Fill in the blanks in the code template. push @match_ops, $arg; push @search_cond, join('', $match_cond[0], $arg, $match_cond[1]); } elsif (/^-?string$/i) { ## Fill in the blanks in the code template. $arg =~ s/'/\\'/g; # quote ticks push @search_cond, join('', $string_cond[0], "'$arg'", $string_cond[1], length($arg), $string_cond[2]); } else { return $self->error('usage: $obj->waitfor([Match => ', '$match_op,] [String => $string,] ', '[Timeout => $secs,])'); } } } ## Construct conditional to check for requested string and pattern matches. ## Turn subsequent "if"s into "elsif". $search_cond = join "\n\tels", @search_cond; ## Construct loop to fill buffer until string/pattern, timeout, or eof. $search = join '', " while (1) {\n\t", $search_cond, ' &_fillbuf($self, $stream, $endtime) or do { last if $stream->{timedout}; $self->close; last; }; }'; ## Set wall time when we timeout. $endtime = &_endtime($timeout); ## Run the loop. { local $^W = 1; local $SIG{'__WARN__'} = sub { push @warns, @_ }; local $stream->{errormode} = 'return'; $stream->{errormsg} = ''; eval $search; } ## Check for failure. return $self->error("pattern match timed-out") if $stream->{timedout}; return $self->error($stream->{errormsg}) if $stream->{errormsg} ne ''; return $self->error("pattern match read eof") if $stream->{eofile}; ## Check for Perl syntax errors or warnings. if ($@ or @warns) { foreach $match_op (@match_ops) { &_match_check($self, $match_op) or return; } return $self->error($@) if $@; return $self->error(@warns) if @warns; } wantarray ? ($prematch, $match) : 1; } # end sub waitfor ######################## Private Subroutines ######################### 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"); } # end sub _append_lineno sub _carp { warn &_append_lineno(@_); } # end sub _carp sub _croak { die &_append_lineno(@_); } # end sub _croak sub _endtime { my($interval) = @_; ## Compute wall time when timeout occurs. if (defined $interval) { if ($interval >= $^T) { # it's already an absolute time return $interval; } elsif ($interval > 0) { # it's relative to the current time return int(time + 1.5 + $interval); } else { # it's a one time poll return 0; } } else { # there's no timeout return undef; } } # end sub _endtime sub _fillbuf { my($self, $s, $endtime) = @_; my( $fh, $firstpos, $lastpos, $len_w_sep, $len_wo_sep, $nextchar, $nfound, $nread, $offset, $pos, $pushback_len, $ready, $timed_out, $timeout, ); return unless $s->{opened}; while (1) { ## Ensure we haven't exceeded maximum buffer size. return $self->error("maximum input buffer length exceeded: ", $s->{maxbufsize}, " bytes") unless length($s->{buf}) <= $s->{maxbufsize}; ## Set how long to wait for input ready. ($timed_out, $timeout) = &_timeout_interval($endtime); if ($timed_out) { $s->{timedout} = 1; return $self->error("read timed-out"); } ## Wait for input ready. $nfound = select $ready=$s->{fdmask}, '', '', $timeout; if ($nfound > 0) { # data can be read ## Append any partially read telnet char sequence. $pushback_len = length $s->{pushback_buf}; if ($pushback_len) { $s->{buf} .= $s->{pushback_buf}; $s->{pushback_buf} = ''; } ## Do the read. $offset = length $s->{buf}; if ($nread = sysread $self, $s->{buf}, $s->{blksize}, $offset) { ## If requested, display network traffic. ($s->{dumplog}) and &_log_dump('<', $s->{dumplog}, \$s->{buf}, $offset); ## Process any telnet commands in the data stream. if ($s->{telnet_mode} and index($s->{buf}, "\377", $offset - $pushback_len) > -1) { &_interpret_cmd($self, $s, $offset - $pushback_len); } ## Process carriage-return sequences in the data stream. $pos = $offset - $pushback_len; while (($pos = index($s->{buf}, "\015", $pos)) > -1) { $nextchar = substr($s->{buf}, $pos + 1, 1); if ($nextchar eq "\0") { ## Convert CR NULL to CR substr($s->{buf}, $pos + 1, 1) = '' if $s->{telnet_mode}; } elsif ($nextchar eq "\012") { ## Convert CR LF to newline when not in binary mode. substr($s->{buf}, $pos, 2) = "\n" if ! $s->{bin_mode}; } elsif (! length($nextchar) and $s->{telnet_mode}) { ## Save CR for possible CR NULL conversion. $s->{pushback_buf} .= "\015"; chop $s->{buf}; } $pos++; } next if length $s->{buf} <= $offset; ## If requested, log the input. if ($s->{inputlog}) { local $\ = ''; $fh = $s->{inputlog}; $fh->print(substr $s->{buf}, $offset); } ## Save last line in the buffer. if (($lastpos = rindex $s->{buf}, $s->{rs}) > -1) { while (1) { ## Find beginning of line. $firstpos = rindex $s->{buf}, $s->{rs}, $lastpos - 1; if ($firstpos == -1) { $offset = 0; } else { $offset = $firstpos + length $s->{rs}; } ## Determine length of line with and without separator. $len_wo_sep = $lastpos - $offset; $len_w_sep = $len_wo_sep + length $s->{rs}; ## Save line if it's not blank. if (substr($s->{buf}, $offset, $len_wo_sep) !~ /^\s*$/) { $s->{last_line} = substr($s->{buf}, $offset, $len_w_sep); last; } last if $firstpos == -1; $lastpos = $firstpos; } } return 1; } elsif (! defined $nread) { # read failed next if $! =~ /^Interrupted/; $s->{opened} = ''; return $self->error("unexpected read error: $!"); } else { # read end-of-file $s->{opened} = ''; return; } } elsif ($nfound < 0) { # select failure next if $! =~ /^Interrupted/; ## Failure equates to eof. $s->{opened} = ''; return $self->error("unexpected read error: $!"); } else { # timed-out $s->{timedout} = 1; return $self->error("read timed-out"); } } } # end sub _fillbuf sub _flush_opts { my($self, $s) = @_; my( $option_chars, ); ## Get option and clear the output buf. $option_chars = $s->{unsent_opts}; $s->{unsent_opts} = ''; ## Try to send options without waiting. { local $s->{errormode} = 'return'; local $s->{time_out} = 0; local $s->{ors} = ''; $self->print($option_chars) or do { ## Save chars not printed for later. substr($option_chars, 0, $self->print_length) = ''; $s->{unsent_opts} .= $option_chars; }; } 1; } # end sub _flush_opts sub _fname_to_handle { my($self, $fh) = @_; my( $filename, ); ## Default is off. if (!defined $fh or !length $fh) { return ''; } ## Assume arg is a filename if it's not an open filehandle. no strict 'refs'; if (!defined fileno($fh)) { $filename = $fh; $fh = &_new_handle(); open $fh, ">$filename" or do { &_carp($self, "problem creating $filename: $!"); return ''; }; } $fh->autoflush; $fh; } # end sub _fname_to_handle sub _have_alarm { eval { local $SIG{'__DIE__'} = 'DEFAULT'; local $SIG{ALRM} = sub { die }; alarm 0; }; ! $@; } # end sub _have_alarm sub _interpret_cmd { my($self, $s, $offset) = @_; my( $endpos, $nextchar, $option, $pos, ); ## Parse telnet commands in the data stream. $pos = $offset; while (($pos = index $s->{buf}, "\377", $pos) > -1) { # unprocessed IAC $nextchar = substr $s->{buf}, $pos + 1, 1; ## Save command if it's only partially read. if (! length $nextchar) { $s->{pushback_buf} .= "\377"; chop $s->{buf}; last; } if ($nextchar eq "\377") { # IAC is escaping "\377" char ## Remove escape char from data stream. substr($s->{buf}, $pos, 1) = ''; $pos++; } elsif ($nextchar eq "\375" or $nextchar eq "\373" or $nextchar eq "\374" or $nextchar eq "\376") { # opt negotiation $option = substr $s->{buf}, $pos + 2, 1; ## Save command if it's only partially read. if (! length $option) { $s->{pushback_buf} .= "\377" . $nextchar; chop $s->{buf}; chop $s->{buf}; last; } ## Remove command from data stream. substr($s->{buf}, $pos, 3) = ''; ## Handle option negotiation. &_negotiate_recv($self, $s, $nextchar, ord($option), $pos); } elsif ($nextchar eq "\372") { # start of subnegotiation parameters ## Save command if it's only partially read. $endpos = index $s->{buf}, "\360", $pos; if ($endpos == -1) { $s->{pushback_buf} .= substr $s->{buf}, $pos; substr($s->{buf}, $pos) = ''; last; } ## Ignore subnegotiation cmd. substr($s->{buf}, $pos, $endpos - $pos + 1) = ''; } else { # various two char telnet commands ## Ignore and remove command from data stream. substr($s->{buf}, $pos, 2) = ''; } } ## Try to send any waiting option negotiation. if (length $s->{unsent_opts}) { &_flush_opts($self, $s); } 1; } # end sub _interpret_cmd sub _log_dump { my($direction, $fh, $data, $offset, $len) = @_; my( $addr, $hexvals, $line, ); $addr = 0; $len = length($$data) - $offset unless defined $len; ## 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, $len; } $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. printf $fh "%s 0x%5.5lx: %s%s\n", $direction, $addr, $hexvals, $line; $addr += 16; $offset += 16; $len -= 16; } print $fh "\n"; 1; } # end sub _log_dump sub _log_option { my($fh, $direction, $request, $option) = @_; my( $name, ); if ($option >= 0 and $option <= $#Telopts) { $name = $Telopts[$option]; } else { $name = $option; } print $fh "$direction $request $name\n"; } # end sub _log_option sub _match_check { my($self, $code) = @_; my $error; my @warns = (); ## Use eval to check for syntax errors or warnings. { local $^W = 1; local $SIG{'__WARN__'} = sub { push @warns, @_ }; local $SIG{'__DIE__'} = 'DEFAULT'; 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; } # end sub _match_check sub _negotiate_callback { my($self, $opt, $is_remote, $is_enabled, $was_enabled, $opt_bufpos) = @_; my( $callback, $opt_state, $stream, ); ## Keep track of remote echo. if ($is_remote and $opt == &TELOPT_ECHO) { # received WILL or WONT ECHO $stream = $ {*$self}{net_telnet}; if ($is_enabled and !$was_enabled) { # received WILL ECHO $stream->{remote_echo} = 1; } elsif (!$is_enabled and $was_enabled) { # received WONT ECHO $stream->{remote_echo} = ''; } } ## Invoke callback, if there is one. $callback = $self->option_callback; if ($callback) { &$callback($self, $opt, $is_remote, $is_enabled, $was_enabled, $opt_bufpos); } 1; } # end sub _negotiate_callback sub _negotiate_recv { my($self, $s, $opt_request, $opt, $opt_bufpos) = @_; ## Ensure data structure exists for this option. unless (defined $s->{opts}{$opt}) { &_set_default_option($s, $opt); } ## Process the option. if ($opt_request eq "\376") { # DONT &_negotiate_recv_disable($self, $s, $opt, "dont", $opt_bufpos, $s->{opts}{$opt}{local_enable_ok}, \$s->{opts}{$opt}{local_enabled}, \$s->{opts}{$opt}{local_state}); } elsif ($opt_request eq "\375") { # DO &_negotiate_recv_enable($self, $s, $opt, "do", $opt_bufpos, $s->{opts}{$opt}{local_enable_ok}, \$s->{opts}{$opt}{local_enabled}, \$s->{opts}{$opt}{local_state}); } elsif ($opt_request eq "\374") { # WONT &_negotiate_recv_disable($self, $s, $opt, "wont", $opt_bufpos, $s->{opts}{$opt}{remote_enable_ok}, \$s->{opts}{$opt}{remote_enabled}, \$s->{opts}{$opt}{remote_state}); } elsif ($opt_request eq "\373") { # WILL &_negotiate_recv_enable($self, $s, $opt, "will", $opt_bufpos, $s->{opts}{$opt}{remote_enable_ok}, \$s->{opts}{$opt}{remote_enabled}, \$s->{opts}{$opt}{remote_state}); } else { # internal error die; } 1; } # end sub _negotiate_recv sub _negotiate_recv_disable { my($self, $s, $opt, $opt_request, $opt_bufpos, $enable_ok, $is_enabled, $state) = @_; my( $ack, $disable_cmd, $enable_cmd, $is_remote, $nak, $was_enabled, ); ## What do we use to request enable/disable or respond with ack/nak. if ($opt_request eq "wont") { $enable_cmd = "\377\375" . pack('C', $opt); # do command $disable_cmd = "\377\376" . pack('C', $opt); # dont command $is_remote = 1; $ack = "DO"; $nak = "DONT"; &_log_option($s->{opt_log}, "RCVD", "WONT", $opt) if $s->{opt_log}; } elsif ($opt_request eq "dont") { $enable_cmd = "\377\373" . pack('C', $opt); # will command $disable_cmd = "\377\374" . pack('C', $opt); # wont command $is_remote = ''; $ack = "WILL"; $nak = "WONT"; &_log_option($s->{opt_log}, "RCVD", "DONT", $opt) if $s->{opt_log}; } else { # internal error die; } ## Respond to WONT or DONT based on the current negotiation state. if ($$state eq "no") { # state is already disabled } elsif ($$state eq "yes") { # they're initiating disable $$is_enabled = ''; $$state = "no"; ## Send positive acknowledgment. $s->{unsent_opts} .= $disable_cmd; &_log_option($s->{opt_log}, "SENT", $nak, $opt) if $s->{opt_log}; ## Invoke callbacks. &_negotiate_callback($self, $opt, $is_remote, $$is_enabled, $was_enabled, $opt_bufpos); } elsif ($$state eq "wantno") { # they sent positive ack $$is_enabled = ''; $$state = "no"; ## Invoke callback. &_negotiate_callback($self, $opt, $is_remote, $$is_enabled, $was_enabled, $opt_bufpos); } elsif ($$state eq "wantno opposite") { # pos ack but we changed our mind ## Indicate disabled but now we want to enable. $$is_enabled = ''; $$state = "wantyes"; ## Send queued request. $s->{unsent_opts} .= $enable_cmd; &_log_option($s->{opt_log}, "SENT", $ack, $opt) if $s->{opt_log}; ## Invoke callback. &_negotiate_callback($self, $opt, $is_remote, $$is_enabled, $was_enabled, $opt_bufpos); } elsif ($$state eq "wantyes") { # they sent negative ack $$is_enabled = ''; $$state = "no"; ## Invoke callback. &_negotiate_callback($self, $opt, $is_remote, $$is_enabled, $was_enabled, $opt_bufpos); } elsif ($$state eq "wantyes opposite") { # nak but we changed our mind $$is_enabled = ''; $$state = "no"; ## Invoke callback. &_negotiate_callback($self, $opt, $is_remote, $$is_enabled, $was_enabled, $opt_bufpos); } } # end sub _negotiate_recv_disable sub _negotiate_recv_enable { my($self, $s, $opt, $opt_request, $opt_bufpos, $enable_ok, $is_enabled, $state) = @_; my( $ack, $disable_cmd, $enable_cmd, $is_remote, $nak, $was_enabled, ); ## What we use to send enable/disable request or send ack/nak response. if ($opt_request eq "will") { $enable_cmd = "\377\375" . pack('C', $opt); # do command $disable_cmd = "\377\376" . pack('C', $opt); # dont command $is_remote = 1; $ack = "DO"; $nak = "DONT"; &_log_option($s->{opt_log}, "RCVD", "WILL", $opt) if $s->{opt_log}; } elsif ($opt_request eq "do") { $enable_cmd = "\377\373" . pack('C', $opt); # will command $disable_cmd = "\377\374" . pack('C', $opt); # wont command $is_remote = ''; $ack = "WILL"; $nak = "WONT"; &_log_option($s->{opt_log}, "RCVD", "DO", $opt) if $s->{opt_log}; } else { # internal error die; } ## Save current enabled state. $was_enabled = $$is_enabled; ## Respond to WILL or DO based on the current negotiation state. if ($$state eq "no") { # they're initiating enable if ($enable_ok) { # we agree they/us should enable $$is_enabled = 1; $$state = "yes"; ## Send positive acknowledgment. $s->{unsent_opts} .= $enable_cmd; &_log_option($s->{opt_log}, "SENT", $ack, $opt) if $s->{opt_log}; ## Invoke callbacks. &_negotiate_callback($self, $opt, $is_remote, $$is_enabled, $was_enabled, $opt_bufpos); } else { # we disagree they/us should enable ## Send negative acknowledgment. $s->{unsent_opts} .= $disable_cmd; &_log_option($s->{opt_log}, "SENT", $nak, $opt) if $s->{opt_log}; } } elsif ($$state eq "yes") { # state is already enabled } elsif ($$state eq "wantno") { # error: our disable req answered by enable $$is_enabled = ''; $$state = "no"; ## Invoke callbacks. &_negotiate_callback($self, $opt, $is_remote, $$is_enabled, $was_enabled, $opt_bufpos); } elsif ($$state eq "wantno opposite") { # err: disable req answerd by enable $$is_enabled = 1; $$state = "yes"; ## Invoke callbacks. &_negotiate_callback($self, $opt, $is_remote, $$is_enabled, $was_enabled, $opt_bufpos); } elsif ($$state eq "wantyes") { # they sent pos ack $$is_enabled = 1; $$state = "yes"; ## Invoke callback. &_negotiate_callback($self, $opt, $is_remote, $$is_enabled, $was_enabled, $opt_bufpos); } elsif ($$state eq "wantyes opposite") { # pos ack but we changed our mind ## Indicate enabled but now we want to disable. $$is_enabled = 1; $$state = "wantno"; ## Inform other side we changed our mind. $s->{unsent_opts} .= $disable_cmd; &_log_option($s->{opt_log}, "SENT", $nak, $opt) if $s->{opt_log}; ## Invoke callback. &_negotiate_callback($self, $opt, $is_remote, $$is_enabled, $was_enabled, $opt_bufpos); } 1; } # end sub _negotiate_recv_enable sub _new_handle { if ($INC{'IO/Handle.pm'}) { return IO::Handle->new; } else { require FileHandle; return FileHandle->new; } } # end sub _new_handle sub _opt_accept { my($self, @args) = @_; my( $arg, $option, $stream, ); ## Init vars. $stream = $ {*$self}{net_telnet}; foreach $arg (@args) { ## Ensure data structure defined for this option. $option = $arg->{option}; if (!defined $stream->{opts}{$option}) { &_set_default_option($stream, $option); } ## Save whether we'll accept or reject this option. if ($arg->{is_remote}) { $stream->{opts}{$option}{remote_enable_ok} = $arg->{is_enable}; } else { $stream->{opts}{$option}{local_enable_ok} = $arg->{is_enable}; } } 1; } # end sub _opt_accept sub _parse_timeout { my($timeout) = @_; ## Ensure valid timeout. if (defined $timeout) { ## Test for non-numeric or negative values. eval { local $^W = 1; local $SIG{'__WARN__'} = sub { die "non-numeric\n" }; local $SIG{'__DIE__'} = 'DEFAULT'; $timeout *= 1; }; if ($@) { # timeout arg is non-numeric $timeout = undef; } elsif ($timeout < 0) { $timeout = undef; } } $timeout; } # end sub _parse_timeout sub _qualify_fh { my($obj, $name) = @_; my( $user_class, ); local $_; ## Get user's package name. ($user_class) = &_user_caller($obj); ## Ensure name is qualified with a package name. $name = qualify($name, $user_class); ## If it's not already, make it a typeglob ref. if (! ref $name) { no strict; local $^W = 0; $name =~ s/^\*+//; $name = eval "\\*$name"; return unless ref $name; } $name; } # end sub _qualify_fh sub _reset_options { my($opts) = @_; my( $opt, ); foreach $opt (keys %$opts) { $opts->{$opt}{remote_enabled} = ''; $opts->{$opt}{remote_state} = "no"; $opts->{$opt}{local_enabled} = ''; $opts->{$opt}{local_state} = "no"; } 1; } # end sub _reset_options sub _set_default_option { my($stream, $option) = @_; $stream->{opts}{$option} = { remote_enabled => '', remote_state => "no", remote_enable_ok => '', local_enabled => '', local_state => "no", local_enable_ok => '', }; } # end sub _set_default_option sub _timeout_interval { my($endtime) = @_; my( $timeout, ); ## Return timed-out boolean and timeout interval. if (defined $endtime) { ## Is it a one-time poll. return ('', 0) if $endtime == 0; ## Calculate the timeout interval. $timeout = $endtime - time; ## Did we already timeout. return (1, 0) unless $timeout > 0; return ('', $timeout); } else { # there is no timeout return ('', undef); } } # end sub _timeout_interval sub _user_caller { my($obj) = @_; my( $class, $curr_pkg, $file, $i, $line, $pkg, $isa, %isa, @isa, ); ## 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); } # end sub _user_caller sub _verify_telopt_arg { my($self, $option, $argname) = @_; ## If provided, use argument name in error message. if (defined $argname) { $argname = "for arg $argname"; } else { $argname = ""; } ## Ensure telnet option is a non-negative integer. eval { local $^W = 1; local $SIG{'__WARN__'} = sub { die "non-numeric\n" }; local $SIG{'__DIE__'} = 'DEFAULT'; $option = abs(int $option); }; return $self->error("bad telnet option $argname: non-numeric") if $@; return $self->error("bad telnet option $argname: option > 255") unless $option <= 255; $option; } # end sub _verify_telopt_arg ######################## Exported Constants ########################## sub TELNET_IAC () {255}; # interpret as command: sub TELNET_DONT () {254}; # you are not to use option sub TELNET_DO () {253}; # please, you use option sub TELNET_WONT () {252}; # I won't use option sub TELNET_WILL () {251}; # I will use option sub TELNET_SB () {250}; # interpret as subnegotiation sub TELNET_GA () {249}; # you may reverse the line sub TELNET_EL () {248}; # erase the current line sub TELNET_EC () {247}; # erase the current character sub TELNET_AYT () {246}; # are you there sub TELNET_AO () {245}; # abort output--but let prog finish sub TELNET_IP () {244}; # interrupt process--permanently sub TELNET_BREAK () {243}; # break sub TELNET_DM () {242}; # data mark--for connect. cleaning sub TELNET_NOP () {241}; # nop sub TELNET_SE () {240}; # end sub negotiation sub TELNET_EOR () {239}; # end of record (transparent mode) sub TELNET_ABORT () {238}; # Abort process sub TELNET_SUSP () {237}; # Suspend process sub TELNET_EOF () {236}; # End of file sub TELNET_SYNCH () {242}; # for telfunc calls sub TELOPT_BINARY () {0}; # Binary Transmission sub TELOPT_ECHO () {1}; # Echo sub TELOPT_RCP () {2}; # Reconnection sub TELOPT_SGA () {3}; # Suppress Go Ahead sub TELOPT_NAMS () {4}; # Approx Message Size Negotiation sub TELOPT_STATUS () {5}; # Status sub TELOPT_TM () {6}; # Timing Mark sub TELOPT_RCTE () {7}; # Remote Controlled Trans and Echo sub TELOPT_NAOL () {8}; # Output Line Width sub TELOPT_NAOP () {9}; # Output Page Size sub TELOPT_NAOCRD () {10}; # Output Carriage-Return Disposition sub TELOPT_NAOHTS () {11}; # Output Horizontal Tab Stops sub TELOPT_NAOHTD () {12}; # Output Horizontal Tab Disposition sub TELOPT_NAOFFD () {13}; # Output Formfeed Disposition sub TELOPT_NAOVTS () {14}; # Output Vertical Tabstops sub TELOPT_NAOVTD () {15}; # Output Vertical Tab Disposition sub TELOPT_NAOLFD () {16}; # Output Linefeed Disposition sub TELOPT_XASCII () {17}; # Extended ASCII sub TELOPT_LOGOUT () {18}; # Logout sub TELOPT_BM () {19}; # Byte Macro sub TELOPT_DET () {20}; # Data Entry Terminal sub TELOPT_SUPDUP () {21}; # SUPDUP sub TELOPT_SUPDUPOUTPUT () {22}; # SUPDUP Output sub TELOPT_SNDLOC () {23}; # Send Location sub TELOPT_TTYPE () {24}; # Terminal Type sub TELOPT_EOR () {25}; # End of Record sub TELOPT_TUID () {26}; # TACACS User Identification sub TELOPT_OUTMRK () {27}; # Output Marking sub TELOPT_TTYLOC () {28}; # Terminal Location Number sub TELOPT_3270REGIME () {29}; # Telnet 3270 Regime sub TELOPT_X3PAD () {30}; # X.3 PAD sub TELOPT_NAWS () {31}; # Negotiate About Window Size sub TELOPT_TSPEED () {32}; # Terminal Speed sub TELOPT_LFLOW () {33}; # Remote Flow Control sub TELOPT_LINEMODE () {34}; # Linemode sub TELOPT_XDISPLOC () {35}; # X Display Location sub TELOPT_OLD_ENVIRON () {36}; # Environment Option sub TELOPT_AUTHENTICATION () {37}; # Authentication Option sub TELOPT_ENCRYPT () {38}; # Encryption Option sub TELOPT_NEW_ENVIRON () {39}; # New Environment Option sub TELOPT_EXOPL () {255}; # Extended-Options-List 1; __END__; ######################## User Documentation ########################## ## To format the following user documentation into a more readable ## format, use one of these programs: pod2man; pod2html; pod2text. =head1 NAME Net::Telnet - interact with TELNET port or other TCP ports =head1 SYNOPSIS C see METHODS section below =head1 DESCRIPTION Net::Telnet allows you to make client connections to a TCP port and do network I/O, especially to a port using the TELNET protocol. Simple I/O methods such as print, get, and getline are provided. More sophisticated interactive features are provided because connecting to a TELNET port ultimately means communicating with a program designed for human interaction. These interactive features include the ability to specify a timeout and to wait for patterns to appear in the input stream, such as the prompt from a shell. Other reasons to use this module than strictly with a TELNET port are: =over 2 =item * You're not familiar with sockets and you want a simple way to make client connections to TCP services. =item * You want to be able to specify your own time-out while connecting, reading, or writing. =item * You're communicating with an interactive program at the other end of some socket or pipe and you want to wait for certain patterns to appear. =back Here's an example that prints who's logged-on to the remote host sparky. In addition to a username and password, you must also know the user's shell prompt, which for this example is C use Net::Telnet (); $t = new Net::Telnet (Timeout => 10, Prompt => '/bash\$ $/'); $t->open("sparky"); $t->login($username, $passwd); @lines = $t->cmd("/usr/bin/who"); print @lines; More examples are in the B section below. =head2 What To Know Before Using =over 2 =item * All output is flushed while all input is buffered. Each object contains an input buffer. =item * The output record separator for C and C is set to C<"\n"> by default, so that you don't have to append all your commands with a newline. See C to change the behavior. =item * The methods C and C use the I setting in the object to determine when a login or remote command is complete. The method will fail with a time-out if you don't set the prompt correctly. =item * To avoid unexpected backslash interpretation, always use single quotes instead of double quotes to construct a match operator argument for C and C (e.g. C<'/bash\$ $/'>). If you're constructing a DOS like file path, you'll need to use four backslashes to represent one (e.g. C<'/c:\\\\users\\\\billE$/i'>). Of course don't forget about regexp metacharacters like C<.>, C<[>, or C<$>. You'll only need a single backslash to quote them. The anchor metacharacters C<^> and C<$> refer to positions in the input buffer. =item * Errors such as timing-out are handled according to the I action. The default action is to print an error message to standard error and have the program die. Use C to change the action. Using an I of C<"return"> arranges for the error message to be saved and the offending method to return with an undefined value. You can obtain the error message using C. =item * You'll need to be running at least Perl version 5.002 to use this module. This module does not require any libraries that don't already come with a standard Perl distribution. If you have the IO:: libraries installed then IO::Socket::INET is used as a base class, otherwise FileHandle is used. The IO:: libraries now come standard starting with perl5.004. =item * In the input stream, each sequence of I and I (i.e. C<"\015\012"> or CR LF) is converted to C<"\n">. In the output stream, each occurrence of C<"\n"> is converted to a sequence of CR LF. See C to change the behavior. TCP protocols typically use the ASCII sequence, carriage return and line feed to designate a newline. =item * Timing-out while making a connection is disabled for machines that don't support the C function. Most notably these include Win32 machines. More universal support for connection time-outs will be in a later release. =item * This is an alpha version - meaning that the interface may change in future versions. Contact me, Jay Rogers , if you find any bugs or have suggestions for improvement. =back =head2 Debugging The typical bug causes a timeout error because you've made incorrect assumptions about what the remote side actually sends. The easiest way to reconcile what the remote side sends with your expectations is to use C or C. C allows you to see the data being sent from the remote side before any translation is done, while C shows you the results after translation. The translation includes converting end of line characters and stripping and responding to TELNET protocol commands. =head2 Style of Named Parameters Two different styles of named parameters are supported. This document only shows the IO:: style: Net::Telnet->new(Timeout => 20); however the dash-option style is also allowed: Net::Telnet->new(-timeout => 20); =head2 Connecting to a Remote Win32 Machine By default, Windows machines don't come with a TELNET service. However, third party TELNET servers can be acquired to provide access to a DOS shell. As is all too familiar, many of these servers are of inferior quality. One particularly nasty problem is a server that sends ANSI terminal escape sequences despite being told not to. These escape sequences make your job of parsing the data much more difficult. You can sometimes avoid this with a server that prompts you for I. Choose I to console mode. =head1 METHODS =over 4 =item B - create a new Net::Telnet object $obj = Net::Telnet->new([Binmode => $mode,] [Cmd_remove_mode => $mode,] [Dump_Log => $filename,] [Errmode => $errmode,] [Fhopen => $filehandle,] [Host => $host,] [Input_log => $file,] [Input_record_separator => $char,] [Option_log => $file,] [Output_log => $file,] [Output_record_separator => $char,] [Port => $port,] [Prompt => $matchop,] [Telnetmode => $mode,] [Timeout => $secs,]); This is the constructor for Net::Telnet objects. A new object is returned on success, the I<$errmode> action is performed on failure - see C. The arguments are short-cuts to methods of the same name. If the I<$host> argument is given then the object is opened by connecting to TCP I<$port> on I<$host>. Also see C. The new object returned is given the following defaults in the absence of corresponding named arguments: =over 4 =item The default I is C<"localhost"> =item The default I is C<23> =item The default I is C<'/[\$%#E] $/'> =item The default I is C<10> =item The default I is C<"die"> =item The default I is C<"\n"> =item The default I is C<"\n"> =item The default I is C<0>, which means do newline translation =item The default I is C<"auto">. =back =back =over 4 =item B - toggle newline translation $mode = $obj->binmode; $prev = $obj->binmode($mode); This method controls whether or not sequences of carriage returns and line feeds (CR LF or more specifically C<"\015\012">) are translated. By default they are translated (i.e. binmode is C<0>). If no argument is given, the current mode is returned. If I<$mode> is C<1> then binmode is I and newline translation is not done. If I<$mode> is C<0> then binmode is I and newline translation is done. In the input stream, each sequence of CR LF is converted to C<"\n"> and in the output stream, each occurrence of C<"\n"> is converted to a sequence of CR LF. Note that input is always buffered. Changing binmode doesn't effect what's already been read into the buffer. Output is not buffered and changing binmode will have an immediate effect. =back =over 4 =item B - send TELNET break character $ok = $obj->break; This method sends the TELNET break character. This character is provided because it's a signal outside the USASCII character set which is currently given local meaning within many systems. It's intended to indicate that the Break Key or the Attention Key was hit. =back =over 4 =item B - scalar reference to object's input buffer $ref = $obj->buffer; This method returns a scalar reference to the input buffer for I<$obj>. Data in the input buffer is data that has been read from the remote side but has yet to be read by the user. Modifications to the input buffer are returned by a subsequent read. =back =over 4 =item B - discard all data in object's input buffer $obj->buffer_empty; This method removes all data in the input buffer for I<$obj>. =back =over 4 =item B - close object $ok = $obj->close; This method closes the socket, file, or pipe associated with the object. =back =over 4 =item B - issue command and retrieve output $ok = $obj->cmd($string); $ok = $obj->cmd(String => $string, [Output => $ref,] [Prompt => $match,] [Timeout => $secs,] [Cmd_remove_mode => $mode,]); @output = $obj->cmd($string); @output = $obj->cmd(String => $string, [Output => $ref,] [Prompt => $match,] [Timeout => $secs,] [Cmd_remove_mode => $mode,]); This method sends the command I<$string>, and reads the characters sent back by the command up until and including the matching prompt. It's assumed that the program to which you're sending is some kind of command prompting interpreter such as a shell. In a scalar context the characters read are discarded and a boolean is returned indicating the success or failure of sending the command string and reading the prompt. Note that in order to return on error, C must not be set to C<"die">. In an array context, just the output generated by the command is returned, one line per element. In other words, all the characters in between the echoed back command string and the prompt are returned. If the command happens to return no output, an array containing one element, the null string is returned. This is so the array will indicate true in a boolean context. Many command interpreters echo back the command sent. In most situations, this method removes the first line returned from the remote side (i.e. the echoed back command). See C for more control over this feature. Use C to debug when this method keeps timing-out and you don't think it should. Optional named arguments are provided to override the current settings of prompt, timeout, and cmd_remove_mode. The I named argument provides an alternative method of receiving command output. If you pass a scalar reference, all the output (even if it contains multiple lines) is returned in the referenced scalar. If you pass an array or hash reference, the lines of output are returned in the referenced array or hash. =back =over 4 =item B - toggle removal of echoed commands $mode = $obj->cmd_remove_mode; $prev = $obj->cmd_remove_mode($mode); This method controls how to deal with echoed back commands in the output returned by cmd(). Typically, when you send a command to the remote side, the first line of output returned is the command echoed back. Use this mode to remove the first line of output normally returned by cmd(). If no argument is given, the current mode is returned. If I<$mode> is C<0> then the command output returned from cmd() has no lines removed. If I<$mode> is a positive integer, then the first I<$mode> lines of command output are stripped. By default, I<$mode> is set to C<"auto">. Auto means that whether or not the first line of command output is stripped, depends on whether or not the remote side offered to echo. By default, Net::Telnet always accepts an offer to echo by the remote side. You can change the default to reject such an offer using C. =back =over 4 =item B - log all I/O in dump format $fh = $obj->dump_log; $fh = $obj->dump_log($fh); $fh = $obj->dump_log($filename); This method starts or stops dump format logging of all the object's input and output. The dump format shows the blocks read and written in a hexadecimal and printable character format. This method is useful when debugging, however you might want to first try C as it's more readable. If no argument is given, the current log filehandle is returned. A null string indicates logging is off. To stop logging, use a null string as an argument. If an open filehandle is given, it is used for logging and returned. Otherwise, the argument is assumed to be the name of a file, the file is opened and a filehandle to it is returned. =back =over 4 =item B - end of file indicator $eof = $obj->eof; This method indicates if end of file has been read. Because the input is buffered this isn't the same thing as I<$obj> has closed. In other words I<$obj> can be closed but there still can be stuff in the buffer to be read. Under this condition you can still read but you won't be able to write. =back =over 4 =item B - define action to be performed on error $mode = $obj->errmode; $prev = $obj->errmode($mode); This method gets or sets the action used when errors are encountered using the object. The first calling sequence returns the current error mode. The second calling sequence sets it to I<$mode> and returns the previous mode. Valid values for I<$mode> are C<"die"> (the default), C<"return">, a I, or an I. When mode is C<"die"> and an error is encountered using the object, then an error message is printed to standard error and the program dies. When mode is C<"return"> then the method generating the error places an error message in the object and returns the undefined value in a scalar context and a null list in list context. The error message may be obtained using C. When mode is a I, then when an error is encountered I is called with the error message as its first argument. Using this mode you may have your own subroutine handle errors. If I itself returns then the method generating the error returns undefined or a null list depending on context. When mode is an I, the first element of the array must be a I. Any elements that follow are the arguments to I. When an error is encountered, the I is called with its arguments. Using this mode you may have your own subroutine handle errors. If the I itself returns then the method generating the error returns undefined or a null list depending on context. =back =over 4 =item B - most recent error message $msg = $obj->errmsg; $prev = $obj->errmsg(@msgs); The first calling sequence returns the error message associated with the object. The null string is returned if no error has been encountered yet. The second calling sequence sets the error message for the object to the concatenation of I<@msgs> and returns the previous error message. Normally, error messages are set internally by a method when an error is encountered. =back =over 4 =item B - perform the error mode action $obj->error(@msgs); This method concatenates I<@msgs> into a string and places it in the object as the error message. Also see C. It then performs the error mode. Also see C. If the error mode doesn't cause the program to die then the undefined value or a null list is returned depending on context. This method is primarily used by this class or a sub-class to perform the user requested action when an error is encountered. =back =over 4 =item B - use already open filehandle for I/O $ok = $obj->fhopen($fh); This method associates the open filehandle I<$fh> with I<$obj> for further I/O. Filehandle I<$fh> must already be opened. Suppose you want to use the features of this module to do I/O to something other than a TCP port, for example STDIN or a filehandle opened to read from a process. Instead of opening the object for I/O to a TCP port by using C or C, call this method instead. =back =over 4 =item B - read block of data $data = $obj->get([Timeout => $secs,]); This method reads a block of data from the object and returns it along with any buffered data. If no buffered data is available to return, it will wait for data to read using the timeout specified in the object. You can override that timeout using I<$secs>. Also see C. If buffered data is available to return, it also checks for a block of data that can be immediately read. On eof an undefined value is returned. On time-out or other errors the error mode action is performed. An undefined value is returned for both eof and time-out when I is not set to C<"die">. Use C and C to distinguish. =back =over 4 =item B - read next line $line = $obj->getline([Timeout => $secs,]); This method reads and returns the next line of data from the object. You can use C to change the notion of what separates a line. The default is C<"\n">. If a line isn't immediately available, this method blocks waiting for a line or the timeout. You can override the object's timeout for this method using I<$secs>. Also see C. On eof an undefined value is returned. On timeout or other errors the error mode action is performed. An undefined value is returned for both eof and time-out when I is not set to C<"die">. Use C and C to distinguish. =back =over 4 =item B - read next lines @lines = $obj->getlines([Timeout => $secs,]); This method reads and returns the next available lines of data from the object. You can use C to change the notion of what separates a line. The default is C<"\n">. If a line isn't immediately available, this method blocks waiting for one or more lines, or the timeout. You can override the object's timeout for this method using I<$secs>. Also see C. On eof a null array is returned. On timeout or other errors the error mode action is performed. A null array is returned for both eof and time-out when I is not set to C<"die">. Use C and C to distinguish. =back =over 4 =item B - name of remote host $host = $obj->host; $prev = $obj->host($host); This method designates the remote host. With no argument this method returns the current host name set in the object. With an argument it sets the current host name to I<$host> and returns the previous host name. You may indicate the remote host using either a hostname or an IP address. =back =over 4 =item B - log all input $fh = $obj->input_log; $fh = $obj->input_log($fh); $fh = $obj->input_log($filename); This method starts or stops logging of input. This is useful when debugging. Also see C. Because most command interpreters echo back commands received, its likely all your output will also be in this log. Note that input logging occurs after newline translation. See C for details on newline translation. If no argument is given, the log filehandle is returned. A null string indicates logging is off. To stop logging, use a null string as an argument. If an open filehandle is given, it is used for logging and returned. Otherwise, the argument is assumed to be the name of a file, the file is opened for logging and a filehandle to it is returned. =back =over 4 =item B - input line delimiter $rs = $obj->input_record_separator; $prev = $obj->input_record_separator($rs); This method designates the line delimiter for input. It's used with C, C, and C to determine lines in the input. With no argument this method returns the current input record separator set in the object. With an argument it sets the input record separator to I<$rs> and returns the previous value. =back =over 4 =item B - last line read $line = $obj->lastline; $prev = $obj->lastline($line); This method saves the last line read from the object. This may be a useful error message when the remote side abnormally closes the connection. Typically the remote side will print an error message before closing. With no argument this method returns the last line read from the object. With an argument it sets the last line read to I<$line> and returns the previous value. Normally, only internal methods set the last line. =back =over 4 =item B - perform standard login $ok = $obj->login($username, $password); $ok = $obj->login(Name => $username, Password => $password, [Prompt => $match,] [Timeout => $secs,]); This method performs a standard login by waiting for a login prompt and responding with I<$username>, then waiting for the password prompt and responding with I<$password>, and then waiting for the command interpreter prompt. If any of those prompts sent by the remote side don't match what's expected, this method will timeout - unless timeout is turned off. Login prompts must match either of the patterns: /login[: ]*$/i /username[: ]*$/i Password prompts must match the pattern: /password[: ]*$/i The command interpreter prompt must match the current setting of prompt. Use C to debug when this method keeps timing-out and you don't think it should. Optional named arguments are provided to override the current settings of prompt and timeout. =back =over 4 =item B - maximum size of input buffer $len = $obj->max_buffer_length; $prev = $obj->max_buffer_length($len); This method designates the maximum size of the input buffer. An error is generated when a read causes the buffer to exceed this limit. The default value is 1,048,576 bytes (1MB). The input buffer can grow much larger than the block size when you continuously read using C or C and the data stream contains no newlines or matching waitfor patterns. With no argument this method returns the current maximum buffer length set in the object. With an argument it sets the maximum buffer length to I<$len> and returns the previous value. =back =over 4 =item B - connect to port on remote host $ok = $obj->open($host); $ok = $obj->open([Host => $host,] [Port => $port,] [Timeout => $secs,]); This method opens a TCP connection to I<$port> on I<$host>. If either argument is missing then the current value of C or C is used. An optional named argument is provided to override the current setting of timeout. On time-out or other connection errors, the error mode action is performed. Timeouts don't work for this method on machines that don't implement SIGALRM - most notably Win32 machines. For those machines, an error is returned when the system reaches its own time-out while trying to connect. A side effect of this method is to reset the alarm interval associated with SIGALRM. =back =over 4 =item B - indicate willingness to accept a TELNET option $fh = $obj->option_accept([Do => $telopt,] [Dont => $telopt,] [Will => $telopt,] [Wont => $telopt,]); This method is used to indicate whether to accept or reject an offer to enable a TELNET option made by the remote side. If you're using I or I to indicate a willingness to enable, then a notification callback must have already been defined by a prior call to C. See C for details on receiving enable/disable notification of a TELNET option. You can give multiple I, I, I, or I arguments for different TELNET options in the same call to this method. The following example describes the meaning of the named arguments. A TELNET option, such as C used below, is an integer constant that you can import from Net::Telnet. See the source in file Telnet.pm for the complete list. =over 4 =item I => C =over 4 =item we'll accept an offer to enable the echo option on the local side =back =item I => C =over 4 =item we'll reject an offer to enable the echo option on the local side =back =item I => C =over 4 =item we'll accept an offer to enable the echo option on the remote side =back =item I => C =over 4 =item we'll reject an offer to enable the echo option on the remote side =back =back =item Use C to send a request to the remote side to enable or disable a particular TELNET option. =back =over 4 =item B - define the option negotiation callback $coderef = $obj->option_callback; $prev = $obj->option_callback($coderef); This method defines the callback subroutine that's called when a TELNET option is enabled or disabled. Once defined, the I may not be undefined. However, calling this method with a different I<$coderef> changes it. Here are the circumstances that invoke I<$coderef>: =over 4 =item An option becomes enabled because the remote side requested an enable and C had been used to arrange that it be accepted. =item The remote side arbitrarily decides to disable an option that is currently enabled. Note that Net::Telnet always accepts a request to disable from the remote side. =item C was used to send a request to enable or disable an option and the response from the remote side has just been received. Note, that if a request to enable is rejected then I<$coderef> is still invoked even though the option didn't change. =back =item Here are the arguments passed to I<&$coderef>: &$coderef($obj, $option, $is_remote, $is_enabled, $was_enabled, $buf_position); =over 4 =item 1. I<$obj> is the Net::Telnet object =item 2. I<$option> is the TELNET option. Net::Telnet exports constants for the various TELNET options which just equate to an integer. =item 3. I<$is_remote> is a boolean indicating for which side the option applies. =item 4. I<$is_enabled> is a boolean indicating the option is enabled or disabled =item 5. I<$was_enabled> is a boolean indicating the option was previously enabled or disabled =item 6. I<$buf_position> is an integer indicating the position in the object's input buffer where the option takes effect. See C to access the object's input buffer. =back =back =over 4 =item B - log all TELNET options sent or received $fh = $obj->option_log; $fh = $obj->option_log($fh); $fh = $obj->option_log($filename); This method starts or stops logging of all TELNET options being sent or received. This is useful for debugging when you send options via C or you arrange to accept option requests from the remote side via C. Also see C. If no argument is given, the log filehandle is returned. A null string indicates logging is off. To stop logging, use a null string as an argument. If an open filehandle is given, it is used for logging and returned. Otherwise, the argument is assumed to be the name of a file, the file is opened for logging and a filehandle to it is returned. =back =over 4 =item B - send TELNET option negotiation request $ok = $obj->option_send([Do => $telopt,] [Dont => $telopt,] [Will => $telopt,] [Wont => $telopt,] [Async => $boolean,]); This method is not yet implemented. Look for it in a future version. =back =over 4 =item B - get current state of a TELNET option $hashref = $obj->option_state($telopt); This method returns a hashref containing a copy of the current state of TELNET option I<$telopt>. Here are the values returned in the hash: =over 4 =item I<$hashref>->{remote_enabled} =over 4 =item boolean that indicates if the option is enabled on the remote side. =back =item I<$hashref>->{remote_enable_ok} =over 4 =item boolean that indicates if it's ok to accept an offer to enable this option on the remote side. =back =item I<$hashref>->{remote_state} =over 4 =item string used to hold the internal state of option negotiation for this option on the remote side. =back =item I<$hashref>->{local_enabled} =over 4 =item boolean that indicates if the option is enabled on the local side. =back =item I<$hashref>->{local_enable_ok} =over 4 =item boolean that indicates if it's ok to accept an offer to enable this option on the local side. =back =item I<$hashref>->{local_state} =over 4 =item string used to hold the internal state of option negotiation for this option on the local side. =back =back =back =over 4 =item B - field separator for print $ofs = $obj->output_field_separator; $prev = $obj->output_field_separator($ofs); This method designates the output field separator for C. Ordinarily the print method simply prints out the comma separated fields you specify. Set this to specify what's printed between fields. With no argument this method returns the current output field separator set in the object. With an argument it sets the output field separator to I<$ofs> and returns the previous value. =back =over 4 =item B - log all output $fh = $obj->output_log; $fh = $obj->output_log($fh); $fh = $obj->output_log($filename); This method starts or stops logging of output. This is useful when debugging. Also see C. Because most command interpreters echo back commands received, its likely all your output would also be in an input log. See C. Note that output logging occurs before newline translation. See C for details on newline translation. If no argument is given, the log filehandle is returned. A null string indicates logging is off. To stop logging, use a null string as an argument. If an open filehandle is given, it is used for logging and returned. Otherwise, the argument is assumed to be the name of a file, the file is opened for logging and a filehandle to it is returned. =back =over 4 =item B - output line delimiter $ors = $obj->output_record_separator; $prev = $obj->output_record_separator($ors); This method designates the output record separator for C. Ordinarily the print operator simply prints out the comma separated fields you specify, with no trailing newline or record separator assumed. Set this variable to specify what's printed at the end of the print. Note: the output record separator is set to C<"\n"> by default, so there's no need to append all your commands with a newline. With no argument this method returns the current output record separator set in the object. With an argument it sets the output record separator to I<$ors> and returns the previous value. =back =over 4 =item B - remote port $port = $obj->port; $prev = $obj->port($port); This method designates the remote TCP port. With no argument this method returns the current port number. With an argument it sets the current port number to I<$port> and returns the previous port. If I<$port> is a service name, then first it's converted to a port number using the perl function C. =back =over 4 =item B - write to object $ok = $obj->print(@list); This method prints a string or a comma-separated list of strings to the opened object and returns non-zero if all data was successfully written. By default, the C is set to C<"\n"> in order to have your commands automatically end with a newline. In most cases your output is being read by a command interpreter which won't accept a command until newline is read. This is similar to someone typing a command and hitting the return key. On failure, it's possible that some data was written. If you choose to try and recover from a print timing-out, use C to determine how much was written before time-out occurred. =back =over 4 =item B - number of bytes written by print $num = $obj->print_length; This returns the number of bytes successfully written by the most recent C. =back =over 4 =item B - pattern to match a prompt $matchop = $obj->prompt; $prev = $obj->prompt($matchop); This method sets the pattern used to find a prompt in the input stream. It must be a string representing a valid perl pattern match operator. The methods C and C try to read until matching the prompt. They will fail with a time-out error if the pattern you've chosen doesn't match what the remote side sends. With no argument this method returns the prompt set in the object. With an argument it sets the prompt to I<$matchop> and returns the previous value. The default prompt is C<'/[\$%#E] $/'> Always use single quotes, instead of double quotes, to construct I<$matchop> (e.g. C<'/bash\$ $/'>). If you're constructing a DOS like file path, you'll need to use four backslashes to represent one (e.g. C<'/c:\\\\users\\\\billE$/i'>). Of course don't forget about regexp metacharacters like C<.>, C<[>, or C<$>. You'll only need a single backslash to quote them. The anchor metacharacters C<^> and C<$> refer to positions in the input buffer. =back =over 4 =item B - turn off/on telnet command interpretation $mode = $obj->telnetmode; $prev = $obj->telnetmode($mode); This method controls whether or not TELNET commands in the data stream are recognized and handled. The TELNET protocol uses certain character sequences sent in the data stream to control the session. If the port you're connecting to isn't using the TELNET protocol, then you should turn this mode off. The default is I. If no argument is given, the current mode is returned. If I<$mode> is C<0> then telnet mode is off. If I<$mode> is C<1> then telnet mode is on. =back =over 4 =item B - time-out indicator $boolean = $obj->timed_out; $prev = $obj->timed_out($boolean); This method indicates if a previous read or write method timed-out. With no argument this method returns true if a previous method timed-out. With an argument it sets the indicator. Normally, only internal methods set this indicator. =back =over 4 =item B - I/O time-out interval $secs = $obj->timeout; $prev = $obj->timeout($secs); This method sets the timeout interval that's used when performing I/O or connecting to a port. When a method doesn't complete within the timeout interval then it's an error and the error mode action is performed. The timeout may be expressed as a relative or absolute value. If I<$secs> is greater than or equal to the time the program was started, as determined by $^T, then it's the absolute time when timeout occurs. Also see the perl function C. A relative timeout happens I<$secs> from when the I/O method begins. If I<$secs> is C<0> then timeout occurs if the data cannot be immediately read or written. Use the undefined value to turn off timing-out. With no argument this method returns the timeout set in the object. With an argument it sets the timeout to I<$secs> and returns the previous value. =back =over 4 =item B - wait for pattern in the input $ok = $obj->waitfor($matchop); $ok = $obj->waitfor([Match => $matchop,] [String => $string,] [Timeout => $secs,]); ($prematch, $match) = $obj->waitfor($matchop); ($prematch, $match) = $obj->waitfor([Match => $matchop,] [String => $string,] [Timeout => $secs,]); This method reads until a pattern match or string is found in the input stream. All the characters before and including the match are removed from the input stream. On time-out, eof, or other errors the error mode action is performed. In an array context the characters before the match and the matched characters are returned in I<$prematch> and I<$match>. You can specify more than one pattern or string by simply providing multiple I and/or I named arguments. A I<$matchop> must be a string representing a valid Perl pattern match operator. The I<$string> is just a substring to find in the input stream. Use C to debug when this method keeps timing-out and you don't think it should. An optional named argument is provided to override the current setting of timeout. To avoid unexpected backslash interpretation, always use single quotes instead of double quotes to construct a match operator argument for C and C (e.g. C<'/bash\$ $/'>). If you're constructing a DOS like file path, you'll need to use four backslashes to represent one (e.g. C<'/c:\\\\users\\\\billE$/i'>). Of course don't forget about regexp metacharacters like C<.>, C<[>, or C<$>. You'll only need a single backslash to quote them. The anchor metacharacters C<^> and C<$> refer to positions in the input buffer. =back =head1 SEE ALSO =over 2 =item RFC 854 S S =item RFC 1143 S S =item TELNET Option Assignments S =back =head1 EXAMPLES This example gets the current weather forecast for Brainerd, Minnesota. my($forecast, $t); use Net::Telnet (); $t = new Net::Telnet; $t->open("rainmaker.wunderground.com"); ## Wait for first prompt and "hit return". $t->waitfor('/continue:.*$/'); $t->print(""); ## Wait for second prompt and respond with city code. $t->waitfor('/city code.*$/'); $t->print("BRD"); ## Read and print the first page of forecast. ($forecast) = $t->waitfor('/[ \t]+press return to continue/i'); print $forecast; exit; This example checks a POP server to see if you have mail. my($hostname, $line, $passwd, $pop, $username); $hostname = "your_destination_host_here"; $username = "your_username_here"; $passwd = "your_password_here"; use Net::Telnet (); $pop = new Net::Telnet (Telnetmode => 0); $pop->open(Host => $hostname, Port => 110); ## Read connection message. $line = $pop->getline; die $line unless $line =~ /^\+OK/; ## Send user name. $pop->print("user $username"); $line = $pop->getline; die $line unless $line =~ /^\+OK/; ## Send password. $pop->print("pass $passwd"); $line = $pop->getline; die $line unless $line =~ /^\+OK/; ## Request status of messages. $pop->print("list"); $line = $pop->getline; print $line; exit; Here's an example you can use to down load a file of any type. The file is read from the remote host's standard output using cat. To prevent any output processing, the remote host's standard output is put in raw mode using the Bourne shell. The Bourne shell is used because some shells, notably tcsh, prevent changing tty modes. Upon completion, FTP style statistics are printed to stderr. my($block, $filename, $host, $hostname, $k_per_sec, $line, $num_read, $passwd, $prevblock, $prompt, $size, $size_bsd, $size_sysv, $start_time, $total_time, $username); $hostname = "your_destination_host_here"; $username = "your_username_here"; $passwd = "your_password_here"; $filename = "your_download_file_here"; ## Connect and login. use Net::Telnet (); $host = new Net::Telnet (Timeout => 30, Prompt => '/[%#>] $/'); $host->open($hostname); $host->login($username, $passwd); ## Make sure prompt won't match anything in send data. $prompt = '_funkyPrompt_'; $host->prompt("/$prompt\$/"); $host->cmd("set prompt = '$prompt'"); ## Get size of file. ($line) = $host->cmd("/usr/bin/ls -l $filename"); ($size_bsd, $size_sysv) = (split ' ', $line)[3,4]; if ($size_sysv =~ /^\d+$/) { $size = $size_sysv; } elsif ($size_bsd =~ /^\d+$/) { $size = $size_bsd; } else { die "$filename: no such file on $hostname"; } ## Start sending the file. binmode STDOUT; $host->binmode(1); $host->print("/usr/bin/sh -c 'stty raw; cat $filename'"); $host->getline; # discard echoed back line ## Read file a block at a time. $num_read = 0; $prevblock = ''; $start_time = time; while (($block = $host->get) and ($block !~ /$prompt$/o)) { if (length $block >= length $prompt) { print $prevblock; $num_read += length $prevblock; $prevblock = $block; } else { $prevblock .= $block; } } $host->close; ## Print last block without trailing prompt. $prevblock .= $block; $prevblock =~ s/$prompt$//; print $prevblock; $num_read += length $prevblock; die "error: expected size $size, received size $num_read\n" unless $num_read == $size; ## Print totals. $total_time = (time - $start_time) || 1; $k_per_sec = ($size / 1024) / $total_time; $k_per_sec = sprintf "%3.1f", $k_per_sec; warn("$num_read bytes received in $total_time seconds ", "($k_per_sec Kbytes/s)\n"); exit; Here's an example that shows how to talk to a program that must communicate via a terminal. In this case we're talking to the telnet program via a pseudo-terminal. We use the Comm package to start the telnet program and return a filehandle to the pseudo-terminal. This example sends some initial commands and then allows the user to type commands to the telnet session. my($comm_pty, $host, $hostname, $passwd, $pty, $username, @lines); $hostname = "your_host_here"; $username = "your_name_here"; $passwd = "your_passwd_here"; ## Start the telnet program so we can talk to it via a ## pseudo-terminal. { local $^W = 0; # Comm.pl isn't warning clean require "Comm.pl"; &Comm::init("close_it", "interact", "open_proc", "stty_raw", "stty_sane"); $comm_pty = &open_proc("telnet $hostname") or die "open_proc failed"; ## Unfortunately the Comm package doesn't ## return us a fully qualified filehandle. We ## must keep the filehandle Comm returned for ## its use and we must build another filehandle ## qualified with the current package for our ## use. $pty = "main::" . $comm_pty; } ## Obtain a new Net::Telnet object that does I/O to the ## pseudo-terminal attached to the running telnet ## program. The "Telnetmode" is "off" because we're ## not talking directly to a telnet port as we normally ## do, we're talking to a pseudo-terminal. The ## "Output_record_separator" is now a carriage return ## because that's what you'd normally hit when you get ## done typing a line at a terminal. use Net::Telnet (); $host = new Net::Telnet (Fhopen => $pty, Timeout => 10, Prompt => '/[\$%#>] $/', Output_record_separator => "\r", Telnetmode => 0, Cmd_remove_mode => 1); ## Issue some commands. $host->login($username, $passwd); $host->cmd("setenv DISPLAY $ENV{DISPLAY}"); print $host->cmd("who"); ## Allow the user to interact with telnet program until ## they exit. { no strict 'subs'; # so we can refer to STDIN local $^W = 0; # Comm.pl isn't warning clean &stty_raw(STDIN); &interact($comm_pty); &stty_sane(STDIN); &close_it($comm_pty); } print "Exited telnet\n"; exit; =head1 AUTHOR Jay Rogers Ejay@rgrs.comE =head1 COPYRIGHT Copyright (c) 1997 Jay Rogers. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. cisco-auditing-tool-1.0/lib/Net/.svn/tmp/0000755000000000000000000000000012046511414016703 5ustar rootrootcisco-auditing-tool-1.0/lib/Net/.svn/tmp/text-base/0000755000000000000000000000000012046511414020577 5ustar rootrootcisco-auditing-tool-1.0/lib/Net/.svn/tmp/props/0000755000000000000000000000000012046511414020046 5ustar rootrootcisco-auditing-tool-1.0/lib/Net/.svn/tmp/prop-base/0000755000000000000000000000000012046511414020573 5ustar rootrootcisco-auditing-tool-1.0/lib/Net/.svn/props/0000755000000000000000000000000012046511414017246 5ustar rootrootcisco-auditing-tool-1.0/lib/Net/.svn/prop-base/0000755000000000000000000000000012046511414017773 5ustar rootrootcisco-auditing-tool-1.0/lib/Net/Telnet.pm0000644000000000000000000032505412046511414017021 0ustar rootrootpackage Net::Telnet; require 5.002; ## User documentation in POD format is at end of this file. Search for =head use strict; ## Module export. use vars qw(@EXPORT_OK); @EXPORT_OK = qw(TELNET_IAC TELNET_DONT TELNET_DO TELNET_WONT TELNET_WILL TELNET_SB TELNET_GA TELNET_EL TELNET_EC TELNET_AYT TELNET_AO TELNET_IP TELNET_BREAK TELNET_DM TELNET_NOP TELNET_SE TELNET_EOR TELNET_ABORT TELNET_SUSP TELNET_EOF TELNET_SYNCH TELOPT_BINARY TELOPT_ECHO TELOPT_RCP TELOPT_SGA TELOPT_NAMS TELOPT_STATUS TELOPT_TM TELOPT_RCTE TELOPT_NAOL TELOPT_NAOP TELOPT_NAOCRD TELOPT_NAOHTS TELOPT_NAOHTD TELOPT_NAOFFD TELOPT_NAOVTS TELOPT_NAOVTD TELOPT_NAOLFD TELOPT_XASCII TELOPT_LOGOUT TELOPT_BM TELOPT_DET TELOPT_SUPDUP TELOPT_SUPDUPOUTPUT TELOPT_SNDLOC TELOPT_TTYPE TELOPT_EOR TELOPT_TUID TELOPT_OUTMRK TELOPT_TTYLOC TELOPT_3270REGIME TELOPT_X3PAD TELOPT_NAWS TELOPT_TSPEED TELOPT_LFLOW TELOPT_LINEMODE TELOPT_XDISPLOC TELOPT_OLD_ENVIRON TELOPT_AUTHENTICATION TELOPT_ENCRYPT TELOPT_NEW_ENVIRON TELOPT_EXOPL); ## Module import. use Exporter (); use Socket qw(AF_INET SOCK_STREAM inet_aton sockaddr_in); use Symbol qw(qualify); ## Base class. use vars qw(@ISA); @ISA = qw(Exporter); if (eval 'require IO::Socket') { push @ISA, 'IO::Socket::INET'; } else { require FileHandle; push @ISA, 'FileHandle'; } ## Global variables. use vars qw($Default_blocksize $VERSION @Telopts); $Default_blocksize = 8192; $VERSION = "3.01"; @Telopts = ("BINARY", "ECHO", "RCP", "SUPPRESS GO AHEAD", "NAME", "STATUS", "TIMING MARK", "RCTE", "NAOL", "NAOP", "NAOCRD", "NAOHTS", "NAOHTD", "NAOFFD", "NAOVTS", "NAOVTD", "NAOLFD", "EXTEND ASCII", "LOGOUT", "BYTE MACRO", "DATA ENTRY TERMINAL", "SUPDUP", "SUPDUP OUTPUT", "SEND LOCATION", "TERMINAL TYPE", "END OF RECORD", "TACACS UID", "OUTPUT MARKING", "TTYLOC", "3270 REGIME", "X.3 PAD", "NAWS", "TSPEED", "LFLOW", "LINEMODE", "XDISPLOC", "OLD-ENVIRON", "AUTHENTICATION", "ENCRYPT", "NEW-ENVIRON"); ########################### Public Methods ########################### sub new { my($class) = @_; my( $fh_open, $host, $self, %args, ); local $_; ## Create a new object with defaults. $self = $class->SUPER::new; $ {*$self}{net_telnet} = { bin_mode => 0, blksize => $Default_blocksize, buf => "", cmd_prompt => '/[\$%#>] $/', cmd_rm_mode => "auto", dumplog => '', eofile => 1, errormode => 'die', errormsg => "", fdmask => '', host => "localhost", inputlog => '', last_line => "", maxbufsize => 1024 * 1024, num_wrote => 0, ofs => "", opened => '', opt_cback => '', opt_log => '', opts => {}, ors => "\n", outputlog => '', port => 23, pushback_buf => "", rs => "\n", telnet_mode => 1, time_out => 10, timedout => '', unsent_opts => "", }; ## Indicate that we'll accept an offer from remote side for it to echo ## and suppress go aheads. &_opt_accept($self, { option => &TELOPT_ECHO, is_remote => 1, is_enable => 1 }, { option => &TELOPT_SGA, is_remote => 1, is_enable => 1 }, ); ## Parse the args. if (@_ == 2) { # one positional arg given $host = $_[1]; } elsif (@_ > 2) { # named args given ## Get the named args. (undef, %args) = @_; ## Parse the errmode named arg first. foreach (keys %args) { $self->errmode($args{$_}) if /^-?errmode$/i; } ## Parse all other named args. foreach (keys %args) { if (/^-?binmode$/i) { $self->binmode($args{$_}); } elsif (/^-?cmd_remove_mode$/i) { $self->cmd_remove_mode($args{$_}); } elsif (/^-?dump_log$/i) { $self->dump_log($args{$_}); } elsif (/^-?errmode$/i) { next; } elsif (/^-?fhopen$/i) { $fh_open = $args{$_}; } elsif (/^-?host$/i) { $host = $args{$_}; } elsif (/^-?input_log$/i) { $self->input_log($args{$_}); } elsif (/^-?input_record_separator$/i) { $self->input_record_separator($args{$_}); } elsif (/^-?option_log$/i) { $self->option_log($args{$_}); } elsif (/^-?output_log$/i) { $self->output_log($args{$_}); } elsif (/^-?output_record_separator$/i) { $self->output_record_separator($args{$_}); } elsif (/^-?port$/i) { $self->port($args{$_}) or return; } elsif (/^-?prompt$/i) { $self->prompt($args{$_}) or return; } elsif (/^-?telnetmode$/i) { $self->telnetmode($args{$_}); } elsif (/^-?timeout$/i) { $self->timeout($args{$_}); } else { $self->error('usage: Net::Telnet->new(' . '[Binmode => $mode,] ' . '[Cmd_remove_mode => $mode,] ' . '[Dump_Log => $filename,] ' . '[Errmode => $errmode,] ' . '[Fhopen => $filehandle,] ' . '[Host => $host,] ' . '[Input_log => $file,] ' . '[Input_record_separator => $char,] ' . '[Option_log => $file,] ' . '[Output_log => $file,] ' . '[Output_record_separator => $char,] '. '[Port => $port,] ' . '[Prompt => $matchop,] ' . '[Telnetmode => $mode,] ' . '[Timeout => $secs,])'); } } } if (defined $fh_open) { # user wants us to attach to existing filehandle $self->fhopen($fh_open) or return; } elsif (defined $host) { # user wants us to open a connection to host $self->host($host); $self->open or return; } $self; } # end sub new sub DESTROY { } # end sub DESTROY sub binmode { my($self, $mode) = @_; my( $prev, $stream, ); $stream = $ {*$self}{net_telnet}; $prev = $stream->{bin_mode}; if (@_ >= 2) { $mode = 0 unless defined $mode; $stream->{bin_mode} = $mode; } $prev; } # end sub binmode sub break { my($self) = @_; my $stream = $ {*$self}{net_telnet}; $stream->{timedout} = ''; return if $stream->{eofile}; local $stream->{ors} = ''; $self->print("\xff\xf3"); } # end sub break sub buffer { my($self) = @_; my $stream = $ {*$self}{net_telnet}; \$stream->{buf}; } # end sub buffer sub buffer_empty { my($self) = @_; my( $buffer, ); $buffer = $self->buffer; $$buffer = ""; } # end sub buffer_empty sub close { my($self) = @_; my $stream = $ {*$self}{net_telnet}; $stream->{eofile} = 1; $stream->{opened} = ''; close $self if defined fileno($self); 1; } # end sub close sub cmd { my($self, @args) = @_; my( $arg, $buf, $cmd_remove_mode, $firstpos, $lastpos, $lines, $orig_errmode, $orig_prompt, $orig_timeout, $output, $output_ref, $prompt, $remove_echo, $rs, $rs_len, $telopt_echo, $timeout, @cmd, ); local $_; ## Init vars. $output = []; $cmd_remove_mode = $self->cmd_remove_mode; $timeout = $self->timeout; $self->timed_out(''); return if $self->eof; ## Parse args. if (@_ == 2) { # one positional arg given push @cmd, $_[1]; } elsif (@_ > 2) { # named args given ## Parse the named args. while (($_, $arg) = splice @args, 0, 2) { if (/^-?cmd_remove/i) { $cmd_remove_mode = $arg; $cmd_remove_mode = "auto" if $cmd_remove_mode =~ /^auto/i; } elsif (/^-?output$/i) { $output_ref = $arg; if (defined($output_ref) and ref($output_ref) eq "ARRAY") { $output = $output_ref; } } elsif (/^-?prompt$/i) { $prompt = $arg; } elsif (/^-?string$/i) { push @cmd, $arg; } elsif (/^-?timeout$/i) { $timeout = &_parse_timeout($arg); } else { return $self->error('usage: $obj->cmd(', '[Cmd_remove => $boolean,] ', '[Output => $ref,] ', '[Prompt => $match,] ', '[String => $string,] ', '[Timeout => $secs,])'); } } } ## Override some user settings. $orig_errmode = $self->errmode('return'); $orig_timeout = $self->timeout(&_endtime($timeout)); $orig_prompt = $self->prompt($prompt) if defined $prompt; $self->errmsg(''); ## Send command and wait for the prompt. $self->print(@cmd) and ($lines) = $self->waitfor($self->prompt); ## Restore user settings. $self->errmode($orig_errmode); $self->timeout($orig_timeout); $self->prompt($orig_prompt) if defined $orig_prompt; ## Check for failure. return $self->error("command timed-out") if $self->timed_out; return $self->error($self->errmsg) if $self->errmsg ne ''; return if $self->eof; ## Split lines into an array, keeping record separator at end of line. $firstpos = 0; $rs = $self->input_record_separator; $rs_len = length $rs; while (($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); } ## Determine if we should remove the first line of output based ## on the assumption that it's an echoed back command. if ($cmd_remove_mode eq "auto") { ## See if remote side told us they'd echo. $telopt_echo = $self->option_state(&TELOPT_ECHO); $remove_echo = $telopt_echo->{remote_enabled}; } else { # user explicitly told us how many lines to remove. $remove_echo = $cmd_remove_mode; } ## Get rid of possible echo back command. while ($remove_echo--) { 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 = (''); } ## 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 : 1; } # end sub cmd sub cmd_remove_mode { my($self, $mode) = @_; my( $prev, $stream, ); $stream = $ {*$self}{net_telnet}; $prev = $stream->{cmd_rm_mode}; if (@_ >= 2) { if (! defined $mode) { $mode = 0; } elsif ($mode =~ /^auto/i) { $mode = "auto"; } else { ## Ensure it's a non-negative integer. eval { local $^W = 1; local $SIG{'__WARN__'} = sub { die "non-numeric\n" }; local $SIG{'__DIE__'} = 'DEFAULT'; $mode = abs(int $mode); }; if ($@) { $mode = 0; } } $stream->{cmd_rm_mode} = $mode; } $prev; } # end sub cmd_remove_mode sub dump_log { my($self, $name) = @_; my( $fh, $stream, ); $stream = $ {*$self}{net_telnet}; $fh = $stream->{dumplog}; if (@_ >= 2) { $fh = &_fname_to_handle($self, $name); $stream->{dumplog} = $fh; } $fh; } # end sub dump_log sub eof { my($self) = @_; $ {*$self}{net_telnet}{eofile}; } # end sub eof sub errmode { my($self, $mode) = @_; my( $prev, $stream, ); $stream = $ {*$self}{net_telnet}; $prev = $stream->{errormode}; if (@_ >= 2) { ## Set the error mode. defined $mode or $mode = ''; if (ref($mode) eq 'CODE') { $stream->{errormode} = $mode; } elsif (ref($mode) eq 'ARRAY') { unless (ref($mode->[0]) eq 'CODE') { &_carp($self, 'bad errmode: first item in list must be a code ref'); $mode = 'die'; } $stream->{errormode} = $mode; } elsif ($mode =~ /^return$/i) { $stream->{errormode} = 'return'; } else { $stream->{errormode} = 'die'; } } $prev; } # end sub errmode sub errmsg { my($self, @errmsgs) = @_; my( $prev, $stream, ); $stream = $ {*$self}{net_telnet}; $prev = $stream->{errormsg}; if (@_ >= 2) { $stream->{errormsg} = join '', @errmsgs; } $prev; } # end sub errmsg sub error { my($self, @errmsg) = @_; my( $errmsg, $func, $mode, $stream, @args, ); $stream = $ {*$self}{net_telnet}; if (@_ >= 2) { ## Put error message in the object. $errmsg = join '', @errmsg; $stream->{errormsg} = $errmsg; ## Do the error action as described by error mode. $mode = $stream->{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 $stream->{errormsg} ne ''; } } # end sub error sub fhopen { my($self, $fh) = @_; my( $blksize, $globref, $stream, ); ## Convert given filehandle to a typeglob reference, if necessary. $globref = &_qualify_fh($self, $fh); ## Ensure filehandle is already open. return $self->error("fhopen filehandle isn't already open") unless defined($globref) and defined(fileno $globref); ## Ensure we're closed. $self->close; ## Save our private data. $stream = $ {*$self}{net_telnet}; ## Switch ourself with the given filehandle. *$self = *$globref; ## Restore our private data. $ {*$self}{net_telnet} = $stream; ## Re-initialize ourself. $self->autoflush; $stream = $ {*$self}{net_telnet}; $blksize = (stat $self)[11]; $stream->{blksize} = $blksize || $Default_blocksize; $stream->{buf} = ""; $stream->{cmd_rm_mode} = 0; $stream->{eofile} = ''; $stream->{errormsg} = ""; vec($stream->{fdmask}='', fileno($self), 1) = 1; $stream->{host} = ""; $stream->{last_line} = ""; $stream->{num_wrote} = 0; $stream->{opened} = 1; $stream->{port} = ''; $stream->{pushback_buf} = ""; $stream->{telnet_mode} = 0; $stream->{timedout} = ''; $stream->{unsent_opts} = ""; &_reset_options($stream->{opts}); 1; } # end sub fhopen sub get { my($self, %args) = @_; my( $endtime, $line, $stream, $timeout, ); local $_; ## Init vars. $stream = $ {*$self}{net_telnet}; $timeout = $stream->{time_out}; $stream->{timedout} = ''; return if $stream->{eofile}; ## Parse the named args. foreach (keys %args) { if (/^-?timeout$/i) { $timeout = &_parse_timeout($args{$_}); } else { return $self->error('usage: $obj->get([Timeout => $secs,])'); } } ## Set wall time when we time out. $endtime = &_endtime($timeout); ## Try to send any waiting option negotiation. if (length $stream->{unsent_opts}) { &_flush_opts($self, $stream); } ## Try to read just the waiting data using return error mode. { local $stream->{errormode} = 'return'; $stream->{errormsg} = ''; &_fillbuf($self, $stream, 0); } ## We're done if we timed-out and timeout value is set to "poll". return if $stream->{timedout} and defined($timeout) and $timeout == 0; ## We're done if we hit an error other than timing out. return $self->error($stream->{errormsg}) if $stream->{errormsg} and ! $stream->{timedout}; ## If buffer is still empty, try to read according to user's timeout. if (! length $stream->{buf}) { &_fillbuf($self, $stream, $endtime) or do { return if $stream->{timedout}; ## We've reached end-of-file. $self->close; return; }; } ## Extract chars from buffer. $line = $stream->{buf}; $stream->{buf} = ''; $line; } # end sub get sub getline { my($self, %args) = @_; my( $endtime, $len, $line, $offset, $pos, $stream, $timeout, ); local $_; ## Init vars. $stream = $ {*$self}{net_telnet}; $timeout = $stream->{time_out}; $stream->{timedout} = ''; return if $stream->{eofile}; ## Parse the named args. foreach (keys %args) { if (/^-?timeout$/i) { $timeout = &_parse_timeout($args{$_}); } else { return $self->error('usage: $obj->getline([Timeout => $secs,])'); } } ## Set wall time when we time out. $endtime = &_endtime($timeout); ## Try to send any waiting option negotiation. if (length $stream->{unsent_opts}) { &_flush_opts($self, $stream); } ## Keep reading into buffer until end-of-line is read. $offset = 0; while (($pos = index($stream->{buf}, $stream->{rs}, $offset)) == -1) { $offset = length $stream->{buf}; &_fillbuf($self, $stream, $endtime) or do { return if $stream->{timedout}; ## We've reached end-of-file. $self->close; if (length $stream->{buf}) { return $stream->{buf}; } else { return; } }; } ## Extract line from buffer. $len = $pos + length $stream->{rs}; $line = substr($stream->{buf}, 0, $len); substr($stream->{buf}, 0, $len) = ''; $line; } # end sub getline sub getlines { my($self) = @_; my( $len, $line, $pos, $stream, @lines, ); $stream = $ {*$self}{net_telnet}; ## Fill buffer and get first line. $line = getline(@_) or return; push @lines, $line; ## Extract subsequent lines from buffer. while (($pos = index($stream->{buf}, $stream->{rs})) != -1) { $len = $pos + length $stream->{rs}; push @lines, substr($stream->{buf}, 0, $len); substr($stream->{buf}, 0, $len) = ''; } @lines; } # end sub getlines sub host { my($self, $host) = @_; my( $prev, $stream, ); $stream = $ {*$self}{net_telnet}; $prev = $stream->{host}; if (@_ >= 2) { $host = '' unless defined $host and length $host; $stream->{host} = $host; } $prev; } # end sub host sub input_log { my($self, $name) = @_; my( $fh, $prev, $stream, ); $stream = $ {*$self}{net_telnet}; $prev = $stream->{inputlog}; if (@_ >= 2) { $fh = &_fname_to_handle($self, $name); $stream->{inputlog} = $fh; } $prev; } # end sub input_log sub input_record_separator { my($self, $rs) = @_; my( $prev, $stream, ); $stream = $ {*$self}{net_telnet}; $prev = $stream->{rs}; if (@_ >= 2) { defined $rs or $rs = ''; $stream->{rs} = $rs; } $prev; } # end sub input_record_separator sub lastline { my($self, $line) = @_; my( $prev, $stream, ); $stream = $ {*$self}{net_telnet}; $prev = $stream->{last_line}; if (@_ >= 2) { defined $line or $line = ''; $stream->{last_line} = $line; } $prev; } # end sub lastline sub login { my($self) = @_; my( $cmd_prompt, $endtime, $error, $lastline, $match, $orig_errmode, $orig_timeout, $passwd, $prematch, $reset, $timeout, $usage, $username, %args, ); local $_; ## Init vars. $timeout = $self->timeout; $self->timed_out(''); return if $self->eof; $cmd_prompt = $self->prompt; $usage = 'usage: $obj->login(Name => $name, Password => $password, ' . '[Prompt => $match,] [Timeout => $secs,])'; if (@_ == 3) { # just username and passwd given $username = $_[1]; $passwd = $_[2]; } else { # named args given ## Get the named args. (undef, %args) = @_; ## Parse the named args. foreach (keys %args) { if (/^-?name$/i) { $username = $args{$_}; defined($username) or $username = ""; } elsif (/^-?pass/i) { $passwd = $args{$_}; defined($passwd) or $passwd = ""; } elsif (/^-?prompt$/i) { $cmd_prompt = $args{$_}; defined $cmd_prompt or $cmd_prompt = ''; return $self->error("bad match operator: ", "opening delimiter missing: $cmd_prompt") unless ($cmd_prompt =~ m(^\s*/) or $cmd_prompt =~ m(^\s*m\s*\W)); } elsif (/^-?timeout$/i) { $timeout = &_parse_timeout($args{$_}); } else { return $self->error($usage); } } } return $self->error($usage) unless defined($username) and defined($passwd); ## Override these user set-able values. $endtime = &_endtime($timeout); $orig_timeout = $self->timeout($endtime); $orig_errmode = $self->errmode('return'); ## Create a subroutine to reset to original values. $reset = sub { $self->errmode($orig_errmode); $self->timeout($orig_timeout); 1; }; ## Create a subroutine to generate an error for user. $error = sub { my($errmsg) = @_; &$reset; 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($self->errmsg); } }; ## Wait for login prompt. $self->waitfor(-match => '/login[: ]*$/i', -match => '/username[: ]*$/i') or do { return &$error("read eof waiting for login prompt") if $self->eof; return &$error("timed-out waiting for login prompt"); }; ## Send login name. $self->print($username) or return &$error("login disconnected"); ## Wait for password prompt. $self->waitfor(-match => '/password[: ]*$/i') or do { return &$error("read eof waiting for password prompt") if $self->eof; return &$error("timed-out waiting for password prompt"); }; ## Send password. $self->print($passwd) or return &$error("login disconnected"); ## Wait for command prompt or another login prompt. ($prematch, $match) = $self->waitfor(-match => '/login[: ]*$/i', -match => '/username[: ]*$/i', -match => $cmd_prompt) or do { return &$error("read eof waiting for command prompt") if $self->eof; return &$error("timed-out waiting for command prompt"); }; ## Reset object to orig values. &$reset; ## It's a bad login if we got another login prompt. return $self->error("login failed: bad name or password") if $match =~ /login[: ]*$/i or $match =~ /username[: ]*$/i; 1; } # end sub login sub max_buffer_length { my($self, $maxbufsize) = @_; my( $minbufsize, $prev, $stream, ); $stream = $ {*$self}{net_telnet}; $prev = $stream->{maxbufsize}; $minbufsize = 512; if (@_ >= 2) { ## Ensure a valid max length. unless (defined $maxbufsize) { $maxbufsize = $minbufsize; } ## Test for non-numeric or negative values. eval { local $^W = 1; local $SIG{'__WARN__'} = sub { die "non-numeric\n" }; local $SIG{'__DIE__'} = 'DEFAULT'; $maxbufsize *= 1; }; if ($@ or $maxbufsize < $minbufsize) { $maxbufsize = $minbufsize; } $stream->{maxbufsize} = $maxbufsize; } $prev; } # end sub max_buffer_length sub open { my($self) = @_; my( $blksize, $errno, $host, $ip_addr, $port, $stream, $timeout, %args, ); local $_; ## Init vars. $stream = $ {*$self}{net_telnet}; $timeout = $stream->{time_out}; $stream->{timedout} = ''; if (@_ == 2) { # one positional arg given $self->host($_[1]); } elsif (@_ > 2) { # named args given ## Get the named args. (undef, %args) = @_; ## Parse the named args. foreach (keys %args) { if (/^-?host$/i) { $self->host($args{$_}); } elsif (/^-?port$/i) { $self->port($args{$_}) or return; } elsif (/^-?timeout$/i) { $timeout = &_parse_timeout($args{$_}); } else { return $self->error('usage: $obj->open([Host => $host,] ', '[Port => $service,] ', '[Timeout => secs,])'); } } } ## Get host and port. $host = $self->host; $port = $self->port; ## Ensure we're already closed. $self->close; ## Don't use a timeout if we can't use the alarm signal. unless (&_have_alarm) { $timeout = undef; } if (defined $timeout) { # use a timeout ## Ensure a valid timeout value for alarm. if ($timeout < 1) { $timeout = 1; } $timeout = int($timeout + 1.5); ## Connect to server, timing out if it takes too long. eval { ## Turn on timer. local $SIG{'__DIE__'} = 'DEFAULT'; local $SIG{ALRM} = sub { die "timed-out\n" }; alarm $timeout; ## Lookup server's IP address. $ip_addr = inet_aton $host or die "unknown remote host: $host\n"; ## Create a socket and attach the filehandle to it. socket $self, AF_INET, SOCK_STREAM, 0 or die "problem creating socket: $!\n"; ## Open connection to server. connect $self, sockaddr_in($port, $ip_addr) or die "problem connecting to \"$host\", port $port: $!\n"; }; alarm 0; ## Check for error. if ($@ =~ /^timed-out$/) { # time out failure $stream->{timedout} = 1; $self->close; if (! $ip_addr) { return $self->error("unknown remote host: $host: ", "name lookup timed-out"); } else { return $self->error("problem connecting to \"$host\", ", "port $port: connection timed-out"); } } elsif ($@) { # hostname lookup or connect failure $self->close; chomp $@; return $self->error($@); } } else { # don't use a timeout ## Lookup server's IP address. $ip_addr = inet_aton $host or return $self->error("unknown remote host: $host"); ## Create a socket and attach the filehandle to it. socket $self, AF_INET, SOCK_STREAM, 0 or return $self->error("problem creating socket: $!"); ## Open connection to server. connect $self, sockaddr_in($port, $ip_addr) or do { $errno = "$!"; $self->close; return $self->error("problem connecting to \"$host\", ", "port $port: $errno"); }; } $self->autoflush; $blksize = (stat $self)[11]; $stream->{blksize} = $blksize || $Default_blocksize; $stream->{buf} = ""; $stream->{eofile} = ''; $stream->{errormsg} = ""; vec($stream->{fdmask}='', fileno($self), 1) = 1; $stream->{last_line} = ""; $stream->{num_wrote} = 0; $stream->{opened} = 1; $stream->{pushback_buf} = ""; $stream->{timedout} = ''; $stream->{unsent_opts} = ""; &_reset_options($stream->{opts}); 1; } # end sub open sub option_accept { my($self, @args) = @_; my( $arg, $option, $stream, @opt_args, ); local $_; ## Init vars. $stream = $ {*$self}{net_telnet}; ## Parse the named args. while (($_, $arg) = splice @args, 0, 2) { ## Verify and save arguments. if (/^-?do$/i) { ## Make sure a callback is defined. return $self->error("usage: an option callback must already ", "be defined when enabling with $_") unless $stream->{opt_cback}; $option = &_verify_telopt_arg($self, $arg, $_) or return; push @opt_args, { option => $option, is_remote => '', is_enable => 1, }; } elsif (/^-?dont$/i) { $option = &_verify_telopt_arg($self, $arg, $_) or return; push @opt_args, { option => $option, is_remote => '', is_enable => '', }; } elsif (/^-?will$/i) { ## Make sure a callback is defined. return $self->error("usage: an option callback must already ", "be defined when enabling with $_") unless $stream->{opt_cback}; $option = &_verify_telopt_arg($self, $arg, $_) or return; push @opt_args, { option => $option, is_remote => 1, is_enable => 1, }; } elsif (/^-?wont$/i) { $option = &_verify_telopt_arg($self, $arg, $_) or return; push @opt_args, { option => $option, is_remote => 1, is_enable => '', }; } else { return $self->error('usage: $obj->option_accept(' . '[Do => $telopt,] ', '[Dont => $telopt,] ', '[Will => $telopt,] ', '[Wont => $telopt,]'); } } ## Set "receive ok" for options specified. &_opt_accept($self, @opt_args); } # end sub option_accept sub option_callback { my($self, $callback) = @_; my( $prev, $stream, ); $stream = $ {*$self}{net_telnet}; $prev = $stream->{opt_cback}; if (@_ >= 2) { return $self->error("actual argument is not a code ref") unless defined $callback and ref($callback) eq "CODE"; $stream->{opt_cback} = $callback; } $prev; } # end sub option_callback sub option_log { my($self, $name) = @_; my( $fh, $prev, $stream, ); $stream = $ {*$self}{net_telnet}; $prev = $stream->{opt_log}; if (@_ >= 2) { $fh = &_fname_to_handle($self, $name); $stream->{opt_log} = $fh; } $prev; } # end sub option_log sub option_state { my($self, $option) = @_; my( $opt_state, $stream, %opt_state, ); ## Ensure telnet option is non-negative integer. $option = &_verify_telopt_arg($self, $option) or return; ## Init vars. $stream = $ {*$self}{net_telnet}; unless (defined $stream->{opts}{$option}) { &_set_default_option($stream, $option); } ## Return hashref to a copy of the values. $opt_state = $stream->{opts}{$option}; %opt_state = %$opt_state; \%opt_state; } # end sub option_state sub output_field_separator { my($self, $ofs) = @_; my( $prev, $stream, ); $stream = $ {*$self}{net_telnet}; $prev = $stream->{ofs}; if (@_ >= 2) { defined $ofs or $ofs = ''; $stream->{ofs} = $ofs; } $prev; } # end sub output_field_separator sub output_log { my($self, $name) = @_; my( $fh, $prev, $stream, ); $stream = $ {*$self}{net_telnet}; $prev = $stream->{outputlog}; if (@_ >= 2) { $fh = &_fname_to_handle($self, $name); $stream->{outputlog} = $fh; } $prev; } # end sub output_log sub output_record_separator { my($self, $ors) = @_; my( $prev, $stream, ); $stream = $ {*$self}{net_telnet}; $prev = $stream->{ors}; if (@_ >= 2) { defined $ors or $ors = ''; $stream->{ors} = $ors; } $prev; } # end sub output_record_separator sub port { my($self, $port) = @_; my( $prev, $service, $stream, ); $stream = $ {*$self}{net_telnet}; $prev = $stream->{port}; if (@_ >= 2) { return $self->error("bad port number: 0") unless defined $port and $port; ## Convert service to a port number. if ($port !~ /^\d+$/) { # port isn't all digits $service = $port; $port = getservbyname($service, 'tcp') or return $self->error("unknown TCP service: $service"); } $stream->{port} = $port; } $prev; } # end sub port sub print { my($self) = shift; my( $data, $endtime, $fh, $len, $nfound, $nwrote, $offset, $ready, $stream, $timed_out, $timeout, ); $stream = $ {*$self}{net_telnet}; $stream->{timedout} = ''; $stream->{num_wrote} = 0; return $self->error("print failed: handle is closed") unless $stream->{opened}; ## Try to send any waiting option negotiation. if (length $stream->{unsent_opts}) { &_flush_opts($self, $stream); } ## Add field and record separators. $data = join($stream->{ofs}, @_) . $stream->{ors}; ## If requested, log the output. if ($stream->{outputlog}) { local $\ = ''; $fh = $stream->{outputlog}; $fh->print($data); } ## Convert newlines to carriage-return and linefeed. $data =~ s(\n)(\015\012)g unless $stream->{bin_mode}; $offset = 0; $len = length $data; $endtime = &_endtime($stream->{time_out}); while ($len) { ## Set how long to wait for output ready. ($timed_out, $timeout) = &_timeout_interval($endtime); if ($timed_out) { $stream->{timedout} = 1; return $self->error("print timed-out"); } ## Wait for output ready. $nfound = select '', $ready=$stream->{fdmask}, '', $timeout; if ($nfound > 0) { # data can be written if ($nwrote = syswrite $self, $data, $len, $offset) { ## If requested, display network traffic. ($stream->{dumplog}) and &_log_dump('>', $stream->{dumplog}, \$data, $offset, $nwrote); $stream->{num_wrote} += $nwrote; $offset += $nwrote; $len -= $nwrote; next; } elsif (! defined $nwrote) { # write failed next if $! =~ /^Interrupted/; $stream->{opened} = ''; return $self->error("unexpected write error: $!"); } else { # zero chars written $stream->{opened} = ''; return $self->error("unexpected zero length write error: $!"); } } elsif ($nfound < 0) { # select failure next if $! =~ /^Interrupted/; ## Failure equates to eof. $stream->{opened} = ''; return $self->error("unexpected write error: $!"); } else { # timed-out $stream->{timedout} = 1; return $self->error("print timed-out"); } } 1; } # end sub print sub print_length { my($self) = @_; $ {*$self}{net_telnet}{num_wrote}; } # end sub print_length sub prompt { my($self, $prompt) = @_; my( $prev, $stream, ); $stream = $ {*$self}{net_telnet}; $prev = $stream->{cmd_prompt}; ## Parse args. if (@_ == 2) { defined $prompt or $prompt = ''; return $self->error("bad match operator: ", "opening delimiter missing: $prompt") unless $prompt =~ m(^\s*/) or $prompt =~ m(^\s*m\s*\W); $stream->{cmd_prompt} = $prompt; } elsif (@_ > 2) { return $self->error('usage: $obj->prompt($match_op)'); } $prev; } # end sub prompt sub telnetmode { my($self, $mode) = @_; my( $prev, $stream, ); $stream = $ {*$self}{net_telnet}; $prev = $stream->{telnet_mode}; if (@_ >= 2) { $mode = 0 unless defined $mode; $stream->{telnet_mode} = $mode; } $prev; } # end sub telnetmode sub timed_out { my($self, $value) = @_; my( $prev, $stream, ); $stream = $ {*$self}{net_telnet}; $prev = $stream->{timedout}; if (@_ >= 2) { defined $value or $value = ''; $stream->{timedout} = $value; } $prev; } # end sub timed_out sub timeout { my($self, $timeout) = @_; my( $prev, $stream, ); $stream = $ {*$self}{net_telnet}; $prev = $stream->{time_out}; if (@_ >= 2) { $stream->{time_out} = &_parse_timeout($timeout); } $prev; } # end sub timeout sub waitfor { my($self, @args) = @_; my( $arg, $endtime, $len, $match, $match_op, $pos, $prematch, $search, $search_cond, $stream, $string, $timeout, @match_cond, @match_ops, @search_cond, @string_cond, @warns, ); local $_; ## Init vars. $stream = $ {*$self}{net_telnet}; $timeout = $stream->{time_out}; $stream->{timedout} = ''; return if $stream->{eofile}; return unless @args; ## Code template used build conditional to match a string. ## Values between array elements must be supplied later. @string_cond = ('if (($pos = index $stream->{buf}, ', ') > -1) { $len = ', '; $prematch = substr $stream->{buf}, 0, $pos; $match = substr $stream->{buf}, $pos, $len; substr($stream->{buf}, 0, $pos + $len) = ""; last; }'); ## Code template used build conditional to match a pattern. ## Values between array elements must be supplied later. @match_cond = ('if ($stream->{buf} =~ ', ') { $prematch = $`; $match = $&; substr($stream->{buf}, 0, length($`) + length($&)) = ""; last; }'); ## Parse args. if (@_ == 2) { # one positional arg given $arg = $_[1]; return $self->error("bad match operator: ", "opening delimiter missing: $arg") unless $arg =~ m(^\s*/) or $arg =~ m(^\s*m\s*\W); ## Fill in the blanks in the code template. push @match_ops, $arg; push @search_cond, join('', $match_cond[0], $arg, $match_cond[1]); } elsif (@_ > 2) { # named args given ## Parse the named args. while (($_, $arg) = splice @args, 0, 2) { if (/^-?timeout$/i) { $timeout = &_parse_timeout($arg); } elsif (/^-?match$/i) { return $self->error("bad match operator: ", "opening delimiter missing: $arg") unless $arg =~ m(^\s*/) or $arg =~ m(^\s*m\s*\W); ## Fill in the blanks in the code template. push @match_ops, $arg; push @search_cond, join('', $match_cond[0], $arg, $match_cond[1]); } elsif (/^-?string$/i) { ## Fill in the blanks in the code template. $arg =~ s/'/\\'/g; # quote ticks push @search_cond, join('', $string_cond[0], "'$arg'", $string_cond[1], length($arg), $string_cond[2]); } else { return $self->error('usage: $obj->waitfor([Match => ', '$match_op,] [String => $string,] ', '[Timeout => $secs,])'); } } } ## Construct conditional to check for requested string and pattern matches. ## Turn subsequent "if"s into "elsif". $search_cond = join "\n\tels", @search_cond; ## Construct loop to fill buffer until string/pattern, timeout, or eof. $search = join '', " while (1) {\n\t", $search_cond, ' &_fillbuf($self, $stream, $endtime) or do { last if $stream->{timedout}; $self->close; last; }; }'; ## Set wall time when we timeout. $endtime = &_endtime($timeout); ## Run the loop. { local $^W = 1; local $SIG{'__WARN__'} = sub { push @warns, @_ }; local $stream->{errormode} = 'return'; $stream->{errormsg} = ''; eval $search; } ## Check for failure. return $self->error("pattern match timed-out") if $stream->{timedout}; return $self->error($stream->{errormsg}) if $stream->{errormsg} ne ''; return $self->error("pattern match read eof") if $stream->{eofile}; ## Check for Perl syntax errors or warnings. if ($@ or @warns) { foreach $match_op (@match_ops) { &_match_check($self, $match_op) or return; } return $self->error($@) if $@; return $self->error(@warns) if @warns; } wantarray ? ($prematch, $match) : 1; } # end sub waitfor ######################## Private Subroutines ######################### 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"); } # end sub _append_lineno sub _carp { warn &_append_lineno(@_); } # end sub _carp sub _croak { die &_append_lineno(@_); } # end sub _croak sub _endtime { my($interval) = @_; ## Compute wall time when timeout occurs. if (defined $interval) { if ($interval >= $^T) { # it's already an absolute time return $interval; } elsif ($interval > 0) { # it's relative to the current time return int(time + 1.5 + $interval); } else { # it's a one time poll return 0; } } else { # there's no timeout return undef; } } # end sub _endtime sub _fillbuf { my($self, $s, $endtime) = @_; my( $fh, $firstpos, $lastpos, $len_w_sep, $len_wo_sep, $nextchar, $nfound, $nread, $offset, $pos, $pushback_len, $ready, $timed_out, $timeout, ); return unless $s->{opened}; while (1) { ## Ensure we haven't exceeded maximum buffer size. return $self->error("maximum input buffer length exceeded: ", $s->{maxbufsize}, " bytes") unless length($s->{buf}) <= $s->{maxbufsize}; ## Set how long to wait for input ready. ($timed_out, $timeout) = &_timeout_interval($endtime); if ($timed_out) { $s->{timedout} = 1; return $self->error("read timed-out"); } ## Wait for input ready. $nfound = select $ready=$s->{fdmask}, '', '', $timeout; if ($nfound > 0) { # data can be read ## Append any partially read telnet char sequence. $pushback_len = length $s->{pushback_buf}; if ($pushback_len) { $s->{buf} .= $s->{pushback_buf}; $s->{pushback_buf} = ''; } ## Do the read. $offset = length $s->{buf}; if ($nread = sysread $self, $s->{buf}, $s->{blksize}, $offset) { ## If requested, display network traffic. ($s->{dumplog}) and &_log_dump('<', $s->{dumplog}, \$s->{buf}, $offset); ## Process any telnet commands in the data stream. if ($s->{telnet_mode} and index($s->{buf}, "\377", $offset - $pushback_len) > -1) { &_interpret_cmd($self, $s, $offset - $pushback_len); } ## Process carriage-return sequences in the data stream. $pos = $offset - $pushback_len; while (($pos = index($s->{buf}, "\015", $pos)) > -1) { $nextchar = substr($s->{buf}, $pos + 1, 1); if ($nextchar eq "\0") { ## Convert CR NULL to CR substr($s->{buf}, $pos + 1, 1) = '' if $s->{telnet_mode}; } elsif ($nextchar eq "\012") { ## Convert CR LF to newline when not in binary mode. substr($s->{buf}, $pos, 2) = "\n" if ! $s->{bin_mode}; } elsif (! length($nextchar) and $s->{telnet_mode}) { ## Save CR for possible CR NULL conversion. $s->{pushback_buf} .= "\015"; chop $s->{buf}; } $pos++; } next if length $s->{buf} <= $offset; ## If requested, log the input. if ($s->{inputlog}) { local $\ = ''; $fh = $s->{inputlog}; $fh->print(substr $s->{buf}, $offset); } ## Save last line in the buffer. if (($lastpos = rindex $s->{buf}, $s->{rs}) > -1) { while (1) { ## Find beginning of line. $firstpos = rindex $s->{buf}, $s->{rs}, $lastpos - 1; if ($firstpos == -1) { $offset = 0; } else { $offset = $firstpos + length $s->{rs}; } ## Determine length of line with and without separator. $len_wo_sep = $lastpos - $offset; $len_w_sep = $len_wo_sep + length $s->{rs}; ## Save line if it's not blank. if (substr($s->{buf}, $offset, $len_wo_sep) !~ /^\s*$/) { $s->{last_line} = substr($s->{buf}, $offset, $len_w_sep); last; } last if $firstpos == -1; $lastpos = $firstpos; } } return 1; } elsif (! defined $nread) { # read failed next if $! =~ /^Interrupted/; $s->{opened} = ''; return $self->error("unexpected read error: $!"); } else { # read end-of-file $s->{opened} = ''; return; } } elsif ($nfound < 0) { # select failure next if $! =~ /^Interrupted/; ## Failure equates to eof. $s->{opened} = ''; return $self->error("unexpected read error: $!"); } else { # timed-out $s->{timedout} = 1; return $self->error("read timed-out"); } } } # end sub _fillbuf sub _flush_opts { my($self, $s) = @_; my( $option_chars, ); ## Get option and clear the output buf. $option_chars = $s->{unsent_opts}; $s->{unsent_opts} = ''; ## Try to send options without waiting. { local $s->{errormode} = 'return'; local $s->{time_out} = 0; local $s->{ors} = ''; $self->print($option_chars) or do { ## Save chars not printed for later. substr($option_chars, 0, $self->print_length) = ''; $s->{unsent_opts} .= $option_chars; }; } 1; } # end sub _flush_opts sub _fname_to_handle { my($self, $fh) = @_; my( $filename, ); ## Default is off. if (!defined $fh or !length $fh) { return ''; } ## Assume arg is a filename if it's not an open filehandle. no strict 'refs'; if (!defined fileno($fh)) { $filename = $fh; $fh = &_new_handle(); open $fh, ">$filename" or do { &_carp($self, "problem creating $filename: $!"); return ''; }; } $fh->autoflush; $fh; } # end sub _fname_to_handle sub _have_alarm { eval { local $SIG{'__DIE__'} = 'DEFAULT'; local $SIG{ALRM} = sub { die }; alarm 0; }; ! $@; } # end sub _have_alarm sub _interpret_cmd { my($self, $s, $offset) = @_; my( $endpos, $nextchar, $option, $pos, ); ## Parse telnet commands in the data stream. $pos = $offset; while (($pos = index $s->{buf}, "\377", $pos) > -1) { # unprocessed IAC $nextchar = substr $s->{buf}, $pos + 1, 1; ## Save command if it's only partially read. if (! length $nextchar) { $s->{pushback_buf} .= "\377"; chop $s->{buf}; last; } if ($nextchar eq "\377") { # IAC is escaping "\377" char ## Remove escape char from data stream. substr($s->{buf}, $pos, 1) = ''; $pos++; } elsif ($nextchar eq "\375" or $nextchar eq "\373" or $nextchar eq "\374" or $nextchar eq "\376") { # opt negotiation $option = substr $s->{buf}, $pos + 2, 1; ## Save command if it's only partially read. if (! length $option) { $s->{pushback_buf} .= "\377" . $nextchar; chop $s->{buf}; chop $s->{buf}; last; } ## Remove command from data stream. substr($s->{buf}, $pos, 3) = ''; ## Handle option negotiation. &_negotiate_recv($self, $s, $nextchar, ord($option), $pos); } elsif ($nextchar eq "\372") { # start of subnegotiation parameters ## Save command if it's only partially read. $endpos = index $s->{buf}, "\360", $pos; if ($endpos == -1) { $s->{pushback_buf} .= substr $s->{buf}, $pos; substr($s->{buf}, $pos) = ''; last; } ## Ignore subnegotiation cmd. substr($s->{buf}, $pos, $endpos - $pos + 1) = ''; } else { # various two char telnet commands ## Ignore and remove command from data stream. substr($s->{buf}, $pos, 2) = ''; } } ## Try to send any waiting option negotiation. if (length $s->{unsent_opts}) { &_flush_opts($self, $s); } 1; } # end sub _interpret_cmd sub _log_dump { my($direction, $fh, $data, $offset, $len) = @_; my( $addr, $hexvals, $line, ); $addr = 0; $len = length($$data) - $offset unless defined $len; ## 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, $len; } $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. printf $fh "%s 0x%5.5lx: %s%s\n", $direction, $addr, $hexvals, $line; $addr += 16; $offset += 16; $len -= 16; } print $fh "\n"; 1; } # end sub _log_dump sub _log_option { my($fh, $direction, $request, $option) = @_; my( $name, ); if ($option >= 0 and $option <= $#Telopts) { $name = $Telopts[$option]; } else { $name = $option; } print $fh "$direction $request $name\n"; } # end sub _log_option sub _match_check { my($self, $code) = @_; my $error; my @warns = (); ## Use eval to check for syntax errors or warnings. { local $^W = 1; local $SIG{'__WARN__'} = sub { push @warns, @_ }; local $SIG{'__DIE__'} = 'DEFAULT'; 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; } # end sub _match_check sub _negotiate_callback { my($self, $opt, $is_remote, $is_enabled, $was_enabled, $opt_bufpos) = @_; my( $callback, $opt_state, $stream, ); ## Keep track of remote echo. if ($is_remote and $opt == &TELOPT_ECHO) { # received WILL or WONT ECHO $stream = $ {*$self}{net_telnet}; if ($is_enabled and !$was_enabled) { # received WILL ECHO $stream->{remote_echo} = 1; } elsif (!$is_enabled and $was_enabled) { # received WONT ECHO $stream->{remote_echo} = ''; } } ## Invoke callback, if there is one. $callback = $self->option_callback; if ($callback) { &$callback($self, $opt, $is_remote, $is_enabled, $was_enabled, $opt_bufpos); } 1; } # end sub _negotiate_callback sub _negotiate_recv { my($self, $s, $opt_request, $opt, $opt_bufpos) = @_; ## Ensure data structure exists for this option. unless (defined $s->{opts}{$opt}) { &_set_default_option($s, $opt); } ## Process the option. if ($opt_request eq "\376") { # DONT &_negotiate_recv_disable($self, $s, $opt, "dont", $opt_bufpos, $s->{opts}{$opt}{local_enable_ok}, \$s->{opts}{$opt}{local_enabled}, \$s->{opts}{$opt}{local_state}); } elsif ($opt_request eq "\375") { # DO &_negotiate_recv_enable($self, $s, $opt, "do", $opt_bufpos, $s->{opts}{$opt}{local_enable_ok}, \$s->{opts}{$opt}{local_enabled}, \$s->{opts}{$opt}{local_state}); } elsif ($opt_request eq "\374") { # WONT &_negotiate_recv_disable($self, $s, $opt, "wont", $opt_bufpos, $s->{opts}{$opt}{remote_enable_ok}, \$s->{opts}{$opt}{remote_enabled}, \$s->{opts}{$opt}{remote_state}); } elsif ($opt_request eq "\373") { # WILL &_negotiate_recv_enable($self, $s, $opt, "will", $opt_bufpos, $s->{opts}{$opt}{remote_enable_ok}, \$s->{opts}{$opt}{remote_enabled}, \$s->{opts}{$opt}{remote_state}); } else { # internal error die; } 1; } # end sub _negotiate_recv sub _negotiate_recv_disable { my($self, $s, $opt, $opt_request, $opt_bufpos, $enable_ok, $is_enabled, $state) = @_; my( $ack, $disable_cmd, $enable_cmd, $is_remote, $nak, $was_enabled, ); ## What do we use to request enable/disable or respond with ack/nak. if ($opt_request eq "wont") { $enable_cmd = "\377\375" . pack('C', $opt); # do command $disable_cmd = "\377\376" . pack('C', $opt); # dont command $is_remote = 1; $ack = "DO"; $nak = "DONT"; &_log_option($s->{opt_log}, "RCVD", "WONT", $opt) if $s->{opt_log}; } elsif ($opt_request eq "dont") { $enable_cmd = "\377\373" . pack('C', $opt); # will command $disable_cmd = "\377\374" . pack('C', $opt); # wont command $is_remote = ''; $ack = "WILL"; $nak = "WONT"; &_log_option($s->{opt_log}, "RCVD", "DONT", $opt) if $s->{opt_log}; } else { # internal error die; } ## Respond to WONT or DONT based on the current negotiation state. if ($$state eq "no") { # state is already disabled } elsif ($$state eq "yes") { # they're initiating disable $$is_enabled = ''; $$state = "no"; ## Send positive acknowledgment. $s->{unsent_opts} .= $disable_cmd; &_log_option($s->{opt_log}, "SENT", $nak, $opt) if $s->{opt_log}; ## Invoke callbacks. &_negotiate_callback($self, $opt, $is_remote, $$is_enabled, $was_enabled, $opt_bufpos); } elsif ($$state eq "wantno") { # they sent positive ack $$is_enabled = ''; $$state = "no"; ## Invoke callback. &_negotiate_callback($self, $opt, $is_remote, $$is_enabled, $was_enabled, $opt_bufpos); } elsif ($$state eq "wantno opposite") { # pos ack but we changed our mind ## Indicate disabled but now we want to enable. $$is_enabled = ''; $$state = "wantyes"; ## Send queued request. $s->{unsent_opts} .= $enable_cmd; &_log_option($s->{opt_log}, "SENT", $ack, $opt) if $s->{opt_log}; ## Invoke callback. &_negotiate_callback($self, $opt, $is_remote, $$is_enabled, $was_enabled, $opt_bufpos); } elsif ($$state eq "wantyes") { # they sent negative ack $$is_enabled = ''; $$state = "no"; ## Invoke callback. &_negotiate_callback($self, $opt, $is_remote, $$is_enabled, $was_enabled, $opt_bufpos); } elsif ($$state eq "wantyes opposite") { # nak but we changed our mind $$is_enabled = ''; $$state = "no"; ## Invoke callback. &_negotiate_callback($self, $opt, $is_remote, $$is_enabled, $was_enabled, $opt_bufpos); } } # end sub _negotiate_recv_disable sub _negotiate_recv_enable { my($self, $s, $opt, $opt_request, $opt_bufpos, $enable_ok, $is_enabled, $state) = @_; my( $ack, $disable_cmd, $enable_cmd, $is_remote, $nak, $was_enabled, ); ## What we use to send enable/disable request or send ack/nak response. if ($opt_request eq "will") { $enable_cmd = "\377\375" . pack('C', $opt); # do command $disable_cmd = "\377\376" . pack('C', $opt); # dont command $is_remote = 1; $ack = "DO"; $nak = "DONT"; &_log_option($s->{opt_log}, "RCVD", "WILL", $opt) if $s->{opt_log}; } elsif ($opt_request eq "do") { $enable_cmd = "\377\373" . pack('C', $opt); # will command $disable_cmd = "\377\374" . pack('C', $opt); # wont command $is_remote = ''; $ack = "WILL"; $nak = "WONT"; &_log_option($s->{opt_log}, "RCVD", "DO", $opt) if $s->{opt_log}; } else { # internal error die; } ## Save current enabled state. $was_enabled = $$is_enabled; ## Respond to WILL or DO based on the current negotiation state. if ($$state eq "no") { # they're initiating enable if ($enable_ok) { # we agree they/us should enable $$is_enabled = 1; $$state = "yes"; ## Send positive acknowledgment. $s->{unsent_opts} .= $enable_cmd; &_log_option($s->{opt_log}, "SENT", $ack, $opt) if $s->{opt_log}; ## Invoke callbacks. &_negotiate_callback($self, $opt, $is_remote, $$is_enabled, $was_enabled, $opt_bufpos); } else { # we disagree they/us should enable ## Send negative acknowledgment. $s->{unsent_opts} .= $disable_cmd; &_log_option($s->{opt_log}, "SENT", $nak, $opt) if $s->{opt_log}; } } elsif ($$state eq "yes") { # state is already enabled } elsif ($$state eq "wantno") { # error: our disable req answered by enable $$is_enabled = ''; $$state = "no"; ## Invoke callbacks. &_negotiate_callback($self, $opt, $is_remote, $$is_enabled, $was_enabled, $opt_bufpos); } elsif ($$state eq "wantno opposite") { # err: disable req answerd by enable $$is_enabled = 1; $$state = "yes"; ## Invoke callbacks. &_negotiate_callback($self, $opt, $is_remote, $$is_enabled, $was_enabled, $opt_bufpos); } elsif ($$state eq "wantyes") { # they sent pos ack $$is_enabled = 1; $$state = "yes"; ## Invoke callback. &_negotiate_callback($self, $opt, $is_remote, $$is_enabled, $was_enabled, $opt_bufpos); } elsif ($$state eq "wantyes opposite") { # pos ack but we changed our mind ## Indicate enabled but now we want to disable. $$is_enabled = 1; $$state = "wantno"; ## Inform other side we changed our mind. $s->{unsent_opts} .= $disable_cmd; &_log_option($s->{opt_log}, "SENT", $nak, $opt) if $s->{opt_log}; ## Invoke callback. &_negotiate_callback($self, $opt, $is_remote, $$is_enabled, $was_enabled, $opt_bufpos); } 1; } # end sub _negotiate_recv_enable sub _new_handle { if ($INC{'IO/Handle.pm'}) { return IO::Handle->new; } else { require FileHandle; return FileHandle->new; } } # end sub _new_handle sub _opt_accept { my($self, @args) = @_; my( $arg, $option, $stream, ); ## Init vars. $stream = $ {*$self}{net_telnet}; foreach $arg (@args) { ## Ensure data structure defined for this option. $option = $arg->{option}; if (!defined $stream->{opts}{$option}) { &_set_default_option($stream, $option); } ## Save whether we'll accept or reject this option. if ($arg->{is_remote}) { $stream->{opts}{$option}{remote_enable_ok} = $arg->{is_enable}; } else { $stream->{opts}{$option}{local_enable_ok} = $arg->{is_enable}; } } 1; } # end sub _opt_accept sub _parse_timeout { my($timeout) = @_; ## Ensure valid timeout. if (defined $timeout) { ## Test for non-numeric or negative values. eval { local $^W = 1; local $SIG{'__WARN__'} = sub { die "non-numeric\n" }; local $SIG{'__DIE__'} = 'DEFAULT'; $timeout *= 1; }; if ($@) { # timeout arg is non-numeric $timeout = undef; } elsif ($timeout < 0) { $timeout = undef; } } $timeout; } # end sub _parse_timeout sub _qualify_fh { my($obj, $name) = @_; my( $user_class, ); local $_; ## Get user's package name. ($user_class) = &_user_caller($obj); ## Ensure name is qualified with a package name. $name = qualify($name, $user_class); ## If it's not already, make it a typeglob ref. if (! ref $name) { no strict; local $^W = 0; $name =~ s/^\*+//; $name = eval "\\*$name"; return unless ref $name; } $name; } # end sub _qualify_fh sub _reset_options { my($opts) = @_; my( $opt, ); foreach $opt (keys %$opts) { $opts->{$opt}{remote_enabled} = ''; $opts->{$opt}{remote_state} = "no"; $opts->{$opt}{local_enabled} = ''; $opts->{$opt}{local_state} = "no"; } 1; } # end sub _reset_options sub _set_default_option { my($stream, $option) = @_; $stream->{opts}{$option} = { remote_enabled => '', remote_state => "no", remote_enable_ok => '', local_enabled => '', local_state => "no", local_enable_ok => '', }; } # end sub _set_default_option sub _timeout_interval { my($endtime) = @_; my( $timeout, ); ## Return timed-out boolean and timeout interval. if (defined $endtime) { ## Is it a one-time poll. return ('', 0) if $endtime == 0; ## Calculate the timeout interval. $timeout = $endtime - time; ## Did we already timeout. return (1, 0) unless $timeout > 0; return ('', $timeout); } else { # there is no timeout return ('', undef); } } # end sub _timeout_interval sub _user_caller { my($obj) = @_; my( $class, $curr_pkg, $file, $i, $line, $pkg, $isa, %isa, @isa, ); ## 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); } # end sub _user_caller sub _verify_telopt_arg { my($self, $option, $argname) = @_; ## If provided, use argument name in error message. if (defined $argname) { $argname = "for arg $argname"; } else { $argname = ""; } ## Ensure telnet option is a non-negative integer. eval { local $^W = 1; local $SIG{'__WARN__'} = sub { die "non-numeric\n" }; local $SIG{'__DIE__'} = 'DEFAULT'; $option = abs(int $option); }; return $self->error("bad telnet option $argname: non-numeric") if $@; return $self->error("bad telnet option $argname: option > 255") unless $option <= 255; $option; } # end sub _verify_telopt_arg ######################## Exported Constants ########################## sub TELNET_IAC () {255}; # interpret as command: sub TELNET_DONT () {254}; # you are not to use option sub TELNET_DO () {253}; # please, you use option sub TELNET_WONT () {252}; # I won't use option sub TELNET_WILL () {251}; # I will use option sub TELNET_SB () {250}; # interpret as subnegotiation sub TELNET_GA () {249}; # you may reverse the line sub TELNET_EL () {248}; # erase the current line sub TELNET_EC () {247}; # erase the current character sub TELNET_AYT () {246}; # are you there sub TELNET_AO () {245}; # abort output--but let prog finish sub TELNET_IP () {244}; # interrupt process--permanently sub TELNET_BREAK () {243}; # break sub TELNET_DM () {242}; # data mark--for connect. cleaning sub TELNET_NOP () {241}; # nop sub TELNET_SE () {240}; # end sub negotiation sub TELNET_EOR () {239}; # end of record (transparent mode) sub TELNET_ABORT () {238}; # Abort process sub TELNET_SUSP () {237}; # Suspend process sub TELNET_EOF () {236}; # End of file sub TELNET_SYNCH () {242}; # for telfunc calls sub TELOPT_BINARY () {0}; # Binary Transmission sub TELOPT_ECHO () {1}; # Echo sub TELOPT_RCP () {2}; # Reconnection sub TELOPT_SGA () {3}; # Suppress Go Ahead sub TELOPT_NAMS () {4}; # Approx Message Size Negotiation sub TELOPT_STATUS () {5}; # Status sub TELOPT_TM () {6}; # Timing Mark sub TELOPT_RCTE () {7}; # Remote Controlled Trans and Echo sub TELOPT_NAOL () {8}; # Output Line Width sub TELOPT_NAOP () {9}; # Output Page Size sub TELOPT_NAOCRD () {10}; # Output Carriage-Return Disposition sub TELOPT_NAOHTS () {11}; # Output Horizontal Tab Stops sub TELOPT_NAOHTD () {12}; # Output Horizontal Tab Disposition sub TELOPT_NAOFFD () {13}; # Output Formfeed Disposition sub TELOPT_NAOVTS () {14}; # Output Vertical Tabstops sub TELOPT_NAOVTD () {15}; # Output Vertical Tab Disposition sub TELOPT_NAOLFD () {16}; # Output Linefeed Disposition sub TELOPT_XASCII () {17}; # Extended ASCII sub TELOPT_LOGOUT () {18}; # Logout sub TELOPT_BM () {19}; # Byte Macro sub TELOPT_DET () {20}; # Data Entry Terminal sub TELOPT_SUPDUP () {21}; # SUPDUP sub TELOPT_SUPDUPOUTPUT () {22}; # SUPDUP Output sub TELOPT_SNDLOC () {23}; # Send Location sub TELOPT_TTYPE () {24}; # Terminal Type sub TELOPT_EOR () {25}; # End of Record sub TELOPT_TUID () {26}; # TACACS User Identification sub TELOPT_OUTMRK () {27}; # Output Marking sub TELOPT_TTYLOC () {28}; # Terminal Location Number sub TELOPT_3270REGIME () {29}; # Telnet 3270 Regime sub TELOPT_X3PAD () {30}; # X.3 PAD sub TELOPT_NAWS () {31}; # Negotiate About Window Size sub TELOPT_TSPEED () {32}; # Terminal Speed sub TELOPT_LFLOW () {33}; # Remote Flow Control sub TELOPT_LINEMODE () {34}; # Linemode sub TELOPT_XDISPLOC () {35}; # X Display Location sub TELOPT_OLD_ENVIRON () {36}; # Environment Option sub TELOPT_AUTHENTICATION () {37}; # Authentication Option sub TELOPT_ENCRYPT () {38}; # Encryption Option sub TELOPT_NEW_ENVIRON () {39}; # New Environment Option sub TELOPT_EXOPL () {255}; # Extended-Options-List 1; __END__; ######################## User Documentation ########################## ## To format the following user documentation into a more readable ## format, use one of these programs: pod2man; pod2html; pod2text. =head1 NAME Net::Telnet - interact with TELNET port or other TCP ports =head1 SYNOPSIS C see METHODS section below =head1 DESCRIPTION Net::Telnet allows you to make client connections to a TCP port and do network I/O, especially to a port using the TELNET protocol. Simple I/O methods such as print, get, and getline are provided. More sophisticated interactive features are provided because connecting to a TELNET port ultimately means communicating with a program designed for human interaction. These interactive features include the ability to specify a timeout and to wait for patterns to appear in the input stream, such as the prompt from a shell. Other reasons to use this module than strictly with a TELNET port are: =over 2 =item * You're not familiar with sockets and you want a simple way to make client connections to TCP services. =item * You want to be able to specify your own time-out while connecting, reading, or writing. =item * You're communicating with an interactive program at the other end of some socket or pipe and you want to wait for certain patterns to appear. =back Here's an example that prints who's logged-on to the remote host sparky. In addition to a username and password, you must also know the user's shell prompt, which for this example is C use Net::Telnet (); $t = new Net::Telnet (Timeout => 10, Prompt => '/bash\$ $/'); $t->open("sparky"); $t->login($username, $passwd); @lines = $t->cmd("/usr/bin/who"); print @lines; More examples are in the B section below. =head2 What To Know Before Using =over 2 =item * All output is flushed while all input is buffered. Each object contains an input buffer. =item * The output record separator for C and C is set to C<"\n"> by default, so that you don't have to append all your commands with a newline. See C to change the behavior. =item * The methods C and C use the I setting in the object to determine when a login or remote command is complete. The method will fail with a time-out if you don't set the prompt correctly. =item * To avoid unexpected backslash interpretation, always use single quotes instead of double quotes to construct a match operator argument for C and C (e.g. C<'/bash\$ $/'>). If you're constructing a DOS like file path, you'll need to use four backslashes to represent one (e.g. C<'/c:\\\\users\\\\billE$/i'>). Of course don't forget about regexp metacharacters like C<.>, C<[>, or C<$>. You'll only need a single backslash to quote them. The anchor metacharacters C<^> and C<$> refer to positions in the input buffer. =item * Errors such as timing-out are handled according to the I action. The default action is to print an error message to standard error and have the program die. Use C to change the action. Using an I of C<"return"> arranges for the error message to be saved and the offending method to return with an undefined value. You can obtain the error message using C. =item * You'll need to be running at least Perl version 5.002 to use this module. This module does not require any libraries that don't already come with a standard Perl distribution. If you have the IO:: libraries installed then IO::Socket::INET is used as a base class, otherwise FileHandle is used. The IO:: libraries now come standard starting with perl5.004. =item * In the input stream, each sequence of I and I (i.e. C<"\015\012"> or CR LF) is converted to C<"\n">. In the output stream, each occurrence of C<"\n"> is converted to a sequence of CR LF. See C to change the behavior. TCP protocols typically use the ASCII sequence, carriage return and line feed to designate a newline. =item * Timing-out while making a connection is disabled for machines that don't support the C function. Most notably these include Win32 machines. More universal support for connection time-outs will be in a later release. =item * This is an alpha version - meaning that the interface may change in future versions. Contact me, Jay Rogers , if you find any bugs or have suggestions for improvement. =back =head2 Debugging The typical bug causes a timeout error because you've made incorrect assumptions about what the remote side actually sends. The easiest way to reconcile what the remote side sends with your expectations is to use C or C. C allows you to see the data being sent from the remote side before any translation is done, while C shows you the results after translation. The translation includes converting end of line characters and stripping and responding to TELNET protocol commands. =head2 Style of Named Parameters Two different styles of named parameters are supported. This document only shows the IO:: style: Net::Telnet->new(Timeout => 20); however the dash-option style is also allowed: Net::Telnet->new(-timeout => 20); =head2 Connecting to a Remote Win32 Machine By default, Windows machines don't come with a TELNET service. However, third party TELNET servers can be acquired to provide access to a DOS shell. As is all too familiar, many of these servers are of inferior quality. One particularly nasty problem is a server that sends ANSI terminal escape sequences despite being told not to. These escape sequences make your job of parsing the data much more difficult. You can sometimes avoid this with a server that prompts you for I. Choose I to console mode. =head1 METHODS =over 4 =item B - create a new Net::Telnet object $obj = Net::Telnet->new([Binmode => $mode,] [Cmd_remove_mode => $mode,] [Dump_Log => $filename,] [Errmode => $errmode,] [Fhopen => $filehandle,] [Host => $host,] [Input_log => $file,] [Input_record_separator => $char,] [Option_log => $file,] [Output_log => $file,] [Output_record_separator => $char,] [Port => $port,] [Prompt => $matchop,] [Telnetmode => $mode,] [Timeout => $secs,]); This is the constructor for Net::Telnet objects. A new object is returned on success, the I<$errmode> action is performed on failure - see C. The arguments are short-cuts to methods of the same name. If the I<$host> argument is given then the object is opened by connecting to TCP I<$port> on I<$host>. Also see C. The new object returned is given the following defaults in the absence of corresponding named arguments: =over 4 =item The default I is C<"localhost"> =item The default I is C<23> =item The default I is C<'/[\$%#E] $/'> =item The default I is C<10> =item The default I is C<"die"> =item The default I is C<"\n"> =item The default I is C<"\n"> =item The default I is C<0>, which means do newline translation =item The default I is C<"auto">. =back =back =over 4 =item B - toggle newline translation $mode = $obj->binmode; $prev = $obj->binmode($mode); This method controls whether or not sequences of carriage returns and line feeds (CR LF or more specifically C<"\015\012">) are translated. By default they are translated (i.e. binmode is C<0>). If no argument is given, the current mode is returned. If I<$mode> is C<1> then binmode is I and newline translation is not done. If I<$mode> is C<0> then binmode is I and newline translation is done. In the input stream, each sequence of CR LF is converted to C<"\n"> and in the output stream, each occurrence of C<"\n"> is converted to a sequence of CR LF. Note that input is always buffered. Changing binmode doesn't effect what's already been read into the buffer. Output is not buffered and changing binmode will have an immediate effect. =back =over 4 =item B - send TELNET break character $ok = $obj->break; This method sends the TELNET break character. This character is provided because it's a signal outside the USASCII character set which is currently given local meaning within many systems. It's intended to indicate that the Break Key or the Attention Key was hit. =back =over 4 =item B - scalar reference to object's input buffer $ref = $obj->buffer; This method returns a scalar reference to the input buffer for I<$obj>. Data in the input buffer is data that has been read from the remote side but has yet to be read by the user. Modifications to the input buffer are returned by a subsequent read. =back =over 4 =item B - discard all data in object's input buffer $obj->buffer_empty; This method removes all data in the input buffer for I<$obj>. =back =over 4 =item B - close object $ok = $obj->close; This method closes the socket, file, or pipe associated with the object. =back =over 4 =item B - issue command and retrieve output $ok = $obj->cmd($string); $ok = $obj->cmd(String => $string, [Output => $ref,] [Prompt => $match,] [Timeout => $secs,] [Cmd_remove_mode => $mode,]); @output = $obj->cmd($string); @output = $obj->cmd(String => $string, [Output => $ref,] [Prompt => $match,] [Timeout => $secs,] [Cmd_remove_mode => $mode,]); This method sends the command I<$string>, and reads the characters sent back by the command up until and including the matching prompt. It's assumed that the program to which you're sending is some kind of command prompting interpreter such as a shell. In a scalar context the characters read are discarded and a boolean is returned indicating the success or failure of sending the command string and reading the prompt. Note that in order to return on error, C must not be set to C<"die">. In an array context, just the output generated by the command is returned, one line per element. In other words, all the characters in between the echoed back command string and the prompt are returned. If the command happens to return no output, an array containing one element, the null string is returned. This is so the array will indicate true in a boolean context. Many command interpreters echo back the command sent. In most situations, this method removes the first line returned from the remote side (i.e. the echoed back command). See C for more control over this feature. Use C to debug when this method keeps timing-out and you don't think it should. Optional named arguments are provided to override the current settings of prompt, timeout, and cmd_remove_mode. The I named argument provides an alternative method of receiving command output. If you pass a scalar reference, all the output (even if it contains multiple lines) is returned in the referenced scalar. If you pass an array or hash reference, the lines of output are returned in the referenced array or hash. =back =over 4 =item B - toggle removal of echoed commands $mode = $obj->cmd_remove_mode; $prev = $obj->cmd_remove_mode($mode); This method controls how to deal with echoed back commands in the output returned by cmd(). Typically, when you send a command to the remote side, the first line of output returned is the command echoed back. Use this mode to remove the first line of output normally returned by cmd(). If no argument is given, the current mode is returned. If I<$mode> is C<0> then the command output returned from cmd() has no lines removed. If I<$mode> is a positive integer, then the first I<$mode> lines of command output are stripped. By default, I<$mode> is set to C<"auto">. Auto means that whether or not the first line of command output is stripped, depends on whether or not the remote side offered to echo. By default, Net::Telnet always accepts an offer to echo by the remote side. You can change the default to reject such an offer using C. =back =over 4 =item B - log all I/O in dump format $fh = $obj->dump_log; $fh = $obj->dump_log($fh); $fh = $obj->dump_log($filename); This method starts or stops dump format logging of all the object's input and output. The dump format shows the blocks read and written in a hexadecimal and printable character format. This method is useful when debugging, however you might want to first try C as it's more readable. If no argument is given, the current log filehandle is returned. A null string indicates logging is off. To stop logging, use a null string as an argument. If an open filehandle is given, it is used for logging and returned. Otherwise, the argument is assumed to be the name of a file, the file is opened and a filehandle to it is returned. =back =over 4 =item B - end of file indicator $eof = $obj->eof; This method indicates if end of file has been read. Because the input is buffered this isn't the same thing as I<$obj> has closed. In other words I<$obj> can be closed but there still can be stuff in the buffer to be read. Under this condition you can still read but you won't be able to write. =back =over 4 =item B - define action to be performed on error $mode = $obj->errmode; $prev = $obj->errmode($mode); This method gets or sets the action used when errors are encountered using the object. The first calling sequence returns the current error mode. The second calling sequence sets it to I<$mode> and returns the previous mode. Valid values for I<$mode> are C<"die"> (the default), C<"return">, a I, or an I. When mode is C<"die"> and an error is encountered using the object, then an error message is printed to standard error and the program dies. When mode is C<"return"> then the method generating the error places an error message in the object and returns the undefined value in a scalar context and a null list in list context. The error message may be obtained using C. When mode is a I, then when an error is encountered I is called with the error message as its first argument. Using this mode you may have your own subroutine handle errors. If I itself returns then the method generating the error returns undefined or a null list depending on context. When mode is an I, the first element of the array must be a I. Any elements that follow are the arguments to I. When an error is encountered, the I is called with its arguments. Using this mode you may have your own subroutine handle errors. If the I itself returns then the method generating the error returns undefined or a null list depending on context. =back =over 4 =item B - most recent error message $msg = $obj->errmsg; $prev = $obj->errmsg(@msgs); The first calling sequence returns the error message associated with the object. The null string is returned if no error has been encountered yet. The second calling sequence sets the error message for the object to the concatenation of I<@msgs> and returns the previous error message. Normally, error messages are set internally by a method when an error is encountered. =back =over 4 =item B - perform the error mode action $obj->error(@msgs); This method concatenates I<@msgs> into a string and places it in the object as the error message. Also see C. It then performs the error mode. Also see C. If the error mode doesn't cause the program to die then the undefined value or a null list is returned depending on context. This method is primarily used by this class or a sub-class to perform the user requested action when an error is encountered. =back =over 4 =item B - use already open filehandle for I/O $ok = $obj->fhopen($fh); This method associates the open filehandle I<$fh> with I<$obj> for further I/O. Filehandle I<$fh> must already be opened. Suppose you want to use the features of this module to do I/O to something other than a TCP port, for example STDIN or a filehandle opened to read from a process. Instead of opening the object for I/O to a TCP port by using C or C, call this method instead. =back =over 4 =item B - read block of data $data = $obj->get([Timeout => $secs,]); This method reads a block of data from the object and returns it along with any buffered data. If no buffered data is available to return, it will wait for data to read using the timeout specified in the object. You can override that timeout using I<$secs>. Also see C. If buffered data is available to return, it also checks for a block of data that can be immediately read. On eof an undefined value is returned. On time-out or other errors the error mode action is performed. An undefined value is returned for both eof and time-out when I is not set to C<"die">. Use C and C to distinguish. =back =over 4 =item B - read next line $line = $obj->getline([Timeout => $secs,]); This method reads and returns the next line of data from the object. You can use C to change the notion of what separates a line. The default is C<"\n">. If a line isn't immediately available, this method blocks waiting for a line or the timeout. You can override the object's timeout for this method using I<$secs>. Also see C. On eof an undefined value is returned. On timeout or other errors the error mode action is performed. An undefined value is returned for both eof and time-out when I is not set to C<"die">. Use C and C to distinguish. =back =over 4 =item B - read next lines @lines = $obj->getlines([Timeout => $secs,]); This method reads and returns the next available lines of data from the object. You can use C to change the notion of what separates a line. The default is C<"\n">. If a line isn't immediately available, this method blocks waiting for one or more lines, or the timeout. You can override the object's timeout for this method using I<$secs>. Also see C. On eof a null array is returned. On timeout or other errors the error mode action is performed. A null array is returned for both eof and time-out when I is not set to C<"die">. Use C and C to distinguish. =back =over 4 =item B - name of remote host $host = $obj->host; $prev = $obj->host($host); This method designates the remote host. With no argument this method returns the current host name set in the object. With an argument it sets the current host name to I<$host> and returns the previous host name. You may indicate the remote host using either a hostname or an IP address. =back =over 4 =item B - log all input $fh = $obj->input_log; $fh = $obj->input_log($fh); $fh = $obj->input_log($filename); This method starts or stops logging of input. This is useful when debugging. Also see C. Because most command interpreters echo back commands received, its likely all your output will also be in this log. Note that input logging occurs after newline translation. See C for details on newline translation. If no argument is given, the log filehandle is returned. A null string indicates logging is off. To stop logging, use a null string as an argument. If an open filehandle is given, it is used for logging and returned. Otherwise, the argument is assumed to be the name of a file, the file is opened for logging and a filehandle to it is returned. =back =over 4 =item B - input line delimiter $rs = $obj->input_record_separator; $prev = $obj->input_record_separator($rs); This method designates the line delimiter for input. It's used with C, C, and C to determine lines in the input. With no argument this method returns the current input record separator set in the object. With an argument it sets the input record separator to I<$rs> and returns the previous value. =back =over 4 =item B - last line read $line = $obj->lastline; $prev = $obj->lastline($line); This method saves the last line read from the object. This may be a useful error message when the remote side abnormally closes the connection. Typically the remote side will print an error message before closing. With no argument this method returns the last line read from the object. With an argument it sets the last line read to I<$line> and returns the previous value. Normally, only internal methods set the last line. =back =over 4 =item B - perform standard login $ok = $obj->login($username, $password); $ok = $obj->login(Name => $username, Password => $password, [Prompt => $match,] [Timeout => $secs,]); This method performs a standard login by waiting for a login prompt and responding with I<$username>, then waiting for the password prompt and responding with I<$password>, and then waiting for the command interpreter prompt. If any of those prompts sent by the remote side don't match what's expected, this method will timeout - unless timeout is turned off. Login prompts must match either of the patterns: /login[: ]*$/i /username[: ]*$/i Password prompts must match the pattern: /password[: ]*$/i The command interpreter prompt must match the current setting of prompt. Use C to debug when this method keeps timing-out and you don't think it should. Optional named arguments are provided to override the current settings of prompt and timeout. =back =over 4 =item B - maximum size of input buffer $len = $obj->max_buffer_length; $prev = $obj->max_buffer_length($len); This method designates the maximum size of the input buffer. An error is generated when a read causes the buffer to exceed this limit. The default value is 1,048,576 bytes (1MB). The input buffer can grow much larger than the block size when you continuously read using C or C and the data stream contains no newlines or matching waitfor patterns. With no argument this method returns the current maximum buffer length set in the object. With an argument it sets the maximum buffer length to I<$len> and returns the previous value. =back =over 4 =item B - connect to port on remote host $ok = $obj->open($host); $ok = $obj->open([Host => $host,] [Port => $port,] [Timeout => $secs,]); This method opens a TCP connection to I<$port> on I<$host>. If either argument is missing then the current value of C or C is used. An optional named argument is provided to override the current setting of timeout. On time-out or other connection errors, the error mode action is performed. Timeouts don't work for this method on machines that don't implement SIGALRM - most notably Win32 machines. For those machines, an error is returned when the system reaches its own time-out while trying to connect. A side effect of this method is to reset the alarm interval associated with SIGALRM. =back =over 4 =item B - indicate willingness to accept a TELNET option $fh = $obj->option_accept([Do => $telopt,] [Dont => $telopt,] [Will => $telopt,] [Wont => $telopt,]); This method is used to indicate whether to accept or reject an offer to enable a TELNET option made by the remote side. If you're using I or I to indicate a willingness to enable, then a notification callback must have already been defined by a prior call to C. See C for details on receiving enable/disable notification of a TELNET option. You can give multiple I, I, I, or I arguments for different TELNET options in the same call to this method. The following example describes the meaning of the named arguments. A TELNET option, such as C used below, is an integer constant that you can import from Net::Telnet. See the source in file Telnet.pm for the complete list. =over 4 =item I => C =over 4 =item we'll accept an offer to enable the echo option on the local side =back =item I => C =over 4 =item we'll reject an offer to enable the echo option on the local side =back =item I => C =over 4 =item we'll accept an offer to enable the echo option on the remote side =back =item I => C =over 4 =item we'll reject an offer to enable the echo option on the remote side =back =back =item Use C to send a request to the remote side to enable or disable a particular TELNET option. =back =over 4 =item B - define the option negotiation callback $coderef = $obj->option_callback; $prev = $obj->option_callback($coderef); This method defines the callback subroutine that's called when a TELNET option is enabled or disabled. Once defined, the I may not be undefined. However, calling this method with a different I<$coderef> changes it. Here are the circumstances that invoke I<$coderef>: =over 4 =item An option becomes enabled because the remote side requested an enable and C had been used to arrange that it be accepted. =item The remote side arbitrarily decides to disable an option that is currently enabled. Note that Net::Telnet always accepts a request to disable from the remote side. =item C was used to send a request to enable or disable an option and the response from the remote side has just been received. Note, that if a request to enable is rejected then I<$coderef> is still invoked even though the option didn't change. =back =item Here are the arguments passed to I<&$coderef>: &$coderef($obj, $option, $is_remote, $is_enabled, $was_enabled, $buf_position); =over 4 =item 1. I<$obj> is the Net::Telnet object =item 2. I<$option> is the TELNET option. Net::Telnet exports constants for the various TELNET options which just equate to an integer. =item 3. I<$is_remote> is a boolean indicating for which side the option applies. =item 4. I<$is_enabled> is a boolean indicating the option is enabled or disabled =item 5. I<$was_enabled> is a boolean indicating the option was previously enabled or disabled =item 6. I<$buf_position> is an integer indicating the position in the object's input buffer where the option takes effect. See C to access the object's input buffer. =back =back =over 4 =item B - log all TELNET options sent or received $fh = $obj->option_log; $fh = $obj->option_log($fh); $fh = $obj->option_log($filename); This method starts or stops logging of all TELNET options being sent or received. This is useful for debugging when you send options via C or you arrange to accept option requests from the remote side via C. Also see C. If no argument is given, the log filehandle is returned. A null string indicates logging is off. To stop logging, use a null string as an argument. If an open filehandle is given, it is used for logging and returned. Otherwise, the argument is assumed to be the name of a file, the file is opened for logging and a filehandle to it is returned. =back =over 4 =item B - send TELNET option negotiation request $ok = $obj->option_send([Do => $telopt,] [Dont => $telopt,] [Will => $telopt,] [Wont => $telopt,] [Async => $boolean,]); This method is not yet implemented. Look for it in a future version. =back =over 4 =item B - get current state of a TELNET option $hashref = $obj->option_state($telopt); This method returns a hashref containing a copy of the current state of TELNET option I<$telopt>. Here are the values returned in the hash: =over 4 =item I<$hashref>->{remote_enabled} =over 4 =item boolean that indicates if the option is enabled on the remote side. =back =item I<$hashref>->{remote_enable_ok} =over 4 =item boolean that indicates if it's ok to accept an offer to enable this option on the remote side. =back =item I<$hashref>->{remote_state} =over 4 =item string used to hold the internal state of option negotiation for this option on the remote side. =back =item I<$hashref>->{local_enabled} =over 4 =item boolean that indicates if the option is enabled on the local side. =back =item I<$hashref>->{local_enable_ok} =over 4 =item boolean that indicates if it's ok to accept an offer to enable this option on the local side. =back =item I<$hashref>->{local_state} =over 4 =item string used to hold the internal state of option negotiation for this option on the local side. =back =back =back =over 4 =item B - field separator for print $ofs = $obj->output_field_separator; $prev = $obj->output_field_separator($ofs); This method designates the output field separator for C. Ordinarily the print method simply prints out the comma separated fields you specify. Set this to specify what's printed between fields. With no argument this method returns the current output field separator set in the object. With an argument it sets the output field separator to I<$ofs> and returns the previous value. =back =over 4 =item B - log all output $fh = $obj->output_log; $fh = $obj->output_log($fh); $fh = $obj->output_log($filename); This method starts or stops logging of output. This is useful when debugging. Also see C. Because most command interpreters echo back commands received, its likely all your output would also be in an input log. See C. Note that output logging occurs before newline translation. See C for details on newline translation. If no argument is given, the log filehandle is returned. A null string indicates logging is off. To stop logging, use a null string as an argument. If an open filehandle is given, it is used for logging and returned. Otherwise, the argument is assumed to be the name of a file, the file is opened for logging and a filehandle to it is returned. =back =over 4 =item B - output line delimiter $ors = $obj->output_record_separator; $prev = $obj->output_record_separator($ors); This method designates the output record separator for C. Ordinarily the print operator simply prints out the comma separated fields you specify, with no trailing newline or record separator assumed. Set this variable to specify what's printed at the end of the print. Note: the output record separator is set to C<"\n"> by default, so there's no need to append all your commands with a newline. With no argument this method returns the current output record separator set in the object. With an argument it sets the output record separator to I<$ors> and returns the previous value. =back =over 4 =item B - remote port $port = $obj->port; $prev = $obj->port($port); This method designates the remote TCP port. With no argument this method returns the current port number. With an argument it sets the current port number to I<$port> and returns the previous port. If I<$port> is a service name, then first it's converted to a port number using the perl function C. =back =over 4 =item B - write to object $ok = $obj->print(@list); This method prints a string or a comma-separated list of strings to the opened object and returns non-zero if all data was successfully written. By default, the C is set to C<"\n"> in order to have your commands automatically end with a newline. In most cases your output is being read by a command interpreter which won't accept a command until newline is read. This is similar to someone typing a command and hitting the return key. On failure, it's possible that some data was written. If you choose to try and recover from a print timing-out, use C to determine how much was written before time-out occurred. =back =over 4 =item B - number of bytes written by print $num = $obj->print_length; This returns the number of bytes successfully written by the most recent C. =back =over 4 =item B - pattern to match a prompt $matchop = $obj->prompt; $prev = $obj->prompt($matchop); This method sets the pattern used to find a prompt in the input stream. It must be a string representing a valid perl pattern match operator. The methods C and C try to read until matching the prompt. They will fail with a time-out error if the pattern you've chosen doesn't match what the remote side sends. With no argument this method returns the prompt set in the object. With an argument it sets the prompt to I<$matchop> and returns the previous value. The default prompt is C<'/[\$%#E] $/'> Always use single quotes, instead of double quotes, to construct I<$matchop> (e.g. C<'/bash\$ $/'>). If you're constructing a DOS like file path, you'll need to use four backslashes to represent one (e.g. C<'/c:\\\\users\\\\billE$/i'>). Of course don't forget about regexp metacharacters like C<.>, C<[>, or C<$>. You'll only need a single backslash to quote them. The anchor metacharacters C<^> and C<$> refer to positions in the input buffer. =back =over 4 =item B - turn off/on telnet command interpretation $mode = $obj->telnetmode; $prev = $obj->telnetmode($mode); This method controls whether or not TELNET commands in the data stream are recognized and handled. The TELNET protocol uses certain character sequences sent in the data stream to control the session. If the port you're connecting to isn't using the TELNET protocol, then you should turn this mode off. The default is I. If no argument is given, the current mode is returned. If I<$mode> is C<0> then telnet mode is off. If I<$mode> is C<1> then telnet mode is on. =back =over 4 =item B - time-out indicator $boolean = $obj->timed_out; $prev = $obj->timed_out($boolean); This method indicates if a previous read or write method timed-out. With no argument this method returns true if a previous method timed-out. With an argument it sets the indicator. Normally, only internal methods set this indicator. =back =over 4 =item B - I/O time-out interval $secs = $obj->timeout; $prev = $obj->timeout($secs); This method sets the timeout interval that's used when performing I/O or connecting to a port. When a method doesn't complete within the timeout interval then it's an error and the error mode action is performed. The timeout may be expressed as a relative or absolute value. If I<$secs> is greater than or equal to the time the program was started, as determined by $^T, then it's the absolute time when timeout occurs. Also see the perl function C. A relative timeout happens I<$secs> from when the I/O method begins. If I<$secs> is C<0> then timeout occurs if the data cannot be immediately read or written. Use the undefined value to turn off timing-out. With no argument this method returns the timeout set in the object. With an argument it sets the timeout to I<$secs> and returns the previous value. =back =over 4 =item B - wait for pattern in the input $ok = $obj->waitfor($matchop); $ok = $obj->waitfor([Match => $matchop,] [String => $string,] [Timeout => $secs,]); ($prematch, $match) = $obj->waitfor($matchop); ($prematch, $match) = $obj->waitfor([Match => $matchop,] [String => $string,] [Timeout => $secs,]); This method reads until a pattern match or string is found in the input stream. All the characters before and including the match are removed from the input stream. On time-out, eof, or other errors the error mode action is performed. In an array context the characters before the match and the matched characters are returned in I<$prematch> and I<$match>. You can specify more than one pattern or string by simply providing multiple I and/or I named arguments. A I<$matchop> must be a string representing a valid Perl pattern match operator. The I<$string> is just a substring to find in the input stream. Use C to debug when this method keeps timing-out and you don't think it should. An optional named argument is provided to override the current setting of timeout. To avoid unexpected backslash interpretation, always use single quotes instead of double quotes to construct a match operator argument for C and C (e.g. C<'/bash\$ $/'>). If you're constructing a DOS like file path, you'll need to use four backslashes to represent one (e.g. C<'/c:\\\\users\\\\billE$/i'>). Of course don't forget about regexp metacharacters like C<.>, C<[>, or C<$>. You'll only need a single backslash to quote them. The anchor metacharacters C<^> and C<$> refer to positions in the input buffer. =back =head1 SEE ALSO =over 2 =item RFC 854 S S =item RFC 1143 S S =item TELNET Option Assignments S =back =head1 EXAMPLES This example gets the current weather forecast for Brainerd, Minnesota. my($forecast, $t); use Net::Telnet (); $t = new Net::Telnet; $t->open("rainmaker.wunderground.com"); ## Wait for first prompt and "hit return". $t->waitfor('/continue:.*$/'); $t->print(""); ## Wait for second prompt and respond with city code. $t->waitfor('/city code.*$/'); $t->print("BRD"); ## Read and print the first page of forecast. ($forecast) = $t->waitfor('/[ \t]+press return to continue/i'); print $forecast; exit; This example checks a POP server to see if you have mail. my($hostname, $line, $passwd, $pop, $username); $hostname = "your_destination_host_here"; $username = "your_username_here"; $passwd = "your_password_here"; use Net::Telnet (); $pop = new Net::Telnet (Telnetmode => 0); $pop->open(Host => $hostname, Port => 110); ## Read connection message. $line = $pop->getline; die $line unless $line =~ /^\+OK/; ## Send user name. $pop->print("user $username"); $line = $pop->getline; die $line unless $line =~ /^\+OK/; ## Send password. $pop->print("pass $passwd"); $line = $pop->getline; die $line unless $line =~ /^\+OK/; ## Request status of messages. $pop->print("list"); $line = $pop->getline; print $line; exit; Here's an example you can use to down load a file of any type. The file is read from the remote host's standard output using cat. To prevent any output processing, the remote host's standard output is put in raw mode using the Bourne shell. The Bourne shell is used because some shells, notably tcsh, prevent changing tty modes. Upon completion, FTP style statistics are printed to stderr. my($block, $filename, $host, $hostname, $k_per_sec, $line, $num_read, $passwd, $prevblock, $prompt, $size, $size_bsd, $size_sysv, $start_time, $total_time, $username); $hostname = "your_destination_host_here"; $username = "your_username_here"; $passwd = "your_password_here"; $filename = "your_download_file_here"; ## Connect and login. use Net::Telnet (); $host = new Net::Telnet (Timeout => 30, Prompt => '/[%#>] $/'); $host->open($hostname); $host->login($username, $passwd); ## Make sure prompt won't match anything in send data. $prompt = '_funkyPrompt_'; $host->prompt("/$prompt\$/"); $host->cmd("set prompt = '$prompt'"); ## Get size of file. ($line) = $host->cmd("/usr/bin/ls -l $filename"); ($size_bsd, $size_sysv) = (split ' ', $line)[3,4]; if ($size_sysv =~ /^\d+$/) { $size = $size_sysv; } elsif ($size_bsd =~ /^\d+$/) { $size = $size_bsd; } else { die "$filename: no such file on $hostname"; } ## Start sending the file. binmode STDOUT; $host->binmode(1); $host->print("/usr/bin/sh -c 'stty raw; cat $filename'"); $host->getline; # discard echoed back line ## Read file a block at a time. $num_read = 0; $prevblock = ''; $start_time = time; while (($block = $host->get) and ($block !~ /$prompt$/o)) { if (length $block >= length $prompt) { print $prevblock; $num_read += length $prevblock; $prevblock = $block; } else { $prevblock .= $block; } } $host->close; ## Print last block without trailing prompt. $prevblock .= $block; $prevblock =~ s/$prompt$//; print $prevblock; $num_read += length $prevblock; die "error: expected size $size, received size $num_read\n" unless $num_read == $size; ## Print totals. $total_time = (time - $start_time) || 1; $k_per_sec = ($size / 1024) / $total_time; $k_per_sec = sprintf "%3.1f", $k_per_sec; warn("$num_read bytes received in $total_time seconds ", "($k_per_sec Kbytes/s)\n"); exit; Here's an example that shows how to talk to a program that must communicate via a terminal. In this case we're talking to the telnet program via a pseudo-terminal. We use the Comm package to start the telnet program and return a filehandle to the pseudo-terminal. This example sends some initial commands and then allows the user to type commands to the telnet session. my($comm_pty, $host, $hostname, $passwd, $pty, $username, @lines); $hostname = "your_host_here"; $username = "your_name_here"; $passwd = "your_passwd_here"; ## Start the telnet program so we can talk to it via a ## pseudo-terminal. { local $^W = 0; # Comm.pl isn't warning clean require "Comm.pl"; &Comm::init("close_it", "interact", "open_proc", "stty_raw", "stty_sane"); $comm_pty = &open_proc("telnet $hostname") or die "open_proc failed"; ## Unfortunately the Comm package doesn't ## return us a fully qualified filehandle. We ## must keep the filehandle Comm returned for ## its use and we must build another filehandle ## qualified with the current package for our ## use. $pty = "main::" . $comm_pty; } ## Obtain a new Net::Telnet object that does I/O to the ## pseudo-terminal attached to the running telnet ## program. The "Telnetmode" is "off" because we're ## not talking directly to a telnet port as we normally ## do, we're talking to a pseudo-terminal. The ## "Output_record_separator" is now a carriage return ## because that's what you'd normally hit when you get ## done typing a line at a terminal. use Net::Telnet (); $host = new Net::Telnet (Fhopen => $pty, Timeout => 10, Prompt => '/[\$%#>] $/', Output_record_separator => "\r", Telnetmode => 0, Cmd_remove_mode => 1); ## Issue some commands. $host->login($username, $passwd); $host->cmd("setenv DISPLAY $ENV{DISPLAY}"); print $host->cmd("who"); ## Allow the user to interact with telnet program until ## they exit. { no strict 'subs'; # so we can refer to STDIN local $^W = 0; # Comm.pl isn't warning clean &stty_raw(STDIN); &interact($comm_pty); &stty_sane(STDIN); &close_it($comm_pty); } print "Exited telnet\n"; exit; =head1 AUTHOR Jay Rogers Ejay@rgrs.comE =head1 COPYRIGHT Copyright (c) 1997 Jay Rogers. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. cisco-auditing-tool-1.0/lib/.svn/0000755000000000000000000000000012046511414015355 5ustar rootrootcisco-auditing-tool-1.0/lib/.svn/entries0000444000000000000000000000055712046511414016756 0ustar rootroot10 dir 1733 svn+ssh://dookie@10.0.0.12/var/svn/backtrack/microverse/c/cisco-auditing-tool/source-cisco-auditing-tool-1.0-bt1/var/backtrack/sources/cisco-auditing-tool/1.0/bt1/upstream-sources/cisco-auditing-tool/lib svn+ssh://dookie@10.0.0.12/var/svn/backtrack 2011-04-18T09:02:05.482722Z 327 emgent d9273255-a111-4fa6-bf0a-919607b5ba98 Net dir cisco-auditing-tool-1.0/lib/.svn/text-base/0000755000000000000000000000000012046511414017251 5ustar rootrootcisco-auditing-tool-1.0/lib/.svn/tmp/0000755000000000000000000000000012046511414016155 5ustar rootrootcisco-auditing-tool-1.0/lib/.svn/tmp/text-base/0000755000000000000000000000000012046511414020051 5ustar rootrootcisco-auditing-tool-1.0/lib/.svn/tmp/props/0000755000000000000000000000000012046511414017320 5ustar rootrootcisco-auditing-tool-1.0/lib/.svn/tmp/prop-base/0000755000000000000000000000000012046511414020045 5ustar rootrootcisco-auditing-tool-1.0/lib/.svn/props/0000755000000000000000000000000012046511414016520 5ustar rootrootcisco-auditing-tool-1.0/lib/.svn/prop-base/0000755000000000000000000000000012046511414017245 5ustar rootrootcisco-auditing-tool-1.0/TODO0000644000000000000000000000012712046511414014413 0ustar rootroot* add enable scanner * add "traceroute" scanner * add ip list router scanner/detector cisco-auditing-tool-1.0/.svn/0000755000000000000000000000000012046511414014607 5ustar rootrootcisco-auditing-tool-1.0/.svn/entries0000444000000000000000000000124712046511414016205 0ustar rootroot10 dir 1733 svn+ssh://dookie@10.0.0.12/var/svn/backtrack/microverse/c/cisco-auditing-tool/source-cisco-auditing-tool-1.0-bt1/var/backtrack/sources/cisco-auditing-tool/1.0/bt1/upstream-sources/cisco-auditing-tool svn+ssh://dookie@10.0.0.12/var/svn/backtrack 2011-04-18T09:02:05.482722Z 327 emgent d9273255-a111-4fa6-bf0a-919607b5ba98 plugins dir TODO file 2011-08-26T04:18:02.838183Z 7b25ae111249f6dcc26f005d585bf364 2011-04-18T09:02:05.482722Z 327 emgent 87 lib dir CAT file 2011-08-26T04:18:02.838183Z 8f20942c9df21524ded6ad1c2ef1fae2 2011-04-18T09:02:05.482722Z 327 emgent has-props 3420 lists dir cisco-auditing-tool-1.0/.svn/text-base/0000755000000000000000000000000012046511414016503 5ustar rootrootcisco-auditing-tool-1.0/.svn/text-base/CAT.svn-base0000444000000000000000000000653412046511414020560 0ustar rootroot#!/usr/bin/perl # use lib './lib'; use Getopt::Std; $|=1; require './plugins/usage'; require './plugins/brute'; require './plugins/snmp'; require './plugins/ihist'; getopts("h:f:p:w:a:l:iq", \%args); if(!%args) { usage(); exit; } #if(!defined $args{l}) { #$logfile = "$args{h}.log"; #} else { #$logfile = $args{l}; elsif(!defined $args{h} && !defined $args {f}) { usage(); exit; } if(defined $args{f}) { @hosts = `cat $args{f}`; } else { @hosts = $args{h}; } if(defined $args{p}) { $port = $args{p}; } else { $port = 23; } if(defined $args{w}) { @community = `cat $args{w}`; } else { @community = ( "public", "private" ); } if(defined $args{a}) { @wordlist = `cat $args{a}`; } else { @wordlist = ( "cisco", "ciscos", "cisco1", "router", "router1", "admin", "Admin" ) ; } if(defined $args{i}) { $ioshist = 1; } if(defined $args{l}) { $logfile = $args{l}; open LOG, ">$logfile"; } if(defined $args{q}) { $quiet = 1; } if (!defined $quiet) { print "\nCisco Auditing Tool - g0ne [null0]\n\n"; } if (defined $logfile) { print LOG "\nCisco Auditing Tool - g0ne [null0]\n\n"; } foreach(@hosts) { $hostname = $_; chomp $hostname; if (!defined $quiet) { print "Checking Host: $hostname\n\n\n"; print "Guessing passwords: \n\n"; } if (defined $logfile) { print LOG "Checking Host: $hostname\n\n\n"; print LOG "Guessing passwords: \n\n"; } foreach(@wordlist) { $password = $_; chomp $password; $ret = brute($hostname, $port, $password); if ($ret eq 1) { if (!defined $quiet) { print "Password Found: $password\n"; } if (defined $logfile) { print LOG "Password Found: $password\n"; } } else { if (!defined $quiet) { print "Invalid Password: $password\n"; } if (defined $logfile) { print LOG "Invalid Password: $password\n"; } } sleep 2; } if (!defined $quiet) { print "\n\nGuessing Community Names: \n\n"; } if (defined $logfile) { print LOG "\n\nGuessing Community Names: \n\n"; } foreach(@community) { $community = $_; chomp $community; $ret = snmp($hostname, $community); if ($ret eq 1) { if (!defined $quiet) { print "Community Name Found: $community\n"; } if (defined $logile) { #print to log file } } else { if (!defined $quiet) { print "Invalid Community Name: $community\n"; } if (defined $logfile) { print LOG "Invalid Community Name: $community\n"; } } } if (defined $ioshist) { if (!defined $quiet) { print "\n\nChecking for IOS History Bug: \n\n"; } if (defined $logfile) { print LOG "\n\nChecking for IOS History Bug: \n\n"; } ($users, $history) = ihist($hostname, $port); if (!defined $quiet) { print "Users Currently Logged In: \n"; print $users; print "\n\n"; print "History Log: \n"; print $history; print "\n"; } if (defined $logfile) { print LOG "Users Currently Logged In: \n"; print LOG $users; print LOG "\n\n"; print LOG "History Log: \n"; print LOG $history; print LOG "\n"; } } if (!defined $quiet) { print "\n---------------------------------------------------\n\n"; } if (defined $logfile) { print LOG "\n---------------------------------------------------\n\n"; } } if (!defined $quiet) { print "Audit Complete\n\n"; } if (defined $logfile) { print LOG "Audit Complete\n\n"; close LOG; } exit; cisco-auditing-tool-1.0/.svn/text-base/TODO.svn-base0000444000000000000000000000012712046511414020706 0ustar rootroot* add enable scanner * add "traceroute" scanner * add ip list router scanner/detector cisco-auditing-tool-1.0/.svn/tmp/0000755000000000000000000000000012046511414015407 5ustar rootrootcisco-auditing-tool-1.0/.svn/tmp/text-base/0000755000000000000000000000000012046511414017303 5ustar rootrootcisco-auditing-tool-1.0/.svn/tmp/props/0000755000000000000000000000000012046511414016552 5ustar rootrootcisco-auditing-tool-1.0/.svn/tmp/prop-base/0000755000000000000000000000000012046511414017277 5ustar rootrootcisco-auditing-tool-1.0/.svn/props/0000755000000000000000000000000012046511414015752 5ustar rootrootcisco-auditing-tool-1.0/.svn/prop-base/0000755000000000000000000000000012046511414016477 5ustar rootrootcisco-auditing-tool-1.0/.svn/prop-base/CAT.svn-base0000444000000000000000000000003612046511414020543 0ustar rootrootK 14 svn:executable V 1 * END cisco-auditing-tool-1.0/CAT0000755000000000000000000000653412046511414014270 0ustar rootroot#!/usr/bin/perl # use lib './lib'; use Getopt::Std; $|=1; require './plugins/usage'; require './plugins/brute'; require './plugins/snmp'; require './plugins/ihist'; getopts("h:f:p:w:a:l:iq", \%args); if(!%args) { usage(); exit; } #if(!defined $args{l}) { #$logfile = "$args{h}.log"; #} else { #$logfile = $args{l}; elsif(!defined $args{h} && !defined $args {f}) { usage(); exit; } if(defined $args{f}) { @hosts = `cat $args{f}`; } else { @hosts = $args{h}; } if(defined $args{p}) { $port = $args{p}; } else { $port = 23; } if(defined $args{w}) { @community = `cat $args{w}`; } else { @community = ( "public", "private" ); } if(defined $args{a}) { @wordlist = `cat $args{a}`; } else { @wordlist = ( "cisco", "ciscos", "cisco1", "router", "router1", "admin", "Admin" ) ; } if(defined $args{i}) { $ioshist = 1; } if(defined $args{l}) { $logfile = $args{l}; open LOG, ">$logfile"; } if(defined $args{q}) { $quiet = 1; } if (!defined $quiet) { print "\nCisco Auditing Tool - g0ne [null0]\n\n"; } if (defined $logfile) { print LOG "\nCisco Auditing Tool - g0ne [null0]\n\n"; } foreach(@hosts) { $hostname = $_; chomp $hostname; if (!defined $quiet) { print "Checking Host: $hostname\n\n\n"; print "Guessing passwords: \n\n"; } if (defined $logfile) { print LOG "Checking Host: $hostname\n\n\n"; print LOG "Guessing passwords: \n\n"; } foreach(@wordlist) { $password = $_; chomp $password; $ret = brute($hostname, $port, $password); if ($ret eq 1) { if (!defined $quiet) { print "Password Found: $password\n"; } if (defined $logfile) { print LOG "Password Found: $password\n"; } } else { if (!defined $quiet) { print "Invalid Password: $password\n"; } if (defined $logfile) { print LOG "Invalid Password: $password\n"; } } sleep 2; } if (!defined $quiet) { print "\n\nGuessing Community Names: \n\n"; } if (defined $logfile) { print LOG "\n\nGuessing Community Names: \n\n"; } foreach(@community) { $community = $_; chomp $community; $ret = snmp($hostname, $community); if ($ret eq 1) { if (!defined $quiet) { print "Community Name Found: $community\n"; } if (defined $logile) { #print to log file } } else { if (!defined $quiet) { print "Invalid Community Name: $community\n"; } if (defined $logfile) { print LOG "Invalid Community Name: $community\n"; } } } if (defined $ioshist) { if (!defined $quiet) { print "\n\nChecking for IOS History Bug: \n\n"; } if (defined $logfile) { print LOG "\n\nChecking for IOS History Bug: \n\n"; } ($users, $history) = ihist($hostname, $port); if (!defined $quiet) { print "Users Currently Logged In: \n"; print $users; print "\n\n"; print "History Log: \n"; print $history; print "\n"; } if (defined $logfile) { print LOG "Users Currently Logged In: \n"; print LOG $users; print LOG "\n\n"; print LOG "History Log: \n"; print LOG $history; print LOG "\n"; } } if (!defined $quiet) { print "\n---------------------------------------------------\n\n"; } if (defined $logfile) { print LOG "\n---------------------------------------------------\n\n"; } } if (!defined $quiet) { print "Audit Complete\n\n"; } if (defined $logfile) { print LOG "Audit Complete\n\n"; close LOG; } exit; cisco-auditing-tool-1.0/lists/0000755000000000000000000000000012046511414015061 5ustar rootrootcisco-auditing-tool-1.0/lists/.svn/0000755000000000000000000000000012046511414015745 5ustar rootrootcisco-auditing-tool-1.0/lists/.svn/entries0000444000000000000000000000121112046511414017332 0ustar rootroot10 dir 1733 svn+ssh://dookie@10.0.0.12/var/svn/backtrack/microverse/c/cisco-auditing-tool/source-cisco-auditing-tool-1.0-bt1/var/backtrack/sources/cisco-auditing-tool/1.0/bt1/upstream-sources/cisco-auditing-tool/lists svn+ssh://dookie@10.0.0.12/var/svn/backtrack 2011-04-18T09:02:05.482722Z 327 emgent d9273255-a111-4fa6-bf0a-919607b5ba98 community file 2011-08-26T04:18:02.838183Z 2ee6702fa9863abef9b54a17eba858c9 2011-04-18T09:02:05.482722Z 327 emgent 20 passwords file 2011-08-26T04:18:02.838183Z 69d43b46354a69cc86cad4ab5630974e 2011-04-18T09:02:05.482722Z 327 emgent 18 cisco-auditing-tool-1.0/lists/.svn/text-base/0000755000000000000000000000000012046511414017641 5ustar rootrootcisco-auditing-tool-1.0/lists/.svn/text-base/passwords.svn-base0000444000000000000000000000002212046511414023316 0ustar rootrootlist cisco1 cisco cisco-auditing-tool-1.0/lists/.svn/text-base/community.svn-base0000444000000000000000000000002412046511414023317 0ustar rootrootlist public private cisco-auditing-tool-1.0/lists/.svn/tmp/0000755000000000000000000000000012046511414016545 5ustar rootrootcisco-auditing-tool-1.0/lists/.svn/tmp/text-base/0000755000000000000000000000000012046511414020441 5ustar rootrootcisco-auditing-tool-1.0/lists/.svn/tmp/props/0000755000000000000000000000000012046511414017710 5ustar rootrootcisco-auditing-tool-1.0/lists/.svn/tmp/prop-base/0000755000000000000000000000000012046511414020435 5ustar rootrootcisco-auditing-tool-1.0/lists/.svn/props/0000755000000000000000000000000012046511414017110 5ustar rootrootcisco-auditing-tool-1.0/lists/.svn/prop-base/0000755000000000000000000000000012046511414017635 5ustar rootrootcisco-auditing-tool-1.0/lists/passwords0000644000000000000000000000002212046511414017023 0ustar rootrootlist cisco1 cisco cisco-auditing-tool-1.0/lists/community0000644000000000000000000000002412046511414017024 0ustar rootrootlist public private