package Evo::Base;

use strict;
use warnings;
use utf8;
use feature ();

# No imports because we get subclassed, a lot!
use Carp ();

# Only Perl 5.14+ requires it on demand
use IO::Handle ();

# Protect subclasses using AUTOLOAD
sub DESTROY { }

sub import {
  my $class = shift;
  return unless my $flag = shift;

  # Base
  if ($flag eq '-base') { $flag = $class }

  # Strict
  elsif ($flag eq '-strict') { $flag = undef }

  # Module
  elsif ((my $file = $flag) && !$flag->can('new')) {
    $file =~ s!::|'!/!g;
    ## no critic
    require "$file.pm";
  }

  # ISA
  if ($flag) {
    my $caller = caller;
    ## no critic
    no strict 'refs';
    push @{"${caller}::ISA"}, $flag;
    *{"${caller}::has"} = sub { attr($caller, @_) };
  }

  # Evo modules are strict and use cool features
  $_->import for qw(strict warnings utf8);
  feature->import(':5.20', 'signatures', 'postderef');
  warnings->unimport('experimental::signatures', 'experimental::postderef');
}

sub attr {
  my ($self, $attrs, $default) = @_;
  return unless (my $class = ref $self || $self) && $attrs;

  Carp::croak 'Default has to be a code reference or constant value'
    if ref $default && ref $default ne 'CODE';

  for my $attr (@{ref $attrs eq 'ARRAY' ? $attrs : [$attrs]}) {
    Carp::croak qq{Attribute "$attr" invalid} unless $attr =~ /^[a-zA-Z_]\w*$/;

    # Header (check arguments)
    my $code = "package $class;\nsub $attr {\n  if (\@_ == 1) {\n";

    # No default value (return value)
    unless (defined $default) { $code .= "    return \$_[0]{'$attr'};" }

    # Default value
    else {

      # Return value
      $code .= "    return \$_[0]{'$attr'} if exists \$_[0]{'$attr'};\n";

      # Return default value
      $code .= "    return \$_[0]{'$attr'} = ";
      $code .= ref $default eq 'CODE' ? '$default->($_[0]);' : '$default;';
    }

    # Footer (store value and return invocant)
    $code .= "\n  }\n  \$_[0]{'$attr'} = \$_[1];\n  \$_[0];\n}";

    warn "-- Attribute $attr in $class\n$code\n\n" if $ENV{MOJO_BASE_DEBUG};
    ## no critic
    Carp::croak "Evo::Base error: $@" unless eval "$code;1";
  }
}

sub new {
  my $class = shift;
  bless @_ ? @_ > 1 ? {@_} : {%{$_[0]}} : {}, ref $class || $class;
}

sub tap {
  my ($self, $cb) = (shift, shift);
  $_->$cb(@_) for $self;
  return $self;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Evo::Base

=head1 VERSION

version 0.009

=head1 SYNOPSIS

  package Cat;
  use Evo::Base -base;

  has name => 'Nyan';
  has [qw(birds mice)] => 2;

  package Tiger;
  use Evo::Base 'Cat';

  has friend  => sub { Cat->new };
  has stripes => 42;

  package main;
  use Evo::Base -strict;

  my $mew = Cat->new(name => 'Longcat');
  say $mew->mice;
  say $mew->mice(3)->birds(4)->mice;

  my $rawr = Tiger->new(stripes => 23, mice => 0);
  say $rawr->tap(sub { $_->friend->name('Tacgnol') })->mice;

=head1 DESCRIPTION

L<Evo::Base> is a simple base class for L<Evo> projects.

  # Automatically enables "strict", "warnings", "utf8" and Perl 5.10 features
  use Evo::Base -strict;
  use Evo::Base -base;
  use Evo::Base 'SomeBaseClass';

All three forms save a lot of typing.

  # use Evo::Base -strict;
  use strict;
  use warnings;
  use utf8;
  use feature (':5.20');
  use experimental qw(signatures postderef);

  use IO::Handle ();

  # use Evo::Base -base;
  use strict;
  use warnings;
  use utf8;
  use feature (':5.20');
  use experimental qw(signatures postderef);
  use IO::Handle ();
  use Evo::Base;
  push @ISA, 'Evo::Base';
  sub has { Evo::Base::attr(__PACKAGE__, @_) }

  # use Evo::Base 'SomeBaseClass';
  use strict;
  use warnings;
  use utf8;
  use feature (':5.20');
  use experimental qw(signatures postderef);
  use IO::Handle ();
  require SomeBaseClass;
  push @ISA, 'SomeBaseClass';
  use Evo::Base;
  sub has { Evo::Base::attr(__PACKAGE__, @_) }

=head1 NAME

Evo::Base - Minimal base class. Almost copypast from L<Mojo::Base>
Will be changed to Moo in the future

=head1 FUNCTIONS

L<Evo::Base> implements the following functions, which can be imported with
the C<-base> flag or by setting a base class.

=head2 has

  has 'name';
  has [qw(name1 name2 name3)];
  has name => 'foo';
  has name => sub {...};
  has [qw(name1 name2 name3)] => 'foo';
  has [qw(name1 name2 name3)] => sub {...};

Create attributes for hash-based objects, just like the L</"attr"> method.

=head1 METHODS

L<Evo::Base> implements the following methods.

=head2 attr

  $object->attr('name');
  SubClass->attr('name');
  SubClass->attr([qw(name1 name2 name3)]);
  SubClass->attr(name => 'foo');
  SubClass->attr(name => sub {...});
  SubClass->attr([qw(name1 name2 name3)] => 'foo');
  SubClass->attr([qw(name1 name2 name3)] => sub {...});

Create attribute accessor for hash-based objects, an array reference can be
used to create more than one at a time. Pass an optional second argument to
set a default value, it should be a constant or a callback. The callback will
be executed at accessor read time if there's no set value. Accessors can be
chained, that means they return their invocant when they are called with an
argument.

=head2 new

  my $object = SubClass->new;
  my $object = SubClass->new(name => 'value');
  my $object = SubClass->new({name => 'value'});

This base class provides a basic constructor for hash-based objects. You can
pass it either a hash or a hash reference with attribute values.

=head2 tap

  $object = $object->tap(sub {...});
  $object = $object->tap($method);
  $object = $object->tap($method, @args);

K combinator, tap into a method chain to perform operations on an object
within the chain. The object will be the first argument passed to the callback
and is also available as C<$_>.

  # Longer version
  $object = $object->tap(sub { $_->$method(@args) });

  # Inject side effects into a method chain
  $object->foo('A')->tap(sub { say $_->foo })->foo('B');

=head1 DEBUGGING

You can set the C<MOJO_BASE_DEBUG> environment variable to get some advanced
diagnostics information printed to C<STDERR>.

  MOJO_BASE_DEBUG=1

=head1 SEE ALSO

L<Mojolicious>

=head1 AUTHOR

alexbyk.com

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2015 by alexbyk.

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

=cut
