<% $multi[$row][$col] %> | % }
Request Information | Connection Information |
$r->method( [$meth] ) = <% $r->method() %> $r->method_number( [$num] ) = <% $r->method_number() %> $r->bytes_sent = <% $r->bytes_sent %> $r->the_request = <% $r->the_request %> $r->proxyreq = <% $r->proxyreq %> $r->header_only = <% $r->header_only %> $r->protocol = <% $r->protocol %> $r->uri( [$uri] ) = <% $r->uri() %> $r->filename( [$filename] ) = <% $r->filename() %> $r->path_info( [$path_info] ) = <% $r->path_info() %> $r->args = <% $r->args %> $r->header_in( $header_name, [$value] ) = <% $r->header_in("Content-type") %> $r->get_remote_host = <% $r->get_remote_host %> $r->requires = <% $r->requires %> $r->auth_type = <% $r->auth_type %> $r->auth_name = <% $r->auth_name %> $r->document_root = <% $r->document_root %> $r->allow_options = <% $r->allow_options %> |
% my $c = $r->connection;
$c->remote_host = <%$c->remote_host%> $c->remote_ip = <%$c->remote_ip %> $c->local_addr = <%$c->local_addr %> $c->remote_addr = <%$c->remote_addr %> $c->remote_logname = <%$c->remote_logname%> $c->user = <%$c->user %> $c->auth_type = <%$c->auth_type %> $c->aborted = <%$c->aborted %> |
---|---|
Server Configuration | |
% my $s = $r->server;
$s->server_admin = <% $s->server_admin %> $s->server_hostname = <%$s->server_hostname%> $s->port = <%$s->port%> $s->is_virtual = <%$s->is_virtual%> $s->names = <%$s->names%> |
$r->method( [$meth] )
$c = $r->connection
If the configuration directive HostNameLookups is set to off: calls to
$r->get_remote_host return a string that contains the dotted decimal
representation of the remote client's IP address. However this string
is not cached, and $c->remote_host is undefined. So, it's best to to
call $r->get_remote_host instead of directly accessing this variable.
Among other things, this can be used, together with $c->local_addr, to
perform RFC1413 ident lookups on the remote client even when the
configuration directive IdentityCheck is turned off.
Can be used like:
If the configuration directive IdentityCheck is set to off: then
$r->get_remote_logname does nothing and $c->remote_logname is always
undefined.
% if (%ARGS) {
Arguments:
% foreach my $key (sort keys %ARGS) {
<% $key %>: <% $ARGS{$key} %>
amper_test.
amper_test.
amper_test.
amper_test.
amper_test.
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'ampersand_with_args',
description => 'tests variations of component calls with arguments',
component => <<'EOF',
<& /comp-calls/support/amper_test, message=>'Hello World!' &>
<& support/amper_test, message=>'Hello World!',
to=>'Joe' &>
<& "support/amper_test" &>
% my $dir = "support";
% my %args = (a=>17, b=>32);
<& $dir . "/amper_test", %args &>
EOF
expect => <<'EOF',
amper_test.
Arguments:
message: Hello World!
Arguments:
message: Hello World!
amper_test.
Arguments:
a: 17
amper_test.
amper_test.
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'fetch_comp_no_arg',
description => 'fetch_comp with blank or undefined argument returns undef',
component => <<'EOF',
fetch_comp(undef) = <% defined($m->fetch_comp(undef)) ? 'defined' : 'undefined' %>
fetch_comp("") = <% defined($m->fetch_comp("")) ? 'defined' : 'undefined' %>
EOF
expect => <<'EOF',
fetch_comp(undef) = undefined
fetch_comp("") = undefined
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'outside_comp_root_prepare',
description => 'test that file exists in dist/t for next two tests',
pre_code => sub { local *F; open(F, ">$outside_comp_root_test_file"); print F "hi"; },
component => "test file '$outside_comp_root_test_file' <% -e '$outside_comp_root_test_file' ? 'exists' : 'does not exist' %>",
expect => "test file '$outside_comp_root_test_file' exists",
);
#------------------------------------------------------------
$group->add_test( name => 'outside_comp_root_absolute',
description => 'cannot call components outside comp root with absolute path',
component => <<'EOF',
<& /../.outside_comp &>
EOF
expect_error => qr{could not find component for path '/../.outside_comp'},
);
#------------------------------------------------------------
$group->add_test( name => 'outside_comp_root_relative',
description => 'cannot call components outside comp root with relative path',
component => <<'EOF',
<& ../../.outside_comp &>
EOF
expect_error => qr{could not find component for path '../../.outside_comp'},
);
#------------------------------------------------------------
# put /../ in add_support path to put component right under comp root
$group->add_support( path => '/../outside_comp_root_from_top',
component => <<'EOF',
<& ../.outside_comp &>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'outside_comp_root_relative_from_top',
description => 'cannot call components outside comp root with relative path from component at top of root',
component => <<'EOF',
<& /outside_comp_root_from_top &>
EOF
expect_error => qr{could not find component for path '../.outside_comp'},
);
#------------------------------------------------------------
$group->add_test( name => 'parent_designator_with_no_parent',
description => 'using PARENT from component with no parent',
component => <<'EOF',
<%flags>
inherit=>undef
%flags>
<& PARENT:foo &>
EOF
expect_error => qr/PARENT designator used from component with no parent/,
);
#------------------------------------------------------------
$group->add_test( name => 'no_such_method',
description => 'calling nonexistent method on existing component',
component => <<'EOF',
<& support/amper_test:bar &>
EOF
expect_error => qr/no such method 'bar' for component/,
);
#------------------------------------------------------------
$group->add_test( name => 'fetch_comp_no_errors',
description => 'fetch_comp should not throw any errors',
component => <<'EOF',
% foreach my $path (qw(foo support/amper_test:bar PARENT)) {
<% $m->fetch_comp($path) ? 'defined' : 'undefined' %>
% }
EOF
expect => <<'EOF',
undefined
undefined
undefined
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/support/methods',
component => <<'EOF',
<%method foo>%method>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'comp_exists',
description => 'test comp_exists with various types of paths',
component => <<'EOF',
<%perl>
my @paths = qw(
support/methods
support/methods:foo
support/methods:bar
.foo
.bar
SELF
SELF:foo
PARENT
PARENT:foo
REQUEST
REQUEST:foo
);
%perl>
<%def .foo>%def>
% foreach my $path (@paths) {
<% $path %>: <% $m->comp_exists($path) %>
% }
EOF
expect => <<'EOF',
support/methods: 1
support/methods:foo: 1
support/methods:bar: 0
.foo: 1
.bar: 0
SELF: 1
SELF:foo: 0
PARENT: 0
PARENT:foo: 0
REQUEST: 1
REQUEST:foo: 0
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'comp_exists_no_arg',
description => 'comp_exists with blank or undefined argument returns 0',
component => <<'EOF',
comp_exists(undef) = <% $m->comp_exists(undef) %>
comp_exists("") = <% $m->comp_exists("") %>
EOF
expect => <<'EOF',
comp_exists(undef) = 0
comp_exists("") = 0
EOF
);
return $group;
}
HTML-Mason-1.56/t/10-cache.t 0000644 0001750 0001750 00000035465 12431555444 015061 0 ustar autarch autarch use strict;
use warnings;
use HTML::Mason::Tests;
use HTML::Mason::Tools;
# Skip if flock not implemented.
eval { my $fh = do { local *FH; *FH; }; open $fh, $0; flock $fh,1; };
if ($@)
{
print "1..0 # Skipped: flock() is not available on this system\n";
exit;
}
# Skip if Cache::FileCache not present.
eval { require Cache::FileCache };
if ($@)
{
print "1..0 # Skipped: Cache::FileCache is not installed\n";
exit;
}
my $tests = make_tests();
$tests->run;
sub make_tests
{
my $group = HTML::Mason::Tests->tests_class->new( name => 'cache',
description => 'Test caching' );
#------------------------------------------------------------
$group->add_test( name => 'cache_packages',
description => 'test that Mason cache packages get created',
component => <<'EOF',
% my $cache;
% $cache = $m->cache(cache_class=>'Cache::FileCache');
<% ref($cache) %>
<% $HTML::Mason::Cache::FileCache::VERSION + 0 %>
<% HTML::Mason::Tools::pkg_loaded('HTML::Mason::Cache::FileCache') ? 'loaded' : 'not loaded' %>
% $cache = $m->cache(cache_class=>'MemoryCache');
<% ref($cache) %>
<% $HTML::Mason::Cache::MemoryCache::VERSION + 0%>
<% HTML::Mason::Tools::pkg_loaded('HTML::Mason::Cache::FileCache') ? 'loaded' : 'not loaded' %>
EOF
expect => <<'EOF',
HTML::Mason::Cache::FileCache
1
loaded
HTML::Mason::Cache::MemoryCache
1
loaded
EOF
);
#------------------------------------------------------------
$group->add_support( path => 'support/cache_test',
component => <<'EOF',
<% $result %>
This was<% $cached ? '' : ' not' %> cached.
<%init>
my $cached = 0;
my $result;
my $return;
unless ($result = $m->cache->get('fandango')) {
$result = "Hello Dolly.";
$return = $m->cache->set('fandango', $result) || '';
} else {
$cached = 1;
}
%init>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'cache',
description => 'basic caching functionality',
component => <<'EOF',
% for (my $i=0; $i<3; $i++) {
<& support/cache_test &>
% }
EOF
expect => <<'EOF',
Hello Dolly.
This was not cached.
Hello Dolly.
This was cached.
Hello Dolly.
This was cached.
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'keys',
description => q|test multiple keys and $m->cache->get_keys|,
component => <<'EOF',
<%init>
foreach my $key (qw(foo bar baz)) {
$m->cache->set($key, $key);
}
my @keys = sort $m->cache->get_keys;
$m->print("keys in cache: ".join(",",@keys)."\n");
foreach my $key (qw(foo bar baz)) {
my $value = $m->cache->get($key) || "undefined";
$m->print("value for $key is $value\n");
}
$m->cache->remove('foo');
$m->cache->remove('bar');
$m->print("expiring foo and bar...\n");
foreach my $key (qw(foo bar baz)) {
my $value = $m->cache->get($key) || "undefined";
$m->print("value for $key is $value\n");
}
%init>
EOF
expect => <<'EOF',
keys in cache: bar,baz,foo
value for foo is foo
value for bar is bar
value for baz is baz
expiring foo and bar...
value for foo is undefined
value for bar is undefined
value for baz is baz
EOF
);
#------------------------------------------------------------
$group->add_support ( path => 'support/cache_self',
component => <<'EOF',
x is <% $x %>
<%args>
$x
%args>
<%init>
return if $m->cache_self;
%init>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'cache_self',
description => 'test $m->cache_self',
component => <<'EOF',
<& support/cache_self, x => 1 &>
<& support/cache_self, x => 99 &>
EOF
expect => <<'EOF',
x is 1
x is 1
EOF
);
#------------------------------------------------------------
$group->add_support ( path => 'support/cache_self_expires_in',
component => <<'EOF',
x is <% $x %>
<%args>
$x
%args>
<%init>
return if $m->cache_self( expires_in => '3s' );
%init>
EOF
);
$group->add_test( name => 'cache_self_expires_in',
description => 'test that $m->cache_self respects expires_in parameter',
component => <<'EOF',
<& support/cache_self_expires_in, x => 1 &>
<& support/cache_self_expires_in, x => 2 &>
% sleep 5;
<& support/cache_self_expires_in, x => 99 &>
EOF
expect => <<'EOF',
x is 1
x is 1
x is 99
EOF
);
#------------------------------------------------------------
$group->add_support ( path => 'support/cache_self_expire_in',
component => <<'EOF',
x is <% $x %>
<%args>
$x
%args>
<%init>
return if $m->cache_self( expire_in => '2s' );
%init>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'cache_self_expire_in',
description => 'test that $m->cache_self respects expire_in parameter',
component => <<'EOF',
<& support/cache_self_expire_in, x => 1 &>
<& support/cache_self_expire_in, x => 2 &>
% sleep 5;
<& support/cache_self_expire_in, x => 99 &>
EOF
expect => <<'EOF',
x is 1
x is 1
x is 99
EOF
);
#------------------------------------------------------------
$group->add_support ( path => 'support/cache_self_expire_if',
component => <<'EOF',
x is <% $x %>
<%args>
$x
%args>
<%init>
return if $m->cache_self( expire_if => sub { $x == 3 } );
%init>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'cache_self_expire_if',
description => 'test that $m->cache_self respects expire_if parameter',
component => <<'EOF',
<& support/cache_self_expire_if, x => 1 &>
<& support/cache_self_expire_if, x => 2 &>
<& support/cache_self_expire_if, x => 3 &>
<& support/cache_self_expire_if, x => 4 &>
EOF
expect => <<'EOF',
x is 1
x is 1
x is 3
x is 3
EOF
);
#------------------------------------------------------------
$group->add_support ( path => 'support/cache_self_with_key',
component => <<'EOF',
x is <% $x %>
<%args>
$x
$key
%args>
<%init>
return if $m->cache_self( key => $key );
%init>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'cache_self_key',
description => 'test $m->cache_self with a key',
component => <<'EOF',
<& support/cache_self_with_key, x => 1, key => 1 &>
<& support/cache_self_with_key, x => 99, key => 99 &>
<& support/cache_self_with_key, x => 1000, key => 1 &>
EOF
expect => <<'EOF',
x is 1
x is 99
x is 1
EOF
);
#------------------------------------------------------------
$group->add_support ( path => 'support/cache_self_and_die',
component => <<'EOF',
<%init>
return if $m->cache_self;
die "argh!";
%init>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'cache_self_error',
description => 'test $m->cache_self with an error to make sure errors are propogated',
component => <<'EOF',
<& support/cache_self_and_die, x => 1, key => 1 &>
EOF
expect_error => qr/argh! at .*/,
);
#------------------------------------------------------------
$group->add_test( name => 'cache_self_scomp',
description => 'make sure that $m->cache_self cooperates with $m->scomp',
component => <<'EOF',
<% $m->scomp( 'support/cache_self', x => 1 ) %>
<% $m->scomp( 'support/cache_self', x => 99 ) %>
EOF
expect => <<'EOF',
x is 1
x is 1
EOF
);
#------------------------------------------------------------
$group->add_support ( path => 'support/cache_self_filtered',
component => <<'EOF',
x is <% $x %>
<%args>
$x
$key => 1
%args>
<%init>
return if $m->cache_self( key => $key );
%init>
<%filter>
$_ = uc $_;
$_ .= ' filtered';
%filter>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'cache_self_filtered',
description => 'test $m->cache_self with a filter block',
component => <<'EOF',
<& support/cache_self_filtered, x => 1 &>
<& support/cache_self_filtered, x => 99 &>
EOF
expect => <<'EOF',
X IS 1
filtered
X IS 1
filtered
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'cache_self_filtered_scomp',
description => 'test $m->cache_self with a filter block callled via $m->scomp',
component => <<'EOF',
<% $m->scomp( 'support/cache_self_filtered', key => 2, x => 1 ) %>
<% $m->scomp( 'support/cache_self_filtered', key => 2, x => 99 ) %>
EOF
expect => <<'EOF',
X IS 1
filtered
X IS 1
filtered
EOF
);
#------------------------------------------------------------
$group->add_support ( path => 'support/cache_self_filtered_2',
component => <<'EOF',
x is <% $x %>
<%args>
$x
%args>
<%init>
return if $m->cache_self;
%init>
<%filter>
s/(\d+)/$1+1/ge;
%filter>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'cache_self_filtered_2',
description => 'make sure that results are only filtered once',
component => <<'EOF',
<& support/cache_self_filtered_2, x => 1 &>
<& support/cache_self_filtered_2, x => 99 &>
EOF
expect => <<'EOF',
x is 2
x is 2
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'expire_if',
description => 'test expire_if',
component => <<'EOF',
<% join(', ', $value1 || 'undef', $value2 || 'undef', $value3 || 'undef') %>
<%init>
my $time = time;
my $cache = $m->cache;
$cache->set('main', 'gardenia');
my $value1 = $cache->get('main', expire_if=>sub { $_[0]->get_created_at <= $time-1 });
my $value2 = $cache->get('main', expire_if=>sub { $_[0]->get_created_at >= $time });
my $value3 = $cache->get('main');
%init>
EOF
expect => <<'EOF',
gardenia, undef, undef
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'busy_lock',
description => 'test busy_lock',
component => <<'EOF',
<% join(', ', $value1 || 'undef', $value2 || 'undef') %>
<%init>
my $time = time;
my $cache = $m->cache;
$cache->set('main', 'gardenia', 0);
my $value1 = $cache->get('main', busy_lock=>'10 sec');
my $value2 = $cache->get('main');
%init>
EOF
expect => <<'EOF',
undef, gardenia
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'busy_lock_expiration',
description => 'test busy_lock expiration',
component => <<'EOF',
<% join(', ', $value1 || 'undef', $value2 || 'undef') %>
<%init>
my $time = time;
my $cache = $m->cache;
$cache->set('main', 'gardenia', 0);
my $value1 = $cache->get('main', busy_lock=>'1 sec');
sleep(1);
my $value2 = $cache->get('main');
%init>
EOF
expect => <<'EOF',
undef, undef
EOF
);
#------------------------------------------------------------
$group->add_support ( path => 'support/cache_self_die',
component => <<'EOF',
die
<%init>
return if $m->cache_self;
die 'foo';
%init>
EOF
);
$group->add_test( name => 'cache_self_death',
description => 'test $m->cache_self and death',
component => <<'EOF',
<%init>
$m->comp( 'support/cache_self_die' );
%init>
EOF
expect_error => qr/foo at/,
);
#------------------------------------------------------------
$group->add_support ( path => 'support/cache_self_abort2',
component => <<'EOF',
going to abort, a = <% $ARGS{a} %>
% $m->abort();
EOF
);
$group->add_support( path => 'support/cache_self_abort',
component => <<'EOF',
<%init>
return if $m->cache_self;
$m->comp( 'cache_self_abort2', a=>5 );
%init>
EOF
);
$group->add_test( name => 'cache_self_abort',
description => 'test $m->cache_self and abort',
component => <<'EOF',
<%init>
eval { $m->comp( 'support/cache_self_abort', a=>5 ) };
eval { $m->comp( 'support/cache_self_abort', a=>10 ) };
%init>
EOF
expect => <<'EOF'
going to abort, a = 5
going to abort, a = 5
EOF
);
#------------------------------------------------------------
$group->add_support( path => 'support/cache_self_with_subexec2',
component => <<'EOF',
This is the subrequest, a = <% $ARGS{a} %>
EOF
);
$group->add_support( path => 'support/cache_self_with_subexec',
component => <<'EOF',
% return if $m->cache_self;
% $m->subexec('cache_self_with_subexec2', a=>$ARGS{a});
EOF
);
$group->add_test( name => 'cache_self_with_subexec',
description => 'test $m->subexec in presence of $m->cache_self',
component => <<'EOF',
<& support/cache_self_with_subexec, a=>5 &>
<& support/cache_self_with_subexec, a=>10 &>
EOF
expect => <<'EOF',
This is the subrequest, a = 5
This is the subrequest, a = 5
EOF
);
#------------------------------------------------------------
$group->add_support( path => 'declined/dhandler',
component => <<'EOF',
decline was called
EOF
);
$group->add_test( name => 'declined/cache_self_decline',
description => 'test $m->decline in presence of $m->cache_self',
component => <<'EOF',
% return if $m->cache_self;
% $m->decline;
EOF
expect => <<'EOF',
decline was called
EOF
);
#------------------------------------------------------------
return $group;
}
HTML-Mason-1.56/t/02a-filter.t 0000644 0001750 0001750 00000020127 12431555444 015432 0 ustar autarch autarch use strict;
use warnings;
use HTML::Mason::Tests;
my $tests = make_tests();
$tests->run;
sub make_tests
{
my $group =
HTML::Mason::Tests->tests_class->new( name => 'filter',
description => 'Tests <%filter> specific problems' );
#------------------------------------------------------------
$group->add_test( name => 'filter_and_shared',
description =>
'make sure <%filter> can see variables from <%shared>',
component => <<'EOF',
I am X
<%shared>
my $change_to = 'Y';
%shared>
<%filter>
s/X/$change_to/;
%filter>
EOF
expect => <<'EOF',
I am Y
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'filter_and_ARGS',
description =>
'make sure <%filter> can see variables %ARGS',
call_args => { change_to => 'Y' },
component => <<'EOF',
I am X
<%filter>
s/X/$ARGS{change_to}/;
%filter>
EOF
expect => <<'EOF',
I am Y
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'filter_and_ARGS_assign',
description =>
'make sure <%filter> can see changes to %ARGS',
component => <<'EOF',
I am X
<%init>
$ARGS{change_to} = 'Y';
%init>
<%filter>
s/X/$ARGS{change_to}/;
%filter>
EOF
expect => <<'EOF',
I am Y
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'filter_and_args_section',
description =>
'make sure <%filter> can see variables from <%args> section',
component => <<'EOF',
I am X
<%args>
$change_to => 'Y'
%args>
<%filter>
s/X/$change_to/;
%filter>
EOF
expect => <<'EOF',
I am Y
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'filter_and_args_error',
description =>
'args error should not present a problem for <%filter>',
component => <<'EOF',
<%args>
$required
%args>
foo
<%filter>
s/foo/bar/g;
%filter>
EOF
expect_error => qr/no value sent for required parameter/,
);
#------------------------------------------------------------
$group->add_support( path => '/support/has_filter',
component => <<'EOF',
lower case
<%filter>
$_ = uc $_;
%filter>
EOF
);
$group->add_test( name => 'filter_and_clear',
description => 'make sure <%filter> does not break $m->clear_buffer',
component => <<'EOF',
I should not show up.
<& support/has_filter &>
% $m->clear_buffer;
I should show up.
EOF
expect => <<'EOF',
I should show up.
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'filters_in_subcomps',
description => 'test <%filter> sections in subcomps only',
component => <<'EOF',
Main Component
<& .sub1 &>
<& .sub2 &>
<%def .sub1>
Sub 1
<%filter>
s/Sub/Subcomponent/;
%filter>
%def>
<%def .sub2>
Subcomp 2
<%filter>
s/Subcomp/Subcomponent/;
%filter>
%def>
EOF
expect => <<'EOF',
Main Component
Subcomponent 1
Subcomponent 2
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'filters_in_comp_and_subcomps',
description => 'test <%filter> sections in both main comp and subcomps',
component => <<'EOF',
Main Component (lowercase)
<& .sub1 &>
<& .sub2 &>
<%def .sub1>
Sub 1
<%filter>
s/Sub/Subcomponent/;
%filter>
%def>
<%def .sub2>
Subcomp 2
<%filter>
s/Subcomp/Subcomponent/;
%filter>
%def>
<%filter>
$_ = lc($_);
%filter>
EOF
expect => <<'EOF',
main component (lowercase)
subcomponent 1
subcomponent 2
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'filter_and_flush',
description => 'test that filter still occurs in presence of flush',
component => <<'EOF',
hello
% $m->flush_buffer;
goodbye
<%filter>
tr/a-z/A-Z/
%filter>
EOF
expect => <<'EOF',
HELLO
GOODBYE
EOF
);
#------------------------------------------------------------
$group->add_support( path => 'clear_filter_comp',
component => <<'EOF',
Bar
% $m->clear_buffer;
Baz
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'clear_in_comp_called_with_filter',
description => 'Test that clear_buffer clears _all_ buffers, even inside a filter',
component => <<'EOF',
Foo
<& clear_filter_comp &>\
<%filter>
s/^/-/gm;
%filter>
EOF
expect => <<'EOF',
-Baz
EOF
);
#------------------------------------------------------------
$group->add_support( path => 'some_comp',
component => <<'EOF',
Some stuff
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'comp_call_in_filter',
description => 'Test that calling another component from a filter section works',
component => <<'EOF',
Stuff
<%filter>
$_ .= $m->scomp( 'some_comp' );
$_ = lc $_;
%filter>
EOF
expect => <<'EOF',
stuff
some stuff
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/auto_filter_die/dies',
component => <<'EOF',
% die "foo death";
EOF
);
$group->add_support( path => '/auto_filter_die/autohandler',
component => <<'EOF',
autohandler
% $m->call_next;
EOF
);
$group->add_test( name => 'auto_filter_die/abort_comp_call_in_filter_with_autohandler',
description => 'Test that calling another component that dies from a filter section in a component wrapped by an autohandler produces a proper error',
component => <<'EOF',
Stuff
<%filter>
$m->comp( 'dies' );
%filter>
EOF
expect_error => qr/foo death/,
);
#------------------------------------------------------------
$group->add_support( path => '/support/abort_in_filter',
component => <<'EOF',
Will not be seen
<%filter>
$m->abort;
$_ = lc $_;
%filter>
EOF
);
$group->add_test( name => 'abort_in_filter',
description => 'Test that abort in a filter causes no output',
component => <<'EOF',
Before the abort
<& support/abort_in_filter &>
After the abort - not seen
EOF
expect => <<'EOF',
Before the abort
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/support/abort_in_shared_with_filter',
component => <<'EOF',
<%shared>
$m->abort('dead');
%shared>
<%filter>
$_ = lc $_;
%filter>
EOF
);
$group->add_test( name => 'abort_in_shared_with_filter',
description => 'Test that abort in a shared block works when component has a filter block',
component => <<'EOF',
<% $out %>
<%init>
eval { $m->comp( 'support/abort_in_shared_with_filter' ) };
my $e = $@;
my $out = 'no error';
if ($e)
{
$out = $m->aborted($e) ? $e->aborted_value : "error: $e";
}
%init>
EOF
expect => <<'EOF',
dead
EOF
);
#------------------------------------------------------------
return $group;
}
HTML-Mason-1.56/t/20-plugins.t 0000644 0001750 0001750 00000045326 12431555444 015475 0 ustar autarch autarch use strict;
use warnings;
use HTML::Mason::Tests;
package HTML::Mason::Plugin::TestBeforeAndAfterRequest;
use base qw(HTML::Mason::Plugin);
sub start_request_hook {
my ($self, $context) = @_;
print "Before Request\n";
}
sub end_request_hook {
print "After Request\n";
}
package HTML::Mason::Plugin::TestBeforeAndAfterComponent;
use base qw(HTML::Mason::Plugin);
sub start_component_hook {
my ($self, $context) = @_;
print "Before Component " . $context->comp->title . "\n";
}
sub end_component_hook {
my ($self, $context) = @_;
print "After Component " . $context->comp->title . "\n";
}
# test the ordering of plugin calls
package HTML::Mason::Plugin::TestAllCalls;
use base qw(HTML::Mason::Plugin);
sub start_request_hook {
my ($self, $context) = @_;
my $rcomp = $context->request->request_comp()->title;
print "AllCalls Request Start on: $rcomp\n";
}
sub end_request_hook {
my ($self, $context) = @_;
my $rcomp = $context->request->request_comp()->title;
print "AllCalls Request Finish on: $rcomp\n";
}
sub start_component_hook {
my ($self, $context) = @_;
print "AllCalls Before Component " . $context->comp->title . "\n";
}
sub end_component_hook {
my ($self, $context) = @_;
print "AllCalls After Component " . $context->comp->title . "\n";
}
package HTML::Mason::Plugin::TestResetEachRequest;
use base qw(HTML::Mason::Plugin);
sub start_request_hook {
my ($self, $context) = @_;
my $rcomp = $context->request->request_comp->title();
print "PreRequest: " . ++ $self->{count} . " : $rcomp\n";
}
sub end_request_hook {
my ($self, $context) = @_;
my $rcomp = $context->request->request_comp->title();
print "PostRequest: " . ++ $self->{count} . " : $rcomp\n";
}
sub start_component_hook {
my ($self, $context) = @_;
print "PreComponent: " . ++ $self->{count} . " : " . $context->comp->title() ."\n";
}
sub end_component_hook {
my ($self, $context) = @_;
print "PostComponent: " . ++ $self->{count} . " : " . $context->comp->title() ."\n";
}
package HTML::Mason::Plugin::TestErrorStartRequest;
use base qw(HTML::Mason::Plugin);
sub start_request_hook {
my ($self, $context) = @_;
die("plugin error on start request " . $context->request->request_comp->title);
}
package HTML::Mason::Plugin::TestErrorEndRequest;
use base qw(HTML::Mason::Plugin);
sub end_request_hook {
my ($self, $context) = @_;
die("plugin error on end request " . $context->request->request_comp->title);
}
package HTML::Mason::Plugin::TestErrorStartComponent;
use base qw(HTML::Mason::Plugin);
sub start_component_hook {
my ($self, $context) = @_;
die("plugin error on start component " . $context->comp->title);
}
package HTML::Mason::Plugin::TestErrorEndComponent;
use base qw(HTML::Mason::Plugin);
sub end_component_hook {
my ($self, $context) = @_;
die("plugin error on end component " . $context->comp->title);
}
package HTML::Mason::Plugin::TestModifyReturnEndComponent;
use base qw(HTML::Mason::Plugin);
sub end_component_hook {
my ($self, $context) = @_;
my $result = $context->result;
if (defined($result->[0])) {
$result->[0] = $result->[0] * 2;
}
}
package HTML::Mason::Plugin::TestModifyReturnEndRequest;
use base qw(HTML::Mason::Plugin);
sub end_request_hook {
my ($self, $context) = @_;
my $result = $context->result;
if (defined($result->[0])) {
$result->[0] = $result->[0] * 2;
}
}
package HTML::Mason::Plugin::TestCatchErrorEndComponent;
use base qw(HTML::Mason::Plugin);
sub end_component_hook {
my ($self, $context) = @_;
my $error = $context->error;
if (defined($$error)) {
print "Caught error " . $$error . " and trapping it.\n";
$$error = undef;
}
}
package HTML::Mason::Plugin::TestCatchErrorEndRequest;
use base qw(HTML::Mason::Plugin);
sub end_request_hook {
my ($self, $context) = @_;
my $error = $context->error;
if (defined($$error)) {
print "Caught error " . $$error . " and trapping it.\n";
$$error = undef;
}
}
package HTML::Mason::Plugin::TestEndRequestModifyOutput;
use base qw(HTML::Mason::Plugin);
sub end_request_hook {
my ($self, $context) = @_;
my $content_ref = $context->output;
$$content_ref = uc($$content_ref);
}
package main;
my $tests = make_tests();
$tests->run;
sub make_tests
{
my $group = HTML::Mason::Tests->tests_class->new( name => 'plugins',
description => 'request and component plugin hooks'
);
#------------------------------------------------------------
# comp A calls comp B two times.
$group->add_support( path => '/support/A.m',
component => <<'EOF',
Component A Start
<& B.m &>
<& B.m &>
Component A Finish
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/support/B.m',
component => <<'EOF',
Component B Start
Component B Finish
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/support/error.m',
component => <<'EOF',
% die("uh oh");
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'before_and_after_request',
description => 'a simple plugin for requests',
interp_params =>
{
plugins => ['HTML::Mason::Plugin::TestBeforeAndAfterRequest'],
},
component => '<& support/A.m &>',
expect => <<'EOF',
Before Request
Component A Start
Component B Start
Component B Finish
Component B Start
Component B Finish
Component A Finish
After Request
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'before_and_after_component',
description => 'a simple plugin for components',
interp_params =>
{
plugins => ['HTML::Mason::Plugin::TestBeforeAndAfterComponent'],
},
component => '<& support/A.m &>',
expect => <<'EOF',
Before Component /plugins/before_and_after_component
Before Component /plugins/support/A.m
Component A Start
Before Component /plugins/support/B.m
Component B Start
Component B Finish
After Component /plugins/support/B.m
Before Component /plugins/support/B.m
Component B Start
Component B Finish
After Component /plugins/support/B.m
Component A Finish
After Component /plugins/support/A.m
After Component /plugins/before_and_after_component
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'two_plugins',
description => 'using two different plugins',
interp_params =>
{
plugins => ['HTML::Mason::Plugin::TestBeforeAndAfterComponent', 'HTML::Mason::Plugin::TestBeforeAndAfterRequest'],
},
component => '<& support/A.m &>',
expect =><<'EOF',
Before Request
Before Component /plugins/two_plugins
Before Component /plugins/support/A.m
Component A Start
Before Component /plugins/support/B.m
Component B Start
Component B Finish
After Component /plugins/support/B.m
Before Component /plugins/support/B.m
Component B Start
Component B Finish
After Component /plugins/support/B.m
Component A Finish
After Component /plugins/support/A.m
After Component /plugins/two_plugins
After Request
EOF
);
$group->add_test( name => 'plugin_ordering',
description => 'make sure plugins are called in reverse order when ending',
interp_params =>
{
plugins => ['HTML::Mason::Plugin::TestAllCalls','HTML::Mason::Plugin::TestBeforeAndAfterRequest', 'HTML::Mason::Plugin::TestBeforeAndAfterComponent'],
},
component => '<& support/A.m &>',
expect =><<'EOF',
AllCalls Request Start on: /plugins/plugin_ordering
Before Request
AllCalls Before Component /plugins/plugin_ordering
Before Component /plugins/plugin_ordering
AllCalls Before Component /plugins/support/A.m
Before Component /plugins/support/A.m
Component A Start
AllCalls Before Component /plugins/support/B.m
Before Component /plugins/support/B.m
Component B Start
Component B Finish
After Component /plugins/support/B.m
AllCalls After Component /plugins/support/B.m
AllCalls Before Component /plugins/support/B.m
Before Component /plugins/support/B.m
Component B Start
Component B Finish
After Component /plugins/support/B.m
AllCalls After Component /plugins/support/B.m
Component A Finish
After Component /plugins/support/A.m
AllCalls After Component /plugins/support/A.m
After Component /plugins/plugin_ordering
AllCalls After Component /plugins/plugin_ordering
After Request
AllCalls Request Finish on: /plugins/plugin_ordering
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'two_of_the_same_plugin',
description => 'two_of_the_same_plugin',
interp_params =>
{
plugins => ['HTML::Mason::Plugin::TestBeforeAndAfterComponent', 'HTML::Mason::Plugin::TestBeforeAndAfterComponent'],
},
component => '<& support/A.m &>',
expect =><<'EOF',
Before Component /plugins/two_of_the_same_plugin
Before Component /plugins/two_of_the_same_plugin
Before Component /plugins/support/A.m
Before Component /plugins/support/A.m
Component A Start
Before Component /plugins/support/B.m
Before Component /plugins/support/B.m
Component B Start
Component B Finish
After Component /plugins/support/B.m
After Component /plugins/support/B.m
Before Component /plugins/support/B.m
Before Component /plugins/support/B.m
Component B Start
Component B Finish
After Component /plugins/support/B.m
After Component /plugins/support/B.m
Component A Finish
After Component /plugins/support/A.m
After Component /plugins/support/A.m
After Component /plugins/two_of_the_same_plugin
After Component /plugins/two_of_the_same_plugin
EOF
);
$group->add_test( name => 'reset_each_request',
description => 'use the same plugin twice, they should be different objects',
interp_params =>
{
plugins => ['HTML::Mason::Plugin::TestResetEachRequest', 'HTML::Mason::Plugin::TestResetEachRequest'],
},
component => '<& support/A.m &>',
expect =><<'EOF',
PreRequest: 1 : /plugins/reset_each_request
PreRequest: 1 : /plugins/reset_each_request
PreComponent: 2 : /plugins/reset_each_request
PreComponent: 2 : /plugins/reset_each_request
PreComponent: 3 : /plugins/support/A.m
PreComponent: 3 : /plugins/support/A.m
Component A Start
PreComponent: 4 : /plugins/support/B.m
PreComponent: 4 : /plugins/support/B.m
Component B Start
Component B Finish
PostComponent: 5 : /plugins/support/B.m
PostComponent: 5 : /plugins/support/B.m
PreComponent: 6 : /plugins/support/B.m
PreComponent: 6 : /plugins/support/B.m
Component B Start
Component B Finish
PostComponent: 7 : /plugins/support/B.m
PostComponent: 7 : /plugins/support/B.m
Component A Finish
PostComponent: 8 : /plugins/support/A.m
PostComponent: 8 : /plugins/support/A.m
PostComponent: 9 : /plugins/reset_each_request
PostComponent: 9 : /plugins/reset_each_request
PostRequest: 10 : /plugins/reset_each_request
PostRequest: 10 : /plugins/reset_each_request
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'error_on_start_request',
description => 'a plugin that dies',
interp_params =>
{
plugins => ['HTML::Mason::Plugin::TestErrorStartRequest'],
},
component => '<& support/A.m &>',
expect_error => 'plugin error on start request /plugins/error_on_start_request',
);
#------------------------------------------------------------
$group->add_test( name => 'error_on_end_request',
description => 'a plugin that dies',
interp_params =>
{
plugins => ['HTML::Mason::Plugin::TestErrorEndRequest'],
},
component => '<& support/A.m &>',
expect_error => 'plugin error on end request /plugins/error_on_end_request',
);
#------------------------------------------------------------
$group->add_test( name => 'error_on_start_component',
description => 'a plugin that dies',
interp_params =>
{
plugins => ['HTML::Mason::Plugin::TestErrorStartComponent'],
},
component => '<& support/A.m &>',
expect_error => 'plugin error on start component /plugins/error_on_start_component',
);
#------------------------------------------------------------
$group->add_test( name => 'error_on_end_component',
description => 'a plugin that dies',
interp_params =>
{
plugins => ['HTML::Mason::Plugin::TestErrorEndComponent'],
},
component => '<& support/A.m &>',
expect_error => 'plugin error on end component /plugins/error_on_end_component',
);
#------------------------------------------------------------
$group->add_test( name => 'not_persistent_across_requests',
description => 'different plugin for each request',
interp_params =>
{
plugins => ['HTML::Mason::Plugin::TestResetEachRequest'],
},
component => '% $m->subexec("support/A.m"); ',
expect =><<'EOF',
PreRequest: 1 : /plugins/not_persistent_across_requests
PreComponent: 2 : /plugins/not_persistent_across_requests
PreRequest: 1 : /plugins/support/A.m
PreComponent: 2 : /plugins/support/A.m
Component A Start
PreComponent: 3 : /plugins/support/B.m
Component B Start
Component B Finish
PostComponent: 4 : /plugins/support/B.m
PreComponent: 5 : /plugins/support/B.m
Component B Start
Component B Finish
PostComponent: 6 : /plugins/support/B.m
Component A Finish
PostComponent: 7 : /plugins/support/A.m
PostRequest: 8 : /plugins/support/A.m
PostComponent: 3 : /plugins/not_persistent_across_requests
PostRequest: 4 : /plugins/not_persistent_across_requests
EOF
);
#------------------------------------------------------------
my $PersistentPlugin = HTML::Mason::Plugin::TestResetEachRequest->new();
$group->add_test( name => 'persistent_across_requests',
description => 'same plugin across a subrequest',
interp_params =>
{
plugins => [$PersistentPlugin],
},
component => '% $m->subexec("support/A.m"); ',
expect =><<'EOF',
PreRequest: 1 : /plugins/persistent_across_requests
PreComponent: 2 : /plugins/persistent_across_requests
PreRequest: 3 : /plugins/support/A.m
PreComponent: 4 : /plugins/support/A.m
Component A Start
PreComponent: 5 : /plugins/support/B.m
Component B Start
Component B Finish
PostComponent: 6 : /plugins/support/B.m
PreComponent: 7 : /plugins/support/B.m
Component B Start
Component B Finish
PostComponent: 8 : /plugins/support/B.m
Component A Finish
PostComponent: 9 : /plugins/support/A.m
PostRequest: 10 : /plugins/support/A.m
PostComponent: 11 : /plugins/persistent_across_requests
PostRequest: 12 : /plugins/persistent_across_requests
EOF
);
#------------------------------------------------------------
$group->add_support ( path => '/support/return_numbers',
component => <<'EOF',
<%def .five><%perl>return 5;%perl>%def>
<%def .six><%perl>return 6;%perl>%def>
% return $m->comp('.five') + $m->comp('.six');
EOF
);
$group->add_test( name => 'modify_return_end_component',
description => 'an end_component plugin that modifies its return value',
interp_params =>
{
plugins => ['HTML::Mason::Plugin::TestModifyReturnEndComponent'],
},
component => '<% $m->comp("support/return_numbers") %>',
expect => '44',
);
$group->add_test( name => 'modify_return_end_request',
description => 'an end_request plugin that modifies its return value',
interp_params =>
{
plugins => ['HTML::Mason::Plugin::TestModifyReturnEndRequest'],
},
component => '<% $m->subexec("support/return_numbers") %>',
expect => '22',
);
#------------------------------------------------------------
$group->add_test( name => 'catch_error_end_component',
description => 'an end_component plugin that modifies its arguments to trap errors',
interp_params =>
{
plugins => ['HTML::Mason::Plugin::TestCatchErrorEndComponent'],
},
component => '<& support/error.m &>',
expect => qr{Caught error uh oh},
);
$group->add_test( name => 'catch_error_end_request',
description => 'an end_request plugin that modifies its arguments to trap errors',
interp_params =>
{
plugins => ['HTML::Mason::Plugin::TestCatchErrorEndRequest'],
},
component => '<& support/error.m &>',
expect => qr{Caught error uh oh},
);
#------------------------------------------------------------
$group->add_test( name => 'modify_content_end_request',
description => 'modify content at end of request',
interp_params =>
{
plugins => ['HTML::Mason::Plugin::TestEndRequestModifyOutput'],
},
component => '<%def .something>capitalized%def>I will be <& .something &>',
expect => <<'EOF',
I WILL BE CAPITALIZED
EOF
);
return $group;
}
HTML-Mason-1.56/t/04-misc.t 0000644 0001750 0001750 00000021367 12431555444 014750 0 ustar autarch autarch use strict;
use warnings;
use File::Spec;
use HTML::Mason::Tests;
my $tests = make_tests();
$tests->run;
sub make_tests
{
my $group = HTML::Mason::Tests->tests_class->new( name => 'misc',
description => 'autohandler and dhandler functionality' );
#------------------------------------------------------------
$group->add_support( path => '/autohandler_test/autohandler',
component => <<'EOF',
<& header &>
Autohandler comp: <% $m->fetch_next->title %>
% my $buf;
% $m->call_next(b=>$a*2);
<& footer &>
<%args>
$a=>5
%args>
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/autohandler_test/header',
component => <<'EOF',
Explicitly HTML-escaped redundantly: <% $expr |hh %>
Explicitly URL-escaped: <% $expr |u
%>
No flags: <% $expr %>
No flags again: <% $expr %>
Explicitly not escaped: <% $expr | n%>
<%init>
my $expr = "Hello there.";
%init>
EOF
expect => <<'EOF',
Explicitly HTML-escaped: <b><i>Hello there</i></b>.
Explicitly HTML-escaped redundantly: <b><i>Hello there</i></b>.
Explicitly URL-escaped: %3Cb%3E%3Ci%3EHello%20there%3C%2Fi%3E%3C%2Fb%3E.
No flags: Hello there.
No flags again: Hello there.
Explicitly not escaped: Hello there.
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'default_escape_flags_new',
description => 'test new escape flags',
interp_params => { use_object_files => 0 },
component => <<'EOF',
Explicitly HTML-escaped: <% $expr | h %>
Explicitly HTML-escaped redundantly: <% $expr | h,h %>
Explicitly URL-escaped: <% $expr |u
%>
No flags: <% $expr %>
No flags again: <% $expr %>
Explicitly not escaped: <% $expr | n %>
<%init>
my $expr = "Hello there.";
%init>
EOF
expect => <<'EOF',
Explicitly HTML-escaped: <b><i>Hello there</i></b>.
Explicitly HTML-escaped redundantly: <b><i>Hello there</i></b>.
Explicitly URL-escaped: %3Cb%3E%3Ci%3EHello%20there%3C%2Fi%3E%3C%2Fb%3E.
No flags: Hello there.
No flags again: Hello there.
Explicitly not escaped: Hello there.
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'default_escape_flags_2',
description => 'test that turning on default escaping works',
interp_params => { use_object_files => 0, default_escape_flags => 'h' },
component => <<'EOF',
Explicitly HTML-escaped: <% $expr |h %>
Explicitly HTML-escaped redundantly: <% $expr |hh %>
Explicitly URL-escaped: <% $expr |un
%>
No flags: <% $expr %>
No flags again: <% $expr %>
Explicitly not escaped: <% $expr | n%>
<%init>
my $expr = "Hello there.";
%init>
EOF
expect => <<'EOF',
Explicitly HTML-escaped: <b><i>Hello there</i></b>.
Explicitly HTML-escaped redundantly: <b><i>Hello there</i></b>.
Explicitly URL-escaped: %3Cb%3E%3Ci%3EHello%20there%3C%2Fi%3E%3C%2Fb%3E.
No flags: <b><i>Hello there</i></b>.
No flags again: <b><i>Hello there</i></b>.
Explicitly not escaped: Hello there.
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'default_escape_flags_2_new',
description => 'test that turning on default escaping works with new flags',
interp_params => { use_object_files => 0,
default_escape_flags => [ 'h' ] },
component => <<'EOF',
Explicitly HTML-escaped: <% $expr | h %>
Explicitly HTML-escaped redundantly: <% $expr | h , h %>
Explicitly URL-escaped: <% $expr | u, n
%>
No flags: <% $expr %>
No flags again: <% $expr %>
Explicitly not escaped: <% $expr | n %>
<%init>
my $expr = "Hello there.";
%init>
EOF
expect => <<'EOF',
Explicitly HTML-escaped: <b><i>Hello there</i></b>.
Explicitly HTML-escaped redundantly: <b><i>Hello there</i></b>.
Explicitly URL-escaped: %3Cb%3E%3Ci%3EHello%20there%3C%2Fi%3E%3C%2Fb%3E.
No flags: <b><i>Hello there</i></b>.
No flags again: <b><i>Hello there</i></b>.
Explicitly not escaped: Hello there.
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'setting_escapes',
description => 'test setting escapes',
component => <<'EOF',
% $m->interp->set_escape( uc => sub { ${$_[0]} = uc ${$_[0]} } );
This will be in <% 'upper case' | uc %>
EOF
expect => <<'EOF',
This will be in UPPER CASE
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'invalid_escape_name',
description => 'test setting an escape with an invalid name',
component => <<'EOF',
% $m->interp->set_escape( 'u c' => sub { uc $_[0] } );
EOF
expect_error => qr/Invalid escape name/,
);
#------------------------------------------------------------
$group->add_test( name => 'globals_in_default_package',
description => 'tests that components are executed in HTML::Mason::Commands package by default',
interp_params => { use_object_files => 0,
allow_globals => ['$packvar'] },
component => <<'EOF',
<% $packvar %>
<%init>
$HTML::Mason::Commands::packvar = 'commands';
$HTML::Mason::NewPackage::packvar = 'newpackage';
%init>
EOF
expect => <<'EOF',
commands
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'globals_in_different_package',
description => 'tests in_package compiler parameter',
interp_params => { use_object_files => 0,
allow_globals => ['$packvar'],
in_package => 'HTML::Mason::NewPackage' },
component => <<'EOF',
<% $packvar %>
<%init>
$HTML::Mason::Commands::packvar = 'commands';
$HTML::Mason::NewPackage::packvar = 'newpackage';
%init>
EOF
expect => <<'EOF',
newpackage
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'preamble',
description => 'tests preamble compiler parameter',
interp_params => { preamble => 'my $msg = "This is the preamble.\n"; $m->print($msg);
'},
component => <<'EOF',
This is the body.
EOF
expect => <<'EOF',
This is the preamble.
This is the body.
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'postamble',
description => 'tests postamble compiler parameter',
interp_params => { postamble => 'my $msg = "This is the postamble.\n"; $m->print($msg);
'},
component => <<'EOF',
This is the body.
EOF
expect => <<'EOF',
This is the body.
This is the postamble.
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'preprocess',
description => 'test preprocess compiler parameter',
interp_params => { preprocess => \&brackets_to_lt_gt },
component => <<'EOF',
[% 'foo' %]
bar
EOF
expect => <<'EOF',
foo
bar
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'postprocess_text1',
description => 'test postprocess compiler parameter (alpha blocks)',
interp_params => { postprocess_text => \&uc_alpha },
component => <<'EOF',
<% 'foo' %>
bar
EOF
expect => <<'EOF',
foo
BAR
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'postprocess_text2',
description => 'test postprocess compiler parameter (alpha blocks)',
interp_params => { postprocess_text => \&uc_alpha },
component => <<'EOF',
<% 'foo' %>
<%text>bar%text>
EOF
expect => <<'EOF',
foo
BAR
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'postprocess_perl1',
description => 'test postprocess compiler parameter (perl blocks)',
interp_params => { postprocess_perl => \&make_foo_foofoo },
component => <<'EOF',
<% 'foo' %>
bar
EOF
expect => <<'EOF',
foofoo
bar
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'postprocess_perl2',
description => 'test postprocess compiler parameter (perl blocks)',
interp_params => { postprocess_perl => \&make_foo_foofoo },
component => <<'EOF',
<% 'foo' %>
% $m->print("Make mine foo!\n");
bar
<% "stuff-$var-stuff" %>
<%init>
my $var = 'foo';
%init>
EOF
expect => <<'EOF',
foofoo
Make mine foofoo!
bar
stuff-foofoo-stuff
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'bad_var_name',
description => 'test that invalid Perl variable names are caught',
component => <<'EOF',
<%args>
$foo
$8teen
%bar
%args>
Never get here
EOF
expect_error => qr{Invalid <%args> section line},
);
#------------------------------------------------------------
$group->add_test( name => 'whitespace_near_args',
description => 'test that whitespace is allowed before %args>',
call_args => [qw(foo foo)],
component => <<'EOF',
<%args>
$foo
%args>
EOF
expect => " \n",
);
#------------------------------------------------------------
$group->add_test( name => 'line_nums',
description => 'make sure that errors are reported with the correct line numbers',
component => <<'EOF',
<% $x %> <% $y %>
<% $z %>
% die "Dead";
<%init>
my ($x, $y, $z) = qw(a b c);
%init>
EOF
expect_error => qr/Dead at .* line 3/,
);
#------------------------------------------------------------
$group->add_test( name => 'line_nums2',
description => 'make sure that errors are reported with the correct line numbers',
component => <<'EOF',
<% $x %> <% $y %>
<% $z %>\
% die "Dead";
<%init>
my ($x, $y, $z) = qw(a b c);
%init>
EOF
expect_error => qr/Dead at .* line 3/,
);
#------------------------------------------------------------
$group->add_test( name => 'line_nums3',
description => 'make sure that errors are reported with the correct line numbers',
component => <<'EOF',
<% $x %> <% $y %>
<% $z %>
<%init>
my ($x, $y, $z) = qw(a b c);
die "Dead";
%init>
EOF
expect_error => qr/Dead at .* line 5/,
);
#------------------------------------------------------------
$group->add_test( name => 'line_nums4',
description => 'make sure that errors are reported with the correct line numbers in <%once> blocks',
component => <<'EOF',
1
2
3
<%ONCE>
$x = 1;
%ONCE>
EOF
expect_error => qr/Global symbol .* at .* line 5/,
);
#------------------------------------------------------------
$group->add_test( name => 'line_nums_with_escaped_newlines',
description => 'Check line numbers of error messages after escaped newlines',
component => <<'EOF',
1
2
3\
4\
5
% die "Dead";
EOF
expect_error => qr/Dead at .* line 6/,
);
#------------------------------------------------------------
$group->add_test( name => 'line_nums_off_by_one',
description => 'make sure that line number reporting is not off by one',
component => <<'EOF',
1
2
3
<%once>#4
my $x = 1; #5
%once>6
7
<%args>#8
$foo#9
@bar#10
%args>11
<%init>#12
#13
#14
#15
$y; #16
%init>
EOF
expect_error => qr/Global symbol .* at .* line 16/,
);
#------------------------------------------------------------
$group->add_test( name => 'line_nums_off_2',
description => 'make sure that line number reporting is not off (another buggy case)',
component => <<'EOF',
<%flags>
inherit => undef
%flags>
% die "really #4";
EOF
expect_error => qr/really #4 .* line 4/,
);
#------------------------------------------------------------
$group->add_test( name => 'attr_block_zero',
description => 'test proper handling of zero in <%attr> block values',
component => <<'EOF',
<%attr>
key => 0
%attr>
<% $m->current_comp->attr_exists('key') ? 'exists' : 'missing' %>
EOF
expect => "exists\n",
);
#------------------------------------------------------------
$group->add_test( name => 'attr_flag_block_comment',
description => 'test comment lines in attr and flags blocks',
component => <<'EOF',
<%attr>
# this is a comment
# another comment
key => 'foo'
# one last comment
%attr>
<%flags>
# this is a comment
# another comment
inherit => undef
# one last comment
%flags>
compiled
EOF
expect => 'compiled',
);
#------------------------------------------------------------
$group->add_test( name => 'attr_flag_block_empty',
description => 'test empty attr and flags blocks',
component => <<'EOF',
<%attr>%attr>
<%flags>
%flags>
compiled
EOF
expect => 'compiled',
);
#------------------------------------------------------------
my $error =
$] >= 5.006 ? qr/Unterminated <>/ : qr/Bareword "subcomp" not allowed/;
$group->add_test( name => 'subcomp_parse_error',
description => 'A misnamed block at the beginning of a component was throwing the lexer into an infinite loop. Now it should be compiled into a component with a syntax error.',
component => <<'EOF',
<%subcomp .foo>
<% 5 %>
%subcomp>
EOF
expect_error => $error,
);
#------------------------------------------------------------
$group->add_test( name => 'error_in_args',
description => 'Test line number reporting for <%args> block',
component => <<'EOF',
lalalal
<%args>
$foo => this should break
%args>
EOF
expect_error => qr/Bareword "break".*error_in_args line 3/,
);
#------------------------------------------------------------
$group->add_test( name => 'block_end_without_nl',
description => 'Test that a block can end without a newline before it',
component => <<'EOF',
no newlines<%args>$foo => 1%args><%attr>foo => 1%attr><%flags>inherit => undef%flags>
EOF
expect => <<'EOF',
no newlines
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'more_block_variations',
description => 'Test various mixture of whitespace with blocks',
component => <<'EOF',
various
<%args>
$foo => 1%args>
<%attr>
foo => 1%attr>
<%args>$bar => 1
%args>
<%attr>bar => 1
%attr>
<%args>
$quux => 1%args>
<%attr>
quux => 1%attr>
<%args> $baz => 1
%args>
<%attr> baz => 1
%attr>
EOF
expect => <<'EOF',
various
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'percent_at_end',
description => 'Make sure that percent signs are only considered perl lines when at the beginning of the line',
component => <<'EOF',
<% $x %>% $x = 5;
<% $x %>
<%init>
my $x = 10;
%init>
EOF
expect => <<'EOF',
10% $x = 5;
10
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'nameless_method',
description => 'Check for appropriate error message when there is a method or def block without a name',
component => <<'EOF',
<%method>
foo
%method>
EOF
expect_error => qr/method block without a name at .*/
);
#------------------------------------------------------------
$group->add_test( name => 'invalid_method_name',
description => 'Check for appropriate error message when there is a method with an invalid name',
component => <<'EOF',
<%method >
foo
%method>
EOF
expect_error => qr/Invalid method name:.*/
);
#------------------------------------------------------------
$group->add_test( name => 'uc_method',
description => 'make sure that <%METHOD ...> is allowed',
component => <<'EOF',
calling SELF:foo - <& SELF:foo &>
<%METHOD foo>bar%METHOD>
EOF
expect => <<'EOF',
calling SELF:foo - bar
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'no_strict',
description => 'test turning off strict in a component',
interp_params => { use_strict => 0 },
component => <<'EOF',
no errors
<%init>
$x = 1;
%init>
EOF
expect => <<'EOF',
no errors
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'no_strict_no_object_files',
description =>
'test turning off strict in a component when not using object files',
interp_params => { use_strict => 0, use_object_files => 0 },
component => <<'EOF',
no errors
<%init>
$x = 1;
%init>
EOF
expect => <<'EOF',
no errors
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'weird_case',
description => 'test weird parsing case',
component => <<'EOF',
<%init()%>
<%args()%>
<%once>
sub init { 'init' }
sub args { 'args' }
%once>
EOF
expect => <<'EOF',
init
args
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'subst_tag_comments',
description => 'Make sure comments parse correctly in substitution tags',
component => <<'EOF',
<%# Here's a comment
5 + 5 %>
EOF
expect => 10,
);
#------------------------------------------------------------
$group->add_test( name => 'shared_to_init',
description => 'Make sure <%init> can see lexicals in <%shared>',
component => <<'EOF',
<%init>
$m->out( $x );
%init>
<%shared>
my $x = 7;
%shared>
EOF
expect => 7,
);
#------------------------------------------------------------
$group->add_test( name => 'shared_to_init_global',
description => 'Make sure <%init> can see global variables in <%shared>',
interp_params => { allow_globals => ['$x'] },
component => <<'EOF',
<%init>
$m->out( $x );
%init>
<%shared>
$x = 8;
%shared>
EOF
expect => 8,
);
#------------------------------------------------------------
$group->add_test( name => 'double_pipe_or',
description => 'Make sure || works in a substitution',
component => <<'EOF',
Should be 1: <% 1 || 2 %>
EOF
expect => <<'EOF',
Should be 1: 1
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'double_pipe_or_2',
description => 'Make sure || works in a substitution (again)',
component => <<'EOF',
<%once>
sub foo { 'foo!' }
sub bar { 'bar!' }
%once>
<% foo || bar %>
EOF
expect => <<'EOF',
foo!
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'flags_regex',
description => 'Make sure flags must start with alpha or underscore',
component => <<'EOF',
<% 1 | 1 %>
EOF
expect => <<'EOF',
1
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'qw_in_perl_lines',
description => 'Make sure that Mason that a qw() list stretching across multiple perl-lines works',
component => <<'EOF',
% foreach my $foo ( qw( a
% b ) ) {
<% $foo %>
% }
EOF
expect => <<'EOF',
a
b
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/has_subcomp',
component => <<'EOF',
<& .a &>
<%def .a>
A
%def>
EOF
);
$group->add_support( path => '/no_subcomp',
component => <<'EOF',
<%shared>
my $y = 1;
%shared>
EOF
);
$group->add_test( name => 'subcomp_leak',
description => 'Make sure subcomps from one component do not show up in other components',
component => <<'EOF',
<%init>
$m->scomp('has_subcomp');
$m->scomp('no_subcomp');
local *FH;
my $obj = $m->fetch_comp('no_subcomp')->object_file;
open FH, "< $obj"
or die "Cannot read $obj";
my $text = join '',
&>
done!
EOF
expect => <<'EOF',
five
four
three
two
one
done!
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'contentless',
path => 'filter_test/test4',
call_path => 'filter_test/test4',
description => 'test a filter with no content',
component => <<'EOF',
nothing <& filter &> here
EOF
expect => <<'EOF',
nothing content returned '' here
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'default_content',
path => 'filter_test/test5',
call_path => 'filter_test/test5',
description => 'test a filter which does not access content',
component => <<'EOF',
outside <&| null &> inside &> outside
EOF
expect => <<'EOF',
outside outside
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'current_component',
path => 'filter_test/test6',
call_path => 'filter_test/test6',
call_args => {arg=>1},
description => 'test $m->current_comp inside filter content',
component => <<'EOF',
<% $m->current_comp->name %>
<&| echo &>
<% $m->current_comp->name %>
<&| echo &>
<% $m->current_comp->name %>
<% join(", ", $m->caller_args(0)) %>
&>
&>
EOF
expect => <<'EOF',
test6
test6
test6
arg, 1
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'various_tags',
path => 'filter_test/test7',
call_path => 'filter_test/test7',
description => 'test various tags in content',
component => <<'EOF',
<%method lala>
component call
%method>
<&| filter &>
% $m->print("this is a perl line ");
<% "substitution tag" %>
<& SELF:lala &>
<%perl>
$m->print("perl tag");
%perl>
&>
EOF
expect => <<'EOF',
content returned 'this is a perl line substitution tag
component call
perl tag'
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'filter_with_filter',
path => 'filter_test/test8',
call_path => 'filter_test/test8',
description => 'test interaction with filter section',
component => <<'EOF',
<&| filter &>hi ho&>
<%filter>
s/content returned/simon says/
%filter>
EOF
expect => <<'EOF',
simon says 'hi ho'
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'top_level_content',
description => 'test $m->content at top level is empty',
component => <<'EOF',
top level content is '<% $m->content %>'
EOF
expect => <<'EOF',
top level content is ''
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'filter_content',
path => 'filter_test/test10',
call_path => 'filter_test/test10',
description => 'test filtering $m->content',
component => <<'EOF',
top
<&| double &>guts&>
EOF
expect => <<'EOF',
top
one
content returned 'guts'
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'subcomponent_filter',
description => 'test method as filter',
component => <<'EOF',
<%def sad>
<% $m->content %>? I can't help it!
%def>
<%method happy>
<% $m->content %>, be happy!
%method>
<&| SELF:happy &>don't worry&>
<&| sad &>why worry&>
EOF
expect => <<'EOF',
don't worry, be happy!
why worry? I can't help it!
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'dollar_underscore',
description => 'Test using $_ in a filter',
component => <<'EOF',
<&| filter_test/repeat2, list => [1,2,3] &>$_ is <% $_ %>&>
EOF
expect => <<'EOF',
$_ is 1
$_ is 2
$_ is 3
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'multi_filter',
description => 'Test order of multiple filters',
component => <<'EOF',
<&| .lc &>\
<&| .uc &>\
MixeD CAse\
&>\
&>\
<%def .uc>\
<% uc $m->content %>\
%def>
<%def .lc>\
<% lc $m->content %>\
%def>
EOF
expect => <<'EOF',
mixed case
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'clear_in_filter',
description => 'Test clear_buffer in a filtered call',
component => <<'EOF',
clear me
<&| .lc &>\
MIXED case
% $m->clear_buffer;
mixed CASE
&>
<%def .lc>\
in .lc
<% lc $m->content %>\
%def>
EOF
expect => <<'EOF',
mixed case
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'clear_in_filter2',
description => 'More clear_buffer in a filtered call',
component => <<'EOF',
clear me
<&| .lc &>\
MIXED case
<& .clear &>\
mixed CASE
&>
<%def .lc>\
in .lc
<% lc $m->content %>\
%def>\
<%def .clear>\
% $m->clear_buffer;
%def>
EOF
expect => <<'EOF',
mixed case
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'flush_in_filter',
description => 'Test flush_buffer in a filtered call',
component => <<'EOF',
<&| .lc &>\
Should do nothing
% $m->flush_buffer;
so both should appear
&>
<%def .lc>\
<% lc $m->content %>\
%def>
EOF
expect => <<'EOF',
should do nothing
so both should appear
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'has_content',
description => 'Test $m->has_content',
component => <<'EOF',
<& .show_content &>\
-----
<&| .show_content &>\
This is the content
&>
<%def .show_content>\
% if ($m->has_content) {
My content is:
<% $m->content %>
% } else {
I have no content.
% }
%def>
EOF
expect => <<'EOF',
I have no content.
-----
My content is:
This is the content
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'ending_tag_match',
description => 'Test & comp >',
component => <<'EOF',
<&|.outer &>\
<&| .inner, dummy=>1 &>\
This is the content
&.inner >
& .outer>
<%def .inner>\
% $m->print("inner: ".$m->content);
%def>
<%def .outer>\
% $m->print("outer: ".$m->content);
%def>
EOF
expect => <<'EOF',
outer: inner: This is the content
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'ending_tag_nomatch',
description => 'Test bad & comp > match',
component => <<'EOF',
<&|.outer &>\
<&| .inner&>\
This is the content
&.outer >
& .inner>
<%def .inner>\
% $m->print("inner: ".$m->content);
%def>
<%def .outer>\
% $m->print("outer: ".$m->content);
%def>
EOF
expect_error => 'Component name in ending tag \(\.outer\) does not match component name in beginning tag \(\.inner\)',
);
#------------------------------------------------------------
$group->add_test( name => 'ending_tag_expr',
description => 'Test expr in <& expr> not matched',
component => <<'EOF',
<&| ".outer" &>\
<&| ".inner" &>\
This is the content
&>
& .outer >
<%def .inner>\
% $m->print("inner: ".$m->content);
%def>
<%def .outer>\
% $m->print("outer: ".$m->content);
%def>
EOF
expect_error => 'Cannot match an expression as a component name',
);
#------------------------------------------------------------
$group->add_test( name => 'ending_tag_expr2',
description => 'Test expr in &> not allowed',
component => <<'EOF',
<&| ".outer" &>\
<&| ".inner" &>\
This is the content
&>
& ".inner" >
<%def .inner>\
% $m->print("inner: ".$m->content);
%def>
<%def .outer>\
% $m->print("outer: ".$m->content);
%def>
EOF
expect_error => 'Cannot use an expression inside component with content ending tag',
);
#------------------------------------------------------------
$group->add_test( name => 'multiline_open_close',
description => 'Tests multiline opening and closing blocks for component with content call tags',
component => <<'EOF',
<&|
Wrap
&>\
Hello\
&
Wrap
>\
<%def Wrap>\
[Wrap start]
<% $m->content %>
[Wrap end]\
%def>
EOF
expect => <<'EOF',
[Wrap start]
Hello
[Wrap end]
EOF
);
#------------------------------------------------------------
return $group;
}
HTML-Mason-1.56/t/25-flush-in-content.t 0000644 0001750 0001750 00000002165 12431555444 017210 0 ustar autarch autarch use strict;
use warnings;
use File::Spec;
use HTML::Mason::Tests;
my $tests = make_tests();
$tests->run;
sub make_tests {
my $group = HTML::Mason::Tests->tests_class->new(
name => 'flush-in-content',
description => 'recursive calls with $m->content'
);
#------------------------------------------------------------
$group->add_support(
path => '/widget',
component => <<'EOF',
% if ($count < $max) {
<& recurse_test, count=>$count+1, max=>$max &>
% }
Exiting <% $count %> \
<%args>
$count=>0
$max
%args>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'max_recurse_1',
description => 'Test that recursion 8 levels deep is allowed',
component => <<'EOF',
% eval { $m->comp('support/recurse_test', max=>8) };
EOF
expect => <<'EOF',
Entering 0
Entering 1
Entering 2
Entering 3
Entering 4
Entering 5
Entering 6
Entering 7
Entering 8
Exiting 8
Exiting 7
Exiting 6
Exiting 5
Exiting 4
Exiting 3
Exiting 2
Exiting 1
Exiting 0
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'max_recurse_2',
description => 'Test that recursion is stopped after 32 levels',
interp_params => { autoflush => 1 },
component => '<& support/recurse_test, max=>48 &>',
expect_error => qr{32 levels deep in component stack \(infinite recursive call\?\)},
);
#------------------------------------------------------------
$group->add_test( name => 'max_recurse_3',
description => 'Test interp max_recurse param',
interp_params => { max_recurse => 50 },
component => <<'EOF',
% eval { $m->comp('support/recurse_test', max=>48) };
<% $@ ? "Error" : "No error" %>
EOF
expect => <<'EOF',
Entering 0
Entering 1
Entering 2
Entering 3
Entering 4
Entering 5
Entering 6
Entering 7
Entering 8
Entering 9
Entering 10
Entering 11
Entering 12
Entering 13
Entering 14
Entering 15
Entering 16
Entering 17
Entering 18
Entering 19
Entering 20
Entering 21
Entering 22
Entering 23
Entering 24
Entering 25
Entering 26
Entering 27
Entering 28
Entering 29
Entering 30
Entering 31
Entering 32
Entering 33
Entering 34
Entering 35
Entering 36
Entering 37
Entering 38
Entering 39
Entering 40
Entering 41
Entering 42
Entering 43
Entering 44
Entering 45
Entering 46
Entering 47
Entering 48
Exiting 48
Exiting 47
Exiting 46
Exiting 45
Exiting 44
Exiting 43
Exiting 42
Exiting 41
Exiting 40
Exiting 39
Exiting 38
Exiting 37
Exiting 36
Exiting 35
Exiting 34
Exiting 33
Exiting 32
Exiting 31
Exiting 30
Exiting 29
Exiting 28
Exiting 27
Exiting 26
Exiting 25
Exiting 24
Exiting 23
Exiting 22
Exiting 21
Exiting 20
Exiting 19
Exiting 18
Exiting 17
Exiting 16
Exiting 15
Exiting 14
Exiting 13
Exiting 12
Exiting 11
Exiting 10
Exiting 9
Exiting 8
Exiting 7
Exiting 6
Exiting 5
Exiting 4
Exiting 3
Exiting 2
Exiting 1
Exiting 0
No error
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/support/code_cache/show_code_cache',
component => <<'EOF',
% $m->interp->purge_code_cache();
% my $code_cache = $m->interp->{code_cache};
% my @plain_comp_names = sort grep { /^plain/ } map { $_->{comp}->name } values(%$code_cache);
Code cache contains: <% join(", ", @plain_comp_names) %>
EOF
);
#------------------------------------------------------------
foreach my $i (1..7) {
$group->add_support( path => "/support/code_cache/plain$i",
component => "",
);
}
$group->add_support( path => "/support/code_cache/call_plain_comps",
component => <<'EOF',
<& plain1 &><& plain1 &><& plain1 &><& plain1 &><& plain1 &><& plain1 &><& plain1 &>
<& plain2 &><& plain2 &><& plain2 &><& plain2 &><& plain2 &>
<& plain3 &><& plain3 &><& plain3 &>
<& plain4 &>
<& plain5 &><& plain5 &>
<& plain6 &><& plain6 &><& plain6 &><& plain6 &>
<& plain7 &><& plain7 &><& plain7 &><& plain7 &><& plain7 &><& plain7 &>
EOF
);
#------------------------------------------------------------
my $create_code_cache_test = sub {
my ($max_size, $expected) = @_;
$group->add_test( name => "code_cache_$max_size",
interp_params => { code_cache_max_size => $max_size },
description => "code cache: max_size = $max_size",
component => <<'EOF',
<%init>
$m->scomp('support/code_cache/call_plain_comps');
$m->scomp('support/code_cache/call_plain_comps');
$m->comp('support/code_cache/show_code_cache');
%init>
EOF
expect => <<"EOF",
Code cache contains: $expected
EOF
);
};
$create_code_cache_test->('unlimited', 'plain1, plain2, plain3, plain4, plain5, plain6, plain7');
$create_code_cache_test->(0, '');
$create_code_cache_test->(4, 'plain1, plain2, plain7');
$create_code_cache_test->(8, 'plain1, plain2, plain3, plain5, plain6, plain7');
#------------------------------------------------------------
$group->add_test( name => 'dhandler_name',
description => 'Test that providing an alternate name for dhandlers works',
path => 'dhandler_test/plainfile',
call_path => 'dhandler_test/foo/blag',
interp_params => { dhandler_name => 'plainfile' },
component => <<'EOF',
dhandler arg = <% $m->dhandler_arg %>
EOF
expect => <<'EOF',
dhandler arg = foo/blag
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'dhandler_name2',
description => 'Shut off dhandlers',
path => 'dhandler_test/plainfile',
call_path => 'dhandler_test/foo/blag',
interp_params => { dhandler_name => '' },
component => 'foo',
expect_error => qr{could not find component},
);
#------------------------------------------------------------
$group->add_test( name => 'no dhandlers',
description => 'tests turning off dhandlers by setting name to ""',
call_path => 'dhandler_test/exists',
interp_params => { dhandler_name => '' },
component => <<'EOF',
Hello World! dhandlers are <% $m->use_dhandlers ? 'on' : 'off' %>
EOF
expect => <<'EOF',
Hello World! dhandlers are off
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'dhandler_name0',
description => 'dhandler_name => 0 should not shut off dhandlers',
path => 'dhandler_test/0',
call_path => 'dhandler_test/foo/blag',
interp_params => { dhandler_name => '0' },
component => <<'EOF',
dhandler arg = <% $m->dhandler_arg %>
comp = <% $m->current_comp->name %>
EOF
expect => <<'EOF',
dhandler arg = foo/blag
comp = 0
EOF
);
#------------------------------------------------------------
$group->add_support( path => 'mode_test',
component => <<'EOF',
First of all I'd
% $m->clear_buffer;
No what I really wanted to say was
% $m->clear_buffer;
Oh never mind.
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'no_autoflush_mode',
description => 'Test that no autoflush (batch) mode setting works',
component => <<'EOF',
<& mode_test &>
EOF
expect => <<'EOF',
Oh never mind.
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'autoflush_mode',
description => 'Test that autoflush setting works',
interp_params => { autoflush => 1 },
component => <<'EOF',
<& mode_test &>
EOF
expect => <<'EOF',
First of all I'd
No what I really wanted to say was
Oh never mind.
EOF
);
#------------------------------------------------------------
$group->add_support( path => 'preloads_test/show_code_cache',
component => <<'EOF',
Code cache contains:
% my %c = %{$m->interp->{code_cache}};
<% join("\n",sort(keys(%c))) %>
EOF
);
#------------------------------------------------------------
$group->add_support( path => 'preloads_test/hello',
component => 'hello',
);
#------------------------------------------------------------
$group->add_support( path => 'preloads_test/goodbye',
component => 'goodbye',
);
#------------------------------------------------------------
$group->add_support( path => 'preloads_test/howareyou',
component => 'howareyou',
);
#------------------------------------------------------------
$group->add_support( path => 'preloads_test/subdir/in_a_subdir',
component => 'howareyou',
);
#------------------------------------------------------------
$group->add_test( name => 'preload_1',
description => 'Make sure no preloading is done by default',
component => <<'EOF',
<& preloads_test/show_code_cache &>
EOF
expect => <<'EOF',
Code cache contains:
/interp/preload_1
/interp/preloads_test/show_code_cache
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'preload_2',
description => 'Preload a single component by filename',
interp_params => { preloads => [ '/interp/preloads_test/hello' ] },
component => <<'EOF',
<& preloads_test/show_code_cache &>
EOF
expect => <<'EOF',
Code cache contains:
/interp/preload_2
/interp/preloads_test/hello
/interp/preloads_test/show_code_cache
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'preload_3',
description => 'Preload all components (including subdirectory) by glob pattern',
interp_params => { preloads => [ '/interp/preloads_test/*', '/interp/preloads_test/*/*' ] },
component => <<'EOF',
<& preloads_test/show_code_cache &>
EOF
expect => <<'EOF',
Code cache contains:
/interp/preload_3
/interp/preloads_test/goodbye
/interp/preloads_test/hello
/interp/preloads_test/howareyou
/interp/preloads_test/show_code_cache
/interp/preloads_test/subdir/in_a_subdir
EOF
);
#------------------------------------------------------------
my $interp = HTML::Mason::Tests->tests_class->_make_interp
( data_dir => $group->data_dir,
comp_root => $group->comp_root,
);
$interp->compiler->allow_globals( qw($global) );
$interp->set_global( global => 'parsimmon' );
$group->add_test( name => 'globals',
description => 'Test setting a global in interp & compiler objects',
interp => $interp,
component => <<'EOF',
<% $global %>
EOF
expect => <<'EOF',
parsimmon
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/comp_path_test/a/b/c/foo',
component => <<'EOF',
I am foo!
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'process_comp_path',
description => 'Test that component paths cannot be resolved outside the comp root',
component => <<'EOF',
<& ../../../../../interp/comp_path_test/a/b/c/../c/foo &>
EOF
expect => <<'EOF'
I am foo!
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'process_comp_path2',
description => 'Test that component paths containing /../ work as long they stay in the comp root',
path => '/comp_path_test/a/b/d/process',
call_path => '/comp_path_test/a/b/d/process',
component => <<'EOF',
<& ../c/foo &>
EOF
expect => <<'EOF'
I am foo!
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'default_warnings',
description => 'test that warnings during component compilation cause an exception except for redefined subs',
component => <<'EOF',
a global: <% $GLOBAL %>
<%once>
sub foo { 1 }
sub foo { 1 }
%once>
EOF
expect_error => qr/Global symbol "\$GLOBAL" requires explicit package name/,
);
#------------------------------------------------------------
$group->add_test( name => 'ignore_warnings',
description => 'test that setting ignore_warnings_exp works',
interp_params => { ignore_warnings_expr => qr/useless use of "re" pragma/i },
component => <<'EOF',
% use re;
foo
EOF
expect => <<'EOF',
foo
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'ignore_all_warnings',
description => 'test ignoring all warnings',
interp_params =>
{ ignore_warnings_expr => '.' },
component => <<'EOF',
<%once>
sub foo { 1 }
sub foo { 1 }
%once>
foo
EOF
expect => <<'EOF',
foo
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'make_anonymous_component',
description => 'test make_component() without a path',
component => <<'EOF',
<%init>
my $ctext = q|
% my $x = 'Hello, ';
<% $x %>|;
my $comp = $m->interp->make_component( comp_source => $ctext );
%init>
% $m->comp($comp);
World
EOF
expect => <<'EOF',
Hello, World
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'read_write_contained',
description => 'test that we can read/write contained object params',
component => <<'EOF',
% $m->autoflush(1);
% my $req = $m->make_subrequest(comp=>($m->interp->make_component(comp_source => 'hi')));
% $m->autoflush(0);
autoflush for new request is <% $req->autoflush %>
EOF
expect => <<'EOF',
autoflush for new request is 1
EOF
);
#------------------------------------------------------------
if ( load_pkg('Cache::Cache') && load_pkg('Cache::MemoryCache') )
{
$group->add_test( name => 'no_data_dir',
description => 'test interp without a data directory',
interp => HTML::Mason::Tests->tests_class->_make_interp( comp_root => HTML::Mason::Tests->tests_class->comp_root ),
component => <<'EOF',
Hello World!
<% ref $m->cache %>
EOF
expect => <<'EOF',
Hello World!
HTML::Mason::Cache::MemoryCache
EOF
);
}
#------------------------------------------------------------
$group->add_support( path => 'no_comp_root_helper',
component => <<'EOF',
I am rootless
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'no_comp_root',
description => 'test interp without a comp root or data dir',
component => <<'EOF',
% my $buffer;
% my $interp = HTML::Mason::Tests->tests_class->_make_interp( out_method => \$buffer );
% $interp->exec( "/mason_tests/$$/comps/interp/no_comp_root_helper" );
<% $buffer %>
EOF
expect => <<'EOF',
I am rootless
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'make_component_error',
description => 'make sure a proper exception is thrown with make_component syntax errors',
component => <<'EOF',
% $m->interp->make_component(comp_source => '<% &>');
EOF
# Would be better to do $@->isa(syntax-error) or the like.
expect_error => qr/without matching/,
);
#------------------------------------------------------------
if ( $] < 5.012 && load_pkg('Switch') )
{
$group->add_test( name => 'source_filter',
description => 'make sure source filters work',
interp_params =>
{ ignore_warnings_expr =>
qr/uninitialized|Subroutine .* redefined/i },
component => <<'EOF',
no explosion
<%init>
use Switch;
my $x = 1;
switch ($x) { case 1 { $x = 2 } }
%init>
EOF
expect => <<'EOF',
no explosion
EOF
);
}
#------------------------------------------------------------
$group->add_test( name => 'escape_flags',
description => 'test setting escape flags via constructor',
interp_params =>
{ escape_flags => { uc => sub { ${$_[0]} = uc ${$_[0]} } } },
component => <<'EOF',
<% 'upper case' | uc %>
EOF
expect => <<'EOF',
UPPER CASE
EOF
);
#------------------------------------------------------------
# Note that setting out_method on the interp affects _future_
# request objects, not the current one. This is just a test to
# make sure we can set it at all.
$group->add_test( name => 'set_out_method',
description => 'test setting out_method on the interp object',
component => <<'EOF',
foo
% $m->interp->out_method( sub {} );
bar
baz
EOF
expect => <<'EOF',
foo
bar
baz
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/support/corrupt_object_file',
component => "I was loaded\n",
);
$group->add_test( name => 'corrupt_object_file',
description => 'test that Mason can recover from a corrupt or empty object file',
component => <<'EOF',
<%init>
my $path = 'support/corrupt_object_file';
my $comp = $m->fetch_comp('support/corrupt_object_file');
$m->comp($comp);
my $object_file = $comp->object_file;
die "object file does not exist" unless -f $object_file;
die "object file is not writable" unless -w $object_file;
my $corrupt_object_file_and_reload = sub {
my ($content) = @_;
my $original_object_file_size = (stat($object_file))[7];
my $fh = new IO::File ">$object_file"
or die "cannot write $object_file: $!";
$fh->print($content);
$fh->close();
die "object file is not the right size after corruption"
unless (stat($object_file))[7] == length($content);
$m->interp->flush_code_cache();
$m->comp($path);
die "object file is the same size after reloading"
if (stat($object_file))[7] == length($content);
};
$corrupt_object_file_and_reload->("");
$corrupt_object_file_and_reload->(0);
$corrupt_object_file_and_reload->("return 5");
$corrupt_object_file_and_reload->("slkd%^^&*(@@");
$corrupt_object_file_and_reload->("die 'bleah';");
%init>
EOF
expect => <<'EOF',
I was loaded
I was loaded
I was loaded
I was loaded
I was loaded
I was loaded
EOF
);
return $group;
}
HTML-Mason-1.56/t/05a-stack-corruption.t 0000644 0001750 0001750 00000002715 12431555444 017462 0 ustar autarch autarch use strict;
use warnings;
use HTML::Mason::Tests;
my $tests = make_tests();
$tests->run;
sub make_tests
{
my $group = HTML::Mason::Tests->tests_class->new( name => 'stack_corruption',
description => 'tests for stack corruption',
);
# The key to this test is that it first calls a component that in
# turn has a comp-with-content call. That comp-with-content call
# then calls $m->content (this is important).
#
# After that, _further_ component calls reveal stack corruption.
$group->add_support( path => '/support/comp',
component => <<'EOF',
<&| .subcomp1 &>
<& .subcomp2 &>
&>
<%def .subcomp1>
% $m->content;
%def>
<%def .subcomp2>
content
%def>
EOF
);
$group->add_support( path => '/support/comp2',
component => <<'EOF',
EOF
);
$group->add_test( name => 'stack_corruption',
description => 'test for stack corruption with comp-with-content call',
component => <<'EOF',
<& support/comp &>
<& support/comp2 &>
<& .callers &>
<%def .callers>
Stack at this point:
% for my $f ( $m->callers ) {
<% defined $f ? $f->path : 'undef' %>
% }
%def>
EOF
expect => qr{/stack_corruption/stack_corruption:.callers\n(?!undef)},
);
return $group;
}
HTML-Mason-1.56/t/11-inherit.t 0000644 0001750 0001750 00000040475 12431555444 015456 0 ustar autarch autarch use strict;
use warnings;
use HTML::Mason::Tests;
my $tests = make_tests();
$tests->run;
sub make_tests
{
my $group = HTML::Mason::Tests->tests_class->new( name => 'inherit',
description => 'Test inheritance' );
#------------------------------------------------------------
$group->add_support( path => 'autohandler',
component => <<'EOF',
<%method m1>m1 from level 1%method>
<%method m12>m12 from level 1%method>
<%method m13>m13 from level 1%method>
<%method m123>m123 from level 1%method>
<%attr>
a1=>'a1 from level 1'
a12=>'a12 from level 1'
a13=>'a13 from level 1'
a123=>'a123 from level 1'
%attr>
<& { base_comp => $m->base_comp }, 'variants' &>
% $m->call_next;
EOF
);
#------------------------------------------------------------
$group->add_support( path => 'report_parent',
component => <<'EOF',
% my $comp = $m->callers(1);
My name is <% $comp->path %> and <% $comp->parent ? "my parent is ".$comp->parent->path : "I have no parent" %>.
EOF
);
#------------------------------------------------------------
$group->add_support( path => 'variants',
component => <<'EOF',
% my @variants = qw(1 2 3 12 13 23 123);
Methods (called from <% $m->callers(1)->title %>)
% foreach my $v (@variants) {
% if ($self->method_exists("m$v")) {
m<% $v %>: <& "SELF:m$v" &>
% } else {
m<% $v %>: does not exist
% }
% }
Attributes (referenced from <% $m->callers(1)->title %>)
% foreach my $v (@variants) {
% if ($self->attr_exists("a$v")) {
a<% $v %>: <% $self->attr("a$v") %>
% } else {
a<% $v %>: does not exist
% }
% }
<%init>
my $self = $m->base_comp;
%init>
EOF
);
#------------------------------------------------------------
$group->add_support( path => 'subdir/call_next_helper',
component => <<'EOF',
<%init>
# Making sure we can call_next from a helper component
$m->call_next;
%init>
EOF
);
#------------------------------------------------------------
$group->add_support( path => 'subdir/autohandler',
component => <<'EOF',
<%method m2>m2 from level 2%method>
<%method m12>m12 from level 2%method>
<%method m23>m23 from level 2%method>
<%method m123>m123 from level 2%method>
<%attr>
a2=>'a2 from level 2'
a12=>'a12 from level 2'
a23=>'a23 from level 2'
a123=>'a123 from level 2'
%attr>
<& { base_comp => $m->base_comp }, '../variants' &>
<& call_next_helper &>
<%init>
my $self = $m->base_comp;
%init>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'bypass',
description => 'test inheritance that skips one autohandler',
path => 'subdir/bypass',
call_path => 'subdir/bypass',
component => <<'EOF',
<%method m3>m3 from level 3%method>
<%method m13>m13 from level 3%method>
<%method m23>m23 from level 3%method>
<%method m123>m123 from level 3%method>
<%attr>
a3=>'a3 from level 3'
a13=>'a13 from level 3'
a23=>'a23 from level 3'
a123=>'a123 from level 3'
%attr>
<& { base_comp => $m->base_comp }, '../variants' &>
<& ../report_parent &>
<%flags>
inherit=>'../autohandler'
%flags>
EOF
expect => <<'EOF',
Methods (called from /inherit/autohandler)
m1: m1 from level 1
m2: does not exist
m3: m3 from level 3
m12: m12 from level 1
m13: m13 from level 3
m23: m23 from level 3
m123: m123 from level 3
Attributes (referenced from /inherit/autohandler)
a1: a1 from level 1
a2: does not exist
a3: a3 from level 3
a12: a12 from level 1
a13: a13 from level 3
a23: a23 from level 3
a123: a123 from level 3
Methods (called from /inherit/subdir/bypass)
m1: m1 from level 1
m2: does not exist
m3: m3 from level 3
m12: m12 from level 1
m13: m13 from level 3
m23: m23 from level 3
m123: m123 from level 3
Attributes (referenced from /inherit/subdir/bypass)
a1: a1 from level 1
a2: does not exist
a3: a3 from level 3
a12: a12 from level 1
a13: a13 from level 3
a23: a23 from level 3
a123: a123 from level 3
My name is /inherit/subdir/bypass and my parent is /inherit/autohandler.
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'ignore',
description => 'turning off inheritance',
path => 'subdir/ignore',
call_path => 'subdir/ignore',
component => <<'EOF',
<%method m3>m3 from level 3%method>
<%method m13>m13 from level 3%method>
<%method m23>m23 from level 3%method>
<%method m123>m123 from level 3%method>
<%attr>
a3=>'a3 from level 3'
a13=>'a13 from level 3'
a23=>'a23 from level 3'
a123=>'a123 from level 3'
%attr>
%# base_comp currently does not change when a comp ref is used
% my $variants = $m->fetch_comp('../variants');
<& $variants &>
<& ../report_parent &>
<%flags>
inherit=>undef
%flags>
EOF
expect => <<'EOF',
Methods (called from /inherit/subdir/ignore)
m1: does not exist
m2: does not exist
m3: m3 from level 3
m12: does not exist
m13: m13 from level 3
m23: m23 from level 3
m123: m123 from level 3
Attributes (referenced from /inherit/subdir/ignore)
a1: does not exist
a2: does not exist
a3: a3 from level 3
a12: does not exist
a13: a13 from level 3
a23: a23 from level 3
a123: a123 from level 3
My name is /inherit/subdir/ignore and I have no parent.
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'normal',
description => 'normal inheritance path',
path => 'subdir/normal',
call_path => 'subdir/normal',
component => <<'EOF',
<%method m3>m3 from level 3%method>
<%method m13>m13 from level 3%method>
<%method m23>m23 from level 3%method>
<%method m123>m123 from level 3%method>
<%attr>
a3=>'a3 from level 3'
a13=>'a13 from level 3'
a23=>'a23 from level 3'
a123=>'a123 from level 3'
%attr>
<& { base_comp => $m->base_comp }, '../variants' &>
<& ../report_parent &>
EOF
expect => <<'EOF',
Methods (called from /inherit/autohandler)
m1: m1 from level 1
m2: m2 from level 2
m3: m3 from level 3
m12: m12 from level 2
m13: m13 from level 3
m23: m23 from level 3
m123: m123 from level 3
Attributes (referenced from /inherit/autohandler)
a1: a1 from level 1
a2: a2 from level 2
a3: a3 from level 3
a12: a12 from level 2
a13: a13 from level 3
a23: a23 from level 3
a123: a123 from level 3
Methods (called from /inherit/subdir/autohandler)
m1: m1 from level 1
m2: m2 from level 2
m3: m3 from level 3
m12: m12 from level 2
m13: m13 from level 3
m23: m23 from level 3
m123: m123 from level 3
Attributes (referenced from /inherit/subdir/autohandler)
a1: a1 from level 1
a2: a2 from level 2
a3: a3 from level 3
a12: a12 from level 2
a13: a13 from level 3
a23: a23 from level 3
a123: a123 from level 3
Methods (called from /inherit/subdir/normal)
m1: m1 from level 1
m2: m2 from level 2
m3: m3 from level 3
m12: m12 from level 2
m13: m13 from level 3
m23: m23 from level 3
m123: m123 from level 3
Attributes (referenced from /inherit/subdir/normal)
a1: a1 from level 1
a2: a2 from level 2
a3: a3 from level 3
a12: a12 from level 2
a13: a13 from level 3
a23: a23 from level 3
a123: a123 from level 3
My name is /inherit/subdir/normal and my parent is /inherit/subdir/autohandler.
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/base/autohandler',
component => <<'EOF',
<%flags>
inherit => undef
%flags>
<%attr>
a => 'base autohandler'
%attr>
<%method x>
This is X in base autohandler
attribute A is <% $m->base_comp->attr('a') %>
<& SELF:x &>
<& .util &>
%method>
<%method y>
This is method Y in base autohandler
base_comp is <% $m->base_comp->name %>
%method>
<%def .util>
This is subcomponent .util
base_comp is <% $m->base_comp->name %>
<& SELF:y &>
%def>
% $m->call_next;
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/util/autohandler',
component => <<'EOF',
<%flags>
inherit => undef
%flags>
<%attr>
a => 'util autohandler'
%attr>
<%method x>
This is X in util autohandler
attribute A is <% $m->base_comp->attr('a') %>
<& SELF:x , why => 'infinite loop if PARENT does not work ' &>
%method>
<%method exec>
This is autohandler:exec
exec was really called for <% $m->base_comp->name %>
attribute A is <% $m->base_comp->attr('a') %>
<& SELF:x &>
%method>
% $m->call_next;
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/util/util',
component => <<'EOF',
<%method x>
This is method X in UTIL
%method>
<%attr>
a => 'util'
%attr>
This is UTIL
attribute A is <% $m->base_comp->attr('a') %>
<& SELF:x &>
<& PARENT:x &>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'base_comp',
path => '/base/base',
call_path => '/base/base',
description => 'base_comp test',
component => <<'EOF',
<%method x>
This is method X in BASE
%method>
<%attr>
a => 'base'
%attr>
This is BASE
attribute A is <% $m->base_comp->attr('a') %>
<& SELF:x &>
<& ../util/util &>
<& PARENT:x &>
EOF
expect => <<'EOF',
This is BASE
attribute A is base
This is method X in BASE
This is UTIL
attribute A is util
This is method X in UTIL
This is X in util autohandler
attribute A is util
This is method X in UTIL
This is X in base autohandler
attribute A is base
This is method X in BASE
This is subcomponent .util
base_comp is base
This is method Y in base autohandler
base_comp is base
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'base_comp_method',
path => '/base/meth',
call_path => '/base/meth',
description => 'base_comp method inheritance test',
component => <<'EOF',
<%method x>
This is method X in METH
%method>
<%attr>
a => 'meth'
%attr>
This is METH
attribute A is <% $m->base_comp->attr('a') %>
<& SELF:x &>
<& ../util/util:exec &>
EOF
expect => <<'EOF',
This is METH
attribute A is meth
This is method X in METH
This is autohandler:exec
exec was really called for util
attribute A is util
This is method X in UTIL
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/base2/autohandler',
component => <<'EOF',
<%flags>
inherit => undef
%flags>
This is autohandler A
<& sub/sibling &>
% $m->call_next;
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/base2/sub/autohandler',
component => <<'EOF',
This is autohandler B
<& SELF:m &>
% $m->call_next;
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/base2/sub/sibling',
component => <<'EOF',
This is SIBLING
<& PARENT &>
<%method m>
This is method M in SIBLING
%method>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'double_parent',
path => '/base2/sub/child',
call_path => '/base2/sub/child',
description => 'test that parent does not confuse children',
component => <<'EOF',
This is CHILD
<%method m>
This is method M in CHILD
%method>
EOF
expect => <<'EOF',
This is autohandler A
This is SIBLING
This is autohandler B
This is method M in SIBLING
This is CHILD
This is autohandler B
This is method M in CHILD
This is CHILD
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'subcomponent',
path => '/base2/subcomp',
call_path => '/base2/subcomp',
description => 'test subcomponents',
component => <<'EOF',
<%flags>
inherit => undef
%flags>
<%def .sub>
This is a subcomponent
<& SELF:x &>
%def>
<%method x>
This is method X
%method>
This is the component
<& .sub &>
EOF
expect => <<'EOF',
This is the component
This is a subcomponent
This is method X
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/base3/autohandler',
component => <<'EOF',
<%flags>
inherit => undef
%flags>
<%method x>
This is X in base autohandler
%method>
<& .foo &>
<%def .foo>
% $m->call_next;
%def>
EOF
);
#------------------------------------------------------------
# Remarks: this used to work in older versions of Mason. It's not
# *quite* surprising that it fails, because the call to <& .foo &>
# is a "normal" call and thus changes base_comp. But since .foo
# can't actually function usefully as a base_comp (as far as I
# know), it would be possible to not change base_comp while
# calling subcomponents. Currently base_comp changes to the
# autohandler in this situation, which seems odd.
#
# Current workaround is <& {base_comp => $m->request_comp}, $m->fetch_next, $m->caller_args(1) &>
#
# -Ken
$group->add_test( name => 'call_next_in_def',
path => '/base3/call_next_in_def',
call_path => '/base3/call_next_in_def',
description => 'Test call_next() inside a subcomponent',
component => <<'EOF',
<%method x>
This is method X in BASE
%method>
This is BASE
base_comp is <% $m->base_comp->name %>
<& SELF:x &>
EOF
expect => <<'EOF',
This is BASE
base_comp is call_next_in_def
This is method X in BASE
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/subcompbase/parent',
component => <<'EOF',
<& _foo &>
<%def _foo>
<& SELF:bar &>
%def>
<%method bar>
This is parent's bar.
%method>
<%flags>
inherit => undef
%flags>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'subcomponent_inheritance',
path => '/subcompbase/child',
call_path => '/subcompbase/child',
description => 'test base_comp with subcomponents',
component => <<'EOF',
<%flags>
inherit => 'parent'
%flags>
<%method bar>
This is child's bar.
%method>
EOF
expect => <<'EOF',
This is child's bar.
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/request_test/autohandler',
component => <<'EOF',
<& SELF:x &>\
<& REQUEST:x &>\
next\
% $m->call_next;
<%method x>
x in autohandler
%method>
<%flags>
inherit => undef
%flags>
EOF
);
$group->add_support( path => '/request_test/other_comp',
component => <<'EOF',
<& REQUEST:x &>\
<& SELF:x &>\
<%method x>x in other comp
%method>
<%flags>
inherit => undef
%flags>
EOF
);
$group->add_test( name => 'request_tests',
path => '/request_test/request_test',
call_path => '/request_test/request_test',
description => 'Test that REQUEST: works',
component => <<'EOF',
<& PARENT:x &>\
<& other_comp &>\
<%method x>x in requested comp
%method>
EOF
expect => <<'EOF',
x in requested comp
x in requested comp
next
x in autohandler
x in requested comp
x in other comp
EOF
);
#------------------------------------------------------------
return $group;
}
HTML-Mason-1.56/t/13-errors.t 0000644 0001750 0001750 00000035655 12431555444 015336 0 ustar autarch autarch use strict;
use warnings;
use Cwd qw(realpath);
use File::Basename;
use File::Spec;
use HTML::Mason::Tests;
use HTML::Mason::Tools qw(load_pkg);
my $root_dir = realpath(dirname(dirname($0)));
my $tests = make_tests();
$tests->run;
# Using this as an error_format with error_mode='output' causes just
# the error string to be output
sub HTML::Mason::Exception::as_munged
{
my $err = shift->error;
return $err =~ /^(.+?) at/ ? $1 : $err;
}
sub make_tests
{
my $group = HTML::Mason::Tests->tests_class->new( name => 'errors',
description => 'Test that errors are generated properly' );
#------------------------------------------------------------
$group->add_support( path => '/support/error_helper',
component => <<'EOF',
<%init>
eval { $m->comp('error1') };
$m->comp('error2');
%init>
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/support/error1',
component => <<'EOF',
% die "terrible error";
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/support/error2',
component => <<'EOF',
% die "horrible error";
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'bad_args',
description => 'Make sure a bad args line is caught properly',
component => <<'EOF',
<%args>
foo
%args>
EOF
expect_error => qr|Invalid <%args> section line|
);
#------------------------------------------------------------
$group->add_test( name => 'backtrace',
description => 'Make sure trace for second error is accurate when first error is caught by eval',
component => <<'EOF',
<%init>
$m->comp('support/error_helper');
%init>
EOF
expect_error => q|horrible error.*|
);
#------------------------------------------------------------
# This fails as root because the file will always be readable, but
# we can't know that it will fail until we're inside the test. So
# we'll just run this test for developers, not end users.
if ( $ENV{MASON_MAINTAINER} )
{
$group->add_support( path => '/support/unreadable',
component => <<'EOF',
unreadable
EOF
);
my $file = File::Spec->catfile( $group->comp_root, 'errors', 'support', 'unreadable' );
$group->add_test( name => 'cannot_read_source',
description => 'Make sure that Mason throws a useful error when it cannot read a source file',
component => <<"EOF",
<%init>
chmod 0222, '$file'
or die "Cannot chmod file for " . '$file' . ": \$!";
\$m->comp('support/unreadable');
%init>
EOF
expect_error => q|Permission denied|
);
}
#------------------------------------------------------------
$group->add_support( path => '/support/zero_size',
component => '',
);
#------------------------------------------------------------
$group->add_test( name => 'read_zero_size',
description => 'Make sure that Mason handles a zero length source file correctly',
component => <<'EOF',
zero[<& support/zero_size &>]zero
EOF
expect => <<'EOF'
zero[]zero
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'bad_source_callback',
description => 'Make sure that a bad source_callback for a ComponentSource object reports a useful error',
interp_params => { resolver_class => 'My::Resolver' },
component => <<'EOF',
does not matter
EOF
expect_error => qr/Undefined subroutine.*will_explode/,
);
#------------------------------------------------------------
$group->add_test( name => 'bad_escape_flag',
description => 'Make sure that an invalid escape flag is reported properly',
component => <<'EOF',
<% 1234 | abc %>
EOF
expect_error => qr/Invalid escape flag: abc/,
);
#------------------------------------------------------------
$group->add_test( name => 'error_mode_output',
description => 'Make sure that existing output is cleared when an error occurs in error_mode=output',
interp_params => { error_format => 'munged',
error_mode => 'output',
},
component => <<'EOF',
Should not appear in output!
% $m->comp( '/errors/support/error1' );
EOF
expect => <<'EOF',
terrible error
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'error_in_subrequest',
description => 'Make sure that an error in a subrequest is propogated back to the main request',
interp_params => { error_format => 'munged',
error_mode => 'output',
},
component => <<'EOF',
Should not appear in output!
% $m->subexec( '/errors/support/error1' );
EOF
expect => <<'EOF',
terrible error
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'check_error_format',
description => 'Make sure setting error_format => "html" works',
interp_params => { error_format => 'html',
error_mode => 'output',
},
component => <<'EOF',
% die("Horrible death");
EOF
expect => qr{^\s+.*Horrible death}is,
);
#------------------------------------------------------------
$group->add_test( name => 'check_exec_not_found',
description => 'Request to non-existent component',
component => <<'EOF',
% $m->subexec("/does/not/exist");
EOF
expect_error => qr{could not find component for initial path}is,
);
#------------------------------------------------------------
$group->add_test( name => 'check_exec_not_found_html_format',
description => 'Request to non-existent component in html format',
interp_params => { error_format => 'html',
error_mode => 'output',
},
component => <<'EOF',
% $m->subexec("/does/not/exist");
EOF
expect => qr{^\s+.*could not find component for initial path}is,
);
#------------------------------------------------------------
$group->add_test( name => 'check_comp_not_found',
description => 'Component call to non-existent component',
component => <<'EOF',
% $m->comp("/does/not/exist");
EOF
expect_error => qr{could not find component for path}is,
);
#------------------------------------------------------------
$group->add_test( name => 'change_error_format',
description => 'Make sure setting $m->error_format($foo) works on the fly',
interp_params => { error_format => 'html',
error_mode => 'output',
},
component => <<'EOF',
% $m->error_format('text');
% die("Horrible death");
EOF
expect => qr{^Horrible death},
);
#------------------------------------------------------------
$group->add_test( name => 'check_error_format_brief',
description => 'Make sure setting error_format => "brief" works',
interp_params => { error_format => 'brief',
error_mode => 'output',
},
component => <<'EOF',
% die("Horrible death");
EOF
expect => qr{^Horrible death at .*check_error_format_brief line \d+\.$}s,
);
#------------------------------------------------------------
$group->add_test( name => 'object_exception',
description => "Make sure Mason doesn't co-opt non Exception::Class exception objects",
component => <<'EOF',
% eval { die bless { foo => 'bar' }, 'FooException' };
<% ref $@ %>
EOF
expect => <<'EOF',
FooException
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'subcomponent_redefined',
description => "Make sure Mason doesn't allow redefinition of subcomponent",
component => <<'EOF',
<%def foo>
foo
%def>
<%def foo>
foo
%def>
EOF
expect_error => qr/Duplicate definition of subcomponent/,
);
#------------------------------------------------------------
$group->add_test( name => 'method_redefined',
description => "Make sure Mason doesn't allow redefinition of method",
component => <<'EOF',
<%method foo>
foo
%method>
<%method foo>
foo
%method>
EOF
expect_error => qr/Duplicate definition of method/,
);
#------------------------------------------------------------
$group->add_test( name => 'method_subcomp_conflict',
description => "Make sure Mason doesn't allow a subcomponent and method to have the same name",
component => <<'EOF',
<%method foo>
foo
%method>
<%def foo>
foo
%def>
EOF
expect_error => qr/with the same name/,
);
#------------------------------------------------------------
$group->add_test( name => 'subcomp_bad_name',
description => "Make sure Mason doesn't allow a subcomponent with a bad name",
component => <<'EOF',
<%def abc+def>
foo
%def>
EOF
expect_error => qr/Invalid def name/,
);
#------------------------------------------------------------
$group->add_test( name => 'content_comp_wrong_error',
description => "Make sure syntax error inside <&|> &> tags is thrown correctly",
component => <<'EOF',
<&| ttt &>
<%
&>
<%def ttt>
%def>
EOF
expect_error => qr/'<%' without matching '%>'/,
);
#------------------------------------------------------------
$group->add_test( name => 'top_level_compilation_error',
description => "Make sure top-level compiler errors work in output mode",
interp_params => {
error_format => 'text',
error_mode => 'output',
},
component => <<'EOF',
% my $x =
EOF
# match "Error during compilation" followed by
# exactly one occurance of "Stack:"
# (Mason should stop after the first error)
expect => qr/Error during compilation((?!Stack:).)*Stack:((?!Stack:).)*$/s,
);
#------------------------------------------------------------
$group->add_test( name => 'component_error_handler_false',
description => 'Test error-handling with component_error_handler set to false',
interp_params => { component_error_handler => 0 },
component => <<'EOF',
% die 'a string error';
EOF
expect_error => qr/a string error/,
);
#------------------------------------------------------------
$group->add_test( name => 'component_error_Handler_no_upgrade',
description => 'Test that errors do not become object with component_error_handler set to false',
interp_params => { component_error_handler => 0 },
component => <<'EOF',
% eval { die 'a string error' };
exception: <% ref $@ ? ref $@ : 'not a ref' %>
EOF
expect => <<'EOF',
exception: not a ref
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'component_error_handler_false_fatal_mode',
description => 'Test error-handling with component_error_handler set to false and error_mode set to fatal',
interp_params => { component_error_handler => 0,
error_mode => 'fatal',
},
component => <<'EOF',
% die 'a string error';
EOF
expect_error => qr/a string error/,
);
#------------------------------------------------------------
$group->add_test( name => 'component_error_handler_uc_message',
description => 'Test error-handling with component_error_handler set to a subroutine that upper-cases all text',
interp_params => { component_error_handler => sub { die map { uc } @_ } },
component => <<'EOF',
% die 'a string error';
EOF
expect_error => qr/A STRING ERROR/,
);
#------------------------------------------------------------
$group->add_test( name => 'use_bad_module',
description => 'Use a module with an error',
component => <<'EOF',
<%init>
use lib qw(t/lib); use BadModule;
%init>
hi!
EOF
expect_error => qr/syntax error/,
);
#------------------------------------------------------------
$group->add_test( name => 'require_bad_module_in_once',
description => 'Require a module with an error in a once block',
component => <<'EOF',
<%once>
require "t/lib/BadModule.pm";
%once>
hi!
EOF
expect_error => qr/syntax error/,
);
#------------------------------------------------------------
return $group;
}
package My::Resolver;
use base 'HTML::Mason::Resolver::File';
sub get_info
{
my $self = shift;
if ( my $source = $self->SUPER::get_info(@_) )
{
$source->{source_callback} = sub { will_explode() };
return $source;
}
}
HTML-Mason-1.56/t/19-subrequest.t 0000644 0001750 0001750 00000026755 12431555444 016233 0 ustar autarch autarch use strict;
use warnings;
use HTML::Mason::Tests;
my $tests = make_tests();
$tests->run;
sub make_tests
{
my $group = HTML::Mason::Tests->tests_class->new( name => 'subrequest',
description => 'subrequest-related features' );
#------------------------------------------------------------
$group->add_support( path => '/support/subrequest_error_test',
component => <<'EOF',
<& /shared/display_req_obj &>
% die "whoops!";
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/support/dir/autohandler',
component => <<'EOF',
I am the autohandler.
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/support/dir/comp',
component => <<'EOF',
I am the called comp (no autohandler).
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'subrequest',
description => 'tests the official subrequest mechanism',
component => <<'EOF',
<%def .helper>
Executing subrequest
% print "I can print before the subrequest\n";
% my $buf;
% my $req = $m->make_subrequest(comp=>'/shared/display_req_obj', out_method => \$buf);
% $req->exec();
<% $buf %>
% print "I can still print after the subrequest\n";
%def>
Calling helper
<& .helper &>
EOF
expect => <<'EOF',
Calling helper
Executing subrequest
I can print before the subrequest
My depth is 1.
I am a subrequest.
The top-level component is /shared/display_req_obj.
My stack looks like:
-----
/shared/display_req_obj
-----
I can still print after the subrequest
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'subrequest_with_autohandler',
description => 'tests the subrequest mechanism with an autohandler',
component => <<'EOF',
Executing subrequest
% my $buf;
% my $req = $m->make_subrequest(comp=>'/subrequest/support/dir/comp', out_method => \$buf);
% $req->exec();
<% $buf %>
EOF
expect => <<'EOF',
Executing subrequest
I am the autohandler.
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/subrequest2/autohandler',
component => <<'EOF',
I am the autohandler for <% $m->base_comp->name %>.
% $m->call_next;
<%flags>
inherit => undef
%flags>
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/subrequest2/bar',
component => <<'EOF',
I am bar.
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'subreq_exec_order',
path => '/subrequest2/subreq_exec_order',
call_path => '/subrequest2/subreq_exec_order',
description => 'Test that output from a subrequest comes out when we expect it to.',
component => <<'EOF',
% $m->subexec('/subrequest/subrequest2/bar');
I am subreq_exec_order.
EOF
expect => <<'EOF',
I am the autohandler for subreq_exec_order.
I am the autohandler for bar.
I am bar.
I am subreq_exec_order.
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/support/autoflush_subrequest',
component => <<'EOF',
% $m->autoflush($autoflush) if $autoflush;
here is the child
% $m->clear_buffer if $clear;
<%args>
$autoflush => 0
$clear => 0
%args>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'autoflush_subrequest',
description => 'make sure that a subrequest respects its parent autoflush setting',
interp_params => { autoflush => 1 },
component => <<'EOF',
My child says:
% $m->flush_buffer;
% $m->subexec('/subrequest/support/autoflush_subrequest');
% $m->clear_buffer;
EOF
expect => <<'EOF',
My child says:
here is the child
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'subrequest_inherits_no_autoflush',
description => 'make sure that a subrequest inherits its parent autoflush setting (autoflush off)',
interp_params => { autoflush => 0 },
component => <<'EOF',
My child says:
% $m->flush_buffer;
% $m->subexec('/subrequest/support/autoflush_subrequest');
% $m->clear_buffer;
EOF
expect => <<'EOF',
My child says:
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'autoflush_in_subrequest',
description => 'make sure that a subrequest with autoflush on does not flush parent',
component => <<'EOF',
My child says:
% $m->flush_buffer;
% $m->subexec('/subrequest/support/autoflush_subrequest', autoflush => 1);
% $m->clear_buffer;
EOF
expect => <<'EOF',
My child says:
EOF
);
#------------------------------------------------------------
# SKIPPING THIS TEST FOR NOW - NOT SURE OF DESIRED BEHAVIOR
if (0) {
$group->add_test( name => 'autoflush_in_parent_not_subrequest',
description => 'make sure that a subrequest with autoflush can clear its own buffers',
interp_params => { autoflush => 1 },
component => <<'EOF',
My child says:
% $m->flush_buffer;
% $m->subexec('/subrequest/support/autoflush_subrequest', autoflush => 0, clear => 1);
% $m->clear_buffer;
EOF
expect => <<'EOF',
My child says:
EOF
);
}
#------------------------------------------------------------
$group->add_support( path => '/support/return/scalar',
component => <<'EOF',
% die "wantarray should be false" unless defined(wantarray) and !wantarray;
% return 'foo';
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'return_scalar',
description => 'tests that exec returns scalar return value of top component',
component => <<'EOF',
% my $req = $m->make_subrequest(comp=>'/subrequest/support/return/scalar');
% my $value = $req->exec();
return value is <% $value %>
EOF
expect => <<'EOF',
return value is foo
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/support/return/list',
component => <<'EOF',
% die "wantarray should be true" unless wantarray;
% return (1, 2, 3);
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'return_list',
description => 'tests that exec returns list return value of top component',
component => <<'EOF',
% my $req = $m->make_subrequest(comp=>'/subrequest/support/return/list');
% my @value = $req->exec();
return value is <% join(",", @value) %>
EOF
expect => <<'EOF',
return value is 1,2,3
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/support/return/nothing',
component => <<'EOF',
wantarray is <% defined(wantarray) ? "defined" : "undefined" %>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'return_nothing',
description => 'tests exec in non-return context',
component => <<'EOF',
% my $req = $m->make_subrequest(comp=>'/subrequest/support/return/nothing');
% $req->exec();
EOF
expect => <<'EOF',
wantarray is undefined
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/support/output',
component => <<'EOF',
More output
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'kwindla',
description => 'tests bug report from Kwindla Kramer',
component => <<'EOF',
Some output
% $m->clear_buffer;
% my $req = $m->make_subrequest( comp => '/subrequest/support/output' );
% $req->exec();
% $m->flush_buffer;
% $m->abort;
EOF
expect => <<'EOF',
More output
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'in_package',
description => 'use in_package with subrequest',
interp_params => { in_package => 'Test::Package' },
component => <<'EOF',
Before subreq
% $m->subexec( '/subrequest/support/output' );
After subreq
EOF
expect => <<'EOF',
Before subreq
More output
After subreq
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'relative_path_call',
description => 'call subrequest with relative path',
component => <<'EOF',
% $m->subexec( 'support/output' );
EOF
expect => <<'EOF',
More output
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'comp_object_call',
description => 'call subrequest with component object',
component => <<'EOF',
% $m->subexec( $m->interp->load('/subrequest/support/output') );
EOF
expect => <<'EOF',
More output
EOF
);
#------------------------------------------------------------
$group->add_support( path => 'support/subexec_recurse_test',
component => <<'EOF',
Entering <% $m->request_depth %>
% if ($count < $max) {
% $m->subexec('subexec_recurse_test', count=>$count+1, max=>$max)
% }
Exiting <% $m->request_depth %>
<%args>
$count=>0
$max
%args>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'max_recurse_1',
description => 'Test that recursion 8 levels deep is allowed',
component => '<& support/subexec_recurse_test, max=>8 &>',
expect => <<'EOF',
Entering 1
Entering 2
Entering 3
Entering 4
Entering 5
Entering 6
Entering 7
Entering 8
Entering 9
Exiting 9
Exiting 8
Exiting 7
Exiting 6
Exiting 5
Exiting 4
Exiting 3
Exiting 2
Exiting 1
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'max_recurse_2',
description => 'Test that recursion is stopped after 32 subexecs',
component => '<& support/subexec_recurse_test, max=>48 &>',
expect_error => qr{subrequest depth > 32 \(infinite subrequest loop\?\)},
);
#------------------------------------------------------------
return $group;
}
HTML-Mason-1.56/t/author-pod-spell.t 0000644 0001750 0001750 00000005620 12431555444 016765 0 ustar autarch autarch
BEGIN {
unless ($ENV{AUTHOR_TESTING}) {
require Test::More;
Test::More::plan(skip_all => 'these tests are for testing by the author');
}
}
use strict;
use warnings;
use Test::More;
# generated by Dist::Zilla::Plugin::Test::PodSpelling 2.006008
use Test::Spelling 0.12;
use Pod::Wordlist;
add_stopwords();
all_pod_files_spelling_ok( qw( bin lib ) );
__DATA__
DROLSKY
DROLSKY's
Rolsky
Rolsky's
AUTOHANDLERS
Adminstrator
ApacheModPerl
ApacheReload
Autohandlers
Bekman
CGI
ContactUs
DSO
DeWitt
DocumentRoot
DocumentRoots
FastCGI
FilesMatch
Follett
ForceFileDownload
GIF
Georgiou
HPUX
HUP
HandlingDirectoriesWithDhandlers
Khera
Kiriakos
Kirwan
Kumar
LFU
LogLevel
MSIE
MailingLists
Mallah
MasonAllowGlobals
MasonApacheStatusTitle
MasonArgsMethod
MasonAutoSendHeaders
MasonAutoflush
MasonAutohandlerName
MasonBufferPreallocateSize
MasonCodeCacheMaxSize
MasonCompClass
MasonCompRoot
MasonCompilerClass
MasonComponentErrorHandler
MasonDataCacheApi
MasonDataCacheDefaults
MasonDataDir
MasonDeclineDirs
MasonDefaultEscapeFlags
MasonDefineArgsHash
MasonDhandlerName
MasonDynamicCompRoot
MasonEnableAutoflush
MasonErrorFormat
MasonErrorMode
MasonEscapeFlags
MasonIgnoreWarningsExpr
MasonInPackage
MasonInterpClass
MasonLexerClass
MasonMaxRecurse
MasonNamedComponentSubs
MasonObjectFileExtension
MasonOutMethod
MasonPlugins
MasonPostamble
MasonPostprocessPerl
MasonPostprocessText
MasonPreamble
MasonPreloads
MasonPreprocess
MasonRequestClass
MasonResolverClass
MasonStaticSource
MasonStaticSourceTouchFile
MasonSubcompClass
MasonUseObjectFiles
MasonUseSourceLineNumbers
MasonUseStrict
MasonUseWarnings
NullCache
O'Reilly
PerlFreshRestart
PerlHandler
PerlModule
PerlSetVar
Preallocating
Preloading
RPMs
Rajesh
RedHat
ReloadAll
SUBCLASSABLE
SYNOPIS
Solaris
SpeedyCGI
Stas
Subcomponents
Subrequests
TIEHASH
USR
UserDir
Vivek
ala
apachectl
apachehandler
attr
autohandler
autohandlers
bgcolor
breakpoint'able
certian
checksum
conf
corrup
defined'ness
dhandler
dhandlers
dynamicImage
faq
fh
fido
filenaming
foobarbaz
gif
gifs
htaccess
html
interp
isNetscape
ized
izing
jpegs
lexed
libapreq
libexpat
mc
mcomp
mhtml
mpl
mtxt
nh
onwards
optimizations
overrideable
perlsub
postprocess
predeclaring
preload
preloaded
preloading
preloads
prepopulate
preprocess
profiler
rdist
reallocations
reparsed
reuseability
scomp
se
serializable
sql
srm
subcomponent
subcomponents
subcomps
subexec
subrequest
subrequests
taglibs
tgz
tmp
todo
un
undeclarable
unweakened
updateable
uring
use'd
xml
Jonathan
Swartz
swartz
Dave
autarch
Ken
Williams
ken
Ævar
Arnfjörð
Bjarmason
avarab
Alex
Vandiver
alex
John
jwilliams
Kevin
Falcone
falcone
Patrick
Kane
modus
Ricardo
Signes
rjbs
lib
HTML
Mason
Compiler
Devel
Params
Resolver
File
Plugin
Context
Utils
ToObject
FakeApache
Subclassing
Component
FileBased
Null
Escapes
Tests
Request
Subcomponent
Exceptions
Admin
Parser
Interp
Apache
Tools
Lexer
ApacheHandler
FAQ
Handler
CGIHandler
Cache
BaseCache
ComponentSource
MethodMaker
HTML-Mason-1.56/t/07a-interp-mcr.t 0000644 0001750 0001750 00000012471 12431555444 016235 0 ustar autarch autarch use strict;
use warnings;
use HTML::Mason::Tests;
my $tests = make_tests();
$tests->run;
sub make_tests
{
my $group = HTML::Mason::Tests->tests_class->new( name => 'interp-mcr',
description => 'In-depth testing of multiple component roots' );
$group->add_test( name => 'no_dynamic_comp_root',
description => 'change comp root without dynamic_comp_root',
pre_code => sub {
my ($interp) = @_;
$interp->comp_root($group->data_dir);
},
skip_component => 1,
call_path => '/',
expect_error => qr/cannot assign new comp_root/,
);
$group->add_test( name => 'change_single_comp_root',
description => 'change single root',
interp_params => {comp_root => '/usr/local/foo',
dynamic_comp_root => 1},
pre_code => sub {
my ($interp) = @_;
$interp->comp_root('/usr/local/bar');
},
skip_component => 1,
call_path => '/',
expect_error => qr/was originally associated with .*, cannot change/,
);
$group->add_test( name => 'reuse_comp_root_key',
description => 'change comp root key mapping',
interp_params => {comp_root => [['foo' => '/usr/local/foo'],
['bar' => '/usr/local/bar']],
dynamic_comp_root => 1},
pre_code => sub {
my ($interp) = @_;
$interp->comp_root([['foo' => '/usr/local/foo'],
['bar' => '/usr/local/baz']]),
},
skip_component => 1,
call_path => '/',
expect_error => qr/was originally associated with .*, cannot change/,
);
# For each test below, change the interpreter's component root on
# the fly, then make sure the right versions of /foo and /bar/ are
# being loaded. Also occasionally remove a component to make sure
# that the next one gets loaded. Run with both static_source=0 and
# static_source=1.
#
foreach my $static_source (0, 1) {
my $interp = $group->_make_interp ( comp_root => $group->comp_root,
data_dir => $group->data_dir,
static_source => $static_source,
dynamic_comp_root => 1,
);
foreach my $root (1..4) {
$group->add_support( path => "/$root/interp-mcr/$static_source/foo",
component => "I am $root/foo, <& bar &>",
);
}
foreach my $root (7..8) {
$group->add_support( path => "/$root/interp-mcr/$static_source/bar",
component => "I am $root/bar",
);
}
my $make_test_for_roots = sub
{
my ($keys, %params) = @_;
my $test_name = "test" . join('', @$keys) . "-" . $static_source;
$group->add_test( name => $test_name,
description => "test roots assigned to " . join(", ", @$keys) . ", static_source=$static_source",
skip_component => 1,
interp => $interp,
pre_code => sub {
$interp->comp_root([map { [$_, $group->comp_root . "/interp-mcr/$_"] } @$keys]);
if ($params{remove}) {
foreach my $comp (qw(foo bar)) {
unlink("mason_tests/$$/comps/interp-mcr/$params{remove}/interp-mcr/$static_source/$comp");
}
}
},
call_path => "/$static_source/foo",
%params
);
};
$make_test_for_roots->([1, 7], expect=>'I am 1/foo, I am 7/bar');
$make_test_for_roots->([1, 2, 3, 4, 8], expect=>'I am 1/foo, I am 8/bar');
if ($static_source) {
$make_test_for_roots->([1, 2, 3, 7], remove=>'1', expect=>'I am 1/foo, I am 7/bar');
} else {
$make_test_for_roots->([1, 2, 3, 7], remove=>'1', expect=>'I am 2/foo, I am 7/bar');
}
$make_test_for_roots->([2, 3, 4, 7], expect=>'I am 2/foo, I am 7/bar');
$make_test_for_roots->([5, 4, 2, 3, 8], expect=>'I am 4/foo, I am 8/bar');
$make_test_for_roots->([5, 6], expect_error => qr/could not find component/);
$make_test_for_roots->([1, 2, 3, 4], expect_error => qr/could not find component/);
}
return $group;
}
HTML-Mason-1.56/t/05-request.t 0000644 0001750 0001750 00000061006 12431555444 015500 0 ustar autarch autarch use strict;
use warnings;
use HTML::Mason::Tests;
my $tests = make_tests();
$tests->run;
sub make_tests
{
my $group = HTML::Mason::Tests->tests_class->new( name => 'request',
description => 'request object functionality' );
#------------------------------------------------------------
$group->add_support( path => '/support/abort_test',
component => <<'EOF',
<%args>
$val => 50
%args>
Some more text
% $m->abort($val);
But this will never be seen
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/sections/perl',
component => <<'EOF',
foo
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/support/various_test',
component => <<'EOF',
Caller is <% $m->caller->title %> or <% $m->callers(1)->title %> or <% $m->callers(-2)->title %>.
The top level component is <% $m->callers(-1)->title %> or <% $m->request_comp->title %>.
The full component stack is <% join(",",map($_->title,$m->callers)) %>.
My argument list is (<% join(",",$m->caller_args(0)) %>).
The top argument list is (<% join(",",$m->request_args()) %>) or (<% join(",",$m->caller_args(-1)) %>).
% foreach my $path (qw(various_test /request/sections/perl foobar /shared)) {
% my $full_path = HTML::Mason::Tools::absolute_comp_path($path, $m->current_comp->dir_path);
Trying to fetch <% $path %> (full path <% $full_path %>):
% if ($m->comp_exists($path)) {
% if (my $comp = $m->fetch_comp($path)) {
<% $path %> exists with title <% $comp->title %>.
% } else {
<% $path %> exists but could not fetch object!
% }
% } else {
<% $path %> does not exist.
% }
% }
% $m->print("Output via the out function.");
/request/file outputs <% int(length($m->scomp("/request/file"))/10) %>0+ characters.
EOF
);
#------------------------------------------------------------
$group->add_support( path => 'various_helper',
component => <<'EOF',
<& support/various_test, %ARGS &>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'abort',
description => 'test $m->abort method (autoflush on)',
interp_params => { autoflush => 1 },
component => <<'EOF',
Some text
% eval {$m->comp('support/abort_test')};
% if (my $err = $@) {
% if ($m->aborted) {
Component aborted with value <% $err->aborted_value %>
% } else {
Got error
% }
% }
EOF
expect => <<'EOF',
Some text
Some more text
Component aborted with value 50
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'abort_0',
description => 'test $m->abort method with value of 0',
component => <<'EOF',
Some text
% eval {$m->comp('support/abort_test', val => 0)};
% if (my $err = $@) {
% if ($m->aborted($err)) {
Component aborted with value <% $err->aborted_value %>
% } else {
Got error
% }
% }
EOF
expect => <<'EOF',
Some text
Some more text
Component aborted with value 0
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'abort',
description => 'test $m->abort method (autoflush off)',
component => <<'EOF',
Some text
% eval {$m->comp('support/abort_test')};
% if (my $err = $@) {
% if ($m->aborted) {
Component aborted with value <% $err->aborted_value %>
% } else {
Got error
% }
% }
EOF
expect => <<'EOF',
Some text
Some more text
Component aborted with value 50
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'file',
description => 'tests $m->file method',
component => <<'EOF',
Now I will print myself:
% my $output = $m->file("file");
% $output =~ s/\cM//g;
<% $output %>
EOF
expect => <<'EOF',
Now I will print myself:
Now I will print myself:
% my $output = $m->file("file");
% $output =~ s/\cM//g;
<% $output %>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'file_in_subcomp',
description => 'tests $m->file method in subcomponent',
component => <<'EOF',
Here I am:
<& .sub &>
<%def .sub>
% my $f = $m->file('file_in_subcomp'); $f =~ s/\r\n?/\n/g;
<% $f %>
%def>
EOF
expect => <<'EOF',
Here I am:
Here I am:
<& .sub &>
<%def .sub>
% my $f = $m->file('file_in_subcomp'); $f =~ s/\r\n?/\n/g;
<% $f %>
%def>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'list_out',
description => 'tests that $m->print can handle a list of arguments',
component => <<'EOF',
Sending list of arguments:
<% 'blah','boom','bah' %>
<%perl>
$m->print(3,4,5);
my @lst = (7,8,9);
$m->print(@lst);
%perl>
EOF
expect => <<'EOF',
Sending list of arguments:
blahboombah
345789
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'req_obj',
description => 'tests various operations such as comp calls, $m->current_comp',
component => <<'EOF',
<%def .subcomp>
% if ($count < 5) {
<& $m->current_comp, count=>$count+1 &>
% } else {
<& /shared/display_req_obj &>
% }
<%args>
$count
%args>
%def>
<% '-' x 10 %>
One level request:
<& /shared/display_req_obj &>
<% '-' x 10 %>
Many level request:
<& .subcomp, count=>0 &>
<% '-' x 10 %>
EOF
expect => <<'EOF',
----------
One level request:
My depth is 2.
I am not a subrequest.
The top-level component is /request/req_obj.
My stack looks like:
-----
/shared/display_req_obj
/request/req_obj
-----
----------
Many level request:
My depth is 8.
I am not a subrequest.
The top-level component is /request/req_obj.
My stack looks like:
-----
/shared/display_req_obj
/request/req_obj:.subcomp
/request/req_obj:.subcomp
/request/req_obj:.subcomp
/request/req_obj:.subcomp
/request/req_obj:.subcomp
/request/req_obj:.subcomp
/request/req_obj
-----
----------
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'various',
call_args => {junk=>5},
description => 'tests caller, callers, fetch_comp, process_comp_path, comp_exists and scomp',
component => <<'EOF',
<& various_helper, junk=>$ARGS{junk}+1 &>
EOF
expect => <<'EOF',
Caller is /request/various_helper or /request/various_helper or /request/various_helper.
The top level component is /request/various or /request/various.
The full component stack is /request/support/various_test,/request/various_helper,/request/various.
My argument list is (junk,6).
The top argument list is (junk,5) or (junk,5).
Trying to fetch various_test (full path /request/support/various_test):
various_test exists with title /request/support/various_test.
Trying to fetch /request/sections/perl (full path /request/sections/perl):
/request/sections/perl exists with title /request/sections/perl.
Trying to fetch foobar (full path /request/support/foobar):
foobar does not exist.
Trying to fetch /shared (full path /shared):
/shared does not exist.
Output via the out function.
/request/file outputs 120+ characters.
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/autohandler_test2/autohandler',
component => <<'EOF',
This is the first autohandler
Remaining chain: <% join(',',map($_->title,$m->fetch_next_all)) %>
<& $m->fetch_next, level => 1 &>\
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/autohandler_test2/dir1/autohandler',
component => <<'EOF',
This is the second autohandler
Remaining chain: <% join(',',map($_->title,$m->fetch_next_all)) %>
% foreach (@_) {
<% $_ %>
% }
<& $m->fetch_next, level => 2 &>\
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'fetch_next',
path => '/autohandler_test2/dir1/fetch_next',
call_path => '/autohandler_test2/dir1/fetch_next',
description => 'Test $m->fetch_next and $m->fetch_next_all',
component => <<'EOF',
This is the main component (called by level <% $ARGS{level} %>)
Remaining chain: <% join(',',map($_->title,$m->fetch_next_all)) %>
% foreach (@_) {
<% $_ %>
% }
EOF
expect => <<'EOF',
This is the first autohandler
Remaining chain: /request/autohandler_test2/dir1/autohandler,/request/autohandler_test2/dir1/fetch_next
This is the second autohandler
Remaining chain: /request/autohandler_test2/dir1/fetch_next
level
1
This is the main component (called by level 2)
Remaining chain:
level
2
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'print',
description => 'Test print function from a component',
component => <<'EOF',
This is first.
% print "This is second.\n";
This is third.
EOF
expect => <<'EOF',
This is first.
This is second.
This is third.
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'printf',
description => 'Test printf function from a component',
component => <<'EOF',
This is first.
% printf '%s', "This is second.\n";
This is third.
EOF
expect => <<'EOF',
This is first.
This is second.
This is third.
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'autoflush_print',
description => 'Test print function from a component with autoflush on',
interp_params => { autoflush => 1 },
component => <<'EOF',
This is first.
% print "This is second.\n";
This is third.
EOF
expect => <<'EOF',
This is first.
This is second.
This is third.
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'autoflush_printf',
description => 'Test printf function from a component with autoflush on',
interp_params => { autoflush => 1 },
component => <<'EOF',
This is first.
% printf '%s', "This is second.\n";
This is third.
EOF
expect => <<'EOF',
This is first.
This is second.
This is third.
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'flush_print',
description => 'Test print function from a component in conjunction with $m->flush_buffer call',
component => <<'EOF',
This is first.
% print "This is second.\n";
% $m->flush_buffer;
This is third.
EOF
expect => <<'EOF',
This is first.
This is second.
This is third.
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'flush_print_autoflush',
description => 'Test print function from a component with autoflush on in conjunction with $m->flush_buffer call',
interp_params => { autoflush => 1 },
component => <<'EOF',
This is first.
% print "This is second.\n";
% $m->flush_buffer;
This is third.
EOF
expect => <<'EOF',
This is first.
This is second.
This is third.
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'flush_filter',
description => 'Test $m->flush_buffer in presence of filter',
component => <<'EOF',
one
% $m->flush_buffer;
% $m->clear_buffer;
two
<%filter>
$_ .= $_;
%filter>
EOF
expect => <<'EOF',
one
one
two
two
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'clear_buffer',
description => 'Test $m->clear_buffer in a normal component',
component => <<'EOF',
one
% $m->clear_buffer;
two
EOF
expect => <<'EOF',
two
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'clear_filter',
description => 'Test $m->clear_buffer in presence of filter',
component => <<'EOF',
one
% $m->clear_buffer;
two
<%filter>
$_ .= $_;
%filter>
EOF
expect => <<'EOF',
two
two
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'autoflush_disabled',
description => 'Using autoflush when disabled generates an error',
interp_params => { autoflush => 1, enable_autoflush => 0 },
component => <<'EOF',
Hi
EOF
expect_error => qr/Cannot use autoflush unless enable_autoflush is set/,
);
#------------------------------------------------------------
$group->add_test( name => 'instance',
description => 'Test HTML::Mason::Request->instance',
component => <<'EOF',
<% $m eq HTML::Mason::Request->instance ? 'yes' : 'no' %>
EOF
expect => <<'EOF',
yes
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'abort_and_filter',
description => 'Test that an abort in a filtered component still generates _some_ output, and that filter is run only once',
component => <<'EOF',
filter
% eval { $m->comp('support/abort_test') };
<%filter>
$_ = uc $_;
$_ =~ s/\s+$//;
$_ .= "\nfilter ran once";
%filter>
EOF
expect => <<'EOF',
FILTER
SOME MORE TEXT
filter ran once
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'abort_and_filter_2',
description => 'Test that $m->aborted can be checked in a filter section',
component => <<'EOF',
filter
% $m->abort;
<%filter>
unless ( $m->aborted )
{
$_ = uc $_;
$_ =~ s/\s+$//;
$_ .= "\nfilter ran once";
}
%filter>
EOF
expect => <<'EOF',
filter
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'abort_and_store',
description => 'Test that an abort in a store\'d component still generates _some_ output',
component => <<'EOF',
filter
% my $foo;
% eval { $m->comp( { store => \$foo }, 'support/abort_test') };
<% $foo %>
EOF
expect => <<'EOF',
filter
Some more text
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'clear_and_abort',
description => 'Test the clear_and_abort() method',
component => <<'EOF',
Some output
% $m->flush_buffer;
More output
% $m->clear_and_abort();
EOF
expect => <<'EOF',
Some output
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'reexec',
description => 'test that $m cannot be reexecuted',
component => <<'EOF',
<%init>
$m->exec;
%init>
EOF
expect_error => qr/Can only call exec\(\) once/,
);
#------------------------------------------------------------
$group->add_test( name => 'caller_in_subcomp',
description => 'tests $m->caller() in subcomponent',
component => <<'EOF',
<%def .foo>
<% $m->caller->name %>
%def>
<& .foo &>
EOF
expect => <<'EOF',
caller_in_subcomp
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'caller_at_top_level',
description => 'tests $m->caller() from top component',
component => <<'EOF',
caller is <% defined($m->caller) ? "defined" : "undefined" %>
callers(5) is <% defined($m->callers(5)) ? "defined" : "undefined" %>
caller_args(7) is <% defined($m->callers(7)) ? "defined" : "undefined" %>
EOF
expect => <<'EOF',
caller is undefined
callers(5) is undefined
caller_args(7) is undefined
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/support/longjump_test3',
component => <<'EOF',
Depth is <% $m->depth %>.
The full component stack is <% join(",",map($_->title,$m->callers)) %>.
EOF
);
$group->add_support( path => '/support/subdir/longjump_test2',
component => <<'EOF',
This is longjump_test2
% no warnings 'uninitialized'; next;
EOF
);
$group->add_support( path => '/support/longjump_test1',
component => <<'EOF',
<& longjump_test3 &>
% foreach my $i (0..2) {
<& subdir/longjump_test2 &>
% }
<& longjump_test3 &>
EOF
);
# It is possible to accidentally call 'next' from a component and
# jump out to the last loop or block in a previous component.
# While this cannot be supported behavior (since necessary cleanup
# and plugin code is skipped), we'd like to avoid a Mason request
# stack corruption at a minimum.
#
$group->add_test( name => 'longjump',
description => 'Accidentally calling next to exit a component does not corrupt stack',
component => <<'EOF',
<& support/longjump_test1 &>
EOF
expect => <<'EOF',
Depth is 3.
The full component stack is /request/support/longjump_test3,/request/support/longjump_test1,/request/longjump.
This is longjump_test2
This is longjump_test2
This is longjump_test2
Depth is 3.
The full component stack is /request/support/longjump_test3,/request/support/longjump_test1,/request/longjump.
EOF
# This just shuts the test code up
expect_warnings => qr/.*/,
);
#------------------------------------------------------------
$group->add_support( path => '/support/callers_out_of_bounds2',
component => <<'EOF',
hi
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/support/callers_out_of_bounds1',
component => <<'EOF',
<& callers_out_of_bounds2 &>
% foreach my $i (-4 .. 4) {
callers(<% $i %>) is <% defined($m->callers($i)) ? $m->callers($i)->title : 'not defined' %>
% }
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'callers_out_of_bounds',
description => 'tests $m->callers() for out of bounds indexes',
component => <<'EOF',
<& support/callers_out_of_bounds1 &>
EOF
expect => <<'EOF',
hi
callers(-4) is not defined
callers(-3) is not defined
callers(-2) is /request/support/callers_out_of_bounds1
callers(-1) is /request/callers_out_of_bounds
callers(0) is /request/support/callers_out_of_bounds1
callers(1) is /request/callers_out_of_bounds
callers(2) is not defined
callers(3) is not defined
callers(4) is not defined
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'call_self',
description => 'Test $m->call_self',
component => <<'EOF',
called
<%init>
my $out;
if ( $m->call_self( \$out, undef ) )
{
$m->print($out);
return;
}
%init>
EOF
expect => <<'EOF',
called
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'call_self_retval',
description => 'Test that we can get return value of component via $m->call_self',
component => <<'EOF',
called
<%init>
my @return;
if ( $m->call_self( undef, \@return ) )
{
$m->print( "0: $return[0]\n1: $return[1]\n" );
return;
}
return ( 'foo', 'bar' );
%init>
EOF
expect => <<'EOF',
0: foo
1: bar
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'call_self_output_and_retval',
description => 'Test that we can get return value and output of component via $m->call_self',
component => <<'EOF',
called
<%init>
my $out;
my @return;
if ( $m->call_self( \$out, \@return ) )
{
$m->print( "${out}0: $return[0]\n1: $return[1]\n" );
return;
}
%init>
<%cleanup>
return ( 'foo', 'bar' );
%cleanup>
EOF
expect => <<'EOF',
called
0: foo
1: bar
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'call_self_with_filter',
description => 'Test that $m->call_self works in presence of filter',
component => <<'EOF',
called
<%filter>
$_ = uc $_;
$_ .= ' filtered';
%filter>
<%init>
my $out;
if ( $m->call_self( \$out, undef ) )
{
$m->print($out);
return;
}
%init>
EOF
expect => <<'EOF',
CALLED
filtered
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'subcomp_from_shared',
description => 'Test calling a subcomponent inside shared block',
component => <<'EOF',
<%shared>
$m->comp('subcomp');
%shared>
<%def subcomp>
a subcomp
%def>
EOF
expect_error =>
qr/cannot call a method or subcomponent from a <%shared> block/,
);
#------------------------------------------------------------
$group->add_test( name => 'method_in_shared',
description => 'Test calling a method inside shared block',
component => <<'EOF',
<%shared>
$m->comp('SELF:meth');
%shared>
<%method meth>
a method
%method>
EOF
expect_error =>
qr/cannot call a method or subcomponent from a <%shared> block/,
);
#------------------------------------------------------------
$group->add_test( name => 'notes',
description => 'Test the notes() method',
component => <<'EOF',
% $m->notes('key', 'value');
k: <% $m->notes('key') %>
k2: <% $m->notes->{key} %>
EOF
expect =>
qr/k: value\s+k2: value/,
);
#------------------------------------------------------------
$group->add_test( name => 'flush_and_store',
description => q{Test that $m->flush_buffer is ignored in a store'd component},
interp_params => { autoflush => 1 },
component => <<'EOF',
<%def .world>\
World\
%def>
% my $world;
% $m->comp( { store => \$world }, '.world');
Hello, <% $world %>!
% $world = $m->scomp('.world');
Hello, <% $world %>!
EOF
expect => <<'EOF',
Hello, World!
Hello, World!
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'flush_and_scomp_recursive',
description => 'Test that $m->flush_buffer is ignored in a recursive scomp() call',
interp_params => { autoflush => 1 },
component => <<'EOF',
<%def .orld>\
orld\
%def>
<%def .world>\
W<& .orld &>\
%def>
% my $world = $m->scomp('.world');
Hello, <% $world %>!
EOF
expect => <<'EOF',
Hello, World!
EOF
);
#------------------------------------------------------------
return $group;
}
HTML-Mason-1.56/t/10b-cache-chi.t 0000644 0001750 0001750 00000037313 12431555444 015756 0 ustar autarch autarch use strict;
use warnings;
use HTML::Mason::Tests;
use HTML::Mason::Tools;
# Skip if flock not implemented.
eval { my $fh = do { local *FH; *FH; }; open $fh, $0; flock $fh,1; };
if ($@)
{
print "1..0 # Skipped: flock() is not available on this system\n";
exit;
}
# Skip if CHI not present.
eval "use CHI 0.21";
if ($@)
{
print "1..0 # Skipped: CHI 0.21+ is not installed\n";
exit;
}
my %chi_interp_params = (interp_params => { data_cache_api => 'chi' });
my $tests = make_tests();
$tests->run;
sub make_tests
{
my $group = HTML::Mason::Tests->tests_class->new( name => 'cache',
description => 'Test caching' );
#------------------------------------------------------------
$group->add_support( path => 'support/cache_test',
component => <<'EOF',
<% $result %>
This was<% $cached ? '' : ' not' %> cached.
<%init>
my $cached = 0;
my $result;
my $return;
unless ($result = $m->cache->get('fandango')) {
$result = "Hello Dolly.";
$return = $m->cache->set('fandango', $result) || '';
} else {
$cached = 1;
}
%init>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'cache',
description => 'basic caching functionality',
%chi_interp_params,
component => <<'EOF',
% for (my $i=0; $i<3; $i++) {
<& support/cache_test &>
% }
EOF
expect => <<'EOF',
Hello Dolly.
This was not cached.
Hello Dolly.
This was cached.
Hello Dolly.
This was cached.
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'keys',
description => q|test multiple keys and $m->cache->get_keys|,
%chi_interp_params,
component => <<'EOF',
<%init>
foreach my $key (qw(foo bar baz)) {
$m->cache->set($key, $key);
}
my @keys = sort $m->cache->get_keys;
$m->print("keys in cache: ".join(",",@keys)."\n");
foreach my $key (qw(foo bar baz)) {
my $value = $m->cache->get($key) || "undefined";
$m->print("value for $key is $value\n");
}
$m->cache->remove('foo');
$m->cache->remove('bar');
$m->print("expiring foo and bar...\n");
foreach my $key (qw(foo bar baz)) {
my $value = $m->cache->get($key) || "undefined";
$m->print("value for $key is $value\n");
}
%init>
EOF
expect => <<'EOF',
keys in cache: bar,baz,foo
value for foo is foo
value for bar is bar
value for baz is baz
expiring foo and bar...
value for foo is undefined
value for bar is undefined
value for baz is baz
EOF
);
#------------------------------------------------------------
$group->add_support ( path => 'support/cache_self',
component => <<'EOF',
x is <% $x %>
<%args>
$x
%args>
<%init>
return if $m->cache_self;
%init>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'cache_self',
description => 'test $m->cache_self',
%chi_interp_params,
component => <<'EOF',
<& support/cache_self, x => 1 &>
<& support/cache_self, x => 99 &>
EOF
expect => <<'EOF',
x is 1
x is 1
EOF
);
#------------------------------------------------------------
$group->add_support ( path => 'support/cache_self_expires_in',
component => <<'EOF',
x is <% $x %>
<%args>
$x
%args>
<%init>
return if $m->cache_self( expires_in => '3s' );
%init>
EOF
);
$group->add_test( name => 'cache_self_expires_in',
description => 'test that $m->cache_self respects expires_in parameter',
%chi_interp_params,
component => <<'EOF',
<& support/cache_self_expires_in, x => 1 &>
<& support/cache_self_expires_in, x => 2 &>
% sleep 5;
<& support/cache_self_expires_in, x => 99 &>
EOF
expect => <<'EOF',
x is 1
x is 1
x is 99
EOF
);
#------------------------------------------------------------
$group->add_support ( path => 'support/cache_self_expire_in',
component => <<'EOF',
x is <% $x %>
<%args>
$x
%args>
<%init>
return if $m->cache_self( expire_in => '1s' );
%init>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'cache_self_expire_in',
description => 'test that $m->cache_self respects expire_in parameter',
%chi_interp_params,
component => <<'EOF',
<& support/cache_self_expire_in, x => 1 &>
<& support/cache_self_expire_in, x => 2 &>
% sleep 5;
<& support/cache_self_expire_in, x => 99 &>
EOF
expect => <<'EOF',
x is 1
x is 1
x is 99
EOF
);
#------------------------------------------------------------
$group->add_support ( path => 'support/cache_self_expire_if',
component => <<'EOF',
x is <% $x %>
<%args>
$x
%args>
<%init>
return if $m->cache_self( expire_if => sub { $x == 3 } );
%init>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'cache_self_expire_if',
description => 'test that $m->cache_self respects expire_if parameter',
%chi_interp_params,
component => <<'EOF',
<& support/cache_self_expire_if, x => 1 &>
<& support/cache_self_expire_if, x => 2 &>
<& support/cache_self_expire_if, x => 3 &>
<& support/cache_self_expire_if, x => 4 &>
EOF
expect => <<'EOF',
x is 1
x is 1
x is 3
x is 3
EOF
);
#------------------------------------------------------------
$group->add_support ( path => 'support/cache_self_with_key',
component => <<'EOF',
x is <% $x %>
<%args>
$x
$key
%args>
<%init>
return if $m->cache_self( key => $key );
%init>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'cache_self_key',
description => 'test $m->cache_self with a key',
%chi_interp_params,
component => <<'EOF',
<& support/cache_self_with_key, x => 1, key => 1 &>
<& support/cache_self_with_key, x => 99, key => 99 &>
<& support/cache_self_with_key, x => 1000, key => 1 &>
EOF
expect => <<'EOF',
x is 1
x is 99
x is 1
EOF
);
#------------------------------------------------------------
$group->add_support ( path => 'support/cache_self_and_die',
component => <<'EOF',
<%init>
return if $m->cache_self;
die "argh!";
%init>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'cache_self_error',
description => 'test $m->cache_self with an error to make sure errors are propogated',
%chi_interp_params,
component => <<'EOF',
<& support/cache_self_and_die, x => 1, key => 1 &>
EOF
expect_error => qr/argh! at .*/,
);
#------------------------------------------------------------
$group->add_test( name => 'cache_self_scomp',
description => 'make sure that $m->cache_self cooperates with $m->scomp',
%chi_interp_params,
component => <<'EOF',
<% $m->scomp( 'support/cache_self', x => 1 ) %>
<% $m->scomp( 'support/cache_self', x => 99 ) %>
EOF
expect => <<'EOF',
x is 1
x is 1
EOF
);
#------------------------------------------------------------
$group->add_support ( path => 'support/cache_self_filtered',
component => <<'EOF',
x is <% $x %>
<%args>
$x
$key => 1
%args>
<%init>
return if $m->cache_self( key => $key );
%init>
<%filter>
$_ = uc $_;
$_ .= ' filtered';
%filter>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'cache_self_filtered',
description => 'test $m->cache_self with a filter block',
%chi_interp_params,
component => <<'EOF',
<& support/cache_self_filtered, x => 1 &>
<& support/cache_self_filtered, x => 99 &>
EOF
expect => <<'EOF',
X IS 1
filtered
X IS 1
filtered
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'cache_self_filtered_scomp',
description => 'test $m->cache_self with a filter block callled via $m->scomp',
%chi_interp_params,
component => <<'EOF',
<% $m->scomp( 'support/cache_self_filtered', key => 2, x => 1 ) %>
<% $m->scomp( 'support/cache_self_filtered', key => 2, x => 99 ) %>
EOF
expect => <<'EOF',
X IS 1
filtered
X IS 1
filtered
EOF
);
#------------------------------------------------------------
$group->add_support ( path => 'support/cache_self_filtered_2',
component => <<'EOF',
x is <% $x %>
<%args>
$x
%args>
<%init>
return if $m->cache_self;
%init>
<%filter>
s/(\d+)/$1+1/ge;
%filter>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'cache_self_filtered_2',
description => 'make sure that results are only filtered once',
%chi_interp_params,
component => <<'EOF',
<& support/cache_self_filtered_2, x => 1 &>
<& support/cache_self_filtered_2, x => 99 &>
EOF
expect => <<'EOF',
x is 2
x is 2
EOF
);
#------------------------------------------------------------
# Note: expire_if works differently with CHI than with previous Mason caching.
# CHI does not actually expire the value (which would entail an extra write),
# it just returns false from get(). This was different in earlier verisons of CHI,
# so we don't test for $value3 as we do in the comprable 10-cache.t test.
$group->add_test( name => 'expire_if',
description => 'test expire_if',
%chi_interp_params,
component => <<'EOF',
<% join(', ', $value1 || 'undef', $value2 || 'undef' ) %>
<%init>
my $time = time;
my $cache = $m->cache;
$cache->set('main', 'gardenia');
my $value1 = $cache->get('main', expire_if=>sub { $_[0]->get_created_at <= $time-1 });
my $value2 = $cache->get('main', expire_if=>sub { $_[0]->get_created_at >= $time });
%init>
EOF
expect => <<'EOF',
gardenia, undef
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'busy_lock',
description => 'test busy_lock',
%chi_interp_params,
component => <<'EOF',
<% join(', ', $value1 || 'undef', $value2 || 'undef') %>
<%init>
my $time = time;
my $cache = $m->cache;
$cache->set('main', 'gardenia', 0);
my $value1 = $cache->get('main', busy_lock=>'10 sec');
my $value2 = $cache->get('main');
%init>
EOF
expect => <<'EOF',
undef, gardenia
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'busy_lock_expiration',
description => 'test busy_lock expiration',
%chi_interp_params,
component => <<'EOF',
<% join(', ', $value1 || 'undef', $value2 || 'undef') %>
<%init>
my $time = time;
my $cache = $m->cache;
$cache->set('main', 'gardenia', 0);
my $value1 = $cache->get('main', busy_lock=>'1 sec');
sleep(1);
my $value2 = $cache->get('main');
%init>
EOF
expect => <<'EOF',
undef, undef
EOF
);
#------------------------------------------------------------
$group->add_support ( path => 'support/cache_self_die',
component => <<'EOF',
die
<%init>
return if $m->cache_self;
die 'foo';
%init>
EOF
);
$group->add_test( name => 'cache_self_death',
description => 'test $m->cache_self and death',
%chi_interp_params,
component => <<'EOF',
<%init>
$m->comp( 'support/cache_self_die' );
%init>
EOF
expect_error => qr/foo at/,
);
#------------------------------------------------------------
$group->add_support ( path => 'support/cache_self_abort2',
component => <<'EOF',
going to abort, a = <% $ARGS{a} %>
% $m->abort();
EOF
);
$group->add_support( path => 'support/cache_self_abort',
component => <<'EOF',
<%init>
return if $m->cache_self;
$m->comp( 'cache_self_abort2', a=>5 );
%init>
EOF
);
$group->add_test( name => 'cache_self_abort',
description => 'test $m->cache_self and abort',
%chi_interp_params,
component => <<'EOF',
<%init>
eval { $m->comp( 'support/cache_self_abort', a=>5 ) };
eval { $m->comp( 'support/cache_self_abort', a=>10 ) };
%init>
EOF
expect => <<'EOF'
going to abort, a = 5
going to abort, a = 5
EOF
);
#------------------------------------------------------------
$group->add_support( path => 'support/cache_self_with_subexec2',
component => <<'EOF',
This is the subrequest, a = <% $ARGS{a} %>
EOF
);
$group->add_support( path => 'support/cache_self_with_subexec',
component => <<'EOF',
% return if $m->cache_self;
% $m->subexec('cache_self_with_subexec2', a=>$ARGS{a});
EOF
);
$group->add_test( name => 'cache_self_with_subexec',
description => 'test $m->subexec in presence of $m->cache_self',
%chi_interp_params,
component => <<'EOF',
<& support/cache_self_with_subexec, a=>5 &>
<& support/cache_self_with_subexec, a=>10 &>
EOF
expect => <<'EOF',
This is the subrequest, a = 5
This is the subrequest, a = 5
EOF
);
#------------------------------------------------------------
$group->add_support( path => 'declined/dhandler',
component => <<'EOF',
decline was called
EOF
);
$group->add_test( name => 'declined/cache_self_decline',
description => 'test $m->decline in presence of $m->cache_self',
%chi_interp_params,
component => <<'EOF',
% return if $m->cache_self;
% $m->decline;
EOF
expect => <<'EOF',
decline was called
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'data_cache_defaults',
description => 'modifying data_cache_defaults',
interp_params => { data_cache_api => 'chi', data_cache_defaults => { driver => 'Memory', global => 1 } },
component => <<'EOF',
Using driver '<% $m->cache->short_driver_name %>'
% for (my $i=0; $i<3; $i++) {
<& support/cache_test &>
% }
EOF
expect => <<'EOF',
Using driver 'Memory'
Hello Dolly.
This was not cached.
Hello Dolly.
This was cached.
Hello Dolly.
This was cached.
EOF
);
#------------------------------------------------------------
return $group;
}
HTML-Mason-1.56/t/14-cgi.t 0000644 0001750 0001750 00000010502 12431555444 014545 0 ustar autarch autarch use strict;
use warnings;
use HTML::Mason::CGIHandler;
use CGI qw(-no_debug); # Prevent "(offline mode: enter name=value pairs on standard input)"
{
# This class simulates CGI requests. It's rather ugly, it tries
# to fool HTML::Mason::Tests into thinking that CGIHandler is a subclass of Interp.
package CGITest;
use HTML::Mason::Tests;
use base 'HTML::Mason::Tests';
sub _run_test
{
my $self = shift;
my $test = $self->{current_test};
$self->{buffer} = '';
my %interp_params = ( exists $test->{interp_params} ?
%{ $test->{interp_params} } :
() );
my $interp = HTML::Mason::CGIHandler->new
(comp_root => $self->comp_root,
data_dir => $self->data_dir,
%interp_params,
);
eval { local $CGI::LIST_CONTEXT_WARN = 0; $self->_execute($interp) };
return $self->check_result($@);
}
sub _execute
{
my ($self, $interp) = @_; # $interp is a CGIHandler object
my $test = $self->{current_test};
#print "Calling $test->{name} test with path: $test->{call_path}\n" if $DEBUG;
$test->{pretest_code}->() if $test->{pretest_code};
CGI::initialize_globals(); # make sure CGI doesn't cache previous query
$ENV{REQUEST_METHOD} = 'GET'; # CGI.pm needs this, or it won't process args
$ENV{PATH_INFO} = $test->{call_path};
$ENV{QUERY_STRING} = join '=', @{$test->{call_args}};
$interp->handle_request($self->{buffer});
}
}
$ENV{DOCUMENT_ROOT} = CGITest->comp_root;
my $group = CGITest->new( name => 'cgi',
description => 'HTML::Mason::CGIHandler class',
interp_class => 'HTML::Mason::CGIHandler',
);
#------------------------------------------------------------
my $basic_header = "Content-Type: text/html";
$basic_header .= '; charset=ISO-8859-1' if CGI->can('charset');
$basic_header .= "${CGI::CRLF}${CGI::CRLF}";
$group->add_test( name => 'basic',
description => 'Test basic CGIHandler operation',
component => 'some text',
expect => "${basic_header}some text",
);
#------------------------------------------------------------
$group->add_test( name => 'dynamic',
description => 'Test CGIHandler operation with dynamic components',
component => 'some <% "dynamic" %> text',
expect => "${basic_header}some dynamic text",
);
#------------------------------------------------------------
$group->add_test( name => 'args',
description => 'Test CGIHandler operation with arguments',
call_args => [arg => 'dynamic'],
component => 'some <% $ARGS{arg} %> text',
expect => "${basic_header}some dynamic text",
);
#------------------------------------------------------------
$group->add_test( name => 'cgi_object',
description => 'Test access to the CGI request object',
call_args => [arg => 'boohoo'],
component => q{some <% $m->cgi_object->param('arg') %> cryin'},
expect => "${basic_header}some boohoo cryin'",
);
#------------------------------------------------------------
$group->add_test( name => 'fatal_error',
description => 'Test fatal error_mode',
interp_params => { error_mode => 'fatal', error_format => 'text' },
component => q{% die 'dead';},
expect_error => qr/dead at .+/,
);
$group->add_test( name => 'headers',
description => 'Test header generation',
component => q{% $r->header_out('foo' => 'bar');},
expect => qr/Foo: bar/i,
);
$group->add_test( name => 'redirect_headers',
description => 'Test header generation',
component => q{% $m->redirect('/hello.html');},
expect => qr/Status: 302\s+Location: \/hello\.html|Location: \/hello\.html\s+Status: 302/i,
);
#------------------------------------------------------------
$group->run;
HTML-Mason-1.56/eg/ 0000775 0001750 0001750 00000000000 12431555444 013530 5 ustar autarch autarch HTML-Mason-1.56/eg/MyApp/ 0000775 0001750 0001750 00000000000 12431555444 014556 5 ustar autarch autarch HTML-Mason-1.56/eg/MyApp/MasonWithSession.pm 0000644 0001750 0001750 00000002027 12431555444 020370 0 ustar autarch autarch package MyApp::MasonPlusSession;
use strict;
use warnings;
use HTML::Mason::ApacheHandler;
# This does not come with the Mason core code. It must be installed
# from CPAN separately.
use MasonX::Request::PlusApacheSession;
my $ah =
new HTML::Mason::ApacheHandler
( request_class => 'MasonX::Request::PlusApacheSession',
session_class => 'Apache::Session::File',
# Let MasonX::Request::PlusApacheSession automatically
# set and read cookies containing the session id
session_use_cookie => 1,
session_directory => '/tmp/sessions',
session_lock_directory => '/tmp/session-locks',
comp_root => '
The $r->method method will return the request method. It will be a
string such as ``GET'', ``HEAD'' or ``POST''. Passing an argument will
set the method, mainly used for internal redirects.
$r->method_number( [$num] )
The $r->method_number method will return the request method
number. The method numbers are defined by the M_GET,
M_POST,... constants available from the Apache::Constants
module. Passing an argument will set the method_number, mainly used
for internal redirects and testing authorization restriction masks.
$r->bytes_sent
The number of bytes sent to the client, handy for logging, etc.
$r->the_request
The request line send by the client, handy for logging, etc.
$r->proxyreq
Returns true if the request is proxy http. Mainly used during the
filename translation stage of the request, which may be handled by a
PerlTransHandler.
$r->header_only
Returns true if the client is asking for headers only, e.g. if the
request method was HEAD.
$r->protocol
The $r->protocol method will return a string identifying the protocol
that the client speaks. Typical values will be ``HTTP/1.0'' or
``HTTP/1.1''.
$r->uri( [$uri] )
The $r->uri method will return the requested URI, optionally changing
it with the first argument.
$r->filename( [$filename] )
The $r->filename method will return the result of the URI --> filename
translation, optionally changing it with the first argument if you
happen to be doing the translation.
$r->path_info( [$path_info] )
The $r->path_info method will return what is left in the path after
the URI --> filename translation, optionally changing it with the
first argument if you happen to be doing the translation.
$r->args
The $r->args method will return the contents of the URI query
string. When called in a scalar context, the entire string is
returned. When called in a list context, a list of parsed key => value
pairs are returned, i.e. it can be used like this:
$query = $r->args;
%in = $r->args;
<%doc>
$r->headers_in
The $r->headers_in method will return a %hash of client request headers. This can be used to initialize
a perl hash, or one could use the $r->header_in() method (described below) to retrieve a specific
header value directly.
%doc>
$r->header_in( $header_name, [$value] )
Return the value of a client header. Can be used like this:
$ct = $r->header_in("Content-type");
$r->header_in($key, $val); #set the value of header '$key'
$r->content
The $r->content method will return the entity body read from the
client, but only if the request content type is
application/x-www-form-urlencoded. When called in a scalar context,
the entire string is returned. When called in a list context, a list
of parsed key => value pairs are returned. *NOTE*: you can only ask
for this once, as the entire body is read from the client.
$r->read_client_block($buf, $bytes_to_read)
Read from the entity body sent by the client. Example of use:
$r->read_client_block($buf, $r->header_in('Content-length'));
$r->get_remote_host= <% $r->get_remote_host %>
Lookup the client's DNS hostname. If the configuration directive
HostNameLookups is set to off, this returns the dotted decimal
representation of the client's IP address instead. Might return undef
if the hostname is not known.
$r->get_remote_logname = NOT IMPLEMENTED BY MOD_PERL
Lookup the remote user's system name. Might return undef if the remote
system is not running an RFC 1413 server or if the configuration
directive IdentityCheck is not turned on.
More information about the client can be obtained from the
Apache::Connection object, as described below.
The $r->connection method will return a reference to the request
connection object (blessed into the Apache::Connection package). This
is really a conn_rec* in disguise. The following methods can be used
on the connection object:
$c->remote_host
If the configuration directive HostNameLookups is set to on: then the
first time $r->get_remote_host is called the server does a DNS lookup
to get the remote client's host name. The result is cached in
$c->remote_host then returned. If the server was unable to resolve the
remote client's host name this will be set to ``''. Subsequent calls
to $r->get_remote_host return this cached value.
$c->remote_ip
The dotted decimal representation of the remote client's IP
address. This is set by then server when the connection record is
created so is always defined.
$c->local_addr
A packed SOCKADDR_IN in the same format as returned by Socket,
containing the port and address on the local host that the remote
client is connected to. This is set by the server when the connection
record is created so it is always defined.
$c->remote_addr
A packed SOCKADDR_IN in the same format as returned by Socket,
containing the port and address on the remote host that the server is
connected to. This is set by the server when the connection record is
created so it is always defined.
$c->remote_logname
use Net::Ident qw (lookupFromInAddr);
...
my $remoteuser = lookupFromInAddr ($c->local_addr,
$c->remote_addr, 2);
Note that the lookupFromInAddr interface does not currently exist in
the Net::Ident module, but the author is planning on adding it soon.
If the configuration directive IdentityCheck is set to on: then the
first time $r->get_remote_logname is called the server does an RFC
1413 (ident) lookup to get the remote users system name. Generally for
UNI* systems this is their login. The result is cached in
$c->remote_logname then returned. Subsequent calls to
$r->get_remote_host return the cached value.
$c->user
If an authentication check was successful, the authentication handler
caches the user name here.
$c->auth_type
Returns the authentication scheme that successfully authenticate
$c->user, if any.
$c->aborted
Returns true if the client stopped talking to us.
SERVER CONFIGURATION INFORMATION
The following methods are used to obtain information from server
configuration and access control files.
$r->dir_config( $key )
Returns the value of a per-directory variable specified by the
PerlSetVar directive.
#
$r->requires
Returns an array reference of hash references, containing information
related to the require directive. This is normally used for access
control, see Apache for an example.
$r->auth_type
Returns a reference to the current value of the per directory
configuration directive AuthType. Normally this would be set to Basic
to use the basic authentication scheme defined in RFC 1945, Hypertext
Transfer Protocol -- HTTP/1.0. However, you could set to something
else and implement your own authentication scheme.
$r->auth_name
Returns a reference to the current value of the per directory
configuration directive AuthName. The AuthName directive creates
protection realm within the server document space. To quote RFC 1945
``These realms allow the protected resources on a server to be
partitioned into a set of protection spaces, each with its own
authentication scheme and/or authorization database.'' The client uses
the root URL of the server to determine which authentication
credentials to send with each HTTP request. These credentials are
tagged with the name of the authentication realm that created
them. Then during the authentication stage the server uses the current
authentication realm, from $r->auth_name, to determine which set of
credentials to authenticate.
$r->document_root
Returns a reference to the current value of the per server
configuration directive DocumentRoot. To quote the Apache server
documentation, ``Unless matched by a directive like Alias, the server
appends the path from the requested URL to the document root to make
the path to the document.'' This same value is passed to CGI scripts
in the DOCUMENT_ROOT environment variable.
$r->allow_options
The $r->allow_options method can be used for checking if it is OK to
run a perl script. The Apache::Options module provides the constants
to check against.
if(!($r->allow_options & OPT_EXECCGI)) {
$r->log_reason("Options ExecCGI is off in this directory",
$filename);
}
$s = $r->server
Return a reference to the server info object (blessed into the
Apache::Server package). This is really a server_rec* in disguise. The
following methods can be used on the server object:
$s = Apache->server
Same as above, but only available during server startup for use in
$s->server_admin
Returns the mail address of the person responsible for this server.
$s->server_hostname
Returns the hostname used by this server.
$s->port
Returns the port that this servers listens too.
$s->is_virtual
Returns true if this is a virtual server.
$s->names
Returns the wild-carded names for HostAlias servers.
$s->warn
Alias for Apache::warn.
$s->log_error
Alias for Apache::log_error.
HTML-Mason-1.56/samples/show-env 0000644 0001750 0001750 00000000174 12431555444 016272 0 ustar autarch autarch Current Environment
% foreach my $key (sort(keys(%ENV))) {
HTML-Mason-1.56/t/ 0000775 0001750 0001750 00000000000 12431555444 013400 5 ustar autarch autarch HTML-Mason-1.56/t/01a-comp-calls.t 0000644 0001750 0001750 00000022266 12431555444 016204 0 ustar autarch autarch use strict;
use warnings;
use File::Basename;
use HTML::Mason::Tests;
my $outside_comp_root_test_file;
my $tests = make_tests();
$tests->run;
sub make_tests
{
my $group = HTML::Mason::Tests->tests_class->new( name => 'comp-calls',
description => 'Component call syntax' );
$outside_comp_root_test_file = dirname($group->comp_root) . "/.outside_comp";
#------------------------------------------------------------
$group->add_support( path => '/support/amper_test',
component => <<'EOF',
amper_test.
% }
% }
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'ampersand',
description => 'tests all variations of component call path syntax',
component => <<'EOF',
<&support/amper_test&>
<& support/amper_test &>
<& support/amper_test, &>
<& support/amper_test
&>
<&
support/amper_test &>
<&
support/amper_test
&>
EOF
expect => <<'EOF',
amper_test.
amper_test.
to: Joe
amper_test.
b: 32
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/support/funny_-+=@~~~._name',
component => <<'EOF',
foo is <% $ARGS{foo} %>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'ampersand_with_funny_name',
description => 'component with non-alphabetic characters',
component => <<'EOF',
<& support/funny_-+=@~~~._name, foo => 5 &>
EOF
expect => <<'EOF',
foo is 5
EOF
);
#------------------------------------------------------------
# This only tests for paths passed through Request::fetch_comp,
# not Interp::load. Not sure how zealously we want to
# canonicalize.
#
$group->add_test( name => 'canonicalize_paths',
description => 'test that various paths are canonicalized to the same component',
component => <<'EOF',
<%perl>
my $path1 = '///comp-calls/support//amper_test';
my $comp1 = $m->fetch_comp($path1)
or die "could not fetch comp1";
my $path2 = './support/./././amper_test';
my $comp2 = $m->fetch_comp($path2)
or die "could not fetch comp2";
my $path3 = './support/../support/../support/././amper_test';
my $comp3 = $m->fetch_comp($path3)
or die "could not fetch comp3";
unless ($comp1 == $comp2 && $comp2 == $comp3) {
die sprintf
(
"different component objects for same canonical path:\n %s (%s -> %s)\n %s (%s -> %s)\n %s (%s -> %s)",
$comp1, $path1, $comp1->path,
$comp2, $path2, $comp2->path,
$comp3, $path3, $comp3->path,
);
}
$m->comp($comp1);
$m->comp($comp2);
$m->comp($comp3);
%perl>
EOF
expect => <<'EOF',
amper_test.The Site
<%args>
$bgcolor=>'white'
%args>
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/autohandler_test/footer',
component => <<'EOF',
Copyright 1999 Schmoopie Inc.
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'autohandler',
path => '/autohandler_test/hello',
call_path => '/autohandler_test/hello',
description => 'autohandler test',
component => <<'EOF',
Hello World!
The answer is <% $b %>.
<%args>
$b
%args>
EOF
expect => <<'EOF',
The Site
Autohandler comp: /misc/autohandler_test/hello
Hello World!
The answer is 10.
Copyright 1999 Schmoopie Inc.
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/dhandler_test/dhandler',
component => <<'EOF',
dhandler = <% $m->current_comp->title %>
dhandler arg = <% $m->dhandler_arg %>
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/dhandler_test/subdir/dhandler',
component => <<'EOF',
% $m->decline if $m->dhandler_arg eq 'leaf3';
% $m->decline if $m->dhandler_arg eq 'slashes';
% $m->decline if $m->dhandler_arg eq 'buffers';
dhandler = <% $m->current_comp->title %>
dhandler arg = <% $m->dhandler_arg %>
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/dhandler_test/subdir/autohandler',
component => <<'EOF',
Header
<% $m->call_next %>
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/dhandler_test/bar/dhandler',
component => <<'EOF',
dhandler = <% $m->current_comp->title %>
dhandler arg = <% $m->dhandler_arg %>
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/dhandler_test/buff/dhandler',
component => <<'EOF',
Buffer stack size: <% scalar $m->buffer_stack %>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'dhandler1',
description => 'tests dhandler against nonexistent comp',
call_path => '/dhandler_test/foo/bar',
skip_component => 1,
expect => <<'EOF',
dhandler = /misc/dhandler_test/dhandler
dhandler arg = foo/bar
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'dhandler2',
description => 'real comp to make sure the real comp is invoked, not the dhandler',
path => '/dhandler_test/subdir/leaf',
call_path => '/dhandler_test/subdir/leaf',
component => <<'EOF',
I'm leaf
EOF
expect => <<'EOF',
Header
I'm leaf
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'dhandler3',
description => 'real comp declines the request to make sure the dhandler is invoked',
path => '/dhandler_test/subdir/leaf2',
call_path => '/dhandler_test/subdir/leaf2',
component => <<'EOF',
% $m->decline;
I'm leaf2
EOF
expect => <<'EOF',
Header
dhandler = /misc/dhandler_test/subdir/dhandler
dhandler arg = leaf2
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'dhandler4',
description => 'declines twice to make sure higher level dhandler is called',
path => '/dhandler_test/subdir/leaf3',
call_path => '/dhandler_test/subdir/leaf3',
component => <<'EOF',
% $m->decline;
I'm leaf3
EOF
expect => <<'EOF',
dhandler = /misc/dhandler_test/dhandler
dhandler arg = subdir/leaf3
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'dhandler5',
description => 'decline with doubled slash (//) in URL path',
path => '/dhandler_test/subdir/slashes',
call_path => '//dhandler_test//subdir//slashes',
component => <<'EOF',
% $m->decline;
I have many slashes!
EOF
expect => <<'EOF',
dhandler = /misc/dhandler_test/dhandler
dhandler arg = subdir/slashes
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'dhandler6',
description => 'test that a dhandler more than one directory up is found',
call_path => '/dhandler_test/bar/baz/quux/not_here',
skip_component => 1,
expect => <<'EOF',
dhandler = /misc/dhandler_test/bar/dhandler
dhandler arg = baz/quux/not_here
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'accessor_validate',
description => 'test accessor parameter validation',
component => <<'EOF',
% $m->interp->ignore_warnings_expr([1]);
EOF
expect_error => qr/Parameter #1.*to .*? was an 'arrayref'/,
);
#------------------------------------------------------------
$group->add_test( name => 'contained_accessor_validate',
description => 'test contained accessor parameter validation',
component => <<'EOF',
% $m->interp->autoflush([1]);
EOF
expect_error => qr/Parameter #1.*to .*? was an 'arrayref'/,
);
#------------------------------------------------------------
# define /dhandler that sometimes declines. test framework should provide a
# more supported way to define a top-level component!
my $updir = File::Spec->updir;
$group->add_support( path => "$updir/dhandler",
component => <<'EOF',
% if ($m->request_args->{decline_from_top}) {
% $m->decline;
% } else {
top-level dhandler: path = <% $m->current_comp->path %>
% }
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/dhandler',
component => <<'EOF',
% $m->decline;
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'top_level_dhandler_handles',
description => 'make sure dhandler at /dhandler is called correctly after decline from lower-level dhandler',
path => '/notused',
call_path => '/nonexistent',
component => <<'EOF',
not ever used
EOF
expect => <<'EOF',
top-level dhandler: path = /dhandler
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'top_level_dhandler_declines',
description => 'make sure /dhandler decline results in not-found error',
path => '/notused2',
call_path => '/nonexistent',
call_args => { decline_from_top => 1 },
component => <<'EOF',
not ever used
EOF
expect_error => qr/could not find component for initial path/,
);
#------------------------------------------------------------
return $group;
}
HTML-Mason-1.56/t/18-leak.t 0000644 0001750 0001750 00000017457 12431555444 014743 0 ustar autarch autarch use strict;
use warnings;
use HTML::Mason::Tests;
use HTML::Mason::Tools qw(can_weaken);
BEGIN
{
unless ( can_weaken )
{
print "Your installation does not include Scalar::Util::weaken\n";
print "1..0\n";
exit;
}
}
my $tests = make_tests();
$tests->run;
{
package InterpWatcher;
my $_destroy_count = 0;
use base qw(HTML::Mason::Interp);
sub DESTROY { $_destroy_count++ }
sub _destroy_count { $_destroy_count }
sub _clear_destroy_count { $_destroy_count = 0 }
}
{
package RequestWatcher;
my $_destroy_count = 0;
use base qw(HTML::Mason::Request);
sub DESTROY { $_destroy_count++ }
sub _destroy_count { $_destroy_count }
sub _clear_destroy_count { $_destroy_count = 0 }
}
{
# Unfortunately cannot override component class, even by setting
# comp_class, because it is hardcoded in
# Resolver/FileBased.pm. This works as long as Component.pm
# doesn't have any of these methods.
#
package HTML::Mason::Component;
my $_destroy_count = 0;
sub DESTROY { $_destroy_count++ }
sub _destroy_count { $_destroy_count }
sub _clear_destroy_count { $_destroy_count = 0 }
}
{
package SubcomponentWatcher;
my $_destroy_count = 0;
use base qw(HTML::Mason::Component::Subcomponent);
sub DESTROY { $_destroy_count++ }
sub _destroy_count { $_destroy_count }
sub _clear_destroy_count { $_destroy_count = 0 }
}
sub make_tests
{
my $group = HTML::Mason::Tests->tests_class->new( name => '18-leak.t',
description => 'Tests that various memory leaks are no longer with us' );
$group->add_test( name => 'interp_destroy',
description => 'Test that interps with components in cache still get destroyed',
component => <<'EOF',
<%perl>
{
my $interp = InterpWatcher->new();
my $comp = $interp->make_component( comp_source => 'foo' );
}
$m->print("destroy_count = " . InterpWatcher->_destroy_count . "\n");
{
my $interp = InterpWatcher->new();
my $comp = $interp->make_component( comp_source => 'foo' );
}
$m->print("destroy_count = " . InterpWatcher->_destroy_count . "\n");
%perl>
EOF
expect => <<'EOF',
destroy_count = 1
destroy_count = 2
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/support/no_error_comp',
component => <<'EOF',
No error here.
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/support/compile_error_comp',
component => <<'EOF',
<%
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/support/runtime_error_comp',
component => <<'EOF',
% die "bleah";
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/support/recursive_caller_1',
component => <<'EOF',
<%perl>
$m->comp("recursive_caller_2", %ARGS);
return;
%perl>
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/support/recursive_caller_2',
component => <<'EOF',
<%perl>
my $anon_comp = $ARGS{anon_comp};
$m->comp($anon_comp, %ARGS) if $m->depth < 16;
return;
%perl>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'request_destroy',
description => 'Test that requests get destroyed after top-level component error',
interp_params => { request_class => 'RequestWatcher' },
component => <<'EOF',
<%perl>
eval { $m->subexec('support/no_error_comp') };
$m->print("destroy_count = " . RequestWatcher->_destroy_count . "\n");
eval { $m->subexec('support/compile_error_comp') };
$m->print("destroy_count = " . RequestWatcher->_destroy_count . "\n");
eval { $m->subexec('support/not_found_comp') };
$m->print("destroy_count = " . RequestWatcher->_destroy_count . "\n");
%perl>
EOF
expect => <<'EOF',
No error here.
destroy_count = 1
destroy_count = 2
destroy_count = 3
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/support/def_and_method',
component => <<'EOF',
<%init>
$m->comp('.def');
$m->comp('SELF:method');
return;
%init>
<%def .def>
This is a def
%def>
<%method method>
This is a method
%method>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'component_destroy',
description => 'Test that components get freed when cleared from the main cache',
interp_params => { code_cache_max_size => 0 },
component => <<'EOF',
<%perl>
HTML::Mason::Component->_clear_destroy_count;
$m->subexec('support/no_error_comp');
$m->print("destroy_count = " . HTML::Mason::Component->_destroy_count . "\n");
$m->subexec('support/no_error_comp');
$m->print("destroy_count = " . HTML::Mason::Component->_destroy_count . "\n");
eval { $m->subexec('support/runtime_error_comp') };
$m->print("destroy_count = " . HTML::Mason::Component->_destroy_count . "\n");
eval { $m->subexec('support/runtime_error_comp') };
$m->print("destroy_count = " . HTML::Mason::Component->_destroy_count . "\n");
%perl>
EOF
expect => <<'EOF',
No error here.
destroy_count = 1
No error here.
destroy_count = 2
destroy_count = 3
destroy_count = 4
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'component_destroy_static_source',
description => 'Test that components get freed in static source mode',
interp_params => { static_source => 1 },
component => <<'EOF',
<%perl>
HTML::Mason::Component->_clear_destroy_count;
my $anon_comp_text = q|
<%init>
$m->comp("/18-leak.t/support/recursive_caller_1", %ARGS);
return;
%init>
|;
my $anon_comp = $m->interp->make_component( comp_source => $anon_comp_text );
$m->subexec('support/recursive_caller_1', anon_comp=>$anon_comp);
$m->interp->flush_code_cache;
$m->print("destroy_count = " . HTML::Mason::Component->_destroy_count . "\n");
$m->subexec('support/recursive_caller_1', anon_comp=>$anon_comp);
$m->interp->flush_code_cache;
$m->print("destroy_count = " . HTML::Mason::Component->_destroy_count . "\n");
%perl>
EOF
expect => <<'EOF',
destroy_count = 2
destroy_count = 4
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'subcomponent_destroy',
description => 'Test that defs and methods don\'t cause components to leak',
interp_params => { subcomp_class => 'SubcomponentWatcher',
code_cache_max_size => 0 },
component => <<'EOF',
<%perl>
HTML::Mason::Component->_clear_destroy_count;
$m->subexec('support/def_and_method');
$m->print("destroy_count = " . HTML::Mason::Component->_destroy_count . ", " . SubcomponentWatcher->_destroy_count . "\n");
$m->subexec('support/def_and_method');
$m->print("destroy_count = " . HTML::Mason::Component->_destroy_count . ", " . SubcomponentWatcher->_destroy_count . "\n");
%perl>
EOF
expect => <<'EOF',
This is a def
This is a method
destroy_count = 1, 2
This is a def
This is a method
destroy_count = 2, 4
EOF
);
#------------------------------------------------------------
return $group;
}
HTML-Mason-1.56/t/06a-compiler_obj.t 0000644 0001750 0001750 00000001215 12431555444 016612 0 ustar autarch autarch use strict;
use warnings;
use HTML::Mason;
use Test;
plan tests => 4;
ok 1; # Loaded
# We use the Interp class as a front-end to the compiler, but we're
# really testing the compiler here. We could change this to eliminate
# the Interp stuff, probably.
my $interp = HTML::Mason::Interp->new;
ok $interp;
# Make sure the compiler can recover properly after a syntax error
eval {$interp->make_component( comp_source => <<'EOF' )};
<&| syntax_error, in => "this" &>
component
&|>
EOF
ok $@, qr{ending tag};
eval {$interp->make_component( comp_source => <<'EOF' )};
<&| syntax_error, in => "this" &>
component
&>
EOF
ok $@, '';
HTML-Mason-1.56/t/02-sections.t 0000644 0001750 0001750 00000027123 12431555444 015636 0 ustar autarch autarch use strict;
use warnings;
use HTML::Mason::Tests;
my $tests = make_tests();
$tests->run;
sub make_tests
{
my $group = HTML::Mason::Tests->tests_class->new( name => 'sections',
description => 'Tests various <%foo>%foo> sections' );
#------------------------------------------------------------
$group->add_support( path => '/support/args_test',
component => <<'EOF',
<% $message %>\
<%args>
$message
%args>
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/support/perl_args_test',
component => <<'EOF',
a: <% $a %>
b: <% join(",",@b) %>
c: <% join(",",map("$_=$c{$_}",sort(keys(%c)))) %>
d: <% $d %>
e: <% join(",",@e) %>
f: <% join(",",map("$_=$f{$_}",sort(keys(%f)))) %>
<%args>
$a
@b # a comment
%c
$d=>5 # another comment
@e=>('foo','baz')
%f=>(joe=>1,bob=>2)
%args>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'args',
description => 'tests <%args> block',
component => <<'EOF',
My name is <% $comp->name %>. Full name <% $comp->title %>.
I was created by <% $comp->owner->path %>.
<& .link, site=>'masonhq', label=>'Mason' &>
%def>
<& intro &>
<& .link, site=>'apache', label=>'Apache Foundation' &>
<& .link, site=>'yahoo' &>
<& .link, site=>'excite' &>
<%def .link>
--> <% $label %>
<%args>
$site
$label=>ucfirst($site)
%args>
%def>
EOF
expect => <<'EOF',
Hello!
My name is intro. Full name /sections/def:intro.
I was created by /sections/def.
--> Mason
--> Apache Foundation
--> Yahoo
--> Excite
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'doc',
description => 'tests <%doc> section',
component => <<'EOF',
<&| repeat , var => \$a, list => [1,2,3,4,5] &>
EOF
expect => <<'EOF',
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'filter',
path => 'filter_test/test2',
call_path => 'filter_test/test2',
description => 'Tests a filter changes the contents',
component => <<'EOF',
<&| filter &>1&>
<&| filter &>2&>
<&| filter &>hi&>
end
EOF
expect => <<'EOF',
one
two
content returned 'hi'
end
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'nested',
path => 'filter_test/test3',
call_path => 'filter_test/test3',
description => 'Tests nested filters',
component => <<'EOF',
% my $i;
<&| repeat , var => \$i , list => [5,4,3,2,1] &>
<&| filter &> <% $i %> &>