Sub-Exporter-0.987HEADSub-Exporter-0.987master

6 files changed, 273 insertions, 0 deletions

diff --git a/t/lib/Test/SubExporter/DashSetup.pm b/t/lib/Test/SubExporter/DashSetup.pm
new file mode 100644
index 0000000..3425322
--- /dev/null
+++ b/t/lib/Test/SubExporter/DashSetup.pm
@@ -0,0 +1,35 @@
+#!perl
+package Test::SubExporter::DashSetup;
+
+use strict;
+use warnings;
+
+use Sub::Exporter -setup => {
+  exports => {
+    xyzzy        => undef,
+    hello_sailor => \&_hs_gen,
+  },
+  groups => {
+    default => [ qw(xyzzy hello_sailor) ],
+    sailor  => [
+      xyzzy => undef,
+      hello_sailor => { -as => 'hs_works', game => 'zork3' },
+      hello_sailor => { -as => 'hs_fails', game => 'zork1' },
+    ]
+  },
+  collectors => [ 'defaults' ],
+};
+
+sub xyzzy { return "Nothing happens." };
+
+sub _hs_gen {
+  my ($class, $name, $arg, $collection) = @_;
+
+  if (($arg->{game}||'') eq 'zork3') {
+    return sub { return "Something happens!" };
+  } else {
+    return sub { return "Nothing happens yet." };
+  }
+}
+
+"y2";
diff --git a/t/lib/Test/SubExporter/Faux.pm b/t/lib/Test/SubExporter/Faux.pm
new file mode 100644
index 0000000..a4332e8
--- /dev/null
+++ b/t/lib/Test/SubExporter/Faux.pm
@@ -0,0 +1,67 @@
+
+use strict;
+use warnings;
+package Test::SubExporter::Faux;
+
+use base qw(Exporter);
+
+our @EXPORT = qw(faux_installer exports_ok everything_ok);
+
+sub faux_installer {
+  my ($verbose) = @_;
+  $verbose = 1;
+
+  my @exported;
+
+  my $reset = sub { @exported = () };
+
+  my $generator = sub {
+    my ($arg) = @_;
+    # my ($class, $name, $generator) = @$arg{qw(class name generator)};
+
+    return $arg;
+  };
+
+  my $installer  = sub {
+    my ($arg, $to_export) = @_;
+
+    for (my $i = 0; $i < @$to_export; $i += 2) {
+      my ($as, $gen_arg) = @$to_export[ $i, $i+1 ];
+
+      # my ($class, $generator, $name, $arg, $collection, $as, $into) = @_;
+      my $everything = {
+        class      => $gen_arg->{class},
+        generator  => $gen_arg->{generator},
+        name       => $gen_arg->{name},
+        arg        => $gen_arg->{arg},
+        collection => $gen_arg->{col},
+        as         => $as,
+        into       => $arg->{into},
+      };
+
+      push @exported, [
+        $gen_arg->{name},
+        ($verbose ? $everything : $gen_arg->{arg}),
+      ];
+    }
+  };
+
+  return ($generator, $installer, $reset, \@exported);
+}
+
+sub exports_ok {
+  my ($got, $expected, $comment) = @_;
+  my $got_simple = [ map { [ $_->[0], $_->[1]{arg} ] } @$got ];
+  my @g = sort { ($a->[0] cmp $b->[0]) || ($a->[1] <=> $b->[1]) } @$got_simple;
+  my @e = sort { ($a->[0] cmp $b->[0]) || ($a->[1] <=> $b->[1]) } @$expected;
+  main::is_deeply(\@e, \@g, $comment);
+}
+
+sub everything_ok {
+  my ($got, $expected, $comment) = @_;
+  my @g = sort { ($a->[0] cmp $b->[0]) || ($a->[1] <=> $b->[1]) } @$got;
+  my @e = sort { ($a->[0] cmp $b->[0]) || ($a->[1] <=> $b->[1]) } @$expected;
+  main::is_deeply(\@e, \@g, $comment);
+}
+
+1;
diff --git a/t/lib/Test/SubExporter/GroupGen.pm b/t/lib/Test/SubExporter/GroupGen.pm
new file mode 100644
index 0000000..be95112
--- /dev/null
+++ b/t/lib/Test/SubExporter/GroupGen.pm
@@ -0,0 +1,57 @@
+#!perl
+package Test::SubExporter::GroupGen;
+
+use strict;
+use warnings;
+
+use Sub::Exporter;
+
+my $alfa  = sub { 'alfa'  };
+my $bravo = sub { 'bravo' };
+
+my $returner = sub {
+  my ($class, $group, $arg, $collection) = @_;
+
+  my %given = (
+    class => $class,
+    group => $group,
+    arg   => $arg,
+    collection => $collection,
+  );
+
+  return {
+    foo => sub { return { name => 'foo', %given }; },
+    bar => sub { return { name => 'bar', %given }; },
+  };
+};
+
+sub gen_group_by_name {
+  my ($class, $group, $arg, $collection) = @_;
+
+  my %given = (
+    class => $class,
+    group => $group,
+    arg   => $arg,
+    collection => $collection,
+  );
+
+  return {
+    baz => sub { return { name => 'baz', %given }; },
+  };
+}
+
+my $config = {
+  exports => [ ],
+  groups  => {
+    alphabet  => sub { { a => $alfa, b => $bravo } },
+    generated => $returner,
+    # symbolic  => \&gen_group_by_name,
+    # symbolic  => sub { shift->gen_group_by_name(@_) },
+    symbolic  => \'gen_group_by_name',
+  },
+  collectors => [ 'col1' ],
+};
+
+Sub::Exporter::setup_exporter($config);
+
+"gg";
diff --git a/t/lib/Test/SubExporter/GroupGenSubclass.pm b/t/lib/Test/SubExporter/GroupGenSubclass.pm
new file mode 100644
index 0000000..7e34c97
--- /dev/null
+++ b/t/lib/Test/SubExporter/GroupGenSubclass.pm
@@ -0,0 +1,22 @@
+use strict;
+use warnings;
+
+package Test::SubExporter::GroupGenSubclass;
+use base qw(Test::SubExporter::GroupGen);
+
+sub gen_group_by_name {
+  my ($class, $group, $arg, $collection) = @_;
+
+  my %given = (
+    class => $class,
+    group => $group,
+    arg   => $arg,
+    collection => $collection,
+  );
+
+  return {
+    baz => sub { return { name => 'baz-sc', %given }; },
+  };
+}
+
+"power overwhelming";
diff --git a/t/lib/Test/SubExporter/ObjGen.pm b/t/lib/Test/SubExporter/ObjGen.pm
new file mode 100644
index 0000000..845d4b4
--- /dev/null
+++ b/t/lib/Test/SubExporter/ObjGen.pm
@@ -0,0 +1,54 @@
+#!perl
+package Test::SubExporter::ObjGen::Obj;
+
+use strict;
+use warnings;
+
+sub new {
+  my $class = shift;
+  my $code  = $class->can(shift);
+
+  bless { code => $code } => $class;
+}
+
+sub group {
+  return {
+    foo => sub { return 'FOO' },
+    bar => sub { return 'BAR' },
+  };
+}
+
+sub baz {
+  return sub {
+    return 'BAZ';
+  };
+}
+
+use overload
+  '&{}'  => sub { $_[0]->{code} },
+  'bool' => sub { 1 };
+
+package Test::SubExporter::ObjGen;
+
+my ($group_o, $group_b, $baz, $quux);
+BEGIN {
+  $quux  = sub { sub { 'QUUX' } };
+  bless $quux => 'Test::SubExporter::Whatever';
+
+  $group_o = sub { return {
+    ringo   => sub { 'starr' },
+    richard => sub { 'starkey' },
+  } };
+  bless $group_o => 'Test::SubExporter::Whatever';
+
+  $baz     = Test::SubExporter::ObjGen::Obj->new('baz');
+  $group_b = Test::SubExporter::ObjGen::Obj->new('group');
+}
+
+use Sub::Exporter -setup => {
+  exports => { baz  => $baz, quux => $quux },
+  groups  => { meta => $group_b, ringo => $group_o },
+};
+  
+
+"call me";
diff --git a/t/lib/Test/SubExporter/s_e.pm b/t/lib/Test/SubExporter/s_e.pm
new file mode 100644
index 0000000..64c9932
--- /dev/null
+++ b/t/lib/Test/SubExporter/s_e.pm
@@ -0,0 +1,38 @@
+#!perl
+package Test::SubExporter::s_e;
+
+use strict;
+use warnings;
+
+use Sub::Exporter;
+
+Sub::Exporter::setup_exporter({
+  exports => {
+    xyzzy        => undef,
+    hello_sailor => \&_hs_gen,
+    hi_sailor    => \"_hs_gen",
+  },
+  groups => {
+    default => [ qw(xyzzy hello_sailor) ],
+    sailor  => [
+      xyzzy => undef,
+      hello_sailor => { -as => 'hs_works', game => 'zork3' },
+      hello_sailor => { -as => 'hs_fails', game => 'zork1' },
+    ]
+  },
+  collectors => [ 'defaults' ],
+});
+
+sub xyzzy { return "Nothing happens." };
+
+sub _hs_gen {
+  my ($class, $name, $arg, $collection) = @_;
+
+  if (($arg->{game}||'') eq 'zork3') {
+    return sub { return "Something happens!" };
+  } else {
+    return sub { return "Nothing happens yet." };
+  }
+}
+
+"y2";