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 &nbsp; 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/&nbsp;/ /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