view release on metacpan or  search on metacpan

lib/FCGI/Daemon.pm  view on Meta::CPAN

    }
}

=head2 run()
    Modulino-style main routine
=cut
sub run {
    getopts('hde:f:q:p:s:g:u:m:c:l:w:',\%o) or help(0);
    help(2) if $o{'h'};

    $o{sockfile}=$o{'s'}||'/var/run/fcgi-daemon.sock';
    $o{pidfile}=$o{'p'}||'/var/run/fcgi-daemon.pid' if $o{'d'};
    $o{prefork}=defined $o{'w'} ? $o{'w'} : 1;
    $o{queue}=defined $o{'q'} ? $o{'q'} : 96;
    $o{rlimit_vmem}=($o{'m'}||512)*1024*1024;
    $o{rlimit_cpu}=$o{'c'}||32;
    $o{max_evals}=defined $o{'e'} ? $o{'e'} : 10240;   #max evals before exit - paranoid to free memory if leaks
    $o{file_pattern}=$o{'f'}||qr{\.pl};
    $o{leak_threshold}=$o{'l'}||1.3;

    if($REAL_USER_ID==$EFFECTIVE_USER_ID and $EFFECTIVE_USER_ID==0){        # if run as root
        $o{gid}=$o{g}||'www-data'; $o{gid_num}=scalar getgrnam($o{gid});
        $o{uid}=$o{u}||'www-data'; $o{uid_num}=scalar getpwnam($o{uid});
    }

    local $SIG{INT}= local $SIG{TERM}= sub{
        # actually FCGI::ProcManager override our TERM handler so .sock and .pid files will be removed only by sysv script... :(
        $o{fcgi_pm}->pm_remove_pid_file() if $o{fcgi_pm};
        for my $f ( @o{'pidfile','sockfile'} ) {
            unlink $f if -f $f; 
        }    
        $o{fcgi_pm}->pm_die() if $o{fcgi_pm};   #pm_die() does not return
        exit 0;
    };

    # daemonize
    if($o{'d'}){
        chdir '/';                              # this is good practice for unmounting
        local $PROGRAM_NAME='FCGI::Daemon';
        defined(my $pid=fork) or die "Can't fork: $!";
        exit if $pid;
        eval {use POSIX qw(setsid); POSIX::setsid();} or die q{Can't start a new session: }.$OS_ERROR;
        open *STDIN,'<','/dev/null';
        open *STDOUT,'>>','/dev/null';
        open *STDERR,'>>','/dev/null';
        umask 022;
    }

    my %req_env;
    $o{fcgi_pm}=FCGI::ProcManager->new({n_processes=>$o{prefork},
                                        die_timeout=>28,
                                        pid_fname=>$o{pidfile}
                                      });
    print "Opening socket $o{sockfile}\n";
    my $rqst=FCGI::Request(\*STDIN,\*STDOUT,\*STDERR,\%req_env,
             FCGI::OpenSocket($o{sockfile},$o{prefork}*$o{queue}),
             FCGI::FAIL_ACCEPT_ON_INTR())
        or die "Error: Unable to create FCGI::Request...";

    if(defined $o{gid_num} and defined $o{uid_num}){                # if run as root
        chown $o{uid_num},$o{gid_num},$o{sockfile}                  # chown SOCKfile
            or dieif($OS_ERROR,'Unable to chown SOCKfile');
    }

    $o{fcgi_pm}->pm_manage();   # from now on we are worker process

    # drop privileges if run as root
    if(defined $o{gid_num} and defined $o{uid_num}){
       my $gid = getgrnam($o{gid});
       $EFFECTIVE_GROUP_ID = "$gid $gid";
       dieif($OS_ERROR,'Unable to effective group_id to '.$o{gid});
       $REAL_GROUP_ID = $gid;
       dieif($OS_ERROR,'Unable to change real group_id to '.$o{gid});
       my $uid = getpwnam($o{uid});
       $EFFECTIVE_USER_ID = $uid;
       dieif($OS_ERROR,'Unable to change effective user_id to '.$o{uid});
       $REAL_USER_ID  = $uid;
       dieif($OS_ERROR,'Unable to change real user_id to '.$o{uid});
    }

    ## set rlimit(s)
    setrlimit(RLIMIT_AS, $o{rlimit_vmem}, $o{rlimit_vmem})
      or warn "Unable to set RLIMIT_AS.\n";
    setrlimit(RLIMIT_CPU, $o{rlimit_cpu}, $o{rlimit_cpu})
      or warn "Unable to set RLIMIT_CPU.\n";

    REQ_LOOP:   # main loop
    while($rqst->Accept()>=0){

        $req_env{'PATH_INFO'}=$req_env{'SCRIPT_FILENAME'};
        $req_env{'SCRIPT_FILENAME'}=get_file_from_path($req_env{SCRIPT_FILENAME});
        $req_env{'PATH_INFO'}=~s/$req_env{'SCRIPT_FILENAME'}//;
        $req_env{'SCRIPT_NAME'}=$req_env{'SCRIPT_FILENAME'};
        $req_env{'SCRIPT_NAME'}=~s/$req_env{'DOCUMENT_ROOT'}//;

        # check if script (exacutable, readable, non-zero size)
        unless(-x -s -r $req_env{'SCRIPT_FILENAME'}){
            print "Content-type: text/plain\r\n\r\n";
            $_="Error: No such CGI app - $req_env{SCRIPT_FILENAME} may not exist or is not executable by this process.\n";
            print $_;
            print {*STDERR} $_;
            next;
        }

        local @ENV{keys %req_env}=values %req_env;
        chdir $1 if $req_env{'SCRIPT_FILENAME'}=~m{^(.*)\/};   # cd to the script's local directory

        # Fast Perl-CGI processing
        if($o{max_evals}>0 and $req_env{'SCRIPT_FILENAME'}=~m{$o{file_pattern}\z}){   # detect if perl script
            my %allvars;
            @allvars{keys %main::}=();
            {
                local *CORE::GLOBAL::exit=sub { die 'notr3a11yeXit' };
                local $0=$req_env{SCRIPT_FILENAME};     #fixes FindBin (in English $0 means $PROGRAM_NAME)
                no strict;                              ## no critic :: default for Perl5
                do $0;                                  # do $0; could be enough for strict scripts
                if($EVAL_ERROR){
                    $EVAL_ERROR=~s{\n+\z}{};
                    print {*STDERR} "$0\n$EVAL_ERROR\n\b" unless $EVAL_ERROR =~ m{^notr3a11yeXit};
                }
            }