view release on metacpan or  search on metacpan

lib/Catalyst/ControllerRole/URI.pm  view on Meta::CPAN

  my @parents = ();
  my $parent = "DUMMY";
  my $extra  = $dispatcher->_list_extra_http_methods($endpoint);
  my $consumes = $dispatcher->_list_extra_consumes($endpoint);
  my $scheme = $dispatcher->_list_extra_scheme($endpoint);
  my $curr = $endpoint;
  while ($curr) {
      if (my $cap = $curr->list_extra_info->{CaptureArgs}) {
          if($curr->has_captures_constraints) {
              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 = $dispatcher->_actions->{$parent};
      unshift(@parents, $curr) if $curr;
  }
  my @path_args = ();
  foreach my $p (@parents) {
      my $name = "/${p}";

      if (defined(my $extra = $dispatcher->_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)";
            push @path_args, $tc if $tc;
          } else {
            $name .= " ($cap)";
            push @path_args, $cap if $cap;
          }
      }
      if (defined(my $ct = $p->list_extra_info->{Consumes})) {
          $name .= ' :'.$ct;
      }
      if (defined(my $s = $p->list_extra_info->{Scheme})) {
          $scheme = uc $s;
      }
  }

  my @display_parts = map { $_ =~s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; decode_utf8 $_ } @parts;
  my $path = join('/', '', @display_parts) || '/';
  $path = "${extra} ${path}" if $extra;

  return $path, \@path_args;
}

sub _normalize_uri_args {
  my $self = shift;
  my $parts_proto = shift if $_[0] && ((ref($_[0]) eq 'ARRAY') || ( blessed($_[0]) ));
  my $query = shift if $_[0] && (ref($_[0]) eq 'HASH');
  my $fragment = shift if $_[0] && (ref($_[0]) eq 'SCALAR');

  my $c = $self->ctx;
  my @parts = ();

  # If parts are passed in then use them. If just one and its a blessed object
  # then use its id. If an arrayref then use the ids of the objects.
  if(blessed $parts_proto) {
    push @parts, $parts_proto->id;
  } elsif(ref($parts_proto) eq 'ARRAY') {
    my @part_ids = map { blessed $_ ? $_->id : $_ } @$parts_proto;
    push @parts, @part_ids;
  }

  my @return_args = (\@parts);
  push @return_args, $query if $query;
  push @return_args, $fragment if $fragment;

  return @return_args;
}

1;

=head1 NAME
 
Catalyst::ControllerRole::URI - Inject local URI helpers

=head1 SYNOPSIS

    package Example::Controller::Register;

    use Moose;
    use MooseX::MethodAttributes;

    extends 'Catalyst::ControllerPerRequest';
    with 'Catalyst::ControllerRole::URI';


=head1 DESCRIPTION

Experimental role for L<Catalyst::ControllerPerRequest> that injects URI helper methods 
into your controller and application.  This is a work in progress and may change in the future.

I'm not documenting this more, if you can't follow the source you shouldn't be
using this.   I may trash it eventually.

=head1 ALSO SEE
 
L<Catalyst::Runtime>, L<Catalyst::Controller>

=head1 AUTHOR

    John Napiorkowski <jjnapiork@cpan.org>

=head1 COPYRIGHT
 
    2023

=head1 LICENSE

This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself.