Merge branch 'moose-definition' into static_definition. Moved Asset.pm over to the new Definition.
This commit is contained in:
Colin Kuskie
commit
ed0eeb9bc5
22 changed files with 2426 additions and 651 deletions
|
|
@ -39,166 +39,160 @@ use WebGUI::ProgressBar;
|
|||
use WebGUI::Search::Index;
|
||||
use WebGUI::TabForm;
|
||||
use WebGUI::Utility;
|
||||
use WebGUI::Definition::Asset (
|
||||
properties => [
|
||||
title=>{
|
||||
tab =>"properties",
|
||||
label =>['99','Asset'],
|
||||
hoverHelp =>['99 description','Asset'],
|
||||
fieldType =>'text',
|
||||
defaultValue =>'Untitled',
|
||||
},
|
||||
menuTitle=>{
|
||||
tab =>"properties",
|
||||
label =>['411','Asset'],
|
||||
hoverHelp =>['411 description','Asset'],
|
||||
uiLevel =>1,
|
||||
fieldType =>'text',
|
||||
defaultValue =>'Untitled',
|
||||
},
|
||||
url=>{
|
||||
tab =>"properties",
|
||||
label =>['104','Asset'],
|
||||
hoverHelp =>['104 description','Asset'],
|
||||
uiLevel =>3,
|
||||
fieldType =>'text',
|
||||
defaultValue => sub { return $_[0]->getId; },
|
||||
},
|
||||
isHidden=>{
|
||||
tab =>"display",
|
||||
label =>['886','Asset'],
|
||||
hoverHelp =>['886 description','Asset'],
|
||||
uiLevel =>6,
|
||||
fieldType =>'yesNo',
|
||||
defaultValue =>0,
|
||||
},
|
||||
newWindow=>{
|
||||
tab =>"display",
|
||||
label =>['940','Asset'],
|
||||
hoverHelp =>['940 description','Asset'],
|
||||
uiLevel =>9,
|
||||
fieldType =>'yesNo',
|
||||
defaultValue =>0,
|
||||
},
|
||||
encryptPage=>{
|
||||
fieldType => 'yesNo',
|
||||
noFormPost => sub { return $_[0]->session->config->get("sslEnabled"); },
|
||||
tab => "security",
|
||||
label => ['encrypt page','Asset'],
|
||||
hoverHelp => ['encrypt page description','Asset'],
|
||||
uiLevel => 6,
|
||||
defaultValue => 0,
|
||||
},
|
||||
ownerUserId=>{
|
||||
tab =>"security",
|
||||
label =>['108','Asset'],
|
||||
hoverHelp =>['108 description','Asset'],
|
||||
uiLevel =>6,
|
||||
fieldType =>'user',
|
||||
defaultValue =>'3',
|
||||
},
|
||||
groupIdView=>{
|
||||
tab =>"security",
|
||||
label =>['872','Asset'],
|
||||
hoverHelp =>['872 description','Asset'],
|
||||
uiLevel =>6,
|
||||
fieldType =>'group',
|
||||
defaultValue =>'7',
|
||||
},
|
||||
groupIdEdit=>{
|
||||
tab =>"security",
|
||||
label =>['871','Asset'],
|
||||
excludeGroups =>[1,7],
|
||||
hoverHelp =>['871 description','Asset'],
|
||||
uiLevel =>6,
|
||||
fieldType =>'group',
|
||||
defaultValue =>'4',
|
||||
},
|
||||
synopsis=>{
|
||||
tab =>"meta",
|
||||
label =>['412','Asset'],
|
||||
hoverHelp =>['412 description','Asset'],
|
||||
uiLevel =>3,
|
||||
fieldType =>'textarea',
|
||||
defaultValue =>undef,
|
||||
},
|
||||
extraHeadTags=>{
|
||||
tab =>"meta",
|
||||
label =>["extra head tags",'Asset'],
|
||||
hoverHelp =>['extra head tags description','Asset'],
|
||||
uiLevel =>5,
|
||||
fieldType =>'codearea',
|
||||
defaultValue =>undef,
|
||||
customDrawMethod=> 'drawExtraHeadTags',
|
||||
},
|
||||
extraHeadTagsPacked => {
|
||||
fieldType => 'hidden',
|
||||
defaultValue => undef,
|
||||
noFormPost => 1,
|
||||
},
|
||||
usePackedHeadTags => {
|
||||
tab => "meta",
|
||||
label => ['usePackedHeadTags label','Asset'],
|
||||
hoverHelp => ['usePackedHeadTags description','Asset'],
|
||||
uiLevel => 7,
|
||||
fieldType => 'yesNo',
|
||||
defaultValue => 0,
|
||||
},
|
||||
isPackage=>{
|
||||
label =>["make package",'Asset'],
|
||||
tab =>"meta",
|
||||
hoverHelp =>['make package description','Asset'],
|
||||
uiLevel =>7,
|
||||
fieldType =>'yesNo',
|
||||
defaultValue =>0,
|
||||
},
|
||||
isPrototype=>{
|
||||
tab =>"meta",
|
||||
label =>["make prototype",'Asset'],
|
||||
hoverHelp =>['make prototype description','Asset'],
|
||||
uiLevel =>9,
|
||||
fieldType =>'yesNo',
|
||||
defaultValue =>0,
|
||||
},
|
||||
isExportable=>{
|
||||
tab =>'meta',
|
||||
label =>['make asset exportable','Asset'],
|
||||
hoverHelp =>['make asset exportable description','Asset'],
|
||||
uiLevel =>9,
|
||||
fieldType =>'yesNo',
|
||||
defaultValue =>1,
|
||||
},
|
||||
inheritUrlFromParent=>{
|
||||
tab =>'meta',
|
||||
label =>['does asset inherit URL from parent','Asset'],
|
||||
hoverHelp =>['does asset inherit URL from parent description','Asset'],
|
||||
uiLevel =>9,
|
||||
fieldType =>'yesNo',
|
||||
defaultValue =>0,
|
||||
},
|
||||
status=>{
|
||||
noFormPost =>1,
|
||||
fieldType =>'text',
|
||||
defaultValue =>'pending',
|
||||
},
|
||||
lastModified=>{
|
||||
noFormPost =>1,
|
||||
fieldType =>'DateTime',
|
||||
defaultValue => sub { return time() },
|
||||
},
|
||||
assetSize=>{
|
||||
noFormPost =>1,
|
||||
fieldType =>'integer',
|
||||
defaultValue =>0,
|
||||
},
|
||||
],
|
||||
assetName =>'asset',
|
||||
tableName =>'assetData',
|
||||
className =>'WebGUI::Asset',
|
||||
icon =>'assets.gif',
|
||||
);
|
||||
|
||||
|
||||
use WebGUI::Definition::Asset;
|
||||
attribute assetName => 'asset',
|
||||
attribute tableName => 'assetData',
|
||||
attribute icon => 'assets.gif',
|
||||
property title => (
|
||||
tab => "properties",
|
||||
label => ['99','Asset'],
|
||||
hoverHelp => ['99 description','Asset'],
|
||||
fieldType => 'text',
|
||||
defaultValue => 'Untitled',
|
||||
);
|
||||
property menuTitle => (
|
||||
tab => "properties",
|
||||
label => ['411','Asset'],
|
||||
hoverHelp => ['411 description','Asset'],
|
||||
uiLevel => 1,
|
||||
fieldType => 'text',
|
||||
defaultValue => 'Untitled',
|
||||
);
|
||||
property url => (
|
||||
tab => "properties",
|
||||
label => ['104','Asset'],
|
||||
hoverHelp => ['104 description','Asset'],
|
||||
uiLevel => 3,
|
||||
fieldType => 'text',
|
||||
defaultValue => sub { return $_[0]->getId; },
|
||||
);
|
||||
property isHidden => (
|
||||
tab =>"display",
|
||||
label =>['886','Asset'],
|
||||
hoverHelp =>['886 description','Asset'],
|
||||
uiLevel =>6,
|
||||
fieldType =>'yesNo',
|
||||
defaultValue =>0,
|
||||
);
|
||||
property newWindow => (
|
||||
tab =>"display",
|
||||
label =>['940','Asset'],
|
||||
hoverHelp =>['940 description','Asset'],
|
||||
uiLevel =>9,
|
||||
fieldType =>'yesNo',
|
||||
defaultValue =>0,
|
||||
);
|
||||
property encryptPage => (
|
||||
fieldType => 'yesNo',
|
||||
noFormPost => sub { return $_[0]->session->config->get("sslEnabled"); },
|
||||
tab => "security",
|
||||
label => ['encrypt page','Asset'],
|
||||
hoverHelp => ['encrypt page description','Asset'],
|
||||
uiLevel => 6,
|
||||
defaultValue => 0,
|
||||
);
|
||||
property ownerUserId => (
|
||||
tab => "security",
|
||||
label => ['108','Asset'],
|
||||
hoverHelp => ['108 description','Asset'],
|
||||
uiLevel => 6,
|
||||
fieldType => 'user',
|
||||
defaultValue => '3',
|
||||
);
|
||||
property groupIdView => (
|
||||
tab => "security",
|
||||
label => ['872','Asset'],
|
||||
hoverHelp => ['872 description','Asset'],
|
||||
uiLevel => 6,
|
||||
fieldType => 'group',
|
||||
defaultValue => '7',
|
||||
);
|
||||
property groupIdEdit => (
|
||||
tab => "security",
|
||||
label => ['871','Asset'],
|
||||
excludeGroups => [1,7],
|
||||
hoverHelp => ['871 description','Asset'],
|
||||
uiLevel => 6,
|
||||
fieldType => 'group',
|
||||
defaultValue => '4',
|
||||
);
|
||||
property synopsis => (
|
||||
tab => "meta",
|
||||
label => ['412','Asset'],
|
||||
hoverHelp => ['412 description','Asset'],
|
||||
uiLevel => 3,
|
||||
fieldType => 'textarea',
|
||||
defaultValue => undef,
|
||||
);
|
||||
property extraHeadTags => (
|
||||
tab => "meta",
|
||||
label => ["extra head tags",'Asset'],
|
||||
hoverHelp => ['extra head tags description','Asset'],
|
||||
uiLevel => 5,
|
||||
fieldType => 'codearea',
|
||||
defaultValue => undef,
|
||||
customDrawMethod=> 'drawExtraHeadTags',
|
||||
);
|
||||
property extraHeadTagsPacked => (
|
||||
fieldType => 'hidden',
|
||||
defaultValue => undef,
|
||||
noFormPost => 1,
|
||||
);
|
||||
property usePackedHeadTags => (
|
||||
tab => "meta",
|
||||
label => ['usePackedHeadTags label','Asset'],
|
||||
hoverHelp => ['usePackedHeadTags description','Asset'],
|
||||
uiLevel => 7,
|
||||
fieldType => 'yesNo',
|
||||
defaultValue => 0,
|
||||
);
|
||||
property isPackage => (
|
||||
label => ["make package",'Asset'],
|
||||
tab => "meta",
|
||||
hoverHelp => ['make package description','Asset'],
|
||||
uiLevel => 7,
|
||||
fieldType => 'yesNo',
|
||||
defaultValue => 0,
|
||||
);
|
||||
property isPrototype => (
|
||||
tab => "meta",
|
||||
label => ["make prototype",'Asset'],
|
||||
hoverHelp => ['make prototype description','Asset'],
|
||||
uiLevel => 9,
|
||||
fieldType => 'yesNo',
|
||||
defaultValue => 0,
|
||||
);
|
||||
property isExportable => (
|
||||
tab => 'meta',
|
||||
label => ['make asset exportable','Asset'],
|
||||
hoverHelp => ['make asset exportable description','Asset'],
|
||||
uiLevel => 9,
|
||||
fieldType => 'yesNo',
|
||||
defaultValue => 1,
|
||||
);
|
||||
property inheritUrlFromParent => (
|
||||
tab => 'meta',
|
||||
label => ['does asset inherit URL from parent','Asset'],
|
||||
hoverHelp => ['does asset inherit URL from parent description','Asset'],
|
||||
uiLevel => 9,
|
||||
fieldType => 'yesNo',
|
||||
defaultValue => 0,
|
||||
);
|
||||
property status => (
|
||||
noFormPost =>1,
|
||||
fieldType =>'text',
|
||||
defaultValue =>'pending',
|
||||
);
|
||||
property lastModified => (
|
||||
noFormPost => 1,
|
||||
fieldType => 'DateTime',
|
||||
defaultValue => sub { return time() },
|
||||
);
|
||||
property assetSize => (
|
||||
noFormPost => 1,
|
||||
fieldType => 'integer',
|
||||
defaultValue => 0,
|
||||
);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
|
|
|
|||
|
|
@ -226,19 +226,6 @@ sub get {
|
|||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 flush ( )
|
||||
|
||||
Flushes the caching system. Must be overridden.
|
||||
|
||||
=cut
|
||||
|
||||
sub flush {
|
||||
my $self = shift;
|
||||
File::Path::rmtree($self->session->config->get("uploadsPath")."/temp");
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 mget ( names )
|
||||
|
||||
Retrieves multiple values from cache at once, which is much faster than retrieving one at a time. Returns an array reference containing the values in the order they were requested.
|
||||
|
|
|
|||
|
|
@ -14,301 +14,148 @@ package WebGUI::Definition;
|
|||
|
||||
=cut
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
no warnings qw(uninitialized);
|
||||
use 5.010;
|
||||
use Moose;
|
||||
use Moose::Exporter;
|
||||
use namespace::autoclean;
|
||||
use WebGUI::Definition::Meta::Class;
|
||||
use WebGUI::Definition::Meta::Property;
|
||||
no warnings qw(uninitialized);
|
||||
|
||||
our $VERSION = '0.0.1';
|
||||
use Sub::Name ();
|
||||
use Clone ();
|
||||
use mro ();
|
||||
|
||||
# used to generate unique packages
|
||||
my $gen_package = 0;
|
||||
|
||||
sub import {
|
||||
my $class = shift;
|
||||
if (! @_) {
|
||||
return;
|
||||
}
|
||||
|
||||
my $definition = (@_ == 1 && ref $_[0]) ? $_[0] : { @_ };
|
||||
my $caller = caller;
|
||||
|
||||
# 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');
|
||||
$class->_build($super, $caller, $definition);
|
||||
return;
|
||||
}
|
||||
|
||||
sub _build {
|
||||
my ($class, $super, $caller, $definition) = @_;
|
||||
|
||||
# construct an ordered list and hash of the properties
|
||||
my @propertyList;
|
||||
my %properties;
|
||||
if ( my $properties = delete $definition->{properties} ) {
|
||||
for (my $i = 0; $i < @{ $properties }; $i += 2) {
|
||||
my $property = $properties->[$i];
|
||||
push @propertyList, $property;
|
||||
$properties{ $property } = $properties->[$i + 1];
|
||||
}
|
||||
}
|
||||
|
||||
# accessors for properties
|
||||
for my $property ( @propertyList ) {
|
||||
no strict 'refs';
|
||||
$class->_install($super, $property, $class->_gen_accessor($property));
|
||||
}
|
||||
|
||||
$class->_install($super, 'getProperty', $class->_gen_getProperty(\%properties));
|
||||
$class->_install($super, 'getProperties', $class->_gen_getProperties(\@propertyList));
|
||||
$class->_install($super, 'getAttribute', $class->_gen_getAttribute($definition));
|
||||
$class->_install($super, 'get', $class->_gen_get);
|
||||
$class->_install($super, 'set', $class->_gen_set);
|
||||
$class->_install($super, 'update', $class->_gen_update);
|
||||
$class->_install($super, 'instantiate', $class->_gen_instantiate);
|
||||
return;
|
||||
}
|
||||
|
||||
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 _gen_accessor {
|
||||
my $class = shift;
|
||||
my $property = shift;
|
||||
return sub {
|
||||
if (@_ > 1) {
|
||||
my $value = $_[1];
|
||||
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;
|
||||
if ($self->can($prop)) {
|
||||
return $self->$prop;
|
||||
}
|
||||
return undef;
|
||||
}
|
||||
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;
|
||||
|
||||
__END__
|
||||
|
||||
=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
|
||||
-------------------------------------------------------------------
|
||||
|
||||
=head1 NAME
|
||||
|
||||
WebGUI::Definition - Define properties for a class
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
package MyClass;
|
||||
use WebGUI::Definition (
|
||||
name => 'My Class',
|
||||
properties => [
|
||||
'myProperty' => {
|
||||
label => "Class Property",
|
||||
},
|
||||
],
|
||||
);
|
||||
my $object = MyClass->instantiate;
|
||||
|
||||
# property list
|
||||
$object->getProperties;
|
||||
|
||||
# property attributes
|
||||
$object->getProperty('myProperty');
|
||||
|
||||
# attribute value
|
||||
$object->getAttribute('name');
|
||||
|
||||
# generated accessor
|
||||
$object->myProperty('value');
|
||||
Package WebGUI::Definition
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Define properties and attributes for a class.
|
||||
Moose-based meta class for all definitions in WebGUI.
|
||||
|
||||
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 SYNOPSIS
|
||||
|
||||
=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.
|
||||
A definition contains all the information needed to build an object.
|
||||
Information required to build forms are added as optional roles and
|
||||
sub metaclasses. Database persistance is handled similarly.
|
||||
|
||||
=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 ( [ $property ] )
|
||||
|
||||
Retrieves the value of the given property. If no property is
|
||||
specified, returns all of the properties as a hash reference.
|
||||
|
||||
=head2 set ( $properties )
|
||||
|
||||
Accepts a hash reference and sets all of the given properties.
|
||||
|
||||
=head2 update ( $properties )
|
||||
|
||||
Sets properties just as L</set> does, then calls the C<write> method if it is available in the class.
|
||||
|
||||
=head2 instantiate ( $properties )
|
||||
|
||||
Creates a new object instance, setting the given properties.
|
||||
|
||||
=head2 $property
|
||||
|
||||
An accessor is created for each property.
|
||||
These methods are available from this class:
|
||||
|
||||
=cut
|
||||
|
||||
my ($import, $unimport, $init_meta) = Moose::Exporter->build_import_methods(
|
||||
install => [ 'unimport' ],
|
||||
with_meta => [ 'property', 'attribute' ],
|
||||
also => 'Moose',
|
||||
);
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 import ( )
|
||||
|
||||
A custom import method is provided so that uninitialized properties do not
|
||||
generate warnings.
|
||||
|
||||
=cut
|
||||
|
||||
sub import {
|
||||
my $class = shift;
|
||||
my $caller = caller;
|
||||
$class->$import({ into_level => 1 });
|
||||
warnings->unimport('uninitialized');
|
||||
namespace::autoclean->import( -cleanee => $caller );
|
||||
return 1;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 init_meta ( )
|
||||
|
||||
Sets the metaclass to WebGUI::Definition::Meta::Class.
|
||||
|
||||
=cut
|
||||
|
||||
sub init_meta {
|
||||
my $class = shift;
|
||||
my %options = @_;
|
||||
$options{metaclass} //= 'WebGUI::Definition::Meta::Class';
|
||||
my $meta = Moose->init_meta(%options);
|
||||
Moose::Util::apply_all_roles($meta, 'WebGUI::Definition::Role::Object');
|
||||
return $meta;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 attribute ( )
|
||||
|
||||
An attribute of the definition is typically static data which is never processed from a form
|
||||
or persisted to the database. In an Asset-style definition, an attribute would
|
||||
be the table name, the asset's name, or the path to the asset's icon.
|
||||
|
||||
=cut
|
||||
|
||||
sub attribute {
|
||||
my ($meta, $name, $value) = @_;
|
||||
if ($meta->can($name)) {
|
||||
$meta->$name($value);
|
||||
$meta->add_method( $name, sub { $meta->$name } );
|
||||
}
|
||||
else {
|
||||
$meta->add_method( $name, sub { $value } );
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 property ( $name, %options )
|
||||
|
||||
A property is a special object attribute with it's type constraints set by
|
||||
HTML form properties, such as base type (Text, Integer, Float, SelectList),
|
||||
default value, value, etc.
|
||||
|
||||
=head3 $name
|
||||
|
||||
The name of the property.
|
||||
|
||||
=head3 %options
|
||||
|
||||
An options hashref [need list of base options]. Any option which belongs to a form
|
||||
is relegated to the form attribute of the property and removed from the list of
|
||||
regular attributes.
|
||||
|
||||
=head4 fieldType
|
||||
|
||||
The type of field to be created by the form builder. This is required, and should be the name of
|
||||
a WebGUI::Form plugin, with the initial letter lowercased.
|
||||
|
||||
=head4 noFormPost, label
|
||||
|
||||
Either or both of these must be passed in.
|
||||
|
||||
=cut
|
||||
|
||||
sub property {
|
||||
my ($meta, $name, %options) = @_;
|
||||
if (! (exists $options{noFormPost} || exists $options{label}) ) {
|
||||
Moose->throw_error("Must pass either noFormPost or label when making a property");
|
||||
}
|
||||
my %form_options;
|
||||
my $prop_meta = $meta->property_meta;
|
||||
for my $key ( keys %options ) {
|
||||
if ( ! $prop_meta->meta->find_attribute_by_name($key) ) {
|
||||
$form_options{$key} = delete $options{$key};
|
||||
}
|
||||
}
|
||||
$meta->add_attribute(
|
||||
$name,
|
||||
is => 'rw',
|
||||
metaclass => $prop_meta,
|
||||
form => \%form_options,
|
||||
%options,
|
||||
);
|
||||
return 1;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -14,127 +14,78 @@ package WebGUI::Definition::Asset;
|
|||
|
||||
=cut
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use 5.010;
|
||||
use base qw(WebGUI::Definition);
|
||||
|
||||
use WebGUI::International;
|
||||
use WebGUI::Exception;
|
||||
use Moose;
|
||||
use Moose::Exporter;
|
||||
use WebGUI::Definition ();
|
||||
use WebGUI::Definition::Meta::Asset;
|
||||
use namespace::autoclean;
|
||||
no warnings qw(uninitialized);
|
||||
|
||||
our $VERSION = '0.0.1';
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
sub import {
|
||||
my $class = shift;
|
||||
if (! @_) {
|
||||
return;
|
||||
}
|
||||
my $definition = (@_ == 1 && ref $_[0]) ? $_[0] : { @_ };
|
||||
|
||||
my $table = $definition->{tableName}
|
||||
|| WebGUI::Error::InvalidParam->throw(param => 'tableName');
|
||||
|
||||
if ( my $properties = $definition->{properties} ) {
|
||||
for ( my $i = 0; $i < $#{ $properties }; $i += 2) {
|
||||
my ($name, $value) = @{ $properties }[$i, $i + 1];
|
||||
$value->{tableName} ||= $table;
|
||||
if ( ! $value->{tableName}|| ref $value->{tableName}) {
|
||||
WebGUI::Error::InvalidParam->throw(param => 'tableName');
|
||||
}
|
||||
elsif ( ! $value->{fieldType} || ref $value->{fieldType}) {
|
||||
WebGUI::Error::InvalidParam->throw(param => 'fieldType');
|
||||
}
|
||||
elsif ( ( ! $value->{noFormPost} || ref $value->{noFormPost} ) && ! $value->{label}) {
|
||||
WebGUI::Error::InvalidParam->throw(param => 'label');
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# WebGUI::Definition->import uses caller, so avoid the extra entry in the call stack
|
||||
my $next = $class->next::can;
|
||||
@_ = ($class, $definition);
|
||||
goto $next;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
sub _build {
|
||||
my ($class, $super, $caller, $definition) = @_;
|
||||
$class->next::method($super, $caller, $definition);
|
||||
$class->_install($super, 'getTables', $class->_gen_getTables());
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
sub _gen_getTables {
|
||||
my $class = shift;
|
||||
return sub {
|
||||
my $self = shift;
|
||||
my %found;
|
||||
my @tables;
|
||||
foreach my $property ($self->getProperties) {
|
||||
my $definition = $self->getProperty($property);
|
||||
unless ($found{$definition->{tableName}}) {
|
||||
push @tables, $definition->{tableName};
|
||||
}
|
||||
$found{$definition->{tableName}} = 1;
|
||||
}
|
||||
return @tables;
|
||||
};
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
sub _gen_getProperty {
|
||||
my $class = shift;
|
||||
my $superGetProperty = $class->next::method(@_);
|
||||
return sub {
|
||||
my $self = shift;
|
||||
my $property = $self->$superGetProperty(@_);
|
||||
for my $element (qw(label hoverHelp)) {
|
||||
if ($property->{$element} && ref $property->{$element} eq 'ARRAY') {
|
||||
$property->{$element}
|
||||
= WebGUI::International->new($self->session)->get(@{$property->{$element}});
|
||||
}
|
||||
}
|
||||
return $property;
|
||||
};
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=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
|
||||
-------------------------------------------------------------------
|
||||
|
||||
=head1 NAME
|
||||
|
||||
WebGUI::Definition::Asset
|
||||
Package WebGUI::Definition::Asset
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Extends WebGUI::Definition with asset specific methods and convienences. It automatically inserts the tableName attribute as an element of each property if the property doesn't explicitly set it.
|
||||
Moose-based meta class for all Asset definitions in WebGUI.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
A definition contains all the information needed to build an object.
|
||||
Information required to build forms are added as optional roles and
|
||||
sub metaclasses. Database persistance is handled similarly.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
The following methods are exposed through this class.
|
||||
These methods are available from this class:
|
||||
|
||||
=head2 getProperty ( property )
|
||||
=cut
|
||||
|
||||
Extends getProperty() method generated by WebGUI::Definition by automatically converting the label and hoverHelp elements into strings.
|
||||
my ($import, $unimport, $init_meta) = Moose::Exporter->build_import_methods(
|
||||
install => [ 'unimport' ],
|
||||
also => 'WebGUI::Definition',
|
||||
with_meta => [ 'property' ],
|
||||
);
|
||||
|
||||
=head2 getTables ( )
|
||||
sub import {
|
||||
my $class = shift;
|
||||
my $caller = caller;
|
||||
$class->$import({ into_level => 1 });
|
||||
warnings->unimport('uninitialized');
|
||||
namespace::autoclean->import( -cleanee => $caller );
|
||||
return 1;
|
||||
}
|
||||
|
||||
Returns a list of the tables that this asset's properties are stored in.
|
||||
sub init_meta {
|
||||
my $class = shift;
|
||||
my %options = @_;
|
||||
$options{metaclass} //= 'WebGUI::Definition::Meta::Asset';
|
||||
my $meta = WebGUI::Definition->init_meta(%options);
|
||||
Moose::Util::apply_all_roles($meta, 'WebGUI::Definition::Role::Asset');
|
||||
return $meta;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 property ( $name, %options )
|
||||
|
||||
Extends WebGUI::Definition::property to copy the tableName attribute from the
|
||||
meta class into the options for each property.
|
||||
|
||||
=head3 $name
|
||||
|
||||
=head3 %options
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
sub property {
|
||||
my ($meta, $name, %options) = @_;
|
||||
$options{tableName} //= $meta->tableName;
|
||||
return WebGUI::Definition::property($meta, $name, %options);
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
91
lib/WebGUI/Definition/Meta/Asset.pm
Normal file
91
lib/WebGUI/Definition/Meta/Asset.pm
Normal file
|
|
@ -0,0 +1,91 @@
|
|||
package WebGUI::Definition::Meta::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 5.010;
|
||||
use Moose;
|
||||
use namespace::autoclean;
|
||||
use WebGUI::Definition::Meta::Property::Asset;
|
||||
no warnings qw(uninitialized);
|
||||
|
||||
extends 'WebGUI::Definition::Meta::Class';
|
||||
|
||||
our $VERSION = '0.0.1';
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Package WebGUI::Definition::Meta::Property::Asset
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Extends WebGUI::Definition::Meta::Class to provide
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
Extends 'WebGUI::Definition::Meta::Class' to provide attributes specific to Assets.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
These methods are available from this class:
|
||||
|
||||
=cut
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 property_meta ( )
|
||||
|
||||
Asset Definitions use WebGUI::Definition::Meta::Property::Asset as the base class
|
||||
for properties.
|
||||
|
||||
=cut
|
||||
|
||||
sub property_meta {
|
||||
return 'WebGUI::Definition::Meta::Property::Asset';
|
||||
}
|
||||
|
||||
has [ qw{tableName icon assetName} ] => (
|
||||
is => 'rw',
|
||||
);
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 tableName ( )
|
||||
|
||||
The table that this asset stores its properties in.
|
||||
|
||||
=cut
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 icon ( )
|
||||
|
||||
The filename of the icon for this Asset. Icons are stored in
|
||||
www/extras/assets and are 48 x 48 pixels in size. A smaller version of
|
||||
the icon, 16x16, is found in www/extras/assets/small.
|
||||
|
||||
=cut
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 assetName ( )
|
||||
|
||||
An array reference containing two items. The first is the i18n key for the asset's name.
|
||||
The second is the i18n namespace to find the asset's name.
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
1;
|
||||
|
||||
140
lib/WebGUI/Definition/Meta/Class.pm
Normal file
140
lib/WebGUI/Definition/Meta/Class.pm
Normal file
|
|
@ -0,0 +1,140 @@
|
|||
package WebGUI::Definition::Meta::Class;
|
||||
|
||||
=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 5.010;
|
||||
use Moose;
|
||||
use namespace::autoclean;
|
||||
use WebGUI::Definition::Meta::Property;
|
||||
no warnings qw(uninitialized);
|
||||
|
||||
extends 'Moose::Meta::Class';
|
||||
|
||||
our $VERSION = '0.0.1';
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Package WebGUI::Definition::Meta::Class
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Moose-based meta class for all definitions in WebGUI.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
A definition contains all the information needed to build an object.
|
||||
Information required to build forms are added as optional roles and
|
||||
sub metaclasses. Database persistance is handled similarly.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
These methods are available from this class:
|
||||
|
||||
=cut
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 get_all_properties ( )
|
||||
|
||||
Returns an array of all Properties, in all classes, in the order they were
|
||||
created in the Definition.
|
||||
|
||||
=cut
|
||||
|
||||
sub get_all_properties {
|
||||
my $self = shift;
|
||||
my @properties = ();
|
||||
CLASS: foreach my $className (reverse $self->linearized_isa()) {
|
||||
my $meta = $self->initialize($className);
|
||||
next CLASS unless $meta->isa('WebGUI::Definition::Meta::Class');
|
||||
push @properties,
|
||||
sort { $a->insertion_order <=> $b->insertion_order } # In insertion order
|
||||
grep { $_->isa('WebGUI::Definition::Meta::Property') } # that are Meta::Properties
|
||||
$meta->get_attributes # All attributes
|
||||
;
|
||||
}
|
||||
return @properties;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 get_attributes ( )
|
||||
|
||||
Returns an array of all attributes, but only for this class. This is the
|
||||
API-safe way of doing $self->_attribute_map;
|
||||
|
||||
=cut
|
||||
|
||||
sub get_attributes {
|
||||
my $self = shift;
|
||||
return map { $self->find_attribute_by_name($_) } $self->get_attribute_list;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 get_property_list ( )
|
||||
|
||||
Returns an array of the names of all Properties, in all classes, in the
|
||||
order they were created in the Definition. Duplicate names are filtered
|
||||
out.
|
||||
|
||||
=cut
|
||||
|
||||
sub get_property_list {
|
||||
my $self = shift;
|
||||
my @properties = ();
|
||||
my %seen = ();
|
||||
push @properties,
|
||||
grep { ! $seen{$_}++ } # Uniqueness check
|
||||
map { $_->name } # Just the name
|
||||
$self->get_all_properties
|
||||
;
|
||||
return @properties;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 get_tables ( )
|
||||
|
||||
Returns an array of the names of all tables in every class used by
|
||||
this Class.
|
||||
|
||||
=cut
|
||||
|
||||
sub get_tables {
|
||||
my $self = shift;
|
||||
my @properties = ();
|
||||
my %seen = ();
|
||||
push @properties,
|
||||
grep { ! $seen{$_}++ }
|
||||
map { $_->tableName }
|
||||
$self->get_all_properties
|
||||
;
|
||||
return @properties;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 property_meta ( )
|
||||
|
||||
Returns the name of the class for properties.
|
||||
|
||||
=cut
|
||||
|
||||
sub property_meta {
|
||||
return 'WebGUI::Definition::Meta::Property';
|
||||
}
|
||||
|
||||
1;
|
||||
54
lib/WebGUI/Definition/Meta/Property.pm
Normal file
54
lib/WebGUI/Definition/Meta/Property.pm
Normal file
|
|
@ -0,0 +1,54 @@
|
|||
package WebGUI::Definition::Meta::Property;
|
||||
|
||||
=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 5.010;
|
||||
use Moose;
|
||||
use namespace::autoclean;
|
||||
no warnings qw(uninitialized);
|
||||
|
||||
our $VERSION = '0.0.1';
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Package WebGUI::Definition::Meta::Property
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Moose-based meta class for all properties in WebGUI::Definition.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
WebGUI::Definition::Meta::Property extends Moose::Meta::Attribute to include
|
||||
a read-only form method, that provides the form properties for the attribute.
|
||||
|
||||
=cut
|
||||
|
||||
extends 'Moose::Meta::Attribute';
|
||||
|
||||
has 'form' => (
|
||||
is => 'ro',
|
||||
);
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 form ( )
|
||||
|
||||
Returns a hashref of propertes that are specific to WebGUI::Forms.
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
|
||||
85
lib/WebGUI/Definition/Meta/Property/Asset.pm
Normal file
85
lib/WebGUI/Definition/Meta/Property/Asset.pm
Normal file
|
|
@ -0,0 +1,85 @@
|
|||
package WebGUI::Definition::Meta::Property::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 5.010;
|
||||
use Moose;
|
||||
use namespace::autoclean;
|
||||
no warnings qw(uninitialized);
|
||||
|
||||
our $VERSION = '0.0.1';
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Package WebGUI::Definition::Meta::Property::Asset
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Extends WebGUI::Definition::Meta::Property to provide Asset properties with
|
||||
specific methods. The tableName and fieldType class properties must be defined.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
The following methods are added.
|
||||
|
||||
=cut
|
||||
|
||||
extends 'WebGUI::Definition::Meta::Property';
|
||||
|
||||
has 'tableName' => (
|
||||
is => 'ro',
|
||||
required => 1,
|
||||
);
|
||||
|
||||
has 'fieldType' => (
|
||||
is => 'ro',
|
||||
required => 1,
|
||||
);
|
||||
|
||||
has 'noFormPost' => (
|
||||
is => 'ro',
|
||||
);
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 tableName ( )
|
||||
|
||||
Previously, properties were storied in arrays of definitions, with each definition
|
||||
providing its own attributes like table. This Moose based implementation stores
|
||||
the properties flat, so the tableName attribute is copied into the property so we
|
||||
know where to store it.
|
||||
|
||||
=cut
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 fieldType ( )
|
||||
|
||||
The type of HTML form field that this property should use to generate its UI
|
||||
and validate its data.
|
||||
|
||||
=cut
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 noFormPost ( )
|
||||
|
||||
This is boolean which indicates that no data from HTML forms should be validated
|
||||
and stored for this property.
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
|
||||
27
lib/WebGUI/Definition/Role/Asset.pm
Normal file
27
lib/WebGUI/Definition/Role/Asset.pm
Normal file
|
|
@ -0,0 +1,27 @@
|
|||
package WebGUI::Definition::Role::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 5.010;
|
||||
use Moose::Role;
|
||||
use namespace::autoclean;
|
||||
no warnings qw(uninitialized);
|
||||
|
||||
with 'WebGUI::Definition::Role::Asset';
|
||||
|
||||
our $VERSION = '0.0.1';
|
||||
|
||||
1;
|
||||
|
||||
149
lib/WebGUI/Definition/Role/Object.pm
Normal file
149
lib/WebGUI/Definition/Role/Object.pm
Normal file
|
|
@ -0,0 +1,149 @@
|
|||
package WebGUI::Definition::Role::Object;
|
||||
|
||||
=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 5.010;
|
||||
use Moose::Role;
|
||||
use namespace::autoclean;
|
||||
no warnings qw(uninitialized);
|
||||
|
||||
our $VERSION = '0.0.1';
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Package WebGUI::Role::Object
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Moose-based role for providing classic WebGUI get/set style methods for objects.
|
||||
This role is automatically included in all Definition objects.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
$obj->get('someProperty');
|
||||
$obj->set({ someProperty => 'someValue' });
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
These methods are available from this class:
|
||||
|
||||
=cut
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 get ( [ $name ] )
|
||||
|
||||
Generic accessor for this object's properties.
|
||||
|
||||
=head3 $name
|
||||
|
||||
If $name is defined, and is an attribute of the object, it returns the
|
||||
value of the attribute. If $name is not an attribute, then it returns
|
||||
undef.
|
||||
|
||||
If $name is not defined, it returns a hashref of all attributes.
|
||||
|
||||
=cut
|
||||
|
||||
sub get {
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
my $property = shift;
|
||||
if ($self->meta->find_attribute_by_name($property)) {
|
||||
return $self->$property;
|
||||
}
|
||||
return undef;
|
||||
}
|
||||
my %properties = map { $_ => scalar $self->$_ } $self->meta->get_property_list;
|
||||
return \%properties;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 set ( dataSpec )
|
||||
|
||||
Generic setter for this object's properties.
|
||||
|
||||
=head3 dataSpec
|
||||
|
||||
Accepts either a hash, or a hash reference, of data to set in the object. If the key
|
||||
is not an attribute of the object, then it is silently ignored.
|
||||
|
||||
=cut
|
||||
|
||||
sub set {
|
||||
my $self = shift;
|
||||
my $properties = @_ % 2 ? shift : { @_ };
|
||||
KEY: for my $key ( keys %$properties ) {
|
||||
next KEY unless $self->meta->find_attribute_by_name($key);
|
||||
$self->$key($properties->{$key});
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 update ( dataSpec )
|
||||
|
||||
Combines the actions of setting data in the object and writing the data.
|
||||
|
||||
=head3 dataSpec
|
||||
|
||||
See L<set>.
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
sub update {
|
||||
my $self = shift;
|
||||
$self->set(@_);
|
||||
if ($self->can('write')) {
|
||||
$self->write;
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getProperty ( $name )
|
||||
|
||||
Returns the requested property, which will be a subclass of Moose::Meta::Attribute.
|
||||
|
||||
=head3 $name
|
||||
|
||||
The name of the property to return.
|
||||
|
||||
=cut
|
||||
|
||||
sub getProperty {
|
||||
my $self = shift;
|
||||
return $self->meta->find_attribute_by_name(@_);
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getProperties ( )
|
||||
|
||||
Returns a list of the names of all properties of the object, as set by the Definition.
|
||||
|
||||
=cut
|
||||
|
||||
sub getProperties {
|
||||
my $self = shift;
|
||||
return $self->meta->get_property_list;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
278
lib/WebGUI/FormBuilder.pm
Normal file
278
lib/WebGUI/FormBuilder.pm
Normal file
|
|
@ -0,0 +1,278 @@
|
|||
package WebGUI::FormBuilder;
|
||||
|
||||
use strict;
|
||||
use Moose;
|
||||
use MooseX::Storage;
|
||||
|
||||
has 'action' => ( is => 'rw' );
|
||||
has 'enctype' => ( is => 'rw', default => 'multipart/form-data' );
|
||||
has 'method' => ( is => 'rw', default => 'POST' );
|
||||
has 'name' => ( is => 'rw' );
|
||||
has 'session' => (
|
||||
is => 'ro',
|
||||
isa => 'WebGUI::Session',
|
||||
required => 1,
|
||||
weak_ref => 1,
|
||||
traits => [ 'DoNotSerialize' ],
|
||||
);
|
||||
|
||||
with Storage( format => 'JSON' );
|
||||
with 'WebGUI::FormBuilder::Role::HasFields';
|
||||
with 'WebGUI::FormBuilder::Role::HasFieldsets';
|
||||
with 'WebGUI::FormBuilder::Role::HasTabs';
|
||||
|
||||
use WebGUI::FormBuilder::Tab;
|
||||
use WebGUI::FormBuilder::Tabset;
|
||||
use WebGUI::FormBuilder::Fieldset;
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 new ( session, properties )
|
||||
|
||||
Create a new FormBuilder object. C<properties> is a list of name => value pairs
|
||||
|
||||
=over 4
|
||||
|
||||
=item name
|
||||
|
||||
The name of the form. Optional, but recommended.
|
||||
|
||||
=item action
|
||||
|
||||
The URL to submit the form to.
|
||||
|
||||
=item method
|
||||
|
||||
The HTTP method to submit the form with. Defaults to POST.
|
||||
|
||||
=item enctype
|
||||
|
||||
The encoding type to use for the form. Defaults to "multipart/form-data". The
|
||||
other possible value is "application/x-www-form-urlencoded".
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my ( $class, $session, %properties ) = @_;
|
||||
$properties{ session } = $session;
|
||||
return $class->SUPER::new( %properties );
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 action ( [ newAction ] )
|
||||
|
||||
Get or set the action property / HTML attribute.
|
||||
|
||||
=cut
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 clone ( )
|
||||
|
||||
Create a clone of this Form
|
||||
|
||||
=cut
|
||||
|
||||
sub clone {
|
||||
# TODO
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 enctype ( [ newEnctype ] )
|
||||
|
||||
Get or set the enctype property / HTML attribute.
|
||||
|
||||
=cut
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 getFooter ( )
|
||||
|
||||
Get the footer for this form.
|
||||
|
||||
=cut
|
||||
|
||||
sub getFooter {
|
||||
my ( $self ) = @_;
|
||||
|
||||
my $html = '</form>';
|
||||
|
||||
return $html;
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 getHeader ( )
|
||||
|
||||
Get the header for this form.
|
||||
|
||||
=cut
|
||||
|
||||
sub getHeader {
|
||||
my ( $self ) = @_;
|
||||
|
||||
my @attrs = qw{ action method name enctype };
|
||||
my $attrs = join " ", map { qq{$_="} . $self->$_ . qq{"} } grep { $self->$_ } @attrs;
|
||||
|
||||
my $html = sprintf '<form %s>', $attrs;
|
||||
|
||||
return $html;
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 method ( [ newMethod ] )
|
||||
|
||||
Get or set the method property / HTML attribute.
|
||||
|
||||
=cut
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 name ( [ newName ] )
|
||||
|
||||
Get or set the name property / HTML attribute.
|
||||
|
||||
=cut
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 session ( )
|
||||
|
||||
Get the WebGUI::Session attached to this object
|
||||
|
||||
=cut
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 toHtml ( )
|
||||
|
||||
Return the HTML for the form
|
||||
|
||||
=cut
|
||||
|
||||
sub toHtml {
|
||||
my ( $self ) = @_;
|
||||
|
||||
my $html = $self->getHeader;
|
||||
# Add individual objects
|
||||
$html .= join "", map { $_->toHtml } @{$self->objects};
|
||||
$html .= $self->getFooter;
|
||||
|
||||
return $html;
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 toTemplateVars ( prefix, [var] )
|
||||
|
||||
Get the template variables for the form's controls with the given prefix.
|
||||
C<var> is an optional hashref to add the variables to.
|
||||
|
||||
=cut
|
||||
|
||||
sub toTemplateVars {
|
||||
my ( $self, $prefix, $var ) = @_;
|
||||
$prefix ||= "form";
|
||||
$var ||= {};
|
||||
|
||||
# $prefix_header
|
||||
$var->{ "${prefix}_header" } = $self->getHeader;
|
||||
# $prefix_footer
|
||||
$var->{ "${prefix}_footer" } = $self->getFooter;
|
||||
# $prefix_fieldloop
|
||||
# name -- for comparisons
|
||||
# field
|
||||
# label -- includes hoverhelp
|
||||
# label_nohover
|
||||
# pretext
|
||||
# subtext
|
||||
# hoverhelp -- The text. For use with label_nohover
|
||||
# $prefix_field_$fieldName
|
||||
if ( @{$self->fields} ) {
|
||||
my $fieldLoop = [];
|
||||
$var->{ "${prefix}_fieldloop" } = $fieldLoop;
|
||||
for my $field ( @{$self->fields} ) {
|
||||
my $name = $field->get('name');
|
||||
my $props = {
|
||||
name => $name,
|
||||
field => $field->toHtml,
|
||||
label => $field->getLabel,
|
||||
label_nohover => $field->get('label'),
|
||||
pretext => $field->get('pretext'),
|
||||
subtext => $field->get('subtext'),
|
||||
hoverhelp => $field->get('hoverhelp'),
|
||||
};
|
||||
for my $key ( keys %{$props} ) {
|
||||
$var->{ "${prefix}_field_${name}_${key}" } = $props->{$key};
|
||||
}
|
||||
push @{$fieldLoop}, $props;
|
||||
}
|
||||
}
|
||||
# $prefix_fieldsetloop
|
||||
# name
|
||||
# legend
|
||||
# label -- same as legend
|
||||
# fieldloop
|
||||
# ...
|
||||
# fieldsetloop
|
||||
# ...
|
||||
# tabloop
|
||||
# ...
|
||||
# $prefix_fieldset_$fieldsetName
|
||||
if ( @{$self->fieldsets} ) {
|
||||
my $fieldsetLoop = [];
|
||||
$var->{ "${prefix}_fieldsetLoop" } = $fieldsetLoop;
|
||||
for my $fieldset ( @{$self->fieldsets} ) {
|
||||
my $name = $fieldset->name;
|
||||
my $props = $fieldset->toTemplateVars;
|
||||
for my $key ( keys %{$props} ) {
|
||||
$var->{ "${prefix}_fieldset_${name}_${key}" } = $props->{key};
|
||||
}
|
||||
push @{$fieldsetLoop}, $props;
|
||||
}
|
||||
}
|
||||
# $prefix_tabloop
|
||||
# name
|
||||
# label
|
||||
# fieldloop
|
||||
# ...
|
||||
# fieldsetloop
|
||||
# ...
|
||||
# tabloop
|
||||
# ...
|
||||
# $prefix_tab_$tabName
|
||||
if ( @{$self->tabs} ) {
|
||||
my $tabLoop = [];
|
||||
$var->{ "${prefix}_tabLoop" } = $tabLoop;
|
||||
for my $tab ( @{$self->tabs} ) {
|
||||
my $name = $tab->name;
|
||||
my $props = $tab->toTemplateVars;
|
||||
for my $key ( keys %{$props} ) {
|
||||
$var->{ "${prefix}_tab_${name}_${key}" } = $props->{key};
|
||||
}
|
||||
push @{$tabLoop}, $props;
|
||||
}
|
||||
}
|
||||
|
||||
return $var;
|
||||
}
|
||||
|
||||
=head1 TEMPLATES
|
||||
|
||||
=head2 Default View
|
||||
|
||||
This is a Template Toolkit template that will recreate the default toHtml() view
|
||||
of a form.
|
||||
|
||||
# TODO
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
144
lib/WebGUI/FormBuilder/Fieldset.pm
Normal file
144
lib/WebGUI/FormBuilder/Fieldset.pm
Normal file
|
|
@ -0,0 +1,144 @@
|
|||
package WebGUI::FormBuilder::Fieldset;
|
||||
|
||||
use strict;
|
||||
use Moose;
|
||||
use MooseX::Storage;
|
||||
|
||||
has 'name' => (
|
||||
is => 'ro',
|
||||
isa => 'Str',
|
||||
required => 1,
|
||||
);
|
||||
|
||||
has 'label' => (
|
||||
is => 'rw',
|
||||
isa => 'Str',
|
||||
);
|
||||
|
||||
has 'session' => (
|
||||
is => 'ro',
|
||||
isa => 'WebGUI::Session',
|
||||
required => 1,
|
||||
weak_ref => 1,
|
||||
traits => [ 'DoNotSerialize' ],
|
||||
);
|
||||
|
||||
with Storage( format => 'JSON' );
|
||||
with 'WebGUI::FormBuilder::Role::HasFields';
|
||||
with 'WebGUI::FormBuilder::Role::HasFieldsets';
|
||||
with 'WebGUI::FormBuilder::Role::HasTabs';
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=cut
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 new ( session, properties )
|
||||
|
||||
Create a new Fieldset object. C<session> is a WebGUI Session. C<properties> is
|
||||
a list of name => value pairs.
|
||||
|
||||
|
||||
=over 4
|
||||
|
||||
=item name
|
||||
|
||||
Required. The name of the fieldset. Cannot be changed after initially set,
|
||||
otherwise the parent <form> may not work correctly.
|
||||
|
||||
=item label
|
||||
|
||||
Optional. A label to show the user.
|
||||
|
||||
=item legend
|
||||
|
||||
Optional. A synonym for C<label>.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my ( $class, $session, %properties ) = @_;
|
||||
$properties{ session } = $session;
|
||||
$properties{ label } ||= delete $properties{ legend };
|
||||
return $class->SUPER::new( %properties );
|
||||
}
|
||||
|
||||
sub getFooter {
|
||||
my ( $self ) = @_;
|
||||
return '</fieldset>';
|
||||
}
|
||||
|
||||
sub getHeader {
|
||||
my ( $self ) = @_;
|
||||
return '<fieldset><legend>' . $self->label . '</legend>';
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 label ( newLabel )
|
||||
|
||||
A label to show the user
|
||||
|
||||
=cut
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 legend ( newLegend )
|
||||
|
||||
A synonym for label.
|
||||
|
||||
=cut
|
||||
|
||||
sub legend {
|
||||
my ( $self, @args ) = @_;
|
||||
return $self->label( @args );
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 name ( )
|
||||
|
||||
The name of the fieldset. Read-only.
|
||||
|
||||
=cut
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 session ( )
|
||||
|
||||
Get the WebGUI::Session attached to this object
|
||||
|
||||
=cut
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 toHtml ( )
|
||||
|
||||
Returns the HTML to render the fieldset.
|
||||
|
||||
=cut
|
||||
|
||||
sub toHtml {
|
||||
my ( $self ) = @_;
|
||||
|
||||
my $html = $self->getHeader;
|
||||
$html .= join "", map { $_->toHtml } @{$self->objects};
|
||||
$html .= $self->getFooter;
|
||||
|
||||
return $html;
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 toTemplateVars ( )
|
||||
|
||||
=cut
|
||||
|
||||
sub toTemplateVars {
|
||||
|
||||
}
|
||||
|
||||
1;
|
||||
125
lib/WebGUI/FormBuilder/Role/HasFields.pm
Normal file
125
lib/WebGUI/FormBuilder/Role/HasFields.pm
Normal file
|
|
@ -0,0 +1,125 @@
|
|||
package WebGUI::FormBuilder::Role::HasFields;
|
||||
|
||||
use strict;
|
||||
use Moose::Role;
|
||||
|
||||
requires 'session', 'pack', 'unpack';
|
||||
|
||||
has 'fields' => (
|
||||
is => 'rw',
|
||||
isa => 'ArrayRef[WebGUI::Form::Control]',
|
||||
default => sub { [] },
|
||||
);
|
||||
|
||||
with 'WebGUI::FormBuilder::Role::HasObjects';
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 addField ( WebGUI::Form::Control )
|
||||
|
||||
Add a field. Any WebGUI::Form::Control object.
|
||||
|
||||
=head2 addField ( type, properties )
|
||||
|
||||
Add a field. C<type> is a class name, optionally without 'WebGUI::Form::'.
|
||||
C<properties> is a list of name => value pairs.
|
||||
|
||||
Returns the field object
|
||||
|
||||
=over 4
|
||||
|
||||
=item name
|
||||
|
||||
Required. The name of the field in the form.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub addField {
|
||||
my ( $self, $type, @properties ) = @_;
|
||||
my $field;
|
||||
|
||||
if ( blessed( $type ) ) {
|
||||
$field = $type;
|
||||
}
|
||||
else {
|
||||
# Is $type a class name?
|
||||
eval { WebGUI::Pluggable::load( $type ) };
|
||||
if ( $@ ) {
|
||||
eval { WebGUI::Pluggable::load( "WebGUI::Form::" . ucfirst( $type ) ) };
|
||||
if ( $@ ) {
|
||||
$self->session->error("Could not load field type '$type'. Try loading it manually." );
|
||||
confess "Could not load field type '$type'. Try loading it manually.";
|
||||
}
|
||||
$type = "WebGUI::Form::" . ucfirst( $type );
|
||||
}
|
||||
$field = $type->new( $self->session, { @properties } );
|
||||
}
|
||||
|
||||
push @{$self->fields}, $field;
|
||||
$self->addObject( $field );
|
||||
$self->{_fieldsByName}{ $field->get('name') } = $field; # TODO: Must allow multiple fields per name
|
||||
return $field;
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 deleteField ( name )
|
||||
|
||||
Delete a field by name. Returns the field deleted.
|
||||
|
||||
=cut
|
||||
|
||||
sub deleteField {
|
||||
my ( $self, $name ) = @_;
|
||||
my $field = delete $self->{_fieldsByName}{$name};
|
||||
for ( my $i = 0; $i < scalar @{$self->fields}; $i++ ) {
|
||||
my $testField = $self->fields->[$i];
|
||||
if ( $testField->get('name') eq $name ) {
|
||||
splice @{$self->fields}, $i, 1;
|
||||
}
|
||||
}
|
||||
return $field;
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 getField ( name )
|
||||
|
||||
Get a field by name. Returns the field object.
|
||||
|
||||
=cut
|
||||
|
||||
sub getField {
|
||||
my ( $self, $name ) = @_;
|
||||
return $self->{_fieldsByName}{$name};
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 getFieldsRecursive ( )
|
||||
|
||||
Get all the fields in this section, including fieldsets and tabs.
|
||||
|
||||
=cut
|
||||
|
||||
sub getFieldsRecursive {
|
||||
my ( $self ) = @_;
|
||||
|
||||
my $fields = [ @{$self->fields} ]; # New arrayref, but same field objects
|
||||
|
||||
if ( $self->DOES('WebGUI::FormBuilder::Role::HasFieldsets') ) {
|
||||
# Add $self->{_fieldsets} fields
|
||||
}
|
||||
if ( $self->DOES('WebGUI::FormBuilder::Role::HasTabs') ) {
|
||||
# Add $self->{_tabs} fields
|
||||
}
|
||||
|
||||
return $fields;
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
128
lib/WebGUI/FormBuilder/Role/HasFieldsets.pm
Normal file
128
lib/WebGUI/FormBuilder/Role/HasFieldsets.pm
Normal file
|
|
@ -0,0 +1,128 @@
|
|||
package WebGUI::FormBuilder::Role::HasFieldsets;
|
||||
|
||||
use strict;
|
||||
use Moose::Role;
|
||||
|
||||
has 'fieldsets' => (
|
||||
is => 'rw',
|
||||
isa => 'ArrayRef[WebGUI::FormBuilder::Fieldset]',
|
||||
default => sub { [] },
|
||||
);
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=cut
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 addFieldset( properties )
|
||||
|
||||
Add a fieldset. C<properties> is a list of name => value pairs. Returns the
|
||||
new WebGUI::FormBuilder::Fieldset object.
|
||||
|
||||
=over 4
|
||||
|
||||
=item name
|
||||
|
||||
Required. The name of the fieldset.
|
||||
|
||||
=item legend
|
||||
|
||||
The label for the fieldset.
|
||||
|
||||
=back
|
||||
|
||||
=head2 addFieldset( object, overrideProperties )
|
||||
|
||||
Add a fieldset. C<object> is any object that implements the C<WebGUI::FormBuilder::Role::HasFields>
|
||||
class. Any fieldsets or tabs in the C<object> will also be added. C<overrideProperties> is a list
|
||||
of name => value pairs to override properties in the C<object> (such as name and label).
|
||||
|
||||
=cut
|
||||
|
||||
sub addFieldset {
|
||||
my ( $fieldset, $self );
|
||||
if ( blessed( $_[1] ) ) {
|
||||
( $self, my $object, my %properties ) = @_;
|
||||
$properties{ name } ||= $object->can('name') ? $object->name : "";
|
||||
$properties{ label } ||= $object->can('label') ? $object->label : "";
|
||||
$fieldset = WebGUI::FormBuilder::Fieldset->new( $self->session, %properties );
|
||||
if ( $object->DOES('WebGUI::FormBuilder::Role::HasTabs') ) {
|
||||
for my $objectTabset ( @{$object->tabsets} ) {
|
||||
for my $objectTab ( @{$objectTabset->tabs} ) {
|
||||
$fieldset->addTab( $objectTab, tabset => $objectTabset->name );
|
||||
}
|
||||
}
|
||||
}
|
||||
if ( $object->DOES('WebGUI::FormBuilder::Role::HasFieldsets') ) {
|
||||
for my $objectFieldset ( @{$object->fieldsets} ) {
|
||||
$fieldset->addFieldset( $objectFieldset );
|
||||
}
|
||||
}
|
||||
if ( $object->DOES('WebGUI::FormBuilder::Role::HasFields') ) {
|
||||
for my $objectField ( @{$object->fields} ) {
|
||||
$fieldset->addField( $objectField );
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
( $self, my @properties ) = @_;
|
||||
$fieldset = WebGUI::FormBuilder::Fieldset->new( $self->session, @properties );
|
||||
}
|
||||
push @{$self->fieldsets}, $fieldset;
|
||||
$self->addObject( $fieldset );
|
||||
$self->{_fieldsetsByName}{ $fieldset->name } = $fieldset;
|
||||
return $fieldset;
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 deleteFieldset ( name )
|
||||
|
||||
Delete a fieldset by name. Returns the fieldset deleted.
|
||||
|
||||
=cut
|
||||
|
||||
sub deleteFieldset {
|
||||
my ( $self, $name ) = @_;
|
||||
my $fieldset = delete $self->{_fieldsetsByName}{$name};
|
||||
for ( my $i = 0; $i < scalar @{$self->fieldsets}; $i++ ) {
|
||||
my $testFieldset = $self->fieldsets->[$i];
|
||||
if ( $testFieldset->name eq $name ) {
|
||||
splice @{$self->fieldsets}, $i, 1;
|
||||
}
|
||||
}
|
||||
return $fieldset;
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 getFieldset ( name )
|
||||
|
||||
Get a fieldset object by name
|
||||
|
||||
=cut
|
||||
|
||||
sub getFieldset {
|
||||
my ( $self, $name ) = @_;
|
||||
return $self->{_fieldsetsByName}{$name};
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 toHtml ( )
|
||||
|
||||
Render the fieldsets in this part of the form
|
||||
|
||||
=cut
|
||||
|
||||
override 'toHtml' => sub {
|
||||
my ( $self ) = @_;
|
||||
my $html = super();
|
||||
for my $fieldset ( @{$self->fieldsets} ) {
|
||||
$html .= $fieldset->toHtml;
|
||||
}
|
||||
return $html;
|
||||
};
|
||||
|
||||
1;
|
||||
23
lib/WebGUI/FormBuilder/Role/HasObjects.pm
Normal file
23
lib/WebGUI/FormBuilder/Role/HasObjects.pm
Normal file
|
|
@ -0,0 +1,23 @@
|
|||
package WebGUI::FormBuilder::Role::HasObjects;
|
||||
|
||||
use Moose::Role;
|
||||
|
||||
has 'objects' => (
|
||||
is => 'rw',
|
||||
isa => 'ArrayRef[Object]',
|
||||
default => sub { [] },
|
||||
);
|
||||
|
||||
# Objects combines "fields", "fieldsets", and "tabsets"
|
||||
|
||||
sub addObject {
|
||||
my ( $self, $object ) = @_;
|
||||
push @{$self->objects}, $object;
|
||||
return $object;
|
||||
}
|
||||
|
||||
# Handle re-ordering of objects
|
||||
|
||||
|
||||
1;
|
||||
|
||||
142
lib/WebGUI/FormBuilder/Role/HasTabs.pm
Normal file
142
lib/WebGUI/FormBuilder/Role/HasTabs.pm
Normal file
|
|
@ -0,0 +1,142 @@
|
|||
package WebGUI::FormBuilder::Role::HasTabs;
|
||||
|
||||
use strict;
|
||||
use Moose::Role;
|
||||
|
||||
with 'WebGUI::FormBuilder::Role::HasObjects';
|
||||
requires 'session', 'pack', 'unpack';
|
||||
|
||||
has 'tabsets' => (
|
||||
is => 'rw',
|
||||
isa => 'ArrayRef[WebGUI::FormBuilder::Tabset]',
|
||||
default => sub { [] },
|
||||
);
|
||||
|
||||
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=cut
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 addTab ( properties )
|
||||
|
||||
Add a tab. C<properties> is a list of name => value pairs to be passed to
|
||||
L<WebGUI::FormBuilder::Tab>.
|
||||
|
||||
=head2 addTab ( object, propertiesOverrides )
|
||||
|
||||
Add a tab. C<object> is any object that implements L<WebGUI::FormBuilder::Role::HasFields>.
|
||||
Any sub-tabs or fieldsets will also be included.
|
||||
|
||||
=cut
|
||||
|
||||
sub addTab {
|
||||
my ($tab, $self, %properties);
|
||||
if ( blessed( $_[1] ) ) {
|
||||
( $self, my $object, %properties ) = @_;
|
||||
$properties{ name } ||= $object->can('name') ? $object->name : "";
|
||||
$properties{ label } ||= $object->can('label') ? $object->label : "";
|
||||
$tab = WebGUI::FormBuilder::Tab->new( $self->session, %properties );
|
||||
if ( $object->DOES('WebGUI::FormBuilder::Role::HasTabs') ) {
|
||||
for my $objectTabset ( @{$object->tabsets} ) {
|
||||
for my $objectTab ( @{$objectTabset->tabs} ) {
|
||||
$tab->addTab( $objectTab, tabset => $objectTabset->name );
|
||||
}
|
||||
}
|
||||
}
|
||||
if ( $object->DOES('WebGUI::FormBuilder::Role::HasFieldsets') ) {
|
||||
for my $objectFieldset ( @{$object->fieldsets} ) {
|
||||
$tab->addFieldset( $objectFieldset );
|
||||
}
|
||||
}
|
||||
if ( $object->DOES('WebGUI::FormBuilder::Role::HasFields') ) {
|
||||
for my $objectField ( @{$object->fields} ) {
|
||||
$tab->addField( $objectField );
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
( $self, %properties ) = @_;
|
||||
$tab = WebGUI::FormBuilder::Tab->new( $self->session, %properties );
|
||||
}
|
||||
my $tabsetName = delete $properties{ tabset } || "default";
|
||||
my $tabset = $self->getTabset( $tabsetName )
|
||||
|| $self->addTabset( name => $tabsetName )
|
||||
;
|
||||
$tabset->addTab( $tab );
|
||||
$self->{_tabsByName}{$tab->name} = $tab;
|
||||
return $tab;
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 addTabset ( properties )
|
||||
|
||||
Add a tabset. A tabset holds a bunch of tabs. Returns the WebGUI::FormBuilder::Tabset
|
||||
object.
|
||||
|
||||
=cut
|
||||
|
||||
sub addTabset {
|
||||
my ( $self, %properties ) = @_;
|
||||
if ( $self->{_tabsetsByName}{$properties{name}} ) {
|
||||
confess "Cannot add another tabset of the same name: $properties{name}\n";
|
||||
}
|
||||
my $tabset = WebGUI::FormBuilder::Tabset->new( $self->session, %properties );
|
||||
$self->{_tabsetsByName}{$tabset->name} = $tabset;
|
||||
push @{$self->tabsets}, $tabset;
|
||||
$self->addObject( $tabset );
|
||||
return $tabset;
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 deleteTab ( name )
|
||||
|
||||
Delete a tab by name. Returns the tab deleted.
|
||||
|
||||
=cut
|
||||
|
||||
sub deleteTab {
|
||||
my ( $self, $name ) = @_;
|
||||
my $tab = delete $self->{_tabsByName}{$name};
|
||||
for my $tabset ( @{ $self->tabsets } ) {
|
||||
for ( my $i = 0; $i < scalar @{$tabset->tabs}; $i++ ) {
|
||||
my $testTab = $tabset->tabs->[$i];
|
||||
if ( $testTab->name eq $name ) {
|
||||
splice @{$tabset->tabs}, $i, 1;
|
||||
}
|
||||
}
|
||||
}
|
||||
return $tab;
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 getTab ( name )
|
||||
|
||||
Get a tab object by name
|
||||
|
||||
=cut
|
||||
|
||||
sub getTab {
|
||||
my ( $self, $name ) = @_;
|
||||
return $self->{_tabsByName}{$name};
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 getTabset ( name )
|
||||
|
||||
Get a tabset object by name
|
||||
|
||||
=cut
|
||||
|
||||
sub getTabset {
|
||||
my ( $self, $name ) = @_;
|
||||
return $self->{_tabsetsByName}{$name};
|
||||
}
|
||||
|
||||
1;
|
||||
100
lib/WebGUI/FormBuilder/Tab.pm
Normal file
100
lib/WebGUI/FormBuilder/Tab.pm
Normal file
|
|
@ -0,0 +1,100 @@
|
|||
package WebGUI::FormBuilder::Tab;
|
||||
|
||||
use strict;
|
||||
use Moose;
|
||||
use MooseX::Storage;
|
||||
|
||||
has 'label' => (
|
||||
is => 'rw',
|
||||
isa => 'Str',
|
||||
);
|
||||
|
||||
has 'name' => (
|
||||
is => 'ro',
|
||||
isa => 'Str',
|
||||
required => 1,
|
||||
);
|
||||
|
||||
has 'session' => (
|
||||
is => 'ro',
|
||||
isa => 'WebGUI::Session',
|
||||
required => 1,
|
||||
weak_ref => 1,
|
||||
traits => [ 'DoNotSerialize' ],
|
||||
);
|
||||
|
||||
with Storage( format => 'JSON' );
|
||||
with 'WebGUI::FormBuilder::Role::HasFields';
|
||||
with 'WebGUI::FormBuilder::Role::HasFieldsets';
|
||||
with 'WebGUI::FormBuilder::Role::HasTabs';
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=cut
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 new ( session, properties )
|
||||
|
||||
Create a new Tab object. C<session> is a WebGUI Session. C<properties> is a
|
||||
list of name => value pairs.
|
||||
|
||||
=over 4
|
||||
|
||||
=item name
|
||||
|
||||
Required. A name for the tab.
|
||||
|
||||
=item label
|
||||
|
||||
Optional. A label for the tab.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my ( $class, $session, %properties ) = @_;
|
||||
$properties{ session } = $session;
|
||||
return $class->SUPER::new( %properties );
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 label ( newLabel )
|
||||
|
||||
A label to show the user
|
||||
|
||||
=cut
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 name ( )
|
||||
|
||||
The name of the fieldset.
|
||||
|
||||
=cut
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 session ( )
|
||||
|
||||
Get the WebGUI::Session attached to this object
|
||||
|
||||
=cut
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 toHtml ( )
|
||||
|
||||
Render the objects in this tab
|
||||
|
||||
=cut
|
||||
|
||||
sub toHtml {
|
||||
my ( $self ) = @_;
|
||||
my $html = join "", map { $_->toHtml } @{$self->objects};
|
||||
return $html;
|
||||
}
|
||||
|
||||
1;
|
||||
93
lib/WebGUI/FormBuilder/Tabset.pm
Normal file
93
lib/WebGUI/FormBuilder/Tabset.pm
Normal file
|
|
@ -0,0 +1,93 @@
|
|||
package WebGUI::FormBuilder::Tabset;
|
||||
|
||||
use Moose;
|
||||
use MooseX::Storage;
|
||||
use WebGUI::FormBuilder::Tab;
|
||||
|
||||
has 'name' => (
|
||||
is => 'ro',
|
||||
isa => 'Str',
|
||||
required => 1,
|
||||
);
|
||||
|
||||
has 'tabs' => (
|
||||
is => 'rw',
|
||||
isa => 'ArrayRef[WebGUI::FormBuilder::Tab]',
|
||||
default => sub { [] },
|
||||
);
|
||||
|
||||
has 'session' => (
|
||||
is => 'ro',
|
||||
isa => 'WebGUI::Session',
|
||||
required => 1,
|
||||
weak_ref => 1,
|
||||
traits => [ 'DoNotSerialize' ],
|
||||
);
|
||||
|
||||
with Storage( format => 'JSON' );
|
||||
with 'WebGUI::FormBuilder::Role::HasObjects';
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 new ( session, properties )
|
||||
|
||||
Create a new Tabset object. C<properties> is a list of name => value pairs
|
||||
|
||||
=over 4
|
||||
|
||||
=item name
|
||||
|
||||
The name of the tabset. Required.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my ( $class, $session, %properties ) = @_;
|
||||
$properties{ session } = $session;
|
||||
return $class->SUPER::new( %properties );
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
sub addTab {
|
||||
my ( $self, $tab ) = @_;
|
||||
push @{$self->tabs}, $tab;
|
||||
$self->addObject( $tab );
|
||||
return $tab;
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
sub toHtml {
|
||||
my ( $self ) = @_;
|
||||
my $html = sprintf( '<div id="%s" class="yui-navset">', $self->name )
|
||||
. '<ul class="yui-nav">'
|
||||
;
|
||||
|
||||
for ( my $i = 0; $i < @{$self->tabs}; $i++ ) {
|
||||
my $tab = $self->tabs->[$i];
|
||||
$html .= sprintf '<li><a href="#tab%i"><em>%s</em></a></li>', $i, $tab->label;
|
||||
}
|
||||
|
||||
$html .= '</ul>'
|
||||
. '<div class="yui-content">'
|
||||
;
|
||||
|
||||
for ( my $i = 0; $i < @{$self->tabs}; $i++ ) {
|
||||
my $tab = $self->tabs->[$i];
|
||||
$html .= sprintf '<div id="tab%i">%s</div>', $i, $tab->toHtml;
|
||||
}
|
||||
|
||||
$html .= '</div>'
|
||||
. '</div>'
|
||||
. q{<script type="text/javascript">}
|
||||
. sprintf( q{var tabView = new YAHOO.widget.TabView('%s');}, $self->name )
|
||||
. q{</script>}
|
||||
;
|
||||
|
||||
return $html;
|
||||
}
|
||||
|
||||
1;
|
||||
Loading…
Add table
Add a link
Reference in a new issue