File Coverage

File:lib/OpenAPI.pm
Coverage:83.2%

linestmtbrancondsubpodtimecode
1package OpenAPI;
2
3our $VERSION = '1.0.1';
4
5
22
22
22
22
194
68
202
use strict;
6
22
22
22
22
239
67
178
use warnings;
7
8#use Smart::Comments;
9
22
22
22
22
414
118
99
use YAML::Syck ();
10
22
22
22
22
318
90
90
use JSON::Syck ();
11
12
22
22
22
22
256
74
442
use List::Util qw(first);
13
22
22
22
22
274
221
349
use Params::Util qw(_HASH _STRING _ARRAY0 _ARRAY _SCALAR);
14
22
22
22
22
331
86
287
use Encode qw(from_to encode decode);
15
22
22
22
22
310
103
2589
use DBI;
16
17
22
22
22
22
352
116
390
use SQL::Select;
18
22
22
22
22
512
108
357
use SQL::Update;
19
22
22
22
22
291
107
343
use SQL::Insert;
20
21
22
22
22
22
293
100
317
use OpenAPI::Backend;
22
22
22
22
22
230
81
286
use OpenAPI::Limits;
23
24
22
22
22
22
300
101
396
use MiniSQL::Select;
25#use encoding "utf8";
26
27
22
22
22
22
498
132
296
use OpenAPI::Util;
28
22
22
22
22
306
119
303
use OpenAPI::Handler::Model;
29
22
22
22
22
333
131
287
use OpenAPI::Handler::View;
30
22
22
22
22
317
127
256
use OpenAPI::Handler::Action;
31
22
22
22
22
340
118
312
use OpenAPI::Handler::Role;
32
22
22
22
22
336
128
264
use OpenAPI::Handler::Admin;
33
22
22
22
22
301
128
270
use OpenAPI::Handler::Login;
34
22
22
22
22
342
108
297
use OpenAPI::Handler::Captcha;
35
22
22
22
22
322
103
249
use OpenAPI::Handler::Version;
36
22
22
22
22
300
95
174
use Encode::Guess;
37
38$YAML::Syck::ImplicitUnicode = 1;
39#$YAML::Syck::ImplicitBinary = 1;
40
41our ($Backend, $BackendName);
42our $Cache;
43our $UUID = Data::UUID->new;
44
45our %OpMap = (
46    contains => 'like',
47    gt => '>',
48    ge => '>=',
49    lt => '<',
50    le => '<=',
51    eq => '=',
52    ne => '<>',
53);
54
55our %ext2dumper = (
56    '.yml' => \&YAML::Syck::Dump,
57    '.yaml' => \&YAML::Syck::Dump,
58    '.js' => \&JSON::Syck::Dump,
59    '.json' => \&JSON::Syck::Dump,
60);
61
62our %EncodingMap = (
63    'cp936' => 'GBK',
64    'utf8' => 'UTF-8',
65    'euc-cn' => 'GB2312',
66    'big5-eten' => 'Big5',
67);
68
69our %ext2importer = (
70    '.yml' => \&YAML::Syck::Load,
71    '.yaml' => \&YAML::Syck::Load,
72    '.js' => \&JSON::Syck::Load,
73    '.json' => \&JSON::Syck::Load,
74);
75
76our $Ext = qr/\.(?:js|json|xml|yaml|yml)/;
77our ($Dumper, $Importer);
78$Dumper = \&JSON::Syck::Dump;
79$Importer = \&JSON::Syck::Load;
80
81# XXX more data types...
82sub parse_data {
83
222
222
0
941
    shift;
84
222
50
1379
    if (!$Importer) {
85
0
0
        $Importer = \&JSON::Syck::Load;
86    }
87
222
20070
    return $Importer->($_[0]);
88}
89
90sub new {
91
602
602
0
3851
    my ($class, $cgi) = @_;
92
602
12017
    return bless { _cgi => $cgi, _charset => 'UTF-8' }, $class;
93}
94
95sub init {
96
602
602
0
3633
    my ($self, $rurl) = @_;
97
602
2786
    my $class = ref $self;
98
602
3143
    my $cgi = $self->{_cgi};
99
100
602
8677
    my $db_state = $Backend->state;
101
602
50
67
5270
    if ($db_state && $db_state =~ /^(?:08|57)/) {
102
0
0
        $Backend->disconnect;
103
0
0
        my $backend = $OpenAPI::Config{'backend.type'};
104
0
0
        OpenAPI->connect($backend);
105        #die "Backend connection lost: ", $db_state, "\n";
106    }
107
108
602
50
4213
    my $as_html = $cgi->url_param('as_html') || 0;
109
602
4385
    $self->{_as_html} = $as_html;
110
111
602
100
3913
    $self->{_use_cookie} = $cgi->url_param('use_cookie') || 0;
112
602
4046
    $self->{_session} = $cgi->url_param('session');
113
114
602
100
3954
    my $charset = $cgi->url_param('charset') || 'UTF-8';
115
116
602
100
4972
    if ($charset =~ /^guess(?:ing)?$/i) {
117
4
13
        undef $charset;
118
4
25
        my $url = $ENV{REQUEST_URI};
119
4
0
16
0
        $url =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
120        ### Raw URL: $url
121
4
50
50
25
        my $data = $url .
122            ($cgi->param('PUTDATA') || '') .
123            ($cgi->param('POSTDATA') || '');
124        ### $data
125
4
189
        my @enc = qw( UTF-8 GB2312 Big5 GBK Latin1 );
126
4
20
        for my $enc (@enc) {
127
11
67
            my $decoder = guess_encoding($data, $enc);
128
11
100
687
            if (ref $decoder) {
129    # if ($enc ne 'ascii') {
130    # print "line $.: $enc message found: ", $decoder->decode($s), "\n";
131    # }
132
4
34
                $charset = $decoder->name;
133
4
33
44
                $charset = $EncodingMap{$charset} || $charset;
134
4
16
                last;
135            }
136        }
137
4
50
26
        if (!$charset) {
138
0
0
            die "Can't determine the charset of the input.\n";
139        }
140        ### $charset
141    }
142
602
3559
    $self->{'_charset'} = $charset;
143
144
602
3903
    $self->{'_var'} = $cgi->url_param('var');
145
602
3855
    $self->{'_callback'} = $cgi->url_param('callback');
146
147
602
3963
    my $offset = $cgi->url_param('offset');
148
602
100
3808
    $offset ||= 0;
149
602
100
6101
    if ($offset !~ /^\d+$/) {
150
2
7
        die "Invalid value for the \"offset\" param: $offset\n";
151    }
152
600
5241
    $self->{_offset} = $offset;
153
154
600
4012
    my $limit = $cgi->url_param('count');
155    # limit is an alias for count
156
600
100
4204
    if (!defined $limit) {
157
588
3747
        $limit = $cgi->url_param('limit');
158    }
159
600
100
3345
    if (!defined $limit) {
160
587
2699
        $limit = $MAX_SELECT_LIMIT;
161    } else {
162
13
100
80
        $limit ||= 0;
163
13
100
125
        if ($limit !~ /^\d+$/) {
164
2
8
            die "Invalid value for the \"count\" param: $limit\n";
165        }
166
11
50
94
        if ($limit > $MAX_SELECT_LIMIT) {
167
0
0
            die "Value too large for the limit param: $limit\n";
168        }
169    }
170
598
3762
    $self->{_limit} = $limit;
171
172
598
3449
    my $http_meth = $ENV{REQUEST_METHOD};
173    #$self->{'_method'} = $http_meth;
174
175    #die "#XXXX !!!! $http_meth", Dumper($self);
176
177
598
2615
    my $url = $$rurl;
178
598
1848
    eval {
179
598
4761
        from_to($url, $charset, 'UTF-8');
180    };
181
182
598
35702
    $url =~ s{/+$}{}g;
183
598
2954
    $url =~ s/\%2A/*/g;
184
598
100
7621
    if ($url =~ s/$Ext$//) {
185
94
634
        my $ext = $&;
186        # XXX obsolete
187
94
729
        $self->set_formatter($ext);
188    } else {
189
504
3705
        $self->set_formatter;
190    }
191
598
1814
    my $req_data;
192
598
100
100
5199
    if ($http_meth eq 'POST') {
193
162
1107
        $req_data = $cgi->param('POSTDATA');
194        #die "Howdy! >>$req_data<<", $cgi->param('data'), "\n";
195        #die $Dumper->(\%ENV);
196
197
162
50
8171
        if (!defined $req_data) {
198
0
0
0
            $req_data = $cgi->param('data') or
199                die "No POST content specified or no \"data\" field found.\n";
200        } else {
201
162
50
1677
            if (length($req_data) > $POST_LEN_LIMIT) {
202
0
0
                die "Exceeded POST content length limit: $POST_LEN_LIMIT\n";
203            }
204        }
205    }
206    elsif ($http_meth eq 'PUT') {
207
57
450
        $req_data = $cgi->param('PUTDATA');
208
209
57
50
3063
        if (!defined $req_data) {
210
0
0
0
            $req_data = $cgi->param('data') or
211                die "No PUT content specified.\n";
212        } else {
213
57
50
531
            if (length($req_data) > $POST_LEN_LIMIT) {
214
0
0
                die "Exceeded PUT content length limit: $POST_LEN_LIMIT\n";
215            }
216        }
217    }
218
219
598
100
100
100
100
100
100
20088
    if ($http_meth eq 'POST' and $url =~ s{^=/put/}{=/}) {
220
3
14
        $http_meth = 'PUT';
221    } elsif ($http_meth =~ /^(?:GET|POST)$/ and $url =~ s{^=/delete/}{=/}) {
222
6
30
        $http_meth = 'DELETE';
223    } elsif ($http_meth eq 'GET' and $url =~ s{^=/(post|put)/}{=/} ) {
224
6
48
        $http_meth = uc($1);
225
6
48
        $req_data = $cgi->url_param('data');
226        #$req_data = $Importer->($content);
227
228        #warn "Content: ", $Dumper->($content);
229        #warn "Data: ", $Dumper->($req_data);
230    }
231
232
598
3375
    $$rurl = $url;
233
598
5216
    $self->{'_url'} = $url;
234
598
3832
    $self->{'_http_method'} = $http_meth;
235
236
598
100
3241
    if ($req_data) {
237
222
1485
        from_to($req_data, $charset, 'UTF-8');
238
222
14085
        $req_data = $self->parse_data($req_data);
239    }
240
241
597
6001
    $self->{_req_data} = $req_data;
242}
243
244sub fatal {
245
159
159
0
1136
    my ($self, $s) = @_;
246
159
1139
    $self->error($s);
247
159
1113
    $self->response();
248}
249
250sub error {
251
159
159
0
964
    my ($self, $s) = @_;
252
159
723
    $s =~ s/^Syck parser \(line (\d+), column (\d+)\): syntax error at .+/Syntax error found in the JSON input: line $1, column $2./;
253
159
728
    $s =~ s/^DBD::Pg::st execute failed:\s+ERROR:\s+//;
254    #$s =~ s/^DBD::Pg::db do failed:\s.*?ERROR:\s+//;
255
159
2273
    $self->{_error} .= $s . "\n";
256
257}
258
259sub data {
260
438
438
0
6317
    $_[0]->{_data} = $_[1];
261}
262
263sub warning {
264
10
10
0
126
    $_[0]->{_warning} = $_[1];
265}
266
267sub response {
268
602
602
0
3215
    my $self = shift;
269
602
0
50
4595
0
    if ($self->{_no_response}) { return; }
270
602
3504
    my $charset = $self->{_charset};
271
602
3232
    my $cgi = $self->{_cgi};
272
602
2909
    my $cookie_data = $self->{_cookie};
273
602
1790
    my @cookies;
274
602
100
3137
    if ($cookie_data) {
275
38
500
        while (my ($key, $val) = each %$cookie_data) {
276
38
633
            push @cookies, CGI::Cookie->new(
277                -name => $key, -value => $val
278            );
279        }
280    }
281
282
602
4789
    print "HTTP/1.1 200 OK\n";
283
602
23199
    my $as_html = $self->{_as_html};
284
602
50
67
10370
    my $type = $self->{_type} || ($as_html ? 'text/html' : 'text/plain');
285    #warn $s;
286
602
2679
    my $str = '';
287
602
100
4610
    if (my $bin_data = $self->{_bin_data}) {
288
16
106
        binmode \*STDOUT;
289
16
100
50
373
        print $cgi->header(
290            -type => "$type" . ($type =~ /text/ ? "; charset=$charset" : ""),
291            @cookies ? (-cookie => \@cookies) : ()
292        );
293
16
100
586
        if (my $callback = $self->{_callback}) {
294
1
5
            chomp($bin_data);
295
1
4
            print "$callback($bin_data);\n";
296        } else {
297
15
70
            print $bin_data;
298        }
299
16
905
        return;
300    }
301
586
100
50
5909
    if ($self->{_error}) {
302
159
1397
        $str = $self->emit_error($self->{_error});
303    } elsif ($self->{_data}) {
304
427
2274
        my $data = $self->{_data};
305
427
100
2620
        if ($self->{_warning}) {
306
8
73
            $data->{warning} = $self->{_warning};
307        }
308
427
3093
        $str = $self->emit_data($data);
309    }
310    #die $charset;
311    # XXX if $charset is 'UTF-8' then don't bother decoding and encoding...
312
586
3806
    eval {
313        #$str = decode_utf8($str);
314        #if (is_utf8($str)) {
315            #} else {
316
586
5404
        $str = $Backend->encode_string($str, $charset);
317            #$str = decode('UTF-8', $str);
318            #$str = encode($charset, $str);
319            #}
320    }; #warn $@ if $@;
321
586
100
100
67
100
11222
    if (my $var = $self->{_var} and $Dumper eq \&JSON::Syck::Dump) {
322
8
87
        $str = "$var=$str;";
323    } elsif (my $callback = $self->{_callback} and $Dumper eq \&JSON::Syck::Dump) {
324
28
264
        $str = "$callback($str);";
325    }
326
586
3716
    $str =~ s/\n+$//s;
327
328
586
50
3365
    if ($as_html) {
329
0
0
        $str = "<html><body><script type=\"text/javascript\">parent.location.hash = ".$Dumper->($str)."</script></body></html>";
330    }
331
332
586
100
7222
    if ($self->{_http_method} =~ /^(?:PUT|POST)$/) {
333
224
50
4538
        push @cookies, CGI::Cookie->new(
334            -name => 'last_response',
335            -value => length($str) > 1024 ? substr($str, 0, 1024) : $str,
336        );
337    }
338    #warn ">>>>>>>>>>>>Cookies<<<<<<<<<<<<<<: @cookies\n";
339
586
50
100
142849
    print $cgi->header(
340        -type => "$type" . ($type =~ /text/ ? "; charset=$charset" : ""),
341        @cookies ? (-cookie => \@cookies) : ()
342    );
343
344
586
2723
    print $str, "\n";
345}
346
347sub set_formatter {
348
598
598
0
3869
    my ($self, $ext) = @_;
349
598
100
4027
    $ext ||= '.json';
350
598
3863
    $Dumper = $ext2dumper{$ext};
351
598
4657
    $Importer = $ext2importer{$ext};
352}
353
354sub connect {
355
22
22
0
138
    my $self = shift;
356
22
33
216
    my $name = shift || $BackendName;
357
22
102
    $BackendName = $name;
358
22
327
    $Backend = OpenAPI::Backend->new($name);
359    #$Backend->select("");
360}
361
362sub emit_data {
363
586
586
0
3741
    my ($self, $data) = @_;
364
586
53970
    return $Dumper->($data);
365}
366
367sub has_user {
368
589
589
0
3891
    my ($self, $user) = @_;
369
589
5125
    return $Backend->has_user($user);
370}
371
372sub add_user {
373
0
0
0
0
    my ($self, $user) = @_;
374
0
0
    $Backend->add_user($user);
375}
376
377sub drop_user {
378
0
0
0
0
    my ($self, $user) = @_;
379
0
0
    $Backend->drop_user($user);
380}
381
382sub _IDENT {
383
2192
100
67
2192
55836
    (defined $_[0] && $_[0] =~ /^[A-Za-z]\w*$/) ? $_[0] : undef;
384}
385
386sub set_user {
387
589
589
0
4413
    my ($self, $user) = @_;
388
589
4730
    $Backend->set_user($user);
389
589
5310
    $self->{_user} = $user;
390}
391
392sub current_user {
393
33
33
0
171
    my ($self) = @_;
394
33
273
    $self->{_user};
395}
396
397sub do {
398
151
151
0
1106
    my $self = shift;
399
151
1199
    $Backend->do(@_);
400}
401
402sub select {
403
2317
2317
0
21739
    my $self = shift;
404
2317
17091
    $Backend->select(@_);
405}
406
407sub last_insert_id {
408
39
39
0
223
    my $self = shift;
409
39
314
    $Backend->last_insert_id(@_);
410}
411
412sub emit_success {
413
0
0
0
0
    my $self = shift;
414
0
0
    return $self->emit_data( { success => 1 } );
415}
416
417sub emit_error {
418
159
159
0
791
    my $self = shift;
419
159
785
    my $msg = shift;
420
159
1576
    $msg =~ s/\n+$//s;
421
159
2305
    return $self->emit_data( { success => 0, error => $msg } );
422}
423
424sub set_role {
425
573
573
0
4552
    my ($self, $role) = @_;
426
573
6043
    $self->{_role} = $role;
427}
428
4291;
430