X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FHTML%2FString%2FValue.pm;h=e1f6c9577aee3ef685b2b9c7778a613473c9ad03;hb=e8420dab517c57d30d9a3fa22de9966dc1c99c1b;hp=99a12847785af917f6b4011e187534c697f71782;hpb=586054e05c7ac2fcdb3b7a27442f8b1586c64105;p=scpubgit%2FHTML-String.git diff --git a/lib/HTML/String/Value.pm b/lib/HTML/String/Value.pm index 99a1284..e1f6c95 100644 --- a/lib/HTML/String/Value.pm +++ b/lib/HTML/String/Value.pm @@ -3,48 +3,26 @@ package HTML::String::Value; use strictures 1; use UNIVERSAL::ref; use Safe::Isa; +use Scalar::Util qw(blessed); use Data::Munge; -sub op_factory { - my ($op) = @_; - - return eval q|sub { - my ($self, $str) = @_; - - if ( $str->$_isa(__PACKAGE__) ) { - return $self->unescaped_string | . $op . q| $str->unescaped_string; - } - else { - return $self->unescaped_string | . $op . q| $str; - } - }|; -} - use overload - '""' => 'escaped_string', - '.' => 'dot', - '.=' => 'dot_equals', - '=' => 'clone', - - 'cmp' => op_factory('cmp'), - 'eq' => op_factory('eq'), - '<=>' => op_factory('<=>'), - '==' => op_factory('=='), - '%' => op_factory('%'), - '+' => op_factory('+'), - '-' => op_factory('-'), - '*' => op_factory('*'), - '/' => op_factory('/'), - '**' => op_factory('**'), - '>>' => op_factory('>>'), - '<<' => op_factory('<<'), + '""' => '_hsv_escaped_string', + '.' => '_hsv_dot', + 'bool' => '_hsv_is_true', fallback => 1, ; sub new { + if (blessed($_[0])) { + my $c = shift; + return $c->_hsv_unescaped_string->new(@_); + } my ($class, @raw_parts) = @_; + my $opts = (ref($raw_parts[-1]) eq 'HASH') ? pop(@raw_parts) : {}; + my @parts = map { if (ref($_) eq 'ARRAY') { $_ @@ -55,14 +33,26 @@ sub new { } } @raw_parts; - my $self = bless { parts => \@parts }, $class; + my $self = bless { parts => \@parts, %$opts }, $class; return $self; } -sub escaped_string { +sub AUTOLOAD { + my $invocant = shift; + (my $meth = our $AUTOLOAD) =~ s/.*:://; + die "No such method ${meth} on ${invocant}" + unless ref($invocant); + return $invocant->_hsv_unescaped_string->$meth(@_); +} + +sub _hsv_escaped_string { my $self = shift; + if ($self->{ignore}{scalar caller}) { + return $self->_hsv_unescaped_string; + } + return join '', map +( $_->[1] ? byval { @@ -70,21 +60,22 @@ sub escaped_string { s//>/g; s/"/"/g; + s/'/'/g; } $_->[0] : $_->[0] ), @{$self->{parts}}; } -sub unescaped_string { +sub _hsv_unescaped_string { my $self = shift; return join '', map $_->[0], @{$self->{parts}}; } -sub dot { +sub _hsv_dot { my ($self, $str, $prefix) = @_; - return $self unless $str; + return $self unless defined $str && length $str; my @parts = @{$self->{parts}}; @@ -100,31 +91,212 @@ sub dot { push @parts, @new_parts; } - return ref($self)->new(@parts); + return bless({ %$self, parts => \@parts }, blessed($self)); } -sub dot_equals { - my ($self, $str, $prefix) = @_; +sub _hsv_is_true { + my ($self) = @_; + return 1 if grep $_, map $_->[0], @{$self->{parts}}; +} - return $self unless $str; +# we need to local $@ here because some modules (cough, TT, cough) +# will do a 'die $@ if $@' without realising that it wasn't their eval +# that set it - my @new_parts = ( - $str->$_isa(__PACKAGE__) - ? @{$str->{parts}} - : [ $str, 1 ] +sub isa { + my $self = shift; + return ( + do { + local $@; + eval { blessed($self) and $self->_hsv_unescaped_string->isa(@_) } + } + or $self->SUPER::isa(@_) ); - - push @{$self->{parts}}, @new_parts; - - return $self; } -sub clone { +sub can { my $self = shift; - - return ref($self)->new(@{$self->{parts}}); + return ( + do { + local $@; + eval { blessed($self) and $self->_hsv_unescaped_string->isa(@_) } + } + or $self->SUPER::can(@_) + ); } sub ref { '' } +sub DESTROY { } + 1; + +__END__ + +=head1 NAME + +HTML::String::Value - A scalar hiding as a string on behalf of L + +=head1 SYNOPSIS + +Usually, you'd create this with L's L export +but: + + my $html = HTML::String::Value->new($do_not_escape_this); + + my $html = HTML::String::Value->new([ $do_not_escape_this, 0 ]); + + my $html = HTML::String::Value->new([ $do_escape_this, 1 ]); + + my $html = HTML::String::Value->new($already_an_html_string_value); + + my $html = HTML::String::Value->new(@an_array_of_any_of_the_above); + + my $html = HTML::String::Value->new( + @parts, { ignore => { package_name => 1 } } + ); + +=head1 METHODS + +=head2 new + + my $html = HTML::String::Value->new(@parts, \%options?); + +Each entry in @parts consists of one of: + + 'some text that will not be escaped' + + [ 'some text that will not be escaped', 0 ] + + [ 'text that you DO want to be escaped', 1 ] + + $existing_html_string_value + +Currently, the %options hashref contains only: + + ( + ignore => { 'Package::One' => 1, 'Package::Two' => 1, ... } + ) + +which tells this value object to ignore whether escaping has been requested +for any particular chunk and instead to provide the unescaped version. + +When called on an existing object, does the equivalent of + + $self->_hsv_unescaped_string->new(@args); + +to fit in with the "pretending to be a class name" behaviour provided by +L. + +=head2 _hsv_escaped_string + + $html->_hsv_escaped_string + +Returns a concatenation of all parts of this value with those marked for +escaping escaped, unless the calling package has been specified in the +C option to L. + +If the calling package has been marked as ignoring escaping, returns the +result of L. + +You probably shouldn't be calling this directly. + +=head2 _hsv_unescaped_string + + $html->_hsv_unescaped_string + +Returns a concatenation of all parts of this value with no escaping performed. + +You probably shouldn't be calling this directly. + +=head2 _hsv_dot + + $html->_hsv_dot($other_string, $reversed) + +Returns a new value object consisting of the two values' parts concatenated +together (in reverse if C<$reversed> is true). + +Unlike L, this method defaults to escaping a bare string provided. + +You probably shouldn't be calling this directly. + +=head2 _hsv_is_true + + $html->_hsv_is_true + +Returns true if any of this value's parts are true. + +You probably shouldn't be calling this directly. + +=head2 AUTOLOAD + + $html->method_name(@args) + +This calls the equivalent of + + $html->_hsv_unescaped_string->method_name(@args) + +to allow for class method calls even when the class name has ended up being +turned into a value object. + +=head2 isa + + $html->isa($name) + +This method returns true if either the value or the unescaped string are +isa the supplied C<$name> in order to allow for class method calls even when +the class name has ended up being turned into a value object. + +=head2 can + + $html->can($name) + +This method returns a coderef if either the value or the unescaped string +provides this method; methods on the unescaped string are preferred to allow +for class method calls even when the class name has ended up being +turned into a value object. + +=head2 ref + + $html->ref + +This method always returns C<''>. Since we register ourselves with +L, this means that + + ref($html); + +will also return C<''>, which means that modules loaded after this one will +see a value object as being a plain scalar unless they're explicitly checking +the defined-ness of the return value of C, which probably means that they +wanted to spot people cheating like we're trying to. + +If you have trouble with things trying to treat a value object as something +other than a string, try loading L earlier. + +=head2 DESTROY + +Overridden to do nothing so that L doesn't trap it. + +=head1 OPERATOR OVERLOADS + +=head2 stringification + +Stringification is overloaded to call L + +=head2 concatenation + +Concatentation is overloaded to call L + +=head2 boolification + +Boolification is overloaded to call L + +=head1 AUTHORS + +See L for authors. + +=head1 COPYRIGHT AND LICENSE + +See L for the copyright and license. + +=cut