Changeset 3413 for lang/perl/Archive-Lha

Timestamp:

12/21/07 18:32:34 (12 months ago)

Author:

charsbar

Message:

lang/perl/Archive-Lha: xs -> trunk

Location:

lang/perl/Archive-Lha/trunk

Files:

• Changes (modified) (1 diff)
• Lha.h (added)
• Lha.xs (added)
• MANIFEST (modified) (2 diffs)
• Makefile.PL (modified) (1 diff)
• lib/Archive/Lha.pm (modified) (2 diffs)
• lib/Archive/Lha/Bitstream.pm (deleted)
• lib/Archive/Lha/CRC.pm (deleted)
• lib/Archive/Lha/Decode/Base.pm (modified) (3 diffs)
• lib/Archive/Lha/Decode/LH0.pm (modified) (3 diffs)
• lib/Archive/Lha/Header/Level0.pm (modified) (1 diff)
• lib/Archive/Lha/Queue.pm (deleted)
• lib/Archive/Lha/Table.pm (deleted)
• lib/Archive/Lha/TableSet.pm (deleted)
• lib/Archive/Lha/Tree.pm (deleted)
• ppport.h (added)
• t/10_bitstream.t (deleted)
• t/20_decode.t (modified) (1 diff)

lang/perl/Archive-Lha/trunk/Changes

@@ -1 +1 @@
 Revision history for Archive-Lha
 
-0.01 2007/12/18
-  - initial CodeRepos release
+0.01 2007/12/10
+  - initial release

lang/perl/Archive-Lha/trunk/MANIFEST

@@ -1 +1 @@
 Changes
+Lha.h
+Lha.xs
 lib/Archive/Lha.pm
-lib/Archive/Lha/Bitstream.pm
 lib/Archive/Lha/Constants.pm
-lib/Archive/Lha/CRC.pm
 lib/Archive/Lha/Debug.pm
 lib/Archive/Lha/Decode.pm
@@ -16 +16 @@
 lib/Archive/Lha/Header/Level2.pm
 lib/Archive/Lha/Header/Utils.pm
-lib/Archive/Lha/Queue.pm
 lib/Archive/Lha/Stream.pm
 lib/Archive/Lha/Stream/File.pm
 lib/Archive/Lha/Stream/Hex.pm
 lib/Archive/Lha/Stream/String.pm
-lib/Archive/Lha/Table.pm
-lib/Archive/Lha/TableSet.pm
-lib/Archive/Lha/Tree.pm
 Makefile.PL
 MANIFEST                        This list of files
+ppport.h
 README
 t/00_load.t

lang/perl/Archive-Lha/trunk/Makefile.PL

@@ -16 +16 @@
     'List::Util'          => 0,
     'Log::Dispatch'       => 0,
+    'Test::UseAllModules' => 0,
     'Test::More'          => 0.47,
-    'Test::UseAllModules' => 0,
     'Time::Piece'         => 0,
   },

lang/perl/Archive-Lha/trunk/lib/Archive/Lha.pm

@@ -5 +5 @@
 
 our $VERSION = '0.01';
+
+require XSLoader;
+XSLoader::load('Archive::Lha', $VERSION);
 
 1;
@@ -20 +23 @@
 =head1 ACKNOWLEDGMENT
 
-The decoding algorithm used here is based on the one of LHa for UNIX version 1.14i-ac20050924p1. Though largely modified, you may find that some parts of this perl port are still similar, or almost literal translations of the original, especially where I've not fully understood yet.
+The decoding (XS) part is based on the C sources of LHa for UNIX version 1.14i-ac20050924p1. Though I modified a lot not only to XSify but aslo to make it (comparatively) thread-safe and easy to understand, I'm not fair if I omit the names of the original authors/contributors. If you find this port valuable, kudos be to them. If you find something wrong, most probably that'd be my fault.
 
-Well, as a whole, they are different, in terms of file layout, object-orientedness and thread safety, not to mention the language used.
+According to the original C sources, those parts of LHa for UNIX version 1.14i-ac20050924p1 are copyrighted by Nobutaka Watazaki (1993-1995), Tsugio Okamoto (1996-2000?), and Koji Arai (2002-). I'm grateful to them, and also to all the people who involved in the development of LHa and its descendants/relatives including Masaru Oki, Yoichi Tagawa, Haruhiko Okumura, Haruyasu Yoshizaki, Kazuhiko Miki and others.
 
-However, I'm not fair if I omit the names of the original authors/contributors. If you find this port valuable, kudos be to them. If you find something wrong, most probably that'd be my fault.
-
-According to the C sources, those parts of LHa for UNIX version 1.14i-ac20050924p1 are copyrighted by Nobutaka Watazaki (1993-1995), Tsugio Okamoto (1996-2000?), and Koji Arai (2002-). I'm grateful to them, and also to all the people who involved in the development of LHa and its descendants/relatives including Masaru Oki, Yoichi Tagawa, Haruhiko Okumura, Haruyasu Yoshizaki, Kazuhiko Miki and others.
+Other parts including headers file and perl sources are mine or of contributors to this perl port. See appropriate POD sections for details.
 
 =head1 SEE ALSO

lang/perl/Archive-Lha/trunk/lib/Archive/Lha/Decode/Base.pm

@@ -6 +6 @@
 use List::Util qw( min );
 use Archive::Lha::Constants;
-use Archive::Lha::Bitstream;
-use Archive::Lha::Queue;
-use Archive::Lha::TableSet;
-use Archive::Lha::Tree;
+use base qw( Archive::Lha );
 
 sub import {
@@ -18 +15 @@
     no strict 'refs'; no warnings 'redefine';
 
-    my $dicbit = $options{dicbit};
+    my $dicbit = $options{dicbit} || 13;
 
     # these should be configurable, probably?
@@ -68 +65 @@
   my $header = $options{header};
 
-  my $bitstream = Archive::Lha::Bitstream->new(
-    callback => $options{read},
-    length   => $header->{packed_size},
-  );
-
-  my $pt_table = Archive::Lha::TableSet->new(
-    bit => $class->PT_TABLE_BIT, length => $class->NPT
-  );
-  my $c_table = Archive::Lha::TableSet->new(
-    bit => $class->C_TABLE_BIT, length => $class->NC
-  );
-  my $tree = Archive::Lha::Tree->new( size => 2 * $class->NC - 1 );
-
   my $self  = bless {
     blocksize => 0,
-    pt        => $pt_table,
-    c         => $c_table,
-    tree      => $tree,
-    bit       => $bitstream,
+    read      => $options{read},
     write     => $options{write},
+    packed    => $header->{packed_size},
     original  => $header->{original_size},
-    crc16     => $header->{crc16},
+    crc16     => $header->{crc16} || 0,
+    DICSIZE   => $class->DICSIZE,
+    MAXMATCH  => $class->MAXMATCH,
+    THRESHOLD => $class->THRESHOLD,
+    NPT       => $class->NPT,
+    NP        => $class->NP,
+    NT        => $class->NT,
+    NC        => $class->NC,
+    PBIT      => $class->PBIT,
+    TBIT      => $class->TBIT,
+    CBIT      => $class->CBIT,
+    PT_TABLE_BIT  => $class->PT_TABLE_BIT,
+    PT_TABLE_SIZE => $class->PT_TABLE_SIZE,
+    C_TABLE_BIT   => $class->C_TABLE_BIT,
+    C_TABLE_SIZE  => $class->C_TABLE_SIZE,
   }, $class;
 
   $self;
-}
-
-sub decode {  # modified from slide.c:decode
-  my $self = shift;
-
-  my $queue = Archive::Lha::Queue->new(
-    size     => $self->DICSIZE,
-    callback => $self->{write},
-  );
-  my $adjust   = ( 1 << UCHAR_BIT ) - $self->THRESHOLD;
-  my $total    = 0;
-  my $original = $self->{original};
-
-  while ( $total < $original ) {
-    my $char = $self->_decode_c;
-    if ( $char <= UCHAR_MAX ) {
-      $queue->set( $char );
-      $total++;
-    }
-    else {
-      my $length = $char - $adjust;
-      my $offset = $self->_decode_p + 1;
-
-      $queue->copy( $offset, $length );
-      $total += $length;
-    }
-  }
-  $queue->output;
-  croak "CRC mismatch" if $queue->crc16 != $self->{crc16};
-}
-
-sub _decode_c {  # modified from huf.c:decode_c
-  my $self = shift;
-
-  if ( $self->{blocksize} == 0 ) {
-    $self->{blocksize} = $self->bit->read( USHORT_BIT );
-    $self->_read_pt( $self->NT, $self->TBIT, 3 );
-    $self->_read_c;
-    $self->_read_pt( $self->NP, $self->PBIT, -1 );
-  }
-  $self->{blocksize}--;
-
-  my $char = $self->c->value( $self->bit->peek( $self->c->bit ) );
-
-  if ( $char < $self->c->length_size ) {
-    $self->bit->cut( $self->c->length( $char ) );
-  }
-  else {
-    $self->bit->cut( $self->c->bit );
-    $char = $self->tree->_follow(
-      from  => $char,
-      bits  => $self->bit->peek( USHORT_BIT ),
-      limit => $self->c->length_size,
-    );
-    $self->bit->cut( $self->c->length( $char ) - $self->c->bit );
-  }
-  return $char;
-}
-
-sub _decode_p {  # modified from huf.c:decode_p
-  my $self = shift;
-
-  my $pt = $self->pt->value( $self->bit->peek( $self->pt->bit ) );
-
-  if ( $pt < $self->NP ) {
-    $self->bit->cut( $self->pt->length( $pt ) );
-  }
-  else {
-    $self->bit->cut( $self->pt->bit );
-    $pt = $self->tree->_follow(
-      from  => $pt,
-      bits  => $self->bit->peek( USHORT_BIT ),
-      limit => $self->NP,
-    );
-    $self->bit->cut( $self->pt->length( $pt ) - $self->pt->bit );
-  }
-  if ( $pt ) {
-    $pt = ( 1 << ( $pt - 1 ) ) + $self->bit->read( $pt - 1 );
-  }
-  return $pt;
-}
-
-sub _read_pt {  # modified from huf.c:read_pt_len
-  my ($self, $nn, $nbit, $threshold) = @_;
-
-  my $n = $self->bit->read( $nbit );
-  if ( $n == 0 ) {
-    $self->pt->fill_value( with => $self->bit->read( $nbit ) );
-    $self->pt->fill_length( with => 0, to => $nn );
-  }
-  else {
-    my $i = 0;
-    while ( $i < min( $n, $self->pt->length_size ) ) {
-      my $c = $self->bit->peek(3);
-      if ( $c == 7 ) {
-        my $mask = _ushort( 1 << ( ( USHORT_BIT - 1 ) - 3 ) );
-        while ( $self->bit->check( $mask ) ) {
-          $mask >>= 1;
-          $c++;
-        }
-        $self->bit->cut( $c - 3 );
-      }
-      else {
-        $self->bit->cut(3);
-      }
-
-      $self->pt->length( $i++ => $c );
-      if ( $i == $threshold ) {
-        $c = $self->bit->read(2);
-        while( --$c >= 0 && $i < $self->pt->length_size ) {
-          $self->pt->length( $i++ => 0 );
-        }
-      }
-    }
-    $self->pt->fill_length( with => 0, from => $i, to => $nn );
-    $self->_make_table( $self->pt, $nn );
-  }
-}
-
-sub _read_c {  # modified from huf.c:read_c_len
-  my $self = shift;
-
-  my $n = $self->bit->read( $self->CBIT );
-  if ( $n == 0 ) {
-    $self->c->fill_value( with => $self->bit->read( $self->CBIT ) );
-    $self->c->fill_length( with => 0 );
-  }
-  else {
-    my $i = 0;
-    while ( $i < min( $n, $self->c->length_size ) ) {
-      my $c = $self->pt->value( $self->bit->peek( $self->pt->bit ) );
-      if ( $c >= $self->NT ) {
-        $c = $self->tree->_follow(
-          from       => $c,
-          bits       => $self->bit->peek( USHORT_BIT ),
-          mask_shift => $self->pt->bit,
-          limit      => $self->NT,
-        );
-      }
-      $self->bit->cut( $self->pt->length( $c ) );
-      if ( $c <= 2 ) {
-        if ( $c == 0 ) {
-          $c = 1;
-        }
-        elsif ( $c == 1 ) {
-          $c = $self->bit->read(4) + 3;
-        }
-        else {
-          $c = $self->bit->read( $self->CBIT ) + 20;
-        }
-        while ( --$c >= 0 ) {
-          $self->c->length( $i++ => 0 );
-        }
-      }
-      else {
-        $self->c->length( $i++ => $c - 2 );
-      }
-    }
-    $self->c->fill_length( with => 0, from => $i );
-    $self->_make_table( $self->c, $self->c->length_size );
-  }
-}
-
-sub _make_table {  # modified from maketbl.c:make_table
-  my ($self, $table, $nchar) = @_;
-
-  my (@count, @weight, @start);
-
-  for( my $i = 1; $i <= USHORT_BIT; $i++ ) {
-    $count[$i]  = 0;
-    $weight[$i] = _ushort( 1 << ( USHORT_BIT - $i ) );
-  }
-
-  for( my $i = 0; $i < $nchar; $i++ ) {
-    if ( $table->length( $i ) > USHORT_BIT ) {
-      croak "Table is broken: ".$table->stringify;
-    }
-    $count[ $table->length( $i ) ]++;
-  }
-
-  my $total = 0;
-  for( my $i = 1; $i <= USHORT_BIT; $i++ ) {
-    $start[$i] = $total;
-    $total += $weight[$i] * $count[$i];
-  }
-
-  if ( $total & USHORT_MAX ) {
-    croak "Table is broken: ".$table->stringify;
-  }
-
-  my $m = USHORT_BIT - $table->bit;
-
-  for( my $i = 1; $i <= $table->bit; $i++ ) {
-    $start[$i]  = _ushort( $start[$i] >> $m );
-    $weight[$i] = _ushort( $weight[$i] >> $m );
-  }
-
-  my $j = $start[ $table->bit + 1 ] >> $m;
-  my $k = min( 1 << $table->bit, $table->size );
-
-  if ( $j ) {
-    $table->fill_value( with => 0, from => $j, to => $k );
-  }
-
-  my $avail = $nchar;
-  for( my $j = 0; $j < $nchar; $j++ ) {
-    my $k = $table->length( $j ) or next;
-    my $l = $start[$k] + $weight[$k];
-
-    if ( $k <= $table->bit ) {
-      $l = min( $l, $table->size );
-      $table->fill_value( with => $j, from => $start[$k], to => $l );
-    }
-    else {
-      my $i = $start[$k];
-      if ( ( $i >> $m ) > $table->size ) {
-        croak "Table is broken: ".$table->stringify;
-      }
-
-      my $p_addr = $i >> $m;
-      my $p_type = 'table';
-      my $p      = $table->value( $p_addr );
-      my $n = $k - $table->bit;
-      $i = _ushort( $i << $table->bit );
-
-      while ( --$n >= 0 ) {
-        if ( $p == 0 ) {
-          $self->tree->right( $avail => 0 );
-          $self->tree->left(  $avail => 0 );
-          $p = $avail++;
-          if ( $p_type eq 'table' ) {
-            $table->value( $p_addr => $p );
-          }
-          elsif ( $p_type eq 'right' ) {
-            $self->tree->right( $p_addr => $p );
-          }
-          elsif ( $p_type eq 'left' ) {
-            $self->tree->left( $p_addr => $p );
-          }
-        }
-        if ( $i >= USHORT_CENTER ) {
-          $p_type = 'right';
-          $p_addr = $p;
-          $p = $self->tree->right( $p_addr );
-        }
-        else {
-          $p_type = 'left';
-          $p_addr = $p;
-          $p = $self->tree->left( $p_addr );
-        }
-        $i = _ushort( $i << 1 );
-      }
-      if ( $p_type eq 'table' ) {
-        $table->value( $p_addr => $j );
-      }
-      elsif ( $p_type eq 'right' ) {
-        $self->tree->right( $p_addr => $j );
-      }
-      elsif ( $p_type eq 'left' ) {
-        $self->tree->left( $p_addr => $j );
-      }
-    }
-    $start[$k] = $l;
-  }
 }
 

lang/perl/Archive-Lha/trunk/lib/Archive/Lha/Decode/LH0.pm

@@ -4 +4 @@
 use warnings;
 use Carp;
+use bytes;
 use Archive::Lha::Constants;
-use Archive::Lha::CRC;
+use Archive::Lha;
 
 sub new {
@@ -26 +27 @@
   my $self = shift;
 
+  my $crc   = 0;
   my $total = 0;
   my $size  = $self->{size};
-  my $crc   = Archive::Lha::CRC->new;
-
   while ( $total < $size ) {
     my $left = $size - $total;
@@ -35 +35 @@
     my $str = $self->{read}->( $length );
     $self->{write}->( $str );
-    $crc->add( $str );
+    $crc = Archive::Lha::crc16( $crc, $str, length($str) );
     $total += $length;
   }
-  croak "CRC mismatch" if $crc->value != $self->{crc16};
+  croak "CRC mismatch" if $crc != $self->{crc16};
+  return $crc;
 }
 

lang/perl/Archive-Lha/trunk/lib/Archive/Lha/Header/Level0.pm

@@ -22 +22 @@
   my $checksum  = ord( $bits[1] );
   my $checksum1 = ( sum( map { ord } @bits[2..$#bits] ) ) & CHAR_MAX;
-  croak "Header is broken: checksum $checksum/$checksum1"
+  croak "Header is broken: start:$start checksum $checksum/$checksum1"
     unless $checksum == $checksum1;
 

lang/perl/Archive-Lha/trunk/t/20_decode.t

@@ -27 +27 @@
       write  => sub { $decoded .= join '', @_ },
     );
-    $decoder->decode;
+    my $crc = $decoder->decode;
+    if ( $header->{crc16} ) {
+      ok $crc == $header->{crc16}, "CRC: $crc / $$header{crc16}";
+    }
 
     if ( defined $value ) {