local-lib5/lib/perl5/Git/PurePerl/Pack.pm

   1 package Git::PurePerl::Pack;
   2 use Moose;
   3 use MooseX::StrictConstructor;
   4 use MooseX::Types::Path::Class;
   5 use Compress::Raw::Zlib;
   6 use IO::File;
   7 use namespace::autoclean;
   8
   9 has 'filename' =>
  10     ( is => 'ro', isa => 'Path::Class::File', required => 1, coerce => 1 );
  11 has 'fh' => ( is => 'rw', isa => 'IO::File', required => 0 );
  12
  13 my @TYPES = ( 'none', 'commit', 'tree', 'blob', 'tag', '', 'ofs_delta',
  14     'ref_delta' );
  15 my $OBJ_NONE      = 0;
  16 my $OBJ_COMMIT    = 1;
  17 my $OBJ_TREE      = 2;
  18 my $OBJ_BLOB      = 3;
  19 my $OBJ_TAG       = 4;
  20 my $OBJ_OFS_DELTA = 6;
  21 my $OBJ_REF_DELTA = 7;
  22
  23 my $SHA1Size = 20;
  24
  25 sub BUILD {
  26     my $self = shift;
  27     my $fh = IO::File->new( $self->filename ) || confess($!);
  28     $fh->binmode();
  29     $self->fh($fh);
  30 }
  31
  32 sub all_sha1s {
  33     my ( $self, $want_sha1 ) = @_;
  34     return Data::Stream::Bulk::Array->new(
  35         array => [ $self->index->all_sha1s ] );
  36 }
  37
  38 sub unpack_object {
  39     my ( $self, $offset ) = @_;
  40     my $obj_offset = $offset;
  41     my $fh         = $self->fh;
  42
  43     $fh->seek( $offset, 0 ) || die "Error seeking in pack: $!";
  44     $fh->read( my $c, 1 ) || die "Error reading from pack: $!";
  45     $c = unpack( 'C', $c ) || die $!;
  46
  47     my $size        = ( $c & 0xf );
  48     my $type_number = ( $c >> 4 ) & 7;
  49     my $type = $TYPES[$type_number] || confess "invalid type $type_number";
  50
  51     my $shift = 4;
  52     $offset++;
  53
  54     while ( ( $c & 0x80 ) != 0 ) {
  55         $fh->read( $c, 1 ) || die $!;
  56         $c = unpack( 'C', $c ) || die $!;
  57         $size |= ( ( $c & 0x7f ) << $shift );
  58         $shift  += 7;
  59         $offset += 1;
  60     }
  61
  62     if ( $type eq 'ofs_delta' || $type eq 'ref_delta' ) {
  63         ( $type, $size, my $content )
  64             = $self->unpack_deltified( $type, $offset, $obj_offset, $size );
  65         return ( $type, $size, $content );
  66
  67     } elsif ( $type eq 'commit'
  68         || $type eq 'tree'
  69         || $type eq 'blob'
  70         || $type eq 'tag' )
  71     {
  72         my $content = $self->read_compressed( $offset, $size );
  73         return ( $type, $size, $content );
  74     } else {
  75         confess "invalid type $type";
  76     }
  77 }
  78
  79 sub read_compressed {
  80     my ( $self, $offset, $size ) = @_;
  81     my $fh = $self->fh;
  82
  83     $fh->seek( $offset, 0 ) || die $!;
  84     my ( $deflate, $status ) = Compress::Raw::Zlib::Inflate->new(
  85         -AppendOutput => 1,
  86         -ConsumeInput => 0
  87     );
  88
  89     my $out = "";
  90     while ( length($out) < $size ) {
  91         $fh->read( my $block, 4096 ) || die $!;
  92         my $status = $deflate->inflate( $block, $out );
  93     }
  94     confess length($out)." is not $size" unless length($out) == $size;
  95
  96     $fh->seek( $offset + $deflate->total_in, 0 ) || die $!;
  97     return $out;
  98 }
  99
 100 sub unpack_deltified {
 101     my ( $self, $type, $offset, $obj_offset, $size ) = @_;
 102     my $fh = $self->fh;
 103
 104     my $base;
 105
 106     $fh->seek( $offset, 0 ) || die $!;
 107     $fh->read( my $data, $SHA1Size ) || die $!;
 108     my $sha1 = unpack( 'H*', $data );
 109
 110     if ( $type eq 'ofs_delta' ) {
 111         my $i           = 0;
 112         my $c           = unpack( 'C', substr( $data, $i, 1 ) );
 113         my $base_offset = $c & 0x7f;
 114
 115         while ( ( $c & 0x80 ) != 0 ) {
 116             $c = unpack( 'C', substr( $data, ++$i, 1 ) );
 117             $base_offset++;
 118             $base_offset <<= 7;
 119             $base_offset |= $c & 0x7f;
 120         }
 121         $base_offset = $obj_offset - $base_offset;
 122         $offset += $i + 1;
 123
 124         ( $type, undef, $base ) = $self->unpack_object($base_offset);
 125     } else {
 126         ( $type, undef, $base ) = $self->get_object($sha1);
 127         $offset += $SHA1Size;
 128
 129     }
 130
 131     my $delta = $self->read_compressed( $offset, $size );
 132     my $new = $self->patch_delta( $base, $delta );
 133
 134     return ( $type, length($new), $new );
 135 }
 136
 137 sub patch_delta {
 138     my ( $self, $base, $delta ) = @_;
 139
 140     my ( $src_size, $pos ) = $self->patch_delta_header_size( $delta, 0 );
 141     if ( $src_size != length($base) ) {
 142         confess "invalid delta data";
 143     }
 144
 145     ( my $dest_size, $pos ) = $self->patch_delta_header_size( $delta, $pos );
 146     my $dest = "";
 147
 148     while ( $pos < length($delta) ) {
 149         my $c = substr( $delta, $pos, 1 );
 150         $c = unpack( 'C', $c );
 151         $pos++;
 152         if ( ( $c & 0x80 ) != 0 ) {
 153
 154             my $cp_off  = 0;
 155             my $cp_size = 0;
 156             $cp_off = unpack( 'C', substr( $delta, $pos++, 1 ) )
 157                 if ( $c & 0x01 ) != 0;
 158             $cp_off |= unpack( 'C', substr( $delta, $pos++, 1 ) ) << 8
 159                 if ( $c & 0x02 ) != 0;
 160             $cp_off |= unpack( 'C', substr( $delta, $pos++, 1 ) ) << 16
 161                 if ( $c & 0x04 ) != 0;
 162             $cp_off |= unpack( 'C', substr( $delta, $pos++, 1 ) ) << 24
 163                 if ( $c & 0x08 ) != 0;
 164             $cp_size = unpack( 'C', substr( $delta, $pos++, 1 ) )
 165                 if ( $c & 0x10 ) != 0;
 166             $cp_size |= unpack( 'C', substr( $delta, $pos++, 1 ) ) << 8
 167                 if ( $c & 0x20 ) != 0;
 168             $cp_size |= unpack( 'C', substr( $delta, $pos++, 1 ) ) << 16
 169                 if ( $c & 0x40 ) != 0;
 170             $cp_size = 0x10000 if $cp_size == 0;
 171
 172             $dest .= substr( $base, $cp_off, $cp_size );
 173         } elsif ( $c != 0 ) {
 174             $dest .= substr( $delta, $pos, $c );
 175             $pos += $c;
 176         } else {
 177             confess 'invalid delta data';
 178         }
 179     }
 180
 181     if ( length($dest) != $dest_size ) {
 182         confess 'invalid delta data';
 183     }
 184     return $dest;
 185 }
 186
 187 sub patch_delta_header_size {
 188     my ( $self, $delta, $pos ) = @_;
 189
 190     my $size  = 0;
 191     my $shift = 0;
 192     while (1) {
 193
 194         my $c = substr( $delta, $pos, 1 );
 195         unless ( defined $c ) {
 196             confess 'invalid delta header';
 197         }
 198         $c = unpack( 'C', $c );
 199
 200         $pos++;
 201         $size |= ( $c & 0x7f ) << $shift;
 202         $shift += 7;
 203         last if ( $c & 0x80 ) == 0;
 204     }
 205     return ( $size, $pos );
 206 }
 207
 208 __PACKAGE__->meta->make_immutable;
 209