1# <@LICENSE> 2# Licensed to the Apache Software Foundation (ASF) under one or more 3# contributor license agreements. See the NOTICE file distributed with 4# this work for additional information regarding copyright ownership. 5# The ASF licenses this file to you under the Apache License, Version 2.0 6# (the "License"); you may not use this file except in compliance with 7# the License. You may obtain a copy of the License at: 8# 9# http://www.apache.org/licenses/LICENSE-2.0 10# 11# Unless required by applicable law or agreed to in writing, software 12# distributed under the License is distributed on an "AS IS" BASIS, 13# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 14# See the License for the specific language governing permissions and 15# limitations under the License. 16# </@LICENSE> 17 18# HTML decoding TODOs 19# - add URIs to list for faster URI testing 20 21package Mail::SpamAssassin::HTML; 22 23use strict; 24use warnings; 25use re 'taint'; 26 27require 5.008; # need basic Unicode support for HTML::Parser::utf8_mode 28# require 5.008008; # Bug 3787; [perl #37950]: Malformed UTF-8 character ... 29 30use HTML::Parser 3.43 (); 31use Mail::SpamAssassin::Logger; 32use Mail::SpamAssassin::Constants qw(:sa); 33use Mail::SpamAssassin::Util qw(untaint_var); 34 35our @ISA = qw(HTML::Parser); 36 37# elements defined by the HTML 4.01 and XHTML 1.0 DTDs (do not change them!) 38# does not include XML 39my %elements = map {; $_ => 1 } 40 # strict 41 qw( a abbr acronym address area b base bdo big blockquote body br button caption cite code col colgroup dd del dfn div dl dt em fieldset form h1 h2 h3 h4 h5 h6 head hr html i img input ins kbd label legend li link map meta noscript object ol optgroup option p param pre q samp script select small span strong style sub sup table tbody td textarea tfoot th thead title tr tt ul var ), 42 # loose 43 qw( applet basefont center dir font frame frameset iframe isindex menu noframes s strike u ), 44 # non-standard tags 45 qw( nobr x-sigsep x-tab ), 46; 47 48# elements that we want to render, but not count as valid 49my %tricks = map {; $_ => 1 } 50 # non-standard and non-valid tags 51 qw( bgsound embed listing plaintext xmp ), 52 # other non-standard tags handled in popfile 53 # blink ilayer multicol noembed nolayer spacer wbr 54; 55 56# elements that change text style 57my %elements_text_style = map {; $_ => 1 } 58 qw( body font table tr th td big small basefont marquee span p div a ), 59; 60 61# elements that insert whitespace 62my %elements_whitespace = map {; $_ => 1 } 63 qw( br div li th td dt dd p hr blockquote pre embed listing plaintext xmp title 64 h1 h2 h3 h4 h5 h6 ), 65; 66 67# elements that push URIs 68my %elements_uri = map {; $_ => 1 } 69 qw( body table tr td a area link img frame iframe embed script form base bgsound ), 70; 71 72# style attribute not accepted 73#my %elements_no_style = map {; $_ => 1 } 74# qw( base basefont head html meta param script style title ), 75#; 76 77# permitted element attributes 78my %ok_attributes; 79$ok_attributes{basefont}{$_} = 1 for qw( color face size ); 80$ok_attributes{body}{$_} = 1 for qw( text bgcolor link alink vlink background ); 81$ok_attributes{font}{$_} = 1 for qw( color face size ); 82$ok_attributes{marquee}{$_} = 1 for qw( bgcolor background ); 83$ok_attributes{table}{$_} = 1 for qw( bgcolor style ); 84$ok_attributes{td}{$_} = 1 for qw( bgcolor style ); 85$ok_attributes{th}{$_} = 1 for qw( bgcolor style ); 86$ok_attributes{tr}{$_} = 1 for qw( bgcolor style ); 87$ok_attributes{span}{$_} = 1 for qw( style ); 88$ok_attributes{p}{$_} = 1 for qw( style ); 89$ok_attributes{div}{$_} = 1 for qw( style ); 90$ok_attributes{a}{$_} = 1 for qw( style ); 91 92sub new { 93 my ($class, $character_semantics_input, $character_semantics_output) = @_; 94 my $self = $class->SUPER::new( 95 api_version => 3, 96 handlers => [ 97 start_document => ["html_start", "self"], 98 start => ["html_tag", "self,tagname,attr,'+1'"], 99 end_document => ["html_end", "self"], 100 end => ["html_tag", "self,tagname,attr,'-1'"], 101 text => ["html_text", "self,dtext"], 102 comment => ["html_comment", "self,text"], 103 declaration => ["html_declaration", "self,text"], 104 ], 105 marked_sections => 1); 106 $self->{SA_character_semantics_input} = $character_semantics_input; 107 $self->{SA_encode_results} = 108 $character_semantics_input && !$character_semantics_output; 109 $self; 110} 111 112sub html_start { 113 my ($self) = @_; 114 115 # trigger HTML_MESSAGE 116 $self->put_results(html => 1); 117 118 # initial display attributes 119 $self->{basefont} = 3; 120 my %default = (tag => "default", 121 fgcolor => "#000000", 122 bgcolor => "#ffffff", 123 size => $self->{basefont}); 124 push @{ $self->{text_style} }, \%default; 125} 126 127sub html_end { 128 my ($self) = @_; 129 130 delete $self->{text_style}; 131 132 my @uri; 133 134 # add the canonicalized version of each uri to the detail list 135 if (defined $self->{uri}) { 136 @uri = keys %{$self->{uri}}; 137 } 138 139 # these keep backward compatibility, albeit a little wasteful 140 $self->put_results(uri => \@uri); 141 $self->put_results(anchor => $self->{anchor}); 142 143 $self->put_results(uri_detail => $self->{uri}); 144 $self->put_results(uri_truncated => $self->{uri_truncated}); 145 146 # final results scalars 147 $self->put_results(image_area => $self->{image_area}); 148 $self->put_results(length => $self->{length}); 149 $self->put_results(min_size => $self->{min_size}); 150 $self->put_results(max_size => $self->{max_size}); 151 if (exists $self->{tags}) { 152 $self->put_results(closed_extra_ratio => 153 ($self->{closed_extra} / $self->{tags})); 154 } 155 156 # final result arrays 157 $self->put_results(comment => $self->{comment}); 158 $self->put_results(script => $self->{script}); 159 $self->put_results(title => $self->{title}); 160 161 # final result hashes 162 $self->put_results(inside => $self->{inside}); 163 164 # end-of-document result values that don't require looking at the text 165 if (exists $self->{backhair}) { 166 $self->put_results(backhair_count => scalar keys %{ $self->{backhair} }); 167 } 168 if (exists $self->{elements} && exists $self->{tags}) { 169 $self->put_results(bad_tag_ratio => 170 ($self->{tags} - $self->{elements}) / $self->{tags}); 171 } 172 if (exists $self->{elements_seen} && exists $self->{tags_seen}) { 173 $self->put_results(non_element_ratio => 174 ($self->{tags_seen} - $self->{elements_seen}) / 175 $self->{tags_seen}); 176 } 177 if (exists $self->{tags} && exists $self->{obfuscation}) { 178 $self->put_results(obfuscation_ratio => 179 $self->{obfuscation} / $self->{tags}); 180 } 181} 182 183sub put_results { 184 my $self = shift; 185 my %results = @_; 186 187 while (my ($k, $v) = each %results) { 188 $self->{results}{$k} = $v; 189 } 190} 191 192sub get_results { 193 my ($self) = @_; 194 195 return $self->{results}; 196} 197 198sub get_rendered_text { 199 my $self = shift; 200 my %options = @_; 201 202 return join('', @{ $self->{text} }) unless %options; 203 204 my $mask; 205 while (my ($k, $v) = each %options) { 206 next if !defined $self->{"text_$k"}; 207 if (!defined $mask) { 208 $mask |= $v ? $self->{"text_$k"} : ~ $self->{"text_$k"}; 209 } 210 else { 211 $mask &= $v ? $self->{"text_$k"} : ~ $self->{"text_$k"}; 212 } 213 } 214 215 my $text = ''; 216 my $i = 0; 217 for (@{ $self->{text} }) { $text .= $_ if vec($mask, $i++, 1); } 218 return $text; 219} 220 221sub parse { 222 my ($self, $text) = @_; 223 224 $self->{image_area} = 0; 225 $self->{title_index} = -1; 226 $self->{max_size} = 3; # start at default size 227 $self->{min_size} = 3; # start at default size 228 $self->{closed_html} = 0; 229 $self->{closed_body} = 0; 230 $self->{closed_extra} = 0; 231 $self->{text} = []; # rendered text 232 $self->{length} += untaint_var(length($text)); 233 234 # NOTE: We *only* need to fix the rendering when we verify that it 235 # differs from what people see in their MUA. Testing is best done with 236 # the most common MUAs and browsers, if you catch my drift. 237 238 # NOTE: HTML::Parser can cope with: <?xml pis>, <? with space>, so we 239 # don't need to fix them here. 240 241 # # (outdated claim) HTML::Parser converts into a question mark ("?") 242 # # for some reason, so convert them to spaces. Confirmed in 3.31, at least. 243 # ... Actually it doesn't, it is correctly converted into Unicode NBSP, 244 # nevertheless it does not hurt to treat it as a space. 245 $text =~ s/ / /g; 246 247 # bug 4695: we want "<br/>" to be treated the same as "<br>", and 248 # the HTML::Parser API won't do it for us 249 $text =~ s/<(\w+)\s*\/>/<$1>/gi; 250 251 if (!$self->UNIVERSAL::can('utf8_mode')) { 252 # utf8_mode is cleared by default, only warn if it would need to be set 253 warn "message: cannot set utf8_mode, module HTML::Parser is too old\n" 254 if !$self->{SA_character_semantics_input}; 255 } else { 256 $self->SUPER::utf8_mode($self->{SA_character_semantics_input} ? 0 : 1); 257 my $utf8_mode = $self->SUPER::utf8_mode; 258 dbg("message: HTML::Parser utf8_mode %s", 259 $utf8_mode ? "on (assumed UTF-8 octets)" 260 : "off (default, assumed Unicode characters)"); 261 } 262 263 eval { 264 local $SIG{__WARN__} = sub { 265 my $err = $_[0]; 266 $err =~ s/\s+/ /gs; $err =~ s/(.*) at .*/$1/s; 267 info("message: HTML::Parser warning: $err"); 268 }; 269 $self->SUPER::parse($text); 270 }; 271 272 # bug 7437: deal gracefully with HTML::Parser misbehavior on unclosed <style> and <script> tags 273 # (typically from not passing the entire message to spamc, but possibly a DoS attack) 274 $self->SUPER::parse("</style>") while exists $self->{inside}{style} && $self->{inside}{style} > 0; 275 $self->SUPER::parse("</script>") while exists $self->{inside}{script} && $self->{inside}{script} > 0; 276 277 $self->SUPER::eof; 278 279 return $self->{text}; 280} 281 282sub html_tag { 283 my ($self, $tag, $attr, $num) = @_; 284 utf8::encode($tag) if $self->{SA_encode_results}; 285 286 my $maybe_namespace = ($tag =~ m@^(?:o|st\d):[\w-]+/?$@); 287 288 if (exists $elements{$tag} || $maybe_namespace) { 289 $self->{elements}++; 290 $self->{elements_seen}++ if !exists $self->{inside}{$tag}; 291 } 292 $self->{tags}++; 293 $self->{tags_seen}++ if !exists $self->{inside}{$tag}; 294 $self->{inside}{$tag} += $num; 295 if ($self->{inside}{$tag} < 0) { 296 $self->{inside}{$tag} = 0; 297 $self->{closed_extra}++; 298 } 299 300 return if $maybe_namespace; 301 302 # ignore non-elements 303 if (exists $elements{$tag} || exists $tricks{$tag}) { 304 $self->text_style($tag, $attr, $num) if exists $elements_text_style{$tag}; 305 306 # bug 5009: things like <p> and </p> both need dealing with 307 $self->html_whitespace($tag) if exists $elements_whitespace{$tag}; 308 309 # start tags 310 if ($num == 1) { 311 $self->html_uri($tag, $attr) if exists $elements_uri{$tag}; 312 $self->html_tests($tag, $attr, $num); 313 } 314 # end tags 315 else { 316 $self->{closed_html} = 1 if $tag eq "html"; 317 $self->{closed_body} = 1 if $tag eq "body"; 318 } 319 } 320} 321 322sub html_whitespace { 323 my ($self, $tag) = @_; 324 325 # ordered by frequency of tag groups, note: whitespace is always "visible" 326 if ($tag eq "br" || $tag eq "div") { 327 $self->display_text("\n", whitespace => 1); 328 } 329 elsif ($tag =~ /^(?:li|t[hd]|d[td]|embed|h\d)$/) { 330 $self->display_text(" ", whitespace => 1); 331 } 332 elsif ($tag =~ /^(?:p|hr|blockquote|pre|listing|plaintext|xmp|title)$/) { 333 $self->display_text("\n\n", whitespace => 1); 334 } 335} 336 337# puts the uri onto the internal array 338# note: uri may be blank (<a href=""></a> obfuscation, etc.) 339sub push_uri { 340 my ($self, $type, $uri) = @_; 341 342 $uri = $self->canon_uri($uri); 343 utf8::encode($uri) if $self->{SA_encode_results}; 344 345 my $target = target_uri($self->{base_href} || "", $uri); 346 347 # skip things like <iframe src="" ...> 348 $self->{uri}->{$uri}->{types}->{$type} = 1 if $uri ne ''; 349} 350 351sub canon_uri { 352 my ($self, $uri) = @_; 353 354 # URIs don't have leading/trailing whitespace ... 355 $uri =~ s/^\s+//; 356 $uri =~ s/\s+$//; 357 358 # Make sure all the URIs are nice and short 359 if (length $uri > MAX_URI_LENGTH) { 360 $self->{'uri_truncated'} = 1; 361 $uri = substr $uri, 0, MAX_URI_LENGTH; 362 } 363 364 return $uri; 365} 366 367sub html_uri { 368 my ($self, $tag, $attr) = @_; 369 370 # ordered by frequency of tag groups 371 if ($tag =~ /^(?:body|table|tr|td)$/) { 372 if (defined $attr->{background}) { 373 $self->push_uri($tag, $attr->{background}); 374 } 375 } 376 elsif ($tag =~ /^(?:a|area|link)$/) { 377 if (defined $attr->{href}) { 378 $self->push_uri($tag, $attr->{href}); 379 } 380 if (defined $attr->{'data-saferedirecturl'}) { 381 $self->push_uri($tag, $attr->{'data-saferedirecturl'}); 382 } 383 } 384 elsif ($tag =~ /^(?:img|frame|iframe|embed|script|bgsound)$/) { 385 if (defined $attr->{src}) { 386 $self->push_uri($tag, $attr->{src}); 387 } 388 } 389 elsif ($tag eq "form") { 390 if (defined $attr->{action}) { 391 $self->push_uri($tag, $attr->{action}); 392 } 393 } 394 elsif ($tag eq "base") { 395 if (my $uri = $attr->{href}) { 396 $uri = $self->canon_uri($uri); 397 398 # use <BASE HREF="URI"> to turn relative links into absolute links 399 400 # even if it is a base URI, handle like a normal URI as well 401 $self->push_uri($tag, $uri); 402 403 # a base URI will be ignored by browsers unless it is an absolute 404 # URI of a standard protocol 405 if ($uri =~ m@^(?:https?|ftp):/{0,2}@i) { 406 # remove trailing filename, if any; base URIs can have the 407 # form of "http://foo.com/index.html" 408 $uri =~ s@^([a-z]+:/{0,2}[^/]+/.*?)[^/\.]+\.[^/\.]{2,4}$@$1@i; 409 410 # Make sure it ends in a slash 411 $uri .= "/" unless $uri =~ m@/$@; 412 utf8::encode($uri) if $self->{SA_encode_results}; 413 $self->{base_href} = $uri; 414 } 415 } 416 } 417} 418 419# this might not be quite right, may need to pay attention to table nesting 420sub close_table_tag { 421 my ($self, $tag) = @_; 422 423 # don't close if never opened 424 return unless grep { $_->{tag} eq $tag } @{ $self->{text_style} }; 425 426 my $top; 427 while (@{ $self->{text_style} } && ($top = $self->{text_style}[-1]->{tag})) { 428 if (($tag eq "td" && ($top eq "font" || $top eq "td")) || 429 ($tag eq "tr" && $top =~ /^(?:font|td|tr)$/)) 430 { 431 pop @{ $self->{text_style} }; 432 } 433 else { 434 last; 435 } 436 } 437} 438 439sub close_tag { 440 my ($self, $tag) = @_; 441 442 # don't close if never opened 443 return if !grep { $_->{tag} eq $tag } @{ $self->{text_style} }; 444 445 # close everything up to and including tag 446 while (my %current = %{ pop @{ $self->{text_style} } }) { 447 last if $current{tag} eq $tag; 448 } 449} 450 451sub text_style { 452 my ($self, $tag, $attr, $num) = @_; 453 454 # treat <th> as <td> 455 $tag = "td" if $tag eq "th"; 456 457 # open 458 if ($num == 1) { 459 # HTML browsers generally only use first <body> for colors, 460 # so only push if we haven't seen a body tag yet 461 if ($tag eq "body") { 462 # TODO: skip if we've already seen body 463 } 464 465 # change basefont (only change size) 466 if ($tag eq "basefont" && 467 exists $attr->{size} && $attr->{size} =~ /^\s*(\d+)/) 468 { 469 $self->{basefont} = $1; 470 return; 471 } 472 473 # close elements with optional end tags 474 $self->close_table_tag($tag) if ($tag eq "td" || $tag eq "tr"); 475 476 # copy current text state 477 my %new = %{ $self->{text_style}[-1] }; 478 479 # change tag name! 480 $new{tag} = $tag; 481 482 # big and small tags 483 if ($tag eq "big") { 484 $new{size} += 1; 485 push @{ $self->{text_style} }, \%new; 486 return; 487 } 488 if ($tag eq "small") { 489 $new{size} -= 1; 490 push @{ $self->{text_style} }, \%new; 491 return; 492 } 493 494 # tag attributes 495 for my $name (keys %$attr) { 496 next unless exists $ok_attributes{$tag}{$name}; 497 if ($name eq "text" || $name eq "color") { 498 # two different names for text color 499 $new{fgcolor} = name_to_rgb($attr->{$name}); 500 } 501 elsif ($name eq "size") { 502 if ($attr->{size} =~ /^\s*([+-]\d+)/) { 503 # relative font size 504 $new{size} = $self->{basefont} + $1; 505 } 506 elsif ($attr->{size} =~ /^\s*(\d+)/) { 507 # absolute font size 508 $new{size} = $1; 509 } 510 } 511 elsif ($name eq 'style') { 512 $new{style} = $attr->{style}; 513 my @parts = split(/;/, $new{style}); 514 foreach (@parts) { 515 if (/^\s*(background-)?color:\s*(.+?)\s*$/i) { 516 my $whcolor = $1 ? 'bgcolor' : 'fgcolor'; 517 my $value = lc $2; 518 519 if ($value =~ /rgb/) { 520 $value =~ tr/0-9,//cd; 521 my @rgb = split(/,/, $value); 522 $new{$whcolor} = sprintf("#%02x%02x%02x", 523 map { !$_ ? 0 : $_ > 255 ? 255 : $_ } 524 @rgb[0..2]); 525 } 526 elsif ($value eq 'inherit') { 527 # do nothing, just prevent parsing of the valid 528 # CSS3 property value as 'invalid color' (Bug 7778) 529 } 530 else { 531 $new{$whcolor} = name_to_rgb($value); 532 } 533 } 534 elsif (/^\s*([a-z_-]+)\s*:\s*(\S.*?)\s*$/i) { 535 # "display: none", "visibility: hidden", etc. 536 $new{'style_'.$1} = $2; 537 } 538 } 539 } 540 elsif ($name eq "bgcolor") { 541 # overwrite with hex value, $new{bgcolor} is set below 542 $attr->{bgcolor} = name_to_rgb($attr->{bgcolor}); 543 } 544 else { 545 # attribute is probably okay 546 $new{$name} = $attr->{$name}; 547 } 548 549 if ($new{size} > $self->{max_size}) { 550 $self->{max_size} = $new{size}; 551 } 552 elsif ($new{size} < $self->{min_size}) { 553 $self->{min_size} = $new{size}; 554 } 555 } 556 push @{ $self->{text_style} }, \%new; 557 } 558 # explicitly close a tag 559 else { 560 if ($tag ne "body") { 561 # don't close body since browsers seem to render text after </body> 562 $self->close_tag($tag); 563 } 564 } 565} 566 567sub html_font_invisible { 568 my ($self, $text) = @_; 569 570 my $fg = $self->{text_style}[-1]->{fgcolor}; 571 my $bg = $self->{text_style}[-1]->{bgcolor}; 572 my $size = $self->{text_style}[-1]->{size}; 573 my $display = $self->{text_style}[-1]->{style_display}; 574 my $visibility = $self->{text_style}[-1]->{style_visibility}; 575 576 # invisibility 577 if (substr($fg,-6) eq substr($bg,-6)) { 578 $self->put_results(font_low_contrast => 1); 579 return 1; 580 # near-invisibility 581 } elsif ($fg =~ /^\#?([0-9a-f]{2})([0-9a-f]{2})([0-9a-f]{2})$/) { 582 my ($r1, $g1, $b1) = (hex($1), hex($2), hex($3)); 583 584 if ($bg =~ /^\#?([0-9a-f]{2})([0-9a-f]{2})([0-9a-f]{2})$/) { 585 my ($r2, $g2, $b2) = (hex($1), hex($2), hex($3)); 586 587 my $r = ($r1 - $r2); 588 my $g = ($g1 - $g2); 589 my $b = ($b1 - $b2); 590 591 # geometric distance weighted by brightness 592 # maximum distance is 191.151823601032 593 my $distance = ((0.2126*$r)**2 + (0.7152*$g)**2 + (0.0722*$b)**2)**0.5; 594 595 # the text is very difficult to read if the distance is under 12, 596 # a limit of 14 to 16 might be okay if the usage significantly 597 # increases (near-invisible text is at about 0.95% of spam and 598 # 1.25% of HTML spam right now), but please test any changes first 599 if ($distance < 12) { 600 $self->put_results(font_low_contrast => 1); 601 return 1; 602 } 603 } 604 } 605 606 607 # invalid color 608 if ($fg eq 'invalid' or $bg eq 'invalid') { 609 $self->put_results(font_invalid_color => 1); 610 return 1; 611 } 612 613 # size too small 614 if ($size <= 1) { 615 return 1; 616 } 617 618 # <span style="display: none"> 619 if ($display && lc $display eq 'none') { 620 return 1; 621 } 622 623 if ($visibility && lc $visibility eq 'hidden') { 624 return 1; 625 } 626 627 return 0; 628} 629 630sub html_tests { 631 my ($self, $tag, $attr, $num) = @_; 632 633 if ($tag eq "font" && exists $attr->{face}) { 634 # Fixes from Bug 5956, 7312 635 # Examples seen in ham: 636 # "Tahoma", Verdana, Arial, sans-serif 637 # 'Montserrat', sans-serif 638 # Arial,Helvetica,Sans-Serif; 639 # .SFUIDisplay 640 # hirakakupro-w3 641 # TODO: There's still the problem completely foreign unicode strings, 642 # probably this rule should be deprecated. 643 if ($attr->{face} !~ /^\s*["'.]?[a-z ][a-z -]*[a-z]\d?["']?(?:,\s*["']?[a-z][a-z -]*[a-z]\d?["']?)*;?$/i) { 644 $self->put_results(font_face_bad => 1); 645 } 646 } 647 if ($tag eq "img" && exists $self->{inside}{a} && $self->{inside}{a} > 0) { 648 my $uri = $self->{anchor_last}; 649 utf8::encode($uri) if $self->{SA_encode_results}; 650 $self->{uri}->{$uri}->{anchor_text}->[-1] .= "<img>\n"; 651 $self->{anchor}->[-1] .= "<img>\n"; 652 } 653 654 if ($tag eq "img" && exists $attr->{width} && exists $attr->{height}) { 655 my $width = 0; 656 my $height = 0; 657 my $area = 0; 658 659 # assume 800x600 screen for percentage values 660 if ($attr->{width} =~ /^(\d+)(\%)?$/) { 661 $width = $1; 662 $width *= 8 if (defined $2 && $2 eq "%"); 663 } 664 if ($attr->{height} =~ /^(\d+)(\%)?$/) { 665 $height = $1; 666 $height *= 6 if (defined $2 && $2 eq "%"); 667 } 668 # guess size 669 $width = 200 if $width <= 0; 670 $height = 200 if $height <= 0; 671 if ($width > 0 && $height > 0) { 672 $area = $width * $height; 673 $self->{image_area} += $area; 674 } 675 } 676 if ($tag eq "form" && exists $attr->{action}) { 677 $self->put_results(form_action_mailto => 1) if $attr->{action} =~ /mailto:/i 678 } 679 if ($tag eq "object" || $tag eq "embed") { 680 $self->put_results(embeds => 1); 681 } 682 683 # special text delimiters - <a> and <title> 684 if ($tag eq "a") { 685 my $uri = $self->{anchor_last} = 686 (exists $attr->{href} ? $self->canon_uri($attr->{href}) : ""); 687 utf8::encode($uri) if $self->{SA_encode_results}; 688 push(@{$self->{uri}->{$uri}->{anchor_text}}, ''); 689 push(@{$self->{anchor}}, ''); 690 } 691 if ($tag eq "title") { 692 $self->{title_index}++; 693 $self->{title}->[$self->{title_index}] = ""; 694 } 695 696 if ($tag eq "meta" && 697 exists $attr->{'http-equiv'} && 698 exists $attr->{content} && 699 $attr->{'http-equiv'} =~ /Content-Type/i && 700 $attr->{content} =~ /\bcharset\s*=\s*["']?([^"']+)/i) 701 { 702 $self->{charsets} .= exists $self->{charsets} ? " $1" : $1; 703 } 704} 705 706sub display_text { 707 my $self = shift; 708 my $text = shift; 709 my %display = @_; 710 711 # Unless it's specified to be invisible, then it's not invisible. ;) 712 if (!exists $display{invisible}) { 713 $display{invisible} = 0; 714 } 715 716 if ($display{whitespace}) { 717 # trim trailing whitespace from previous element if it was not whitespace 718 # and it was not invisible 719 if (@{ $self->{text} } && 720 (!defined $self->{text_whitespace} || 721 !vec($self->{text_whitespace}, $#{$self->{text}}, 1)) && 722 (!defined $self->{text_invisible} || 723 !vec($self->{text_invisible}, $#{$self->{text}}, 1))) 724 { 725 $self->{text}->[-1] =~ s/ $//; 726 } 727 } 728 else { 729 # NBSP: UTF-8: C2 A0, ISO-8859-*: A0 730 $text =~ s/[ \t\n\r\f\x0b]+|\xc2\xa0/ /gs; 731 # trim leading whitespace if previous element was whitespace 732 # and current element is not invisible 733 if (@{ $self->{text} } && !$display{invisible} && 734 defined $self->{text_whitespace} && 735 vec($self->{text_whitespace}, $#{$self->{text}}, 1)) 736 { 737 $text =~ s/^ //; 738 } 739 } 740 push @{ $self->{text} }, $text; 741 while (my ($k, $v) = each %display) { 742 my $textvar = "text_".$k; 743 if (!exists $self->{$textvar}) { $self->{$textvar} = ''; } 744 vec($self->{$textvar}, $#{$self->{text}}, 1) = $v; 745 } 746} 747 748sub html_text { 749 my ($self, $text) = @_; 750 utf8::encode($text) if $self->{SA_encode_results}; 751 752 # text that is not part of body 753 if (exists $self->{inside}{script} && $self->{inside}{script} > 0) 754 { 755 push @{ $self->{script} }, $text; 756 return; 757 } 758 if (exists $self->{inside}{style} && $self->{inside}{style} > 0) { 759 return; 760 } 761 762 # text that is part of body and also stored separately 763 if (exists $self->{inside}{a} && $self->{inside}{a} > 0) { 764 # this doesn't worry about nested anchors 765 my $uri = $self->{anchor_last}; 766 utf8::encode($uri) if $self->{SA_encode_results}; 767 $self->{uri}->{$uri}->{anchor_text}->[-1] .= $text; 768 $self->{anchor}->[-1] .= $text; 769 } 770 if (exists $self->{inside}{title} && $self->{inside}{title} > 0) { 771 $self->{title}->[$self->{title_index}] .= $text; 772 } 773 774 my $invisible_for_bayes = 0; 775 776 # NBSP: UTF-8: C2 A0, ISO-8859-*: A0 777 # Bug 7374 - regex recursion limit exceeded 778 #if ($text !~ /^(?:[ \t\n\r\f\x0b]|\xc2\xa0)*\z/s) { 779 # .. alternative way, remove from string and see if there's anything left 780 if (do {(my $tmp = $text) =~ s/(?:[ \t\n\r\f\x0b]|\xc2\xa0)//gs; length($tmp)}) { 781 $invisible_for_bayes = $self->html_font_invisible($text); 782 } 783 784 if (exists $self->{text}->[-1]) { 785 # ideas discarded since they would be easy to evade: 786 # 1. using \w or [A-Za-z] instead of \S or non-punctuation 787 # 2. exempting certain tags 788 # no re "strict"; # since perl 5.21.8: Ranges of ASCII printables... 789 if ($text =~ /^[^\s\x21-\x2f\x3a-\x40\x5b-\x60\x7b-\x7e]/s && 790 $self->{text}->[-1] =~ /[^\s\x21-\x2f\x3a-\x40\x5b-\x60\x7b-\x7e]\z/s) 791 { 792 $self->{obfuscation}++; 793 } 794 if ($self->{text}->[-1] =~ 795 /\b([^\s\x21-\x2f\x3a-\x40\x5b-\x60\x7b-\x7e]{1,7})\z/s) 796 { 797 my $start = length($1); 798 if ($text =~ /^([^\s\x21-\x2f\x3a-\x40\x5b-\x60\x7b-\x7e]{1,7})\b/s) { 799 $self->{backhair}->{$start . "_" . length($1)}++; 800 } 801 } 802 } 803 804 if ($invisible_for_bayes) { 805 $self->display_text($text, invisible => 1); 806 } 807 else { 808 $self->display_text($text); 809 } 810} 811 812# note: $text includes <!-- and --> 813sub html_comment { 814 my ($self, $text) = @_; 815 utf8::encode($text) if $self->{SA_encode_results}; 816 817 push @{ $self->{comment} }, $text; 818} 819 820sub html_declaration { 821 my ($self, $text) = @_; 822 utf8::encode($text) if $self->{SA_encode_results}; 823 824 if ($text =~ /^<!doctype/i) { 825 my $tag = "!doctype"; 826 $self->{elements}++; 827 $self->{tags}++; 828 $self->{inside}{$tag} = 0; 829 } 830} 831 832########################################################################### 833 834my %html_color = ( 835 # HTML 4 defined 16 colors 836 aqua => 0x00ffff, 837 black => 0x000000, 838 blue => 0x0000ff, 839 fuchsia => 0xff00ff, 840 gray => 0x808080, 841 green => 0x008000, 842 lime => 0x00ff00, 843 maroon => 0x800000, 844 navy => 0x000080, 845 olive => 0x808000, 846 purple => 0x800080, 847 red => 0xff0000, 848 silver => 0xc0c0c0, 849 teal => 0x008080, 850 white => 0xffffff, 851 yellow => 0xffff00, 852 # colors specified in CSS3 color module 853 aliceblue => 0xf0f8ff, 854 antiquewhite => 0xfaebd7, 855 aqua => 0x00ffff, 856 aquamarine => 0x7fffd4, 857 azure => 0xf0ffff, 858 beige => 0xf5f5dc, 859 bisque => 0xffe4c4, 860 black => 0x000000, 861 blanchedalmond => 0xffebcd, 862 blue => 0x0000ff, 863 blueviolet => 0x8a2be2, 864 brown => 0xa52a2a, 865 burlywood => 0xdeb887, 866 cadetblue => 0x5f9ea0, 867 chartreuse => 0x7fff00, 868 chocolate => 0xd2691e, 869 coral => 0xff7f50, 870 cornflowerblue => 0x6495ed, 871 cornsilk => 0xfff8dc, 872 crimson => 0xdc143c, 873 cyan => 0x00ffff, 874 darkblue => 0x00008b, 875 darkcyan => 0x008b8b, 876 darkgoldenrod => 0xb8860b, 877 darkgray => 0xa9a9a9, 878 darkgreen => 0x006400, 879 darkgrey => 0xa9a9a9, 880 darkkhaki => 0xbdb76b, 881 darkmagenta => 0x8b008b, 882 darkolivegreen => 0x556b2f, 883 darkorange => 0xff8c00, 884 darkorchid => 0x9932cc, 885 darkred => 0x8b0000, 886 darksalmon => 0xe9967a, 887 darkseagreen => 0x8fbc8f, 888 darkslateblue => 0x483d8b, 889 darkslategray => 0x2f4f4f, 890 darkslategrey => 0x2f4f4f, 891 darkturquoise => 0x00ced1, 892 darkviolet => 0x9400d3, 893 deeppink => 0xff1493, 894 deepskyblue => 0x00bfff, 895 dimgray => 0x696969, 896 dimgrey => 0x696969, 897 dodgerblue => 0x1e90ff, 898 firebrick => 0xb22222, 899 floralwhite => 0xfffaf0, 900 forestgreen => 0x228b22, 901 fuchsia => 0xff00ff, 902 gainsboro => 0xdcdcdc, 903 ghostwhite => 0xf8f8ff, 904 gold => 0xffd700, 905 goldenrod => 0xdaa520, 906 gray => 0x808080, 907 green => 0x008000, 908 greenyellow => 0xadff2f, 909 grey => 0x808080, 910 honeydew => 0xf0fff0, 911 hotpink => 0xff69b4, 912 indianred => 0xcd5c5c, 913 indigo => 0x4b0082, 914 ivory => 0xfffff0, 915 khaki => 0xf0e68c, 916 lavender => 0xe6e6fa, 917 lavenderblush => 0xfff0f5, 918 lawngreen => 0x7cfc00, 919 lemonchiffon => 0xfffacd, 920 lightblue => 0xadd8e6, 921 lightcoral => 0xf08080, 922 lightcyan => 0xe0ffff, 923 lightgoldenrodyellow => 0xfafad2, 924 lightgray => 0xd3d3d3, 925 lightgreen => 0x90ee90, 926 lightgrey => 0xd3d3d3, 927 lightpink => 0xffb6c1, 928 lightsalmon => 0xffa07a, 929 lightseagreen => 0x20b2aa, 930 lightskyblue => 0x87cefa, 931 lightslategray => 0x778899, 932 lightslategrey => 0x778899, 933 lightsteelblue => 0xb0c4de, 934 lightyellow => 0xffffe0, 935 lime => 0x00ff00, 936 limegreen => 0x32cd32, 937 linen => 0xfaf0e6, 938 magenta => 0xff00ff, 939 maroon => 0x800000, 940 mediumaquamarine => 0x66cdaa, 941 mediumblue => 0x0000cd, 942 mediumorchid => 0xba55d3, 943 mediumpurple => 0x9370db, 944 mediumseagreen => 0x3cb371, 945 mediumslateblue => 0x7b68ee, 946 mediumspringgreen => 0x00fa9a, 947 mediumturquoise => 0x48d1cc, 948 mediumvioletred => 0xc71585, 949 midnightblue => 0x191970, 950 mintcream => 0xf5fffa, 951 mistyrose => 0xffe4e1, 952 moccasin => 0xffe4b5, 953 navajowhite => 0xffdead, 954 navy => 0x000080, 955 oldlace => 0xfdf5e6, 956 olive => 0x808000, 957 olivedrab => 0x6b8e23, 958 orange => 0xffa500, 959 orangered => 0xff4500, 960 orchid => 0xda70d6, 961 palegoldenrod => 0xeee8aa, 962 palegreen => 0x98fb98, 963 paleturquoise => 0xafeeee, 964 palevioletred => 0xdb7093, 965 papayawhip => 0xffefd5, 966 peachpuff => 0xffdab9, 967 peru => 0xcd853f, 968 pink => 0xffc0cb, 969 plum => 0xdda0dd, 970 powderblue => 0xb0e0e6, 971 purple => 0x800080, 972 red => 0xff0000, 973 rosybrown => 0xbc8f8f, 974 royalblue => 0x4169e1, 975 saddlebrown => 0x8b4513, 976 salmon => 0xfa8072, 977 sandybrown => 0xf4a460, 978 seagreen => 0x2e8b57, 979 seashell => 0xfff5ee, 980 sienna => 0xa0522d, 981 silver => 0xc0c0c0, 982 skyblue => 0x87ceeb, 983 slateblue => 0x6a5acd, 984 slategray => 0x708090, 985 slategrey => 0x708090, 986 snow => 0xfffafa, 987 springgreen => 0x00ff7f, 988 steelblue => 0x4682b4, 989 tan => 0xd2b48c, 990 teal => 0x008080, 991 thistle => 0xd8bfd8, 992 tomato => 0xff6347, 993 turquoise => 0x40e0d0, 994 violet => 0xee82ee, 995 wheat => 0xf5deb3, 996 white => 0xffffff, 997 whitesmoke => 0xf5f5f5, 998 yellow => 0xffff00, 999 yellowgreen => 0x9acd32, 1000); 1001 1002sub name_to_rgb_old { 1003 my $color = lc $_[0]; 1004 1005 # note: Mozilla strips leading and trailing whitespace at this point, 1006 # but IE does not 1007 1008 # named colors 1009 my $hex = $html_color{$color}; 1010 if (defined $hex) { 1011 return sprintf("#%06x", $hex); 1012 } 1013 1014 # Flex Hex: John Graham-Cumming, http://www.jgc.org/pdf/lisa2004.pdf 1015 # strip optional # character 1016 $color =~ s/^#//; 1017 # pad right-hand-side to a multiple of three 1018 $color .= "0" x (3 - (length($color) % 3)) if (length($color) % 3); 1019 # split into triplets 1020 my $length = length($color) / 3; 1021 my @colors = ($color =~ /(.{$length})(.{$length})(.{$length})/); 1022 # truncate each color to a DWORD, take MSB, left pad nibbles 1023 foreach (@colors) { s/.*(.{8})$/$1/; s/(..).*/$1/; s/^(.)$/0$1/ }; 1024 # the color 1025 $color = join("", @colors); 1026 # replace non-hex characters with 0 1027 $color =~ tr/0-9a-f/0/c; 1028 1029 return "#" . $color; 1030} 1031 1032sub name_to_rgb { 1033 my $color = lc $_[0]; 1034 my $before = $color; 1035 1036 # strip leading and ending whitespace 1037 $color =~ s/^\s*//; 1038 $color =~ s/\s*$//; 1039 1040 # named colors 1041 my $hex = $html_color{$color}; 1042 if (defined $hex) { 1043 return sprintf("#%06x", $hex); 1044 } 1045 1046 # IF NOT A NAME, IT SHOULD BE A HEX COLOR, HEX SHORTHAND or rgb values 1047 if ($color =~ m/^[#a-f0-9]*$|rgb\([\d%, ]*\)/i) { 1048 1049 #Convert the RGB values to hex values so we can fall through on the programming 1050 1051 #RGB PERCENTS TO HEX 1052 if ($color =~ m/rgb\((\d+)%,\s*(\d+)%,\s*(\d+)%\s*\)/i) { 1053 $color = "#".dec2hex(int($1/100*255)).dec2hex(int($2/100*255)).dec2hex(int($3/100*255)); 1054 } 1055 1056 #RGB DEC TO HEX 1057 if ($color =~ m/rgb\((\d+),\s*(\d+),\s*(\d+)\s*\)/i) { 1058 $color = "#".dec2hex($1).dec2hex($2).dec2hex($3); 1059 } 1060 1061 #PARSE THE HEX 1062 if ($color =~ m/^#/) { 1063 # strip to hex only 1064 $color =~ s/[^a-f0-9]//ig; 1065 1066 # strip to 6 if greater than 6 1067 if (length($color) > 6) { 1068 $color=substr($color,0,6); 1069 } 1070 1071 # strip to 3 if length < 6) 1072 if (length($color) > 3 && length($color) < 6) { 1073 $color=substr($color,0,3); 1074 } 1075 1076 # pad right-hand-side to a multiple of three 1077 $color .= "0" x (3 - (length($color) % 3)) if (length($color) % 3); 1078 1079 #DUPLICATE SHORTHAND HEX 1080 if (length($color) == 3) { 1081 $color =~ m/(.)(.)(.)/; 1082 $color = "$1$1$2$2$3$3"; 1083 } 1084 1085 } else { 1086 return "invalid"; 1087 } 1088 1089 } else { 1090 #INVALID 1091 1092 #??RETURN BLACK SINCE WE DO NOT KNOW HOW THE MUA / BROWSER WILL PARSE 1093 #$color = "000000"; 1094 1095 return "invalid"; 1096 } 1097 1098 #print "DEBUG: before/after name_to_rgb new version: $before/$color\n"; 1099 1100 return "#" . $color; 1101} 1102 1103sub dec2hex { 1104 my ($dec) = @_; 1105 my ($pre) = ''; 1106 1107 if ($dec < 16) { 1108 $pre = '0'; 1109 } 1110 1111 return sprintf("$pre%lx", $dec); 1112} 1113 1114 1115use constant URI_STRICT => 0; 1116 1117# resolving relative URIs as defined in RFC 2396 (steps from section 5.2) 1118# using draft http://www.gbiv.com/protocols/uri/rev-2002/rfc2396bis.html 1119sub _parse_uri { 1120 my ($u) = @_; 1121 my %u; 1122 ($u{scheme}, $u{authority}, $u{path}, $u{query}, $u{fragment}) = 1123 $u =~ m|^(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|; 1124 return %u; 1125} 1126 1127sub _remove_dot_segments { 1128 my ($input) = @_; 1129 my $output = ""; 1130 1131 $input =~ s@^(?:\.\.?/)@/@; 1132 1133 while ($input) { 1134 if ($input =~ s@^/\.(?:$|/)@/@) { 1135 } 1136 elsif ($input =~ s@^/\.\.(?:$|/)@/@) { 1137 $output =~ s@/?[^/]*$@@; 1138 } 1139 elsif ($input =~ s@(/?[^/]*)@@) { 1140 $output .= $1; 1141 } 1142 } 1143 return $output; 1144} 1145 1146sub _merge_uri { 1147 my ($base_authority, $base_path, $r_path) = @_; 1148 1149 if (defined $base_authority && !$base_path) { 1150 return "/" . $r_path; 1151 } 1152 else { 1153 if ($base_path =~ m|/|) { 1154 $base_path =~ s|(?<=/)[^/]*$||; 1155 } 1156 else { 1157 $base_path = ""; 1158 } 1159 return $base_path . $r_path; 1160 } 1161} 1162 1163sub target_uri { 1164 my ($base, $r) = @_; 1165 1166 my %r = _parse_uri($r); # parsed relative URI 1167 my %base = _parse_uri($base); # parsed base URI 1168 my %t; # generated temporary URI 1169 1170 if ((not URI_STRICT) and 1171 (defined $r{scheme} && defined $base{scheme}) and 1172 ($r{scheme} eq $base{scheme})) 1173 { 1174 undef $r{scheme}; 1175 } 1176 1177 if (defined $r{scheme}) { 1178 $t{scheme} = $r{scheme}; 1179 $t{authority} = $r{authority}; 1180 $t{path} = _remove_dot_segments($r{path}); 1181 $t{query} = $r{query}; 1182 } 1183 else { 1184 if (defined $r{authority}) { 1185 $t{authority} = $r{authority}; 1186 $t{path} = _remove_dot_segments($r{path}); 1187 $t{query} = $r{query}; 1188 } 1189 else { 1190 if ($r{path} eq "") { 1191 $t{path} = $base{path}; 1192 if (defined $r{query}) { 1193 $t{query} = $r{query}; 1194 } 1195 else { 1196 $t{query} = $base{query}; 1197 } 1198 } 1199 else { 1200 if ($r{path} =~ m|^/|) { 1201 $t{path} = _remove_dot_segments($r{path}); 1202 } 1203 else { 1204 $t{path} = _merge_uri($base{authority}, $base{path}, $r{path}); 1205 $t{path} = _remove_dot_segments($t{path}); 1206 } 1207 $t{query} = $r{query}; 1208 } 1209 $t{authority} = $base{authority}; 1210 } 1211 $t{scheme} = $base{scheme}; 1212 } 1213 $t{fragment} = $r{fragment}; 1214 1215 # recompose URI 1216 my $result = ""; 1217 if ($t{scheme}) { 1218 $result .= $t{scheme} . ":"; 1219 } 1220 elsif (defined $t{authority}) { 1221 # this block is not part of the RFC 1222 # TODO: figure out what MUAs actually do with unschemed URIs 1223 # maybe look at URI::Heuristic 1224 if ($t{authority} =~ /^www\d*\./i) { 1225 # some spammers are using unschemed URIs to escape filters 1226 $result .= "http:"; 1227 } 1228 elsif ($t{authority} =~ /^ftp\d*\./i) { 1229 $result .= "ftp:"; 1230 } 1231 } 1232 if ($t{authority}) { 1233 $result .= "//" . $t{authority}; 1234 } 1235 $result .= $t{path}; 1236 if (defined $t{query}) { 1237 $result .= "?" . $t{query}; 1238 } 1239 if (defined $t{fragment}) { 1240 $result .= "#" . $t{fragment}; 1241 } 1242 return $result; 1243} 1244 12451; 1246__END__ 1247