#!/usr/bin/perl -w
use strict;
use Test::More tests => 79;
use Set::Object qw(ish_int is_int is_double is_string is_object
blessed reftype refaddr is_key);
is(is_int(0), 1, "is_int(0)");
is(is_int(7), 1, "is_int(7)");
is(is_key(7), 1, "is_key(7)");
is(is_int(7.0), undef, "!is_int(7.0)");
is(is_key(7.0), 1, "is_key(7.0)");
is(is_int('7'), undef, "!is_int('7')");
is(is_key('7'), 1, "is_key('7')");
is(is_string(7), undef, "!is_string()");
is(is_string(7.0), undef, "!is_string(7.0)");
is(is_string("7"), 1, "is_string('7')");
is(is_double(7), undef, "!is_double(7)");
is(is_double(7.0), 1, "is_double(7.0)");
is(is_double("7"), undef, "!is_double('7')");
# behvaiour for numeric strings
my $foo;
is(is_int($foo="7"), undef, "!is_int(\$foo = '7')");
is(is_double($foo), undef, "!is_double($foo)");
is(ish_int($foo), undef, "!ish_int($foo)");
# behaviour changes between Perls
#is(is_int($foo+0), 1, "is_int(\$foo + 0)");
is(is_int(int($foo)), 1, "is_int(int(\$foo))");
# behaviour changes between Perls
#is(is_double($foo), undef, "is_double($foo)");
is(ish_int($foo), 7, "ish_int($foo)");
is(is_double($foo+0.01-0.01), 1, "is_double(\$foo + 0)");
is(is_double($foo), 1, "is_double($foo)");
is(is_int(int($foo)), 1, "is_int(int(\$foo))");
is(ish_int($foo), 7, "ish_int($foo)");
{
# no warnings for brevity
local($^W) = 0;
is(ish_int($foo = "7am"), undef,
"!defined(ish_int($foo = '7am'))");
is(ish_int($foo + 0), 7, "ish_int(\$foo + 0) == 7");
# behaviour changes between Perls
#is(is_int($foo), undef, "!is_int($foo)");
is(is_double($foo), 1, "is_double($foo)");
#diag("foo is $foo");
is(ish_int($foo), undef, "!defined(ish_int($foo))");
is(ish_int($foo = "7.0"), undef,
"!defined(ish_int($foo = '7.0'))");
is(ish_int($foo + 0), 7, "ish_int($foo + 0) == 7");
# behaviour changes between Perls
# is(is_int($foo), undef, "!is_int($foo)");
is(is_double($foo), 1, "is_double($foo)");
is(ish_int($foo), undef, "!defined(ish_int($foo))");
is(ish_int($foo = "7e6"), undef,
"!defined(ish_int($foo = '7e6'))");
is(ish_int($foo + 0), 7e6, "ish_int($foo + 0) == 7e6");
# behaviour changes between Perls
# is(is_int($foo), undef, "!is_int($foo)");
is(is_double($foo), 1, "is_double($foo)");
is(ish_int($foo), undef, "!defined(ish_int($foo))");
is(ish_int($foo = "7"), undef,
"!defined(ish_int($foo = '7'))");
is(ish_int($foo + 0.001 - 0.001), 7, "ish_int($foo + 0) == 7");
is(is_double($foo), 1, "is_double($foo)");
# behaviour changes between Perls
# is(is_int($foo), undef, "is_int($foo)");
is(ish_int($foo), 7, "ish_int($foo) == 7");
is(ish_int($foo = "0"), undef,
"!defined(ish_int($foo = '0'))");
is(ish_int($foo + 0.001 - 0.001), 0, "ish_int($foo + 0) == 0");
is(is_double($foo), 1, "is_double($foo)");
# behaviour changes between Perls
# is(is_int($foo), undef, "is_int($foo)");
is(ish_int($foo), 0, "ish_int($foo) == 7");
# value must be within 1e-9 of an int
is(ish_int(7.000000001234), undef,
"!ish_int(7.000000001234)");
is(ish_int(7.0000000001234), 7,
"ish_int(7.0000000001234) == 7");
}
is(blessed($foo = []), undef, "!blessed(\$foo = [])");
is(is_key($foo), undef, "is_key([])");
is(reftype($foo), "ARRAY",
"reftype(\$foo) eq 'ARRAY'");
bless $foo, "This";
is(blessed($foo), "This", "blessed(\$foo) eq 'This'");
is(reftype($foo), "ARRAY", "reftype(\$foo) eq 'ARRAY'");
is(is_key($foo), undef, "is_key(blessed array)");
$foo = {};
bless $foo, "This";
is(reftype({}), "HASH", "reftype({})");
is(reftype($foo), "HASH", "reftype(\$foo)");
is(is_key($foo), undef, "is_key(blessed hash)");
my %foo;
my $tiehandle = tie %foo, "This";
is(reftype(\%foo), "HASH", "reftype(\%foo) - tied");
is(reftype($tiehandle),
"ARRAY", "reftype(\$tiehandle)");
untie(%foo);
my $psuedonum = psuedonum->new(7);
ok($psuedonum == 7, "Pseudonum numifies OK");
ok($psuedonum == 7.0, "Pseudonum numifies OK");
ok($psuedonum eq "7", "Pseudonum stringifies OK");
is(blessed($psuedonum), "psuedonum", "Pseudonum is blessed");
is(ish_int($psuedonum), 7, "ish_int(Pseudonum)");
is(is_key($psuedonum), 1, "is_key(psuedonum)");
$psuedonum = [ ];
is(is_key($psuedonum), undef, "is_key(psuedonum/hash)");
my $nevernum = nevernum->new(7);
eval { if ($nevernum == 7) { } };
ok($@, "nevernum dies when numified");
eval { if ($nevernum == 7.0) { } };
ok($@, "nevernum dies when doublified");
ok($nevernum eq "7", "nevernum stringifies OK");
ok(blessed($nevernum) eq "nevernum", "nevernum is blessed");
is(ish_int($nevernum), undef, "ish_int(Nevernum)");
is(is_key($nevernum), 1, "is_key(nevernum)");
my $notreallynum = notreallynum->new(7);
ok($notreallynum == 7, "notreallynum numifies OK");
ok($notreallynum == 7.0, "notreallynum numifies OK");
ok($notreallynum eq "7", "notreallynum stringifies OK");
ok(blessed($notreallynum) eq "notreallynum", "nevernum is blessed");
is(ish_int($notreallynum), undef, "ish_int(notreallynum)");
is(is_key($nevernum), 1, "is_key(notreallynum)");
# now test tied scalars
$tiehandle = tie $foo, "This";
$foo = 7;
ok(tied $foo, "\$foo is tied");
# my @spells = detect_magic($foo);
# ok(@spells && $spells[0] =~ m/Magic type q/,
# "Foo is definitely tied");
#use Devel::Peek qw(Dump);
#print Dump $foo;
is(ish_int($foo), 7, "ish_int(tied var)");
eval { _ish_int($foo) };
like($@, qr/tie/, "ish_int(tied var)");
is(is_key($foo), 1, "is_key(tied var)");
ok(refaddr($notreallynum) > 0 && refaddr($notreallynum) != refaddr($nevernum),
"refaddr()");
exit(0);
# unused debugging function
sub showit {
my $var = shift;
if (defined $var) {
if (is_int($var)) {
return $var;
} elsif (is_double($var)) {
return sprintf("%e",$var);
} elsif (is_string($var)) {
return "`$var'";
} elsif (my $b = blessed($var)) {
return "Object($b)(".reftype($var).")";
} else {
return "onion";
}
} else {
return "undef";
}
}
package This;
# this class is an array pretending to be a hash
sub TIESCALAR {
my $invocant = shift;
my $test = [ ];
return bless $test, $invocant;
}
sub TIEHASH {
my $invocant = shift;
my $test = [ { } ];
return bless $test, $invocant;
}
sub FETCH {
my $self = shift;
if (@_) {
my $key = shift;
if (my $idx = ish_int($key)) {
return $self->[$idx+1];
} else {
if (exists $self->[0]->{$key}) {
return $self->[$self->[0]->{$key}];
} else {
return undef;
}
}
} else {
# scalar fetch
return $self->[0];
}
}
sub STORE {
my $self = shift;
if (@_ == 2) {
# hash set
my $key = shift;
if (!defined $key) {
$key = "";
}
} elsif (@_ == 1) {
# scalar set
$self->[0] = shift;
}
}
sub UNTIE {
my $self = shift;
@$self=();
}
package psuedonum;
use overload
'""' => \&stringify,
'0+' => \&numify,
fallback => 1;
sub new {
my $self = shift;
my $val = shift;
return bless { val => $val }
}
sub set {
my $self = shift;
my $val = shift;
$self->{val} = $val;
}
sub stringify {
my $self = shift;
return "$self->{val}";
}
sub numify {
my $self = shift;
return $self->{val} + 0;
}
package notreallynum;
use overload
'""' => \&stringify,
fallback => 1;
sub new {
my $self = shift;
my $val = shift;
return bless { val => $val }
}
sub set {
my $self = shift;
my $val = shift;
$self->{val} = $val;
}
sub stringify {
my $self = shift;
return "$self->{val}";
}
package nevernum;
use overload
'""' => \&stringify,
'eq' => \&equal,
fallback => 0;
sub new {
my $self = shift;
my $val = shift;
return bless { val => $val }
}
sub set {
my $self = shift;
my $val = shift;
$self->{val} = $val;
}
sub stringify {
my $self = shift;
return "$self->{val}";
}
sub equal {
my $self = shift;
my $other = shift;
return $self->{val} eq $other;
}