/[webpac]/branches/biomed/index_DBI_filter.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 /branches/biomed/index_DBI_filter.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 697 - (hide annotations)
Sun Mar 13 02:03:30 2005 UTC (19 years ago) by dpavlin
File size: 8283 byte(s)
updated branches to head

1 dpavlin 641 #
2     # this file implements index functions using DBI
3     # and huge amounts of memory for cache speedup
4     #
5     # this version doesn't support ident (which sould be location in
6     # library). But, that functionality is not used anyway...
7     #
8    
9     package index_DBI;
10     use strict qw(vars);
11     use vars qw($Count);
12     use HTML::Entities;
13     use URI::Escape;
14     use Carp;
15     use DBI;
16 dpavlin 697 use locale;
17 dpavlin 641
18     # bench time
19     my $bench_time = time();
20    
21     my $debug = 1;
22    
23     sub bench {
24     my $self = shift;
25     my $msg = shift;
26    
27     print STDERR "last operation took ",time()-$bench_time," seconds...\n";
28     $bench_time=time();
29     print STDERR "$msg\n";
30     }
31    
32     sub new {
33     my $class = shift;
34     my $self = {};
35     bless($self, $class);
36    
37     my $dbd = shift || die "need dbi_dbd= in [global] section of configuration file";
38     my $dsn = shift || die "need dbi_dsn= in [global] section of configuration file";
39     my $user = shift || die "need dbi_user= in [global] section of configuration file";
40     my $passwd = shift || die "need dbi_passwd= in [global] section of configuration file";
41    
42     $self->{dbd} = $dbd;
43    
44     $self->{dbh} = DBI->connect("DBI:$dbd:$dsn",$user,$passwd) || die $DBI::errstr;
45     $Count++;
46    
47     $self->bench("connected to $dbd as $user");
48    
49     # force SQLite to support binary 0 in data (which shouldn't
50     # happend, but it did to me)
51     eval {
52     no warnings 'all';
53     $self->{dbh}->{sqlite_handle_binary_nulls} = 1;
54     };
55    
56     return $self;
57     }
58    
59     sub delete_and_create {
60     my $self = shift;
61    
62 dpavlin 651 my $table = shift || croak "need table name!";
63 dpavlin 641 my $sql = shift || croak "need sql to create table!";
64    
65 dpavlin 651 print STDERR "## delete_and_create($table)\n" if ($debug);
66 dpavlin 641
67 dpavlin 651 my $sql_delete = "delete from $table";
68     my $sth = $self->{dbh}->prepare($sql_delete);
69 dpavlin 641
70 dpavlin 651 if ($sth && $sth->execute()) {
71     print STDERR "## deleted rows from table $table\n" if ($debug);
72 dpavlin 642 } else {
73 dpavlin 641 # can't delete from table, assume it doesn't exists!
74     $self->{dbh}->rollback;
75     $self->{dbh}->do($sql) || confess "SQL: $sql ".$self->{dbh}->errstr();
76 dpavlin 651 print STDERR "## creating table $table\n" if ($debug);
77 dpavlin 641 $self->{dbh}->begin_work;
78     }
79     }
80    
81     sub insert {
82     my $self = shift;
83    
84     my $field = shift;
85     my $index_data = shift || print STDERR "\$index->insert($field,NULL,...)";
86     my $display = shift || $index_data;
87 dpavlin 642 my $filter = shift;
88 dpavlin 641
89     if (! $index_data) {
90     print STDERR "\$index->insert() -- no value to insert\n";
91     return;
92     }
93    
94     $index_data =~ s#&(\w)(acute|cedil|circ|grave|ring|slash|tilde|uml);#$1#gi;
95    
96     # strip spaces
97     $index_data =~ s#^\s+##;
98     $index_data =~ s#\s+$##;
99     $index_data =~ s#\s\s+# #g;
100    
101     my $uc = uc($index_data);
102    
103     if (! $self->{c}->{$uc}->{$field}) {
104     #print stderr "in index: $index_data\n";
105 dpavlin 697 $self->{c}->{$uc}->{$field}->{item} = lc($index_data);
106 dpavlin 641 $self->{c}->{$uc}->{$field}->{display} = $display;
107     }
108    
109     $self->{c}->{$uc}->{$field}->{count}++;
110 dpavlin 642 $self->{c}->{$uc}->{$field}->{filter}->{$filter}++ if ($filter);
111 dpavlin 641 }
112    
113     sub count {
114     my $self = shift;
115    
116     my $field = shift;
117     my $where = shift;
118    
119 dpavlin 643 my $filter = shift;
120 dpavlin 641
121 dpavlin 651 my $tables_sql = 'data';
122 dpavlin 643 my $where_sql = '';
123 dpavlin 697 my @sql_args = ( $field, lc($where) );
124 dpavlin 641
125 dpavlin 643 if ($filter) {
126     $tables_sql .= ",filters";
127     $where_sql .= "
128 dpavlin 651 and data.ord = filters.ord
129 dpavlin 643 and filter = ?
130     ";
131     push @sql_args, $filter;
132     }
133    
134     my $sql = qq{
135     select count(*)
136     from $tables_sql
137 dpavlin 697 where name = ? and item like ?||'%'
138 dpavlin 643 $where_sql
139     };
140    
141     my $sth = $self->{dbh}->prepare($sql) || confess $self->{dbh}->errstr();
142     $sth->execute(@sql_args) || confess "sql: $sql; ".$self->{dbh}->errstr();
143    
144 dpavlin 641 my ($total) = $sth->fetchrow_array();
145    
146     # no results, count all
147     if (! $total) {
148 dpavlin 643 my $sql = qq{
149     select count(*)
150     from $tables_sql
151 dpavlin 651 where data.name = ?
152 dpavlin 643 $where_sql
153     };
154 dpavlin 641
155 dpavlin 643 @sql_args = ( $field );
156     push @sql_args, $filter if ($filter);
157    
158     my $sth = $self->{dbh}->prepare($sql) || confess $self->{dbh}->errstr();
159     $sth->execute(@sql_args) || confess "sql: $sql; ".$self->{dbh}->errstr();
160 dpavlin 641 $total = $sth->fetchrow_array();
161    
162     }
163    
164 dpavlin 643 return $total || '0';
165 dpavlin 641 }
166    
167    
168     sub fetch {
169     my $self = shift;
170    
171     my $field = shift;
172     my $where = shift;
173    
174     my $offset = shift || 0;
175     my $rows = shift || 10;
176 dpavlin 643 my $filter = shift;
177    
178 dpavlin 641 my $from_ord = 0;
179    
180 dpavlin 651 my $tables_sql = 'data';
181 dpavlin 643 my $where_sql = '';
182 dpavlin 641
183 dpavlin 697 my @sql_args = ( $field, lc($where) );
184 dpavlin 641
185 dpavlin 643 if ($filter) {
186     $tables_sql .= ",filters";
187     $where_sql .= "
188 dpavlin 651 and data.ord = filters.ord
189 dpavlin 643 and filter = ?
190     ";
191     push @sql_args, $filter;
192     }
193    
194 dpavlin 641 if ($where) {
195 dpavlin 643 my $sql2 = qq{
196 dpavlin 651 select data.ord as ord
197 dpavlin 643 from $tables_sql
198 dpavlin 697 where name = ? and item like ?||'%'
199 dpavlin 643 $where_sql
200 dpavlin 697 order by data.ord
201 dpavlin 643 };
202     my $sth = $self->{dbh}->prepare($sql2) || confess "sql2: $sql2; ".$self->{dbh}->errstr();
203 dpavlin 641
204 dpavlin 643 $sth->execute(@sql_args) || confess "sql2: $sql2; ".$self->{dbh}->errstr();
205 dpavlin 641 if (my $row = $sth->fetchrow_hashref) {
206 dpavlin 697 $from_ord = $row->{ord} - 1;
207 dpavlin 641 } else {
208     # if no match is found when searching from beginning
209     # of word in index, try substring match anywhere
210 dpavlin 643 $sql2 = qq{
211 dpavlin 651 select data.ord as ord
212 dpavlin 643 from $tables_sql
213 dpavlin 697 where name = ? and item like '%'||?||'%'
214 dpavlin 643 $where_sql
215 dpavlin 697 order by data.ord
216 dpavlin 643 };
217    
218     $sth = $self->{dbh}->prepare($sql2) || confess "sql2: $sql2; ".$self->{dbh}->errstr();
219     $sth->execute(@sql_args) || confess "sql2: $sql2; ".$self->{dbh}->errstr();
220    
221 dpavlin 641 if (my $row = $sth->fetchrow_hashref) {
222 dpavlin 697 $from_ord = $row->{ord} - 1;
223 dpavlin 641 }
224     }
225     }
226    
227 dpavlin 643 @sql_args = ( $field, $from_ord );
228     push @sql_args, $filter if ($filter);
229    
230     my $sql = qq{
231 dpavlin 651 select item,display,data.count as count
232 dpavlin 643 from $tables_sql
233     where name = ?
234 dpavlin 651 and data.ord > ?
235 dpavlin 643 $where_sql
236 dpavlin 651 order by data.ord
237 dpavlin 643 };
238    
239 dpavlin 651 # fix SQLite problem which doesn't allow placeholders in limit and offset
240     # http://thread.gmane.org/gmane.comp.db.sqlite.general/9707
241     $sql .= "limit $rows offset $offset";
242    
243 dpavlin 643 my $sth = $self->{dbh}->prepare($sql) || confess "prepare: $sql; ".$self->{dbh}->errstr();
244 dpavlin 651 $sth->execute(@sql_args) || confess "execute: $sql; ".join("|",@sql_args)." ".$self->{dbh}->errstr();
245 dpavlin 641 my @arr;
246     while (my $row = $sth->fetchrow_hashref) {
247     $row->{item} = HTML::Entities::encode($row->{item},' <>&"');
248     $row->{display} = HTML::Entities::encode($row->{display},'<>&"');
249     $row->{item} =~ s#&amp;(\w)(acute|cedil|circ|grave|ring|slash|tilde|uml);#$1#gi;
250     $row->{display} =~ s#&amp;(\w)(acute|cedil|circ|grave|ring|slash|tilde|uml);#&$1$2;#gi;
251     push @arr,$row;
252     }
253     return @arr;
254     }
255    
256     sub close {
257     my $self = shift;
258    
259     return if (! $self->{dbh});
260    
261 dpavlin 643 $self->{dbh}->begin_work || confess $self->{dbh}->errstr();
262 dpavlin 641
263 dpavlin 651 $self->delete_and_create('data', qq{
264     create table data (
265 dpavlin 641 name varchar(255),
266     ord int,
267     item text,
268     display text,
269     count int,
270     primary key (name,ord)
271     );
272     });
273    
274 dpavlin 642 $self->delete_and_create('filters', qq{
275     create table filters (
276     filter varchar(255),
277 dpavlin 641 ord int,
278     count int,
279 dpavlin 642 primary key (filter,ord)
280 dpavlin 641 );
281     });
282    
283     $self->bench("getting all entries");
284     my @items = keys %{$self->{c}};
285     $self->bench("got ".($#items+1)." items, now sorting");
286     @items = sort @items;
287    
288 dpavlin 651 my $sql = "insert into data (name,ord,item,display,count) values (?,?,?,?,?)";
289 dpavlin 641 my $sth_index = $self->{dbh}->prepare($sql) || confess "$sql: ".$self->{dbh}->errstr();
290    
291 dpavlin 642 $sql = "insert into filters (filter, ord, count) values (?,?,?)";
292     my $sth_filter = $self->{dbh}->prepare($sql) || confess "$sql: ".$self->{dbh}->errstr();
293 dpavlin 641
294     my $ord = 0;
295     foreach my $key (@items) {
296    
297     foreach my $field (keys %{$self->{c}->{$key}}) {
298     # store items
299     $sth_index->execute(
300     $field,
301     ++$ord,
302     $self->{c}->{$key}->{$field}->{item},
303     $self->{c}->{$key}->{$field}->{display},
304     $self->{c}->{$key}->{$field}->{count},
305     );
306    
307 dpavlin 642 # store filters
308     next unless ($self->{c}->{$key}->{$field}->{filter});
309 dpavlin 641
310 dpavlin 642 foreach my $filter (keys %{$self->{c}->{$key}->{$field}->{filter}}) {
311     $sth_filter->execute( $filter, $ord, $self->{c}->{$key}->{$field}->{filter}->{$filter} );
312 dpavlin 641 }
313     }
314    
315    
316     }
317    
318 dpavlin 643 $self->{dbh}->commit || confess $self->{dbh}->errstr();
319 dpavlin 641
320     $self->bench("vacuuming");
321    
322     if ($self->{dbd} =~ m/(Pg|SQLite)/) {
323     $self->{dbh}->do(qq{vacuum}) || carp "vacumming failed. It shouldn't if you are using PostgreSQL or SQLite: ".$self->{dbh}->errstr();
324     }
325    
326     $self->bench("disconnecting from database");
327    
328     $self->{dbh}->disconnect;
329     undef $self->{dbh};
330     }
331    
332     END {
333     $Count--;
334     print STDERR "index_DBI fatal error: \$index->close() not called... $Count references left!\n" if ($Count > 0);
335     # FIX: debug output
336     # print STDERR "usage\ttable\n";
337     # foreach (keys %Table) {
338     # print STDERR $Table{$_},"\t$_\n";
339     # }
340     }
341    
342     1;

  ViewVC Help
Powered by ViewVC 1.1.26