diff --git a/lib/Data/BitStream/Base.pm b/lib/Data/BitStream/Base.pm index 7abe20f..39b7dd1 100644 --- a/lib/Data/BitStream/Base.pm +++ b/lib/Data/BitStream/Base.pm @@ -2,6 +2,7 @@ package Data::BitStream::Base; use strict; use warnings; use Carp; +our @CARP_NOT; BEGIN { $Data::BitStream::Base::AUTHORITY = 'cpan:DANAJ'; $Data::BitStream::Base::VERSION = '0.08'; @@ -316,6 +317,7 @@ sub code_pos_is_set { sub error_off_stream { my $self = shift; my $skipping = shift; + local @CARP_NOT = (@CARP_NOT, ref($self)); # Give the skip error only if we were not reading a code. if ( (defined $skipping) && (@{$self->_code_pos_array} == 0) ) { @@ -329,6 +331,7 @@ sub error_off_stream { sub error_stream_mode { my $self = shift; my $type = shift; + local @CARP_NOT = (@CARP_NOT, ref($self)); my $codename = $self->_code_restore_pos(); $codename = " ($codename)" if $codename ne ''; @@ -351,6 +354,7 @@ sub error_code { my $self = shift; my $type = shift; my $text = shift; + local @CARP_NOT = (@CARP_NOT, ref($self)); if ($type eq 'zeroval') { # Implied text $type = 'value'; $text = 'value must be >= 0'; diff --git a/lib/Data/BitStream/WordVec.pm b/lib/Data/BitStream/WordVec.pm index ef1f6fd..d80ffc9 100644 --- a/lib/Data/BitStream/WordVec.pm +++ b/lib/Data/BitStream/WordVec.pm @@ -396,7 +396,19 @@ sub to_raw { my $self = shift; $self->write_close; my $rvec = $self->_vecref; - return $$rvec; + my $byte_count = int(($self->len + 7) / 8); + # $$rvec may have more or fewer zeroes than is appropriate based on + # optimizations + return $$rvec if length($$rvec) == $byte_count; + if (length($$rvec) > $byte_count) { + # return only the first $byte_count bytes + return substr($$rvec, 0, $byte_count); + } else { + # a more complex case: there are some virtual '0' bits at the end + # we need to make them appear here + my $zeroes_needed = $byte_count - length($$rvec); + return $$rvec . ("\x00" x $zeroes_needed); + } } sub from_raw { diff --git a/t/73-error-loc.t b/t/73-error-loc.t new file mode 100644 index 0000000..7aa7298 --- /dev/null +++ b/t/73-error-loc.t @@ -0,0 +1,30 @@ +#!/usr/bin/perl +use strict; +use warnings; + +use Test::More tests => 5; +use Test::Exception; + +use Moo::Role qw/apply_roles_to_object/; + +my $error_regex = qr/error-loc\.t/; + +require_ok 'Data::BitStream'; + +my $dbs = Data::BitStream->new(mode => 'ro'); + +throws_ok { $dbs->read($dbs->maxbits + 1) } $error_regex, 'read(maxbits + 1) should fail'; +note "Message: $@"; +throws_ok { $dbs->write(42, 8) } $error_regex, 'write to read-only should fail'; +note "Message: $@"; +throws_ok { $dbs->skip(-999999) } $error_regex, 'negative skip() should fail'; +note "Message: $@"; + +# I'm not certain if this is the correct behavior, but a read() returns undef +# if there are exactly zero bytes left in the stream +$dbs = Data::BitStream->new(); +$dbs->from_raw("\x00"); +throws_ok { $dbs->read(32) } $error_regex, 'read past EOF should fail'; +note "Message: $@"; + +done_testing; diff --git a/t/74-to-raw.t b/t/74-to-raw.t new file mode 100644 index 0000000..12d3cc5 --- /dev/null +++ b/t/74-to-raw.t @@ -0,0 +1,31 @@ +#!/usr/bin/perl +use strict; +use warnings; + +use Test::More; + +use Moo::Role qw/apply_roles_to_object/; + +sub test_case(&); + +require_ok 'Data::BitStream'; + +my $dbs; + +# write a single '1' bit; the result should be 1 byte long. +test_case { $dbs->write(1, 1) }; +# write a single '1' bit; the result should be 1 byte long. +test_case { $dbs->write(1, 0) }; + +sub test_case(&) { + my ($sub) = @_; + $dbs = Data::BitStream->new(); + $sub->($dbs); + my $bits = $dbs->len; + my $expected_length = int(($bits + 7) / 8); + my $raw_data = $dbs->to_raw(); + my $actual_length = length($raw_data); + is($actual_length, $expected_length, "Expecting $bits bits to take $expected_length bytes"); +} + +done_testing;