The Perl and Raku Conference 2025: Greenville, South Carolina - June 27-29 Learn more

$Mason::t::Request::VERSION = '2.23';
use Test::Class::Most parent => 'Mason::Test::Class';
use Log::Any qw($log);
sub _get_current_comp_class {
my $m = shift;
return $m->current_comp_class;
}
sub test_add_cleanup : Tests {
my $self = shift;
my $foo = 1;
$self->test_comp(
src => '
% my $ref = $.args->{ref};
% $m->add_cleanup(sub { $$ref++ });
foo = <% $$ref %>
',
args => { ref => \$foo },
expect => 'foo = 1'
);
is( $foo, 2, "foo now 2" );
}
sub test_capture : Tests {
my $self = shift;
$self->run_test_in_comp(
test => sub {
my $comp = shift;
my $m = $comp->m;
is( $m->capture( sub { print "abcde" } ), 'abcde' );
}
);
}
sub test_comp_exists : Tests {
my $self = shift;
$self->add_comp( path => '/comp_exists/one.mc', src => 'hi' );
$self->test_comp(
path => '/comp_exists/two.mc',
src => '
% foreach my $path (qw(/comp_exists/one.mc /comp_exists/two.mc /comp_exists/three.mc one.mc two.mc three.mc)) {
<% $path %>: <% $m->comp_exists($path) ? "yes" : "no" %>
% }
',
expect => '
/comp_exists/one.mc: yes
/comp_exists/two.mc: yes
/comp_exists/three.mc: no
one.mc: yes
two.mc: yes
three.mc: no
',
);
}
sub test_current_comp_class : Tests {
shift->test_comp(
path => '/current_comp_class.mc',
src => '<% ' . __PACKAGE__ . '::_get_current_comp_class($m)->cmeta->path %>',
expect => '/current_comp_class.mc'
);
}
sub test_id : Tests {
my $self = shift;
$self->setup_dirs;
$self->add_comp( path => '/id.mc', src => 'id=<% $m->id %>' );
my ($id1) = ( $self->interp->run('/id')->output =~ /id=(\d+)/ );
my ($id2) = ( $self->interp->run('/id')->output =~ /id=(\d+)/ );
ok( $id1 != $id2 );
}
sub test_log : Tests {
my $self = shift;
$self->add_comp( path => '/log/one.mc', src => '% $m->log->info("message one")' );
$self->run_test_in_comp(
path => '/log.mc',
test => sub {
my $comp = shift;
my $m = $comp->m;
$m->comp('/log/one.mc');
$log->contains_ok("message one");
},
);
}
sub test_notes : Tests {
my $self = shift;
$self->add_comp(
path => '/show',
src => '
<% $m->notes("foo") %>
% $m->notes("foo", 3);
',
);
$self->test_comp(
src => '
% $m->notes("foo", 2);
<% $m->notes("foo") %>
<& /show &>
<% $m->notes("foo") %>
',
expect => "2\n\n2\n\n3\n",
);
}
sub test_page : Tests {
my $self = shift;
$self->add_comp( path => '/page/other.mi', src => '<% $m->page->cmeta->path %>' );
$self->test_comp(
path => '/page/first.mc',
src => '<% $m->page->cmeta->path %>; <& other.mi &>',
expect => '/page/first.mc; /page/first.mc'
);
}
sub test_result_data : Tests {
my $self = shift;
$self->test_comp(
src => '% $m->result->data->{color} = "red"',
expect_data => { color => "red" }
);
}
sub test_scomp : Tests {
my $self = shift;
$self->add_comp( path => '/str', src => 'abcde' );
$self->run_test_in_comp(
test => sub {
my $comp = shift;
my $m = $comp->m;
is( $m->scomp('/str'), 'abcde' );
is( $m->capture( sub { $m->scomp('/str') } ), '' );
}
);
}
sub test_go : Tests {
my $self = shift;
my ( $buf, $result );
reset_id();
$self->add_comp(
path => '/subreq/other.mc',
src => '
id=<% $m->id %>
<% $m->page->cmeta->path %>
<% $m->request_path %>
args: <% Mason::Util::dump_one_line($m->request_args) %>
',
);
$self->test_comp(
path => '/subreq/go.mc',
src => '
This should not get printed.
<%perl>$m->go("/subreq/other", foo => 5);</%perl>',
expect => '
id=1
/subreq/other.mc
/subreq/other
args: {foo => 5}
',
);
reset_id();
$self->test_comp(
path => '/subreq/go_with_req_params.mc',
src => '
This should not get printed.
<%perl>my $buf; $m->go({out_method => \$buf}, "/subreq/other", foo => 5)</%perl>',
expect => '',
);
reset_id();
$result = $self->interp->run( { out_method => \$buf }, '/subreq/go' );
is( $result->output, '', 'no output' );
is(
$buf, '
id=1
/subreq/other.mc
/subreq/other
args: {foo => 5}
', 'output in buf'
);
}
sub test_visit : Tests {
my $self = shift;
my ( $buf, $result );
reset_id();
$self->add_comp(
path => '/subreq/other.mc',
src => '
id=<% $m->id %>
<% $m->page->cmeta->path %>
<% $m->request_path %>
args: <% Mason::Util::dump_one_line($m->request_args) %>
',
);
$self->test_comp(
path => '/subreq/visit.mc',
src => '
begin
id=<% $m->id %>
<%perl>$m->visit("/subreq/other", foo => 5);</%perl>
id=<% $m->id %>
end
',
expect => '
begin
id=0
id=1
/subreq/other.mc
/subreq/other
args: {foo => 5}
id=0
end
',
);
reset_id();
$self->test_comp(
path => '/subreq/visit_with_req_params.mc',
src => '
begin
id=<% $m->id %>
<%perl>my $buf; $m->visit({out_method => \$buf}, "/subreq/other", foo => 5); print uc($buf);</%perl>
id=<% $m->id %>
end
',
expect => '
begin
id=0
ID=1
/SUBREQ/OTHER.MC
/SUBREQ/OTHER
ARGS: {FOO => 5}
id=0
end
',
);
reset_id();
$result = $self->interp->run( { out_method => \$buf }, '/subreq/visit' );
is( $result->output, '', 'no output' );
is(
$buf, '
begin
id=0
id=1
/subreq/other.mc
/subreq/other
args: {foo => 5}
id=0
end
', 'visit with initial out_method'
);
}
sub reset_id {
Mason::Request->_reset_next_id;
}
1;