The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/perl
#===============================================================================
#
#         FILE: wd_fcgi.fpl
#
#  DESCRIPTION:  FastCGI script for WebDAO project
#       AUTHOR:  Aliaksandr P. Zahatski (Mn), <zag@cpan.org>
#===============================================================================
#$Id: wd_fcgi.fpl,v 1.1 2006/10/13 12:39:09 zag Exp $
use HTML::WebDAO;
use FCGI;
use HTML::WebDAO::CVcgi;
use HTML::WebDAO::Session;
use HTML::WebDAO::Lex;
use HTML::WebDAO::FCGI::ProcManager;
use Data::Dumper;
use Getopt::Long;
use Pod::Usage;
use strict;
use warnings;
use POSIX;
#use Test::More;
use Carp;

my ( $listen, $nproc, $pidfile, $manager, $detach, $man, $help, $maxreq );

#set defaults
$nproc = 1;
my %opt = ( 'help|?' => \$help, man => \$man, );
GetOptions(
    'help|?'      => \$help,
    'listen|l=s'  => \$listen,
    'nproc|n=i'   => \$nproc,
    'pidfile|p=s' => \$pidfile,
    'daemon|d'    => \$detach,
    'maxreq|m=i'  => \$maxreq,
    'man'         => \$man
  )
  or pod2usage(2);
pod2usage(1) if $help;
pod2usage( -exitstatus => 0, -verbose => 2 ) if $man;

#begin init socket
my $sock = 0;
if ($listen) {
    my $saved_umask = umask(0);
    $ENV{FCGI_SOCKET_PATH}  = $listen;
    $ENV{FCGI_LISTEN_QUEUE} = 100;
    eval "use CGI::Fast qw(:standard); 1" or die $@;
    umask($saved_umask);
}
elsif ( $^O ne 'MSWin32' ) {
    -S STDIN
      or die "STDIN is not a socket; specify a listen location";
    eval "use CGI::Fast qw(:standard); 1" or die $@;

}

my $proc_manager;
if ($listen) {
    &daemon_fork() if $detach;
    $proc_manager = new HTML::WebDAO::FCGI::ProcManager::(
        {
            n_processes => $nproc,
            pid_fname   => $pidfile,
        }
    );

    # detach *before* the ProcManager inits
    &daemon_detach() if $detach;
    $proc_manager->pm_manage();
}

=head2 daemon_fork

Performs the first part of daemon initialisation.  Specifically,
forking.  STDERR, etc are still connected to a terminal.

=cut

sub daemon_fork {

    fork && exit;
}

=head2 daemon_detach

Performs the second part of daemon initialisation.  Specifically,
disassociates from the terminal.

However, this does B<not> change the current working directory to "/",
as normal daemons do.  It also does not close all open file
descriptors (except STDIN, STDOUT and STDERR, which are re-opened from
F</dev/null>).

=cut

sub daemon_detach {
    print "FastCGI daemon started (pid $$)\n";
    open STDIN,  "+</dev/null" or die $!;
    open STDOUT, ">&STDIN"     or die $!;
    open STDERR, ">&STDIN"     or die $!;
    POSIX::setsid();
}

sub load_module {
    my $class = shift || return;

    #check non loaded mods
    my ( $main, $module ) = $class =~ m/(.*\:\:)?(\S+)$/;
    $main ||= 'main::';
    $module .= '::';
    no strict 'refs';
    unless ( exists $$main{$module} ) {
        eval "use $class";
        if ($@) {
            croak "Error register class :$class with $@ ";
            return -1;
        }
    }
    use strict 'refs';
}

sub _parse_str_to_hash {
    my $str = shift;
    return unless $str;
    my %hash = map { split( /=/, $_ ) } split( /;/, $str );
    foreach ( values %hash ) {
        s/^\s+//;
        s/\s+^//;
    }
    \%hash;
}

my ( $def_store_class, $def_session_class, $def_eng_class );
my ( $store_class, $session_class, $eng_class ) = map {
    &load_module($_);
    $_
  } (
    $def_store_class = $ENV{WD_STORE}
      || $ENV{wdStore}
      || 'HTML::WebDAO::Store::Abstract',
    $def_session_class =
      $ENV{WD_SESSION} || $ENV{wdSession} || 'HTML::WebDAO::Session',
    $def_eng_class = $ENV{WD_ENGINE} || $ENV{wdEngine} || 'HTML::WebDAO::Engine'
  );
my $count_req = $maxreq || $ENV{wdFCGIreq} || -1;

while ( $count_req != 0 and my $fcgi_obj = new CGI::Fast ) {

    $proc_manager && $proc_manager->pm_pre_dispatch();
#    diag Dumper(\%ENV);
    if ( $ENV{SERVER_SOFTWARE} && $ENV{SERVER_SOFTWARE} =~ /lighttpd/ ) {
        $ENV{PATH_INFO} ||= delete $ENV{SCRIPT_NAME};
    }
    
    #customize ENV
    $store_class   = $ENV{WD_STORE}   || $ENV{wdStore}   || $def_store_class;
    $session_class = $ENV{WD_SESSION} || $ENV{wdSession} || $def_session_class;
    $eng_class     = $ENV{WD_ENGINE}  || $ENV{wdEngine}  || $def_eng_class;
    foreach my $rec (
        [ $store_class,   $store_class   eq $def_store_class ],
        [ $session_class, $session_class eq $def_session_class ],
        [ $eng_class,     $eng_class     eq $def_eng_class ]
      )
    {
        next if $rec->[1];
        &load_module( $rec->[0] );
    }
    my $store_obj = $store_class->new(
        %{
            &_parse_str_to_hash( $ENV{wdStorePar} || $ENV{WD_STORE_PAR} ) || {}
          }
    );
    my $sess = $session_class->new(
        %{
            &_parse_str_to_hash( $ENV{wdSessionPar} || $ENV{WD_SESSION_PAR} )
              || {}
          },
        store => $store_obj,
        cv    => new HTML::WebDAO::CVcgi:: $fcgi_obj,

    );
    $sess->set_header( -type => 'text/html; charset=utf-8' );

    #determine root document
    my $env_var = $ENV{wdIndexFile} || $ENV{WD_INDEXFILE};
    my %ini_pars = ();
    if ( $env_var && !-z $env_var ) {
        my ($filename) = grep { -r $_ && -f $_ } $env_var,
          "$ENV{DOCUMENT_ROOT}/$env_var", "$ENV{DOCUMENT_ROOT}/index.xhtml";
        die "$0 ERR:: file not found or can't access (WD_INDEXFILE): $env_var"
          unless $filename;
        my $content = qq!<wD><include file="$filename"/></wD>!;
        my $lex = new HTML::WebDAO::Lex:: content => $content;
        $ini_pars{lexer} = $lex;
    }
    else {
        $ini_pars{source} = '';
    }
    my $eng = $eng_class->new(
        %{
            &_parse_str_to_hash( $ENV{WD_ENGINE_PAR} || $ENV{wdEnginePar} )
              || {}
          },
        %ini_pars,
        session  => $sess,
    );
    $sess->ExecEngine($eng);
    $sess->destroy;
    --$count_req if $count_req > 0;
    $proc_manager && $proc_manager->pm_post_dispatch();
}
FCGI::finish();

__END__

=head1 NAME

wd_fcgi.fpl - FastCGI script for WebDAO project

=head1 SYNOPSIS

wd_fcgi.fpl [options]

    -d -daemon     Daemonize the server.
    -p -pidfile    Write a pidfile with the pid of the process manager.
    -l -listen     Listen on a socket path, hostname:port, or :port.
    -n -nproc      The number of processes started to handle requests.
    -m -maxreq     Number of request before process will be restarted 
                   -1 - unlimited. (defailt: -1)
                   

=head1 SETUP



=head1 SEE ALSO

http://sourceforge.net/projects/webdao, HTML::WebDAO

=head1 AUTHOR

Zahatski Aliaksandr, E<lt>zag@cpan.orgE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright 2003-2008 by Zahatski Aliaksandr

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself. 

=cut