File Coverage

blib/lib/HTML/Widget/Plugin/Attrs.pm
Criterion Covered Total %
statement 29 30 96.6
branch 9 14 64.2
condition 4 6 66.6
subroutine 7 7 100.0
pod 3 3 100.0
total 52 60 86.6


line stmt bran cond sub pod time code
1 15     15   15655 use strict;
  15         32  
  15         629  
2 15     15   247 use warnings;
  15         28  
  15         1153  
3             package HTML::Widget::Plugin::Attrs;
4             # ABSTRACT: an HTML attribute string
5             $HTML::Widget::Plugin::Attrs::VERSION = '0.202';
6 15     15   1620 use parent 'HTML::Widget::Plugin';
  15         636  
  15         115  
7              
8             #pod =head1 DESCRIPTION
9             #pod
10             #pod This plugin produces HTML attribute strings.
11             #pod
12             #pod =cut
13              
14 15     15   4193 use HTML::Element;
  15         54160  
  15         145  
15              
16             #pod =head1 METHODS
17             #pod
18             #pod =head2 C< provided_widgets >
19             #pod
20             #pod This plugin provides the following widgets: attrs
21             #pod
22             #pod =cut
23              
24 19     19 1 83 sub provided_widgets { qw(attrs) }
25              
26             #pod =head2 C< attrs >
27             #pod
28             #pod This method returns HTML attribute strings, so:
29             #pod
30             #pod $factory->attrs({
31             #pod size => 10,
32             #pod name => q(Michael "Five-Toes" O'Gambini),
33             #pod });
34             #pod
35             #pod will produce something like:
36             #pod
37             #pod size="10" name="Michael "Five-Toes""
38             #pod
39             #pod None of the standard argument rewriting applies. These are the valid
40             #pod arguments:
41             #pod
42             #pod =over
43             #pod
44             #pod =item -tag
45             #pod
46             #pod This may be the name of an HTML element. If given, it will be used to look up
47             #pod what attributes are boolean.
48             #pod
49             #pod =item -bool
50             #pod
51             #pod This may be an arrayref of attribute names to treat as boolean arguments.
52             #pod
53             #pod =back
54             #pod
55             #pod All attributes not beginning with a dash will be treated as attributes for the
56             #pod attribute string. Boolean attributes will always have the attribute name as
57             #pod the value if true, and will be omitted if false.
58             #pod
59             #pod If both C<-tag> and C<-bool> are given, they are unioned.
60             #pod
61             #pod =cut
62              
63             # Note that we're totally replacing the standard args rewriting! This is not
64             # going to act quite like existing widget plugins! -- rjbs, 2008-05-05
65             # ALL unless they are boolean args.
66 1     1 1 4 sub rewrite_arg { return $_[1] }
67              
68             sub attrs {
69 1     1 1 3 my ($self, $factor, $arg) = @_;
70              
71 1         2 my $attr = {};
72              
73 1         1 my %bool;
74 1 50       2 $bool{lc $_} = 1 for @{ $arg->{-bool} || [] };
  1         21  
75              
76 1         8 require HTML::Tagset;
77 1 50 33     6 if ($arg->{-tag} and my $entry = $HTML::Tagset::boolean_attr{$arg->{-tag}}) {
78 0 0       0 $bool{lc $_} = 1 for (ref $entry ? keys %$entry : $entry);
79             }
80              
81 1         2 my $str = '';
82 1 100       42 for my $key (sort grep { $_ !~ /^-/ and defined $arg->{$_} } keys %$arg) {
  8         51  
83 6         117 my $is_bool = $bool{ lc $key };
84 6 100 100     21 next if $is_bool and not $arg->{$key};
85              
86 5 100       15 $str .= HTML::Entities::encode_entities($key)
87             . '="'
88             . ($is_bool ? HTML::Entities::encode_entities($key)
89             : HTML::Entities::encode_entities($arg->{$key}))
90             . '" ';
91             }
92              
93             # Remove the trailing space that we're sure to have -- rjbs, 2008-05-05
94 1 50       24 substr $str, -1, 1, '' if length $str;
95              
96 1         6 return $str;
97             }
98              
99             1;
100              
101             __END__