|
Packit |
972a07 |
#!perl
|
|
Packit |
972a07 |
use strict;
|
|
Packit |
972a07 |
use warnings;
|
|
Packit |
972a07 |
use File::Basename;
|
|
Packit |
972a07 |
use File::Copy;
|
|
Packit |
972a07 |
use File::Path;
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
my $name = shift || 'PerlLog';
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
# get the version from the message file
|
|
Packit |
972a07 |
open(my $msgfh, '<', "$name.mc") or die "fatal: Can't read file '$name.mc': $!\n";
|
|
Packit |
972a07 |
my $top = <$msgfh>;
|
|
Packit |
972a07 |
close($msgfh);
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
my ($version) = $top =~ /Sys::Syslog Message File (\d+\.\d+\.\d+)/
|
|
Packit |
972a07 |
or die "error: File '$name.mc' doesn't have a version number\n";
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
# compile the message text files
|
|
Packit |
972a07 |
system("mc -d $name.mc");
|
|
Packit |
972a07 |
system("rc $name.rc");
|
|
Packit |
972a07 |
system(qq{ link -nodefaultlib -incremental:no -release /nologo -base:0x60000000 }
|
|
Packit |
972a07 |
.qq{ -comment:"Perl Syslog Message File v$version" }
|
|
Packit |
972a07 |
.qq{ -machine:i386 -dll -noentry -out:$name.dll $name.res });
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
# uuencode the resource file
|
|
Packit |
972a07 |
open(my $rsrc, '<', "$name.RES") or die "fatal: Can't read resource file '$name.RES': $!";
|
|
Packit |
972a07 |
binmode($rsrc);
|
|
Packit |
972a07 |
my $uudata = pack "u", do { local $/; <$rsrc> };
|
|
Packit |
972a07 |
close($rsrc);
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
open(my $uufh, '>', "$name\_RES.uu") or die "fatal: Can't write file '$name\_RES.uu': $!";
|
|
Packit |
972a07 |
print $uufh $uudata;
|
|
Packit |
972a07 |
close($uufh);
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
# uuencode the DLL
|
|
Packit |
972a07 |
open(my $dll, '<', "$name.dll") or die "fatal: Can't read DLL '$name.dll': $!";
|
|
Packit |
972a07 |
binmode($dll);
|
|
Packit |
972a07 |
$uudata = pack "u", do { local $/; <$dll> };
|
|
Packit |
972a07 |
close($dll);
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
open($uufh, '>', "$name\_dll.uu") or die "fatal: Can't write file '$name\_dll.uu': $!";
|
|
Packit |
972a07 |
print $uufh $uudata;
|
|
Packit |
972a07 |
close($uufh);
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
# parse the generated header to extract the constants
|
|
Packit |
972a07 |
open(my $header, '<', "$name.h") or die "fatal: Can't read header file '$name.h': $!";
|
|
Packit |
972a07 |
my %vals;
|
|
Packit |
972a07 |
my $max = 0;
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
while (<$header>) {
|
|
Packit |
972a07 |
if (/^#define\s+(\w+)\s+(\d+)$/ || /^#define\s+(\w+)\s+\(\(DWORD\)(\d+)L\)/) {
|
|
Packit |
972a07 |
$vals{$1} = $2;
|
|
Packit |
972a07 |
if (substr($1, 0, 1) eq 'C') {
|
|
Packit |
972a07 |
$max = $2 if $max < $2;
|
|
Packit |
972a07 |
}
|
|
Packit |
972a07 |
}
|
|
Packit |
972a07 |
}
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
close($header);
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
my ($hash, $f2c, %fac);
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
for my $name (sort { substr($a,0,1) cmp substr($b,0,1) || $vals{$a} <=> $vals{$b} } keys %vals) {
|
|
Packit |
972a07 |
$hash .= " $name => $vals{$name},\n" ;
|
|
Packit |
972a07 |
if ($name =~ /^CAT_(\w+)$/) {
|
|
Packit |
972a07 |
$fac{$1} = $vals{$name};
|
|
Packit |
972a07 |
}
|
|
Packit |
972a07 |
}
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
for my $name (sort {$fac{$a} <=> $fac{$b}} keys %fac) {
|
|
Packit |
972a07 |
$f2c .= " Sys::Syslog::LOG_$name() => '$name',\n";
|
|
Packit |
972a07 |
}
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
# write the Sys::Syslog::Win32 module
|
|
Packit |
972a07 |
open my $out, '>', "Win32.pm" or die "fatal: Can't write Win32.pm: $!";
|
|
Packit |
972a07 |
my $template = join '', <DATA>;
|
|
Packit |
972a07 |
$template =~ s/__CONSTANT__/$hash/;
|
|
Packit |
972a07 |
$template =~ s/__F2C__/$f2c/;
|
|
Packit |
972a07 |
$template =~ s/__NAME_VER__/$name/;
|
|
Packit |
972a07 |
$template =~ s/__VER__/$version/;
|
|
Packit |
972a07 |
$max = sprintf "0x%08x", $max;
|
|
Packit |
972a07 |
$template =~ s/__MAX__/'$max'/g;
|
|
Packit |
972a07 |
$template =~ s/__TIME__/localtime()/ge;
|
|
Packit |
972a07 |
print $out $template;
|
|
Packit |
972a07 |
close $out;
|
|
Packit |
972a07 |
print "Updated Win32.pm and relevant message files\n";
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
__END__
|
|
Packit |
972a07 |
package Sys::Syslog::Win32;
|
|
Packit |
972a07 |
use strict;
|
|
Packit |
972a07 |
use warnings;
|
|
Packit |
972a07 |
use Carp;
|
|
Packit |
972a07 |
use File::Spec;
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
# === WARNING === WARNING === WARNING === WARNING === WARNING === WARNING ===
|
|
Packit |
972a07 |
#
|
|
Packit |
972a07 |
# This file was generated by Sys-Syslog/win32/compile.pl on __TIME__
|
|
Packit |
972a07 |
# Any changes being made here will be lost the next time Sys::Syslog
|
|
Packit |
972a07 |
# is installed.
|
|
Packit |
972a07 |
#
|
|
Packit |
972a07 |
# Do NOT USE THIS MODULE DIRECTLY: this is a utility module for Sys::Syslog.
|
|
Packit |
972a07 |
# It may change at any time to fit the needs of Sys::Syslog therefore no
|
|
Packit |
972a07 |
# warranty is made WRT to its API. You Have Been Warned.
|
|
Packit |
972a07 |
#
|
|
Packit |
972a07 |
# === WARNING === WARNING === WARNING === WARNING === WARNING === WARNING ===
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
our $Source;
|
|
Packit |
972a07 |
my $logger;
|
|
Packit |
972a07 |
my $Registry;
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
use Win32::EventLog;
|
|
Packit |
972a07 |
use Win32::TieRegistry 0.20 (
|
|
Packit |
972a07 |
TiedRef => \$Registry,
|
|
Packit |
972a07 |
Delimiter => "/",
|
|
Packit |
972a07 |
ArrayValues => 1,
|
|
Packit |
972a07 |
SplitMultis => 1,
|
|
Packit |
972a07 |
AllowLoad => 1,
|
|
Packit |
972a07 |
qw(
|
|
Packit |
972a07 |
REG_SZ
|
|
Packit |
972a07 |
REG_EXPAND_SZ
|
|
Packit |
972a07 |
REG_DWORD
|
|
Packit |
972a07 |
REG_BINARY
|
|
Packit |
972a07 |
REG_MULTI_SZ
|
|
Packit |
972a07 |
KEY_READ
|
|
Packit |
972a07 |
KEY_WRITE
|
|
Packit |
972a07 |
KEY_ALL_ACCESS
|
|
Packit |
972a07 |
),
|
|
Packit |
972a07 |
);
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
my $is_Cygwin = $^O =~ /Cygwin/i;
|
|
Packit |
972a07 |
my $is_Win32 = $^O =~ /Win32/i;
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
my %const = (
|
|
Packit |
972a07 |
__CONSTANT__
|
|
Packit |
972a07 |
);
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
my %id2name = (
|
|
Packit |
972a07 |
__F2C__
|
|
Packit |
972a07 |
);
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
my @priority2eventtype = (
|
|
Packit |
972a07 |
EVENTLOG_ERROR_TYPE(), # LOG_EMERG
|
|
Packit |
972a07 |
EVENTLOG_ERROR_TYPE(), # LOG_ALERT
|
|
Packit |
972a07 |
EVENTLOG_ERROR_TYPE(), # LOG_CRIT
|
|
Packit |
972a07 |
EVENTLOG_ERROR_TYPE(), # LOG_ERR
|
|
Packit |
972a07 |
EVENTLOG_WARNING_TYPE(), # LOG_WARNING
|
|
Packit |
972a07 |
EVENTLOG_WARNING_TYPE(), # LOG_NOTICE
|
|
Packit |
972a07 |
EVENTLOG_INFORMATION_TYPE(), # LOG_INFO
|
|
Packit |
972a07 |
EVENTLOG_INFORMATION_TYPE(), # LOG_DEBUG
|
|
Packit |
972a07 |
);
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
#
|
|
Packit |
972a07 |
# _install()
|
|
Packit |
972a07 |
# --------
|
|
Packit |
972a07 |
# Used to set up a connection to the eventlog.
|
|
Packit |
972a07 |
#
|
|
Packit |
972a07 |
sub _install {
|
|
Packit |
972a07 |
return $logger if $logger;
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
# can't just use basename($0) here because Win32 path often are a
|
|
Packit |
972a07 |
# a mix of / and \, and File::Basename::fileparse() can't handle that,
|
|
Packit |
972a07 |
# while File::Spec::splitpath() can.. Go figure..
|
|
Packit |
972a07 |
my (undef, undef, $basename) = File::Spec->splitpath($0);
|
|
Packit |
972a07 |
($Source) ||= $basename;
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
$Source.=" [SSW:__VER__]";
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
#$Registry->Delimiter("/"); # is this needed?
|
|
Packit |
972a07 |
my $root = 'LMachine/SYSTEM/CurrentControlSet/Services/Eventlog/Application/';
|
|
Packit |
972a07 |
my $dll = 'Sys/Syslog/__NAME_VER__.dll';
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
if (!$Registry->{$root.$Source} ||
|
|
Packit |
972a07 |
!$Registry->{$root.$Source.'/CategoryMessageFile'}[0] ||
|
|
Packit |
972a07 |
!-e $Registry->{$root.$Source.'/CategoryMessageFile'}[0] )
|
|
Packit |
972a07 |
{
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
# find the resource DLL, which should be along Syslog.dll
|
|
Packit |
972a07 |
my ($file) = grep { -e $_ } map { ("$_/$dll" => "$_/auto/$dll") } @INC;
|
|
Packit |
972a07 |
$dll = $file if $file;
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
# on Cygwin, convert the Unix path into absolute Windows path
|
|
Packit |
972a07 |
if ($is_Cygwin) {
|
|
Packit |
972a07 |
if ($] > 5.009005) {
|
|
Packit |
972a07 |
chomp($file = Cygwin::posix_to_win_path($file, 1));
|
|
Packit |
972a07 |
}
|
|
Packit |
972a07 |
else {
|
|
Packit |
972a07 |
local $ENV{PATH} = '';
|
|
Packit |
972a07 |
chomp($dll = `/usr/bin/cygpath --absolute --windows "$dll"`);
|
|
Packit |
972a07 |
}
|
|
Packit |
972a07 |
}
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
$dll =~ s![\\/]+!\\!g; # must be backslashes!
|
|
Packit |
972a07 |
die "fatal: Can't find resource DLL for Sys::Syslog\n" if !$dll;
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
$Registry->{$root.$Source} = {
|
|
Packit |
972a07 |
'/EventMessageFile' => [ $dll, REG_EXPAND_SZ ],
|
|
Packit |
972a07 |
'/CategoryMessageFile' => [ $dll, REG_EXPAND_SZ ],
|
|
Packit |
972a07 |
'/CategoryCount' => [ __MAX__, REG_DWORD ],
|
|
Packit |
972a07 |
#'/TypesSupported' => [ __MAX__, REG_DWORD ],
|
|
Packit |
972a07 |
};
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
warn "Configured eventlog to use $dll for $Source\n" if $Sys::Syslog::DEBUG;
|
|
Packit |
972a07 |
}
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
#Carp::confess("Registry has the wrong value for '$Source', possibly mismatched dll!\nMine:$dll\nGot :$Registry->{$root.$Source.'/CategoryMessageFile'}[0]\n")
|
|
Packit |
972a07 |
# if $Registry->{$root.$Source.'/CategoryMessageFile'}[0] ne $dll;
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
# we really should do something useful with this but for now
|
|
Packit |
972a07 |
# we set it to "" to prevent Win32::EventLog from warning
|
|
Packit |
972a07 |
my $host = "";
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
$logger = Win32::EventLog->new($Source, $host)
|
|
Packit |
972a07 |
or Carp::confess("Failed to connect to the '$Source' event log");
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
return $logger;
|
|
Packit |
972a07 |
}
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
#
|
|
Packit |
972a07 |
# _syslog_send()
|
|
Packit |
972a07 |
# ------------
|
|
Packit |
972a07 |
# Used to convert syslog messages into eventlog messages
|
|
Packit |
972a07 |
#
|
|
Packit |
972a07 |
sub _syslog_send {
|
|
Packit |
972a07 |
my ($buf, $numpri, $numfac) = @_;
|
|
Packit |
972a07 |
$numpri ||= EVENTLOG_INFORMATION_TYPE();
|
|
Packit |
972a07 |
$numfac ||= Sys::Syslog::LOG_USER();
|
|
Packit |
972a07 |
my $name = $id2name{$numfac};
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
my $opts = {
|
|
Packit |
972a07 |
EventType => $priority2eventtype[$numpri],
|
|
Packit |
972a07 |
EventID => $const{"MSG_$name"},
|
|
Packit |
972a07 |
Category => $const{"CAT_$name"},
|
|
Packit |
972a07 |
Strings => "$buf\0",
|
|
Packit |
972a07 |
Data => "",
|
|
Packit |
972a07 |
};
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
if ($Sys::Syslog::DEBUG) {
|
|
Packit |
972a07 |
require Data::Dumper;
|
|
Packit |
972a07 |
warn Data::Dumper->Dump(
|
|
Packit |
972a07 |
[$numpri, $numfac, $name, $opts],
|
|
Packit |
972a07 |
[qw(numpri numfac name opts)]
|
|
Packit |
972a07 |
);
|
|
Packit |
972a07 |
}
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
return $logger->Report($opts);
|
|
Packit |
972a07 |
}
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
=head1 NAME
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
Sys::Syslog::Win32 - Win32 support for Sys::Syslog
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
=head1 DESCRIPTION
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
This module is a back-end plugin for C<Sys::Syslog>, for supporting the Win32
|
|
Packit |
972a07 |
event log. It is not expected to be directly used by any module other than
|
|
Packit |
972a07 |
C<Sys::Syslog> therefore it's API may change at any time and no warranty is
|
|
Packit |
972a07 |
made with regards to backward compatibility. You Have Been Warned.
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
In order to execute this script and compile the Win32 support files, you
|
|
Packit |
972a07 |
need some helper programs: mc.exe, rc.exe and link.exe
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
mc.exe and rc.exe can be downloaded from
|
|
Packit |
972a07 |
http://www.microsoft.com/en-us/download/details.aspx?id=11310
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
link.exe is usually shipped with Visual Studio.
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
=head1 SEE ALSO
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
L<Sys::Syslog>
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
=head1 AUTHORS
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
SE<eacute>bastien Aperghis-Tramoni and Yves Orton
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
=head1 LICENSE
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
This program is free software; you can redistribute it and/or modify it
|
|
Packit |
972a07 |
under the same terms as Perl itself.
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
=cut
|
|
Packit |
972a07 |
|
|
Packit |
972a07 |
1;
|