view release on metacpan or  search on metacpan

pperl.h.header  view on Meta::CPAN

#!perl
use strict;

package PPerlServer;

use IO::Socket;
use IO::File;
use Fcntl ':flock', 'F_GETFL';
use POSIX qw(:signal_h setsid WNOHANG);
use Carp 'croak','cluck';
use PPerl qw( recv_fd read_int );

use vars qw(%CHILDREN $spid $data_at %FILEHANDLES $logfile);

$spid = $$;      # stash it as we change to be someone else later
$data_at = tell main::DATA
  if fileno main::DATA;  # strangely it moves!

BEGIN {
    $logfile = '/tmp/pperl.log';
    
    $PPERL::SOCKET_NAME = $ARGV[0];
    $PPERL::MAX_SERVERS = $ARGV[1] || 3;
    $PPERL::MAX_REQUESTS = $ARGV[2] || 100;
    $PPERL::WIDE_OPEN = $ARGV[3] || 0;
    $PPERL::NO_CLEANUP = $ARGV[4] || 0;
    $0 = $ARGV[5];
}

sub log_error {
    local *FH;
    open(FH, ">>$logfile")
      or die "Can't open logfile: '$logfile' $!";
    print FH @_;
}


my $____self;
my $should_exit = 0;
my $exit_code = 0;

BEGIN {
    *CORE::GLOBAL::exit = sub {
        my $retval = shift || 0;
        my $package = (caller)[0];

        log_error("exit $package $retval $should_exit\n");
        if ($package eq 'PPerlServer' || $should_exit) {
            exit($retval);
        }
        $exit_code = $retval;
        goto __PPerl_exit;
    };

    *CORE::GLOBAL::fork = sub {
        my $package = (caller)[0];
        my $ret = fork();
        if (defined $ret && !$ret && $package ne 'PPerlServer') {
            # forked children should just exit
            $should_exit = 1;
        }
        return $ret;
    };

    *CORE::GLOBAL::exec = sub {
        # This is so horribly wrong, overloading exec() to be
        # system();exit() - but there's no other way to make this
        # work. See the documentation in t/19invoke_djbish.t for
        # further info on this issue.
        my $package = (caller)[0];
        log_error("exec $package $should_exit\n");
        if ($package eq 'PPerlServer' || $should_exit) {
            exec(@_);
        }
        my $code = system(@_);
        $exit_code = $code >> 8;
        goto __PPerl_exit;
    };
}

sub barf {
    print $____self "XX @_";
    exit 1;
}

use vars qw( $pid $pidfile $saved_dir );


# lifted from B::walksymtable - mild tweaks to avoid all that slow
# slow recursion

my ($count, $closed);
sub find_open_filehandles {
    my ($symref, $prefix) = @_;
    return if $PPERL::NO_CLEANUP;
    my $sym;
    my $ref;
    no strict 'vars';
    
    $prefix = '' unless defined $prefix;
    push @packages, [ $symref, $prefix ];

    local(*GLOB);
    
    my %fhs;
    
    my $foo;
    while ($foo = shift @packages) {
        ($symref, $prefix) = @$foo;
        
        log_error("Examining $prefix\n");
        
        while (($sym, $ref) = each %$symref) {
            $count++;
            *GLOB = "*main::".$prefix.$sym;
            
            log_error("Processing: $sym\n");
            if ($sym =~ /::$/) {
                $sym = $prefix . $sym;
                if ($sym ne "main::" && $sym ne "<none>::") {
                    push @packages, [ \%GLOB, $sym ];
                }
            }
            else {
                next if $sym eq 'DATA';
                if (defined *GLOB{IO} and fileno(*GLOB{IO})) {
                    log_error("Adding: *main::".$prefix.$sym. " to FILEHANDLES\n");
                    $fhs{"*main::".$prefix.$sym} = *GLOB{IO};
                }
            }