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