view release on metacpan or  search on metacpan

lib/Devel/IPerl/Plugin/Perlbrew.pm  view on Meta::CPAN

      }
      return $new->success;
    });
  }

  for my $name (qw{list list_modules}) {
    $iperl->helper("perlbrew_$name" => sub {
      my ($ip, $ret) = (shift, -1);
      return $ret if 0 == PERLBREW_INSTALLED;
      my $pb = PERLBREW_CLASS->new();
      $pb->home($domain->($ip));
      local $App::perlbrew::PERLBREW_HOME = $pb->home
        if ($name eq 'list_modules');
      return $pb->run_command($name, @_);
    });
  }

  for my $name (qw{lib_create}) {
    $iperl->helper("perlbrew_$name" => sub {
      my ($ip, $lib, $ret) = (shift, shift, -1);
      return $ret if not defined $lib;
      return $ret if 0 == PERLBREW_INSTALLED;
      my $pb = PERLBREW_CLASS->new();
      $pb->home($domain->($ip));
      eval { $pb->run_command_lib_create($class->_make_name($lib)); };
      return $@ ? 0 : 1;
    });
  }

  $iperl->helper('perlbrew_domain' => sub {
    my ($ip, $dir) = (shift, shift);
    return $domain->($ip) unless $dir && -d $dir;
    return $domain->($ip, $dir)->{'perlbrew_domain'};
  });

  return 1;
}

sub saved { return $_[0]{saved}  if @_ == 1; $_[0]{saved}  = $_[1]; $_[0]; }

sub spoil {
  my $self = shift;
  my %env  = %{$self->env || {}};
  my %save = %{$self->saved || {}};
  for my $var(_filtered_env_keys(\%env)) {
    if (exists $save{$var}) {
      say STDERR "revert ", join " = ", $var, $save{$var} if DEBUG;
      $ENV{$var} = $save{$var};
    } else {
      say STDERR "unset ", $var if DEBUG;
      delete $ENV{$var};
    }
  }
  if ($env{PERL5LIB}) {
    say STDERR join " = ", 'PERL5LIB', $env{'PERL5LIB'} if DEBUG;
    eval "no lib split ':', q[$env{PERL5LIB}];";
    warn $@ if $@; ## uncoverable branch true
    if ($self->unload) {
      my $path_re = qr{\Q$env{PERL5LIB}\E};
      for my $module_path(keys %INC) {
        ## autosplit modules
        next if $module_path =~ m{\.(al|ix)$} && delete $INC{$module_path};
        ## global destruction ?
        next if not defined $INC{$module_path};
        ## FatPacked ?
        next if ref($INC{$module_path});
        ## Not part of this PERL5LIB
        next if $INC{$module_path} !~ m{^$path_re};
        ## translate to class_path
        (my $class = $module_path) =~ s{/}{::}g;
        $class =~ s/\.pm//;
        ## notify and unload
        say "unloading $class ($module_path) from $INC{$module_path}";
        _teardown( $class );
        delete $INC{$module_path};
      }
    }
  }
  # no need to revert again.
  return $self->env({})->saved({});
}

sub success { scalar(keys %{$_[0]->{env}}) ? 1 : 0; }

sub unload { return $_[0]{unload} if @_ == 1; $_[0]{unload} = $_[1]; $_[0]; }

sub _filtered_env_keys {
  return (sort grep { m/^PERL/i && $_ ne "PERL5LIB" } keys %{+pop});
}

sub _from_binary_path {
  say STDERR $^X if DEBUG;
  if ($^X =~ m{/perls/([^/]+)/bin/perl}) { return $1; }
  (my $v = $^V->normal) =~ s/v/perl-/;
  return $v;
}

sub _make_name {
  my ($class, $name, $current) =
    (shift, shift, $ENV{PERLBREW_PERL} || _from_binary_path());
  my ($perl, $lib) =
    split /\@/, ($name =~ m/\@/ || $name eq $current ? $name : "\@$name");
  $perl = $current;
  return $perl unless $lib;
  return join '@', $perl, $lib;
}

## from Mojo::Util
sub _teardown {
  return unless my $class = shift;
  # @ISA has to be cleared first because of circular references
  no strict 'refs';
  @{"${class}::ISA"} = ();
  delete_package $class;
}

sub DESTROY {
  my $self = shift;
  say STDERR "DESTROY $self @$self{name}" if DEBUG;
  $self->spoil;
  return ;