*** /dev/null Mon May 6 09:45:32 2024
--- - Mon May 6 09:50:36 2024
***************
*** 0 ****
--- 1,841 ----
+ #!/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);
+
|
