Win32::EventLog::Carp - for carping in the Windows NT Event Log

  Carp
  Win32::EventLog

  use Win32::EventLog::Carp;
  croak "We're outta here!";

  use Win32::EventLog::Carp qw(cluck);
  cluck "This is how we got here!";

  Win32::EventLog::Carp::click "Hello!\n";

  use CGI::Carp;
  use Win32::EventLog::Carp

  BEGIN
    {
      $SIG{__WARN__} = \&my_handler;
    }

  use Win32::EventLog::Carp

  use Win32::EventLog::Carp
        {
          LogEvals => 1
        };

  $Win32::EventLog::Carp::LogEvals = 1;

  carp "Hello";

  Hello at script.pl line 10

  The description for Event ID ( 0 ) in Source ( script.pl ) could
  not be found. It contains the following insertion string(s): Hello
  at script.pl line 10.

  use Win32::EventLog::Carp qw(cluck carp croak click confess),
        {
          Source => 'MyProject'
        };

  use Win32::EventLog::Carp 1.40
        {
          Register => 'System'
        };

  perl -MCarp=verbose script.pl

  require Win32;

  if (Win32::IsWinNT) {
    require Win32::EventLog::Carp;
    import Win32::EventLog::Carp 1.31;
  }
  else {
    require Carp;
    import Carp;
  }

  Carp
  Win32::EventLog
  Win32::EventLog::Message

  CGI::Carp
  Log::Dispatch::Win32EventLog
  Tk::Carp
  Win32::GUI::Carp
  Wx::Perl::Carp

package Win32::EventLog::Carp;

use strict;

# use warnings;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $LogEvals);

require Exporter;

@ISA       = qw( Exporter );
@EXPORT    = qw( confess carp croak );
@EXPORT_OK = qw( cluck click register_source );

$VERSION = '1.42';

require Carp;
require Carp::Heavy;

use File::Basename;
use File::Spec;

use Win32::EventLog qw(
  EVENTLOG_INFORMATION_TYPE EVENTLOG_WARNING_TYPE EVENTLOG_ERROR_TYPE
  EVENTLOG_AUDIT_SUCCESS EVENTLOG_AUDIT_FAILURE
);

my ( $EventLogHandle, $Source, $SourceFileName, $Register );

# We want to provide options on the 'use Win32::EventLog::Carp' line

sub import {
    my $package = shift;

    my @exports = grep { "HASH" ne ref($_) } @_;
    my @options = grep { "HASH" eq ref($_) } @_;

    foreach (@options) {
        $Source   = $_->{Source};      # Source name (defaults to script name)
        $LogEvals = $_->{LogEvals};    # Do we log evals when they fail?
        $Register = $_->{Register};    # Should we register the source?
    }

    if ($Register) {
        register_source( $Register, $Source );
    }

    @_ = ( $package, @exports );
    goto &Exporter::import;
}

sub register_source

  # If the Win32::EventLog::Message module is available, register the source
  # with the Windows NT event log (this only works if the user has the proper
  # permissions). This removes the 'description not found' warning in when
  # looking at the event in the event log viewer.

  # Needs to check if a log is created, and if so, close it and then reopen it.

{
    my ( $log_name, $source_name ) = @_;

    # Really what we need to do is to check if the source is registered
    # first...

    my $aux = $LogEvals;
    $LogEvals = 0;    # save LogEvals
    eval {
        require Win32::EventLog::Message;
        import Win32::EventLog::Message;
        Win32::EventLog::Message::RegisterSource( $log_name, $source_name );
    };
    $LogEvals = $aux;    # restore LogEvals

    if ($@) {
        CORE::warn
          "Unable to register source \`$source_name\' in \`$log_name\' log";
    }
}

sub _report

  # Reports an event in the Windows NT event log.

{
    unless ($EventLogHandle) {

        # Create a handle to the Windows NT event log (we do this in the BEGIN
        # block so that we can trap some compilation errors).

        my $log = ($Register) ? $Source : "Application";

        $EventLogHandle = Win32::EventLog->new( $log, Win32::NodeName )
          or CORE::die "Unable to initialize Windows NT event log";

    }

    # If for some reason the log isn't initialized...!

    unless ( defined $EventLogHandle ) {
        CORE::die "Win32::EventLog not initialized in Win32::EventLog::Carp";
        return;
    }

    my ( $event_type, $event_text ) = @_;

    unless ( ( defined $event_text ) && ( defined $event_type ) ) {
        return;
    }

    # If we're posting to the security log, convert the event types to
    # ones associated with the security log. (In reality, Windows
    # doesn't seem to care, but we want to play nice...)

    if ( ( $Register || "" ) eq "Security" ) {
        if ( $event_type == EVENTLOG_INFORMATION_TYPE ) {
            $event_type = EVENTLOG_AUDIT_SUCCESS;
        }
        else {
            $event_type = EVENTLOG_AUDIT_FAILURE;
        }
    }

    # Change newlines to semicolons ('; ') since they do not show up well in
    # the event log viewer (does Windows 2000 handle newlines better?)

    $event_text = join( ": ", $SourceFileName, $event_text );

    #     $event_text =~ s/\x0/; /g;                # only one string is used
    $event_text =~ s/(\r?\n){1,}(?!\z)/\; /g;
    $event_text =~ s/\r?\n\z//;

    my $event = {
        Computer  => Win32::NodeName,
        Source    => $Source,
        EventID   => 0,
        Category  => 0,
        EventType => $event_type,
        Strings   => $event_text,
        Data      => "",
    };

    $EventLogHandle->Report($event);
}

# Test to see if we're in an eval { }

sub _ineval {
    if ($LogEvals)    # If $LogEvals is true, lie and say we're never in an eval
    {
        return;
    }
    else              # Otherwise actually do a test
    {

        # This test is based on the one used in CGI::Carp v1.20
        return ( Carp::longmess(@_) =~ /eval [\'\{]/m );
    }
}

# Our own verson of "warn"

sub _warn {
    _report( EVENTLOG_WARNING_TYPE, @_ );
    CORE::warn @_;
}

# Our own version of "die"

sub _die {
    unless ( _ineval @_ )    # don't log it if we're in an eval
    {
        _report( EVENTLOG_ERROR_TYPE, @_ );
    }
    CORE::die @_;
}

BEGIN {

    # These are hooks for defining our own Source and Log

    $SourceFileName = File::Spec->rel2abs($0);

    unless ($Source) {

        # We use the basename of the file because registry keys cannot have
        # slashes in them. Of course since we are registering an event source
        # (only if we have admin privs) we'll include the full patch in the
        # event text (after all, an error in 'index.pl' doesn't tell us which
        # one).

        $Source = File::Basename::basename($SourceFileName);
    }

    # If there's already a handler, we just report the error to the log and
    # go to the existing handler (so we assume the other handler does what
    # it should); otherwise we use our own.

    if ( $SIG{__WARN__} ) {
        my $previous = $SIG{__WARN__};
        $SIG{__WARN__} = sub {
            _report( EVENTLOG_WARNING_TYPE, @_ );
            return &$previous;
        };
    }
    else {
        $SIG{__WARN__} = \&Win32::EventLog::Carp::_warn;
    }

    # Likewise for "die", we put ourselves between an existing signal handler
    # rather than take it over.

    if ( $SIG{__DIE__} ) {
        my $previous = $SIG{__DIE__};
        $SIG{__DIE__} = sub {
            unless ( _ineval(@_) ) {
                _report( EVENTLOG_ERROR_TYPE, @_ );
            }
            return &$previous;
        };
    }
    else {
        $SIG{__DIE__} = \&Win32::EventLog::Carp::_die;
    }

}

# Close the event log.

sub _closelog() {
    if ($EventLogHandle) {
        $EventLogHandle->Close();
        $EventLogHandle = undef;
    }
}

END {

    # Make sure we clean up after ourselves!
    _closelog();
}

# Our own versions of Carp's functions ... we piggyback on Carp's special
# "longmess" and shortmess" functions. (According to some discussion on
# the Perl 5 Porters list in July 2001 these may be renamed to "yodel" and
# "yelp", but with aliases for the old names. Don't panic.)

sub carp    { CORE::warn Carp::shortmess @_; }
sub croak   { CORE::die Carp::shortmess @_; }
sub cluck   { CORE::warn Carp::longmess @_; }
sub confess { CORE::die Carp::longmess @_; }

# Since posting diagnostic (non-warning/error) messages into the event log
# is useful, why not a function that simply reports to the log and STDERR
# without being considered an error? Hence, "click".

sub click {
    my $message = Carp::shortmess(@_);
    &_report( EVENTLOG_INFORMATION_TYPE, $message );
    print STDERR $message;
}

1;
__END__