File Coverage

blib/lib/Spreadsheet/WriteExcel/OLEwriter.pm

Criterion	Covered	Total	%
statement	197	203	97.0
branch	22	30	73.3
condition			n/a
subroutine	17	17	100.0
pod	0	5	0.0
total	236	255	92.5

package Spreadsheet::WriteExcel::OLEwriter;

###############################################################################
#
# OLEwriter - A writer class to store BIFF data in a OLE compound storage file.
#
#
# Used in conjunction with Spreadsheet::WriteExcel
#
# Copyright 2000-2010, John McNamara, [e-mail]
#
# Documentation after __END__
#

use Exporter;
use strict;
use Carp;
use FileHandle;





use vars qw($VERSION @ISA);
@ISA = qw(Exporter);

$VERSION = '2.40';

###############################################################################
#
# new()
#
# Constructor
#
sub new {

    my $class  = shift;
    my $self   = {
                    _olefilename   => $_[0],
                    _filehandle    => "",
                    _fileclosed    => 0,
                    _internal_fh   => 0,
                    _biff_only     => 0,
                    _size_allowed  => 0,
                    _biffsize      => 0,
                    _booksize      => 0,
                    _big_blocks    => 0,
                    _list_blocks   => 0,
                    _root_start    => 0,
                    _block_count   => 4,
                 };

    bless $self, $class;
    $self->_initialize();
    return $self;
}


###############################################################################
#
# _initialize()
#
# Create a new filehandle or use the provided filehandle.
#
sub _initialize {

    my $self    = shift;
    my $olefile = $self->{_olefilename};
    my $fh;

    # If the filename is a reference it is assumed that it is a valid
    # filehandle, if not we create a filehandle.
    #
    if (ref($olefile)) {
        $fh = $olefile;
    }
    else{

        # Create a new file, open for writing
        $fh = FileHandle->new("> $olefile");

        # Workbook.pm also checks this but something may have happened since
        # then.
        if (not defined $fh) {
            croak "Can't open $olefile. It may be in use or protected.\n";
        }

        # binmode file whether platform requires it or not
        binmode($fh);

        $self->{_internal_fh} = 1;
    }

    # Store filehandle
    $self->{_filehandle} = $fh;
}


###############################################################################
#
# set_size($biffsize)
#
# Set the size of the data to be written to the OLE stream
#
#   $big_blocks = (109 depot block x (128 -1 marker word)
#                 - (1 x end words)) = 13842
#   $maxsize    = $big_blocks * 512 bytes = 7087104
#
sub set_size {

    my $self    = shift;
    my $maxsize = 7_087_104; # Use Spreadsheet::WriteExcel::Big to exceed this

    if ($_[0] > $maxsize) {
        return $self->{_size_allowed} = 0;
    }

    $self->{_biffsize} = $_[0];

    # Set the min file size to 4k to avoid having to use small blocks
    if ($_[0] > 4096) {
        $self->{_booksize} = $_[0];
    }
    else {
        $self->{_booksize} = 4096;
    }

    return $self->{_size_allowed} = 1;

}


###############################################################################
#
# _calculate_sizes()
#
# Calculate various sizes needed for the OLE stream
#
sub _calculate_sizes {

    my $self     = shift;
    my $datasize = $self->{_booksize};

    if ($datasize % 512 == 0) {
        $self->{_big_blocks} = $datasize/512;
    }
    else {
        $self->{_big_blocks} = int($datasize/512) +1;
    }
    # There are 127 list blocks and 1 marker blocks for each big block
    # depot + 1 end of chain block
    $self->{_list_blocks} = int(($self->{_big_blocks})/127) +1;
    $self->{_root_start}  = $self->{_big_blocks};
}


###############################################################################
#
# close()
#
# Write root entry, big block list and close the filehandle.
# This routine is used to explicitly close the open filehandle without
# having to wait for DESTROY.
#
sub close {

    my $self = shift;

    return if not $self->{_size_allowed};

    $self->_write_padding()          if not $self->{_biff_only};
    $self->_write_property_storage() if not $self->{_biff_only};
    $self->_write_big_block_depot()  if not $self->{_biff_only};

    my $close = 1; # Default to no error for external filehandles.

    # Close the filehandle if it was created internally.
    $close = CORE::close($self->{_filehandle}) if $self->{_internal_fh};

    $self->{_fileclosed} = 1;

    return $close;
}


###############################################################################
#
# DESTROY()
#
# Close the filehandle if it hasn't already been explicitly closed.
#
sub DESTROY {

    my $self = shift;

    local ($@, $!, $^E, $?);

    $self->close() unless $self->{_fileclosed};
}


###############################################################################
#
# write($data)
#
# Write BIFF data to OLE file.
#
sub write {

    my $self = shift;

    # Protect print() from -l on the command line.
    local $\ = undef;
    print {$self->{_filehandle}} $_[0];
}


###############################################################################
#
# write_header()
#
# Write OLE header block.
#
sub write_header {

    my $self            = shift;

    return if $self->{_biff_only};
    $self->_calculate_sizes();

    my $root_start      = $self->{_root_start};
    my $num_lists       = $self->{_list_blocks};

    my $id              = pack("NN",   0xD0CF11E0, 0xA1B11AE1);
    my $unknown1        = pack("VVVV", 0x00, 0x00, 0x00, 0x00);
    my $unknown2        = pack("vv",   0x3E, 0x03);
    my $unknown3        = pack("v",    -2);
    my $unknown4        = pack("v",    0x09);
    my $unknown5        = pack("VVV",  0x06, 0x00, 0x00);
    my $num_bbd_blocks  = pack("V",    $num_lists);
    my $root_startblock = pack("V",    $root_start);
    my $unknown6        = pack("VV",   0x00, 0x1000);
    my $sbd_startblock  = pack("V",    -2);
    my $unknown7        = pack("VVV",  0x00, -2 ,0x00);
    my $unused          = pack("V",    -1);

    # Protect print() from -l on the command line.
    local $\ = undef;

    print {$self->{_filehandle}}  $id;
    print {$self->{_filehandle}}  $unknown1;
    print {$self->{_filehandle}}  $unknown2;
    print {$self->{_filehandle}}  $unknown3;
    print {$self->{_filehandle}}  $unknown4;
    print {$self->{_filehandle}}  $unknown5;
    print {$self->{_filehandle}}  $num_bbd_blocks;
    print {$self->{_filehandle}}  $root_startblock;
    print {$self->{_filehandle}}  $unknown6;
    print {$self->{_filehandle}}  $sbd_startblock;
    print {$self->{_filehandle}}  $unknown7;

    for (1..$num_lists) {
        $root_start++;
        print {$self->{_filehandle}}  pack("V", $root_start);
    }

    for ($num_lists..108) {
        print {$self->{_filehandle}}  $unused;
    }
}


###############################################################################
#
# _write_big_block_depot()
#
# Write big block depot.
#
sub _write_big_block_depot {

    my $self         = shift;
    my $num_blocks   = $self->{_big_blocks};
    my $num_lists    = $self->{_list_blocks};
    my $total_blocks = $num_lists *128;
    my $used_blocks  = $num_blocks + $num_lists +2;

    my $marker       = pack("V", -3);
    my $end_of_chain = pack("V", -2);
    my $unused       = pack("V", -1);


    # Protect print() from -l on the command line.
    local $\ = undef;

    for my $i (1..$num_blocks-1) {
        print {$self->{_filehandle}}  pack("V",$i);
    }

    print {$self->{_filehandle}}  $end_of_chain;
    print {$self->{_filehandle}}  $end_of_chain;

    for (1..$num_lists) {
        print {$self->{_filehandle}}  $marker;
    }

    for ($used_blocks..$total_blocks) {
        print {$self->{_filehandle}}  $unused;
    }
}


###############################################################################
#
# _write_property_storage()
#
# Write property storage. TODO: add summary sheets
#
sub _write_property_storage {

    my $self     = shift;

    my $rootsize = -2;
    my $booksize = $self->{_booksize};

    #################  name         type   dir start size
    $self->_write_pps('Root Entry', 0x05,   1,   -2, 0x00);
    $self->_write_pps('Workbook',   0x02,  -1, 0x00, $booksize);
    $self->_write_pps('',           0x00,  -1, 0x00, 0x0000);
    $self->_write_pps('',           0x00,  -1, 0x00, 0x0000);
}


###############################################################################
#
# _write_pps()
#
# Write property sheet in property storage
#
sub _write_pps {

    my $self            = shift;

    my $name            = $_[0];
    my @name            = ();
    my $length          = 0;

    if ($name ne '') {
        $name   = $_[0] . "\0";
        # Simulate a Unicode string
        @name   = map(ord, split('', $name));
        $length = length($name) * 2;
    }

    my $rawname         = pack("v*", @name);
    my $zero            = pack("C",  0);

    my $pps_sizeofname  = pack("v",  $length);    #0x40
    my $pps_type        = pack("v",  $_[1]);      #0x42
    my $pps_prev        = pack("V",  -1);         #0x44
    my $pps_next        = pack("V",  -1);         #0x48
    my $pps_dir         = pack("V",  $_[2]);      #0x4c

    my $unknown1        = pack("V",  0);

    my $pps_ts1s        = pack("V",  0);          #0x64
    my $pps_ts1d        = pack("V",  0);          #0x68
    my $pps_ts2s        = pack("V",  0);          #0x6c
    my $pps_ts2d        = pack("V",  0);          #0x70
    my $pps_sb          = pack("V",  $_[3]);      #0x74
    my $pps_size        = pack("V",  $_[4]);      #0x78


    # Protect print() from -l on the command line.
    local $\ = undef;

    print {$self->{_filehandle}}  $rawname;
    print {$self->{_filehandle}}  $zero x (64 -$length);
    print {$self->{_filehandle}}  $pps_sizeofname;
    print {$self->{_filehandle}}  $pps_type;
    print {$self->{_filehandle}}  $pps_prev;
    print {$self->{_filehandle}}  $pps_next;
    print {$self->{_filehandle}}  $pps_dir;
    print {$self->{_filehandle}}  $unknown1 x 5;
    print {$self->{_filehandle}}  $pps_ts1s;
    print {$self->{_filehandle}}  $pps_ts1d;
    print {$self->{_filehandle}}  $pps_ts2d;
    print {$self->{_filehandle}}  $pps_ts2d;
    print {$self->{_filehandle}}  $pps_sb;
    print {$self->{_filehandle}}  $pps_size;
    print {$self->{_filehandle}}  $unknown1;
}


###############################################################################
#
# _write_padding()
#
# Pad the end of the file
#
sub _write_padding {

    my $self     = shift;
    my $biffsize = $self->{_biffsize};
    my $min_size;

    if ($biffsize < 4096) {
        $min_size = 4096;
    }
    else {
        $min_size = 512;
    }

    # Protect print() from -l on the command line.
    local $\ = undef;

    if ($biffsize % $min_size != 0) {
        my $padding  = $min_size - ($biffsize % $min_size);
        print {$self->{_filehandle}}  "\0" x $padding;
    }
}


1;


__END__