use methods for generating subs in definition

lib/WebGUI/Definition.pm

@@ -24,6 +24,7 @@ use Sub::Name ();
 use Clone ();
 use mro ();
 
+# used to generate unique packages
 my $gen_package = 0;
 
 sub import {
@@ -31,13 +32,24 @@ sub import {
     if (! @_) {
         return;
     }
+
     my $definition = (@_ == 1 && ref $_[0]) ? $_[0] : { @_ };
     my $caller = caller;
-    # ensure we are using c3 method resolution
+
-    mro::set_mro($caller, 'c3');
+    # generate superclass
     $gen_package++;
     my $super = __PACKAGE__ . '::_gen' . $gen_package;
+
+    # insert generated package as superclass
+    {
+        no strict 'refs';
+        @{$super . '::ISA'} = @{$caller . '::ISA'};
+        @{$caller . '::ISA'} = ($super);
+    }
+
+    # ensure we are using c3 method resolution
     mro::set_mro($super, 'c3');
+    mro::set_mro($caller, 'c3');
 
     # construct an ordered list and hash of the properties
     my @propertyList;
@@ -53,60 +65,16 @@ sub import {
     # accessors for properties
     for my $property ( @propertyList ) {
         no strict 'refs';
-        $class->_install($super, $property, sub {
+        $class->_install($super, $property, $class->_gen_accessor($property));
-            if (@_ > 1) {
-                my $value = $_[1];
-                return $_[0]{properties}{$property} = $value;
-            }
-            else {
-                return $_[0]{properties}{$property};
-            }
-        });
     }
 
-    $class->_install($super, 'getProperty', sub {
+    $class->_install($super, 'getProperty',   $class->_gen_getProperty(\%properties));
-        my $self = shift;
+    $class->_install($super, 'getProperties', $class->_gen_getProperties(\@propertyList));
-        my $property = shift;
+    $class->_install($super, 'getAttribute',  $class->_gen_getAttribute($definition));
-        if (exists $properties{$property}) {
+    $class->_install($super, 'get',           $class->_gen_get);
-            my $subattributes = Clone::clone $properties{$property};
+    $class->_install($super, 'set',           $class->_gen_set);
-            if ( ref $self ) {
+    $class->_install($super, 'update',        $class->_gen_update);
-                for my $subattribute ( keys %{ $subattributes } ) {
+    $class->_install($super, 'instantiate',   $class->_gen_instantiate);
-                    my $attrValue = $subattributes->{$subattribute};
-                    if ( ref $attrValue && ref $attrValue eq 'CODE' ) {
-                        $subattributes->{$subattribute} = $self->$attrValue($property, $subattribute);
-                    }
-                }
-            }
-            return $subattributes;
-        }
-        return $self->maybe::next::method($property);
-    });
-
-    $class->_install($super, 'getProperties', sub {
-        my $self = shift;
-        my %props = map { $_ => 1 } @propertyList;
-        # remove any properties from superclass list that exist in this class
-        my @allProperties = grep { ! $props{$_} } $self->maybe::next::method(@_);
-        push @allProperties, @propertyList;
-        return @allProperties;
-    });
-
-    $class->_install($super, 'getAttribute', sub {
-        my $self = shift;
-        my $attribute = shift;
-        if ( exists $definition->{$attribute} ) {
-            return $definition->{$attribute};
-        }
-        return $self->maybe::next::method($attribute);
-    });
-
-    no strict 'refs';
-    *{$super . '::get'} = \&_get;
-    *{$super . '::set'} = \&_set;
-    *{$super . '::update'} = \&_update;
-    *{$super . '::instantiate'} = \&_instantiate;
-    @{$super . '::ISA'} = @{$caller . '::ISA'};
-    @{$caller . '::ISA'} = ($super);
     return;
 }
 
@@ -118,47 +86,117 @@ sub _install {
     return $sub;
 }
 
-sub _set {
+sub _gen_accessor {
-    my $self = shift;
-    my $properties = ( @_ == 1 && ref $_[0] ) ? $_[0] : { @_ };
-    my %availProperties = map { $_ => 1 } $self->getProperties;
-    for my $property ( keys %{ $properties } ) {
-        if ( $availProperties{$property} ) {
-            $self->$property( $properties->{$property} );
-        }
-    }
-}
-
-sub _get {
-    my $self = shift;
-    if (@_) {
-        my $prop = shift;
-        return $self->$prop;
-    }
-    my @all_properties = $self->getProperties;
-    my %props;
-    for my $property ( @all_properties ) {
-        $props{$property} = $self->$property;
-    }
-    return \%props;
-}
-
-sub _update {
-    my $self = shift;
-    $self->set(@_);
-    if ($self->can('write')) {
-        $self->write;
-    }
-}
-
-sub _instantiate {
     my $class = shift;
-    my $self = bless {
+    my $property = shift;
-        properties => {},
+    return sub {
-    }, $class;
+        if (@_ > 1) {
-    $self->set(@_);
+            my $value = $_[1];
-    return $self;
+            return $_[0]{properties}{$property} = $value;
-};
+        }
+        else {
+            return $_[0]{properties}{$property};
+        }
+    };
+}
+
+sub _gen_getProperty {
+    my $class = shift;
+    my $properties = shift;
+    return sub {
+        my $self = shift;
+        my $property = shift;
+        if (exists $properties->{$property}) {
+            my $subattributes = Clone::clone($properties->{$property});
+            if ( ref $self ) {
+                for my $subattribute ( keys %{ $subattributes } ) {
+                    my $attrValue = $subattributes->{$subattribute};
+                    if ( ref $attrValue && ref $attrValue eq 'CODE' ) {
+                        $subattributes->{$subattribute} = $self->$attrValue($property, $subattribute);
+                    }
+                }
+            }
+            return $subattributes;
+        }
+        return $self->maybe::next::method($property);
+    };
+}
+
+sub _gen_getProperties {
+    my $class = shift;
+    my $propertyList = shift;
+    return sub {
+        my $self = shift;
+        my %props = map { $_ => 1 } @$propertyList;
+        # remove any properties from superclass list that exist in this class
+        my @allProperties = grep { ! $props{$_} } $self->maybe::next::method(@_);
+        push @allProperties, @$propertyList;
+        return @allProperties;
+    };
+}
+
+sub _gen_getAttribute {
+    my $class = shift;
+    my $definition = shift;
+    return sub {
+        my $self = shift;
+        my $attribute = shift;
+        if ( exists $definition->{$attribute} ) {
+            return $definition->{$attribute};
+        }
+        return $self->maybe::next::method($attribute);
+    };
+}
+
+sub _gen_set {
+    return sub {
+        my $self = shift;
+        my $properties = ( @_ == 1 && ref $_[0] ) ? $_[0] : { @_ };
+        my %availProperties = map { $_ => 1 } $self->getProperties;
+        for my $property ( keys %{ $properties } ) {
+            if ( $availProperties{$property} ) {
+                $self->$property( $properties->{$property} );
+            }
+        }
+    };
+}
+
+sub _gen_get {
+    return sub {
+        my $self = shift;
+        if (@_) {
+            my $prop = shift;
+            return $self->$prop;
+        }
+        my @all_properties = $self->getProperties;
+        my %props;
+        for my $property ( @all_properties ) {
+            $props{$property} = $self->$property;
+        }
+        return \%props;
+    };
+}
+
+sub _gen_update {
+    return sub {
+        my $self = shift;
+        $self->set(@_);
+        if ($self->can('write')) {
+            $self->write;
+        }
+    };
+}
+
+sub _gen_instantiate {
+    return sub {
+        my $class = shift;
+        my $self = bless {
+            properties => {},
+        }, $class;
+        $self->set(@_);
+        return $self;
+    };
+}
 
 1;
 

t/Definition.t

@@ -45,7 +45,7 @@ my $written;
     use base qw(WGT::Class);
     use WebGUI::Definition (
         attribute2 => 'attribute 2 value',
-        properties => {
+        properties => [
             property2 => {
                 label => 'property2 label',
                 defaultValue => sub { return "dynamic value" },
@@ -53,7 +53,7 @@ my $written;
             a_property => {
                 defaultValue => 1,
             },
-        },
+        ],
     );
 
     sub write {
@@ -88,7 +88,7 @@ is_deeply [ $object->getProperties ], ['property1'],
     'class has correct properties';
 ok $called_getProperties, 'able to override getProperties';
 undef $called_getProperties;
-is_deeply [ $subclass_object->getProperties ], ['property1', 'a_property', 'property2'],
+is_deeply [ $subclass_object->getProperties ], ['property1', 'property2', 'a_property'],
     'subclass has correct properties';
 ok $called_getProperties, 'subclass uses correctly overridden getProperties';