lib/Catalyst/DispatchType/Path.pm

   1 package Catalyst::DispatchType::Path;
   2
   3 use Moose;
   4 extends 'Catalyst::DispatchType';
   5
   6 #use strict;
   7 #use base qw/Catalyst::DispatchType/;
   8 use Text::SimpleTable;
   9 use URI;
  10
  11 =head1 NAME
  12
  13 Catalyst::DispatchType::Path - Path 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 Debug output for Path dispatch points
  26
  27 =cut
  28
  29 sub list {
  30     my ( $self, $c ) = @_;
  31     my $paths = Text::SimpleTable->new( [ 35, 'Path' ], [ 36, 'Private' ] );
  32     foreach my $path ( sort keys %{ $self->{paths} } ) {
  33         my $display_path = $path eq '/' ? $path : "/$path";
  34         foreach my $action ( @{ $self->{paths}->{$path} } ) {
  35             $paths->row( $display_path, "/$action" );
  36         }
  37     }
  38     $c->log->debug( "Loaded Path actions:\n" . $paths->draw . "\n" )
  39       if ( keys %{ $self->{paths} } );
  40 }
  41
  42 =head2 $self->match( $c, $path )
  43
  44 For each action registered to this exact path, offers the action a chance to
  45 match the path (in the order in which they were registered). Succeeds on the
  46 first action that matches, if any; if not, returns 0.
  47
  48 =cut
  49
  50 sub match {
  51     my ( $self, $c, $path ) = @_;
  52
  53     $path ||= '/';
  54
  55     foreach my $action ( @{ $self->{paths}->{$path} || [] } ) {
  56         next unless $action->match($c);
  57         $c->req->action($path);
  58         $c->req->match($path);
  59         $c->action($action);
  60         $c->namespace( $action->namespace );
  61         return 1;
  62     }
  63
  64     return 0;
  65 }
  66
  67 =head2 $self->register( $c, $action )
  68
  69 Calls register_path for every Path attribute for the given $action.
  70
  71 =cut
  72
  73 sub register {
  74     my ( $self, $c, $action ) = @_;
  75
  76     my @register = @{ $action->attributes->{Path} || [] };
  77
  78     $self->register_path( $c, $_, $action ) for @register;
  79
  80     return 1 if @register;
  81     return 0;
  82 }
  83
  84 =head2 $self->register_path($c, $path, $action)
  85
  86 Registers an action at a given path.
  87
  88 =cut
  89
  90 sub register_path {
  91     my ( $self, $c, $path, $action ) = @_;
  92     $path =~ s!^/!!;
  93     $path = '/' unless length $path;
  94     $path = URI->new($path)->canonical;
  95
  96     unshift( @{ $self->{paths}{$path} ||= [] }, $action);
  97
  98     return 1;
  99 }
 100
 101 =head2 $self->uri_for_action($action, $captures)
 102
 103 get a URI part for an action; always returns undef is $captures is set
 104 since Path actions don't have captures
 105
 106 =cut
 107
 108 sub uri_for_action {
 109     my ( $self, $action, $captures ) = @_;
 110
 111     return undef if @$captures;
 112
 113     if (my $paths = $action->attributes->{Path}) {
 114         my $path = $paths->[0];
 115         $path = '/' unless length($path);
 116         $path = "/${path}" unless ($path =~ m/^\//);
 117         $path = URI->new($path)->canonical;
 118         return $path;
 119     } else {
 120         return undef;
 121     }
 122 }
 123
 124 =head1 AUTHOR
 125
 126 Matt S Trout
 127 Sebastian Riedel, C<sri@cpan.org>
 128
 129 =head1 COPYRIGHT
 130
 131 This program is free software, you can redistribute it and/or modify it under
 132 the same terms as Perl itself.
 133
 134 =cut
 135
 136 1;