File Coverage

blib/lib/Luka.pm

Criterion	Covered	Total	%
statement	57	201	28.3
branch	0	60	0.0
condition	0	35	0.0
subroutine	19	24	79.1
pod	1	3	33.3
total	77	323	23.8

# $Id: Luka.pm,v 1.12 2006/07/17 22:02:44 toni Exp $
package Luka;
use strict;
use warnings;
use Socket;
use Sys::Syslog;
use Sys::Hostname;
use Sys::Hostname::Long;
use Luka::Mailer;
use Luka::Exceptions;
use Luka::Error;
use Luka::Conf;
use Error qw(:try);
use Data::Dumper;

push @Exception::Class::Base::ISA, 'Error'
    unless Exception::Class::Base->isa('Error');

use Carp;
use Exporter;
our (@ISA, @EXPORT_OK, @EXPORT, @modes, %error_str );

@ISA = qw(Exporter);
@EXPORT_OK = qw(report_error);

our $VERSION = "1.07";
our $LukaDebug = "LukaDebug";

use Class::Std;

{
    # config definition of the script handled
    my %script_about : ATTR( :get  :set );

    #-----------------------------------
    # captured error/report properties
    #-----------------------------------
    my %error      : ATTR( :get      :set ); # error object
    my %id         : ATTR( :get         :set );
    my %line       : ATTR( :get       :set );
    my %stacktrace : ATTR( :get :set );
    my %text       : ATTR( :get       :set );    # error string
    my %severity   : ATTR( :get   :set );
    my %args       : ATTR( :get       :set );
    my %context    : ATTR( :get    :set );

    # config file location (for tests)
    my %conf       : ATTR( :get       :set );

    # captured script properties
    my %path     : ATTR( :get      :set );
    my %filename : ATTR( :get  :set );

    # captured device state
    my %ipaddr          : ATTR( :get           :set );
    my %hostname        : ATTR( :get         :set );
    my %hostname_long   : ATTR( :get    :set );
    my %local_date_time : ATTR( :get  :set );
    my %syslogd         : ATTR( :get          :set );

    # captured process state
    my %pid  : ATTR( :get   :set  );
    my %uid  : ATTR( :get   :set  );
    my %euid : ATTR( :get  :set );
    my %gid  : ATTR( :get   :set  );
    my %egid : ATTR( :get  :set );

    # global config options
    my %doc_base : ATTR( :get :set );
    my %debug    : ATTR( :get    :set );
    my %nomail   : ATTR( :get   :set );
    my %state_code_error           : ATTR( :get           :set );
    my %state_code_success         : ATTR( :get         :set );
    my %default_state_code_error   : ATTR( :get   :set );
    my %default_state_code_success : ATTR( :get :set );

    # reporting [delivery:email]
    my %send_to             : ATTR( :get              :set );
    my %send_cc             : ATTR( :get              :set );
    my %send_from           : ATTR( :get            :set );
    my %send_subj_success   : ATTR( :get    :set );
    my %report_body_error   : ATTR( :get    :set );
    my %report_body_success : ATTR( :get  :set );

    # syslog logging options
    my %syslogopt : ATTR( :get  :set );
    my %syslogfacility : ATTR( :get  :set );

    @modes = qw( error success );
    $error_str{"modes"} = "Unknown mode 'ARG'. Available modes: " . join(",",@modes);
    $error_str{"unknown_method"} = "Unknown method 'ARG' can not be called on " .
	__PACKAGE__ . " objects.";

    sub validate_modes : PRIVATE {
	my ($self, $mode) = @_;
	if (!grep {/^$mode$/} @modes ) {
	    throw Luka::Exception::Program
		( error => $self->get_error_str("modes",$mode), show_trace =>1 );
	}
    }

    sub get_error_str : PRIVATE {
	my ($self, $type, $arg) = @_;
	if (exists $error_str{$type}) {
	    my $str = $error_str{$type};
	    $str =~ s/ARG/$arg/;
	    return $str;
	} else {
	    throw Luka::Exception::Program
		( error => "Error type '$type', isn't defined", show_trace =>1 );
	}
    }

    sub get : PRIVATE {
	my ($self, $val, $mode) = @_;
	#print "val=$val,mode=$mode\n";
	$self->validate_modes($mode);
    	my $method = "get_" . $val . "_" . $mode;
	if ( $self->can($method) ) {
	    #print "method=$method\n";
	    return $self->$method;
	} else {
	    throw Luka::Exception::Program
		( error => $self->get_error_str("unknown_method",$method), show_trace =>1 );
	}
    }

    sub BUILD {
	my ($self, $ident, $arg_ref) = @_;

	my $luka_conf;
	# capture device and process state
	my $unknown = "unknown";
	$hostname{$ident} = hostname();
	$hostname_long{$ident} = hostname_long();
	$pid{$ident}     = $$;
	$uid{$ident}     = $<;
	$euid{$ident}    = $>;
	$gid{$ident}     = $(;
	$egid{$ident}    = $);
	my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(CORE::time());
	$local_date_time{$ident} =
	    sprintf("%s-%s-%sT%s:%s:%s",$year + 1900,$mon + 1,$mday,$hour,$min,$sec);
	$hostname{$ident}      = hostname() || $unknown;
	$hostname_long{$ident} = hostname_long() || $unknown;

	# error/report properties
	if (defined $arg_ref->{'error'}) {

	    my $E = $arg_ref->{'error'};

 	    $filename{$ident} = $arg_ref->{'filename'};
 	    #$filename{$ident}  = $E->file;
	    $id{$ident}        = $E->id || "generic";
	    $severity{$ident}  = $E->can("severity") ? $E->severity : $unknown;
	    $args{$ident}      = $E->can("args")     ?
		(defined($E->args) ? $E->args : $unknown) : $unknown;
	    $context{$ident}   = $E->can("context")  ? $E->context  : $unknown;
	    $line{$ident}      = $E->line;
	    $path{$ident}      = $E->path;
	    $conf{$ident}      = $E->conf ? $E->conf : undef;

	    if ( ref($E) eq "Error::Simple" or ref($E) eq "Luka::Error" ) {

		$text{$ident}       = $E->text       || $unknown;
		$stacktrace{$ident} = $E->stacktrace || $unknown;

	    } else {

		$text{$ident}       = $E->error || $unknown;
		$stacktrace{$ident} = $E->trace || $unknown;

	    }

	    # do we have syslogd running or not?
	    try {
	    #eval {
		#local $SIG{'__DIE__'}; # see "perldoc -f eval"
		openlog($filename{$ident}, "pid,noname", "daemon")
		    || die;
		syslog('info', "Luka initiating...") || die;
		$syslogd{$ident} = 1;
		open(BLA, '>> /tmp/log');
		print BLA "test try \n";
		close BLA;
	    #};
	    } catch Error with {
	    #if ($@ or $!) {
		my $e = shift;
		my $bla = Dumper $e;
		open(BLA2, '>> /tmp/log');
		print BLA2 "test catch\n";
		close BLA2;
		die "oops";
		$syslogd{$ident} = undef;
	    }

	    #===========================================================
	    # we had to delay seting of IP address, because of config
	    # object dependecy on possible optional 'conf' value passed
	    # to thrown Luka execptions.
	    #==========================================================
	    $luka_conf = Luka::Conf->new( conf => $conf{$ident}, syslogd => $syslogd{$ident} );
	    $ipaddr{$ident} = $unknown;
	    my ($name,$aliases,$addrtype,$length,@addrs) = gethostbyname($hostname{$ident});
	    # of all interfaces, use closest match to IP from the config
	    my $expected_ip = $luka_conf->get_conf('global','expected_ip');
	    for(0..$#addrs) {
		$addrs[$_] = inet_ntoa($addrs[$_]);
		# print $addrs[$_] . "\n";
		$ipaddr{$ident} = $addrs[$_] if $addrs[$_] =~ $expected_ip;
	    }

	} else { # success

	    my $caller = (caller(1))[1];
	    my ($vol,$dir,$file) = File::Spec->splitpath($caller);
	    $arg_ref->{'filename'} = $file;
 	    $filename{$ident} = $arg_ref->{'filename'};

	    # do we have syslogd running or not?
	    eval {
		openlog($filename{$ident}, "pid,noname", "daemon");
		syslog('info', "Luka initiating...");
	    };
	    if ($@) {
		$syslogd{$ident} = undef;
	    } else {
		$syslogd{$ident} = 1;
	    }

	    #===========================================================
	    # we had to delay seting of IP address, because of config
	    # object dependecy on possible optional 'conf' value passed
	    # to thrown Luka execptions.
	    #==========================================================
	    $luka_conf = Luka::Conf->new( syslogd => $syslogd{$ident} );
	    $ipaddr{$ident} = $unknown;
	    my ($name,$aliases,$addrtype,$length,@addrs) = gethostbyname($hostname{$ident});

	    # of all interfaces, use closest match to IP from the config
	    my $expected_ip = $luka_conf->get_conf('global','expected_ip');
	    for(0..$#addrs) {
		$addrs[$_] = inet_ntoa($addrs[$_]);
		# print $addrs[$_] . "\n";
		$ipaddr{$ident} = $addrs[$_] if $addrs[$_] =~ $expected_ip;
	    }

	    $text{$ident} = $luka_conf->get_conf( $arg_ref->{'filename'},'about' );
	}

	# reporting [delivery:email]
	$send_subj_success{$ident} = $luka_conf->get_conf( $arg_ref->{'filename'}, 'on_success');

	$send_to{$ident}     = $arg_ref->{'filename'} .
	    "@" . $luka_conf->get_conf('global','email_domain');

	$send_cc{$ident}     = $luka_conf->get_conf( $arg_ref->{'filename'}, 'cc');

	$send_from{$ident}   = $luka_conf->get_conf( $arg_ref->{'filename'}, 'from') ||
	    "root@" . $hostname_long{$ident};

	$doc_base{$ident}    = $luka_conf->get_conf('global','doc_base') . "/" .
	    $luka_conf->get_conf($arg_ref->{'filename'},'doc');

	if (defined $arg_ref->{'error'}) {
	    $doc_base{$ident} .=  "#" . $self->get_id;
	    $report_body_error{$ident} .= sprintf("%s=%s\n","host",$self->get_hostname_long eq "localhost" ?
						  $self->get_hostname : $self->get_hostname_long);
	    $report_body_error{$ident} .= sprintf("%s=%s\n","hosterr",$self->get_syslogd ? "" : "syslogd");
	    $report_body_error{$ident} .= sprintf("%s=%s\n","ipaddr",$self->get_ipaddr);
	    $report_body_error{$ident} .= sprintf("%s=%s\n","time",$self->get_local_date_time);
	    $report_body_error{$ident} .= sprintf("%s=%s\n","script",$arg_ref->{'filename'});
	    $report_body_error{$ident} .= sprintf("%s=%s\n","path", $self->get_path);
	    $report_body_error{$ident} .= sprintf("%s=%s\n","line",$self->get_line);
	    $report_body_error{$ident} .= sprintf("%s=%s\n","pid",$self->get_pid);
	    $report_body_error{$ident} .= sprintf("%s=%s\n","severity",$self->get_severity);
	    $report_body_error{$ident} .= sprintf("%s=%s\n","context",$self->get_context);
	    $report_body_error{$ident} .= sprintf("%s=%s\n","args",$self->get_args);
	    $report_body_error{$ident} .= sprintf("%s=%s\n","id",$self->get_id);
	    $report_body_error{$ident} .= sprintf("%s=%s\n\n","error",$self->get_text);
	    $report_body_error{$ident} .= sprintf("%s\n",$self->get_stacktrace);
	} else {
	    $report_body_success{$ident} .= sprintf("%s=%s\n","host",$self->get_hostname_long eq "localhost" ?
						    $self->get_hostname : $self->get_hostname_long)
	        . sprintf("%s=%s\n","hosterr",$self->get_syslogd ? "" : "syslogd")
		. sprintf("%s=%s\n","ipaddr",$self->get_ipaddr)
		. sprintf("%s=%s\n","time",$self->get_local_date_time)
		. sprintf("%s=%s\n","script",$arg_ref->{'filename'})
		. sprintf("%s=%s\n","pid",$self->get_pid);
	}

	$default_state_code_error{$ident}   = "E";
	$default_state_code_success{$ident} = "I";
	$state_code_error{$ident}           =
	    $luka_conf->get_conf('global','single_char_error_code');
	$state_code_success{$ident}         =
	    $luka_conf->get_conf('global','single_char_success_code');

	$debug{$ident}          = $luka_conf->get_conf('global','debug');
	$nomail{$ident}         = $luka_conf->get_conf($arg_ref->{'filename'},'nomail');
	$script_about{$ident}   = $luka_conf->get_conf($arg_ref->{'filename'},'about');
	$syslogopt{$ident}      = $luka_conf->get_conf('global','syslogopt');
	$syslogfacility{$ident} = $luka_conf->get_conf('global','syslogfacility');

	# what are the underlining Error class and text
	if ($debug{$ident} eq 1 && defined $arg_ref->{'error'} and defined($syslogd{$ident})) {
	    openlog( $filename{$ident}, $syslogopt{$ident}, $syslogfacility{$ident});
	    syslog('warning', "[$LukaDebug][class] %s", ref($arg_ref->{'error'}));
	    syslog('warning', "[$LukaDebug][text] %s", $self->get_text);
	    syslog('warning', "[$LukaDebug][context] %s", $self->get_context);
	    syslog('warning', "[$LukaDebug][args] %s", $self->get_args);
	    syslog('warning', "[$LukaDebug][id] %s", $self->get_id);
	    syslog('warning', "[$LukaDebug][hostname] %s", $self->get_hostname);
	    syslog('warning', "[$LukaDebug][ipaddres] %s", $self->get_ipaddr);
	    syslog('warning', "[$LukaDebug][hostname_long] %s", $self->get_hostname_long);
	}

    } # BUILD

    #======================
    # PUBLIC interface
    #======================
    sub report_error {
	my ($self,$message) = @_;
	$self->report("error",$message);
    }

    sub report_success {
	my ($self,$message) = @_;
	$self->report("success",$message);
    }
    #========================
    # PUBLIC interface ENDS
    #========================

    sub report : PRIVATE {
	my ($self,$mode,$message) = @_;

	openlog( $self->get_filename, $self->get_syslogopt, $self->get_syslogfacility )
	    if $self->get_syslogd;

	if ($mode eq "error" ) { # error mode

	    syslog('warning', "Error at line %s: %s", $self->get_line, $self->get_text)
		if $self->get_syslogd;

	} else { 	         # success mode

	    if ($message) {
		$self->set_text($message);
	    } else {
		$self->set_text($self->get_send_subj_success);
	    }

	}

	if (not $self->get_nomail) {

	    my $mess = Luka::Mailer->new
		( to         => $self->get_send_to,
		  cc         => $self->get_send_cc,
		  subject    => sprintf("[%s][%s][%s] %s",
					$self->get_hostname,
					$self->get_local_date_time,
					$self->get("state_code",$mode) ||
					$self->get("default_state_code",$mode),
 					    $self->get_text),
		  from       => $self->get_send_from,
		  body       => $self->get_script_about . "\n\n" .
		  $self->get_doc_base . "\n\n" .
		  $self->get("report_body",$mode) . "\n\n",
		  );

	    if (not $mess->send("Report emailed to recepients.\n")) {

		if ($self->get_syslogd) {

		    syslog('warning', "Couldn't report by email: to: %s, cc: %s, from: %s",
			   $self->get_send_to, $self->get_send_cc, $self->get_send_from);
		    syslog('warning', "Mail system reported: %s", $mess->error);

		}

		warn( "Couldn't report by email to:" . $self->get_send_to . ";cc:" .
		      $self->get_send_cc . ";from:" . $self->get_send_from  . "\n");
	    } else {

		syslog( 'info', ucfirst($mode) . " report sent to " .
			$self->get_send_to . ","  . $self->get_send_cc )
		    if $self->get_syslogd;

	    }

	} # if nomail

	closelog() if $self->get_syslogd;

    } # sub _report

}

1;

__END__