Apache2::Controller::Dispatch::HashTree - Apache2::Controller::Dispatch::HashTree documentation

 <Location "/subdir">
     SetHandler modperl
     PerlInitHandler MyApp::Dispatch
 </Location>

 # lib/MyApp::Dispatch:

 package MyApp::Dispatch;
 use base qw(
     Apache2::Controller::Dispatch::HashTree
 );

 # return a hash reference from dispach_map()
 sub dispatch_map { return {
    foo => {
        default     => 'MyApp::C::Foo',
        bar => {
            biz         => 'MyApp::C::Biz',
            baz         => 'MyApp::C::Baz',
        },
    },
    default => 'MyApp::C::Default',
 } }

 1;
 __END__

 /subdir/foo                    MyApp::C::Foo->default()

 /subdir/foo/bar                MyApp::C::Foo->bar()

 /subdir/foo/bar/zerm           MyApp::C::Foo->bar(), path_args == ['zerm']

 /subdir/foo/bar/biz            MyApp::C::Biz->default()

 /subdir/foo/biz/baz/noz/wiz    MyApp::C::Baz->noz(), path_args == ['wiz']

package Apache2::Controller::Dispatch::HashTree;

use version;
our $VERSION = version->new('1.000.111');

use strict;
use warnings FATAL => 'all';
use English '-no_match_vars';
use Carp qw( confess );

use base qw( Apache2::Controller::Dispatch );

use Apache2::Controller::X;
use Apache2::Controller::Funk qw( controller_allows_method check_allowed_method );

use Log::Log4perl qw(:easy);
use YAML::Syck;

sub find_controller {
    my ($self) = @_;
    my $dispatch_map = $self->get_dispatch_map();
    my $r = $self->{r};
    my $location = $r->location();
    my $uri = $r->uri();
    my $uri_below_loc = substr $uri, length $location;

    DEBUG(sub{Dump({
        uri             => $uri,
        uri_below_loc   => $uri_below_loc,
        location        => $location,
    })});

    # efficiently split up the uri into an array of path parts
    my @path;
    my $j = 0;
    my $uri_len = length $uri_below_loc;
    my $last_char_idx = $uri_len - 1;
    my $prev_char = q{};
    my $uri_without_leading_slash = '';
    CHAR:
    for (my $i = 0; $i <= $last_char_idx; $i++) {
        my $char = substr $uri_below_loc, $i, 1;
        DEBUG(sub { "j=$j; char $i = '$char' (".ord($char).")" });
        if ($char eq '/') {
            # skip over first /
            if ($i == 0) {
                $prev_char = $char;
                next CHAR;
            }

            # skip over repeat //'s
            next CHAR if $char eq $prev_char;

            # skip a trailing /
            last CHAR if $i == $last_char_idx;

            # not skipped, so iterate the path counter
            $j++;
        }
        else {
            $path[$j] .= $char;
            DEBUG("added $char to path[$j] ($path[$j])");
        }
        $prev_char = $char;
        $uri_without_leading_slash .= $char;
    }
    $uri_below_loc = $uri_without_leading_slash;
    DEBUG("uri_below_loc is now $uri_below_loc");

    # follow these keys through the hash and push remaining path parts
    # to an array for after we're done searching for the method
    my $node = $dispatch_map;

    DEBUG(sub{"path: (@path)"});

    my @trace_path;
    @trace_path = map { 
        ref $node   # wow, i didn't know you could do this...
            ? do { $node = $node->{$_}; $node }
            : undef
    } @path;
    DEBUG(sub{"dispatch hash trace_path:\n".Dump(\@trace_path)});
    
    my %results = ();
    my @path_args;

    FIND_NODE:
    for (my $i = $#trace_path; $i >= 0; $i--) {

        next FIND_NODE if !exists $trace_path[$i];

        my $node = $trace_path[$i];

        my $part = $path[$i];

        DEBUG(sub { "part = '$part', i = $i, path=(@path), node = ".Dump($node) });

        my $ref  = ref $node;

        my $maybe_method = $path[$i + 1];
        my $maybe_controller = $ref ? $node->{default} : $node;

        next FIND_NODE if !$maybe_controller;  # no default specified, no matches

        DEBUG(sub {
            "ctrl? => '$maybe_controller', method? => ".($maybe_method || '[none]')
        });

        if  (   $maybe_method
            &&  controller_allows_method($maybe_controller => $maybe_method)
            ) {
            # got it!
            $results{controller}    = $maybe_controller;
            $results{method}        = $maybe_method;
            $results{relative_uri}  = join('/', @path[ 0 .. $i ]);
            @path_args              = @path[ $i + 2 .. $#path ];
            last FIND_NODE;
        }
        else {  # maybe 'default' here?
            if (controller_allows_method($maybe_controller => 'default')) {
                $results{controller}    = $maybe_controller;
                $results{method}        = 'default';
                $results{relative_uri}  = join('/', @path[ 0 .. $i ]);
                @path_args              = @path[ $i + 1 .. $#path ];
                last FIND_NODE;
            }
            else {
                # not here... go back one
                next FIND_NODE;
            }
        }
    }

    # if still no controller, select the default
    if (!$results{controller}) {
        my $ctrl = $dispatch_map->{default};

        a2cx "$uri no default controller" if !$ctrl;

        a2cx "$uri no references allowed in dispatch_map for default"
            if ref $ctrl;

        $results{controller} = $ctrl;

        # and find a method.
        my $maybe_method = $path[0];
        if  (   $maybe_method 
            &&  controller_allows_method($results{controller}, $maybe_method)
            ) {
            $results{method} = $maybe_method;
            @path_args = @path[ 1 .. $#path ] if exists $path[1];
        }
        elsif (controller_allows_method($results{controller}, 'default')) {
            $results{method} = 'default';
            @path_args = @path[ 0 .. $#path ] if exists $path[0];
        }
        else {
            a2cx "$uri cannot find a working method in $results{controller}";
        }

        # relative uri is ''
        $results{relative_uri} = '';
    }

    DEBUG(sub{Dump({
        path_args => \@path_args,
        results => \%results,
    })});

    # make sure this worked
    a2cx "did not detect $_"
        for grep !exists $results{$_}, 
        qw( controller method relative_uri );

    # save the info in pnotes
    my $pnotes = $r->pnotes;
    $pnotes->{a2c}{$_} = $results{$_} for keys %results;
    $pnotes->{a2c}{path_args} = \@path_args;

    # now try finding a matching module in dispatch_map

    #######################################################
    return $results{controller};
}

1;