view release on metacpan or  search on metacpan

DiaColloDB/Utils.pm  view on Meta::CPAN

## $cmd_prefix = sortCmd($njobs=$DiaColloDB::NJOBS)
##  + returns command-prefix for UNIX sort
##  + uses environment variable $DIACOLLO_SORT if present, otherwise $SORT if set
##  + defualts to system 'sort' command from PATH with appended sortJobs() options
sub sortCmd {
  my $that = UNIVERSAL::isa($_[0],__PACKAGE__) ? shift : __PACKAGE__;
  return $ENV{DIACOLLO_SORT} || $ENV{SORT} || ('sort '.$that->sortJobs(@_));
}

## $bool = csort_to(\@sortargs, \&catcher)
##  + runs system sort and feeds resulting lines to \&catcher
sub csort_to {
  my $that = UNIVERSAL::isa($_[0],__PACKAGE__) ? shift : __PACKAGE__;
  my ($sortargs,$catcher) = @_;
  return crun([$that->sortCmd(),@$sortargs], '>', IPC::Run::new_chunker("\n"), $catcher);
}

## $bool = csortuc_to(\@sortargs, \&catcher)
##  + runs system sort | uniq -c and feeds resulting lines to \&catcher
sub csortuc_to {
  my $that = UNIVERSAL::isa($_[0],__PACKAGE__) ? shift : __PACKAGE__;
  my ($sortargs,$catcher) = @_;
  return crun([$that->sortCmd(),@$sortargs], '|', [qw(uniq -c)], '>', IPC::Run::new_chunker("\n"), $catcher);
}


##==============================================================================
## Functions: pack filters

## $len = PACKAGE::packsize($packfmt)
## $len = PACKAGE::packsize($packfmt,@args)
##  + get pack-size for $packfmt with args @args
sub packsize {
  use bytes; #use bytes; ##-- deprecated in perl v5.18.2
  no warnings;
  shift if (UNIVERSAL::isa($_[0],__PACKAGE__));
  return bytes::length(pack($_[0],@_[1..$#_]));
}

## $bool = PACKAGE::packsingle($packfmt)
## $bool = PACKAGE::packsingle($packfmt,@args)
##  + guess whether $packfmt is a single-element (scalar) format
sub packsingle {
  shift if (UNIVERSAL::isa($_[0],__PACKAGE__));
  return (packsize($_[0],0)==packsize($_[0],0,0)
	  && $_[0] !~ m{\*|(?:\[(?:[2-9]|[0-9]{2,})\])|(?:[[:alpha:]].*[[:alpha:]])});
}

## $bool = PACKAGE::packeq($packfmt1,$packfmt2,$val=0x123456789abcdef)
##  + returns true iff $packfmt1 and $packfmt2 are equivalent for $val
sub packeq {
  shift if (UNIVERSAL::isa($_[0],__PACKAGE__));
  my ($fmt1,$fmt2,$val) = @_;
  $val //= 0x12345678;
  return pack($fmt1,$val) eq pack($fmt2,$val);
}

## \&filter_sub = PACKAGE::packFilterStore($pack_template)
## \&filter_sub = PACKAGE::packFilterStore([$pack_template_store, $pack_template_fetch])
## \&filter_sub = PACKAGE::packFilterStore([\&pack_code_store,   \&pack_code_fetch])
##   + returns a DB_File-style STORE-filter sub for transparent packing of data to $pack_template
sub packFilterStore {
  my $that   = UNIVERSAL::isa($_[0],__PACKAGE__) ? shift : __PACKAGE__;
  my $packas = shift;
  $packas    = $packas->[0] if (UNIVERSAL::isa($packas,'ARRAY'));
  return $packas  if (UNIVERSAL::isa($packas,'CODE'));
  return undef    if (!$packas || $packas eq 'raw');
  if ($that->packsingle($packas)) {
    return sub {
      $_ = pack($packas,$_) if (defined($_));
    };
  } else {
    return sub {
      $_ = pack($packas, ref($_) ? @$_ : split(/\t/,$_)) if (defined($_));
    };
  }
}

## \&filter_sub = PACKAGE::packFilterFetch($pack_template)
## \&filter_sub = PACKAGE::packFilterFetch([$pack_template_store, $pack_template_fetch])
## \&filter_sub = PACKAGE::packFilterFetch([\&pack_code_store,   \&pack_code_fetch])
##   + returns a DB_File-style FETCH-filter sub for transparent unpacking of data from $pack_template
sub packFilterFetch {
  my $that   = UNIVERSAL::isa($_[0],__PACKAGE__) ? shift : __PACKAGE__;
  my $packas = shift;
  $packas    = $packas->[1] if (UNIVERSAL::isa($packas,'ARRAY'));
  return $packas  if (UNIVERSAL::isa($packas,'CODE'));
  return undef    if (!$packas || $packas eq 'raw');
  if ($that->packsingle($packas)) {
    return sub {
      $_ = unpack($packas,$_);
    };
  } else {
    return sub {
      $_ = [unpack($packas,$_)];
    }
  }
}

##==============================================================================
## Math stuff

sub isNan {
  no warnings qw(uninitialized numeric);
  return !($_[0]<=0||$_[0]>=0);
}
sub isInf {
  no warnings qw(uninitialized numeric);
  return !($_[0]<=0||$_[0]>=0) || ($_[0]==+"INF") || ($_[0]==-"INF");
}
sub isFinite {
  no warnings qw(uninitialized numeric);
  return ($_[0]<=0||$_[0]>=0) && ($_[0]!=+"INF") && ($_[0]!=-"INF");
}

our ($LOG2);
BEGIN {
  $LOG2 = log(2.0);
}

## $log2 = log2($x)
sub log2 {
  return $_[0]==0 ? -inf : log($_[0])/$LOG2;
}

## $max2 = max2($x,$y)
sub max2 {
  return $_[0] > $_[1] ? $_[0] : $_[1];
}

## $min2 = min2($x,$y)
sub min2 {
  return $_[0] < $_[1] ? $_[0] : $_[1];
}

## $max = lmax(@vals)
sub lmax {
  my $max = undef;
  foreach (@_) {
    $max = $_ if (!defined($max) || (defined($_) && $_ > $max));
  }
  return $max;