ossp-pkg/xmldb/xmldb.cgi
#!/e/is/bin/perl
##
## xmldb.cgi -- XML Database Engine
## Copyright (c) 2002 Ralf S. Engelschall <rse@engelschall.com>
## Copyright (c) 2002 Cable & Wireless Deutschland <http://www.cw.com/de/>
##
## Permission to use, copy, modify, and distribute this software for
## any purpose with or without fee is hereby granted, provided that
## the above copyright notice and this permission notice appear in all
## copies.
##
## THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESSED OR IMPLIED
## WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
## MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
## IN NO EVENT SHALL THE AUTHORS AND COPYRIGHT HOLDERS AND THEIR
## CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
## SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
## LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
## USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
## ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
## OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT
## OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
## SUCH DAMAGE.
##
# requirements
require 5.006;
use IO; # standard in Perl 5.6
use POSIX; # standard in Perl 5.6
use CGI; # standard in Perl 5.6
use Fcntl ':flock'; # standard in Perl 5.6
use Data::Dumper;
# program configuration
my $MY = {
PROG_NAME => 'OSSP xmldb',
PROG_VERS => '0.1.0',
PROG_DESC => 'XML Database CGI Engine',
PROG_HOME => 'http://www.ossp.org/pkg/tool/xmldb/',
TEMPLATE => "<html>\n<head>\n\@HEAD\@\n</head>\n<body>\n\@BODY\@\n</body></html>"
};
# switch to unbuffered output
$|++;
# adjust CGI environment to make sure that self-referencing
# URLs go again through the direct URL of the MCT file!!
$ENV{SCRIPT_NAME} = $ENV{PATH_INFO};
delete $ENV{REQUEST_URI};
# remove and remember GET query strings
my $qs = '';
if ($ENV{QUERY_STRING} ne '') {
$qs = $ENV{QUERY_STRING};
delete $ENV{QUERY_STRING};
}
# establish CGI object
my $cgi = new CGI;
# re-insert GET query strings into CGI environment
if ($qs ne '') {
if ($qs =~ m|^([^=]+)=([^=]+)$|s) {
$cgi->param("action", "view");
$cgi->param("field", &url_unescape($1));
$cgi->param("key", &url_unescape($2));
}
}
# generate an HTTP response
sub http_response {
my ($head, $body) = @_;
# fill in template page
my $response = $MY->{TEMPLATE};
$response =~ s|\@HEAD\@|$head|sg;
$response =~ s|\@BODY\@|$body|sg;
# prepend with HTTP header
$response = $cgi->header(
-type => 'text/html',
-expires => 'now',
'-Content-length' => length($response)
) . $response;
return $response;
}
# activate a general error handler
$SIG{__DIE__} = sub {
my ($err) = @_;
$err =~ s|at\s+\S+\s+line\s+(\d+)|(line $1)|s;
$err =~ s|\n|<br>\n|sg;
print STDOUT &http_response(
"<title>XMLDB ERROR</title>",
"<h1>XMLDB ERROR</h1>\n" .
"<pre>$err</pre>\n"
);
exit(0);
};
# XML escape/unescape
sub xml_escape {
my ($str) = @_;
$str =~ s|&|&|sg;
$str =~ s|<|<|sg;
$str =~ s|>|>|sg;
$str =~ s|"|"|sg;
return $str;
}
sub xml_unescape {
my ($str) = @_;
$str =~ s|&|&|sg;
$str =~ s|<|<|sg;
$str =~ s|>|>|sg;
$str =~ s|"|"|sg;
return $str;
}
# import database
sub db_import {
my ($file) = @_;
# read XML file
my $fh = new IO::File "<$file"
|| die "unable to open database \"$file\" for reading";
my $xml = '';
$xml .= $_ while (<$fh>);
$fh->close;
# parse XML
my $db = {
'TEXT' => { 'PROLOG' => '', 'EPILOG' => '' },
'ORDER' => { 'USER' => undef, 'ATTRIB' => undef, 'RECORD' => undef },
'INDEX' => { 'USER' => {}, 'ATTRIB' => {}, 'RECORD' => {} },
'CONFIG' => {},
'USER' => [],
'ATTRIB' => [],
'RECORD' => [],
};
if ($xml =~ m|^(.*?)<xmldb>(.*?)</xmldb>(.*)$|s) {
$db->{TEXT}->{PROLOG} = $1;
$xml = $2;
$db->{TEXT}->{EPILOG} = $3;
}
else {
die "invalid XML markup in database file \"$file\"";
}
$xml =~ s|<config>(.*?)</config>|&parse_config($1), ''|sge;
sub parse_config {
my ($xml) = @_;
$xml =~ s|<([a-z][a-z0-9_-]*)((?:\s+[a-zA-Z][a-zA-Z0-9-]*="[^"]*")+)/>|&parse_config_entry($1, $2), ''|sge;
sub parse_config_entry {
my ($tag, $xml) = @_;
$db->{CONFIG}->{$tag} = {};
while ($xml =~ s|^\s*([a-zA-Z][a-zA-Z0-9-]*)="([^"]*)"\s*||) {
$db->{CONFIG}->{$tag}->{$1} = &xml_unescape($2);
}
}
}
$xml =~ s|<user((?:\s+[a-zA-Z][a-zA-Z0-9-]*="[^"]*")+)/>|&parse_user($1), ''|sge;
$xml =~ s|<attrib((?:\s+[a-zA-Z][a-zA-Z0-9-]*="[^"]*")+)/>|&parse_attrib($1), ''|sge;
$xml =~ s|<record((?:\s+[a-zA-Z][a-zA-Z0-9-]*="[^"]*")+)/>|&parse_record($1), ''|sge;
sub parse_user {
my ($xml) = @_;
my $user = {};
my $order = [];
while ($xml =~ s|^\s*([a-zA-Z][a-zA-Z0-9-]*)="([^"]*)"\s*||) {
$user->{$1} = &xml_unescape($2);
push(@{$order}, $1);
}
if ($user->{"id"} ne '') {
push(@{$db->{USER}}, $user);
$db->{INDEX}->{USER}->{$user->{"id"}} = $user;
if (not defined($db->{ORDER}->{USER})) {
$db->{ORDER}->{USER} = $order;
}
}
}
sub parse_attrib {
my ($xml) = @_;
my $attrib = {};
my $order = [];
while ($xml =~ s|^\s*([a-zA-Z][a-zA-Z0-9-]*)="([^"]*)"\s*||) {
$attrib->{$1} = &xml_unescape($2);
push(@{$order}, $1);
}
if ($attrib->{"id"} ne '') {
push(@{$db->{ATTRIB}}, $attrib);
$db->{INDEX}->{ATTRIB}->{$attrib->{"id"}} = $attrib;
if ($attrib->{"index"} eq 'yes') {
$db->{INDEX}->{RECORD}->{$attrib->{"id"}} = {};
}
if (not defined($db->{ORDER}->{ATTRIB})) {
$db->{ORDER}->{ATTRIB} = $order;
}
}
}
sub parse_record {
my ($xml) = @_;
my $record = {};
my $order = [];
while ($xml =~ s|^\s*([a-zA-Z][a-zA-Z0-9-]*)="([^"]*)"\s*||) {
if (defined($db->{INDEX}->{ATTRIB}->{$1})) {
$record->{$1} = &xml_unescape($2);
if ($db->{INDEX}->{ATTRIB}->{$1}->{"index"} eq 'yes') {
$db->{INDEX}->{RECORD}->{$1}->{$2} = $record;
}
push(@{$order}, $1);
}
}
push(@{$db->{RECORD}}, $record);
if (not defined($db->{ORDER}->{RECORD})) {
$db->{ORDER}->{RECORD} = $order;
}
}
return $db;
}
# export database
sub db_export {
my ($db, $file) = @_;
# read XML file
my $fh = new IO::File "<$file"
|| die "unable to open database \"$file\" for reading";
my $old = '';
$old .= $_ while (<$fh>);
$fh->close;
my $out = '';
$out .= $db->{TEXT}->{PROLOG};
$out .= "<xmldb>\n";
$out .= " <config>\n";
$out .= " <title major=\"".&xml_escape($db->{CONFIG}->{title}->{major} || "")."\" ".
"minor=\"".&xml_escape($db->{CONFIG}->{title}->{minor} || "")."\"/>\n";
$out .= " <contact name=\"".&xml_escape($db->{CONFIG}->{contact}->{name} || "")."\" ".
"email=\"".&xml_escape($db->{CONFIG}->{contact}->{email} || "")."\"/>\n";
$out .= " <copyright year=\"".&xml_escape($db->{CONFIG}->{copyright}->{year} || "")."\" ".
"holder=\"".&xml_escape($db->{CONFIG}->{copyright}->{holder} || "")."\"/>\n";
$out .= " </config>\n";
$out .= " <access>\n";
foreach $user (@{$db->{USER}}) {
$out .= " <user";
foreach $a (@{$db->{ORDER}->{USER}}) {
$out .= " $a=\"".$user->{$a}."\"";
}
$out .= "/>\n";
}
$out .= " </access>\n";
$out .= " <schema>\n";
foreach $attrib (@{$db->{ATTRIB}}) {
$out .= " <attrib";
foreach $a (@{$db->{ORDER}->{ATTRIB}}) {
$out .= " $a=\"".$attrib->{$a}."\"";
}
$out .= "/>\n";
}
$out .= " </schema>\n";
$out .= " <records>\n";
foreach $record (@{$db->{RECORD}}) {
$out .= " <record";
foreach $r (@{$db->{ORDER}->{RECORD}}) {
$out .= " $r=\"".$record->{$r}."\"";
}
$out .= "/>\n";
}
$out .= " </records>\n";
$out .= "</xmldb>";
$out .= $db->{TEXT}->{EPILOG};
my $fh = new IO::File ">$file"
or die "unable to open database \"$file\" for writing";
flock($fh, LOCK_EX) or die "(exclusive) lock failed: $!";
$fh->print($out);
$fh->flush();
$fh->sync();
flock($fh, LOCK_UN) or die "unlock failed: $!";
$fh->close();
# read XML file
$fh = new IO::File "<$file"
|| die "unable to open database \"$file\" for reading";
my $new = '';
$new .= $_ while (<$fh>);
$fh->close;
if ($new ne $out) {
my $fh = new IO::File ">$file"
or die "unable to open database \"$file\" for writing";
flock($fh, LOCK_EX) or die "(exclusive) lock failed: $!";
$fh->print($old);
$fh->flush();
$fh->sync();
flock($fh, LOCK_UN) or die "unlock failed: $!";
$fh->close();
die "re-read newly written new database and found difference -- restored old database!";
}
return $out;
}
# convert Sugar-style markup text to HTML text
sub sug2html {
my ($text) = @_;
# escape HTML special characters
$text =~ s|&|&|sg;
$text =~ s|<|<|sg;
$text =~ s|>|>|sg;
# expand Sugar markup
$text =~ s/\|\|(.+?)\|\|/<tt>$1<\/tt>/sg;
$text =~ s|//(.+?)//|<i>$1</i>|sg;
$text =~ s|\*\*(.+?)\*\*|<b>$1</b>|sg;
$text =~ s|->(.+?)::(.+?)<-|<a href="$2" target="mct-extern">$1</a>|sg;
$text =~ s|->(.+?)<-|<a href="$1" target="mct-extern">$1</a>|sg;
return $text;
}
# fetch CGI parameters
my $action = $cgi->param('action') || 'list';
my $xmldb = $cgi->path_translated();
my $head = '';
my $body = '';
# optionally read HTML page template
my $template = $xmldb;
$template =~ s|\.xmldb$|.html|s;
my $fh = new IO::File "<$template" || die;
$MY->{TEMPLATE} = '';
$MY->{TEMPLATE} .= $_ while (<$fh>);
$fh->close();
# import CSS
sub addcss {
my ($file) = @_;
$head .= "<style type=\"text/css\"><!--\n";
my $fh = new IO::File "<$file" || die;
$head .= $_ while (<$fh>);
$fh->close();
$head .= "--></style>\n";
}
my $css = $xmldb;
$css =~ s|\.xmldb$|.css|s;
if (-f "$css") {
&addcss("$css");
}
if (-f "xmldb.css") {
&addcss("xmldb.css");
}
# read database
my $db = &db_import($xmldb);
#################################
#$body .= "<pre>";
#$body .= Data::Dumper->Dump([$db]);
#$body .= "</pre>";
#foreach $e (sort(keys(%ENV))) {
# $body .= "$e=$ENV{$e}<br>\n";
#}
sub url_escape {
my ($text) = @_;
$text =~ s|([ \t&+?:/=\n\r])|sprintf("%%%02x", ord($1))|sge;
return $text;
}
sub url_unescape {
my ($text) = @_;
$text =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack('C', hex($1))/eg;
return $text;
}
my $sortby = $cgi->param("view.sortby") || "";
if ($sortby eq '') {
for ($i = 0; $i < ($#{$db->{ORDER}->{RECORD}}+1); $i++) {
if (($cgi->param("sortby-$i") || '') ne '') {
$sortby = $i;
$action = "list";
last;
}
}
}
if ($sortby eq '' or $sortby < 0) {
$sortby = 0;
}
if ($cgi->param('new') ne '') {
$action = "new";
}
if ($cgi->param('update') ne '') {
$action = "list";
}
if ($cgi->param('list') ne '') {
$action = "list";
}
if ($cgi->param('view') ne '') {
$action = "view";
}
if ($cgi->param('edit') ne '') {
$action = "edit";
}
if ($cgi->param('edit-save') ne '') {
$action = "edit-save";
}
my $hint = {};
DISPATCH:
my $title = "";
if ($action eq 'list') {
$body .= "<table border=0 cellspacing=0 cellpadding=2>\n";
$body .= $cgi->hidden(-name => 'view.sortby', -default => [ $sortby ]);
# determine default list of columns
my $view_field_name = [];
foreach my $a (@{$db->{ATTRIB}}) {
if ($a->{"list"} eq 'yes') {
push(@{$view_field_name}, $a->{"id"});
}
}
# determine number of fields to view
my $view_fields_list = [];
for ($i = 0; $i < $#{$db->{ORDER}->{RECORD}}+1; $i++) {
push(@{$view_fields_list}, $i);
}
my $view_fields = $cgi->param("view.fields") || "";
if ($view_fields eq '') {
# $view_fields = sprintf("%d", ($#{$db->{ORDER}->{RECORD}}+1)/2);
# $view_fields = 6 if ($view_fields > 6);
$view_fields = sprintf("%d", $#{$view_field_name}+1);
}
elsif ($view_fields < 1) {
$view_fields = 1;
}
elsif ($view_fields > $#{$db->{ORDER}->{RECORD}}+1) {
$view_fields = $#{$db->{ORDER}->{RECORD}}+1;
}
if ($view_fields > $#{$view_field_name}+1) {
foreach my $a (@{$db->{ATTRIB}}) {
if ($a->{"list"} eq 'no') {
if ($view_fields > $#{$view_field_name}+1) {
push(@{$view_field_name}, $a->{"id"});
}
}
}
}
$body .= " <tr>\n";
$body .= " <td>\n";
$body .= "<span class=\"xmldb-button-update\">" .
$cgi->submit(-name => 'update', -value => "Update") .
"</span>\n";
$body .= " </td>\n";
for ($i = 0; $i < $view_fields; $i++) {
$body .= " <td>\n";
$body .= "<span class=\"xmldb-button-sort".($i == $sortby ? "-active" :"")."\">";
$body .= $cgi->submit(-name => "sortby-$i", -value => "Sort") ;
$body .= "</span>";
$body .= " </td>\n";
}
$body .= " </tr>\n";
$body .= " <tr>\n";
$body .= " <td>\n";
# FIXME
# $body .= "<span class=\"xmldb-button\">" .
# $cgi->submit(-name => 'new', -value => "New") .
# "</span>\n";
$body .= " </td>\n";
for ($i = 0; $i < $view_fields; $i++) {
my $pattern = $cgi->param("view.field.$i.pattern") || "*";
$body .= " <td>\n";
$body .= "<span class=\"xmldb-field-pattern".($i == $sortby ? "-active" :"")."\">";
$body .= $cgi->textfield(-name => "view.field.$i.pattern",
-default => $pattern,
-size => 10,
-maxlength => 20);
$body .= "</span>";
$body .= " </td>\n";
}
$body .= " </tr>\n";
$body .= " <tr>\n";
$body .= " <td>\n";
$body .= "<span class=\"xmldb-field-list\">";
$body .= $cgi->popup_menu(-name => 'view.fields',
-values => $view_fields_list,
-default => $view_fields);
$body .= "</span>";
$body .= " </td>\n";
for ($i = 0; $i < $view_fields; $i++) {
#my $name = $cgi->param("view.field.$i.name") || $db->{ORDER}->{RECORD}->[$i];
my $name = $cgi->param("view.field.$i.name") || $view_field_name->[$i];
$body .= " <td>\n";
$body .= "<span class=\"xmldb-field-select".($i == $sortby ? "-active" :"")."\">";
$body .= $cgi->popup_menu(-name => "view.field.$i.name",
-values => $db->{ORDER}->{RECORD},
-default => $name);
$body .= "</span>";
$body .= " </td>\n";
}
$body .= " </tr>\n";
my @result = ();
foreach my $r (@{$db->{RECORD}}) {
my $match = 1;
for ($i = 0; $i < $view_fields; $i++) {
#my $name = $cgi->param("view.field.$i.name") || $db->{ORDER}->{RECORD}->[$i];
my $name = $cgi->param("view.field.$i.name") || $view_field_name->[$i];
my $pattern = $cgi->param("view.field.$i.pattern") || "*";
sub pattern_match {
my ($s, $p) = @_;
$p =~ s|\*|.*|sg;
$p =~ s|\?|.|sg;
return ($s =~ m|^.*$p.*$|is);
}
if (not &pattern_match($r->{$name}, $pattern)) {
$match = 0;
last;
}
}
if ($match) {
my $entry = [];
for ($i = 0; $i < $view_fields; $i++) {
#my $name = $cgi->param("view.field.$i.name") || $db->{ORDER}->{RECORD}->[$i];
my $name = $cgi->param("view.field.$i.name") || $view_field_name->[$i];
push(@{$entry}, $r->{$name});
}
push(@result, $entry);
}
}
my $view_rows = $cgi->param("view.rows") || 20;
my $view_rows_list = [];
for ($i = 1; $i < 100; $i++) {
push(@{$view_rows_list}, $i);
}
if ($sortby > $#result) {
$sortby = $#result;
}
my @sorted = sort { return ($a->[$sortby] cmp $b->[$sortby]); } @result;
my $c = 0;
my $row = 0;
my $scroll = (($#sorted+1) > 10);
foreach my $r (@sorted) {
$body .= " <tr class=xmldb-list-row$c>\n";
$body .= " <td>\n";
# if ($scroll and $row == 0) {
# $body .= "<span class=\"xmldb-button\">" .
# $cgi->submit(-name => 'scroll-up', -value => "U") .
# "</span>\n";
# }
# elsif ($scroll and $row == 1) {
# $body .= $cgi->popup_menu(-name => 'view.rows',
# -values => $view_rows_list,
# -default => $view_rows);
# }
# elsif ($scroll and $row == 2) {
# $body .= "<span class=\"xmldb-button\">" .
# $cgi->submit(-name => 'scroll-down', -value => "D") .
# "</span>\n";
# }
# else {
$body .= " ";
# }
$body .= " </td>\n";
for ($i = 0; $i < $view_fields; $i++) {
#my $name = $cgi->param("view.field.$i.name") || $db->{ORDER}->{RECORD}->[$i];
my $name = $cgi->param("view.field.$i.name") || $view_field_name->[$i];
my $a = $r->[$i];
$body .= " <td class=xmldb-list-col$c".($i == $sortby ? "-active" :"").">\n";
$body .= " <span class=\"xmldb-list-row-text".($i == $sortby ? "-active" :"")."\">";
if ($db->{INDEX}->{ATTRIB}->{$name}->{"index"} eq 'yes') {
$body .= "<a href=\"". $cgi->url(-full => 1)."?" .
&url_escape($name)."=".&url_escape($a) .
"\">$a</a>";
}
else {
$body .= $a;
}
$body .= " </span>\n";
$body .= " </td>\n";
}
$body .= " </tr>\n";
$c = (($c + 1) % 2);
$row++;
}
$body .= "</table>\n";
$title = "List Database";
}
elsif ($action eq 'view') {
my $field = $cgi->param("field") || die;
my $key = $cgi->param("key") || die;
my $r = $db->{INDEX}->{RECORD}->{$field}->{$key} || die;
$body .= "<input type=\"hidden\" name=\"field\" value=\"$field\" />\n";
$body .= "<input type=\"hidden\" name=\"key\" value=\"$key\" />\n";
$body .= "<span class=\"xmldb-button-back\">" .
$cgi->submit(-name => 'list', -value => "Back") .
"</span>\n";
$body .= "<span class=\"xmldb-button-refresh\">" .
$cgi->submit(-name => 'view', -value => "Refresh") .
"</span>\n";
$body .= "<span class=\"xmldb-button-edit\">" .
$cgi->submit(-name => 'edit', -value => "Edit") .
"</span>\n";
$body .= "<p>";
$body .= "<table width=100% border=0 cellspacing=0 cellpadding=2>\n";
my $c = 0;
foreach $k (@{$db->{ORDER}->{RECORD}}) {
$body .= " <tr class=xmldb-list-row$c>\n";
$body .= " <td width=50%>";
$body .= " <span class=\"xmldb-list-row-text".($i == $sortby ? "-active" :"")."\">";
$body .= $db->{INDEX}->{ATTRIB}->{$k}->{name} . ": ";
$body .= " </span>\n";
$body .= " </td>\n";
$body .= " <td width=50%>\n";
$body .= " <span class=\"xmldb-list-row-text".($i == $sortby ? "-active" :"")."\">";
my $x = $r->{$k};
if ($x =~ m|^[^@]+@([^@.]+\.)*[^@.]+$|) {
$x = "<a href=\"mailto:$x\">$x</a>";
}
elsif ($x =~ m/^(http|ftp):\/\/.+/) {
$x = "<a href=\"$x\">$x</a>";
}
$body .= " $x\n";
$body .= " </span>\n";
$body .= " </td>\n";
$body .= " </tr>\n";
$c = ($c + 1) % 2;
}
$body .= "</table>\n";
$title = "View Database Record";
}
elsif ($action eq 'edit') {
my $field = $cgi->param("field") || die;
my $key = $cgi->param("key") || die;
my $r = $db->{INDEX}->{RECORD}->{$field}->{$key} || die;
$body .= "<input type=\"hidden\" name=\"field\" value=\"$field\" />\n";
$body .= "<input type=\"hidden\" name=\"key\" value=\"$key\" />\n";
$body .= "<span class=\"xmldb-button-cancel\">" .
$cgi->submit(-name => 'view', -value => "Cancel") .
"</span>\n";
$body .= "<span class=\"xmldb-button-refresh\">" .
$cgi->submit(-name => 'edit', -value => "Refresh") .
"</span>\n";
$body .= "<span class=\"xmldb-button-save\">" .
$cgi->submit(-name => 'edit-save', -value => "Save") .
"</span>\n";
$body .= "<p>";
$body .= "<table width=100% border=0 cellspacing=0 cellpadding=0>\n";
my $c = 0;
foreach $k (@{$db->{ORDER}->{RECORD}}) {
$body .= " <tr class=xmldb-list-row$c>\n";
$body .= " <td width=50%>";
$body .= " <span class=\"xmldb-list-row-text".($i == $sortby ? "-active" :"")."\">";
$body .= $db->{INDEX}->{ATTRIB}->{$k}->{name} . ": ";
$body .= " </span>\n";
$body .= " </td>";
$body .= " <td width=50%>";
$body .= " <span class=\"xmldb-list-row-text".($i == $sortby ? "-active" :"")."\">";
my $match = $db->{INDEX}->{ATTRIB}->{$k}->{match};
if ($match =~ m|^mc:(.*)$|) {
my @mc = split(/\|/, $1);
my $l = 0;
$body .= "<table cellspacing=0 cellpadding=0 border=0>\n";
foreach $mc (@mc) {
$body .= "<tr>" if ($l % 3 == 0);
$body .= "<td>";
$body .= "<input ".($r->{$k} eq $mc ? "checked " : "").
"type=\"radio\" name=\"$k\" value=\"$mc\">";
$body .= " " . $mc . " ";
$body .= "</td>";
$l++;
$body .= "</tr>" if ($l % 3 == 0);
}
$body .= "</tr>" if ($l % 3 != 0);
$body .= "</table>\n";
}
else {
$body .= $cgi->textfield(-name => "$k",
-default => $r->{$k},
-size => 40,
-maxlength => 80);
}
$body .= " </span>\n";
$body .= " </td>\n";
$body .= " </tr>\n";
if (defined($hint->{$k}) && $hint->{$k} ne '') {
$body .= " <tr>\n";
$body .= " <td>\n";
$body .= " </td>\n";
$body .= " <td>\n";
$body .= " <span class=\"xmldb-text-edit-hint\">\n";
$body .= " ".$hint->{$k}."\n";
$body .= " </span>\n";
$body .= " </td>\n";
$body .= " </tr>\n";
}
$c = ($c + 1) % 2;
}
$body .= "</table>\n";
$title = "Edit Database Record";
}
elsif ($action eq 'edit-save') {
my $field = $cgi->param("field") || die;
my $key = $cgi->param("key") || die;
my $r = $db->{INDEX}->{RECORD}->{$field}->{$key} || die;
my $ok_global = 1;
foreach $k (@{$db->{ORDER}->{RECORD}}) {
my $val = $cgi->param("$k");
my $match = $db->{INDEX}->{ATTRIB}->{$k}->{match};
my $ok_local = 0;
if ($match =~ m|^mc:(.*)$|s) {
my @mc = split(/\|/, $1);
foreach $mc (@mc) {
if ($mc eq $val) {
$ok_local = 1;
last;
}
}
if (not $ok_local) {
$hint->{$k} = "has to be one of: ".join(", ", @mc).".";
}
}
elsif ($match =~ m|^re:(.*)$|s) {
my $re = $1;
if ($val =~ m|$re|s) {
$ok_local = 1;
}
else {
$hint->{$k} = "has to match on regular expression \"$re\".";
}
}
else {
die "invalid match attribute \"$match\"";
}
if (not $ok_local) {
$ok_global = 0;
}
else {
$r->{$k} = $val;
}
}
if (not $ok_global) {
$action = "edit";
}
else {
$action = "view";
&db_export($db, $xmldb);
}
goto DISPATCH;
}
elsif ($action eq 'new') {
$body .= "NEW!";
$title = "New Database Record";
}
elsif ($action eq 'login') {
my $login_username = '';
my $login_password = '';
my $body = '';
$body .= "<table><tr>\n";
$body .= "<td>Username:</td>\n";
$body .= "<td>".$cgi->textfield(-name => "login_username", -default => $login_username, -size => 20, -maxlength => 40)."</td>";
$body .= "<td>Password:</td>\n";
$body .= "<td>".$cgi->password_field(-name => "login_password", -default => $login_password, -size => 20, -maxlength => 40)."</td>";
$body .= "<td>".$cgi->submit(-name => 'login', -value => "Login")."</td>";
$body .= "</tr></table>\n";
}
my $login_dialog = '';
sub login_valid {
my ($username, $password) = @_;
return 0;
}
# FIXME
# if (&login_valid($login_username, $login_password)) {
# $login_dialog .= "Logged in as ". $login_username;
# }
# else {
# $login_dialog .= $cgi->submit(-name => 'login', -value => "Login");
# }
$head .= "<title>XMLDB: $title</title>\n";
$body = $cgi->startform(-method => "POST", -action => $cgi->url(-full => 1)) .
"<table class=xmldb-box-outmost>\n" .
" <tr>\n" .
" <td class=xmldb-title-cell valign=top>\n" .
" <span class=xmldb-title-text-major>".$db->{CONFIG}->{title}->{major}."</span><br>\n" .
" <span class=xmldb-title-text-minor>".$db->{CONFIG}->{title}->{minor}."</span>\n" .
" </td>\n" .
" <td align=right valign=top>\n" .
# $login_dialog .
# " <br>\n" .
" " .
" <span class=xmldb-title-dialog>$title</span>\n" .
" </td>\n" .
" </tr>\n" .
" <tr>\n" .
" <td colspan=2>\n" .
$body .
" </td>\n" .
" </tr>\n" .
# " <tr>\n" .
# " <td class=xmldb-foot-left-cell>\n" .
# " <span class=xmldb-foot-left-text>".
# "Copyright © ".$db->{CONFIG}->{copyright}->{year} ." ".
# $db->{CONFIG}->{copyright}->{holder} . "<br>\n" .
# "Contact: ".$db->{CONFIG}->{contact}->{name} . " " .
# "<<a href=\"mailto:".$db->{CONFIG}->{contact}->{email}."\">".$db->{CONFIG}->{contact}->{email}."</a>>".
# " </span>\n" .
# " </td>\n" .
# " <td class=xmldb-foot-right-cell>\n" .
# " <span class=xmldb-foot-right-text>".
# "<a href=\"".$MY->{PROG_HOME}."\">".
# $MY->{PROG_NAME} . "</a> " . $MY->{PROG_VERS} . "<br>" .
# $MY->{PROG_DESC} .
# " </span>\n" .
# " </td>\n" .
# " </tr>\n" .
"</table>\n" .
$cgi->endform;
print STDOUT &http_response($head, $body);
exit(0);
