home *** CD-ROM | disk | FTP | other *** search
/ PC Open 101 / PC Open 101 CD 1.bin / CD1 / INTERNET / EMAIL / pop file / setup.exe / Classifier / MailParse.pm < prev    next >
Encoding:
Perl POD Document  |  2004-09-30  |  87.4 KB  |  2,484 lines
  1. package Classifier::MailParse;
  2.  
  3. # ---------------------------------------------------------------------------------------------
  4. #
  5. # MailParse.pm --- Parse a mail message or messages into words
  6. #
  7. # Copyright (c) 2001-2004 John Graham-Cumming
  8. #
  9. #   This file is part of POPFile
  10. #
  11. #   POPFile is free software; you can redistribute it and/or modify
  12. #   it under the terms of the GNU General Public License as published by
  13. #   the Free Software Foundation; either version 2 of the License, or
  14. #   (at your option) any later version.
  15. #
  16. #   POPFile is distributed in the hope that it will be useful,
  17. #   but WITHOUT ANY WARRANTY; without even the implied warranty of
  18. #   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19. #   GNU General Public License for more details.
  20. #
  21. #   You should have received a copy of the GNU General Public License
  22. #   along with POPFile; if not, write to the Free Software
  23. #   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
  24. #
  25. # ---------------------------------------------------------------------------------------------
  26.  
  27. use strict;
  28. use locale;
  29.  
  30. use MIME::Base64;
  31. use MIME::QuotedPrint;
  32.  
  33. use HTML::Tagset;
  34.  
  35. # Korean characters definition
  36.  
  37. my $ksc5601_sym = '(?:[\xA1-\xAC][\xA1-\xFE])';
  38. my $ksc5601_han = '(?:[\xB0-\xC8][\xA1-\xFE])';
  39. my $ksc5601_hanja  = '(?:[\xCA-\xFD][\xA1-\xFE])';
  40. my $ksc5601 = "(?:$ksc5601_sym|$ksc5601_han|$ksc5601_hanja)";
  41.  
  42. my $eksc = "(?:$ksc5601|[\x81-\xC6][\x41-\xFE])"; #extended ksc
  43.  
  44. # These are used for Japanese support
  45.  
  46. my %encoding_candidates = (
  47.     'Nihongo' => [ 'shiftjis', 'euc-jp', '7bit-jis' ]
  48. );
  49.  
  50. my $ascii = '[\x00-\x7F]'; # ASCII chars
  51. my $two_bytes_euc_jp = '(?:[\x8E\xA1-\xFE][\xA1-\xFE])'; # 2bytes EUC-JP chars
  52. my $three_bytes_euc_jp = '(?:\x8F[\xA1-\xFE][\xA1-\xFE])'; # 3bytes EUC-JP chars
  53. my $euc_jp = "(?:$ascii|$two_bytes_euc_jp|$three_bytes_euc_jp)"; # EUC-JP chars
  54.  
  55. # Symbols in EUC-JP chars which cannot be considered a part of words
  56. my $symbol_row1_euc_jp = '(?:[\xA1][\xA1-\xBB\xBD-\xFE])';
  57. my $symbol_row2_euc_jp = '(?:[\xA2][\xA1-\xFE])';
  58. my $symbol_row8_euc_jp = '(?:[\xA8][\xA1-\xFE])';
  59. my $symbol_euc_jp = "(?:$symbol_row1_euc_jp|$symbol_row2_euc_jp|$symbol_row8_euc_jp)";
  60.  
  61. # Cho-on kigou(symbol in Japanese), a special symbol which can appear in middle of words
  62. my $cho_on_symbol = '(?:\xA1\xBC)';
  63.  
  64. # Non-symbol EUC-JP chars
  65. my $non_symbol_two_bytes_euc_jp = '(?:[\x8E\xA3-\xA7\xB0-\xFE][\xA1-\xFE])';
  66. my $non_symbol_euc_jp = "(?:$non_symbol_two_bytes_euc_jp|$three_bytes_euc_jp|$cho_on_symbol)";
  67.  
  68. # HTML entity mapping to character codes, this maps things like & to their corresponding
  69. # character code
  70.  
  71. my %entityhash = ('aacute'  => 225,     'Aacute'  => 193,     'Acirc'   => 194,     'acirc'   => 226, # PROFILE BLOCK START
  72.                   'acute'   => 180,     'AElig'   => 198,     'aelig'   => 230,     'Agrave'  => 192,
  73.                   'agrave'  => 224,     'amp'     => 38,      'Aring'   => 197,     'aring'   => 229,
  74.                   'atilde'  => 227,     'Atilde'  => 195,     'Auml'    => 196,     'auml'    => 228,
  75.                   'brvbar'  => 166,     'ccedil'  => 231,     'Ccedil'  => 199,     'cedil'   => 184,
  76.                   'cent'    => 162,     'copy'    => 169,     'curren'  => 164,     'deg'     => 176,
  77.                   'divide'  => 247,     'Eacute'  => 201,     'eacute'  => 233,     'ecirc'   => 234,
  78.                   'Ecirc'   => 202,     'Egrave'  => 200,     'egrave'  => 232,     'ETH'     => 208,
  79.                   'eth'     => 240,     'Euml'    => 203,     'euml'    => 235,     'frac12'  => 189,
  80.                   'frac14'  => 188,     'frac34'  => 190,     'iacute'  => 237,     'Iacute'  => 205,
  81.                   'icirc'   => 238,     'Icirc'   => 206,     'iexcl'   => 161,     'igrave'  => 236,
  82.                   'Igrave'  => 204,     'iquest'  => 191,     'iuml'    => 239,     'Iuml'    => 207,
  83.                   'laquo'   => 171,     'macr'    => 175,     'micro'   => 181,     'middot'  => 183,
  84.                   'nbsp'    => 160,     'not'     => 172,     'ntilde'  => 241,     'Ntilde'  => 209,
  85.                   'oacute'  => 243,     'Oacute'  => 211,     'Ocirc'   => 212,     'ocirc'   => 244,
  86.                   'Ograve'  => 210,     'ograve'  => 242,     'ordf'    => 170,     'ordm'    => 186,
  87.                   'oslash'  => 248,     'Oslash'  => 216,     'Otilde'  => 213,     'otilde'  => 245,
  88.                   'Ouml'    => 214,     'ouml'    => 246,     'para'    => 182,     'plusmn'  => 177,
  89.                   'pound'   => 163,     'raquo'   => 187,     'reg'     => 174,     'sect'    => 167,
  90.                   'shy'     => 173,     'sup1'    => 185,     'sup2'    => 178,     'sup3'    => 179,
  91.                   'szlig'   => 223,     'thorn'   => 254,     'THORN'   => 222,     'times'   => 215,
  92.                   'Uacute'  => 218,     'uacute'  => 250,     'ucirc'   => 251,     'Ucirc'   => 219,
  93.                   'ugrave'  => 249,     'Ugrave'  => 217,     'uml'     => 168,     'Uuml'    => 220,
  94.                   'uuml'    => 252,     'Yacute'  => 221,     'yacute'  => 253,     'yen'     => 165,
  95.                   'yuml'    => 255 ); # PROFILE BLOCK STOP
  96.  
  97. # All known HTML tags divided into two groups: tags that generate
  98. # whitespace as in 'foo<br></br>bar' and tags that don't such as
  99. # 'foo<b></b>bar'.  The first case shouldn't count as an empty pair
  100. # because it breaks the line.  The second case doesn't have any visual
  101. # impact and it treated as 'foobar' with an empty pair.
  102.  
  103. my $spacing_tags = "address|applet|area|base|basefont" . # PROFILE BLOCK START
  104.     "|bdo|bgsound|blockquote|body|br|button|caption" .
  105.     "|center|col|colgroup|dd|dir|div|dl|dt|embed" .
  106.     "|fieldset|form|frame|frameset|h1|h2|h3|h4|h5|h6" .
  107.     "|head|hr|html|iframe|ilayer|input|isindex|label" .
  108.     "|legend|li|link|listing|map|menu|meta|multicol" .
  109.     "|nobr|noembed|noframes|nolayer|noscript|object" .
  110.     "|ol|optgroup|option|p|param|plaintext|pre|script" .
  111.     "|select|spacer|style|table|tbody|td|textarea" .
  112.     "|tfoot|th|thead|title|tr|ul|wbr|xmp"; # PROFILE BLOCK STOP
  113.  
  114. my $non_spacing_tags = "a|abbr|acronym|b|big|blink" . # PROFILE BLOCK START
  115.     "|cite|code|del|dfn|em|font|i|img|ins|kbd|q|s" .
  116.     "|samp|small|span|strike|strong|sub|sup|tt|u|var"; # PROFILE BLOCK STOP
  117.  
  118. my $eol = "\015\012";
  119.  
  120. #----------------------------------------------------------------------------
  121. # new
  122. #
  123. # Class new() function
  124. #----------------------------------------------------------------------------
  125. sub new
  126. {
  127.     my $type = shift;
  128.     my $self;
  129.  
  130.     # Hash of word frequences
  131.  
  132.     $self->{words__}  = {};
  133.  
  134.     # Total word cout
  135.  
  136.     $self->{msg_total__} = 0;
  137.  
  138.     # Internal use for keeping track of a line without touching it
  139.  
  140.     $self->{ut__}        = '';
  141.  
  142.     # Specifies the parse mode, '' means no color output, if non-zero
  143.     # then color output using a specific session key stored here
  144.  
  145.     $self->{color__}        = '';
  146.     $self->{color_matrix__} = undef;
  147.     $self->{color_idmap__}  = undef;
  148.     $self->{color_userid__} = undef;
  149.  
  150.     # This will store the from, to, cc and subject from the last parse
  151.     $self->{from__}      = '';
  152.     $self->{to__}        = '';
  153.     $self->{cc__}        = '';
  154.     $self->{subject__}   = '';
  155.  
  156.     # This is used to store the words found in the from, to, and subject
  157.     # lines for use in creating new magnets, it is a list of pairs mapping
  158.     # a magnet type to a magnet string, e.g. from => popfile@jgc.org
  159.  
  160.     $self->{quickmagnets__}      = {};
  161.  
  162.     # store the tag that set the foreground/background color so the
  163.     # color can be unset when the tag closes
  164.  
  165.     $self->{cssfontcolortag__} = '';
  166.     $self->{cssbackcolortag__} = '';
  167.  
  168.     # This is the distance betwee the back color and the font color
  169.     # as computed using compute_rgb_distance
  170.  
  171.     $self->{htmlcolordistance__} = 0;
  172.  
  173.     # This is a mapping between HTML color names and HTML hexadecimal
  174.     # color values used by the map_color value to get canonical color
  175.     # values
  176.  
  177.     $self->{color_map__} = { 'aliceblue','f0f8ff', 'antiquewhite','faebd7', 'aqua','00ffff', 'aquamarine','7fffd4', 'azure','f0ffff', # PROFILE BLOCK START
  178.         'beige','f5f5dc', 'bisque','ffe4c4', 'black','000000', 'blanchedalmond','ffebcd', 'blue','0000ff', 'blueviolet','8a2be2',
  179.         'brown','a52a2a', 'burlywood','deb887', 'cadetblue','5f9ea0', 'chartreuse','7fff00', 'chocolate','d2691e', 'coral','ff7f50',
  180.         'cornflowerblue','6495ed', 'cornsilk','fff8dc', 'crimson','dc143c', 'cyan','00ffff', 'darkblue','00008b', 'darkcyan','008b8b',
  181.         'darkgoldenrod','b8860b', 'darkgray','a9a9a9', 'darkgreen','006400', 'darkkhaki','bdb76b', 'darkmagenta','8b008b', 'darkolivegreen','556b2f',
  182.         'darkorange','ff8c00', 'darkorchid','9932cc', 'darkred','8b0000', 'darksalmon','e9967a', 'darkseagreen','8fbc8f', 'darkslateblue','483d8b',
  183.         'darkturquoise','00ced1', 'darkviolet','9400d3', 'deeppink','ff1493', 'deepskyblue','00bfff', 'deepskyblue','2f4f4f', 'dimgray','696969',
  184.         'dodgerblue','1e90ff', 'firebrick','b22222', 'floralwhite','fffaf0', 'forestgreen','228b22', 'fuchsia','ff00ff', 'gainsboro','dcdcdc',
  185.         'ghostwhite','f8f8ff', 'gold','ffd700', 'goldenrod','daa520', 'gray','808080', 'green','008000', 'greenyellow','adff2f',
  186.         'honeydew','f0fff0', 'hotpink','ff69b4', 'indianred','cd5c5c', 'indigo','4b0082', 'ivory','fffff0', 'khaki','f0e68c',
  187.         'lavender','e6e6fa', 'lavenderblush','fff0f5', 'lawngreen','7cfc00', 'lemonchiffon','fffacd', 'lightblue','add8e6',
  188.         'lightcoral','f08080', 'lightcyan','e0ffff', 'lightgoldenrodyellow','fafad2', 'lightgreen','90ee90', 'lightgrey','d3d3d3',
  189.         'lightpink','ffb6c1', 'lightsalmon','ffa07a', 'lightseagreen','20b2aa', 'lightskyblue','87cefa', 'lightslategray','778899',
  190.         'lightsteelblue','b0c4de', 'lightyellow','ffffe0', 'lime','00ff00', 'limegreen','32cd32', 'linen','faf0e6', 'magenta','ff00ff',
  191.         'maroon','800000', 'mediumaquamarine','66cdaa', 'mediumblue','0000cd', 'mediumorchid','ba55d3', 'mediumpurple','9370db',
  192.         'mediumseagreen','3cb371', 'mediumslateblue','7b68ee', 'mediumspringgreen','00fa9a', 'mediumturquoise','48d1cc',
  193.         'mediumvioletred','c71585', 'midnightblue','191970', 'mintcream','f5fffa', 'mistyrose','ffe4e1', 'moccasin','ffe4b5',
  194.         'navajowhite','ffdead', 'navy','000080', 'oldlace','fdf5e6', 'olive','808000', 'olivedrab','6b8e23', 'orange','ffa500',
  195.         'orangered','ff4500', 'orchid','da70d6', 'palegoldenrod','eee8aa', 'palegreen','98fb98', 'paleturquoise','afeeee',
  196.         'palevioletred','db7093', 'papayawhip','ffefd5', 'peachpuff','ffdab9', 'peru','cd853f', 'pink','ffc0cb', 'plum','dda0dd',
  197.         'powderblue','b0e0e6', 'purple','800080', 'red','ff0000', 'rosybrown','bc8f8f', 'royalblue','4169e1', 'saddlebrown','8b4513',
  198.         'salmon','fa8072', 'sandybrown','f4a460', 'seagreen','2e8b57', 'seashell','fff5ee', 'sienna','a0522d', 'silver','c0c0c0',
  199.         'skyblue','87ceeb', 'slateblue','6a5acd', 'slategray','708090', 'snow','fffafa', 'springgreen','00ff7f', 'steelblue','4682b4',
  200.         'tan','d2b48c', 'teal','008080', 'thistle','d8bfd8', 'tomato','ff6347', 'turquoise','40e0d0', 'violet','ee82ee', 'wheat','f5deb3',
  201.         'white','ffffff', 'whitesmoke','f5f5f5', 'yellow','ffff00', 'yellowgreen','9acd32' }; # PROFILE BLOCK STOP
  202.  
  203.     # These store the current HTML background color and font color to
  204.     # detect "invisible ink" used by spammers
  205.  
  206.     my $result = bless $self, $type;
  207.  
  208.     $self->{htmlbackcolor__} = $self->map_color( 'white' );
  209.     $self->{htmlbodycolor__} = $self->map_color( 'white' );
  210.     $self->{htmlfontcolor__} = $self->map_color( 'black' );
  211.  
  212.     $self->{content_type__} = '';
  213.     $self->{base64__}       = '';
  214.     $self->{in_html_tag__}  = 0;
  215.     $self->{html_tag__}     = '';
  216.     $self->{html_arg__}     = '';
  217.     $self->{in_headers__}   = 0;
  218.  
  219.     # This is used for switching on/off language specific functionality
  220.  
  221.     $self->{lang__} = '';
  222.     $self->{first20__}      = '';
  223.  
  224.     # For support Quoted Printable in Japanese text, save encoded text in multiple lines
  225.     $self->{prev__} = '';
  226.  
  227.     return $result;
  228. }
  229.  
  230. # ---------------------------------------------------------------------------------------------
  231. #
  232. # get_color__
  233. #
  234. # Gets the color for the passed in word
  235. #
  236. # $word          The word to check
  237. #
  238. # ---------------------------------------------------------------------------------------------
  239. sub get_color__
  240. {
  241.     my ( $self, $word ) = @_;
  242.  
  243.     if ( !defined( $self->{color_matrix__} ) ) {
  244.         return $self->{bayes__}->get_color( $self->{color__}, $word );
  245.     } else {
  246.         my $id;
  247.  
  248.         for my $i (keys %{$self->{color_idmap__}}) {
  249.             if ( $word eq $self->{color_idmap__}{$i} ) {
  250.                 $id = $i;
  251.                 last;
  252.             }
  253.         }
  254.  
  255.         if ( defined( $id ) ) {
  256.             my @buckets = $self->{bayes__}->get_buckets( $self->{color__} );
  257.  
  258.             return $self->{bayes__}->get_bucket_color( $self->{color__},
  259.                 $self->{bayes__}->get_top_bucket__(
  260.                     $self->{color_userid__},
  261.                     $id,
  262.                     $self->{color_matrix__},
  263.                     \@buckets ) );
  264.         } else {
  265.             return 'black';
  266.         }
  267.     }
  268. }
  269.  
  270. # ---------------------------------------------------------------------------------------------
  271. #
  272. # compute_rgb_distance
  273. #
  274. # Given two RGB colors compute the distance between them by considering them as points
  275. # in 3 dimensions and calculating the distance between them (or equivalently the length
  276. # of a vector between them)
  277. #
  278. # $left          One color
  279. # $right         The other color
  280. #
  281. # ---------------------------------------------------------------------------------------------
  282. sub compute_rgb_distance
  283. {
  284.     my ( $self, $left, $right ) = @_;
  285.  
  286.     # TODO: store front/back colors in a RGB hash/array
  287.     #       converting to a hh hh hh format and back
  288.     #       is a waste as is repeatedly decoding
  289.     #       from hh hh hh format
  290.  
  291.     # Figure out where the left color is and then subtract the right
  292.     # color (point from it) to get the vector
  293.  
  294.     $left =~ /^(..)(..)(..)$/;
  295.     my ( $rl, $gl, $bl ) = ( hex($1), hex($2), hex($3) );
  296.  
  297.     $right =~ /^(..)(..)(..)$/;
  298.     my ( $r, $g, $b ) = ( $rl - hex($1), $gl - hex($2), $bl - hex($3) );
  299.  
  300.     # Now apply Pythagoras in 3D to get the distance between them, we return
  301.     # the int because we don't need decimal level accuracy
  302.  
  303.     print "rgb distance: $left -> $right = " . int( sqrt( $r*$r + $g*$g + $b*$b ) ) . "\n" if $self->{debug__};
  304.  
  305.     return int( sqrt( $r*$r + $g*$g + $b*$b ) );
  306. }
  307.  
  308. # ---------------------------------------------------------------------------------------------
  309. #
  310. # compute_html_color_distance
  311. #
  312. # Calls compute_rgb_distance to set up htmlcolordistance__ from the current HTML back and
  313. # font colors
  314. #
  315. # ---------------------------------------------------------------------------------------------
  316. sub compute_html_color_distance
  317. {
  318.     my ( $self ) = @_;
  319.  
  320.     # TODO: store front/back colors in a RGB hash/array
  321.     #       converting to a hh hh hh format and back
  322.     #       is a waste as is repeatedly decoding
  323.     #       from hh hh hh format
  324.  
  325.     $self->{htmlcolordistance__} = $self->compute_rgb_distance( $self->{htmlfontcolor__}, $self->{htmlbackcolor__} );
  326. }
  327.  
  328. # ---------------------------------------------------------------------------------------------
  329. #
  330. # map_color
  331. #
  332. # Convert an HTML color value into its canonical lower case hexadecimal form with no #
  333. #
  334. # $color        A color value found in a tag
  335. #
  336. # ---------------------------------------------------------------------------------------------
  337. sub map_color
  338. {
  339.     my ( $self, $color ) = @_;
  340.  
  341.     # The canonical form is lowercase hexadecimal, so start by
  342.     # lowercasing and stripping any initial #
  343.  
  344.     $color = lc( $color );
  345.  
  346.     # Map color names to hexadecimal values
  347.  
  348.     if ( defined( $self->{color_map__}{$color} ) ) {
  349.         return $self->{color_map__}{$color};
  350.     } else {
  351.  
  352.         # Do this after checking the color map, as there is no "#blue" color
  353.         # TODO: The #, however, is optional in IE.. Do we pseudo-word this?
  354.  
  355.         $color =~ s/^#//;
  356.  
  357.         my $old_color = $color;
  358.  
  359.         # Due to a bug/feature in Microsoft Internet Explorer it's
  360.         # possible to use invalid hexadecimal colors where the number
  361.         # 0 is replaced by any other character and if the hex has an
  362.         # uneven multiple of 3 number of characters it is padded on
  363.         # the right with 0s and if the hex is too long, it is divided
  364.         # into even triplets with the leftmost characters in the
  365.         # triplets being significant. Short (1-char) triplets are
  366.         # left-padded with 0's
  367.  
  368.         my $quotient = ((length($color) - (length($color) % 3)) / 3 );
  369.  
  370.         # We go one higher than the quotient if the length isn't an
  371.         # even multiple of 3
  372.  
  373.         $quotient += 1 if (length($color) % 3);
  374.  
  375.         # right-pad entire value to get past the next
  376.         # full multiple of the quotient ("abc abc abc"
  377.         # needs at least one more character to make
  378.         # three even triplets)
  379.  
  380.         $color .= "00" . "0" x $quotient;
  381.  
  382.         # even length RGB triplets
  383.         my ($r, $g, $b) = ($color =~ /(.{$quotient})(.{$quotient})(.{$quotient})/);
  384.  
  385.         print "$r $g $b\n" if $self->{debug_};
  386.  
  387.         # left-trim very long triplets to 4 bytes
  388.         $r =~ s/.*(.{8})$/$1/;
  389.         $g =~ s/.*(.{8})$/$1/;
  390.         $b =~ s/.*(.{8})$/$1/;
  391.  
  392.         # right-trim long triplets to get the first two bytes
  393.         $r =~ s/(..).*/$1/;
  394.         $g =~ s/(..).*/$1/;
  395.         $b =~ s/(..).*/$1/;
  396.  
  397.         # left-pad short triplets (eg FFF -> 0F0F0F)
  398.         $r = '0' . $r if (length($r) == 1);
  399.         $g = '0' . $g if (length($g) == 1);
  400.         $b = '0' . $b if (length($b) == 1);
  401.  
  402.         $color = "$r$g$b"; # here is our real color value
  403.  
  404.         # Any non-hex values remaining get 0'd out
  405.         $color =~ s/[^0-9a-f]/0/g;
  406.  
  407.         print "hex color $color\n" if ($self->{debug__});
  408.         print "flex-hex detected\n" if ($self->{debug__} && ($color ne $old_color));
  409.  
  410.         # Add pseudo-word anytime flex hex detected
  411.  
  412.         if ( $color ne $old_color ) {
  413.             $self->update_pseudoword( 'trick:flexhex', $old_color, 0, '' );
  414.         }
  415.  
  416.         return $color;
  417.     }
  418. }
  419.  
  420. # ---------------------------------------------------------------------------------------------
  421. #
  422. # increment_word
  423. #
  424. # Updates the word frequency for a word without performing any coloring or transformation
  425. # on the word
  426. #
  427. # $word     The word
  428. #
  429. # ---------------------------------------------------------------------------------------------
  430. sub increment_word
  431. {
  432.     my ($self, $word) = @_;
  433.  
  434.     $self->{words__}{$word} += 1;
  435.     $self->{msg_total__}    += 1;
  436.  
  437.     print "--- $word ($self->{words__}{$word})\n" if ($self->{debug__});
  438. }
  439.  
  440. # ---------------------------------------------------------------------------------------------
  441. #
  442. # update_pseudoword
  443. #
  444. # Updates the word frequency for a pseudoword, note that this differs from update_word
  445. # because it does no word mangling
  446. #
  447. # $prefix       The pseudoword prefix (e.g. header)
  448. # $word         The pseudoword (e.g. Mime-Version)
  449. # $encoded      Whether this was found inside encoded text
  450. # $literal      The literal text that generated this pseudoword
  451. #
  452. # Returns 0 if the pseudoword was filtered out by a stopword
  453. #
  454. # ---------------------------------------------------------------------------------------------
  455. sub update_pseudoword
  456. {
  457.     my ( $self, $prefix, $word, $encoded, $literal ) = @_;
  458.  
  459.     my $mword = $self->{mangle__}->mangle("$prefix:$word",1);
  460.  
  461.     if ( $mword ne '' ) {
  462.         if ( $self->{color__} ne '' ) {
  463.             if ( $encoded == 1 )  {
  464.                 $literal =~ s/</</g;
  465.                 $literal =~ s/>/>/g;
  466.                 my $color = $self->get_color__($mword);
  467.                 my $to    = "<b><font color=\"$color\"><a title=\"$mword\">$literal</a></font></b>";
  468.                 $self->{ut__} .= $to . ' ';
  469.             }
  470.         }
  471.  
  472.         $self->increment_word( $mword );
  473.         return 1;
  474.     }
  475.  
  476.     return 0;
  477. }
  478.  
  479. # ---------------------------------------------------------------------------------------------
  480. #
  481. # update_word
  482. #
  483. # Updates the word frequency for a word
  484. #
  485. # $word         The word that is being updated
  486. # $encoded      1 if the line was found in encoded text (base64)
  487. # $before       The character that appeared before the word in the original line
  488. # $after        The character that appeared after the word in the original line
  489. # $prefix       A string to prefix any words with in the corpus, used for the special
  490. #               identification of values found in for example the subject line
  491. #
  492. # ---------------------------------------------------------------------------------------------
  493. sub update_word
  494. {
  495.     my ($self, $word, $encoded, $before, $after, $prefix) = @_;
  496.  
  497.     my $mword = $self->{mangle__}->mangle($word);
  498.  
  499.     if ( $mword ne '' )  {
  500.         $mword = $prefix . ':' . $mword if ( $prefix ne '' );
  501.  
  502.         if ( $prefix =~ /(from|to|cc|subject)/i ) {
  503.             push @{$self->{quickmagnets__}{$prefix}}, $word;
  504.         }
  505.  
  506.         if ( $self->{color__} ne '' ) {
  507.             my $color = $self->get_color__($mword);
  508.             if ( $encoded == 0 )  {
  509.                 $after = '&' if ( $after eq '>' );
  510.                 if ( !( $self->{ut__} =~ s/($before)\Q$word\E($after)/$1<b><font color=\"$color\">$word<\/font><\/b>$2/ ) ) {
  511.                     print "Could not find $word for colorization\n" if ( $self->{debug__} );
  512.                 }
  513.             } else {
  514.                 $self->{ut__} .= "<font color=\"$color\">$word<\/font> ";
  515.             }
  516.         }
  517.  
  518.         $self->increment_word( $mword );
  519.     }
  520. }
  521.  
  522. # ---------------------------------------------------------------------------------------------
  523. #
  524. # add_line
  525. #
  526. # Parses a single line of text and updates the word frequencies
  527. #
  528. # $bigline      The line to split into words and add to the word counts
  529. # $encoded      1 if the line was found in encoded text (base64)
  530. # $prefix       A string to prefix any words with in the corpus, used for the special
  531. #               identification of values found in for example the subject line
  532. #
  533. # ---------------------------------------------------------------------------------------------
  534. sub add_line
  535. {
  536.     my ($self, $bigline, $encoded, $prefix) = @_;
  537.     my $p = 0;
  538.  
  539.     print "add_line: [$bigline]\n" if $self->{debug__};
  540.  
  541.     # If the line is really long then split at every 1k and feed it to the parser below
  542.  
  543.     # Check the HTML back and font colors to ensure that we are not about to
  544.     # add words that are hidden inside invisible ink
  545.  
  546.     if ( $self->{htmlfontcolor__} ne $self->{htmlbackcolor__} ) {
  547.  
  548.         # If we are adding a line and the colors are different then we will
  549.         # add a count for the color difference to make sure that we catch
  550.         # camouflage attacks using similar colors, if the color similarity
  551.         # is less than 100.  I chose 100 somewhat arbitrarily but classic
  552.         # black text on white background has a distance of 441, red/blue or
  553.         # green on white has distance 255.  100 seems like a reasonable upper
  554.         # bound for tracking evil spammer tricks with similar colors
  555.  
  556.         if ( $self->{htmlcolordistance__} < 100 ) {
  557.             $self->update_pseudoword( 'html', "colordistance$self->{htmlcolordistance__}", $encoded, '' );
  558.         }
  559.  
  560.         while ( $p < length($bigline) ) {
  561.             my $line = substr($bigline, $p, 1024);
  562.  
  563.             # mangle up html character entities
  564.             # these are just the low ISO-Latin1 entities
  565.             # see: http://www.w3.org/TR/REC-html32#latin1
  566.             # TODO: find a way to make this (and other similar stuff) highlight
  567.             #       without using the encoded content printer or modifying $self->{ut__}
  568.  
  569.             while ( $line =~ m/(&(\w{3,6});)/g ) {
  570.                 my $from = $1;
  571.                 my $to   = $entityhash{$2};
  572.  
  573.                 if ( defined( $to ) ) {
  574.  
  575.                     # HTML entities confilict with DBCS chars. Replace entities with blanks.
  576.  
  577.                     if ( $self->{lang__} eq 'Korean' ) {
  578.                             $to = ' ';
  579.                     } else {
  580.                         $to = chr($to);
  581.                     }
  582.                     $line       =~ s/$from/$to/g;
  583.                     $self->{ut__} =~ s/$from/$to/g;
  584.                     print "$from -> $to\n" if $self->{debug__};
  585.                 }
  586.             }
  587.  
  588.             while ( $line =~ m/(&#([\d]{1,3});)/g ) {
  589.  
  590.                 # Don't decode odd (nonprintable) characters or < >'s.
  591.  
  592.                 if ( ( ( $2 < 255 ) && ( $2 > 63 ) ) || ( $2 == 61 ) || ( ( $2 < 60 ) && ( $2 > 31 ) ) ) {
  593.                     my $from = $1;
  594.                     my $to   = chr($2);
  595.  
  596.                     if ( defined( $to ) &&  ( $to ne '' ) ) {
  597.                         $line       =~ s/$from/$to/g;
  598.                         $self->{ut__} =~ s/$from/$to/g;
  599.                         print "$from -> $to\n" if $self->{debug__};
  600.                         $self->update_pseudoword( 'html', 'numericentity', $encoded, $from );
  601.                     }
  602.                 }
  603.             }
  604.  
  605.             # Pull out any email addresses in the line that are marked with <> and have an @ in them
  606.  
  607.             while ( $line =~ s/(mailto:)?([[:alpha:]0-9\-_\.]+?@([[:alpha:]0-9\-_\.]+\.[[:alpha:]0-9\-_]+))([\"\&\)\?\:\/ >\&\;])// )  {
  608.                 update_word($self, $2, $encoded, ($1?$1:''), '[\&\?\:\/ >\&\;]', $prefix);
  609.                 add_url($self, $3, $encoded, '\@', '[\&\?\:\/]', $prefix);
  610.             }
  611.  
  612.             # Grab domain names
  613.             while ( $line =~ s/(([[:alpha:]0-9\-_]+\.)+)(com|edu|gov|int|mil|net|org|aero|biz|coop|info|museum|name|pro)([^[:alpha:]0-9\-_\.]|$)/$4/i )  {
  614.                  add_url($self, "$1$3", $encoded, '', '', $prefix);
  615.             }
  616.  
  617.             # Grab IP addresses
  618.  
  619.             while ( $line =~ s/(([12]?\d{1,2}\.){3}[12]?\d{1,2})// )  {
  620.                 update_word($self, "$1", $encoded, '', '', $prefix);
  621.             }
  622.  
  623.             # Deal with runs of alternating spaces and letters
  624.  
  625.             foreach my $space (' ', '\'', '*', '^', '`', '  ', '\38', '.' ){
  626.                 while ( $line =~ s/( |^)(([A-Z]\Q$space\E){2,15}[A-Z])( |\Q$space\E|[!\?,])/ /i ) {
  627.                     my $original = "$1$2$4";
  628.                     my $word = $2;
  629.                     print "$word ->" if $self->{debug__};
  630.                     $word    =~ s/[^A-Z]//gi;
  631.                     print "$word\n" if $self->{debug__};
  632.                     $self->update_word( $word, $encoded, ' ', ' ', $prefix);
  633.                     $self->update_pseudoword( 'trick', 'spacedout', $encoded, $original );
  634.                 }
  635.             }
  636.  
  637.             # Deal with random insertion of . inside words
  638.  
  639.             while ( $line =~ s/ ([A-Z]+)\.([A-Z]{2,}) / $1$2 /i ) {
  640.                 $self->update_pseudoword( 'trick', 'dottedwords', $encoded, "$1$2" );
  641.             }
  642.  
  643.             if ( $self->{lang__} eq 'Nihongo' ) {
  644.                 # In Japanese mode, non-symbol EUC-JP characters should be
  645.                 # matched.
  646.                 #
  647.                 # ^$euc_jp*? is added to avoid incorrect matching.
  648.                 # For example, EUC-JP char represented by code A4C8, should not
  649.                 # match the middle of two EUC-JP chars represented by CCA4 and
  650.                 # C8BE, the second byte of the first char and the first byte of
  651.                 # the second char.
  652.  
  653.                 while ( $line =~ s/^$euc_jp*?(([A-Za-z]|$non_symbol_euc_jp)([A-Za-z\']|$non_symbol_euc_jp){1,44})([_\-,\.\"\'\)\?!:;\/& \t\n\r]{0,5}|$)//ox ) {
  654.                     if ( ( $self->{in_headers__} == 0 ) && ( $self->{first20count__} < 20 ) ) {
  655.                         $self->{first20count__} += 1;
  656.                         $self->{first20__} .= " $1";
  657.                     }
  658.  
  659.                     my $matched_word = $1;
  660.  
  661.                     # In Japanese, 2 characters words are common, so care about
  662.                     # words between 2 and 45 characters
  663.  
  664.                     if (((length $matched_word >= 3) && ($matched_word =~ /[A-Za-z]/)) || ((length $matched_word >= 2) && ($matched_word =~ /$non_symbol_euc_jp/))) {
  665.                         update_word($self, $matched_word, $encoded, '', '[_\-,\.\"\'\)\?!:;\/ &\t\n\r]'."|$symbol_euc_jp", $prefix);
  666.                     }
  667.                 }
  668.             } else {
  669.                 if ( $self->{lang__} eq 'Korean' ) {
  670.  
  671.                     # In Korean mode, [[:alpha:]] in regular expression is changed to 2bytes chars
  672.                     # to support 2 byte characters.
  673.                     #
  674.                     # In Korean, care about words between 2 and 45 characters.
  675.  
  676.                     while ( $line =~ s/(([A-Za-z]|$eksc)([A-Za-z\']|$eksc){1,44})([_\-,\.\"\'\)\?!:;\/& \t\n\r]{0,5}|$)// ) {
  677.                         if ( ( $self->{in_headers__} == 0 ) && ( $self->{first20count__} < 20 ) ) {
  678.                             $self->{first20count__} += 1;
  679.                             $self->{first20__} .= " $1";
  680.                         }
  681.  
  682.                         update_word($self,$1, $encoded, '', '[_\-,\.\"\'\)\?!:;\/ &\t\n\r]', $prefix) if (length $1 >= 2);
  683.                     }
  684.                 } else {
  685.  
  686.                     # Only care about words between 3 and 45 characters since short words like
  687.                     # an, or, if are too common and the longest word in English (according to
  688.                     # the OED) is pneumonoultramicroscopicsilicovolcanoconiosis
  689.  
  690.                     while ( $line =~ s/([[:alpha:]][[:alpha:]\']{1,44})([_\-,\.\"\'\)\?!:;\/& \t\n\r]{0,5}|$)// ) {
  691.                         if ( ( $self->{in_headers__} == 0 ) && ( $self->{first20count__} < 20 ) ) {
  692.                             $self->{first20count__} += 1;
  693.                             $self->{first20__} .= " $1";
  694.                         }
  695.  
  696.                        update_word($self,$1, $encoded, '', '[_\-,\.\"\'\)\?!:;\/ &\t\n\r]', $prefix) if (length $1 >= 3);
  697.                     }
  698.                 }
  699.             }
  700.  
  701.             $p += 1024;
  702.         }
  703.     } else {
  704.         if ( $bigline =~ /[^ \t]/ ) {
  705.             $self->update_pseudoword( 'trick', 'invisibleink', $encoded, $bigline );
  706.         }
  707.     }
  708. }
  709.  
  710. # ---------------------------------------------------------------------------------------------
  711. #
  712. # update_tag
  713. #
  714. # Extract elements from within HTML tags that are considered important 'words' for analysis
  715. # such as domain names, alt tags,
  716. #
  717. # $tag      The tag name
  718. # $arg      The arguments
  719. # $end_tag  Whether this is an end tag or not
  720. # $encoded  1 if this HTML was found inside encoded (base64) text
  721. #
  722. # ---------------------------------------------------------------------------------------------
  723. sub update_tag
  724. {
  725.     my ( $self, $tag, $arg, $end_tag, $encoded ) = @_;
  726.  
  727.     # TODO: Make sure $tag only ever gets alphanumeric input (in some cases it
  728.     #       has been demonstrated that things like ()| etc can end up in $tag
  729.  
  730.     $tag =~ s/[\r\n]//g;
  731.     $arg =~ s/[\r\n]//g;
  732.  
  733.     print "HTML " . ($end_tag?"closing":'') . " tag $tag with argument " . $arg . "\n" if ($self->{debug__});
  734.  
  735.     # End tags do not require any argument decoding but we do look at them
  736.     # to make sure that we handle /font to change the font color
  737.  
  738.     if ( $end_tag ) {
  739.         if ( $tag =~ /^font$/i ) {
  740.             $self->{htmlfontcolor__} = map_color( $self, 'black' );
  741.             $self->compute_html_color_distance();
  742.         }
  743.  
  744.         # If we hit a table tag then any font information is lost
  745.  
  746.         if ( $tag =~ /^(table|td|tr|th)$/i ) {
  747.             $self->{htmlfontcolor__} = map_color( $self, 'black' );
  748.             $self->{htmlbackcolor__} = $self->{htmlbodycolor__};
  749.             $self->compute_html_color_distance();
  750.         }
  751.  
  752.         if ( lc( $tag ) eq $self->{cssbackcolortag__} ) {
  753.             $self->{htmlbackcolor__} = $self->{htmlbodycolor__};
  754.             $self->{cssbackcolortag__} = '';
  755.  
  756.             $self->compute_html_color_distance();
  757.  
  758.             print "CSS back color reset to $self->{htmlbackcolor__} (tag closed: $tag)\n" if ( $self->{debug__} );
  759.         }
  760.  
  761.         if ( lc( $tag ) eq $self->{cssfontcolortag__} ) {
  762.             $self->{htmlfontcolor__} = map_color( $self, 'black' );
  763.             $self->{cssfontcolortag__} = '';
  764.  
  765.             $self->compute_html_color_distance();
  766.  
  767.             print "CSS font color reset to $self->{htmlfontcolor__} (tag closed: $tag)\n" if ( $self->{debug__} );
  768.         }
  769.  
  770.         return;
  771.     }
  772.  
  773.     # Count the number of TD elements
  774.     $self->update_pseudoword('html', 'td', $encoded, $tag ) if ( $tag =~ /^td$/i );
  775.  
  776.     my $attribute;
  777.     my $value;
  778.  
  779.     # These are used to pass good values to update_word
  780.  
  781.     my $quote;
  782.     my $end_quote;
  783.  
  784.     # Strip the first attribute while there are any attributes
  785.     # Match the closing attribute character, if there is none
  786.     # (this allows nested single/double quotes),
  787.     # match a space or > or EOL
  788.  
  789.     my $original;
  790.  
  791.     while ( $arg =~ s/[ \t]*((\w+)[ \t]*=[ \t]*(([\"\'])(.*?)\4|([^ \t>]+)($|([ \t>]))))// ) {
  792.         $original  = $1;
  793.         $attribute = $2;
  794.         $value     = $5 || $6;
  795.         $quote     = '';
  796.         $end_quote = '[\> \t\&\n]';
  797.         if (defined $4) {
  798.             $quote     = $4;
  799.             $end_quote = $4;
  800.         }
  801.  
  802.         print "   attribute $attribute with value $quote$value$quote\n" if ($self->{debug__});
  803.  
  804.         # Remove leading whitespace and leading value-less attributes
  805.  
  806.         if ( $arg =~ s/^(([ \t]*(\w+)[\t ]+)+)([^=])/$4/ ) {
  807.             print "   attribute(s) " . $1 . " with no value\n" if ($self->{debug__});
  808.         }
  809.  
  810.         # Toggle for parsing script URI's.
  811.         # Should be left off (0) until more is known about how different html
  812.         # rendering clients behave.
  813.  
  814.         my $parse_script_uri = 0;
  815.  
  816.         # Tags with src attributes
  817.  
  818.         if ( ( $attribute =~ /^src$/i ) && # PROFILE BLOCK START
  819.              ( ( $tag =~ /^img|frame|iframe$/i )
  820.                || ( $tag =~ /^script$/i && $parse_script_uri ) ) ) { # PROFILE BLOCK STOP
  821.  
  822.             # "CID:" links refer to an origin-controlled attachment to a html email.
  823.             # Adding strings from these, even if they appear to be hostnames, may or
  824.             # may not be beneficial
  825.  
  826.             if ($value =~ /^(cid)\:/i ) {
  827.  
  828.                 # Add a pseudo-word when CID source links are detected
  829.  
  830.                 $self->update_pseudoword( 'html', 'cidsrc' );
  831.  
  832.                 # TODO: I've seen virus messages try to use a CID: href
  833.  
  834.  
  835.             } else {
  836.  
  837.                 my $host = add_url( $self, $value, $encoded, $quote, $end_quote, '' );
  838.  
  839.                 # If the host name is not blank (i.e. there was a hostname in the url
  840.                 # and it was an image, then if the host was not this host then report
  841.                 # an off machine image
  842.  
  843.                 if ( ( $host ne '' ) && ( $tag =~ /^img$/i ) ) {
  844.                     if ( $host ne 'localhost' ) {
  845.                         $self->update_pseudoword( 'html', 'imgremotesrc', $encoded, $original );
  846.                     }
  847.                 }
  848.  
  849.                 if ( ( $host ne '' ) && ( $tag =~ /^iframe$/i ) ) {
  850.                     if ( $host ne 'localhost' ) {
  851.                         $self->update_pseudoword( 'html', 'iframeremotesrc', $encoded, $original );
  852.                     }
  853.                 }
  854.             }
  855.  
  856.             next;
  857.         }
  858.  
  859.         # Tags with href attributes
  860.  
  861.         if ( $attribute =~ /^href$/i && $tag =~ /^(a|link|base|area)$/i )  {
  862.  
  863.             # Look for mailto:'s
  864.  
  865.             if ($value =~ /^mailto:/i) {
  866.                 if ( $tag =~ /^a$/ && $value =~ /^mailto:([[:alpha:]0-9\-_\.]+?@([[:alpha:]0-9\-_\.]+?))([>\&\?\:\/\" \t]|$)/i )  {
  867.                    update_word( $self, $1, $encoded, 'mailto:', ($3?'[\\\>\&\?\:\/]':$end_quote), '' );
  868.                    add_url( $self, $2, $encoded, '@', ($3?'[\\\&\?\:\/]':$end_quote), '' );
  869.                 }
  870.             } else {
  871.  
  872.                 # Anything that isn't a mailto is probably an URL
  873.  
  874.                 $self->add_url($value, $encoded, $quote, $end_quote, '');
  875.             }
  876.  
  877.             next;
  878.         }
  879.  
  880.         # Tags with alt attributes
  881.  
  882.         if ( $attribute =~ /^alt$/i && $tag =~ /^img$/i )  {
  883.             add_line($self, $value, $encoded, '');
  884.             next;
  885.          }
  886.  
  887.         # Tags with working background attributes
  888.  
  889.         if ( $attribute =~ /^background$/i && $tag =~ /^(td|table|body)$/i ) {
  890.             add_url( $self, $value, $encoded, $quote, $end_quote, '' );
  891.             next;
  892.         }
  893.  
  894.         # Tags that load sounds
  895.  
  896.         if ( $attribute =~ /^bgsound$/i && $tag =~ /^body$/i ) {
  897.             add_url( $self, $value, $encoded, $quote, $end_quote, '' );
  898.             next;
  899.         }
  900.  
  901.  
  902.         # Tags with colors in them
  903.  
  904.         if ( ( $attribute =~ /^color$/i ) && ( $tag =~ /^font$/i ) ) {
  905.             update_word( $self, $value, $encoded, $quote, $end_quote, '' );
  906.             $self->update_pseudoword( 'html', "fontcolor$value", $encoded, $original );
  907.             $self->{htmlfontcolor__} = map_color($self, $value);
  908.             $self->compute_html_color_distance();
  909.             print "Set html font color to $self->{htmlfontcolor__}\n" if ( $self->{debug__} );
  910.             next;
  911.         }
  912.  
  913.         if ( ( $attribute =~ /^text$/i ) && ( $tag =~ /^body$/i ) ) {
  914.             $self->update_pseudoword( 'html', "fontcolor$value", $encoded, $original );
  915.             update_word( $self, $value, $encoded, $quote, $end_quote, '' );
  916.             $self->{htmlfontcolor__} = map_color($self, $value);
  917.             $self->compute_html_color_distance();
  918.             print "Set html font color to $self->{htmlfontcolor__}\n" if ( $self->{debug__} );
  919.             next;
  920.         }
  921.  
  922.         # The width and height of images
  923.  
  924.         if ( ( $attribute =~ /^(width|height)$/i ) && ( $tag =~ /^img$/i ) ) {
  925.             $attribute = lc( $attribute );
  926.             $self->update_pseudoword( 'html', "img$attribute$value", $encoded, $original );
  927.             next;
  928.         }
  929.  
  930.         # Font sizes
  931.  
  932.         if ( ( $attribute =~ /^size$/i ) && ( $tag =~ /^font$/i ) ) {
  933.             #TODO: unify font size scaling to use the same scale across size specifiers
  934.             $self->update_pseudoword( 'html', "fontsize$value", $encoded, $original );
  935.             next;
  936.         }
  937.  
  938.         # Tags with background colors
  939.  
  940.         if ( ( $attribute =~ /^(bgcolor|back)$/i ) && ( $tag =~ /^(td|table|body|tr|th|font)$/i ) ) {
  941.             update_word( $self, $value, $encoded, $quote, $end_quote, '' );
  942.             $self->update_pseudoword( 'html', "backcolor$value" );
  943.             $self->{htmlbackcolor__} = map_color($self, $value);
  944.             print "Set html back color to $self->{htmlbackcolor__}\n" if ( $self->{debug__} );
  945.  
  946.             $self->{htmlbodycolor__} = $self->{htmlbackcolor__} if ( $tag =~ /^body$/i );
  947.             $self->compute_html_color_distance();
  948.             next;
  949.         }
  950.  
  951.         # Tags with a charset
  952.  
  953.         if ( ( $attribute =~ /^content$/i ) && ( $tag =~ /^meta$/i ) ) {
  954.             if ( $value=~ /charset=([^\t\r\n ]{1,40})[\"\>]?/ ) {
  955.                 update_word( $self, $1, $encoded, '', '', '' );
  956.             }
  957.             next;
  958.         }
  959.  
  960.         # CSS handling
  961.  
  962.         if ( !exists($HTML::Tagset::emptyElement->{lc($tag)}) && $attribute =~ /^style$/i ) {
  963.             print "      Inline style tag found in $tag: $attribute=$value\n" if ( $self->{debug__} );
  964.  
  965.             my $style = $self->parse_css_style($value);
  966.  
  967.             if ($self->{debug__}) {
  968.                 print "      CSS properties: ";
  969.                 foreach my $key (keys( %{$style})) {
  970.                     print "$key($style->{$key}), ";
  971.                 }
  972.                 print "\n";
  973.             }
  974.  
  975.             # CSS font sizing
  976.             if (defined($style->{'font-size'})) {
  977.  
  978.                 my $size = $style->{'font-size'};
  979.  
  980.                 # TODO: unify font size scaling to use the same scale across size specifiers
  981.                 # approximate font sizes here:
  982.                 # http://www.dejeu.com/web/tools/tech/css/variablefontsizes.asp
  983.  
  984.                 if ($size =~ /(((\+|\-)?\d?\.?\d+)(em|ex|px|%|pt|in|cm|mm|pt|pc))|(xx-small|x-small|small|medium|large|x-large|xx-large)/) {
  985.                     $self->update_pseudoword( 'html', "cssfontsize$size", $encoded, $original );
  986.                     print "     CSS font-size set to: $size\n" if $self->{debug__};
  987.                 }
  988.             }
  989.  
  990.             # CSS visibility
  991.             if (defined($style->{'visibility'})) {
  992.                 $self->update_pseudoword( 'html', "cssvisibility" . $style->{'visibility'}, $encoded, $original );
  993.             }
  994.  
  995.             # CSS display
  996.             if (defined($style->{'display'})) {
  997.                 $self->update_pseudoword( 'html', "cssdisplay" . $style->{'display'}, $encoded, $original );
  998.             }
  999.  
  1000.  
  1001.             # CSS foreground coloring
  1002.  
  1003.             if (defined($style->{'color'})) {
  1004.                 my $color = $style->{'color'};
  1005.  
  1006.                 print "      CSS color: $color\n" if ($self->{debug__});
  1007.  
  1008.                 $color = $self->parse_css_color($color);
  1009.  
  1010.                 if ( $color ne "error" ) {
  1011.                     $self->{htmlfontcolor__} = $color;
  1012.                     $self->compute_html_color_distance();
  1013.  
  1014.                     print "      CSS set html font color to $self->{htmlfontcolor__}\n" if ( $self->{debug__} );
  1015.                     $self->update_pseudoword( 'html', "cssfontcolor$self->{htmlfontcolor__}", $encoded, $original );
  1016.  
  1017.                     $self->{cssfontcolortag__} = lc($tag);
  1018.                 }
  1019.             }
  1020.  
  1021.             # CSS background coloring
  1022.  
  1023.             if (defined($style->{'background-color'})) {
  1024.  
  1025.                 my $background_color = $style->{'background-color'};
  1026.  
  1027.                 $background_color = $self->parse_css_color($background_color);
  1028.  
  1029.                 if ($background_color ne "error") {
  1030.                     $self->{htmlbackcolor__} = $background_color;
  1031.                     $self->compute_html_color_distance();
  1032.                     print "       CSS set html back color to $self->{htmlbackcolor__}\n" if ( $self->{debug__} );
  1033.  
  1034.                     $self->{htmlbodycolor__} = $background_color if ( $tag =~ /^body$/i );
  1035.                     $self->{cssbackcolortag__} = lc($tag);
  1036.  
  1037.                     $self->update_pseudoword( 'html', "cssbackcolor$self->{htmlbackcolor__}", $encoded, $original );
  1038.                 }
  1039.             }
  1040.  
  1041.             # CSS all-in one background declaration (ugh)
  1042.  
  1043.             if (defined($style->{'background'})) {
  1044.                 my $expression;
  1045.                 my $background = $style->{'background'};
  1046.  
  1047.                 # Take the possibly multi-expression "background" property
  1048.  
  1049.                 while ( $background =~ s/^([^ \t\r\n\f]+)( |$)// ) {
  1050.  
  1051.                     # and examine each expression individually
  1052.  
  1053.                     $expression = $1;
  1054.                     print "       CSS expression $expression in background property\n" if ($self->{debug__} );
  1055.  
  1056.                     my $background_color = $self->parse_css_color($expression);
  1057.  
  1058.                     # to see if it is a color
  1059.  
  1060.                     if ($background_color ne "error") {
  1061.                         $self->{htmlbackcolor__} = $background_color;
  1062.                         $self->compute_html_color_distance();
  1063.                         print "       CSS set html back color to $self->{htmlbackcolor__}\n" if ( $self->{debug__} );
  1064.  
  1065.                         $self->{htmlbodycolor__} = $background_color if ( $tag =~ /^body$/i );
  1066.                         $self->{cssbackcolortag__} = lc($tag);
  1067.  
  1068.                         $self->update_pseudoword( 'html', "cssbackcolor$self->{htmlbackcolor__}", $encoded, $original );
  1069.                     }
  1070.                 }
  1071.             }
  1072.         }
  1073.  
  1074.         # TODO: move this up into the style part above
  1075.  
  1076.         # Tags with style attributes (this one may impact performance!!!)
  1077.         # most container tags accept styles, and the background style may
  1078.         # not be in a predictable location (search the entire value)
  1079.  
  1080.         if ( $attribute =~ /^style$/i && $tag =~ /^(body|td|tr|table|span|div|p)$/i ) {
  1081.             add_url( $self, $1, $encoded, '[\']', '[\']', '' ) if ( $value =~ /background\-image:[ \t]?url\([ \t]?\'(.*)\'[ \t]?\)/i );
  1082.             next;
  1083.         }
  1084.  
  1085.         # Tags with action attributes
  1086.  
  1087.         if ( $attribute =~ /^action$/i && $tag =~ /^form$/i )  {
  1088.             if ( $value =~ /^(ftp|http|https):\/\//i ) {
  1089.                 add_url( $self, $value, $encoded, $quote, $end_quote, '' );
  1090.                 next;
  1091.             }
  1092.  
  1093.             # mailto forms
  1094.  
  1095.             if ( $value =~ /^mailto:([[:alpha:]0-9\-_\.]+?@([[:alpha:]0-9\-_\.]+?))([>\&\?\:\/\" \t]|$)/i )  {
  1096.                update_word( $self, $1, $encoded, 'mailto:', ($3?'[\\\>\&\?\:\/]':$end_quote), '' );
  1097.                add_url( $self, $2, $encoded, '@', ($3?'[\\\>\&\?\:\/]':$end_quote), '' );
  1098.             }
  1099.             next;
  1100.         }
  1101.     }
  1102. }
  1103.  
  1104. # ---------------------------------------------------------------------------------------------
  1105. #
  1106. # add_url
  1107. #
  1108. # Parses a single url or domain and identifies interesting parts
  1109. #
  1110. # $url          the domain name to handle
  1111. # $encoded      1 if the domain was found in encoded text (base64)
  1112. # $before       The character that appeared before the URL in the original line
  1113. # $after        The character that appeared after the URL in the original line
  1114. # $prefix       A string to prefix any words with in the corpus, used for the special
  1115. #               identification of values found in for example the subject line
  1116. # $noadd        If defined indicates that only parsing should be done, no word updates
  1117. #
  1118. # Returns the hostname
  1119. #
  1120. # ---------------------------------------------------------------------------------------------
  1121. sub add_url
  1122. {
  1123.     my ($self, $url, $encoded, $before, $after, $prefix, $noadd) = @_;
  1124.  
  1125.     my $temp_url = $url;
  1126.     my $temp_before;
  1127.     my $temp_after;
  1128.     my $hostform;   #ip or name
  1129.  
  1130.     # parts of a URL, from left to right
  1131.     my $protocol;
  1132.     my $authinfo;
  1133.     my $host;
  1134.     my $port;
  1135.     my $path;
  1136.     my $query;
  1137.     my $hash;
  1138.  
  1139.     # Strip the protocol part of a URL (e.g. http://)
  1140.  
  1141.     $protocol = $1 if ( $url =~ s/^([^:]*)\:\/\/// );
  1142.  
  1143.     # Remove any URL encoding (protocol may not be URL encoded)
  1144.  
  1145.     my $oldurl   = $url;
  1146.     my $percents =  ( $url =~ s/(%([0-9A-Fa-f]{2}))/chr(hex("0x$2"))/ge );
  1147.  
  1148.     if ( $percents > 0 ) {
  1149.         $self->update_pseudoword( 'html', 'encodedurl', $encoded, $oldurl ) if ( !defined( $noadd ) );
  1150.     }
  1151.  
  1152.     # Extract authorization information from the URL (e.g. http://foo@bar.com)
  1153.  
  1154.     $authinfo = $1 if ( $url =~ s/^(([[:alpha:]0-9\-_\.\;\:\&\=\+\$\,]+)(\@|\%40))+// );
  1155.  
  1156.     $self->update_pseudoword( 'html', 'authorization', $encoded, $oldurl ) if ( defined( $authinfo ) && ( $authinfo ne '' ) );
  1157.  
  1158.     if ( $url =~ s/^(([[:alpha:]0-9\-_]+\.)+)(com|edu|gov|int|mil|net|org|aero|biz|coop|info|museum|name|pro|[[:alpha:]]{2})([^[:alpha:]0-9\-_\.]|$)/$4/i ) {
  1159.         $host = "$1$3";
  1160.         $hostform = "name";
  1161.     } else {
  1162.         if ( $url =~ /(([^:\/])+)/ ) {
  1163.  
  1164.             # Some other hostname format found, maybe
  1165.             # Read here for reference: http://www.pc-help.org/obscure.htm
  1166.             # Go here for comparison: http://www.samspade.org/t/url
  1167.  
  1168.             # save the possible hostname
  1169.  
  1170.             my $host_candidate = $1;
  1171.  
  1172.             # stores discovered IP address
  1173.  
  1174.             my %quads;
  1175.  
  1176.             # temporary values
  1177.  
  1178.             my $quad = 1;
  1179.             my $number;
  1180.  
  1181.             # iterate through the possible hostname, build dotted quad format
  1182.  
  1183.             while ($host_candidate =~ s/\G^((0x)[0-9A-Fa-f]+|0[0-7]+|[0-9]+)(\.)?//) {
  1184.                 my $hex = $2;
  1185.  
  1186.                 # possible IP quad(s)
  1187.  
  1188.                 my $quad_candidate = $1;
  1189.                 my $more_dots      = $3;
  1190.  
  1191.                 if (defined $hex) {
  1192.  
  1193.                     # hex number
  1194.                     # trim arbitrary octets that are greater than most significant bit
  1195.  
  1196.                     $quad_candidate =~ s/.*(([0-9A-F][0-9A-F]){4})$/$1/i;
  1197.                     $number = hex( $quad_candidate );
  1198.                 } else {
  1199.                     if ( $quad_candidate =~ /^0([0-7]+)/ )  {
  1200.  
  1201.                         # octal number
  1202.  
  1203.                         $number = oct($1);
  1204.                     } else {
  1205.  
  1206.                         # assume decimal number
  1207.                         # deviates from the obscure.htm document here, no current browsers overflow
  1208.  
  1209.                         $number = int($quad_candidate);
  1210.                     }
  1211.                 }
  1212.  
  1213.                 # No more IP dots?
  1214.  
  1215.                 if ( !defined( $more_dots ) ) {
  1216.  
  1217.                     # Expand final decimal/octal/hex to extra quads
  1218.  
  1219.                     while ( $quad <= 4 ) {
  1220.                         my $shift = ((4 - $quad) * 8);
  1221.                         $quads{$quad} = ($number & (hex("0xFF") << $shift) ) >> $shift;
  1222.                         $quad += 1;
  1223.                     }
  1224.                 } else {
  1225.  
  1226.                     # Just plug the quad in, no overflow allowed
  1227.  
  1228.                     $quads{$quad} = $number if ($number < 256);
  1229.                     $quad += 1;
  1230.                 }
  1231.  
  1232.                 last if ( $quad > 4 );
  1233.             }
  1234.  
  1235.             $host_candidate =~ s/\r|\n|$//g;
  1236.             if ( ( $host_candidate eq '' ) && # PROFILE BLOCK START
  1237.                  defined( $quads{1} )      &&
  1238.                  defined( $quads{2} )      &&
  1239.                  defined( $quads{3} )      &&
  1240.                  defined( $quads{4} )      &&
  1241.                  !defined( $quads{5} ) ) {    # PROFILE BLOCK STOP
  1242.  
  1243.                 # we did actually find an IP address, and not some fake
  1244.  
  1245.                 $hostform = "ip";
  1246.                 $host = "$quads{1}.$quads{2}.$quads{3}.$quads{4}";
  1247.                 $url =~ s/(([^:\/])+)//;
  1248.             }
  1249.         }
  1250.     }
  1251.  
  1252.     if ( !defined( $host ) || ( $host eq '' ) ) {
  1253.         print "no hostname found: [$temp_url]\n" if ($self->{debug__});
  1254.         return '';
  1255.     }
  1256.  
  1257.     $port = $1 if ( $url =~ s/^\:(\d+)//);
  1258.     $path = $1 if ( $url =~ s/^([\\\/][^\#\?\n]*)($)?// );
  1259.     $query = $1 if ( $url =~ s/^[\?]([^\#\n]*|$)?// );
  1260.     $hash = $1 if ( $url =~ s/^[\#](.*)$// );
  1261.  
  1262.     if ( !defined( $protocol ) || ( $protocol =~ /^(http|https)$/ ) ) {
  1263.         $temp_before = $before;
  1264.         $temp_before = "\:\/\/" if (defined $protocol);
  1265.         $temp_before = "[\@]" if (defined $authinfo);
  1266.  
  1267.         $temp_after = $after;
  1268.         $temp_after = "[\#]" if (defined $hash);
  1269.         $temp_after = "[\?]" if (defined $query);
  1270.         $temp_after = "[\\\\\/]" if (defined $path);
  1271.         $temp_after = "[\:]" if (defined $port);
  1272.  
  1273.         # add the entire domain
  1274.  
  1275.         update_word( $self, $host, $encoded, $temp_before, $temp_after, $prefix) if ( !defined( $noadd ) );
  1276.  
  1277.         # decided not to care about tld's beyond the verification performed when
  1278.         # grabbing $host
  1279.         # special subTLD's can just get their own classification weight (eg, .bc.ca)
  1280.         # http://www.0dns.org has a good reference of ccTLD's and their sub-tld's if desired
  1281.  
  1282.         if ( $hostform eq 'name' ) {
  1283.             # recursively add the roots of the domain
  1284.  
  1285.             while ( $host =~ s/^([^\.]+\.)?(([^\.]+\.?)*)(\.[^\.]+)$/$2$4/ ) {
  1286.  
  1287.                 if (!defined($1)) {
  1288.                     update_word( $self, $4, $encoded, $2, '[<]', $prefix) if ( !defined( $noadd ) );
  1289.                     last;
  1290.                 }
  1291.                 update_word( $self, $host, $encoded, $1 || $2, '[<]', $prefix) if ( !defined( $noadd ) );
  1292.             }
  1293.         }
  1294.     }
  1295.  
  1296.     # $protocol $authinfo $host $port $query $hash may be processed below if desired
  1297.     return $host;
  1298. }
  1299.  
  1300. # ---------------------------------------------------------------------------------------------
  1301. #
  1302. # parse_html
  1303. #
  1304. # Parse a line that might contain HTML information, returns 1 if we are still inside an
  1305. # unclosed HTML tag
  1306. #
  1307. # $line     A line of text
  1308. # $encoded  1 if this HTML was found inside encoded (base64) text
  1309. #
  1310. # ---------------------------------------------------------------------------------------------
  1311. sub parse_html
  1312. {
  1313.     my ( $self, $line, $encoded ) = @_;
  1314.  
  1315.     my $found = 1;
  1316.  
  1317.     $line =~ s/[\r\n]+/ /gm;
  1318.  
  1319.     print "parse_html: [$line] " . $self->{in_html_tag__} . "\n" if $self->{debug__};
  1320.  
  1321.     # Remove HTML comments and other tags that begin !
  1322.  
  1323.     while ( $line =~ s/(<!.*?>)// ) {
  1324.         $self->update_pseudoword( 'html', 'comment', $encoded, $1 );
  1325.         print "$line\n" if $self->{debug__};
  1326.     }
  1327.  
  1328.     # Remove invalid tags.  This finds tags of the form [a-z0-9]+ with
  1329.     # optional attributes and removes them if the tag isn't
  1330.     # recognized.
  1331.  
  1332.     # TODO: This also removes tags in plain text emails so a sentence
  1333.     # such as 'To run the program type "program <filename>".' is also
  1334.     # effected.  The correct fix seams to be to look at the
  1335.     # Content-Type header and only process mails of type text/html.
  1336.  
  1337.     while ( $line =~ s/(<\/?(?!(?:$spacing_tags|$non_spacing_tags)\W)[a-z0-9]+(?:\s+.*?)?\/?>)//io ) {
  1338.         $self->update_pseudoword( 'html', 'invalidtag', $encoded, $1 );
  1339.         print "html:invalidtag: $1\n" if $self->{debug__};
  1340.     }
  1341.  
  1342.     # Remove pairs of non-spacing tags without content such as <b></b>
  1343.     # and also <b><i></i></b>.
  1344.  
  1345.     # TODO: What about combined open and close tags such as <b />?
  1346.  
  1347.     while ( $line =~s/(<($non_spacing_tags)(?:\s+[^>]*?)?><\/\2>)//io ) {
  1348.         $self->update_pseudoword( 'html', 'emptypair', $encoded, $1 );
  1349.         print "html:emptypair: $1\n" if $self->{debug__};
  1350.     }
  1351.  
  1352.     while ( $found && ( $line ne '' ) ) {
  1353.         $found = 0;
  1354.  
  1355.         # If we are in an HTML tag then look for the close of the tag, if we get it then
  1356.         # handle the tag, if we don't then keep building up the arguments of the tag
  1357.  
  1358.         if ( $self->{in_html_tag__} )  {
  1359.             if ( $line =~ s/^([^>]*?)>// ) {
  1360.                 $self->{html_arg__} .= $1;
  1361.                 $self->{in_html_tag__} = 0;
  1362.                 $self->{html_tag__} =~ s/=\n ?//g;
  1363.                 $self->{html_arg__} =~ s/=\n ?//g;
  1364.                 update_tag( $self, $self->{html_tag__}, $self->{html_arg__}, $self->{html_end}, $encoded );
  1365.                 $self->{html_tag__} = '';
  1366.                 $self->{html_arg__} = '';
  1367.                 $found = 1;
  1368.                 next;
  1369.             } else {
  1370.                 $self->{html_arg__} .= $line;
  1371.                 return 1;
  1372.             }
  1373.         }
  1374.  
  1375.         # Does the line start with a HTML tag that is closed (i.e. has both the < and the
  1376.         # > present)?  If so then handle that tag immediately and continue
  1377.  
  1378.         if ( $line =~ s/^<([\/]?)([A-Za-z]+)([^>]*?)>// )  {
  1379.             update_tag( $self, $2, $3, ( $1 eq '/' ), $encoded );
  1380.             $found = 1;
  1381.             next;
  1382.         }
  1383.  
  1384.         # Does the line consist of just a tag that has no closing > then set up the global
  1385.         # vars that record the tag and return 1 to indicate to the caller that we have an
  1386.         # unclosed tag
  1387.  
  1388.         if ( $line =~ /^<([\/]?)([A-Za-z][^ >]+)([^>]*)$/ )  {
  1389.             $self->{html_end}    = ( $1 eq '/' );
  1390.             $self->{html_tag__}    = $2;
  1391.             $self->{html_arg__}    = $3;
  1392.             $self->{in_html_tag__} = 1;
  1393.             return 1;
  1394.         }
  1395.  
  1396.         # There could be something on the line that needs parsing (such as a word), if we reach here
  1397.         # then we are not in an unclosed tag and so we can grab everything from the start of the line
  1398.         # to the end or the first < and pass it to the line parser
  1399.  
  1400.         if ( $line =~ s/^([^<]+)(<|$)/$2/ ) {
  1401.             $found = 1;
  1402.             $self->add_line( $1, $encoded, '' );
  1403.         }
  1404.     }
  1405.  
  1406.     return 0;
  1407. }
  1408.  
  1409. # ---------------------------------------------------------------------------------------------
  1410. #
  1411. # parse_file
  1412. #
  1413. # Read messages from file and parse into a list of words and frequencies, returns a colorized
  1414. # HTML version of message if color__ is set
  1415. #
  1416. # $file     The file to open and parse
  1417. # $max_size The maximum size of message to parse, or 0 for unlimited
  1418. # $reset    If set to 0 then the list of words from a previous parse is not reset, this
  1419. #           can be used to do multiple parses and build a single word list.  By default
  1420. #           this is set to 1 and the word list is reset
  1421. #
  1422. # ---------------------------------------------------------------------------------------------
  1423. sub parse_file
  1424. {
  1425.     my ( $self, $file, $max_size, $reset ) = @_;
  1426.  
  1427.     $reset    = 1 if ( !defined( $reset    ) );
  1428.     $max_size = 0 if ( !defined( $max_size ) );
  1429.  
  1430.     $self->start_parse( $reset );
  1431.  
  1432.     my $size_read = 0;
  1433.  
  1434.     open MSG, "<$file";
  1435.     binmode MSG;
  1436.  
  1437.     # Read each line and find each "word" which we define as a sequence of alpha
  1438.     # characters
  1439.  
  1440.     while (<MSG>) {
  1441.         $size_read += length($_);
  1442.         $self->parse_line( $_ );
  1443.         if ( ( $max_size > 0 ) &&
  1444.              ( $size_read > $max_size ) ) {
  1445.             last;
  1446.         }
  1447.     }
  1448.  
  1449.     close MSG;
  1450.  
  1451.     $self->stop_parse();
  1452.  
  1453.     if ( $self->{color__} ne '' )  {
  1454.         $self->{colorized__} .= $self->{ut__} if ( $self->{ut__} ne '' );
  1455.  
  1456.         $self->{colorized__} .= "</tt>";
  1457.         $self->{colorized__} =~ s/(\r\n\r\n|\r\r|\n\n)/__BREAK____BREAK__/g;
  1458.         $self->{colorized__} =~ s/[\r\n]+/__BREAK__/g;
  1459.         $self->{colorized__} =~ s/__BREAK__/<br \/>/g;
  1460.  
  1461.         return $self->{colorized__};
  1462.     } else {
  1463.         return '';
  1464.     }
  1465. }
  1466.  
  1467. # ---------------------------------------------------------------------------------------------
  1468. #
  1469. # start_parse
  1470. #
  1471. # Called to reset internal variables before parsing.  This is automatically called when using
  1472. # the parse_file API, and must be called before the first call to parse_line.
  1473. #
  1474. # $reset    If set to 0 then the list of words from a previous parse is not reset, this
  1475. #           can be used to do multiple parses and build a single word list.  By default
  1476. #           this is set to 1 and the word list is reset
  1477. #
  1478. # ---------------------------------------------------------------------------------------------
  1479. sub start_parse
  1480. {
  1481.     my ( $self, $reset ) = @_;
  1482.  
  1483.     $reset = 1 if ( !defined( $reset ) );
  1484.  
  1485.     # This will contain the mime boundary information in a mime message
  1486.  
  1487.     $self->{mime__} = '';
  1488.  
  1489.     # Contains the encoding for the current block in a mime message
  1490.  
  1491.     $self->{encoding__} = '';
  1492.  
  1493.     # Variables to save header information to while parsing headers
  1494.  
  1495.     $self->{header__} = '';
  1496.     $self->{argument__} = '';
  1497.  
  1498.     # Clear the word hash
  1499.  
  1500.     $self->{content_type__} = '';
  1501.  
  1502.     # Base64 attachments are loaded into this as we read them
  1503.  
  1504.     $self->{base64__}       = '';
  1505.  
  1506.     # Variable to note that the temporary colorized storage is "frozen",
  1507.     # and what type of freeze it is (allows nesting of reasons to freeze
  1508.     # colorization)
  1509.  
  1510.     $self->{in_html_tag__} = 0;
  1511.  
  1512.     $self->{html_tag__}    = '';
  1513.     $self->{html_arg__}    = '';
  1514.  
  1515.     if ( $reset ) {
  1516.         $self->{words__} = {};
  1517.     }
  1518.  
  1519.     $self->{msg_total__}    = 0;
  1520.     $self->{from__}         = '';
  1521.     $self->{to__}           = '';
  1522.     $self->{cc__}           = '';
  1523.     $self->{subject__}      = '';
  1524.     $self->{ut__}           = '';
  1525.     $self->{quickmagnets__} = {};
  1526.  
  1527.     $self->{htmlbodycolor__} = map_color( $self, 'white' );
  1528.     $self->{htmlbackcolor__} = map_color( $self, 'white' );
  1529.     $self->{htmlfontcolor__} = map_color( $self, 'black' );
  1530.     $self->compute_html_color_distance();
  1531.  
  1532.     $self->{in_headers__} = 1;
  1533.  
  1534.     $self->{first20__}      = '';
  1535.     $self->{first20count__} = 0;
  1536.  
  1537.     # Used to return a colorize page
  1538.  
  1539.     $self->{colorized__} = '';
  1540.     $self->{colorized__} .= "<tt>" if ( $self->{color__} ne '' );
  1541. }
  1542.  
  1543. # ---------------------------------------------------------------------------------------------
  1544. #
  1545. # stop_parse
  1546. #
  1547. # Called at the end of a parse job.  Automatically called if parse_file is used, must be
  1548. # called after the last call to parse_line.
  1549. #
  1550. # ---------------------------------------------------------------------------------------------
  1551. sub stop_parse
  1552. {
  1553.     my ( $self ) = @_;
  1554.  
  1555.     $self->{colorized__} .= $self->clear_out_base64();
  1556.  
  1557.     # If we reach here and discover that we think that we are in an unclosed HTML tag then there
  1558.     # has probably been an error (such as a < in the text messing things up) and so we dump
  1559.     # whatever is stored in the HTML tag out
  1560.  
  1561.     if ( $self->{in_html_tag__} ) {
  1562.         $self->add_line( $self->{html_tag__} . ' ' . $self->{html_arg__}, 0, '' );
  1563.     }
  1564.  
  1565.     # if we are here, and still have headers stored, we must have a bodyless message
  1566.  
  1567.     #TODO: Fix me
  1568.  
  1569.     if ( $self->{header__} ne '' ) {
  1570.         $self->parse_header( $self->{header__}, $self->{argument__}, $self->{mime__}, $self->{encoding__} );
  1571.         $self->{header__} = '';
  1572.         $self->{argument__} = '';
  1573.     }
  1574.  
  1575.     $self->{in_html_tag__} = 0;
  1576. }
  1577.  
  1578. # ---------------------------------------------------------------------------------------------
  1579. #
  1580. # parse_line
  1581. #
  1582. # Called to parse a single line from a message.  If using this API directly then be sure
  1583. # to call start_parse before the first call to parse_line.
  1584. #
  1585. # $line               Line of file to parse
  1586. #
  1587. # ---------------------------------------------------------------------------------------------
  1588. sub parse_line
  1589. {
  1590.     my ( $self, $read ) = @_;
  1591.  
  1592.     if ( $read ne '' ) {
  1593.  
  1594.         # For the Mac we do further splitting of the line at the CR characters
  1595.  
  1596.         while ( $read =~ s/(.*?)[\r\n]+// )  {
  1597.             my $line = "$1\r\n";
  1598.  
  1599.             next if ( !defined($line) );
  1600.  
  1601.             print ">>> $line" if $self->{debug__};
  1602.  
  1603.             # Decode quoted-printable
  1604.             if ( !$self->{in_headers__} && $self->{encoding__} =~ /quoted\-printable/i) {
  1605.                 if ( $self->{lang__} eq 'Nihongo') {
  1606.                     if ( $line =~ /=\r\n$/ ) {
  1607.                         # Encoded in multiple lines
  1608.                         $line =~ s/=\r\n$//g;
  1609.                         $self->{prev__} .= $line;
  1610.                         next;
  1611.                     } else {
  1612.                         $line = $self->{prev__} . $line;
  1613.                         $self->{prev__} = '';
  1614.                     }
  1615.                 }
  1616.                 $line = decode_qp( $line );
  1617.             }
  1618.  
  1619.             # Decode \x??
  1620.             if ( $self->{lang__} eq 'Nihongo' && !$self->{in_headers__} ) {
  1621.                 $line =~ s/\\x([8-9A-F][A-F0-9])/pack("C", hex($1))/eig;
  1622.             }
  1623.  
  1624.             if ( $self->{lang__} eq 'Nihongo' ) {
  1625.                 $line = convert_encoding( $line, $self->{charset__}, 'euc-jp', '7bit-jis', @{$encoding_candidates{$self->{lang__}}} );
  1626.                 $line = parse_line_with_kakasi( $self, $line );
  1627.             }
  1628.  
  1629.             if ($self->{color__} ne '' ) {
  1630.  
  1631.                 if (!$self->{in_html_tag__}) {
  1632.                     $self->{colorized__} .= $self->{ut__};
  1633.                     $self->{ut__} = '';
  1634.                 }
  1635.  
  1636.                 $self->{ut__} .= $self->splitline($line, $self->{encoding__});
  1637.             }
  1638.  
  1639.             if ($self->{in_headers__}) {
  1640.  
  1641.                 # temporary colorization while in headers is handled within parse_header
  1642.  
  1643.                 $self->{ut__} = '';
  1644.  
  1645.                 # Check for blank line signifying end of headers
  1646.  
  1647.                 if ( $line =~ /^(\r\n|\r|\n)/) {
  1648.  
  1649.                      # Parse the last header
  1650.                     ($self->{mime__},$self->{encoding__}) = $self->parse_header($self->{header__},$self->{argument__},$self->{mime__},$self->{encoding__});
  1651.  
  1652.                     # Clear the saved headers
  1653.                     $self->{header__}   = '';
  1654.                     $self->{argument__} = '';
  1655.  
  1656.                     $self->{ut__} .= $self->splitline( "\015\012", 0 );
  1657.  
  1658.                     $self->{in_headers__} = 0;
  1659.                     print "Header parsing complete.\n" if $self->{debug__};
  1660.  
  1661.                     next;
  1662.                 }
  1663.  
  1664.                 # Append to argument if the next line begins with whitespace (isn't a new header)
  1665.  
  1666.                 if ( $line =~ /^([\t ].+)([^\r\n]+)/ ) {
  1667.                     $self->{argument__} .= "$eol$1$2";
  1668.                     next;
  1669.                 }
  1670.  
  1671.                 # If we have an email header then split it into the header and its argument
  1672.  
  1673.                 if ( $line =~ /^([A-Za-z\-]+):[ \t]*([^\n\r]*)/ )  {
  1674.  
  1675.                     # Parse the last header
  1676.  
  1677.                     ($self->{mime__},$self->{encoding__}) = $self->parse_header($self->{header__},$self->{argument__},$self->{mime__},$self->{encoding__}) if ($self->{header__} ne '');
  1678.  
  1679.                     # Save the new information for the current header
  1680.  
  1681.                     $self->{header__}   = $1;
  1682.                     $self->{argument__} = $2;
  1683.                     next;
  1684.                 }
  1685.  
  1686.                 next;
  1687.             }
  1688.  
  1689.             # If we are in a mime document then spot the boundaries
  1690.  
  1691.             if ( ( $self->{mime__} ne '' ) && ( $line =~ /^\-\-($self->{mime__})(\-\-)?/ ) ) {
  1692.  
  1693.                 # approach each mime part with fresh eyes
  1694.  
  1695.                 $self->{encoding__} = '';
  1696.  
  1697.                 if ( !defined( $2 ) ) {
  1698.  
  1699.                     # This means there was no trailing -- on the mime boundary (which would
  1700.                     # have indicated the end of a boundary, so now we have a new part of the
  1701.                     # document, hence we need to look for new headers
  1702.  
  1703.                     print "Hit MIME boundary --$1\n" if $self->{debug__};
  1704.  
  1705.                     $self->{in_headers__} = 1;
  1706.                 } else {
  1707.  
  1708.                     # A boundary was just terminated
  1709.  
  1710.                     $self->{in_headers__} = 0;
  1711.  
  1712.                     my $boundary = $1;
  1713.  
  1714.                     print "Hit MIME boundary terminator --$1--\n" if $self->{debug__};
  1715.  
  1716.                     # Escape to match escaped boundary characters
  1717.  
  1718.                     $boundary =~ s/(.*)/\Q$1\E/g;
  1719.  
  1720.                     # Remove the boundary we just found from the boundary list.  The list
  1721.                     # is stored in $self->{mime__} and consists of mime boundaries separated
  1722.                     # by the alternation characters | for use within a regexp
  1723.  
  1724.                     my $temp_mime = '';
  1725.  
  1726.                     foreach my $aboundary (split(/\|/,$self->{mime__})) {
  1727.                         if ($boundary ne $aboundary) {
  1728.                             if ( $temp_mime ne '' ) {
  1729.                                 $temp_mime = join('|', $temp_mime, $aboundary);
  1730.                             } else {
  1731.                                 $temp_mime = $aboundary
  1732.                             }
  1733.                         }
  1734.                     }
  1735.  
  1736.                     $self->{mime__} = $temp_mime;
  1737.  
  1738.                     print "MIME boundary list now $self->{mime__}\n" if $self->{debug__};
  1739.                 }
  1740.  
  1741.                 next;
  1742.             }
  1743.  
  1744.             # If we are doing base64 decoding then look for suitable lines and remove them
  1745.             # for decoding
  1746.  
  1747.             if ( $self->{encoding__} =~ /base64/i ) {
  1748.                 $line =~ s/[\r\n]//g;
  1749.                 $line =~ s/!$//;
  1750.                 $self->{base64__} .= $line;
  1751.  
  1752.                 next;
  1753.             }
  1754.  
  1755.             next if ( !defined($line) );
  1756.  
  1757.             parse_html( $self, $line, 0 );
  1758.         }
  1759.     }
  1760. }
  1761.  
  1762. # ---------------------------------------------------------------------------------------------
  1763. #
  1764. # clear_out_base64
  1765. #
  1766. # If there's anything in the {base64__} then decode it and parse it, returns colorization
  1767. # information to be added to the colorized output
  1768. #
  1769. # ---------------------------------------------------------------------------------------------
  1770. sub clear_out_base64
  1771. {
  1772.     my ( $self ) = @_;
  1773.  
  1774.     my $colorized = '';
  1775.  
  1776.     if ( $self->{base64__} ne '' ) {
  1777.         my $decoded = '';
  1778.  
  1779.         $self->{ut__}     = '' if ( $self->{color__} ne '' );
  1780.         $self->{base64__} =~ s/ //g;
  1781.  
  1782.         print "Base64 data: " . $self->{base64__} . "\n" if ($self->{debug__});
  1783.  
  1784.         $decoded = decode_base64( $self->{base64__} );
  1785.         $self->parse_html( $decoded, 1 );
  1786.  
  1787.         print "Decoded: " . $decoded . "\n" if ($self->{debug__});
  1788.  
  1789.         $self->{ut__} = "<b>Found in encoded data:</b> " . $self->{ut__} if ( $self->{color__} ne '' );
  1790.  
  1791.             if ( $self->{color__} ne '' )  {
  1792.                 if ( $self->{ut__} ne '' )  {
  1793.                     $colorized = $self->{ut__};
  1794.                     $self->{ut__} = '';
  1795.             }
  1796.         }
  1797.     }
  1798.  
  1799.     $self->{base64__} = '';
  1800.  
  1801.     return $colorized;
  1802. }
  1803.  
  1804. # ---------------------------------------------------------------------------------------------
  1805. #
  1806. # decode_string - Decode MIME encoded strings used in the header lines
  1807. # in email messages
  1808. #
  1809. # $mystring     - The string that neeeds decode
  1810. #
  1811. # Return the decoded string, this routine recognizes lines of the form
  1812. #
  1813. # =?charset?[BQ]?text?=
  1814. #
  1815. # $lang Pass in the current interface language for language specific
  1816. # encoding conversion A B indicates base64 encoding, a Q indicates
  1817. # quoted printable encoding
  1818. # ---------------------------------------------------------------------------------------------
  1819. sub decode_string
  1820. {
  1821.     # I choose not to use "$mystring = MIME::Base64::decode( $1 );"
  1822.     # because some spam mails have subjects like: "Subject: adjpwpekm
  1823.     # =?ISO-8859-1?Q?=B2=E1=A4=D1=AB=C7?= dopdalnfjpw".  Therefore, it
  1824.     # will be better to store the decoded text in a temporary variable
  1825.     # and substitute the original string with it later. Thus, this
  1826.     # subroutine returns the real decoded result.
  1827.  
  1828.     my ( $self, $mystring, $lang ) = @_;
  1829.  
  1830.     my $decode_it = '';
  1831.     my $charset = '';
  1832.  
  1833.     $lang = $self->{lang__} if ( !defined( $lang ) || ( $lang eq '' ) );
  1834.  
  1835.     while ( $mystring =~ /=\?([\w-]+)\?(B|Q)\?(.*?)\?=/ig ) {
  1836.         if ($2 eq "B" || $2 eq "b") {
  1837.             $charset = $1;
  1838.             $decode_it = decode_base64( $3 );
  1839.  
  1840.             # for Japanese header
  1841.             if ($lang eq 'Nihongo') {
  1842.                 $decode_it = convert_encoding( $decode_it, $charset, 'euc-jp', '7bit-jis', @{$encoding_candidates{$self->{lang__}}} );
  1843.             }
  1844.  
  1845.             $mystring =~ s/=\?[\w-]+\?B\?(.*?)\?=/$decode_it/i;
  1846.         } else {
  1847.             if ($2 eq "Q" || $2 eq "q") {
  1848.                 $decode_it = $3;
  1849.                 $decode_it =~ s/\_/=20/g;
  1850.                 $decode_it = decode_qp( $decode_it );
  1851.  
  1852.                 # for Japanese header
  1853.                 if ($lang eq 'Nihongo') {
  1854.                     $decode_it = convert_encoding( $decode_it, $charset, 'euc-jp', '7bit-jis', @{$encoding_candidates{$self->{lang__}}} );
  1855.                 }
  1856.  
  1857.                 $mystring =~ s/=\?[\w-]+\?Q\?(.*?)\?=/$decode_it/i;
  1858.             }
  1859.         }
  1860.     }
  1861.  
  1862.     return $mystring;
  1863. }
  1864.  
  1865. # ---------------------------------------------------------------------------------------------
  1866. #
  1867. # get_header - Returns the value of the from, to, subject or cc header
  1868. #
  1869. # $header      Name of header to return (note must be lowercase)
  1870. #
  1871. # ---------------------------------------------------------------------------------------------
  1872. sub get_header
  1873. {
  1874.     my ( $self, $header ) = @_;
  1875.  
  1876.     return $self->{$header . '__'} || '';
  1877. }
  1878.  
  1879. # ---------------------------------------------------------------------------------------------
  1880. #
  1881. # parse_header - Performs parsing operations on a message header
  1882. #
  1883. # $header       Name of header being processed
  1884. # $argument     Value of header being processed
  1885. # $mime         The presently saved mime boundaries list
  1886. # $encoding     Current message encoding
  1887. #
  1888. # ---------------------------------------------------------------------------------------------
  1889. sub parse_header
  1890. {
  1891.     my ($self, $header, $argument, $mime, $encoding) = @_;
  1892.  
  1893.     print "Header ($header) ($argument)\n" if ($self->{debug__});
  1894.  
  1895.     # After a discussion with Tim Peters and some looking at emails
  1896.     # I'd received I discovered that the header names (case sensitive) are
  1897.     # very significant in identifying different types of mail, for example
  1898.     # much spam uses MIME-Version, MiME-Version and Mime-Version
  1899.  
  1900.     my $fix_argument = $argument;
  1901.     $fix_argument =~ s/</</g;
  1902.     $fix_argument =~ s/>/>/g;
  1903.  
  1904.     $argument =~ s/(\r\n|\r|\n)/ /g;
  1905.     $argument =~ s/^[ \t]+//;
  1906.  
  1907.     if ( $self->update_pseudoword( 'header', $header, 0, $header ) ) {
  1908.         if ( $self->{color__} ne '' ) {
  1909.             my $color     = $self->get_color__("header:$header" );
  1910.             $self->{ut__} =  "<b><font color=\"$color\">$header</font></b>: $fix_argument\015\012";
  1911.         }
  1912.     } else {
  1913.         if ( $self->{color__} ne '' ) {
  1914.             $self->{ut__} =  "$header: $fix_argument\015\012";
  1915.         }
  1916.     }
  1917.  
  1918.     # Check the encoding type in all RFC 2047 encoded headers
  1919.  
  1920.     if ( $argument =~ /=\?([^\r\n\t ]{1,40})\?(Q|B)/i ) {
  1921.             update_word( $self, $1, 0, '', '', 'charset' );
  1922.     }
  1923.  
  1924.     # Handle the From, To and Cc headers and extract email addresses
  1925.     # from them and treat them as words
  1926.  
  1927.     # For certain headers we are going to mark them specially in the corpus
  1928.     # by tagging them with where they were found to help the classifier
  1929.     # do a better job.  So if you have
  1930.     #
  1931.     # From: foo@bar.com
  1932.     #
  1933.     # then we'll add from:foo@bar.com to the corpus and not just foo@bar.com
  1934.  
  1935.     my $prefix = '';
  1936.  
  1937.     if ( $header =~ /^(From|To|Cc|Reply\-To)$/i ) {
  1938.  
  1939.         # These headers at least can be decoded
  1940.  
  1941.         $argument = $self->decode_string( $argument , $self->{lang__} );
  1942.  
  1943.         if ( $header =~ /^From$/i )  {
  1944.             $prefix = 'from';
  1945.             if ( $self->{from__} eq '' ) {
  1946.                 $self->{from__} = $argument;
  1947.                 $self->{from__} =~ s/[\t\r\n]//g;
  1948.             }
  1949.         }
  1950.  
  1951.         if ( $header =~ /^To$/i ) {
  1952.             $prefix = 'to';
  1953.             if ( $self->{to__} eq '' ) {
  1954.                 $self->{to__} = $argument;
  1955.                 $self->{to__} =~ s/[\t\r\n]//g;
  1956.             }
  1957.         }
  1958.  
  1959.         if ( $header =~ /^Cc$/i ) {
  1960.             $prefix = 'cc';
  1961.             if ( $self->{cc__} eq '' ) {
  1962.                 $self->{cc__} = $argument;
  1963.                 $self->{cc__} =~ s/[\t\r\n]//g;
  1964.             }
  1965.         }
  1966.  
  1967.         while ( $argument =~ s/<([[:alpha:]0-9\-_\.]+?@([[:alpha:]0-9\-_\.]+?))>// )  {
  1968.             update_word($self, $1, 0, ';', '&',$prefix);
  1969.             add_url($self, $2, 0, '@', '[&<]',$prefix);
  1970.         }
  1971.  
  1972.         while ( $argument =~ s/([[:alpha:]0-9\-_\.]+?@([[:alpha:]0-9\-_\.]+))// )  {
  1973.             update_word($self, $1, 0, '', '',$prefix);
  1974.             add_url($self, $2, 0, '@', '',$prefix);
  1975.         }
  1976.  
  1977.         add_line( $self, $argument, 0, $prefix );
  1978.         return ($mime, $encoding);
  1979.     }
  1980.  
  1981.     if ( $header =~ /^Subject$/i ) {
  1982.  
  1983.         $prefix = 'subject';
  1984.         $argument = $self->decode_string( $argument, $self->{lang__} );
  1985.         if ( $self->{subject__} eq '' ) {
  1986.  
  1987.             # In Japanese mode, parse subject with kakasi
  1988.  
  1989.             $argument = parse_line_with_kakasi( $self, $argument ) if ( $self->{lang__} eq 'Nihongo' && $argument ne '' );
  1990.  
  1991.             $self->{subject__} = $argument;
  1992.             $self->{subject__} =~ s/[\t\r\n]//g;
  1993.         }
  1994.     }
  1995.  
  1996.     $self->{date__} = $argument if ( $header =~ /^Date$/i );
  1997.  
  1998.     if ( $header =~ /^X-Spam-Status$/i) {
  1999.  
  2000.         # We have found a header added by SpamAssassin. We expect to
  2001.         # find keywords in here that will help us classify our messages
  2002.  
  2003.         # We will find the keywords after the phrase "tests=" and before
  2004.         # SpamAssassin's version number or autolearn= string
  2005.  
  2006.         (my $sa_keywords = $argument) =~ s/[\r\n ]//sg;
  2007.         $sa_keywords =~ s/^.+tests=(.+)/$1/;
  2008.         $sa_keywords =~ s/(.+)autolearn.+$/$1/ or $sa_keywords =~ s/(.+)version.+$/$1/;
  2009.  
  2010.         # remove all spaces that may still be present:
  2011.         $sa_keywords =~ s/[\t ]//g;
  2012.  
  2013.         foreach ( split /,/, $sa_keywords ) {
  2014.             $self->update_pseudoword( 'spamassassin', lc($_), 0, $argument );
  2015.         }
  2016.     }
  2017.  
  2018.     if ( $header =~ /^X-Spam-Level$/i) {
  2019.         my $count = ( $argument =~ tr/*// );
  2020.         for ( 1 .. $count ) {
  2021.             $self->update_pseudoword( 'spamassassinlevel', 'spam', 0, $argument );
  2022.         }
  2023.     }
  2024.  
  2025.     # Look for MIME
  2026.  
  2027.     if ( $header =~ /^Content-Type$/i ) {
  2028.         if ( $argument =~ /charset=\"?([^\"\r\n\t ]{1,40})\"?/ ) {
  2029.             $self->{charset__} = $1;
  2030.             update_word( $self, $1, 0, '' , '', 'charset' );
  2031.         }
  2032.  
  2033.         if ( $argument =~ /^(.*?)(;)/ ) {
  2034.             print "Set content type to $1\n" if $self->{debug__};
  2035.             $self->{content_type__} = $1;
  2036.         }
  2037.  
  2038.         if ( $argument =~ /multipart\//i ) {
  2039.             my $boundary = $argument;
  2040.  
  2041.             if ( $boundary =~ /boundary= ?(\"([A-Z0-9\'\(\)\+\_\,\-\.\/\:\=\?][A-Z0-9\'\(\)\+_,\-\.\/:=\? ]{0,69})\"|([^\(\)\<\>\@\,\;\:\\\"\/\[\]\?\=]{1,70}))/i ) {
  2042.  
  2043.                 $boundary = ($2 || $3);
  2044.  
  2045.                 $boundary =~ s/(.*)/\Q$1\E/g;
  2046.  
  2047.                 if ($mime ne '') {
  2048.  
  2049.                     # Fortunately the pipe character isn't a valid mime boundary character!
  2050.  
  2051.                     $mime = join('|', $mime, $boundary);
  2052.                 } else {
  2053.                     $mime = $boundary;
  2054.                 }
  2055.                 print "Set mime boundary to " . $mime . "\n" if $self->{debug__};
  2056.                 return ($mime, $encoding);
  2057.             }
  2058.         }
  2059.  
  2060.         if ( $argument =~ /name=\"(.*)\"/i ) {
  2061.             $self->add_attachment_filename( $1 );
  2062.         }
  2063.  
  2064.         return ( $mime, $encoding );
  2065.     }
  2066.  
  2067.     # Look for the different encodings in a MIME document, when we hit base64 we will
  2068.     # do a special parse here since words might be broken across the boundaries
  2069.  
  2070.     if ( $header =~ /^Content-Transfer-Encoding$/i ) {
  2071.         $encoding = $argument;
  2072.         print "Setting encoding to $encoding\n" if $self->{debug__};
  2073.         my $compact_encoding = $encoding;
  2074.         $compact_encoding =~ s/[^A-Za-z0-9]//g;
  2075.         $self->update_pseudoword( 'encoding', $compact_encoding, 0, $encoding );
  2076.         return ($mime, $encoding);
  2077.     }
  2078.  
  2079.     # Some headers to discard
  2080.  
  2081.     return ($mime, $encoding) if ( $header =~ /^(Thread-Index|X-UIDL|Message-ID|X-Text-Classification|X-Mime-Key)$/i );
  2082.  
  2083.     # Some headers should never be RFC 2047 decoded
  2084.  
  2085.     $argument = $self->decode_string($argument, $self->{lang__}) unless ($header =~ /^(Received|Content\-Type|Content\-Disposition)$/i);
  2086.  
  2087.     if ( $header =~ /^Content-Disposition$/i ) {
  2088.         $self->handle_disposition( $argument );
  2089.         return ( $mime, $encoding );
  2090.     }
  2091.  
  2092.     add_line( $self, $argument, 0, $prefix );
  2093.  
  2094.     return ($mime, $encoding);
  2095. }
  2096.  
  2097. # ---------------------------------------------------------------------------------------------
  2098. #
  2099. # parse_css_ruleset - Parses text for CSS declarations
  2100. #                     Uses the second part of the "ruleset" grammar
  2101. #
  2102. # $line         The line to match
  2103. # $braces       1 if braces are included, 0 if excluded. Defaults to 0. Optional.
  2104. # Returns       A hash of properties containing their expressions
  2105. #
  2106. # ---------------------------------------------------------------------------------------------
  2107.  
  2108. sub parse_css_style
  2109. {
  2110.     my ( $self, $line, $braces ) = @_;
  2111.  
  2112.     # http://www.w3.org/TR/CSS2/grammar.html
  2113.  
  2114.     $braces = 0 unless ( defined( $braces ) );
  2115.  
  2116.     # A reference is used to return data
  2117.  
  2118.     my $hash = {};
  2119.  
  2120.     if ($braces) {
  2121.         $line =~ s/\{(.*?)\}/$1/
  2122.     }
  2123.     while ($line =~ s/^[ \t\r\n\f]*([a-z][a-z0-9\-]+)[ \t\r\n\f]*:[ \t\r\n\f]*(.*?)[ \t\r\n\f]?(;|$)//i) {
  2124.         $hash->{lc($1)} = $2;
  2125.     }
  2126.     return $hash;
  2127. }
  2128.  
  2129. # ---------------------------------------------------------------------------------------------
  2130. #
  2131. # parse_css_color - Parses a CSS color string
  2132. #
  2133. # $color        The string to parse
  2134. # Returns       (r,g,b) triplet in list context, rrggbb (hex) color in scalar context
  2135. # In case of an error: (-1,-1,-1) in list context, "error" in scalar context
  2136. #
  2137. # ---------------------------------------------------------------------------------------------
  2138.  
  2139. sub parse_css_color
  2140. {
  2141.     my ( $self, $color ) = @_;
  2142.  
  2143.     # CSS colors can be in a rgb(r,g,b), #hhh, #hhhhhh or a named color form
  2144.  
  2145.     # http://www.w3.org/TR/CSS2/syndata.html#color-units
  2146.  
  2147.     my ($r, $g, $b, $error, $found) = (0,0,0,0,0);
  2148.  
  2149.     if ($color =~ /^rgb\( ?(.*?) ?\, ?(.*?) ?\, ?(.*?) ?\)$/ ) {
  2150.  
  2151.         # rgb(r,g,b) can be expressed as values 0-255 or percentages 0%-100%,
  2152.         # numbers outside this range are allowed and should be clipped into
  2153.         # this range
  2154.  
  2155.         # TODO: store front/back colors in a RGB hash/array
  2156.         #       converting to a hh hh hh format and back
  2157.         #       is a waste as is repeatedly decoding
  2158.         #       from hh hh hh format
  2159.  
  2160.         ($r, $g, $b) = ($1, $2, $3);
  2161.  
  2162.         my $ispercent = 0;
  2163.  
  2164.         my $value_re = qr/^((-[1-9]\d*)|([1-9]\d*|0))$/;
  2165.         my $percent_re = qr/^([1-9]\d+|0)%$/;
  2166.  
  2167.         my ($r_temp, $g_temp, $b_temp);
  2168.  
  2169.         if (( ($r_temp) = ($r =~ $percent_re) ) &&   # PROFILE BLOCK START
  2170.             ( ($g_temp) = ($g =~ $percent_re) ) &&
  2171.             ( ($b_temp) = ($b =~ $percent_re) )) { # PROFILE BLOCK STOP
  2172.  
  2173.             $ispercent = 1;
  2174.  
  2175.             # clip to 0-100
  2176.             $r_temp = 100 if ($r_temp > 100);
  2177.             $g_temp = 100 if ($g_temp > 100);
  2178.             $b_temp = 100 if ($b_temp > 100);
  2179.  
  2180.             # convert into 0-255 range
  2181.             $r = int((($r_temp / 100) * 255) + .5);
  2182.             $g = int((($g_temp / 100) * 255) + .5);
  2183.             $b = int((($b_temp / 100) * 255) + .5);
  2184.  
  2185.             $found = 1;
  2186.         }
  2187.  
  2188.         if ( ( $r =~ $value_re ) &&   # PROFILE BLOCK START
  2189.              ( $g =~ $value_re ) &&
  2190.              ( $b =~ $value_re ) ) { # PROFILE BLOCK STOP
  2191.  
  2192.             $ispercent = 0;
  2193.  
  2194.             #clip to 0-255
  2195.  
  2196.             $r = 0   if ($r <= 0);
  2197.             $r = 255 if ($r >= 255);
  2198.             $g = 0   if ($g <= 0);
  2199.             $g = 255 if ($g >= 255);
  2200.             $b = 0   if ($b <= 0);
  2201.             $b = 255 if ($b >= 255);
  2202.  
  2203.             $found = 1;
  2204.         }
  2205.  
  2206.         if (!$found) {
  2207.             # here we have a combination of percentages and integers or some other oddity
  2208.             $ispercent = 0;
  2209.             $error = 1
  2210.         }
  2211.  
  2212.         print "        CSS rgb($r, $g, $b) percent: $ispercent\n" if ( $self->{debug__} );
  2213.     }
  2214.     if ( $color =~ /^#(([0-9a-f]{3})|([0-9a-f]{6}))$/i ) {
  2215.  
  2216.         # #rgb or #rrggbb
  2217.         print "        CSS numeric form: $color\n" if $self->{debug__};
  2218.  
  2219.         $color = $2 || $3;
  2220.  
  2221.         if (defined($2)) {
  2222.  
  2223.             # in 3 value form, the value is computed by doubling each digit
  2224.  
  2225.             ( $r, $g, $b )  = ( hex( $1 . $1 ), hex( $2 . $2 ), hex( $3 . $3 ) ) if ($color =~ /^(.)(.)(.)$/);
  2226.         } else {
  2227.             ( $r, $g, $b ) = ( hex( $1 ), hex( $2 ), hex( $3 ) ) if ($color =~ /^(..)(..)(..)$/);
  2228.         }
  2229.         $found = 1;
  2230.  
  2231.     }
  2232.     if ($color =~ /^(aqua|black|blue|fuchsia|gray|green|lime|maroon|navy|olive|purple|red|silver|teal|white|yellow)$/i ) {
  2233.         # these are the only CSS defined colours
  2234.  
  2235.         print "       CSS textual color form: $color\n" if $self->{debug__};
  2236.  
  2237.         my $new_color = map_color( $self, $color );
  2238.  
  2239.         # our color map may have failed
  2240.         $error = 1 if ($new_color eq $color);
  2241.         ($r, $g, $b) = (hex($1), hex($2), hex($3)) if ( $new_color =~ /^(..)(..)(..)$/);
  2242.         $found = 1;
  2243.     }
  2244.  
  2245.     $found = 0 if ($error);
  2246.  
  2247.     if ( defined($r) && ( 0 <= $r) && ($r <= 255) && # PROFILE BLOCK START
  2248.          defined($g) && ( 0 <= $g) && ($g <= 255) &&
  2249.          defined($b) && ( 0 <= $b) && ($b <= 255) &&
  2250.          $found ) {                                 # PROFILE BLOCK STOP
  2251.         if (wantarray) {
  2252.             return ( $r, $g, $b );
  2253.         } else {
  2254.             $color = sprintf('%1$02x%2$02x%3$02x', $r, $g, $b);
  2255.             return $color;
  2256.         }
  2257.     } else {
  2258.         if (wantarray) {
  2259.             return (-1,-1,-1);
  2260.         } else {
  2261.             return "error";
  2262.         }
  2263.     }
  2264. }
  2265.  
  2266. # ---------------------------------------------------------------------------------------------
  2267. #
  2268. # match_attachment_filename - Matches a line  like 'attachment; filename="<filename>"
  2269. #
  2270. # $line         The line to match
  2271. # Returns       The first match (= "attchment" if found)
  2272. #               The second match (= name of the file if found)
  2273. #
  2274. # ---------------------------------------------------------------------------------------------
  2275. sub match_attachment_filename
  2276. {
  2277.     my ( $self, $line ) = @_;
  2278.  
  2279.     $line =~ /\s*(.*);\s*filename=\"(.*)\"/;
  2280.  
  2281.     return ( $1, $2 );
  2282. }
  2283.  
  2284. # ---------------------------------------------------------------------------------------------
  2285. #
  2286. # file_extension - Splits a filename into name and extension
  2287. #
  2288. # $filename     The filename to split
  2289. # Returns       The name of the file
  2290. #               The extension of the file
  2291. #
  2292. # ---------------------------------------------------------------------------------------------
  2293. sub file_extension
  2294. {
  2295.     my ( $self, $filename ) = @_;
  2296.  
  2297.     $filename =~ s/(.*)\.(.*)$//;
  2298.  
  2299.     if ( length( $1 ) > 0 ) {
  2300.         return ( $1, $2 );
  2301.     } else {
  2302.         return ( $filename, "" );
  2303.     }
  2304. }
  2305. # ---------------------------------------------------------------------------------------------
  2306. #
  2307. # add_attachment_filename - Adds a file name and extension as pseudo words attchment_name
  2308. #                         and attachment_ext
  2309. #
  2310. # $filename     The filename to add to the list of words
  2311. #
  2312. # ---------------------------------------------------------------------------------------------
  2313. sub add_attachment_filename
  2314. {
  2315.     my ( $self, $filename ) = @_;
  2316.  
  2317.     if ( length( $filename ) > 0) {
  2318.         print "Add filename $filename\n" if $self->{debug__};
  2319.  
  2320.         my ( $name, $ext ) = $self->file_extension( $filename );
  2321.  
  2322.         if ( length( $name ) > 0) {
  2323.             $self->update_pseudoword( 'mimename', $name, 0, $name );
  2324.         }
  2325.  
  2326.         if ( length( $ext ) > 0 ) {
  2327.             $self->update_pseudoword( 'mimeextension', $ext, 0, $ext );
  2328.         }
  2329.     }
  2330. }
  2331.  
  2332. # ---------------------------------------------------------------------------------------------
  2333. #
  2334. # handle_disposition - Parses Content-Disposition header to extract filename.
  2335. #                      If filename found, at the file name and extension to the word list
  2336. #
  2337. # $params     The parameters of the Content-Disposition header
  2338. #
  2339. # ---------------------------------------------------------------------------------------------
  2340. sub handle_disposition
  2341. {
  2342.     my ( $self, $params ) = @_;
  2343.  
  2344.     my ( $attachment, $filename ) = $self->match_attachment_filename( $params );
  2345.  
  2346.     if ( $attachment eq 'attachment' ) {
  2347.         $self->add_attachment_filename( $filename ) ;
  2348.     }
  2349. }
  2350.  
  2351. # ---------------------------------------------------------------------------------------------
  2352. #
  2353. # splitline - Escapes characters so a line will print as plain-text within a HTML document.
  2354. #
  2355. # $line         The line to escape
  2356. # $encoding     The value of any current encoding scheme
  2357. #
  2358. # ---------------------------------------------------------------------------------------------
  2359. sub splitline
  2360. {
  2361.     my ( $self, $line, $encoding) = @_;
  2362.  
  2363.     $line =~ s/([^\r\n]{100,120} )/$1\r\n/g;
  2364.     $line =~ s/([^ \r\n]{120})/$1\r\n/g;
  2365.  
  2366.     $line =~ s/</</g;
  2367.     $line =~ s/>/>/g;
  2368.  
  2369.     if ( $encoding =~ /quoted\-printable/i ) {
  2370.         $line =~ s/=3C/</g;
  2371.         $line =~ s/=3E/>/g;
  2372.     }
  2373.  
  2374.     $line =~ s/\t/    /g;
  2375.  
  2376.     return $line;
  2377. }
  2378.  
  2379. # GETTERS/SETTERS
  2380.  
  2381. sub first20
  2382. {
  2383.    my ( $self ) = @_;
  2384.  
  2385.    return $self->{first20__};
  2386. }
  2387.  
  2388. sub quickmagnets
  2389. {
  2390.    my ( $self ) = @_;
  2391.  
  2392.    return $self->{quickmagnets__};
  2393. }
  2394.  
  2395. sub mangle
  2396. {
  2397.     my ( $self, $value ) = @_;
  2398.  
  2399.     $self->{mangle__} = $value;
  2400. }
  2401.  
  2402. # ---------------------------------------------------------------------------------------------
  2403. #
  2404. # convert_encoding
  2405. #
  2406. # Convert string from one encoding to another
  2407. #
  2408. # $string       The string to be converted
  2409. # $from         Original encoding
  2410. # $to           The encoding which the string is converted to
  2411. # $default      The default encoding that is used when $from is invalid or not defined
  2412. # @candidates   Candidate encodings for guessing
  2413. # ---------------------------------------------------------------------------------------------
  2414. sub convert_encoding
  2415. {
  2416.     my ( $string, $from, $to, $default, @candidates ) = @_;
  2417.  
  2418.     require Encode;
  2419.     require Encode::Guess;
  2420.  
  2421.     # First, guess the encoding.
  2422.  
  2423.     my $enc = Encode::Guess::guess_encoding( $string, @candidates );
  2424.  
  2425.     if(ref $enc){
  2426.        $from= $enc->name;
  2427.     } else {
  2428.  
  2429.         # If guess does not work, check whether $from is valid.
  2430.  
  2431.         if (!(Encode::resolve_alias($from))) {
  2432.  
  2433.             # Use $default as $from when $from is invalid.
  2434.  
  2435.             $from = $default;
  2436.         }
  2437.     }
  2438.  
  2439.     unless ($from eq $to) {
  2440.         my ($orig_string) = $string;
  2441.  
  2442.         # Workaround for Encode::Unicode error bug.
  2443.         eval {
  2444.             Encode::from_to($string, $from, $to);
  2445.         };
  2446.         $string = $orig_string if ($@);
  2447.     }
  2448.     return $string;
  2449. }
  2450.  
  2451. # ---------------------------------------------------------------------------------------------
  2452. #
  2453. # parse_line_with_kakasi
  2454. #
  2455. # Parse a line with Kakasi
  2456. #
  2457. # Japanese needs to be parsed by language processing filter, "Kakasi"
  2458. # before it is passed to Bayes classifier because words are not splitted
  2459. # by spaces.
  2460. #
  2461. # $line          The line to be parsed
  2462. #
  2463. # ---------------------------------------------------------------------------------------------
  2464. sub parse_line_with_kakasi
  2465. {
  2466.     my ( $self, $line ) = @_;
  2467.  
  2468.     # This is used to parse Japanese
  2469.     require Text::Kakasi;
  2470.  
  2471.     # Split Japanese line into words using Kakasi Wakachigaki
  2472.     # mode(-w is passed to Kakasi as argument). Both input and ouput
  2473.     # encoding are EUC-JP.
  2474.  
  2475.     Text::Kakasi::getopt_argv("kakasi", "-w -ieuc -oeuc");
  2476.     $line = Text::Kakasi::do_kakasi($line);
  2477.     Text::Kakasi::close_kanwadict();
  2478.  
  2479.     return $line;
  2480. }
  2481.  
  2482.  
  2483. 1;
  2484.