File Coverage

blib/lib/Template/Plugin/HighlightPerl.pm

Criterion	Covered	Total	%
statement	12	87	13.7
branch	0	18	0.0
condition	0	5	0.0
subroutine	4	10	40.0
pod	0	6	0.0
total	16	126	12.7

#============================================================= -*-Perl-*-
#
# Template::Plugin::HighlightPerl
#
# DESCRIPTION
#   Template Toolkit Filter For Syntax Highlighting
#
# AUTHOR
#   Stephen Sykes
#   http://www.stephensykes.us
#
# COPYRIGHT
#   Copyright (C) 2008 Stephen Sykes.  All Rights Reserved.
#
#   This module is free software; you can redistribute it and/or
#   modify it under the same terms as Perl itself.
#
#============================================================================

package Template::Plugin::HighlightPerl;

use Syntax::Highlight::Perl;
use Template::Plugin::Filter;
use base qw( Template::Plugin::Filter );
use strict;

our $VERSION = '0.04';

sub init {
    my $self = shift;
    my $name = $self->{ _CONFIG }->{ name } || 'highlight_perl';
    $self->install_filter($name);
    return $self;
}

sub filter {
    my ($self, $text) = @_;

    if (($text !~ '\[perl]') && ($text !~ '\[code]') && ($text !~ '\[nobr]')) {
        $text = break($text);
    } else {
        if ($text =~ '\[perl]') {
            $text = perl($text);
        }
        if ($text =~ '\[code]') {
            $text = code($text);
        }
        if ($text =~ '\[nobr]') {
            $text = nobreak($text);
        }
    }
    return $text;

}

sub perl {
    my $text = shift;

    $text =~ s///g;

    my $color_table = {
        'Variable_Scalar'   => 'color:#FFFFFF;',
        'Variable_Array'    => 'color:#FFFFFF;',
        'Variable_Hash'     => 'color:#FFFFFF;',
        'Variable_Typeglob' => 'color:#f03;',
        'Subroutine'        => 'color:#FFFFFF;',
        'Quote'             => 'color:#DEDE73;',
        'String'            => 'color:#DEDE73;',
        'Comment_Normal'    => 'color:#ACAEAC;font-style:italic;',
        'Comment_POD'       => 'color:#ACAEAC;font-family:' .
                                   'garamond,serif;font-size:11pt;',
        'Bareword'          => 'color:#FFFFFF;',
        'Package'           => 'color:#FFFFFF;',
        'Number'            => 'color:#4AAEAC;',
        'Operator'          => 'color:#7BE283;',
        'Symbol'            => 'color:#7BE283;',
        'Keyword'           => 'color:#7BE283;',
        'Builtin_Operator'  => 'color:#7BE283;',
        'Builtin_Function'  => 'color:#7BE283;',
        'Character'         => 'color:#DEDE73;',
        'Directive'         => 'color:#ACAEAC;font-style:italic;',
        'Label'             => 'color:#939;font-style:italic;',
        'Line'              => 'color:#000;',
        'Print'             => 'color:#7BE283;',
        'Hash'              => 'color:#FFFFFF;',
        'Translation_Operation'           => 'color=#3199FF;',
    };

    my $formatter = Syntax::Highlight::Perl->new();

    $formatter->define_substitution('<' => '<',
                                    '>' => '>',
                                    '&' => '&'); # HTML escapes.

    # install the formats set up above
    while ( my ( $type, $style ) = each %{$color_table} ) {
        $formatter->set_format($type, [ qq||,
                                        '' ] );
    }

    my @code = split(/\[perl]/, $text);
    for my $rec (@code) {
        my $format_code;

        if ($rec =~ '\[/perl]') {
            my @code_rec = split(/\[\/perl]/, $rec);
            my $count = 0;
            for my $ret (@code_rec) {
                $count++;
                if ($count % 2 == 1) {
                    my $formatter_code  = $formatter->format_string($ret);
                    my $line_count = 0;
                    my @line_ar = split(/\n/, $formatter_code);
                    for my $line ( @line_ar ) {
                        $line_count++;
                        if ($line_count == 1) {
                            $formatter_code = $line;
                        } else {
                            $formatter_code .= $line;
                        }
                    }
                    $format_code  = 'Perl Code:';
                    $format_code .= '' .$formatter_code. '';
                } else {
                    $ret =~ s/\n//g;
                    $format_code = $ret;
                }
                $text .= $format_code;
           }

        } else {
            $rec =~ s/\n//g;
            $text = $rec;
        }
    }
    return $text;

}

sub code {
    my $text = shift;

    $text =~ s//\n/g;

    my @code = split(/\[code]/, $text);
    for my $rec (@code) {
        my $format_code;
        if ($rec =~ '\[/code]') {
            my @code_rec = split(/\[\/code]/, $rec);
            my $count = 0;
            for my $ret (@code_rec) {
                $count++;
                if ($count % 2 == 1) {
                    $ret =~ s/
                    $ret =~ s/>/>/g;
                    $format_code  = 'Code:';
                    $format_code .= '' .$ret. '';
                } else {
                    $ret =~ s/\n//g;
                    $format_code = $ret;
                }
                $text .= $format_code;
           }
        } else {
            $rec =~ s/\n//g;
            $text = $rec;
        }
    }
    return $text;

}

sub nobreak {
    my $text = shift;
    $text =~ s/\[nobr\]//g;
    $text =~ s/\[\/nobr\]//g;
    return $text;
}

sub break {
    my $text = shift;
    $text =~ s/\n//g;
    return $text;
}

1;

__END__