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

Annotation of /trunk/lib/perl/Gedafe/DB.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

1 dpavlin 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 dpavlin 4 'inet' => 'text(size=15)',
85 dpavlin 1 );
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