File Coverage

blib/lib/Text/NumericData.pm

Criterion	Covered	Total	%
statement	214	255	83.9
branch	108	160	67.5
condition	17	24	70.8
subroutine	15	17	88.2
pod	7	15	46.6
total	361	471	76.6

package Text::NumericData;

use strict;
use Storable qw(dclone);

# TODO: optimize those regexes, compile once in constructor

# major.minor.bugfix, the latter two with 3 digits each
# It's not pretty, but I gave up on 1.2.3 style.
our $VERSION = '2.004001';
our $version = $VERSION;
$VERSION = eval $VERSION;

our $years = '2005-2023';
our $copyright = 'Copyright (c) '.$years.' Thomas Orgis, Free Software licensed under the same terms as Perl 5.10';
our $author = 'Thomas Orgis ';

# TODO: More smarts in separator search.
# One should find ', ' as separator in
# a / c, d /e
my $newhite = '[^\S\015\012]'; # whitespace that is no line end character
my $trenner = $newhite.'+|,'.$newhite.'*|;'.$newhite.'*';
my $ntrenner = '[^\s,;]+'; # also excludes CR LF
my $lend = '[\012\015]+';
my $nlend = '[^\012\015]';
my $quotematch = "['\"]";

my %endname =   ("\015\012"=>'DOS', "\012"=>'UNIX', "\015"=>'MAC');
my %endstring = reverse %endname;

# Fallback defaults if anything else fails.
our $default_sep = "\t";
our $default_eol = $/;
our $default_comchar = '#';
our $default_quote = 1;
our $default_quotechar = '"';

our %help =
(
	 separator=>'use this separator for input (otherwise deduce from data; TAB is another way to say "tabulator", fallback is'.$default_sep.')'
	,outsep=>'use this separator for output (leave undefined to use input separator, fallback to '.($default_sep eq "\t" ? 'TAB' : $default_sep).')'
	,lineend=>'line ending to use: ('.join(', ', sort keys %endstring).' or be explicit if you can, taken from data if undefined, finally resorting to '.(defined $endname{$default_eol} ? $endname{$default_eol} : $default_eol).')'
	,comchar=>'comment character (if not set, deduce from data or use '.$default_comchar.')'
	,numregex=>'regex for matching numbers'
	,numformat=>'printf formats to use (if there is no "%" present at all, one will be prepended)'
	,comregex=>'regex for matching comments'
	,quote=>'quote titles'
	,quotechar=>'quote character to use (derived from input or '.$default_quotechar.')'
	,strict=>'strictly split data lines at configured separator (otherwise more fuzzy logic is involved)'
	,text=>'allow text as data (not first column)'
	,fill=>'fill value for undefined data'
	,black=>'ignore whitespace at beginning and end of line (disables strict mode)'
	,empty=>'treat empty lines as empty data sets, preserving them in output'
);

# These are defaults for user settings.
our %defaults =
(
	'separator',undef,
	'outsep', undef,
	'lineend', undef,
	'comchar', undef,
	'numregex', '[\+\-]?\d*\.?\d*[eE]?\+?\-?\d*',
	'numformat',[],
	'comregex','[#%]*'.$newhite.'*',
	'quote',undef,
	'quotechar',undef,
	'strict', 0,
	'text', 1
	,'fill',undef # a value to fill in for non-existent but still demanded data
	,'black', 0
	,'empty',0
);

sub new
{
	my $class = shift;
	my $self = {};
	bless $self, $class;
	# Only pick the parts of the config hash that are of interest here.
	my $gotconf = shift;
	$self->{gotconfig} = {};
	for my $n (keys %defaults)
	{
		if(ref $gotconf->{$n})
		{
			$self->{gotconfig}{$n} = dclone($gotconf->{$n});
		}
		else
		{
			$self->{gotconfig}{$n} = $gotconf->{$n};
		}
	}
	foreach my $n (@{$self->{gotconfig}->{numformat}})
	{
		$n = '%'.$n unless $n =~ /\%/;
	}
	# Expand named special characters for line ending.
	if(defined $gotconf->{lineend})
	{
		$self->{gotconfig}{lineend} = defined $endstring{$gotconf->{lineend}}
			? $endstring{$gotconf->{lineend}}
			: $gotconf->{lineend};
	}
	for (qw(separator outsep))
	{
		if(defined $gotconf->{$_} and $gotconf->{$_} eq 'TAB'){ $self->{gotconfig}{$_} = "\t"; }
	}

	$self->{gotconfig}{strict} = 0
		if $self->{gotconfig}{black};
	$self->init();
	return $self;
}

sub init
{
	my $self = shift;
	%{$self->{config}} = %{$self->{gotconfig}};
	$self->{comments} = []; #some comment in header
	$self->{guessquote} = undef;
	$self->{titles} = []; #column titles
	$self->{title} = undef; #file title
	foreach my $k ('numregex','numformat','comregex','fill')
	{
		$self->{config}{$k} = $defaults{$k} unless defined $self->{config}{$k};
	}
	# Strict mode needs some set separator.
	if($self->{config}{strict} and not defined $self->{config}{separator})
	{
		$self->{config}{separator} = $default_sep;
	}
}

#line_check($line, $onlycheck)
#$onlycheck: 0/undef: do full search for file/line titles and line end, etc.
#            1: only determine if data or not
sub line_check #return 1 and set separator and line ending if data line and 0 otherwise
{
	my $self = shift;
	# temporary hack until fully switching to value instead of ref, which is a ref anyway
	my $lr = ref $_[0] ? $_[0] : \$_[0];
	my $oc = $_[1];
	my $zahl = $self->{config}{numregex};
	my $seppl = $trenner;
	$seppl = $self->{config}{separator} if $self->{config}{strict};
	#the leading whitespace is a workaround for TISEAN
	#good or bad? It should not break any files that worked before...
	if( ${$lr} =~ /^\s*$/ and ${$lr} =~ /^($nlend*)($lend)$/o )
	{
		$self->{config}{lineend} = $2 unless defined $self->{config}{lineend};
		# An empty line counts as comment when it comes after a title.
		push(@{$self->{comments}},$1)
			if defined $self->{title};
		return 0;
	}
	if(${$lr} =~ /^\s*($zahl)(($seppl)$nlend*|)($lend)$/)
	{
		my ($num, $end, $sep) = ($1, $4, $3);
		my $piece = $1.$2;
		unless(not defined $end or defined $self->{config}{lineend})
		{
			$self->{config}{lineend} = $end;
		}
		unless($self->{config}{text})
		{
			# If text is not allowed, we strictly only want
			# numbers and separators and line end.
			# Let's get expensive: Remove everything we know. if there is something
			# left, we got text.
			my $linecopy = ${$lr};
			$linecopy =~ s/$seppl//g;
			$linecopy =~ s/($zahl|\s+|$lend)//g;
			if($linecopy ne '')
			{
				if( defined $self->{title} ){ push(@{$self->{comments}},$piece); }
				else{	$self->{title} = $piece; }
				return 0;
			}
		}
		# sanity check for loosened definition of number... at least one digit shall be there
		if($num =~ /\d/)
		{
			unless(not defined $sep or defined $self->{config}{separator})
			{
				$self->{config}{separator} = $sep;
			}
			if($#{$self->{comments}} > -1 and $#{$self->{titles}} > -1)
			{
				pop(@{$self->{comments}});
			}
			return 1; # Yeah, found a number line.
		}
	}
	elsif($oc){ return 0; }
	else
	{
		if(${$lr} =~ /^($self->{config}{comregex})($lend)$/)
		{
			$self->{config}{comchar} = $1
				unless defined $self->{config}{comchar};
			$self->{config}{lineend} = $2
				unless defined $self->{config}{lineend};
			return 0;
		}
		#first non-empty line is some kind of title or comment
		#first means: we didn't have content up to now
		if(${$lr} =~ /^($self->{config}{comregex})($nlend+)($lend)$/)
		{
			if( defined $self->{title} ){ push(@{$self->{comments}},$2); }
			else{	$self->{title} = $2; }
			$self->{config}{lineend} = $3
				unless defined $self->{config}{lineend};
			$self->{config}{comchar} = $1
				unless defined $self->{config}{comchar};
		}
		#attention: I take " or ' just as quotes, do distinction!
		my $quote = $self->{config}{quotechar};
		$quote = $quotematch
			unless defined $quote;
		if(${$lr} =~ /^($self->{config}{comregex})($quote)($nlend*\2($seppl)\2*$nlend*)\2*($lend)$/)
		{
			$self->{config}{quote} = 1
				unless defined $self->{config}{quote};
			$self->{config}{quotechar} = $2
				unless defined $self->{config}{quotechar};
			# "axis title"\t"axis title"\t"..."
			# allow flexible space in separator
			my $sep  = $4;
			my $q    = $2;
			my $rest = $3;
			$rest =~ s:$q$::;
			$sep =~ s:\s+$:\\s+:
				unless($self->{config}{strict});
			my @ax = split($q.$sep.$q,$rest);
			$self->{titles} = \@ax;
			$self->{config}{lineend} = $5
				unless defined $self->{config}{lineend};
			$self->{config}{comchar} = $1
				unless defined $self->{config}{comchar};
		}
		#either no quotes at all or maybe quotes but single item without separator
		elsif(${$lr} =~ /^($self->{config}{comregex})($quote?)($nlend*)($lend)$/)
		{
			if($2 ne '')
			{
				$self->{config}{quotechar} = $2
					unless defined $self->{config}{quotechar};
				$self->{config}{quote} = 1
					unless defined $self->{config}{quote};
			}
			else
			{
				$self->{guessquote} = 0
			}
			$self->{config}{lineend} = $4
				unless defined $self->{config}{lineend};
			$self->{config}{comchar} = $1
				unless defined $self->{config}{comchar};
			my $d = $3;
			$d =~ s/$quote$//;
			my @ax = ();
			if($d =~ /($seppl)/)
			{
				@ax = split($1, $d);
			}
			else{ @ax = ($d); }
			$self->{titles} = \@ax;
		}
		return 0;
	}
}

sub get_insep
{
	my $self = shift;
	return defined $self->{config}{separator}
		? $self->{config}{separator}
		: $default_sep;
}

sub get_outsep
{
	my $self = shift;
	return defined $self->{config}{outsep}
		? $self->{config}{outsep}
		: (
			defined $self->{config}{separator}
				? $self->{config}{separator}
				: $default_sep
		);
}

sub get_end
{
	my $self = shift;
	return defined $self->{config}{lineend}
		? $self->{config}{lineend}
		: $default_eol;
}

sub get_quote
{
	my $self = shift;
	my $want = defined $self->{config}{quote}
		? $self->{config}{quote}
		: ( defined $self->{guessquote}
			? $self->{guessquote}
			: $default_quote );
	return $want
		? (  defined $self->{config}{quotechar}
			? $self->{config}{quotechar}
			: $default_quotechar )
		: '';
}

sub get_comchar
{
	my $self = shift;
	return defined $self->{config}{comchar}
		? $self->{config}{comchar}
		: $default_comchar;
}

sub line_data
{
	my $self = shift;
	my $lr = ref $_[0] ? $_[0] : \$_[0];
	my @ar = ();
	my $zahl = $self->{config}{numregex};
	# empty lines
	return ($self->{config}{empty} ? [] : undef) if(${$lr} =~ /^$lend$/);
	if($self->{config}{strict})
	{
		#just split with defined or found separator
		@ar = split($self->get_insep(), ${$lr});
		#remove line end
		if($#ar > -1){ $ar[$#ar] =~ s/$lend//o; }
	}
	else
	{
		my $l = ${$lr};
		if($self->{config}{black})
		{
			$l =~ s/^\s*//;
			# s/\s*$// deletes the line end -- no problem here
			$l =~ s/\s*$//;
		}
		if($l =~ /^($zahl)(.*)$/){ push(@ar, $1); $l = $2; }else{ return undef; }
		unless($self->{config}{text})
		{
			while($l =~ /^($trenner)($zahl)(.*)$/o)
			{
				push(@ar, $2);
				$l = $3;
			}
		}
		else
		{
			while($l =~ /^($trenner)($ntrenner)(.*)$/o)
			{
				push(@ar, $2);
				$l = $3;
			}
		}
	}
	return \@ar;
}

sub data_line
{
	my $self = shift;
	my $ar = shift;

	my $cols_include = shift;
	my $cols_exclude = shift;
	my $l = '';
	my $zahl = $self->{config}{numregex};
	my $end = $self->get_end();
	my $sep = $self->get_outsep();
	my @vals;
	my @cols;
	my $i = -1;

	unless(defined $cols_include)
	{
		@vals = @{$ar};
		@cols = (0..$#vals);
	}
	else
	{
		for my $k (@{$cols_include})
		{
			push(@vals, ($k > -1 and $k < @{$ar})
				? $ar->[$k]
				: $self->{config}{fill});
			push(@cols, $k > -1 ? $k : 0); # ... for numerformat ... arrg
		}
	}

	if(defined $cols_exclude)
	{
		my @oldvals = @vals;
		my @oldcols = @cols;
		@vals = ();
		@cols = ();
		for(my $i=0; $i<=$#oldvals; ++$i)
		{
			if(not grep {$_ == $i} @{$cols_exclude})
			{
				push(@vals, $oldvals[$i]);
				push(@cols, $oldcols[$i]);
			}
		}
	}

	if(defined $self->{config}{numformat}->[0])
	{
		foreach my $i (0..$#vals)
		{
			my $v = $vals[$i];
			my $c = $cols[$i];
			unless(defined $v){ $l .= $sep; next; }

			my $numform = $self->{config}{numformat}->[$c];
			$numform = $self->{config}{numformat}->[0] unless defined $numform;
			if($numform ne '')
			{
				$l .= ($v ne '' and $v =~ /^$zahl$/ ? sprintf($numform, $v) : $v).$sep;
			}
			else{ $l .= $v.$sep; }
		}
		$l =~ s/$sep$/$end/;
	}
	else
	{
		# do I want to care for undefs?
		# not here ... failure is not communicated from here, you shall handle bad columns externally
		$l = join($sep, @vals).$end;
	}
	return \$l;
}

sub title_line
{
	my $self = shift;
	my $cols_include = shift;
	my $cols_exclude = shift;

	my @cols = defined $cols_include ? @{$cols_include} : (0..$#{$self->{titles}});
	if(defined $cols_exclude)
	{
		my @oldcols = @cols;
		@cols = ();
		for(my $i=0; $i<=$#oldcols; ++$i)
		{
			if(not grep {$_ == $i} @{$cols_exclude})
			{
				push(@cols, $oldcols[$i]);
			}
		}
	}

	my $end = $self->get_end();
	my $sep = $self->get_outsep();
	my $com = $self->get_comchar();
	my $q = $self->get_quote();
	my $l = $com.$q;
	#print STDERR "titles: @{$self->{titles}}\n";
	#print STDERR "titles for @{$ar}\n" if defined $ar;
	foreach my $k (@cols)
	{
		# should match for title containing $q
		my $t = $k > -1 ? $self->{titles}->[$k] : undef;
		$t = "" unless defined $t;
		$l .= $t.$q.$sep.$q;
	}
	$l =~ s/$q$//;
	$l =~ s/$sep$/$end/;
	return \$l;
}

sub comment_line
{
	my $self = shift;
	my $line = ref $_[0] ? $_[0] : \$_[0];
	my $cline = $self->get_comchar().${$line}.$self->get_end();
	return \$cline;
}

sub chomp_line
{
	my $self = shift;
	my $string = ref $_[0] ? $_[0] : \$_[0];
	if(defined $string)
	{
		${$string} =~ s/$lend$//;
	}
}

sub make_naked
{
	my $self = shift;
	my $string = ref $_[0] ? $_[0] : \$_[0];
	if(defined $string)
	{
		${$string} =~ s/$lend$//;
		${$string} =~ s/^$self->{config}{comregex}//;
	}
}

# Not well supported, but possible: Text in between numeric data.
# To make it a bit safer, this filter will replace everything that would count as separator.
# It's only a bit safer... supsequent parsers are supposed to work in strict mode if we're in strict mode here.
sub filter_text
{
	my $self = shift;
	my $match;
	if($self->{config}{strict})
	{
		my $sep = $self->get_outsep();
		$match = qr/$sep/;
	}
	else
	{
		$match = qr/$trenner/;
	}
	for(@_){ s:$match:_:g; }
}

1;

__END__