'
x_serialization_backend: 'YAML::Tiny version 1.70'
HTML-Mason-1.58/weaver.ini 0000644 0001750 0001750 00000000254 13175376764 015144 0 ustar autarch autarch [@CorePrep]
[Generic / NAME]
[Version]
[Generic / SYNOPSIS]
[Generic / DESCRIPTION]
[Leftovers]
[=inc::Pod::Weaver::Section::SeeAlsoMason]
[Authors]
[Contributors]
[Legal]
HTML-Mason-1.58/t/ 0000775 0001750 0001750 00000000000 13175376764 013416 5 ustar autarch autarch HTML-Mason-1.58/t/15-subclass.t 0000644 0001750 0001750 00000011352 13175376764 015645 0 ustar autarch autarch 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.58/t/11-inherit.t 0000644 0001750 0001750 00000040475 13175376764 015474 0 ustar autarch autarch use strict;
use warnings;
use HTML::Mason::Tests;
my $tests = make_tests();
$tests->run;
sub make_tests
{
my $group = HTML::Mason::Tests->tests_class->new( name => 'inherit',
description => 'Test inheritance' );
#------------------------------------------------------------
$group->add_support( path => 'autohandler',
component => <<'EOF',
<%method m1>m1 from level 1%method>
<%method m12>m12 from level 1%method>
<%method m13>m13 from level 1%method>
<%method m123>m123 from level 1%method>
<%attr>
a1=>'a1 from level 1'
a12=>'a12 from level 1'
a13=>'a13 from level 1'
a123=>'a123 from level 1'
%attr>
<& { base_comp => $m->base_comp }, 'variants' &>
% $m->call_next;
EOF
);
#------------------------------------------------------------
$group->add_support( path => 'report_parent',
component => <<'EOF',
% my $comp = $m->callers(1);
My name is <% $comp->path %> and <% $comp->parent ? "my parent is ".$comp->parent->path : "I have no parent" %>.
EOF
);
#------------------------------------------------------------
$group->add_support( path => 'variants',
component => <<'EOF',
% my @variants = qw(1 2 3 12 13 23 123);
Methods (called from <% $m->callers(1)->title %>)
% foreach my $v (@variants) {
% if ($self->method_exists("m$v")) {
m<% $v %>: <& "SELF:m$v" &>
% } else {
m<% $v %>: does not exist
% }
% }
Attributes (referenced from <% $m->callers(1)->title %>)
% foreach my $v (@variants) {
% if ($self->attr_exists("a$v")) {
a<% $v %>: <% $self->attr("a$v") %>
% } else {
a<% $v %>: does not exist
% }
% }
<%init>
my $self = $m->base_comp;
%init>
EOF
);
#------------------------------------------------------------
$group->add_support( path => 'subdir/call_next_helper',
component => <<'EOF',
<%init>
# Making sure we can call_next from a helper component
$m->call_next;
%init>
EOF
);
#------------------------------------------------------------
$group->add_support( path => 'subdir/autohandler',
component => <<'EOF',
<%method m2>m2 from level 2%method>
<%method m12>m12 from level 2%method>
<%method m23>m23 from level 2%method>
<%method m123>m123 from level 2%method>
<%attr>
a2=>'a2 from level 2'
a12=>'a12 from level 2'
a23=>'a23 from level 2'
a123=>'a123 from level 2'
%attr>
<& { base_comp => $m->base_comp }, '../variants' &>
<& call_next_helper &>
<%init>
my $self = $m->base_comp;
%init>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'bypass',
description => 'test inheritance that skips one autohandler',
path => 'subdir/bypass',
call_path => 'subdir/bypass',
component => <<'EOF',
<%method m3>m3 from level 3%method>
<%method m13>m13 from level 3%method>
<%method m23>m23 from level 3%method>
<%method m123>m123 from level 3%method>
<%attr>
a3=>'a3 from level 3'
a13=>'a13 from level 3'
a23=>'a23 from level 3'
a123=>'a123 from level 3'
%attr>
<& { base_comp => $m->base_comp }, '../variants' &>
<& ../report_parent &>
<%flags>
inherit=>'../autohandler'
%flags>
EOF
expect => <<'EOF',
Methods (called from /inherit/autohandler)
m1: m1 from level 1
m2: does not exist
m3: m3 from level 3
m12: m12 from level 1
m13: m13 from level 3
m23: m23 from level 3
m123: m123 from level 3
Attributes (referenced from /inherit/autohandler)
a1: a1 from level 1
a2: does not exist
a3: a3 from level 3
a12: a12 from level 1
a13: a13 from level 3
a23: a23 from level 3
a123: a123 from level 3
Methods (called from /inherit/subdir/bypass)
m1: m1 from level 1
m2: does not exist
m3: m3 from level 3
m12: m12 from level 1
m13: m13 from level 3
m23: m23 from level 3
m123: m123 from level 3
Attributes (referenced from /inherit/subdir/bypass)
a1: a1 from level 1
a2: does not exist
a3: a3 from level 3
a12: a12 from level 1
a13: a13 from level 3
a23: a23 from level 3
a123: a123 from level 3
My name is /inherit/subdir/bypass and my parent is /inherit/autohandler.
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'ignore',
description => 'turning off inheritance',
path => 'subdir/ignore',
call_path => 'subdir/ignore',
component => <<'EOF',
<%method m3>m3 from level 3%method>
<%method m13>m13 from level 3%method>
<%method m23>m23 from level 3%method>
<%method m123>m123 from level 3%method>
<%attr>
a3=>'a3 from level 3'
a13=>'a13 from level 3'
a23=>'a23 from level 3'
a123=>'a123 from level 3'
%attr>
%# base_comp currently does not change when a comp ref is used
% my $variants = $m->fetch_comp('../variants');
<& $variants &>
<& ../report_parent &>
<%flags>
inherit=>undef
%flags>
EOF
expect => <<'EOF',
Methods (called from /inherit/subdir/ignore)
m1: does not exist
m2: does not exist
m3: m3 from level 3
m12: does not exist
m13: m13 from level 3
m23: m23 from level 3
m123: m123 from level 3
Attributes (referenced from /inherit/subdir/ignore)
a1: does not exist
a2: does not exist
a3: a3 from level 3
a12: does not exist
a13: a13 from level 3
a23: a23 from level 3
a123: a123 from level 3
My name is /inherit/subdir/ignore and I have no parent.
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'normal',
description => 'normal inheritance path',
path => 'subdir/normal',
call_path => 'subdir/normal',
component => <<'EOF',
<%method m3>m3 from level 3%method>
<%method m13>m13 from level 3%method>
<%method m23>m23 from level 3%method>
<%method m123>m123 from level 3%method>
<%attr>
a3=>'a3 from level 3'
a13=>'a13 from level 3'
a23=>'a23 from level 3'
a123=>'a123 from level 3'
%attr>
<& { base_comp => $m->base_comp }, '../variants' &>
<& ../report_parent &>
EOF
expect => <<'EOF',
Methods (called from /inherit/autohandler)
m1: m1 from level 1
m2: m2 from level 2
m3: m3 from level 3
m12: m12 from level 2
m13: m13 from level 3
m23: m23 from level 3
m123: m123 from level 3
Attributes (referenced from /inherit/autohandler)
a1: a1 from level 1
a2: a2 from level 2
a3: a3 from level 3
a12: a12 from level 2
a13: a13 from level 3
a23: a23 from level 3
a123: a123 from level 3
Methods (called from /inherit/subdir/autohandler)
m1: m1 from level 1
m2: m2 from level 2
m3: m3 from level 3
m12: m12 from level 2
m13: m13 from level 3
m23: m23 from level 3
m123: m123 from level 3
Attributes (referenced from /inherit/subdir/autohandler)
a1: a1 from level 1
a2: a2 from level 2
a3: a3 from level 3
a12: a12 from level 2
a13: a13 from level 3
a23: a23 from level 3
a123: a123 from level 3
Methods (called from /inherit/subdir/normal)
m1: m1 from level 1
m2: m2 from level 2
m3: m3 from level 3
m12: m12 from level 2
m13: m13 from level 3
m23: m23 from level 3
m123: m123 from level 3
Attributes (referenced from /inherit/subdir/normal)
a1: a1 from level 1
a2: a2 from level 2
a3: a3 from level 3
a12: a12 from level 2
a13: a13 from level 3
a23: a23 from level 3
a123: a123 from level 3
My name is /inherit/subdir/normal and my parent is /inherit/subdir/autohandler.
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/base/autohandler',
component => <<'EOF',
<%flags>
inherit => undef
%flags>
<%attr>
a => 'base autohandler'
%attr>
<%method x>
This is X in base autohandler
attribute A is <% $m->base_comp->attr('a') %>
<& SELF:x &>
<& .util &>
%method>
<%method y>
This is method Y in base autohandler
base_comp is <% $m->base_comp->name %>
%method>
<%def .util>
This is subcomponent .util
base_comp is <% $m->base_comp->name %>
<& SELF:y &>
%def>
% $m->call_next;
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/util/autohandler',
component => <<'EOF',
<%flags>
inherit => undef
%flags>
<%attr>
a => 'util autohandler'
%attr>
<%method x>
This is X in util autohandler
attribute A is <% $m->base_comp->attr('a') %>
<& SELF:x , why => 'infinite loop if PARENT does not work ' &>
%method>
<%method exec>
This is autohandler:exec
exec was really called for <% $m->base_comp->name %>
attribute A is <% $m->base_comp->attr('a') %>
<& SELF:x &>
%method>
% $m->call_next;
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/util/util',
component => <<'EOF',
<%method x>
This is method X in UTIL
%method>
<%attr>
a => 'util'
%attr>
This is UTIL
attribute A is <% $m->base_comp->attr('a') %>
<& SELF:x &>
<& PARENT:x &>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'base_comp',
path => '/base/base',
call_path => '/base/base',
description => 'base_comp test',
component => <<'EOF',
<%method x>
This is method X in BASE
%method>
<%attr>
a => 'base'
%attr>
This is BASE
attribute A is <% $m->base_comp->attr('a') %>
<& SELF:x &>
<& ../util/util &>
<& PARENT:x &>
EOF
expect => <<'EOF',
This is BASE
attribute A is base
This is method X in BASE
This is UTIL
attribute A is util
This is method X in UTIL
This is X in util autohandler
attribute A is util
This is method X in UTIL
This is X in base autohandler
attribute A is base
This is method X in BASE
This is subcomponent .util
base_comp is base
This is method Y in base autohandler
base_comp is base
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'base_comp_method',
path => '/base/meth',
call_path => '/base/meth',
description => 'base_comp method inheritance test',
component => <<'EOF',
<%method x>
This is method X in METH
%method>
<%attr>
a => 'meth'
%attr>
This is METH
attribute A is <% $m->base_comp->attr('a') %>
<& SELF:x &>
<& ../util/util:exec &>
EOF
expect => <<'EOF',
This is METH
attribute A is meth
This is method X in METH
This is autohandler:exec
exec was really called for util
attribute A is util
This is method X in UTIL
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/base2/autohandler',
component => <<'EOF',
<%flags>
inherit => undef
%flags>
This is autohandler A
<& sub/sibling &>
% $m->call_next;
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/base2/sub/autohandler',
component => <<'EOF',
This is autohandler B
<& SELF:m &>
% $m->call_next;
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/base2/sub/sibling',
component => <<'EOF',
This is SIBLING
<& PARENT &>
<%method m>
This is method M in SIBLING
%method>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'double_parent',
path => '/base2/sub/child',
call_path => '/base2/sub/child',
description => 'test that parent does not confuse children',
component => <<'EOF',
This is CHILD
<%method m>
This is method M in CHILD
%method>
EOF
expect => <<'EOF',
This is autohandler A
This is SIBLING
This is autohandler B
This is method M in SIBLING
This is CHILD
This is autohandler B
This is method M in CHILD
This is CHILD
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'subcomponent',
path => '/base2/subcomp',
call_path => '/base2/subcomp',
description => 'test subcomponents',
component => <<'EOF',
<%flags>
inherit => undef
%flags>
<%def .sub>
This is a subcomponent
<& SELF:x &>
%def>
<%method x>
This is method X
%method>
This is the component
<& .sub &>
EOF
expect => <<'EOF',
This is the component
This is a subcomponent
This is method X
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/base3/autohandler',
component => <<'EOF',
<%flags>
inherit => undef
%flags>
<%method x>
This is X in base autohandler
%method>
<& .foo &>
<%def .foo>
% $m->call_next;
%def>
EOF
);
#------------------------------------------------------------
# Remarks: this used to work in older versions of Mason. It's not
# *quite* surprising that it fails, because the call to <& .foo &>
# is a "normal" call and thus changes base_comp. But since .foo
# can't actually function usefully as a base_comp (as far as I
# know), it would be possible to not change base_comp while
# calling subcomponents. Currently base_comp changes to the
# autohandler in this situation, which seems odd.
#
# Current workaround is <& {base_comp => $m->request_comp}, $m->fetch_next, $m->caller_args(1) &>
#
# -Ken
$group->add_test( name => 'call_next_in_def',
path => '/base3/call_next_in_def',
call_path => '/base3/call_next_in_def',
description => 'Test call_next() inside a subcomponent',
component => <<'EOF',
<%method x>
This is method X in BASE
%method>
This is BASE
base_comp is <% $m->base_comp->name %>
<& SELF:x &>
EOF
expect => <<'EOF',
This is BASE
base_comp is call_next_in_def
This is method X in BASE
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/subcompbase/parent',
component => <<'EOF',
<& _foo &>
<%def _foo>
<& SELF:bar &>
%def>
<%method bar>
This is parent's bar.
%method>
<%flags>
inherit => undef
%flags>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'subcomponent_inheritance',
path => '/subcompbase/child',
call_path => '/subcompbase/child',
description => 'test base_comp with subcomponents',
component => <<'EOF',
<%flags>
inherit => 'parent'
%flags>
<%method bar>
This is child's bar.
%method>
EOF
expect => <<'EOF',
This is child's bar.
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/request_test/autohandler',
component => <<'EOF',
<& SELF:x &>\
<& REQUEST:x &>\
next\
% $m->call_next;
<%method x>
x in autohandler
%method>
<%flags>
inherit => undef
%flags>
EOF
);
$group->add_support( path => '/request_test/other_comp',
component => <<'EOF',
<& REQUEST:x &>\
<& SELF:x &>\
<%method x>x in other comp
%method>
<%flags>
inherit => undef
%flags>
EOF
);
$group->add_test( name => 'request_tests',
path => '/request_test/request_test',
call_path => '/request_test/request_test',
description => 'Test that REQUEST: works',
component => <<'EOF',
<& PARENT:x &>\
<& other_comp &>\
<%method x>x in requested comp
%method>
EOF
expect => <<'EOF',
x in requested comp
x in requested comp
next
x in autohandler
x in requested comp
x in other comp
EOF
);
#------------------------------------------------------------
return $group;
}
HTML-Mason-1.58/t/01a-comp-calls.t 0000644 0001750 0001750 00000022266 13175376764 016222 0 ustar autarch autarch use strict;
use warnings;
use File::Basename;
use HTML::Mason::Tests;
my $outside_comp_root_test_file;
my $tests = make_tests();
$tests->run;
sub make_tests
{
my $group = HTML::Mason::Tests->tests_class->new( name => 'comp-calls',
description => 'Component call syntax' );
$outside_comp_root_test_file = dirname($group->comp_root) . "/.outside_comp";
#------------------------------------------------------------
$group->add_support( path => '/support/amper_test',
component => <<'EOF',
amper_test.
% 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);
%perl>
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
%flags>
<& PARENT:foo &>
EOF
expect_error => qr/PARENT designator used from component with no parent/,
);
#------------------------------------------------------------
$group->add_test( name => 'no_such_method',
description => 'calling nonexistent method on existing component',
component => <<'EOF',
<& support/amper_test:bar &>
EOF
expect_error => qr/no such method 'bar' for component/,
);
#------------------------------------------------------------
$group->add_test( name => 'fetch_comp_no_errors',
description => 'fetch_comp should not throw any errors',
component => <<'EOF',
% foreach my $path (qw(foo support/amper_test:bar PARENT)) {
<% $m->fetch_comp($path) ? 'defined' : 'undefined' %>
% }
EOF
expect => <<'EOF',
undefined
undefined
undefined
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/support/methods',
component => <<'EOF',
<%method foo>%method>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'comp_exists',
description => 'test comp_exists with various types of paths',
component => <<'EOF',
<%perl>
my @paths = qw(
support/methods
support/methods:foo
support/methods:bar
.foo
.bar
SELF
SELF:foo
PARENT
PARENT:foo
REQUEST
REQUEST:foo
);
%perl>
<%def .foo>%def>
% foreach my $path (@paths) {
<% $path %>: <% $m->comp_exists($path) %>
% }
EOF
expect => <<'EOF',
support/methods: 1
support/methods:foo: 1
support/methods:bar: 0
.foo: 1
.bar: 0
SELF: 1
SELF:foo: 0
PARENT: 0
PARENT:foo: 0
REQUEST: 1
REQUEST:foo: 0
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'comp_exists_no_arg',
description => 'comp_exists with blank or undefined argument returns 0',
component => <<'EOF',
comp_exists(undef) = <% $m->comp_exists(undef) %>
comp_exists("") = <% $m->comp_exists("") %>
EOF
expect => <<'EOF',
comp_exists(undef) = 0
comp_exists("") = 0
EOF
);
return $group;
}
HTML-Mason-1.58/t/01-syntax.t 0000644 0001750 0001750 00000015642 13175376764 015355 0 ustar autarch autarch use strict;
use warnings;
use HTML::Mason::Tests;
my $tests = make_tests();
$tests->run;
sub make_tests
{
my $group = HTML::Mason::Tests->tests_class->new( name => 'syntax',
description => 'Basic component syntax tests' );
#------------------------------------------------------------
$group->add_test( name => 'replace',
description => 'tests <% %> tag',
component => <<'EOF',
Replacement Test
<% "Hello World!" %>
EOF
expect => <<'EOF',
Replacement Test
Hello World!
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'percent',
description => 'tests %-line syntax',
component => <<'EOF',
Percent Test
% my $message = "Hello World!";
<% $message %>
EOF
expect => <<'EOF',
Percent Test
Hello World!
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'fake_percent',
description => 'tests % in text section',
component => 'some text, a %, and some text',
expect => 'some text, a %, and some text',
);
#------------------------------------------------------------
$group->add_test( name => 'empty_percents',
description => 'tests empty %-lines',
component => <<'EOF',
some text,
%
and some more
EOF
expect => "some text,\nand some more\n",
);
#------------------------------------------------------------
$group->add_test( name => 'empty_percents2',
description => 'tests empty %-lines followed by other %-lines',
component => <<'EOF',
some text,
%
% $m->print('foo, ');
and some more
EOF
expect => "some text,\nfoo, and some more\n",
);
#------------------------------------------------------------
$group->add_test( name => 'space_after_method_name',
description => 'tests that spaces are allowed after method/subcomp names',
component => <<'EOF',
a
<%def foo >
%def>
<%method bar
>
%method>
b
EOF
expect => <<'EOF',
a
b
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'comment_in_attr_flags',
description => 'tests that comments are allowed at end of flag/attr lines',
component => <<'EOF',
a
<%flags>
inherit => undef # foo bar
%flags>
<%attr>
a => 1 # a is 1
b => 2 # ya ay
%attr>
b
EOF
expect => <<'EOF',
a
b
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'dash in subcomp named',
description => 'tests that dashes are allowed in subcomponent names',
component => <<'EOF',
a
<%def has-dashes>
foo
%def>
b
EOF
expect => <<'EOF',
a
b
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'flags_on_one_line',
description => 'tests that a flags block can be one line',
component => <<'EOF',
a
<%flags>inherit => undef%flags>
b
EOF
expect => <<'EOF',
a
b
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'attr_uc_ending',
description => 'tests that an attr ending tag can be upper-case',
component => <<'EOF',
<%ATTR>
thing => 1%ATTR>
thing: <% $m->request_comp->attr('thing') %>
EOF
expect => <<'EOF',
thing: 1
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'args_uc_ending',
description => 'tests that args ending tag can be mixed case',
component => <<'EOF',
<%ARGS>
$a => 1%ARGS>
a is <% $a %>
b
EOF
expect => <<'EOF',
a is 1
b
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'comment_in_call',
description => 'make a comp call with a commented line',
component => <<'EOF',
<& .foo,
foo => 1,
# bar => 2,
&>
<& .foo,
# foo => 1,
bar => 2,
&>
<%def .foo>foo! args are <% join(", ", %ARGS) %>%def>
EOF
expect => <<'EOF',
foo! args are foo, 1
foo! args are bar, 2
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'comment_in_call2',
description => 'make a comp call with content with a commented line',
component => <<'EOF',
<&| .show_content,
foo => 1,
# bar => 2,
&>\
This is the content\
&>
<%def .show_content>\
<% $m->content %>\
%def>
EOF
expect => <<'EOF',
This is the content
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'call_starts_with_newline',
description => 'make a comp call where the tag starts with a newline',
component => <<'EOF',
<&
.foo,
x => 1
&>\
<%def .foo>\
x is <% $ARGS{x} %>
%def>
EOF
expect => <<'EOF',
x is 1
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'cleanup_init',
description => 'test that cleanup block has access to variables from init section',
component => <<'EOF',
<%init>
my $x = 7;
%init>
<%cleanup>
$m->print("x is $x");
%cleanup>
EOF
expect => <<'EOF',
x is 7
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'cleanup_perl',
description => 'test that cleanup block has access to variables from perl section',
component => <<'EOF',
<%perl>
my $x = 7;
%perl>
<%cleanup>
$m->print("x is $x");
%cleanup>
EOF
expect => <<'EOF',
x is 7
EOF
);
#------------------------------------------------------------
return $group;
}
HTML-Mason-1.58/t/run_tests 0000755 0001750 0001750 00000000275 13175376764 015374 0 ustar autarch autarch #!/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.58/t/14a-fake_apache.t 0000644 0001750 0001750 00000017637 13175376764 016411 0 ustar autarch autarch 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.58/t/00-report-prereqs.t 0000644 0001750 0001750 00000013426 13175376764 017016 0 ustar autarch autarch #!perl
use strict;
use warnings;
# This test was generated by Dist::Zilla::Plugin::Test::ReportPrereqs 0.027
use Test::More tests => 1;
use ExtUtils::MakeMaker;
use File::Spec;
# from $version::LAX
my $lax_version_re =
qr/(?: undef | (?: (?:[0-9]+) (?: \. | (?:\.[0-9]+) (?:_[0-9]+)? )?
|
(?:\.[0-9]+) (?:_[0-9]+)?
) | (?:
v (?:[0-9]+) (?: (?:\.[0-9]+)+ (?:_[0-9]+)? )?
|
(?:[0-9]+)? (?:\.[0-9]+){2,} (?:_[0-9]+)?
)
)/x;
# hide optional CPAN::Meta modules from prereq scanner
# and check if they are available
my $cpan_meta = "CPAN::Meta";
my $cpan_meta_pre = "CPAN::Meta::Prereqs";
my $HAS_CPAN_META = eval "require $cpan_meta; $cpan_meta->VERSION('2.120900')" && eval "require $cpan_meta_pre"; ## no critic
# Verify requirements?
my $DO_VERIFY_PREREQS = 1;
sub _max {
my $max = shift;
$max = ( $_ > $max ) ? $_ : $max for @_;
return $max;
}
sub _merge_prereqs {
my ($collector, $prereqs) = @_;
# CPAN::Meta::Prereqs object
if (ref $collector eq $cpan_meta_pre) {
return $collector->with_merged_prereqs(
CPAN::Meta::Prereqs->new( $prereqs )
);
}
# Raw hashrefs
for my $phase ( keys %$prereqs ) {
for my $type ( keys %{ $prereqs->{$phase} } ) {
for my $module ( keys %{ $prereqs->{$phase}{$type} } ) {
$collector->{$phase}{$type}{$module} = $prereqs->{$phase}{$type}{$module};
}
}
}
return $collector;
}
my @include = qw(
);
my @exclude = qw(
);
# Add static prereqs to the included modules list
my $static_prereqs = do './t/00-report-prereqs.dd';
# Merge all prereqs (either with ::Prereqs or a hashref)
my $full_prereqs = _merge_prereqs(
( $HAS_CPAN_META ? $cpan_meta_pre->new : {} ),
$static_prereqs
);
# Add dynamic prereqs to the included modules list (if we can)
my ($source) = grep { -f } 'MYMETA.json', 'MYMETA.yml';
my $cpan_meta_error;
if ( $source && $HAS_CPAN_META
&& (my $meta = eval { CPAN::Meta->load_file($source) } )
) {
$full_prereqs = _merge_prereqs($full_prereqs, $meta->prereqs);
}
else {
$cpan_meta_error = $@; # capture error from CPAN::Meta->load_file($source)
$source = 'static metadata';
}
my @full_reports;
my @dep_errors;
my $req_hash = $HAS_CPAN_META ? $full_prereqs->as_string_hash : $full_prereqs;
# Add static includes into a fake section
for my $mod (@include) {
$req_hash->{other}{modules}{$mod} = 0;
}
for my $phase ( qw(configure build test runtime develop other) ) {
next unless $req_hash->{$phase};
next if ($phase eq 'develop' and not $ENV{AUTHOR_TESTING});
for my $type ( qw(requires recommends suggests conflicts modules) ) {
next unless $req_hash->{$phase}{$type};
my $title = ucfirst($phase).' '.ucfirst($type);
my @reports = [qw/Module Want Have/];
for my $mod ( sort keys %{ $req_hash->{$phase}{$type} } ) {
next if $mod eq 'perl';
next if grep { $_ eq $mod } @exclude;
my $file = $mod;
$file =~ s{::}{/}g;
$file .= ".pm";
my ($prefix) = grep { -e File::Spec->catfile($_, $file) } @INC;
my $want = $req_hash->{$phase}{$type}{$mod};
$want = "undef" unless defined $want;
$want = "any" if !$want && $want == 0;
my $req_string = $want eq 'any' ? 'any version required' : "version '$want' required";
if ($prefix) {
my $have = MM->parse_version( File::Spec->catfile($prefix, $file) );
$have = "undef" unless defined $have;
push @reports, [$mod, $want, $have];
if ( $DO_VERIFY_PREREQS && $HAS_CPAN_META && $type eq 'requires' ) {
if ( $have !~ /\A$lax_version_re\z/ ) {
push @dep_errors, "$mod version '$have' cannot be parsed ($req_string)";
}
elsif ( ! $full_prereqs->requirements_for( $phase, $type )->accepts_module( $mod => $have ) ) {
push @dep_errors, "$mod version '$have' is not in required range '$want'";
}
}
}
else {
push @reports, [$mod, $want, "missing"];
if ( $DO_VERIFY_PREREQS && $type eq 'requires' ) {
push @dep_errors, "$mod is not installed ($req_string)";
}
}
}
if ( @reports ) {
push @full_reports, "=== $title ===\n\n";
my $ml = _max( map { length $_->[0] } @reports );
my $wl = _max( map { length $_->[1] } @reports );
my $hl = _max( map { length $_->[2] } @reports );
if ($type eq 'modules') {
splice @reports, 1, 0, ["-" x $ml, "", "-" x $hl];
push @full_reports, map { sprintf(" %*s %*s\n", -$ml, $_->[0], $hl, $_->[2]) } @reports;
}
else {
splice @reports, 1, 0, ["-" x $ml, "-" x $wl, "-" x $hl];
push @full_reports, map { sprintf(" %*s %*s %*s\n", -$ml, $_->[0], $wl, $_->[1], $hl, $_->[2]) } @reports;
}
push @full_reports, "\n";
}
}
}
if ( @full_reports ) {
diag "\nVersions for all modules listed in $source (including optional ones):\n\n", @full_reports;
}
if ( $cpan_meta_error || @dep_errors ) {
diag "\n*** WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING ***\n";
}
if ( $cpan_meta_error ) {
my ($orig_source) = grep { -f } 'MYMETA.json', 'MYMETA.yml';
diag "\nCPAN::Meta->load_file('$orig_source') failed with: $cpan_meta_error\n";
}
if ( @dep_errors ) {
diag join("\n",
"\nThe following REQUIRED prerequisites were not satisfied:\n",
@dep_errors,
"\n"
);
}
pass;
# vim: ts=4 sts=4 sw=4 et:
HTML-Mason-1.58/t/09a-comp_content.t 0000644 0001750 0001750 00000032014 13175376764 016660 0 ustar autarch autarch use strict;
use warnings;
use HTML::Mason::Tests;
my $tests = make_tests();
$tests->run;
sub make_tests
{
my $group = HTML::Mason::Tests->tests_class->new( name => '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');
%once>
<%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."'");
}
%perl>
EOF
);
#------------------------------------------------------------
$group->add_support( path => 'filter_test/repeat',
component => <<'EOF',
<%args>
$var
@list
%args>
<%perl>
for (@list) {
$$var = $_;
$m->print($m->content);
}
%perl>
EOF
);
#------------------------------------------------------------
$group->add_support( path => 'filter_test/repeat2',
component => <<'EOF',
<%args>
@list
%args>
% 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;
<&| repeat , var => \$a, list => [1,2,3,4,5] &>
- <% $a %>
&>
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 %> &>
&>
done!
EOF
expect => <<'EOF',
five
four
three
two
one
done!
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'contentless',
path => 'filter_test/test4',
call_path => 'filter_test/test4',
description => 'test a filter with no content',
component => <<'EOF',
nothing <& filter &> here
EOF
expect => <<'EOF',
nothing content returned '' here
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'default_content',
path => 'filter_test/test5',
call_path => 'filter_test/test5',
description => 'test a filter which does not access content',
component => <<'EOF',
outside <&| null &> inside &> outside
EOF
expect => <<'EOF',
outside outside
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'current_component',
path => 'filter_test/test6',
call_path => 'filter_test/test6',
call_args => {arg=>1},
description => 'test $m->current_comp inside filter content',
component => <<'EOF',
<% $m->current_comp->name %>
<&| echo &>
<% $m->current_comp->name %>
<&| echo &>
<% $m->current_comp->name %>
<% join(", ", $m->caller_args(0)) %>
&>
&>
EOF
expect => <<'EOF',
test6
test6
test6
arg, 1
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'various_tags',
path => 'filter_test/test7',
call_path => 'filter_test/test7',
description => 'test various tags in content',
component => <<'EOF',
<%method lala>
component call
%method>
<&| filter &>
% $m->print("this is a perl line ");
<% "substitution tag" %>
<& SELF:lala &>
<%perl>
$m->print("perl tag");
%perl>
&>
EOF
expect => <<'EOF',
content returned 'this is a perl line substitution tag
component call
perl tag'
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'filter_with_filter',
path => 'filter_test/test8',
call_path => 'filter_test/test8',
description => 'test interaction with filter section',
component => <<'EOF',
<&| filter &>hi ho&>
<%filter>
s/content returned/simon says/
%filter>
EOF
expect => <<'EOF',
simon says 'hi ho'
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'top_level_content',
description => 'test $m->content at top level is empty',
component => <<'EOF',
top level content is '<% $m->content %>'
EOF
expect => <<'EOF',
top level content is ''
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'filter_content',
path => 'filter_test/test10',
call_path => 'filter_test/test10',
description => 'test filtering $m->content',
component => <<'EOF',
top
<&| double &>guts&>
EOF
expect => <<'EOF',
top
one
content returned 'guts'
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'subcomponent_filter',
description => 'test method as filter',
component => <<'EOF',
<%def sad>
<% $m->content %>? I can't help it!
%def>
<%method happy>
<% $m->content %>, be happy!
%method>
<&| SELF:happy &>don't worry&>
<&| sad &>why worry&>
EOF
expect => <<'EOF',
don't worry, be happy!
why worry? I can't help it!
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'dollar_underscore',
description => 'Test using $_ in a filter',
component => <<'EOF',
<&| filter_test/repeat2, list => [1,2,3] &>$_ is <% $_ %>&>
EOF
expect => <<'EOF',
$_ is 1
$_ is 2
$_ is 3
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'multi_filter',
description => 'Test order of multiple filters',
component => <<'EOF',
<&| .lc &>\
<&| .uc &>\
MixeD CAse\
&>\
&>\
<%def .uc>\
<% uc $m->content %>\
%def>
<%def .lc>\
<% lc $m->content %>\
%def>
EOF
expect => <<'EOF',
mixed case
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'clear_in_filter',
description => 'Test clear_buffer in a filtered call',
component => <<'EOF',
clear me
<&| .lc &>\
MIXED case
% $m->clear_buffer;
mixed CASE
&>
<%def .lc>\
in .lc
<% lc $m->content %>\
%def>
EOF
expect => <<'EOF',
mixed case
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'clear_in_filter2',
description => 'More clear_buffer in a filtered call',
component => <<'EOF',
clear me
<&| .lc &>\
MIXED case
<& .clear &>\
mixed CASE
&>
<%def .lc>\
in .lc
<% lc $m->content %>\
%def>\
<%def .clear>\
% $m->clear_buffer;
%def>
EOF
expect => <<'EOF',
mixed case
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'flush_in_filter',
description => 'Test flush_buffer in a filtered call',
component => <<'EOF',
<&| .lc &>\
Should do nothing
% $m->flush_buffer;
so both should appear
&>
<%def .lc>\
<% lc $m->content %>\
%def>
EOF
expect => <<'EOF',
should do nothing
so both should appear
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'has_content',
description => 'Test $m->has_content',
component => <<'EOF',
<& .show_content &>\
-----
<&| .show_content &>\
This is the content
&>
<%def .show_content>\
% if ($m->has_content) {
My content is:
<% $m->content %>
% } else {
I have no content.
% }
%def>
EOF
expect => <<'EOF',
I have no content.
-----
My content is:
This is the content
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'ending_tag_match',
description => 'Test & comp >',
component => <<'EOF',
<&|.outer &>\
<&| .inner, dummy=>1 &>\
This is the content
&.inner >
& .outer>
<%def .inner>\
% $m->print("inner: ".$m->content);
%def>
<%def .outer>\
% $m->print("outer: ".$m->content);
%def>
EOF
expect => <<'EOF',
outer: inner: This is the content
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'ending_tag_nomatch',
description => 'Test bad & comp > match',
component => <<'EOF',
<&|.outer &>\
<&| .inner&>\
This is the content
&.outer >
& .inner>
<%def .inner>\
% $m->print("inner: ".$m->content);
%def>
<%def .outer>\
% $m->print("outer: ".$m->content);
%def>
EOF
expect_error => 'Component name in ending tag \(\.outer\) does not match component name in beginning tag \(\.inner\)',
);
#------------------------------------------------------------
$group->add_test( name => 'ending_tag_expr',
description => 'Test expr in <& expr> not matched',
component => <<'EOF',
<&| ".outer" &>\
<&| ".inner" &>\
This is the content
&>
& .outer >
<%def .inner>\
% $m->print("inner: ".$m->content);
%def>
<%def .outer>\
% $m->print("outer: ".$m->content);
%def>
EOF
expect_error => 'Cannot match an expression as a component name',
);
#------------------------------------------------------------
$group->add_test( name => 'ending_tag_expr2',
description => 'Test expr in &> not allowed',
component => <<'EOF',
<&| ".outer" &>\
<&| ".inner" &>\
This is the content
&>
& ".inner" >
<%def .inner>\
% $m->print("inner: ".$m->content);
%def>
<%def .outer>\
% $m->print("outer: ".$m->content);
%def>
EOF
expect_error => 'Cannot use an expression inside component with content ending tag',
);
#------------------------------------------------------------
$group->add_test( name => 'multiline_open_close',
description => 'Tests multiline opening and closing blocks for component with content call tags',
component => <<'EOF',
<&|
Wrap
&>\
Hello\
&
Wrap
>\
<%def Wrap>\
[Wrap start]
<% $m->content %>
[Wrap end]\
%def>
EOF
expect => <<'EOF',
[Wrap start]
Hello
[Wrap end]
EOF
);
#------------------------------------------------------------
return $group;
}
HTML-Mason-1.58/t/12-taint.t 0000644 0001750 0001750 00000006713 13175376764 015147 0 ustar autarch autarch #!/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.58/t/run_one_test 0000755 0001750 0001750 00000000047 13175376764 016047 0 ustar autarch autarch #!/bin/bash
/usr/bin/perl -I../lib $*
HTML-Mason-1.58/t/05a-stack-corruption.t 0000644 0001750 0001750 00000002715 13175376764 017500 0 ustar autarch autarch use strict;
use warnings;
use HTML::Mason::Tests;
my $tests = make_tests();
$tests->run;
sub make_tests
{
my $group = HTML::Mason::Tests->tests_class->new( name => 'stack_corruption',
description => 'tests for stack corruption',
);
# The key to this test is that it first calls a component that in
# turn has a comp-with-content call. That comp-with-content call
# then calls $m->content (this is important).
#
# After that, _further_ component calls reveal stack corruption.
$group->add_support( path => '/support/comp',
component => <<'EOF',
<&| .subcomp1 &>
<& .subcomp2 &>
&>
<%def .subcomp1>
% $m->content;
%def>
<%def .subcomp2>
content
%def>
EOF
);
$group->add_support( path => '/support/comp2',
component => <<'EOF',
EOF
);
$group->add_test( name => 'stack_corruption',
description => 'test for stack corruption with comp-with-content call',
component => <<'EOF',
<& support/comp &>
<& support/comp2 &>
<& .callers &>
<%def .callers>
Stack at this point:
% for my $f ( $m->callers ) {
<% defined $f ? $f->path : 'undef' %>
% }
%def>
EOF
expect => qr{/stack_corruption/stack_corruption:.callers\n(?!undef)},
);
return $group;
}
HTML-Mason-1.58/t/10a-cache-1.0x.t 0000644 0001750 0001750 00000013046 13175376764 015713 0 ustar autarch autarch #
# 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;
}
%init>
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');
%init>
<%args>
$var
%args>
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");
}
%init>
EOF
expect => <<'EOF',
keys in cache: bar,baz,foo
value for foo is foo
value for bar is bar
value for baz is baz
expiring foo and bar...
value for foo is undefined
value for bar is undefined
value for baz is baz
EOF
);
#------------------------------------------------------------
$group->add_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;
%init>
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;
%init>
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;
%init>
EOF
expect => <<'EOF',
undef, undef
EOF
);
#------------------------------------------------------------
return $group;
}
HTML-Mason-1.58/t/19-subrequest.t 0000644 0001750 0001750 00000026755 13175376764 016251 0 ustar autarch autarch use strict;
use warnings;
use HTML::Mason::Tests;
my $tests = make_tests();
$tests->run;
sub make_tests
{
my $group = HTML::Mason::Tests->tests_class->new( name => 'subrequest',
description => 'subrequest-related features' );
#------------------------------------------------------------
$group->add_support( path => '/support/subrequest_error_test',
component => <<'EOF',
<& /shared/display_req_obj &>
% die "whoops!";
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/support/dir/autohandler',
component => <<'EOF',
I am the autohandler.
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/support/dir/comp',
component => <<'EOF',
I am the called comp (no autohandler).
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'subrequest',
description => 'tests the official subrequest mechanism',
component => <<'EOF',
<%def .helper>
Executing subrequest
% print "I can print before the subrequest\n";
% my $buf;
% my $req = $m->make_subrequest(comp=>'/shared/display_req_obj', out_method => \$buf);
% $req->exec();
<% $buf %>
% print "I can still print after the subrequest\n";
%def>
Calling helper
<& .helper &>
EOF
expect => <<'EOF',
Calling helper
Executing subrequest
I can print before the subrequest
My depth is 1.
I am a subrequest.
The top-level component is /shared/display_req_obj.
My stack looks like:
-----
/shared/display_req_obj
-----
I can still print after the subrequest
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'subrequest_with_autohandler',
description => 'tests the subrequest mechanism with an autohandler',
component => <<'EOF',
Executing subrequest
% my $buf;
% my $req = $m->make_subrequest(comp=>'/subrequest/support/dir/comp', out_method => \$buf);
% $req->exec();
<% $buf %>
EOF
expect => <<'EOF',
Executing subrequest
I am the autohandler.
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/subrequest2/autohandler',
component => <<'EOF',
I am the autohandler for <% $m->base_comp->name %>.
% $m->call_next;
<%flags>
inherit => undef
%flags>
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/subrequest2/bar',
component => <<'EOF',
I am bar.
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'subreq_exec_order',
path => '/subrequest2/subreq_exec_order',
call_path => '/subrequest2/subreq_exec_order',
description => 'Test that output from a subrequest comes out when we expect it to.',
component => <<'EOF',
% $m->subexec('/subrequest/subrequest2/bar');
I am subreq_exec_order.
EOF
expect => <<'EOF',
I am the autohandler for subreq_exec_order.
I am the autohandler for bar.
I am bar.
I am subreq_exec_order.
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/support/autoflush_subrequest',
component => <<'EOF',
% $m->autoflush($autoflush) if $autoflush;
here is the child
% $m->clear_buffer if $clear;
<%args>
$autoflush => 0
$clear => 0
%args>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'autoflush_subrequest',
description => 'make sure that a subrequest respects its parent autoflush setting',
interp_params => { autoflush => 1 },
component => <<'EOF',
My child says:
% $m->flush_buffer;
% $m->subexec('/subrequest/support/autoflush_subrequest');
% $m->clear_buffer;
EOF
expect => <<'EOF',
My child says:
here is the child
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'subrequest_inherits_no_autoflush',
description => 'make sure that a subrequest inherits its parent autoflush setting (autoflush off)',
interp_params => { autoflush => 0 },
component => <<'EOF',
My child says:
% $m->flush_buffer;
% $m->subexec('/subrequest/support/autoflush_subrequest');
% $m->clear_buffer;
EOF
expect => <<'EOF',
My child says:
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'autoflush_in_subrequest',
description => 'make sure that a subrequest with autoflush on does not flush parent',
component => <<'EOF',
My child says:
% $m->flush_buffer;
% $m->subexec('/subrequest/support/autoflush_subrequest', autoflush => 1);
% $m->clear_buffer;
EOF
expect => <<'EOF',
My child says:
EOF
);
#------------------------------------------------------------
# SKIPPING THIS TEST FOR NOW - NOT SURE OF DESIRED BEHAVIOR
if (0) {
$group->add_test( name => 'autoflush_in_parent_not_subrequest',
description => 'make sure that a subrequest with autoflush can clear its own buffers',
interp_params => { autoflush => 1 },
component => <<'EOF',
My child says:
% $m->flush_buffer;
% $m->subexec('/subrequest/support/autoflush_subrequest', autoflush => 0, clear => 1);
% $m->clear_buffer;
EOF
expect => <<'EOF',
My child says:
EOF
);
}
#------------------------------------------------------------
$group->add_support( path => '/support/return/scalar',
component => <<'EOF',
% die "wantarray should be false" unless defined(wantarray) and !wantarray;
% return 'foo';
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'return_scalar',
description => 'tests that exec returns scalar return value of top component',
component => <<'EOF',
% my $req = $m->make_subrequest(comp=>'/subrequest/support/return/scalar');
% my $value = $req->exec();
return value is <% $value %>
EOF
expect => <<'EOF',
return value is foo
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/support/return/list',
component => <<'EOF',
% die "wantarray should be true" unless wantarray;
% return (1, 2, 3);
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'return_list',
description => 'tests that exec returns list return value of top component',
component => <<'EOF',
% my $req = $m->make_subrequest(comp=>'/subrequest/support/return/list');
% my @value = $req->exec();
return value is <% join(",", @value) %>
EOF
expect => <<'EOF',
return value is 1,2,3
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/support/return/nothing',
component => <<'EOF',
wantarray is <% defined(wantarray) ? "defined" : "undefined" %>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'return_nothing',
description => 'tests exec in non-return context',
component => <<'EOF',
% my $req = $m->make_subrequest(comp=>'/subrequest/support/return/nothing');
% $req->exec();
EOF
expect => <<'EOF',
wantarray is undefined
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/support/output',
component => <<'EOF',
More output
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'kwindla',
description => 'tests bug report from Kwindla Kramer',
component => <<'EOF',
Some output
% $m->clear_buffer;
% my $req = $m->make_subrequest( comp => '/subrequest/support/output' );
% $req->exec();
% $m->flush_buffer;
% $m->abort;
EOF
expect => <<'EOF',
More output
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'in_package',
description => 'use in_package with subrequest',
interp_params => { in_package => 'Test::Package' },
component => <<'EOF',
Before subreq
% $m->subexec( '/subrequest/support/output' );
After subreq
EOF
expect => <<'EOF',
Before subreq
More output
After subreq
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'relative_path_call',
description => 'call subrequest with relative path',
component => <<'EOF',
% $m->subexec( 'support/output' );
EOF
expect => <<'EOF',
More output
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'comp_object_call',
description => 'call subrequest with component object',
component => <<'EOF',
% $m->subexec( $m->interp->load('/subrequest/support/output') );
EOF
expect => <<'EOF',
More output
EOF
);
#------------------------------------------------------------
$group->add_support( path => 'support/subexec_recurse_test',
component => <<'EOF',
Entering <% $m->request_depth %>
% if ($count < $max) {
% $m->subexec('subexec_recurse_test', count=>$count+1, max=>$max)
% }
Exiting <% $m->request_depth %>
<%args>
$count=>0
$max
%args>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'max_recurse_1',
description => 'Test that recursion 8 levels deep is allowed',
component => '<& support/subexec_recurse_test, max=>8 &>',
expect => <<'EOF',
Entering 1
Entering 2
Entering 3
Entering 4
Entering 5
Entering 6
Entering 7
Entering 8
Entering 9
Exiting 9
Exiting 8
Exiting 7
Exiting 6
Exiting 5
Exiting 4
Exiting 3
Exiting 2
Exiting 1
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'max_recurse_2',
description => 'Test that recursion is stopped after 32 subexecs',
component => '<& support/subexec_recurse_test, max=>48 &>',
expect_error => qr{subrequest depth > 32 \(infinite subrequest loop\?\)},
);
#------------------------------------------------------------
return $group;
}
HTML-Mason-1.58/t/10-cache.t 0000644 0001750 0001750 00000035465 13175376764 015077 0 ustar autarch autarch use strict;
use warnings;
use HTML::Mason::Tests;
use HTML::Mason::Tools;
# Skip if flock not implemented.
eval { my $fh = do { local *FH; *FH; }; open $fh, $0; flock $fh,1; };
if ($@)
{
print "1..0 # Skipped: flock() is not available on this system\n";
exit;
}
# Skip if Cache::FileCache not present.
eval { require Cache::FileCache };
if ($@)
{
print "1..0 # Skipped: Cache::FileCache is not installed\n";
exit;
}
my $tests = make_tests();
$tests->run;
sub make_tests
{
my $group = HTML::Mason::Tests->tests_class->new( name => 'cache',
description => 'Test caching' );
#------------------------------------------------------------
$group->add_test( name => 'cache_packages',
description => 'test that Mason cache packages get created',
component => <<'EOF',
% my $cache;
% $cache = $m->cache(cache_class=>'Cache::FileCache');
<% ref($cache) %>
<% $HTML::Mason::Cache::FileCache::VERSION + 0 %>
<% HTML::Mason::Tools::pkg_loaded('HTML::Mason::Cache::FileCache') ? 'loaded' : 'not loaded' %>
% $cache = $m->cache(cache_class=>'MemoryCache');
<% ref($cache) %>
<% $HTML::Mason::Cache::MemoryCache::VERSION + 0%>
<% HTML::Mason::Tools::pkg_loaded('HTML::Mason::Cache::FileCache') ? 'loaded' : 'not loaded' %>
EOF
expect => <<'EOF',
HTML::Mason::Cache::FileCache
1
loaded
HTML::Mason::Cache::MemoryCache
1
loaded
EOF
);
#------------------------------------------------------------
$group->add_support( path => 'support/cache_test',
component => <<'EOF',
<% $result %>
This was<% $cached ? '' : ' not' %> cached.
<%init>
my $cached = 0;
my $result;
my $return;
unless ($result = $m->cache->get('fandango')) {
$result = "Hello Dolly.";
$return = $m->cache->set('fandango', $result) || '';
} else {
$cached = 1;
}
%init>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'cache',
description => 'basic caching functionality',
component => <<'EOF',
% for (my $i=0; $i<3; $i++) {
<& support/cache_test &>
% }
EOF
expect => <<'EOF',
Hello Dolly.
This was not cached.
Hello Dolly.
This was cached.
Hello Dolly.
This was cached.
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'keys',
description => q|test multiple keys and $m->cache->get_keys|,
component => <<'EOF',
<%init>
foreach my $key (qw(foo bar baz)) {
$m->cache->set($key, $key);
}
my @keys = sort $m->cache->get_keys;
$m->print("keys in cache: ".join(",",@keys)."\n");
foreach my $key (qw(foo bar baz)) {
my $value = $m->cache->get($key) || "undefined";
$m->print("value for $key is $value\n");
}
$m->cache->remove('foo');
$m->cache->remove('bar');
$m->print("expiring foo and bar...\n");
foreach my $key (qw(foo bar baz)) {
my $value = $m->cache->get($key) || "undefined";
$m->print("value for $key is $value\n");
}
%init>
EOF
expect => <<'EOF',
keys in cache: bar,baz,foo
value for foo is foo
value for bar is bar
value for baz is baz
expiring foo and bar...
value for foo is undefined
value for bar is undefined
value for baz is baz
EOF
);
#------------------------------------------------------------
$group->add_support ( path => 'support/cache_self',
component => <<'EOF',
x is <% $x %>
<%args>
$x
%args>
<%init>
return if $m->cache_self;
%init>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'cache_self',
description => 'test $m->cache_self',
component => <<'EOF',
<& support/cache_self, x => 1 &>
<& support/cache_self, x => 99 &>
EOF
expect => <<'EOF',
x is 1
x is 1
EOF
);
#------------------------------------------------------------
$group->add_support ( path => 'support/cache_self_expires_in',
component => <<'EOF',
x is <% $x %>
<%args>
$x
%args>
<%init>
return if $m->cache_self( expires_in => '3s' );
%init>
EOF
);
$group->add_test( name => 'cache_self_expires_in',
description => 'test that $m->cache_self respects expires_in parameter',
component => <<'EOF',
<& support/cache_self_expires_in, x => 1 &>
<& support/cache_self_expires_in, x => 2 &>
% sleep 5;
<& support/cache_self_expires_in, x => 99 &>
EOF
expect => <<'EOF',
x is 1
x is 1
x is 99
EOF
);
#------------------------------------------------------------
$group->add_support ( path => 'support/cache_self_expire_in',
component => <<'EOF',
x is <% $x %>
<%args>
$x
%args>
<%init>
return if $m->cache_self( expire_in => '2s' );
%init>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'cache_self_expire_in',
description => 'test that $m->cache_self respects expire_in parameter',
component => <<'EOF',
<& support/cache_self_expire_in, x => 1 &>
<& support/cache_self_expire_in, x => 2 &>
% sleep 5;
<& support/cache_self_expire_in, x => 99 &>
EOF
expect => <<'EOF',
x is 1
x is 1
x is 99
EOF
);
#------------------------------------------------------------
$group->add_support ( path => 'support/cache_self_expire_if',
component => <<'EOF',
x is <% $x %>
<%args>
$x
%args>
<%init>
return if $m->cache_self( expire_if => sub { $x == 3 } );
%init>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'cache_self_expire_if',
description => 'test that $m->cache_self respects expire_if parameter',
component => <<'EOF',
<& support/cache_self_expire_if, x => 1 &>
<& support/cache_self_expire_if, x => 2 &>
<& support/cache_self_expire_if, x => 3 &>
<& support/cache_self_expire_if, x => 4 &>
EOF
expect => <<'EOF',
x is 1
x is 1
x is 3
x is 3
EOF
);
#------------------------------------------------------------
$group->add_support ( path => 'support/cache_self_with_key',
component => <<'EOF',
x is <% $x %>
<%args>
$x
$key
%args>
<%init>
return if $m->cache_self( key => $key );
%init>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'cache_self_key',
description => 'test $m->cache_self with a key',
component => <<'EOF',
<& support/cache_self_with_key, x => 1, key => 1 &>
<& support/cache_self_with_key, x => 99, key => 99 &>
<& support/cache_self_with_key, x => 1000, key => 1 &>
EOF
expect => <<'EOF',
x is 1
x is 99
x is 1
EOF
);
#------------------------------------------------------------
$group->add_support ( path => 'support/cache_self_and_die',
component => <<'EOF',
<%init>
return if $m->cache_self;
die "argh!";
%init>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'cache_self_error',
description => 'test $m->cache_self with an error to make sure errors are propogated',
component => <<'EOF',
<& support/cache_self_and_die, x => 1, key => 1 &>
EOF
expect_error => qr/argh! at .*/,
);
#------------------------------------------------------------
$group->add_test( name => 'cache_self_scomp',
description => 'make sure that $m->cache_self cooperates with $m->scomp',
component => <<'EOF',
<% $m->scomp( 'support/cache_self', x => 1 ) %>
<% $m->scomp( 'support/cache_self', x => 99 ) %>
EOF
expect => <<'EOF',
x is 1
x is 1
EOF
);
#------------------------------------------------------------
$group->add_support ( path => 'support/cache_self_filtered',
component => <<'EOF',
x is <% $x %>
<%args>
$x
$key => 1
%args>
<%init>
return if $m->cache_self( key => $key );
%init>
<%filter>
$_ = uc $_;
$_ .= ' filtered';
%filter>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'cache_self_filtered',
description => 'test $m->cache_self with a filter block',
component => <<'EOF',
<& support/cache_self_filtered, x => 1 &>
<& support/cache_self_filtered, x => 99 &>
EOF
expect => <<'EOF',
X IS 1
filtered
X IS 1
filtered
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'cache_self_filtered_scomp',
description => 'test $m->cache_self with a filter block callled via $m->scomp',
component => <<'EOF',
<% $m->scomp( 'support/cache_self_filtered', key => 2, x => 1 ) %>
<% $m->scomp( 'support/cache_self_filtered', key => 2, x => 99 ) %>
EOF
expect => <<'EOF',
X IS 1
filtered
X IS 1
filtered
EOF
);
#------------------------------------------------------------
$group->add_support ( path => 'support/cache_self_filtered_2',
component => <<'EOF',
x is <% $x %>
<%args>
$x
%args>
<%init>
return if $m->cache_self;
%init>
<%filter>
s/(\d+)/$1+1/ge;
%filter>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'cache_self_filtered_2',
description => 'make sure that results are only filtered once',
component => <<'EOF',
<& support/cache_self_filtered_2, x => 1 &>
<& support/cache_self_filtered_2, x => 99 &>
EOF
expect => <<'EOF',
x is 2
x is 2
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'expire_if',
description => 'test expire_if',
component => <<'EOF',
<% join(', ', $value1 || 'undef', $value2 || 'undef', $value3 || 'undef') %>
<%init>
my $time = time;
my $cache = $m->cache;
$cache->set('main', 'gardenia');
my $value1 = $cache->get('main', expire_if=>sub { $_[0]->get_created_at <= $time-1 });
my $value2 = $cache->get('main', expire_if=>sub { $_[0]->get_created_at >= $time });
my $value3 = $cache->get('main');
%init>
EOF
expect => <<'EOF',
gardenia, undef, undef
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'busy_lock',
description => 'test busy_lock',
component => <<'EOF',
<% join(', ', $value1 || 'undef', $value2 || 'undef') %>
<%init>
my $time = time;
my $cache = $m->cache;
$cache->set('main', 'gardenia', 0);
my $value1 = $cache->get('main', busy_lock=>'10 sec');
my $value2 = $cache->get('main');
%init>
EOF
expect => <<'EOF',
undef, gardenia
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'busy_lock_expiration',
description => 'test busy_lock expiration',
component => <<'EOF',
<% join(', ', $value1 || 'undef', $value2 || 'undef') %>
<%init>
my $time = time;
my $cache = $m->cache;
$cache->set('main', 'gardenia', 0);
my $value1 = $cache->get('main', busy_lock=>'1 sec');
sleep(1);
my $value2 = $cache->get('main');
%init>
EOF
expect => <<'EOF',
undef, undef
EOF
);
#------------------------------------------------------------
$group->add_support ( path => 'support/cache_self_die',
component => <<'EOF',
die
<%init>
return if $m->cache_self;
die 'foo';
%init>
EOF
);
$group->add_test( name => 'cache_self_death',
description => 'test $m->cache_self and death',
component => <<'EOF',
<%init>
$m->comp( 'support/cache_self_die' );
%init>
EOF
expect_error => qr/foo at/,
);
#------------------------------------------------------------
$group->add_support ( path => 'support/cache_self_abort2',
component => <<'EOF',
going to abort, a = <% $ARGS{a} %>
% $m->abort();
EOF
);
$group->add_support( path => 'support/cache_self_abort',
component => <<'EOF',
<%init>
return if $m->cache_self;
$m->comp( 'cache_self_abort2', a=>5 );
%init>
EOF
);
$group->add_test( name => 'cache_self_abort',
description => 'test $m->cache_self and abort',
component => <<'EOF',
<%init>
eval { $m->comp( 'support/cache_self_abort', a=>5 ) };
eval { $m->comp( 'support/cache_self_abort', a=>10 ) };
%init>
EOF
expect => <<'EOF'
going to abort, a = 5
going to abort, a = 5
EOF
);
#------------------------------------------------------------
$group->add_support( path => 'support/cache_self_with_subexec2',
component => <<'EOF',
This is the subrequest, a = <% $ARGS{a} %>
EOF
);
$group->add_support( path => 'support/cache_self_with_subexec',
component => <<'EOF',
% return if $m->cache_self;
% $m->subexec('cache_self_with_subexec2', a=>$ARGS{a});
EOF
);
$group->add_test( name => 'cache_self_with_subexec',
description => 'test $m->subexec in presence of $m->cache_self',
component => <<'EOF',
<& support/cache_self_with_subexec, a=>5 &>
<& support/cache_self_with_subexec, a=>10 &>
EOF
expect => <<'EOF',
This is the subrequest, a = 5
This is the subrequest, a = 5
EOF
);
#------------------------------------------------------------
$group->add_support( path => 'declined/dhandler',
component => <<'EOF',
decline was called
EOF
);
$group->add_test( name => 'declined/cache_self_decline',
description => 'test $m->decline in presence of $m->cache_self',
component => <<'EOF',
% return if $m->cache_self;
% $m->decline;
EOF
expect => <<'EOF',
decline was called
EOF
);
#------------------------------------------------------------
return $group;
}
HTML-Mason-1.58/t/07a-interp-mcr.t 0000644 0001750 0001750 00000012471 13175376764 016253 0 ustar autarch autarch use strict;
use warnings;
use HTML::Mason::Tests;
my $tests = make_tests();
$tests->run;
sub make_tests
{
my $group = HTML::Mason::Tests->tests_class->new( name => 'interp-mcr',
description => 'In-depth testing of multiple component roots' );
$group->add_test( name => 'no_dynamic_comp_root',
description => 'change comp root without dynamic_comp_root',
pre_code => sub {
my ($interp) = @_;
$interp->comp_root($group->data_dir);
},
skip_component => 1,
call_path => '/',
expect_error => qr/cannot assign new comp_root/,
);
$group->add_test( name => 'change_single_comp_root',
description => 'change single root',
interp_params => {comp_root => '/usr/local/foo',
dynamic_comp_root => 1},
pre_code => sub {
my ($interp) = @_;
$interp->comp_root('/usr/local/bar');
},
skip_component => 1,
call_path => '/',
expect_error => qr/was originally associated with .*, cannot change/,
);
$group->add_test( name => 'reuse_comp_root_key',
description => 'change comp root key mapping',
interp_params => {comp_root => [['foo' => '/usr/local/foo'],
['bar' => '/usr/local/bar']],
dynamic_comp_root => 1},
pre_code => sub {
my ($interp) = @_;
$interp->comp_root([['foo' => '/usr/local/foo'],
['bar' => '/usr/local/baz']]),
},
skip_component => 1,
call_path => '/',
expect_error => qr/was originally associated with .*, cannot change/,
);
# For each test below, change the interpreter's component root on
# the fly, then make sure the right versions of /foo and /bar/ are
# being loaded. Also occasionally remove a component to make sure
# that the next one gets loaded. Run with both static_source=0 and
# static_source=1.
#
foreach my $static_source (0, 1) {
my $interp = $group->_make_interp ( comp_root => $group->comp_root,
data_dir => $group->data_dir,
static_source => $static_source,
dynamic_comp_root => 1,
);
foreach my $root (1..4) {
$group->add_support( path => "/$root/interp-mcr/$static_source/foo",
component => "I am $root/foo, <& bar &>",
);
}
foreach my $root (7..8) {
$group->add_support( path => "/$root/interp-mcr/$static_source/bar",
component => "I am $root/bar",
);
}
my $make_test_for_roots = sub
{
my ($keys, %params) = @_;
my $test_name = "test" . join('', @$keys) . "-" . $static_source;
$group->add_test( name => $test_name,
description => "test roots assigned to " . join(", ", @$keys) . ", static_source=$static_source",
skip_component => 1,
interp => $interp,
pre_code => sub {
$interp->comp_root([map { [$_, $group->comp_root . "/interp-mcr/$_"] } @$keys]);
if ($params{remove}) {
foreach my $comp (qw(foo bar)) {
unlink("mason_tests/$$/comps/interp-mcr/$params{remove}/interp-mcr/$static_source/$comp");
}
}
},
call_path => "/$static_source/foo",
%params
);
};
$make_test_for_roots->([1, 7], expect=>'I am 1/foo, I am 7/bar');
$make_test_for_roots->([1, 2, 3, 4, 8], expect=>'I am 1/foo, I am 8/bar');
if ($static_source) {
$make_test_for_roots->([1, 2, 3, 7], remove=>'1', expect=>'I am 1/foo, I am 7/bar');
} else {
$make_test_for_roots->([1, 2, 3, 7], remove=>'1', expect=>'I am 2/foo, I am 7/bar');
}
$make_test_for_roots->([2, 3, 4, 7], expect=>'I am 2/foo, I am 7/bar');
$make_test_for_roots->([5, 4, 2, 3, 8], expect=>'I am 4/foo, I am 8/bar');
$make_test_for_roots->([5, 6], expect_error => qr/could not find component/);
$make_test_for_roots->([1, 2, 3, 4], expect_error => qr/could not find component/);
}
return $group;
}
HTML-Mason-1.58/t/18-leak.t 0000644 0001750 0001750 00000017457 13175376764 014761 0 ustar autarch autarch use strict;
use warnings;
use HTML::Mason::Tests;
use HTML::Mason::Tools qw(can_weaken);
BEGIN
{
unless ( can_weaken )
{
print "Your installation does not include Scalar::Util::weaken\n";
print "1..0\n";
exit;
}
}
my $tests = make_tests();
$tests->run;
{
package InterpWatcher;
my $_destroy_count = 0;
use base qw(HTML::Mason::Interp);
sub DESTROY { $_destroy_count++ }
sub _destroy_count { $_destroy_count }
sub _clear_destroy_count { $_destroy_count = 0 }
}
{
package RequestWatcher;
my $_destroy_count = 0;
use base qw(HTML::Mason::Request);
sub DESTROY { $_destroy_count++ }
sub _destroy_count { $_destroy_count }
sub _clear_destroy_count { $_destroy_count = 0 }
}
{
# Unfortunately cannot override component class, even by setting
# comp_class, because it is hardcoded in
# Resolver/FileBased.pm. This works as long as Component.pm
# doesn't have any of these methods.
#
package HTML::Mason::Component;
my $_destroy_count = 0;
sub DESTROY { $_destroy_count++ }
sub _destroy_count { $_destroy_count }
sub _clear_destroy_count { $_destroy_count = 0 }
}
{
package SubcomponentWatcher;
my $_destroy_count = 0;
use base qw(HTML::Mason::Component::Subcomponent);
sub DESTROY { $_destroy_count++ }
sub _destroy_count { $_destroy_count }
sub _clear_destroy_count { $_destroy_count = 0 }
}
sub make_tests
{
my $group = HTML::Mason::Tests->tests_class->new( name => '18-leak.t',
description => 'Tests that various memory leaks are no longer with us' );
$group->add_test( name => 'interp_destroy',
description => 'Test that interps with components in cache still get destroyed',
component => <<'EOF',
<%perl>
{
my $interp = InterpWatcher->new();
my $comp = $interp->make_component( comp_source => 'foo' );
}
$m->print("destroy_count = " . InterpWatcher->_destroy_count . "\n");
{
my $interp = InterpWatcher->new();
my $comp = $interp->make_component( comp_source => 'foo' );
}
$m->print("destroy_count = " . InterpWatcher->_destroy_count . "\n");
%perl>
EOF
expect => <<'EOF',
destroy_count = 1
destroy_count = 2
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/support/no_error_comp',
component => <<'EOF',
No error here.
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/support/compile_error_comp',
component => <<'EOF',
<%
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/support/runtime_error_comp',
component => <<'EOF',
% die "bleah";
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/support/recursive_caller_1',
component => <<'EOF',
<%perl>
$m->comp("recursive_caller_2", %ARGS);
return;
%perl>
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/support/recursive_caller_2',
component => <<'EOF',
<%perl>
my $anon_comp = $ARGS{anon_comp};
$m->comp($anon_comp, %ARGS) if $m->depth < 16;
return;
%perl>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'request_destroy',
description => 'Test that requests get destroyed after top-level component error',
interp_params => { request_class => 'RequestWatcher' },
component => <<'EOF',
<%perl>
eval { $m->subexec('support/no_error_comp') };
$m->print("destroy_count = " . RequestWatcher->_destroy_count . "\n");
eval { $m->subexec('support/compile_error_comp') };
$m->print("destroy_count = " . RequestWatcher->_destroy_count . "\n");
eval { $m->subexec('support/not_found_comp') };
$m->print("destroy_count = " . RequestWatcher->_destroy_count . "\n");
%perl>
EOF
expect => <<'EOF',
No error here.
destroy_count = 1
destroy_count = 2
destroy_count = 3
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/support/def_and_method',
component => <<'EOF',
<%init>
$m->comp('.def');
$m->comp('SELF:method');
return;
%init>
<%def .def>
This is a def
%def>
<%method method>
This is a method
%method>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'component_destroy',
description => 'Test that components get freed when cleared from the main cache',
interp_params => { code_cache_max_size => 0 },
component => <<'EOF',
<%perl>
HTML::Mason::Component->_clear_destroy_count;
$m->subexec('support/no_error_comp');
$m->print("destroy_count = " . HTML::Mason::Component->_destroy_count . "\n");
$m->subexec('support/no_error_comp');
$m->print("destroy_count = " . HTML::Mason::Component->_destroy_count . "\n");
eval { $m->subexec('support/runtime_error_comp') };
$m->print("destroy_count = " . HTML::Mason::Component->_destroy_count . "\n");
eval { $m->subexec('support/runtime_error_comp') };
$m->print("destroy_count = " . HTML::Mason::Component->_destroy_count . "\n");
%perl>
EOF
expect => <<'EOF',
No error here.
destroy_count = 1
No error here.
destroy_count = 2
destroy_count = 3
destroy_count = 4
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'component_destroy_static_source',
description => 'Test that components get freed in static source mode',
interp_params => { static_source => 1 },
component => <<'EOF',
<%perl>
HTML::Mason::Component->_clear_destroy_count;
my $anon_comp_text = q|
<%init>
$m->comp("/18-leak.t/support/recursive_caller_1", %ARGS);
return;
%init>
|;
my $anon_comp = $m->interp->make_component( comp_source => $anon_comp_text );
$m->subexec('support/recursive_caller_1', anon_comp=>$anon_comp);
$m->interp->flush_code_cache;
$m->print("destroy_count = " . HTML::Mason::Component->_destroy_count . "\n");
$m->subexec('support/recursive_caller_1', anon_comp=>$anon_comp);
$m->interp->flush_code_cache;
$m->print("destroy_count = " . HTML::Mason::Component->_destroy_count . "\n");
%perl>
EOF
expect => <<'EOF',
destroy_count = 2
destroy_count = 4
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'subcomponent_destroy',
description => 'Test that defs and methods don\'t cause components to leak',
interp_params => { subcomp_class => 'SubcomponentWatcher',
code_cache_max_size => 0 },
component => <<'EOF',
<%perl>
HTML::Mason::Component->_clear_destroy_count;
$m->subexec('support/def_and_method');
$m->print("destroy_count = " . HTML::Mason::Component->_destroy_count . ", " . SubcomponentWatcher->_destroy_count . "\n");
$m->subexec('support/def_and_method');
$m->print("destroy_count = " . HTML::Mason::Component->_destroy_count . ", " . SubcomponentWatcher->_destroy_count . "\n");
%perl>
EOF
expect => <<'EOF',
This is a def
This is a method
destroy_count = 1, 2
This is a def
This is a method
destroy_count = 2, 4
EOF
);
#------------------------------------------------------------
return $group;
}
HTML-Mason-1.58/t/23-leak2.t 0000644 0001750 0001750 00000007123 13175376764 015024 0 ustar autarch autarch 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
%args>
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();
%init>
<&| .sub &>
%# <% $object %> - with this here the object doesn't leak!
<&| .sub &>
<% $object %>
&>
&>
else
<%def .sub>
<% $m->content() %>
%def>
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.58/t/10b-cache-chi.t 0000644 0001750 0001750 00000037313 13175376764 015774 0 ustar autarch autarch use strict;
use warnings;
use HTML::Mason::Tests;
use HTML::Mason::Tools;
# Skip if flock not implemented.
eval { my $fh = do { local *FH; *FH; }; open $fh, $0; flock $fh,1; };
if ($@)
{
print "1..0 # Skipped: flock() is not available on this system\n";
exit;
}
# Skip if CHI not present.
eval "use CHI 0.21";
if ($@)
{
print "1..0 # Skipped: CHI 0.21+ is not installed\n";
exit;
}
my %chi_interp_params = (interp_params => { data_cache_api => 'chi' });
my $tests = make_tests();
$tests->run;
sub make_tests
{
my $group = HTML::Mason::Tests->tests_class->new( name => 'cache',
description => 'Test caching' );
#------------------------------------------------------------
$group->add_support( path => 'support/cache_test',
component => <<'EOF',
<% $result %>
This was<% $cached ? '' : ' not' %> cached.
<%init>
my $cached = 0;
my $result;
my $return;
unless ($result = $m->cache->get('fandango')) {
$result = "Hello Dolly.";
$return = $m->cache->set('fandango', $result) || '';
} else {
$cached = 1;
}
%init>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'cache',
description => 'basic caching functionality',
%chi_interp_params,
component => <<'EOF',
% for (my $i=0; $i<3; $i++) {
<& support/cache_test &>
% }
EOF
expect => <<'EOF',
Hello Dolly.
This was not cached.
Hello Dolly.
This was cached.
Hello Dolly.
This was cached.
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'keys',
description => q|test multiple keys and $m->cache->get_keys|,
%chi_interp_params,
component => <<'EOF',
<%init>
foreach my $key (qw(foo bar baz)) {
$m->cache->set($key, $key);
}
my @keys = sort $m->cache->get_keys;
$m->print("keys in cache: ".join(",",@keys)."\n");
foreach my $key (qw(foo bar baz)) {
my $value = $m->cache->get($key) || "undefined";
$m->print("value for $key is $value\n");
}
$m->cache->remove('foo');
$m->cache->remove('bar');
$m->print("expiring foo and bar...\n");
foreach my $key (qw(foo bar baz)) {
my $value = $m->cache->get($key) || "undefined";
$m->print("value for $key is $value\n");
}
%init>
EOF
expect => <<'EOF',
keys in cache: bar,baz,foo
value for foo is foo
value for bar is bar
value for baz is baz
expiring foo and bar...
value for foo is undefined
value for bar is undefined
value for baz is baz
EOF
);
#------------------------------------------------------------
$group->add_support ( path => 'support/cache_self',
component => <<'EOF',
x is <% $x %>
<%args>
$x
%args>
<%init>
return if $m->cache_self;
%init>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'cache_self',
description => 'test $m->cache_self',
%chi_interp_params,
component => <<'EOF',
<& support/cache_self, x => 1 &>
<& support/cache_self, x => 99 &>
EOF
expect => <<'EOF',
x is 1
x is 1
EOF
);
#------------------------------------------------------------
$group->add_support ( path => 'support/cache_self_expires_in',
component => <<'EOF',
x is <% $x %>
<%args>
$x
%args>
<%init>
return if $m->cache_self( expires_in => '3s' );
%init>
EOF
);
$group->add_test( name => 'cache_self_expires_in',
description => 'test that $m->cache_self respects expires_in parameter',
%chi_interp_params,
component => <<'EOF',
<& support/cache_self_expires_in, x => 1 &>
<& support/cache_self_expires_in, x => 2 &>
% sleep 5;
<& support/cache_self_expires_in, x => 99 &>
EOF
expect => <<'EOF',
x is 1
x is 1
x is 99
EOF
);
#------------------------------------------------------------
$group->add_support ( path => 'support/cache_self_expire_in',
component => <<'EOF',
x is <% $x %>
<%args>
$x
%args>
<%init>
return if $m->cache_self( expire_in => '1s' );
%init>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'cache_self_expire_in',
description => 'test that $m->cache_self respects expire_in parameter',
%chi_interp_params,
component => <<'EOF',
<& support/cache_self_expire_in, x => 1 &>
<& support/cache_self_expire_in, x => 2 &>
% sleep 5;
<& support/cache_self_expire_in, x => 99 &>
EOF
expect => <<'EOF',
x is 1
x is 1
x is 99
EOF
);
#------------------------------------------------------------
$group->add_support ( path => 'support/cache_self_expire_if',
component => <<'EOF',
x is <% $x %>
<%args>
$x
%args>
<%init>
return if $m->cache_self( expire_if => sub { $x == 3 } );
%init>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'cache_self_expire_if',
description => 'test that $m->cache_self respects expire_if parameter',
%chi_interp_params,
component => <<'EOF',
<& support/cache_self_expire_if, x => 1 &>
<& support/cache_self_expire_if, x => 2 &>
<& support/cache_self_expire_if, x => 3 &>
<& support/cache_self_expire_if, x => 4 &>
EOF
expect => <<'EOF',
x is 1
x is 1
x is 3
x is 3
EOF
);
#------------------------------------------------------------
$group->add_support ( path => 'support/cache_self_with_key',
component => <<'EOF',
x is <% $x %>
<%args>
$x
$key
%args>
<%init>
return if $m->cache_self( key => $key );
%init>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'cache_self_key',
description => 'test $m->cache_self with a key',
%chi_interp_params,
component => <<'EOF',
<& support/cache_self_with_key, x => 1, key => 1 &>
<& support/cache_self_with_key, x => 99, key => 99 &>
<& support/cache_self_with_key, x => 1000, key => 1 &>
EOF
expect => <<'EOF',
x is 1
x is 99
x is 1
EOF
);
#------------------------------------------------------------
$group->add_support ( path => 'support/cache_self_and_die',
component => <<'EOF',
<%init>
return if $m->cache_self;
die "argh!";
%init>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'cache_self_error',
description => 'test $m->cache_self with an error to make sure errors are propogated',
%chi_interp_params,
component => <<'EOF',
<& support/cache_self_and_die, x => 1, key => 1 &>
EOF
expect_error => qr/argh! at .*/,
);
#------------------------------------------------------------
$group->add_test( name => 'cache_self_scomp',
description => 'make sure that $m->cache_self cooperates with $m->scomp',
%chi_interp_params,
component => <<'EOF',
<% $m->scomp( 'support/cache_self', x => 1 ) %>
<% $m->scomp( 'support/cache_self', x => 99 ) %>
EOF
expect => <<'EOF',
x is 1
x is 1
EOF
);
#------------------------------------------------------------
$group->add_support ( path => 'support/cache_self_filtered',
component => <<'EOF',
x is <% $x %>
<%args>
$x
$key => 1
%args>
<%init>
return if $m->cache_self( key => $key );
%init>
<%filter>
$_ = uc $_;
$_ .= ' filtered';
%filter>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'cache_self_filtered',
description => 'test $m->cache_self with a filter block',
%chi_interp_params,
component => <<'EOF',
<& support/cache_self_filtered, x => 1 &>
<& support/cache_self_filtered, x => 99 &>
EOF
expect => <<'EOF',
X IS 1
filtered
X IS 1
filtered
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'cache_self_filtered_scomp',
description => 'test $m->cache_self with a filter block callled via $m->scomp',
%chi_interp_params,
component => <<'EOF',
<% $m->scomp( 'support/cache_self_filtered', key => 2, x => 1 ) %>
<% $m->scomp( 'support/cache_self_filtered', key => 2, x => 99 ) %>
EOF
expect => <<'EOF',
X IS 1
filtered
X IS 1
filtered
EOF
);
#------------------------------------------------------------
$group->add_support ( path => 'support/cache_self_filtered_2',
component => <<'EOF',
x is <% $x %>
<%args>
$x
%args>
<%init>
return if $m->cache_self;
%init>
<%filter>
s/(\d+)/$1+1/ge;
%filter>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'cache_self_filtered_2',
description => 'make sure that results are only filtered once',
%chi_interp_params,
component => <<'EOF',
<& support/cache_self_filtered_2, x => 1 &>
<& support/cache_self_filtered_2, x => 99 &>
EOF
expect => <<'EOF',
x is 2
x is 2
EOF
);
#------------------------------------------------------------
# Note: expire_if works differently with CHI than with previous Mason caching.
# CHI does not actually expire the value (which would entail an extra write),
# it just returns false from get(). This was different in earlier verisons of CHI,
# so we don't test for $value3 as we do in the comprable 10-cache.t test.
$group->add_test( name => 'expire_if',
description => 'test expire_if',
%chi_interp_params,
component => <<'EOF',
<% join(', ', $value1 || 'undef', $value2 || 'undef' ) %>
<%init>
my $time = time;
my $cache = $m->cache;
$cache->set('main', 'gardenia');
my $value1 = $cache->get('main', expire_if=>sub { $_[0]->get_created_at <= $time-1 });
my $value2 = $cache->get('main', expire_if=>sub { $_[0]->get_created_at >= $time });
%init>
EOF
expect => <<'EOF',
gardenia, undef
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'busy_lock',
description => 'test busy_lock',
%chi_interp_params,
component => <<'EOF',
<% join(', ', $value1 || 'undef', $value2 || 'undef') %>
<%init>
my $time = time;
my $cache = $m->cache;
$cache->set('main', 'gardenia', 0);
my $value1 = $cache->get('main', busy_lock=>'10 sec');
my $value2 = $cache->get('main');
%init>
EOF
expect => <<'EOF',
undef, gardenia
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'busy_lock_expiration',
description => 'test busy_lock expiration',
%chi_interp_params,
component => <<'EOF',
<% join(', ', $value1 || 'undef', $value2 || 'undef') %>
<%init>
my $time = time;
my $cache = $m->cache;
$cache->set('main', 'gardenia', 0);
my $value1 = $cache->get('main', busy_lock=>'1 sec');
sleep(1);
my $value2 = $cache->get('main');
%init>
EOF
expect => <<'EOF',
undef, undef
EOF
);
#------------------------------------------------------------
$group->add_support ( path => 'support/cache_self_die',
component => <<'EOF',
die
<%init>
return if $m->cache_self;
die 'foo';
%init>
EOF
);
$group->add_test( name => 'cache_self_death',
description => 'test $m->cache_self and death',
%chi_interp_params,
component => <<'EOF',
<%init>
$m->comp( 'support/cache_self_die' );
%init>
EOF
expect_error => qr/foo at/,
);
#------------------------------------------------------------
$group->add_support ( path => 'support/cache_self_abort2',
component => <<'EOF',
going to abort, a = <% $ARGS{a} %>
% $m->abort();
EOF
);
$group->add_support( path => 'support/cache_self_abort',
component => <<'EOF',
<%init>
return if $m->cache_self;
$m->comp( 'cache_self_abort2', a=>5 );
%init>
EOF
);
$group->add_test( name => 'cache_self_abort',
description => 'test $m->cache_self and abort',
%chi_interp_params,
component => <<'EOF',
<%init>
eval { $m->comp( 'support/cache_self_abort', a=>5 ) };
eval { $m->comp( 'support/cache_self_abort', a=>10 ) };
%init>
EOF
expect => <<'EOF'
going to abort, a = 5
going to abort, a = 5
EOF
);
#------------------------------------------------------------
$group->add_support( path => 'support/cache_self_with_subexec2',
component => <<'EOF',
This is the subrequest, a = <% $ARGS{a} %>
EOF
);
$group->add_support( path => 'support/cache_self_with_subexec',
component => <<'EOF',
% return if $m->cache_self;
% $m->subexec('cache_self_with_subexec2', a=>$ARGS{a});
EOF
);
$group->add_test( name => 'cache_self_with_subexec',
description => 'test $m->subexec in presence of $m->cache_self',
%chi_interp_params,
component => <<'EOF',
<& support/cache_self_with_subexec, a=>5 &>
<& support/cache_self_with_subexec, a=>10 &>
EOF
expect => <<'EOF',
This is the subrequest, a = 5
This is the subrequest, a = 5
EOF
);
#------------------------------------------------------------
$group->add_support( path => 'declined/dhandler',
component => <<'EOF',
decline was called
EOF
);
$group->add_test( name => 'declined/cache_self_decline',
description => 'test $m->decline in presence of $m->cache_self',
%chi_interp_params,
component => <<'EOF',
% return if $m->cache_self;
% $m->decline;
EOF
expect => <<'EOF',
decline was called
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'data_cache_defaults',
description => 'modifying data_cache_defaults',
interp_params => { data_cache_api => 'chi', data_cache_defaults => { driver => 'Memory', global => 1 } },
component => <<'EOF',
Using driver '<% $m->cache->short_driver_name %>'
% for (my $i=0; $i<3; $i++) {
<& support/cache_test &>
% }
EOF
expect => <<'EOF',
Using driver 'Memory'
Hello Dolly.
This was not cached.
Hello Dolly.
This was cached.
Hello Dolly.
This was cached.
EOF
);
#------------------------------------------------------------
return $group;
}
HTML-Mason-1.58/t/17-print.t 0000644 0001750 0001750 00000002377 13175376764 015173 0 ustar autarch autarch 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.58/t/09-component.t 0000644 0001750 0001750 00000024201 13175376764 016030 0 ustar autarch autarch use strict;
use warnings;
use HTML::Mason::Tests;
my $tests = make_tests();
$tests->run;
sub make_tests
{
my $group = HTML::Mason::Tests->tests_class->new( name => '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
%args>
%def>
<%method meth>
% my $adj = 'sad';
I am a <% $adj %> method.
<%args>
$crucial
$useless=>17
%args>
%method>
% 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')
%args>
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' );
%def>
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 '', @_ %>.
%def>
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';
%def>
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
%method>
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
%attr>
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>
<%method y>
y
%method>
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>
<%def y>
y
%def>
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
%attr>
EOF
expect => <<'EOF',
x
y
EOF
);
#------------------------------------------------------------
$group->add_support( path => 'args_copying_helper',
component => <<'EOF',
<%init>
$_[1] = 4;
$b = 5;
$ARGS{'c'} = 6;
%init>
<%args>
$a
$b
%args>
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);
%init>
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);
%init>
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);
%init>
EOF
expect_error => 'Modification of a read-only value',
);
#------------------------------------------------------------
return $group;
}
HTML-Mason-1.58/t/22-path-security.t 0000644 0001750 0001750 00000000663 13175376764 016630 0 ustar autarch autarch 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.58/t/06a-compiler_obj.t 0000644 0001750 0001750 00000001215 13175376764 016630 0 ustar autarch autarch use strict;
use warnings;
use HTML::Mason;
use Test;
plan tests => 4;
ok 1; # Loaded
# We use the Interp class as a front-end to the compiler, but we're
# really testing the compiler here. We could change this to eliminate
# the Interp stuff, probably.
my $interp = HTML::Mason::Interp->new;
ok $interp;
# Make sure the compiler can recover properly after a syntax error
eval {$interp->make_component( comp_source => <<'EOF' )};
<&| syntax_error, in => "this" &>
component
&|>
EOF
ok $@, qr{ending tag};
eval {$interp->make_component( comp_source => <<'EOF' )};
<&| syntax_error, in => "this" &>
component
&>
EOF
ok $@, '';
HTML-Mason-1.58/t/14-cgi.t 0000644 0001750 0001750 00000010502 13175376764 014563 0 ustar autarch autarch use strict;
use warnings;
use HTML::Mason::CGIHandler;
use CGI qw(-no_debug); # Prevent "(offline mode: enter name=value pairs on standard input)"
{
# This class simulates CGI requests. It's rather ugly, it tries
# to fool HTML::Mason::Tests into thinking that CGIHandler is a subclass of Interp.
package CGITest;
use HTML::Mason::Tests;
use base 'HTML::Mason::Tests';
sub _run_test
{
my $self = shift;
my $test = $self->{current_test};
$self->{buffer} = '';
my %interp_params = ( exists $test->{interp_params} ?
%{ $test->{interp_params} } :
() );
my $interp = HTML::Mason::CGIHandler->new
(comp_root => $self->comp_root,
data_dir => $self->data_dir,
%interp_params,
);
eval { local $CGI::LIST_CONTEXT_WARN = 0; $self->_execute($interp) };
return $self->check_result($@);
}
sub _execute
{
my ($self, $interp) = @_; # $interp is a CGIHandler object
my $test = $self->{current_test};
#print "Calling $test->{name} test with path: $test->{call_path}\n" if $DEBUG;
$test->{pretest_code}->() if $test->{pretest_code};
CGI::initialize_globals(); # make sure CGI doesn't cache previous query
$ENV{REQUEST_METHOD} = 'GET'; # CGI.pm needs this, or it won't process args
$ENV{PATH_INFO} = $test->{call_path};
$ENV{QUERY_STRING} = join '=', @{$test->{call_args}};
$interp->handle_request($self->{buffer});
}
}
$ENV{DOCUMENT_ROOT} = CGITest->comp_root;
my $group = CGITest->new( name => 'cgi',
description => 'HTML::Mason::CGIHandler class',
interp_class => 'HTML::Mason::CGIHandler',
);
#------------------------------------------------------------
my $basic_header = "Content-Type: text/html";
$basic_header .= '; charset=ISO-8859-1' if CGI->can('charset');
$basic_header .= "${CGI::CRLF}${CGI::CRLF}";
$group->add_test( name => 'basic',
description => 'Test basic CGIHandler operation',
component => 'some text',
expect => "${basic_header}some text",
);
#------------------------------------------------------------
$group->add_test( name => 'dynamic',
description => 'Test CGIHandler operation with dynamic components',
component => 'some <% "dynamic" %> text',
expect => "${basic_header}some dynamic text",
);
#------------------------------------------------------------
$group->add_test( name => 'args',
description => 'Test CGIHandler operation with arguments',
call_args => [arg => 'dynamic'],
component => 'some <% $ARGS{arg} %> text',
expect => "${basic_header}some dynamic text",
);
#------------------------------------------------------------
$group->add_test( name => 'cgi_object',
description => 'Test access to the CGI request object',
call_args => [arg => 'boohoo'],
component => q{some <% $m->cgi_object->param('arg') %> cryin'},
expect => "${basic_header}some boohoo cryin'",
);
#------------------------------------------------------------
$group->add_test( name => 'fatal_error',
description => 'Test fatal error_mode',
interp_params => { error_mode => 'fatal', error_format => 'text' },
component => q{% die 'dead';},
expect_error => qr/dead at .+/,
);
$group->add_test( name => 'headers',
description => 'Test header generation',
component => q{% $r->header_out('foo' => 'bar');},
expect => qr/Foo: bar/i,
);
$group->add_test( name => 'redirect_headers',
description => 'Test header generation',
component => q{% $m->redirect('/hello.html');},
expect => qr/Status: 302\s+Location: \/hello\.html|Location: \/hello\.html\s+Status: 302/i,
);
#------------------------------------------------------------
$group->run;
HTML-Mason-1.58/t/07-interp.t 0000644 0001750 0001750 00000065205 13175376764 015336 0 ustar autarch autarch use strict;
use warnings;
use File::Spec;
use HTML::Mason::Tests;
use HTML::Mason::Tools qw(load_pkg);
use IO::File;
my $tests = make_tests();
$tests->run;
sub make_tests
{
my $group = HTML::Mason::Tests->tests_class->new( name => 'interp',
description => 'interp object functionality',
pre_test_cleanup => 0 );
#------------------------------------------------------------
$group->add_support( path => '/autohandler_test/autohandler',
component => <<'EOF',
The recursive autohandler: <% $m->current_comp->path %>
% $m->call_next;
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'no recursive autohandlers',
description => 'tests turning off recursive autohandlers',
call_path => '/autohandler_test/subdir/hello',
component => <<'EOF',
Hello World!
EOF
expect => <<'EOF',
The recursive autohandler: /interp/autohandler_test/autohandler
Hello World!
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'no autohandlers',
description => 'tests turning off autohandlers by setting name to ""',
call_path => '/autohandler_test/subdir/off',
interp_params => { autohandler_name => '' },
component => <<'EOF',
Hello World! Autohandlers are <% $m->interp->use_autohandlers ? 'on' : 'off' %>
EOF
expect => <<'EOF',
Hello World! Autohandlers are off
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/autohandler_test/subdir/plainfile',
component => <<'EOF',
The local autohandler: <% $m->current_comp->path %>
% $m->call_next;
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'alternate autohandler name',
description => 'tests that providing an alternate name for autohandlers works',
call_path => '/autohandler_test/subdir/hello',
interp_params => { autohandler_name => 'plainfile' },
component => <<'EOF',
Hello World!
EOF
expect => <<'EOF',
The local autohandler: /interp/autohandler_test/subdir/plainfile
Hello World!
EOF
);
my $alt_root = File::Spec->catdir( HTML::Mason::Tests->tests_class->base_path, 'alt_root' );
my @roots = ( [ main => HTML::Mason::Tests->tests_class->comp_root],
[ alt => $alt_root ] );
#HACK!
HTML::Mason::Tests->tests_class->write_comp( '/alt_root/interp/comp_root_test/private2',
File::Spec->catdir( $alt_root, 'interp', 'comp_root_test' ),
'private2',
<<'EOF' );
private2 in the alternate component root.
<& showcomp &>
EOF
HTML::Mason::Tests->tests_class->write_comp( '/alt_root/interp/comp_root_test/shared',
File::Spec->catdir( $alt_root, 'interp', 'comp_root_test' ),
'shared',
<<'EOF' );
shared.html in the alternate component root.
<& showcomp &>
EOF
#------------------------------------------------------------
$group->add_support( path => '/comp_root_test/showcomp',
component => <<'EOF',
% my $comp = $m->callers(1);
<& /shared/display_comp_obj, comp=>$comp &>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'shared',
description => 'test that component in both comp_roots is called in first comp_root',
call_path => '/comp_root_test/shared',
interp_params => { comp_root => \@roots },
component => <<'EOF',
shared in the main component root.
<& showcomp &>
EOF
expect => <<'EOF',
shared in the main component root.
Declared args:
I am not a subcomponent.
I am not a method.
I am file-based.
My short name is shared.
My directory is /interp/comp_root_test.
I have 0 subcomponent(s).
My title is /interp/comp_root_test/shared [main].
My path is /interp/comp_root_test/shared.
My comp_id is /main/interp/comp_root_test/shared.
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'private1',
description => 'test that component in first comp_root is found',
call_path => '/comp_root_test/private1',
interp_params => { comp_root => \@roots },
component => <<'EOF',
private1 in the main component root.
<& showcomp &>
EOF
expect => <<'EOF',
private1 in the main component root.
Declared args:
I am not a subcomponent.
I am not a method.
I am file-based.
My short name is private1.
My directory is /interp/comp_root_test.
I have 0 subcomponent(s).
My title is /interp/comp_root_test/private1 [main].
My path is /interp/comp_root_test/private1.
My comp_id is /main/interp/comp_root_test/private1.
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'private2',
description => 'test that component in second comp_root is found',
call_path => '/comp_root_test/private2',
path => '/foo', # its already written. HACK!
interp_params => { comp_root => \@roots },
component => <<'EOF',
foo
EOF
expect => <<'EOF',
private2 in the alternate component root.
Declared args:
I am not a subcomponent.
I am not a method.
I am file-based.
My short name is private2.
My directory is /interp/comp_root_test.
I have 0 subcomponent(s).
My title is /interp/comp_root_test/private2 [alt].
My path is /interp/comp_root_test/private2.
My comp_id is /alt/interp/comp_root_test/private2.
EOF
);
#------------------------------------------------------------
$group->add_support( path => 'support/recurse_test',
component => <<'EOF',
Entering <% $count %>
% if ($count < $max) {
<& recurse_test, count=>$count+1, max=>$max &>
% }
Exiting <% $count %>
\
<%args>
$count=>0
$max
%args>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'max_recurse_1',
description => 'Test that recursion 8 levels deep is allowed',
component => <<'EOF',
% eval { $m->comp('support/recurse_test', max=>8) };
EOF
expect => <<'EOF',
Entering 0
Entering 1
Entering 2
Entering 3
Entering 4
Entering 5
Entering 6
Entering 7
Entering 8
Exiting 8
Exiting 7
Exiting 6
Exiting 5
Exiting 4
Exiting 3
Exiting 2
Exiting 1
Exiting 0
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'max_recurse_2',
description => 'Test that recursion is stopped after 32 levels',
interp_params => { autoflush => 1 },
component => '<& support/recurse_test, max=>48 &>',
expect_error => qr{32 levels deep in component stack \(infinite recursive call\?\)},
);
#------------------------------------------------------------
$group->add_test( name => 'max_recurse_3',
description => 'Test interp max_recurse param',
interp_params => { max_recurse => 50 },
component => <<'EOF',
% eval { $m->comp('support/recurse_test', max=>48) };
<% $@ ? "Error" : "No error" %>
EOF
expect => <<'EOF',
Entering 0
Entering 1
Entering 2
Entering 3
Entering 4
Entering 5
Entering 6
Entering 7
Entering 8
Entering 9
Entering 10
Entering 11
Entering 12
Entering 13
Entering 14
Entering 15
Entering 16
Entering 17
Entering 18
Entering 19
Entering 20
Entering 21
Entering 22
Entering 23
Entering 24
Entering 25
Entering 26
Entering 27
Entering 28
Entering 29
Entering 30
Entering 31
Entering 32
Entering 33
Entering 34
Entering 35
Entering 36
Entering 37
Entering 38
Entering 39
Entering 40
Entering 41
Entering 42
Entering 43
Entering 44
Entering 45
Entering 46
Entering 47
Entering 48
Exiting 48
Exiting 47
Exiting 46
Exiting 45
Exiting 44
Exiting 43
Exiting 42
Exiting 41
Exiting 40
Exiting 39
Exiting 38
Exiting 37
Exiting 36
Exiting 35
Exiting 34
Exiting 33
Exiting 32
Exiting 31
Exiting 30
Exiting 29
Exiting 28
Exiting 27
Exiting 26
Exiting 25
Exiting 24
Exiting 23
Exiting 22
Exiting 21
Exiting 20
Exiting 19
Exiting 18
Exiting 17
Exiting 16
Exiting 15
Exiting 14
Exiting 13
Exiting 12
Exiting 11
Exiting 10
Exiting 9
Exiting 8
Exiting 7
Exiting 6
Exiting 5
Exiting 4
Exiting 3
Exiting 2
Exiting 1
Exiting 0
No error
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/support/code_cache/show_code_cache',
component => <<'EOF',
% $m->interp->purge_code_cache();
% my $code_cache = $m->interp->{code_cache};
% my @plain_comp_names = sort grep { /^plain/ } map { $_->{comp}->name } values(%$code_cache);
Code cache contains: <% join(", ", @plain_comp_names) %>
EOF
);
#------------------------------------------------------------
foreach my $i (1..7) {
$group->add_support( path => "/support/code_cache/plain$i",
component => "",
);
}
$group->add_support( path => "/support/code_cache/call_plain_comps",
component => <<'EOF',
<& plain1 &><& plain1 &><& plain1 &><& plain1 &><& plain1 &><& plain1 &><& plain1 &>
<& plain2 &><& plain2 &><& plain2 &><& plain2 &><& plain2 &>
<& plain3 &><& plain3 &><& plain3 &>
<& plain4 &>
<& plain5 &><& plain5 &>
<& plain6 &><& plain6 &><& plain6 &><& plain6 &>
<& plain7 &><& plain7 &><& plain7 &><& plain7 &><& plain7 &><& plain7 &>
EOF
);
#------------------------------------------------------------
my $create_code_cache_test = sub {
my ($max_size, $expected) = @_;
$group->add_test( name => "code_cache_$max_size",
interp_params => { code_cache_max_size => $max_size },
description => "code cache: max_size = $max_size",
component => <<'EOF',
<%init>
$m->scomp('support/code_cache/call_plain_comps');
$m->scomp('support/code_cache/call_plain_comps');
$m->comp('support/code_cache/show_code_cache');
%init>
EOF
expect => <<"EOF",
Code cache contains: $expected
EOF
);
};
$create_code_cache_test->('unlimited', 'plain1, plain2, plain3, plain4, plain5, plain6, plain7');
$create_code_cache_test->(0, '');
$create_code_cache_test->(4, 'plain1, plain2, plain7');
$create_code_cache_test->(8, 'plain1, plain2, plain3, plain5, plain6, plain7');
#------------------------------------------------------------
$group->add_test( name => 'dhandler_name',
description => 'Test that providing an alternate name for dhandlers works',
path => 'dhandler_test/plainfile',
call_path => 'dhandler_test/foo/blag',
interp_params => { dhandler_name => 'plainfile' },
component => <<'EOF',
dhandler arg = <% $m->dhandler_arg %>
EOF
expect => <<'EOF',
dhandler arg = foo/blag
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'dhandler_name2',
description => 'Shut off dhandlers',
path => 'dhandler_test/plainfile',
call_path => 'dhandler_test/foo/blag',
interp_params => { dhandler_name => '' },
component => 'foo',
expect_error => qr{could not find component},
);
#------------------------------------------------------------
$group->add_test( name => 'no dhandlers',
description => 'tests turning off dhandlers by setting name to ""',
call_path => 'dhandler_test/exists',
interp_params => { dhandler_name => '' },
component => <<'EOF',
Hello World! dhandlers are <% $m->use_dhandlers ? 'on' : 'off' %>
EOF
expect => <<'EOF',
Hello World! dhandlers are off
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'dhandler_name0',
description => 'dhandler_name => 0 should not shut off dhandlers',
path => 'dhandler_test/0',
call_path => 'dhandler_test/foo/blag',
interp_params => { dhandler_name => '0' },
component => <<'EOF',
dhandler arg = <% $m->dhandler_arg %>
comp = <% $m->current_comp->name %>
EOF
expect => <<'EOF',
dhandler arg = foo/blag
comp = 0
EOF
);
#------------------------------------------------------------
$group->add_support( path => 'mode_test',
component => <<'EOF',
First of all I'd
% $m->clear_buffer;
No what I really wanted to say was
% $m->clear_buffer;
Oh never mind.
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'no_autoflush_mode',
description => 'Test that no autoflush (batch) mode setting works',
component => <<'EOF',
<& mode_test &>
EOF
expect => <<'EOF',
Oh never mind.
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'autoflush_mode',
description => 'Test that autoflush setting works',
interp_params => { autoflush => 1 },
component => <<'EOF',
<& mode_test &>
EOF
expect => <<'EOF',
First of all I'd
No what I really wanted to say was
Oh never mind.
EOF
);
#------------------------------------------------------------
$group->add_support( path => 'preloads_test/show_code_cache',
component => <<'EOF',
Code cache contains:
% my %c = %{$m->interp->{code_cache}};
<% join("\n",sort(keys(%c))) %>
EOF
);
#------------------------------------------------------------
$group->add_support( path => 'preloads_test/hello',
component => 'hello',
);
#------------------------------------------------------------
$group->add_support( path => 'preloads_test/goodbye',
component => 'goodbye',
);
#------------------------------------------------------------
$group->add_support( path => 'preloads_test/howareyou',
component => 'howareyou',
);
#------------------------------------------------------------
$group->add_support( path => 'preloads_test/subdir/in_a_subdir',
component => 'howareyou',
);
#------------------------------------------------------------
$group->add_test( name => 'preload_1',
description => 'Make sure no preloading is done by default',
component => <<'EOF',
<& preloads_test/show_code_cache &>
EOF
expect => <<'EOF',
Code cache contains:
/interp/preload_1
/interp/preloads_test/show_code_cache
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'preload_2',
description => 'Preload a single component by filename',
interp_params => { preloads => [ '/interp/preloads_test/hello' ] },
component => <<'EOF',
<& preloads_test/show_code_cache &>
EOF
expect => <<'EOF',
Code cache contains:
/interp/preload_2
/interp/preloads_test/hello
/interp/preloads_test/show_code_cache
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'preload_3',
description => 'Preload all components (including subdirectory) by glob pattern',
interp_params => { preloads => [ '/interp/preloads_test/*', '/interp/preloads_test/*/*' ] },
component => <<'EOF',
<& preloads_test/show_code_cache &>
EOF
expect => <<'EOF',
Code cache contains:
/interp/preload_3
/interp/preloads_test/goodbye
/interp/preloads_test/hello
/interp/preloads_test/howareyou
/interp/preloads_test/show_code_cache
/interp/preloads_test/subdir/in_a_subdir
EOF
);
#------------------------------------------------------------
my $interp = HTML::Mason::Tests->tests_class->_make_interp
( data_dir => $group->data_dir,
comp_root => $group->comp_root,
);
$interp->compiler->allow_globals( qw($global) );
$interp->set_global( global => 'parsimmon' );
$group->add_test( name => 'globals',
description => 'Test setting a global in interp & compiler objects',
interp => $interp,
component => <<'EOF',
<% $global %>
EOF
expect => <<'EOF',
parsimmon
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/comp_path_test/a/b/c/foo',
component => <<'EOF',
I am foo!
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'process_comp_path',
description => 'Test that component paths cannot be resolved outside the comp root',
component => <<'EOF',
<& ../../../../../interp/comp_path_test/a/b/c/../c/foo &>
EOF
expect => <<'EOF'
I am foo!
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'process_comp_path2',
description => 'Test that component paths containing /../ work as long they stay in the comp root',
path => '/comp_path_test/a/b/d/process',
call_path => '/comp_path_test/a/b/d/process',
component => <<'EOF',
<& ../c/foo &>
EOF
expect => <<'EOF'
I am foo!
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'default_warnings',
description => 'test that warnings during component compilation cause an exception except for redefined subs',
component => <<'EOF',
a global: <% $GLOBAL %>
<%once>
sub foo { 1 }
sub foo { 1 }
%once>
EOF
expect_error => qr/Global symbol "\$GLOBAL" requires explicit package name/,
);
#------------------------------------------------------------
$group->add_test( name => 'ignore_warnings',
description => 'test that setting ignore_warnings_exp works',
interp_params => { ignore_warnings_expr => qr/useless use of "re" pragma/i },
component => <<'EOF',
% use re;
foo
EOF
expect => <<'EOF',
foo
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'ignore_all_warnings',
description => 'test ignoring all warnings',
interp_params =>
{ ignore_warnings_expr => '.' },
component => <<'EOF',
<%once>
sub foo { 1 }
sub foo { 1 }
%once>
foo
EOF
expect => <<'EOF',
foo
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'make_anonymous_component',
description => 'test make_component() without a path',
component => <<'EOF',
<%init>
my $ctext = q|
% my $x = 'Hello, ';
<% $x %>|;
my $comp = $m->interp->make_component( comp_source => $ctext );
%init>
% $m->comp($comp);
World
EOF
expect => <<'EOF',
Hello, World
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'read_write_contained',
description => 'test that we can read/write contained object params',
component => <<'EOF',
% $m->autoflush(1);
% my $req = $m->make_subrequest(comp=>($m->interp->make_component(comp_source => 'hi')));
% $m->autoflush(0);
autoflush for new request is <% $req->autoflush %>
EOF
expect => <<'EOF',
autoflush for new request is 1
EOF
);
#------------------------------------------------------------
if ( load_pkg('Cache::Cache') && load_pkg('Cache::MemoryCache') )
{
$group->add_test( name => 'no_data_dir',
description => 'test interp without a data directory',
interp => HTML::Mason::Tests->tests_class->_make_interp( comp_root => HTML::Mason::Tests->tests_class->comp_root ),
component => <<'EOF',
Hello World!
<% ref $m->cache %>
EOF
expect => <<'EOF',
Hello World!
HTML::Mason::Cache::MemoryCache
EOF
);
}
#------------------------------------------------------------
$group->add_support( path => 'no_comp_root_helper',
component => <<'EOF',
I am rootless
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'no_comp_root',
description => 'test interp without a comp root or data dir',
component => <<'EOF',
% my $buffer;
% my $interp = HTML::Mason::Tests->tests_class->_make_interp( out_method => \$buffer );
% $interp->exec( "/mason_tests/$$/comps/interp/no_comp_root_helper" );
<% $buffer %>
EOF
expect => <<'EOF',
I am rootless
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'make_component_error',
description => 'make sure a proper exception is thrown with make_component syntax errors',
component => <<'EOF',
% $m->interp->make_component(comp_source => '<% &>');
EOF
# Would be better to do $@->isa(syntax-error) or the like.
expect_error => qr/without matching/,
);
#------------------------------------------------------------
if ( $] < 5.012 && load_pkg('Switch') )
{
$group->add_test( name => 'source_filter',
description => 'make sure source filters work',
interp_params =>
{ ignore_warnings_expr =>
qr/uninitialized|Subroutine .* redefined/i },
component => <<'EOF',
no explosion
<%init>
use Switch;
my $x = 1;
switch ($x) { case 1 { $x = 2 } }
%init>
EOF
expect => <<'EOF',
no explosion
EOF
);
}
#------------------------------------------------------------
$group->add_test( name => 'escape_flags',
description => 'test setting escape flags via constructor',
interp_params =>
{ escape_flags => { uc => sub { ${$_[0]} = uc ${$_[0]} } } },
component => <<'EOF',
<% 'upper case' | uc %>
EOF
expect => <<'EOF',
UPPER CASE
EOF
);
#------------------------------------------------------------
# Note that setting out_method on the interp affects _future_
# request objects, not the current one. This is just a test to
# make sure we can set it at all.
$group->add_test( name => 'set_out_method',
description => 'test setting out_method on the interp object',
component => <<'EOF',
foo
% $m->interp->out_method( sub {} );
bar
baz
EOF
expect => <<'EOF',
foo
bar
baz
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/support/corrupt_object_file',
component => "I was loaded\n",
);
$group->add_test( name => 'corrupt_object_file',
description => 'test that Mason can recover from a corrupt or empty object file',
component => <<'EOF',
<%init>
my $path = 'support/corrupt_object_file';
my $comp = $m->fetch_comp('support/corrupt_object_file');
$m->comp($comp);
my $object_file = $comp->object_file;
die "object file does not exist" unless -f $object_file;
die "object file is not writable" unless -w $object_file;
my $corrupt_object_file_and_reload = sub {
my ($content) = @_;
my $original_object_file_size = (stat($object_file))[7];
my $fh = new IO::File ">$object_file"
or die "cannot write $object_file: $!";
$fh->print($content);
$fh->close();
die "object file is not the right size after corruption"
unless (stat($object_file))[7] == length($content);
$m->interp->flush_code_cache();
$m->comp($path);
die "object file is the same size after reloading"
if (stat($object_file))[7] == length($content);
};
$corrupt_object_file_and_reload->("");
$corrupt_object_file_and_reload->(0);
$corrupt_object_file_and_reload->("return 5");
$corrupt_object_file_and_reload->("slkd%^^&*(@@");
$corrupt_object_file_and_reload->("die 'bleah';");
%init>
EOF
expect => <<'EOF',
I was loaded
I was loaded
I was loaded
I was loaded
I was loaded
I was loaded
EOF
);
return $group;
}
HTML-Mason-1.58/t/04-misc.t 0000644 0001750 0001750 00000021367 13175376764 014766 0 ustar autarch autarch use strict;
use warnings;
use File::Spec;
use HTML::Mason::Tests;
my $tests = make_tests();
$tests->run;
sub make_tests
{
my $group = HTML::Mason::Tests->tests_class->new( name => 'misc',
description => 'autohandler and dhandler functionality' );
#------------------------------------------------------------
$group->add_support( path => '/autohandler_test/autohandler',
component => <<'EOF',
<& header &>
Autohandler comp: <% $m->fetch_next->title %>
% my $buf;
% $m->call_next(b=>$a*2);
<& footer &>
<%args>
$a=>5
%args>
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/autohandler_test/header',
component => <<'EOF',
>
The Site
<%args>
$bgcolor=>'white'
%args>
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/autohandler_test/footer',
component => <<'EOF',
Copyright 1999 Schmoopie Inc.
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'autohandler',
path => '/autohandler_test/hello',
call_path => '/autohandler_test/hello',
description => 'autohandler test',
component => <<'EOF',
Hello World!
The answer is <% $b %>.
<%args>
$b
%args>
EOF
expect => <<'EOF',
The Site
Autohandler comp: /misc/autohandler_test/hello
Hello World!
The answer is 10.
Copyright 1999 Schmoopie Inc.
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/dhandler_test/dhandler',
component => <<'EOF',
dhandler = <% $m->current_comp->title %>
dhandler arg = <% $m->dhandler_arg %>
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/dhandler_test/subdir/dhandler',
component => <<'EOF',
% $m->decline if $m->dhandler_arg eq 'leaf3';
% $m->decline if $m->dhandler_arg eq 'slashes';
% $m->decline if $m->dhandler_arg eq 'buffers';
dhandler = <% $m->current_comp->title %>
dhandler arg = <% $m->dhandler_arg %>
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/dhandler_test/subdir/autohandler',
component => <<'EOF',
Header
<% $m->call_next %>
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/dhandler_test/bar/dhandler',
component => <<'EOF',
dhandler = <% $m->current_comp->title %>
dhandler arg = <% $m->dhandler_arg %>
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/dhandler_test/buff/dhandler',
component => <<'EOF',
Buffer stack size: <% scalar $m->buffer_stack %>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'dhandler1',
description => 'tests dhandler against nonexistent comp',
call_path => '/dhandler_test/foo/bar',
skip_component => 1,
expect => <<'EOF',
dhandler = /misc/dhandler_test/dhandler
dhandler arg = foo/bar
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'dhandler2',
description => 'real comp to make sure the real comp is invoked, not the dhandler',
path => '/dhandler_test/subdir/leaf',
call_path => '/dhandler_test/subdir/leaf',
component => <<'EOF',
I'm leaf
EOF
expect => <<'EOF',
Header
I'm leaf
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'dhandler3',
description => 'real comp declines the request to make sure the dhandler is invoked',
path => '/dhandler_test/subdir/leaf2',
call_path => '/dhandler_test/subdir/leaf2',
component => <<'EOF',
% $m->decline;
I'm leaf2
EOF
expect => <<'EOF',
Header
dhandler = /misc/dhandler_test/subdir/dhandler
dhandler arg = leaf2
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'dhandler4',
description => 'declines twice to make sure higher level dhandler is called',
path => '/dhandler_test/subdir/leaf3',
call_path => '/dhandler_test/subdir/leaf3',
component => <<'EOF',
% $m->decline;
I'm leaf3
EOF
expect => <<'EOF',
dhandler = /misc/dhandler_test/dhandler
dhandler arg = subdir/leaf3
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'dhandler5',
description => 'decline with doubled slash (//) in URL path',
path => '/dhandler_test/subdir/slashes',
call_path => '//dhandler_test//subdir//slashes',
component => <<'EOF',
% $m->decline;
I have many slashes!
EOF
expect => <<'EOF',
dhandler = /misc/dhandler_test/dhandler
dhandler arg = subdir/slashes
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'dhandler6',
description => 'test that a dhandler more than one directory up is found',
call_path => '/dhandler_test/bar/baz/quux/not_here',
skip_component => 1,
expect => <<'EOF',
dhandler = /misc/dhandler_test/bar/dhandler
dhandler arg = baz/quux/not_here
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'accessor_validate',
description => 'test accessor parameter validation',
component => <<'EOF',
% $m->interp->ignore_warnings_expr([1]);
EOF
expect_error => qr/Parameter #1.*to .*? was an 'arrayref'/,
);
#------------------------------------------------------------
$group->add_test( name => 'contained_accessor_validate',
description => 'test contained accessor parameter validation',
component => <<'EOF',
% $m->interp->autoflush([1]);
EOF
expect_error => qr/Parameter #1.*to .*? was an 'arrayref'/,
);
#------------------------------------------------------------
# define /dhandler that sometimes declines. test framework should provide a
# more supported way to define a top-level component!
my $updir = File::Spec->updir;
$group->add_support( path => "$updir/dhandler",
component => <<'EOF',
% if ($m->request_args->{decline_from_top}) {
% $m->decline;
% } else {
top-level dhandler: path = <% $m->current_comp->path %>
% }
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/dhandler',
component => <<'EOF',
% $m->decline;
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'top_level_dhandler_handles',
description => 'make sure dhandler at /dhandler is called correctly after decline from lower-level dhandler',
path => '/notused',
call_path => '/nonexistent',
component => <<'EOF',
not ever used
EOF
expect => <<'EOF',
top-level dhandler: path = /dhandler
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'top_level_dhandler_declines',
description => 'make sure /dhandler decline results in not-found error',
path => '/notused2',
call_path => '/nonexistent',
call_args => { decline_from_top => 1 },
component => <<'EOF',
not ever used
EOF
expect_error => qr/could not find component for initial path/,
);
#------------------------------------------------------------
return $group;
}
HTML-Mason-1.58/t/single_test.pl 0000755 0001750 0001750 00000000462 13175376764 016276 0 ustar autarch autarch #!/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.58/t/07b-interp-static-source.t 0000644 0001750 0001750 00000014227 13175376764 020261 0 ustar autarch autarch 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");
%perl>
<& 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);
%perl>
<& 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);
%perl>
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'";
%perl>
<& 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;
%init>
<& 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);
%perl>
<& 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);
%perl>
<& 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.58/t/02a-filter.t 0000644 0001750 0001750 00000020127 13175376764 015450 0 ustar autarch autarch use strict;
use warnings;
use HTML::Mason::Tests;
my $tests = make_tests();
$tests->run;
sub make_tests
{
my $group =
HTML::Mason::Tests->tests_class->new( name => 'filter',
description => 'Tests <%filter> specific problems' );
#------------------------------------------------------------
$group->add_test( name => 'filter_and_shared',
description =>
'make sure <%filter> can see variables from <%shared>',
component => <<'EOF',
I am X
<%shared>
my $change_to = 'Y';
%shared>
<%filter>
s/X/$change_to/;
%filter>
EOF
expect => <<'EOF',
I am Y
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'filter_and_ARGS',
description =>
'make sure <%filter> can see variables %ARGS',
call_args => { change_to => 'Y' },
component => <<'EOF',
I am X
<%filter>
s/X/$ARGS{change_to}/;
%filter>
EOF
expect => <<'EOF',
I am Y
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'filter_and_ARGS_assign',
description =>
'make sure <%filter> can see changes to %ARGS',
component => <<'EOF',
I am X
<%init>
$ARGS{change_to} = 'Y';
%init>
<%filter>
s/X/$ARGS{change_to}/;
%filter>
EOF
expect => <<'EOF',
I am Y
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'filter_and_args_section',
description =>
'make sure <%filter> can see variables from <%args> section',
component => <<'EOF',
I am X
<%args>
$change_to => 'Y'
%args>
<%filter>
s/X/$change_to/;
%filter>
EOF
expect => <<'EOF',
I am Y
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'filter_and_args_error',
description =>
'args error should not present a problem for <%filter>',
component => <<'EOF',
<%args>
$required
%args>
foo
<%filter>
s/foo/bar/g;
%filter>
EOF
expect_error => qr/no value sent for required parameter/,
);
#------------------------------------------------------------
$group->add_support( path => '/support/has_filter',
component => <<'EOF',
lower case
<%filter>
$_ = uc $_;
%filter>
EOF
);
$group->add_test( name => 'filter_and_clear',
description => 'make sure <%filter> does not break $m->clear_buffer',
component => <<'EOF',
I should not show up.
<& support/has_filter &>
% $m->clear_buffer;
I should show up.
EOF
expect => <<'EOF',
I should show up.
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'filters_in_subcomps',
description => 'test <%filter> sections in subcomps only',
component => <<'EOF',
Main Component
<& .sub1 &>
<& .sub2 &>
<%def .sub1>
Sub 1
<%filter>
s/Sub/Subcomponent/;
%filter>
%def>
<%def .sub2>
Subcomp 2
<%filter>
s/Subcomp/Subcomponent/;
%filter>
%def>
EOF
expect => <<'EOF',
Main Component
Subcomponent 1
Subcomponent 2
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'filters_in_comp_and_subcomps',
description => 'test <%filter> sections in both main comp and subcomps',
component => <<'EOF',
Main Component (lowercase)
<& .sub1 &>
<& .sub2 &>
<%def .sub1>
Sub 1
<%filter>
s/Sub/Subcomponent/;
%filter>
%def>
<%def .sub2>
Subcomp 2
<%filter>
s/Subcomp/Subcomponent/;
%filter>
%def>
<%filter>
$_ = lc($_);
%filter>
EOF
expect => <<'EOF',
main component (lowercase)
subcomponent 1
subcomponent 2
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'filter_and_flush',
description => 'test that filter still occurs in presence of flush',
component => <<'EOF',
hello
% $m->flush_buffer;
goodbye
<%filter>
tr/a-z/A-Z/
%filter>
EOF
expect => <<'EOF',
HELLO
GOODBYE
EOF
);
#------------------------------------------------------------
$group->add_support( path => 'clear_filter_comp',
component => <<'EOF',
Bar
% $m->clear_buffer;
Baz
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'clear_in_comp_called_with_filter',
description => 'Test that clear_buffer clears _all_ buffers, even inside a filter',
component => <<'EOF',
Foo
<& clear_filter_comp &>\
<%filter>
s/^/-/gm;
%filter>
EOF
expect => <<'EOF',
-Baz
EOF
);
#------------------------------------------------------------
$group->add_support( path => 'some_comp',
component => <<'EOF',
Some stuff
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'comp_call_in_filter',
description => 'Test that calling another component from a filter section works',
component => <<'EOF',
Stuff
<%filter>
$_ .= $m->scomp( 'some_comp' );
$_ = lc $_;
%filter>
EOF
expect => <<'EOF',
stuff
some stuff
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/auto_filter_die/dies',
component => <<'EOF',
% die "foo death";
EOF
);
$group->add_support( path => '/auto_filter_die/autohandler',
component => <<'EOF',
autohandler
% $m->call_next;
EOF
);
$group->add_test( name => 'auto_filter_die/abort_comp_call_in_filter_with_autohandler',
description => 'Test that calling another component that dies from a filter section in a component wrapped by an autohandler produces a proper error',
component => <<'EOF',
Stuff
<%filter>
$m->comp( 'dies' );
%filter>
EOF
expect_error => qr/foo death/,
);
#------------------------------------------------------------
$group->add_support( path => '/support/abort_in_filter',
component => <<'EOF',
Will not be seen
<%filter>
$m->abort;
$_ = lc $_;
%filter>
EOF
);
$group->add_test( name => 'abort_in_filter',
description => 'Test that abort in a filter causes no output',
component => <<'EOF',
Before the abort
<& support/abort_in_filter &>
After the abort - not seen
EOF
expect => <<'EOF',
Before the abort
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/support/abort_in_shared_with_filter',
component => <<'EOF',
<%shared>
$m->abort('dead');
%shared>
<%filter>
$_ = lc $_;
%filter>
EOF
);
$group->add_test( name => 'abort_in_shared_with_filter',
description => 'Test that abort in a shared block works when component has a filter block',
component => <<'EOF',
<% $out %>
<%init>
eval { $m->comp( 'support/abort_in_shared_with_filter' ) };
my $e = $@;
my $out = 'no error';
if ($e)
{
$out = $m->aborted($e) ? $e->aborted_value : "error: $e";
}
%init>
EOF
expect => <<'EOF',
dead
EOF
);
#------------------------------------------------------------
return $group;
}
HTML-Mason-1.58/t/06b-compiler-named-subs.t 0000644 0001750 0001750 00000004272 13175376764 020041 0 ustar autarch autarch use strict;
use warnings;
use HTML::Mason::Tests;
my $tests = make_tests();
$tests->run;
sub make_tests {
my $group =
HTML::Mason::Tests->tests_class->new
( name => 'compiler_named_subs',
description => 'compiler with named subs in components' );
#------------------------------------------------------------
$group->add_test( name => 'basic',
description => 'Make sure that named_component_subs_works',
interp_params => { named_component_subs => 1 },
component => <<'EOF',
This is a test
EOF
expect => <<'EOF',
This is a test
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'subcomps',
description => 'Make sure that named_component_subs_works with subcomps',
interp_params => { named_component_subs => 1 },
component => <<'EOF',
<& .subcomp &>
<%def .subcomp>
This is a subcomp
%def>
EOF
expect => <<'EOF',
This is a subcomp
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'methods',
description => 'Make sure that named_component_subs_works with methods',
interp_params => { named_component_subs => 1 },
component => <<'EOF',
<& SELF:method &>
<%method method>
This is a method
%method>
EOF
expect => <<'EOF',
This is a method
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'shared',
description => 'Make sure that named_component_subs_works with shared block',
interp_params => { named_component_subs => 1 },
component => <<'EOF',
<%shared>
my $x = 42;
%shared>
1: x is <% $x %>
<& SELF:method &>
<%method method>
2: x is <% $x %>
%method>
EOF
expect => <<'EOF',
1: x is 42
2: x is 42
EOF
);
#------------------------------------------------------------
return $group;
}
HTML-Mason-1.58/t/06c-compiler-spaces-path.t 0000644 0001750 0001750 00000001005 13175376764 020203 0 ustar autarch autarch use strict;
use warnings;
use Config;
use HTML::Mason::Tests;
my $tests = make_tests();
$tests->run;
sub make_tests {
my $group = HTML::Mason::Tests->tests_class->new(
name => 'has space',
description => 'compiler test for paths with spaces'
);
$group->add_test(
name => 'whatever',
description => 'error in component in path with spaces',
component => <<'EOF',
% $foo = 1;
EOF
expect_error => qr/.+line 1/,
);
return $group;
}
HTML-Mason-1.58/t/00-report-prereqs.dd 0000644 0001750 0001750 00000005310 13175376764 017133 0 ustar autarch autarch do { my $x = {
'configure' => {
'requires' => {
'ExtUtils::MakeMaker' => '0'
},
'suggests' => {
'JSON::PP' => '2.27300'
}
},
'develop' => {
'requires' => {
'CHI' => '0.21',
'Code::TidyAll' => '0.56',
'Code::TidyAll::Plugin::SortLines::Naturally' => '0.000003',
'Code::TidyAll::Plugin::Test::Vars' => '0.02',
'Parallel::ForkManager' => '1.19',
'Perl::Critic' => '1.126',
'Perl::Tidy' => '20160302',
'Test::CPAN::Meta::JSON' => '0.16',
'Test::Memory::Cycle' => '0',
'Test::Mojibake' => '0',
'Test::More' => '0.88',
'Test::NoTabs' => '0',
'Test::Pod' => '1.41',
'Test::Spelling' => '0.12',
'Test::Vars' => '0.009',
'Test::Version' => '2.05'
}
},
'runtime' => {
'requires' => {
'CGI' => '2.46',
'Cache::Cache' => '1.00',
'Class::Container' => '0.07',
'Exception::Class' => '1.15',
'File::Spec' => '0.8',
'HTML::Entities' => '0',
'Log::Any' => '0.08',
'Params::Validate' => '0.70',
'Scalar::Util' => '1.01'
}
},
'test' => {
'recommends' => {
'CPAN::Meta' => '2.120900'
},
'requires' => {
'ExtUtils::MakeMaker' => '0',
'File::Spec' => '0.8',
'Test::Deep' => '0',
'Test::More' => '0.96'
}
}
};
$x;
} HTML-Mason-1.58/t/06-compiler.t 0000644 0001750 0001750 00000110043 13175376764 015635 0 ustar autarch autarch use strict;
use warnings;
use Config;
use HTML::Mason::Tests;
use HTML::Mason::Tools qw(load_pkg);
my $tests = make_tests();
$tests->run;
{ package HTML::Mason::Commands;
sub _make_interp {
$tests->_make_interp(@_);
}}
sub make_tests {
my $group = HTML::Mason::Tests->tests_class->new( name => 'compiler',
description => 'compiler and lexer object functionality' );
#------------------------------------------------------------
$group->add_test( name => 'allowed_globals',
description => 'test that undeclared globals cause an error',
interp_params => { use_object_files => 0 }, # force it to parse comp each time
component => <<'EOF',
<% $global = 1 %>
EOF
expect_error => 'Global symbol .* requires explicit package name',
);
#------------------------------------------------------------
$group->add_test( name => 'allowed_globals2',
description => 'test that undeclared globals cause an error',
pretest_code => sub { undef *HTML::Mason::Commands::global; undef *HTML::Mason::Commands::global }, # repeated to squash a var used only once warning
interp_params => { use_object_files => 0 },
component => <<'EOF',
<% $global = 1 %>
EOF
expect_error => 'Global symbol .* requires explicit package name',
);
#------------------------------------------------------------
$group->add_test( name => 'allowed_globals3',
description => 'test that declared globals are allowed',
interp_params => { use_object_files => 0, allow_globals => ['$global'] },
component => <<'EOF',
<% $global = 1 %>
EOF
expect => <<'EOF',
1
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'default_escape_flags',
description => 'test that no escaping is done by default',
interp_params => { use_object_files => 0 },
component => <<'EOF',
Explicitly HTML-escaped: <% $expr |h %>
Explicitly HTML-escaped redundantly: <% $expr |hh %>
Explicitly URL-escaped: <% $expr |u
%>
No flags: <% $expr %>
No flags again: <% $expr %>
Explicitly not escaped: <% $expr | n%>
<%init>
my $expr = "Hello there.";
%init>
EOF
expect => <<'EOF',
Explicitly HTML-escaped: <b><i>Hello there</i></b>.
Explicitly HTML-escaped redundantly: <b><i>Hello there</i></b>.
Explicitly URL-escaped: %3Cb%3E%3Ci%3EHello%20there%3C%2Fi%3E%3C%2Fb%3E.
No flags: Hello there.
No flags again: Hello there.
Explicitly not escaped: Hello there.
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'default_escape_flags_new',
description => 'test new escape flags',
interp_params => { use_object_files => 0 },
component => <<'EOF',
Explicitly HTML-escaped: <% $expr | h %>
Explicitly HTML-escaped redundantly: <% $expr | h,h %>
Explicitly URL-escaped: <% $expr |u
%>
No flags: <% $expr %>
No flags again: <% $expr %>
Explicitly not escaped: <% $expr | n %>
<%init>
my $expr = "Hello there.";
%init>
EOF
expect => <<'EOF',
Explicitly HTML-escaped: <b><i>Hello there</i></b>.
Explicitly HTML-escaped redundantly: <b><i>Hello there</i></b>.
Explicitly URL-escaped: %3Cb%3E%3Ci%3EHello%20there%3C%2Fi%3E%3C%2Fb%3E.
No flags: Hello there.
No flags again: Hello there.
Explicitly not escaped: Hello there.
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'default_escape_flags_2',
description => 'test that turning on default escaping works',
interp_params => { use_object_files => 0, default_escape_flags => 'h' },
component => <<'EOF',
Explicitly HTML-escaped: <% $expr |h %>
Explicitly HTML-escaped redundantly: <% $expr |hh %>
Explicitly URL-escaped: <% $expr |un
%>
No flags: <% $expr %>
No flags again: <% $expr %>
Explicitly not escaped: <% $expr | n%>
<%init>
my $expr = "Hello there.";
%init>
EOF
expect => <<'EOF',
Explicitly HTML-escaped: <b><i>Hello there</i></b>.
Explicitly HTML-escaped redundantly: <b><i>Hello there</i></b>.
Explicitly URL-escaped: %3Cb%3E%3Ci%3EHello%20there%3C%2Fi%3E%3C%2Fb%3E.
No flags: <b><i>Hello there</i></b>.
No flags again: <b><i>Hello there</i></b>.
Explicitly not escaped: Hello there.
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'default_escape_flags_2_new',
description => 'test that turning on default escaping works with new flags',
interp_params => { use_object_files => 0,
default_escape_flags => [ 'h' ] },
component => <<'EOF',
Explicitly HTML-escaped: <% $expr | h %>
Explicitly HTML-escaped redundantly: <% $expr | h , h %>
Explicitly URL-escaped: <% $expr | u, n
%>
No flags: <% $expr %>
No flags again: <% $expr %>
Explicitly not escaped: <% $expr | n %>
<%init>
my $expr = "Hello there.";
%init>
EOF
expect => <<'EOF',
Explicitly HTML-escaped: <b><i>Hello there</i></b>.
Explicitly HTML-escaped redundantly: <b><i>Hello there</i></b>.
Explicitly URL-escaped: %3Cb%3E%3Ci%3EHello%20there%3C%2Fi%3E%3C%2Fb%3E.
No flags: <b><i>Hello there</i></b>.
No flags again: <b><i>Hello there</i></b>.
Explicitly not escaped: Hello there.
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'setting_escapes',
description => 'test setting escapes',
component => <<'EOF',
% $m->interp->set_escape( uc => sub { ${$_[0]} = uc ${$_[0]} } );
This will be in <% 'upper case' | uc %>
EOF
expect => <<'EOF',
This will be in UPPER CASE
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'invalid_escape_name',
description => 'test setting an escape with an invalid name',
component => <<'EOF',
% $m->interp->set_escape( 'u c' => sub { uc $_[0] } );
EOF
expect_error => qr/Invalid escape name/,
);
#------------------------------------------------------------
$group->add_test( name => 'globals_in_default_package',
description => 'tests that components are executed in HTML::Mason::Commands package by default',
interp_params => { use_object_files => 0,
allow_globals => ['$packvar'] },
component => <<'EOF',
<% $packvar %>
<%init>
$HTML::Mason::Commands::packvar = 'commands';
$HTML::Mason::NewPackage::packvar = 'newpackage';
%init>
EOF
expect => <<'EOF',
commands
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'globals_in_different_package',
description => 'tests in_package compiler parameter',
interp_params => { use_object_files => 0,
allow_globals => ['$packvar'],
in_package => 'HTML::Mason::NewPackage' },
component => <<'EOF',
<% $packvar %>
<%init>
$HTML::Mason::Commands::packvar = 'commands';
$HTML::Mason::NewPackage::packvar = 'newpackage';
%init>
EOF
expect => <<'EOF',
newpackage
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'preamble',
description => 'tests preamble compiler parameter',
interp_params => { preamble => 'my $msg = "This is the preamble.\n"; $m->print($msg);
'},
component => <<'EOF',
This is the body.
EOF
expect => <<'EOF',
This is the preamble.
This is the body.
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'postamble',
description => 'tests postamble compiler parameter',
interp_params => { postamble => 'my $msg = "This is the postamble.\n"; $m->print($msg);
'},
component => <<'EOF',
This is the body.
EOF
expect => <<'EOF',
This is the body.
This is the postamble.
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'preprocess',
description => 'test preprocess compiler parameter',
interp_params => { preprocess => \&brackets_to_lt_gt },
component => <<'EOF',
[% 'foo' %]
bar
EOF
expect => <<'EOF',
foo
bar
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'postprocess_text1',
description => 'test postprocess compiler parameter (alpha blocks)',
interp_params => { postprocess_text => \&uc_alpha },
component => <<'EOF',
<% 'foo' %>
bar
EOF
expect => <<'EOF',
foo
BAR
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'postprocess_text2',
description => 'test postprocess compiler parameter (alpha blocks)',
interp_params => { postprocess_text => \&uc_alpha },
component => <<'EOF',
<% 'foo' %>
<%text>bar%text>
EOF
expect => <<'EOF',
foo
BAR
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'postprocess_perl1',
description => 'test postprocess compiler parameter (perl blocks)',
interp_params => { postprocess_perl => \&make_foo_foofoo },
component => <<'EOF',
<% 'foo' %>
bar
EOF
expect => <<'EOF',
foofoo
bar
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'postprocess_perl2',
description => 'test postprocess compiler parameter (perl blocks)',
interp_params => { postprocess_perl => \&make_foo_foofoo },
component => <<'EOF',
<% 'foo' %>
% $m->print("Make mine foo!\n");
bar
<% "stuff-$var-stuff" %>
<%init>
my $var = 'foo';
%init>
EOF
expect => <<'EOF',
foofoo
Make mine foofoo!
bar
stuff-foofoo-stuff
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'bad_var_name',
description => 'test that invalid Perl variable names are caught',
component => <<'EOF',
<%args>
$foo
$8teen
%bar
%args>
Never get here
EOF
expect_error => qr{Invalid <%args> section line},
);
#------------------------------------------------------------
$group->add_test( name => 'whitespace_near_args',
description => 'test that whitespace is allowed before %args>',
call_args => [qw(foo foo)],
component => <<'EOF',
<%args>
$foo
%args>
EOF
expect => " \n",
);
#------------------------------------------------------------
$group->add_test( name => 'line_nums',
description => 'make sure that errors are reported with the correct line numbers',
component => <<'EOF',
<% $x %> <% $y %>
<% $z %>
% die "Dead";
<%init>
my ($x, $y, $z) = qw(a b c);
%init>
EOF
expect_error => qr/Dead at .* line 3/,
);
#------------------------------------------------------------
$group->add_test( name => 'line_nums2',
description => 'make sure that errors are reported with the correct line numbers',
component => <<'EOF',
<% $x %> <% $y %>
<% $z %>\
% die "Dead";
<%init>
my ($x, $y, $z) = qw(a b c);
%init>
EOF
expect_error => qr/Dead at .* line 3/,
);
#------------------------------------------------------------
$group->add_test( name => 'line_nums3',
description => 'make sure that errors are reported with the correct line numbers',
component => <<'EOF',
<% $x %> <% $y %>
<% $z %>
<%init>
my ($x, $y, $z) = qw(a b c);
die "Dead";
%init>
EOF
expect_error => qr/Dead at .* line 5/,
);
#------------------------------------------------------------
$group->add_test( name => 'line_nums4',
description => 'make sure that errors are reported with the correct line numbers in <%once> blocks',
component => <<'EOF',
1
2
3
<%ONCE>
$x = 1;
%ONCE>
EOF
expect_error => qr/Global symbol .* at .* line 5/,
);
#------------------------------------------------------------
$group->add_test( name => 'line_nums_with_escaped_newlines',
description => 'Check line numbers of error messages after escaped newlines',
component => <<'EOF',
1
2
3\
4\
5
% die "Dead";
EOF
expect_error => qr/Dead at .* line 6/,
);
#------------------------------------------------------------
$group->add_test( name => 'line_nums_off_by_one',
description => 'make sure that line number reporting is not off by one',
component => <<'EOF',
1
2
3
<%once>#4
my $x = 1; #5
%once>6
7
<%args>#8
$foo#9
@bar#10
%args>11
<%init>#12
#13
#14
#15
$y; #16
%init>
EOF
expect_error => qr/Global symbol .* at .* line 16/,
);
#------------------------------------------------------------
$group->add_test( name => 'line_nums_off_2',
description => 'make sure that line number reporting is not off (another buggy case)',
component => <<'EOF',
<%flags>
inherit => undef
%flags>
% die "really #4";
EOF
expect_error => qr/really #4 .* line 4/,
);
#------------------------------------------------------------
$group->add_test( name => 'attr_block_zero',
description => 'test proper handling of zero in <%attr> block values',
component => <<'EOF',
<%attr>
key => 0
%attr>
<% $m->current_comp->attr_exists('key') ? 'exists' : 'missing' %>
EOF
expect => "exists\n",
);
#------------------------------------------------------------
$group->add_test( name => 'attr_flag_block_comment',
description => 'test comment lines in attr and flags blocks',
component => <<'EOF',
<%attr>
# this is a comment
# another comment
key => 'foo'
# one last comment
%attr>
<%flags>
# this is a comment
# another comment
inherit => undef
# one last comment
%flags>
compiled
EOF
expect => 'compiled',
);
#------------------------------------------------------------
$group->add_test( name => 'attr_flag_block_empty',
description => 'test empty attr and flags blocks',
component => <<'EOF',
<%attr>%attr>
<%flags>
%flags>
compiled
EOF
expect => 'compiled',
);
#------------------------------------------------------------
my $error =
$] >= 5.006 ? qr/Unterminated <>/ : qr/Bareword "subcomp" not allowed/;
$group->add_test( name => 'subcomp_parse_error',
description => 'A misnamed block at the beginning of a component was throwing the lexer into an infinite loop. Now it should be compiled into a component with a syntax error.',
component => <<'EOF',
<%subcomp .foo>
<% 5 %>
%subcomp>
EOF
expect_error => $error,
);
#------------------------------------------------------------
$group->add_test( name => 'error_in_args',
description => 'Test line number reporting for <%args> block',
component => <<'EOF',
lalalal
<%args>
$foo => this should break
%args>
EOF
expect_error => qr/Bareword "break".*error_in_args line 3/,
);
#------------------------------------------------------------
$group->add_test( name => 'block_end_without_nl',
description => 'Test that a block can end without a newline before it',
component => <<'EOF',
no newlines<%args>$foo => 1%args><%attr>foo => 1%attr><%flags>inherit => undef%flags>
EOF
expect => <<'EOF',
no newlines
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'more_block_variations',
description => 'Test various mixture of whitespace with blocks',
component => <<'EOF',
various
<%args>
$foo => 1%args>
<%attr>
foo => 1%attr>
<%args>$bar => 1
%args>
<%attr>bar => 1
%attr>
<%args>
$quux => 1%args>
<%attr>
quux => 1%attr>
<%args> $baz => 1
%args>
<%attr> baz => 1
%attr>
EOF
expect => <<'EOF',
various
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'percent_at_end',
description => 'Make sure that percent signs are only considered perl lines when at the beginning of the line',
component => <<'EOF',
<% $x %>% $x = 5;
<% $x %>
<%init>
my $x = 10;
%init>
EOF
expect => <<'EOF',
10% $x = 5;
10
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'nameless_method',
description => 'Check for appropriate error message when there is a method or def block without a name',
component => <<'EOF',
<%method>
foo
%method>
EOF
expect_error => qr/method block without a name at .*/
);
#------------------------------------------------------------
$group->add_test( name => 'invalid_method_name',
description => 'Check for appropriate error message when there is a method with an invalid name',
component => <<'EOF',
<%method >
foo
%method>
EOF
expect_error => qr/Invalid method name:.*/
);
#------------------------------------------------------------
$group->add_test( name => 'uc_method',
description => 'make sure that <%METHOD ...> is allowed',
component => <<'EOF',
calling SELF:foo - <& SELF:foo &>
<%METHOD foo>bar%METHOD>
EOF
expect => <<'EOF',
calling SELF:foo - bar
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'no_strict',
description => 'test turning off strict in a component',
interp_params => { use_strict => 0 },
component => <<'EOF',
no errors
<%init>
$x = 1;
%init>
EOF
expect => <<'EOF',
no errors
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'no_strict_no_object_files',
description =>
'test turning off strict in a component when not using object files',
interp_params => { use_strict => 0, use_object_files => 0 },
component => <<'EOF',
no errors
<%init>
$x = 1;
%init>
EOF
expect => <<'EOF',
no errors
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'weird_case',
description => 'test weird parsing case',
component => <<'EOF',
<%init()%>
<%args()%>
<%once>
sub init { 'init' }
sub args { 'args' }
%once>
EOF
expect => <<'EOF',
init
args
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'subst_tag_comments',
description => 'Make sure comments parse correctly in substitution tags',
component => <<'EOF',
<%# Here's a comment
5 + 5 %>
EOF
expect => 10,
);
#------------------------------------------------------------
$group->add_test( name => 'shared_to_init',
description => 'Make sure <%init> can see lexicals in <%shared>',
component => <<'EOF',
<%init>
$m->out( $x );
%init>
<%shared>
my $x = 7;
%shared>
EOF
expect => 7,
);
#------------------------------------------------------------
$group->add_test( name => 'shared_to_init_global',
description => 'Make sure <%init> can see global variables in <%shared>',
interp_params => { allow_globals => ['$x'] },
component => <<'EOF',
<%init>
$m->out( $x );
%init>
<%shared>
$x = 8;
%shared>
EOF
expect => 8,
);
#------------------------------------------------------------
$group->add_test( name => 'double_pipe_or',
description => 'Make sure || works in a substitution',
component => <<'EOF',
Should be 1: <% 1 || 2 %>
EOF
expect => <<'EOF',
Should be 1: 1
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'double_pipe_or_2',
description => 'Make sure || works in a substitution (again)',
component => <<'EOF',
<%once>
sub foo { 'foo!' }
sub bar { 'bar!' }
%once>
<% foo || bar %>
EOF
expect => <<'EOF',
foo!
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'flags_regex',
description => 'Make sure flags must start with alpha or underscore',
component => <<'EOF',
<% 1 | 1 %>
EOF
expect => <<'EOF',
1
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'qw_in_perl_lines',
description => 'Make sure that Mason that a qw() list stretching across multiple perl-lines works',
component => <<'EOF',
% foreach my $foo ( qw( a
% b ) ) {
<% $foo %>
% }
EOF
expect => <<'EOF',
a
b
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/has_subcomp',
component => <<'EOF',
<& .a &>
<%def .a>
A
%def>
EOF
);
$group->add_support( path => '/no_subcomp',
component => <<'EOF',
<%shared>
my $y = 1;
%shared>
EOF
);
$group->add_test( name => 'subcomp_leak',
description => 'Make sure subcomps from one component do not show up in other components',
component => <<'EOF',
<%init>
$m->scomp('has_subcomp');
$m->scomp('no_subcomp');
local *FH;
my $obj = $m->fetch_comp('no_subcomp')->object_file;
open FH, "< $obj"
or die "Cannot read $obj";
my $text = join '', ;
close FH;
%init>
% if ( $text =~ /subcomponent_\.a/ ) {
Subcomponent leakage!
% } else {
No leak
% }
EOF
expect => <<'EOF',
No leak
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'use_source_line_numbers_1',
description => 'test presence of line directives when use_source_line_numbers is 1 (default)',
component => <<'EOF',
This is line <% __LINE__ %>.
<%doc>
%doc>
This is line <% __LINE__ %>.
EOF
expect => <<'EOF',
This is line 1.
This is line 5.
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'use_source_line_numbers_0',
description => 'test absence of line directives when use_source_line_numbers is 1',
interp_params => { use_source_line_numbers => 0 },
component => <<'EOF',
This line number is <% __LINE__ < 3 ? 'less than 3' : 'not less than 3' %>.
EOF
expect => <<'EOF',
This line number is not less than 3.
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'define_args_hash_never',
description => 'test setting define_args_hash to never',
interp_params => { define_args_hash => 'never' },
component => <<'EOF',
% $ARGS{foo} = 1;
no error?
EOF
expect_error => qr/Global symbol.*%ARGS/
);
#------------------------------------------------------------
$group->add_test( name => 'define_args_hash_always',
description => 'test setting define_args_hash to always',
interp_params => { define_args_hash => 'always' },
component => <<'EOF',
% eval '$AR' . 'GS{foo} = 1';
<% $@ ? $@ : 'no error' %>
EOF
expect => <<'EOF',
no error
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'define_args_hash_auto',
description => 'test setting define_args_hash to always',
call_args => { bar => 7 },
component => <<'EOF',
<%args>
$foo => $ARGS{bar}
%args>
foo is <% $foo %>
EOF
expect => <<'EOF',
foo is 7
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'comment_in_sub',
description => 'test a substitution that only contains a comment',
component => <<'EOF',
0
<% # a one-line comment %>
1
<%
# a multiline
# comment
%>
2
<% # a multiline
# comment %>
3
<% %>
4
EOF
expect => <<'EOF',
0
1
2
3
4
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'in_package_shared',
description => 'Make sure in_package works with %shared',
interp_params => { in_package => 'HTML::Mason::Foo' },
component => <<'EOF',
<%shared>
my $foo = 'bar';
%shared>
Foo: <% $foo %>
EOF
expect => <<'EOF',
Foo: bar
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'in_package_m_in_shared',
description => 'Make sure $m works with %shared when in_package is set',
interp_params => { in_package => 'HTML::Mason::Bar' },
component => <<'EOF',
<%shared>
my $dh = $m->dhandler_name;
%shared>
<% $dh %>
EOF
expect => <<'EOF',
dhandler
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'compiler_id_change',
description => 'Make sure different compiler params use different object dirs',
component => <<'EOF',
<%args>
$count => 0
$compiler_params => {}
$object_id_hash => {}
%args>
count = <% $count %>
<%perl>
my $object_id = $m->interp->compiler->object_id;
if ($object_id_hash->{$object_id}++) {
die "object_id '$object_id' has been seen (count = $count)!";
}
if ($count == 0) {
$compiler_params->{enable_autoflush} = 0;
} elsif ($count == 1) {
$compiler_params->{default_escape_flags} = 'h';
} elsif ($count == 2) {
$compiler_params->{use_source_line_numbers} = 0;
} elsif ($count == 3) {
$compiler_params->{postprocess_text} = sub { my $content = shift; $$content =~ tr/a-z/A-Z/ };
} else {
return;
}
my $buf;
my $interp = _make_interp(comp_root => $m->interp->comp_root,
data_dir => $m->interp->data_dir,
out_method => \$buf,
%$compiler_params);
$interp->exec($m->current_comp->path, count=>$count+1, compiler_params=>$compiler_params, object_id_hash=>$object_id_hash);
$m->print($buf);
%perl>
EOF
expect => <<'EOF',
count = 0
count = 1
count = 2
count = 3
COUNT = 4
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'no_warnings',
description => 'Make sure no warnings are generated for trying to output undef',
component => <<'EOF',
% my $x;
x is <% $x %>
EOF
expect => <<'EOF',
x is
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'no_warnings_without_autoflush',
description => 'Make sure no warnings are generated for trying to output undef when enable_autoflush is off',
interp_params => { enable_autoflush => 0 },
component => <<'EOF',
% my $x;
x is <% $x %>
EOF
expect => <<'EOF',
x is
EOF
no_warnings => 1,
);
#------------------------------------------------------------
$group->add_test( name => 'no warnings',
description => "Make sure that warnings _aren't_ generated for other bad use of uninit",
component => <<'EOF',
% my $x;
x is <% $x + 2 %>
EOF
expect => <<'EOF',
x is 2
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'warnings_without_autoflush',
description => "Make sure that warnings _aren't_ generated for other bad use of uninit when enable_autoflush is off",
interp_params => { enable_autoflush => 0 },
component => <<'EOF',
% my $x;
x is <% $x + 2 %>
EOF
expect => <<'EOF',
x is 2
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'warnings_need_explicit_enabling',
description => "Make sure that warnings _are_ generated for other bad use of uninit",
component => <<'EOF',
% use warnings;
% my $x;
x is <% $x + 2 %>
EOF
expect => <<'EOF',
x is 2
EOF
expect_warnings => qr/Use of uninitialized value.+in addition/,
);
#------------------------------------------------------------
$group->add_test( name => 'warnings_need_explicit_enabling_without_autoflush',
description => "Make sure that warnings _are_ generated for other bad use of uninit when enable_autoflush is off",
interp_params => { enable_autoflush => 0 },
component => <<'EOF',
% use warnings;
% my $x;
x is <% $x + 2 %>
EOF
expect => <<'EOF',
x is 2
EOF
expect_warnings => qr/Use of uninitialized value.+in addition/,
);
#------------------------------------------------------------
$group->add_test( name => 'warnings_do_not_need_explicit_enabling_on_use_warnings',
interp_params => { use_warnings => 1 },
description => "Make sure that warnings _are_ generated on use_warnings for other bad use of uninit",
component => <<'EOF',
% my $x;
use_warnings is <% $x + 2 %>
EOF
expect => <<'EOF',
use_warnings is 2
EOF
expect_warnings => qr/Use of uninitialized value.+in addition/,
);
#------------------------------------------------------------
$group->add_test( name => 'warnings_do_not_need_explicit_enabling_without_autoflush_on_use_warnings',
description => "Make sure that warnings _are_ generated on use_warnings for other bad use of uninit when enable_autoflush is off",
interp_params => { enable_autoflush => 0, use_warnings => 1 },
component => <<'EOF',
% my $x;
use_warnings is <% $x + 2 %>
EOF
expect => <<'EOF',
use_warnings is 2
EOF
expect_warnings => qr/Use of uninitialized value.+in addition/,
);
#------------------------------------------------------------
$group->add_test( name => 'unbalanced_content_block_error',
description => 'Detect and report unbalanced &> tags',
interp_params => { enable_autoflush => 0 },
component => <<'EOF',
&>
EOF
expect_error => qr/content ending tag but no beginning tag/
);
#------------------------------------------------------------
$group->add_test( name => 'unbalanced_content_block_subcomp_error',
description => 'Detect and report unbalanced &> tags in subcomponents',
interp_params => { enable_autoflush => 0 },
component => <<'EOF',
<%def test>
&>
%def>
EOF
expect_error => qr/content ending tag but no beginning tag/
);
#------------------------------------------------------------
$group->add_test( name => 'non_stringifying_escape',
description => 'stringify after escapes, not before',
component => <<'EOF',
% $m->interp->set_escape( blort => sub { ${$_[0]} = ${$_[0]}->[0] if ref ${$_[0]} } );
Works for <% 'strings' | blort %>
Works for <% ['refs'] | blort %>
EOF
expect => <<'EOF',
Works for strings
Works for refs
EOF
);
#------------------------------------------------------------
return $group;
}
# preprocessing the component
sub brackets_to_lt_gt
{
my $comp = shift;
${ $comp } =~ s/\[\%(.*?)\%\]/<\%$1\%>/g;
}
# postprocessing alpha/perl code
sub uc_alpha
{
${ $_[0] } = uc ${ $_[0] };
}
sub make_foo_foofoo
{
${ $_[0] } =~ s/foo/foofoo/ig;
}
HTML-Mason-1.58/t/05-request.t 0000644 0001750 0001750 00000061006 13175376764 015516 0 ustar autarch autarch use strict;
use warnings;
use HTML::Mason::Tests;
my $tests = make_tests();
$tests->run;
sub make_tests
{
my $group = HTML::Mason::Tests->tests_class->new( name => 'request',
description => 'request object functionality' );
#------------------------------------------------------------
$group->add_support( path => '/support/abort_test',
component => <<'EOF',
<%args>
$val => 50
%args>
Some more text
% $m->abort($val);
But this will never be seen
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/sections/perl',
component => <<'EOF',
foo
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/support/various_test',
component => <<'EOF',
Caller is <% $m->caller->title %> or <% $m->callers(1)->title %> or <% $m->callers(-2)->title %>.
The top level component is <% $m->callers(-1)->title %> or <% $m->request_comp->title %>.
The full component stack is <% join(",",map($_->title,$m->callers)) %>.
My argument list is (<% join(",",$m->caller_args(0)) %>).
The top argument list is (<% join(",",$m->request_args()) %>) or (<% join(",",$m->caller_args(-1)) %>).
% foreach my $path (qw(various_test /request/sections/perl foobar /shared)) {
% my $full_path = HTML::Mason::Tools::absolute_comp_path($path, $m->current_comp->dir_path);
Trying to fetch <% $path %> (full path <% $full_path %>):
% if ($m->comp_exists($path)) {
% if (my $comp = $m->fetch_comp($path)) {
<% $path %> exists with title <% $comp->title %>.
% } else {
<% $path %> exists but could not fetch object!
% }
% } else {
<% $path %> does not exist.
% }
% }
% $m->print("Output via the out function.");
/request/file outputs <% int(length($m->scomp("/request/file"))/10) %>0+ characters.
EOF
);
#------------------------------------------------------------
$group->add_support( path => 'various_helper',
component => <<'EOF',
<& support/various_test, %ARGS &>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'abort',
description => 'test $m->abort method (autoflush on)',
interp_params => { autoflush => 1 },
component => <<'EOF',
Some text
% eval {$m->comp('support/abort_test')};
% if (my $err = $@) {
% if ($m->aborted) {
Component aborted with value <% $err->aborted_value %>
% } else {
Got error
% }
% }
EOF
expect => <<'EOF',
Some text
Some more text
Component aborted with value 50
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'abort_0',
description => 'test $m->abort method with value of 0',
component => <<'EOF',
Some text
% eval {$m->comp('support/abort_test', val => 0)};
% if (my $err = $@) {
% if ($m->aborted($err)) {
Component aborted with value <% $err->aborted_value %>
% } else {
Got error
% }
% }
EOF
expect => <<'EOF',
Some text
Some more text
Component aborted with value 0
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'abort',
description => 'test $m->abort method (autoflush off)',
component => <<'EOF',
Some text
% eval {$m->comp('support/abort_test')};
% if (my $err = $@) {
% if ($m->aborted) {
Component aborted with value <% $err->aborted_value %>
% } else {
Got error
% }
% }
EOF
expect => <<'EOF',
Some text
Some more text
Component aborted with value 50
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'file',
description => 'tests $m->file method',
component => <<'EOF',
Now I will print myself:
% my $output = $m->file("file");
% $output =~ s/\cM//g;
<% $output %>
EOF
expect => <<'EOF',
Now I will print myself:
Now I will print myself:
% my $output = $m->file("file");
% $output =~ s/\cM//g;
<% $output %>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'file_in_subcomp',
description => 'tests $m->file method in subcomponent',
component => <<'EOF',
Here I am:
<& .sub &>
<%def .sub>
% my $f = $m->file('file_in_subcomp'); $f =~ s/\r\n?/\n/g;
<% $f %>
%def>
EOF
expect => <<'EOF',
Here I am:
Here I am:
<& .sub &>
<%def .sub>
% my $f = $m->file('file_in_subcomp'); $f =~ s/\r\n?/\n/g;
<% $f %>
%def>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'list_out',
description => 'tests that $m->print can handle a list of arguments',
component => <<'EOF',
Sending list of arguments:
<% 'blah','boom','bah' %>
<%perl>
$m->print(3,4,5);
my @lst = (7,8,9);
$m->print(@lst);
%perl>
EOF
expect => <<'EOF',
Sending list of arguments:
blahboombah
345789
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'req_obj',
description => 'tests various operations such as comp calls, $m->current_comp',
component => <<'EOF',
<%def .subcomp>
% if ($count < 5) {
<& $m->current_comp, count=>$count+1 &>
% } else {
<& /shared/display_req_obj &>
% }
<%args>
$count
%args>
%def>
<% '-' x 10 %>
One level request:
<& /shared/display_req_obj &>
<% '-' x 10 %>
Many level request:
<& .subcomp, count=>0 &>
<% '-' x 10 %>
EOF
expect => <<'EOF',
----------
One level request:
My depth is 2.
I am not a subrequest.
The top-level component is /request/req_obj.
My stack looks like:
-----
/shared/display_req_obj
/request/req_obj
-----
----------
Many level request:
My depth is 8.
I am not a subrequest.
The top-level component is /request/req_obj.
My stack looks like:
-----
/shared/display_req_obj
/request/req_obj:.subcomp
/request/req_obj:.subcomp
/request/req_obj:.subcomp
/request/req_obj:.subcomp
/request/req_obj:.subcomp
/request/req_obj:.subcomp
/request/req_obj
-----
----------
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'various',
call_args => {junk=>5},
description => 'tests caller, callers, fetch_comp, process_comp_path, comp_exists and scomp',
component => <<'EOF',
<& various_helper, junk=>$ARGS{junk}+1 &>
EOF
expect => <<'EOF',
Caller is /request/various_helper or /request/various_helper or /request/various_helper.
The top level component is /request/various or /request/various.
The full component stack is /request/support/various_test,/request/various_helper,/request/various.
My argument list is (junk,6).
The top argument list is (junk,5) or (junk,5).
Trying to fetch various_test (full path /request/support/various_test):
various_test exists with title /request/support/various_test.
Trying to fetch /request/sections/perl (full path /request/sections/perl):
/request/sections/perl exists with title /request/sections/perl.
Trying to fetch foobar (full path /request/support/foobar):
foobar does not exist.
Trying to fetch /shared (full path /shared):
/shared does not exist.
Output via the out function.
/request/file outputs 120+ characters.
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/autohandler_test2/autohandler',
component => <<'EOF',
This is the first autohandler
Remaining chain: <% join(',',map($_->title,$m->fetch_next_all)) %>
<& $m->fetch_next, level => 1 &>\
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/autohandler_test2/dir1/autohandler',
component => <<'EOF',
This is the second autohandler
Remaining chain: <% join(',',map($_->title,$m->fetch_next_all)) %>
% foreach (@_) {
<% $_ %>
% }
<& $m->fetch_next, level => 2 &>\
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'fetch_next',
path => '/autohandler_test2/dir1/fetch_next',
call_path => '/autohandler_test2/dir1/fetch_next',
description => 'Test $m->fetch_next and $m->fetch_next_all',
component => <<'EOF',
This is the main component (called by level <% $ARGS{level} %>)
Remaining chain: <% join(',',map($_->title,$m->fetch_next_all)) %>
% foreach (@_) {
<% $_ %>
% }
EOF
expect => <<'EOF',
This is the first autohandler
Remaining chain: /request/autohandler_test2/dir1/autohandler,/request/autohandler_test2/dir1/fetch_next
This is the second autohandler
Remaining chain: /request/autohandler_test2/dir1/fetch_next
level
1
This is the main component (called by level 2)
Remaining chain:
level
2
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'print',
description => 'Test print function from a component',
component => <<'EOF',
This is first.
% print "This is second.\n";
This is third.
EOF
expect => <<'EOF',
This is first.
This is second.
This is third.
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'printf',
description => 'Test printf function from a component',
component => <<'EOF',
This is first.
% printf '%s', "This is second.\n";
This is third.
EOF
expect => <<'EOF',
This is first.
This is second.
This is third.
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'autoflush_print',
description => 'Test print function from a component with autoflush on',
interp_params => { autoflush => 1 },
component => <<'EOF',
This is first.
% print "This is second.\n";
This is third.
EOF
expect => <<'EOF',
This is first.
This is second.
This is third.
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'autoflush_printf',
description => 'Test printf function from a component with autoflush on',
interp_params => { autoflush => 1 },
component => <<'EOF',
This is first.
% printf '%s', "This is second.\n";
This is third.
EOF
expect => <<'EOF',
This is first.
This is second.
This is third.
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'flush_print',
description => 'Test print function from a component in conjunction with $m->flush_buffer call',
component => <<'EOF',
This is first.
% print "This is second.\n";
% $m->flush_buffer;
This is third.
EOF
expect => <<'EOF',
This is first.
This is second.
This is third.
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'flush_print_autoflush',
description => 'Test print function from a component with autoflush on in conjunction with $m->flush_buffer call',
interp_params => { autoflush => 1 },
component => <<'EOF',
This is first.
% print "This is second.\n";
% $m->flush_buffer;
This is third.
EOF
expect => <<'EOF',
This is first.
This is second.
This is third.
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'flush_filter',
description => 'Test $m->flush_buffer in presence of filter',
component => <<'EOF',
one
% $m->flush_buffer;
% $m->clear_buffer;
two
<%filter>
$_ .= $_;
%filter>
EOF
expect => <<'EOF',
one
one
two
two
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'clear_buffer',
description => 'Test $m->clear_buffer in a normal component',
component => <<'EOF',
one
% $m->clear_buffer;
two
EOF
expect => <<'EOF',
two
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'clear_filter',
description => 'Test $m->clear_buffer in presence of filter',
component => <<'EOF',
one
% $m->clear_buffer;
two
<%filter>
$_ .= $_;
%filter>
EOF
expect => <<'EOF',
two
two
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'autoflush_disabled',
description => 'Using autoflush when disabled generates an error',
interp_params => { autoflush => 1, enable_autoflush => 0 },
component => <<'EOF',
Hi
EOF
expect_error => qr/Cannot use autoflush unless enable_autoflush is set/,
);
#------------------------------------------------------------
$group->add_test( name => 'instance',
description => 'Test HTML::Mason::Request->instance',
component => <<'EOF',
<% $m eq HTML::Mason::Request->instance ? 'yes' : 'no' %>
EOF
expect => <<'EOF',
yes
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'abort_and_filter',
description => 'Test that an abort in a filtered component still generates _some_ output, and that filter is run only once',
component => <<'EOF',
filter
% eval { $m->comp('support/abort_test') };
<%filter>
$_ = uc $_;
$_ =~ s/\s+$//;
$_ .= "\nfilter ran once";
%filter>
EOF
expect => <<'EOF',
FILTER
SOME MORE TEXT
filter ran once
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'abort_and_filter_2',
description => 'Test that $m->aborted can be checked in a filter section',
component => <<'EOF',
filter
% $m->abort;
<%filter>
unless ( $m->aborted )
{
$_ = uc $_;
$_ =~ s/\s+$//;
$_ .= "\nfilter ran once";
}
%filter>
EOF
expect => <<'EOF',
filter
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'abort_and_store',
description => 'Test that an abort in a store\'d component still generates _some_ output',
component => <<'EOF',
filter
% my $foo;
% eval { $m->comp( { store => \$foo }, 'support/abort_test') };
<% $foo %>
EOF
expect => <<'EOF',
filter
Some more text
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'clear_and_abort',
description => 'Test the clear_and_abort() method',
component => <<'EOF',
Some output
% $m->flush_buffer;
More output
% $m->clear_and_abort();
EOF
expect => <<'EOF',
Some output
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'reexec',
description => 'test that $m cannot be reexecuted',
component => <<'EOF',
<%init>
$m->exec;
%init>
EOF
expect_error => qr/Can only call exec\(\) once/,
);
#------------------------------------------------------------
$group->add_test( name => 'caller_in_subcomp',
description => 'tests $m->caller() in subcomponent',
component => <<'EOF',
<%def .foo>
<% $m->caller->name %>
%def>
<& .foo &>
EOF
expect => <<'EOF',
caller_in_subcomp
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'caller_at_top_level',
description => 'tests $m->caller() from top component',
component => <<'EOF',
caller is <% defined($m->caller) ? "defined" : "undefined" %>
callers(5) is <% defined($m->callers(5)) ? "defined" : "undefined" %>
caller_args(7) is <% defined($m->callers(7)) ? "defined" : "undefined" %>
EOF
expect => <<'EOF',
caller is undefined
callers(5) is undefined
caller_args(7) is undefined
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/support/longjump_test3',
component => <<'EOF',
Depth is <% $m->depth %>.
The full component stack is <% join(",",map($_->title,$m->callers)) %>.
EOF
);
$group->add_support( path => '/support/subdir/longjump_test2',
component => <<'EOF',
This is longjump_test2
% no warnings 'uninitialized'; next;
EOF
);
$group->add_support( path => '/support/longjump_test1',
component => <<'EOF',
<& longjump_test3 &>
% foreach my $i (0..2) {
<& subdir/longjump_test2 &>
% }
<& longjump_test3 &>
EOF
);
# It is possible to accidentally call 'next' from a component and
# jump out to the last loop or block in a previous component.
# While this cannot be supported behavior (since necessary cleanup
# and plugin code is skipped), we'd like to avoid a Mason request
# stack corruption at a minimum.
#
$group->add_test( name => 'longjump',
description => 'Accidentally calling next to exit a component does not corrupt stack',
component => <<'EOF',
<& support/longjump_test1 &>
EOF
expect => <<'EOF',
Depth is 3.
The full component stack is /request/support/longjump_test3,/request/support/longjump_test1,/request/longjump.
This is longjump_test2
This is longjump_test2
This is longjump_test2
Depth is 3.
The full component stack is /request/support/longjump_test3,/request/support/longjump_test1,/request/longjump.
EOF
# This just shuts the test code up
expect_warnings => qr/.*/,
);
#------------------------------------------------------------
$group->add_support( path => '/support/callers_out_of_bounds2',
component => <<'EOF',
hi
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/support/callers_out_of_bounds1',
component => <<'EOF',
<& callers_out_of_bounds2 &>
% foreach my $i (-4 .. 4) {
callers(<% $i %>) is <% defined($m->callers($i)) ? $m->callers($i)->title : 'not defined' %>
% }
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'callers_out_of_bounds',
description => 'tests $m->callers() for out of bounds indexes',
component => <<'EOF',
<& support/callers_out_of_bounds1 &>
EOF
expect => <<'EOF',
hi
callers(-4) is not defined
callers(-3) is not defined
callers(-2) is /request/support/callers_out_of_bounds1
callers(-1) is /request/callers_out_of_bounds
callers(0) is /request/support/callers_out_of_bounds1
callers(1) is /request/callers_out_of_bounds
callers(2) is not defined
callers(3) is not defined
callers(4) is not defined
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'call_self',
description => 'Test $m->call_self',
component => <<'EOF',
called
<%init>
my $out;
if ( $m->call_self( \$out, undef ) )
{
$m->print($out);
return;
}
%init>
EOF
expect => <<'EOF',
called
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'call_self_retval',
description => 'Test that we can get return value of component via $m->call_self',
component => <<'EOF',
called
<%init>
my @return;
if ( $m->call_self( undef, \@return ) )
{
$m->print( "0: $return[0]\n1: $return[1]\n" );
return;
}
return ( 'foo', 'bar' );
%init>
EOF
expect => <<'EOF',
0: foo
1: bar
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'call_self_output_and_retval',
description => 'Test that we can get return value and output of component via $m->call_self',
component => <<'EOF',
called
<%init>
my $out;
my @return;
if ( $m->call_self( \$out, \@return ) )
{
$m->print( "${out}0: $return[0]\n1: $return[1]\n" );
return;
}
%init>
<%cleanup>
return ( 'foo', 'bar' );
%cleanup>
EOF
expect => <<'EOF',
called
0: foo
1: bar
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'call_self_with_filter',
description => 'Test that $m->call_self works in presence of filter',
component => <<'EOF',
called
<%filter>
$_ = uc $_;
$_ .= ' filtered';
%filter>
<%init>
my $out;
if ( $m->call_self( \$out, undef ) )
{
$m->print($out);
return;
}
%init>
EOF
expect => <<'EOF',
CALLED
filtered
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'subcomp_from_shared',
description => 'Test calling a subcomponent inside shared block',
component => <<'EOF',
<%shared>
$m->comp('subcomp');
%shared>
<%def subcomp>
a subcomp
%def>
EOF
expect_error =>
qr/cannot call a method or subcomponent from a <%shared> block/,
);
#------------------------------------------------------------
$group->add_test( name => 'method_in_shared',
description => 'Test calling a method inside shared block',
component => <<'EOF',
<%shared>
$m->comp('SELF:meth');
%shared>
<%method meth>
a method
%method>
EOF
expect_error =>
qr/cannot call a method or subcomponent from a <%shared> block/,
);
#------------------------------------------------------------
$group->add_test( name => 'notes',
description => 'Test the notes() method',
component => <<'EOF',
% $m->notes('key', 'value');
k: <% $m->notes('key') %>
k2: <% $m->notes->{key} %>
EOF
expect =>
qr/k: value\s+k2: value/,
);
#------------------------------------------------------------
$group->add_test( name => 'flush_and_store',
description => q{Test that $m->flush_buffer is ignored in a store'd component},
interp_params => { autoflush => 1 },
component => <<'EOF',
<%def .world>\
World\
%def>
% my $world;
% $m->comp( { store => \$world }, '.world');
Hello, <% $world %>!
% $world = $m->scomp('.world');
Hello, <% $world %>!
EOF
expect => <<'EOF',
Hello, World!
Hello, World!
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'flush_and_scomp_recursive',
description => 'Test that $m->flush_buffer is ignored in a recursive scomp() call',
interp_params => { autoflush => 1 },
component => <<'EOF',
<%def .orld>\
orld\
%def>
<%def .world>\
W<& .orld &>\
%def>
% my $world = $m->scomp('.world');
Hello, <% $world %>!
EOF
expect => <<'EOF',
Hello, World!
EOF
);
#------------------------------------------------------------
return $group;
}
HTML-Mason-1.58/t/13-errors.t 0000644 0001750 0001750 00000035657 13175376764 015356 0 ustar autarch autarch use strict;
use warnings;
use Cwd qw(realpath);
use File::Basename;
use File::Spec;
use HTML::Mason::Tests;
use HTML::Mason::Tools qw(load_pkg);
my $root_dir = realpath(dirname(dirname($0)));
my $tests = make_tests();
$tests->run;
# Using this as an error_format with error_mode='output' causes just
# the error string to be output
sub HTML::Mason::Exception::as_munged
{
my $err = shift->error;
return $err =~ /^(.+?) at/ ? $1 : $err;
}
sub make_tests
{
my $group = HTML::Mason::Tests->tests_class->new( name => 'errors',
description => 'Test that errors are generated properly' );
#------------------------------------------------------------
$group->add_support( path => '/support/error_helper',
component => <<'EOF',
<%init>
eval { $m->comp('error1') };
$m->comp('error2');
%init>
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/support/error1',
component => <<'EOF',
% die "terrible error";
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/support/error2',
component => <<'EOF',
% die "horrible error";
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'bad_args',
description => 'Make sure a bad args line is caught properly',
component => <<'EOF',
<%args>
foo
%args>
EOF
expect_error => qr|Invalid <%args> section line|
);
#------------------------------------------------------------
$group->add_test( name => 'backtrace',
description => 'Make sure trace for second error is accurate when first error is caught by eval',
component => <<'EOF',
<%init>
$m->comp('support/error_helper');
%init>
EOF
expect_error => q|horrible error.*|
);
#------------------------------------------------------------
# This fails as root because the file will always be readable, but
# we can't know that it will fail until we're inside the test. So
# we'll just run this test for developers, not end users.
if ( $ENV{MASON_MAINTAINER} )
{
$group->add_support( path => '/support/unreadable',
component => <<'EOF',
unreadable
EOF
);
my $file = File::Spec->catfile( $group->comp_root, 'errors', 'support', 'unreadable' );
$group->add_test( name => 'cannot_read_source',
description => 'Make sure that Mason throws a useful error when it cannot read a source file',
component => <<"EOF",
<%init>
chmod 0222, '$file'
or die "Cannot chmod file for " . '$file' . ": \$!";
\$m->comp('support/unreadable');
%init>
EOF
expect_error => q|Permission denied|
);
}
#------------------------------------------------------------
$group->add_support( path => '/support/zero_size',
component => '',
);
#------------------------------------------------------------
$group->add_test( name => 'read_zero_size',
description => 'Make sure that Mason handles a zero length source file correctly',
component => <<'EOF',
zero[<& support/zero_size &>]zero
EOF
expect => <<'EOF'
zero[]zero
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'bad_source_callback',
description => 'Make sure that a bad source_callback for a ComponentSource object reports a useful error',
interp_params => { resolver_class => 'My::Resolver' },
component => <<'EOF',
does not matter
EOF
expect_error => qr/Undefined subroutine.*will_explode/,
);
#------------------------------------------------------------
$group->add_test( name => 'bad_escape_flag',
description => 'Make sure that an invalid escape flag is reported properly',
component => <<'EOF',
<% 1234 | abc %>
EOF
expect_error => qr/Invalid escape flag: abc/,
);
#------------------------------------------------------------
$group->add_test( name => 'error_mode_output',
description => 'Make sure that existing output is cleared when an error occurs in error_mode=output',
interp_params => { error_format => 'munged',
error_mode => 'output',
},
component => <<'EOF',
Should not appear in output!
% $m->comp( '/errors/support/error1' );
EOF
expect => <<'EOF',
terrible error
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'error_in_subrequest',
description => 'Make sure that an error in a subrequest is propogated back to the main request',
interp_params => { error_format => 'munged',
error_mode => 'output',
},
component => <<'EOF',
Should not appear in output!
% $m->subexec( '/errors/support/error1' );
EOF
expect => <<'EOF',
terrible error
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'check_error_format',
description => 'Make sure setting error_format => "html" works',
interp_params => { error_format => 'html',
error_mode => 'output',
},
component => <<'EOF',
% die("Horrible death");
EOF
expect => qr{^\s+.*Horrible death}is,
);
#------------------------------------------------------------
$group->add_test( name => 'check_exec_not_found',
description => 'Request to non-existent component',
component => <<'EOF',
% $m->subexec("/does/not/exist");
EOF
expect_error => qr{could not find component for initial path}is,
);
#------------------------------------------------------------
$group->add_test( name => 'check_exec_not_found_html_format',
description => 'Request to non-existent component in html format',
interp_params => { error_format => 'html',
error_mode => 'output',
},
component => <<'EOF',
% $m->subexec("/does/not/exist");
EOF
expect => qr{^\s+.*could not find component for initial path}is,
);
#------------------------------------------------------------
$group->add_test( name => 'check_comp_not_found',
description => 'Component call to non-existent component',
component => <<'EOF',
% $m->comp("/does/not/exist");
EOF
expect_error => qr{could not find component for path}is,
);
#------------------------------------------------------------
$group->add_test( name => 'change_error_format',
description => 'Make sure setting $m->error_format($foo) works on the fly',
interp_params => { error_format => 'html',
error_mode => 'output',
},
component => <<'EOF',
% $m->error_format('text');
% die("Horrible death");
EOF
expect => qr{^Horrible death},
);
#------------------------------------------------------------
$group->add_test( name => 'check_error_format_brief',
description => 'Make sure setting error_format => "brief" works',
interp_params => { error_format => 'brief',
error_mode => 'output',
},
component => <<'EOF',
% die("Horrible death");
EOF
expect => qr{^Horrible death at .*check_error_format_brief line \d+\.$}s,
);
#------------------------------------------------------------
$group->add_test( name => 'object_exception',
description => "Make sure Mason doesn't co-opt non Exception::Class exception objects",
component => <<'EOF',
% eval { die bless { foo => 'bar' }, 'FooException' };
<% ref $@ %>
EOF
expect => <<'EOF',
FooException
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'subcomponent_redefined',
description => "Make sure Mason doesn't allow redefinition of subcomponent",
component => <<'EOF',
<%def foo>
foo
%def>
<%def foo>
foo
%def>
EOF
expect_error => qr/Duplicate definition of subcomponent/,
);
#------------------------------------------------------------
$group->add_test( name => 'method_redefined',
description => "Make sure Mason doesn't allow redefinition of method",
component => <<'EOF',
<%method foo>
foo
%method>
<%method foo>
foo
%method>
EOF
expect_error => qr/Duplicate definition of method/,
);
#------------------------------------------------------------
$group->add_test( name => 'method_subcomp_conflict',
description => "Make sure Mason doesn't allow a subcomponent and method to have the same name",
component => <<'EOF',
<%method foo>
foo
%method>
<%def foo>
foo
%def>
EOF
expect_error => qr/with the same name/,
);
#------------------------------------------------------------
$group->add_test( name => 'subcomp_bad_name',
description => "Make sure Mason doesn't allow a subcomponent with a bad name",
component => <<'EOF',
<%def abc+def>
foo
%def>
EOF
expect_error => qr/Invalid def name/,
);
#------------------------------------------------------------
$group->add_test( name => 'content_comp_wrong_error',
description => "Make sure syntax error inside <&|> &> tags is thrown correctly",
component => <<'EOF',
<&| ttt &>
<%
&>
<%def ttt>
%def>
EOF
expect_error => qr/'<%' without matching '%>'/,
);
#------------------------------------------------------------
$group->add_test( name => 'top_level_compilation_error',
description => "Make sure top-level compiler errors work in output mode",
interp_params => {
error_format => 'text',
error_mode => 'output',
},
component => <<'EOF',
% my $x =
EOF
# match "Error during compilation" followed by
# exactly one occurance of "Stack:"
# (Mason should stop after the first error)
expect => qr/Error during compilation((?!Stack:).)*Stack:((?!Stack:).)*$/s,
);
#------------------------------------------------------------
$group->add_test( name => 'component_error_handler_false',
description => 'Test error-handling with component_error_handler set to false',
interp_params => { component_error_handler => 0 },
component => <<'EOF',
% die 'a string error';
EOF
expect_error => qr/a string error/,
);
#------------------------------------------------------------
$group->add_test( name => 'component_error_Handler_no_upgrade',
description => 'Test that errors do not become object with component_error_handler set to false',
interp_params => { component_error_handler => 0 },
component => <<'EOF',
% eval { die 'a string error' };
exception: <% ref $@ ? ref $@ : 'not a ref' %>
EOF
expect => <<'EOF',
exception: not a ref
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'component_error_handler_false_fatal_mode',
description => 'Test error-handling with component_error_handler set to false and error_mode set to fatal',
interp_params => { component_error_handler => 0,
error_mode => 'fatal',
},
component => <<'EOF',
% die 'a string error';
EOF
expect_error => qr/a string error/,
);
#------------------------------------------------------------
$group->add_test( name => 'component_error_handler_uc_message',
description => 'Test error-handling with component_error_handler set to a subroutine that upper-cases all text',
interp_params => { component_error_handler => sub { die map { uc } @_ } },
component => <<'EOF',
% die 'a string error';
EOF
expect_error => qr/A STRING ERROR/,
);
#------------------------------------------------------------
$group->add_test( name => 'use_bad_module',
description => 'Use a module with an error',
component => <<'EOF',
<%init>
use lib qw(t/lib); use BadModule;
%init>
hi!
EOF
expect_error => qr/syntax error/,
);
#------------------------------------------------------------
$group->add_test( name => 'require_bad_module_in_once',
description => 'Require a module with an error in a once block',
component => <<'EOF',
<%once>
require "./t/lib/BadModule.pm";
%once>
hi!
EOF
expect_error => qr/syntax error/,
);
#------------------------------------------------------------
return $group;
}
package My::Resolver;
use base 'HTML::Mason::Resolver::File';
sub get_info
{
my $self = shift;
if ( my $source = $self->SUPER::get_info(@_) )
{
$source->{source_callback} = sub { will_explode() };
return $source;
}
}
HTML-Mason-1.58/t/lib/ 0000775 0001750 0001750 00000000000 13175376764 014164 5 ustar autarch autarch HTML-Mason-1.58/t/lib/BadModule.pm 0000644 0001750 0001750 00000000026 13175376764 016352 0 ustar autarch autarch package BadModule;
(
HTML-Mason-1.58/t/lib/Mason/ 0000775 0001750 0001750 00000000000 13175376764 015241 5 ustar autarch autarch HTML-Mason-1.58/t/lib/Mason/ApacheTest.pm 0000644 0001750 0001750 00000066577 13175376764 017643 0 ustar autarch autarch 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;
%init>
<%args>
$blank=>0
%args>
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'
%args>
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' );
}
%init>
We should never see this.
EOF
);
_write_comp( 'redirect', <<'EOF',
% $m->print("\n"); # leading whitespace
<%perl>
$m->scomp('foo');
$m->redirect('/comps/basic');
%perl>
<%def foo>
fum
%def>
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;
%init>
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);
%init>
EOF
);
_write_comp( 'internal_redirect_target', <<'EOF',
The number is <% $foo %>.
<%args>
$foo
%args>
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');
%perl>
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.58/t/lib/Apache/ 0000775 0001750 0001750 00000000000 13175376764 015345 5 ustar autarch autarch HTML-Mason-1.58/t/lib/Apache/test.pm 0000644 0001750 0001750 00000055065 13175376764 016673 0 ustar autarch autarch 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 <);
$response ||= $default;
} until (!$mustfind || ($response eq $canskip) || (-e $response || !print("$response not found\n")));
return $response;
}
sub get_test_params {
my $pkg = shift;
print("\nFor testing purposes, please give the full path to an httpd\n",
"with mod_perl enabled. The path defaults to \$ENV{APACHE}, if present.");
my %conf;
my $httpd = $pkg->_find_mod_perl_httpd(1);
my $found;
do
{
$httpd = _ask("\n", $httpd, 1, '!');
if ($httpd eq '!') {
print "Skipping.\n";
return;
}
if ($pkg->_httpd_has_mod_perl($httpd)) {
$found = 1;
} else {
warn("$httpd does not appear to have been compiled with\n",
"mod_perl as a static or dynamic module\n");
$httpd = $pkg->_find_mod_perl_httpd(0);
}
} until ($found);
system "$Config{lns} $httpd t/httpd";
$conf{httpd} = $httpd;
# Default: search for dynamic dependencies if mod_so is present, don't bother otherwise.
my $default = (`t/httpd -l` =~ /mod_so\.c/ ? 'y' : 'n');
if (lc _ask("Search existing config file for dynamic module dependencies?", $default) eq 'y') {
my %compiled = $pkg->get_compilation_params('t/httpd');
$conf{version} = $compiled{SERVER_VERSION};
$conf{config_file} = _ask(" Config file", $compiled{SERVER_CONFIG_FILE}, 1);
$conf{modules} = $pkg->_read_existing_conf($conf{config_file});
}
# Get default user (apache doesn't like to run as root, special-case it)
my $defuser = ($< && getpwuid $<) || 'nobody';
$conf{user} = _ask("User to run tests under", $defuser);
my $defgroup = ($defuser eq 'nobody' ? 'nobody' : getgrgid((getpwnam $conf{user})[3]));
$conf{group} = _ask("Group to run tests under", $defgroup);
$conf{port} = _ask("Port to run tests under", 8228);
return %conf;
}
sub get_compilation_params {
my ($self, $httpd) = @_;
my %compiled;
for (`$httpd -V`) {
if (/([\w]+)="(.*)"/) {
$compiled{$1} = $2;
}
if (/Server version: .*?([\d\.]+)/i) {
$compiled{SERVER_VERSION} = $1;
}
}
$compiled{SERVER_CONFIG_FILE} =~ s,^,$compiled{HTTPD_ROOT}/,
unless $compiled{SERVER_CONFIG_FILE} =~ m,^/,;
return %compiled;
}
sub _read_existing_conf {
# Returns some "(Add|Load)Module" config lines, generated from the
# existing config file and a few must-have modules.
my ($self, $server_conf, $default_root, $is_include) = @_;
open SERVER_CONF, $server_conf or die "Couldn't open $server_conf: $!";
my @lines = grep {!m/^\s*\#/} ;
close SERVER_CONF;
my ($server_root) = (map /^\s*ServerRoot\s*(\S+)/, @lines);
$server_root =~ s/^"//;
$server_root =~ s/"$//;
$server_root ||= $default_root;
my @includes;
foreach my $include (grep /^\s*Include\s+\S+/, @lines) {
my ($file) = $include =~ /^\s*Include\s+(\S+)/;
$file =~ s/^"//;
$file =~ s/"//;
$file =~ s!^([^/])!$server_root/$1!; # absolute path
if ($file =~ m/\*/) {
# expand wildcard includes (used in Fedora Core 1 default config)
my @add = glob $file;
unless ($Apache::test::quiet) {
warn "expanding wildcard Include $file\n";
warn "ADDED INC $_\n" for @add;
}
push @includes, @add;
} else {
push @includes, $file;
warn "ADDED INC $file\n" unless $Apache::test::quiet;
}
}
my @modules = grep /^\s*(Add|Load|Clear)Module/, @lines;
# Rewrite all modules to load from an absolute path.
foreach (@modules) {
s!(\s)([^/\s]\S+/)!$1$server_root/$2!;
}
# Follow each include recursively to find needed modules
foreach my $include (@includes) {
push @modules, $self->_read_existing_conf($include, $server_root, 1);
}
# The last bits only need to be done once.
return @modules if $is_include;
my $static_mods = $self->static_modules('t/httpd');
my @load;
# Have to make sure that dir, autoindex and perl are loaded.
foreach my $module (qw(dir autoindex perl)) {
unless ($static_mods->{"mod_$module"} or grep /$module/i, @modules) {
warn "Will attempt to load mod_$module dynamically.\n" unless $Apache::test::quiet;
push @load, $module;
}
}
# Directories where apache DSOs live.
my @module_dirs = map {m,(/\S*)/,} @modules;
# Finally compute the directives to load modules that need to be loaded.
MODULE:
foreach my $module (@load) {
foreach my $module_dir (@module_dirs) {
foreach my $filename ("mod_$module.so", "lib$module.so", "ApacheModule\u$module.dll") {
if (-e "$module_dir/$filename") {
push @modules, "LoadModule ${module}_module $module_dir/$filename\n"; next MODULE;
}
}
}
warn "Warning: couldn't find anything to load for 'mod_$module'.\n" unless $Apache::test::quiet;
}
unless ($Apache::test::quiet) {
print "Adding the following dynamic config lines: \n";
print join '', @modules;
print "\n\n";
}
return join '', @modules;
}
sub static_modules {
# Returns a hashref whose keys are each of the modules compiled
# statically into the given httpd binary.
my ($self, $httpd) = @_;
my @l = `$httpd -l`;
return {map {lc($_) => 1} map /(\S+)\.c/, @l};
}
sub _find_mod_perl_httpd {
my ($self, $respect_env) = @_;
return $ENV{'APACHE'} if $ENV{'APACHE'} && $respect_env;
local $Apache::test::quiet = 1;
foreach ( '/usr/local/apache/bin/httpd',
'/usr/local/apache_mp/bin/httpd',
'/usr/local/apache2/bin/httpd',
'/opt/apache/bin/httpd',
'/usr/sbin/apache-perl',
'/usr/sbin/apache',
'/usr/sbin/apache2',
'/usr/sbin/httpd',
$self->_which('httpd'),
$self->_which('apache'),
) {
return $_ if -x $_ && $self->_httpd_has_mod_perl($_);
}
}
sub _httpd_has_mod_perl {
my ($self, $httpd) = @_;
return 1 if `$httpd -l` =~ /mod_perl\.c/;
my %compiled = $self->get_compilation_params($httpd);
if ($compiled{SERVER_VERSION} =~ m/^2\./) {
warn("Apache $compiled{SERVER_VERSION} detected. Report problems to mason-users\@lists.sourceforge.net\n") unless $Apache::test::quiet;
}
if ($compiled{SERVER_CONFIG_FILE}) {
local $Apache::test::quiet = 1;
my @lines = $self->_read_existing_conf($compiled{SERVER_CONFIG_FILE},$compiled{HTTPD_ROOT});
return 1 if grep { /mod_perl/ } grep /^\s*(Add|Load)Module/, @lines;
}
return 0;
}
sub _which {
return grep {-x $_} map { "$_/$_[1]" } split /:/, $ENV{PATH};
}
sub test {
shift() if UNIVERSAL::isa($_[0], __PACKAGE__);
my $s = $_[1] ? "ok $_[0]\n" : "not ok $_[0]\n";
if($ENV{MOD_PERL}) {
Apache->request->print($s);
}
else {
print $s;
}
}
sub fetch {
# Old code calls fetch() as a function, new code as a method
my $want_response;
$want_response = shift() if UNIVERSAL::isa($_[0], __PACKAGE__);
my ($ua, $url) = (@_ == 1 ? ($UA, shift()) : @_);
my $request = ref $url ? $url : {uri=>$url};
# Set some defaults
$ENV{PORT} ||= 8529; # For mod_perl's own tests
$request->{method} ||= 'GET';
$request->{content} = '' unless exists $request->{content};
$request->{uri} = "http://localhost:$ENV{PORT}$request->{uri}"
unless $request->{uri} =~ /^http/;
$request->{headers}{Content_Type} = 'application/x-www-form-urlencoded'
if (!$request->{headers} and $request->{method} eq 'POST'); # Is this necessary?
# Create & send the request
$request->{headers} = new HTTP::Headers(%{$request->{headers}||{}});
my $req = new HTTP::Request(@{$request}{'method','uri','headers','content'});
my $response = $ua->request($req);
return $want_response ? $response : $response->content;
}
sub simple_fetch {
my $ua = LWP::UserAgent->new;
my $url = URI::URL->new("http://$net::httpserver");
my($path,$q) = split /\?/, shift;
$url->path($path);
$url->query($q) if $q;
my $request = new HTTP::Request('GET', $url);
my $response = $ua->request($request, undef, undef);
$response->is_success;
}
sub have_module {
my $mod = shift;
my $v = shift;
eval {# surpress "can't boostrap" warnings
local $SIG{__WARN__} = sub {};
if ($mod_perl2::VERSION >= 2.00) {
# use Apache2 is no longer needed
} else {
require Apache;
}
};
eval "require $mod";
if($v and not $@) {
eval {
local $SIG{__WARN__} = sub {};
$mod->UNIVERSAL::VERSION($v);
};
if($@) {
warn $@;
return 0;
}
}
if($@ && ($@ =~ /Can.t locate/)) {
return 0;
}
elsif($@ && ($@ =~ /Can.t find loadable object for module/)) {
return 0;
}
elsif($@) {
warn "$@\n";
}
print "module $mod is installed\n" unless $ENV{MOD_PERL};
return 1;
}
sub skip_test {
print "1..0\n";
exit;
}
sub have_httpd {
return -e 't/httpd';
}
sub run {
require Test::Harness;
my $self = shift;
my $args = shift || {};
my @tests = ();
# First we check if we already are within the "t" directory
if (-d "t") {
# try to move into test directory
chdir "t" or die "Can't chdir: $!";
# fix all relative library locations
foreach (@INC) {
$_ = "../$_" unless m,^(/)|([a-f]:),i;
}
}
# Pick up the library files from the ../blib directory
unshift(@INC, "../blib/lib", "../blib/arch");
#print "@INC\n";
$Test::Harness::verbose = shift(@ARGV)
if $ARGV[0] =~ /^\d+$/ || $ARGV[0] eq "-v";
$Test::Harness::verbose ||= $args->{verbose};
if (@ARGV) {
for (@ARGV) {
if (-d $_) {
push(@tests, <$_/*.t>);
}
else {
$_ .= ".t" unless /\.t$/;
push(@tests, $_);
}
}
}
else {
push @tests, <*.t>, map { <$_/*.t> } @{ $args->{tdirs} || [] };
}
Test::Harness::runtests(@tests);
}
sub MM_test {
# Writes the test section for the Makefile
shift(); # Don't need package name
my %conf = @_;
my $section = < 0) {
die "usage: grab host:port path";
}
my($host, $port) = split ":", shift @args;
$port ||= 80;
my $url = shift @args || "/";
my $remote = IO::Socket::INET->new(Proto => "tcp",
PeerAddr => $host,
PeerPort => $port,
);
unless ($remote) {
die "cannot connect to http daemon on $host";
}
$remote->autoflush(1);
print $remote "GET $url HTTP/1.0\n\n";
my $response_line = 0;
my $header_terminator = 0;
my @msg = ();
while ( <$remote> ) {
#e.g. HTTP/1.1 200 OK
if(m:^(HTTP/\d+\.\d+)[ \t]+(\d+)[ \t]*([^\012]*):i) {
push @msg, $_;
$response_line = 1;
}
elsif(/^([a-zA-Z0-9_\-]+)\s*:\s*(.*)/) {
push @msg, $_;
}
elsif(/^\015?\012$/) {
$header_terminator = 1;
push @msg, $_;
}
print;
}
close $remote;
print "~" x 40, "\n", "Diagnostics:\n";
if ($response_line and $header_terminator) {
print " HTTP response is valid:\n";
}
else {
print " GET -> http://$host:$port$url\n";
print " >>> No response line\n" unless $response_line;
print " >>> No header terminator\n" unless $header_terminator;
print " *** HTTP response is malformed\n";
}
print "-" x 40, "\n", @msg, "-" x 40, "\n";
}
sub run_test {
my($test, $verbose) = @_;
my $cmd = "$^X -w $test|";
my $fh = FileHandle->new;
$fh->open($cmd) or print "can't run $test. $!\n";
my($ok,$next,$max,$files,$totok,$totmax);
$ok = $next = $max = 0;
my @failed = ();
while (<$fh>) {
if( $verbose ){
print ">>> $_";
}
if (/^1\.\.([0-9]+)/) {
$max = $1;
$totmax += $max;
$files++;
$next = 1;
}
elsif ($max && /^(not\s+)?ok\b/) {
my $this = $next;
if (/^not ok\s*(\d*)/){
$this = $1 if $1 > 0;
push @failed, $this;
}
elsif (/^ok\s*(\d*)/) {
$this = $1 if $1 > 0;
$ok++;
$totok++;
}
if ($this > $next) {
# warn "Test output counter mismatch [test $this]\n";
# no need to warn probably
push @failed, $next..$this-1;
}
elsif ($this < $next) {
#we have seen more "ok" lines than the number suggests
warn "Confused test output: test $this answered after test ", $next-1, "\n";
$next = $this;
}
$next = $this + 1;
}
}
$fh->close; # must close to reap child resource values
return($max, \@failed);
}
1;
__END__
=head1 NAME
Apache::test - Facilitates testing of Apache::* modules
=head1 SYNOPSIS
# In Makefile.PL
use Apache::test;
my %params = Apache::test->get_test_params();
Apache::test->write_httpd_conf(%params, include => $more_directives);
*MY::test = sub { Apache::test->MM_test(%params) };
# In t/*.t script (or test.pl)
use Apache::test qw(skip_test have_httpd);
skip_test unless have_httpd;
(Some more methods of Doug's that I haven't reviewed or documented yet)
=head1 DESCRIPTION
This module helps authors of Apache::* modules write test suites that
can query an actual running Apache server with mod_perl and their
modules loaded into it. Its functionality is generally separated into
methods that go in a Makefile.PL to configure, start, and stop the
server, and methods that go in one of the test scripts to make HTTP
queries and manage the results.
=head1 METHODS
=head2 get_test_params()
This will ask the user a few questions about where the httpd binary
is, and what user/group/port should be used when running the server.
It will return a hash of the information it discovers. This hash is
suitable for passing to the C method.
=head2 write_httpd_conf(%params)
This will write a basic C file suitable for starting a
HTTP server during the 'make test' stage. A hash of key/value pairs
that affect the written file can be passed as arguments. The
following keys are recognized:
=over 4
=item * conf_file
The path to the file that will be created. Default is 't/httpd.conf'.
=item * port
The port that the Apache server will listen on.
=item * user
The user that the Apache server will run as.
=item * group
The group that the Apache server will run as.
=item * include
Any additional text you want added at the end of the config file.
Typically you'll have some C and C
directives to pass control to the module you're testing. The C
directories will be added to the C<@INC> path when searching for
modules, so that's nice.
=back
=head2 MM_test(%params)
This method helps write a Makefile that supports running a web server
during the 'make test' stage. When you execute 'make test', 'make'
will run 'make start_httpd', 'make run_tests', and 'make kill_httpd'
in sequence. You can also run these commands independently if you
want.
Pass the hash of parameters returned by C as an
argument to C.
To patch into the ExtUtils::MakeMaker wizardry (voodoo?), typically
you'll do the following in your Makefile.PL:
*MY::test = sub { Apache::test->MM_test(%params) };
=head2 fetch
Apache::test->fetch($request);
Apache::test->fetch($user_agent, $request);
Call this method in a test script in order to fetch a page from the
running web server. If you pass two arguments, the first should be an
LWP::UserAgent object, and the second should specify the request to
make of the server. If you only pass one argument, it specifies the
request to make.
The request can be specified either by a simple string indicating the
URI to fetch, or by a hash reference, which gives you more control
over the request. The following keys are recognized in the hash:
=over 4
=item * uri
The URI to fetch from the server. If the URI does not begin with
"http", we prepend "http://localhost:$PORT" so that we make requests
of the test server.
=item * method
The request method to use. Default is 'GET'.
=item * content
The request content body. Typically used to simulate HTML fill-out
form submission for POST requests. Default is null.
=item * headers
A hash of headers you want sent with the request. You might use this
to send cookies or provide some application-specific header.
=back
If you don't provide a 'headers' parameter and you set the 'method'
to 'POST', then we assume that you're trying to simulate HTML form
submission and we add a 'Content_Type' header with a value of
'application/x-www-form-urlencoded'.
In a scalar context, fetch() returns the content of the web server's
response. In a list context, fetch() returns the content and the
HTTP::Response object itself. This can be handy if you need to check
the response headers, or the HTTP return code, or whatever.
=head2 static_modules
Example: $mods = Apache::test->static_modules('/path/to/httpd');
This method returns a hashref whose keys are all the modules
statically compiled into the given httpd binary. The corresponding
values are all 1.
=head1 EXAMPLES
No good examples yet. Example submissions are welcome. In the meantime, see
L , which
I'm retrofitting to use Apache::test.
=head1 TO DO
The MM_test method doesn't try to be very smart, it just writes the
text that seems to work in my configuration. I am morally against
using the 'make' command for installing Perl modules (though of course
I do it anyway), so I haven't looked into this very much. Send bug
reports or better (patches).
I've got lots of code in my Apache::AuthCookie module (etc.) that
assists in actually making the queries of the running server. I plan
to add that to this module, but first I need to compare what's already
here that does the same stuff.
=head1 KUDOS
To Doug MacEachern for writing the first version of this module.
To caelum@debian.org (Rafael Kitover) for contributing the code to
parse existing httpd.conf files for --enable-shared=max and DSOs.
=head1 CAVEATS
Except for making sure that the mod_perl distribution itself can run
'make test' okay, I haven't tried very hard to keep compatibility with
older versions of this module. In particular MM_test() has changed
and probably isn't usable in the old ways, since some of its
assumptions are gone. But none of this was ever documented, and
MM_test() doesn't seem to actually be used anywhere in the mod_perl
disribution, so I don't feel so bad about it.
=head1 AUTHOR
Doug MacEachern (original version)
Ken Williams (latest changes and this documentation)
=cut
HTML-Mason-1.58/t/lib/LoadTest.pm 0000644 0001750 0001750 00000000072 13175376764 016236 0 ustar autarch autarch package LoadTest;
use Does::Not::Exist;
sub new {}
1;
HTML-Mason-1.58/t/21-escapes.t 0000644 0001750 0001750 00000001405 13175376764 015444 0 ustar autarch autarch 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.58/t/02-sections.t 0000644 0001750 0001750 00000027123 13175376764 015654 0 ustar autarch autarch use strict;
use warnings;
use HTML::Mason::Tests;
my $tests = make_tests();
$tests->run;
sub make_tests
{
my $group = HTML::Mason::Tests->tests_class->new( name => 'sections',
description => 'Tests various <%foo>%foo> sections' );
#------------------------------------------------------------
$group->add_support( path => '/support/args_test',
component => <<'EOF',
<% $message %>\
<%args>
$message
%args>
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/support/perl_args_test',
component => <<'EOF',
a: <% $a %>
b: <% join(",",@b) %>
c: <% join(",",map("$_=$c{$_}",sort(keys(%c)))) %>
d: <% $d %>
e: <% join(",",@e) %>
f: <% join(",",map("$_=$f{$_}",sort(keys(%f)))) %>
<%args>
$a
@b # a comment
%c
$d=>5 # another comment
@e=>('foo','baz')
%f=>(joe=>1,bob=>2)
%args>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'args',
description => 'tests <%args> block',
component => <<'EOF',
args Test
<& support/args_test, message => 'Hello World!' &>
EOF
expect => <<'EOF',
args Test
Hello World!
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'attr',
description => 'tests <%attr> block',
component => <<'EOF',
attr Test
foo
<% $m->current_comp->attr('foo') %>
<% $m->current_comp->attr('bar')->[1] %>
<% $m->current_comp->attr('baz')->{b} %>
<%attr>
foo => 'a'
bar => [1, 3]
baz => { a => 1, b => 2 }
%attr>
EOF
expect => <<'EOF',
attr Test
foo
a
3
2
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'def',
description => 'tests <%def> block',
component => <<'EOF',
<%def intro>
% my $comp = $m->current_comp;
Hello!
My name is <% $comp->name %>. Full name <% $comp->title %>.
I was created by <% $comp->owner->path %>.
<& .link, site=>'masonhq', label=>'Mason' &>
%def>
<& intro &>
<& .link, site=>'apache', label=>'Apache Foundation' &>
<& .link, site=>'yahoo' &>
<& .link, site=>'excite' &>
<%def .link>
--> <% $label %>
<%args>
$site
$label=>ucfirst($site)
%args>
%def>
EOF
expect => <<'EOF',
Hello!
My name is intro. Full name /sections/def:intro.
I was created by /sections/def.
--> Mason
--> Apache Foundation
--> Yahoo
--> Excite
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'doc',
description => 'tests <%doc> section',
component => <<'EOF',
doc Test
Hello World!
<%doc>
This is an HTML::Mason documentation section.
Right?
%doc>
EOF
expect => <<'EOF',
doc Test
Hello World!
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'filter',
description => 'tests <%filter> section',
component => <<'EOF',
filter Test
!dlorW olleH
<%filter>
s/\!dlorW olleH/Hello World!/;
%filter>
EOF
expect => <<'EOF',
filter Test
Hello World!
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'flags',
description => 'tests <%flags> section',
component => <<'EOF',
flags Test
foo
<%flags>
inherit=>undef # an inherit flag
%flags>
EOF
expect => <<'EOF',
flags Test
foo
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'init',
description => 'tests <%init> section',
component => <<'EOF',
init Test
<% $message %>
<%init>
my $message = "Hello World!";
%init>
EOF
expect => <<'EOF',
init Test
Hello World!
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'method',
description => 'tests <%method> section',
component => <<'EOF',
method Test
% $m->current_comp->call_method('foo','y'=>2);
% my $out = $m->current_comp->scall_method('bar',qw(a b c));
<% uc($out) %>
<%method foo>
% my $sum = $y + $y;
<% $y %> + <% $y %> = <% $sum %>.
<%ARGS>
$y
%ARGS>
%method>
<%method bar>
The second method. Arguments are <% join(",",@_) %>.
%method>
EOF
expect => <<'EOF',
method Test
2 + 2 = 4.
THE SECOND METHOD. ARGUMENTS ARE A,B,C.
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'once',
description => 'tests <%once> block',
component => <<'EOF',
once Test
<% $message %>
<%once>
my $message = "Hello World";
%once>
<%INIT>
$message .= "!";
%INIT>
EOF
expect => <<'EOF',
once Test
Hello World!
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'perl',
description => 'test <%perl> sections and makes sure block names are case-insensitive',
component => <<'EOF',
perl Test
<%perl>
my $message = "Hello";
%PERL>
<%Perl>
$message .= " World!";
%perl>
<% $message %>
<%perl>
$message = "How are you?";
%perL>
<% $message %>
EOF
expect => <<'EOF',
perl Test
Hello World!
How are you?
EOF
);
#------------------------------------------------------------
=pod
$group->add_test( name => 'perl_args',
description => 'tests old <%perl_args> block',
component => <<'EOF',
<& support/perl_args_test, a=>'fargo', b=>[17,82,16], c=>{britain=>3, spain=>1} &>
EOF
expect => <<'EOF',
a: fargo
b: 17,82,16
c: britain=3,spain=1
d: 5
e: foo,baz
f: bob=2,joe=1
EOF
);
=cut
#------------------------------------------------------------
# Carp in 5.6.0 is broken so just skip it
unless ($] == 5.006)
{
$group->add_test( name => 'omitted_args',
description => 'tests error message when expect args are not passed',
component => '<& support/perl_args_test, b=>[17,82,16], c=>{britain=>3, spain=>1} &>',
expect_error => qr{no value sent for required parameter 'a'},
);
}
#------------------------------------------------------------
$group->add_test( name => 'overridden_args',
description => 'tests overriding of default args values',
component => <<'EOF',
<& support/perl_args_test, a=>'fargo', b=>[17,82,16], c=>{britain=>3, spain=>1}, d=>103, e=>['a','b','c'], f=>{ralph=>15, sue=>37} &>
EOF
expect => <<'EOF',
a: fargo
b: 17,82,16
c: britain=3,spain=1
d: 103
e: a,b,c
f: ralph=15,sue=37
EOF
);
#------------------------------------------------------------
=pod
$group->add_test( name => 'perl_doc',
description => 'tests old <%perl_doc> section',
component => <<'EOF',
perl_doc Test
Hello World!
<%perl_doc>
This is an HTML::Mason documentation section.
Right?
%perl_doc>
EOF
expect => <<'EOF',
perl_doc Test
Hello World!
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'perl_init',
description => 'tests old <%perl_init> section',
component => <<'EOF',
perl_init Test
<% $message %>
<%perl_init>
my $message = "Hello World!";
%perl_init>
EOF
expect => <<'EOF',
perl_init Test
Hello World!
EOF
);
=cut
#------------------------------------------------------------
$group->add_test( name => 'shared',
description => 'tests <%shared> section',
component => <<'EOF',
<%def .main>
Hello <% $name %>.
% $m->current_comp->owner->call_method('foo');
% $m->current_comp->owner->call_method('bar');
<& .baz &>
%def>
<%method foo>
This is the foo method, <% $name %>.
%method>
<%method bar>
This is the bar method, <% $name %>.
%method>
<%def .baz>
This is the baz subcomponent, <% $name %>.
%def>
<& .main &>
% $name = 'Mary';
<& .main &>
<%shared>
my $name = 'Joe';
%shared>
EOF
expect => <<'EOF',
Hello Joe.
This is the foo method, Joe.
This is the bar method, Joe.
This is the baz subcomponent, Joe.
Hello Mary.
This is the foo method, Mary.
This is the bar method, Mary.
This is the baz subcomponent, Mary.
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'text',
description => 'tests <%text> section',
component => <<'EOF',
<%text>
%
<%once>
<%init>
<%doc>
<%args>
%text>
EOF
expect => <<'EOF',
%
<%once>
<%init>
<%doc>
<%args>
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'multiple',
description => 'tests repeated blocks of the same type',
component => <<'EOF',
<%attr>
name=>'Joe'
%attr>
<%init>
my $var1 = "Foo!";
%init>
<%filter>
tr/a-z/A-Z/
%filter>
var1 = <% $var1 %>
var2 = <% $var2 %>
Name = <% $m->current_comp->attr('name') %>
Color = <% $m->current_comp->attr('color') %>
<%filter>
s/\!/\?/g
%filter>
<%init>
my $var2 = "Bar!";
%init>
<%attr>
color=>'Blue'
%attr>
EOF
expect => <<'EOF',
VAR1 = FOO?
VAR2 = BAR?
NAME = JOE
COLOR = BLUE
EOF
);
#------------------------------------------------------------
return $group;
}
HTML-Mason-1.58/t/24-tools.t 0000644 0001750 0001750 00000000335 13175376764 015165 0 ustar autarch autarch 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.58/t/25-flush-in-content.t 0000644 0001750 0001750 00000002165 13175376764 017226 0 ustar autarch autarch use strict;
use warnings;
use File::Spec;
use HTML::Mason::Tests;
my $tests = make_tests();
$tests->run;
sub make_tests {
my $group = HTML::Mason::Tests->tests_class->new(
name => 'flush-in-content',
description => 'recursive calls with $m->content'
);
#------------------------------------------------------------
$group->add_support(
path => '/widget',
component => <<'EOF',
\
<% $content |n %>\
\
<%init>
my $content = $m->content;
%init>
EOF
);
#------------------------------------------------------------
$group->add_support(
path => '/block',
component => <<'EOF',
\
% $m->flush_buffer;
EOF
);
#------------------------------------------------------------
$group->add_test(
name => 'flush-in-deep-content',
description =>
'make sure flush does not flush when we are in $m->content()',
component => <<'EOF',
<&| widget &><&| widget &><& block &>&>&>
EOF
expect => <<'EOF',
EOF
);
return $group;
}
HTML-Mason-1.58/t/20-plugins.t 0000644 0001750 0001750 00000045326 13175376764 015513 0 ustar autarch autarch use strict;
use warnings;
use HTML::Mason::Tests;
package HTML::Mason::Plugin::TestBeforeAndAfterRequest;
use base qw(HTML::Mason::Plugin);
sub start_request_hook {
my ($self, $context) = @_;
print "Before Request\n";
}
sub end_request_hook {
print "After Request\n";
}
package HTML::Mason::Plugin::TestBeforeAndAfterComponent;
use base qw(HTML::Mason::Plugin);
sub start_component_hook {
my ($self, $context) = @_;
print "Before Component " . $context->comp->title . "\n";
}
sub end_component_hook {
my ($self, $context) = @_;
print "After Component " . $context->comp->title . "\n";
}
# test the ordering of plugin calls
package HTML::Mason::Plugin::TestAllCalls;
use base qw(HTML::Mason::Plugin);
sub start_request_hook {
my ($self, $context) = @_;
my $rcomp = $context->request->request_comp()->title;
print "AllCalls Request Start on: $rcomp\n";
}
sub end_request_hook {
my ($self, $context) = @_;
my $rcomp = $context->request->request_comp()->title;
print "AllCalls Request Finish on: $rcomp\n";
}
sub start_component_hook {
my ($self, $context) = @_;
print "AllCalls Before Component " . $context->comp->title . "\n";
}
sub end_component_hook {
my ($self, $context) = @_;
print "AllCalls After Component " . $context->comp->title . "\n";
}
package HTML::Mason::Plugin::TestResetEachRequest;
use base qw(HTML::Mason::Plugin);
sub start_request_hook {
my ($self, $context) = @_;
my $rcomp = $context->request->request_comp->title();
print "PreRequest: " . ++ $self->{count} . " : $rcomp\n";
}
sub end_request_hook {
my ($self, $context) = @_;
my $rcomp = $context->request->request_comp->title();
print "PostRequest: " . ++ $self->{count} . " : $rcomp\n";
}
sub start_component_hook {
my ($self, $context) = @_;
print "PreComponent: " . ++ $self->{count} . " : " . $context->comp->title() ."\n";
}
sub end_component_hook {
my ($self, $context) = @_;
print "PostComponent: " . ++ $self->{count} . " : " . $context->comp->title() ."\n";
}
package HTML::Mason::Plugin::TestErrorStartRequest;
use base qw(HTML::Mason::Plugin);
sub start_request_hook {
my ($self, $context) = @_;
die("plugin error on start request " . $context->request->request_comp->title);
}
package HTML::Mason::Plugin::TestErrorEndRequest;
use base qw(HTML::Mason::Plugin);
sub end_request_hook {
my ($self, $context) = @_;
die("plugin error on end request " . $context->request->request_comp->title);
}
package HTML::Mason::Plugin::TestErrorStartComponent;
use base qw(HTML::Mason::Plugin);
sub start_component_hook {
my ($self, $context) = @_;
die("plugin error on start component " . $context->comp->title);
}
package HTML::Mason::Plugin::TestErrorEndComponent;
use base qw(HTML::Mason::Plugin);
sub end_component_hook {
my ($self, $context) = @_;
die("plugin error on end component " . $context->comp->title);
}
package HTML::Mason::Plugin::TestModifyReturnEndComponent;
use base qw(HTML::Mason::Plugin);
sub end_component_hook {
my ($self, $context) = @_;
my $result = $context->result;
if (defined($result->[0])) {
$result->[0] = $result->[0] * 2;
}
}
package HTML::Mason::Plugin::TestModifyReturnEndRequest;
use base qw(HTML::Mason::Plugin);
sub end_request_hook {
my ($self, $context) = @_;
my $result = $context->result;
if (defined($result->[0])) {
$result->[0] = $result->[0] * 2;
}
}
package HTML::Mason::Plugin::TestCatchErrorEndComponent;
use base qw(HTML::Mason::Plugin);
sub end_component_hook {
my ($self, $context) = @_;
my $error = $context->error;
if (defined($$error)) {
print "Caught error " . $$error . " and trapping it.\n";
$$error = undef;
}
}
package HTML::Mason::Plugin::TestCatchErrorEndRequest;
use base qw(HTML::Mason::Plugin);
sub end_request_hook {
my ($self, $context) = @_;
my $error = $context->error;
if (defined($$error)) {
print "Caught error " . $$error . " and trapping it.\n";
$$error = undef;
}
}
package HTML::Mason::Plugin::TestEndRequestModifyOutput;
use base qw(HTML::Mason::Plugin);
sub end_request_hook {
my ($self, $context) = @_;
my $content_ref = $context->output;
$$content_ref = uc($$content_ref);
}
package main;
my $tests = make_tests();
$tests->run;
sub make_tests
{
my $group = HTML::Mason::Tests->tests_class->new( name => 'plugins',
description => 'request and component plugin hooks'
);
#------------------------------------------------------------
# comp A calls comp B two times.
$group->add_support( path => '/support/A.m',
component => <<'EOF',
Component A Start
<& B.m &>
<& B.m &>
Component A Finish
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/support/B.m',
component => <<'EOF',
Component B Start
Component B Finish
EOF
);
#------------------------------------------------------------
$group->add_support( path => '/support/error.m',
component => <<'EOF',
% die("uh oh");
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'before_and_after_request',
description => 'a simple plugin for requests',
interp_params =>
{
plugins => ['HTML::Mason::Plugin::TestBeforeAndAfterRequest'],
},
component => '<& support/A.m &>',
expect => <<'EOF',
Before Request
Component A Start
Component B Start
Component B Finish
Component B Start
Component B Finish
Component A Finish
After Request
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'before_and_after_component',
description => 'a simple plugin for components',
interp_params =>
{
plugins => ['HTML::Mason::Plugin::TestBeforeAndAfterComponent'],
},
component => '<& support/A.m &>',
expect => <<'EOF',
Before Component /plugins/before_and_after_component
Before Component /plugins/support/A.m
Component A Start
Before Component /plugins/support/B.m
Component B Start
Component B Finish
After Component /plugins/support/B.m
Before Component /plugins/support/B.m
Component B Start
Component B Finish
After Component /plugins/support/B.m
Component A Finish
After Component /plugins/support/A.m
After Component /plugins/before_and_after_component
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'two_plugins',
description => 'using two different plugins',
interp_params =>
{
plugins => ['HTML::Mason::Plugin::TestBeforeAndAfterComponent', 'HTML::Mason::Plugin::TestBeforeAndAfterRequest'],
},
component => '<& support/A.m &>',
expect =><<'EOF',
Before Request
Before Component /plugins/two_plugins
Before Component /plugins/support/A.m
Component A Start
Before Component /plugins/support/B.m
Component B Start
Component B Finish
After Component /plugins/support/B.m
Before Component /plugins/support/B.m
Component B Start
Component B Finish
After Component /plugins/support/B.m
Component A Finish
After Component /plugins/support/A.m
After Component /plugins/two_plugins
After Request
EOF
);
$group->add_test( name => 'plugin_ordering',
description => 'make sure plugins are called in reverse order when ending',
interp_params =>
{
plugins => ['HTML::Mason::Plugin::TestAllCalls','HTML::Mason::Plugin::TestBeforeAndAfterRequest', 'HTML::Mason::Plugin::TestBeforeAndAfterComponent'],
},
component => '<& support/A.m &>',
expect =><<'EOF',
AllCalls Request Start on: /plugins/plugin_ordering
Before Request
AllCalls Before Component /plugins/plugin_ordering
Before Component /plugins/plugin_ordering
AllCalls Before Component /plugins/support/A.m
Before Component /plugins/support/A.m
Component A Start
AllCalls Before Component /plugins/support/B.m
Before Component /plugins/support/B.m
Component B Start
Component B Finish
After Component /plugins/support/B.m
AllCalls After Component /plugins/support/B.m
AllCalls Before Component /plugins/support/B.m
Before Component /plugins/support/B.m
Component B Start
Component B Finish
After Component /plugins/support/B.m
AllCalls After Component /plugins/support/B.m
Component A Finish
After Component /plugins/support/A.m
AllCalls After Component /plugins/support/A.m
After Component /plugins/plugin_ordering
AllCalls After Component /plugins/plugin_ordering
After Request
AllCalls Request Finish on: /plugins/plugin_ordering
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'two_of_the_same_plugin',
description => 'two_of_the_same_plugin',
interp_params =>
{
plugins => ['HTML::Mason::Plugin::TestBeforeAndAfterComponent', 'HTML::Mason::Plugin::TestBeforeAndAfterComponent'],
},
component => '<& support/A.m &>',
expect =><<'EOF',
Before Component /plugins/two_of_the_same_plugin
Before Component /plugins/two_of_the_same_plugin
Before Component /plugins/support/A.m
Before Component /plugins/support/A.m
Component A Start
Before Component /plugins/support/B.m
Before Component /plugins/support/B.m
Component B Start
Component B Finish
After Component /plugins/support/B.m
After Component /plugins/support/B.m
Before Component /plugins/support/B.m
Before Component /plugins/support/B.m
Component B Start
Component B Finish
After Component /plugins/support/B.m
After Component /plugins/support/B.m
Component A Finish
After Component /plugins/support/A.m
After Component /plugins/support/A.m
After Component /plugins/two_of_the_same_plugin
After Component /plugins/two_of_the_same_plugin
EOF
);
$group->add_test( name => 'reset_each_request',
description => 'use the same plugin twice, they should be different objects',
interp_params =>
{
plugins => ['HTML::Mason::Plugin::TestResetEachRequest', 'HTML::Mason::Plugin::TestResetEachRequest'],
},
component => '<& support/A.m &>',
expect =><<'EOF',
PreRequest: 1 : /plugins/reset_each_request
PreRequest: 1 : /plugins/reset_each_request
PreComponent: 2 : /plugins/reset_each_request
PreComponent: 2 : /plugins/reset_each_request
PreComponent: 3 : /plugins/support/A.m
PreComponent: 3 : /plugins/support/A.m
Component A Start
PreComponent: 4 : /plugins/support/B.m
PreComponent: 4 : /plugins/support/B.m
Component B Start
Component B Finish
PostComponent: 5 : /plugins/support/B.m
PostComponent: 5 : /plugins/support/B.m
PreComponent: 6 : /plugins/support/B.m
PreComponent: 6 : /plugins/support/B.m
Component B Start
Component B Finish
PostComponent: 7 : /plugins/support/B.m
PostComponent: 7 : /plugins/support/B.m
Component A Finish
PostComponent: 8 : /plugins/support/A.m
PostComponent: 8 : /plugins/support/A.m
PostComponent: 9 : /plugins/reset_each_request
PostComponent: 9 : /plugins/reset_each_request
PostRequest: 10 : /plugins/reset_each_request
PostRequest: 10 : /plugins/reset_each_request
EOF
);
#------------------------------------------------------------
$group->add_test( name => 'error_on_start_request',
description => 'a plugin that dies',
interp_params =>
{
plugins => ['HTML::Mason::Plugin::TestErrorStartRequest'],
},
component => '<& support/A.m &>',
expect_error => 'plugin error on start request /plugins/error_on_start_request',
);
#------------------------------------------------------------
$group->add_test( name => 'error_on_end_request',
description => 'a plugin that dies',
interp_params =>
{
plugins => ['HTML::Mason::Plugin::TestErrorEndRequest'],
},
component => '<& support/A.m &>',
expect_error => 'plugin error on end request /plugins/error_on_end_request',
);
#------------------------------------------------------------
$group->add_test( name => 'error_on_start_component',
description => 'a plugin that dies',
interp_params =>
{
plugins => ['HTML::Mason::Plugin::TestErrorStartComponent'],
},
component => '<& support/A.m &>',
expect_error => 'plugin error on start component /plugins/error_on_start_component',
);
#------------------------------------------------------------
$group->add_test( name => 'error_on_end_component',
description => 'a plugin that dies',
interp_params =>
{
plugins => ['HTML::Mason::Plugin::TestErrorEndComponent'],
},
component => '<& support/A.m &>',
expect_error => 'plugin error on end component /plugins/error_on_end_component',
);
#------------------------------------------------------------
$group->add_test( name => 'not_persistent_across_requests',
description => 'different plugin for each request',
interp_params =>
{
plugins => ['HTML::Mason::Plugin::TestResetEachRequest'],
},
component => '% $m->subexec("support/A.m"); ',
expect =><<'EOF',
PreRequest: 1 : /plugins/not_persistent_across_requests
PreComponent: 2 : /plugins/not_persistent_across_requests
PreRequest: 1 : /plugins/support/A.m
PreComponent: 2 : /plugins/support/A.m
Component A Start
PreComponent: 3 : /plugins/support/B.m
Component B Start
Component B Finish
PostComponent: 4 : /plugins/support/B.m
PreComponent: 5 : /plugins/support/B.m
Component B Start
Component B Finish
PostComponent: 6 : /plugins/support/B.m
Component A Finish
PostComponent: 7 : /plugins/support/A.m
PostRequest: 8 : /plugins/support/A.m
PostComponent: 3 : /plugins/not_persistent_across_requests
PostRequest: 4 : /plugins/not_persistent_across_requests
EOF
);
#------------------------------------------------------------
my $PersistentPlugin = HTML::Mason::Plugin::TestResetEachRequest->new();
$group->add_test( name => 'persistent_across_requests',
description => 'same plugin across a subrequest',
interp_params =>
{
plugins => [$PersistentPlugin],
},
component => '% $m->subexec("support/A.m"); ',
expect =><<'EOF',
PreRequest: 1 : /plugins/persistent_across_requests
PreComponent: 2 : /plugins/persistent_across_requests
PreRequest: 3 : /plugins/support/A.m
PreComponent: 4 : /plugins/support/A.m
Component A Start
PreComponent: 5 : /plugins/support/B.m
Component B Start
Component B Finish
PostComponent: 6 : /plugins/support/B.m
PreComponent: 7 : /plugins/support/B.m
Component B Start
Component B Finish
PostComponent: 8 : /plugins/support/B.m
Component A Finish
PostComponent: 9 : /plugins/support/A.m
PostRequest: 10 : /plugins/support/A.m
PostComponent: 11 : /plugins/persistent_across_requests
PostRequest: 12 : /plugins/persistent_across_requests
EOF
);
#------------------------------------------------------------
$group->add_support ( path => '/support/return_numbers',
component => <<'EOF',
<%def .five><%perl>return 5;%perl>%def>
<%def .six><%perl>return 6;%perl>%def>
% return $m->comp('.five') + $m->comp('.six');
EOF
);
$group->add_test( name => 'modify_return_end_component',
description => 'an end_component plugin that modifies its return value',
interp_params =>
{
plugins => ['HTML::Mason::Plugin::TestModifyReturnEndComponent'],
},
component => '<% $m->comp("support/return_numbers") %>',
expect => '44',
);
$group->add_test( name => 'modify_return_end_request',
description => 'an end_request plugin that modifies its return value',
interp_params =>
{
plugins => ['HTML::Mason::Plugin::TestModifyReturnEndRequest'],
},
component => '<% $m->subexec("support/return_numbers") %>',
expect => '22',
);
#------------------------------------------------------------
$group->add_test( name => 'catch_error_end_component',
description => 'an end_component plugin that modifies its arguments to trap errors',
interp_params =>
{
plugins => ['HTML::Mason::Plugin::TestCatchErrorEndComponent'],
},
component => '<& support/error.m &>',
expect => qr{Caught error uh oh},
);
$group->add_test( name => 'catch_error_end_request',
description => 'an end_request plugin that modifies its arguments to trap errors',
interp_params =>
{
plugins => ['HTML::Mason::Plugin::TestCatchErrorEndRequest'],
},
component => '<& support/error.m &>',
expect => qr{Caught error uh oh},
);
#------------------------------------------------------------
$group->add_test( name => 'modify_content_end_request',
description => 'modify content at end of request',
interp_params =>
{
plugins => ['HTML::Mason::Plugin::TestEndRequestModifyOutput'],
},
component => '<%def .something>capitalized%def>I will be <& .something &>',
expect => <<'EOF',
I WILL BE CAPITALIZED
EOF
);
return $group;
}
HTML-Mason-1.58/t/25-log.t 0000644 0001750 0001750 00000004103 13175376764 014604 0 ustar autarch autarch 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.58/t/taint.comp 0000644 0001750 0001750 00000000320 13175376764 015406 0 ustar autarch autarch <%perl>
$m->print('part2');
%perl>
<%args>
$foo => 1
$bar
%args>
hey there
% my $x = 1;
<%perl>
$m->print($x++) while $x < 100;
%perl>
<%def .foo>
lalalalalala
%def>
<%method foo>
foobar
%method>
HTML-Mason-1.58/inc/ 0000775 0001750 0001750 00000000000 13175376764 013724 5 ustar autarch autarch HTML-Mason-1.58/inc/Pod/ 0000775 0001750 0001750 00000000000 13175376764 014446 5 ustar autarch autarch HTML-Mason-1.58/inc/Pod/Weaver/ 0000775 0001750 0001750 00000000000 13175376764 015677 5 ustar autarch autarch HTML-Mason-1.58/inc/Pod/Weaver/Section/ 0000775 0001750 0001750 00000000000 13175376764 017303 5 ustar autarch autarch HTML-Mason-1.58/inc/Pod/Weaver/Section/SeeAlsoMason.pm 0000644 0001750 0001750 00000001744 13175376764 022176 0 ustar autarch autarch package inc::Pod::Weaver::Section::SeeAlsoMason;
use Moose;
with 'Pod::Weaver::Role::Section';
use Moose::Autobox;
# Add "SEE ALSO: Mason"
sub weave_section {
my ( $self, $document, $input ) = @_;
return if $input->{filename} =~ m{\QHTML/Mason.pm};
my $idc = $input->{pod_document}->children;
for ( my $i = 0 ; $i < $idc->length ; $i++ ) {
next unless my $para = $idc->[$i];
return
if $para->can('command')
&& $para->command eq 'head1'
&& $para->content eq 'SEE ALSO';
}
$document->children->push(
Pod::Elemental::Element::Nested->new(
{
command => 'head1',
content => 'SEE ALSO',
children => [
Pod::Elemental::Element::Pod5::Ordinary->new(
{ content => "L" }
),
],
}
),
);
}
__PACKAGE__->meta->make_immutable;
no Moose;
1;
HTML-Mason-1.58/live-tests/ 0000775 0001750 0001750 00000000000 13175376764 015252 5 ustar autarch autarch HTML-Mason-1.58/live-tests/live/ 0000775 0001750 0001750 00000000000 13175376764 016211 5 ustar autarch autarch HTML-Mason-1.58/live-tests/live/multi-conf.t 0000644 0001750 0001750 00000000423 13175376764 020450 0 ustar autarch autarch use strict;
use warnings;
use File::Spec;
use lib 'lib', File::Spec->catdir( 't', 'lib' );
use Mason::ApacheTest qw( chmod_data_dir );
Mason::ApacheTest->run_tests(
apache_define => 'multi_config',
with_handler => 0,
test_sets => [qw( multi_config )],
);
HTML-Mason-1.58/live-tests/live/cgi-no-handler.t 0000644 0001750 0001750 00000000442 13175376764 021163 0 ustar autarch autarch use strict;
use warnings;
use File::Spec;
use lib 'lib', File::Spec->catdir( 't', 'lib' );
use Mason::ApacheTest qw( require_cgi );
require_cgi();
Mason::ApacheTest->run_tests(
apache_define => 'CGI_no_handler',
with_handler => 0,
test_sets => [qw( standard cgi )],
);
HTML-Mason-1.58/live-tests/live/CGIHandler.t 0000644 0001750 0001750 00000000373 13175376764 020277 0 ustar autarch autarch use strict;
use warnings;
use File::Spec;
use lib 'lib', File::Spec->catdir( 't', 'lib' );
use Mason::ApacheTest;
Mason::ApacheTest->run_tests(
apache_define => 'CGIHandler',
with_handler => 0,
test_sets => [qw( cgi_handler )],
);
HTML-Mason-1.58/live-tests/live/taint.t 0000644 0001750 0001750 00000000363 13175376764 017515 0 ustar autarch autarch use strict;
use warnings;
use File::Spec;
use lib 'lib', File::Spec->catdir( 't', 'lib' );
use Mason::ApacheTest;
Mason::ApacheTest->run_tests(
apache_define => 'taint',
with_handler => 0,
test_sets => [qw( standard )],
);
HTML-Mason-1.58/live-tests/live/apache-filter.t 0000644 0001750 0001750 00000000523 13175376764 021100 0 ustar autarch autarch use strict;
use warnings;
use File::Spec;
use lib 'lib', File::Spec->catdir( 't', 'lib' );
use Mason::ApacheTest qw( require_libapreq require_apache_filter );
require_libapreq();
require_apache_filter();
Mason::ApacheTest->run_tests(
apache_define => 'filter_tests',
with_handler => 0,
test_sets => [qw( filter )],
);
HTML-Mason-1.58/live-tests/live/cgi-with-handler.t 0000644 0001750 0001750 00000000427 13175376764 021525 0 ustar autarch autarch use strict;
use warnings;
use File::Spec;
use lib 'lib', File::Spec->catdir( 't', 'lib' );
use Mason::ApacheTest qw( require_cgi );
require_cgi();
Mason::ApacheTest->run_tests(
apache_define => 'CGI',
with_handler => 1,
test_sets => [qw( standard cgi )],
);
HTML-Mason-1.58/live-tests/live/libapreq-no-handler.t 0000644 0001750 0001750 00000000474 13175376764 022225 0 ustar autarch autarch use strict;
use warnings;
use File::Spec;
use lib 'lib', File::Spec->catdir( 't', 'lib' );
use Mason::ApacheTest qw( require_libapreq );
require_libapreq();
Mason::ApacheTest->run_tests(
apache_define => 'mod_perl_no_handler',
with_handler => 0,
test_sets => [qw( standard apache_request )],
);
HTML-Mason-1.58/live-tests/live/libapreq-with-handler.t 0000644 0001750 0001750 00000000461 13175376764 022560 0 ustar autarch autarch use strict;
use warnings;
use File::Spec;
use lib 'lib', File::Spec->catdir( 't', 'lib' );
use Mason::ApacheTest qw( require_libapreq );
require_libapreq();
Mason::ApacheTest->run_tests(
apache_define => 'mod_perl',
with_handler => 1,
test_sets => [qw( standard apache_request )],
);
HTML-Mason-1.58/live-tests/live/single-level-server-root.t 0000644 0001750 0001750 00000000405 13175376764 023246 0 ustar autarch autarch use strict;
use warnings;
use File::Spec;
use lib 'lib', File::Spec->catdir( 't', 'lib' );
use Mason::ApacheTest;
Mason::ApacheTest->run_tests(
apache_define => 'single_level_serverroot',
with_handler => 0,
test_sets => [qw( standard )],
);
HTML-Mason-1.58/live-tests/live/no-config.t 0000644 0001750 0001750 00000000443 13175376764 020254 0 ustar autarch autarch use strict;
use warnings;
use File::Spec;
use lib 'lib', File::Spec->catdir( 't', 'lib' );
use Mason::ApacheTest qw( require_libapreq );
require_libapreq();
Mason::ApacheTest->run_tests(
apache_define => 'no_config',
with_handler => 0,
test_sets => [qw( standard )],
);
HTML-Mason-1.58/live-tests/live/set-content-type.t 0000644 0001750 0001750 00000000462 13175376764 021620 0 ustar autarch autarch use strict;
use warnings;
use File::Spec;
use lib 'lib', File::Spec->catdir( 't', 'lib' );
use Mason::ApacheTest qw( require_libapreq );
require_libapreq();
Mason::ApacheTest->run_tests(
apache_define => 'set_content_type',
with_handler => 0,
test_sets => [qw( set_content_type )],
);
HTML-Mason-1.58/xt/ 0000775 0001750 0001750 00000000000 13175376764 013606 5 ustar autarch autarch HTML-Mason-1.58/xt/release/ 0000775 0001750 0001750 00000000000 13175376764 015226 5 ustar autarch autarch HTML-Mason-1.58/xt/release/meta-json.t 0000644 0001750 0001750 00000000064 13175376764 017306 0 ustar autarch autarch #!perl
use Test::CPAN::Meta::JSON;
meta_json_ok();
HTML-Mason-1.58/xt/author/ 0000775 0001750 0001750 00000000000 13175376764 015110 5 ustar autarch autarch HTML-Mason-1.58/xt/author/test-version.t 0000644 0001750 0001750 00000000637 13175376764 017743 0 ustar autarch autarch use strict;
use warnings;
use Test::More;
# generated by Dist::Zilla::Plugin::Test::Version 1.09
use Test::Version;
my @imports = qw( version_all_ok );
my $params = {
is_strict => 1,
has_version => 1,
multiple => 0,
};
push @imports, $params
if version->parse( $Test::Version::VERSION ) >= version->parse('1.002');
Test::Version->import(@imports);
version_all_ok;
done_testing;
HTML-Mason-1.58/xt/author/no-tabs.t 0000644 0001750 0001750 00000005054 13175376764 016642 0 ustar autarch autarch use strict;
use warnings;
# this test was generated with Dist::Zilla::Plugin::Test::NoTabs 0.15
use Test::More 0.88;
use Test::NoTabs;
my @files = (
'bin/convert0.6.README',
'bin/convert0.6.pl',
'bin/convert0.8.README',
'bin/convert0.8.pl',
'bin/mason.pl',
'lib/HTML/Mason.pm',
'lib/HTML/Mason/Admin.pod',
'lib/HTML/Mason/Apache/Request.pm',
'lib/HTML/Mason/ApacheHandler.pm',
'lib/HTML/Mason/CGIHandler.pm',
'lib/HTML/Mason/Cache/BaseCache.pm',
'lib/HTML/Mason/Compiler.pm',
'lib/HTML/Mason/Compiler/ToObject.pm',
'lib/HTML/Mason/Component.pm',
'lib/HTML/Mason/Component/FileBased.pm',
'lib/HTML/Mason/Component/Subcomponent.pm',
'lib/HTML/Mason/ComponentSource.pm',
'lib/HTML/Mason/Devel.pod',
'lib/HTML/Mason/Escapes.pm',
'lib/HTML/Mason/Exceptions.pm',
'lib/HTML/Mason/FAQ.pod',
'lib/HTML/Mason/FakeApache.pm',
'lib/HTML/Mason/Handler.pm',
'lib/HTML/Mason/Interp.pm',
'lib/HTML/Mason/Lexer.pm',
'lib/HTML/Mason/MethodMaker.pm',
'lib/HTML/Mason/Params.pod',
'lib/HTML/Mason/Parser.pm',
'lib/HTML/Mason/Plugin.pm',
'lib/HTML/Mason/Plugin/Context.pm',
'lib/HTML/Mason/Request.pm',
'lib/HTML/Mason/Resolver.pm',
'lib/HTML/Mason/Resolver/File.pm',
'lib/HTML/Mason/Resolver/Null.pm',
'lib/HTML/Mason/Subclassing.pod',
'lib/HTML/Mason/Tests.pm',
'lib/HTML/Mason/Tools.pm',
'lib/HTML/Mason/Utils.pm',
't/00-report-prereqs.dd',
't/00-report-prereqs.t',
't/01-syntax.t',
't/01a-comp-calls.t',
't/02-sections.t',
't/02a-filter.t',
't/04-misc.t',
't/05-request.t',
't/05a-stack-corruption.t',
't/06-compiler.t',
't/06a-compiler_obj.t',
't/06b-compiler-named-subs.t',
't/06c-compiler-spaces-path.t',
't/07-interp.t',
't/07a-interp-mcr.t',
't/07b-interp-static-source.t',
't/09-component.t',
't/09a-comp_content.t',
't/10-cache.t',
't/10a-cache-1.0x.t',
't/10b-cache-chi.t',
't/11-inherit.t',
't/12-taint.t',
't/13-errors.t',
't/14-cgi.t',
't/14a-fake_apache.t',
't/15-subclass.t',
't/17-print.t',
't/18-leak.t',
't/19-subrequest.t',
't/20-plugins.t',
't/21-escapes.t',
't/22-path-security.t',
't/23-leak2.t',
't/24-tools.t',
't/25-flush-in-content.t',
't/25-log.t',
't/lib/Apache/test.pm',
't/lib/BadModule.pm',
't/lib/LoadTest.pm',
't/lib/Mason/ApacheTest.pm',
't/run_one_test',
't/run_tests',
't/single_test.pl',
't/taint.comp'
);
notabs_ok($_) foreach @files;
done_testing;
HTML-Mason-1.58/xt/author/mojibake.t 0000644 0001750 0001750 00000000151 13175376764 017051 0 ustar autarch autarch #!perl
use strict;
use warnings qw(all);
use Test::More;
use Test::Mojibake;
all_files_encoding_ok();
HTML-Mason-1.58/xt/author/pod-syntax.t 0000644 0001750 0001750 00000000252 13175376764 017400 0 ustar autarch autarch #!perl
# This file was automatically generated by Dist::Zilla::Plugin::PodSyntaxTests.
use strict; use warnings;
use Test::More;
use Test::Pod 1.41;
all_pod_files_ok();
HTML-Mason-1.58/xt/author/pod-spell.t 0000644 0001750 0001750 00000005521 13175376764 017175 0 ustar autarch autarch use strict;
use warnings;
use Test::More;
# generated by Dist::Zilla::Plugin::Test::PodSpelling 2.007004
use Test::Spelling 0.12;
use Pod::Wordlist;
add_stopwords();
all_pod_files_spelling_ok( qw( bin lib ) );
__DATA__
AUTOHANDLERS
Admin
Adminstrator
Alex
Apache
ApacheHandler
ApacheModPerl
ApacheReload
Arnfjörð
Autohandlers
Balhatchet
BaseCache
Bekman
Bjarmason
CGI
CGIHandler
Cache
Compiler
Component
ComponentSource
ContactUs
Context
DROLSKY
DROLSKY's
DSO
Dave
DeWitt
Devel
DocumentRoot
DocumentRoots
Escapes
Exceptions
FAQ
FakeApache
Falcone
FastCGI
File
FileBased
FilesMatch
Fish
Follett
ForceFileDownload
Fredric
GIF
Georgiou
HPUX
HTML
HUP
Handler
HandlingDirectoriesWithDhandlers
Interp
John
Jonathan
Kane
Ken
Kent
Kevin
Khera
Kiriakos
Kirwan
Kumar
LFU
Lexer
LogLevel
MSIE
MailingLists
Mallah
Mason
MasonAllowGlobals
MasonApacheStatusTitle
MasonArgsMethod
MasonAutoSendHeaders
MasonAutoflush
MasonAutohandlerName
MasonBufferPreallocateSize
MasonCodeCacheMaxSize
MasonCompClass
MasonCompRoot
MasonCompilerClass
MasonComponentErrorHandler
MasonDataCacheApi
MasonDataCacheDefaults
MasonDataDir
MasonDeclineDirs
MasonDefaultEscapeFlags
MasonDefineArgsHash
MasonDhandlerName
MasonDynamicCompRoot
MasonEnableAutoflush
MasonErrorFormat
MasonErrorMode
MasonEscapeFlags
MasonIgnoreWarningsExpr
MasonInPackage
MasonInterpClass
MasonLexerClass
MasonMaxRecurse
MasonNamedComponentSubs
MasonObjectFileExtension
MasonOutMethod
MasonPlugins
MasonPostamble
MasonPostprocessPerl
MasonPostprocessText
MasonPreamble
MasonPreloads
MasonPreprocess
MasonRequestClass
MasonResolverClass
MasonStaticSource
MasonStaticSourceTouchFile
MasonSubcompClass
MasonUseObjectFiles
MasonUseSourceLineNumbers
MasonUseStrict
MasonUseWarnings
MethodMaker
Null
NullCache
O'Reilly
Params
Parser
Patrick
PayPal
PerlFreshRestart
PerlHandler
PerlModule
PerlSetVar
Plugin
Preallocating
Preloading
RPMs
Rajesh
RedHat
ReloadAll
Request
Resolver
Ricardo
Rolsky
Rolsky's
SUBCLASSABLE
SYNOPIS
Shlomi
Signes
Solaris
SpeedyCGI
Stas
Subclassing
Subcomponent
Subcomponents
Subrequests
Swartz
TIEHASH
Tests
ToObject
Tools
USR
UserDir
Utils
Vandiver
Vivek
Williams
ala
alex
apachectl
apachehandler
attr
autarch
autohandler
autohandlers
avarab
bgcolor
bin
breakpoint'able
certian
checksum
conf
convert0
corrup
defined'ness
dhandler
dhandlers
drolsky
dynamicImage
falcone
faq
fh
fido
filenaming
foobarbaz
gif
gifs
htaccess
html
interp
isNetscape
ized
izing
jpegs
jwilliams
kaoru
ken
kentnl
lexed
lib
libapreq
libexpat
mason
mc
mcomp
mhtml
modus
mpl
mtxt
nh
onwards
optimizations
overrideable
perlsub
postprocess
predeclaring
preload
preloaded
preloading
preloads
prepopulate
preprocess
profiler
rdist
reallocations
reparsed
reuseability
rjbs
scomp
se
serializable
shlomif
sql
srm
subcomponent
subcomponents
subcomps
subexec
subrequest
subrequests
swartz
taglibs
tgz
tmp
todo
un
undeclarable
unweakened
updateable
uring
use'd
xml
Ævar
HTML-Mason-1.58/benchmarks/ 0000775 0001750 0001750 00000000000 13175376764 015270 5 ustar autarch autarch HTML-Mason-1.58/benchmarks/comps/ 0000775 0001750 0001750 00000000000 13175376764 016411 5 ustar autarch autarch HTML-Mason-1.58/benchmarks/comps/print.mas 0000644 0001750 0001750 00000006453 13175376764 020255 0 ustar autarch autarch <%args>
$title
$integer
%args>
<% $title %>
<%perl>
# build tight loop table with array data, multidimensional 5x6
my @array = sort ("Hello", "World", "2000", "Hello", "World", "2000");
my @multi = (\@array, \@array, \@array, \@array, \@array);
%perl>
% for my $row (0..$#multi) {
% for my $col (0..$#array) {
<% $multi[$row][$col] %> |
% }
% }
<%perl>
for my $i (1..5) {
my $var = $i+$integer;
%perl>
<%$var%> Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World
<%$var%> Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World
<%$var%> Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World
<%$var%> Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World
<%$var%> Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World
<%$var%> Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World
<%$var%> Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World
<%$var%> Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World
<%$var%> Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World
<%$var%> Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World
<%$var%> Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World
<%$var%> Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World
<%$var%> Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World
<%$var%> Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World
<%$var%> Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World
<%$var%> Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World
<%$var%> Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World
<%$var%> Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World
<%$var%> Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World
<%$var%> Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World
<%perl>
}
%perl>
HTML-Mason-1.58/benchmarks/comps/comp_helper.mas 0000644 0001750 0001750 00000000046 13175376764 021406 0 ustar autarch autarch bar!
% my $x = 2;
<% $x %>
bar again!
HTML-Mason-1.58/benchmarks/comps/comp.mas 0000644 0001750 0001750 00000000252 13175376764 020046 0 ustar autarch autarch call comp_helper.mas a bunch
<& comp_helper.mas &>
<& comp_helper.mas &>
<& comp_helper.mas &>
<& comp_helper.mas &>
<& comp_helper.mas &>
<& comp_helper.mas &>
called it HTML-Mason-1.58/benchmarks/bench.pl 0000755 0001750 0001750 00000011264 13175376764 016711 0 ustar autarch autarch #!/usr/bin/perl -w
use strict;
use lib '../lib';
use Benchmark;
use Cwd;
use Fcntl qw( O_RDWR O_CREAT );
use Getopt::Long;
use MLDBM qw( DB_File Storable );
use Proc::ProcessTable;
use File::Path;
use File::Spec;
my %tests =
( print =>
{ code =>
sub { call_comp( '/comps/print.mas', title => 'print', integer => 1000 ) },
description =>
'Calls $m->print many times.',
},
one_comp =>
{ code =>
sub { call_comp( '/comps/comp.mas' ) },
description =>
'Calls a single component',
},
large =>
{ code =>
sub { call_comp( '/comps/large.mas' ) },
description =>
'Calls a very large text-only component',
},
);
my %flags =
(
test => {type => ':s',
descr => 'Specify one or more tests to perform.',
default => []},
profile =>
{descr => '(Not implemented)'},
reps => {type => ':i',
descr => 'Number of times to repeat each test. Defaults to 1000.',
default => 1000},
save => {descr => 'Saves information to result_history.db (an MLDBM DB_File).'},
cvs_tag =>
{type => ':s',
descr => 'A CVS tag (like "-r release-1-1-5") to check out in lib/ first.'},
tag => {type => ':s',
descr => 'Specifies a tag to save to result_history.db. '.
'Default is $HTML::Mason::VERSION or --cvs_tag value.'},
clear_cache =>
{descr => 'Will clear on-disk cache first. Useful for exercising the compiler.'},
help => {descr => 'Prints this message and exits.'},
);
my %opts;
$opts{$_} = $flags{$_}{default}
foreach grep exists($flags{$_}{default}), keys %flags;
{
local $^W;
GetOptions( \%opts, map "$_$flags{$_}{type}", keys %flags );
}
if ( $opts{help} )
{
usage();
exit;
}
die "$0 must be run from inside the benchmarks/ directory\n"
unless -e 'comps' and -d 'comps';
my $large_comp = File::Spec->catfile( 'comps', 'large.mas' );
# Don't check this into CVS because it's big:
unless ( -e $large_comp )
{
open my $fh, ">$large_comp" or die "Can't create $large_comp: $!";
print $fh 'x' x 79, "\n" for 1..30_000; # 80 * 30_000 = 2.4 MB
}
if ($opts{cvs_tag})
{
my $cwd = cwd();
my $lib = File::Spec->catdir( $cwd, '..', 'lib' );
print "chdir $lib\n";
chdir $lib or die "Can't chdir($lib): $!";
my $cmd = "cvs update $opts{cvs_tag}";
print "$cmd\n";
open my($fh), "$cmd |" or die "Can't execute '$cmd': $!";
print while <$fh>;
close $fh or die "Can't close command: $!";
$opts{tag} ||= $opts{cvs_tag};
chdir $cwd or die "Can't chdir($lib): $!";
}
# Do this only after updating lib/ to proper CVS version
require HTML::Mason;
$opts{tag} ||= $HTML::Mason::VERSION;
# Clear out the mason-data directory, otherwise we might include
# compilation in one run and not the next
my $data_dir = File::Spec->rel2abs( File::Spec->catdir( cwd, 'mason-data' ) );
rmtree($data_dir) if $opts{clear_cache};
foreach my $test ( @{ $opts{test} } )
{
unless ( exists $tests{$test} )
{
print "\n*** Invalid test: $test\n";
usage();
exit;
}
}
my $interp =
HTML::Mason::Interp->new( comp_root => File::Spec->rel2abs(cwd),
data_dir => $data_dir,
);
my ($proc) = grep { $_->pid == $$ } @{ Proc::ProcessTable->new->table };
print "\n";
foreach my $name ( @{ $opts{test} } )
{
my $results = Benchmark::timethis( $opts{reps}, $tests{$name}{code}, $name );
my $per_sec = sprintf( '%.2f', $opts{reps} / ($results->[1] + $results->[2]) );
my $rss = sprintf( '%.2f', ( $proc->rss / 1024 ) );
my $size = sprintf( '%.2f', ( $proc->size / 1024 ) );
# my ($rss, $vsz) = `ps -eo rss,vsz -p $$` =~ /(\d+)\s+(\d+)/;
print " Real mem: $rss MB\n";
print "Virtual mem: $size MB\n";
if ( $opts{save} )
{
my %save;
tie %save, 'MLDBM', 'result_history.db', O_CREAT | O_RDWR, 0644
or die "Cannot tie to result_history.db: $!";
my $tag = $opts{tag};
my $old = $save{$tag};
$old->{$name} ||= [];
push @{ $old->{$name} }, $per_sec;
$save{$tag} = $old;
}
}
print "\n";
sub call_comp
{
my ($comp, @args) = @_;
my $out;
$interp->out_method(\$out);
$interp->exec( $comp, @args );
}
sub usage
{
my $comps;
foreach my $name ( sort keys %tests )
{
$comps .= sprintf( " %-10s %s\n", $name, $tests{$name}{description} );
}
my $opts;
foreach my $name ( sort keys %flags )
{
$opts .= sprintf " %13s %s\n", "--$name", $flags{$name}{descr};
}
print <<"EOF";
Usage: $0
$opts
Valid tests include:
$comps
EOF
}
HTML-Mason-1.58/benchmarks/multiple_benches.pl 0000755 0001750 0001750 00000000453 13175376764 021152 0 ustar autarch autarch #!/usr/bin/perl
# This program accepts a list of CVS revision tags (or dates) and a
# benchmark to run. It then checks out the versions of Mason
# indicated and uses them when running the benchmark indicated. This
# helps facilitate tracking how Mason has changed over time on the
# benchmarks.
HTML-Mason-1.58/INSTALL 0000644 0001750 0001750 00000002164 13175376764 014205 0 ustar autarch autarch This is the Perl distribution HTML-Mason.
Installing HTML-Mason is straightforward.
## Installation with cpanm
If you have cpanm, you only need one line:
% cpanm HTML::Mason
If it does not have permission to install modules to the current perl, cpanm
will automatically set up and install to a local::lib in your home directory.
See the local::lib documentation (https://metacpan.org/pod/local::lib) for
details on enabling it in your environment.
## Installing with the CPAN shell
Alternatively, if your CPAN shell is set up, you should just be able to do:
% cpan HTML::Mason
## Manual installation
As a last resort, you can manually install it. Download the tarball, untar it,
then build it:
% perl Makefile.PL
% make && make test
Then install it:
% make install
If your perl is system-managed, you can create a local::lib in your home
directory to install modules to. For details, see the local::lib documentation:
https://metacpan.org/pod/local::lib
## Documentation
HTML-Mason documentation is available as POD.
You can run perldoc from a shell to read the documentation:
% perldoc HTML::Mason
HTML-Mason-1.58/Changes 0000644 0001750 0001750 00000262644 13175376764 014462 0 ustar autarch autarch Revision history for HTML::Mason.
** denotes an incompatible change
1.58 2017-10-29
- Redid the release because of some dzil issues. 1.57 might be a little
wonky.
1.57 2017-10-29
[ BUG FIXES ]
- Fix test failures under 5.26.0+ due to "." no longer being in @INC. PR
By Kent Fredric. GH #6. Fixed RT #121443.
1.56 2014-11-14
[ BUG FIXES ]
- Fix a packaging issue with the last release that prevented PAUSE from
indexing some modules in the tarball.
1.55 2014-11-14
[ BUG FIXES ]
- Shut up warnings from recent versions of CGI.pm. Patch by Kevin
Falcone. GitHub PR #1.
1.54 Jan 19, 2014
[ DISTRIBUTION ]
- Remake with gnutar
1.53 Jan 18, 2014
[ DISTRIBUTION ]
- Attempt to fix corrupted tar
1.52 Oct 9, 2013
[ BUG FIXES ]
- Ignore 'Software caused connection abort' errors. RT #49031. Submitted
by Morten Bjoernsvik.
- Sort hash keys to deal with Perl 5.18+ hash randomization. RT
#88708. Submitted by Zefram.
- Fix 'and' precedence with explicit parens. RT #87050. Submitted by
Alex Vandiver.
- Escape each part of substitution, not their
concatenation. github.com/jonswar/perl-HTML-Mason/pull/1. Submitted
by Ricardo Signes.
[ ENHANCEMENTS ]
- Add use_warnings flag, similar to
use_strict. github.com/jonswar/perl-HTML-Mason/pull/4. Submitted by
Aevar Bjarmason.
1.51 May 8, 2013
[ DISTRIBUTION ]
- Fix hardcoded version
[DOCS]
- Add HTML::Mason::FAQ, from old masonhq.com website
1.50 Jul 11, 2012
[ DISTRIBUTION ]
- Switch to Dist::Zilla
- Eliminate HTML docs from distribution, available on web
- Move live Apache tests to author-only
1.49 Feb 27, 2012
[ DOCS ]
- Fixed misspellings in docs. RT #74676. Reported by Salvatore Bonaccorso.
1.48 Feb 3, 2012
[ BUG FIXES ]
- Calling a subcomponent from inside an anonymous component (created via
$interp->make_component) caused an uninitialized value warning. Reported by
Javier Amor Garcia.
1.47 Oct 21, 2011
[ BUG FIXES ]
- Silenced an uninitalized value warning from ApacheHandler with newer
versions of Perl. RT #61900.
1.46 Aug 1, 2011
[ DOCS ]
- Mention Mason 2 in documentation
1.45 Apr 3, 2010
[ BUG FIXES ]
- Silenced some new warnings that appeared when using Mason with Perl
5.12.0+. Reported by Jesse Vincent.
1.44 Jan 4, 2010
[ ENHANCEMENTS ]
- Use Log::Any to log various events, such as the start and end of each
request and each component call.
- Add $m->log, allowing easy logging to a component-specific namespace.
- Fix use of CHI when no data directory is specified.
1.43 Dec 25, 2009
[ BUG FIXES ]
- If a component was located in a patch with spaces, the feature which
referred to errors by their source file line number was broken. This could
cause test failures if the package was downloaded into a path with spaces by
CPAN. Reported by Shawn Moore. RT #53072.
- HTML::Entities is no longer an optional dependency. This fixes some issues
with packaged versions of Mason. Reported by Jens Rehsack. RT #48890.
- $m->flush_buffer is now ignored when inside $m->scomp or $m->content. Patch
by Frédéric Brière, with extra tests from Ruslan Zakirov. RT #38924.
1.42 May 7, 2009
[ BUG FIXES ]
- Fix 10b-cache-chi.t to work with latest version of CHI - expire_if
and ref of cache changed
- Fixed a bug where attempting to load a module that failed to compile
in a Mason component could mask the compilation error. RT #39803.
- Fixed the print method in HTML::Mason::FakeApache. It was including
the object itself in the output. Patch by Martin Petricek. RT
#43035.
1.41 May 5, 2009
[ BUG FIXES ]
- This is a one-fix release to get this module working with the latest
version of Exception::Class (1.27).
1.40 Jul 24, 2008
[ BUG FIXES ]
- Attempting to set multiple cookies when running under CGIHandler
failed. Patch by Andrej Czapszys. RT #33710.
- The Request->alter_superclass() method could cause a segfault
(sometimes) with perl 5.10.0. Reported and patched by Jesse Vincent.
1.39 Jan 30, 2008
[ ENHANCEMENTS ]
- CHI may now be used as the backend for $m->cache as an updated
alternative to Cache::Cache. Among other things, this facilitates
easy use of Cache::FastMmap and memcached for data
caching. Cache::Cache is still the default for now, and is still
listed as a prereq for Mason.
1.38 Dec 20, 2007
[ BUG FIXES ]
- (Hopefully) fixed a problem where the cpan shell thought that Mason
needed mod_perl1 as a prereq when it was trying to require a newish
version of mod_perl2.
- If you called $r->send_http_header() explicitly in a component under
mod_perl 1.x, headers would end up getting sent again once the
component finished executing. Reported by Brett Gardner.
- Component call with content end tags could not span multiple
lines. Fixing this makes it consistent with the opening tag. Patch
by Alex Robinson.
- Includes a possible fix for a test failure in 10-cache.t. This
failure is a problem in the test code, not the Mason core code.
1.37 Sep 6, 2007
[ BUG FIXES ]
- Mason could send the HTTP headers twice under mod_perl 1.x when
making a request for a directory path that was handled by a
dhandler. Reported by David Beaudet.
- If you set the Content-Type header in a handler sub before passing
control to Mason via ApacheHandler, this value was overwritten if
the request was for a directory path.
[ ENHANCEMENTS ]
- Make t/08-ah.t and t/16-live-cgi.t more verbose about why they are
skipping tests when they do so. Based on a patch from
C.J. Adams-Collier.
1.36 Jun 10, 2007
[ BUG FIXES ]
- If a component with content call ending tag appeared inside a
subcomp or method without an opening tag, then the compiler dies
with a Perl error, rather than reporting the error
usefully. Reported by Rich Williams.
- Under mod_perl 2, if decline_dirs was false and a directory was
requested, you got a "Use of uninitialized value" warning from
ApacheHandler in your logs. Reported by Ogden Nefix.
- HTML::Entities is now a prereq. Not requiring it made for various
weird gyrations in the tests that didn't seem to work all the time,
causing various failures. Fixes RT #24827.
- Request::CGIHandler->exec() now returns the return value from
executing the component, just like a normal Request. Reported by
Adrian Irving-Beer.
[ ENHANCEMENTS ]
- Added a new Compiler::ToObject parameter,
named_component_subs. Turning this on makes it possible to profile
components.
- Added a new Request parameter, component_error_handler. This can be
set to change how component compilation and runtime errors are
handled. It can also be set to false to just let errors go
unhandled, which could speed up apps that throw a lot of non-object
exceptions.
1.35 Oct 17, 2006
[ BUG FIXES ]
- Version 1.34 introduced a bug that caused corruption of the callers
stack when a component call with content was used.
- When Mason tried to load a package required for a feature (like
Cache::Cache for $m->cache) and this failed, the error message would
say something like "Can't locate Cache::Cache". However, the real
error could be that Cache::Cache was present, but a module required by
Cache::Cache was not. Now we report the real missing module.
- Some people saw a spurious test failure in 05-request.t. RT #22099.
- Added Module::Build to the build_requires prereqs.
1.34 Oct 14, 2006
[ BUG FIXES ]
- List Module::Build as a build prereq in the Build.PL, so it shows up
in META.yml. Reported by Colin Henein. RT #22097.
- Apache::Request and mod_perl{1,2} will no longer show up as prereqs
in META.yml. Requested by Jesse Vincent.
- Fixed a serious memory leak bug where an object referenced in
arguments to another component was never destroyed. Reported by
Dominic Mitchell.
- Using $m->call_next from a helper component should reset base_comp
to the request_comp. Reported by Mark Elrod.
- The 08-ah.t and 16-live-cgi.t test files could fail with an error
like "Failed to re-load 'Mason::Build'" when Mason was being installed
via the CPANPLUS shell (and maybe other cases). Reported by David
Wheeler.
- Fixed a bug where $m->clear_buffer inside a component called from a
comp_with_content did not clear all buffers.
[ ENHANCEMENTS ]
- Added support for get_server_port() in FakeApache. Patch from Dieter
Piercey.
1.33 May 28, 2006
[ BUG FIXES ]
- If $m->flush_buffer() was called when there was a filter somewhere
in the component chain, the flush did nothing. Task id #596. Reported
by Shane McCarron.
- Added several tests for $m->flush_buffer() and $m->clear_buffer(),
which will hopefully avoid more bugs in this part of the code.
- On Win32, a test failed when Mason tried to use rename to move a dir
into an existing dir. Patch by Shane McCarron. Task id #594 and RT
#17828.
- Trying to load HTML::Mason::ApacheHandler outside of mod_perl caused
an error "like Undefined subroutine &Apache::perl_hook called at
/usr/local/share/perl/5.8.7/HTML/Mason/ApacheHandler.pm line
257". While it will never _run_ outside of mod_perl, it should at
least load.
- Fixed test in 14a-fake_apache.t that failed with CGI.pm >= 3.16.
- The example code in the HTML::Mason::Resolver::Null code was
just wrong. Fixed by John Siracusa.
- Fixed a test failure in 06-compile.t when using bleadperl. RT
#17118.
1.32 January 3, 2006
[ BUG FIXES ]
- Under mod_perl 1.x with error_mode set to output, the headers were
sent after the content when a compilation error occurred. Reported by
Gareth Kirwan. Task id #592.
- URI-escape utf8 characters the same way that CGI::escape and
URI::Escape::uri_escape_utf8 do. Patch by Denis Shaposhnikov.
- On startup Mason creates a file named ".__obj_create_marker" in the
object directory. Under mod_perl, Mason was not chmod'ing the file
when Apache was started as root. This led to permission errors in
environments where the Interp is created anew every request. Task id
#593.
- Treat the return value of component execution as a string in
ApacheHandler. This prevent warnings about comparing the empty string
to a number when a component returns "". Reported by Benjamin Franz.
- Setting a MasonPlugins Apache parameter caused a fatal error. Patch
by David Jack Olrik.
- Calling base_comp() on the Request object inside a plugin's
start_request_hook method caused an infinite recursion in Mason.
Reported by Jesse Vincent.
1.3101 August 23, 2005
[ BUG FIXES ]
- One last fix for CGIHandler. If you provided your own out_method it
was ignoring it and using its own. Reported by David Glasser.
1.31 August 20, 2005
[ BUG FIXES ]
- Fix several regressions in the CGIHandler and FakeApache modules.
Some changes from the stable branch were never merged into the trunk
before 1.30. Reported by Jesse Vincent. Task id #589.
- Under Apache2, if an ApacheHandler object was created during server
startup and the associated Interp object created any files or
directories, Mason would crash when attempting to chown those
files/dirs to the uid/gid that Apache will use after forking. Task
#586.
- The compiler was adding an extra block around a component's
body, which meant that variables declared in the body (in perl lines
or blocks) were not seen in the cleanup section. Task id #587.
- The compiler was also adding "no warnings 'uninitialized'" in this
block, which could hide various errors.
- Hopefully fix $VERSION in ApacheHandler so PAUSE will not be
confused and think we have regressed.
- Turned off some prompts during the module's installation. These
were intended to help new users configure Apache to run Mason
components, but they're probably a bit confusing. Will return in a
future release as a separate script that can be run from the command
line.
1.30 August 11, 2005
[ INCOMPATIBLE CHANGES ]
- ** Under mod_perl2, MasonArgsMethod will default to "CGI", since
libapreq2 is still in development. If you have successfully installed
libapreq2, just set MasonArgsMethod to "mod_perl" to use it.
[ ENHANCEMENTS ]
- Some doc tweaks to clarify that Mason should work out of the box
with both mod_perl 1 and 2.
- Added "use warnings" to all modules and made sure all tests ran
warnings-free.
[ BUG FIXES ]
- Silence a warning when HTML::Mason::ApacheHandler was loaded outside
of mod_perl.
- Support renamed Apache2::Status module.
1.29_02 June 22, 2005
[ ENHANCEMENTS ]
- ** Support for mod_perl-2.00 (mod_perl-1.99 is no longer supported
because of API changes in 2.0RC5).
- Mason recovers more gracefully from an empty or corrupted object
file. Task id #579.
[ BUG FIXES ]
- Fixed bug with content type being reset when decline_dirs=0.
Submitted by Brian Phillips. Task id #584.
- Put "Mason" prefix back in Params.pod. Task id #575.
- Fixed fetch_comp(undef) to not return an empty hash. Task id #578.
- static_source_touch_file did not take effect until after one request
for a top-level component. Reported by Lai Zit Seng. Task id #576.
1.29_01 January 25, 2005
[ INCOMPATIBLE CHANGES ]
- ** Mason now requires Perl 5.6.0 or later. However, because 5.6.0
has so many problems, it cannot be officially supported; we strongly
recommend upgrading to at least 5.6.1.
- ** Mason now requires version 1.24 of mod_perl in the ApacheHandler
module.
- ** The behaviors of $m->flush_buffer and $m->clear_buffer have been
simplified. $m->flush_buffer only acts on the top-level output buffer;
$m->clear_buffer clears all output buffers. Task id #554.
- ** max_code_cache_size is now kept in terms of number of components,
not bytes, and its default value is 'unlimited'.
- ** Components with a <%filter> and a cache_self are no longer cached
in their filtered state. Performance-related code simplifications made
this behavior difficult to maintain. Long term this would be
easier to implement with a cache_self component <%flag>.
- ** All compiler properties are now read-only. If you need to change
compiler properties on a per-request basis, you'll need to create
multiple compiler and interpreter objects.
- ** comp_exists may try to load the designated component, and may
throw an error if it contains a syntax error.
- ** The current_time method, deprecated in 1.1x, has been removed.
- ** The HTML::Mason::Buffer class has been eliminated for performance
reasons. You can use separate components, methods, or subcomponents
and scomp to achieve the same effects as buffer pushes and pops.
[ ENHANCEMENTS ]
- Significantly improved performance in component execution,
especially in static_source mode.
- Added static_source_touch_file, making it much easier to update
a server running in static_source mode.
- Added a plugin architecture. Plugin classes can perform actions at
key points, e.g. before and after each request and each component
call. See HTML::Mason::Plugin for documentation. Task id #24.
Initial implementation by Doug Treder.
- Added the ability to change component root(s) on the fly if the
dynamic_comp_root parameter is turned on. Task id #561. Suggested
by Alex Robinson.
- Added enable_autoflush parameter. When turned off, Mason can
compile components to a more efficient form.
- Changed the &> tag to allow the starting component name to be
included. e.g. <&| /foo &> ... & /foo >. Task id #556. Suggested
by Alex Robinson, John Williams, and others.
- Moved the notion of component roots (single and multiple) from the
Resolver to the Interpreter. This improved the performance of multiple
component roots in conjunction with static source mode. Any resolver,
file-based or otherwise, can benefit from component root settings or
choose to ignore them.
- Added the compiler object_id to the object file path, so that
multiple versions of Mason do not collide in the same object
directory. Task id #569.
- Added .obj (or a configurable extension) to object filenames.
Task id #152. Suggested by John Tobey.
- Added $m->clear_and_abort, syntactic sugar for the common idiom
of calling clear_buffer() and then abort(). Task id #505.
- Added an official comment syntax, <% # ... %>, and documented
the various comment markers in the developer's manual. Task id #566.
- Added buffer_preallocate_size parameter, which allows you to
potentially reduce buffer reallocations.
- Augmented the 'could not find component' error message with the
current component root(s). Task id #562.
[ BUG FIXES ]
- Mason now throws an error if the path specified in a component's
'inherit' flag cannot be found. Task id #480.
- Fixed comp_exists to work with any path accepted by comp or
fetch_comp, and fixed fetch_comp to stop throwing errors for certain
bad paths. Task id #572.
- Fixed $m->decline to work from /dhandler. Task id #573. Submitted
by Carl Raiha.
- Using 'next' or 'last' without a loop can no longer corrupt
the component stack. Task id #539.
1.28 November 6, 2004
This version is entirely identical to 1.27 except for a fix to make
CPAN/PAUSE properly index the version number in
HTML::Mason::ApacheHandler. If you already installed 1.27 you do not
need to install this version unless you want to fix the "out of date
modules" report from the CPAN or CPANPLUS shells.
1.27 October 28, 2004
[ ENHANCEMENTS ]
- Full support for Apache2/mod_perl2.
[ BUG FIXES ]
- The request object was not available as $m in the preamble if
in_package was set. Reported by David Wheeler and David Baird. Task
id #538.
- Component with subcomponents or methods were not getting freed when
they were purged from the code cache. Task id #549.
- Component calls (<& &>) starting with a newline were compiled
incorrectly. Reported by Rick Delaney. Task id #564.
- If both a parent request and subrequest had autoflush set, output
from the subrequest wasn't actually flushed. Reported by Tony
Clayton. Task id #550.
- The documentation in HTML::Mason::Tests for the path and call_path
parameters was wrong. Reported by Michael Gray. Task id #528.
- Line numbers in errors were incorrectly reported if the error
happened in code after an <%args>, <%attr>, or <%flags> block.
Reported by Tony Clayton. Task id #552.
- The Apache handler now only sends headers once if make_request()
aborts, such as when a redirect is executed in a
MasonX::Interp::WithCallbacks callback.
1.26 April 5, 2004
[ BUG FIXES ]
- The fix to make CGIHandler support flush_buffer and autoflush caused
it to not rethrow any exceptions created during the request. If
error_mode was set to 'fatal', then an error would simply cause no
output to be generated. Task id #531.
- A comment in the last line of a component call with content caused a
syntax error in the compiled component. Reported by Todd Goldenbaum.
Task id #530.
- The various request handling methods in CGIHandler once again return
the value of calling the Interp object's exec() method.
- CGIHandler now explicitly handles redirect statuses when an abort
exception is thrown from the Interp object's exec() method. This
fixes some problems when this module was used with David Wheeler's
MasonX::Interp::WithCallbacks module.
- Using a <%shared> block when "in_package" was set to something other
than HTML::Mason::Commands led to an error like "Can't call method
"call_dynamic" on an undefined value". Reported by David Wheeler.
Task id #535.
1.25 December 12, 2003
[ BUG FIXES ]
- CGIHandler did not support $m->flush_buffer or autoflush. Reported
by Shane McCarron.
- Every line in the error stacktrace had a 'g' appended to it in HTML
error mode.
- The HTML error display of the stacktrace was not filtering out some
packages that it should have, so there were extra lines that made it
harder to find the real error.
- Several FakeApache methods were broken: path_info, uri, and
the_request. Reported by Matthias F. Brandstetter.
[ ENHANCEMENTS ]
- The CGIHandler request object now supports the autoflush parameter.
1.24 November 12, 2003
[ BUG FIXES ]
- Two tests in 04-misc.t, #9 and #10, failed if Params::Validate 0.66+
was installed. This happened because an error message given by
Params::Validate changed slightly, and was not a problem in the Mason
core code.
- The Component object method attr_if_exists returned 0 when the
attribute didn't exist, instead of undef as is documented. Reported
by Chris Reinhardt.
- The HTML::Mason::Resolver::File glob_path method, which is used for
the preloads feature, now uses File::Glob::bsd_glob when run with Perl
5.6.0+. This function properly handles spaces in filenames, which are
legal on most systems, and common on Win32. Implemented by Autrijus
Tang.
- The Admin guide erroneously said that the default component root
when running Mason outside a web environment was "/". It is the
current working directory. Reported by Patrick Kane.
1.23 September 8, 2003
[ ENHANCEMENTS ]
- Lots of enhancements to the Apache.pm emulation when using the
CGIHandler module. Implemented by David Wheeler.
- The fact that autohandlers or dhandlers can be turned off by setting
autohandler_name or dhandler_name to "" has now been documented, and
we explicitly check for this in the code. Task id #499.
- The ApacheHandler module now handles certain exceptions
(TopLevelNotFound, Abort, Decline) thrown from the Interp class's
make_request method by returning the desired error code. With the
default Mason Interp & Request classes, this will never happen.
However, subclasses may want to throw exceptions when constructing a
request. Implemented by David Wheeler.
[ BUG FIXES ]
- If any code type parameters were set in the httpd.conf file, Mason
died trying to read them. This bug was introduced in version 1.20.
Task id #496. Reported by David Wheeler.
- $m->caller, $m->callers and $m->caller_args now return undef or an
empty list instead of crashing when the specified stack level does not
exist. Task id #495. Reported by Bernhard Schmalhofer.
- The busy_lock option to $m->cache->get did not accept did not accept
string values for durations, like "4m". Task id #484. Reported by
Igor Muratov.
- When generating the HTML error message page, we now only use basic
HTML escaping. This fixes two problems. One is that if
HTML::Entities is not installed, using the "|h" escape flag in the
error display component causes an endless loop. The other is that the
"|h" flag can mangle non-Latin-1 characters. Task ids #497 and #494.
Reported by Harmen and Oleg Bartunov respectively.
- If a component generated output, then called another component via
$m->scomp, and that other component attempted to clear the buffer and
then abort, any output generated before the call to $m->scomp was
still sent to the client. This broke calling $m->redirect inside an
$m->scomp call. Task id #498. Reported by Kim Alexander Hansen.
1.22 July 14, 2003
[ ENHANCEMENTS ]
- Added $m->has_content to check for content without evaluating it.
- Comments are now allowed on separate lines inside <%attr> and
<%flags> blocks. Task id #475.
- $m->subexec and $m->make_subrequest now accept relative paths which
are interpreted relative to the current component directory, like
$m->comp.
- Documented potential problems if call to $m->redirect is trapped in
an eval block, and then output is generated before the exception is
rethrown. Task id #477.
[ BUG FIXES ]
- If a component with a filter section called abort, the filter was
run twice. Task id #473.
- If an exception was thrown when creating a request, memory was
leaked. This can happen when the top-level component cannot be
found (e.g. 404) or if there is an error in compiling the top-level
component. Task id #478. Reported by Doug Treder.
- Removed the use of alarm() and SIG{ALRM} to trap rare infinite loops
inside the compilation of components. It interfered with Mason
environments that use alarm() for their own purposes, and the
associated test would crash in certain Perl environments. If you find
that Mason sometimes enters an infinite loop, see the
"Hanging Processes: Detection and Diagnostics" section of the mod_perl
guide for hints on diagnosing the problem. Task id #472.
- Mason allowed a component to define two subcomponents or methods
with the same name. Task id #476. Reported by John Michael Mars.
1.21 June 4, 2003
[ INCOMPATIBLE CHANGES ]
- ** The semantics of @_ for components now match Perl subroutines: @_
contains aliases to the caller's arguments, instead of copies. For
example, if a component updates $_[0], the corresponding argument is
updated (or an error occurs if it is not updateable). The only users
that will notice this are those that update elements of @_ in
components and do not expect those changes to affect the caller. If
you have any doubts, grep your component tree for '\$_\[' and look for
assignment statements.
[ ENHANCEMENTS ]
- Cache the result of taint_is_on() for performance.
- Mason was copying arguments several times for a request, and several
more times for each component call. The unnecessary copies have been
eliminated. As part of eliminating these copies, a new compiler
parameter has been added, "define_args_hash". The default setting,
"auto", should work with all existing Mason components. See the
HTML::Mason::Compiler::ToObject docs for details. Task id #464.
Suggested by Doug Treder.
- Added more details about subclassing the compiler to the Subclassing
documentation.
- There is now a compiler parameter called "use_source_line_numbers",
which can be used to turn off line numbering based on the source file.
This can be useful when single stepping a component through the
debugger. Task id #461.
[ BUG FIXES ]
- Fixed a serious error in which a Compiler that was used on a
component containing certain kinds of syntax errors would claim that
any future components also contained syntax errors. Task id #467.
- Now assigning runtime properties (such as interp) to method
component objects as well as subcomponent objects. Task id #462.
- Fixed the HTML error display. Errors were not being properly
HTML-escaped. Task id #468. Reported by Jeremy Blain.
- A bad interaction between the XS version of Params::Validate, Perl
5.00503 and taint mode has been "fixed" by requiring Params::Validate
0.59, where the problem is fixed. Task id #470.
- The test suite now runs the taint mode tests with earlier versions
of Perl. Task id #471.
- The ApacheHandler module would go into an infinite memory-eating
loop when run in taint mode with Perl 5.6.1. Task id #469. Reported
by William McKee.
1.20 May 1, 2003 (May Day)
[ ENHANCEMENTS ]
- Added an $m->notes() method, which is similar to $r->pnotes() but
may be used outside a mod_perl environment. Task id #449.
- Mason will now only convert non-reference exceptions to
HTML::Mason::Exception objects, so it should cooperate better with
modules like Error.pm. Task id #446.
- Added more documentation on Mason's error handling and exception
system. Task id #446.
- If Mason was configured via the Apache httpd.conf file, it could in
many cases be quite a bit slower than configuration via a custom
handler subroutine. Now configuration via the httpd.conf is much
faster, and is only about 5% slower than a custom handler subroutine.
Reported by Jeremy Blain.
- Mason's test harness now gives verbose output when the TEST_VERBOSE
environment variable is true. This eliminates the need for setting
MASON_VERBOSE.
- ** It is now an error to have a subcomponent and method with the
same name in a single component.
[ BUG FIXES ]
- Mason would die if asked to compile a component that evaluates
to a false value. Task id #444. Reported by David Wheeler.
- Mason now gives a better error message if you try to call a
component's methods or subcomponents from its <%shared> block. Task
id #448. Reported by Randy Harmon.
- If in_package was set, Mason would die if output was generated after
a subrequest. Task id #453. Reported by David R. Baird.
- If Perl's print() was called after a subrequest, Mason would die
when run with any Perl before 5.8.0. Task id #458.
- If a component called $m->cache_self, and then $m->decline, no
output would be generated. Task id #454. Patch by Vadim Ustiansky.
1.19 March 3, 2003
[ BUG FIXES ]
- Fixed a very nasty bug that could cause subcomponents or methods
from one component to show up in another components. Task id #443 in
todo list.
- If the closing tag of a <%flags>, <%attr>, or <%args> block
contained upper case characters, the component would not be parsed
properly. Reported by Chris Snyder. Task id #440 in
todo list.
- Providing a Resolver object directly to the ApacheHandler
constructor caused a fatal error. Reported by Kwindla Kramer. Task
id #441 in todo list.
1.18 January 24, 2003
[ BUG FIXES ]
- Require Exception::Class 1.09. Version 1.08 has a bug that causes
problems with Mason when used with any Perl earlier than 5.8.0.
- Fix a bug in the lexer code that caused Mason to not work with Perl
5.00503 at all.
1.17 January 17, 2003
[ ENHANCEMENTS ]
- Added "REQUEST:" as a component specifier for method comp calls,
similar to "SELF:" and "PARENT:". "REQUEST:" is short-hand for
$m->request_comp. Suggested by Manuel Capinha, among others.
- Added $m->call_self. This was present in Mason pre-1.10, and has
been added back per Jon Swartz's request.
- Added $comp->attributes, similar to $comp->methods. This just
returns attributes for a given component object. It doesn't return
attributes inherited from a parent. Suggested by Matti Makitalo.
[ BUG FIXES ]
- ** When $m->cache_self was used for a component with a filter block,
the output would be cached _before_ filtering, and filtered every time
it was retrieved from the cache. This has been fixed, and the
documentation now specifies that the filtered output is cached.
- Fixed failure of 12-taint.t #7 on Win32 boxes. Reported by Randy
Kobes.
- Without HTML::Entities installed, 13-errors.t #7 failed. Reported
by Sam Kington.
- $m->file did not handle relative paths properly when called from a
subcomponent or method. Reported by Chris Hutchinson.
- If $m->abort was called in the shared block of a component that had
a filter, then a fatal error occured. Reported by Chris Pudney.
- Mason was not cooperating with Apache::Filter, and attempts to
filter Mason's output did not work. Fixing this also requires
Apache::Filter 1.021, if you are using Apache::Request to handling
incoming arguments. Reported by by Manuel Capinha.
- Mason assumed that if Scalar::Util loaded without errors, it had a
weaken() subroutine. However, Scalar::Util provides a pure Perl
implementation that does not include this subroutine. Now we check
for this subroutine explicitly. Reported by Autrijus Tang.
- Some code constructs, such as qw() lists, would end up being turned
into invalid code during component compilation. Reported by Robert
Landrum.
- Subclassing a subclass of HTML::Mason::Request broke when the class
between HTML::Mason::Request and your own class called
alter_superclass.
- Under mod_perl 2.0, when ApacheHandler could't resolve a filename to
a component, it would die instead of returning a not found status.
[ INCOMPATIBLE CHANGES ]
- ** Removed the long deprecated and undocumented $comp->parent_comp
method. Use $comp->owner instead.
1.16 December 13, 2002
[ ENHANCEMENTS ]
- Documented behavior of $m->flush_buffer when a filter is present.
- Turned off "nowrap" for error message on HTML error page. No more
horizontal scrolling!
- Substantially rewrote portions of the Admin Guide, in order to
improve and clarify the portions related to configuring and
customizing Mason under mod_perl.
- Added back "raw error" on HTML error page.
- Replaced FilesMatch with LocationMatch in docs and FAQ, because
using FilesMatch means you can't use dhandlers.
- Reduced memory usage when compiling large components. Memory usage
for smaller components hasn't changed much, but they weren't really a
problem in the first place.
- Added a cgi_request method to the CGIHandler::Request object, which
parallels the apache_req method offered by the ApacheHandler::Request
object.
[ BUG FIXES ]
- When using the code cache within an Interp, a circular reference was
created which prevented the Interp object from ever being destroyed.
With Perl 5.6.0+, this will be automatically prevented by using weak
references as needed. With Perl 5.00503, you will need to call the
new Interp->flush_code_cache method in order to break the circular
reference. This bug could cause memory leaks with code that created
new Interp objects over time, though most uses of Mason do not do
this. Reported by Kate Porter.
- Fixed bad parsing of <% $foo || 50 %>. Mason was interpreting this
as an escape flag. Escape flags now much match /^[[:alpha:]_]\w+/ and
Mason specifically looks for || in a substitution as well. Reported
by Kwindla Kramer.
- If a dhandler one subdirectory down (like /foo/dhandler) called
$m->decline, Mason threw a bogus exception. Fixed by Harmen.
- Running the test suite caused an error in the shell on Win32 with
newer versions of MakeMaker. Reported by Murat Unalan. (We _think_
this is fixed but we'd like confirmation from a Win32 user).
- It was not possible to set the data_cache_defaults parameter from
the httpd.conf file. Now it is.
- Mason was using Apache::Request->new instead of
Apache::Request->instance. This meant that if you had a handler that
ran earlier (like a TransHandler) and that handler created an
Apache::Request object, then the one Mason created would be missing
any POST arguments. Reported by Ray Zimmerman.
- Several different places in the docs said that Cache::Cache accepts
a username option, but there is no such thing.
- alter_superclass didn't work with CGIHandler because CGIHandler
didn't define a $VERSION variable. Reported by Nadine and Harry
Laxen.
- Made CGIHandler merge together POST and query string arguments in
order to be consistent with ApacheHandler. Reported by Nadine and Harry
Laxen.
- The CGIHandler module was overriding any out_method provided by the
user. Reported by Nadine and Harry Laxen.
1.15 October 14, 2002
[ BUG FIXES ]
- Fixed a number of problems with filters:
-- They didn't see changes made to %ARGS (they were seeing a copy).
-- They couldn't see any variables declared in <%args> blocks.
-- The presence of a filter caused a call to $m->flush_buffer,
breaking redirects.
- Added a number of tests for filters (*cough*).
- Fixed broken links and other bugs in the POD and HTML versions of
the docs.
- Fixed test failures when running as root. These failures were not
reflective of bugs in Mason, simply problems in the tests or test
setup. Now we skip the tests for end user installs (we still run them
during development, never fear).
- HTML::Mason::Request contained code that caused an error when using
the CPAN shell's "r" command.
1.14 October 7, 2002
[ BACKWARDS COMPATIBILITY ]
- Added compatibility layer for 1.0x cache API. It is now possible to
use $m->cache and $m->cache_self in the old way by setting the
data_cache_api parameter to '1.0'.
- Added back $comp->create_time, which was renamed as $comp->load_time
in 1.09_02, as a deprecated method.
- Added back $interp->time and $m->current_time, which were removed in
1.09_01, as deprecated methods.
[ ENHANCEMENTS ]
- Implemented the long requested user-defined escapes feature. It is
now possible to define your own escape flags, as well as overriding
Mason's own 'h' and 'u' flags.
- Implemented expire_if and busy_lock options in new $m->cache->get
API. These retain the essence of the 1.0x options although both
work a little differently.
- Added new module to implement caching extensions,
HTML::Mason::Cache::BaseCache, with accompanying documentation.
- Enhanced Params.pod with TOC and full descriptions of all
parameters. Standardized rest of documentation to link to Params.pod
when referring to a parameter.
- When a component path is not found, but that path matches a file on
disk, we now print an extra warning, because this indicates that the
user does not understand the distinction between component paths and
filesystem paths.
- The Request object's redirect() method now accepts an optional
additional argument, allowing users to use a status code other than
302 for the redirect.
- Mason should now work on a box with a fresh mod_perl 2/Apache 2
install. Previously, Mason unconditionally tried to load
Apache::Status, which comes with mod_perl 1.x, but not (yet?) with
mod_perl 2.
[ BUG FIXES ]
- Installation was failing when Exception::Class wasn't installed.
- Calling <%def> subcomponents no longer changes base_comp, which is
important in autohandlers. (reported by Ian Robertson)
- The documentation incorrectly indicated that you could create an
ApacheHandler object during server startup without providing a
component root. This will also shown incorrectly in the sample
handler.pl in the eg/ directory.
- Reduced Mason's memory usage when compiling and serving components.
This is particularly noticeable with very large components (1-2MB or
greater). Work on this will continue for future versions. (reported
by Todd Holbrook)
- %ARGS and <%shared> variables could not be accessed from <%filter>.
(reported by Adam Roth)
- Switch.pm did not work in file-based components. (reported by Gert
Thiel)
- use_strict could not be turned off. (reported by Viacheslav
Voytovich)
- $m->clear_buffer (and $m->redirect) did not work inside a component
call with content. (reported by Manuel Capinha)
- Some tests were failing on Windows, because they assumed Unix style
filesystem paths. This was a problem with the tests, not the core
code, but still worth fixing. (reported by Adam Rinehart).
- $m->caller() was inadvertently left out of the documentation - fixed.
- Fixed a small documentation error about what kinds of things are
valid keys in <%flags> and <%attr> blocks.
- Configuring multiple component roots via the httpd.conf file failed
silently (as opposed to releases 1.10 - 1.12, where this failed with
an error).
- Unreadable component source files caused the confusing error message
"source callback returned no source". This will now throw a much more
helpful exception.
- Errors occurring in subrequests would cause error output to be mixed
with regular output when the error_mode was "output" (the default with
ApacheHandler and CGIHandler). Errors in subrequests should now look
the same as errors in the top request.
1.13 August 26, 2002 (Taiwan time)
[ ENHANCEMENTS ]
- Replace the regex "[A-Za-z0-9]" with "\w", which should cooperate
better with Unicode.
- Added a section called "Avoiding Concurrent Recomputations" to the
Developer's Manual. This describes how to achieve the same effect as
was provided by the "busy locks" feature in 1.0x.
[ BUG FIXES ]
- When running under mod_perl, a warning was issued from
HTML::Mason::Request::ApacheHandler's exec() method. (reported by
Marius Feraru)
- The request wrapper code did not work with anonymous component.
(reported by Bob McElrath)
- Mason 1.10-1.12 did not cooperate with Apache::Filter, or any other
Apache subclass that overrode the print() method. (reported by Mark
Moseley)
- If an object blessed into Apache::Request was provided to
ApacheHandler's handle_request method, and you were using the
args_method parameter was set to "mod_perl" (the default), then
ApacheHandler would die. This was a bug introduced in 1.12 as a
result of fixing the memory leaks in 1.11. (reported by Autrijus
Tang)
- Configuring multiple component roots via the httpd.conf file failed.
(reported and patched by Alexei V. Barantsev)
- $interp->exec and $m->exec were not respecting wantarray. (reported
by David Bushong)
- Suppress a "subroutine redefined" warning from
HTML::Mason::Request::Apachehandler's exec() method. (reported by
Marius Feraru)
- Combining cache_self, <%filter> blocks, and $m->scomp did not work.
(reported by Calle Dybedahl)
- Tests 4 & 5 for 06-compiler.t would fail if HTML::Entities was not
installed. Now they will be skipped if necessary.
- Tests 75 & 99 for 08-ah.t depended on hash key ordering and would
fail with Perl 5.8.0. (submitted by Michael Gray)
- Fixed a number of cases where the lexer/compiler's behavior differed
from Mason 1.05 in unintended ways.
-- Dashes were not being allowed in subcomponent and method names,
even though this is documented as being allowed. (reported by Ken
Miller)
-- Space between a method or subcomponent name and the '>' at the end
of the tag was not being allowed. It should be noted that this is not
documented as being allowed in the docs, and so may change in the
future. But for now, we'd rather be compatible with 1.05. (reported
by Chris Hutchinson)
-- Comments were not being allowed after flag and attribute
assignments. Again, this is not documented as being allowed.
(reported by Chris Hutchinson)
- CPAN thought that version 1.68 of HTML::Mason::ApacheHandler (part
of the 1.05 release), was newer than version 1.242 (part of the 1.1201
release). This is what we get for using CVS to set verson numbers.
This version number is now set by hand in order to make sure that this
does not happen in the future.
1.1201 July 24, 2002
[ ENHANCEMENTS ]
- Added details to the UPGRADE document on what has changed with the
caching system.
- Added some documentation on how to arbitrarily expire items in the
cache with the new caching system. This is in HTML::Mason::Devel.
[ BUG FIXES ]
- Fixed a compilation error in HTML::Mason::Tools that was occurring
with Perl 5.00503.
- Made sure that <%method> and <%def> tags are treated
case-insensitively.
1.12 July 23, 2002
[ ENHANCEMENTS ]
- Various optimizations have been added to this release in order to
address the fact that Mason 1.11 is quite a bit slower than 1.05. One
major factor was optimizing Params::Validate and Class::Container, so
for that reason this version of Mason requires Params::Validate 0.24
and Class::Container 0.07. With these modules installed, this release
shows improvements of up to 50-60% in benchmarks that stress Mason's
weaknesses, with other benchmarks showing up to a 100% improvement.
- Made subclassing CGIHandler more useful by breaking out its arg
processing into a request_args method, just like ApacheHandler.
- Added alter_superclass method to Request class, for use by Request
subclasses. See the HTML::Mason::Subclassing document for details.
[ BUG FIXES ]
- Fix HTML generated for error messages so that tags balance out.
Unbalanced table tags caused this page to not display properly with
Netscape 4.x.
- Fix nasty memory leaks in ApacheHandler.
1.11 July 3, 2002
[ BUG FIXES ]
- The 08-ah.t tests failed with a runtime error if run by root. This
was not a Mason bug, but a bug in the test code itself.
- ApacheHandler did not work Perl 5.005.
- Even if ApacheHandler was given an Apache::Request object to
handle_request() or prepare_request(), it was still calling
Apache::Request->new. (reported by Ray Zimmerman)
- Fixed incorrect $m->make_subrequest documentation. (reported by Ray
Zimmerman)
- Added some incompatibilities in 1.10 to the UPGRADE document that
were left out in previous versions.
- HTML error output could be sent as plain text or some other content
type depending on your Apache config and the file extension of the
requested component. Now we explicitly set $r->content_type before
sending HTML error output.
- Fix failures of Resolver::File::glob_path() with Win32. (reported
by Adam Reinhart)
1.10 June 25, 2002
This is a big release and there are a number of backwards
incompatibilities with version 1.05 and earlier. Please make sure to
read the UPGRADE document, which covers these in more detail.
[ ENHANCEMENTS ]
- Mason can always detect when an object file was compiled with an
incompatible compiler/lexer, even if the object file contains syntax
errors.
- Method and subcomponent blocks with no name (<%method>) were caught
as an error, but the error message was very confusing. This has been
fixed.
- Added HTML::Mason::Subclassing, documentation on subclassing Mason
objects.
- Added documentation on the interaction between <%once> sections and
preloading components.
- Mason automatically calls $m->clear_buffer when $m->decline is
called.
[ BUG FIXES ]
- Fixed a bug in the lexer that made it think it had found a Perl-line
where none existed.
- Fixed a bug related to handling of parameters in httpd.conf files.
This was only noticeable if you attempted to provide a subclass of one
of Mason's classes (like your own Request class) that took its own
parameters. Mason was not recognizing those additional parameters as
valid.
- Improved line number reporting from earlier releases. Line numbers
are now reported properly for errors in any type of block.
1.09_02 June 4, 2002
[ INCOMPATIBLE CHANGES ]
- ** The Component class's create_time method has been renamed as
load_time.
- ** Relative component paths in the $interp->exec() method are no
longer resolved. All component paths must be absolute. Relative path
resolution was added in 1.09_01 so this change is unlikely to affect
most users.
- ** Removed option to expire a component from the Apache::Status
page. This option made little sense since components are cached
per-process, and there's no guarantee that any particular process has
cached a given component. Again, this is a feature added in 1.09_01
so this change should not cause most people any problems.
- ** Renamed CGIHandler's handle_cgi method to handle_comp.
- ** Removed the dev_dirs feature from CGIHandler.
- ** The default component root when not using ApacheHandler or
CGIHandler is now the current working directory at the time the
HTML::Mason::Resolver::File class is loaded.
[ ENHANCEMENTS ]
- All the modules included with Mason are now documented.
- Various pieces of existing documentation have been tweaked and
modified.
- Added handle_cgi_object method to CGIHandler.
- Mason works with the CVS version of mod_perl 2.0 when mod_perl 2.0's
backwards compatibility layer is used. AFAICT, the CVS version is
close enough to what will be released as 2.0 that few, if any, changes
should be required once 2.0 is out.
- When running Mason with the ApacheHandler or CGIHandler modules, the
Mason request object ($m) now has a "redirect" method, which can be
used to send an HTTP redirect to the client.
[ BUG FIXES ]
- $m->flush_buffer was sending out '' to the buffer, even if no output
existed. This caused ApacheHandler to send headers, which broke
redirects, for example.
- Fix broken Apache::Status page (reported by Thomas A. Lowery).
- The lexing code now handles some weird edge case errors in a better
way. One of these involved a component starting with a invalid block
name like <%foo>.
- A component that compiles into Perl code that causes syntax errors
seems to trigger a Perl bug when Mason attempts to eval it. The
symptom is that Mason simply hangs when it tries to eval the
component's object file. This bug is present in Perls before 5.7.3,
but appears to be fixed in the development branch. Mason will use
alarm, if supported by the system, to work around this.
- Output from subrequests was appearing _before_ other component
output. The new default is that this output appears "inline" in the
calling component, which we think is most DWIM-ish. Alternate
behavior can be achieved by explicitly setting the subrequest's
out_method parameter.
- The $r object provided by CGIHandler.pm was not passing header
values to CGI.pm in a way that CGI.pm liked. Now we add a '-' to the
front of the header name if necessary, and all headers are canonized
to lower case in order to avoid having duplicates.
- Mason only requires Apache::Request if you have mod_perl installed
already.
1.09_01 April 4, 2002
[ INCOMPATIBLE CHANGES ]
- ** Errors now report line numbers from the component source file.
- ** The Parser class has been removed entirely. Its functionality
has been split between the Lexer and Compiler objects.
- ** The debug file feature has been removed.
- ** The previewer has been removed.
- ** The system log feature has been removed.
- ** The Interp use_reload_files parameter has been removed. The new
static_source parameter provides a useful, and conceptually simpler,
replacement.
- ** Mason's built in caching now uses Cache::Cache to do all the
heavy lifting. This means that parameters for both the $m->cache and
$m->cache_self methods have changed.
- ** The ApacheHandler's top_level_predicate parameter has been
removed.
- ** The mc_* commands have been removed entirely.
- ** The Interp's taint_check parameter has been removed. Mason now
simply determines whether or not it is running in taint mode and acts
appropriately without user intervention.
- ** Mason now uses Apache::Request as its default argument processing
module. You can explicitly use CGI.pm if you prefer.
- ** The ApacheHandler module no longers accepts parameters when
imported. Instead, you specify this parameter via the ApacheHandler
constructor.
- ** The ApacheHandler module now requires a minimum of mod_perl 1.22.
- ** The Component's run_count() and first_time() methods have been
removed.
- ** The HTML::Mason::Config module is no longer needed, and is no
longer generated during the installation process.
- ** The Interp's autohandler_name and dhandler_name params no longer take
undef as a valid value.
- ** The Interp's use_autohandlers, use_dhandlers, and
allow_recursive_autohandlers parameters have all been removed.
- ** The $m->top_args and $m->top_comp methods have been renamed to
$m->request_args and $m->request_comp. The old methods are deprecated
but will work until the 1.20 release.
- ** Passing an Interp object to the ApacheHandler constructor (as in
a handler.pl file) will no longer work unless you set the Interp's
resolver_class parameter to
'HTML::Mason::Resolver::File::ApacheHandler'. However, you can now
pass Interp constructor params directly to the ApacheHandler
constructor, which will create the interp object internally.
- ** The MasonMultipleConfig httpd.conf parameter has been removed.
Mason can now figure this out by itself.
- ** The HTML::Mason::Interp time() method has gone away.
- ** The base_comp is now changed for each component call, unless that
component call uses a component object for its first argument, or the
call starts with SELF: or PARENT:.
- ** The "perl_" prefix for Mason tags is no longer supported.
- ** The backslash character now eliminates a newline at the end of
any line, not just before %-lines and section tags.
[ ENHANCEMENTS AND NEW FEATURES ]
- It is now possible to pass chunks of component content as part of a
component call.
- Mason now supports subrequests via the new $m->subexec and
$m->make_subrequest methods.
- Mason no longer requires you to specify a component root or data
directory. The component root now defaults to your document root in a
web context, or your filesystem root in a standalone context. The
data directory will be a subdirectory of your server root under
mod_perl, and Mason can work without any data directory at all in
other contexts.
- The Resolver class API has been redesigned and is documented for the
first time.
- The installation process will offer to help you setup Mason for use
with mod_perl if it can find your Apache configuration file and it
cannot find an existing Mason configuration.
- The HTML::Mason::Request->instance method is now the officially
supported way of getting at the current request object outside of a
Mason component (suggested by John Siracusa).
- The HTML::Mason::Interp->comp_exists method now checks for a
component's existence without loading the component (suggested by
Randal Schwartz).
- Mason now includes a module called HTML::Mason::CGIHandler, which
greatly simplifies the use of Mason via CGI scripts.
- Mason now uses File::Spec for all filesystem operations.
- All the .pod files have been merged into their corresponding .pm
files, where appropriate.
- Added the Component attr_if_exists method (suggested by Joe
Frisbie).
- We now use the HTML::Entities module's encode function for the 'h'
substitution escape flag. This module escapes high-ascii characters
properly.
- Calling a method via $m->comp('comp:method') works just like
$comp->call_method('method').
- When an object contains other objects then the containing object's
constructor accepts parameters intended for the contained objects.
For example, the Interp object contains a Resolver object and Request
objects. The Interp's new method will accept constructor parameter
for both the Resolver and Request objects.
- The ApacheHandler args_method is now a per-object parameter.
- Mason is now much smarter about recompiling components. In general,
it can detect if compiler options for a compiled component are
different from the current options, and will recompile the component
if necessary. The exception to this is that with compiler parameters
which take callbacks (such as preprocess), Mason can only tell if such
a parameter is present, not whether the actual callback has changed.
- The ApacheHandler object will chown any files created during server
startup as needed.
[ BUG FIXES ]
- The <%args> section can now contain comments which contain the
string '=>' (reported by Chris Hutchinson).
- Fixed the longstanding bug that using print() or $r->print() causes
output/headers to appear out of order. You can now safely use these,
though we still recommend that you use Mason to send output.
- Filtered output now does appear when $m->abort() used. However, an
abort inside a component called via $m->scomp() still cause the output
generated by that component to disappear.
[ INTERNALS ]
- Output buffering and filtering is handled by the new
HTML::Mason::Buffer class.
- All fatal errors thrown during component execution are exception
objects in the HTML::Mason::Exception class hierarchy.
- The CGI GET/POST argument processing code has been simplified
(submitted by Ilmari Karonen).
- ApacheHandler now uses a special Resolver subclass to translate URIs
to component paths.
- Parameters passed to "set" accessors are now validated in the same
way as constructor parameters.
- The component requested and the arguments it was passed are now
properties of the Request object.
1.05 April 30, 2002
- Fixed improper handling of parameters for non-GET/POST
request. (submitted by Radu Greab)
- Fixed Interp to accept a resolver object param. (reported by Bojan
Jovanovic)
- Fixed infinite loop when calling $m->decline with // in dhandler
arg. (reported by Baldur Kristinsson)
1.04 October 30, 2001
- Fixed locale parser_version 0,8 problem. (submitted by Louis-David Mitterrand)
- Fixed inability to use '/' for comp_root. (reported by Doug Hunt)
- Fixed HTML::Mason::Parser::make_dirs dying when reload_file not
defined. (reported by Ivan E. Panchenko)
- Made error_process regexps more specific. (suggested by Vadim Belman)
- Fixed $m->count. (reported by David Wheeler)
- Fixed writing of object files in taint mode. (submitted by Barrie Slaymaker)
- Made it possible to run Makefile.PL without prompts.
1.03 May 17, 2001
- Made raw error message accessible from the new error display via
an unobtrusive link.
- Fixed Apache tests when started by a non-root user. (reported
by Barrie Slaymaker)
- Added short-circuits for Apache tests on Win32 and on systems with
Apache configurations that cannot be properly parsed. (reported by
Jindra Vavruska)
1.02 April 17, 2001
- Completely redesigned error display. The new display includes a
contextual source listing and readable stacktrace. You can access the
old error behavior with the raw_html and raw_fatal error modes.
(implemented by Matthew Lewinski)
- Fixed $m->file to close its filehandle between uses. (reported by
Matthew Lewinski)
- Fixed bad interaction with Mason 1.01 and CPAN module, by adding
version number to ApacheHandler.pm.
- Fixed $m->top_comp to work as documented, and made documentation
a bit more explicit. (reported by Gordon Henriksen)
- Fixed specification of a component root as "foo => /foo" in
httpd.conf. (reported by Chuck O'Donnell)
- Added MasonDeclineDirs, accidentally omitted in 1.01. (reported by
David Wheeler)
- Changed sql examples in Devel.pod to use bind variables. (suggested
by Austin S. Lin)
1.015 April 3, 2001
- Fixed incompatibility with mod_perl < 1.21_01, introduced in 1.01.
- Added 'use Apache.pm' to ApacheHandler.pm, necessary for some
mod_perl installations.
1.01 March 27, 2001
- Implemented configuration of Mason from httpd.conf via PerlSetVar
directives. This removes the need for a handler.pl file in many
cases.
- Revamped ApacheHandler tests to use a real Apache web server and
mod_perl (assuming this is installed). This allows for much better
testing of Mason. However, the test suite takes a bit longer to run
as starting and stopping the server can take a second or two each
time.
- ** Fixed handling of POST requests with query strings via CGI.pm;
the query string arguments were previously ignored, and are now merged
with POST arguments. This is an incompatible change only for those
whose code relied on the arguments missing.
- Added basic validation of arguments to Parser, Interp,
and ApacheHandler constructors.
- Added interp->die_handler, allowing you to install your own
subroutine as $SIG{__DIE__} to catch errors during component
execution. Alternately, you can simply turn the special error
handling off.
- Added interp->use_dhandlers and interp->use_autohandlers, more
intuitive ways to turn on/off dhandlers and autohandlers.
- Eliminated interp->verbose_compile_error, which is no longer needed
and has not worked for some time.
- Wrapped each component call in eval, allowing us to simplify the
request stack code. No visible user change.
- Documented that you cannot call return() from a <%shared> or <%once>
section. (reported by Paolo Campanella)
- Fixed documentation of escaped newline behavior.
- Fixed incorrect code for using mod_perl args method in
eg/session_handler.pl.
1.0 January 31, 2001
- Identical to 0.896 except for version.
0.896 January 5, 2001
- Fixed bug preventing Mason from working with PerlFreshRestart.
- Fixed use_reload_file to work as documented and not stat() source files. (submitted by Benjamin John Turner)
- Fixed display in Apache::Status.
- Documented the significance of ordering in <%args> sections.
- Fixed documentation of %ARGS with regards to hashes passed in query string. (suggested by Adam Stubbs)
- Added version # to 'use Apache::Session::File' in session_handler.pl.
- Fixed preloads documentation to match reality.
0.895 December 11, 2000
- ** Removed ApacheHandler from Mason.pm. It is now necessary to
explicitly 'use' the HTML::Mason::ApacheHandler module in your
handler.pl file (or elsewhere). This fixes an intermittent
args_method bug and cleans up Mason.pod.
- ** Changed $m->caller_args to return a hash reference in scalar
context and a list/hash in list context. Older calls expecting a list
reference will need to be changed.
- Fixed Mason to work under Perl's tainting mode again. Thanks to John
Tobey for pointing us in the right direction.
- Modified the definition of "next component" to depend on the current
component, not merely the number of times $m->call_next has been
called. This allows $m->fetch_next to work as documented. Also
added $m->fetch_next_all, which returns the rest of the wrapper chain.
- Fixed bug with ../.. in component paths. Versions 0.88 and 0.89
would create multiple object files for a single component and would
allow any filename to be treated as an internal component. This was
_not_ exploitable externally via Apache, however. (reported by Pascal
Eeftinck)
- Implemented $m->top_comp and $m->top_args, and fixed documentation
for $m->callers(-1). (suggested by Kees Vonk)
- Added full line comments to <%args> sections. (suggested by Matthew
Lewinski)
- Revamped test harness system with HTML::Mason::Tests, greatly
simplifying the new test creation process.
- Implemented partial compliance with Apache::Filter; Mason can now be
used as a pre-filter but not yet as a post-filter. i.e. Configurations
like "PerlHandler HTML::Mason Apache::Compress" will work.
- Implemented logging of NOT FOUND errors to match plain Apache. Also
issue special warnings for Mason-specific causes of NOT FOUND.
- Documented Mason request object's aborted and aborted_value methods.
- Documented the fact that any variable declared in the <%args>
section must be a valid Perl variable name. The parser will now give
an error if it encounters an invalid name (such as $foo.x).
- Eliminated upgrade of Apache request object to Apache::Request class
if this were done previously. (submitted by Shevek)
- Removed FAQ from distribution. Users should seek out the most
current FAQ, now maintained by Kwindla Kramer, on the web.
- Fixed bug where an attempt to escape a substitution that contained a
function operating on a list (like sort or map) ended up appending the
escape flag characters to the list being operated on.
- Fixed the test 08-ah to work with CGI versions >= 3.0. (reported by
Alexei V. Barantsev)
- Fixed a problem with the parser when running with a locale that used
a comma as the decimal separator instead of a period. (reported by
Louis-David Mitterrand)
- Clarified the 'u' escape flag in docs.
- Removed use of $r->finfo in Apachehandler.pm, which causes random
core dumps in certain versions of mod_perl.
- Updated eg/session_handler.pl code to match Apache::Session 1.50+.
- Fixed various problems with debug files.
- Fixed a bug sometimes seen when the parser failed to parse a
component called by another component.
- Fixed a bug that prevented the $m->cache_self method from returning
anything.
- Fixed documentation regarding 'months' and 'years' units in
expire_in cache flag.
- Fixed bug in HTML/Mason/Component/Subcomponent.pm create_time
method. (reported by Caleb Crome)
- Fixed bug where Mason would try to escape undefined values in a
substitution with an escape flag. (submitted by Denis Shaposhnikov)
0.89 September 14, 2000
- Fixed broken CGI args implementation from 0.88 (old arguments
appearing in new requests)
- Fixed system log bug from 0.88
0.88 August 30, 2000
- Fixed broken Parser postprocessor code (broken since 0.85). Added
tests for this code path as well as the preprocessor feature.
(reported by Tim Bishop)
- Replaced lots of simple accessors with new HTML::Mason::MethodMaker
(which just makes simple read-only and read-write accessor methods).
- Removed all direct hash key access from one object into another.
- Removed all unneeded uses of Exporter in various modules.
- Added warning about using mod_perl as a DSO to README file.
- Added 'cgi_object' method to HTML::Mason::Request::ApacheHandler.
This method returns the CGI object Mason uses internally (unless
you're using Apache::Request instead in which case its a fatal error).
Added documentation for this. (suggested by many people).
- Squashed warning in assignment to %ARGS in component sub body.
- Fixed call_method and scall_method to take arbitrary list of args
instead of hash.
- Fixed expression escape flags to allow arbitrary following
whitespace. (reported by Mikhail Zabaluev)
- Added FAQ on how to handle file uploads.
- $m->cache returns the value stored on a successful store action.
- Reduced memory usage by removing unneeded uses of various modules.
On my box I see about a 500k or so reduction in memory use (Dave).
- Removed all uses of the IO::* modules.
- Mason seems to be working under a mod_perl DSO, at least under
mod_perl 1.24 and Apache 1.3.12. This probably has nothing to do with
Mason but the very adventurous are encouraged to experiment with a
mod_perl DSO and report back to the mason list.
0.87 May 24, 2000
- Fixed multiple GET/POST argument glitch introduced in 0.86.
(reported by Matt Hoskins)
0.86 May 18, 2000
- Fixed multiple-<%perl>-section infinite loop bug introduced in 0.85.
- (Re-)Fixed Apache hang on POST not-found bug.
- Added $m->scall_method, analagous to $m->scomp. (suggested by Michael Shulman)
- When using mod_perl args method, $r is upgraded to Apache::Request object.
(suggested by Matt Hoskins)
- Documented attr, methods, and flags in Component.pod.
- Improved error msg for <%def> or <%method> lacking name.
- Improved error msg for using invalid embedded tag in def or
method. (submitted by Dave Rolsky)
- Eliminated reliance on hash ordering in tests.
- Changed test scripts to create separate data dirs for each test
branch and clear data dir at start of test.
- Added mixed case and repeated sections to <%perl> tests.
- ** Removed mod_perl specific $m->http_input; can no longer be
supported.
- Fixed args processing loop to allow multiple file
uploads. (submitted by Matt Hoskins)
0.85 May 7, 2000
- Added object-oriented primitives to components. Components can
define methods and attributes and inherit from parent components.
Templates can access the current page's methods and attributes for
greater flexibility.
- ** Major improvements/changes to autohandler feature. Autohandlers
are now recursive by default, and all applicable autohandlers for a
given page get a chance to run. If you have multiple autohandlers in
parent/child directories, or if you used autohandlers with
allow_recursive_autohandlers=0, you will need to adjust for the new
policy.
- Integrated a revamped parse_component that is cleaner, more modular
and easier to subclass. Courtesy of Dave Rolsky.
- New <%shared> section contains code that executes once per request
and whose declarations are visible from the main component, methods
and subcomponents alike.
- Added escape flags for <% %> output. Can now HTML-escape or
URI-escape expressions on a site-wide or per-expression
basis.
- Added choice of CGI or Apache::Request when using
ApacheHandler. (submitted by Dave Rolsky)
- Documented $m->clear_buffer, which removes all pending output from
the buffer.
- Fixed keys and expires cache actions from m->cache
interface. (suggested by Matt Hoskins)
- dhandlers can now serve their own directory; added documentation
about handling directories.
- Fixed dhandler bug introduced in 0.81 whereby $m->dhandler_arg only
contains the first branch of a multi-branch argument.
- Removed memory leak in ApacheHandler::handle_request_1. (submitted
by Pascal Eeftinck and Renzo Toma)
- Changed parent_comp() to owner() for subcomponents/methods.
- Increased maximum recurse level from 16 to 32.
- Reorganized syntax section of developer's manual and added a "how to
use this manual" section.
- Added an UPGRADE guide to distribution.
- Added section about securing top-level components to Admin.pod.
(suggested by Sean Cazzell)
- Added section about declining image requests to Admin.pod.
- Eliminated "Subroutine status_mason redefined" warning when creating
multiple ApacheHandlers.
- Updated cookie expiration in CD-ME example. (reported by Renzo Toma)
- Added a "-f" flag to rm in faq Makefile. (reported by Jeremy Taylor)
0.81 February 20, 2000
- Fixed small 0.8 bugs with automatic header sending. Headers are now
sent for blank pages and are not sent on an error status code.
- Fixed bug with default system log file. (submitted by Renzo Toma)
- Eliminated memory leak introduced in 0.8 for a few Linux platforms.
(submitted by Renzo Toma and Pascal Eeftinck)
- Fixed bug with component paths displaying two leading slashes.
- Fixed $comp->source_file when multiple comp roots declared.
- Fixed $m->decline in mod_perl mode.
- Removed legacy dhandler code from ApacheHandler.
- Replaced $r->filename with $r->finfo in ApacheHandler.
(submitted by Dennis Watson)
- Added dynamic virtual server configuration example to Admin.pod.
(submitted by Caleb Crome)
0.8 January 23, 2000
- New integrated request API. $m replaces $REQ as the global variable
containing the current request object. All mc_ commands have been
incorporated into $m methods: mc_comp becomes $m->comp, mc_file
becomes $m->file, etc. The old commands still work for now.
- The utility bin/convert0.8.pl converts existing components to use
the new request API.
- Autohandler methods have been renamed: from mc_auto_next to
$m->call_next and mc_auto_comp to $m->fetch_next. This is in
preparation for a more general component inheritance system.
convert0.8.pl handles this change.
- Can now specify multiple component roots in the spirit of @INC.
(suggested by Ewan Edwards and others)
- Simplified HTTP header behavior. Headers are sent at the end of the
request (in batch mode) or just before the first non-whitespace output
(in stream mode). suppress_http_header no longer needed.
- New organization of Component class into subclasses
Component::FileBased and Component::Subcomponent. No outward change.
- Updated object file format. Mason should generally auto-detect
and recompile old object files, but may not catch everything. Try
removing your object directory if errors persist.
- ** mc_suppress_http_header command still exists but does nothing.
In most cases this should not cause a problem. The only
incompatibility is if you have used mc_suppress_http_header to
suppress headers completely (i.e. you don't want Mason to send headers
at all); in this case pass auto_send_headers=>0 to ApacheHandler.
- Output mode parameter was moved from ah->output_mode to
interp->out_mode, to make it independent of mod_perl.
ah->output_mode still works.
- New in-memory code cache keeps track of component usage, and
discards the most infrequently used components as needed. You can
specify the cache size with interp->max_code_cache_size.
- ** Eliminated the now unnecessary interp->code_cache_mode.
- ** Eliminated the "source references" optimization, a common source of
bugs, no longer needed with the new code cache.
- Allow arguments to be accessed via @_ as in regular subroutines; no
longer required to be in hash form. (suggested by Ken Williams)
- Added $m->scomp, which returns the output of the component call
instead of printing it. This is a cleaner replacement for the STORE
parameter, which still works but is no longer officially documented.
- Added $m->flush_buffer, which forces the buffer to be sent to the
client when in batch mode.
- Added $m->caller_args, which returns the argument list for any point
in the stack. (suggested by Lee Semel)
- Added $m->decline, which passes control to the next dhandler.
(suggested by Chuck O'Donnell)
- Augmented $m->cache_self to cache return values as well as output.
(suggested by Jon Frisby)
- Changed data cache filenames from colon-separated to url-encode
style for Win32 compatibility. (submitted by Ken Williams)
- Added improved, separate session_handler.pl for session handling.
- ** mc_comp_source no longer works for non-existent components.
- ** Removed mc_date legacy command.
- Many new test scripts.
- Added warnings about using Mason with mod_perl DSO.
- Added more site configuration examples to Admin.pod.
- Split object parameter methods (interp->comp_root, etc.) into
read/write and read-only as appropriate.
- Fixed request stack corruption when die() or error from one
component is caught by another component's eval.
- Fixed doc_root / comp_root mismatch on case-insensitive O/S.
(reported by John Arnold)
- Fixed "directory not absolute" warning on "/" (reported by Joe Edmonds)
- Fixed reload file scanning mechanism (submitted by Brian Holmes)
- Added use_data_dumper_xs Config.pm item, which checks whether
Data::Dumper::Dumpxs is available. (reported by Pelle Johnsen)
- Added "code examples" section to README
0.72 October 15, 1999
- Eliminated long-standing infinite-block bug when POSTing to a
non-existent URL
- Fixed "keys" cache action which never worked as documented
(submitted by Scott Straley)
- Fixed source references on Win32 platforms by using text mode when
reading object file (submitted by Michael Shulman)
- Fixed various methods in FakeApache
- Remove final slash from system paths (component root, etc.) and
check that those paths are absolute
- Fixed all-text subcomponents, by bypassing the pure-text
optimization
- Quoted all hash strings in object file to reduce "Ambiguous use
of ..." warnings (suggested by Paul Schilling)
- Replaced */* with default-handler as recommended way to bypass Mason
(suggested by Dirk Koopman)
- Removed defunct pure text section in Administrators Guide (reported
by Michael Shulman)
0.71 September 14, 1999
- Logic of top_level_predicate was reversed in 0.7; fixed.
(reported by Tom Hughes, Eric Hammond)
- mc_suppress_http_header(0) was broken in 0.7; fixed.
(reported by Michael Alan Dorman)
- Fixed bug in parser section that determines whether % is at the
beginning of a line. (reported by Tom Hughes)
- Parser no longer inadvertently accepts argument names with
whitespace. (reported by Phillip Gwyn)
0.7 September 1, 1999
- Improved core implementation with two new classes,
HTML::Mason::Request and HTML::Mason::Component. Code is now cleaner
and more scalable, and the new APIs give developers control and
introspection over Mason's inner workings.
- Added documentation to accommodate new classes: created
Request.pod and Component.pod, and moved component developer's guide
(previously at Components.pod) to Devel.pod to avoid
confusion.
- Object files have changed significantly (they now return a
component object). Pre-0.7 object files will be detected and
automatically updated, unless you are running in reload file mode
in which case you are responsible for generating new object files.
- New <%def> section defines a subcomponent embedded inside a larger
component. This allows repeated code and HTML to be modularized
without affecting the global component namespace.
- <%args> section now accommodates optional comments for declarations
- Improved Perl translation of <%args> section (submitted by Ken
Williams)
- Autohandler and dhandler file names are now configurable
- Dhandlers, which formerly worked only in mod_perl mode, now work in
stand-alone mode as well
- Interp::exec is now re-entrant with all request specific information
having been moved to Request class.
- ** Reworked Parser API. parse is now called make_component, has a
simplified set of options, and returns a component object
directly. make is now called make_dirs.
- Source references now read from the object file, cleaner for a
variety of reasons. Preprocess and postprocess now work with source
references.
- Removed obsolete and undocumented Interp::vars and mc_var functions
- Simplified chown/getpwuid usage in handler.pl (submitted by Randal
Schwartz)
0.6.2 August 20, 1999
- Fixed problem with shared data cache locks over NFS (submitted by
Tom Hughes)
- Fixed mc_auto_comp, which never really worked as documented
- Fixed preloading for directories (submitted by Dennis Watson)
- Added back Utils::get_lock, which is used by content management
0.6.1 July 27, 1999
- Added warnings to convert-0.6.pl about occasional erroneous
component call syntax conversions (reported by Oleg Bartunov)
- Fixed conversion of <% mc_comp("/foo/$bar") %> (reported by Oleg
Bartunov)
- Fixed cache access under high concurrencies (reported by Oleg
Bartunov)
- Fixed uppercase <%PERL>, broken in 0.6 (reported by Daniel L. Jones)
- Fixed mc_suppress_http_header(0), broken in 0.6 (reported by Jim
Mortko)
0.6 July 16, 1999
- New <& &> tag provides a more convenient way to call components
inside HTML. mc_comp still works.
- The "perl_" prefix has been eliminated from section names: now
simply use <%init>, <%cleanup>, <%args>, etc. The old names still
work.
- The utility bin/convert0.6.pl converts existing components to use
the above new syntax.
- New autohandler feature finally provides an easy way to specify a
common template or behavior for a directory. An autohandler is invoked
just before any top-level components in its directory begins executing.
It can display header/footers, apply a filtering function, set up
globals, etc. A good complement to dhandlers.
- New <%once> section contains code that will be executed once when a
component is loaded. It is useful for defining persistent variables
and named subroutines.
- New <%filter> section and mc_call_self command allow you to arbitrarily
filter the output of the current component.
- New <%text> section allows you to turn off Mason processing for a
particular section of text.
- Implemented first installation test suite! [modus]
- HEAD optimization: we now automatically abort after headers are sent
on a HEAD request.
- New Parser make() utility traverses a tree of components, compiling
any out-of-date components into object files and reporting errors.
- New mc_comp_source command returns the source filename of this or
any component.
- mc_file now uses current component path by default for relative paths
if no static_file_root defined (suggested by John Landahl)
- Various previewer interface improvements
- Removed link tags in pods documentation due to 5.004 problems
- Took out previewer stub from Mason.pm to eliminate "subroutine
redefined" warning
- Updated makeconfig.pl to prefer GDBM_File, to avoid a bug in
Berkeley DB 1.x
- Cleaned and sped up interp hooks facility
- Stopped substituting control characters for section strings in Parser
[modus]
- Fixed mc_cache 'expire' bug (reported by Aaron Ross)
- Changed ignore_warnings default to ignore "subroutine redefined"
warnings to make <%once> more useful
- Removed defunct Safe code from Parser and defunct ALLOW_HANDLERS
code from Interp
- Added index file to htdocs/
0.5.1 June 10, 1999
- Removed leftover "use File::Recurse" in ApacheHandler.pm [modus]
- Added empty test target to FAQ Makefile, required on certain
architectures [modus]
0.5 June 3, 1999
- Removed memory leak associated with "return sub { ... }"
- Overhauled Config.pm, now maintains previous configuration when
upgrading Mason (suggested by Patrick Kane)
- Made filename processing compatible with Windows 32 (suggested by
Rafael Weinstein)
- Removed requirement of File::Tools/File::Recurse, replaced with
standard File::Find
- Switched output to STDOUT from $r->print, to facilitate chaining
with other mod_perl tools
- Switched to standard argument processing code, now handles
multi-part forms [modus]
- New preprocess and postprocess Parser options allow you to apply
auomatic modifications to components, before or after they are compiled
into code. (submitted by Philip Gwyn)
- New in_package Parser option allows components to live in any
package. (submitted by Philip Gwyn)
- Added documentation about using globals in components, and
some new facilities: Parser option 'allow_globals' and Interp
method 'set_global'.
- Documented how to save persistent user information with Apache::Session [modus]
- ** Changed behavior of reload_file mode to read directly from object
files. If you use reload files, you're now responsible for
creating object files. [mschmick]
- Reduced number of file stats when loading components [mschmick]
- New apache_status_title ApacheHandler option makes it possible to
use Mason's perl-status page with multiple ApacheHandler objects.
(submitted by Philip Gwyn)
- Upgraded FakeApache/debug files to work with mod_perl 1.19
- New sections in Component Developer's Guide explain how debug files
work and some caveats about when they don't.
- Mentioned mailing lists, masonhq.com web site, and FAQ in the
documentation and README
- Improved documentation on how to integrate images and non-Mason
hierarchies with Mason.
- Differentiated mc_cache and mc_cache_self in the commands manual
(suggested by Tom Hukins)
- Increased discouraging of SDBM, improved warnings when cache store
fails (suggested by Patrick Kane)
- Fixed HTML documentation to work with IE (suggested by Fen Lebalme)
- Fixed infinite loop in ApacheHandler dhandler search (submitted by
Chuck O'Donnell)
- Documented Parser method parse(), which allows you to compile
components outside of a Interp environment.
- New mc_cache actions 'expire' and 'keys' help you peer into data cache
files and expire selected keys.
- Corrected Parser to properly handle \ in components (submitted by
Ken Williams)
- ** Took Preview out of Mason.pm; ApacheHandler used only if mod_perl
environment. If you use the previewer, you now have to explicitly "use
HTML::Mason::Preview" in your handler.pl.
- Improved documentation about argument/GET/POST handling (suggested
by Ken Williams)
- Added cache option 'busy_lock', which prevents multiple processes
from recomputing an expire cache value at the same time. (suggested
by Dennis Watson)
- Inserted work-around for Perl 5.005 $r scoping bug (submitted by
Rafael Weinstein)
- Fixed "new CGI" example in Components.pod (submitted by Austin Lin)
- Fixed "return if content-type..." line in handler.pl and Mason.pod
(submitted by Patrick Kane)
- Added CREDITS file
0.4 January 06, 1999
- Added support for using Perl profiler in conjunction with debug
files
- Fixed bug in previewer HTML trace introduced in 0.3
- Created Perl status section for Mason
- Removed most warnings when PerlWarn is on (suggested by Philip Gwyn)
- Added code_cache_mode parameter to control caching of components in
memory
- Fixed mismatch between documentation and code with regards to cache
store events in system log. The real event name is CACHE_WRITE.
- Changed system logging to use canonical server name when recording
URI
- Field access methods inside Mason objects are now handled with
custom subroutines instead of generic AUTOLOAD, improving performance
- Information for debug file is no longer collected if debug mode is
"none"
- Code to decline images and other non-text requests was placed in
default handler.pl and described in documentation (suggested by
Patrick Kane)
- Fixed server header output from debug files (suggested by Ewan Edwards)
- Created a Mason bundle
- Created a CPAN "alias" from Apache::Mason to HTML::Mason
0.3 November 25, 1998
- Added optional system logging of page requests, cache activity,
component loading
- Deny directory requests so that index files will work in mod_perl 1.16+
- Removed reliance on several external packages (Date::Manip,
CGI::Base, URI::Escape). This should reduce the amount of memory taken
up by Mason processes and make Mason easier to install.
- ** Due to the removal of Date::Manip, the mc_date command will no
longer work unless Date::Manip is explicitly used, and the syntax for
the expire_at cache parameter and the Interp current_time parameter
have changed.
- Added parser taint_check flag which allows Mason to work with taint
checking on (suggested by Randal Schwartz)
- Added warning messages when returning 404 from ApacheHandler
- Improved cache locking with the use of separate lock files
- Makefile.PL checks for required and optional packages
- Documentation fixes and improvements
- Removed obsolete and undocumented commands from Commands.pm
- Failure to write debug file is now a warning rather than fatal error
- Augmented "no configuration for previewer port" error
- Fixed $interp->exec to be able to return list
- Changed parser to remove ctrl-Ms instead of replacing with spaces
- Always call http_header hook, not just at top level
- Added global IN_DEBUG_FILE flag
- Renamed mc_call_stack to mc_comp_stack to match documentation
0.2 August 21, 1998
- Replaced File::lockf module, which could not port to some systems,
with simple call to flock
- Corrected email address in README
- Fixed undeclared variable bug in preview component
- The previewer did not work in basic versions of Perl 5.004 due to an
eval scoping bug. A workaround was put in place.
- Fixed expire_if cache option to pass correct argument to provided
subroutine
- Empty argument section no longer parsing incorrectly
- Took out directory names from manifest which were causing errors on
install
- Debug file is no longer prepared when debug_mode is "none"
- Use Preview.pm in Mason.pm
0.1 July 22, 1998
- Original version; created by h2xs 1.18
HTML-Mason-1.58/bin/ 0000775 0001750 0001750 00000000000 13175376764 013723 5 ustar autarch autarch HTML-Mason-1.58/bin/convert0.8.README 0000644 0001750 0001750 00000001110 13175376764 016477 0 ustar autarch autarch convert0.8.pl
This utility converts existing components to use new syntax
introduced in Mason 0.8.
1. Old-style mc_commands (mc_comp, mc_file, etc.) are converted to
new-style $m methods ($m->comp, $m->file, etc.) See Commands.pod for
all the conversions to be performed.
2. References to request variable $REQ are converted to $m.
All directories will be traversed recursively. We STRONGLY recommend
that you backup your components, and/or use the -t flag to preview,
before running this program for real. Files are modified
destructively and no automatic backups are created.
HTML-Mason-1.58/bin/mason.pl 0000755 0001750 0001750 00000004017 13175376764 015400 0 ustar autarch autarch #!/usr/bin/perl
use strict;
use HTML::Mason '1.11';
use File::Basename qw(dirname basename);
use File::Spec ();
use Cwd ();
my ( $params, $component, $args ) = parse_command_line(@ARGV);
# Set a default comp_root
unless ( exists $params->{comp_root} ) {
if ( File::Spec->file_name_is_absolute($component) ) {
$params->{comp_root} = dirname($component);
$component = '/' . basename($component);
}
else {
$params->{comp_root} = Cwd::cwd;
# Convert local path syntax to slashes
my ( $dirs, $file ) = ( File::Spec->splitpath($component) )[ 1, 2 ];
$component = '/' . join '/', File::Spec->splitdir($dirs), $file;
}
}
my $interp = HTML::Mason::Interp->new(%$params);
$interp->exec( $component, @$args );
#######################################################################################
sub parse_command_line {
die usage() unless @_;
my %params;
while (@_) {
if ( $_[0] eq '--config_file' ) {
shift;
my $file = shift;
eval { require YAML; 1 }
or die
"--config_file requires the YAML Perl module to be installed.\n";
my $href = YAML::LoadFile($file);
@params{ keys %$href } = values %$href;
}
elsif ( $_[0] =~ /^--/ ) {
my ( $k, $v ) = ( shift, shift );
$k =~ s/^--//;
$params{$k} = $v;
}
else {
my $comp = shift;
return ( \%params, $comp, \@_ );
}
}
die usage();
}
sub usage {
return <