#!/v/openpkg/sw/bin/perl
##
## registry-ui.pl - OpenPKG Registry - User Interface (mod_perl)
## Copyright (c) 2000-2005 OpenPKG Foundation e.V. \n";
$head .= "
\n";
$head .= "
OpenPKG Registry \n";
if ($menu =~ m/-menu/) {
my $td;
$head .= " \n";
}
return $head;
}
sub prettyauthinfo ($)
{
my ($mode) = @_;
my ($boldon, $boldoff, $text, $username);
($boldon, $boldoff) = '';
($boldon, $boldoff) = ('
', ' ') if ($mode eq 'fancy');
$text = "";
$username = &identifyusername();
if (defined $username) {
$text .= "authenticated as " . $boldon . $username . $boldoff;
}
else {
$text .= "you are " . $boldon . "not authenticated" . $boldoff;
}
if ($cfg->{identification}->{mode} eq "ase" and defined $ase) {
$text .= " via ase login";
}
elsif ($cfg->{identification}->{mode} eq "basicauth") {
$text .= " via basic authentication";
}
elsif ($cfg->{identification}->{mode} eq "naive") {
$text .= " via naive input";
}
elsif ($cfg->{identification}->{mode} eq "constant") {
$text .= " via constant setting";
}
else {
$text .= " through magic";
}
return $text;
}
sub viewhtmltail ()
{
my ($msg, $html);
$html = "";
if ($cfg->{identification}->{mode} eq "ase" and defined $ase) {
$html .= $ase->canvas(-part => "body") . "\n";
}
$msg = "";
if ($cfg->{status}->{showversion}) {
$msg .= ($msg ? " | " : "" );
$msg .= $progname . " " . $progvers . " (" . $progdate . ")";
}
if ($cfg->{status}->{showuser}) {
$msg .= ($msg ? " | " : "" );
$msg .= &prettyauthinfo('dumb');
}
if ($cfg->{status}->{showsid}) {
$msg .= ($msg ? " | " : "" );
$msg .= "sid=" . ( defined $session ? $session->id : "undef" );
}
if ($msg) {
$html .= "
\n";
$html .= "
\n";
$html .= $msg;
$html .= "
\n";
}
$html .= "
';
$html .= $cgi->start_form(-action => "$myurl?page=profile");
$html .= "" . $cgi->submit('submit','profile') . "
";
$html .= $cgi->end_form;
$html .= ' ';
return $html;
}
sub viewassociationform ()
{
my ($html);
$html = '';
$html .= '';
$html .= $cgi->start_form(-action => "$myurl?page=association");
$html .= "" . $cgi->submit('submit','association') . "
";
$html .= $cgi->end_form;
$html .= ' ';
return $html;
}
sub viewloginform ()
{
my $html;
$html = '';
$html .= '';
if ($cfg->{identification}->{mode} eq "ase" and defined $ase) {
$html .= $cgi->start_form(-action => $ase->url(-action => "login", -mode_during => "ase", -mode_after => "asecomeback"));
$html .= "" . $cgi->submit('submit','login') . "
";
$html .= $cgi->end_form;
}
elsif ($cfg->{identification}->{mode} eq "basicauth") {
# nop
}
elsif ($cfg->{identification}->{mode} eq "naive") {
$html .= $cgi->start_form(-action => "$myurl?page=login");
$html .= "" . $cgi->submit('submit','login') . "
";
$html .= $cgi->textfield(
-name => 'username',
-override => 1,
-size => 50,
-maxlength => 50,
-default => $cfg->{identification}->{default},
) . "\n";
$html .= $cgi->end_form;
}
elsif ($cfg->{identification}->{mode} eq "constant") {
# nop
}
else {
# nop, misconfigured
}
$html .= ' ';
return $html;
}
sub viewasecomeback ()
{
my ($html, $username);
$username = &identifyusername();
if (defined $username) {
# updating heartbeat or creating username
#
$dbh->{AutoCommit} = 1;
$sql = sprintf("UPDATE reg_user SET heartbeat = now() WHERE ( username = %s );", $dbh->quote($username));
$rv = $dbh->do($sql);
if (not defined $rv) {
&viewprettyerror("updating user $username", prettydbi());
goto CUS;
}
elsif ($rv != 1) {
$sql = sprintf("INSERT INTO reg_user (username) VALUES (%s);", $dbh->quote($username));
$rv = $dbh->do($sql);
if (not defined $rv) {
&viewprettyerror("inserting user $username", prettydbi());
goto CUS;
}
elsif ($rv != 1) {
&viewprettyerror("creating user $username", prettydbi());
goto CUS;
}
}
}
# HTTP header
$response->{header}->{type} = 'text/html';
$response->{header}->{expires} = '+1s';
$response->{header}->{redirect} = "$myurl?page=login";
}
sub viewprettyerror ($$)
{
my ($marketingmessage, $technicaldetail) = @_;
my $html;
# HTTP header
$response->{header}->{type} = 'text/html';
$response->{header}->{expires} = '+1s';
$html = '';
$html .= "";
$html .= "Sorry \n";
$html .= "ERROR occurred and prevents further processing.Problem scope \n%sTechnical details \n%sPlease come back later and try again \nSorry for the inconvenience\n";
$html .= "";
# HTTP message
$response->{message}->divert("message");
$response->{message}->append(&canvas($html));
$response->{message}->undivert(0);
}
sub prettydbi ()
{
my $msg;
$msg = $DBI::errstr;
$msg =~ s/[ ]*ERROR:?[ ]*//;
$msg =~ s/ for user.*$//;
return $msg;
}
sub viewemptypage ()
{
my ($html, $username);
# HTTP header
$response->{header}->{type} = 'text/html';
$response->{header}->{expires} = '+1s';
$html = '';
$html .= &viewhtmlhead(-menu);
$html .= &viewhtmltail();
# HTTP message
$response->{message}->divert("message");
$response->{message}->append(&canvas($html));
$response->{message}->undivert(0);
}
sub viewmainpage ()
{
my ($html, $username);
# HTTP header
$response->{header}->{type} = 'text/html';
$response->{header}->{expires} = '+1s';
$html = '';
$html .= &viewhtmlhead(-menu);
$html .= $cfg->{page}->{main};
$html .= &viewhtmltail();
# HTTP message
$response->{message}->divert("message");
$response->{message}->append(&canvas($html));
$response->{message}->undivert(0);
}
sub viewlogin ()
{
my ($html, $username, $fullname);
# HTTP header
$response->{header}->{type} = 'text/html';
$response->{header}->{expires} = '+1s';
$html = '';
$html .= &viewhtmlhead(-menu);
if ($cfg->{identification}->{mode} eq "ase" and defined $ase) {
# nop
}
elsif ($cfg->{identification}->{mode} eq "basicauth") {
# nop
}
elsif ($cfg->{identification}->{mode} eq "naive") {
$session->param('username', $cgi->param("username"));
}
elsif ($cfg->{identification}->{mode} eq "constant") {
# nop
}
else {
# nop, misconfigured
}
# identify username after login attempt
$username = &identifyusername();
# welcome user showing fullname (if available)
if (defined $username) {
$sql = sprintf("SELECT username, fullname FROM reg_user WHERE ( username = '%s' );", $username);
$rv = $dbh->selectall_hashref($sql, "username");
if (not $rv) {
die "ERROR:$0: DataBase error: ".$dbh->errstr."\n";
}
$fullname = $rv->{$username}->{fullname};
$html .= "Login successful \n";
$html .= "Welcome,
Please note you can create a user token and use it as a replacement for
your (email) login when running openpkg register. This is
useful for writing scripts and documentation without revealing your
email address. All you need to do is visit the profile tab and issue a
new token. Tokens with additional capabilities like automatic instance
association without manual web interface usage are available if you
update your profile with additional information.
};
}
}
}
else {
$html .= "Login failed \n";
}
$html .= &viewhtmltail();
# HTTP message
$response->{message}->divert("message");
$response->{message}->append(&canvas($html));
$response->{message}->undivert(0);
}
sub viewlogoutform ()
{
my $html;
$html = '';
$html .= '';
if ($cfg->{identification}->{mode} eq "ase" and defined $ase) {
$html .= $cgi->start_form(-action => $ase->url(-action => "logout", -mode_during => "ase", -mode_after => "logout"));
$html .= "" . $cgi->submit('submit','logout') . "
";
$html .= $cgi->end_form;
}
elsif ($cfg->{identification}->{mode} eq "basicauth") {
# nop
}
elsif ($cfg->{identification}->{mode} eq "naive") {
$html .= $cgi->start_form(-action => "$myurl?page=logout");
$html .= "" . $cgi->submit('submit','logout') . "
";
$html .= $cgi->end_form;
}
elsif ($cfg->{identification}->{mode} eq "constant") {
# nop
}
else {
# nop, misconfigured
}
$html .= ' ';
return $html;
}
sub viewlogout ()
{
my ($html, $username);
# HTTP header
$response->{header}->{type} = 'text/html';
$response->{header}->{expires} = '+1s';
$html = '';
$html .= &viewhtmlhead(-menu);
if ($cfg->{identification}->{mode} eq "ase" and defined $ase) {
# nop
}
elsif ($cfg->{identification}->{mode} eq "basicauth") {
# nop
}
elsif ($cfg->{identification}->{mode} eq "naive") {
$session->clear('username');
}
elsif ($cfg->{identification}->{mode} eq "constant") {
# nop
}
else {
# nop, misconfigured
}
# identify username after logout attempt
$username = &identifyusername();
if (not defined $username) {
$html .= "Logged out \n";
}
else {
$html .= "Logout failed; \n";
}
$html .= &viewhtmltail();
# HTTP message
$response->{message}->divert("message");
$response->{message}->append(&canvas($html));
$response->{message}->undivert(0);
}
sub viewmainform ()
{
my $html;
$html = '';
$html .= '';
$html .= $cgi->start_form(-action => "$myurl?page=main");
$html .= "" . $cgi->submit('submit','main') . "
";
$html .= $cgi->end_form;
$html .= ' ';
return $html;
}
sub viewdropxmlform ()
{
my $html;
$html = '';
$html .= '';
$html .= $cgi->start_form(-action => "$myurl?page=dropxml");
$html .= "" . $cgi->submit('submit','dropxml') . "
";
$html .= $cgi->end_form;
$html .= ' ';
return $html;
}
sub execassociation ()
{
my $html;
my ($formstruct, $username, $headerout);
$html = '';
$username = &identifyusername();
if (not defined $username) {
$html .= "Access denied ";
$html .= "Login to authenticate";
return $html;
}
$formstruct = {};
foreach my $k (keys %{$cgi->Vars()}) {
if ($k =~ m|^([^/]+)/([^/]+)/([^/]+)$|) {
$formstruct->{$1}->{$2}->{$3} = $cgi->param($k);
$cgi->delete(-name=>$k);
}
}
$headerout = 0;
foreach my $mode ("arrival", "active", "departure") {
if ($cgi->param("$mode/modify")) {
foreach my $k (keys %{$formstruct->{$mode}}) {
if ($formstruct->{$mode}->{$k}->{check} eq 'on') {
$html .= "Updating " unless($headerout++);
my $associate;
$associate = '';
$associate = "associated = 'true', " if ($mode eq "arrival");
$dbh->{AutoCommit} = 1;
$sql = sprintf("UPDATE reg_instance SET %s registry_desc = ? WHERE ( uuid_registry = ? );", $associate);
$sth = $dbh->prepare($sql);
$rv = $sth->execute($formstruct->{$mode}->{$k}->{registry_desc}, $k);
if (not defined $rv) {
$msg = $dbh->errstr;
$msg =~ s/[ ]*ERROR:?[ ]*//;
$html .= sprintf("%s %s %s Deleting " unless($headerout++);
$dbh->{AutoCommit} = 1;
$sql = sprintf("DELETE FROM reg_instance WHERE ( uuid_registry = ? );");
$sth = $dbh->prepare($sql);
$rv = $sth->execute($k);
if (not defined $rv) {
$msg = $dbh->errstr;
$msg =~ s/[ ]*ERROR:?[ ]*//;
$html .= sprintf("%s %s %s Unlinking " unless($headerout++);
$dbh->{AutoCommit} = 1;
$sql = sprintf("UPDATE reg_instance SET registry_link = NULL WHERE ( uuid_registry = ? );");
$sth = $dbh->prepare($sql);
$rv = $sth->execute($k);
if (not defined $rv) {
$msg = $dbh->errstr;
$msg =~ s/[ ]*ERROR:?[ ]*//;
$html .= sprintf("%s %s %s Access denied ";
$html .= "Login to authenticate";
}
else {
$html .= sprintf("Instances related to %s ", $username);
$html .= "\n";
$html .= "";
$html .= "";
$html .= $cgi->start_form(-action => "$myurl?page=association");
$html .= "$headline ";
$html .= " ";
$html .= " \n";
$sql = sprintf("SELECT uuid_registry, registry_date, registry_desc, registry_link FROM reg_instance AS i %s WHERE ( %s );", $join, $where);
$rv = $dbh->selectall_hashref($sql, "uuid_registry");
if (not $rv) {
die "ERROR:$0: DataBase error: ".$dbh->errstr."\n";
}
if ((keys %{$rv}) == "") {
$html .= "\n";
$html .= "---empty--- ";
$html .= " \n";
}
else {
$html .= "";
# checkallboxes
$html .= "";
$html .= $cgi->checkbox(
-class => "checkbox",
-name => "$mode/checkallboxes",
-checked => ($mode eq "arrival" ? 1 : 0),
-label => "",
-onClick => "checkallboxes(this)"
) . " ";
$html .= "date registry description link \n";
my $row=1;
for my $i (sort keys %{$rv}) {
$html .= "";
# checkbox
$html .= "";
$html .= $cgi->checkbox(
-class => "checkbox",
-id => "row-$row",
-name => "$mode/$i/check",
-checked => ($mode eq "arrival" ? 1 : 0),
-label => ""
) . " ";
# date
$html .= "" . $rv->{$i}->{registry_date} . " ";
# registry
$html .= "" . $i . " ";
$html .= $cgi->textfield(
-name => "$mode/$i/registry_desc",
-override => 1,
-size => 50,
-maxlength => 50,
-default => $rv->{$i}->{registry_desc},
-onchange => "checkrowbox('row-$row')"
) . " ";
}
else {
$html .= "" . $rv->{$i}->{registry_desc} . "" . $rv->{$i}->{registry_link} . " \n";
$row++;
}
$html .= "";
$html .= "→ ";
$html .= "";
if ($mode eq "linked") {
$html .= "" . $cgi->submit("$mode/unlink",'unlink') . "
";
}
else {
$html .= "" . $cgi->submit("$mode/delete",'delete') . "
";
}
$html .= " ";
$html .= "";
if ($mode eq "arrival") {
$html .= $cgi->submit("$mode/modify",'modify and associate')
}
elsif ($mode ne "linked") {
$html .= $cgi->submit("$mode/modify",'modify and reload')
}
$html .= " ";
$html .= "";
$html .= " ";
$html .= " \n";
}
$cgi->delete(-name=>'username');
$cgi->hidden(-name=>'username', -value => $username);
$html .= $cgi->end_form;
$html .= "
";
}
sub execprofile ()
{
my $html;
my ($formstruct, $username, $headerout, $changes);
$html = '';
$username = &identifyusername();
if (not defined $username) {
$html .= "Access denied ";
$html .= "Login to authenticate";
return $html;
}
$formstruct = {};
foreach my $k (keys %{$cgi->Vars()}) {
if ($k =~ m|^([^/]+)/([^/]+)/([^/]+)$|) {
$formstruct->{$1}->{$2}->{$3} = $cgi->param($k);
$cgi->delete(-name=>$k);
}
}
$headerout = 0;
if ($cgi->param("profile/modify")) {
$changes = 0;
foreach my $k (keys %{$formstruct->{profile}->{username}}) {
my $v = $formstruct->{profile}->{username}->{$k};
$html .= "Updating Profile " unless($headerout++);
# We do not distinguish between empty string and
# undefined/NULL, but the database does. The logic here
# is: if our value is empty/undefined, we set the database
# record to empty in case it currently carries data. If
# the database record is NULL, we do not touch it. If
# our value is something not empty/undefined, we set the
# database record no matter if currently carries data or
# is NULL. The net result is that empty fields do not
# touch NULL records but they clear others and filled
# fields are set unconditionally. A db record may be left
# as NULL but once it has been set to something it will
# never return to the NULL state.
$dbh->{AutoCommit} = 1;
if ($v eq "") {
$sql = sprintf("UPDATE reg_user SET %s = ? WHERE ( username = ? AND %s != ? );", $k, $k);
}
else {
$sql = sprintf("UPDATE reg_user SET %s = ? WHERE ( username = ? AND ( %s IS NULL OR %s != ? ));", $k, $k, $k);
}
$sth = $dbh->prepare($sql);
$rv = $sth->execute($v, $username, $v);
if (not defined $rv) {
$msg = $dbh->errstr;
$msg =~ s/[ ]*ERROR:?[ ]*//;
$html .= sprintf("%s %s %s no changes \n");
}
};
$html .= "Creating Token ";
if (( $formstruct->{token}->{new}->{linkenable} eq "on"
or $formstruct->{token}->{new}->{assocenable} eq "on"
) and not $mok) {
$html .= sprintf("%s %s %s Updating Token " unless($headerout++);
if (( $formstruct->{token}->{$k}->{linkenable} eq "on"
or $formstruct->{token}->{$k}->{assocenable} eq "on"
) and not $mok) {
$html .= sprintf("%s %s %s Deleting Token " unless($headerout++);
# unlink all occurences of token from reg_instance
$dbh->{AutoCommit} = 1;
$sql = sprintf("UPDATE reg_instance SET registry_link = NULL WHERE ( registry_link = ? );");
$sth = $dbh->prepare($sql);
$rv = $sth->execute($k);
if (not defined $rv) {
$msg = $dbh->errstr;
$msg =~ s/[ ]*ERROR:?[ ]*//;
$html .= sprintf("%s %s %s Access denied ";
$html .= "Login to authenticate";
}
else {
$html .= sprintf("Profile of %s ", $username);
$html .= "";
$html .= "";
$html .= "" if ($mandatory);
$html .= "$long";
$html .= " " if ($mandatory);
$html .= " ";
$html .= "";
$html .= $cgi->textfield(
-name => "profile/username/$id",
-override => 1,
-size => $size,
-maxlength => $size,
-default => $rv->{username}->{$id},
) . " ";
$html .= " \n";
return $html;
}
sub condprofiletextarea ($$$$)
{
my ($id, $long, $columns, $rows) = @_;
$long =~ s/ / /g;
my $mandatory = $cfg->{profile}->{mandatories}->{$id};
my ($html);
$html = '';
# text2
$html .= "";
$html .= "";
$html .= "" if ($mandatory);
$html .= "$long";
$html .= " " if ($mandatory);
$html .= " ";
$html .= "";
$html .= $cgi->textarea(
-name => "profile/username/$id",
-override => 1,
-columns => $columns,
-rows => $rows,
-maxlength => $columns,
-default => $rv->{username}->{$id},
) . " ";
$html .= " \n";
return $html;
}
sub condprofilepicklist ($$$$)
{
my ($id, $long, $values, $labels) = @_;
$long =~ s/ / /g;
my $mandatory = $cfg->{profile}->{mandatories}->{$id};
my ($html);
$html = '';
# text2
$html .= "";
$html .= "";
$html .= "" if ($mandatory);
$html .= "$long";
$html .= " " if ($mandatory);
$html .= " ";
$html .= "";
$html .= $cgi->popup_menu(
-name => "profile/username/$id",
-values => $values,
-labels => $labels,
-default => $rv->{username}->{$id},
) . " ";
$html .= " \n";
return $html;
}
sub condprofile ($)
{
my ($username) = @_;
my ($html);
$html = '';
$html .= "\n";
$html .= "";
$html .= "";
$html .= $cgi->start_form(-action => "$myurl?page=profile");
$html .= "Profile ";
$html .= " ";
$html .= " \n";
$sql = "SELECT cc, human FROM reg_countrycodes;";
$rv = $dbh->selectall_hashref($sql, "cc");
if (not $rv) {
die "ERROR:$0: DataBase error: ".$dbh->errstr."\n";
}
my @countrycodes;
my $countrycodeshuman = {};
push @countrycodes, "";
$countrycodeshuman->{""} = "";
for my $k (sort keys %{$rv}) {
push @countrycodes, $k;
$countrycodeshuman->{$k} = "$k = " . $rv->{$k}->{human};
}
$sql = "SELECT bc FROM reg_businesscategories;";
$rv = $dbh->selectall_hashref($sql, "bc");
if (not $rv) {
die "ERROR:$0: DataBase error: ".$dbh->errstr."\n";
}
my @businesscategories;
push @businesscategories, "";
for my $k (sort keys %{$rv}) {
push @businesscategories, $k;
}
$sql = sprintf("SELECT * FROM reg_user WHERE ( username = '%s' );", $username);
$rv = $dbh->selectall_hashref($sql, "username");
if (not $rv) {
die "ERROR:$0: DataBase error: ".$dbh->errstr."\n";
}
$rv->{username} = $rv->{$username};
my @timezones;
push @timezones, "";
for (my $i=-12; $i<=14; $i++) {
push @timezones, "UTC" . (($i<0 or $i>0) ? sprintf("%+05d", $i*100) : "");
};
$html .= &condprofiletextfield ("fullname", "Full Name", 50);
$html .= &condprofiletextfield ("organization", "Organization", 50);
$html .= &condprofilepicklist ("businesscategory", "Business Category", \@businesscategories);
$html .= &condprofiletextarea ("addresslabel", "Address Label", 30, 6);
$html .= &condprofilepicklist ("country", "Country", \@countrycodes, $countrycodeshuman);
$html .= &condprofilepicklist ("timezone", "Time Zone", \@timezones);
$html .= &condprofiletextfield ("telephonenumber", "Telephone Number", 50);
$html .= &condprofiletextfield ("mobilenumber", "Mobile Number", 50);
$html .= "";
$html .= "→ ";
$html .= "";
$html .= "" . $cgi->submit("profile/modify",'modify') . "
";
$html .= " ";
$html .= " \n";
$html .= $cgi->end_form;
$html .= "
";
#
# token
#
if ($cfg->{profile}->{token}->{uienable}) {
my $row = 0;
$html .= "\n";
$html .= "";
$html .= "";
$html .= $cgi->start_form(-action => "$myurl?page=profile");
$html .= "Token ";
$html .= " ";
$html .= " \n";
my $mok = &profilemandatoriesok($username);
if (not $mok) {
$html .= "";
$html .= "token features link and assoc unavailable because profile prerequisites not met\n";
$html .= " ";
}
$html .= "";
$html .= "id description user link assoc \n";
# new token
$html .= "";
# checkbox
$html .= "";
$html .= $cgi->checkbox(
-class => "checkbox",
-id => "row-$row",
-name => "token/new/check",
-checked => 1,
-label => ""
) . " ";
# id
$html .= "xxxxxxxx-xxxx-xxxx-xxxx-xxxxxxxxxxxx ";
$html .= $cgi->textfield(
-name => "token/new/description",
-override => 1,
-size => 50,
-maxlength => 50,
-default => "unspecified",
-onchange => "checkrowbox('row-$row')"
) . " ";
# userenable
$html .= "";
$html .= $cgi->checkbox(
-class => "checkbox",
-name => "token/new/userenable",
-checked => 1,
-label => "",
-onchange => "checkrowbox('row-$row')"
) . " ";
# usercount
$html .= "0 ";
# linkenable
$html .= "";
$html .= $cgi->checkbox(
-class => "checkbox",
-name => "token/new/linkenable",
-checked => $mok,
-label => "",
-onchange => "checkrowbox('row-$row')"
) . " ";
# linkcount
$html .= "0 ";
# assocenable
$html .= "";
$html .= $cgi->checkbox(
-class => "checkbox",
-name => "token/new/assocenable",
-checked => $mok,
-label => "",
-onchange => "checkrowbox('row-$row')"
) . " ";
# assoccount
$html .= "0 ";
$html .= " ";
$html .= "";
$html .= "→ ";
$html .= "";
$html .= "" . $cgi->submit("token/new",'new') . "
";
$html .= " ";
$html .= " ";
$html .= "";
$html .= " ";
$html .= " \n";
$row++;
# delete/modify existing tokens
$sql = sprintf("SELECT * FROM reg_token WHERE ( username = '%s' );", $username);
$rv = $dbh->selectall_hashref($sql, "id");
if (not $rv) {
die "ERROR:$0: DataBase error: ".$dbh->errstr."\n";
}
my @keys = sort keys %{$rv};
if (@keys >= 1) {
for my $k (@keys) {
$html .= "";
# checkbox
$html .= "";
$html .= $cgi->checkbox(
-id => "row-$row",
-class => "checkbox",
-name => "token/$k/check",
-checked => 0,
-label => ""
) . " ";
# id
$html .= "" . $k . " ";
$html .= $cgi->textfield(
-name => "token/$k/description",
-override => 1,
-size => 50,
-maxlength => 50,
-default => $rv->{$k}->{description},
-onchange => "checkrowbox('row-$row')"
) . " ";
# userenable
$html .= "";
$html .= $cgi->checkbox(
-class => "checkbox",
-name => "token/$k/userenable",
-checked => $rv->{$k}->{userenable},
-label => "",
-onclick => "checkrowbox('row-$row')"
) . " ";
# usercount
$html .= "" . $rv->{$k}->{usercount} . " ";
# linkenable
$html .= "";
$html .= $cgi->checkbox(
-class => "checkbox",
-name => "token/$k/linkenable",
-checked => $rv->{$k}->{linkenable},
-label => "",
-onclick => "checkrowbox('row-$row')"
) . " ";
# linkcount
$html .= "" . $rv->{$k}->{linkcount} . " ";
# assocenable
$html .= "";
$html .= $cgi->checkbox(
-class => "checkbox",
-name => "token/$k/assocenable",
-checked => $rv->{$k}->{assocenable},
-label => "",
-onclick => "checkrowbox('row-$row')"
) . " ";
# assoccount
$html .= "" . $rv->{$k}->{assoccount} . " ";
$html .= " \n";
$row++;
}
$html .= "";
$html .= "→ ";
$html .= "";
$html .= "" . $cgi->submit("token/delete",'delete') . "
";
$html .= " ";
$html .= "";
$html .= "" . $cgi->submit("token/modify",'modify') . "
";
$html .= " ";
$html .= " \n";
}
$html .= "";
$html .= "";
$html .= "Legend:id = the actual token to be used for openpkg register commanddescription = assume this information is visible to the publicuser = token enabled for --user= replacementlink = token enabled for --link= usageassoc = token enabled for automatic association (practically requires user or link)numbers = show token and feature use count statistic ";
$html .= " \n";
$cgi->delete(-name=>'username');
$html .= $cgi->hidden(-name=>'username', -value => $username);
$html .= $cgi->end_form;
$html .= "
";
};
}
sub execdropxml ()
{
my $html;
my $data;
$html = '';
if (&uao()) {
$html .= "\n";
$html .= "\n";
}
$data = $cgi->param("data");
if (not defined $data) {
if (&uao()) {
$html .= "\n";
$html .= " \n";
}
return($html)
}
$data =~ s|^[^<]*<|<|s; # cut off crap preceeding opening brace
$data =~ s|>[^>]*$|>|s; # cut off crap succeeding closing brace
if ($data eq "") {
if (&uao()) {
$html .= "\n";
$html .= " \n";
}
return($html)
}
# XMLin() requires the string being passed to start with '<'
# otherwise it is assumed the parameter is a filename to be
# read. We check for the closing brace at the end, too.
#
if (not $data =~ m|^<.*>$|s) {
if (&uao()) {
$html .= "\n";
$html .= "ERROR: not XML data\n";
$html .= " \n";
}
else {
$html .= sprintf("\n";
$html .= sprintf("ERROR: XML parser reports %s\n", $msg);
$html .= " \n";
}
else {
$html .= sprintf("\n";
$html .= sprintf("ERROR: at begin of transaction, DataBase reports %s\n", $msg);
$html .= " \n";
}
else {
$html .= sprintf("\n";
$html .= sprintf("ERROR: commit transaction failed, DataBase reports %s\n", $msg);
$html .= " \n";
}
else {
$html .= sprintf("\n";
$html .= sprintf("ERROR: rollback transaction failed, DataBase reports %s\n", $msg);
$html .= " \n";
}
else {
$html .= sprintf("\n" if (&uao());
foreach my $k (@keys) {
$msg = $res->{$k};
if ($msg eq "DONE") {
$msg = $ref->{request}->{$k}->{registry_desc};
if ($commit == 1) {
if (&uao()) {
$html .= sprintf(" %s \n", $k, $msg);
}
else {
$html .= sprintf("%s %s\n", $k, $msg);
}
}
else {
if (&uao()) {
$html .= sprintf(" IGNORED: %s \n", $k, $msg);
}
else {
$html .= sprintf("%s IGNORED: %s\n", $k, $msg);
}
}
}
else {
if (&uao()) {
$html .= sprintf(" %s \n", $k, $msg);
}
else {
$html .= sprintf("%s %s\n", $k, $msg);
}
}
}
$html .= " \n" if (&uao());
return($html);
}
sub viewdropxml ()
{
my $html;
# HTTP header
$response->{header}->{type} = &uao() ? 'plain/text' : 'text/html';
$response->{header}->{expires} = '+1s';
$html = '';
if (not &uao()) {
$html .= &viewhtmlhead(-menu);
}
$html .= &execdropxml();
if (not &uao()) {
if (defined $cgi->param("data")) {
$html .= "Correct registration data below ";
}
else {
$html .= "Paste registration data below ";
}
$html .= " \n";
$html .= &viewhtmltail();
}
# HTTP message
$response->{message}->divert("message");
$response->{message}->append(&uao() ? $html : &canvas($html));
$response->{message}->undivert(0);
}
sub printjscheckallboxes ()
{
my $js;
$js = <<'EOT';
EOT
return $js;
}
sub canvas ($)
{
my ($page) = @_;
my ($head, $body, $canvas);
$head = '';
$head = $1 if ($page =~ m|]*>(.*)|s);
$body = '';
$body = $1 if ($page =~ m|]*>(.*) |s);
(undef, undef, $canvas) = &fetchurlcached($cfg->{canvas}->{url});
if (not defined $canvas or $canvas eq "") {
$canvas =
"\n" .
"\n" .
"