File Coverage

blib/lib/PML/File.pm

Criterion	Covered	Total	%
statement	46	57	80.7
branch	12	24	50.0
condition	3	5	60.0
subroutine	4	4	100.0
pod	0	2	0.0
total	65	92	70.6

#! /usr/bin/perl -w
################################################################################
#
# File.pm (do cool things with files)
#
################################################################################
#
# Package
#
################################################################################
package PML::File;
################################################################################
#
# Includes
#
################################################################################
use strict;
################################################################################
#
# Global Variables and Default Settings
#
################################################################################
use vars qw($VERSION $DATE $ID);
$VERSION	= '0.01';
$DATE		= 'Wed May 24 16:58:17 2000';
$ID		= '$Id: File.pm,v 1.4 2000/07/31 17:13:46 pjones Exp $';

my $pkg = 'file::';
my $local = "${pkg}local";
my $prefix = "${pkg}prefix";
my $dprefix = 'conf';
################################################################################
#
# Code Start
#
################################################################################
PML->register(name=>"${pkg}cat", token=>\&cat);
PML->register(name=>"${pkg}conf",token=>\&conf);
################################################################################
#
# ==== cat ==== ################################################################
#
#   Arguments:
#	See PML Docs
#
#     Returns:
#	The contents of the files
#
# Description:
#	Returns the contents of a bunch of files
#
################################################################################
sub cat
{
	my ($self, $token) = @_;
	my ($name, $a, $b) = @{$token->data};
	my (@files, $file, $result);

	@files = $self->tokens_execute($a);

	foreach $file (@files) {
		unless (open CAT, $file) {
			if ($self->warning) {
				print STDERR "can't open file '$file': $!\n";
			}
			next;
		}

		$result .= join '', ;
		close CAT;
	}

	return $result;
} # <-- End cat -->
################################################################################
#
# ==== conf ==== ###############################################################
#
#   Arguments:
#	See PML Docs
#
#     Returns:
#	Nothing
#
# Description:
#	Loads variables from config file
#
################################################################################
sub conf
{
	my ($self, $token) = @_;
	my ($name, $a, $b) = @{$token->data};
	my (@files, $file, $key, $value, $lastline);

	@files = $self->tokens_execute($a);

	foreach $file (@files) {
		unless (open CONF, $file) {
			if ($self->warning) {
				print STDERR "can't open file '$file': $!\n";
			}
			next;
		}

		$lastline = '';
		while () {
			next if /^\s*$/ or /^\s*#/;

			if (s|\\$||) {
				chomp;
				$lastline =~ s/\s+$/ /; s/^\s+//;
				$lastline .= $_;
				next unless eof CONF;
			}

			if (length $lastline) {
				$lastline =~ s/\s+$/ /; s/^\s+//;
				$_ = $lastline . $_;
				$lastline = '';
			}

			s/^\s+//; s/\s+$//; chomp;
			($key, $value) = split(/\s*=\s*/, $_, 2);

			unless ($key) {
				if ($self->warning) {
					print STDERR "no config variable on line $. of file '$file'\n";
				}
				next;
			}

			if ($self->[PML->PML_V]{$local}) {
				$self->[PML->PML_V]{$key} =  $value || '';
			} elsif ($self->[PML->PML_V]{$prefix}) {
				$self->[PML->PML_V]{$self->[PML->PML_V]{$prefix}}{$key} = $value;
			} else {
				$self->[PML->PML_V]{$dprefix}{$key} = $value;
			}
		}

		close CONF;
	}

	return undef;
} # <-- End conf -->
################################################################################
#                              END-OF-SCRIPT                                   #
################################################################################
=head1 NAME

File.pm

=head1 SYNOPSIS

Quick Usage

=head1 DESCRIPTION

What does it do?

=head1 OPTIONS

Long Usage

=head1 EXAMPLES

Example usage

=head1 SEE ALSO

perl(1)

=head1 AUTHOR

Peter J Jones
[e-mail]

=cut

1;
__END__