mirror of
https://github.com/mozilla/gecko-dev.git
synced 2024-11-29 07:42:04 +00:00
Improve the Exception class so it can work out what 'eval' numbers map to; remove the 'properties' stuff since it was taking a good 4% of the overall time of PLIF applications. THIS WILL CAUSE HUGE PROBLEMS WITH PLIF CONSUMERS. I REPEAT, THIS **WILL** BREAK YOUR CODE. DO NOT UPDATE TO THIS CODE IF YOU DON'T WANT TO SPEND A LOT OF TIME UPDATING YOUR CODE\!\!\!
This commit is contained in:
ian%hixie.ch
parent
9359dc9771
commit
ceef63652c
@ -40,7 +40,7 @@ my %MODULES = ('PLIF' => 1);
|
||||
# Levels are assumed to be something along the following:
|
||||
# 0 = debugging remarks for the section currently under test
|
||||
# 1 =
|
||||
# 2 =
|
||||
# 2 = perl warnings
|
||||
# 3 =
|
||||
# 4 = important warnings (e.g. unexpected but possibly legitimate lack of data)
|
||||
# 5 = important events (e.g. application started)
|
||||
@ -124,9 +124,9 @@ sub load {
|
||||
}
|
||||
$MODULES{$package} = 1;
|
||||
local $/ = undef;
|
||||
my $data = "package $package;\nuse strict;\n" . eval "<$package\::DATA>";
|
||||
my $data = "package $package;use strict;" . eval "<$package\::DATA>";
|
||||
#print STDERR "================================================================================\n$data\n================================================================================\n";
|
||||
eval $data;
|
||||
evalString $data, "${package}::DATA block";
|
||||
if ($@) {
|
||||
$self->error(1, "Error while loading '$package': $@");
|
||||
}
|
||||
@ -138,18 +138,9 @@ sub AUTOLOAD {
|
||||
my $name = $AUTOLOAD;
|
||||
syntaxError "Use of inherited AUTOLOAD for non-method $name is deprecated" if not defined($self);
|
||||
$name =~ s/^.*://o; # strip fully-qualified portion
|
||||
if ($self->propertyImpliedAccessAllowed($name)) {
|
||||
if (scalar(@_) == 1) {
|
||||
return $self->propertySet($name, @_);
|
||||
} elsif (scalar(@_) == 0) {
|
||||
if ($self->propertyExists($name)) {
|
||||
return $self->propertyGet($name);
|
||||
} else {
|
||||
return $self->propertyGetUndefined($name);
|
||||
}
|
||||
}
|
||||
}
|
||||
$self->methodMissing($name, @_);
|
||||
my $method = $self->can('implyMethod'); # get a function pointer
|
||||
@_ = ($self, $name, @_); # set the arguments
|
||||
goto &$method; # invoke the method using deep magic
|
||||
}
|
||||
|
||||
sub propertySet {
|
||||
@ -159,22 +150,6 @@ sub propertySet {
|
||||
return $self->{$name} = $value;
|
||||
}
|
||||
|
||||
sub propertyExists {
|
||||
# this is not a class method
|
||||
my $self = shift;
|
||||
my($name) = @_;
|
||||
$self->assert($name, 0, 'propertyExists() cannot be called without arguments');
|
||||
return exists($self->{$name});
|
||||
}
|
||||
|
||||
sub propertyImpliedAccessAllowed {
|
||||
# this is not (supposed to be) a class method
|
||||
# my $self = shift;
|
||||
# my($name) = @_;
|
||||
# $self->assert($name, 0, 'propertyImpliedAccessAllowed() cannot be called without arguments');
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub propertyGet {
|
||||
# this is not a class method
|
||||
my $self = shift;
|
||||
@ -182,11 +157,7 @@ sub propertyGet {
|
||||
return $self->{$name};
|
||||
}
|
||||
|
||||
sub propertyGetUndefined {
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub methodMissing {
|
||||
sub implyMethod {
|
||||
my $self = shift;
|
||||
my($method) = @_;
|
||||
syntaxError "Tried to access non-existent method '$method' in object '$self'";
|
||||
@ -225,9 +196,9 @@ sub error {
|
||||
# the next three lines are a highly magical incantation to remove
|
||||
# this call from the stack so that the stack trace looks like the
|
||||
# previous function raised the exception itself
|
||||
my $raise = PLIF::Exception->can('raise');
|
||||
@_ = ('PLIF::Exception', 'message', join("\n", @data));
|
||||
goto &$raise;
|
||||
my $raise = PLIF::Exception->can('raise'); # get a function pointer
|
||||
@_ = ('PLIF::Exception', 'message', join("\n", @data)); # set the arguments
|
||||
goto &$raise; # and invoke the call using deep call stack magic
|
||||
}
|
||||
|
||||
# this should not be called with the @data containing a trailing dot
|
||||
|
||||
@ -43,9 +43,9 @@ sub init {
|
||||
my $self = shift;
|
||||
$self->SUPER::init(@_);
|
||||
# prepare the services array for the registration system
|
||||
$self->services([]);
|
||||
$self->objects([]);
|
||||
$self->servicesHash({});
|
||||
$self->{services} = [];
|
||||
$self->{objects} = [];
|
||||
$self->{servicesHash} = {};
|
||||
# perform the registration
|
||||
$self->registerServices();
|
||||
}
|
||||
@ -56,7 +56,7 @@ sub init {
|
||||
sub register {
|
||||
my $self = shift;
|
||||
foreach my $service (@_) {
|
||||
push(@{$self->services}, $service);
|
||||
push(@{$self->{services}}, $service);
|
||||
my $file = $service;
|
||||
# XXX THIS IS PLATFORM SPECIFIC CODE XXX
|
||||
if ($^O eq 'linux') {
|
||||
@ -87,7 +87,7 @@ sub addObject {
|
||||
my $self = shift;
|
||||
foreach my $object (@_) {
|
||||
$self->assert(defined($object), 1, 'Internal error: Tried to add undefined object to object list.');
|
||||
push(@{$self->objects}, $object);
|
||||
push(@{$self->{objects}}, $object);
|
||||
}
|
||||
}
|
||||
|
||||
@ -95,15 +95,15 @@ sub removeObject {
|
||||
my $self = shift;
|
||||
# XXX for 5.6.1, use this:
|
||||
# foreach my $object (@_) {
|
||||
# foreach my $index (0..$#{$self->objects}) {
|
||||
# if ($self->objects->[$index] == $object) {
|
||||
# delete($self->objects->[$index]);
|
||||
# foreach my $index (0..$#{$self->{objects}}) {
|
||||
# if ($self->{objects}->[$index] == $object) {
|
||||
# delete($self->{objects}->[$index]);
|
||||
# }
|
||||
# }
|
||||
# }
|
||||
# won't work in early perls though, so instead:
|
||||
my $objects = [];
|
||||
object: foreach my $object (@{$self->objects}) {
|
||||
object: foreach my $object (@{$self->{objects}}) {
|
||||
foreach my $removee (@_) {
|
||||
if ($object == $removee) {
|
||||
next object;
|
||||
@ -111,16 +111,16 @@ sub removeObject {
|
||||
}
|
||||
push(@$objects, $objects);
|
||||
}
|
||||
$self->objects($objects);
|
||||
$self->{objects} = $objects;
|
||||
}
|
||||
|
||||
sub getService {
|
||||
my $self = shift;
|
||||
my($name) = @_;
|
||||
if (defined($self->servicesHash->{$name})) {
|
||||
return $self->servicesHash->{$name};
|
||||
if (defined($self->{servicesHash}->{$name})) {
|
||||
return $self->{servicesHash}->{$name};
|
||||
}
|
||||
foreach my $service (@{$self->services}) {
|
||||
foreach my $service (@{$self->{services}}) {
|
||||
if ($service->provides($name)) {
|
||||
# Create the service. If it is already created, this will
|
||||
# just return the object reference, so no harm done.
|
||||
@ -129,7 +129,7 @@ sub getService {
|
||||
# Doing so would create a circular dependency, resulting
|
||||
# in a memory leak.
|
||||
$service = $service->create($self);
|
||||
$self->servicesHash->{$name} = $service;
|
||||
$self->{servicesHash}->{$name} = $service;
|
||||
return $service;
|
||||
}
|
||||
}
|
||||
@ -141,7 +141,7 @@ sub getObject {
|
||||
# constructor call
|
||||
my $self = shift;
|
||||
my($name) = @_;
|
||||
foreach my $object (@{$self->objects}) {
|
||||
foreach my $object (@{$self->{objects}}) {
|
||||
if ($object->objectProvides($name)) {
|
||||
return $object;
|
||||
}
|
||||
@ -153,7 +153,7 @@ sub getServiceList {
|
||||
my $self = shift;
|
||||
my($name) = @_;
|
||||
my @services = ();
|
||||
foreach my $service (@{$self->services}) {
|
||||
foreach my $service (@{$self->{services}}) {
|
||||
if ($service->provides($name)) {
|
||||
# Create the service. If it is already created, this will
|
||||
# just return the object reference, so no harm done.
|
||||
@ -174,7 +174,7 @@ sub getObjectList {
|
||||
my $self = shift;
|
||||
my($name) = @_;
|
||||
my @objects = ();
|
||||
foreach my $object (@{$self->objects}) {
|
||||
foreach my $object (@{$self->{objects}}) {
|
||||
if ($object->objectProvides($name)) {
|
||||
push(@objects, $object);
|
||||
}
|
||||
@ -215,7 +215,7 @@ sub getSelectingObjectList {
|
||||
sub getServiceInstance {
|
||||
my $self = shift;
|
||||
my($name, @data) = @_;
|
||||
foreach my $service (@{$self->services}) {
|
||||
foreach my $service (@{$self->{services}}) {
|
||||
if ($service->provides($name)) {
|
||||
# Create and return the service instance, without storing
|
||||
# a copy.
|
||||
@ -258,9 +258,9 @@ sub DESTROY {
|
||||
my $self = shift;
|
||||
$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})) .
|
||||
scalar(keys(%{$self->{servicesHash}})) .
|
||||
' had been placed in the services hash.');
|
||||
$self->SUPER::DESTROY(@_);
|
||||
}
|
||||
|
||||
@ -63,7 +63,7 @@ sub database {
|
||||
}
|
||||
}
|
||||
}
|
||||
$self->error(1, 'There is no suitable \''.$self->databaseName.'\' database installed.');
|
||||
$self->error(1, 'There is no suitable \''.$self->databaseName.'\' database installed');
|
||||
}
|
||||
|
||||
sub helper {
|
||||
@ -86,5 +86,5 @@ sub helper {
|
||||
}
|
||||
}
|
||||
}
|
||||
$self->error(1, 'Configuration Error: There is no database helper suitable for the \''.$self->databaseName.'\' database installed.');
|
||||
$self->error(1, 'Configuration Error: There is no database helper suitable for the \''.$self->databaseName.'\' database installed');
|
||||
}
|
||||
|
||||
@ -59,9 +59,9 @@ sub init {
|
||||
$self->SUPER::init(@_);
|
||||
require HTTP::Negotiate; import HTTP::Negotiate; # DEPENDENCY
|
||||
require HTTP::Headers; import HTTP::Headers; # DEPENDENCY
|
||||
$self->variantsCache({});
|
||||
$self->stringsCache({});
|
||||
$self->enabled(1);
|
||||
$self->{variantsCache} = {};
|
||||
$self->{stringsCache} = {};
|
||||
$self->{enabled} = 1;
|
||||
}
|
||||
|
||||
# returns ($type, $version, $string)
|
||||
@ -69,7 +69,7 @@ sub getCustomisedString {
|
||||
my $self = shift;
|
||||
my($app, $session, $protocol, $string) = @_;
|
||||
# error handling makes code ugly :-)
|
||||
if ($self->enabled) {
|
||||
if ($self->{enabled}) {
|
||||
my $variant;
|
||||
if (defined($session)) {
|
||||
$variant = $session->selectVariant($protocol);
|
||||
@ -79,10 +79,10 @@ sub getCustomisedString {
|
||||
# $app->input instead
|
||||
$variant = $self->selectVariant($app, $protocol);
|
||||
}
|
||||
if (not defined($self->stringsCache->{$variant})) {
|
||||
$self->stringsCache->{$variant} = {};
|
||||
if (not defined($self->{stringsCache}->{$variant})) {
|
||||
$self->{stringsCache}->{$variant} = {};
|
||||
}
|
||||
if (not defined($self->stringsCache->{$variant}->{$string})) {
|
||||
if (not defined($self->{stringsCache}->{$variant}->{$string})) {
|
||||
my @results;
|
||||
try {
|
||||
@results = $self->getString($app, $variant, $string);
|
||||
@ -92,13 +92,13 @@ sub getCustomisedString {
|
||||
$self->warn(4, "While I was looking for the string '$string' in protocol '$protocol' using variant '$variant', I failed with: @_");
|
||||
};
|
||||
if (@results) {
|
||||
$self->stringsCache->{$variant}->{$string} = \@results;
|
||||
$self->{stringsCache}->{$variant}->{$string} = \@results;
|
||||
return @results;
|
||||
} else {
|
||||
return;
|
||||
}
|
||||
} else {
|
||||
return @{$self->stringsCache->{$variant}->{$string}};
|
||||
return @{$self->{stringsCache}->{$variant}->{$string}};
|
||||
}
|
||||
} else {
|
||||
$self->dump(9, "String datasource is disabled, skipping");
|
||||
@ -144,31 +144,31 @@ sub selectVariant {
|
||||
sub variants {
|
||||
my $self = shift;
|
||||
my($app, $protocol) = @_;
|
||||
if (not defined($self->variantsCache->{$protocol})) {
|
||||
if (not defined($self->{variantsCache}->{$protocol})) {
|
||||
try {
|
||||
$self->variantsCache->{$protocol} = $self->getVariants($app, $protocol);
|
||||
$self->{variantsCache}->{$protocol} = $self->getVariants($app, $protocol);
|
||||
} except {
|
||||
# ok, so, er, it seems that didn't go to well
|
||||
# XXX do we want to do an error here or something?
|
||||
$self->warn(4, "While I was looking for the variants, I failed with: @_");
|
||||
$self->variantsCache->{$protocol} = []; # no variants here, no sir!
|
||||
$self->{variantsCache}->{$protocol} = []; # no variants here, no sir!
|
||||
};
|
||||
}
|
||||
return $self->variantsCache->{$protocol};
|
||||
return $self->{variantsCache}->{$protocol};
|
||||
}
|
||||
|
||||
# setup.events.start
|
||||
sub setupStarting {
|
||||
my $self = shift;
|
||||
my($app) = @_;
|
||||
$self->enabled(0);
|
||||
$self->{enabled} = 0;
|
||||
}
|
||||
|
||||
# setup.events.end
|
||||
sub setupEnding {
|
||||
my $self = shift;
|
||||
my($app) = @_;
|
||||
$self->enabled(1);
|
||||
$self->{enabled} = 1;
|
||||
}
|
||||
|
||||
# setup.install
|
||||
|
||||
@ -118,22 +118,17 @@ sub write {
|
||||
|
||||
sub propertySet {
|
||||
my $self = shift;
|
||||
my($name, $value) = @_;
|
||||
$self->ensureRead();
|
||||
my $result = $self->SUPER::propertySet(@_);
|
||||
$self->{'_DIRTY'} = 1;
|
||||
return $result;
|
||||
}
|
||||
|
||||
sub propertyExists {
|
||||
my $self = shift;
|
||||
$self->ensureRead();
|
||||
return $self->SUPER::propertyExists(@_);
|
||||
return $self->{$name} = $value;
|
||||
}
|
||||
|
||||
sub propertyGet {
|
||||
my $self = shift;
|
||||
my($name) = @_;
|
||||
$self->ensureRead();
|
||||
return $self->SUPER::propertyGet(@_);
|
||||
return $self->{$name};
|
||||
}
|
||||
|
||||
sub DESTROY {
|
||||
|
||||
@ -57,34 +57,40 @@ sub init {
|
||||
$self->openDB(@_);
|
||||
}
|
||||
|
||||
sub type {
|
||||
my $self = shift;
|
||||
syntaxError "type() called with arguments" if @_;
|
||||
return $self->{type};
|
||||
}
|
||||
|
||||
sub openDB {
|
||||
my $self = shift;
|
||||
my($app) = @_;
|
||||
try {
|
||||
$self->getConfig($app);
|
||||
} except {
|
||||
$self->handle(undef);
|
||||
$self->errstr(@_);
|
||||
$self->{handle} = undef;
|
||||
$self->{errstr} = @_;
|
||||
$self->dump(9, "failed to get the database configuration, not going to bother to connect: @_");
|
||||
} otherwise {
|
||||
try {
|
||||
$self->handle(DBI->connect($self->connectString, $self->username, $self->password,
|
||||
{RaiseError => 0, PrintError => 0, AutoCommit => 1, Taint => 1}));
|
||||
$self->errstr($DBI::errstr);
|
||||
$self->{handle} = DBI->connect($self->connectString, $self->{username}, $self->{password},
|
||||
{RaiseError => 0, PrintError => 0, AutoCommit => 1, Taint => 1});
|
||||
$self->{errstr} = $DBI::errstr;
|
||||
$self->dump(9, 'created a database object without raising an exception');
|
||||
} except {
|
||||
$self->handle(undef);
|
||||
$self->errstr(@_);
|
||||
$self->error(1, "failed to connect to the database because of @_");
|
||||
$self->{handle} = undef;
|
||||
$self->{errstr} = @_;
|
||||
$self->error(1, "failed to connect to the database: @_");
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub closeDB {
|
||||
my $self = shift;
|
||||
if ($self->handle) {
|
||||
$self->handle->disconnect();
|
||||
$self->handle(undef);
|
||||
if ($self->{handle}) {
|
||||
$self->{handle}->disconnect();
|
||||
$self->{handle} = undef;
|
||||
}
|
||||
}
|
||||
|
||||
@ -92,14 +98,14 @@ sub connectString {
|
||||
my $self = shift;
|
||||
my($name) = @_;
|
||||
if (not defined($name)) {
|
||||
$name = $self->name;
|
||||
$name = $self->{name};
|
||||
}
|
||||
return 'DBI:'.($self->type).':'.($name).':'.($self->host).':'.($self->port);
|
||||
return 'DBI:'.($self->{type}).':'.($name).':'.($self->{host}).':'.($self->{port});
|
||||
}
|
||||
|
||||
sub lastError {
|
||||
my $self = shift;
|
||||
return $self->handle->err;
|
||||
return $self->{handle}->err;
|
||||
}
|
||||
|
||||
sub prepare {
|
||||
@ -123,9 +129,9 @@ sub attempt {
|
||||
sub createResultsFrame {
|
||||
my $self = shift;
|
||||
my($statement, $execute, @values) = @_;
|
||||
$self->assert($self->handle, 1, 'No database handle: '.(defined($self->errstr) ? $self->errstr : 'unknown error'));
|
||||
$self->assert($self->{handle}, 1, 'No database handle: '.(defined($self->{errstr}) ? $self->{errstr} : 'unknown error'));
|
||||
$statement =~ /^(.*)$/os; # untaint # (XXX?)
|
||||
my $handle = $self->handle->prepare($1);
|
||||
my $handle = $self->{handle}->prepare($1);
|
||||
if ($handle) {
|
||||
return PLIF::Database::ResultsFrame::DBI->create($handle, $self, $execute, @values);
|
||||
} else {
|
||||
@ -204,7 +210,7 @@ sub setupConfigure {
|
||||
my $return;
|
||||
$app->output->setupProgress("$prefix.admin.checking");
|
||||
try {
|
||||
DBI->connect($self->connectString, $self->username, $self->password,
|
||||
DBI->connect($self->connectString, $self->{username}, $self->{password},
|
||||
{RaiseError => 1, PrintError => 0, AutoCommit => 1, Taint => 1})->disconnect();
|
||||
} except {
|
||||
$return = $self->setupConfigureDatabase($app, $prefix);
|
||||
@ -273,31 +279,31 @@ sub setupConfigureDatabase {
|
||||
my @helpers = $app->getServiceList('database.helper');
|
||||
helper: foreach my $helperInstance (@helpers) {
|
||||
foreach my $helperType ($helperInstance->databaseType) {
|
||||
if ($helperType eq $self->type) {
|
||||
if ($helperType eq $self->{type}) {
|
||||
$helper = $helperInstance;
|
||||
last helper;
|
||||
}
|
||||
}
|
||||
}
|
||||
$self->assert(defined($helper), 1, 'No database helper installed for database type \''.$self->type.'\'');
|
||||
$self->assert(defined($helper), 1, 'No database helper installed for database type \''.$self->{type}.'\'');
|
||||
|
||||
# connect
|
||||
eval {
|
||||
$self->handle(DBI->connect($self->connectString($helper->setupDatabaseName), $adminUsername, $adminPassword,
|
||||
{RaiseError => 0, PrintError => 1, AutoCommit => 1, Taint => 1}));
|
||||
$self->{handle} = DBI->connect($self->connectString($helper->setupDatabaseName), $adminUsername, $adminPassword,
|
||||
{RaiseError => 0, PrintError => 1, AutoCommit => 1, Taint => 1});
|
||||
};
|
||||
$self->assert((not $@), 1, "Could not connect to database: $@");
|
||||
$self->assert($self->handle, 1, 'Failed to connect to database: '.(defined($DBI::errstr) ? $DBI::errstr : 'unknown error'));
|
||||
$self->assert($self->{handle}, 1, 'Failed to connect to database: '.(defined($DBI::errstr) ? $DBI::errstr : 'unknown error'));
|
||||
|
||||
# get the helper to do its stuff
|
||||
$helper->setupVerifyVersion($app, $self);
|
||||
$helper->setupCreateUser($app, $self, $self->username, $self->password, $localHostname, $self->name);
|
||||
$helper->setupCreateDatabase($app, $self, $self->name);
|
||||
$helper->setupSetRights($app, $self, $self->username, $self->password, $localHostname, $self->name);
|
||||
$helper->setupCreateUser($app, $self, $self->{username}, $self->{password}, $localHostname, $self->{name});
|
||||
$helper->setupCreateDatabase($app, $self, $self->{name});
|
||||
$helper->setupSetRights($app, $self, $self->{username}, $self->{password}, $localHostname, $self->{name});
|
||||
|
||||
# disconnect
|
||||
$self->handle->disconnect();
|
||||
$self->handle(undef);
|
||||
$self->{handle}->disconnect();
|
||||
$self->{handle} = undef;
|
||||
}
|
||||
|
||||
sub DESTROY {
|
||||
|
||||
@ -41,8 +41,8 @@ sub init {
|
||||
my $self = shift;
|
||||
$self->SUPER::init(@_);
|
||||
my($handle, $database, $execute, @values) = @_;
|
||||
$self->handle($handle);
|
||||
$self->database($database);
|
||||
$self->{handle} = $handle;
|
||||
$self->{database} = $database;
|
||||
if (defined($execute)) {
|
||||
$self->execute($execute, @values);
|
||||
}
|
||||
@ -52,23 +52,23 @@ __DATA__
|
||||
|
||||
sub lastError {
|
||||
my $self = shift;
|
||||
return $self->handle->err;
|
||||
return $self->{handle}->err;
|
||||
}
|
||||
|
||||
sub rowsAffected {
|
||||
my $self = shift;
|
||||
return $self->handle->rows;
|
||||
return $self->{handle}->rows;
|
||||
}
|
||||
|
||||
sub row {
|
||||
my $self = shift;
|
||||
$self->assert($self->executed, 1, 'Tried to fetch data from an unexecuted statement');
|
||||
$self->assert($self->{executed}, 1, 'Tried to fetch data from an unexecuted statement');
|
||||
my $wantarray = wantarray; # to propagate it into the try block below
|
||||
my @result = try {
|
||||
if ($wantarray) {
|
||||
return $self->handle->fetchrow_array();
|
||||
return $self->{handle}->fetchrow_array();
|
||||
} else {
|
||||
my $array = $self->handle->fetchrow_arrayref();
|
||||
my $array = $self->{handle}->fetchrow_arrayref();
|
||||
if ((not defined($array)) or @$array == 0) {
|
||||
# no data
|
||||
return undef;
|
||||
@ -94,9 +94,9 @@ sub row {
|
||||
|
||||
sub rows {
|
||||
my $self = shift;
|
||||
$self->assert($self->executed, 1, 'Tried to fetch data from an unexecuted statement');
|
||||
$self->assert($self->{executed}, 1, 'Tried to fetch data from an unexecuted statement');
|
||||
my $result = try {
|
||||
$self->handle->fetchall_arrayref();
|
||||
$self->{handle}->fetchall_arrayref();
|
||||
} except {
|
||||
my($exception) = @_;
|
||||
if (my $error = $self->lastError) {
|
||||
@ -128,14 +128,14 @@ sub execute {
|
||||
}
|
||||
}
|
||||
my $result = try {
|
||||
$self->handle->execute(@values);
|
||||
$self->{handle}->execute(@values);
|
||||
} except {
|
||||
raise PLIF::Exception::Database (
|
||||
'message' => $_[0],
|
||||
);
|
||||
};
|
||||
if ($result) {
|
||||
$self->executed(1);
|
||||
$self->{executed} = 1;
|
||||
return $self;
|
||||
} elsif (not $raise) {
|
||||
return $self;
|
||||
@ -154,12 +154,12 @@ sub raiseError {
|
||||
# This should only be used by MySQL-specific DBI data sources
|
||||
raise PLIF::Exception::Database::Duplicate (
|
||||
'code' => $self->lastError,
|
||||
'message' => $self->handle->errstr,
|
||||
'message' => $self->{handle}->errstr,
|
||||
);
|
||||
} else {
|
||||
raise PLIF::Exception::Database (
|
||||
'code' => $self->lastError,
|
||||
'message' => $self->handle->errstr,
|
||||
'message' => $self->{handle}->errstr,
|
||||
);
|
||||
}
|
||||
}
|
||||
@ -167,7 +167,7 @@ sub raiseError {
|
||||
# This should only be used by MySQL-specific DBI data sources
|
||||
sub MySQLID {
|
||||
my $self = shift;
|
||||
return $self->handle->{'mysql_insertid'};
|
||||
return $self->{handle}->{'mysql_insertid'};
|
||||
}
|
||||
|
||||
# other possible APIs:
|
||||
|
||||
@ -43,3 +43,5 @@ sub databaseType {
|
||||
my $self = shift;
|
||||
$self->notImplemented();
|
||||
}
|
||||
|
||||
__DATA__
|
||||
|
||||
@ -32,7 +32,17 @@ use vars qw(@ISA @EXPORT);
|
||||
use overload '""' => 'stringify', 'cmp' => 'comparison';
|
||||
require Exporter;
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT = qw(try catch with fallthrough except otherwise finally syntaxError);
|
||||
@EXPORT = qw(try catch with fallthrough except otherwise finally syntaxError evalString);
|
||||
my %EVALS = ();
|
||||
|
||||
# Make warnings
|
||||
$SIG{__WARN__} = sub {
|
||||
my $message = shift;
|
||||
$message =~ s/\(eval ([0-9]+)\)/ exists $EVALS{$1} ? $EVALS{$1} : $1 /gose;
|
||||
$message =~ s/, <DATA> line [0-9]+//gos; # clean up irrelevant useless junk...
|
||||
warn $message; # reraise the updated message
|
||||
};
|
||||
|
||||
|
||||
# To use this package, you first have to define your own exceptions:
|
||||
#
|
||||
@ -70,6 +80,23 @@ require Exporter;
|
||||
#
|
||||
# The report method also returns a valid exception, should you wish to
|
||||
# later raise it for real.
|
||||
#
|
||||
# If you want to evaluate a string, call evalString($string,
|
||||
# $filename). This will take a note of the eval number for stack
|
||||
# traces and warnings. All warnings in blocks evaluated by this will
|
||||
# be updated automatically.
|
||||
|
||||
sub evalString($$) {
|
||||
my($string, $filename) = @_;
|
||||
my $evalID;
|
||||
my $test = eval "sub { (undef eq 0) }";
|
||||
local $^W = 1;
|
||||
local $SIG{__WARN__} = sub { $_[0] =~ m/^Use of uninitialized value in string eq at \(eval ([0-9]+)\) line 1/os; $evalID = $1; };
|
||||
&$test();
|
||||
$EVALS{++$evalID} = $filename;
|
||||
# print STDERR "evaluating eval $evalID = $EVALS{$evalID}\n";
|
||||
eval $string;
|
||||
}
|
||||
|
||||
# constants for stringifying exceptions
|
||||
sub seMaxLength() { 80 }
|
||||
@ -90,6 +117,9 @@ sub getFrames() {
|
||||
my @frames;
|
||||
my $index = 0;
|
||||
while (my @data = caller($index++)) {
|
||||
# expand knows eval numbers
|
||||
$data[1] =~ s/\(eval ([0-9]+)\)/ exists $EVALS{$1} ? $EVALS{$1} : $1 /ose;
|
||||
# push frame onto stack
|
||||
push(@frames, {
|
||||
'package' => $data[0],
|
||||
'filename' => $data[1],
|
||||
@ -142,6 +172,10 @@ sub init {
|
||||
$exception->{'line'} = $line;
|
||||
$exception->{'stacktrace'} = $stacktrace;
|
||||
}
|
||||
if (defined($exception->{'message'})) {
|
||||
$exception->{'message'} =~ s/\(eval ([0-9]+)\)/ exists $EVALS{$1} ? $EVALS{$1} : $1 /ose;
|
||||
$exception->{'message'} =~ s/\.?\n$/, reraised/os;
|
||||
}
|
||||
return $exception;
|
||||
}
|
||||
|
||||
@ -156,6 +190,7 @@ sub report {
|
||||
my($exception, @data) = @_;
|
||||
syntaxError "Syntax error in \"report\": \"$exception\" is not a PLIF::Exception class", 1 unless UNIVERSAL::isa($exception, __PACKAGE__);
|
||||
$exception = $exception->init(@data);
|
||||
local $SIG{__WARN__} = undef; # don't want this warning going through our processor
|
||||
warn $exception;
|
||||
return $exception;
|
||||
}
|
||||
@ -273,8 +308,8 @@ sub stringify {
|
||||
$value .= "\nStack Trace:\n";
|
||||
foreach my $frame (@{$self->{'stacktrace'}}) {
|
||||
my $where;
|
||||
if ($frame->{'filename'} =~ m/^\(eval [0-9]+\)$/os) {
|
||||
$where = "line $frame->{'line'} of eval '...' created in $frame->{'package'} context";
|
||||
if ($frame->{'filename'} =~ m/^\(eval ([0-9]+)\)$/os) {
|
||||
$where = "line $frame->{'line'} of eval '...' $1 created in $frame->{'package'} context";
|
||||
} else {
|
||||
$where = "$frame->{'filename'} line $frame->{'line'}";
|
||||
}
|
||||
@ -308,7 +343,6 @@ sub stringify {
|
||||
foreach my $key (sort keys %ENV) {
|
||||
$value .= " $key = $ENV{$key}\n";
|
||||
}
|
||||
$value .= "\n";
|
||||
return $value;
|
||||
}
|
||||
|
||||
@ -392,6 +426,9 @@ sub wrap($) {
|
||||
if (not ref($exception) or
|
||||
not $exception->isa('PLIF::Exception')) {
|
||||
# an unexpected exception
|
||||
$exception =~ s/\(eval ([0-9]+)\)/ exists $EVALS{$1} ? $EVALS{$1} : $1 /gose;
|
||||
$exception =~ s/, <DATA> line [0-9]+//gos; # clean up irrelevant useless junk...
|
||||
$exception =~ s/\.?\n$/, reraised/os;
|
||||
$exception = PLIF::Exception->create('message' => $exception);
|
||||
}
|
||||
if (not exists $exception->{'stacktrace'}) {
|
||||
|
||||
@ -56,7 +56,7 @@ sub init {
|
||||
my $self = shift;
|
||||
my($app) = @_;
|
||||
$self->SUPER::init(@_);
|
||||
$self->app($app); # only safe because input services are created as service instances not pure services!!!
|
||||
$self->{app} = $app; # only safe because input services are created as service instances not pure services!!!
|
||||
$self->fetchArguments();
|
||||
}
|
||||
|
||||
|
||||
@ -163,8 +163,17 @@ sub createArgument {
|
||||
$self->{"argument $argument"} = [];
|
||||
}
|
||||
|
||||
sub propertyExists {
|
||||
return 1;
|
||||
sub implyMethod {
|
||||
my $self = shift;
|
||||
my($name, @data) = @_;
|
||||
if (@data > 1) {
|
||||
return $self->SUPER::implyMethod(@_);
|
||||
}
|
||||
if (@data) {
|
||||
return $self->propertySet($name, @data);
|
||||
} else {
|
||||
return $self->propertyGet($name);
|
||||
}
|
||||
}
|
||||
|
||||
sub propertyGet {
|
||||
|
||||
@ -80,22 +80,22 @@ sub splitArguments {
|
||||
if ($self->HTTP_AUTHORIZATION =~ /^Basic +(.*)$/os) {
|
||||
# HTTP Basic Authentication
|
||||
my($username, $password) = split(/:/, decode_base64($1), 2);
|
||||
$self->username($username);
|
||||
$self->password($password);
|
||||
$self->{username} = $username;
|
||||
$self->{password} = $password;
|
||||
} else {
|
||||
# Some other authentication scheme
|
||||
}
|
||||
}
|
||||
# hook in cookies
|
||||
$self->cookies({}); # empty the list of cookies first
|
||||
$self->{cookies} = {}; # empty the list of cookies first
|
||||
if (defined($ENV{'HTTP_COOKIE'})) {
|
||||
foreach my $cookie (split(/; /os, $ENV{'HTTP_COOKIE'})) {
|
||||
my($field, $value) = split(/=/os, $cookie);
|
||||
$self->cookies->{$field} = $value;
|
||||
$self->{cookies}->{$field} = $value;
|
||||
}
|
||||
}
|
||||
# decode the arguments
|
||||
$self->decodeHTTPArguments;
|
||||
$self->decodeHTTPArguments();
|
||||
}
|
||||
|
||||
sub decodeHTTPArguments {
|
||||
@ -150,7 +150,7 @@ sub setCommandArgument {
|
||||
sub getMetaData {
|
||||
my $self = shift;
|
||||
my($field) = @_;
|
||||
return $self->metaData->{$field};
|
||||
return $self->{metaData}->{$field};
|
||||
}
|
||||
|
||||
sub registerPropertyAsMetaData {
|
||||
@ -159,7 +159,7 @@ sub registerPropertyAsMetaData {
|
||||
foreach my $property (@propertys) {
|
||||
my $value = $self->propertyGet($property);
|
||||
if (defined($value)) {
|
||||
$self->metaData->{$field} = $value;
|
||||
$self->{metaData}->{$field} = $value;
|
||||
last;
|
||||
}
|
||||
}
|
||||
@ -169,5 +169,5 @@ sub registerPropertyAsMetaData {
|
||||
sub getSessionData {
|
||||
my $self = shift;
|
||||
my($field) = @_;
|
||||
return $self->cookies->{$field};
|
||||
return $self->{cookies}->{$field};
|
||||
}
|
||||
|
||||
@ -50,7 +50,7 @@ sub decodeHTTPArguments {
|
||||
} else {
|
||||
$self->dump(9, 'HTTP HEAD. No input.');
|
||||
}
|
||||
$self->app->addObject($self);
|
||||
$self->{app}->addObject($self);
|
||||
}
|
||||
|
||||
sub objectProvides {
|
||||
|
||||
@ -70,8 +70,8 @@ sub decodeHTTPArguments {
|
||||
|
||||
# parse the MIME body
|
||||
local $/ = undef;
|
||||
my $data = 'Content-Type: ' . $self->CONTENT_TYPE . "\n" .
|
||||
'Content-Length: ' . $self->CONTENT_LENGTH . "\n" .
|
||||
my $data = 'Content-Type: ' . $self->{CONTENT_TYPE} . "\n" .
|
||||
'Content-Length: ' . $self->{CONTENT_LENGTH} . "\n" .
|
||||
"\n" . <STDIN>;
|
||||
$self->dump(9, "Data was:\n==============================\n$data\n==============================");
|
||||
my $entity = $parser->parse_data($data);
|
||||
@ -111,11 +111,11 @@ sub decodeHTTPArguments {
|
||||
}
|
||||
|
||||
# store the entity so that we can purge the files later
|
||||
$self->entity($entity);
|
||||
$self->{entity} = $entity;
|
||||
}
|
||||
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
$self->entity->purge();
|
||||
$self->{entity}->purge();
|
||||
$self->SUPER::destroy();
|
||||
}
|
||||
|
||||
@ -54,15 +54,15 @@ sub decodeHTTPArguments {
|
||||
$self->dump(9, 'XML-RPC call. Input was:', '=' x 72 . "\n$input", '=' x 72);
|
||||
|
||||
# find someone who understands XML RPC
|
||||
my $service = $self->app->getService('service.xmlrpc');
|
||||
my $service = $self->{app}->getService('service.xmlrpc');
|
||||
|
||||
# decode the XML stream and stuff the arguments from it
|
||||
my($method, $arguments) = $service->decodeXMLRPC($self->app, $input);
|
||||
my($method, $arguments) = $service->decodeXMLRPC($self->{app}, $input);
|
||||
$self->addArgument('command', $method);
|
||||
foreach my $argument (keys(%$arguments)) {
|
||||
$self->addArgument($argument, $arguments->{$argument});
|
||||
}
|
||||
|
||||
# tell the XML RPC expert to that our input is being used
|
||||
$service->registerHook($self->app);
|
||||
$service->registerHook($self->{app});
|
||||
}
|
||||
|
||||
@ -102,7 +102,7 @@ sub createArgument {
|
||||
# defer to superclass
|
||||
$self->SUPER::createArgument(@_);
|
||||
} else {
|
||||
$self->app->output->request(@_);
|
||||
$self->{app}->output->request(@_);
|
||||
# get input from user
|
||||
my $term = $self->term();
|
||||
my $value = $term->readline(''); # (the parameter passed is the prompt, if any)
|
||||
@ -127,7 +127,7 @@ sub createArgument {
|
||||
sub term {
|
||||
my $self = shift;
|
||||
if (not defined($self->{'term'})) {
|
||||
$self->{'term'} = Term::ReadLine->new($self->app->name);
|
||||
$self->{'term'} = Term::ReadLine->new($self->{app}->name);
|
||||
}
|
||||
return $self->{'term'};
|
||||
}
|
||||
|
||||
@ -50,25 +50,17 @@ sub serviceInstanceInit {
|
||||
my $self = shift;
|
||||
my($app) = @_;
|
||||
$self->SUPER::init(@_);
|
||||
$self->propertySet('app', $app);
|
||||
$self->{app} = $app;
|
||||
# output classes disable implied property creation, so we use
|
||||
# propertySet() here instead of just $self->app($app).
|
||||
}
|
||||
|
||||
# disable implied property access so that calls to unimplemented
|
||||
# output methods will always be caught and can be handled by generic
|
||||
# output handlers.
|
||||
sub propertyImpliedAccessAllowed {
|
||||
my $self = shift;
|
||||
return $self->propertyExists(@_);
|
||||
# propertySet() here instead of just $self->{app} = $app.
|
||||
}
|
||||
|
||||
# if we don't implement the output handler directly, let's see if some
|
||||
# output dispatcher service for this protocol does
|
||||
sub methodMissing {
|
||||
sub implyMethod {
|
||||
my $self = shift;
|
||||
my($method, @arguments) = @_;
|
||||
if (not $self->app->dispatchMethod('dispatcher.output.'.$self->protocol, 'output', $method, $self, @arguments)) {
|
||||
$self->SUPER::methodMissing(@_);
|
||||
if (not $self->{app}->dispatchMethod('dispatcher.output.'.$self->protocol, 'output', $method, $self, @arguments)) {
|
||||
$self->SUPER::implyMethod(@_);
|
||||
}
|
||||
}
|
||||
|
||||
@ -55,10 +55,10 @@ use PLIF::Output;
|
||||
#
|
||||
# It calls the generic output module's 'HelloWorld' method, which in
|
||||
# this case doesn't exist and ends up going through core PLIF and then
|
||||
# back to methodMissing implemented in this module and the ancestor
|
||||
# back to implyMethod implemented in this module and the ancestor
|
||||
# Output module.
|
||||
#
|
||||
# The methodMissing methods first call every output dispatcher service
|
||||
# The implyMethod methods first call every output dispatcher service
|
||||
# for the actual protocol (HTTP in this case) and then every output
|
||||
# dispatcher service for the generic protocol until one of them
|
||||
# handles the HelloWorld method.
|
||||
@ -122,7 +122,7 @@ sub serviceInstanceInit {
|
||||
my($app, $session, $protocol) = @_;
|
||||
$self->propertySet('actualSession', $session);
|
||||
$self->propertySet('actualProtocol', $protocol);
|
||||
$self->propertySet('outputter', $self->app->getService("output.generic.$protocol"));
|
||||
$self->propertySet('outputter', $self->{app}->getService("output.generic.$protocol"));
|
||||
}
|
||||
|
||||
# output.generic service instance method
|
||||
@ -130,18 +130,18 @@ sub output {
|
||||
my $self = shift;
|
||||
my($string, $data, $session) = @_;
|
||||
if (not defined($session)) {
|
||||
$session = $self->actualSession;
|
||||
$session = $self->{actualSession};
|
||||
}
|
||||
$self->dump(9, "outputting string '$string' on protocol '". ($self->actualProtocol) .'\'');
|
||||
$self->dump(9, "outputting string '$string' on protocol '". ($self->{actualProtocol}) .'\'');
|
||||
$self->fillData($data);
|
||||
# it's not that anyone would override dataSource.strings, it's just that
|
||||
# people might call it without calling output(), so the right thing here
|
||||
# is also to call it through getService():
|
||||
$string = $self->app->getService('dataSource.strings')->getExpandedString($self->app, $session, $self->actualProtocol, $string, $data);
|
||||
foreach my $filter ($self->app->getObjectList('output.filter')) {
|
||||
$string = $filter->filterOutput($self->app, $session, $string);
|
||||
$string = $self->{app}->getService('dataSource.strings')->getExpandedString($self->{app}, $session, $self->{actualProtocol}, $string, $data);
|
||||
foreach my $filter ($self->{app}->getObjectList('output.filter')) {
|
||||
$string = $filter->filterOutput($self->{app}, $session, $string);
|
||||
}
|
||||
$self->outputter->output($self->app, $session, $string);
|
||||
$self->{outputter}->output($self->{app}, $session, $string);
|
||||
}
|
||||
|
||||
# output.generic service instance method
|
||||
@ -151,12 +151,12 @@ sub output {
|
||||
# even though this is actually the generic output handler, because
|
||||
# there _is_ no 'output object for this protocol' since if there was
|
||||
# the generic output module wouldn't get called!
|
||||
sub methodMissing {
|
||||
sub implyMethod {
|
||||
my $self = shift;
|
||||
my($method, @arguments) = @_;
|
||||
if (not $self->app->dispatchMethod('dispatcher.output.'.$self->actualProtocol, 'output', $method, $self, @arguments)) {
|
||||
if (not $self->{app}->dispatchMethod('dispatcher.output.'.$self->{actualProtocol}, 'output', $method, $self, @arguments)) {
|
||||
# ok, no generic output dispatcher for the actual protocol, let's try the generic protocol
|
||||
if (not $self->app->dispatchMethod('dispatcher.output.'.$self->protocol, 'output', $method, $self, @arguments)) {
|
||||
if (not $self->{app}->dispatchMethod('dispatcher.output.'.$self->protocol, 'output', $method, $self, @arguments)) {
|
||||
# nope, so let's do our own.
|
||||
# this assumes the string will be the same as the output
|
||||
# method and that the arguments will be all in 'data'.
|
||||
@ -169,12 +169,12 @@ sub methodMissing {
|
||||
sub fillData {
|
||||
my $self = shift;
|
||||
my($data) = @_;
|
||||
$data->{'app'} = $self->app->hash;
|
||||
if (defined($self->actualSession)) {
|
||||
$data->{'session'} = $self->actualSession->hash;
|
||||
$data->{'app'} = $self->{app}->hash;
|
||||
if (defined($self->{actualSession})) {
|
||||
$data->{'session'} = $self->{actualSession}->hash;
|
||||
}
|
||||
$data->{'input'} = $self->app->input->hash;
|
||||
$data->{'output'} = $self->outputter->hash;
|
||||
$data->{'input'} = $self->{app}->input->hash;
|
||||
$data->{'output'} = $self->{outputter}->hash;
|
||||
}
|
||||
|
||||
# dataSource.strings default implementation
|
||||
|
||||
@ -68,7 +68,7 @@ sub init {
|
||||
$app->getService('dataSource.configuration')->getSettings($app, $self, 'protocol.aim');
|
||||
} except {
|
||||
$self->dump(9, "failed to get the AIM configuration, not going to bother to connect: @_");
|
||||
$self->handle(undef);
|
||||
$self->{handle} = undef;
|
||||
} otherwise {
|
||||
$self->open();
|
||||
}
|
||||
@ -78,19 +78,19 @@ sub open {
|
||||
my $self = shift;
|
||||
# try to connect
|
||||
$self->dump(9, 'opening AIM connection');
|
||||
$self->handle(undef);
|
||||
$self->{handle} = undef;
|
||||
eval {
|
||||
# The Net::AIM code sprouts warning like there's no tomorrow
|
||||
# Let's mute them. :-)
|
||||
local $^W = 0;
|
||||
my $aim = Net::AIM->new();
|
||||
# $aim->debug(${$self->getDebugLevel} > 4);
|
||||
if ($aim->newconn('Screenname' => $self->address,
|
||||
'Password' => $self->password,
|
||||
if ($aim->newconn('Screenname' => $self->{address},
|
||||
'Password' => $self->{password},
|
||||
'AutoReconnect' => 1)) {
|
||||
# wow, we did it
|
||||
# add a buddy first of all (seem to need this, not sure why)
|
||||
$aim->add_buddy(0, 'Buddies', $self->address);
|
||||
$aim->add_buddy(0, 'Buddies', $self->{address});
|
||||
|
||||
# this is dodgy; protocol specs don't guarentee that this
|
||||
# message will arrive
|
||||
@ -98,7 +98,7 @@ sub open {
|
||||
my $conn = shift;
|
||||
my($evt, $from, $to) = @_;
|
||||
my $nick = $evt->args()->[0];
|
||||
$self->handle($aim);
|
||||
$self->{handle} = $aim;
|
||||
$self->dump(9, "opened AIM connection to $from as $nick");
|
||||
});
|
||||
|
||||
@ -112,11 +112,11 @@ sub open {
|
||||
$self->warn(4, "error occured while opening AIM connection: $errstr");
|
||||
});
|
||||
|
||||
while (not defined($self->handle) and $aim->do_one_loop()) { }
|
||||
while (not defined($self->{handle}) and $aim->do_one_loop()) { }
|
||||
}
|
||||
};
|
||||
|
||||
if (not defined($self->handle)) {
|
||||
if (not defined($self->{handle})) {
|
||||
if ($@) {
|
||||
$self->warn(4, "Could not create the AIM handle: $@");
|
||||
} else {
|
||||
@ -127,8 +127,8 @@ sub open {
|
||||
|
||||
sub close {
|
||||
my $self = shift;
|
||||
if (defined($self->handle)) {
|
||||
my $conn = $self->handle->getconn;
|
||||
if (defined($self->{handle})) {
|
||||
my $conn = $self->{handle}->getconn;
|
||||
if (defined($conn)) {
|
||||
$conn->disconnect();
|
||||
}
|
||||
@ -139,16 +139,16 @@ sub close {
|
||||
sub output {
|
||||
my $self = shift;
|
||||
my($app, $session, $string) = @_;
|
||||
$self->assert(defined($self->handle), 1, 'No AIM handle, can\'t send IM');
|
||||
$self->handle->send_im($session->getAddress('aim'), $string);
|
||||
$self->assert(defined($self->{handle}), 1, 'No AIM handle, can\'t send IM');
|
||||
$self->{handle}->send_im($session->getAddress('aim'), $string);
|
||||
}
|
||||
|
||||
# protocol.aim
|
||||
sub checkAddress {
|
||||
my $self = shift;
|
||||
my($app, $username) = @_;
|
||||
$self->assert(defined($self->handle), 1, 'No AIM handle, can\'t check address');
|
||||
# my $result = $self->handle->XXX;
|
||||
$self->assert(defined($self->{handle}), 1, 'No AIM handle, can\'t check address');
|
||||
# my $result = $self->{handle}->XXX;
|
||||
# return $result;
|
||||
return 1;
|
||||
}
|
||||
@ -196,6 +196,6 @@ sub setupConfigure {
|
||||
sub hash {
|
||||
my $self = shift;
|
||||
return {
|
||||
'address' => $self->address,
|
||||
'address' => $self->{address},
|
||||
};
|
||||
}
|
||||
|
||||
@ -55,7 +55,7 @@ sub init {
|
||||
$app->getService('dataSource.configuration')->getSettings($app, $self, 'protocol.email');
|
||||
} except {
|
||||
$self->dump(9, "failed to get the SMTP configuration, not going to bother to connect: $@");
|
||||
$self->handle(undef);
|
||||
$self->{handle} = undef;
|
||||
} otherwise {
|
||||
$self->open();
|
||||
}
|
||||
@ -67,20 +67,20 @@ sub open {
|
||||
try {
|
||||
local $SIG{ALRM} = sub { raise PLIF::Exception::Alarm };
|
||||
local $^W = 0; # XXX shut up warnings in Net::SMTP
|
||||
$self->handle(Net::SMTP->new($self->host, 'Timeout' => $self->timeout));
|
||||
$self->{handle} = Net::SMTP->new($self->{host}, 'Timeout' => $self->{timeout});
|
||||
alarm(0);
|
||||
} catch PLIF::Exception::Alarm with {
|
||||
# timed out -- ignore
|
||||
};
|
||||
if (not defined($self->handle)) {
|
||||
if (not defined($self->{handle})) {
|
||||
$self->warn(4, 'Could not create the SMTP handle');
|
||||
}
|
||||
}
|
||||
|
||||
sub close {
|
||||
my $self = shift;
|
||||
if (defined($self->handle)) {
|
||||
$self->handle->quit();
|
||||
if (defined($self->{handle})) {
|
||||
$self->{handle}->quit();
|
||||
}
|
||||
}
|
||||
|
||||
@ -88,12 +88,12 @@ sub close {
|
||||
sub output {
|
||||
my $self = shift;
|
||||
my($app, $session, $string) = @_;
|
||||
$self->assert(defined($self->handle), 1, 'No SMTP handle, can\'t send mail');
|
||||
$self->assert(defined($self->{handle}), 1, 'No SMTP handle, can\'t send mail');
|
||||
try {
|
||||
local $SIG{ALRM} = sub { raise PLIF::Exception::Alarm };
|
||||
$self->assert($self->handle->mail($self->from), 1, 'Could not start sending mail');
|
||||
$self->assert($self->handle->to($session->getAddress('email')), 1, 'Could not set mail recipient (was going to send to '.($session->getAddress('email')).')');
|
||||
$self->assert($self->handle->data($string), 1, 'Could not send mail body');
|
||||
$self->assert($self->{handle}->mail($self->from), 1, 'Could not start sending mail');
|
||||
$self->assert($self->{handle}->to($session->getAddress('email')), 1, 'Could not set mail recipient (was going to send to '.($session->getAddress('email')).')');
|
||||
$self->assert($self->{handle}->data($string), 1, 'Could not send mail body');
|
||||
alarm(0);
|
||||
} catch PLIF::Exception::Alarm with {
|
||||
$self->error(1, 'Timed out while trying to send e-mail');
|
||||
@ -106,9 +106,9 @@ sub checkAddress {
|
||||
my($app, $username) = @_;
|
||||
return (defined($username) and $username =~ m/^[^@\s]+@[^@\s]+\.[^@.\s]+$/os);
|
||||
# XXX this doesn't seem to be working:
|
||||
# $self->assert(defined($self->handle), 1, 'No SMTP handle, can\'t check address');
|
||||
# $self->assert(defined($self->{handle}), 1, 'No SMTP handle, can\'t check address');
|
||||
# $self->assert(defined($username), 1, 'Internal error: no username passed to checkAddress');
|
||||
# my $result = $self->handle->verify($username);
|
||||
# my $result = $self->{handle}->verify($username);
|
||||
# return $result;
|
||||
}
|
||||
|
||||
@ -133,7 +133,7 @@ sub setupConfigure {
|
||||
|
||||
my $value;
|
||||
|
||||
$value = $self->host;
|
||||
$value = $self->{host};
|
||||
if (not defined($value)) {
|
||||
$value = 'localhost';
|
||||
}
|
||||
@ -141,9 +141,9 @@ sub setupConfigure {
|
||||
if (not defined($value)) {
|
||||
return 'protocol.email.host';
|
||||
}
|
||||
$self->host($value);
|
||||
$self->{host} = $value;
|
||||
|
||||
$value = $self->address;
|
||||
$value = $self->{address};
|
||||
if (defined($value)) {
|
||||
# default to existing value
|
||||
$value = $app->input->getArgument('protocol.email.address', $value);
|
||||
@ -155,9 +155,9 @@ sub setupConfigure {
|
||||
if (not defined($value)) {
|
||||
return 'protocol.email.address';
|
||||
}
|
||||
$self->address($value);
|
||||
$self->{address} = $value;
|
||||
|
||||
$value = $self->timeout;
|
||||
$value = $self->{timeout};
|
||||
if (not defined($value)) {
|
||||
$value = 5;
|
||||
}
|
||||
@ -165,7 +165,7 @@ sub setupConfigure {
|
||||
if (not defined($value)) {
|
||||
return 'protocol.email.timeout';
|
||||
}
|
||||
$self->timeout($value);
|
||||
$self->{timeout} = $value;
|
||||
|
||||
$self->open();
|
||||
$app->getService('dataSource.configuration')->setSettings($app, $self, 'protocol.email');
|
||||
@ -176,7 +176,7 @@ sub setupConfigure {
|
||||
sub hash {
|
||||
my $self = shift;
|
||||
return {
|
||||
'address' => $self->address,
|
||||
'address' => $self->{address},
|
||||
# XXX RFC822 date -- need to provide this WITHOUT duplicating code in StdOut outputter
|
||||
};
|
||||
}
|
||||
|
||||
@ -63,11 +63,11 @@ sub run {
|
||||
if ($self->verifyInput()) {
|
||||
if ($self->input->command) {
|
||||
$self->dump(8, 'Command: ' . ($self->input->command));
|
||||
$self->command($self->input->command);
|
||||
$self->{command} = $self->input->command;
|
||||
$self->dispatch($self->input->command);
|
||||
} else {
|
||||
$self->dump(8, 'Command: (none)');
|
||||
$self->command('');
|
||||
$self->{command} = '';
|
||||
$self->noCommand();
|
||||
}
|
||||
} # verifyInput should deal with the errors
|
||||
@ -76,20 +76,20 @@ sub run {
|
||||
$self->output->reportFatalError(@_);
|
||||
};
|
||||
# command has been completed, reset it
|
||||
$self->command(undef);
|
||||
$self->{command} = undef;
|
||||
# In case we used a progressive output device, let it shut
|
||||
# down. It's important to do this, because it holds a
|
||||
# reference to us and we wouldn't want a memory leak...
|
||||
$self->defaultOutput(undef);
|
||||
$self->{defaultOutput} = undef;
|
||||
# empty the session objects list
|
||||
$self->objects([]);
|
||||
$self->{objects} = [];
|
||||
} while ($self->input->next());
|
||||
# clear the objects hash here, so that objects are removed before
|
||||
# us, otherwise they can't refer back to us during shutdown.
|
||||
# don't need to do the same to services as services should never
|
||||
# use the application object during shutdown. (They shouldn't be
|
||||
# able to. If they can, there is a circular reference.)
|
||||
$self->objects([]);
|
||||
$self->{objects} = [];
|
||||
$self->input(undef); # shutdown the input service instance
|
||||
$self->dump(5, 'PLIF application completed normally.');
|
||||
}
|
||||
@ -106,6 +106,15 @@ sub initInput {
|
||||
}
|
||||
}
|
||||
|
||||
sub input {
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
return $self->{'_input'} = shift;
|
||||
} else {
|
||||
return $self->{'_input'};
|
||||
}
|
||||
}
|
||||
|
||||
# Returns an applicable output method. If you need a particular
|
||||
# protocol, pass it as a parameter. To get the default output class
|
||||
# given the current objects, do not pass any parameters. The output
|
||||
@ -121,8 +130,8 @@ sub output {
|
||||
my($protocol, $session) = @_;
|
||||
my $default = 0;
|
||||
if (not defined($protocol)) {
|
||||
if (defined($self->defaultOutput)) {
|
||||
return $self->defaultOutput;
|
||||
if (defined($self->{defaultOutput})) {
|
||||
return $self->{defaultOutput};
|
||||
}
|
||||
if ($session) {
|
||||
$self->warn(3, 'Tried to use default output method for a specific session object');
|
||||
@ -161,11 +170,7 @@ sub output {
|
||||
# which returns a reference which will be treated just as a
|
||||
# normal output service. In particular, this means that any
|
||||
# method could be called. So most output hooks should use
|
||||
# methodMissing much like PLIF::Output::Generic. (Don't
|
||||
# forget to implement a strict propertyImpliedAccessAllowed
|
||||
# method -- see the PLIF::Output module for an example. If
|
||||
# you don't, then outputs with zero or just one arguments
|
||||
# will be treated as properties, not methods.)
|
||||
# implyMethod much like PLIF::Output::Generic.
|
||||
# * passthrough hooks should then call the original method
|
||||
# again on the argument of the getOutputHook method (which
|
||||
# is the next object). Override hooks (like the XML RPC one)
|
||||
@ -177,7 +182,7 @@ sub output {
|
||||
foreach my $hook (@hooks) {
|
||||
$output = $hook->getOutputHook($output);
|
||||
}
|
||||
$self->defaultOutput($output);
|
||||
$self->{defaultOutput} = $output;
|
||||
}
|
||||
return $output;
|
||||
}
|
||||
@ -205,6 +210,12 @@ sub hash {
|
||||
return { 'name' => $self->name };
|
||||
}
|
||||
|
||||
sub command {
|
||||
my $self = shift;
|
||||
syntaxError 'command() called with arguments' if @_;
|
||||
return $self->{command};
|
||||
}
|
||||
|
||||
|
||||
# Implementation Specific Methods
|
||||
# At least some of these should be overriden by real applications
|
||||
|
||||
@ -56,7 +56,7 @@ sub objectInit {
|
||||
my $self = shift;
|
||||
my($app, $user) = @_;
|
||||
$self->SUPER::objectInit(@_);
|
||||
$self->user($user);
|
||||
$self->{user} = $user;
|
||||
}
|
||||
|
||||
# user.login.canLogin.<protocol>
|
||||
@ -77,7 +77,7 @@ sub loginRequired {
|
||||
my($app) = @_;
|
||||
my $userHandle = $app->getObject('user.login.loggedOutUserHandle.http');
|
||||
if (defined($userHandle)) {
|
||||
my $state = $userHandle->user->hasField('state', 'http.logout');
|
||||
my $state = $userHandle->{user}->hasField('state', 'http.logout');
|
||||
if (defined($state)) {
|
||||
my $value = $state->data - 1;
|
||||
if ($value > 0) {
|
||||
|
||||
@ -60,7 +60,7 @@ sub verifyInput {
|
||||
my $self = shift;
|
||||
my($app) = @_;
|
||||
# clear internal flags
|
||||
$self->userAdminMessage('');
|
||||
$self->{userAdminMessage} = '';
|
||||
# let's see if there are any protocol-specific user authenticators
|
||||
my @result = $app->getSelectingServiceList('input.verify.user.'.$app->input->defaultOutputProtocol)->authenticateUser($app);
|
||||
if (not @result) {
|
||||
@ -84,7 +84,7 @@ sub verifyInput {
|
||||
} else {
|
||||
# hmm, so apparently user is not allowed to log in
|
||||
$self->dump(2, 'user '.($result[0]->userID).' tried logging in but their account is disabled');
|
||||
$self->userAdminMessage($result[0]->adminMessage);
|
||||
$self->{userAdminMessage} = $result[0]->{adminMessage};
|
||||
return $self; # supports user.login (reportInputVerificationError)
|
||||
}
|
||||
}
|
||||
@ -108,7 +108,7 @@ sub authenticateUser {
|
||||
sub reportInputVerificationError {
|
||||
my $self = shift;
|
||||
my($app) = @_;
|
||||
$app->output->loginFailed(1, $self->userAdminMessage); # 1 means 'unknown username/password'
|
||||
$app->output->loginFailed(1, $self->{userAdminMessage}); # 1 means 'unknown username/password'
|
||||
}
|
||||
|
||||
# dispatcher.commands
|
||||
|
||||
@ -81,7 +81,7 @@ sub cmdUserPrefs {
|
||||
foreach my $userID (@userIDs) {
|
||||
my $targetUser = $userFactory->getUserByID($app, $userID);
|
||||
if (defined($targetUser)) {
|
||||
$userData->{$userID} = $self->populateUserPrefsHash($app, $userDataSource, $user, $targetUser, $userID, $userID == $user->userID, @rights);
|
||||
$userData->{$userID} = $self->populateUserPrefsHash($app, $userDataSource, $user, $targetUser, $userID, $userID == $user->{userID}, @rights);
|
||||
} else {
|
||||
$self->warn(2, "someone tried to get the details of invalid user $userID");
|
||||
push(@notifications, [$userID, '', 'user.noSuchUser']);
|
||||
|
||||
@ -45,7 +45,7 @@ sub objectInit {
|
||||
my $self = shift;
|
||||
my($app) = @_;
|
||||
$self->SUPER::objectInit(@_);
|
||||
$self->app($app);
|
||||
$self->{app} = $app;
|
||||
}
|
||||
|
||||
# expected by dataSource.strings
|
||||
|
||||
@ -113,7 +113,7 @@ sub objectProvides {
|
||||
my $self = shift;
|
||||
my($service) = @_;
|
||||
return ($service eq 'user' or
|
||||
$service eq 'user.'.($self->userID) or
|
||||
$service eq 'user.'.($self->{userID}) or
|
||||
$self->SUPER::objectProvides($service));
|
||||
}
|
||||
|
||||
@ -139,12 +139,12 @@ sub objectInit {
|
||||
my($app, $userID, $mode, $password, $adminMessage, $fields, $groups, $rights) = @_;
|
||||
$self->{'_DIRTY'} = {}; # make sure propertySet is happy
|
||||
$self->SUPER::objectInit(@_);
|
||||
$self->userID($userID);
|
||||
$self->mode($mode); # 0=active, 1=disabled XXX need a way to make this extensible
|
||||
$self->password($password);
|
||||
$self->adminMessage($adminMessage);
|
||||
$self->fields({});
|
||||
$self->fieldsByID({});
|
||||
$self->{userID} = $userID;
|
||||
$self->{mode} = $mode; # 0=active, 1=disabled XXX need a way to make this extensible
|
||||
$self->{password} = $password;
|
||||
$self->{adminMessage} = $adminMessage;
|
||||
$self->{fields} = {};
|
||||
$self->{fieldsByID} = {};
|
||||
# don't forget to update the 'hash' function if you add more properties/field whatever you want to call them
|
||||
my $fieldFactory = $app->getService('user.fieldFactory');
|
||||
foreach my $fieldID (keys(%$fields)) {
|
||||
@ -157,25 +157,25 @@ sub objectInit {
|
||||
$groupsByID->{$group->[0]} = {'name' => $group->[1], 'level' => $group->[2], }; # id => name, level
|
||||
$groupsByName->{$group->[1]} = {'groupID' => $group->[0], 'level' => $group->[2], }; # name => id, level
|
||||
}
|
||||
$self->groupsByID($groupsByID); # authoritative version
|
||||
$self->originalGroupsByID({%{$groupsByID}}); # a backup used to make a comparison when saving the groups
|
||||
$self->groupsByName($groupsByName); # helpful version for output purposes only
|
||||
$self->{groupsByID} = $groupsByID; # authoritative version
|
||||
$self->{originalGroupsByID} = {%{$groupsByID}}; # a backup used to make a comparison when saving the groups
|
||||
$self->{groupsByName} = $groupsByName; # helpful version for output purposes only
|
||||
# rights
|
||||
$self->rights({ map {$_ => 1} @$rights }); # map a list of strings into a hash for easy access
|
||||
$self->{rights} = { map {$_ => 1} @$rights }; # map a list of strings into a hash for easy access
|
||||
$self->{'_DIRTY'}->{'properties'} = not(defined($userID));
|
||||
}
|
||||
|
||||
sub hasRight {
|
||||
my $self = shift;
|
||||
my($right) = @_;
|
||||
return (defined($self->rights->{$right}) or $self->levelInGroup(1)); # group 1 is a magical group
|
||||
return (defined($self->{rights}->{$right}) or $self->levelInGroup(1)); # group 1 is a magical group
|
||||
}
|
||||
|
||||
sub hasField {
|
||||
my $self = shift;
|
||||
my($category, $name) = @_;
|
||||
if (defined($self->fields->{$category})) {
|
||||
return $self->fields->{$category}->{$name};
|
||||
if (defined($self->{fields}->{$category})) {
|
||||
return $self->{fields}->{$category}->{$name};
|
||||
}
|
||||
return undef;
|
||||
}
|
||||
@ -188,7 +188,7 @@ sub getField {
|
||||
my($category, $name) = @_;
|
||||
my $field = $self->hasField($category, $name);
|
||||
if (not defined($field)) {
|
||||
$field = $self->insertField($self->app->getService('user.fieldFactory')->createFieldByName($self->app, $self, $category, $name));
|
||||
$field = $self->insertField($self->{app}->getService('user.fieldFactory')->createFieldByName($self->{app}, $self, $category, $name));
|
||||
}
|
||||
return $field;
|
||||
}
|
||||
@ -199,9 +199,9 @@ sub getField {
|
||||
sub getFieldByID {
|
||||
my $self = shift;
|
||||
my($ID) = @_;
|
||||
my $field = $self->fieldsByID->{$ID};
|
||||
my $field = $self->{fieldsByID}->{$ID};
|
||||
if (not defined($field)) {
|
||||
$field = $self->insertField($self->app->getService('user.fieldFactory')->createFieldByID($self->app, $self, $ID));
|
||||
$field = $self->insertField($self->{app}->getService('user.fieldFactory')->createFieldByID($self->{app}, $self, $ID));
|
||||
}
|
||||
return $field;
|
||||
}
|
||||
@ -211,7 +211,7 @@ sub getAddress {
|
||||
my($protocol) = @_;
|
||||
my $field = $self->hasField('contact', $protocol);
|
||||
if (defined($field)) {
|
||||
return $field->address;
|
||||
return $field->{address};
|
||||
} else {
|
||||
return undef;
|
||||
}
|
||||
@ -221,18 +221,18 @@ sub addFieldChange {
|
||||
my $self = shift;
|
||||
my($field, $newData, $password, $type) = @_;
|
||||
$field->prepareChange($newData);
|
||||
return $self->app->getService('dataSource.user')->setUserFieldChange($self->app, $self->userID, $field->fieldID, $newData, $password, $type);
|
||||
return $self->{app}->getService('dataSource.user')->setUserFieldChange($self->{app}, $self->{userID}, $field->{fieldID}, $newData, $password, $type);
|
||||
}
|
||||
|
||||
sub performFieldChange {
|
||||
my $self = shift;
|
||||
my($changeID, $candidatePassword, $minTime) = @_;
|
||||
my $dataSource = $self->app->getService('dataSource.user');
|
||||
my($userID, $fieldID, $newData, $password, $createTime, $type) = $dataSource->getUserFieldChangeFromChangeID($self->app, $changeID);
|
||||
my $dataSource = $self->{app}->getService('dataSource.user');
|
||||
my($userID, $fieldID, $newData, $password, $createTime, $type) = $dataSource->getUserFieldChangeFromChangeID($self->{app}, $changeID);
|
||||
# check for valid change
|
||||
if ((not defined($userID)) or # invalid change ID
|
||||
($userID != $self->userID) or # wrong change ID
|
||||
(not $self->app->getService('service.password')->checkPassword($candidatePassword, $password)) or # wrong password
|
||||
($userID != $self->{userID}) or # wrong change ID
|
||||
(not $self->{app}->getService('service.password')->checkPassword($candidatePassword, $password)) or # wrong password
|
||||
($createTime < $minTime)) { # expired change
|
||||
return 0;
|
||||
}
|
||||
@ -242,11 +242,11 @@ sub performFieldChange {
|
||||
if ($type == 1) { # XXX HARDCODED CONSTANT ALERT
|
||||
# this is an override change
|
||||
# remove all pending changes for this field (including this one)
|
||||
$dataSource->removeUserFieldChangesByUserIDAndFieldID($self->app, $userID, $fieldID);
|
||||
$dataSource->removeUserFieldChangesByUserIDAndFieldID($self->{app}, $userID, $fieldID);
|
||||
} else {
|
||||
# this is a normal change
|
||||
# remove just this change
|
||||
$dataSource->removeUserFieldChangesByChangeID($self->app, $changeID);
|
||||
$dataSource->removeUserFieldChangesByChangeID($self->{app}, $changeID);
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
@ -262,7 +262,7 @@ sub setting {
|
||||
} else {
|
||||
my $field = $self->hasField('settings', $setting);
|
||||
if (defined($field)) {
|
||||
$$variable = $field->data;
|
||||
$$variable = $field->{data};
|
||||
}
|
||||
}
|
||||
}
|
||||
@ -270,26 +270,26 @@ sub setting {
|
||||
sub hash {
|
||||
my $self = shift;
|
||||
my $result = $self->SUPER::hash();
|
||||
$result->{'userID'} = $self->userID,
|
||||
$result->{'mode'} = $self->mode,
|
||||
$result->{'adminMessage'} = $self->adminMessage,
|
||||
$result->{'groupsByID'} = $self->groupsByID;
|
||||
$result->{'groupsByName'} = $self->groupsByName;
|
||||
$result->{'rights'} = [keys(%{$self->rights})];
|
||||
$result->{'userID'} = $self->{userID},
|
||||
$result->{'mode'} = $self->{mode},
|
||||
$result->{'adminMessage'} = $self->{adminMessage},
|
||||
$result->{'groupsByID'} = $self->{groupsByID};
|
||||
$result->{'groupsByName'} = $self->{groupsByName};
|
||||
$result->{'rights'} = [keys(%{$self->{rights}})];
|
||||
if ($self->levelInGroup(1)) {
|
||||
# has all rights
|
||||
$result->{'right'} = {};
|
||||
foreach my $right (@{$self->app->getService('dataSource.user')->getAllRights($self->app)}) {
|
||||
foreach my $right (@{$self->{app}->getService('dataSource.user')->getAllRights($self->{app})}) {
|
||||
$result->{'right'}->{$right} = 1;
|
||||
}
|
||||
} else {
|
||||
$result->{'right'} = $self->rights;
|
||||
$result->{'right'} = $self->{rights};
|
||||
}
|
||||
$result->{'fields'} = {};
|
||||
foreach my $field (values(%{$self->fieldsByID})) {
|
||||
foreach my $field (values(%{$self->{fieldsByID}})) {
|
||||
# XXX should we also pass the field metadata on? (e.g. typeData)
|
||||
$result->{'fields'}->{$field->fieldID} = $field->hash; # (not an array btw: could have holes)
|
||||
$result->{'fields'}->{$field->category.'.'.$field->name} = $field->hash;
|
||||
$result->{'fields'}->{$field->{fieldID}} = $field->hash; # (not an array btw: could have holes)
|
||||
$result->{'fields'}->{$field->{category} . '.' . $field->{name}} = $field->hash;
|
||||
}
|
||||
return $result;
|
||||
}
|
||||
@ -297,19 +297,19 @@ sub hash {
|
||||
sub checkPassword {
|
||||
my $self = shift;
|
||||
my($password) = @_;
|
||||
return $self->app->getService('service.passwords')->checkPassword($self->password, $password);
|
||||
return $self->{app}->getService('service.passwords')->checkPassword($self->{password}, $password);
|
||||
}
|
||||
|
||||
sub checkLogin {
|
||||
my $self = shift;
|
||||
return ($self->mode == 0);
|
||||
return ($self->{mode} == 0);
|
||||
}
|
||||
|
||||
sub joinGroup {
|
||||
my $self = shift;
|
||||
my($groupID, $level) = @_;
|
||||
if ($level > 0) {
|
||||
my $groupName = $self->app->getService('dataSource.user')->getGroupName($self->app, $groupID);
|
||||
my $groupName = $self->{app}->getService('dataSource.user')->getGroupName($self->{app}, $groupID);
|
||||
$self->{'groupsByID'}->{$groupID} = {'name' => $groupName, 'level' => $level, };
|
||||
$self->{'groupsByName'}->{$groupName} = {'groupID' => $groupID, 'level' => $level, };
|
||||
$self->invalidateRights();
|
||||
@ -347,14 +347,14 @@ sub insertField {
|
||||
my $self = shift;
|
||||
my($field) = @_;
|
||||
$self->assert(ref($field) and $field->provides('user.field'), 1, 'Tried to insert something that wasn\'t a field object into a user\'s field hash');
|
||||
$self->fields->{$field->category}->{$field->name} = $field;
|
||||
$self->fieldsByID->{$field->fieldID} = $field;
|
||||
$self->{fields}->{$field->{category}}->{$field->{name}} = $field;
|
||||
$self->{fieldsByID}->{$field->{fieldID}} = $field;
|
||||
return $field;
|
||||
}
|
||||
|
||||
sub invalidateRights {
|
||||
my $self = shift;
|
||||
my $rights = $self->app->getService('dataSource.user')->getRightsForGroups($self->app, keys(%{$self->{'groupsByID'}}));
|
||||
my $rights = $self->{app}->getService('dataSource.user')->getRightsForGroups($self->{app}, keys(%{$self->{'groupsByID'}}));
|
||||
$self->rights({ map {$_ => 1} @$rights }); # map a list of strings into a hash for easy access
|
||||
# don't set a dirty flag, because rights are merely a convenient
|
||||
# cached expansion of the rights data. Changing this externally
|
||||
@ -373,8 +373,8 @@ sub propertySet {
|
||||
my $result = $self->SUPER::propertySet(@_);
|
||||
if (($hadUndefinedID) and (defined($value))) {
|
||||
# we've just aquired an ID, so propagate the change to all fields
|
||||
foreach my $field (values(%{$self->fieldsByID})) {
|
||||
$field->userID($value);
|
||||
foreach my $field (values(%{$self->{fieldsByID}})) {
|
||||
$field->{userID} = $value;
|
||||
}
|
||||
# and mark the groups as dirty too
|
||||
$self->{'_DIRTY'}->{'groups'} = 1;
|
||||
@ -391,10 +391,10 @@ sub propertyGet {
|
||||
# Create new hash so that they can't edit ours. This ensures
|
||||
# that they can't inadvertently bypass the DIRTY flagging by
|
||||
# propertySet(), above. This does mean that internally we have
|
||||
# to access $self->{'groupsByID'} instead of $self->groupsByID.
|
||||
# to access $self->{'groupsByID'} instead of $self->{groupsByID}.
|
||||
} else {
|
||||
# we don't bother looking at $self->rights or
|
||||
# $self->groupsByName, but any changes made to those won't be
|
||||
# $self->{groupsByName}, but any changes made to those won't be
|
||||
# saved anyway.
|
||||
return $self->SUPER::propertyGet(@_);
|
||||
}
|
||||
@ -413,24 +413,24 @@ sub DESTROY {
|
||||
|
||||
sub writeProperties {
|
||||
my $self = shift;
|
||||
$self->userID($self->app->getService('dataSource.user')->setUser($self->app, $self->userID, $self->mode,
|
||||
$self->password, $self->adminMessage,
|
||||
$self->newFieldID, $self->newFieldValue, $self->newFieldKey));
|
||||
$self->{userID} = $self->{app}->getService('dataSource.user')->setUser($self->{app}, $self->{userID}, $self->{mode},
|
||||
$self->{password}, $self->{adminMessage},
|
||||
$self->newFieldID, $self->{newFieldValue}, $self->{newFieldKey});
|
||||
}
|
||||
|
||||
sub writeGroups {
|
||||
my $self = shift;
|
||||
# compare the group lists before and after and see which got added or changed and which got removed
|
||||
my $dataSource = $self->app->getService('dataSource.user');
|
||||
my $dataSource = $self->{app}->getService('dataSource.user');
|
||||
foreach my $group (keys(%{$self->{'groupsByID'}})) {
|
||||
if ((not defined($self->{'originalGroupsByID'}->{$group})) or
|
||||
($self->{'groupsByID'}->{$group}->{'level'} != $self->{'originalGroupsByID'}->{$group}->{'level'})) {
|
||||
$dataSource->addUserGroup($self->app, $self->userID, $group, $self->{'groupsByID'}->{$group}->{'level'});
|
||||
$dataSource->addUserGroup($self->{app}, $self->{userID}, $group, $self->{'groupsByID'}->{$group}->{'level'});
|
||||
}
|
||||
}
|
||||
foreach my $group (keys(%{$self->{'originalGroupsByID'}})) {
|
||||
if (not defined($self->{'groupsByID'}->{$group})) {
|
||||
$dataSource->removeUserGroup($self->app, $self->userID, $group);
|
||||
$dataSource->removeUserGroup($self->{app}, $self->{userID}, $group);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
@ -67,13 +67,13 @@ sub init {
|
||||
my($app, $user, $fieldID, $fieldCategory, $fieldName, $fieldTypeData, $fieldMode, $fieldData) = @_;
|
||||
$self->SUPER::init($app);
|
||||
# do not hold on to $user!
|
||||
$self->app($app);
|
||||
$self->userID($user->userID); # only change this if it started as undef
|
||||
$self->fieldID($fieldID); # change this at your peril
|
||||
$self->category($fieldCategory); # change this at your peril
|
||||
$self->name($fieldName); # change this at your peril
|
||||
$self->typeData($fieldTypeData); # change this at your peril
|
||||
$self->mode($fieldMode); # change this at your peril
|
||||
$self->{app} = $app;
|
||||
$self->{userID} = $user->{userID}; # only change this if it started as undef
|
||||
$self->{fieldID} = $fieldID; # change this at your peril
|
||||
$self->{category} = $fieldCategory; # change this at your peril
|
||||
$self->{name} = $fieldName; # change this at your peril
|
||||
$self->{typeData} = $fieldTypeData; # change this at your peril
|
||||
$self->{mode} = $fieldMode; # change this at your peril
|
||||
$self->{'data'} = $fieldData; # read this via $field->data and write via $field->data($foo)
|
||||
# don't forget to update the 'hash' function if you add more member variables here
|
||||
$self->{'_DATAFIELD'} = 'data';
|
||||
@ -111,7 +111,7 @@ sub data {
|
||||
|
||||
sub hash {
|
||||
my $self = shift;
|
||||
return $self->data;
|
||||
return $self->{data};
|
||||
}
|
||||
|
||||
# Methods specifically for 'contact' category fields
|
||||
@ -120,21 +120,21 @@ sub hash {
|
||||
# followed by the field data itself
|
||||
sub username {
|
||||
my $self = shift;
|
||||
$self->assert($self->category eq 'contact', 0, 'Tried to get the username from the non-contact field \''.($self->fieldID).'\'');
|
||||
return $self->typeData.$self->data;
|
||||
$self->assert($self->{category} eq 'contact', 0, 'Tried to get the username from the non-contact field \''.($self->{fieldID}).'\'');
|
||||
return $self->{typeData} . $self->{data};
|
||||
}
|
||||
|
||||
sub address {
|
||||
my $self = shift;
|
||||
$self->assert($self->category eq 'contact', 0, 'Tried to get the address of the non-contact field \''.($self->fieldID).'\'');
|
||||
return $self->data;
|
||||
$self->assert($self->{category} eq 'contact', 0, 'Tried to get the address of the non-contact field \''.($self->{fieldID}).'\'');
|
||||
return $self->{data};
|
||||
}
|
||||
|
||||
sub prepareChange {
|
||||
my $self = shift;
|
||||
my($newData) = @_;
|
||||
$self->assert($self->validate($newData), 0, 'tried to prepare change to invalid value'); # XXX might want to provide more debugging data
|
||||
$self->newData($newData);
|
||||
$self->{newData} = $newData;
|
||||
}
|
||||
|
||||
# sets a flag so that calls to ->data and ->address will return the
|
||||
@ -168,8 +168,8 @@ sub DESTROY {
|
||||
sub write {
|
||||
my $self = shift;
|
||||
if ($self->{'_DELETE'}) {
|
||||
$self->app->getService('dataSource.user')->removeUserField($self->app, $self->userID, $self->fieldID);
|
||||
$self->{app}->getService('dataSource.user')->removeUserField($self->{app}, $self->{userID}, $self->{fieldID});
|
||||
} else {
|
||||
$self->app->getService('dataSource.user')->setUserField($self->app, $self->userID, $self->fieldID, $self->data);
|
||||
$self->{app}->getService('dataSource.user')->setUserField($self->{app}, $self->{userID}, $self->{fieldID}, $self->{data});
|
||||
}
|
||||
}
|
||||
|
||||
@ -55,19 +55,19 @@ sub get {
|
||||
if (defined($referrer)) {
|
||||
$request->referer($referrer);
|
||||
}
|
||||
if (not exists $self->{'ua'}) {
|
||||
if (not exists $self->{ua}) {
|
||||
require LWP::UserAgent; import LWP::UserAgent; # DEPENDENCY
|
||||
my $ua = LWP::UserAgent->new();
|
||||
$ua->agent($ua->agent . ' (' . $app->name . ')');
|
||||
$ua->timeout(5); # XXX HARDCODED CONSTANT ALERT
|
||||
$ua->env_proxy();
|
||||
$self->ua($ua);
|
||||
$self->{ua} = $ua;
|
||||
}
|
||||
my $response = $self->ua->request($request);
|
||||
my $response = $self->{ua}->request($request);
|
||||
if (wantarray) {
|
||||
return ($response->content, $response);
|
||||
return ($response->{content}, $response);
|
||||
} else {
|
||||
return $response->content;
|
||||
return $response->{content};
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
@ -104,7 +104,7 @@ sub reportFatalError {
|
||||
}
|
||||
|
||||
# output.hook
|
||||
sub methodMissing {
|
||||
sub implyMethod {
|
||||
my $self = shift;
|
||||
my($method, @arguments) = @_;
|
||||
# We drop 'method' on the floor, since it is assumed that an XML
|
||||
@ -125,14 +125,6 @@ sub methodMissing {
|
||||
$self->output->XMLRPC($response->as_string);
|
||||
}
|
||||
|
||||
# disable implied property access so that all method calls are routed
|
||||
# through methodMissing() above.
|
||||
sub propertyImpliedAccessAllowed {
|
||||
my $self = shift;
|
||||
my($name) = @_;
|
||||
return ($name eq 'output');
|
||||
}
|
||||
|
||||
# This is commented out because the default generic output module
|
||||
# defaults to this behaviour anyway, and we don't really want this
|
||||
# module being probed for output.generic.dispatcher stuff since it has
|
||||
|
||||
@ -15,3 +15,8 @@ Make getSettings return a boolean instead of raising an exception.
|
||||
|
||||
|
||||
Stylesheet should be a template
|
||||
|
||||
|
||||
|
||||
refactor the |die|, |warn|, |PLIF::warn|, |PLIF::error|, |PLIF::dump|
|
||||
call sites and functions so that they all go through the same system.
|
||||
|
||||
Loading…
Reference in New Issue
Block a user