File Coverage

blib/lib/Geo/E00.pm

Criterion	Covered	Total	%
statement	14	226	6.1
branch	1	80	1.2
condition	1	3	33.3
subroutine	5	17	29.4
pod	0	14	0.0
total	21	340	6.1

# Geo::E00
#
# Arc/Info Export (E00) parser.
#
#	Copyright (c) 2002-2003 Tower Technologies s.r.l.
#	All Rights Reserved
#



package Geo::E00;

use strict;

use Carp;
use IO::File;

$Geo::E00::VERSION = '0.05';

# Constructor
sub new
{
	my ($proto) = @_;

	my $class = ref($proto) || $proto;

	return bless {
		'FH'	=> undef,
	}, $class;
}

sub open
{
	my ($self, $file) = @_;

	return undef unless defined $file;

	$self->{'FH'} = new IO::File $file, 'r';

	return $self->{'FH'};
}

sub parse
{
	my ($self) = @_;
	my ($fn);

	my $fh = $self->{'FH'};

	return undef unless defined $fh;

	# Read the first line
	my $headline = $fh->getline;

	return undef unless defined $headline;

#	print STDERR $headline;

	return undef unless $headline =~ m|^EXP\s+(\d+)\s+(.+)\s*$|;

	$self->{'VERSION'} = $1;
	$self->{'EXPFILE'} = $2;

#	print STDERR "Version $self->{'VERSION'} , file $self->{'EXPFILE'}\n";

	my $data = {};

	while (my $line = $fh->getline)
	{
		if ($line =~ m|^([A-Z]{3})\s+(\d+)|)
		{
			# Section start

			my $section = $1;
			my $param = $2;

#			print STDERR "Got section: $section, $param\n";

			$data->{'arc'} = $self->parse_arc($fh, $param) if $section eq 'ARC';
			$data->{'cnt'} = $self->parse_cnt($fh, $param) if $section eq 'CNT';
			$data->{'lab'} = $self->parse_lab($fh, $param) if $section eq 'LAB';
			$data->{'tol'} = $self->parse_tol($fh, $param) if $section eq 'TOL';
			$data->{'tx7'} = $self->parse_tx7($fh, $param) if $section eq 'TX7';
			$data->{'log'} = $self->parse_log($fh, $param) if $section eq 'LOG';
			$data->{'prj'} = $self->parse_prj($fh, $param) if $section eq 'PRJ';
			$data->{'pal'} = $self->parse_pal($fh, $param) if $section eq 'PAL';
			$data->{'ifo'} = $self->parse_ifo($fh, $param) if $section eq 'IFO';
		}
	}
	$data = combine($data);

	return $data;
}

sub parse_arc
{
	my ($self, $fh) = @_;

	my @sets = ();

	while (my $line = $fh->getline)
	{
		# Check for termination pattern
		last if $line =~ m|^\s*-1(\s+0){6}|;

		# Set header
		if ($line =~ m|^\s*(\d+)\s+(\-?\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)|)
		{
			my $arc = {
				'cov-num'	=> $1,
				'cov-id'	=> $2,
				'node-from'	=> $3,
				'node-to'	=> $4,
				'poly-left'	=> $5,
				'poly-right'	=> $6,
				'npoints'	=> $7,
			};

			my @coords    = ();
			my @llcoords  = ();

#			print STDERR "NUM: $arc->{'cov-num'}, ID: $arc->{'cov-id'}, PAIRS: $arc->{'npoints'}\n";

			for (my $i = 0; $i < $arc->{'npoints'};)
			{
				# Get a new line

				my $cline = $fh->getline;

				# Check if this is a 2 pairs line

				if ($cline =~ m{^(\s*[ -]\d+\.\d+E[+-]\d+)(\s*[ -]\d+\.\d+E[+-]\d+)(\s*[ -]\d+\.\d+E[+-]\d+)(\s*[ -]\d+\.\d+E[+|-]\d+)})
				{
					$llcoords[$i]->{'x'}=$1;
					$llcoords[$i]->{'y'}=$2;
					$llcoords[$i+1]->{'x'}=$3;
					$llcoords[$i+1]->{'y'}=$4;

					push(@coords, $1, $2, $3, $4);

#					print STDERR " got 2 pairs line\n";
					$i += 2;

					next;
				}

				# 1 pair line

				if ($cline =~ m{^(\s*[ -]\d+\.\d+E[+-]\d+)(\s*[ -]\d+\.\d+E[+-]\d+)})
				{
					$llcoords[$i]->{'x'}=$1;
					$llcoords[$i]->{'y'}=$2;
					push(@coords, $1, $2);

#					print STDERR " got 1 pair line\n";
					$i += 1;

					next;
				}

				Carp::croak "Unknown pair line: $cline\n";
			}

			Carp::croak "Wrong number of x-y pairs in ARC <> $arc->{'npoints'}\n"
				 unless ((scalar @coords) / 2 ) eq $arc->{'npoints'};

			$arc->{'points'}   = \@coords;
			$arc->{'coord'}    = \@llcoords;

			push(@sets, $arc);

			next;
		}

		Carp::croak "Unknown set line: $line";
	}

#	print STDERR Data::Dumper->Dump( [ \@sets ] );

#	print STDERR "END ARC SECTION\n";

	return \@sets;
}

sub parse_cnt
{
	my ($self, $fh) = @_;

	my @sets = ();

	while (my $line = $fh->getline)
	{
		# Check for termination pattern
		if ($line =~ m{^\s*(\d+)})
		{
			my $cnt = {
				'cnt-id'	=> $1,
			};
			$line = $fh->getline;
			last if $line =~ m|^\s*-1(\s+0){6}|;
			if ($line =~ m{^\s*(\d+)(\s*[ -]\d+\.\d+E[+-]\d+)(\s*[ -]\d+\.\d+E[+-]\d+)})
			{
				$cnt->{ 'x' } = $2;
				$cnt->{ 'y' } = $3;
			} else {
				Carp::croak "Unknown CNT line: $line\n";
			}

			# Store
			push(@sets, $cnt);
		}

	}

	return \@sets;

}


sub parse_lab
{
	my ($self, $fh) = @_;

	my @sets = ();

	while (my $line = $fh->getline)
	{
		# Check for termination pattern
		last if $line =~ m|^\s*-1\s+0|;

		# Set header
		if ($line =~ m{^\s*(\d+)\s+(\d+)(\s*[ -]\d+\.\d+E[+-]\d+)(\s*[ -]\d+\.\d+E[+-]\d+)})
		{
			my $lab = {
				'cov-id'	=> $1,
				'poly-id'	=> $2,
				'x'		=> $3,
				'y'		=> $4,
			};

			# Read and throw away the next line
			$fh->getline;

			# Store
			push(@sets, $lab);

			# Next set...
			next;
		}

		Carp::croak "Unknown set line: $line";
	}

	return \@sets;
}

sub parse_tol
{
#	print STDERR "END TOL SECTION\n";
}

sub parse_tx7
{
#	print STDERR "END TX7 SECTION\n";
}

sub parse_log
{
	my ($self, $fh) = @_;

	my @sets = ();

	while (my $line = $fh->getline)
	{
		last if $line =~ m|^EOL|;

		my ($year,$month,$day,$hour,$minute,$connecttime,$cputime,$iotime,$commandline)=unpack(
			"a4 a2 a2 a2 a2 a4 a6 a6 a*",$line);
		my $log = {
			'year'		=> $year,
			'month'		=> $month,
			'day'		=> $day,
			'hour'		=> $hour,
			'minute'	=> $minute,
			'connecttime'	=> $connecttime,
			'cputime'	=> $cputime,
			'iotime'	=> $iotime,
			'commandline'	=> $commandline,
		};

		# Read and throw away the next line

		$fh->getline;
		push(@sets, $log);
	}
	return \@sets;
}

sub parse_prj
{
# 	not needed
#	print STDERR "END PRJ SECTION\n";
}

sub parse_ifo
{
	my ($self, $fh, $param) = @_;

	my $data;

	while (my $line = $fh->getline)
	{
		# Check for termination pattern
		last if $line =~ m|^EOI|;
		if ($line =~ m|^(.*)?\.([A-Z]{3})\s+XX\s+(\d+)\s+\d+\s+\d+\s+(\d+)|)
		{
			my $ifo = {
				section => $1,
				name => $2,
				items => $3,
				records => $4,
				lines => 1,
			};

			my $totallength = 0;

			for (my $i = 0; $i <$ifo->{items}; $i++) {
				my ($itemname,$widthpos,$startpos,$outputformat,$dummy) =
					split(" ",$fh->getline,6);
				$widthpos        =~ s/-1$//;
				$startpos        =~ s/4-1$//;
				$outputformat    =~ s/-1$//;
				if ($outputformat == 12 ) { $outputformat = 14; }
				if ($outputformat ==  5 ) { $outputformat = 11; }

				$totallength    += $outputformat;
				$ifo->{format}  .= "a$outputformat ";
				if ($totallength > 80) {
					$ifo->{lines}++;
					$totallength -= 80;
				}
				push @{$ifo->{item}},$itemname;
			}
			$data->{$ifo->{name}} = $self->parse_types($fh, $ifo);
		}

	}
	$data;
}


sub parse_pal
{
	my ($self, $fh) = @_;

	my @sets = ();

	while (my $line = $fh->getline)
	{
		# Check for termination pattern
		last if $line =~ m|^\s*-1(\s+0){6}|;

		# Set header
		if ($line =~ m{^\s*(\d+)(\s*[ -]\d+\.\d+E[+-]\d+)(\s*[ -]\d+\.\d+E[+-]\d+)(\s*[ -]\d+\.\d+E[+-]\d+)(\s*[ -]\d+\.\d+E[+|-]\d+)})
		{
			my $pal = {
				'npoints'	=> $1,
				'xmin'		=> $2,
				'ymin'		=> $3,
				'xmax'		=> $4,
				'ymax'		=> $5,
			};

			my @points = ();

			for (my $i = 0; $i < $pal->{'npoints'};)
			{
				# Get a new line

				my $cline = $fh->getline;

				# Check if this is a 2 pairs line

				if ($cline =~ m{^(\s*[ -]\d+)(\s*[ -]\d+)(\s*[ -]\d+)(\s*[ -]\d+)(\s*[ -]\d+)(\s*[ -]\d+)})
				{
					$points[$i]->{'arc-number'}  = $1;
					$points[$i]->{'node-number'} = $2;
					$points[$i]->{'polygon-number'} = $3;
					$points[$i+1]->{'arc-number'}  = $4;
					$points[$i+1]->{'node-number'} = $5;
					$points[$i+1]->{'polygon-number'} = $6;

#					print STDERR " got 2 pairs line\n";
					$i += 2;

					next;
				}

				# 1 pair line

				if ($cline =~ m{^(\s*[ -]\d+)(\s*[ -]\d+)(\s*[ -]\d+)})
				{
					$points[$i]->{'arc-number'}  = $1;
					$points[$i]->{'node-number'} = $2;
					$points[$i]->{'polygon-number'} = $3;

#					print STDERR " got 1 pair line\n";
					$i += 1;

					next;
				}

				Carp::croak "Unknown pair line: $cline\n";
			}

			Carp::croak "Wrong number of x-y pairs in PAL <> $pal->{'npoints'}\n"
				 unless ((scalar @points) ) eq $pal->{'npoints'};

			$pal->{'points'} = \@points;

			push(@sets, $pal);

			next;
		}

		Carp::croak "Unknown set line: $line";
	}

	return \@sets;
}

sub parse_types
{
	my ($self, $fh, $ifo) = @_;

	my @sets = ();

	for (my $i = 0; $i < $ifo->{'records'}; $i++) {
		my ($types,@ri,$itemsnow);
		$itemsnow = 0;
		while ($itemsnow < $ifo->{'items'}) {
			my ($line,$j,$x);
			for ($j =0; $j < $ifo->{'lines'}; $j++) {
				$x     = $fh->getline();chomp($x);
				$line .= sprintf("%-80s",$x)
			}
			my (@ri) = unpack($ifo->{format},$line);
			for ($j=0; $j < (@ri); $j++) {
				$ri[$j] =~ s/^ *//;$ri[$j] =~ s/ *$//;
				$types->{$ifo->{'item'}->[$j+$itemsnow]}=$ri[$j];
			}
			$itemsnow += (@ri);
		}
		push(@sets, $types);
	}
	$ifo->{data}=\@sets;
	return $ifo;
}

sub combine
{
	my ($data) = @_;
	my ($rarc, $rlab);

	if (defined($data->{'arc'})) {
		my $nr  = 0;
		my $arc = $data->{arc};
                foreach my $arcline (@$arc) {
			$rarc->{$arcline->{"cov-num"}} = $nr++;
		}
	}

	if (defined($data->{'lab'})) {
		my $nr  = 0;
		my $lab = $data->{lab};
                foreach my $labline (@$lab) {
			$rlab->{$labline->{'poly-id'}} = $nr++;
		}
	}

	if (defined($data->{'ifo'})) {
#___________________________________________________
# AAT Part
#___________________________________________________
		if (defined($data->{'ifo'}->{'AAT'})) {
			my $aat = $data->{'ifo'}->{'AAT'};
			my (@el,$item,$nr);
		# the next AAT field will be saved in the ARC structure
		# 0 FNODE#
		# 1 TNODE#
		# 2 LPOLY#
		# 3 RPOLY#
		# 4 LENGTH        saved
		# 5 RRLINE#       < compare with cov_num
		# 6 RRLINE-ID
		# 7 ..		extra fields
			$nr=0;
			foreach $item (@{$aat->{item}}) {
				$el[$nr++] = $item;
			}
			my $dline;
			foreach $dline (@{$aat->{data}}) {
				$nr = $rarc->{$dline->{$el[5]}};
				$data->{'arc'}->[$nr]->{$el[4]} =  $dline->{$el[4]};
				for (my $i = 7; $i <$aat->{items}; $i++) {
					$data->{'arc'}->[$nr]->{$el[$i]} =  $dline->{$el[$i]};
				}
			}

		}
#___________________________________________________
# PAT Part
#___________________________________________________
		if (defined($data->{'ifo'}->{'PAT'})) {
			my $pat = $data->{'ifo'}->{'PAT'};
			my (@el,$item,$nr);
		# the next PAT field will be saved in the LAB structure
		# 0 AREA
		# 1 PERIMETER
		# 2 PPPOINT#
		# 3 PPPOINT-ID
		# 4 ..
			$nr=0;
			foreach $item (@{$pat->{item}}) {
				$el[$nr++] = $item;
			}
			my $dline;
			foreach $dline (@{$pat->{data}}) {

				$nr = $rlab->{$dline->{$el[2]}};
				for (my $i = 4; $i <$pat->{items}; $i++) {
					$data->{'lab'}->[$nr]->{$el[$i]} =  $dline->{$el[$i]};
				}
			}
		}
	}
	$data;
}

1;

__END__