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 use overload
   9     '""'   => '_hsv_escaped_string',
  10     '.'    => '_hsv_dot',
  11     'bool' => '_hsv_is_true',
  12
  13     fallback => 1,
  14 ;
  15
  16 sub new {
  17     if (ref($_[0])) { my $c = shift; return $c->_hsv_unescaped_string->new(@_) }
  18     my ($class, @raw_parts) = @_;
  19
  20     my $opts = (ref($raw_parts[-1]) eq 'HASH') ? pop(@raw_parts) : {};
  21
  22     my @parts = map {
  23         if (ref($_) eq 'ARRAY') {
  24             $_
  25         } elsif ($_->$_isa(__PACKAGE__)) {
  26             @{$_->{parts}}
  27         } else {
  28             [ $_, 0 ]
  29         }
  30     } @raw_parts;
  31
  32     my $self = bless { parts => \@parts, %$opts }, $class;
  33
  34     return $self;
  35 }
  36
  37 sub AUTOLOAD {
  38     my $invocant = shift;
  39     (my $meth = our $AUTOLOAD) =~ s/.*:://;
  40     die "No such method ${meth} on ${invocant}"
  41         unless ref($invocant);
  42     return $invocant->_hsv_unescaped_string->$meth(@_);
  43 }
  44
  45 sub _hsv_escaped_string {
  46     my $self = shift;
  47
  48     if ($self->{ignore}{scalar caller}) {
  49         return $self->_hsv_unescaped_string;
  50     }
  51
  52     return join '', map +(
  53         $_->[1]
  54             ? byval {
  55                 s/&/&amp;/g;
  56                 s/</&lt;/g;
  57                 s/>/&gt;/g;
  58                 s/"/&quot;/g;
  59               } $_->[0]
  60             : $_->[0]
  61     ), @{$self->{parts}};
  62 }
  63
  64 sub _hsv_unescaped_string {
  65     my $self = shift;
  66
  67     return join '', map $_->[0], @{$self->{parts}};
  68 }
  69
  70 sub _hsv_dot {
  71     my ($self, $str, $prefix) = @_;
  72
  73     return $self unless $str;
  74
  75     my @parts = @{$self->{parts}};
  76
  77     my @new_parts = (
  78         $str->$_isa(__PACKAGE__)
  79             ? @{$str->{parts}}
  80             : [ $str, 1 ]
  81     );
  82
  83     if ( $prefix ) {
  84         unshift @parts, @new_parts;
  85     } else {
  86         push @parts, @new_parts;
  87     }
  88
  89     return ref($self)->new(@parts, { ignore => $self->{ignore} });
  90 }
  91
  92 sub _hsv_is_true {
  93     my ($self) = @_;
  94     return 1 if grep length($_), map $_->[0], @{$self->{parts}};
  95 }
  96
  97 sub ref { '' }
  98
  99 1;