view release on metacpan or  search on metacpan

File.pm  view on Meta::CPAN

	$self->debug("alive(): $pid");

	if ($pid && $pid != $$ && kill(0, $pid)) {
        return $self->verify($pid) ? $pid : 0;
        }

	return 0;
	}

=head2 touch

Causes for the current process id to be written to the I<pidfile>.

=cut

sub touch {
	shift->write();
	}

=head2 release

This method is used to delete the I<pidfile> and is automatically called by DESTROY method.  It should thus be unnecessary to call it directly.

=cut

sub release {
	my $self = shift;
	$self->debug("release()");
	unlink($self->{path}) || warn $!;
	}

=head2 locktime [hash[-ref]]

This method returns the I<mtime> of the I<pidfile>.

=cut

sub locktime {
    my $self = shift;
    return (stat($self->{path}))[10];
	}

# -- support functionality ---------------------------------------------------

sub verify {
    my ($self, $pid) = @_;
    return 1 unless $self->{verify};

	my $ret = 0;
    $self->debug("verify(): OS = $^O");
    if ($^O =~ /linux|freebsd|cygwin|darwin/i) {
        my $me = $self->{verify};
		if (!$me || $me eq "1") {
			$me = $ME;
			if ($^O eq "cygwin") {
				$^X =~ m|([^/]+)$|;
				($me = $1) =~ s/\.exe$//;
				}
			}
		my $cols = delete($ENV{'COLUMNS'}); # prevents `ps` from wrapping
        my @ps = split m|$/|, qx/ps -fp $pid/
            || die "ps utility not available: $!";
        s/^\s+// for @ps;   # leading spaces confuse us

		$ENV{'COLUMNS'} = $cols if defined($cols);
        no warnings;    # hate that deprecated @_ thing
        my $n = split(/\s+/, $ps[0]);
        @ps = split /\s+/, $ps[1], $n;
        $ret = $ps[$n - 1] =~ /\Q$me\E/;;
        }

	$self->debug(" - ret: [$ret]");
	$ret;
    }

# Returns the process id currently stored in the file set.  If the method
# is passed a file handle, it will return the value, leaving the file handle
# locked.  This is useful for atomic operations where the caller needs to
# write to the file after the read without allowing other dirty writes.
# 
# Please note, when passing a file handle, caller is responsible for
# closing it. Also, file handles must be passed by reference!

sub read {
	my ($self, $fh) = @_;

	sysopen($fh, $self->{path}, O_RDWR|O_CREAT)
		|| die qq/Cannot open pid file "$self->{path}": $!\n/;
	flock($fh, LOCK_EX | LOCK_NB)
        || die qq/pid "$self->{path}" already locked: $!\n/;
	my ($pid) = <$fh> =~ /^(\d+)/;
	close $fh if @_ == 1;

	$self->debug("read(\"$self->{path}\") = " . ($pid || ""));
	return $pid;
	}

# Causes for the current process id to be written to the selected
# file.  If a file handle it passed, the method assumes it has already
# been opened, otherwise it opens its own. Please note that file
# handles must be passed by reference!

sub write {
	my ($self, $fh) = @_;

	$self->debug("write($$)");
	if (@_ == 1) {
		sysopen($fh, $self->{path}, O_RDWR|O_CREAT)
			|| die qq/Cannot open pid file "$self->{path}": $!\n/;
		flock($fh, LOCK_EX | LOCK_NB)
        	|| die qq/pid "$self->{path}" already locked: $!\n/;
		}
	sysseek  $fh, 0, 0;
	truncate $fh, 0;
	syswrite $fh, "$$\n", length("$$\n");
	close $fh || die qq/Cannot write pid file "$self->{path}": $!\n/;
	}

sub args {
	!defined($_[0]) ? () : ref($_[0]) ? %{$_[0]} : @_;
	}