develooper Front page | perl.perl5.porters | Postings from September 2001

[PATCH MANIFEST lib/Tie/Scalar.pm lib/Tie/Scalar.t] Add tests, clean up Tie::Scalar

Thread Next
From:
chromatic
Date:
September 28, 2001 20:25
Subject:
[PATCH MANIFEST lib/Tie/Scalar.pm lib/Tie/Scalar.t] Add tests, clean up Tie::Scalar
Message ID:
20010929032543.58322.qmail@onion.perl.org
Writing tests for Tie::Scalar, I had a terrible time figuring out why it
wouldn't call an inherited new() from TIESCALAR() if TIESCALAR() were not
overridden.

So I patched the module to Do What It Should.  The test assumes this patch is
in place.  I can rewrite the test if the patch is dumb (it's been a long day).

There are a couple of tests in other places (t/op/tie.t, t/op/pos.t) that use
Tie::Scalar, but nothing comprehensive.

-- c

--- ~MANIFEST	Fri Sep 28 20:43:42 2001
+++ MANIFEST	Fri Sep 28 21:04:31 2001
@@ -1225,6 +1225,7 @@
 lib/Tie/RefHash.pm		Base class for tied hashes with references as keys
 lib/Tie/RefHash.t		Test for Tie::RefHash and Tie::RefHash::Nestable
 lib/Tie/Scalar.pm		Base class for tied scalars
+lib/Tie/Scalar.t		See if Tie::Scalar works
 lib/Tie/SubstrHash.pm		Compact hash for known key, value and table size
 lib/Tie/SubstrHash.t		Test for Tie::SubstrHash
 lib/Time/gmtime.pm		By-name interface to Perl's builtin gmtime

--- lib/Tie/~Scalar.pm	Fri Sep 28 20:41:07 2001
+++ lib/Tie/Scalar.pm	Fri Sep 28 20:46:22 2001
@@ -93,7 +93,7 @@
 
 sub TIESCALAR {
     my $pkg = shift;
-    if (defined &{"{$pkg}::new"}) {
+	if ($pkg->can('new') and $pkg ne __PACKAGE__) {
 	warnings::warnif("WARNING: calling ${pkg}->new since ${pkg}->TIESCALAR is missing");
 	$pkg->new(@_);
     }

--- /dev/null	Tue May  5 14:32:27 1998
+++ lib/Tie/Scalar.t	Fri Sep 28 20:43:03 2001
@@ -0,0 +1,76 @@
+#!./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 => 13;
+
+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;
+}

Thread Next


nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About