File Coverage

blib/lib/WebService/MyJSONs.pm
Criterion Covered Total %
statement 26 133 19.5
branch 0 42 0.0
condition 0 9 0.0
subroutine 9 24 37.5
pod 11 11 100.0
total 46 219 21.0


line stmt bran cond sub pod time code
1             #!/usr/bin/env perl
2             package WebService::MyJSONs;
3 1     1   1788 use 5.024000;
  1         4  
4 1     1   5 use warnings;
  1         2  
  1         29  
5 1     1   545 use experimental qw< signatures >;
  1         3505  
  1         5  
6 1     1   161 no warnings qw< experimental::signatures >;
  1         2  
  1         76  
7             { our $VERSION = '0.001' }
8              
9 1     1   6 use Carp qw< croak >;
  1         2  
  1         42  
10 1     1   780 use HTTP::Tiny;
  1         47847  
  1         45  
11 1     1   9 use Scalar::Util 'blessed';
  1         2  
  1         54  
12 1     1   6 use Exporter 'import';
  1         2  
  1         169  
13              
14             our @EXPORT_OK = map { +"myjsons_$_" }
15             qw< cmdline get get_json put put_json >;
16             our %EXPORT_TAGS = (all => [@EXPORT_OK]);
17             our $DEFAULT_ENDPOINT = 'https://www.myjsons.com';
18              
19 0     0 1   sub code ($self, @new) {
  0            
  0            
  0            
20 0 0         $self->{code} = $new[0] if @new > 0;
21 0           return $self->{code};
22             }
23              
24 0     0     sub __dump ($d) {
  0            
  0            
25 0           require Data::Dumper;
26 1     1   6 no warnings 'once';
  1         2  
  1         1391  
27 0           local $Data::Dumper::Indent = 1;
28 0           print {*STDERR} Dumper($d);
  0            
29             } ## end sub __dump
30              
31 0     0 1   sub get ($self, $code = undef) {
  0            
  0            
  0            
32 0           require JSON::PP;
33 0           return JSON::PP::decode_data($self->get_json($code));
34             }
35              
36 0     0 1   sub get_json ($self, $code = undef) {
  0            
  0            
  0            
37 0 0         $self = $self->new unless blessed $self;
38 0   0       $code //= $self->code;
39 0 0         croak "no code set for retrieval" unless defined $code;
40              
41 0           my $response = HTTP::Tiny->new->get($self->_url(v => $code));
42 0 0         $self->{response_callback}->($response) if $self->{response_callback};
43 0 0         __dump($response) if $ENV{MYJSONS_DUMP_RESPONSE};
44              
45             croak "Failed: $response->{status} $response->{reason}"
46 0 0         unless $response->{success};
47 0           return $response->{content};
48             } ## end sub get_json
49              
50 0     0 1   sub myjsons_cmdline ($op = 'help', $code = undef) {
  0            
  0            
  0            
51 0     0     my $p2u = sub ($message = undef) {
  0            
  0            
52 0           require Pod::Usage;
53 0 0         Pod::Usage::pod2usage(
54             -input => __FILE__,
55             -verbose => 99,
56             -sections => 'NAME|SYNOPSIS',
57             (defined $message ? (-message => $message) : ()),
58             );
59 0           };
60 0 0         $p2u->() if $op =~ m{\A(?: -h | --help | help )\z}imxs;
61              
62 0 0         if ($op eq 'get') {
    0          
63 0 0         $p2u->('undefined code for operation') unless defined $code;
64 0           print {*STDOUT} __new($code)->get_json;
  0            
65             }
66             elsif ($op eq 'put') {
67 0           my $json = do { local $/; };
  0            
  0            
68 0           print {*STDOUT} __new($code)->put_json($json)->code;
  0            
69             }
70             else {
71 0           $p2u->('invalid operation');
72             }
73              
74 0           return 0;
75             } ## end if (!caller)
76              
77 0     0 1   sub myjsons_get ($code) { __new($code)->get }
  0            
  0            
  0            
78 0     0 1   sub myjsons_get_json ($code) { __new($code)->get_json }
  0            
  0            
  0            
79              
80 0     0 1   sub myjsons_put (@args) {
  0            
  0            
81 0 0         my ($code, $data) = @args == 1 ? (undef, $args[0]) : @args[0, 1];
82 0           return __new($code)->put($data)->code;
83             }
84              
85 0     0 1   sub myjsons_put_json (@args) {
  0            
  0            
86 0 0         my ($code, $json) = @args == 1 ? (undef, $args[0]) : @args[0, 1];
87 0           return __new($code)->put_json($json)->code;
88             }
89              
90 0     0 1   sub new ($package, %args) {
  0            
  0            
  0            
91             my $self = bless {
92             code => $args{code},
93             endpoint => ($args{endpoint} // $DEFAULT_ENDPOINT),
94             response_callback => $args{response_callback},
95 0   0       }, $package;
96 0           return $self;
97             } ## end sub new
98              
99 0     0     sub __new ($code) { __PACKAGE__->new(code => $code) }
  0            
  0            
  0            
100              
101 0     0 1   sub put ($self, @args) {
  0            
  0            
  0            
102 0           require JSON::PP;
103 0 0         my ($code, $data) = @args == 1 ? (undef, $args[0]) : @args[0, 1];
104 0           return $self->put_json($code, JSON::PP::encode_json($data));
105             }
106              
107 0     0 1   sub put_json ($self, @args) {
  0            
  0            
  0            
108 0 0         $self = __PACKAGE__->new unless blessed $self;
109 0 0         my ($code, $json) = @args == 1 ? (undef, $args[0]) : @args[0, 1];
110 0   0       $code //= $self->{code};
111              
112 0 0         my $url = $self->_url(defined($code) ? (e => $code) : ());
113 0           my $response = HTTP::Tiny->new->post_form($url, {json => $json});
114 0 0         $self->{response_callback}->($response) if $self->{response_callback};
115 0 0         __dump($response) if $ENV{MYJSONS_DUMP_RESPONSE};
116              
117             croak "Failed: $response->{status} $response->{reason}"
118 0 0         unless $response->{status} == 302;
119              
120 0 0         $self->code($response->{headers}{location} =~ m{/([^/]+)\s*\z}mxs)
121             unless defined $code;
122 0           return $self;
123             } ## end sub put_json
124              
125 0     0     sub _url ($s, @pts) { join '/', ($s->{endpoint} =~ s{/+\z}{}rmxs), @pts }
  0            
  0            
  0            
  0            
126              
127             exit myjsons_cmdline(@ARGV) unless caller;
128              
129             1;
130             __END__