in reply to Re^3: Return 403 from within CGI::Application runmode
in thread Return 403 from within CGI::Application runmode

Sample CGI::Application::Dispatch:

package Sample::Dispatch;

use strict;
use warnings;

use CGI::Application::Dispatch;
use base qw(CGI::Application::Dispatch);

sub dispatch_args {
    return {
        prefix => 'Sample',
        table  => [ q{} => { app => 'Application', rm => 'index' }, ],
    };
}

1;

[download]

Sample CGI::Application:

package Sample::Application;

use strict;
use warnings;

use base qw(CGI::Application);

use CGI::Application::Plugin::Apache qw(:all);

sub setup {
    my ( $self, $args ) = @_;
    $self->run_modes('index' => 'index');
    $self->start_mode('index');
    return 1;
}

sub index {
    my ( $self, $args ) = @_;
    $self->header_type('none');
    $self->query->status(403);
    return q{};
}

1;

[download]
If you set the value of $self->query->status() to 400, 404, and 500 it works as expected. Why does it not support setting any other type of status?

Replies are listed 'Best First'.
Re^5: Return 403 from within CGI::Application runmode
by Anonymous Monk on Feb 11, 2010 at 21:14 UTC
    CGI::Application::Plugin::Apache seems very much like junk 
    #!/usr/bin/perl --
use strict;
use warnings;
use CGI::Application::Dispatch 2.17;

Main(@ARGV);
exit(0);

sub Main {
  local $ENV{PATH_INFO} = '/MyApp/g403';
  local $ENV{PATH_INFO} = '/MyApp/';
#~     CGI::Application::Dispatch->dispatch( default => 'g403', );
  CGI::Application::Dispatch->dispatch;
} ## end sub Main

BEGIN {

  package MyApp;
  $INC{'MyApp.pm'} = __FILE__;
  use parent 'CGI::Application';

  sub setup {
    my $self = shift;
    $self->start_mode('g403');
    $self->run_modes( g403 => 'g403', );
  }

  sub g403 {
    shift->header_props( -status => 403, -nph => 1, );
    return "you do not have permission";
  }
} ## end BEGIN
__END__
HTTP/1.0 403
Server: cmdline
Status: 403
Date: Thu, 11 Feb 2010 20:09:25 GMT
Content-Type: text/html; charset=ISO-8859-1

you do not have permission

    [download]
[reply]
[d/l]

In Section Seekers of Perl Wisdom