Commit | Line | Data |
a650b841 |
1 | #!perl |
2 | use strict; |
3 | use warnings; |
4 | use File::Basename; |
5 | use File::Copy; |
6 | use File::Path; |
7 | |
8 | my $name = shift || 'PerlLog'; |
9 | |
10 | # get the version from the message file |
11 | open(my $msgfh, '<', "$name.mc") or die "fatal: Can't read file '$name.mc': $!\n"; |
12 | my $top = <$msgfh>; |
13 | close($msgfh); |
14 | |
15 | my ($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 |
19 | system("mc -d $name.mc"); |
20 | system("rc $name.rc"); |
21 | system(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 |
26 | open(my $rsrc, '<', "$name.RES") or die "fatal: Can't read resource file '$name.RES': $!"; |
27 | binmode($rsrc); |
28 | my $uudata = pack "u", do { local $/; <$rsrc> }; |
29 | close($rsrc); |
30 | |
31 | open(my $uufh, '>', "$name\_RES.uu") or die "fatal: Can't write file '$name\_RES.uu': $!"; |
32 | print $uufh $uudata; |
33 | close($uufh); |
34 | |
35 | # uuencode the DLL |
36 | open(my $dll, '<', "$name.dll") or die "fatal: Can't read DLL '$name.dll': $!"; |
37 | binmode($dll); |
38 | $uudata = pack "u", do { local $/; <$dll> }; |
39 | close($dll); |
40 | |
41 | open($uufh, '>', "$name\_dll.uu") or die "fatal: Can't write file '$name\_dll.uu': $!"; |
42 | print $uufh $uudata; |
43 | close($uufh); |
44 | |
45 | # parse the generated header to extract the constants |
46 | open(my $header, '<', "$name.h") or die "fatal: Can't read header file '$name.h': $!"; |
47 | my %vals; |
48 | my $max = 0; |
49 | |
50 | while (<$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 | |
59 | close($header); |
60 | |
61 | my ($hash, $f2c, %fac); |
62 | |
63 | for 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 | |
70 | for 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 |
75 | open my $out, '>', "Win32.pm" or die "fatal: Can't write Win32.pm: $!"; |
76 | my $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; |
84 | print $out $template; |
85 | close $out; |
86 | print "Updated Win32.pm and relevent message files\n"; |
87 | |
88 | __END__ |
89 | package Sys::Syslog::Win32; |
90 | use strict; |
91 | use warnings; |
92 | use Carp; |
93 | use 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 | |
107 | our $Source; |
108 | my $logger; |
109 | my $Registry; |
110 | |
111 | use Win32::EventLog; |
112 | use 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 | |
130 | my $is_Cygwin = $^O =~ /Cygwin/i; |
131 | my $is_Win32 = $^O =~ /Win32/i; |
132 | |
133 | my %const = ( |
134 | __CONSTANT__ |
135 | ); |
136 | |
137 | my %id2name = ( |
138 | __F2C__ |
139 | ); |
140 | |
141 | my @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 | # |
158 | sub _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 | # |
225 | sub _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 | |
253 | Sys::Syslog::Win32 - Win32 support for Sys::Syslog |
254 | |
255 | =head1 DESCRIPTION |
256 | |
257 | This module is a back-end plugin for C<Sys::Syslog>, for supporting the Win32 |
258 | event log. It is not expected to be directly used by any module other than |
259 | C<Sys::Syslog> therefore it's API may change at any time and no warranty is |
260 | made with regards to backward compatibility. You Have Been Warned. |
261 | |
262 | =head1 SEE ALSO |
263 | |
264 | L<Sys::Syslog> |
265 | |
266 | =head1 AUTHORS |
267 | |
268 | SE<eacute>bastien Aperghis-Tramoni and Yves Orton |
269 | |
270 | =head1 LICENSE |
271 | |
272 | This program is free software; you can redistribute it and/or modify it |
273 | under the same terms as Perl itself. |
274 | |
275 | =cut |
276 | |
277 | 1; |