view release on metacpan or  search on metacpan

lib/B/C.pm  view on Meta::CPAN

    $p =~ s/^main:://;
    if ($include_package{$p} and !exists $dumped_package{$p}
        and !$static_core_pkg{$p}
        and $p !~ /^(threads|main|__ANON__|PerlIO)$/
       )
    {
      next if $module and $p ne $module;
      if ($p eq 'warnings::register' and !$B::C::warnings) {
        delete_unsaved_hashINC('warnings::register');
        next;
      }
      $again++;
      warn "$p marked but not saved, save now\n" if $verbose or $debug{pkg};
      # mark_package( $p, 1);
      #eval {
      #  require(inc_packname($p)) && add_hashINC( $p );
      #} unless $savINC{inc_packname($p)};
      walk_syms( $p );
    }
  }
  $again;
}

my @made_c3;

sub make_c3 {
  my $package = shift or die;

  return if ( grep { $_ eq $package } @made_c3 );
  push @made_c3, $package;

  mark_package( 'mro', 1 );
  mark_package($package);
  my $isa_packages = mro::get_linear_isa($package) || [];
  foreach my $isa (@$isa_packages) {
    mark_package($isa);
  }
  warn "set c3 for $package\n" if $verbose or $debug{pkg};

  ## from setmro.xs:
  # classname = ST(0);
  # class_stash = gv_stashsv(classname, GV_ADD);
  # meta = HvMROMETA(class_stash);
  # Perl_mro_set_mro(aTHX_ meta, ST(1));

  $init2->add( sprintf( 'Perl_mro_set_mro(aTHX_ HvMROMETA(%s), newSVpvs("c3"));',
                        savestashpv($package) ) );
}

# global state only, unneeded for modules
sub save_context {
  # forbid run-time extends of curpad syms, names and INC
  warn "save context:\n" if $verbose;
  my $warner = $SIG{__WARN__};
  save_sig($warner) if $B::C::save_sig;
  # honour -w and %^H
  $init->add( "/* honor -w */",
    sprintf "PL_dowarn = ( %s ) ? G_WARN_ON : G_WARN_OFF;", $^W );
  if ($^{TAINT}) {
    $init->add( "/* honor -Tt */",
                "PL_tainting = TRUE;",
                # -T -1 false, -t 1 true
                "PL_taint_warn = ".($^{TAINT} < 0 ? "FALSE" : "TRUE").";");
  }

  if ($PERL510) {
    # need to mark assign c3 to %main::. no need to assign the default dfs
    if (is_using_mro() && mro::get_mro("main") eq 'c3') {
        make_c3('main');
    }
    # Tie::Hash::NamedCapture is added for *+ *-, Errno for *!
    #no strict 'refs';
    #if ( defined(objsym(svref_2object(\*{'main::+'}))) or defined(objsym(svref_2object(\*{'main::-'}))) ) {
    #  use strict 'refs';
    #  if (!$include_package{'Tie::Hash::NamedCapture'}) {
    #	$init->add("/* force saving of Tie::Hash::NamedCapture */");
    #    if ($] >= 5.014) {
    #      mark_package('Config', 1);  # DynaLoader needs Config to set the EGV
    #      walk_syms('Config');
    #      svref_2object(\&{'Tie::Hash::NamedCapture::bootstrap'})->save;
    #    }
    #	mark_package('Tie::Hash::NamedCapture', 1);
    #  } # else already included
    #} else {
    #  use strict 'refs';
    #  delete_unsaved_hashINC('Tie::Hash::NamedCapture');
    #}
    no strict 'refs';
    if ( defined(objsym(svref_2object(\*{'main::!'}))) ) {
      use strict 'refs';
      if (!$module and !$include_package{'Errno'}) {
	$init->add("/* force saving of Errno */");
	mark_package('Config', 1);
        walk_syms('Config');
	mark_package('Errno', 1);
        svref_2object(\&{'Errno::bootstrap'})->save;
      } # else already included
    } else {
      use strict 'refs';
      delete_unsaved_hashINC('Errno');
    }
  }

  my ($curpad_nam, $curpad_sym);
  {
    # Record comppad sv's names, may not be static
    local $B::C::const_strings = 0;
    $init->add("/* curpad names */");
    warn "curpad names:\n" if $verbose;
    $curpad_nam      = ( comppadlist->ARRAY )[0]->save('curpad_name');
    warn "curpad syms:\n" if $verbose;
    $init->add("/* curpad syms */");
    $curpad_sym      = ( comppadlist->ARRAY )[1]->save('curpad_syms');
  }
  my ($inc_hv, $inc_av);
  {
    local $B::C::const_strings = 1 if $B::C::ro_inc;
    warn "\%INC and \@INC:\n" if $verbose;
    $init->add('/* %INC */');
    inc_cleanup(0);
    my $inc_gv = svref_2object( \*main::INC );
    $inc_hv    = $inc_gv->HV->save('main::INC');
    if ($cross) {