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.
446 lines
13 KiB
446 lines
13 KiB
4 months ago
|
#!/usr/bin/perl
|
||
|
|
#
|
||
|
|
# $Id: dbreport.pl,v 1.3 2004/01/29 07:57:04 jeffo Exp $
|
||
|
|
#
|
||
|
|
|
||
|
|
# Generic report generation code. See schema description at
|
||
|
|
# http://.../cgi-bin/db.pl for details.
|
||
|
|
|
||
|
|
print "Content-Type: text/html\n\n";
|
||
|
|
|
||
|
|
# Get config
|
||
|
|
use POSIX qw(iscntrl);
|
||
|
|
use Data::Dumper;
|
||
|
|
use logger;
|
||
|
|
use dm;
|
||
|
|
use toolbox;
|
||
|
|
|
||
|
|
my $debug = 1;
|
||
|
|
|
||
|
|
my $dbopts = {
|
||
|
|
dbhost => $ENV{PGPORT} || `hostname`,
|
||
|
|
dbport => $ENV{PGPORT} || 5432,
|
||
|
|
dbname => $ENV{PGDATABASE} || 'tmdb',
|
||
|
|
dbuser => $ENV{PGUSER} || 'wwwrun',
|
||
|
|
loadme => 1,
|
||
|
|
cache => 1,
|
||
|
|
};
|
||
|
|
chomp $dbopts->{dbhost};
|
||
|
|
|
||
|
|
my $dbversion;
|
||
|
|
my $cgi = "/cgi-bin/db.pl";
|
||
|
|
|
||
|
|
|
||
|
|
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 TextElement {
|
||
|
|
my ($form, $dbopts, $value) = @_;
|
||
|
|
|
||
|
|
return $value;
|
||
|
|
}
|
||
|
|
|
||
|
|
#############################################################################
|
||
|
|
sub SQLElement {
|
||
|
|
my ($form, $dbopts, $value) = @_;
|
||
|
|
|
||
|
|
my ($out, $results);
|
||
|
|
my $sql = $value;
|
||
|
|
my $qopts = { %$dbopts };
|
||
|
|
$qopts->{want_array_refs} = 1;
|
||
|
|
if ( $sql =~ /^\s*SELECT\s+/i && $sql !~ /\s+INTO\s+/i ) {
|
||
|
|
$results = dm::SelectData($sql, undef, $qopts);
|
||
|
|
} else {
|
||
|
|
$results = dm::ModifyData($sql, undef, $qopts);
|
||
|
|
}
|
||
|
|
foreach my $row ( @$results ) {
|
||
|
|
foreach my $col ( @$row ) {
|
||
|
|
$out .= $col;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
return $out;
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
#############################################################################
|
||
|
|
sub CodeElement {
|
||
|
|
my ($form, $dbopts, $value) = @_;
|
||
|
|
|
||
|
|
my ($out, $results);
|
||
|
|
my $results = eval $value;
|
||
|
|
if ( $@ ) {
|
||
|
|
logger::logerr("Evaluation failed for [$value]: $@");
|
||
|
|
} else {
|
||
|
|
$out = $results;
|
||
|
|
}
|
||
|
|
|
||
|
|
return $out;
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
#############################################################################
|
||
|
|
sub FileElement {
|
||
|
|
my ($form, $dbopts, $value) = @_;
|
||
|
|
|
||
|
|
my $out;
|
||
|
|
if ( open(INFILE, "< $value") ) {
|
||
|
|
while ( <INFILE> ) {
|
||
|
|
$out .= $_;
|
||
|
|
}
|
||
|
|
close INFILE;
|
||
|
|
} else {
|
||
|
|
logger::logerr("Could not open $value: $!");
|
||
|
|
}
|
||
|
|
|
||
|
|
return $out;
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
#############################################################################
|
||
|
|
sub SQLFileElement {
|
||
|
|
my ($form, $dbopts, $value) = @_;
|
||
|
|
return SQLElement($form, $dbopts, FileElement($form, $dbopts, $value));
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
#############################################################################
|
||
|
|
sub CodeFileElement {
|
||
|
|
my ($form, $dbopts, $value) = @_;
|
||
|
|
return CodeElement($form, $dbopts, FileElement($form, $dbopts, $value));
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
#############################################################################
|
||
|
|
sub showreport {
|
||
|
|
my ($form, $dbopts) = @_;
|
||
|
|
|
||
|
|
my $sql = qq{
|
||
|
|
SELECT e.value, t.name AS "type", c.inclusion_order AS "order",
|
||
|
|
e.id AS "element_id", c.id AS "component_id",
|
||
|
|
r.id AS "report_id"
|
||
|
|
FROM report_element e, report_component c, report_element_type t,
|
||
|
|
report r
|
||
|
|
WHERE r.name = ?
|
||
|
|
AND c.report_id = r.id
|
||
|
|
AND c.element_id = e.id
|
||
|
|
AND e.type_id = t.id
|
||
|
|
AND c.active = 't'
|
||
|
|
ORDER BY c.inclusion_order ASC;
|
||
|
|
};
|
||
|
|
my $params = [ $form->{id} ];
|
||
|
|
my $data = dm::SelectData($sql, $params, $dbopts);
|
||
|
|
my ($html, $pval, $order, $eid, $cid);
|
||
|
|
foreach my $e ( @$data ) {
|
||
|
|
$order = $e->{order};
|
||
|
|
($eid, $cid) = ($e->{element_id}, $e->{component_id});
|
||
|
|
if ( $form->{dbg} && $form->{dbg} == 2 ) {
|
||
|
|
$html .= qq{<br><pre>$e->{type}: };
|
||
|
|
$html .= escape_special_chars($e->{value});
|
||
|
|
$html .= qq{</pre><br>};
|
||
|
|
}
|
||
|
|
|
||
|
|
if ( $e->{type} eq 'Text' ) {
|
||
|
|
if ( $form->{dbg} || $form->{debug} ) {
|
||
|
|
$html .= qq{\n\n<!-- Element #$order: $e->{type} -->\n};
|
||
|
|
$html .= qq{<!-- element_id $eid, component_id $cid -->\n\n};
|
||
|
|
}
|
||
|
|
$html .= TextElement($form, $dbopts, $e->{value});
|
||
|
|
if ( $form->{dbg} || $form->{debug} ) {
|
||
|
|
$html .= qq{\n<!-- END - Element #$order: $e->{type} -->\n};
|
||
|
|
}
|
||
|
|
|
||
|
|
} elsif ( $e->{type} eq 'SQL' ) {
|
||
|
|
$pval = $e->{value};
|
||
|
|
$pval =~ s/\n/ /g;
|
||
|
|
if ( $form->{dbg} || $form->{debug} ) {
|
||
|
|
$html .= qq{\n\n<!-- Element #$order: $e->{type} : $pval -->\n};
|
||
|
|
$html .= qq{<!-- element_id $eid, component_id $cid -->\n\n};
|
||
|
|
}
|
||
|
|
$html .= SQLElement($form, $dbopts, $e->{value});
|
||
|
|
if ( $form->{dbg} || $form->{debug} ) {
|
||
|
|
$html .= qq{\n<!-- END - Element #$order: $e->{type} -->\n};
|
||
|
|
}
|
||
|
|
|
||
|
|
} elsif ( $e->{type} eq 'Code' ) {
|
||
|
|
$pval = $e->{value};
|
||
|
|
$pval =~ s/\n/ /g;
|
||
|
|
if ( $form->{dbg} || $form->{debug} ) {
|
||
|
|
$html .= qq{\n\n<!-- Element #$order: $e->{type} : $pval -->\n};
|
||
|
|
$html .= qq{<!-- element_id $eid, component_id $cid -->\n\n};
|
||
|
|
}
|
||
|
|
$html .= CodeElement($form, $dbopts, $e->{value});
|
||
|
|
if ( $form->{dbg} || $form->{debug} ) {
|
||
|
|
$html .= qq{\n<!-- END - Element #$order: $e->{type} -->\n};
|
||
|
|
}
|
||
|
|
|
||
|
|
} elsif ( $e->{type} eq 'TextFile' ) {
|
||
|
|
$pval = $e->{value};
|
||
|
|
if ( $form->{dbg} || $form->{debug} ) {
|
||
|
|
$html .= qq{\n\n<!-- Element #$order: $e->{type} : $pval -->\n};
|
||
|
|
$html .= qq{<!-- element_id $eid, component_id $cid -->\n\n};
|
||
|
|
}
|
||
|
|
$html .= FileElement($form, $dbopts, $e->{value});
|
||
|
|
if ( $form->{dbg} || $form->{debug} ) {
|
||
|
|
$html .= qq{\n<!-- END - Element #$order: $e->{type} -->\n};
|
||
|
|
}
|
||
|
|
|
||
|
|
} elsif ( $e->{type} eq 'SQLFile' ) {
|
||
|
|
$pval = $e->{value};
|
||
|
|
if ( $form->{dbg} || $form->{debug} ) {
|
||
|
|
$html .= qq{\n\n<!-- Element #$order: $e->{type} : $pval -->\n};
|
||
|
|
$html .= qq{<!-- element_id $eid, component_id $cid -->\n\n};
|
||
|
|
}
|
||
|
|
$html .= SQLFileElement($form, $dbopts, $e->{value});
|
||
|
|
if ( $form->{dbg} || $form->{debug} ) {
|
||
|
|
$html .= qq{\n<!-- END - Element #$order: $e->{type} -->\n};
|
||
|
|
}
|
||
|
|
|
||
|
|
} elsif ( $e->{type} eq 'CodeFile' ) {
|
||
|
|
$pval = $e->{value};
|
||
|
|
if ( $form->{dbg} || $form->{debug} ) {
|
||
|
|
$html .= qq{\n\n<!-- Element #$order: $e->{type} : $pval -->\n};
|
||
|
|
$html .= qq{<!-- element_id $eid, component_id $cid -->\n\n};
|
||
|
|
}
|
||
|
|
$html .= CodeFileElement($form, $dbopts, $e->{value});
|
||
|
|
if ( $form->{dbg} || $form->{debug} ) {
|
||
|
|
$html .= qq{\n<!-- END - Element #$order: $e->{type} -->\n};
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
logger::logerr("Unrecognized element type [$e->{type}]");
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
return $html;
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
#############################################################################
|
||
|
|
sub showreportlist {
|
||
|
|
my ($form, $dbopts) = @_;
|
||
|
|
|
||
|
|
my $sql = qq{
|
||
|
|
SELECT r.id, r.name, r.description
|
||
|
|
FROM report r;
|
||
|
|
};
|
||
|
|
my $data = dm::SelectData($sql, undef, $dbopts);
|
||
|
|
my $html = qq{<table border="1">};
|
||
|
|
# $html .= qq{<tr><th>Client</th><th>Report Name</th><th>Description</th></tr>};
|
||
|
|
$html .= qq{<tr><th>Report Name</th><th>Description</th></tr>};
|
||
|
|
foreach my $rep ( @$data ) {
|
||
|
|
my $link .= qq{<a href="dbreport.pl?id=$rep->{name}};
|
||
|
|
$link .= qq{&dbg=1} if ( $debug );
|
||
|
|
$link .= qq{">};
|
||
|
|
my $row = qq{<tr>};
|
||
|
|
$row .= qq{<td>$link$rep->{name}</a></td>};
|
||
|
|
$row .= qq{<td>$link$rep->{description}</a></td>};
|
||
|
|
$html .= qq{<tr>$row</tr>};
|
||
|
|
}
|
||
|
|
$html .= qq{</table>};
|
||
|
|
|
||
|
|
return $html;
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
#############################################################################
|
||
|
|
sub go {
|
||
|
|
my %FORM;
|
||
|
|
initialize(\%FORM);
|
||
|
|
foreach my $key ( keys %FORM ) {
|
||
|
|
$dbopts->{$key} = $FORM{$key} if ( defined($dbopts->{$key}) );
|
||
|
|
}
|
||
|
|
|
||
|
|
$dbversion = dm::SelectDataValue("select version();", undef, $dbopts);
|
||
|
|
|
||
|
|
my $html;
|
||
|
|
my $t0 = toolbox::NowAsScalar();
|
||
|
|
if ( defined($FORM{id}) ) {
|
||
|
|
$html = &showreport(\%FORM, $dbopts);
|
||
|
|
} else {
|
||
|
|
$html = &showreportlist(\%FORM, $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;
|