Cmd-Dwarf
30 results

 view release on metacpan or  search on metacpan

examples/helloworld/app/lib/Dwarf/Module/SocialMedia/Amazon.pm  view on Meta::CPAN 

85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
        #
        # my $res = $self->ua->post($uri);
 
        my $res = $self->ua->post($self->urls->{access_token}, \%params);
 
        if ($res->code !~ /^2/) {
                $self->on_error->('Amazon OAuth Error: Could not get access token.');
                return;
        }
 
        my $decoded = decode_json $res->{_content};
        my $access_token = $decoded->{access_token};
 
        $self->access_token($access_token);
}
 
sub _make_request {
        my ($self, $command, $method, $params) = @_;
 
        $method = uc $method;
 
        my $uri = URI->new($self->urls->{api} . '/' . $command);

examples/helloworld/app/lib/Dwarf/Module/SocialMedia/Amazon.pm  view on Meta::CPAN 

132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
sub call {
        my ($self, $command, $method, $params) = @_;
        $self->authorized;
        my $req = $self->_make_request($command, $method, $params);
        my $res = $self->ua->request($req);
        return $self->validate($res);
}
 
sub validate {
        my ($self, $res) = @_;
        my $content = eval { decode_json($res->decoded_content) };
        if ($@) {
                warn "Couldn't decode JSON: $@";
                $content = $res->decoded_content;
        }
 
        # [todo] 
        #       check error status codes
 
        return $content;
}
 
1;

examples/helloworld/app/lib/Dwarf/Module/SocialMedia/Facebook.pm  view on Meta::CPAN 

236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
        my $uri = URI->new($self->urls->{access_token});
        $uri->query_form(%params);
 
        my $res = $self->ua->get($uri);
 
        if ($res->code !~ /^2/) {
                $self->on_error->('Facebook OAuth Error: Could not get access token.');
                return;
        }
 
        my $access_token = $res->decoded_content;
        $access_token =~ s/^access_token=//;
        $access_token =~ s/&expires=[0-9]+$//;
 
        $self->access_token($access_token);
}
 
sub _make_request {
        my ($self, $command, $method, $params) = @_;
 
        $method = uc $method;

examples/helloworld/app/lib/Dwarf/Module/SocialMedia/Facebook.pm  view on Meta::CPAN 

310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
        my @contents;
        for my $res (@responses) {
                push @contents, $self->validate($res);
        }
 
        return @contents;
}
 
sub validate {
        my ($self, $res) = @_;
        my $content = eval { decode_json($res->decoded_content) };
        if ($@) {
                warn "Couldn't decode JSON: $@";
                $content = $res->decoded_content;
        }
 
        if ($res->code !~ /^2/) {
                if ($content) {
                        if (ref $content) {
                                my $error_code = $content->{error}->{code} // '';
 
                                # 506 = 二重投稿
                                if ($error_code eq '506') {
                                        warn 'Facebook API Error: ', $content->{error}->{message};

examples/helloworld/app/lib/Dwarf/Module/SocialMedia/Line.pm  view on Meta::CPAN 

82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
        my $uri = URI->new($self->urls->{access_token});
        $uri->query_form(%params);
 
        my $res = $self->ua->post($uri);
 
        if ($res->code !~ /^2/) {
                $self->on_error->('Line OAuth Error: Could not get access token.');
                return;
        }
 
        my $decoded = decode_json $res->{_content};
        my $access_token = $decoded->{access_token};
 
        $self->access_token($access_token);
}
 
sub _make_request {
        my ($self, $command, $method, $params) = @_;
 
        $method = uc $method;
 
        my $uri = URI->new($self->urls->{api} . '/' . $command);

examples/helloworld/app/lib/Dwarf/Module/SocialMedia/Line.pm  view on Meta::CPAN 

129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
sub call {
        my ($self, $command, $method, $params) = @_;
        $self->authorized;
        my $req = $self->_make_request($command, $method, $params);
        my $res = $self->ua->request($req);
        return $self->validate($res);
}
 
sub validate {
        my ($self, $res) = @_;
        my $content = eval { decode_json($res->decoded_content) };
        if ($@) {
                warn "Couldn't decode JSON: $@";
                $content = $res->decoded_content;
        }
 
        # [todo] 
        #       check error status codes
 
        return $content;
}
 
1;

examples/helloworld/app/lib/Dwarf/Module/SocialMedia/Rakuten.pm  view on Meta::CPAN 

37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
        die 'access token must be specified.' unless defined $self->access_token;
 
        my $params = {};
        $params->{access_token} = $self->access_token;
 
        my $uri = URI->new($self->urls->{api});
        $uri->query_form(%$params);
 
        my $res = $self->ua->post($uri);
 
        my $content = eval { safe_decode_json(encode_utf8 $res->decoded_content) };
        if ($@) {
                warn "Couldn't decode JSON: $@";
                $content = $res->decoded_content;
        }
 
        return $content;
}
 
sub request_access_token {
        my ($self, %params) = @_;
 
        die 'key must be specified.' unless defined $self->key;
        die 'secret must be specified.' unless defined $self->secret;

examples/helloworld/app/lib/Dwarf/Module/SocialMedia/Rakuten.pm  view on Meta::CPAN 

68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
        my $uri = URI->new($self->urls->{access_token});
        $uri->query_form(%params);
 
        my $res = $self->ua->post($uri);
 
        if ($res->code !~ /^2/) {
                $self->on_error->('Rakuten OAuth Error: Could not get access token.');
                return;
        }
 
        my $content = eval { decode_json $res->decoded_content };
        if ($@) {
                warn "Couldn't decode JSON: $@";
                $content = $res->decoded_content;
        }
 
        $self->_validate_id_token($content->{id_token});
 
        my $access_token = $content->{access_token};
 
        $self->access_token($access_token);
}
 
sub _validate_id_token {

examples/helloworld/app/lib/Dwarf/Plugin/JSON.pm  view on Meta::CPAN 

27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
add_method($c, json => sub {
        my $self = shift;
        if (@_ == 1) {
                $self->{'dwarf.json'} = $_[0];
        }
        return $self->{'dwarf.json'};
});
 
add_method($c, decode_json => sub {
        my ($self, $data) = @_;
        my $decoded = eval { $self->{'dwarf.json'}->decode($data) };
 
        if ($@) {
                $@ = undef;
                return $data;
        }
 
        return $decoded;
});
 
add_method($c, encode_json => sub {
        my ($self, $data) = @_;
        my $encoded = eval { $self->{'dwarf.json'}->encode($data) };
 
        if ($@) {
                $@ = undef;
                return $data;
        }

examples/helloworld/app/lib/Dwarf/Plugin/MouseX/Types/Common.pm  view on Meta::CPAN 

132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
                return 0;
        }
        return 1;
}
 
sub _base64_type {
        my ($value, $expected) = @_;
 
        my $filetype = '';
 
        my $decoded = decode_base64($value);
        my $type = image_type(\$decoded);
 
        if (my $error = $type->{error}) {
                return 0;
        }
 
        $filetype = lc $type->{file_type};
        return $filetype =~ /^$expected$/i;
};
 
sub _delsp {

examples/helloworld/app/lib/Dwarf/Request.pm  view on Meta::CPAN 

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
 
sub _build_encoding { 'utf-8' }
 
sub new {
        my ($class, $env) = @_;
        my $self = $class->SUPER::new($env);
        return $self;
}
 
# ------------------------------------------------------------------------- 
# This object returns decoded parameter values by default
 
sub body_parameters {
        my ($self) = @_;
        $self->{'dwarf.body_parameters'} ||= $self->_decode_parameters($self->SUPER::body_parameters());
}
 
sub query_parameters {
        my ($self) = @_;
        $self->{'dwarf.query_parameters'} ||= $self->_decode_parameters($self->SUPER::query_parameters());
}
 
sub _decode_parameters {
        my ($self, $stuff) = @_;
 
        $stuff = $self->_decode_array_parameters($stuff);
 
        my $encoding = $self->encoding;
        my @flatten = $stuff->flatten();
        my @decoded;
        while ( my ($k, $v) = splice @flatten, 0, 2 ) {
                push @decoded, Encode::decode($encoding, $k), Encode::decode($encoding, $v);
        }
        return Hash::MultiValue->new(@decoded);
}
 
sub _decode_array_parameters {
        my ($self, $stuff) = @_;
        my @flatten = $stuff->flatten();
        my @decoded;
        while ( my ($k, $v) = splice @flatten, 0, 2 ) {
                if ($k =~ /^(.+)\[\d+\]$/) {
                        my $name = $1;
                        $k = "${name}[]";
                }
                push @decoded, $k, $v;
        }
        return Hash::MultiValue->new(@decoded);
}
 
sub param {
        my $self = shift;
        return keys %{ $self->parameters } if @_ == 0;
 
        my $key = shift;
        #return $self->parameters->get_all($key) if wantarray; # list コンテキストで配列を返す機能を削除
        return [$self->parameters->get_all($key)] if $key =~ /^.+\[\]$/;
        return $self->parameters->{$key};

examples/helloworld/app/lib/Dwarf/Validator/Constraint/Default.pm  view on Meta::CPAN 

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
package Dwarf::Validator::Constraint::Default;
use Dwarf::Validator::Constraint;
use Dwarf::Validator::NullValue;
use Email::Valid;
use Email::Valid::Loose;
use Dwarf::Util qw/encode_utf8 decode_utf8/;
use Image::Info qw/image_type/;
use JSON;
use MIME::Base64 qw(decode_base64 decoded_base64_length);
use Scalar::Util qw/looks_like_number/;
 
 
rule NOT_NULL => sub {
        return 0 if not defined($_);
        return 0 if ref $_ eq 'ARRAY' && @$_ == 0;
        return 1;
};
alias NOT_NULL => 'REQUIRED';

examples/helloworld/app/lib/Dwarf/Validator/Constraint/Default.pm  view on Meta::CPAN 

238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
 
rule CREDITCARD_NUMBER   => sub { $_ =~ /\A[0-9]{14,16}\z/ };
rule CREDITCARD_EXPIRE   => sub { $_ =~ /^\d{2}\/\d{2}$/ };
rule CREDITCARD_SECURITY => sub { $_ =~ /\A[0-9]{3,4}\z/ };
 
rule BASE64_TYPE => sub {
        Carp::croak('missing args. usage: ["BASE64_TYPE", "(jpeg|png|gif)"]') unless @_;
        my $expected = $_[0];
        my $filetype = '';
 
        my $decoded = decode_base64($_);
        my $type = image_type(\$decoded);
 
        if (my $error = $type->{error}) {
                return 0;
        }
        $filetype = lc $type->{file_type};
        return $filetype =~ /^$expected$/i;
};
 
rule BASE64_SIZE => sub {
        Carp::croak('missing args. usage: ["BASE64_SIZE", "10000"]') unless @_;
        my $expected = $_[0];
        my $length = decoded_base64_length($_);
        return $length < $expected;
};
 
 
file_rule FILE_NOT_NULL => sub {
        return 0 if not defined($_);
        return 0 if $_ eq "";
        return 0 if ref($_) eq 'ARRAY' && @$_ == 0;
        return 1;
};

examples/helloworld/app/t/00_dwarf/03_pragma.t  view on Meta::CPAN 

3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
use Test::More 0.88;
 
subtest "boolean" => sub {
        ok true;
        ok !false;
        ok (1 == 1);
        ok !(1 == 0);
 
        my $json = JSON->new->convert_blessed;
        my $encoded = $json->encode({ false => false, true => true });
        my $decoded = $json->decode($encoded);
        #is $encoded, '{"false":false,"true":true}';
};
 
done_testing();

examples/helloworld/app/t/00_dwarf/05_request.t  view on Meta::CPAN 

40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
        $c->request_handler_prefix('');
 
        return $c;
}
 
subtest "Decode parameters" => sub {
        my $c = c(
        );
 
        my $hoge = $c->param('hoge');
        ok Encode::is_utf8($hoge), 'parameters are decoded';
};
 
subtest "ARRAY parameters" => sub {
        my $c = c(
        );
        my $name = $c->param('name[]');
        is ref $name, 'ARRAY', 'name[] param is ARRAY REF';
        is @$name, 2, 'name[] param have 2 values in scalar context';
 
        my @name_arr = $c->param('name[]');

examples/test-validate-json-body/app/lib/Dwarf/Module/SocialMedia/Amazon.pm  view on Meta::CPAN 

85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
        #
        # my $res = $self->ua->post($uri);
 
        my $res = $self->ua->post($self->urls->{access_token}, \%params);
 
        if ($res->code !~ /^2/) {
                $self->on_error->('Amazon OAuth Error: Could not get access token.');
                return;
        }
 
        my $decoded = decode_json $res->{_content};
        my $access_token = $decoded->{access_token};
 
        $self->access_token($access_token);
}
 
sub _make_request {
        my ($self, $command, $method, $params) = @_;
 
        $method = uc $method;
 
        my $uri = URI->new($self->urls->{api} . '/' . $command);

examples/test-validate-json-body/app/lib/Dwarf/Module/SocialMedia/Amazon.pm  view on Meta::CPAN 

132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
sub call {
        my ($self, $command, $method, $params) = @_;
        $self->authorized;
        my $req = $self->_make_request($command, $method, $params);
        my $res = $self->ua->request($req);
        return $self->validate($res);
}
 
sub validate {
        my ($self, $res) = @_;
        my $content = eval { decode_json($res->decoded_content) };
        if ($@) {
                warn "Couldn't decode JSON: $@";
                $content = $res->decoded_content;
        }
 
        # [todo] 
        #       check error status codes
 
        return $content;
}
 
1;

examples/test-validate-json-body/app/lib/Dwarf/Module/SocialMedia/Facebook.pm  view on Meta::CPAN 

236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
        my $uri = URI->new($self->urls->{access_token});
        $uri->query_form(%params);
 
        my $res = $self->ua->get($uri);
 
        if ($res->code !~ /^2/) {
                $self->on_error->('Facebook OAuth Error: Could not get access token.');
                return;
        }
 
        my $access_token = $res->decoded_content;
        $access_token =~ s/^access_token=//;
        $access_token =~ s/&expires=[0-9]+$//;
 
        $self->access_token($access_token);
}
 
sub _make_request {
        my ($self, $command, $method, $params) = @_;
 
        $method = uc $method;

examples/test-validate-json-body/app/lib/Dwarf/Module/SocialMedia/Facebook.pm  view on Meta::CPAN 

310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
        my @contents;
        for my $res (@responses) {
                push @contents, $self->validate($res);
        }
 
        return @contents;
}
 
sub validate {
        my ($self, $res) = @_;
        my $content = eval { decode_json($res->decoded_content) };
        if ($@) {
                warn "Couldn't decode JSON: $@";
                $content = $res->decoded_content;
        }
 
        if ($res->code !~ /^2/) {
                if ($content) {
                        if (ref $content) {
                                my $error_code = $content->{error}->{code} // '';
 
                                # 506 = 二重投稿
                                if ($error_code eq '506') {
                                        warn 'Facebook API Error: ', $content->{error}->{message};

examples/test-validate-json-body/app/lib/Dwarf/Module/SocialMedia/Line.pm  view on Meta::CPAN 

82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
        my $uri = URI->new($self->urls->{access_token});
        $uri->query_form(%params);
 
        my $res = $self->ua->post($uri);
 
        if ($res->code !~ /^2/) {
                $self->on_error->('Line OAuth Error: Could not get access token.');
                return;
        }
 
        my $decoded = decode_json $res->{_content};
        my $access_token = $decoded->{access_token};
 
        $self->access_token($access_token);
}
 
sub _make_request {
        my ($self, $command, $method, $params) = @_;
 
        $method = uc $method;
 
        my $uri = URI->new($self->urls->{api} . '/' . $command);

examples/test-validate-json-body/app/lib/Dwarf/Module/SocialMedia/Line.pm  view on Meta::CPAN 

129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
sub call {
        my ($self, $command, $method, $params) = @_;
        $self->authorized;
        my $req = $self->_make_request($command, $method, $params);
        my $res = $self->ua->request($req);
        return $self->validate($res);
}
 
sub validate {
        my ($self, $res) = @_;
        my $content = eval { decode_json($res->decoded_content) };
        if ($@) {
                warn "Couldn't decode JSON: $@";
                $content = $res->decoded_content;
        }
 
        # [todo] 
        #       check error status codes
 
        return $content;
}
 
1;

examples/test-validate-json-body/app/lib/Dwarf/Module/SocialMedia/Rakuten.pm  view on Meta::CPAN 

37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
        die 'access token must be specified.' unless defined $self->access_token;
 
        my $params = {};
        $params->{access_token} = $self->access_token;
 
        my $uri = URI->new($self->urls->{api});
        $uri->query_form(%$params);
 
        my $res = $self->ua->post($uri);
 
        my $content = eval { safe_decode_json(encode_utf8 $res->decoded_content) };
        if ($@) {
                warn "Couldn't decode JSON: $@";
                $content = $res->decoded_content;
        }
 
        return $content;
}
 
sub request_access_token {
        my ($self, %params) = @_;
 
        die 'key must be specified.' unless defined $self->key;
        die 'secret must be specified.' unless defined $self->secret;

examples/test-validate-json-body/app/lib/Dwarf/Module/SocialMedia/Rakuten.pm  view on Meta::CPAN 

68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
        my $uri = URI->new($self->urls->{access_token});
        $uri->query_form(%params);
 
        my $res = $self->ua->post($uri);
 
        if ($res->code !~ /^2/) {
                $self->on_error->('Rakuten OAuth Error: Could not get access token.');
                return;
        }
 
        my $content = eval { decode_json $res->decoded_content };
        if ($@) {
                warn "Couldn't decode JSON: $@";
                $content = $res->decoded_content;
        }
 
        $self->_validate_id_token($content->{id_token});
 
        my $access_token = $content->{access_token};
 
        $self->access_token($access_token);
}
 
sub _validate_id_token {

examples/test-validate-json-body/app/lib/Dwarf/Plugin/JSON.pm  view on Meta::CPAN 

25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
add_method($c, json => sub {
        my $self = shift;
        if (@_ == 1) {
                $self->{'dwarf.json'} = $_[0];
        }
        return $self->{'dwarf.json'};
});
 
add_method($c, decode_json => sub {
        my ($self, $data) = @_;
        my $decoded = eval { $self->{'dwarf.json'}->decode($data) };
 
        if ($@) {
                $@ = undef;
                return $data;
        }
 
        return $decoded;
});
 
add_method($c, encode_json => sub {
        my ($self, $data) = @_;
        my $encoded = eval { $self->{'dwarf.json'}->encode($data) };
 
        if ($@) {
                $@ = undef;
                return $data;
        }

examples/test-validate-json-body/app/lib/Dwarf/Plugin/MouseX/Types/Common.pm  view on Meta::CPAN 

132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
                return 0;
        }
        return 1;
}
 
sub _base64_type {
        my ($value, $expected) = @_;
 
        my $filetype = '';
 
        my $decoded = decode_base64($value);
        my $type = image_type(\$decoded);
 
        if (my $error = $type->{error}) {
                return 0;
        }
 
        $filetype = lc $type->{file_type};
        return $filetype =~ /^$expected$/i;
};
 
sub _delsp {

examples/test-validate-json-body/app/lib/Dwarf/Request.pm  view on Meta::CPAN 

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
 
sub _build_encoding { 'utf-8' }
 
sub new {
        my ($class, $env) = @_;
        my $self = $class->SUPER::new($env);
        return $self;
}
 
# ------------------------------------------------------------------------- 
# This object returns decoded parameter values by default
 
sub body_parameters {
        my ($self) = @_;
        $self->{'dwarf.body_parameters'} ||= $self->_decode_parameters($self->SUPER::body_parameters());
}
 
sub query_parameters {
        my ($self) = @_;
        $self->{'dwarf.query_parameters'} ||= $self->_decode_parameters($self->SUPER::query_parameters());
}
 
sub _decode_parameters {
        my ($self, $stuff) = @_;
 
        $stuff = $self->_decode_array_parameters($stuff);
 
        my $encoding = $self->encoding;
        my @flatten = $stuff->flatten();
        my @decoded;
        while ( my ($k, $v) = splice @flatten, 0, 2 ) {
                push @decoded, Encode::decode($encoding, $k), Encode::decode($encoding, $v);
        }
        return Hash::MultiValue->new(@decoded);
}
 
sub _decode_array_parameters {
        my ($self, $stuff) = @_;
        my @flatten = $stuff->flatten();
        my @decoded;
        while ( my ($k, $v) = splice @flatten, 0, 2 ) {
                if ($k =~ /^(.+)\[\d+\]$/) {
                        my $name = $1;
                        $k = "${name}[]";
                }
                push @decoded, $k, $v;
        }
        return Hash::MultiValue->new(@decoded);
}
 
sub param {
        my $self = shift;
        return keys %{ $self->parameters } if @_ == 0;
 
        my $key = shift;
        #return $self->parameters->get_all($key) if wantarray; # list コンテキストで配列を返す機能を削除
        return [$self->parameters->get_all($key)] if $key =~ /^.+\[\]$/;
        return $self->parameters->{$key};

examples/test-validate-json-body/app/lib/Dwarf/Validator/Constraint/Default.pm  view on Meta::CPAN 

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
package Dwarf::Validator::Constraint::Default;
use Dwarf::Validator::Constraint;
use Dwarf::Validator::NullValue;
use Email::Valid;
use Email::Valid::Loose;
use Dwarf::Util qw/encode_utf8 decode_utf8/;
use Image::Info qw/image_type/;
use JSON;
use MIME::Base64 qw(decode_base64 decoded_base64_length);
use Scalar::Util qw/looks_like_number/;
 
 
rule NOT_NULL => sub {
        return 0 if not defined($_);
        return 0 if ref $_ eq 'ARRAY' && @$_ == 0;
        return 1;
};
alias NOT_NULL => 'REQUIRED';

examples/test-validate-json-body/app/lib/Dwarf/Validator/Constraint/Default.pm  view on Meta::CPAN 

238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
 
rule CREDITCARD_NUMBER   => sub { $_ =~ /\A[0-9]{14,16}\z/ };
rule CREDITCARD_EXPIRE   => sub { $_ =~ /^\d{2}\/\d{2}$/ };
rule CREDITCARD_SECURITY => sub { $_ =~ /\A[0-9]{3,4}\z/ };
 
rule BASE64_TYPE => sub {
        Carp::croak('missing args. usage: ["BASE64_TYPE", "(jpeg|png|gif)"]') unless @_;
        my $expected = $_[0];
        my $filetype = '';
 
        my $decoded = decode_base64($_);
        my $type = image_type(\$decoded);
 
        if (my $error = $type->{error}) {
                return 0;
        }
        $filetype = lc $type->{file_type};
        return $filetype =~ /^$expected$/i;
};
 
rule BASE64_SIZE => sub {
        Carp::croak('missing args. usage: ["BASE64_SIZE", "10000"]') unless @_;
        my $expected = $_[0];
        my $length = decoded_base64_length($_);
        return $length < $expected;
};
 
 
file_rule FILE_NOT_NULL => sub {
        return 0 if not defined($_);
        return 0 if $_ eq "";
        return 0 if ref($_) eq 'ARRAY' && @$_ == 0;
        return 1;
};

examples/test-validate-json-body/app/t/00_dwarf/03_pragma.t  view on Meta::CPAN 

3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
use Test::More 0.88;
 
subtest "boolean" => sub {
        ok true;
        ok !false;
        ok (1 == 1);
        ok !(1 == 0);
 
        my $json = JSON->new->convert_blessed;
        my $encoded = $json->encode({ false => false, true => true });
        my $decoded = $json->decode($encoded);
        #is $encoded, '{"false":false,"true":true}';
};
 
done_testing();

examples/test-validate-json-body/app/t/00_dwarf/05_request.t  view on Meta::CPAN 

40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
        $c->request_handler_prefix('');
 
        return $c;
}
 
subtest "Decode parameters" => sub {
        my $c = c(
        );
 
        my $hoge = $c->param('hoge');
        ok Encode::is_utf8($hoge), 'parameters are decoded';
};
 
subtest "ARRAY parameters" => sub {
        my $c = c(
        );
        my $name = $c->param('name[]');
        is ref $name, 'ARRAY', 'name[] param is ARRAY REF';
        is @$name, 2, 'name[] param have 2 values in scalar context';
 
        my @name_arr = $c->param('name[]');

share/app/lib/Dwarf/Module/SocialMedia/Amazon.pm  view on Meta::CPAN 

85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
        #
        # my $res = $self->ua->post($uri);
 
        my $res = $self->ua->post($self->urls->{access_token}, \%params);
 
        if ($res->code !~ /^2/) {
                $self->on_error->('Amazon OAuth Error: Could not get access token.');
                return;
        }
 
        my $decoded = decode_json $res->{_content};
        my $access_token = $decoded->{access_token};
 
        $self->access_token($access_token);
}
 
sub _make_request {
        my ($self, $command, $method, $params) = @_;
 
        $method = uc $method;
 
        my $uri = URI->new($self->urls->{api} . '/' . $command);

share/app/lib/Dwarf/Module/SocialMedia/Amazon.pm  view on Meta::CPAN 

132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
sub call {
        my ($self, $command, $method, $params) = @_;
        $self->authorized;
        my $req = $self->_make_request($command, $method, $params);
        my $res = $self->ua->request($req);
        return $self->validate($res);
}
 
sub validate {
        my ($self, $res) = @_;
        my $content = eval { decode_json($res->decoded_content) };
        if ($@) {
                warn "Couldn't decode JSON: $@";
                $content = $res->decoded_content;
        }
 
        # [todo] 
        #       check error status codes
 
        return $content;
}
 
1;

share/app/lib/Dwarf/Module/SocialMedia/Facebook.pm  view on Meta::CPAN 

236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
        my $uri = URI->new($self->urls->{access_token});
        $uri->query_form(%params);
 
        my $res = $self->ua->get($uri);
 
        if ($res->code !~ /^2/) {
                $self->on_error->('Facebook OAuth Error: Could not get access token.');
                return;
        }
 
        my $access_token = $res->decoded_content;
        $access_token =~ s/^access_token=//;
        $access_token =~ s/&expires=[0-9]+$//;
 
        $self->access_token($access_token);
}
 
sub _make_request {
        my ($self, $command, $method, $params) = @_;
 
        $method = uc $method;

share/app/lib/Dwarf/Module/SocialMedia/Facebook.pm  view on Meta::CPAN 

310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
        my @contents;
        for my $res (@responses) {
                push @contents, $self->validate($res);
        }
 
        return @contents;
}
 
sub validate {
        my ($self, $res) = @_;
        my $content = eval { decode_json($res->decoded_content) };
        if ($@) {
                warn "Couldn't decode JSON: $@";
                $content = $res->decoded_content;
        }
 
        if ($res->code !~ /^2/) {
                if ($content) {
                        if (ref $content) {
                                my $error_code = $content->{error}->{code} // '';
 
                                # 506 = 二重投稿
                                if ($error_code eq '506') {
                                        warn 'Facebook API Error: ', $content->{error}->{message};

share/app/lib/Dwarf/Module/SocialMedia/Line.pm  view on Meta::CPAN 

82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
        my $uri = URI->new($self->urls->{access_token});
        $uri->query_form(%params);
 
        my $res = $self->ua->post($uri);
 
        if ($res->code !~ /^2/) {
                $self->on_error->('Line OAuth Error: Could not get access token.');
                return;
        }
 
        my $decoded = decode_json $res->{_content};
        my $access_token = $decoded->{access_token};
 
        $self->access_token($access_token);
}
 
sub _make_request {
        my ($self, $command, $method, $params) = @_;
 
        $method = uc $method;
 
        my $uri = URI->new($self->urls->{api} . '/' . $command);

share/app/lib/Dwarf/Module/SocialMedia/Line.pm  view on Meta::CPAN 

129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
sub call {
        my ($self, $command, $method, $params) = @_;
        $self->authorized;
        my $req = $self->_make_request($command, $method, $params);
        my $res = $self->ua->request($req);
        return $self->validate($res);
}
 
sub validate {
        my ($self, $res) = @_;
        my $content = eval { decode_json($res->decoded_content) };
        if ($@) {
                warn "Couldn't decode JSON: $@";
                $content = $res->decoded_content;
        }
 
        # [todo] 
        #       check error status codes
 
        return $content;
}
 
1;

share/app/lib/Dwarf/Module/SocialMedia/Rakuten.pm  view on Meta::CPAN 

37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
        die 'access token must be specified.' unless defined $self->access_token;
 
        my $params = {};
        $params->{access_token} = $self->access_token;
 
        my $uri = URI->new($self->urls->{api});
        $uri->query_form(%$params);
 
        my $res = $self->ua->post($uri);
 
        my $content = eval { safe_decode_json(encode_utf8 $res->decoded_content) };
        if ($@) {
                warn "Couldn't decode JSON: $@";
                $content = $res->decoded_content;
        }
 
        return $content;
}
 
sub request_access_token {
        my ($self, %params) = @_;
 
        die 'key must be specified.' unless defined $self->key;
        die 'secret must be specified.' unless defined $self->secret;

share/app/lib/Dwarf/Module/SocialMedia/Rakuten.pm  view on Meta::CPAN 

68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
        my $uri = URI->new($self->urls->{access_token});
        $uri->query_form(%params);
 
        my $res = $self->ua->post($uri);
 
        if ($res->code !~ /^2/) {
                $self->on_error->('Rakuten OAuth Error: Could not get access token.');
                return;
        }
 
        my $content = eval { decode_json $res->decoded_content };
        if ($@) {
                warn "Couldn't decode JSON: $@";
                $content = $res->decoded_content;
        }
 
        $self->_validate_id_token($content->{id_token});
 
        my $access_token = $content->{access_token};
 
        $self->access_token($access_token);
}
 
sub _validate_id_token {

share/app/lib/Dwarf/Plugin/JSON.pm  view on Meta::CPAN 

27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
add_method($c, json => sub {
        my $self = shift;
        if (@_ == 1) {
                $self->{'dwarf.json'} = $_[0];
        }
        return $self->{'dwarf.json'};
});
 
add_method($c, decode_json => sub {
        my ($self, $data) = @_;
        my $decoded = eval { $self->{'dwarf.json'}->decode($data) };
 
        if ($@) {
                $@ = undef;
                return $data;
        }
 
        return $decoded;
});
 
add_method($c, encode_json => sub {
        my ($self, $data) = @_;
        my $encoded = eval { $self->{'dwarf.json'}->encode($data) };
 
        if ($@) {
                $@ = undef;
                return $data;
        }

share/app/lib/Dwarf/Plugin/MouseX/Types/Common.pm  view on Meta::CPAN 

132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
                return 0;
        }
        return 1;
}
 
sub _base64_type {
        my ($value, $expected) = @_;
 
        my $filetype = '';
 
        my $decoded = decode_base64($value);
        my $type = image_type(\$decoded);
 
        if (my $error = $type->{error}) {
                return 0;
        }
 
        $filetype = lc $type->{file_type};
        return $filetype =~ /^$expected$/i;
};
 
sub _delsp {

share/app/lib/Dwarf/Request.pm  view on Meta::CPAN 

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
 
sub _build_encoding { 'utf-8' }
 
sub new {
        my ($class, $env) = @_;
        my $self = $class->SUPER::new($env);
        return $self;
}
 
# ------------------------------------------------------------------------- 
# This object returns decoded parameter values by default
 
sub body_parameters {
        my ($self) = @_;
        $self->{'dwarf.body_parameters'} ||= $self->_decode_parameters($self->SUPER::body_parameters());
}
 
sub query_parameters {
        my ($self) = @_;
        $self->{'dwarf.query_parameters'} ||= $self->_decode_parameters($self->SUPER::query_parameters());
}
 
sub _decode_parameters {
        my ($self, $stuff) = @_;
 
        $stuff = $self->_decode_array_parameters($stuff);
 
        my $encoding = $self->encoding;
        my @flatten = $stuff->flatten();
        my @decoded;
        while ( my ($k, $v) = splice @flatten, 0, 2 ) {
                push @decoded, Encode::decode($encoding, $k), Encode::decode($encoding, $v);
        }
        return Hash::MultiValue->new(@decoded);
}
 
sub _decode_array_parameters {
        my ($self, $stuff) = @_;
        my @flatten = $stuff->flatten();
        my @decoded;
        while ( my ($k, $v) = splice @flatten, 0, 2 ) {
                if ($k =~ /^(.+)\[\d+\]$/) {
                        my $name = $1;
                        $k = "${name}[]";
                }
                push @decoded, $k, $v;
        }
        return Hash::MultiValue->new(@decoded);
}
 
sub param {
        my $self = shift;
        return keys %{ $self->parameters } if @_ == 0;
 
        my $key = shift;
        #return $self->parameters->get_all($key) if wantarray; # list コンテキストで配列を返す機能を削除
        return [$self->parameters->get_all($key)] if $key =~ /^.+\[\]$/;
        return $self->parameters->{$key};

share/app/lib/Dwarf/Validator/Constraint/Default.pm  view on Meta::CPAN 

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
package Dwarf::Validator::Constraint::Default;
use Dwarf::Validator::Constraint;
use Dwarf::Validator::NullValue;
use Email::Valid;
use Email::Valid::Loose;
use Dwarf::Util qw/encode_utf8 decode_utf8/;
use Image::Info qw/image_type/;
use JSON;
use MIME::Base64 qw(decode_base64 decoded_base64_length);
use Scalar::Util qw/looks_like_number/;
use UNIVERSAL::require;
 
 
rule NOT_NULL => sub {
        return 0 if not defined($_);
        return 0 if ref $_ eq 'ARRAY' && @$_ == 0;
        return 1;
};
alias NOT_NULL => 'REQUIRED';

share/app/lib/Dwarf/Validator/Constraint/Default.pm  view on Meta::CPAN 

239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
 
rule CREDITCARD_NUMBER   => sub { $_ =~ /\A[0-9]{14,16}\z/ };
rule CREDITCARD_EXPIRE   => sub { $_ =~ /^\d{2}\/\d{2}$/ };
rule CREDITCARD_SECURITY => sub { $_ =~ /\A[0-9]{3,4}\z/ };
 
rule BASE64_TYPE => sub {
        Carp::croak('missing args. usage: ["BASE64_TYPE", "(jpeg|png|gif)"]') unless @_;
        my $expected = $_[0];
        my $filetype = '';
 
        my $decoded = decode_base64($_);
        my $type = image_type(\$decoded);
 
        if (my $error = $type->{error}) {
                return 0;
        }
        $filetype = lc $type->{file_type};
        return $filetype =~ /^$expected$/i;
};
 
rule BASE64_SIZE => sub {
        Carp::croak('missing args. usage: ["BASE64_SIZE", "10000"]') unless @_;
        my $expected = $_[0];
        my $length = decoded_base64_length($_);
        return $length < $expected;
};
 
 
file_rule FILE_NOT_NULL => sub {
        return 0 if not defined($_);
        return 0 if $_ eq "";
        return 0 if ref($_) eq 'ARRAY' && @$_ == 0;
        return 1;
};

share/app/t/00_dwarf/03_pragma.t  view on Meta::CPAN 

3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
use Test::More 0.88;
 
subtest "boolean" => sub {
        ok true;
        ok !false;
        ok (1 == 1);
        ok !(1 == 0);
 
        my $json = JSON->new->convert_blessed;
        my $encoded = $json->encode({ false => false, true => true });
        my $decoded = $json->decode($encoded);
        #is $encoded, '{"false":false,"true":true}';
};
 
done_testing();

share/app/t/00_dwarf/05_request.t  view on Meta::CPAN 

40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
        $c->request_handler_prefix('');
 
        return $c;
}
 
subtest "Decode parameters" => sub {
        my $c = c(
        );
 
        my $hoge = $c->param('hoge');
        ok Encode::is_utf8($hoge), 'parameters are decoded';
};
 
subtest "ARRAY parameters" => sub {
        my $c = c(
        );
        my $name = $c->param('name[]');
        is ref $name, 'ARRAY', 'name[] param is ARRAY REF';
        is @$name, 2, 'name[] param have 2 values in scalar context';
 
        my @name_arr = $c->param('name[]');



( run in 0.735 second using v1.01-cache-2.11-cpan-eab888a1d7d )