view release on metacpan or  search on metacpan

bin/perlbrewise-spec  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 ;