From 24dd478a46ec5b27634140704a340f744b81d245 Mon Sep 17 00:00:00 2001 From: slerena Date: Thu, 7 Oct 2010 15:09:04 +0000 Subject: [PATCH] 2010-10-07 Sancho Lerena * conf/pandora_server.conf: Removed multicast options * Makefile.PL: Removed need for dependencies on Mail::Sendmail and Traceroute::PurePerl, now are included in the Pandora FMS distribution. * lib/PandoraFMS/Config.pm: Removed options for multicast * lib/PandoraFMS/Traceroute.pm, lib/PandoraFMS/Sendmail.pm, lib/PandoraFMS/Traceroute/PurePerl.pm: Now included on Pandora FMS distribution, this will help to do easier installs of Pandora, because that packages was difficult to build/install in different distros. * lib/PandoraFMS/Core.pm: Removed the old multicast-on change enterprise feature, not used/supported anymore. * lib/PandoraFMS/ReconServer.pm: Now uses the internal Traceroute Pureperl implementation. * lib/PandoraFMS/Tools.pm: Now uses the internal Mail::Sendmail copy. * bin/pandora_server: Removed the multicast option from main loop. * FreeBSD/pandora_server.conf: Removed multicast from options. * util/mcast_client.pl: Deleted sample client for multicast. * util/pandora_logrotate: Updated the rotate options for SNMP logfile. * util/compaq_chassis_trap_manager2.pl: Added sample of SNMP Trap postprocessor. * pandora_server.redhat.spec, pandora_server.spec, DEBIAN/control: Updated packages deps and other minor changes (xprobe2 is not mandatory now). git-svn-id: https://svn.code.sf.net/p/pandora/code/trunk@3365 c3f86ba8-e40f-0410-aaad-9ba5e7f4b01f --- pandora_server/ChangeLog | 39 + pandora_server/DEBIAN/control | 4 +- pandora_server/FreeBSD/pandora_server.conf | 9 - pandora_server/Makefile.PL | 3 - pandora_server/bin/pandora_server | 12 +- pandora_server/conf/pandora_server.conf | 9 - pandora_server/lib/PandoraFMS/Config.pm | 21 - pandora_server/lib/PandoraFMS/Core.pm | 13 +- pandora_server/lib/PandoraFMS/ReconServer.pm | 4 +- pandora_server/lib/PandoraFMS/Sendmail.pm | 1032 +++++++++++++ pandora_server/lib/PandoraFMS/Tools.pm | 7 +- pandora_server/lib/PandoraFMS/Traceroute.pm | 1065 ++++++++++++++ .../lib/PandoraFMS/Traceroute/PurePerl.pm | 1295 +++++++++++++++++ pandora_server/pandora_server.redhat.spec | 4 +- pandora_server/pandora_server.spec | 4 +- pandora_server/pandora_server_installer | 16 +- .../util/compaq_chassis_trap_manager2.pl | 90 ++ pandora_server/util/mcast_client.pl | 25 - pandora_server/util/pandora_logrotate | 12 +- 19 files changed, 3560 insertions(+), 104 deletions(-) create mode 100644 pandora_server/lib/PandoraFMS/Sendmail.pm create mode 100644 pandora_server/lib/PandoraFMS/Traceroute.pm create mode 100644 pandora_server/lib/PandoraFMS/Traceroute/PurePerl.pm create mode 100755 pandora_server/util/compaq_chassis_trap_manager2.pl delete mode 100755 pandora_server/util/mcast_client.pl diff --git a/pandora_server/ChangeLog b/pandora_server/ChangeLog index 4c98321228..c1cc83b98c 100644 --- a/pandora_server/ChangeLog +++ b/pandora_server/ChangeLog @@ -1,3 +1,42 @@ +2010-10-07 Sancho Lerena + + * conf/pandora_server.conf: Removed multicast options + + * Makefile.PL: Removed need for dependencies on Mail::Sendmail + and Traceroute::PurePerl, now are included in the Pandora FMS + distribution. + + * lib/PandoraFMS/Config.pm: Removed options for multicast + + * lib/PandoraFMS/Traceroute.pm, + lib/PandoraFMS/Sendmail.pm, + lib/PandoraFMS/Traceroute/PurePerl.pm: Now included on Pandora FMS + distribution, this will help to do easier installs of Pandora, because + that packages was difficult to build/install in different distros. + + * lib/PandoraFMS/Core.pm: Removed the old multicast-on change enterprise + feature, not used/supported anymore. + + * lib/PandoraFMS/ReconServer.pm: Now uses the internal Traceroute Pureperl + implementation. + + * lib/PandoraFMS/Tools.pm: Now uses the internal Mail::Sendmail copy. + + * bin/pandora_server: Removed the multicast option from main loop. + + * FreeBSD/pandora_server.conf: Removed multicast from options. + + * util/mcast_client.pl: Deleted sample client for multicast. + + * util/pandora_logrotate: Updated the rotate options for SNMP logfile. + + * util/compaq_chassis_trap_manager2.pl: Added sample of SNMP Trap postprocessor. + + * pandora_server.redhat.spec, + pandora_server.spec, + DEBIAN/control: Updated packages deps and other minor changes (xprobe2 is not + mandatory now). + 2010-10-06 Ramon Novoa * lib/PandoraFMS/Core.pm: Retrieve agent information before the module diff --git a/pandora_server/DEBIAN/control b/pandora_server/DEBIAN/control index 6a542ff35d..b2ef8f3e89 100644 --- a/pandora_server/DEBIAN/control +++ b/pandora_server/DEBIAN/control @@ -1,10 +1,10 @@ package: PandoraFMS-Server -Version: 3.1 +Version: 3.2 Architecture: all Priority: optional Section: admin Installed-Size: 640 Maintainer: Miguel de Dios Homepage: http://pandorafms.org/ -Depends: perl (>= 5.8), libmail-sendmail-perl, libio-socket-multicast-perl, libdbi-perl, libdbd-mysql-perl,libtime-format-perl, libnetaddr-ip-perl, libtime-format-perl, libxml-simple-perl, libhtml-parser-perl, snmp, snmpd, traceroute, xprobe2, nmap, sudo +Depends: perl (>= 5.8), libdbi-perl, libdbd-mysql-perl, libtime-format-perl, libnetaddr-ip-perl, libtime-format-perl, libxml-simple-perl, libhtml-parser-perl, snmp, snmpd, traceroute, xprobe2, nmap, sudo Description: Pandora FMS is a monitoring system for big IT environments. It uses remote tests, or local agents to grab information. Pandora supports all standard OS (Linux, AIX, HP-UX, Solaris and Windows XP,2000/2003), and support multiple setups in HA enviroments. This is the server package. Server makes the remote checks and process information transfer by Pandora FMS agents to the server. diff --git a/pandora_server/FreeBSD/pandora_server.conf b/pandora_server/FreeBSD/pandora_server.conf index 1a00a9c17f..ac276df8dd 100644 --- a/pandora_server/FreeBSD/pandora_server.conf +++ b/pandora_server/FreeBSD/pandora_server.conf @@ -225,15 +225,6 @@ autocreate 1 max_log_size 65536 -# Send XML over Multicast channels async uptades on events and sync full tree -# info of tagged items (With custom ID) (only enterprise). - -# mcast_status_port 22222 -# mcast_status_group 224.1.1.1 - -# mcast_change_port 11111 -# mcast_change_group 224.1.1.1 - # max_queue_files (250 by default) # When server have more than max_queue_files in incoming directory, skips the read # the directory to avoid filesystem overhead. diff --git a/pandora_server/Makefile.PL b/pandora_server/Makefile.PL index 0b27ea502d..86ff15dae4 100644 --- a/pandora_server/Makefile.PL +++ b/pandora_server/Makefile.PL @@ -10,13 +10,10 @@ WriteMakefile( DBI => 0, threads::shared => 0, IO::Socket => 0, - Time::Format => 0, Time::Local => 0, XML::Simple => 0, Time::HiRes => 0, IO::Socket => 0, - Mail::Sendmail => 0, - Net::Traceroute::PurePerl => 0, HTML::Entities => 0, }, EXE_FILES => [ 'bin/pandora_server', 'bin/pandora_exec'], diff --git a/pandora_server/bin/pandora_server b/pandora_server/bin/pandora_server index 90750cd260..19ea0aa78a 100755 --- a/pandora_server/bin/pandora_server +++ b/pandora_server/bin/pandora_server @@ -233,8 +233,6 @@ while (1) { # Set the status of unknown modules pandora_module_unknown (\%Config, $DBH); - # Multicast status report each 30 x Server Threshold secs - enterprise_hook('mcast_status_report', [\%Config, $DBH]); } # TASKS DONE EACH 60 SECONDS (Low latency tasks) @@ -255,12 +253,12 @@ while (1) { pandora_group_statistics (\%Config, $DBH); pandora_server_statistics (\%Config, $DBH); } + } - # Pandora self monitoring - if (defined($Config{"self_monitoring"}) - && $Config{"self_monitoring"} == 1){ - pandora_self_monitoring (\%Config, $DBH); - } + # Pandora self monitoring + if (defined($Config{"self_monitoring"}) + && $Config{"self_monitoring"} == 1){ + pandora_self_monitoring (\%Config, $DBH); } } }; diff --git a/pandora_server/conf/pandora_server.conf b/pandora_server/conf/pandora_server.conf index c21f15e582..5ffa8566d5 100755 --- a/pandora_server/conf/pandora_server.conf +++ b/pandora_server/conf/pandora_server.conf @@ -221,15 +221,6 @@ autocreate 1 max_log_size 65536 -# Send XML over Multicast channels async uptades on events and sync full tree -# info of tagged items (With custom ID) (only enterprise). - -# mcast_status_port 22222 -# mcast_status_group 224.1.1.1 - -# mcast_change_port 11111 -# mcast_change_group 224.1.1.1 - # max_queue_files (250 by default) # When server have more than max_queue_files in incoming directory, skips the read # the directory to avoid filesystem overhead. diff --git a/pandora_server/lib/PandoraFMS/Config.pm b/pandora_server/lib/PandoraFMS/Config.pm index 40276c7dcc..8c9ad8aeba 100644 --- a/pandora_server/lib/PandoraFMS/Config.pm +++ b/pandora_server/lib/PandoraFMS/Config.pm @@ -258,15 +258,6 @@ sub pandora_load_config { # max log size (bytes) $pa_config->{'max_log_size'} = 32000; - # Multicast status report - $pa_config->{'mcast_status_group'} = ''; - $pa_config->{'mcast_status_port'} = ''; - - - # Multicast change report - $pa_config->{'mcast_change_group'} = ''; - $pa_config->{'mcast_change_port'} = ''; - # Ignore the timestamp in the XML and use the file timestamp instead $pa_config->{'use_xml_timestamp'} = 0; @@ -520,18 +511,6 @@ sub pandora_load_config { elsif ($parametro =~ m/^max_log_size\s([0-9]*)/i) { $pa_config->{'max_log_size'}= clean_blank($1); } - elsif ($parametro =~ m/^mcast_status_group\s([0-9\.]*)/i) { - $pa_config->{'mcast_status_group'}= clean_blank($1); - } - elsif ($parametro =~ m/^mcast_change_group\s([0-9\.]*)/i) { - $pa_config->{'mcast_change_group'}= clean_blank($1); - } - elsif ($parametro =~ m/^mcast_status_port\s([0-9]*)/i) { - $pa_config->{'mcast_status_port'}= clean_blank($1); - } - elsif ($parametro =~ m/^mcast_change_port\s([0-9]*)/i) { - $pa_config->{'mcast_change_port'}= clean_blank($1); - } elsif ($parametro =~ m/^wmi_threads\s([0-9]*)/i) { $pa_config->{'wmi_threads'}= clean_blank($1); } diff --git a/pandora_server/lib/PandoraFMS/Core.pm b/pandora_server/lib/PandoraFMS/Core.pm index 1798393b5f..cf8ed0a1d3 100644 --- a/pandora_server/lib/PandoraFMS/Core.pm +++ b/pandora_server/lib/PandoraFMS/Core.pm @@ -23,7 +23,7 @@ PandoraFMS::Core - Core functions of Pandora FMS =head1 VERSION -Version 3.1 +Version 3.2 =head1 SYNOPSIS @@ -1602,12 +1602,10 @@ sub generate_status_event ($$$$$$$) { if ($status == 0) { ($event_type, $severity) = ('going_down_normal', 2); $description .= "going to NORMAL"; - enterprise_hook('mcast_change_report', [$pa_config, $module->{'nombre'}, $module->{'custom_id'}, strftime ("%Y-%m-%d %H:%M:%S", localtime()), 'OK', $dbh]); # Critical } elsif ($status == 1) { ($event_type, $severity) = ('going_up_critical', 4); $description .= "going to CRITICAL"; - enterprise_hook('mcast_change_report', [$pa_config, $module->{'nombre'}, $module->{'custom_id'}, strftime ("%Y-%m-%d %H:%M:%S", localtime()), 'ERR', $dbh]); # Warning } elsif ($status == 2) { @@ -1624,7 +1622,6 @@ sub generate_status_event ($$$$$$$) { # Unknown last_status return; } - enterprise_hook('mcast_change_report', [$pa_config, $module->{'nombre'}, $module->{'custom_id'}, strftime ("%Y-%m-%d %H:%M:%S", localtime()), 'WARN', $dbh]); } else { # Unknown status logger($pa_config, "Unknown status $status for module '" . $module->{'nombre'} . "' agent '" . $agent->{'nombre'} . "'.", 10); @@ -2006,8 +2003,16 @@ sub pandora_self_monitoring ($$) { my $agents_unknown = get_db_value ($dbh, "SELECT * FROM tagente_estado, tagente WHERE tagente.disabled =0 AND tagente.id_agente = tagente_estado.id_agente AND running_by = $my_data_server AND utimestamp < NOW() - (current_interval * 2) limit 10;"); + if (!defined($agents_unknown)){ + $agents_unknown = 0; + } + my $queued_modules = get_db_value ($dbh, "SELECT SUM(queued_modules) FROM tserver WHERE name = '".$pa_config->{"servername"}."'"); + if (!defined($queued_modules)){ + $queued_modules = 0; + } + my $dbmaintance = get_db_value ($dbh, "SELECT COUNT(*) FROM tconfig WHERE token = 'db_maintance' AND `value` > UNIX_TIMESTAMP() - 86400"); $xml_output .=" "; diff --git a/pandora_server/lib/PandoraFMS/ReconServer.pm b/pandora_server/lib/PandoraFMS/ReconServer.pm index 6242972626..c41206618e 100644 --- a/pandora_server/lib/PandoraFMS/ReconServer.pm +++ b/pandora_server/lib/PandoraFMS/ReconServer.pm @@ -45,7 +45,7 @@ my @TaskQueue :shared; my %PendingTasks :shared; my $Sem :shared = Thread::Semaphore->new; my $TaskSem :shared = Thread::Semaphore->new (0); -my $TracerouteAvailable = (eval 'use Net::Traceroute::PurePerl; 1') ? 1 : 0; +my $TracerouteAvailable = (eval 'use PandoraFMS::Traceroute::PurePerl; 1') ? 1 : 0; ######################################################################################## # Recon Server class constructor. @@ -396,7 +396,7 @@ sub get_host_parent ($$){ my $traceroutetimeout = $pa_config->{'networktimeout'}; - my $tr = Net::Traceroute::PurePerl->new ( + my $tr = PandoraFMS::Traceroute::PurePerl->new ( backend => 'PurePerl', host => $host, debug => 0, diff --git a/pandora_server/lib/PandoraFMS/Sendmail.pm b/pandora_server/lib/PandoraFMS/Sendmail.pm new file mode 100644 index 0000000000..394add6d1f --- /dev/null +++ b/pandora_server/lib/PandoraFMS/Sendmail.pm @@ -0,0 +1,1032 @@ +package PandoraFMS::Sendmail; + +# Repackaged for work "by default" in PandoraFMS. +# Original library by: +# Mail::Sendmail by Milivoj Ivkovic +# see embedded POD documentation after __END__ +# or http://alma.ch/perl/mail.html + +=head1 NAME + +Mail::Sendmail v. 0.79_16 - Simple platform independent mailer + +=cut + +$VERSION = '0.79_16'; + +# *************** Configuration you may want to change ******************* +# You probably want to set your SMTP server here (unless you specify it in +# every script), and leave the rest as is. See pod documentation for details + +%mailcfg = ( + # List of SMTP servers: + 'smtp' => [ qw( localhost ) ], + #'smtp' => [ qw( mail.mydomain.com ) ], # example + + 'from' => '', # default sender e-mail, used when no From header in mail + + 'mime' => 1, # use MIME encoding by default + + 'retries' => 1, # number of retries on smtp connect failure + 'delay' => 1, # delay in seconds between retries + + 'tz' => '', # only to override automatic detection + 'port' => 25, # change it if you always use a non-standard port + 'debug' => 0 # prints stuff to STDERR +); + +# ******************************************************************* + +require Exporter; +use strict; +use vars qw( + $VERSION + @ISA + @EXPORT + @EXPORT_OK + %mailcfg + $address_rx + $debug + $log + $error + $retry_delay + $connect_retries + $auth_support + ); + +use Socket; +use Time::Local; # for automatic time zone detection +use Sys::Hostname; # for use of hostname in HELO + +#use Digest::HMAC_MD5 qw(hmac_md5 hmac_md5_hex); + +$auth_support = 'DIGEST-MD5 CRAM-MD5 PLAIN LOGIN'; + +# use MIME::QuotedPrint if available and configured in %mailcfg +eval("use MIME::QuotedPrint"); +$mailcfg{'mime'} &&= (!$@); + +@ISA = qw(Exporter); +@EXPORT = qw(&sendmail); +@EXPORT_OK = qw( + %mailcfg + time_to_date + $address_rx + $debug + $log + $error + ); + +# regex for e-mail addresses where full=$1, user=$2, domain=$3 +# see pod documentation about this regex + +my $word_rx = '[\x21\x23-\x27\x2A-\x2B\x2D\x2F\w\x3D\x3F]+'; +my $user_rx = $word_rx # valid chars + .'(?:\.' . $word_rx . ')*' # possibly more words preceded by a dot + ; +my $dom_rx = '\w[-\w]*(?:\.\w[-\w]*)*'; # less valid chars in domain names +my $ip_rx = '\[\d{1,3}(?:\.\d{1,3}){3}\]'; + +$address_rx = '((' . $user_rx . ')\@(' . $dom_rx . '|' . $ip_rx . '))'; +; # v. 0.61 + +sub _require_md5 { + eval { require Digest::MD5; Digest::MD5->import(qw(md5 md5_hex)); }; + $error .= $@ if $@; + return ($@ ? undef : 1); +} + +sub _require_base64 { + eval { + require MIME::Base64; MIME::Base64->import(qw(encode_base64 decode_base64)); + }; + $error .= $@ if $@; + return ($@ ? undef : 1); +} + +sub _hmac_md5 { + my ($pass, $ckey) = @_; + my $size = 64; + $pass = md5($pass) if length($pass) > $size; + my $ipad = $pass ^ (chr(0x36) x $size); + my $opad = $pass ^ (chr(0x5c) x $size); + return md5_hex($opad, md5($ipad, $ckey)); +} + +sub _digest_md5 { + my ($user, $pass, $challenge, $realm) = @_; + + my %ckey = map { /^([^=]+)="?(.+?)"?$/ } split(/,/, $challenge); + $realm ||= $ckey{realm}; #($user =~ s/\@(.+)$//o) ? $1 : $server; + my $nonce = $ckey{nonce}; + my $cnonce = &make_cnonce; + my $uri = join('/', 'smtp', hostname()||'localhost', $ckey{realm}); + my $qop = 'auth'; + my $nc = '00000001'; + my($hv, $a1, $a2); + $hv = md5("$user:$realm:$pass"); + $a1 = md5_hex("$hv:$nonce:$cnonce"); + $a2 = md5_hex("AUTHENTICATE:$uri"); + $hv = md5_hex("$a1:$nonce:$nc:$cnonce:$qop:$a2"); + return qq(username="$user",realm="$ckey{realm}",nonce="$nonce",nc=$nc,cnonce="$cnonce",digest-uri="$uri",response=$hv,qop=$qop); +} + +sub make_cnonce { + my $s = '' ; + for(1..16) { $s .= chr(rand 256) } + $s = encode_base64($s, ""); + $s =~ s/\W/X/go; + return substr($s, 0, 16); +} + +sub time_to_date { + # convert a time() value to a date-time string according to RFC 822 + + my $time = $_[0] || time(); # default to now if no argument + + my @months = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec); + my @wdays = qw(Sun Mon Tue Wed Thu Fri Sat); + + my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) + = localtime($time); + + my $TZ = $mailcfg{'tz'}; + if ( $TZ eq "" ) { + # offset in hours + my $offset = sprintf "%.1f", (timegm(localtime) - time) / 3600; + my $minutes = sprintf "%02d", abs( $offset - int($offset) ) * 60; + $TZ = sprintf("%+03d", int($offset)) . $minutes; + } + return join(" ", + ($wdays[$wday] . ','), + $mday, + $months[$mon], + $year+1900, + sprintf("%02d:%02d:%02d", $hour, $min, $sec), + $TZ + ); +} # end sub time_to_date + +sub sendmail { + + $error = ''; + $log = "Mail::Sendmail v. $VERSION - " . scalar(localtime()) . "\n"; + + my $CRLF = "\015\012"; + local $/ = $CRLF; + local $\ = ''; # to protect us from outside settings + local $_; + + my (%mail, $k, + $smtp, $server, $port, $connected, $localhost, + $fromaddr, $recip, @recipients, $to, $header, + %esmtp, @wanted_methods, + ); + use vars qw($server_reply); + # -------- a few internal subs ---------- + sub fail { + # things to do before returning a sendmail failure + $error .= join(" ", @_) . "\n"; + if ($server_reply) { + $error .= "Server said: $server_reply\n"; + print STDERR "Server said: $server_reply\n" if $^W; + } + close S; + return 0; + } + + sub socket_write { + my $i; + for $i (0..$#_) { + # accept references, so we don't copy potentially big data + my $data = ref($_[$i]) ? $_[$i] : \$_[$i]; + if ($mailcfg{'debug'} > 5) { + if (length($$data) < 500) { + print ">", $$data; + } + else { + print "> [...", length($$data), " bytes sent ...]\n"; + } + } + print(S $$data) || return 0; + } + 1; + } + + sub socket_read { + $server_reply = ""; + do { + $_ = ; + $server_reply .= $_; + #chomp $_; + print "<$_" if $mailcfg{'debug'} > 5; + if (/^[45]/ or !$_) { + chomp $server_reply; + return; # return false + } + } while (/^[\d]+-/); + chomp $server_reply; + return $server_reply; + } + # -------- end of internal subs ---------- + + # all config keys to lowercase, to prevent typo errors + foreach $k (keys %mailcfg) { + if ($k =~ /[A-Z]/) { + $mailcfg{lc($k)} = $mailcfg{$k}; + } + } + + # redo mail hash, arranging keys case etc... + while (@_) { + $k = shift @_; + if (!$k and $^W) { + warn "Received false mail hash key: \'$k\'. Did you forget to put it in quotes?\n"; + } + + # arrange keys case + $k = ucfirst lc($k); + + $k =~ s/\s*:\s*$//o; # kill colon (and possible spaces) at end, we add it later. + # uppercase also after "-", so people don't complain that headers case is different + # than in Outlook. + $k =~ s/-(.)/"-" . uc($1)/ge; + $mail{$k} = shift @_; + if ($k !~ /^(Message|Body|Text)$/i) { + # normalize possible line endings in headers + $mail{$k} =~ s/\015\012?/\012/go; + $mail{$k} =~ s/\012/$CRLF/go; + } + } + + $smtp = $mail{'Smtp'} || $mail{'Server'}; + unshift @{$mailcfg{'smtp'}}, $smtp if ($smtp and $mailcfg{'smtp'}->[0] ne $smtp); + + # delete non-header keys, so we don't send them later as mail headers + # I like this syntax, but it doesn't seem to work with AS port 5.003_07: + # delete @mail{'Smtp', 'Server'}; + # so instead: + delete $mail{'Smtp'}; delete $mail{'Server'}; + + $mailcfg{'port'} = $mail{'Port'} || $mailcfg{'port'} || 25; + delete $mail{'Port'}; + + my $auth = $mail{'Auth'}; + delete $mail{'Auth'}; + + + { # don't warn for undefined values below + local $^W = 0; + $mail{'Message'} = join("", $mail{'Message'}, $mail{'Body'}, $mail{'Text'}); + } + + # delete @mail{'Body', 'Text'}; + delete $mail{'Body'}; delete $mail{'Text'}; + + # Extract 'From:' e-mail address to use as envelope sender + + $fromaddr = $mail{'Sender'} || $mail{'From'} || $mailcfg{'from'}; + #delete $mail{'Sender'}; + unless ($fromaddr =~ /$address_rx/) { + return fail("Bad or missing From address: \'$fromaddr\'"); + } + $fromaddr = $1; + + # add Date header if needed + $mail{Date} ||= time_to_date() ; + $log .= "Date: $mail{Date}\n"; + + # cleanup message, and encode if needed + $mail{'Message'} =~ s/\r\n/\n/go; # normalize line endings, step 1 of 2 (next step after MIME encoding) + + $mail{'Mime-Version'} ||= '1.0'; + $mail{'Content-Type'} ||= 'text/plain; charset="iso-8859-1"'; + + unless ( $mail{'Content-Transfer-Encoding'} + || $mail{'Content-Type'} =~ /multipart/io ) + { + if ($mailcfg{'mime'}) { + $mail{'Content-Transfer-Encoding'} = 'quoted-printable'; + $mail{'Message'} = encode_qp($mail{'Message'}); + } + else { + $mail{'Content-Transfer-Encoding'} = '8bit'; + if ($mail{'Message'} =~ /[\x80-\xFF]/o) { + $error .= "MIME::QuotedPrint not present!\nSending 8bit characters, hoping it will come across OK.\n"; + warn "MIME::QuotedPrint not present!\n", + "Sending 8bit characters without encoding, hoping it will come across OK.\n" + if $^W; + } + } + } + + $mail{'Message'} =~ s/^\./\.\./gom; # handle . as first character + $mail{'Message'} =~ s/\n/$CRLF/go; # normalize line endings, step 2. + + # Get recipients + { # don't warn for undefined values below + local $^W = 0; + $recip = join(", ", $mail{To}, $mail{Cc}, $mail{Bcc}); + } + + delete $mail{'Bcc'}; + + @recipients = (); + while ($recip =~ /$address_rx/go) { + push @recipients, $1; + } + unless (@recipients) { + return fail("No recipient!") + } + + # get local hostname for polite HELO + $localhost = hostname() || 'localhost'; + + foreach $server ( @{$mailcfg{'smtp'}} ) { + # open socket needs to be inside this foreach loop on Linux, + # otherwise all servers fail if 1st one fails !??! why? + unless ( socket S, AF_INET, SOCK_STREAM, scalar(getprotobyname 'tcp') ) { + return fail("socket failed ($!)") + } + + print "- trying $server\n" if $mailcfg{'debug'} > 1; + + $server =~ s/\s+//go; # remove spaces just in case of a typo + # extract port if server name like "mail.domain.com:2525" + $port = ($server =~ s/:(\d+)$//o) ? $1 : $mailcfg{'port'}; + $smtp = $server; # save $server for use outside foreach loop + + my $smtpaddr = inet_aton $server; + unless ($smtpaddr) { + $error .= "$server not found\n"; + next; # next server + } + + my $retried = 0; # reset retries for each server + while ( ( not $connected = connect S, pack_sockaddr_in($port, $smtpaddr) ) + and ( $retried < $mailcfg{'retries'} ) + ) { + $retried++; + $error .= "connect to $server failed ($!)\n"; + print "- connect to $server failed ($!)\n" if $mailcfg{'debug'} > 1; + print "retrying in $mailcfg{'delay'} seconds...\n" if $mailcfg{'debug'} > 1; + sleep $mailcfg{'delay'}; + } + + if ( $connected ) { + print "- connected to $server\n" if $mailcfg{'debug'} > 3; + last; + } + else { + $error .= "connect to $server failed\n"; + print "- connect to $server failed, next server...\n" if $mailcfg{'debug'} > 1; + next; # next server + } + } + + unless ( $connected ) { + return fail("connect to $smtp failed ($!) no (more) retries!") + }; + + { + local $^W = 0; # don't warn on undefined variables + # Add info to log variable + $log .= "Server: $smtp Port: $port\n" + . "From: $fromaddr\n" + . "Subject: $mail{Subject}\n" + ; + } + + my($oldfh) = select(S); $| = 1; select($oldfh); + + socket_read() + || return fail("Connection error from $smtp on port $port ($_)"); + socket_write("EHLO $localhost$CRLF") + || return fail("send EHLO error (lost connection?)"); + my $ehlo = socket_read(); + if ($ehlo) { + # parse EHLO response + map { + s/^\d+[- ]//; + my ($k, $v) = split /\s+/, $_, 2; + $esmtp{$k} = $v || 1 if $k; + } split(/\n/, $ehlo); + } + else { + # try plain HELO instead + socket_write("HELO $localhost$CRLF") + || return fail("send HELO error (lost connection?)"); + } + + if ($auth) { + warn "AUTH requested\n" if ($mailcfg{debug} > 4); + # reduce wanted methods to those supported + my @methods = grep {$esmtp{'AUTH'}=~/(^|\s)$_(\s|$)/i} + grep {$auth_support =~ /(^|\s)$_(\s|$)/i} + grep /\S/, split(/\s+/, $auth->{method}); + + if (@methods) { + # try to authenticate + + if (exists $auth->{pass}) { + $auth->{password} = $auth->{pass}; + } + + my $method = uc $methods[0]; + _require_base64() || fail("Could not use MIME::Base64 module required for authentication"); + if ($method eq "LOGIN") { + print STDERR "Trying AUTH LOGIN\n" if ($mailcfg{debug} > 9); + socket_write("AUTH LOGIN$CRLF") + || return fail("send AUTH LOGIN failed (lost connection?)"); + socket_read() + || return fail("AUTH LOGIN failed: $server_reply"); + socket_write(encode_base64($auth->{user},$CRLF)) + || return fail("send LOGIN username failed (lost connection?)"); + socket_read() + || return fail("LOGIN username failed: $server_reply"); + socket_write(encode_base64($auth->{password},$CRLF)) + || return fail("send LOGIN password failed (lost connection?)"); + socket_read() + || return fail("LOGIN password failed: $server_reply"); + } + elsif ($method eq "PLAIN") { + warn "Trying AUTH PLAIN\n" if ($mailcfg{debug} > 9); + socket_write( + "AUTH PLAIN " + . encode_base64(join("\0", $auth->{user}, $auth->{user}, $auth->{password}), $CRLF) + ) || return fail("send AUTH PLAIN failed (lost connection?)"); + socket_read() + || return fail("AUTH PLAIN failed: $server_reply"); + } + elsif ($method eq "CRAM-MD5") { + _require_md5() || fail("Could not use Digest::MD5 module required for authentication"); + warn "Trying AUTH CRAM-MD5\n" if ($mailcfg{debug} > 9); + socket_write("AUTH CRAM-MD5$CRLF") + || return fail("send CRAM-MD5 failed (lost connection?)"); + my $challenge = socket_read() + || return fail("AUTH CRAM-MD5 failed: $server_reply"); + $challenge =~ s/^\d+\s+//; + my $response = _hmac_md5($auth->{password}, decode_base64($challenge)); + socket_write(encode_base64("$auth->{user} $response", $CRLF)) + || return fail("AUTH CRAM-MD5 failed: $server_reply"); + socket_read() + || return fail("AUTH CRAM-MD5 failed: $server_reply"); + } + elsif ($method eq "DIGEST-MD5") { + _require_md5() || fail("Could not use Digest::MD5 module required for authentication"); + warn "Trying AUTH DIGEST-MD5\n" if ($mailcfg{debug} > 9); + socket_write("AUTH DIGEST-MD5$CRLF") + || return fail("send CRAM-MD5 failed (lost connection?)"); + my $challenge = socket_read() + || return fail("AUTH DIGEST-MD5 failed: $server_reply"); + $challenge =~ s/^\d+\s+//; $challenge =~ s/[\r\n]+$//; + warn "\nCHALLENGE=", decode_base64($challenge), "\n" if ($mailcfg{debug} > 10); + my $response = _digest_md5($auth->{user}, $auth->{password}, decode_base64($challenge), $auth->{realm}); + warn "\nRESPONSE=$response\n" if ($mailcfg{debug} > 10); + socket_write(encode_base64($response, ""), $CRLF) + || return fail("AUTH DIGEST-MD5 failed: $server_reply"); + my $status = socket_read() + || return fail("AUTH DIGEST-MD5 failed: $server_reply"); + if ($status =~ /^3/) { + socket_write($CRLF) + || return fail("AUTH DIGEST-MD5 failed: $server_reply"); + socket_read() + || return fail("AUTH DIGEST-MD5 failed: $server_reply"); + } + } + else { + return fail("$method not supported (and wrongly advertised as supported by this silly module)\n"); + } + $log .= "AUTH $method succeeded as user $auth->{user}\n"; + } + else { + $esmtp{'AUTH'} =~ s/(^\s+|\s+$)//g; # cleanup for printig it below + if ($auth->{required}) { + return fail("Required AUTH method '$auth->{method}' not supported. " + ."(Server supports '$esmtp{'AUTH'}'. Module supports: '$auth_support')"); + } + else { + warn "No common authentication method! Requested: '$auth->{method}'. Server supports '$esmtp{'AUTH'}'. Module supports: '$auth_support'. Skipping authentication\n"; + } + } + } + socket_write("MAIL FROM:<$fromaddr>$CRLF") + || return fail("send MAIL FROM: error"); + socket_read() + || return fail("MAIL FROM: error ($_)"); + + my $to_ok = 0; + foreach $to (@recipients) { + socket_write("RCPT TO:<$to>$CRLF") + || return fail("send RCPT TO: error"); + if (socket_read()) { + $log .= "To: $to\n"; + $to_ok++; + } else { + $log .= "FAILED To: $to ($server_reply)"; + $error .= "Bad recipient <$to>: $server_reply\n"; + } + } + unless ($to_ok) { + return fail("No valid recipient"); + } + + # start data part + + socket_write("DATA$CRLF") + || return fail("send DATA error"); + socket_read() + || return fail("DATA error ($_)"); + + # print headers + foreach $header (keys %mail) { + next if $header eq "Message"; + $mail{$header} =~ s/\s+$//o; # kill possible trailing garbage + socket_write("$header: $mail{$header}$CRLF") + || return fail("send $header: error"); + }; + + #- test diconnecting from network here, to see what happens + #- print STDERR "DISCONNECT NOW!\n"; + #- sleep 4; + #- print STDERR "trying to continue, expecting an error... \n"; + + # send message body (passed as a reference, in case it's big) + socket_write($CRLF, \$mail{'Message'}, "$CRLF.$CRLF") + || return fail("send message error"); + socket_read() + || return fail("message transmission error ($_)"); + $log .= "\nResult: $_"; + + # finish + socket_write("QUIT$CRLF") + || return fail("send QUIT error"); + socket_read(); + close S; + + return 1; +} # end sub sendmail + +1; +__END__ + +=head1 SYNOPSIS + + use Mail::Sendmail; + + %mail = ( To => 'you@there.com', + From => 'me@here.com', + Message => "This is a very short message" + ); + + sendmail(%mail) or die $Mail::Sendmail::error; + + print "OK. Log says:\n", $Mail::Sendmail::log; + +=head1 DESCRIPTION + +Simple platform independent e-mail from your perl script. Only requires +Perl 5 and a network connection. + +Mail::Sendmail takes a hash with the message to send and sends it to your +mail server. It is intended to be very easy to setup and +use. See also L<"FEATURES"> below, and as usual, read this documentation. + +There is also a FAQ (see L<"NOTES">). + +=head1 INSTALLATION + +=over 4 + +=item Best + +C + +=item Traditional + + perl Makefile.PL + make + make test + make install + +=item Manual + +Copy Sendmail.pm to Mail/ in your Perl lib directory. + + (eg. c:\Perl\site\lib\Mail\ + or /usr/lib/perl5/site_perl/Mail/ + or whatever it is on your system. + They are listed when you type C< perl -V >) + +=item ActivePerl's PPM + +Depending on your PPM version: + + ppm install --location=http://alma.ch/perl/ppm Mail-Sendmail + +or + + ppm install http://alma.ch/perl/ppm/Mail-Sendmail.ppd + +But this way you don't get a chance to have a look at other files (Changes, +Todo, test.pl, ...). + +=back + +At the top of Sendmail.pm, set your default SMTP server(s), unless you specify +it with each message, or want to use the default (localhost). + +Install MIME::QuotedPrint. This is not required but strongly recommended. + +=head1 FEATURES + +Automatic time zone detection, Date: header, MIME quoted-printable encoding +(if MIME::QuotedPrint installed), all of which can be overridden. + +Bcc: and Cc: support. + +Allows real names in From:, To: and Cc: fields + +Doesn't send an X-Mailer: header (unless you do), and allows you to send any +header(s) you want. + +Configurable retries and use of alternate servers if your mail server is +down + +Good plain text error reporting + +Experimental support for SMTP AUTHentication + +=head1 LIMITATIONS + +Headers are not encoded, even if they have accented characters. + +Since the whole message is in memory, it's not suitable for +sending very big attached files. + +The SMTP server has to be set manually in Sendmail.pm or in your script, +unless you have a mail server on localhost. + +Doesn't work on OpenVMS, I was told. Cannot test this myself. + +=head1 CONFIGURATION + +=over 4 + +=item Default SMTP server(s) + +This is probably all you want to configure. It is usually done through +I<$mailcfg{smtp}>, which you can edit at the top of the Sendmail.pm file. +This is a reference to a list of SMTP servers. You can also set it from +your script: + +C + +Alternatively, you can specify the server in the I<%mail> hash you send +from your script, which will do the same thing: + +C<$mail{smtp} = 'my.mail.server';> + +A future version will (hopefully) try to set useful defaults for you +during the Makefile.PL. + +=item Other configuration settings + +See I<%mailcfg> under L<"DETAILS"> below for other configuration options. + +=back + +=head1 DETAILS + +=head2 sendmail() + +sendmail is the only thing exported to your namespace by default + +C + +It takes a hash containing the full message, with keys for all headers +and the body, as well as for some specific options. + +It returns 1 on success or 0 on error, and rewrites +C<$Mail::Sendmail::error> and C<$Mail::Sendmail::log>. + +Keys are NOT case-sensitive. + +The colon after headers is not necessary. + +The Body part key can be called 'Body', 'Message' or 'Text'. + +The SMTP server key can be called 'Smtp' or 'Server'. If the connection to +this one fails, the other ones in C<$mailcfg{smtp}> will still be tried. + +The following headers are added unless you specify them yourself: + + Mime-Version: 1.0 + Content-Type: 'text/plain; charset="iso-8859-1"' + + Content-Transfer-Encoding: quoted-printable + or (if MIME::QuotedPrint not installed) + Content-Transfer-Encoding: 8bit + + Date: [string returned by time_to_date()] + +If you wish to use an envelope sender address different than the +From: address, set C<$mail{Sender}> in your %mail hash. + + + +The following are not exported by default, but you can still access them +with their full name, or request their export on the use line like in: +C + +=head3 embedding options in your %mail hash + +The following options can be set in your %mail hash. The corresponding keys +will be removed before sending the mail. + +=over 4 + +=item $mail{smtp} or $mail{server} + +The SMTP server to try first. It will be added + +=item $mail{port} + +This option will be removed. To use a non-standard port, set it in your server name: + +$mail{server}='my.smtp.server:2525' will try to connect to port 2525 on server my.smtp.server + +=item $mail{auth} + +This must be a reference to a hash containg all your authentication options: + +$mail{auth} = \%options; +or +$mail{auth} = {user=>"username", password=>"password", method=>"DIGEST-MD5", required=>0 }; + +=over + +=item user + +username + +=item pass or password + +password + +=item method + +optional method. compared (stripped down) to available methods. If empty, will try all available. + +=item required + +optional. defaults to false. If set to true, no delivery will be attempted if +authentication fails. If false or undefined, and authentication fails or is not available, sending is tried without. + +(different auth for different servers?) + +=back + +=back + +=head2 Mail::Sendmail::time_to_date() + +convert time ( as from C ) to an RFC 822 compliant string for the +Date header. See also L<"%Mail::Sendmail::mailcfg">. + +=head2 $Mail::Sendmail::error + +When you don't run with the B<-w> flag, the module sends no errors to +STDERR, but puts anything it has to complain about in here. You should +probably always check if it says something. + +=head2 $Mail::Sendmail::log + +A summary that you could write to a log file after each send + +=head2 $Mail::Sendmail::address_rx + +A handy regex to recognize e-mail addresses. + +A correct regex for valid e-mail addresses was written by one of the judges +in the obfuscated Perl contest... :-) It is quite big. This one is an +attempt to a reasonable compromise, and should accept all real-world +internet style addresses. The domain part is required and comments or +characters that would need to be quoted are not supported. + + Example: + $rx = $Mail::Sendmail::address_rx; + if (/$rx/) { + $address=$1; + $user=$2; + $domain=$3; + } + +=head2 %Mail::Sendmail::mailcfg + +This hash contains installation-wide configuration options. You normally edit it once (if +ever) in Sendmail.pm and forget about it, but you could also access it from +your scripts. For readability, I'll assume you have imported it +(with something like C). + +The keys are not case-sensitive: they are all converted to lowercase before +use. Writing C<$mailcfg{Port} = 2525;> is OK: the default $mailcfg{port} +(25) will be deleted and replaced with your new value of 2525. + +=over 4 + +=item $mailcfg{smtp} + +C<$mailcfg{smtp} = [qw(localhost my.other.mail.server)];> + +This is a reference to a list of smtp servers, so if your main server is +down, the module tries the next one. If one of your servers uses a special +port, add it to the server name with a colon in front, to override the +default port (like in my.special.server:2525). + +Default: localhost. + +=item $mailcfg{from} + +C<$mailcfg{from} = 'Mailing script me@mydomain.com';> + +From address used if you don't supply one in your script. Should not be of +type 'user@localhost' since that may not be valid on the recipient's +host. + +Default: undefined. + +=item $mailcfg{mime} + +C<$mailcfg{mime} = 1;> + +Set this to 0 if you don't want any automatic MIME encoding. You normally +don't need this, the module should 'Do the right thing' anyway. + +Default: 1; + +=item $mailcfg{retries} + +C<$mailcfg{retries} = 1;> + +How many times should the connection to the same SMTP server be retried in +case of a failure. + +Default: 1; + +=item $mailcfg{delay} + +C<$mailcfg{delay} = 1;> + +Number of seconds to wait between retries. This delay also happens before +trying the next server in the list, if the retries for the current server +have been exhausted. For CGI scripts, you want few retries and short delays +to return with a results page before the http connection times out. For +unattended scripts, you may want to use many retries and long delays to +have a good chance of your mail being sent even with temporary failures on +your network. + +Default: 1 (second); + +=item $mailcfg{tz} + +C<$mailcfg{tz} = '+0800';> + +Normally, your time zone is set automatically, from the difference between +C and C. This allows you to override automatic detection +in cases where your system is confused (such as some Win32 systems in zones +which do not use daylight savings time: see Microsoft KB article Q148681) + +Default: undefined (automatic detection at run-time). + +=item $mailcfg{port} + +C<$mailcfg{port} = 25;> + +Port used when none is specified in the server name. + +Default: 25. + +=item $mailcfg{debug} + +C<$mailcfg{debug} = 0;> + +Prints stuff to STDERR. Current maximum is 6, which prints the whole SMTP +session, except data exceeding 500 bytes. + +Default: 0; + +=back + +=head2 $Mail::Sendmail::VERSION + +The package version number (you can not import this one) + +=head2 Configuration variables from previous versions + +The following global variables were used in version 0.74 for configuration. +As from version 0.78_1, they are not supported anymore. +Use the I<%mailcfg> hash if you need to access the configuration +from your scripts. + +=over 4 + +=item $Mail::Sendmail::default_smtp_server + +=item $Mail::Sendmail::default_smtp_port + +=item $Mail::Sendmail::default_sender + +=item $Mail::Sendmail::TZ + +=item $Mail::Sendmail::connect_retries + +=item $Mail::Sendmail::retry_delay + +=item $Mail::Sendmail::use_MIME + +=back + +=head1 ANOTHER EXAMPLE + + use Mail::Sendmail; + + print "Testing Mail::Sendmail version $Mail::Sendmail::VERSION\n"; + print "Default server: $Mail::Sendmail::mailcfg{smtp}->[0]\n"; + print "Default sender: $Mail::Sendmail::mailcfg{from}\n"; + + %mail = ( + #To => 'No to field this time, only Bcc and Cc', + #From => 'not needed, use default', + Bcc => 'Someone , Someone else her@there.com', + # only addresses are extracted from Bcc, real names disregarded + Cc => 'Yet someone else ', + # Cc will appear in the header. (Bcc will not) + Subject => 'Test message', + 'X-Mailer' => "Mail::Sendmail version $Mail::Sendmail::VERSION", + ); + + + $mail{Smtp} = 'special_server.for-this-message-only.domain.com'; + $mail{'X-custom'} = 'My custom additionnal header'; + $mail{'mESSaGE : '} = "The message key looks terrible, but works."; + # cheat on the date: + $mail{Date} = Mail::Sendmail::time_to_date( time() - 86400 ); + + if (sendmail %mail) { print "Mail sent OK.\n" } + else { print "Error sending mail: $Mail::Sendmail::error \n" } + + print "\n\$Mail::Sendmail::log says:\n", $Mail::Sendmail::log; + +Also see http://alma.ch/perl/Mail-Sendmail-FAQ.html for examples +of HTML mail and sending attachments. + +=head1 CHANGES + +Main changes since version 0.79: + +Experimental SMTP AUTH support (LOGIN PLAIN CRAM-MD5 DIGEST-MD5) + +Fix bug where one refused RCPT TO: would abort everything + +send EHLO, and parse response + +Better handling of multi-line responses, and better error-messages + +Non-conforming line-endings also normalized in headers + +Now keeps the Sender header if it was used. Previous versions +only used it for the MAIL FROM: command and deleted it. + +See the F file for the full history. If you don't have it +because you installed through PPM, you can also find the latest +one on F. + +=head1 AUTHOR + +Milivoj Ivkovic ("\x40" is "@" of course) + +=head1 NOTES + +MIME::QuotedPrint is used by default on every message if available. It +allows reliable sending of accented characters, and also takes care of +too long lines (which can happen in HTML mails). It is available in the +MIME-Base64 package at http://www.perl.com/CPAN/modules/by-module/MIME/ or +through PPM. + +Look at http://alma.ch/perl/Mail-Sendmail-FAQ.html for additional +info (CGI, examples of sending attachments, HTML mail etc...) + +You can use this module freely. (Someone complained this is too vague. +So, more precisely: do whatever you want with it, but be warned that +terrible things will happen to you if you use it badly, like for sending +spam, or ...?) + +Thanks to the many users who sent me feedback, bug reports, suggestions, etc. +And please excuse me if I forgot to answer your mail. I am not always reliabe +in answering mail. I intend to set up a mailing list soon. + +Last revision: 06.02.2003. Latest version should be available on +CPAN: F. + +=cut diff --git a/pandora_server/lib/PandoraFMS/Tools.pm b/pandora_server/lib/PandoraFMS/Tools.pm index 78bf5e39d7..fae0586a61 100644 --- a/pandora_server/lib/PandoraFMS/Tools.pm +++ b/pandora_server/lib/PandoraFMS/Tools.pm @@ -21,7 +21,7 @@ use warnings; use Time::Local; use POSIX qw(setsid strftime); use POSIX; -use Mail::Sendmail; # New in 2.0. Used to sendmail internally, without external scripts +use PandoraFMS::Sendmail; # New in 2.0. Used to sendmail internally, without external scripts #use Module::Loaded; # Used to calculate the MD5 checksum of a string @@ -334,11 +334,6 @@ sub enterprise_load ($) { my $pa_config = shift; # Check dependencies - eval 'local $SIG{__DIE__}; require IO::Socket::Multicast'; - if ($@) { - print_message ($pa_config, " [*] Error loading Pandora FMS Enterprise: IO::Socket::Multicast not found.", 1); - return 0; - } # Already loaded #return 1 if (is_loaded ('PandoraFMS::Enterprise')); diff --git a/pandora_server/lib/PandoraFMS/Traceroute.pm b/pandora_server/lib/PandoraFMS/Traceroute.pm new file mode 100644 index 0000000000..01a27422ad --- /dev/null +++ b/pandora_server/lib/PandoraFMS/Traceroute.pm @@ -0,0 +1,1065 @@ +# Traceroute.pm library +# Repackaged by Pandora FMS +# +### +# Copyright 1998, 1999 Massachusetts Institute of Technology +# Copyright 2000-2005 Daniel Hagerty +# +# Permission to use, copy, modify, distribute, and sell this software and its +# documentation for any purpose is hereby granted without fee, provided that +# the above copyright notice appear in all copies and that both that +# copyright notice and this permission notice appear in supporting +# documentation, and that the name of M.I.T. not be used in advertising or +# publicity pertaining to distribution of the software without specific, +# written prior permission. M.I.T. makes no representations about the +# suitability of this software for any purpose. It is provided "as is" +# without express or implied warranty. + +### +# File: traceroute.pm +# Author: Daniel Hagerty, hag@ai.mit.edu +# Date: Tue Mar 17 13:44:00 1998 +# Description: Perl traceroute module for performing traceroute(1) +# functionality. +# +# $Id: Traceroute.pm,v 1.25 2007/01/10 02:30:13 hag Exp $ + +# Currently attempts to parse the output of the system traceroute command, +# which it expects will behave like the standard LBL traceroute program. +# If it doesn't, (Windows, HPUX come to mind) you lose. +# + +# Could eventually be broken into several classes that know how to +# deal with various traceroutes; could attempt to auto-recognize the +# particular traceroute and parse it. +# +# Has a couple of random useful hooks for child classes to override. + +package PandoraFMS::Traceroute; + +use strict; +no strict qw(subs); + +#require 5.xxx; # We'll probably need this + +use vars qw(@EXPORT $VERSION @ISA); + +use Exporter; +use IO::Pipe; +use IO::Select; +use Socket; +use Symbol qw(qualify_to_ref); +use Time::HiRes qw(time); +use Errno qw(EAGAIN EINTR); +use Data::Dumper; # Debugging + +$VERSION = "1.10"; # Version number is only incremented by + # hand. + +@ISA = qw(Exporter); + +@EXPORT = qw( + TRACEROUTE_OK + TRACEROUTE_TIMEOUT + TRACEROUTE_UNKNOWN + TRACEROUTE_BSDBUG + TRACEROUTE_UNREACH_NET + TRACEROUTE_UNREACH_HOST + TRACEROUTE_UNREACH_PROTO + TRACEROUTE_UNREACH_NEEDFRAG + TRACEROUTE_UNREACH_SRCFAIL + TRACEROUTE_UNREACH_FILTER_PROHIB + TRACEROUTE_UNREACH_ADDR + ); + +### + +## Exported functions. + +# Perl's facist mode gets very grumbly if a few things aren't declared +# first. + +sub TRACEROUTE_OK { 0 } +sub TRACEROUTE_TIMEOUT { 1 } +sub TRACEROUTE_UNKNOWN { 2 } +sub TRACEROUTE_BSDBUG { 3 } +sub TRACEROUTE_UNREACH_NET { 4 } +sub TRACEROUTE_UNREACH_HOST { 5 } +sub TRACEROUTE_UNREACH_PROTO { 6 } +sub TRACEROUTE_UNREACH_NEEDFRAG { 7 } +sub TRACEROUTE_UNREACH_SRCFAIL { 8 } +sub TRACEROUTE_UNREACH_FILTER_PROHIB { 9 } +sub TRACEROUTE_UNREACH_ADDR { 10 } + +## Internal data used throughout the module + +# Instance variables that are nothing special, and have an obvious +# corresponding accessor/mutator method. +my @public_instance_vars = + qw( + base_port + debug + host + max_ttl + packetlen + queries + query_timeout + source_address + trace_program + timeout + no_fragment + use_icmp + ); + +my @simple_instance_vars = ( + qw( + pathmtu + stat + ), + @public_instance_vars, + ); + +# Field offsets for query info array +use constant query_stat_offset => 0; +use constant query_host_offset => 1; +use constant query_time_offset => 2; + +### +# Public methods + +# Constructor + +sub new ($;%) { + my $self = shift; + my $type = ref($self) || $self; + + my %arg = @_; + + # We implement a goofy UI so that all programmers can use + # Net::Traceroute as a constructor for all types of object. + if(exists($arg{backend})) { + my $backend = $arg{backend}; + if($backend ne "Parser") { + my $module = "Net::Traceroute::$backend"; + eval "require $module"; + + # Ignore error on the possibility that they just defined + # the module at runtime, rather than an actual module in + # the filesystem. + my $newref = qualify_to_ref("new", $module); + my $newcode = *{$newref}{CODE}; + if(!defined($newcode)) { + die "Backend implementation $backend has no new"; + } + return(&{$newcode}($module, @_)); + } + } + + if(!ref($self)) { + $self = bless {}, $type; + } + + $self->init(%arg); + $self; +} + +sub init { + my $self = shift; + my %arg = @_; + + # Take our constructer arguments and initialize the attributes with + # them. + my $var; + foreach $var (@public_instance_vars) { + if(defined($arg{$var})) { + $self->$var($arg{$var}); + } + } + + # Initialize debug if it isn't already. + $self->debug(0) if(!defined($self->debug)); + $self->trace_program("traceroute") if(!defined($self->trace_program)); + + $self->debug_print(1, "Running in debug mode\n"); + + # Initialize status + $self->stat(TRACEROUTE_UNKNOWN); + + if(defined($self->host)) { + $self->traceroute; + } + + $self->debug_print(9, Dumper($self)); +} + +sub clone ($;%) { + my $self = shift; + my $type = ref($self); + + my %arg = @_; + + die "Can't clone a non-object!" unless($type); + + my $clone = bless {}, $type; + + # Does a shallow copy of the hash key/values to the new hash. + if(ref($self)) { + my($key, $val); + while(($key, $val) = each %{$self}) { + $clone->{$key} = $val; + } + } + + # Take our constructer arguments and initialize the attributes with + # them. + my $var; + foreach $var (@public_instance_vars) { + if(defined($arg{$var})) { + $clone->$var($arg{$var}); + } + } + + # Initialize status + $clone->stat(TRACEROUTE_UNKNOWN); + + if(defined($clone->host)) { + $clone->traceroute; + } + + $clone->debug_print(9, Dumper($clone)); + + return($clone); +} + +## +# Methods + +# Do the actual work. Not really a published interface; completely +# useable from the constructor. +sub traceroute ($) { + my $self = shift; + my $host = $self->host(); + + $self->debug_print(1, "Performing traceroute\n"); + + die "No host provided!" unless $host; + + # Sit in a select loop on the incoming text from traceroute, + # waiting for a timeout if we need to. Accumulate the text for + # parsing later in one fell swoop. + + # Note time. Time::HiRes will give us floating point. + my $start_time; + my $end_time; + my $total_wait = $self->timeout(); + my @this_wait; + if(defined($total_wait)) { + $start_time = time(); + push(@this_wait, $total_wait); + $end_time = $start_time + $total_wait; + } + + my $tr_pipe = $self->_make_pipe(); + my $select = new IO::Select($tr_pipe); + + $self->_zero_text_accumulator(); + $self->_zero_hops(); + + my @ready; + out: + while( @ready = $select->can_read(@this_wait)) { + my $fh; + foreach $fh (@ready) { + my $buf; + my $len = $fh->sysread($buf, 2048); + + # XXX Linux is fond of returning EAGAIN, which we'll need + # to check for here. Still true for sysread? + if(!defined($len)) { + my $errno = int($!); + next out if(($errno == EAGAIN) || ($errno == EINTR)); + die "read error: $!"; + } + last out if(!$len); # EOF + + $self->_text_accumulator($self->_text_accumulator() . $buf); + } + + # Adjust select timer if we need to. + if(defined($total_wait)) { + my $now = time(); + last out if($now >= $end_time); + $this_wait[0] = $end_time - $now; + } + } + if(defined($total_wait)) { + my $now = time(); + $self->stat(TRACEROUTE_TIMEOUT) if($now >= $end_time); + } + + $tr_pipe->close(); + + my $accum = $self->_text_accumulator(); + die "No output from traceroute. Exec failure?" if($accum eq ""); + + # Do the grunt parsing work + $self->_parse($accum); + + # XXX are you really sure you want to do it like this?? + if($self->stat() != TRACEROUTE_TIMEOUT) { + $self->stat(TRACEROUTE_OK); + } + + $self; +} + +## +# Hop and query functions + +sub hops ($) { + my $self = shift; + + my $hop_ary = $self->{"hops"}; + + return() unless $hop_ary; + + return(int(@{$hop_ary})); +} + +sub hop_queries ($$) { + my $self = shift; + my $hop = (shift) - 1; + + $self->{"hops"} && $self->{"hops"}->[$hop] && + int(@{$self->{"hops"}->[$hop]}); +} + +sub found ($) { + my $self = shift; + my $hops = $self->hops(); + + if($hops) { + my $last_hop = $self->hop_query_host($hops, 0); + my $stat = $self->hop_query_stat($hops, 0); + + # Is this the correct thing to be doing? This gap in + # semantics missed me, and wasn't caught until post 1.5 It + # would be a good to audit the semantics here. It's possible + # that a prior version change broke this. + + # Getting good regression tests would be nice, but traceroute + # is an annoying thing to do regression on -- you usually + # don't have enough control over the network. If I was good, + # I would be collecting my bug reports, and saving the + # traceroute output produced there. + return(undef) if(!defined($last_hop)); + + # Ugh, what to do here? + # In IPv4, a host may send the port-unreachable ICMP from an + # address other than the one we sent to. (and in fact, I use + # this feature quite a bit to map out networks) + # IIRC, IPv6 mandates that the unreachable comes from the address we + # sent to, so we don't have this problem. + + # This assumption will that any last hop answer that wasn't an + # error may bite us. + if( + (($stat == TRACEROUTE_OK) || ($stat == TRACEROUTE_BSDBUG) || + ($stat == TRACEROUTE_UNREACH_PROTO))) { + return(1); + } + } + return(undef); +} + +sub hop_query_stat ($$) { + _query_accessor_common(@_,query_stat_offset); +} + +sub hop_query_host ($$) { + _query_accessor_common(@_,query_host_offset); +} + +sub hop_query_time ($$) { + _query_accessor_common(@_,query_time_offset); +} + +## +# Accesssor/mutators for ordinary instance variables. (Read/Write) +# We generate these. + +foreach my $name (@simple_instance_vars) { + my $sym = qualify_to_ref($name); + my $code = sub { + my $self = shift; + my $old = $self->{$name}; + $self->{$name} = $_[0] if @_; + return $old; + }; + *{$sym} = $code; +} + +### +# Various internal methods + +# Many of these would be useful to override in a derived class. + +# Build and return the pipe that talks to our child traceroute. +sub _make_pipe ($) { + my $self = shift; + + my @tr_args; + + push(@tr_args, $self->trace_program()); + push(@tr_args, $self->_tr_cmd_args()); + push(@tr_args, $self->host()); + my @plen = ($self->packetlen) || (); # Sigh. + push(@tr_args, @plen); + + # XXX we probably shouldn't throw stderr away. + # XXX we probably shouldn't use named filehandles. + open(SAVESTDERR, ">&STDERR"); + open(STDERR, ">/dev/null"); + + my $pipe = new IO::Pipe; + + # IO::Pipe is very unhelpful about error catching. It calls die + # in the child program, but returns a reasonable looking object in + # the parent. This is really a standard unix fork/exec issue, but + # the library doesn't help us. + my $result = $pipe->reader(@tr_args); + + open(STDERR, ">& SAVESTDERR"); + close(SAVESTDERR); + + # Long standing bug; the pipe needs to be marked non blocking. + $result->blocking(0); + + $result; +} + +# Map some instance variables to command line arguments that take +# arguments. +my %cmdline_valuemap = + ( "base_port" => "-p", + "max_ttl" => "-m", + "queries" => "-q", + "query_timeout" => "-w", + "source_address" => "-s", + ); + +# Map more instance variables to command line arguments that are +# flags. +my %cmdline_flagmap = + ( "no_fragment" => "-F", + "use_icmp" => "-I", + ); + +# Build a list of command line arguments +sub _tr_cmd_args ($) { + my $self = shift; + + my @result; + + push(@result, "-n"); + + my($key, $flag); + + while(($key, $flag) = each %cmdline_flagmap) { + push(@result, $flag) if($self->$key());; + } + + while(($key, $flag) = each %cmdline_valuemap) { + my $val = $self->$key(); + if(defined $val) { + push(@result, $flag, $val); + } + } + + @result; +} + +# Map ! notation traceroute uses for various icmp packet types +# it may receive. +my %icmp_map = (N => TRACEROUTE_UNREACH_NET, + H => TRACEROUTE_UNREACH_HOST, + P => TRACEROUTE_UNREACH_PROTO, + F => TRACEROUTE_UNREACH_NEEDFRAG, + S => TRACEROUTE_UNREACH_SRCFAIL, + A => TRACEROUTE_UNREACH_ADDR, + X => TRACEROUTE_UNREACH_FILTER_PROHIB); + +# Do the grunt work of parsing the output. +sub _parse ($$) { + my $self = shift; + my $tr_output = shift; + + # This is a crufty hand coded parser that does its job well + # enough. The approach of regular expressions without state is + # far from perfect, but it gets the job done. + line: + foreach $_ (split(/\n/, $tr_output)) { + + # Some traceroutes appear to print informational line to stdout, + # and we don't care. + /^traceroute to / && next; + + # AIX 5L has to be different. + /^trying to get / && next; + /^source should be / && next; + + # NetBSD's traceroute emits info about path MTU discovery if + # you want, don't know who else does this. + /^message too big, trying new MTU = (\d+)/ && do { + $self->pathmtu($1); + next; + }; + + # For now, discard MPLS label stack information emitted by + # some vendor's traceroutes. Once I'm sure I'm sure I + # understand the semantics offered by both the underlying MPLS + # and whatever crazy limits the MPLS patch has, I can think + # about an interface. My reading of the code is that you will + # get the label stack of the last query. If this isn't + # representative of all of the queries, it sucks to be you. + # You can still get what you need, but it would be nice if the + # tool didn't throw information away... + # possibilities. + /^\s+MPLS Label=(\d+) CoS=(\d) TTL=(\d+) S=(\d+)/ && next; + + # Each line starts with the hopno (space padded to two characters) + # and a space. + /^([0-9 ][0-9]) / || die "Unable to traceroute output: $_"; + my $hopno = $1 + 0; + + my $query = 1; + my $addr; + my $time; + + $_ = substr($_,length($&)); + + query: + while($_) { + # ip address of a response + /^ (\d+\.\d+\.\d+\.\d+)/ && do { + $addr = $1; + $_ = substr($_, length($&)); + next query; + }; + # ipv6 address of a response + /^ ([0-9a-fA-F:]+)/ && do { + $addr = $1; + $_ = substr($_, length($&)); + next query; + }; + # Redhat FC5 traceroute does this; it's redundant. + /^ \((\d+\.\d+\.\d+\.\d+)\)/ && do { + $_ = substr($_, length($&)); + next query; + }; + # round trip time of query + /^ ?([0-9.]+) ms/ && do { + $time = $1 + 0; + + $self->_add_hop_query($hopno, $query, + TRACEROUTE_OK, $addr, $time); + $query++; + $_ = substr($_, length($&)); + next query; + }; + # query timed out + /^ +\*/ && do { + $self->_add_hop_query($hopno, $query, + TRACEROUTE_TIMEOUT, + inet_ntoa(INADDR_NONE), 0); + $query++; + $_ = substr($_, length($&)); + next query; + }; + + # extra information from the probe (random ICMP info + # and such). + + # There was a bug in this regexp prior to 1.09; reorder + # the clauses and everything gets better. + + # Note that this is actually a very subtle DWIM on perl's + # part: in "pure" regular expression theory, order of + # expression doesn't matter; the resultant DFA has no + # order concept. Without perl DWIMing on our regexp, we'd + # write the regexp and code to perform a token lookahead: + # the transitions after ! would be < for digits, the keys + # of icmp map, and finally whitespace or end of string + # indicate a lone "!". + + /^ (!<\d+>|![NHPFSAX]?)/ && do { + my $flag = $1; + my $matchlen = length($&); + + # Flip the counter back one; this flag only appears + # optionally and by now we've already incremented the + # query counter. + my $query = $query - 1; + + if($flag =~ /^!<\d>$/) { + $self->_change_hop_query_stat($hopno, $query, + TRACEROUTE_UNKNOWN); + } elsif($flag =~ /^!$/) { + $self->_change_hop_query_stat($hopno, $query, + TRACEROUTE_BSDBUG); + } elsif($flag =~ /^!([NHPFSAX])$/) { + my $icmp = $1; + + # Shouldn't happen + die "Unable to traceroute output (flag $icmp)!" + unless(defined($icmp_map{$icmp})); + + $self->_change_hop_query_stat($hopno, $query, + $icmp_map{$icmp}); + } + $_ = substr($_, $matchlen); + next query; + }; + # Nothing left, next line. + /^$/ && do { + next line; + }; + # Some LBL derived traceroutes print ttl stuff + /^ \(ttl ?= ?\d+!\)/ && do { + $_ = substr($_, length($&)); + next query; + }; + + die "Unable to parse traceroute output: $_"; + } + } +} + +# I don't understand why this one won't work with the accessor generator. +sub _text_accumulator ($;$) { + my $self = shift; + my $name = "_text_accumulator"; + my $old = $self->{$name}; + $self->{$name} = $_[0] if @_; + return $old; +} + +sub _zero_text_accumulator ($) { + my $self = shift; + my $elem = "_text_accumulator"; + + $self->{$elem} = ""; +} + +# Hop stuff +sub _zero_hops ($) { + my $self = shift; + + delete $self->{"hops"}; +} + +sub _add_hop_query ($$$$$$) { + my $self = shift; + + my $hop = (shift) - 1; + my $query = (shift) - 1; + + my $stat = shift; + my $host = shift; + my $time = shift; + + $self->{"hops"}->[$hop]->[$query] = [ $stat, $host, $time ]; +} + +sub _change_hop_query_stat ($$$$) { + my $self = shift; + + # Zero base these + my $hop = (shift) - 1; + my $query = (shift) - 1; + + my $stat = shift; + + $self->{"hops"}->[$hop]->[$query]->[ query_stat_offset ] = $stat; +} + +sub _query_accessor_common ($$$) { + my $self = shift; + + # Zero base these + my $hop = (shift) - 1; + my $query = (shift) - 1; + + my $which_one = shift; + + # Deal with wildcard + if($query == -1) { + my $query_stat; + + my $aref; + query: + foreach $aref (@{$self->{"hops"}->[$hop]}) { + $query_stat = $aref->[query_stat_offset]; + $query_stat == TRACEROUTE_TIMEOUT && do { next query }; + $query_stat == TRACEROUTE_UNKNOWN && do { next query }; + do { return $aref->[$which_one] }; + } + return undef; + } else { + $self->{"hops"}->[$hop]->[$query]->[$which_one]; + } +} + +sub debug_print ($$$;@) { + my $self = shift; + my $level = shift; + my $fmtstring = shift; + + return unless $self->debug() >= $level; + + my($package, $filename, $line, $subroutine, + $hasargs, $wantarray, $evaltext, $is_require) = caller(0); + + my $caller_line = $line; + my $caller_name = $subroutine; + my $caller_file = $filename; + + my $string = sprintf($fmtstring, @_); + + my $caller = "${caller_file}:${caller_name}:${caller_line}"; + + print STDERR "$caller: $string"; +} + +1; + +__END__ + +=head1 NAME + +Net::Traceroute - traceroute(1) functionality in perl + +=head1 SYNOPSIS + + use Net::Traceroute; + $tr = Net::Traceroute->new(host=> "life.ai.mit.edu"); + if($tr->found) { + my $hops = $tr->hops; + if($hops > 1) { + print "Router was " . + $tr->hop_query_host($tr->hops - 1, 0) . "\n"; + } + } + +=head1 DESCRIPTION + +This module implements traceroute(1) functionality for perl5. It +allows you to trace the path IP packets take to a destination. It is +currently implemented as a parser around the system traceroute +command. + +=head1 OVERVIEW + +A new Net::Traceroute object must be created with the I method. +Depending on exactly how the constructor is invoked, it may perform +the traceroute immediately, or it may return a "template" object that +can be used to set parameters for several subsequent traceroutes. + +Methods are available for accessing information about a given +traceroute attempt. There are also methods that view/modify the +options that are passed to the object's constructor. + +To trace a route, UDP packets are sent with a small TTL (time-to-live) +field in an attempt to get intervening routers to generate ICMP +TIME_EXCEEDED messages. + +=head1 CONSTRUCTOR AND CLONING + + $obj = Net::Traceroute->new([base_port => $base_port,] + [debug => $debuglvl,] + [max_ttl => $max_ttl,] + [host => $host,] + [queries => $queries,] + [query_timeout => $query_timeout,] + [timeout => $timeout,] + [source_address => $srcaddr,] + [packetlen => $packetlen,] + [trace_program => $program,] + [no_fragment => $nofrag,] + [use_icmp => $useicmp,]); + $frob = $obj->clone([options]); + +This is the constructor for a new Net::Traceroute object. If given +C, it will actually perform the traceroute. You can call the +traceroute method later. + +Given an existing Net::Traceroute object $obj as a template, you can +call $obj->clone() with the usual constructor parameters. The same +rules apply about defining host; that is, traceroute will be run if it +is defined. You can always pass host => undef to clone. + +Possible options are: + +B - A host to traceroute to. If you don't set this, you get a +Traceroute object with no traceroute data in it. The module always +uses IP addresses internally and will attempt to lookup host names via +inet_aton. + +B - Base port number to use for the UDP queries. +Traceroute assumes that nothing is listening to port C to +C +where nhops is the number of hops required to reach the destination +address. Default is what the system traceroute uses (normally 33434). +C's C<-p> option. + +B - A number indicating how verbose debug information should +be. Please include debug=>9 output in bug reports. + +B - Maximum number of hops to try before giving up. Default +is what the system traceroute uses (normally 30). C's +C<-m> option. + +B - Number of times to send a query for a given hop. +Defaults to whatever the system traceroute uses (3 for most +traceroutes). C's C<-q> option. + +B - How many seconds to wait for a response to each +query sent. Uses the system traceroute's default value of 5 if +unspecified. C's C<-w> option. + +B - Maximum time, in seconds, to wait for the traceroute to +complete. If not specified, the traceroute will not return until the +host has been reached, or traceroute counts to infinity (C * +C * C). Note that this option is implemented +by Net::Traceroute, not the underlying traceroute command. + +B - Select the source address that traceroute wil use. + +B - Length of packets to use. Traceroute tries to make the +IP packet exactly this long. + +B - Name of the traceroute program. Defaults to traceroute. +You can pass traceroute6 to do IPv6 traceroutes. + +B - Set the IP don't fragment bit. Some traceroute +programs will perform path mtu discovery with this option. + +B - Request that traceroute perform probes with ICMP echo +packets, rather than UDP. + +=head1 METHODS + +=over 4 + +=item traceroute + +Run system traceroute, and parse the results. Will fill in the rest +of the object for informational queries. + +=back + +=head2 Controlling traceroute invocation + +Each of these methods return the current value of the option specified +by the corresponding constructor option. They will set the object's +instance variable to the given value if one is provided. + +Changing an instance variable will only affect newly performed +traceroutes. Setting a different value on a traceroute object that +has already performed a trace has no effect. + +See the constructor documentation for information about methods that +aren't documented here. + +=over 4 + +=item base_port([PORT]) + +=item max_ttl([PORT]) + +=item queries([QUERIES]) + +=item query_timeout([TIMEOUT]) + +=item host([HOST]) + +=item timeout([TIMEOUT]) + +=item source_address([SRC]) + +=item packetlen([LEN]) + +=item trace_program([PROGRAM]) + +=item no_fragment([PROGRAM]) + +=back + +=head2 Obtaining information about a Trace + +These methods return information about a traceroute that has already +been performed. + +Any of the methods in this section that return a count of something or +want an Ith type count to identify something employ one based +counting. + +=over 4 + +=item stat + +Returns the status of a given traceroute object. One of +TRACEROUTE_OK, TRACEROUTE_TIMEOUT, or TRACEROUTE_UNKNOWN (each defined +as an integer). TRACEROUTE_OK will only be returned if the host was +actually reachable. + +=item found + +Returns 1 if the host was found, undef otherwise. + +=item pathmtu + +If your traceroute supports MTU discovery, this method will return the +MTU in some circumstances. You must set no_fragment, and must use a +packetlen larger than the path mtu for this to be set. + +=item hops + +Returns the number of hops that it took to reach the host. + +=item hop_queries(HOP) + +Returns the number of queries that were sent for a given hop. This +should normally be the same for every query. + +=item hop_query_stat(HOP, QUERY) + +Return the status of the given HOP's QUERY. The return status can be +one of the following (each of these is actually an integer constant +function defined in Net::Traceroute's export list): + +QUERY can be zero, in which case the first succesful query will be +returned. + +=over 4 + +=item TRACEROUTE_OK + +Reached the host, no problems. + +=item TRACEROUTE_TIMEOUT + +This query timed out. + +=item TRACEROUTE_UNKNOWN + +Your guess is as good as mine. Shouldn't happen too often. + +=item TRACEROUTE_UNREACH_NET + +This hop returned an ICMP Network Unreachable. + +=item TRACEROUTE_UNREACH_HOST + +This hop returned an ICMP Host Unreachable. + +=item TRACEROUTE_UNREACH_PROTO + +This hop returned an ICMP Protocol unreachable. + +=item TRACEROUTE_UNREACH_NEEDFRAG + +Indicates that you can't reach this host without fragmenting your +packet further. Shouldn't happen in regular use. + +=item TRACEROUTE_UNREACH_SRCFAIL + +A source routed packet was rejected for some reason. Shouldn't happen. + +=item TRACEROUTE_UNREACH_FILTER_PROHIB + +A firewall or similar device has decreed that your traffic is +disallowed by administrative action. Suspect sheer, raving paranoia. + +=item TRACEROUTE_BSDBUG + +The destination machine appears to exhibit the 4.[23]BSD time exceeded +bug. + +=back + +=item hop_query_host(HOP, QUERY) + +Return the dotted quad IP address of the host that responded to HOP's +QUERY. + +QUERY can be zero, in which case the first succesful query will be +returned. + +=item hop_query_time(HOP, QUERY) + +Return the round trip time associated with the given HOP's query. If +your system's traceroute supports fractional second timing, so +will Net::Traceroute. + +QUERY can be zero, in which case the first succesful query will be +returned. + +=back + +=head1 CLONING SUPPORT BEFORE 1.04 + +Net::Traceroute Versions before 1.04 used new to clone objects. This +has been deprecated in favor of the clone() method. + +If you have code of the form: + + my $template = Net::Traceroute->new(); + my $tr = $template->new(host => "localhost"); + +You need to change the $template->new to $template->clone. + +This behavior was changed because it interfered with subclassing. + +=head1 BUGS + +Net::Traceroute parses the output of the system traceroute command. +As such, it may not work on your system. Support for more traceroute +outputs (e.g. Windows, HPUX) could be done, although currently the +code assumes there is "One true traceroute". + +The actual functionality of traceroute could also be implemented +natively in perl or linked in from a C library. + +Versions prior to 1.04 had some interface issues for subclassing. +These issues have been addressed, but required a public interface +change. If you were relying on the behavior of new to clone existing +objects, your code needs to be fixed. + +There are some suspected issues in how timeout is handled. I haven't +had time to address this yet. + +=head1 SEE ALSO + +traceroute(1) + +=head1 AUTHOR + +Daniel Hagerty + +=head1 COPYRIGHT + +Copyright 1998, 1999 Massachusetts Institute of Technology +Copyright 2000, 2001 Daniel Hagerty + +Permission to use, copy, modify, distribute, and sell this software +and its documentation for any purpose is hereby granted without fee, +provided that the above copyright notice appear in all copies and that +both that copyright notice and this permission notice appear in +supporting documentation, and that the name of M.I.T. not be used in +advertising or publicity pertaining to distribution of the software +without specific, written prior permission. M.I.T. makes no +representations about the suitability of this software for any +purpose. It is provided "as is" without express or implied warranty. + +=cut diff --git a/pandora_server/lib/PandoraFMS/Traceroute/PurePerl.pm b/pandora_server/lib/PandoraFMS/Traceroute/PurePerl.pm new file mode 100644 index 0000000000..ba1f304ba3 --- /dev/null +++ b/pandora_server/lib/PandoraFMS/Traceroute/PurePerl.pm @@ -0,0 +1,1295 @@ +# Repackaged by Pandora FMS +# Original lib at Net::Traceroute::PurePerl; + +package PandoraFMS::Traceroute::PurePerl; + +use vars qw(@ISA $VERSION $AUTOLOAD %net_traceroute_native_var %protocols); +use strict; +use warnings; +use PandoraFMS::Traceroute; +use Socket; +use FileHandle; +use Carp qw(carp croak); +use Time::HiRes qw(time); + +@ISA = qw(PandoraFMS::Traceroute); +$VERSION = '0.10'; + +# Constants from header files or RFCs + +use constant SO_BINDTODEVICE => 25; # from asm/socket.h +use constant IPPROTO_IP => 0; # from netinet/in.h + +# Windows winsock2 uses 4 for IP_TTL instead of 2 +use constant IP_TTL => ($^O eq "MSWin32") ? 4 : 2; + +use constant IP_HEADERS => 20; # Length of IP headers +use constant ICMP_HEADERS => 8; # Length of ICMP headers +use constant UDP_HEADERS => 8; # Length of UDP headers + +use constant IP_PROTOCOL => 9; # Position of protocol number + +use constant UDP_DATA => IP_HEADERS + UDP_HEADERS; +use constant ICMP_DATA => IP_HEADERS + ICMP_HEADERS; + +use constant UDP_SPORT => IP_HEADERS + 0; # Position of sport +use constant UDP_DPORT => IP_HEADERS + 2; # Position of dport + +use constant ICMP_TYPE => IP_HEADERS + 0; # Position of type +use constant ICMP_CODE => IP_HEADERS + 2; # Position of code +use constant ICMP_ID => IP_HEADERS + 4; # Position of ID +use constant ICMP_SEQ => IP_HEADERS + 6; # Position of seq + +use constant ICMP_PORT => 0; # ICMP has no port + +use constant ICMP_TYPE_TIMEEXCEED => 11; # ICMP Type +use constant ICMP_TYPE_ECHO => 8; # ICMP Type +use constant ICMP_TYPE_UNREACHABLE => 3; # ICMP Type +use constant ICMP_TYPE_ECHOREPLY => 0; # ICMP Type + +use constant ICMP_CODE_ECHO => 0; # ICMP Echo has no code + +# Perl 5.8.6 under Windows has a bug in the socket code, this env variable +# works around the bug. It may effect other versions as well, and they should +# be added here +BEGIN +{ + if ($^O eq "MSWin32" and $^V eq v5.8.6) + { + $ENV{PERL_ALLOW_NON_IFS_LSP} = 1; + } +} + +# The list of currently accepted protocols +%protocols = +( + 'icmp' => 1, + 'udp' => 1, +); + +my @icmp_unreach_code = +( + TRACEROUTE_UNREACH_NET, + TRACEROUTE_UNREACH_HOST, + TRACEROUTE_UNREACH_PROTO, + 0, + TRACEROUTE_UNREACH_NEEDFRAG, + TRACEROUTE_UNREACH_SRCFAIL, +); + +# set up allowed autoload attributes we need +my @net_traceroute_native_vars = qw(use_alarm concurrent_hops protocol + first_hop device); + +@net_traceroute_native_var{@net_traceroute_native_vars} = (); + +# Methods + +# AUTOLOAD (perl internal) +# Used to create the methods for the object dynamically from +# net_traceroute_naive_vars. +sub AUTOLOAD +{ + my $self = shift; + my $attr = $AUTOLOAD; + $attr =~ s/.*:://; + return unless $attr =~ /[^A-Z]/; # skip DESTROY and all-cap methods + carp "invalid attribute method: ->$attr()" + unless exists $net_traceroute_native_var{$attr}; + $self->{$attr} = shift if @_; + return $self->{$attr}; +} + +# new (public method) +# Creates a new blessed object of type Net::Traceroute::PurePerl. +# Accepts many options as arguments, and initilizes the new object with +# their values. +# Croaks on bad arguments. +sub new +{ + my $self = shift; + my $type = ref($self) || $self; + my %arg = @_; + + $self = bless {}, $type; + + # keep a loop from happening when calling super::new + my $backend = delete $arg{'backend'}; + + # used to get around the real traceroute running the trace + my $host = delete $arg{'host'}; + + # Old method to use ICMP for traceroutes, using `protocol' is preferred + my $useicmp = delete $arg{'useicmp'}; + + $self->debug_print(1, + "The useicmp parameter is depreciated, use `protocol'\n") if ($useicmp); + + # Initialize blessed hash with passed arguments + $self->_init(%arg); + + # Set protocol to ICMP if useicmp was set; + if ($useicmp) + { + carp ("Protocol already set, useicmp is overriding") + if (defined $self->protocol and $self->protocol ne "icmp"); + $self->protocol('icmp') if ($useicmp); + } + + # put our host back in and set defaults for undefined options + $self->host($host) if (defined $host); + $self->max_ttl(30) unless (defined $self->max_ttl); + $self->queries(3) unless (defined $self->queries); + $self->base_port(33434) unless (defined $self->base_port); + $self->query_timeout(5) unless (defined $self->query_timeout); + $self->packetlen(40) unless (defined $self->packetlen); + $self->first_hop(1) unless (defined $self->first_hop); + $self->concurrent_hops(6) unless (defined $self->concurrent_hops); + + # UDP is the UNIX default for traceroute + $self->protocol('udp') unless (defined $self->protocol); + + # Depreciated: we no longer use libpcap, so the alarm is no longer + # required. Kept for backwards compatibility but not used. + $self->use_alarm(0) unless (defined $self->use_alarm); + + # Validates all of the parameters. + $self->_validate(); + + return $self; +} + +# _init (private initialization method) +# Overrides Net::Traceroutes init to set PurePerl specific parameters. +sub _init +{ + my $self = shift; + my %arg = @_; + + foreach my $var (@net_traceroute_native_vars) + { + if(defined($arg{$var})) { + $self->$var($arg{$var}); + } + } + + $self->SUPER::init(@_); +} + +# pretty_print (public method) +# The output of pretty_print tries to match the output of traceroute(1) as +# close as possible, with two excpetions. First, I cleaned up the columns to +# make it easier to read, and second, I start a new line if the host IP changes +# instead of printing the new IP inline. The first column stays the same hop +# number, only the host changes. +sub pretty_print +{ + my $self = shift; + my $resolve = shift; + + print "traceroute to " . $self->host; + print " (" . inet_ntoa($self->{'_destination'}) . "), "; + print $self->max_ttl . " hops max, " . $self->packetlen ." byte packets\n"; + + my $lasthop = $self->first_hop + $self->hops - 1; + + for (my $hop=$self->first_hop; $hop <= $lasthop; $hop++) + { + my $lasthost = ''; + + printf '%2s ', $hop; + + if (not $self->hop_queries($hop)) + { + print "error: no responses\n"; + next; + } + + for (my $query=1; $query <= $self->hop_queries($hop); $query++) { + my $host = $self->hop_query_host($hop,$query); + if ($host and $resolve) + { + my $ip = $host; + $host = (gethostbyaddr(inet_aton($ip),AF_INET))[0] || $ip; + } + if ($host and ( not $lasthost or $host ne $lasthost )) + { + printf "\n%2s ", $hop if ($lasthost and $host ne $lasthost); + printf '%-15s ', $host; + $lasthost = $host; + } + my $time = $self->hop_query_time($hop, $query); + if (defined $time and $time > 0) + { + printf '%7s ms ', $time; + } + else + { + print "* "; + } + } + + print "\n"; + } + + return; +} + +# traceroute (public method) +# Starts a new traceroute. This is a blocking call and it will either croak on +# error, or return 0 if the host wasn't reached, or 1 if it was. +sub traceroute +{ + my $self = shift; + + # Revalidate parameters incase they were changed by calling $t->parameter() + # since the object was created. + $self->_validate(); + + carp "No host provided!" && return undef unless (defined $self->host); + + $self->debug_print(1, "Performing traceroute\n"); + + # Lookup the destination IP inside of a local scope + { + my $destination = inet_aton($self->host); + + croak "Could not resolve host " . $self->host + unless (defined $destination); + + $self->{_destination} = $destination; + } + + # release any old hop structure + $self->_zero_hops(); + + # Create the ICMP socket, used to send ICMP messages and receive ICMP errors + # Under windows, the ICMP socket doesn't get the ICMP errors unless the + # sending socket was ICMP, or the interface is in promiscuous mode, which + # is why ICMP is the only supported protocol under windows. + my $icmpsocket = FileHandle->new(); + + socket($icmpsocket, PF_INET, SOCK_RAW, getprotobyname('icmp')) || + croak("ICMP Socket error - $!"); + + $self->debug_print(2, "Created ICMP socket to receive errors\n"); + + $self->{'_icmp_socket'} = $icmpsocket; + $self->{'_trace_socket'} = $self->_create_tracert_socket(); + + # _run_traceroute is the event loop that actually does the work. + my $success = $self->_run_traceroute(); + + return $success; +} + +# Private methods + +# _validate (private method) +# Normalizes and validates all parameters, croaks on error +sub _validate +{ + my $self = shift; + + # Normalize values; + + $self->protocol( lc $self->protocol); + + $self->max_ttl( sprintf('%i',$self->max_ttl)); + $self->queries( sprintf('%i',$self->queries)); + $self->base_port( sprintf('%i',$self->base_port)); + $self->query_timeout( sprintf('%i',$self->query_timeout)); + $self->packetlen( sprintf('%i',$self->packetlen)); + $self->first_hop( sprintf('%i',$self->first_hop)); + $self->concurrent_hops( sprintf('%i',$self->concurrent_hops)); + + # Check to see if values are sane + + croak "Parameter `protocol' value is not supported : " . $self->protocol + if (not exists $protocols{$self->protocol}); + + croak "Parameter `first_hop' must be an integer between 1 and 255" + if ($self->first_hop < 1 or $self->first_hop > 255); + + croak "Parameter `max_ttl' must be an integer between 1 and 255" + if ($self->max_ttl < 1 or $self->max_ttl > 255); + + croak "Parameter `base_port' must be an integer between 1 and 65280" + if ($self->base_port < 1 or $self->base_port > 65280); + + croak "Parameter `packetlen' must be an integer between 40 and 1492" + if ($self->packetlen < 40 or $self->packetlen > 1492); + + croak "Parameter `first_hop' must be less than or equal to `max_ttl'" + if ($self->first_hop > $self->max_ttl); + + croak "parameter `queries' must be an interger between 1 and 255" + if ($self->queries < 1 or $self->queries > 255); + + croak "parameter `concurrent_hops' must be an interger between 1 and 255" + if ($self->concurrent_hops < 1 or $self->concurrent_hops > 255); + + croak "protocol " . $self->protocol . " not supported under Windows" + if ($self->protocol ne 'icmp' and $^O eq 'MSWin32'); + + return; +} + +# _run_traceroute (private method) +# The heart of the traceroute method. Sends out packets with incrementing +# ttls per hop. Recieves responses, validates them, and updates the hops +# hash with the time and host. Processes timeouts and returns when the host +# is reached, or the last packet on the last hop sent has been received +# or has timed out. Returns 1 if the host was reached, or 0. +sub _run_traceroute +{ + my $self = shift; + + my ( $end, # Counter for endhop to wait until all queries return + $endhop, # The hop that the host was reached on + $stop, # Tells the main loop to exit + $sentpackets, # Number of packets sent + $currenthop, # Current hop + $currentquery, # Current query within the hop + $nexttimeout, # Next time a packet will timeout + $rbits, # select() bits + $nfound, # Number of ready sockets from select() + %packets, # Hash of packets sent but without a response + %pktids, # Hash of packet port or seq numbers to packet ids + ); + + $stop = $end = $endhop = $sentpackets = 0; + + %packets = (); + %pktids = (); + + $currenthop = $self->first_hop; + $currentquery = 0; + + $rbits = ""; + vec($rbits,$self->{'_icmp_socket'}->fileno(), 1) = 1; + + while (not $stop) + { + # Reset the variable + $nfound = 0; + + # Send packets so long as there are packets to send, there is less than + # conncurrent_hops packets currently outstanding, there is no packets + # waiting to be read on the socket and we haven't reached the host yet. + while (scalar keys %packets < $self->concurrent_hops and + $currenthop <= $self->max_ttl and + (not $endhop or $currenthop <= $endhop) and + not $nfound = select((my $rout = $rbits),undef,undef,0)) + { + # sentpackets is used as an uid in the %packets hash. + $sentpackets++; + + $self->debug_print(1,"Sending packet $currenthop $currentquery\n"); + my $start_time = $self->_send_packet($currenthop,$currentquery); + my $id = $self->{'_last_id'}; + my $localport = $self->{'_local_port'}; + + $packets{$sentpackets} = + { + 'id' => $id, + 'hop' => $currenthop, + 'query' => $currentquery, + 'localport' => $localport, + 'starttime' => $start_time, + 'timeout' => $start_time+$self->query_timeout, + }; + + $pktids{$id} = $sentpackets; + + $nexttimeout = $packets{$sentpackets}{'timeout'} + unless ($nexttimeout); + + # Current query and current hop increments + $currentquery = ($currentquery + 1) % $self->queries; + if ($currentquery == 0) + { + $currenthop++; + } + } + + # If $nfound is nonzero than data is waiting to be read, no need to + # call select again. + if (not $nfound) # No data waiting to be read yet + { + # This sets the timeout for select to no more than .1 seconds + my $timeout = $nexttimeout - time; + $timeout = .1 if ($timeout > .1); + $nfound = select((my $rout = $rbits),undef,undef,$timeout); + } + + # While data is waiting to be read, read it. + while ($nfound and keys %packets) + { + my ( $recv_msg, # The packet read by recv() + $from_saddr, # The saddr returned by recv() + $from_port, # The port the packet came from + $from_ip, # The IP the packet came from + $from_id, # The dport / seq of the received packet + $from_proto, # The protocol of the packet + $from_type, # The ICMP type of the packet + $from_code, # The ICMP code of the packet + $icmp_data, # The data portion of the ICMP packet + $local_port, # The local port the packet is a reply to + $end_time, # The time the packet arrived + $last_hop, # Set to 1 if this packet came from the host + ); + + $end_time = time; + + $from_saddr = recv($self->{'_icmp_socket'},$recv_msg,1500,0); + if (defined $from_saddr) + { + ($from_port,$from_ip) = sockaddr_in($from_saddr); + $from_ip = inet_ntoa($from_ip); + $self->debug_print(1,"Received packet from $from_ip\n"); + } + else + { + $self->debug_print(1,"No packet?\n"); + $nfound = 0; + last; + } + + $from_proto = unpack('C',substr($recv_msg,IP_PROTOCOL,1)); + + if ($from_proto != getprotobyname('icmp')) + { + my $protoname = getprotobynumber($from_proto); + $self->debug_print(1,"Packet not ICMP $from_proto($protoname)\n"); + last; + } + + ($from_type,$from_code) = unpack('CC',substr($recv_msg,ICMP_TYPE,2)); + $icmp_data = substr($recv_msg,ICMP_DATA); + + if (not $icmp_data) + { + $self->debug_print(1, + "No data in packet ($from_type,$from_code)\n"); + last; + } + +# TODO This code does not decode ICMP codes, only ICMP types, which can lead +# to false results if a router sends, for instance, a Network Unreachable +# or Fragmentation Needed packet. + if ( $from_type == ICMP_TYPE_TIMEEXCEED or + $from_type == ICMP_TYPE_UNREACHABLE or + ($self->protocol eq "icmp" and + $from_type == ICMP_TYPE_ECHOREPLY) ) + { + + if ($self->protocol eq 'udp') + { + # The local port is used to verify the packet was sent from + # This process. + $local_port = unpack('n',substr($icmp_data,UDP_SPORT,2)); + + # The ID for UDP is the destination port number of the packet + $from_id = unpack('n',substr($icmp_data,UDP_DPORT,2)); + + # The target system will send ICMP port unreachable, routers + # along the path will send ICMP Time Exceeded messages. + $last_hop = ($from_type == ICMP_TYPE_UNREACHABLE) ? 1 : 0; + } + elsif ($self->protocol eq 'icmp') + { + if ($from_type == ICMP_TYPE_ECHOREPLY) + { + # The ICMP ID is used to verify the packet was sent from + # this process. + my $icmp_id = unpack('n',substr($recv_msg,ICMP_ID,2)); + last unless ($icmp_id == $$); + + my $seq = unpack('n',substr($recv_msg,ICMP_SEQ,2)); + $from_id = $seq; # The ID for ICMP is the seq number + $last_hop = 1;; + } + else + { + # The ICMP ID is used to verify the packet was sent from + # this process. + my $icmp_id = unpack('n',substr($icmp_data,ICMP_ID,2)); + last unless ($icmp_id == $$); + + my $ptype = unpack('C',substr($icmp_data,ICMP_TYPE,1)); + my $pseq = unpack('n',substr($icmp_data,ICMP_SEQ,2)); + if ($ptype eq ICMP_TYPE_ECHO) + { + $from_id = $pseq; # The ID for ICMP is the seq number + } + } + } + } + + # If we got and decoded the packet to get an ID, process it. + if ($from_ip and $from_id) + { + my $id = $pktids{$from_id}; + if (not $id) + { + $self->debug_print(1,"No packet sent matches the reply\n"); + last; + } + if (not exists $packets{$id}) + { + $self->debug_print(1,"Packet $id received after ID deleted"); + last; + } + if ($packets{$id}{'id'} == $from_id) + { + last if ($self->protocol eq 'udp' and + $packets{$id}{'localport'} != $local_port); + + my $total_time = $end_time - $packets{$id}{'starttime'}; + my $hop = $packets{$id}{'hop'}; + my $query = $packets{$id}{'query'}; + + if (not $endhop or $hop <= $endhop) + { + $self->debug_print(1,"Recieved response for $hop $query\n"); + $self->_add_hop_query($hop, $query+1, TRACEROUTE_OK, + $from_ip, sprintf("%.2f", 1000 * $total_time) ); + + # Sometimes a route will change and last_hop won't be set + # causing the traceroute to hang. Therefore if hop = endhop + # we set $end to the number of query responses for the + # hop recieved so far. + + if ($last_hop or ($endhop and $hop == $endhop)) + { + $end = $self->hop_queries($hop); + $endhop = $hop; + } + } + + # No longer waiting for this packet + delete $packets{$id}; + } + } + # Check if more data is waiting to be read, if so keep reading + $nfound = select((my $rout = $rbits),undef,undef,0); + } + + # Process timed out packets + if (keys %packets and $nexttimeout < time) + { + undef $nexttimeout; + + foreach my $id (sort keys %packets) + { + my $hop = $packets{$id}{'hop'}; + + if ($packets{$id}{'timeout'} < time) + { + my $query = $packets{$id}{'query'}; + + $self->debug_print(1,"Timeout for $hop $query\n"); + $self->_add_hop_query($hop, $query+1, TRACEROUTE_TIMEOUT, + "", 0 ); + + if ($endhop and $hop == $endhop) + { + # Sometimes a route will change and last_hop won't be set + # causing the traceroute to hang. Therefore if hop = endhop + # we set $end to the number of query responses for the + # hop recieved so far. + + $end = $self->hop_queries($hop); + } + + # No longer waiting for this packet + delete $packets{$id}; + } + elsif (not defined $nexttimeout) + { + # Reset next timeout to the next packet + $nexttimeout = $packets{$id}{'timeout'}; + last; + } + } + } + + # Check if it is time to stop the looping + if ($currenthop > $self->max_ttl and not keys %packets) + { + $self->debug_print(1,"No more packets, reached max_ttl\n"); + $stop = 1; + } + elsif ($end >= $self->queries) + { + # Delete packets for hops after $endhop + foreach my $id (sort keys %packets) + { + my $hop = $packets{$id}{'hop'}; + if (not $hop or ( $endhop and $hop > $endhop) ) + { + # No longer care about this packet + delete $packets{$id}; + } + } + if (not keys %packets) + { + $self->debug_print(1,"Reached host on $endhop hop\n"); + $end = 1; + $stop = 1; + } + } + + # Looping + } + + return $end; +} + +# _create_tracert_socket (private method) +# Reuses the ICMP socket already created for icmp traceroutes, or creates a +# new socket. It then binds the socket to the user defined device and/or +# source address if provided and returns the created socket. +sub _create_tracert_socket +{ + my $self = shift; + my $socket; + + if ($self->protocol eq "icmp") + { + $socket = $self->{'_icmp_socket'}; + } + elsif ($self->protocol eq "udp") + { + $socket = FileHandle->new(); + + socket($socket, PF_INET, SOCK_DGRAM, getprotobyname('udp')) or + croak "UDP Socket creation error - $!"; + + $self->debug_print(2,"Created UDP socket"); + } + + if ($self->device) + { + setsockopt($socket, SOL_SOCKET, SO_BINDTODEVICE, + pack('Z*', $self->device)) or + croak "error binding to ". $self->device ." - $!"; + + $self->debug_print(2,"Bound socket to ". $self->device ."\n"); + } + + if ($self->source_address and $self->source_address ne '0.0.0.0') + { + $self->_bind($socket); + } + + return $socket; +} + +# _bind (private method) +# binds a sockets to a local address so all packets originate from that IP. +sub _bind +{ + my $self = shift; + my $socket = shift; + + my $ip = inet_aton($self->source_address); + + croak "Nonexistant local address ". $self->source_address + unless (defined $ip); + + CORE::bind($socket, sockaddr_in(0,$ip)) or + croak "Error binding to ".$self->source_address.", $!"; + + $self->debug_print(2,"Bound socket to " . $self->source_address . "\n"); + + return; +} + +# _send_packet (private method) +# Sends the packet for $hop, $query to the destination. Actually calls +# submethods for the different protocols which create and send the packet. +sub _send_packet +{ + my $self = shift; + my ($hop,$query) = @_; + + if ($self->protocol eq "icmp") + { + # Sequence ID for the ICMP echo request + my $seq = ($hop-1) * $self->queries + $query + 1; + $self->_send_icmp_packet($seq,$hop); + $self->{'_last_id'} = $seq; + } + elsif ($self->protocol eq "udp") + { + # Destination port for the UDP packet + my $dport = $self->base_port + ($hop-1) * $self->queries + $query; + $self->_send_udp_packet($dport,$hop); + $self->{'_last_id'} = $dport; + } + + return time; +} + +# _send_icmp_packet (private method) +# Sends an ICMP packet with the given sequence number. The PID is used as +# the packet ID and $seq is the sequence number. +sub _send_icmp_packet +{ + my $self = shift; + my ($seq,$hop) = @_; + + # Set TTL of socket to $hop. + my $saddr = $self->_connect(ICMP_PORT,$hop); + my $data = 'a' x ($self->packetlen - ICMP_DATA); + + my ($pkt, $chksum) = (0,0); + + # Create packet twice, once without checksum, once with it + foreach (1 .. 2) + { + $pkt = pack('CC n3 A*', + ICMP_TYPE_ECHO, # Type + ICMP_CODE_ECHO, # Code + $chksum, # Checksum + $$, # ID (pid) + $seq, # Sequence + $data, # Data + ); + + $chksum = $self->_checksum($pkt) unless ($chksum); + } + + send($self->{'_trace_socket'}, $pkt, 0, $saddr); + + return; +} + +# _send_udp_packet (private method) +# Sends a udp packet to the given destination port. +sub _send_udp_packet +{ + my $self = shift; + my ($dport,$hop) = @_; + + # Connect socket to destination port and set TTL + my $saddr = $self->_connect($dport,$hop); + my $data = 'a' x ($self->packetlen - UDP_DATA); + + $self->_connect($dport,$hop); + + send($self->{'_trace_socket'}, $data, 0); + + return; +} + +# _connect (private method) +# Connects the socket unless the protocol is ICMP and sets the TTL. +sub _connect +{ + my $self = shift; + my ($port,$hop) = @_; + + my $socket_addr = sockaddr_in($port,$self->{_destination}); + + if ($self->protocol eq 'udp') + { + CORE::connect($self->{'_trace_socket'},$socket_addr); + $self->debug_print(2,"Connected to " . $self->host . "\n"); + } + + setsockopt($self->{'_trace_socket'}, IPPROTO_IP, IP_TTL, pack('C',$hop)); + $self->debug_print(2,"Set TTL to $hop\n"); + + if ($self->protocol eq 'udp') + { + my $localaddr = getsockname($self->{'_trace_socket'}); + my ($lport,undef) = sockaddr_in($localaddr); + $self->{'_local_port'} = $lport; + } + + return ($self->protocol eq 'icmp') ? $socket_addr : undef; +} + +# _checksum (private method) +# Lifted verbatum from Net::Ping 2.31 +# Description: Do a checksum on the message. Basically sum all of +# the short words and fold the high order bits into the low order bits. +sub _checksum +{ + my $self = shift; + my $msg = shift; + + my ( $len_msg, # Length of the message + $num_short, # The number of short words in the message + $short, # One short word + $chk # The checksum + ); + + $len_msg = length($msg); + $num_short = int($len_msg / 2); + $chk = 0; + foreach $short (unpack("n$num_short", $msg)) + { + $chk += $short; + } # Add the odd byte in + $chk += (unpack("C", substr($msg, $len_msg - 1, 1)) << 8) if $len_msg % 2; + $chk = ($chk >> 16) + ($chk & 0xffff); # Fold high into low + return(~(($chk >> 16) + $chk) & 0xffff); # Again and complement +} + +1; + +__END__ + +=head1 NAME + +Net::Traceroute:PurePerl - traceroute(1) functionality in perl via raw sockets + +=head1 VERSION + +This document describes version 0.10 of Net::Traceroute::PurePerl. + +=head1 SYNOPSIS + + use Net::Traceroute::PurePerl; + + my $t = new Net::Traceroute::PurePerl( + backend => 'PurePerl', # this optional + host => 'www.openreach.com', + debug => 0, + max_ttl => 12, + query_timeout => 2, + packetlen => 40, + protocol => 'udp', # Or icmp + ); + $t->traceroute; + $t->pretty_print; + + +=head1 DESCRIPTION + +This module implements traceroute(1) functionality for perl5. +It allows you to trace the path IP packets take to a destination. +It is implemented by using raw sockets to act just like the regular traceroute. + +You must also be root to use the raw sockets. + +=head1 INSTALLATION + +=head2 Basic Installation + +Net::Traceroute::PurePerl may be installed through the CPAN shell +in the usual CPAN shell manner. This typically is: + + $ perl -MCPAN -e 'install Net::Traceroute::PurePerl' + +You can also read this README from the CPAN shell: + + $ perl -MCPAN -e shell + cpan> readme Net::Traceroute::PurePerl + +And you can install the module from the CPAN prompt as well: + + cpan> install Net::Traceroute::PurePerl + +=head2 Manual Installation + +Net::Traceroute::PurePerl can also be installed manually. +L or a +similarly named directory at your favorite CPAN mirror should hold the +latest version. + +Downloading and unpacking the distribution are left up to the reader. + +To build and test it: + + perl Makefile.PL + make + make test + +The test program, t/01_trace.t, makes an excellent sample program. It was +adapted from the code used to test and develop this module. There may be +additional sample programs in the examples folder. + +When you are ready to install the module: + + make install + +It should now be ready to use. + +=head1 OVERVIEW + +A new Net::Traceroute::PurePerl object must be created with the I method. +This will not perform the traceroute immediately, unlike Net::Traceroute. +It will return a "template" object that can be used to set parameters for +several subsequent traceroutes. + +Methods are available for accessing information about a given +traceroute attempt. There are also methods that view/modify the +options that are passed to the object's constructor. + +To trace a route, UDP or ICMP packets are sent with a small TTL (time-to-live) +field in an attempt to get intervening routers to generate ICMP +TIME_EXCEEDED messages. + +=head1 VERSION CHANGES + +This version of Net::Traceroute::PurePerl is a complete rewrite of the internal +traceroute code used in the 0.02 release. As such a number of new capabilities +have been introduced, and probably a number of bugs as well. + +The public methods have remained unchanged, and this should be a drop in +replacement for the older version. + +This version no longer resolves router IPs to host names in the traceroute +code. If you need the IP resolved you have to do it from your code, or use +the pretty_print method with a positive value passed as an argument. + +The current version does not correctly detect network unreachable and +other nonstandard ICMP errors. This can lead to problems on networks where +these errors are sent instead of a port unreachable or ttl exceeded packet. + +=head1 CONSTRUCTOR + + $obj = Net::Traceroute::PurePerl->new( + [base_port => $base_port,] + [debug => $debuglvl,] + [max_ttl => $max_ttl,] + [host => $host,] + [queries => $queries,] + [query_timeout => $query_timeout,] + [source_address => $srcaddr,] + [packetlen => $packetlen,] + [concurrent_hops => $concurrent,] + [first_hop => $first_hop,] + [device => $device,] + [protocol => $protocol,] + ); + + +This is the constructor for a new Net::Traceroute object. +If given C, it will NOT actually perform the traceroute. +You MUST call the traceroute method later. + +Possible options are: + +B - A host to traceroute to. If you don't set this, you get a +Traceroute object with no traceroute data in it. The module always +uses IP addresses internally and will attempt to lookup host names via +inet_aton. + +B - Base port number to use for the UDP queries. +Traceroute assumes that nothing is listening to port C to +C +where nhops is the number of hops required to reach the destination +address and nqueries is the number of queries per hop. +Default is what the system traceroute uses (normally 33434) +C's C<-p> option. + +B - A number indicating how verbose debug information should +be. Please include debug=>9 output in bug reports. + +B - Maximum number of hops to try before giving up. Default +is what the system traceroute uses (normally 30). C's +C<-m> option. + +B - Number of times to send a query for a given hop. +Defaults to whatever the system traceroute uses (3 for most +traceroutes). C's C<-q> option. + +B - How many seconds to wait for a response to each +query sent. Uses the system traceroute's default value of 5 if +unspecified. C's C<-w> option. + +B - unused here + +B - Select the source address that traceroute will use. +C's C<-S> option. + +B - Length of packets to use. Traceroute tries to make the +IP packet exactly this long. + +B - unused here + +B - unused at the moment + +B - unused in this version + +B - Either ICMP or UDP. ICMP uses ICMP echo packets with incrementing +sequence numbers, while UDP uses USP packets with incrementing ports. It +defaults to udp. + +B - This is the maximum number of outstanding packets sent +at one time. Setting this to a high number may overflow your socket receive +buffer and slightly delay the processing of response packets, making the +round trip time reported slightly higher, however it will significantly +decrease the amount of time it takes to run a traceroute. Defaults to 6. + C's C<-N> option. + +B - This is the lowest TTL to use. Setting this will skip the +first x routers in the path, especially useful if they never change. Defaults +to 1. C's C<-f> option. + +B - The device to send the packet from. Normally this is determined +by the system's routing table, but it can be overridden. It defaults to undef. + C's C<-I> option. + +=head1 METHODS + +=over 4 + +=item traceroute + +Run the traceroute. +Will fill in the rest of the object for informational queries. + +The traceroute method is a blocking call. It will not return until the max_ttl +is reached or the host is reached. As such, if your program is time dependent +the call should be wrapped in an eval with an ALARM set. + + eval { + local $SIG{ALRM} = sub { die "alarm" }; + alarm $timeout; + $success = $t->traceroute(); + alarm 0; + } + warn "Traceroute timed out\n" if ($@ and $@ eq "alarm"); + +Returns 1 if the host was reached, or 0 if it wasn't. + +=back + +=head2 Controlling traceroute invocation + +Each of these methods return the current value of the option specified +by the corresponding constructor option. They will set the object's +instance variable to the given value if one is provided. + +Changing an instance variable will only affect newly performed +traceroutes. Setting a different value on a traceroute object that +has already performed a trace has no effect. + +See the constructor documentation for information about methods that +aren't documented here. + +=over 4 + +=item base_port([PORT]) + +=item max_ttl([PORT]) + +=item queries([QUERIES]) + +=item query_timeout([TIMEOUT]) + +=item host([HOST]) + +=item source_address([SRC]) + +=item packetlen([LEN]) + +=item use_alarm([0|1]) + +=item protocl([PROTOCOL]) + +=item concurrent_hops([CONCURRENT]) + +=item first_hop([FIRST_HOP]) + +=item device([DEVICE]) + +=back + +=head2 Obtaining information about a Trace + +These methods return information about a traceroute that has already +been performed. + +Any of the methods in this section that return a count of something or +want an Ith type count to identify something employ one based +counting. + +=over 4 + +=item pretty_print + +Prints to stdout a traceroute-like text. Tries to mimic traceroute(1)'s +output as close as possible with a few exceptions. First, the columns are +easier to read, and second, a new line is started if the host IP changes +instead of printing the new IP inline. The first column stays the same hop +number, only the host changes. + +Passing in an argument of 1 will make pretty_print resolve the names of the +router ips, otherwise they are printed as raw ip addresses, like +C's C<-n> option. + +=item stat + +Returns the status of a given traceroute object. One of +TRACEROUTE_OK, TRACEROUTE_TIMEOUT, or TRACEROUTE_UNKNOWN (each defined +as an integer). TRACEROUTE_OK will only be returned if the host was +actually reachable. + +=item found + +Returns 1 if the host was found, undef otherwise. + +=item pathmtu + +If your traceroute supports MTU discovery, this method will return the +MTU in some circumstances. You must set no_fragment, and must use a +packetlen larger than the path mtu for this to be set. + +NOTE: This doesn't work with this version. + +=item hops + +Returns the number of hops that it took to reach the host. + +=item hop_queries(HOP) + +Returns the number of queries that were sent for a given hop. This +should normally be the same for every query. + +=item hop_query_stat(HOP, QUERY) + +Return the status of the given HOP's QUERY. The return status can be +one of the following (each of these is actually an integer constant +function defined in Net::Traceroute's export list): + +QUERY can be zero, in which case the first succesful query will be +returned. + +=over 4 + +=item TRACEROUTE_OK + +Reached the host, no problems. + +=item TRACEROUTE_TIMEOUT + +This query timed out. + +=item TRACEROUTE_UNKNOWN + +Your guess is as good as mine. Shouldn't happen too often. + +=item TRACEROUTE_UNREACH_NET + +This hop returned an ICMP Network Unreachable. + +=item TRACEROUTE_UNREACH_HOST + +This hop returned an ICMP Host Unreachable. + +=item TRACEROUTE_UNREACH_PROTO + +This hop returned an ICMP Protocol unreachable. + +=item TRACEROUTE_UNREACH_NEEDFRAG + +Indicates that you can't reach this host without fragmenting your +packet further. Shouldn't happen in regular use. + +=item TRACEROUTE_UNREACH_SRCFAIL + +A source routed packet was rejected for some reason. Shouldn't happen. + +=item TRACEROUTE_UNREACH_FILTER_PROHIB + +A firewall or similar device has decreed that your traffic is +disallowed by administrative action. Suspect sheer, raving paranoia. + +=item TRACEROUTE_BSDBUG + +The destination machine appears to exhibit the 4.[23]BSD time exceeded +bug. + +=back + +=item hop_query_host(HOP, QUERY) + +Return the dotted quad IP address of the host that responded to HOP's +QUERY. + +QUERY can be zero, in which case the first succesful query will be +returned. + +=item hop_query_time(HOP, QUERY) + +Return the round trip time associated with the given HOP's query. If +your system's traceroute supports fractional second timing, so +will Net::Traceroute. + +QUERY can be zero, in which case the first succesful query will be +returned. + +=back + +=head1 BUGS and LIMITATIONS + +I have not tested the cloning functions of Net::Traceroute::PurePerl. +It ought to work, but if not, BUG me. + +This module requires root or administrative privileges to run. It opens a raw +socket to listen for TTL exceeded messages. Take appropriate precautions. + +Windows only supports ICMP traceroutes. This may change in a future release, +but it is a real pain since Windows doesn't send ICMP error messages to +applications for other protocols unless the socket is in promiscous mode. :( + +The current version does not correctly detect network unreachable and +other nonstandard ICMP errors. This can lead to problems on networks where +these errors are sent instead of a port unreachable or ttl exceeded packet. + +The current version does not support Net::Traceroute's clone method. +Calling clone will create an object that is unusable at this point. + +=head1 TODO + +=over 2 + +=item * + +Implement IPv6 capability. + +=item * + +Implement TCP traceroute. + +=item * + +Fix bugs listed above. + +=back + +=head1 SEE ALSO + +traceroute(1) + +This module's traceroute code was heavily influenced by C. + +See the examples folder and the test programs for more examples of this module +in action. + +=head1 AUTHOR + +Tom Scanlan owner Net::Traceroute::PurePerl + +Andrew Hoying current co-maintainer of +Net::Traceroute::PurePerl. Any bugs in this release are mine, please send me +the bug reports. + +Daniel Hagerty owner of Net::Traceroute and input on this fella + +=head1 COPYRIGHT + +Go right ahead and copy it. 2002 Tom Scanlan. Copyright 2006 by Andrew Hoying. +Don't blame me for damages, just the bugs. + +Net::Traceroute::PurePerl is free software; you may redistribute it and or modify it under the same terms as Perl itself. + +=cut diff --git a/pandora_server/pandora_server.redhat.spec b/pandora_server/pandora_server.redhat.spec index 6a9827b26c..eb8d690089 100644 --- a/pandora_server/pandora_server.redhat.spec +++ b/pandora_server/pandora_server.redhat.spec @@ -24,10 +24,10 @@ Prereq: %{_sbindir}/useradd AutoReq: 0 Provides: %{name}-%{version} Requires: coreutils -Requires: perl-Mail-Sendmail perl-DBI perl-DBD-mysql perl-Time-Format +Requires: perl-DBI perl-DBD-mysql Requires: perl-XML-Simple perl-XML-SAX Requires: perl-NetAddr-IP net-snmp net-tools -Requires: nmap wmic sudo xprobe2 +Requires: nmap wmic sudo %description Pandora FMS is a monitoring system for big IT environments. It uses remote tests, or local agents to grab information. Pandora supports all standard OS (Linux, AIX, HP-UX, Solaris and Windows XP,2000/2003), and support multiple setups in HA enviroments. diff --git a/pandora_server/pandora_server.spec b/pandora_server/pandora_server.spec index d737563f7c..618ce16bce 100644 --- a/pandora_server/pandora_server.spec +++ b/pandora_server/pandora_server.spec @@ -21,9 +21,9 @@ BuildArchitectures: noarch Requires(pre): /usr/sbin/useradd AutoReq: 0 Provides: %{name}-%{version} -Requires: perl-Mail-Sendmail perl-DBI perl-DBD-mysql perl-time-format +Requires: perl-DBI perl-DBD-mysql Requires: perl-NetAddr-IP net-snmp net-tools -Requires: nmap wmic sudo xprobe2 perl-HTML-Tree perl-XML-SAX +Requires: nmap wmic sudo perl-HTML-Tree perl-XML-SAX %description Pandora FMS is a monitoring system for big IT environments. It uses remote tests, or local agents to grab information. Pandora supports all standard OS (Linux, AIX, HP-UX, Solaris and Windows XP,2000/2003), and support multiple setups in HA enviroments. diff --git a/pandora_server/pandora_server_installer b/pandora_server/pandora_server_installer index 78ad3a6d1d..3c4af614f1 100755 --- a/pandora_server/pandora_server_installer +++ b/pandora_server/pandora_server_installer @@ -90,22 +90,22 @@ install () { echo "You are missing the following dependencies" echo " " cat output | awk -F ": prerequisite" '{print $2}' | awk -F " " '{print $1}' - echo "The complete installation guide is at: "http://www.openideas.info/wiki/index.php?title=Pandora_2.0:Documentation_en:Install_Server#Pandora_FMS_Server_installation" " + echo "The complete installation guide is at: http://openideas.info/wiki/index.php?title=Pandora" echo " " echo "Debian-based distribution do:" - echo " # apt-get install snmp snmpd libtime-format-perl libxml-simple-perl libnetaddr-ip-perl libdbi-perl libxml-simple-perl libnetaddr-ip-perl libhtml-parser-perl wmi-client xprobe2 libmail-sendmail-perl" + echo " # apt-get install snmp snmpd libxml-simple-perl libnetaddr-ip-perl libdbi-perl libxml-simple-perl libnetaddr-ip-perl libhtml-parser-perl wmi-client xprobe2" echo " " echo "For CentOS / RHEL do: " echo " " - echo " # yum install perl-XML-SAX* perl-Tie* perl-XML-Simple* perl-IO-Socket* perl-Time-modules* perl-NetAddr-IP* perl-DateTime* perl-ExtUtils perl-DBI nmap xprobe2" + echo " # yum install perl-XML-SAX* perl-Tie* perl-XML-Simple* perl-IO-Socket* perl-Time-modules* perl-NetAddr-IP* perl-DateTime* perl-ExtUtils perl-DBI nmap " echo " " echo "For OpenSUSE / SLES do : " echo " " - echo " # zypper install install nmap perl-DBD-mysql perl-DBI perl-Date-Calc perl-HTML-Parser -perl-HTML-Encoding perl-HTML-Tree perl-IO-Socket-Multicast perl-Mail-Sendmail perl-NetAddr-IP + echo " # zypper install install nmap perl-DBD-mysql perl-DBI perl-HTML-Parser +perl-HTML-Encoding perl-HTML-Tree perl-NetAddr-IP perl-TimeDate perl-XML-Simple perl-libwww-perl mysql-client" echo " " - echo " You also will need to install xprobe2 and wmiclient from rpm (download from our website)" + echo " You also will need to install (optionally) xprobe2 and wmiclient from rpm (download from our website)" echo " " echo "For FreeBSD do : " echo " " @@ -118,12 +118,12 @@ perl-TimeDate perl-XML-Simple perl-libwww-perl mysql-client" echo " # make install" echo " " echo " Install following tools from ports. Don't use packages." - echo " Recommended: p5-DBI p5-Mail-Sendmail p5-NetAddr-IP p5-XML-Simple p5-Time-Format p5-HTML-Parser p5-Net-Traceroute-PurePerl p5-IO-Socket-Multicast p5-DBD-mysql" + echo " Recommended: p5-DBI p5-NetAddr-IP p5-XML-Simple p5-HTML-Parser p5-DBD-mysql" echo " Optional: nmap xprobe" echo " " echo "To get it from source through CPAN do" echo " " - echo " $ cpan Digest::MD5 Time::Local DBI XML::Simple IO::Socket Time::HiRes Time::Format NetAddr::IP Mail::Sendmail Net::Traceroute::PurePerl HTML::Entities" + echo " $ cpan Time::Local DBI XML::Simple IO::Socket Time::HiRes NetAddr::IP HTML::Entities" echo " " rm output else diff --git a/pandora_server/util/compaq_chassis_trap_manager2.pl b/pandora_server/util/compaq_chassis_trap_manager2.pl new file mode 100755 index 0000000000..e6086784a7 --- /dev/null +++ b/pandora_server/util/compaq_chassis_trap_manager2.pl @@ -0,0 +1,90 @@ +#!/usr/bin/perl +# (c) Sancho Lerena 2010 +# Specific Pandora FMS trap collector for Compaq Hardware + +# Parameter list: list_event, code with TRAP VALUES to match +# module_name: Name of the module generated. + +my @list_event = ('22013', '22042', '22039'); +my $module_name = "evento_enclosure"; + +use POSIX qw(setsid strftime); + +sub show_help { + print "\nSpecific Pandora FMS trap collector for compaq Hardware\n"; + print "(c) Sancho Lerena 2010 \n"; + print "Usage:\n\n"; + print " compaq_chassis_trap_manager.pl \n\n"; + exit; +} + +sub writexml { + my ($hostname, $xmlmessage ) = @_; + my $file = "/var/spool/pandora/data_in/$hostname.".rand(1000).".data"; + +# my $file = "/tmp/compaq.debug"; + open (FILE, ">> $file") or die "[FATAL] Cannot write to XML '$file'"; + print FILE $xmlmessage; + close (FILE); +} + +if ($#ARGV == -1){ + show_help(); +} + +$chunk = ""; + +# First parameter is always destination host for virtual server +$target_host = $ARGV[0]; + +foreach $argnum (1 .. $#ARGV) { + if ($chunk ne ""){ + $chunk .= " "; + } + $chunk .= $ARGV[$argnum]; +} + +my $hostname = ""; +my $now = strftime ("%Y-%m-%d %H:%M:%S", localtime()); +my $xmldata = ""; + +my $blade = "N/A"; +my $index_pos = 1; +my $enclosure = "N/A"; +my $rack = "N/A"; + +# Get position +if ($chunk =~ m/.1.3.6.1.4.1.232.22.2.4.1.1.1.8.([0-9])*\s/){ + $index_pos = $1; +} + +# Get blade +if ($chunk =~ m/.1.3.6.1.4.1.232.22.2.4.1.1.1.4.$index_pos \= STRING\: ([A-Za-z0-9\-\.]*)\s/){ + $blade = $1; +} + +# Get enclosure +if ($chunk =~ m/.1.3.6.1.4.1.232.22.2.4.1.1.1.5.$index_pos \= STRING\: ([A-Za-z0-9\-\.]*)\s/){ + $enclosure = $1; +} + +# Get rack +if ($chunk =~ m/1.3.6.1.4.1.232.22.2.2.1.1.2.1 \= STRING\: ([A-Za-z0-9\-\.]*)\s\.1/){ + $rack = $1; +} + +my $event_code = ""; +foreach $argnum (0 .. $#list_event) { + if ($chunk =~ m/\s\.($list_event[$argnum])\s/){ + $text = chunk; + $event_code = $1; + } +} + +$xmldata .= +"$module_name_$event_codeasync_string\n"; +$xmldata .= "\n"; + +writexml ($target_host, $xmldata); + + diff --git a/pandora_server/util/mcast_client.pl b/pandora_server/util/mcast_client.pl deleted file mode 100755 index 74beaadfc4..0000000000 --- a/pandora_server/util/mcast_client.pl +++ /dev/null @@ -1,25 +0,0 @@ -#!/usr/bin/perl -# Multicast client -# Copyright (c) 2007 Artica Soluciones Tecnologicas S.L. - -use strict; -use IO::Socket::Multicast; - -if ($#ARGV != 1) { - print "Usage: $0 \n"; - exit 1; -} - -my $group = $ARGV[0]; -my $port = $ARGV[1]; - -my $sock = IO::Socket::Multicast->new(Proto=>'udp',LocalPort=>$port); -$sock->mcast_add($group) || die "Couldn't set group: $!\n"; - -print "Press ctr-c to quit\n"; - -while (1) { - my $data; - next unless $sock->recv($data,1024); - print $data; -} diff --git a/pandora_server/util/pandora_logrotate b/pandora_server/util/pandora_logrotate index 4e07481fbb..b757b9c2f4 100644 --- a/pandora_server/util/pandora_logrotate +++ b/pandora_server/util/pandora_logrotate @@ -30,11 +30,15 @@ } /var/log/pandora/pandora_snmptrap.log { - daily + weekly missingok - size 150000 + size 500000 rotate 1 - maxage 7 + maxage 365 notifempty - create 644 root root + create 664 root root + postrotate + /etc/init.d/pandora_server restart + endscript + }