view release on metacpan or  search on metacpan

t/app/Plack/Handler/CGI.t  view on Meta::CPAN

                                                                            data => branch { ',',
                                                                                left => leaf '1',
                                                                                right => leaf '1',
                                                                            },
                                                                        },
                                                                    },
                                                                },
                                                                right => branch { '=>',
                                                                    left => leaf 'psgi.url_scheme',
                                                                    right => three_term_operator { '?',
                                                                        cond => branch { '=~',
                                                                            left => branch { '||',
                                                                                left => hash { '$ENV',
                                                                                    key => hash_ref { '{}',
                                                                                        data => leaf 'HTTPS',
                                                                                    },
                                                                                },
                                                                                right => leaf 'off',
                                                                            },
                                                                            right => regexp { '^(?:on|1)$',
                                                                                option => leaf 'i',
                                                                            },
                                                                        },
                                                                        true_expr => leaf 'https',
                                                                        false_expr => leaf 'http',
                                                                    },
                                                                },
                                                            },
                                                            right => branch { '=>',
                                                                left => leaf 'psgi.input',
                                                                right => single_term_operator { '*',
                                                                    expr => handle { 'STDIN',
                                                                    },
                                                                },
                                                            },
                                                        },
                                                        right => branch { '=>',
                                                            left => leaf 'psgi.errors',
                                                            right => single_term_operator { '*',
                                                                expr => handle { 'STDERR',
                                                                },
                                                            },
                                                        },
                                                    },
                                                    right => branch { '=>',
                                                        left => leaf 'psgi.multithread',
                                                        right => leaf '0',
                                                    },
                                                },
                                                right => branch { '=>',
                                                    left => leaf 'psgi.multiprocess',
                                                    right => leaf '1',
                                                },
                                            },
                                            right => branch { '=>',
                                                left => leaf 'psgi.run_once',
                                                right => leaf '1',
                                            },
                                        },
                                        right => branch { '=>',
                                            left => leaf 'psgi.streaming',
                                            right => leaf '1',
                                        },
                                    },
                                    right => branch { '=>',
                                        left => leaf 'psgi.nonblocking',
                                        right => leaf '1',
                                    },
                                },
                                right => dereference { '%{',
                                    expr => leaf '$override_env',
                                },
                            },
                        },
                    },
                },
                function_call { 'delete',
                    args => [
                        branch { '->',
                            left => leaf '$env',
                            right => hash_ref { '{}',
                                data => leaf 'HTTP_CONTENT_TYPE',
                            },
                        },
                    ],
                },
                function_call { 'delete',
                    args => [
                        branch { '->',
                            left => leaf '$env',
                            right => hash_ref { '{}',
                                data => leaf 'HTTP_CONTENT_LENGTH',
                            },
                        },
                    ],
                },
                branch { '||=',
                    left => branch { '->',
                        left => leaf '$env',
                        right => hash_ref { '{}',
                            data => leaf 'HTTP_COOKIE',
                        },
                    },
                    right => hash { '$ENV',
                        key => hash_ref { '{}',
                            data => leaf 'COOKIE',
                        },
                    },
                },
                if_stmt { 'if',
                    expr => single_term_operator { '!',
                        expr => function_call { 'exists',
                            args => [
                                branch { '->',
                                    left => leaf '$env',
                                    right => hash_ref { '{}',
                                        data => leaf 'PATH_INFO',
                                    },
                                },
                            ],
                        },

t/app/Plack/Handler/CGI.t  view on Meta::CPAN

    414 => 'Request-URI Too Large',
    415 => 'Unsupported Media Type',
    416 => 'Request Range Not Satisfiable',
    417 => 'Expectation Failed',
    422 => 'Unprocessable Entity',            # RFC 2518 (WebDAV)
    423 => 'Locked',                          # RFC 2518 (WebDAV)
    424 => 'Failed Dependency',               # RFC 2518 (WebDAV)
    425 => 'No code',                         # WebDAV Advanced Collections
    426 => 'Upgrade Required',                # RFC 2817
    449 => 'Retry with',                      # unofficial Microsoft
    500 => 'Internal Server Error',
    501 => 'Not Implemented',
    502 => 'Bad Gateway',
    503 => 'Service Unavailable',
    504 => 'Gateway Timeout',
    505 => 'HTTP Version Not Supported',
    506 => 'Variant Also Negotiates',         # RFC 2295
    507 => 'Insufficient Storage',            # RFC 2518 (WebDAV)
    509 => 'Bandwidth Limit Exceeded',        # unofficial
    510 => 'Not Extended',                    # RFC 2774
);

sub new { bless {}, shift }

sub run {
    my ($self, $app) = @_;

    my $env = $self->setup_env();

    my $res = $app->($env);
    if (ref $res eq 'ARRAY') {
        $self->_handle_response($res);
    }
    elsif (ref $res eq 'CODE') {
        $res->(sub {
            $self->_handle_response($_[0]);
        });
    }
    else {
        die "Bad response $res";
    }
}

sub setup_env {
    my ( $self, $override_env ) = @_;

    $override_env ||= {};

    binmode STDIN;
    binmode STDERR;

    my $env = {
        %ENV,
        'psgi.version'    => [ 1, 1 ],
        'psgi.url_scheme' => ($ENV{HTTPS}||'off') =~ /^(?:on|1)$/i ? 'https' : 'http',
        'psgi.input'      => *STDIN,
        'psgi.errors'     => *STDERR,
        'psgi.multithread'  => 0,
        'psgi.multiprocess' => 1,
        'psgi.run_once'     => 1,
        'psgi.streaming'    => 1,
        'psgi.nonblocking'  => 1,
        %{ $override_env },
    };

    delete $env->{HTTP_CONTENT_TYPE};
    delete $env->{HTTP_CONTENT_LENGTH};
    $env->{'HTTP_COOKIE'} ||= $ENV{COOKIE}; # O'Reilly server bug

    if (!exists $env->{PATH_INFO}) {
        $env->{PATH_INFO} = '';
    }

    if ($env->{SCRIPT_NAME} eq '/') {
        $env->{SCRIPT_NAME} = '';
        $env->{PATH_INFO}   = '/' . $env->{PATH_INFO};
    }

    return $env;
}



sub _handle_response {
    my ($self, $res) = @_;

    *STDOUT->autoflush(1);
    binmode STDOUT;

    my $hdrs;
    my $message = $StatusCode{$res->[0]};
    $hdrs = "Status: $res->[0] $message\015\012";

    my $headers = $res->[1];
    while (my ($k, $v) = splice(@$headers, 0, 2)) {
        $hdrs .= "$k: $v\015\012";
    }
    $hdrs .= "\015\012";

    print STDOUT $hdrs;

    my $body = $res->[2];
    my $cb = sub { print STDOUT $_[0] };

    # inline Plack::Util::foreach here
    if (ref $body eq 'ARRAY') {
        for my $line (@$body) {
            $cb->($line) if length $line;
        }
    }
    elsif (defined $body) {
        local $/ = \65536 unless ref $/;
        while (defined(my $line = $body->getline)) {
            $cb->($line) if length $line;
        }
        $body->close;
    }
    else {
        return Plack::Handler::CGI::Writer->new;
    }
}