webgui/t/Definition.t

#-------------------------------------------------------------------
# WebGUI is Copyright 2001-2012 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 WebGUI::Test;

use Test::More;
#use Test::More tests => 17;
use Test::Deep;
use Test::Exception;

my $session = WebGUI::Test->session;

{
    package WGT::Class;
    use Moose;
    use WebGUI::Definition;

    define 'define1' => 'define1 value';
    property 'property1' => (
        arbitrary_key => 'arbitrary_value',
        label         => 'property1',
    );
    property 'property2' => (
        nother_key => 'nother_value',
        label         => 'property2',
    );

    # define creates methods
    ::can_ok +__PACKAGE__, 'define1';

    # properties create methods
    ::can_ok +__PACKAGE__, 'property1';

    # role applied
    ::can_ok +__PACKAGE__, 'update';
    ::can_ok +__PACKAGE__, 'get';
    ::can_ok +__PACKAGE__, 'set';

    ::ok +__PACKAGE__->meta->does_role('WebGUI::Definition::Role::Object'), 'meta class check on the package';

    ::cmp_deeply(
        [ +__PACKAGE__->getProperties ],
        [qw/property1 property2/],
        'getProperties works as a class method'
    );

}

{
    package WGT::Class2;
    use Moose;
    use WebGUI::Definition;

    define 'define1' => 'define1 value';
    property  'property3' => ( label => 'label' );
    property  'property1' => ( label => 'label' );
    property  'property2' => ( label => 'label' );

    my @set_order = ();

    before 'property1' => sub {
        my $self = shift;
        push @set_order, '1';
    };

    before 'property2' => sub {
        my $self = shift;
        push @set_order, '2';
    };

    before 'property3' => sub {
        my $self = shift;
        push @set_order, '3';
    };

    my $object = WGT::Class2->new();
    $object->set(property1 => 1, property2 => 0, property3 => 1);
    ::cmp_deeply( [ @set_order ], [3,1,2], 'properties set in insertion order');

    @set_order = ();
    $object->set(property2 => 1, property3 => 0, property1 => 1);
    ::cmp_deeply( [ @set_order ], [3,1,2], '... and again');

    ::cmp_deeply(
        $object->getFormProperties('property1'),
        { label => 'label' },
        'getFormProperties works for a simple set of properties'
    );

}

{
    package WGT::Class3;
    use Moose;
    use WebGUI::Definition;

    define 'define1' => 'define1 value';
    property  'property1' => (
        label     => ['webgui', 'WebGUI'],
        hoverHelp => ['webgui help %s', 'WebGUI', 'extra'],
        options   => \&property1_options,
        named_url => \&named_url,
    );
    has session => (
        is       => 'ro',
        required => 1,
    );
    sub property1_options {
        return { one => 1, two => 2, three => 3 };
    }

    sub named_url {
        my ($self, $property, $property_name) = @_;
        ::note "Checking arguments passed to subroutine for defining a form property";
        ::isa_ok($self, 'WGT::Class3');
        ::ok($property->can('form'),      'propery has a form method');
        #::ok($property->can('serialize'), 'and a serialize method');
        ::is($property_name, 'named_url', 'form property name sent');
        return $property->name;
    }

    my $object = WGT::Class3->new({session => $session});

    ::cmp_deeply(
        $object->getFormProperties('property1'),
        {
            label     => 'WebGUI',
            hoverHelp => 'webgui help extra',
            options   => { one => 1, two => 2, three => 3 },
            named_url => 'property1',
        },
        'getFormProperties handles i18n and subroutines'
    );

    ::cmp_deeply(
        __PACKAGE__->getFormProperties($object->session,'property1'),
        {
            label     => 'WebGUI',
            hoverHelp => 'webgui help extra',
            options   => { one => 1, two => 2, three => 3 },
            named_url => 'property1',
        },
        'getFormProperties called as class method',
    );

}

{
    package WGT::Class4;
    use Moose;
    use WebGUI::Definition;
    extends 'WGT::Class3';

    define 'define41' => 'define41 value';
    property  'property41' => (
        label   => ['webgui', 'WebGUI'],
    );
    has something => (
        is       => 'rw',
    );

    my $object3 = WGT::Class3->new({session => $session});
    my $object4 = WGT::Class4->new({session => $session});

    ::cmp_bag (
        [WGT::Class3->meta->get_all_attributes_list],
        [qw/ property1 session /],
        'get_all_attributes_list returns all attributes in all metaclasses for the class'
    );

    ::cmp_bag (
        [WGT::Class4->meta->get_all_attributes_list],
        [qw/ property41 something property1 session /],
        '... checking inherited class'
    );
}

{
    package WGT::Class5;
    use Moose;
    use WebGUI::Definition;

    property  'traitorous' => (
        noFormPost => 1,
        traits  => ['Array'],
        isa     => 'ArrayRef',
        is      => 'ro',
        handles => {
            pop_traitor => 'pop',
            push_traitor => 'push',
        },
        default => sub { [] },
    );

    my $object5 = WGT::Class5->new({session => $session});
    $object5->push_traitor('Boggs');
    ::cmp_deeply($object5->traitorous, ['Boggs'], 'push_traitor handler worked');

}

{
    package WGT::Class6;
    use Moose;
    use Moose::Util::TypeConstraints;
    use WebGUI::Definition;
    use JSON;
    use WebGUI::Types;

    property  'leaded' => (
        noFormPost => 1,
        default    => sub { [] },
        traits     => ['Array', 'WebGUI::Definition::Meta::Property::Serialize'],
        isa        => 'WebGUI::Type::JSONArray',
        coerce     => 1,
    );

    property  'regular' => (
        noFormPost => 1,
        default    => sub { [] },
        traits     => ['Array'],
        isa        => 'ArrayRef',
    );

    my $object6 = WGT::Class6->new({session => $session});
    my $leaded  = $object6->meta->find_attribute_by_name('leaded');
    my $regular = $object6->meta->find_attribute_by_name('regular');
    use Moose::Util;
    ::ok Moose::Util::does_role($leaded, 'WebGUI::Definition::Meta::Property::Serialize'), 'does_role detects role';
    ::ok !Moose::Util::does_role($regular, 'WebGUI::Definition::Meta::Property::Serialize'), 'does_role detects lack of role';
    ::ok $leaded->does('WebGUI::Definition::Meta::Property::Serialize'), 'property does role';
    ::ok !$regular->does('WebGUI::Definition::Meta::Property::Serialize'), 'property lacks role';

    my $object6a = WGT::Class6->new({session => $session, leaded => '[{"a": "alpha"}]', });
    ::cmp_deeply(
        $object6a->leaded,
        [ { a => "alpha", }, ],
        'coercion from JSON worked on custom subtype'
    );

    my $object6b = WGT::Class6->new({session => $session, leaded => [{"b" => "beta"}], });
    ::cmp_deeply(
        $object6b->leaded,
        [ { b => "beta", }, ],
        'regular constructor without coercion'
    );

}


done_testing();