home *** CD-ROM | disk | FTP | other *** search
/ PC Open 101 / PC Open 101 CD 1.bin / CD1 / INTERNET / EMAIL / pop file / setup.exe / Classifier / WordMangle.pm < prev   
Encoding:
Perl POD Document  |  2004-06-08  |  6.3 KB  |  241 lines
  1. # POPFILE LOADABLE MODULE
  2. package Classifier::WordMangle;
  3.  
  4. use POPFile::Module;
  5. @ISA = ("POPFile::Module");
  6.  
  7. # ---------------------------------------------------------------------------------------------
  8. #
  9. # WordMangle.pm --- Mangle words for better classification
  10. #
  11. # Copyright (c) 2001-2004 John Graham-Cumming
  12. #
  13. #   This file is part of POPFile
  14. #
  15. #   POPFile is free software; you can redistribute it and/or modify
  16. #   it under the terms of the GNU General Public License as published by
  17. #   the Free Software Foundation; either version 2 of the License, or
  18. #   (at your option) any later version.
  19. #
  20. #   POPFile is distributed in the hope that it will be useful,
  21. #   but WITHOUT ANY WARRANTY; without even the implied warranty of
  22. #   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  23. #   GNU General Public License for more details.
  24. #
  25. #   You should have received a copy of the GNU General Public License
  26. #   along with POPFile; if not, write to the Free Software
  27. #   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
  28. #
  29. # ---------------------------------------------------------------------------------------------
  30.  
  31. use strict;
  32. use warnings;
  33. use locale;
  34.  
  35. # These are used for Japanese support
  36.  
  37. my $ascii = '[\x00-\x7F]'; # ASCII chars
  38. my $two_bytes_euc_jp = '(?:[\x8E\xA1-\xFE][\xA1-\xFE])'; # 2bytes EUC-JP chars
  39. my $three_bytes_euc_jp = '(?:\x8F[\xA1-\xFE][\xA1-\xFE])'; # 3bytes EUC-JP chars
  40. my $euc_jp = "(?:$ascii|$two_bytes_euc_jp|$three_bytes_euc_jp)"; # EUC-JP chars
  41.  
  42. #----------------------------------------------------------------------------
  43. # new
  44. #
  45. #   Class new() function
  46. #----------------------------------------------------------------------------
  47.  
  48. sub new
  49. {
  50.     my $type = shift;
  51.     my $self = POPFile::Module->new();
  52.  
  53.     $self->{stop__} = {};
  54.  
  55.     bless $self, $type;
  56.  
  57.     $self->name( 'wordmangle' );
  58.  
  59.     return $self;
  60. }
  61.  
  62. sub start
  63. {
  64.     my ( $self ) = @_;
  65.  
  66.     $self->load_stopwords();
  67.  
  68.     return 1;
  69. }
  70.  
  71. # ---------------------------------------------------------------------------------------------
  72. #
  73. # load_stopwords, save_stopwords - load and save the stop word list in the stopwords file
  74. #
  75. # ---------------------------------------------------------------------------------------------
  76. sub load_stopwords
  77. {
  78.     my ($self) = @_;
  79.  
  80.     if ( open STOPS, '<' . $self->get_user_path_( 'stopwords' ) ) {
  81.         delete $self->{stop__};
  82.         while ( <STOPS> ) {
  83.             s/[\r\n]//g;
  84.             $self->{stop__}{$_} = 1;
  85.         }
  86.  
  87.         close STOPS;
  88.     } else { 
  89.         $self->log_( 0, "Failed to open stopwords file" );
  90.     }
  91. }
  92.  
  93. sub save_stopwords
  94. {
  95.     my ($self) = @_;
  96.  
  97.     if ( open STOPS, '>' . $self->get_user_path_( 'stopwords' ) ) {
  98.         for my $word (keys %{$self->{stop__}}) {
  99.             print STOPS "$word\n";
  100.         }
  101.  
  102.         close STOPS;
  103.     }
  104. }
  105.  
  106. # ---------------------------------------------------------------------------------------------
  107. #
  108. # mangle
  109. #
  110. # Mangles a word into either the empty string to indicate that the word should be ignored
  111. # or the canonical form
  112. #
  113. # $word         The word to either mangle into a nice form, or return empty string if this word
  114. #               is to be ignored
  115. # $allow_colon  Set to any value allows : inside a word, this is used when mangle is used
  116. #               while loading the corpus in Bayes.pm but is not used anywhere else, the colon
  117. #               is used as a separator to indicate special words found in certain lines
  118. #               of the mail header
  119. #
  120. # $ignore_stops If defined ignores the stop word list
  121. #
  122. # ---------------------------------------------------------------------------------------------
  123. sub mangle
  124. {
  125.     my ($self, $word, $allow_colon, $ignore_stops) = @_;
  126.  
  127.     # All words are treated as lowercase
  128.  
  129.     my $lcword = lc($word);
  130.  
  131.     # Stop words are ignored
  132.  
  133.     return '' if ( ( ( $self->{stop__}{$lcword} ) ||   # PROFILE BLOCK START
  134.                      ( $self->{stop__}{$word} ) ) &&
  135.                    ( !defined( $ignore_stops ) ) );    # PROFILE BLOCK STOP
  136.  
  137.     # Remove characters that would mess up a Perl regexp and replace with .
  138.  
  139.     $lcword =~ s/(\+|\/|\?|\*|\||\(|\)|\[|\]|\{|\}|\^|\$|\.|\\)/\./g;
  140.  
  141.     # Long words are ignored also
  142.  
  143.     return '' if ( length($lcword) > 45 );
  144.  
  145.     # Ditch long hex numbers
  146.  
  147.     return '' if ( $lcword =~ /^[A-F0-9]{8,}$/i );
  148.  
  149.     # Colons are forbidden inside words, we should never get passed a word
  150.     # with a colon in it here, but if we do then we strip the colon.  The colon
  151.     # is used as a separator between a special identifier and a word, see MailParse.pm
  152.     # for more details
  153.  
  154.     $lcword =~ s/://g if ( !defined( $allow_colon ) );
  155.  
  156.     return ($lcword =~ /:/ )?$word:$lcword;
  157. }
  158.  
  159. # ---------------------------------------------------------------------------------------------
  160. #
  161. # add_stopword, remove_stopword
  162. #
  163. # Adds or removes a stop word
  164. #
  165. # $stopword    The word to add or remove
  166. # $lang        The current language
  167. #
  168. # Returns 1 if successful, or 0 for a bad stop word
  169. # ---------------------------------------------------------------------------------------------
  170.  
  171. sub add_stopword
  172. {
  173.     my ( $self, $stopword, $lang ) = @_;
  174.  
  175.     # In Japanese mode, reject non EUC Japanese characters.
  176.  
  177.     if ( $lang eq 'Nihongo') {
  178.         if ( $stopword !~ /$euc_jp/i ) {
  179.             return 0;
  180.         }
  181.     } else {
  182.         if ( ( $stopword !~ /:/ ) && ( $stopword =~ /[^[:alpha:]\-_\.\@0-9]/i ) ) {
  183.             return 0;
  184.         }
  185.     }
  186.  
  187.     $stopword = $self->mangle( $stopword, 1, 1 );
  188.  
  189.     if ( $stopword ne '' ) {
  190.         $self->{stop__}{$stopword} = 1;
  191.         $self->save_stopwords();
  192.  
  193.        return 1;
  194.     }
  195.  
  196.     return 0;
  197. }
  198.  
  199. sub remove_stopword
  200. {
  201.     my ( $self, $stopword, $lang ) = @_;
  202.  
  203.     # In Japanese mode, reject non EUC Japanese characters.
  204.  
  205.     if ( $lang eq 'Nihongo') {
  206.         if ( $stopword !~ /$euc_jp/i ) {
  207.             return 0;
  208.         }
  209.     } else {
  210.         if ( ( $stopword !~ /:/ ) && ( $stopword =~ /[^[:alpha:]\-_\.\@0-9]/i ) ) {
  211.             return 0;
  212.         }
  213.     }
  214.  
  215.     $stopword = $self->mangle( $stopword, 1, 1 );
  216.  
  217.     if ( $stopword ne '' ) {
  218.         delete $self->{stop__}{$stopword};
  219.         $self->save_stopwords();
  220.  
  221.         return 1;
  222.     }
  223.  
  224.     return 0;
  225. }
  226.  
  227. # GETTER/SETTERS
  228.  
  229. sub stopwords
  230. {
  231.     my ( $self, $value ) = @_;
  232.  
  233.     if ( defined( $value ) ) {
  234.         %{$self->{stop__}} = %{$value};
  235.     }
  236.  
  237.     return keys %{$self->{stop__}};
  238. }
  239.  
  240. 1;
  241.