view release on metacpan or  search on metacpan

DiaColloDB/Utils.pm  view on Meta::CPAN

##    (
##     from   => $from,      ##-- replace prefix $from in file(s) with $todir; default=undef: flat copy to $todir
##     method => \&method,   ##-- use CODE-ref \&method as underlying copy routing; default=\&File::Copy::copy
##     label  => $label,     ##-- report errors as '$label'; (default='copyto()')
##    )
sub copyto {
  my $that = UNIVERSAL::isa($_[0],__PACKAGE__) ? shift : __PACKAGE__;
  my ($srcfiles,$todir,%opts) = @_;
  my $method = $opts{method} || \&File::Copy::copy;
  my $label  = $opts{label}  || 'copyto()';
  my $from   = $opts{from};
  my ($src,$dst,$dstdir);
  foreach $src (UNIVERSAL::isa($srcfiles,'ARRAY') ? @$srcfiles : $srcfiles) {
    if (defined($from)) {
      ($dst = $src) =~ s{^\Q$from\E}{$todir};
    } else {
      $dst = "$todir/".basename($src);
    }
    $dstdir = dirname($dst);
    -d $dstdir
      or make_path($dstdir)
      or $that->logconfess("$label: failed to create target directory '$dstdir': $!");
    $method->($src,$dst)
      or $that->logconfess("$label: failed to transfer file '$src' to to '$dst': $!");
  }
  return 1;
}

## $bool = PACKAGE->copyto_a($src,$dstdir,%opts)
## + wrapper for PACKAGE->copyto($src,$dstdir, %opts,method=>PACKAGE->can('cp_a'),label=>'copyto_a()')
sub copyto_a {
  my $that = UNIVERSAL::isa($_[0],__PACKAGE__) ? shift : __PACKAGE__;
  return $that->copyto(@_, method=>\&cp_a, label=>'copyto_a()');
}

## $bool = PACKAGE->moveto($src,$dstdir, %opts)
## + wrapper for PACKAGE->copyto($src,$dstdir, %opts,method=>\&File::Copy::move,label=>'moveto()')
sub moveto {
  my $that = UNIVERSAL::isa($_[0],__PACKAGE__) ? shift : __PACKAGE__;
  return $that->copyto(@_, method=>\&File::Copy::move, label=>'moveto()');
}

## $bool = PACKAGE->cp_a($src,$dst)
## $bool = PACKAGE->cp_a($src,$dstdir)
##  + copies file $src to $dst, propagating ownership, permissions, and timestamps
sub cp_a {
  my $that = UNIVERSAL::isa($_[0],__PACKAGE__) ? shift : __PACKAGE__;
  my ($src,$dst) = @_;
  if (File::Copy->can('syscopy') && File::Copy->can('syscopy') ne File::Copy->can('copy')) {
    ##-- use File::copy::syscopy() if available
    return File::Copy::syscopy($src,$dst,3);
  }
  ##-- copy and then manually propagate file attributes
  my $rc = File::Copy::copy($src,$dst) or return undef;
  $dst = "$dst/".basename($src) if (-d $dst);
  my @stat = stat($src);
  my ($perm,$gid,$atime,$mtime) = @stat[2,5,8,9];
  my $uid = $>==0 ? $stat[4] : $>;  ##-- don't try to set uid unless we're running as root
  $rc &&= CORE::chown($uid,$gid,$dst)
      or $that->warn("cp_a(): failed to propagate ownership from '$src' to '$dst': $!");
  $rc &&= CORE::chmod(($perm & 07777), $dst)
      or $that->warn("cp_a(): failed to propagate persmissions from '$src' to '$dst': $!");
  $rc &&= CORE::utime($atime,$mtime,$dst)
      or $that->warn("cp_a(): failed to propagate timestamps from '$src' to '$dst': $!");
  return $rc;
}

## $fh_or_undef = PACKAGE->fh_flush($fh)
##  + flushes filehandle $fh using its flush() method if available
sub fh_flush {
  shift if (UNIVERSAL::isa($_[0],__PACKAGE__));
  my $fh = shift;
  return UNIVERSAL::can($fh,'flush') ? $fh->flush() : $fh;
}

## $fh_or_undef = PACKAGE->fh_reopen($fh,$file)
##  + closes and re-opens filehandle $fh
sub fh_reopen {
  shift if (UNIVERSAL::isa($_[0],__PACKAGE__));
  my ($fh,$file) = @_;
  my $flags      = fcgetfl($fh) & (~O_TRUNC);
  my @layers0    = PerlIO::get_layers($fh);
  CORE::close($fh) || return undef;
  CORE::open($fh, fcperl($flags), $file) or return undef;
  my @layers1    = PerlIO::get_layers($fh);
  while (@layers0 && @layers1 && $layers0[0] eq $layers1[0]) {
    shift(@layers0);
    shift(@layers1);
  }
  binmode($fh,":$_") foreach (@layers1);
  return $fh;
}



##==============================================================================
## Utils: SI

## $str = si_str($float)
sub si_str {
  shift if (UNIVERSAL::isa($_[0],__PACKAGE__));
  my $x = shift;
  return sprintf("%.2fY", $x/10**24) if ($x >= 10**24);  ##-- yotta
  return sprintf("%.2fZ", $x/10**21) if ($x >= 10**21);  ##-- zetta
  return sprintf("%.2fE", $x/10**18) if ($x >= 10**18);  ##-- exa
  return sprintf("%.2fP", $x/10**15) if ($x >= 10**15);  ##-- peta
  return sprintf("%.2fT", $x/10**12) if ($x >= 10**12);  ##-- tera
  return sprintf("%.2fG", $x/10**9)  if ($x >= 10**9);   ##-- giga
  return sprintf("%.2fM", $x/10**6)  if ($x >= 10**6);   ##-- mega
  return sprintf("%.2fk", $x/10**3)  if ($x >= 10**3);   ##-- kilo
  return sprintf("%.2f",  $x)        if ($x >= 1);       ##-- (natural units)
  return sprintf("%.2fm", $x*10**3)  if ($x >= 10**-3);  ##-- milli
  return sprintf("%.2fu", $x*10**6)  if ($x >= 10**-6);  ##-- micro
  return sprintf("%.2fn", $x*10**9)  if ($x >= 10**-9);  ##-- nano
  return sprintf("%.2fp", $x*10**12) if ($x >= 10**-12); ##-- pico
  return sprintf("%.2ff", $x*10**15) if ($x >= 10**-15); ##-- femto
  return sprintf("%.2fa", $x*10**18) if ($x >= 10**-18); ##-- atto
  return sprintf("%.2fz", $x*10**21) if ($x >= 10**-21); ##-- zepto
  return sprintf("%.2fy", $x*10**24) if ($x >= 10**-24); ##-- yocto
  return sprintf("%.2g", $x); ##-- default
}