view release on metacpan or  search on metacpan

examples/rfc/bin/rfc2xhtml.pl  view on Meta::CPAN

EOFOOT
    print $foot;
    $self->{state} = 'stop';
} # stop();

sub _abort {
    my ($self,$event,$line,$args) = @_;
    my @args = sort map { "$_($args->{$_})" } keys %$args;
    my $state = $self->{state};
    my $text = $args->{text} ? $args->{text} : $line;
    die join("\n  ","abort in state($state), event($event)"
        , "line($line)",@args)
} # _abort_event()

sub _begin_h2 {
    my ($self,$event,$line,$args) = @_;
    my $id = $args->{id} || '';

    $self->_catch_unfinished_paragraph();
    $self->{lasttext} = [];
    print qq(<h2><a id="section-$id">$line</a></h2>\n);
} # _begin_h2()

sub _begin_h3 {
    my ($self,$event,$line,$args) = @_;
    my $id = $args->{id} || '';

    $self->_catch_unfinished_paragraph();
    $self->{lasttext} = [];
    print qq(<h3><a id="section-$id">$line</a></h3>\n);
} # _begin_h3()

sub _begin_h4 {
    my ($self,$event,$line,$args) = @_;
    my $id = $args->{id} || '';

    $self->_catch_unfinished_paragraph();
    $self->{lasttext} = [];
    print qq(<h4><a id="section-$id">$line</a></h4>\n);
} # _begin_h4()

sub _begin_h5 {
    my ($self,$event,$line,$args) = @_;
    my $id = $args->{id} || '';

    $self->_catch_unfinished_paragraph();
    $self->{lasttext} = [];
    print qq(<h5><a id="section-$id">$line</a></h5>\n);
} # _begin_h5()

sub _begin_toc {
    my ($self,$event,$line,$args) = @_;
    $self->{lasttext} = [];
    print qq(<h2><a id="section-toc">$line</a></h2>\n<ul>\n);
} # _begin_toc()

sub _catch_unfinished_paragraph {
    my ($self) = @_;
    my $prevtext = $self->{prevtext};
    my $lasttext = $self->{lasttext};
    my @lines = map { _escape($_->{text}) } @$lasttext;

    if (0 < scalar @$prevtext) {        # we had an old unfinished paragraph
        if (_is_image(@lines)
            or _is_different_indent($prevtext,$lasttext)) {
            $self->{lasttext} = $prevtext;
            $self->{prevtext} = [];
            $self->{forceprint} = 1;
            $self->_print_paragraph();
            $self->{lasttext} = $lasttext;
            $self->{forceprint} = 0;
        }
        else {
            my @fullparagraph = ();
            push @fullparagraph, @$prevtext, @$lasttext;
            $self->{prevtext} = [];
            $self->{lasttext} = \@fullparagraph;
        }
    }
} # _catch_unfinished_paragraph()

sub _collect_text {
    my ($self,$event,$line,$args) = @_;
    push @{$self->{lasttext}}, $args;
    return;
} # _collect_text()

sub _end_toc_h2 {
    my ($self,$event,$line,$args) = @_;
    my $id = $args->{id} || '';
    $self->{lasttext} = [];
    print qq(</ul>\n<h2><a id="section-$id">$line</a></h2>\n);
} # _end_toc_h2()

sub _escape {
    my ($text) = @_;
    $text =~ s/</&lt;/g;
    return $text;
} # _escape()

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

    $self->{xmlns}  = "http://www.w3.org/1999/xhtml";
    $self->{indent} = 0;
    $self->{lasttext} = [];
    $self->{prevtext} = [];
    $self->{title}  = $args->{title} ? $args->{title}
                    : $self->{title} ? $self->{title}
                    :                  "You forgot to set a title"
                    ;
} # _init();

sub _is_different_indent {
    my ($par1,$par2) = @_;
    my @p1 = @$par1;
    my @p2 = @$par2;

    if (0 == scalar @p2) {
        return 1;
    }
    if (1 < scalar @p2
        and $p2[0]->{indent} != $p2[1]->{indent}) {
        return 1;
    }
    if ($p1[$#p1]->{indent} != $p2[0]->{indent}) {
        return 1;
    }
    return 0;
} # _is_different_indent()

sub _is_image {
    my @lines = @_;
    my $fl = grep { /(^[.]|[+|*]|-----|__)/ } @lines;
    my $table = grep { /___/ } @lines;
    my $is_image = (0 <= $#lines
                    and (0 < $fl
                         and ((length(@lines) + .0) / $fl < 2
                              or 0 < $table)));
    return $is_image;
} # _is_image()

sub _is_unfinished {
    my $unfinished = ((0 <= $#_)
                      and not _is_image(@_)
                      and ($_[$#_] !~ /[.:)\]]\s*$/));
    return $unfinished;
} # _is_unfinished()

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

    $self->_catch_unfinished_paragraph();
    my $lasttext = $self->{lasttext};
    my @lines = map { _escape($_->{text}) } @$lasttext;

    # Heuristic: If a single line ends without a dot, it probably won't be an
    #            unfinished paragraph.
    #
    if (not $self->{forceprint}
        and 1 < scalar @lines
        and _is_unfinished(@lines)) {
        $self->{prevtext} = $lasttext;
        $self->{lasttext} = [];
        $lasttext = [];
    }
    if (0 == scalar @$lasttext) {
        return;
    }
    if (_is_image(@lines)) {
        my $fig = "<pre>\n";
        foreach my $line (@$lasttext) {
            $fig .= " " x $line->{indent};
            $fig .= _escape($line->{text}) . "\n";
        }
        print $fig . "</pre>\n";
    }
    elsif (0 < $#lines
            and $lasttext->[0]->{indent} + 4 == $lasttext->[1]->{indent}) {
        my $first = shift @lines;
        my $class = 'term';
        my $fline = "<b>$first</b><br />";
        if ($lasttext->[0]->{text} =~ /^o   /) {
            $class = 'list';
            $fline = $first;
        }
        print join( "\n"
                  , qq(<p class="$class">)
                  , $fline
                  , @lines
                  , "</p>\n");
    }
    else {
        print join("\n", "<p>", @lines, "</p>\n");
    }
    $self->{lasttext} = [];
} # _print_paragraph()

sub _print_pre {
    my ($self) = @_;
    my @lines = map { $_->{text} } @{$self->{lasttext}};
    if (0 <= $#lines) {
        print join("\n", "<pre>", @lines, "</pre>\n");
    }
    $self->{lasttext} = [];
} # _print_pre()

sub _print_title {
    my ($self) = @_;
    my $lines = join("<br />\n", map { $_->{text} } @{$self->{lasttext}});
    $self->{lasttext} = [];
    print "<h1>$lines</h1>\n";
} # _print_title()

sub _print_tocline {
    my ($self,$event,$line,$args) = @_;
    my $id   = $args->{id};
    my $head = $args->{head};
    print qq(<li><a href="#section-$id">$id</a> $head</li>\n);
} # _print_tocline()

sub _print_toctext {
    my ($self,$event,$line,$args) = @_;
    if ($line =~ /\s*(Footnotes) \.\./
            or $line =~ /\s*(Security Considerations) \.\./
            or $line =~ /\s*(Author's Address) \.\./
            or $line =~ /\s*(Full Copyright Statement) \.\./
            or $line =~ /\s*(References) \.\./) {
        print qq(<li>$1</li>\n);
    }
    else {
        die "unknown toctext($line)";
    }
} # _print_toctext()