1package HTML::TagFilter; 2use strict; 3use base qw(HTML::Parser); 4use URI::Escape; 5use vars qw($VERSION); 6 7$VERSION = '1.03'; 8 9=head1 NAME 10 11HTML::TagFilter - A fine-grained html-filter, xss-blocker and mailto-obfuscator 12 13=head1 SYNOPSIS 14 15 use HTML::TagFilter; 16 my $tf = new HTML::TagFilter; 17 my $clean_html = $tf->filter($dirty_html); 18 19 # or 20 21 my $tf = HTML::TagFilter->new( 22 allow=>{...}, 23 deny=>{...}, 24 log_rejects => 1, 25 strip_comments => 1, 26 echo => 1, 27 verbose => 1, 28 skip_xss_protection => 1, 29 skip_entification => 1, 30 skip_mailto_entification => 1, 31 xss_risky_attributes => [...], 32 xss_permitted_protocols => [...], 33 xss_allow_local_links => 1, 34 ); 35 36 # or 37 38 my $tf = HTML::TagFilter->new( 39 on_finish_document =>sub { 40 return "\n<p>" . $self->report . "</p>\n"; 41 }, 42 ); 43 44 $tf->parse($some_html); 45 $tf->parse($more_html); 46 my $clean_html = $tf->output; 47 my $cleaning_summary = $tf->report; 48 my @tags_removed = $tf->report; 49 my $error_log = $tf->error; 50 51=head1 DESCRIPTION 52 53HTML::TagFilter is a subclass of HTML::Parser with a single purpose: it will remove unwanted html tags and attributes from a piece of text. It can act in a more or less fine-grained way - you can specify permitted tags, permitted attributes of each tag, and permitted values for each attribute in as much detail as you like. 54 55Tags which are not allowed are removed. Tags which are allowed are trimmed down to only the attributes which are allowed for each tag. It is possible to allow all or no attributes from a tag, or to allow all or no values for an attribute, and so on. 56 57The filter will also guard against cross-site scripting attacks and obfuscate any mailto:email addresses, unless you tell it not to. 58 59The original purpose for this was to screen user input. In that setting you'll often find that just using: 60 61 my $tf = new HTML::TagFilter; 62 put_in_database($tf->filter($my_text)); 63 64will do. However, it can also be used for display processes (eg text-only translation) or cleanup (eg removal of old javascript). In those cases you'll probably want to override the default rule set with a small number of denial rules. 65 66 my $self = HTML::TagFilter->new(deny => {img => {'all'}}); 67 print $tf->filter($my_text); 68 69Will strip out all images, for example, but leave everything else untouched. 70 71nb (faq #1) the filter only removes the tags themselves: all it does to text which is not part of a tag is to escape the <s and >s, to guard against false negatives and some common cross-site attacks. 72 73obPascal: Sorry about the incredibly long documentation, by the way. When I have time I'll make it shorter. 74 75=head1 CONFIGURATION: RULES 76 77Creating the rule set is fairly simple. You have three options: 78 79=head2 use the defaults 80 81which will produce safe but still formatted html, without tables, javascript or much else apart from inline text formatting, links and images. 82 83=head2 selectively override the defaults 84 85use the allow_tags and deny_tags methods to pass in one or more additional tag settings. eg: 86 87 $self->allow_tags({ p => { class=> ['lurid','sombre','plain']} }); 88 $self->deny_tags({ img => { all => [] }); 89 90will mean that all attributes other than class="lurid|sombre|plain" will be removed from <p> tags, but the other default rules will remain unchanged. See below for more about how to specify rules. 91 92=head2 supply your own configuration 93 94To override the defaults completely, supply the constructor with some rules: 95 96 my $self = HTML::TagFilter->new( 97 allow=>{ p => { class=> ['lurid','sombre','plain']} } 98 ); 99 100In this case only the rules you supply will be applied: the defaults are ignored. You can achieve the same thing after construction by first clearing the rule set: 101 102 my $self = HTML::TagFilter->new(); 103 $self->clear_rules(); 104 $self->allow_tags({ p => { align=> ['left','right','center']} }); 105 106Future versions are intended to offer a more sophisticated rule system, allowing you to specify combinations of attributes, ranges for values and generally match names in a more fuzzy way. 107 108=head1 CONFIGURATION: BEHAVIOUR 109 110There are currently seven switches that will change the behaviour of the filter. They're supplied at construction time alongside any rules you care to specify. All of them default to 'off': 111 112 my $tf = HTML::TagFilter->new( 113 log_rejects => 1, 114 strip_comments => 1, 115 echo => 1, 116 verbose => 1, 117 skip_xss_protection => 1, 118 skip_ltgt_entification => 1, 119 skip_mailto_entification => 1, 120 ); 121 122=over 4 123 124=head3 log_rejects 125 126Set log to something true and the filter will keep a detailed log of all the tags it removes. The log can be retrieved by calling report(), which will return a summary in scalar context and a detailed AoH in list. 127 128=head3 echo 129 130Set echo to 1, or anything true, and the output of the filter will be sent straight to STDOUT. Otherwise the filter is silent until you call output(). 131 132=head3 verbose 133 134Set verbose to 1, or anything true, and error messages will be output to STDERR as well as being stockpiled ready for a call to error(). 135 136=head3 strip_comments 137 138Set strip_comments to 1 and comments will be stripped. If you don't, they won't. 139 140=head3 skip_xss_protection 141 142Unless you set skip_xss_protection to 1, the filter will postprocess some of its output to protect against common cross-site scripting attacks. 143 144It will entify any < and > in non-tag text, entify quotes in attribute values (the Parser will have unencoded them) and strip out values for vulnerable attributes if they don't look suitably like urls. By default these attributes are checked: src, lowsrc, href, background and cite. You can replace that list (not extend it) at any time: 145 146 $self->xss_risky_attributes( qw(your list of attributes) ); 147 148=head3 skip_ltgt_entification 149 150Disables the entification of < and > even if cross-site protection is on. 151 152=head3 skip_mailto_entification 153 154Unless you specify otherwise, any mailto:url seen by the filter is completely turned into html entities. <a href="mailto:wross@cpan.org">will</a> becomes <a href="mailto:%77%72%6F%73%73%40%63%70%61%6E%2E%6F%72%67">will</a>. This should defeat most email-harvesting software, but note that it has no effect on the text of your link, only its address. Links like <a href="mailto:wross@cpan.org">wross@cpan.org</a> are only partly obscured and should be avoided. 155 156=head3 other constructor parameters 157 158You can also supply values that will be used as default values for the methods of the same name: 159 160 xss_risky_attributes 161 xss_permitted_protocols 162 163each of which expects a list of strings, and 164 165 xss_allow_local_links 166 167which wants a single true or false value. 168 169=back 170 171=head1 RULES 172 173Each element is tested as it is encountered, in two stages: 174 175=over 4 176 177=head3 tag filter 178 179Just checks that this tag is permitted, and blocks the whole thing if not. Applied to both opening and closing tags. 180 181=head3 attribute filter 182 183Any tag that passes the tag filter will remain in the text, but the attribute filter will strip out of it any attributes that are not permitted, or which have values that are not permitted for that tag/attribute combination. 184 185=back 186 187=head2 format for rules 188 189There are two kinds of rule: permissions and denials. They work as you'd expect, and can coexist, but they're not quite symmetrical. Denial rules are intended to complement permission rules, so that they can provide a kind of compound 'unless'. 190 191* If there are any 'permission' rules, then everything that doesn't satisfy any of them is eliminated. 192 193* If there are any 'deny' rules, then anything that satisfies any of them is eliminated. 194 195* If there are both denial and permission rules, then everything either satisfies a denial rule or fails to satisfy any of the permission rules is eliminated. 196 197* If there is neither kind, we strip out everything just to be on the safe side. 198 199The two most likely setups are 200 2011. a full set of permission rules and maybe a couple of denial rules to eliminate pet hates. 202 2032. no permission rules at all and a small set of denial rules to remove particular tags. 204 205Rules are passed in as a HoHoL: 206 207 { tag name->{attribute name}->[valuelist] } 208 209There are three reserved words: 'any and 'none' stand respectively for 'anything is permitted' and 'nothing is permitted', or if in denial: 'anything is removed' and 'nothing is removed'. 'all' is only used in denial rules and it indicates that the whole tag should be stripped out: see below for an explanation and some mumbled excuses. 210 211For example: 212 213 $self->allow_tags({ p => { any => [] }); 214 215Will permit <p> tags with any attributes. For clarity's sake it may be shortened to: 216 217 $self->allow_tags({ p => { 'any' }); 218 219but note that you'll get a warning about the odd number of hash elements if -w is on, and in the absence of the => the quotes are required. And 220 221 $self->allow_tags({ p => { none => [] }); 222 223Will allow <p> tags to remain in the text, but all attributes will be removed. The same rules apply at all levels in the tag/attribute/value hierarchy, so you can say things like: 224 225 $self->allow_tags({ any => { align => [qw(left center right)] }); 226 $self->allow_tags({ p => { align => ['any'] }); 227 228=head2 examples 229 230To indicate that a link destination is ok and you don't mind what value it takes: 231 232 $self->allow_tags({ a => { 'href' } }); 233 234To limit the values an attribute can take: 235 236 $self->allow_tags({ a => { class => [qw(big small middling)] } }); 237 238To clear all permissions: 239 240 $self->allow_tags({}); 241 242To remove all onClicks from links but allow all targets: 243 244 $self->allow_tags({ a => { onClick => ['none'], target => [], } }); 245 246You can combine allows and denies to create 'unless' rules: 247 248 $self->allow_tags({ a => { any => [] } }); 249 $self->deny_tags({ a => { onClick => [] } }); 250 251Will remove only the onClick attribute of a link, allowing everything else through. If this was your only purpose, you could achieve the same thing just with the denial rule and an empty permission set, but if there's other stuff going on then you probably need this combination. 252 253=head2 order of application 254 255denial rules are applied first. we take out whatever you specify in deny, then take out whatever you don't specify in allow, unless the allow set is empty, in which case we ignore it. If both sets are empty, no tags gets through. 256 257(We prefer to err on the side of less markup, but I expect this will be configurable soon.) 258 259=head2 oddities 260 261Only one deliberate one, so far. The main asymmetry between permission and denial rules is that from 262 263 allow_tags->{ p => {...}} 264 265it follows that p tags are permitted, but the reverse is not true: 266 267 deny_tags->{ p => {...}} 268 269doesn't imply that p tags are removed, just that the relevant attributes are removed from them. If you want to use a denial rule to eliminate a whole tag, you have to say so explicitly: 270 271 deny_tags->{ p => {'all'}} 272 273will remove every <p> tag, whereas 274 275 deny_tags->{ p => {'any'}} 276 277will just remove all the attributes from <p> tags. Not very pretty, I know. It's likely to change, but probably not until after we've invented a system for supplying rules in a more readable format. 278 279=cut 280 281sub allowed_by_default { 282 return { 283 h1 => { none => [] }, 284 h2 => { none => [] }, 285 h3 => { none => [] }, 286 h4 => { none => [] }, 287 h5 => { none => [] }, 288 p => { none => [] }, 289 a => { href => [], name => [], target => [] }, 290 br => { clear => [qw(left right all)] }, 291 ul =>{ type => [] }, 292 li =>{ type => [] }, 293 ol => { none => [] }, 294 em => { none => [] }, 295 i => { none => [] }, 296 b => { none => [] }, 297 strong => { none => [] }, 298 tt => { none => [] }, 299 pre => { none => [] }, 300 code => { none => [] }, 301 hr => { none => [] }, 302 blockquote => { none => [] }, 303 img => { src => [], height => [], width => [], alt => [], align => [] }, 304 any => { align => [qw(left right center)] }, 305 }; 306} 307 308sub denied_by_default { 309 return { 310 blink => { all => [] }, 311 marquee => { all => [] }, 312 any => { style => [], onMouseover => [], onClick => [], onMouseout => [], }, 313 }; 314} 315 316sub new { 317 my $class = shift; 318 my $config = {@_}; 319 320 my $self = $class->SUPER::new(api_version => 3); 321 322 $self->SUPER::handler(start => "filter_start", 'self, tagname, attr, attrseq'); 323 $self->SUPER::handler(end => "filter_end", 'self, tagname'); 324 $self->SUPER::handler(default => "clean_text", "self, text"); 325 $self->SUPER::handler(comment => "") if delete $config->{strip_comments}; 326 327 $self->{_allows} = {}; 328 $self->{_denies} = {}; 329 $self->{_settings} = {}; 330 $self->{_log} = (); 331 $self->{_error} = (); 332 $self->{_triggers} = (); 333 334 $config->{allow} = allowed_by_default() unless $config->{allow} || $config->{deny}; 335 $config->{deny} = denied_by_default() unless $config->{allow} || $config->{deny}; 336 337 $self->_add_trigger($_ => delete $config->{$_}) for (qw(on_construct on_start_document on_open_tag on_process_text on_close_tag on_finish_document)); 338 $self->allow_tags(delete $config->{allow}); 339 $self->deny_tags(delete $config->{deny}); 340 341 $self->{_settings}->{log} = 1 if delete $config->{log_rejects}; 342 $self->{_settings}->{echo} = 1 if delete $config->{echo}; 343 $self->{_settings}->{xss} = 1 unless delete $config->{skip_xss_protection}; 344 $self->{_settings}->{ent} = 1 unless delete $config->{skip_entification} || delete $config->{skip_ltgt_entification}; 345 $self->{_settings}->{mailto} = 1 unless delete $config->{skip_mailto_entification}; 346 $self->{_settings}->{verbose} = 1 if delete $config->{verbose}; 347 $self->_log_error("[warning] ignored unknown config field: $_") for keys %$config; 348 349 $self->_call_trigger('on_construct'); 350 return $self; 351} 352 353sub _add_trigger { 354 my ($self, $point, $sub) = @_; 355 if ($sub && ref $sub eq 'CODE') { 356 $self->{_triggers}{$point} = $sub; 357 } else { 358 $self->{_triggers}{$point} = 1; 359 my $class = ref $self; 360 no strict ('refs'); 361 *{"HTML::TagFilter::$point"} = sub { return }; 362 } 363} 364 365sub _call_trigger { 366 my ($self, $point, @args) = @_; 367 my $sub = $self->{_triggers}{$point}; 368 if ( $sub && ref $sub eq 'CODE') { 369 my $response; 370 eval { 371 $response = &$sub($self, @args); 372 }; 373 if ($@) { 374 $self->_log_error("[warning] $point callback failed: $@"); 375 } elsif ($response) { 376 $self->add_to_output( $response ); 377 } 378 379 } elsif ($sub) { 380 $self->$point(@args); 381 382 } else { 383 my ($package, $filename, $line) = caller; 384 $self->_log_error("[warning] unknown trigger point '$point' called at $package line $line"); 385 } 386} 387 388=head1 CALLBACKS 389 390Several trigger points are provided for the convenience of people who want to extend rather than replacing the normal behaviour of a tagfilter object. To use them, you just pass in a code reference with the appropriate name at construction time. 391 392The example below will maintain a stack of seen tags and make the filter repair tag nesting, so that any unclosed tags are closed in roughly the right place, and any unopened close tags are omitted: 393 394 my $filter = HTML::TagFilter->new( 395 on_start_document => sub { 396 my ($self, $rawtext) = @_; 397 $self->{_tag_stack} = []; 398 return; 399 }, 400 on_open_tag => sub { 401 my ($self, $tag, $attributes, $sequence) = @_; 402 push @{ $self->{_tag_stack} }, $$tag unless grep {$_ eq $$tag} qw(img br hr meta link); 403 return; 404 }, 405 on_close_tag => sub { 406 my ($self, $tag) = @_; 407 unless (@{ $self->{_tag_stack} } && grep {$_ eq $$tag} @{ $self->{_tag_stack} }) { 408 undef ${ $tag }; 409 return; 410 } 411 my @unclosed; 412 while (my $lasttag = pop @{ $self->{_tag_stack} }) { 413 return join '', map "</$_>", @unclosed if $lasttag eq $$tag; 414 push @unclosed, $lasttag; 415 } 416 }, 417 on_finish_document => sub { 418 my ($self, $cleantext) = @_; 419 return join '', map "</$_>", reverse @{ $self->{_tag_stack} }; 420 }, 421 ); 422 423You can also fill these trigger points in subclass: If no callback method is supplied, we will call the class method of the same (triggerpoint) name instead. In this class those methods do nothing, so you can selectively override them without affecting normal functionality. To change all <b> tags to <strong> tags, for example: 424 425 sub on_open_tag { 426 my ($self, $tag, $attributes, $sequence) = @_; 427 $$tag = 'strong' if $$tag eq 'b'; 428 } 429 430 sub on_close_tag { 431 my ($self, $tag) = @_; 432 $$tag = 'strong' if $$tag eq 'b'; 433 } 434 435As you can see here The tag and attribute values are passed in as string references: changes you make in callback will change the tag itself. 436 437The available trigger points are: 438 439=head3 on_construct () 440 441This is called during construction of a new TagFilter object, just before the constructed object is returned. It receives no arguments apart from the tagfilter object. 442 443=head3 on_start_document ( $text ) 444 445This is called by the filter() method, and passed a reference to the text that is to be filtered. You can change the text, or return any values that should be prepended to output. 446 447=head3 on_open_tag ( $tagname, $attributes, $attribute_sequence ) 448 449This is called by the filter_start() method, with is the checker of opening and single tags. It is passed the same variables as that method uses: the name of the tag, a hashref containing all its attributes and a listref holding attribute names in order. 450 451Together with on_close_tag, this hook is very useful for adding document-tidying functions like tag closure, or for more sophisticated logging than tagfilter provides by itself. 452 453=head3 on_process_text ( $text ) 454 455We normally just translate disallowed characters in text blocks, but this method receives a reference to the text string, so you can do what you like with it. 456 457Note that if you just want to add more disallowed characters, you can just subclass character_map(). 458 459=head3 on_close_tag ( $text ) 460 461This is called by the filter_end() method, which is the checker of closing tags. It is passed the closing tag name. 462 463=head3 on_finish_document ( $text ) 464 465This is called by the output() method. It receives no arguments, or we get the output a bit tangled up, but whatever you return will be appended to the final output string. 466 467=head1 METHODS 468 469For reference: 470 471=head3 HTML::TagFilter->new(); 472 473If called without parameters, loads the default set. Otherwise loads the rules you supply. For the rule format, see above. 474 475=head2 FILTER METHODS 476 477These make up the main interface. You probably won't often need to call anything but filter(). 478 479=head3 $tf->filter($html); 480 481Exactly equivalent to: 482 483 $tf->parse($html); 484 $tf->output(); 485 486but more useful, because it'll fit in a oneliner. eg: 487 488 print $tf->filter( $pages{$_} ) for keys %pages; 489 490Note that calling filter() will clear anything that was waiting in the output buffer, and will clear the buffer again when it's finished. it's meant to be a one-shot operation and doesn't co-operate well. use parse() and output() if you want to daisychain. 491 492=cut 493 494sub filter { 495 my ($self, $text) = @_; 496 return unless $text; 497 $self->_call_trigger('on_start_document', \$text); 498 $self->{output} = ''; 499 $self->parse($text); 500 return $self->output unless $self->{_settings}->{echo}; 501} 502 503=head3 parse($text); 504 505The parse method is inherited from HTML::Parser, but most of its ancillary methods are subclassed here and the output they normally print is kept for later. The other configuration options that HTML::Parser normally offers are not passed on, at the moment, nor can you override the handler definitions in this module. 506 507=head3 output() 508 509This will return and clear the output buffer. It will conclude the processing of your text, but you can of course pass a new piece of text to the same parser object and begin again. 510 511=cut 512 513sub output { 514 my $self = shift; 515 $self->eof; 516 $self->_call_trigger('on_finish_document'); 517 my $output = $self->{output}; 518 $self->_log_error("[warning] no output from filter") unless $output; 519 $self->{output} = ''; 520 return $output; 521} 522 523=head3 report() 524 525If called in list context, returns the array of rejected tag/attribute/value combinations. 526 527In scalar context returns a more or less readable summary. Returns () if logging not enabled. Clears the log. 528 529=cut 530 531sub report { 532 my $self = shift; 533 return () unless defined $self->{_log}; 534 my @rejects = @{ $self->{_log} }; 535 $self->{_log} = (); 536 return @rejects if wantarray; 537 538 my $report = "The following tags and attributes have been stripped:\n"; 539 for (@rejects) { 540 if ($_->{attribute}) { 541 $report .= $_->{attribute} . '="' . $_->{value} . '" from the tag <' . $_->{tag} . ">"; 542 $report .= "(url disallowed)" if $_->{reason} eq 'url'; 543 $report .= "\n"; 544 } else { 545 $report .= '<' . $_->{tag} . ">\n"; 546 } 547 } 548 return $report; 549} 550 551=head3 filter_start($tag, $attributes_hashref, $attribute_sequence_listref); 552 553This is the handler for html start tags: it checks the tag against the current set of rules, then checks each attribute and its value. Any text that fails is stripped out: the rest is passed to output. 554 555=cut 556 557sub filter_start { 558 my ($self, $tagname, $attributes, $attribute_sequence) = @_; 559 return unless $self->tag_ok(lc($tagname)); 560 $self->_call_trigger('on_open_tag', \$tagname, $attributes, $attribute_sequence); 561 return unless $tagname; 562 563 for (@$attribute_sequence) { 564 my @data = (lc($tagname), lc($_), lc($attributes->{$_})); # (tag, attribute, value) 565 delete $attributes->{$_} unless $self->attribute_ok(@data) && $self->url_ok(@data); 566 } 567 my $surviving_attributes = join('', map { " $_=\"" . $self->_xss_clean_attribute($attributes->{$_}, $_) . '"' } grep { defined $attributes->{$_} } @$attribute_sequence); 568 $self->add_to_output("<$tagname$surviving_attributes>"); 569} 570 571=head3 filter_end($tag); 572 573This is the handler for html end tags: it checks the tag against the current set of rules, and passes it to output if it's ok. 574 575=cut 576 577sub filter_end { 578 my ($self, $tagname) = @_; 579 return unless $self->tag_ok(lc($tagname)); 580 $self->_call_trigger('on_close_tag', \$tagname); 581 return unless $tagname; 582 $self->add_to_output( "</$tagname>" ); 583} 584 585=head3 clean_text($text); 586 587This is the handler for text: anything which is not tag is passed through here before being passed to output. At the moment it only applies some very simple cross-site protection: subclassing this method is an easy way to modify just the text part of your page. 588 589=cut 590 591sub clean_text { 592 my ($self, $text) = @_; 593 $self->_call_trigger('on_process_text', \$text); 594 $self->add_to_output($self->_xss_clean_text($text)); 595} 596 597sub _xss_clean_text { 598 my ($self, $text) = @_; 599 return $text unless $self->{_settings}->{xss}; 600 return $text unless $self->{_settings}->{ent}; 601 return $self->_clean_text($text); 602} 603 604sub _clean_text { 605 my ($self, $text) = @_; 606 my $filter = $self->character_map; 607 $text =~ s/$_/$$filter{$_}/gs for keys %$filter; 608 return $text; 609} 610 611=head3 character_map($text); 612 613Returns a hashref of {disallowed_character => replacement_character} for use when cleaning text blocks. 614 615=cut 616 617sub character_map { 618 my $self = shift; 619 return $self->{_settings}->{charmap} = $_[0] if @_; 620 return $self->{_settings}->{charmap} if exists $self->{_settings}->{charmap}; 621 return $self->{_settings}->{charmap} = { 622 '"' => '"', 623 "'" => ''', 624 '>' => '>', 625 '<' => '<', 626 }; 627} 628 629=head3 add_to_output($text); 630 631The supplied text is appended to the output buffer (or immediately printed, if echo is on). 632 633=cut 634 635sub add_to_output { 636 my $self = shift; 637 return unless @_ && defined $_[0]; 638 if ($self->{_settings}->{echo}) { 639 print $_[0]; 640 } else { 641 $self->{output} .= $_[0]; 642 } 643} 644 645=head3 logging($boolean); 646 647This provides get-or-set access to the 'log' configuration parameter. Switching logging on or off during parsing will result in incomplete reports, of course. 648 649=cut 650 651sub logging { 652 my $self = shift; 653 $self->{_settings}->{log} = $_[0] if @_; 654 return $self->{_settings}->{log}; 655} 656 657=head3 log_denied($refused_tag); 658 659If logging is on, this method will append the supplied failure information to the log. The standard form for this is a hashref that will contain some or all of these keys: 'tag', 'attribute', 'value' and 'reason'. 660 661=cut 662 663sub log_denied { 664 my ($self, $bad_tag) = @_; 665 return unless $self->logging; 666 push @{ $self->{_log} } , $bad_tag; 667} 668 669=head2 RULE CHECKERS 670 671Compare individual tags and attributes against the rule set currently in force. These simple methods are the core of tagfilter: most of the rest is configuration, and the filter methods are really just glue to connect these tests to HTML::Parser's progress through a document. 672 673=head3 tag_ok($tag); 674 675Returns true if the supplied tag name is allowed in the text. If not, returns false and logs the failure with the reason 'tag'. 676 677=cut 678 679sub tag_ok { 680 my ($self, $tagname) = @_; 681 my $ok = $self->_tag_ok($tagname); 682 $self->log_denied({tag => $tagname, reason => 'tag' }) unless $ok; 683 return $ok; 684} 685 686sub _tag_ok { 687 my ($self, $tagname) = @_; 688 return 0 unless $tagname && $self->has_rules; 689 return 0 if $self->_check('_denies', 'attributes', $tagname, 'all'); 690 return 1 unless $self->has_allow_rules; 691 return 1 if $self->_check('_allows', 'tags', $tagname); 692 return 0; 693} 694 695=head3 attribute_ok($tag, $attribute); 696 697Returns true if it that attribute is allowed for that tag, and it is allowed to have the supplied value. If not, returns false and logs the failure with the reason 'attribute'. 698 699=cut 700 701sub attribute_ok { 702 my ($self, $tagname, $attribute, $value) = @_; 703 my $ok = $self->_attribute_ok( $tagname, $attribute, $value ); 704 $self->log_denied({ tag => $tagname, attribute => $attribute, value => $value, reason => 'attribute' }) unless $ok; 705 return $ok; 706} 707 708sub _attribute_ok { 709 my ($self, $tagname, $attribute, $value) = @_; 710 return 0 unless $tagname && $attribute && $self->has_rules; 711 return 0 if $self->_check('_denies','attributes', $tagname, 'any'); 712 return 0 if $self->_check('_denies','values', $tagname, 'all',); 713 return 0 if $self->_check('_denies','values', $tagname, $attribute, 'any'); 714 return 0 if $self->_check('_denies','values', $tagname, $attribute, $value); 715 return 1 unless $self->has_allow_rules; 716 return 1 if $self->_check('_allows','attributes', $tagname, 'any'); 717 return 1 if $self->_check('_allows','values', 'any', $attribute, 'any'); 718 return 1 if $self->_check('_allows','values', 'any', $attribute, $value); 719 return 1 if $self->_check('_allows','values', $tagname, $attribute, 'any'); 720 return 1 if $self->_check('_allows','values', $tagname, $attribute, $value); 721 return 0; 722} 723 724=head3 url_ok($tag, $attributes, $value); 725 726If xss protection is on, we check whether this attribute is a url field, and if it is we check that the url is a url (rather than a script tag or some other naughtiness). Failures are logged with the reason 'url'. 727 728=cut 729 730sub url_ok { 731 my ($self, $tagname, $attribute, $value) = @_; 732 my $ok = $self->_url_ok( $attribute, $value ); 733 $self->log_denied({ tag => $tagname, attribute => $attribute, value => $value, reason => 'url' }) unless $ok; 734 return $ok; 735} 736 737sub _url_ok { 738 my ($self, $attribute, $value) = @_; 739 return 1 unless $self->{_settings}->{xss}; 740 return 1 unless $self->_is_risky($attribute); 741 return 1 if $self->xss_allow_local_links && ($value =~ /^\.*\//s || $value !~ /:/s); 742 return 1 if grep { $value =~ /^$_:/s } $self->xss_permitted_protocols; 743 return 0; 744} 745 746# _xss_clean_attribute(): defends against very basic XSS attacks by entifying quote marks and <> 747 748sub _xss_clean_attribute { 749 my ($self, $text, $attribute) = @_; 750 return $text unless $self->{_settings}->{xss}; 751 my $filter = $self->character_map; 752 $text =~ s/$_/$$filter{$_}/gs for keys %$filter; 753 return $self->_obfuscate_mailto($text) if $attribute eq 'href'; 754 return $text; 755} 756 757sub _is_risky { 758 my ($self, $attribute) = @_; 759 my %risky = map { $_ => 1 } $self->xss_risky_attributes; 760 return $risky{$attribute}; 761} 762 763# uri_escape is imported from URI::Escape 764 765sub _obfuscate_mailto { 766 my ($self, $address) = @_; 767 return $address unless $self->{_settings}->{mailto}; 768 return $address unless $address =~ /^mailto:(.*)/; 769 my $garbled = join '', map { uri_escape($_, "\0-\377") } split //, $1; 770 return "mailto:$garbled"; 771} 772 773# _check(): a private function to test for a value buried deep in a HoHoHo 774# without cluttering the place up with autovivification. 775 776sub _check { 777 my $self = shift; 778 my $field = shift; 779 my @russian_dolls = @_; 780 unless (@russian_dolls) { 781 $self->_log_error("[warning] _check: no keys supplied"); 782 return 0; 783 } 784 my $deepref = $self->{$field}; 785 for (@russian_dolls) { 786 unless (ref $deepref eq 'HASH') { 787 $self->_log_error("[error] _check: deepref not a hashref"); 788 return 0; 789 } 790 return 0 unless $deepref->{$_}; 791 $deepref = $deepref->{$_}; 792 } 793 return 1; 794} 795 796=head2 configuration methods 797 798The configuration of the filter is held in a hash of hashes, usually referred to here as a hohoho as it usually has at least three levels. These methods expect to receive full or partial rule sets in the simplified form described above and merge them into - or drop them on top of - the active set. 799 800=head3 allow_tags($hashref) 801 802Takes a hashref of permissions and adds them to what we already have, replacing at the tag level where rules are already defined. In other words, you can add a tag to the existing set, but to add an attribute to an existing tag you have to specify the whole set of attribute permissions. 803 804If no rules are sent (eg an empty hashref, or nothing at all, or a non-hashref) this clears the permission rule set. 805 806=cut 807 808sub allow_tags { 809 my ($self, $tagset) = @_; 810 if ($tagset && ref $tagset eq 'HASH' && %$tagset) { 811 $self->_configurise('_allows', $tagset); 812 } else { 813 $self->{_allows} = {}; 814 } 815 return 1; 816} 817 818=head3 deny_tags($hashref) 819 820likewise but sets up (or clears) denial rules. 821 822=cut 823 824sub deny_tags { 825 my ($self, $tagset) = @_; 826 if ($tagset && ref $tagset eq 'HASH' && %$tagset) { 827 $self->_configurise('_denies', $tagset); 828 } else { 829 $self->{_denies} = {}; 830 } 831 return 1; 832} 833 834=head3 has_rules() 835 836Returns true only if either allow or deny rules have been defined. 837 838=cut 839 840sub has_rules { 841 my $self = shift; 842 return 1 if $self->has_allow_rules || $self->has_deny_rules; 843 return 0; 844} 845 846=head3 has_allow_rules() 847 848Returns true if allow rules have been defined. 849 850=cut 851 852sub has_allow_rules { 853 my $self = shift; 854 return 1 if $self->{_allows} && %{ $self->{_allows} }; 855 return 0; 856} 857 858=head3 has_deny_rules() 859 860Returns true if denial rules have been defined. 861 862=cut 863 864sub has_deny_rules { 865 my $self = shift; 866 return 1 if $self->{_denies} && %{ $self->{_denies} }; 867 return 0; 868} 869 870=head3 clear_rules() 871 872Clears the entire rule set ready for the supply of a new set. A filter with no rules will strip *all* html from supplied text, by the way. 873 874=cut 875 876sub clear_rules { 877 my $self = shift; 878 $self->{_allows} = {}; 879 $self->{_denies} = {}; 880} 881 882# _configurise(): a private function that translates input rules into 883# the bushy HoHoHo's we're using for lookup. 884 885sub _configurise { 886 my ($self, $field, $tagset) = @_; 887 888 unless (ref $tagset eq 'HASH') { 889 $self->_log_error("[error] _configurise: supplied rules not a hashref"); 890 return (); 891 } 892 $self->_log_error("[warning] _configurise: supplied rule set empty") unless keys %$tagset; 893 894 TAG: foreach my $tag (keys %$tagset) { 895 $self->{$field}->{tags}->{$tag} = 1; 896 897 ATT: foreach my $att (keys %{ $tagset->{$tag} }) { 898 if ($att eq 'none') { 899 $self->{$field}->{attributes}->{$tag} = {}; 900 next TAG; 901 } 902 $self->{$field}->{attributes}->{$tag}->{$att} = 1; 903 $self->{$field}->{values}->{$tag}->{$att}->{any} = 1 904 unless defined( $tagset->{$tag}->{$att} ) && @{ $tagset->{$tag}->{$att} }; 905 foreach my $val (@{ $tagset->{$tag}->{$att} }) { 906 $self->{$field}->{values}->{$tag}->{$att}->{$val} = 1; 907 } 908 } 909 } 910} 911 912=head3 allows() 913 914Returns the full set of permissions as a HoHoho. Can't be set this way: just a utility function in case you want to either display the rule set, or get the whole thing so you can send it back to allow_tags in a modified form. 915 916=head3 denies() 917 918Likewise for denial rules. 919 920=cut 921 922sub allows { 923 my $self = shift; 924 return $self->{_allows}; 925} 926 927sub denies { 928 my $self = shift; 929 return $self->{_denies}; 930} 931 932=head2 XSS configuration 933 934Cross-site scripting attacks are invented or identified all the time. We'll try and stay up to date, but you may be more paranoid or up to date than us: if so, just override one or more of these methods. 935 936=head3 xss_risky_attributes( @list_of_attributes ); 937 938Sets and returns a list of attributes that are considered to be urls, and should be checked for well-formedness. 939 940The default list is href, src, lowsrc, cite and background: any supplied values will be used to replace (not extend) this list. 941 942=cut 943 944sub xss_risky_attributes { 945 my $self = shift; 946 return @{ $self->{_xss_att} } = @_ if @_; 947 return @{ $self->{_xss_att} } if $self->{_xss_att}; 948 return @{ $self->{_xss_att} } = qw(src href cite lowsrc background) ; 949} 950 951=head3 xss_permitted_protocols( @list_of_prefixes ); 952 953Sets and returns a list of protocols that are acceptable in attributes that we considered to be urls (ie they're in the list returned by C<xss_risky_attributes>). 954 955The default list is http, https, ftp and mailto. Any supplied values will be used to replace (not extend) this list. Don't include the colon. 956 957=cut 958 959sub xss_permitted_protocols { 960 my $self = shift; 961 return @{ $self->{_xss_stems} } = @_ if @_; 962 return @{ $self->{_xss_stems} } if $self->{_xss_stems}; 963 return @{ $self->{_xss_stems} } = qw(http https mailto ftp) ; 964} 965 966=head3 xss_allow_local_links( $boolean ); 967 968If this method returns a true value, then addresses that begin '/' or '../' will be accepted in url fields. 969 970You can set this value by calling the method with a parameter, as usual. The default is true. 971 972=cut 973 974sub xss_allow_local_links { 975 my $self = shift; 976 return $self->{_xss_local} = $_[0] if @_; 977 return $self->{_xss_local} if defined $self->{_xss_local}; 978 return $self->{_xss_local} = 1; 979} 980 981=head3 error() 982 983Returns an error report of currently dubious usefulness. If you want to record error messages in subclass, call $self->_add_error(@messages). 984 985There is no class-level error logging mechanism at the moment, which is why the usefulness of this is rather limited. 986 987=cut 988 989sub error { 990 my $self = shift; 991 return "HTML::TagFilter errors:\n" . join("\n", @{$self->{_error}}) if $self->{_error}; 992 return ''; 993} 994 995# _log_error: append a message to the error log 996 997sub _log_error { 998 my $self = shift; 999 push @{ $self ->{_error} } , @_; 1000 warn @_ if $self->{_settings}->{verbose}; 1001} 1002 1003# handler() exists here only to admonish people who try to use this module as they would 1004# HTML::Parser. The handler definitions in new() use SUPER::handler() to get around this. 1005 1006sub handler { 1007 die("You can't set handlers for HTML::TagFilter. Perhaps you should be using HTML::Parser directly?"); 1008} 1009 1010sub version { 1011 return $VERSION; 1012} 1013 10141; 1015 1016=head1 TO DO 1017 1018Make the documentation about half as long 1019 1020More sanity checks on incoming rules 1021 1022Simpler rule-definition interface 1023 1024Complex rules. The long term goal is that someone can supply a rule like "remove all images where height or width is missing" or "change all font tags where size="2" to <span class="small">. Which will be hard. For a start, HTML::Parser doesn't see paired start and close tags, which would be required for conditional actions. 1025 1026An option to speed up operations by working only at the tag level and using HTML::Parser's built-in screens. 1027 1028=head1 REQUIRES 1029 1030HTML::Parser 1031 1032=head1 SEE ALSO 1033 1034L<HTML::Parser> 1035 1036=head1 AUTHOR 1037 1038William Ross, wross@cpan.org 1039 1040=head1 COPYRIGHT 1041 1042Copyright 2001-3 William Ross 1043 1044This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. 1045 1046Please use https://rt.cpan.org/ to report bugs & omissions, describe cross-site attacks that get through, or suggest improvements. 1047 1048=cut 1049