Alter

 view release on metacpan or  search on metacpan

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

lib/Alter/AlterXS_in_perl.pm  view on Meta::CPAN

    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;

ppport.h  view on Meta::CPAN

sv_pvutf8n||5.006000|
sv_pvutf8||5.006000|
sv_pv||5.006000|
sv_recode_to_utf8||5.007003|
sv_reftype|||
sv_release_COW|||
sv_release_IVX|||
sv_replace|||
sv_report_used|||
sv_reset|||
sv_rvweaken||5.006000|
sv_setiv_mg|5.004050||p
sv_setiv|||
sv_setnv_mg|5.006000||p
sv_setnv|||
sv_setpv_mg|5.004050||p
sv_setpvf_mg_nocontext|||pvn
sv_setpvf_mg|5.006000|5.004000|pv
sv_setpvf_nocontext|||vn
sv_setpvf||5.004000|v
sv_setpviv_mg||5.008001|

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

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

    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 = {};