package Sonema::Class;

use 5.6.0;
use strict;
use warnings;

our $AUTHOR = q{ ks.perl@kurtstephens.com 2003/02/26 };
our $VERSION = do { my @r = (q$Revision: 1.1 $ =~ /\d+/g); sprintf "%d." . "%03d" x $#r, @r };


use base 'Exporter';

our @EXPORT = qw('class');

my $classes = { };


sub new
{
  my ($self, %opts) = @_;

  $classes->{$opts{'name'}} ||= bless(\%opts, $self)->defaults->initialize;
}


sub defaults
{
  my ($self) = @_;
  
  $self;
}


sub initialize
{
  my ($self) = @_;

  $self->{'attrs'} = [ ];
  $self->{'meths'} = [ ];

  $self;
}


sub _add_attr
{
  my ($self, $attr) = @_;

  push(@{$self->{'attrs'}}, $attr);
}


sub _parse_attr
{
  my ($self, $args) = @_;
  
  while ( @$args ) {
    my $x = shift @$args;
    if ( ref($x) eq 'ARRAY' ) {
      $self->_parse_attr($x);
    }
    elsif ( ref($x) eq 'HASH' ) {
      $self->_add_attr($x);
    }
    else {
      $x = { 'name' => $x };
      $self->_add_attr($x);
      last;
    }
  }
 
  $self;
}


sub _add_meth
{
  my ($self, $x) = @_;

  push(@{$self->{'meths'}}, $x);
}



sub _parse_meth
{
  my ($self, $args) = @_;

  while ( @$args ) {
    my $x = shift @$args;
    if ( ref($x) eq 'ARRAY' ) {
      $self->_parse_meth($x);
    }
    elsif ( ref($x) eq 'HASH' ) {
      $self->_add_meth($x);
      last;
    }
    else {
      $x = { 'name' => $x };
      $x->sub = shift @$args;
      $self->_add_meth($x);
      last;
    }
  }

  $self;
}


sub _parse
{
  my ($self, $args) = @_;

  while ( @$args ) {
    my $x = shift @$args;
    if ( $x eq 'attr' ) {
      $self->_parse_attr($args);
    }
    elsif ( $x eq 'meth' ) {
      $self->_parse_meth($args);
    }
  }

  $self;
}


sub _export
{
  my ($self) = @_;

  no strict 'refs';
  my $pkg = $self->{'name'};

  for my $attr ( @{$self->{'attrs'}} ) {
    my $name = $attr->{'name'};
    my $meth = $name;

    *{"${pkg}::${meth}"} = sub {
      $_[0]->{$name};
    };

    $meth = "set_$name";
    *{"${pkg}::${meth}"} = sub {
      $_[0]->{$name} = $_[1];
    }
  }

  for my $meth ( @{$self->{'meth'}} ) {
    my $name = $meth->{'name'};
    my $meth = $meth->{'name'};
    
    *{"${pkg}::${meth}"} = $meth->{'sub'};
  }

  *{"${pkg}::new"} = \&new;
  *{"${pkg}::initialize"} = \&initialize;
  *{"${pkg}::defaults"} = \&defaults;

  $self;
}


sub class
{
  my (@args) = @_;

  my $self = __PACKAGE__->new('name' => scalar caller);

  $self->_parse(\@args);
  $self->_export;

  $self;
}


1;
