Commit | Line | Data |
f6c77cf1 |
1 | #!./perl |
2 | |
3 | BEGIN { |
4 | chdir 't' if -d 't'; |
5 | @INC = '../lib'; |
0c4f7ff0 |
6 | unless (find PerlIO::Layer 'perlio') { |
f6c77cf1 |
7 | print "1..0 # Skip: not perlio\n"; |
8 | exit 0; |
9 | } |
740dabb8 |
10 | require Config; |
98641f60 |
11 | if (($Config::Config{'extensions'} !~ m!\bPerlIO/scalar\b!) ){ |
740dabb8 |
12 | print "1..0 # Skip -- Perl configured without PerlIO::scalar module\n"; |
13 | exit 0; |
14 | } |
f6c77cf1 |
15 | } |
16 | |
42bc49da |
17 | use Fcntl qw(SEEK_SET SEEK_CUR SEEK_END); # Not 0, 1, 2 everywhere. |
18 | |
f6c77cf1 |
19 | $| = 1; |
42bc49da |
20 | |
21 | use Test::More tests => 51; |
f6c77cf1 |
22 | |
23 | my $fh; |
42bc49da |
24 | my $var = "aaa\n"; |
25 | ok(open($fh,"+<",\$var)); |
26 | |
27 | is(<$fh>, $var); |
28 | |
29 | ok(eof($fh)); |
30 | |
31 | ok(seek($fh,0,SEEK_SET)); |
32 | ok(!eof($fh)); |
33 | |
34 | ok(print $fh "bbb\n"); |
35 | is($var, "bbb\n"); |
f6c77cf1 |
36 | $var = "foo\nbar\n"; |
42bc49da |
37 | ok(seek($fh,0,SEEK_SET)); |
38 | ok(!eof($fh)); |
39 | is(<$fh>, "foo\n"); |
40 | ok(close $fh, $!); |
ae1204bf |
41 | |
42 | # Test that semantics are similar to normal file-based I/O |
43 | # Check that ">" clobbers the scalar |
44 | $var = "Something"; |
45 | open $fh, ">", \$var; |
42bc49da |
46 | is($var, ""); |
ae1204bf |
47 | # Check that file offset set to beginning of scalar |
48 | my $off = tell($fh); |
42bc49da |
49 | is($off, 0); |
ae1204bf |
50 | # Check that writes go where they should and update the offset |
51 | $var = "Something"; |
52 | print $fh "Brea"; |
53 | $off = tell($fh); |
42bc49da |
54 | is($off, 4); |
55 | is($var, "Breathing"); |
c350b88c |
56 | close $fh; |
ae1204bf |
57 | |
58 | # Check that ">>" appends to the scalar |
59 | $var = "Something "; |
c350b88c |
60 | open $fh, ">>", \$var; |
ae1204bf |
61 | $off = tell($fh); |
42bc49da |
62 | is($off, 10); |
63 | is($var, "Something "); |
ae1204bf |
64 | # Check that further writes go to the very end of the scalar |
65 | $var .= "else "; |
42bc49da |
66 | is($var, "Something else "); |
67 | |
ae1204bf |
68 | $off = tell($fh); |
42bc49da |
69 | is($off, 10); |
70 | |
ae1204bf |
71 | print $fh "is here"; |
42bc49da |
72 | is($var, "Something else is here"); |
23a2eb0a |
73 | close $fh; |
74 | |
75 | # Check that updates to the scalar from elsewhere do not |
76 | # cause problems |
77 | $var = "line one\nline two\line three\n"; |
78 | open $fh, "<", \$var; |
79 | while (<$fh>) { |
80 | $var = "foo"; |
81 | } |
82 | close $fh; |
42bc49da |
83 | is($var, "foo"); |
ecdeb87c |
84 | |
85 | # Check that dup'ing the handle works |
86 | |
87 | $var = ''; |
ecdeb87c |
88 | open $fh, "+>", \$var; |
42bc49da |
89 | print $fh "xxx\n"; |
ecdeb87c |
90 | open $dup,'+<&',$fh; |
42bc49da |
91 | print $dup "yyy\n"; |
92 | seek($dup,0,SEEK_SET); |
93 | is(<$dup>, "xxx\n"); |
94 | is(<$dup>, "yyy\n"); |
ecdeb87c |
95 | close($fh); |
96 | close($dup); |
97 | |
34fcc551 |
98 | open $fh, '<', \42; |
42bc49da |
99 | is(<$fh>, "42", "reading from non-string scalars"); |
34fcc551 |
100 | close $fh; |
c5b94a97 |
101 | |
42bc49da |
102 | { package P; sub TIESCALAR {bless{}} sub FETCH { "shazam" } } |
c5b94a97 |
103 | tie $p, P; open $fh, '<', \$p; |
42bc49da |
104 | is(<$fh>, "shazam", "reading from magic scalars"); |
03aa69f9 |
105 | |
106 | { |
107 | use warnings; |
42bc49da |
108 | my $warn = 0; |
109 | local $SIG{__WARN__} = sub { $warn++ }; |
03aa69f9 |
110 | open my $fh, '>', \my $scalar; |
111 | print $fh "foo"; |
112 | close $fh; |
42bc49da |
113 | is($warn, 0, "no warnings when writing to an undefined scalar"); |
03aa69f9 |
114 | } |
47cc46ee |
115 | |
116 | my $data = "a non-empty PV"; |
117 | $data = undef; |
118 | open(MEM, '<', \$data) or die "Fail: $!\n"; |
119 | my $x = join '', <MEM>; |
42bc49da |
120 | is($x, ''); |
5735c168 |
121 | |
122 | { |
123 | # [perl #35929] verify that works with $/ (i.e. test PerlIOScalar_unread) |
124 | my $s = <<'EOF'; |
125 | line A |
126 | line B |
127 | a third line |
128 | EOF |
129 | open(F, '<', \$s) or die "Could not open string as a file"; |
130 | local $/ = ""; |
131 | my $ln = <F>; |
132 | close F; |
42bc49da |
133 | is($ln, $s, "[perl #35929]"); |
5735c168 |
134 | } |
b35bc0c6 |
135 | |
136 | # [perl #40267] PerlIO::scalar doesn't respect readonly-ness |
137 | { |
42bc49da |
138 | ok(!(defined open(F, '>', \undef)), "[perl #40267] - $!"); |
b35bc0c6 |
139 | close F; |
42bc49da |
140 | |
b35bc0c6 |
141 | my $ro = \43; |
42bc49da |
142 | ok(!(defined open(F, '>', $ro)), $!); |
b35bc0c6 |
143 | close F; |
144 | # but we can read from it |
42bc49da |
145 | ok(open(F, '<', $ro), $!); |
146 | is(<F>, 43); |
b35bc0c6 |
147 | close F; |
148 | } |
42bc49da |
149 | |
150 | { |
151 | # Check that we zero fill when needed when seeking, |
152 | # and that seeking negative off the string does not do bad things. |
153 | |
154 | my $foo; |
155 | |
156 | ok(open(F, '>', \$foo)); |
157 | |
158 | # Seeking forward should zero fill. |
159 | |
160 | ok(seek(F, 50, SEEK_SET)); |
161 | print F "x"; |
162 | is(length($foo), 51); |
163 | like($foo, qr/^\0{50}x$/); |
164 | |
165 | is(tell(F), 51); |
166 | ok(seek(F, 0, SEEK_SET)); |
167 | is(length($foo), 51); |
168 | |
169 | # Seeking forward again should zero fill but only the new bytes. |
170 | |
171 | ok(seek(F, 100, SEEK_SET)); |
172 | print F "y"; |
173 | is(length($foo), 101); |
174 | like($foo, qr/^\0{50}x\0{49}y$/); |
175 | is(tell(F), 101); |
176 | |
177 | # Seeking back and writing should not zero fill. |
178 | |
179 | ok(seek(F, 75, SEEK_SET)); |
180 | print F "z"; |
181 | is(length($foo), 101); |
182 | like($foo, qr/^\0{50}x\0{24}z\0{24}y$/); |
183 | is(tell(F), 76); |
184 | |
185 | # Seeking negative should not do funny business. |
186 | |
187 | ok(!seek(F, -50, SEEK_SET), $!); |
188 | ok(seek(F, 0, SEEK_SET)); |
189 | ok(!seek(F, -50, SEEK_CUR), $!); |
190 | ok(!seek(F, -150, SEEK_END), $!); |
191 | } |
192 | |