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/</g; | |||||
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__ |