| 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; |