File Coverage

blib/lib/Data/BitStream/XS.pm

Criterion	Covered	Total	%
statement	141	146	96.5
branch	77	106	72.6
condition	6	15	40.0
subroutine	29	29	100.0
pod	21	21	100.0
total	274	317	86.4

package Data::BitStream::XS;
# Tested with Perl 5.6.2 through 5.16.0
# Tested on 32-bit big-endian and 64-bit little endian
use strict;
use warnings;
use Carp qw/croak confess/;

BEGIN {
  $Data::BitStream::XS::AUTHORITY = 'cpan:DANAJ';
  $Data::BitStream::XS::VERSION = '0.08';
}

# parent is cleaner, and in the Perl 5.10.1 / 5.12.0 core, but not earlier.
# use parent qw( Exporter );
use base qw( Exporter );
our @EXPORT_OK = qw(
                     code_is_supported code_is_universal
                     prime_count nth_prime is_prime
                   );

BEGIN {
  eval {
    require XSLoader;
    XSLoader::load(__PACKAGE__, $Data::BitStream::XS::VERSION);
    prime_init(0);
    1;
  } or do {
    # We could insert a Pure Perl implementation here.
    croak "XS Code not available: $@";
  }
}

################################################################################
#
#                               SUPPORT FUNCTIONS
#
################################################################################

sub maxbits {    # Works as a class method or object method
  my $self = shift;
  _maxbits();
}
sub erase_for_write {
  my $self = shift;
  $self->erase;
  $self->write_open if !$self->writing;
}
sub rewind_for_read {
  my $self = shift;
  $self->write_close if $self->writing;
  $self->rewind;
}

sub to_string {
  my $self = shift;
  $self->rewind_for_read;
  $self->read_string($self->len);
}

sub from_string {
  my $self = shift;
  $self->erase_for_write;
  $self->put_string($_[0]);
  $self->rewind_for_read;
}

# TODO:
sub to_store {
  shift->to_raw(@_);
}
sub from_store {
  shift->from_raw(@_);
}

# Takes a stream and inserts its contents into the current stream.
# Non-destructive to both streams.
sub put_stream {
  my $self = shift;
  my $source = shift;
  return 0 unless defined $source;

  if (ref $source eq __PACKAGE__) {
    # optimized method for us.
    $self->_xput_stream($source);
  } else {
    return 0 unless $source->can('to_string');
    $self->put_string($source->to_string);
    # WordVec is still slow with this (it needs a fast put_raw)
    # $self->put_raw($source->to_raw, $source->len);
  }
  1;
}

################################################################################
#
#                                   CODES
#
################################################################################

sub get_golomb {
  my $self = shift;
  return    (ref $_[0] eq 'CODE')
         ?  $self->_xget_golomb_sub(@_)
         :  $self->_xget_golomb_sub(undef, @_);
}
sub put_golomb {
  my $self = shift;
  return    (ref $_[0] eq 'CODE')
         ?  $self->_xput_golomb_sub(@_)
         :  $self->_xput_golomb_sub(undef, @_);
}

sub get_rice {
  my $self = shift;
  return    (ref $_[0] eq 'CODE')
         ?  $self->_xget_rice_sub(@_)
         :  $self->_xget_rice_sub(undef, @_);
}
sub put_rice {
  my $self = shift;
  return    (ref $_[0] eq 'CODE')
         ?  $self->_xput_rice_sub(@_)
         :  $self->_xput_rice_sub(undef, @_);
}

sub get_arice {
  my $self = shift;
  return    (ref $_[0] eq 'CODE')
         ?  $self->_xget_arice_sub(@_)
         :  $self->_xget_arice_sub(undef, @_);
}
sub put_arice {
  my $self = shift;
  return    (ref $_[0] eq 'CODE')
         ?  $self->_xput_arice_sub(@_)
         :  $self->_xput_arice_sub(undef, @_);
}


# Map Start-Step-Stop codes to Start/Stop codes.
# See Data::BitStream::Code::StartStop for more detail

sub _map_sss_to_ss {
  my($start, $step, $stop, $maxstop) = @_;
  $stop = $maxstop if (!defined $stop) || ($stop > $maxstop);
  croak "invalid parameters" unless ($start >= 0) && ($start <= $maxstop);
  croak "invalid parameters" unless $step >= 0;
  croak "invalid parameters" unless $stop >= $start;
  return if $start == $stop;  # Binword
  return if $step == 0;       # Rice

  my @pmap = ($start);
  my $blen = $start;
  while ($blen < $stop) {
    $blen += $step;
    $blen = $stop if $blen > $stop;
    push @pmap, $step;
  }
  @pmap;
}

sub put_startstepstop {
  my $self = shift;
  my $p = shift;
  croak "invalid parameters" unless (ref $p eq 'ARRAY') && scalar @$p == 3;

  my($start, $step, $stop) = @$p;
  return $self->put_binword($start, @_) if $start == $stop;
  return $self->put_rice($start, @_)    if $step == 0;
  my @pmap = _map_sss_to_ss($start, $step, $stop, _maxbits());
  confess "unexpected death" unless scalar @pmap >= 2;
  $self->put_startstop( [@pmap], @_ );
}
sub get_startstepstop {
  my $self = shift;
  my $p = shift;
  croak "invalid parameters" unless (ref $p eq 'ARRAY') && scalar @$p == 3;

  my($start, $step, $stop) = @$p;
  return $self->get_binword($start, @_) if $start == $stop;
  return $self->get_rice($start, @_)    if $step == 0;
  my @pmap = _map_sss_to_ss($start, $step, $stop, _maxbits());
  confess "unexpected death" unless scalar @pmap >= 2;
  return $self->get_startstop( [@pmap], @_ );
}

################################################################################
#
#                               TEXT METHODS
#
################################################################################

# The Data::BitStream class does this all dynamically and gets its info from
# all Data::BitStream::Code::* files that have been loaded as roles.
# We're going to do it all statically, which isn't nearly as cool.

my @_initinfo = (
    { package   => __PACKAGE__,
      name      => 'Unary',
      universal => 0,
      params    => 0,
      encodesub => sub {shift->put_unary(@_)},
      decodesub => sub {shift->get_unary(@_)}, },
    { package   => __PACKAGE__,
      name      => 'Unary1',
      universal => 0,
      params    => 0,
      encodesub => sub {shift->put_unary1(@_)},
      decodesub => sub {shift->get_unary1(@_)}, },
    { package   => __PACKAGE__,
      name      => 'BinWord',
      universal => 0,  # it is universal if and only if param == maxbits
      params    => 1,
      encodesub => sub {shift->put_binword(@_)},
      decodesub => sub {shift->get_binword(@_)}, },
    { package   => __PACKAGE__,
      name      => 'Gamma',
      universal => 1,
      params    => 0,
      encodesub => sub {shift->put_gamma(@_)},
      decodesub => sub {shift->get_gamma(@_)}, },
    { package   => __PACKAGE__,
      name      => 'Delta',
      universal => 1,
      params    => 0,
      encodesub => sub {shift->put_delta(@_)},
      decodesub => sub {shift->get_delta(@_)}, },
    { package   => __PACKAGE__,
      name      => 'Omega',
      universal => 1,
      params    => 0,
      encodesub => sub {shift->put_omega(@_)},
      decodesub => sub {shift->get_omega(@_)}, },
    { package   => __PACKAGE__,
      name      => 'EvenRodeh',
      universal => 1,
      params    => 0,
      encodesub => sub {shift->put_evenrodeh(@_)},
      decodesub => sub {shift->get_evenrodeh(@_)}, },
    { package   => __PACKAGE__,
      name      => 'Levenstein',
      aliases   => ['Levenshtein'],
      universal => 1,
      params    => 0,
      encodesub => sub {shift->put_levenstein(@_)},
      decodesub => sub {shift->get_levenstein(@_)}, },
    { package   => __PACKAGE__,
      name      => 'GoldbachG1',
      universal => 1,
      params    => 0,
      encodesub => sub {shift->put_goldbach_g1(@_)},
      decodesub => sub {shift->get_goldbach_g1(@_)}, },
    { package   => __PACKAGE__,
      name      => 'GoldbachG2',
      universal => 1,
      params    => 0,
      encodesub => sub {shift->put_goldbach_g2(@_)},
      decodesub => sub {shift->get_goldbach_g2(@_)}, },
    { package   => __PACKAGE__,
      name      => 'Fibonacci',
      universal => 1,
      params    => 0,
      encodesub => sub {shift->put_fib(@_)},
      decodesub => sub {shift->get_fib(@_)}, },
    { package   => __PACKAGE__,
      name      => 'FibGen',
      universal => 1,
      params    => 1,
      encodesub => sub {shift->put_fibgen(@_)},
      decodesub => sub {shift->get_fibgen(@_)}, },
    { package   => __PACKAGE__,
      name      => 'Comma',
      universal => 1,
      params    => 1,
      encodesub => sub {shift->put_comma(@_)},
      decodesub => sub {shift->get_comma(@_)}, },
    { package   => __PACKAGE__,
      name      => 'BlockTaboo',
      universal => 1,
      params    => 1,
      encodesub => sub {shift->put_blocktaboo(@_)},
      decodesub => sub {shift->get_blocktaboo(@_)}, },
    { package   => __PACKAGE__,
      name      => 'Golomb',
      universal => 0,
      params    => 1,
      encodesub => sub {shift->put_golomb(@_)},
      decodesub => sub {shift->get_golomb(@_)}, },
    { package   => __PACKAGE__,
      name      => 'Rice',
      universal => 0,
      params    => 1,
      encodesub => sub {shift->put_rice(@_)},
      decodesub => sub {shift->get_rice(@_)}, },
    { package   => __PACKAGE__,
      name      => 'ExpGolomb',
      universal => 1,
      params    => 1,
      encodesub => sub {shift->put_expgolomb(@_)},
      decodesub => sub {shift->get_expgolomb(@_)}, },
    { package   => __PACKAGE__,
      name      => 'GammaGolomb',
      universal => 1,
      params    => 1,
      encodesub => sub {shift->put_gammagolomb(@_)},
      decodesub => sub {shift->get_gammagolomb(@_)}, },
    { package   => __PACKAGE__,
      name      => 'Baer',
      universal => 1,
      params    => 1,
      encodesub => sub {shift->put_baer(@_)},
      decodesub => sub {shift->get_baer(@_)}, },
    { package   => __PACKAGE__,
      name      => 'BoldiVigna',
      universal => 1,
      params    => 1,
      encodesub => sub {shift->put_boldivigna(@_)},
      decodesub => sub {shift->get_boldivigna(@_)}, },
    { package   => __PACKAGE__,
      name      => 'ARice',
      universal => 1,
      params    => 1,
      encodesub => sub {shift->put_arice(@_)},
      decodesub => sub {shift->get_arice(@_)}, },
    { package   => __PACKAGE__,
      name      => 'StartStop',
      universal => 1,
      params    => 1,
      encodesub => sub {shift->put_startstop([split('-',shift)], @_)},
      decodesub => sub {shift->get_startstop([split('-',shift)], @_)}, },
    { package   => __PACKAGE__,
      name      => 'StartStepStop',
      universal => 1,
      params    => 1,
      encodesub => sub {shift->put_startstepstop([split('-',shift)], @_)},
      decodesub => sub {shift->get_startstepstop([split('-',shift)], @_)}, },
   );
my %codeinfo;

sub add_code {
  my $rinfo = shift;
  croak "add_code needs a hash ref" unless defined $rinfo && ref $rinfo eq 'HASH';
  foreach my $p (qw(package name universal params encodesub decodesub)) {
    croak "invalid registration: missing $p" unless defined $$rinfo{$p};
  }
  my $name = lc $$rinfo{'name'};
  if (defined $codeinfo{$name}) {
    return 1 if $codeinfo{$name}{'package'} eq $$rinfo{'package'};
    croak "module $$rinfo{'package'} trying to reuse code name '$name' already in use by $codeinfo{$name}{'package'}";
  }
  $codeinfo{$name} = $rinfo;
  1;
};

my $init_codeinfo_sub = sub {
  if (scalar @_initinfo > 0) {
    foreach my $rinfo (@_initinfo) {
      add_code($rinfo);
    }
    @_initinfo = ();
  }
};

sub _find_code {
  my $code = lc shift;

  $init_codeinfo_sub->() if scalar @_initinfo > 0;
  return $codeinfo{$code};
};

sub code_is_supported {
  my $code = lc shift;
  my $param;  $param = $1 if $code =~ s/\((.+)\)$//;
  return defined _find_code($code);
}

sub code_is_universal {
  my $code = lc shift;
  my $param;  $param = $1 if $code =~ s/\((.+)\)$//;
  my $inforef = _find_code($code);
  return unless defined $inforef;  # Unknown code.
  return $inforef->{'universal'};
}

# It would be nice to speed these up, but doing so isn't trivial.  I've added
# a couple shortcuts for Unary and Gamma, but it isn't a generic solution.
sub code_put {
  my $self = shift;
  my $code = lc shift;
  if    ($code eq 'unary' ) { return $self->put_unary(@_); }
  elsif ($code eq 'gamma' ) { return $self->put_gamma(@_); }
  my $param;  $param = $1 if $code =~ s/\((.+)\)$//;
  my $inforef = $codeinfo{$code};
  $inforef = _find_code($code) unless defined $inforef;
  croak "Unknown code $code" unless defined $inforef;
  my $sub = $inforef->{'encodesub'};
  croak "No encoding sub for code $code!" unless defined $sub;
  if ($inforef->{'params'}) {
    croak "Code $code needs a parameter" unless defined $param;
    return $sub->($self, $param, @_);
  } else {
    croak "Code $code does not have parameters" if defined $param;
    return $sub->($self, @_);
  }
}

sub code_get {
  my $self = shift;
  my $code = lc shift;
  if    ($code eq 'unary' ) { return $self->get_unary(@_); }
  elsif ($code eq 'gamma' ) { return $self->get_gamma(@_); }
  my $param;  $param = $1 if $code =~ s/\((.+)\)$//;
  my $inforef = $codeinfo{$code};
  $inforef = _find_code($code) unless defined $inforef;
  croak "Unknown code $code" unless defined $inforef;
  my $sub = $inforef->{'decodesub'};
  croak "No decoding sub for code $code!" unless defined $sub;
  if ($inforef->{'params'}) {
    croak "Code $code needs a parameter" unless defined $param;
    return $sub->($self, $param, @_);
  } else {
    croak "Code $code does not have parameters" if defined $param;
    return $sub->($self, @_);
  }
}


################################################################################
#
#                               CLASS METHODS
#
################################################################################

1;

__END__