Gecko [ www.blackthorn-inc.com ]

Name	Size	Permission	Date
Array	[ DIR ]	drwxr-xr-x	2015-02-14 16:56
Handle	[ DIR ]	drwxr-xr-x	2015-02-14 16:56
Hash	[ DIR ]	drwxr-xr-x	2016-10-10 17:40
Array.pm	7.15 KB	-r--r--r--	2014-12-27 11:48
ExtraHash.t	1.01 KB	-r--r--r--	2014-12-27 11:48
File.pm	75.56 KB	-r--r--r--	2014-12-27 11:49
Handle.pm	4.1 KB	-r--r--r--	2014-12-27 11:48
Hash.pm	7.46 KB	-r--r--r--	2014-12-27 11:48
Hash.t	318 B	-r--r--r--	2014-12-27 11:48
Memoize.pm	4.15 KB	-r--r--r--	2014-12-27 11:48
RefHash.pm	6.09 KB	-r--r--r--	2014-12-27 11:48
Scalar.pm	4.06 KB	-r--r--r--	2014-12-27 11:48
Scalar.t	2.97 KB	-r--r--r--	2014-12-27 11:48
StdHandle.pm	1.37 KB	-r--r--r--	2014-12-27 11:48
SubstrHash.pm	5.28 KB	-r--r--r--	2014-12-27 11:48
SubstrHash.t	2.27 KB	-r--r--r--	2014-12-27 11:48

Rename

#!./perl

BEGIN {
	chdir 't' if -d 't';
	@INC = '../lib';
}

# this must come before main, or tests will fail
package TieTest;

use Tie::Scalar;
use vars qw( @ISA );
@ISA = qw( Tie::Scalar );

sub new { 'Fooled you.' }

package main;

use vars qw( $flag );
use Test::More tests => 16;

use_ok( 'Tie::Scalar' );

# these are "abstract virtual" parent methods
for my $method (qw( TIESCALAR FETCH STORE )) {
	eval { Tie::Scalar->$method() };
	like( $@, qr/doesn't define a $method/, "croaks on inherited $method()" );
}

# the default value is undef
my $scalar = Tie::StdScalar->TIESCALAR();
is( $$scalar, undef, 'used TIESCALAR, default value is still undef' );

# Tie::StdScalar redirects to TIESCALAR
$scalar = Tie::StdScalar->new();
is( $$scalar, undef, 'used new(), default value is still undef' );

# this approach should work as well
tie $scalar, 'Tie::StdScalar';
is( $$scalar, undef, 'tied a scalar, default value is undef' );

# first set, then read
$scalar = 'fetch me';
is( $scalar, 'fetch me', 'STORE() and FETCH() verified with one test!' );

# test DESTROY with an object that signals its destruction
{
	my $scalar = 'foo';
	tie $scalar, 'Tie::StdScalar', DestroyAction->new();
	ok( $scalar, 'tied once more' );
	is( $flag, undef, 'destroy flag not set' );
}

# $scalar out of scope, Tie::StdScalar::DESTROY() called, DestroyAction set flag
is( $flag, 1, 'and DESTROY() works' );

# we want some noise, and some way to capture it
use warnings;
my $warn;
local $SIG{__WARN__} = sub {
	$warn = $_[0];
};

# Tie::Scalar::TIEHANDLE should find and call TieTest::new and complain
is( tie( my $foo, 'TieTest'), 'Fooled you.', 'delegated to new()' );
like( $warn, qr/WARNING: calling TieTest->new/, 'caught warning fine' );

package DestroyAction;

sub new {
	bless( \(my $self), $_[0] );
}

sub DESTROY {
	$main::flag = 1;
}

#
# Bug #72878: don't recurse forever if both new and TIESCALAR are missing.
#
package main;

@NoMethods::ISA = qw [Tie::Scalar];

{
    #
    # Without the fix for #72878, the code runs forever.
    # Trap this, and die if with an appropriate message if this happens.
    #
    local $SIG {__WARN__} = sub {
        die "Called NoMethods->new"
             if $_ [0] =~ /^WARNING: calling NoMethods->new/;
    };

eval {tie my $foo => "NoMethods";};

like $@ =>
        qr /\QNoMethods must define either a TIESCALAR() or a new() method/,
        "croaks if both new() and TIESCALAR() are missing";
};

#
# Don't croak on missing new/TIESCALAR if you're inheriting one.
#
my $called1 = 0;
my $called2 = 0;

sub HasMethod1::new {$called1 ++}
   @HasMethod1::ISA        = qw [Tie::Scalar];
   @InheritHasMethod1::ISA = qw [HasMethod1];

sub HasMethod2::TIESCALAR {$called2 ++}
   @HasMethod2::ISA        = qw [Tie::Scalar];
   @InheritHasMethod2::ISA = qw [HasMethod2];

my $r1 = eval {tie my $foo => "InheritHasMethod1"; 1};
my $r2 = eval {tie my $foo => "InheritHasMethod2"; 1};

ok $r1 && $called1, "inheriting new() does not croak";
ok $r2 && $called2, "inheriting TIESCALAR() does not croak";