package MultiTask::Minion;
$VERSION = eval{require version}?version::qv($_):$_ for(0.10.1);

use warnings;
use strict;
use Carp;


use Class::Accessor::Classy;
rw 'on_quit';
rs 'done' => \(my $set_done);
no  Class::Accessor::Classy;

=head1 NAME

MultiTask::Minion - a worker

=head1 SYNOPSIS

=cut


=head2 new

  my $worker = MultiTask::Minion->new();

=cut

sub new {
  my $class = shift;
  my $self = {};

  my $new_class = "$self";
  {
    $new_class =~ s/HASH\(([^\)]*)\)/${class}::$1/ or
      croak("cannot transform $self into a package");
    my $isa = do { no strict 'refs'; \@{"${new_class}::ISA"}; };
    push(@$isa, $class); # You're one of us now...
  }

  bless($self, $new_class);
  return($self);
} # end subroutine new definition
########################################################################

=head2 make

Creates a new minion class, defining work() and other methods inline.

  my $worker = MultiTask::Minion->make(sub {
    return(work => sub {...})
  });

=cut

sub make {
  my $package = shift;
  my ($subref) = @_;
  ((ref($subref) || '') eq 'CODE') or croak("not a code reference");

  my $self = $package->new;
  my %atts = $subref->($self);
  foreach my $att ($self->_standard_attributes) {
    if($atts{$att}) {
      $self->_make_method($att, delete($atts{$att}));
    }
  }
  keys(%atts) and
    croak("unsupported attributes ", join(", ", keys(%atts)));
  return($self);
} # end subroutine make definition
########################################################################

=head2 _standard_attributes

  $self->_standard_attributes;

=cut

sub _standard_attributes {
  my $self = shift;
  return(qw(
    start
    work
    finish
    quit
  ));
} # end subroutine _standard_attributes definition
########################################################################

=head2 _make_method

  $self->_make_method($name, $subref);

=cut

sub _make_method {
  my $self = shift;
  my ($name, $subref) = @_;
  ($name =~ m/^[a-z_][\w]*$/i) or croak("'$name' not a valid name");

  my $class = ref($self);
  ($class =~ m/::0x/) or croak("'$class' is invalid");

  if(my $super_sub = $class->can($name)) {
    no strict 'refs';
    *{$class . '::SUPER_' . $name} = $super_sub;
  }

  no strict 'refs';
  defined(&{$class . '::' . $name}) and croak("cannot overwrite $name");
  *{$class . '::' . $name} = $subref;
} # end subroutine _make_method definition
########################################################################

=head1 Control

=head2 quit

  $minion->quit;

=cut

sub quit {
  my $self = shift;

  if(my $on_quit = $self->on_quit) {
    $on_quit->($self);
  }
  my $class = ref($self);
  if($class =~ m/::0x/) { # delete our methods
    foreach my $att ($self->_standard_attributes) {
      no strict 'refs';
      if(defined(&{$class . '::' . $att})) {
        delete(${$class . '::'}{$att});
      }
    }
  }
  $self->$set_done(1);
} # end subroutine quit definition
########################################################################

=head2 DESTROY

  $minion->DESTROY;

=cut

sub DESTROY {
  my $self = shift;
  #warn "destroy $self\n";
  delete($self->{$_}) for(keys(%$self));
  if(1) { # cleanup namespace
    my $package = ref($self);
    $package =~ m/^(.*::)([^:]+)$/ or die;
    my $parent = $1;
    my $inner = $2 . '::';
    # don't kill-off permanent packages!
    # TODO use something that's not pattern-based?
    ($inner =~ m/^0x/) or return; # warn "not destroying $package";
    my $pack;
    {
      no strict 'refs';
      $parent = \%{"$parent"};
      #$innerp = \%{"$inner"};
      $pack   = \%{"${package}::"};
    }
    #warn join(",", keys(%$parent));
    #warn join(",", keys(%$pack));
    #warn join(",", keys(%{$parent->{$inner}}));
    delete($parent->{$inner});
    #warn join(",", keys(%$parent));
  }
  return;
} # end subroutine DESTROY definition
########################################################################

=head1 AUTHOR

Eric Wilhelm <ewilhelm at cpan dot org>

http://scratchcomputing.com/

=head1 BUGS

If you found this module on CPAN, please report any bugs or feature
requests through the web interface at L<http://rt.cpan.org>.  I will be
notified, and then you'll automatically be notified of progress on your
bug as I make changes.

If you pulled this development version from my /svn/, please contact me
directly.

=head1 COPYRIGHT

Copyright (C) 2006 Eric L. Wilhelm, All Rights Reserved.

=head1 NO WARRANTY

Absolutely, positively NO WARRANTY, neither express or implied, is
offered with this software.  You use this software at your own risk.  In
case of loss, no person or entity owes you anything whatsoever.  You
have been warned.

=head1 LICENSE

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

=cut

# vi:ts=2:sw=2:et:sta
1;