| 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; |
Parent Directory
| 
Revision Log