view release on metacpan or  search on metacpan

lib/Catalyst/DispatchType/Chained.pm  view on Meta::CPAN

                    my $names = join '/', map { "{$_}" } $curr->all_captures_constraints;
                    unshift(@parts, $names);
                } else {
                    unshift(@parts, (("*") x $cap));
                }
            }
            if (my $pp = $curr->attributes->{PathPart}) {
                unshift(@parts, $pp->[0])
                    if (defined $pp->[0] && length $pp->[0]);
            }
            $parent = $curr->attributes->{Chained}->[0];
            $curr = $self->_actions->{$parent};
            unshift(@parents, $curr) if $curr;
        }
        if ($parent ne '/') {
            $has_unattached_actions = 1;
            $unattached_actions->row('/' . ($parents[0] || $endpoint)->reverse, $parent);
            next ENDPOINT;
        }
        my @rows;
        foreach my $p (@parents) {
            my $name = "/${p}";

            if (defined(my $extra = $self->_list_extra_http_methods($p))) {
                $name = "${extra} ${name}";
            }
            if (defined(my $cap = $p->list_extra_info->{CaptureArgs})) {
                if($p->has_captures_constraints) {
                  my $tc = join ',', @{$p->captures_constraints};
                  $name .= " ($tc)";
                } else {
                  $name .= " ($cap)";
                }
            }
            if (defined(my $ct = $p->list_extra_info->{Consumes})) {
                $name .= ' :'.$ct;
            }
            if (defined(my $s = $p->list_extra_info->{Scheme})) {
                $scheme = uc $s;
            }

            unless ($p eq $parents[0]) {
                $name = "-> ${name}";
            }
            push(@rows, [ '', $name ]);
        }

        my $endpoint_arg_info = $endpoint;
        if($endpoint->has_args_constraints) {
          my $tc = join ',', @{$endpoint->args_constraints};
          $endpoint_arg_info .= " ($tc)";
        } else {
          $endpoint_arg_info .= defined($endpoint->attributes->{Args}[0]) ? " ($args)" : " (...)";
        }
        push(@rows, [ '', (@rows ? "=> " : '').($extra ? "$extra " : ''). ($scheme ? "$scheme: ":'')."/${endpoint_arg_info}". ($consumes ? " :$consumes":"" ) ]);
        my @display_parts = map { $_ =~s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; decode_utf8 $_ } @parts;
        $rows[0][0] = join('/', '', @display_parts) || '/';
        $paths->row(@$_) for @rows;
    }

    $c->log->debug( "Loaded Chained actions:\n" . $paths->draw . "\n" );
    $c->log->debug( "Unattached Chained actions:\n", $unattached_actions->draw . "\n" )
        if $has_unattached_actions;
}

sub _list_extra_http_methods {
    my ( $self, $action ) = @_;
    return unless defined $action->list_extra_info->{HTTP_METHODS};
    return join(', ', @{$action->list_extra_info->{HTTP_METHODS}});

}

sub _list_extra_consumes {
    my ( $self, $action ) = @_;
    return unless defined $action->list_extra_info->{CONSUMES};
    return join(', ', @{$action->list_extra_info->{CONSUMES}});
}

sub _list_extra_scheme {
    my ( $self, $action ) = @_;
    return unless defined $action->list_extra_info->{Scheme};
    return uc $action->list_extra_info->{Scheme};
}

=head2 $self->match( $c, $path )

Calls C<recurse_match> to see if a chain matches the C<$path>.

=cut

sub match {
    my ( $self, $c, $path ) = @_;

    my $request = $c->request;
    return 0 if @{$request->args};

    my @parts = split('/', $path);

    my ($chain, $captures, $parts) = $self->recurse_match($c, '/', \@parts);

    if ($parts && @$parts) {
        for my $arg (@$parts) {
            $arg =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
            push @{$request->args}, $arg;
        }
    }

    return 0 unless $chain;

    my $action = Catalyst::ActionChain->from_chain($chain);

    $request->action("/${action}");
    $request->match("/${action}");
    $request->captures($captures);
    $c->action($action);
    $c->namespace( $action->namespace );

    return 1;
}

=head2 $self->recurse_match( $c, $parent, \@path_parts )