Perl subroutine returning unexpected value - perl

Question

I am extending CGI and trying to add a simple router to it, just for fun.
Here are my Test::More tests
use strict;
use warnings;
use Data::Dumper;
use Test::More tests => 4;
use CGI::Router;
my $router = CGI::Router->new;
my $resp;
## 1. test ##
$ENV{'REQUEST_URI'} = '/';
$ENV{'REQUEST_METHOD'} = 'GET';
$resp = $router->connect('GET /', sub {
# print Dumper #_;
return 'Hello 1';
});
# print Dumper $resp;
ok( $resp eq 'Hello 1' );
## 2. test ##
$ENV{'REQUEST_URI'} = '/hello';
$ENV{'REQUEST_METHOD'} = 'GET';
$resp = $router->connect('GET /hello', sub {
# print Dumper #_;
return 'Hello 2';
});
# print Dumper $resp;
ok( $resp eq 'Hello 2' );
## 3. test ##
$ENV{'REQUEST_URI'} = '/hello/kitty';
$ENV{'REQUEST_METHOD'} = 'GET';
$resp = $router->connect('GET /hello/:who', sub {
# print Dumper #_;
return 'Hello 3';
});
# print Dumper $resp;
ok( $resp eq 'Hello 3' );
## 4. test ##
$ENV{'REQUEST_URI'} = '/hello/kitty/kat';
$ENV{'REQUEST_METHOD'} = 'GET';
$resp = $router->connect('GET /hello/:who/:what', sub {
# print Dumper #_;
return 'Hello kitty kat';
});
# print Dumper $resp;
ok( $resp eq 'Hello kitty kat' );
$router->run;
Here is my module
package CGI::Router;
use strict;
use warnings;
use parent 'CGI';
use Carp;
use Data::Dumper;
sub connect {
my ( $self, $req, $subr ) = #_;
$self->{routes} //= {};
$self->{env} //= \%ENV;
if ( ! exists $self->{routes}->{$req} ) {
$self->{routes}->{$req} = {
handler => $subr,
pattern => $self->build_pattern( $req ),
method => $req =~ /^(GET|PUT|POST|DELETE)/
};
} else {
Carp::croak( "Similar request already exists $req!" );
}
# Get current request destination
# TODO: Add that stupid IIS HTTP header
$self->{destination} = $self->{env}->{REQUEST_URI};
$self->{method} = $self->{env}->{REQUEST_METHOD};
return $self->mapper();
}
sub mapper {
my $self = shift;
my $router;
my #params;
foreach my $key ( keys %{ $self->{routes} } ) {
my $route = $self->{routes}->{$key};
if ( $self->{method} eq $route->{method} &&
$self->{destination} =~ $route->{pattern} ) {
#params = $self->{destination} =~ $route->{pattern};
$router = $route;
}
}
return $router->{handler}->( #params );
}
sub build_pattern {
my ( $self, $pattern ) = #_;
$pattern =~ s/(GET|POST|PUT|DELETE)\s?//i;
$pattern = do {
# Replace something like /word/:token with /word/(^:([a-z]+))
$pattern =~ s!
(\:([a-z]+))
!
if ( $2 ) {
"([^/]+)"
}
!gex;
"^$pattern\$";
};
return $pattern;
}
sub run {
}
1;
When the test cases run and I Dump e.g $resp in ## 4. test ## the returned value is not some version of "Hello kitty" but 'GET'.
Here is the output of the test
1..4
ok 1
ok 2
ok 3
ok 4
Why do all the subroutines return 'GET', I don't see where I generate this output.
I know a ton of similar frameworks exists, I am just doing this for fun :)

Answer 1

I modified your code to work/not error. Take it or leave it ;)
CGI/Router.pm:
Things changed:
build_pattern returns a compiled regex via qr/$pattern/
connect param handling is less confusing. You were taking $self, #args off #_, but then taking $req, $subr from #args and doing nothing else with it. So I moved them up
connect returns the value of run
$foo = $bar if !defined $foo; is better written as $foo //= $bar;. Similar to $foo ||= $bar but checks for definedness rather than truth.
Code:
package CGI::Router;
use strict;
use warnings;
use parent 'CGI';
use Carp;
use Data::Dumper;
sub connect {
my ( $self, $req, $subr ) = #_;
$self->{routes} //= {};
$self->{env} //= \%ENV;
if ( !exists $self->{routes}->{$req} ) {
$self->{routes}->{$req} = {
handler => $subr,
pattern => $self->build_pattern($req),
method => $req =~ /^(GET|PUT|POST|DELETE)/
};
}
else {
Carp::croak("Similar request already exists $req!");
}
# Get current request destination
# TODO: Add that stupid IIS HTTP header
$self->{destination} = $self->{env}->{REQUEST_URI};
$self->{method} = $self->{env}->{REQUEST_METHOD};
return $self->run();
}
sub build_pattern {
my ( $self, $pattern ) = #_;
$pattern =~ s/(GET|POST|PUT|DELETE)\s?//i;
$pattern = do {
# Replace something like /word/:token with /word/(^:([a-z]+))
$pattern =~ s!
(\:([a-z]+))
!
if ( $2 ) {
"([^/]+)"
}
!gex;
"^$pattern\$";
};
return qr/$pattern/;
}
sub run {
my $self = shift;
my $router;
my #params;
foreach my $key ( keys %{ $self->{routes} } ) {
my $route = $self->{routes}->{$key};
if ( $self->{method} eq $route->{method}
&& $self->{destination} =~ $route->{pattern} )
{
#params =
$self->{destination} =~ $route->{pattern}; # Not fully working yet
$router = $route;
}
}
return $router->{handler}->(#params);
}
1;
test-router.pl:
Things changed:
The BEGIN block was doing setup that you ought not do for a test script. I.e. randomising the flow.. so I ditched that off
Added the environment variables for each test case
Code:
#!/usr/bin/perl
use strict;
use warnings;
use Data::Dumper;
use Test::More tests => 4;
use CGI::Router;
my $router = CGI::Router->new;
my $resp;
## 1. test ##
$ENV{'REQUEST_URI'} = '/';
$ENV{'REQUEST_METHOD'} = 'GET';
$resp = $router->connect('GET /', sub {
# print Dumper #_;
return 'Hello 1';
});
print Dumper $resp;
ok( $resp eq 'Hello 1' );
## 2. test ##
$ENV{'REQUEST_URI'} = '/hello';
$ENV{'REQUEST_METHOD'} = 'GET';
$resp = $router->connect('GET /hello', sub {
# print Dumper #_;
return 'Hello 2';
});
print Dumper $resp;
ok( $resp eq 'Hello 2' );
## 3. test ##
$ENV{'REQUEST_URI'} = '/hello/kitty';
$ENV{'REQUEST_METHOD'} = 'GET';
$resp = $router->connect('GET /hello/:who', sub {
# print Dumper #_;
return 'Hello 3';
});
print Dumper $resp;
ok( $resp eq 'Hello 3' );
## 4. test ##
$ENV{'REQUEST_URI'} = '/hello/kitty/kat';
$ENV{'REQUEST_METHOD'} = 'GET';
$resp = $router->connect('GET /hello/:who/:what', sub {
# print Dumper #_;
return 'Hello kitty kat';
});
print Dumper $resp;
ok( $resp eq 'Hello kitty kat' );