do i grok pidfiles?

zengargoyle has asked for the wisdom of the Perl Monks concerning the following question:

Proc::PID::File gave me some trouble recently and i may be reinventing the wheel but i need a pidfile module that DWIM.

# i want to do something like this...

=begin example

my $pf = pidfile->new;

if ($pf->is_alive) {
        warn "already running!\n";
        # Proc::PID::File would unlink the pidfile of the
        # active daemon here!
        exit;
} else {
        # if is_alive == 0 Proc::PID::File would go ahead and
        # write the current $$ to the pidfile here.
        warn "starting\n";
        Proc::Daemon::Init;
        $pf->write;    # oops! already written by parent!
}

=cut
[download]

which seems a little weird to me, but maybe i don't grok pidfiles. what i came up with was this:

package pidfile;

use 5.006;
use strict;
use warnings;

our $VERSION = '0.0.1';

use Carp;
use IO::File;
use Fcntl qw(:flock);
use File::Basename;
use File::Spec;

our %PF_Default = (
    path => '/tmp',
    name => basename($0),
    mode => 0644,
);

# Preloaded methods go here.

sub new {
    my ( $class, %args ) = @_;
    my %pf = ( %PF_Default, %args );
    croak "path => $pf{path} is not a directory" unless -d $pf{path};
    croak "path => $pf{path} is not readable"    unless -r _;
    croak "path => $pf{path} is not writeable"   unless -w _;
    croak "name must be set" unless defined $pf{name} and length $pf{n
+ame};

    return bless \%pf, $class;
}

sub pidfile {
    my $s = shift;
    return $s->{file} ||= File::Spec->catfile($s->{path}, $s->{name}."
+.pid");
}

sub activate {
    my $s = shift;
    croak sprintf "%s contains a living pid %d\n", $s->pidfile, $s->ge
+tpid
      if ( $s->is_alive );
    $s->setpid;
}

sub setpid {
    my $s = shift;
    my $f = IO::File->new( $s->pidfile, O_RDWR | O_CREAT, $PF_Default{
+mode} );
    croak sprintf "can't open %s for writing: $!\n", $s->pidfile
      unless defined $f;
    croak sprintf "can't lock_ex %s: $!\n", $s->pidfile
      unless flock $f, LOCK_EX;
    $f->setpos(0);
    $f->truncate(0);
    $f->print( "$$", $/ );
    $f->close;
    return 1;
}

sub getpid {
    my $s = shift;
    my $f = IO::File->new( $s->pidfile, O_RDONLY );
    croak sprintf "can't open %s for reading: $!\n", $s->pidfile
      unless defined $f;
    croak sprintf "can't lock_sh %s: $!\n", $s->pidfile
      unless flock $f, LOCK_SH;
    my $l = $f->getline; 
    $f->close; 
    chomp $l;
    croak sprintf "%s contained non-numeric pid\n", $s->pidfile
      unless $l == $l + 0;
    return $l+0;
}

sub is_alive {
    my $s = shift;
    return 0 unless -f $s->pidfile;
    return kill 0, $s->getpid;
}   

sub is_self {
    my $s = shift;
    return 0 unless -f $s->pidfile;
    return $$ == $s->getpid;
}
    
sub DESTROY {
    my $s = shift;
    unlink $s->pidfile if $s->is_self;
}   
    
1;  
__END__
[download]

Comments, Suggestions, a good Smack with a Stick?

Comment on do i grok pidfiles? Select or Download Code

Replies are listed 'Best First'.
•Re: do i grok pidfiles? by merlyn (Sage) on Feb 16, 2003 at 16:18 UTC
You should get a module name from the module-name gods. You should never name a module beginning with a lowercase character: those are reserved for Perl pragmata. -- Randal L. Schwartz, Perl hacker Be sure to read my standard disclaimer if this is a reply.	[reply]
Re: •Re: do i grok pidfiles? by zengargoyle (Deacon) on Feb 16, 2003 at 16:35 UTC
point taken and taken. `$ ls ../Pidfile MANIFEST Makefile.PL Pidfile-0.0.1.tar.gz README foo.pl t Makefile Makefile.old Pidfile.pm blib pm_to_blib` [download] Pidfile showed promise, but i was trying to be fancy and get by with Pidfile::new returning a simple blessed scalar reference of the pidfilename. i couldn't quite pull it off gracefully =(.	[reply] [d/l]
Re: Re: •Re: do i grok pidfiles? by jdporter (Paladin) on Feb 16, 2003 at 18:36 UTC
... and furthermore, that top-level names should not be used if you're expecting to put this thing on CPAN and have the world adopt it. (Allowances are made for large, complex systems like application frameworks.) Be sure to read the appropriate documentation: Part 2, section 5, of The Perl 5 Module List PAUSE jdporter The 6th Rule of Perl Club is -- There is no Rule #6.	[reply]
Re^4: do i grok pidfiles? by zengargoyle (Deacon) on Feb 16, 2003 at 20:36 UTC
pidfiles test 00_basic.t by zengargoyle (Deacon) on Feb 16, 2003 at 16:06 UTC
use Test::More tests => 30; #use Test::More qw(no_plan); BEGIN { use_ok( 'pidfile' ); } require_ok( 'pidfile'); #ok( 1 == 1, 'trust no one'); print "# TEST_VERBOSE = $ENV{TEST_VERBOSE}$/"; print <<'_EOT_' if ($ENV{TEST_VERBOSE}); # use pidfile; # my $pf = pidfile->new( # Carp::croak's on f +ailure. # path => '/tmp', # default (may chang +e) # name => File::Basename::basename($0), # default # ); # # Methods: is_alive, is_self, activate, (pidfile, getpid, setpid) # DESTROY: unlink $self->pidfile if $self->is_self # _EOT_ my $pf = pidfile->new(); isa_ok( $pf, 'pidfile', 'object'); my $pidfile; is( $pidfile = $pf->pidfile, '/tmp/00_basic.t.pid', "object is the def +ault: $pid file"); ok( !-f $pidfile, "$pidfile does not exist"); ok( $pf->is_alive == 0, "is_alive == 0"); ok( $pf->activate == 1, "activate == 1"); ok( -f $pidfile, "$pidfile now exists"); my $p; { local @ARGV; unshift @ARGV, $pidfile; $p = <>; } ok( $pf->getpid == $p, "getpid matches contents of $pidfile"); ok( $pf->getpid == $$, 'getpid == $$'); ok( $pf->is_alive == 1, "is_alive == 1"); ok( $pf->is_self == 1, "is_self == 1"); eval { $pf->activate }; like( $@, qr/contains a living pid/, 'double activate fails'); $pf = undef; ok( !-f $pidfile, "object gone, $pidfile gone"); my $pf = pidfile->new(); ok( $pf->is_alive == 0, "is_alive == 0"); ok( $pf->is_self == 0, "is_self == 0"); $pf = undef; my $pid; if (defined($pid = fork)) { if ($pid) { ok( 1, "woot! you have a fork! testing a child."); sleep 2; my $pf = pidfile->new(name => '00_basic.t.child'); isa_ok( $pf, 'pidfile', 'parent'); ok($pf->is_alive == 1, 'parent is_alive == 1'); ok($pf->is_self == 0, 'parent is_self == 0'); ok($pf->getpid != $$, 'parent getpid != $$'); ok($pf->getpid == $pid, 'parent getpid == child_pid_fr +om_fork'); eval { $pf->activate }; like( $@, qr/contains a living pid/, 'parent double ac +tivate fai ls'); kill 'TERM', $pid; waitpid $pid, 0; ok($pf->is_alive == 0, 'child has been TERMinated'); ok(!-f '00_basic.t.child', "child's pidfile gone"); # } else { # child my $pf = pidfile->new(name => '00_basic.t.child'); $pf->activate; sleep 300; } } else { ok( 0, 'forking failure'); } eval { $pf = pidfile->new( path => '/etc' ) }; like( $@, qr/not writeable/, "/etc isn't writeable by me"); eval { $pf = pidfile->new( path => '/etc/passwd' ) }; like( $@, qr/not a directory/, "/etc/passwd isn't even a directory"); ok( 1, "if -w and -d work, -r had better!"); eval { $pf = pidfile->new( name => '' ) }; like( $@, qr/name must be set/, "blank name fails"); eval { $pf = pidfile->new( name => undef ) }; like( $@, qr/name must be set/, "undef name fails"); [download] $ perl 00_basic.t 1..30 ok 1 - use pidfile; ok 2 - require pidfile; # TEST_VERBOSE = ok 3 - object isa pidfile ok 4 - object is the default: /tmp/00_basic.t.pid ok 5 - /tmp/00_basic.t.pid does not exist ok 6 - is_alive == 0 ok 7 - activate == 1 ok 8 - /tmp/00_basic.t.pid now exists ok 9 - getpid matches contents of /tmp/00_basic.t.pid ok 10 - getpid == $$ ok 11 - is_alive == 1 ok 12 - is_self == 1 ok 13 - double activate fails ok 14 - object gone, /tmp/00_basic.t.pid gone ok 15 - is_alive == 0 ok 16 - is_self == 0 ok 17 - woot! you have a fork! testing a child. ok 18 - parent isa pidfile ok 19 - parent is_alive == 1 ok 20 - parent is_self == 0 ok 21 - parent getpid != $$ ok 22 - parent getpid == child_pid_from_fork ok 23 - parent double activate fails ok 24 - child has been TERMinated ok 25 - child's pidfile gone ok 26 - /etc isn't writeable by me ok 27 - /etc/passwd isn't even a directory ok 28 - if -w and -d work, -r had better! ok 29 - blank name fails ok 30 - undef name fails	[reply] [d/l]