package Cluster::Init;
#

#
# The Design 
# ==========
#
# A collection of event-driven DFA or finite state machines; each machine 
# is its own object.
#
# Daemon machine started first, daemon starts group machines, group machines
# start process machines, process machines start and stop processes.
#
# Client talks to daemon via UNIX domain socket.
#
use strict;
use warnings;
use Data::Dump qw(dump);
use Carp::Assert;
use IO::Socket;
use POSIX qw(:signal_h :errno_h :sys_wait_h);
use IPC::LDT qw(              
  LDT_OK
  LDT_CLOSED
  LDT_READ_INCOMPLETE
  LDT_WRITE_INCOMPLETE
);
use Cluster::Init::DB;
use Cluster::Init::Conf;
use Cluster::Init::Util qw(debug);
use Cluster::Init::Daemon;
use base qw(Cluster::Init::Util);

our $VERSION     = "0.207";

my $debug=$ENV{DEBUG} || 0;

my $cltab="/etc/cltab";


=head1 NAME

Cluster::Init - Clusterwide "init", spawn cluster applications

=head1 SYNOPSIS

  use Cluster::Init;

  my $init = new Cluster::Init;

  # spawn all apps for resource group "foo", runlevel "run"
  $init->tell("foo","run");

  # spawn all apps for resource group "foo", runlevel "runmore"
  # (this stops everything started by runlevel "run")
  $init->tell("foo","runmore");

  # spawn all apps for resource group "bar", runlevel "3"
  # (this does *not* stop or otherwise affect anything in "foo")
  $init->tell("bar",3);

=head1 DESCRIPTION

This module provides basic B<init> functionality, giving you a single
inittab-like file to manage initialization and daemon startup across a
cluster or collection of machines.  

This module is used by B<OpenMosix::HA>, for instance, to provide high
availability with failure detection, automatic migration, and restart
of applications running in a cluster.  B<OpenMosix::HA> provides you
with the ability to build 24x7 mission-critical, high-performance
server farms using only commodity hardware.  See L<OpenMosix::HA>.

I wrote the original version of this module to provide a more flexible
interface between IBM's AIX HACMP cluster manager and managed
applications.  This provided a cleaner configuration, much faster
configuration changes, and respawn ability for individual daemons.

Other uses abound, including non-cluster environments -- use your
imagination.  Generically, what you get in this package is an
application-level "init" written in Perl, with added bits in the form
of resource groups, status file output, and a 'test' runmode (see
below).  

=head1 INSTALLATION

Use Perl's normal sequence:

  perl Makefile.PL
  make
  make test
  make install

This module includes a script, B<clinit>, which will be installed when
you run 'make install'.  See the output of C<perl -V:installscript> to
find out which directory the script is installed in.

=head1 CONFIGURATION

You will need to create a configuration file, F</etc/cltab> by
default, which is identical in format to F</etc/inittab>, with a new
"resource group" column added.  See F<t/cltab> in the B<Cluster::Init>
distribution for an example.  This file must be replicated across all
hosts in the cluster by some means of your own.  On OpenMosix
clusters, B<OpenMosix::HA> will replicate this file for you.  See
F<http://www.Infrastructures.Org> for ways to do this in other
environments.

A I<resource group> is a collection of applications and physical
resources (like filesystem mounts) which need to execute together on
the same cluster node.  Resource groups allow easy migration of
applications between nodes.  For example, B<sendmail>,
F</etc/sendmail.cf>, and the F</var/spool/mqueue> directory might make
up a resource group.  From F</etc/cltab> you could spawn the scripts
which update F<sendmail.cf>, mount F<mqueue>, and then start
B<sendmail> itself.  For another example, Apache, a virtual IP
address, and the filesystem containing the HTML document tree might
together constitute a resource group.  To start this resource group,
you might need to mount the filesystem, ifconfig the virtual IP, and
start httpd.  This sequence can easily be specified in F</etc/cltab>.

Any time B<Cluster::Init> changes the runlevel of a resource group, it
will update a status file, F</var/run/clinit/clstat> by default.  This
file can be read directly or via the C<status()> method, below.

You can specify tests to be performed during startup of a resource
group:  In addition to the init-style modes of 'once', 'wait',
'respawn', and 'off', B<Cluster::Init> supports a 'test' runmode.  If
the return code of a 'test' command is anything other than zero, then
the resource group as a whole is marked as 'FAILED' in F<clstat>.  For
example, this 'test' mode is used by B<OpenMosix::HA> to test a node
for eligibility before attempting to start a resource group there.

=head1 CLINIT SCRIPT 

Cluster::Init includes B<clinit>, a script which is intended to be a
bolt-in cluster init tool.  The script is called like B<init>, with
the addition of a new "resource group" argument.  See the output of
C<clinit -h>.  

The first time you execute B<clinit> you will need to use the C<-d>
flag only, to start the B<Cluster::Init> daemon.  

Once you have the daemon running, use B<clinit> I<without> the C<-d>
flag.  This will cause it to run as a client only, talking to the
daemon via a UNIX domain socket.  At this point you will use B<clinit>
in roughly the same way you would use the UNIX B<telinit>, in this
case commanding resource groups to switch to different runlevels.
That's it! 

Use the C<-k> flag to tell the daemon and all child processes to shut
down gracefully.

=head2 CLINIT SCRIPT EXAMPLES

(here we will show an example cltab, some clinit command lines, and
the resulting clstat contents -- in the meantime take a look at the
contents of F<t/*>)

=head1 PUBLIC METHODS

=head2 daemon(%parms)

The server-side constructor.  Accepts an optional hash containing the
paths to the configuration file, socket, and status output file, like
this:

  my $init = new Cluster::Init (
      'cltab' => '/etc/cltab',
      'socket' => '/var/run/clinit/init.s'
      'clstat' => '/var/run/clinit/clstat'
			  );

You can also specify 'socket' and 'clstat' locations in the F<cltab>
file itself, like this:

  # location of socket
  :::socket:/tmp/init.s
  # location of status file
  :::clstat:/tmp/clstat

Settings found in the cltab file override those found in the
constructor.

This method opens a UNIX domain socket, F</var/run/clinit/init.s> by
default.  Subsequent executions communicate with the first via this
socket.  


=cut

sub daemon
{
  my $class = shift;
  my $self = {@_};
  bless $self, $class;
  my $conf = $self->getconf(context=>'server',@_);
  Cluster::Init::Daemon->new(conf=>$conf);
  $self->loop();
  return 1;
}

sub client
{
  my $class = shift;
  my $self = {@_};
  bless $self, $class;
  my $conf = $self->getconf(context=>'client',@_);
  $self->{'socket'} = $conf->get('socket');
  return $self;
}

sub tell
{
  my $self=shift;
  my $group = shift;
  my $level = shift;
  my $socket = $self->{'socket'};
  affirm { $socket };
  affirm { -S $socket };
  my $client = new IO::Socket::UNIX 
  (
    Peer => $socket,
    Type => SOCK_STREAM
  ) || die $!;
  my $ldt=new IPC::LDT(handle=>$client, objectMode=>1);
  # send command
  debug "sending command $group $level";
  $ldt->send({group=>$group,level=>$level}) || warn $ldt->{'msg'};
  debug "command sent";
  # get response
  my $res;
  until (($res)=$ldt->receive)
  {
    die $ldt->{msg} if $ldt->{rc} == LDT_CLOSED;
  }
  return $res->{msg};
}


=head2 status(group=>'foo',level=>'bar',clstat=>'/tmp/clstat')

This method will read the status file for you, dumping it to stdout.
All arguments are optional.  If you provide 'group' or 'level', then
output will be filtered accordingly.  If you specify 'clstat', then
the status file at the given pathname wil be read (this is handy if
you need to query multiple Cluster::Init status files in a shared cluster
filesystem).

In addition to the usual $obj->status() syntax, the status() method
can also be called as a class function, as in
Cluster::Init::status(clstat=>'/tmp/clstat').   The 'clstat' argument
is required in this case.  Again, this is handy if you want to query a
running Cluster::Init on another machine via a shared filesystem, without
creating an Cluster::Init object or daemon here.  

=cut

sub status
{
  my $self=shift;
  my %parm = @_;
  # allow this to be called as Cluster::Init->status(...)
  $self=bless({},$self) unless ref($self);
  my $group = $parm{'group'} if $parm{'group'};
  my $level = $parm{'level'} if defined($parm{'level'});
  my $clstat = $parm{'clstat'} || $self->conf('clstat');
  die "need to specify clstat" unless $clstat;
  return "" unless -f $clstat;
  my $out ="";
  open(CLSTAT,"<$clstat") || die $!;
  while(<CLSTAT>)
  {
    chomp;
    my ($obj,$name,$stlevel,$state)=split;
    next unless $obj eq "Cluster::Init::Group";
    if ($group)
    {
      next unless $group eq $name;
    }
    if (defined($level))
    {
      next unless $level eq $stlevel;
    }
    $out.="$name " unless $group;
    $out.="$stlevel " unless $level;
    $out.=$state;
    $out.="\n" unless $group && $level;
  }
  return $out;
}

=head2 shutdown()

Causes daemon to stop all child processes and exit.

=cut

sub shutdown
{
  my $self=shift;
  return $self->tell(":::ALL:::",":::SHUTDOWN:::");
}

sub getconf
{
  my $self=shift;
  $cltab=$self->{cltab} if $self->{cltab};
  $self->{conf} = Cluster::Init::Conf->new(cltab=>$cltab,@_);
  my $conf = $self->{conf};
  return $conf;
}

sub conf
{
  my $self=shift;
  my $var=shift;
  die "can't set conf here" if @_;
  my $conf = $self->{conf};
  return $conf->get($var);
}

sub loop
{
  my $rc=Event::loop();
  debug $rc if $rc;
}

package XXX;
use IO::Socket;
# use IO::Select;
use POSIX qw(:signal_h :errno_h :sys_wait_h);
use Event qw(loop unloop unloop_all all_watchers);
use Event::Stats;
# use Time::HiRes qw(time);
use Storable qw(store retrieve freeze thaw dclone);


# Event priorities
use constant PCLIENT => 1; # client input
use constant PCHLD   => 2; # sigchld
use constant PKILL   => 2; # process killers
use constant PSTART  => 2; # process managers

# Event or group bit states
#  renumber with:
#   :perldo $i=1 
#   :'a,'bperldo s/\d+;/$i;/;$i*=2;
use constant CONFIGURED	=>    1; # found in config file
use constant STARTING	=>    2; # to be exec'd
use constant RUNNING	=>    4; # exec complete
use constant EXITED	=>    8; # exited, analysis pending
use constant DONE	=>   16; # exited normally
use constant KILL1	=>   32; # kill 1 sent
use constant KILL2	=>   64; # kill 2 sent
use constant KILL9	=>  128; # kill 9 sent
use constant KILL15	=>  256; # kill 15 sent
use constant KILLED	=>  512; # exited after kill 
use constant PASSED	=> 1024; # 'test' mode exited with zero rc
use constant FAILED	=> 2048; # 'test' mode exited with nonzero rc
use constant REMOVED	=> 4096; # not found in config file
use constant SHUTDOWN	=> 8192; # kill everything and exit

sub debug
{
  my ($package, $filename, $line, $subroutine, $hasargs, $wantarray, $evaltext, $is_require, $hints, $bitmask) = caller(1);
  my $subline = (caller(0))[2];
  my $msg = join(' ',@_);
  $msg.="\n" unless $msg =~ /\n$/;
  warn "$$ $subroutine,$subline: $msg" if $debug;
  if ($debug > 1)
  {
    warn _stacktrace();
  }
  if ($debug > 2)
  {
    Event::Stats::collect(1);
    warn sprintf("%d\n%-20s %3s %10s %4s %4s %4s %4s %7s\n", time,
    "DESC", "PRI", "CBTIME", "PEND", "CARS", "RAN", "DIED", "ELAPSED");
    for my $w (reverse all_watchers())
    {
      my @pending = $w->pending();
      my $pending = @pending;
      my $cars=sprintf("%01d%01d%01d%01d",
      $w->is_cancelled,$w->is_active,$w->is_running,$w->is_suspended);
      my ($ran,$died,$elapsed) = $w->stats(60);
      warn sprintf("%-20s %3d %10d %4d %4s %4d %4d %7.3f\n",
      $w->desc,
      $w->prio,
      $w->cbtime,
      $pending,
      $cars,
      $ran,
      $died,
      $elapsed);
    }
  }
}

sub log
{
  my $self=shift;
  my $log = $self->conf('log');
  return unless $log;
  open(LOG,">>$log") || die $!;
  print LOG "@_\n";
  close LOG;
}

sub new
{
  my $class=shift;
  $class = (ref $class || $class);
  my $self={};
  $self->{role}='unknown';
  bless $self, $class;


  my %parms=@_;

  $self->{db} = new DB;
  my $db = $self->{db};

  # parms override cltab
  $self->conf('cltab',$parms{'cltab'} || "/etc/cltab");
  $self->conf('socket',$parms{'socket'}) if $parms{'socket'};
  $self->conf('clstat',$parms{'clstat'}) if $parms{'clstat'};
  $self->conf('log',$parms{'log'}) if $parms{'log'};
  # cltab *might* override parms
  $self->_cltab();
  # otherwise use defaults
  $self->conf('socket',"/var/run/clinit/init.s") unless $self->conf('socket');
  $self->conf('clstat',"/var/run/clinit/clstat") unless $self->conf('clstat');
  $self->conf('log',"/var/run/clinit/initlog") unless $self->conf('log');

  # ($self->{'group'}, $self->{'level'}) = ("NULL", "NULL");



  $self->_open_socket() || $self->_start_daemon() || die $!;

  return $self;
}

=head2 tell($resource_group,$runlevel)

This method talks to a running Cluster::Init daemon, telling it to switch
the given resource group to the given runlevel.  

All processes listed in the configuration file (normally
/etc/cltab) which belong to the new runlevel will be started if
they aren't already running.

All processes in the resource group which do not belong to the new
runlevel will be killed.

Other resource groups will not be affected.

=cut

# *all* socket comm to server goes through here
sub tell
{
  my ($self,$group,$runlevel)=@_;
  debug "opening on client side";
  my $socket = $self->_open_socket() || die $!;
  debug "sending $group $runlevel to server";
  print $socket "$group $runlevel\n";
  # debug "reading on client side";
  # my $res = <$socket>;
  close($socket);
  debug "done on client side";
  1;
}

=head2 shutdown()

Causes daemon to stop all child processes and exit.

=cut

sub shutdown
{
  my ($self)=@_;
  $self->tell(":::ALL:::",":::SHUTDOWN:::");
  1;
}

=head2 status(group=>'foo',level=>'bar',clstat=>'/tmp/clstat')

This method will read the status file for you, dumping it to stdout.
All arguments are optional.  If you provide 'group' or 'level', then
output will be filtered accordingly.  If you specify 'clstat', then
the status file at the given pathname wil be read (this is handy if
you need to query multiple Cluster::Init status files in a shared cluster
filesystem).

In addition to the usual $obj->status() syntax, the status() method
can also be called as a class function, as in
Cluster::Init::status(clstat=>'/tmp/clstat').   The 'clstat' argument
is required in this case.  Again, this is handy if you want to query a
running Cluster::Init on another machine via a shared filesystem, without
creating an Cluster::Init object or daemon here.  

=cut

sub status
{
  my $self=shift;
  my %parm = @_;
  # allow this to be called as Cluster::Init->status(...)
  $self=bless({},$self) unless ref($self);
  my $group = $parm{'group'} if $parm{'group'};
  my $level = $parm{'level'} if $parm{'level'};
  my $clstat = $parm{'clstat'} || $self->conf('clstat');
  die "need to specify clstat" unless $clstat;
  return "" unless -f $clstat;
  open(CLSTAT,"<$clstat") || die $!;
  warn <CLSTAT>;
}

=head1 PRIVATE METHODS

The following methods are documented here for internal use only.  No
user serviceable parts inside.

=cut

=head2 _open_socket()

Opens a client-side socket.

=cut

sub _open_socket
{
  my $self=shift;
  my $client = new IO::Socket::UNIX (
      Peer => $self->conf('socket'),
      Type => SOCK_STREAM
				    );
  return $client;
}

=head2 _start_daemon()

Opens server-side socket, starts main event loop, with long-running
event watchers for accepting and processing commands from client,
child exits, status file maintenance, etc.

=cut

sub _start_daemon
{
  my $self=shift;
  my $db=$self->{db};
  my $child;
  unless ($child = fork())
  {
    if ($debug > 4)
    {
      require NetServer::Portal;
      NetServer::Portal->default_start();  # creates server
      warn "NetServer::Portal listening on port ".(7000+($$ % 1000))."\n";
      $Event::DebugLevel=$debug;
    }
    unlink $self->conf('socket');
    my $server = new IO::Socket::UNIX (
      Local => $self->conf('socket'),
      Type => SOCK_STREAM,
      Listen => SOMAXCONN
    ) || die $!;

    Event->io
    (
      desc=>'_daemon',
      fd=>$server,
      cb=>\&_daemon,
      prio=>PCLIENT,
      data=>$self
    );

    Event->var
    (
      desc=>'_writestat',
      var=>\$db->{_mtime},
      poll=>'w',
      cb=>\&_writestat,
      prio=>PCLIENT,
      data=>$self
    );

    # $Event::DIED = sub {
      # Event::verbose_exception_handler(@_);
      # # warn _stacktrace();
      # Event::unloop_all();
      # # exit 1;
      # };

    my $rc = loop();
    debug "loop returned $rc";
    exit 1 unless $rc == SHUTDOWN;
    debug "exiting normally";
    # for my $w (all_watchers)
    # {
      # $w->cancel();
      # }
    exit 0;
  }
  debug "Cluster::Init daemon started as PID $child\n"; 
  sleep 1;
  return $child;
}

=head2 _daemon()

Watcher triggered by I/O activity on server socket; calls accept() and
sets a watcher for client I/O.

=cut

sub _daemon
{
  my $e=shift;
  my $self=$e->w->data;
  my $server=$e->w->fd;
  my $client = $server->accept();
  Event->io
  (
    desc=>'_client',
    fd=>$client,
    cb=>\&_client,
    prio=>PCHLD,
    data=>$self
  );
}

=head2 _client()

Watcher triggered by I/O activity on accept()ed client socket; parses
text from client and does the right thing.

=cut

sub _client
{
  my $e=shift;
  my $self=$e->w->data;
  my $client=$e->w->fd;
  debug "reading on server side";
  my $data=<$client>;
  $e->w->cancel;
  unless ($data)
  {
    debug "no data";
    # print $client "no command seen\n";
    return;
  }
  # warn dump($e);
  # $e->w->debug(0) unless $data;
  chomp($data);
  debug "got: $data\n" if $data;
  my ($group,$level) = split(' ',$data);
  unless (defined($group) && defined($level))
  {
    debug "got garbage";
    return
  }
  if ($level eq ":::SHUTDOWN:::")
  {
    $self->_shutdown();
    # print $client "shutdown accepted\n";
  }
  else
  {
    $self->_tellgroup($group,$level);
    # print $client "command accepted\n";
  }
}

=head2 _tellgroup($group,$level)

Finds the watcher for a particular resource group, and tells it what
the new runlevel is.  If the watcher isn't running yet, then we start
it.  

=cut

sub _tellgroup
{
  my $self=shift;
  my $db=$self->{db};
  my $group=shift;
  my $newlevel=shift;
  debug "_tellgroup $group $newlevel";
  # re-read cltab
  $self->_cltab();
  # find watcher
  affirm { $group };
  my ($summary) = $db->get({type=>'summary',group=>$group});
  unless ($summary)
  {
    $summary = $db->ins
    (
      {
	type=>'summary',
	group=>$group,
	state=>CONFIGURED,
	level=>undef()
      }
    );
    affirm { $summary->{_mtime} };
    my $w = Event->var
    (
      desc=>"_group_$group",
      var=>\$summary->{_mtime},
      cb=>\&_group,
      prio=>PSTART,
      data=>[$self,$summary]
    );
    $summary->{w}=$w;
    # $w->now();
  }
  affirm { $summary->{type} eq 'summary' };
  affirm { $summary->{group} eq $group };
  $db->upd($summary,{newlevel=>$newlevel});
}

=head2 _group()

Watcher triggered by control activity for a resource group; start
and/or stop watchers for the individual entries in the group.
Maintain master summary of group info.

Setting a runlevel of undef() causes the group to stop all of its
processes and cancel its watcher.

=cut

sub _group
{
  my $e=shift;
  my $self=$e->w->data->[0];
  my $summary=$e->w->data->[1];
  $self->_cltab();
  my $db = $self->{db};
  my $group = $summary->{group};
  debug "group $group";
  my $level = $summary->{level};
  my $newlevel = $summary->{newlevel};
  # dump $db;
  my @entry = sort byline $db->get({type=>'entry',group=>$group});
  # make sure every entry has a triggered watcher
  for my $entry (@entry)
  {
    my $tag = $entry->{tag};
    my $w = $entry->{w};
    unless ($w)
    {
      $w = Event->var
      (
	desc=>"_entry_${tag}",
	var=>\$entry->{_mtime},
	cb=>\&_entry,
	prio=>PSTART,
	data=>[$self,$entry]
      );
      $entry->{w}=$w;
    }
    debug "triggering";
    $w->now();
  }

  # $DB::single=1 if $newlevel eq ":::SHUTDOWN:::";
  # update state 
  my $all=$self->_sum(type=>'entry',group=>$group);
  my $old=0;
  if (defined($level))
  {
    my $levelqr   =qr/(^[^,]*$level   [^,]*$)|((^|,)$level   (,|$))/x;
    $old=$self->_sum(type=>'entry',group=>$group,level=>$levelqr);
  }
  # $old=CONFIGURED unless $old;
  my $new=0;
  if (defined($newlevel))
  {
    my $newlevelqr=qr/(^[^,]*$newlevel[^,]*$)|((^|,)$newlevel(,|$))/x;
    $new=$self->_sum(type=>'entry',group=>$group,level=>$newlevelqr);
  }
  $new=SHUTDOWN if $new==0 && $newlevel eq ":::SHUTDOWN:::";
  debug "all $all old $old new $new";
  my $state=$new | ($old & ~CONFIGURED);
  if 
  (
    (defined($summary->{state}) && ($summary->{state} != $state) ) ||
    ! defined($summary->{state})
  )
  {
    $db->upd($summary,{state=>$state}) 
  }

  # update level
  $level=$newlevel if ($old == 0)          && ($new & ~CONFIGURED);
  $level=$newlevel if ($old == CONFIGURED) && ($new & ~CONFIGURED);
  $level=$newlevel if $state == SHUTDOWN;
  if 
  (
    (defined($summary->{level}) && ($summary->{level} ne $level) ) ||
    ! defined($summary->{level})
  )
  {
    $db->upd($summary,{level=>$level});
  }
  # $e->w->stop;
  # $e->w->start;

  debug "group $group state $state level "
  .(defined $level ? $level : 'undef')
  ." newlevel "
  .(defined $newlevel ? $newlevel : 'undef')
  ;

}

sub _sum
{
  my $self=shift;
  my %filter=@_;
  my @item = $self->{db}->get(\%filter);
  my $sum=0;
  for my $item (@item)
  {
    affirm { $item->{state} };
    $sum|=$item->{state};
    # debug "tag ".$item->{tag}." state ".$item->{state}." sum $sum";
  }
  return $sum;
}

=head2 _entry()

Watcher triggered by control activity for an individual cltab entry;
start or stop process accordingly.  Will also be triggered indirectly
by signals, via _sigchld.

Each entry gets an active watcher, all the time, regardless of whether
the entry is for a currently active runlevel or not.

If the cltab entry for a given watcher disappears, then the watcher
kills its own process and cancels itself.

=cut

sub _entry
{
  my $e=shift;
  my $self=$e->w->data->[0];
  my $entry=$e->w->data->[1];
  affirm { $entry->{state} } ;
  affirm { $entry->{w} } ;
  my $db = $self->{db};
  my $w=$e->w;
  my $tag=$entry->{tag};
  debug "entry $tag running, address is $w";
  affirm { $w };
  affirm { $w == $entry->{w} } ;
  my $pid=$entry->{pid} || 0;
  my $group=$entry->{group};
  my $mode = $entry->{mode};
  my $cmd = $entry->{cmd};
  my $elevel=$entry->{level};
  affirm { $elevel } ;
  my @level;
  if ($elevel =~/,/)
  {
    @level = split(',',$elevel);
  }
  else
  {
    @level = split('',$elevel);
  }
  debug "entry $tag has levels ".dump(@level);
  my ($summary) = $db->get({type=>'summary',group=>$group});
  my $level = $summary->{level};
  my $newlevel = $summary->{newlevel};
  # $e->w->stop;
  # $e->w->start;
  my $s = $entry->{state};
  debug "analyzing $tag, state is $s";
  {

    $s|= SHUTDOWN if $newlevel eq ":::SHUTDOWN:::";

    (STARTING | RUNNING) & $s && do
    {
      unless (grep /^$newlevel$/, @level)
      {
	$self->_kill($entry);
	last;
      }
    };

    CONFIGURED == $s && do
    {
      last unless grep /^$newlevel$/, @level;
      # this is the *only* place a process gets started
      $s|=STARTING;
      $db->upd($entry,{state=>$s});
      # prevent race -- start the signal handler before forking
      Event->signal
      (
	desc=>"_sigchld_${tag}_$elevel",
	signal=>'CHLD',
	cb=>\&_sigchld,
	prio=>PCHLD,
	repeat=>1,
	data=>[$self,$entry]
      );
      my $childpid;
      unless ($childpid = fork())
      {
	# child
	# prevent race -- wait for SIGCONT from parent
	debug "waiting for SIGCONT: $tag";
	kill 19, $$;
	debug "$tag exec $cmd\n";
	exec($cmd);
	die $!;
      }
      # parent
      $s|=RUNNING;
      $db->upd($entry,{state=>$s,rc=>undef,pid=>$childpid});
      debug "sending $tag SIGCONT";
      kill 18, $childpid;
      debug "$childpid forked: $tag: $cmd\n";
      last;
    };

    (CONFIGURED | STARTING | RUNNING) == $s && do
    {
      $db->upd($entry,{state=>RUNNING});
      last;
    };

    RUNNING == $s && do {last};

    (CONFIGURED | SHUTDOWN) == $s && do
    {
      # all done
      # $db->del($entry);
      $e->w->stop();
      last;
    };

    (CONFIGURED | STARTING | RUNNING | SHUTDOWN) == $s && do
    {
      $self->_kill($entry);
      last;
    };

    (KILLED | REMOVED) & $s && do
    {
      affirm { kill(0,$entry->{pid}) == 0 };
      $db->del($entry);
      $e->w->cancel();
      last;
    };

    (REMOVED & $s) && do
    {
      # we've been removed -- kill the process
      $self->_kill($entry);
      last;
    };

    KILLED & $s && do
    {
      affirm { kill(0,$entry->{pid}) == 0 };
      if ($newlevel eq ":::SHUTDOWN:::")
      {
	$db->upd($entry,{state=>SHUTDOWN});
	last;
      }
      $db->upd($entry,{state=>CONFIGURED});
    };

    EXITED & $s && do
    {
      affirm { kill(0,$entry->{pid}) == 0 };
      for ($mode)
      {
	/^wait$/    && do { $db->upd($entry,{state=>DONE}) };
	/^once$/    && do { $db->upd($entry,{state=>DONE}) };
	/^respawn$/ && do { $db->upd($entry,{state=>CONFIGURED}) };
	/^test$/    && do 
	{ 
	  my $rc=$entry->{rc};
	  debug "$pid got rc $rc";
	  my $state=$rc ? FAILED : PASSED;
	  $db->upd($entry,{state=>$state}) 
	};
      }
      affirm { $entry->{state} != EXITED };

      last;
    };

    (DONE | PASSED | FAILED) & $s && do 
    {
      if ($newlevel eq ":::SHUTDOWN:::")
      {
	$db->upd($entry,{state=>SHUTDOWN});
	last;
      }
      last if $newlevel eq $level;
      $db->upd($entry,{state=>CONFIGURED});
      last;
    };

    SHUTDOWN == $s && do
    {
      last;
    };

    die "unknown state $s in ".$entry->{tag};
    
  }
}

sub byline
{
  $a->{line} <=> $b->{line};
}

sub _stacktrace
{
  my $out="";
  for (my $i=1;;$i++)
  {
    my @frame = caller($i);
    last unless @frame;
    $out .= "$frame[3] $frame[1] line $frame[2]\n";
  }
  return $out;
}

sub _writestat
{
  my $e=shift;
  my $self=$e->w->data;
  my $db = $self->{db};
  # debug "in _writestat";
  return unless $self->conf('clstat');
  my $clstat = $self->conf('clstat');
  my $tmp = "$clstat.".time();
  # for my $group (keys %{$self->{'status'}})
  store($db,$tmp) || die $!;
  rename($tmp,$clstat) || die $!;
}

sub _shutdown
{
  my $self=shift;
  my $db=$self->{db};
  for my $summary ($db->get({type=>'summary'}))
  {
    # tell each group to go away
    my $group = $summary->{group};
    affirm { $group };
    $self->_tellgroup($group,":::SHUTDOWN:::");
    debug "done telling";
  }
  my $w = Event->timer
  (
    desc=>'_halt',
    at=>time+1,
    interval=>1,
    cb=>\&_halt,
    prio=>0,
    data=>$self
  );
  $w->now();
}

sub _halt
{
  my $e=shift;
  my $self=$e->w->data;
  my $db=$self->{db};
  debug "halting";
  for my $summary ($db->get({type=>'summary'}))
  {
    my $group = $summary->{group};
    my $level = $summary->{level};
    debug "$group level is $level";
    if ($summary->{level} ne ":::SHUTDOWN:::")
    {
      $self->_tellgroup($group,":::SHUTDOWN:::");
    debug "done telling again";
      return 1;
    }
  }
  debug "unlooping";
  unloop_all(SHUTDOWN);
}

sub _kill
{
  my $self = shift;
  my $entry = shift;
  my $tag = $entry->{tag};
  my $pid = $entry->{pid};
  debug "killing $tag";
  my $i=0;
  for my $sig (2,15,9)
  {
    Event->timer
    (
      desc=>'__kill',
      at=>time+$i,
      interval=>10,
      cb=>\&__kill,
      prio=>PKILL,
      data=>[$self,$entry,$sig]
    );
    $i+=10;
  }
}

sub __kill
{
  my $e=shift;
  my $self=$e->w->data->[0];
  my $db=$self->{db};
  my $entry=$e->w->data->[1];
  my $sig=$e->w->data->[2];
  my $tag = $entry->{tag};
  my $pid = $entry->{pid};
  my $state = $entry->{state};
  unless ($pid)
  {
    $e->w->stop;
    return;
  }
  unless (kill(0,$pid))
  {
    debug "killed $pid\n";
    $db->upd($entry,{pid=>0,state=>($state|=KILLED)});
    $e->w->stop;
    return;
  }
  debug "killing $pid with $sig\n";
  kill($sig,$pid);
  my $sigbit;
  $sigbit = KILL2  if $sig == 2;
  $sigbit = KILL9  if $sig == 9;
  $sigbit = KILL15 if $sig == 15;
  $db->upd($entry,{state=>($state|=$sigbit)});
}

sub _sigchld
{
  my $e=shift;
  my $self=$e->w->data->[0];
  my $entry=$e->w->data->[1];
  my $db=$self->{db};
  # debug dump($self);
  # debug "got _sigchld in\n". _stacktrace;
  debug "got _sigchld in ".$entry->{tag};
  my $pid = $entry->{pid};
  affirm { $pid };
  my $waitpid = waitpid($pid, &WNOHANG);
  my $rc = $?;
  # debug "waitpid returned: $waitpid\n";
  affirm { $waitpid != -1 };
  unless (kill(0,$waitpid) == 0)
  {
    # still running -- false alarm
    debug $entry->{tag}." false alarm";
    return;
  }
  affirm { $pid == $waitpid };
  # $pid exited
  debug "$pid returned $rc";
  my $state=$entry->{state}|EXITED;
  $db->upd($entry,{state=>$state,rc=>$rc});
  $e->w->stop;
}


=head1 BUGS

=head1 AUTHOR

	Steve Traugott
	CPAN ID: STEVEGT
	stevegt@TerraLuna.Org
	http://www.stevegt.com

=head1 COPYRIGHT

Copyright (c) 2003 Steve Traugott. All rights reserved.
This program is free software; you can redistribute
it and/or modify it under the same terms as Perl itself.

The full text of the license can be found in the
LICENSE file included with this module.

=head1 SEE ALSO

perl(1).

=cut

1; 

__END__


