view release on metacpan or  search on metacpan

lib/App/HTTP_Proxy_IMP/IMP.pm  view on Meta::CPAN

    my $typ = shift;
    $typ ~~ [ 'gzip','deflate' ] or return; # not supported

    my $gzip_csum;
    my $buf = '';
    my $inflate;

    return sub {
	my $data = shift;
	$buf .= $data;

	goto inflate if defined $inflate;

	# read gzip|deflate header
	my $wb;
	my $more = $data eq '' ? undef:''; # need more data if possible
	if ( $typ eq 'gzip' ) {
	    my $hdr_len = 10; # minimum gzip header

	    return $more if length($buf) < $hdr_len; 
	    my ($magic,$method,$flags) = unpack('vCC',$buf);
	    if ( $magic != 0x8b1f or $method != Z_DEFLATED or $flags & 0xe0 ) {
		$DEBUG && debug("no valid gzip header. assuming plain text");
		$inflate = ''; # defined but false
		goto inflate;
	    }
	    if ( $flags & 4 ) {
		# skip extra section
		return $more if length($buf) < ($hdr_len+=2);
		$hdr_len += unpack('x10v',$buf);
		return $more if length($buf) < $hdr_len;
	    }
	    if ( $flags & 8 ) {
		# skip filename
		my $o = index($buf,"\0",$hdr_len);
		return $more if $o == -1; # end of filename not found
		$hdr_len = $o+1;
	    }
	    if ( $flags & 16 ) {
		# skip comment
		my $o = index($buf,"\0",$hdr_len);
		return $more if $o == -1; # end of comment not found
		$hdr_len = $o+1;
	    }
	    if ( $flags & 2 ) {
		# skip CRC
		return $more if length($buf) < ($hdr_len+=2);
	    }

	    # remove header
	    substr($buf,0,$hdr_len,'');
	    $gzip_csum = 8; # 8 byte Adler CRC at end
	    $wb = -MAX_WBITS(); # see Compress::Raw::Zlib

	} else { 
	    # deflate
	    # according to RFC it should be zlib, but due to the encoding name
	    # often real deflate is used instead 
	    # check magic bytes to decide

	    # lets see if it looks like a zlib header
	    # check for CM=8, CMID<=7 in first byte and valid FCHECK in
	    # seconds byte
	    return $more if length($buf)<2;
	    my $magic = unpack('C',substr($buf,0,1));
	    if (
		( $magic & 0b1111 ) == 8                   # CM = 8
		and $magic >> 4 <= 7                       # CMID <= 7
		and unpack('n',substr($buf,0,2)) % 31 == 0 # valid FCHECK
	    ) {
		# looks like zlib header
		$wb = +MAX_WBITS(); # see Compress::Raw::Zlib
	    } else {
		# assume deflate
		$wb = -MAX_WBITS(); # see Compress::Raw::Zlib
	    }
	}

	$inflate = Compress::Raw::Zlib::Inflate->new(
	    -WindowBits => $wb,
	    -AppendOutput => 1,
	    -ConsumeInput => 1
	) or die "cannot create inflation stream";

	inflate:

	return '' if $buf eq '';

	if ( ! $inflate ) {
	    # wrong gzip header: sometimes servers claim to use gzip
	    # if confronted with "Accept-Encoding: identity" but in reality
	    # they send plain text
	    # so consider it plain text and don't decode
	    my $out = $buf;
	    $buf = '';
	    return $out
	}

	my $out = '';
	my $stat = $inflate->inflate(\$buf,\$out);
	if ( $stat == Z_STREAM_END ) {
	    if ( $gzip_csum and length($buf) >= $gzip_csum ) {
		# TODO - check checksum - but what would it help?
		substr($buf,0,$gzip_csum,'');
		$gzip_csum = 0;
	    }
	} elsif ( $stat != Z_OK ) {
	    $DEBUG && debug("decode failed: $stat");
	    return; # error
	}
	return $out 
    };
}

1;