lib/HTML/String/Value.pm

   1 package HTML::String::Value;
   2
   3 use strictures 1;
   4 use UNIVERSAL::ref;
   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',
  27     '='    => 'clone',
  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
  48     my @parts = map {
  49         if (ref($_) eq 'ARRAY') {
  50             $_
  51         } elsif ($_->$_isa(__PACKAGE__)) {
  52             @{$_->{parts}}
  53         } else {
  54             [ $_, 0 ]
  55         }
  56     } @raw_parts;
  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/&/&amp;/g;
  70                 s/</&lt;/g;
  71                 s/>/&gt;/g;
  72                 s/"/&quot;/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
 122 sub clone {
 123     my $self = shift;
 124
 125     return ref($self)->new(@{$self->{parts}});
 126 }
 127
 128 sub ref { '' }
 129
 130 1;