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 | |
8 | sub op_factory { |
9 | my ($op) = @_; |
10 | |
11 | return eval q|sub { |
12 | my ($self, $str) = @_; |
13 | |
14 | if ( $str->$_isa(__PACKAGE__) ) { |
15 | return $self->unescaped_string | . $op . q| $str->unescaped_string; |
16 | } |
17 | else { |
18 | return $self->unescaped_string | . $op . q| $str; |
19 | } |
20 | }|; |
21 | } |
22 | |
23 | use overload |
24 | '""' => 'escaped_string', |
25 | '.' => 'dot', |
26 | '.=' => 'dot_equals', |
ed99cbb4 |
27 | '=' => 'clone', |
e1b4b35c |
28 | |
29 | 'cmp' => op_factory('cmp'), |
30 | 'eq' => op_factory('eq'), |
31 | '<=>' => op_factory('<=>'), |
32 | '==' => op_factory('=='), |
33 | '%' => op_factory('%'), |
34 | '+' => op_factory('+'), |
35 | '-' => op_factory('-'), |
36 | '*' => op_factory('*'), |
37 | '/' => op_factory('/'), |
38 | '**' => op_factory('**'), |
39 | '>>' => op_factory('>>'), |
40 | '<<' => op_factory('<<'), |
41 | |
42 | fallback => 1, |
43 | ; |
44 | |
45 | sub new { |
46 | my ($class, @raw_parts) = @_; |
47 | |
51eaef0b |
48 | my @parts = map { |
49 | if (ref($_) eq 'ARRAY') { |
50 | $_ |
51 | } elsif ($_->$_isa(__PACKAGE__)) { |
52 | @{$_->{parts}} |
53 | } else { |
54 | [ $_, 0 ] |
55 | } |
56 | } @raw_parts; |
e1b4b35c |
57 | |
58 | my $self = bless { parts => \@parts }, $class; |
59 | |
60 | return $self; |
61 | } |
62 | |
63 | sub escaped_string { |
64 | my $self = shift; |
65 | |
66 | return join '', map +( |
67 | $_->[1] |
68 | ? byval { |
69 | s/&/&/g; |
70 | s/</</g; |
71 | s/>/>/g; |
72 | s/"/"/g; |
73 | } $_->[0] |
74 | : $_->[0] |
75 | ), @{$self->{parts}}; |
76 | } |
77 | |
78 | sub unescaped_string { |
79 | my $self = shift; |
80 | |
81 | return join '', map $_->[0], @{$self->{parts}}; |
82 | } |
83 | |
84 | sub dot { |
85 | my ($self, $str, $prefix) = @_; |
86 | |
87 | return $self unless $str; |
88 | |
89 | my @parts = @{$self->{parts}}; |
90 | |
91 | my @new_parts = ( |
92 | $str->$_isa(__PACKAGE__) |
93 | ? @{$str->{parts}} |
94 | : [ $str, 1 ] |
95 | ); |
96 | |
97 | if ( $prefix ) { |
98 | unshift @parts, @new_parts; |
99 | } else { |
100 | push @parts, @new_parts; |
101 | } |
102 | |
103 | return ref($self)->new(@parts); |
104 | } |
105 | |
106 | sub dot_equals { |
107 | my ($self, $str, $prefix) = @_; |
108 | |
109 | return $self unless $str; |
110 | |
111 | my @new_parts = ( |
112 | $str->$_isa(__PACKAGE__) |
113 | ? @{$str->{parts}} |
114 | : [ $str, 1 ] |
115 | ); |
116 | |
117 | push @{$self->{parts}}, @new_parts; |
118 | |
119 | return $self; |
120 | } |
121 | |
ed99cbb4 |
122 | sub clone { |
123 | my $self = shift; |
124 | |
125 | return ref($self)->new(@{$self->{parts}}); |
126 | } |
127 | |
586054e0 |
128 | sub ref { '' } |
129 | |
e1b4b35c |
130 | 1; |