Initial Commit

database/perl/vendor/lib/Class/C3/Componentised.pm

@@ -0,0 +1,260 @@
+package Class::C3::Componentised;
+
+=head1 NAME
+
+Class::C3::Componentised - Load mix-ins or components to your C3-based class
+
+=head1 SYNOPSIS
+
+  package MyModule;
+
+  use strict;
+  use warnings;
+
+  use base 'Class::C3::Componentised';
+
+  sub component_base_class { "MyModule::Component" }
+
+  package main;
+
+  MyModule->load_components( qw/Foo Bar/ );
+  # Will load MyModule::Component::Foo and MyModule::Component::Bar
+
+=head1 DESCRIPTION
+
+This will inject base classes to your module using the L<Class::C3> method
+resolution order.
+
+Please note: these are not plugins that can take precedence over methods
+declared in MyModule. If you want something like that, consider
+L<MooseX::Object::Pluggable>.
+
+=head1 METHODS
+
+=cut
+
+use strict;
+use warnings;
+
+# This will prime the Class::C3 namespace (either by loading it proper on 5.8
+# or by installing compat shims on 5.10+). A user might have a reasonable
+# expectation that using Class::C3::<something> will give him access to
+# Class::C3 itself, and this module has been providing this historically.
+# Therefore leaving it in indefinitely.
+use MRO::Compat;
+
+use Carp ();
+use List::Util ();
+
+our $VERSION = '1.001002';
+$VERSION =~ tr/_//d;
+
+my $invalid_class = qr/(?: \b:\b | \:{3,} | \:\:$ )/x;
+
+=head2 load_components( @comps )
+
+Loads the given components into the current module. If a module begins with a
+C<+> character, it is taken to be a fully qualified class name, otherwise
+C<< $class->component_base_class >> is prepended to it.
+
+Calling this will call C<Class::C3::reinitialize>.
+
+=cut
+
+sub load_components {
+  my $class = shift;
+  $class->_load_components( map {
+    /^\+(.*)$/
+      ? $1
+      : join ('::', $class->component_base_class, $_)
+    } grep { $_ !~ /^#/ } @_
+  );
+}
+
+=head2 load_own_components( @comps )
+
+Similar to L<load_components|/load_components( @comps )>, but assumes every
+class is C<"$class::$comp">.
+
+=cut
+
+sub load_own_components {
+  my $class = shift;
+  $class->_load_components( map { "${class}::$_" } grep { $_ !~ /^#/ } @_ );
+}
+
+sub _load_components {
+  my $class = shift;
+  return unless @_;
+
+  $class->ensure_class_loaded($_) for @_;
+  $class->inject_base($class => @_);
+  Class::C3::reinitialize();
+}
+
+=head2 load_optional_components
+
+As L<load_components|/load_components( @comps )>, but will silently ignore any
+components that cannot be found.
+
+=cut
+
+sub load_optional_components {
+  my $class = shift;
+  $class->_load_components( grep
+    { $class->load_optional_class( $_ ) }
+    ( map
+      { /^\+(.*)$/
+          ? $1
+          : join ('::', $class->component_base_class, $_)
+      }
+      grep { $_ !~ /^#/ } @_
+    )
+  );
+}
+
+=head2 ensure_class_loaded
+
+Given a class name, tests to see if it is already loaded or otherwise
+defined. If it is not yet loaded, the package is require'd, and an exception
+is thrown if the class is still not loaded.
+
+ BUG: For some reason, packages with syntax errors are added to %INC on
+      require
+=cut
+
+sub ensure_class_loaded {
+  my ($class, $f_class) = @_;
+
+  no strict 'refs';
+
+  # ripped from Class::Inspector for speed
+  # note that the order is important (faster items are first)
+  return if ${"${f_class}::VERSION"};
+
+  return if @{"${f_class}::ISA"};
+
+  my $file = (join ('/', split ('::', $f_class) ) ) . '.pm';
+  return if $INC{$file};
+
+  for ( keys %{"${f_class}::"} ) {
+    return if ( *{"${f_class}::$_"}{CODE} );
+  }
+
+  # require always returns true on success
+  # ill-behaved modules might very well obliterate $_
+  eval { local $_; require($file) } or do {
+
+    $@ = "Invalid class name '$f_class'" if $f_class =~ $invalid_class;
+
+    if ($class->can('throw_exception')) {
+      $class->throw_exception($@);
+    } else {
+      Carp::croak $@;
+    }
+  };
+
+  return;
+}
+
+=head2 ensure_class_found
+
+Returns true if the specified class is installed or already loaded, false
+otherwise.
+
+=cut
+
+sub ensure_class_found {
+  #my ($class, $f_class) = @_;
+  require Class::Inspector;
+  return Class::Inspector->loaded($_[1]) ||
+         Class::Inspector->installed($_[1]);
+}
+
+
+=head2 inject_base
+
+Does the actual magic of adjusting C<@ISA> on the target module.
+
+=cut
+
+sub inject_base {
+  my $class = shift;
+  my $target = shift;
+
+  mro::set_mro($target, 'c3');
+
+  for my $comp (reverse @_) {
+    my $apply = do {
+      no strict 'refs';
+      sub { unshift ( @{"${target}::ISA"}, $comp ) };
+    };
+    unless ($target eq $comp || $target->isa($comp)) {
+      our %APPLICATOR_FOR;
+      if (my $apply_class
+            = List::Util::first { $APPLICATOR_FOR{$_} } @{mro::get_linear_isa($comp)}
+      ) {
+        $APPLICATOR_FOR{$apply_class}->_apply_component_to_class($comp,$target,$apply);
+      } else {
+        $apply->();
+      }
+    }
+  }
+}
+
+=head2 load_optional_class
+
+Returns a true value if the specified class is installed and loaded
+successfully, throws an exception if the class is found but not loaded
+successfully, and false if the class is not installed
+
+=cut
+
+sub load_optional_class {
+  my ($class, $f_class) = @_;
+
+  # ensure_class_loaded either returns a () (*not* true)  or throws
+  eval {
+   $class->ensure_class_loaded($f_class);
+   1;
+  } && return 1;
+
+  my $err = $@;   # so we don't lose it
+
+  if ($f_class =~ $invalid_class) {
+    $err = "Invalid class name '$f_class'";
+  }
+  else {
+    my $fn = quotemeta( (join ('/', split ('::', $f_class) ) ) . '.pm' );
+    return 0 if ($err =~ /Can't locate ${fn} in \@INC/ );
+  }
+
+  if ($class->can('throw_exception')) {
+    $class->throw_exception($err);
+  }
+  else {
+    die $err;
+  }
+}
+
+=head1 AUTHORS
+
+Matt S. Trout and the L<DBIx::Class team|DBIx::Class/CONTRIBUTORS>
+
+Pulled out into separate module by Ash Berlin C<< <ash@cpan.org> >>
+
+Optimizations and overall bolt-tightening by Peter "ribasushi" Rabbitson
+C<< <ribasushi@cpan.org> >>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2006 - 2011 the Class::C3::Componentised L</AUTHORS> as listed
+above.
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+
+1;

database/perl/vendor/lib/Class/C3/Componentised/ApplyHooks.pm

@@ -0,0 +1,156 @@
+package Class::C3::Componentised::ApplyHooks;
+
+use strict;
+use warnings;
+
+our %Before;
+our %After;
+
+sub BEFORE_APPLY (&) {
+  push @{$Before{scalar caller}}, $_[0];
+  $Class::C3::Componentised::APPLICATOR_FOR{scalar caller} = __PACKAGE__;
+}
+sub AFTER_APPLY  (&) {
+  push @{$After {scalar caller}}, $_[0];
+  $Class::C3::Componentised::APPLICATOR_FOR{scalar caller} = __PACKAGE__;
+}
+
+sub _apply_component_to_class {
+  my ($me, $comp, $target, $apply) = @_;
+  my @heritage = @{mro::get_linear_isa($comp)};
+
+  my @before = map {
+     my $to_run = $Before{$_};
+     ($to_run?[$_,$to_run]:())
+  } @heritage;
+
+  for my $todo (@before) {
+     my ($parent, $fn)  = @$todo;
+     for my $f (reverse @$fn) {
+        $target->$f($parent)
+     }
+  }
+
+  $apply->();
+
+  my @after = map {
+     my $to_run = $After{$_};
+     ($to_run?[$_,$to_run]:())
+  } @heritage;
+
+  for my $todo (reverse @after) {
+     my ($parent, $fn)  = @$todo;
+     for my $f (@$fn) {
+        $target->$f($parent)
+     }
+  }
+}
+
+{
+   no strict 'refs';
+   sub import {
+      my ($from, @args) = @_;
+      my $to = caller;
+
+      my $default = 1;
+      my $i = 0;
+      my $skip = 0;
+      my @import;
+      for my $arg (@args) {
+         if ($skip) {
+            $skip--;
+            $i++;
+            next
+         }
+
+         if ($arg eq '-before_apply') {
+            $default = 0;
+            $skip = 1;
+            push @{$Before{$to}}, $args[$i + 1];
+            $Class::C3::Componentised::APPLICATOR_FOR{$to} = $from;
+         } elsif ($arg eq '-after_apply') {
+            $default = 0;
+            $skip = 1;
+            push @{$After{$to}}, $args[$i + 1];
+            $Class::C3::Componentised::APPLICATOR_FOR{$to} = $from;
+         } elsif ($arg =~ /^BEFORE_APPLY|AFTER_APPLY$/) {
+            $default = 0;
+            push @import, $arg
+         }
+         $i++;
+      }
+      @import = qw(BEFORE_APPLY AFTER_APPLY)
+         if $default;
+
+      *{"$to\::$_"} = \&{"$from\::$_"} for @import
+   }
+}
+
+1;
+
+=head1 NAME
+
+Class::C3::Componentised::ApplyHooks - Run methods before or after components are injected
+
+=head1 SYNOPSIS
+
+ package MyComponent;
+
+ our %statistics;
+
+ use Class::C3::Componentised::ApplyHooks
+   -before_apply => sub {
+     my ($class, $component) = @_;
+
+     push @{$statistics{$class}}, '-before_apply';
+   },
+   -after_apply  => sub {
+     my ($class, $component) = @_;
+
+     push @{$statistics{$class}}, '-after_apply';
+   }, qw(BEFORE_APPLY AFTER_APPLY);
+
+ BEFORE_APPLY { push @{$statistics{$class}}, 'BEFORE_APPLY' };
+ AFTER_APPLY { push @{$statistics{$class}}, 'AFTER_APPLY' };
+ AFTER_APPLY { use Devel::Dwarn; Dwarn %statistics };
+
+ 1;
+
+=head1 DESCRIPTION
+
+This package allows a given component to run methods on the class that is being
+injected into before or after the component is injected.  Note from the
+L</SYNOPSIS> that all C<Load Actions> may be run more than once.
+
+=head1 IMPORT ACTION
+
+Both import actions simply run a list of coderefs that will be passed the class
+that is being acted upon and the component that is being added to the class.
+
+=head1 IMPORT OPTIONS
+
+=head2 -before_apply
+
+Adds a before apply action for the current component without importing
+any subroutines into your namespace.
+
+=head2 -after_apply
+
+Adds an after apply action for the current component without importing
+any subroutines into your namespace.
+
+=head1 EXPORTED SUBROUTINES
+
+=head2 BEFORE_APPLY
+
+ BEFORE_APPLY { warn "about to apply $_[1] to class $_[0]"  };
+
+Adds a before apply action for the current component.
+
+=head2 AFTER_APPLY
+
+ AFTER_APPLY { warn "just applied $_[1] to class $_[0]"  };
+
+Adds an after apply action for the current component.
+
+=cut

database/perl/vendor/lib/Class/C3/next.pm

@@ -0,0 +1,106 @@
+package  # hide me from PAUSE
+    next;
+
+use strict;
+use warnings;
+no warnings 'redefine'; # for 00load.t w/ core support
+
+use Scalar::Util 'blessed';
+
+our $VERSION = '0.35';
+
+our %METHOD_CACHE;
+
+sub method {
+    my $self     = $_[0];
+    my $class    = blessed($self) || $self;
+    my $indirect = caller() =~ /^(?:next|maybe::next)$/;
+    my $level = $indirect ? 2 : 1;
+
+    my ($method_caller, $label, @label);
+    while ($method_caller = (caller($level++))[3]) {
+      @label = (split '::', $method_caller);
+      $label = pop @label;
+      last unless
+        $label eq '(eval)' ||
+        $label eq '__ANON__';
+    }
+
+    my $method;
+
+    my $caller   = join '::' => @label;
+
+    $method = $METHOD_CACHE{"$class|$caller|$label"} ||= do {
+
+        my @MRO = Class::C3::calculateMRO($class);
+
+        my $current;
+        while ($current = shift @MRO) {
+            last if $caller eq $current;
+        }
+
+        no strict 'refs';
+        my $found;
+        foreach my $class (@MRO) {
+            next if (defined $Class::C3::MRO{$class} &&
+                     defined $Class::C3::MRO{$class}{methods}{$label});
+            last if (defined ($found = *{$class . '::' . $label}{CODE}));
+        }
+
+        $found;
+    };
+
+    return $method if $indirect;
+
+    die "No next::method '$label' found for $self" if !$method;
+
+    goto &{$method};
+}
+
+sub can { method($_[0]) }
+
+package  # hide me from PAUSE
+    maybe::next;
+
+use strict;
+use warnings;
+no warnings 'redefine'; # for 00load.t w/ core support
+
+our $VERSION = '0.35';
+
+sub method { (next::method($_[0]) || return)->(@_) }
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Class::C3::next - Pure-perl next::method and friends
+
+=head1 DESCRIPTION
+
+This module is used internally by L<Class::C3> when
+necessary, and shouldn't be used (or required in
+distribution dependencies) directly.  It
+defines C<next::method>, C<next::can>, and
+C<maybe::next::method> in pure perl.
+
+=head1 AUTHOR
+
+Stevan Little, <stevan@iinteractive.com>
+
+Brandon L. Black, <blblack@gmail.com>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2005, 2006 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut