| 1 |
# Documentation and Copyright exist after __END__ |
| 2 |
|
| 3 |
package Lingua::Spelling::Alternative; |
| 4 |
require 5.001; |
| 5 |
|
| 6 |
use strict; |
| 7 |
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); |
| 8 |
|
| 9 |
use Exporter; |
| 10 |
$VERSION = '0.01'; |
| 11 |
@ISA = ('Exporter'); |
| 12 |
|
| 13 |
#@EXPORT = qw(); |
| 14 |
@EXPORT_OK = qw( |
| 15 |
&alternatives |
| 16 |
&load_affix |
| 17 |
); |
| 18 |
|
| 19 |
#my @affix_regexp; |
| 20 |
#my @affix_add; |
| 21 |
#my @affix_sub; |
| 22 |
|
| 23 |
my $debug=1; |
| 24 |
|
| 25 |
# stub |
| 26 |
|
| 27 |
sub new { |
| 28 |
my $class = shift; |
| 29 |
my $self = {}; |
| 30 |
bless($self, $class); |
| 31 |
$self->{ARGS} = {@_}; |
| 32 |
$self ? return $self : return undef; |
| 33 |
} |
| 34 |
|
| 35 |
|
| 36 |
# |
| 37 |
# load affix file in internal structures |
| 38 |
# |
| 39 |
|
| 40 |
sub load_affix { |
| 41 |
my $self = shift; |
| 42 |
my $filename = shift; |
| 43 |
|
| 44 |
my $suffixes=0; |
| 45 |
|
| 46 |
my ($regexp,$add,$sub); |
| 47 |
|
| 48 |
print STDERR "reading affix file $filename\n" if ($debug); |
| 49 |
|
| 50 |
open (A,$filename) || die "Can't open affix file $filename: $!"; |
| 51 |
while(<A>) { |
| 52 |
chomp; |
| 53 |
next if (/^#|^[\s\t\n\r]*$/); |
| 54 |
|
| 55 |
if (/^suffixes/i) { |
| 56 |
$suffixes++; |
| 57 |
next; |
| 58 |
} |
| 59 |
|
| 60 |
next if (! $suffixes); |
| 61 |
|
| 62 |
if (/^flag[\s\t]+\*{0,1}(.):/i) { |
| 63 |
undef $regexp; |
| 64 |
undef $add; |
| 65 |
undef $sub; |
| 66 |
next; |
| 67 |
} |
| 68 |
|
| 69 |
if (/^[\s\t]*([^>#]+)>[\s\t]+-([^\,\s\t]+),([^\s\t]+)/) { |
| 70 |
$regexp = $1; |
| 71 |
$add = $2; |
| 72 |
$sub = $3 if ($3 ne "-"); |
| 73 |
} elsif (/^[\s\t]*([^>#]+)>[\s\t]+([^\s\t\#]+)/) { |
| 74 |
$regexp = $1; |
| 75 |
$sub = $2; |
| 76 |
} |
| 77 |
|
| 78 |
sub nuke_s { |
| 79 |
my $tmp = $_[0]; |
| 80 |
return if (!$tmp); |
| 81 |
$tmp=~s/^ *//g; |
| 82 |
$tmp=~s/ *$//g; |
| 83 |
$tmp=~s/ *//g; |
| 84 |
return $tmp; |
| 85 |
} |
| 86 |
|
| 87 |
push @{$self->{affix_regexp}},nuke_s($regexp); |
| 88 |
push @{$self->{affix_add}},nuke_s($add); |
| 89 |
push @{$self->{affix_sub}},nuke_s($sub); |
| 90 |
} |
| 91 |
return 1; |
| 92 |
} |
| 93 |
|
| 94 |
# |
| 95 |
# function which returns original word and all alternatives |
| 96 |
# |
| 97 |
|
| 98 |
sub alternatives { |
| 99 |
my $self = shift; |
| 100 |
my @out; |
| 101 |
foreach my $word (@_) { |
| 102 |
push @out,$word; # save original word |
| 103 |
next if (length($word) < 3); # cludge: preskoci kratke |
| 104 |
for(my $i=0; $i<=$#{$self->{affix_regexp}}; $i++) { |
| 105 |
my $regexp = $self->{affix_regexp}[$i]; |
| 106 |
my $add = $self->{affix_add}[$i]; |
| 107 |
my $sub = $self->{affix_sub}[$i]; |
| 108 |
next if length($word) < length($sub); |
| 109 |
my $tmp_word = $word; |
| 110 |
if ($sub) { |
| 111 |
next if ($word !~ m/$sub$/i); |
| 112 |
if ($add) { |
| 113 |
$tmp_word =~ s/$sub$/$add/i; |
| 114 |
} else { |
| 115 |
$tmp_word =~ s/$sub$//i; |
| 116 |
} |
| 117 |
} else { |
| 118 |
$tmp_word = $word.$add; |
| 119 |
} |
| 120 |
if ($tmp_word =~ m/$regexp/ix) { |
| 121 |
# print "$word -> $tmp_word\t-$sub, +$add, regexp: $regexp\n"; |
| 122 |
push @out,lc($tmp_word); |
| 123 |
} |
| 124 |
} |
| 125 |
} |
| 126 |
return @out; |
| 127 |
} |
| 128 |
|
| 129 |
############################################################################### |
| 130 |
1; |
| 131 |
__END__ |
| 132 |
|
| 133 |
=head1 NAME |
| 134 |
|
| 135 |
Alternative.pm - see all alternatives of a given word in a given language |
| 136 |
|
| 137 |
=head1 SYNOPSIS |
| 138 |
|
| 139 |
use Lingua::Spelling:Alternative; |
| 140 |
|
| 141 |
my $en = new Alternative; |
| 142 |
$en->load_affix('/usr/lib/ispell/english.aff') or die $!; |
| 143 |
print $en->alternatives("cars"); |
| 144 |
|
| 145 |
=head1 DESCRIPTION |
| 146 |
|
| 147 |
This module is designed to return all valid forms of a given word |
| 148 |
(for example when you want to see all possible forms of some word |
| 149 |
entered in search engine) |
| 150 |
|
| 151 |
=head1 PUBLIC METHODS |
| 152 |
|
| 153 |
=over 4 |
| 154 |
|
| 155 |
=item new |
| 156 |
|
| 157 |
The new() constructor (without parameters) create container for new |
| 158 |
language. |
| 159 |
|
| 160 |
=item load_affix |
| 161 |
|
| 162 |
Function load_affix loads ispell's affix file. |
| 163 |
|
| 164 |
=item alternatives |
| 165 |
|
| 166 |
Function alternatives |
| 167 |
|
| 168 |
=head1 PRIVATE METHODS |
| 169 |
|
| 170 |
Documented as being not documented. |
| 171 |
|
| 172 |
=head1 EXAMPLES |
| 173 |
|
| 174 |
Please see the test.pl program in distribution which exercises some |
| 175 |
aspects of Alternative.pm. |
| 176 |
|
| 177 |
=head1 BUGS |
| 178 |
|
| 179 |
There are no known bugs. |
| 180 |
|
| 181 |
=head1 CONTACT AND COPYRIGHT |
| 182 |
|
| 183 |
Copyright 2002 Dobrica Pavlinusic (dpavlin@rot13.org). All |
| 184 |
rights reserved. This program is free software; you can redistribute |
| 185 |
it and/or modify it under the same terms as Perl itself. |
| 186 |
|
| 187 |
=cut |
Parent Directory
| 
Revision Log