[BACK]Return to LOTP CVS log [TXT] [DIR] Up to [Public] / perl / modules / CGI
File:  [Public] / perl / modules / CGI / LOTP
Revision 1.3: download - view: text, annotated - select for diffs
Sun Oct 8 01:24:39 2000 UTC (23 years, 8 months ago) by eric
Branches: MAIN
CVS tags: threads, release2, amaya5_3release, V1_2, HEAD
cleaned up refs to W3CAclInterface

#!/usr/bin/perl

## W3C LOTP - dispatch LOTP datagrams

#Copyright Massachusetts Institute of technology, 2000.
#Written by Eric Prud'hommeaux

#things that need to be done:
#1. write it

#####
# What It Does:
# presents form to query LOTP applets. The form is preloaded with a 
# sample Adder applet. LOTP hands its output back to itself.

#####
# set up module environment

BEGIN {unshift@INC,('..');}

$LOTP::REVISION = '$Id: LOTP,v 1.3 2000/10/08 01:24:39 eric Exp $ ';
package LOTP;
use vars qw($REVISION $VERSION);

$VERSION=0.95;

# --- DEBUGGING MODE ---
use CGI;
use strict;
use W3C::Util::W3CDebugCGI;
use W3C::LOTP::TransferAdapters::CGI;
use W3C::Util::Exception;
my $query = new W3C::Util::W3CDebugCGI($0, $ARGV[0] eq 'DEBUG', {-storeIn => '/tmp', -dieNoOpen => 1, -logExt => '.log'});
# ---- RELEASE MODE ----
#use CGI;
#$query = new CGI;
@XMLPresenter::ISA = (qw(Presenter));
@HTMLPresenter::ISA = (qw(Presenter));


#####
# main - either LOTP or show source

if ($query->param('w3c_showSource')) {
    &showMySources($query);
#} elsif ($query->param('w3c_LOTP') || $query->param('w3c_rdf_state')) {
} else {
    LOTP LOTP($query);
#    &resourcePrompt($query);
}

#####
# LOTP - present form to call and interpret rdf results
#

sub LOTP {
    my $proto = shift;
    my $class = ref $proto || $proto;
    my $self = {};
    bless ($self, $class);

    # constructor parameters
    ($self->{READ}) = @_;
    $self->{WRITE} = new CGI({});

    use W3C::LOTP::TransferAdapters::CGI;
    my $results; &read('test.lotp');
    eval {
	my $core = new W3C::LOTP::TransferAdapters::CGI->getCore;
	$core->handle($ENV{PATH_INFO}, $ENV{POST_VARS});
	$results = $core->getResults;
    }; if ($@) {if (my $ex = &catch('W3C::LOTP::AuthRequiredException')) {
	return print $self->requireAuth($ex->getRealm, $ex->getAccess);
    } elsif (my $ex = &catch('W3C::LOTP::NoSuchLibraryException')) {
	return print $self->noSuchLibrary($ex);
    } elsif (my $outerException = &catch('W3C::SAX::SAXParseException')) {
	eval {
	    my $core = new W3C::LOTP::TransferAdapters::CGI->getCore;
	    $self->importCGIParms;
	    $core->handle($ENV{PATH_INFO}, $self->{LOTP_POST});
	    $results = $core->getResults;
	}; if ($@) {if (my $ex = &catch('W3C::LOTP::AuthRequiredException')) {
	    return print $self->requireAuth($ex->getRealm, $ex->getAccess);
	} else {
	    return print $self->unknownException($outerException);
	}}
    } elsif (my $ex = &catch('W3C::Util::Exception')) {
	return print $self->unknownException($ex);
    } else {
	return print $self->unknownException(new W3C::Util::PerlException);
    }}

    # build accept table of the form ('text/html'=>0.7, 'text/html;level=1'=>1, '*/*'=>0.5, 'text/*'=>0.3)
    my %accepts = map {($_ =~ m/(.*?)\;q=(.*)/) ? ($1, $2) : ($_, 1)} split(/[,\s]+/, $ENV{'HTTP_ACCEPT'});

    my $presenter = undef;
    if (($accepts{'text/xml'} >= $accepts{'*/*'} && $accepts{'text/xml'} >= $accepts{'text/html'}) || $self->{FORCE_XML}) {
	$presenter = new XMLPresenter($self, $self->{WRITE});
    } else {
	$presenter = new HTMLPresenter($self, $self->{WRITE});
    }

    $presenter->printHead;

    print $results;

    $presenter->printFoot;
}

sub endMessage {
    my ($self, $message) = @_;
    print $message;
}

sub arrayHasDiffs {
    my ($a, $b) = @_;
    return 1 if ($#$a != $#$b);
    my (%a, %b);
    map {$a{$_} = undef} @$a;
    map {return 1 if (!exists $a{$_})} @$b;
    return 0;
}

# CGI inputs:

sub importCGIParms {
    my ($self) = @_;

    # read the inputs from the query
    my @params = $self->{READ}->param;
    my $changeDirectory = undef;
    foreach my $param (@params) {
	# entry into the rdf script through a specified resource and optional wildcards
	($param =~ m/(w3c_LOTP)/) && 
	    ($self->{LOTP_POST} = $self->{READ}->param('w3c_LOTP'));
	($param =~ m/(w3c_forceXML)/) && 
	    ($self->{FORCE_XML} = $self->{READ}->param('w3c_forceXML'));
    }

    # assign defaults

    if ($self->{SUBMIT} == $LOTP::SUBMIT_AnnotateShow) {
	$self->{ANNOTATE} = 1;
    } elsif ($self->{SUBMIT} == $LOTP::SUBMIT_AnnotateHide) {
	$self->{ANNOTATE} = 0;
    }

    return 1;
}

sub unknownException {
    my ($self, $exception) = @_;
    $exception = $exception->toString if ($exception->isa('W3C::Util::Exception'));
    my $redirResponse = <<EOF
Status: 200 OK
Connection: close
Content-Type: text/html

<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">
<HTML><HEAD>
<TITLE>LOTP: Unknown Exception</TITLE>
</HEAD><BODY>
<H1>LOTP: Unknown Exception</H1>
LOTP blew its mind.<br>
<PRE>$exception</PRE>
<P></BODY></HTML>
EOF
    ;
    return $redirResponse;
}

sub requireAuth {
    my ($self, $realm, $needed) = @_;
    my $resource = join(' ', @{$self->{RESOURCE_LIST}});
    my $authResponse = <<EOF
Status: 401 Authorization Required
WWW-Authenticate: Basic realm=\"$realm\"
Connection: close
Content-Type: text/html

<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">
<HTML><HEAD>
<TITLE>401 Authorization Required</TITLE>
</HEAD><BODY>
<H1>Authorization Required</H1>
You need $needed access to $resource to perform the requested opperation.<P>
EOF
    ;
    return $authResponse;
}

sub noSuchLibrary {
    my ($self, $libraryException) = @_;
    my $method = $libraryException->getFile;
    my $string = $libraryException->toString;
    my $response = <<EOF
Status: 404 SCREW YOU HIPPI
Connection: close
Content-Type: text/html

<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">
<HTML><HEAD>
<TITLE>404 SCREW YOU HIPPI</TITLE>
</HEAD><BODY>
<H1>$method not found</H1>
$string
EOF
    ;
    return $response;
}

sub confFileMissing {
    my ($self, $filename) = @_;
    my $confResponse = <<EOF
Status: 200 OK
Connection: close
Content-Type: text/html

<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">
<HTML><HEAD>
<TITLE>LOTP: Configuration File Missing</TITLE>
</HEAD><BODY>
<H1>LOTP: Configuration File Missing</H1>
LOTP needs the file \"$filename\" to opperate.<P></BODY></HTML>
EOF
    ;
    return $confResponse;
}

#####
# Front end to W3C::Util::ShowSource module

sub showMySources {
    my ($query) = @_;
    use W3C::Util::ShowSource;
    my @sources = ('LOTP.pl', 'W3C::Database::DBIInterface.pm', 
		   'W3C::Util::Properties.pm', 'W3C::Util::ShowSource.pm', 'W3C::Rdf::RdfParser.pm', 
		   'W3C::SAX::XmlParser.pm', 'W3C::SAX::InputSource.pm', 'W3C::SAX::AttributeListImpl.pm', 
		   'W3C::SAX::HandlerBase.pm', 'W3C::SAX::SAXException.pm', 'W3C::SAX::SAXParseException.pm', 
		   'W3C::SAX::HandlerBase.pm', 'W3C::SAX::XmlElement.pm');
    my %paths = ('LOTP.pl' => 'LOTP', 
		 'W3C::Database::DBIInterface.pm' => 'DBIInterface',
		 'W3C::Util::Properties.pm' => 'Properties', 
		 'W3C::Util::ShowSource.pm' => 'ShowSource', 
		 'W3C::Rdf::RdfParser.pm' => 'RdfParser', 
		 'W3C::SAX::XmlParser.pm' => 'XmlParser', 
		 'W3C::SAX::InputSource.pm' => 'InputSource', 
		 'W3C::SAX::AttributeListImpl.pm' => 'AttributeListImpl', 
		 'W3C::SAX::HandlerBase.pm' => 'HandlerBase', 
		 'W3C::SAX::SAXException.pm' => 'SAXException', 
		 'W3C::SAX::SAXParseException.pm' => 'SAXParseException', 
		 'W3C::SAX::HandlerBase.pm' => 'HandlerBase', 
		 'W3C::SAX::XmlElement.pm' => 'XmlElement');

    my ($useColor, $funcLinks, $funcList) = ($query->param('w3c_useColor'), 
					     $query->param('w3c_funcLinks'), 
					     $query->param('w3c_funcList'));
    #####
    # Start the page
    print $query->header(-expires=>'+4h');
    print $query->start_html(-title=>'Rdf Editor Sources', -BGCOLOR=>"#FFFFFF", -TEXT=>"#000000", -LINK=>"#0000ee", -VLINK=>"#551a8b");
    print <<EOF;
<h1>Rdf Editor Sources</h1>
    <p>
    <a href='#LOTP'>LOTP</a> presents the the current 
    ACLs for a resource and creates forms to manipulate them. 
    <a href='#LOTP'>LOTP</a> then handles 
    the output from the forms. Both are layered on top of 
    <a href='#DBIInterface'>W3C::Database::DBIInterface.pm</a>.
    <p>
    RDF parsing facilities are handled by a stack of parser:
    <pre>
    <a href='#RdfParser'>W3C::Rdf::RdfParser</a>
       |
    <a href='#XmlParser'>W3C::SAX::XmlParser</a>
    </pre> The <a href='#XmlParser'>W3C::SAX::XmlParser</a> is an
    implementation of a SAX interface ported to perl. It uses:
    <ul>
	<li><a href='#InputSource'>W3C::SAX::InputSource</a>
	<li><a href='#AttributeListImpl'>W3C::SAX::AttributeListImpl</a>
	<li><a href='#HandlerBase'>W3C::SAX::HandlerBase</a>
	<li><a href='#SAXException'>W3C::SAX::SAXException</a>
	<li><a href='#SAXParseException.'>W3C::SAX::SAXParseException.</a>
	<li><a href='#HandlerBase'>W3C::SAX::HandlerBase</a>
	<li><a href='#XmlElement'>W3C::SAX::XmlElement</a>
    </ul>
    <p>
    &lt;brought to you by <a href='#ShowSource'>W3C::Util::ShowSource.pm</a>&gt;.
EOF
    ;

    #####
    # Print source
    my $showSource = W3C::Util::ShowSource->new(\@sources, \%paths, $query);
    $showSource->present($useColor, $funcLinks, $funcList);
    print $query->end_html;
}

#####
# handy page to prompt for resource to edit

sub resourcePrompt {
    my ($query) = @_;

    #####
    # Start the page
    print $query->header;
    print $query->start_html(-title=>'W3C Rdf Editor', -BGCOLOR=>"#ffffff", -TEXT=>"#000000", -LINK=>"#0000ee"), "\n";

    print $query->end_html;
}

package Presenter;

sub new {
    my ($proto, $engine, $renderer) = @_;
    my $class = ref($proto) || $proto;
    my $self = {ENGINE => $engine, RENDERER => $renderer};
    bless ($self, $class);
    return $self;
}

package HTMLPresenter;
sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new(@_);
    bless ($self, $class);
    return $self;
}

sub printHead {
    my ($self) = @_;
	print $self->{RENDERER}->header;
	print "<a href=\"http://www.w3.org/\"><img border=\"0\" src=\"http://www.w3.org/Icons/WWW/w3c_home\" ALT=\"W3C Home\"></a>\n";
	my $dummy = <<EODUMMY;
  <p>
    <a href=\"http://www.w3.org/\"><img
       src=\"http://www.w3.org/Icons/WWW/w3c_home\" height=48 border=0
       alt=\"W3C\"></a>
  </p>
  <h1>W3C Rdf Editor</h1>
  <p>
    Welcome to the W3C rdf Editor!
  </p>
  <p>
    This tool manipulates access control lists for a given resource.
  </p>
  <hr>
EODUMMY
    ;
	my $title = 'Query RDF ';
	$title .= 'for: '.$self->{LOTP_POST} if ($self->{LOTP_POST});
	print $self->{RENDERER}->start_html(-title=>$title, -BGCOLOR=>"#FFFFFF", -TEXT=>"#000000", -LINK=>"#0000ee");
	#  -VLINK=>"#551a8b"
	print $self->{RENDERER}->h1($title), "\n";
}

sub printNodes {
    my ($self, $nodes, $selects, $messages, $proofs) = @_;
    print join ("<br>\n", @$messages);
    my $nodeCount = scalar(@$nodes);
    print @$nodes > 1 ? "<br>$nodeCount results:\n" : ' -> ';
    print "<table border=2><tr><td></td><th>".join ('</th><th>', @$selects)."</th></tr>\n";
    for (my $i = 0; $i < @$nodes; $i++) {
	my $row = $nodes->[$i];
	print "<tr><th>$i</th><td>".join ('</td><td>', map {$_->show} @$row)."</td></tr>\n";
	for (my $j = 0; $j < @{$proofs->[$i]}; $j++) {
	    my $statement = $proofs->[$i]->[$j];
	    print "<tr><th></th><td colspan=".@$row." bgcolor=\"greeb\">".$statement->show(undef, undef, {-noReifications => 1})."</td></tr>\n";
	}
    }
    print "</table>\n";
}

sub printFoot {
    my ($self) = @_;
    print $self->{RENDERER}->startform('POST', $self->{RENDERER}->url, 'application/x-www-form-urlencoded');
    my $selfUri = $query->self_url;
    my $displayQuery = $self->{ENGINE}->{LOTP_POST};
    if ($displayQuery) {
#	$displayQuery =~ s/\n//g;
#	$displayQuery = $self->{RENDERER}->unescape($displayQuery);
	$displayQuery = $self->{RENDERER}->escapeHTML($displayQuery);
    } else {
	$displayQuery = "(ask '((http://www.w3.org/schema/certHTMLv1/access ?x &quot;acc1&quot;) (?y ?x &quot;http://user1&quot;)) :collect '(?x ?y))";
#	$displayQuery = $self->{RENDERER}->escapeHTML($displayQuery);
    }
    print <<EOF;
  <hr><p>
    Enter a LOTP query: here are some examples:<br>
    LOTP query: <code>(ask '((predicate1 subject1 object1) [(predicaten subjectn objectn)]*) :collect '(v1 [vn]*))</code><br>
    perl query: <code></code><br>
    Base URI: <code>http://www.w3.org/Library/Overview.html</code><br>
  </p>
  <form method=GET action=\"$selfUri\">
<!--    Rdf query: <input name=\"w3c_LOTP\" size=80 value="$displayQuery"><br> -->
    Rdf query: <textarea name=\"w3c_LOTP\" rows=\"13\" cols=\"100\">$displayQuery</textarea><br>
    <input type="checkbox" name="w3c_forceXML" value="*">force text mode 
    <input type=\"submit\" value=\"Submit LOTP query\">
    <!-- input type=\"submit\" value=\"Submit Extended LOTP query\" -->
    <!-- input type=\"submit\" value=\"Submit perl query\" -->
    <input type=\"reset\" value=\"Reset this form\">
  </form>
  <hr>
  <h2><a name=\"otherInfo\">Other sources of information</a></h2>
  <ul>
    <li>the <a href="rdfInput.pl">input</a> page</li>
    <li>
	<form method=GET action=\"$selfUri\">
	Source code browser:<br>
	<INPUT TYPE="checkbox" NAME="w3c_useColor" VALUE="*"> <font color=\"red\">i</font><font color=\"orange\">n</font> <font color=\"yellow\">c</font><font color=\"green\">o</font><font color=\"blue\">l</font><font color=\"purple\">o</font><font color=\"red\">r</font> (about 2.5 times as large)<br>
	<INPUT TYPE="checkbox" NAME="w3c_funcLinks" VALUE="*"> list of functions with links to their declarations<br>
	<INPUT TYPE="checkbox" NAME="w3c_funcList" VALUE="*"> links function from function invocations (a cool tool, but it takes about 10 minutes to generate)<br>
	<input name=\"w3c_showSource\" type=\"submit\" value=\"see the source code\">
	</form>
	</li>
  </ul>
  <h2><a name=\"toDo\">To Do</a></h2>
  <ul>
    <li>A comprehensive user manual.
    <li>A user manager.
  </ul>
  <hr>
EOF
    ; # 
    print $self->{RENDERER}->endform."\n";

    # done - clean up
    print $self->{RENDERER}->end_html."\n";
}

package XMLPresenter;
sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new(@_);
    bless ($self, $class);
    return $self;
}

sub printHead {
    my ($self) = @_;
    print $self->{RENDERER}->header({-type=>'text/plain'});
}

sub printNodes {
    my ($self, $nodes, $selects, $messages, $proofs) = @_;
    print join ("\n", map {'('.join (' ', map {$_->show} @$_).')'} @$nodes)."\n";
}

sub printFoot {
    my ($self) = @_;
    print "\n";
}

package LOTP;

sub read {
    my ($file) = @_;
    open(FILE, $file) || die;
    $ENV{PATH_INFO} = <FILE>;
    $ENV{POST_VARS} = join ('', <FILE>);
}
Webmaster