almost working using metaclass roles
This commit is contained in:
Graham Knop
parent
a2f0cbe9ba
commit
12fcdf201f
6 changed files with 116 additions and 60 deletions
|
|
@ -50,14 +50,10 @@ for properties.
|
|||
|
||||
=cut
|
||||
|
||||
sub _build_property_metaclass {
|
||||
my $self = shift;
|
||||
Moose::Meta::Class->create_anon_class(
|
||||
superclasses => [ $self->attribute_metaclass ],
|
||||
roles => [ 'WebGUI::Definition::Meta::Property', 'WebGUI::Definition::Meta::Property::Asset' ],
|
||||
cache => 1,
|
||||
);
|
||||
}
|
||||
has '+property_metaroles' => (
|
||||
is => 'ro',
|
||||
default => sub { [ 'WebGUI::Definition::Meta::Property', 'WebGUI::Definition::Meta::Property::Asset'] },
|
||||
);
|
||||
|
||||
has [ qw{tableName icon assetName uiLevel} ] => (
|
||||
is => 'rw',
|
||||
|
|
|
|||
|
|
@ -54,7 +54,8 @@ sub add_property {
|
|||
Moose->throw_error("Must pass either noFormPost or label when making a property");
|
||||
}
|
||||
my %form_options;
|
||||
my $prop_meta = $self->property_metaclass;
|
||||
my $prop_meta_roles = $self->property_metaroles;
|
||||
my $prop_meta = $self->_property_metaclass;
|
||||
for my $key ( keys %options ) {
|
||||
if ( ! $prop_meta->meta->find_attribute_by_name($key) ) {
|
||||
$form_options{$key} = delete $options{$key};
|
||||
|
|
@ -63,7 +64,7 @@ sub add_property {
|
|||
$self->add_attribute(
|
||||
$name,
|
||||
is => 'rw',
|
||||
metaclass => $prop_meta,
|
||||
traits => $prop_meta_roles,
|
||||
form => \%form_options,
|
||||
%options,
|
||||
);
|
||||
|
|
@ -98,9 +99,9 @@ in the order they were created in the Definition.
|
|||
sub get_all_class_metas {
|
||||
my $self = shift;
|
||||
my @metas = ();
|
||||
CLASS: foreach my $class_name (reverse $self->linearized_isa()) {
|
||||
my $meta = $self->initialize($class_name);
|
||||
next CLASS unless $meta->does('WebGUI::Definition::Meta::Class');
|
||||
CLASS: foreach my $class_name (reverse $self->linearized_isa) {
|
||||
my $meta = $class_name->meta;
|
||||
next CLASS unless $meta->can('get_all_properties');
|
||||
push @metas, $meta;
|
||||
}
|
||||
return @metas;
|
||||
|
|
@ -193,7 +194,12 @@ Returns the name of the class for properties.
|
|||
|
||||
=cut
|
||||
|
||||
has property_metaclass => (
|
||||
has property_metaroles => (
|
||||
is => 'ro',
|
||||
default => sub { ['WebGUI::Definition::Meta::Property' ] },
|
||||
);
|
||||
|
||||
has _property_metaclass => (
|
||||
is => 'ro',
|
||||
lazy => 1,
|
||||
builder => '_build_property_metaclass',
|
||||
|
|
@ -203,7 +209,7 @@ sub _build_property_metaclass {
|
|||
my $self = shift;
|
||||
my $class = Moose::Meta::Class->create_anon_class(
|
||||
superclasses => [ $self->attribute_metaclass ],
|
||||
roles => [ 'WebGUI::Definition::Meta::Property' ],
|
||||
roles => $self->property_metaroles,
|
||||
cache => 1,
|
||||
);
|
||||
return $class;
|
||||
|
|
|
|||
|
|
@ -17,6 +17,7 @@ package WebGUI::Definition::Role::Object;
|
|||
use 5.010;
|
||||
use Moose::Role;
|
||||
use namespace::autoclean;
|
||||
use WebGUI::International;
|
||||
no warnings qw(uninitialized);
|
||||
|
||||
our $VERSION = '0.0.1';
|
||||
|
|
|
|||
|
|
@ -25,6 +25,7 @@ my $session = WebGUI::Test->session;
|
|||
my $called_getProperties;
|
||||
{
|
||||
package WGT::Class;
|
||||
use Moose;
|
||||
use WebGUI::Definition;
|
||||
|
||||
define 'define1' => 'define1 value';
|
||||
|
|
@ -58,6 +59,7 @@ my $called_getProperties;
|
|||
|
||||
{
|
||||
package WGT::Class2;
|
||||
use Moose;
|
||||
use WebGUI::Definition;
|
||||
|
||||
define 'define1' => 'define1 value';
|
||||
|
|
@ -100,6 +102,7 @@ my $called_getProperties;
|
|||
|
||||
{
|
||||
package WGT::Class3;
|
||||
use Moose;
|
||||
use WebGUI::Definition;
|
||||
|
||||
define 'define1' => 'define1 value';
|
||||
|
|
@ -116,11 +119,12 @@ my $called_getProperties;
|
|||
sub property1_options {
|
||||
return { one => 1, two => 2, three => 3 };
|
||||
}
|
||||
|
||||
sub named_url {
|
||||
my ($self, $property, $property_name) = @_;
|
||||
::note "Checking arguments passed to subroutine for defining a form property";
|
||||
::isa_ok($self, 'WGT::Class3');
|
||||
::isa_ok($property, 'WebGUI::Definition::Meta::Property');
|
||||
::ok($property->can('form'), 'Correct property class given');
|
||||
::is($property_name, 'named_url', 'form property name sent');
|
||||
return $property->name;
|
||||
}
|
||||
|
|
@ -142,6 +146,7 @@ my $called_getProperties;
|
|||
|
||||
{
|
||||
package WGT::Class4;
|
||||
use Moose;
|
||||
use WebGUI::Definition;
|
||||
extends 'WGT::Class3';
|
||||
|
||||
|
|
|
|||
|
|
@ -22,6 +22,7 @@ use WebGUI::Test;
|
|||
|
||||
{
|
||||
package WGT::Class::Atset;
|
||||
use Moose;
|
||||
use WebGUI::Definition::Asset;
|
||||
|
||||
define tableName => 'asset';
|
||||
|
|
@ -42,6 +43,7 @@ use WebGUI::Test;
|
|||
|
||||
{
|
||||
package WGT::Class::Asset;
|
||||
use Moose;
|
||||
use WebGUI::Definition::Asset;
|
||||
|
||||
define tableName => 'asset';
|
||||
|
|
@ -136,6 +138,7 @@ use WebGUI::Test;
|
|||
{
|
||||
|
||||
package WGT::Class::AlsoAsset;
|
||||
use Moose;
|
||||
use WebGUI::Definition::Asset;
|
||||
|
||||
define tableName => 'asset';
|
||||
|
|
@ -153,6 +156,7 @@ use WebGUI::Test;
|
|||
);
|
||||
|
||||
package WGT::Class::Asset::Snippet;
|
||||
use Moose;
|
||||
use WebGUI::Definition::Asset;
|
||||
extends 'WGT::Class::AlsoAsset';
|
||||
|
||||
|
|
@ -208,6 +212,7 @@ use WebGUI::Test;
|
|||
{
|
||||
|
||||
package WGT::Class::Asset::NotherOne;
|
||||
use Moose;
|
||||
use WebGUI::Definition::Asset;
|
||||
extends 'WGT::Class::AlsoAsset';
|
||||
|
||||
|
|
@ -234,6 +239,7 @@ use WebGUI::Test;
|
|||
{
|
||||
|
||||
package WGT::Class::Asset::Tertiary;
|
||||
use Moose;
|
||||
use WebGUI::Definition::Asset;
|
||||
extends 'WGT::Class::AlsoAsset';
|
||||
|
||||
|
|
|
|||
|
|
@ -26,25 +26,6 @@ use strict;
|
|||
use warnings;
|
||||
use base qw(Test::Builder::Module);
|
||||
|
||||
BEGIN {
|
||||
# http://thread.gmane.org/gmane.comp.apache.apreq/3378
|
||||
# http://article.gmane.org/gmane.comp.apache.apreq/3388
|
||||
if ( $^O eq 'darwin' && $Config::Config{osvers} lt '8.0.0' ) {
|
||||
unshift @INC, sub {
|
||||
return undef unless $_[1] =~ m/^Apache2|APR/;
|
||||
return IO::File->new( $INC{'Class/Null.pm'}, &IO::File::O_RDONLY );
|
||||
#my $buffer = '1';
|
||||
#open my $fh, '<', \$buffer;
|
||||
#return $fh;
|
||||
};
|
||||
|
||||
no warnings 'redefine';
|
||||
*Apache2::Const::OK = sub () { 0 };
|
||||
*Apache2::Const::DECLINED = sub () { -1 };
|
||||
*Apache2::Const::NOT_FOUND = sub () { 404 };
|
||||
}
|
||||
}
|
||||
|
||||
use Test::MockObject;
|
||||
use Test::MockObject::Extends;
|
||||
use Clone qw(clone);
|
||||
|
|
@ -117,15 +98,23 @@ sub import {
|
|||
});
|
||||
|
||||
if ($ENV{WEBGUI_TEST_DEBUG}) {
|
||||
##Offset Sessions, and Scratch by 1 because 1 will exist at the start
|
||||
my @checkCount = (
|
||||
Sessions => 'userSession',
|
||||
Scratch => 'userSessionScratch',
|
||||
Users => 'users',
|
||||
Groups => 'groups',
|
||||
mailQ => 'mailQueue',
|
||||
Tags => 'assetVersionTag',
|
||||
Assets => 'assetData',
|
||||
Workflows => 'Workflow',
|
||||
Sessions => 'userSession',
|
||||
Scratch => 'userSessionScratch',
|
||||
Users => 'users',
|
||||
Groups => 'groups',
|
||||
mailQ => 'mailQueue',
|
||||
Tags => 'assetVersionTag',
|
||||
Assets => 'assetData',
|
||||
Workflows => 'Workflow',
|
||||
Carts => 'cart',
|
||||
Transactions => 'transaction',
|
||||
'Transaction Items' => 'transactionItem',
|
||||
'Ship Drivers' => 'shipper',
|
||||
'Payment Drivers' => 'paymentGateway',
|
||||
'Database Links' => 'databaseLink',
|
||||
'LDAP Links' => 'ldapLink',
|
||||
);
|
||||
my %initCounts;
|
||||
for ( my $i = 0; $i < @checkCount; $i += 2) {
|
||||
|
|
@ -136,7 +125,10 @@ sub import {
|
|||
for ( my $i = 0; $i < @checkCount; $i += 2) {
|
||||
my ($label, $table) = @checkCount[$i, $i+1];
|
||||
my $quant = $session->db->quickScalar('SELECT COUNT(*) FROM ' . $table);
|
||||
$CLASS->builder->diag(sprintf '%-10s: %4d (delta %+d)', $label, $quant, ($quant - $initCounts{$table}));
|
||||
my $delta = $quant - $initCounts{$table};
|
||||
if ($delta) {
|
||||
$CLASS->builder->diag(sprintf '%-10s: %4d (delta %+d)', $label, $quant, $delta);
|
||||
}
|
||||
}
|
||||
});
|
||||
}
|
||||
|
|
@ -154,12 +146,15 @@ sub cleanup {
|
|||
pop @guarded
|
||||
while @guarded;
|
||||
|
||||
if ( my $session = $CLASS->session ) {
|
||||
$session->var->end;
|
||||
$session->close;
|
||||
if ( our $SESSION ) {
|
||||
$SESSION->var->end;
|
||||
$SESSION->close;
|
||||
undef $SESSION;
|
||||
}
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 newSession ( $noCleanup )
|
||||
|
||||
Builds a WebGUI session object for testing.
|
||||
|
|
@ -170,8 +165,6 @@ If true, the session won't be registered for automatic deletion.
|
|||
|
||||
=cut
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
sub newSession {
|
||||
my $noCleanup = shift;
|
||||
my $pseudoRequest = WebGUI::PseudoRequest->new;
|
||||
|
|
@ -184,6 +177,8 @@ sub newSession {
|
|||
}
|
||||
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 mockAssetId ( $assetId, $object )
|
||||
|
||||
Causes WebGUI::Asset->new* initializers to return the specified
|
||||
|
|
@ -401,7 +396,8 @@ sub getPage {
|
|||
my $oldRequest = $session->request;
|
||||
my $request = WebGUI::PseudoRequest->new;
|
||||
$request->setup_param($optionsRef->{formParams});
|
||||
$session->{_request} = $request;
|
||||
local $session->{_request} = $request;
|
||||
local $session->output->{_handle};
|
||||
|
||||
# Fill the buffer
|
||||
my $returnedContent;
|
||||
|
|
@ -414,7 +410,7 @@ sub getPage {
|
|||
else {
|
||||
# Try using it as a subroutine
|
||||
no strict 'refs';
|
||||
$returnedContent = $actor->(@{$optionsRef->{args}});
|
||||
$returnedContent = $actor->(@{$optionsRef->{args}});
|
||||
}
|
||||
|
||||
if ($returnedContent && $returnedContent ne "chunked") {
|
||||
|
|
@ -423,10 +419,9 @@ sub getPage {
|
|||
|
||||
# Restore the former user and request
|
||||
$session->user({ user => $oldUser });
|
||||
$session->{_request} = $oldRequest;
|
||||
|
||||
# Return the page's output
|
||||
my $return = $request->get_output;
|
||||
return $request->get_output;
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
|
@ -504,6 +499,27 @@ sub webguiBirthday {
|
|||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 getSmokeLDAPProps ( )
|
||||
|
||||
Returns a hashref of properties for connecting to smoke's LDAP server.
|
||||
|
||||
=cut
|
||||
|
||||
sub getSmokeLDAPProps {
|
||||
my $ldapProps = {
|
||||
ldapLinkName => "Test LDAP Link",
|
||||
ldapUrl => "ldaps://smoke.plainblack.com/o=shawshank", # Always test ldaps
|
||||
connectDn => "cn=Warden,o=shawshank",
|
||||
identifier => "gooey",
|
||||
ldapUserRDN => "dn",
|
||||
ldapIdentity => "uid",
|
||||
ldapLinkId => sprintf( '%022s', "testlink" ),
|
||||
};
|
||||
return $ldapProps;
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 prepareMailServer ( )
|
||||
|
||||
Prepare a Net::SMTP::Server to use for testing mail.
|
||||
|
|
@ -775,6 +791,12 @@ were passed in. Currently able to destroy:
|
|||
WebGUI::User
|
||||
WebGUI::VersionTag
|
||||
WebGUI::Workflow
|
||||
WebGUI::Shop::Cart
|
||||
WebGUI::Shop::ShipDriver
|
||||
WebGUI::Shop::PayDriver
|
||||
WebGUI::Shop::Transaction
|
||||
WebGUI::DatabaseLink
|
||||
WebGUI::LDAPLink
|
||||
|
||||
Example call:
|
||||
|
||||
|
|
@ -806,6 +828,7 @@ Example call:
|
|||
'WebGUI::Group' => sub {
|
||||
WebGUI::Group->new($CLASS->session, shift->getId);
|
||||
},
|
||||
'WebGUI::Session' => 'duplicate',
|
||||
);
|
||||
|
||||
my %check = (
|
||||
|
|
@ -815,6 +838,11 @@ Example call:
|
|||
die "Refusing to clean up vital user @{[ $user->username ]}!\n"
|
||||
if any { $userId eq $_ } (1, 3);
|
||||
},
|
||||
'WebGUI::DatabaseLink' => sub {
|
||||
my $db_link = shift;
|
||||
die "Refusing to clean up database link @{[ $db_link->get('title') ]}!\n"
|
||||
if $db_link->getId eq '0';
|
||||
},
|
||||
'WebGUI::Group' => sub {
|
||||
my $group = shift;
|
||||
die "Refusing to clean up vital group @{[ $group->name ]}!\n"
|
||||
|
|
@ -842,17 +870,31 @@ Example call:
|
|||
);
|
||||
|
||||
my %cleanup = (
|
||||
'WebGUI::User' => 'delete',
|
||||
'WebGUI::Group' => 'delete',
|
||||
'WebGUI::Storage' => 'delete',
|
||||
'WebGUI::Asset' => 'purge',
|
||||
'WebGUI::VersionTag' => 'rollback',
|
||||
'WebGUI::Workflow' => 'delete',
|
||||
'WebGUI::Session' => sub {
|
||||
'WebGUI::User' => 'delete',
|
||||
'WebGUI::Group' => 'delete',
|
||||
'WebGUI::Storage' => 'delete',
|
||||
'WebGUI::Asset' => 'purge',
|
||||
'WebGUI::VersionTag' => 'rollback',
|
||||
'WebGUI::Workflow' => 'delete',
|
||||
'WebGUI::DatabaseLink' => 'delete',
|
||||
'WebGUI::Shop::Transaction' => 'delete',
|
||||
'WebGUI::Shop::ShipDriver' => 'delete',
|
||||
'WebGUI::Shop::PayDriver' => 'delete',
|
||||
'WebGUI::Shop::Cart' => sub {
|
||||
my $cart = shift;
|
||||
my $addressBook = $cart->getAddressBook();
|
||||
$addressBook->delete if $addressBook; ##Should we call cleanupGuard instead???
|
||||
$cart->delete;
|
||||
},
|
||||
'WebGUI::Session' => sub {
|
||||
my $session = shift;
|
||||
$session->var->end;
|
||||
$session->close;
|
||||
},
|
||||
'WebGUI::LDAPLink' => sub {
|
||||
my $link = shift;
|
||||
$link->session->db->write("delete from ldapLink where ldapLinkId=?", [$link->{ldapLinkId}]);
|
||||
},
|
||||
);
|
||||
|
||||
sub cleanupGuard {
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue