view release on metacpan or  search on metacpan

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

    my $stsym = $stash->save;
    my $name  = cstring($cvname);
    if ($] >= 5.016) { # need to check 'Encode::XS' constant encodings
      # warn "$sv CONSTSUB $name";
      if ((ref($sv) eq 'B::IV' or ref($sv) eq 'B::PVMG') and $sv->FLAGS & SVf_ROK) {
        my $rv = $sv->RV;
        if ($rv->FLAGS & (SVp_POK|SVf_IOK) and $rv->IVX > LOWEST_IMAGEBASE) {
          patch_dlsym($rv, $fullname, $rv->IVX);
        }
      }
    }
    # scalarref: t/CORE/v5.22/t/op/const-optree.t at curpad_syms[6]
    # main::__ANON__ -> CxPOPSUB_DONE=SCALAR
    # TODO Attribute::Handlers #171, test 176
    if ($sv and ref($sv) and ref($sv) =~ /^(SCALAR|ARRAY|HASH|CODE|REF)$/) {
      # Save XSUBANY, maybe ARRAY or HASH also?
      warn "SCALAR const sub $cvstashname\::$cvname -> $sv\n" if $debug{cv};
      my $vsym = svref_2object( \$sv )->save;
      my $cvi = "cv".$cv_index++;
      $decl->add("Static CV* $cvi;");
      $init->add("$cvi = newCONSTSUB( $stsym, $name, (SV*)$vsym );");
      return savesym( $cv, $cvi );
    }
    elsif ($sv and ref($sv) =~ /^B::[ANRPI]/) { # use constant => ()
      my $vsym  = $sv->save;
      my $cvi = "cv".$cv_index++;
      $decl->add("Static CV* $cvi;");
      $init->add("$cvi = newCONSTSUB( $stsym, $name, (SV*)$vsym );");
      return savesym( $cv, $cvi );
    } else {
      warn "Warning: Undefined const sub $cvstashname\::$cvname -> $sv\n" if $verbose;
    }
  }

  # This define is forwarded to the real sv below
  # The new method, which saves a SV only works since 5.10 (? Does not work in newer perls)
  my $sv_ix = $svsect->index + 1;
  my $xpvcv_ix;
  my $new_cv_fw = 0;#$PERL510; # XXX this does not work yet
  if ($new_cv_fw) {
    $sym = savesym( $cv, "CVIX$sv_ix" );
  } else {
    $svsect->add("CVIX$sv_ix");
    $svsect->debug( "&".$fullname, $cv->flagspv ) if $debug{flags};
    $xpvcv_ix = $xpvcvsect->index + 1;
    $xpvcvsect->add("XPVCVIX$xpvcv_ix");
    # Save symbol now so that GvCV() doesn't recurse back to us via CvGV()
    $sym = savesym( $cv, "&sv_list[$sv_ix]" );
  }

  warn sprintf( "saving %s CV 0x%x as %s\n", $fullname, $$cv, $sym )
    if $debug{cv};
  if (!$$root and $] < 5.010) {
    $package_pv = $cvstashname;
    push_package($package_pv);
  }
  if ($fullname eq 'utf8::SWASHNEW') { # bypass utf8::AUTOLOAD, a new 5.13.9 mess
    load_utf8_heavy();
  }

  if ($fullname eq 'IO::Socket::SSL::SSL_Context::new') {
    if ($IO::Socket::SSL::VERSION ge '1.956' and $IO::Socket::SSL::VERSION lt '1.995') {
      # See https://code.google.com/p/perl-compiler/issues/detail?id=317
      # https://rt.cpan.org/Ticket/Display.html?id=95452
      warn "Warning: Your IO::Socket::SSL version $IO::Socket::SSL::VERSION is unsupported to create\n".
           "  a server. You need to upgrade IO::Socket::SSL to at least 1.995 [CPAN #95452]\n";
    }
  }

  if (!$$root && !$cvxsub) {
    my $reloaded;
    if ($cvstashname =~ /^(bytes|utf8)$/) { # no autoload, force compile-time
      force_heavy($cvstashname);
      $cv = svref_2object( \&{$cvstashname."::".$cvname} );
      $reloaded = 1;
    } elsif ($fullname eq 'Coro::State::_jit') { # 293
      # need to force reload the jit src
      my ($pl) = grep { m|^Coro/jit-| } keys %INC;
      if ($pl) {
        delete $INC{$pl};
        require $pl;
        $cv = svref_2object( \&{$fullname} );
        $reloaded = 1;
      }
    }
    if ($reloaded) {
      if (!$cv->is_named) {
        $gv = $cv->GV;
        warn sprintf( "Redefined CV 0x%x as PVGV 0x%x %s CvFLAGS=0x%x\n",
                      $$cv, $$gv, $fullname, $CvFLAGS ) if $debug{cv};
      } else {
        $fullname = $cv->NAME_HEK;
        $fullname = '' unless defined $fullname;
        if ($fullname =~ /^(.*)::(.*?)$/) {
          $cvstashname = $1;
          $cvname      = $2;
        }
        warn sprintf( "Redefined CV 0x%x as NAMED %s CvFLAGS=0x%x\n",
                      $$cv, $fullname, $CvFLAGS ) if $debug{cv};
      }
      $sym = savesym( $cv, $sym );
      $root    = $cv->ROOT;
      $cvxsub  = $cv->XSUB;
    }
  }
  if ( !$$root && !$cvxsub ) {
    if ( my $auto = try_autoload( $cvstashname, $cvname ) ) {
      if (ref $auto eq 'B::CV') { # explicit goto or UNIVERSAL
        $root   = $auto->ROOT;
        $cvxsub = $auto->XSUB;
	if ($$auto) {
	  # XXX This has now created a wrong GV name!
	  my $oldcv = $cv;
	  $cv  = $auto ; # This is new. i.e. via AUTOLOAD or UNIVERSAL, in another stash
	  my $gvnew = $cv->GV;
	  if ($$gvnew) {
	    if ($cvstashname ne $gvnew->STASH->NAME or $cvname ne $gvnew->NAME) { # UNIVERSAL or AUTOLOAD
	      my $newname = $gvnew->STASH->NAME."::".$gvnew->NAME;
	      warn " New $newname autoloaded. remove old cv\n" if $debug{sub}; # and wrong GV?
	      unless ($new_cv_fw) {
		$svsect->remove;
		$xpvcvsect->remove;
	      }
	      delsym($oldcv);
	      return $cv->save($newname) if !$PERL510;