File Coverage

lib/HTML/Accessors.pm
Criterion Covered Total %
statement 105 105 100.0
branch 40 42 95.2
condition 46 51 90.2
subroutine 17 17 100.0
pod 7 7 100.0
total 215 222 96.8


line stmt bran cond sub pod time code
1             package HTML::Accessors;
2              
3 1     1   625 use 5.01;
  1         2  
  1         32  
4 1     1   4 use strict;
  1         1  
  1         29  
5 1     1   4 use warnings;
  1         1  
  1         23  
6 1     1   4 use version; our $VERSION = qv( sprintf '0.13.%d', q$Rev: 1 $ =~ /\d+/gmx );
  1         1  
  1         11  
7              
8 1     1   98 use Carp;
  1         1  
  1         63  
9 1     1   453 use HTML::GenerateUtil qw( generate_tag :consts );
  1         1310  
  1         167  
10 1     1   459 use HTML::Tagset;
  1         910  
  1         35  
11 1     1   8 use Scalar::Util qw( blessed );
  1         1  
  1         909  
12              
13             my $INP = { checkbox => 'checkbox',
14             hidden => 'hidden',
15             image_button => 'image',
16             password_field => 'password',
17             radio_button => 'radio',
18             submit => 'submit',
19             textfield => 'text' };
20             my $NUL = q();
21              
22             # Private functions
23             my $_hash_merge = sub {
24             return { %{ $_[ 0 ] }, %{ $_[ 1 ] || {} } };
25             };
26              
27             my $_hashify = sub {
28             return $_[ 0 ] ? ref $_[ 0 ] eq 'HASH' ? { %{ $_[ 0 ] } } : { @_ } : {};
29             };
30              
31             # Public methods
32             sub new {
33 3   66 3 1 1406 my ($self, @args) = @_; my $class = blessed $self || $self;
  3         19  
34              
35 3         6 my $attr = { content_type => 'application/xhtml+xml' };
36              
37 3         6 return bless $_hash_merge->( $attr, $_hashify->( @args ) ), $class;
38             }
39              
40             sub content_type {
41 14     14 1 83 return $_[ 0 ]->{content_type};
42             }
43              
44             sub escape_html {
45 1     1 1 424 my ($self, @args) = @_; return HTML::GenerateUtil::escape_html( @args );
  1         10  
46             }
47              
48             sub is_xml {
49 14 100   14 1 20 return $_[ 0 ]->content_type =~ m{ / (.*) xml \z }mx ? 1 : 0;
50             }
51              
52             sub popup_menu {
53 5     5 1 1668 my ($self, @args) = @_; my $options;
  5         5  
54              
55 5         7 my $args = $_hashify->( @args );
56 5   100     20 my $classes = delete $args->{classes} || {};
57 5   66     16 my $def = delete $args->{default} || $NUL;
58 5   100     15 my $labels = delete $args->{labels } || {};
59 5   100     15 my $values = delete $args->{values } || [];
60              
61 5         5 for my $val (grep { defined } @{ $values }) {
  4         8  
  5         8  
62 4 100       10 my $opt_attr = $val eq $def ? { selected => $self->is_xml
    100          
63             ? 'selected' : undef } : {};
64              
65 4 50       8 exists $classes->{ $val } and $opt_attr->{class} = $classes->{ $val };
66              
67 4 100       7 if (exists $labels->{ $val }) {
68 2         4 $opt_attr->{value} = $val; $val = $labels->{ $val };
  2         1  
69             }
70              
71 4         21 $options .= generate_tag( 'option', $opt_attr, $val, GT_ADDNEWLINE );
72             }
73              
74 5 100       9 if ($options) { $options = "\n".$options }
  2         4  
75 3         8 else { $options = generate_tag( 'option', undef, $NUL, GT_ADDNEWLINE ) }
76              
77 5         42 return generate_tag( 'select', $args, $options, GT_ADDNEWLINE );
78             }
79              
80             sub radio_group {
81 5     5 1 4136 my ($self, @args) = @_;
82              
83 5         11 my $args = $_hashify->( @args );
84 5   100     16 my $cols = $args->{columns } || '999999';
85 5   100     15 my $def = $args->{default } || 0;
86 5   100     14 my $labels = $args->{labels } || {};
87 5   100     13 my $label_class = $args->{label_class} || 'radio_group_label';
88 5   100     10 my $name = $args->{name } || 'radio';
89 5   100     12 my $values = $args->{values } || [];
90 5         9 my $inp_attr = { name => $name, type => 'radio' };
91 5 100       10 my $mode = $self->is_xml ? GT_CLOSETAG : 0;
92 5         7 my $html = $NUL;
93 5         6 my $i = 1;
94              
95 5 50       9 $args->{onchange} and $inp_attr->{onchange} = $args->{onchange};
96              
97 5         5 for my $val (grep { defined } @{ $values }) {
  32         36  
  5         13  
98 32         33 $inp_attr->{value } = $val;
99 32         30 $inp_attr->{tabindex} = $i;
100             $val =~ m{ \d+ }mx and $def =~ m{ \d+ }mx and $val == $def
101 32 100 100     124 and $inp_attr->{checked } = $self->is_xml ? 'checked' : undef;
    100 100        
102             ($val !~ m{ \d+ }mx or $def !~ m{ \d+ }mx) and $val eq $def
103 32 100 100     141 and $inp_attr->{checked } = $self->is_xml ? 'checked' : undef;
    100 100        
104 32         148 $html .= generate_tag( 'input', $inp_attr, undef, $mode );
105 32 100 100     230 (exists $labels->{ $val } and not defined $labels->{ $val })
      100        
106             or $html .= generate_tag( 'label',
107             { class => $label_class },
108             ($labels->{ $val } || $val),
109             GT_ADDNEWLINE );
110 32 100       93 $i % $cols == 0 and $html .= generate_tag( 'br', undef, undef, $mode );
111 32         35 delete $inp_attr->{checked};
112 32         31 $i++;
113             }
114              
115 5         30 return $html;
116             }
117              
118             sub scrolling_list {
119 1     1 1 2 my ($self, @args) = @_; my $args = $_hashify->( @args );
  1         2  
120              
121 1         2 $args->{multiple} = 'multiple';
122 1         2 return $self->popup_menu( $args );
123             }
124              
125             sub AUTOLOAD { ## no critic
126 7     7   420 my ($self, @args) = @_; my $args = {};
  7         10  
127              
128 7         7 my $mode = GT_ADDNEWLINE; my $val = $args[ 0 ];
  7         6  
129              
130 7         47 (my $elem = lc $HTML::Accessors::AUTOLOAD) =~ s{ .* :: }{}mx;
131              
132 7 100 100     28 if ($val and ref $val eq 'HASH') { $args = { %{ $val } }; $val = $args[ 1 ] }
  3         3  
  3         9  
  3         4  
133              
134 7 100       16 if (exists $INP->{ $elem }) {
135 3         7 $args->{type} = $INP->{ $elem };
136 3 100       8 defined $args->{default} and $args->{value} = delete $args->{default};
137 3 100       7 defined $args->{value } or $args->{value} = $NUL;
138 3         3 $elem = 'input';
139             }
140              
141 7 100       18 unless ($HTML::Tagset::isKnown{ $elem }) { ## no critic
142 1         126 carp "Unknown element $elem"; return;
  1         140  
143             }
144              
145 6   33     27 $val //= delete $args->{default} // $NUL;
      66        
146              
147 6 100       11 if ($HTML::Tagset::emptyElement{ $elem }) { ## no critic
148 3 100       3 $val = undef; $mode = $self->is_xml ? GT_CLOSETAG : 0;
  3         7  
149             }
150              
151 6         52 return generate_tag( $elem, $args, $val, $mode );
152             }
153              
154 1     1   5 sub DESTROY {}
155              
156             1;
157              
158             __END__