Alter
view release on metacpan or search on metacpan
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#define NEED_newRV_noinc
#include "ppport.h"
/* id-key for ext magic (Hi, Eva, David) */
#define ALT_EXTMG_CORONA 2805 + 1811
/* basic access to an object's corona (may croak) */
HV *ALT_corona(SV *obj) {
HV *corona;
SV *self;
MAGIC *mg;
if (!SvROK(obj) )
Perl_croak(aTHX_ "Alter: Can't use a non-reference");
self = SvRV(obj);
if (SvREADONLY(self))
Perl_croak(aTHX_ "Alter: Can't modify a read-only value");
if (SvTYPE(self) < SVt_PVMG)
(void) SvUPGRADE(self, SVt_PVMG);
for (mg = SvMAGIC(self); mg; mg = mg->mg_moremagic) {
if ((mg->mg_type == PERL_MAGIC_ext) &&
(mg->mg_private == ALT_EXTMG_CORONA)
) break;
}
if (!mg) {
corona = newHV();
mg = sv_magicext(self, (SV*)corona, PERL_MAGIC_ext, NULL, NULL, 0);
SvREFCNT_dec(corona); /* must compensate */
mg->mg_private = ALT_EXTMG_CORONA;
} else {
corona = (HV*)mg->mg_obj;
}
return corona;
}
/* Access to the type table (program-wide, i.e. not thread-duplicated)
* This hash holds an SvTYPE (as an integer SV) for every class that
* wants to autovivify the ego
*/
HV *ALT_type_tab() {
static HV *type_tab = NULL;
if (!type_tab)
type_tab = newHV();
/*
void is_xs()
PPCODE:
ST(0) = newSViv(1);
sv_2mortal(ST(0));
XSRETURN(1);
*/
MODULE = Alter PACKAGE = Alter
SV *corona(SV *obj)
PROTOTYPE: $
PREINIT:
HV *corona;
CODE:
corona = ALT_corona(obj);
if (!corona)
XSRETURN_EMPTY;
RETVAL = newRV_inc((SV*)corona);
OUTPUT:
RETVAL
SV *alter(SV *obj, SV *val)
PROTOTYPE: $$
PREINIT:
HV *corona;
char *class;
CODE:
corona = ALT_corona(obj);
if (!corona)
XSRETURN_EMPTY;
class = CopSTASHPV(PL_curcop);
hv_store(corona, class, strlen(class), SvREFCNT_inc(val), 0);
RETVAL = SvREFCNT_inc(obj); /* method chaining */
OUTPUT:
RETVAL
SV *ego(SV *obj, ...)
PROTOTYPE: $
CODE:
HV *corona = ALT_corona(obj);
char *class;
SV **ego_ptr;
SV *ego;
if (!corona)
XSRETURN_EMPTY;
class = CopSTASHPV(PL_curcop);
if ((ego_ptr = hv_fetch(corona, class, strlen(class), 0))) {
ego = *ego_ptr;
} else {
if ( (ego = ALT_vivify(class)) ) {
hv_store(corona, class, strlen(class), ego, 0);
}
}
if (!ego)
XSRETURN_UNDEF;
RETVAL = SvREFCNT_inc(ego);
OUTPUT:
RETVAL
void _set_class_type(char *class, SV *spec)
CODE:
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;
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)"
Assigns $val to the reference $obj as an *alter ego* for the
caller's class. The class is the package into which the call to
"alter" is compiled. Returns $obj (*not* the value assigned).
"Alter::corona( $obj)"
Direct access to the *corona* of *alter ego*'s of $obj. The corona
is a hash keyed by class name in which the alter ego's of an object
are stored. Unlike "alter()" and "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.
"Alter::is_xs"
Returns a true value if the XS implementation of "Alter" is active,
false if the pure Perl fallback is in place.
Autovivification
You can set one of the types "SCALAR", "ARRAY", "HASH" or "GLOB" for
autovivification of the alter ego. This is done by specifying the type
in a "use" statement, as in
package MyClass;
use Alter 'ARRAY';
If the "ego()" function is later called from "MyClass" before an alter
ego has been specified using "alter()", a new *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 "[]" can be used for "ARRAY" and "{}" for "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 => {};
(within the limitations of the respective modules).
"Alter" works by giving every object a class-specific *alter ego*, which
can be any scalar, for its (the classe's) specific needs for data
storage. The alter ego is set by the "alter()" function (or by
autovivification), usually once per class and object at initialization
time. It is retrieved by the "ego()" function in terms of which a class
will define its accessors.
That works by magically (in the technical sense of "PERL_MAGIC_ext")
assigning a hash keyed by classname, the *corona*, to every object that
takes part in the game. The corona holds the individual alter ego's for
each class. It is created when needed and stays with an object for its
lifetime. It is subject to garbage collection when the object goes out
of scope. Normally the corona is invisible to the user, but the
"Alter::corona()" function (not exported) allows direct access if
needed.
Example
The example first shows how a class "Name" is built from two classes
"First" and "Last" which implement the first and last names separately.
"First" treats its objects as hashes whereas "Last" uses them as arrays.
Nevertheless, the code in "Name" that joins the two classes via
subclassing is straightforward.
The second part of the example shows that "Alter" classes actually
lib/Alter.pm view on Meta::CPAN
no strict 'refs';
push @{ join '::' => $client, 'ISA' }, $base;
}
### Serialization support: ->image and ->reify
# Key to use for object body in image (different from any class name)
use constant BODY => '(body)';
# create a hash image of an object that contains the body and
# corona data
sub image {
my $obj = shift;
+{
BODY() => $obj,
%{ corona( $obj) }, # shallow copy
};
}
# recreate the original object from an image. When called as a
# class method, take the object from the "(body)" entry in image
# (the class is ignored). Called as an object method, re-model
# the given object (whose data is lost) to match the image. In
# this case, the types of the given object and the "(body)" entry
# must match, or else... Also, the ref type must be supported
# ("CODE" isn't).
sub reify {
my $obj = shift;
my $im = shift;
if ( ref $obj ) {
my $orig = delete $im->{ BODY()};
_transfer_content( $orig, $obj);
} else {
$obj = delete $im->{ BODY()};
}
%{ corona( $obj)} = %$im;
$obj;
}
my %trans_tab = (
SCALAR => sub { ${ $_[ 1] } = ${ $_[ 0] } },
ARRAY => sub { @{ $_[ 1] } = @{ $_[ 0] } },
HASH => sub { %{ $_[ 1] } = %{ $_[ 0] } },
GLOB => sub { *{ $_[ 1] } = *{ $_[ 0] } },
);
lib/Alter.pm view on Meta::CPAN
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.
lib/Alter.pm view on Meta::CPAN
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
lib/Alter.pm view on Meta::CPAN
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 => {};
lib/Alter.pm view on Meta::CPAN
and made persistent (within the limitations of the respective modules).
C<Alter> works by giving every object a class-specific I<alter ego>,
which can be any scalar, for its (the classe's) specific needs for
data storage. The alter ego is set by the C<alter()> function (or
by autovivification), usually once per class and object at initialization
time. It is retrieved by the C<ego()> function in terms of which
a class will define its accessors.
That works by magically (in the technical sense of C<PERL_MAGIC_ext>)
assigning a hash keyed by classname, the I<corona>, to every object
that takes part in the game. The corona holds the individual alter
ego's for each class. It is created when needed and stays with
an object for its lifetime. It is subject to garbage collection
when the object goes out of scope. Normally the corona is invisible
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.
lib/Alter/AlterXS_in_perl.pm view on Meta::CPAN
package Alter;
use strict; use warnings;
### basic functions corona(), alter() and ego()
use Scalar::Util qw( readonly reftype weaken);
no warnings 'redefine'; # in case we're called after the XS version was loaded
my %corona_tab;
my %ob_reg;
sub corona ($) {
@_ == 1 or croak "Usage: Alter::corona(obj)";
my $obj = shift;
ref $obj or croak "Alter: Can't use a non-reference";
reftype $obj eq 'SCALAR' and readonly( $$obj) and
croak "Alter: Can't modify a read-only value";
my $id = $obj + 0;
$corona_tab{ $id} ||= do {
weaken( $ob_reg{ $id} = $obj);
{};
};
}
sub alter ($$) {
@_ == 2 or croak "Usage: Alter::alter(obj, val)";
my ( $obj, $val) = @_;
corona( $obj)->{ caller()} = $val;
$obj;
}
sub ego ($) {
@_ == 1 or die "Usage: Alter::ego(obj)";
my $obj = shift;
corona( $obj)->{ caller()} ||= _vivify( caller());
}
sub is_xs { 0 }
### Autovivification
my %type_tab;
sub _set_class_type {
my ( $class, $type) = @_;
lib/Alter/AlterXS_in_perl.pm view on Meta::CPAN
sub _vivify {
my $class = shift;
return undef unless $type_tab{ $class};
$viv_tab{ ref $type_tab{ $class}}->();
}
### Garbage collection and thread support
sub Alter::Destructor::DESTROY {
my $id = shift() + 0;
delete $corona_tab{ $id};
delete $ob_reg{ $id};
}
sub CLONE {
return unless shift eq __PACKAGE__;
for my $old_id ( keys %ob_reg ) {
my $new_obj = delete $ob_reg{ $old_id};
my $new_id = $new_obj + 0;
weaken( $ob_reg{ $new_id} = $new_obj);
$corona_tab{ $new_id} = delete $corona_tab{ $old_id};
}
}
1;
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;
( run in 0.800 second using v1.01-cache-2.11-cpan-87723dcf8b7 )