File Coverage

blib/lib/App/WRT/HTML.pm
Criterion Covered Total %
statement 35 35 100.0
branch 4 4 100.0
condition n/a
subroutine 10 10 100.0
pod 0 3 0.0
total 49 52 94.2


line stmt bran cond sub pod time code
1             package App::WRT::HTML;
2              
3 10     10   105225 use strict;
  10         30  
  10         330  
4 10     10   52 use warnings;
  10         16  
  10         296  
5 10     10   52 no warnings 'uninitialized';
  10         18  
  10         373  
6              
7 10     10   56 use Exporter;
  10         16  
  10         1402  
8             our @ISA = qw(Exporter);
9              
10             our %EXPORT_TAGS = ( 'all' => [ qw(a div p em small strong table
11             table_row table_cell entry_markup
12             heading article nav section
13             unordered_list ordered_list list_item) ],
14              
15             'highlevel' => [ qw(a p em small strong table
16             table_row table_cell
17             entry_markup heading) ] );
18              
19             our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
20             our @EXPORT = qw( );
21              
22 10     10   625 use HTML::Entities qw(encode_entities);
  10         6144  
  10         1652  
23              
24             # Generate subs for these:
25             my %tags = (
26             p => \&tag,
27             em => \&tag,
28             small => \&tag,
29             strong => \&tag,
30             table => \&tag,
31             tr => \&tag,
32             td => \&tag,
33             a => \&tag,
34             div => \&tag,
35             article => \&tag,
36             nav => \&tag,
37             section => \&tag,
38             ul => \&tag,
39             ol => \&tag,
40             li => \&tag,
41             );
42              
43             # ...but map these tags to different sub names:
44             my %tagmap = (
45             tr => 'table_row',
46             td => 'table_cell',
47             ul => 'unordered_list',
48             ol => 'ordered_list',
49             li => 'list_item',
50             );
51              
52             # Install appropriate subs in symbol table:
53 10     10   76 { no strict 'refs';
  10         18  
  10         4126  
54              
55             for my $key (keys %tags) {
56             my $subname = $tagmap{$key};
57             $subname = $key unless ($subname);
58              
59 1662     1662   5148 *{ $subname } = sub { $tags{$key}->($key, @_); };
60             }
61              
62             }
63              
64             # handle most HTML tags:
65             sub tag {
66 1722     1722 0 2526 my ($tag) = shift;
67              
68 1722         2153 my ($attr_string, $text);
69              
70 1722         2587 for my $param (@_) {
71              
72 3074 100       4809 if (ref($param)) {
73             # A hashref containing one or more attribute => value pairs. We sort
74             # these by key because, if using each, order is random(ish), and this can
75             # lead to different HTML for the same input.
76 1272         1444 foreach my $attr (sort keys %{ $param }) {
  1272         3701  
77 1909         2320 my $value = encode_entities( ${ $param }{$attr} );
  1909         3807  
78 1909         26713 $attr_string .= ' ' . $attr . '="' . $value . '"';
79             }
80             }
81             else {
82             # Text that goes inside the content of the tag.
83 1802 100       3464 $text .= "\n" if length($text) > 0;
84 1802         2667 $text .= $param;
85             }
86              
87             }
88              
89             # Voila, an X(HT)ML tag, pretty much:
90 1722         7093 return '<' . $tag . $attr_string . '>' . $text . '';
91             }
92              
93             # Special cases and higher-level markup
94              
95             sub entry_markup {
96 240     240 0 1547 return qq{\n\n
}
97             . $_[0]
98             . "\n\n";
99             }
100              
101             sub heading {
102 60     60 0 123 my ($text, $level) = @_;
103 60         122 my $h = "h$level";
104 60         135 return tag($h, $text);
105             }
106              
107             1;