File Coverage

blib/lib/Unix/ConfigFile.pm

Criterion	Covered	Total	%
statement	111	137	81.0
branch	46	88	52.2
condition	3	3	100.0
subroutine	23	24	95.8
pod	8	16	50.0
total	191	268	71.2

package Unix::ConfigFile;

# $Id: ConfigFile.pm,v 1.6 2000/05/02 15:49:19 ssnodgra Exp $

use 5.004;
use strict;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $LOCKEXT);
use Carp;
use IO::File;
use Fcntl qw(:flock);
use Text::Tabs;

require Exporter;

@ISA = qw(Exporter);
# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.
@EXPORT = qw(

);
$VERSION = '0.06';

# Package variables
my $SALTCHARS = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789/.";

# 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};
}


# Mode accessor
sub mode {
    my $this = shift;
    return $this->{mode} unless @_;
    my $mode = shift;
    return undef unless grep { $mode eq $_ } qw(r r+ w);
    $this->{mode} = $mode;
}


# Obtain a lock on the file.  You can pass "shared" to request a shared lock;
# the default is exclusive.  This function is somewhat inconsistent at the
# moment since it will block with the flock method but return an error if the
# dotlock method fails.
sub lock {
    my $this = shift;

    return 1 if ($this->locking eq "none");
    return 0 if $this->{locked};
    if ($this->locking eq "flock") {
	@_ ? flock $this->fh, LOCK_SH : flock $this->fh, LOCK_EX;
    }
    elsif ($this->locking eq "dotlock") {
	# We only support exclusive locks with dotlock
	my $fh = new IO::File $this->lockfile, O_CREAT|O_EXCL|O_RDWR;
	return 0 unless defined($fh);
	$this->lockfh($fh);
    }
    $this->{locked} = 1;
}


# Unlock the file
sub unlock {
    my $this = shift;

    # NOTE: Originally I wasn't unlinking the lock file unless the lock
    # filehandle was defined.  This led to the rather unexpected discovery
    # the Perl would sometimes destroy the filehandle before destroying
    # the object during program shutdown.  Thus, we now check if locked
    # is set, which happens only if a lock is successfully acquired.
    # This also prevents us from unlinking someone else's lock file.

    return 1 if ($this->locking eq "none");
    return 0 unless $this->{locked};
    $this->{locked} = 0;
    if ($this->locking eq "flock") {
	flock $this->fh, LOCK_UN;
	return 1;
    }
    elsif ($this->locking eq "dotlock") {
	$this->lockfh->close() if defined($this->lockfh);
	my $result = unlink $this->lockfile;
	return ($result == 1);
    }
}


# Encrypts a plaintext password with a random salt
# This is provided for use with the subclasses
sub encpass {
    my ($this, $pass) = @_;

    my $salt = substr($SALTCHARS, int(rand(length($SALTCHARS))), 1) .
	       substr($SALTCHARS, int(rand(length($SALTCHARS))), 1);
    crypt($pass, $salt);
}


# Return the file sequence
sub sequence {
    my $this = shift;
    return @{$this->{seq}};
}


# Append information to the file sequence
sub seq_append {
    my $this = shift;
    push @{$this->{seq}}, @_;
}


# Insert information into the file sequence before the given data
sub seq_insert {
    my $this = shift;
    my $data = shift;

    for (my $i = 0; $i < @{$this->{seq}}; $i++) {
	if ($this->{seq}[$i] eq $data) {
	    splice @{$this->{seq}}, $i, 0, @_;
	    return 1;
	}
    }
    return 0;
}


# Remove the specified data from the file sequence
sub seq_remove {
    my ($this, $data) = @_;

    for (my $i = 0; $i < @{$this->{seq}}; $i++) {
	if ($this->{seq}[$i] eq $data) {
	    splice @{$this->{seq}}, $i, 1;
	    return 1;
	}
    }
    return 0;
}


# Joinwrap is a utility function that happens to be useful in several modules
# This thing was a bitch to get working 100% right, so use caution.  :-)
sub joinwrap {
    my ($this, $linelen, $head, $indent, $delim, $tail, @list) = @_;

    my $result = "";
    my $line = 0;
    $linelen -= length(expand($tail));
    while (@list) {
	my $curline = $result ? $indent : $head;
	$curline =~ s/%n/$line/;
	my $appended = 0;
	while (@list && length(expand($curline . $delim . $list[0])) <= $linelen) {
	    $curline .= $delim if $appended;
	    $curline .= shift @list;
	    $appended++;
	}
	# Special case - element is longer than linelen
	$curline .= shift @list unless $appended;
	# Append newline if this isn't the first line
	$result .= "\n" if $result;
	$result .= $curline;
	# Append tail unless this is the last line
	$result .= $tail if @list;
	$line++;
    }
    $result ? $result : $head;
}


# Autoload methods go after =cut, and are processed by the autosplit program.

1;
__END__