package TB2::CanDupFilehandles;
use TB2::Mouse ();
use TB2::Mouse::Role;
with 'TB2::CanTry';
our $VERSION = '1.005000_005';
$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
=head1 NAME
TB2::CanDupFilehandles - A role for duplicating filehandles
=head1 SYNOPSIS
package Some::Thing;
use TB2::Mouse;
with 'TB2::CanDupFilehandles';
=head1 DESCRIPTION
This role supplies a class with the ability to duplicate filehandles
in a way which also copies IO layers such as UTF8.
It's most handy for Streamers.
=head1 METHODS
=head3 dup_filehandle
my $duplicate = $obj->dup_filehandle($src);
my $duplicate = $obj->dup_filehandle($src, $duplicate);
Creates a duplicate filehandle including copying any IO layers.
If you hand it an existing $duplicate filehandle it will overwrite it
and return it. If it's undef, it will return a new one. This
is handy as it will preserve the glob and fileno.
=cut
sub dup_filehandle {
my $self = shift;
my($fh, $dup) = @_;
local $!;
open( $dup, ">&", $fh ) or die "Can't dup $fh: $!";
$self->_copy_io_layers( $fh, $dup );
return $dup;
}
=head3 autoflush
$obj->autoflush($fh);
Turns on autoflush for a filehandle.
=cut
sub autoflush {
my $self = shift;
my $fh = shift;
my $old_fh = select $fh;
$| = 1;
select $old_fh;
return;
}
sub _copy_io_layers {
my( $self, $src, $dst ) = @_;
$self->try(
sub {
require PerlIO;
my @src_layers = PerlIO::get_layers($src);
_apply_layers($dst, @src_layers) if @src_layers;
}
);
return;
}
sub _apply_layers {
my ($fh, @layers) = @_;
my %seen;
my @unique = grep { defined $_ } grep { $_ ne 'unix' and !$seen{$_}++ } @layers;
binmode($fh, join(":", "", "raw", @unique));
}
no TB2::Mouse::Role;
1;