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