Unix::Conf::ConfIO - This is an internal module for handling line

    use Unix::Conf;

    my $conf = Unix::Conf->_open_conf (
        NAME            => 'some_file',
        SECURE_OPEN     => 1,
        LOCK_STYLE      => 'dotlock',
    );
    $conf->die ('DEAD') unless ($conf);

    # use the file in various ways
    print while (<$conf>);
    $conf->setline (10, "this is the 11th line\n");
    $conf->close ();

# Class to cache configuration file I/O
#
# Copyright Karthik Krishnamurthy <karthik.k@extremix.net>

package Unix::Conf::ConfIO;

use 5.6.0;
use strict;
use warnings;

use Fcntl qw (:DEFAULT :mode :flock);
use Unix::Conf;

use overload '<>'	=> 'getline',
			 'bool'	=> '__interpret_as_bool',
			 '""'	=> '__interpret_as_string',
			 'eq'	=> '__interpret_as_string';

# Cache of file keyed on filenames. Value is a hash reference.
# {
#	NAME, 
#	FH, 
#	MODE,
#	PERMS,
#	DATA, 
#	TIMESTAMP,
#	LINENO, 
#	LOCK_STYLE,
#	DIRTY,
#	PERSIST,
#	IN_USE,
# }
# FH is true if the file is currently in use (the filehandle is stored there).
# TIMESTAMP is used to see if the file contents have been changed.
# PERSIST is used for those files that need to be held and not
# released even when their destructors have been called. This is needed for
# cases where the file obj goes out of scope, but the file is not closed
# here thus not releasing the lock on that file. This eases the task of
# maintaining the filehandle by the user of this module.
my %File_Cache;

# This hash contains an entry for every module that calls us. If persistent
# open is called, such files are stored as values for the key, which is the
# calling module name. Thus, when release_all is called, we know exactly which
# persistent files are to be released.
my %Calling_Modules;

	
sub open
{
	my $class = shift ();
	my $args = {
		LOCK_STYLE	=> 'flock',
		MODE		=> O_RDWR | O_CREAT,
		PERMS		=> 0600,
		SECURE_OPEN	=> 0,
		PERSIST		=> 0,
		@_,
	};

	my ($fh, $name, $timestamp, $retval);

	# do sanity check on the passed argument
	return (Unix::Conf->_err ('open', "neither filename nor filehandle passed"))
		unless (defined ($args->{FH}) || defined ($args->{NAME}));

	if ($args->{FH}) {
		return (Unix::Conf->_err ("open", "`$args->{LOCK_STYLE}' illegal with FH"))
			if ($args->{LOCK_STYLE} ne 'flock');
		return (Unix::Conf->_err ("open", "`SECURE_OPEN' illegal with FH"))
			if ($args->{SECURE_OPEN});
		# store the filehandle name as the name of the file.
		# this is needed for persistent opens where the handle 
		# is cached in $Calling_Modules.
		$args->{NAME} = "$args->{FH}";
		$args->{FILEHANDLE_PASSED} = 1;
		$fh = $File_Cache{$args->{NAME}} = $args
			unless (($fh = $File_Cache{$args->{NAME}}));
		# fh now contains the old ConfIO object if one with the same
		# name exists

		# if file is locked in our cache return Err
		return (Unix::Conf->_err ('open', "`$fh->{NAME}' already in use, locked"))
			if ($fh->{IN_USE});
		$retval = __lock ($fh) or return ($retval);
	}
	elsif ($args->{NAME}) {
		$fh = $File_Cache{$args->{NAME}} = $args
			unless (($fh = $File_Cache{$args->{NAME}}));
		# fh now contains the old ConfIO object if one with the same
		# name exists

		# if file is locked in our cache return Err
		return (Unix::Conf->_err ('open', "`$fh->{NAME}' already in use, locked"))
			if ($fh->{IN_USE});
	
		# if FH exists, file must be a persistent one. we call __checkpath
		# if SECURE_OPEN was specified, and not before. However any change in
		# modes we barf
		if ($fh->{FH}) {
			my $ret;
			$ret = __checkpath ($fh->{NAME}) or return ($ret)
				if ($args->{SECURE_OPEN} > $fh->{SECURE_OPEN});
			my ($oldmode, $newmode);
			$oldmode = $fh->{MODE} & (O_RDONLY | O_WRONLY | O_RDWR);
			$newmode = $args->{MODE} & (O_RDONLY | O_WRONLY | O_RDWR);
			return (Unix::Conf->_err ('open', "mode is not the same as in the original open"))
				if ($oldmode != $newmode); 
		}
		else {
			# file is not in cache, or is but had been previously closed.
			# we need to open file even if our cache has good data, and lock the file
			$fh->{FH} = __open (
								$fh->{NAME}, 
								$fh->{MODE}, 
								$fh->{PERMS}, 
								$fh->{SECURE_OPEN}
			) or return ($fh->{FH});

			unless ($retval = __lock ($fh)) {
				close ($fh->{FH});
				return ($retval);
			}
		}
	}
	# check timestamp even if file was held in persistent store and locked
	$timestamp = (stat ($fh->{FH}))[9];
	# if we had previously cached the file and it has not changed since
	# bless and return.
	if (!defined ($fh->{TIMESTAMP}) || $fh->{TIMESTAMP} != $timestamp) {
		# if we reach here, either we don't have the file in our cache, 
		# the cache is stale.
		return (Unix::Conf->_err ("open")) unless (seek ($fh->{FH}, 0, 0));
		my @lines = readline ($fh->{FH});
		@$fh{'DATA', 'TIMESTAMP'} = (\@lines, $timestamp);
	}

	@$fh{'LINENO', 'DIRTY'} = (-1, 0);
	$fh->{IN_USE} = 1;
	# store files that the calling module wants persisted. subsequently
	# when release_all is called by the same module, these will be actually 
	# released (locks)
	$Calling_Modules{__caller ()}{$fh->{NAME}} = 1
		if ($fh->{PERSIST});
	my $instance = $fh->{NAME};
	my $obj = bless (\$instance, $class);
	return ($obj);
}

# method instance. can also be called as a subroutine with the filename as the 
# first arg.
sub close
{
	my $self = shift ();
	my $file = ref ($self) ? $File_Cache{$$self} : $File_Cache{$self};

	return (Unix::Conf->_err ('close', "object already closed"))
		unless ($file->{FH});

	# sync file if dirty
	if ($file->{DIRTY}) {
		truncate ($file->{FH}, 0) or return (Unix::Conf->_err ("truncate"));
		sysseek ($file->{FH}, 0, 0) or return (Unix::Conf->_err ("sysseek"));

		# suppress warnings so that we don't get a warning about empty
		# array elements that we delete'ed.
		no warnings;
		syswrite ($file->{FH}, $_ ) for (@{$$file{DATA}});
	}

	$file->{TIMESTAMP} = (stat ($file->{FH}))[8];	# store new timestamp.
	$file->{IN_USE} = 0;

	# if persistent file, do not close
	return (1) if ($file->{PERSIST});

	close ($file->{FH}) || return (Unix::Conf->_err ('close'));
	__unlock ($file);
	delete ($File_Cache{$file->{NAME}}) if ($file->{FILEHANDLE_PASSED});
	undef ($file->{FH});
	return (1);
}

sub DESTROY 
{
	my $self = shift ();
	my $obj = $File_Cache{$$self};
	my $retval;

	# if FH is still set, call close
	if ($obj->{FH}) {
		$retval	= $self->close () or $retval->die ('Unix::Conf::ConfIO DESTRUCTOR failed'); 
	}
}

sub secure_open 
{
	my $self = shift ();
	my $obj = $File_Cache{$$self};
	return ($obj->{SECURE_OPEN}); 
}

sub release
{
	my $self = shift ();
	my $obj = $File_Cache{$$self};

	# if FH is still set, call close
	if ($obj->{FH}) {
		# clear PERSIST so that close below can actually close
		$obj->{PERSIST} = 0;
		my $caller = __caller ();
		#
		# check to see the sanity check works properly.
		#
		return (Unix::Conf->_err ('release', "This file was not opened with PERSIST by $caller"))
			unless (exists ($Calling_Modules{$caller}{$$self}));
		delete ($Calling_Modules{$caller}{$$self});
		return ($self->close ()); 
	}
	return (1);
}

sub release_all
{
	my $caller = __caller ();
	my ($obj, $ret);

	return (Unix::Conf->_err ('release_all', "No files were opened with PERSIST by $caller"))
		unless (exists ($Calling_Modules{$caller}));
	for (keys(%{$Calling_Modules{$caller}})) {
		$obj = $File_Cache{$_};
		$obj->{PERSIST} = 0;
		# call method close with the filename as arg
		$ret = &close ($_) or return ($ret);
	}
	delete ($Calling_Modules{$caller});
	return (1);
}

sub dirty
{
	my $self 	= $File_Cache{${shift ()}};
	$self->{DIRTY} = 1;
	return (1);
}

	
sub name 	
{
	my $self 	= $File_Cache{${shift ()}};
	return ($self->{FILENAME});
}

sub rewind
{
	my $self	= $File_Cache{${shift ()}};
	$self->{LINENO} = -1;
	return (1);
}

sub next_lineno
{
	my $self    = $File_Cache{${shift ()}};
	return (scalar (@{$self->{DATA}}));
}

sub set_scalar
{
	no warnings;
	my $self    = $File_Cache{${shift ()}};
	# release the old data
	undef ($self->{DATA});
	$self->{DATA} = [ split (/^/, ${$_[0]}) ];
	$self->{DIRTY} = 1;
	return (1);
}

sub getlines	
{ 
	my $self 	= $File_Cache{${shift ()}};
	return ($self->{DATA}); 	
}

sub setlines	
{
	my $self 	= $File_Cache{${shift ()}};
	my $openmode = $self->{MODE} & O_ACCMODE;
	return (Unix::Conf->_err ('setlines', "file $self->{FH} not opened for writing"))
		if ($openmode != O_WRONLY && $openmode != O_RDWR);
	$self->{DATA} = shift;  	
	$self->{DIRTY} = 1;
	return (1);
}

sub delete
{
    my $self    	= $File_Cache{${shift ()}};
	my $openmode = $self->{MODE} & O_ACCMODE;
	return (Unix::Conf->_err ('delete', "file $self->{FH} not opened for writing"))
		if ($openmode != O_WRONLY && $openmode != O_RDWR);
	$self->{LINENO}	= -1;
	undef (@{$self->{DATA}});
	$self->{DIRTY}	= 1;
	return (1);
}

sub lineno 		
{ 
	my $self 	= $File_Cache{${shift ()}};
	my $lineno	= shift ();
	if (defined ($lineno)) {
		return (Unix::Conf->_err ('lineno', "argument passed not numeric"))
			if ($lineno !~ /^-?\d+$/);
		return (Unix::Conf->_err ('lineno', "`$lineno' value illegal"))
			if ($lineno < -1);
		my $max = $#{$self->{DATA}};
		return (Unix::Conf->_err ('lineno', "argument passed out of bounds, max possible `$max'"))
			if ($lineno > $max);
		$self->{LINENO} = $lineno;
		return (1);
	}
	return ($self->{LINENO}); 	
}

sub getline
{
	my $self = $File_Cache{${shift ()}};
	return ( $self->{DATA}[++($self->{LINENO})] );
}

sub setline
{
	my $self = $File_Cache{${shift ()}};

	my $openmode = $self->{MODE} & O_ACCMODE;
	return (Unix::Conf->_err ('setline', "file $self->{FH} not opened for writing"))
		if ($openmode != O_WRONLY && $openmode != O_RDWR);
	$self->{DATA}[$_[0]] = $_[1];
	$self->{DIRTY} = 1;
	return (1);
}

sub append
{
	my $self = $File_Cache{${shift ()}};
	my $openmode = $self->{MODE} & O_ACCMODE;
	return (Unix::Conf->_err ('append', "file $self->{FH} not opened for writing"))
		if ($openmode != O_WRONLY && $openmode != O_RDWR);
	push (@{$self->{DATA}}, @_);
	$self->{DIRTY} = 1;
	return (1);
}

sub delete_lines
{
	my $self = $File_Cache{${shift ()}};
	my $openmode = $self->{MODE} & O_ACCMODE;
	return (Unix::Conf->_err ('delete_lines', "file $self->{FH} not opened for writing"))
		if ($openmode != O_WRONLY && $openmode != O_RDWR);
	return (Unix::Conf->_err ('delete_lines', "offset not specified"))
		unless (defined ($_[0]));
	my $start = $_[0];	
	my $end = $_[1] ? $_[1] : $start;
	delete (@{$self->{DATA}}[$start..$end]);
	$self->{DIRTY} = 1;
	return (1);
}

	
sub ungetline			
{  
	my $self = $File_Cache{${shift ()}};
	($self->{LINENO})--; 	
	return (1);
}

sub __caller { return ((caller (1))[0]); }

# If a ConfIO object has a defined filehandle it is true, else false
sub __interpret_as_bool	
{
	my $self = $File_Cache{${shift ()}};
	return ($self->{IN_USE}); 
}

sub __interpret_as_string
{
	my $self = shift;
	return "$$self";
}

sub __lock ($)
{
	my ($fh) = @_;

	($fh->{LOCK_STYLE} eq 'flock') 	&& do {
		flock ($fh->{FH}, LOCK_EX | LOCK_NB) || return (Unix::Conf->_err ('flock'));
		return (1);
	};
	($fh->{LOCK_STYLE} eq 'dotlock') 	&& do {
		return (__dotlock ($fh->{NAME}));
	};
}

sub __unlock ($)
{
	my ($fh) = @_;

	($fh->{LOCK_STYLE} eq 'flock')		&& do {
		# no unlocking necessary. when the appropriate fh is released or
		# close called on it the lock will be automatically released.
		return (1);
	};
	($fh->{LOCK_STYLE} eq 'dotlock')	&& do {
		unlink ("$fh->{NAME}.lock") or return (Unix::Conf->_err ('unlink'));
	    return (1);
	};
}

# ARGUMENTS: filename to be locked
# RETURN:    BOOL indicating failure or success.
# Locks files.
# Create a unique file from the filename (filename.pid). Write our PID into 
# pidfile. link to filename.lock. If filename.lock nlink is 2 then we have 
# succeded, unlink pidfile. If link fails then read the PID from the (already) 
# existing lockfile. Post 0 to that PID. If no such process exists, lock file 
# is stale and hence unlink it. loop again. All of this is because, opening
# the actual lock file and writing out the PID into it is not atomic. So we
# create an tmp unique file, write out our PID into it and then try linking it
# which is atomic, since it translates into a single system call.
sub __dotlock ($)
{
    my $file = shift;
    my ($pidfile, $lockfile) = ("$file.$$", "$file.lock");
    my $retval;

    sysopen (FH, $pidfile, O_WRONLY | O_CREAT || O_EXCL, 0600)
        or return (Unix::Conf->_err ('sysopen'));
    print FH "$$\x00"	or return (Unix::Conf->_err ('new'));
    CORE::close (FH)	or return (Unix::Conf->_err ('close'));

    # keep looping until we lock or return inside loop
    until (link ($pidfile, $lockfile)) {
        my $pid;
        unless (sysopen (FH, $lockfile, O_RDONLY)) {
            $retval = Unix::Conf->_err ('sysopen');
            goto ERR_RET;
        }
        $pid = <FH> || goto ERR_RET;
        $pid = substr ($pid, 0, -1);
        CORE::close (FH) || goto ERR_RET;
        # if process is alive unlink opened files and return undef
        if (kill (0, $pid)) {
            $retval = Unix::Conf->_err ('kill');
            goto ERR_RET;
        }
        unlink ($lockfile);
    }

    $retval = __check_link_count ($pidfile);
    unlink ($pidfile);
    return $retval;

ERR_RET:
    unlink ($pidfile);
    return ($retval);
}

# check link count of argument and return true if link count == 2
sub __check_link_count ($)
{
    my $file = shift;
    my $nlink;
    (undef, undef, undef, $nlink) = stat ($file)
        or return (Unix::Conf->_err ('stat'));

    return (1) if ($nlink == 2);
    # failure. set _err and return failure
    return (Unix::Conf->_err ('__check_link_count', 'link count of $file is $nlink'));
}

# ARGUMENTS: file_path, mode, perms, secure
# if secure is true then security checks are done on the pathname to see
# if any component is writeable by anyone other than root. if so return
# error.
sub __open ($$$$)
{
	my ($file_path, $mode, $perms, $secure) = @_;
	
	my ($fh, $ret);
    sysopen ($fh, $file_path, $mode, $perms) || 
		return (Unix::Conf->_err ("sysopen ($file_path)"));

	if ($secure) {
		$ret = __checkpath ($file_path) or return ($ret);
	}
	return ($fh);
}

sub __checkpath ($)
{
	my $file_path = $_[0];

	my @chopped = split (/\//, $file_path);
	# if $chopped[0] is "" then the path was absolute.
	if ($chopped[0]) {
		# is using `pwd` safe ?
		my $cwd = `pwd`;
		chomp ($cwd);
		unshift (@chopped, split (/\//, $cwd));
	}
	my ($uid, $gid, $mode);
	my $path = "";
	foreach (@chopped) {
		# on the second iteration $path will be just '/'.
		$path .= ($path =~ /^\/$/) ? "$_" : "/$_";
		($mode, $uid, $gid) = (stat ($path))[2,4,5];
		# check ownership
		return (Unix::Conf->_err ('__open', "$file_path resides in an insecure path ($path)")) 
			if ($uid != 0 || $gid != 0);
		# check to see if others have write perms
		return (Unix::Conf->_err ('__open', "$file_path resides in an insecure path ($path)"))
			if ($mode & S_IWOTH);
	}
	return (1);
}

1;
__END__