File Coverage

blib/lib/HTML/SyntaxHighlighter.pm
Criterion Covered Total %
statement 156 221 70.5
branch 47 102 46.0
condition 58 192 30.2
subroutine 30 35 85.7
pod 15 27 55.5
total 306 577 53.0


line stmt bran cond sub pod time code
1             package HTML::SyntaxHighlighter;
2              
3 1     1   96564 use strict;
  1         2  
  1         212  
4 1     1   6 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
  1         3  
  1         83  
5              
6 1     1   5 use Carp ();
  1         14  
  1         17  
7 1     1   1224 use HTML::Entities;
  1         34357  
  1         105  
8 1     1   13 use HTML::Parser;
  1         2  
  1         14292  
9              
10             require Exporter;
11              
12             @ISA = qw(HTML::Parser Exporter);
13             # Items to export into callers namespace by default. Note: do not export
14             # names by default without a very good reason. Use EXPORT_OK instead.
15             # Do not simply export all your public functions/methods/constants.
16             @EXPORT_OK = qw(
17             );
18              
19             $VERSION = '0.03';
20              
21             my %default_args = (
22             out_func => \*STDOUT,
23             header => 1,
24             default_type => 'html',
25             force_type => 0,
26             debug => 0,
27             br => '
',
28             collapse_inline => 0,
29             indent_level => 2
30             );
31              
32             # Preloaded methods go here.
33              
34             sub new {
35 1     1 1 565 my $class = shift;
36 1         4 my %args = @_;
37 1         3 my $self = bless {}, $class;
38              
39 1         8 $self->init(%args);
40 1         5 return $self;
41             }
42              
43             sub init {
44 1     1 0 2 my $self = shift;
45 1         3 my %args = @_;
46              
47 1         6 foreach ( keys %default_args ) {
48 8 50       38 $self->$_( exists( $args{$_} ) ? delete $args{$_} : $default_args{$_} );
49             }
50              
51 1         12 $self->SUPER::init(%args);
52 1         90 $self->unbroken_text( 1 );
53              
54 1         4 $self->handler(comment => 'comment', 'self, text');
55 1         11 $self->handler(declaration => 'declaration', 'self, tokens');
56 1         7 $self->handler(start_document => 'start_document', 'self');
57 1         5 $self->handler(end_document => 'end_document', 'self');
58             }
59              
60             # SETTINGS
61              
62             sub debug {
63 2     2 1 5 my ($self, $debug ) = @_;
64 2         10 $self->{debug} = $debug;
65             }
66              
67             sub out_func {
68 3     3 1 7 my ($self, $output) = @_;
69 3         7 my $ref = ref( $output );
70 3 50       20 if( $ref eq 'CODE' ) {
    100          
    50          
71 0     0   0 $self->{out_func} = sub { $output->( "@_\n" ) };
  0         0  
72             } elsif ( $ref eq 'GLOB' ) {
73 2     53   33 $self->{out_func} = sub { print $output "@_\n" };
  53         12786  
74             } elsif ( $ref eq 'SCALAR' ) {
75 1     27   12 $self->{out_func} = sub { $$output .= "@_\n" };
  27         547  
76             } else {
77 0         0 Carp::croak( "Output argument ot type '$ref' not supported" );
78             }
79             }
80              
81             sub header {
82 2     2 1 8 my ($self, $header ) = @_;
83 2         8 $self->{header} = $header;
84             }
85              
86             sub default_type {
87 1     1 1 2 my ($self, $type ) = @_;
88 1 50 33     5 unless ( ($type eq 'html') ||
89             ($type eq 'xhtml') ) {
90 0         0 Carp::croak( "Type '$type' not supported" );
91             }
92 1         5 $self->{default_type} = $type;
93             }
94              
95             sub force_type {
96 2     2 1 5 my ($self, $force ) = @_;
97 2         8 $self->{force_type} = $force;
98             }
99              
100             sub type {
101 5     5 0 14 my ($self, $type ) = @_;
102 5 50 66     31 unless ( ($type eq 'html') ||
103             ($type eq 'xhtml') ) {
104 0         0 Carp::croak( "Type '$type' not supported" );
105             }
106              
107 5         34 $self->{type} = $type;
108             }
109              
110             sub br {
111 2     2 1 4 my ($self, $br ) = @_;
112 2         10 $self->{br} = $br;
113             }
114              
115             sub collapse_inline {
116 1     1 1 2 my ($self, $collapse_inline ) = @_;
117 1         3 $self->{collapse_inline} = $collapse_inline;
118             }
119              
120             sub indent_level {
121 1     1 0 2 my ($self, $indent_level ) = @_;
122 1         3 $self->{indent_level} = $indent_level;
123             }
124              
125             # HANDLERS
126              
127             sub start_document {
128 3     3 1 427 my $self = shift;
129              
130             # reset html tag stack
131 3         12 $self->{stack} = [];
132              
133             # set type to default in case we don't encounter a DTD
134 3         15 $self->type( $self->{default_type} );
135              
136             # header on: turn off output initially
137 3 50       14 $self->{silent} = $self->{header} ? 0 : 1;
138 3         5 $self->{threshold} = 0;
139 3         6 $self->{past_first_line} = 0;
140              
141 3         9 $self->{out_func}->( '' );
142             }
143              
144             sub end_document {
145 3     3 1 163 my $self = shift;
146              
147 3         11 $self->{out_func}->( '' );
148             }
149              
150             sub start {
151 24     24 1 52 my ($self, $tagname, $attr, $attrseq) = @_;
152 24         54 my $indent = $self->mk_indent();
153 24         32 my ($output, $error);
154              
155 24         1914 my $type = sel_type($tagname);
156 24 50 66     2751 if( exists( $attr->{'/'} ) ) {
    50 33        
      33        
      33        
      33        
      33        
      33        
      33        
      33        
      33        
157             # standalone xhtml tag, e.g. '
'
158             } elsif( ($self->{type} eq 'html') &&
159             ($tagname eq 'br') ||
160             ($tagname eq 'hr') ||
161             ($tagname eq 'img') ||
162             ($tagname eq 'input') ||
163             ($tagname eq 'link') ||
164             ($tagname eq 'meta') ||
165             ($tagname eq 'area') ||
166             ($tagname eq 'col') ||
167             ($tagname eq 'base') ||
168             ($tagname eq 'param') ) {
169             # allowable standalone tag in html
170             } else {
171             # check for commonly unclosed tags
172 24 50 66     569 if( ($tagname eq 'p') ||
      66        
      33        
      33        
      33        
173             ($tagname eq 'select') ||
174             ($tagname eq 'li') ||
175             ($tagname eq 'td') ||
176             ($tagname eq 'th') ||
177             ($tagname eq 'tr') ) {
178 3         8 my $close = $self->{stack}->[-1];
179 3 50       8 if( $close eq $tagname ) {
180             # tag is same as the one above, and can't be
181             # assume missing closed tag, go up a level
182             # unless it looks like we have a missing open tag too (ugh!)
183 0 0       0 if( $close ne $self->{last_block} ) {
184 0         0 pop @{$self->{stack}};
  0         0  
185 0         0 $indent = $self->mk_indent();
186 0 0       0 if( $self->{debug} ) {
187 0         0 $output = gen_tag('X', "/$close", undef, undef, { error => "Missing closing '$close' tag" } );
188 0         0 $self->output( $indent, "$output" );
189             }
190             }
191             }
192             }
193             # one level deeper
194 24         38 push @{$self->{stack}}, $tagname;
  24         75  
195             }
196              
197 24 50 66     90 if( ($type eq 'B') && !$self->block_allowed ) {
198 0         0 $error = "Block-level element '$tagname' within illegal inline element '$self->{stack}->[-1]'";
199 0         0 $type = 'X';
200             }
201              
202 24 50 33     708 $output = gen_tag($type, $tagname, $attr, $attrseq,
203             ($error && $self->{debug}) ? { error => $error } : ()
204             );
205              
206 24 50       66 if( $self->{collapse_inline} ) {
207 0 0 0     0 if( ($type ne 'I') or is_element($tagname) or is_row($tagname) or $self->in_head() ) {
      0        
      0        
208 0         0 $self->{no_indent} = 0;
209             }
210             }
211              
212             # header off: no line break before first line of body
213 24         33 my $nobr;
214 24 50 33     82 if( !$self->{header} && !$self->{past_first_line} && ($self->{stack}->[-2] eq 'body') ) {
      33        
215 0         0 $nobr = 1;
216 0         0 $self->{past_first_line} = 1;
217             }
218              
219 24         191 $self->output( $indent, $output, $nobr );
220              
221 24 50       83 if( $self->{collapse_inline} ) {
222 0 0 0     0 if( ($type eq 'I') and !is_script($tagname) ) {
223 0         0 $self->{no_indent} = 1;
224             }
225             }
226              
227             # header off: turn on output as we enter the body
228 24 50 33     68 if( !$self->{header} && ($tagname eq 'body') ) {
229 0         0 $self->{silent} = 0;
230 0         0 $self->{threshold} = scalar( @{$self->{stack}} );
  0         0  
231             }
232              
233 24 100       254 $self->{last_block} = undef if $type eq 'B';
234             }
235              
236             sub end {
237 24     24 1 41 my ($self, $tagname) = @_;
238 24         23 my $start = pop @{$self->{stack}};
  24         49  
239 24         37 my ($output, $error);
240              
241 24         14597 my $type = sel_type($tagname);
242 24 50       66 if( $start ne $tagname ) {
243             # mismatched tags
244             # check if tag is on the level above if we're using block-level components
245             # if so, go up a level. if close tag same as the last, assume missing open tag
246 0         0 $error = "Mismatched tag '$start' / '$tagname'";
247              
248 0 0       0 if( $type eq 'B') {
249 0 0       0 if( $self->{stack}->[-1] eq $tagname ) {
    0          
250 0         0 my $up = pop @{$self->{stack}};
  0         0  
251 0         0 $error .= ", going up a level to '$up'";
252             } elsif( $self->{last_block} eq $tagname ) {
253 0         0 push @{$self->{stack}}, $tagname;
  0         0  
254 0         0 $error .= ", assuming missing open '$self->{last_block}' tag";
255             }
256             }
257              
258 0 0       0 $type = 'X' if( $self->{debug} );
259             }
260              
261 24         54 my $indent = $self->mk_indent();
262              
263             # header off: turn off output as we leave the body
264 24 50 33     70 $self->{silent} = 1 if !$self->{header} && ($tagname eq 'body');
265              
266 24 50 33     102 $output = gen_tag($type, "/$tagname", undef, undef,
267             ($error && $self->{debug}) ? { error => $error } : ()
268             );
269              
270 24 50       64 if( $self->{no_indent} ) {
271 0 0 0     0 if( ($type ne 'I') or is_row($tagname) ) {
272 0         0 $self->{no_indent} = 0;
273             }
274             }
275              
276 24         56 $self->output( $indent, $output );
277              
278             # store tagname for missing open tag checking
279 24 100       519 $self->{last_block} = $tagname if $type eq 'B';
280             }
281              
282             sub text {
283 48     48 1 508 my ($self, $origtext) = @_;
284 48         95 my $indent = $self->mk_indent();
285 48         58 my $output;
286              
287 48         251 my $text = encode_entities($origtext);
288              
289 48 100       2264 if( $text =~ /\S/ ) {
290             # different formatting for the contents of 'script' and 'style' tags
291 21         46 my $parent = $self->{stack}->[-1];
292 21 50       557 if( is_script($parent) ) {
293 0         0 $text =~ s/^\n//;
294 0         0 $text =~ s/\n\s*$//;
295 0         0 $output = qq[$text];
296 0         0 $self->output( '', $output );
297             } else {
298 21         77 $text =~ s/\n//g;
299 21         78 $text =~ s/^\s+//;
300 21         203 $text =~ s/\s+$//;
301              
302             # header off: no line break before first line of body
303 21         26 my $nobr;
304 21 50 33     87 if( !$self->{header} && !$self->{past_first_line} && ($self->{stack}->[-1] eq 'body') ) {
      33        
305 0         0 $nobr = 1;
306 0         0 $self->{past_first_line} = 1;
307             }
308              
309 21         39 $output = qq[$text];
310 21         45 $self->output( $indent, $output, $nobr );
311              
312 21 50       3767 if( $self->{collapse_inline} ) {
313 0         0 $self->{no_indent} = 1;
314             }
315             }
316             }
317             }
318              
319             sub comment {
320 0     0 1 0 my ($self, $origtext) = @_;
321 0         0 my $indent = $self->mk_indent();
322 0         0 my $output;
323              
324 0         0 my $text = encode_entities($origtext);
325 0         0 $output = qq[$text];
326 0         0 $self->output( $indent, $output );
327             }
328              
329             sub declaration {
330 3     3 1 5 my $self = shift;
331 3         5 my @tokens = @{shift()};
  3         21  
332 3         28 my $output;
333              
334 3         12 $output = qq[<];
335 3         10 map { s!^"(.*)"$!"$1"! } @tokens;
  15         93  
336 3         14 $output .= join ' ', @tokens;
337 3         6 $output .= qq[>];
338 3         15 $self->output( '', $output, 1 );
339              
340 3 100       28 unless( $self->{force_type} ) {
341 2 50       8 if( my $identifier = $tokens[3] ){
342 2 50       16 if( $identifier =~ m!(X?HTML)! ) {
343 2         8 my $type = lc( $1 );
344 2         7 $self->type( $type );
345             }
346             }
347             }
348             }
349              
350             # OTHER METHODS
351              
352             sub block_allowed {
353 6     6 0 10 my $self = shift;
354 6         15 my $tag = $self->{stack}->[-1];
355 6 50 33     11 if( (sel_type( $tag ) ne 'I' ) ||
      33        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
356             ($tag eq 'li') ||
357             ($tag eq 'dd') ||
358             ($tag eq 'td') ||
359             ($tag eq 'th') ||
360             ($tag eq 'object') ||
361             ($tag eq 'ins') ||
362             ($tag eq 'del') ||
363             ($tag eq 'ins') ||
364             ($tag eq 'button') ) {
365 6         30 return 1;
366             } else {
367 0         0 return 0;
368             }
369             }
370              
371             sub is_element {
372 0     0 0 0 my $tag = shift;
373 0 0 0     0 if( ($tag eq 'li') ||
      0        
      0        
      0        
374             ($tag eq 'dt') ||
375             ($tag eq 'dd') ||
376             ($tag eq 'td') ||
377             ($tag eq 'th') ) {
378 0         0 return 1;
379             } else {
380 0         0 return 0;
381             }
382             }
383              
384             sub is_row {
385 0     0 0 0 my $tag = shift;
386 0 0 0     0 if( ($tag eq 'tr') ||
      0        
      0        
387             ($tag eq 'thead') ||
388             ($tag eq 'tbody') ||
389             ($tag eq 'tfoot') ) {
390 0         0 return 1;
391             } else {
392 0         0 return 0;
393             }
394             }
395              
396             sub is_script {
397 21     21 0 30 my $tag = shift;
398 21 50 33     101 if( ($tag eq 'script') ||
399             ($tag eq 'style') ) {
400 0         0 return 1;
401             } else {
402 21         62 return 0;
403             }
404             }
405              
406             sub in_head {
407 0     0 0 0 my $self = shift;
408 0         0 my $doc_level = $self->{stack}[1];
409 0 0       0 if( ($doc_level eq 'head') ) {
410 0         0 return 1;
411             } else {
412 0         0 return 0;
413             }
414             }
415              
416             sub output {
417 72     72 0 1948 my ($self, $indent, $output, $nobr ) = @_;
418 72 50       165 if( !$self->{no_indent} ) {
419 72         132 $output = $indent . $output;
420 72 100       802 $output = $self->{br} . $output unless $nobr;
421             }
422 72 50       241 $self->{out_func}->( $output ) unless $self->{silent};
423             }
424              
425             sub gen_tag {
426 48     48 0 88 my ($type, $tagname, $attr, $attrseq, $opts) = @_;
427 48         58 my $output;
428              
429 48 50       105 if( defined $opts->{error} ) {
430 0         0 $output = qq[<$tagname];
431             } else {
432 48         711 $output = qq[<$tagname];
433             }
434              
435 48         49 foreach ( @{$attrseq} ) {
  48         367  
436 3 50       11 if( $attr->{$_} ne $_ ) {
437 3         16 $output .= qq[ $_="$attr->{$_}"];
438             } else {
439 0         0 $output .= " $_";
440             }
441             }
442 48         66 $output .= '>';
443 48         140 return $output;
444             }
445              
446             sub sel_type {
447 54     54 0 74 my $tag = shift;
448 54 100 100     2281 if( ($tag eq 'html') ||
    100 100        
      33        
      33        
      33        
      33        
      33        
      33        
      66        
      66        
      66        
      33        
      33        
      33        
      33        
      66        
449             ($tag eq 'body') ||
450             ($tag eq 'head') ) {
451 18         60 return 'H';
452             } elsif( ($tag eq 'address') ||
453             ($tag eq 'blockquote') ||
454             ($tag eq 'center') || # deprecated, but people are still (unfortunately) going to use it
455             ($tag eq 'div') ||
456             ($tag eq 'dl') ||
457             ($tag eq 'form') ||
458             ($tag eq 'ol') ||
459             ($tag eq 'p') ||
460             ($tag eq 'pre') ||
461             ($tag eq 'table') ||
462             ($tag eq 'ul') ||
463             ($tag eq 'noscript') ||
464             ($tag eq 'noframes') ||
465             ($tag eq 'fieldset') ||
466             ($tag =~ /^h[1-6]$/) ) {
467 18         69 return 'B';
468             } else {
469 18         46 return 'I';
470             }
471             }
472              
473             sub mk_indent {
474 96     96 0 119 my $self = shift;
475 96         105 my $i = scalar( @{$self->{stack}} ) - $self->{threshold};
  96         254  
476 96         321 return ' ' x ($i * $self->{indent_level});
477             }
478              
479             # Autoload methods go after =cut, and are processed by the autosplit program.
480              
481             1;
482             __END__