#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 14 January 2013
# Latest edit on: 16 July 2015
# https://github.com/trizen

# Perl source code highlighter.

use utf8;
use 5.018;
use strict;
use warnings;

use open IO => ':utf8', ':std';

#use lib qw(../lib);
use Perl::Tokenizer qw(perl_tokens);
use HTML::Entities qw(encode_entities);

my $header = <<'EOT';
<!DOCTYPE html>
<html xmlns="http://www.w3.org/1999/xhtml">
<head>
<title>pl2html</title>
<meta http-equiv="content-type" content="text/html; charset=utf-8" />
<style type="text/css">
/*<![CDATA[*/
<!--
/* default style sheet generated by pl2html */
pre { color: #000000;
      background: #FFFFFF;
      font-family: monospace;
    }

.dereference_operator  { color: #1800ff; }
.fat_comma             { color: #1800ff; }
.assignment_operator   { color: #1800ff; }
.comma                 { color: #1800ff; }
.operator              { color: #1800ff; }
.comment               { color: #676767; }
.number                { color: #ff0000; }
.binary_number         { color: #ff0000; }
.hex_number            { color: #ff0000; }
.v_string              { color: #ff0000; }
.heredoc_beg           { color: #CD5555; font-weight:bold; }
.heredoc               { color: #CD5555; font-style:italic; }
.keyword               { color: #317cd4; font-weight:bold; }
.file_test             { color: #317cd4; font-weight:bold; }
.special_keyword       { color: #317cd4; font-weight:bold; }
.bare_word             { color: #000000; }
.semicolon             { color: #000000; font-weight:bold; }
.sub_name              { color: #ff547c; font-weight:bold; }
.sub_proto             { color: #148f14; font-style:italic; }
.scalar_sigil          { color: #006f27; font-weight:bold; }
.array_sigil           { color: #006f27; font-weight:bold; }
.hash_sigil            { color: #006f27; font-weight:bold; }
.glob_sigil            { color: #006f27; font-weight:bold; }
.ampersand_sigil       { color: #006f27; font-weight:bold; }
.qq_string             { color: #1800ff; font-weight:bold; }
.q_string              { color: #1800ff; font-weight:bold; }
.double_quoted_string  { color: #1800ff; font-weight:bold; }
.single_quoted_string  { color: #1800ff; font-weight:bold; }
.match_regex           { color: #ff6136; font-weight:bold; }
.compiled_regex        { color: #296aef; font-weight:bold; }
.transliteration       { color: #c6b34d; font-weight:bold; }
.substitution          { color: #737400; font-weight:bold; }
.backtick              { color: #b91be0; font-weight:bold; }
.qx_string             { color: #b91be0; font-weight:bold; }
.var_name              { color: #006f27; font-weight:bold; }
.special_var_name      { color: #006f27; font-weight:bold; }
.pod                   { color: #228B22; font-style:italic; }
.qw_string             { color: #148f14; font-weight:bold; }
.glob_readline         { color: #e31620; font-weight:bold; }
.data                  { color: #747474; font-style:italic; }
.format                { color: #7283ff; font-style:italic; }

-->
/*]]>*/
</style>
</head>
<body>
<pre>
EOT

my $footer = <<'EOT';
</pre>
</body>
</html>
EOT

my $code = (
    do { local $/; <> }
      // die "usage: $0 [file]\n"
);

my %highlight_tokens;
@highlight_tokens{$header =~ /^\.(\w+)/mg} = ();

print $header;

perl_tokens {
    my ($token, $from, $to) = @_;

    my $substr = encode_entities(substr($code, $from, $to - $from));

    $substr =~ s{\R}{<br/>}g;

    if (exists $highlight_tokens{$token}) {
        print qq{<span class="$token">}, $substr, '</span>';
    }
    else {
        print $substr;
    }
} $code;

print $footer;

=encoding utf8

=head1 NAME

pl2html - highlights Perl code in HTML

=head1 SYNOPSIS

    pl2html < [script.pl] > [file.html]

=head1 DESCRIPTION

pl2html reads a Perl script and outputs an highlighted HTML version of it.

=head1 AUTHOR

Trizen, E<lt>trizen@cpan.orgE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2015

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.22.0 or,
at your option, any later version of Perl 5 you may have available.

=cut