File Coverage

blib/lib/Math/SimpleHisto/XS.pm

Criterion	Covered	Total	%
statement	117	144	81.2
branch	49	78	62.8
condition	6	15	40.0
subroutine	14	15	93.3
pod	3	6	50.0
total	189	258	73.2

package Math::SimpleHisto::XS;
use 5.008001;
use strict;
use warnings;
use Carp qw(croak);

our $VERSION = '1.30'; # Committed to floating point version numbers!

require XSLoader;
XSLoader::load('Math::SimpleHisto::XS', $VERSION);

require Math::SimpleHisto::XS::RNG;

require Exporter;
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(
  INTEGRAL_CONSTANT
);
  #INTEGRAL_POL1

our %EXPORT_TAGS = (
  'all' => \@EXPORT_OK,
);

our @JSON_Modules = qw(JSON::XS JSON::PP JSON);
our $JSON_Implementation;
our $JSON;

foreach my $json_module (@JSON_Modules) {
  if (eval "require $json_module; 1;") {
    $JSON = $json_module->new;
    $JSON->indent(0) if $JSON->can('indent');
    $JSON->space_before(0) if $JSON->can('space_before');
    $JSON->space_after(0) if $JSON->can('space_after');
    $JSON->canonical(0) if $JSON->can('canonical');
    $JSON_Implementation = $json_module;
    last if $JSON;
  }
}

sub new {
  my $class = shift;
  my %opt = @_;

  if (defined $opt{bins}) {
    my $bins = $opt{bins};
    croak("Cannot combine the 'bins' parameter with other parameters") if keys %opt > 1;
    croak("The 'bins' parameter needs to be a reference to an array of bins")
      if not ref($bins)
      or not ref($bins) eq 'ARRAY'
      or not @$bins > 1;
    return $class->_new_histo_bins($bins);
  }
  else {
    foreach (qw(min max nbins)) {
      croak("Need parameter '$_'") if not defined $opt{$_};
    }
  }

  return $class->_new_histo(@opt{qw(nbins min max)});
}

# See ExtUtils::Constant
sub AUTOLOAD {
  # This AUTOLOAD is used to 'autoload' constants from the constant()
  # XS function.

  my $constname;
  our $AUTOLOAD;
  ($constname = $AUTOLOAD) =~ s/.*:://;
  croak('&' . __PACKAGE__ . "::constant not defined") if $constname eq 'constant';
  my ($error, $val) = constant($constname);
  if ($error) { croak($error); }
  {
    no strict 'refs';
    *$AUTOLOAD = sub { $val };
  }
  goto &$AUTOLOAD;
}


use constant _PACK_FLAG_VARIABLE_BINS => 0;

my $native_pack_len;
SCOPE: {
  require bytes;
  my $intlen = bytes::length(pack('I', 0));
  $native_pack_len = 8 + 4 + 16 + 4 + $intlen*2 + 16;
}

sub dump {
  my $self = shift;
  my $type = shift;
  $type = lc($type);

  my ($min, $max, $nbins, $nfills, $overflow, $underflow, $data_ary, $bins_ary)
    = $self->_get_info;

  if ($type eq 'simple') {
    return join(
      ';',
      $VERSION,
      $min, $max, $nbins,
      $nfills, $overflow, $underflow,
      join('|', @$data_ary),
      (defined($bins_ary) ? join('|', @$bins_ary) : ''),
    );
  }
  elsif ($type eq 'json' or $type eq 'yaml') {
    my $struct = {
      version => $VERSION,
      min => $min, max => $max, nbins => $nbins,
      nfills => $nfills, overflow => $overflow, underflow => $underflow,
      data => $data_ary,
    };
    $struct->{bins} = $bins_ary if defined $bins_ary;

    if ($type eq 'json') {
      if (not defined $JSON) {
        die "Cannot use JSON dump mode since no JSON handling module could be loaded: "
            . join(', ', @JSON_Modules);
      }
      return $JSON->encode($struct);
    }
    else { # type eq yaml
      require YAML::Tiny;
      return YAML::Tiny::Dump($struct);
    }
  }
  elsif ($type eq 'native_pack') {
    my $flags = 0;
    vec($flags, _PACK_FLAG_VARIABLE_BINS, 1) = $bins_ary ? 1 : 0;

    my $len = $native_pack_len + 8 * (scalar(@$data_ary) + scalar(@{$bins_ary || []}));
    return pack(
      'd V d2 V I2 d2 d*',
      $VERSION,
      $len,
      $min, $max,
      $flags,
      $nbins,
      $nfills, $overflow, $underflow,
      @$data_ary,
      @{$bins_ary || []}
    );
  }
  else {
    croak("Unknown dump type: '$type'");
  }
  die "Must not be reached";
}


sub _check_version {
  my $version = shift;
  my $type = shift;
  if (not $version) {
    croak("Invalid '$type' dump format");
  }
  elsif ($VERSION-$version < -1.) {
    croak("Dump was generated with an incompatible newer version ($version) of this module ($VERSION)");
  }
}

sub new_from_dump {
  my $class = shift;
  my $type = shift;
  my $dump = shift;
  $type = lc($type);

  croak("Need dump string") if not defined $dump;

  my $version;
  my $hashref;
  if ($type eq 'simple') {
    ($version, my @rest) = split /;/, $dump, -1;
    my $nexpected = 9;

    _check_version($version, 'simple');
    if ($version <= 1.) { # no bins array in VERSION < 1
      $nexpected--;
    }
    elsif (@rest != $nexpected-1) {
      croak("Invalid 'simple' dump format, wrong number of elements in top level structure");
    }

    $hashref = {
      min => $rest[0], max => $rest[1], nbins => $rest[2],
      nfills => $rest[3], overflow => $rest[4], underflow => $rest[5],
      data => [split /\|/, $rest[6]]
    };
    if ($version >= 1. and $rest[7] ne '') {
      $hashref->{bins} = [split /\|/, $rest[7]];
    }
  }
  elsif ($type eq 'json') {
    if (not defined $JSON) {
      die "Cannot use JSON dump mode since no JSON handling module could be loaded: "
          . join(', ', @JSON_Modules);
    }
    $hashref = $JSON->decode($dump);
    $version = $hashref->{version};
    _check_version($version, 'json');
    croak("Invalid JSON dump, not a hashref") if not ref($hashref) eq 'HASH';
  }
  elsif ($type eq 'yaml') {
    require YAML::Tiny;
    my @docs = YAML::Tiny::Load($dump);
    if (@docs != 1 or not ref($docs[0]) eq 'HASH') {
      croak("Invalid YAML dump, not a single YAML document or not containing a hashref");
    }
    $hashref = $docs[0];
    $version = $hashref->{version};
    _check_version($version, 'yaml');
  }
  elsif ($type eq 'native_pack') {
    my $version = unpack('d', $dump);
    _check_version($version, 'native_pack');
    my $flags_support = $version >= 1.;
    my $prepended_length = $version >= 1.28;
    my $ndoubles;

    # We go through all this pain about the length and the number of elements in the packed
    # dump because that'll allow us to prevent reading beyond the end of a given dump.
    if ($prepended_length) {
      (undef, my $len) = unpack('d V', $dump);
      $len -= $native_pack_len;
      $ndoubles = $len / 8;
    }
    my $pack_str = $flags_support
                   ? ($prepended_length ? "d V d2 V I2 d2 d$ndoubles" : 'd3 V I2 d2 d*')
                   : 'd3 I2 d2 d*';

    my @things = unpack($pack_str, $dump);
    $version = shift @things;
    $hashref = {version => $version};

    foreach (($prepended_length ? ('data_length') : ()),
             qw(min max),
             ($flags_support ? ('flags') : ()),
             qw(nbins nfills overflow underflow))
    {
      $hashref->{$_} = shift(@things);
    }

    if ($flags_support) {
      my $flags = delete $hashref->{flags};
      if (vec($flags, _PACK_FLAG_VARIABLE_BINS, 1)) {
        $hashref->{bins} = [splice(@things, $hashref->{nbins})];
      }
    }

    $hashref->{data} = \@things;
  }
  else {
    croak("Unknown dump type: '$type'");
  }

  my $self;
  if (defined $hashref->{bins}) {
    $self = $class->new(bins => $hashref->{bins});
  }
  else {
    $self = $class->new(
      min   => $hashref->{min},
      max   => $hashref->{max},
      nbins => $hashref->{nbins},
    );
  }

  $self->set_nfills($hashref->{nfills});
  $self->set_overflow($hashref->{overflow});
  $self->set_underflow($hashref->{underflow});
  $self->set_all_bin_contents($hashref->{data});

  return $self;
}


sub STORABLE_freeze {
  my $self = shift;
  my $cloning = shift;
  my $serialized = $self->dump('simple');
  return $serialized;
}

sub STORABLE_thaw {
  my $self = shift;
  my $cloning = shift;
  my $serialized = shift;
  my $new = ref($self)->new_from_dump('simple', $serialized);
  $$self = $$new;
  # Pesky DESTROY :P
  bless($new => 'Math::SimpleHisto::XS::Doesntexist');
  $new = undef;
}

sub to_soot {
  my ($self, $name, $title) = @_;
  $name = '' if not defined $name;
  $title = '' if not defined $title;

  require SOOT;
  my $th1d = TH1D->new($name, $title, $self->nbins, $self->min, $self->max);
  $th1d->SetBinContent($_, $self->bin_content($_-1)) for 1..$self->nbins;
  $th1d->SetEntries($self->nfills);

  return $th1d;
}

1;
__END__