File Coverage

blib/lib/Carp/Notify.pm

Criterion	Covered	Total	%
statement	91	203	44.8
branch	29	104	27.8
condition	0	17	0.0
subroutine	13	19	68.4
pod	8	11	72.7
total	141	354	39.8

package Carp::Notify;
{
  $Carp::Notify::VERSION = '1.11';
}

# ABSTRACT: Loudly complain in lots of places when things break badly

use 5.005; # probably lower, but I haven't tested it below 005
use strict;
local $^W = 1;

my %def = (
    "smtp"   => 'your.smtp.com', # IMPORTANT!  Set this!  I mean it!
    "domain" => 'smtp.com',      # IMPORTANT!  Set this!  I mean it!
    "port"   => 25,

    "email_it" => 1,                       # should we email by default? true/false
    "email"    => '[e-mail]', # who are we emailing by default?
    "return"   => '[e-mail]', # who is the error coming from?
    "subject"  => 'Ye Gods!  An error!',

    "log_it"   => 1,                # should we log by default?
    "log_file" => '/tmp/error.log', # default error log for notifys and explodes

    "log_explode" => 0,                  # should we log explodes by default?
    "explode_log" => '/tmp/explode.log', # default error log for explodes ONLY

    "log_notify" => 0,                 # should we log notifys by default?
    "notify_log" => '/tmp/notify.log', # default error log for notifys ONLY

    "store_vars"  => 1, # should we store variables by default? true/false
    "stack_trace" => 1, # should we do a stack trace by default? true/false
    "store_env"   => 1, # should we store our environment by default? true/false

    "die_to_stdout"  => 0, # should we send our death_message to STDOUT by default? true/false
    "die_everywhere" => 0, # should we send our death_message to STDOUT and STDERR by default? true/false
    "die_quietly"    => 0, # should we not print our death_message anywhere?  true/false

    "error_function" => '', # function to call if Carp::Notify encounters an error
    "death_function" => '', # function to call upon termination, used in place of death_message

    # What would you like to die with?  This is probably the message that's going to your user in
    # his browser, so make it something nice.  You'll have to set the content type yourself, though.
    # Why's that, you ask?  I wanted to be sure that you had the option of easily redirecting to
    # a different page if you'd prefer.

    "death_message"   => <<'eoE'
Content-type:text/plain\n\n

We're terribly sorry, but some horrid internal error seems to have occurred.  We are actively
looking into the problem and hope to repair the error shortly.  We're sorry for any inconvenience.

eoE
);
# end defaults.  Don't mess with anything else! I mean it!

my $settables = "(?:" . join('|', keys %def) . ')';

BEGIN {
    $Carp::Notify::can_email = 1;
    eval "use Socket";
    $Carp::Notify::can_email = 0 if $@;

    $Carp::Notify::fatal = 1; # doesn't really belong here, but it's the cleanest place to put it...
};


{
    no strict 'refs';
    my $calling_package = undef;

    my %storable_vars = ();

    my @storable_vars = ();
    my %init = ();

    sub import {
        my ($package, $file, $line) = caller;
        $calling_package = $package;

        *{$package . "::explode"} = \&Carp::Notify::explode;
        *{$package . "::notify"} = \&Carp::Notify::notify;

        while (defined (my $var = shift)){
            if ($var eq ""){die ("Error...tried to import undefined value in $file, Line $line\n")};

            if ($var =~ /^$settables$/o){
                $def{$var} = shift;
                next;
            };

            push @storable_vars, $var if $var =~ /^[\$@%&]/;
            push @{$storable_vars{$calling_package}}, $var if $var =~ /^[\$@%&]/;

            # see if we want to overload croak or export anything while we're at it.

            *{$package . "::croak"}           = \&Carp::Notify::explode if $var eq "croak";
            *{$package . "::carp"}            = \&Carp::Notify::notify if $var eq "carp";
            *{$package . "::make_storable"}   = \&Carp::Notify::make_storable if $var eq "make_storable";
            *{$package . "::make_unstorable"} = \&Carp::Notify::make_unstorable if $var eq "make_unstorable";
        };
    };

    sub store_vars {
        my $stored_vars = "";
        my $calling_package = (caller(1))[0]; # eek!  This may not always work

        foreach my $storable_var (@{$storable_vars{$calling_package}}){
            my $type = $1 if $storable_var =~ s/([\$@%&])//;

            my $package = $calling_package . "::";
            $package = $1 if $storable_var =~ s/(.+::)//;

            if ($type eq '$') {
                my $storable_val = ${$package . "$storable_var"};
                $stored_vars .= "\t\$${package}$storable_var : $storable_val\n";next;
            }
            elsif ($type eq '@') {
                my @storable_val = @{$package . "$storable_var"};
                $stored_vars .= "\t\@${package}$storable_var : (@storable_val)\n";next;
            }
            elsif ($type eq '%') {
                my %temp_hash = %{$package . "$storable_var"};
                my @storable_val =  map {"\n\t\t$_ => $temp_hash{$_}"} keys %temp_hash;
                $stored_vars .= "\t\%${package}$storable_var : @storable_val\n";next;
            }
            elsif ($type eq '&'){
                my $storable_val = &{$package . "$storable_var"};
                $stored_vars .= "\t\&${package}$storable_var : $storable_val\n";next;
            };
        };

        return $stored_vars;
    };

    sub make_storable {
        foreach my $var (@_){
            push @storable_vars, $var if $var =~ /^[\$@%&]/;;
        };
        return 1;
    };

    sub make_unstorable {
        my $no_store = join("|", map {quotemeta} @_);
        @storable_vars = grep {!/^(?:$no_store)$/} @storable_vars;
        return 1;
    };

    # hee hee!  Remember, a notification is just an explosion that isn't fatal.  So we use our nifty handy dandy
    # fatal class variable to tell explode that it's not a fatal error.  explode() will set fatal back to 1 once
    # it realizes that errors are non-fatal.  That way a future explosion will still be fatal.
    #
    # and then goto &explode makes perl think it just started at the explode function.  Even caller can't catch it!
    sub notify {
        $Carp::Notify::fatal = 0;
        goto &explode;
    };

    sub explode {
        my $errors = undef;

        my %init = ();

        while (defined (my $arg = shift)) {
            if ($arg =~ /^$settables$/o){
                $init{$arg} = shift;
            }
            else {$errors .= "\t$arg\n"};
        };

        %init = (%def, %init);

        my $stored_vars = store_vars()  if $init{'store_vars'};
        my $stack       = stack_trace() if $init{'stack_trace'};
        my $environment = store_env()   if $init{'store_env'};

        my $message = "";

        my $method = $Carp::Notify::fatal ? 'explosion' : 'notification';

        $message .= "An error via $method occurred on " . today() . "\n";

        $message .= "\n>>>>>>>>>\nERROR MESSAGES\n>>>>>>>>>\n\n$errors\n<<<<<<<<<\nEND ERROR MESSAGES\n<<<<<<<<<\n"          if $errors;
        $message .= "\n>>>>>>>>>\nSTORED VARIABLES\n>>>>>>>>>\n\n$stored_vars\n<<<<<<<<<\nEND STORED VARIABLES\n<<<<<<<<<\n" if $stored_vars;
        $message .= "\n>>>>>>>>>\nCALL STACK TRACE\n>>>>>>>>>\n\n$stack\n<<<<<<<<<\nEND CALL STACK TRACE\n<<<<<<<<<\n"       if $init{'stack_trace'};
        $message .= "\n>>>>>>>>>\nENVIRONMENT\n>>>>>>>>>\n\n$environment\n<<<<<<<<<\nEND ENVIRONMENT\n<<<<<<<<<\n"           if $init{'store_env'};

        log_it(
            "log_it"         => $init{'log_it'},
            "log_file"       => $init{'log_file'},

            "log_explode"    => $Carp::Notify::fatal && $init{"log_explode"} ? $init{"log_explode"} : 0,
            "explode_log"    => $init{'explode_log'},

            "log_notify"     => ! $Carp::Notify::fatal && $init{"log_notify"} ? $init{"log_notify"} : 0,
            "notify_log"     => $init{"notify_log"},

            "message"        => $message,
            "error_function" => $init{'error_function'}
        );

        simple_smtp_mailer(
            "email"          => $init{'email'},
            "return"         => $init{'return'},
            "message"        => $message,
            "subject"        => $init{'subject'},
            "smtp"           => $init{'smtp'},
            "port"           => $init{'port'},
            "error_function" => $init{'error_function'}
        ) if $init{'email_it'};

        if ($Carp::Notify::fatal){
            if ($init{'die_quietly'}){
                exit;
            }
            elsif ($init{'death_function'}){
                if (ref $init{'death_function'} eq 'CODE'){
                    $init{'death_function'}->(%init, 'errors' => $errors);
                }
                else {
                    no strict 'vars';
                    my ($calling_package) = (caller)[0];
                    my $package = $calling_package . "::";
                    $package = $1 if $init{'death_function'} =~ s/(.+::)//;
                    $init{'death_function'} =~ s/^&//;
                    &{$package . $init{'death_function'}}(%init, 'errors' => $errors);
                    exit;
                };
            }
            else {
                if ($init{'die_to_stdout'}){
                    print STDERR $init{'death_message'} if $init{'die_everywhere'};
                    print $init{'death_message'};
                    exit;
                }
                else {
                    print $init{'death_message'} if $init{'die_everywhere'};
                    die $init{'death_message'};
                };
            };
        }
        else {
            $Carp::Notify::fatal = 1;
            return undef;
        };
    };
};


# psst!  If you're looking for store_vars, it's up at the top wrapped up with import!

sub store_env {
    my $env = '';
    foreach (sort keys %ENV){
        $env .= "\t$_ : $ENV{$_}\n";
    };
    return $env;
};

sub stack_trace {
    my $caller_count = 1;
    my $caller_stack = undef;
    my @verbose_caller = ("Package: ", "Filename: ", "Line number: ", "Subroutine: ", "Has Args? : ", "Want array? : ", "Evaltext: ", "Is require? : ");

    push @verbose_caller, ("Hints:  ", "Bitmask:  ") if $] >= 5.006; # 5.6 has a more verbose caller stack.

    while (my @caller = caller($caller_count++)){
        $caller_stack .= "\t---------\n";
        foreach (0..$#caller){
            $caller_stack .= "\t\t$verbose_caller[$_]$caller[$_]\n" if $caller[$_];
        };
    };

    $caller_stack .= "\t---------\n";
    return $caller_stack;
};

sub log_it {
    my %init = @_;

    my $message  = $init{message};

    local *LOG;
    my %pairs = (
        "log_notify"  => "notify_log",
        "log_explode" => "explode_log",
        "log_it"      => "log_file"
    );

    foreach my $permission (grep {$init{$_}} keys %pairs) {
        my $file = $init{$pairs{$permission}};
        if (ref $file){
            print $file "\n__________________\n$message\n__________________\n";
        }
        else {
            open (LOG, ">>$file") or error($init{'error_function'},"Cannot open log file: $!");
            print LOG "\n__________________\n$message\n__________________\n";
            close LOG or error($init{'error_function'},"Cannot close log file: $!");
        };
    };
};

sub simple_smtp_mailer {
    my %init = @_;
    my $message = $init{"message"};
    error($init{'error_function'},"Cannot email: Socket.pm could not load!") unless $Carp::Notify::can_email;

    local *MAIL;
    my $response = undef;
    my ($s_tries, $c_tries) = (5, 5);
    local $\ = "\015\012";
    local $/ = "\015\012";

    # connect to the server
    1 while ($s_tries-- && ! socket(MAIL, PF_INET, SOCK_STREAM, getprotobyname('tcp')));
    return error($init{'error_function'}, "Socket error $!") if $s_tries < 0;

    my $remote_address = inet_aton($init{'smtp'});
    my $paddr = sockaddr_in($init{'port'}, $remote_address);
    1 while ! connect(MAIL, $paddr) && $c_tries--;
    return error($init{'error_function'}, "Connect error $!") if $c_tries < 0;

    # keep our bulk pipes piping hot.
    select((select(MAIL), $| = 1)[0]);
    # connected

    # build the envelope
    my @conversation =
        (
            ["", "No response from server: ?"],
            ["HELO $def{'domain'}", "Mean ole' server won't say HELO: ?"],
            ["RSET", "Cannot reset connection: ?"],
            ["MAIL FROM:<$def{'return'}>", "Invalid Sender: ?"],
            ["RCPT TO:<$init{'email'}>", "Invalid Recipient: ?"],
            ["DATA", "Not ready to accept data: ?"]
        );

    while (my $array_ref = shift @conversation){
        my ($i_say, $i_die) = @{$array_ref};
        print MAIL $i_say if $i_say;
        my $response =  || "";

        if (! $response || $response =~ /^[45]/){
            $i_die =~ s/\?/$response/;
            return error($init{'error_function'}, $i_die);
        };
        return error($init{'error_function'}, "Server disconnected: $response") if $response =~ /^221/;

    };
    # built

    # send the data
    print MAIL "Date: ", today();
    print MAIL "From: $init{'return'}";
    print MAIL "Subject: $init{'subject'}";
    print MAIL "To: $init{'email'}";
    print MAIL "X-Priority:2  (High)";
    print MAIL "X-Carp-Notify: $Carp::Notify::VERSION";

    print MAIL "";

    $message =~ s/^\./../gm;
    $message =~ s/(\r?\n|\r)/\015\012/g;

    print MAIL $message;

    print MAIL ".";
    # sent

    return 1; # yay!
};

sub today {
    my @months = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
    my @days   = qw(Sun Mon Tue Wed Thu Fri Sat);

    my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = localtime(time);
    $year += 1900;
    my ($gmin, $ghour, $gsdst) = (gmtime(time))[1,2, -1];

    my $diffhour = $hour - $ghour;
    $diffhour = 12 - $diffhour if $diffhour > 12;
    $diffhour = 12 + $diffhour if $diffhour < -12;

    ($diffhour = sprintf("%03d", $diffhour)) =~ s/^0/\+/;

    return sprintf("%s, %02d %s %04d %02d:%02d:%02d %05s",
        $days[$wday], $mday, $months[$mon], $year + 1900, $hour, $min, $sec, $diffhour . sprintf("%02d", $min - $gmin));
};

# error does nothing unless you specify the error_function, in that case it's called with the error provided.
sub error {
    my ($func, $error) = @_;
    if (ref $func eq 'CODE'){
        $func->($error);
    }
    elsif ($func){
        no strict 'refs';
        my ($calling_package) = (caller)[0];
        my $package = $calling_package . "::";
        $package = $1 if $$func =~ s/(.+::)//;
        &{$package . $func}($error);
    }
    else {undef};
};


1;

__END__