view release on metacpan or  search on metacpan

lib/CGI/Application/Plugin/Routes.pm  view on Meta::CPAN

package CGI::Application::Plugin::Routes;
use strict;
use Carp;

use vars qw($VERSION @ISA @EXPORT);

our $VERSION = '1.02';

sub import {
    my $pkg     = shift;
    my $callpkg = caller;

    # Do our own exporting.
    {
        no strict qw(refs);
        *{ $callpkg . '::routes' } = \&CGI::Application::Plugin::Routes::routes;
        *{ $callpkg . '::routes_parse' } = \&CGI::Application::Plugin::Routes::routes_parse;
        *{ $callpkg . '::routes_dbg' } = \&CGI::Application::Plugin::Routes::routes_dbg;
        *{ $callpkg . '::routes_root' } = \&CGI::Application::Plugin::Routes::routes_root;
        *{ $callpkg . '::routes_params' } = \&CGI::Application::Plugin::Routes::routes_params;
        
    }

    if ( ! UNIVERSAL::isa($callpkg, 'CGI::Application') ) {
        warn "Calling package is not a CGI::Application module so not setting up the prerun hook.  If you are using \@ISA instead of 'use base', make sure it is in a BEGIN { } block, and make sure these statements appear before the plugin is loaded";
    }
    elsif ( ! UNIVERSAL::can($callpkg, 'add_callback')) {
        warn "You are using an older version of CGI::Application that does not support callbacks, so the prerun method can not be registered automatically (Lookup the prerun_callback method in the docs for more info)";
    }
    else {
	    #Add the required callback to the CGI::Application app so it executes the routes_parse sub on the prerun stage
        $callpkg->add_callback( prerun => 'routes_parse' );
    }
}

sub routes {
	my ($self, $table) = @_;
	$self->{'Application::Plugin::Routes::__dispatch_table'} = $table;
    #register every runmode declared.
	for(my $i = 1 ; $i < scalar(@$table) ; $i += 2) {
        my $rm_name = $table->[$i];
        $self->run_modes([$rm_name]);
	}
}

sub routes_dbg {
	my $self = shift;
    require Data::Dumper;
	return Dumper($self->{'Application::Plugin::Routes::__r_params'});
}

sub routes_root{
	my ($self, $root) = @_;
	#make sure no trailing slash is present on the root.
	$root =~ s/\/$//;
	$self->{'Application::Plugin::Routes::__routes_root'} = $root;
}

sub routes_params{
   my ($self) = shift;
   if ( @_ ){
       $self->{'Application::Plugin::Routes::__routes_params'} = [ @_ ];
   }
   return $self->{'Application::Plugin::Routes::__routes_params'};
}

sub routes_parse {
	#all this routine, except a few own modifications was borrowed from the wonderful
	# Michael Peter's CGI::Application::Dispatch module that can be found here:
	# http://search.cpan.org/~wonko/CGI-Application-Dispatch/
	my ($self) = @_;
	my $path = $self->query->path_info;
	# get the module name from the table
	my $table = $self->{'Application::Plugin::Routes::__dispatch_table'};
	unless(ref($table) eq 'ARRAY') {
		carp "[__parse_path] Invalid or no dispatch table!\n";
		return;
	}
	# look at each rule and stop when we get a match
	for(my $i = 0 ; $i < scalar(@$table) ; $i += 2) {
		my $rule = $self->{'Application::Plugin::Routes::__routes_root'} . $table->[$i];
		my @names = ();
		# translate the rule into a regular expression, but remember where the named args are
		# '/:foo' will become '/([^\/]*)'
		# and
		# '/:bar?' will become '/?([^\/]*)?'
		# and then remember which position it matches
		$rule =~ s{