Changeset 32629

Timestamp:

04/20/09 00:23:40 (4 years ago)

Author:

ktat

Message:

fix misunderstanding feature of Sub::Exporter

Location:

lang/perl/Util-Any/trunk

Files:

• lib/Util/Any.pm (modified) (8 diffs)
• t/01-util.t (added)
• t/12-sub-exporter-like-export.t (modified) (2 diffs)
• t/lib/UtilExporter.pm (modified) (1 diff)
• t/lib/UtilSubExporter2.pm (modified) (1 diff)
• t/lib/exampleHello.pm (modified) (1 diff)

lang/perl/Util-Any/trunk/lib/Util/Any.pm

@@ -36 +36 @@
     foreach my $class (@{$config->{$kind}}) { # $class is class name or array ref
       my @funcs = @{$funcs->{$kind} || []};
-      ($class, $module_prefix, $options) = ref $class ? @$class : ($class, '', []);
+      ($class, $module_prefix, $options) = @$class if ref $class;
       $prefix = $kind_prefix                             ? $kind_prefix   :
                 ($opt{module_prefix} and $module_prefix) ? $module_prefix :
@@ -57 +57 @@
         }
         foreach my $o (grep !/^-/, keys %$options) {
-          if (defined &{$class . '::' . $o}) {
+          if (ref $options->{$o} eq 'CODE') {
+            my $gen = $options->{$o};
+            foreach my $def (@{$local_definition->{$o}}) {
+              my %arg;
+              $arg{$_} = $def->{$_}  for grep !/^-/, keys %$def;
+              ExportTo::export_to($caller => {delete $def->{-as} => $gen->($pkg, $class, $o, \%arg)});
+            }
+
+          } elsif (defined &{$class . '::' . $o}) {
             push @funcs , $o;
             $rename{$o} = $options->{$o};
@@ -66 +74 @@
       }
       $pkg->_do_export($caller, $class, \@funcs, $local_definition, \%rename, $prefix);
+    }
   }
 }
@@ -82 +91 @@
   if (%$local_definition) {
     foreach my $func (keys %$local_definition) {
-        foreach my $def (@{$local_definition->{$func}}) {
-          my $local_rename = delete $def->{-as} || '';
+      foreach my $def (@{$local_definition->{$func}}) {
+        my $local_rename = delete $def->{-as} || '';
+        unless (%$def) {
           ExportTo::export_to
               ($caller =>
                {
                 ($local_rename ? $local_rename : $prefix ? $prefix . $func : $func)
-                  => %$def ? sub { no strict 'refs'; &{$class . '::' . $func}(%$def, @_) }
-                         : $class . '::' . $func
+                              => $class . '::' . $func
                });
         }
       }
-      @export_funcs = grep !exists $local_definition->{$_}, @export_funcs;
     }
-    ExportTo::export_to($caller => ($prefix or %$rename)
-                        ? {map {($prefix . ($rename->{$_} || $_)) => $class . '::' . $_} @export_funcs}
-                        : [map $class . '::' . $_, uniq @export_funcs]);
+    @export_funcs = grep !exists $local_definition->{$_}, @export_funcs;
   }
+  ExportTo::export_to($caller => ($prefix or %$rename)
+                      ? {map {($prefix . ($rename->{$_} || $_)) => $class . '::' . $_} @export_funcs}
+                      : [map $class . '::' . $_, uniq @export_funcs]);
 }
 
 sub _insert_want_arg {
-  my ($config, $f, $setting, $want, $arg) = @_;
-  my $lf = lc $f;
-  exists $config->{$lf} ?
-    $want->{$lf} = $setting :
-    push @$arg, $f, defined $setting ? $setting : ();
+  my ($config, $kind, $setting, $want, $arg) = @_;
+  my $kind = lc $f;
+  exists $config->{$kind} ?
+    $want->{$kind} = $setting:
+    push @$arg, $kind, defined $setting ? $setting : ();
 }
 
@@ -501 +510 @@
 =head3 C<all> cannot be used for key.
 
- NG $Utils = { all => [qw/List::Util/]};
+ NG $Utils = { all    => [qw/List::Util/]};
+ NG $Utils = { -all   => [qw/List::Util/]};
+ NG $Utils = { ':all' => [qw/List::Util/]};
 
 =head3 Value is array ref which contained scalar or array ref.
@@ -589 +600 @@
 =head2 EXPORTING LIKE Sub::Exporter
 
-It's experimental featrue. not enough tested. and only support '-prefix', '-as' and pass default args.
+It's experimental featrue. not enough tested. and only support '-prefix' and '-as'.
 
  use UtilSubExporter list => {-prefix => 'list__', min => {-as => "list___min"}},
@@ -598 +609 @@
 Check t/lib/UtilSubExporter.pm, t/10-sub-exporter-like-epxort.t and  t/12-sub-exporter-like-export.t
 
+=head3 Sub::Exporter's generator way
+
+It's experimental feature, not enough tested.
 
 =head1 WORKING WITH EXPORTER-LIKE MODULES
@@ -606 +620 @@
 
 If you want to use module mentioned above, you have to change the way to inherit these modules.
+
+=head2 DIFFERENCE between 'all' and '-all' or ':all'
+
+If your utility module which inherited Util::Any has utility functions and export them by Exporter-like module,
+behavior of 'all' and '-all' or ':all' is a bit different.
+
+ 'all' ... export all utilities defined in your package's $Utils variables.
+ '-all' or ':all' ... export all utilities including functions in your util module itself.
 
 =head2 ALTERNATIVE INHERITING

lang/perl/Util-Any/trunk/t/12-sub-exporter-like-export.t

@@ -5 +5 @@
 my $err;
 use UtilExporter
-  -hello => [hello_name  => {-as => 'hello_ktat', name => 'ktat'},
-             hello_where => {-as => 'hello_japan', where => 'japan'},
-             hello_where => {-as => 'hello_japan', in => 'japan', where => 'osaka'}],
+  -hello => [hello_name  => {-as => 'hello_rename'},
+             hey => {-as => 'hey_japan', in => 'japan'},
+             hey => {-as => 'hey_osaka', in => 'japan', at => 'osaka'}],
  'askme';
 
@@ -14 +14 @@
 use Test::More qw/no_plan/;
 
-ok(defined &hello_ktat,  'defined hello_ktat');
-ok(defined &hello_japan, 'defined hello_japan');
+ok(defined &hello_rename, 'defined hello_rename');
+ok(defined &hey_japan,  'defined hello_japan');
 ok(defined &askme,  'defined askme');
 
-is(hello_ktat(), 'hello, ktat'  , 'hello, ktat');
-is(hello_japan(), 'hello, japan', 'hello, japan');
-is(hello_japan(where => "Osaka"), 'hello, Osaka', 'override where');
+is(hello_rename()    , 'hello, ', 'hello_rename');
+is(hey_japan()       , 'hey, japan', 'hey_japan');
+is(hey_japan("Osaka"), 'hey, Osaka in japan', 'hey_japan("Osaka")');
+is(hey_osaka()       , 'hey, osaka in japan', 'hey_osaka');
+is(hey_osaka("Osaka"), 'hey, Osaka in japan', 'hey_osaka("Osaka")');

lang/perl/Util-Any/trunk/t/lib/UtilExporter.pm

@@ -19 +19 @@
                  ['List::Util', '', [qw(first min minstr max maxstr sum)]],
                 ];
-$Utils->{-hello} = ['exampleHello'];
+$Utils->{-hello} = [
+                    ['exampleHello' => '', {'hey'   => \&hey_generator}],
+                   ];
 
 sub hello { "hello there" }
 sub askme { "what you will" }
 sub hi    { "hi there" }
+sub hello_where { "hello where" }
+
+sub hey_generator {
+  my ($self, $class, $func, $given) = @_;
+  my $at = $given->{at};
+  my $in = $given->{in};
+  return sub {
+    no strict 'refs';
+    my ($_at, $_in) = @_;
+    &{$class . '::' . $func}($_at || $at, $_in || $in);
+  }
+}
 
 1;

lang/perl/Util-Any/trunk/t/lib/UtilSubExporter2.pm

@@ -31 +31 @@
 our $Utils = clone $Util::Any::Utils;
 $Utils->{-l2s} = [
-                 ['List::Util', '', [qw(first min minstr max maxstr sum)]],
+                  ['List::Util', '', [qw(first min minstr max maxstr sum)]],
+                  {
+                   'hoge' => \&hoge_generator, # generator
+                   'hogehoge' => 'hello', # &hello
+                  }
                 ];
 

lang/perl/Util-Any/trunk/t/lib/exampleHello.pm

@@ -6 +6 @@
 our @EXPORT_OK = qw/hello_name hello_where/;
 
-sub hello_name {my %arg = @_; "hello, $arg{name}"}
+sub hello_name {my %arg = @_; "hello, " . ($arg{name} || '')}
 sub hello_where {
-  my %arg = @_;
-  return "hello, $arg{where}";
+  my ($at, $in) = @_;
+  return @_ > 1 ? "hello, $at in $in" : "hello, $at";
+}
+
+sub hey {
+  my ($at, $in) = @_;
+  unless ($at) {
+    return "hey, $in";
+  } else {
+    return "hey, $at in $in";
+  }
 }