view release on metacpan or  search on metacpan

lib/Alter.pm  view on Meta::CPAN

    package Alter::Storable;

    my $running; # indicate if the call is (indirectly) from ourselves
    sub STORABLE_freeze {
        my ( $obj, $cloning) = @_;
        return if $cloning;
        return unless $running = !$running; # return if $running was true
        # $running now true, preventing recursion
        Storable::freeze( $obj->Alter::image);
    }

    # recognized (and preferred) by Storable 2.15+, (Perl v5.8.8)
    # ignored by earlier versions
    sub STORABLE_attach {
        my ( $class, $cloning, $ser) = @_;
        ++ our $attaching; # used by t/*.t, not needed for anything else
        $class->Alter::reify( Storable::thaw( $ser));
    }

    # recognized by all versions of Storable
    # incidentally, the code is equivalent to STORABLE_attach
    sub STORABLE_thaw {
        my ( $obj, $cloning, $ser) = @_;
        ++ our $thawing; # used by t/*.t, not needed for anything else
        $obj->Alter::reify( Storable::thaw( $ser));
    }
}

1;
__END__

=head1 NAME

Alter - Alter Ego Objects

=head2 Synopsis

  package MyClass;
  use Alter ego => {}; # Alter ego of type hash

  # Put data in it
  my $obj = \ do { my $o };
  ego( $obj)->{a} = 1;
  ego( $obj)->{b} = 2;

  # Retrieve it again
  print ego( $obj)->{ b}, "\n"; # prints 2

  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;

=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.

=item C<alter($obj, $val)>

Assigns C<$val> to the reference C<$obj> as an I<alter ego> for the caller's
class.  The class is the package into which the call to C<alter> is compiled.
Returns C<$obj> (I<not> the value assigned).

=item C<Alter::corona( $obj)>

Direct access to the I<corona> of I<alter ego>'s of C<$obj>.  The
corona is a hash keyed by class name in which the alter ego's of
an object are stored.  Unlike C<alter()> and C<ego()>, this function is
not caller-sensitive. Returns a reference to the corona hash, which
is created if necessary.  This function is not exported, if needed
it must be called fully qualified.

=item C<Alter::is_xs>

Returns a true value if the XS implementation of C<Alter> is active,
false if the pure Perl fallback is in place.

=back

=head3 Autovivification

You can set one of the types C<SCALAR>, C<ARRAY>, C<HASH> or C<GLOB> for
autovivification of the alter ego.  This is done by specifying the
type in a C<use> statement, as in

    package MyClass;
    use Alter 'ARRAY';

If the C<ego()> function is later called from C<MyClass> before an alter
ego has been specified using C<alter()>, a new I<array reference> will
be created and returned.  Autovivification happens only once
per class and object.  (You would have to delete the class entry from
the object's corona to make it happen again.)

The type specification can also be a referece of the appropriate
type, so C<[]> can be used for C<"ARRAY"> and C<{}> for C<"HASH">
(globrefs and scalar refs can also be used, but are less attractive).

Type specification can be combined with function imports.  Thus

    package MyClass;
    use Alter ego => {};

imports the C<ego()> function and specifies a hash tape for
autovivification.  With autovivification you will usually
not need to import the C<alter> function at all.

lib/Alter.pm  view on Meta::CPAN

to the user, but the C<Alter::corona()> function (not exported)
allows direct access if needed.

=head2 Example

The example first shows how a class C<Name> is built from two
classes C<First> and C<Last> which implement the first and last
names separately.  C<First> treats its objects as hashes whereas
C<Last> uses them as arrays.  Nevertheless, the code in C<Name> that
joins the two classes via subclassing is straightforward.

The second part of the example shows that C<Alter> classes actually
support black-box inheritance.  Here, we use an object of class
C<IO::File> as the "carrier" object.  This must be a globref to work.
This object can be initialized to the class C<Name>, which in part
sees it as a hash, in another part as an array.  Methods of both
classes now work on the object.

    #!/usr/local/bin/perl
    use strict; use warnings; $| = 1;

    # Show that class Name works
    my $prof = Name->new( qw( Albert Einstein));
    print $prof->fname, "\n";
    print $prof->lname, "\n";
    print $prof->name, "\n";


    # Share an object with a foreign class
    {
        package Named::Handle;
        use base 'IO::File';
        push our @ISA, qw( Name);

        sub new {
            my $class = shift;
            my ( $file, $first, $last) = @_;
            $class->IO::File::new( $file)->init( $first, $last);
        }

        sub init {
            my $nh = shift;
            $nh->Name::init( @_);
        }
    }

    my $nh = Named::Handle->new( '/dev/null', 'Bit', 'Bucket');
    print "okay, at eof\n" if $nh->eof; # IO::File methods work
    print $nh->name, "\n";      # ...as do Name methods

    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);
            @_ ? $l->[ 0] = shift : $l->[ 0];
        }
    }

    {
        package Name;
        use base 'First';
        use base 'Last';

        sub init {
            my $n = shift;
            $n->First::init( shift);
            $n->Last::init( shift);
        }

        sub name {
            my $n = shift;
            join ' ' => $n->fname, $n->lname;
        }
    }

    __END__

=head2 Thanks

Thanks to Abigail who invented the inside-out technique, showhing I<what>
the problem is with Perl inheritance and I<how> it could be overcome
with just a little stroke of genius.

Thanks also to Jerry Hedden for making me aware of the possibilities
of C<ext> magic on which this implementation of C<Alter> is built.

=head1 Author

Anno Siegel, E<lt>anno4000@zrz.tu-berlin.deE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2007 by Anno Siegel

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.7 or,
at your option, any later version of Perl 5 you may have available.

=cut