Cross Reference:
xref
: /
illumos-gate
/
usr
/
src
/
cmd
/
perl
/
5.6.1
/
distrib
/
t
/
op
/
tiehandle.t
Home
History
Annotate
Line#
Navigate
Download
Search
only in
./
tiehandle.t revision 7c478bd95313f5f23a4c958a745db2134aa03244
1008
N/A
#!./perl
1008
N/A
1008
N/A
BEGIN
{
1008
N/A
chdir
't'
if
-d
't'
;
1008
N/A
@
INC
=
'../lib'
;
1008
N/A
}
1008
N/A
1008
N/A
my
@
expect
;
1008
N/A
my
$data
=
""
;
1008
N/A
my
@
data
=
()
;
1008
N/A
my
$test
=
1
;
1008
N/A
1008
N/A
sub
ok
{
print
"not "
unless
shift
;
print
"ok "
,
$test
++,
"\n"
; }
1008
N/A
1008
N/A
package
Implement
;
1008
N/A
1008
N/A
BEGIN
{ *
ok
= \*
main
::
ok
}
1008
N/A
1008
N/A
sub
compare
{
1008
N/A
return
unless
@
expect
;
1008
N/A
return
ok
(
0
)
unless
(@_ == @
expect
)
;
1008
N/A
1008
N/A
my
$i;
1008
N/A
for
($i =
0
; $i < @_ ; $i++)
{
1008
N/A
next
if
$_[$i]
eq
$expect
[$i];
1008
N/A
return
ok
(
0
)
;
1008
N/A
}
1008
N/A
1008
N/A
ok
(
1
)
;
1008
N/A
}
1008
N/A
1008
N/A
sub
TIEHANDLE
{
1008
N/A
compare
(
TIEHANDLE
=> @_)
;
1008
N/A
my
(
$class
,@
val
)
= @_;
1008
N/A
return
bless
\@
val
,
$class
;
1008
N/A
}
1008
N/A
1008
N/A
sub
PRINT
{
1008
N/A
compare
(
PRINT
=> @_)
;
1008
N/A
1
;
1008
N/A
}
1008
N/A
1008
N/A
sub
PRINTF
{
1008
N/A
compare
(
PRINTF
=> @_)
;
1008
N/A
2
;
1008
N/A
}
1008
N/A
1008
N/A
sub
READLINE
{
1008
N/A
compare
(
READLINE
=> @_)
;
1008
N/A
wantarray
? @
data
:
shift
@
data
;
1008
N/A
}
1008
N/A
1008
N/A
sub
GETC
{
1008
N/A
compare
(
GETC
=> @_)
;
1008
N/A
substr
(
$data
,
0
,
1
)
;
1008
N/A
}
1008
N/A
1008
N/A
sub
READ
{
1008
N/A
compare
(
READ
=> @_)
;
1008
N/A
substr
($_[
1
],$_[
3
] ||
0
)
=
substr
(
$data
,
0
,$_[
2
])
;
1008
N/A
3
;
1008
N/A
}
1008
N/A
1008
N/A
sub
WRITE
{
1008
N/A
compare
(
WRITE
=> @_)
;
1008
N/A
$data
=
substr
($_[
1
],$_[
3
] ||
0
, $_[
2
])
;
length
(
$data
)
;
}
sub
CLOSE
{
compare
(
CLOSE
=> @_)
;
5
;
}
package
main
;
use
Symbol
;
print
"1..33\n"
;
my
$fh
=
gensym
;
@
expect
=
(
TIEHANDLE
=>
'Implement'
)
;
my
$ob
=
tie
*
$fh
,
'Implement'
;
ok
(
ref
(
$ob
)
eq
'Implement'
)
;
ok
(
tied
(*
$fh
)
==
$ob
)
;
@
expect
=
(
PRINT
=>
$ob
,
"some"
,
"text"
)
;
$r =
print
$fh
@
expect
[
2
,
3
];
ok
($r ==
1
)
;
@
expect
=
(
PRINTF
=>
$ob
,
"%s"
,
"text"
)
;
$r =
printf
$fh
@
expect
[
2
,
3
];
ok
($r ==
2
)
;
$text
=
(@
data
=
(
"the line\n"
)
)
[
0
];
@
expect
=
(
READLINE
=>
$ob
)
;
$ln
= <
$fh
>;
ok
(
$ln
eq
$text
)
;
@
expect
=
()
;
@
in
= @
data
=
qw
(a
line
at
a
time
)
;
@
line
= <
$fh
>;
@
expect
= @
in
;
Implement
::
compare
(@
line
)
;
@
expect
=
(
GETC
=>
$ob
)
;
$data
=
"abc"
;
$ch
=
getc
$fh
;
ok
(
$ch
eq
"a"
)
;
$buf
=
"xyz"
;
@
expect
=
(
READ
=>
$ob
,
$buf
,
3
)
;
$data
=
"abc"
;
$r =
read
$fh
,
$buf
,
3
;
ok
($r ==
3
)
;
ok
(
$buf
eq
"abc"
)
;
$buf
=
"xyzasd"
;
@
expect
=
(
READ
=>
$ob
,
$buf
,
3
,
3
)
;
$data
=
"abc"
;
$r =
sysread
$fh
,
$buf
,
3
,
3
;
ok
($r ==
3
)
;
ok
(
$buf
eq
"xyzabc"
)
;
$buf
=
"qwerty"
;
@
expect
=
(
WRITE
=>
$ob
,
$buf
,
4
,
1
)
;
$data
=
""
;
$r =
syswrite
$fh
,
$buf
,
4
,
1
;
ok
($r ==
4
)
;
ok
(
$data
eq
"wert"
)
;
$buf
=
"qwerty"
;
@
expect
=
(
WRITE
=>
$ob
,
$buf
,
4
)
;
$data
=
""
;
$r =
syswrite
$fh
,
$buf
,
4
;
ok
($r ==
4
)
;
ok
(
$data
eq
"qwer"
)
;
$buf
=
"qwerty"
;
@
expect
=
(
WRITE
=>
$ob
,
$buf
,
6
)
;
$data
=
""
;
$r =
syswrite
$fh
,
$buf
;
ok
($r ==
6
)
;
ok
(
$data
eq
"qwerty"
)
;
@
expect
=
(
CLOSE
=>
$ob
)
;
$r =
close
$fh
;
ok
($r ==
5
)
;
# Does aliasing work with tied FHs?
*
ALIAS
= *
$fh
;
@
expect
=
(
PRINT
=>
$ob
,
"some"
,
"text"
)
;
$r =
print
ALIAS
@
expect
[
2
,
3
];
ok
($r ==
1
)
;
{
use
warnings
;
# Special case of aliasing STDERR, which used
# to dump core when warnings were enabled
*
STDERR
= *
$fh
;
@
expect
=
(
PRINT
=>
$ob
,
"some"
,
"text"
)
;
$r =
print
STDERR
@
expect
[
2
,
3
];
ok
($r ==
1
)
;
}