ASP4

 view release on metacpan or  search on metacpan

lib/ASP4/ConfigNode/Web.pm  view on Meta::CPAN

  return unless $s->{__has_router};
  $s->_parse_routes() unless $s->{__parsed_routes}++;
  $s->{routes};
}# end routes()


sub _parse_routes
{
  my $s = shift;
  
  my @original = @{ $s->{routes} };
  my $app_root = $s->application_root;
  @{ $s->{routes} } = map {
    $_->{include_routes} ? do {
      my $item = $_;
      $item->{include_routes} =~ s/\@ServerRoot\@/$app_root/sg;
      $item->{include_routes} =~ s{\\\\}{\\}g;
      open my $ifh, '<', $item->{include_routes}
        or die "Cannot open '$item->{include_routes}' for reading: $!";
      local $/;
      my $json = eval { decode_json( scalar(<$ifh>) ) }
        or confess "Error parsing '$item->{include_routes}': $@";
      ref($json) eq 'ARRAY'
        or confess "File '$item->{include_routes}' should be an arrayref but it's a '@{[ ref($json) ]}' instead.";
      @$json;
    } : $_
  } @original;
  
  my $router = Router::Generic->new();
  map { $router->add_route( %$_ ) } @{ $s->{routes} };
  $s->{router} = $router;
}# end _parse_routes()

1;# return true:

=pod

lib/ASP4/Response.pm  view on Meta::CPAN

  
  return $s->_subrequest( $file, $args );
}# end TrapInclude()


sub _subrequest
{
  my ($s, $file, $args) = @_;
  
  my $context = ASP4::HTTPContext->new( is_subrequest => 1 );
  my $original_r = $s->context->r;
  my $root = $s->context->config->web->www_root;
  my $cgi = $s->context->cgi;
  (my $uri = $file) =~ s/^\Q$root\E//;
  my $r = ASP4::Mock::RequestRec->new(
    uri   => $uri,
    args  => $original_r->args,
  );
  SCOPE: {
    local $ASP4::HTTPContext::_instance = $context;
    local $ENV{SCRIPT_NAME} = $uri;
    local $ENV{SCRIPT_FILENAME} = $file;
    $context->setup_request( $r, $cgi );
    $context->execute( $args, 1 );
  };
  
  return $context->r->buffer;
}# end _subrequest()


#sub _subrequest
#{
#  my ($s, $file, $args) = @_;
#  
#  $s->context->add_buffer();
#  my $original_r = $s->context->r;
#  my $root = $s->context->config->web->www_root;
#  (my $uri = $file) =~ s/^\Q$root\E//;
#  my $r = ASP4::Mock::RequestRec->new(
#    uri   => $uri,
#    args  => $original_r->args,
#  );
#  local $ENV{SCRIPT_NAME} = $uri;
#  local $ENV{SCRIPT_FILENAME} = $file;
#  my $original_status = $s->Status();
#  $s->context->setup_request( $r, $s->context->cgi );
#  $s->context->execute( $args, 1 );
#  $s->Flush;
#  $s->Status( $original_status );
#  my $buffer = $s->context->purge_buffer();
#  $s->context->{r} = $original_r;
#  $s->context->did_end( 0 );
#  return $r->buffer;
#}# end _subrequest()


sub DESTROY
{
  my $s = shift;
  undef(%$s);
}# end DESTROY()

t/050-encoding/010-default.t  view on Meta::CPAN

#!/usr/bin/perl -w

use utf8;
use strict;
use warnings 'all';
use Test::More 'no_plan';
use ASP4::API;

my $hellos = {
  arabic  => {
    original  => 'مرحبا ، العالم!',
    encoded => 'JiMxNjA1OyYjMTU4NTsmIzE1ODE7JiMxNTc2OyYjMTU3NTsgJiMxNTQ4OyAmIzE1NzU7JiMxNjA0
OyYjMTU5MzsmIzE1NzU7JiMxNjA0OyYjMTYwNTsh'
  },
  armenian  => {
    original  => 'Ô²Õ¡Ö€Õ¥Ö‚, Õ¡Õ·Õ­Õ¡Ö€Õ°Õ«.',
    encoded   => 'JiMxMzMwOyYjMTM3NzsmIzE0MDg7JiMxMzgxOyYjMTQxMDssICYjMTM3NzsmIzEzOTk7JiMxMzg5
OyYjMTM3NzsmIzE0MDg7JiMxMzkyOyYjMTM4Nzsu',
  },
  russian   => {
    original  => 'Здравствуй, мир!',
    encoded   => 'JiMxMDQ3OyYjMTA3NjsmIzEwODg7JiMxMDcyOyYjMTA3NDsmIzEwODk7JiMxMDkwOyYjMTA3NDsm
IzEwOTE7JiMxMDgxOywgJiMxMDg0OyYjMTA4MDsmIzEwODg7IQ=='
  },
  chinese_simplified  => {
    original  => '你好，世界！',
    encoded   => 'JiMyMDMyMDsmIzIyOTA5OyYjNjUyOTI7JiMxOTk5MDsmIzMwMDI4OyYjNjUyODE7',
  },
  foo => {
    original  => 'Bjòrknù',
  }
};

my $api = ASP4::API->new;

for my $lang (qw( arabic chinese_simplified armenian foo ))
{
  ok( my $res = $api->ua->get("/handlers/dev.encoding.hello?lang=$lang"), "GET /handlers/dev.encoding.hello?lang=$lang" );
  is $res->decoded_content, $hellos->{$lang}->{original};
}# end for()

t/handlers/dev/encoding/hello.pm  view on Meta::CPAN

use Encode;
use utf8;

# TODO: Encoding tests to make sure we get round-trip encoding integrity.
sub run
{
  my ($s, $context) = @_;
  
  my $hellos = {
    arabic  => {
      original  => 'مرحبا ، العالم!',
      encoded => 'JiMxNjA1OyYjMTU4NTsmIzE1ODE7JiMxNTc2OyYjMTU3NTsgJiMxNTQ4OyAmIzE1NzU7JiMxNjA0
OyYjMTU5MzsmIzE1NzU7JiMxNjA0OyYjMTYwNTsh'
    },
    armenian  => {
      original  => 'Ô²Õ¡Ö€Õ¥Ö‚, Õ¡Õ·Õ­Õ¡Ö€Õ°Õ«.',
      encoded   => 'JiMxMzMwOyYjMTM3NzsmIzE0MDg7JiMxMzgxOyYjMTQxMDssICYjMTM3NzsmIzEzOTk7JiMxMzg5
OyYjMTM3NzsmIzE0MDg7JiMxMzkyOyYjMTM4Nzsu',
    },
    russian   => {
      original  => 'Здравствуй, мир!',
      encoded   => 'JiMxMDQ3OyYjMTA3NjsmIzEwODg7JiMxMDcyOyYjMTA3NDsmIzEwODk7JiMxMDkwOyYjMTA3NDsm
IzEwOTE7JiMxMDgxOywgJiMxMDg0OyYjMTA4MDsmIzEwODg7IQ=='
    },
    chinese_simplified  => {
      original  => '你好，世界！',
      encoded   => 'JiMyMDMyMDsmIzIyOTA5OyYjNjUyOTI7JiMxOTk5MDsmIzMwMDI4OyYjNjUyODE7',
    },
    foo => {
      original  => 'Bjòrknù',
    }
  };
  
  my $lang = $Form->{lang}
    or return;
  $Response->ContentType("text/plain; charset=utf-8");
  $Response->Write(
    encode_utf8(
      $hellos->{$lang}->{original}
    )
  );
}# end run()

1;# return true: