view release on metacpan or  search on metacpan

t/02_function.t  view on Meta::CPAN

        main::is $res, $obj, "alter() in class '$class' accepted";
        $res = main::ego( $obj);
        main::is $res, $ego, "ego() retrieves ego in class '$class'";
    }
    my %ret_tab;
    {
        package One;
        $ret_tab{ +__PACKAGE__} = main::ego $obj;
    }
    {
        package Two;
        $ret_tab{ +__PACKAGE__} = main::ego $obj;
    }
    for my $class ( qw( One Two) ) {
        is $ret_tab{ $class}, $ego_tab{ $class},
            "Class dependent retrieval for class '$class'";
        is $access_tab{ $class}->( $obj), $ego_tab{ $class},
            "Accessor retrieval for class '$class'";
    }
    BEGIN { $n_tests += 8 }

    # marginal behavior
    eval { alter( 'abc', 0) };
    like $@, qr/Alter:/, "alter( non-ref) dies";
    eval { alter( \ 123, 0) };
    like $@, qr/Alter:/, "alter( \\ read-only) dies";
    eval 'alter()'; # prototyping, catch at compile time
    like $@, qr/^Not enough arguments/, "alter() prototype active";
    eval { &alter( '') }; # protoyping disabled, catch at run time
    like $@, qr/^Usage/, "&alter() dies with one argument";
    eval { &alter() };
    like $@, qr/^Usage/, "&alter() dies without arguments";

    eval { ego( 'abc') };
    like $@, qr/Alter:/, "ego( non-ref) dies";
    eval { ego( \ 123) };
    like $@, qr/Alter:/, "ego( \\ read-only) dies";
    my @res = ego( []);
    ok @res == 1 && ! defined $res[ 0], "ego(uncommitted_obj) returns undef";
    eval 'ego()';
    like $@, qr/^Not enough arguments/, "ego() prototype active";
    eval { &ego() };
    like $@, qr/^Usage/, "&ego() dies without arguments";

    BEGIN { $n_tests += 10 }
}

# diag "Autovivifying behavior";
{
    use Scalar::Util qw( reftype);
    use Symbol;
    my $obj = \ do { my $o };
    our ( @supported, @unsupported);
    BEGIN {
        @supported = (
            \ do { my $o }, # scalar
            [],             # array
            {},             # hash
        );
        @unsupported = (
            gensym(),       # glob (glob is disabled)
            sub {},         # code
        );
    }
    my $template = <<"EOC";
        package Class_TYPE;
        use Alter 'alter', ego => 'TYPE';
        sub access_ego { ego( shift) }
EOC
    for my $type ( map reftype( $_) => @supported ) {
        ( my $code = $template) =~ s/TYPE/$type/g;
        no warnings "redefine";
        eval $code;
        die $@ if $@;
    }
    for my $type ( map reftype( $_) => @unsupported ) {
        ( my $code = $template) =~ s/TYPE/$type/g;
        eval $code;
        like $@, qr/not exported/, "Unsupported type '$type' rejected";
    }
    for ( @supported ) {
        my $type = reftype $_;
        my $class = "Class_$type";
        my $meth = $class->can( 'access_ego');
        my $ans = $obj->$meth;
        is reftype $ans, $type, "Autovivification with type '$type'";
    }
    for my $type ( 'NONE' ) {
        package Class_NONE;
        use Alter ego => {};       # switch to anything
        use Alter ego => 'NOAUTO'; # switch off again
        my $obj = bless [];
        main::is ego( $obj), undef, "No autovivification with type '$type'";
    }
    BEGIN { $n_tests += @unsupported + @supported + 1 }
}

# diag "The keywords -dumper and -storable";
# only checking the effect on @ISA here, actual function checked in 03_class.t
{
    {
        package A1;
        Alter->import( '-dumper');
        Alter->import( 'Dumper');

        package A2;
        Alter->import( '-storable');
        Alter->import( 'STORABLE_freeze');

        package B;
        Alter->import();
        Alter->import(); # only first one pushes
    }
    is grep( $_ eq 'Alter::Dumper', @A1::ISA), 0,
        "'-dumper' etc. don't push 'Alter::Dumper'";
    is grep( $_ eq 'Alter::Storable', @A2::ISA), 0,
        "'-storable' etc. don't push 'Alter::Storable'";
    is grep( $_ eq 'Alter::Dumper', @B::ISA), 1,
        "plain use pushes 'Alter::Dumper'";
    is grep( $_ eq 'Alter::Storable', @B::ISA), 1,
        "plain use pushes 'Alter::Storable'";