tags to separate posts might wish to disallow the C
tag in posts, even though C
presents no XSS hazard. =back =cut require 5.005; # for qr// use HTML::Scrubber; use vars qw(%re); %re = ( size => qr#^[+-]?\d+(?:\./d+)?[%*]?$#, color => qr#^(?:\w{2,20}|\#[\da-fA-F]{6})$#, word => qw#^\w*$#, wordlist => qr#(?:[\w\-\, ]{1,200})$#, text => qr#^[^\0]*$#, url => qr# (?:^ (?:https?|ftp) :// ) | (?:^ [\w\.,/-]+ $) #ix, a_mailto => qr# (?:^ (?:https?|ftp) :// ) | (?:^ [\w\.,/-]+ $) | (?:^ mailto: [\w\-\.\+\=\*]+\@[\w\-\.]+ $) #ix, ); sub new { my ($pkg, %cfg) = @_; my (@cite, @href, @src, @background); @cite = ( cite => $re{'url'} ) if $cfg{Allow_href}; @href = ( href => $re{'url'} ) if $cfg{Allow_href}; @src = ( src => $re{'url'} ) if $cfg{Allow_src}; @background = ( background => $re{'url'} ) if $cfg{Allow_src}; my %empty = (); my %font_attr = ( 'size' => $re{'size'}, 'face' => $re{'wordlist'}, 'color' => $re{'color'}, ); my %insdel_attr = ( @cite, 'datetime' => $re{'text'}, ); my %texta_attr = ( 'align' => $re{'word'}, ); my %cellha_attr = ( 'align' => $re{'word'}, 'char' => $re{'word'}, 'charoff' => $re{'size'}, ); my %cellva_attr = ( 'valign' => $re{'word'}, ); my %cellhv_attr = ( %cellha_attr, %cellva_attr ); my %col_attr = ( %cellhv_attr, 'width' => $re{'size'}, 'span' => $re{'number'}, ); my %thtd_attr = ( 'abbr' => $re{'text'}, 'axis' => $re{'text'}, 'headers' => $re{'text'}, 'scope' => $re{'word'}, 'rowspan' => $re{'size'}, 'colspan' => $re{'size'}, %cellhv_attr, 'nowrap' => $re{'word'}, 'bgcolor' => $re{'color'}, 'width' => $re{'size'}, 'height' => $re{'size'}, 'bordercolor' => $re{'color'}, 'bordercolorlight' => $re{'color'}, 'bordercolordark' => $re{'color'}, ); my %rules = ( 'br' => { 'clear' => $re{'word'} }, 'em' => \%empty, 'strong' => \%empty, 'dfn' => \%empty, 'code' => \%empty, 'samp' => \%empty, 'kbd' => \%empty, 'var' => \%empty, 'cite' => \%empty, 'abbr' => \%empty, 'acronym' => \%empty, 'q' => { @cite }, 'blockquote' => { @cite }, 'sub' => \%empty, 'sup' => \%empty, 'tt' => \%empty, 'i' => \%empty, 'b' => \%empty, 'big' => \%empty, 'small' => \%empty, 'u' => \%empty, 's' => \%empty, 'strike' => \%empty, 'font' => \%font_attr, 'table' => { 'frame' => $re{'word'}, 'rules' => $re{'word'}, %texta_attr, 'bgcolor' => $re{'color'}, @background, 'width' => $re{'size'}, 'height' => $re{'size'}, 'cellspacing' => $re{'size'}, 'cellpadding' => $re{'size'}, 'border' => $re{'size'}, 'bordercolor' => $re{'color'}, 'bordercolorlight' => $re{'color'}, 'bordercolordark' => $re{'color'}, 'summary' => $re{'text'}, }, 'caption' => { 'align' => $re{'word'} }, 'colgroup' => \%col_attr, 'col' => \%col_attr, 'thead' => \%cellhv_attr, 'tfoot' => \%cellhv_attr, 'tbody' => \%cellhv_attr, 'tr' => { bgcolor => $re{'color'}, %cellhv_attr, }, 'th' => \%thtd_attr, 'td' => \%thtd_attr, 'ins' => \%insdel_attr, 'del' => \%insdel_attr, 'a' => { @href }, 'h1' => \%texta_attr, 'h2' => \%texta_attr, 'h3' => \%texta_attr, 'h4' => \%texta_attr, 'h5' => \%texta_attr, 'h6' => \%texta_attr, 'p' => \%texta_attr, 'div' => \%texta_attr, 'span' => \%texta_attr, 'ul' => { 'type' => $re{'word'}, 'compact' => $re{'word'}, }, 'ol' => { 'type' => $re{'text'}, 'compact' => $re{'word'}, 'start' => $re{'size'}, }, 'li' => { 'type' => $re{'text'}, 'value' => $re{'size'}, }, 'dl' => { 'compact' => $re{'word'} }, 'dt' => \%empty, 'dd' => \%empty, 'address' => \%empty, 'hr' => { %texta_attr, 'width' => $re{'size'}, 'size ' => $re{'size'}, 'noshade' => $re{'word'}, }, 'pre' => { 'width' => $re{'size'} }, 'center' => \%empty, 'nobr' => \%empty, 'img' => { @src, 'alt' => $re{'text'}, 'width' => $re{'size'}, 'height' => $re{'size'}, 'border' => $re{'size'}, 'hspace' => $re{'size'}, 'vspace' => $re{'size'}, 'align' => $re{'word'}, }, ( $cfg{Whole_document} ? ( 'body' => { 'bgcolor' => $re{'color'}, @background, 'link' => $re{'color'}, 'vlink' => $re{'color'}, 'alink' => $re{'color'}, 'text' => $re{'color'}, }, 'head' => {}, 'title' => {}, 'html' => {}, ) : () ), ); if ( $cfg{Allow_href} and $cfg{Allow_a_mailto} ) { $rules{'a'}{'href'} = $re{'a_mailto'}; } if ( $cfg{Block_tags} ) { foreach my $block (@{ $cfg{Block_tags} }) { delete $rules{$block}; } } return HTML::Scrubber->new( rules => [%rules], comment => 0, process => 0, ); } =head1 BUGS =over =item All scripting is safely removed, but no attempt is made to ensure that there is a matching end tag for each start tag. That could be a problem if the scrubbed HTML is to be inserted into a larger HTML document, since C tags and so on could be maliciously left open. If that's a big problem for you, consider using the more heavyweight (and probably much slower) L