# $Id: FileSize.pm,v 1.7 2003/08/27 19:16:23 mrodrigu Exp $
package Format::FileSize;

use strict;

use List::Util qw( first);
use Scalar::Util qw( looks_like_number);
use Memoize;
use Carp;

memoize qw(make_size);
memoize qw(validate_params);

require Exporter;

use vars qw( @ISA %EXPORT_TAGS @EXPORT_OK @EXPORT $VERSION);

@ISA = qw(Exporter);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration	use Format::FileSize ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
#%EXPORT_TAGS = ( 'all' => [ qw( formatted_size) ) ] );

#@EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

@EXPORT = qw( formatted_size );

$VERSION = '0.01';

my $DEBUG=1;

# options names
my $OPT_PRECISION = 'precision';
my $OPT_NB_DEC    = 'nb_dec';
my $OPT_SYMBOLS   = 'symbols';
my $OPT_FACTOR    = 'factor';
my $OPT_KEEP_SIZE = 'keep_size';

my @ALLOWED_OPTIONS= ( $OPT_PRECISION, $OPT_NB_DEC, $OPT_SYMBOLS, $OPT_FACTOR, $OPT_KEEP_SIZE);
my %ALLOWED_OPTIONS= map { $_ => 1 } @ALLOWED_OPTIONS;

# default values
my $NB_DEC  = { 0 => 2, 10 => 1, 100 => 0 };
my $SYMBOLS = [ '', ' K', ' M', ' G', ' T', ' P'];
my $FACTOR  = 1024;

sub make_size
  { my( $factor, $symbols)= @_;
    my $i=0;
	my %size= map { $_ => $factor ** $i++ } @$symbols;
	return \%size;
  }
  
my $param_error;

sub formatted_size
  { my $size= shift;

	my %options= @_ ? (validate_params( @_) ? @_ : croak $param_error) : ();

	my $nb_dec  = defined $options{$OPT_NB_DEC}  ? $options{$OPT_NB_DEC}  : $NB_DEC; 
	my $factor  = defined $options{$OPT_FACTOR}  ? $options{$OPT_FACTOR}  : $FACTOR;
	my $symbols = defined $options{$OPT_SYMBOLS} ? $options{$OPT_SYMBOLS} : $SYMBOLS;

    my $size_map= make_size( $factor, $symbols);

    foreach my $unit ( reverse @$symbols)
      { my $int= int( $size / $size_map->{$unit});
		if( $int)
          { return $int.$unit if( $int == $size);
            # range found
			my $raw_dec= ($size % $size_map->{$unit}) / $size_map->{$unit};
			my $precision= defined $options{$OPT_PRECISION} 
			                 ? $options{$OPT_PRECISION}
		                     : ($nb_dec->{first { $int >= $_ } sort { $b <=> $a } keys %$nb_dec}); 
            my $dec= round( $raw_dec, $precision); 
			my $dec= ($dec=~ /[^0]/ || $options{$OPT_PRECISION}) ? ".$dec" : "";

            my $fs= "$int$dec$unit";
		   	
	        if( $options{$OPT_KEEP_SIZE}) 
			  { my $align= $options{$OPT_KEEP_SIZE} eq 'left' ? '-' : '';
                my $length= length( $size);
				if( (my $overflow= length( $fs) - $length) > 0 ) 
				  { if( length( $dec) > $overflow)
					  { substr( $dec, -$overflow, $overflow, '');
                        $dec=~ s{\.$}{}; # do not keep lone . at the end of the number
                        $fs= "$int$dec$unit";
                      }
                  }
                $fs= sprintf( "%$align$length\s", $fs);
              }

			return $fs;
          }
      }
    return 0;
  }

sub round
  { my( $nb, $precision)= @_;
	return 0 unless $precision;
	return sprintf( "%0$precision\d", int( $nb * (10 ** $precision)));
  }

sub validate_params
  { my %options= @_;
	
	if( defined $options{$OPT_PRECISION})
	  { if( defined $options{$OPT_NB_DEC}) 
          { $param_error= "cannot use both $OPT_PRECISION and $OPT_NB_DEC";
            return 0;
          }
        unless( allowed_precision( $options{$OPT_PRECISION}) )
		  { $param_error= "wrong precision $options{$OPT_PRECISION}: allowed values for $OPT_PRECISION are 0..4";
            return 0;
          }
      }

	if( defined $options{$OPT_NB_DEC})
	  { unless( UNIVERSAL::isa( $options{$OPT_NB_DEC}, 'HASH'))
          { $param_error= "$OPT_NB_DEC is not a hashref";
            return 0;
          }
        while( my( $key, $precision)= each %{$options{$OPT_NB_DEC}})
		  { unless( looks_like_number( $key))
			  { $param_error= "invalid key $key in $OPT_NB_DEC: key should be a number";
				return 0;
              }
            unless( allowed_precision( $precision))
			  { $param_error= "wrong precision $precision in $OPT_NB_DEC: allowed values for precision are 0..4"; }
            return 0;
          }
      }

    if( defined $options{$OPT_SYMBOLS})
	  {  unless( UNIVERSAL::isa( $options{$OPT_SYMBOLS}, 'ARRAY'))
          { $param_error= "$OPT_SYMBOLS is not an array";
            return 0;
          }
      }

	if( defined $options{$OPT_FACTOR})
	  { unless( looks_like_number( $options{$OPT_FACTOR}))
			  { $param_error= "invalid value $options{$OPT_FACTOR} for $OPT_FACTOR: value should be a number";
				return 0;
              }
      }

	if( my @invalid_options= grep { !$ALLOWED_OPTIONS{$_} } keys %options)
	  {  my $s= @invalid_options > 1 ? 's': '';
         $param_error= "invalid option$s " . join( ', ', @invalid_options);
		 return 0;
      }
    return 1;
  }


        

sub allowed_precision
  { my $precision= shift;
    return $precision=~ /^\s*[01234]\s*$/ ? 1 : 0;
  }


1;
__END__
# Below is stub documentation for your module. You'd better edit it!

=head1 NAME

Format::FileSize - Perl extension for formating file sizes

=head1 SYNOPSIS

  use Format::FileSize;
  my $size= formatted_size( -s $ARG[0]);
  print "$ARG[0] $size\n";

=head1 ABSTRACT

  Format::FileSize exports one function: formatted_size, which takes a size and
  returns a nicely formated number.

  It can also be configured to format other types of data.

=head1 DESCRIPTION

The number is formated so that it looks like I<n.nn U> or I<n U> where I<U> is
one of C<''>, C<K>, C<M>, C<G>, C<T>, C<P>.

=head2 EXPORT

=head3 formatted_size <$size>

C<formatted_size> takes a file size and returns it nicely formatted.

You can probably stop reading here.

By default the number is given as a number of units. Units are '' (empty), C<K>,
C<M>, C<G>, C<T>, C<P>. The number is formatted with 2 decimals if < 10, with 1 
if < 100 and with no decimals if > 100.

You should definitely stop reading HERE!

You can add (named) options after the size. 

Options are:

=over 4

=item precision => <$nb>

$nb must be an integer from 0 to 4. 

Numbers are always formatted with this number of digits after the dot.

=item nb_dec => <$hasref_trigger2precision>

C<$hasref_trigger2precision> is a hashref that controls how many digits
are displayed, depending on the integer part of the number.

The default is

   nb_dec => { 0 => 2, 10 => 1, 100 => 0 }

Which means that numbers between 0 and 10 are displayed with 2 digits
after the dot, numbers 10 and 100 with one digit after the dot, and
only the integer part is displayed for numbers above 100

You cannot use both C<precision> and C<nb_dec>.

=item symbols => <$arrayref_list_of_symbols>

Maybe you don't like the default units. No problem, you can change them
by passing a list to C<formatted_size>

  symbols => [ '', ' Kb', ' Mb', ' Gb', ' Tb', ' Waouh!' ]

A few notes: 

- don't forget the initial empty string if you don't want sizes under 1 Kb 
to get a unit

- the space between the number and the unit is part of the unit string, don't
forget it

=item factor

By default  C<formatted_size> assumes a factor of 1024 between 2 units, but
of course hard disk manufacturers use this strange (at least for computer geeks)
system where a Kb is really 1000 bytes, and a Mb is 1000 Kb. The C<factor>
option changes this:

  factor => 1000

=item keep_size => <left|right>

It can be convenient, when processing an output that's already formatted for 
example, to have the formatted string be the same size as the original string.

Use C<keep_size> to force the string to keep the same size. The code will try 
as hard as possible, even if means loosing precision.

=back

=head1 SEE ALSO

Time::Duration

=head1 AUTHOR

Michel Rodriguez, E<lt>mirod@cpan.org<gt>

=head1 COPYRIGHT AND LICENSE

Copyright 2003 by Michel Rodriguez

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself. 

=cut
