opener-tokenizer-base 1.0.0

data/core/lib/Sub/Exporter/Util.pm

@@ -0,0 +1,354 @@
+use strict;
+use warnings;
+package Sub::Exporter::Util;
+{
+  $Sub::Exporter::Util::VERSION = '0.984';
+}
+# ABSTRACT: utilities to make Sub::Exporter easier
+
+use Data::OptList ();
+use Params::Util ();
+
+
+sub curry_method {
+  my $override_name = shift;
+  sub {
+    my ($class, $name) = @_;
+    $name = $override_name if defined $override_name;
+    sub { $class->$name(@_); };
+  }
+}
+
+BEGIN { *curry_class = \&curry_method; }
+
+
+sub curry_chain {
+  # In the future, we can make \%arg an optional prepend, like the "special"
+  # args to the default Sub::Exporter-generated import routine.
+  my (@opt_list) = @_;
+
+  my $pairs = Data::OptList::mkopt(\@opt_list, 'args', 'ARRAY');
+
+  sub {
+    my ($class) = @_;
+
+    sub {
+      my $next = $class;
+
+      for my $i (0 .. $#$pairs) {
+        my $pair = $pairs->[ $i ];
+        
+        unless (Params::Util::_INVOCANT($next)) { ## no critic Private
+          my $str = defined $next ? "'$next'" : 'undef';
+          Carp::croak("can't call $pair->[0] on non-invocant $str")
+        }
+
+        my ($method, $args) = @$pair;
+
+        if ($i == $#$pairs) {
+          return $next->$method($args ? @$args : ());
+        } else {
+          $next = $next->$method($args ? @$args : ());
+        }
+      }
+    };
+  }
+}
+
+# =head2 name_map
+# 
+# This utility returns an list to be used in specify export generators.  For
+# example, the following:
+# 
+#   exports => {
+#     name_map(
+#       '_?_gen'  => [ qw(fee fie) ],
+#       '_make_?' => [ qw(foo bar) ],
+#     ),
+#   }
+# 
+# is equivalent to:
+# 
+#   exports => {
+#     name_map(
+#       fee => \'_fee_gen',
+#       fie => \'_fie_gen',
+#       foo => \'_make_foo',
+#       bar => \'_make_bar',
+#     ),
+#   }
+# 
+# This can save a lot of typing, when providing many exports with similarly-named
+# generators.
+# 
+# =cut
+# 
+# sub name_map {
+#   my (%groups) = @_;
+# 
+#   my %map;
+# 
+#   while (my ($template, $names) = each %groups) {
+#     for my $name (@$names) {
+#       (my $export = $template) =~ s/\?/$name/
+#         or Carp::croak 'no ? found in name_map template';
+# 
+#       $map{ $name } = \$export;
+#     }
+#   }
+# 
+#   return %map;
+# }
+
+
+sub merge_col {
+  my (%groups) = @_;
+
+  my %merged;
+
+  while (my ($default_name, $group) = each %groups) {
+    while (my ($export_name, $gen) = each %$group) {
+      $merged{$export_name} = sub {
+        my ($class, $name, $arg, $col) = @_;
+
+        my $merged_arg = exists $col->{$default_name}
+                       ? { %{ $col->{$default_name} }, %$arg }
+                       : $arg;
+
+        if (Params::Util::_CODELIKE($gen)) { ## no critic Private
+          $gen->($class, $name, $merged_arg, $col);
+        } else {
+          $class->$$gen($name, $merged_arg, $col);
+        }
+      }
+    }
+  }
+
+  return %merged;
+}
+
+
+sub __mixin_class_for {
+  my ($class, $mix_into) = @_;
+  require Package::Generator;
+  my $mixin_class = Package::Generator->new_package({
+    base => "$class\:\:__mixin__",
+  });
+
+  ## no critic (ProhibitNoStrict)
+  no strict 'refs';
+  if (ref $mix_into) {
+    unshift @{"$mixin_class" . "::ISA"}, ref $mix_into;
+  } else {
+    unshift @{"$mix_into" . "::ISA"}, $mixin_class;
+  }
+  return $mixin_class;
+}
+
+sub mixin_installer {
+  sub {
+    my ($arg, $to_export) = @_;
+
+    my $mixin_class = __mixin_class_for($arg->{class}, $arg->{into});
+    bless $arg->{into} => $mixin_class if ref $arg->{into};
+
+    Sub::Exporter::default_installer(
+      { %$arg, into => $mixin_class },
+      $to_export,
+    );
+  };
+}
+
+sub mixin_exporter {
+  Carp::cluck "mixin_exporter is deprecated; use mixin_installer instead; it behaves identically";
+  return mixin_installer;
+}
+
+
+sub like {
+  sub {
+    my ($value, $arg) = @_;
+    Carp::croak "no regex supplied to regex group generator" unless $value;
+
+    # Oh, qr//, how you bother me!  See the p5p thread from around now about
+    # fixing this problem... too bad it won't help me. -- rjbs, 2006-04-25
+    my @values = eval { $value->isa('Regexp') } ? ($value, undef)
+               :                                  @$value;
+
+    while (my ($re, $opt) = splice @values, 0, 2) {
+      Carp::croak "given pattern for regex group generater is not a Regexp"
+        unless eval { $re->isa('Regexp') };
+      my @exports  = keys %{ $arg->{config}->{exports} };
+      my @matching = grep { $_ =~ $re } @exports;
+
+      my %merge = $opt ? %$opt : ();
+      my $prefix = (delete $merge{-prefix}) || '';
+      my $suffix = (delete $merge{-suffix}) || '';
+
+      for my $name (@matching) {
+        my $as = $prefix . $name . $suffix;
+        push @{ $arg->{import_args} }, [ $name => { %merge, -as => $as } ];
+      }
+    }
+
+    1;
+  }
+}
+
+use Sub::Exporter -setup => {
+  exports => [ qw(
+    like
+    name_map
+    merge_col
+    curry_method curry_class
+    curry_chain
+    mixin_installer mixin_exporter
+  ) ]
+};
+
+1;
+
+__END__
+=pod
+
+=head1 NAME
+
+Sub::Exporter::Util - utilities to make Sub::Exporter easier
+
+=head1 VERSION
+
+version 0.984
+
+=head1 DESCRIPTION
+
+This module provides a number of utility functions for performing common or
+useful operations when setting up a Sub::Exporter configuration.  All of the
+utilites may be exported, but none are by default.
+
+=head1 THE UTILITIES
+
+=head2 curry_method
+
+  exports => {
+    some_method => curry_method,
+  }
+
+This utility returns a generator which will produce an invocant-curried version
+of a method.  In other words, it will export a method call with the exporting
+class built in as the invocant.
+
+A module importing the code some the above example might do this:
+
+  use Some::Module qw(some_method);
+
+  my $x = some_method;
+
+This would be equivalent to:
+
+  use Some::Module;
+
+  my $x = Some::Module->some_method;
+
+If Some::Module is subclassed and the subclass's import method is called to
+import C<some_method>, the subclass will be curried in as the invocant.
+
+If an argument is provided for C<curry_method> it is used as the name of the
+curried method to export.  This means you could export a Widget constructor
+like this:
+
+  exports => { widget => curry_method('new') }
+
+This utility may also be called as C<curry_class>, for backwards compatibility.
+
+=head2 curry_chain
+
+C<curry_chain> behaves like C<L</curry_method>>, but is meant for generating
+exports that will call several methods in succession.
+
+  exports => {
+    reticulate => curry_chain([
+      new => gather_data => analyze => [ detail => 100 ] => results
+    ]),
+  }
+
+If imported from Spliner, calling the C<reticulate> routine will be equivalent
+to:
+
+  Splinter->new->gather_data->analyze(detail => 100)->results;
+
+If any method returns something on which methods may not be called, the routine
+croaks.
+
+The arguments to C<curry_chain> form an optlist.  The names are methods to be
+called and the arguments, if given, are arrayrefs to be dereferenced and passed
+as arguments to those methods.  C<curry_chain> returns a generator like those
+expected by Sub::Exporter.
+
+B<Achtung!> at present, there is no way to pass arguments from the generated
+routine to the method calls.  This will probably be solved in future revisions
+by allowing the opt list's values to be subroutines that will be called with
+the generated routine's stack.
+
+=head2 merge_col
+
+  exports => {
+    merge_col(defaults => {
+      twiddle => \'_twiddle_gen',
+      tweak   => \&_tweak_gen,
+    }),
+  }
+
+This utility wraps the given generator in one that will merge the named
+collection into its args before calling it.  This means that you can support a
+"default" collector in multipe exports without writing the code each time.
+
+You can specify as many pairs of collection names and generators as you like.
+
+=head2 mixin_installer
+
+  use Sub::Exporter -setup => {
+    installer => Sub::Exporter::Util::mixin_installer,
+    exports   => [ qw(foo bar baz) ],
+  };
+
+This utility returns an installer that will install into a superclass and
+adjust the ISA importing class to include the newly generated superclass.
+
+If the target of importing is an object, the hierarchy is reversed: the new
+class will be ISA the object's class, and the object will be reblessed.
+
+B<Prerequisites>: This utility requires that Package::Generator be installed.
+
+=head2 like
+
+It's a collector that adds imports for anything like given regex.
+
+If you provide this configuration:
+
+  exports    => [ qw(igrep imap islurp exhausted) ],
+  collectors => { -like => Sub::Exporter::Util::like },
+
+A user may import from your module like this:
+
+  use Your::Iterator -like => qr/^i/; # imports igre, imap, islurp
+
+or
+
+  use Your::Iterator -like => [ qr/^i/ => { -prefix => 'your_' } ];
+
+The group-like prefix and suffix arguments are respected; other arguments are
+passed on to the generators for matching exports.
+
+=head1 AUTHOR
+
+Ricardo Signes <rjbs@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2007 by Ricardo Signes.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
+

data/core/lib/Sub/Install.pm

@@ -0,0 +1,329 @@
+package Sub::Install;
+
+use warnings;
+use strict;
+
+use Carp;
+use Scalar::Util ();
+
+=head1 NAME
+
+Sub::Install - install subroutines into packages easily
+
+=head1 VERSION
+
+version 0.926
+
+=cut
+
+our $VERSION = '0.926';
+
+=head1 SYNOPSIS
+
+  use Sub::Install;
+
+  Sub::Install::install_sub({
+    code => sub { ... },
+    into => $package,
+    as   => $subname
+  });
+
+=head1 DESCRIPTION
+
+This module makes it easy to install subroutines into packages without the
+unslightly mess of C<no strict> or typeglobs lying about where just anyone can
+see them.
+
+=head1 FUNCTIONS
+
+=head2 install_sub
+
+  Sub::Install::install_sub({
+   code => \&subroutine,
+   into => "Finance::Shady",
+   as   => 'launder',
+  });
+
+This routine installs a given code reference into a package as a normal
+subroutine.  The above is equivalent to:
+
+  no strict 'refs';
+  *{"Finance::Shady" . '::' . "launder"} = \&subroutine;
+
+If C<into> is not given, the sub is installed into the calling package.
+
+If C<code> is not a code reference, it is looked for as an existing sub in the
+package named in the C<from> parameter.  If C<from> is not given, it will look
+in the calling package.
+
+If C<as> is not given, and if C<code> is a name, C<as> will default to C<code>.
+If C<as> is not given, but if C<code> is a code ref, Sub::Install will try to
+find the name of the given code ref and use that as C<as>.
+
+That means that this code:
+
+  Sub::Install::install_sub({
+    code => 'twitch',
+    from => 'Person::InPain',
+    into => 'Person::Teenager',
+    as   => 'dance',
+  });
+
+is the same as:
+
+  package Person::Teenager;
+
+  Sub::Install::install_sub({
+    code => Person::InPain->can('twitch'),
+    as   => 'dance',
+  });
+
+=head2 reinstall_sub
+
+This routine behaves exactly like C<L</install_sub>>, but does not emit a
+warning if warnings are on and the destination is already defined.
+
+=cut
+
+sub _name_of_code {
+  my ($code) = @_;
+  require B;
+  my $name = B::svref_2object($code)->GV->NAME;
+  return $name unless $name =~ /\A__ANON__/;
+  return;
+}
+
+# See also Params::Util, to which this code was donated.
+sub _CODELIKE {
+  (Scalar::Util::reftype($_[0])||'') eq 'CODE'
+  || Scalar::Util::blessed($_[0])
+  && (overload::Method($_[0],'&{}') ? $_[0] : undef);
+}
+
+# do the heavy lifting
+sub _build_public_installer {
+  my ($installer) = @_;
+
+  sub {
+    my ($arg) = @_;
+    my ($calling_pkg) = caller(0);
+
+    # I'd rather use ||= but I'm whoring for Devel::Cover.
+    for (qw(into from)) { $arg->{$_} = $calling_pkg unless $arg->{$_} }
+
+    # This is the only absolutely required argument, in many cases.
+    Carp::croak "named argument 'code' is not optional" unless $arg->{code};
+
+    if (_CODELIKE($arg->{code})) {
+      $arg->{as} ||= _name_of_code($arg->{code});
+    } else {
+      Carp::croak
+        "couldn't find subroutine named $arg->{code} in package $arg->{from}"
+        unless my $code = $arg->{from}->can($arg->{code});
+
+      $arg->{as}   = $arg->{code} unless $arg->{as};
+      $arg->{code} = $code;
+    }
+
+    Carp::croak "couldn't determine name under which to install subroutine"
+      unless $arg->{as};
+
+    $installer->(@$arg{qw(into as code) });
+  }
+}
+
+# do the ugly work
+
+my $_misc_warn_re;
+my $_redef_warn_re;
+BEGIN {
+  $_misc_warn_re = qr/
+    Prototype\ mismatch:\ sub\ .+?  |
+    Constant subroutine \S+ redefined
+  /x;
+  $_redef_warn_re = qr/Subroutine\ \S+\ redefined/x;
+}
+
+my $eow_re;
+BEGIN { $eow_re = qr/ at .+? line \d+\.\Z/ };
+
+sub _do_with_warn {
+  my ($arg) = @_;
+  my $code = delete $arg->{code};
+  my $wants_code = sub {
+    my $code = shift;
+    sub {
+      my $warn = $SIG{__WARN__} ? $SIG{__WARN__} : sub { warn @_ }; ## no critic
+      local $SIG{__WARN__} = sub {
+        my ($error) = @_;
+        for (@{ $arg->{suppress} }) {
+            return if $error =~ $_;
+        }
+        for (@{ $arg->{croak} }) {
+          if (my ($base_error) = $error =~ /\A($_) $eow_re/x) {
+            Carp::croak $base_error;
+          }
+        }
+        for (@{ $arg->{carp} }) {
+          if (my ($base_error) = $error =~ /\A($_) $eow_re/x) {
+            return $warn->(Carp::shortmess $base_error);
+          }
+        }
+        ($arg->{default} || $warn)->($error);
+      };
+      $code->(@_);
+    };
+  };
+  return $wants_code->($code) if $code;
+  return $wants_code;
+}
+
+sub _installer {
+  sub {
+    my ($pkg, $name, $code) = @_;
+    no strict 'refs'; ## no critic ProhibitNoStrict
+    *{"$pkg\::$name"} = $code;
+    return $code;
+  }
+}
+
+BEGIN {
+  *_ignore_warnings = _do_with_warn({
+    carp => [ $_misc_warn_re, $_redef_warn_re ]
+  });
+
+  *install_sub = _build_public_installer(_ignore_warnings(_installer));
+
+  *_carp_warnings =  _do_with_warn({
+    carp     => [ $_misc_warn_re ],
+    suppress => [ $_redef_warn_re ],
+  });
+
+  *reinstall_sub = _build_public_installer(_carp_warnings(_installer));
+
+  *_install_fatal = _do_with_warn({
+    code     => _installer,
+    croak    => [ $_redef_warn_re ],
+  });
+}
+
+=head2 install_installers
+
+This routine is provided to allow Sub::Install compatibility with
+Sub::Installer.  It installs C<install_sub> and C<reinstall_sub> methods into
+the package named by its argument.
+
+ Sub::Install::install_installers('Code::Builder'); # just for us, please
+ Code::Builder->install_sub({ name => $code_ref });
+
+ Sub::Install::install_installers('UNIVERSAL'); # feeling lucky, punk?
+ Anything::At::All->install_sub({ name => $code_ref });
+
+The installed installers are similar, but not identical, to those provided by
+Sub::Installer.  They accept a single hash as an argument.  The key/value pairs
+are used as the C<as> and C<code> parameters to the C<install_sub> routine
+detailed above.  The package name on which the method is called is used as the
+C<into> parameter.
+
+Unlike Sub::Installer's C<install_sub> will not eval strings into code, but
+will look for named code in the calling package.
+
+=cut
+
+sub install_installers {
+  my ($into) = @_;
+
+  for my $method (qw(install_sub reinstall_sub)) {
+    my $code = sub {
+      my ($package, $subs) = @_;
+      my ($caller) = caller(0);
+      my $return;
+      for (my ($name, $sub) = %$subs) {
+        $return = Sub::Install->can($method)->({
+          code => $sub,
+          from => $caller,
+          into => $package,
+          as   => $name
+        });
+      }
+      return $return;
+    };
+    install_sub({ code => $code, into => $into, as => $method });
+  }
+}
+
+=head1 EXPORTS
+
+Sub::Install exports C<install_sub> and C<reinstall_sub> only if they are
+requested.
+
+=head2 exporter
+
+Sub::Install has a never-exported subroutine called C<exporter>, which is used
+to implement its C<import> routine.  It takes a hashref of named arguments,
+only one of which is currently recognize: C<exports>.  This must be an arrayref
+of subroutines to offer for export.
+
+This routine is mainly for Sub::Install's own consumption.  Instead, consider
+L<Sub::Exporter>.
+
+=cut
+
+sub exporter {
+  my ($arg) = @_;
+  
+  my %is_exported = map { $_ => undef } @{ $arg->{exports} };
+
+  sub {
+    my $class = shift;
+    my $target = caller;
+    for (@_) {
+      Carp::croak "'$_' is not exported by $class" if !exists $is_exported{$_};
+      install_sub({ code => $_, from => $class, into => $target });
+    }
+  }
+}
+
+BEGIN { *import = exporter({ exports => [ qw(install_sub reinstall_sub) ] }); }
+
+=head1 SEE ALSO
+
+=over
+
+=item L<Sub::Installer>
+
+This module is (obviously) a reaction to Damian Conway's Sub::Installer, which
+does the same thing, but does it by getting its greasy fingers all over
+UNIVERSAL.  I was really happy about the idea of making the installation of
+coderefs less ugly, but I couldn't bring myself to replace the ugliness of
+typeglobs and loosened strictures with the ugliness of UNIVERSAL methods.
+
+=item L<Sub::Exporter>
+
+This is a complete Exporter.pm replacement, built atop Sub::Install.
+
+=back
+
+=head1 AUTHOR
+
+Ricardo Signes, C<< <rjbs@cpan.org> >>
+
+Several of the tests are adapted from tests that shipped with Damian Conway's
+Sub-Installer distribution.
+
+=head1 BUGS
+
+Please report any bugs or feature requests through the web interface at
+L<http://rt.cpan.org>.  I will be notified, and then you'll automatically be
+notified of progress on your bug as I make changes.
+
+=head1 COPYRIGHT
+
+Copyright 2005-2006 Ricardo Signes, All Rights Reserved.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
+
+1;