File Coverage

blib/lib/Mojo/Bass.pm

Criterion	Covered	Total	%
statement	56	56	100.0
branch	17	18	94.4
condition	5	7	71.4
subroutine	13	13	100.0
pod			n/a
total	91	94	96.8

package Mojo::Bass;
$Mojo::Bass::VERSION = '0.3.0'; # TRIAL
# ABSTRACT: Mojo::Base + lexical "has"
use 5.018;
use Mojo::Base -strict;

use Carp ();

BEGIN {
  our @ISA = qw(Mojo::Base);
}

use Sub::Inject 0.2.0 ();

use constant ROLES => Mojo::Base::ROLES;

use constant SIGNATURES => ($] >= 5.020);

use constant EXPORTS_FOR => {
  -base => [ROLES ? qw(has with) : qw(has)],
  -role => [qw(has)],
  -strict => [],
};

sub import {
  my ($class, $caller) = (shift, caller);
  return unless my $flag = shift;

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

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

  # Role
  elsif ($flag eq '-role') {
    Carp::croak 'Role::Tiny 2.000001+ is required for roles' unless ROLES;
    eval "package $caller; use Role::Tiny; 1" or die $@;
  }

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

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

  # Signatures (Perl 5.20+)
  if ((shift || '') eq '-signatures') {
    Carp::croak 'Subroutine signatures require Perl 5.20+' unless SIGNATURES;
    require experimental;
    experimental->import('signatures');
  }

  # ISA
  if ($base) {
    no strict 'refs';
    push @{"${caller}::ISA"}, $base;
  }

  my $exports = EXPORTS_FOR->{$flag};
  if (@$exports) {
    @_ = $class->_generate_subs($caller, @$exports);
    goto &Sub::Inject::sub_inject;
  }
}

our %EXPORT_GEN = (
  has => sub {
    my (undef, $target) = @_;
    return sub { Mojo::Base::attr($target, @_) }
  },
  with => sub {
    my (undef, $target) = @_;
    return sub { Role::Tiny->apply_roles_to_package($target, @_) }
  },
);

sub _generate_subs {
  my ($class, $target) = (shift, shift);
  return map { my $cb = $EXPORT_GEN{$_}; $_ => $class->$cb($target) } @_;
}

1;

#pod =encoding utf8
#pod
#pod =head1 SYNOPSIS
#pod
#pod   package Cat {
#pod     use Mojo::Bass -base;
#pod
#pod     has name => 'Nyan';
#pod     has ['age', 'weight'] => 4;
#pod   }
#pod
#pod   package Tiger {
#pod     use Mojo::Bass 'Cat';
#pod
#pod     has friend => sub { Cat->new };
#pod     has stripes => 42;
#pod   }
#pod
#pod   package main;
#pod   use Mojo::Bass -strict;
#pod
#pod   my $mew = Cat->new(name => 'Longcat');
#pod   say $mew->age;
#pod   say $mew->age(3)->weight(5)->age;
#pod
#pod   my $rawr = Tiger->new(stripes => 38, weight => 250);
#pod   say $rawr->tap(sub { $_->friend->name('Tacgnol') })->weight;
#pod
#pod =head1 DESCRIPTION
#pod
#pod L works like L but C is imported
#pod as lexical subroutine.
#pod
#pod =head1 CAVEATS
#pod
#pod =over 4
#pod
#pod =item *
#pod
#pod L requires perl 5.18 or newer
#pod
#pod =item *
#pod
#pod Because a lexical sub does not behave like a package import,
#pod some code may need to be enclosed in blocks to avoid warnings like
#pod
#pod     "state" subroutine &has masks earlier declaration in same scope at...
#pod
#pod =back
#pod
#pod =head1 SEE ALSO
#pod
#pod L.
#pod
#pod =cut

__END__