File Coverage

blib/lib/Pod/WordML.pm

Criterion	Covered	Total	%
statement	192	252	76.1
branch	24	42	57.1
condition	3	15	20.0
subroutine	72	109	66.0
pod	11	94	11.7
total	302	512	58.9

package Pod::WordML;
use strict;
use base 'Pod::PseudoPod';

use warnings;
no warnings;

use subs qw();
use vars qw($VERSION);

use Carp;

$VERSION = '0.16';

=encoding utf8

=head1 NAME

Pod::WordML - Turn Pod into Microsoft Word's WordML

=head1 SYNOPSIS

	use Pod::WordML;

=head1 DESCRIPTION

***THIS IS ALPHA SOFTWARE. MAJOR PARTS WILL CHANGE***

I wrote just enough of this module to get my job done, and I skipped every
part of the specification I didn't need while still making it flexible enough
to handle stuff later.

=head2 The style information

I don't handle all of the complexities of styles, defining styles, and
all that other stuff. There are methods to return style names, and you
can override those in a subclass.

=cut

=over 4

=item document_header

This is the start of the document that defines all of the styles. You'll need
to override this. You can take this directly from

=cut

sub document_header
	{
	my $string = <<'XML';




XML

	$string .= $_[0]->fonts . $_[0]->lists . $_[0]->styles;

	$string .= <<'XML';

XML
	}


sub fonts  { '' }
sub lists  { '' }
sub styles { '' }

=item document_footer

=cut

sub document_footer
	{
	<<'XML';


XML
	}

=item head1_style, head2_style, head3_style, head4_style

The paragraph styles to use with each heading level. By default these are
C, and so on.

=cut

sub head0_style         { 'Heading0' }
sub head1_style         { 'Heading1' }
sub head2_style         { 'Heading2' }
sub head3_style         { 'Heading3' }
sub head4_style         { 'Heading4' }

=item normal_paragraph_style

The paragraph style for normal Pod paragraphs. You don't have to use this
for all normal paragraphs, but you'll have to override and extend more things
to get everything just how you like. You'll need to override C to
get more variety.

=cut

sub normal_para_style   { 'NormalParagraphStyle' }

=item bullet_paragraph_style

Like C, but for paragraphs sections under C<=item>
sections.

=cut

sub first_item_para_style     { 'FirstItemParagraphStyle'  }
sub middle_item_para_style    { 'MiddleItemParagraphStyle' }
sub last_item_para_style      { 'LastItemParagraphStyle'   }
sub item_subpara_style        { 'ItemSubParagraphStyle'    }

=item code_paragraph_style

Like C, but for verbatim sections. To get more fancy
handling, you'll need to override C and C.

=cut

sub code_para_style        { 'CodeParagraphStyle'   }
sub single_code_line_style { 'CodeParagraphStyle'   }

=item inline_code_style

The character style that goes with C<< CE> >>.

=cut

sub inline_code_style	{ 'CodeCharacterStyle' }

=item inline_url_style

The character style that goes with C<< UEE >>.

=cut

sub inline_url_style    { 'URLCharacterStyle'  }

=item inline_italic_style

The character style that goes with C<< IE> >>.

=cut

sub inline_italic_style { 'ItalicCharacterStyle' }

=item inline_bold_style

The character style that goes with C<< BE> >>.

=cut

sub inline_bold_style   { 'BoldCharacterStyle' }

=back

=head2 The Pod::Simple mechanics

Everything else is the same stuff from C.

=cut
use Data::Dumper;
sub new { my $self = $_[0]->SUPER::new() }

sub emit
	{
	print {$_[0]->{'output_fh'}} $_[0]->{'scratch'};
	$_[0]->{'scratch'} = '';
	return;
	}

sub get_pad
	{
	# flow elements first
	   if( $_[0]{module_flag}   ) { 'scratch'   }
	elsif( $_[0]{url_flag}      ) { 'url_text'      }
	# then block elements
	# finally the default
	else                          { 'scratch'       }
	}

sub start_Document
	{
	$_[0]->{'scratch'} .= $_[0]->document_header; $_[0]->emit;
	}

sub end_Document
	{
	$_[0]->{'scratch'} .= $_[0]->document_footer; $_[0]->emit;
	}

=begin comment






        This is an h1



=cut

sub _header_start
	{
	my( $self, $style, $level ) = @_;

	my $format = '




      ';

	$self->{scratch} = sprintf $format, $style;
	$self->emit;
	}

sub _header_end
	{
	'


';
	}

sub start_head0     { $_[0]->_header_start( $_[0]->head0_style, 0 ); }
sub end_head0       { $_[0]{'scratch'}  .= $_[0]->_header_end; $_[0]->end_non_code_text }

sub start_head1     { $_[0]->_header_start( $_[0]->head1_style, 1 ); }
sub end_head1       { $_[0]{'scratch'}  .= $_[0]->_header_end; $_[0]->end_non_code_text }

sub start_head2     { $_[0]->_header_start( $_[0]->head2_style, 2 );  }
sub end_head2       { $_[0]{'scratch'} .= $_[0]->_header_end; $_[0]->end_non_code_text }

sub start_head3     { $_[0]->_header_start( $_[0]->head3_style, 3 );  }
sub end_head3       { $_[0]{'scratch'} .= $_[0]->_header_end; $_[0]->end_non_code_text }

sub start_head4     { $_[0]->_header_start( $_[0]->head4_style, 4 );  }
sub end_head4       { $_[0]{'scratch'} .= $_[0]->_header_end; $_[0]->end_non_code_text }

sub end_non_code_text
	{
	my $self = shift;

	$self->make_curly_quotes;

	$self->emit;
	}

=begin comment




      This is a line in a paragraph





      This is another line in another paragraph








=end comment

=cut

sub make_para
	{
	my( $self, $style, $para ) = @_;

	$self->{'scratch'}  =
qq|




      $para


|;

	$self->emit;
	}

sub start_Para
	{
	my $self = shift;

	# it would be nice to take this through make_para
	my $style = do {
		if( $self->{in_item} )
			{
			if( $self->{item_count} == 1 ) { $self->first_item_para_style }
			else                           { $self->middle_item_para_style }
			}
		elsif( $self->{in_item_list} ) { $self->item_subpara_style }
		else                           { $self->normal_para_style  }
		};

	$self->{'scratch'}  =
qq|




      |;

	$self->{'scratch'} .= "\x{25FE} " if $self->{in_item};

	$self->emit;

	$self->{'in_para'} = 1;
	}


sub end_Para
	{
	my $self = shift;

	$self->{'scratch'} .= '


';

	$self->emit;

	$self->end_non_code_text;

	$self->{'in_para'} = 0;
	}

sub start_figure 	{ }

sub end_figure      { }

sub first_code_line_style  { 'first code line'   }
sub middle_code_line_style { 'middle code line'  }
sub last_code_line_style   { 'last code line'    }

sub first_code_line  { $_[0]->make_para( $_[0]->first_code_line_style,  $_[1] ) }
sub middle_code_line { $_[0]->make_para( $_[0]->middle_code_line_style, $_[1] ) }
sub last_code_line   { $_[0]->make_para( $_[0]->last_code_line_style,   $_[1] ) }

sub start_Verbatim
	{
	$_[0]{'in_verbatim'} = 1;
	}

sub end_Verbatim
	{
	my $self = shift;

	# get rid of all but one trailing newline
	$self->{'scratch'} =~ s/\s+\z//;

	chomp( my @lines = split m/^/m, $self->{'scratch'} );
	$self->{'scratch'} = '';

	@lines = map { s/

	if( @lines == 1 )
		{
		$self->make_para( $self->single_code_line_style, @lines );
		}
	elsif( @lines )
		{
		my $first = shift @lines;
		my $last  = pop   @lines;

		$self->first_code_line( $first );

		foreach my $line ( @lines )
			{
			$self->middle_code_line( $line );
			}

		$self->last_code_line( $last );
		}

	$self->{'in_verbatim'} = 0;
	}

sub _get_initial_item_type
	{
	my $self = shift;

	my $type = $self->SUPER::_get_initial_item_type;

	#print STDERR "My item type is [$type]\n";

	$type;
	}

=pod










      List item 1



=cut

sub not_implemented { croak "Not implemented!" }

sub bullet_item_style { 'bullet item' }
sub start_item_bullet
	{
	my( $self ) = @_;

	$self->{in_item} = 1;
	$self->{item_count}++;

	$self->start_Para;
	}

sub start_item_number { not_implemented() }
sub start_item_block  { not_implemented() }
sub start_item_text   { not_implemented() }

sub end_item_bullet
	{
	my $self = shift;
	$self->end_Para;
	$self->{in_item} = 0;
	}
sub end_item_number { not_implemented() }
sub end_item_block  { not_implemented() }
sub end_item_text   { not_implemented() }

sub start_over_bullet
	{
	my $self = shift;

	$self->{in_item_list} = 1;
	$self->{item_count}   = 0;
	}
sub start_over_text   { not_implemented() }
sub start_over_block  { not_implemented() }
sub start_over_number { not_implemented() }

sub end_over_bullet
	{
	my $self = shift;

	$self->end_non_code_text;

	$self->{in_item_list} = 0;
	$self->{item_count}   = 0;
	$self->{last_thingy}  = 'item_list';
	$self->{scratch}      = '';
	}
sub end_over_text   { not_implemented() }
sub end_over_block  { not_implemented() }
sub end_over_number { not_implemented() }

sub start_char_style
	{
	my( $self, $style ) = @_;

	$self->{'scratch'} .= qq|





      |;

	$self->emit;
	}

sub end_char_style
	{
	$_[0]->{'scratch'} .= '


      ';

	$_[0]->emit;
	}


sub bold_char_style { 'Bold' }
sub end_B    { $_[0]->end_char_style }
sub start_B
	{
	$_[0]->start_char_style( $_[0]->bold_char_style );
	}

sub inline_code_char_style { 'Code' }
sub start_C
	{
	$_[0]->{in_C} = 1;
	$_[0]->start_char_style( $_[0]->inline_code_char_style );
	}
sub end_C
	{
	$_[0]->end_char_style;
	$_[0]->{in_C} = 0;
	}

sub italic_char_style { 'Italic' }
sub end_I   { $_[0]->end_char_style }
sub start_I { $_[0]->start_char_style( $_[0]->italic_char_style ); }

sub start_F { $_[0]->end_char_style }
sub end_F   { $_[0]->start_char_style( $_[0]->italic_char_style ); }

sub start_M
	{
	$_[0]{'module_flag'} = 1;
	$_[0]{'module_text'} = '';
	$_[0]->start_C;
	}

sub end_M
	{
	$_[0]->end_C;
	$_[0]{'module_flag'} = 0;
	}

sub start_N { }
sub end_N   { }

sub start_U { $_[0]->start_I }
sub end_U   { $_[0]->end_I   }

sub handle_text
	{
	my( $self, $text ) = @_;

	my $pad = $self->get_pad;

	$self->escape_text( \$text );
	$self->{$pad} .= $text;

	unless( $self->dont_escape )
		{
		$self->make_curly_quotes;
		$self->make_em_dashes;
		$self->make_ellipses;
		}
	}

sub dont_escape {
	my $self = shift;
	$self->{in_verbatim} || $self->{in_C}
	}

sub escape_text
	{
	my( $self, $text_ref ) = @_;

	$$text_ref =~ s/&/&/g;
	$$text_ref =~ s/

	return 1;
	}

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

	my $text = $self->{scratch};

	require Tie::Cycle;

	tie my $cycle, 'Tie::Cycle', [ qw( “ ” ) ];

	1 while $text =~ s/"/$cycle/;

	# escape escape chars. This is escpaing them for InDesign
	# so don't worry about double escaping for other levels. Don't
	# worry about InDesign in the pod.
	$text =~ s/'/’/g;

	$self->{'scratch'} = $text;

	return 1;
	}

sub make_em_dashes
	{
	$_[0]->{scratch} =~ s/--/—/g;
	return 1;
	}

sub make_ellipses
	{
	$_[0]->{scratch} =~ s/\Q.../…/g;
	return 1;
	}

BEGIN {
require Pod::Simple::BlackBox;

package Pod::Simple::BlackBox;

sub _ponder_Verbatim {
	my ($self,$para) = @_;
	DEBUG and print STDERR " giving verbatim treatment...\n";

	$para->[1]{'xml:space'} = 'preserve';
	foreach my $line ( @$para[ 2 .. $#$para ] )
		{
		$line =~ s/^\t//gm;
		$line =~ s/^(\t+)/" " x ( 4 * length($1) )/e
  		}

  # Now the VerbatimFormatted hoodoo...
  if( $self->{'accept_codes'} and
      $self->{'accept_codes'}{'VerbatimFormatted'}
  ) {
    while(@$para > 3 and $para->[-1] !~ m/\S/) { pop @$para }
     # Kill any number of terminal newlines
    $self->_verbatim_format($para);
  } elsif ($self->{'codes_in_verbatim'}) {
    push @$para,
    @{$self->_make_treelet(
      join("\n", splice(@$para, 2)),
      $para->[1]{'start_line'}, $para->[1]{'xml:space'}
    )};
    $para->[-1] =~ s/\n+$//s; # Kill any number of terminal newlines
  } else {
    push @$para, join "\n", splice(@$para, 2) if @$para > 3;
    $para->[-1] =~ s/\n+$//s; # Kill any number of terminal newlines
  }
  return;
}

}

BEGIN {

# override _treat_Es so I can localize e2char
sub _treat_Es
	{
	my $self = shift;

	require Pod::Escapes;
	local *Pod::Escapes::e2char = *e2char_tagged_text;

	$self->SUPER::_treat_Es( @_ );
	}

sub e2char_tagged_text
	{
	package Pod::Escapes;

	my $in = shift;

	return unless defined $in and length $in;

	   if( $in =~ m/^(0[0-7]*)$/ )         { $in = oct $in; }
	elsif( $in =~ m/^0?x([0-9a-fA-F]+)$/ ) { $in = hex $1;  }

	if( $NOT_ASCII )
	  	{
		unless( $in =~ m/^\d+$/ )
			{
			$in = $Name2character{$in};
			return unless defined $in;
			$in = ord $in;
	    	}

		return $Code2USASCII{$in}
			|| $Latin1Code_to_fallback{$in}
			|| $FAR_CHAR;
		}

 	if( defined $Name2character_number{$in} and $Name2character_number{$in} < 127 )
 		{
 		return "&$in;";
 		}
	elsif( defined $Name2character_number{$in} )
		{
		# this needs to be fixed width because I want to look for
		# it in a negative lookbehind
		return sprintf '&#x%04x;', $Name2character_number{$in};
		}
	else
		{
		return '???';
		}

	}
}

=head1 TO DO


=head1 SEE ALSO

L, L

=head1 SOURCE AVAILABILITY

This source is in Github:

	http://github.com/briandfoy/Pod-WordML

If, for some reason, I disappear from the world, one of the other
members of the project can shepherd this module appropriately.

=head1 AUTHOR

brian d foy, C<<  >>

=head1 COPYRIGHT AND LICENSE

Copyright (c) 2009-2014, brian d foy, All Rights Reserved.

You may redistribute this under the same terms as Perl itself.

=cut

1;