Add a test for study() on tied scalars, by Andy Lester after

Rick Delaney

p4raw-id: //depot/perl@27271

diff --git a/MANIFEST b/MANIFEST
index bdb85d5..0eeaae0 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -3338,6 +3338,7 @@ t/op/sselect.t                    See if 4 argument select works
 t/op/stash.t                   See if %:: stashes work
 t/op/stat.t                    See if stat works
 t/op/study.t                   See if study works
+t/op/studytied.t               See if study works with tied scalars
 t/op/sub_lval.t                        See if lvalue subroutines work
 t/op/subst_amp.t               See if $&-related substitution works
 t/op/substr.t                  See if substr works

diff --git a/t/op/studytied.t b/t/op/studytied.t
new file mode 100644 (file)
index 0000000..d50c964
--- /dev/null
+++ b/t/op/studytied.t
@@ -0,0 +1,50 @@
+#!./perl
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+}
+
+use strict;
+use warnings;
+
+use Test::More tests => 14;
+
+{
+    package J;
+    my $c = 0;
+    sub reset { $c = 0 }
+    sub TIESCALAR { bless [] }
+    sub FETCH { $c++ ? "next" : "first" }
+}
+
+# This test makes sure that we can't pull a fast one on study().  If we
+# study() a tied variable, perl should know that the studying isn't
+# valid on subsequent references, and should account for it.
+
+for my $do_study qw( 0 1 ) {
+    J::reset();
+    my $x;
+    tie $x, "J";
+
+    if ($do_study) {
+        study $x;
+        pass( "Studying..." );
+    } else {
+        my $first_fetch = $x;
+        pass( "Not studying..." );
+    }
+
+    # When it was studied (or first_fetched), $x was "first", but is now "next", so
+    # should not match /f/.
+    ok( $x !~ /f/,              qq{"next" doesn't match /f/} );
+    is( index( $x, 'f' ), -1,   qq{"next" doesn't contain "f"} );
+
+    # Subsequent references to $x are "next", so should match /n/
+    ok( $x =~ /n/,              qq{"next" matches /n/} );
+    is( index( $x, 'n' ), 0,    qq{"next" contains "n" at pos 0} );
+
+    # The letter "t" is in both, but in different positions
+    ok( $x =~ /t/,              qq{"next" matches /x/} );
+    is( index( $x, 't' ), 3,    qq{"next" contains "x" at pos 3} );
+}