/[gedafe]/trunk/lib/perl/Gedafe/DB.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 /trunk/lib/perl/Gedafe/DB.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 4 - (show annotations)
Mon Feb 14 22:34:48 2005 UTC (19 years, 1 month ago) by dpavlin
File size: 32196 byte(s)
added inet type

1 # Gedafe, the Generic Database Frontend
2 # copyright (c) 2000-2003 ETH Zurich
3 # see http://isg.ee.ethz.ch/tools/gedafe/
4
5 # released under the GNU General Public License
6
7 package Gedafe::DB;
8 use strict;
9
10 use Gedafe::Global qw(%g);
11
12 use DBI;
13 use DBD::Pg 1.20; # 1.20 has constants for data types
14
15 use vars qw(@ISA @EXPORT_OK);
16 require Exporter;
17 @ISA = qw(Exporter);
18 @EXPORT_OK = qw(
19 DB_Connect
20 DB_GetNumRecords
21 DB_FetchList
22 DB_GetRecord
23 DB_AddRecord
24 DB_UpdateRecord
25 DB_GetCombo
26 DB_DeleteRecord
27 DB_GetDefault
28 DB_ParseWidget
29 DB_ID2HID
30 DB_HID2ID
31 DB_GetBlobType
32 DB_GetBlobName
33 DB_DumpBlob
34 DB_RawField
35 DB_DumpTable
36 );
37
38 sub DB_AddRecord($$$);
39 sub DB_Connect($$);
40 sub DB_DB2HTML($$);
41 sub DB_DeleteRecord($$$);
42 sub DB_DumpBlob($$$$);
43 sub DB_DumpTable($$$);
44 sub DB_ExecQuery($$$$$);
45 sub DB_FetchList($$);
46 sub DB_FetchListSelect($$);
47 sub DB_GetBlobName($$$$);
48 sub DB_GetBlobType($$$$);
49 sub DB_GetCombo($$$);
50 sub DB_GetDefault($$$);
51 sub DB_GetNumRecords($$);
52 sub DB_GetRecord($$$$);
53 sub DB_HID2ID($$$);
54 sub DB_ID2HID($$$);
55 sub DB_Init($$);
56 sub DB_MergeAcls($$);
57 sub DB_ParseWidget($);
58 sub DB_PrepareData($$);
59 sub DB_RawField($$$$);
60 sub DB_ReadDatabase($);
61 sub DB_ReadFields($$$);
62 sub DB_ReadTableAcls($$);
63 sub DB_ReadTables($$);
64 sub DB_Record2DB($$$$);
65 sub DB_UpdateRecord($$$);
66 sub DB_Widget($$);
67
68 my %type_widget_map = (
69 'date' => 'text(size=12)',
70 'time' => 'text(size=12)',
71 'timestamp' => 'text(size=22)',
72 'timestamptz' => 'text(size=28)',
73 'int2' => 'text(size=6)',
74 'int4' => 'text(size=12)',
75 'int8' => 'text(size=12)',
76 'numeric' => 'text(size=12)',
77 'float4' => 'text(size=12)',
78 'float8' => 'text(size=12)',
79 'bpchar' => 'text(size=40)',
80 'text' => 'text',
81 'name' => 'text(size=20)',
82 'bool' => 'checkbox',
83 'bytea' => 'file',
84 'inet' => 'text(size=15)',
85 );
86
87 sub DB_Init($$)
88 {
89 my ($user, $pass) = @_;
90 my $dbh = DBI->connect_cached("$g{conf}{db_datasource}", $user, $pass) or
91 return undef;
92
93 # read database
94 $g{db_database} = DB_ReadDatabase($dbh);
95
96 # read tables
97 $g{db_tables} = DB_ReadTables($dbh, $g{db_database});
98 defined $g{db_tables} or return undef;
99
100 # order tables
101 $g{db_tables_list} = [ sort { $g{db_tables}{$a}{desc} cmp
102 $g{db_tables}{$b}{desc} } keys %{$g{db_tables}} ];
103
104 # read table acls
105 DB_ReadTableAcls($dbh, $g{db_tables}) or return undef;
106
107 # read fields
108 $g{db_fields} = DB_ReadFields($dbh, $g{db_database}, $g{db_tables});
109 defined $g{db_fields} or return undef;
110
111 # order fields
112 for my $table (@{$g{db_tables_list}}) {
113 $g{db_fields_list}{$table} =
114 [ sort { $g{db_fields}{$table}{$a}{order} <=>
115 $g{db_fields}{$table}{$b}{order} }
116 keys %{$g{db_fields}{$table}}
117 ];
118 }
119
120 return 1;
121 }
122
123 sub DB_ReadDatabase($)
124 {
125 my $dbh = shift;
126 my ($sth, $query, $data);
127 my %database = ();
128
129 # PostgreSQL version
130 $query = "SELECT VERSION()";
131 $sth = $dbh->prepare($query);
132 $sth->execute() or return undef;
133 $data = $sth->fetchrow_arrayref();
134 $sth->finish;
135 if($data->[0] =~ /^PostgreSQL (\d+\.\d+)/) {
136 $database{version} = $1;
137 }
138 else {
139 # we don't support versions older than 7.0
140 # if VERSION() doesn't exist, assume 7.0
141 $database{version} = '7.0';
142 }
143
144 # database oid
145 my $oid;
146 $query = "SELECT oid FROM pg_database WHERE datname = '$dbh->{Name}'";
147 $sth = $dbh->prepare($query);
148 $sth->execute() or die $sth->errstr;
149 $data = $sth->fetchrow_arrayref() or die $sth->errstr;
150 $oid = $data->[0];
151 $sth->finish;
152
153 # read database name from database comment
154 $query = "SELECT description FROM pg_description WHERE objoid = $oid";
155 $sth = $dbh->prepare($query);
156 $sth->execute() or die $sth->errstr;
157 $data = $sth->fetchrow_arrayref();
158 $database{desc} = $data ? $data->[0] : $dbh->{Name};
159 $sth->finish;
160
161 return \%database;
162 }
163
164 sub DB_ReadTables($$)
165 {
166 my ($dbh, $database) = @_;
167 my %tables = ();
168 my ($query, $sth, $data);
169
170 # combo
171 # 7.0: views have relkind 'r'
172 # 7.1: views have relkind 'v'
173
174 # tables
175 if($database->{version} >= 7.3) {
176 $query = <<END;
177 SELECT c.relname
178 FROM pg_class c, pg_namespace n
179 WHERE (c.relkind = 'r' OR c.relkind = 'v')
180 AND (c.relname !~ '^pg_')
181 AND (c.relnamespace = n.oid)
182 AND (n.nspname != 'information_schema')
183 END
184 } else {
185 $query = <<END;
186 SELECT c.relname
187 FROM pg_class c
188 WHERE (c.relkind = 'r' OR c.relkind = 'v')
189 AND c.relname !~ '^pg_'
190 END
191 }
192 $sth = $dbh->prepare($query) or return undef;
193 $sth->execute() or return undef;
194 while ($data = $sth->fetchrow_arrayref()) {
195 $tables{$data->[0]} = { };
196 if($data->[0] =~ /^meta|(_list|_combo)$/) {
197 $tables{$data->[0]}{hide} = 1;
198 }
199 if($data->[0] =~ /_rep$/) {
200 $tables{$data->[0]}{report} = 1;
201 }
202 }
203 $sth->finish;
204
205 # read table comments as descriptions
206 if($database->{version} >= 7.2) {
207 $query = <<'END';
208 SELECT c.relname, obj_description(c.oid, 'pg_class')
209 FROM pg_class c
210 WHERE (c.relkind = 'r' OR c.relkind = 'v')
211 AND c.relname !~ '^pg_'
212 END
213 }
214 else {
215 $query = <<'END';
216 SELECT c.relname, d.description
217 FROM pg_class c, pg_description d
218 WHERE (c.relkind = 'r' OR c.relkind = 'v')
219 AND c.relname !~ '^pg_'
220 AND c.oid = d.objoid
221 END
222 }
223 $sth = $dbh->prepare($query) or return undef;
224 $sth->execute() or return undef;
225 while ($data = $sth->fetchrow_arrayref()) {
226 next unless defined $tables{$data->[0]};
227 $tables{$data->[0]}{desc} = $data->[1];
228 }
229 $sth->finish;
230
231 # set not-defined table descriptions
232 for my $table (keys %tables) {
233 next if defined $tables{$table}{desc};
234 if(exists $tables{"${table}_list"} and defined
235 $tables{"${table}_list"}{desc})
236 {
237 $tables{$table}{desc} = $tables{"${table}_list"}{desc};
238 }
239 else {
240 $tables{$table}{desc} = $table;
241 }
242 }
243
244 # meta_tables
245 $query = 'SELECT meta_tables_table, meta_tables_attribute, meta_tables_value FROM meta_tables';
246 $sth = $dbh->prepare($query) or die $dbh->errstr;
247 $sth->execute() or die $sth->errstr;
248 while ($data = $sth->fetchrow_arrayref()) {
249 next unless defined $tables{$data->[0]};
250 my $attr = lc($data->[1]);
251 $tables{$data->[0]}{meta}{$attr}=$data->[2];
252 if($attr eq 'hide' and $data->[2]) {
253 $tables{$data->[0]}{hide}=1;
254 }
255 }
256 $sth->finish;
257
258 return \%tables;
259 }
260
261 sub DB_MergeAcls($$)
262 {
263 my ($a, $b) = @_;
264
265 $a = '' unless defined $a;
266 $b = '' unless defined $a;
267 my %acls = ();
268 for(split('',$a)) {
269 $acls{$_}=1;
270 }
271 for(split('',$b)) {
272 $acls{$_}=1;
273 }
274 return join('',keys %acls);
275 }
276
277 sub DB_ReadTableAcls($$)
278 {
279 my ($dbh, $tables) = @_;
280
281 my ($query, $sth, $data);
282
283 # users
284 my %db_users;
285 $query = 'SELECT usename, usesysid FROM pg_user';
286 $sth = $dbh->prepare($query) or die $dbh->errstr;
287 $sth->execute() or die $sth->errstr;
288 while ($data = $sth->fetchrow_arrayref()) {
289 $db_users{$data->[1]} = $data->[0];
290 }
291 $sth->finish;
292
293 # groups
294 my %db_groups;
295 $query = 'SELECT groname, grolist FROM pg_group';
296 $sth = $dbh->prepare($query) or die $dbh->errstr;
297 $sth->execute() or die $sth->errstr;
298 while ($data = $sth->fetchrow_arrayref()) {
299 my $group = $data->[1];
300 if(defined $group) {
301 $group =~ s/^{(.*)}$/$1/;
302 my @g = split /,/, $group;
303 $db_groups{$data->[0]} = [@db_users{@g}];
304 }
305 else {
306 $db_groups{$data->[0]} = [];
307 }
308 }
309 $sth->finish;
310
311 # acls
312 $query = "SELECT c.relname, c.relacl FROM pg_class c WHERE (c.relkind = 'r' OR c.relkind='v') AND relname !~ '^pg_'";
313 $sth = $dbh->prepare($query) or die $dbh->errstr;
314 $sth->execute() or die $sth->errstr;
315 while ($data = $sth->fetchrow_arrayref()) {
316 next unless defined $data->[0];
317 next unless defined $data->[1];
318 next unless defined $tables->{$data->[0]};
319 my $acldef = $data->[1];
320 $acldef =~ s/^{(.*)}$/$1/;
321 my @acldef = split(',', $acldef);
322 map { s/^"(.*)"$/$1/ } @acldef;
323 acl: for(@acldef) {
324 /(.*)=(.*)/;
325 my $who = $1; my $what = $2;
326 if($who eq '') {
327 # PUBLIC: assign permissions to all db users
328 for(values %db_users) {
329 $tables->{$data->[0]}{acls}{$_} =
330 DB_MergeAcls($tables->{$data->[0]}{acls}{$_}, $what);
331 }
332 }
333 elsif($who =~ /^group (.*)$/) {
334 # group permissions: assign to all db groups
335 for(@{$db_groups{$1}}) {
336 $tables->{$data->[0]}{acls}{$_} =
337 DB_MergeAcls($tables->{$data->[0]}{acls}{$_}, $what);
338 }
339 }
340 else {
341 # individual user: assign just to this db user
342 $tables->{$data->[0]}{acls}{$who} =
343 DB_MergeAcls($tables->{$data->[0]}{acls}{$who}, $what);
344 }
345 }
346 }
347
348 $sth->finish;
349
350 return 1;
351 }
352
353 # DB_Widget: determine widget from type if not explicitely defined
354 sub DB_Widget($$)
355 {
356 my ($fields, $f) = @_;
357
358 if(defined $f->{widget} and $f->{widget} eq 'isearch'){
359 my $r = $f->{reference};
360 my $rt = $g{db_tables}{$r};
361 defined $rt or die "table $f->{reference}, referenced from $f->{table}:$f->{field}, not found.\n";
362 if(defined $fields->{$r}{"${r}_hid"}) {
363 # Combo with HID
364 return "hidisearch(ref=$r)";
365 }
366 return "isearch(ref=$r)";
367 }
368
369
370 return $f->{widget} if defined $f->{widget};
371
372 # HID and combo-boxes
373 if($f->{type} eq 'int4' or $f->{type} eq 'int8') {
374 if(defined $f->{reference}) {
375 my $r = $f->{reference};
376 my $rt = $g{db_tables}{$r};
377 defined $rt or die "table $f->{reference}, referenced from $f->{table}:$f->{field}, not found.\n";
378 my $combo = "${r}_combo";
379 if(defined $g{db_tables}{$combo}) {
380 if(defined $fields->{$r}{"${r}_hid"}) {
381 # Combo with HID
382 return "hidcombo(combo=$combo,ref=$r)";
383 }
384 return "idcombo(combo=$combo)";
385 }
386 if(defined $fields->{$r}{"${r}_hid"}) {
387 # Plain with HID
388 return "hid(ref=$r)";
389 }
390 return "text";
391 }
392 return $type_widget_map{$f->{type}};
393 }
394 elsif($f->{type} eq 'varchar') {
395 my $len = $f->{atttypmod}-4;
396 if($len <= 0) {
397 return 'text';
398 }
399 else {
400 return "text(size=$len,maxlength=$len)";
401 }
402 }
403 else {
404 my $w = $type_widget_map{$f->{type}};
405 defined $w or die "unknown widget for type $f->{type} ($f->{table}:$f->{field}).\n";
406 return $w;
407 }
408 }
409
410 # Parse widget specification, split args, verify if it is a valid widget
411 sub DB_ParseWidget($)
412 {
413 my ($widget) = @_;
414 $widget =~ /^(\w+)(\((.*)\))?$/ or die "syntax error for widget: $widget";
415 my ($type, $args_str) = ($1, $3);
416 my %args=();
417 if(defined $args_str) {
418 for my $w (split('\s*,\s*',$args_str)) {
419 $w =~ s/^\s+//;
420 $w =~ s/\s+$//;
421 $w =~ /^(\w+)\s*=\s*(.*)$/ or die "syntax error in $type-widget argument: $w";
422 $args{$1}=$2;
423 }
424 }
425
426 # verify
427 if($type eq 'idcombo' or $type eq 'hidcombo' or $type eq 'combo') {
428 defined $args{'combo'} or
429 die "widget $widget: mandatory argument 'combo' not defined";
430 }
431 if($type eq 'hidcombo' or $type eq 'hidisearch') {
432 my $r = $args{'ref'};
433 defined $r or
434 die "widget $widget: mandatory argument 'ref' not defined";
435 defined $g{db_tables}{$r} or
436 die "widget $widget: no such table: $r";
437 defined $g{db_fields}{$r}{"${r}_hid"} or
438 die "widget $widget: table $r has no HID";
439 }
440
441 return ($type, \%args);
442 }
443
444 sub DB_ReadFields($$$)
445 {
446 my ($dbh, $database, $tables) = @_;
447 my ($query, $sth, $data);
448 my %fields = ();
449
450 # fields
451 $query = <<'END';
452 SELECT a.attname, t.typname, a.attnum, a.atthasdef, a.atttypmod
453 FROM pg_class c, pg_attribute a, pg_type t
454 WHERE c.relname = ? AND a.attnum > 0
455 AND a.attrelid = c.oid AND a.atttypid = t.oid
456 AND a.attname != ('........pg.dropped.' || a.attnum || '........')
457 ORDER BY a.attnum
458 END
459 $sth = $dbh->prepare($query);
460 for my $table (keys %$tables) {
461 $sth->execute($table) or die $sth->errstr;
462 my $order = 1;
463 while ($data = $sth->fetchrow_arrayref()) {
464 if($data->[0] eq 'meta_sort') {
465 $tables->{$table}{meta_sort}=1;
466 }
467 else {
468 $fields{$table}{$data->[0]} = {
469 field => $data->[0],
470 order => $order++,
471 type => $data->[1],
472 attnum => $data->[2],
473 atthasdef => $data->[3],
474 atttypmod => $data->[4]
475 };
476 }
477 }
478 }
479 $sth->finish;
480
481 my %field_descs = ();
482
483 # read field comments as descriptions
484 if($database->{version} >= 7.2) {
485 $query = <<'END';
486 SELECT a.attname, col_description(a.attrelid, a.attnum)
487 FROM pg_class c, pg_attribute a
488 WHERE c.relname = ? AND a.attnum > 0
489 AND a.attrelid = c.oid
490 AND a.attname != ('........pg.dropped.' || a.attnum || '........')
491 END
492 }
493 else {
494 $query = <<'END';
495 SELECT a.attname, d.description
496 FROM pg_class c, pg_attribute a, pg_description d
497 WHERE c.relname = ? AND a.attnum > 0
498 AND a.attrelid = c.oid
499 AND a.oid = d.objoid
500 AND a.attname != ('........pg.dropped.' || a.attnum || '........')
501 END
502 }
503
504 $sth = $dbh->prepare($query);
505 for my $table (keys %$tables) {
506 $sth->execute($table) or die $sth->errstr;
507 while ($data = $sth->fetchrow_arrayref()) {
508 defined $data->[1] and $data->[1] !~ /^\s*$/ or next;
509 $fields{$table}{$data->[0]}{desc}=$data->[1];
510 $field_descs{$data->[0]} = $data->[1];
511 }
512 }
513 $sth->finish;
514
515 # set not-defined field descriptions
516 for my $table (keys %$tables) {
517 for my $field (keys %{$fields{$table}}) {
518 my $f = $fields{$table}{$field};
519 if(not defined $f->{desc}) {
520 if(defined $field_descs{$field}) {
521 $f->{desc} = $field_descs{$field};
522 }
523 else {
524 $f->{desc} = $field;
525 }
526 }
527 }
528 }
529
530 # defaults
531 $query = <<'END';
532 SELECT d.adsrc FROM pg_attrdef d, pg_class c WHERE
533 c.relname = ? AND c.oid = d.adrelid AND d.adnum = ?;
534 END
535 $sth = $dbh->prepare($query) or die $dbh->errstr;
536 for my $table (keys %$tables) {
537 for my $field (keys %{$fields{$table}}) {
538 if(! $fields{$table}{$field}{atthasdef}) { next; }
539 $sth->execute($table, $fields{$table}{$field}{attnum}) or die $sth->errstr;
540 my $d = $sth->fetchrow_arrayref();
541 $fields{$table}{$field}{default} = $d->[0];
542 $sth->finish;
543 }
544 }
545
546 # meta fields
547 my %meta_fields = ();
548 $query = <<'END';
549 SELECT meta_fields_table, meta_fields_field, meta_fields_attribute,
550 meta_fields_value FROM meta_fields
551 END
552 $sth = $dbh->prepare($query) or die $dbh->errstr;
553 $sth->execute() or die $sth->errstr;
554 while ($data = $sth->fetchrow_arrayref()) {
555 $meta_fields{lc($data->[0])}{lc($data->[1])}{lc($data->[2])} =
556 $data->[3];
557 }
558 $sth->finish;
559
560 # foreign-key constraints (REFERENCES)
561 $query = <<'END';
562 SELECT tgargs from pg_trigger, pg_proc where pg_trigger.tgfoid=pg_proc.oid AND pg_trigger.tgname
563 LIKE 'RI_ConstraintTrigger%' AND pg_proc.proname = 'RI_FKey_check_ins'
564 END
565 $sth = $dbh->prepare($query) or die $dbh->errstr;
566 $sth->execute() or die $sth->errstr;
567 while ($data = $sth->fetchrow_arrayref()) {
568 my @d = split(/(?:\000|\\000)/,$$data[0]); # DBD::Pg 0.95: \\000, DBD::Pg 0.98: \000
569 $meta_fields{$d[1]}{$d[4]}{reference} = $d[2];
570 }
571 $sth->finish;
572
573 # if there is a HID field, then hide the ID field
574 for my $view (keys %$tables) {
575 my $table = $view; $table =~ /^(.*)_list$/ and $table = $1;
576 if(defined $fields{$view}{"${table}_hid"} and
577 defined $fields{$view}{"${table}_id"})
578 {
579 $fields{$view}{"${table}_id"}{hide_list}=1;
580 }
581 }
582
583 # go through every table and field and fill-in:
584 # - table information in reference fields
585 # - meta information from meta_fields
586 # - widget from type (if not specified)
587 table: for my $table (keys %$tables) {
588 field: for my $field (keys %{$fields{$table}}) {
589 my $f = $fields{$table}{$field};
590 my $m = undef;
591 if(defined $meta_fields{$table}) {
592 $m = $meta_fields{$table}{$field};
593 }
594 if(defined $m) {
595 $f->{widget} = $m->{widget};
596 $f->{reference} = $m->{reference};
597 $f->{copy} = $m->{copy};
598 $f->{sortfunc} = $m->{sortfunc};
599 $f->{markup} = $m->{markup};
600 $f->{align} = $m->{align};
601 $f->{hide_list} = $m->{hide_list};
602 }
603 #if(! defined $f->{widget}) {
604 $f->{widget} = DB_Widget(\%fields, $f);
605 #}
606 }
607 }
608
609 return \%fields;
610 }
611
612 sub DB_Connect($$)
613 {
614 my $user = shift;
615 my $pass = shift;
616 my $dbh;
617 if($dbh = DBI->connect_cached("$g{conf}{db_datasource}", $user, $pass)) {
618 if(not defined $g{db_meta_loaded}) {
619 DB_Init($user, $pass) or return undef;
620 $g{db_meta_loaded} = 1;
621 }
622 return $dbh;
623 }
624 return undef;
625 }
626
627 sub DB_GetDefault($$$)
628 {
629 my $dbh = shift;
630 my $table = shift;
631 my $field = shift;
632
633 my $query = $g{db_fields}{$table}{$field}{default};
634 return undef unless defined $query;
635
636 $query = "SELECT ".$query;
637 my $sth = $dbh->prepare_cached($query) or die $dbh->errstr;
638 #print "<!-- Executing: $query -->\n";
639 $sth->execute() or die $sth->errstr;
640 my $d = $sth->fetchrow_arrayref();
641 my $default = $d->[0];
642 $sth->finish;
643
644 return $default;
645 }
646
647 sub DB_DB2HTML($$)
648 {
649 my $str = shift;
650 my $type = shift;
651
652 # undef -> ''
653 $str = '' unless defined $str;
654
655 # trim space
656 $str =~ s/^\s+//;
657 $str =~ s/\s+$//;
658
659 if($type eq 'bool') {
660 $str = ($str ? 'yes' : 'no');
661 }
662 if($type eq 'text' and $str !~ /<[^>]+>/) { #make sure the text does not contain html
663 $str =~ s/\n/<BR>/g;
664 }
665 if($str eq '') {
666 $str = '&nbsp;';
667 }
668
669 return $str;
670 }
671
672 # this is merely an envelope for DB_FetchList()
673 sub DB_GetNumRecords($$)
674 {
675 my $s = shift;
676 my $spec = shift;
677
678 $spec->{countrows} = 1;
679 return DB_FetchList($s, $spec);
680 }
681
682 sub DB_FetchListSelect($$)
683 {
684 my $dbh = shift;
685 my $spec = shift;
686 my $v = $spec->{view};
687
688 # does the view/table exist?
689 defined $g{db_fields_list}{$v} or die "no such table: $v\n";
690
691 # go through fields and build field list for SELECT (...)
692 my @fields = @{$g{db_fields_list}{$v}};
693 my @select_fields;
694 for my $f (@fields) {
695 if($g{db_fields}{$v}{$f}{type} eq 'bytea') {
696 push @select_fields, "substring($f,1,position(' '::bytea in $f)-1)";
697 }
698 else {
699 push @select_fields, $f;
700 }
701 }
702
703 my @query_parameters = ();
704
705 my $query = "SELECT ";
706 $query .= $spec->{countrows} ? "COUNT(*)" : join(', ',@select_fields);
707 $query .= " FROM $v";
708 my $searching=0;
709 if(defined $spec->{search_field} and defined $spec->{search_value}
710 and $spec->{search_field} ne '' and $spec->{search_value} ne '')
711 {
712 my $type = $g{db_fields}{$v}{$spec->{search_field}}{type};
713
714
715 if($type eq 'date') {
716 $query .= " WHERE $spec->{search_field} = ? ";
717 push @query_parameters, "$spec->{search_value}";
718 }
719 elsif($type eq 'bool') {
720 $query .= " WHERE $spec->{search_field} = ? ";
721 push @query_parameters, "$spec->{search_value}";
722 }
723 elsif($type eq 'bytea') {
724 $query .= " WHERE position(?::bytea in $spec->{search_field}) != 0";
725 push @query_parameters, "$spec->{search_value}";
726 }
727 else {
728 $query .= " WHERE $spec->{search_field} ~* ? ";
729 push @query_parameters, ".*$spec->{search_value}.*";
730 }
731 $searching=1;
732 }
733 if(defined $spec->{filter_field} and defined $spec->{filter_value}) {
734 if($searching) {
735 $query .= ' AND';
736 }
737 else {
738 $query .= ' WHERE';
739 }
740 $query .= " $spec->{filter_field} = ? ";
741 push @query_parameters, "$spec->{filter_value}";
742 }
743 unless ($spec->{countrows}) {
744 if (defined $spec->{orderby} and $spec->{orderby} ne '') {
745 if (defined $g{db_fields}{$v}{$spec->{orderby}}{sortfunc}) {
746 my $f = $g{db_fields}{$v}{$spec->{orderby}}{sortfunc};
747 $query .= " ORDER BY $f($spec->{orderby})";
748 } else {
749 $query .= " ORDER BY $spec->{orderby}";
750 }
751 if ($spec->{descending}) {
752 $query .= " DESC";
753 }
754 if (defined $g{db_tables}{$v}{meta_sort}) {
755 $query .= ", $v.meta_sort";
756 }
757 else {
758 # if sorting on a non unique field,
759 # then the order of the record is not
760 # guaranteed -> this can be confusing
761 # while scrolling.
762 # try to put order by sorting additionally
763 # with first field, assumed to be the ID
764 $query .= ", $fields[0]";
765 }
766 } elsif (defined $g{db_tables}{$v}{meta_sort}) {
767 $query .= " ORDER BY $v.meta_sort";
768 }
769 if (defined $spec->{limit} and $spec->{limit} != -1 and !$spec->{export})
770 {
771 $query .= " LIMIT $spec->{limit}";
772 }
773 if (defined $spec->{offset} and !$spec->{countrows}) {
774 $query .= " OFFSET $spec->{offset}";
775 }
776 }
777
778
779 # print "\n<!-- $query -->\n" unless $spec->{export};
780 # this is kind of useless now that query's are made with the ? placeholders.
781
782 my $sth = $dbh->prepare_cached($query) or die $dbh->errstr;
783
784 for(1..scalar(@query_parameters)){
785 #count from 1 to number_of_parameters including.
786 #sql parameters start at 1.
787 $sth->bind_param($_,shift @query_parameters);
788 }
789
790 $sth->execute() or die $sth->errstr . " ($query)";
791 return (\@fields, $sth);
792 }
793
794 sub DB_FetchList($$)
795 {
796 my $s = shift;
797 my $spec = shift;
798
799 my $dbh = $s->{dbh};
800 my $user = $s->{user};
801 my $v = $spec->{view};
802
803 # fetch one row more than necessary, so that we
804 # can find out when we are at the end (skip if DB_GetNumRecords)
805 $spec->{limit}++ unless $spec->{countrows};
806
807 my ($fields, $sth) = DB_FetchListSelect($dbh, $spec);
808
809 # if this is actually a call to DB_GetNumRecords()
810 if($spec->{countrows}) {
811 my $data = $sth->fetchrow_arrayref();
812 $sth->finish or die $sth->errstr;
813 return $data->[0];
814 }
815
816 # the idea of the %list hash, which then gets passed to GUI_ListTable
817 # is that it is a self-contained description of the data. It shouldn't
818 # be necessary to go look at db_tables and db_fields to figure out how
819 # to display the data, so we need to provide all the required
820 # information here
821 my %list = (
822 spec => $spec,
823 data => [],
824 fields => $fields,
825 acl => defined $g{db_tables}{$spec->{table}}{acls}{$user} ?
826 $g{db_tables}{$spec->{table}}{acls}{$user} : ''
827 );
828 my $col = 0;
829 my @columns;
830 for my $f (@{$list{fields}}) {
831 $columns[$col] = {
832 field => $f,
833 desc => $g{db_fields}{$v}{$f}{desc},
834 align => $g{db_fields}{$v}{$f}{align},
835 hide_list => $g{db_fields}{$v}{$f}{hide_list},
836 markup => $g{db_fields}{$v}{$f}{markup},
837 type => $g{db_fields}{$v}{$f}{type},
838 };
839 $col++;
840 }
841 $list{columns} = \@columns;
842
843 # fetch the data
844 while(my $data = $sth->fetchrow_arrayref()) {
845 my $col;
846 my @row;
847 for($col=0; $col<=$#$data; $col++) {
848 push @row, $spec->{export} ? $data->[$col] :
849 DB_DB2HTML($data->[$col], $columns[$col]{type});
850 }
851
852 push @{$list{data}}, [ $data->[0], \@row ];
853 }
854 die $sth->errstr if $sth->err;
855
856 # are we at the end?
857 if(scalar @{$list{data}} != $spec->{limit}) {
858 $list{end} = 1
859 }
860 else {
861 $list{end} = 0;
862 pop @{$list{data}}; # we did get one more than requested
863 }
864 # decrement temporarily incremented LIMIT count
865 $spec->{limit}--;
866
867 return \%list;
868 }
869
870 sub DB_GetRecord($$$$)
871 {
872 my $dbh = shift;
873 my $table = shift;
874 my $id = shift;
875 my $record = shift;
876
877 my @fields_list = @{$g{db_fields_list}{$table}};
878 #update the query to prevent listing binary data
879 my @select_fields = @fields_list;
880 for(@select_fields){
881 if($g{db_fields}{$table}{$_}{type} eq 'bytea'){
882 $_ = "substring($_,1,position(' '::bytea in $_)-1)";
883 }
884 }
885
886 # fetch raw data
887 my $data;
888 my $query = "SELECT ";
889 $query .= join(', ',@select_fields); # @{$g{db_fields_list}{$table}});
890 $query .= " FROM $table WHERE ${table}_id = $id";
891 my $sth;
892 $sth = $dbh->prepare_cached($query) or die $dbh->errstr;
893 $sth->execute() or die $sth->errstr;
894 $data = $sth->fetchrow_arrayref() or
895 die ($sth->err ? $sth->errstr : "Record not found ($query)\n");
896
897 # transorm raw data into record
898 my $i=0;
899 for(@fields_list) {
900 $record->{$_} = $data->[$i];
901 $i++;
902 }
903
904 return 1;
905 }
906
907 sub DB_ID2HID($$$)
908 {
909 my $dbh = shift;
910 my $table = shift;
911 my $id = shift;
912
913 return unless defined $id and $id ne '';
914 my $q = "SELECT ${table}_hid FROM ${table} WHERE ${table}_id = '$id'";
915 my $sth = $dbh->prepare_cached($q) or die $dbh->errstr;
916 $sth->execute or die $sth->errstr;
917 my $d = $sth->fetchrow_arrayref();
918 die $sth->errstr if $sth->err;
919
920 return $d->[0];
921 }
922
923 sub DB_HID2ID($$$)
924 {
925 my $dbh = shift;
926 my $table = shift;
927 my $hid = shift;
928
929 return unless defined $hid and $hid ne '';
930 my $q = "SELECT ${table}_id FROM ${table} WHERE ${table}_hid = ?";
931 my $sth = $dbh->prepare_cached($q) or die $dbh->errstr;
932 $sth->execute($hid) or die $sth->errstr;
933 my $d = $sth->fetchrow_arrayref();
934 die $sth->errstr if $sth->err;
935
936 return $d->[0];
937 }
938
939 sub DB_PrepareData($$)
940 {
941 $_ = shift;
942 $_ = '' unless defined $_;
943 my $type = shift;
944 s/^\s+//;
945 s/\s+$//;
946
947 # quoting for the SQL statements
948 # obsolete since migration to placeholder querys
949 # insert ... values(?,?) etc.
950
951
952 #s/\\/\\\\/g;
953 #s/'/\\'/g;
954
955 if($type eq 'bool') {
956 $_ = ($_ ? '1' : '0');
957 }
958
959 # this is a hack. It should be implemented in GUI.pm or
960 # (better) with a widget-type
961 if($type eq 'numeric') {
962 if(/^(\d*):(\d+)$/) {
963 my $hours = $1 or 0;
964 my $mins = $2;
965 $_ = $hours+$mins/60;
966 }
967 }
968
969 if($_ eq '') {
970 $_ = undef;
971 }
972
973 return $_;
974 }
975
976 sub DB_Record2DB($$$$)
977 {
978 my $dbh = shift;
979 my $table = shift;
980 my $record = shift;
981 my $dbdata = shift;
982
983 my $fields = $g{db_fields}{$table};
984 my @fields_list = @{$g{db_fields_list}{$table}};
985
986 my $f;
987 for $f (@fields_list) {
988 my $type = $fields->{$f}{type};
989 my $data = $record->{$f};
990
991 $data = DB_PrepareData($data, $type);
992
993 $dbdata->{$f} = $data;
994 }
995 }
996
997 sub DB_ExecQuery($$$$$)
998 {
999 my $dbh = shift;
1000 my $table = shift;
1001 my $query = shift;
1002 my $data = shift;
1003 my $fields = shift;
1004
1005 my %datatypes = ();
1006 for(@$fields){
1007 $datatypes{$_} = $g{db_fields}{$table}{$_}{type};
1008 }
1009
1010 #print "<!-- Executing: $query -->\n";
1011
1012 my $sth = $dbh->prepare($query) or die $dbh->errstr;
1013
1014 my $paramnumber = 1;
1015 for(@$fields){
1016 my $type = $datatypes{$_};
1017 my $data = $data->{$_};
1018 if($type eq "bytea") {
1019 #note the reference to the large blob
1020 $sth->bind_param($paramnumber,$$data,{ pg_type => DBD::Pg::PG_BYTEA });
1021 }
1022 else {
1023 $sth->bind_param($paramnumber,$data);
1024 }
1025 $paramnumber++;
1026 }
1027 my $res = $sth->execute() or do {
1028 # report nicely the error
1029 $g{db_error}=$sth->errstr; return undef;
1030 };
1031 if($res ne 1 and $res ne '0E0') {
1032 die "Number of rows affected is not 1! ($res)";
1033 }
1034 return 1;
1035 }
1036
1037 sub DB_AddRecord($$$)
1038 {
1039 my $dbh = shift;
1040 my $table = shift;
1041 my $record = shift;
1042
1043 my $fields = $g{db_fields}{$table};
1044 my @fields_list = grep !/${table}_id/, @{$g{db_fields_list}{$table}};
1045
1046 # filter-out readonly fields
1047 @fields_list = grep { not defined $g{db_fields}{$table}{$_}{widget} or $g{db_fields}{$table}{$_}{widget} ne 'readonly' } @fields_list;
1048
1049 my %dbdata = ();
1050 DB_Record2DB($dbh, $table, $record, \%dbdata);
1051
1052 my $query = "INSERT INTO $table (";
1053 $query .= join(', ',@fields_list);
1054 $query .= ") VALUES (";
1055 my $first = 1;
1056 for(@fields_list) {
1057 if($first) {
1058 $first = 0;
1059 }
1060 else {
1061 $query .= ', ';
1062 }
1063 $query .= '?'
1064 }
1065 $query .= ")";
1066 return DB_ExecQuery($dbh,$table,$query,\%dbdata,\@fields_list);
1067 }
1068
1069 sub DB_UpdateRecord($$$)
1070 {
1071 my $dbh = shift;
1072 my $table = shift;
1073 my $record = shift;
1074
1075 my $fields = $g{db_fields}{$table};
1076 my @fields_list = @{$g{db_fields_list}{$table}};
1077
1078 # filter-out readonly fields
1079 @fields_list = grep { $g{db_fields}{$table}{$_}{widget} ne 'readonly' } @fields_list;
1080
1081 # filter-out bytea fields that have value=undef
1082 # these should keep the value that is now in the database.
1083 @fields_list = grep { defined($record->{$_}) or $g{db_fields}{$table}{$_}{type} ne 'bytea' } @fields_list;
1084
1085 my %dbdata = ();
1086 DB_Record2DB($dbh, $table, $record, \%dbdata);
1087
1088
1089 my @updates;
1090 my $query = "UPDATE $table SET ";
1091 my @updatefields;
1092 for(@fields_list) {
1093 if($_ eq "id") { next; }
1094 if($_ eq "${table}_id") { next; }
1095 push @updates,"$_ = ?";
1096 push @updatefields,$_;
1097 }
1098 $query .= join(', ',@updates);
1099 $query .= " WHERE ${table}_id = $record->{id}";
1100
1101 return DB_ExecQuery($dbh,$table,$query,\%dbdata,\@updatefields);
1102 }
1103
1104 sub DB_GetCombo($$$)
1105 {
1106 my $dbh = shift;
1107 my $combo_view = shift;
1108 my $combo_data = shift;
1109
1110 my $query = "SELECT id, text FROM $combo_view";
1111 if(defined $g{db_tables}{$combo_view}{meta_sort}) {
1112 $query .= " ORDER BY meta_sort";
1113 }
1114 else {
1115 $query .= " ORDER BY text";
1116 }
1117 my $sth = $dbh->prepare_cached($query) or die $dbh->errstr;
1118 $sth->execute() or die $sth->errstr;
1119 my $data;
1120 while($data = $sth->fetchrow_arrayref()) {
1121 $data->[0]='' unless defined $data->[0];
1122 $data->[1]='' unless defined $data->[1];
1123 push @$combo_data, [$data->[0], $data->[1]];
1124 }
1125 die $sth->errstr if $sth->err;
1126
1127 return 1;
1128 }
1129
1130 sub DB_DeleteRecord($$$)
1131 {
1132 my $dbh = shift;
1133 my $table = shift;
1134 my $id = shift;
1135
1136 my $query = "DELETE FROM $table WHERE ${table}_id = $id";
1137
1138 #print "<!-- Executing: $query -->\n";
1139 my $sth = $dbh->prepare($query) or die $dbh->errstr;
1140 $sth->execute() or do {
1141 # report nicely the error
1142 $g{db_error}=$sth->errstr; return undef;
1143 };
1144
1145 return 1;
1146 }
1147
1148 sub DB_GetBlobName($$$$)
1149 {
1150 my $dbh = shift;
1151 my $table = shift;
1152 my $field = shift;
1153 my $id = shift;
1154
1155 my $idcolumn = "${table}_id";
1156 if($table =~ /\w+_list/){
1157 #tables that end with _list are actualy views and have their
1158 # id column as the first column of the view
1159 $idcolumn = $g{db_fields_list}{$table}[0];
1160 }
1161
1162 my $query = "Select substring($field,1,position(' '::bytea in $field)-1) from $table where $idcolumn=$id";
1163 my $sth = $dbh->prepare($query);
1164 $sth->execute() or return undef;
1165 my $data = $sth->fetchrow_arrayref() or return undef;
1166 return $data->[0];
1167 }
1168
1169 sub DB_GetBlobType($$$$)
1170 {
1171 my $dbh = shift;
1172 my $table = shift;
1173 my $field = shift;
1174 my $id = shift;
1175
1176 my $idcolumn = "${table}_id";
1177 if($table =~ /\w+_list/){
1178 #tables that end with _list are actualy views and have their
1179 # id column as the first column of the view
1180 $idcolumn = $g{db_fields_list}{$table}[0];
1181 }
1182
1183 my $query = "Select substring($field,position(' '::bytea in $field)+1,position('#'::bytea in $field)-(position(' '::bytea in $field)+1)) from $table where $idcolumn=$id";
1184 my $sth = $dbh->prepare($query);
1185 $sth->execute() or return undef;
1186 my $data = $sth->fetchrow_arrayref() or return undef;
1187 return $data->[0];
1188 }
1189
1190 sub DB_DumpBlob($$$$)
1191 {
1192 my $dbh = shift;
1193 my $table = shift;
1194 my $field = shift;
1195 my $id = shift;
1196
1197 my $idcolumn = "${table}_id";
1198 if($table =~ /\w+_list/){
1199 #tables that end with _list are actualy views and have their
1200 # id column as the first column of the view.
1201 $idcolumn = $g{db_fields_list}{$table}[0];
1202 }
1203
1204 my $query = "Select position('#'::bytea in $field)+1,octet_length($field) from $table where $idcolumn=$id";
1205 my $sth = $dbh->prepare($query);
1206 $sth->execute() or return -1;
1207 my $data = $sth->fetchrow_arrayref() or return -1;
1208 my $startpos = $data->[0] || 0;
1209 my $strlength = $data->[1] || 0;
1210 $sth->finish();
1211 my $endpos = $strlength-($startpos-1);
1212 my $dumpquery = "Select substring($field,?,?) from $table where $idcolumn=$id";
1213 my $dumpsth = $dbh->prepare($dumpquery);
1214 my $blobdata;
1215 $dumpsth->execute($startpos,$endpos) or return -1;
1216 $blobdata = $dumpsth->fetchrow_arrayref() or return -1;
1217 # I know it is not nice to do the print here but I don't want to make the memory footprint
1218 # to large so returning the blob to a GUI routine is not possible.
1219 print $blobdata->[0];
1220 return 1;
1221 }
1222
1223 sub DB_RawField($$$$)
1224 {
1225 my $dbh = shift;
1226 my $table = shift;
1227 my $field = shift;
1228 my $id = shift;
1229
1230 my $query = "Select $field from $table where ${table}_id = $id";
1231 # print STDERR $query."\n";
1232 my $sth = $dbh->prepare($query);
1233 $sth->execute() or return undef;
1234 my $data = $sth->fetchrow_arrayref() or return undef;
1235 return $data->[0];
1236 }
1237
1238 sub DB_DumpTable($$$)
1239 {
1240 my $dbh = shift;
1241 my $table = shift;
1242 my $view = defined $g{db_tables}{"${table}_list"} ?
1243 "${table}_list" : $table;
1244 my $atribs = shift;
1245
1246 my @fields = @{$g{db_fields_list}{$view}};
1247 # update the query to prevent listing binary data
1248 my @select_fields = @fields;
1249 for(@select_fields){
1250 if($g{db_fields}{$view}{$_}{type} eq 'bytea'){
1251 $_ = "substring($_,1,position(' '::bytea in $_)-1)";
1252 }
1253 }
1254
1255 my $query = "SELECT ";
1256 $query .= join(', ',@select_fields);
1257 $query .= " FROM $view";
1258
1259 # fix this for placeholders
1260
1261 my $first = 1;
1262 for my $field (keys(%$atribs)){
1263 if($first){
1264 $query .= " where ";
1265 }else{
1266 $query .= " and ";
1267 }
1268 my $value = $atribs->{$field};
1269 my $type = $g{db_fields}{$view}{$field}{type};
1270 if($type eq 'date') {
1271 $query .= " $field = '$value'";
1272 }
1273 elsif($type eq 'bool') {
1274 $query .= " $field = '$value'";
1275 }
1276 else {
1277 $query .= " $field ~* '.*$value.*'";
1278 }
1279 }
1280
1281 my $sth = $dbh->prepare($query) or return undef;
1282 $sth->execute() or return undef;
1283
1284 my (@row, $data);
1285
1286 $data=$sth->rows."\n";
1287
1288 $first = 1;
1289 my $numcolumns = scalar @select_fields;
1290 while(@row = $sth->fetchrow_array()) {
1291 $first = 1;
1292 for (0..$numcolumns-1){
1293 my $field=$row[$_];
1294 if(!$field||$field eq ""){
1295 $field = " ";
1296 }
1297
1298 if(not $first){
1299 $data.="\t";
1300 }
1301 $first = 0;
1302 $field =~ s/\t/\&\#09\;/gm;
1303 $field =~ s/\n/\&\#10\;/gm;
1304 $field =~ s/[\r\f]//gm;
1305
1306 $data .= $field;
1307 }
1308 $data .= "\n";
1309 }
1310 $sth->finish();
1311 if(length($data)>20000){
1312 $data = "Resultset exeeds desirable size.\n";
1313 }
1314 return $data;
1315 }
1316
1317 1;

  ViewVC Help
Powered by ViewVC 1.1.26