File Coverage

blib/lib/Spreadsheet/ExcelTableReader.pm

Criterion	Covered	Total	%
statement	38	266	14.2
branch	3	130	2.3
condition	3	36	8.3
subroutine	12	33	36.3
pod	7	8	87.5
total	63	473	13.3

package Spreadsheet::ExcelTableReader;
use Moo 2;
use Spreadsheet::ParseExcel;
use Spreadsheet::ParseExcel::Utility 'int2col';
use Spreadsheet::XLSX;
use Log::Any '$log';
use Spreadsheet::ExcelTableReader::Field;
use Carp 'croak';
use IO::Handle;

our $VERSION= '0.000001_001';

# ABSTRACT: Module to extract a table from somewhere within an Excel spreadsheet


has file => ( is => 'ro' );


has sheet => ( is => 'ro' );

# Arrayref of all sheets we can search
has _sheets => ( is => 'lazy' );


has fields => ( is => 'ro', required => 1, coerce => \&_coerce_field_list );
sub field_list { @{ shift->fields } }


has find_table_args => ( is => 'rw' );

has _table_location => ( is => 'rw', lazy_build => 1 );

sub _build__sheets {
	my $self= shift;

	# If we have ->sheet and it is a worksheet object, then no need to do anything else
	if ($self->sheet && ref($self->sheet) && ref($self->sheet)->can('get_cell')) {
		return [ $self->sheet ];
	}

	# Else we need to scan sheets from the excel file.  Make sure we have the file
	my $wbook= $self->_open_workbook($self->file);
	my @sheets= $wbook->worksheets;
	@sheets or croak "No worksheets in file?";
	if (defined $self->sheet) {
		if (ref($self->sheet) eq 'Regexp') {
			@sheets= grep { $_->get_name =~ $self->sheet } @sheets;
		} elsif (ref($self->sheet) eq 'CODE') {
			@sheets= grep { $self->sheet->($_) } @sheets;
		} elsif (!ref $self->sheet) {
			@sheets= grep { $_->get_name eq $self->sheet } @sheets;
		} else {
			croak "Unknown type of sheet specification: ".$self->sheet;
		}
	}
	@sheets or croak "No worksheets match the specification";

	return \@sheets;
}

sub _open_workbook {
	my ($self, $f)= @_;

	defined $f or croak "workbook file is undefined";

	my $wbook;
	if (ref($f) && ref($f)->can('worksheets')) {
		$wbook= $f;
	} else {
		my $type= "xlsx";

		# Probe the file to determine type
		if (ref($f) eq 'GLOB' or ref($f) && ref($f)->can('read')) {
			my $fpos= $f->tell;
			$fpos >= 0 or croak "File handle must be seekable";
			$f->read(my $buf, 4) == 4 or croak "read($f,4): $!";
			$f->seek($fpos, 0) or croak "failed to seek back to start of file";
			$type= 'xls' if $buf eq "\xD0\xCF\x11\xE0";
		}
		elsif (-e $f) {
			$f= "$f"; # force stringification
			open my $fh, '<', $f or croak "open($f): $!";
			read($fh, my $buf, 4) == 4 or croak "read($f,4): $!";
			$type= 'xls' if $buf eq "\xD0\xCF\x11\xE0";
		}
		else {
			$log->notice("Can't determine parser for '$f', guessing '$type'") if $log->is_notice;
		}

		if ($type eq 'xlsx') {
			# Spreadsheet::XLSX uses Archive::Zip which can *only* work on IO::Handle
			# instances, not plain globrefs. (seems like a bug, hm)
			if (ref($f) eq 'GLOB') {
				require IO::File;
				my $f_obj= IO::File->new;
				$f_obj->fdopen($f, 'r') or croak "Can't convert GLOBref to IO::File";
				$f= $f_obj;
			}
			$wbook= Spreadsheet::XLSX->new($f);
		} else {
			$wbook= Spreadsheet::ParseExcel->new->parse($f);
		}
		defined $wbook or croak "Can't parse file '".$self->file."'";
	}
	return $wbook;
}

sub _build__table_location {
	my $self= shift;
	my $args= $self->find_table_args;
	$self->find_table( !$args? () : (ref($args) eq 'ARRAY')? @$args : %$args )
		or croak "No match for table header in excel file";
	$self->{_table_location}; # find_table sets the value already, in a slight violation of this builder method.
}

sub _coerce_field_list {
	my ($list)= @_;
	defined $list and ref $list eq 'ARRAY' or croak "'fields' must be a non-empty arrayref";
	my @list= @$list; # clone it, to make sure we don't unexpectedly alter the caller's data
	for (@list) {
		if (!ref $_) {
			$_= Spreadsheet::ExcelTableReader::Field->new(
				name => $_,
				header => qr/^\s*\Q$_\E\s*$/i,
			);
		} elsif (ref $_ eq 'HASH') {
			my %args= %$_;
			# "isa" alias for the 'type' attribute
			$args{type}= delete $args{isa} if defined $args{isa} && !defined $args{type};
			# default header to field name with optional whitespace
			$args{header}= qr/^\s*\Q$args{name}\E\s*$/i unless defined $args{header};
			$_= Spreadsheet::ExcelTableReader::Field->new( %args )
		} else {
			croak "Can't coerce '$_' to a Field object"
		}
	}
	return \@list;
}


sub BUILD {
	my $self= shift;
	# Any errors getting the list of searchable worksheets should happen now, during construction time
	$self->_sheets;
}


sub _cell_name {
	my ($row, $col)= @_;
	return int2col($col).($row+1);
}

sub find_table {
	my $self= shift;

	my $location;
	my @sheets= @{$self->_sheets};
	my @fields= $self->field_list;
	my $num_required_fields= grep { $_->required } @fields;

	# Algorithm is O(N^4) in worst case, but the regex should make it more like O(N^2) in most
	# real world cases.  The worst case would be if every row of every sheet of the workbook almost
	# matched the header row (which could happen with extremely lax field header patterns)
	my $header_regex= qr/(?:@{[ join('|', map { $_->header_regex } @fields) ]})/ms;

	# Scan top-down across all sheets at once, since headers are probably at the top of the document.
	my $row= 0;
	my $in_range= 1; # flag turns false if we pass the bottom of all sheets
	row_loop: while ($in_range) {
		$in_range= 0;
		for my $sheet (@sheets) {
			$log->trace("row $row sheet $sheet") if $log->is_trace;
			my %field_found;
			my ($rmin, $rmax)= $sheet->row_range();
			my ($cmin, $cmax)= $sheet->col_range();
			next unless $row >= $rmin && $row <= $rmax;
			$in_range++;
			my @row_vals= map { my $c= $sheet->get_cell($row, $_); $c? $c->value : '' } 0..$cmax;
			my $match_count= grep { $_ =~ $header_regex } @row_vals;
			$log->trace("str=@row_vals, regex=$header_regex, match_count=$match_count");
			if ($match_count >= $num_required_fields) {
				my $field_col= $self->_resolve_field_columns($sheet, $row, \@row_vals);
				if ($field_col) {
					$location= {
						sheet => $sheet,
						header_row => $row,
						min_row => $row+1,
						field_col => $field_col,
					};
					last row_loop;
				}
			}
		}
		++$row;
	}

	return '' unless defined $location;

	# Calculate a few more fields for location
	my @cols_used= sort { $a <=> $b } values %{ $location->{field_col} };
	$location->{min_col}= $cols_used[0];
	$location->{max_col}= $cols_used[-1];

	# Maybe should look for the last row containing data for our columns, but that seems expensive...
	$location->{max_row}= ($location->{sheet}->row_range())[1];

	$location->{start_cell}= _cell_name($location->{min_row}, $location->{min_col});
	$location->{end_cell}=   _cell_name($location->{min_col}, $location->{max_col});
	$self->_table_location($location);

	return 1;
}

sub _resolve_field_columns {
	my ($self, $sheet, $row, $row_vals)= @_;
	my %col_map;
	my %field_found;
	my $fields= $self->fields;

	# Try each cell to see if it matches each field's header
	for my $col (0..$#$row_vals) {
		my $v= $row_vals->[$col];
		next unless defined $v and length $v;
		for my $field (@$fields) {
			push @{ $field_found{$field->name} }, $col
				if $v =~ $field->header_regex;
		}
	}

	# Is there one and only one mapping of fields to columns?
	my $ambiguous= 0;
	my @todo= @$fields;
	while (@todo) {
		my $field= shift @todo;
		next unless defined $field_found{$field->name};
		my $possible= $field_found{$field->name};
		my @available= grep { !defined $col_map{$_} } @$possible;
		$log->trace("ambiguous=$ambiguous : field ".$field->name." could be ".join(',', map { _cell_name($row,$_) } @$possible)
			." and ".join(',', map { _cell_name($row,$_) } @available)." are available");
		if (!@available) {
			# It is possible that two fields claim the same columns and one is required
			if ($field->required) {
				my $col= $possible->[0];
				$log->debug("Field ".$field->name." and ".$col_map{$col}." would both claim "._cell_name($row, $col))
					if $log->is_debug;
				return;
			}
		}
		elsif (@available > 1) {
			# It is possible for a field to match more than one column.
			# If so, we send it to the back of the list in case another more specific
			# column claims one of the options.
			if (++$ambiguous > @todo) {
				$log->debug("Can't decide between ".join(', ', map { _cell_name($row,$_) } @available)." for field ".$field->name)
					if $log->is_debug;
				return;
			}
			push @todo, $field;
		}
		else {
			$col_map{$available[0]}= $field->name;
			$ambiguous= 0; # made progress, start counting over again
		}
	}
	# Success!  convert the col map to an array of col-index-per-field
	$log->debug("Found headers at ".join(' ', map { _cell_name($row,$_) } sort keys %col_map))
		if $log->is_debug;
	return { reverse %col_map };
}


sub table_location {
	my ($self)= @_;
	return undef unless defined $self->{_table_location};
	# Deep-clone the location
	my %loc= %{ $self->_table_location };
	$loc{field_col}= { %{ $loc{field_col} } };
	return \%loc;
}


sub record_count {
	my $self= shift;
	return 0 unless defined $self->_table_location;
	return $self->_table_location->{max_row} - $self->_table_location->{min_row} + 1;
}


sub records {
	my ($self, %opts)= @_;
	my $i= $self->iterator(%opts);
	my @records;
	while (my $r= $i->()) { push @records, $r; }
	return \@records;
}


sub record_arrays { shift->records(as => 'array', @_) }


our %_Iterators;

sub iterator {
	my ($self, %opts)= @_;
	my ($as, $blank_row, $on_error)= delete @opts{'as','blank_row','on_error'};
	croak "Unknown option(s) to iterator: ".join(', ', keys %opts)
		if keys %opts;

	$as= 'hash' unless defined $as;
	my $hash= ($as eq 'hash');

	$blank_row= 'end' unless defined $blank_row;
	my $skip_blank_row= ($blank_row eq 'skip');
	my $end_blank_row=  ($blank_row eq 'end');

	my $sheet=     $self->_table_location->{sheet};
	my $min_row=   $self->_table_location->{min_row};
	my $row=       $min_row - 1;
	my $col;
	my $min_col=   $self->_table_location->{min_col};
	my $remaining= $self->_table_location->{max_row} - $self->_table_location->{min_row} + 1;
	my $is_blank_row;
	my %field_col= %{ $self->_table_location->{field_col} };
	my (@result_keys, @field_extractors, @validations);
	for my $field ($self->field_list) {
		my $blank= $field->blank;
		my $src_col= $field_col{$field->name};

		# Don't need an extractor for fields not found in the table if result type is hash,
		# but if result type is array we need to pad with a null value
		if (!defined $src_col) {
			$hash or push @field_extractors, sub { undef; };
			next;
		}

		push @result_keys, $field->name if $hash;

		# If trimming, use a different implementation than if not, for a little efficiency
		push @field_extractors, $field->trim?
			sub {
				my $v= $sheet->get_cell($row, $src_col);
				return $blank unless defined $v;
				$v= $v->value;
				$v =~ s/^\s*(.*?)\s*$/$1/;
				return $blank unless length $v;
				$is_blank_row= 0;
				$v;
			}
		:
			sub {
				my $v= $sheet->get_cell($row, $src_col);
				defined $v && length($v= $v->value)
					or return $blank;
				$is_blank_row= 0;
				$v;
			};

		if (defined (my $type= $field->type)) {
			# This sub will access the values array at the same position as the current field_extractor
			my $idx= $#field_extractors;
			push @validations, sub {
				return if $type->check($_[0][$idx]);
				$col= $src_col; # so the iterator->col reports the column of the error
				croak "Not a ".$type->name." at cell "._cell_name($row, $col);
			};
		}
	}

	# Closure over everything, for very fast access
	my $sub= sub {
		$log->trace("iterator: remaining=$remaining row=$row sheet=$sheet");
		again:
		return unless $remaining > 0;
		++$row;
		$col= $min_col;
		--$remaining;
		$is_blank_row= 1; # This var is closured, and gets set to 0 by the next line
		my @values= map { $_->() } @field_extractors;
		goto again if $skip_blank_row && $is_blank_row;
		if ($end_blank_row && $is_blank_row) {
			$remaining= 0;
			return;
		}
		$_->(\@values) for @validations; # This can die.  It can also be an empty list.
		return $hash? do { my %r; @r{@result_keys}= @values; \%r } : \@values;
	};

	# Blessed coderef, so we can call methods on it
	bless $sub, 'Spreadsheet::ExcelTableReader::Iterator';

	# Store references to all the closered variables so the methods can access them
	$_Iterators{$sub}= {
		r_sheet => \$sheet,
		r_row => \$row,
		r_col => \$col,
		r_remaining => \$remaining,
		min_row => $self->_table_location->{min_row},
		max_row => $self->_table_location->{max_row},
	};

	return $sub;
}

package Spreadsheet::ExcelTableReader::Iterator;

sub DESTROY   { delete $_Iterators{$_[0]}; }
sub sheet     { ${ $_Iterators{$_[0]}{r_sheet} } }
sub col       { ${ $_Iterators{$_[0]}{r_col} } }
sub row       { ${ $_Iterators{$_[0]}{r_row} } }
sub remaining { ${ $_Iterators{$_[0]}{r_remaining} } }

sub rewind {
	my $self= $_Iterators{$_[0]};
	${$self->{r_row}}= $self->{min_row} - 1;
	${$self->{r_remaining}}= $self->{max_row} - $self->{min_row} + 1;
	return 1;
}

1;

__END__