use
lib
"$FindBin::RealBin/lib"
;
require_ok(
'HTML::Laundry'
);
my
$l
= HTML::Laundry->new({
notidy
=> 31 });
my
$start_count
= 0;
my
$end_count
= 0;
my
$text_count
= 0;
my
$output_count
= 0;
sub
start_test {
my
(
$laundry
,
$tagref
,
$attrref
) =
@_
;
my
$tag
= ${
$tagref
};
isa_ok(
$laundry
,
'HTML::Laundry'
,
'Laundry object is passed into start_tag callback'
);
is(
$tag
,
q{p}
,
'Tag is passed correctly to start_tag callback'
);
is(
$attrref
->{id},
q{foo}
,
'Attribute (id) is passed correctly via start_tag callback'
);
is(
$attrref
->{class},
q{bar}
,
'Attribute (class) is passed correctly via start_tag callback'
);
$attrref
->{class} =
q{baz}
;
delete
$attrref
->{id};
my
$newtag
=
q{span}
;
${
$tagref
} =
$newtag
;
return
1;
}
sub
end_test {
my
(
$laundry
,
$tagref
,
$attrref
) =
@_
;
my
$tag
= ${
$tagref
};
isa_ok(
$laundry
,
'HTML::Laundry'
,
'Laundry object is passed into end_tag callback'
);
is(
$tag
,
q{p}
,
'Tag is passed correctly to end_tag callback'
);
ok( !
$attrref
,
'Attributes not passed to end_tag callback'
);
my
$newtag
=
q{span}
;
${
$tagref
} =
$newtag
;
return
1;
}
sub
text_test {
my
(
$laundry
,
$textref
,
$iscdata
) =
@_
;
isa_ok(
$laundry
,
'HTML::Laundry'
,
'Laundry object is passed into text callback'
);
my
$text
= ${
$textref
};
my
$expected
=
q{Sixteen years had Miss Taylor been in Mr. Woodhouse's family, less as a governess than a friend, very fond of both daughters, but particularly of Emma.}
;
is(
$text
,
$expected
,
'Text is passed correctly to text callback'
);
${
$textref
} =
'The family of Dashwood had been long settled in Sussex.'
;
return
1;
}
sub
entity_test {
my
(
$laundry
,
$textref
,
$iscdata
) =
@_
;
my
$text
= ${
$textref
};
ok(
$text
!~
q{lt;}
,
'Text is passed before entity escaping has occured'
);
return
1;
}
sub
output_test {
my
(
$laundry
,
$fragsref
) =
@_
;
isa_ok(
$laundry
,
'HTML::Laundry'
,
'Laundry object is passed into output callback'
);
my
@fragments
= @{
$fragsref
};
is(
scalar
@fragments
, 3,
'Fragments array is passed via reference, has right number of elements'
);
@{
$fragsref
} = (
'<p>'
,
'The family of Dashwood had been long settled'
,
' in Sussex.'
,
'</p>'
);
return
1;
}
sub
uri_test {
my
(
$laundry
,
$tagname
,
$attr
,
$uri_ref
) =
@_
;
isa_ok(
$laundry
,
'HTML::Laundry'
,
'Laundry object is passed into uri callback'
);
is(
$tagname
,
'img'
,
'Tagname is given as scalar'
);
is(
$attr
,
'src'
,
'Attribute is passed as scalar'
);
my
$uri
= ${
$uri_ref
};
is(
$uri
->path,
'/static/otter.png'
,
'URI object is passed as reference'
);
$uri
->scheme(
q{https}
);
${
$uri_ref
} =
$uri
;
return
1;
}
sub
cancel {
return
0;
}
my
$austen
=
q{<p id="foo" class="bar">Sixteen years had Miss Taylor been in Mr. Woodhouse's family, less as a governess than a friend, very fond of both daughters, but particularly of Emma.</p>}
;
my
$alt_austen
=
q{<p class="bar" id="foo">Sixteen years had Miss Taylor been in Mr. Woodhouse's family, less as a governess than a friend, very fond of both daughters, but particularly of Emma.</p>}
;
my
$output
;
$l
->add_callback(
'start_tag'
, \
&start_test
);
$output
=
$l
->clean(
$austen
);
is(
$output
,
q{<span class="baz">Sixteen years had Miss Taylor been in Mr. Woodhouse's family, less as a governess than a friend, very fond of both daughters, but particularly of Emma.</p>}
,
'Start tag callback allows: elimination of attribute; modification of attribute; modification of tag'
);
$l
->add_callback(
'start_tag'
, \
&cancel
);
$output
=
$l
->clean(
$austen
);
is(
$output
,
q{Sixteen years had Miss Taylor been in Mr. Woodhouse's family, less as a governess than a friend, very fond of both daughters, but particularly of Emma.</p>}
,
'Start tag callback allows forced non-parsing of tag via false return'
);
$l
->clear_callback(
'start_tag'
);
$output
=
$l
->clean(
$austen
);
ok( (
$output
eq
$austen
or
$output
eq
$alt_austen
),
'Cleared start_tag callback turns off callback'
);
$l
->add_callback(
'start_tag'
,
sub
{
my
(
$laundry
,
$tagref
,
$attrref
) =
@_
;
if
(
$$tagref
eq
'img'
) {
$attrref
->{alt} =
'surly otter baby!'
;
}
});
$l
->add_callback(
'start_tag'
,
sub
{
my
(
$laundry
,
$tagref
,
$attrref
) =
@_
;
if
(
$$tagref
eq
'img'
) {
my
$alt
=
$attrref
->{alt};
$alt
=~ s/[aeiou]//g;
$attrref
->{alt} =
$alt
;
}
});
$l
->clear_callback(
'start_tag'
);
$l
->add_callback(
'end_tag'
, \
&end_test
);
$austen
=
q{<p id="foo">Sixteen years had Miss Taylor been in Mr. Woodhouse's family, less as a governess than a friend, very fond of both daughters, but particularly of Emma.</p>}
;
$output
=
$l
->clean(
$austen
);
$austen
=~ s{/p}{/span};
ok( (
$output
eq
$austen
),
'end_tag callback allows modification of end tag'
);
$austen
=~ s{/span}{/p};
$l
->add_callback(
'end_tag'
, \
&cancel
);
$output
=
$l
->clean(
$austen
);
$output
.=
q{</p>}
;
ok( (
$output
eq
$austen
),
'end_tag callback allows forced non-parsing of end tag via false return'
);
$l
->clear_callback(
'end_tag'
);
$output
=
$l
->clean(
$austen
);
ok( (
$output
eq
$austen
),
'Cleared end_tag callback turns off callback'
);
$l
->add_callback(
'end_tag'
,
sub
{
my
(
$laundry
,
$tagref
,
$attrref
) =
@_
;
if
(
$$tagref
eq
'em'
) {
$$tagref
=
q{span}
}
return
1;
});
$l
->add_callback(
'end_tag'
,
sub
{
my
(
$laundry
,
$tagref
,
$attrref
) =
@_
;
if
(
$$tagref
eq
'p'
) {
$$tagref
=
q{div}
;
}
return
1;
});
$output
=
$l
->clean(
q{<p><em>Hello</em></p>}
);
is(
$output
,
q{<p><em>Hello</span></div>}
,
'End_tag callbacks may be chained'
);
$l
->clear_callback(
'end_tag'
);
$l
->add_callback(
'text'
, \
&text_test
);
$output
=
$l
->clean(
$austen
);
is(
$output
,
q{<p id="foo">The family of Dashwood had been long settled in Sussex.</p>}
,
'Text callback allows manipulation of text'
);
$l
->clear_callback(
'text'
);
$l
->add_callback(
'text'
, \
&entity_test
);
$l
->clean(
q{1 < 2}
);
$l
->clear_callback(
'text'
);
$l
->add_callback(
'text'
, \
&cancel
);
$output
=
$l
->clean(
$austen
);
is(
$output
,
q{<p id="foo"></p>}
,
'Text callback allows forced non-parsing of text via false return '
);
$l
->clear_callback(
'text'
);
$l
->clear_callback(
'uri'
);
$l
->add_callback(
'text'
,
sub
{
my
(
$laundry
,
$textref
,
$iscdata
) =
@_
;
${
$textref
} =~ s/a//g;
});
$l
->add_callback(
'text'
,
sub
{
my
(
$laundry
,
$textref
,
$iscdata
) =
@_
;
${
$textref
} =~ s/e/ee/g;
});
$l
->add_callback(
'text'
,
sub
{
my
(
$laundry
,
$textref
,
$iscdata
) =
@_
;
${
$textref
} =~ s/qu/kw/g;
});
$output
=
$l
->clean(
q{<p><em>The quick brown fox jumped over the lazy dogs.</em></p>}
);
is(
$output
,
q{<p><em>Thee kwick brown fox jumpeed oveer thee lzy dogs.</em></p>}
,
q{Text callbacks may be chained. (text)}
);
$l
->clear_callback(
'text'
);
$output
=
$l
->clean(
$austen
);
is(
$output
,
$austen
,
'Cleared text callback turns off callback'
);
$l
->add_callback(
'output'
, \
&output_test
);
$output
=
$l
->clean(
$austen
);
is(
$output
,
q{<p>The family of Dashwood had been long settled in Sussex.</p>}
,
'Output callback allows manipulation of entire output stack'
);
$l
->clear_callback(
'output'
);
$output
=
$l
->clean(
$austen
);
is(
$output
,
$austen
,
'Cleared output callback turns off callback'
);
$l
->add_callback(
'output'
,
sub
{
my
(
$laundry
,
$fragsref
) =
@_
;
for
my
$element
(@{
$fragsref
}) {
$element
=~ s/Teh/The/g;
}
return
1;
});
$l
->add_callback(
'output'
,
sub
{
my
(
$laundry
,
$fragsref
) =
@_
;
push
@{
$fragsref
},
' - THE END'
;
return
1;
});
$output
=
$l
->clean(
'<p>Teh quick brown fox jumped over the lazy dogs.</p>'
);
is(
$output
,
q{<p>The quick brown fox jumped over the lazy dogs.</p> - THE END}
,
q{Output callbacks may be chained}
);
$l
->clear_callback(
'output'
);
$l
->add_callback(
'uri'
, \
&uri_test
);
$output
=
$l
->clean(
$image
);
q{URI callback allows manipulation of URI}
);
$l
->clear_callback(
'uri'
);
$output
=
$l
->clean(
$image
);
TestHelpers::eq_or_diff_html(
$output
,
$image
,
'Cleared URI callback turns off callback'
);
$l
->add_callback(
'uri'
, \
&cancel
);
$output
=
$l
->clean(
$image
);
TestHelpers::eq_or_diff_html(
$output
,
q{<p>Some text, and then: <img alt="Surly otter baby!" class="exciting" /></p>}
,
'URI callback allows of entire attribute via false return'
);
$l
->clear_callback(
'uri'
);
$l
->add_callback(
'uri'
,
sub
{
my
(
$laundry
,
$tagname
,
$attr
,
$uri_ref
) =
@_
;
my
$href
= ${
$uri_ref
}->as_string;
$href
=~ s/o+/o/g;
print
$href
.
"\n"
;
$$uri_ref
= URI->new(
$href
);
return
1;
} );
$l
->add_callback(
'uri'
,
sub
{
my
(
$laundry
,
$tagname
,
$attr
,
$uri_ref
) =
@_
;
my
$href
= ${
$uri_ref
}->as_string;
$href
=~ s/l/ll/g;
$$uri_ref
= URI->new(
$href
);
print
$href
.
"\n"
;
return
1;
} );
$l
->clear_callback(
'uri'
);