This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
8b43acb17afd9e96cd8dc1ca08c229b6c28f19bd
[perl5.git] / ext / PerlIO / t / scalar.t
1 #!./perl
2
3 BEGIN {
4     chdir 't' if -d 't';
5     @INC = '../lib';
6     unless (find PerlIO::Layer 'perlio') {
7         print "1..0 # Skip: not perlio\n";
8         exit 0;
9     }
10     require Config;
11     if (($Config::Config{'extensions'} !~ m!\bPerlIO/scalar\b!) ){
12         print "1..0 # Skip -- Perl configured without PerlIO::scalar module\n";
13         exit 0;
14     }
15 }
16
17 $| = 1;
18 print "1..27\n";
19
20 my $fh;
21 my $var = "ok 2\n";
22 open($fh,"+<",\$var) or print "not ";
23 print "ok 1\n";
24 print <$fh>;
25 print "not " unless eof($fh);
26 print "ok 3\n";
27 seek($fh,0,0) or print "not ";
28 print "not " if eof($fh);
29 print "ok 4\n";
30 print "ok 5\n";
31 print $fh "ok 7\n" or print "not ";
32 print "ok 6\n";
33 print $var;
34 $var = "foo\nbar\n";
35 seek($fh,0,0) or print "not ";
36 print "not " if eof($fh);
37 print "ok 8\n";
38 print "not " unless <$fh> eq "foo\n";
39 print "ok 9\n";
40 my $rv = close $fh;
41 if (!$rv) {
42     print "# Close on scalar failed: $!\n";
43     print "not ";
44 }
45 print "ok 10\n";
46
47 # Test that semantics are similar to normal file-based I/O
48 # Check that ">" clobbers the scalar
49 $var = "Something";
50 open $fh, ">", \$var;
51 print "# Got [$var], expect []\n";
52 print "not " unless $var eq "";
53 print "ok 11\n";
54 #  Check that file offset set to beginning of scalar
55 my $off = tell($fh);
56 print "# Got $off, expect 0\n";
57 print "not " unless $off == 0;
58 print "ok 12\n";
59 # Check that writes go where they should and update the offset
60 $var = "Something";
61 print $fh "Brea";
62 $off = tell($fh);
63 print "# Got $off, expect 4\n";
64 print "not " unless $off == 4;
65 print "ok 13\n";
66 print "# Got [$var], expect [Breathing]\n";
67 print "not " unless $var eq "Breathing";
68 print "ok 14\n";
69 close $fh;
70
71 # Check that ">>" appends to the scalar
72 $var = "Something ";
73 open $fh, ">>", \$var;
74 $off = tell($fh);
75 print "# Got $off, expect 10\n";
76 print "not " unless $off == 10;
77 print "ok 15\n";
78 print "# Got [$var], expect [Something ]\n";
79 print "not " unless $var eq "Something ";
80 print "ok 16\n";
81 #  Check that further writes go to the very end of the scalar
82 $var .= "else ";
83 print "# Got [$var], expect [Something else ]\n";
84 print "not " unless $var eq "Something else ";
85 print "ok 17\n";
86 $off = tell($fh);
87 print "# Got $off, expect 10\n";
88 print "not " unless $off == 10;
89 print "ok 18\n";
90 print $fh "is here";
91 print "# Got [$var], expect [Something else is here]\n";
92 print "not " unless $var eq "Something else is here";
93 print "ok 19\n";
94 close $fh;
95
96 # Check that updates to the scalar from elsewhere do not
97 # cause problems
98 $var = "line one\nline two\line three\n";
99 open $fh, "<", \$var;
100 while (<$fh>) {
101     $var = "foo";
102 }
103 close $fh;
104 print "# Got [$var], expect [foo]\n";
105 print "not " unless $var eq "foo";
106 print "ok 20\n";
107
108 # Check that dup'ing the handle works
109
110 $var = '';
111
112 open $fh, "+>", \$var;
113 print $fh "ok 21\n";
114 open $dup,'+<&',$fh;
115 print $dup "ok 22\n";
116 seek($dup,0,0);
117 while (<$dup>) {
118     print;
119 }
120 close($fh);
121 close($dup);
122
123 # Check reading from non-string scalars
124
125 open $fh, '<', \42;
126 print <$fh> eq "42" ? "ok 23\n" : "not ok 23\n";
127 close $fh;
128
129 # reading from magic scalars
130
131 { package P; sub TIESCALAR {bless{}} sub FETCH {"ok 24\n"} }
132 tie $p, P; open $fh, '<', \$p;
133 print <$fh>;
134
135 # don't warn when writing to an undefined scalar
136
137 {
138     use warnings;
139     my $ok = 1;
140     local $SIG{__WARN__} = sub { $ok = 0; };
141     open my $fh, '>', \my $scalar;
142     print $fh "foo";
143     close $fh;
144     print $ok ? "ok 25\n" : "not ok 25\n";
145 }
146
147 my $data = "a non-empty PV";
148 $data = undef;
149 open(MEM, '<', \$data) or die "Fail: $!\n";
150 my $x = join '', <MEM>;
151 print $x eq '' ? "ok 26\n" : "not ok 26\n";
152
153 {
154     # [perl #35929] verify that works with $/ (i.e. test PerlIOScalar_unread)
155     my $s = <<'EOF';
156 line A
157 line B
158 a third line
159 EOF
160     open(F, '<', \$s) or die "Could not open string as a file";
161     local $/ = "";
162     my $ln = <F>;
163     close F;
164     print $ln eq $s ? "ok 27\n" : "not ok 27\n";
165 }