first rev of new definition class
This commit is contained in:
Graham Knop
parent
814bde6b93
commit
34182a39ee
3 changed files with 410 additions and 0 deletions
242
lib/WebGUI/Definition.pm
Normal file
242
lib/WebGUI/Definition.pm
Normal file
|
|
@ -0,0 +1,242 @@
|
|||
package WebGUI::Definition;
|
||||
|
||||
=head1 LEGAL
|
||||
|
||||
-------------------------------------------------------------------
|
||||
WebGUI is Copyright 2001-2009 Plain Black Corporation.
|
||||
-------------------------------------------------------------------
|
||||
Please read the legal notices (docs/legal.txt) and the license
|
||||
(docs/license.txt) that came with this distribution before using
|
||||
this software.
|
||||
-------------------------------------------------------------------
|
||||
http://www.plainblack.com info@plainblack.com
|
||||
-------------------------------------------------------------------
|
||||
|
||||
=cut
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
no warnings qw(uninitialized);
|
||||
use 5.010;
|
||||
|
||||
our $VERSION = '0.0.1';
|
||||
use Sub::Name ();
|
||||
use Clone ();
|
||||
use mro ();
|
||||
|
||||
sub import {
|
||||
my $class = shift;
|
||||
if (! @_) {
|
||||
return;
|
||||
}
|
||||
my $definition = (@_ == 1 && ref $_[0]) ? $_[0] : { @_ };
|
||||
my $caller = caller;
|
||||
# ensure we are using c3 method resolution
|
||||
mro::set_mro($caller, 'c3');
|
||||
|
||||
# construct an ordered list and hash of the properties
|
||||
my @property_list;
|
||||
my %properties;
|
||||
if ( my $properties = delete $definition->{properties} ) {
|
||||
# accept a hash and alphabetize it
|
||||
if (ref $properties eq 'HASH') {
|
||||
$properties = [ map { $_ => $properties->{$_} } sort keys %{ $properties } ];
|
||||
}
|
||||
for (my $i = 0; $i < @{ $properties }; $i += 2) {
|
||||
my $property = $properties->[$i];
|
||||
push @property_list, $property;
|
||||
$properties{ $property } = $properties->[$i + 1];
|
||||
}
|
||||
}
|
||||
|
||||
# accessors for properties
|
||||
for my $property ( @property_list ) {
|
||||
no strict 'refs';
|
||||
$class->_install($caller, $property, sub {
|
||||
if (@_ > 1) {
|
||||
my $value = $_[1];
|
||||
# call _set_$property with set value and use return value for actual value
|
||||
if (my $set = $_[0]->can('_set_' . $property)) {
|
||||
$value = $_[0]->$set($value);
|
||||
}
|
||||
return $_[0]{properties}{$property} = $value;
|
||||
}
|
||||
else {
|
||||
# call _get_$property and use return
|
||||
if (my $get = $_[0]->can('_get_' . $property)) {
|
||||
return $_[0]->$get($value);
|
||||
}
|
||||
return $_[0]{properties}{$property};
|
||||
}
|
||||
});
|
||||
}
|
||||
|
||||
$class->_install($caller, 'getProperty', 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);
|
||||
});
|
||||
|
||||
$class->_install($caller, 'getProperties', sub {
|
||||
my $self = shift;
|
||||
my %props = map { $_ => 1 } @properties;
|
||||
# remove any properties from superclass list that exist in this class
|
||||
my @allProperties = grep { ! $props{$_} } $self->maybe::next::method(@_);
|
||||
push @allProperties, @properties;
|
||||
return @allProperties;
|
||||
});
|
||||
|
||||
$class->_install($caller, 'getAttribute', sub {
|
||||
my $self = shift;
|
||||
my $attribute = shift;
|
||||
if ( exists $definition->{$attribute} ) {
|
||||
return $definition->{$attribute};
|
||||
}
|
||||
return $self->maybe::next::method($attribute);
|
||||
});
|
||||
|
||||
no strict 'refs';
|
||||
*{$caller . '::get'} = \&_get;
|
||||
*{$caller . '::set'} = \&_set;
|
||||
*{$caller . '::update'} = \&_update;
|
||||
*{$caller . '::instantiate'} = \&_instantiate;
|
||||
}
|
||||
|
||||
sub _install {
|
||||
my ($class, $package, $subname, $sub) = @_;
|
||||
my $full_sub = $package . '::' . $subname;
|
||||
no strict 'refs';
|
||||
*{$full_sub} = Sub::Name::subname( $full_sub, $sub );
|
||||
return $sub;
|
||||
}
|
||||
|
||||
sub _set {
|
||||
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 {
|
||||
properties => {},
|
||||
}, $class;
|
||||
$self->set(@_);
|
||||
return $self;
|
||||
};
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
WebGUI::Definition - Define properties for a class
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
package MyClass;
|
||||
use WebGUI::Definition (
|
||||
name => 'My Class',
|
||||
properties => [
|
||||
'classProperty' => {
|
||||
label => "Class Property",
|
||||
},
|
||||
],
|
||||
);
|
||||
my $object = MyClass->instantiate;
|
||||
$object->getProperties;
|
||||
$object->getProperty('classProperty');
|
||||
$object->getAttribute('name');
|
||||
$object->classProperty('value');
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Define properties and attributes for a class.
|
||||
|
||||
All information about the class is provided as a hash to WebGUI::Definition
|
||||
by the import method. This is usually called when 'use'ing the
|
||||
module.
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
The top level values given the WebGUI::Definition are attributes. Your class will make them available using the getAttribute method. One exception to this is the 'properties' attribute. It is not available through getAttribute but instead creates its own methods.
|
||||
|
||||
=head1 PROPERTIES
|
||||
|
||||
For each property, an accessor is created using the property name.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 import
|
||||
|
||||
Defines the class.
|
||||
|
||||
=head1 METHODS CREATED
|
||||
|
||||
=head2 getAttribute ( $attribute )
|
||||
|
||||
Returns the value of the given attribute the class or any of its superclasses.
|
||||
|
||||
=head2 getProperties ( )
|
||||
|
||||
Returns a list of all of the properties for the class.
|
||||
|
||||
=head2 getProperty ( $property )
|
||||
|
||||
Returns the attributes for the given property.
|
||||
|
||||
=head2 get
|
||||
|
||||
=head2 set
|
||||
|
||||
=head2 update
|
||||
|
||||
=head2 instantiate
|
||||
|
||||
=head2 $property
|
||||
|
||||
An accessor is created for each property.
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
42
lib/WebGUI/Definition/Asset.pm
Normal file
42
lib/WebGUI/Definition/Asset.pm
Normal file
|
|
@ -0,0 +1,42 @@
|
|||
package WebGUI::Definition::Asset;
|
||||
|
||||
=head1 LEGAL
|
||||
|
||||
-------------------------------------------------------------------
|
||||
WebGUI is Copyright 2001-2009 Plain Black Corporation.
|
||||
-------------------------------------------------------------------
|
||||
Please read the legal notices (docs/legal.txt) and the license
|
||||
(docs/license.txt) that came with this distribution before using
|
||||
this software.
|
||||
-------------------------------------------------------------------
|
||||
http://www.plainblack.com info@plainblack.com
|
||||
-------------------------------------------------------------------
|
||||
|
||||
=cut
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use 5.010;
|
||||
use base qw(WebGUI::Definition);
|
||||
|
||||
our $VERSION = '0.0.1';
|
||||
|
||||
sub import {
|
||||
my $class = shift;
|
||||
if (! @_) {
|
||||
return;
|
||||
}
|
||||
my $definition = (@_ == 1 && ref $_[0]) ? $_[0] : { @_ };
|
||||
if ( my $properties = $definition->{properties} ) {
|
||||
my $table = $definition->{table_name};
|
||||
for ( my $i = 1; $i < @{ $properties }; $i += 2) {
|
||||
$propeties->[$i]{table_name} = $table;
|
||||
}
|
||||
}
|
||||
my $next = $class->next::can;
|
||||
@_ = ($class, $definition);
|
||||
goto $next;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
126
t/Definition.t
Normal file
126
t/Definition.t
Normal file
|
|
@ -0,0 +1,126 @@
|
|||
#-------------------------------------------------------------------
|
||||
# WebGUI is Copyright 2001-2009 Plain Black Corporation.
|
||||
#-------------------------------------------------------------------
|
||||
# Please read the legal notices (docs/legal.txt) and the license
|
||||
# (docs/license.txt) that came with this distribution before using
|
||||
# this software.
|
||||
#-------------------------------------------------------------------
|
||||
# http://www.plainblack.com info@plainblack.com
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
no warnings qw(uninitialized);
|
||||
|
||||
use Test::More 'no_plan'; #tests => 1;
|
||||
|
||||
{
|
||||
package WGT::Class;
|
||||
use WebGUI::Definition (
|
||||
attribute1 => 'attribute 1 value',
|
||||
properties => [
|
||||
property1 => {
|
||||
label => 'property1 label',
|
||||
defaultValue => sub { return shift },
|
||||
},
|
||||
],
|
||||
);
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $self = $class->instantiate;
|
||||
return $self;
|
||||
}
|
||||
}
|
||||
|
||||
my $written;
|
||||
{
|
||||
package WGT::SubClass;
|
||||
use base qw(WGT::Class);
|
||||
use WebGUI::Definition (
|
||||
attribute2 => 'attribute 2 value',
|
||||
properties => {
|
||||
property2 => {
|
||||
label => 'property2 label',
|
||||
defaultValue => sub { return "dynamic value" },
|
||||
},
|
||||
a_property => {
|
||||
defaultValue => 1,
|
||||
},
|
||||
},
|
||||
);
|
||||
|
||||
sub write {
|
||||
my $self = shift;
|
||||
$written = 1;
|
||||
}
|
||||
|
||||
sub _set_a_property {
|
||||
my $self = shift;
|
||||
my $value = shift;
|
||||
return "$value - BLAH";
|
||||
}
|
||||
}
|
||||
|
||||
my $object = WGT::Class->new;
|
||||
my $subclass_object = WGT::SubClass->new;
|
||||
|
||||
can_ok $object, qw(getProperties getProperty get update getAttribute instantiate property1);
|
||||
can_ok $subclass_object, qw(getProperties getProperty get update getAttribute instantiate property1 property2 a_property);
|
||||
|
||||
is $object->property1('property 1 value'), 'property 1 value',
|
||||
'property mutator returns newly set value';
|
||||
is $object->property1, 'property 1 value',
|
||||
'property accessor returns correct value';
|
||||
|
||||
is $subclass_object->property2('property 2 value'), 'property 2 value',
|
||||
'property mutator returns newly set value';
|
||||
is $subclass_object->property2, 'property 2 value',
|
||||
'property accessor returns correct value';
|
||||
|
||||
is_deeply [ $object->getProperties ], ['property1'],
|
||||
'class has correct properties';
|
||||
is_deeply [ $subclass_object->getProperties ], ['property1', 'a_property', 'property2'],
|
||||
'subclass has correct properties';
|
||||
|
||||
is_deeply $object->get, { property1 => 'property 1 value' },
|
||||
'get returns hash with correct properties';
|
||||
is_deeply $subclass_object->get, { property1 => undef, a_property => undef, property2 => 'property 2 value' },
|
||||
'get returns hash with correct properties';
|
||||
|
||||
is_deeply $object->getProperty('property1'), { label => 'property1 label', defaultValue => $object },
|
||||
'getProperty returns correct hash for object';
|
||||
is_deeply $subclass_object->getProperty('property2'), { label => 'property2 label', defaultValue => 'dynamic value' },
|
||||
'getProperty returns correct hash for subclass object';
|
||||
|
||||
is $object->getAttribute('attribute1'), 'attribute 1 value',
|
||||
'object has correct attribute';
|
||||
is $subclass_object->getAttribute('attribute1'), 'attribute 1 value',
|
||||
'subclass object has correct inherited attribute';
|
||||
is $subclass_object->getAttribute('attribute2'), 'attribute 2 value',
|
||||
'subclass object has correct own value';
|
||||
|
||||
ok eval { $object->update; 1},
|
||||
'update works when no write sub available';
|
||||
ok eval { $subclass_object->update; 1},
|
||||
'update works when write sub available';
|
||||
ok $written,
|
||||
'update calls write';
|
||||
|
||||
$object->update({ property1 => 'new value', nonproperty => 'other value' });
|
||||
|
||||
is $object->property1, 'new value', 'update sets all properties';
|
||||
|
||||
$object->property1(undef);
|
||||
|
||||
is $object->property1, undef, 'able to set undef as property value';
|
||||
|
||||
is +WGT::Class->instantiate(property1 => 'property value')->property1, 'property value',
|
||||
'instantiate sets correct values';
|
||||
|
||||
is $subclass_object->a_property('value'), 'value - BLAH', 'accessor calls custom filter if needed';
|
||||
|
||||
|
||||
#->update
|
||||
#->new
|
||||
|
||||
Loading…
Add table
Add a link
Reference in a new issue