File Coverage

blib/lib/X12/Parser.pm

Criterion	Covered	Total	%
statement	124	152	81.5
branch	29	38	76.3
condition			n/a
subroutine	16	20	80.0
pod	12	12	100.0
total	181	222	81.5

# Copyright 2009 by Prasad Balan
# All rights reserved.
#
# This library is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself.
package X12::Parser;
use strict;
require Exporter;
our @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.
# This allows declaration    use X12 ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = (
	'all' => [
		qw(
		  )
	]
);
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
our @EXPORT    = qw(
);
our $VERSION = '0.80';

# Preloaded methods go here.
use X12::Parser::Tree;
use X12::Parser::Cf;

#constructor.
sub new {
	my $self = {
		file                  => undef,
		conf                  => undef,
		_TREE_ROOT            => undef,
		_TREE_POS             => undef,
		_FILE_HANDLE          => undef,
		_FILE_CLOSED          => undef,
		_SEGMENT_SEPARATOR    => undef,
		_ELEMENT_SEPARATOR    => undef,
		_SUBELEMENT_SEPARATOR => undef,
		_NEXT_LOOP            => undef,
		_NEXT_SEGMENT         => undef,
	};
	return bless $self;
}

#public method, takes the X12 handle and Cf file name as input.
#loads the config file and sets the separators.
sub parse {
	my $self   = shift;
	my %params = @_;
	$self->{handle}       = $params{handle};
	$self->{conf}         = $params{conf};
	$self->{_FILE_HANDLE} = $params{handle};
	$self->{_FILE_CLOSED} = undef;

	#read the config file to create the TREE object
	my $cf = X12::Parser::Cf->new();
	$self->{_TREE_ROOT} = $cf->load( file => "$self->{conf}" )
	  if defined $self->{conf};
	$self->{_TREE_POS} = $self->{_TREE_ROOT};

	#set the separators
	$self->_set_separator;
}

#public method, takes the X12 and Cf file name as input.
#loads the config file and sets the separators.
sub parsefile {
	my $self   = shift;
	my %params = @_;
	$self->{file} = $params{file};
	$self->{conf} = $params{conf};

	#chose the handle just in case this method is being called the second time
	#without closing the file
	if ( defined $self->{_FILE_HANDLE} ) {
		close( $self->{_FILE_HANDLE} );
		$self->{_FILE_CLOSED} = 1;
	}
	open( my $handle, "$self->{file}" )
	  || die "error: cannot open file $self->{file}\n";
	$self->parse( handle => $handle, conf => $self->{conf} );
}

#close the file
sub closefile {
	my $self = shift;
	if ( defined $self->{_FILE_HANDLE} ) {
		close( $self->{_FILE_HANDLE} );
		$self->{_FILE_CLOSED} = 1;
	}
}

#private method. sets the separators.
sub _set_separator {
	my $self = shift;
	my $isa  = undef;
	if ( read( $self->{_FILE_HANDLE}, $isa, 108 ) != 108 ) {
		close( $self->{_FILE_HANDLE} );
		$self->{_FILE_CLOSED} = 1;
		die "error: invalid file format $self->{file}\n";
	}

	#set the segment terminator
	my $terminator = substr( $isa, 106, 2 );
	if ( $terminator =~ /\r\n/ ) {
		$self->{_SEGMENT_SEPARATOR} = substr( $isa, 105, 3 );
	}
	elsif ( $terminator =~ /^\n/ ) {
		$self->{_SEGMENT_SEPARATOR} = substr( $isa, 105, 2 );
	}
	else {
		$self->{_SEGMENT_SEPARATOR} = substr( $isa, 105, 1 );
	}

	#set the element separator
	$self->{_ELEMENT_SEPARATOR} = substr( $isa, 3, 1 );

	#set the sub element separator
	$self->{_SUBELEMENT_SEPARATOR} = substr( $isa, 104, 1 );
	seek( $self->{_FILE_HANDLE}, -108, 1 );
}

#public method. gets the next loop.
sub get_next_loop {
	my $self = shift;
	if ( defined $self->{_NEXT_LOOP} ) {
		my $loop = $self->{_NEXT_LOOP};
		$self->{_NEXT_LOOP} = undef;
		return $loop;
	}
	else {
		return $self->_get_next_loop();
	}
}

sub get_next_pos_loop {
	my $self = shift;
	my $loop = undef;
	if ( defined $self->{_NEXT_LOOP} ) {
		$loop = $self->{_NEXT_LOOP};
		$self->{_NEXT_LOOP} = undef;
		return ( $., $loop );
	}
	else {
		$loop = $self->_get_next_loop();
		if ( defined $loop ) {
			return ( $., $loop );
		}
		else {
			return;
		}
	}
}

sub get_next_pos_level_loop {
	my $self = shift;
	my $loop = undef;
	if ( defined $self->{_NEXT_LOOP} ) {
		$loop = $self->{_NEXT_LOOP};
		$self->{_NEXT_LOOP} = undef;
		return ( $., $self->{_TREE_POS}->get_depth(), $loop );
	}
	else {
		$loop = $self->_get_next_loop();
		if ( defined $loop ) {
			return ( $., $self->{_TREE_POS}->get_depth(), $loop );
		}
		else {
			return;
		}
	}
}

#private method. does the hard lifting.
sub _get_next_loop {
	my $self = shift;
	my ( $segment, $file_handle, $node, $loop, @element );
	local $/;
	$/             = $self->{_SEGMENT_SEPARATOR};
	$file_handle   = $self->{_FILE_HANDLE};
	$node          = $self->{_TREE_POS};
	$self->{_LOOP} = [];
	if ( defined $self->{_NEXT_SEGMENT} ) {
		push( @{ $self->{_LOOP} }, $self->{_NEXT_SEGMENT} );
		$self->{_NEXT_SEGMENT} = undef;
	}
	if ( defined $self->{_FILE_CLOSED} ) {
		return undef;
	}
	while ( $segment = <$file_handle> ) {
		chomp($segment);
		@element = split( /\Q$self->{_ELEMENT_SEPARATOR}\E/, $segment );
		$loop = $self->_check_child_match( $node, \@element );
		if ( defined $loop ) {
			$self->{_NEXT_SEGMENT} = $segment;
			return $loop;
		}
		$loop = $self->_check_parent_match( $node, \@element );
		if ( defined $loop ) {
			$self->{_NEXT_SEGMENT} = $segment;
			return $loop;
		}
		push( @{ $self->{_LOOP} }, $segment );
	}
	close($file_handle);
	$self->{_FILE_CLOSED} = 1;
	return undef;
}

#private method. check if any of the child loops match
sub _check_child_match {
	my ( $self, $node, $elements ) = @_;
	for ( my $i = 0 ; $i < $node->get_child_count() ; $i++ ) {
		my $child = $node->get_child($i);
		if ( $child->is_loop_start($elements) ) {
			$self->{_TREE_POS} = $child;
			return $child->get_name();
		}
	}
	return undef;
}

#private method. check if any of the parent loops match
sub _check_parent_match {
	my ( $self, $node, $elements ) = @_;
	my $parent = $node->get_parent();
	if ( !defined $parent ) { return undef; }
	for ( my $i = 0 ; $i < $parent->get_child_count() ; $i++ ) {
		my $child = $parent->get_child($i);
		if ( $child->is_loop_start($elements) ) {
			$self->{_TREE_POS} = $child;
			return $child->get_name();
		}
	}
	$self->_check_parent_match( $parent, $elements );
}

#get the segments in the loop
sub get_loop_segments {
	my $self = shift;
	my $loop = $self->_get_next_loop();
	$self->{_NEXT_LOOP} = $loop;
	return @{ $self->{_LOOP} };
}

sub get_segment_separator {
	my $self = shift;
	return $self->{_SEGMENT_SEPARATOR};
}

sub get_element_separator {
	my $self = shift;
	return $self->{_ELEMENT_SEPARATOR};
}

sub get_subelement_separator {
	my $self = shift;
	return $self->{_SUBELEMENT_SEPARATOR};
}

sub print_tree {
	my $self = shift;
	my ( $pad, $index, $segment );
	while ( my ( $pos, $level, $loop ) = $self->get_next_pos_level_loop ) {
		$pad = '  |' x $level;
		print "       $pad--$loop\n";
		$pad = '  |' x ( $level + 1 );
		my @loop = $self->get_loop_segments;
		foreach $segment (@loop) {
			$index = sprintf( "%+7s", $pos++ );
			print "$index$pad-- $segment\n";
		}
	}
}

#private method only called for tests
sub _print_tree {
	my $self = shift;
	my ( $pad, $index, $segment, $tree );
	while ( my ( $pos, $level, $loop ) = $self->get_next_pos_level_loop ) {
		$pad = '  |' x $level;
		$tree .= "       $pad--$loop\n";
		$pad = '  |' x ( $level + 1 );
		my @loop = $self->get_loop_segments;
		foreach $segment (@loop) {
			$index = sprintf( "%+7s", $pos++ );
			$tree .= "$index$pad-- $segment\n";
		}
	}
	return $tree;
}
1;
__END__