File Coverage

blib/lib/HTML/Tiny.pm
Criterion Covered Total %
statement 116 117 99.1
branch 44 46 95.6
condition 12 16 75.0
subroutine 25 25 100.0
pod 13 13 100.0
total 210 217 96.7


line stmt bran cond sub pod time code
1 5     5   59409 use strict; use warnings;
  5     5   32  
  5         112  
  5         20  
  5         6  
  5         139  
2              
3             package HTML::Tiny;
4              
5 5     5   19 use Carp;
  5         7  
  5         830  
6              
7             =head1 NAME
8              
9             HTML::Tiny - Lightweight, dependency free HTML/XML generation
10              
11             =cut
12              
13             our $VERSION = '1.08';
14              
15             BEGIN {
16              
17             # https://developer.mozilla.org/en-US/docs/Web/HTML/Element
18 5     5   40 for my $tag ( qw(
19             a abbr acronym address applet area article aside audio
20             b base bdi bdo big blink blockquote body br button
21             canvas caption center cite code col colgroup
22             data datalist dd del details dfn dialog dir div dl dt
23             em embed
24             fieldset figcaption figure font footer form frame frameset
25             h1 h2 h3 h4 h5 h6 head header hgroup hr html
26             i iframe img input ins
27             kbd keygen
28             label legend li link
29             main map mark marquee menu menuitem meta meter
30             nav nobr noframes noscript
31             object ol optgroup option output
32             p param picture portal pre progress
33             q
34             rb rp rt rtc ruby
35             s samp script section select slot small source spacer span strike strong style sub summary sup
36             table tbody td template textarea tfoot th thead time title tr track tt
37             u ul
38             var video
39             wbr
40             xmp
41             ) ) {
42 5     5   29 no strict 'refs';
  5         8  
  5         277  
43 665     1384   11672 *$tag = sub { shift->auto_tag( $tag, @_ ) };
  1384         689360  
44             }
45             }
46              
47             # Tags that are closed (
versus

)
48             my @DEFAULT_CLOSED
49             # https://developer.mozilla.org/en-US/docs/Glossary/Empty_element
50             = qw( area base br col embed hr img input keygen link meta param source track wbr );
51              
52             # Tags that get a trailing newline
53             my @DEFAULT_NEWLINE = qw( html head body div p tr table );
54              
55             my %DEFAULT_AUTO = (
56             suffix => '',
57             method => 'tag'
58             );
59              
60             =head1 SYNOPSIS
61              
62             use HTML::Tiny;
63              
64             my $h = HTML::Tiny->new;
65              
66             # Generate a simple page
67             print $h->html(
68             [
69             $h->head( $h->title( 'Sample page' ) ),
70             $h->body(
71             [
72             $h->h1( { class => 'main' }, 'Sample page' ),
73             $h->p( 'Hello, World', { class => 'detail' }, 'Second para' )
74             ]
75             )
76             ]
77             );
78              
79             # Outputs
80            
81            
82             Sample page
83            
84            
85            

Sample page

86            

Hello, World

87            

Second para

88            
89            
90              
91             =head1 DESCRIPTION
92              
93             C<< HTML::Tiny >> is a simple, dependency free module for generating
94             HTML (and XML). It concentrates on generating syntactically correct
95             XHTML using a simple Perl notation.
96              
97             In addition to the HTML generation functions utility functions are
98             provided to
99              
100             =over
101              
102             =item * encode and decode URL encoded strings
103              
104             =item * entity encode HTML
105              
106             =item * build query strings
107              
108             =item * JSON encode data structures
109              
110             =back
111              
112             =head1 INTERFACE
113              
114             =over
115              
116             =item C<< new >>
117              
118             Create a new C<< HTML::Tiny >>. The constructor takes one optional
119             argument: C<< mode >>. C<< mode >> can be either C<< 'xml' >> (default)
120             or C<< 'html' >>. The difference is that in HTML mode, closed tags will
121             not be closed with a forward slash; instead, closed tags will be
122             returned as single open tags.
123              
124             Example:
125            
126             # Set HTML mode.
127             my $h = HTML::Tiny->new( mode => 'html' );
128              
129             # The default is XML mode, but this can also be defined explicitly.
130             $h = HTML::Tiny->new( mode => 'xml' );
131              
132             HTML is a dialect of SGML, and is not XML in any way. "Orphan" open tags
133             or unclosed tags are legal and in fact expected by user agents. In
134             practice, if you want to generate XML or XHTML, supply no arguments. If
135             you want valid HTML, use C<< mode => 'html' >>.
136              
137             =back
138              
139             =cut
140              
141             sub new {
142 193     193 1 79694 my $self = bless {}, shift;
143              
144 193         415 my %params = @_;
145 193   100     397 my $mode = $params{'mode'} || 'xml';
146              
147 193 50 66     597 croak "Unknown mode: $mode"
148             unless $mode eq 'xml'
149             or $mode eq 'html';
150              
151 193         329 $self->{'_mode'} = $mode;
152              
153 193         439 $self->_set_auto( 'method', 'closed', @DEFAULT_CLOSED );
154 193         426 $self->_set_auto( 'suffix', "\n", @DEFAULT_NEWLINE );
155 193         465 return $self;
156             }
157              
158             sub _set_auto {
159 386     386   604 my ( $self, $kind, $value ) = splice @_, 0, 3;
160 386         2722 $self->{autotag}->{$kind}->{$_} = $value for @_;
161             }
162              
163             =head2 HTML Generation
164              
165             =over
166              
167             =item C<< tag( $name, ... ) >>
168              
169             Returns HTML (or XML) that encloses each of the arguments in the specified tag. For example
170              
171             print $h->tag('p', 'Hello', 'World');
172              
173             would print
174              
175            

Hello

World

176              
177             notice that each argument is individually wrapped in the specified tag.
178             To avoid this multiple arguments can be grouped in an anonymous array:
179              
180             print $h->tag('p', ['Hello', 'World']);
181              
182             would print
183              
184            

HelloWorld

185              
186             The [ and ] can be thought of as grouping a number of arguments.
187              
188             Attributes may be supplied by including an anonymous hash in the
189             argument list:
190              
191             print $h->tag('p', { class => 'normal' }, 'Foo');
192              
193             would print
194              
195            

Foo

196              
197             Attribute values will be HTML entity encoded as necessary.
198              
199             Multiple hashes may be supplied in which case they will be merged:
200              
201             print $h->tag('p',
202             { class => 'normal' }, 'Bar',
203             { style => 'color: red' }, 'Bang!'
204             );
205              
206             would print
207              
208            

Bar

Bang!

209              
210             Notice that the class="normal" attribute is merged with the style
211             attribute for the second paragraph.
212              
213             To remove an attribute set its value to undef:
214              
215             print $h->tag('p',
216             { class => 'normal' }, 'Bar',
217             { class => undef }, 'Bang!'
218             );
219              
220             would print
221              
222            

Bar

Bang!

223              
224             An empty attribute - such as 'checked' in a checkbox can be encoded by
225             passing an empty array reference:
226              
227             print $h->closed( 'input', { type => 'checkbox', checked => [] } );
228              
229             would print
230              
231            
232              
233             B
234              
235             In a scalar context C<< tag >> returns a string. In a list context it
236             returns an array each element of which corresponds to one of the
237             original arguments:
238              
239             my @html = $h->tag('p', 'this', 'that');
240              
241             would return
242              
243             @html = (
244             '

this

',
245             '

that

'
246             );
247              
248             That means that when you nest calls to tag (or the equivalent HTML
249             aliases - see below) the individual arguments to the inner call will be
250             tagged separately by each enclosing call. In practice this means that
251              
252             print $h->tag('p', $h->tag('b', 'Foo', 'Bar'));
253              
254             would print
255              
256            

Foo

Bar

257              
258             You can modify this behavior by grouping multiple args in an
259             anonymous array:
260              
261             print $h->tag('p', [ $h->tag('b', 'Foo', 'Bar') ] );
262              
263             would print
264              
265            

FooBar

266              
267             This behaviour is powerful but can take a little time to master. If you
268             imagine '[' and ']' preventing the propagation of the 'tag individual
269             items' behaviour it might help visualise how it works.
270              
271             Here's an HTML table (using the tag-name convenience methods - see
272             below) that demonstrates it in more detail:
273              
274             print $h->table(
275             [
276             $h->tr(
277             [ $h->th( 'Name', 'Score', 'Position' ) ],
278             [ $h->td( 'Therese', 90, 1 ) ],
279             [ $h->td( 'Chrissie', 85, 2 ) ],
280             [ $h->td( 'Andy', 50, 3 ) ]
281             )
282             ]
283             );
284              
285             which would print the unformatted version of:
286              
287            
288            
NameScorePosition
289            
Therese901
290            
Chrissie852
291            
Andy503
292            
293              
294             Note how you don't need a td() for every cell or a tr() for every row.
295             Notice also how the square brackets around the rows prevent tr() from
296             wrapping each individual cell.
297              
298             Often when generating nested HTML you will find yourself writing
299             corresponding nested calls to HTML generation methods. The table
300             generation code above is an example of this.
301              
302             If you prefer these nested method calls can be deferred like this:
303              
304             print $h->table(
305             [
306             \'tr',
307             [ \'th', 'Name', 'Score', 'Position' ],
308             [ \'td', 'Therese', 90, 1 ],
309             [ \'td', 'Chrissie', 85, 2 ],
310             [ \'td', 'Andy', 50, 3 ]
311             ]
312             );
313              
314             In general a nested call like
315              
316             $h->method( args )
317              
318             may be rewritten like this
319              
320             [ \'method', args ]
321              
322             This allows complex HTML to be expressed as a pure data structure. See
323             the C method for more information.
324              
325             =cut
326              
327             sub tag {
328 1265     1265 1 10381 my ( $self, $name ) = splice @_, 0, 2;
329              
330 1265         1629 my %attr = ();
331 1265         1495 my @out = ();
332              
333 1265         1678 for my $a ( @_ ) {
334 2524 100       4401 if ( 'HASH' eq ref $a ) {
335              
336             # Merge into attributes
337 116         314 %attr = ( %attr, %$a );
338             }
339             else {
340              
341             # Generate markup
342 2408         4147 push @out,
343             $self->_tag( 0, $name, \%attr )
344             . $self->stringify( $a )
345             . $self->close( $name );
346             }
347             }
348              
349             # Special case: generate an empty tag pair if there's no content
350 1265 100       2151 push @out, $self->_tag( 0, $name, \%attr ) . $self->close( $name )
351             unless @out;
352              
353 1265 100       2993 return wantarray ? @out : join '', @out;
354             }
355              
356             =item C<< open( $name, ... ) >>
357              
358             Generate an opening HTML or XML tag. For example:
359              
360             print $h->open('marker');
361              
362             would print
363              
364            
365              
366             Attributes can be provided in the form of anonymous hashes in the same way as for C<< tag >>. For example:
367              
368             print $h->open('marker', { lat => 57.0, lon => -2 });
369              
370             would print
371              
372            
373              
374             As for C<< tag >> multiple attribute hash references will be merged. The example above could be written:
375              
376             print $h->open('marker', { lat => 57.0 }, { lon => -2 });
377              
378             =cut
379              
380 22     22 1 8332 sub open { shift->_tag( 0, @_ ) }
381              
382             =item C<< close( $name ) >>
383              
384             Generate a closing HTML or XML tag. For example:
385              
386             print $h->close('marker');
387              
388             would print:
389              
390            
391              
392             =cut
393              
394 2462     2462 1 14423 sub close { "" }
395              
396             =item C<< closed( $name, ... ) >>
397              
398             Generate a closed HTML or XML tag. For example
399              
400             print $h->closed('marker');
401              
402             would print:
403              
404            
405              
406             As for C<< tag >> and C<< open >> attributes may be provided as hash
407             references:
408              
409             print $h->closed('marker', { lat => 57.0 }, { lon => -2 });
410              
411             would print:
412              
413            
414              
415             =cut
416              
417 193     193 1 8693 sub closed { shift->_tag( 1, @_ ) }
418              
419             =item C<< auto_tag( $name, ... ) >>
420              
421             Calls either C<< tag >> or C<< closed >> based on built in rules
422             for the tag. Used internally to implement the tag-named methods.
423              
424             =cut
425              
426             sub auto_tag {
427 1400     1400 1 11252 my ( $self, $name ) = splice @_, 0, 2;
428             my ( $method, $post )
429 1400 100       2089 = map { $self->{autotag}->{$_}->{$name} || $DEFAULT_AUTO{$_} }
  2800         10100  
430             ( 'method', 'suffix' );
431 1400         3130 my @out = map { $_ . $post } $self->$method( $name, @_ );
  2568         4508  
432 1400 100       4506 return wantarray ? @out : join '', @out;
433             }
434              
435             =item C<< stringify( $obj ) >>
436              
437             Called internally to obtain string representations of values.
438              
439             It also implements the deferred method call notation (mentioned
440             above) so that
441              
442             my $table = $h->table(
443             [
444             $h->tr(
445             [ $h->th( 'Name', 'Score', 'Position' ) ],
446             [ $h->td( 'Therese', 90, 1 ) ],
447             [ $h->td( 'Chrissie', 85, 2 ) ],
448             [ $h->td( 'Andy', 50, 3 ) ]
449             )
450             ]
451             );
452              
453             may also be written like this:
454              
455             my $table = $h->stringify(
456             [
457             \'table',
458             [
459             \'tr',
460             [ \'th', 'Name', 'Score', 'Position' ],
461             [ \'td', 'Therese', 90, 1 ],
462             [ \'td', 'Chrissie', 85, 2 ],
463             [ \'td', 'Andy', 50, 3 ]
464             ]
465             ]
466             );
467              
468             Any reference to an array whose first element is a reference to a scalar
469              
470             [ \'methodname', args ]
471              
472             is executed as a call to the named method with the specified args.
473              
474             =cut
475              
476             sub stringify {
477 2888     2888 1 4067 my ( $self, $obj ) = @_;
478 2888 100       4136 if ( ref $obj ) {
479              
480             # Flatten array refs...
481 92 100       153 if ( 'ARRAY' eq ref $obj ) {
482             # Check for deferred method call specified as a scalar
483             # ref...
484 90 100 66     273 if ( @$obj && 'SCALAR' eq ref $obj->[0] ) {
485 36         59 my ( $method, @args ) = @$obj;
486 36         77 return join '', $self->$$method( @args );
487             }
488 54         74 return join '', map { $self->stringify( $_ ) } @$obj;
  122         172  
489             }
490              
491             # ...stringify objects...
492 2         2 my $str;
493 2 100       4 return $str if eval { $str = $obj->as_string; 1 };
  2         20  
  1         7  
494             }
495              
496             # ...default stringification
497 2797         5756 return "$obj";
498             }
499              
500             =back
501              
502             =head2 Methods named after tags
503              
504             In addition to the methods described above C<< HTML::Tiny >> provides
505             all of the following HTML generation methods:
506              
507             a abbr acronym address applet area article aside audio b base bdi bdo big
508             blink blockquote body br button canvas caption center cite code col colgroup
509             data datalist dd del details dfn dialog dir div dl dt em embed fieldset
510             figcaption figure font footer form frame frameset h1 h2 h3 h4 h5 h6 head
511             header hgroup hr html i iframe img input ins kbd keygen label legend li link
512             main map mark marquee menu menuitem meta meter nav nobr noframes noscript
513             object ol optgroup option output p param picture portal pre progress q rb rp
514             rt rtc ruby s samp script section select slot small source spacer span strike
515             strong style sub summary sup table tbody td template textarea tfoot th thead
516             time title tr track tt u ul var video wbr xmp
517              
518             The following methods generate closed XHTML (
) tags by default:
519              
520             area base br col embed frame hr iframe img input keygen link meta param
521             source track wbr
522              
523             So:
524              
525             print $h->br; # prints
526             print $h->input({ name => 'field1' });
527             # prints
528             print $h->img({ src => 'pic.jpg' });
529             # prints
530              
531             All other tag methods generate tags to wrap whatever content they
532             are passed:
533              
534             print $h->p('Hello, World');
535              
536             prints:
537              
538            

Hello, World

539              
540             So the following are equivalent:
541              
542             print $h->a({ href => 'http://hexten.net' }, 'Hexten');
543              
544             and
545              
546             print $h->tag('a', { href => 'http://hexten.net' }, 'Hexten');
547              
548             =head2 Utility Methods
549              
550             =over
551              
552             =item C<< url_encode( $str ) >>
553              
554             URL encode a string. Spaces become '+' and non-alphanumeric characters
555             are encoded as '%' + their hexadecimal character code.
556              
557             $h->url_encode( ' ' ) # returns '+%3chello%3e+'
558              
559             =cut
560              
561             sub url_encode {
562 92     92 1 9136 my $str = $_[0]->stringify( $_[1] );
563 92         303 $str
564 151 100       485 =~ s/([^A-Za-z0-9_~])/$1 eq ' ' ? '+' : sprintf("%%%02x", ord($1))/eg;
565 92         292 return $str;
566             }
567              
568             =item C<< url_decode( $str ) >>
569              
570             URL decode a string. Reverses the effect of C<< url_encode >>.
571              
572             $h->url_decode( '+%3chello%3e+' ) # returns ' '
573              
574             =cut
575              
576             sub url_decode {
577 18     18 1 8319 my $str = $_[1];
578 18         84 $str =~ s/[+]/ /g;
579 18         98 $str =~ s/%([0-9a-f]{2})/chr(hex($1))/ieg;
  53         163  
580 18         52 return $str;
581             }
582              
583             =item C<< query_encode( $hash_ref ) >>
584              
585             Generate a query string from an anonymous hash of key, value pairs:
586              
587             print $h->query_encode({ a => 1, b => 2 })
588              
589             would print
590              
591             a=1&b=2
592              
593             =cut
594              
595             sub query_encode {
596 19     19 1 8263 my $self = shift;
597 19   100     50 my $hash = shift || {};
598             return join '&', map {
599 37         64 join( '=', map { $self->url_encode( $_ ) } ( $_, $hash->{$_} ) )
  74         108  
600 19         65 } sort grep { defined $hash->{$_} } keys %$hash;
  37         101  
601             }
602              
603             =item C<< entity_encode( $str ) >>
604              
605             Encode the characters '<', '>', '&', '\'' and '"' as their HTML entity
606             equivalents:
607              
608             print $h->entity_encode( '<>\'"&' );
609              
610             would print:
611              
612             <>'"&
613              
614             =cut
615              
616             {
617             my %ENT_MAP = (
618             '&' => '&',
619             '<' => '<',
620             '>' => '>',
621             '"' => '"', # shorter than "
622             "'" => ''', # HTML does not define '
623             "\xA" => ' ',
624             "\xD" => ' ',
625             );
626              
627             my $text_special = qr/([<>&'"])/;
628             my $attr_special = qr/([<>&'"\x0A\x0D])/; # FIXME needs tests
629              
630             sub entity_encode {
631 219     219 1 8677 my $str = $_[0]->stringify( $_[1] );
632 219 100       383 my $char_rx = $_[2] ? $attr_special : $text_special;
633 219         820 $str =~ s/$char_rx/$ENT_MAP{$1}/eg;
  5         13  
634 219         358 return $str;
635             }
636             }
637              
638             sub _attr {
639 203     203   304 my ( $self, $attr, $val ) = @_;
640              
641 203 100       326 if ( ref $val ) {
642 2 100       5 return $attr if not $self->_xml_mode;
643 1         2 $val = $attr;
644             }
645              
646 202         315 my $enc_val = $self->entity_encode( $val, 1 );
647 202         609 return qq{$attr="$enc_val"};
648             }
649              
650 194     194   917 sub _xml_mode { $_[0]->{'_mode'} eq 'xml' }
651              
652       2656 1   sub validate_tag {
653             # Do nothing. Subclass to throw an error for invalid tags
654             }
655              
656             sub _tag {
657 2659     2659   3827 my ( $self, $closed, $name ) = splice @_, 0, 3;
658              
659             croak "Attributes must be passed as hash references"
660 2659 100       3333 if grep { 'HASH' ne ref $_ } @_;
  2587         6523  
661              
662             # Merge attribute hashes
663 2658         3545 my %attr = map { %$_ } @_;
  2586         4143  
664              
665 2658         5382 $self->validate_tag( $closed, $name, \%attr );
666              
667             # Generate markup
668             my $tag = join( ' ',
669             "<$name",
670 203         346 map { $self->_attr( $_, $attr{$_} ) }
671 2658         5988 sort grep { defined $attr{$_} } keys %attr );
  224         564  
672              
673 2658 100 100     7979 return $tag . ( $closed && $self->_xml_mode ? ' />' : '>' );
674             }
675              
676             {
677             my @UNPRINTABLE = qw(
678             z x01 x02 x03 x04 x05 x06 a
679             x08 t n v f r x0e x0f
680             x10 x11 x12 x13 x14 x15 x16 x17
681             x18 x19 x1a e x1c x1d x1e x1f
682             );
683              
684             sub _json_encode_ref {
685 82     82   100 my ( $self, $seen, $obj ) = @_;
686 82         98 my $type = ref $obj;
687 82 100 33     153 if ( 'HASH' eq $type ) {
    100          
    50          
688             return '{' . join(
689             ',',
690             map {
691 59         161 $self->_json_encode( $seen, $_ ) . ':'
692 29         47 . $self->_json_encode( $seen, $obj->{$_} )
693             } sort keys %$obj
694             ) . '}';
695             }
696             elsif ( 'ARRAY' eq $type ) {
697             return
698             '['
699 22         45 . join( ',', map { $self->_json_encode( $seen, $_ ) } @$obj )
  76         116  
700             . ']';
701             }
702             elsif ( UNIVERSAL::can( $obj, 'can' ) && $obj->can( 'TO_JSON' ) ) {
703 1         5 return $self->_json_encode( $seen, $obj->TO_JSON );
704             }
705             else {
706 0         0 croak "Can't json_encode a $type";
707             }
708             }
709              
710             # Minimal JSON encoder. Provided here for completeness - it's useful
711             # when generating JS.
712             sub _json_encode {
713 163     163   218 my ( $self, $seen, $obj ) = @_;
714              
715 163 100       309 return 'null' unless defined $obj;
716              
717 145 100       234 if ( my $type = ref $obj ) {
718             croak "json_encode can't handle self referential structures"
719 83 100       347 if $seen->{$obj}++;
720 82         127 my $rep = $self->_json_encode_ref( $seen, $obj );
721 80         147 delete $seen->{$obj};
722 80         249 return $rep;
723             }
724              
725 62 100       311 return $obj if $obj =~ /^-?\d+(?:[.]\d+)?$/;
726              
727 31         57 $obj = $self->stringify( $obj );
728 31         53 $obj =~ s/\\/\\\\/g;
729 31         37 $obj =~ s/"/\\"/g;
730 31         52 $obj =~ s/ ( [\x00-\x1f] ) / '\\' . $UNPRINTABLE[ ord($1) ] /gex;
  32         57  
731              
732 31         85 return qq{"$obj"};
733             }
734             }
735              
736             =item C<< json_encode >>
737              
738             Encode a data structure in JSON (Javascript) format:
739              
740             print $h->json_encode( { ar => [ 1, 2, 3, { a => 1, b => 2 } ] } );
741              
742             would print:
743            
744             {"ar":[1,2,3,{"a":1,"b":2}]}
745              
746             Because JSON is valid Javascript this method can be useful when
747             generating ad-hoc Javascript. For example
748              
749             my $some_perl_data = {
750             score => 45,
751             name => 'Fred',
752             history => [ 32, 37, 41, 45 ]
753             };
754              
755             # Transfer value to Javascript
756             print $h->script( { type => 'text/javascript' },
757             "\nvar someVar = " . $h->json_encode( $some_perl_data ) . ";\n " );
758              
759             # Prints
760             #
763              
764             If you attempt to json encode a blessed object C will look
765             for a C method and, if found, use its return value as the
766             structure to be converted in place of the object. An attempt to encode a
767             blessed object that does not implement C will fail.
768              
769             =cut
770              
771 28     28 1 9013 sub json_encode { shift->_json_encode( {}, @_ ) }
772              
773             1;
774              
775             __END__