File Coverage

blib/lib/Tie/Comma.pm

Criterion	Covered	Total	%
statement	38	41	92.6
branch	16	20	80.0
condition	5	6	83.3
subroutine	7	9	77.7
pod	0	2	0.0
total	66	78	84.6

=for gpg
-----BEGIN PGP SIGNED MESSAGE-----
Hash: SHA1

=head1 NAME

Tie::Comma - A simple and easy way to format numbers with commas,
using a tied hash.

=head1 VERSION

This documentation describes version 0.04 of Tie::Comma, January 07, 2005

=cut

use strict;
package Tie::Comma;
$Tie::Comma::VERSION = 0.04;

use Exporter;
use vars qw/@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS %comma/;
@ISA       = qw/Exporter/;
@EXPORT    = qw/%comma/;
@EXPORT_OK = qw/commify/;
%EXPORT_TAGS = (all => [@EXPORT, @EXPORT_OK]);

# Defaults
our $thou_sep = ',';
our $deci_sep = '.';
our $grouping = 3;

# Configure for locale, if possible.
eval
{
    require POSIX;
    my $loc = POSIX::setlocale(POSIX::LC_NUMERIC());
    my $lc  = POSIX::localeconv();
    $thou_sep = $lc->{thousands_sep} || $thou_sep;
    $deci_sep = $lc->{decimal_point} || $deci_sep;
    $grouping = $lc->{grouping}? unpack('c', $lc->{grouping}) : $grouping;
};   # Ignore any errors in this block -- just fall back to the defaults.

# Substitution pattern
my $num_pat = "(" . ("\\d" x $grouping) . ")(?=\\d)(?!\\d*\\$deci_sep)";
my $num_re  = qr/$num_pat/;

# Here's the statement that makes it all happen.
tie our %comma, 'Tie::Comma';

# Delay loading Carp.pm until needed.
sub Tie::Comma::croak
{
    require Carp;
    goto &Carp::croak;
}

#--->     $string = commify $number;
# commify : Formats a number with commas.
# This version is taken from the Perl Cookbook.
sub commify ($)
{
    my $rev_num = reverse shift;  # The number to be formatted, reversed.
    $rev_num =~ s/$num_re/$1$thou_sep/g;
    return scalar reverse $rev_num;
}

sub TIEHASH
{
    my $class = shift;
    my $dummy;   # not used, but we need a reference.
    bless \$dummy, $class;
}

sub FETCH
{
    my $self = shift;
    my $key  = shift;
    return '' if !defined $key;    # No args? or undef? return empty string.

    my @args = split $;, $key, -1;
    @args > 3  and Tie::Comma::croak "Too many arguments to %comma";
    my ($num, $dp, $min_fw) = @args;

    for ($dp, $min_fw)
    {
        next unless defined;
        next unless length;
        s/\Q$deci_sep\E.*//o;  # remove any fractional part
        $_ = 0 unless /^-?\d+$/;
    }
    $min_fw = 0  if (!defined $min_fw  or  length $min_fw == 0);

    # Caller specified number of decimal places?
    if (defined $dp  &&  length $dp)
    {
        Tie::Comma::croak "Negative decimal places in %comma" if $dp < 0;
        $dp = abs($dp);
        $num = sprintf "%.${dp}f", $num;
    }

    my $cnum = commify $num;

    # Pad, if necessary.
    return $cnum if length $cnum >= abs($min_fw);
    my $spaces = ' ' x (abs($min_fw) - length $cnum);
    return $min_fw < 0?  "$cnum$spaces" : "$spaces$cnum";
}

use subs qw(
 STORE    EXISTS    CLEAR    FIRSTKEY    NEXTKEY  );
*STORE = *EXISTS = *CLEAR = *FIRSTKEY = *NEXTKEY = sub
{
    Tie::Comma::croak "Invalid call to Tie::Comma internal function";
};


1;
__END__