view release on metacpan or search on metacpan
lib/Circle/Net/Matrix.pm view on Meta::CPAN
use Circle::Widget::Box;
use Circle::Widget::Label;
use Data::Dump qw( pp );
use Scalar::Util qw( weaken );
=head1 NAME
C<Circle::Net::Matrix> - use C<Circle> as a I<Matrix> client
lib/Circle/Net/Matrix.pm view on Meta::CPAN
sub WEAKSELF_EVAL
{
my ( $self, $method ) = @_;
my $code = $self->can( $method ) or return sub {};
weaken( $self );
return sub {
my @args = @_;
eval { $self->$code( @args ); 1 } or
warn $@;
};
lib/Circle/Net/Matrix.pm view on Meta::CPAN
my $loop = $self->{loop} = $args{loop};
# For WindowItem
$self->set_prop_tag( $args{tag} );
weaken( my $weakself = $self );
my $matrix = $self->{matrix} = Net::Async::Matrix->new(
on_log => sub { }, # TODO
on_presence => $self->WEAKSELF_EVAL( 'on_presence' ),
on_room_new => $self->WEAKSELF_EVAL( 'on_room_new' ),
on_room_del => $self->WEAKSELF_EVAL( 'on_room_del' ),
view release on metacpan or search on metacpan
lib/Cisco/Reconfig.pm view on Meta::CPAN
use strict;
use Text::Tabs;
use Carp;
use Carp qw(verbose confess);
use IO::File;
use Scalar::Util qw(weaken);
my $iostrings;
our $allow_minus_one_indent = qr/class /;
our $allow_plus_one_indent = qr/service-policy |quit$/;
our $bad_indent_policy = 'DIE';
lib/Cisco/Reconfig.pm view on Meta::CPAN
my $config = bless { $bloc => 1 }, __PACKAGE__;
$config->{$debg} = "BLOCK:$dseq:$dcon" if $ddata;
$config->{$cntx} = $parent;
weaken $config->{$cntx};
$dseq++;
my $prev;
my $ciscobug;
for(;$line;$prev = $line, $line = <$fh>) {
lib/Cisco/Reconfig.pm view on Meta::CPAN
$context->{$seqn} = $seq++;
$context->{$text} = $line;
confess if $context->{$cntx};
$context->{$cntx} = $config;
weaken $context->{$cntx};
unless ($nonext) {
if ($last) {
$last->{$next} = $context;
weaken $last->{$next};
} else {
$config->{$next} = $context;
weaken $config->{$next};
}
}
$last = $context;
lib/Cisco/Reconfig.pm view on Meta::CPAN
#
die unless defined $1;
my $sep = qr/\Q$1\E/;
my $sub = $last->{$subs} = bless { $bloc => 1 }, __PACKAGE__;
$sub->{$cntx} = $last;
weaken $sub->{$cntx};
my $subnull = $sub->{''} = bless { $bloc => 1, $dupl => [] }, __PACKAGE__;
$subnull->{$cntx} = $sub;
weaken $subnull->{$cntx};
for(;;) {
$line = <$fh>;
last unless $line;
my $l = bless {
$ddata ? ( $debg => "$dseq:DUP:$line" ) : (),
}, __PACKAGE__;
$dseq++;
$l->{$seqn} = $seq++;
$l->{$text} = $line;
$l->{$cntx} = $subnull;
weaken($l->{$cntx});
push(@{$subnull->{$dupl}}, $l);
last if $line =~ /$sep[\r]?$/;
}
warn "parse probably failed"
unless $line && $line =~ /$sep[\r]?$/;
view release on metacpan or search on metacpan
lib/Cisco/UCS/Blade.pm view on Meta::CPAN
use warnings;
use strict;
use Carp qw(croak);
use Scalar::Util qw(weaken);
use Cisco::UCS::Blade::Adaptor;
use Cisco::UCS::Blade::CPU;
use Cisco::UCS::Blade::PowerBudget;
use Cisco::UCS::Common::PowerStats;
lib/Cisco/UCS/Blade.pm view on Meta::CPAN
defined $args{dn}
? $self->{dn} = $args{dn}
: croak 'dn not defined';
defined $args{ucs}
? weaken($self->{ucs} = $args{ucs})
: croak 'dn not defined';
my %attr = %{ $self->{ucs}->resolve_dn(
dn => $self->{dn})->{outConfig}->{computeBlade}
};
view release on metacpan or search on metacpan
lib/Class/Accessor/Grouped.pm view on Meta::CPAN
# now things are installed - one ref less to carry
delete $resolved_methods->{$current_class}{$methname};
# but need to record it in the expectation registry *in case* it
# was cached via ->can for some moronic reason
Scalar::Util::weaken( $cag_produced_crefs->{$resolved_implementation} = $resolved_implementation );
# older perls segfault if the cref behind the goto throws
# http://rt.perl.org/rt3/Public/Bug/Display.html?id=35878
return $resolved_implementation->(@_) if __CAG_ENV__::BROKEN_GOTO;
goto $resolved_implementation;
};
Scalar::Util::weaken($cag_produced_crefs->{$ret} = $ret);
$ret; # returning shim
}
# no Sub::Name - just install the coderefs directly (compiling every time)
view release on metacpan or search on metacpan
xs/accessors.h view on Meta::CPAN
PUSHs(slot); \
PUTBACK; \
} \
#define CALL_WRITE_WEAKEN(slot) \
if (opts & IsWeak) sv_rvweaken(slot)
#define READONLY_TYPE_ASSERT \
assert(type == Inherited || type == PrivateClass || type == ObjectOnly || type == LazyClass)
#define READONLY_CROAK_CHECK \
view release on metacpan or search on metacpan
lib/Class/Accessor/Lvalue.pm view on Meta::CPAN
use strict;
package Class::Accessor::Lvalue;
use base qw( Class::Accessor );
use Scalar::Util qw(weaken);
use Want qw( want );
our $VERSION = '0.11';
sub make_accessor {
my ($class, $field) = @_;
view release on metacpan or search on metacpan
lib/Class/AutoDB.pm view on Meta::CPAN
deletion: it is now possible for a variable to contain a reference
pointing to an object that has been deleted; likewise, an object can
contain a reference (technically an Oid) pointing to a deleted object.
The closest Perl analog is L<weak
references|Scalar::Util/"weaken_REF">. The standard Perl rule stated
above -- "an object exists until all references to the object cease to
exist" -- does not apply to weak references. A weak reference can go
stale (in other words, point to an object that no longer exists). When
this happens, Perl sets the reference to undef, and any attempt to
access the object via the stale reference generates an error.
view release on metacpan or search on metacpan
lib/Class/Builtin/Array.pm view on Meta::CPAN
sub shuffle {
__PACKAGE__->new( [ List::Util::shuffle @{ $_[0] } ] );
}
# Scalar::Util related
for my $meth (qw/blessed isweak refaddr reftype weaken/){
eval qq{
sub Class::Builtin::Array::$meth
{
my \$self = CORE::shift;
my \$ret = Scalar::Util::$meth(\$self);
view release on metacpan or search on metacpan
lib/Class/Cloneable.pm view on Meta::CPAN
use strict;
use warnings;
use overload ();
use Carp qw(confess);
use Scalar::Util qw(blessed reftype weaken isweak);
our $VERSION = '0.03';
sub clone {
(UNIVERSAL::isa((caller)[0], 'Class::Cloneable') ||
lib/Class/Cloneable.pm view on Meta::CPAN
|| confess "Illegal Operation : This method can only be called by a subclass of Class::Cloneable";
my ($to_clone, $cache, $ref_type) = @_;
(ref($to_clone) && (ref($cache) && ref($cache) eq 'HASH'))
|| confess "Insufficient Arguments : Must specify the object to clone and a valid cache";
$ref_type = ref($to_clone) unless defined $ref_type;
# check if it is weakened
my $is_weak;
$is_weak = 1 if isweak($to_clone);
my ($clone, $tied);
if ($ref_type eq 'HASH') {
$clone = {};
lib/Class/Cloneable.pm view on Meta::CPAN
# shallow copy reference to code, glob, regex
$clone = $to_clone;
}
# store it in our cache
$cache->{$to_clone} = $clone;
# and weaken it if appropriate
weaken($clone) if $is_weak;
# and return the clone
return $clone;
}
1;
view release on metacpan or search on metacpan
t/lib/Test/More.pm view on Meta::CPAN
use Test::More tests => $Num_Tests;
There are rare cases when you will not know beforehand how many tests
your script is going to run. In this case, you can declare that you
have no plan. (Try to avoid using this as it weakens your test.)
use Test::More qw(no_plan);
In some cases, you'll want to completely skip an entire testing script.
view release on metacpan or search on metacpan
lib/Class/Container.pm view on Meta::CPAN
my $HAVE_WEAKEN;
BEGIN {
eval {
require Scalar::Util;
Scalar::Util->import('weaken');
$HAVE_WEAKEN = 1;
};
*weaken = sub {} unless defined &weaken;
}
use Carp;
# The create_contained_objects() method lets one object
lib/Class/Container.pm view on Meta::CPAN
if ($HAVE_WEAKEN) {
my $c = $self->get_contained_object_spec;
foreach my $name (keys %$c) {
next if $c->{$name}{delayed};
$self->{$name}{container}{container} = $self;
weaken $self->{$name}{container}{container};
}
}
return $self;
}
lib/Class/Container.pm view on Meta::CPAN
my ($self, $name) = (shift, shift);
croak "Unknown delayed item '$name'" unless $self->{container}{contained}{$name}{delayed};
if ($HAVE_WEAKEN) {
push @_, container => {container => $self};
weaken $_[-1]->{container};
}
return $self->call_method($name, 'new', @_);
}
sub delayed_object_class
view release on metacpan or search on metacpan
self(self->next) instead of $_[0] = $_[0]->next.
- refactored all condition checking to use <C>generic_check</C> function
- revisted _inheritence and generic_check. Think I've finally got
weakening pre-conditional checks working correctly. There is a good
test covering this in t/method.t
1.04 Wed Jan 31 15:45:42 2001
1.00 Sun Aug 6 07:11:35 2000
- Changed semantics of preconditions.
Now only inherited if not defined in same class
(this conforms with the notion of derived classes
being allowed to weaken, but not strengthen preconditions).
- Added postconditions on SCALAR, ARRAY, and HASH attributes
- Added &value for attr conditions
view release on metacpan or search on metacpan
lib/Class/DBI/Frozen/301.pm view on Meta::CPAN
BEGIN {
$Weaken_Is_Available = 1;
eval {
require Scalar::Util;
import Scalar::Util qw(weaken);
};
if ($@) {
$Weaken_Is_Available = 0;
}
}
lib/Class/DBI/Frozen/301.pm view on Meta::CPAN
$obj = bless {}, $class;
$obj->_attribute_store(%$data);
# don't store it unless all keys are present
if ($obj_key && $Weaken_Is_Available) {
weaken($Live_Objects{$obj_key} = $obj);
# time to clean up your room?
$class->purge_dead_from_object_index
if ++$Init_Count % $class->purge_object_index_every == 0;
}
view release on metacpan or search on metacpan
lib/Class/DBI/Lite.pm view on Meta::CPAN
use vars qw( $Weaken_Is_Available %Live_Objects );
$Weaken_Is_Available = 1;
eval {
require Scalar::Util;
import Scalar::Util qw(weaken isweak);
};
$Weaken_Is_Available = 0 if $@;
}# end BEGIN:
lib/Class/DBI/Lite.pm view on Meta::CPAN
my $obj = bless $data, $class;
if( $Weaken_Is_Available && ! $is_void_context )
{
$Live_Objects{$key} = $obj;
weaken( $Live_Objects{$key} );
return $Live_Objects{$key};
}
else
{
return $obj;
view release on metacpan or search on metacpan
t/cdbi-t/02-Film.t view on Meta::CPAN
eval { $film = Film->retrieve('Goodbye Norma Jean') };
ok !$film, "It destroys itself";
}
SKIP: {
skip "Scalar::Util::weaken not available", 3
if !$Class::DBI::Weaken_Is_Available;
# my bad taste is your bad taste
my $btaste = Film->retrieve('Bad Taste');
my $btaste2 = Film->retrieve('Bad Taste');
view release on metacpan or search on metacpan
lib/Class/DBI.pm view on Meta::CPAN
BEGIN {
$Weaken_Is_Available = 1;
eval {
require Scalar::Util;
import Scalar::Util qw(weaken);
};
if ($@) {
$Weaken_Is_Available = 0;
}
}
lib/Class/DBI.pm view on Meta::CPAN
my $obj = bless {}, $class;
$obj->_attribute_store(%$data);
# don't store it unless all keys are present
if ($key && $Weaken_Is_Available) {
weaken($Live_Objects{$key} = $obj);
# time to clean up your room?
$class->purge_dead_from_object_index
if ++$Init_Count % $class->purge_object_index_every == 0;
}
lib/Class/DBI.pm view on Meta::CPAN
objects in memory. It is not a traditional cache - when your objects
go out of scope, they will be destroyed normally, and a future retrieve
will instantiate an entirely new object.
The ability to perform this magic for you replies on your perl having
access to the Scalar::Util::weaken function. Although this is part of
the core perl distribution, some vendors do not compile support for it.
To find out if your perl has support for it, you can run this on the
command line:
perl -e 'use Scalar::Util qw(weaken)'
If you get an error message about weak references not being implemented,
Class::DBI will not maintain this lookup index, but give you a separate
instances for each retrieve.
view release on metacpan or search on metacpan
lib/Class/EHierarchy.pm view on Meta::CPAN
use strict;
use warnings;
use vars qw($VERSION @EXPORT @EXPORT_OK %EXPORT_TAGS);
use base qw(Exporter);
use Carp;
use Scalar::Util qw(weaken);
($VERSION) = ( q$Revision: 2.01 $ =~ /(\d+(?:\.(\d+))+)/sm );
# Ordinal indexes for the @objects element records
use constant CEH_OREF => 0;
lib/Class/EHierarchy.pm view on Meta::CPAN
$objects[$id] = [];
$objects[$id][CEH_CREF] = [];
$objects[$id][CEH_CLASSES] = [];
$objects[$id][CEH_OREF] = $obj;
$objects[$id][CEH_PKG] = ref $obj;
weaken( $objects[$$obj][CEH_OREF] );
$id = '0 but true' if $id == 0;
# Build object class list
{
view release on metacpan or search on metacpan
sv_reftype|||
sv_release_COW|||
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
view release on metacpan or search on metacpan
t/lib/Test/More.pm view on Meta::CPAN
use Test::More tests => $Num_Tests;
There are rare cases when you will not know beforehand how many tests
your script is going to run. In this case, you can declare that you
have no plan. (Try to avoid using this as it weakens your test.)
use Test::More qw(no_plan);
In some cases, you'll want to completely skip an entire testing script.
view release on metacpan or search on metacpan
lib/Class/Field.pm view on Meta::CPAN
" return \$_[0]->{%s} = do { my \$self = \$_[0]; %s }\n" .
" unless \$#_ > 0 or defined \$_[0]->{%s};\n",
weak_init =>
" return do {\n" .
" \$_[0]->{%s} = do { my \$self = \$_[0]; %s };\n" .
" Scalar::Util::weaken(\$_[0]->{%s}) if ref \$_[0]->{%s};\n" .
" \$_[0]->{%s};\n" .
" } unless \$#_ > 0 or defined \$_[0]->{%s};\n",
return_if_get =>
" return \$_[0]->{%s} unless \$#_ > 0;\n",
set =>
" \$_[0]->{%s} = \$_[1];\n",
weaken =>
" Scalar::Util::weaken(\$_[0]->{%s}) if ref \$_[0]->{%s};\n",
sub_end =>
" return \$_[0]->{%s};\n}\n",
);
sub field {
lib/Class/Field.pm view on Meta::CPAN
local *paired_arguments = sub { (qw(-package -init)) };
Class::Field->parse_arguments(@_);
};
my ($field, $default) = @values;
$package = $args->{-package} if defined $args->{-package};
die "Cannot have a default for a weakened field ($field)"
if defined $default && $args->{-weak};
return if defined &{"${package}::$field"};
require Scalar::Util if $args->{-weak};
my $default_string =
( ref($default) eq 'ARRAY' and not @$default )
lib/Class/Field.pm view on Meta::CPAN
}
$code .= sprintf $code{set_default}, $field, $default_string, $field
if defined $default;
$code .= sprintf $code{return_if_get}, $field;
$code .= sprintf $code{set}, $field;
$code .= sprintf $code{weaken}, $field, $field
if $args->{-weak};
$code .= sprintf $code{sub_end}, $field;
my $sub = eval $code;
die $@ if $@;
view release on metacpan or search on metacpan
lib/Class/InsideOut.pm view on Meta::CPAN
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
lib/Class/InsideOut.pm view on Meta::CPAN
# register( REFERENCE/OBJECT, CLASSNAME )
$obj = shift;
bless $obj, shift; # ok to rebless
}
weaken( $OBJECT_REGISTRY{ refaddr $obj } = $obj );
return $obj;
}
#--------------------------------------------------------------------------#
# private functions for implementation
lib/Class/InsideOut.pm view on Meta::CPAN
$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{
lib/Class/InsideOut.pm view on Meta::CPAN
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:
view release on metacpan or search on metacpan
IntrospectionMethods.pm view on Meta::CPAN
@EXPORT_OK = qw(make_methods set_obsolete_behavior set_parent_method_name);
# Utility -----------------------------
# Necessary for parent feature
use Scalar::Util qw(isweak weaken) ;
use Class::IntrospectionMethods::Catalog
qw/set_global_catalog set_method_info set_method_in_catalog/;
use Class::IntrospectionMethods::Parent
qw/set_parent_method_name graft_parent_method/ ;
view release on metacpan or search on metacpan
sv_ref||5.015004|
sv_replace|||
sv_report_used|||
sv_resetpvn|||
sv_reset|||
sv_rvweaken||5.006000|
sv_sethek|||
sv_setiv_mg|5.004050||p
sv_setiv|||
sv_setnv_mg|5.006000||p
sv_setnv|||
view release on metacpan or search on metacpan
inc/Spiffy.pm view on Meta::CPAN
" return \$_[0]->{%s} = do { my \$self = \$_[0]; %s }\n" .
" unless \$#_ > 0 or defined \$_[0]->{%s};\n",
weak_init =>
" return do {\n" .
" \$_[0]->{%s} = do { my \$self = \$_[0]; %s };\n" .
" Scalar::Util::weaken(\$_[0]->{%s}) if ref \$_[0]->{%s};\n" .
" \$_[0]->{%s};\n" .
" } unless \$#_ > 0 or defined \$_[0]->{%s};\n",
return_if_get =>
" return \$_[0]->{%s} unless \$#_ > 0;\n",
set =>
" \$_[0]->{%s} = \$_[1];\n",
weaken =>
" Scalar::Util::weaken(\$_[0]->{%s}) if ref \$_[0]->{%s};\n",
sub_end =>
" return \$_[0]->{%s};\n}\n",
);
sub field {
inc/Spiffy.pm view on Meta::CPAN
local *paired_arguments = sub { (qw(-package -init)) };
Spiffy->parse_arguments(@_);
};
my ($field, $default) = @values;
$package = $args->{-package} if defined $args->{-package};
die "Cannot have a default for a weakened field ($field)"
if defined $default && $args->{-weak};
return if defined &{"${package}::$field"};
require Scalar::Util if $args->{-weak};
my $default_string =
( ref($default) eq 'ARRAY' and not @$default )
inc/Spiffy.pm view on Meta::CPAN
}
$code .= sprintf $code{set_default}, $field, $default_string, $field
if defined $default;
$code .= sprintf $code{return_if_get}, $field;
$code .= sprintf $code{set}, $field;
$code .= sprintf $code{weaken}, $field, $field
if $args->{-weak};
$code .= sprintf $code{sub_end}, $field;
my $sub = eval $code;
die $@ if $@;
view release on metacpan or search on metacpan
sv_reftype|||
sv_release_COW|||
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
view release on metacpan or search on metacpan
lib/Class/Monadic.pm view on Meta::CPAN
methods => undef,
modifiers => undef,
fields => undef,
field_map => undef,
}, $metaclass;
Scalar::Util::weaken( $meta->{object} );
&Internals::SvREADONLY($meta, 1); # lock_keys(%{$meta})
my $sclass = $class . '::' . $meta->{id};
my $sclass_isa = do{ no strict 'refs'; \@{$sclass . '::ISA'} };
view release on metacpan or search on metacpan
t/lib/Test/More.pm view on Meta::CPAN
use Test::More tests => $Num_Tests;
There are rare cases when you will not know beforehand how many tests
your script is going to run. In this case, you can declare that you
have no plan. (Try to avoid using this as it weakens your test.)
use Test::More qw(no_plan);
In some cases, you'll want to completely skip an entire testing script.
view release on metacpan or search on metacpan
lib/Class/Observable.pm view on Meta::CPAN
my $invocant = delete $registry{ $oldaddr };
my $observers = delete $O{ $oldaddr };
if ( defined $invocant ) {
my $addr = refaddr $invocant;
$O{ $addr } = $observers;
Scalar::Util::weaken( $registry{ $addr } = $invocant );
} else {
$have_warned++ or warn
"*** Inconsistent state ***\n",
"Observed instances have gone away " .
"without invoking Class::Observable::DESTROY\n";
lib/Class/Observable.pm view on Meta::CPAN
}
sub add_observer {
my $invocant = shift;
my $addr = refaddr $invocant;
Scalar::Util::weaken( $registry{ $addr } = $invocant ) if NEEDS_REGISTRY and $addr;
push @{ $O{ $addr || "::$invocant" } }, @_;
}
sub delete_observer {
my $invocant = shift;
view release on metacpan or search on metacpan
lib/Class/Plain/Document/Cookbook.pm view on Meta::CPAN
=head1 Weakening Field
Weaken a field.
use Scalar::Util 'weaken';
use Class::Plain;
class Foo {
field x;
method weaken_x {
weaken $self->{x};
}
}
=head1 Class Variable
view release on metacpan or search on metacpan
lib/Class/Property/RO/Lazy.pm view on Meta::CPAN
my( $self ) = @_;
if( not defined $self->{'flag_ref'}->{$self->{'object'}} )
{
$self->{'flag_ref'}->{$self->{'object'}} = $self->{'object'};
Scalar::Util::weaken($self->{'flag_ref'}->{$self->{'object'}});
$self->{'object'}->{$self->{'field'}} = $self->{'init'}->($self->{'object'});
}
return $self->{'object'}->{$self->{'field'}};
}