1#!perl
2use strict;
3use warnings;
4use File::Basename;
5use File::Copy;
6use File::Path;
7
8my $name = shift || 'PerlLog';
9
10# get the version from the message file
11open(my $msgfh, '<', "$name.mc") or die "fatal: Can't read file '$name.mc': $!\n";
12my $top = <$msgfh>;
13close($msgfh);
14
15my ($version) = $top =~ /Sys::Syslog Message File (\d+\.\d+\.\d+)/
16        or die "error: File '$name.mc' doesn't have a version number\n";
17
18# compile the message text files
19system("mc -d $name.mc");
20system("rc $name.rc");
21system(qq{ link -nodefaultlib -incremental:no -release /nologo -base:0x60000000 }
22      .qq{ -comment:"Perl Syslog Message File v$version" }
23      .qq{ -machine:i386 -dll -noentry -out:$name.dll $name.res });
24
25# uuencode the resource file
26open(my $rsrc, '<', "$name.RES") or die "fatal: Can't read resource file '$name.RES': $!";
27binmode($rsrc);
28my $uudata = pack "u", do { local $/; <$rsrc> };
29close($rsrc);
30
31open(my $uufh, '>', "$name\_RES.uu") or die "fatal: Can't write file '$name\_RES.uu': $!";
32print $uufh $uudata;
33close($uufh);
34
35# uuencode the DLL
36open(my $dll, '<', "$name.dll") or die "fatal: Can't read DLL '$name.dll': $!";
37binmode($dll);
38$uudata = pack "u", do { local $/; <$dll> };
39close($dll);
40
41open($uufh, '>', "$name\_dll.uu") or die "fatal: Can't write file '$name\_dll.uu': $!";
42print $uufh $uudata;
43close($uufh);
44
45# parse the generated header to extract the constants
46open(my $header, '<', "$name.h") or die "fatal: Can't read header file '$name.h': $!";
47my %vals;
48my $max = 0;
49
50while (<$header>) {
51    if (/^#define\s+(\w+)\s+(\d+)$/ || /^#define\s+(\w+)\s+\(\(DWORD\)(\d+)L\)/) {
52        $vals{$1} = $2;
53        if (substr($1, 0, 1) eq 'C') {
54            $max = $2 if $max < $2;
55        }
56    }
57}
58
59close($header);
60
61my ($hash, $f2c, %fac);
62
63for my $name (sort { substr($a,0,1) cmp substr($b,0,1) || $vals{$a} <=> $vals{$b} } keys %vals) {
64    $hash .= "    $name => $vals{$name},\n" ;
65    if ($name =~ /^CAT_(\w+)$/) {
66        $fac{$1} = $vals{$name};
67    }
68}
69
70for my $name (sort {$fac{$a} <=> $fac{$b}} keys %fac) {
71    $f2c .= "    Sys::Syslog::LOG_$name() => '$name',\n";
72}
73
74# write the Sys::Syslog::Win32 module
75open my $out, '>', "Win32.pm" or die "fatal: Can't write Win32.pm: $!";
76my $template = join '', <DATA>;
77$template =~ s/__CONSTANT__/$hash/;
78$template =~ s/__F2C__/$f2c/;
79$template =~ s/__NAME_VER__/$name/;
80$template =~ s/__VER__/$version/;
81$max = sprintf "0x%08x", $max;
82$template =~ s/__MAX__/'$max'/g;
83$template =~ s/__TIME__/localtime()/ge;
84print $out $template;
85close $out;
86print "Updated Win32.pm and relevant message files\n";
87
88__END__
89package Sys::Syslog::Win32;
90use strict;
91use warnings;
92use Carp;
93use File::Spec;
94
95# === WARNING === WARNING === WARNING === WARNING === WARNING === WARNING ===
96#
97# This file was generated by Sys-Syslog/win32/compile.pl on __TIME__
98# Any changes being made here will be lost the next time Sys::Syslog
99# is installed.
100#
101# Do NOT USE THIS MODULE DIRECTLY: this is a utility module for Sys::Syslog.
102# It may change at any time to fit the needs of Sys::Syslog therefore no
103# warranty is made WRT to its API. You Have Been Warned.
104#
105# === WARNING === WARNING === WARNING === WARNING === WARNING === WARNING ===
106
107our $Source;
108my $logger;
109my $Registry;
110
111use Win32::EventLog;
112use Win32::TieRegistry 0.20 (
113    TiedRef     => \$Registry,
114    Delimiter   => "/",
115    ArrayValues => 1,
116    SplitMultis => 1,
117    AllowLoad   => 1,
118    qw(
119        REG_SZ
120        REG_EXPAND_SZ
121        REG_DWORD
122        REG_BINARY
123        REG_MULTI_SZ
124        KEY_READ
125        KEY_WRITE
126        KEY_ALL_ACCESS
127    ),
128);
129
130my $is_Cygwin = $^O =~ /Cygwin/i;
131my $is_Win32  = $^O =~ /Win32/i;
132
133my %const = (
134__CONSTANT__
135);
136
137my %id2name = (
138__F2C__
139);
140
141my @priority2eventtype = (
142    EVENTLOG_ERROR_TYPE(),       # LOG_EMERG
143    EVENTLOG_ERROR_TYPE(),       # LOG_ALERT
144    EVENTLOG_ERROR_TYPE(),       # LOG_CRIT
145    EVENTLOG_ERROR_TYPE(),       # LOG_ERR
146    EVENTLOG_WARNING_TYPE(),     # LOG_WARNING
147    EVENTLOG_WARNING_TYPE(),     # LOG_NOTICE
148    EVENTLOG_INFORMATION_TYPE(), # LOG_INFO
149    EVENTLOG_INFORMATION_TYPE(), # LOG_DEBUG
150);
151
152
153#
154# _install()
155# --------
156# Used to set up a connection to the eventlog.
157#
158sub _install {
159    return $logger if $logger;
160
161    # can't just use basename($0) here because Win32 path often are a
162    # a mix of / and \, and File::Basename::fileparse() can't handle that,
163    # while File::Spec::splitpath() can.. Go figure..
164    my (undef, undef, $basename) = File::Spec->splitpath($0);
165    ($Source) ||= $basename;
166
167    $Source.=" [SSW:__VER__]";
168
169    #$Registry->Delimiter("/"); # is this needed?
170    my $root = 'LMachine/SYSTEM/CurrentControlSet/Services/Eventlog/Application/';
171    my $dll  = 'Sys/Syslog/__NAME_VER__.dll';
172
173    if (!$Registry->{$root.$Source} ||
174        !$Registry->{$root.$Source.'/CategoryMessageFile'}[0] ||
175        !-e $Registry->{$root.$Source.'/CategoryMessageFile'}[0] )
176    {
177
178        # find the resource DLL, which should be along Syslog.dll
179        my ($file) = grep { -e $_ }  map { ("$_/$dll" => "$_/auto/$dll") }  @INC;
180        $dll = $file if $file;
181
182        # on Cygwin, convert the Unix path into absolute Windows path
183        if ($is_Cygwin) {
184            if ($] > 5.009005) {
185                chomp($file = Cygwin::posix_to_win_path($file, 1));
186            }
187            else {
188                local $ENV{PATH} = '';
189                chomp($dll = `/usr/bin/cygpath --absolute --windows "$dll"`);
190            }
191        }
192
193        $dll =~ s![\\/]+!\\!g;     # must be backslashes!
194        die "fatal: Can't find resource DLL for Sys::Syslog\n" if !$dll;
195
196        $Registry->{$root.$Source} = {
197            '/EventMessageFile'    => [ $dll, REG_EXPAND_SZ ],
198            '/CategoryMessageFile' => [ $dll, REG_EXPAND_SZ ],
199            '/CategoryCount'       => [ __MAX__, REG_DWORD ],
200            #'/TypesSupported'      => [ __MAX__, REG_DWORD ],
201        };
202
203        warn "Configured eventlog to use $dll for $Source\n" if $Sys::Syslog::DEBUG;
204    }
205
206    #Carp::confess("Registry has the wrong value for '$Source', possibly mismatched dll!\nMine:$dll\nGot :$Registry->{$root.$Source.'/CategoryMessageFile'}[0]\n")
207    #    if $Registry->{$root.$Source.'/CategoryMessageFile'}[0] ne $dll;
208
209    # we really should do something useful with this but for now
210    # we set it to "" to prevent Win32::EventLog from warning
211    my $host = "";
212
213    $logger = Win32::EventLog->new($Source, $host)
214        or Carp::confess("Failed to connect to the '$Source' event log");
215
216    return $logger;
217}
218
219
220#
221# _syslog_send()
222# ------------
223# Used to convert syslog messages into eventlog messages
224#
225sub _syslog_send {
226    my ($buf, $numpri, $numfac) = @_;
227    $numpri ||= EVENTLOG_INFORMATION_TYPE();
228    $numfac ||= Sys::Syslog::LOG_USER();
229    my $name = $id2name{$numfac};
230
231    my $opts = {
232        EventType   => $priority2eventtype[$numpri],
233        EventID     => $const{"MSG_$name"},
234        Category    => $const{"CAT_$name"},
235        Strings     => "$buf\0",
236        Data        => "",
237    };
238
239    if ($Sys::Syslog::DEBUG) {
240        require Data::Dumper;
241        warn Data::Dumper->Dump(
242            [$numpri, $numfac, $name, $opts],
243            [qw(numpri numfac name opts)]
244        );
245    }
246
247    return $logger->Report($opts);
248}
249
250
251=head1 NAME
252
253Sys::Syslog::Win32 - Win32 support for Sys::Syslog
254
255=head1 DESCRIPTION
256
257This module is a back-end plugin for C<Sys::Syslog>, for supporting the Win32
258event log. It is not expected to be directly used by any module other than
259C<Sys::Syslog> therefore it's API may change at any time and no warranty is
260made with regards to backward compatibility. You Have Been Warned.
261
262In order to execute this script and compile the Win32 support files, you
263need some helper programs: mc.exe, rc.exe and link.exe
264
265mc.exe and rc.exe can be downloaded from
266http://www.microsoft.com/en-us/download/details.aspx?id=11310
267
268link.exe is usually shipped with Visual Studio.
269
270=head1 SEE ALSO
271
272L<Sys::Syslog>
273
274=head1 AUTHORS
275
276SE<eacute>bastien Aperghis-Tramoni and Yves Orton
277
278=head1 LICENSE
279
280This program is free software; you can redistribute it and/or modify it
281under the same terms as Perl itself.
282
283=cut
284
2851;
286