OpenPKG CVS Repository
http://cvs.openpkg.org/
____________________________________________________________________________
Server: cvs.openpkg.org Name: Thomas Lotterer
Root: /v/openpkg/cvs Email: [EMAIL PROTECTED]
Module: openpkg-registry Date: 30-Jun-2006 16:55:01
Branch: HEAD Handle: 2006063015550000
Modified files:
openpkg-registry registry-ui.pl
Log:
work off to leverage String::Divert
Summary:
Revision Changes Path
1.62 +253 -221 openpkg-registry/registry-ui.pl
____________________________________________________________________________
patch -p0 <<'@@ .'
Index: openpkg-registry/registry-ui.pl
============================================================================
$ cvs diff -u -r1.61 -r1.62 registry-ui.pl
--- openpkg-registry/registry-ui.pl 30 Jun 2006 12:15:29 -0000 1.61
+++ openpkg-registry/registry-ui.pl 30 Jun 2006 14:55:00 -0000 1.62
@@ -35,6 +35,7 @@
use DBD::Pg;
use MIME::Base64;
use XML::Simple;
+use String::Divert;
# configure optional debugging
$Data::Dumper::Purity = 1;
@@ -43,13 +44,19 @@
# program name, version and date
my $progname="registry-ui.pl";
-my $progvers="0.4.1";
-my $progdate="12-May-2006";
+my $progvers="0.5.0";
+my $progdate="20060224234220";
# determine path to OpenPKG instance
my $PREFIX='@l_prefix@';
$PREFIX=$ENV{OPENPKG_PREFIX} if ($ENV{OPENPKG_PREFIX} ne "");
+# initialize output
+my $response = {};
+$response->{header} = {};
+$response->{message} = new String::Divert;
+$response->{message}->fold("message");
+
# configuration
#
my $cfg = {};
@@ -74,8 +81,8 @@
$cfg->{canvas}->{mark_body}="<!-- CANVAS: BODY -->";
$cfg->{page}->{default} = undef;
$cfg->{status}->{showuser} = 1;
-$cfg->{status}->{showversion} = 1;
-$cfg->{status}->{showsid} = 1;
+$cfg->{status}->{showversion} = 0;
+$cfg->{status}->{showsid} = 0;
my $ase;
$ase = undef;
@@ -85,12 +92,11 @@
}
# create objects
-my $cgi = new CGI;
+my $cgi = new CGI;
my $myurl = $cgi->url(-relative => 1) || ".";
my $sid = $cgi->cookie("registry-sid") || undef;
-my $requestedpage = $cgi->url_param("page") || $cfg->{page}->{default};
-$cgi->delete(-name=>'page');
-my $out = undef;
+my $requestedpage = $cgi->url_param("page") || $cfg->{page}->{default};
$cgi->delete(-name=>'page');
+my $session; $session = undef;
# database handle and scratch variables
#
@@ -102,7 +108,7 @@
my $dbh; # database handle
my $dbs; # database handle for session
-sub dbopen($) {
+sub dbopen ($) {
my ($db) = @_;
my $dbi;
$dbi = undef;
@@ -138,49 +144,51 @@
# first check for pages which do not require database access
#
if ($requestedpage eq "css") {
- $out = '';
- $out .= &viewhttp('text/css', '+3600s');
- $out .= &viewcss();
- print STDOUT $out;
+ &viewcss();
+ goto CUS;
}
elsif ($requestedpage eq "jpg") {
- $out = '';
- $out .= &viewhttp('image/jpg', '+3600s');
- $out .= &viewjpg($cgi->param("name"));
- print STDOUT $out;
+ &viewjpg($cgi->param("name"));
+ goto CUS;
}
elsif ($requestedpage eq "gif") {
- $out = '';
- $out .= &viewhttp('image/gif', '+3600s');
- $out .= &viewgif($cgi->param("name"));
- print STDOUT $out;
+ &viewgif($cgi->param("name"));
+ goto CUS;
}
+else { #FIXME defer indentation making diff better readable
# pages below require database access
#
$dbh = &dbopen("registry");
if (not defined $dbh) {
- &printprettyerror("Registry database backend unavailable",
&prettydbi()); #FIXME we get a guru here but it should be a pretty message
+ &viewprettyerror("Registry database backend unavailable", &prettydbi());
goto CUS;
}
$dbs = &dbopen("session");
if (not defined $dbs) {
- &printprettyerror("Session database not accessible", &prettydbi());
+ &viewprettyerror("Session database not accessible", &prettydbi());
goto CUS;
}
# establish CGI Session object
-my $session;
-$session = undef;
CGI::Session->name("registry-sid");
$session = new CGI::Session(
"driver:sqlite;serializer:Storable;id:uuid", $sid, { Handle => $dbs,
TableName => 'session' }
);
if (not defined $session) {
- &printprettyerror("Session handling failed", "");
+ &viewprettyerror("Session handling failed", "");
goto CUS;
}
+# response cookies for session persistency
$session->expire("+3600s");
+if ($session->is_new()) {
+ $response->{header}->{cookie} = $cgi->cookie(
+ -name => $session->name(),
+ -value => $session->id(),
+ -expires => sprintf("+%ds", $session->expires()),
+ -path => $cgi->url(-absolute => 1)
+ )
+}
if ($cfg->{identification}->{mode} eq "ase") {
# establish ASE object
@@ -192,7 +200,7 @@
-session => $session,
);
if (not defined $ase) {
- &printprettyerror("Affiliation Services Environment", "");
+ &viewprettyerror("Affiliation Services Environment", "");
goto CUS;
}
@@ -203,7 +211,7 @@
print $ase->response();
}
else {
- &printprettyerror("Affiliation Services Environment",
$ase->error());
+ &viewprettyerror("Affiliation Services Environment",
$ase->error());
}
goto CUS;
}
@@ -212,69 +220,53 @@
# continue to the pages that require database access
#
if ($requestedpage eq "login") {
- $out = '';
- $out .= &viewhttp();
- $out .= &viewhtmlhead(-menu);
- $out .= &viewlogin();
- $out .= &viewhtmltail();
- print STDOUT &canvas($out);
+ &viewlogin();
}
elsif ($requestedpage eq "logout") {
- $out = '';
- $out .= &viewhttp();
- $out .= &viewhtmlhead(-menu);
- $out .= &viewlogout();
- $out .= &viewhtmltail();
- print STDOUT &canvas($out);
+ &viewlogout();
}
elsif ($requestedpage eq "asecomeback") {
- $out = '';
- $out .= &viewasecomeback();
- print STDOUT &canvas($out);
+ &viewasecomeback();
}
elsif ($requestedpage eq "association") {
- $out = '';
- $out .= &viewhttpauthrequired("association");
- $out .= &viewhtmlhead(-menu);
- $out .= &viewassociation();
- $out .= &viewhtmltail();
- print STDOUT &canvas($out);
-}
-elsif ($requestedpage eq "dropxml" and not &uao()) {
- $out = '';
- $out .= &viewhttp();
- $out .= &viewhtmlhead(-menu);
- $out .= &viewdropxml();
- $out .= &viewhtmltail();
- print STDOUT &canvas($out);
-}
-elsif ($requestedpage eq "dropxml" and &uao()) {
- $out = '';
- $out .= &viewhttp("plain/text");
- $out .= &viewdropxml();
- print STDOUT $out;
+ &viewassociation();
+}
+elsif ($requestedpage eq "dropxml") {
+ &viewdropxml();
}
elsif ($requestedpage eq "ase") {
- $out = '';
- $out .= &viewhttp();
- $out .= &viewhtmlhead(-menu);
- $out .= &viewhtmltail();
- print STDOUT &canvas($out);
+ &viewemptypage();
}
else {
- if (not defined $out) {
- $out = '';
- $cgi->delete_all();
- $out .= &viewhttp();
- $out .= &viewhtmlhead(-menu);
- $out .= &viewhtmltail();
- print STDOUT &canvas($out);
- }
+ $cgi->delete_all();
+ &viewemptypage();
}
+} #FIXME defer indentation making diff better readable
-# die gracefully ;-)
+# cleanup sequence
#
CUS:
+if ($response->{header}->{redirect}) {
+ print STDOUT $cgi->redirect(
+ -nph => 0,
+ -uri => $response->{header}->{redirect},
+ -type => $response->{header}->{type},
+ -status => $response->{header}->{status},
+ -expires => $response->{header}->{expires},
+ -cookie => $response->{header}->{cookie}
+ ) . $response->{message}->unfold();
+}
+else {
+ print STDOUT $cgi->header(
+ -nph => 0,
+ -type => $response->{header}->{type},
+ -status => $response->{header}->{status},
+ -expires => $response->{header}->{expires},
+ -cookie => $response->{header}->{cookie}
+ ) . $response->{message}->unfold();
+}
+$response->{message}->destroy();
+undef $response->{message};
undef $ase;
undef $session;
undef $cgi;
@@ -283,60 +275,11 @@
# check whether user agent is openpkg-register
#
-sub uao()
+sub uao ()
{
return $cgi->user_agent() =~
m:^openpkg-regist(er|ry)/[01][\.ab]\d+[\.ab]\d+$:;
}
-sub httpheader ($$$)
-{
- my ($type, $expires, $refresh) = @_;
- my $header = {};
- $header->{type} = $type || 'text/html';
- $header->{expires} = $expires || '+1s';
- if ($refresh) {
- $header->{refresh} = "$refresh; $myurl";
- }
-
- # determine HTTP response cookies for session persistency
- if (defined $session and $session->is_new()) {
- $header->{cookie} = $cgi->cookie(
- -name => $session->name(),
- -value => $session->id(),
- -expires => sprintf("+%ds", $session->expires()),
- -path => $cgi->url(-absolute => 1)
- )
- }
-
- return $header;
-}
-
-sub viewhttp ($$$)
-{
- my ($type, $expires, $refresh) = @_;
- my $header = {};
-
- $header = &httpheader($type, $expires, $refresh);
-
- return $cgi->header($header);
-}
-
-sub viewhttpauthrequired($$$$)
-{
- my ($page, $type, $expires, $refresh) = @_;
- my ($header, $username);
-
- $header = &httpheader($type, $expires, $refresh);
-
- $username = &identifyusername();
- if (not defined $username or $username eq '') {
- if ($cfg->{identification}->{mode} eq "ase" and defined $ase) {
- $header->{redirect} = $cgi->redirect(-uri => $ase->url(-action
=> "login", -mode_during => "ase", -mode_after => $page));
- }
- }
- return $cgi->header($header);
-}
-
sub viewhtmlhead (;$)
{
my ($menu) = @_;
@@ -365,7 +308,6 @@
$head .= " </tr>\n";
$head .= " <tr>\n";
$head .= " <td colspan=\"" . $td . "\">\n";
- $head .= &prettyauthinfo("fancy");
$head .= " </td>\n";
$head .= " </tr>\n";
$head .= " </table>\n";
@@ -384,14 +326,14 @@
$text = "";
$username = &identifyusername();
- if ($username ne "") {
+ if (defined $username) {
$text .= "authenticated as " . $boldon . $username . $boldoff;
}
else {
$text .= "you are " . $boldon . "not authenticated" . $boldoff;
}
- if ($cfg->{identification}->{mode} eq "ase") {
+ if ($cfg->{identification}->{mode} eq "ase" and defined $ase) {
$text .= " via ase login";
}
elsif ($cfg->{identification}->{mode} eq "basicauth") {
@@ -445,8 +387,15 @@
}
sub viewcss () {
- my $css = '';
+ my $css;
+ # HTTP header
+ $response->{header}->{type} = 'text/css';
+ $response->{header}->{expires} = '+3600s';
+
+ # HTTP message
+ $response->{message}->divert("message");
+ $css = '';
$css .= "/*\n";
$css .= "** registry-ui.pl - OpenPKG registration user interface\n";
$css .= "*/\n";
@@ -459,7 +408,7 @@
$css .= "}\n";
$css .= "DIV.status {\n";
$css .= " font-family: sans-serif, helvetica, arial;\n";
- $css .= " font-size: 66%;\n";
+ $css .= " font-size: 100% /* 66% */;\n";
$css .= "}\n";
$css .= "BODY.registry DIV.registry {\n";
$css .= " background-image: url($myurl?page=jpg&name=bg);\n";
@@ -548,11 +497,11 @@
$css .= ".registry TABLE.association TD {\n";
$css .= " padding: 0px 10px 0px 10px;\n";
$css .= "}\n";
-
- return $css;
+ $response->{message}->append($css);
+ $response->{message}->undivert(0);
}
-sub viewjpg () {
+sub viewjpg ($) {
my ($name) = @_;
$name .= ".jpg";
@@ -944,10 +893,17 @@
EOT
};
- return decode_base64($jpg->{$name});
+ # HTTP header
+ $response->{header}->{type} = 'image/gif';
+ $response->{header}->{expires} = '+3600s';
+
+ # HTTP message
+ $response->{message}->divert("message");
+ $response->{message}->append(decode_base64($jpg->{$name}));
+ $response->{message}->undivert(0);
}
-sub viewgif () {
+sub viewgif ($) {
my ($name) = @_;
$name .= ".gif";
@@ -970,10 +926,17 @@
EOT
};
- return decode_base64($gif->{$name});
+ # HTTP header
+ $response->{header}->{type} = 'image/gif';
+ $response->{header}->{expires} = '+3600s';
+
+ # HTTP message
+ $response->{message}->divert("message");
+ $response->{message}->append(decode_base64($gif->{$name}));
+ $response->{message}->undivert(0);
}
-sub viewassociationform()
+sub viewassociationform ()
{
my ($html);
$html = '';
@@ -985,7 +948,7 @@
return $html;
}
-sub viewloginform()
+sub viewloginform ()
{
my $html;
$html = '';
@@ -1020,13 +983,10 @@
return $html;
}
-sub viewasecomeback()
+sub viewasecomeback ()
{
- my ($redirect, $username);
- my $html;
- my $header = {};
+ my ($html, $username);
- $html = '';
$username = &identifyusername();
if (defined $username) {
@@ -1036,52 +996,52 @@
$sql = sprintf("UPDATE reg_user SET heartbeat = now() WHERE (
username = '%s' );", $username);
$rv = $dbh->do($sql);
if (not defined $rv) {
- $html .= &printprettyerror("updating user $username",
prettydbi());
+ &viewprettyerror("updating user $username", prettydbi());
+ goto CUS;
}
elsif ($rv != 1) {
$sql = sprintf("INSERT INTO reg_user (username) VALUES ('%s');",
$username);
$rv = $dbh->do($sql);
if (not defined $rv) {
- $html .= &printprettyerror("inserting user $username",
prettydbi());
+ &viewprettyerror("inserting user $username", prettydbi());
+ goto CUS;
}
elsif ($rv != 1) {
- $html .= &printprettyerror("creating user $username",
prettydbi());
+ &viewprettyerror("creating user $username", prettydbi());
+ goto CUS;
}
}
}
- return $html if ($html);
- $header->{redirect} = $cgi->redirect(-uri => "$myurl?page=login");
- return $cgi->header($header);
-}
-
-sub printprettyerror($$)
-{
- my ($marketingmessage, $technicaldetail) = @_;
- my $out;
- $out = '';
- $out .= &viewhttp();
- $out .= &viewhtmlhead();
- $out .= &viewprettyerror($marketingmessage, $technicaldetail);
- $out .= &viewhtmltail();
- print STDOUT &canvas($out);
+ # HTTP header
+ $response->{header}->{type} = 'text/html';
+ $response->{header}->{expires} = '+1s';
+ $response->{header}->{redirect} = "$myurl?page=login";
}
-sub viewprettyerror($$)
+sub viewprettyerror ($$)
{
my ($marketingmessage, $technicaldetail) = @_;
my $html;
+ # HTTP header
+ $response->{header}->{type} = 'text/html';
+ $response->{header}->{expires} = '+1s';
+
$html = '';
$html .= "<h2>Sorry</h2>\n";
$html .= "<img src=\"?page=gif;name=icon-x\"> an internal
<b>ERROR</b> occurred and prevents further processing.<br/>\n";
$html .= sprintf("<h2>Problem scope</h2>\n%s<br/>\n", $marketingmessage)
if (defined $marketingmessage and $marketingmessage ne "");
$html .= sprintf("<h2>Technical details</h2>\n%s<br/>\n",
$technicaldetail) if (defined $technicaldetail and $technicaldetail ne "");
$html .= "<h2>Please come back later and try again</h2>\nSorry for the
inconvenience\n";
- return $html
+
+ # HTTP message
+ $response->{message}->divert("message");
+ $response->{message}->append(&canvas($html));
+ $response->{message}->undivert(0);
}
-sub prettydbi()
+sub prettydbi ()
{
my $msg;
$msg = $DBI::errstr;
@@ -1090,12 +1050,36 @@
return $msg;
}
-sub viewlogin()
+sub viewemptypage ()
{
my ($html, $username);
+
+ # HTTP header
+ $response->{header}->{type} = 'text/html';
+ $response->{header}->{expires} = '+1s';
+
$html = '';
+ $html .= &viewhtmlhead(-menu);
+ $html .= &viewhtmltail();
- if ($cfg->{identification}->{mode} eq "ase") {
+ # HTTP message
+ $response->{message}->divert("message");
+ $response->{message}->append(&canvas($html));
+ $response->{message}->undivert(0);
+}
+
+sub viewlogin ()
+{
+ 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") {
@@ -1111,18 +1095,26 @@
# nop, misconfigured
}
+ # identify username after login attempt
$username = &identifyusername();
- if ($username ne "") {
+
+ if (defined $username) {
$html .= "<h2>Login successful</h2>\n";
$html .= "Welcome,<br>\n" . $username . "<br>\n";
}
else {
$html .= "<h2>Login failed</h2>\n";
}
- return $html;
+
+ $html .= &viewhtmltail();
+
+ # HTTP message
+ $response->{message}->divert("message");
+ $response->{message}->append(&canvas($html));
+ $response->{message}->undivert(0);
}
-sub viewlogoutform()
+sub viewlogoutform ()
{
my $html;
$html = '';
@@ -1150,12 +1142,18 @@
return $html;
}
-sub viewlogout()
+sub viewlogout ()
{
- my ($html);
+ my ($html, $username);
+
+ # HTTP header
+ $response->{header}->{type} = 'text/html';
+ $response->{header}->{expires} = '+1s';
+
$html = '';
+ $html .= &viewhtmlhead(-menu);
- if ($cfg->{identification}->{mode} eq "ase") {
+ if ($cfg->{identification}->{mode} eq "ase" and defined $ase) {
# nop
}
elsif ($cfg->{identification}->{mode} eq "basicauth") {
@@ -1171,13 +1169,24 @@
# nop, misconfigured
}
- $session->delete();
- $session = undef;
- $html .= "<h2>Logout completed</h2>\n";
- return $html;
+ # identify username after logout attempt
+ $username = &identifyusername();
+ if (not defined $username) {
+ $html .= "<h2>Logged out</h2>\n";
+ }
+ else {
+ $html .= "<h2>Logout failed;</h2>\n";
+ }
+
+ $html .= &viewhtmltail();
+
+ # HTTP message
+ $response->{message}->divert("message");
+ $response->{message}->append(&canvas($html));
+ $response->{message}->undivert(0);
}
-sub viewdropxmlform()
+sub viewdropxmlform ()
{
my $html;
$html = '';
@@ -1189,7 +1198,7 @@
return $html;
}
-sub execassociation()
+sub execassociation ()
{
my $html;
my ($formstruct, $username, $headerout);
@@ -1273,30 +1282,40 @@
return $html;
}
-sub viewassociation()
+sub viewassociation ()
{
- my $html;
- my $username;
+ my ($html, $username);
+
+ # HTTP header
+ $response->{header}->{type} = 'text/html';
+ $response->{header}->{expires} = '+1s';
$html = '';
+ $html .= &viewhtmlhead(-menu);
$username = &identifyusername();
if (not defined $username) {
$html .= "<h2>Access denied</h2>";
$html .= "Login to authenticate";
- return $html;
}
- $html .= sprintf("<h2>Instances related to %s</h2>", $username);
- $html .= "<hr>\n";
+ else {
+ $html .= sprintf("<h2>Instances related to %s</h2>", $username);
+ $html .= "<hr>\n";
+
+ $html .= &execassociation();
+ $html .= &condassociation("arrival", $username);
+ $html .= &condassociation("active", $username);
+ $html .= &condassociation("departure", $username);
+ }
- $html .= &execassociation();
- $html .= &condassociation("arrival", $username);
- $html .= &condassociation("active", $username);
- $html .= &condassociation("departure", $username);
+ $html .= &viewhtmltail();
- return $html;
+ # HTTP message
+ $response->{message}->divert("message");
+ $response->{message}->append(&canvas($html));
+ $response->{message}->undivert(0);
}
-sub condassociation($)
+sub condassociation ($)
{
my ($mode, $username) = @_;
my ($html, $where, $headline);
@@ -1405,7 +1424,7 @@
$html .= "</table>";
}
-sub execdropxml()
+sub execdropxml ()
{
my $html;
my $data;
@@ -1634,41 +1653,54 @@
return($html);
}
-sub viewdropxml()
+sub viewdropxml ()
{
my $html;
- my $data;
+
+ # HTTP header
+ $response->{header}->{type} = &uao() ? 'plain/text' : 'text/html';
+ $response->{header}->{expires} = '+1s';
+
$html = '';
+ if (not &uao()) {
+ $html .= &viewhtmlhead(-menu);
+ }
$html .= &execdropxml();
- return $html if (&uao());
- if (defined $cgi->param("data")) {
- $html .= "<h2>Correct registration data below</h2>";
- }
- else {
- $html .= "<h2>Paste registration data below</h2>";
+ if (not &uao()) {
+ if (defined $cgi->param("data")) {
+ $html .= "<h2>Correct registration data below</h2>";
+ }
+ else {
+ $html .= "<h2>Paste registration data below</h2>";
+ }
+
+ $html .= " <table class=\"menu\">\n";
+ $html .= " <tr>\n";
+ $html .= " <td>\n";
+ $html .= $cgi->start_form(-action => "$myurl?page=dropxml");
+ $html .= "<div>" . $cgi->textarea(
+ -name => 'data',
+ -columns => 80,
+ -rows => 15,
+ -default => '',
+ ) . "</div>\n";
+ $html .= "<div>" . $cgi->submit('submit','register') . "</div>";
+ $html .= $cgi->end_form;
+ $html .= " </td>\n";
+ $html .= " </tr>\n";
+ $html .= " </table>\n";
+ $html .= &viewhtmltail();
}
- $html .= " <table class=\"menu\">\n";
- $html .= " <tr>\n";
- $html .= " <td>\n";
- $html .= $cgi->start_form(-action => "$myurl?page=dropxml");
- $html .= "<div>" . $cgi->textarea(
- -name => 'data',
- -columns => 80,
- -rows => 15,
- -default => '',
- ) . "</div>\n";
- $html .= "<div>" . $cgi->submit('submit','register') . "</div>";
- $html .= $cgi->end_form;
- $html .= " </td>\n";
- $html .= " </tr>\n";
- $html .= " </table>\n";
- return $html;
+ # HTTP message
+ $response->{message}->divert("message");
+ $response->{message}->append(&uao() ? $html : &canvas($html));
+ $response->{message}->undivert(0);
}
-sub printjscheckallboxes()
+sub printjscheckallboxes ()
{
my $js;
$js = <<'EOT';
@@ -1689,7 +1721,7 @@
return $js;
}
-sub canvas($)
+sub canvas ($)
{
my ($page) = @_;
my ($http, $head, $body, $canvas);
@@ -1748,7 +1780,7 @@
$rv = $dbs->do("DELETE FROM cache WHERE ( expires <= ? );", undef,
time()) or die $dbs->errstr(); #FIXME
# dig in the cache
- $sth = $dbs->prepare_cached("SELECT content_type, expires, content FROM
cache WHERE url = ?;") or die $dbs->errstr(); #FIXME
+ $sth = $dbs->prepare("SELECT content_type, expires, content FROM cache
WHERE url = ?;") or die $dbs->errstr(); #FIXME
$sth->execute($url) or die $dbs->errstr(); #FIXME
$rv = $sth->fetchrow_hashref;
@@ -1796,7 +1828,7 @@
return $content_type, $expires, $content;
}
-sub identifyusername()
+sub identifyusername ()
{
my $username;
$username = undef;
@@ .
______________________________________________________________________
The OpenPKG Project www.openpkg.org
CVS Repository Commit List openpkg-cvs@openpkg.org
