summaryrefslogtreecommitdiff
path: root/lib/Log/Log4perl/Util
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Log/Log4perl/Util')
-rw-r--r--lib/Log/Log4perl/Util/Semaphore.pm264
-rw-r--r--lib/Log/Log4perl/Util/TimeTracker.pm259
2 files changed, 523 insertions, 0 deletions
diff --git a/lib/Log/Log4perl/Util/Semaphore.pm b/lib/Log/Log4perl/Util/Semaphore.pm
new file mode 100644
index 0000000..e88e39b
--- /dev/null
+++ b/lib/Log/Log4perl/Util/Semaphore.pm
@@ -0,0 +1,264 @@
+#//////////////////////////////////////////
+package Log::Log4perl::Util::Semaphore;
+#//////////////////////////////////////////
+use IPC::SysV qw(IPC_RMID IPC_CREAT IPC_EXCL SEM_UNDO IPC_NOWAIT
+ IPC_SET IPC_STAT SETVAL);
+use IPC::Semaphore;
+use POSIX qw(EEXIST);
+use strict;
+use warnings;
+use constant INTERNAL_DEBUG => 0;
+
+###########################################
+sub new {
+###########################################
+ my($class, %options) = @_;
+
+ my $self = {
+ key => undef,
+ mode => undef,
+ uid => undef,
+ gid => undef,
+ destroy => undef,
+ semop_wait => .1,
+ semop_retries => 1,
+ creator => $$,
+ %options,
+ };
+
+ $self->{ikey} = unpack("i", pack("A4", $self->{key}));
+
+ # Accept usernames in the uid field as well
+ if(defined $self->{uid} and
+ $self->{uid} =~ /\D/) {
+ $self->{uid} = (getpwnam $self->{uid})[2];
+ }
+
+ bless $self, $class;
+ $self->init();
+
+ my @values = ();
+ for my $param (qw(mode uid gid)) {
+ push @values, $param, $self->{$param} if defined $self->{$param};
+ }
+ $self->semset(@values) if @values;
+
+ return $self;
+}
+
+###########################################
+sub init {
+###########################################
+ my($self) = @_;
+
+ print "Semaphore init '$self->{key}'/'$self->{ikey}'\n" if INTERNAL_DEBUG;
+
+ $self->{id} = semget( $self->{ikey},
+ 1,
+ &IPC_EXCL|&IPC_CREAT|($self->{mode}||0777),
+ );
+
+ if(! defined $self->{id} and
+ $! == EEXIST) {
+ print "Semaphore '$self->{key}' already exists\n" if INTERNAL_DEBUG;
+ $self->{id} = semget( $self->{ikey}, 1, 0 )
+ or die "semget($self->{ikey}) failed: $!";
+ } elsif($!) {
+ die "Cannot create semaphore $self->{key}/$self->{ikey} ($!)";
+ }
+}
+
+###########################################
+sub status_as_string {
+###########################################
+ my($self, @values) = @_;
+
+ my $sem = IPC::Semaphore->new($self->{ikey}, 1, 0);
+
+ my $values = join('/', $sem->getall());
+ my $ncnt = $sem->getncnt(0);
+ my $pidlast = $sem->getpid(0);
+ my $zcnt = $sem->getzcnt(0);
+ my $id = $sem->id();
+
+ return <<EOT;
+Semaphore Status
+Key ...................................... $self->{key}
+iKey ..................................... $self->{ikey}
+Id ....................................... $id
+Values ................................... $values
+Processes waiting for counter increase ... $ncnt
+Processes waiting for counter to hit 0 ... $zcnt
+Last process to perform an operation ..... $pidlast
+EOT
+}
+
+###########################################
+sub semsetval {
+###########################################
+ my($self, %keyvalues) = @_;
+
+ my $sem = IPC::Semaphore->new($self->{ikey}, 1, 0);
+ $sem->setval(%keyvalues);
+}
+
+###########################################
+sub semset {
+###########################################
+ my($self, @values) = @_;
+
+ print "Setting values for semaphore $self->{key}/$self->{ikey}\n" if
+ INTERNAL_DEBUG;
+
+ my $sem = IPC::Semaphore->new($self->{ikey}, 1, 0);
+ $sem->set(@values);
+}
+
+###########################################
+sub semlock {
+###########################################
+ my($self) = @_;
+
+ my $operation = pack("s!*",
+ # wait until it's 0
+ 0, 0, 0,
+ # increment by 1
+ 0, 1, SEM_UNDO
+ );
+
+ print "Locking semaphore '$self->{key}'\n" if INTERNAL_DEBUG;
+ $self->semop($self->{id}, $operation);
+}
+
+###########################################
+sub semunlock {
+###########################################
+ my($self) = @_;
+
+# my $operation = pack("s!*",
+# # decrement by 1
+# 0, -1, SEM_UNDO
+# );
+#
+ print "Unlocking semaphore '$self->{key}'\n" if INTERNAL_DEBUG;
+
+# # ignore errors, as they might result from trying to unlock an
+# # already unlocked semaphore.
+# semop($self->{id}, $operation);
+
+ semctl $self->{id}, 0, SETVAL, 0;
+}
+
+###########################################
+sub remove {
+###########################################
+ my($self) = @_;
+
+ print "Removing semaphore '$self->{key}'\n" if INTERNAL_DEBUG;
+
+ semctl ($self->{id}, 0, &IPC_RMID, 0) or
+ die "Removing semaphore $self->{key} failed: $!";
+}
+
+###########################################
+sub DESTROY {
+###########################################
+ my($self) = @_;
+
+ if($self->{destroy} && $$==$self->{creator}) {
+ $self->remove();
+ }
+}
+
+###########################################
+sub semop {
+###########################################
+ my($self, @args) = @_;
+
+ my $retries = $self->{semop_retries};
+
+ my $rc;
+
+ {
+ $rc = semop($args[0], $args[1]);
+
+ if(!$rc and
+ $! =~ /temporarily unavailable/ and
+ $retries-- > 0) {
+ $rc = 'undef' unless defined $rc;
+ print "semop failed (rc=$rc), retrying\n",
+ $self->status_as_string if INTERNAL_DEBUG;
+ select undef, undef, undef, $self->{semop_wait};
+ redo;
+ }
+ }
+
+ $rc or die "semop(@args) failed: $! ";
+ $rc;
+}
+
+1;
+
+__END__
+
+=encoding utf8
+
+=head1 NAME
+
+Log::Log4perl::Util::Semaphore - Easy to use semaphores
+
+=head1 SYNOPSIS
+
+ use Log::Log4perl::Util::Semaphore;
+ my $sem = Log::Log4perl::Util::Semaphore->new( key => "abc" );
+
+ $sem->semlock();
+ # ... critical section
+ $sem->semunlock();
+
+ $sem->semset( uid => (getpwnam("hugo"))[2],
+ gid => 102,
+ mode => 0644
+ );
+
+=head1 DESCRIPTION
+
+Log::Log4perl::Util::Semaphore provides the synchronisation mechanism
+for the Synchronized.pm appender in Log4perl, but can be used independently
+of Log4perl.
+
+As a convenience, the C<uid> field accepts user names as well, which it
+translates into the corresponding uid by running C<getpwnam>.
+
+=head1 LICENSE
+
+Copyright 2002-2013 by Mike Schilli E<lt>m@perlmeister.comE<gt>
+and Kevin Goess E<lt>cpan@goess.orgE<gt>.
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=head1 AUTHOR
+
+Please contribute patches to the project on Github:
+
+ http://github.com/mschilli/log4perl
+
+Send bug reports or requests for enhancements to the authors via our
+
+MAILING LIST (questions, bug reports, suggestions/patches):
+log4perl-devel@lists.sourceforge.net
+
+Authors (please contact them via the list above, not directly):
+Mike Schilli <m@perlmeister.com>,
+Kevin Goess <cpan@goess.org>
+
+Contributors (in alphabetical order):
+Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton
+Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony
+Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy
+Grundman, Paul Harrington, Alexander Hartmaier David Hull,
+Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter,
+Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope,
+Lars Thegler, David Viner, Mac Yang.
+
diff --git a/lib/Log/Log4perl/Util/TimeTracker.pm b/lib/Log/Log4perl/Util/TimeTracker.pm
new file mode 100644
index 0000000..35847c6
--- /dev/null
+++ b/lib/Log/Log4perl/Util/TimeTracker.pm
@@ -0,0 +1,259 @@
+##################################################
+package Log::Log4perl::Util::TimeTracker;
+##################################################
+
+use 5.006;
+use strict;
+use warnings;
+use Log::Log4perl::Util;
+use Carp;
+
+our $TIME_HIRES_AVAILABLE;
+
+BEGIN {
+ # Check if we've got Time::HiRes. If not, don't make a big fuss,
+ # just set a flag so we know later on that we can't have fine-grained
+ # time stamps
+ $TIME_HIRES_AVAILABLE = 0;
+ if(Log::Log4perl::Util::module_available("Time::HiRes")) {
+ require Time::HiRes;
+ $TIME_HIRES_AVAILABLE = 1;
+ }
+}
+
+##################################################
+sub new {
+##################################################
+ my $class = shift;
+ $class = ref ($class) || $class;
+
+ my $self = {
+ reset_time => undef,
+ @_,
+ };
+
+ $self->{time_function} = \&_gettimeofday unless
+ defined $self->{time_function};
+
+ bless $self, $class;
+
+ $self->reset();
+
+ return $self;
+}
+
+##################################################
+sub hires_available {
+##################################################
+ return $TIME_HIRES_AVAILABLE;
+}
+
+##################################################
+sub _gettimeofday {
+##################################################
+ # Return secs and optionally msecs if we have Time::HiRes
+ if($TIME_HIRES_AVAILABLE) {
+ return (Time::HiRes::gettimeofday());
+ } else {
+ return (time(), 0);
+ }
+}
+
+##################################################
+sub gettimeofday {
+##################################################
+ my($self) = @_;
+
+ my($seconds, $microseconds) = $self->{time_function}->();
+
+ $microseconds = 0 if ! defined $microseconds;
+ return($seconds, $microseconds);
+}
+
+##################################################
+sub reset {
+##################################################
+ my($self) = @_;
+
+ my $current_time = [$self->gettimeofday()];
+ $self->{reset_time} = $current_time;
+ $self->{last_call_time} = $current_time;
+
+ return $current_time;
+}
+
+##################################################
+sub time_diff {
+##################################################
+ my($time_from, $time_to) = @_;
+
+ my $seconds = $time_to->[0] -
+ $time_from->[0];
+
+ my $milliseconds = int(( $time_to->[1] -
+ $time_from->[1] ) / 1000);
+
+ if($milliseconds < 0) {
+ $milliseconds = 1000 + $milliseconds;
+ $seconds--;
+ }
+
+ return($seconds, $milliseconds);
+}
+
+##################################################
+sub milliseconds {
+##################################################
+ my($self, $current_time) = @_;
+
+ $current_time = [ $self->gettimeofday() ] unless
+ defined $current_time;
+
+ my($seconds, $milliseconds) = time_diff(
+ $self->{reset_time},
+ $current_time);
+
+ return $seconds*1000 + $milliseconds;
+}
+
+##################################################
+sub delta_milliseconds {
+##################################################
+ my($self, $current_time) = @_;
+
+ $current_time = [ $self->gettimeofday() ] unless
+ defined $current_time;
+
+ my($seconds, $milliseconds) = time_diff(
+ $self->{last_call_time},
+ $current_time);
+
+ $self->{last_call_time} = $current_time;
+
+ return $seconds*1000 + $milliseconds;
+}
+
+1;
+
+__END__
+
+=encoding utf8
+
+=head1 NAME
+
+Log::Log4perl::Util::TimeTracker - Track time elapsed
+
+=head1 SYNOPSIS
+
+ use Log::Log4perl::Util::TimeTracker;
+
+ my $timer = Log::Log4perl::Util::TimeTracker->new();
+
+ # equivalent to Time::HiRes::gettimeofday(), regardless
+ # if Time::HiRes is present or not.
+ my($seconds, $microseconds) = $timer->gettimeofday();
+
+ # reset internal timer
+ $timer->reset();
+
+ # return milliseconds since last reset
+ $msecs = $timer->milliseconds();
+
+ # return milliseconds since last call
+ $msecs = $timer->delta_milliseconds();
+
+=head1 DESCRIPTION
+
+This utility module helps tracking time elapsed for PatternLayout's
+date and time placeholders. Its accuracy depends on the availability
+of the Time::HiRes module. If it's available, its granularity is
+milliseconds, if not, seconds.
+
+The most common use of this module is calling the gettimeofday()
+method:
+
+ my($seconds, $microseconds) = $timer->gettimeofday();
+
+It returns seconds and microseconds of the current epoch time. If
+Time::HiRes is installed, it will simply defer to its gettimeofday()
+function, if it's missing, time() will be called instead and $microseconds
+will always be 0.
+
+To measure time elapsed in milliseconds, use the reset() method to
+reset the timer to the current time, followed by one or more calls to
+the milliseconds() method:
+
+ # reset internal timer
+ $timer->reset();
+
+ # return milliseconds since last reset
+ $msecs = $timer->milliseconds();
+
+On top of the time span between the last reset and the current time,
+the module keeps track of the time between calls to delta_milliseconds():
+
+ $msecs = $timer->delta_milliseconds();
+
+On the first call, this will return the number of milliseconds since the
+last reset(), on subsequent calls, it will return the time elapsed in
+milliseconds since the last call to delta_milliseconds() instead. Note
+that reset() also resets the time of the last call.
+
+The internal timer of this module gets its time input from the POSIX time()
+function, or, if the Time::HiRes module is available, from its
+gettimeofday() function. To figure out which one it is, use
+
+ if( $timer->hires_available() ) {
+ print "Hooray, we get real milliseconds!\n";
+ } else {
+ print "Milliseconds are just bogus\n";
+ }
+
+For testing purposes, a different time source can be provided, so test
+suites can simulate time passing by without actually having to wait:
+
+ my $start_time = time();
+
+ my $timer = Log::Log4perl::Util::TimeTracker->new(
+ time_function => sub {
+ return $start_time++;
+ },
+ );
+
+Every call to $timer->epoch() will then return a time value that is one
+second ahead of the value returned on the previous call. This also means
+that every call to delta_milliseconds() will return a value that exceeds
+the value returned on the previous call by 1000.
+
+=head1 LICENSE
+
+Copyright 2002-2013 by Mike Schilli E<lt>m@perlmeister.comE<gt>
+and Kevin Goess E<lt>cpan@goess.orgE<gt>.
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=head1 AUTHOR
+
+Please contribute patches to the project on Github:
+
+ http://github.com/mschilli/log4perl
+
+Send bug reports or requests for enhancements to the authors via our
+
+MAILING LIST (questions, bug reports, suggestions/patches):
+log4perl-devel@lists.sourceforge.net
+
+Authors (please contact them via the list above, not directly):
+Mike Schilli <m@perlmeister.com>,
+Kevin Goess <cpan@goess.org>
+
+Contributors (in alphabetical order):
+Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton
+Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony
+Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy
+Grundman, Paul Harrington, Alexander Hartmaier David Hull,
+Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter,
+Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope,
+Lars Thegler, David Viner, Mac Yang.
+
View Lorry Controller Status