Index: ossp-pkg/xmldb/TODO RCS File: /v/ossp/cvs/ossp-pkg/xmldb/TODO,v co -q -kk -p'1.1' '/v/ossp/cvs/ossp-pkg/xmldb/TODO,v' | diff -u /dev/null - -L'ossp-pkg/xmldb/TODO' 2>/dev/null --- ossp-pkg/xmldb/TODO +++ - 2024-05-19 08:50:09.552934928 +0200 @@ -0,0 +1,4 @@ +- new record dialog +- CSS optical look +- scrolling implementieren +- print version? Index: ossp-pkg/xmldb/xmldb.cgi RCS File: /v/ossp/cvs/ossp-pkg/xmldb/xmldb.cgi,v co -q -kk -p'1.1' '/v/ossp/cvs/ossp-pkg/xmldb/xmldb.cgi,v' | diff -u /dev/null - -L'ossp-pkg/xmldb/xmldb.cgi' 2>/dev/null --- ossp-pkg/xmldb/xmldb.cgi +++ - 2024-05-19 08:50:09.568720727 +0200 @@ -0,0 +1,841 @@ +#!/e/is/bin/perl +## +## xmldb.cgi -- XML Database Engine +## Copyright (c) 2002 Ralf S. Engelschall +## Copyright (c) 2002 Cable & Wireless Deutschland +## +## 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 => "\n\n\@HEAD\@\n\n\n\@BODY\@\n" +}; + +# 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|
\n|sg; + print STDOUT &http_response( + "XMLDB ERROR", + "

XMLDB ERROR

\n" . + "

$err

\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|^(.*?)(.*?)(.*)$|s) { + $db->{TEXT}->{PROLOG} = $1; + $xml = $2; + $db->{TEXT}->{EPILOG} = $3; + } + else { + die "invalid XML markup in database file \"$file\""; + } + $xml =~ s|(.*?)|&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||&parse_user($1), ''|sge; + $xml =~ s||&parse_attrib($1), ''|sge; + $xml =~ s||&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 .= "\n"; + $out .= " \n"; + $out .= " {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\"></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\n"; +$body = $cgi->startform(-method => "POST", -action => $cgi->url(-full => 1)) . + "\n" . + " \n" . + " \n" . + " \n" . + " \n" . + " \n" . + " \n" . + " \n" . +# " \n" . +# " \n" . +# " \n" . +# " \n" . + "

\n" . + " ".$db->{CONFIG}->{title}->{major}." \n" . + " ".$db->{CONFIG}->{title}->{minor}."\n" . + "	\n" . +# $login_dialog . +# " \n" . + " " . + " $title\n" . + "
\n" . + $body . + "
\n" . +# " ". +# "Copyright © ".$db->{CONFIG}->{copyright}->{year} ." ". +# $db->{CONFIG}->{copyright}->{holder} . " \n" . +# "Contact: ".$db->{CONFIG}->{contact}->{name} . " " . +# "<{CONFIG}->{contact}->{email}."\">".$db->{CONFIG}->{contact}->{email}.">". +# " \n" . +# "	\n" . +# " ". +# "{PROG_HOME}."\">". +# $MY->{PROG_NAME} . " " . $MY->{PROG_VERS} . " " . +# $MY->{PROG_DESC} . +# " \n" . +# "

\n" . + $cgi->endform; + +print STDOUT &http_response($head, $body); + +exit(0); + Index: ossp-pkg/xmldb/xmldb.css RCS File: /v/ossp/cvs/ossp-pkg/xmldb/xmldb.css,v co -q -kk -p'1.1' '/v/ossp/cvs/ossp-pkg/xmldb/xmldb.css,v' | diff -u /dev/null - -L'ossp-pkg/xmldb/xmldb.css' 2>/dev/null --- ossp-pkg/xmldb/xmldb.css +++ - 2024-05-19 08:50:09.571679438 +0200 @@ -0,0 +1,109 @@ + +.xmldb-box-outmost { + border-style: solid; + border-width: 1; + border-color: #000000; + background: #d0d0ff; + margin: 0; + padding: 0; + spacing: 0; +} +.xmldb-title-cell { + background: #d0d0ff; + vertical-align: top; + text-align: left; +} +.xmldb-title-text-major { + font-family: helvetica,lucida,arial,sans-serif; + font-weight: bold; + font-size: 150%; + color: #000000; +} +.xmldb-title-text-minor { + font-family: helvetica,lucida,arial,sans-serif; + font-weight: bold; + font-size: 100%; + color: #000000; +} +.xmldb-title-dialog { + font-family: helvetica,lucida,arial,sans-serif; + font-weight: bold; + font-size: 140%; +} + +.xmldb-foot-left-cell { + background: #f0f0f0; + vertical-align: bottom; + text-align: left; +} +.xmldb-foot-left-text { + font-family: helvetica,lucida,arial,sans-serif; + color: #999999; +} +.xmldb-foot-left-text A { + text-decoration: none; + color: #999999; +} +.xmldb-foot-right-cell { + background: #f0f0f0; + vertical-align: bottom; + text-align: right; +} +.xmldb-foot-right-text { + font-family: helvetica,lucida,arial,sans-serif; + color: #999999; +} +.xmldb-foot-right-text A { + text-decoration: none; + color: #999999; +} + +.xmldb-text-edit-hint { + font-family: helvetica,lucida,arial,sans-serif; + font-weight: bold; + color: #cc3333; +} + +.xmldb-button-update INPUT { background: #666699; border-color: #666699; color: #f0f0ff; } +.xmldb-button-back INPUT { background: #666699; border-color: #666699; color: #f0f0ff; } +.xmldb-button-refresh INPUT { background: #666699; border-color: #666699; color: #f0f0ff; } +.xmldb-button-edit INPUT { background: #666699; border-color: #666699; color: #f0f0ff; } +.xmldb-button-cancel INPUT { background: #666699; border-color: #666699; color: #f0f0ff; } +.xmldb-button-save INPUT { background: #666699; border-color: #666699; color: #f0f0ff; } + +.xmldb-button-sort INPUT { background: #d0d0ff; border-color: #d0d0ff; color: #333366; } +.xmldb-button-sort-active INPUT { background: #ffffff; border-color: #ffffff; color: #000000; } +.xmldb-field-pattern INPUT { background: #c0c0ef; border-color: #c0c0ef; color: #333366; } +.xmldb-field-pattern-active INPUT { background: #ffffff; border-color: #ffffff; color: #000000; } +.xmldb-field-list SELECT { background: #c0c0ef; border-color: #c0c0ef; color: #333366; } +.xmldb-field-list-active SELECT { background: #ffffff; border-color: #ffffff; color: #000000; } +.xmldb-field-select SELECT { background: #c0c0ef; border-color: #c0c0ef; color: #333366; } +.xmldb-field-select-active SELECT { background: #ffffff; border-color: #ffffff; color: #000000; } + +.xmldb-list-row0 { background: #c0c0ef; } +.xmldb-list-row1 { background: #b0b0df; } +.xmldb-list-col0 { background: #c0c0ef; } +.xmldb-list-col1 { background: #b0b0df; } +.xmldb-list-col0-active { background: #e0e0ff; } +.xmldb-list-col1-active { background: #d0d0ef; } + +.xmldb-list-row-text { + font-family: helvetica,lucida,arial,sans-serif; + color: #000000; +} +.xmldb-list-row-text A { + color: #333399; + text-decoration: none; + font-weight: bold; +} + +.xmldb-list-row-text-active { + font-family: helvetica,lucida,arial,sans-serif; + color: #000000; +} +.xmldb-list-row-text-active A { + color: #333399; + text-decoration: none; + font-weight: bold; +} +