254 lines
7.1 KiB
Perl
254 lines
7.1 KiB
Perl
#---------------------------------------------------------------------
|
|
package Logmsg;
|
|
#
|
|
# Copyright (c) Microsoft Corporation. All rights reserved.
|
|
#
|
|
# Version: 2.00 07/20/2000 JeremyD new version
|
|
# 2.01 12/27/2000 JeremyD remove compatibility hooks
|
|
# 2.02 02/02/2001 JeremyD add logfile_append function
|
|
#---------------------------------------------------------------------
|
|
use strict;
|
|
use vars qw(@ISA @EXPORT $VERSION $DEBUG);
|
|
use Carp;
|
|
use Exporter;
|
|
use Win32::Mutex;
|
|
use IO::File;
|
|
use File::Basename;
|
|
@ISA = qw(Exporter);
|
|
@EXPORT = qw(dbgmsg infomsg logmsg wrnmsg errmsg timemsg append_file);
|
|
|
|
$VERSION = '2.02';
|
|
|
|
|
|
sub timestamp() {
|
|
my ($sec,$min,$hour,$day,$mon,$year) = localtime;
|
|
$year %= 100;
|
|
$mon++;
|
|
return sprintf("%02d/%02d/%02d %02d:%02d:%02d", $mon, $day, $year,
|
|
$hour, $min, $sec);
|
|
}
|
|
|
|
sub scriptname() {
|
|
$ENV{SCRIPT_NAME} || basename($0);
|
|
}
|
|
|
|
sub sync_write {
|
|
my $data = shift;
|
|
my $filename = shift;
|
|
|
|
# validate data
|
|
return unless $data;
|
|
return unless $filename;
|
|
|
|
# get a global mutex for this file, this breaks down if
|
|
# relative paths are used, so don't use them
|
|
my $mutexname = $filename;
|
|
$mutexname =~ tr/A-Z\\/a-z\//;
|
|
$mutexname = "Global\\$mutexname";
|
|
|
|
my $mutex = Win32::Mutex->new(0, $mutexname);
|
|
if (defined $mutex) {
|
|
if ($mutex->wait(60000)) {
|
|
if (my $fh = IO::File->new($filename, "a")) {
|
|
$fh->print($data);
|
|
undef $fh;
|
|
} else {
|
|
carp "Failed to open $filename: $!";
|
|
}
|
|
$mutex->release;
|
|
} else {
|
|
carp "Timed out trying to get mutex for $filename, skipping";
|
|
}
|
|
} else {
|
|
carp "Failed to create mutex $mutexname for log access";
|
|
}
|
|
}
|
|
|
|
sub sync_write_multiple {
|
|
my $data = shift;
|
|
my @filenames = @_;
|
|
for my $filename (@filenames) {
|
|
sync_write($data, $filename);
|
|
}
|
|
}
|
|
|
|
|
|
sub dbgmsg {
|
|
my $message = shift;
|
|
return unless ($DEBUG or $ENV{DEBUG});
|
|
my $line = sprintf("(%s) [%s] $message\n", scriptname(), timestamp());
|
|
print $line;
|
|
sync_write_multiple($line,
|
|
$ENV{LOGFILE}, $ENV{INTERLEAVE_LOG});
|
|
return $line;
|
|
}
|
|
|
|
|
|
sub infomsg {
|
|
my $message = shift;
|
|
my $line = sprintf("(%s) [%s] $message\n", scriptname(), timestamp());
|
|
sync_write_multiple($line,
|
|
$ENV{LOGFILE}, $ENV{INTERLEAVE_LOG});
|
|
return $line;
|
|
}
|
|
|
|
|
|
sub logmsg {
|
|
my $message = shift;
|
|
my $line = sprintf("(%s) $message\n", scriptname());
|
|
print $line;
|
|
sync_write_multiple($line,
|
|
$ENV{LOGFILE}, $ENV{INTERLEAVE_LOG});
|
|
return $line;
|
|
}
|
|
|
|
sub timemsg {
|
|
my $message = shift;
|
|
my $line = sprintf("(%s) [%s] $message\n", scriptname(), timestamp());
|
|
print $line;
|
|
sync_write_multiple($line,
|
|
$ENV{LOGFILE}, $ENV{INTERLEAVE_LOG});
|
|
return $line;
|
|
}
|
|
|
|
sub wrnmsg {
|
|
my $message = shift;
|
|
my $line = sprintf("(%s) WARNING: $message\n", scriptname());
|
|
print $line;
|
|
sync_write_multiple($line,
|
|
$ENV{LOGFILE}, $ENV{INTERLEAVE_LOG});
|
|
return $line;
|
|
}
|
|
|
|
sub errmsg {
|
|
my $message = shift;
|
|
my $line = sprintf("(%s) ERROR: $message\n", scriptname());
|
|
print $line;
|
|
sync_write_multiple($line,
|
|
$ENV{ERRFILE}, $ENV{LOGFILE}, $ENV{INTERLEAVE_LOG});
|
|
$ENV{ERRORS}++;
|
|
return $line;
|
|
# maybe this should croak?
|
|
}
|
|
|
|
sub append_file {
|
|
my $filename = shift;
|
|
my $shortname = basename($filename);
|
|
my $content = sprintf("(%s) [%s] appending $filename\n", scriptname(), timestamp());
|
|
|
|
open FILE, $filename or die $!;
|
|
while (<FILE>) {
|
|
$content .= "$shortname: $_";
|
|
}
|
|
close FILE;
|
|
|
|
sync_write_multiple($content,
|
|
$ENV{LOGFILE}, $ENV{INTERLEAVE_LOG});
|
|
return $filename;
|
|
}
|
|
|
|
1;
|
|
|
|
__END__
|
|
|
|
=head1 NAME
|
|
|
|
Logmsg - An interface for writing to log files
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
use Logmsg;
|
|
logmsg "the text to be logged";
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
The Logmsg module provides an interface for writing to log files.
|
|
|
|
The functions exported by Logmsg all take exactly one scalar, the message to
|
|
be logged and return the text that was logged.
|
|
|
|
The name of the running script is logged at the beginning of each message. The
|
|
script name is set to either the SCRIPT_NAME environment variable or $0 if
|
|
SCRIPT_NAME is not set.
|
|
|
|
If a filename is available but the file does not exist it will be created.
|
|
|
|
If a logfile environment variable (LOGFILE, INTERLEAVE_LOG, ERRFILE) is not set
|
|
no attempt will be made to log to the file that it doesn't specify. No error or
|
|
warning is generated.
|
|
|
|
Any files that cannot be logged to (unable to obtain a lock within timeout) are
|
|
skipped printing a warning to STDERR.
|
|
|
|
=over 4
|
|
|
|
|
|
=item logmsg( $message )
|
|
|
|
Logs to STDOUT and the files specified by LOGFILE and INTERLEAVE_LOG.
|
|
|
|
=item errmsg( $message )
|
|
|
|
Logs to STDOUT and the files specified by ERRFILE, LOGFILE and INTERLEAVE_LOG. The
|
|
message text is preceeded by "ERROR: " and the ERRORS environment variable is
|
|
incremented.
|
|
|
|
=item wrnmsg( $message )
|
|
|
|
Logs to STDOUT and the files specified by LOGFILE and INTERLEAVE_LOG. The message
|
|
text is preceeded by "WARNING: ".
|
|
|
|
=item infomsg( $message )
|
|
|
|
Logs to files specified by LOGFILE and INTERLEAVE_LOG. infomsg is similar to logmsg
|
|
but can be used when output to STDOUT is not desirable.
|
|
|
|
=item dbgmsg( $message )
|
|
|
|
Logs to STDOUT and the files specified by LOGFILE and INTERLEAVE_LOG only if
|
|
$Logmsg::DEBUG or the DEBUG environment variable is set.
|
|
|
|
=item timemsg( $message )
|
|
|
|
Logs to STDOUT and the files specified by LOGFILE and INTERLEAVE_LOG. The message
|
|
text is preceeded by a date/time stamp.
|
|
|
|
=item append_file( $filename )
|
|
|
|
The contents of $filename are appended to LOGFILE and INTERLEAVE_LOG. The time and
|
|
filename passed in are logged first followed by the contents of the file. Each
|
|
line is prefixed with the base filename.
|
|
|
|
=back
|
|
|
|
=head1 ENVIRONMENT
|
|
|
|
The environment variable SCRIPT_NAME is used to determine the script name to be
|
|
logged with each message. The base filename of $0 is used if this is not set.
|
|
|
|
If neither the DEBUG environment variable nor $Logfile::DEBUG is set then dbgmsg
|
|
returns immediately and does not log.
|
|
|
|
The environment variables LOGFILE, INTERLEAVE_LOG and ERRFILE specify the filenames
|
|
to be used for logging. Any or all of these may be left unset without generating a
|
|
warning or error.
|
|
|
|
The errmsg function increments the ERRORS environment variable each time it is called.
|
|
|
|
=head1 NOTES
|
|
|
|
All file access is syncronized with a mutex based on the filename given. If different
|
|
relative paths are used for a filename than locking protection will not work. In this
|
|
case it is possible that some data may be corrupted by simultaneous writes to the same
|
|
file.
|
|
|
|
=head1 AUTHOR
|
|
|
|
Jeremy Devenport <JeremyD>
|
|
|
|
=head1 COPYRIGHT
|
|
|
|
Copyright (c) Microsoft Corporation. All rights reserved.
|
|
|
|
=cut
|