This is an automated email from the git hooks/post-receive script. fsfs pushed a commit to annotated tag release/0.12-TRIAL in repository libhtml-scrubber-perl.
commit 7a0ae2aa9d076aa311666f8ec64d22690ac437fa Author: Nigel Metheringham <[email protected]> Date: Sat Mar 14 18:06:49 2015 +0000 Apply tidy settings to whole repository Apologies to anyone who has their patches screwed up by this - send them to me vanilla and I will happily fix them up. However by default I use a standard set of perltidy settings across my perl work - maybe just OCD but it helps me. The settings for perltidy etc are included in the repo. For tidyall have a look at L<Code::TidyAll> --- lib/HTML/Scrubber.pm | 364 ++++++++++++++++++++++------------------------- t/01_use.t | 4 +- t/03_more.t | 21 ++- t/04_style_script.t | 23 ++- t/05_pi_comment.t | 23 ++- t/06_scrub_file.t | 2 +- t/07_booleans.t | 66 +++------ t/08_cb_attrs.t | 12 +- t/09_memory_cycle.t | 2 +- t/rt19063_xhtml.t | 6 +- t/rt25477_self_closing.t | 2 +- 11 files changed, 236 insertions(+), 289 deletions(-) diff --git a/lib/HTML/Scrubber.pm b/lib/HTML/Scrubber.pm index 210acce..14f908d 100644 --- a/lib/HTML/Scrubber.pm +++ b/lib/HTML/Scrubber.pm @@ -36,20 +36,20 @@ package HTML::Scrubber; =head1 DESCRIPTION -If you want to "scrub" or "sanitize" html input in a reliable and -flexible fashion, then this module is for you. +If you want to "scrub" or "sanitize" html input in a reliable and flexible +fashion, then this module is for you. I wasn't satisfied with HTML::Sanitizer because it is based on -HTML::TreeBuilder, so I thought I'd write something similar that -works directly with HTML::Parser. +HTML::TreeBuilder, so I thought I'd write something similar that works directly +with HTML::Parser. =head1 METHODS -First a note on documentation: just study the L<EXAMPLE|"EXAMPLE"> below. -It's all the documentation you could need +First a note on documentation: just study the L<EXAMPLE|"EXAMPLE"> below. It's +all the documentation you could need -Also, be sure to read all the comments as well as -L<How does it work?|"How does it work?">. +Also, be sure to read all the comments as well as L<How does it work?|"How does +it work?">. If you're new to perl, good luck to you. @@ -61,55 +61,54 @@ use HTML::Parser 3.47 (); use HTML::Entities; use Scalar::Util ('weaken'); -our( @_scrub, @_scrub_fh ); +our ( @_scrub, @_scrub_fh ); # VERSION # AUTHORITY # my my my my, these here to prevent foolishness like # http://perlmonks.org/index.pl?node_id=251127#Stealing+Lexicals -(@_scrub )= ( \&_scrub, "self, event, tagname, attr, attrseq, text"); -(@_scrub_fh )= ( \&_scrub_fh, "self, event, tagname, attr, attrseq, text"); +(@_scrub) = ( \&_scrub, "self, event, tagname, attr, attrseq, text" ); +(@_scrub_fh) = ( \&_scrub_fh, "self, event, tagname, attr, attrseq, text" ); sub new { my $package = shift; - my $p = HTML::Parser->new( - api_version => 3, - default_h => \@_scrub, - marked_sections => 0, - strict_comment => 0, - unbroken_text => 1, - case_sensitive => 0, + my $p = HTML::Parser->new( + api_version => 3, + default_h => \@_scrub, + marked_sections => 0, + strict_comment => 0, + unbroken_text => 1, + case_sensitive => 0, boolean_attribute_value => undef, - empty_element_tags => 1, + empty_element_tags => 1, ); my $self = { - _p => $p, - _rules => { - '*' => 0, - }, - _comment => 0, - _process => 0, - _r => "", + _p => $p, + _rules => { '*' => 0, }, + _comment => 0, + _process => 0, + _r => "", _optimize => 1, - _script => 0, - _style => 0, + _script => 0, + _style => 0, }; $p->{"\0_s"} = bless $self, $package; - weaken($p->{"\0_s"}); + weaken( $p->{"\0_s"} ); return $self unless @_; - my(%args)= @_; + my (%args) = @_; - for my $f( qw[ default allow deny rules process comment ] ) { + for my $f (qw[ default allow deny rules process comment ]) { next unless exists $args{$f}; - if( ref $args{$f} ) { - $self->$f( @{ $args{$f} } ) ; - } else { - $self->$f( $args{$f} ) ; + if ( ref $args{$f} ) { + $self->$f( @{ $args{$f} } ); + } + else { + $self->$f( $args{$f} ); } } @@ -124,9 +123,8 @@ sub new { =cut sub comment { - return - $_[0]->{_comment} - if @_ == 1; + return $_[0]->{_comment} + if @_ == 1; $_[0]->{_comment} = $_[1]; return; } @@ -138,33 +136,28 @@ sub comment { =cut - sub process { - return - $_[0]->{_process} - if @_ == 1; + return $_[0]->{_process} + if @_ == 1; $_[0]->{_process} = $_[1]; return; } - =head2 script warn "script tags (and everything in between) are supressed" if $p->script; # off by default $p->script( 0 || 1 ); -B<**> Please note that this is implemented -using HTML::Parser's ignore_elements function, -so if C<script> is set to true, -all script tags encountered will be validated like all other tags. +B<**> Please note that this is implemented using HTML::Parser's ignore_elements +function, so if C<script> is set to true, all script tags encountered will be +validated like all other tags. =cut sub script { - return - $_[0]->{_script} - if @_ == 1; + return $_[0]->{_script} + if @_ == 1; $_[0]->{_script} = $_[1]; return; } @@ -175,17 +168,15 @@ sub script { if $p->style; # off by default $p->style( 0 || 1 ); -B<**> Please note that this is implemented -using HTML::Parser's ignore_elements function, -so if C<style> is set to true, -all style tags encountered will be validated like all other tags. +B<**> Please note that this is implemented using HTML::Parser's ignore_elements +function, so if C<style> is set to true, all style tags encountered will be +validated like all other tags. =cut sub style { - return - $_[0]->{_style} - if @_ == 1; + return $_[0]->{_style} + if @_ == 1; $_[0]->{_style} = $_[1]; return; } @@ -198,15 +189,14 @@ sub style { sub allow { my $self = shift; - for my $k(@_){ - $self->{_rules}{lc $k}=1; + for my $k (@_) { + $self->{_rules}{ lc $k } = 1; } - $self->{_optimize} = 1; # each time a rule changes, reoptimize when parse + $self->{_optimize} = 1; # each time a rule changes, reoptimize when parse return; } - =head2 deny $p->deny(qw[ t a g s ]); @@ -216,11 +206,11 @@ sub allow { sub deny { my $self = shift; - for my $k(@_){ - $self->{_rules}{lc $k} = 0; + for my $k (@_) { + $self->{_rules}{ lc $k } = 0; } - $self->{_optimize} = 1; # each time a rule changes, reoptimize when parse + $self->{_optimize} = 1; # each time a rule changes, reoptimize when parse return; } @@ -240,22 +230,22 @@ sub deny { ... ); -Updates set of attribute rules. Each rule can be 1/0, regular expression -or a callback. Values longer than 1 char are treated as regexps. Callback -is called with the following arguments: this object, tag name, attribute -name and attribute value, should return empty list to drop attribute, -C<undef> to keep it without value or a new scalar value. +Updates set of attribute rules. Each rule can be 1/0, regular expression or a +callback. Values longer than 1 char are treated as regexps. Callback is called +with the following arguments: this object, tag name, attribute name and +attribute value, should return empty list to drop attribute, C<undef> to keep +it without value or a new scalar value. =cut -sub rules{ +sub rules { my $self = shift; - my(%rules)= @_; - for my $k(keys %rules) { - $self->{_rules}{lc $k} = $rules{$k}; + my (%rules) = @_; + for my $k ( keys %rules ) { + $self->{_rules}{ lc $k } = $rules{$k}; } - $self->{_optimize} = 1; # each time a rule changes, reoptimize when parse + $self->{_optimize} = 1; # each time a rule changes, reoptimize when parse return; } @@ -274,13 +264,12 @@ sub rules{ =cut sub default { - return - $_[0]->{_rules}{'*'} - if @_ == 1; + return $_[0]->{_rules}{'*'} + if @_ == 1; $_[0]->{_rules}{'*'} = $_[1] if defined $_[1]; $_[0]->{_rules}{'_'} = $_[2] if defined $_[2] and ref $_[2]; - $_[0]->{_optimize} = 1; # each time a rule changes, reoptimize when parse + $_[0]->{_optimize} = 1; # each time a rule changes, reoptimize when parse return; } @@ -297,15 +286,16 @@ sub default { =cut sub scrub_file { - if(@_ > 2){ - return unless defined $_[0]->_out($_[2]); - } else { + if ( @_ > 2 ) { + return unless defined $_[0]->_out( $_[2] ); + } + else { $_[0]->{_p}->handler( default => @_scrub ); } - $_[0]->_optimize() ;#if $_[0]->{_optimize}; + $_[0]->_optimize(); #if $_[0]->{_optimize}; - $_[0]->{_p}->parse_file($_[1]); + $_[0]->{_p}->parse_file( $_[1] ); return delete $_[0]->{_r} unless exists $_[0]->{_out}; print { $_[0]->{_out} } $_[0]->{_r} if length $_[0]->{_r}; @@ -325,15 +315,16 @@ sub scrub_file { =cut sub scrub { - if(@_ > 2){ - return unless defined $_[0]->_out($_[2]); - } else { + if ( @_ > 2 ) { + return unless defined $_[0]->_out( $_[2] ); + } + else { $_[0]->{_p}->handler( default => @_scrub ); } - $_[0]->_optimize();# if $_[0]->{_optimize}; + $_[0]->_optimize(); # if $_[0]->{_optimize}; - $_[0]->{_p}->parse($_[1]) if defined($_[1]); + $_[0]->{_p}->parse( $_[1] ) if defined( $_[1] ); $_[0]->{_p}->eof(); return delete $_[0]->{_r} unless exists $_[0]->{_out}; @@ -341,7 +332,6 @@ sub scrub { return 1; } - =for comment _out $scrubber->_out(*STDOUT) if fileno STDOUT; $scrubber->_out('foo.html') or die "eeek $!"; @@ -349,13 +339,14 @@ sub scrub { =cut sub _out { - my($self, $o ) = @_; + my ( $self, $o ) = @_; - unless( ref $o and ref \$o ne 'GLOB') { + unless ( ref $o and ref \$o ne 'GLOB' ) { open my $F, '>', $o or return; binmode $F; $self->{_out} = $F; - } else { + } + else { $self->{_out} = $o; } @@ -364,7 +355,6 @@ sub _out { return 1; } - =for comment _validate Uses $self->{_rules} to do attribute validation. Takes tag, rule('_' || $tag), attrref. @@ -372,37 +362,36 @@ Takes tag, rule('_' || $tag), attrref. =cut sub _validate { - my($s, $t, $r, $a, $as) = @_; + my ( $s, $t, $r, $a, $as ) = @_; return "<$t>" unless %$a; $r = $s->{_rules}->{$r}; my %f; - for my $k( keys %$a ) { - my $check = exists $r->{$k}? $r->{$k} : exists $r->{'*'}? $r->{'*'} : next; + for my $k ( keys %$a ) { + my $check = exists $r->{$k} ? $r->{$k} : exists $r->{'*'} ? $r->{'*'} : next; - if( ref $check eq 'CODE' ) { + if ( ref $check eq 'CODE' ) { my @v = $check->( $s, $t, $k, $a->{$k}, $a, \%f ); next unless @v; $f{$k} = shift @v; - } elsif( ref $check || length($check) > 1 ) { + } + elsif ( ref $check || length($check) > 1 ) { $f{$k} = $a->{$k} if $a->{$k} =~ m{$check}; - } elsif( $check ) { + } + elsif ($check) { $f{$k} = $a->{$k}; } } - if( %f ){ + if (%f) { my %seen; return "<$t $r>" - if $r = join ' ', - map { - defined $f{$_} - ? qq[$_="].encode_entities($f{$_}).q["] - : $_; # boolean attribute (TODO?) - } grep { - exists $f{$_} and !$seen{$_}++; - } @$as; + if $r = join ' ', map { + defined $f{$_} + ? qq[$_="] . encode_entities( $f{$_} ) . q["] + : $_; # boolean attribute (TODO?) + } grep { exists $f{$_} and !$seen{$_}++; } @$as; } return "<$t>"; @@ -410,9 +399,8 @@ sub _validate { =for comment _scrub_str -I<default> handler, used by both _scrub and _scrub_fh -Moved all the common code (basically all of it) into a single routine for -ease of maintenance +I<default> handler, used by both _scrub and _scrub_fh Moved all the common code +(basically all of it) into a single routine for ease of maintenance =cut @@ -447,10 +435,11 @@ sub _scrub_str { elsif ( $s->{_rules}->{'*'} ) { $place = 1; } - if ( $place ) { + if ($place) { if ( length $text ) { $outstr .= "</$t>"; - } else { + } + else { substr $s->{_r}, -1, 0, ' /'; } } @@ -476,21 +465,21 @@ sub _scrub_str { =for comment _scrub_fh -I<default> handler, does the scrubbing if we're scrubbing out to a file. -Now calls _scrub_str and pushes that out to a file. +I<default> handler, does the scrubbing if we're scrubbing out to a file. Now +calls _scrub_str and pushes that out to a file. =cut sub _scrub_fh { - my $self = $_[0]->{"\0_s"}; + my $self = $_[0]->{"\0_s"}; print { $self->{_out} } $self->{'_r'} if length $self->{_r}; $self->{'_r'} = _scrub_str(@_); } =for comment _scrub -I<default> handler, does the scrubbing if we're returning a giant string. -Now calls _scrub_str and appends that to the output string. +I<default> handler, does the scrubbing if we're returning a giant string. Now +calls _scrub_str and appends that to the output string. =cut @@ -500,51 +489,44 @@ sub _scrub { } sub _optimize { - my($self) = @_; + my ($self) = @_; - my( @ignore_elements ) = grep { not $self->{"_$_"} } qw(script style); - $self->{_p}->ignore_elements(@ignore_elements); # if @ is empty, we reset ;) + my (@ignore_elements) = grep { not $self->{"_$_"} } qw(script style); + $self->{_p}->ignore_elements(@ignore_elements); # if @ is empty, we reset ;) return unless $self->{_optimize}; -#sub allow -# return unless $self->{_optimize}; # till I figure it out (huh) - if( $self->{_rules}{'*'} ){ # default allow - $self->{_p}->report_tags(); # so clear it - } else { + #sub allow + # return unless $self->{_optimize}; # till I figure it out (huh) - my(@reports) = - grep { # report only tags we want - $self->{_rules}{$_} - } keys %{ - $self->{_rules} - }; + if ( $self->{_rules}{'*'} ) { # default allow + $self->{_p}->report_tags(); # so clear it + } + else { - $self->{_p}->report_tags( # default deny, so optimize + my (@reports) = + grep { # report only tags we want + $self->{_rules}{$_} + } keys %{ $self->{_rules} }; + + $self->{_p}->report_tags( # default deny, so optimize @reports ) if @reports; } -# sub deny -# return unless $self->{_optimize}; # till I figure it out (huh) - my(@ignores)= - grep { - not $self->{_rules}{$_} - } grep { - $_ ne '*' - } keys %{ - $self->{_rules} - }; - - $self->{_p}->ignore_tags( # always ignore stuff we don't want + # sub deny + # return unless $self->{_optimize}; # till I figure it out (huh) + my (@ignores) = + grep { not $self->{_rules}{$_} } grep { $_ ne '*' } keys %{ $self->{_rules} }; + + $self->{_p}->ignore_tags( # always ignore stuff we don't want @ignores ) if @ignores; - $self->{_optimize}=0; + $self->{_optimize} = 0; return; } - 1; #print sprintf q[ '%-12s => %s,], "$_'", $h{$_} for sort keys %h;# perl! @@ -554,14 +536,13 @@ sub _optimize { =head1 How does it work? -When a tag is encountered, HTML::Scrubber -allows/denies the tag using the explicit rule if one exists. +When a tag is encountered, HTML::Scrubber allows/denies the tag using the +explicit rule if one exists. If no explicit rule exists, Scrubber applies the default rule. -If an explicit rule exists, -but it's a simple rule(1), -the default attribute rule is applied. +If an explicit rule exists, but it's a simple rule(1), the default attribute +rule is applied. =head2 EXAMPLE @@ -575,24 +556,25 @@ the default attribute rule is applied. my @rules = ( script => 0, - img => { - src => qr{^(?!http://)}i, # only relative image links allowed - alt => 1, # alt attribute allowed - '*' => 0, # deny all other attributes + img => { + src => qr{^(?!http://)}i, # only relative image links allowed + alt => 1, # alt attribute allowed + '*' => 0, # deny all other attributes }, ); my @default = ( - 0 => # default rule, deny all tags - { - '*' => 1, # default rule, allow all attributes - 'href' => qr{^(?:http|https|ftp)://}i, - 'src' => qr{^(?:http|https|ftp)://}i, - # If your perl doesn't have qr - # just use a string with length greater than 1 + 0 => # default rule, deny all tags + { + '*' => 1, # default rule, allow all attributes + 'href' => qr{^(?:http|https|ftp)://}i, + 'src' => qr{^(?:http|https|ftp)://}i, + + # If your perl doesn't have qr + # just use a string with length greater than 1 'cite' => '(?i-xsm:^(?:http|https|ftp):)', 'language' => 0, - 'name' => 1, # could be sneaky, but hey ;) + 'name' => 1, # could be sneaky, but hey ;) 'onblur' => 0, 'onchange' => 0, 'onclick' => 0, @@ -614,14 +596,14 @@ the default attribute rule is applied. 'onunload' => 0, 'src' => 0, 'type' => 0, - } + } ); my $scrubber = HTML::Scrubber->new(); - $scrubber->allow( @allow ); - $scrubber->rules( @rules ); # key/value pairs - $scrubber->default( @default ); - $scrubber->comment(1); # 1 allow, 0 deny + $scrubber->allow(@allow); + $scrubber->rules(@rules); # key/value pairs + $scrubber->default(@default); + $scrubber->comment(1); # 1 allow, 0 deny ## preferred way to create the same object $scrubber = HTML::Scrubber->new( @@ -632,7 +614,7 @@ the default attribute rule is applied. process => 0, ); - require Data::Dumper,die Data::Dumper::Dumper($scrubber) if @ARGV; + require Data::Dumper, die Data::Dumper::Dumper($scrubber) if @ARGV; my $it = q[ <?php echo(" EVIL EVIL EVIL "); ?> <!-- asdf --> @@ -648,21 +630,13 @@ the default attribute rule is applied. </A> <br> ]; - print "#original text",$/, $it, $/; + print "#original text", $/, $it, $/; print - "#scrubbed text (default ", - $scrubber->default(), # no arguments returns the current value - " comment ", - $scrubber->comment(), - " process ", - $scrubber->process(), - " )", - $/, - $scrubber->scrub($it), - $/; + "#scrubbed text (default ", $scrubber->default(), # no arguments returns the current value + " comment ", $scrubber->comment(), " process ", $scrubber->process(), " )", $/, $scrubber->scrub($it), $/; - $scrubber->default(1); # allow all tags by default - $scrubber->comment(0); # deny comments + $scrubber->default(1); # allow all tags by default + $scrubber->comment(0); # deny comments print "#scrubbed text (default ", @@ -671,15 +645,14 @@ the default attribute rule is applied. $scrubber->comment(), " process ", $scrubber->process(), - " )", - $/, + " )", $/, $scrubber->scrub($it), $/; - $scrubber->process(1); # allow process instructions (dangerous) - $default[0] = 1; # allow all tags by default - $default[1]->{'*'} = 0; # deny all attributes by default - $scrubber->default(@default); # set the default again + $scrubber->process(1); # allow process instructions (dangerous) + $default[0] = 1; # allow all tags by default + $default[1]->{'*'} = 0; # deny all attributes by default + $scrubber->default(@default); # set the default again print "#scrubbed text (default ", @@ -688,8 +661,7 @@ the default attribute rule is applied. $scrubber->comment(), " process ", $scrubber->process(), - " )", - $/, + " )", $/, $scrubber->scrub($it), $/; @@ -707,6 +679,14 @@ If you have Test::Inline (and you've installed HTML::Scrubber), try L<HTML::Parser>, L<Test::Inline>. -The HTML::Sanitizer module is no longer available on CPAN. +The C<HTML::Sanitizer> module is no longer available on CPAN. + +=head1 CONTRIBUTING + +If you want to contribute to the development of this module, the code is on +L<GitHub|http://github.com/nigelm/html-scrubber>. You'll need a perl +environment with L<Dist::Zilla>, and if you're just getting started, there's +some documentation on using Vagrant and Perlbrew +L<here|http://mrcaron.github.io/2015/03/06/Perl-CPAN-Pull-Request.html>. =cut diff --git a/t/01_use.t b/t/01_use.t index d31aa24..6bf5370 100644 --- a/t/01_use.t +++ b/t/01_use.t @@ -3,7 +3,7 @@ use Test::More tests => 1; BEGIN { - use_ok( 'HTML::Scrubber' ) || print "Bail out!\n"; + use_ok('HTML::Scrubber') || print "Bail out!\n"; } -diag( "Testing HTML::Scrubber $HTML::Scrubber::VERSION, Perl $], $^X" ); +diag("Testing HTML::Scrubber $HTML::Scrubber::VERSION, Perl $], $^X"); diff --git a/t/03_more.t b/t/03_more.t index 52554ae..4fed43a 100644 --- a/t/03_more.t +++ b/t/03_more.t @@ -1,17 +1,16 @@ # perl Makefile.PL && nmake realclean && cls && perl Makefile.PL && nmake test # cpan-upload -mailto [email protected] -verbose -user podmaster HTML-Scrubber-0.04.tar.gz - use strict; use Test::More tests => 7; BEGIN { $^W = 1 } -use_ok( 'HTML::Scrubber' ); +use_ok('HTML::Scrubber'); -my $s = HTML::Scrubber->new; +my $s = HTML::Scrubber->new; my $html = q[<a href=1>link </a><br><B> bold </B><U> UNDERLINE </U>]; -isa_ok($s, 'HTML::Scrubber'); +isa_ok( $s, 'HTML::Scrubber' ); $s->rules( 'font' => { face => 1 } ); @@ -21,26 +20,24 @@ $s->allow(qw[ U ]); #use Data::Dumper;warn $/,Dumper($s); -is( $s->scrub($html), q[link bold <u> UNDERLINE </u>],'only U'); +is( $s->scrub($html), q[link bold <u> UNDERLINE </u>], 'only U' ); $s->allow(qw[ B U ]); #use Data::Dumper;warn $/,Dumper($s); -is( $s->scrub($html), q[link <b> bold </b><u> UNDERLINE </u>],'B and U'); +is( $s->scrub($html), q[link <b> bold </b><u> UNDERLINE </u>], 'B and U' ); $s->allow(qw[ A B ]); $s->deny('U'); -$s->default(0,{ '*'=> 1}); +$s->default( 0, { '*' => 1 } ); #use Data::Dumper;warn $/,Dumper($s); -is( $s->scrub($html), q[<a href="1">link </a><b> bold </b> UNDERLINE ],'A and B'); +is( $s->scrub($html), q[<a href="1">link </a><b> bold </b> UNDERLINE ], 'A and B' ); -$s = HTML::Scrubber->new( - default => [ 1, { '*' => 1 } ] -); +$s = HTML::Scrubber->new( default => [ 1, { '*' => 1 } ] ); -is( $s->scrub($html), q[<a href="1">link </a><br><b> bold </b><u> UNDERLINE </u>], 'A B U and BR'); +is( $s->scrub($html), q[<a href="1">link </a><br><b> bold </b><u> UNDERLINE </u>], 'A B U and BR' ); #use Data::Dumper;warn $/,Dumper($s); diff --git a/t/04_style_script.t b/t/04_style_script.t index f1c5130..beea13a 100644 --- a/t/04_style_script.t +++ b/t/04_style_script.t @@ -4,24 +4,21 @@ use strict; use Test::More tests => 9; BEGIN { $^W = 1 } -use_ok( 'HTML::Scrubber' ); +use_ok('HTML::Scrubber'); -my $s = HTML::Scrubber->new; +my $s = HTML::Scrubber->new; my $html = q[start <style>in the style</style> middle <script>in the script</script> end]; -isa_ok($s, 'HTML::Scrubber'); - -is( $s->script, 0, 'script off by default'); -is( $s->style, 0, 'style off by default'); -is( $s->scrub($html), 'start middle end', 'default (no style no script)'); +isa_ok( $s, 'HTML::Scrubber' ); +is( $s->script, 0, 'script off by default' ); +is( $s->style, 0, 'style off by default' ); +is( $s->scrub($html), 'start middle end', 'default (no style no script)' ); $s->script(1); -is( $s->script, 1, 'script on'); -is( $s->scrub($html), 'start middle in the script end', 'script off'); - - +is( $s->script, 1, 'script on' ); +is( $s->scrub($html), 'start middle in the script end', 'script off' ); $s->style(1); -is( $s->style, 1, 'style on'); -is( $s->scrub($html), 'start in the style middle in the script end', 'style off and script off'); \ No newline at end of file +is( $s->style, 1, 'style on' ); +is( $s->scrub($html), 'start in the style middle in the script end', 'style off and script off' ); diff --git a/t/05_pi_comment.t b/t/05_pi_comment.t index 7514fe6..40417d3 100644 --- a/t/05_pi_comment.t +++ b/t/05_pi_comment.t @@ -4,24 +4,21 @@ use strict; use Test::More tests => 9; BEGIN { $^W = 1 } -use_ok( 'HTML::Scrubber' ); +use_ok('HTML::Scrubber'); -my $s = HTML::Scrubber->new; +my $s = HTML::Scrubber->new; my $html = q[start <!--comment--> mid1 <?html pi> mid2 <?xml pi?> end]; -isa_ok($s, 'HTML::Scrubber'); - -is( $s->comment, 0, 'comment off by default'); -is( $s->process, 0, 'process off by default'); -is( $s->scrub($html), 'start mid1 mid2 end'); +isa_ok( $s, 'HTML::Scrubber' ); +is( $s->comment, 0, 'comment off by default' ); +is( $s->process, 0, 'process off by default' ); +is( $s->scrub($html), 'start mid1 mid2 end' ); $s->comment(1); -is( $s->comment, 1, 'comment on'); -is( $s->scrub($html), 'start <!--comment--> mid1 mid2 end', 'comment on'); - - +is( $s->comment, 1, 'comment on' ); +is( $s->scrub($html), 'start <!--comment--> mid1 mid2 end', 'comment on' ); $s->process(1); -is( $s->process, 1, 'process on'); -is( $s->scrub($html), 'start <!--comment--> mid1 <?html pi> mid2 <?xml pi?> end', 'process on'); \ No newline at end of file +is( $s->process, 1, 'process on' ); +is( $s->scrub($html), 'start <!--comment--> mid1 <?html pi> mid2 <?xml pi?> end', 'process on' ); diff --git a/t/06_scrub_file.t b/t/06_scrub_file.t index 5a9612b..a970be5 100644 --- a/t/06_scrub_file.t +++ b/t/06_scrub_file.t @@ -17,7 +17,7 @@ my $tmpdir = tempdir( CLEANUP => 1 ); SKIP: { skip "no writable temporary directory found", 6 unless length $tmpdir - and -d $tmpdir; + and -d $tmpdir; my $template = 'html-scrubber-XXXX'; my ( $tfh, $tmpfile ) = tempfile( $template, DIR => $tmpdir, SUFFIX => '.html' ); diff --git a/t/07_booleans.t b/t/07_booleans.t index a36b65a..713f7dc 100644 --- a/t/07_booleans.t +++ b/t/07_booleans.t @@ -5,72 +5,52 @@ use File::Spec; use Test::More tests => 9; BEGIN { $^W = 1 } -use_ok( 'HTML::Scrubber' ); +use_ok('HTML::Scrubber'); use HTML::Scrubber; -my @allow = qw[ br hr b a option button th ]; +my @allow = qw[ br hr b a option button th ]; my $scrubber = HTML::Scrubber->new(); -$scrubber->allow( @allow ); +$scrubber->allow(@allow); $scrubber->default( - undef, # don't change - { # default attribute rules - '/' => 1, # '/' ia boolean (stand-alone) attribute - 'pie' => 1, + undef, # don't change + { # default attribute rules + '/' => 1, # '/' ia boolean (stand-alone) attribute + 'pie' => 1, 'selected' => 1, 'disabled' => 1, - 'nowrap' => 1, + 'nowrap' => 1, } ); -ok( $scrubber, "got scrubber"); - -test( -q~<br> hi <br /> <a href= >~, -q~<br> hi <br /> <a>~, -"br /"); +ok( $scrubber, "got scrubber" ); +test( q~<br> hi <br /> <a href= >~, q~<br> hi <br /> <a>~, "br /" ); -test( -q~<option selected> flicka <a href=>~, -q~<option selected> flicka <a>~, -"selected"); +test( q~<option selected> flicka <a href=>~, q~<option selected> flicka <a>~, "selected" ); test( -q~<button name="flicka" Disabled > the flicker </button>~, -q~<button disabled> the flicker </button>~, -"disabled"); - - -test( -q~<button disabled > dd </button>~, -q~<button disabled> dd </button>~, -"dd"); - + q~<button name="flicka" Disabled > the flicker </button>~, + q~<button disabled> the flicker </button>~, + "disabled" +); -test( -q~<a disabled pie=6> | </a>~, -q~<a disabled pie="6"> | </a>~, -"pie"); +test( q~<button disabled > dd </button>~, q~<button disabled> dd </button>~, "dd" ); +test( q~<a disabled pie=6> | </a>~, q~<a disabled pie="6"> | </a>~, "pie" ); test( -q~<a selected disabled selected pie pie pie disabled /> | </a>~, -q~<a selected disabled pie /> | </a>~, -"selected pie"); - + q~<a selected disabled selected pie pie pie disabled /> | </a>~, + q~<a selected disabled pie /> | </a>~, + "selected pie" +); #dependent on version of HTML::Parser, after 0.36 1st is returned (ie pie) #test(q~<br pie pie=4>~, q~<br pie="4">~, 'repeated mixed'); -test( q~<th nowrap=nowrap>~, -q~<th nowrap="nowrap">~, -"th nowrap=nowrap"); - - - +test( q~<th nowrap=nowrap>~, q~<th nowrap="nowrap">~, "th nowrap=nowrap" ); sub test { - my ($in, $out, $name) = @_; + my ( $in, $out, $name ) = @_; is( $scrubber->scrub($in), $out, $name ); } diff --git a/t/08_cb_attrs.t b/t/08_cb_attrs.t index f7545da..7fb874a 100644 --- a/t/08_cb_attrs.t +++ b/t/08_cb_attrs.t @@ -9,20 +9,20 @@ my $scrubber = HTML::Scrubber->new; $scrubber->default(1); my $cb = sub { - my ($self, $tag, $attr, $avalue) = @_; + my ( $self, $tag, $attr, $avalue ) = @_; my %h = ( drop => [], bool => [undef], empty => [''], foo => ['bar'], ); - return @{ $h{ $avalue } }; + return @{ $h{$avalue} }; }; $scrubber->rules( p => { a => $cb } ); -is($scrubber->scrub('<p a="drop">'), '<p>', "correct result"); -is($scrubber->scrub('<p a="bool">'), '<p a>', "correct result"); -is($scrubber->scrub('<p a="empty">'), '<p a="">', "correct result"); -is($scrubber->scrub('<p a="foo">'), '<p a="bar">', "correct result"); +is( $scrubber->scrub('<p a="drop">'), '<p>', "correct result" ); +is( $scrubber->scrub('<p a="bool">'), '<p a>', "correct result" ); +is( $scrubber->scrub('<p a="empty">'), '<p a="">', "correct result" ); +is( $scrubber->scrub('<p a="foo">'), '<p a="bar">', "correct result" ); done_testing; diff --git a/t/09_memory_cycle.t b/t/09_memory_cycle.t index 4fe973c..d49b97e 100644 --- a/t/09_memory_cycle.t +++ b/t/09_memory_cycle.t @@ -6,4 +6,4 @@ use HTML::Scrubber; my $scrubber = HTML::Scrubber->new(); -memory_cycle_ok($scrubber, "Scrubber has no cycles"); +memory_cycle_ok( $scrubber, "Scrubber has no cycles" ); diff --git a/t/rt19063_xhtml.t b/t/rt19063_xhtml.t index 39f6874..463e966 100644 --- a/t/rt19063_xhtml.t +++ b/t/rt19063_xhtml.t @@ -9,10 +9,6 @@ use HTML::Scrubber; my $scrubber = HTML::Scrubber->new; $scrubber->default(1); -is( - $scrubber->scrub('<hr/><hr><hr /><hr></hr>'), - '<hr /><hr><hr /><hr></hr>', - "correct result" -); +is( $scrubber->scrub('<hr/><hr><hr /><hr></hr>'), '<hr /><hr><hr /><hr></hr>', "correct result" ); done_testing; diff --git a/t/rt25477_self_closing.t b/t/rt25477_self_closing.t index a939caa..4dee117 100644 --- a/t/rt25477_self_closing.t +++ b/t/rt25477_self_closing.t @@ -18,7 +18,7 @@ my $scrubbed = $scrubber->scrub( <<'END' ); <b>two</b> END -is($scrubbed, <<'END', "correct result"); +is( $scrubbed, <<'END', "correct result" ); <b>one</b> -- Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libhtml-scrubber-perl.git _______________________________________________ Pkg-perl-cvs-commits mailing list [email protected] http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/pkg-perl-cvs-commits
