lib/Devel/REPL/Script.pm

   1 package Devel::REPL::Script;
   2
   3 use Moo;
   4 use Devel::REPL;
   5 use File::HomeDir;
   6 use File::Spec;
   7 use vars qw($CURRENT_SCRIPT);
   8 use namespace::sweep;
   9 use Getopt::Long;
  10 use MooX::Types::MooseLike::Base qw(Str InstanceOf);
  11 use Module::Load ();
  12 use Carp qw(confess);
  13
  14 has 'rcfile' => (
  15   is => 'rw',
  16   isa => Str,
  17   required => 1,
  18 );
  19
  20 has 'profile' => (
  21   is       => 'rw',
  22   isa      => Str,
  23   required => 1,
  24 );
  25
  26 has '_repl' => (
  27   is => 'ro', isa => InstanceOf('Devel::REPL'), required => 1,
  28   default => sub { Devel::REPL->new() }
  29 );
  30
  31 sub new_with_options {
  32   my ($class) = @_;
  33
  34   my $rcfile  = 'repl.rc';
  35   my $profile = $ENV{DEVEL_REPL_PROFILE} || 'Default';
  36   GetOptions(
  37       'rcfile=s'  => \$rcfile,
  38       'profile=s' => \$profile,
  39   );
  40   $class->new(profile => $profile, rcfile => $rcfile);
  41 }
  42
  43 sub BUILD {
  44   my ($self) = @_;
  45   $self->load_profile($self->profile);
  46   $self->load_rcfile($self->rcfile);
  47 }
  48
  49 sub load_profile {
  50   my ($self, $profile) = @_;
  51   $profile = "Devel::REPL::Profile::${profile}" unless $profile =~ /::/;
  52   Module::Load::load($profile);
  53   confess "Profile class ${profile} doesn't do 'Devel::REPL::Profile'"
  54     unless $profile->does('Devel::REPL::Profile');
  55   $profile->new->apply_profile($self->_repl);
  56 }
  57
  58 sub load_rcfile {
  59   my ($self, $rc_file) = @_;
  60
  61   # plain name => ~/.re.pl/${rc_file}
  62   if ($rc_file !~ m!/!) {
  63     $rc_file = File::Spec->catfile(File::HomeDir->my_home, '.re.pl', $rc_file);
  64   }
  65
  66   $self->apply_script($rc_file);
  67 }
  68
  69 sub apply_script {
  70   my ($self, $script, $warn_on_unreadable) = @_;
  71
  72   if (!-e $script) {
  73     warn "File '$script' does not exist" if $warn_on_unreadable;
  74     return;
  75   }
  76   elsif (!-r _) {
  77     warn "File '$script' is unreadable" if $warn_on_unreadable;
  78     return;
  79   }
  80
  81   open RCFILE, '<', $script or die "Couldn't open ${script}: $!";
  82   my $rc_data;
  83   { local $/; $rc_data = <RCFILE>; }
  84   close RCFILE; # Don't care if this fails
  85   $self->eval_script($rc_data);
  86   warn "Error executing script ${script}: $@\n" if $@;
  87 }
  88
  89 sub eval_script {
  90   my ($self, $data) = @_;
  91   local $CURRENT_SCRIPT = $self;
  92   $self->_repl->eval($data);
  93 }
  94
  95 sub run {
  96   my ($self) = @_;
  97   $self->_repl->run;
  98 }
  99
 100 sub import {
 101   my ($class, @opts) = @_;
 102   return unless (@opts == 1 && $opts[0] eq 'run');
 103   $class->new_with_options->run;
 104 }
 105
 106 sub current {
 107   confess "->current should only be called as class method" if ref($_[0]);
 108   confess "No current instance (valid only during rc parse)"
 109     unless $CURRENT_SCRIPT;
 110   return $CURRENT_SCRIPT;
 111 }
 112
 113 1;