lib/HTML/String/Value.pm

   1 package HTML::String::Value;
   2
   3 use strictures 1;
   4 use Safe::Isa;
   5 use Data::Munge;
   6
   7 sub op_factory {
   8     my ($op) = @_;
   9
  10     return eval q|sub {
  11         my ($self, $str) = @_;
  12
  13         if ( $str->$_isa(__PACKAGE__) ) {
  14             return $self->unescaped_string | . $op . q| $str->unescaped_string;
  15         }
  16         else {
  17             return $self->unescaped_string | . $op . q| $str;
  18         }
  19     }|;
  20 }
  21
  22 use overload
  23     '""'   => 'escaped_string',
  24     '.'    => 'dot',
  25     '.='   => 'dot_equals',
  26     '='    => 'clone',
  27
  28     'cmp' => op_factory('cmp'),
  29     'eq'  => op_factory('eq'),
  30     '<=>' => op_factory('<=>'),
  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
  41     fallback => 1,
  42 ;
  43
  44 sub new {
  45     my ($class, @raw_parts) = @_;
  46
  47     my @parts = map { ref($_) eq 'ARRAY' ? $_ : [$_] } @raw_parts;
  48
  49     my $self = bless { parts => \@parts }, $class;
  50
  51     return $self;
  52 }
  53
  54 sub escaped_string {
  55     my $self = shift;
  56
  57     return join '', map +(
  58         $_->[1]
  59             ? byval {
  60                 s/&/&amp;/g;
  61                 s/</&lt;/g;
  62                 s/>/&gt;/g;
  63                 s/"/&quot;/g;
  64               } $_->[0]
  65             : $_->[0]
  66     ), @{$self->{parts}};
  67 }
  68
  69 sub unescaped_string {
  70     my $self = shift;
  71
  72     return join '', map $_->[0], @{$self->{parts}};
  73 }
  74
  75 sub dot {
  76     my ($self, $str, $prefix) = @_;
  77
  78     return $self unless $str;
  79
  80     my @parts = @{$self->{parts}};
  81
  82     my @new_parts = (
  83         $str->$_isa(__PACKAGE__)
  84             ? @{$str->{parts}}
  85             : [ $str, 1 ]
  86     );
  87
  88     if ( $prefix ) {
  89         unshift @parts, @new_parts;
  90     } else {
  91         push @parts, @new_parts;
  92     }
  93
  94     return ref($self)->new(@parts);
  95 }
  96
  97 sub dot_equals {
  98     my ($self, $str, $prefix) = @_;
  99
 100     return $self unless $str;
 101
 102     my @new_parts = (
 103         $str->$_isa(__PACKAGE__)
 104             ? @{$str->{parts}}
 105             : [ $str, 1 ]
 106     );
 107
 108     push @{$self->{parts}}, @new_parts;
 109
 110     return $self;
 111 }
 112
 113 sub clone {
 114     my $self = shift;
 115
 116     return ref($self)->new(@{$self->{parts}});
 117 }
 118
 119 1;