package YAML::Base;
use strict;
use warnings;

# XXX - Prevent collision with other YAML modules while developing PlYaml
BEGIN {
    use diagnostics '-trace';
    use Data::Dumper;
    use Exporter::Heavy;
    delete $ENV{PERL5LIB};
    @INC = qw(lib);
}

##  At some point I would like to abstract this out into a generalized base
##  class. Perhaps as a Module::Compile module that injects stuff inline.

sub import {
    my ($class, $flag) = @_;
    my ($package, $module) = caller(0);

    if ($class->isa(__PACKAGE__) and
        defined $flag and
        $flag eq '-base'
    ) {
        $class->import_base($package, $module);
    }
    else {
        require Exporter;
        goto &Exporter::import;
    }
}

sub import_base {
    my ($class, $package, $module) = @_;
    no strict 'refs';
    push @{$package . '::ISA'}, $class;
    $class->import_fake($package, $module);
    $class->export_base($package);
}

sub import_fake {
    my ($class, $package, $module) = @_;
    my $inc_module = $package . '.pm';
    $inc_module =~ s/::/\//g;
    return if defined $INC{$inc_module};
    $INC{$inc_module} = $module;
}

sub export_base {
    my ($source, $target) = @_;
    no strict 'refs';
    for my $sub (map {
        /::/ ? $_ : "${source}::$_"
    } $source->EXPORT_BASE()) {
        my $name = $sub;
        $name =~ s/.*:://;
        *{$target . "::$name"} = \&$sub;
    }
}

sub new {
    my $class = shift;
    $class->dump_object(@_);
    my $self = bless {}, $class;
    $self->init(@_);
    return $self;
}

sub dump_object {
    my $class = shift;
    my $args = '(';
    while (my ($k, $v) = splice(@_, 0, 2)) {
        last unless $k;
        if (not defined $v) {
            $v = '~';
        }
        elsif (ref $v) {
            $v = '@';
        }
        elsif (length $v > 15) {
            $v = substr $v, 0, 15;
        }
        $args .= "${k}:$v,";
    }
    $args =~ s/,$//;
    $args .= ')';
#     printf "\t\t\t\t\t\t\t%s :\n%26s %s\n", (caller(2))[3], $class, $args;
    printf "%26s %s\n", $class, $args;
}

sub init {
    my $self = shift;
    while (my ($property, $value) = splice(@_, 0, 2)) {
        unless ($self->can($property)) {
            my $class = ref $self;
            Carp::confess("Class '$class' has no property '$property'");
        }
        $self->$property($value);
    }
}

sub create {
    my $self = shift;
    my $object_class = (shift) . '_class';
    my $module_name = $self->$object_class;
    eval "require $module_name";
    $self->die("Error in require $module_name - $@")
        if $@ and "$@" !~ /Can't locate/;
    return $module_name->new;
}

sub die {
    my $self = shift;
    Carp::confess(@_);
}

my %code = (
    sub_start =>
      "sub {\n",
    set_default =>
      "  \$_[0]->{%s} = %s\n    unless exists \$_[0]->{%s};\n",
    init =>
      "  return \$_[0]->{%s} = do { my \$self = \$_[0]; %s }\n" .
      "    unless \$#_ > 0 or defined \$_[0]->{%s};\n",
    return_if_get =>
      "  return \$_[0]->{%s} unless \$#_ > 0;\n",
    set =>
      "  \$_[0]->{%s} = \$_[1];\n",
    onset =>
      "  do { local \$_ = \$_[1]; my \$self = \$_[0]; %s };\n",
    sub_end => 
      "  return \$_[0]->{%s};\n}\n",
);

my $parse_arguments = sub {
    my $paired_arguments = shift || []; 
    my ($args, @values) = ({}, ());
    my %pairs = map { ($_, 1) } @$paired_arguments;
    while (@_) {
        my $elem = shift;
        if (defined $elem and defined $pairs{$elem} and @_) {
            $args->{$elem} = shift;
        }
        else {
            push @values, $elem;
        }
    }
    return wantarray ? ($args, @values) : $args;        
};

my $default_as_code = sub {
    no warnings 'once';
    require Data::Dumper;
    local $Data::Dumper::Sortkeys = 1;
    my $code = Data::Dumper::Dumper(shift);
    $code =~ s/^\$VAR1 = //;
    $code =~ s/;$//;
    return $code;
};

sub field {
    my $package = caller;
    my ($args, @values) = &$parse_arguments(
        [ qw(-package -init -onset) ],
        @_,
    );
    my ($field, $default) = @values;
    $package = $args->{-package} if defined $args->{-package};
    return if defined &{"${package}::$field"};
    my $default_string =
        ( ref($default) eq 'ARRAY' and not @$default )
        ? '[]'
        : (ref($default) eq 'HASH' and not keys %$default )
          ? '{}'
          : &$default_as_code($default);

    my $code = $code{sub_start};
    if ($args->{-init}) {
        my $fragment = $code{init};
        $code .= sprintf $fragment, $field, $args->{-init}, ($field) x 4;
    }
    $code .= sprintf $code{set_default}, $field, $default_string, $field
      if defined $default;
    $code .= sprintf $code{return_if_get}, $field;
    $code .= sprintf $code{set}, $field;
    $code .= sprintf $code{onset}, $args->{-onset}
      if defined $args->{-onset};
    $code .= sprintf $code{sub_end}, $field;

    my $sub = eval $code;
    CORE::die $@ if $@;
    no strict 'refs';
    *{"${package}::$field"} = $sub;
    return $code if defined wantarray;
}

sub _dump {
    local $Data::Dumper::Sortkeys = 1;
    local $Data::Dumper::Indent = 1;
    return Data::Dumper::Dumper(@_);
}

sub XXX {
    CORE::die _dump(@_);
}

sub WWW {
    CORE::warn _dump(@_);
    return(@_);
}

sub assert {
    Carp::confess "assert failed" unless $_[0];
}

sub throw {
    CORE::die @_;
}

sub EXPORT_BASE {
    return qw(
        YAML::Base::field
        YAML::Base::XXX
        YAML::Base::WWW
        YAML::Base::assert
        YAML::Base::throw
    );
}

1;

=head1 NAME

YAML::Base - Base Class of all YAML Components

=head1 SYNOPSIS

    package YAML::Foo;
    use strict;
    use warnings;
    use YAML::Base -base;

    field 'foo';
    field 'bar' => 'blah';

=head1 DESCRIPTION

The YAML toolset is made up of a bunch of modules that are object
oriented. All these modules inherit from YAML::Base, directly or
eventually.

In the spirit of Spiffyness (but without source filtering or
dependencies) YAML::Base provides the C<field> accessor generator to all
its subclasses. It also provides XXX for debugging with Data::Dumper
(since debugging with YAML would be a conflict of interest while
debugging YAML itself).

Additionally YAML::Base provides default C<new> and C<init> class
methods for object construction.

=head1 AUTHOR

Ingy döt Net <ingy@cpan.org>

=head1 COPYRIGHT

Copyright (c) 2006. Ingy döt Net. All rights reserved.

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

See L<http://www.perl.com/perl/misc/Artistic.html>

=cut