package Lire::ReportParser::HTMLDocBookFormatter;

use strict;

use base qw/ Exporter Lire::DocBookParser /;

use Text::Wrap qw/ wrap /;

use Lire::Utils qw/deep_copy/;
use Lire::I18N qw/ensure_utf8/;

our @EXPORT_OK = qw/ dbk2html /;
our %dbk2html = ( 'quote' => 'q',
                  'abbrev' => 'abbr',
                  'acronym' => 'acronym',
                  'computeroutput' => 'samp',
                  'prompt' => 'samp',
                  'emphasis' => 'em',
                  'userinput' => 'kbd',
                  'subscript' => 'sub',
                  'superscript' => 'sup' );

our @dbk_vartags = qw/ varname envar constant structfield structname function
                       option optional parameter classname symbol property
                       type errorname /;
=pod

=head1 NAME

Lire::ReportParser::HTMLDocBookFormatter - Lire::ReportParser subclass
which formats description.

=head1 SYNOPSIS

To format DocBook:

    use Lire::ReportParser::HTMLDocBookFormatter qw/dbk2html/;

    my $txt = dbk2html( "<para>Test</para>" );

In XML Report processors :

    package MyParser;

    use base qw/ Lire::ReportParser::HTMLDocBookFormatter Lire::ReportParser /;

    sub new {
        my $self = shift->SUPER::new( @_ );

        $self->init_docbook_formatter( @_ );

        return $self;
    }

    sub handle_description {
        my ( $self, $desc ) = @_;

        print $desc;

        return;
    }

=head1 DESCRIPTION

Lire::ReportParser::HTMLDocBookFormatter is the counterpart to
Lire::ReportParser::AsciiDocBookFormatter for the HTML output format. Please
read its documentation to learn how to use this class. Their use is exactly
the same.

=cut

sub new {
    my $self  = shift->SUPER::new( @_ );

    $self->init_docbook_formatter( @_ );

    return $self;
}

sub namespaces {
    my $self = $_[0];

    return { "http://www.logreport.org/LRML/" => 'lire' };
}


sub elements_spec {
    my $self = $_[0];

    my $spec = deep_copy( $self->Lire::DocBookParser::elements_spec() );
    foreach my $admon ( @Lire::DocBookParser::admonitions_mix ) {
        $spec->{$admon}{'start'} = 'admonition_start';
        $spec->{$admon}{'end'} = 'admonition_end';
    }
    foreach my $element ( keys %dbk2html ) {
        $spec->{$element}{'start'} = 'mapped_start';
        $spec->{$element}{'end'} = 'mapped_end';
    }
    foreach my $element ( @dbk_vartags ) {
        $spec->{$element}{'start'} = 'var_start';
        $spec->{$element}{'end'} = 'var_end';
    }

    my %except = map { $_ => 1 } ( keys %dbk2html, @dbk_vartags,
                                   'email', 'term', 'title', 'ulink' );
    foreach my $element ( @Lire::DocBookParser::inline_mix ) {
        next if $except{$element};
        $spec->{$element}{'start'} = 'span_start';
        $spec->{$element}{'end'} = 'span_end';
    }

    foreach my $element ( keys %$spec ) {
        next if $element eq 'ulink';
        $spec->{$element}{'char'} = 'inline_char'
          if exists $spec->{$element}{'char'};
    }

    $spec->{'email'}{'start'} = 'collector_start';
    $spec->{'email'}{'char'} = 'collector_char';
    $spec->{'term'}{'char'} = 'collector_char';

    $spec->{'lire:description'} = [ @Lire::DocBookParser::top_levels ];

    return $spec;
}

sub init_docbook_formatter {
    my ( $self, %args ) = @_;

    $self->{'dbk_columns'} = $args{'dbk_columns'} || 78;
    $self->{'dbk_tag_ender'} = ( $args{'xhtml'} ? ' /' : '' );

    return $self;
}

sub dbk_start_processing {
    my $self = $_[0];

    $self->{'dbk_process'}      = 1;
    $self->{'dbk_text'}         = "";
    $self->{'dbk_text_blocks'}  = [];
    $self->{'dbk_lists'}        = [];
    $self->{'dbk_left_margin'}  = 4;

    return;
}

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

    delete $self->{'dbk_process'};
    delete $self->{'dbk_text'};
    delete $self->{'dbk_text_blocks'};
    delete $self->{'dbk_lists'};

    return;
}

sub description_start {
    $_[0]->dbk_start_processing();

    return;
}

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

    return unless $self->{'dbk_process'};

    $self->handle_description( $self->{'dbk_text'} );
    $self->dbk_end_processing();

    return;
}

sub handle_description {
    $_[0]{'saved_dbk'} = $_[1];

    return;
}

sub parse_end {
    return $_[0]{'saved_dbk'};
}

sub parent_block {
    return undef unless @{$_[0]{'dbk_text_blocks'}} > 1;
    return $_[0]{'dbk_text_blocks'}[$#{$_[0]{'dbk_text_blocks'}} - 1];
}

sub current_block {
    return undef unless @{$_[0]{'dbk_text_blocks'}};
    return $_[0]{'dbk_text_blocks'}[$#{$_[0]{'dbk_text_blocks'}}];
}

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

    my $block = $self->current_block();
    return unless $block;
    return unless length $block->{'dbk_text'};

    my $margin = ' ' x $self->{'dbk_left_margin'};
    my $initial = $margin . $block->{'dbk_initial_indent'};
    my $next    = $margin . $block->{'dbk_indent'};

    # Squash space and trim the string.
    $block->{'dbk_text'} =~ tr/\n\t / /s;
    $block->{'dbk_text'} =~ s/^\s*//;
    $block->{'dbk_text'} =~ s/\s*$//;
    return if $block->{'dbk_text'} =~ /^\s*$/;

    local $Text::Wrap::columns = $self->{'dbk_columns'};
    $self->{'dbk_text'} .= wrap( $initial, $next, $block->{'dbk_text'} );
    $self->{'dbk_text'} .= "\n";

    # Flush text buffer
    $block->{'dbk_text'} = "";

    return;
}

sub inline_char {
    my ( $self, $str ) = @_;

    my $block = $self->current_block();
    $block->{'dbk_text'} .= $str if $block;

    return;
}

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

    $self->inline_char( "<span class=\"$class\">$text</span>" );
}

sub start_div {
    my ( $self, $class ) = @_;

    $self->start_block();
    $self->inline_char( "<div class=\"$class\">" );

    return;
}

sub end_div {
    my $self = $_[0];

    $self->inline_char( '</div>' );
    $self->end_block();

    return;
}

sub start_block {
    my ( $self, $left_margin_indent )= @_;

    $left_margin_indent ||= 0;

    # Flush the current block, if there is one
    $self->print_block();

    $self->{'dbk_left_margin'}  += $left_margin_indent;
    push @{$self->{'dbk_text_blocks'}},
      { 'dbk_text'            => "",
        'dbk_initial_indent'  => '',
        'dbk_indent'          => '',
        'dbk_left_margin_indent'  => $left_margin_indent,
        'dbk_children'        => 0,
      };

    my $parent = $self->parent_block();
    $parent->{'dbk_children'}++ if $parent;

    return $self->current_block();
}

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

    # Flush the current block, if there is one
    $self->print_block();

    my $block = $self->current_block();
    $self->{'dbk_left_margin'}  -= $block->{'dbk_left_margin_indent'};

    pop @{$self->{'dbk_text_blocks'}};

    return;
}

sub current_list {
    return undef unless @{$_[0]{'dbk_lists'}};
    return $_[0]{'dbk_lists'}[$#{$_[0]{'dbk_lists'}}];
}

sub start_list {
    my ( $self, $type, %attr )= @_;

    $self->start_block();

    my $list_tag;
    my $item_tag;
    if ( $type eq 'ordered' ) {
        $list_tag = 'ol';
        $item_tag = 'li';
    } elsif ( $type eq 'itemized' ) {
        $list_tag = 'ul';
        $item_tag = 'li';
    } elsif ( $type eq 'variable' ) {
        $self->start_div( 'variablelist' );
        $list_tag = 'dl';
        $item_tag = 'dd';
    } else {
        die "unsupported list type: '$type'\n";
    }

    $self->inline_char( "<$list_tag>" )
      unless ( $type eq 'variable' );
    $self->start_block( 2 );
    push @{$self->{'dbk_lists'}}, { 'dbk_type' => $type,
                                    'dbk_list_tag' => $list_tag,
                                    'dbk_listitem_tag' => $item_tag,
                                    %attr,
                                  };

    return $self->current_list();
}

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

    $self->end_block();
    my $list = pop @{$self->{'dbk_lists'}};
    my $list_tag = $list->{ 'dbk_list_tag' };
    $self->inline_char( "</$list_tag>" );
    if ( $list->{'dbk_type'} eq 'variable' ) {
        $self->end_block();
        $self->inline_char( "</div>" );
    }
    $self->end_block();

    return;
}

sub dbk_para_start {
    my ( $self, $name, $attr )= @_;

    my $block = $self->start_div( 'para' );

    if ( $self->in_element( "listitem" ) ) {
        my $parent = $self->parent_block();

        my $list = $self->current_list();

        # Copy listitem indent and initial_indent attribute
        if ( $parent->{'dbk_children'} == 1 ) {
            $block->{'dbk_initial_indent'} = $parent->{'dbk_initial_indent'};
        } else {
            # Add extra space before the paragraph if it wasn't the first
            # and the list is compact
            $self->{'dbk_text'} .= "\n"
              if ( $parent->{'dbk_children'} > 1
                   && $list->{'spacing'} eq 'compact' );

            # Put mark only on first para
            $block->{'dbk_initial_indent'} = $parent->{'dbk_indent'};
        }
        $block->{'dbk_indent'} = $parent->{'dbk_indent'};
    }

    return;
}

sub dbk_para_end {
    $_[0]->end_div();

    return;
}

sub dbk_itemizedlist_start {
    my ( $self, $name, $attr )= @_;

    $self->start_list( 'itemized',
                       'mark' => '-',
                       'spacing' => 'normal',
                       %$attr );

    return;
}

sub dbk_itemizedlist_end {
    $_[0]->end_list();

    return;
}

sub dbk_orderedlist_start {
    my ( $self, $name, $attr )= @_;

    $self->start_list( 'ordered',
                       'spacing' => 'normal',
                       %$attr,
                       'item_count' => 0 );

    return;
}

sub dbk_orderedlist_end {
    $_[0]->end_list();

    return;
}

sub dbk_variablelist_start {
    my ( $self, $name, $attr )= @_;

    $self->start_list( 'variable',
                       'spacing' => 'normal',
                       %$attr );

    return;
}

sub dbk_variablelist_end {
    $_[0]->end_list();

    return;
}

sub dbk_varlistentry_start {
    my $self = $_[0];

    my $list = $self->current_list();
    return unless defined( $list );
    if ( !$list->{'_list_started'} ) {
        $self->inline_char( "<$list->{'dbk_list_tag'}>" );
        $self->start_block( 2 );
        $list->{'_list_started'} = 'yes';
    }

    return;
}

sub dbk_listitem_start {
    my ( $self, $name, $attr )= @_;

    $self->start_block();
    my $list = $self->current_list();
    return unless defined( $list );
    $self->inline_char( "<$list->{'dbk_listitem_tag'}>" );
    $self->start_block( 2 );

    return;
}

sub dbk_listitem_end {
    my $self = $_[0];

    $self->end_block();
    my $list = $self->current_list();
    return unless defined( $list );
    $self->inline_char( "</$list->{'dbk_listitem_tag'}>" );
    $self->end_block();

    return;
}

sub admonition_start {
    my ( $self, $name, $attr ) = @_;

    $self->start_div( $name );
    $self->span_text( 'admonition', ucfirst( $name . ":" ) );
    $self->start_block( 2 );

    return;
}

sub admonition_end {
    my $self = $_[0];

    $self->end_block();
    $self->end_div();

    return;
}

sub mapped_start {
    my ( $self, $name ) = @_;

    $self->inline_char( "<$dbk2html{$name}>" );

    return;
}

sub mapped_end {
    my ( $self, $name ) = @_;

    $self->inline_char( "</$dbk2html{$name}>" );

    return;
}

sub span_start {
    my ( $self, $name, $attr ) = @_;

    $self->inline_char( "<span class=\"$name\">" );
    return;
}

sub span_end {
    my ( $self, $name ) = @_;

    $self->inline_char( "</span>" );
    return;
}

sub var_start {
    my ( $self, $name, $attr ) = @_;

    $self->inline_char( "<var class=\"$name\">" );
    return;
}

sub var_end {
    my ( $self, $name, $attr ) = @_;

    $self->inline_char( "</var>" );
    return;
}

sub dbk_email_end {
    my ( $self, $name ) = @_;

    my $email = $self->get_collector( $name );
    $_[0]->inline_char( "<a href=\"mailto:$email\">$email</a>" );

    return;
}

sub dbk_term_start {
    my ( $self, $name, $attr )= @_;

    my $block = $self->start_block();

    $self->collector_start( $name );

    return;
}

sub dbk_term_end {
    my ( $self, $name ) = @_;

    $self->inline_char( "<dt>" . $self->get_collector( $name ). "</dt>" );
    $self->end_block();

    return;
}

sub dbk_title_start {
    my ( $self, $name, $attr )= @_;

    $self->start_block( 0 );
    $self->span_start( $name );
    return;
}

sub dbk_title_end {
    my ( $self, $name ) = @_;

    $self->span_end( $name );
    $_[0]->end_block();

    return;
}

sub dbk_ulink_start {
    my ( $self, $name, $attr )= @_;

    my $url = $attr->{'url'} || '';
    $self->{'dbk_curr_url_attr'} = $url;
    $self->inline_char( "<a href=\"$url\">" );

    return;
}

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

    $self->inline_char( '</a>' );
    delete $self->{'dbk_curr_url_attr'};
    delete $self->{'dbk_curr_url'};

    return;
}

sub dbk_ulink_char {
    my ( $self, $str )= @_;

    my $cdata = ( $str ne ''
                  ? $str
                  : $self->$self->{'dbk_curr_url_attr'} );
    $self->inline_char( $cdata );

    return;
}

=pod

=head1 dbk2html( $docbook_str, [$columns], [$xhtml] )

Returns an HTML version of the DocBook XML fragment $docbook_str. The
C<columns> parameter sets the number of columns in which the DocBook HTML text
should be formatted. The C<xhtml> parameter defines whether the generated code
will be XHTML-compliant; the default is yes.

This method will die() in case of error.

=cut

sub dbk2html {
    my ( $docbook_str, $columns, $xhtml ) = @_;

    $xhtml = 1 unless defined $xhtml;
    $docbook_str = ensure_utf8( $docbook_str );

    my %args = ( 'dbk_columns' => $columns,
                 'xhtml' => $xhtml );
    my $parser = new Lire::ReportParser::HTMLDocBookFormatter( %args );
    my $str = <<EOD;
<?xml version="1.0" encoding="utf-8"?>
<lire:description xmlns:lire="http://www.logreport.org/LRML/">
  $docbook_str
</lire:description>
EOD

    return $parser->parse( $str );
}

1;

__END__


=head1 SEE ALSO

Lire::ReportParser(3pm) Lire::ReportParser::AsciiDocBookFormatter(3pm)

=head1 VERSION

$Id: HTMLDocBookFormatter.pm,v 1.10 2006/07/23 13:16:31 vanbaal Exp $

=head1 AUTHORS

  Francis J. Lacoste <flacoste@logreport.org>
  Wolfgang Sourdeau <wolfgang@logreport.org>

=head1 COPYRIGHT

Copyright (C) 2001-2004 Stichting LogReport Foundation LogReport@LogReport.org

This file is part of Lire.

Lire is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program (see COPYING); if not, check with
http://www.gnu.org/copyleft/gpl.html. 

=cut