/[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

Contents of /Alternative.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (show annotations)
Mon Feb 11 14:33:42 2002 UTC (22 years, 1 month ago) by dpavlin
Branch: MAIN
Changes since 1.1: +4 -1 lines
DEBUG option to new constructor

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

  ViewVC Help
Powered by ViewVC 1.1.26