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