use strict;
use Text::Wrap;
use Win32::OLE qw(in with);
use Win32::OLE::Const 'Microsoft Word';

die "Usage: perl word2pod.pl Documentation.doc" unless @ARGV == 1;
my $File = $ARGV[0];
$File = Win32::GetCwd() . "/$File" if $File !~ /^(\w:)?[\/\\]/;
die "File $ARGV[0] does not exist" unless -f $File;

my $Word = Win32::OLE->new('Word.Application', 'Quit')
  or die "Couldn't run Word";

my $Doc = $Word->Documents->Open($File);

# Cache the names of various styles
my %Style = (
   Heading1     => $Doc->Styles(wdStyleHeading1)->NameLocal,
   Heading2     => $Doc->Styles(wdStyleHeading2)->NameLocal,
   List         => $Doc->Styles(wdStyleList)->NameLocal,
   ListBullet   => $Doc->Styles(wdStyleListBullet)->NameLocal,
   ListContinue => $Doc->Styles(wdStyleListContinue)->NameLocal,
   ListNumber   => $Doc->Styles(wdStyleListNumber)->NameLocal,
   Normal       => $Doc->Styles(wdStyleNormal)->NameLocal,
   PlainText    => $Doc->Styles(wdStylePlainText)->NameLocal,
  );

# The following styles will not break list mode
my %ListStyle = map {$_ => 1} @Style{qw(List ListBullet ListContinue
					ListNumber PlainText)};

# We don't want to encode Bold/Italic/Code in headings or plaintext
foreach my $Style (wdStyleHeading1, wdStyleHeading2, wdStylePlainText) {
    with($Doc->Styles($Style)->Font,
	 Bold   => 0,
	 Italic => 0,
	 Name   => 'Times New Roman',
	);
}

# Translating the format on a char by char basis is just too slow through OLE.
# We use Words Search-and-Replace feature instead.
my $Search = $Doc->Content->Find;
my $Replace = $Search->Replacement;

$Search->Font->{Bold} = 1;
$Replace->{Text} = 'B<^&>';
$Search->Execute({Replace => wdReplaceAll});

$Search->Clearformatting;
$Search->Font->{Italic} = 1;
$Replace->{Text} = 'I<^&>';
$Search->Execute({Replace => wdReplaceAll});

$Search->Clearformatting;
$Replace->{Text} = 'C<^&>';
foreach my $FontName ('Courier', 'Courier New') {
    $Search->Font->{Name} = $FontName;
    $Search->Execute({Replace => wdReplaceAll});
}

my $EmptyLine = 1;
my $ListItem;

foreach my $Paragraph (in $Doc->Paragraphs) {
    my $Style = $Paragraph->Format->Style->NameLocal;
    # Remove trailing ^M (the paragraph marker) from Range
    my $Text = substr($Paragraph->Range->Text, 0, -1);

    if ($Style eq $Style{PlainText}) {
	$EmptyLine = scalar $Text =~ /^\s*$/;
	# Make sure plaintext starts with whitespace
	$Text = "\t$Text" unless $EmptyLine || $Text =~ /^\s/;
	print "$Text\n";
	next;
    }

    # Make sure previous plaintext block has a trailing empty line
    print "\n" unless $EmptyLine;
    $EmptyLine = 1;

    if (defined $ListItem && !$ListStyle{$Style}) {
	print "=back\n\n";
	undef $ListItem;
    }

    if ($Style eq $Style{Heading1}) {
	print "=head1 $Text\n\n";
    }
    elsif ($Style eq $Style{Heading2}) {
	print "=head2 $Text\n\n";
    }
    elsif ($ListStyle{$Style} && $Style ne $Style{ListContinue}) {
	unless (defined $ListItem) {
	    print "=over 4\n\n";
	    $ListItem = 0;
	}

	my $Bullet = '';
	$Bullet = '* ' if $Style eq $Style{ListBullet};
	$Bullet = sprintf "%d. ", ++$ListItem if $Style eq $Style{ListNumber};
	print "=item $Bullet$Text\n\n";
    }
    else {
	printf "%s\n\n", wrap('', '', $Text);
    }
}

$Doc->{Saved} = 1;
$Doc->Close;