# Philippe Verdret 1998-1999
use strict;

package RTF::HTML::Converter;
$RTF::HTML::Converter::VERSION = '1.11';
use RTF::Control;
use RTF::HTML::Converter::ansi;
use RTF::HTML::Converter::charmap;

@RTF::HTML::Converter::ISA = qw(RTF::Control);

use constant TRACE                    => 0;
use constant LIST_TRACE               => 0;
use constant SHOW_STYLE_NOT_PROCESSED => 1;
use constant SHOW_STYLE               => 0;    # insert style name in the output
use constant SHOW_RTF_LINE_NUMBER     => 0;

use constant RTF_DEBUG => 0;

=head1 NAME

RTF::HTML::Converter - Perl extension for converting RTF into HTML

=head1 VERSION

version 1.11

=head1 DESCRIPTION

Perl extension for converting RTF into HTML

=head1 SYNOPSIS

	use strict;
	use RTF::HTML::Converter;

	my $object = RTF::HTML::Converter->new(

		output => \*STDOUT

	);

	$object->parse_stream( \*RTF_FILE );

OR

	use strict;
	use RTF::HTML::Converter;

	my $object = RTF::HTML::Converter->new(

		output => \$string

	);

	$object->parse_string( $rtf_data );

=head1 METHODS

=head2 new()

Constructor method. Currently takes one named parameter, C<output>,
which can either be a reference to a filehandle, or a reference to
a string. This is where our HTML will end up.

=head2 parse_stream()

Read RTF in from a filehandle, and start processing it. Pass me
a reference to a filehandle.

=head2 parse_string()

Read RTF in from a string, and start processing it. Pass me a string.

=head1 JUST SO YOU KNOW

You can mix-and-match your output and input methods - nothing to stop
you outputting to a string when you've read from a filehandle...

=head1 AUTHOR

Peter Sergeant C<pete@clueball.com>, originally by Philippe Verdret

=head1 COPYRIGHT

Copyright 2004 B<Pete Sergeant>.

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

=head1 CREDITS

This work was carried out under a grant generously provided by The Perl Foundation -
give them money!


=cut

# Symbol exported by the RTF::Ouptut module:
# %info: informations of the {\info ...}
# %par_props: paragraph properties
# $style: name of the current style or pseudo-style
# $event: start and end on the 'document' event
# $text: text associated to the current style
# %symbol: symbol translations
# %do_on_control: routines associated to RTF controls
# %do_on_event: routines associated to events
# output(): a stack oriented output routine (don't use print())

my $START_NEW_PARA = 1;    # some actions to do at the beginning of a new para

###########################################################################
my $N            = "\n";   # Pretty-printing
                           # some output parameters
my $TITLE_FLAG   = 0;
my $LANG         = 'en';
my $TABLE_BORDER = 1;

my $CURRENT_LI = 0;        # current list indent
my @LIST_STACK = ();       # stack of opened lists
my %LI_LEVEL   = ();       # li -> list level

my %charmap_defaults = map( { sprintf( "%02x", $_ ) => "&#$_;" } ( 0 .. 255 ) );

my %PAR_ALIGN = qw(
    qc CENTER
    ql LEFT
    qr RIGHT
    qj LEFT
);
# here put your style mappings
my %STYLES = (
    'Normal'   => 'p',
    'Abstract' => 'Blockquote',
    'PACSCode' => 'Code',
    #'AuthGrp' => '',
    'Section'   => 'H1',
    'heading 1' => 'H1',
    'heading 2' => 'H2',
    'heading 3' => 'H3',
    'heading 4' => 'H4',
    'heading 5' => 'H5',
    'heading 6' => 'H6',
    'Code'      => 'pre',
    'par'       => 'p',     # default value
);
# list names -> level
my %UL_STYLES = (
    'toc 1' => 1,
    'toc 2' => 2,
    'toc 3' => 3,
    'toc 4' => 4,
    'toc 5' => 5, );

# not used
my %UL_TYPES = qw(b7 disk
    X square
    Y circle
);

my %OL_STYLES = ();
# not used
my %OL_TYPES = (
    'pncard'  => '1',    # Cardinal numbering: One, Two, Three
    'pndec'   => '1',    # Decimal numbering: 1, 2, 3
    'pnucltr' => 'A',    # Uppercase alphabetic numbering
    'pnlcltr' => 'a',    # lowercase alphabetic numbering
    'pnucrm'  => 'I',    # Uppercase roman numbering
    'pnlcrm'  => 'i',    # Lowercase roman numbering
);
my $in_Field    = -1;    # nested links are illegal, not used
my $in_Bookmark = -1;    # nested links are illegal, not used
%do_on_event = (
    'document' => sub {    # Special action
        if ( $event eq 'start' ) {
            output
                qq@<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" []>$N<html>$N<body>$N@;
        } else {
            my $author  = $info{author};
            my $creatim = $info{creatim};
            my $revtim  = $info{revtim};

            my $tag;
            while (@LIST_STACK) {
                $tag = pop @LIST_STACK;
                output "</$tag>" . $N;
            }
            $style = 'p';

            if ( $LANG eq 'fr' ) {
                output "<$style><b>Auteur</b> : $author</$style>\n" if $author;
                output "<$style><b>Date de cr&eacute;ation</b> : $creatim</$style>\n"
                    if $creatim;
                output
                    "<$style><b>Date de modification</b> : $revtim</$style>\n"
                    if $revtim;
            } else {    # Default
                output "<$style><b>Author</b> : $author</$style>\n" if $author;
                output "<$style><b>Creation date</b>: $creatim</$style>\n"
                    if $creatim;
                output "<$style><b>Modification date</b>: $revtim</$style>\n"
                    if $revtim;
            }
            output "</body>\n</html>\n";
        }
    },
    # Table processing
    'table' => sub {    # end of table
        if ( $event eq 'end' ) {
            #print STDERR "end of table\n";
            $TABLE_BORDER ? output "<table BORDER>$N$text</table>$N" :
                output "<table>$N$text</table>$N";
        } else {
            #print STDERR "start of table\n";
            my $end;
            while (@LIST_STACK) {
                $end .= '</' . pop(@LIST_STACK) . '>' . $N;
            }
            output($end);
        }
    },
    'row' => sub {    # end of row
                      #my $char_props = $_[SELF]->force_char_props('end');
                      #output "$N<tr valign='top'>$text$char_props</tr>$N";
        if ( $event eq 'end' ) {
            output "$N<tr valign='top'>$N$text$N</tr>$N";
        } else {
            # not defined
        }
    },
    'cell' => sub {    # end of cell
        if ( $event eq 'end' ) {
            my $char_props = $_[SELF]->force_char_props('end');
            my $end;
            while (@LIST_STACK) {
                $end .= '</' . pop(@LIST_STACK) . '>' . $N;
            }
            output "<td>$text$char_props$end</td>$N";
        } else {
            # not defined
        }
    },
    # PARAGRAPH STYLES
    #'Normal' => sub {},		# create one entry per style name???
    'par' => sub {    # Default rule: if no entry for a paragraph style
                      # Paragraph styles
                      #print STDERR "$style\n" if LIST_TRACE;
        return output($text) unless $text =~ /\S/;
        my ( $tag_start, $tag_end, $before ) = ( '', '', '' );

        if ( defined( my $level = $UL_STYLES{$style} ) )
        {             # registered list styles
            if ( $level > @LIST_STACK ) {
                my $tag;
                push @LIST_STACK, $tag = 'UL';
                if (SHOW_STYLE) {
                    $before = "<$tag>[$style]" . $N;
                } else {
                    $before = "<$tag>" . $N;
                }
                $tag_start = $tag_end = 'LI';
            } else {
                $level = @LIST_STACK - $level;
                while ( $level-- > 0 ) {
                    $before .= '</' . pop(@LIST_STACK) . '>' . $N;
                }
                $tag_start = $tag_end = 'LI';
            }
        } else {
        }

        if ( $tag_start eq '' ) {    # end of list
            while (@LIST_STACK) {
                $before .= '</' . pop(@LIST_STACK) . '>' . $N;
            }
            $tag_start = $tag_end = $STYLES{$style} || do {
                if (SHOW_STYLE_NOT_PROCESSED) {
                    use vars qw/%style_not_processed/;
                    # todo: add count
                    unless ( exists $style_not_processed{$style} ) {
                        print STDERR "style not defined '$style'\n"
                            if SHOW_STYLE_NOT_PROCESSED;
                        $style_not_processed{$style} = '';
                    }
                }
                $STYLES{'par'};
            };
            foreach (qw(qj qc ql qr)) {    # for some html elements...
                if ( $par_props{$_} ) {
                    $tag_start .= " ALIGN=$PAR_ALIGN{$_}";
                }
            }
        }

        $_[SELF]->trace("$tag_start-$tag_end: $text") if TRACE;
        my $char_props = $_[SELF]->force_char_props('end');
        if (SHOW_RTF_LINE_NUMBER) {
            output "$N$before<$tag_start>[$.]$text$char_props</$tag_end>$N";
        } else {
            output "$N$before<$tag_start>$text$char_props</$tag_end>$N";
        }
        $START_NEW_PARA = 1;
    },
    # Hypertextuel links
    #   'bookmark' => sub {
    #     $_[SELF]->trace("bookmark $event $text") if TRACE;
    #     if ($event eq 'end') {
    #       return if $in_Bookmark--;
    #       output("</a>");
    #     } else {
    #       return if ++$in_Bookmark;
    #       output("<a name='$text'>");
    #     }
    #   },
    #   'field' => sub {
    #     my $id = $_[0];
    #     $_[SELF]->trace("field $event $text") if TRACE;
    #     if ($event eq 'end') {
    #       return if $in_Field--;
    #       output("$text</a>");
    #     } else {
    #       return if ++$in_Field;
    #       output("<a href='#$id'>"); # doesn't work!
    #     }
    #   },
    # CHAR properties
    'b' => sub {
        $style = 'b';
        if ( $event eq 'end' ) {
            output "</$style>";
        } else {
            output "<$style>";
        }
    },
    'i' => sub {
        $style = 'i';
        if ( $event eq 'end' ) {
            output "</$style>";
        } else {
            output "<$style>";
        }
    },
    'ul' => sub {
        $style = 'u';
        if ( $event eq 'end' ) {
            output "</$style>";
        } else {
            output "<$style>";
        }
    },
    'sub' => sub {
        $style = 'sub';
        if ( $event eq 'end' ) {
            output "</$style>";
        } else {
            output "<$style>";
        }
    },
    'super' => sub {
        $style = 'sup';
        if ( $event eq 'end' ) {
            output "</$style>";
        } else {
            output "<$style>";
        }
    },
    'strike' => sub {
        $style = 'strike';
        if ( $event eq 'end' ) {
            output "</$style>";
        } else {
            output "<$style>";
        }
    }, );

###############################################################################
# Could be used in a next release
# manage a minimal context for the tag generation
# gen_tags(EVENT, TAG_NAME, [ATTLIST])
#          EVENT: open|close
# return: a tag start|end
my %cant_nest = map { $_ => 1 } qw(a);
use constant GEN_TAGS_WARNS => 1;
my @element_stack = ();
my %open_element  = ();

sub gen_tags {    # manage a minimal context for tag outputs

    debug( 'gen_tags', @_ ) if RTF_DEBUG > 5;

    die "bad argument number" unless ( @_ >= 2 );
    my ( $eve, $tag, $att ) = @_;

    my $result = '';
    if ( $eve eq 'open' ) {
        push @element_stack, $tag;    # add a new node
        if ( $open_element{$tag}++ and defined $cant_nest{$tag} ) {
            #print STDERR "skip open $tag\n";
            $result = '';
        } else {
            $result = '<' . $tag . '>' . $N;
        }
    } else {                          # close
        unless (@element_stack) {
            warn "no element to close on the '$tag' tag\n" if GEN_TAGS_WARNS;
            return $result;
        }
        my $opened_elt;
        while (1) {
            $opened_elt = pop @element_stack;
            if ( --$open_element{$tag} >= 1 and defined $cant_nest{$tag} ) {
                #print STDERR "skip close $opened_elt\n";
            } else {
                $result .= '</' . $opened_elt . '>' . $N;
            }
            last if $tag eq $opened_elt;
            unless (@element_stack) {
                warn "element stack is empty on $tag close\n" if GEN_TAGS_WARNS;
                return $result;
            }
        }
    }
    $result;
}
###############################################################################
# If you have an &<entity>; in your RTF document and if
# <entity> is a character entity, you'll see "&<entity>;" in the RTF document
# and the corresponding glyphe in the HTML document
# How to give a new definition to a control registered in %do_on_control:
# - method redefinition (could be the purist's solution)
# - $Control::do_on_control{control_word} = sub {};
# - when %do_on_control is exported write:
$do_on_control{'ansi'} =    # callback redefinition
    sub {
    # RTF: \'<hex value>
    # HTML: &#<dec value>;

    my @charmap_data = $_[SELF]->charmap_reader( $_[CONTROL] );

    my %charset = (    # general rule
        %charmap_defaults,
        # and some specific defs
        map( {  s/^\s+//;
                    split /\s+/
        } @charmap_data ) );
    *char = sub {
        my $char_props;
        if ($START_NEW_PARA) {
            $char_props     = $_[SELF]->force_char_props('start');
            $START_NEW_PARA = 0;
        } else {
            $char_props = $_[SELF]->process_char_props();
        }
        output $char_props . $charset{ $_[1] };
        }
    };

# symbol processing
# RTF: \~
# named chars
# RTF: \ldblquote, \rdblquote
$symbol{'~'}   = '&nbsp;';
$symbol{'tab'} = ' ';       #'&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;';
$symbol{'ldblquote'} = '&laquo;';
$symbol{'rdblquote'} = '&raquo;';
$symbol{'line'}      = '<br>';

sub symbol {

    debug( 'symbol', @_ ) if RTF_DEBUG > 5;

    my $char_props;
    if ($START_NEW_PARA) {
        $char_props     = $_[SELF]->force_char_props('start');
        $START_NEW_PARA = 0;
    } else {
        $char_props = $_[SELF]->process_char_props();
    }
    if ( defined( my $sym = $symbol{ $_[1] } ) ) {
        output $char_props . $sym;
    } else {
        output $char_props . $_[1];    # as it
    }
}
# Text
# certainly do the same thing with the char() method
sub text {    # parser callback redefinition

    debug( 'text', @_ ) if RTF_DEBUG > 5;

    my $text       = $_[1];
    my $char_props = '';
    if ($START_NEW_PARA) {
        $char_props     = $_[SELF]->force_char_props('start');
        $START_NEW_PARA = 0;
    } else {
        $char_props = $_[SELF]->process_char_props();
    }
    $text =~ s/&/&amp;/g;
    $text =~ s/</&lt;/g;
    $text =~ s/>/&gt;/g;
    if ( defined $char_props ) {
        output("$char_props$text");
    } else {
        output("$text");
    }
}

sub debug {

    my $function = shift;

    print STDERR "[RTF::HTML::Converter::$function]" . ( join '|', @_ ), "\n";

}

1;
__END__
