You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
1091 lines
32 KiB
1091 lines
32 KiB
#!/usr/bin/perl
|
|
#
|
|
# $Id: db.pl,v 1.3 2004/01/29 07:57:04 jeffo Exp $
|
|
#
|
|
# Source File: db.pl
|
|
|
|
print "Content-Type: text/html\n\n";
|
|
|
|
# Get config
|
|
use POSIX qw(iscntrl);
|
|
use Data::Dumper;
|
|
use logger;
|
|
use dm;
|
|
use toolbox;
|
|
|
|
my $dbopts = {
|
|
dbhost => $ENV{PGPORT} || `hostname`,
|
|
dbport => $ENV{PGPORT} || 5432,
|
|
dbname => $ENV{PGDATABASE} || 'template1',
|
|
dbuser => $ENV{PGUSER} || 'tmdba',
|
|
loadme => 1,
|
|
cache => 1,
|
|
};
|
|
chomp $dbopts->{dbhost};
|
|
|
|
my $dbversion;
|
|
my $cgi = "/cgi-bin/db.pl";
|
|
|
|
my %ri_cache;
|
|
|
|
sub numeric_type {
|
|
my ($table, $attname) = @_;
|
|
|
|
if ( $attname eq 'attnum' ||
|
|
$attname eq 'attnotnull' ||
|
|
$attname eq 'id' ||
|
|
$attname =~ /_id$/ ) {
|
|
return 1;
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
|
|
sub get_ri_info {
|
|
my ($table, $column, $keyval, $opts) = @_;
|
|
|
|
my $sql = qq{
|
|
SELECT t.tgargs
|
|
FROM pg_trigger t, pg_class c
|
|
WHERE c.relname= ?
|
|
AND c.oid = t.tgrelid
|
|
AND t.tgname like 'RI_ConstraintTrigger_%';
|
|
};
|
|
my $params;
|
|
push( @$params, $table );
|
|
|
|
my $cachekey = $column.$keyval.$sql.join('',@$params).join('',$opts);
|
|
|
|
my $data = ($ri_cache{$cachekey} ? $ri_cache{$cachekey} :
|
|
dm::SelectData($sql, $params, $opts) );
|
|
|
|
$ri_cache{$cachekey} = $data;
|
|
|
|
my $info = undef;
|
|
|
|
foreach my $href ( @$data ) {
|
|
($nm,$thistable,$ftable,$x,$fkey,$fcol) = split('\0',$href->{tgargs});
|
|
if ( $thistable eq $table && $column eq $fkey ) {
|
|
my $mkeyval = munge($keyval);
|
|
$info->{fcol} = $fcol;
|
|
$info->{ftable} = $ftable;
|
|
return { %$info };
|
|
}
|
|
}
|
|
|
|
return undef;
|
|
}
|
|
|
|
|
|
sub get_pkey_cols {
|
|
my ($table, $opts) = @_;
|
|
|
|
|
|
$depth = (defined($depth) ? $depth : 1);
|
|
|
|
my $sql = qq{
|
|
SELECT a.attname
|
|
FROM pg_class c, pg_attribute a
|
|
WHERE a.attnum > 0 AND a.attrelid = c.oid
|
|
AND c.relname = (
|
|
SELECT pkidx.relname
|
|
FROM pg_class c, pg_class pkidx, pg_index i
|
|
WHERE c.relname = ?
|
|
AND c.oid = i.indrelid
|
|
AND i.indexrelid = pkidx.oid
|
|
AND i.indisprimary
|
|
AND i.indisunique
|
|
ORDER BY pkidx.relname);
|
|
};
|
|
|
|
my $params = [ $table ];
|
|
my $pkeycols = &dm::SelectData($sql, $params, $opts);
|
|
|
|
return $pkeycols;
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
sub get_pkey_value {
|
|
my ($table, $fkeycol, $fkeyval, $opts, $depth) = @_;
|
|
|
|
|
|
$depth = (defined($depth) ? $depth : 1);
|
|
|
|
my $sql = qq{
|
|
SELECT a.attname
|
|
FROM pg_class c, pg_attribute a
|
|
WHERE a.attnum > 0 AND a.attrelid = c.oid
|
|
AND c.relname = (
|
|
SELECT pkidx.relname
|
|
FROM pg_class c, pg_class pkidx, pg_index i
|
|
WHERE c.relname = ?
|
|
AND c.oid = i.indrelid
|
|
AND i.indexrelid = pkidx.oid
|
|
AND i.indisprimary
|
|
AND i.indisunique
|
|
ORDER BY pkidx.relname);
|
|
};
|
|
|
|
my $params = [ $table ];
|
|
my $pkeycols = &dm::SelectData($sql, $params, $opts);
|
|
|
|
|
|
my $pkeyval;
|
|
my $info;
|
|
my $selectclause;
|
|
|
|
if ( ! $pkeycols ) {
|
|
return "";
|
|
}
|
|
|
|
foreach my $rec ( @$pkeycols ) {
|
|
|
|
$selectclause .= ", " if length($selectclause);
|
|
$selectclause .= $rec->{attname};
|
|
}
|
|
|
|
$sql = qq{
|
|
SELECT $selectclause
|
|
FROM $table
|
|
WHERE $fkeycol = ?;
|
|
};
|
|
$params = [ $fkeyval ];
|
|
$pkeyvals = &dm::SelectData($sql, $params, $opts);
|
|
|
|
foreach my $rec ( @$pkeyvals ) {
|
|
|
|
while ( my ($col, $val) = each %$rec ) {
|
|
$info = get_ri_info( $table, $col, $val, $opts );
|
|
$pkeyval .= ", " if length($pkeyval);
|
|
if ( $info ) {
|
|
$pkeyval .= get_pkey_value($info->{ftable}, $info->{fcol}, $val, $opts, $depth + 1);
|
|
} else {
|
|
$pkeyval .= $val;
|
|
}
|
|
}
|
|
}
|
|
|
|
return $pkeyval;
|
|
}
|
|
|
|
|
|
|
|
sub tabledescription {
|
|
my ($table, $opts) = @_;
|
|
|
|
my $sql = qq{
|
|
select obj_description(c.oid) as "Table Description"
|
|
from pg_class c
|
|
where c.relname = '$table';};
|
|
|
|
return dm::SelectDataValue($sql,undef,$opts);
|
|
}
|
|
|
|
|
|
|
|
sub dataview {
|
|
my ($opts) = @_;
|
|
|
|
&logger::logdbg("Entering dataview...");
|
|
my $sortdir = ($opts->{sd} eq 'dn' ? 'up' : 'dn');
|
|
my $sortbyidx;
|
|
my $offset = $opts->{off} ||= 0;
|
|
my $limit = $opts->{rc} || 10;
|
|
my $lastrec = $offset + $limit;
|
|
my $nextoffset;
|
|
my $extent = $limit;
|
|
my $table = $opts->{t};
|
|
my $pkeycols = get_pkey_cols($table, $opts);
|
|
my $sortby = $opts->{sb} || $pkeycols->[0]->{attname};
|
|
|
|
my $orderbyclause = $sortby;
|
|
$orderbyclause .= ($orderbyclause ? ($sortdir eq 'up' ? ' ASC' : ' DESC'):"");
|
|
|
|
for my $kcol ( @$pkeycols ) {
|
|
$orderbyclause .= ', ' if ($orderbyclause);
|
|
$orderbyclause .= "$kcol->{attname} ASC";
|
|
}
|
|
|
|
# gather pre-existing filters...
|
|
my $filters;
|
|
my $filterhash;
|
|
my $filternote;
|
|
my $whereclause;
|
|
my (@params, $col, $fop, $fopkey);
|
|
while ( my($key,$val) = each %$opts ) {
|
|
if ( $key =~ /^(_f)-(\S+)$/ ) {
|
|
$col = $2;
|
|
$fopkey = "${1}op-$col";
|
|
$fop = (defined($opts->{$fopkey}) ? $opts->{$fopkey} : '=');
|
|
$filters .= "&" if length($filters);
|
|
$filters .= "$key=$val";
|
|
$filters .= "&$fopkey=".munge($opts->{$fopkey});
|
|
$whereclause .= qq{
|
|
and } if ( length($whereclause) );
|
|
$whereclause .= qq{$col $fop ?};
|
|
push( @params, $val );
|
|
$filternote .= qq{<tr><th>Column</th><th>Op</th><th>Value</th></tr>\n} if ( ! length($filternote) );
|
|
$filternote .= qq{<tr><td>$col</td><td align="center">$fop</td><td>$val</td></tr>\n};
|
|
$filterhash->{$col}{fop} = $fop;
|
|
$filterhash->{$col}{val} = $val;
|
|
}
|
|
}
|
|
|
|
$opts->{pk} = (defined($opts->{pk}) ? $opts->{pk} : 1);
|
|
$opts->{sys} = (defined($opts->{sys}) ? $opts->{sys} : 0);
|
|
|
|
$filters .= "&ff=$opts->{ff}";
|
|
$filters .= "&sys=$opts->{sys}";
|
|
|
|
my $desc = tabledescription($table,$opts);
|
|
# Make sure these column headers don't have spaces for URI sorting...
|
|
my $sql = qq{
|
|
select *
|
|
from $table};
|
|
$sql .= qq{
|
|
where $whereclause} if ( length($whereclause) );
|
|
$sql .= qq{
|
|
order by $orderbyclause} if ( length($orderbyclause) );
|
|
$sql .= qq{
|
|
limit $limit
|
|
offset $offset;};
|
|
|
|
logger::logdbg($sql);
|
|
|
|
my $tmpopts = { %$opts };
|
|
$tmpopts->{want_array_refs} = 1;
|
|
my $data = dm::SelectData($sql, \@params, $tmpopts);
|
|
my $reccnt = scalar(@$data) - 1;
|
|
&logger::logdbg("Got $reccnt rows from DB...");
|
|
$sortby ||= $data->[0][0];
|
|
my $totreccnt = dm::SelectDataValue("select count(id) from $table",undef,$opts);
|
|
|
|
my ($html, $otherlabel, $labellink);
|
|
|
|
$html .= qq{<html>};
|
|
$html .= qq{<head>};
|
|
$html .= qq{</head>};
|
|
$html .= qq{<title>};
|
|
$html .= breadcrumb_label($opts);
|
|
$html .= qq{</title>};
|
|
$html .= qq{<body>};
|
|
$html .= breadcrumb($opts);
|
|
$html .= qq{<h1>Table: $table (Data)</h1>};
|
|
$html .= qq{<table border="1"><caption><b>Data Filters</b></caption>$filternote</table>\n} if ( length($filternote) );
|
|
$html .= "<table border=1>";
|
|
|
|
|
|
my $hdrrow;
|
|
my (@hdrs, $i);
|
|
foreach my $rowaref ( @$data ) {
|
|
$hdrrow = "<tr>";
|
|
foreach my $hdr ( @$rowaref ) {
|
|
my $thattrs = ($sortby eq $hdr ? qq{ bgcolor="#CCCCCC"} : "");
|
|
my $arrow = ($sortby eq $hdr ? ($sortdir eq 'up' ? ' ↓' : ' ↑') : "");
|
|
$arrow = qq{<font size="-3">$arrow</font>};
|
|
my $hdrlink = qq{<a href="$cgi?dbname=$opts->{dbname}&t=$table&v=data&sb=$hdr&sd=$sortdir&off=$nextoffset&rc=$extent&pk=$opts->{pk}};
|
|
$hdrlink .= qq{&$filters} if ( length($filters) );
|
|
$hdrlink .= qq{">$hdr</a>$arrow};
|
|
$hdrrow .= qq{<th$thattrs>$hdrlink</th>};
|
|
if ( $hdr eq $sortby ) {
|
|
$sortbyidx = $i;
|
|
}
|
|
push(@hdrs, $hdr);
|
|
$i++;
|
|
}
|
|
$hdrrow .= "</tr>\n";
|
|
last;
|
|
}
|
|
|
|
my $span = scalar(@hdrs);
|
|
$html .= qq{<tr><td colspan="$span"><b>Description:</b><i> $desc</i></td><tr>};
|
|
$html .= qq{<tr>};
|
|
$html .= qq{<td colspan="$span">};
|
|
$html .= qq{<a href="$cgi?dbname=$opts->{dbname}&t=$table&v=schema">View Schema</a>...};
|
|
$html .= qq{<a href="$cgi?dbname=$opts->{dbname}&t=$table&v=data&pk=$opts->{pk}">Reset Filters</a>...};
|
|
$html .= qq{<a href="$cgi?dbname=$opts->{dbname}&t=$table&v=data&$filters&sb=$opts->{sb}&sd=$opts->{sd}&off=$opts->{off}&rc=$opts->{rc}};
|
|
if ( $opts->{pk} ) {
|
|
$html .= qq{&pk=0">Hide Primary Keys</a>...};
|
|
} else {
|
|
$html .= qq{&pk=1">Show Primary Keys</a>...};
|
|
}
|
|
$html .= qq{<a href="$cgi?dbname=$opts->{dbname}&t=$table&v=data&pk=$opts->{pk}&$filters&sb=$opts->{sb}&sd=$opts->{sd}&off=$opts->{off}&rc=$opts->{rc}};
|
|
if ( $opts->{ff} ) {
|
|
$html .= qq{&ff=0">Hide Full Filters</a>...};
|
|
} else {
|
|
$html .= qq{&ff=1">Show Full Filters</a>...};
|
|
}
|
|
$opts->{fs} ||= 0;
|
|
my $bfs = $opts->{fs} + 1;
|
|
my $sfs = $opts->{fs} - 1;
|
|
|
|
$opts->{fs} = ($opts->{fs} >= 0 ? "+".$opts->{fs} : $opts->{fs});
|
|
$bfs = ($bfs >= 0 ? "+".$bfs : $bfs);
|
|
$sfs = ($sfs >= 0 ? "+".$sfs : $sfs);
|
|
|
|
$html .= qq{<a href="$cgi?dbname=$opts->{dbname}&t=$table&v=data&pk=$opts->{pk}&$filters&sb=$opts->{sb}&sd=$opts->{sd}&off=$opts->{off}&rc=$opts->{rc}};
|
|
$html .= qq{&fs=$sfs">Smaller Font</a>...};
|
|
$html .= qq{<a href="$cgi?dbname=$opts->{dbname}&t=$table&v=data&pk=$opts->{pk}&$filters&sb=$opts->{sb}&sd=$opts->{sd}&off=$opts->{off}&rc=$opts->{rc}};
|
|
$html .= qq{&fs=$bfs">Bigger Font</a>...};
|
|
|
|
$html .= qq{</td>} if ( length($filters) );
|
|
$html .= qq{</tr>\n};
|
|
|
|
$html .= $hdrrow;
|
|
|
|
shift @$data; # discard headers
|
|
|
|
my $sortf;
|
|
if ( $sortby ) {
|
|
if ( numeric_type($table, $sortby) ) {
|
|
if ( $sortdir eq 'dn' ) {
|
|
$sortf = sub { return $a->[$sortbyidx] <=> $b->[$sortbyidx]; };
|
|
} else {
|
|
$sortf = sub { return $b->[$sortbyidx] <=> $a->[$sortbyidx]; };
|
|
}
|
|
} else {
|
|
if ( $sortdir eq 'dn' ) {
|
|
$sortf = sub { return $a->[$sortbyidx] cmp $b->[$sortbyidx]; };
|
|
} else {
|
|
$sortf = sub { return $b->[$sortbyidx] cmp $a->[$sortbyidx]; };
|
|
}
|
|
}
|
|
} else {
|
|
$sortf = sub { return $a->[$sortbyidx] cmp $b->[$sortbyidx]; };
|
|
}
|
|
|
|
$i = 0;
|
|
my $fkeylink;
|
|
foreach my $rowaref ( @$data ) {
|
|
my $cellrow = "<tr>";
|
|
my $hi = 0;
|
|
foreach my $cell ( @$rowaref ) {
|
|
$fkeylink = undef;
|
|
my $info = get_ri_info( $table, $hdrs[$hi], $cell, $opts );
|
|
my $mval = munge($cell);
|
|
if ( $info && defined($cell) ) {
|
|
if ( $opts->{pk} ) {
|
|
my $pkeyval = get_pkey_value($info->{ftable}, $info->{fcol}, $cell, $opts);
|
|
$cell = $pkeyval;
|
|
}
|
|
$fkeylink = qq{t=$info->{ftable}&_f-$info->{fcol}=$mval};
|
|
$fkeylink = qq{<a href="$cgi?dbname=$opts->{dbname}&$fkeylink&v=data">$cell</a>};
|
|
}
|
|
$cellrow .= qq{<td>};
|
|
$cellrow .= qq{<font size="$opts->{fs}">} if (defined($opts->{fs}));
|
|
|
|
my ($filterlink, $op, $foplinks);
|
|
|
|
if ( defined($fkeylink) ) {
|
|
$cellrow .= qq{$fkeylink};
|
|
} else {
|
|
if ( ! $opts->{ff} ) {
|
|
$op = '=';
|
|
$fop = ($op);
|
|
$fopkey = "_fop-$hdrs[$hi]";
|
|
$filterlink = "";
|
|
$filterlink .= qq{$filters&} if $filters;
|
|
$filterlink .= qq{_f-$hdrs[$hi]=$mval&$fopkey=};
|
|
$filterlink .= munge($fop);
|
|
$cellrow .= qq{<a href="$cgi?dbname=$opts->{dbname}&t=$table&$filterlink&v=data&pk=$opts->{pk}">$cell</a>};
|
|
} else {
|
|
$cellrow .= qq{$cell};
|
|
}
|
|
}
|
|
|
|
|
|
$op = '<';
|
|
$fop = ($op);
|
|
$fopkey = "_fop-$hdrs[$hi]";
|
|
$filterlink = "";
|
|
$filterlink .= qq{$filters&} if $filters;
|
|
$filterlink .= qq{_f-$hdrs[$hi]=$mval&$fopkey=};
|
|
$filterlink .= munge($fop);
|
|
$foplinks .= qq{<a href="$cgi?dbname=$opts->{dbname}&t=$table&$filterlink&v=data&pk=$opts->{pk}">};
|
|
$foplinks .= escape_special_chars($op);
|
|
$foplinks .= qq{</a>};
|
|
$foplinks .= qq{...};
|
|
|
|
$op = '<=';
|
|
$fop = ($op);
|
|
$fopkey = "_fop-$hdrs[$hi]";
|
|
$filterlink = "";
|
|
$filterlink .= qq{$filters&} if $filters;
|
|
$filterlink .= qq{_f-$hdrs[$hi]=$mval&$fopkey=};
|
|
$filterlink .= munge($fop);
|
|
$foplinks .= qq{<a href="$cgi?dbname=$opts->{dbname}&t=$table&$filterlink&v=data&pk=$opts->{pk}">};
|
|
$foplinks .= escape_special_chars($op);
|
|
$foplinks .= qq{</a>};
|
|
$foplinks .= qq{...};
|
|
|
|
$op = '=';
|
|
$fop = ($op);
|
|
$fopkey = "_fop-$hdrs[$hi]";
|
|
$filterlink = "";
|
|
$filterlink .= qq{$filters&} if $filters;
|
|
$filterlink .= qq{_f-$hdrs[$hi]=$mval&$fopkey=};
|
|
$filterlink .= munge($fop);
|
|
$foplinks .= qq{<a href="$cgi?dbname=$opts->{dbname}&t=$table&$filterlink&v=data&pk=$opts->{pk}">};
|
|
$foplinks .= escape_special_chars($op);
|
|
$foplinks .= qq{</a>};
|
|
$foplinks .= qq{...};
|
|
|
|
$op = '>=';
|
|
$fop = ($op);
|
|
$fopkey = "_fop-$hdrs[$hi]";
|
|
$filterlink = "";
|
|
$filterlink .= qq{$filters&} if $filters;
|
|
$filterlink .= qq{_f-$hdrs[$hi]=$mval&$fopkey=};
|
|
$filterlink .= munge($fop);
|
|
$foplinks .= qq{<a href="$cgi?dbname=$opts->{dbname}&t=$table&$filterlink&v=data&pk=$opts->{pk}">};
|
|
$foplinks .= escape_special_chars($op);
|
|
$foplinks .= qq{</a>};
|
|
$foplinks .= qq{...};
|
|
|
|
$op = '>';
|
|
$fop = ($op);
|
|
$fopkey = "_fop-$hdrs[$hi]";
|
|
$filterlink = "";
|
|
$filterlink .= qq{$filters&} if $filters;
|
|
$filterlink .= qq{_f-$hdrs[$hi]=$mval&$fopkey=};
|
|
$filterlink .= munge($fop);
|
|
$foplinks .= qq{<a href="$cgi?dbname=$opts->{dbname}&t=$table&$filterlink&v=data&pk=$opts->{pk}">};
|
|
$foplinks .= escape_special_chars($op);
|
|
$foplinks .= qq{</a>};
|
|
|
|
|
|
if ( $opts->{ff} ) {
|
|
$cellrow .= qq{ <font size="-2"><br><nobr>(};
|
|
$cellrow .= $foplinks;
|
|
$cellrow .= qq{)</nobr</font>};
|
|
}
|
|
$cellrow .= qq{</font>} if ( defined($opts->{fs}) );
|
|
$cellrow .= qq{</td>};
|
|
|
|
$hi++;
|
|
}
|
|
$cellrow .= "</tr>\n";
|
|
$html .= "$cellrow\n";
|
|
}
|
|
|
|
my $navlink;
|
|
$html .= "<tr><td colspan=$span>";
|
|
$html .= qq{<i>($reccnt of $totreccnt from $table table)</i> };
|
|
logger::logdbg("offset = $offset, reccnt = $reccnt, lastrec = $lastrec");
|
|
if ( $offset > 0 ) {
|
|
$nextoffset = ($offset - $extent < 0 ? 0 : $offset - $extent);
|
|
$navlink = qq{<a href="$cgi?dbname=$opts->{dbname}&t=$table&v=data&sb=$sortby&sd=$opts->{sd}&off=$nextoffset&rc=$extent">[Previous $extent...]</a>};
|
|
$html .= "$navlink ";
|
|
|
|
$extent *= 2;
|
|
$nextoffset = ($offset - $extent < 0 ? 0 : $offset - $extent);
|
|
$navlink = qq{<a href="$cgi?dbname=$opts->{dbname}&t=$table&v=data&sb=$sortby&sd=$opts->{sd}&off=$nextoffset&rc=$extent">[Previous $extent...]</a>};
|
|
$html .= "$navlink ";
|
|
}
|
|
|
|
$extent = $limit;
|
|
if ( $totreccnt > $lastrec ) {
|
|
$nextoffset = $lastrec;
|
|
$navlink = qq{<a href="$cgi?dbname=$opts->{dbname}&t=$table&v=data&sb=$sortby&sd=$opts->{sd}&off=$nextoffset&rc=$extent">[Next $extent...]</a>};
|
|
$html .= "$navlink ";
|
|
|
|
$extent *= 2;
|
|
$navlink = qq{<a href="$cgi?dbname=$opts->{dbname}&t=$table&v=data&sb=$sortby&sd=$opts->{sd}&off=$nextoffset&rc=$extent">[Next $extent...]</a>};
|
|
$html .= "$navlink ";
|
|
}
|
|
$html .= "</td></tr>\n";
|
|
$html .= "</table>\n";
|
|
|
|
&logger::logdbg("Exiting schemaview...");
|
|
|
|
return $html;
|
|
}
|
|
|
|
|
|
sub schemaview {
|
|
my ($opts) = @_;
|
|
|
|
&logger::logdbg("Entering schemaview...");
|
|
my $table = $opts->{t};
|
|
my $desc = tabledescription($table,$opts);
|
|
# Make sure these column headers don't have spaces for URI sorting...
|
|
my $sql = qq{
|
|
SELECT a.attnum, a.attname, format_type(a.atttypid, a.atttypmod),
|
|
a.attnotnull, a.atthasdef,
|
|
'<i>'||col_description(a.attrelid, a.attnum)||'</a>' as "description"
|
|
FROM pg_class c, pg_attribute a
|
|
WHERE c.relname = '$table'
|
|
AND a.attnum > 0 AND a.attrelid = c.oid
|
|
ORDER BY a.attnum;
|
|
};
|
|
my $tmpopts = { %$opts };
|
|
$tmpopts->{want_array_refs} = 1;
|
|
my $data = dm::SelectData($sql, undef, $tmpopts);
|
|
|
|
my ($html, $otherlabel, $labellink);
|
|
|
|
$html = qq{<html>};
|
|
$html .= qq{<head>};
|
|
$html .= qq{</head>};
|
|
$html .= qq{<title>};
|
|
$html .= breadcrumb_label($opts);
|
|
$html .= qq{</title>};
|
|
$html .= qq{<body>};
|
|
$html .= breadcrumb($opts);
|
|
$html .= qq{<h1>Table: $table (Schema)</h1>};
|
|
$html .= "<table border=1>";
|
|
|
|
my $sortdir = ($opts->{sd} eq 'dn' ? 'up' : 'dn');
|
|
my $sortby = $opts->{sb} ||= $data->[0][0];
|
|
my $sortbyidx;
|
|
|
|
|
|
my $hdrrow;
|
|
my (@hdrs, $i);
|
|
foreach my $rowaref ( @$data ) {
|
|
$hdrrow = "<tr>";
|
|
foreach my $hdr ( @$rowaref ) {
|
|
my $thattrs = ($sortby eq $hdr ? qq{ bgcolor="#CCCCCC"} : "");
|
|
my $arrow = ($sortby eq $hdr ? ($sortdir eq 'up' ? ' ↓' : ' ↑') : "");
|
|
$arrow = qq{<font size="-3">$arrow</font>};
|
|
my $hdrlink = qq{<a href="$cgi?dbname=$opts->{dbname}&t=$table&v=schema&sb=$hdr&sd=$sortdir">$hdr</a>$arrow};
|
|
$hdrrow .= qq{<th$thattrs>$hdrlink</th>};
|
|
if ( $hdr eq $sortby ) {
|
|
$sortbyidx = $i;
|
|
}
|
|
push(@hdrs, $hdr);
|
|
$i++;
|
|
}
|
|
$hdrrow .= "</tr>\n";
|
|
last;
|
|
}
|
|
|
|
my $span = scalar(@hdrs);
|
|
$html .= qq{<tr><td colspan="$span"><b>Description:</b><i> $desc</i></td><tr>};
|
|
$html .= qq{<tr>};
|
|
$html .= qq{<td colspan="$span">};
|
|
$html .= qq{<a href="$cgi?dbname=$opts->{dbname}&t=$table&v=data">View Data</a>};
|
|
$html .= qq{</td>};
|
|
$html .= qq{</tr>\n};
|
|
|
|
$html .= $hdrrow;
|
|
|
|
shift @$data; # discard headers
|
|
|
|
my $sortf;
|
|
if ( $sortby ) {
|
|
if ( numeric_type($table, $sortby) ) {
|
|
if ( $sortdir eq 'dn' ) {
|
|
$sortf = sub { return $a->[$sortbyidx] <=> $b->[$sortbyidx]; };
|
|
} else {
|
|
$sortf = sub { return $b->[$sortbyidx] <=> $a->[$sortbyidx]; };
|
|
}
|
|
} else {
|
|
if ( $sortdir eq 'dn' ) {
|
|
$sortf = sub { return $a->[$sortbyidx] cmp $b->[$sortbyidx]; };
|
|
} else {
|
|
$sortf = sub { return $b->[$sortbyidx] cmp $a->[$sortbyidx]; };
|
|
}
|
|
}
|
|
} else {
|
|
$sortf = sub { return $a->[$sortbyidx] cmp $b->[$sortbyidx]; };
|
|
}
|
|
|
|
|
|
&logger::logdbg("There are ".scalar(@$data)." rows.");
|
|
foreach my $rowaref ( sort $sortf @$data ) {
|
|
my $cellrow = "<tr>";
|
|
foreach my $cell ( @$rowaref ) {
|
|
$cellrow .= qq{<td>$cell</td>};
|
|
}
|
|
$cellrow .= "</tr>\n";
|
|
$html .= $cellrow;
|
|
}
|
|
|
|
$html .= "</table>\n";
|
|
|
|
&logger::logdbg("Exiting schemaview...");
|
|
|
|
return $html;
|
|
}
|
|
|
|
|
|
sub tableview {
|
|
my ($opts) = @_;
|
|
|
|
if ( $opts->{v} eq 'schema' ) {
|
|
return schemaview($opts);
|
|
} else {
|
|
return dataview($opts);
|
|
}
|
|
}
|
|
|
|
|
|
sub dbviewhome {
|
|
my ($opts) = @_;
|
|
|
|
my $sql = qq{
|
|
select tablename as "Table"
|
|
from pg_tables};
|
|
|
|
if ( ! $opts->{sys} ) {
|
|
$sql .= qq{
|
|
where tablename not like 'pg_%'};
|
|
}
|
|
|
|
$sql .= qq{
|
|
order by tablename};
|
|
$sql .= ';';
|
|
|
|
my $tmpopts = { %$opts };
|
|
$tmpopts->{want_array_refs} = 1;
|
|
my $data = dm::SelectData($sql, undef, $tmpopts);
|
|
|
|
my ($html, $otherlabel, $labellink);
|
|
|
|
$html = qq{<html>};
|
|
$html .= qq{<head>};
|
|
$html .= qq{</head>};
|
|
$html .= qq{<title>};
|
|
$html .= breadcrumb_label($opts);
|
|
$html .= qq{</title>};
|
|
$html .= qq{<body>};
|
|
$html .= breadcrumb($opts);
|
|
$html .= "<table border=1>";
|
|
my $sortdir = ($opts->{sd} eq 'dn' ? 'up' : 'dn');
|
|
&logger::logdbg("sd = $opts->{sd} ===> sortdir = $sortdir");
|
|
my $sortby = $opts->{sb} || 'name';
|
|
my $tablehdr = qq{<a href="$cgi?dbname=$opts->{dbname}&sb=name&sd=$sortdir&sys=$opts->{sys}">Table</a>};
|
|
my $cnthdr = qq{<a href="$cgi?dbname=$opts->{dbname}&sb=count&sd=$sortdir&sys=$opts->{sys}">Record Count</a>};
|
|
my $tablehdrattrs = ($sortby eq 'name' ? qq{ bgcolor="#CCCCCC"} : "");
|
|
my $cnthdrattrs = ($sortby eq 'count' ? qq{ bgcolor="#CCCCCC"} : "");
|
|
$html .= "<tr><th$tablehdrattrs>$tablehdr</th><th$cnthdrattrs>$cnthdr</th><th>Description</th></tr>\n";
|
|
|
|
my $i = 0;
|
|
my $table;
|
|
my @recs;
|
|
|
|
$opts->{sys} = (defined($opts->{sys}) ? $opts->{sys} : 0);
|
|
|
|
foreach my $aref ( @$data ) {
|
|
next if ($i++ == 0);
|
|
|
|
my $v = shift @$aref;
|
|
my $table = (defined($v) ? $v : "");
|
|
$sql = qq{select count(*) from $table;};
|
|
my $count = dm::SelectDataValue($sql, undef, $opts);
|
|
push( @recs, { table => $table, count => $count } );
|
|
}
|
|
|
|
my $sortf;
|
|
|
|
if ( $sortby eq 'name' ) {
|
|
if ( $sortdir eq 'dn' ) {
|
|
$sortf = sub { return $a->{table} cmp $b->{table}; };
|
|
} else {
|
|
$sortf = sub { return $b->{table} cmp $a->{table}; };
|
|
}
|
|
} else {
|
|
if ( $sortdir eq 'dn' ) {
|
|
$sortf = sub { return $a->{count} <=> $b->{count}; };
|
|
} else {
|
|
$sortf = sub { return $b->{count} <=> $a->{count}; };
|
|
}
|
|
}
|
|
|
|
|
|
foreach my $href ( sort $sortf @recs ) {
|
|
my $row = "<tr>";
|
|
my $j = 0;
|
|
|
|
my $table = $href->{table};
|
|
my $count = $href->{count};
|
|
my $desc = tabledescription($table,$opts);
|
|
$row .= qq{<td><a href="$cgi?dbname=$opts->{dbname}&t=$table&v=schema&sys=$opts->{sys}">$table</a></td>};
|
|
$row .= qq{<td align="center"><a href="$cgi?dbname=$opts->{dbname}&t=$table&v=data&sys=$opts->{sys}">$count</a></td>};
|
|
$row .= qq{<td align="left"><font size="-2">$desc</font></td>};
|
|
$row .= "</tr>\n";
|
|
|
|
$html .= $row;
|
|
}
|
|
$html .= "</table>\n";
|
|
|
|
return $html;
|
|
}
|
|
|
|
sub serverview {
|
|
my ($opts) = @_;
|
|
|
|
my $sql = qq{
|
|
select datname as "Database"
|
|
from pg_database};
|
|
|
|
if ( ! $opts->{sys} ) {
|
|
$sql .= qq{
|
|
where datname !~ 'template[01]'};
|
|
}
|
|
|
|
$sql .= qq{
|
|
order by datname;
|
|
};
|
|
|
|
my $tmpopts = { %$opts };
|
|
# $tmpopts->{want_array_refs} = 1;
|
|
my $data = dm::SelectData($sql, undef, $tmpopts);
|
|
|
|
my ($html, $otherlabel, $labellink);
|
|
|
|
$html = breadcrumb($opts);
|
|
$html .= qq{<h1>$opts->{dbhost}:$opts->{dbport}</h1>};
|
|
$html .= qq{<font size="-1"><b>Version:</b> <i>$dbversion</i></font>};
|
|
$html .= "<table border=1>";
|
|
my $sortdir = ($opts->{sd} eq 'dn' ? 'up' : 'dn');
|
|
my $sortby = $opts->{sb} || 'datname';
|
|
my $dbhdr = qq{<a href="$cgi?sb=name&sd=$sortdir&sys=$opts->{sys}">Database</a>};
|
|
my $dbhdrattrs = ($sortby eq 'datname' ? qq{ bgcolor="#CCCCCC"} : "");
|
|
$html .= "<tr><th$dbhdrattrs>$dbhdr</th></tr>\n";
|
|
|
|
my $i = 0;
|
|
my $table;
|
|
my @recs;
|
|
|
|
$opts->{sys} = (defined($opts->{sys}) ? $opts->{sys} : 0);
|
|
|
|
my $sortf;
|
|
|
|
if ( $sortdir eq 'dn' ) {
|
|
$sortf = sub { return $a->{$sortby} cmp $b->{$sortby}; };
|
|
} else {
|
|
$sortf = sub { return $b->{$sortby} cmp $a->{$sortby}; };
|
|
}
|
|
|
|
print STDERR Dumper($data);
|
|
|
|
foreach my $href ( sort $sortf @$data ) {
|
|
my $row = "<tr>";
|
|
my $j = 0;
|
|
|
|
my $db = $href->{Database};
|
|
$row .= qq{<td><a href="$cgi?dbv=1&dbname=$db">$db</a></td>};
|
|
$row .= "</tr>\n";
|
|
|
|
$html .= $row;
|
|
}
|
|
$html .= "</table>\n";
|
|
|
|
return $html;
|
|
}
|
|
|
|
sub dbview {
|
|
my ($opts) = @_;
|
|
|
|
if ( $opts->{t} ) {
|
|
return tableview($opts);
|
|
} else {
|
|
return dbviewhome($opts);
|
|
}
|
|
}
|
|
|
|
sub munge( $ ) {
|
|
my ($string) = @_;
|
|
$string =~ s/([\<\>\=\'\"\?\&\\!\$\#\@\*\;\:\r\n])/join('', '%', uc(unpack("H*",$1)))/eg;
|
|
return $string;
|
|
}
|
|
|
|
sub unmunge( $ ) {
|
|
my ($string) = @_;
|
|
$string =~ s/%([<>=a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
|
|
return $string;
|
|
}
|
|
|
|
my $escape_map = {
|
|
'"' => '"',
|
|
'&' => '&',
|
|
'<' => '<',
|
|
'>' => '>',
|
|
'<=' => '≤',
|
|
'=' => '=',
|
|
'=>' => '≥',
|
|
};
|
|
|
|
sub get_escape( $ ) {
|
|
my ($char) = shift;
|
|
if ( ! defined($escape_map->{$char}) ) {
|
|
logger::logerr("WARNING: undefined escape for '$char'");
|
|
}
|
|
return $escape_map->{$char};
|
|
}
|
|
|
|
sub escape_special_chars( $ ) {
|
|
my ($string) = @_;
|
|
$string =~ s/([\"&<>=])/get_escape($1)/eg;
|
|
return $string;
|
|
}
|
|
|
|
sub initialize {
|
|
my ($FORM) = @_;
|
|
|
|
if ( ! $FORM ) {
|
|
&logger::logerr("Missing FORM hashref");
|
|
return undef;
|
|
}
|
|
|
|
my ($reqmeth,@cookies,$cookie,$nm,$vlu,$qstr);
|
|
my ($contenttype,$srch,$trash,$boundary,$endboundary,$consep,@parts,);
|
|
my ($contype,$content,%UI,%COOKIES,$part,@lines,$nme,$fname,$ftype,$line);
|
|
my (@segs,$arraykey,%UPLOADED_FILES,@parameters,$pair);
|
|
|
|
&logger::logdbg("Initializing...");
|
|
|
|
$FORM->{servertime} = POSIX::strftime($UI{DATETIME_FMT}, localtime(time));
|
|
# set variables from query parameters based on the request method
|
|
$reqmeth = $ENV{'REQUEST_METHOD'};
|
|
@cookies = split(/\;/,$ENV{'HTTP_COOKIE'});
|
|
foreach $cookie (sort @cookies) {
|
|
($nm, $vlu) = split(/=/, $cookie);
|
|
$nm =~ s/ //g;
|
|
$vlu =~ tr/+/ /;
|
|
$vlu = unmunge($vlu);
|
|
$COOKIES{$nm} = $vlu;
|
|
&logger::logdbg("\$COOKIES{$nm} = $COOKIES{$nm}");
|
|
}
|
|
if ($reqmeth =~ /POST/i) {
|
|
&logger::logdbg("Reading POST data...");
|
|
read (STDIN, $qstr, $ENV{'CONTENT_LENGTH'});
|
|
} else {
|
|
if ($reqmeth =~ /GET/i) {
|
|
&logger::logdbg("Reading GET data...");
|
|
$qstr=$ENV{'QUERY_STRING'};
|
|
} else {
|
|
&logger::logdbg("Unrecognized request method: [$reqmeth]");
|
|
}
|
|
}
|
|
|
|
&logger::logdbg("qstr = $qstr");
|
|
|
|
if ($qstr) {
|
|
$contenttype=$ENV{'CONTENT_TYPE'};
|
|
if ($contenttype =~ 'multipart/form-data') {
|
|
$srch="boundary\=";
|
|
($trash,$boundary) = split(/$srch/, $contenttype);
|
|
($boundary, $trash) = split(/ /, $boundary);
|
|
$endboundary = join('', $boundary, "\-\-");
|
|
$boundary = join('', $boundary, "\r\n");
|
|
($qstr, $trash) = split(/$endboundary/, $qstr);
|
|
@parts = split(/$boundary/, $qstr);
|
|
$trash = shift @parts;
|
|
$consep = "\r\n\r\n";
|
|
foreach $part (@parts) {
|
|
($contype, $content) = split(/$consep/, $part);
|
|
if ($contype ne '') {
|
|
$contype =~ s/\: /=/g;
|
|
$contype =~ s/\r\n/; /g;
|
|
@lines = split(/\; /, $contype);
|
|
$nme = "";
|
|
$fname = "";
|
|
$ftype = "";
|
|
foreach $line (@lines) {
|
|
$line =~ s/\"//g;
|
|
($nm,$vlu) = split(/=/, $line);
|
|
$vlu =~ tr/+/ /;
|
|
$vlu = unmunge($vlu);
|
|
if ($nm eq 'filename') {
|
|
@segs = split(/\./, $vlu);
|
|
$ftype = $segs[$#segs];
|
|
} else {
|
|
if ($nm eq 'name') {
|
|
$nme = $vlu;
|
|
}
|
|
}
|
|
}
|
|
chop($content);
|
|
chop($content);
|
|
if ($ftype eq '') {
|
|
if ($content =~ /\<RAWHTML\>/ ) {
|
|
$content =~ s/\<RAWHTML\>//g;
|
|
chop($content);
|
|
chop($content);
|
|
} else {
|
|
$content =~ s/\r\n//g;
|
|
}
|
|
$content =~ tr/+/ /;
|
|
$content = unmunge($content);
|
|
if ($FORM->{$nme} eq '') {
|
|
$FORM->{$nme} = $content;
|
|
} else {
|
|
$FORM->{$nme} = join(',', $FORM->{$nme}, $content);
|
|
}
|
|
} else {
|
|
if ($ftype eq 'csv') {
|
|
$content =~ s/\r//g;
|
|
$content =~ s/\n\n/\n/g;
|
|
} else {
|
|
$content =~ s/(.*)\r\n/$1/;
|
|
}
|
|
$arraykey="$nme.$ftype";
|
|
$UPLOADED_FILES{$arraykey} = $content;
|
|
}
|
|
}
|
|
}
|
|
} else {
|
|
# parse request parameters into variables
|
|
@parameters = split(/&/, $qstr);
|
|
foreach $pair (@parameters) {
|
|
($nm, $vlu) = split(/=/, $pair);
|
|
$vlu =~ tr/+/ /;
|
|
$vlu = unmunge($vlu);
|
|
$FORM->{$nm} = $vlu;
|
|
}
|
|
}
|
|
foreach my $key ( sort keys %$FORM ) {
|
|
&logger::logdbg("\$FORM{$key} = '$FORM->{$key}'");
|
|
}
|
|
return 1;
|
|
} else {
|
|
return 0;
|
|
}
|
|
}
|
|
|
|
sub breadcrumb_label {
|
|
my ($opts) = @_;
|
|
|
|
my ($breadcrumb, $label);
|
|
|
|
if ( $opts->{dbhost} ) {
|
|
$label .= qq{$opts->{dbhost}};
|
|
}
|
|
|
|
if ( $opts->{dbport} ) {
|
|
$label .= ":$opts->{dbport}";
|
|
}
|
|
|
|
$breadcrumb .= qq{$label};
|
|
|
|
if ( $opts->{dbname} ) {
|
|
$label = ":$opts->{dbname}";
|
|
} else {
|
|
return $breadcrumb;
|
|
}
|
|
|
|
if ( $opts->{t} ) {
|
|
$label .= ":$opts->{t}";
|
|
} else {
|
|
return $breadcrumb;
|
|
}
|
|
|
|
if ( $opts->{v} ) {
|
|
$label .= " ($opts->{v})";
|
|
}
|
|
|
|
$breadcrumb .= qq{$label};
|
|
|
|
return $breadcrumb;
|
|
}
|
|
|
|
|
|
sub breadcrumb {
|
|
my ($opts) = @_;
|
|
|
|
my ($hiddenargs, $fmtbegin, $fmtend);
|
|
my ($breadcrumb, $args, $label, $fs);
|
|
|
|
$fs = (defined($opts->{fs}) ? ($opts->{fs} - 1) : -1);
|
|
$fs = "+$fs" if ( $fs >= 0 );
|
|
|
|
$fmtbegin = qq{<font size="$fs" color="blue">};
|
|
$fmtend = qq{</font>};
|
|
$separator = qq{...};
|
|
|
|
my @hiddenargs = qw( fs ff pk );
|
|
foreach my $harg ( @hiddenargs ) {
|
|
if ( $opts->{$harg} ) {
|
|
$hiddenargs .= qq{&} if length($hiddenargs);
|
|
$hiddenargs .= qq{$harg=$opts->{$harg}};
|
|
}
|
|
}
|
|
|
|
if ( $opts->{dbhost} ) {
|
|
$args .= qq{dbhost=$opts->{dbhost}};
|
|
$label .= qq{$opts->{dbhost}};
|
|
}
|
|
|
|
if ( $opts->{dbport} ) {
|
|
$args .= qq{&} if length($args);
|
|
$args .= qq{dbport=$opts->{dbport}};
|
|
$label .= ":$opts->{dbport}";
|
|
}
|
|
|
|
$breadcrumb .= qq{$fmtbegin<a href="$cgi?$args&$hiddenargs">$label</a>$fmtend};
|
|
|
|
if ( $opts->{dbname} ) {
|
|
$args = qq{&} if length($args);
|
|
$args .= qq{dbname=$opts->{dbname}};
|
|
$label = "$opts->{dbname}";
|
|
} else {
|
|
return $breadcrumb;
|
|
}
|
|
|
|
$breadcrumb .= qq{$separator$fmtbegin<a href="$cgi?$args&$hiddenargs">$label</a>$fmtend};
|
|
|
|
if ( $opts->{t} ) {
|
|
$args .= qq{&} if length($args);
|
|
$args .= qq{t=$opts->{t}};
|
|
$label = "$opts->{t}";
|
|
} else {
|
|
return $breadcrumb;
|
|
}
|
|
|
|
if ( $opts->{v} ) {
|
|
$args .= qq{&} if length($args);
|
|
$args .= qq{v=$opts->{v}};
|
|
$label .= " ($opts->{v})";
|
|
}
|
|
|
|
$breadcrumb .= qq{$separator$fmtbegin<a href="$cgi?$args&$hiddenargs">$label</a>$fmtend};
|
|
|
|
return $breadcrumb;
|
|
}
|
|
|
|
|
|
sub go {
|
|
my %FORM;
|
|
initialize(\%FORM);
|
|
foreach my $key ( keys %FORM ) {
|
|
$dbopts->{$key} = $FORM{$key};
|
|
}
|
|
|
|
$dbversion = dm::SelectDataValue("select version();", undef, $dbopts);
|
|
|
|
my $html;
|
|
my $t0 = toolbox::NowAsScalar();
|
|
if ( defined($dbopts->{dbname}) && $dbopts->{dbname} !~ /^template[01]$/ ) {
|
|
$html = &dbview($dbopts);
|
|
} else {
|
|
$html = &serverview($dbopts);
|
|
}
|
|
|
|
$html .= qq{<hr><font color="blue" size="-2">};
|
|
|
|
my $tf = toolbox::NowAsScalar();
|
|
my $size = length($html);
|
|
$html .= sprintf("Generated %.1f KB in %.3f secs finishing %s<br>\n",
|
|
($size/1000), $tf - $t0, scalar(localtime(time)));
|
|
|
|
$t0 = toolbox::NowAsScalar();
|
|
print $html;
|
|
$tf = toolbox::NowAsScalar();
|
|
|
|
$html = sprintf("Transmitted %.1f KB in %.3f secs finishing %s\n",
|
|
($size/1000), $tf - $t0, scalar(localtime(time)));
|
|
$html .= qq{</body>};
|
|
$html .= qq{</html>};
|
|
print $html;
|
|
}
|
|
|
|
&go();
|
|
|
|
1;
|
|
|