Update Module::Load::Conditional to CPAN version 0.38

[p5sagit/p5-mst-13.2.git] / cpan / Sys-Syslog / win32 / Win32.pm

package Sys::Syslog::Win32;
use strict;
use warnings;
use Carp;
use File::Spec;

# === WARNING === WARNING === WARNING === WARNING === WARNING === WARNING ===
#
# This file was generated by Sys-Syslog/win32/compile.pl on Wed Aug 22 01:33:58 2007
# Any changes being made here will be lost the next time Sys::Syslog 
# is installed. 
#
# Do NOT USE THIS MODULE DIRECTLY: this is a utility module for Sys::Syslog.
# It may change at any time to fit the needs of Sys::Syslog therefore no 
# warranty is made WRT to its API. You Have Been Warned.
#
# === WARNING === WARNING === WARNING === WARNING === WARNING === WARNING ===

our $Source;
my $logger;
my $Registry;

use Win32::EventLog;
use Win32::TieRegistry 0.20 (
    TiedRef     => \$Registry,
    Delimiter   => "/",
    ArrayValues => 1,
    SplitMultis => 1,
    AllowLoad   => 1,
    qw(
        REG_SZ
        REG_EXPAND_SZ
        REG_DWORD
        REG_BINARY
        REG_MULTI_SZ
        KEY_READ
        KEY_WRITE
        KEY_ALL_ACCESS
    ),
);    

my $is_Cygwin = $^O =~ /Cygwin/i;
my $is_Win32  = $^O =~ /Win32/i;

my %const = (
    CAT_KERN => 1,
    CAT_USER => 2,
    CAT_MAIL => 3,
    CAT_DAEMON => 4,
    CAT_AUTH => 5,
    CAT_SYSLOG => 6,
    CAT_LPR => 7,
    CAT_NEWS => 8,
    CAT_UUCP => 9,
    CAT_CRON => 10,
    CAT_AUTHPRIV => 11,
    CAT_FTP => 12,
    CAT_LOCAL0 => 13,
    CAT_LOCAL1 => 14,
    CAT_LOCAL2 => 15,
    CAT_LOCAL3 => 16,
    CAT_LOCAL4 => 17,
    CAT_LOCAL5 => 18,
    CAT_LOCAL6 => 19,
    CAT_LOCAL7 => 20,
    CAT_NETINFO => 21,
    CAT_REMOTEAUTH => 22,
    CAT_RAS => 23,
    CAT_INSTALL => 24,
    CAT_LAUNCHD => 25,
    CAT_CONSOLE => 26,
    CAT_NTP => 27,
    CAT_SECURITY => 28,
    CAT_AUDIT => 29,
    CAT_LFMT => 30,
    MSG_KERNEL => 128,
    MSG_USER => 129,
    MSG_MAIL => 130,
    MSG_DAEMON => 131,
    MSG_AUTH => 132,
    MSG_SYSLOG => 133,
    MSG_LPR => 134,
    MSG_NEWS => 135,
    MSG_UUCP => 136,
    MSG_CRON => 137,
    MSG_AUTHPRIV => 138,
    MSG_FTP => 139,
    MSG_LOCAL0 => 140,
    MSG_LOCAL1 => 141,
    MSG_LOCAL2 => 142,
    MSG_LOCAL3 => 143,
    MSG_LOCAL4 => 144,
    MSG_LOCAL5 => 145,
    MSG_LOCAL6 => 146,
    MSG_LOCAL7 => 147,
    MSG_NETINFO => 148,
    MSG_REMOTEAUTH => 149,
    MSG_RAS => 150,
    MSG_INSTALL => 151,
    MSG_LAUNCHD => 152,
    MSG_CONSOLE => 153,
    MSG_NTP => 154,
    MSG_SECURITY => 155,
    MSG_AUDIT => 156,
    MSG_LFMT => 157,
    STATUS_SEVERITY_SUCCESS => 0,
    STATUS_SEVERITY_INFORMATIONAL => 1,
    STATUS_SEVERITY_WARNING => 2,
    STATUS_SEVERITY_ERROR => 3,

);

my %id2name = (
    Sys::Syslog::LOG_KERN() => 'KERN',
    Sys::Syslog::LOG_USER() => 'USER',
    Sys::Syslog::LOG_MAIL() => 'MAIL',
    Sys::Syslog::LOG_DAEMON() => 'DAEMON',
    Sys::Syslog::LOG_AUTH() => 'AUTH',
    Sys::Syslog::LOG_SYSLOG() => 'SYSLOG',
    Sys::Syslog::LOG_LPR() => 'LPR',
    Sys::Syslog::LOG_NEWS() => 'NEWS',
    Sys::Syslog::LOG_UUCP() => 'UUCP',
    Sys::Syslog::LOG_CRON() => 'CRON',
    Sys::Syslog::LOG_AUTHPRIV() => 'AUTHPRIV',
    Sys::Syslog::LOG_FTP() => 'FTP',
    Sys::Syslog::LOG_LOCAL0() => 'LOCAL0',
    Sys::Syslog::LOG_LOCAL1() => 'LOCAL1',
    Sys::Syslog::LOG_LOCAL2() => 'LOCAL2',
    Sys::Syslog::LOG_LOCAL3() => 'LOCAL3',
    Sys::Syslog::LOG_LOCAL4() => 'LOCAL4',
    Sys::Syslog::LOG_LOCAL5() => 'LOCAL5',
    Sys::Syslog::LOG_LOCAL6() => 'LOCAL6',
    Sys::Syslog::LOG_LOCAL7() => 'LOCAL7',
    Sys::Syslog::LOG_NETINFO() => 'NETINFO',
    Sys::Syslog::LOG_REMOTEAUTH() => 'REMOTEAUTH',
    Sys::Syslog::LOG_RAS() => 'RAS',
    Sys::Syslog::LOG_INSTALL() => 'INSTALL',
    Sys::Syslog::LOG_LAUNCHD() => 'LAUNCHD',
    Sys::Syslog::LOG_CONSOLE() => 'CONSOLE',
    Sys::Syslog::LOG_NTP() => 'NTP',
    Sys::Syslog::LOG_SECURITY() => 'SECURITY',
    Sys::Syslog::LOG_AUDIT() => 'AUDIT',
    Sys::Syslog::LOG_LFMT() => 'LFMT',

);

my @priority2eventtype = (
    EVENTLOG_ERROR_TYPE(),       # LOG_EMERG
    EVENTLOG_ERROR_TYPE(),       # LOG_ALERT
    EVENTLOG_ERROR_TYPE(),       # LOG_CRIT
    EVENTLOG_ERROR_TYPE(),       # LOG_ERR
    EVENTLOG_WARNING_TYPE(),     # LOG_WARNING
    EVENTLOG_WARNING_TYPE(),     # LOG_NOTICE
    EVENTLOG_INFORMATION_TYPE(), # LOG_INFO
    EVENTLOG_INFORMATION_TYPE(), # LOG_DEBUG
);


# 
# _install()
# --------
# Used to set up a connection to the eventlog.
# 
sub _install {
    return $logger if $logger;

    # can't just use basename($0) here because Win32 path often are a 
    # a mix of / and \, and File::Basename::fileparse() can't handle that, 
    # while File::Spec::splitpath() can.. Go figure..
    my (undef, undef, $basename) = File::Spec->splitpath($0);
    ($Source) ||= $basename;
    
    $Source.=" [SSW:1.0.1]";

    #$Registry->Delimiter("/"); # is this needed?
    my $root = 'LMachine/SYSTEM/CurrentControlSet/Services/Eventlog/Application/';
    my $dll  = 'Sys/Syslog/PerlLog.dll';

    if (!$Registry->{$root.$Source} || 
        !$Registry->{$root.$Source.'/CategoryMessageFile'}[0] ||
        !-e $Registry->{$root.$Source.'/CategoryMessageFile'}[0] ) 
    {

        # find the resource DLL, which should be along Syslog.dll
        my ($file) = grep { -e $_ }  map { ("$_/$dll" => "$_/auto/$dll") }  @INC;
        $dll = $file if $file;

        # on Cygwin, convert the Unix path into absolute Windows path
        if ($is_Cygwin) {
            if ($] > 5.009005) {
                chomp($file = Cygwin::posix_to_win_path($file, 1));
            }
            else {
                local $ENV{PATH} = '';
                chomp($dll = `/usr/bin/cygpath --absolute --windows "$dll"`);
            }
        }

        $dll =~ s![\\/]+!\\!g;     # must be backslashes!
        die "fatal: Can't find resource DLL for Sys::Syslog\n" if !$dll;

        $Registry->{$root.$Source} = {
            '/EventMessageFile'    => [ $dll, REG_EXPAND_SZ ],
            '/CategoryMessageFile' => [ $dll, REG_EXPAND_SZ ],
            '/CategoryCount'       => [ '0x0000001e', REG_DWORD ],
            #'/TypesSupported'      => [ '0x0000001e', REG_DWORD ],
        };

        warn "Configured eventlog to use $dll for $Source\n" if $Sys::Syslog::DEBUG;
    }

    #Carp::confess("Registry has the wrong value for '$Source', possibly mismatched dll!\nMine:$dll\nGot :$Registry->{$root.$Source.'/CategoryMessageFile'}[0]\n")
    #    if $Registry->{$root.$Source.'/CategoryMessageFile'}[0] ne $dll;

    # we really should do something useful with this but for now
    # we set it to "" to prevent Win32::EventLog from warning
    my $host = "";

    $logger = Win32::EventLog->new($Source, $host) 
        or Carp::confess("Failed to connect to the '$Source' event log");

    return $logger;
}


# 
# _syslog_send()
# ------------
# Used to convert syslog messages into eventlog messages
# 
sub _syslog_send {
    my ($buf, $numpri, $numfac) = @_;
    $numpri ||= EVENTLOG_INFORMATION_TYPE();
    $numfac ||= Sys::Syslog::LOG_USER();
    my $name = $id2name{$numfac};

    my $opts = {
        EventType   => $priority2eventtype[$numpri], 
        EventID     => $const{"MSG_$name"},
        Category    => $const{"CAT_$name"}, 
        Strings     => "$buf\0", 
        Data        => "",
    };

    if ($Sys::Syslog::DEBUG) {
        require Data::Dumper;
        warn Data::Dumper->Dump(
            [$numpri, $numfac, $name, $opts], 
            [qw(numpri numfac name opts)]
        );
    }

    return $logger->Report($opts);
}


=head1 NAME

Sys::Syslog::Win32 - Win32 support for Sys::Syslog

=head1 DESCRIPTION

This module is a back-end plugin for C<Sys::Syslog>, for supporting the Win32 
event log. It is not expected to be directly used by any module other than 
C<Sys::Syslog> therefore it's API may change at any time and no warranty is 
made with regards to backward compatibility. You Have Been Warned. 

=head1 SEE ALSO

L<Sys::Syslog>

=head1 AUTHORS

SE<eacute>bastien Aperghis-Tramoni and Yves Orton

=head1 LICENSE

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

1;