1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
|
#!./perl
# Test $!
print "1..16\n";
$teststring = "1\n12\n123\n1234\n1234\n12345\n\n123456\n1234567\n";
# Create our test datafile
1 while unlink 'foo'; # in case junk left around
rmdir 'foo';
open TESTFILE, ">./foo" or die "error $! $^E opening";
binmode TESTFILE;
print TESTFILE $teststring;
close TESTFILE or die "error $! $^E closing";
open TESTFILE, "<./foo";
binmode TESTFILE;
# Check the default $/
$bar = <TESTFILE>;
if ($bar eq "1\n") {print "ok 1\n";} else {print "not ok 1\n";}
# explicitly set to \n
$/ = "\n";
$bar = <TESTFILE>;
if ($bar eq "12\n") {print "ok 2\n";} else {print "not ok 2\n";}
# Try a non line terminator
$/ = 3;
$bar = <TESTFILE>;
if ($bar eq "123") {print "ok 3\n";} else {print "not ok 3\n";}
# Eat the line terminator
$/ = "\n";
$bar = <TESTFILE>;
# How about a larger terminator
$/ = "34";
$bar = <TESTFILE>;
if ($bar eq "1234") {print "ok 4\n";} else {print "not ok 4\n";}
# Eat the line terminator
$/ = "\n";
$bar = <TESTFILE>;
# Does paragraph mode work?
$/ = '';
$bar = <TESTFILE>;
if ($bar eq "1234\n12345\n\n") {print "ok 5\n";} else {print "not ok 5\n";}
# Try slurping the rest of the file
$/ = undef;
$bar = <TESTFILE>;
if ($bar eq "123456\n1234567\n") {print "ok 6\n";} else {print "not ok 6\n";}
# try the record reading tests. New file so we don't have to worry about
# the size of \n.
close TESTFILE;
unlink "./foo";
open TESTFILE, ">./foo";
print TESTFILE "1234567890123456789012345678901234567890";
binmode TESTFILE;
close TESTFILE;
open TESTFILE, "<./foo";
binmode TESTFILE;
# Test straight number
$/ = \2;
$bar = <TESTFILE>;
if ($bar eq "12") {print "ok 7\n";} else {print "not ok 7\n";}
# Test stringified number
$/ = \"2";
$bar = <TESTFILE>;
if ($bar eq "34") {print "ok 8\n";} else {print "not ok 8\n";}
# Integer variable
$foo = 2;
$/ = \$foo;
$bar = <TESTFILE>;
if ($bar eq "56") {print "ok 9\n";} else {print "not ok 9\n";}
# String variable
$foo = "2";
$/ = \$foo;
$bar = <TESTFILE>;
if ($bar eq "78") {print "ok 10\n";} else {print "not ok 10\n";}
close TESTFILE;
# Now for the tricky bit--full record reading
if ($^O eq 'VMS') {
# Create a temp file. We jump through these hoops 'cause CREATE really
# doesn't like our methods for some reason.
open FDLFILE, "> ./foo.fdl";
print FDLFILE "RECORD\n FORMAT VARIABLE\n";
close FDLFILE;
open CREATEFILE, "> ./foo.com";
print CREATEFILE '$ DEFINE/USER SYS$INPUT NL:', "\n";
print CREATEFILE '$ DEFINE/USER SYS$OUTPUT NL:', "\n";
print CREATEFILE '$ OPEN YOW []FOO.BAR/WRITE', "\n";
print CREATEFILE '$ CLOSE YOW', "\n";
print CREATEFILE "\$EXIT\n";
close CREATEFILE;
$throwaway = `\@\[\]foo`, "\n";
open(TEMPFILE, ">./foo.bar") or print "# open failed $! $^E\n";
print TEMPFILE "foo\nfoobar\nbaz\n";
close TEMPFILE;
open TESTFILE, "<./foo.bar";
$/ = \10;
$bar = <TESTFILE>;
if ($bar eq "foo\n") {print "ok 11\n";} else {print "not ok 11\n";}
$bar = <TESTFILE>;
if ($bar eq "foobar\n") {print "ok 12\n";} else {print "not ok 12\n";}
# can we do a short read?
$/ = \2;
$bar = <TESTFILE>;
if ($bar eq "ba") {print "ok 13\n";} else {print "not ok 13\n";}
# do we get the rest of the record?
$bar = <TESTFILE>;
if ($bar eq "z\n") {print "ok 14\n";} else {print "not ok 14\n";}
close TESTFILE;
1 while unlink qw(foo.bar foo.com foo.fdl);
} else {
# Nobody else does this at the moment (well, maybe OS/390, but they can
# put their own tests in) so we just punt
foreach $test (11..14) {print "ok $test # skipped on non-VMS system\n"};
}
$/ = "\n";
# see if open/readline/close work on our and my variables
{
if (open our $T, "./foo") {
my $line = <$T>;
print "# $line\n";
length($line) == 40 or print "not ";
close $T or print "not ";
}
else {
print "not ";
}
print "ok 15\n";
}
{
if (open my $T, "./foo") {
my $line = <$T>;
print "# $line\n";
length($line) == 40 or print "not ";
close $T or print "not ";
}
else {
print "not ";
}
print "ok 16\n";
}
# Get rid of the temp file
END { unlink "./foo"; }
|
