Question

我正在扩展CGI并尝试添加一个简单的路由器，只是为了好玩。

以下是我的测试::更多测试

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;

这是我的模块

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;

当测试用例运行时，我在## 4中转储例如$ resp。测试##返回的值不是“Hello kitty”的某个版本，而是“GET”。

以下是测试的输出

1..4 好的1 好的2 好的3 好的4

为什么所有子程序都返回'GET'，我看不到我在哪里生成这个输出。

我知道存在大量类似的框架，我只是为了好玩而这样做：）

Answer 1

我修改了你的代码工作/不是错误。接受或离开;）

CGI/Router.pm：

事情发生了变化：

build_pattern通过qr/$pattern/
connect param处理不那么令人困惑。您正在$self, @args关闭@_，但之后从$req, $subr获取@args，并且不执行任何其他操作。所以我把它们搬了起来
connect返回run
$foo = $bar if !defined $foo;最好写成$foo //= $bar;。与$foo ||= $bar类似，但检查定义而非真实。

代码：

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：

BEGIN块正在进行您不应该为测试脚本执行的设置。即随机化流程..所以我放弃了
为每个测试用例添加了环境变量

代码：

#!/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' );

Perl子例程返回意外值

1 个答案: