view release on metacpan or  search on metacpan

t/app/Plack/Util.t  view on Meta::CPAN

        # anything else, including GLOBS without IO (even if they are blessed)
        # and non GLOB objects that look like filehandle objects cannot have a
        # valid file descriptor in fileno($fh) context so may break.
        return FALSE;
    }
}

sub set_io_path {
    my($fh, $path) = @_;
    bless $fh, 'Plack::Util::IOWithPath';
    $fh->path($path);
}

sub content_length {
    my $body = shift;

    return unless defined $body;

    if (ref $body eq 'ARRAY') {
        my $cl = 0;
        for my $chunk (@$body) {
            $cl += length $chunk;
        }
        return $cl;
    } elsif ( is_real_fh($body) ) {
        return (-s $body) - tell($body);
    }

    return;
}

sub foreach {
    my($body, $cb) = @_;

    if (ref $body eq 'ARRAY') {
        for my $line (@$body) {
            $cb->($line) if length $line;
        }
    } else {
        local $/ = \65536 unless ref $/;
        while (defined(my $line = $body->getline)) {
            $cb->($line) if length $line;
        }
        $body->close;
    }
}

sub class_to_file {
    my $class = shift;
    $class =~ s!::!/!g;
    $class . ".pm";
}

sub _load_sandbox {
    my $_file = shift;

    my $_package = $_file;
    $_package =~ s/([^A-Za-z0-9_])/sprintf("_%2x", unpack("C", $1))/eg;

    local $0 = $_file; # so FindBin etc. works
    local @ARGV = ();  # Some frameworks might try to parse @ARGV

    return eval sprintf <<'END_EVAL', $_package;
package Plack::Sandbox::%s;
{
    my $app = do $_file;
    if ( !$app && ( my $error = $@ || $! )) { die $error; }
    $app;
}
END_EVAL
}

sub load_psgi {
    my $stuff = shift;

    local $ENV{PLACK_ENV} = $ENV{PLACK_ENV} || 'development';

    my $file = $stuff =~ /^[a-zA-Z0-9\_\:]+$/ ? class_to_file($stuff) : File::Spec->rel2abs($stuff);
    my $app = _load_sandbox($file);
    die "Error while loading $file: $@" if $@;

    return $app;
}

sub run_app($$) {
    my($app, $env) = @_;

    return eval { $app->($env) } || do {
        my $body = "Internal Server Error";
        $env->{'psgi.errors'}->print($@);
        [ 500, [ 'Content-Type' => 'text/plain', 'Content-Length' => length($body) ], [ $body ] ];
    };
}

sub headers {
    my $headers = shift;
    inline_object(
        iter   => sub { header_iter($headers, @_) },
        get    => sub { header_get($headers, @_) },
        set    => sub { header_set($headers, @_) },
        push   => sub { header_push($headers, @_) },
        exists => sub { header_exists($headers, @_) },
        remove => sub { header_remove($headers, @_) },
        headers => sub { $headers },
    );
}

sub header_iter {
    my($headers, $code) = @_;

    my @headers = @$headers; # copy
    while (my($key, $val) = splice @headers, 0, 2) {
        $code->($key, $val);
    }
}

sub header_get {
    my($headers, $key) = (shift, lc shift);

    my @val;
    header_iter $headers, sub {