cpan/Sys-Syslog/win32/compile.pl

   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;