view release on metacpan or  search on metacpan

lib/Catalyst/Plugin/CachedUriForAction.pm  view on Meta::CPAN

		my $n_args = $xa->number_of_args; # might be undef to mean "any number"
		my $tmpl = $c->uri_for( $action, [ ("\0\0\0\0") x $n_caps ], ("\0\0\0\0") x ( $n_args || 0 ) );
		my ( $prefix, @part ) = split /%00%00%00%00/, $tmpl, -1;
		$prefix =~ s!\A/!!;
		$cache->{ '/' . $action->reverse } = [ $n_caps, $n_args, \@part, $prefix ];
	}
}

sub uri_for_action {
	my $c = shift;

	my $dispatcher = $c->dispatcher;
	my $cache = $dispatcher && $dispatcher->{(CACHE_KEY)}
		or return $c->next::method( @_ ); # fall back if called too early

	my $action   = shift;
	my $captures = @_ && 'ARRAY'  eq ref $_[0]  ? shift : [];
	my $fragment = @_ && 'SCALAR' eq ref $_[-1] ? pop   : undef;
	my $params   = @_ && 'HASH'   eq ref $_[-1] ? pop   : undef;

	$action = '/' . $dispatcher->get_action_by_path( $action )->reverse
		if ref $action
		and do { local $@; eval { $action->isa( 'Catalyst::Action' ) } };

	my $info = $cache->{ $action }
		or Carp::croak "Can't find action for path '$action' in uri_for_action";

	my ( $uri, $base ) = '';
	if ( ref $c ) {
		$base = $c->request->base;
		$uri = '/' if $$base !~ m!/\z!;
	} else { # fallback if called as class method
		$base = bless \( my $tmp = '' ), 'URI::_generic';
		$uri = '/';
	}

	my ( $n_caps, $n_args, $extra_parts ) = @$info;
	$uri .= $info->[-1];

	# this is not very sensical but it has to be like this because it is what Catalyst does:
	# the :Args() case (i.e. any number of args) is grouped with the :Args(0) case (i.e. no args)
	# instead of being grouped with with the :Args(N) case (i.e. a fixed non-zero number of args)
	if ( $n_args ) {
		Carp::croak "Not enough captures for path '$action' (need $n_caps) in uri_for_action"
			if @$captures < $n_caps;
	} else {
		Carp::croak "Wrong number of captures for path '$action' (need $n_caps) in uri_for_action"
			if @$captures != $n_caps;
	}

	# the following is carefully written to
	# - loop over every input array exactly once
	# - avoid any conditionals inside each loop body
	# - use only simple loop forms that are specially optimised by the perl interpreter
	my $i = -1;
	if ( defined $n_args ) { # the non-slurpy case
		Carp::croak "Wrong number of args+captures for path '$action' (need ".@$extra_parts.") in uri_for_action"
			if ( @$captures + @_ ) != @$extra_parts;
		# and now since @$extra_parts is exactly the same length as @$captures and @_ combined
		# iterate over those arrays and use a cursor into @$extra_parts to interleave its elements
		for ( @$captures ) { ( $uri .= uri_encode_utf8 $_ ) .= $extra_parts->[ ++$i ] }
		for ( @_ )         { ( $uri .= uri_encode_utf8 $_ ) .= $extra_parts->[ ++$i ] }
	} else {
		# in the slurpy case, the size of @$extra_parts is determined by $n_caps alone since $n_args was undef
		# and as we checked above @$captures alone has at least length $n_caps
		# so we will need all of @$captures to cover @$extra_parts, and may then still have some of it left over
		# so iterate over @$extra_parts and use a cursor into @$captures to interleave its elements
		for ( @$extra_parts )       { ( $uri .= uri_encode_utf8 $captures->[ ++$i ] ) .= $_ }
		# and then append the rest of @$captures, and then everything from @_ after that
		for ( ++$i .. $#$captures ) { ( $uri .= '/' ) .= uri_encode_utf8 $captures->[ $_ ] }
		for ( @_ )                  { ( $uri .= '/' ) .= uri_encode_utf8 $_ }
	}

	$uri =~ s/%2B/+/g;
	substr $uri, 0, 0, $$base;

	if ( defined $params ) {
		my $query = '';
		my $delim = $URI::DEFAULT_QUERY_FORM_DELIMITER || '&';
		my ( $v, $enc_key );
		for my $key ( sort keys %$params ) {
			$v = $params->{ $key };
			if ( 'ARRAY' ne ref $v ) {
				( $query .= $delim ) .= uri_encode_utf8 $key;
				( $query .= '=' ) .= uri_encode_utf8 $v if defined $v;
			} elsif ( @$v ) {
				$enc_key = $delim . uri_encode_utf8 $key;
				for ( @$v ) {
					$query .= $enc_key;
					( $query .= '=' ) .= uri_encode_utf8 $_ if defined;
				}
			}
		}
		if ( '' ne $query ) {
			$query =~ s/%20/+/g;
			( $uri .= '?' ) .= substr $query, length $delim;
		}
	}

	if ( defined $fragment ) {
		( $uri .= '#' ) .= uri_encode_utf8 $$fragment;
	}

	bless \$uri, ref $base;
}

BEGIN { delete $Catalyst::Plugin::CachedUriForAction::{'uri_encode_utf8'} }

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Catalyst::Plugin::CachedUriForAction - drop-in supercharger for uri_for_action

=head1 SYNOPSIS

 use Catalyst qw( CachedUriForAction );

=head1 DESCRIPTION

This provides a (mostly) drop-in replacement version of C<uri_for_action>.