File Coverage

blib/lib/TOBYINK/Pod/HTML.pm
Criterion Covered Total %
statement 26 145 17.9
branch 0 30 0.0
condition 0 17 0.0
subroutine 9 34 26.4
pod 7 7 100.0
total 42 233 18.0


line stmt bran cond sub pod time code
1 1     1   107764 use 5.014;
2: use strict;
3: use warnings;
4:
5: use HTML::HTML5::Parser ();
6: use Pod::Simple ();
7: use XML::LibXML::QuerySelector ();
8:
9: {
10: package TOBYINK::Pod::HTML::Helper;
11:
12: our $AUTHORITY = 'cpan:TOBYINK';
13: our $VERSION = '0.005';
14:
15: use parent "Pod::Simple::HTML";
16:
17: sub new
18: {
19: my $class = shift;
20: my $self = $class->SUPER::new(@_);
21: $self->perldoc_url_prefix("https://metacpan.org/pod/");
22: return $self;
23: }
24:
25: sub _get_titled_section
26: {
27: my $self = shift;
28: my @r;
29: $self->{_in_get_titled_section} = 1;
30: wantarray
31: ? (@r = $self->SUPER::_get_titled_section(@_))
32: : ($r[0] = $self->SUPER::_get_titled_section(@_));
33: delete $self->{_in_get_titled_section};
34: wantarray ? @r : $r[0];
35: }
36:
37: sub get_token
38: {
39: my $self = shift;
40: my $tok = $self->SUPER::get_token;
41:
42: if (!$self->{_in_get_titled_section} and defined $tok and $tok->[0] eq 'start' and $tok->[1] eq 'for')
43: {
44: my $target = $tok->[2]{"target"};
45: my $data;
46: until ($tok->[0] eq 'end' and $tok->[1] eq 'for')
47: {
48: $data .= $tok->[1] if $tok->[0] eq 'text';
49: $tok = $self->SUPER::get_token;
50: }
51: ${$self->output_string} .= "<!-- for $target $data -->\n";
52: $tok = $self->SUPER::get_token;
53: }
54:
55: return $tok;
56: }
57: }
58:
59: {
60: package TOBYINK::Pod::HTML;
61:
62: our $AUTHORITY = 'cpan:TOBYINK';
63: our $VERSION = '0.005';
64:
65: use Moo;
66: use Carp;
67:
68: has pretty => (
69: is => 'ro',
70: default => sub { 0 },
71: );
72:
73: has code_highlighting => (
74: is => 'ro',
75: default => sub { 0 },
76: );
77:
78: has code_styles => (
79: is => 'ro',
80: default => sub {
81: return +{
82: symbol => 'color:#333;background-color:#fcc',
83: pod => 'color:#060',
84: comment => 'color:#060;font-style:italic',
85: operator => 'color:#000;font-weight:bold',
86: single => 'color:#909',
87: double => 'color:#909',
88: literal => 'color:#909',
89: interpolate => 'color:#909',
90: words => 'color:#333;background-color:#ffc',
91: regex => 'color:#333;background-color:#9f9',
92: match => 'color:#333;background-color:#9f9',
93: substitute => 'color:#333;background-color:#f90',
94: transliterate => 'color:#333;background-color:#f90',
95: number => 'color:#39C',
96: magic => 'color:#900;font-weight:bold',
97: cast => 'color:#f00;font-weight:bold',
98: pragma => 'color:#009',
99: keyword => 'color:#009;font-weight:bold',
100: core => 'color:#009;font-weight:bold',
101: line_number => 'color:#666',
102: # for non-Perl code103: alert => 'color:#f00;background-color:#ff0',
104: warning => 'color:#f00;background-color:#ff0;font-style:italic',
105: error => 'color:#f00;background-color:#ff0;font-style:italic;font-weight:bold',
106: bstring => '',
107: function => '',
108: regionmarker => '',
109: others => '',
110: }
111: },
112: );
113:
114: # tri-state (0, 1, undef)
115: has code_line_numbers => (
116: is => 'ro',
117: default => sub { +undef },
118: );
119:
120: sub BUILD
121: {
122: my $self = shift;
123: croak "code_line_numbers without code_highlighting will not work"
124: if $self->code_line_numbers && !$self->code_highlighting;
125: }
126:
127: sub file_to_dom
128: {
129: my $self = shift;
130: $self->_pod_to_dom(parse_file => @_);
131: }
132:
133: sub string_to_dom
134: {
135: my $self = shift;
136: $self->_pod_to_dom(parse_string_document => @_);
137: }
138:
139: sub file_to_html
140: {
141: my $self = shift;
142: $self->_dom_to_html($self->file_to_dom(@_));
143: }
144:
145: sub string_to_html
146: {
147: my $self = shift;
148: $self->_dom_to_html($self->string_to_dom(@_));
149: }
150:
151: sub file_to_xhtml
152: {
153: my $self = shift;
154: $self->file_to_dom(@_)->toString;
155: }
156:
157: sub string_to_xhtml
158: {
159: my $self = shift;
160: $self->string_to_dom(@_)->toString;
161: }
162:
163: sub _pull_code_styles
164: {
165: my $css = shift->code_styles;
166: my %pull = @_;
167: $css->{$_} = $pull{$_} for grep !exists($css->{$_}), keys %pull;
168: }
169:
170: sub _pod_to_dom
171: {
172: my $self = shift;
173: my $dom = $self->_make_dom( $self->_make_markup(@_) );
174: $self->_dom_cleanups($dom);
175: $self->_syntax_highlighting($dom) if $self->code_highlighting;
176: if ($self->pretty)
177: {
178: require XML::LibXML::PrettyPrint;
179: "XML::LibXML::PrettyPrint"->new_for_html->pretty_print($dom);
180: }
181: return $dom;
182: }
183:
184: sub _make_markup
185: {
186: my $self = shift;
187: my ($method, $input) = @_;
188:
189: my $tmp;
190: my $p = (__PACKAGE__."::Helper")->new;
191: $p->accept_targets(qw/ highlighter /);
192: $p->output_string(\$tmp);
193: $p->$method($input);
194: return $tmp;
195: }
196:
197: sub _make_dom
198: {
199: my $self = shift;
200: my ($markup) = @_;
201: my $dom = "HTML::HTML5::Parser"->load_html(string => $markup);
202: }
203:
204: sub _dom_cleanups
205: {
206: my $self = shift;
207: my ($dom) = @_;
208:
209: # My pod is always utf-8 or a subset thereof
210: %{ $dom->querySelector('head meta') } = (charset => 'utf-8');
211:
212: # Non-useful comments
213: $_->parentNode->removeChild($_) for
214: grep { not /for (highlighter)/ }
215: $dom->findnodes('//comment()');
216:
217: # Drop these <a name> elements
218: $dom->querySelectorAll('a[name]')->foreach(sub
219: {
220: $_->setNodeName('span');
221: %$_ = (id => $_->{name});
222: });
223: }
224:
225: sub _syntax_highlighting
226: {
227: my $self = shift;
228: my ($dom) = @_;
229:
230: my $opt = {
231: line_numbers => $self->code_line_numbers,
232: language => "perl",
233: };
234:
235: $dom->findnodes('//comment() | //*[local-name()="pre"]')->foreach(sub
236: {
237: if ($_->nodeName eq '#comment')
238: {
239: my $data = $_->data;
240: while ($data =~ m{\b(\w+?)=(\S+)}g)
241: {
242: my ($k, $v) = ($1, $2);
243: $opt->{$k} = $v;
244: }
245: return;
246: }
247:
248: $self->_syntax_highlighting_for_element($_ => $opt);
249: });
250: }
251:
252: sub _syntax_highlighting_for_element
253: {
254: my $self = shift;
255: my ($pre, $opt) = @_;
256:
257: my $out = $self->_syntax_highlighting_for_text($pre->textContent, $opt);
258: $out =~ s/<br>//g; # already in <pre>!
259:
260: # Replace original <pre> contents with new stuff.
261: $pre->removeChild($_) for $pre->childNodes;
262: $pre->appendWellBalancedChunk($out);
263:
264: # Adjust CSS
265: my $CSS = $self->code_styles;
266: $pre->findnodes('.//*[@class]')->foreach(sub
267: {
268: $_->{style} = $CSS->{$_->{class}} if $CSS->{$_->{class}};
269: });
270:
271: # Add @class to <pre> itself
272: $pre->{class} = sprintf("highlighting-%s", lc $opt->{language});
273: }
274:
275: sub _syntax_highlighting_for_text
276: {
277: my $self = shift;
278: my ($txt, $opt) = @_;
279:
280: return $txt
281: if $opt->{language} =~ /^(text)$/i;
282:
283: return $self->_syntax_highlighting_for_text_via_ppi(@_)
284: if $opt->{language} =~ /^(perl)$/i;
285:
286: return $self->_syntax_highlighting_for_text_via_shrdf(@_)
287: if $opt->{language} =~ /^(turtle|n.?triples|n.?quads|trig|n3|notation.?3|pret|pretdsl|sparql|sparql.?(update|query)|json|xml)$/i;
288:
289: return $self->_syntax_highlighting_for_text_via_kate(@_);
290: }
291:
292: sub _syntax_highlighting_for_text_via_ppi
293: {
294: my $self = shift;
295: my ($txt, $opt) = @_;
296:
297: require PPI::Document;
298: require PPI::HTML;
299:
300: my $hlt = "PPI::HTML"->new(
301: line_numbers => ($opt->{line_numbers} // scalar($txt =~ m{^\s+#!/}s)),
302: );
303: return $hlt->html("PPI::Document"->new(\$txt));
304: }
305:
306: sub _syntax_highlighting_for_text_via_shrdf
307: {
308: my $self = shift;
309: my ($txt, $opt) = @_;
310:
311: require Syntax::Highlight::RDF;
312: require Syntax::Highlight::XML;
313: require Syntax::Highlight::JSON2;
314:
315: # Syntax::Highlight::RDF uses different CSS classes
316: my $css = $self->code_styles;
317: $self->_pull_code_styles(%Syntax::Highlight::RDF::STYLE)
318: unless $css->{rdf_comment};
319: $self->_pull_code_styles(%Syntax::Highlight::XML::STYLE)
320: unless $css->{xml_tag_is_doctype};
321: $self->_pull_code_styles(%Syntax::Highlight::JSON2::STYLE)
322: unless $css->{json_boolean};
323:
324: my $hlt = "Syntax::Highlight::RDF"->highlighter($opt->{language});
325: return $hlt->highlight(\$txt);
326: }
327:
328: # Does not support line numbers
329: sub _syntax_highlighting_for_text_via_kate
330: {
331: my $self = shift;
332: my ($txt, $opt) = @_;
333:
334: require Syntax::Highlight::Engine::Kate;
335:
336: my $hl = "Syntax::Highlight::Engine::Kate"->new(
337: language => $opt->{language},
338: substitutions => {
339: "<" => "&lt;",
340: ">" => "&gt;",
341: "&" => "&amp;",
342: "\n" => "\n",
343: },
344: format_table => {
345: Normal => ["", ""],
346: Keyword => [q[<span class="keyword">], q[</span>]],
347: DataType => [q[<span class="cast">], q[</span>]],
348: DecVal => [q[<span class="number">], q[</span>]],
349: BaseN => [q[<span class="number">], q[</span>]],
350: Float => [q[<span class="number">], q[</span>]],
351: Char => [q[<span class="single">], q[</span>]],
352: String => [q[<span class="single">], q[</span>]],
353: IString => [q[<span class="double">], q[</span>]],
354: Comment => [q[<span class="comment">], q[</span>]],
355: Others => [q[<span class="others">], q[</span>]],
356: Alert => [q[<span class="alert">], q[</span>]],
357: Function => [q[<span class="function">], q[</span>]],
358: RegionMarker => [q[<span class="regionmarker">], q[</span>]],
359: Error => [q[<span class="error">], q[</span>]],
360: Operator => [q[<span class="operator">], q[</span>]],
361: Reserved => [q[<span class="core">], q[</span>]],
362: Variable => [q[<span class="symbol">], q[</span>]],
363: Warning => [q[<span class="warning">], q[</span>]],
364: BString => [q[<span class="bstring">], q[</span>]],
365: },
366: );
367: return $hl->highlightText($txt);
368: }
369:
370: sub _dom_to_html
371: {
372: require HTML::HTML5::Writer;
373:
374: my $self = shift;
375: return "HTML::HTML5::Writer"->new(polyglot => 1)->document(@_);
376: }
377: }
378:
379: __FILE__
380: __END__
381:
382: =head1 NAME
383:
384: TOBYINK::Pod::HTML - convert Pod to HTML like TOBYINK
385:
386: =head1 SYNOPSIS
387:
388: #!/usr/bin/perl
389:
390: use strict;
391: use warnings;
392: use TOBYINK::Pod::HTML;
393:
394: my $pod2html = "TOBYINK::Pod::HTML"->new(
395: pretty => 1, # nicely indented HTML
396: code_highlighting => 1, # use PPI::HTML
397: code_line_numbers => undef,
398: code_styles => { # some CSS
399: comment => 'color:green',
400: keyword => 'font-weight:bold',
401: }
402: );
403:
404: print $pod2html->file_to_html(__FILE__);
405:
406: =head1 DESCRIPTION
407:
408: Yet another pod2html converter.
409:
410: Note that this module requires Perl 5.14, and I have no interest in
411: supporting legacy versions of Perl.
412:
413: =head2 Constructor
414:
415: =over
416:
417: =item C<< new(%attrs) >>
418:
419: Moose-style constructor.
420:
421: =back
422:
423: =head2 Attributes
424:
425: =over
426:
427: =item C<< pretty >>
428:
429: If true, will output pretty-printed (nicely indented) HTML. This doesn't make
430: any difference to the appearance of the HTML in a browser.
431:
432: This feature requires L<XML::LibXML::PrettyPrint>.
433:
434: Defaults to false.
435:
436: =item C<< code_highlighting >>
437:
438: If true, source code samples within pod will be syntax highlighted as Perl 5.
439:
440: This feature requires L<PPI::HTML> and L<PPI::Document>.
441:
442: Defaults to false.
443:
444: =item C<< code_line_numbers >>
445:
446: If undef, source code samples within pod will have line numbers, but only if
447: they begin with C<< "#!" >>.
448:
449: If true, all source code samples within pod will have line numbers.
450:
451: This feature only works in conjunction with C<< code_highlighting >>.
452:
453: Defaults to undef.
454:
455: =item C<< code_styles >>
456:
457: A hashref of CSS styles to assign to highlighted code. The defaults are:
458:
459: +{
460: symbol => 'color:#333;background-color:#fcc',
461: pod => 'color:#060',
462: comment => 'color:#060;font-style:italic',
463: operator => 'color:#000;font-weight:bold',
464: single => 'color:#909',
465: double => 'color:#909',
466: literal => 'color:#909',
467: interpolate => 'color:#909',
468: words => 'color:#333;background-color:#ffc',
469: regex => 'color:#333;background-color:#9f9',
470: match => 'color:#333;background-color:#9f9',
471: substitute => 'color:#333;background-color:#f90',
472: transliterate => 'color:#333;background-color:#f90',
473: number => 'color:#39C',
474: magic => 'color:#900;font-weight:bold',
475: cast => 'color:#f00;font-weight:bold',
476: pragma => 'color:#009',
477: keyword => 'color:#009;font-weight:bold',
478: core => 'color:#009;font-weight:bold',
479: line_number => 'color:#666',
480: # for non-Perl code
481: alert => 'color:#f00;background-color:#ff0',
482: warning => 'color:#f00;background-color:#ff0;font-style:italic',
483: error => 'color:#f00;background-color:#ff0;font-style:italic;font-weight:bold',
484: bstring => '',
485: function => '',
486: regionmarker => '',
487: others => '',
488: }
489:
490: Which looks kind of like the Perl highlighting from SciTE.
491:
492: =back
493:
494: =head2 Methods
495:
496: =over
497:
498: =item C<< file_to_dom($filename) >>
499:
500: Convert pod from file to a L<XML::LibXML::Document> object.
501:
502: =item C<< string_to_dom($document) >>
503:
504: Convert pod from string to a L<XML::LibXML::Document> object.
505:
506: =item C<< file_to_xhtml($filename) >>
507:
508: Convert pod from file to an XHTML string.
509:
510: =item C<< string_to_xhtml($document) >>
511:
512: Convert pod from string to an XHTML string.
513:
514: =item C<< file_to_html($filename) >>
515:
516: Convert pod from file to an HTML5 string.
517:
518: This feature requires L<HTML::HTML5::Writer>.
519:
520: =item C<< string_to_html($document) >>
521:
522: Convert pod from string to an HTML5 string.
523:
524: This feature requires L<HTML::HTML5::Writer>.
525:
526: =back
527:
528: =begin trustme
529:
530: =item C<< BUILD >>
531:
532: =end trustme
533:
534: =head2 Alternative Syntax Highlighting
535:
536: =for highlighter language=Text
537:
538: This module defines an additional Pod command to change the language for
539: syntax highlighting. To tell TOBYINK::Pod::HTML to switch to, say, Haskell
540: instead of the default (Perl), just use:
541:
542: =for highlighter language=Haskell
543:
544: Then all subsequent code samples will be highlighted as Haskell, until
545: another such command is seen.
546:
547: While syntax highlighting for Perl uses L<PPI::HTML>, syntax highlighting
548: for other languages uses either L<Syntax::Highlight::RDF> or
549: L<Syntax::Highlight::Engine::Kate> as appropriate, so you need to have
550: them installed if you want this feature.
551:
552: Note that the language names defined by Syntax::Highlight::Engine::Kate
553: are case-sensitive, and TOBYINK::Pod::HTML makes no attempt at case-folding,
554: so you must use the correct case!
555:
556: Note that only the PPI highlighter supports line numbering.
557:
558: The following command can be used to switch to plain text syntax highlighting
559: (i.e. no highlighting at all):
560:
561: =for highlighter language=Text
562:
563: =for highlighter language=Perl
564:
565: =head1 SEE ALSO
566:
567: L<Pod::Simple>, L<PPI::HTML>, etc.
568:
569: =head1 AUTHOR
570:
571: Toby Inkster E<lt>tobyink@cpan.orgE<gt>.
572:
573: =head1 COPYRIGHT AND LICENCE
574:
575: This software is copyright (c) 2013-2014 by Toby Inkster.
576:
577: This is free software; you can redistribute it and/or modify it under
578: the same terms as the Perl 5 programming language system itself.
579:
580: =head1 DISCLAIMER OF WARRANTIES
581:
582: THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
583: WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
584: MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
585:
  1         4