Fixing a gazillion syntax, logic and XML errors and adding some debug code. It compiles!

This commit is contained in:
ian%hixie.ch 2001-06-03 14:49:41 +00:00
Родитель 7daa595cd4
Коммит 5dd8af9c83
14 изменённых файлов: 89 добавлений и 75 удалений

Просмотреть файл

@ -124,7 +124,7 @@ sub getObject {
sub getServiceList {
my $self = shift;
my($name) = @_;
my @services;
my @services = ();
foreach my $service (@{$self->services}) {
if ($service->provides($name)) {
# Create the service. If it is already created, this will
@ -137,6 +137,8 @@ sub getServiceList {
push(@services, $service);
}
}
local $" = '\', \'';
$self->dump(10, "Created a service list for '$name' containing: '@services'");
return @services;
}
@ -145,12 +147,13 @@ sub getObjectList {
# constructor call
my $self = shift;
my($name) = @_;
my @services;
my @services = ();
foreach my $service (@{$self->objects}) {
if ($service->objectProvides($name)) {
push(@services, $service);
}
}
$self->dump(10, "Created an object list for '$name' containing: '@services'");
return @services;
}
@ -213,15 +216,16 @@ sub dispatchMethod {
my $self = shift;
my($service, $prefix, $method, @arguments) = @_;
# the \u makes the first letter of the $command uppercase
$self->dump(10, "dispatching method '$prefix\u$method'...");
return ($self->getSelectingServiceList($service)->dispatch($self, "$prefix\u$method", @arguments) or
$self->getSelectingObjectList($service)->dispatch($self, "$prefix\u$method", @arguments));
}
sub DESTROY {
my $self = shift;
$self->dump(9, 'At controller shutdown, there were ' .
$self->dump(10, 'At controller shutdown, there were ' .
# I assume there will always be > 1 and so haven't bothered to special case the singular grammar
scalar($self->services) .
scalar(@{$self->services}) .
' services registered, of which ' .
scalar(keys(%{$self->servicesHash})) .
' had been placed in the services hash.')

Просмотреть файл

@ -84,6 +84,9 @@ sub getDefaultString {
<embed string="debug.dumpVars"/>
</set>
</set>
<else>
<text value=" (prefix)"/><br/>
</else>
</if>
</with>
<without variable="prefix">

Просмотреть файл

@ -65,7 +65,7 @@ sub getUserByContactDetails {
my($app, $contactName, $address) = @_;
# decent databases can do this in one go. Those that can't can do
# it in a generic two-step process:
return $self->getUserByID($app, $self->getUserIDByContactDetails($app, $username));
return $self->getUserByID($app, $self->getUserIDByContactDetails($app, $contactName, $address));
# XXX no error checking! if getUserID... return undef, return ()!
# return the same as getUserByID()
}

Просмотреть файл

@ -48,7 +48,7 @@ sub getUserIDByUsername {
return $self->database($app)->execute('SELECT userData.userID
FROM userData, userDataTypes
WHERE userData.fieldID = userDataTypes.fieldID
AND userDataTypes.category = 'contact'
AND userDataTypes.category = \'contact\'
AND CONCAT(userDataTypes.data, userData.data) = ?', $username)->row->[0];
# XXX no error checking!
# return userID or undef
@ -60,7 +60,7 @@ sub getUserIDByContactDetails {
return $self->database($app)->execute('SELECT userData.userID
FROM userData, userDataTypes
WHERE userData.fieldID = userDataTypes.fieldID
AND userDataTypes.category = 'contact'
AND userDataTypes.category = \'contact\'
AND userDataTypes.name = ?
AND userData.data = ?', $contactName, $address)->row->[0];
# XXX no error checking!
@ -231,19 +231,12 @@ sub setGroup {
# This probably doesn't need to be too efficient...
$self->assert(defined($groupID) or defined($groupName), 1,
'Invalid arguments to DataSource::User::setGroup: \'groupID\' and \'groupName\' both undefined');
if (defined($fieldID)) {
} else {
return $self->database($app)->execute('INSERT INTO userDataTypes SET category=?, name=?, type=?, data=?, mode=?',
$category, $name, $type, $data, $mode)->ID;
}
if (not defined($groupID)) {
# add a new record
$groupID = $self->database($app)->execute('INSERT INTO groups SET name=?', $name)->ID;
$groupID = $self->database($app)->execute('INSERT INTO groups SET name=?', $groupName)->ID;
} elsif (defined($groupName)) {
# replace the existing record
$self->database($app)->execute('UPDATE groups SET name=? WHERE groupID = ?', $name, $groupID);
$self->database($app)->execute('UPDATE groups SET name=? WHERE groupID = ?', $groupName, $groupID);
}
# now update the rights mapping table
$self->database($app)->execute('DELETE FROM groupRightsMapping WHERE groupID = ?', $groupID);

Просмотреть файл

@ -63,7 +63,7 @@ sub getArgument {
sub getArguments {
my $self = shift;
my $result = {};
foreach my $argument (keys %$self) {
foreach my $argument (keys(%$self)) {
if ($argument =~ /^argument (.*)$/o) {
$result->{$1} = \@{$self->{$argument}};
}

Просмотреть файл

@ -86,7 +86,7 @@ sub createArgument {
if ($self->getArgument('batch')) {
$self->SUPER::createArgument($argument);
} else {
$self->dump(5, "going to request $argument from user!");
$self->warn(5, "going to request '$argument' from user!");
$self->app->output->request($argument);
# get input from user :-)
my $term = Term::ReadLine->new($self->app->name);

Просмотреть файл

@ -134,7 +134,9 @@ sub methodMissing {
sub fillData {
my $self = shift;
my($data) = @_;
$data->{'app'} = $app->hash;
$data->{'session'} = $self->session->hash;
$data->{'input'} = $app->input->hash;
$data->{'app'} = $self->app->hash;
if (defined($self->actualSession)) {
$data->{'session'} = $self->actualSession->hash;
}
$data->{'input'} = $self->app->input->hash;
}

Просмотреть файл

@ -41,7 +41,7 @@ $app->run();
# setup everything (automatically called by the constructor, above)
sub init {
my $self = shift;
$self->dump(5, '*** Started PLIF Application ***');
$self->dump(5, '', '', '*** Started PLIF Application ***', '********************************');
$self->SUPER::init(@_);
$self->initInput();
}
@ -55,7 +55,7 @@ sub run {
$self->objects([]);
if ($self->verifyInput()) {
if ($self->input->command) {
$self->command($command);
$self->command($self->input->command);
$self->dispatch($self->input->command);
} else {
$self->command('');

Просмотреть файл

@ -46,10 +46,13 @@ sub dispatch {
my $self = shift;
my($app, $name, @arguments) = @_;
my $method = $self->can($name);
local $" = '\', \'';
if ($method) {
$self->dump(10, "Attempting to dispatch method: $self->$name('$app', '@arguments')");
&$method($self, $app, @arguments);
return 1;
} else {
return undef;
$self->dump(10, "There is no method '$name' in object '$self', skipping...");
return;
}
}

Просмотреть файл

@ -93,32 +93,38 @@ sub expand {
my $source = $self->evaluateExpression($attributes->{'source'}, $scope);
if ($order or $source) {
my @items = $self->sort($order, $self->keys($value, $source));
push(@index, $index);
push(@stack, $stack);
push(@scope, $superscope);
# now we push all but one of the items onto
# the stack -- so first take that item...
my $firstItem = pop(@items); # (@items is sorted backwards)
# and then take a copy of the scope if we didn't already
if ($scope == $superscope) {
$scope = {%$scope};
if (@items) {
push(@index, $index);
push(@stack, $stack);
push(@scope, $superscope);
# now we push all but one of the items onto
# the stack -- so first take that item...
my $firstItem = pop(@items); # (@items is sorted backwards)
# and then take a copy of the scope if we didn't already
$superscope->{'coses: last condition'} = 1;
if ($scope == $superscope) {
$scope = {%$scope};
}
$scope->{'coses: last condition'} = 0;
foreach my $item (@items) {
push(@index, 1);
push(@stack, $contents);
$scope->{$variable} = $item;
push(@scope, $scope);
# make sure we create a new scope for the
# next item -- otherwise each part of the
# loop would just have a reference to the
# same shared hash, and so they would all
# have the same value!
$scope = {%$scope};
}
# and finally create the first scope (not pushed on the stack, it is the next, live one)
$index = 1; # skip past attributes
$stack = $contents;
$scope->{$variable} = $firstItem;
} else {
$superscope->{'coses: last condition'} = 0;
}
foreach my $item (@items) {
push(@index, 1);
push(@stack, $contents);
$scope->{$variable} = $item;
push(@scope, $scope);
# make sure we create a new scope for the
# next item -- otherwise each part of the
# loop would just have a reference to the
# same shared hash, and so they would all
# have the same value!
$scope = {%$scope};
}
# and finally create the first scope (not pushed on the stack, it is the next, live one)
$index = 1; # skip past attributes
$stack = $contents;
$scope->{$variable} = $firstItem;
next node;
} else {
if ($scope == $superscope) {
@ -199,15 +205,16 @@ sub getString {
sub evaluateVariable {
my $self = shift;
my($variable, $scope) = @_;
my @parts = split(/\./o, $variable); # split variable at dots ('.')
my @parts = split(/\./o, $variable, -1); # split variable at dots ('.') (the negative number prevents null trailing fields from being stripped)
# drill down through scope
foreach my $part (@parts) {
if (ref($scope) eq 'HASH') {
$scope = $scope->{$part};
} elsif (ref($scope) eq 'ARRAY') {
$self->assert(scalar($part =~ /^\d+$/o), 1, "Tried to drill into an array using a non-numeric key ('$part')");
$scope = $scope->[$part];
} else {
$self->error(1, "Could not resolve '$variable' at '$part'");
$self->error(1, "Could not resolve '$variable' (the part giving me trouble was '$part')");
}
}
if (defined($scope)) {
@ -361,7 +368,7 @@ sub sort {
my $self = shift;
my($order, @list) = @_;
# sort the list (in reverse order!)
if (defined($order)) {
if (defined($order) and scalar(@list)) {
if ($order eq 'lexical') {
return sort { $b cmp $a } @list;
} elsif ($order eq 'reverse lexical') {

Просмотреть файл

@ -45,7 +45,7 @@ sub provides {
# this is typically used by input devices
sub outputRequest {
my $self = shift;
my($app, $argument) = @_;
my($app, $output, $argument) = @_;
$output->output(undef, 'request', {
'command' => $app->command,
'argument' => $argument,
@ -55,8 +55,8 @@ sub outputRequest {
# dispatcher.output.generic
sub outputReportFatalError {
my $self = shift;
my($error) = @_;
$self->output(undef, 'error', {
my($app, $output, $error) = @_;
$output->output(undef, 'error', {
'error' => $error,
});
}
@ -67,13 +67,15 @@ sub getDefaultString {
my($app, $protocol, $string) = @_;
if ($protocol eq 'stdout') {
if ($string eq 'request') {
return '<text>'<text variable="(data.argument)"/>'? </text>';
return '<text>\'<text value="(data.argument)"/>\'? </text>';
} elsif ($string eq 'error') {
return '<text>Error:<br/><text variable="(data.error)"/></br/></text>';
$self->dump(9, 'Looks like an error occured, because the string \'error\' is being requested');
return '<text>Error:<br/><text value="(data.error)"/><br/></text>';
}
} elsif ($protocol eq 'http') {
if ($string eq 'error') {
return '<text>HTTP/1.1 500 Internal Error<br/>Content-Type: text/plain<br/><br/>Error:<br/><text variable="(data.error)"/></text>';
$self->dump(9, 'Looks like an error occured, because the string \'error\' is being requested');
return '<text>HTTP/1.1 500 Internal Error<br/>Content-Type: text/plain<br/><br/>Error:<br/><text value="(data.error)"/></text>';
}
}
return; # nope, sorry

Просмотреть файл

@ -50,10 +50,10 @@ sub verifyInput {
my $self = shift;
my($app) = @_;
# let's see if there are any protocol-specific user authenticators
my @result = $self->getSelectingServiceList('input.verify.user.'.$app->input->protocol)->authenticateUser($app);
my @result = $app->getSelectingServiceList('input.verify.user.'.$app->input->defaultOutputProtocol)->authenticateUser($app);
if (not @result) {
# ok, let's try the generic authenticators...
@result = $self->getSelectingServiceList('input.verify.user.generic')->authenticateUser($app);
@result = $app->getSelectingServiceList('input.verify.user.generic')->authenticateUser($app);
}
# now let's see what that gave us
if (@result) {
@ -73,7 +73,7 @@ sub authenticateUser {
my $self = shift;
my($app) = @_;
if (defined($app->input->username)) {
return $app->getService('user.factory')->getUserByCredentials($app->input->username, $app->input->password);
return $app->getService('user.factory')->getUserByCredentials($app, $app->input->username, $app->input->password);
} else {
return; # return nothing (not undef)
}
@ -92,7 +92,7 @@ sub cmdSendPassword {
my($app) = @_;
my $protocol = $app->input->getAttribute('protocol');
my $address = $app->input->getAttribute('address');
if (defined($method) and defined($address)) {
if (defined($protocol) and defined($address)) {
my $user = $app->getService('user.factory')->getUserByContactDetails($app, $protocol, $address);
my $password;
if (defined($user)) {
@ -110,7 +110,7 @@ sub cmdSendPassword {
sub hasRight {
my $self = shift;
my($app, $right) = @_;
my $user = $self->getObject('user');
my $user = $app->getObject('user');
if (defined($user)) {
if ($user->hasRight($right)) {
return $user;
@ -183,15 +183,15 @@ sub getDefaultString {
if ($string eq 'loginAccessDenied') {
return '<text>Access Denied<br/></text>';
} elsif ($string eq 'loginFailed') {
return '<text><if lvalue="(data.tried)" condition="=" rvalue="1">Wrong username or password.</if><else>You must give your username or password.</else><br/><!-- XXX offer to create an account or send the password --></br/></text>';
return '<text><if lvalue="(data.tried)" condition="=" rvalue="1">Wrong username or password.</if><else>You must give your username or password.</else><br/><!-- XXX offer to create an account or send the password --><br/></text>';
} elsif ($string eq 'loginDetailsSent') {
return '<text>Login details were sent. (Protocol: <text variable="(data.protocol)"/>; Address: <text variable="(data.address)"/>)</br/></text>';
return '<text>Login details were sent. (Protocol: <text variable="(data.protocol)"/>; Address: <text variable="(data.address)"/>)<br/></text>';
}
} elsif ($protocol eq 'http') {
if ($string eq 'loginAccessDenied') {
return '<text>HTTP/1.1 401 Access Denied<br/>Content-Type: text/plain<br/><br/>Access Denied</text>';
} elsif ($string eq 'loginFailed') {
return '<text>HTTP/1.1 401 Login Required<br/>WWW-Authenticate: Basic realm="<text variable="(data.app.name)"/>"<br/>Content-Type: text/plain<br/><br/><if lvalue="(data.tried)" condition="=" rvalue="1">Wrong username or password.</if><else>You must give your username or password.</else></br/><!-- XXX offer to create an account or send the password --></text>';
return '<text>HTTP/1.1 401 Login Required<br/>WWW-Authenticate: Basic realm="<text variable="(data.app.name)"/>"<br/>Content-Type: text/plain<br/><br/><if lvalue="(data.tried)" condition="=" rvalue="1">Wrong username or password.</if><else>You must give your username or password.</else><br/><!-- XXX offer to create an account or send the password --></text>';
} elsif ($string eq 'loginDetailsSent') {
return '<text>HTTP/1.1 200 OK<br/>Content-Type: text/plain<br/><br/>Login details were sent.<br/>Protocol: <text variable="(data.protocol)"/><br/>Address: <text variable="(data.address)"/>)</text>';
}
@ -215,7 +215,7 @@ sub createUser {
my($app, $protocol, $address) = @_;
my($password, $crypt) = $app->getService('service.passwords')->newPassword();
my $user = $app->getService('user.factory')->getNewUser($app, $crypt);
$user->getField('contact', $protocol)->data = $address;
$user->getField('contact', $protocol)->data($address);
return ($user, $password);
}

Просмотреть файл

@ -84,7 +84,7 @@ sub getUserByContactDetails {
sub getUserByID {
my $self = shift;
my($app, $id) = @_;
my($app, $userID) = @_;
my(@data) = $app->getService('dataSource.user')->getUserByUserID($app, $userID);
if (@data) {
return $self->objectCreate($app, @data);
@ -121,7 +121,7 @@ sub objectInit {
$self->fieldsByID({});
# don't forget to update the 'hash' function if you add more fields
my $fieldFactory = $app->getService('user.fieldFactory');
foreach my $fieldID (keys($fields)) {
foreach my $fieldID (keys(%$fields)) {
$self->insertField($fieldFactory->createFieldByID($app, $self, $fieldID, $fields->{$fieldID}));
}
$self->groups({%$groups}); # hash of groupID => groupName
@ -146,13 +146,13 @@ sub hasField {
}
# if you want to add a field, you do:
# $user->getField('category', 'name')->data = $myData;
# $user->getField('category', 'name')->data($myData);
sub getField {
my $self = shift;
my($category, $name) = @_;
my $field = $self->hasField($category, $name);
if (not defined($field)) {
$field = $self->insertField($fieldFactory->createFieldByName($app, $self, $fieldCategory, $fieldName));
$field = $self->insertField($self->app->getService('user.fieldFactory')->createFieldByName($self->app, $self, $category, $name));
}
return $field;
}
@ -199,7 +199,7 @@ sub doAddressChange {
my $field = $self->fieldsByID->{$self->newFieldID};
$self->assert(defined($field), 1, 'Database integrity error: newFieldID doesn\'t map to a field!');
if (defined($password) and ($self->app->getService('service.passwords')->checkPassword($self->newFieldPassword, $password))) {
$field->data = $self->newFieldValue;
$field->data($self->newFieldValue);
} elsif (not defined($field->data)) {
$field->remove();
}
@ -228,7 +228,7 @@ sub hash {
$result->{'adminMessage'} = $self->adminMessage,
$result->{'groups'} = $self->groups,
$result->{'rights'} = keys(%{$self->rights});
$result->{'fields'} = {},
$result->{'fields'} = {};
foreach my $field (values(%{$self->fieldsByID})) {
# XXX should we also pass the field metadata on? (e.g. typeData)
$result->{'fields'}->{$field->fieldID} = $field->data;

Просмотреть файл

@ -135,8 +135,8 @@ sub DESTROY {
sub write {
my $self = shift;
if ($self->{'_DELETE'}) {
$self->app->getService('dataSource.user')->removeUserField($elf->app, $self->userID, $self->fieldID);
$self->app->getService('dataSource.user')->removeUserField($self->app, $self->userID, $self->fieldID);
} else {
$self->app->getService('dataSource.user')->setUserField($elf->app, $self->userID, $self->fieldID, $self->data);
$self->app->getService('dataSource.user')->setUserField($self->app, $self->userID, $self->fieldID, $self->data);
}
}