File Coverage

blib/lib/Pod/2/DocBook.pm

Criterion	Covered	Total	%
statement	392	462	84.8
branch	193	246	78.4
condition	51	82	62.2
subroutine	34	35	97.1
pod	11	11	100.0
total	681	836	81.4

package Pod::2::DocBook;

=head1 NAME

Pod::2::DocBook - Convert Pod data to DocBook SGML

=head1 SYNOPSIS

    use Pod::2::DocBook;
    my $parser = Pod::2::DocBook->new(
        title             => 'My Article',
        doctype           => 'article',
        base_id           => 'article42'
        fix_double_quotes => 1,
        spaces            => 3,
        id_version        => 2,
    );

  $parser->parse_from_file ('my_article.pod', 'my_article.sgml');

=head1 DESCRIPTION

Pod::2::DocBook is a module for translating Pod-formatted documents to
DocBook 4.2 SGML (see L).  It is primarily a
back end for B, but, as a Pod::Parser subclass, it can be
used on its own.  The only public extensions to the Pod::Parser
interface are options available to C:

=over

=item doctype

This option sets the output document's doctype.  The currently
supported types are B, B, B and
B.  Special processing is performed when the doctype is set
to B (see L).  You I set this option
in order to get valid DocBook output.

=item fix_double_quotes

If this option is set to a true value, pairs of double quote
characters ('"') in ordinary paragraphs will be replaced with
BquoteE> and B/quoteE>.  See L
Paragraphs> for details.

=item header

If this option is set to a true value, Pod::2::DocBook will emit a
DOCTYPE as the first line of output.

=item spaces

Pod::2::DocBook produces pretty-printed output.  This option sets the
number of spaces per level of indentation in the output.

=item title

This option sets the output document's title.

=back

The rest of this document only describes issues specific to
Pod::2::DocBook; for details on invoking the parser, specifically the
C, C and C methods,
see L.

=cut

use 5.006001;
use strict;
use warnings;

use Digest::MD5 'md5_hex';
use Pod::Parser;
use Pod::ParseLink;
use Text::ParseWords;
use Text::Wrap;
use List::MoreUtils 'any';

=head1 METHODS

    use base 'Pod::Parser';

=cut

use base 'Pod::Parser';
our $VERSION = '0.03';

my $SPACE        = q{ };
my $DOUBLE_QUOTE = q{"};

#----------------------------------------------------------------------
# overridden Pod::Parser methods
#----------------------------------------------------------------------

=head2 initialize()

Initialize parser.

=cut

sub initialize {
    my $parser = shift;

    $parser->errorsub('error_msg');
    $parser->{'Pod::2::DocBook::errors'} = [];

    $parser->{title}      ||= q{};
    $parser->{spaces}     ||= 0;
    $parser->{id_version} ||= 1;
    my $skip = $parser->{skip};
    $parser->{skip}       = [];
    push @{$parser->{skip}}, split(/\s*,\s*/, $skip || '')
        if $parser->{skip};

    # if base_id not set, put title as base_id or a random number in worst case
    $parser->{base_id} ||= $parser->{title} || q{:}._big_random_number();
    $parser->{base_id} = $parser->cleanup_id($parser->{base_id});

    return;
}

=head2 begin_pod()

Output docbook header stuff.

=cut

sub begin_pod {
    my ($parser) = @_;
    my $out_fh = $parser->output_handle();

    print $out_fh <<"END_HEADER" if $parser->{header};
{doctype}
        PUBLIC "-//OASIS//DTD DocBook V4.2//EN"
               "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" >
END_HEADER

    print $out_fh join("\n",
        '"),
      "\n";

    $parser->{indentlevel} = 1;

    if ($parser->{doctype} eq 'refentry') {
        print $out_fh join(q{},
            "\n",                    $parser->_indent(),
            "\n",                     $parser->_current_indent(),
            "$parser->{title}", "\n",
            $parser->_outdent(),               "\n");
    }
    else {
        print $out_fh '<',
          $parser->{doctype},
          ($parser->{base_id} ? ' id="' . $parser->{base_id} . $DOUBLE_QUOTE : ()),
          '>', </td>
</tr>

<tr>
<td  class="h" >
<a name="164">164</a>
</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td class="s">           $parser->{title}, </td>
</tr>

<tr>
<td  class="h" >
<a name="165">165</a>
</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td class="s">           '',
          "\n";
    }

    return;
}

=head2 end_pod()

Output docbook footer. Will print also errors if any in a comment block.

=cut

sub end_pod {
    my ($parser) = @_;
    my $out_fh = $parser->output_handle();

    $parser->_transition('THE END');

    # end document
    print $out_fh "{doctype}>\n";
    if (@{ $parser->{'Pod::2::DocBook::errors'} }) {
        print $out_fh "\n\n";
    }

    return;
}

=head2 commans($command, $paragraph, $line_num)

Process POD commands.

=cut

sub command {
    my ($parser, $command, $paragraph, $line_num) = @_;
    my $out_fh = $parser->output_handle();

    return if $command eq 'pod';

    # check if we need to skip this heading
    if ($command =~ /^head[1-4]/xms) {
        $parser->{'skip_current'} = (
            (any { $paragraph =~ m/^$_/  } @{$parser->{'skip'}})
            ? 1
            : 0
        );
    }

    $paragraph =~ s/\s+$//sx;
    $paragraph = $parser->interpolate($paragraph, $line_num);

    # For blocks must be considered before we escape entries, otherwise
    # docbook markup will get mangled.

    if ($command eq 'for') {
        $parser->_transition('for');
        if ($paragraph =~ /^(:\S+|docbook)/xms) {
            $paragraph =~ s/$1\s+//xms;
            print $out_fh $paragraph, "\n";
        }

        # If we've processed a docbook 'for', then we're done.
        # If we've process any other 'for', then it wasn't
        # intended for us, and we're also done.
        return;
    }

    # Now escape SGML-escape our text, and figure out what to do
    # with it.

    $paragraph = _fix_chars($paragraph);

    if ($command =~ /^head[1-4]/xms) {
        $parser->_transition($command);

        return if $parser->{'skip_current'};
        $parser->_handle_head($command, $paragraph, $line_num);
    }
    elsif ($command eq 'begin') {
        $parser->_transition("begin $paragraph");
        push(@{ $parser->{'Pod::2::DocBook::state'} }, "begin $paragraph");
    }
    elsif ($command eq 'end') {
        $parser->_transition("end $paragraph");
    }
    elsif ($command eq 'over') {
        $parser->_transition('over');
        push @{ $parser->{'Pod::2::DocBook::state'} }, 'over';
    }
    elsif ($command eq 'item') {
        $parser->_transition('item');
        $parser->_handle_item($paragraph, $line_num);
    }
    elsif ($command =~ /^back/xms) {
        $parser->_transition('back');
    }
    else {
        my $file = $parser->input_file();
        $parser->error_msg("unknown command `$command' at",
            "line $line_num in file $file");
    }

    return;
}

=head2 textblock ($paragraph, $line_num)

Process text block.

=cut

sub textblock {
    my ($parser, $paragraph, $line_num) = @_;
    my $out_fh   = $parser->output_handle();
    my $state    = pop @{ $parser->{'Pod::2::DocBook::state'} };
    my $para_out = q{};

    $state = q{} unless defined $state;
    $paragraph =~ s/\s+$//xms unless $state eq 'begin docbook';

    $paragraph =~ s/&/&/xmsg unless $state eq 'begin docbook';

    unless ($state eq 'begin docbook' || $state eq 'begin table') {
        $paragraph = $parser->interpolate($paragraph, $line_num);
        $paragraph = _fix_chars($paragraph);
    }

    if ($state eq 'name') {
        my ($name, $purpose) = split(/\s*-\s*/xms, $paragraph, 2);

        $para_out = join(q{},
            $parser->_indent(),
            "\n",
            $parser->_current_indent(),
            "$name\n",
            "$purpose\n",
            $parser->_outdent(),
            "\n");
    }
    elsif ($state eq 'synopsis+') {
        $para_out = join(q{},
            $parser->_indent(), "\n",
            "$paragraph\n");

        push @{ $parser->{'Pod::2::DocBook::state'} }, 'synopsis';
    }
    elsif ($state eq 'synopsis') {
        $para_out = "$paragraph\n";
        push @{ $parser->{'Pod::2::DocBook::state'} }, $state;
    }
    elsif ($state eq 'begin docbook') {
        push @{ $parser->{'Pod::2::DocBook::dbpara'} }, $paragraph;
        push @{ $parser->{'Pod::2::DocBook::state'} },  $state;
    }
    elsif ($state eq 'begin table') {
        $parser->_handle_table($paragraph, $line_num);
        push @{ $parser->{'Pod::2::DocBook::state'} }, $state;
    }
    elsif ($state =~ /^begin\s[^:]/xms) {
        push @{ $parser->{'Pod::2::DocBook::state'} }, $state;
    }
    elsif ($state eq 'over') {
        ## no critic (Variables::ProhibitPackageVars )
        local $Text::Wrap::huge = 'overflow';    # don't break tags
        ## use critic

        $paragraph =~ s/\s*\n\s*/ /gx;            # don't just wrap, fill

        $para_out = join(
            q{},
            $parser->_indent(),
            "\n",
            $parser->_indent(),
            "\n",
            wrap(
                ' ' x ($parser->{spaces} * $parser->{indentlevel}),
                ' ' x ($parser->{spaces} * $parser->{indentlevel}),
                $paragraph
            ),
            "\n",
            $parser->_outdent(),
            "\n"
        );

        push @{ $parser->{'Pod::2::DocBook::state'} }, 'indent';
    }
    else {
        ## no critic (Variables::ProhibitPackageVars )
        local $Text::Wrap::huge = 'overflow';    # don't break tags
        ## use critic

        print $out_fh "]]>\n" if $state eq 'verbatim';

        $paragraph =~ s/\s*\n\s*/ /gx;            # don't just wrap, fill

        {
            $para_out = $parser->_indent;

            my $padding = ' ' x ($parser->{spaces} * $parser->{indentlevel});

            $para_out .= join q{},
              "\n",
              wrap($padding, $padding, $paragraph),
              "\n",
              $parser->_outdent,
              "\n";
        }
        $state =~ s/\+$//xms;
        push @{ $parser->{'Pod::2::DocBook::state'} }, $state
          unless ($state eq 'verbatim' || $state eq q{});
    }

    # fix double quotes in ordinary paragraphs if asked to
    if ($state !~ /^begin/xms && $parser->{fix_double_quotes} && $para_out =~ /"/xms)
    {
        my @protected;
        while ($para_out =~ m#(<[^>"]*".+?>)#sx) {

            # don't modify things that look like tags with quotes inside
            my $protect = $1 || $2;
            my $replace = quotemeta($protect);

            $para_out =~ s/$replace/\376/xms;
            push @protected, $protect;
        }

        $para_out =~ s!"(.+?)"!$1!sgx;
        foreach my $protect (@protected) {
            $para_out =~ s/\376/$protect/xms;
        }
    }

    print $out_fh $para_out
        if not $parser->{'skip_current'};

    return;
}

=head2 verbatim($paragraph, $line_num)

Process verbatim text block.

=cut

sub verbatim {
    my ($parser, $paragraph, $line_num) = @_;
    my $out_fh = $parser->output_handle();
    my $state = pop @{ $parser->{'Pod::2::DocBook::state'} } || q{};
    my @lines;
    my $min_leader;

    return if $parser->{'skip_current'};

    $paragraph =~ s/\s+$//sx unless $state eq 'begin docbook';

    @lines = split(/\n/xms, $paragraph);
    foreach my $line (@lines) {

        # expand tabs (see perldoc -q 'expand tabs')
        1 while $line =~ s/\t+/' ' x (length($&) * 8 - length($`) % 8)/ex;

        # find the minimum-length whitespace leader for this paragraph
        my ($leader) = ($line =~ /^(\s+)/xms);
        $leader ||= q{};

        $min_leader = length($leader)
            if ((not defined $min_leader) or (length($leader) < $min_leader));
    }

    $paragraph = join("\n", @lines);

    # strip the minimum-length whitespace leader from every line
    $paragraph =~ s/^\s{$min_leader}//gxms
        if $min_leader;

    if (!defined $state) {
        print $out_fh $parser->_current_indent(), "
        push @{ $parser->{'Pod::2::DocBook::state'} }, 'verbatim';
    }
    elsif ($state eq 'name') {
        my ($name, $purpose) = split(/\s*-\s*/xms, $paragraph, 2);

        $purpose ||= q{};    # $purpose can be empty

        print $out_fh $parser->_indent,
          "\n",
          $parser->_current_indent,
          "$name\n",
          $parser->_current_indent,
          "$purpose\n",
          $parser->_outdent,
          "\n";
    }
    elsif ($state eq 'synopsis+') {
        print $out_fh join(q{},
            $parser->_indent(), "\n",
            "$paragraph\n");

        push @{ $parser->{'Pod::2::DocBook::state'} }, 'synopsis';
    }
    elsif ($state eq 'synopsis') {
        print $out_fh "$paragraph\n";
        push @{ $parser->{'Pod::2::DocBook::state'} }, $state;
    }
    elsif ($state eq 'begin docbook') {
        push @{ $parser->{'Pod::2::DocBook::dbpara'} }, $paragraph;
        push @{ $parser->{'Pod::2::DocBook::state'} },  $state;
    }
    elsif ($state =~ /^begin\s[^:]/xms) {
        push @{ $parser->{'Pod::2::DocBook::state'} }, $state;
    }
    elsif ($state eq 'over') {
        print $out_fh join(q{},
            $parser->_indent(), "\n", $parser->_current_indent(),
            "

        push @{ $parser->{'Pod::2::DocBook::state'} }, 'indent';
        push @{ $parser->{'Pod::2::DocBook::state'} }, 'verbatim';
    }
    elsif ($state eq 'verbatim') {
        print $out_fh "\n\n$paragraph";
        push @{ $parser->{'Pod::2::DocBook::state'} }, $state;
    }
    else {
        print $out_fh $parser->_current_indent(), "
        $state =~ s/\+$//xms;
        push @{ $parser->{'Pod::2::DocBook::state'} }, $state;
        push @{ $parser->{'Pod::2::DocBook::state'} }, 'verbatim';
    }

    return;
}

=head2 interior_sequence($command, $argument, $seq)

Process formatting commands.

=cut

sub interior_sequence {
    my ($parser, $command, $argument, $seq) = @_;
    my $out_fh = $parser->output_handle();
    my $string;

    # nothing is ever allowed to be nested inside of E<>, or Z<>
    if (my $parent = $seq->nested()) {
        if ($parent->cmd_name() eq 'E' || $parent->cmd_name() eq 'Z') {
            my ($file, $line) = $seq->file_line();
            $parser->error_msg(
                "formatting code `$command' nested within",
                "`" . $parent->cmd_name() . "'",
                "at line $line in file $file"
            );
            return $seq->raw_text();
        }
    }

    $argument = q{} unless defined $argument;

    # the substring "\37632\377" is a space character protected
    # against translation in S<>; other characters are protected at
    # the end of this function, and all protected characters are
    # de-protected in _fix_chars ()

    if ($command eq 'I') {
        $string = qq!$argument!;
    }
    elsif ($command eq 'B') {
        $string = qq!$argument!;
    }
    elsif ($command eq 'C') {
        $string = qq!!
          . "";
    }
    elsif ($command eq 'L') {
        $string = $parser->_handle_L($argument, $seq);
    }
    elsif ($command eq 'E') {
        $string = $parser->_handle_E($argument, $seq);
    }
    elsif ($command eq 'F') {
        $string = "$argument";
    }
    elsif ($command eq 'S') {
        $argument =~ s/\s(?![^<]*>)/ /gx;
        $string = $argument;
    }
    elsif ($command eq 'X') {
        $string = "$argument";
    }
    elsif ($command eq 'Z') {
        $string = q{};
    }
    else {
        my ($file, $line) = $seq->file_line();
        $parser->error_msg("unknown formatting code `$command' at line",
            "in file $file");
        $string = $seq->raw_text();
    }

    # protect &, <, and > characters from later processing
    # I got this from the first edition Camel Book
    unless ($seq->nested()) {

        # just do this once, at the top of a subtree so we can
        # report more meaningful errors along the way
        foreach my $char ('&', '<', '>') {
            $string =~ s/$char/"\376" . ord ($char) . "\377"/egx;
        }
    }

    return $string;
}

#----------------------------------------------------------------------
# other public methods
#----------------------------------------------------------------------

=head2 error_msg

Returns parser error message(s) if any occured.

=cut

sub error_msg {
    my ($parser, @parts) = @_;

    push(@{ $parser->{'Pod::2::DocBook::errors'} }, join(' ', @parts));

    return;
}

#----------------------------------------------------------------------
# private methods and helper functions
#----------------------------------------------------------------------

sub _indent {
    my ($parser) = @_;
    return (' ' x ($parser->{spaces} * $parser->{indentlevel}++));
}

sub _outdent {
    my ($parser) = @_;
    return (' ' x (--$parser->{indentlevel} * $parser->{spaces}));
}

sub _current_indent {
    my $parser = shift;
    return ' ' x ($parser->{spaces} * $parser->{indentlevel});
}

=head2 make_id($text)

default id format -

Function will construct an element id string. Id string is composed of
C<< join (':', $parser->{base_id}, $text) >>, where C<$text> in most cases
is the pod heading text.

version 2 id format -

having ':' in id was not a best choice. (Xerces complains - Attribute value
"lib.Moose.Manual.pod:NAME" of type ID must be an NCName when namespaces are
enabled.) To not break backwards compatibity switch with F< 2>> in
constructor for using '-' instead.

The xml id string has strict format. Checkout L function for
specification.

=cut

sub make_id {
    my $parser  = shift;
    my $text    = shift;
    my $base_id = $parser->{base_id};

    # trim text spaces
    $text    =~ s/^\s*//xms;$text    =~ s/\s*$//xms;
    $base_id =~ s/^\s*//xms;$base_id =~ s/\s*$//xms;

    return $parser->cleanup_id(join ('-', $base_id, $text))
        if $parser->{'id_version'} == 2;

    return $parser->cleanup_id(join (':', $base_id, $text));
}


=head2 make_uniq_id($text)

Calls C<< $parser->make_id($text) >> and checks if such id was already
generated. If so, generates new one by adding _i1 (or _i2, i3, ...) to the id
string. Return value is new uniq id string.

=cut

sub make_uniq_id {
    my $parser = shift;
    my $text   = shift;

    my $id_string = $parser->make_id($text);

    # prevent duplicate ids
    my $ids_used = $parser->{'ids_used'} || {};
    while (exists $ids_used->{$id_string}) {
        if ($id_string =~ m/_i(\d+)$/xms) {
            my $last_used_id_index = $1;
            substr($id_string, 0-length($last_used_id_index), length($id_string), $last_used_id_index + 1);
        }
        else {
            $id_string .= '_i1';
        }
    }
    $ids_used->{$id_string} = 1;
    $parser->{'ids_used'} = $ids_used;

    return $id_string;
}

sub _handle_L {
    my ($parser, $argument, $seq) = @_;
    my $node = $seq;

    # look all the way up the subtree to see if any ancestor is an 'L'
    while ($node = $node->nested()) {
        if ($node->cmd_name() eq 'L') {
            my ($file, $line) = $seq->file_line();
            $parser->error_msg("formatting code `L' nested within `L' at",
                "line $line in file $file");
            return $seq->raw_text();
        }
    }

    # the substring "\37632\377" is a space character protected
    # against translation in S<>; other characters are protected at
    # the end of interior_sequence (), and all protected characters
    # are de-protected in _fix_chars ()

    my ($text, $inferred, $name, $section, $type) = parselink($argument);
    $inferred =~ s/&/&/xmsg
        if $inferred;
    $name     =~ s/&/&/xmsg
        if $name;

    return qq!$inferred!
      if $type eq 'url';

    # types 'man' and 'pod' are handled the same way
    if (defined $section && !defined $name) {
        my $id = $parser->make_id($section);

        $section = $text if defined $text;
        return (qq!$section!
              . "");
    }

    return $text if defined $text;

    if (defined $name) {
        my $string =
            $name =~ /(.+?)\((.+)\)/xms
          ? $parser->_manpage($1, $2)
          : $parser->_manpage($name);

        return defined $section
          ? "$section in $string"
          : $string;
    }

    my ($file, $line) = $seq->file_line();
    $parser->error_msg("empty L<> at line", "$line in file $file\n");
    return $seq->raw_text();
}

sub _handle_E {
    my ($parser, $argument, $seq) = @_;

    if ($argument !~ /\A\w+\z/xms) {
        my ($file, $line) = $seq->file_line();
        $parser->error_msg("invalid escape `$argument'",
            "at line $line in file $file\n");
        return $seq->raw_text();
    }

    # careful! the order is important
    return
        $argument eq 'verbar' ? '|'
      : $argument eq 'sol'    ? '/'
      : (    $argument eq 'lchevron'
          or $argument eq 'laquo') ? '«'
      : (    $argument eq 'rchevron'
          or $argument eq 'raquo') ? '»'
      : $argument =~ /^0x/xms   ? '&#' . hex($argument) . ';'
      : $argument =~ /^0/xms    ? '&#' . oct($argument) . ';'
      : $argument =~ /^\d+$/xms ? "&#$argument;"
      :                        "&$argument;";
}

sub _handle_head {
    my ($parser, $command, $paragraph, $line_num) = @_;
    my $out_fh = $parser->output_handle();

    if (   $parser->{doctype} eq 'refentry'
        && $command   eq 'head1'
        && $paragraph eq 'NAME')
    {
        push @{ $parser->{'Pod::2::DocBook::state'} }, 'name';
    }
    elsif ($parser->{doctype} eq 'refentry'
        && $command   eq 'head1'
        && $paragraph eq 'SYNOPSIS')
    {
        push @{ $parser->{'Pod::2::DocBook::state'} }, 'synopsis+';
    }
    else {
        push @{ $parser->{'Pod::2::DocBook::state'} }, "$command+";
        my $id = $parser->make_uniq_id($paragraph);

        if ($parser->{doctype} eq 'refentry') {
            print $out_fh $parser->_indent(),
              qq!$paragraph\n!;
        }
        else {
            print $out_fh $parser->_indent(),
              qq!$paragraph\n!;
        }
    }

    return;
}

sub _handle_item {
    my ($parser, $paragraph, $line_num) = @_;
    my $out_fh = $parser->output_handle();
    my $state  = pop @{ $parser->{'Pod::2::DocBook::state'} };

    $state = q{} unless defined $state;

    if ($state eq 'verbatim') {
        print $out_fh "]]>\n";
        $state = pop @{ $parser->{'Pod::2::DocBook::state'} };
        $state = q{} unless defined $state;
    }

    if ($state =~ /list\+$/xms) {
        print $out_fh $parser->_current_indent(), "\n";
    }

    if ($state eq 'over') {

        # first item
        if (   !defined($paragraph)
            || $paragraph =~ /^\s*$/xms
            || $paragraph eq q{*})
        {
            print $out_fh join(q{},
                $parser->_indent(), "\n",         $parser->_indent(),
                "\n", $parser->_indent(), "\n");
            $state = 'list+';
        }
        elsif ($paragraph =~ /^([1aAiI])\.?$/xms) {
            my $numeration = {
                1 => 'arabic',
                a => 'loweralpha',
                A => 'upperalpha',
                i => 'lowerroman',
                I => 'upperroman'
            }->{$1};

            print $out_fh join(q{},
                $parser->_indent(),
                "\n",
                $parser->_indent(),
                qq!\n!,
                $parser->_indent(),
                "\n");
            $state = 'olist+';
        }
        else {
            my $id = $parser->make_uniq_id($paragraph);
            print $out_fh join(q{},
                $parser->_indent(),
                "\n",
                $parser->_indent(),
                "\n",
                $parser->_indent(),
                "\n",
                $parser->_current_indent(),
                qq!$paragraph\n!,
                $parser->_indent(),
                qq!\n!);
            $state = 'vlist+';
        }
    }
    elsif ($state =~ /^o?list/xms) {
        print $out_fh join(q{},
            $parser->_outdent(), "\n",
            $parser->_indent(),  "\n");
        $state = "$state+" unless $state =~ /\+$/xms;
    }
    elsif ($state =~ /^vlist/xms) {
        my $id = $parser->make_uniq_id($paragraph);
        print $out_fh join(q{},
            $parser->_outdent(),
            "\n",
            $parser->_outdent(),
            "\n",
            $parser->_indent(),
            "\n",
            $parser->_current_indent(),
            qq!$paragraph\n!,
            $parser->_indent(),
            "\n");
        $state = 'vlist+';
    }
    else {
        $parser->error_msg(
            '=item must be inside an',
            '=over ... =back region',
            "at line $line_num in file",
            $parser->input_file()
        );
    }

    push @{ $parser->{'Pod::2::DocBook::state'} }, $state;

    return;
}

sub _transition {
    my ($parser, $what) = @_;
    my $out_fh = $parser->output_handle();
    my ($level);

    # $level helps us determine what to do when we see =head
    # 1-4 are the valid numbers after '=head', so 0 and 5
    # are safe to use to mark out-of-bounds on either side
    if ($what eq 'THE END') {
        $level = 0;
    }
    elsif ($what =~ /^head(\d)/xms) {
        $level = $1;
    }
    else {
        $level = 5;
    }

    while (my $state = pop @{ $parser->{'Pod::2::DocBook::state'} }) {
        if (   ($what eq 'item' || $what eq 'over')
            && ($state eq 'over' || $state =~ /^(o|v)?list/xms))
        {

            # these are treated specially in _handle_item ()
            push @{ $parser->{'Pod::2::DocBook::state'} }, $state;
            last;
        }

        if ($state =~ /list\+$/xms) {
            print $out_fh $parser->_current_indent(), "\n";
            $state =~ s/\+$//xms;
        }

        if ($state =~ /^head(\d)/xms) {
            my $prev_level = $1;

            if ($level > $prev_level) {

                # embed in a previously opened section (i.e. restore
                # state and continue processing the document)

                # the enclosing section is no longer empty
                $state =~ s/\+$//xms;
                push @{ $parser->{'Pod::2::DocBook::state'} }, $state;
                last;
            }
            else {
                if ($state =~ /\+$/xms) {

                    # prevent empty sections
                    print $out_fh $parser->_current_indent(), "\n";
                }

                # close the previous section and continue with the stack
                if ($parser->{doctype} eq 'refentry') {
                    print $out_fh $parser->_outdent(), "\n";
                }
                else {
                    print $out_fh $parser->_outdent(), "\n";
                }
            }
        }
        elsif ($state eq 'indent') {
            print $out_fh $parser->_outdent(), "\n";

            push @{ $parser->{'Pod::2::DocBook::state'} }, 'over'
              if ($what eq 'item');

            last if $what eq 'back';
        }
        elsif ($state eq 'list') {
            print $out_fh join(q{},
                $parser->_outdent(), "\n",     $parser->_outdent(),
                "\n", $parser->_outdent(), "\n");

            last if $what eq 'back';
        }
        elsif ($state eq 'olist') {
            print $out_fh join(q{},
                $parser->_outdent(), "\n",     $parser->_outdent(),
                "\n",  $parser->_outdent(), "\n");

            last if $what eq 'back';
        }
        elsif ($state eq 'vlist') {
            print $out_fh join(q{},
                $parser->_outdent(), "\n",     $parser->_outdent(),
                "\n", $parser->_outdent(), "\n",
                $parser->_outdent(), "\n");

            last if $what eq 'back';
        }
        elsif ($state =~ /^synopsis/xms) {
            print $out_fh join(q{},
                $parser->_indent(),         "\n",
                $parser->_current_indent(), "\n")
              if $state eq 'synopsis+';

            print $out_fh $parser->_outdent(), "\n";
        }
        elsif ($state eq 'name') {
            print $out_fh join(q{},
                $parser->_indent(),         "\n",
                $parser->_indent(),         "\n",
                $parser->_current_indent(), "\n",
                $parser->_outdent(),        "\n");
        }
        elsif ($state eq 'verbatim') {
            print $out_fh "]]>\n";
        }
        elsif ($state =~ /^begin\s(.+)/xms) {
            my $begin_format = $1;
            if ($what =~ /^end\s(.+)/xms) {
                my $end_format = $1;

                if ($end_format eq $begin_format) {
                    if ($end_format eq 'docbook') {
                        my $paragraph =
                          join(q{}, @{ $parser->{'Pod::2::DocBook::dbpara'} });
                        $paragraph =~ s/\s+$//xms;
                        print $out_fh $paragraph, "\n";
                        $parser->{'Pod::2::DocBook::dbpara'} = [];
                    }

                    last;
                }
                else {

                    # this is bad POD, but we do what we can
                    # (maybe we'll find the begin we're looking for
                    #  deeper in the stack)
                    $parser->error_msg(
                        "`=end $end_format' found",
                        'but current region opened with',
                        "`=begin $begin_format'"
                    );
                }
            }
            elsif ($what eq 'THE END') {

                # this is bad POD, but we do what we can
                $parser->error_msg("no matching `=end' for",
                    "`=begin $begin_format'");

                # we've got the data stored; might as well use it
                if ($begin_format eq 'docbook') {
                    my $paragraph =
                      join(q{}, @{ $parser->{'Pod::2::DocBook::dbpara'} });
                    $paragraph =~ s/\s+$//xms;
                    print $out_fh $paragraph, "\n";
                    $parser->{'Pod::2::DocBook::dbpara'} = [];
                }
            }
            else {
                push @{ $parser->{'Pod::2::DocBook::state'} }, $state;
                last;
            }
        }
        elsif ($state eq 'over') {
            next;
        }
        else {
            $parser->error_msg("encountered unknown state `$state'",
                '(this should never happen)');
        }
    }

    return;
}

sub _handle_table {
    my ($parser, $paragraph, $line_num) = @_;
    my $out_fh = $parser->output_handle();
    my (@rows, $columns, $title);

    my $TABLE_ROW_TITLE      = 0;
    my $TABLE_ROW_ALIGNMENTS = 1;
    my $TABLE_ROW_HEADER     = 2;
    my $TABLE_FIRST_DATA_ROW = 3;

    foreach my $row (split(/\n/xms, $paragraph)) {
        my @fields = quotewords(',', 0, $row);

        $columns = @fields
          if (!defined $columns || @fields > $columns);
        push @rows, [@fields];
    }

    # the first row specifies the title
    $title = $rows[$TABLE_ROW_TITLE]->[0];

    print $out_fh join(q{},
        $parser->_indent(), "\n", $parser->_current_indent(), \n", $parser->_indent(), "\n"); 


\n"); \n"; \n",        $parser->_outdent(), 




1094




 





 





 





 





 





 



         "$title\n", $parser->_indent(), 




1095




 





 





 





 





 





 



         qq!\n!); 




1096




 





 





 





 





 





 



   




1097




 





 





 





 





 





 



     # the second row specifies column alignments 




1098




2





 





 





 





 





4



     foreach my $spec (@{ $rows[$TABLE_ROW_ALIGNMENTS] }) { 




 




2





 





 





 





 





3



   




1099




6





 





 





 





 





13



         print $out_fh $parser->_current_indent(), '




1100




 





 





 





 





 





 



   




1101




6




  
100
  




 




  
13
  




 





27



         if (any { $_ eq $spec } qw(left right center justify)) { 




 




13





 





 





 





 





25



   




1102




5





 





 





 





 





16



             print $out_fh qq!align="$spec">\n!; 




1103




 





 





 





 





 





 



         } 




1104




 





 





 





 





 





 



         else { 




1105




1





 





 





 





 





2



             print $out_fh qq!align="left">\n!; 




1106




1





 





 





 





 





11



             $parser->error_msg( 




1107




 





 





 





 





 





 



                 "unknown colspec `$spec' in table", 




1108




 





 





 





 





 





 



                 $title, "at line $line_num in file", 




1109




 





 





 





 





 





 



                 $parser->input_file() 




1110




 





 





 





 





 





 



             ); 




1111




 





 





 





 





 





 



         } 




1112




 





 





 





 





 





 



     } 




1113




 





 





 





 





 





 



   




1114




 





 





 





 





 





 



     # the third row (first row of data) is the table header 




1115




2





 





 





 





 





7



     print $out_fh 




1116




 





 





 





 





 





 



       join(q{}, $parser->_indent(), "

1117




 





 





 





 





 





 



   




1118




2





 





 





 





 





5



     foreach my $field (@{ $rows[$TABLE_ROW_HEADER] }) { 




 




2





 





 





 





 





4



   




1119




6





 





 





 





 





10



         print $out_fh $parser->_current_indent(), "$field\n"; 




1120




 





 





 





 





 





 



     } 




1121




 





 





 





 





 





 



   




1122




2





 





 





 





 





8



     print $out_fh join(q{}, 




1123




 





 





 





 





 





 



         $parser->_outdent(), "\n", $parser->_outdent(), "




1124




 





 





 





 





 





 



   




1125




 





 





 





 





 





 



     # the remaining rows are the table body 




1126




2





 





 





 





 





7



     print $out_fh $parser->_indent(), "




1127




 





 





 





 





 





 



   




1128




2





 





 





 





 





10



     foreach my $row (@rows[ $TABLE_FIRST_DATA_ROW .. $#rows ]) { 




1129




10





 





 





 





 





17



         print $out_fh $parser->_indent(), "\n"; 




1130




 





 





 





 





 





 



   




1131




10





 





 





 





 





12



         foreach my $field (@{$row}) { 




 




10





 





 





 





 





16



   




1132




30





 





 





 





 





50



             print $out_fh $parser->_current_indent(), "$field\n"; 




1133




 





 





 





 





 





 



         } 




1134




 





 





 





 





 





 



   




1135




10





 





 





 





 





22



         print $out_fh $parser->_outdent(), "\n"; 




1136




 





 





 





 





 





 



     } 




1137




 





 





 





 





 





 



   




1138




2





 





 





 





 





6



     print $out_fh join(q{}, 




1139




 





 





 





 





 





 



         $parser->_outdent(), "




1140




 





 





 





 





 





 



         "\n",       $parser->_outdent(), "\n");
        "$title\n", $parser->_indent(),
        qq!\n!);

    # the second row specifies column alignments
    foreach my $spec (@{ $rows[$TABLE_ROW_ALIGNMENTS] }) {
        print $out_fh $parser->_current_indent(), '

        if (any { $_ eq $spec } qw(left right center justify)) {
            print $out_fh qq!align="$spec">\n!;
        }
        else {
            print $out_fh qq!align="left">\n!;
            $parser->error_msg(
                "unknown colspec `$spec' in table",
                $title, "at line $line_num in file",
                $parser->input_file()
            );
        }
    }

    # the third row (first row of data) is the table header
    print $out_fh
      join(q{}, $parser->_indent(), "

    foreach my $field (@{ $rows[$TABLE_ROW_HEADER] }) {
        print $out_fh $parser->_current_indent(), "$field\n";
    }

    print $out_fh join(q{},
        $parser->_outdent(), "\n", $parser->_outdent(), "

    # the remaining rows are the table body
    print $out_fh $parser->_indent(), "

    foreach my $row (@rows[ $TABLE_FIRST_DATA_ROW .. $#rows ]) {
        print $out_fh $parser->_indent(), "\n";

        foreach my $field (@{$row}) {
            print $out_fh $parser->_current_indent(), "$field\n";
        }

        print $out_fh $parser->_outdent(), "\n";
    }

    print $out_fh join(q{},
        $parser->_outdent(), "
        "\n",       $parser->_outdent(), "

    return;
}

sub _manpage {
    my ($parser, $title, $volnum) = @_;

    # the substring "\37632\377" is a space character protected
    # against translation in S<>; other characters are protected at
    # the end of interior_sequence (), and all protected characters
    # are de-protected in _fix_chars ()

    my $manvol =
      $volnum
      ? "\37632\377" x $parser->{spaces} . "$volnum"
      : q{};

    return join "\n" => '',
      "\37632\377" x $parser->{spaces}
      . "$title",
      $manvol,
      '';
}

#----------------------------------------------------------------------
# helper functions
#----------------------------------------------------------------------

sub _fix_chars {
    my ($paragraph) = @_;

    # fix characters that might annoy an SGML parser
    $paragraph =~ s/&/&/gxms;
    $paragraph =~ s/
    $paragraph =~ s/>/>/gxms;

    # finally, de-protect any characters that were protected
    # from the previous step
    $paragraph =~ s!\376(\d+)\377!pack ('C', $1)!egxms;

    return $paragraph;
}

=head2 cleanup_id($id_string)

This function is used internally to remove/change any illegal characters
from the elements id string. (see http://www.w3.org/TR/2000/REC-xml-20001006#NT-Name
for the id string specification)

    $id_string =~ s//$1/g;   # keep just inside of CDATA
    $id_string =~ s/<.+?>//g;                     # remove tags
    $id_string =~ s/^\s*//;                       # ltrim spaces
    $id_string =~ s/\s*$//;                       # rtrim spaces
    $id_string =~ tr{/ }{._};                     # replace / with . and spaces with _
    $id_string =~ s/[^\-_a-zA-Z0-9\.: ]//g;       # closed set of characters allowed in id string

In the worst case when the C<$id_string> after clean up will not conform with
the specification, warning will be printed out and random number with leading colon
will be used.

=cut

sub cleanup_id {
    my $parser    = shift;
    my $id_string = shift;

    $id_string =~ s//$1/gxms;# keep just inside of CDATA
    $id_string =~ s/<.+?>//gxms;                  # remove tags
    $id_string =~ s/^\s*//xms;                    # ltrim spaces
    $id_string =~ s/\s*$//xms;                    # rtrim spaces
    $id_string =~ tr{/ }{._};                     # replace / with . and spaces with _
    $id_string =~ s/[^\-_a-zA-Z0-9\.:]//gxms;     # closed set of characters allowed in id string
    $id_string =~ s/^[^A-Za-z_:]+//xms;           # remove invalid leading characters
    $id_string =~ s/:/_/xmsg                      # remove : in ids version 2
        if $parser->{'id_version'} == 2;

    # check if the id string is valid (SEE http://www.w3.org/TR/2000/REC-xml-20001006#NT-Name)
    # TODO refactor to the function, we will need if also later and some tests will be handfull
    #      we should also "die" if the base_id is set through the command line parameter
    if ($id_string !~ m/^[A-Za-z_:] [-A-Za-z0-9_.:]*/xms) {
        $id_string = q{:}._big_random_number();
        warn 'wrong xml id string "', $id_string, '", throwing away and using ', $id_string, ' instead!', "\n";
    }

    return $id_string;
}

sub _big_random_number {
    ## no critic ValuesAndExpressions::ProhibitMagicNumbers
    return int(rand(9e10)+10e10);
    ## use critic
}

1;

__END__