/[Lingua-Spelling-Alternative]/Alternative.pm
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Annotation of /Alternative.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (hide annotations)
Mon Feb 11 14:26:22 2002 UTC (22 years, 1 month ago) by dpavlin
Branch: MAIN
perl module

1 dpavlin 1.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

  ViewVC Help
Powered by ViewVC 1.1.26