File Coverage

blib/lib/Number/Bytes/Human.pm

Criterion	Covered	Total	%
statement	162	181	89.5
branch	74	92	80.4
condition	47	67	70.1
subroutine	16	16	100.0
pod	6	6	100.0
total	305	362	84.2

package Number::Bytes::Human;

use strict;
use warnings;

our $VERSION = '0.10';

require Exporter;
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(format_bytes parse_bytes);

require POSIX;
use Carp qw(croak carp);

#my $DEFAULT_BLOCK = 1024;
#my $DEFAULT_ZERO = '0';
#my $DEFAULT_ROUND_STYLE = 'ceil';
my %DEFAULT_SUFFIXES = (
  1024 => ['', 'K', 'M', 'G', 'T', 'P', 'E', 'Z', 'Y'],
  1000 => ['', 'k', 'M', 'G', 'T', 'P', 'E', 'Z', 'Y'],
  1024000 => ['', 'M', 'T', 'E', 'Y'],
  si_1024 => ['B', 'KiB', 'MiB', 'GiB', 'TiB', 'PiB', 'EiB', 'ZiB', 'YiB'],
  si_1000 => ['B', 'kB', 'MB', 'GB', 'TB', 'PB', 'EB', 'ZB', 'YB'],
);
my @DEFAULT_PREFIXES = @{$DEFAULT_SUFFIXES{1024}};

sub _default_suffixes {
  my $set = shift || 1024;
  if (exists $DEFAULT_SUFFIXES{$set}) {
    return @{$DEFAULT_SUFFIXES{$set}} if wantarray;
    return [ @{$DEFAULT_SUFFIXES{$set}} ];
  }
  croak "unknown suffix set '$set'";
}

my %ROUND_FUNCTIONS = (
  ceil => sub { return POSIX::ceil($_[0] * (10 ** $_[1])) / 10**$_[1]; },
  floor => sub { return POSIX::floor($_[0] * (10 ** $_[1])) / 10**$_[1]; },
  round => sub { return sprintf( "%." . ( $_[1] || 0 ) . "f", $_[0] ); },
  trunc => sub { return sprintf( "%d", $_[0] * (10 ** $_[1])) / 10**$_[1]; },
  # what about 'ceiling'?
);

sub _round_function {
  my $style = shift;
  if (exists $ROUND_FUNCTIONS{$style}) {
    return $ROUND_FUNCTIONS{$style}
  }
  croak "unknown round style '$style'";
}

# options
#   block | block_size | base | bs => 1024 | 1000
#   base_1024 | block_1024 | 1024 => $true
#   base_1000 | block_1000 | 1000 => $true
#
#   round_function => \&
#   round_style => 'ceiling', 'round', 'floor', 'trunc'
#
#   suffixes => 1024 | 1000 | si_1024 | si_1000 | 1024000 | \@
#   si => 1
#   unit => string (eg., 'B' | 'bps' | 'b')
#
#   zero => '0' (default) | '-' | '0%S' | undef
#
#
#   supress_point_zero | no_point_zero =>
#   b_to_i => 1
#   to_s => \&
#
#   allow_minus => 0 | 1
#   too_large => string
#   quiet => 1 (supresses "too large number" warning)



#  PROBABLY CRAP:
#   precision => integer

# parsed options
#   BLOCK => 1024 | 1000
#   ROUND_STYLE => 'ceil', 'round', 'floor', 'trunc'
#   ROUND_FUNCTION => \&
#   SUFFIXES => \@
#   ZERO =>
#   SI => undef | 1			Parse SI compatible


=begin private

  $options = _parse_args($seed, $args)
  $options = _parse_args($seed, arg1 => $val1, ...)

$seed is undef or a hashref
$args is a hashref

=end private

=cut

sub _parse_args {
  my $seed = shift;
  my %args;

  my %options;
  unless (defined $seed) { # use defaults
    $options{BLOCK} = 1024;
    $options{ROUND_STYLE} = 'ceil';
    $options{ROUND_FUNCTION} = _round_function($options{ROUND_STYLE});
    $options{ZERO} = '0';
    $options{SI} = undef;
    $options{PRECISION} = 1;
    $options{PRECISION_CUTOFF} = 1;
    #$options{SUFFIXES} = # deferred to the last minute when we know BLOCK, seek [**]
    $options{UNIT} = undef;
  }
  # else { %options = %$seed } # this is set if @_!=0, down below

  if (@_==0) { # quick return for default values (no customized args)
    return (defined $seed) ? $seed : \%options;
  } elsif (@_==1 && ref $_[0]) { # \%args
    %args = %{$_[0]};
  } else { # arg1 => $val1, arg2 => $val2
    %args = @_;
  }

  # this is done here so this assignment/copy doesn't happen if @_==0
  %options = %$seed unless %options;

# block | block_size | base | bs => 1024 | 1000
# block_1024 | base_1024 | 1024 => $true
# block_1000 | base_1000 | 1024 => $true
  if ($args{block} ||
      $args{block_size} ||
      $args{base} ||
      $args{bs}
    ) {
    my $block = $args{block} ||
                $args{block_size} ||
                $args{base} ||
                $args{bs};
    unless ($block==1000 || $block==1024 || $block==1_024_000) {
      croak "invalid base: $block (should be 1024, 1000 or 1024000)";
    }
    $options{BLOCK} = $block;

  } elsif ($args{block_1024} ||
           $args{base_1024}  ||
           $args{1024}) {

    $options{BLOCK} = 1024;
  } elsif ($args{block_1000} ||
           $args{base_1000}  ||
           $args{1000}) {

    $options{BLOCK} = 1000;
  }

# round_function => \&
# round_style => 'ceil' | 'floor' | 'round' | 'trunc'
  if ($args{round_function}) {
    unless (ref $args{round_function} eq 'CODE') {
      croak "round function ($args{round_function}) should be a code ref";
    }
    $options{ROUND_FUNCTION} = $args{round_function};
    $options{ROUND_STYLE} = $args{round_style} || 'unknown';
  } elsif ($args{round_style}) {
    $options{ROUND_FUNCTION} = _round_function($args{round_style});
    $options{ROUND_STYLE} = $args{round_style};
  }

# SI compatibility (mostly for parsing)
  if ($args{si}) {
    $options{SI} = 1;
  }

# suffixes => 1024 | 1000 | si_1024 | si_1000 | 1024000 | \@
  if ($args{suffixes}) {
    if (ref $args{suffixes} eq 'ARRAY') {
      $options{SUFFIXES} = $args{suffixes};
    } elsif ($args{suffixes} =~ /^(si_)?(1000|1024)$/) {
      $options{SUFFIXES} = _default_suffixes($args{suffixes});
    } else {
      croak "suffixes ($args{suffixes}) should be 1024, 1000, si_1024, si_1000, 1024000 or an array ref";
    }
  }
  if (defined $args{unit}) {
    $options{UNIT} = $args{unit};
  }

# zero => undef | string
  if (exists $args{zero}) {
    $options{ZERO} = $args{zero};
    if (defined $options{ZERO}) {
      $options{ZERO} =~ s/%S/$options{SUFFIXES}->[0]/g
    }
  }

# precision =>
  if (exists $args{precision} and $args{precision} =~ /\A\d+\z/) {
    $options{PRECISION} = $args{precision};
  }

# precision_cutoff =>
  if (exists $args{precision_cutoff} and ($args{precision_cutoff} =~ /\A\d+\z/ or $args{precision_cutoff} = '-1')) {
    $options{PRECISION_CUTOFF} = $args{precision_cutoff};
  }

# quiet => 1
  if ($args{quiet}) {
    $options{QUIET} = 1;
  }

  if (defined $seed) {
    %$seed = %options;
    return $seed;
  }
  return \%options
}

# NOTE. _format_bytes() SHOULD not change $options - NEVER.

sub _format_bytes {
  my $bytes = shift;
  return undef unless defined $bytes;
  my $options = shift;
  my %options = %$options;

  local *human_round = $options{ROUND_FUNCTION};

  return $options{ZERO} if ($bytes==0 && defined $options{ZERO});

  my $block = $options{BLOCK};

  # if a suffix set was not specified, pick a default [**]
  my @suffixes = $options{SUFFIXES} ? @{$options{SUFFIXES}} : _default_suffixes( ($options{SI} ? 'si_' : '') . $block);

  # WHAT ABOUT NEGATIVE NUMBERS: -1K ?
  my $sign = '';
  if ($bytes<0) {
     $bytes = -$bytes;
     $sign = '-';
  }

  my $suffix = $suffixes[0];
  my $x = $bytes;
  my $magnitude = 0;
  if($bytes >= $block) {
  #  return "$sign$bytes" if $bytes<$block;
    do {
      $x /= $block;
      $magnitude++;
    } while ( human_round($x, $options{PRECISION}) >= $block );
    if($magnitude >= (0 + @suffixes)) {
      carp "number too large (>= $block**$magnitude)" unless ($options{QUIET});
    }
    $suffix = $suffixes[$magnitude];
  }
  #$x = human_round( $x, $options{PRECISION} );

  $x = _precision_cutoff($x, $options);
  #reasses encase the precision_cutoff caused the value to cross the block size
  if($x >= $block) {
    $x /= $block;
    $magnitude++;
    if($magnitude >= (0 + @suffixes)) {
      carp "number too large (>= $block**$magnitude)" unless ($options{QUIET});
    }
    $suffix = $suffixes[$magnitude];
    $x = _precision_cutoff($x, $options);
  }

  my $unit = $options{UNIT} || '';

  return $sign . $x . $suffix . $unit;

}

sub _precision_cutoff {
 my $bytes   = shift;
 my $options = shift;
 my %options = %$options;
 if ( $options{PRECISION_CUTOFF} != -1 and ( length( sprintf( "%d", $bytes ) ) > $options{PRECISION_CUTOFF} ) ) {
   $bytes = sprintf( "%d", human_round( $bytes, 0 ) );
 } else {
   $bytes = sprintf( "%." . $options{PRECISION} . "f", human_round( $bytes, $options{PRECISION} ) );
 }
 return $bytes;
}

sub _parse_bytes {
  my $human = shift;
  my $options = shift;
  my %options = %$options;

  return 0 if( exists $options{ZERO} && ((!defined $options{ZERO} && !defined $human) || (defined $human && $human eq $options{ZERO})) );
  return undef unless defined $human;

  my %suffix_mult;
  my %suffix_block;
  my $m;

  if( $options{SUFFIXES} ) {
    $m = 1;
    foreach my $s (@{$options{SUFFIXES}}) {
      $suffix_mult{$s} = $m;
      $suffix_block{$s} = $options{BLOCK};
      $m *= $suffix_block{$s};
    }
  } else {
    if( !defined $options{SI} || $options{SI} == 1 ) {
      # If SI compatibility has been set BLOCK is ignored as it is infered from the unit
      $m = 1;
      foreach my $s (@{$DEFAULT_SUFFIXES{si_1000}}) {
        $suffix_mult{$s} = $m;
        $suffix_block{$s} = 1000;
        $m *= $suffix_block{$s};
      }

      $m = 1;
      foreach my $s (@{$DEFAULT_SUFFIXES{si_1024}}) {
        $suffix_mult{$s} = $m;
        $suffix_block{$s} = 1024;
        $m *= $suffix_block{$s};
      }
    }

    # The regular suffixes are only taken into account in default mode without specifically asking for SI compliance
    if( !defined $options{SI} ) {
      $m = 1;
      foreach my $s (_default_suffixes( $options{BLOCK} )) {
        $suffix_mult{$s} = $m;
        $suffix_block{$s} = $options{BLOCK};
        $m *= $suffix_block{$s};
      }
    }
  }

  my ($sign, $k, $unit) = ($human =~ /^\s*(-?)\s*(\d*(?:\.\d*)?)\s*(\D*)$/);

#  print STDERR "S: $sign K: $k U: $unit\n";


  my $mult;
  my $u = $options{UNIT} || '';
  foreach my $s (keys %suffix_block) {
    if( $unit =~ /^${s}${u}$/i ) {
      $mult = ($sign eq '-' ? -1 : 1) * $suffix_mult{$s};
      last;
    }
  }

  if( !defined $mult ) {
    carp "Could not parse human readable byte value '$human'";
use Data::Dumper;
print STDERR Dumper( %suffix_block );
    return undef;
  }

  my $bytes = int( $k * $mult );

  return $bytes;
}


# convert byte count (file size) to human readable format
sub format_bytes {
  my $bytes = shift;
  my $options = _parse_args(undef, @_);
  #use YAML; print Dump $options;
  return _format_bytes($bytes, $options);
}

# convert human readable format to byte count (file size)
sub parse_bytes {
  my $human = shift;
  my $options = _parse_args(undef, @_);
  #use YAML; print Dump $options;
  return _parse_bytes($human, $options);
}

### the OO way

# new()
sub new {
  my $proto = shift;
  my $class = ref $proto || $proto;
  my $opts = _parse_args(undef, @_);
  return bless $opts, $class;
}

# set_options()
sub set_options {
  my $self = shift;
  return $self->_parse_args(@_);
}

# format()
sub format {
  my $self = shift;
  my $bytes = shift;
  return _format_bytes($bytes, $self);
}

# parse()
sub parse {
  my $self = shift;
  my $human = shift;
  return _parse_bytes($human, $self);
}

# the solution by COG in Filesys::DiskUsage
# convert size to human readable format
#sub _convert {
#  defined (my $size = shift) || return undef;
#  my $config = {@_};
#  $config->{human} || return $size;
#  my $block = $config->{'Human-readable'} ? 1000 : 1024;
#  my @args = qw/B K M G/;
#
#  while (@args && $size > $block) {
#    shift @args;
#    $size /= $block;
#  }
#
#  if ($config->{'truncate-readable'} > 0) {
#    $size = sprintf("%.$config->{'truncate-readable'}f",$size);
#  }
#
#  "$size$args[0]";
#}
#
# not exact: 1024 => 1024B instead of 1K
# not nicely formatted => 1.00 instead of 1K

1;

__END__