#!/bin/sh
# vim: set cindent expandtab ts=4 sw=4:
exec ${PERL-perl} -Swx $0 ${1+"$@"}

#!/usr/bin/perl -w
# dispatch.fcgi - a small script to make common cgi into fast
#                 cgi progarme, reduce the forking overhead
#
# Author: He zhiqiang <hzqbbc@hzqbbc.com>
#   Date: 27 Dec 2005
# Update: 30 May 2006
#
# Support: Apache 2.x or lighttpd 1.3.x/1.4.x
use vars qw(%cache $root %CHILDREN $FILENAME);
use POSIX qw(setlocale LC_ALL setsid WNOHANG);
use Getopt::Long;
my $debug = 0;
%cache = ();
$FILENAME = "dispatch.fcgi";

BEGIN {
    $root = $ENV{SCRIPT_FILENAME} || $0;
    if ($root =~/^\./) {
        print "Please run dispatch.fcgi with full path\n";
        print "    example: /path/to/dispatch.fcgi\n";
        exit (255);
    }
    $root =~ s#/*[^/]+$##;
    $root =~ s#/(extmail|extman)$/*$##;
    $root =~ m/^(.*)$/s;
    $root = $1; # untaint
    unshift @INC, "$1/extmail/libs";
    require Ext::FCGI;
}

# initialize locale
setlocale(LC_ALL, "C");

my %opt;
Getopt::Long::Configure('no_ignore_case');
GetOptions(\%opt, 'help|h', 'port|p=i', 'child|c=i', 'server|s',
                  'uid|u=s', 'gid|g=s', 'pid=s', 'request|r=i',
                  'timeout=i')
    or exit(1);
if($opt{help}) {
    print "usage: /path/to/dispatch.fcgi [*option*]\n\n";
    print "  -h, --help       show this usage\n";
    print "  --port=PORT      FCGI server bind port, eg:8888\n";
    print "  --child=NUMB     number of children to prefork\n";
    print "  --request=NUMB   number of requests a child to handle\n";
    print "  --timeout=NUMB   seconds to wait for request timeout\n";
    print "  --server         run as FCGI server, default off\n";
    print "  -u, --uid        set real and effective user ID\n";
    print "  -g, --gid        set real and effective group ID\n";
    print "  --pid=file       the pid file of parent process\n";
    exit (1);
}

if ($opt{server}) {
    $SIG{CHLD} = \&reap_child;
    $SIG{TERM} = \&kill_all;

    daemonize() if ($opt{server});

    my $socket = FCGI::OpenSocket( ":$opt{port}", 5 );
    my $request = FCGI::Request( \*STDIN, \*STDOUT, \*STDERR,
        \%ENV, $socket );
    open (my $_fh, "< $0") or die $!;

    set_master();
    if ($opt{uid} && $opt{gid}) {
        set_gid($opt{gid});
        set_uid($opt{uid});
    }

    while (1) {
        defined ( my $child = fcgi_fork() ) or die "$@";

        if ($child == 0) {
            set_idle();
            main_loop($request, $_fh);
            exit (0);
        } else {
            $CHILDREN{$child} = 1;
        }
    }
    close $_fh;
} else {
    set_idle();
    my $request = Ext::FCGI::Request();
    main_loop($request);
}

#
# main_loop - the core function for fcgi
sub main_loop {
    my $request = shift;
    my $lock = shift;
    my $count = 0;

    while (Ext::FCGI::accept($request, $lock)>=0) {
        my $file = request_file();
        set_busy();

        print "content-type: text/html\r\n\r\n" if ($debug);

        my $last_alarm = alarm($opt{timeout}||120);

        # XXX begin eval() and timeout detection
        eval {
            local $SIG{ALRM} = sub { die "System Timeout or busy\n" };
            if (cached($file)) {
                print "$file cached\n" if ($debug);
                compile($cache{$file}->{code});
            } else {
                print "first time run $file\n" if ($debug);
                my $code = file2code($file);
                $cache{$file}->{code} = $code;
                $cache{$file}->{mtime} = -M $file;
                compile($code);
            }
            if ($@) {
                print "content-type: text/html\r\n\r\n";
                print "Error: $@\n";
            }
        };
        # XXX end of timeout detection
        alarm($last_alarm);

        Ext::FCGI::request_cleanup;
        set_idle();
        $count++;

        # exit main loop to end child process, free
        # memory and other resources
        last if $count >= ($opt{request}||100);
    }
} # XXX end of main_loop

# request_file - initialize file path and ENV
sub request_file {
    my $file = $ENV{SCRIPT_FILENAME};

    # we get PATH_INFO ? possible it's Apache
    if (my $path = $ENV{PATH_INFO}) {
        my $sname = $ENV{SCRIPT_NAME};
        $sname =~ s#^/+##; # remove /extmail/cgi => extmail/cgi
        $path =~ s#^/+##; # remove /index.cgi => index.cgi
        $file = "$root/$sname/$path";
    # or it's lighttpd, well we just guess :D
    } else {
        $file = $ENV{SCRIPT_NAME};
        $file =~ s!^/!!;
        $file = "$root/$file";
    }
    $ENV{SCRIPT_FILENAME} = $file;
    $file;    
}

sub cached {
    my $file = shift;
    if ($cache{$file}) {
        my $mtime = $cache{$file}->{mtime};
        if (-M $file >= $mtime) {
            return 1;
        }
    } else {
        return 0;
    }
}

sub compile {
    my $code = shift;
    $code =~ m/^(.*)$/s;
    eval $1;
}

sub file2code {
    my $file = shift;
    if (-r $file) {
        open (FD, "< $file") or die "$!\n";
        local $/ = undef;
        my $code = <FD>;
        close FD;
        return $code;
    } else {
        return "print \"content-type: text/html\r\n\r\nRequest file $file not exists\"";
    }
}

#
# Multi process fastcgi server functions

sub set_busy {
    $0 = "$FILENAME (busy)";
}

sub set_idle {
    $0 = "$FILENAME (idle)";
}

sub set_master {
    $0 = "$FILENAME (master)";
}

sub fcgi_fork {
    sleep while((scalar keys %CHILDREN) >= $opt{child});
    return fork;
}

sub reap_child {
    while( (my $pid = waitpid(-1, WNOHANG)) > 0 ) {
        next unless $pid;
        delete $CHILDREN{$pid};
    }
}

sub kill_all {
    for my $pid (keys %CHILDREN) {
        next unless kill 0, $pid; # if it's alive
        kill 9, $pid;
    }
    1 while waitpid(-1, WNOHANG) > 0;
    exit 0;
}

sub daemonize {
    open STDIN, '/dev/null' or die "mailgraph: can't read /dev/null: $!";
    open STDOUT, '>/dev/null'
        or die "Can't write to /dev/null: $!";
    defined(my $pid = fork) or die "Can't fork: $!";
    if($pid) {
        # parent
        my $pidfile = $opt{pid} || "$0.pid";
        open PIDFILE, "> $pidfile" or die "Can't write to $0.pid: $!\n";
        print PIDFILE "$pid\n";
        close(PIDFILE);
        exit;
    }
    # child
    setsid                  or die "Can't start a new session: $!";
    open STDERR, '>&STDOUT' or die "Can't dup stdout: $!";
}

# the following functions derive from suid-perl
sub numberp { defined $_[0] && $_[0] =~ m/^-?\d+$/o; }

sub group2gid {
    my $g = shift;
    return $g if numberp ($g);
    my $gid = getgrnam ($g);
    return $gid if defined $gid && numberp ($gid);
    die "no such group: $g";
}

sub user2uid {
    my $u = shift;
    return $u if numberp ($u);
    my $uid = getpwnam ($u);
    return $uid if defined $uid && numberp ($uid);
    die "no such user: $u";
}

sub set_gid {
    my $sgid = group2gid (shift);
    my $rgid = $( + 0;
    my $egid = $) + 0;

    $( = $sgid;
    $) = $sgid;
    die "cannot set rgid $sgid: $!\n" if ($( == $rgid && $rgid != $sgid);
    die "cannot set egid $sgid: $!\n" if ($) == $egid && $egid != $sgid);
}

sub set_uid {
    my $suid = user2uid (shift);
    my $ruid = $<;
    my $euid = $>;

    $< = $suid;
    $> = $suid;
    die "cannot set ruid $suid: $!\n" if ($< == $ruid && $ruid != $suid);
    die "cannot set euid $suid: $!\n" if ($> == $euid && $euid != $suid);
}

1;
__END__

I wrote this programe for extmail project, the mechanism derive
from Embed::Persistent, using eval() and FCGI, it works :-)