File Coverage

blib/lib/Parse/DebControl.pm

Criterion	Covered	Total	%
statement	157	196	80.1
branch	64	88	72.7
condition	12	20	60.0
subroutine	20	21	95.2
pod	7	7	100.0
total	260	332	78.3

package Parse::DebControl;

###########################################################
#       Parse::DebControl - Parse debian-style control
#		files (and other colon key-value fields)
#
#       Copyright 2003 - Jay Bonci
#       Licensed under the same terms as perl itself
#
###########################################################

use strict;
use IO::Scalar;
use Compress::Zlib;
use LWP::UserAgent;

use vars qw($VERSION);
$VERSION = '2.005';

sub new {
	my ($class, $debug) = @_;
	my $this = {};

	my $obj = bless $this, $class;
	if($debug)
	{
		$obj->DEBUG();
	}
	return $obj;
};

sub parse_file {
	my ($this, $filename, $options) = @_;
	unless($filename)
	{
		$this->_dowarn("parse_file failed because no filename parameter was given");
		return;
	}

	my $fh;
	unless(open($fh,"$filename"))
	{
		$this->_dowarn("parse_file failed because $filename could not be opened for reading");
		return;
	}

	return $this->_parseDataHandle($fh, $options);
};

sub parse_mem {
	my ($this, $data, $options) = @_;

	unless($data)
	{
		$this->_dowarn("parse_mem failed because no data was given");
		return;
	}

	my $IOS = new IO::Scalar \$data;

	unless($IOS)
	{
		$this->_dowarn("parse_mem failed because IO::Scalar creation failed.");
		return;
	}

	return $this->_parseDataHandle($IOS, $options);

};

sub parse_web {
	my ($this, $url, $options) = @_;

	unless($url)
	{
		$this->_dowarn("No url given, thus no data to parse");
		return;
	}

	my $ua = LWP::UserAgent->new;

	my $request = HTTP::Request->new(GET => $url);

	unless($request)
	{
		$this->_dowarn("Failed to instantiate HTTP Request object");
		return;
	}

	my $response = $ua->request($request);

	if ($response->is_success) {
		return $this->parse_mem($response->content(), $options);
	} else {
		$this->_dowarn("Failed to fetch $url from the web");
		return;
	}
}

sub write_file {
	my ($this, $filenameorhandle, $dataorarrayref, $options) = @_;

	unless($filenameorhandle)
	{
		$this->_dowarn("write_file failed because no filename or filehandle was given");
		return;
	}

	unless($dataorarrayref)
	{
		$this->_dowarn("write_file failed because no data was given");
		return;
	}

	my $handle = $this->_getValidHandle($filenameorhandle, $options);

	unless($handle)
	{
		$this->_dowarn("write_file failed because we couldn't negotiate a valid handle");
		return;
	}

	my $string = $this->write_mem($dataorarrayref, $options);
	$string ||= "";

	print $handle $string;
	close $handle;

	return length($string);
}

sub write_mem {
	my ($this, $dataorarrayref, $options) = @_;

	unless($dataorarrayref)
	{
		$this->_dowarn("write_mem failed because no data was given");
		return;
	}

	my $arrayref = $this->_makeArrayref($dataorarrayref);

	my $string = $this->_makeControl($arrayref);

	$string .= "\n" if $options->{addNewline};

	$string = Compress::Zlib::memGzip($string) if $options->{gzip};

	return $string;
}

sub DEBUG
{
        my($this, $verbose) = @_;
        $verbose = 1 unless(defined($verbose) and int($verbose) == 0);
        $this->{_verbose} = $verbose;
        return;

}

sub _getValidHandle {
	my($this, $filenameorhandle, $options) = @_;

	if(ref $filenameorhandle eq "GLOB")
	{
		unless($filenameorhandle->opened())
		{
			$this->_dowarn("Can't get a valid filehandle to write to, because that is closed");
			return;
		}

		return $filenameorhandle;
	}else
	{
		my $openmode = ">>";
		$openmode=">" if $options->{clobberFile};
		$openmode=">>" if $options->{appendFile};

		my $handle;

		unless(open $handle,"$openmode$filenameorhandle")
		{
			$this->_dowarn("Couldn't open file: $openmode$filenameorhandle for writing");
			return;
		}

		return $handle;
	}
}

sub _makeArrayref {
	my ($this, $dataorarrayref) = @_;

        if(ref $dataorarrayref eq "ARRAY")
        {
		return $dataorarrayref;
        }else{
		return [$dataorarrayref];
	}
}

sub _makeControl
{
	my ($this, $dataorarrayref) = @_;

	my $str = "";

	foreach my $stanza(@$dataorarrayref)
	{
		foreach my $key(keys %$stanza)
		{
			$stanza->{$key} ||= "";

			my @lines = split("\n", $stanza->{$key});
			if (@lines) {
				$str.="$key\: ".(shift @lines)."\n";
			} else {
				$str.="$key\:\n";
			}

			foreach(@lines)
			{
				if($_ eq "")
				{
					$str.=" .\n";
				}
				else{
					$str.=" $_\n";
				}
			}

		}

		$str ||= "";
		$str.="\n";
	}

	chomp($str);
	return $str;

}

sub _parseDataHandle
{
	my ($this, $handle, $options) = @_;

	my $structs;

	unless($handle)
	{
		$this->_dowarn("_parseDataHandle failed because no handle was given. This is likely a bug in the module");
		return;
	}

	if($options->{tryGzip})
	{
		if(my $gunzipped = $this->_tryGzipInflate($handle))
		{
			$handle = new IO::Scalar \$gunzipped
		}
	}

	my $data = $this->_getReadyHash($options);

	my $linenum = 0;
	my $lastfield = "";

	foreach my $line (<$handle>)
	{
		#Sometimes with IO::Scalar, lines may have a newline at the end

		#$line =~ s/\r??\n??$//; #CRLF fix, but chomp seems to clean it
		chomp $line;


		if($options->{stripComments}){
			next if $line =~ /^\s*\#[^\#]/;
			$line =~ s/\#$//;
			$line =~ s/(?<=[^\#])\#[^\#].*//;
			$line =~ s/\#\#/\#/;
		}

		$linenum++;
		if($line =~ /^[^\t\s]/)
		{
			#we have a valid key-value pair
			if($line =~ /(.*?)\s*\:\s*(.*)$/)
			{
				my $key = $1;
				my $value = $2;

				if($options->{discardCase})
				{
					$key = lc($key);
				}

				unless($options->{verbMultiLine})
				{
					$value =~ s/[\s\t]+$//;
				}

				$data->{$key} = $value;


				if ($options->{verbMultiLine}
					&& (($data->{$lastfield} || "") =~ /\n/o)){
					$data->{$lastfield} .= "\n";
				}

				$lastfield = $key;
			}else{
				$this->_dowarn("Parse error on line $linenum of data; invalid key/value stanza");
				return $structs;
			}

		}elsif($line =~ /^([\t\s])(.*)/)
		{
			#appends to previous line

			unless($lastfield)
			{
				$this->_dowarn("Parse error on line $linenum of data; indented entry without previous line");
				return $structs;
			}
			if($options->{verbMultiLine}){
				$data->{$lastfield}.="\n$1$2";
			}elsif($2 eq "." ){
				$data->{$lastfield}.="\n";
			}else{
				my $val = $2;
				$val =~ s/[\s\t]+$//;
				$data->{$lastfield}.="\n$val";
			}

		}elsif($line =~ /^[\s\t]*$/){
		        if ($options->{verbMultiLine}
			    && ($data->{$lastfield} =~ /\n/o)) {
			    $data->{$lastfield} .= "\n";
			}
			if(keys %$data > 0){
				push @$structs, $data;
			}
			$data = $this->_getReadyHash($options);
			$lastfield = "";
		}else{
			$this->_dowarn("Parse error on line $linenum of data; unidentified line structure");
			return $structs;
		}

	}

	if(keys %$data > 0)
	{
		push @$structs, $data;
	}

	return $structs;
}

sub _tryGzipInflate
{
	my ($this, $handle) = @_;

	my $buffer;
	{
		local $/ = undef;
		$buffer = <$handle>;
	}
	return Compress::Zlib::memGunzip($buffer) || $buffer;
}

sub _getReadyHash
{
	my ($this, $options) = @_;
	my $data;

	if($options->{useTieIxHash})
	{
		eval("use Tie::IxHash");
		if($@)
		{
			$this->_dowarn("Can't use Tie::IxHash. You need to install it to have this functionality");
			return;
		}
		tie(%$data, "Tie::IxHash");
		return $data;
	}

	return {};
}

sub _dowarn
{
        my ($this, $warning) = @_;

        if($this->{_verbose})
        {
                warn "DEBUG: $warning";
        }

        return;
}


1;

__END__