File Coverage

blib/lib/Math/Base/Convert/Bases.pm
Criterion Covered Total %
statement 30 38 78.9
branch 8 8 100.0
condition 16 22 72.7
subroutine 22 24 91.6
pod 0 21 0.0
total 76 113 67.2


line stmt bran cond sub pod time code
1             #!/usr/bin/perl
2              
3             package Math::Base::Convert::Bases;
4              
5             $VERSION = 0.03;
6              
7             package Math::Base::Convert; # into the main package
8              
9             @BASES = qw( bin dna DNA oct dec hex HEX b62 b64 m64 iru url rex id0 id1 xnt xid b85 ascii );
10              
11             $signedBase = 16; # largest allowable known signed base
12              
13             my $package = __PACKAGE__;
14             my $packageLen = length __PACKAGE__;
15              
16             sub _class {
17 0     0   0 (my $class = (caller(1))[3]) =~ s/([^:]+)$/_bs::$1/;
18 0         0 $class;
19             }
20              
21             my $callname = __PACKAGE__ . '::_bs::';
22              
23             # return a pointer to a sub for the array blessed into Package::sub::name
24             #
25              
26             my $_bin = bless ['0', '1'], $callname . 'bin';
27             my $_dna = bless [qw( a c t g )], $callname . 'dna';
28             my $_DNA = bless [qw( A C T G )], $callname . 'DNA';
29             my $_ocT = bless ['0'..'7'], $callname . 'ocT';
30             my $_dec = bless ['0'..'9'], $callname . 'dec';
31             my $_heX = bless ['0'..'9', 'a'..'f'], $callname . 'heX';
32             my $_HEX = bless ['0'..'9', 'A'..'F'], $callname . 'HEX';
33             my $_b62 = bless ['0'..'9', 'a'..'z', 'A'..'Z'], $callname . 'b62';
34             my $_b64 = bless ['0'..'9', 'A'..'Z', 'a'..'z', '.', '_'], $callname . 'b64';
35             my $_m64 = bless ['A'..'Z', 'a'..'z', '0'..'9', '+', '/'], $callname . 'm64';
36             my $_iru = bless ['A'..'Z', 'a'..'z', '0'..'9', '[', ']'], $callname . 'iru';
37             my $_url = bless ['A'..'Z', 'a'..'z', '0'..'9', '*', '-'], $callname . 'url';
38             my $_rex = bless ['A'..'Z', 'a'..'z', '0'..'9', '!', '-'], $callname . 'rex';
39             my $_id0 = bless ['A'..'Z', 'a'..'z', '0'..'9', '_', '-'], $callname . 'id0';
40             my $_id1 = bless ['A'..'Z', 'a'..'z', '0'..'9', '.', '_'], $callname . 'id1';
41             my $_xnt = bless ['A'..'Z', 'a'..'z', '0'..'9', '.', '-'], $callname . 'xnt';
42             my $_xid = bless ['A'..'Z', 'a'..'z', '0'..'9', '_', ':'], $callname . 'xid';
43             my $_b85 = bless ['0'..'9', 'A'..'Z', 'a'..'z', '!', '#', # RFC 1924 for IPv6 addresses, might need to return Math::BigInt objs
44             '$', '%', '&', '(', ')', '*', '+', '-', ';', '<', '=', '>', '?', '@', '^', '_', '`', '{', '|', '}', '~'], $callname . 'b85';
45              
46             my $_ascii = bless [
47             ' ','!','"','#','$','%','&',"'",'(',')','*','+',',','-','.','/',
48             '0','1','2','3','4','5','6','7','8','9',
49             ':',';','<','=','>','?','@',
50             'A','B','C','D','E','F','G','H','I','J','K','L','M',
51             'N','O','P','Q','R','S','T','U','V','W','X','Y','Z',
52             '[','\\',']','^','_','`',
53             'a','b','c','d','e','f','g','h','i','j','k','l','m',
54             'n','o','p','q','r','s','t','u','v','w','x','y','z',
55             '{','|','}','~'], $callname . 'ascii'; # 7 bit printable ascii, base 96
56              
57             #my $_ebcdic = bless [qw
58             # ( 0 1 2 3 37 2D 2E 2F 16 5 25 0B 0C 0D 0E 0F 10 11 12 13 3C 3D 32 26 18 19 3F 27 1C 1D 1E 1F
59             # 40 4F 7F 7B 5B 6C 50 7D 4D 5D 5C 4E 6B 60 4B 61 F0 F1 F2 F3 F4 F5 F6 F7 F8 F9 7A 5E 4C 7E 6E 6F
60             # 7C C1 C2 C3 C4 C5 C6 C7 C8 C9 D1 D2 D3 D4 D5 D6 D7 D8 D9 E2 E3 E4 E5 E6 E7 E8 E9 4A E0 5A 5F 6D
61             # 79 81 82 83 84 85 86 87 88 89 91 92 93 94 95 96 97 98 99 A2 A3 A4 A5 A6 A7 A8 A9 C0 6A D0 A1 7
62             # 20 21 22 23 24 15 6 17 28 29 2A 2B 2C 9 0A 1B 30 31 1A 33 34 35 36 8 38 39 3A 3B 4 14 3E E1 41
63             # 42 43 44 45 46 47 48 49 51 52 53 54 55 56 57 58 59 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76
64             # 77 78 80 8A 8B 8C 8D 8E 8F 90 9A 9B 9C 9D 9E 9F A0 AA AB AC AD AE AF B0 B1 B2 B3 B4 B5 B6 B7 B8
65             # B9 BA BB BC BD BE BF CA CB CC CD CE CF DA DB DC DD DE DF EA EB EC ED EE EF FA FB FC FD FE FF)], $callname . 'ebcdic';
66              
67 845     845 0 58591 sub bin { $_bin }
68 1123     1123 0 68051 sub dna { $_dna }
69 1141     1141 0 70769 sub DNA { $_DNA }
70 1065     1065 0 3294 sub ocT { $_ocT }
71 1158     1158 0 80252 sub dec { $_dec }
72 1500     1500 0 4485 sub heX { $_heX }
73 1064     1064 0 68599 sub HEX { $_HEX }
74 928     928 0 72146 sub b62 { $_b62 }
75 929     929 0 68912 sub b64 { $_b64 }
76 1107     1107 0 71767 sub m64 { $_m64 }
77 3     3 0 237 sub iru { $_iru }
78 3     3 0 180 sub url { $_url }
79 3     3 0 179 sub rex { $_rex }
80 3     3 0 176 sub id0 { $_id0 }
81 3     3 0 173 sub id1 { $_id1 }
82 3     3 0 175 sub xnt { $_xnt }
83 3     3 0 172 sub xid { $_xid }
84 17     17 0 1118 sub b85 { $_b85 }
85 1     1 0 46 sub ascii { $_ascii }
86             #sub ebcdic { $_ebcdic }
87              
88             # Since we're not using BIcalc, the last test can be eliminated...
89             ################### special treatment for override 'hex' ##################################
90              
91             sub hex {
92             # unless our package and is a BC ref and not a BI number (which is an ARRAY)
93 1071 100 66 1071 0 111259 unless (ref($_[0]) && $package eq substr(ref($_[0]),0,$packageLen) && (local *glob = $_[0]) && *glob{HASH}) {
      66        
      50        
94             # $package, $filename, $line, $subroutine, $hasargs
95             # 0 1 2 3 4
96             # if defined and hasargs
97 1069 100 100     6957 if ( defined $_[0] && (caller(0))[4] ) {
98 4         13 return CORE::hex $_[0];
99             }
100             }
101 1067         2723 return heX();
102             }
103              
104             ################### special treatment for override 'oct' #################################
105             sub oct {
106             # unless our package and is a BC ref and not a BI number (which is an ARRAY)
107 835 100 66 835 0 77343 unless (ref($_[0]) && $package eq substr(ref($_[0]),0,$packageLen) && (local *glob = $_[0]) && *glob{HASH}) {
      66        
      50        
108             # $package, $filename, $line, $subroutine, $hasargs
109             # 0 1 2 3 4
110             # if defined and hasargs
111 833 100 100     5268 if ( defined $_[0] && (caller(0))[4] ) {
112 4         11 return CORE::oct $_[0];
113             }
114             }
115 831         1996 return ocT();
116             }
117              
118             ################################## REMOVE ABOVE CODE ###################
119              
120             # return a hash of all base pointers
121             #
122             sub _bases {
123 20     20   97 no strict;
  20         32  
  20         2768  
124 0     0     my %bases;
125 0           foreach (@BASES) {
126 0           my $base = $_->();
127 0           ref($base) =~ /([^:]+)$/;
128 0           $bases{$1} = $base;
129             }
130 0           \%bases;
131             }
132             1;
133              
134             __END__