File Coverage

blib/lib/Jojo/Base.pm

Criterion	Covered	Total	%
statement	83	85	97.6
branch	18	18	100.0
condition	6	9	66.6
subroutine	19	19	100.0
pod	1	2	50.0
total	127	133	95.4

package Jojo::Base;
$Jojo::Base::VERSION = '0.7.0';
# ABSTRACT: Mojo::Base + lexical "has"
use 5.018;
use strict;
use warnings;
use utf8;
use feature      ();
use experimental ();

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

use Carp       ();
use Mojo::Util ();
use Sub::Inject 0.2.0 ();

use constant ROLES =>
  !!(eval { require Jojo::Role; Jojo::Role->VERSION('0.5.0'); 1 });

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

our %EXPORT_TAGS;
our %EXPORT_GEN;

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

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

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

  # Role
  elsif ($flag eq '-role') {
    Carp::croak 'Jojo::Role 0.5.0+ is required for roles' unless ROLES;
    Jojo::Role->make_role($caller);
  }

  # Module
  elsif (($base = $flag) && ($flag = '-base') && !$base->can('new')) {
    require(Mojo::Util::class_to_path($base));
  }

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

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

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

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

sub role_provider {'Jojo::Role'}

sub with_roles {
  Carp::croak 'Jojo::Role 0.5.0+ is required for roles' unless ROLES;
  my ($self, @roles) = @_;

  return Jojo::Role->create_class_with_roles($self, @roles)
    unless my $class = Scalar::Util::blessed $self;

  return Jojo::Role->apply_roles_to_object($self, @roles);
}

BEGIN {
  %EXPORT_TAGS = (-base => [qw(has with)], -role => [qw(has)], -strict => [],);

  %EXPORT_GEN = (
    has => sub {
      my (undef, $target) = @_;
      return sub { Mojo::Base::attr($target, @_) }
    },
    with => sub {    # dummy
      return sub { Carp::croak 'Jojo::Role 0.5.0+ is required for roles' }
    },
  );

  return unless ROLES;

  push @{$EXPORT_TAGS{-role}}, @{$Jojo::Role::EXPORT_TAGS{-role}};

  $EXPORT_GEN{$_} = $Jojo::Role::EXPORT_GEN{$_}
    for @{$Jojo::Role::EXPORT_TAGS{-role}};
}

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 Jojo::Base -base;    # requires perl 5.18+
#pod
#pod     has name => 'Nyan';
#pod     has ['age', 'weight'] => 4;
#pod   }
#pod
#pod   package Tiger {
#pod     use Jojo::Base 'Cat';
#pod
#pod     has friend => sub { Cat->new };
#pod     has stripes => 42;
#pod   }
#pod
#pod   package main;
#pod   use Jojo::Base -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 kind of like L but C is imported
#pod as lexical subroutine.
#pod
#pod L, like L, is a simple base class designed
#pod to be effortless and powerful.
#pod
#pod   # Enables "strict", "warnings", "utf8" and Perl 5.18 and "lexical_subs" features
#pod   use Jojo::Base -strict;
#pod   use Jojo::Base -base;
#pod   use Jojo::Base 'SomeBaseClass';
#pod   use Jojo::Base -role;
#pod
#pod All four forms save a lot of typing. Note that role support depends on
#pod L (0.5.0+).
#pod
#pod   # use Jojo::Base -strict;
#pod   use strict;
#pod   use warnings;
#pod   use utf8;
#pod   use feature ':5.18';
#pod   use experimental 'lexical_subs';
#pod   use IO::Handle ();
#pod
#pod   # use Jojo::Base -base;
#pod   use strict;
#pod   use warnings;
#pod   use utf8;
#pod   use feature ':5.18';
#pod   use experimental 'lexical_subs';
#pod   use IO::Handle ();
#pod   push @ISA, 'Jojo::Base';
#pod   state sub has { ... }    # attributes
#pod   state sub with { ... }   # role composition
#pod
#pod   # use Jojo::Base 'SomeBaseClass';
#pod   use strict;
#pod   use warnings;
#pod   use utf8;
#pod   use feature ':5.18';
#pod   use experimental 'lexical_subs';
#pod   use IO::Handle ();
#pod   require SomeBaseClass;
#pod   push @ISA, 'SomeBaseClass';
#pod   state sub has { ... }    # attributes
#pod   state sub with { ... }   # role composition
#pod
#pod   # use Jojo::Base -role;
#pod   use strict;
#pod   use warnings;
#pod   use utf8;
#pod   use feature ':5.18';
#pod   use experimental 'lexical_subs';
#pod   use IO::Handle ();
#pod   use Jojo::Role;
#pod   state sub has { ... }    # attributes
#pod
#pod On Perl 5.20+ you can also append a C<-signatures> flag to all four forms and
#pod enable support for L.
#pod
#pod   # Also enable signatures
#pod   use Jojo::Base -strict, -signatures;
#pod   use Jojo::Base -base, -signatures;
#pod   use Jojo::Base 'SomeBaseClass', -signatures;
#pod   use Jojo::Base -role, -signatures;
#pod
#pod This will also disable experimental warnings on versions of Perl where this
#pod feature was still experimental.
#pod
#pod =head2 DIFFERENCES FROM C
#pod
#pod =over 4
#pod
#pod =item *
#pod
#pod All functions are exported as lexical subs
#pod
#pod =item *
#pod
#pod Role support depends on L instead of L
#pod
#pod =item *
#pod
#pod C is exported alongside C (when L is available)
#pod
#pod =item *
#pod
#pod Feature bundle for Perl 5.18 is enabled by default, instead of 5.10
#pod
#pod =item *
#pod
#pod Support for L is enabled
#pod by default
#pod
#pod =back
#pod
#pod =head1 FUNCTIONS
#pod
#pod L implements the following functions, which can be imported with
#pod the C<-base> flag, or by setting a base class.
#pod
#pod =head2 has
#pod
#pod   has 'name';
#pod   has ['name1', 'name2', 'name3'];
#pod   has name => 'foo';
#pod   has name => sub {...};
#pod   has ['name1', 'name2', 'name3'] => 'foo';
#pod   has ['name1', 'name2', 'name3'] => sub {...};
#pod
#pod Create attributes for hash-based objects, just like the L method.
#pod
#pod =head2 with
#pod
#pod   with 'SubClass::Role::One';
#pod   with '+One', '+Two';
#pod
#pod Composes the current package with one or more L roles.
#pod For roles following the naming scheme C you
#pod can use the shorthand C<+RoleName>. Note that role support depends on
#pod L (0.5.0+).
#pod
#pod It works with L or L roles.
#pod
#pod =head1 METHODS
#pod
#pod L inherits all methods from L and implements
#pod the following new ones.
#pod
#pod =head2 with_roles
#pod
#pod   my $new_class = SubClass->with_roles('SubClass::Role::One');
#pod   my $new_class = SubClass->with_roles('+One', '+Two');
#pod   $object       = $object->with_roles('+One', '+Two');
#pod
#pod Create a new class with one or more roles. If called on a class
#pod returns the new class, or if called on an object reblesses the object into the
#pod new class. For roles following the naming scheme C you
#pod can use the shorthand C<+RoleName>. Note that role support depends on
#pod L (0.5.0+).
#pod
#pod   # Create a new class with the role "SubClass::Role::Foo" and instantiate it
#pod   my $new_class = SubClass->with_roles('+Foo');
#pod   my $object    = $new_class->new;
#pod
#pod It works with L or L roles.
#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, L.
#pod
#pod =head1 ACKNOWLEDGMENTS
#pod
#pod Thanks to Sebastian Riedel and others, the authors
#pod and copyright holders of L.
#pod
#pod =cut

__END__