package Spreadsheet::WriteExcel::Properties;

###############################################################################
#
# Properties - A module for creating Excel property sets.
#
#
# Used in conjunction with Spreadsheet::WriteExcel
#
# Copyright 2000-2010, John McNamara.
#
# Documentation after __END__
#

use Exporter;
use strict;
use Carp;
use POSIX 'fmod';
use Time::Local 'timelocal';




use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
@ISA        = qw(Exporter);

$VERSION    = '2.40';

# Set up the exports.
my @all_functions = qw(
    create_summary_property_set
    create_doc_summary_property_set
    _pack_property_data
    _pack_VT_I2
    _pack_VT_LPSTR
    _pack_VT_FILETIME
);

my @pps_summaries = qw(
    create_summary_property_set
    create_doc_summary_property_set
);

@EXPORT         = ();
@EXPORT_OK      = (@all_functions);
%EXPORT_TAGS    = (testing          => \@all_functions,
                   property_sets    => \@pps_summaries,
                  );


###############################################################################
#
# create_summary_property_set().
#
# Create the SummaryInformation property set. This is mainly used for the
# Title, Subject, Author, Keywords, Comments, Last author keywords and the
# creation date.
#
sub create_summary_property_set {

    my @properties          = @{$_[0]};

    my $byte_order          = pack 'v',  0xFFFE;
    my $version             = pack 'v',  0x0000;
    my $system_id           = pack 'V',  0x00020105;
    my $class_id            = pack 'H*', '00000000000000000000000000000000';
    my $num_property_sets   = pack 'V',  0x0001;
    my $format_id           = pack 'H*', 'E0859FF2F94F6810AB9108002B27B3D9';
    my $offset              = pack 'V',  0x0030;
    my $num_property        = pack 'V',  scalar @properties;
    my $property_offsets    = '';

    # Create the property set data block and calculate the offsets into it.
    my ($property_data, $offsets) = _pack_property_data(\@properties);

    # Create the property type and offsets based on the previous calculation.
    for my $i (0 .. @properties -1) {
        $property_offsets .= pack('VV', $properties[$i]->[0], $offsets->[$i]);
    }

    # Size of $size (4 bytes) +  $num_property (4 bytes) + the data structures.
    my $size = 8 + length($property_offsets) + length($property_data);
       $size = pack 'V',  $size;


    return  $byte_order         .
            $version            .
            $system_id          .
            $class_id           .
            $num_property_sets  .
            $format_id          .
            $offset             .
            $size               .
            $num_property       .
            $property_offsets   .
            $property_data;
}


###############################################################################
#
# Create the DocSummaryInformation property set. This is mainly used for the
# Manager, Company and Category keywords.
#
# The DocSummary also contains a stream for user defined properties. However
# this is a little arcane and probably not worth the implementation effort.
#
sub create_doc_summary_property_set {

    my @properties          = @{$_[0]};

    my $byte_order          = pack 'v',  0xFFFE;
    my $version             = pack 'v',  0x0000;
    my $system_id           = pack 'V',  0x00020105;
    my $class_id            = pack 'H*', '00000000000000000000000000000000';
    my $num_property_sets   = pack 'V',  0x0002;

    my $format_id_0         = pack 'H*', '02D5CDD59C2E1B10939708002B2CF9AE';
    my $format_id_1         = pack 'H*', '05D5CDD59C2E1B10939708002B2CF9AE';
    my $offset_0            = pack 'V',  0x0044;
    my $num_property_0      = pack 'V',  scalar @properties;
    my $property_offsets_0  = '';

    # Create the property set data block and calculate the offsets into it.
    my ($property_data_0, $offsets) = _pack_property_data(\@properties);

    # Create the property type and offsets based on the previous calculation.
    for my $i (0 .. @properties -1) {
        $property_offsets_0 .= pack('VV', $properties[$i]->[0], $offsets->[$i]);
    }

    # Size of $size (4 bytes) +  $num_property (4 bytes) + the data structures.
    my $data_len = 8 + length($property_offsets_0) + length($property_data_0);
    my $size_0   = pack 'V',  $data_len;


    # The second property set offset is at the end of the first property set.
    my $offset_1 = pack 'V',  0x0044 + $data_len;

    # We will use a static property set stream rather than try to generate it.
    my $property_data_1 = pack 'H*', join '', qw (
        98 00 00 00 03 00 00 00 00 00 00 00 20 00 00 00
        01 00 00 00 36 00 00 00 02 00 00 00 3E 00 00 00
        01 00 00 00 02 00 00 00 0A 00 00 00 5F 50 49 44
        5F 47 55 49 44 00 02 00 00 00 E4 04 00 00 41 00
        00 00 4E 00 00 00 7B 00 31 00 36 00 43 00 34 00
        42 00 38 00 33 00 42 00 2D 00 39 00 36 00 35 00
        46 00 2D 00 34 00 42 00 32 00 31 00 2D 00 39 00
        30 00 33 00 44 00 2D 00 39 00 31 00 30 00 46 00
        41 00 44 00 46 00 41 00 37 00 30 00 31 00 42 00
        7D 00 00 00 00 00 00 00 2D 00 39 00 30 00 33 00
    );


    return  $byte_order         .
            $version            .
            $system_id          .
            $class_id           .
            $num_property_sets  .
            $format_id_0        .
            $offset_0           .
            $format_id_1        .
            $offset_1           .

            $size_0             .
            $num_property_0     .
            $property_offsets_0 .
            $property_data_0    .

            $property_data_1;
}


###############################################################################
#
# _pack_property_data().
#
# Create a packed property set structure. Strings are null terminated and
# padded to a 4 byte boundary. We also use this function to keep track of the
# property offsets within the data structure. These offsets are used by the
# calling functions. Currently we only need to handle 4 property types:
# VT_I2, VT_LPSTR, VT_FILETIME.
#
sub _pack_property_data {

    my @properties          = @{$_[0]};
    my $offset              = $_[1] || 0;
    my $packed_property     = '';
    my $data                = '';
    my @offsets;

    # Get the strings codepage from the first property.
    my $codepage = $properties[0]->[2];

    # The properties start after 8 bytes for size + num_properties + 8 bytes
    # for each property type/offset pair.
    $offset += 8 * (@properties + 1);

    for my $property (@properties) {
        push @offsets, $offset;

        my $property_type = $property->[1];

        if    ($property_type eq 'VT_I2') {
            $packed_property = _pack_VT_I2($property->[2]);
        }
        elsif ($property_type eq 'VT_LPSTR') {
            $packed_property = _pack_VT_LPSTR($property->[2], $codepage);
        }
        elsif ($property_type eq 'VT_FILETIME') {
            $packed_property = _pack_VT_FILETIME($property->[2]);
        }
        else {
            croak "Unknown property type: $property_type\n";
        }

        $offset += length $packed_property;
        $data   .= $packed_property;
    }

    return $data, \@offsets;
}


###############################################################################
#
# _pack_VT_I2().
#
# Pack an OLE property type: VT_I2, 16-bit signed integer.
#
sub _pack_VT_I2 {

    my $type    = 0x0002;
    my $value   = $_[0];

    my $data = pack 'VV', $type, $value;

    return $data;
}


###############################################################################
#
# _pack_VT_LPSTR().
#
# Pack an OLE property type: VT_LPSTR, String in the Codepage encoding.
# The strings are null terminated and padded to a 4 byte boundary.
#
sub _pack_VT_LPSTR {

    my $type        = 0x001E;
    my $string      = $_[0] . "\0";
    my $codepage    = $_[1];
    my $length;
    my $byte_string;

    if ($codepage == 0x04E4) {
        # Latin1
        $byte_string = $string;
        $length      = length $byte_string;
    }
    elsif ($codepage == 0xFDE9) {
        # UTF-8
        if ( $] > 5.008 ) {
            require Encode;
            if (Encode::is_utf8($string)) {
                $byte_string = Encode::encode_utf8($string);
            }
            else {
                $byte_string = $string;
            }
        }
        else {
            $byte_string = $string;
        }

        $length = length $byte_string;
    }
    else {
        croak "Unknown codepage: $codepage\n";
    }

    # Pack the data.
    my $data  = pack 'VV', $type, $length;
       $data .= $byte_string;

    # The packed data has to null padded to a 4 byte boundary.
    if (my $extra = $length % 4) {
        $data .= "\0" x (4 - $extra);
    }

    return $data;
}


###############################################################################
#
# _pack_VT_FILETIME().
#
# Pack an OLE property type: VT_FILETIME.
#
sub _pack_VT_FILETIME {

    my $type        = 0x0040;
    my $localtime   = $_[0];

    # Convert from localtime to seconds.
    my $seconds = Time::Local::timelocal(@{$localtime});

    # Add the number of seconds between the 1601 and 1970 epochs.
    $seconds += 11644473600;

    # The FILETIME seconds are in units of 100 nanoseconds.
    my $nanoseconds = $seconds * 1E7;

    # Pack the total nanoseconds into 64 bits.
    my $time_hi = int($nanoseconds / 2**32);
    my $time_lo = POSIX::fmod($nanoseconds, 2**32);

    my $data = pack 'VVV', $type, $time_lo, $time_hi;

    return $data;
}


1;


__END__

=encoding latin1

=head1 NAME

Properties - A module for creating Excel property sets.

=head1 SYNOPSIS

See the C<set_properties()> method in the Spreadsheet::WriteExcel documentation.

=head1 DESCRIPTION

This module is used in conjunction with Spreadsheet::WriteExcel.

=head1 AUTHOR

John McNamara jmcnamara@cpan.org

=head1 COPYRIGHT

Copyright MM-MMX, John McNamara.

All Rights Reserved. This module is free software. It may be used, redistributed and/or modified under the same terms as Perl itself.