From: matthewt <matthewt@bd8105ee-0ff8-0310-8827-fb3f25b6796d>
Date: Wed, 27 Jun 2007 07:20:56 +0000 (+0000)
Subject: plugin metaclass, profiles, commands plugi
X-Git-Tag: v1.003015~163
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=p5sagit%2FDevel-REPL.git;a=commitdiff_plain;h=4d33251a9f6d375aaafd8aa274743c68dec8f720;hp=950232b2d6e2398c5f804c58e2bedf1e98fd7151

plugin metaclass, profiles, commands plugi

git-svn-id: http://dev.catalyst.perl.org/repos/bast/trunk/Devel-REPL@3545 bd8105ee-0ff8-0310-8827-fb3f25b6796d
---

diff --git a/lib/Devel/REPL/Meta/Plugin.pm b/lib/Devel/REPL/Meta/Plugin.pm
new file mode 100644
index 0000000..c9cca5f
--- /dev/null
+++ b/lib/Devel/REPL/Meta/Plugin.pm
@@ -0,0 +1,21 @@
+package Devel::REPL::Meta::Plugin;
+
+use Moose;
+
+extends 'Moose::Meta::Role';
+
+before 'apply' => sub {
+  my ($self, $other) = @_;
+  if (my $pre = $self->get_method('BEFORE_PLUGIN')) {
+    $pre->body->($other, $self);
+  }
+};
+
+after 'apply' => sub {
+  my ($self, $other) = @_;
+  if (my $pre = $self->get_method('AFTER_PLUGIN')) {
+    $pre->body->($other, $self);
+  }
+};
+
+1;
diff --git a/lib/Devel/REPL/Plugin.pm b/lib/Devel/REPL/Plugin.pm
new file mode 100644
index 0000000..bfa57d3
--- /dev/null
+++ b/lib/Devel/REPL/Plugin.pm
@@ -0,0 +1,15 @@
+package Devel::REPL::Plugin;
+
+use strict;
+use warnings;
+use Devel::REPL::Meta::Plugin;
+use Moose::Role ();
+
+sub import {
+  my $target = caller;
+  my $meta = Devel::REPL::Meta::Plugin->initialize($target);
+  $meta->Moose::Meta::Class::add_method('meta' => sub { $meta });
+  goto &Moose::Role::import;
+}
+
+1;
diff --git a/lib/Devel/REPL/Plugin/Commands.pm b/lib/Devel/REPL/Plugin/Commands.pm
new file mode 100644
index 0000000..1b43106
--- /dev/null
+++ b/lib/Devel/REPL/Plugin/Commands.pm
@@ -0,0 +1,58 @@
+package Devel::REPL::Plugin::Commands;
+
+use Devel::REPL::Plugin;
+use Scalar::Util qw(weaken);
+
+use namespace::clean -except => [ 'meta' ];
+use vars qw($COMMAND_INSTALLER);
+
+has 'command_set' => (
+  is => 'ro', required => 1,
+  lazy => 1, default => sub { {} }
+);
+
+sub BEFORE_PLUGIN {
+  my ($self) = @_;
+  unless ($self->can('setup_commands')) {
+    $self->meta->add_method('setup_commands' => sub {});
+  }
+}
+
+sub AFTER_PLUGIN {
+  my ($self) = @_;
+  $self->setup_commands;
+}
+
+after 'setup_commands' => sub {
+  my ($self) = @_;
+  weaken($self);
+  $self->command_set->{load_plugin} = sub { $self->load_plugin(@_); };
+};
+
+sub command_installer {
+  my ($self) = @_;
+  my %command_set = %{$self->command_set};
+  return sub {
+    my $package = shift;
+    foreach my $command (keys %command_set) {
+      no strict 'refs';
+      no warnings 'redefine';
+      *{"${package}::${command}"} = $command_set{$command};
+    }
+  };
+}
+
+around 'mangle_line' => sub {
+  my ($orig, $self) = (shift, shift);
+  my ($line) = @_;
+  my $name = '$'.__PACKAGE__.'::COMMAND_INSTALLER';
+  return qq{BEGIN { ${name}->(__PACKAGE__) }\n}.$self->$orig(@_);
+};
+
+around 'compile' => sub {
+  my ($orig, $self) = (shift, shift);
+  local $COMMAND_INSTALLER = $self->command_installer;
+  $self->$orig(@_);
+};
+
+1;
diff --git a/lib/Devel/REPL/Plugin/LexEnv.pm b/lib/Devel/REPL/Plugin/LexEnv.pm
index f78fb01..71134f9 100644
--- a/lib/Devel/REPL/Plugin/LexEnv.pm
+++ b/lib/Devel/REPL/Plugin/LexEnv.pm
@@ -17,7 +17,11 @@ around 'mangle_line' => sub {
   my ($self, @rest) = @_;
   my $line = $self->$orig(@rest);
   my $lp = $self->lexical_environment;
-  return join('', map { "my $_;\n" } keys %{$lp->get_context('_')}).$line;
+  # Collate my declarations for all LP context vars then add '';
+  # so an empty statement doesn't return anything (with a no warnings
+  # to prevent "Useless use ..." warning)
+  return join('', map { "my $_;\n" } keys %{$lp->get_context('_')})
+           .qq{{ no warnings 'void'; ''; }\n}.$line;
 };
 
 around 'execute' => sub {
diff --git a/lib/Devel/REPL/Profile.pm b/lib/Devel/REPL/Profile.pm
new file mode 100644
index 0000000..c5c0c23
--- /dev/null
+++ b/lib/Devel/REPL/Profile.pm
@@ -0,0 +1,8 @@
+package Devel::REPL::Profile;
+
+use Moose::Role;
+use namespace::clean -except => [ 'meta' ];
+
+requires 'apply_profile';
+
+1;
diff --git a/lib/Devel/REPL/Profile/Default.pm b/lib/Devel/REPL/Profile/Default.pm
new file mode 100644
index 0000000..672f367
--- /dev/null
+++ b/lib/Devel/REPL/Profile/Default.pm
@@ -0,0 +1,17 @@
+package Devel::REPL::Profile::Default;
+
+use Moose;
+use namespace::clean -except => [ 'meta' ];
+
+with 'Devel::REPL::Profile';
+
+sub plugins {
+  qw(History LexEnv DDS Packages Commands);
+}
+
+sub apply_profile {
+  my ($self, $repl) = @_;
+  $repl->load_plugin($_) for $self->plugins;
+}
+
+1;
diff --git a/lib/Devel/REPL/Script.pm b/lib/Devel/REPL/Script.pm
index dc24a6a..277fc91 100644
--- a/lib/Devel/REPL/Script.pm
+++ b/lib/Devel/REPL/Script.pm
@@ -4,6 +4,7 @@ use Moose;
 use Devel::REPL;
 use File::HomeDir;
 use File::Spec;
+use vars qw($CURRENT_SCRIPT);
 use namespace::clean -except => [ qw(meta) ];
 
 with 'MooseX::Getopt';
@@ -12,6 +13,10 @@ has 'rcfile' => (
   is => 'ro', isa => 'Str', required => 1, default => sub { 'repl.rc' },
 );
 
+has 'profile' => (
+  is => 'ro', isa => 'Str', required => 1, default => sub { 'Default' },
+);
+
 has '_repl' => (
   is => 'ro', isa => 'Devel::REPL', required => 1,
   default => sub { Devel::REPL->new() }
@@ -19,13 +24,19 @@ has '_repl' => (
 
 sub BUILD {
   my ($self) = @_;
-  $self->load_rcfile;
+  $self->load_profile($self->profile);
+  $self->load_rcfile($self->rcfile);
 }
 
-sub load_rcfile {
-  my ($self) = @_;
+sub load_profile {
+  my ($self, $profile) = @_;
+  $profile = "Devel::REPL::Profile::${profile}" unless $profile =~ /::/;
+  Class::MOP::load_class($profile);
+  $profile->new->apply_profile($self->_repl);
+}
 
-  my $rc_file = $self->rcfile;
+sub load_rcfile {
+  my ($self, $rc_file) = @_;
 
   # plain name => ~/.re.pl/${rc_file}
   if ($rc_file !~ m!/!) {
@@ -43,8 +54,9 @@ sub load_rcfile {
 }
 
 sub eval_rcdata {
-  my $_REPL = $_[0]->_repl;
-  eval $_[1];
+  my ($self, $data) = @_;
+  local $CURRENT_SCRIPT = $self;
+  $self->_repl->eval($data);
 }
 
 sub run {
@@ -58,4 +70,11 @@ sub import {
   $class->new_with_options->run;
 }
 
+sub current {
+  confess "->current should only be called as class method" if ref($_[0]);
+  confess "No current instance (valid only during rc parse)"
+    unless $CURRENT_SCRIPT;
+  return $CURRENT_SCRIPT;
+}
+
 1;
diff --git a/t/load_core.t b/t/load_core.t
index c21dc21..6f31386 100644
--- a/t/load_core.t
+++ b/t/load_core.t
@@ -7,3 +7,4 @@ use_ok('Devel::REPL::Script');
 use_ok('Devel::REPL::Plugin::History');
 use_ok('Devel::REPL::Plugin::LexEnv');
 use_ok('Devel::REPL::Plugin::DDS');
+use_ok('Devel::REPL::Plugin::Commands');