view release on metacpan or  search on metacpan

test/Myco/Entity/Meta/Test.pm  view on Meta::CPAN

    my $test = shift;
    return if $test->should_skip;    # skip over this test if asked

    ### Now testing the activation of schema after add_attribute call
    #  package has no previously existing $schema

    my $meta = Myco::Entity::Meta->new(name => $testpkg2);

    eval { $meta->add_attribute(name => 'name', type => 'string'); };
    $test->assert( ! $@, "add_attribute() 'name' call: $@");
    eval { $meta->add_attribute(%$test_attr_params); };
    $test->assert( ! $@, "add_attribute() 'doneness' call: $@");
    eval { $meta->add_attribute(name => 'ramen',
				type => 'string',
				type_options => { string_length => 42 }); };
    $test->assert( ! $@, "add_attribute() 'ramen' call: $@");

    # Wonder Twin Powers, Activate!
    eval { $meta->activate_class; };
    $test->assert( ! $@, "schema activation 2: $@");

    my $testschema;
    {
	no strict "refs";
	$testschema = ${"${testpkg2}::schema"};
    }
    $test->assert( defined $testschema, 'package var $schema now exists');

    # Okay... do we really have a new entity attribute?
    my $instance = eval { $testpkg2->new(name => ENDER); };
    $test->assert( defined($@) && $@ =~ /missing req.*meat_cooked_pref/,
		   "new attribute is required, exception expected");
    $instance = eval { $testpkg2->new(name => ENDER, meat_cooked_pref => 2); };
    $test->assert( ! $@, "new() called with added attribute: $@");
    my $cookpref = eval { $instance->get_meat_cooked_pref ; };
    $test->assert( ! $@, "exception during getter: $@");
    $test->assert( $cookpref == 2, "getter returns expected value");

    # Did $schema 'sql' option get generated from 'type_options'?
    my $ramen = $testschema->{fields}{string}{ramen};
    my $sqlopt = $testschema->{fields}{string}{ramen}{sql};
    $test->assert( defined $ramen, 'ramen attr in $schema');
    $test->assert( defined $sqlopt, 'sql opt in $schema');
    $test->assert( $sqlopt eq 'VARCHAR(42)', 'sql opt correct value');

    # Did $meta ui attribute_options get set up?
    my $attr_opts = $meta->get_ui->get_attribute_options;
    $test->assert(ref $attr_opts eq 'HASH', 'a hash');
    $test->assert(exists $attr_opts->{hidden}, 'an option is present');
    $test->assert(ref $attr_opts->{hidden} eq 'ARRAY', 'an array');
    $test->assert(@{ $attr_opts->{hidden} } == 1, 'maybe one hidden attr');
    $test->assert(defined $attr_opts->{hidden}[0], 'one hidden attr defined');
    $test->assert($attr_opts->{hidden}[0] eq 'meat_cooked_pref',
                  'the expected hidden attr!');

    # Did correct default widget type get set for an attrib with 'values' set?
    my $widg = eval {
        $meta->get_attributes->{meat_cooked_pref}-> get_ui->get_widget->[0];
    };
    $test->assert(! $@, "no trouble looking up widget name:  $@");
    $test->assert($widg eq 'popup_menu',
                  "got us correct default widget... or not:  $widg");
}

sub test_add_attribute {
    my $test = shift;
    return if $test->should_skip;    # skip over this test if asked

    my $meta = Myco::Entity::Meta->new(name => $testpkg1);

    eval { $meta->add_attribute(%$test_attr_params); };
    $test->assert( ! $@, "exception during add_attribute() call: $@");
    $test->assert(exists $meta->{attributes},
		  "attribute hash exists after add_attribute()");
    $test->assert(exists $meta->{attributes}{meat_cooked_pref},
		  "new attribute entry exists after add_attribute()");
    $test->assert(UNIVERSAL::isa($meta->{attributes}{meat_cooked_pref},
				 'Myco::Entity::Meta::Attribute'),
		  "new attribute isa ::Attribute");
    $test->assert($meta->{attributes}{meat_cooked_pref}->get_name
                  eq 'meat_cooked_pref',
		  "new attribute object has name initialized");
}

sub test_add_query {
    my $test = shift;
    return if $test->should_skip;    # skip over this test if asked

    my $meta = Myco::Entity::Meta->new( name => $testpkg1 );

    eval {
        $meta->add_query( name => 'default',
                          description => 'the default query',
                          remotes => { '$testfoo_' => $testpkg1 },
                          result_remote => '$testfoo_',
                          filter => { parts =>
                                      [ { remote => '$testfoo_',
                                          attr => 'meat_cooked_pref',
                                          oper => '==',
                                          param => 'rare_med_done' }
                                      ]
                                    }
                        );
    };
    $test->assert( ! $@, "exception during add_query() call: $@");
}


#     Yep... I've been a bit cut-and-paste happy...

# Let's test this for real!
sub test_basic_behavior_with_real_class {
    my $test = shift;
    return if $test->should_skip;    # skip over this test if asked

    my $testschema;
    {
	no strict "refs";
	$testschema = ${"${samplepkg}::schema"};
    }
    # Let's get ourselves an instance
    my $instance = eval { $samplepkg->new(name => ENDER); };
    $test->assert( ! $@, "creating instance: $@");

    # Test use of attrib defined via $schema
    my $name = eval { $instance->get_name; };
    $test->assert( ! $@, "exception during getter: $@");
    $test->assert( $name eq ENDER, "getter returns expected value");
    # Test use of attrib defined via add_attribute()
    my $fish = eval { $instance->set_fish('carp'); };
    $test->assert( ! $@, "exception during set of added attr: $@");
    $fish = eval { $instance->get_fish; };
    $test->assert( $fish eq 'carp', "fish getter returns expected value");

    # Fetch metadata
    my $meta = eval { $instance->introspect; };
    $test->assert( ! $@, "retrieved class metadata object: $@");

    # Verify metadata basics
    my $m_name = $meta->get_name;
    $test->assert(( defined $m_name and $m_name eq $samplepkg ),
                   "metadata knows class name");
    my $m_syn = $meta->get_synopsis;
    $test->assert(( defined $m_syn and $m_syn eq 'FOO!' ),
                   "metadata knows class synopsis");

    #### Test inherited class level metadata

    #  At present this access_list is the only one
    my $acl = eval { $meta->get_access_list };
    $test->assert( (ref $acl eq 'HASH') && exists $acl->{rw},
                  'got inherited access_list');

    #### Test inherited attribute metadata

    # Test old-style inherited attribute
    #   Did our metadata tangram_option => bases ...   get handled?
    $test->assert(defined $testschema->{bases}, 'bases $schema key defined');
    $test->assert($testschema->{bases}[0] eq "${samplepkg}Base",
		  'bases schema key looks good');
    #   Can we use it?
    $test->_grok_inherited_attrib($meta, $instance,
                                  'heybud', 'string', 'Larry', 'textfield');

    # Test Meta-defined inherited attribute - let's play chicken
    my $attrmeta = $test->_grok_inherited_attrib($meta, $instance,
                                                 'chicken', 'int', '3',
                                                 'radio_group');
    $test->assert($attrmeta->get_value_labels->{3} eq 'Leghorn',
                  'got some chicken val labels');
    $test->assert($attrmeta->get_ui->get_label eq 'Yummy',
                  'got some chicken ui metadata');


    ## Test Meta-defined inherited attribute with override

    $attrmeta = $test->_grok_inherited_attrib($meta, $instance,
                                              'color', 'string', 'blue',
                                              'popup_menu');
    # a metadatum inherited as is
    $test->assert($attrmeta->get_synopsis eq 'Gimme Color',
                  'color synopsis happily inherited');


# After Class::Tangram overhaul - why doesn't this pass?

    # snoop the override
#    $test->assert($attrmeta->get_ui->get_label eq 'Gotcha!',
#                  'color label happily overridden in subclass');

}


sub _grok_inherited_attrib {
    my ($test, $meta, $instance, $attr, $type, $value, $widget_name) = @_;

    #   See if we can use the attrib
    my $setter = 'set_'.$attr;
    my $getter = 'get_'.$attr;
    eval { $instance->$setter($value); };
    $test->assert( ! $@, "exception during set of inherited attr $attr: $@");
    my $gotval = eval { $instance->$getter; };
    $test->assert( $gotval eq $value, "$attr getter returns expected value");

    #   Do we have metadata for this inherited attribute?
    $test->assert(UNIVERSAL::isa($meta, 'Myco::Entity::Meta'),
		  'we have us a ::Meta object');
    my $attrmeta = $meta->get_attributes->{$attr};
    $test->assert(defined $attrmeta, "attr $attr has metadata");
    $test->assert($attrmeta->get_type eq $type,
                  "attr '$attr' metadatum 'type'");

    #   Poke about the ui attr metadata
    my $ui = eval { $attrmeta->get_ui };
    $test->assert(UNIVERSAL::isa($ui,
                                 'Myco::Entity::Meta::Attribute::UI'),
		  "for attr '$attr' we have us a ::Meta::Attr::UI object. "
                  .'ref $ui=='. ref $ui);
    my $widget = $ui->get_widget;
    $test->assert(defined(@$widget) && @$widget,
                  "widget is set for attr $attr");
    $test->assert($widget->[0] eq $widget_name,
                "for attr '$attr' inherited widget spec looks good...\n"
                  ."\tor not:  wanted '$widget_name', got '$widget->[0]'")
      if $widget_name;

    return $attrmeta;
}


sub test_displayname {
    my $test = shift;
    return if $test->should_skip;    # skip over this test if asked

    my $instance = eval { $samplepkg->new(name => ENDER); };
    $test->assert( ! $@, "creating instance: $@");

    ## Use the displayname... on a class/instance without one set
    my $ident = eval { $instance->displayname; };