diff --git a/Changes b/Changes index ea27091e8..2dcbda25c 100644 --- a/Changes +++ b/Changes @@ -6,6 +6,9 @@ {{$NEXT}} + - Remove Test::Builder::IO::Scalar + - Fix #1016 + 1.302205 2024-12-19 09:28:05-08:00 America/Los_Angeles - Use our instead of 'use vars' diff --git a/lib/Test/Builder.pm b/lib/Test/Builder.pm index 87884c8b4..95101de13 100644 --- a/lib/Test/Builder.pm +++ b/lib/Test/Builder.pm @@ -6,12 +6,6 @@ use warnings; our $VERSION = '1.302206'; -BEGIN { - if( $] < 5.008 ) { - require Test::Builder::IO::Scalar; - } -} - use Scalar::Util qw/blessed reftype weaken/; use Test2::Util qw/USE_THREADS try get_tid/; @@ -1366,27 +1360,19 @@ sub todo_output { sub _new_fh { my $self = shift; - my($file_or_fh) = shift; + my ($file_or_fh) = shift; my $fh; - if( $self->is_fh($file_or_fh) ) { + if ($self->is_fh($file_or_fh)) { $fh = $file_or_fh; } - elsif( ref $file_or_fh eq 'SCALAR' ) { - # Scalar refs as filehandles was added in 5.8. - if( $] >= 5.008 ) { - open $fh, ">>", $file_or_fh - or $self->croak("Can't open scalar ref $file_or_fh: $!"); - } - # Emulate scalar ref filehandles with a tie. - else { - $fh = Test::Builder::IO::Scalar->new($file_or_fh) - or $self->croak("Can't tie scalar ref $file_or_fh"); - } + elsif (ref $file_or_fh eq 'SCALAR') { + open $fh, ">>", $file_or_fh + or $self->croak("Can't open scalar ref $file_or_fh: $!"); } else { open $fh, ">", $file_or_fh - or $self->croak("Can't open test output log $file_or_fh: $!"); + or $self->croak("Can't open test output log $file_or_fh: $!"); _autoflush($fh); } diff --git a/lib/Test/Builder/IO/Scalar.pm b/lib/Test/Builder/IO/Scalar.pm deleted file mode 100644 index 9d6aa36e5..000000000 --- a/lib/Test/Builder/IO/Scalar.pm +++ /dev/null @@ -1,658 +0,0 @@ -package Test::Builder::IO::Scalar; - - -=head1 NAME - -Test::Builder::IO::Scalar - A copy of IO::Scalar for Test::Builder - -=head1 DESCRIPTION - -This is a copy of L which ships with L to -support scalar references as filehandles on Perl 5.6. Newer -versions of Perl simply use C's built in support. - -L can not have dependencies on other modules without -careful consideration, so its simply been copied into the distribution. - -=head1 COPYRIGHT and LICENSE - -This file came from the "IO-stringy" Perl5 toolkit. - -Copyright (c) 1996 by Eryq. All rights reserved. -Copyright (c) 1999,2001 by ZeeGee Software Inc. All rights reserved. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - - -=cut - -# This is copied code, I don't care. -##no critic - -use Carp; -use strict; -use IO::Handle; - -use 5.005; - -### The package version, both in 1.23 style *and* usable by MakeMaker: -our $VERSION = '1.302206'; - -### Inheritance: -our @ISA = qw(IO::Handle); - -#============================== - -=head2 Construction - -=over 4 - -=cut - -#------------------------------ - -=item new [ARGS...] - -I -Return a new, unattached scalar handle. -If any arguments are given, they're sent to open(). - -=cut - -sub new { - my $proto = shift; - my $class = ref($proto) || $proto; - my $self = bless \do { local *FH }, $class; - tie *$self, $class, $self; - $self->open(@_); ### open on anonymous by default - $self; -} -sub DESTROY { - shift->close; -} - -#------------------------------ - -=item open [SCALARREF] - -I -Open the scalar handle on a new scalar, pointed to by SCALARREF. -If no SCALARREF is given, a "private" scalar is created to hold -the file data. - -Returns the self object on success, undefined on error. - -=cut - -sub open { - my ($self, $sref) = @_; - - ### Sanity: - defined($sref) or do {my $s = ''; $sref = \$s}; - (ref($sref) eq "SCALAR") or croak "open() needs a ref to a scalar"; - - ### Setup: - *$self->{Pos} = 0; ### seek position - *$self->{SR} = $sref; ### scalar reference - $self; -} - -#------------------------------ - -=item opened - -I -Is the scalar handle opened on something? - -=cut - -sub opened { - *{shift()}->{SR}; -} - -#------------------------------ - -=item close - -I -Disassociate the scalar handle from its underlying scalar. -Done automatically on destroy. - -=cut - -sub close { - my $self = shift; - %{*$self} = (); - 1; -} - -=back - -=cut - - - -#============================== - -=head2 Input and output - -=over 4 - -=cut - - -#------------------------------ - -=item flush - -I -No-op, provided for OO compatibility. - -=cut - -sub flush { "0 but true" } - -#------------------------------ - -=item getc - -I -Return the next character, or undef if none remain. - -=cut - -sub getc { - my $self = shift; - - ### Return undef right away if at EOF; else, move pos forward: - return undef if $self->eof; - substr(${*$self->{SR}}, *$self->{Pos}++, 1); -} - -#------------------------------ - -=item getline - -I -Return the next line, or undef on end of string. -Can safely be called in an array context. -Currently, lines are delimited by "\n". - -=cut - -sub getline { - my $self = shift; - - ### Return undef right away if at EOF: - return undef if $self->eof; - - ### Get next line: - my $sr = *$self->{SR}; - my $i = *$self->{Pos}; ### Start matching at this point. - - ### Minimal impact implementation! - ### We do the fast fast thing (no regexps) if using the - ### classic input record separator. - - ### Case 1: $/ is undef: slurp all... - if (!defined($/)) { - *$self->{Pos} = length $$sr; - return substr($$sr, $i); - } - - ### Case 2: $/ is "\n": zoom zoom zoom... - elsif ($/ eq "\012") { - - ### Seek ahead for "\n"... yes, this really is faster than regexps. - my $len = length($$sr); - for (; $i < $len; ++$i) { - last if ord (substr ($$sr, $i, 1)) == 10; - } - - ### Extract the line: - my $line; - if ($i < $len) { ### We found a "\n": - $line = substr ($$sr, *$self->{Pos}, $i - *$self->{Pos} + 1); - *$self->{Pos} = $i+1; ### Remember where we finished up. - } - else { ### No "\n"; slurp the remainder: - $line = substr ($$sr, *$self->{Pos}, $i - *$self->{Pos}); - *$self->{Pos} = $len; - } - return $line; - } - - ### Case 3: $/ is ref to int. Do fixed-size records. - ### (Thanks to Dominique Quatravaux.) - elsif (ref($/)) { - my $len = length($$sr); - my $i = ${$/} + 0; - my $line = substr ($$sr, *$self->{Pos}, $i); - *$self->{Pos} += $i; - *$self->{Pos} = $len if (*$self->{Pos} > $len); - return $line; - } - - ### Case 4: $/ is either "" (paragraphs) or something weird... - ### This is Graham's general-purpose stuff, which might be - ### a tad slower than Case 2 for typical data, because - ### of the regexps. - else { - pos($$sr) = $i; - - ### If in paragraph mode, skip leading lines (and update i!): - length($/) or - (($$sr =~ m/\G\n*/g) and ($i = pos($$sr))); - - ### If we see the separator in the buffer ahead... - if (length($/) - ? $$sr =~ m,\Q$/\E,g ### (ordinary sep) TBD: precomp! - : $$sr =~ m,\n\n,g ### (a paragraph) - ) { - *$self->{Pos} = pos $$sr; - return substr($$sr, $i, *$self->{Pos}-$i); - } - ### Else if no separator remains, just slurp the rest: - else { - *$self->{Pos} = length $$sr; - return substr($$sr, $i); - } - } -} - -#------------------------------ - -=item getlines - -I -Get all remaining lines. -It will croak() if accidentally called in a scalar context. - -=cut - -sub getlines { - my $self = shift; - wantarray or croak("can't call getlines in scalar context!"); - my ($line, @lines); - push @lines, $line while (defined($line = $self->getline)); - @lines; -} - -#------------------------------ - -=item print ARGS... - -I -Print ARGS to the underlying scalar. - -B this continues to always cause a seek to the end -of the string, but if you perform seek()s and tell()s, it is -still safer to explicitly seek-to-end before subsequent print()s. - -=cut - -sub print { - my $self = shift; - *$self->{Pos} = length(${*$self->{SR}} .= join('', @_) . (defined($\) ? $\ : "")); - 1; -} -sub _unsafe_print { - my $self = shift; - my $append = join('', @_) . $\; - ${*$self->{SR}} .= $append; - *$self->{Pos} += length($append); - 1; -} -sub _old_print { - my $self = shift; - ${*$self->{SR}} .= join('', @_) . $\; - *$self->{Pos} = length(${*$self->{SR}}); - 1; -} - - -#------------------------------ - -=item read BUF, NBYTES, [OFFSET] - -I -Read some bytes from the scalar. -Returns the number of bytes actually read, 0 on end-of-file, undef on error. - -=cut - -sub read { - my $self = $_[0]; - my $n = $_[2]; - my $off = $_[3] || 0; - - my $read = substr(${*$self->{SR}}, *$self->{Pos}, $n); - $n = length($read); - *$self->{Pos} += $n; - ($off ? substr($_[1], $off) : $_[1]) = $read; - return $n; -} - -#------------------------------ - -=item write BUF, NBYTES, [OFFSET] - -I -Write some bytes to the scalar. - -=cut - -sub write { - my $self = $_[0]; - my $n = $_[2]; - my $off = $_[3] || 0; - - my $data = substr($_[1], $off, $n); - $n = length($data); - $self->print($data); - return $n; -} - -#------------------------------ - -=item sysread BUF, LEN, [OFFSET] - -I -Read some bytes from the scalar. -Returns the number of bytes actually read, 0 on end-of-file, undef on error. - -=cut - -sub sysread { - my $self = shift; - $self->read(@_); -} - -#------------------------------ - -=item syswrite BUF, NBYTES, [OFFSET] - -I -Write some bytes to the scalar. - -=cut - -sub syswrite { - my $self = shift; - $self->write(@_); -} - -=back - -=cut - - -#============================== - -=head2 Seeking/telling and other attributes - -=over 4 - -=cut - - -#------------------------------ - -=item autoflush - -I -No-op, provided for OO compatibility. - -=cut - -sub autoflush {} - -#------------------------------ - -=item binmode - -I -No-op, provided for OO compatibility. - -=cut - -sub binmode {} - -#------------------------------ - -=item clearerr - -I Clear the error and EOF flags. A no-op. - -=cut - -sub clearerr { 1 } - -#------------------------------ - -=item eof - -I Are we at end of file? - -=cut - -sub eof { - my $self = shift; - (*$self->{Pos} >= length(${*$self->{SR}})); -} - -#------------------------------ - -=item seek OFFSET, WHENCE - -I Seek to a given position in the stream. - -=cut - -sub seek { - my ($self, $pos, $whence) = @_; - my $eofpos = length(${*$self->{SR}}); - - ### Seek: - if ($whence == 0) { *$self->{Pos} = $pos } ### SEEK_SET - elsif ($whence == 1) { *$self->{Pos} += $pos } ### SEEK_CUR - elsif ($whence == 2) { *$self->{Pos} = $eofpos + $pos} ### SEEK_END - else { croak "bad seek whence ($whence)" } - - ### Fixup: - if (*$self->{Pos} < 0) { *$self->{Pos} = 0 } - if (*$self->{Pos} > $eofpos) { *$self->{Pos} = $eofpos } - return 1; -} - -#------------------------------ - -=item sysseek OFFSET, WHENCE - -I Identical to C, I - -=cut - -sub sysseek { - my $self = shift; - $self->seek (@_); -} - -#------------------------------ - -=item tell - -I -Return the current position in the stream, as a numeric offset. - -=cut - -sub tell { *{shift()}->{Pos} } - -#------------------------------ - -=item use_RS [YESNO] - -I -B -Obey the current setting of $/, like IO::Handle does? -Default is false in 1.x, but cold-welded true in 2.x and later. - -=cut - -sub use_RS { - my ($self, $yesno) = @_; - carp "use_RS is deprecated and ignored; \$/ is always consulted\n"; - } - -#------------------------------ - -=item setpos POS - -I -Set the current position, using the opaque value returned by C. - -=cut - -sub setpos { shift->seek($_[0],0) } - -#------------------------------ - -=item getpos - -I -Return the current position in the string, as an opaque object. - -=cut - -*getpos = \&tell; - - -#------------------------------ - -=item sref - -I -Return a reference to the underlying scalar. - -=cut - -sub sref { *{shift()}->{SR} } - - -#------------------------------ -# Tied handle methods... -#------------------------------ - -# Conventional tiehandle interface: -sub TIEHANDLE { - ((defined($_[1]) && UNIVERSAL::isa($_[1], __PACKAGE__)) - ? $_[1] - : shift->new(@_)); -} -sub GETC { shift->getc(@_) } -sub PRINT { shift->print(@_) } -sub PRINTF { shift->print(sprintf(shift, @_)) } -sub READ { shift->read(@_) } -sub READLINE { wantarray ? shift->getlines(@_) : shift->getline(@_) } -sub WRITE { shift->write(@_); } -sub CLOSE { shift->close(@_); } -sub SEEK { shift->seek(@_); } -sub TELL { shift->tell(@_); } -sub EOF { shift->eof(@_); } -sub FILENO { -1 } - -#------------------------------------------------------------ - -1; - -__END__ - - - -=back - -=cut - - -=head1 WARNINGS - -Perl's TIEHANDLE spec was incomplete prior to 5.005_57; -it was missing support for C, C, and C. -Attempting to use these functions with an IO::Scalar will not work -prior to 5.005_57. IO::Scalar will not have the relevant methods -invoked; and even worse, this kind of bug can lie dormant for a while. -If you turn warnings on (via C<$^W> or C), -and you see something like this... - - attempt to seek on unopened filehandle - -...then you are probably trying to use one of these functions -on an IO::Scalar with an old Perl. The remedy is to simply -use the OO version; e.g.: - - $SH->seek(0,0); ### GOOD: will work on any 5.005 - seek($SH,0,0); ### WARNING: will only work on 5.005_57 and beyond - - -=head1 VERSION - -$Id: Scalar.pm,v 1.6 2005/02/10 21:21:53 dfs Exp $ - - -=head1 AUTHORS - -=head2 Primary Maintainer - -David F. Skoll (F). - -=head2 Principal author - -Eryq (F). -President, ZeeGee Software Inc (F). - - -=head2 Other contributors - -The full set of contributors always includes the folks mentioned -in L. But just the same, special -thanks to the following individuals for their invaluable contributions -(if I've forgotten or misspelled your name, please email me!): - -I -for contributing C. - -I -for suggesting C. - -I -for finding and fixing the bug in C. - -I -for his offset-using read() and write() implementations. - -I -for his patches to massively improve the performance of C -and add C and C. - -I -for stringification and inheritance improvements, -and sundry good ideas. - -I -for the IO::Handle inheritance and automatic tie-ing. - - -=head1 SEE ALSO - -L, which is quite similar but which was designed -more-recently and with an IO::Handle-like interface in mind, -so you could mix OO- and native-filehandle usage without using tied(). - -I as of version 2.x, these classes all work like -their IO::Handle counterparts, so we have comparable -functionality to IO::String. - -=cut - diff --git a/lib/Test2/Tools/Tiny.pm b/lib/Test2/Tools/Tiny.pm index 56f2b1b18..1eea5dcef 100644 --- a/lib/Test2/Tools/Tiny.pm +++ b/lib/Test2/Tools/Tiny.pm @@ -2,12 +2,6 @@ package Test2::Tools::Tiny; use strict; use warnings; -BEGIN { - if ("$]" < 5.008) { - require Test::Builder::IO::Scalar; - } -} - use Scalar::Util qw/blessed/; use Test2::Util qw/try/; @@ -259,16 +253,9 @@ sub capture(&) { my ($out_fh, $err_fh); ($ok, $e) = try { - # Scalar refs as filehandles were added in 5.8. - if ("$]" >= 5.008) { + # Scalar refs as filehandles were added in 5.8. open($out_fh, '>', \$out) or die "Failed to open a temporary STDOUT: $!"; open($err_fh, '>', \$err) or die "Failed to open a temporary STDERR: $!"; - } - # Emulate scalar ref filehandles with a tie. - else { - $out_fh = Test::Builder::IO::Scalar->new(\$out) or die "Failed to open a temporary STDOUT"; - $err_fh = Test::Builder::IO::Scalar->new(\$err) or die "Failed to open a temporary STDERR"; - } test2_stack->top->format->set_handles([$out_fh, $err_fh, $out_fh]); diff --git a/t/Test2/modules/Util.t b/t/Test2/modules/Util.t index 1171ff7a5..73108aa65 100644 --- a/t/Test2/modules/Util.t +++ b/t/Test2/modules/Util.t @@ -33,12 +33,6 @@ use Test2::Util qw/ clone_io /; -BEGIN { - if ("$]" < 5.008) { - require Test::Builder::IO::Scalar; - } -} - { for my $try (\&try, Test2::Util->can('_manual_try'), Test2::Util->can('_local_try')) { my ($ok, $err) = $try->(sub { die "xxx" }); @@ -83,11 +77,7 @@ close($io); my $fh; my $out = ''; -if ("$]" >= 5.008) { - open($fh, '>', \$out) or die "Could not open filehandle"; -} else { - $fh = Test::Builder::IO::Scalar->new(\$out) or die "Could not open filehandle"; -} +open($fh, '>', \$out) or die "Could not open filehandle"; $io = clone_io($fh); is($io, $fh, "For a scalar handle we simply return the original handle, no other choice");