File Coverage

blib/lib/Tie/Function/Examples.pm

Criterion	Covered	Total	%
statement	18	29	62.0
branch			n/a
condition			n/a
subroutine	6	12	50.0
pod			n/a
total	24	41	58.5

package Tie::Function::Examples;

@ISA = qw(Tie::StdHash Exporter);
@EXPORT_OK = qw(%thoucomma %nothoucomma %addcents %q_shell %q_perl %round %sprintf %line_numbers);

require Tie::Hash;
require Exporter;
use Carp;
use strict;
use warnings;

our $VERSION = 0.44;

use strict;

tie our %q_perl, 'Tie::Function::Examples',
	sub {
		my ($string) = @_;
		$string =~ s/'/'."'".'/g;
		return "'$string'";
	};

tie our %q_shell, 'Tie::Function::Examples',
	sub {
		my ($file) = @_;
		return $file if $file =~ /^[-,_\.+=:\/0-9a-zA-Z]+$/;
		$file =~ s/'/'\\''/g;
		return "'$file'";
	};


tie our %sprintf, 'Tie::Function::Examples',
	sub {
		my ($format, @args) = split($; , $_[0]);
		return sprintf($format, @args);
	};

tie our %round, 'Tie::Function::Examples',
	sub {
		my ($amount, $scale) = split($; , $_[0]);
		require POSIX;
		$scale = 1 unless $scale;
		# scale = .01 for cents
		# scale = 1000 for thousands
		$amount /= $scale;
		$amount += .5;
		$amount = POSIX::floor($amount);
		$amount *= $scale;
		return $amount;
	};

tie my %decomma, 'Tie::Function::Examples',
	sub {
		my ($f) = @_;
		$f =~ s/,//g;
		return $f;
	};

tie our %nothoucomma, 'Tie::Function::Examples',
	sub {
		my ($number) = @_;
		$number =~ s/(\A|\D)(\d\d?\d?)(,\d\d\d)+(\D|\z)/$1$2$decomma{$3}$4/g;
		return $number;
	};

tie our %thoucomma, 'Tie::Function::Examples',
	sub {
		my ($number) = @_;
		1 while ($number =~ s/(?
		return $number;
	};

tie our %addcents, 'Tie::Function::Examples',
	sub {
		my ($money) = @_;
		1 while ($money =~ s/(?
		1 while ($money =~ s/(?
		1 while ($money =~ s/(?
		$money =~ s/(\d+\.\d\d\d+)([^\d,]|\z|,(?!\d))/$sprintf{'%.2f', $1}$2/g;
		$money =~ s/(\d[\d,]+\.\d\d\d+)([^\d,]|\z|,(?!\d))/$thoucomma{$sprintf{'%.2f', $nothoucomma{$1}}}$2/g;
		return $money;
	};

tie our %line_numbers, 'Tie::Function::Examples',
	sub {
		my $text = shift;
		my @x = split(/\n/, $text);
		my $c = 0;
		return join("\n", map { sprintf("%-4d%s", $c++, $_) } @x);
	};

#
#
#

sub TIEHASH
{
	my ($pkg, $func, @args) = @_;
	return bless [
		$func,
		[@args],
		{},
	];
}

sub FETCH
{
	my ($self, $lookup) = @_;
	return &{$self->[0]}($lookup, $self->[2], @{$self->[1]});
}

sub STORE    { $_[0]->[2]{$_[1]} = $_[2] }
sub FIRSTKEY { my $a = scalar keys %{$_[0]->[2]}; each %{$_[0]->[2]} }
sub NEXTKEY  { each %{$_[0]->[2]} }
sub EXISTS   { exists $_[0]->[2]{$_[1]} }
sub DELETE   { delete $_[0]->[2]{$_[1]} }
sub CLEAR    { %{$_[0]->[2]} = () }

1;

__END__