almost working using metaclass roles

lib/WebGUI/Definition/Meta/Asset.pm

@@ -50,14 +50,10 @@ for properties.
 
 =cut
 
-sub _build_property_metaclass {
+has '+property_metaroles' => (
-    my $self = shift;
+    is => 'ro',
-    Moose::Meta::Class->create_anon_class(
+    default => sub { [ 'WebGUI::Definition::Meta::Property', 'WebGUI::Definition::Meta::Property::Asset'] },
-        superclasses => [ $self->attribute_metaclass ],
+);
-        roles        => [ 'WebGUI::Definition::Meta::Property', 'WebGUI::Definition::Meta::Property::Asset' ],
-        cache        => 1,
-    );
-}
 
 has [ qw{tableName icon assetName uiLevel} ] => (
     is       => 'rw',

lib/WebGUI/Definition/Meta/Class.pm

@@ -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()) {
+    CLASS: foreach my $class_name (reverse $self->linearized_isa) {
-        my $meta = $self->initialize($class_name);
+        my $meta = $class_name->meta;
-        next CLASS unless $meta->does('WebGUI::Definition::Meta::Class');
+        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;

lib/WebGUI/Definition/Role/Object.pm

@@ -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';

t/Definition.t

@@ -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';
 

t/Definition/Asset.t

@@ -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';
 

t/lib/WebGUI/Test.pm

@@ -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',
+            Sessions            => 'userSession',
-            Scratch   => 'userSessionScratch',
+            Scratch             => 'userSessionScratch',
-            Users     => 'users',
+            Users               => 'users',
-            Groups    => 'groups',
+            Groups              => 'groups',
-            mailQ     => 'mailQueue',
+            mailQ               => 'mailQueue',
-            Tags      => 'assetVersionTag',
+            Tags                => 'assetVersionTag',
-            Assets    => 'assetData',
+            Assets              => 'assetData',
-            Workflows => 'Workflow',
+            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 ) {
+    if ( our $SESSION ) {
-        $session->var->end;
+        $SESSION->var->end;
-        $session->close;
+        $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;
@@ -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::User'              => 'delete',
-        'WebGUI::Group' => 'delete',
+        'WebGUI::Group'             => 'delete',
-        'WebGUI::Storage' => 'delete',
+        'WebGUI::Storage'           => 'delete',
-        'WebGUI::Asset' => 'purge',
+        'WebGUI::Asset'             => 'purge',
-        'WebGUI::VersionTag' => 'rollback',
+        'WebGUI::VersionTag'        => 'rollback',
-        'WebGUI::Workflow' => 'delete',
+        'WebGUI::Workflow'          => 'delete',
-        'WebGUI::Session' => sub {
+        '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 {