[libhtml-scrubber-perl] 10/13: make it possible to process attributes with callabacks
Florian Schlichting
fsfs at moszumanska.debian.org
Sat Nov 11 13:46:06 UTC 2017
This is an automated email from the git hooks/post-receive script.
fsfs pushed a commit to annotated tag release/0.10-TRIAL
in repository libhtml-scrubber-perl.
commit 4ef3e1980e05b6fcb97b0cae3498fa6588b6ec53
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Sun Sep 22 15:16:02 2013 +0400
make it possible to process attributes with callabacks
---
Changes | 2 ++
lib/HTML/Scrubber.pm | 15 ++++++++++++++-
t/08_cb_attrs.t | 28 ++++++++++++++++++++++++++++
3 files changed, 44 insertions(+), 1 deletion(-)
diff --git a/Changes b/Changes
index fc8cc2e..e2445cd 100644
--- a/Changes
+++ b/Changes
@@ -4,6 +4,8 @@ Revision history for Perl extension HTML::Scrubber.
- RT3008 Changed examples to be XSS free
- RT19063, RT25477 fixed handling of self closing tags,
for example '<hr />'
+ - 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
diff --git a/lib/HTML/Scrubber.pm b/lib/HTML/Scrubber.pm
index e02a3c9..2d67ca1 100644
--- a/lib/HTML/Scrubber.pm
+++ b/lib/HTML/Scrubber.pm
@@ -230,10 +230,19 @@ sub deny {
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,
+C<undef> to keep it without value or a new scalar value.
+
=cut
sub rules{
@@ -369,7 +378,11 @@ sub _validate {
for my $k( keys %$a ) {
my $check = exists $r->{$k}? $r->{$k} : exists $r->{'*'}? $r->{'*'} : next;
- if( ref $check || length($check) > 1 ) {
+ 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};
diff --git a/t/08_cb_attrs.t b/t/08_cb_attrs.t
new file mode 100644
index 0000000..f7545da
--- /dev/null
+++ b/t/08_cb_attrs.t
@@ -0,0 +1,28 @@
+use strict;
+use warnings;
+use Test::More;
+
+use_ok('HTML::Scrubber');
+use HTML::Scrubber;
+
+my $scrubber = HTML::Scrubber->new;
+$scrubber->default(1);
+
+my $cb = sub {
+ my ($self, $tag, $attr, $avalue) = @_;
+ my %h = (
+ drop => [],
+ bool => [undef],
+ empty => [''],
+ foo => ['bar'],
+ );
+ 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");
+
+done_testing;
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libhtml-scrubber-perl.git
More information about the Pkg-perl-cvs-commits
mailing list