[Bast-commits] r3545 - in trunk/Devel-REPL: lib/Devel/REPL lib/Devel/REPL/Meta lib/Devel/REPL/Plugin lib/Devel/REPL/Profile t

matthewt at dev.catalyst.perl.org matthewt at dev.catalyst.perl.org
Wed Jun 27 08:20:56 GMT 2007


Author: matthewt
Date: 2007-06-27 08:20:56 +0100 (Wed, 27 Jun 2007)
New Revision: 3545

Added:
   trunk/Devel-REPL/lib/Devel/REPL/Meta/
   trunk/Devel-REPL/lib/Devel/REPL/Meta/Plugin.pm
   trunk/Devel-REPL/lib/Devel/REPL/Plugin.pm
   trunk/Devel-REPL/lib/Devel/REPL/Plugin/Commands.pm
   trunk/Devel-REPL/lib/Devel/REPL/Profile.pm
   trunk/Devel-REPL/lib/Devel/REPL/Profile/
   trunk/Devel-REPL/lib/Devel/REPL/Profile/Default.pm
Modified:
   trunk/Devel-REPL/lib/Devel/REPL/Plugin/LexEnv.pm
   trunk/Devel-REPL/lib/Devel/REPL/Script.pm
   trunk/Devel-REPL/t/load_core.t
Log:
plugin metaclass, profiles, commands plugi

Added: trunk/Devel-REPL/lib/Devel/REPL/Meta/Plugin.pm
===================================================================
--- trunk/Devel-REPL/lib/Devel/REPL/Meta/Plugin.pm	                        (rev 0)
+++ trunk/Devel-REPL/lib/Devel/REPL/Meta/Plugin.pm	2007-06-27 07:20:56 UTC (rev 3545)
@@ -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;

Added: trunk/Devel-REPL/lib/Devel/REPL/Plugin/Commands.pm
===================================================================
--- trunk/Devel-REPL/lib/Devel/REPL/Plugin/Commands.pm	                        (rev 0)
+++ trunk/Devel-REPL/lib/Devel/REPL/Plugin/Commands.pm	2007-06-27 07:20:56 UTC (rev 3545)
@@ -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;

Modified: trunk/Devel-REPL/lib/Devel/REPL/Plugin/LexEnv.pm
===================================================================
--- trunk/Devel-REPL/lib/Devel/REPL/Plugin/LexEnv.pm	2007-06-27 05:59:28 UTC (rev 3544)
+++ trunk/Devel-REPL/lib/Devel/REPL/Plugin/LexEnv.pm	2007-06-27 07:20:56 UTC (rev 3545)
@@ -17,7 +17,11 @@
   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 {

Added: trunk/Devel-REPL/lib/Devel/REPL/Plugin.pm
===================================================================
--- trunk/Devel-REPL/lib/Devel/REPL/Plugin.pm	                        (rev 0)
+++ trunk/Devel-REPL/lib/Devel/REPL/Plugin.pm	2007-06-27 07:20:56 UTC (rev 3545)
@@ -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;

Added: trunk/Devel-REPL/lib/Devel/REPL/Profile/Default.pm
===================================================================
--- trunk/Devel-REPL/lib/Devel/REPL/Profile/Default.pm	                        (rev 0)
+++ trunk/Devel-REPL/lib/Devel/REPL/Profile/Default.pm	2007-06-27 07:20:56 UTC (rev 3545)
@@ -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;

Added: trunk/Devel-REPL/lib/Devel/REPL/Profile.pm
===================================================================
--- trunk/Devel-REPL/lib/Devel/REPL/Profile.pm	                        (rev 0)
+++ trunk/Devel-REPL/lib/Devel/REPL/Profile.pm	2007-06-27 07:20:56 UTC (rev 3545)
@@ -0,0 +1,8 @@
+package Devel::REPL::Profile;
+
+use Moose::Role;
+use namespace::clean -except => [ 'meta' ];
+
+requires 'apply_profile';
+
+1;

Modified: trunk/Devel-REPL/lib/Devel/REPL/Script.pm
===================================================================
--- trunk/Devel-REPL/lib/Devel/REPL/Script.pm	2007-06-27 05:59:28 UTC (rev 3544)
+++ trunk/Devel-REPL/lib/Devel/REPL/Script.pm	2007-06-27 07:20:56 UTC (rev 3545)
@@ -4,6 +4,7 @@
 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 @@
   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,14 +24,20 @@
 
 sub BUILD {
   my ($self) = @_;
-  $self->load_rcfile;
+  $self->load_profile($self->profile);
+  $self->load_rcfile($self->rcfile);
 }
 
+sub load_profile {
+  my ($self, $profile) = @_;
+  $profile = "Devel::REPL::Profile::${profile}" unless $profile =~ /::/;
+  Class::MOP::load_class($profile);
+  $profile->new->apply_profile($self->_repl);
+}
+
 sub load_rcfile {
-  my ($self) = @_;
+  my ($self, $rc_file) = @_;
 
-  my $rc_file = $self->rcfile;
-
   # plain name => ~/.re.pl/${rc_file}
   if ($rc_file !~ m!/!) {
     $rc_file = File::Spec->catfile(File::HomeDir->my_home, '.re.pl', $rc_file);
@@ -43,8 +54,9 @@
 }
 
 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 @@
   $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;

Modified: trunk/Devel-REPL/t/load_core.t
===================================================================
--- trunk/Devel-REPL/t/load_core.t	2007-06-27 05:59:28 UTC (rev 3544)
+++ trunk/Devel-REPL/t/load_core.t	2007-06-27 07:20:56 UTC (rev 3545)
@@ -7,3 +7,4 @@
 use_ok('Devel::REPL::Plugin::History');
 use_ok('Devel::REPL::Plugin::LexEnv');
 use_ok('Devel::REPL::Plugin::DDS');
+use_ok('Devel::REPL::Plugin::Commands');




More information about the Bast-commits mailing list