view release on metacpan or  search on metacpan

ConfigFile.pm  view on Meta::CPAN

# Preloaded methods go here.

# Create a new ConfigFile (or, more likely, a ConfigFile subclass) object.
# Opens the specified file and calls the read method (which will be located
# in the subclass package) to initialize the object data structures
sub new {
    my ($pkg, $filename, %opt) = @_;

    # Initialize the object reference
    my $this = {
	filename    =>	$filename,
	handle	    =>	undef,
	locked	    =>	0,
	lockfh	    =>	undef,
	lockfile    =>	"$filename.lock",
	locking	    =>	"dotlock",
	mode	    =>	"r+",
	seq	    =>	[ ]
    };
    bless $this, $pkg;

    # Set options
    $this->lockfile($opt{lockfile}) if defined $opt{lockfile};
    $this->locking($opt{locking}) if defined $opt{locking};
    $this->mode($opt{mode}) if defined $opt{mode};

    # Get a filehandle
    my $fh = new IO::File $this->filename, $this->mode;
    return undef unless defined($fh);
    $this->fh($fh);

    # Do file locking - this must happen before read is called or we could
    # end up with stale data in memory
    if ($this->mode eq "r") {
	$this->lock("shared") or return undef;
    }
    else {
	$this->lock() or return undef;
    }

    # Initialize object structure from the file
    if (exists $opt{readopts}) {
	$this->read($this->fh, $opt{readopts}) or return undef;
    }
    else {
	$this->read($this->fh) or return undef;
    }
    return $this;
}


# Commit in-memory changes to disk
sub commit {
    my ($this, %opt) = @_;

    return 0 if $this->mode eq "r";
    my $tempname = $this->filename . ".tmp." . $$;
    my $fh = new IO::File ">$tempname" or return 0;
    my ($mode, $uid, $gid) = (stat $this->fh)[2,4,5];
    chown $uid, $gid, $tempname;
    chmod $mode, $tempname;
    if (exists $opt{writeopts}) {
	$this->write($fh, $opt{writeopts}) or return 0;
    }
    else {
	$this->write($fh) or return 0;
    }
    undef $fh;
    if (defined $opt{backup}) {
	rename $this->filename, $this->filename . $opt{backup};
    }
    return rename $tempname, $this->filename;
}


# This method is absolutely necessary to prevent leftover lock files
sub DESTROY {
    my $this = shift;

    $this->unlock() or croak "Can't unlock file: $!";
    $this->fh->close();
}


# Filename accessor
sub filename {
    my $this = shift;
    @_ ? $this->{filename} = shift : $this->{filename};
}


# Filehandle accessor
sub fh {
    my $this = shift;
    @_ ? $this->{handle} = shift : $this->{handle};
}


# Locking method accessor
sub locking {
    my $this = shift;

    return $this->{locking} unless @_;
    my $lockmethod = shift;
    return undef unless grep { $lockmethod eq $_ } qw(flock dotlock none);
    $this->{locking} = $lockmethod;
}


# Lock filehandle accessor
sub lockfh {
    my $this = shift;
    @_ ? $this->{lockfh} = shift : $this->{lockfh};
}


# Lock file name accessor
sub lockfile {
    my $this = shift;
    @_ ? $this->{lockfile} = shift : $this->{lockfile};