Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
- Loading branch information
Showing
6 changed files
with
151 additions
and
2 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -1,5 +1,41 @@ | ||
use strict; | ||
use warnings; | ||
package GID; | ||
|
||
use Import::Into; | ||
use Package::Stash; | ||
|
||
use Path::Class (); | ||
use Carp (); | ||
use File::ShareDir (); | ||
use File::Copy::Recursive (); | ||
use File::Remove (); | ||
use List::MoreUtils (); | ||
use Scalar::Util (); | ||
|
||
sub import { | ||
my $target = scalar caller; | ||
|
||
Path::Class->import::into($target,qw( file dir )); | ||
Carp->import::into($target,qw( confess croak carp )); | ||
File::ShareDir->import::into($target,qw( dist_dir class_dir )); | ||
File::Copy::Recursive->import::into($target,qw( dircopy )); | ||
File::Remove->import::into($target,qw( remove )); | ||
List::MoreUtils->import::into($target,qw( | ||
any all none notall firstidx first_index lastidx last_index | ||
insert_after insert_after_string apply indexes after_incl | ||
before_incl firstval first_value lastval last_value each_array | ||
each_arrayref pairwise natatime mesh zip uniq distinct minmax part | ||
)); | ||
Scalar::Util->import::into($target,qw( | ||
blessed dualvar isweak readonly | ||
refaddr reftype tainted weaken isvstring looks_like_number | ||
set_prototype | ||
)); | ||
my $stash = Package::Stash->new($target); | ||
|
||
$stash->add_symbol('&env',sub { | ||
my $key = join('_',@_); | ||
return defined $ENV{$key} ? $ENV{$key} : ""; | ||
}); | ||
} | ||
|
||
1; |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,57 @@ | ||
package GID::Class; | ||
# ABSTRACT: Making your classes in GID | ||
|
||
use Package::Stash; | ||
use Import::Into; | ||
use Scalar::Util qw( blessed ); | ||
|
||
use GID (); | ||
use Moo (); | ||
use MooX (); | ||
|
||
sub import { | ||
shift; | ||
my $target = scalar caller; | ||
|
||
GID->import::into($target,@_); | ||
|
||
my $stash = Package::Stash->new($target); | ||
my @gid_methods = $stash->list_all_symbols('CODE'); | ||
|
||
MooX->import::into($target,qw( | ||
ClassStash | ||
HasEnv | ||
Options | ||
)); | ||
|
||
$target->can('extends')->('GID::Object'); | ||
|
||
$target->class_stash->around_method('has',sub { | ||
my $has = shift; | ||
my $attribute_arg = shift; | ||
my @attribute_args = @_; | ||
my @attributes = ref $attribute_arg eq 'ARRAY' ? @{$attribute_arg} : ($attribute_arg); | ||
for (@attributes) { | ||
my $attribute = $_; | ||
if (grep { $attribute eq $_ } @gid_methods) { | ||
my $gid_method = $target->class_stash->get_method($attribute); | ||
$target->class_stash->remove_method($attribute); | ||
$has->($attribute,@attribute_args); | ||
$target->class_stash->around_method($attribute,sub { | ||
my $attribute_method = shift; | ||
my @args = @_; | ||
if (blessed $args[0]) { | ||
return $attribute_method->(@args); | ||
} else { | ||
return $gid_method->(@args); | ||
} | ||
}); | ||
} else { | ||
$has->($attribute,@attribute_args); | ||
} | ||
} | ||
}); | ||
|
||
} | ||
|
||
1; |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,6 @@ | ||
package GID::Object; | ||
# ABSTRACT: Base class for GID::Class objects | ||
|
||
use Moo; | ||
|
||
1; |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,38 @@ | ||
#!/usr/bin/env perl | ||
use strict; | ||
use warnings; | ||
use Test::More; | ||
|
||
{ | ||
package GIDTest::Class; | ||
use GID::Class; | ||
|
||
has last_index => ( is => 'rw' ); | ||
|
||
sub test_last_index { | ||
return last_index { $_ eq 1 } ( 1,1,1,1 ); | ||
} | ||
} | ||
|
||
{ | ||
package GIDTest::Class2; | ||
use GID::Class; | ||
extends 'GIDTest::Class'; | ||
} | ||
|
||
my $t = GIDTest::Class->new( last_index => 1 ); | ||
|
||
is($t->last_index,1,'last_index is set proper via constructor'); | ||
isa_ok($t,'GID::Object'); | ||
isa_ok($t,'Moo::Object'); | ||
$t->last_index(2); | ||
is($t->last_index,2,'last_index is changed proper'); | ||
is($t->test_last_index,3,'gid last_index still works fine'); | ||
|
||
my $t2 = GIDTest::Class->new; | ||
|
||
isa_ok($t2,'GIDTest::Class'); | ||
isa_ok($t2,'GID::Object'); | ||
isa_ok($t2,'Moo::Object'); | ||
|
||
done_testing; |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,8 @@ | ||
#!/usr/bin/env perl | ||
use strict; | ||
use warnings; | ||
use Test::LoadAllModules; | ||
|
||
BEGIN { | ||
all_uses_ok( search_path => 'GID' ); | ||
} |