' - * attribute rule can be a regexp - callbacks in rules to check or adjust attributes with custom code (RT15747) 0.09 2011-04-01 16:35:50 Europe/London - Basic conversion to Dist::Zilla/git - Tidies to keep Perl::Critic happier - Removed use of naked filehandles - Reworked tests to not use predicable temp file name - Collapsed duplicate code to a single version - Various documentation tweaks - Change of maintainer as PODMASTER cannot be contacted 0.08 Thu Apr 1 14:14:38 2004 - removed test which relied on stuff that changed in HTML-Parser-3.36
bold missing
'); # output is:bold
# more complex input my $html = q[a => link br =>
b => bold u => UNDERLINE ]; print $scrubber->scrub($html); $scrubber->deny( qw[ p b i u hr br ] ); print $scrubber->scrub($html); DESCRIPTION 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. METHODS First a note on documentation: just study the EXAMPLE below. It's all the documentation you could need Also, be sure to read all the comments as well as How does it work?. If you're new to perl, good luck to you. comment warn "comments are ", $p->comment ? 'allowed' : 'not allowed'; $p->comment(0); # off by default process warn "process instructions are ", $p->process ? 'allowed' : 'not allowed'; $p->process(0); # off by default script warn "script tags (and everything in between) are supressed" if $p->script; # off by default $p->script( 0 || 1 ); ** Please note that this is implemented using HTML::Parser's ignore_elements function, so if script is set to true, all script tags encountered will be validated like all other tags. style warn "style tags (and everything in between) are supressed" if $p->style; # off by default $p->style( 0 || 1 ); ** Please note that this is implemented using HTML::Parser's ignore_elements function, so if style is set to true, all style tags encountered will be validated like all other tags. allow $p->allow(qw[ t a g s ]); deny $p->deny(qw[ t a g s ]); rules $p->rules( img => { src => qr{^(?!http://)}i, # only relative image links allowed alt => 1, # alt attribute allowed '*' => 0, # deny all other attributes }, a => { href => sub { ... }, # check or adjust with a callback }, b => 1, ... ); 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, undef to keep it without value or a new scalar value. default print "default is ", $p->default(); $p->default(1); # allow tags by default $p->default( undef, # don't change { # default attribute rules '*' => 1, # allow attributes by default } ); scrub_file $html = $scrubber->scrub_file('foo.html'); ## returns giant string die "Eeek $!" unless defined $html; ## opening foo.html may have failed $scrubber->scrub_file('foo.html', 'new.html') or die "Eeek $!"; $scrubber->scrub_file('foo.html', *STDOUT) or die "Eeek $!" if fileno STDOUT; scrub print $scrubber->scrub($html); ## returns giant string $scrubber->scrub($html, 'new.html') or die "Eeek $!"; $scrubber->scrub($html', *STDOUT) or die "Eeek $!" if fileno STDOUT; 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 default handler, does the scrubbing if we're scrubbing out to a file. Now calls _scrub_str and pushes that out to a file. default handler, does the scrubbing if we're returning a giant string. Now calls _scrub_str and appends that to the output string. How does it work? 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. EXAMPLE #!/usr/bin/perl -w use HTML::Scrubber; use strict; my @allow = qw[ br hr b a ]; my @rules = ( script => 0, 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 'cite' => '(?i-xsm:^(?:http|https|ftp):)', 'language' => 0, 'name' => 1, # could be sneaky, but hey ;) 'onblur' => 0, 'onchange' => 0, 'onclick' => 0, 'ondblclick' => 0, 'onerror' => 0, 'onfocus' => 0, 'onkeydown' => 0, 'onkeypress' => 0, 'onkeyup' => 0, 'onload' => 0, 'onmousedown' => 0, 'onmousemove' => 0, 'onmouseout' => 0, 'onmouseover' => 0, 'onmouseup' => 0, 'onreset' => 0, 'onselect' => 0, 'onsubmit' => 0, '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 ## preferred way to create the same object $scrubber = HTML::Scrubber->new( allow => \@allow, rules => \@rules, default => \@default, comment => 1, process => 0, ); require Data::Dumper, die Data::Dumper::Dumper($scrubber) if @ARGV; my $it = q[
IN ITALICS WITH FAKE="attribute"
IN BOLD
HREF=JAVA <!>
]; 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), $/; $scrubber->default(1); # allow all tags by default $scrubber->comment(0); # deny comments print "#scrubbed text (default ", $scrubber->default(), " comment ", $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 print "#scrubbed text (default ", $scrubber->default(), " comment ", $scrubber->comment(), " process ", $scrubber->process(), " )", $/, $scrubber->scrub($it), $/; FUN If you have Test::Inline (and you've installed HTML::Scrubber), try pod2test Scrubber.pm >scrubber.t perl scrubber.t SEE ALSO HTML::Parser, Test::Inline. The HTML::Sanitizer module is no longer available on CPAN. VERSION REQUIREMENTS As of version 0.14 I have added a perl minimum version requirement of 5.8. This is basically due to failures on the smokers perl 5.6 installations - which appears to be down to installation mechanisms and requirements. Since I don't want to spend the time supporting a version that is so old (and may not work for reasons on UTF support etc), I have added a use 5.008; to the main module. If this is problematic I am very willing to accept patches to fix this up, although I do not personally see a good reason to support a release that has been obsolete for 13 years. CONTRIBUTING If you want to contribute to the development of this module, the code is on GitHub
bold < underlined LINK ]; my $scrubber = HTML::Scrubber->new(); ok($scrubber); # test 2 ok( !$scrubber->default() ); # test 3 ok( !$scrubber->comment() ); # test 4 ok( !$scrubber->process() ); # test 5 ok( !$scrubber->allow(qw[ p b i u hr br ]) ); # test 6 $scrubber = $scrubber->scrub($html); ok($scrubber); # test 7 ok( $scrubber !~ /href/i ); # test 8 ok( $scrubber !~ /Align/i ); # test 9 ok( $scrubber !~ /\Q 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 mid1 mid2 end', 'comment on' ); $s->process(1); is( $s->process, 1, 'process on' ); is( $s->scrub($html), 'start mid1 mid2 end', 'process on' ); HTML-Scrubber-0.15/t/06_scrub_file.t 000644 000765 000024 00000003421 12606215076 017270 0 ustar 00nigel staff 000000 000000 # perl Makefile.PL && nmake realclean && cls && perl Makefile.PL && nmake test use strict; use File::Temp qw/ tempfile tempdir /; use Test::More tests => 10; BEGIN { $^W = 1 } use_ok('HTML::Scrubber'); my $s = HTML::Scrubber->new; my $html = q[
hi
start mid1 mid2 end];
isa_ok( $s, 'HTML::Scrubber' );
my $tmpdir = tempdir( CLEANUP => 1 );
SKIP: {
skip "no writable temporary directory found", 6
unless length $tmpdir
and -d $tmpdir;
my $template = 'html-scrubber-XXXX';
my ( $tfh, $tmpfile ) = tempfile( $template, DIR => $tmpdir, SUFFIX => '.html' );
my $r = $s->scrub( $html, $tmpfile );
$r = "Error: \$@=$@ \$!=$!" unless $r;
is( $r, 1, "scrub(\$html,\$tmpfile=$tmpfile)" );
local *FILIS;
open FILIS, "+>$tmpfile" or die "can't write to $tmpfile";
$r = $s->scrub( $html, \*FILIS );
$r = "Error: \$@=$@ \$!=$!" unless $r;
is( $r, 1, q[scrub($html,\*FILIS)] );
seek *FILIS, 0, 0;
$r = join '', readline *FILIS;
is( $r, "histart mid1 mid2 end", "FILIS has the right stuff" );
is( close(FILIS), 1, q[close(FILIS)] );
my ( $tfh2, $tmpfile2 ) = tempfile( $template, DIR => $tmpdir, SUFFIX => '.html' );
$r = $s->scrub_file( $tmpfile, "$tmpfile2" );
$r = "Error: \$@=$@ \$!=$!" unless $r;
is( $r, 1, qq[scrub_file(\$tmpfile,"\$tmpfile2"=$tmpfile2)] );
open FILIS, "+>$tmpfile2" or die "can't write to $tmpfile";
$r = $s->scrub_file( $tmpfile, \*FILIS );
$r = "Error: \$@=$@ \$!=$!" unless $r;
is( $r, 1, q[scrub_file($tmpfile,\*FILIS)] );
seek *FILIS, 0, 0;
$r = join '', readline *FILIS;
is( $r, "histart mid1 mid2 end", "FILIS has the right stuff" );
is( close(FILIS), 1, q[close(FILIS)] );
}
HTML-Scrubber-0.15/t/07_booleans.t 000644 000765 000024 00000002671 12606215076 016764 0 ustar 00nigel staff 000000 000000 # 07_booleans.t
use strict;
use File::Spec;
use Test::More tests => 9;
BEGIN { $^W = 1 }
use_ok('HTML::Scrubber');
use HTML::Scrubber;
my @allow = qw[ br hr b a option button th ];
my $scrubber = HTML::Scrubber->new();
$scrubber->allow(@allow);
$scrubber->default(
undef, # don't change
{ # default attribute rules
'/' => 1, # '/' ia boolean (stand-alone) attribute
'pie' => 1,
'selected' => 1,
'disabled' => 1,
'nowrap' => 1,
}
);
ok( $scrubber, "got scrubber" );
test( q~
hi
~, q~
hi
~, "br /" );
test( q~~,
"selected pie"
);
#dependent on version of HTML::Parser, after 0.36 1st is returned (ie pie)
#test(q~
~, q~
~, 'repeated mixed');
test( q~
'), '
', "correct result" ); is( $scrubber->scrub('
'), '
', "correct result" ); is( $scrubber->scrub('
'), '
', "correct result" ); is( $scrubber->scrub('
'), '
', "correct result" );
done_testing;
HTML-Scrubber-0.15/t/09_memory_cycle.t 000644 000765 000024 00000000252 12606215076 017644 0 ustar 00nigel staff 000000 000000
use Test::More tests => 1;
use Test::Memory::Cycle;
use HTML::Scrubber;
my $scrubber = HTML::Scrubber->new();
memory_cycle_ok( $scrubber, "Scrubber has no cycles" );
HTML-Scrubber-0.15/t/09_no_scrub_warnings.t 000644 000765 000024 00000000615 12606215076 020702 0 ustar 00nigel staff 000000 000000 use strict;
use warnings;
use Test::More;
use_ok('HTML::Scrubber');
use HTML::Scrubber;
my $scrubber = HTML::Scrubber->new;
# really one of the Test:: warnings would be better here
# but lets keep this simple
local $SIG{__WARN__} = sub {
fail("warning raised by scrub: @_");
};
ok( !$scrubber->scrub );
ok( !$scrubber->scrub('') );
ok( !$scrubber->scrub('') );
done_testing;
HTML-Scrubber-0.15/t/author-critic.t 000644 000765 000024 00000000666 12606215076 017433 0 ustar 00nigel staff 000000 000000 #!perl
BEGIN {
unless ($ENV{AUTHOR_TESTING}) {
require Test::More;
Test::More::plan(skip_all => 'these tests are for testing by the author');
}
}
use strict;
use warnings;
use Test::More;
use English qw(-no_match_vars);
eval "use Test::Perl::Critic";
plan skip_all => 'Test::Perl::Critic required to criticise code' if $@;
Test::Perl::Critic->import( -profile => "perlcritic.rc" ) if -e "perlcritic.rc";
all_critic_ok();
HTML-Scrubber-0.15/t/author-eol.t 000644 000765 000024 00000001476 12606215076 016735 0 ustar 00nigel staff 000000 000000
BEGIN {
unless ($ENV{AUTHOR_TESTING}) {
require Test::More;
Test::More::plan(skip_all => 'these tests are for testing by the author');
}
}
use strict;
use warnings;
# this test was generated with Dist::Zilla::Plugin::Test::EOL 0.18
use Test::More 0.88;
use Test::EOL;
my @files = (
'lib/HTML/Scrubber.pm',
't/00-compile.t',
't/000-report-versions.t',
't/01_use.t',
't/02_basic.t',
't/03_more.t',
't/04_style_script.t',
't/05_pi_comment.t',
't/06_scrub_file.t',
't/07_booleans.t',
't/08_cb_attrs.t',
't/09_memory_cycle.t',
't/09_no_scrub_warnings.t',
't/jvn53973084.t',
't/rt19063_xhtml.t',
't/rt25477_self_closing.t',
't/rt72659_utf8.t',
't/rt79044_multiple.t'
);
eol_unix_ok($_, { trailing_whitespace => 1 }) foreach @files;
done_testing;
HTML-Scrubber-0.15/t/author-no-tabs.t 000644 000765 000024 00000001444 12606215076 017514 0 ustar 00nigel staff 000000 000000
BEGIN {
unless ($ENV{AUTHOR_TESTING}) {
require Test::More;
Test::More::plan(skip_all => 'these tests are for testing by the author');
}
}
use strict;
use warnings;
# this test was generated with Dist::Zilla::Plugin::Test::NoTabs 0.15
use Test::More 0.88;
use Test::NoTabs;
my @files = (
'lib/HTML/Scrubber.pm',
't/00-compile.t',
't/000-report-versions.t',
't/01_use.t',
't/02_basic.t',
't/03_more.t',
't/04_style_script.t',
't/05_pi_comment.t',
't/06_scrub_file.t',
't/07_booleans.t',
't/08_cb_attrs.t',
't/09_memory_cycle.t',
't/09_no_scrub_warnings.t',
't/jvn53973084.t',
't/rt19063_xhtml.t',
't/rt25477_self_closing.t',
't/rt72659_utf8.t',
't/rt79044_multiple.t'
);
notabs_ok($_) foreach @files;
done_testing;
HTML-Scrubber-0.15/t/author-pod-spell.t 000644 000765 000024 00000000710 12606215076 020043 0 ustar 00nigel staff 000000 000000
BEGIN {
unless ($ENV{AUTHOR_TESTING}) {
require Test::More;
Test::More::plan(skip_all => 'these tests are for testing by the author');
}
}
use strict;
use warnings;
use Test::More;
# generated by Dist::Zilla::Plugin::Test::PodSpelling 2.006009
use Test::Spelling 0.12;
use Pod::Wordlist;
add_stopwords();
all_pod_files_spelling_ok( qw( bin lib ) );
__DATA__
Ruslan
Zakirov
Nigel
Metheringham
nigelm
podmaster
2003
lib
HTML
Scrubber
HTML-Scrubber-0.15/t/jvn53973084.t 000644 000765 000024 00000001112 12606215076 016305 0 ustar 00nigel staff 000000 000000 # Tests related to JVN53973084
use strict;
use warnings;
use Test::More;
use_ok('HTML::Scrubber');
my @allow = qw[
hr
];
my $html_1 = q[ one two three four tag
$scrubber->allow();
foreach my $datum (@data) {
my $result = $datum;
$datum =~ s|||g; # strip with regexp - yay!
is( $scrubber->scrub($datum), $datum, 'Test processed' );
}
done_testing;
HTML-Scrubber-0.15/lib/HTML/ 000755 000765 000024 00000000000 12606215076 015530 5 ustar 00nigel staff 000000 000000 HTML-Scrubber-0.15/lib/HTML/Scrubber.pm 000644 000765 000024 00000047111 12606215076 017641 0 ustar 00nigel staff 000000 000000 package HTML::Scrubber;
# ABSTRACT: Perl extension for scrubbing/sanitizing html
use 5.008; # enforce minimum perl version of 5.8
use strict;
use warnings;
use HTML::Parser 3.47 ();
use HTML::Entities;
use Scalar::Util ('weaken');
our ( @_scrub, @_scrub_fh );
our $VERSION = '0.15'; # VERSION
our $AUTHORITY = 'cpan:NIGELM'; # 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" );
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,
boolean_attribute_value => undef,
empty_element_tags => 1,
);
my $self = {
_p => $p,
_rules => { '*' => 0, },
_comment => 0,
_process => 0,
_r => "",
_optimize => 1,
_script => 0,
_style => 0,
};
$p->{"\0_s"} = bless $self, $package;
weaken( $p->{"\0_s"} );
return $self unless @_;
my (%args) = @_;
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} );
}
}
return $self;
}
sub comment {
return $_[0]->{_comment}
if @_ == 1;
$_[0]->{_comment} = $_[1];
return;
}
sub process {
return $_[0]->{_process}
if @_ == 1;
$_[0]->{_process} = $_[1];
return;
}
sub script {
return $_[0]->{_script}
if @_ == 1;
$_[0]->{_script} = $_[1];
return;
}
sub style {
return $_[0]->{_style}
if @_ == 1;
$_[0]->{_style} = $_[1];
return;
}
sub allow {
my $self = shift;
for my $k (@_) {
$self->{_rules}{ lc $k } = 1;
}
$self->{_optimize} = 1; # each time a rule changes, reoptimize when parse
return;
}
sub deny {
my $self = shift;
for my $k (@_) {
$self->{_rules}{ lc $k } = 0;
}
$self->{_optimize} = 1; # each time a rule changes, reoptimize when parse
return;
}
sub rules {
my $self = shift;
my (%rules) = @_;
for my $k ( keys %rules ) {
$self->{_rules}{ lc $k } = $rules{$k};
}
$self->{_optimize} = 1; # each time a rule changes, reoptimize when parse
return;
}
sub default {
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
return;
}
sub scrub_file {
if ( @_ > 2 ) {
return unless defined $_[0]->_out( $_[2] );
}
else {
$_[0]->{_p}->handler( default => @_scrub );
}
$_[0]->_optimize(); #if $_[0]->{_optimize};
$_[0]->{_p}->parse_file( $_[1] );
return delete $_[0]->{_r} unless exists $_[0]->{_out};
print { $_[0]->{_out} } $_[0]->{_r} if length $_[0]->{_r};
delete $_[0]->{_out};
return 1;
}
sub scrub {
if ( @_ > 2 ) {
return unless defined $_[0]->_out( $_[2] );
}
else {
$_[0]->{_p}->handler( default => @_scrub );
}
$_[0]->_optimize(); # if $_[0]->{_optimize};
$_[0]->{_p}->parse( $_[1] ) if defined( $_[1] );
$_[0]->{_p}->eof();
return delete $_[0]->{_r} unless exists $_[0]->{_out};
delete $_[0]->{_out};
return 1;
}
sub _out {
my ( $self, $o ) = @_;
unless ( ref $o and ref \$o ne 'GLOB' ) {
open my $F, '>', $o or return;
binmode $F;
$self->{_out} = $F;
}
else {
$self->{_out} = $o;
}
$self->{_p}->handler( default => @_scrub_fh );
return 1;
}
sub _validate {
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;
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 ) {
$f{$k} = $a->{$k} if $a->{$k} =~ m{$check};
}
elsif ($check) {
$f{$k} = $a->{$k};
}
}
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;
}
return "<$t>";
}
sub _scrub_str {
my ( $p, $e, $t, $a, $as, $text ) = @_;
my $s = $p->{"\0_s"};
my $outstr = '';
if ( $e eq 'start' ) {
if ( exists $s->{_rules}->{$t} ) # is there a specific rule
{
if ( ref $s->{_rules}->{$t} ) # is it complicated?(not simple;)
{
$outstr .= $s->_validate( $t, $t, $a, $as );
}
elsif ( $s->{_rules}->{$t} ) # validate using default attribute rule
{
$outstr .= $s->_validate( $t, '_', $a, $as );
}
}
elsif ( $s->{_rules}->{'*'} ) # default allow tags
{
$outstr .= $s->_validate( $t, '_', $a, $as );
}
}
elsif ( $e eq 'end' ) {
my $place = 0;
if ( exists $s->{_rules}->{$t} ) {
$place = 1 if $s->{_rules}->{$t};
}
elsif ( $s->{_rules}->{'*'} ) {
$place = 1;
}
if ($place) {
if ( length $text ) {
$outstr .= "";
}
else {
substr $s->{_r}, -1, 0, ' /';
}
}
}
elsif ( $e eq 'comment' ) {
if ( $s->{_comment} ) {
# only copy comments through if they are well formed...
$outstr .= $text if ( $text =~ m|^$|ms );
}
}
elsif ( $e eq 'process' ) {
$outstr .= $text if $s->{_process};
}
elsif ( $e eq 'text' or $e eq 'default' ) {
$text =~ s//>/g;
$outstr .= $text;
}
elsif ( $e eq 'start_document' ) {
$outstr = "";
}
return $outstr;
}
sub _scrub_fh {
my $self = $_[0]->{"\0_s"};
print { $self->{_out} } $self->{'_r'} if length $self->{_r};
$self->{'_r'} = _scrub_str(@_);
}
sub _scrub {
$_[0]->{"\0_s"}->{_r} .= _scrub_str(@_);
}
sub _optimize {
my ($self) = @_;
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 {
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
@ignores
) if @ignores;
$self->{_optimize} = 0;
return;
}
1;
#print sprintf q[ '%-12s => %s,], "$_'", $h{$_} for sort keys %h;# perl!
#perl -ne"chomp;print $_;print qq'\t\t# test ', ++$a if /ok\(/;print $/" test.pl >test2.pl
#perl -ne"chomp;print $_;if( /ok\(/ ){s/\#test \d+$//;print qq'\t\t# test ', ++$a }print $/" test.pl >test2.pl
#perl -ne"chomp;if(/ok\(/){s/# test .*$//;print$_,qq'\t\t# test ',++$a}else{print$_}print$/" test.pl >test2.pl
__END__
=pod
=for stopwords html cpan callback homepage Perlbrew perltidy respository
=head1 NAME
HTML::Scrubber - Perl extension for scrubbing/sanitizing html
=head1 VERSION
version 0.15
=head1 SYNOPSIS
use HTML::Scrubber;
my $scrubber = HTML::Scrubber->new( allow => [ qw[ p b i u hr br ] ] );
print $scrubber->scrub(' bold missing bold
abc];
my $html_2 = q[new( allow => \@allow, comment => $comment_value );
is( $scrubber->scrub($html_1), '
abc', "correct result (1) - with comment => $comment_value" );
is( $scrubber->scrub($html_2), '', "correct result (2) - with comment => $comment_value" );
}
done_testing;
HTML-Scrubber-0.15/t/release-dist-manifest.t 000644 000765 000024 00000000466 12606215076 021041 0 ustar 00nigel staff 000000 000000 #!perl
BEGIN {
unless ($ENV{RELEASE_TESTING}) {
require Test::More;
Test::More::plan(skip_all => 'these tests are for release candidate testing');
}
}
use Test::More;
eval "use Test::DistManifest";
plan skip_all => "Test::DistManifest required for testing the manifest"
if $@;
manifest_ok();
HTML-Scrubber-0.15/t/release-distmeta.t 000644 000765 000024 00000000430 12606215076 020073 0 ustar 00nigel staff 000000 000000 #!perl
BEGIN {
unless ($ENV{RELEASE_TESTING}) {
require Test::More;
Test::More::plan(skip_all => 'these tests are for release candidate testing');
}
}
# This file was automatically generated by Dist::Zilla::Plugin::MetaTests.
use Test::CPAN::Meta;
meta_yaml_ok();
HTML-Scrubber-0.15/t/release-has-version.t 000644 000765 000024 00000000473 12606215076 020526 0 ustar 00nigel staff 000000 000000 #!perl
BEGIN {
unless ($ENV{RELEASE_TESTING}) {
require Test::More;
Test::More::plan(skip_all => 'these tests are for release candidate testing');
}
}
use Test::More;
eval "use Test::HasVersion";
plan skip_all => "Test::HasVersion required for testing version numbers"
if $@;
all_pm_version_ok();
HTML-Scrubber-0.15/t/release-minimum-version.t 000644 000765 000024 00000000526 12606215076 021425 0 ustar 00nigel staff 000000 000000 #!perl
BEGIN {
unless ($ENV{RELEASE_TESTING}) {
require Test::More;
Test::More::plan(skip_all => 'these tests are for release candidate testing');
}
}
use Test::More;
eval "use Test::MinimumVersion";
plan skip_all => "Test::MinimumVersion required for testing minimum versions"
if $@;
all_minimum_version_from_metayml_ok();
HTML-Scrubber-0.15/t/release-pod-syntax.t 000644 000765 000024 00000000456 12606215076 020377 0 ustar 00nigel staff 000000 000000 #!perl
BEGIN {
unless ($ENV{RELEASE_TESTING}) {
require Test::More;
Test::More::plan(skip_all => 'these tests are for release candidate testing');
}
}
# This file was automatically generated by Dist::Zilla::Plugin::PodSyntaxTests.
use Test::More;
use Test::Pod 1.41;
all_pod_files_ok();
HTML-Scrubber-0.15/t/release-portability.t 000644 000765 000024 00000000535 12606215076 020631 0 ustar 00nigel staff 000000 000000 #!perl
BEGIN {
unless ($ENV{RELEASE_TESTING}) {
require Test::More;
Test::More::plan(skip_all => 'these tests are for release candidate testing');
}
}
use strict;
use warnings;
use Test::More;
eval 'use Test::Portability::Files';
plan skip_all => 'Test::Portability::Files required for testing portability'
if $@;
run_tests();
HTML-Scrubber-0.15/t/release-synopsis.t 000644 000765 000024 00000000316 12606215076 020153 0 ustar 00nigel staff 000000 000000 #!perl
BEGIN {
unless ($ENV{RELEASE_TESTING}) {
require Test::More;
Test::More::plan(skip_all => 'these tests are for release candidate testing');
}
}
use Test::Synopsis;
all_synopsis_ok();
HTML-Scrubber-0.15/t/release-unused-vars.t 000644 000765 000024 00000000620 12606215076 020536 0 ustar 00nigel staff 000000 000000 #!perl
BEGIN {
unless ($ENV{RELEASE_TESTING}) {
require Test::More;
Test::More::plan(skip_all => 'these tests are for release candidate testing');
}
}
use Test::More 0.96 tests => 1;
eval { require Test::Vars };
SKIP: {
skip 1 => 'Test::Vars required for testing for unused vars'
if $@;
Test::Vars->import;
subtest 'unused vars' => sub {
all_vars_ok();
};
};
HTML-Scrubber-0.15/t/rt19063_xhtml.t 000644 000765 000024 00000000551 12606215076 017113 0 ustar 00nigel staff 000000 000000 # Tests related to RT25477 - https://rt.cpan.org/Public/Bug/Display.html?id=25477
use strict;
use warnings;
use File::Spec;
use Test::More;
use_ok('HTML::Scrubber');
use HTML::Scrubber;
my $scrubber = HTML::Scrubber->new;
$scrubber->default(1);
is( $scrubber->scrub('
'), '
', "correct result" );
done_testing;
HTML-Scrubber-0.15/t/rt25477_self_closing.t 000644 000765 000024 00000001000 12606215076 020422 0 ustar 00nigel staff 000000 000000 # Tests related to RT25477 - https://rt.cpan.org/Public/Bug/Display.html?id=25477
use strict;
use warnings;
use File::Spec;
use Test::More;
use_ok('HTML::Scrubber');
use HTML::Scrubber;
my $scrubber = HTML::Scrubber->new;
$scrubber->default(1);
my $scrubbed = $scrubber->scrub( <<'END' );
one
two
END
is( $scrubbed, <<'END', "correct result" );
one
two
END
done_testing;
HTML-Scrubber-0.15/t/rt72659_utf8.t 000644 000765 000024 00000001413 12606215076 016655 0 ustar 00nigel staff 000000 000000 # Tests related to RG72659 - https://rt.cpan.org/Public/Bug/Display.html?id=72659
#
# I was unable to reproduce the errors described, but am leaving this in
# place for now as it will catch any future issues with utf8 disjoints.
#
use strict;
use utf8;
use File::Spec;
use Test::More;
use_ok('HTML::Scrubber');
use HTML::Scrubber;
my $source = "\x{DF}";
utf8::upgrade($source);
ok( utf8::is_utf8($source), 'Source string is marked UTF8' );
ok( utf8::valid($source), 'Source string is valid UTF8' );
# scrub it
my $scrubber = HTML::Scrubber->new();
my $result = $scrubber->scrub($source);
ok( utf8::is_utf8($result), 'Result string is marked UTF8' );
ok( utf8::valid($result), 'Result string is valid UTF8' );
is( $source, $result, 'Result = Source' );
done_testing;
HTML-Scrubber-0.15/t/rt79044_multiple.t 000644 000765 000024 00000001373 12606215076 017622 0 ustar 00nigel staff 000000 000000 # rt79044_multiple.t
# this is to test for the problem described in RT #79044
use strict;
use Test::More;
use_ok('HTML::Scrubber');
use HTML::Scrubber;
my @allow = qw[ p ];
my $scrubber = HTML::Scrubber->new();
$scrubber->allow(@allow);
ok( $scrubber, "got scrubber" );
# all of these should go through unscathed
my @data = ( '
a => link
br =>
b => bold
u => UNDERLINE
];
print $scrubber->scrub($html);
$scrubber->deny( qw[ p b i u hr br ] );
print $scrubber->scrub($html);
=head1 DESCRIPTION
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.
=head1 METHODS
First a note on documentation: just study the L