[interchange-cvs] interchange - heins modified 3 files
interchange-cvs at icdevgroup.org
interchange-cvs at icdevgroup.org
Mon Jul 7 02:49:00 EDT 2003
User: heins
Date: 2003-07-07 05:49:33 GMT
Modified: lib/Vend Config.pm Scan.pm Search.pm
Log:
* Add Altavista-style search operator with Text::Query (CPAN) module.
Calls Text::Query::*AdvancedString with op=aq, calls
Text::Query::*SimpleString with op=tq.
Examples:
[loop search="
se=hammer -framing
sf=description
fi=products
st=db
co=yes
rf=*
op=tq
"]
[loop-code] [loop-param description]<br>
[/loop]
[loop search="
se=hammer NEAR framing
sf=description
fi=products
st=db
co=yes
rf=*
op=aq
"]
[loop-code] [loop-param description]<br>
[/loop]
Honors mv_case (-case option), mv_all_chars (-regexp option),
mv_substring_match (-whole option) and mv_exact_match
(-litspace option).
* Add ability to map in custom search routines. In interchange.cfg:
CodeDef find_hammer SearchOp find_hammer
CodeDef find_hammer Routine <<EOR
sub {
my($self, $i, $string, $opname);
#::logDebug("Calling fake SearchOp");
return sub {
#::logDebug("testing with fake SearchOp");
my $string = shift;
$string =~ /hammer/i;
};
}
EOR
Now you can do:
[loop search="
se=hammer NOT framing
sf=description
fi=products
st=db
co=yes
rf=*
op=find_hammer
"]
[loop-code] [loop-param description]<br>
[/loop]
The passed parameters are:
- The search object ($self)
- The index into coordinated search array ($i)
- The pattern to match
- The name of the op (find_hammer in this case)
Must return a sub which receives the data to match and returns
1 if it matches. DOES NOT HONOR mv_negate UNLESS you tell it to.
See Vend::Search::create_text_query for an example of how to
return a proper routine and look in search object for the
associated params.
Revision Changes Path
2.120 +5 -2 interchange/lib/Vend/Config.pm
rev 2.120, prev_rev 2.119
Index: Config.pm
===================================================================
RCS file: /var/cvs/interchange/lib/Vend/Config.pm,v
retrieving revision 2.119
retrieving revision 2.120
diff -u -r2.119 -r2.120
--- Config.pm 25 Jun 2003 16:38:17 -0000 2.119
+++ Config.pm 7 Jul 2003 05:49:33 -0000 2.120
@@ -1,6 +1,6 @@
# Vend::Config - Configure Interchange
#
-# $Id: Config.pm,v 2.119 2003/06/25 16:38:17 mheins Exp $
+# $Id: Config.pm,v 2.120 2003/07/07 05:49:33 mheins Exp $
#
# Copyright (C) 2002-2003 Interchange Development Group
# Copyright (C) 1996-2002 Red Hat, Inc.
@@ -48,7 +48,7 @@
use Vend::File;
use Vend::Data;
-$VERSION = substr(q$Revision: 2.119 $, 10);
+$VERSION = substr(q$Revision: 2.120 $, 10);
my %CDname;
my %CPname;
@@ -1187,6 +1187,7 @@
oc OrderCheck
ut UserTag
fi Filter
+ so SearchOp
fw Widget
lc LocaleChange
tag UserTag
@@ -3612,6 +3613,7 @@
arraycode ArrayCode
hashcode HashCode
coretag CoreTag
+ searchop SearchOp
filter Filter
formaction FormAction
ordercheck OrderCheck
@@ -3676,6 +3678,7 @@
usertag UserTag
hashcode HashCode
arraycode ArrayCode
+ searchop SearchOp
widget Widget
/;
2.23 +3 -2 interchange/lib/Vend/Scan.pm
rev 2.23, prev_rev 2.22
Index: Scan.pm
===================================================================
RCS file: /var/cvs/interchange/lib/Vend/Scan.pm,v
retrieving revision 2.22
retrieving revision 2.23
diff -u -r2.22 -r2.23
--- Scan.pm 6 Jul 2003 17:06:10 -0000 2.22
+++ Scan.pm 7 Jul 2003 05:49:33 -0000 2.23
@@ -1,6 +1,6 @@
# Vend::Scan - Prepare searches for Interchange
#
-# $Id: Scan.pm,v 2.22 2003/07/06 17:06:10 mheins Exp $
+# $Id: Scan.pm,v 2.23 2003/07/07 05:49:33 mheins Exp $
#
# Copyright (C) 2002-2003 Interchange Development Group
# Copyright (C) 1996-2002 Red Hat, Inc.
@@ -30,7 +30,7 @@
perform_search
);
-$VERSION = substr(q$Revision: 2.22 $, 10);
+$VERSION = substr(q$Revision: 2.23 $, 10);
use strict;
use Vend::Util;
@@ -131,6 +131,7 @@
er mv_spelling_errors
ff mv_field_file
fi mv_search_file
+ ft mv_field_title
fm mv_first_match
fn mv_field_names
hs mv_head_skip
2.20 +118 -33 interchange/lib/Vend/Search.pm
rev 2.20, prev_rev 2.19
Index: Search.pm
===================================================================
RCS file: /var/cvs/interchange/lib/Vend/Search.pm,v
retrieving revision 2.19
retrieving revision 2.20
diff -u -r2.19 -r2.20
--- Search.pm 6 Jul 2003 17:06:10 -0000 2.19
+++ Search.pm 7 Jul 2003 05:49:33 -0000 2.20
@@ -1,6 +1,6 @@
# Vend::Search - Base class for search engines
#
-# $Id: Search.pm,v 2.19 2003/07/06 17:06:10 mheins Exp $
+# $Id: Search.pm,v 2.20 2003/07/07 05:49:33 mheins Exp $
#
# Copyright (C) 2002-2003 Interchange Development Group
# Copyright (C) 1996-2002 Red Hat, Inc.
@@ -22,7 +22,7 @@
package Vend::Search;
-$VERSION = substr(q$Revision: 2.19 $, 10);
+$VERSION = substr(q$Revision: 2.20 $, 10);
use strict;
use vars qw($VERSION);
@@ -478,6 +478,67 @@
return $return_sub;
}
+my $TextQuery;
+
+BEGIN {
+ eval {
+ require Text::Query;
+ import Text::Query;
+ $TextQuery = 1;
+ };
+}
+
+sub create_text_query {
+ my ($s, $i, $string, $op) = @_;
+
+ if(! $TextQuery) {
+ die ::errmsg("No Text::Query module installed, cannot use op=%s", $op);
+ }
+
+ $s ||= {};
+ $op ||= 'sq';
+ my $q;
+#::logDebug("query creation called, op=$op");
+
+ my $cs = ref ($s->{mv_case})
+ ? $s->{mv_case}[$i]
+ : $s->{mv_case};
+ my $ac = ref ($s->{mv_all_chars})
+ ? $s->{mv_all_chars}[$i]
+ : $s->{mv_all_chars};
+ my $su = ref ($s->{mv_substring_match})
+ ? $s->{mv_substring_match}[$i]
+ : $s->{mv_substring_match};
+
+#::logDebug("query creation called, op=$op cs=$cs ac=$ac");
+ if($op eq 'aq') {
+ $q = new Text::Query($string,
+ -parse => 'Text::Query::ParseAdvanced',
+ -solve => 'Text::Query::SolveAdvancedString',
+ -build => 'Text::Query::BuildAdvancedString',
+ );
+ }
+ else {
+ $q = new Text::Query($string,
+ -parse => 'Text::Query::ParseSimple',
+ -solve => 'Text::Query::SolveSimpleString',
+ -build => 'Text::Query::BuildSimpleString',
+ );
+ }
+ $q->prepare($string,
+ -litspace => $s->{mv_exact_match},
+ -case => $cs,
+ -regexp => ! $ac,
+ -whole => ! $su,
+ );
+#::logDebug("query object called, is: " . ::uneval($q));
+ return sub {
+ my $str = shift;
+#::logDebug("query routine called string=$str");
+ $q->matchscalar($str);
+ };
+}
+
my %numopmap = (
'!=' => [' != '],
'!~' => [' !~ m{', '}'],
@@ -523,6 +584,8 @@
'em' => [' =~ m{^', '$}i'],
'rm' => [' =~ m{', '}i'],
'rn' => [' !~ m{', '}i'],
+ 'aq' => [\&create_text_query, 'aq'],
+ 'tq' => [\&create_text_query, 'tq'],
'like' => [' =~ m{LIKE', '}i'],
'LIKE' => [' =~ m{LIKE', '}i'],
);
@@ -535,10 +598,17 @@
my $op;
for($i = 0; $i < $count; $i++) {
next unless $c->[$i];
- $c->[$i] =~ tr/ //;
+ $c->[$i] =~ tr/ \t//;
+ my $o = $c->[$i];
$c->[$i] = $s->{mv_numeric}[$i]
- ? $numopmap{$c->[$i]}
- : $stropmap{$c->[$i]};
+ ? $numopmap{$o}
+ : $stropmap{$o};
+ if(! $c->[$i]) {
+ my $r;
+ $c->[$i] = [$r, $o], next
+ if $r = $Global::CodeDef->{SearchOp}
+ and $r = $r->{Routine}{$o};
+ }
}
@{$s->{mv_column_op}};
}
@@ -691,7 +761,28 @@
for($i = 0; $i < $field_count; $i++) {
undef $candidate, undef $f
if $begin[$i] or $s->{mv_orsearch}[$i];
- if($ops[$i]) {
+ my $subfrag;
+ if(! $ops[$i]) {
+ $start = '=~ m{';
+ $start .= '^' if $begin[$i];
+ if($bounds[$i]) {
+ $term = '}';
+ }
+ else {
+ $term = '\b}';
+ $start .= '\b' unless $begin[$i];
+ }
+ $term .= 'i' unless $cases[$i];
+ $candidate = 1 if defined $candidate and ! $begin[$i];
+ }
+ elsif(ref($ops[$i][0]) eq 'CODE') {
+ undef $f; undef $candidate;
+ my $o = shift(@{$ops[$i]});
+ $s->{search_routines} ||= [];
+ $s->{search_routines}[$i] = $o->($s, $i, $specs[$i], @{$ops[$i]});
+ $subfrag = qq{ \$s->{search_routines}[$i]->(\$fields[$i])};
+ }
+ else {
$ops[$i][0] =~ s/m\{$/m{^/ if $begin[$i];
! $bounds[$i]
and $ops[$i][0] =~ s/=~\s+m\{$/=~ m{\\b/
@@ -705,19 +796,7 @@
and $candidate = 1;
#::logDebug("Candidate now=$candidate");
}
- else {
- $start = '=~ m{';
- $start .= '^' if $begin[$i];
- if($bounds[$i]) {
- $term = '}';
- }
- else {
- $term = '\b}';
- $start .= '\b' unless $begin[$i];
- }
- $term .= 'i' unless $cases[$i];
- $candidate = 1 if defined $candidate and ! $begin[$i];
- }
+
if ($start =~ s/LIKE$//) {
$specs[$i] =~ s/^(%)?([^%]*)(%)?$/$2/;
# Substitute if only one present
@@ -729,20 +808,26 @@
: '^' . $specs[$i];
$like = 1;
}
- }
- if ($i >= $k + $field_count) {
- undef $candidate if ! $wild_card;
-#::logDebug("triggered wild_card: $wild_card");
- $wild_card = 0;
- }
- if(defined $candidate and ! $like) {
- undef $f if $candidate;
- $f = "sub { return 1 if $negates[$i]\$_ $start$specs[$i]$term ; return 0}"
- if ! defined $f and $start =~ m'=~';
- undef $candidate if $candidate;
- }
- my $grp = $group[$i] || 0;
- my $frag = qq{$negates[$i]\$fields[$i] $start$specs[$i]$term};
+ }
+ if ($i >= $k + $field_count) {
+ undef $candidate if ! $wild_card;
+#::logDebug(triggered wild_card: $wild_card");
+ $wild_card = 0;
+ }
+ if(defined $candidate and ! $like) {
+ undef $f if $candidate;
+ $f = "sub { return 1 if $negates[$i]\$_ $start$specs[$i]$term ; return 0}"
+ if ! defined $f and $start =~ m'=~';
+ undef $candidate if $candidate;
+ }
+ my $grp = $group[$i] || 0;
+ my $frag;
+ if($subfrag) {
+ $frag = $subfrag;
+ }
+ else {
+ $frag = qq{$negates[$i]\$fields[$i] $start$specs[$i]$term};
+ }
#::logDebug("Code fragment is q!$frag!");
unless ($code[$grp]) {
$code[$grp] = [ $frag ];
More information about the interchange-cvs
mailing list