view release on metacpan or  search on metacpan

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

use warnings; use strict;
use Test::More;

my $n_tests;

use Alter qw( alter ego);

# diag "The Alter::corona() function";
{
    use Symbol;
    use Scalar::Util qw( reftype weaken);
    
    our @obs;
    BEGIN { @obs = ( \ do { my $o }, [], {}, gensym, sub {}, \ []) }

    # create corona for all types
    for my $obj ( @obs ) {
        my $type = reftype $obj;
        my $crown = Alter::corona( $obj);
        is reftype( $crown), 'HASH', "got corona for $type";
    }

    # check that corona fails for invalid objects
    eval { Alter::corona( undef) };
    like $@, qr/Alter:/, "corona( undef) dies";
    eval { Alter::corona( 'abc') };
    like $@, qr/^Alter:/, "corona('abc') dies (non-ref)";
    eval { Alter::corona( \ 123) };
    like $@, qr/^Alter:/, "corona(\\ 123) dies (read-only)";

    # see if the corona is garbage-collected
    my $obj = [];
    # pure perl implementation needs destructor
    bless $obj, 'Alter::Destructor' unless Alter::is_xs();
    my $crown = Alter::corona( $obj);
    weaken $crown;
    is reftype( $crown), "HASH", "got a corona";
    undef $obj;
    is $crown, undef, "corona garbage-collected";

    BEGIN { $n_tests += @obs + 3 + 2 }
}

# diag "The alter() and ego() functions";
{
    my $obj = {};
    my %ego_tab;
    my %access_tab;

    # normal behavior
    {
        package One;
        my $class = __PACKAGE__;
        my $ego = [];
        $ego_tab{ $class} = $ego;
        $access_tab{ $class} = sub { main::ego shift }; # deposit accessor code
        my $res = main::alter( $obj, $ego);
        main::is $res, $obj, "alter() in class '$class' accepted";
        $res = main::ego( $obj);
        main::is $res, $ego, "ego() retrieves ego in class '$class'";
    }

    {
        package Two;
        my $class = __PACKAGE__;
        my $ego = {};
        $ego_tab{ $class} = $ego;
        $access_tab{ $class} = sub { main::ego shift }; # deposit accessor code
        my $res = main::alter( $obj, $ego);
        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