File Coverage

blib/lib/Object/GMP.pm
Criterion Covered Total %
statement 41 49 83.6
branch 9 16 56.2
condition 6 11 54.5
subroutine 8 10 80.0
pod 0 5 0.0
total 64 91 70.3


line stmt bran cond sub pod time code
1             package Object::GMP;
2             $Object::GMP::VERSION = '0.005';
3             =head1 NAME
4              
5             Object::GMP - Moo Role for any object has GMP field
6              
7             =head2 USAGE
8              
9             This module is a moo role
10              
11             =head3 Example
12              
13             package Foo;
14             use Moo;
15             with "Object::GMP";
16             has a => ( is => 'ro' );
17             has b => ( is => 'ro' );
18             has prime => ( is => 'rw' );
19             around BUILDARGS => __PACKAGE__->BUILDARGS_val2gmp('prime');
20             1;
21              
22             The above exmaple to declare the field 'prime' is a GMP value.
23              
24             my $prime =
25             '0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEFFFFFC2F';
26             my $foo = Foo->new( a => 0, b => 7, prime => $prime );
27             isnt( ref( $foo->a ), undef, 'a is not gmp' );
28             isnt( ref( $foo->b ), undef, 'b is not gmp' );
29             isa_ok( $foo->prime, 'Math::BigInt', 'prime is gmp' );
30              
31             So when you create an object, a and b will be normal value
32             and prime will be a GMP value.
33              
34             =head1 LINKS
35              
36             B: L
37              
38             B: L
39              
40             =cut
41              
42 2     2   11239 use Moo::Role;
  2         17334  
  2         10  
43 2     2   2144 use JSON::XS;
  2         6241  
  2         107  
44 2     2   2378 use Math::BigInt lib => 'GMP';
  2         55802  
  2         13  
45              
46             my %GMP_FIELDS = ();
47              
48             sub BUILDARGS_val2gmp {
49 1     1 0 23203 my ($class, @fields) = @_;
50              
51 1         3 map { $GMP_FIELDS{$_} = 1 } @fields;
  1         5  
52              
53             return sub {
54 2     2   3722 my ($orig, $class, %args) = @_;
55              
56 2         6 foreach my $key(@fields) {
57 2         9 $args{$key} = $class->val2gmp($args{$key});
58             }
59              
60 2         1381 return $class->$orig(%args);
61             }
62 1         9 }
63              
64             sub val2gmp {
65 2     2 0 5 my ($class, $val) = @_;
66 2 50       7 return $val if !defined $val;
67 2 100       14 return $val if UNIVERSAL::isa($val, 'Math::BigInt');
68 1         6 return Math::BigInt->from_hex($val);
69             }
70              
71             sub copy {
72 1     1 0 1441 my ($self, %args) = @_;
73              
74 1         3 my %new_me = ();
75              
76 1         8 while (my ($key, $val) = each %$self) {
77 3   66     42 $new_me{$key} = $args{$key} // $val;
78              
79 3 100 66     45 if ($GMP_FIELDS{$key} && defined $new_me{$key}) {
80 1         4 $new_me{$key} = $new_me{$key}->copy;
81             }
82             }
83              
84 1         29 return ref($self)->new(%new_me);
85             }
86              
87             sub hashref {
88 3     3 0 336 my ($self, %options) = @_;
89              
90 3         6 my %hash;
91              
92 3   100     5 my %keep = map { $_ => 1 } @{$options{keep} // []};
  1         4  
  3         31  
93              
94 3         14 while (my ($key, $val) = each %$self) {
95 9 100       80 if ($GMP_FIELDS{$key}) {
96 3 100       25 if ($keep{$key}) {
97 1         4 $hash{$key} = "$val";
98             }
99             else {
100 2         14 $hash{$key} = uc $val->as_hex;
101 2         2252 $hash{$key} =~ s/^([\-\+]?0)X/${1}x/;
102             }
103             }
104             else {
105 6         17 $hash{$key} = $val;
106             }
107             }
108              
109 3         25 return \%hash;
110             }
111              
112             sub to_json {
113 0     0 0   my ($self, %options) = @_;
114 0           return JSON::XS->new->pretty->encode($self->hashref(%options));
115             }
116              
117             sub _debug {
118 0     0     my ($self, $pre_note, %options) = @_;
119 0 0         return if !$ENV{DEBUG};
120 0 0 0       return if $ENV{ONLY_SHOW} && $pre_note !~/$ENV{ONLY_SHOW}/;
121 0 0         print "$pre_note: " if $pre_note;
122 0           print $self->to_json(%options);
123 0           print "\n";
124             }
125              
126             1;