ext/XS/APItest/t/exception.t XS::APItest extension
ext/XS/APItest/t/hash.t XS::APItest extension
ext/XS/APItest/t/my_cxt.t XS::APItest: test MY_CXT interface
+ext/XS/APItest/t/hash.t XS::APItest: tests for OP related APIs
ext/XS/APItest/t/printf.t XS::APItest extension
ext/XS/APItest/t/push.t XS::APItest extension
ext/XS/Typemap/Makefile.PL XS::Typemap extension
t/op/avhv.t See if pseudo-hashes work
t/op/bless.t See if bless works
t/op/bop.t See if bitops work
+t/op/caller.pl Tests shared between caller.t and XS op.t
t/op/caller.t See if caller() works
t/op/chars.t See if character escapes work
t/op/chdir.t See if chdir works
unsharepvn(p, len, hash);
OUTPUT:
RETVAL
+
+bool
+refcounted_he_exists(key, level=0)
+ SV *key
+ IV level
+ CODE:
+ if (level) {
+ croak("level must be zero, not %"IVdf, level);
+ }
+ RETVAL = (Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
+ key, NULL, 0, 0, 0)
+ != &PL_sv_placeholder);
+ OUTPUT:
+ RETVAL
+
+
+SV *
+refcounted_he_fetch(key, level=0)
+ SV *key
+ IV level
+ CODE:
+ if (level) {
+ croak("level must be zero, not %"IVdf, level);
+ }
+ RETVAL = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, key,
+ NULL, 0, 0, 0);
+ SvREFCNT_inc(RETVAL);
+ OUTPUT:
+ RETVAL
+
=pod
--- /dev/null
+#!perl -w
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ push @INC, "::lib:$MacPerl::Architecture:" if $^O eq 'MacOS';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bXS\/APItest\b/) {
+ # Look, I'm using this fully-qualified variable more than once!
+ my $arch = $MacPerl::Architecture;
+ print "1..0 # Skip: XS::APItest was not built\n";
+ exit 0;
+ }
+}
+
+use strict;
+use utf8;
+use Test::More 'no_plan';
+
+use_ok('XS::APItest');
+
+*hint_exists = *hint_exists = \&XS::APItest::Hash::refcounted_he_exists;
+*hint_fetch = *hint_fetch = \&XS::APItest::Hash::refcounted_he_fetch;
+
+require './op/caller.pl';
/* Just to be awkward, if you're using this interface the UTF-8-or-not-ness
of your key has to exactly match that which is stored. */
SV *value = &PL_sv_placeholder;
+ bool is_utf8;
if (keysv) {
if (flags & HVhek_FREEKEY)
Safefree(key);
key = SvPV_const(keysv, klen);
flags = 0;
+ is_utf8 = (SvUTF8(keysv) != 0);
+ } else {
+ is_utf8 = ((flags & HVhek_UTF8) ? TRUE : FALSE);
}
if (!hash) {
continue;
if (memNE(REF_HE_KEY(chain),key,klen))
continue;
+ if (!!is_utf8 != !!(chain->refcounted_he_data[0] & HVhek_UTF8))
+ continue;
#else
if (hash != HEK_HASH(chain->refcounted_he_hek))
continue;
continue;
if (memNE(HEK_KEY(chain->refcounted_he_hek),key,klen))
continue;
+ if (!!is_utf8 != !!HEK_UTF8(chain->refcounted_he_hek))
+ continue;
#endif
value = sv_2mortal(refcounted_he_value(chain));
char flags;
STRLEN key_offset;
U32 hash;
- bool is_utf8 = SvUTF8(key);
+ bool is_utf8 = SvUTF8(key) ? TRUE : FALSE;
if (SvPOK(value)) {
value_type = HVrhek_PV;
--- /dev/null
+# tests shared between t/op/caller.t and ext/XS/APItest/t/op.t
+
+use strict;
+use warnings;
+
+sub dooot {
+ is(hint_fetch('dooot'), undef);
+ is(hint_fetch('thikoosh'), undef);
+ ok(!hint_exists('dooot'));
+ ok(!hint_exists('thikoosh'));
+ if ($::testing_caller) {
+ is(hint_fetch('dooot', 1), 54);
+ }
+ BEGIN {
+ $^H{dooot} = 42;
+ }
+ is(hint_fetch('dooot'), 6 * 7);
+ if ($::testing_caller) {
+ is(hint_fetch('dooot', 1), 54);
+ }
+
+ BEGIN {
+ $^H{dooot} = undef;
+ }
+ is(hint_fetch('dooot'), undef);
+ ok(hint_exists('dooot'));
+
+ BEGIN {
+ delete $^H{dooot};
+ }
+ is(hint_fetch('dooot'), undef);
+ ok(!hint_exists('dooot'));
+ if ($::testing_caller) {
+ is(hint_fetch('dooot', 1), 54);
+ }
+}
+{
+ is(hint_fetch('dooot'), undef);
+ is(hint_fetch('thikoosh'), undef);
+ BEGIN {
+ $^H{dooot} = 1;
+ $^H{thikoosh} = "SKREECH";
+ }
+ if ($::testing_caller) {
+ is(hint_fetch('dooot'), 1);
+ }
+ is(hint_fetch('thikoosh'), "SKREECH");
+
+ BEGIN {
+ $^H{dooot} = 42;
+ }
+ {
+ {
+ BEGIN {
+ $^H{dooot} = 6 * 9;
+ }
+ is(hint_fetch('dooot'), 54);
+ is(hint_fetch('thikoosh'), "SKREECH");
+ {
+ BEGIN {
+ delete $^H{dooot};
+ }
+ is(hint_fetch('dooot'), undef);
+ ok(!hint_exists('dooot'));
+ is(hint_fetch('thikoosh'), "SKREECH");
+ }
+ dooot();
+ }
+ is(hint_fetch('dooot'), 6 * 7);
+ is(hint_fetch('thikoosh'), "SKREECH");
+ }
+ is(hint_fetch('dooot'), 6 * 7);
+ is(hint_fetch('thikoosh'), "SKREECH");
+}
+
+print "# which now works inside evals\n";
+
+{
+ BEGIN {
+ $^H{dooot} = 42;
+ }
+ is(hint_fetch('dooot'), 6 * 7);
+
+ eval "is(hint_fetch('dooot'), 6 * 7); 1" or die $@;
+
+ eval <<'EOE' or die $@;
+ is(hint_fetch('dooot'), 6 * 7);
+ eval "is(hint_fetch('dooot'), 6 * 7); 1" or die $@;
+ BEGIN {
+ $^H{dooot} = 54;
+ }
+ is(hint_fetch('dooot'), 54);
+ eval "is(hint_fetch('dooot'), 54); 1" or die $@;
+ eval 'BEGIN { $^H{dooot} = -1; }; 1' or die $@;
+ is(hint_fetch('dooot'), 54);
+ eval "is(hint_fetch('dooot'), 54); 1" or die $@;
+EOE
+}
+
+{
+ BEGIN {
+ $^H{dooot} = "FIP\0FOP\0FIDDIT\0FAP";
+ }
+ is(hint_fetch('dooot'), "FIP\0FOP\0FIDDIT\0FAP", "Can do embedded 0 bytes");
+
+ BEGIN {
+ $^H{dooot} = chr 256;
+ }
+ is(hint_fetch('dooot'), chr 256, "Can do Unicode");
+
+ BEGIN {
+ $^H{dooot} = -42;
+ }
+ is(hint_fetch('dooot'), -42, "Can do IVs");
+
+ BEGIN {
+ $^H{dooot} = ~0;
+ }
+ cmp_ok(hint_fetch('dooot'), '>', 42, "Can do UVs");
+}
+
+{
+ my ($k1, $k2, $k3, $k4);
+ BEGIN {
+ $k1 = chr 163;
+ $k2 = $k1;
+ $k3 = chr 256;
+ $k4 = $k3;
+ utf8::upgrade $k2;
+ utf8::encode $k4;
+
+ $^H{$k1} = 1;
+ $^H{$k2} = 2;
+ $^H{$k3} = 3;
+ $^H{$k4} = 4;
+ }
+
+
+ is(hint_fetch($k1), 2, "UTF-8 or not, it's the same");
+ if ($::testing_caller) {
+ # Perl_refcounted_he_fetch() insists that you have the key correctly
+ # normalised for the way hashes store them. As this one isn't
+ # normalised down to bytes, it won't t work with
+ # Perl_refcounted_he_fetch()
+ is(hint_fetch($k2), 2, "UTF-8 or not, it's the same");
+ }
+ is(hint_fetch($k3), 3, "Octect sequences and UTF-8 are distinct");
+ is(hint_fetch($k4), 4, "Octect sequences and UTF-8 are distinct");
+}
+
+{
+ my ($k1, $k2, $k3);
+ BEGIN {
+ ($k1, $k2, $k3) = ("\0", "\0\0", "\0\0\0");
+ $^H{$k1} = 1;
+ $^H{$k2} = 2;
+ $^H{$k3} = 3;
+ }
+
+ is(hint_fetch($k1), 1, "Keys with the same hash value don't clash");
+ is(hint_fetch($k2), 2, "Keys with the same hash value don't clash");
+ is(hint_fetch($k3), 3, "Keys with the same hash value don't clash");
+
+ BEGIN {
+ $^H{$k1} = "a";
+ $^H{$k2} = "b";
+ $^H{$k3} = "c";
+ }
+
+ is(hint_fetch($k1), "a", "Keys with the same hash value don't clash");
+ is(hint_fetch($k2), "b", "Keys with the same hash value don't clash");
+ is(hint_fetch($k3), "c", "Keys with the same hash value don't clash");
+}
+
+1;
chdir 't' if -d 't';
@INC = '../lib';
require './test.pl';
- plan( tests => 77 );
+ plan( tests => 78 );
}
my @c;
print "# caller can now return the compile time state of %^H\n";
-sub get_hash {
+sub hint_exists {
+ my $key = shift;
my $level = shift;
my @results = caller($level||0);
- $results[10];
+ exists $results[10]->{$key};
}
-sub get_dooot {
+sub hint_fetch {
+ my $key = shift;
my $level = shift;
my @results = caller($level||0);
- $results[10]->{dooot};
+ $results[10]->{$key};
}
-sub get_thikoosh {
- my $level = shift;
- my @results = caller($level||0);
- $results[10]->{thikoosh};
-}
-
-sub dooot {
- is(get_dooot(), undef);
- is(get_thikoosh(), undef);
- my $hash = get_hash();
- ok(!exists $hash->{dooot});
- ok(!exists $hash->{thikoosh});
- is(get_dooot(1), 54);
- BEGIN {
- $^H{dooot} = 42;
- }
- is(get_dooot(), 6 * 7);
- is(get_dooot(1), 54);
-
- BEGIN {
- $^H{dooot} = undef;
- }
- is(get_dooot(), undef);
- $hash = get_hash();
- ok(exists $hash->{dooot});
-
- BEGIN {
- delete $^H{dooot};
- }
- is(get_dooot(), undef);
- $hash = get_hash();
- ok(!exists $hash->{dooot});
- is(get_dooot(1), 54);
-}
-{
- is(get_dooot(), undef);
- is(get_thikoosh(), undef);
- BEGIN {
- $^H{dooot} = 1;
- $^H{thikoosh} = "SKREECH";
- }
- is(get_dooot(), 1);
- is(get_thikoosh(), "SKREECH");
-
- BEGIN {
- $^H{dooot} = 42;
- }
- {
- {
- BEGIN {
- $^H{dooot} = 6 * 9;
- }
- is(get_dooot(), 54);
- is(get_thikoosh(), "SKREECH");
- {
- BEGIN {
- delete $^H{dooot};
- }
- is(get_dooot(), undef);
- my $hash = get_hash();
- ok(!exists $hash->{dooot});
- is(get_thikoosh(), "SKREECH");
- }
- dooot();
- }
- is(get_dooot(), 6 * 7);
- is(get_thikoosh(), "SKREECH");
- }
- is(get_dooot(), 6 * 7);
- is(get_thikoosh(), "SKREECH");
-}
-
-print "# which now works inside evals\n";
+$::testing_caller = 1;
-{
- BEGIN {
- $^H{dooot} = 42;
- }
- is(get_dooot(), 6 * 7);
-
- eval "is(get_dooot(), 6 * 7); 1" or die $@;
-
- eval <<'EOE' or die $@;
- is(get_dooot(), 6 * 7);
- eval "is(get_dooot(), 6 * 7); 1" or die $@;
- BEGIN {
- $^H{dooot} = 54;
- }
- is(get_dooot(), 54);
- eval "is(get_dooot(), 54); 1" or die $@;
- eval 'BEGIN { $^H{dooot} = -1; }; 1' or die $@;
- is(get_dooot(), 54);
- eval "is(get_dooot(), 54); 1" or die $@;
-EOE
-}
-
-{
- BEGIN {
- $^H{dooot} = "FIP\0FOP\0FIDDIT\0FAP";
- }
- is(get_dooot(), "FIP\0FOP\0FIDDIT\0FAP", "Can do embedded 0 bytes");
-
- BEGIN {
- $^H{dooot} = chr 256;
- }
- is(get_dooot(), chr 256, "Can do Unicode");
-
- BEGIN {
- $^H{dooot} = -42;
- }
- is(get_dooot(), -42, "Can do IVs");
-
- BEGIN {
- $^H{dooot} = ~0;
- }
- cmp_ok(get_dooot(), '>', 42, "Can do UVs");
-}
-
-{
- my ($k1, $k2, $k3);
- BEGIN {
- $k1 = chr 163;
- $k2 = $k1;
- $k3 = $k1;
- utf8::upgrade $k2;
- utf8::encode $k3;
-
- $^H{$k1} = 1;
- $^H{$k2} = 2;
- $^H{$k3} = 3;
- }
-
-
- is(get_hash()->{$k1}, 2, "UTF-8 or not, it's the same");
- is(get_hash()->{$k2}, 2, "UTF-8 or not, it's the same");
- is(get_hash()->{$k3}, 3, "Octect sequences and UTF-8 are distinct");
-}
-
-{
- my ($k1, $k2, $k3);
- BEGIN {
- ($k1, $k2, $k3) = ("\0", "\0\0", "\0\0\0");
- $^H{$k1} = 1;
- $^H{$k2} = 2;
- $^H{$k3} = 3;
- }
-
- is(get_hash()->{$k1}, 1, "Keys with the same hash value don't clash");
- is(get_hash()->{$k2}, 2, "Keys with the same hash value don't clash");
- is(get_hash()->{$k3}, 3, "Keys with the same hash value don't clash");
-
- BEGIN {
- $^H{$k1} = "a";
- $^H{$k2} = "b";
- $^H{$k3} = "c";
- }
-
- is(get_hash()->{$k1}, "a", "Keys with the same hash value don't clash");
- is(get_hash()->{$k2}, "b", "Keys with the same hash value don't clash");
- is(get_hash()->{$k3}, "c", "Keys with the same hash value don't clash");
-}
+do './op/caller.pl';
projects / p5sagit/p5-mst-13.2.git / commitdiff