% if (%ARGS) { Arguments:
% foreach my $key (sort keys %ARGS) {
<% $key %>: <% $ARGS{$key} %>
% }
% }
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.
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!
amper_test.
Arguments:
message: Hello World!
to: Joe
amper_test.
amper_test.
Arguments:
a: 17
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);
EOF
expect => <<'EOF',
amper_test.
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 <& 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> 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 ); <%def .foo> % 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.52/t/PaxHeader/02-sections.t 000644 777777 777777 00000000212 12225201111 017767 x ustar 00jonswart 000000 000000 18 gid=1896053708 17 uid=512269995 20 ctime=1381302857 20 atime=1381302857 23 SCHILY.dev=16777220 22 SCHILY.ino=6246769 18 SCHILY.nlink=1 HTML-Mason-1.52/t/02-sections.t 000644 « q{Μ00000027123 12225201111 016756 0 ustar 00jonswart 000000 000000 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> sections' ); #------------------------------------------------------------ $group->add_support( path => '/support/args_test', component => <<'EOF', <% $message %>\ <%args> $message 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) EOF ); #------------------------------------------------------------ $group->add_test( name => 'args', description => 'tests <%args> block', 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."; 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."; 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."; 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."; 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';
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';
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
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';
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
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 ',
call_args => [qw(foo foo)],
component => <<'EOF',
<%args>
$foo
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);
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);
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";
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;
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
6
7
<%args>#8
$foo#9
@bar#10
11
<%init>#12
#13
#14
#15
$y; #16
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
% 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
<% $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
<%flags>
# this is a comment
# another comment
inherit => undef
# one last comment
compiled
EOF
expect => 'compiled',
);
#------------------------------------------------------------
$group->add_test( name => 'attr_flag_block_empty',
description => 'test empty attr and flags blocks',
component => <<'EOF',
<%attr>
<%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 %>
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
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<%attr>foo => 1<%flags>inherit => undef
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
<%attr>
foo => 1
<%args>$bar => 1
<%attr>bar => 1
<%args>
$quux => 1
<%attr>
quux => 1
<%args> $baz => 1
<%attr> baz => 1
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;
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
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
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
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;
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;
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' }
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 );
<%shared>
my $x = 7;
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 );
<%shared>
$x = 8;
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!' }
<% 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
EOF
);
$group->add_support( path => '/no_subcomp',
component => <<'EOF',
<%shared>
my $y = 1;
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 '',
% if ($count < $max) {
<& recurse_test, count=>$count+1, max=>$max &>
% }
Exiting <% $count %> \
<%args>
$count=>0
$max
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');
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 }
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 }
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 );
% $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 } }
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';");
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.52/t/PaxHeader/07a-interp-mcr.t 000644 777777 777777 00000000212 12225201111 020366 x ustar 00jonswart 000000 000000 18 gid=1896053708
17 uid=512269995
20 ctime=1381302857
20 atime=1381302857
23 SCHILY.dev=16777220
22 SCHILY.ino=6246779
18 SCHILY.nlink=1
HTML-Mason-1.52/t/07a-interp-mcr.t 000644 « q{Μ00000012471 12225201111 017355 0 ustar 00jonswart 000000 000000 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.52/t/PaxHeader/07b-interp-static-source.t 000644 777777 777777 00000000212 12225201111 022373 x ustar 00jonswart 000000 000000 18 gid=1896053708
17 uid=512269995
20 ctime=1381302857
20 atime=1381302857
23 SCHILY.dev=16777220
22 SCHILY.ino=6246780
18 SCHILY.nlink=1
HTML-Mason-1.52/t/07b-interp-static-source.t 000644 « q{Μ00000014227 12225201111 021363 0 ustar 00jonswart 000000 000000 use strict;
use warnings;
use File::Spec;
use HTML::Mason::Tests;
use HTML::Mason::Tools qw(load_pkg);
use IO::File;
package HTML::Mason::Commands;
sub write_component
{
my ($comp, $text) = @_;
my $file = $comp->source_file;
my $fh = new IO::File ">$file" or die "Cannot write to $file: $!";
$fh->print($text);
$fh->close();
}
package main;
my $tests = make_tests();
$tests->run;
sub make_tests
{
my $group = HTML::Mason::Tests->tests_class->new( name => 'interp-static-source',
description => 'interp static source mode' );
#------------------------------------------------------------
foreach my $i (1..4) {
$group->add_support( path => "support/remove_component$i",
component => "I will be removed ($i).\n",
);
}
#------------------------------------------------------------
foreach my $i (1..4) {
$group->add_support( path => "support/change_component$i",
component => "I will be changed ($i).\n",
);
}
#------------------------------------------------------------
$group->add_test( name => 'change_component_without_static_source',
description => 'test that on-the-fly component changes are detected with static_source=0',
component => <<'EOF',
<& support/change_component1 &>\
<%perl>
sleep(2); # Make sure timestamp changes
write_component($m->fetch_comp('support/change_component1'), "I have changed!\n");
<& support/change_component1 &>
EOF
expect => <<'EOF',
I will be changed (1).
I have changed!
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'change_component_with_static_source',
description => 'test that changing component has no effect with static_source=1',
interp_params => { static_source => 1 },
component => <<'EOF',
<& support/change_component2 &>\
<%perl>
sleep(1); # Make sure timestamp changes
write_component($m->fetch_comp('support/change_component2'), "I have changed!\n");
my $comp = $m->interp->load("/interp-static-source/support/change_component2");
$m->comp($comp);
<& support/change_component2 &>
EOF
expect => <<'EOF',
I will be changed (2).
I will be changed (2).
I will be changed (2).
EOF
);
#------------------------------------------------------------
my $static_source_touch_file = File::Spec->catfile($group->base_path, '.__static_source_touch');
$group->add_test( name => 'change_component_with_static_source_touch_file',
description => 'test that changing component has no effect until touch file is touched',
interp_params => { static_source => 1,
static_source_touch_file => $static_source_touch_file },
component => <<'EOF',
<%perl>
my $path = "/interp-static-source/support/change_component3";
$m->comp($path);
sleep(1); # Make sure timestamp changes
write_component($m->fetch_comp('support/change_component3'), "I have changed!\n");
$m->interp->check_static_source_touch_file;
$m->comp($path);
my $touch_file = $m->interp->static_source_touch_file;
my $fh = new IO::File ">$touch_file"
or die "cannot write to '$touch_file': $!";
$fh->close();
$m->interp->check_static_source_touch_file;
$m->comp($path);
EOF
expect => <<'EOF',
I will be changed (3).
I will be changed (3).
I have changed!
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'remove_component_without_static_source',
description => 'test that removing source causes component not found with static_source=0',
component => <<'EOF',
<& support/remove_component1 &>
<%perl>
my $file = $m->fetch_comp('support/remove_component1')->source_file;
unlink($file) or die "could not unlink '$file'";
<& support/remove_component1 &>
EOF
expect_error => qr/could not find component for path/,
);
#------------------------------------------------------------
$group->add_test( name => 'remove_component_with_static_source',
description => 'test that removing source has no effect with static_source=1',
interp_params => { static_source => 1 },
component => <<'EOF',
<%init>
# flush_code_cache actually broke this behavior at one point
$m->interp->flush_code_cache;
<& support/remove_component2 &>
<%perl>
my $file = $m->fetch_comp('support/remove_component2')->source_file;
unlink($file) or die "could not unlink '$file'";
my $comp = $m->interp->load("/interp-static-source/support/remove_component2")
or die "could not load component";
$m->comp($comp);
<& support/remove_component2 &>
EOF
expect => <<'EOF',
I will be removed (2).
I will be removed (2).
I will be removed (2).
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'flush_code_cache_with_static_source',
description => 'test that code cache flush & object file removal works with static_source=1',
interp_params => { static_source => 1 },
component => <<'EOF',
<& support/change_component4 &>
<%perl>
write_component($m->fetch_comp('support/change_component4'), "I have changed!\n");
# Not enough - must delete object file
$m->interp->flush_code_cache;
my $comp = $m->interp->load("/interp-static-source/support/change_component4");
$m->comp($comp);
# This should work
unlink($comp->object_file);
undef $comp;
$m->interp->flush_code_cache;
my $comp2 = $m->interp->load("/interp-static-source/support/change_component4");
$m->comp($comp2);
<& support/change_component4 &>
EOF
expect => <<'EOF',
I will be changed (4).
I will be changed (4).
I have changed!
I have changed!
EOF
);
return $group;
}
HTML-Mason-1.52/t/PaxHeader/09-component.t 000644 777777 777777 00000000212 12225201111 020151 x ustar 00jonswart 000000 000000 18 gid=1896053708
17 uid=512269995
20 ctime=1381302857
20 atime=1381302857
23 SCHILY.dev=16777220
22 SCHILY.ino=6246781
18 SCHILY.nlink=1
HTML-Mason-1.52/t/09-component.t 000644 « q{Μ00000024201 12225201111 017132 0 ustar 00jonswart 000000 000000 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 => 'component',
description => 'Component object functionality' );
#------------------------------------------------------------
$group->add_test( name => 'comp_obj',
path => 'comp_obj_test/comp_obj',
call_path => 'comp_obj_test/comp_obj',
description => 'Tests several component object methods',
component => <<'EOF',
<%def .subcomp>
% my $adj = 'happy';
I am a <% $adj %> subcomp.
<%args>
$crucial
$useless=>17
<%method meth>
% my $adj = 'sad';
I am a <% $adj %> method.
<%args>
$crucial
$useless=>17
% my $anon = $m->interp->make_component(comp_source=>join("\n",'% my $adj = "flummoxed";','I am a <% $adj %> anonymous component.'),name=>'anonymous');
<% '-' x 60 %>
File-based:
<& /shared/display_comp_obj, comp=>$m->current_comp &>
<% '-' x 60 %>
Subcomponent:
<& /shared/display_comp_obj, comp=>$m->fetch_comp('.subcomp') &>
<% '-' x 60 %>
Method:
<& /shared/display_comp_obj, comp=>$m->fetch_comp('SELF:meth') &>
<% '-' x 60 %>
Anonymous component:
<& $anon &>
<& $anon &>
<& /shared/display_comp_obj, comp=>$anon &>
<%args>
@animals=>('lions','tigers')
EOF
expect => <<'EOF',
------------------------------------------------------------
File-based:
Declared args:
@animals=>('lions','tigers')
I am not a subcomponent.
I am not a method.
I am file-based.
My short name is comp_obj.
My directory is /component/comp_obj_test.
I have 1 subcomponent(s).
Including one called .subcomp.
My title is /component/comp_obj_test/comp_obj.
My path is /component/comp_obj_test/comp_obj.
My comp_id is /component/comp_obj_test/comp_obj.
------------------------------------------------------------
Subcomponent:
Declared args:
$crucial
$useless=>17
I am a subcomponent.
I am not a method.
I am not file-based.
My short name is .subcomp.
My parent component is /component/comp_obj_test/comp_obj.
My directory is /component/comp_obj_test.
I have 0 subcomponent(s).
My title is /component/comp_obj_test/comp_obj:.subcomp.
My path is /component/comp_obj_test/comp_obj:.subcomp.
My comp_id is [subcomponent '.subcomp' of /component/comp_obj_test/comp_obj].
------------------------------------------------------------
Method:
Declared args:
$crucial
$useless=>17
I am a subcomponent.
I am a method.
I am not file-based.
My short name is meth.
My parent component is /component/comp_obj_test/comp_obj.
My directory is /component/comp_obj_test.
I have 0 subcomponent(s).
My title is /component/comp_obj_test/comp_obj:meth.
My path is /component/comp_obj_test/comp_obj:meth.
My comp_id is [method 'meth' of /component/comp_obj_test/comp_obj].
------------------------------------------------------------
Anonymous component:
I am a flummoxed anonymous component.
I am a flummoxed anonymous component.
Declared args:
I am not a subcomponent.
I am not a method.
I am not file-based.
My short name is [anon something].
I have 0 subcomponent(s).
My title is [anon something].
My comp_id is [anon something].
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'context',
description => 'Tests list/scalar context propogation in comp calls',
component => <<'EOF',
Context checking:
List:\
% my $discard = [$m->comp('.subcomp')];
Scalar:\
% scalar $m->comp('.subcomp');
Scalar:\
<& .subcomp &>
<%def .subcomp>
% $m->print( wantarray ? 'array' : 'scalar' );
EOF
expect => <<'EOF',
Context checking:
List:
array
Scalar:
scalar
Scalar:
scalar
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'scomp',
description => 'Test scomp Request method',
component => <<'EOF',
% my $text = $m->scomp('.subcomp', 1,2,3);
-----
<% $text %>
<%def .subcomp>
Hello, you say <% join '', @_ %>.
EOF
expect => <<'EOF',
-----
Hello, you say 123.
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'mfu_count',
description => 'Test mfu_count component method',
component => <<'EOF',
<% $m->current_comp->mfu_count %>
% $m->current_comp->mfu_count(75);
<% $m->current_comp->mfu_count %>
EOF
expect => <<'EOF',
1
75
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'store',
description => 'Test store parameter to component call',
component => <<'EOF',
% my $buffy;
% my $rtn;
% $rtn = $m->comp({store => \$buffy}, '.subcomp', 1,2,3,4);
-----
<% $buffy %>
returned <% $rtn %>
<%def .subcomp>
Hello, you say <% join '', @_ %>.
% return 'foo';
EOF
expect => <<'EOF',
-----
Hello, you say 1234.
returned foo
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'flush_clear',
description => 'Flush then clear',
component => <<'EOF',
Foo
% $m->flush_buffer;
Bar
% $m->clear_buffer;
Baz
EOF
expect => <<'EOF',
Foo
Baz
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'flush_clear_scomp',
description => 'Flush then clear inside scomp - flush only affects top buffer',
component => <<'EOF',
<%method s>
Foo
% $m->flush_buffer;
Bar
% $m->clear_buffer;
Baz
This is me
----------
This is scomp-ed output:
<% $m->scomp('SELF:s') %>
----------
This is me again
EOF
expect => <<'EOF',
This is me
----------
This is scomp-ed output:
Baz
----------
This is me again
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'attr_if_exists',
description => 'Test attr_if_exists method',
component => <<'EOF',
have it: <% $m->base_comp->attr_if_exists('have_it') %>
don't have it: <% defined($m->base_comp->attr_if_exists('don\'t have_it')) ? 'defined' : 'undefined' %>
<%attr>
have_it => 1
EOF
expect => <<'EOF',
have it: 1
don't have it: undefined
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'methods',
description => 'Test methods method',
component => <<'EOF',
% my $comp = $m->request_comp;
% my $methods = $comp->methods;
% foreach my $name ( sort keys %$methods ) {
<% $name %>
% }
<% $comp->methods('x') ? 'has' : 'does not have' %> x
<% $comp->methods('y') ? 'has' : 'does not have' %> y
<% $comp->methods('z') ? 'has' : 'does not have' %> z
<%method x>
x
<%method y>
y
EOF
expect => <<'EOF',
x
y
has x
has y
does not have z
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'subcomps',
description => 'Test subcomps method',
component => <<'EOF',
% my $comp = $m->request_comp;
% my $subcomps = $comp->subcomps;
% foreach my $name ( sort keys %$subcomps ) {
<% $name %>
% }
<% $comp->subcomps('x') ? 'has' : 'does not have' %> x
<% $comp->subcomps('y') ? 'has' : 'does not have' %> y
<% $comp->subcomps('z') ? 'has' : 'does not have' %> z
<%def x>
x
<%def y>
y
EOF
expect => <<'EOF',
x
y
has x
has y
does not have z
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'attributes',
description => 'Test attributes method',
component => <<'EOF',
% my $comp = $m->request_comp;
% my $attrs = $comp->attributes;
% foreach my $name ( sort keys %$attrs ) {
<% $name %>
% }
<%attr>
x => 1
y => 2
EOF
expect => <<'EOF',
x
y
EOF
);
#------------------------------------------------------------
$group->add_support( path => 'args_copying_helper',
component => <<'EOF',
<%init>
$_[1] = 4;
$b = 5;
$ARGS{'c'} = 6;
<%args>
$a
$b
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'component_args_copying',
description => 'Test that @_ contains aliases, <%args> and %ARGS contain copies after comp',
component => <<'EOF',
$a is <% $a %>
$b is <% $b %>
$c is <% $c %>
<%init>;
my $a = 1;
my $b = 2;
my $c = 3;
$m->comp('args_copying_helper', a=>$a, b=>$b, c=>$c);
EOF
expect => <<'EOF',
$a is 4
$b is 2
$c is 3
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'subrequest_args_copying',
description => 'Test that @_ contains aliases, <%args> and %ARGS contain copies after subrequest',
component => <<'EOF',
$a is <% $a %>
$b is <% $b %>
$c is <% $c %>
<%init>;
my $a = 1;
my $b = 2;
my $c = 3;
$m->subexec('/component/args_copying_helper', a=>$a, b=>$b, c=>$c);
EOF
expect => <<'EOF',
$a is 4
$b is 2
$c is 3
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'modification_read_only_arg',
description => 'Test that read-only argument cannot be modified through @_',
component => <<'EOF',
<%init>;
$m->comp('args_copying_helper', a=>1, b=>2, c=>3);
EOF
expect_error => 'Modification of a read-only value',
);
#------------------------------------------------------------
return $group;
}
HTML-Mason-1.52/t/PaxHeader/09a-comp_content.t 000644 777777 777777 00000000212 12225201111 021000 x ustar 00jonswart 000000 000000 18 gid=1896053708
17 uid=512269995
20 ctime=1381302857
20 atime=1381302857
23 SCHILY.dev=16777220
22 SCHILY.ino=6246782
18 SCHILY.nlink=1
HTML-Mason-1.52/t/09a-comp_content.t 000644 « q{Μ00000032014 12225201111 017762 0 ustar 00jonswart 000000 000000 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 => 'filters',
description => 'Filter Component' );
#------------------------------------------------------------
$group->add_support( path => 'filter_test/filter',
component => <<'EOF',
<%once>
my %words = (1,'one',2,'two',3,'three',4,'four',5,'five');
<%perl>
my $c = $m->content;
$c = '' unless defined $c; # avoid uninitialized value warnings
$c =~ s/^\s+//;
$c =~ s/\s+$//;
if ($words{$c}) {
$m->print($words{$c});
} else {
$m->print("content returned '".$c."'");
}
EOF
);
#------------------------------------------------------------
$group->add_support( path => 'filter_test/repeat',
component => <<'EOF',
<%args>
$var
@list
<%perl>
for (@list) {
$$var = $_;
$m->print($m->content);
}
EOF
);
#------------------------------------------------------------
$group->add_support( path => 'filter_test/repeat2',
component => <<'EOF',
<%args>
@list
% foreach (@list) {
<% $m->content %>
% }
EOF
);
#------------------------------------------------------------
$group->add_support( path => 'filter_test/null',
component => <<'EOF',
EOF
);
#------------------------------------------------------------
$group->add_support( path => 'filter_test/echo',
component => <<'EOF',
% $m->print($m->content);
EOF
);
#------------------------------------------------------------
$group->add_support( path => 'filter_test/double',
component => <<'EOF',
<&| filter &>1
<&| filter &><% $m->content %>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'repeat',
path => 'filter_test/test1',
call_path => 'filter_test/test1',
description => 'Tests a filter which outputs the content multiple times, with different values',
component => <<'EOF',
% my $a;
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
<&| filter &>
% $m->print("this is a perl line ");
<% "substitution tag" %>
<& SELF:lala &>
<%perl>
$m->print("perl tag");
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/
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!
<%method happy>
<% $m->content %>, be happy!
<&| 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 .lc>\
<% lc $m->content %>\
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 %>\
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 .clear>\
% $m->clear_buffer;
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 %>\
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.
% }
EOF
expect => <<'EOF',
I have no content.
-----
My content is:
This is the content
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'ending_tag_match',
description => 'Test ',
component => <<'EOF',
<&|.outer &>\
<&| .inner, dummy=>1 &>\
This is the content
<%def .inner>\
% $m->print("inner: ".$m->content);
<%def .outer>\
% $m->print("outer: ".$m->content);
EOF
expect => <<'EOF',
outer: inner: This is the content
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'ending_tag_nomatch',
description => 'Test bad match',
component => <<'EOF',
<&|.outer &>\
<&| .inner&>\
This is the content
<%def .inner>\
% $m->print("inner: ".$m->content);
<%def .outer>\
% $m->print("outer: ".$m->content);
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
<%def .inner>\
% $m->print("inner: ".$m->content);
<%def .outer>\
% $m->print("outer: ".$m->content);
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
<%def .inner>\
% $m->print("inner: ".$m->content);
<%def .outer>\
% $m->print("outer: ".$m->content);
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\
\
<%def Wrap>\
[Wrap start]
<% $m->content %>
[Wrap end]\
EOF
expect => <<'EOF',
[Wrap start]
Hello
[Wrap end]
EOF
);
#------------------------------------------------------------
return $group;
}
HTML-Mason-1.52/t/PaxHeader/10-cache.t 000644 777777 777777 00000000212 12225201111 017202 x ustar 00jonswart 000000 000000 18 gid=1896053708
17 uid=512269995
20 ctime=1381302857
20 atime=1381302857
23 SCHILY.dev=16777220
22 SCHILY.ino=6246783
18 SCHILY.nlink=1
HTML-Mason-1.52/t/10-cache.t 000644 « q{Μ00000035465 12225201111 016201 0 ustar 00jonswart 000000 000000 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;
}
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");
}
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
<%init>
return if $m->cache_self;
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
<%init>
return if $m->cache_self( expires_in => '3s' );
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
<%init>
return if $m->cache_self( expire_in => '2s' );
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
<%init>
return if $m->cache_self( expire_if => sub { $x == 3 } );
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
<%init>
return if $m->cache_self( key => $key );
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!";
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
<%init>
return if $m->cache_self( key => $key );
<%filter>
$_ = uc $_;
$_ .= ' filtered';
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
<%init>
return if $m->cache_self;
<%filter>
s/(\d+)/$1+1/ge;
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');
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');
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');
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';
EOF
);
$group->add_test( name => 'cache_self_death',
description => 'test $m->cache_self and death',
component => <<'EOF',
<%init>
$m->comp( 'support/cache_self_die' );
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 );
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 ) };
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.52/t/PaxHeader/10a-cache-1.0x.t 000644 777777 777777 00000000212 12225201111 020027 x ustar 00jonswart 000000 000000 18 gid=1896053708
17 uid=512269995
20 ctime=1381302857
20 atime=1381302857
23 SCHILY.dev=16777220
22 SCHILY.ino=6246784
18 SCHILY.nlink=1
HTML-Mason-1.52/t/10a-cache-1.0x.t 000644 « q{Μ00000013046 12225201111 017015 0 ustar 00jonswart 000000 000000 #
# Test 1.0 cache API compatibility layer.
#
use strict;
use warnings;
use HTML::Mason::Tests;
# Skip if flock not implemented.
eval { my $fh = do { local *FH; *FH; }; open $fh, $0; flock $fh,1; };
if ($@)
{
print "1..0\n";
exit;
}
# Skip if Cache::FileCache not present.
eval { require Cache::FileCache };
if ($@)
{
print "1..0\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_support( path => 'support/cache_test',
component => <<'EOF',
<% $result %>
This was<% $cached ? '' : ' not' %> cached.
Return value: <% $return %>
<%init>
my $cached = 0;
my $result;
my $return;
unless ($result = $m->cache(key=>'fandango')) {
$result = "Hello Dolly.";
$return = $m->cache(action=>'store', key=>'fandango', value=>$result) || '';
} else {
$cached = 1;
}
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'cache',
description => 'basic caching functionality',
interp_params => { data_cache_api => '1.0' },
component => <<'EOF',
% for (my $i=0; $i<3; $i++) {
<& support/cache_test &>
% }
EOF
expect => <<'EOF',
Hello Dolly.
This was not cached.
Return value: Hello Dolly.
Hello Dolly.
This was cached.
Return value:
Hello Dolly.
This was cached.
Return value:
EOF
);
#------------------------------------------------------------
$group->add_support( path => 'support/cache_self_test',
component => <<'EOF',
Hello World! var = <% $var %>
<%init>
return if $m->cache_self(key=>'fandango');
<%args>
$var
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'cache_self',
description => 'cache_self functionality',
interp_params => { data_cache_api => '1.0' },
component => <<'EOF',
% my $var = 1;
% for (my $i=0; $i<3; $i++) {
<% $m->comp('support/cache_self_test',var=>$var) %>
% $var++;
% }
EOF
expect => <<'EOF',
Hello World! var = 1
Hello World! var = 1
Hello World! var = 1
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'keys',
description => q|test $m->cache( action => 'keys' )|,
interp_params => { data_cache_api => '1.0' },
component => <<'EOF',
<%init>
foreach my $key (qw(foo bar baz)) {
$m->cache(action=>'store',key=>$key,value=>$key);
}
my @keys = sort $m->cache(action=>'keys');
$m->out("keys in cache: ".join(",",@keys)."\n");
foreach my $key (qw(foo bar baz)) {
my $value = $m->cache(key=>$key) || "undefined";
$m->out("value for $key is $value\n");
}
$m->cache(action=>'expire', key=>[qw(foo bar)]);
$m->out("expiring foo and bar...\n");
foreach my $key (qw(foo bar baz)) {
my $value = $m->cache(key=>$key) || "undefined";
$m->out("value for $key is $value\n");
}
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_test( name => 'expire_if',
description => 'test expire_if',
interp_params => { data_cache_api => '1.0' },
component => <<'EOF',
<% join(', ', $value1 || 'undef', $value2 || 'undef', $value3 || 'undef', $value4 || 'undef') %>
<%init>
my $time = time;
$m->cache(value=>'gardenia', action=>'store');
my $value1 = $m->cache;
my $value2 = $m->cache(expire_if=>sub { $_[0] <= $time-1 });
my $value3 = $m->cache(expire_if=>sub { $_[0] >= $time });
my $value4 = $m->cache;
EOF
expect => <<'EOF',
gardenia, gardenia, undef, undef
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'busy_lock',
description => 'test busy_lock',
interp_params => { data_cache_api => '1.0' },
component => <<'EOF',
<% join(', ', $value1 || 'undef', $value2 || 'undef') %>
<%init>
my $time = time;
$m->cache(value=>'gardenia', action=>'store', expire_at=>time);
sleep(1);
my $value1 = $m->cache(busy_lock=>'10 sec');
my $value2 = $m->cache;
EOF
expect => <<'EOF',
undef, gardenia
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'busy_lock_expiration',
description => 'test busy_lock expiration',
interp_params => { data_cache_api => '1.0' },
component => <<'EOF',
<% join(', ', $value1 || 'undef', $value2 || 'undef') %>
<%init>
my $time = time;
$m->cache(value=>'gardenia', action=>'store', expire_at=>time);
sleep(1);
my $value1 = $m->cache(busy_lock=>'1 sec');
sleep(1);
my $value2 = $m->cache;
EOF
expect => <<'EOF',
undef, undef
EOF
);
#------------------------------------------------------------
return $group;
}
HTML-Mason-1.52/t/PaxHeader/10b-cache-chi.t 000644 777777 777777 00000000212 12225201111 020105 x ustar 00jonswart 000000 000000 18 gid=1896053708
17 uid=512269995
20 ctime=1381302857
20 atime=1381302857
23 SCHILY.dev=16777220
22 SCHILY.ino=6246785
18 SCHILY.nlink=1
HTML-Mason-1.52/t/10b-cache-chi.t 000644 « q{Μ00000037313 12225201111 017076 0 ustar 00jonswart 000000 000000 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;
}
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");
}
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
<%init>
return if $m->cache_self;
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
<%init>
return if $m->cache_self( expires_in => '3s' );
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
<%init>
return if $m->cache_self( expire_in => '1s' );
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
<%init>
return if $m->cache_self( expire_if => sub { $x == 3 } );
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
<%init>
return if $m->cache_self( key => $key );
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!";
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
<%init>
return if $m->cache_self( key => $key );
<%filter>
$_ = uc $_;
$_ .= ' filtered';
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
<%init>
return if $m->cache_self;
<%filter>
s/(\d+)/$1+1/ge;
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 });
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');
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');
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';
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' );
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 );
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 ) };
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.52/t/PaxHeader/11-inherit.t 000644 777777 777777 00000000212 12225201111 017602 x ustar 00jonswart 000000 000000 18 gid=1896053708
17 uid=512269995
20 ctime=1381302857
20 atime=1381302857
23 SCHILY.dev=16777220
22 SCHILY.ino=6246786
18 SCHILY.nlink=1
HTML-Mason-1.52/t/11-inherit.t 000644 « q{Μ00000040475 12225201111 016576 0 ustar 00jonswart 000000 000000 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 m12>m12 from level 1
<%method m13>m13 from level 1
<%method m123>m123 from level 1
<%attr>
a1=>'a1 from level 1'
a12=>'a12 from level 1'
a13=>'a13 from level 1'
a123=>'a123 from level 1'
<& { 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;
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;
EOF
);
#------------------------------------------------------------
$group->add_support( path => 'subdir/autohandler',
component => <<'EOF',
<%method m2>m2 from level 2
<%method m12>m12 from level 2
<%method m23>m23 from level 2
<%method m123>m123 from level 2
<%attr>
a2=>'a2 from level 2'
a12=>'a12 from level 2'
a23=>'a23 from level 2'
a123=>'a123 from level 2'
<& { base_comp => $m->base_comp }, '../variants' &>
<& call_next_helper &>
<%init>
my $self = $m->base_comp;
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 m13>m13 from level 3
<%method m23>m23 from level 3
<%method m123>m123 from level 3
<%attr>
a3=>'a3 from level 3'
a13=>'a13 from level 3'
a23=>'a23 from level 3'
a123=>'a123 from level 3'
<& { base_comp => $m->base_comp }, '../variants' &>
<& ../report_parent &>
<%flags>
inherit=>'../autohandler'
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 m13>m13 from level 3
<%method m23>m23 from level 3
<%method m123>m123 from level 3
<%attr>
a3=>'a3 from level 3'
a13=>'a13 from level 3'
a23=>'a23 from level 3'
a123=>'a123 from level 3'
%# base_comp currently does not change when a comp ref is used
% my $variants = $m->fetch_comp('../variants');
<& $variants &>
<& ../report_parent &>
<%flags>
inherit=>undef
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 m13>m13 from level 3
<%method m23>m23 from level 3
<%method m123>m123 from level 3
<%attr>
a3=>'a3 from level 3'
a13=>'a13 from level 3'
a23=>'a23 from level 3'
a123=>'a123 from level 3'
<& { 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
<%attr>
a => 'base autohandler'
<%method x>
This is X in base autohandler
attribute A is <% $m->base_comp->attr('a') %>
<& SELF:x &>
<& .util &>
<%method y>
This is method Y in base autohandler
base_comp is <% $m->base_comp->name %>
<%def .util>
This is subcomponent .util
base_comp is <% $m->base_comp->name %>
<& SELF:y &>
% $m->call_next;
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/util/autohandler',
component => <<'EOF',
<%flags>
inherit => undef
<%attr>
a => 'util autohandler'
<%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 exec>
This is autohandler:exec
exec was really called for <% $m->base_comp->name %>
attribute A is <% $m->base_comp->attr('a') %>
<& SELF:x &>
% $m->call_next;
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/util/util',
component => <<'EOF',
<%method x>
This is method X in UTIL
<%attr>
a => 'util'
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
<%attr>
a => 'base'
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
<%attr>
a => 'meth'
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
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
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
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
<%def .sub>
This is a subcomponent
<& SELF:x &>
<%method x>
This is method X
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
<%method x>
This is X in base autohandler
<& .foo &>
<%def .foo>
% $m->call_next;
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
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 &>
<%method bar>
This is parent's bar.
<%flags>
inherit => undef
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'
<%method bar>
This is child's bar.
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
<%flags>
inherit => undef
EOF
);
$group->add_support( path => '/request_test/other_comp',
component => <<'EOF',
<& REQUEST:x &>\
<& SELF:x &>\
<%method x>x in other comp
<%flags>
inherit => undef
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
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.52/t/PaxHeader/12-taint.t 000644 777777 777777 00000000212 12225201111 017260 x ustar 00jonswart 000000 000000 18 gid=1896053708
17 uid=512269995
20 ctime=1381302857
20 atime=1381302857
23 SCHILY.dev=16777220
22 SCHILY.ino=6246787
18 SCHILY.nlink=1
HTML-Mason-1.52/t/12-taint.t 000644 « q{Μ00000006713 12225201111 016251 0 ustar 00jonswart 000000 000000 #!/usr/bin/perl -T
use strict;
use warnings;
BEGIN {
# See 'perlrun' and 'perlsec' man pages
# and http://marc.theaimsgroup.com/?l=mason-devel&m=105469927404246&w=2
$ENV{PATH} = '/bin:/usr/bin';
delete @ENV{qw(IFS CDPATH ENV BASH_ENV)};
}
# Cwd has to be loaded after sanitizing %ENV
use Cwd;
use File::Spec;
use Test;
BEGIN
{
my $curdir = File::Spec->curdir;
my $libs = 'use lib qw( ';
$libs .=
( join ' ',
File::Spec->catdir( $curdir, 'blib', 'lib' ),
File::Spec->catdir( $curdir, 't', 'lib' )
);
if ($ENV{PERL5LIB})
{
$libs .= ' ';
$libs .= join ' ', (split /:|;/, $ENV{PERL5LIB});
}
$libs .= ' );';
($libs) = $libs =~ /(.*)/;
# explicitly use these because otherwise taint mode causes them to
# be ignored
eval $libs;
}
use HTML::Mason::Interp;
use HTML::Mason::Compiler::ToObject;
use HTML::Mason::Tools qw(read_file taint_is_on);
# Clear alarms, and skip test if alarm not implemented
my $alarm_works = eval {alarm 0; 1} || 0;
plan tests => 8 + $alarm_works;
# These tests depend on taint mode being on
ok taint_is_on();
if ($alarm_works)
{
my $compiler = HTML::Mason::Compiler::ToObject->new;
my $alarm;
$SIG{ALRM} = sub { $alarm = 1; die "alarm"; };
my $source = read_file( File::Spec->catfile( File::Spec->curdir, 't', 'taint.comp' ) );
my $comp;
eval { alarm 5;
local $^W;
$comp =
$compiler->compile
( comp_source => $source,
name => 't/taint.comp',
comp_path => '/taint.comp',
);
};
my $error = ( $alarm ? "entered endless while loop" :
$@ ? "gave error during test: $@" :
!defined($comp) ? "returned an undefined value from compiling" :
'' );
ok $error, '';
}
# Make these values untainted
my ($comp_root) = File::Spec->catdir( getcwd(), 'mason_tests', 'comps' ) =~ /(.*)/;
my ($data_dir) = File::Spec->catdir( getcwd(), 'mason_tests', 'data' ) =~ /(.*)/;
ok !is_tainted($comp_root);
ok !is_tainted($data_dir);
my $interp = HTML::Mason::Interp->new( comp_root => $comp_root,
data_dir => $data_dir,
);
$data_dir = File::Spec->catdir( getcwd(), 'mason_tests', 'data' );
# This source is tainted, as is anything with return val from getcwd()
my $comp2 = HTML::Mason::ComponentSource->new
( friendly_name => 't/taint.comp',
comp_path => '/t/taint.comp',
source_callback => sub {
read_file( File::Spec->catfile( File::Spec->curdir, 't', 'taint.comp' ) );
},
);
ok $comp2;
ok is_tainted($comp2->comp_source);
# Make sure we can write tainted data to disk
eval { $interp->compiler->compile_to_file
( file => File::Spec->catfile( $data_dir, 'taint_write_test' ),
source => $comp2,
); };
ok $@, '', "Can write a tainted object to disk";
my $cwd = getcwd(); # tainted
$cwd = "$0$^X" unless is_tainted($cwd);
# This isn't a part of the documented interface, but we test it here anyway.
my $code = "# MASON COMPILER ID: ". $interp->compiler->object_id ."\nmy \$x = '$cwd';"; # also tainted
ok is_tainted($code);
eval { $interp->eval_object_code( object_code => \$code ) };
ok $@, '', "Unable to eval a tainted object file";
###########################################################
sub is_tainted {
return not eval { "+@_" && eval 1 };
}
HTML-Mason-1.52/t/PaxHeader/13-errors.t 000644 777777 777777 00000000212 12225201111 017456 x ustar 00jonswart 000000 000000 18 gid=1896053708
17 uid=512269995
20 ctime=1381302857
20 atime=1381302857
23 SCHILY.dev=16777220
22 SCHILY.ino=6246788
18 SCHILY.nlink=1
HTML-Mason-1.52/t/13-errors.t 000644 « q{Μ00000035655 12225201111 016456 0 ustar 00jonswart 000000 000000 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');
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
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');
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');
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 foo>
foo
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 foo>
foo
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
<%def foo>
foo
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
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>
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;
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";
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.52/t/PaxHeader/14-cgi.t 000644 777777 777777 00000000212 12225201111 016705 x ustar 00jonswart 000000 000000 18 gid=1896053708
17 uid=512269995
20 ctime=1381302857
20 atime=1381302857
23 SCHILY.dev=16777220
22 SCHILY.ino=6246789
18 SCHILY.nlink=1
HTML-Mason-1.52/t/14-cgi.t 000644 « q{Μ00000010437 12225201111 015674 0 ustar 00jonswart 000000 000000 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 { $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.52/t/PaxHeader/14a-fake_apache.t 000644 777777 777777 00000000212 12225201111 020513 x ustar 00jonswart 000000 000000 18 gid=1896053708
17 uid=512269995
20 ctime=1381302857
20 atime=1381302857
23 SCHILY.dev=16777220
22 SCHILY.ino=6246790
18 SCHILY.nlink=1
HTML-Mason-1.52/t/14a-fake_apache.t 000644 « q{Μ00000017637 12225201111 017513 0 ustar 00jonswart 000000 000000 use strict;
use warnings;
use Test::More tests => 97;
use CGI qw(-no_debug);
BEGIN { use_ok('HTML::Mason::CGIHandler') }
# Create headers object.
ok( my $h = HTML::Mason::FakeTable->new, "Create new FakeTable" );
# Test direct hash access.
ok( $h->{Location} = 'foo', "Assing to Location" );
is( $h->{Location}, 'foo', "Location if 'foo'" );
# Test case-insensitivity.
is( $h->{location}, 'foo', "location if 'foo'" );
is( delete $h->{Location}, 'foo', "Delete location" );
# Test add().
ok( $h->{Hey} = 1, "Set 'Hey' to 1" );
ok( $h->add('Hey', 2), "Add another value to 'Hey'" );
# Fetch both values at once.
is_deeply( [$h->get('Hey')], [1,2], "Get array for 'Hey'" );
is( scalar $h->get('Hey'), 1, "Get first 'Hey' value only" );
# Try do(). The code ref should be executed twice, once for each value
# in the 'Hey' array reference.
my $i;
$h->do( sub {
my ($k, $v) = @_;
is( $k, 'Hey', "Check key in 'do'" );
is( $v, ++$i, "Check value in 'do'" );
});
# Try short-circutiting do(). The code ref should be executed only once,
# because it returns a false value.
$h->do( sub {
my ($k, $v) = @_;
is( $k, 'Hey', "Check key in short 'do'" );
is( $v, 1, "Check value in short 'do'" );
return;
});
# Test set() and get().
ok( $h->set('Hey', 'bar'), "Set 'Hey' to 'bar'" );
is( $h->{Hey}, 'bar', "Get 'Hey'" );
is( $h->get('Hey'), 'bar', "Get 'Hey' with get()" );
# Try merge().
ok( $h->merge(Hey => 'you'), "Add 'you' to 'Hey'" );
is( $h->{Hey}, 'bar,you', "Get 'Hey'" );
is( $h->get('Hey'), 'bar,you', "Get 'Hey' with get()" );
# Try unset().
ok( $h->unset('Hey'), "Unset 'Hey'" );
ok( ! exists $h->{Hey}, "Hey doesn't exist" );
is( $h->{Hey}, undef, 'Hey is undef' );
# Try clear().
ok( $h->{Foo} = 'bar', "Add Foo value" );
$h->clear;
ok( ! exists $h->{Foo}, "Hey doesn't exist" );
is( $h->{Foo}, undef, 'Hey is undef' );
# Set up some environment variables.
%ENV = ( 'SCRIPT_NAME' => '/login/welcome.html',
'REQUEST_METHOD' => 'GET',
'HTTP_ACCEPT' => 'text/html',
'HTTP_USER_AGENT' => 'Mozilla/5.0',
'HTTP_CACHE_CONTROL' => 'max-age=0',
'HTTP_ACCEPT_LANGUAGE' => 'en-us,en;q=0.5',
'HTTP_KEEP_ALIVE' => '300',
'GATEWAY_INTERFACE' => 'CGI-Perl/1.1',
'DOCUMENT_ROOT' => '/usr/local/bricolage/comp',
'HTTP_REFERER' => 'http://localhost/',
'HTTP_ACCEPT_ENCODING' => 'gzip,deflate',
'HTTP_CONNECTION' => 'keep-alive',
'HTTP_ACCEPT_CHARSET' => 'ISO-8859-1,utf-8;q=0.7,*;q=0.7',
'HTTP_COOKIE' => 'FOO=BAR; HEY=You',
'HTTP_HOST' => 'localhost',
'AUTH_TYPE' => 'Something',
'CONTENT_TYPE' => 'text/html',
'CONTENT_LENGTH' => 42,
'REQUEST_METHOD' => 'GET',
'PATH_INFO' => '/index.html',
'QUERY_STRING' => "foo=1&bar=2&you=3&you=4",
);
# Now create a fake apache object.
ok( my $r = HTML::Mason::FakeApache->new, "Create new FakeApache" );
# Check its basic methods.
is( $r->method, $ENV{REQUEST_METHOD}, "Check request method" );
ok( $r->content_type('text/xml'), 'Set content type' );
is( $r->content_type, 'text/xml', 'Check content type' );
# Check the headers out.
ok( $h = $r->headers_out, "Get headers out" );
is( $h->{'Content-Type'}, 'text/xml', 'Check header content-type' );
is( $h->{'content-type'}, 'text/xml', 'Check lc header content-type' );
# Check with get().
is( $h->get('Content-Type'), 'text/xml', 'Check header content-type' );
is( $h->get('content-type'), 'text/xml', 'Check lc header content-type' );
# Try getting an array.
ok( my %h = $r->headers_out, "Get headers out" );
is( $h{'Content-Type'}, 'text/xml', 'Check header content-type' );
is( $h{'content-type'}, undef, 'List context returns new hash list' );
# Try assigning a new value via header_out().
ok( $r->header_out('Annoyance-Level' => 'high'), "Set annoyance level" );
is( $r->header_out('Annoyance-Level'), 'high', "Check annoyance level" );
is( $h->{'annoyance-level'}, 'high', "Check the hash directly" );
ok( $h->unset('annoyance-level'), 'Unset annoyance level' );
is( $r->header_out('Annoyance-Level'), undef, "Check annoyance level again" );
is( $h->{'annoyance-level'}, undef, "Check the hash directly again" );
# Add some cookies
ok( $r->headers_out()->add('Set-Cookie' => 'AF_SID=6e8834d8787ee57a; path=/'), "Set cookie" );
ok( $r->headers_out()->add('Set-Cookie' => 'uniq_id=5608074; path=/; expires=Tue, 26-Aug-2008 21:27:03 GMT'), "Set cookie" );
# Now check err_headers_out.
my $url = 'http://example.com/';
ok( my $e = $r->err_headers_out, "Get error headers out" );
is( scalar keys %$e, 0, "Check for no error headers out" );
ok( $r->err_header_out(Location => $url), "Set location header" );
is( $e->{Location}, $url, "Check Location" );
is( $e->{location}, $url, "Check location" );
is( $e->get('Location'), $url, "Get Location" );
is( $e->get('location'), $url, "Get location" );
# Now check headers_in().
is( $r->header_in('User-Agent'), $ENV{HTTP_USER_AGENT}, "Check user agent" );
ok( $h = $r->headers_in, "Get headers in table" );
is( $h->{Referer}, $ENV{HTTP_REFERER}, "Check referer" );
is( $h->get('Content-Type'), $ENV{CONTENT_TYPE}, "Check in content type" );
# Try notes().
ok( my $n = $r->notes, "Get notes" );
is( scalar keys %$n, 0, "No notes yet" );
ok( $r->notes( foo => 'bar'), "Set note 'foo'" );
is( $r->notes('foo'), 'bar', "Get note 'foo'" );
is( $r->notes('FOO'), 'bar', "Get note 'FOO'" );
is( $n->{foo}, 'bar', "Check note 'foo'" );
is( $n->{FOO}, 'bar', "Check uc note 'foo'" );
my $ref = [];
ok( $n->{bar} = $ref, "Set 'bar' to '$ref'" );
is( $n->{bar}, "$ref", "Check for stringified ref" );
is( $n->get('bar'), "$ref", "Get stringified ref" );
# Try pnotes().
ok( my $pn = $r->pnotes, "Get pnotes" );
is( scalar keys %$pn, 0, "No pnotes yet" );
ok( $r->pnotes( foo => 'bar'), "Set note 'foo'" );
is( $r->pnotes('foo'), 'bar', "Get note 'foo'" );
is( $pn->{foo}, 'bar', "Check note 'foo'" );
$ref = [];
ok( $pn->{bar} = $ref, "Set 'bar' to '$ref'" );
is( $pn->{bar}, $ref, "Check for stringified ref" );
# Check params()
ok( my $p = $r->params, "Get params" );
is( $p->{foo}, 1, "Check 'foo'" );
is( $p->{bar}, 2, "Check 'bar'" );
is_deeply( $p->{you}, [3, 4], "Check 'you'" );
# Check subprocess_env.
is( $r->subprocess_env('CONTENT_LENGTH'), 42, "Get CONTENT_LENGTH env" );
is( $r->subprocess_env('content_length'), 42, "Get content_length env" );
is( $r->subprocess_env->{CONTENT_LENGTH}, 42, "Check CONTENT_LENGTH env" );
is( $r->subprocess_env->{content_length}, 42, "Check content_length env" );
ok( $r->subprocess_env('CONTENT_LENGTH', 56), "Set CONTENT_LENGTH 56" );
is( $r->subprocess_env('CONTENT_LENGTH'), 56, "Check CONTENT_LENGTH env 56" );
is( $r->subprocess_env('content_length'), 56, "Check content_length env 56" );
# Reset subprocess_env.
ok( $r->subprocess_env, "Reset env" );
is( $r->subprocess_env('CONTENT_LENGTH'), 42, "Check CONTENT_LENGTH env again" );
is( $r->subprocess_env('content_length'), 42, "Check content_length env again" );
# Now see what CGI.pm does with the headers out.
ok( my $headers = $r->http_header, "Get http headers" );
like( $headers, qr/Status: 302 (?:Moved|Found)/i, "Check status" );
like( $headers, qr|Location: $url|i, "Check location" );
like( $headers, qr|Content-Type: text/xml(?:; charset=ISO-8859-1)?|i,
"Check content type" );
like( $headers, qr|Set-Cookie: AF_SID=6e8834d8787ee57a; path=/|i,
'Check first cookie');
like( $headers, qr|Set-Cookie: uniq_id=5608074; path=/; expires=Tue, 26-Aug-2008 21:27:03 GMT|i,
'Check second cookie' );
is( $r->uri, '/login/welcome.html/index.html', 'test uri method' );
is( $r->path_info, '/index.html', 'test path_info method' );
SKIP:
{
skip 'This test requires Test::Output', 1
unless eval { require Test::Output; Test::Output->import; 1};
stdout_is( sub { $r->print('Foo bar') }, 'Foo bar',
'print does not include the object itself' );
}
__END__
HTML-Mason-1.52/t/PaxHeader/15-subclass.t 000644 777777 777777 00000000212 12225201111 017763 x ustar 00jonswart 000000 000000 18 gid=1896053708
17 uid=512269995
20 ctime=1381302857
20 atime=1381302857
23 SCHILY.dev=16777220
22 SCHILY.ino=6246791
18 SCHILY.nlink=1
HTML-Mason-1.52/t/15-subclass.t 000644 « q{Μ00000011352 12225201111 016747 0 ustar 00jonswart 000000 000000 use strict;
use warnings;
use HTML::Mason::Tests;
{
package HTML::Mason::Request::Test;
@HTML::Mason::Request::Test::ISA = 'HTML::Mason::Request';
__PACKAGE__->valid_params( foo_val => { parse => 'string', type => Params::Validate::SCALAR } );
# shuts up 5.00503 warnings
1 if $HTML::Mason::ApacheHandler::VERSION;
1 if $HTML::Mason::CGIHandler::VERSION;
sub new
{
my $class = shift;
$class->alter_superclass( $HTML::Mason::ApacheHandler::VERSION ?
'HTML::Mason::Request::ApacheHandler' :
$HTML::Mason::CGIHandler::VERSION ?
'HTML::Mason::Request::CGI' :
'HTML::Mason::Request' );
my $self = $class->SUPER::new(@_);
}
sub foo_val { $_[0]->{foo_val} }
}
{
package HTML::Mason::Request::Test::Subclass;
@HTML::Mason::Request::Test::Subclass::ISA = 'HTML::Mason::Request::Test';
__PACKAGE__->valid_params( bar_val => { parse => 'string', type => Params::Validate::SCALAR } );
sub bar_val { $_[0]->{bar_val} }
}
{
package HTML::Mason::Lexer::Test;
@HTML::Mason::Lexer::Test::ISA = 'HTML::Mason::Lexer';
__PACKAGE__->valid_params( bar_val => { parse => 'string', type => Params::Validate::SCALAR } );
sub bar_val { $_[0]->{bar_val} }
}
{
package HTML::Mason::Compiler::ToObject::Test;
@HTML::Mason::Compiler::ToObject::Test::ISA = 'HTML::Mason::Compiler::ToObject';
__PACKAGE__->valid_params( baz_val => { parse => 'string', type => Params::Validate::SCALAR } );
sub baz_val { $_[0]->{baz_val} }
sub compiled_component
{
my $self = shift;
my $comp = $self->SUPER::compiled_component(@_);
$$comp =~ s/!!BAZ!!/$self->{baz_val}/g;
return $comp;
}
}
my $tests = make_tests();
$tests->run;
sub make_tests
{
my $group = HTML::Mason::Tests->tests_class->new( name => 'subclass',
description => 'Test use of subclasses for various core classes' );
#------------------------------------------------------------
$group->add_test( name => 'request_subclass',
description => 'use a HTML::Mason::Request subclass',
interp_params => { request_class => 'HTML::Mason::Request::Test',
foo_val => 77 },
component => <<'EOF',
% if ( $m->can('foo_val') ) {
foo_val is <% $m->foo_val %>
% } else {
this request cannot ->foo_val!
% }
EOF
expect => <<'EOF',
foo_val is 77
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'request_subclass_of_subclass',
description => 'use a HTML::Mason::Request grandchild',
interp_params =>
{ request_class => 'HTML::Mason::Request::Test::Subclass',
foo_val => 77,
bar_val => 42,
},
component => <<'EOF',
% if ( $m->can('foo_val') ) {
foo_val is <% $m->foo_val %>
% } else {
this request cannot ->foo_val!
% }
% if ( $m->can('bar_val') ) {
bar_val is <% $m->bar_val %>
% } else {
this request cannot ->bar_val!
% }
EOF
expect => <<'EOF',
foo_val is 77
bar_val is 42
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'lexer_subclass',
description => 'use a HTML::Mason::Lexer subclass',
interp_params => { lexer_class => 'HTML::Mason::Lexer::Test',
bar_val => 76 },
component => <<'EOF',
% my $lex = $m->interp->compiler->lexer;
% if ( $lex->can('bar_val') ) {
bar_val is <% $lex->bar_val %>
% } else {
this lexer cannot ->bar_val!
% }
EOF
expect => <<'EOF',
bar_val is 76
EOF
);
#------------------------------------------------------------
# We don't use object files, because we want to catch the output
# of compiled_component() instead of writing it to a file
$group->add_test( name => 'compiler_subclass',
description => 'use a HTML::Mason::Compiler subclass',
interp_params => { compiler_class => 'HTML::Mason::Compiler::ToObject::Test',
use_object_files => 0,
baz_val => 75 },
component => <<'EOF',
baz is !!BAZ!!
EOF
expect => <<'EOF',
baz is 75
EOF
);
#------------------------------------------------------------
return $group;
}
HTML-Mason-1.52/t/PaxHeader/17-print.t 000444 777777 777777 00000000212 12225201111 017300 x ustar 00jonswart 000000 000000 18 gid=1896053708
17 uid=512269995
20 ctime=1381302857
20 atime=1381302857
23 SCHILY.dev=16777220
22 SCHILY.ino=6246792
18 SCHILY.nlink=1
HTML-Mason-1.52/t/17-print.t 000444 « q{Μ00000002377 12225201111 016273 0 ustar 00jonswart 000000 000000 use strict;
use Cwd;
use File::Spec;
use HTML::Mason::Tests;
print "1..9\n";
my $comp_root = File::Spec->catdir( getcwd(), 'mason_tests', 'comps' );
($comp_root) = $comp_root =~ /(.*)/;
my $data_dir = File::Spec->catdir( getcwd(), 'mason_tests', 'data' );
($data_dir) = $data_dir =~ /(.*)/;
my $tests = HTML::Mason::Tests->tests_class->new( name => 'print',
description => 'printing to standard output' );
my $interp = HTML::Mason::Tests->tests_class->_make_interp
( comp_root => $comp_root,
data_dir => $data_dir
);
{
my $source = <<'EOF';
ok 1
% print "ok 2\n";
EOF
my $comp = $interp->make_component( comp_source => $source );
my $req = $interp->make_request(comp=>$comp);
$req->exec();
}
# same stuff but with autoflush
{
my $source = <<'EOF';
ok 3
% print "ok 4\n";
EOF
my $comp = $interp->make_component( comp_source => $source );
my $req = $interp->make_request( comp=>$comp, autoflush => 1 );
$req->exec();
}
{
my $source = <<'EOF';
ok 5
% print "ok 6\n";
ok 7
% print "ok 8\n";
% print "", "ok ", "9", "\n";
EOF
my $comp = $interp->make_component( comp_source => $source );
my $req = $interp->make_request( comp=>$comp );
$req->exec();
}
HTML-Mason-1.52/t/PaxHeader/18-leak.t 000644 777777 777777 00000000212 12225201111 017063 x ustar 00jonswart 000000 000000 18 gid=1896053708
17 uid=512269995
20 ctime=1381302857
20 atime=1381302857
23 SCHILY.dev=16777220
22 SCHILY.ino=6246793
18 SCHILY.nlink=1
HTML-Mason-1.52/t/18-leak.t 000644 « q{Μ00000017457 12225201111 016063 0 ustar 00jonswart 000000 000000 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");
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;
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;
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");
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;
<%def .def>
This is a def
<%method method>
This is a 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");
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;
|;
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");
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");
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.52/t/PaxHeader/19-subrequest.t 000644 777777 777777 00000000212 12225201111 020352 x ustar 00jonswart 000000 000000 18 gid=1896053708
17 uid=512269995
20 ctime=1381302857
20 atime=1381302857
23 SCHILY.dev=16777220
22 SCHILY.ino=6246794
18 SCHILY.nlink=1
HTML-Mason-1.52/t/19-subrequest.t 000644 « q{Μ00000026755 12225201111 017353 0 ustar 00jonswart 000000 000000 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";
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
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
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
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.52/t/PaxHeader/20-plugins.t 000644 777777 777777 00000000212 12225201111 017621 x ustar 00jonswart 000000 000000 18 gid=1896053708
17 uid=512269995
20 ctime=1381302857
20 atime=1381302857
23 SCHILY.dev=16777220
22 SCHILY.ino=6246795
18 SCHILY.nlink=1
HTML-Mason-1.52/t/20-plugins.t 000644 « q{Μ00000045326 12225201111 016615 0 ustar 00jonswart 000000 000000 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;
<%def .six><%perl>return 6;
% 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>capitalizedI will be <& .something &>',
expect => <<'EOF',
I WILL BE CAPITALIZED
EOF
);
return $group;
}
HTML-Mason-1.52/t/PaxHeader/21-escapes.t 000644 777777 777777 00000000212 12225201111 017564 x ustar 00jonswart 000000 000000 18 gid=1896053708
17 uid=512269995
20 ctime=1381302857
20 atime=1381302857
23 SCHILY.dev=16777220
22 SCHILY.ino=6246796
18 SCHILY.nlink=1
HTML-Mason-1.52/t/21-escapes.t 000644 « q{Μ00000001405 12225201111 016546 0 ustar 00jonswart 000000 000000 use strict;
use warnings;
use Test::More;
use HTML::Mason::Escapes;
plan tests => 3;
my $html = qq|<>"& \x{2202}|;
HTML::Mason::Escapes::basic_html_escape( \$html );
is( $html, "<>"& \x{2202}",
'test basic HTML escape' );
SKIP:
{
skip 'HTML::Entities does not escape utf8 properly under Perl < 5.8', 1
if $] < 5.008;
# Perl 5.6.2 totally borks this, thought it's probably just be a
# bug in HTML::Entities
my $html2 = qq|<>"& \x{2202}\x{20a5}|;
HTML::Mason::Escapes::html_entities_escape( \$html2 );
is( $html2, "<>"& ∂₥",
'test HTML::Entities escape' );
}
my $url = qq|"=\x{2202}|;
HTML::Mason::Escapes::url_escape( \$url );
is( $url, '%22%3D%E2%88%82',
'test url escape' );
HTML-Mason-1.52/t/PaxHeader/22-path-security.t 000644 777777 777777 00000000212 12225201111 020743 x ustar 00jonswart 000000 000000 18 gid=1896053708
17 uid=512269995
20 ctime=1381302857
20 atime=1381302857
23 SCHILY.dev=16777220
22 SCHILY.ino=6246797
18 SCHILY.nlink=1
HTML-Mason-1.52/t/22-path-security.t 000644 « q{Μ00000000663 12225201111 017732 0 ustar 00jonswart 000000 000000 use strict;
use warnings;
use Test::More;
BEGIN
{
unless ( -f '/etc/passwd' )
{
plan skip_all => 'This test requires that /etc/passwd exist.';
}
}
plan tests => 1;
use HTML::Mason::Resolver::File;
my $resolver = HTML::Mason::Resolver::File->new();
my $source = $resolver->get_info( '/../../../../../../etc/passwd', 'MAIN', '/var/cache' );
ok( ! $source, 'Cannot get at /etc/passwd with bogus comp path' );
HTML-Mason-1.52/t/PaxHeader/23-leak2.t 000644 777777 777777 00000000212 12225201111 017141 x ustar 00jonswart 000000 000000 18 gid=1896053708
17 uid=512269995
20 ctime=1381302857
20 atime=1381302857
23 SCHILY.dev=16777220
22 SCHILY.ino=6246798
18 SCHILY.nlink=1
HTML-Mason-1.52/t/23-leak2.t 000644 « q{Μ00000007123 12225201111 016126 0 ustar 00jonswart 000000 000000 use strict;
use warnings;
use File::Spec;
use File::Temp qw( tempdir );
use Test::More;
use HTML::Mason::Interp;
BEGIN
{
unless ( eval { require Test::Memory::Cycle;
Test::Memory::Cycle->import(); 1 } )
{
plan skip_all => 'These tests require Test::Memory::Cycle to run.';
}
}
plan tests => 8;
SIMPLE_OBJECTS:
{
my $interp = HTML::Mason::Interp->new( out_method => sub {} );
memory_cycle_ok( $interp, 'Interp before making a request' );
my $comp = $interp->make_component( comp_source => 'Comp' );
$interp->exec( $comp, foo => 1 );
memory_cycle_ok( $interp, 'Interp after making a request with in-memory comp' );
}
our $Destroyed = 0;
COMP_ON_DISK:
{
my $dir = tempdir( CLEANUP => 1 );
make_comp( $dir, 'comp1', <<'EOF' );
This is component 1.
<&| comp2, object => $object &>
content
<%args>
$object
EOF
make_comp( $dir, 'comp2', <<'EOF' );
This is component 2.
EOF
my $interp = HTML::Mason::Interp->new( out_method => sub {},
comp_root => $dir,
);
$interp->exec( '/comp1', object => Object->new() );
memory_cycle_ok( $interp, 'Interp after making a request with on-disk comp' );
is( $Destroyed, 1, 'object passed into request was destroyed' );
my $req = $interp->make_request( comp => '/comp1', args => [ object => Object->new() ] );
memory_cycle_ok( $req, 'Request object' );
undef $req;
is( $Destroyed, 2, 'object passed into make_request was destroyed' );
}
# See http://marc.theaimsgroup.com/?l=mason&m=115883578111647&w=2 for
# details.
OBJECTS_CREATED_IN_COMP:
{
my $dir = tempdir( CLEANUP => 1 );
make_comp( $dir, 'comp1', <<'EOF' );
<& /comp2, object => Object->new() &>
Destroyed: <% Object->DestroyCount() %>
EOF
make_comp( $dir, 'comp2', 'Comp 2' );
my $output = '';
my $interp = HTML::Mason::Interp->new( out_method => \$output,
comp_root => $dir,
);
$Destroyed = 0;
$interp->exec('/comp1');
like( $output, qr/Destroyed: 1/,
'one object was destroyed in comp1' );
}
# See http://marc.theaimsgroup.com/?l=mason&m=111769803701028&w=2 for
# details. It actually has nothing to do with %ARGS, it's seems that
# anything referred to inside nested comp-with-content calls never
# gets destroyed.
TWO_COMP_WITH_CONTENT_CALLS:
{
my $dir = tempdir( CLEANUP => 1 );
make_comp( $dir, 'comp1', <<'EOF' );
<%init>
my $object = Object->new();
<&| .sub &>
%# <% $object %> - with this here the object doesn't leak!
<&| .sub &>
<% $object %>
else
<%def .sub>
<% $m->content() %>
EOF
my $output = '';
my $interp = HTML::Mason::Interp->new( out_method => sub {},
comp_root => $dir,
);
$Destroyed = 0;
$interp->exec('/comp1');
# See
# http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2006-10/msg00189.html
# for further details.
local $TODO = 'This seems to be a bug in Perl (< 5.10.0), not Mason.'
if $] < 5.010000;
is( $Destroyed, 1, 'object was destroyed - 2 layers of comp-with-content' );
}
sub make_comp
{
my $dir = shift;
my $file = shift;
my $content = shift;
open my $fh, '>', File::Spec->catfile( $dir, $file )
or die $!;
print $fh $content
or die $!;
close $fh;
}
package Object;
sub new { return bless {}, $_[0] }
sub DESTROY { $Destroyed++ }
sub DestroyCount { $Destroyed }
HTML-Mason-1.52/t/PaxHeader/24-tools.t 000644 777777 777777 00000000212 12225201111 017304 x ustar 00jonswart 000000 000000 18 gid=1896053708
17 uid=512269995
20 ctime=1381302857
20 atime=1381302857
23 SCHILY.dev=16777220
22 SCHILY.ino=6246799
18 SCHILY.nlink=1
HTML-Mason-1.52/t/24-tools.t 000644 « q{Μ00000000335 12225201111 016267 0 ustar 00jonswart 000000 000000 use strict;
use warnings;
use lib 't/lib';
use Test::More tests => 1;
use HTML::Mason::Tools ();
eval { HTML::Mason::Tools::load_pkg( 'LoadTest', 'Required package.' ) };
like( $@, qr/Can't locate Does.Not.Exist/ );
HTML-Mason-1.52/t/PaxHeader/25-flush-in-content.t 000644 777777 777777 00000000212 12225201111 021342 x ustar 00jonswart 000000 000000 18 gid=1896053708
17 uid=512269995
20 ctime=1381302857
20 atime=1381302857
23 SCHILY.dev=16777220
22 SCHILY.ino=6246800
18 SCHILY.nlink=1
HTML-Mason-1.52/t/25-flush-in-content.t 000644 « q{Μ00000002165 12225201111 020330 0 ustar 00jonswart 000000 000000 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',
$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.
<&| 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 %> \
<% $content |n %>\
\
<%init>
my $content = $m->content;
EOF
);
#------------------------------------------------------------
$group->add_support(
path => '/block',
component => <<'EOF',
EOF
);
return $group;
}
HTML-Mason-1.52/t/PaxHeader/25-log.t 000644 777777 777777 00000000212 12225201111 016726 x ustar 00jonswart 000000 000000 18 gid=1896053708
17 uid=512269995
20 ctime=1381302857
20 atime=1381302857
23 SCHILY.dev=16777220
22 SCHILY.ino=6246801
18 SCHILY.nlink=1
HTML-Mason-1.52/t/25-log.t 000644 « q{Μ00000004103 12225201111 015706 0 ustar 00jonswart 000000 000000 use strict;
use warnings;
use Test::More tests => 1;
use Log::Any::Test;
use Log::Any qw($log);
use Test::Deep;
use File::Temp qw(tempdir);
use File::Path;
use HTML::Mason::Interp;
sub write_file {
my ( $file, $content ) = @_;
open( my $fh, ">$file" );
$fh->print($content);
}
my $comp_root = tempdir( 'mason-log-t-XXXX', TMPDIR => 1, CLEANUP => 1 );
mkpath( "$comp_root/bar", 0, 0775 );
my $interp = HTML::Mason::Interp->new( comp_root => $comp_root );
write_file( "$comp_root/foo", "% \$m->log->debug('in foo');\n<& /bar/baz &>" );
write_file( "$comp_root/bar/baz", "% \$m->log->error('in bar/baz')" );
$interp->exec('/foo');
cmp_deeply(
$log->msgs,
[
{
category => 'HTML::Mason::Request',
level => 'debug',
message => 'top path is \'/foo\''
},
{
category => 'HTML::Mason::Request',
level => 'debug',
message => 'starting request for \'/foo\''
},
{
category => 'HTML::Mason::Request',
level => 'debug',
message => 'entering component \'/foo\' [depth 0]'
},
{
category => 'HTML::Mason::Component::foo',
level => 'debug',
message => 'in foo'
},
{
category => 'HTML::Mason::Request',
level => 'debug',
message => 'entering component \'/bar/baz\' [depth 1]'
},
{
category => 'HTML::Mason::Component::bar::baz',
level => 'error',
message => 'in bar/baz'
},
{
category => 'HTML::Mason::Request',
level => 'debug',
message => 'exiting component \'/bar/baz\' [depth 1]'
},
{
category => 'HTML::Mason::Request',
level => 'debug',
message => 'exiting component \'/foo\' [depth 0]'
},
{
category => 'HTML::Mason::Request',
level => 'debug',
message => 'finishing request for \'/foo\''
}
]
);
HTML-Mason-1.52/t/PaxHeader/99-pod.t 000644 777777 777777 00000000212 12225201111 016742 x ustar 00jonswart 000000 000000 18 gid=1896053708
17 uid=512269995
20 ctime=1381302857
20 atime=1381302857
23 SCHILY.dev=16777220
22 SCHILY.ino=6246802
18 SCHILY.nlink=1
HTML-Mason-1.52/t/99-pod.t 000644 « q{Μ00000000245 12225201111 015725 0 ustar 00jonswart 000000 000000 use strict;
use warnings;
use File::Spec;
use Test::More;
eval "use Test::Pod 1.20";
plan skip_all => "Test::Pod 1.20 not installed." if $@;
all_pod_files_ok();
HTML-Mason-1.52/t/PaxHeader/author-live 000775 777777 777777 00000000213 12225201111 017724 x ustar 00jonswart 000000 000000 18 gid=1896053708
17 uid=512269995
20 ctime=1381302857
20 atime=1381302857
23 SCHILY.dev=16777220
22 SCHILY.ino=6246814
19 SCHILY.nlink=13
HTML-Mason-1.52/t/author-live/ 000775 « q{Μ00000000000 12225201111 016757 5 ustar 00jonswart 000000 000000 HTML-Mason-1.52/t/PaxHeader/lib 000775 777777 777777 00000000212 12225201111 016232 x ustar 00jonswart 000000 000000 18 gid=1896053708
17 uid=512269995
20 ctime=1381302857
20 atime=1381302857
23 SCHILY.dev=16777220
22 SCHILY.ino=6246807
18 SCHILY.nlink=6
HTML-Mason-1.52/t/lib/ 000775 « q{Μ00000000000 12225201111 015266 5 ustar 00jonswart 000000 000000 HTML-Mason-1.52/t/PaxHeader/run_one_test 000555 777777 777777 00000000212 12225201111 020164 x ustar 00jonswart 000000 000000 18 gid=1896053708
17 uid=512269995
20 ctime=1381302857
20 atime=1381302857
23 SCHILY.dev=16777220
22 SCHILY.ino=6246803
18 SCHILY.nlink=1
HTML-Mason-1.52/t/run_one_test 000555 « q{Μ00000000047 12225201111 017147 0 ustar 00jonswart 000000 000000 #!/bin/bash
/usr/bin/perl -I../lib $*
HTML-Mason-1.52/t/PaxHeader/run_tests 000555 777777 777777 00000000212 12225201111 017506 x ustar 00jonswart 000000 000000 18 gid=1896053708
17 uid=512269995
20 ctime=1381302857
20 atime=1381302857
23 SCHILY.dev=16777220
22 SCHILY.ino=6246804
18 SCHILY.nlink=1
HTML-Mason-1.52/t/run_tests 000555 « q{Μ00000000275 12225201111 016474 0 ustar 00jonswart 000000 000000 #!/bin/bash
PERL_DL_NONLAZY=1 find . -type f -name "*.t" | sort | egrep -v '08-ah|12-taint|16-live_cgi' | xargs /usr/bin/perl -I../lib -e 'use Test::Harness qw(&runtests); runtests @ARGV;'
HTML-Mason-1.52/t/PaxHeader/single_test.pl 000555 777777 777777 00000000212 12225201111 020412 x ustar 00jonswart 000000 000000 18 gid=1896053708
17 uid=512269995
20 ctime=1381302857
20 atime=1381302857
23 SCHILY.dev=16777220
22 SCHILY.ino=6246805
18 SCHILY.nlink=1
HTML-Mason-1.52/t/single_test.pl 000555 « q{Μ00000000462 12225201111 017376 0 ustar 00jonswart 000000 000000 #!/usr/bin/perl
use strict;
foreach (@ARGV) {
$ENV{MASON_NO_CLEANUP} = 1;
my @command = (-e 'Build' ?
('Build', 'test', "test_files=$_", 'verbose=1') :
('make', 'test', "TEST_FILES=$_", 'TEST_VERBOSE=1')
);
print "@command\n";
system @command;
}
HTML-Mason-1.52/t/PaxHeader/taint.comp 000444 777777 777777 00000000212 12225201111 017531 x ustar 00jonswart 000000 000000 18 gid=1896053708
17 uid=512269995
20 ctime=1381302857
20 atime=1381302857
23 SCHILY.dev=16777220
22 SCHILY.ino=6246806
18 SCHILY.nlink=1
HTML-Mason-1.52/t/taint.comp 000444 « q{Μ00000000320 12225201111 016506 0 ustar 00jonswart 000000 000000 <%perl>
$m->print('part2');
<%args>
$foo => 1
$bar
hey there
% my $x = 1;
<%perl>
$m->print($x++) while $x < 100;
<%def .foo>
lalalalalala
<%method foo>
foobar
HTML-Mason-1.52/t/lib/PaxHeader/Apache 000775 777777 777777 00000000212 12225201111 017413 x ustar 00jonswart 000000 000000 18 gid=1896053708
17 uid=512269995
20 ctime=1381302857
20 atime=1381302857
23 SCHILY.dev=16777220
22 SCHILY.ino=6246810
18 SCHILY.nlink=3
HTML-Mason-1.52/t/lib/Apache/ 000775 « q{Μ00000000000 12225201111 016447 5 ustar 00jonswart 000000 000000 HTML-Mason-1.52/t/lib/PaxHeader/BadModule.pm 000444 777777 777777 00000000212 12225201111 020472 x ustar 00jonswart 000000 000000 18 gid=1896053708
17 uid=512269995
20 ctime=1381302857
20 atime=1381302857
23 SCHILY.dev=16777220
22 SCHILY.ino=6246808
18 SCHILY.nlink=1
HTML-Mason-1.52/t/lib/BadModule.pm 000444 « q{Μ00000000026 12225201111 017452 0 ustar 00jonswart 000000 000000 package BadModule;
(
HTML-Mason-1.52/t/lib/PaxHeader/LoadTest.pm 000444 777777 777777 00000000212 12225201111 020355 x ustar 00jonswart 000000 000000 18 gid=1896053708
17 uid=512269995
20 ctime=1381302857
20 atime=1381302857
23 SCHILY.dev=16777220
22 SCHILY.ino=6246809
18 SCHILY.nlink=1
HTML-Mason-1.52/t/lib/LoadTest.pm 000444 « q{Μ00000000072 12225201111 017336 0 ustar 00jonswart 000000 000000 package LoadTest;
use Does::Not::Exist;
sub new {}
1;
HTML-Mason-1.52/t/lib/PaxHeader/Mason 000775 777777 777777 00000000212 12225201111 017307 x ustar 00jonswart 000000 000000 18 gid=1896053708
17 uid=512269995
20 ctime=1381302857
20 atime=1381302857
23 SCHILY.dev=16777220
22 SCHILY.ino=6246812
18 SCHILY.nlink=3
HTML-Mason-1.52/t/lib/Mason/ 000775 « q{Μ00000000000 12225201111 016343 5 ustar 00jonswart 000000 000000 HTML-Mason-1.52/t/lib/Mason/PaxHeader/ApacheTest.pm 000444 777777 777777 00000000212 12225201111 021734 x ustar 00jonswart 000000 000000 18 gid=1896053708
17 uid=512269995
20 ctime=1381302857
20 atime=1381302857
23 SCHILY.dev=16777220
22 SCHILY.ino=6246813
18 SCHILY.nlink=1
HTML-Mason-1.52/t/lib/Mason/ApacheTest.pm 000444 « q{Μ00000066577 12225201111 020743 0 ustar 00jonswart 000000 000000 package Mason::ApacheTest;
use strict;
use warnings;
use Apache::test qw( have_httpd have_module );
use File::Basename qw( dirname );
use File::Path qw( mkpath rmtree );
use File::Spec;
use Module::Build;
use Test::More;
use lib 'inc';
use base 'Exporter';
our @EXPORT_OK = qw( require_libapreq require_cgi require_apache_filter chmod_data_dir );
my $TestConfig;
INIT
{
$TestConfig = Module::Build->current()->notes()->{apache_test_conf};
unless ( $TestConfig
&& defined $TestConfig->{apache_dir}
&& -d $TestConfig->{apache_dir} )
{
plan skip_all =>
'$TestConfig->{is_maintainer} is not true or '
. '$TestConfig->{apache_dir} is not a directory';
}
unless ( have_httpd() )
{
plan skip_all => 'Apache::test::have_httpd() returned a false value';
}
}
sub require_libapreq
{
my $version = _apache_version();
my $module = $version == 1 ? 'Apache::Request' : 'Apache2::Request';
unless ( eval "use $module; 1" )
{
plan skip_all => "These tests require the $module module.";
}
}
sub require_cgi
{
unless ( eval 'use CGI 3.08; 1' )
{
plan skip_all => 'These tests required CGI.pm 3.08 or greater.';
}
}
sub require_apache_filter
{
my $version = _apache_version();
unless ( eval 'use Apache::Filter; 1' && $version == 1 )
{
plan skip_all => 'These tests required Apache::Filter and mod_perl 1.';
}
}
sub _apache_version
{
my $apache_bin = _apache_bin();
my ($version) = `$apache_bin -v` =~ m{version: Apache/(\d)};
die "Could not determine Apache version"
unless $version;
return $version;
}
sub _apache_bin
{
return File::Spec->catfile( $TestConfig->{apache_dir}, 'httpd' );
}
sub chmod_data_dir
{
# This is a hack but otherwise the multi-conf tests fail if the
# Apache server runs as any user other than root. In real life, a
# user using the multi-config option with httpd.conf must handle
# the file permissions manually.
if ( $> == 0 || $< == 0 )
{
chmod 0777, File::Spec->catdir( $TestConfig->{apache_dir}, 'data' );
}
}
sub run_tests
{
my $class = shift;
my %p = @_;
# Needed for Apache::test->fetch() to work
local $ENV{PORT} = $TestConfig->{port};
_write_test_comps();
my @tests = $class->_tests(%p);
my $count = 0;
$count++ for grep { $_->{expect} || $_->{regex} } @tests;
$count++ for map { $_->{extra} ? @{ $_->{extra} } : () } @tests;
plan tests => $count;
_kill_httpd();
_start_httpd( $p{apache_define} );
_cleanup_data_dir();
_run_test( \%p, $_ ) for @tests;
_kill_httpd();
}
sub _write_test_comps
{
_write_comp( 'basic', <<'EOF',
Basic test.
2 + 2 = <% 2 + 2 %>.
uri = <% $r->uri =~ /basic$/ ? '/basic' : $r->uri %>.
method = <% $r->method %>.
EOF
);
_write_comp( 'headers', <<'EOF',
% $r->headers_out->{'X-Mason-Test'} = 'New value 2';
Blah blah
blah
% $r->headers_out->{'X-Mason-Test'} = 'New value 3';
<%init>
$r->headers_out->{'X-Mason-Test'} = 'New value 1';
$m->abort if $blank;
<%args>
$blank=>0
EOF
);
_write_comp( 'cgi_object', <<'EOF',
<% UNIVERSAL::isa(eval { $m->cgi_object } || undef, 'CGI') ? 'CGI' : 'NO CGI' %><% $@ || '' %>
EOF
);
_write_comp( 'params', <<'EOF',
% foreach (sort keys %ARGS) {
<% $_ %>: <% ref $ARGS{$_} ? join ', ', sort @{ $ARGS{$_} }, 'array' : $ARGS{$_} %>
% }
EOF
);
_write_comp( '_underscore', <<'EOF',
I am underscore.
EOF
);
_write_comp( 'die', <<'EOF',
% die 'Mine heart is pierced';
EOF
);
_write_comp( 'apache_request', <<'EOF',
% if ($r->isa('Apache::Request') || $r->isa('Apache2::Request')) {
Apache::Request
% }
EOF
);
_write_comp( 'multiconf1/foo', <<'EOF',
I am foo in multiconf1
comp root is <% $m->interp->comp_root =~ m,/comps/multiconf1$, ? 'multiconf1' : $m->interp->comp_root %>
EOF
);
_write_comp( 'multiconf1/autohandler', <<'EOF'
<& $m->fetch_next, autohandler => 'present' &>
EOF
);
_write_comp( 'multiconf1/autohandler_test', <<'EOF'
<%args>
$autohandler => 'misnamed'
autohandler is <% $autohandler %>
EOF
);
_write_comp( 'multiconf2/foo', <<'EOF',
I am foo in multiconf2
comp root is <% $m->interp->comp_root =~ m,/comps/multiconf2$, ? 'multiconf2' : $m->interp->comp_root %>
EOF
);
_write_comp( 'multiconf2/dhandler', <<'EOF',
This should not work
EOF
);
_write_comp( 'allow_globals', <<'EOF',
% $foo = 1;
% @bar = ( qw( a b c ) );
$foo is <% $foo %>
@bar is <% @bar %>
EOF
);
_write_comp( 'decline_dirs', <<'EOF',
decline_dirs is <% $m->ah->decline_dirs %>
EOF
);
_write_comp( 'with_dhandler/dhandler', <<'EOF',
% $r->content_type('text/html');
with a dhandler
EOF
);
_write_comp( 'with_dhandler_no_ct/dhandler', <<'EOF',
with a dhandler, no content type
EOF
);
_write_comp( 'print', <<'EOF',
This is first.
% print "This is second.\n";
This is third.
EOF
);
_write_comp( 'r_print', <<'EOF',
This is first.
% $r->print("This is second.\n");
This is third.
EOF
);
_write_comp( 'flush_buffer', <<'EOF',
% $m->print("foo\n");
% $m->flush_buffer;
bar
EOF
);
_write_comp( 'head_request', <<'EOF',
<%init>
my $x = 1;
foreach (sort keys %ARGS) {
$r->headers_out->{'X-Mason-HEAD-Test' . $x++} = "$_: " . (ref $ARGS{$_} ? 'is a ref' : 'not a ref' );
}
We should never see this.
EOF
);
_write_comp( 'redirect', <<'EOF',
% $m->print("\n"); # leading whitespace
<%perl>
$m->scomp('foo');
$m->redirect('/comps/basic');
<%def foo>
fum
EOF
);
_write_comp( 'internal_redirect', <<'EOF',
<%init>
if ($mod_perl2::VERSION >= 1.99) { require Apache2::SubRequest; }
$r->internal_redirect('/comps/internal_redirect_target?foo=17');
$m->auto_send_headers(0);
$m->clear_buffer;
$m->abort;
EOF
);
_write_comp( 'subrequest', <<'EOF',
<%init>
# tests can run under various comp_root settings
my $comp_root = $m->interp->comp_root;
$comp_root = $$comp_root[0][1] if ref $comp_root;
my $comp = $comp_root =~ m/comps/ ? '/internal_redirect_target' : '/comps/internal_redirect_target';
$m->clear_buffer;
my $sub = $m->make_subrequest(comp => $comp, args=> [ foo => 17 ]);
$sub->exec;
$m->flush_buffer;
$m->abort(200);
EOF
);
_write_comp( 'internal_redirect_target', <<'EOF',
The number is <% $foo %>.
<%args>
$foo
EOF
);
_write_comp( 'error_as_html', <<'EOF',
% my $x =
EOF
);
_write_comp( 'interp_class', <<'EOF',
Interp class: <% ref $m->interp %>
EOF
);
_write_comp( 'old_html_escape', <<'EOF',
<% '<>' | old_h %>
EOF
);
_write_comp( 'old_html_escape2', <<'EOF',
<% '<>' | old_h2 %>
EOF
);
_write_comp( 'uc_escape', <<'EOF',
<% 'upper case' | uc %>
EOF
);
_write_comp( 'data_cache_defaults', <<'EOF',
is memory: <% $m->cache->isa('Cache::MemoryCache') ? 1 : 0 %>
namespace: <% $m->cache->get_namespace %>
EOF
);
_write_comp( 'test_code_param', <<'EOF',
preprocess changes lc fooquux to FOOQUUX
EOF
);
_write_comp( 'explicitly_send_header', <<'EOF',
Sending headers in this comp.
<%perl>
$r->send_http_header() if $r->can('send_http_header');
EOF
);
_write_comp( 'cgi_foo_param', <<'EOF',
CGI foo param is <% $r->query->param('foo') %>
EOF
);
_write_comp( 'abort_with_ok', <<'EOF',
All is well
% $m->abort(200);
Will not be seen
EOF
);
_write_comp( 'abort_with_not_ok', <<'EOF',
All is well
% $m->abort(500);
Will not be seen
EOF
);
_write_comp( 'cgi_dh/dhandler', <<'EOF' );
dhandler
dhandler_arg = <% $m->dhandler_arg %>
EOF
_write_comp( 'cgi_dh/file', <<'EOF' );
file
dhandler_arg = <% $m->dhandler_arg %>
path_info = <% $ENV{PATH_INFO} %>
EOF
_write_comp( 'cgi_dh/dir/file', '' );
}
sub _write_comp
{
my $name = shift;
my $comp = shift;
my $file = File::Spec->catfile( $TestConfig->{apache_dir}, 'comps', $name );
my $dir = dirname($file);
mkpath( $dir, 0, 0755 ) unless -d $dir;
open my $fh, '>',$file
or die "Can't write to '$file': $!";
print $fh $comp;
close $fh;
}
sub _start_httpd
{
my $def = shift;
$def = "-D$def" if $def;
my $httpd = _apache_bin();
my $conf_file = File::Spec->catfile( $TestConfig->{apache_dir}, 'conf', 'httpd.conf' );
my $pid_file = File::Spec->catfile( $TestConfig->{apache_dir}, 'logs', 'httpd.pid' );
my $cmd ="$httpd $def -f $conf_file";
diag( "Executing $cmd" );
system ($cmd)
and die "Can't start httpd server as '$cmd': $!";
diag( "Waiting 10 seconds for httpd to start." );
my $x = 0;
until ( -e $pid_file )
{
sleep (1);
$x++;
if ( $x > 10 )
{
die "No $pid_file file has appeared after 10 seconds. ",
"There is probably a problem with the configuration file that was generated for these tests.";
}
}
}
sub _kill_httpd
{
my $pid_file = File::Spec->catfile( $TestConfig->{apache_dir}, 'logs', 'httpd.pid' );
return unless -e $pid_file;
my $pid = _get_pid();
diag( "Killing httpd process ($pid)" );
my $result = kill 'TERM', $pid;
if ( ! $result and $! =~ /no such (?:file|proc)/i )
{
# Looks like apache wasn't running, so we're done
unlink $pid_file
or warn "Couldn't remove $pid_file: $!";
return;
}
die "Can't kill process $pid: $!" unless $result;
diag( "Waiting up to 10 seconds for httpd to shut down" );
my $x = 0;
while ( -e $pid_file )
{
sleep (1);
$x++;
if ( $x > 1 )
{
$result = kill 'TERM', $pid;
if ( ! $result and $! =~ /no such (?:file|proc)/i )
{
# Looks like apache wasn't running, so we're done
if ( -e $pid_file )
{
unlink $pid_file
or warn "Couldn't remove $pid_file: $!";
}
return;
}
}
die "$pid_file file still exists after 10 seconds. Exiting."
if $x > 10;
}
}
sub _get_pid
{
my $pid_file = File::Spec->catfile( $TestConfig->{apache_dir}, 'logs', 'httpd.pid' );
open my $fh, '<', $pid_file
or die "Can't open $pid_file: $!";
my $pid = <$fh>;
close $fh;
chomp $pid;
return $pid;
}
# by wiping out the subdirectories here we can catch permissions
# issues if some of the tests can't write to the data dir.
sub _cleanup_data_dir
{
return if $ENV{MASON_NO_CLEANUP};
my $dir = File::Spec->catdir( $TestConfig->{apache_dir}, 'data' );
opendir my $dh, $dir
or die "Can't open $dir dir: $!";
foreach ( grep { -d File::Spec->catdir( $dir, $_ ) && $_ !~ /^\./ } readdir $dh )
{
rmtree( File::Spec->catdir( $TestConfig->{apache_dir}, 'data', $_ ) );
}
closedir $dh;
}
sub _tests
{
my $class = shift;
my %p = @_;
my @sets = @{ $p{test_sets} };
my @tests;
for my $set (@sets)
{
my $meth = q{_} . $set . '_tests';
push @tests, $class->$meth(%p);
my $addl_meth =
$p{with_handler}
? q{_} . $set . '_with_handler_tests'
: q{_} . $set . '_no_handler_tests';
push @tests, $class->$addl_meth(%p)
if $class->can($addl_meth);
}
return @tests;
}
sub _standard_tests
{
shift;
my %p = @_;
my @tests =
( { path => '/comps/basic',
expect => <<'EOF',
X-Mason-Test: Initial value
Basic test.
2 + 2 = 4.
uri = /basic.
method = GET.
Status code: 0
EOF
extra =>
[ sub { my $response = shift;
unlike( $response->content, qr{HTTP/1\.1},
'the response for a good component should not contain headers in the body' ); },
],
},
{ path => '/comps/headers',
expect => <<'EOF',
X-Mason-Test: New value 3
Blah blah
blah
Status code: 0
EOF
},
{ path => '/comps/headers?blank=1',
expect => <<'EOF',
X-Mason-Test: New value 1
Status code: 0
EOF
},
{ path => '/comps/_underscore',
expect => <<'EOF',
X-Mason-Test: Initial value
I am underscore.
Status code: 0
EOF
},
{ path => '/comps/die',
regex => qr{error.*Mine heart is pierced}s,
},
{ path => '/comps/params?qs1=foo&qs2=bar&foo=A&foo=B',
expect => <<'EOF',
X-Mason-Test: Initial value
foo: A, B, array
qs1: foo
qs2: bar
Status code: 0
EOF
},
{ path => '/comps/params',
post => { post1 => 'foo',
post2 => 'bar',
foo => [ 'A', 'B' ],
},
expect => <<'EOF',
X-Mason-Test: Initial value
foo: A, B, array
post1: foo
post2: bar
Status code: 0
EOF
},
{ path => '/comps/params?qs1=foo&qs2=bar&mixed=A',
post => { post1 => 'a',
post2 => 'b',
mixed => 'B',
},
expect => <<'EOF',
X-Mason-Test: Initial value
mixed: A, B, array
post1: a
post2: b
qs1: foo
qs2: bar
Status code: 0
EOF
},
{ path => '/comps/print',
expect => <<'EOF',
X-Mason-Test: Initial value
This is first.
This is second.
This is third.
Status code: 0
EOF
},
{ path => '/comps/r_print',
expect => <<'EOF',
X-Mason-Test: Initial value
This is first.
This is second.
This is third.
Status code: 0
EOF
},
{ path => '/comps/flush_buffer',
expect => <<'EOF',
X-Mason-Test: Initial value
foo
bar
Status code: 0
EOF
},
{ path => '/comps/redirect',
expect => <<'EOF',
X-Mason-Test: Initial value
Basic test.
2 + 2 = 4.
uri = /basic.
method = GET.
Status code: 0
EOF
},
{ path => '/comps/internal_redirect',
expect => <<'EOF',
X-Mason-Test: Initial value
The number is 17.
Status code: 0
EOF
},
{ path => '/comps/subrequest',
expect => <<'EOF',
X-Mason-Test: Initial value
The number is 17.
Status code: 0
EOF
},
{ path => '/comps/error_as_html',
regex => qr{error:.*Error during compilation}s,
extra =>
[ sub { my $response = shift;
unlike( $response->content, qr{HTTP/1\.1},
'the response for a compilation error should not contain headers in the body' ); },
],
},
{ path => '/comps/explicitly_send_header',
expect => <<'EOF',
X-Mason-Test: Initial value
Sending headers in this comp.
Status code: 0
EOF
},
);
my $expected_class = $p{with_handler} ? 'My::Interp' : 'HTML::Mason::Interp';
push @tests, { path => '/comps/interp_class',
expect => <<"EOF",
X-Mason-Test: Initial value
Interp class: $expected_class
Status code: 0
EOF
};
return @tests;
}
sub _standard_with_handler_tests
{
shift;
my %p = @_;
return ( { path => '/ah=1/comps/headers',
expect => <<'EOF',
X-Mason-Test: New value 1
Blah blah
blah
Status code: 0
EOF
},
{ path => '/ah=1/comps/headers?blank=1',
expect => <<'EOF',
X-Mason-Test: New value 1
Status code: 0
EOF
},
{ path => '/ah=3/comps/die',
# error_mode is fatal so we just get a 500
regex => qr{500 Internal Server Error},
},
{ path => '/ah=1/comps/print',
expect => <<'EOF',
X-Mason-Test: Initial value
This is first.
This is second.
This is third.
Status code: 0
EOF
},
{ path => '/ah=1/comps/r_print',
expect => <<'EOF',
X-Mason-Test: Initial value
This is first.
This is second.
This is third.
Status code: 0
EOF
},
{ path => '/ah=1/comps/flush_buffer',
expect => <<'EOF',
X-Mason-Test: Initial value
foo
bar
Status code: 0
EOF
},
);
}
sub _apache_request_tests
{
shift;
my %p = @_;
return ( { path => '/comps/apache_request',
expect => <<'EOF',
X-Mason-Test: Initial value
Apache::Request
Status code: 0
EOF
},
);
}
sub _apache_request_with_handler_tests
{
shift;
my %p = @_;
return ( { path => '/ah=4/comps/apache_request',
expect => <<'EOF',
X-Mason-Test: Initial value
Status code: 0
EOF
},
);
}
sub _apache_request_no_handler_tests
{
shift;
my %p = @_;
return ( { path => '/comps/decline_dirs',
expect => <<'EOF',
X-Mason-Test: Initial value
decline_dirs is 0
Status code: 0
EOF
},
{ path => '/comps/old_html_escape',
expect => <<'EOF',
X-Mason-Test: Initial value
<>
Status code: 0
EOF
},
{ path => '/comps/old_html_escape2',
expect => <<'EOF',
X-Mason-Test: Initial value
<>
Status code: 0
EOF
},
{ path => '/comps/uc_escape',
expect => <<'EOF',
X-Mason-Test: Initial value
UPPER CASE
Status code: 0
EOF
},
{ path => '/comps/data_cache_defaults',
expect => <<'EOF',
X-Mason-Test: Initial value
is memory: 1
namespace: foo
Status code: 0
EOF
},
{ path => '/comps/test_code_param',
expect => <<"EOF",
X-Mason-Test: Initial value
preprocess changes lc FOOQUUX to FOOQUUX
Status code: 0
EOF
},
{ path => '/comps/with_dhandler/',
expect => <<"EOF",
X-Mason-Test: Initial value
with a dhandler
Status code: 0
EOF
},
);
}
sub _cgi_tests
{
shift;
my %p = @_;
return ( { path => '/comps/cgi_object',
expect => <<'EOF',
X-Mason-Test: Initial value
CGI
Status code: 0
EOF
},
{ path => '/comps/head_request?foo=1&bar=1&bar=2',
method => 'HEAD',
expect => <<'EOF',
X-Mason-Test: Initial value
X-Mason-HEAD-Test1: bar: is a ref
X-Mason-HEAD-Test2: foo: not a ref
Status code: 0
EOF
},
);
}
sub _cgi_no_handler_tests
{
shift;
my %p = @_;
# tests that MasonAllowGlobals works with a list of params
# (testing a list parameter from httpd.conf)
return ( { path => '/comps/allow_globals',
expect => <<'EOF',
X-Mason-Test: Initial value
$foo is 1
@bar is abc
Status code: 0
EOF
},
);
}
sub _filter_tests
{
shift;
my %p = @_;
return ( { path => '/comps/basic',
expect => <<'EOF',
X-Mason-Test: Initial value
BASIC TEST.
2 + 2 = 4.
URI = /BASIC.
METHOD = GET.
Status code: 0
EOF
},
);
}
sub _set_content_type_tests
{
shift;
my %p = @_;
return ( { path => '/comps/basic',
extra =>
[ sub { my $response = shift;
is( $response->headers()->header('Content-Type'),
'text/html; charset=i-made-this-up',
'Content type set by handler is preserved by Mason' ); },
sub { my $response = shift;
unlike( $response->content(), qr/Content-Type:/i,
'response body does not contain a content-type header' ); },
],
},
{ path => '/comps/with_dhandler_no_ct/',
extra =>
[ sub { my $response = shift;
is( $response->headers()->header('Content-Type'),
'text/html; charset=i-made-this-up',
'Content type set by handler is preserved by Mason with directory request' ); },
sub { my $response = shift;
unlike( $response->content(), qr/Content-Type:/i,
'response body does not contain a content-type header with directory request' ); },
],
},
);
}
sub _multi_config_tests
{
shift;
my %p = @_;
return ( { path => '/comps/multiconf1/foo',
expect => <<'EOF',
X-Mason-Test: Initial value
I am foo in multiconf1
comp root is multiconf1
Status code: 0
EOF
},
{ path => '/comps/multiconf1/autohandler_test',
expect => <<'EOF',
X-Mason-Test: Initial value
autohandler is misnamed
Status code: 0
EOF
},
{ path => '/comps/multiconf2/foo',
expect => <<'EOF',
X-Mason-Test: Initial value
I am foo in multiconf2
comp root is multiconf2
Status code: 0
EOF
},
{ path => '/comps/multiconf2/dhandler_test',
regex => qr{404 not found}i,
},
{ path => '/perl-status',
regex => qr{HTML::Mason status},
},
);
}
sub _cgi_handler_tests
{
shift;
my %p = @_;
return ( { path => '/comps/basic',
unfiltered_response => 1,
expect => <<'EOF',
Basic test.
2 + 2 = 4.
uri = /basic.
method = GET.
EOF
},
{ path => '/comps/print',
unfiltered_response => 1,
expect => <<'EOF',
This is first.
This is second.
This is third.
EOF
},
{ path => '/comps/print/autoflush',
unfiltered_response => 1,
expect => <<'EOF',
This is first.
This is second.
This is third.
EOF
},
{ path => '/comps/print/handle_comp',
unfiltered_response => 1,
expect => <<'EOF',
This is first.
This is second.
This is third.
EOF
},
{ path => '/comps/print/handle_cgi_object',
unfiltered_response => 1,
expect => <<'EOF',
This is first.
This is second.
This is third.
EOF
},
{ path => '/comps/cgi_foo_param/handle_cgi_object',
unfiltered_response => 1,
expect => <<'EOF',
CGI foo param is bar
EOF
},
{ path => '/comps/redirect',
unfiltered_response => 1,
expect => <<'EOF',
Basic test.
2 + 2 = 4.
uri = /basic.
method = GET.
EOF
},
{ path => '/comps/params?qs1=foo&qs2=bar&mixed=A',
post => { post1 => 'a',
post2 => 'b',
mixed => 'B',
},
unfiltered_response => 1,
expect => <<'EOF',
mixed: A, B, array
post1: a
post2: b
qs1: foo
qs2: bar
EOF
},
{ path => '/comps/error_as_html',
regex => qr{error:.*Error during compilation}s,
},
{ path => '/comps/abort_with_ok',
unfiltered_response => 1,
expect => <<'EOF',
All is well
EOF
},
# XXX - does this test make any sense?
{ path => '/comps/abort_with_not_ok',
unfiltered_response => 1,
expect => <<'EOF',
All is well
EOF
},
{ path => '/comps/foo/will_decline',
# Having decline generate an error like this is bad,
# but there's not much else we can do without rewriting
# more of CGIHandler, which isn't a good idea for
# stable, methinks.
regex => qr{could not find component for initial path}is,
},
{ path => '/comps/cgi_dh/dir/extra/stuff',
unfiltered_response => 1,
expect => <<'EOF',
dhandler
dhandler_arg = dir/extra/stuff
EOF
},
{ path => '/comps/explicitly_send_header',
unfiltered_response => 1,
expect => <<'EOF',
Sending headers in this comp.
EOF
},
);
## CGIHandler.pm does not do this the same as ApacheHandler.pm
## but we do not want to rewrite CGIHandler in stable
#
# my $path = '/comps/cgi_dh/file/extra/stuff';
# my $response = Apache::test->fetch($path);
# expect => <<'EOF',
#file
#dhandler_arg =
#path_info = /extra/stuff
#EOF
}
sub _run_test
{
my $p = shift;
my $test = shift;
my $path = $test->{path}
or die "Test with no path!";
if ( $p->{with_handler} && $path !~ m{^/ah=\d/} )
{
$path = '/ah=0' . $path;
}
my %fetch_p = ( uri => $path );
if ( $test->{post} )
{
$fetch_p{method} = 'POST';
my $uri = URI->new();
$uri->query_form( $test->{post} );
$fetch_p{content} = $uri->query();
}
elsif ( $test->{method} )
{
$fetch_p{method} = $test->{method};
}
my $response = Apache::test->fetch( \%fetch_p );
my $output =
$test->{unfiltered_response}
? $response->content()
: _filter_response( $response, $p, $test );
_check_output( $output, $test );
if ( $test->{extra} )
{
$_->($response) for @{ $test->{extra} };
}
}
# We're not interested in headers that are always going to be
# different (like date or server type).
sub _filter_response
{
my $response = shift;
my $p = shift;
my $test = shift;
my $actual;
{
$actual = 'X-Mason-Test: ';
my $val;
# This is a nasty hack because some tests using a handler()
# sub are expected to always return this header, and others
# are not.
if ( $p->{with_handler} )
{
$val = $response->headers->header('X-Mason-Test');
}
else
{
$val = ( defined $response->headers->header('X-Mason-Test') ?
$response->headers->header('X-Mason-Test') :
'Initial value' );
}
$actual .= defined $val ? $val : '';
}
$actual .= "\n";
# Any headers starting with X-Mason are added, excluding
# X-Mason-Test, which is handled above
my @headers;
$response->headers->scan( sub { return if $_[0] eq 'X-Mason-Test' || $_[0] !~ /^X-Mason/;
push @headers, [ $_[0], $_[1] ] } );
foreach my $h ( sort { $a->[0] cmp $b->[0] } @headers )
{
$actual .= "$h->[0]: ";
$actual .= defined $h->[1] ? $h->[1] : '';
$actual .= "\n";
}
my $content = $response->content();
$actual .= $content if defined $content;
if ( ( $test->{method} && $test->{method} eq 'HEAD' ) || ! $p->{with_handler} )
{
my $code = $response->code() == 200 ? 0 : $response->code();
$actual .= "Status code: $code";
}
return $actual;
}
sub _check_output
{
my $output = shift;
my $test = shift;
my $desc = $test->{path};
$desc .= ' (post)' if $test->{post};
if ( $test->{expect} )
{
my $expect = $test->{expect};
for ( $output, $expect )
{
s/\s+$//s;
}
is( $output, $expect, $desc );
}
elsif ( $test->{regex} )
{
like( $output, $test->{regex},
"Regex test for $desc" );
}
elsif ( ! $test->{extra} )
{
die "No error, expect, or extra key provided for test ($test->{path})";
}
}
1;
HTML-Mason-1.52/t/lib/Apache/PaxHeader/test.pm 000444 777777 777777 00000000212 12225201111 020776 x ustar 00jonswart 000000 000000 18 gid=1896053708
17 uid=512269995
20 ctime=1381302857
20 atime=1381302857
23 SCHILY.dev=16777220
22 SCHILY.ino=6246811
18 SCHILY.nlink=1
HTML-Mason-1.52/t/lib/Apache/test.pm 000444 « q{Μ00000055065 12225201111 017773 0 ustar 00jonswart 000000 000000 package Apache::test;
use strict;
use vars qw(@EXPORT $USE_THREAD $USE_SFIO $PERL_DIR @EXPORT_OK);
use Exporter ();
use Config;
use FileHandle ();
*import = \&Exporter::import;
@EXPORT = qw(test fetch simple_fetch have_module skip_test
$USE_THREAD $USE_SFIO $PERL_DIR WIN32 grab run_test);
@EXPORT_OK = qw(have_httpd);
BEGIN {
if(not $ENV{MOD_PERL}) {
eval { require "net/config.pl"; }; #for 'make test'
$PERL_DIR = $net::perldir;
}
if ($net::httpserver) {
# Validate that the OS knows the name of the server in $net::httpserver
# if 'localhost' is not defined, the tests wouldn't pass
(my $hostname) = ($net::httpserver =~ /(.*?):/);
warn qq{\n*** [Crucial] You must define "$hostname" (e.g. in /etc/hosts) in order for 'make test' to pass\n}
unless gethostbyname $hostname;
}
}
$PERL_DIR = $ENV{PERL_DIR} if exists $ENV{PERL_DIR};
$USE_THREAD = ($Config{extensions} =~ /Thread/) || $Config{usethreads};
$USE_SFIO = (($Config{'usesfio'} || '') eq 'true');
my $Is_Win32 = ($^O eq "MSWin32");
sub WIN32 () { $Is_Win32 };
my $UA;
eval {
require LWP::UserAgent;
$UA = LWP::UserAgent->new;
};
unless (defined &Apache::bootstrap) {
*Apache::bootstrap = sub {};
*Apache::Constants::bootstrap = sub {};
}
sub write_httpd_conf {
my $pkg = shift;
my %args = (conf_file => 't/httpd.conf', @_);
my $DIR = `pwd`; chomp $DIR;
# Apache2 tweaks
my $Port = 'Port';
my $AccessConfig = 'AccessConfig /dev/null';
my $ResourceConfig = 'ResourceConfig /dev/null';
my $ScoreBoardFile = 'ScoreBoardFile /dev/null';
if ($args{version} =~ m/^2\./) {
$Port = 'Listen';
$AccessConfig = '';
$ResourceConfig = '';
$ScoreBoardFile = '';
}
local *CONF;
open CONF, ">$args{conf_file}" or die "Can't create $args{conf_file}: $!";
print CONF <
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%>
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.
$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.52/samples/PaxHeader/README 000644 777777 777777 00000000212 12225201111 017615 x ustar 00jonswart 000000 000000 18 gid=1896053708
17 uid=512269995
20 ctime=1381302857
20 atime=1381302857
23 SCHILY.dev=16777220
22 SCHILY.ino=6246764
18 SCHILY.nlink=1
HTML-Mason-1.52/samples/README 000644 « q{Μ00000001044 12225201111 016576 0 ustar 00jonswart 000000 000000 Component Samples
=================
dump-request Dumps request parameters, great for debugging.
Converted from Apache documentation.
show-env Dumps current environment.
Note: If you are seeing the source of the above pages as plain text,
it is because the server is assigning the content type "plain/text"
instead of "text/html". The easiest way to remedy this is to put
DefaultType text/html
in your configuration file, and make sure mod_mime_magic is not active.
This will allow filenames with no extensions to be handled by Mason.
HTML-Mason-1.52/samples/PaxHeader/show-env 000644 777777 777777 00000000212 12225201111 020426 x ustar 00jonswart 000000 000000 18 gid=1896053708
17 uid=512269995
20 ctime=1381302857
20 atime=1381302857
23 SCHILY.dev=16777220
22 SCHILY.ino=6246765
18 SCHILY.nlink=1
HTML-Mason-1.52/samples/show-env 000644 « q{Μ00000000174 12225201111 017412 0 ustar 00jonswart 000000 000000 Current Environment
% foreach my $key (sort(keys(%ENV))) {
HTML-Mason-1.52/lib/PaxHeader/HTML 000775 777777 777777 00000000212 12225201111 016533 x ustar 00jonswart 000000 000000 18 gid=1896053708
17 uid=512269995
20 ctime=1381302857
20 atime=1381302857
23 SCHILY.dev=16777220
22 SCHILY.ino=6246721
18 SCHILY.nlink=4
HTML-Mason-1.52/lib/HTML/ 000775 « q{Μ00000000000 12225201111 015567 5 ustar 00jonswart 000000 000000 HTML-Mason-1.52/lib/HTML/PaxHeader/Mason 000775 777777 777777 00000000213 12225201111 017611 x ustar 00jonswart 000000 000000 18 gid=1896053708
17 uid=512269995
20 ctime=1381302857
20 atime=1381302857
23 SCHILY.dev=16777220
22 SCHILY.ino=6246723
19 SCHILY.nlink=32
HTML-Mason-1.52/lib/HTML/Mason/ 000775 « q{Μ00000000000 12225201111 016644 5 ustar 00jonswart 000000 000000 HTML-Mason-1.52/lib/HTML/PaxHeader/Mason.pm 000644 777777 777777 00000000212 12225201111 020216 x ustar 00jonswart 000000 000000 18 gid=1896053708
17 uid=512269995
20 ctime=1381302857
20 atime=1381302857
23 SCHILY.dev=16777220
22 SCHILY.ino=6246722
18 SCHILY.nlink=1
HTML-Mason-1.52/lib/HTML/Mason.pm 000644 « q{Μ00000017735 12225201111 017215 0 ustar 00jonswart 000000 000000 package HTML::Mason;
{
$HTML::Mason::VERSION = '1.52';
}
# Copyright (c) 1998-2005 by Jonathan Swartz. All rights reserved.
# This program is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.
use 5.006;
use HTML::Mason::Interp;
sub version
{
return $HTML::Mason::VERSION;
}
1;
__END__
=pod
=head1 NAME
Mason - High-performance, dynamic web site authoring system
=head1 VERSION
version 1.52
=head1 SYNOPSIS
PerlModule HTML::Mason::ApacheHandler