File Coverage

blib/lib/PPI/HTML.pm
Criterion Covered Total %
statement 131 173 75.7
branch 58 116 50.0
condition 5 14 35.7
subroutine 22 24 91.6
pod 3 3 100.0
total 219 330 66.3


line stmt bran cond sub pod time code
1             package PPI::HTML;
2              
3             =pod
4            
5             =head1 NAME
6            
7             PPI::HTML - Generate syntax-hightlighted HTML for Perl using PPI
8            
9             =head1 SYNOPSIS
10            
11             use PPI;
12             use PPI::HTML;
13            
14             # Load your Perl file
15             my $Document = PPI::Document->load( 'script.pl' );
16            
17             # Create a reusable syntax highlighter
18             my $Highlight = PPI::HTML->new( line_numbers => 1 );
19            
20             # Spit out the HTML
21             print $Highlight->html( $Document );
22            
23             =head1 DESCRIPTION
24            
25             PPI::HTML converts Perl documents into syntax highlighted HTML pages.
26            
27             =head1 HISTORY
28            
29             PPI::HTML is the successor to the now-redundant PPI::Format::HTML.
30            
31             While early on it was thought that the same formatting code might be able
32             to be used for a variety of different types of things (ANSI and HTML for
33             example) later developments with the here-doc code and the need for
34             independantly written serializers meant that this idea had to be discarded.
35            
36             In addition, the old module only made use of the Tokenizer, and had a
37             pretty shit API to boot.
38            
39             =head2 API Overview
40            
41             The new module is much cleaner. Simply create an object with the options
42             you want, pass L<PPI::Document> objects to the C<html> method,
43             and you get strings of HTML that you can do whatever you want with.
44            
45             =head1 METHODS
46            
47             =cut
48              
49 2     2   213645 use 5.005;
  2         8  
  2         72  
50 2     2   11 use strict;
  2         3  
  2         60  
51 2     2   2254 use CSS::Tiny ();
  2         9457  
  2         41  
52 2     2   1097 use PPI::Document ();
  2         170821  
  2         73  
53 2     2   1160 use PPI::HTML::Fragment ();
  2         6  
  2         41  
54 2     2   11 use Params::Util '_HASH', '_INSTANCE';
  2         3  
  2         123  
55              
56 2     2   9 use vars qw{$VERSION};
  2         12  
  2         76  
57             BEGIN {
58 2     2   4086 $VERSION = '1.08';
59             }
60              
61              
62              
63              
64              
65             #####################################################################
66             # Constructor and Accessors
67              
68             =pod
69            
70             =head2 new %args
71            
72             The C<new> constructor takes a simple set of key/value pairs to define
73             the formatting options for the HTML.
74            
75             =over
76            
77             =item page
78            
79             Is the C<page> option is enabled, the generator will wrap the generated
80             HTML fragment in a basic but complete page.
81            
82             =item line_numbers
83            
84             At the present time, the only option available. If set to true, line
85             numbers are added to the output.
86            
87             =item colors | colours
88            
89             For cases where you don't want to use an external stylesheet, you
90             can provide C<colors> as a hash reference where the keys are CSS classes
91             (generally matching the token name) and the values are colours.
92            
93             This allows basic colouring without the need for a whole stylesheet.
94            
95             =item css
96            
97             The C<css> option lets you provide a custom L<CSS::Tiny> object containing
98             any CSS you want to apply to the page (if you are using page mode).
99            
100             If both the C<colors> and C<css> options are used, the colour CSS entries
101             will overwrite anything contained in the L<CSS::Tiny> object. The object
102             will also be cloned if it to be modified, to prevent destroying any CSS
103             objects passed in.
104            
105             =back
106            
107             Returns a new L<PPI::HTML> object
108            
109             =cut
110              
111             sub new {
112 5 50   5 1 3890 my $class = ref $_[0] ? ref shift : shift;
113 5         16 my %args = @_;
114              
115             # Create the basic object
116 5         29 my $self = bless {
117             line_numbers => !! $args{line_numbers},
118             page         => !! $args{page},
119             # colors => undef,
120             # css => undef,
121             }, $class;
122              
123             # Manually specify the class colours and custom CSS
124 5 50       19 $args{colors}   = delete $args{colours} if $args{colours};
125 5 100       33 $self->{colors} = $args{colors} if _HASH($args{colors});
126 5 100       37 $self->{css}    = $args{css} if _INSTANCE($args{css}, 'CSS::Tiny');
127              
128 5         18 $self;
129             }
130              
131             =pod
132            
133             =head2 css
134            
135             The C<css> accessor returns the L<CSS::Tiny> object originally provided
136             to the constructor.
137            
138             =cut
139              
140 1     1 1 478 sub css { $_[0]->{css} }
141              
142              
143              
144              
145              
146             #####################################################################
147             # Main Methods
148              
149             =pod
150            
151             =head2 html $Document | $file | \$source
152            
153             The main method for the class, the C<html> method takes a single
154             L<PPI::Document> object, or anything that can be turned into a
155             L<PPI::Document> via its C<new> method, and returns a string of HTML
156             formatted based on the arguments given to the C<PPI::HTML> constructor.
157            
158             Returns a string, or C<undef> on error.
159            
160             =cut
161              
162             sub html {
163 4     4 1 10505 my $self = shift;
164 4 50       17 my $Document = $self->_Document(shift) or return undef;
165              
166             # Build the basic set of fragments
167 4 50       4625 $self->_build_fragments($Document) or return undef;
168              
169             # Interleave the line numbers
170 4 50       15 $self->_build_line_numbers or return undef;
171              
172             # Optimise
173 4 50       12 $self->_optimize_fragments or return undef;
174              
175             # Merge and stringify the fragments
176 4 50       14 $self->_build_html or return undef;
177              
178             # Return the final HTML
179 4         33 delete $self->{html};
180             }
181              
182             # Create the basic list of fragments
183             sub _build_fragments {
184 4     4   10 my ($self, $Document) = @_;
185              
186             # Convert the list of tokens to a list of fragments
187 4         15 $self->{fragments}      = [];
188 4         9 $self->{heredoc_buffer} = undef;
189 4         24 foreach my $Token ( $Document->tokens ) {
190             # Find the Fragments for the token
191 35         269 my @fragments = ();
192 35 50       257 if ( _INSTANCE($Token, 'PPI::Token::HereDoc') ) {
193 0 0       0 @fragments = $self->_heredoc_fragments($Token) or return undef;
194             } else {
195 35 50       69 @fragments = $self->_simple_fragments($Token) or return undef;
196             }
197              
198             # Add the fragments
199 35         44 foreach my $Fragment ( @fragments ) {
200 35 50       70 $self->_add_fragment( $Fragment ) or return undef;
201             }
202             }
203              
204             # Are there any trailing heredoc lines to add?
205 4 50       15 if ( $self->{heredoc_buffer} ) {
206             # Unless the last line ends in a newline, add one
207 0 0       0 unless ( $self->{fragments}->[-1]->ends_line ) {
208 0 0       0 my $Fragment = PPI::HTML::Fragment->new( "\n" ) or return undef;
209 0         0 push @{$self->{fragments}}, $Fragment;
  0         0  
210             }
211              
212             # Add the remaining buffer lines
213 0         0 push @{$self->{fragments}}, @{$self->{heredoc_buffer}};
  0         0  
  0         0  
214             }
215              
216             # We don't need the heredoc buffer any more
217 4         6 delete $self->{heredoc_buffer};
218              
219 4         14 1;
220             }
221              
222             sub _simple_fragments {
223 35     35   49 my ($self, $Token) = @_;
224              
225             # Split the token content into strings
226 35 50       84 my @strings = grep { defined $_ and length $_ } split /(?<=\n)/, $Token->content;
  35         299  
227              
228             # Convert each string to a fragment
229 35         59 my @fragments = ();
230 35         64 my $css_class = $self->_css_class( $Token );
231 35         57 foreach my $string ( @strings ) {
232 35 50       110 my $Fragment = PPI::HTML::Fragment->new( $string, $css_class ) or return ();
233 35         86 push @fragments, $Fragment;
234             }
235              
236 35         132 @fragments;
237             }
238              
239             sub _heredoc_fragments {
240 0     0   0 my ($self, $Token) = @_;
241              
242             # First, create the heredoc content lines and add them
243             # to the buffer
244 0         0 foreach my $line ( $Token->heredoc ) {
245 0 0       0 $self->_add_heredoc( $line,
246             'heredoc_content' ) or return ();
247             }
248              
249             # Add the terminator line
250 0 0       0 $self->_add_heredoc( $Token->terminator . "\n",
251             'heredoc_terminator' ) or return ();
252              
253             # Return a single fragment for the main content part
254 0 0       0 my $Fragment = PPI::HTML::Fragment->new( $Token->content,
255             $self->_css_class( $Token ) ) or return ();
256              
257 0         0 $Fragment;
258             }
259              
260             sub _build_line_numbers {
261 4     4   7 my $self = shift;
262 4 100       25 return 1 unless $self->{line_numbers};
263              
264             # Find the width of the highest line number, so that
265             # we can pad the line numbers
266 2         5 my $max = 1 + scalar map { $_->ends_line } @{$self->{fragments}};
  19         37  
  2         4  
267 2         4 my $width = length("$max");
268 2         5 my $pattern = "\%${width}s: ";
269              
270             # Iterate over the existing array, and insert new line
271             # fragments after each newline.
272 2         3 my $line = 1;
273 19 100       43 my @fragments = map {
274 2         4 $_->ends_line
275             ? ($_, $self->_line_fragment( sprintf($pattern, ++$line) ))
276             : ($_)
277 2         6 } @{$self->{fragments}};
278              
279             # Add the fragment for line 1 to the beginning
280 2         8 unshift @fragments, $self->_line_fragment( sprintf($pattern, 1) );
281              
282 2         4 $self->{fragments} = \@fragments;
283              
284 2         8 1;
285             }
286              
287             sub _build_html {
288 4     4   6 my $self = shift;
289              
290             # Iterate over the loop, stringifying and merging
291 4         5 my $html = '';
292 4         6 foreach my $Fragment ( @{$self->{fragments}} ) {
  4         10  
293 36         97 $html .= $Fragment->html;
294             }
295              
296             # Page wrap if needed
297 4 100       17 if ( $self->{page} ) {
298 1         3 my $css = $self->_css_html;
299              
300 1         34 $html = <<END_HTML;
301             <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN">
302             <html>
303             <head>
304             <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
305             <meta name="robots" content="noarchive">
306             $css
307             </head>
308             <body bgcolor="#FFFFFF" text="#000000"><pre>$html</pre></body>
309             </html>
310             END_HTML
311             }
312              
313             # Replace the fragments array with the HTML
314 4         7 $self->{html} = $html;
315 4         32 delete $self->{fragments};
316              
317 4         12 1;
318             }
319              
320             sub _optimize_fragments {
321 4     4   9 my $self = shift;
322              
323             # Iterate through and do the simplest optimisation layer,
324             # when is joining identical adjacent fragments.
325 4         5 my $current = $self->{fragments};
326 4         10 my @fragments = ( shift @$current );
327 4         7 foreach my $Fragment ( @$current ) {
328 36 100 33     90 if ( $Fragment->css and $fragments[-1]->css and $Fragment->css eq $fragments[-1]->css ) {
      66        
329 4         8 $fragments[-1]->concat( $Fragment->string );
330             } else {
331 32         131 push @fragments, $Fragment;
332             }
333             }
334              
335             # Remove the class from all whitespace
336 4         8 foreach my $Fragment ( @fragments ) {
337 36 50       78 my $css = $Fragment->css or next;
338 36 100       102 $Fragment->clear if $css eq 'whitespace';
339             }
340              
341             # If we know what classes are coloured, strip the style
342             # from everything that doesn't have a colour.
343 4 100       15 if ( $self->{colors} ) {
344 1         2 my $colors = $self->{colors};
345 1         3 foreach my $Fragment ( @fragments ) {
346 11 100       20 my $css = $Fragment->css or next;
347 7 100       16 next if $colors->{$css};
348 4         8 $Fragment->clear;
349             }
350             }
351              
352             # Overwrite the fragments list
353 4         7 $self->{fragments} = \@fragments;
354              
355 4         38 1;
356             }
357              
358             # For a set of colors, generate the relevant CSS
359             sub _css_html {
360 1     1   2 my $self = shift;
361              
362             # Create and fill a CSS object
363 1 50       8 my $css = $self->{css}
364             ? $self->{css}->clone
365             : CSS::Tiny->new;
366 1         5 foreach my $key ( sort keys %{$self->{colors}} ) {
  1         7  
367 2         7 $css->{".$key"}->{color} = $self->{colors}->{$key};
368             }
369              
370 1 50       7 keys %$css ? $css->html : '';
371             }
372              
373              
374              
375              
376              
377             #####################################################################
378             # Support Methods
379              
380             # Create a Document from anything we can
381             sub _Document {
382 4     4   6 my $class = shift;
383 4 100       50 _INSTANCE( $_[0], 'PPI::Document' )
384             ? $_[0] # Already a Document
385             : PPI::Document->new( @_ ); # Make a Document
386             }
387              
388             # Create a Fragment from anything we can
389             sub _Fragment {
390 35     35   66 my $class = shift;
391 35 50       235 _INSTANCE( $_[0], 'PPI::HTML::Fragment' )
392             ? $_[0]
393             : PPI::HTML::Fragment->new( @_ );
394             }
395              
396             sub _add_fragment {
397 35     35   47 my $self = shift;
398 35 50       59 my $Fragment = $self->_Fragment(@_) or return undef;
399              
400             # Add the fragment itself
401 35         41 push @{$self->{fragments}}, $Fragment;
  35         68  
402              
403             # If the fragment ends a line, add
404             # anything that is in the heredoc buffer.
405 35 50 33     80 if ( $self->{heredoc_buffer} and $Fragment->ends_line ) {
406 0         0 push @{$self->{fragments}}, @{$self->{heredoc_buffer}};
  0         0  
  0         0  
407 0         0 $self->{heredoc_buffer} = undef;
408             }
409              
410 35         131 1;
411             }
412              
413             sub _add_heredoc {
414 0     0   0 my $self = shift;
415 0 0       0 my $Fragment = $self->_Fragment(@_) or return undef;
416 0   0     0 $self->{heredoc_buffer} ||= [];
417 0         0 push @{$self->{heredoc_buffer}}, $Fragment;
  0         0  
418 0         0 1;
419             }
420              
421             sub _line_fragment {
422 5     5   10 my ($self, $line) = @_;
423 5         16 PPI::HTML::Fragment->new( $line, 'line_number' );
424             }
425              
426             sub _css_class {
427 35     35   41 my ($self, $Token) = @_;
428 35 100       155 if ( $Token->isa('PPI::Token::Word') ) {
429             # There are some words we can be very confident are
430             # being used as keywords
431 5         19 my $content = $Token->content;
432              
433 5 50 33     65 unless ( $Token->snext_sibling and $Token->snext_sibling->content eq '=>' ) {
434 5 50       290 if ( $content eq 'sub' ) {
    50          
    50          
    50          
    50          
435 0         0 return 'keyword';
436             } elsif ( $content eq 'return' ) {
437 0         0 return 'keyword';
438             } elsif ( $content eq 'undef' ) {
439 0         0 return 'core';
440             } elsif ( $content eq 'shift' ) {
441 0         0 return 'core';
442             } elsif ( $content eq 'defined' ) {
443 0         0 return 'core';
444             }
445             }
446              
447 5         22 my $parent = $Token->parent;
448 5 50       101 if ( $parent->isa('PPI::Statement::Include') ) {
    100          
    50          
    50          
    50          
    50          
    50          
449 0 0       0 if ( $content =~ /^(?:use|no)$/ ) {
450 0         0 return 'keyword';
451             }
452 0 0       0 if ( $content eq $parent->pragma ) {
453 0         0 return 'pragma';
454             }
455             } elsif ( $parent->isa('PPI::Statement::Variable') ) {
456 3 50       67 if ( $content =~ /^(?:my|local|our)$/ ) {
457 3         12 return 'keyword';
458             }
459             } elsif ( $parent->isa('PPI::Statement::Compound') ) {
460 0 0       0 if ( $content =~ /^(?:if|else|elsif|unless|for|foreach|while|my)$/ ) {
461 0         0 return 'keyword';
462             }
463             } elsif ( $parent->isa('PPI::Statement::Given') ) {
464 0 0       0 if ( $content eq 'given' ) {
465 0         0 return 'keyword';
466             }
467             } elsif ( $parent->isa('PPI::Statement::When') ) {
468 0 0       0 if ( $content =~ /^(?:when|default)$/ ) {
469 0         0 return 'keyword';
470             }
471             } elsif ( $parent->isa('PPI::Statement::Package') ) {
472 0 0       0 if ( $content eq 'package' ) {
473 0         0 return 'keyword';
474             }
475             } elsif ( $parent->isa('PPI::Statement::Scheduled') ) {
476 0         0 return 'keyword';
477             }
478             }
479              
480             # Normal colouring
481 32         68 my $css = lc ref $Token;
482 32         113 $css =~ s/^.+:://;
483 32         71 $css;
484             }
485              
486             1;
487              
488             =pod
489            
490             =head1 SUPPORT
491            
492             Bugs should always be submitted via the CPAN bug tracker
493            
494             L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=PPI-HTML>
495            
496             For other issues, contact the maintainer
497            
498             =head1 AUTHOR
499            
500             Adam Kennedy E<lt>adamk@cpan.orgE<gt>
501            
502             Funding provided by The Perl Foundation
503            
504             =head1 SEE ALSO
505            
506             L<http://ali.as/>, L<PPI>
507            
508             =head1 COPYRIGHT
509            
510             Copyright 2005 - 2009 Adam Kennedy.
511            
512             This program is free software; you can redistribute
513             it and/or modify it under the same terms as Perl itself.
514            
515             The full text of the license can be found in the
516             LICENSE file included with this module.
517            
518             =cut
519