#!/usr/bin/perl -w

use strict;

# Crude draft of what POE scripting could look like.  This is intended as
# much as a test of munging POE::Session->create as anything else.  The
# implementation is not very nice, because it uses call(). Note, however,
# that it doesn't require aliases to keep sessions alive and instead does much
# messing around with refcount_{increment,decrement}.

# what is happening :
#   a session is created that deals with the script
#   a child session is created that contains all the states of the script
#       (and maybe more) 
#   script session either autostarts, or has a 'start'  event posted to it
#   script session then checks all the prereq coderefs (in 'step'), if they
#       return true that state is enqueued
#   script session then call()s the state (in 'do').  If it returns true,
#   it is assumed to have completed.  
#   It's postreq coderef is called and 'step' is called again
#   If it returned false, nothing is done child session posts 'done' with
#   ARG0 = state name

# BUGS : 
#   postreq MUST cancel prereq, otherwise a state is continually looped.
#   prereqs in fact means "transitions".  IE, when B goes from 0 to 1, fire
#   event state2.  How would we encode this, keeping it powerful, and not
#   fall into the "invent a new scripting language" trap?

use Carp qw(croak);

sub POE::Kernel::ASSERT_REFCOUNT () {1}
use POE;

$|++;
sub DEBUG () {0};

my($A, $B, $C, $D)=(1, 0, 0, 0);
my $some_object=SomePackage->new();

POE::Component::Script->create(
       autostart=>1,
       state1=>{inline=>sub { print "This is the inline state\n"; return 1},
                prereq=>sub {
                    DEBUG and warn "A=$A, B=$B";
                    ($A==1)..($B==1)},
                postreq=>sub {$B=1},
               },
               
       state2=>{package=>'SomePackage',
                 prereq=>sub {
                    DEBUG and warn "B=$B, C=$C";
                    ($B==1)..($C==1)},
                 postreq=>sub {$C=1},
               },
       state3=>{object=>$some_object,
                 prereq=>sub {
                    DEBUG and warn "C=$C, D=$D";
                    ($C==1)..($D==1)},
                postreq=>sub {$D=1},
               },
       package_states=>[SomePackage=>[qw(_start _signal _stop other_thing)]],
       options=>{trace=>0},
    );
$poe_kernel->run();
exit 0;


################################################################
package SomePackage;
use POE::Session;

sub new
{
    bless {object=>1}, $_[0];
}

sub _start
{
    my($kernel, $heap)=@_[KERNEL, HEAP];
#    print "_start\n";
}

sub _signal
{
    my($kernel, $arg)=@_[KERNEL, ARG0];
#    print "_signal $arg\n";
    return 0;
}

sub _stop
{
    my($kernel, $heap)=@_[KERNEL, HEAP];
#    print "_stop\n";
    return 1;
}


sub state2
{
    my($package, $ctx)=@_[OBJECT, ARG0];
    print "This is $package/state2\n";
    die "**** To many times!\n" if $ctx->{s2}++;
    $_[KERNEL]->yield('other_thing', $_[SENDER]);
    return 0;                   # not done!
}

sub other_thing
{
    # if we use post(), this session is GCed before our parent can do 
    # another batch of prereqs
    $_[KERNEL]->call($_[ARG0] => 'done', 'state2');
}

sub state3
{
    my($self, $ctx)=@_[OBJECT, ARG0];
    $self->doit($ctx);
}
sub doit
{
    my($self, $ctx)=@_;
    die "**** To many times!\n" if $ctx->{s3}++;
    print "This is $self/state3\n";
    return 1;                   # step done
}

##############################################################################
package POE::Component::Script;

use strict;
use POE::Kernel;
use POE::Session;
use Data::Dumper;

sub DEBUG () {0}

sub create
{
    my $package=shift @_;
    my %args=@_;
    
    my %create;
    foreach my $k (qw(args options heap inline_states object_states
                    package_states)) {
        next unless exists $args{$k};
        $create{$k}=delete $args{$k};
    }

    my $autostart=delete $args{autostart};
    $autostart={} if $autostart and not ref $autostart;

    my $script={};
    my %temp;
    foreach my $state (keys %args) {
        die "Please don't call your state $state" if $state=~ /^_/;

        my $args=$args{$state};
        if($args->{inline}) {
            $create{inline_states}{$state}=$args->{inline};
        } 
        elsif($args->{package}) {

            $temp{package_states}{$args->{package}}||=[$args->{package}];
            push @{$temp{package_states}{$args->{package}}}, $state;

        } 
        elsif($args->{object}) {
            $temp{object_states}{$args->{object}}||=[$args->{object}];
            push @{$temp{object_states}{$args->{object}}}, $state;
        } 
        elsif($args->{coderef}) {
            $script->{$state}{coderef}=$args->{coderef};
        }
        $script->{$state}{prereq}=$args->{prereq};
        $script->{$state}{postreq}=$args->{postreq};
    }

    foreach my $k (qw(object_states package_states)) {
        next unless $temp{$k};

        $create{$k}||=[];
        foreach my $q (values %{$temp{$k}}) {

            my $o=shift @$q;
            push @{$create{$k}}, $o, $q;
        }
    }
    
    POE::Session->create(
            args=>[\%create, $script, $autostart],
            package_states=>[
                $package=>[qw(_start _child done step shutdown start do)],
            ],
            options=>{trace=>0},
        );
}

################################################################
sub _start
{
    my($kernel, $heap, $create, $script, $autostart)=
                @_[KERNEL, HEAP, ARG0, ARG1, ARG2];

    DEBUG and warn Dumper $create;
    $heap->{script}=$script;
    $heap->{autostart}=$autostart;

    my $slave=POE::Session->create(%$create);
    return unless $slave;
    $heap->{slave}=$slave->ID;
    DEBUG and warn "Slave session: $heap->{slave}\n";

    if($heap->{autostart}) {
        DEBUG and warn "Autostarting script\n";
        $heap->{everything}=delete $heap->{autostart};
        $kernel->refcount_increment($heap->{slave}, qq(script _STEP));
        $kernel->yield('step');
    }
}

################################################################
sub start
{
    my($kernel, $heap, $first, $everything)=@_[KERNEL, HEAP, ARG0, ARG1];
    $heap->{everything}=$everything;
    if($first) {
        return unless $heap->{script}{$first};
        $kernel->refcount_increment($heap->{slave}, qq(script $first));
        $kernel->yield('do', $first);
    } 
    else {
        $kernel->refcount_increment($heap->{slave}, qq(script _STEP));
        $kernel->yield('step');
    }
    return;
}

################################################################
sub do
{
    my($kernel, $heap, $state)=@_[KERNEL, HEAP, ARG0];
    
    unless($heap->{stopped}) {
        my $script=$heap->{script}{$state};
        my $done=0;

        if($script->{$state}{coderef}) {
            DEBUG and warn "Doing coderef for $state\n";
            $done=$script->{$state}{coderef}->($heap->{everything});
        }
        else {
            DEBUG and warn "Calling $heap->{slave}/$state\n";
            $done=$kernel->call($heap->{slave}, $state, $heap->{everything});
        }

        return unless $done;

        $kernel->yield('done', $state);
    } 
    else {
        $kernel->refcount_decrement($heap->{slave}, qq(script $state)); 
    }
}

################################################################
sub done
{
    my($kernel, $heap, $state)=@_[KERNEL, HEAP, ARG0];
    $kernel->refcount_decrement($heap->{slave}, qq(script $state)); 

    my $script=$heap->{script}{$state};
    if ($script->{postreq}) {
        $@='';
        DEBUG and warn "postreq for $state";
        eval{$script->{postreq}->()};
        warn $@ if $@;
    }

    $kernel->refcount_increment($heap->{slave}, qq(script _STEP));
    $kernel->yield('step');
    return;
}

################################################################
sub step
{
    my($kernel, $heap)=@_[KERNEL, HEAP];

    $kernel->refcount_decrement($heap->{slave}, qq(script _STEP));
    return if $heap->{stopped};
    
    my @todo;

    while(my($state, $script)=each %{$heap->{script}}) {
        next unless $script->{prereq};

        $@='';
        DEBUG and warn "Trying $state\n";

        my $ret=eval { scalar $script->{prereq}->()};
        warn $@ if $@;
        DEBUG and warn "Returned $ret\n";
        my $yes;
        if($ret=~/^(\d+)E0$/) {
            $script->{bitstable}=1;
            $yes=0;
        } elsif($script->{bitstable}) {
            $yes=1;
        } elsif($ret) {
            $yes=1;
        }
        if($yes) {
            push @todo, $state;
            DEBUG and warn "OK!\n";
        }
    }
    return unless @todo;

    foreach my $state (@todo) {
        $kernel->refcount_increment($heap->{slave}, qq(script $state));
        $kernel->yield('do', $state);
    }
}


################################################################
sub shutdown
{
    my($kernel, $heap)=@_[KERNEL, HEAP];
    $heap->{stopped}=1;
    delete $heap->{script};
    delete $heap->{slave};
    delete $heap->{everything};
}

################################################################
sub _child
{
    my($kernel, $heap, $job)=@_[KERNEL, HEAP, ARG0];
    DEBUG and warn "_child $job\n";
    if($job eq 'create') {
        # what do we care?
    } elsif($job eq 'lose') {
        $kernel->yield('shutdown');
    }
}

1;