File Coverage

lib/Catalyst/Plugin/Server/XMLRPC/DispatchType/XMLRPCPath.pm
Criterion Covered Total %
statement 32 64 50.0
branch 13 30 43.3
condition 3 6 50.0
subroutine 6 8 75.0
pod 4 4 100.0
total 58 112 51.8


line stmt bran cond sub pod time code
1             package Catalyst::Plugin::Server::XMLRPC::DispatchType::XMLRPCPath;
2              
3 6     6   91 use strict;
  6         138  
  6         168  
4 6     6   94 use base qw/Catalyst::DispatchType::Path/;
  6         55  
  6         93  
5 6     6   134 use Text::SimpleTable;
  6         59  
  6         101  
6 6     6   114 use Data::Dumper;
  6         112  
  6         207  
7              
8             __PACKAGE__->mk_accessors(qw/config/);
9             __PACKAGE__->mk_ro_accessors(qw/paths/);
10              
11             =head1 NAME
12            
13             Catalyst::Plugin::Server::XMLRPC::DispatchType::XMLRPCPath - XMLRPCPath DispatchType
14            
15             =head1 SYNOPSIS
16            
17             See L<Catalyst>.
18            
19             =head1 DESCRIPTION
20            
21             =head1 METHODS
22            
23             =head2 $self->list($c)
24            
25             Generates a nice debug-table containing the XMLRPCPath methods.
26            
27             =cut
28              
29             sub list {
30 0     0 1 0     my ( $self, $c ) = @_;
31 0         0     my $prefixwarning = 1;
32              
33             ### Because this is the only place where we need the config
34 0         0     $self->config( $c->server->xmlrpc->config );
35              
36 0         0     my $paths = Text::SimpleTable->new(
37                                         [ 36, 'XMLRPCPath Method' ],
38                                         [ 37, 'Private' ]
39                                     );
40              
41 0         0     for my $method ( sort keys %{ $self->methods($c) } ) {
  0         0  
42 0         0         my $action = $self->methods($c)->{$method};
43 0         0         $paths->row( $method, "/$action" );
44                 }
45              
46 0         0     $c->log->debug( "Loaded XMLRPC entrypoint:\n host.tld" .
47                                     $self->config->path);
48 0         0     $c->log->debug( "Loaded XMLRPCPath Method actions:\n" . $paths->draw )
49 0 0       0       if ( keys %{ $self->methods($c) } );
50 0 0 0     0     $c->log->debug( 'WARNING: XMLRPC prefix set, but _not_ used!' ) if
51                                 ($prefixwarning && $self->config->prefix);
52              
53             }
54              
55             =head2 $self->methods()
56            
57             Returns a hashref containing 'methods' => action_object mappings. Methods
58             are in the form of "example.bla.get"
59            
60             =cut
61              
62             sub methods {
63 0     0 1 0     my ( $self, $c ) = @_;
64 0         0     my $prefixwarning = 1;
65              
66             ### Cached list of method => path mapping
67 0 0       0     return $self->{methods} if $self->{methods};
68 0         0     $self->{methods} = {};
69              
70             ### Because this is the only place where we need the config
71 0 0       0     $self->config( $c->server->xmlrpc->config)
72                         unless $self->config;
73              
74 0         0     for my $path ( sort keys %{ $self->{paths} } ) {
  0         0  
75 0 0       0         my $action = UNIVERSAL::isa($self->{paths}->{$path}, 'ARRAY') ?
76                             $self->{paths}->{$path}->[0] : $self->{paths}->{$path};
77 0 0       0         $path = "/$path" unless $path eq '/';
78 0         0         my ($method) = $path =~ m|^/?(.*)$|;
79 0         0         my $seperator= $self->config->seperator;
80 0         0         my $prefix = $self->config->prefix;
81 0         0         $method =~ s|/|$seperator|g;
82 0         0         $method =~ s|^$prefix\.||g;
83 0         0         $self->{methods}->{$method} = $action;
84                 }
85              
86 0         0     return $self->{methods};
87             }
88              
89             =head2 $self->register( $c, $action )
90            
91             Registers the XMLRPCPath actions into the dispatcher
92            
93             =cut
94              
95             sub register {
96 191     191 1 2501     my ( $self, $c, $action ) = @_;
97              
98 191         3679     my $attrs = $action->attributes;
99 191         1707     my @register;
100              
101 191 100       1969     foreach my $r ( @{ $attrs->{XMLRPCPath} || [] } ) {
  191         3193  
102 20 50       319         unless ($r) {
    50          
103 0         0             $r = $action->namespace;
104 0 0       0             $r = '/' unless $r;
105                     }
106                     elsif ( $r !~ m!^/! ) { # It's a relative path
107 0         0             $r = $action->namespace . "/$r";
108                     }
109 20         264         push( @register, $r );
110                 }
111              
112 191 50       2413     if ( $attrs->{XMLRPCGlobal} ) {
113 0         0         push( @register, $action->name ); # Register sub name against root
114                 }
115              
116 191 100 100     2469     if ( $attrs->{XMLRPCLocal} || $attrs->{XMLRPC} ) {
117 25         338         push( @register, join( '/', $action->namespace, $action->name ) );
118              
119             # Register sub name as a relative path
120                 }
121              
122 191         1564     $self->register_path( $c, $_, $action ) for @register;
  191         2787  
123              
124 191         2692     $c->server->xmlrpc->dispatcher->{Path} = $self
125 191 100       1707         unless (scalar %{$c->server->xmlrpc->dispatcher});
126              
127 191 100       2631     return 1 if @register;
128 146         1729     return 0;
129             }
130              
131             sub match {
132 29     29 1 14721     my $self = shift;
133 29         339     my ($c, $name) = @_;
134              
135             ### This subtile line is available to prevent backing up to
136             ### a default action
137 29 100       328     return unless $c->req->path eq $name;
138              
139 17         1354     $self->SUPER::match( @_ );
140             }
141              
142              
143             =head1 AUTHOR
144            
145             Michiel Ootjers C<michiel@cpan.org>
146             Jos Boumans, C<kane@cpan.org>
147            
148             =head1 COPYRIGHT
149            
150             This program is free software, you can redistribute it and/or modify it under
151             the same terms as Perl itself.
152            
153             =cut
154              
155             1;
156