POD Converter

DESCRIPTION

Uses Perl Formatter library to add syntax highlighting to the source sections.

SYNOPSIS

Perl

require( 'pod_converter.pl' );

# translate a module's pod to html
print pod_to_html( 'Module.pm' );

# cache the output
print pod_to_html( 'Module.pm', '/path/to/cache/' );

Perl-CGI

<?perl
App::require_pl( 'pod_converter.pl' );

# translate a module's pod to html
print pod_to_html( 'Module.pm', 'cache_path' );

# or source directly
print pod_to_html( $perl_source );
?>

EXAMPLES

COPYRIGHT

The library is free software. You may distribute and/or modify under the terms of the GNU General Public License.

SOURCE CODE

# *******************
# * file: pod_converter.pl
# * license: GPL or Artistic License
# * copyright: Christian Mueller
# ******************************************************

#use strict;
if( $PerlCGI::VERSION ) {
    App::require_pl( 'perl_formatter.pl' );
    App::require_pl( 'html_formatter.pl' );
    App::require_pl( 'cpp_formatter.pl' );
}
else {
    require( 'perl_formatter.pl' );
    require( 'html_formatter.pl' );
    require( 'cpp_formatter.pl' );
}

sub pod_to_html {
    my( $source, $path_cache, $url ) = @_;
    my(
        @fss, @fsc, $cache, @source, $count, $html, $lf, $pre, $out, %index,
        $ipos, %links, $pod, $formatter, $i, $line, $id, $list, $h, $indent,
        $name, $v, $str, $fh, $pkg
    );
    if( $PerlCGI::VERSION ) {
        if( App::file_exists( $source ) ) {
            if( $path_cache && ! App::file_exists( $path_cache ) ) {
                print "<p><b>Warning</b>: cache path does not exist</p>\n";
                undef $path_cache;
            }
            if( $path_cache ) {
                @fss = App::file_stat( $source );
                $cache = $source;
                $cache =~ s/\W/_/g;
                $cache = $path_cache . '/' . $cache . '.html';
                if( App::file_exists( $cache ) ) {
                    @fsc = App::file_stat( $cache );
                    return App::file_get( $cache ) if $fss[9] == $fsc[9];
                }
            }
            $source = App::file_get( $source );
        }
    }
    else {
        if( -e $source ) {
            if( $path_cache && ! -e $path_cache ) {
                print "Warning: cache path does not exist\n";
                undef $path_cache;
            }
            if( $path_cache ) {
                @fss = stat( $source );
                $cache = $source;
                $cache =~ s/\W/_/g;
                $cache = $path_cache . '/' . $cache . '.html';
                if( -e $cache ) {
                    @fsc = stat( $cache );
                    if( $fss[9] == $fsc[9] ) {
                        open $fh, "< $cache";
                        read $fh, $source, $fsc[7];
                        close $fh;
                        return $source;
                    }
                }
            }
            open $fh, "< $source";
            read $fh, $source, $fss[7];
            close $fh;
        }
    }
    $source =~ s/\r//gs;
    @source = split( "\n", $source );
    $count = @source;
    $ipos = $html = $lf = 0;
    $pre = $out = '';
    $pod = 0;
    $formatter = 'perl';
    for( $i = 0; $i < $count; $i ++ ) {
        $line = $source[$i];
        if( substr( $line, 0, 1 ) eq '=' ) {
            $pod = 1;
            if( $pre ) {
                if( $formatter eq 'perlcgi' ) {
                    $out .= "<pre>" . perl_format( $pre, 1, 1 ) . "</pre>\n";
                }
                elsif( $formatter eq 'perl' ) {
                    $out .= "<pre>" . perl_format( $pre, 1, 0 ) . "</pre>\n";
                }
                elsif( $formatter eq 'html' ) {
                    $out .= "<pre>" . html_format( $pre, 1 ) . "</pre>\n";
                }
                elsif( $formatter eq 'cpp' ) {
                    $out .= "<pre>" . cpp_format( $pre, 1 ) . "</pre>\n";
                }
                else {
                    $out .= "<pre>$pre</pre>\n";
                }
                $pre = '';
            }
            if( substr( $line, 1, 3 ) eq 'cut' ) {
                $pod = 0;
            }
            elsif( substr( $line, 1, 4 ) eq 'head' ) {
                $h = substr( $line, 5, 1 );
                $id = lc( $name = substr( $line, 7 ) );
                $id =~ s/\w<//go;
                $id =~ s/\W/_/g;
                $id =~ s/_+$//;
                $id =~ s/^_+//;
                $out .= "<h$h><a name='$id'>"
                    . pod_translate_html( $name ) . "</a></h$h>\n";
                $index{$id} = [ $ipos ++, $h, $id, $name ];
            }
            elsif( substr( $line, 1, 4 ) eq 'over' ) {
                $list = 'dl';
                $out .= "<dl>";
            }
            elsif( substr( $line, 1, 4 ) eq 'back' ) {
                if( $list eq 'ul' ) {
                    $out .= "</li></ul>\n";
                }
                elsif( $list eq 'ol' ) {
                    $out .= "</li></ol>\n";
                }
                else {
                    $out .= "</dd></dl>\n";
                }
                $list = '';
            }
            elsif( substr( $line, 1, 4 ) eq 'item' ) {
                while( $source[$i + 1] ne '' ) {
                    $line .= "\n" . $source[++ $i];
                }
                $v = substr( $line, 6 );
                if( substr( $v, 0, 1 ) eq '*' ) {
                    if( $list eq 'dl' ) {
                        $out .= "</dd></dl>\n<ul><li>\n";
                    }
                    elsif( $list eq 'ol' ) {
                        $out .= "</li></ol>\n<ul><li>\n";
                    }
                    else {
                        $out .= "</li><li>\n";
                    }
                    $list = 'ul';
                    $out .= pod_translate_html( substr( $v, 1 ) ) . "\n";
                }
                elsif( $v > 0 && $v =~ m/\s*(\d+)(.*)/ ) {
                    if( $list eq 'dl' ) {
                        $out .= "</dd></dl>\n<ol><li>\n";
                    }
                    elsif( $list eq 'ul' ) {
                        $out .= "</li></ul>\n<ol><li>\n";
                    }
                    else {
                        $out .= "</li><li>\n";
                    }
                    $list = 'ol';
                    $out .= pod_translate_html( $2 ) . "\n";
                }
                else {
                    if( $list eq 'ul' ) {
                        $out .= "</li></ul><dl>\n";
                    }
                    elsif( $list eq 'ol' ) {
                        $out .= "</li></ol><dl>\n";
                    }
                    else {
                        $out .= "</dd>\n";
                    }
                    $list = 'dl';
                    if( $v =~ m/([\w]*)[>\s]*\(/ ) {
                        $id = lc( $1 );
                    }
                    else {
                        $id = lc( $v );
                        $id =~ s/\w<//go;
                        $id =~ s/\W/_/go;
                        $id =~ s/_+$//;
                        $id =~ s/^_+//;
                    }
                    if( ! $links{$id} ) {
                        $links{$id} = 1;
                        $out .= "<dt><a name='$id'>"
                            . pod_translate_html( $v, 1 )
                            . "</a></dt>\n<dd>\n";
                    }
                    else {
                        $out .= "<dt>"
                            . pod_translate_html( $v, 1 )
                            . "</dt>\n<dd>\n";
                    }
                }
            }
            elsif( substr( $line, 1, 5 ) eq 'begin' ) {
                $html = substr( $line, 7 ) eq 'html';
            }
            elsif( substr( $line, 1, 3 ) eq 'end' ) {
                if( substr( $line, 5, 4 ) eq 'html' ) {
                    $html = 0;
                }
            }
            elsif( substr( $line, 1, 3 ) eq 'for' ) {
                if( substr( $line, 5, 4 ) eq 'html' ) {
                    $out .= substr( $line, 10 );
                    while( $source[$i + 1] != '' ) {
                        $out .= "\n" . $source[++ $i];
                    }
                }
                elsif( substr( $line, 5, 9 ) eq 'formatter' ) {
                    $formatter = substr( $line, 15 );
                }
            }
            $lf = 0;
        }
        elsif( $html ) {
            $out .= $line . "\n";
        }
        elsif( $pod ) {
            if( $line eq '' ) {
                if( ++ $lf == 1 ) {
                    if( $list ne 'ul' && $list ne 'ol' ) {
                        $out .= "<p> </p>\n";
                    }
                }
            }
            elsif( substr( $line, 0, 1 ) eq ' ' && ($pre || $lf) ) {
                $pre .= "$line\n";
                $lf = 0;
            }
            else {
                if( $pre ) {
                    if( $formatter eq 'perlcgi' ) {
                        $out .= "<pre>" .
                            perl_format( $pre, 1, 1 ) . "</pre>\n";
                    }
                    elsif( $formatter eq 'perl' ) {
                        $out .= "<pre>" .
                            perl_format( $pre, 1, 0 ) . "</pre>\n";
                    }
                    elsif( $formatter eq 'html' ) {
                        $out .= "<pre>" .
                            html_format( $pre, 1 ) . "</pre>\n";
                    }
                    elsif( $formatter eq 'cpp' ) {
                        $out .= "<pre>" .
                            cpp_format( $pre, 1 ) . "</pre>\n";
                    }
                    else {
                        $out .= "<pre>$pre</pre>\n";
                    }
                    $pre = '';
                }
                if( $lf ) {
                    while( $source[$i + 1] ne '' ) {
                        $line .= "\n" . $source[++ $i];
                    }
                    $out .= "<p> </p>\n"
                        . pod_translate_html( $line ) . "<p> </p>\n";
                }
                else {
                    $out .= pod_translate_html( $line ) . "\n";
                    $lf = 0;
                }
            }
        }
        else {
            # perl code
            if( index( $line, 'package' ) >= 0 ) {
                if( $line =~ m/^\s*package\s+([:\w]+);/ ) {
                    $pkg = $1;
                }
            }
        }
    }
    $out =~ s/C<<<([^>]*)>>>/pod_translate_code($1,\%links,\%index)/gse;
    $out =~ s/L<<<([^>]*)>>>/
            pod_translate_link($1,\%links,\%index,$pkg,$url)/gse;
    # create index
    $str = '';
    $indent = 0;
    foreach $h( sort { $a->[0] <=> $b->[0] } values %index ) {
        for( ; $indent > $h->[1]; $indent -- ) {
            $str .= "</ul>\n";
        }
        for( ; $indent < $h->[1]; $indent ++ ) {
            $str .= "<ul>\n";
        }
        $str .= '<li><a href="#' . $h->[2] . '">' .
            pod_translate_html( $h->[3], 1 ) . "</a></li>\n";
    }
    if( $h ) {
        for( ; $indent > 0; $indent -- ) {
            $str .= "</ul>\n";
        }
        $out = $str . '<hr size="1" style="color: #99bbee;" />' . $out;
    }
    # write to cache
    if( $cache ) {
        if( $PerlCGI::VERSION ) {
            App::file_put( $cache, $out );
            App::file_touch( $cache, $fss[9] );
        }
        else {
            open FH, "> $cache";
            print FH $out;
            close FH;
            utime $fss[9], $fss[9], $cache;
        }
    }
    return $out;
}

sub pod_translate_html {
    my( $str, $nolink ) = @_;
    $str =~ s/([\W])</$1&lt;/gs;
    $str =~ s/E<gt>/&gt;/gso;
    $str =~ s/E<lt>/&lt;/gso;
    $str =~ s/E<amp>/&amp;/gso;
    $str =~ s/E<sol>/\//gso;
    $str =~ s/E<verbar>/\|/gso;
    if( $nolink ) {
        $str =~ s/C<([^>]*)>/<code>$1<\/code>/gs;
        $str =~ s/L<([^>]*)>/<i>$1<\/i>/gs;
    }
    else {    
        $str =~ s/([CL])<([^>]*)>/$1<<<$2>>>/gs;
    }
    $str =~ s/B<([^>]*)>/<b>$1<\/b>/gs;
    $str =~ s/I<([^>]*)>/<i>$1<\/i>/gs;
    return $str;
}

sub pod_translate_code {
    my( $name, $links, $index ) = @_;
    my( $id );
    if( $name =~ m/([\w]*)[>\s]*\(/ ) {
        $id = lc( $1 );
    }
    else {
        $id = lc( $name );
        $id =~ s/\w<//go;
        $id =~ s/\W/_/go;
        $id =~ s/_+$//;
        $id =~ s/^_+//;
    }
    return "<a href='#$id'><code>$name</code></a>" if $links->{$id};
    return "<a href='#$id'><code>$name</code></a>" if $index->{$id};
    return "<code>$name</code>";
}

sub pod_translate_link {
    my( $lnk, $links, $index, $pkg, $search ) = @_;
    my( $text, $id, $p, $sec );
    if( ($p = index( $lnk, '|' )) >= 0 ) {
        $text = substr( $lnk, 0, $p );
        $lnk = substr( $lnk, $p + 1 );
    }
    if( ($p = index( $lnk, '/' )) >= 0 ) {
        if( index( $lnk, '::' ) < 0
            && index( $lnk, ':' ) >= 0
        ) {
            return "<a href='$lnk'>$lnk</a>";
        }
        $sec = substr( $lnk, $p + 1 );
        $lnk = substr( $lnk, 0, $p );
    }
    $text ||= $lnk;
    if( index( $lnk, '::' ) < 0 && index( $lnk, ':' ) >= 0 ) {
        return "<a href='$lnk'>$lnk</a>";
    }
    if( $sec ) {
        $sec = lc( $sec );
        $sec =~ s/\"(.+)\"/$1/;
        $sec =~ s/\W/_/go;
        $sec =~ s/_+$//;
        $sec =~ s/^_+//;
        if( ! $lnk || $lnk eq $pkg ) {
            return "<a href='#$sec'>$text</a>" if $links->{$sec};
            return "<a href='#$sec'>$text</a>" if $index->{$sec};
        }
    }
    if( $lnk =~ m/([\w]+)[>\s]*\(/ ) {
        $id = lc( $1 );
    }
    else {
        $id = lc( $lnk );
        $id =~ s/\w<//go;
        $id =~ s/\W/_/go;
        $id =~ s/_+$//;
        $id =~ s/^_+//;
    }
    return "<a href='#$id'>$text</a>" if $links->{$id};
    return "<a href='#$id'>$text</a>" if $index->{$id};
    if( $search ) {
        return "<a href='$search$lnk#$sec'>$text</a>" if $sec;
        return "<a href='$search$lnk'>$text</a>";
    }
    return "<i>$text</i>";
}

1;