view release on metacpan or  search on metacpan

lib/Dancer/Plugin/FakeCGI.pm  view on Meta::CPAN

    my ($ret, $err) = (undef, undef);
    {
        _capture_start(1, (!$params->{ret_error} && $params->{capture_stderr}) ? 1 : 0);
        debug("After _capture_start() ");

        Dancer::Factory::Hook->instance->execute_hooks('fake_cgi_before', \%ENV, $capture) unless ($params->{ret_error});
        debug("After hook: fake_cgi_before ");

        # Change to current dir where is cgi-bin
        #my $currWorkDir = Cwd::cwd();	# calling method cwd() is slowest than getcwd and use about 65ms
        my $currWorkDir = Cwd::getcwd();
        debug("After Cwd...");

        my $dir = _ret_cgi_bin_path();
        chdir($dir);

        debug("Before eval given code() ");

        #make sure this hooks are restored to their original state
        local $SIG{__DIE__}  = $SIG{__DIE__};
        local $SIG{__WARN__} = $SIG{__WARN__};

        # CGI::Compile made it
        ## Change script name
        #my $old_name = $0;
        ##local $0 = $filename; #this core dumps!?
        #*0 = \$filename if ($filename);

        $run_code_evaled = 1;

        # Test for timeout
        local $SIG{ALRM} = $SIG{ALRM};
        my $timeout = _parse_int($params->{timeout});
        if ($timeout) {
            $SIG{ALRM} = sub { die $str_alarmed };
            alarm $timeout;
        }

        eval {    # Run compiled code
            no strict 'refs';
            $ret = &{$code}();
        };

        alarm(0) if ($timeout);

        $err = $@;    # Save error to scalar

        #*0 = $old_name;

        $run_code_evaled = 0;
        chdir($currWorkDir);

        debug("After eval given code() ");

        _capture_end();
        debug("After _capture_end() ");
    }

    return $err if ($params->{ret_error});

    # When is in CGI called system() function, there is problem with filehandle and it is a blocked, then try to reopen it
    sub _reopen_file {
        return unless ($_[0]);
        close($_[0]) or warn "Can't close IO handler";
        open(my $fh, "<:utf8", $_[0]) or die "Can't reopen for reading : $!";
        return $fh;
    }

    # Print captured string on STDERR
    if ($capture->{"STDERR"}->{string}) {
        debug $capture->{"STDERR"}->{string};
    } elsif ($capture->{"STDERR"}->{io_fh}) {

        #$capture->{io_err} = _reopen_file($capture->{io_err});
        seek($capture->{"STDERR"}->{"io_fh"}, 0, SEEK_SET);

        # Print everything in STDERR as one line
        debug $capture->{"STDERR"}->{"io_fh"}->getlines();
        unlink($capture->{"STDERR"}->{"filename"}) if ($capture->{"STDERR"}->{"filename"});
    }
    delete($capture->{"STDERR"});
    debug("After STDERR print ");

    # Get on first position
    if ($settings->{'stdout-type'} eq 'file') {

        #$capture->{io_out} = _reopen_file($capture->{io_out});
    } elsif (exists($capture->{"STDOUT"}) && $capture->{"STDOUT"}->{"io_fh"}) {
        seek($capture->{"STDOUT"}->{"io_fh"}, 0, SEEK_SET);
    }

    # If error captured, than we finish
    if ($err) {
        croak $err eq $str_alarmed
          ? "Timeouted after " . $params->{timeout} . " seconds"
          : $err;
        return;
    }

    # Delete headers from captured STDOUT
    if (exists($capture->{"STDOUT"}) && $capture->{"STDOUT"}->{"io_fh"}) {
        my $r_str   = undef;
        my $str_len = 0;
        if ($capture->{"STDOUT"}->{"string"}) {
            $r_str = \$capture->{"STDOUT"}->{"string"};
        } else {
            my $str = '';
            $str_len = read($capture->{"STDOUT"}->{"io_fh"}, $str, 8 * 1024);    # Read 8kB from file a find if it isn't header
            $r_str = \$str;
        }

        # From HTTP::Message->parse
        my @hdr;
        while (1) {
            unless ($r_str) {
                last;
            } elsif ($$r_str =~ s/^([^\s:]+)[ \t]*: ?(.*)\n?//) {
                push(@hdr, $1, $2);
                $hdr[-1] =~ s/\r\z//;
            } elsif (@hdr && $$r_str =~ s/^([ \t].*)\n?//) {
                $hdr[-1] .= "\n$1";