Alter

 view release on metacpan or  search on metacpan

README  view on Meta::CPAN

      package OtherClass;
      defined( ego $obj) or die; # dies, OtherClass hasn't set an alter ego

      # Direct access to the corona of alter egos
      my $crown = Alter::corona $obj;

  Functions
   Basic Functions
    The functions described here accept a first argument named $obj. Despite
    the name, $obj can be any reference, it doesn't *have* to be blessed
    (though it usually will be). It is a fatal error if it is not a
    reference or if the reference points to a read-only value.

    "ego($obj)"
        Retrieves the class-specific *alter ego* assigned to $obj by
        "alter()" or by autovivification if that is enabled. If neither is
        the case, an undefined value is returned. The class is the package
        into which the call to "ego()" is compiled.

    "alter($obj, $val)"

README  view on Meta::CPAN

        exit;

        #######################################################################

        {
            package First;
            use Alter qw( alter ego);

            sub new {
                my $class = shift;
                bless( \ my $o, $class)->init( @_);
            }

            sub init {
                my $f = shift;
                alter $f, { name => shift };
                $f;
            }

            sub fname {
                my $h = ego shift;
                @_ ? $h->{ name} = shift : $h->{ name};
            }
        }

        {
            package Last;
            use Alter qw( alter ego);

            sub new {
                my $class = shift;
                bless( \ my $o, $class)->init( @_);
            }

            sub init {
                my $l = shift;
                alter $l, [ shift];
                $l;
            }

            sub lname {
                my $l = ego( shift);

lib/Alter.pm  view on Meta::CPAN

  # Direct access to the corona of alter egos
  my $crown = Alter::corona $obj;

=head2 Functions

=head3 Basic Functions

The functions described here accept a first argument named $obj.
Despite the name, C<$obj> can be any reference, it doesn't I<have>
to be blessed (though it usually will be).  It is a fatal error
if it is not a reference or if the reference points to a read-only value.

=over

=item C<ego($obj)>

Retrieves the class-specific I<alter ego> assigned to C<$obj> by
C<alter()> or by L<autovivification|/Autovivification> if that is
enabled.  If neither is the case, an undefined value is returned.
The class is the package into which the call to C<ego()> is compiled.

lib/Alter.pm  view on Meta::CPAN

    exit;

    #######################################################################

    {
        package First;
        use Alter qw( alter ego);

        sub new {
            my $class = shift;
            bless( \ my $o, $class)->init( @_);
        }

        sub init {
            my $f = shift;
            alter $f, { name => shift };
            $f;
        }

        sub fname {
            my $h = ego shift;
            @_ ? $h->{ name} = shift : $h->{ name};
        }
    }

    {
        package Last;
        use Alter qw( alter ego);

        sub new {
            my $class = shift;
            bless( \ my $o, $class)->init( @_);
        }

        sub init {
            my $l = shift;
            alter $l, [ shift];
            $l;
        }

        sub lname {
            my $l = ego( shift);

ppport.h  view on Meta::CPAN

sv_2pvbyte_nolen|||
sv_2pvbyte|5.006000||p
sv_2pvutf8_nolen||5.006000|
sv_2pvutf8||5.006000|
sv_2pv|||
sv_2uv_flags||5.009001|
sv_2uv|5.004000||p
sv_add_arena|||
sv_add_backref|||
sv_backoff|||
sv_bless|||
sv_cat_decode||5.008001|
sv_catpv_mg|5.004050||p
sv_catpvf_mg_nocontext|||pvn
sv_catpvf_mg|5.006000|5.004000|pv
sv_catpvf_nocontext|||vn
sv_catpvf||5.004000|v
sv_catpvn_flags||5.007002|
sv_catpvn_mg|5.004050||p
sv_catpvn_nomg|5.007002||p
sv_catpvn|||

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

    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";

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

        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;

t/03_class.t  view on Meta::CPAN

# and two_B are set to hold a reference to the same array.  This identity
# must survive a freeze-thaw cycle by either Data::Dumper or Storable

### Class_A

{
    package Class_A;

    sub init {
        my $obj = shift;
        $obj = bless {}, $obj unless ref $obj;
        $obj->{ one_A} = shift;
        $obj->{ two_A} = shift;
        $obj;
    }

    sub one_A { $_[ 0]->{ one_A} }
    sub two_A { $_[ 0]->{ two_A} }
}

{

t/03_class.t  view on Meta::CPAN

    BEGIN { $n_tests += 2 }
}

### Class_B
{
    package Class_B;
    use Alter ego => [];

    sub init {
        my $obj = shift;
        $obj = bless \ my( $o), $obj unless ref $obj;
        my $ego = ego( $obj);
        $ego->[ 0] = shift;
        $ego->[ 1] = shift;
        $obj;
    }

    sub one_B { ego( $_[ 0])->[ 0] }
    sub two_B { ego( $_[ 0])->[ 1] }
}