File Coverage

blib/lib/Hardware/UPS/Perl/PID.pm

Criterion	Covered	Total	%
statement	89	128	69.5
branch	17	44	38.6
condition	0	9	0.0
subroutine	17	20	85.0
pod	7	7	100.0
total	130	208	62.5

package Hardware::UPS::Perl::PID;

#==============================================================================
# package description:
#==============================================================================
# This package supplies a set of methods to deal with PID files. For a
# detailed description see the pod documentation included at the end of this
# file.
#
# List of public methods:
# -----------------------
#   new                     - initializing a Hardware::UPS::Perl PID file
#                             object
#   setLogger               - setting the current logger
#   getLogger               - getting the current logger
#   getErrorMessage         - getting internal error messages
#   delete                  - deleting the PID file
#   getPID                  - getting the current PID
#   getPIDFile              - getting the current PID file
#
#==============================================================================

#==============================================================================
# Copyright:
#==============================================================================
# Copyright (c) 2007 Christian Reile, . All
# rights reserved. This program is free software; you can redistribute it
# and/or modify it under the same terms as Perl itself.
#==============================================================================

#==============================================================================
# Entries for Revision Control:
#==============================================================================
# Revision        : $Revision: 1.9 $
# Author          : $Author: creile $
# Last Modified On: $Date: 2007/04/17 19:47:48 $
# Status          : $State: Exp $
#------------------------------------------------------------------------------
# Modifications   :
#------------------------------------------------------------------------------
#
#   $Log: PID.pm,v $
#   Revision 1.9  2007/04/17 19:47:48  creile
#   documentation bugfixes.
#
#   Revision 1.8  2007/04/14 09:37:26  creile
#   documentation update.
#
#   Revision 1.7  2007/04/07 15:15:13  creile
#   adaptations to "best practices" style;
#   update of documentation.
#
#   Revision 1.6  2007/03/13 17:21:49  creile
#   options as anonymous hashes.
#
#   Revision 1.5  2007/03/03 21:17:23  creile
#   new variable $UPSERROR added;
#   adaptations to revised Constants.pm;
#   "return undef" replaced by "return".
#
#   Revision 1.4  2007/02/25 17:07:33  creile
#   option handling redesigned.
#
#   Revision 1.3  2007/02/05 20:36:40  creile
#   pod documentation revised.
#
#   Revision 1.2  2007/02/04 14:00:39  creile
#   public method delete() revised;
#   logging support added;
#   private method _open() renamed to _writePID();
#   update of documentation.
#
#   Revision 1.1  2007/02/01 10:53:21  creile
#   initial revision.
#
#
#==============================================================================

#==============================================================================
# module preamble:
#==============================================================================

use strict;

BEGIN {

    use vars qw($VERSION @ISA);

    $VERSION = sprintf( "%d.%02d", q$Revision: 1.9 $ =~ /(\d+)\.(\d+)/ );

    @ISA     = qw();

}

#==============================================================================
# end of module preamble
#==============================================================================

#==============================================================================
# packages required:
#------------------------------------------------------------------------------
#
#   Fcntl                           - load the C Fcntl.h defines
#   FileHandle                      - supply object methods for filehandles
#
#   Hardware::UPS::Perl::Constants  - importing Hardware::UPS::Perl constants
#   Hardware::UPS::Perl::General    - importing Hardware::UPS::Perl variables
#                                     and functions for scripts
#   Hardware::UPS::Perl::Logging    - importing Hardware::UPS::Perl methods
#                                     dealing with logfiles
#   Hardware::UPS::Perl::Utils      - importing Hardware::UPS::Perl utility
#                                     functions for packages
#
#==============================================================================

use Fcntl;
use FileHandle;

use Hardware::UPS::Perl::Constants qw(
    UPSPIDFILE
    UPSSCRIPT
);
use Hardware::UPS::Perl::General qw(
    $UPSERROR
);
use Hardware::UPS::Perl::Logging;
use Hardware::UPS::Perl::Utils qw(
    error
);

#==============================================================================
# defining user invisible package variables:
#------------------------------------------------------------------------------
#
#
#
#==============================================================================


#==============================================================================
# public methods:
#==============================================================================

sub new {

    # public method to construct a PID file object
    #
    # parameters: $class   (input) - class
    #             $options (input) - anonymous hash; options
    #
    # The following option keys are recognized:
    #
    #   PIDFile ($) - string; the PID file; optional
    #   Logger  ($) - Hardware::UPS::Perl::Logging object; the logger to use;
    #                 optional

    # input as hidden local variables
    my $class   = shift;
    my $options = @_ ? shift : {};

    # hidden local variables
    my $self    = {};       # referent to be blessed
    my $refType;            # a reference type
    my $option;             # an option
    my $logger;             # the logger object
    my $pidFile;            # the PID file

    # checking options
    $refType = ref($options);
    if ($refType ne 'HASH') {
        error("not a hash reference -- <$refType>");
    }

    # the logger; if we don't have one, we have to create our own with output
    # on STDERR
    $logger = delete $options->{Logger};

    if (!defined $logger) {
        $logger = Hardware::UPS::Perl::Logging->new()
            or return;
    }

    # the name of the PID file
    if (exists $options->{PIDFile}) {
        $pidFile = delete $options->{PIDFile};
    }
    else {
        $pidFile = UPSPIDFILE;
    }

    # checking for misspelled options
    foreach $option (keys %{$options}) {
        error("option unknown -- $option");
    }

    # blessing PID file object
    bless $self, $class;

    # initializing
    $self->{errorMessage} = q{};
    $self->_setPIDFile($pidFile);
    $self->_setPID($$);

    # initializing logging object
    $self->setLogger($logger);

    # opening file
    $self->_writePID($self->getPIDFile())
       or   do {
                $UPSERROR = $self->getErrorMessage();
                return;
            };

    # returning blessed PID file object
    return $self;

} # end of public method "new"

sub DESTROY {

    # the destructor will delete the PID file
    #
    # parameters: $self (input) - referent to a PID file object

    # input as hidden local variable
    my $self = shift;

    # delete PID file
    $self->delete();

} # end of the destructor

sub delete {

    # public method to delete a PID file
    #
    # parameters: $self (input) - referent to a PID file object

    # input as hidden local variable
    my $self = shift;

    # hidden local variables
    my $pid;                # a PID, not necessarily ours
    my $pidFile;            # the current PID file

    # getting PID file
    $pidFile = $self->getPIDFile();

    # deleting
    if (defined $pidFile and $pidFile and -w $pidFile) {

        # getting PID from file
        #
        # defining PID file handle
        my $pid_fh = new FileHandle $pidFile, O_RDONLY;

        # getting PID
        chomp($pid = <$pid_fh>);

        # closing PID file
        undef $pid_fh;

        # deleting PID file if it does exist and does belong to this process
        if ($pid != $self->getPID() and kill(0, $pid)) {
            # another process is not dead yet
            $self->{errorMessage}
                = "another instance ".UPSSCRIPT." still running .(".$pid.")";
            return 0;
        }

        # now we can safely delete
        if (unlink($pidFile)) {
            return 1;
        }
        else {
            $self->{errorMessage} = "could not delete PID file -- $!";
            return 0;
        }

    }
    else {

        # PID file unavailable
        $self->{errorMessage} = "PID file unavailable";
        return 0;

    }

} # end of public method "delete"

sub getErrorMessage {

    # public method to get the current error message
    #
    # parameters: $self (input) - referent to a PID file object

    # input as hidden local variable
    my $self = shift;

    # getting the error message
    if (exists $self->{errorMessage}) {
        return $self->{errorMessage};
    }
    else {
        return;
    }

} # end of public method "getErrorMessage"

sub getPID {

    # public method to get the current PID
    #
    # parameters: $self (input) - referent to a PID file object

    # input as hidden local variable
    my $self = shift;

    # getting PID
    if (exists $self->{pid}) {
        return $self->{pid};
    }
    else {
        return;
    }

} # end of public method "getPID"

sub getPIDFile {

    # public method to get the current PID file
    #
    # parameters: $self (input) - referent to a PID file object

    # input as hidden local variable
    my $self = shift;

    # getting PID file currently used
    if (exists $self->{file}) {
        return $self->{file};
    }
    else {
        return;
    }

} # end of public method "getPIDFile"

sub getLogger {

    # public method to get the logger
    #
    # parameters: $self (input) - referent to an PID file object

    # input as hidden local variable
    my $self = shift;

    # getting logger
    if (exists $self->{logger}) {
        return $self->{logger};
    }
    else {
        return;
    }

} # end of public method "getLogger"

sub setLogger {

    # public method to set the logger
    #
    # parameters: $self   (input) - referent to a PID file object
    #             $logger (input) - the logging object

    # input as hidden local variables
    my $self   = shift;

    1 == @_ or error("usage: setLogger(LOGGER)");
    my $logger = shift;

    if (defined $logger) {
        my $loggerRefType = ref($logger);
        ($loggerRefType eq 'Hardware::UPS::Perl::Logging')
            or error("no logger -- <$loggerRefType>");
    }

    # getting old logger
    my $oldLogger = $self->getLogger();

    # setting logger
    $self->{logger} = $logger;

    # returning old logger
    return $oldLogger;

} # end of public method "setLogger"

#==============================================================================
# private methods:
#==============================================================================

sub _writePID {

    # private method to write a PID file
    #
    # parameters: $self    (input) - referent to a PID file object
    #             $pidFile (input) - the PID file

    # input as hidden local variables
    my $self    = shift;
    my $pidFile = shift;

    # hidden local variables
    my $pid_fh;             # the PID file filehandle
    my $pid;                # the PID

    # getting the logger
    my $logger = $self->getLogger();

    # checking for an existing PID file of this name
    if ( -w $pidFile ) {

        # defining PID file handle
        $pid_fh = new FileHandle $pidFile, O_RDONLY
            or  $logger->fatal(
                    "cannot open PID file $pidFile for reading -- $!"
                );

        # getting PID
        chomp($pid = <$pid_fh>);

        # closing PID file
        undef $pid_fh;

        if (kill(0, $pid)) {
            # still running
            $logger->fatal(
                "there is already another instance of ".UPSSCRIPT." running -- pid = ".$pid
            );
        }
        else {
            # try to remove PID file
            if (!unlink($pidFile)) {
                $logger->fatal("cannot remove PID file $pidFile -- $!");
            }
        }

    }

    # now defining the PID file filehandle for writing PID to PID file
    $pid_fh = new FileHandle $pidFile, O_CREAT| O_WRONLY | O_EXCL, 0644
        or $logger->fatal("cannot create PID file $pidFile -- $!");

    # writing PID to file
    $pid = $self->getPID();
    if (defined $pid) {
        print $pid_fh "$pid\n";
    }
    else {
        $self->{errorMessage} = "PID unavailable";
        return 0;
    }

    # closing PID file
    undef $pid_fh;

    return 1;

} # end of private method "_writePID"

sub _setPID {

    # private method to set the PID
    #
    # parameters: $self (input) - referent to a PID file object
    #             $pid  (input) - the PID

    # input as hidden local variables
    my $self = shift;
    my $pid  = shift;

    # hidden local variable
    my $oldPID;         # the previous PID file

    # getting old PID
    $oldPID = $self->getPID();

    # setting PID
    $self->{pid} = $pid;

    return $oldPID;

} # end of private method "_setPID"

sub _setPIDFile {

    # private method to set the PID file
    #
    # parameters: $self    (input) - referent to a PID file object
    #             $pidFile (input) - the PID file

    # input as hidden local variables
    my $self    = shift;
    my $pidFile = shift;

    # hidden local variable
    my $oldPIDFile;         # the previous PID file

    # getting old PID file
    $oldPIDFile = $self->getPIDFile();

    # setting PID file
    $self->{file} = $pidFile;

    return $oldPIDFile;

} # end of private method "_setPIDFile"

#==============================================================================
# package return:
#==============================================================================
1;

__END__