view release on metacpan or  search on metacpan

lib/PerlIO/via/xz.pm  view on Meta::CPAN

package PerlIO::via::xz;

use 5.012000;
use warnings;

use PerlIO;
use IO::Compress::Xz     qw( $XzError   );
use IO::Uncompress::UnXz qw( $UnXzError );
#use Data::Peek;
use Carp;

our $VERSION = "0.07";

sub import {
    my ($class, %args) = @_;

#DDumper { import => \@_ };
    } # import

# $class->PUSHED ([$mode, [$fh]])
#   Should return an object or the class, or -1 on failure.  (Compare
#   TIEHANDLE.)  The arguments are an optional mode string ("r", "w",
#   "w+", ...) and a filehandle for the PerlIO layer below.  Mandatory.
#
#   When the layer is pushed as part of an "open" call, "PUSHED" will be
#   called before the actual open occurs, whether that be via "OPEN",
#   "SYSOPEN", "FDOPEN" or by letting a lower layer do the open.
sub PUSHED {
    my ($class, $mode, $fh) = @_;

#DDumper { PUSHED => \@_ };
    $mode =~ m/^[wr]$/ or return 1;
    my $self = {
	mode  => $mode,		# "r" or "w"
	fh    => undef,
	level => 9,		# Not yet settable
	bsz   => 4096,		# Not yet settable
	xz    => undef,
	};
    return bless $self => $class;
    } # PUSHED

sub FILENO {
    my ($self, $fh) = @_;
#DDumper { FILENO => \@_ };
    unless (defined $self->{xz}) {
	$self->{fh}     = $fh;
	$self->{fileno} = fileno $fh;
	if ($self->{mode} eq "r") {
	    my $in  = $fh;
	    $self->{xz} = IO::Uncompress::UnXz->new ($in,
		BlockSize => $self->{bsz},
		) or croak "Something went wrong in new (): $UnXzError";
	    }
	else {
	    my $out = $fh;
	    $self->{xz} = IO::Compress::Xz->new ($out,
		AutoClose => 1,
		Preset    => $self->{level},
		) or croak "Something went wrong in new (): $XzError";
	    $self->{xz}->autoflush (1);
	    }
	}
#DDumper $self;
    $self->{fileno};
    } # FILENO

# $obj->POPPED ([$fh])
#   Optional - called when the layer is about to be removed.
#
# $obj->UTF8 ($belowFlag, [$fh])
#   Optional - if present it will be called immediately after PUSHED
#   has returned. It should return a true value if the layer expects
#   data to be UTF-8 encoded. If it returns true, the result is as if
#   the caller had done
#
#        ":via(YourClass):utf8"
#
#   If not present or if it returns false, then the stream is left with
#   the UTF-8 flag clear.  The $belowFlag argument will be true if
#   there is a layer below and that layer was expecting UTF-8.
#
# $obj->OPEN ($path, $mode, [$fh])
#   Optional - if not present a lower layer does the open.  If present,
#   called for normal opens after the layer is pushed.  This function
#   is subject to change as there is no easy way to get a lower layer
#   to do the open and then regain control.
#
# $obj->BINMODE ([$fh])
#   Optional - if not present the layer is popped on binmode ($fh) or
#   when ":raw" is pushed. If present it should return 0 on success, -1
#   on error, or undef to pop the layer.
#
# $obj->FDOPEN ($fd, [$fh])
#   Optional - if not present a lower layer does the open.  If present,
#   called after the layer is pushed for opens which pass a numeric
#   file descriptor.  This function is subject to change as there is no
#   easy way to get a lower layer to do the open and then regain control.
#
# $obj->SYSOPEN ($path, $imode, $perm, [$fh])