File Coverage

File:lib/WWW/OpenAPI/Embedded.pm
Coverage:75.4%

linestmtbrancondsubpodtimecode
1package WWW::OpenAPI::Embedded;
2
3
22
22
22
22
182
63
189
use strict;
4
22
22
22
22
238
64
282
use warnings;
5
6#use Smart::Comments;
7
22
22
22
22
226
68
247
use Carp;
8
22
22
22
22
278
125
340
use Params::Util qw( _HASH0 );
9
22
22
22
22
369
99
326
use OpenAPI::Dispatcher;
10
22
22
22
22
254
69
340
use Data::Dumper;
11
22
22
22
22
323
94
271
use Class::Prototyped;
12
22
22
22
22
341
96
377
use HTTP::Request;
13
22
22
22
22
315
89
406
use HTTP::Response;
14
22
22
22
22
252
72
333
use CGI;
15
22
22
22
22
250
74
284
use Test::Base;
16
22
22
22
22
22
22
22
22
22
22
22
22
254
62
197
231
66
196
234
74
286
use Encode qw(encode is_utf8);
17
18our $Buffer;
19our %Cookies;
20
21
16
16
43
*Test::Base::Handle::BINMODE = sub {};
22
23sub new {
24    ### @_
25
22
50
22
0
219
    my $class = ref $_[0] ? ref shift : shift;
26
22
50
180
    my $params = _HASH0(shift @_) or croak "Invalid params";
27    ### $params
28
22
50
237
    my $server = delete $params->{server} or
29        croak "No server specified.";
30
22
148
    my $timer = delete $params->{timer};
31
22
198
    OpenAPI::Dispatcher->init;
32
22
236
    tie_output(*STDOUT, $Buffer);
33
22
826
    bless {
34        server => $server,
35        timer => $timer,
36    }, $class;
37}
38
39sub content_type {
40
602
602
0
5341
    $_[0]->{content_type} = $_[1];
41}
42
43sub login {
44
0
0
0
0
    my ($self, $user, $password) = @_;
45
0
0
    $self->get("/=/login/$user/$password");
46}
47
48sub get {
49
0
0
0
0
    my $self = shift;
50
0
0
    $self->request(undef, 'GET', @_);
51}
52
53sub post {
54
0
0
0
0
    my $self = shift;
55
0
0
    my $content = shift;
56
0
0
    $self->request($content, 'POST', @_);
57}
58
59sub put {
60
0
0
0
0
    my $self = shift;
61
0
0
    my $content = shift;
62
0
0
    $self->request($content, 'PUT', @_);
63}
64
65sub delete {
66
0
0
0
0
    my $self = shift;
67
0
0
    $self->request(undef, 'DELETE', @_);
68}
69
70sub request {
71
602
602
0
4882
    my ($self, $content, $method, $url, $params) = @_;
72
602
50
33
5469
    !defined $params or _HASH0($params) or
73        die "Params must be a hash: ", Dumper($params), "\n";
74
602
50
33
4240
    if ($params && %$params) {
75
0
0
0
        if ($url =~ /\?/) {
76
0
0
            die "? not allowed when params specified.\n";
77        } else {
78
0
0
            my @params;
79
0
0
            while (my ($key, $val) = each %$params) {
80
0
0
                push @params, "$key=$val";
81            }
82
0
0
            $url .= "?" . join '&', @params;
83        }
84    }
85
602
3339
    my $type = $self->{content_type};
86
602
50
3794
    $type ||= 'text/plain';
87
602
50
5549
    if ($url !~ /^http:\/\//) {
88
0
0
        $url = $self->{server} . $url;
89    }
90
602
5663
    my $req = HTTP::Request->new($method);
91
602
140962
    $req->header('Content-Type' => $type);
92
602
119613
    $req->header('Accept', '*/*');
93
602
113130
    $req->url($url);
94
602
100
100
100
166169
    if ($content) {
95
216
50
33
3836
        if ($method eq 'GET' or $method eq 'HEAD') {
96
0
0
            die "HTTP 1.0/1.1 $method request should not have content: $content\n";
97        }
98
99
216
2141
        $req->content($content);
100    } elsif ($method eq 'POST' or $method eq 'PUT') {
101
3
28
        $req->header('Content-Length' => 0);
102    }
103
602
19492
    my $timer = $self->{timer};
104
602
50
6839
    $timer->start($method) if $timer;
105
602
56281
    my $res = _request($req);
106    #my $res = $ua->request($req);
107
602
50
24273
    $timer->stop($method) if $timer;
108
602
1877
    return $res;
109}
110
111sub _request {
112
602
602
3593
    my ($req) = @_;
113
114
602
3671
    my $http_meth = $req->method;
115
602
29054
    $ENV{REQUEST_METHOD} = $req->method;
116
117
602
32583
    my $uri = $req->uri;
118    #$uri =~ s/ /\%20/g;
119
602
1549
    $uri =~ s/^http:\/\/[^\/]+//;
120
602
9597
    $ENV{REQUEST_URI} = $uri;
121
122
602
100
6473
    if (%Cookies) {
123
563
3296
        my @vals;
124
563
6641
        while (my ($key, $val) = each %Cookies) {
125
1665
363464
            push @vals, $val->as_string;
126        }
127
563
123764
        $ENV{COOKIE} = join('; ', @vals);
128        ### My cookie: $ENV{COOKIE}
129    }
130
131
602
4642
    my $cgi = new_cgi($uri, $req);
132
602
2914
    $Buffer = undef;
133
602
5604
    OpenAPI::Dispatcher->process_request($cgi);
134
602
29963
    my $code;
135
602
100
6432
    if (is_utf8($Buffer)) {
136
268
2132
        $Buffer = encode('UTF-8', $Buffer);
137    }
138
602
50
7873
    if ($Buffer =~ /^HTTP\/1\.[01] (\d+) (\w+)\n/) {
139
602
4669
        $code = $1;
140    }
141
602
6545
    my $res = HTTP::Response->parse($Buffer); # $code, $msg, $header, $content )
142    ## $res
143
602
502276
    my $raw_cookie = $res->header('Set-Cookie');
144    #warn "RAW Cookie: $raw_cookie\n";
145
602
100
95063
    if ($raw_cookie) {
146
262
3826
        %Cookies = (%Cookies, CGI::Cookie->parse($raw_cookie));
147    }
148    #bless $Cookie, 'CGI::Cookie';
149    ### %Cookies
150
151    ## $raw_cookie
152    ## $Buffer
153
602
2142
    $res;
154}
155
156sub new_cgi {
157
602
602
0
4000
    my ($uri, $req) = @_;
158
602
81
2929
699
    $uri =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
159
602
1841
    my %url_params;
160
602
100
4732
    if ($uri =~ /\?(.+)/) {
161
180
1227
        my $list = $1;
162
180
1829
        my @params = split /\&/, $list;
163
180
1210
        for my $param (@params) {
164
249
2095
            my ($var, $val) = split /=/, $param, 2;
165
249
2793
            $url_params{$var} = $val;
166        }
167    }
168    my $cgi = Class::Prototyped->new(
169        param => sub {
170
227
227
1700
            my ($self, $key) = @_;
171            #warn "!!!!!$key!!!!";
172
227
50
2162
            if ($key =~ /^(?:PUTDATA|POSTDATA)$/) {
173
227
2326
                return $req->content;
174            }
175
0
0
            $url_params{$key};
176        },
177        url_param => sub {
178
6220
6220
36775
            my ($self, $name) = @_;
179            #warn ">>>>>>>>>>>>>>> url_param: $name\n";
180
6220
100
31230
            if (defined $name) {
181
6191
64291
                return $url_params{$name};
182            } else {
183
29
389
                return keys %url_params;
184            }
185        },
186        header => sub {
187
602
602
3461
            my $self = shift;
188
602
6426
            return CGI->header(@_);
189
190 - 199
=pod
            my $s;
            while (@_) {
                my $key = shift;
                my $val = shift;
                if ($key eq '-type') {
                    $s .= "Content-type: $val\n";
                }
            }
=cut
200        },
201
602
18602
    );
202}
203
2041;
205