1package IO::Compress::Adapter::Lzf ; 2 3use strict; 4use warnings; 5use bytes; 6 7use IO::Compress::Base::Common 2.101 qw(:Status); 8use Compress::LZF ; 9 10our ($VERSION); 11$VERSION = '2.101'; 12 13use constant SIGNATURE => 'ZV'; 14 15sub mkCompObject 16{ 17 my $blocksize = shift ; 18 19 return bless { 20 'Buffer' => '', 21 'BlockSize' => $blocksize, 22 #'CRC' => ! $minimal, 23 'Error' => '', 24 'ErrorNo' => 0, 25 'CompBytes' => 0, 26 'UnCompBytes'=> 0, 27 } ; 28} 29 30sub compr 31{ 32 my $self = shift ; 33 34 $self->{Buffer} .= ${ $_[0] } ; 35 return $self->writeBlock(\$_[1], 0) 36 if length $self->{Buffer} >= $self->{BlockSize} ; 37 38 39 return STATUS_OK; 40} 41 42sub flush 43{ 44 my $self = shift ; 45 46 return STATUS_OK 47 unless length $self->{Buffer}; 48 49 return $self->writeBlock(\$_[0], 1); 50} 51 52sub close 53{ 54 my $self = shift ; 55 56 return STATUS_OK 57 unless length $self->{Buffer}; 58 59 return $self->writeBlock(\$_[0], 1); 60} 61 62sub writeBlock 63{ 64 my $self = shift; 65 my $flush = $_[1] ; 66 my $blockSize = $self->{BlockSize} ; 67 68 while (length $self->{Buffer} >= $blockSize) { 69 my $buff = substr($self->{Buffer}, 0, $blockSize); 70 substr($self->{Buffer}, 0, $blockSize) = ''; 71 $self->writeOneBlock(\$buff, $_[0]); 72 } 73 74 if ($flush && length $self->{Buffer} ) { 75 $self->writeOneBlock(\$self->{Buffer}, $_[0]); 76 $self->{Buffer} = ''; 77 } 78 79 return STATUS_OK; 80} 81 82sub writeOneBlock 83{ 84 my $self = shift; 85 my $buff = shift; 86 87 my $cmp ; 88 89 eval { $cmp = Compress::LZF::compress($$buff) }; 90 91 return STATUS_ERROR 92 if $@ || ! defined $cmp; 93 94 ${ $_[0] } .= SIGNATURE ; 95 96 #$self->{UnCompBytes} += length $self->{Buffer} ; 97 $self->{UnCompBytes} += length $$buff ; 98 99 # Remove the Compress::LZF header 100 substr($cmp, 0, c_lzf_header_length($cmp)) = ''; 101 102 #if (length($cmp) >= length($self->{Buffer})) 103 if (length($cmp) >= length $$buff) 104 { 105 ${ $_[0] } .= pack("Cn", 0, length($$buff)); 106 ${ $_[0] } .= $$buff; 107 $self->{CompBytes} += length $$buff; 108 } 109 else { 110 111 ${ $_[0] } .= pack("Cnn", 1, length($cmp), length($$buff)); 112 ${ $_[0] } .= $cmp; 113 $self->{CompBytes} += length $cmp; 114 } 115 #$self->{Buffer} = ''; 116 117 return STATUS_OK; 118} 119 120sub c_lzf_header_length 121{ 122 my $firstByte = unpack ("C", substr($_[0], 0, 1)); 123 124 return 1 if $firstByte == 0 ; 125 return 1 unless $firstByte & 0x80 ; 126 return 2 unless $firstByte & 0x20 ; 127 return 3 unless $firstByte & 0x10 ; 128 return 4 unless $firstByte & 0x08 ; 129 return 5 unless $firstByte & 0x04 ; 130 return 6 unless $firstByte & 0x02 ; 131 132 return undef; 133} 134 135sub reset 136{ 137 return STATUS_OK; 138} 139 140sub compressedBytes 141{ 142 my $self = shift ; 143 $self->{CompBytes}; 144} 145 146sub uncompressedBytes 147{ 148 my $self = shift ; 149 $self->{UnCompBytes}; 150} 151 1521; 153 154__END__ 155