File Coverage

blib/lib/Catalyst/Plugin/ActionPaths.pm
Criterion Covered Total %
statement 12 85 14.1
branch 0 44 0.0
condition 0 8 0.0
subroutine 4 5 80.0
pod 1 1 100.0
total 17 143 11.8


line stmt bran cond sub pod time code
1 1     1   668 use strict;
  1         2  
  1         39  
2 1     1   5 use warnings;
  1         1  
  1         51  
3             package Catalyst::Plugin::ActionPaths;
4             $Catalyst::Plugin::ActionPaths::VERSION = '0.01';
5 1     1   597 use Encode 'decode_utf8';
  1         13654  
  1         94  
6 1     1   471 use Moose::Role;
  1         393308  
  1         4  
7              
8             #ABSTRACT: get Catalyst actions with example paths included!
9              
10              
11             sub get_action_paths
12             {
13 0     0 1   my $c = shift;
14 0 0 0       die 'get_action_paths() requires a Catalyst context as an argument'
15             unless $c && $c->isa('Catalyst');
16              
17 0           my @actions = ();
18              
19 0           for my $dt (@{$c->dispatcher->dispatch_types})
  0            
20             {
21 0 0         if (ref $dt eq 'Catalyst::DispatchType::Path')
    0          
22             {
23             # taken from Catalyst::DispatchType::Path
24 0           foreach my $path ( sort keys %{ $dt->_paths } ) {
  0            
25 0           foreach my $action ( @{ $dt->_paths->{$path} } ) {
  0            
26 0           my $args = $action->number_of_args;
27 0 0         my $parts = defined($args) ? '/*' x $args : '/...';
28              
29 0           my $display_path = "/$path/$parts";
30 0           $display_path =~ s{/{1,}}{/}g;
31 0           $display_path =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; # deconvert urlencoded for pretty view·
  0            
32 0           $display_path = decode_utf8 $display_path; # URI does encoding
33 0           $action->{path} = $display_path;
34 0           push @actions, $action;
35             }
36             }
37             }
38             elsif (ref $dt eq 'Catalyst::DispatchType::Chained')
39             {
40             # taken from Catalyst::DispatchType::Chained
41 0           ENDPOINT: foreach my $endpoint (
  0            
42 0           sort { $a->reverse cmp $b->reverse }
43             @{ $dt->_endpoints }
44             ) {
45 0           my $args = $endpoint->list_extra_info->{Args};
46 0 0         my @parts = (defined($endpoint->attributes->{Args}[0]) ? (("*") x $args) : '...');
47 0           my @parents = ();
48 0           my $parent = "DUMMY";
49 0           my $extra = $dt->_list_extra_http_methods($endpoint);
50 0           my $consumes = $dt->_list_extra_consumes($endpoint);
51 0           my $scheme = $dt->_list_extra_scheme($endpoint);
52 0           my $curr = $endpoint;
53 0           my $action = $endpoint;
54 0           while ($curr) {
55 0 0         if (my $cap = $curr->list_extra_info->{CaptureArgs}) {
56 0           unshift(@parts, (("*") x $cap));
57             }
58 0 0         if (my $pp = $curr->attributes->{PathPart}) {
59 0 0 0       unshift(@parts, $pp->[0])
60             if (defined $pp->[0] && length $pp->[0]);
61             }
62 0           $parent = $curr->attributes->{Chained}->[0];
63 0           $curr = $dt->_actions->{$parent};
64 0 0         unshift(@parents, $curr) if $curr;
65             }
66 0 0         if ($parent ne '/') {
67 0           next ENDPOINT;
68             }
69 0           my @rows;
70 0           foreach my $p (@parents) {
71 0           my $name = "/${p}";
72              
73 0 0         if (defined(my $extra = $dt->_list_extra_http_methods($p))) {
74 0           $name = "${extra} ${name}";
75             }
76 0 0         if (defined(my $cap = $p->list_extra_info->{CaptureArgs})) {
77 0 0         if($p->has_captures_constraints) {
78 0           my $tc = join ',', @{$p->captures_constraints};
  0            
79 0           $name .= " ($tc)";
80             } else {
81 0           $name .= " ($cap)";
82             }
83             }
84 0 0         if (defined(my $ct = $p->list_extra_info->{Consumes})) {
85 0           $name .= ' :'.$ct;
86             }
87 0 0         if (defined(my $s = $p->list_extra_info->{Scheme})) {
88 0           $scheme = uc $s;
89             }
90              
91 0 0         unless ($p eq $parents[0]) {
92 0           $name = "-> ${name}";
93             }
94 0           push(@rows, [ '', $name ]);
95             }
96              
97 0 0         if($endpoint->has_args_constraints) {
98 0           my $tc = join ',', @{$endpoint->args_constraints};
  0            
99 0           $endpoint .= " ($tc)";
100             } else {
101 0 0         $endpoint .= defined($endpoint->attributes->{Args}[0]) ? " ($args)" : " (...)";
102             }
103 0 0         push(@rows, [ '', (@rows ? "=> " : '').($extra ? "$extra " : ''). ($scheme ? "$scheme: ":'')."/${endpoint}". ($consumes ? " :$consumes":"" ) ]);
    0          
    0          
    0          
104 0           my @display_parts = map { $_ =~s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; decode_utf8 $_ } @parts;
  0            
  0            
  0            
105 0   0       $rows[0][0] = join('/', '', @display_parts) || '/';
106 0           $action->{path} = $rows[0][0];
107 0           push @actions, $action;
108             }
109             }
110             }
111 0           return \@actions;
112             }
113              
114             1;
115              
116             __END__
117              
118             =pod
119              
120             =encoding UTF-8
121              
122             =head1 NAME
123              
124             Catalyst::Plugin::ActionPaths - get Catalyst actions with example paths included!
125              
126             =head1 VERSION
127              
128             version 0.01
129              
130             =head1 DESCRIPTION
131              
132             This is an early-release plugin for Catalyst. It adds the method C<get_action_paths> to the Catalyst context object.
133              
134             This plugin makes it easier to retrieve every loaded action path and chained path in your Catalyst application, usually for testing purposes.
135              
136             To use the plugin, just install it and append the plugin name in your application class e.g. F<lib/MyApp.pm>
137              
138             use Catalyst 'ActionPaths';
139              
140             =head1 METHODS
141              
142             =head2 get_action_paths
143              
144             Returns an arrayref of C<Catalyst::Actions> objects, with a path attribute added. The path is an example path for the action, e.g.:
145              
146             my $actions = $c->get_action_paths;
147              
148             print $actions->[0]{path}; # /some/*/path/*
149              
150             =head1 AUTHOR
151              
152             David Farrell <dfarrell@cpan.org>
153              
154             =head1 COPYRIGHT AND LICENSE
155              
156             This software is Copyright (c) 2015 by David Farrell.
157              
158             This is free software, licensed under:
159              
160             The (two-clause) FreeBSD License
161              
162             =cut