[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