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


line stmt bran cond sub pod time code
1             #============================================================= -*-Perl-*-
2             #
3             # Template::Plugin::HighlightPerl
4             #
5             # DESCRIPTION
6             # Template Toolkit Filter For Syntax Highlighting
7             #
8             # AUTHOR
9             # Stephen Sykes
10             # http://www.stephensykes.us
11             #
12             # COPYRIGHT
13             # Copyright (C) 2008 Stephen Sykes. All Rights Reserved.
14             #
15             # This module is free software; you can redistribute it and/or
16             # modify it under the same terms as Perl itself.
17             #
18             #============================================================================
19              
20             package Template::Plugin::HighlightPerl;
21              
22 1     1   26886 use Syntax::Highlight::Perl;
  1         41431  
  1         101  
23 1     1   2380 use Template::Plugin::Filter;
  1         10121  
  1         34  
24 1     1   9 use base qw( Template::Plugin::Filter );
  1         7  
  1         80  
25 1     1   6 use strict;
  1         2  
  1         1167  
26              
27             our $VERSION = '0.04';
28              
29             sub init {
30 0     0 0   my $self = shift;
31 0   0       my $name = $self->{ _CONFIG }->{ name } || 'highlight_perl';
32 0           $self->install_filter($name);
33 0           return $self;
34             }
35              
36             sub filter {
37 0     0 0   my ($self, $text) = @_;
38            
39 0 0 0       if (($text !~ '\[perl]') && ($text !~ '\[code]') && ($text !~ '\[nobr]')) {
40 0           $text = break($text);
41             } else {
42 0 0         if ($text =~ '\[perl]') {
43 0           $text = perl($text);
44             }
45 0 0         if ($text =~ '\[code]') {
46 0           $text = code($text);
47             }
48 0 0         if ($text =~ '\[nobr]') {
49 0           $text = nobreak($text);
50             }
51             }
52 0           return $text;
53            
54             }
55              
56             sub perl {
57 0     0 0   my $text = shift;
58            
59 0           $text =~ s/
//g;
60            
61 0           my $color_table = {
62             'Variable_Scalar' => 'color:#FFFFFF;',
63             'Variable_Array' => 'color:#FFFFFF;',
64             'Variable_Hash' => 'color:#FFFFFF;',
65             'Variable_Typeglob' => 'color:#f03;',
66             'Subroutine' => 'color:#FFFFFF;',
67             'Quote' => 'color:#DEDE73;',
68             'String' => 'color:#DEDE73;',
69             'Comment_Normal' => 'color:#ACAEAC;font-style:italic;',
70             'Comment_POD' => 'color:#ACAEAC;font-family:' .
71             'garamond,serif;font-size:11pt;',
72             'Bareword' => 'color:#FFFFFF;',
73             'Package' => 'color:#FFFFFF;',
74             'Number' => 'color:#4AAEAC;',
75             'Operator' => 'color:#7BE283;',
76             'Symbol' => 'color:#7BE283;',
77             'Keyword' => 'color:#7BE283;',
78             'Builtin_Operator' => 'color:#7BE283;',
79             'Builtin_Function' => 'color:#7BE283;',
80             'Character' => 'color:#DEDE73;',
81             'Directive' => 'color:#ACAEAC;font-style:italic;',
82             'Label' => 'color:#939;font-style:italic;',
83             'Line' => 'color:#000;',
84             'Print' => 'color:#7BE283;',
85             'Hash' => 'color:#FFFFFF;',
86             'Translation_Operation' => 'color=#3199FF;',
87             };
88            
89 0           my $formatter = Syntax::Highlight::Perl->new();
90            
91 0           $formatter->define_substitution('<' => '<',
92             '>' => '>',
93             '&' => '&'); # HTML escapes.
94            
95             # install the formats set up above
96 0           while ( my ( $type, $style ) = each %{$color_table} ) {
  0            
97 0           $formatter->set_format($type, [ qq||,
98             '' ] );
99             }
100              
101 0           my @code = split(/\[perl]/, $text);
102 0           for my $rec (@code) {
103 0           my $format_code;
104            
105 0 0         if ($rec =~ '\[/perl]') {
106 0           my @code_rec = split(/\[\/perl]/, $rec);
107 0           my $count = 0;
108 0           for my $ret (@code_rec) {
109 0           $count++;
110 0 0         if ($count % 2 == 1) {
111 0           my $formatter_code = $formatter->format_string($ret);
112 0           my $line_count = 0;
113 0           my @line_ar = split(/\n/, $formatter_code);
114 0           for my $line ( @line_ar ) {
115 0           $line_count++;
116 0 0         if ($line_count == 1) {
117 0           $formatter_code = $line;
118             } else {
119 0           $formatter_code .= $line;
120             }
121             }
122 0           $format_code = '
Perl Code:
';
123 0           $format_code .= '
' .$formatter_code. '
';
124             } else {
125 0           $ret =~ s/\n/
/g;
126 0           $format_code = $ret;
127             }
128 0           $text .= $format_code;
129             }
130            
131             } else {
132 0           $rec =~ s/\n/
/g;
133 0           $text = $rec;
134             }
135             }
136 0           return $text;
137            
138             }
139              
140             sub code {
141 0     0 0   my $text = shift;
142            
143 0           $text =~ s/
/\n/g;
144            
145 0           my @code = split(/\[code]/, $text);
146 0           for my $rec (@code) {
147 0           my $format_code;
148 0 0         if ($rec =~ '\[/code]') {
149 0           my @code_rec = split(/\[\/code]/, $rec);
150 0           my $count = 0;
151 0           for my $ret (@code_rec) {
152 0           $count++;
153 0 0         if ($count % 2 == 1) {
154 0           $ret =~ s/
155 0           $ret =~ s/>/>/g;
156 0           $format_code = '
Code:
';
157 0           $format_code .= '
' .$ret. '
';
158             } else {
159 0           $ret =~ s/\n/
/g;
160 0           $format_code = $ret;
161             }
162 0           $text .= $format_code;
163             }
164             } else {
165 0           $rec =~ s/\n/
/g;
166 0           $text = $rec;
167             }
168             }
169 0           return $text;
170            
171             }
172              
173             sub nobreak {
174 0     0 0   my $text = shift;
175 0           $text =~ s/\[nobr\]//g;
176 0           $text =~ s/\[\/nobr\]//g;
177 0           return $text;
178             }
179              
180             sub break {
181 0     0 0   my $text = shift;
182 0           $text =~ s/\n/
/g;
183 0           return $text;
184             }
185              
186             1;
187              
188             __END__