root/lang/perl/MSWord-ExtractContent/trunk/lib/MSWord/ExtractContent.pm @ 35409

package MSWord::ExtractContent;

use strict;
use warnings;
use 5.008_001;

our $VERSION = '0.01';

use Carp;
use Encode ();
use OLE::Storage_Lite;

use Exporter 'import';

our @EXPORT = qw(
    extract_whole_contents_from_msword_file
    extract_whole_contents_from_msword_data
    extract_contents_from_msword_file
    extract_contents_from_msword_data
    extract_header_from_msword_file
    extract_header_from_msword_data
    extract_footnote_from_msword_file
    extract_footnote_from_msword_data
);

our $DEBUG   = 0;

sub extract_whole_contents_from_msword_file {
    my $filename = shift;

    return __PACKAGE__->from_file($filename)->whole_contents(@_);
}

sub extract_whole_contents_from_msword_data {
    my $buffer = shift;

    return __PACKAGE__->from_buffer($buffer)->whole_contents(@_);
}

sub extract_contents_from_msword_file {
    my $filename = shift;

    return __PACKAGE__->from_file($filename)->contents(@_);
}

sub extract_contents_from_msword_data {
    my $buffer = shift;

    return __PACKAGE__->from_buffer($buffer)->contents(@_);
}

sub extract_header_from_msword_file {
    my $filename = shift;

    return __PACKAGE__->from_file($filename)->header(@_);
}

sub extract_header_from_msword_data {
    my $buffer = shift;

    return __PACKAGE__->from_buffer($buffer)->header(@_);
}

sub extract_footnote_from_msword_file {
    my $filename = shift;

    return __PACKAGE__->from_file($filename)->footnote(@_);
}

sub extract_footnote_from_msword_data {
    my $buffer = shift;

    return __PACKAGE__->from_buffer($buffer)->footnote(@_);
}

sub from_file {
    my $class    = shift;
    my $filename = shift;

    my $self = $class->_ctor();

    if (! $self->_setup($filename)) {
        return;
    }

    return $self;
}

sub from_buffer {
    my $class  = shift;
    my $buffer = shift;

    my $self = $class->_ctor();

    if (! $self->_setup(\$buffer)) {
        return;
    }

    return $self;
}

sub _ctor {
    my $class = shift;
       $class = ref $class if ref $class;

    my $self = bless {}, $class;

    return $self;
}

sub whole_contents {
    my $self = shift;

    return $self->_retrieve_and_filter_text(0, -1, @_);
}

sub contents {
    my $self = shift;

    return $self->_retrieve_and_filter_text(0, $self->{_ccpText}, @_);
}

sub footnote {
    my $self = shift;

    my $offset = $self->{_ccpText};

    return $self->_retrieve_and_filter_text($offset, $self->{_ccpFtn}, @_);
}

sub header {
    my $self = shift;

    my $offset = $self->{_ccpText} + $self->{_ccpFtn};

    return $self->_retrieve_and_filter_text($offset, $self->{_ccpHdd}, @_);
}

sub _retrieve_and_filter_text {
    my $self   = shift;
    my $offset = shift;
    my $length = shift;

    my %option = (@_ && ref $_[0] eq 'HASH') ? %{$_[0]} : @_;

    my $result = $self->_retrieve_substring($offset, $length);

    if ($option{as_plaintext}) {
        $result = _format_into_plain($result);
    }

    return $result;
}

our $PPS_NAME_WORDDOC           = 'WordDocument';
our $PPS_NAME_TABLE_TMPL        = '%dTable';

our $MAGIC_MSWORD               = 0xa5ec;
our $NFIB_MSWORD6               = 101;

our $OFFSET_FIB_IDENT           = 0x0000;
our $OFFSET_FIB_FIB             = 0x0002;

our $OFFSET_FIB_FLAGS           = 0x000a;
our $OFFSET_FIB_FCCLX           = 0x01a2;
our $OFFSET_FIB_LCBCLX          = 0x01a6;

our $OFFSET_FIB_FCMIN           = 0x0018;
our $OFFSET_FIB_FCMAC           = 0x001c;
our $OFFSET_FIB_CBMAC           = 0x0040;

our $MASK_FIBFLAG_COMPLEX       = 0x0004;
our $MASK_FIBFLAG_ENCRYPTED     = 0x0100;
our $MASK_FIBFLAG_WHICHTBLSTM   = 0x0200;

our $LENGTH_CP  = 4;
our $LENGTH_PCD = 8;

our $OFFSET_FIB_CCP_MAP = {
    ccpText     => 0x004c,
    ccpFtn      => 0x0050,
    ccpHdd      => 0x0054,
    ccpMcr      => 0x0058,
    ccpAtn      => 0x005c,
    ccpEdn      => 0x0060,
    ccpTxbx     => 0x0064,
    ccpHdrTxbx  => 0x0068,
};

sub _setup {
    my ($self, $filename) = @_;

    my $oledoc = OLE::Storage_Lite->new($filename);
    return  if ! $oledoc;

    # load main stream
    my $main_stream
        = _retrieve_entry($oledoc, $PPS_NAME_WORDDOC);
    return  if ! $main_stream;
    $self->_main_stream($main_stream);

    # parse FIB in main stream
    if (! $self->_parse_fib()) {
        return;
    }

    # load table stream
    my $name_of_table
        = sprintf $PPS_NAME_TABLE_TMPL,
            ($self->{_flags}->{fWhichTblStm}) ? 1 : 0,
        ;

    my $table_stream
        = _retrieve_entry($oledoc, $name_of_table);
    return  if ! $table_stream;
    $self->_table_stream($table_stream);

    # parse piece table
    if (! $self->_parse_piece_table()) {
        return;
    }

    return $self;
}

sub _parse_fib {
    my $self = shift;

    # Header
    $self->{_wIdent} = _get_short($self->_main_stream, $OFFSET_FIB_IDENT);
    $self->{_nFib}   = _get_short($self->_main_stream, $OFFSET_FIB_FIB);

    croak "Not a MSWord doc file"
        if $self->{_wIdent} != $MAGIC_MSWORD;
    croak "Unsupported version"
        if $self->{_nFib} < $NFIB_MSWORD6;

    # FIB flags
    my $flags = _get_short($self->_main_stream, $OFFSET_FIB_FLAGS);

    $self->{_flags}->{fComplex}
        = ($flags & $MASK_FIBFLAG_COMPLEX) ? 1 : 0;

    $self->{_flags}->{fEncrypted}
        = ($flags & $MASK_FIBFLAG_ENCRYPTED) ? 1 : 0;
    croak "Encrypted MSWord doc file is not supported"
        if $self->{_flags}->{fEncrypted};

    $self->{_flags}->{fWhichTblStm}
        = ($flags & $MASK_FIBFLAG_WHICHTBLSTM) ? 1 : 0;

    # fcMin, fcMac
    $self->{_fcMin} = _get_long($self->_main_stream, $OFFSET_FIB_FCMIN);
    $self->{_fcMac} = _get_long($self->_main_stream, $OFFSET_FIB_FCMAC);
    $self->{_cbMac} = _get_long($self->_main_stream, $OFFSET_FIB_CBMAC);

    # CLX
    $self->{_fcClx}  = _get_long($self->_main_stream, $OFFSET_FIB_FCCLX);
    $self->{_lcbClx} = _get_long($self->_main_stream, $OFFSET_FIB_LCBCLX);

    # CCPs
    $self->_parse_fib_ccps();

    return $self;
}

sub _parse_fib_ccps {
    my $self = shift;

    while (my ($field, $offset) = each %{ $OFFSET_FIB_CCP_MAP }) {
        $self->{'_' . $field} = _get_long($self->_main_stream, $offset);
    }

    return $self;
}

sub _parse_piece_table {
    my $self = shift;

    if ($self->{_lcbClx} <= 0) {
        # pseudo piece table
        my $ccpAll = 0;

        foreach my $field (keys %{ $OFFSET_FIB_CCP_MAP }) {
            $ccpAll += $self->{'_' . $field};
        }

        my $pcd = {
            fc  => $self->{_fcMin},
            cp  => 0,
            ccp => $ccpAll,
        };

        $self->{_pcds} = [ $pcd ];

        return $self;
    }

    my $clx
        = substr $self->_table_stream, $self->{_fcClx}, $self->{_lcbClx};

    while (length $clx > 0) {
        my $clxt = ord(substr $clx, 0, 1, q{});

        last  if $clxt == 2;    # plcfpcd

        if ($clxt == 1) {       # grpprl => SKIP
            my $skip = _get_short(substr $clx, 0, 2, q{});

            substr $clx, 0, $skip, q{};
        }
        else {
            croak "Unknown CLX block.";
        }
    }
    croak "PCDs not found"  if length $clx <= 0;


    my $length = _get_long(substr $clx, 0, 4, q{});

    my $n = ( $length - $LENGTH_CP )  /  ( $LENGTH_CP + $LENGTH_PCD );
    printf {*STDERR} "number of PCDs: %d\n", $n  if $DEBUG;

    my @cps;
    for (0 .. $n) {
        my $cp = _get_long(substr $clx, 0, $LENGTH_CP, q{});
        push @cps, $cp;
    }

    my @pcds;
    for my $i (1 .. $n) {
        my $pcd_data = substr $clx, 0, $LENGTH_PCD, q{};

        my $fc = _get_long($pcd_data, 2);

        my $pcd = {
            fc  => $fc,
            cp  => $cps[$i - 1],
            ccp => $cps[$i] - $cps[$i - 1],
        };

        push @pcds, $pcd;
    }

    $self->{_pcds} = \@pcds;

    return $self;
}

sub _retrieve_substring {
    my ($self, $offset, $length) = @_;

    if (! defined $length) {
        $length = -1;
    }

    my $pcds = $self->{_pcds};

    my $i = 0;
    while ($i < @$pcds) {
        last if $pcds->[$i]->{cp} > $offset;

        $i ++;
    }
    $i --;
    die 'could not find suitable heading piece'  if $i < 0;


    my ($utf16, $ascii);

    my $output = q{};

    while ($length > 0 || $length < 0) {
        my $pcd = $pcds->[$i];

        my $len = $length;
           $len = $pcd->{ccp}  if $pcd->{ccp} < $len || $len < 0;

        if ($pcd->{fc} & 0x40000000) {
            # cp1252
            $ascii ||= Encode::find_encoding('CP1252');

            my $fc = ($pcd->{fc} ^ 0x40000000) >> 1;

            $fc += $offset;
            $offset = 0;

            my $piece = substr $self->_main_stream, $fc, $len;

            $output .= $ascii->decode($piece);
        }
        else {
            # utf-16le
            $utf16 ||= Encode::find_encoding('UTF-16LE');

            my $fc = $pcd->{fc};

            $fc += $offset * 2;
            $offset = 0;

            my $piece = substr $self->_main_stream, $fc, $len * 2;

            $output .= $utf16->decode($piece);
        }

        $length -= $len  if $length >= 0;

        $i ++;
        last if $i >= @$pcds;
    }

    return $output;
}

sub _main_stream {
    my $self = shift;

    if (@_) {
        $self->{main_stream} = shift;
    }

    return $self->{main_stream};
}

sub _table_stream {
    my $self = shift;

    if (@_) {
        $self->{table_stream} = shift;
    }

    return $self->{table_stream};
}

sub _retrieve_entry {
    my ($oledoc, $label) = @_;

    my $utf16 = Encode::find_encoding('UTF-16LE');

    my $u_label = $utf16->encode($label);

    my ($pps) = $oledoc->getPpsSearch([ $u_label ], 1);

    return  if ! defined $pps;

    return $pps->{Data};
}

sub _get_short {
    my ($buffer, $offset) = @_;
    $offset ||= 0;

    return if ! defined $buffer;

    my $bin = substr $buffer, $offset, 2;
    return if length $bin < 2;

    my ($value) = unpack 'v', $bin;

    return $value;
}

sub _get_long {
    my ($buffer, $offset) = @_;
    $offset ||= 0;

    return if ! defined $buffer;

    my $bin = substr $buffer, $offset, 4;
    return if length $bin < 4;

    my ($value) = unpack 'V', $bin;

    return $value;
}

sub _format_into_plain {
    my $text = shift;

    my %unimap = (
        "\x0a" => "\n",         # ASIS: Line Feed
        "\x09" => "\t",         # ASIS: Tab

        "\x0d" => "\n",         # Paragraph ends; \n + U+2029?

        "\x0b" => "\n",         # Hard line breaks

        "\x2d" => "\x2d",       # ASIS: Breaking hyphens; U+2010?
        "\x1f" => "\x{00ad}",   # Non-required hyphens (into Soft hyphen)
        "\x1e" => "\x{2011}",   # Non-breaking hyphens

        "\xa0" => "\xa0",       # ASIS: Non-breaking-spaces

        "\x0c" => "\x0c",       # ASIS: Page breaks or Section marks

        "\x0e" => "\x0e",       # ASIS: Column breaks

        "\x13" => "",           # Field begin mark
        "\x15" => "",           # Field end mark
        "\x14" => "",           # Field separator

        "\x07" => "\t",         # Cell mark or Row mark
    );

    # pseudo row mark detection
    $text =~ s{ ( [\x07]* ) [\x07]{2} }{$1\n}gxmso;

    $text =~ s{([\x00-\x1f])}{ $unimap{$1} || '' }egxmso;

    return $text;
}

1;
__END__

=head1 NAME

MSWord::ExtractContent - Extract text contents from MSWord document

=head1 SYNOPSIS

    use MSWord::ExtractContent;
    use Encode;
    
    # load and parse MSWord file
    my $word = MSWord::ExtractContent->from_file('sample.doc');
    # output contents
    print encode('UTF-8', $word->contents);
    # can retrieve header
    my $header = $word->header( as_plaintext => 1);
    
    # non-OO style
    my $footnote = extract_contents_from_msword_file('sample.doc'));

=head1 DESCRIPTION

MSWord::ExtractContent is contents extractor for Microsoft Word document.

=head1 METHODS

=over 4

=item CLASS-E<gt>from_file($filename)

Parses specified MSWord document file and returns result object.

=item CLASS-E<gt>from_buffer($buffer)

Parses specified MSWord document data and returns result object.

=back

=head1 METHODS FOR RESULT OBJECT

With following four methods, you can retrieve text contents from result
object generated above methods.
They produce text strings in Unicode string form, that means resulting text
may be utf-8 flagged, so you can not output such text on console directly.
(Recommended to use Encode::encode() with suitable encoding for output.)

=over 4

=item $doc-E<gt>contents([ $options ]);

=item $doc-E<gt>header([ $options ]);

=item $doc-E<gt>footnote([ $options ]);

=item $doc-E<gt>whole_contents([ $options ]);

=back

=head1 OPTIONS FOR CONTENTS RETRIEVAL

=over 4

=item as_plaintext

If this option is specified, contents retrieval methods described above
filter some of special characters (such as cell mark) from resulting contents.

=back

=head1 FUNCTIONAL INTERFACE

=over 4

=item extract_contents_from_msword_file($filename, [ $options ]);

=item extract_header_from_msword_file($filename, [ $options ]);

=item extract_footnote_from_msword_file($filename, [ $options ]);

=item extract_whole_contents_from_msword_file($filename, [ $options ]);

=back

Functionalities of following methods are same as above, but they parse
document data buffers instead of parsing files.

=over 4

=item extract_contents_from_msword_data($buffer, [ $options ]);

=item extract_header_from_msword_data($buffer, [ $options ]);

=item extract_footnote_from_msword_data($buffer, [ $options ]);

=item extract_whole_contents_from_msword_data($buffer, [ $options ]);

=back

=head1 LIMITATIONS

Only support Microsoft Word binary document.
Does not support Microsoft Word XML document (.docx).

This module does not handle PAP (PAragraph Properties) and CHP (CHaracter
Properties), that define paragraphs and characters style.
Those styling information are required to determine functionalities of
some of special characters (such as row mark, footnote reference, and etc).

This module does not handle summary information stream in Word file.

=head1 AUTHOR

ITO Nobuaki E<lt>banb@cpan.orgE<gt>

=head1 LICENSE

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=head1 SEE ALSO

=cut