[libhtml-scrubber-perl] 10/13: make it possible to process attributes with callabacks

[Florian Schlichting]

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