#!perl

#
# perl2html
# 2007 Markus Holzer
#
# script for convertin Perl-Sourcecode to Html with
# syntax-highlighting
#
# call with sourcefile as first parameter
# if the second parameter is true, output contains line numbers
#

# never leave home without it
use warnings;
use strict;

use Data::Dumper;

# we need this to escape special html chars
use HTML::Entities;

# performs the config parsing from the DATA-section
use Config::IniFiles;

my $cfg = Config::IniFiles->new( -file => *DATA );

unless ( $cfg )
{
    die join ("\n", @Config::IniFiles::errors) . "\n";
}

# performs the parsing of the sourcecode
use PPI;

# open the sourcefile
my $document = PPI::Document->new( $ARGV[0] );
#print Dumper ($document);

# see if we need to output line_numbers
my $line_number;
my $line_numbers;
my $line_number_format;

if ( $ARGV[1] )
{
    open IN, $ARGV[0] or die "cannot count line numbers\n";
    while (<IN>) { $line_numbers++ };
    close IN;
    
    $line_number_format = "%0".length($line_numbers)."d";
}

unless ( $document )
{
    die "Dokument could not be parsed\n";
}

# counter for skipping elements after a heredoc
my $skip_next;

# Routinen für die Behandlung der Spezialfälle
my %dispatch = 
(
    # ugly but necessary
    # when a heredoc is parsed the elemtens after <<"FOO"
    # and until the semicolon are siblings of the herdoc-element
    # for the output to be correct we have to preread those elements
    'Token::HereDoc' => sub
    {
        my ( $section, $node ) = @_;
    
        #<<"HERE"
        my $content    = $node->{content};
        
        # inner text of the heredoc
        my $text       = join "", @{$node->{_heredoc}};
        
        #HERE
        my $terminator = $node->{_terminator_line};
        chomp $terminator;
        
        my $skip = 0;
        
        print encode($content);

        # preread until we find the semicolon after <<"HERE"
        while ( 1 )
        {
            
            $skip++;
            
            $node = $node->next_sibling;
            process_node ($node,1);
            
            last 
                if $node->{content} eq ";"
        }
        
        print "<br />", encode("$text$terminator");
        
        $skip_next = $skip;
    }
);


print join ("\n", @{$cfg->{v}->{Html}->{header}}), "\n";

$line_number++,
print line_number($line_number)
    if $line_numbers;

process_node($document);

print "\n", join ("\n", @{$cfg->{v}->{Html}->{footer}});

sub process_node
{
    
    
    my $node = shift;
    my $self = shift;
    
    my @list;
    
    if ( $self )
    {
        @list = ($node);
    }
    else
    {
        @list = @{$node->{children}}
            if $node->{children};
    }
    
    for my $child ( @list )
    {
        if ( $skip_next )
        {
            $skip_next--;
            next;
        }

        # what have we got here?
        my $class = ref( $child );
        $class =~ s/^PPI:://;
        
        # opening element?
        if ( $child->{start} )
        {
            out( "brackets", $child, "start");
        }
        
        # do we have a special case for this element?
        if ( $dispatch{$class} )
        {
            # yes. use the dispatcher
            $dispatch{$class}->( $class, $child );
        }
        else
        {
            # no, so standard ouptput
            out ( $class, $child );
        }
        
        # process the children
        process_node( $child );
        
        # closing element?
        if ( $child->{finish} )
        {
            out( "brackets", $child, "finish");
        }
    }
}

# Outputs an element as Html aus und formats it
# using the styles from the configuration
sub out
{
    my ( $section, $node, $index ) = @_;
    
    my $content;

    # Index is true for opening and closing elements
    # so we can use the correct bracket
    # otherwise we use the elements text value
    if ( $index )
    {
        $content  = $node->{$index}->{content} || "";
    }
    else
    {
        # Text des Elements ausgeben
        $content  = $node->{content} || "";
    }
    
    $content = encode($content);

    # is there a style for this element?
    if ( $cfg->{v}->{$section} )
    {
        my $class = $cfg->{v}->{$section}->{ $content   } || 
                    $cfg->{v}->{$section}->{ '*default' } ||
                    "";
        
        print "<span style=\"$class\">$content</span>";
    }
    else
    {
        print $content;
        
    }
}

# encodes html entities and converts whitespace
sub encode
{
    my $content = encode_entities(shift);
    
    $content =~ s^ ^&nbsp;^msg;
    
    if ( $line_numbers )
    {
        while ( $content =~ /\n/ )
        {
            $line_number++;
            
            my $ln = line_number($line_number);
            $content =~ s^\n^<br />$ln^ms;
        }
    }
    else
    {
        $content =~ s^\n^<br />^msg;
    }

    $content =~ s^\t^&nbsp;&nbsp;&nbsp;&nbsp;^msg;
    
    return $content;
}

sub line_number
{
    my $ln = sprintf($line_number_format, shift);
    return '<span style="' . $cfg->{v}->{LineNumber}->{'*default'} . "
+\">$ln: &nbsp;</span>";
}

__DATA__
[brackets]
*default         = color:teal;

[Token::Symbol]
*default         = color:maroon;

[Token::ArrayIndex]
*default         = color:maroon;

[Token::Cast]
*default         = color:maroon;

[Token::Magic]
*default         = color:maroon;

[Token::Quote::Double]
*default         = color:purple;

[Token::Quote::Interpolate]
*default         = color:purple;

[Token::Quote::Literal]
*default         = color:purple;

[Token::Quote::Single]
*default         = color:purple;

[Token::QuoteLike]
*default         = color:purple;

[Token::QuoteLike::Backtick]
*default         = color:purple;

[Token::QuoteLike::Command]
*default         = color:purple;

[Token::QuoteLike::Readline]
*default         = color:purple;

[Token::QuoteLike::Regexp]
*default         = color:purple;

[Token::QuoteLike::Words]
*default         = color:purple;

[Token::DashedWord]
*default         = color:purple;

[Token::HereDoc]
*default         = color:purple;

[Token::Data]
*default         = color:purple;

[Token::Separator]
*default         = color:purple;

[Token::End]
*default         = color:purple;

[Token::Number]
*default          = color:purple;

[Token::Structure]
*default          = color:black;

[Token::Operator]
*default         = color:lime;
and              = color:lime;
cmp              = color:lime;
eq               = color:lime;
le               = color:lime;
ge               = color:lime;
ne               = color:lime;
or               = color:lime;
q                = color:lime;
qq               = color:lime;
qw               = color:lime;
qx               = color:lime;
tr               = color:lime;
xor              = color:lime;

[Token::Word]
*default         = color:black;

AUTOLOAD         = color:yellow;
BEGIN            = color:yellow;
CORE             = color:yellow;
DESTROY          = color:yellow;
END              = color:yellow;

STDERR           = color:gray;
STDIN            = color:gray;
STDOUT           = color:gray;

local            = color:blue;
my               = color:blue;
package          = color:blue;
return           = color:blue;
sub              = color:blue;
use              = color:blue;
require          = color:blue;
do               = color:blue;
else             = color:blue;
elsif            = color:blue;
foreach          = color:blue;
for              = color:blue;
if               = color:blue;
unless           = color:blue;
until            = color:blue;
continue         = color:blue;
while            = color:blue;
goto             = color:blue;
import           = color:blue;
last             = color:blue;
next             = color:blue;
no               = color:blue;
our              = color:blue;
redo             = color:blue;


bless            = color:red;
close            = color:red;
closedir         = color:red;
die              = color:red;
eval             = color:red;
exit             = color:red;
grep             = color:red;
map              = color:red;
open             = color:red;
opendir          = color:red;
print            = color:red;
splice           = color:red;
split            = color:red;
sysopen          = color:red;
warn             = color:red;
each             = color:red;
values           = color:red;
accept           = color:red;
alarm            = color:red;
atan2            = color:red;
bind             = color:red;
binmode          = color:red;
caller           = color:red;
chdir            = color:red;
chmod            = color:red;
chomp            = color:red;
chop             = color:red;
chown            = color:red;
chr              = color:red;
chroot           = color:red;
abs              = color:red;
connect          = color:red;
cos              = color:red;
crypt            = color:red;
dbmclose         = color:red;
dbmopen          = color:red;
defined          = color:red;
delete           = color:red;
dump             = color:red;
endgrent         = color:red;
endhostent       = color:red;
endnetent        = color:red;
endpwent         = color:red;
endservent       = color:red;
eof              = color:red;
exec             = color:red;
exists           = color:red;
exp              = color:red;
fcntl            = color:red;
fileno           = color:red;
flock            = color:red;
fork             = color:red;
format           = color:red;
formline         = color:red;
getc             = color:red;
getgrent         = color:red;
getgrgid         = color:red;
getgrnam         = color:red;
gethostbyaddr    = color:red;
gethostbyname    = color:red;
gethostent       = color:red;
getlogin         = color:red;
getnetbyaddr     = color:red;
getnetbyname     = color:red;
getnetent        = color:red;
getpeername      = color:red;
getpgrp          = color:red;
getppid          = color:red;
getpriority      = color:red;
getprotobyname   = color:red;
getprotobynumber = color:red;
getprotoent      = color:red;
getpwent         = color:red;
getpwnam         = color:red;
getpwuid         = color:red;
getservbyname    = color:red;
getservbyport    = color:red;
getservent       = color:red;
getsockname      = color:red;
getsockopt       = color:red;
glob             = color:red;
gmtime           = color:red;
hex              = color:red;
index            = color:red;
int              = color:red;
ioctl            = color:red;
join             = color:red;
keys             = color:red;
kill             = color:red;
lc               = color:red;
lcfirst          = color:red;
length           = color:red;
link             = color:red;
listen           = color:red;
localtime        = color:red;
log              = color:red;
lstat            = color:red;
mkdir            = color:red;
msgctl           = color:red;
msgget           = color:red;
msgrcv           = color:red;
msgsnd           = color:red;
new              = color:red;
oct              = color:red;
ord              = color:red;
pack             = color:red;
pipe             = color:red;
pop              = color:red;
pos              = color:red;
quotemeta        = color:red;
read             = color:red;
readdir          = color:red;
readline         = color:red;
readlink         = color:red;
readpipe         = color:red;
recv             = color:red;
ref              = color:red;
rename           = color:red;
reset            = color:red;
reverse          = color:red;
rewinddir        = color:red;
rindex           = color:red;
rmdir            = color:red;
scalar           = color:red;
seek             = color:red;
seekdir          = color:red;
select           = color:red;
semctl           = color:red;
semget           = color:red;
semop            = color:red;
send             = color:red;
setgrent         = color:red;
sethostent       = color:red;
setnetent        = color:red;
setpgrp          = color:red;
setpriority      = color:red;
setprotoent      = color:red;
setpwent         = color:red;
setservent       = color:red;
setsockopt       = color:red;
shmctl           = color:red;
shmget           = color:red;
shmread          = color:red;
shmwrite         = color:red;
shutdown         = color:red;
sin              = color:red;
sleep            = color:red;
socket           = color:red;
socketpair       = color:red;
sort             = color:red;
sprintf          = color:red;
printf           = color:red;
sqrt             = color:red;
srand            = color:red;
rand             = color:red;
stat             = color:red;
shift            = color:red;
study            = color:red;
substr           = color:red;
symlink          = color:red;
syscall          = color:red;
sysread          = color:red;
system           = color:red;
syswrite         = color:red;
tell             = color:red;
telldir          = color:red;
time             = color:red;
times            = color:red;
truncate         = color:red;
uc               = color:red;
ucfirst          = color:red;
umask            = color:red;
undef            = color:red;
unlink           = color:red;
unpack           = color:red;
unshift          = color:red;
untie            = color:red;
utime            = color:red;
vec              = color:red;
wait             = color:red;
waitpid          = color:red;
wantarray        = color:red;
write            = color:red;

[Token::Attribute]
*default         = color:black;

[Token::Comment]
*default          = color:green;

[Token::Label]
*default         = color:black;

[Token::Pod]
*default          = color:silver;

[Token::Prototype]
*default         = color:navy;

[Token::Regexp::Match]
*default          = color:olive;

[Token::Regexp::Substitute]
*default          = color:olive;

[Token::Regexp::Transliterate]
*default          = color:olive;

[LineNumber]
*default          = color:olive;


[Html]
header=<<HEADER
<html>
<head></head>
<body>
<div style="font-family:Courier;">
HEADER

footer=<<FOOTER
</div></body></html>
FOOTER
[download]