Commit | Line | Data |
e1b4b35c |
1 | package HTML::String::Value; |
2 | |
3 | use strictures 1; |
586054e0 |
4 | use UNIVERSAL::ref; |
e1b4b35c |
5 | use Safe::Isa; |
6 | use Data::Munge; |
7 | |
e1b4b35c |
8 | use overload |
b8aaa17d |
9 | '""' => '_hsv_escaped_string', |
10 | '.' => '_hsv_dot', |
11 | 'bool' => '_hsv_is_true', |
e1b4b35c |
12 | |
e1b4b35c |
13 | fallback => 1, |
14 | ; |
15 | |
16 | sub new { |
b8aaa17d |
17 | if (ref($_[0])) { my $c = shift; return $c->_hsv_unescaped_string->new(@_) } |
e1b4b35c |
18 | my ($class, @raw_parts) = @_; |
19 | |
f27b509e |
20 | my $opts = (ref($raw_parts[-1]) eq 'HASH') ? pop(@raw_parts) : {}; |
21 | |
51eaef0b |
22 | my @parts = map { |
23 | if (ref($_) eq 'ARRAY') { |
24 | $_ |
25 | } elsif ($_->$_isa(__PACKAGE__)) { |
26 | @{$_->{parts}} |
27 | } else { |
28 | [ $_, 0 ] |
29 | } |
30 | } @raw_parts; |
e1b4b35c |
31 | |
f27b509e |
32 | my $self = bless { parts => \@parts, %$opts }, $class; |
e1b4b35c |
33 | |
34 | return $self; |
35 | } |
36 | |
b8aaa17d |
37 | sub AUTOLOAD { |
38 | my $invocant = shift; |
39 | (my $meth = our $AUTOLOAD) =~ s/.*:://; |
40 | die "No such method ${meth} on ${invocant}" |
41 | unless ref($invocant); |
42 | return $invocant->_hsv_unescaped_string->$meth(@_); |
43 | } |
44 | |
45 | sub _hsv_escaped_string { |
e1b4b35c |
46 | my $self = shift; |
47 | |
f27b509e |
48 | if ($self->{ignore}{scalar caller}) { |
b8aaa17d |
49 | return $self->_hsv_unescaped_string; |
f27b509e |
50 | } |
51 | |
e1b4b35c |
52 | return join '', map +( |
53 | $_->[1] |
54 | ? byval { |
55 | s/&/&/g; |
56 | s/</</g; |
57 | s/>/>/g; |
58 | s/"/"/g; |
59 | } $_->[0] |
60 | : $_->[0] |
61 | ), @{$self->{parts}}; |
62 | } |
63 | |
b8aaa17d |
64 | sub _hsv_unescaped_string { |
e1b4b35c |
65 | my $self = shift; |
66 | |
67 | return join '', map $_->[0], @{$self->{parts}}; |
68 | } |
69 | |
b8aaa17d |
70 | sub _hsv_dot { |
e1b4b35c |
71 | my ($self, $str, $prefix) = @_; |
72 | |
73 | return $self unless $str; |
74 | |
75 | my @parts = @{$self->{parts}}; |
76 | |
77 | my @new_parts = ( |
78 | $str->$_isa(__PACKAGE__) |
79 | ? @{$str->{parts}} |
80 | : [ $str, 1 ] |
81 | ); |
82 | |
83 | if ( $prefix ) { |
84 | unshift @parts, @new_parts; |
85 | } else { |
86 | push @parts, @new_parts; |
87 | } |
88 | |
f27b509e |
89 | return ref($self)->new(@parts, { ignore => $self->{ignore} }); |
90 | } |
91 | |
b8aaa17d |
92 | sub _hsv_is_true { |
f27b509e |
93 | my ($self) = @_; |
94 | return 1 if grep length($_), map $_->[0], @{$self->{parts}}; |
e1b4b35c |
95 | } |
96 | |
586054e0 |
97 | sub ref { '' } |
98 | |
9c9a7ae5 |
99 | sub DESTROY { } |
100 | |
e1b4b35c |
101 | 1; |