
package Jojo::Role;
$Jojo::Role::VERSION = '0.1.0'; # TRIAL
# ABSTRACT: Role::Tiny + lexical "with"
use 5.018;
use strict;
use warnings;

BEGIN {
  require Role::Tiny;
  Role::Tiny->VERSION('2.000005');
  our @ISA = qw(Role::Tiny);
}

use Sub::Inject 0.3.0 ();

# Aliasing of Role::Tiny symbols
BEGIN {
  *INFO           = \%Role::Tiny::INFO;
  *APPLIED_TO     = \%Role::Tiny::APPLIED_TO;
  *COMPOSED       = \%Role::Tiny::COMPOSED;
  *COMPOSITE_INFO = \%Role::Tiny::COMPOSITE_INFO;
  *ON_ROLE_CREATE = \@Role::Tiny::ON_ROLE_CREATE;

  *_getstash = \&Role::Tiny::_getstash;
}

our %INFO;
our %APPLIED_TO;
our %COMPOSED;
our %COMPOSITE_INFO;
our @ON_ROLE_CREATE;

sub import {
  my $target = caller;
  my $me     = shift;

  # Jojo modules are strict!
  $_->import for qw(strict warnings utf8);
  feature->import(':5.10');

  my @exports = qw(before after around requires with);

  my $flag = shift;
  if (!$flag) {
    $me->_become_role($target);
  }

  elsif ($flag eq '-with') {
    @exports = qw(with);
  }

  @_ = $me->_generate_subs($target, @exports);
  goto &Sub::Inject::sub_inject;
}

sub _become_role {
  my ($me, $target) = @_;
  return if $me->is_role($target);    # already exported into this package
  $INFO{$target}{is_role} = 1;

  # get symbol table reference
  my $stash = _getstash($target);

  # grab all *non-constant* (stash slot is not a scalarref) subs present
  # in the symbol table and store their refaddrs (no need to forcibly
  # inflate constant subs into real subs) with a map to the coderefs in
  # case of copying or re-use
  my @not_methods
    = map +(ref $_ eq 'CODE' ? $_ : ref $_ ? () : *$_{CODE} || ()),
    values %$stash;
  @{$INFO{$target}{not_methods} = {}}{@not_methods} = @not_methods;

  # a role does itself
  $APPLIED_TO{$target} = {$target => undef};
  foreach my $hook (@ON_ROLE_CREATE) {
    $hook->($target);
  }
  return;
}

sub _generate_subs {
  my ($me, $target) = (shift, shift);
  my %names = map { $_ => 1 } @_;
  my %subs;
  foreach my $type (qw(before after around)) {
    next unless $names{$type};
    $subs{$type} = sub {
      push @{$INFO{$target}{modifiers} ||= []}, [$type => @_];
      return;
    };
  }
  $subs{'requires'} = sub {
    push @{$INFO{$target}{requires} ||= []}, @_;
    return;
    }
    if $names{'requires'};
  $subs{'with'} = sub {
    $me->apply_roles_to_package($target, @_);
    return;
    }
    if $names{'with'};
  return \%subs;
}

1;

#pod =encoding utf8
#pod
#pod =head1 SYNOPSIS
#pod
#pod   package Some::Role {
#pod     use Jojo::Role;
#pod
#pod     sub foo {...}
#pod     sub bar {...}
#pod     around baz => sub {...};
#pod   }
#pod
#pod   package Some::Class {
#pod     use Jojo::Role -with;
#pod     with 'Some::Role';
#pod
#pod     # bar gets imported, but not foo
#pod     sub foo {...}
#pod
#pod     # baz is wrapped in the around modifier by Class::Method::Modifiers
#pod     sub baz {...}
#pod   }
#pod
#pod =head1 DESCRIPTION
#pod
#pod L<Jojo::Role> works like L<Role::Tiny> but C<with>, C<require>,
#pod C<before>, C<after> and C<around> are imported
#pod as lexical subroutines.
#pod
#pod This is a companion to L<Mojo::Bass>.
#pod
#pod =head1 SEE ALSO
#pod
#pod L<Role::Tiny>
#pod
#pod L<Mojo::Bass>.
#pod
#pod =cut

__END__

=pod

=encoding UTF-8

=head1 NAME

Jojo::Role - Role::Tiny + lexical "with"

=head1 VERSION

version 0.1.0

=head1 SYNOPSIS

  package Some::Role {
    use Jojo::Role;

    sub foo {...}
    sub bar {...}
    around baz => sub {...};
  }

  package Some::Class {
    use Jojo::Role -with;
    with 'Some::Role';

    # bar gets imported, but not foo
    sub foo {...}

    # baz is wrapped in the around modifier by Class::Method::Modifiers
    sub baz {...}
  }

=head1 DESCRIPTION

L<Jojo::Role> works like L<Role::Tiny> but C<with>, C<require>,
C<before>, C<after> and C<around> are imported
as lexical subroutines.

This is a companion to L<Mojo::Bass>.

=head1 SEE ALSO

L<Role::Tiny>

L<Mojo::Bass>.

=head1 AUTHOR

Adriano Ferreira <ferreira@cpan.org>

=head1 CONTRIBUTOR

=for stopwords Adriano Ferreira

Adriano Ferreira <a.r.ferreira@gmail.com>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2017 by Adriano Ferreira.

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
