line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# ************************************************************************* |
2
|
|
|
|
|
|
|
# Copyright (c) 2014-2015-2015, SUSE LLC |
3
|
|
|
|
|
|
|
# |
4
|
|
|
|
|
|
|
# All rights reserved. |
5
|
|
|
|
|
|
|
# |
6
|
|
|
|
|
|
|
# Redistribution and use in source and binary forms, with or without |
7
|
|
|
|
|
|
|
# modification, are permitted provided that the following conditions are met: |
8
|
|
|
|
|
|
|
# |
9
|
|
|
|
|
|
|
# 1. Redistributions of source code must retain the above copyright notice, |
10
|
|
|
|
|
|
|
# this list of conditions and the following disclaimer. |
11
|
|
|
|
|
|
|
# |
12
|
|
|
|
|
|
|
# 2. Redistributions in binary form must reproduce the above copyright |
13
|
|
|
|
|
|
|
# notice, this list of conditions and the following disclaimer in the |
14
|
|
|
|
|
|
|
# documentation and/or other materials provided with the distribution. |
15
|
|
|
|
|
|
|
# |
16
|
|
|
|
|
|
|
# 3. Neither the name of SUSE LLC nor the names of its contributors may be |
17
|
|
|
|
|
|
|
# used to endorse or promote products derived from this software without |
18
|
|
|
|
|
|
|
# specific prior written permission. |
19
|
|
|
|
|
|
|
# |
20
|
|
|
|
|
|
|
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
21
|
|
|
|
|
|
|
# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
22
|
|
|
|
|
|
|
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
23
|
|
|
|
|
|
|
# ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE |
24
|
|
|
|
|
|
|
# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR |
25
|
|
|
|
|
|
|
# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF |
26
|
|
|
|
|
|
|
# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS |
27
|
|
|
|
|
|
|
# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN |
28
|
|
|
|
|
|
|
# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) |
29
|
|
|
|
|
|
|
# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE |
30
|
|
|
|
|
|
|
# POSSIBILITY OF SUCH DAMAGE. |
31
|
|
|
|
|
|
|
# ************************************************************************* |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
package Web::MREST::InitRouter; |
34
|
|
|
|
|
|
|
|
35
|
22
|
|
|
22
|
|
481
|
use 5.012; |
|
22
|
|
|
|
|
87
|
|
36
|
22
|
|
|
22
|
|
130
|
use strict; |
|
22
|
|
|
|
|
83
|
|
|
22
|
|
|
|
|
506
|
|
37
|
22
|
|
|
22
|
|
127
|
use warnings; |
|
22
|
|
|
|
|
51
|
|
|
22
|
|
|
|
|
1012
|
|
38
|
|
|
|
|
|
|
|
39
|
22
|
|
|
22
|
|
163
|
use App::CELL qw( $log $meta $site ); |
|
22
|
|
|
|
|
58
|
|
|
22
|
|
|
|
|
2058
|
|
40
|
22
|
|
|
22
|
|
150
|
use Data::Dumper; |
|
22
|
|
|
|
|
42
|
|
|
22
|
|
|
|
|
899
|
|
41
|
22
|
|
|
22
|
|
7705
|
use Path::Router; |
|
22
|
|
|
|
|
3854326
|
|
|
22
|
|
|
|
|
879
|
|
42
|
22
|
|
|
22
|
|
206
|
use Try::Tiny; |
|
22
|
|
|
|
|
54
|
|
|
22
|
|
|
|
|
3201
|
|
43
|
|
|
|
|
|
|
|
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
=head1 NAME |
46
|
|
|
|
|
|
|
|
47
|
|
|
|
|
|
|
Web::MREST::InitRouter - Routines for initializing our Path::Router instance |
48
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
=head1 SYNOPSIS |
52
|
|
|
|
|
|
|
|
53
|
|
|
|
|
|
|
L<Web::MREST> uses L<Path::Router> to match URIs to resources. All resources |
54
|
|
|
|
|
|
|
are packed into a single object. The singleton is exported as C<$router> from |
55
|
|
|
|
|
|
|
this module and can be initialized by calling C<init_router>, which is also |
56
|
|
|
|
|
|
|
exported, with no arguments. |
57
|
|
|
|
|
|
|
|
58
|
|
|
|
|
|
|
use Web::MREST::InitRouter qw( $router ); |
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
... |
61
|
|
|
|
|
|
|
|
62
|
|
|
|
|
|
|
Web::MREST::InitRouter::init_router() unless defined $router and $router->can( 'match' ); |
63
|
|
|
|
|
|
|
|
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
=head1 PACKAGE VARIABLES |
68
|
|
|
|
|
|
|
|
69
|
|
|
|
|
|
|
=cut |
70
|
|
|
|
|
|
|
|
71
|
|
|
|
|
|
|
our $router; |
72
|
|
|
|
|
|
|
our $resources = {}; |
73
|
|
|
|
|
|
|
our @non_expandable_properties = qw( parent validations documentation resource_name children ); |
74
|
|
|
|
|
|
|
our %no_expand_map = map { ( $_ => '' ) } @non_expandable_properties; |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
|
77
|
|
|
|
|
|
|
=head1 EXPORTS |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
This module provides the following exports: |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
=over |
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
=item C<$router> (Path::Router singleton) |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
=item C<$resources> (expanded resource definitions) |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
=back |
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
=cut |
90
|
|
|
|
|
|
|
|
91
|
22
|
|
|
22
|
|
163
|
use Exporter qw( import ); |
|
22
|
|
|
|
|
52
|
|
|
22
|
|
|
|
|
15966
|
|
92
|
|
|
|
|
|
|
our @EXPORT_OK = qw( $router $resources ); |
93
|
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
|
95
|
|
|
|
|
|
|
=head1 FUNCTIONS |
96
|
|
|
|
|
|
|
|
97
|
|
|
|
|
|
|
=cut |
98
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
# |
101
|
|
|
|
|
|
|
# read in multiple resource definitions from a hash |
102
|
|
|
|
|
|
|
# |
103
|
|
|
|
|
|
|
sub load_resource_defs { |
104
|
20
|
|
|
20
|
0
|
76
|
my $defs = shift; |
105
|
|
|
|
|
|
|
#$log->debug("Entering " . __PACKAGE__. "::_load_resource_defs with argument " . Dumper( $defs )); |
106
|
|
|
|
|
|
|
|
107
|
|
|
|
|
|
|
# first pass -> expand resource defs and add them to $resources |
108
|
20
|
|
|
|
|
219
|
foreach my $resource ( keys( %$defs ) ) { |
109
|
|
|
|
|
|
|
# each resource definition is a hash. |
110
|
240
|
50
|
|
|
|
234283
|
if ( ref( $defs->{$resource} ) eq 'HASH' ) { |
111
|
240
|
|
|
|
|
611
|
_process_resource_def( $resource, $defs->{$resource} ); |
112
|
|
|
|
|
|
|
} else { |
113
|
0
|
|
|
|
|
0
|
die "AAAAAAAHHHHHHH! Definition of resource $resource is not a hashref!"; |
114
|
|
|
|
|
|
|
} |
115
|
240
|
|
|
|
|
439
|
_add_route( $resource ); |
116
|
|
|
|
|
|
|
} |
117
|
|
|
|
|
|
|
} |
118
|
|
|
|
|
|
|
|
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
# processes an individual resource definition hash and adds Path::Router route |
121
|
|
|
|
|
|
|
# for it |
122
|
|
|
|
|
|
|
sub _process_resource_def { |
123
|
240
|
|
|
240
|
|
529
|
my ( $resource, $resource_def ) = @_; |
124
|
|
|
|
|
|
|
#$log->debug("Entering " . __PACKAGE__. "::_process_resource_def with:" ); |
125
|
240
|
|
|
|
|
1827
|
$log->info("Initializing \$resource ->$resource<-"); |
126
|
|
|
|
|
|
|
#$log->debug("\$resource_def " . Dumper( $resource_def ) ); |
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
# expand all properties except those in %no_expand_map |
129
|
240
|
|
|
|
|
38943
|
foreach my $prop ( keys %$resource_def ) { |
130
|
1160
|
100
|
|
|
|
2378
|
next if exists $no_expand_map{ $prop }; |
131
|
700
|
|
|
|
|
1288
|
_expand_property( $resource, $resource_def, $prop ); |
132
|
|
|
|
|
|
|
} |
133
|
|
|
|
|
|
|
|
134
|
|
|
|
|
|
|
# handle non-expandable properties |
135
|
|
|
|
|
|
|
# |
136
|
|
|
|
|
|
|
# - validations |
137
|
240
|
|
|
|
|
464
|
my $validations = $resource_def->{'validations'}; |
138
|
240
|
100
|
|
|
|
550
|
$resources->{$resource}->{'validations'} = $validations if $resource_def->{'validations'}; |
139
|
|
|
|
|
|
|
# |
140
|
|
|
|
|
|
|
# - documentation |
141
|
240
|
|
|
|
|
397
|
my $documentation = $resource_def->{'documentation'}; |
142
|
240
|
100
|
|
|
|
573
|
$resources->{$resource}->{'documentation'} = $documentation if $resource_def->{'documentation'}; |
143
|
|
|
|
|
|
|
# |
144
|
|
|
|
|
|
|
# - parent |
145
|
240
|
100
|
|
|
|
521
|
if ( $resource ne '/' ) { |
146
|
220
|
|
50
|
|
|
502
|
my $parent = $resource_def->{'parent'} || '/'; |
147
|
220
|
|
|
|
|
312
|
push( @{ $resources->{$parent}->{'children'} }, $resource ); |
|
220
|
|
|
|
|
621
|
|
148
|
220
|
|
|
|
|
458
|
$resources->{$resource}->{'parent'} = $parent; |
149
|
|
|
|
|
|
|
} |
150
|
|
|
|
|
|
|
|
151
|
240
|
|
|
|
|
421
|
return; |
152
|
|
|
|
|
|
|
} |
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
sub _add_route { |
156
|
240
|
|
|
240
|
|
363
|
my $resource = shift; |
157
|
240
|
|
|
|
|
338
|
my %validations; |
158
|
240
|
100
|
|
|
|
541
|
if ( ref( $resources->{$resource}->{'validations'} ) eq 'HASH' ) { |
159
|
20
|
|
|
|
|
52
|
%validations = %{ $resources->{$resource}->{'validations'} }; |
|
20
|
|
|
|
|
107
|
|
160
|
20
|
|
|
|
|
60
|
delete $resources->{$resource}->{'validations'}; |
161
|
|
|
|
|
|
|
} |
162
|
|
|
|
|
|
|
my $ARGS = { |
163
|
240
|
|
|
|
|
826
|
target => $resources->{$resource}, |
164
|
|
|
|
|
|
|
}; |
165
|
240
|
100
|
|
|
|
483
|
$ARGS->{'validations'} = \%validations if %validations; |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
try { |
168
|
240
|
|
|
240
|
|
10717
|
$router->add_route( $resource, %$ARGS ); |
169
|
|
|
|
|
|
|
} catch { |
170
|
0
|
|
|
0
|
|
0
|
$log->crit( $_ ); |
171
|
240
|
|
|
|
|
1710
|
}; |
172
|
|
|
|
|
|
|
} |
173
|
|
|
|
|
|
|
|
174
|
|
|
|
|
|
|
|
175
|
|
|
|
|
|
|
# takes an individual resource definition property, expands it and puts it in |
176
|
|
|
|
|
|
|
# $resources package variable |
177
|
|
|
|
|
|
|
sub _expand_property { |
178
|
700
|
|
|
700
|
|
1150
|
my ( $resource, $resource_def, $prop ) = @_; |
179
|
|
|
|
|
|
|
#$log->debug("Entering " . __PACKAGE__. "::_expand_property with " . |
180
|
|
|
|
|
|
|
# "resource \"$resource\" and property \"$prop\"" ); |
181
|
|
|
|
|
|
|
|
182
|
|
|
|
|
|
|
# set the resource_name property |
183
|
700
|
|
|
|
|
1279
|
$resources->{$resource}->{'resource_name'} = $resource; |
184
|
|
|
|
|
|
|
|
185
|
|
|
|
|
|
|
my @supported_methods = ( ref( $resource_def->{'handler'} ) eq 'HASH' ) |
186
|
480
|
|
|
|
|
1044
|
? keys( %{ $resource_def->{'handler'} } ) |
187
|
700
|
50
|
|
|
|
1430
|
: @{ $site->MREST_SUPPORTED_HTTP_METHODS || [ qw( GET POST PUT DELETE ) ] }; |
|
220
|
100
|
|
|
|
1338
|
|
188
|
700
|
|
|
|
|
7304
|
foreach my $method ( @supported_methods ) { |
189
|
|
|
|
|
|
|
#$log->debug( "Considering the \"$method\" method" ); |
190
|
2140
|
50
|
|
|
|
3051
|
if ( exists $resource_def->{$prop} ) { |
191
|
2140
|
|
|
|
|
2693
|
my $prop_def = $resource_def->{$prop}; |
192
|
2140
|
|
100
|
|
|
4715
|
my $refv = ref( $prop_def ) || 'SCALAR'; |
193
|
|
|
|
|
|
|
#$log->debug( "The definition of this property is a $refv" ); |
194
|
2140
|
100
|
|
|
|
3521
|
if ( $refv eq 'HASH' ) { |
|
|
50
|
|
|
|
|
|
195
|
320
|
50
|
|
|
|
563
|
if ( $prop_def->{$method} ) { |
196
|
320
|
|
|
|
|
793
|
$resources->{$resource}->{$method}->{$prop} = $prop_def->{$method}; |
197
|
|
|
|
|
|
|
} else { |
198
|
0
|
|
|
|
|
0
|
$log->crit( "No $prop defined for $method method in $resource!" ); |
199
|
|
|
|
|
|
|
} |
200
|
|
|
|
|
|
|
} elsif ( $refv eq 'SCALAR' ) { |
201
|
1820
|
|
|
|
|
4160
|
$resources->{$resource}->{$method}->{$prop} = $prop_def; |
202
|
|
|
|
|
|
|
} else { |
203
|
0
|
|
|
|
|
|
die "AAAAAGAAAGAAAAAA! in " . __FILE__ . ", _populate_resources"; |
204
|
|
|
|
|
|
|
} |
205
|
|
|
|
|
|
|
} else { |
206
|
|
|
|
|
|
|
# resource with no def_part: suspicious |
207
|
0
|
|
|
|
|
|
$log->notice( "While walking resource definition tree, " . |
208
|
|
|
|
|
|
|
"encountered resource $resource with missing $prop in its definition" ); |
209
|
|
|
|
|
|
|
} |
210
|
|
|
|
|
|
|
} |
211
|
|
|
|
|
|
|
} |
212
|
|
|
|
|
|
|
|
213
|
|
|
|
|
|
|
1; |