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
  27     'cmp' => op_factory('cmp'),
  28     'eq'  => op_factory('eq'),
  29     '<=>' => op_factory('<=>'),
  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
  40     fallback => 1,
  41 ;
  42
  43 sub new {
  44     my ($class, @raw_parts) = @_;
  45
  46     my @parts = map { ref($_) eq 'ARRAY' ? $_ : [$_] } @raw_parts;
  47
  48     my $self = bless { parts => \@parts }, $class;
  49
  50     return $self;
  51 }
  52
  53 sub escaped_string {
  54     my $self = shift;
  55
  56     return join '', map +(
  57         $_->[1]
  58             ? byval {
  59                 s/&/&amp;/g;
  60                 s/</&lt;/g;
  61                 s/>/&gt;/g;
  62                 s/"/&quot;/g;
  63               } $_->[0]
  64             : $_->[0]
  65     ), @{$self->{parts}};
  66 }
  67
  68 sub unescaped_string {
  69     my $self = shift;
  70
  71     return join '', map $_->[0], @{$self->{parts}};
  72 }
  73
  74 sub dot {
  75     my ($self, $str, $prefix) = @_;
  76
  77     return $self unless $str;
  78
  79     my @parts = @{$self->{parts}};
  80
  81     my @new_parts = (
  82         $str->$_isa(__PACKAGE__)
  83             ? @{$str->{parts}}
  84             : [ $str, 1 ]
  85     );
  86
  87     if ( $prefix ) {
  88         unshift @parts, @new_parts;
  89     } else {
  90         push @parts, @new_parts;
  91     }
  92
  93     return ref($self)->new(@parts);
  94 }
  95
  96 sub dot_equals {
  97     my ($self, $str, $prefix) = @_;
  98
  99     return $self unless $str;
 100
 101     my @new_parts = (
 102         $str->$_isa(__PACKAGE__)
 103             ? @{$str->{parts}}
 104             : [ $str, 1 ]
 105     );
 106
 107     push @{$self->{parts}}, @new_parts;
 108
 109     return $self;
 110 }
 111
 112 1;