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. new my $scrubber = HTML::Scrubber->new( allow => [ qw[ p b i u hr br ] ] ); Build a new HTML::Scrubber. The arguments are the initial values for the following directives:- * default * allow * deny * rules * process * comment 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 a set of attribute rules. Each rule can be 1/0, a regular expression or a callback. Values longer than 1 char are treated as regexps. The callback is called with the following arguments: the current object, tag name, attribute name, and attribute value; the callback should return an empty list to drop the attribute, undef to keep it without a 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), then 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.17/t/06_scrub_file.t 000644 000765 000024 00000003414 13124453667 017302 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)" );
open my $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.17/t/07_booleans.t 000644 000765 000024 00000002671 13124453667 016774 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.17/t/09_memory_cycle.t 000644 000765 000024 00000000304 13124453667 017652 0 ustar 00nigel staff 000000 000000 use strict; use warnings; 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.17/t/09_no_scrub_warnings.t 000644 000765 000024 00000000615 13124453667 020712 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.17/t/jvn53973084.t 000644 000765 000024 00000001106 13124453667 016320 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[
abc]; my $html_2 = q[
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.17/t/rt120384_remove_false_tags.t 000644 000765 000024 00000007303 13124453667 021535 0 ustar 00nigel staff 000000 000000 use warnings; use strict; use utf8; use Test::More; use Test::Differences; use HTML::Scrubber; use HTML::Parser; my $scrub = HTML::Scrubber->new( allow => [ qw{ p b i area br base col colgroup embed hr img input link map meta object param table track source video wbr } ] ); $scrub->default( undef, { '*' => 1 } ); # allow all attributes $scrub->comment(1); # html snippets adapted from https://developer.mozilla.org/en/docs/ # except for the
snippet, which is taken from the example in the # original ticket my %snippets = ( "area" => '', "base" => '
-- X-Ray Spex, Germ-Free Adolescents',
"col" => '
',
"embed" => '',
"hr" => '
This is the first paragraph of text.
This is the second paragraph of text.
', "img" => '
',
"input" => '',
"link" => '',
"meta" => '',
"param" => '',
"source" => '',
"track" => '',
"wbr" => 'word
"You may get to touch her
If your gloves are sterilized
Rinse your mouth with Listerine
Blow disinfectant in her eyes"
-- X-Ray Spex, Germ-Free Adolescents',
"col" => '
',
"embed" => '