#!/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);