}
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 . '' . $tag . '>'; | ||||
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; |