line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Business::Stripe::WebCheckout;
|
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
# TODO - Pre release
|
4
|
|
|
|
|
|
|
#
|
5
|
|
|
|
|
|
|
# TODO - Post release
|
6
|
|
|
|
|
|
|
#
|
7
|
|
|
|
|
|
|
# 12-04-21 - Improve obtaining success/cancel URLs from environment
|
8
|
|
|
|
|
|
|
# 14-04-21 - Add P&P
|
9
|
|
|
|
|
|
|
# 16-04-21 - Properly implement live testing without real Stripe keys
|
10
|
|
|
|
|
|
|
#
|
11
|
|
|
|
|
|
|
|
12
|
4
|
|
|
4
|
|
368732
|
use HTTP::Tiny;
|
|
4
|
|
|
|
|
154603
|
|
|
4
|
|
|
|
|
152
|
|
13
|
4
|
|
|
4
|
|
2492
|
use JSON::PP;
|
|
4
|
|
|
|
|
49028
|
|
|
4
|
|
|
|
|
287
|
|
14
|
4
|
|
|
4
|
|
2896
|
use Data::Dumper;
|
|
4
|
|
|
|
|
26506
|
|
|
4
|
|
|
|
|
323
|
|
15
|
|
|
|
|
|
|
|
16
|
4
|
|
|
4
|
|
37
|
use strict;
|
|
4
|
|
|
|
|
10
|
|
|
4
|
|
|
|
|
96
|
|
17
|
4
|
|
|
4
|
|
24
|
use warnings;
|
|
4
|
|
|
|
|
8
|
|
|
4
|
|
|
|
|
7553
|
|
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
our $VERSION = '1.0';
|
20
|
|
|
|
|
|
|
$VERSION = eval $VERSION;
|
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
sub new {
|
23
|
5
|
|
|
5
|
1
|
1662
|
my $class = shift;
|
24
|
5
|
|
|
|
|
36
|
my %attrs = @_;
|
25
|
|
|
|
|
|
|
|
26
|
5
|
|
|
|
|
12
|
my @products;
|
27
|
5
|
|
|
|
|
20
|
$attrs{'trolley'} = \@products;
|
28
|
|
|
|
|
|
|
|
29
|
5
|
|
50
|
|
|
47
|
$attrs{'currency'} //= 'GBP';
|
30
|
|
|
|
|
|
|
|
31
|
5
|
|
|
|
|
20
|
$attrs{'error'} = '';
|
32
|
|
|
|
|
|
|
|
33
|
5
|
|
33
|
|
|
17
|
$attrs{'cancel-url'} //= "$ENV{'REQUEST_SCHEME'}://$ENV{'HTTP_HOST'}$ENV{'SCRIPT_NAME'}";
|
34
|
5
|
|
33
|
|
|
17
|
$attrs{'success-url'} //= "$ENV{'REQUEST_SCHEME'}://$ENV{'HTTP_HOST'}$ENV{'SCRIPT_NAME'}";
|
35
|
5
|
50
|
33
|
|
|
33
|
$attrs{'error'} = 'cancel-url and success-url cannot be derived from the environment and need to be provided' unless ($attrs{'cancel-url'} and $attrs{'success-url'});
|
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
# This is changed during testing only
|
38
|
5
|
|
100
|
|
|
30
|
$attrs{'url'} //= 'https://api.stripe.com/v1/checkout/sessions';
|
39
|
|
|
|
|
|
|
|
40
|
5
|
50
|
33
|
|
|
71
|
$attrs{'error'} = 'Public API key provided is not a valid key' if $attrs{'api-public'} and $attrs{'api-public'} !~ /^pk_/;
|
41
|
5
|
50
|
|
|
|
31
|
$attrs{'error'} = 'Secret API key provided is not a valid key' unless $attrs{'api-secret'} =~ /^sk_/;
|
42
|
5
|
50
|
33
|
|
|
30
|
$attrs{'error'} = 'Secret API key provided as Public key' if $attrs{'api-public'} and $attrs{'api-public'} =~ /^sk_/;
|
43
|
5
|
50
|
|
|
|
22
|
$attrs{'error'} = 'Public API key provided as Secret key' if $attrs{'api-secret'} =~ /^pk_/;
|
44
|
5
|
100
|
|
|
|
22
|
$attrs{'error'} = 'Secret API key is too short' unless length $attrs{'api-secret'} > 100;
|
45
|
5
|
50
|
|
|
|
16
|
$attrs{'error'} = 'Secret API key is missing' unless $attrs{'api-secret'};
|
46
|
|
|
|
|
|
|
|
47
|
5
|
|
|
|
|
24
|
return bless \%attrs, $class;
|
48
|
|
|
|
|
|
|
}
|
49
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
sub success {
|
51
|
11
|
|
|
11
|
1
|
1574
|
my $self = shift;
|
52
|
11
|
|
|
|
|
109
|
return !$self->{'error'};
|
53
|
|
|
|
|
|
|
}
|
54
|
|
|
|
|
|
|
|
55
|
|
|
|
|
|
|
sub error {
|
56
|
0
|
|
|
0
|
1
|
0
|
my $self = shift;
|
57
|
0
|
|
|
|
|
0
|
return $self->{'error'};
|
58
|
|
|
|
|
|
|
}
|
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
sub add_product {
|
61
|
4
|
|
|
4
|
1
|
24
|
my ($self, %product) = @_;
|
62
|
4
|
|
|
|
|
11
|
$self->{'error'} = '';
|
63
|
|
|
|
|
|
|
|
64
|
4
|
50
|
33
|
|
|
32
|
unless ($product{'price'} > 0 and $product{'price'} !~ /\./) {
|
65
|
0
|
|
|
|
|
0
|
$self->{'error'} = 'Invalid price. Price is an integer of the lowest currency unit';
|
66
|
0
|
|
|
|
|
0
|
return;
|
67
|
|
|
|
|
|
|
}
|
68
|
4
|
50
|
33
|
|
|
29
|
unless ($product{'qty'} > 0 and $product{'qty'} !~ /\./) {
|
69
|
0
|
|
|
|
|
0
|
$self->{'error'} = 'Invalid qty. Qty is a positive integer';
|
70
|
0
|
|
|
|
|
0
|
return;
|
71
|
|
|
|
|
|
|
}
|
72
|
|
|
|
|
|
|
|
73
|
4
|
50
|
|
|
|
13
|
unless ($product{'name'}) {
|
74
|
0
|
|
|
|
|
0
|
$self->{'error'} = 'No product name supplied';
|
75
|
0
|
|
|
|
|
0
|
return;
|
76
|
|
|
|
|
|
|
}
|
77
|
4
|
|
|
|
|
10
|
$self->{'intent'} = undef;
|
78
|
|
|
|
|
|
|
# Update existing Product by ID
|
79
|
4
|
|
|
|
|
7
|
foreach my $prod(@{$self->{'trolley'}}) {
|
|
4
|
|
|
|
|
14
|
|
80
|
3
|
50
|
|
|
|
10
|
if ($prod->{'id'} eq $product{'id'}) {
|
81
|
0
|
|
|
|
|
0
|
foreach my $field('name', 'description', 'qty', 'price') {
|
82
|
0
|
|
|
|
|
0
|
$prod->{$field} = $product{$field};
|
83
|
|
|
|
|
|
|
}
|
84
|
0
|
|
|
|
|
0
|
return scalar @{$self->{'trolley'}};
|
|
0
|
|
|
|
|
0
|
|
85
|
|
|
|
|
|
|
}
|
86
|
|
|
|
|
|
|
}
|
87
|
|
|
|
|
|
|
|
88
|
4
|
|
|
|
|
7
|
my $new_product;
|
89
|
4
|
|
|
|
|
9
|
foreach my $field('id', 'name', 'description', 'qty', 'price') {
|
90
|
20
|
|
|
|
|
45
|
$new_product->{$field} = $product{$field};
|
91
|
|
|
|
|
|
|
}
|
92
|
4
|
|
|
|
|
7
|
push @{$self->{'trolley'}}, $new_product;
|
|
4
|
|
|
|
|
17
|
|
93
|
|
|
|
|
|
|
}
|
94
|
|
|
|
|
|
|
|
95
|
|
|
|
|
|
|
sub list_products {
|
96
|
21
|
|
|
21
|
1
|
50
|
my $self = shift;
|
97
|
21
|
|
|
|
|
45
|
my @products;
|
98
|
21
|
|
|
|
|
30
|
foreach my $prod(@{$self->{'trolley'}}) {
|
|
21
|
|
|
|
|
55
|
|
99
|
39
|
|
|
|
|
77
|
push @products, $prod->{'id'};
|
100
|
|
|
|
|
|
|
}
|
101
|
21
|
|
|
|
|
94
|
return @products;
|
102
|
|
|
|
|
|
|
}
|
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
sub get_product {
|
105
|
15
|
|
|
15
|
1
|
35
|
my ($self, $id) = @_;
|
106
|
15
|
|
|
|
|
29
|
$self->{'error'} = '';
|
107
|
|
|
|
|
|
|
|
108
|
15
|
50
|
|
|
|
34
|
unless ($id) {
|
109
|
0
|
|
|
|
|
0
|
$self->{'error'} = 'Product ID missing';
|
110
|
0
|
|
|
|
|
0
|
return;
|
111
|
|
|
|
|
|
|
}
|
112
|
|
|
|
|
|
|
|
113
|
15
|
|
|
|
|
27
|
foreach my $prod(@{$self->{'trolley'}}) {
|
|
15
|
|
|
|
|
27
|
|
114
|
30
|
100
|
|
|
|
64
|
if ($prod->{'id'} eq $id) {
|
115
|
15
|
|
|
|
|
116
|
return $prod;
|
116
|
|
|
|
|
|
|
}
|
117
|
|
|
|
|
|
|
}
|
118
|
0
|
|
|
|
|
0
|
$self->{'error'} = "Product ID $id not found";
|
119
|
|
|
|
|
|
|
}
|
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
sub delete_product {
|
122
|
3
|
|
|
3
|
1
|
10
|
my ($self, $id) = @_;
|
123
|
3
|
|
|
|
|
8
|
$self->{'error'} = '';
|
124
|
|
|
|
|
|
|
|
125
|
3
|
50
|
|
|
|
13
|
unless ($id) {
|
126
|
0
|
|
|
|
|
0
|
$self->{'error'} = 'Product ID missing';
|
127
|
0
|
|
|
|
|
0
|
return;
|
128
|
|
|
|
|
|
|
}
|
129
|
|
|
|
|
|
|
|
130
|
3
|
|
|
|
|
8
|
for (my $i = 0; $i < scalar @{$self->{'trolley'}}; $i++) {
|
|
6
|
|
|
|
|
20
|
|
131
|
5
|
100
|
|
|
|
8
|
if (${$self->{'trolley'}}[$i]->{'id'} eq $id) {
|
|
5
|
|
|
|
|
16
|
|
132
|
2
|
|
|
|
|
5
|
$self->{'intent'} = undef;
|
133
|
2
|
|
|
|
|
4
|
splice @{$self->{'trolley'}}, $i, 1;
|
|
2
|
|
|
|
|
6
|
|
134
|
2
|
|
|
|
|
5
|
return scalar @{$self->{'trolley'}};
|
|
2
|
|
|
|
|
6
|
|
135
|
|
|
|
|
|
|
}
|
136
|
|
|
|
|
|
|
}
|
137
|
1
|
|
|
|
|
8
|
$self->{'error'} = "Product ID $id not found";
|
138
|
|
|
|
|
|
|
}
|
139
|
|
|
|
|
|
|
|
140
|
|
|
|
|
|
|
# Private method called internally by get_intent and get_intent_id
|
141
|
|
|
|
|
|
|
# Attempts to obtain a new session intent from Stripe
|
142
|
|
|
|
|
|
|
# Returns existing session if it exists and Trolley hasn't changed
|
143
|
|
|
|
|
|
|
sub _create_intent {
|
144
|
4
|
|
|
4
|
|
12
|
my $self = shift;
|
145
|
|
|
|
|
|
|
|
146
|
4
|
50
|
|
|
|
20
|
if ($self->{'intent'}) {
|
147
|
0
|
|
|
|
|
0
|
return $self->{'intent'};
|
148
|
|
|
|
|
|
|
}
|
149
|
|
|
|
|
|
|
|
150
|
4
|
|
100
|
|
|
17
|
$self->{'reference'} //= __PACKAGE__;
|
151
|
|
|
|
|
|
|
|
152
|
4
|
|
|
|
|
35
|
my $http = HTTP::Tiny->new;
|
153
|
|
|
|
|
|
|
my $headers = {
|
154
|
4
|
|
|
|
|
657
|
'Authorization' => 'Bearer ' . $self->{'api-secret'},
|
155
|
|
|
|
|
|
|
};
|
156
|
|
|
|
|
|
|
|
157
|
|
|
|
|
|
|
# Update URL and headers during stripe-live tests
|
158
|
4
|
50
|
|
|
|
25
|
if ($self->{'url'} =~ /^https:\/\/www\.boddison\.com/) {
|
159
|
0
|
|
|
|
|
0
|
$headers->{'BODTEST'} = __PACKAGE__ . " v$VERSION";
|
160
|
|
|
|
|
|
|
$headers->{'Authorization'} = undef,
|
161
|
0
|
0
|
|
|
|
0
|
$self->{'url'} .= '?fail' if $self->{'api-test-fail'};
|
162
|
|
|
|
|
|
|
}
|
163
|
|
|
|
|
|
|
|
164
|
4
|
|
|
|
|
19
|
my $vars = {
|
165
|
|
|
|
|
|
|
'headers' => $headers,
|
166
|
|
|
|
|
|
|
'agent' => 'Perl-WebCheckout/$VERSION'
|
167
|
|
|
|
|
|
|
};
|
168
|
|
|
|
|
|
|
my $payload = {
|
169
|
|
|
|
|
|
|
'cancel_url' => $self->{'cancel-url'},
|
170
|
|
|
|
|
|
|
'success_url' => $self->{'success-url'},
|
171
|
|
|
|
|
|
|
'payment_method_types[0]' => 'card',
|
172
|
|
|
|
|
|
|
'mode' => 'payment',
|
173
|
4
|
|
|
|
|
34
|
'client_reference_id' => $self->{'reference'},
|
174
|
|
|
|
|
|
|
};
|
175
|
4
|
50
|
|
|
|
14
|
$payload->{'customer_email'} = $self->{'email'} if $self->{'email'};
|
176
|
|
|
|
|
|
|
|
177
|
4
|
|
|
|
|
10
|
my $i = 0;
|
178
|
4
|
|
|
|
|
11
|
foreach my $prod(@{$self->{'trolley'}}) {
|
|
4
|
|
|
|
|
21
|
|
179
|
0
|
|
|
|
|
0
|
$payload->{"line_items[$i][currency]"} = $self->{'currency'};
|
180
|
0
|
|
|
|
|
0
|
$payload->{"line_items[$i][name]"} = $prod->{'name'};
|
181
|
0
|
0
|
|
|
|
0
|
$payload->{"line_items[$i][description]"} = $prod->{'description'} if $prod->{'description'};
|
182
|
0
|
|
|
|
|
0
|
$payload->{"line_items[$i][quantity]"} = $prod->{'qty'};
|
183
|
0
|
|
|
|
|
0
|
$payload->{"line_items[$i][amount]"} = $prod->{'price'};
|
184
|
0
|
|
|
|
|
0
|
$i++;
|
185
|
|
|
|
|
|
|
}
|
186
|
|
|
|
|
|
|
|
187
|
4
|
|
|
|
|
25
|
my $response = $http->post_form($self->{'url'}, $payload, $vars);
|
188
|
|
|
|
|
|
|
|
189
|
4
|
|
|
|
|
549586
|
$self->{'error'} = '';
|
190
|
4
|
50
|
|
|
|
26
|
if ($response->{'success'}) {
|
191
|
0
|
|
|
|
|
0
|
$self->{'intent'} = $response->{'content'};
|
192
|
|
|
|
|
|
|
} else {
|
193
|
4
|
|
|
|
|
14
|
my $content = $response->{'content'};
|
194
|
4
|
|
|
|
|
13
|
eval {
|
195
|
4
|
|
|
|
|
35
|
$content = decode_json($response->{'content'});
|
196
|
|
|
|
|
|
|
};
|
197
|
4
|
50
|
|
|
|
8608
|
if ($@) {
|
198
|
0
|
|
|
|
|
0
|
$self->{'error'} = $content;
|
199
|
|
|
|
|
|
|
} else {
|
200
|
4
|
|
|
|
|
131
|
$self->{'error'} = $content->{'error'}->{'message'};
|
201
|
|
|
|
|
|
|
}
|
202
|
|
|
|
|
|
|
}
|
203
|
|
|
|
|
|
|
}
|
204
|
|
|
|
|
|
|
|
205
|
|
|
|
|
|
|
sub get_intent {
|
206
|
1
|
|
|
1
|
1
|
8
|
my ($self, %attrs) = @_;
|
207
|
|
|
|
|
|
|
|
208
|
1
|
50
|
|
|
|
11
|
$self->{'reference'} = $attrs{'reference'} if $attrs{'reference'};
|
209
|
1
|
50
|
|
|
|
8
|
$self->{'email'} = $attrs{'email'} if $attrs{'email'};
|
210
|
|
|
|
|
|
|
|
211
|
1
|
|
|
|
|
6
|
$self->{'error'} = '';
|
212
|
1
|
|
|
|
|
7
|
return $self->_create_intent;
|
213
|
|
|
|
|
|
|
}
|
214
|
|
|
|
|
|
|
|
215
|
|
|
|
|
|
|
sub get_intent_id {
|
216
|
3
|
|
|
3
|
1
|
12
|
my ($self, %attrs) = @_;
|
217
|
|
|
|
|
|
|
|
218
|
3
|
50
|
|
|
|
18
|
$self->{'reference'} = $attrs{'reference'} if $attrs{'reference'};
|
219
|
3
|
50
|
|
|
|
18
|
$self->{'email'} = $attrs{'email'} if $attrs{'email'};
|
220
|
|
|
|
|
|
|
|
221
|
3
|
|
|
|
|
9
|
$self->{'error'} = '';
|
222
|
3
|
|
|
|
|
14
|
my $intent = $self->_create_intent;
|
223
|
3
|
50
|
|
|
|
1616
|
if ($self->{'error'}) {
|
224
|
3
|
|
|
|
|
30
|
return $intent;
|
225
|
|
|
|
|
|
|
} else {
|
226
|
0
|
|
|
|
|
0
|
return decode_json($intent)->{'id'};
|
227
|
|
|
|
|
|
|
}
|
228
|
|
|
|
|
|
|
}
|
229
|
|
|
|
|
|
|
|
230
|
|
|
|
|
|
|
sub get_ids {
|
231
|
2
|
|
|
2
|
1
|
9
|
my ($self, %attrs) = @_;
|
232
|
|
|
|
|
|
|
|
233
|
2
|
50
|
|
|
|
17
|
$self->{'public-key'} = $attrs{'public-key'} if $attrs{'public-key'};
|
234
|
|
|
|
|
|
|
|
235
|
2
|
|
|
|
|
10
|
$self->{'error'} = '';
|
236
|
2
|
50
|
|
|
|
9
|
unless ($self->{'api-public'}) {
|
237
|
0
|
|
|
|
|
0
|
$self->{'error'} = 'Required Public API Key missing';
|
238
|
0
|
|
|
|
|
0
|
return;
|
239
|
|
|
|
|
|
|
}
|
240
|
|
|
|
|
|
|
|
241
|
2
|
50
|
|
|
|
7
|
$self->{'reference'} = $attrs{'reference'} if $attrs{'reference'};
|
242
|
2
|
50
|
|
|
|
8
|
$self->{'email'} = $attrs{'email'} if $attrs{'email'};
|
243
|
|
|
|
|
|
|
|
244
|
2
|
|
|
|
|
9
|
my $intent_id = $self->get_intent_id;
|
245
|
|
|
|
|
|
|
|
246
|
2
|
|
|
|
|
8
|
my %result;
|
247
|
2
|
50
|
|
|
|
8
|
if ($self->{'error'}) {
|
248
|
2
|
|
|
|
|
8
|
$result{'status'} = 'error';
|
249
|
2
|
|
|
|
|
7
|
$result{'message'} = $self->{'error'};
|
250
|
|
|
|
|
|
|
} else {
|
251
|
0
|
|
|
|
|
0
|
$result{'status'} = 'success';
|
252
|
0
|
|
|
|
|
0
|
$result{'api-key'} = $self->{'api-public'};
|
253
|
0
|
|
|
|
|
0
|
$result{'session'} = $intent_id;
|
254
|
|
|
|
|
|
|
}
|
255
|
|
|
|
|
|
|
|
256
|
2
|
100
|
|
|
|
11
|
$attrs{'format'} = 'text' unless $attrs{'format'};
|
257
|
2
|
50
|
|
|
|
16
|
return encode_json(\%result) if lc($attrs{'format'}) eq 'json';
|
258
|
2
|
|
33
|
|
|
14
|
return $result{'message'} || "$result{'api-key'}:$result{'session'}";
|
259
|
|
|
|
|
|
|
}
|
260
|
|
|
|
|
|
|
|
261
|
|
|
|
|
|
|
sub checkout {
|
262
|
1
|
|
|
1
|
1
|
3
|
my $self = shift;
|
263
|
|
|
|
|
|
|
|
264
|
1
|
|
|
|
|
6
|
my $data = $self->get_ids( 'format' => 'text', @_);
|
265
|
|
|
|
|
|
|
|
266
|
1
|
50
|
|
|
|
9
|
return if $self->{'error'};
|
267
|
|
|
|
|
|
|
|
268
|
0
|
|
|
|
|
|
my ($key, $session) = split /:/, $data;
|
269
|
|
|
|
|
|
|
|
270
|
0
|
0
|
0
|
|
|
|
unless ($key and $session) {
|
271
|
0
|
|
|
|
|
|
$self->{'error'} = 'Error getting key and session';
|
272
|
0
|
|
|
|
|
|
return;
|
273
|
|
|
|
|
|
|
}
|
274
|
|
|
|
|
|
|
|
275
|
0
|
|
|
|
|
|
return <<"END_HTML";
|
276
|
|
|
|
|
|
|
Content-type: text/html
|
277
|
|
|
|
|
|
|
|
278
|
|
|
|
|
|
|
|
279
|
|
|
|
|
|
|
|
280
|
|
|
|
|
|
|
|
281
|
|
|
|
|
|
|
|
288
|
|
|
|
|
|
|
|
289
|
|
|
|
|
|
|
|
290
|
|
|
|
|
|
|
END_HTML
|
291
|
|
|
|
|
|
|
|
292
|
|
|
|
|
|
|
}
|
293
|
|
|
|
|
|
|
|
294
|
|
|
|
|
|
|
1;
|
295
|
|
|
|
|
|
|
|
296
|
|
|
|
|
|
|
__END__
|