lib/Search/Estraier.pm

package Search::Estraier;

use 5.008;
use strict;
use warnings;

our $VERSION = '0.00';

=head1 NAME

Search::Estraier - pure perl module to use Hyper Estraier search engine

=head1 SYNOPSIS

  use Search::Estraier;
  my $est = new Search::Estraier();

=head1 DESCRIPTION

This module is implementation of node API of Hyper Estraier. Since it's
perl-only module with dependencies only on standard perl modules, it will
run on all platforms on which perl runs. It doesn't require compilation
or Hyper Estraier development files on target machine.

It is implemented as multiple packages which closly resamble Ruby
implementation. It also includes methods to manage nodes.

=cut

=head2 _s

Remove multiple whitespaces from string, as well as whitespaces at beginning or end

 my $text = $self->_s(" this  is a text  ");
 $text = 'this is a text';

=cut

sub _s {
        my $text = $_[1] || return;
        $text =~ s/\s\s+/ /gs;
        $text =~ s/^\s+//;
        $text =~ s/\s+$//;
        return $text;
}

package Search::Estraier::Document;

use Carp qw/croak confess/;

use Search::Estraier;
our @ISA = qw/Search::Estraier/;

=head1 Search::Estraier::Document

This class implements Document which is collection of attributes
(key=value), vectors (also key value) display text and hidden text.

=head2 new

Create new document, empty or from draft.

  my $doc = new Search::HyperEstraier::Document;
  my $doc2 = new Search::HyperEstraier::Document( $draft );

=cut

sub new {
        my $class = shift;
        my $self = {};
        bless($self, $class);

        $self->{id} = -1;

        my $draft = shift;

        if ($draft) {
                my $in_text = 0;
                foreach my $line (split(/\n/, $draft)) {

                        if ($in_text) {
                                if ($line =~ /^\t/) {
                                        push @{ $self->{htexts} }, substr($line, 1);
                                } else {
                                        push @{ $self->{dtexts} }, $line;
                                }
                                next;
                        }

                        if ($line =~ m/^%VECTOR\t(.+)$/) {
                                my @fields = split(/\t/, $1);
                                for my $i ( 0 .. ($#fields - 1) ) {
                                        $self->{kwords}->{ $fields[ $i ] } = $fields[ $i + 1 ];
                                        $i++;
                                }
                                next;
                        } elsif ($line =~ m/^%/) {
                                # What is this? comment?
                                #warn "$line\n";
                                next;
                        } elsif ($line =~ m/^$/) {
                                $in_text = 1;
                                next;
                        } elsif ($line =~ m/^(.+)=(.+)$/) {
                                $self->{attrs}->{ $1 } = $2;
                                next;
                        }

                        warn "draft ignored: $line\n";
                }
        }

        $self ? return $self : return undef;
}


=head2 add_attr

Add an attribute.

  $doc->add_attr( name => 'value' );

Delete attribute using

  $doc->add_attr( name => undef );

=cut

sub add_attr {
        my $self = shift;
        my $attrs = {@_};

        while (my ($name, $value) = each %{ $attrs }) {
                if (! defined($value)) {
                        delete( $self->{attrs}->{ $self->_s($name) } );
                } else {
                        $self->{attrs}->{ $self->_s($name) } = $self->_s($value);
                }
        }

        return 1;
}


=head2 add_text

Add a sentence of text.

  $doc->add_text('this is example text to display');

=cut

sub add_text {
        my $self = shift;
        my $text = shift;
        return unless defined($text);

        push @{ $self->{dtexts} }, $self->_s($text);
}


=head2 add_hidden_text

Add a hidden sentence.

  $doc->add_hidden_text('this is example text just for search');

=cut

sub add_hidden_text {
        my $self = shift;
        my $text = shift;
        return unless defined($text);

        push @{ $self->{htexts} }, $self->_s($text);
}

=head2 id

Get the ID number of document. If the object has never been registred, C<-1> is returned.

  print $doc->id;

=cut

sub id {
        my $self = shift;
        return $self->{id};
}

=head2 attr_names

Returns array with attribute names from document object.

  my @attrs = $doc->attr_names;

=cut

sub attr_names {
        my $self = shift;
        croak "attr_names return array, not scalar" if (! wantarray);
        return sort keys %{ $self->{attrs} };
}


=head2 attr

Returns value of an attribute.

  my $value = $doc->attr( 'attribute' );

=cut

sub attr {
        my $self = shift;
        my $name = shift;

        return $self->{'attrs'}->{ $name };
}


=head2 texts

Returns array with text sentences.

  my @texts = $doc->texts;

=cut

sub texts {
        my $self = shift;
        confess "texts return array, not scalar" if (! wantarray);
        return @{ $self->{dtexts} };
}

=head2 cat_texts

Return whole text as single scalar.

 my $text = $doc->cat_texts;

=cut

sub cat_texts {
        my $self = shift;
        return join(' ',@{ $self->{dtexts} });
}

=head2 dump_draft

Dump draft data from document object.

  print $doc->dump_draft;

=cut

sub dump_draft {
        my $self = shift;
        my $draft;

        foreach my $attr_name (sort keys %{ $self->{attrs} }) {
                $draft .= $attr_name . '=' . $self->{attrs}->{$attr_name} . "\n";
        }

        if ($self->{kwords}) {
                $draft .= '%%VECTOR';
                while (my ($key, $value) = each %{ $self->{kwords} }) {
                        $draft .= "\t$key\t$value";
                }
                $draft .= "\n";
        }

        $draft .= "\n";

        $draft .= join("\n", @{ $self->{dtexts} }) . "\n";
        $draft .= "\t" . join("\n\t", @{ $self->{htexts} }) . "\n";

        return $draft;
}

=head2 delete

Empty document object

  $doc->delete;

This function is addition to original Ruby API, and since it was included in C wrappers it's here as a
convinience. Document objects which go out of scope will be destroyed
automatically.

=cut

sub delete {
        my $self = shift;

        foreach my $data (qw/attrs dtexts stexts kwords/) {
                delete($self->{$data});
        }

        $self->{id} = -1;

        return 1;
}


package Search::Estraier::Condition;

use Carp qw/confess croak/;

use Search::Estraier;
our @ISA = qw/Search::Estraier/;

=head1 Search::Estraier::Condition

=head2 new

  my $cond = new Search::HyperEstraier::Condition;

=cut

sub new {
        my $class = shift;
        my $self = {};
        bless($self, $class);

        $self ? return $self : return undef;
}

=head2 set_phrase

  $cond->set_phrase('search phrase');

=cut

sub set_phrase {
        my $self = shift;
        $self->{phrase} = $self->_s( shift );
}

=head2 add_attr

  $cond->add_attr('@URI STRINC /~dpavlin/');

=cut

sub add_attr {
        my $self = shift;
        my $attr = shift || return;
        push @{ $self->{attrs} }, $self->_s( $attr );
}

=head2 set_order

  $cond->set_order('@mdate NUMD');

=cut

sub set_order {
        my $self = shift;
        $self->{order} = shift;
}

=head2 set_max

  $cond->set_max(42);

=cut

sub set_max {
        my $self = shift;
        my $max = shift;
        croak "set_max needs number" unless ($max =~ m/^\d+$/);
        $self->{max} = $max;
}

=head2 set_options

  $cond->set_options( SURE => 1 );

=cut

my $options = {
        # check N-gram keys skipping by three
        SURE => 1 << 0,
        # check N-gram keys skipping by two
        USUAL => 1 << 1,
        # without TF-IDF tuning
        FAST => 1 << 2,
        # with the simplified phrase
        AGITO => 1 << 3,
        # check every N-gram key
        NOIDF => 1 << 4,
        # check N-gram keys skipping by one
        SIMPLE => 1 << 10,
};

sub set_options {
        my $self = shift;
        my $option = shift;
        confess "unknown option" unless ($options->{$option});
        $self->{options} ||= $options->{$option};
}

=head2 phrase

Return search phrase.

  print $cond->phrase;

=cut

sub phrase {
        my $self = shift;
        return $self->{phrase};
}


package Search::Estraier::Master;

use Carp;

=head1 Search::Estraier::Master

Controll node master. This requires user with administration priviledges.

=cut

{
        package RequestAgent;
        our @ISA = qw(LWP::UserAgent);

        sub new { 
                my $self = LWP::UserAgent::new(@_);
                $self->agent("Search-Estraier/$Search::Estraer::VERSION");
                $self;
        }

        sub get_basic_credentials {
                my($self, $realm, $uri) = @_;
#               return ($user, $password);
        }
}


=head2 new

Create new connection to node master.

  my $master = new Search::Estraier::Master(
        url => 'http://localhost:1978',
        user => 'admin',
        passwd => 'admin',
  );

=cut

sub new {
        my $class = shift;
        my $self = {@_};
        bless($self, $class);

        foreach my $p (qw/url user passwd/) {
                croak "need $p" unless ($self->{$p});
        }

        $self ? return $self : return undef;
}


###

=head1 EXPORT

Nothing.

=head1 SEE ALSO

L<http://hyperestraier.sourceforge.net/>

Hyper Estraier Ruby interface on which this module is based.

=head1 AUTHOR

Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>


=head1 COPYRIGHT AND LICENSE

Copyright (C) 2005-2006 by Dobrica Pavlinusic

This library is free software; you can redistribute it and/or modify
it under the GPL v2 or later.

=cut

1;
1	package Search::Estraier;
2
3	use 5.008;
4	use strict;
5	use warnings;
6
7	our $VERSION = '0.00';
8
9	=head1 NAME
10
11	Search::Estraier - pure perl module to use Hyper Estraier search engine
12
13	=head1 SYNOPSIS
14
15	use Search::Estraier;
16	my $est = new Search::Estraier();
17
18	=head1 DESCRIPTION
19
20	This module is implementation of node API of Hyper Estraier. Since it's
21	perl-only module with dependencies only on standard perl modules, it will
22	run on all platforms on which perl runs. It doesn't require compilation
23	or Hyper Estraier development files on target machine.
24
25	It is implemented as multiple packages which closly resamble Ruby
26	implementation. It also includes methods to manage nodes.
27
28	=cut
29
30	=head2 _s
31
32	Remove multiple whitespaces from string, as well as whitespaces at beginning or end
33
34	my $text = $self->_s(" this is a text ");
35	$text = 'this is a text';
36
37	=cut
38
39	sub _s {
40	my $text = $_[1] \|\| return;
41	$text =~ s/\s\s+/ /gs;
42	$text =~ s/^\s+//;
43	$text =~ s/\s+$//;
44	return $text;
45	}
46
47	package Search::Estraier::Document;
48
49	use Carp qw/croak confess/;
50
51	use Search::Estraier;
52	our @ISA = qw/Search::Estraier/;
53
54	=head1 Search::Estraier::Document
55
56	This class implements Document which is collection of attributes
57	(key=value), vectors (also key value) display text and hidden text.
58
59	=head2 new
60
61	Create new document, empty or from draft.
62
63	my $doc = new Search::HyperEstraier::Document;
64	my $doc2 = new Search::HyperEstraier::Document( $draft );
65
66	=cut
67
68	sub new {
69	my $class = shift;
70	my $self = {};
71	bless($self, $class);
72
73	$self->{id} = -1;
74
75	my $draft = shift;
76
77	if ($draft) {
78	my $in_text = 0;
79	foreach my $line (split(/\n/, $draft)) {
80
81	if ($in_text) {
82	if ($line =~ /^\t/) {
83	push @{ $self->{htexts} }, substr($line, 1);
84	} else {
85	push @{ $self->{dtexts} }, $line;
86	}
87	next;
88	}
89
90	if ($line =~ m/^%VECTOR\t(.+)$/) {
91	my @fields = split(/\t/, $1);
92	for my $i ( 0 .. ($#fields - 1) ) {
93	$self->{kwords}->{ $fields[ $i ] } = $fields[ $i + 1 ];
94	$i++;
95	}
96	next;
97	} elsif ($line =~ m/^%/) {
98	# What is this? comment?
99	#warn "$line\n";
100	next;
101	} elsif ($line =~ m/^$/) {
102	$in_text = 1;
103	next;
104	} elsif ($line =~ m/^(.+)=(.+)$/) {
105	$self->{attrs}->{ $1 } = $2;
106	next;
107	}
108
109	warn "draft ignored: $line\n";
110	}
111	}
112
113	$self ? return $self : return undef;
114	}
115
116
117	=head2 add_attr
118
119	Add an attribute.
120
121	$doc->add_attr( name => 'value' );
122
123	Delete attribute using
124
125	$doc->add_attr( name => undef );
126
127	=cut
128
129	sub add_attr {
130	my $self = shift;
131	my $attrs = {@_};
132
133	while (my ($name, $value) = each %{ $attrs }) {
134	if (! defined($value)) {
135	delete( $self->{attrs}->{ $self->_s($name) } );
136	} else {
137	$self->{attrs}->{ $self->_s($name) } = $self->_s($value);
138	}
139	}
140
141	return 1;
142	}
143
144
145	=head2 add_text
146
147	Add a sentence of text.
148
149	$doc->add_text('this is example text to display');
150
151	=cut
152
153	sub add_text {
154	my $self = shift;
155	my $text = shift;
156	return unless defined($text);
157
158	push @{ $self->{dtexts} }, $self->_s($text);
159	}
160
161
162	=head2 add_hidden_text
163
164	Add a hidden sentence.
165
166	$doc->add_hidden_text('this is example text just for search');
167
168	=cut
169
170	sub add_hidden_text {
171	my $self = shift;
172	my $text = shift;
173	return unless defined($text);
174
175	push @{ $self->{htexts} }, $self->_s($text);
176	}
177
178	=head2 id
179
180	Get the ID number of document. If the object has never been registred, C<-1> is returned.
181
182	print $doc->id;
183
184	=cut
185
186	sub id {
187	my $self = shift;
188	return $self->{id};
189	}
190
191	=head2 attr_names
192
193	Returns array with attribute names from document object.
194
195	my @attrs = $doc->attr_names;
196
197	=cut
198
199	sub attr_names {
200	my $self = shift;
201	croak "attr_names return array, not scalar" if (! wantarray);
202	return sort keys %{ $self->{attrs} };
203	}
204
205
206	=head2 attr
207
208	Returns value of an attribute.
209
210	my $value = $doc->attr( 'attribute' );
211
212	=cut
213
214	sub attr {
215	my $self = shift;
216	my $name = shift;
217
218	return $self->{'attrs'}->{ $name };
219	}
220
221
222	=head2 texts
223
224	Returns array with text sentences.
225
226	my @texts = $doc->texts;
227
228	=cut
229
230	sub texts {
231	my $self = shift;
232	confess "texts return array, not scalar" if (! wantarray);
233	return @{ $self->{dtexts} };
234	}
235
236	=head2 cat_texts
237
238	Return whole text as single scalar.
239
240	my $text = $doc->cat_texts;
241
242	=cut
243
244	sub cat_texts {
245	my $self = shift;
246	return join(' ',@{ $self->{dtexts} });
247	}
248
249	=head2 dump_draft
250
251	Dump draft data from document object.
252
253	print $doc->dump_draft;
254
255	=cut
256
257	sub dump_draft {
258	my $self = shift;
259	my $draft;
260
261	foreach my $attr_name (sort keys %{ $self->{attrs} }) {
262	$draft .= $attr_name . '=' . $self->{attrs}->{$attr_name} . "\n";
263	}
264
265	if ($self->{kwords}) {
266	$draft .= '%%VECTOR';
267	while (my ($key, $value) = each %{ $self->{kwords} }) {
268	$draft .= "\t$key\t$value";
269	}
270	$draft .= "\n";
271	}
272
273	$draft .= "\n";
274
275	$draft .= join("\n", @{ $self->{dtexts} }) . "\n";
276	$draft .= "\t" . join("\n\t", @{ $self->{htexts} }) . "\n";
277
278	return $draft;
279	}
280
281	=head2 delete
282
283	Empty document object
284
285	$doc->delete;
286
287	This function is addition to original Ruby API, and since it was included in C wrappers it's here as a
288	convinience. Document objects which go out of scope will be destroyed
289	automatically.
290
291	=cut
292
293	sub delete {
294	my $self = shift;
295
296	foreach my $data (qw/attrs dtexts stexts kwords/) {
297	delete($self->{$data});
298	}
299
300	$self->{id} = -1;
301
302	return 1;
303	}
304
305
306
307	package Search::Estraier::Condition;
308
309	use Carp qw/confess croak/;
310
311	use Search::Estraier;
312	our @ISA = qw/Search::Estraier/;
313
314	=head1 Search::Estraier::Condition
315
316	=head2 new
317
318	my $cond = new Search::HyperEstraier::Condition;
319
320	=cut
321
322	sub new {
323	my $class = shift;
324	my $self = {};
325	bless($self, $class);
326
327	$self ? return $self : return undef;
328	}
329
330	=head2 set_phrase
331
332	$cond->set_phrase('search phrase');
333
334	=cut
335
336	sub set_phrase {
337	my $self = shift;
338	$self->{phrase} = $self->_s( shift );
339	}
340
341	=head2 add_attr
342
343	$cond->add_attr('@URI STRINC /~dpavlin/');
344
345	=cut
346
347	sub add_attr {
348	my $self = shift;
349	my $attr = shift \|\| return;
350	push @{ $self->{attrs} }, $self->_s( $attr );
351	}
352
353	=head2 set_order
354
355	$cond->set_order('@mdate NUMD');
356
357	=cut
358
359	sub set_order {
360	my $self = shift;
361	$self->{order} = shift;
362	}
363
364	=head2 set_max
365
366	$cond->set_max(42);
367
368	=cut
369
370	sub set_max {
371	my $self = shift;
372	my $max = shift;
373	croak "set_max needs number" unless ($max =~ m/^\d+$/);
374	$self->{max} = $max;
375	}
376
377	=head2 set_options
378
379	$cond->set_options( SURE => 1 );
380
381	=cut
382
383	my $options = {
384	# check N-gram keys skipping by three
385	SURE => 1 << 0,
386	# check N-gram keys skipping by two
387	USUAL => 1 << 1,
388	# without TF-IDF tuning
389	FAST => 1 << 2,
390	# with the simplified phrase
391	AGITO => 1 << 3,
392	# check every N-gram key
393	NOIDF => 1 << 4,
394	# check N-gram keys skipping by one
395	SIMPLE => 1 << 10,
396	};
397
398	sub set_options {
399	my $self = shift;
400	my $option = shift;
401	confess "unknown option" unless ($options->{$option});
402	$self->{options} \|\|= $options->{$option};
403	}
404
405	=head2 phrase
406
407	Return search phrase.
408
409	print $cond->phrase;
410
411	=cut
412
413	sub phrase {
414	my $self = shift;
415	return $self->{phrase};
416	}
417
418
419	package Search::Estraier::Master;
420
421	use Carp;
422
423	=head1 Search::Estraier::Master
424
425	Controll node master. This requires user with administration priviledges.
426
427	=cut
428
429	{
430	package RequestAgent;
431	our @ISA = qw(LWP::UserAgent);
432
433	sub new {
434	my $self = LWP::UserAgent::new(@_);
435	$self->agent("Search-Estraier/$Search::Estraer::VERSION");
436	$self;
437	}
438
439	sub get_basic_credentials {
440	my($self, $realm, $uri) = @_;
441	# return ($user, $password);
442	}
443	}
444
445
446
447	=head2 new
448
449	Create new connection to node master.
450
451	my $master = new Search::Estraier::Master(
452	url => 'http://localhost:1978',
453	user => 'admin',
454	passwd => 'admin',
455	);
456
457	=cut
458
459	sub new {
460	my $class = shift;
461	my $self = {@_};
462	bless($self, $class);
463
464	foreach my $p (qw/url user passwd/) {
465	croak "need $p" unless ($self->{$p});
466	}
467
468	$self ? return $self : return undef;
469	}
470
471
472
473	###
474
475	=head1 EXPORT
476
477	Nothing.
478
479	=head1 SEE ALSO
480
481	L<http://hyperestraier.sourceforge.net/>
482
483	Hyper Estraier Ruby interface on which this module is based.
484
485	=head1 AUTHOR
486
487	Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>
488
489
490	=head1 COPYRIGHT AND LICENSE
491
492	Copyright (C) 2005-2006 by Dobrica Pavlinusic
493
494	This library is free software; you can redistribute it and/or modify
495	it under the GPL v2 or later.
496
497	=cut
498
499	1;