File Coverage

blib/lib/Business/Shipping/Util.pm
Criterion Covered Total %
statement 39 72 54.1
branch 0 20 0.0
condition 0 9 0.0
subroutine 13 17 76.4
pod 4 4 100.0
total 56 122 45.9


line stmt bran cond sub pod time code
1             package Business::Shipping::Util;
2              
3             =head1 NAME
4              
5             Business::Shipping::Util - Miscellaneous functions
6              
7             =head1 DESCRIPTION
8              
9             Misc functions.
10              
11             =head1 METHODS
12              
13             =cut
14              
15 13     13   80 use strict;
  13         26  
  13         541  
16 13     13   76 use warnings;
  13         21  
  13         426  
17 13     13   82 use base ('Exporter');
  13         32  
  13         2024  
18 13     13   38250 use Data::Dumper;
  13         109602  
  13         1091  
19 13     13   221 use Business::Shipping::Logging;
  13         28  
  13         1677  
20 13     13   81 use Carp;
  13         30  
  13         776  
21 13     13   79 use File::Find;
  13         25  
  13         997  
22 13     13   15299 use File::Copy;
  13         44068  
  13         1085  
23 13     13   114 use Fcntl ':flock';
  13         34  
  13         2072  
24 13     13   32707 use English;
  13         38836  
  13         97  
25 13     13   8152 use version; our $VERSION = qv('400');
  13         35  
  13         114  
26 13     13   1281 use vars qw(@EXPORT_OK);
  13         29  
  13         6491  
27              
28             @EXPORT_OK = qw( looks_like_number unique );
29              
30             =head2 * currency( $opt, $amount )
31              
32             Formats a number for display as currency in the current locale (currently, the
33             only locale supported is USD).
34              
35             =cut
36              
37             sub currency {
38 0     0 1   my ($opt, $amount) = @_;
39              
40 0 0         return unless $amount;
41 0           $amount = sprintf("%.2f", $amount);
42 0 0         $amount = "\$$amount" unless $opt->{no_format};
43              
44 0           return $amount;
45             }
46              
47             =head2 * unique( @ary )
48              
49             Removes duplicates (but leaves at least one).
50              
51             =cut
52              
53             sub unique {
54 0     0 1   my (@ary) = @_;
55              
56 0           my %seen;
57             my @unique;
58 0           foreach my $item (@ary) {
59 0 0         push(@unique, $item) unless $seen{$item}++;
60             }
61              
62 0           return @unique;
63             }
64              
65             =head2 * looks_like_number( $scalar )
66              
67             Shamelessly stolen from Scalar::Util 1.10 in order to reduce dependancies.
68             Not part of the normal copyright.
69              
70             =cut
71              
72             sub looks_like_number {
73 0     0 1   local $_ = shift;
74              
75             # checks from perlfaq4
76 0 0         return $] < 5.009002 unless defined;
77 0 0         return 1 if (/^[+-]?\d+$/); # is a +/- integer
78 0 0         return 1
79             if (/^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/); # a C float
80 0 0 0       return 1
      0        
      0        
81             if ($] >= 5.008 and /^(Inf(inity)?|NaN)$/i)
82             or ($] >= 5.006001 and /^Inf$/i);
83              
84 0           0;
85             }
86              
87             =head2 uneval
88              
89             Takes any built-in object and returns the perl representation of it as a string
90             of text. It was copied from Interchange L, written
91             by Mike Heins EFE.
92              
93             =cut
94              
95             sub uneval {
96 0     0 1   my ($self, $o) = @_; # recursive
97 0           my ($r, $s, $key, $value);
98              
99 0           local ($^W) = 0;
100 13     13   91 no warnings; #supress 'use of unitialized values'
  13         30  
  13         3328  
101              
102 0           $r = ref $o;
103 0 0         if (!$r) {
    0          
    0          
104 0           $o =~ s/([\\"\$@])/\\$1/g;
105 0           $s = '"' . $o . '"';
106             }
107             elsif ($r eq 'ARRAY') {
108 0           $s = "[";
109 0           for my $i (0 .. $#$o) {
110 0           $s .= uneval($o->[$i]) . ",";
111             }
112 0           $s .= "]";
113             }
114             elsif ($r eq 'HASH') {
115 0           $s = "{";
116 0           while (($key, $value) = each %$o) {
117 0           $s .= "'$key' => " . uneval($value) . ",";
118             }
119 0           $s .= "}";
120             }
121             else {
122 0           $s = "'something else'";
123             }
124              
125 0           $s;
126             }
127              
128             1;
129              
130             __END__