File Coverage

blib/lib/Spreadsheet/ReadGnumeric.pm

Criterion	Covered	Total	%
statement	221	231	95.6
branch	77	94	81.9
condition	31	35	88.5
subroutine	38	39	97.4
pod	5	5	100.0
total	372	404	92.0

# -*- mode: perl; -*-
#
# Spreadsheet reader for Gnumeric format that returns a
# Spreadsheet::Read-compatible data structure.
#
# Documentation below "__END__".
#
# [created.  -- rgr, 26-Dec-22.]
#

package Spreadsheet::ReadGnumeric;

use 5.010;

use strict;
use warnings;

use XML::Parser::Lite;
use Spreadsheet::Gnumeric::StyleRegion;

our $VERSION = '0.3';

use parent qw(Spreadsheet::Gnumeric::Base);

BEGIN {
    Spreadsheet::ReadGnumeric->define_instance_accessors
	(# User options to control parsing.
	 qw(gzipped_p cells rc attr merge minimal_attributes convert_colors),
	 # Intermediate data structures for sheet parsing.
	 qw(sheet style_regions style_attributes),
	 # XML parsing internals.
	 qw(current_elt current_attrs chars namespaces element_stack));
}

sub new {
    my ($class, @options) = @_;

    my $self = $class->SUPER::new(@options);
    $self->{_cells} //= 1;
    $self->{_rc} //= 1;
    $self->{_convert_colors} //= 1;
    return $self;
}

sub sheets {
    # Read-only slot.  Make sure the sheets slot is initialized.
    my ($self) = @_;

    my $sheets = $self->{_sheets};
    unless ($sheets) {
	# [I'm afraid this is just cargo-culting here.  -- rgr, 27-Dec-22.]
	my $parser_data = { parser => __PACKAGE__,
			    type => 'gnumeric',
			    version => $VERSION };
	my $attrs = { parsers => [ $parser_data ],
		      %$parser_data,
		      error => undef };
	$sheets = [ $attrs ];
	$self->{_sheets} = $sheets;
    }
    return $sheets;
}

### XML parsing support.

# This is because XML::Parser::Lite callbacks are called with the Expat object
# and not us, so we must bind $Self dynamically around the parsing operation.
use vars qw($Self);

sub _context_string {
    my ($self) = @_;

    my $stack = $self->element_stack;
    return $self->current_elt
	unless $stack;
    return join(' ', (map { $_->[0]; } @$stack), $self->current_elt);
}

sub _decode_xlmns_name {
    # Figure out whether we have a Gnumeric element name.
    my ($self, $elt_name) = @_;

    my ($ns_prefix, $base_elt_name) = $elt_name =~ /^([^:]+):([^:]+)$/;
    if ($ns_prefix) {
	# See if the prefix is the one we want.
	my $url = $self->namespaces->{$ns_prefix};
	if ($url && $url eq "http://www.gnumeric.org/v10.dtd") {
	    # Belongs to the Gnumeric schema.
	    return ($base_elt_name, 1);
	}
	else {
	    # It's something else.
	    return ($elt_name, 0);
	}
    }
    else {
	# Assume unqualified names belong to Gnumeric (even though we've never
	# seen any).
	return ($elt_name, 1);
    }
}

sub _handle_start {
    my ($expat, $elt, @attrs) = @_;
    my $attrs = { @attrs };

    # Establish the new namespace scope.  We do this first, because it may
    # define the prefix used on this element.
    my $old_ns_scope = $Self->namespaces || { };
    my $new_ns_scope = { %$old_ns_scope };
    if (grep { /^xmlns:(.*)$/ } keys(%$attrs)) {
	# Copy so as not to clobber the outer scope.
	$new_ns_scope = { %$old_ns_scope };
	for my $attr (keys(%$attrs)) {
	    if ($attr =~ /^xmlns:(.*)$/) {
		my $ns_prefix = $1;
		$new_ns_scope->{$ns_prefix} = $attrs->{$attr};
	    }
	}
    }
    $Self->namespaces($new_ns_scope);

    # Stack the outer context.
    my $stack = $Self->element_stack || [ ];
    push(@$stack, [ $Self->current_elt, $Self->current_attrs,
		    $Self->chars, $old_ns_scope ])
	if $Self->current_elt;
    $Self->element_stack($stack);

    # Install the new element context.
    my ($decoded_name) = $Self->_decode_xlmns_name($elt);
    $Self->current_elt($decoded_name);
    $Self->current_attrs($attrs);
    $Self->chars('');
}

sub _handle_char {
    # Just collect them in our "chars" slot.
    my ($expat, $chars) = @_;

    if (0) {
	warn("handle_char:  '$chars' in ", $Self->_context_string, "\n")
	    unless $chars =~ /^\s*$/;
    }
    $Self->{_chars} .= $chars;
}

sub _handle_end {
    my ($expat, $raw_elt_name) = @_;

    # Process the completed element.
    my ($elt_name, $gnumeric_p) = $Self->_decode_xlmns_name($raw_elt_name);
    if ($gnumeric_p) {
	my $method = "_process_${elt_name}_elt";
	$Self->$method($Self->chars, %{$Self->current_attrs})
	    if $Self->can($method);
    }

    # Restore the outer element context.
    my $stack = $Self->element_stack;
    return
	unless @$stack;
    my ($elt, $attrs, $chars, $old_ns_scope) = @{pop(@$stack)};
    $Self->current_elt($elt);
    $Self->current_attrs($attrs);
    $Self->chars($chars);
    $Self->namespaces($old_ns_scope);
}

### Utility routines.

sub _decode_alpha {
    # Note that this is one-based, so "A" is 1, "Z" is 26, and "AA" is 27.  But
    # there is no consistent zero digit, so this is not really base 26; if it
    # were, "A" should be zero and "Z" should overflow to "BA".
    my ($alpha) = @_;

    if (length($alpha) == 0) {
	return 0;
    }
    else {
	return (26 * _decode_alpha(substr($alpha, 0, -1))
		+ ord(lc(substr($alpha, -1))) - ord('a') + 1)
    }
}

sub _decode_cell_name {
    my ($cell_name) = @_;

    my ($alpha, $digits) = $cell_name =~ /^([a-zA-Z]+)(\d+)$/;
    return
	unless $alpha;
    return (_decode_alpha($alpha), 0 + $digits);
}

sub _encode_cell_name {
    # Note that $value is one-based, so 1 corresponds to "A".  See the note
    # under _decode_alpha.
    my ($value) = @_;

    return ($value <= 26
	    ? chr(ord('A') + $value - 1)
	    : (_encode_cell_name(int(($value - 1) / 26))
	       . _encode_cell_name(1 + ($value - 1) % 26)));
}

### Spreadsheet parsing

sub _parse_stream {
    # Create a new XML::Parser::Lite instance, use it to drive the parsing of
    # $xml_stream (which we assume is uncompressed), and return the resulting
    # spreadsheet object.
    my ($self, $xml_stream) = @_;

    my $parser = XML::Parser::Lite->new
	(Style => 'Stream',
	 Handlers => { Start => \&_handle_start,
		       End   => \&_handle_end,
		       Char  => \&_handle_char });
    local $Self = $self;
    $parser->parse(join('', <$xml_stream>));
    return $self->sheets;
}

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

    # The point of the gzipped_p slot is to allow callers to suppress the gzip
    # test if the stream is not seekable.
    my $gzipped_p = $self->gzipped_p;
    if (! defined($gzipped_p)) {
	read($stream, my $block, 2) or do {
	    my $file_msg = 'from stream';
	    $file_msg = " from '$file'";
	    die "$self:  Failed to read opening bytes$file_msg:  $!";
	};
	# Test if gzipped (/usr/share/misc/magic).
	$gzipped_p = $block eq "\037\213";
	seek($stream, 0, 0);
    }
    return $gzipped_p;
}

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

    my $stream;
    if (ref($input)) {
	# Assume it's a stream.
	$stream = $input;
    }
    elsif ($input =~ m/\A(\037\213|<\?xml)/) {
	# $input is literal content, compressed and/or XML.
	open($stream, '<', \$input);
    }
    else {
	open($stream, '<', $input)
	    or die "$self:  Failed to open '$input':  $!";
    }
    binmode($stream, ':gzip')
	if $self->stream_gzipped_p($stream, ref($input) ? () : $input);
    binmode($stream, ':encoding(UTF-8)');
    return $self->_parse_stream($stream);
}

sub _process_Name_elt {
    # Record the sheet name.
    my ($self, $name) = @_;

    # Find the enclosing element, which needs to be "Sheet".
    my $stack = $self->element_stack;
    return
	unless $stack->[@$stack-1][0] eq 'Sheet';
    my $sheets = $self->sheets;
    $sheets->[0]{sheet}{$name} = @$sheets;
    $self->{_sheet}{label} = $name;
}

sub _process_MaxCol_elt {
    my ($self, $maxcol) = @_;

    $self->{_sheet}{mincol} = 1;
    $self->{_sheet}{maxcol} = 1 + $maxcol;
}

sub _process_MaxRow_elt {
    my ($self, $maxrow) = @_;

    return
	unless defined($maxrow);
    $self->{_sheet}{minrow} = 1;
    $self->{_sheet}{maxrow} = 1 + $maxrow;
}

sub _process_Merge_elt {
    # We don't care about MergedRegions, as that's just a container.
    my ($self, $text) = @_;

    push(@{$self->{_sheet}{merged}},
	 [ map { _decode_cell_name($_) } split(':', $text) ])
	if $self->attr;
}

sub _process_Cell_elt {
    my ($self, $text, %keys) = @_;

    # Ignore empty cells.
    return
	unless $text;
    # Both $row and $col are zero-based; the cell matrix is one-based.
    my ($row, $col) = ($keys{Row}, $keys{Col});
    $self->{_sheet}{cell}[$col + 1][$row + 1] = $text
	if $self->rc;
    $self->{_sheet}{_encode_cell_name($col + 1) . ($row + 1)} = $text
	if $self->cells;
    $self->{_sheet}{attr}[$col + 1][$row + 1]
	= $self->find_style_for_cell($col, $row)
	    if $self->attr;
}

sub _process_Sheet_elt {
    # Add $self->sheet to $self->sheets.
    my ($self, $text, %keys) = @_;

    my $sheets = $self->sheets;
    my $attrs = $sheets->[0];
    my $indx = $attrs->{sheets} = @$sheets;
    my $sheet = $self->sheet;
    $self->{_sheet}{cell}[0] = [ ]	# for consistency.
	if $self->{_sheet}{cell};
    push(@$sheets, $sheet);
    $sheet->{indx} = $indx;
    my $attr = $self->attr;
    if ($attr) {
	$sheet->{style_regions} = $self->style_regions
	    if $attr eq 'keep';
	$self->style_regions([ ]);
	# Distribute non-minimal attributes.
	unless ($self->minimal_attributes) {
	    for my $col (1 .. $sheet->{maxcol}) {
		for my $row (1 .. $sheet->{maxrow} || 0) {
		    $self->{_sheet}{attr}[$col][$row]
			||= $self->find_style_for_cell($col - 1, $row - 1);
		}
	    }
	}
	# Distribute merging information.
	my $merged = $sheet->{merged};
	if ($merged) {
	    my $attrs = $sheet->{attr};
	    my $merge_p = $self->merge;
	    for my $merge (@$merged) {
		my ($col1, $row1, $col2, $row2) = @$merge;
		my $base_cell_name = _encode_cell_name($col1) . $row1;
		my $merge_flag = $merge_p ? $base_cell_name : 1;
		my $base_cell_contents = ($self->rc
					  ? $sheet->{cell}[$col1][$row1]
					  : $sheet->{$base_cell_name});
		for my $col ($col1 .. $col2) {
		    for my $row ($row1 .. $row2) {
			my $cell_attrs
			    = ($attrs->[$col][$row]
			       || $self->find_style_for_cell($col - 1,
							     $row - 1)
			       || { });
			# Copy the hash so we don't accidentally mark other
			# cells as merged due to shared structure.
			$cell_attrs = { %$cell_attrs };
			$cell_attrs->{merged} = $merge_flag;
			$attrs->[$col][$row] = $cell_attrs;
			# When $merge_p, also copy cell contents.
			if ($merge_p) {
			    $sheet->{cell}[$col][$row] = $base_cell_contents
				if $self->rc;
			    my $cell_name = _encode_cell_name($col) . $row;
			    $sheet->{$cell_name} = $base_cell_contents
				if $self->cells;
			}
		    }
		}
	    }
	}
    }
    $self->sheet({ });
}

## Parsing cell style attributes

sub _convert_identity {
    # We assume this is 0 or 1.
    my ($value) = @_;

    return $value;
}

sub _convert_align {
    # This is a string which we truncate and downcase -- and hope the caller
    # can figure it out, since Gnumeric seems to use non-standard values.
    my ($value) = @_;

    return $value =~ /^GNM_.ALIGN_(.*)$/ ? lc($1) : lc($value);
}

sub _convert_color {
    my ($color) = @_;

    my $convert_primary = sub {
	# Pad and/or truncate the value.
	my ($value) = @_;

	my $len = length($value);
	if ($len <= 2) {
	    # Less than #xFF we round to zero.
	    return '00';
	}
	elsif ($len == 3) {
	    return '0' . substr($value, 0, 1);
	}
	else {
	    return substr($value, 0, 2);
	}
    };

    return join('', '#', map { $convert_primary->($_); } split(':', $color));
}

my %style_conversion_map
    = (Back => [ bgcolor => \&_convert_color, 1 ],
       Bold => [ bold    => \&_convert_identity ],
       # Font is not an attribute.
       Fore => [ fgcolor => \&_convert_color, 1 ],
       Format => [ format  => \&_convert_identity ],
       HAlign => [ halign  => \&_convert_align ],
       Hidden => [ hidden  => \&_convert_identity ],
       Indent => [ indent => \&_convert_identity ],
       Italic => [ italic => \&_convert_identity ],
       Locked => [ locked => \&_convert_identity ],
       PatternColor => [ pattern_color => \&_convert_color, 1 ],
       Rotation => [ rotation => \&_convert_identity ],
       Script => [ script => \&_convert_identity ],
       Shade => [ shade => \&_convert_identity ],
       ShrinkToFit => [ shrink_to_fit => \&_convert_identity ],
       Unit => [ size => \&_convert_identity ],
       StrikeThrough => [ strike_through => \&_convert_identity ],
       Underline => [ uline => \&_convert_identity ],
       VAlign => [ valign => \&_convert_align ],
       WrapText => [ wrap => \&_convert_identity ]);

sub _convert_attributes {
    # It is a useful coincidence that the cell metadata Spreadsheet::Read
    # calls attributes are stored in XML attributes by Gnumeric.  So we convert
    # Gnumeric cell attributes to Spreadsheet::Read cell attributes.
    my ($self, $cell_attributes, $gnumeric_attributes) = @_;

    my $convert_colors = $self->convert_colors;
    for my $name (keys(%$gnumeric_attributes)) {
	my $value = $gnumeric_attributes->{$name};
	my $conversion = $style_conversion_map{$name};
	my ($converted_name, $converter, $color_p)
	    = ($conversion ? @$conversion : (lc($name), \&_convert_identity));
	$converter = \&_convert_identity
	    if $color_p && ! $convert_colors;
	my $converted_value = $converter->($value);
	$cell_attributes->{$converted_name} = $converted_value;
    }
}

sub _process_Font_elt {
    # Process a font definition.  This is contained inside , so it ends </td>
</tr>

<tr>
<td  class="h" >
<a name="470">470</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">     # before it, so we initialize the style_attributes slot here, then
    # fills it out.
    my ($self, $font_name, %keys) = @_;

    return
	unless $self->attr;
    my $style_attributes = { font => $font_name };
    $self->_convert_attributes($style_attributes, \%keys);
    $self->style_attributes($style_attributes);
}

sub _process_Style_elt {
    # Process style attributes.
    my ($self, $text, %keys) = @_;

    return
	unless $self->attr;
    my $style_attributes = $self->style_attributes or die;
    $self->_convert_attributes($style_attributes, \%keys);
}

sub find_style_for_cell {
    # Assuming $self->attr is true, find the style region for ($col, $row) and
    # return its attribute hash.
    my ($self, $col, $row) = @_;

    my $found;
    for my $style_region (@{$self->{_style_regions}}) {
	if ($style_region->start_col <= $col
	        && $col <= $style_region->end_col
	    && $style_region->start_row <= $row
	        && $row <= $style_region->end_row) {
	    die "duplicate at ($col, $row)"
		# style regions are supposed to be disjoint; enable this for
		# extra paranoia.
		if 0 && $found;
	    $found = $style_region;
	}
    }
    return $found && $found->style_attributes;
}

sub _process_StyleRegion_elt {
    # Collect a style region for the style attributes we have just defined.
    my ($self, $text, %keys) = @_;

    return
	unless $self->attr;
    my $style_region = Spreadsheet::Gnumeric::StyleRegion->new
	(start_col => $keys{startCol}, end_col => $keys{endCol},
	 start_row => $keys{startRow}, end_row => $keys{endRow},
	 style_attributes => $self->style_attributes);
    push(@{$self->{_style_regions}}, $style_region);
}

1;

__END__