weaken results from the CPAN

Class-InsideOut

package Class::InsideOut;
use strict;
# ABSTRACT: a safe, simple inside-out object construction kit

our $VERSION = '1.14';

use vars qw/@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS/;

@ISA         = qw ( Exporter );
@EXPORT      = qw ( ); # nothing by default
@EXPORT_OK   = qw ( new id options private property public readonly register );
%EXPORT_TAGS = (
    "std"       => [ qw( id private public readonly register ) ],
    "new"       => [ qw( new ) ],
    "all"       => [ @EXPORT_OK ],
    "singleton" => [], # just a flag for import()
);

use Carp;
use Exporter;
use Class::ISA;
use Scalar::Util 1.09 qw( refaddr reftype blessed );

# Check for XS Scalar::Util with weaken() or warn and fallback
# syntax of error changed in Scalar::Util so we check both versions
BEGIN {
    eval { Scalar::Util->import( "weaken" ) };
    if ( $@ =~ /\AWeak references|weaken is only available/ ) {
        warn "Scalar::Util::weaken unavailable: "
           . "Class::InsideOut will not be thread-safe and will leak memory\n";
        *weaken = sub { return @_ };
    }
}

#--------------------------------------------------------------------------#
# Class data
#--------------------------------------------------------------------------#

my %PROP_DATA_FOR;      # class => { prop_name => property hashrefs }
my %PUBLIC_PROPS_FOR;   # class => { prop_name => 1 }
my %CLASS_ISA;          # class => [ list of self and @ISA tree ]
my %OPTIONS;            # class => { default accessor options  }
my %OBJECT_REGISTRY;    # refaddr => weak object reference

#--------------------------------------------------------------------------#
# option validation parameters
#--------------------------------------------------------------------------#

# Private but global so related classes can define their own valid options
# if they need them.  Modify at your own risk.  Done this way so as to 
# avoid creating class functions to do the same basic thing

use vars qw( %_OPTION_VALIDATION );

sub __coderef {
    return 1 if reftype($_[0])||"" eq 'CODE';
    
    # Avoid loading overload.pm unless we'd have to die otherwise
    require overload;
    return 1 if overload::Overloaded($_[0]) && overload::Method($_[0], q[&{}]);
    
    die "must be a code reference";
}

%_OPTION_VALIDATION = (
    privacy => sub { 
        my $v = shift; 
        $v =~ /public|private/ or die "'$v' is not a valid privacy setting"
    },
    set_hook =>  \&__coderef,
    get_hook =>  \&__coderef,
);

#--------------------------------------------------------------------------#
# public functions
#--------------------------------------------------------------------------#

sub import {
    no strict 'refs';
    my $caller = caller;
    *{ "$caller\::DESTROY" } = _gen_DESTROY( $caller );
    # check for ":singleton" and do export attach instead of thaw
    if ( grep { $_ eq ":singleton" } @_ ) {
        *{ "$caller\::STORABLE_freeze" } = _gen_STORABLE_freeze( $caller, 1 );
        *{ "$caller\::STORABLE_attach" } = _gen_STORABLE_attach( $caller );
        @_ = grep { $_ ne ':singleton' } @_; # strip it back out
    }
    else {
        *{ "$caller\::STORABLE_freeze" } = _gen_STORABLE_freeze( $caller, 0 );
        *{ "$caller\::STORABLE_thaw" } = _gen_STORABLE_thaw( $caller );
    }

lib/Class/InsideOut.pm view on Meta::CPAN


    return $self;
}

sub private($\%;$) { ## no critic -- prototype
    &_check_property;
    $_[2] ||= {};
    $_[2] = { %{$_[2]}, privacy => 'private' };
    goto &_install_property;
}

sub property($\%;$) { ## no critic -- prototype
    &_check_property;
    goto &_install_property;
}

sub public($\%;$) { ## no critic -- prototype
    &_check_property;
    $_[2] ||= {};
    $_[2] = { %{$_[2]}, privacy => 'public' };
    goto &_install_property;
}

sub readonly($\%;$) { ## no critic -- prototype
    &_check_property;
    $_[2] ||= {};
    $_[2] = { 
        %{$_[2]}, 
        privacy => 'public',
        set_hook => sub { die "is read-only\n" }
    };
    goto &_install_property;
}

sub register {
    my ($obj);
    if    ( @_ == 0 ) {
        # register()
        croak "Invalid call to register(): empty argument list"
    }
    elsif ( @_ == 1 ) {
        # register( OBJECT | CLASSNAME )
        if    ( blessed $_[0] ) {
            $obj = shift;
        }
        elsif ( ref \$_[0] eq 'SCALAR' ) {
            $obj = \(my $scalar);
            bless $obj, shift;
        }
        else {
            croak "Invalid argument '$_[0]' to register(): " .
                  "must be an object or class name"
        }
    }
    else {
        # register( REFERENCE/OBJECT, CLASSNAME )
        $obj = shift;
        bless $obj, shift; # ok to rebless
    }
    
    weaken( $OBJECT_REGISTRY{ refaddr $obj } = $obj );
    return $obj;
}

#--------------------------------------------------------------------------#
# private functions for implementation
#--------------------------------------------------------------------------#

# Registering is global to avoid having to register objects for each class.
# CLONE is not exported but CLONE in Class::InsideOut updates all registered
# objects for all properties across all classes

sub CLONE {
    my $class = shift;

    # assemble references to all properties for all classes
    my @properties = map { values %$_ } values %PROP_DATA_FOR;

    for my $old_id ( keys %OBJECT_REGISTRY ) {

        # retrieve the new object and id
        my $object = $OBJECT_REGISTRY{ $old_id };
        my $new_id = refaddr $object;

        # for all properties, relocate data to the new id if
        # the property has data under the old id
        for my $prop ( @properties ) {
            next unless exists $prop->{ $old_id };
            $prop->{ $new_id } = $prop->{ $old_id };
            delete $prop->{ $old_id };
        }

        # update the registry to the new, cloned object
        weaken ( $OBJECT_REGISTRY{ $new_id } = $object );
        _deregister( $old_id );
    }
}

sub _check_options{
    my ($opt) = @_;
    local $Carp::CarpLevel = $Carp::CarpLevel + 1;

    croak "Invalid options argument '$opt': must be a hash reference"
        if ref $opt ne 'HASH';

    my @valid_keys = keys %_OPTION_VALIDATION;
    for my $key ( keys %$opt ) {
        croak "Invalid option '$key': unknown option"
            if ! grep { $_ eq $key } @valid_keys;
        eval { $_OPTION_VALIDATION{$key}->( $opt->{$key} ) };
        croak "Invalid option '$key': $@" if $@;
    }
    
    return;
}

sub _check_property {
    my ($label, $hash, $opt) = @_;
    local $Carp::CarpLevel = $Carp::CarpLevel + 1;
    croak "Invalid property name '$label': must be a perl identifier"
        if $label !~ /\A[a-z_]\w*\z/i;
    croak "Duplicate property name '$label'"
        if grep { $_ eq $label } keys %{ $PROP_DATA_FOR{ caller(1) } }; 
    _check_options( $opt ) if defined $opt;
    return;
}

sub _class_tree {
    my $class = shift;
    $CLASS_ISA{ $class } ||= [ Class::ISA::self_and_super_path( $class ) ];
    return @{ $CLASS_ISA{ $class } };
}

# take either object or object id
sub _deregister {
    my ($arg) = @_;
    my $obj_id = ref $arg ? refaddr $arg : $arg;
    delete $OBJECT_REGISTRY{ $obj_id };
    return;
}

# turn object into hash -- see _revert()
sub _evert {
    my ( $obj ) = @_;
        
    # Extract properties to save
    my %property_vals;
    for my $c ( _class_tree( ref $obj) ) {
        next unless exists $PROP_DATA_FOR{ $c };
        my $properties = $PROP_DATA_FOR{ $c };
        for my $prop ( keys %$properties ) {
            my $value = exists $properties->{$prop}{ refaddr $obj }
                      ? $properties->{$prop}{ refaddr $obj }
                      : undef ;

lib/Class/InsideOut.pm view on Meta::CPAN

  register( $class );                   # automatic blessed scalar

Registers objects for thread-safety.  This should be called as part of a
constructor on a object blessed into the current package.  Returns the
resulting object.  When called with only a class name, C<<< register >>> will bless an
anonymous scalar reference into the given class.  When called with both a
reference and a class name, C<<< register >>> will bless the reference into the class.

=head1 OPTIONS

Options customize how properties are generated.  Options may be set as a
default with the C<<< options >>> function or passed as a hash reference to 
C<<< public >>>, C<<< private >>> or C<<< property >>>.  

Valid options include:

=head2 C<<< privacy >>> 

  property rank => my %rank, { privacy => 'public' };
  property serial => my %serial, { privacy => 'private' };

If the I<privacy> option is set to I<public>, an accessor will be created
with the same name as the label.  If the accessor is passed an argument, the
property will be set to the argument.  The accessor always returns the value of
the property.

=head2 C<<< get_hook >>>

  public list => my %list, {
      get_hook => sub { @$_ }
  };

Defines an accessor hook for when values are retrieved.  C<<< $_ >>> is locally
aliased to the property value for the object.  I<The return value of the hook is
passed through as the return value of the accessor.> See "Customizing Accessors"
in L<Class::InsideOut::Manual::Advanced> for details.

The hook must be a coderef, including blessed coderefs and overloaded objects.

=head2 C<<< set_hook >>>

  public age => my %age, {
     set_hook => sub { /^\d+$/ or die "must be an integer" }
  };

Defines an accessor hook for when values are set. The hook subroutine receives
the entire argument list.  C<<< $_ >>> is locally aliased to the first argument for
convenience.  The property receives the value of C<<< $_ >>>. See "Customizing
Accessors" in L<Class::InsideOut::Manual::Advanced> for details.

The hook must be a coderef, including blessed coderefs and overloaded objects.

=head1 SEE ALSO

Programmers seeking a more full-featured approach to inside-out objects are
encouraged to explore L<Object::InsideOut>.  Other implementations are also
noted in L<Class::InsideOut::Manual::About>.

=head1 KNOWN LIMITATIONS

Requires weak reference support (Perl E<gt>= 5.6) and Scalar::Util::weaken() to
avoid memory leaks and to provide thread-safety.

=head1 ROADMAP

Features slated for after the 1.0 release include:

=over

=item *

Adding support for L<Data::Dump::Streamer> serialization hooks

=item *

Adding additional accessor styles (e.g. get_name()E<sol>set_name())

=item *

Further documentation revisions and clarification

=back

=for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan

=head1 SUPPORT

=head2 Bugs / Feature Requests

Please report any bugs or feature requests through the issue tracker
at L<https://github.com/dagolden/class-insideout/issues>.
You will be notified automatically of any progress on your issue.

=head2 Source Code

This is open source software.  The code repository is available for
public review and contribution under the terms of the license.

L<https://github.com/dagolden/class-insideout>

  git clone https://github.com/dagolden/class-insideout.git

=head1 AUTHOR

David Golden <dagolden@cpan.org>

=head1 CONTRIBUTORS

=for stopwords Karen Etheridge Toby Inkster

=over 4

=item *

Karen Etheridge <ether@cpan.org>

=item *

Toby Inkster <tonyink@cpan.org>

=back

( run in 1.673 second using v1.01-cache-2.11-cpan-39bf76dae61 )