File Coverage

blib/lib/Devel/Command.pm

Criterion	Covered	Total	%
statement	47	57	82.4
branch	5	8	62.5
condition			n/a
subroutine	9	12	75.0
pod	3	4	75.0
total	64	81	79.0

package Devel::Command;
use strict;
use warnings;
use Data::Dumper;

use Module::Pluggable search_path=>["Devel::Command"], require=>1;
use Module::Pluggable search_path=>['Devel::Command::DBSub'],
                      sub_name => 'DB_subs';

our $VERSION = '0.11';

sub import {
  # Find and install all the plugins.
  # Uncomment the following line to verify plugin/patch loading in the debugger.
  # $DB::single=1;
  my @plugins = __PACKAGE__->plugins;
  foreach my $plugin (@plugins) {
    # Skip patch plugins.
    next if $plugin =~ /^Devel::Command::DBSub/;

    # get the signature(s) (name, entry point).
    my(@signatures) = $plugin->signature();

    # Install the command(s) in our lookup table.
    while (@signatures) {
      my $cmd_name = shift @signatures;
      my $cmd_ref  = shift @signatures;
      $DB::commands{$cmd_name} = $cmd_ref;
    }

    # Export our eval into the plugin.
    {
      no  strict 'refs';
      *{$plugin."::eval"} = \&eval;
    }
  }

  # Add our local 'cmds' command to the table.
  $DB::commands{"cmds"} = \&cmds;

  # Install the alternate version of DB::DB.
  {
    no warnings 'redefine';
    my $patch;
    print STDERR map {"# $_"} Dumper(__PACKAGE__->DB_subs());
    foreach my $DB_module (__PACKAGE__->DB_subs) {
      my $subref;
      warn "# Trying " .Dumper($DB_module);
      if ($subref = $DB_module->import()) {
        # This module could work for the current Perl.
        $patch = [$subref, $DB_module];
      }
    }
    if (! defined $patch) {
      die "Your Perl can't be patched by Devel::Command (yours is Perl $])\n";
    }
    else {
      print "Patching with ", $patch->[1], "\n";
        *DB::DB = $patch->[0];
    }
  }
}

sub cmds {
  for my $key (keys %DB::commands) {
    print DB::OUT $key,"\n";
  }
  1;
}

sub DB::afterinit {
  my @plugins = __PACKAGE__->plugins;
  foreach my $plugin (@plugins) {
    $plugin->afterinit if $plugin->can('afterinit');
  }
}

sub eval {
  my  $arg = shift;
  $DB::evalarg = $arg;
  DB::eval();
}

sub signature {
  my $class = shift;
  # Generate a command name based on the name
  # of this plugin (the final qualifier),
  # lowercased. Assumes that the actual
  # code to execute the command is in a
  # sub named 'command' in that package.
  (lc(substr($class,rindex($class,'::')+2)),
   eval "\\&".$class."::command");
}

1;
__END__