package Lire::ReportParser::DocBookFormatter;

use strict;

use vars qw/ $VERSION @ISA @EXPORT_OK @dbk_elmnts @auto_pcdata @dbk_pcdata /;

use Exporter;
use Lire::ReportParser;
use Text::Wrap qw/ wrap /;

BEGIN {
    ($VERSION)	= '$Revision: 1.1 $' =~ m!Revision: ([.\d]+)!;
    @ISA = qw/ Lire::ReportParser Exporter/;
    @EXPORT_OK = qw/dbk2txt/;

    @dbk_elmnts = qw/listitem orderedlist itemizedlist 
		     variablelist varlistentry caution note tip warning
		     important /;

    @dbk_pcdata = qw/para term ulink title quote/;

    @auto_pcdata = qw/abbrev acronym emphasis phrase trademark wordasword 
		      action application classname command computeroutput 
		      database email envar errorcode errorname errortype 
		      filename function hardware
		      interface keycap keycode keycombo keysym
		      literal constant markup
		      option optional parameter prompt property 
		      replaceable returnvalue sgmltag structfield structname
		      symbol systemitem token type userinput varname anchor
		      author authorinitials corpauthor modespec othercredit
		      productname productnumber subscript superscript 
		     /;

    foreach my $elmnt ( @auto_pcdata ) {
	no strict 'refs';
	my $sub_pfx = __PACKAGE__ . '::dbk_' . $elmnt;
	*{$sub_pfx . '_start'} = sub {};
	*{$sub_pfx . '_end'} = sub {};
	*{$sub_pfx . '_char'} = sub { 
	    my $self = shift;
	    $self->inline_char( @_ );
	};
    }
}

=pod

=head1 NAME

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

=head1 SYNOPSIS

To format DocBook:

    use Lire::ReportParser::DocBookFormatter qw/dbk2txt/;

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

In XML Report processors :

    package MyParser;

    use Lire::ReportParser::DocBookFormatter;

    use vars qw/@ISA/;

    @ISA = qw/Lire::ReportParser::DocBookFormatter/;

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


=head1 DESCRIPTION

This package defines a subclass of Lire::ReportParser that can handle
the content of C<description> element. Client only have to inherit
from this module so that a new handle_description() method is
available to process the text formatted DocBook description.

This module also provide a convenient dbk2txt() function which can be
used to format a string containing DocBook elements into an ASCII
equivalent.

=head1 USING Lire::ReportParser::DocBookFormatter

Lire::ReportParser processors that would like to work with text
version of the description only have to inherit from
Lire::ReportParser::DocBookFormatter. They shouldn't override the
known_dbk_elements() method nor the known_dbk_pcdata_elements()
method. If they override the element_start(), description_start or
description_end() method, they B<must> link to their parents' version
using C<SUPER::>.

=head2 PARAMETERS

The constructor recognize some parameters that can be used to control
the behavior of the DocBook handling:

=over 4

=item columns

The number of columsn in which the DocBook text should be formatted.
Defaults to 72.

=item target-user

Select for which description the handle_description() event will be
synthetized. The handle_description() method will only be invoked for
description tailored to this target-user. Defaults to C<sysadmin>.

=item userlevel

In description, the maximum level of elements that will be formatted.
Defaults to C<normal> (i.e. C<advanced> elements aren't formatted.

=back

=cut

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

    my %args = @_;
    $self->{dbk_target_user} = $args{'target-user'} || 'sysadmin';
    $self->{dbk_userlevel}   = $args{userlevel} || 'normal';
    $self->{dbk_columns}     = $args{columns}   || 72;
    $self;
}

sub known_dbk_elements {
    return [ @dbk_elmnts, @dbk_pcdata, @auto_pcdata ];
}

sub known_dbk_pcdata_elements {
    return [ @dbk_pcdata, @auto_pcdata ];
}

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

    if ( exists $attr{'target-user'} && 
	 $attr{'target-user'} ne $self->{dbk_target_user})
    {
	# Skip this description if there is a target-user attribute on it
	# and it isn't the same as the requested target-user.
	$self->skip();
    }

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

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

    return unless $self->{dbk_process};

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

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

=pod

=head2 handle_description( $description )

This method is invoked after the closing tag of the C<description>
element is encoutered. The $description contains the description
formatted in plain text.

=cut


sub handle_description {}

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

    # We only handle DocBook elements.
    return 0 unless $self->within_element( "lire:description" );

    # Skip element which have a higher userlevel
    # than requested
    return 0 unless exists $attr{userlevel};
    return 0 if $self->{dbk_userlevel} eq 'advanced';
    return 0 if $attr{userlevel} eq $self->{dbk_userlevel};

    # Requested userlevel is 'normal' and element isn't
    $self->skip();

    return 1;
}

# Called when starting DocBook parse.
sub init_dbk {
    my ( $self ) = @_;

}

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_right_margin};
    $self->{dbk_text} .= wrap( $initial, $next, $block->{dbk_text} );

    if ( $block->{dbk_skip_line} ) {
	$self->{dbk_text} .= "\n\n";
    } else {
	$self->{dbk_text} .= "\n";
    }

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

sub inline_char {
    my ( $self, $str ) = @_;
    my $block = $self->current_block;
    $block->{dbk_text} .= $str if $block;
}

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

    $left_margin_indent ||= 0;
    $right_margin_indent ||= 0;

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

    $self->{dbk_left_margin}  += $left_margin_indent;
    $self->{dbk_right_margin} += $right_margin_indent;
    push @{$self->{dbk_text_blocks}},
      { dbk_text	    => "",
	dbk_initial_indent  => '',
	dbk_indent	    => '',
	dbk_left_margin_indent  => $left_margin_indent,
	dbk_right_margin_indent => $right_margin_indent,
	dbk_skip_line	    => 1,
	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};
    $self->{dbk_right_margin} -= $block->{dbk_right_margin_indent};
    pop @{$self->{dbk_text_blocks}};
}

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

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

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

    push @{$self->{dbk_lists}}, { dbk_type => $type,
				  %attr,
				};

    return $self->current_list;
}

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

    $self->end_block;
    my $list = pop @{$self->{dbk_lists}};

    # We need an extra newline when the spacing was set to compact.
    # Otherwise the next block will start on the line immediately following
    # the last listitem.
    $self->{dbk_text} .= "\n"
      if ( $list->{spacing} eq 'compact' );

    $list;
}

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

    my $block = $self->start_block;

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

	my $list = $self->current_list;
	$block->{dbk_skip_line} = 0 if $list->{spacing} eq 'compact';

	# 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};
    }
}

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

    $self->end_block;
}

sub dbk_para_char {
    my $self = shift;
    $self->inline_char( @_ );
}

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

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

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

    $self->end_list;
}

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

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

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

    $self->end_list;
}

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

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

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

    $self->end_list;
}

sub dbk_varlistentry_start {}

sub dbk_varlistentry_end {}

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

    my $block = $self->start_block;
    $block->{dbk_skip_line} = 0;
}

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

    $self->end_block;
}

sub dbk_term_char {
    my $self = shift;
    $self->inline_char( @_ );
}

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

    my $list = $self->current_list;
    my $block = $self->start_block;
    if ( $list->{dbk_type} eq 'itemized' ) {
	my $mark = $attr{override} || $list->{mark};

	$block->{dbk_initial_indent} = $mark . ' ';
	$block->{dbk_indent} = ' ' x length $block->{dbk_initial_indent};
    } elsif ( $list->{dbk_type} eq 'ordered' ) {
	$list->{dbk_item_count}++;

	$block->{dbk_initial_indent} = $list->{dbk_item_count} . '. ';
	$block->{dbk_initial_indent} .= ' '
	  if length $block->{dbk_initial_indent} < 4 ;
	$block->{dbk_indent} = ' ' x length $block->{dbk_initial_indent};
    } elsif ( $list->{dbk_type} eq 'variable' ) {
	$block->{dbk_initial_indent} = ' ' x 4;
	$block->{dbk_indent} = ' ' x 4;
    } else {
	lr_warn( "unknown list type: $list->{dbk_type}" );
    }

    $block->{dbk_skip_line} = 0 if $list->{spacing} eq 'compact';
}

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

    $self->end_block;
}

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

    $self->start_block( 0, 4 );
}

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

    $self->end_block();
}

sub dbk_title_char {
    my $self = shift;
    $self->inline_char( @_ );
}

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

    $self->{dbk_curr_url_attr} = $attr{url} || "";
    $self->{dbk_curr_url} = "";
}

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

    $self->inline_char( ' (' . $self->{dbk_curr_url_attr} . ')' )
      if ( $self->{dbk_curr_url_attr} ne $self->{dbk_curr_url} );
    delete $self->{dbk_curr_url_attr};
    delete $self->{dbk_curr_url};
}

sub dbk_ulink_char {
    my ( $self, $str )= @_;
    $self->inline_char( $str );
    $self->{dbk_curr_url} .= $str;
}

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

    $self->inline_char( '"' );
}

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

    $self->inline_char( '"' );
}

sub dbk_quote_char {
    my $self = shift;
    $self->inline_char( @_ );
}

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

    my $block = $self->start_block;
    $block->{dbk_skip_line} = 0;
    $self->inline_char( ucfirst $name . ":" );
    $self->end_block;
    $self->start_block( 2 );
}

sub admonition_end {
    my ( $self, $name ) = @_;
    $self->end_block;
}

sub dbk_note_start {
    my $self = shift;
    $self->admonition_start( "note", @_ );
}

sub dbk_note_end {
    $_[0]->admonition_end( "note" );
}

sub dbk_tip_start {
    my $self = shift;
    $self->admonition_start( "tip", @_ );
}

sub dbk_tip_end {
    my $self = shift;
    $self->admonition_end( "tip" );
}

sub dbk_important_start {
    my $self = shift;
    $self->admonition_start( "important", @_ );
}

sub dbk_important_end {
    my $self = shift;
    $self->admonition_end( "important" );
}

sub dbk_caution_start {
    my $self = shift;
    $self->admonition_start( "caution", @_ );
}

sub dbk_caution_end {
    my $self = shift;
    $self->admonition_end( "caution" );
}

sub dbk_warning_start {
    my $self = shift;
    $self->admonition_start( "warning", @_ );
}

sub dbk_warning_end {
    my $self = shift;
    $self->admonition_end( "warning" );
}

=pod

=head1 FORMATTING DocBook SRINGS

If you have DocBook content in a string, like you can obtain from some
of the Report Specifications object, you can format it in plain text
using the dbx2txt() function.

=head2 dbk2txt( $docbook_str, [$userlevel] )

Returns a plain text version of the DocBook XML fragment $docbook_str.
You can set the C<userlevel> according to which it should be formatted
by using the $userlevel parameter.

This method will die() in case of error.

=cut

sub dbk2txt {
    my ( $docbook_str, $userlevel ) = @_;

    $userlevel ||= "normal";

    my $parser = Lire::ReportParser::DocBookFormatter::Simple->new( userlevel => $userlevel );
    my $str = <<EOD;
<?xml version="1.0" encoding="iso-8859-1"?>
<lire:description xmlns:lire="http://www.logreport.org/LRML/">
$docbook_str
</lire:description>
EOD

    $parser->parse( $str );
}

package Lire::ReportParser::DocBookFormatter::Simple;

use vars qw/ @ISA /;

BEGIN {
    @ISA = qw/Lire::ReportParser::DocBookFormatter/;
}

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

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

# keep perl happy
1;

__END__


=head1 SEE ALSO

Lire::ReportParser(3pm)

=head1 VERSION

$Id: DocBookFormatter.pm,v 1.1 2002/07/28 19:29:17 flacoste Exp $

=head1 COPYRIGHT

Copyright (C) 2001 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 or write to the Free Software 
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111, USA.

=head1 AUTHOR

Francis J. Lacoste <flacoste@logreport.org>

=cut
