view release on metacpan or  search on metacpan

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

    $dir =~ s(::)(/)g;
    warn "require \"auto/$dir/$cvname.al\"\n" if $debug{cv};
    eval { local $SIG{__DIE__}; require "auto/$dir/$cvname.al" unless $INC{"auto/$dir/$cvname.al"} };
    unless ($@) {
      warn "Forced load of \"auto/$dir/$cvname.al\"\n" if $verbose;
      return svref_2object( \&$fullname )
	if defined &$fullname;
    }
  }

  # XXX Still not found, now it's getting dangerous (until 5.10 only)
  # Search and call ::AUTOLOAD (=> ROOT and XSUB) (test 27, 5.8)
  # Since 5.10 AUTOLOAD xsubs are already resolved
  if (exists ${$cvstashname.'::'}{AUTOLOAD} and !$PERL510) {
    my $auto = \&{$cvstashname.'::AUTOLOAD'};
    # Tweaked version of __PACKAGE__::AUTOLOAD
    $AutoLoader::AUTOLOAD = ${$cvstashname.'::AUTOLOAD'} = "$cvstashname\::$cvname";

    # Prevent eval from polluting STDOUT,STDERR and our c code.
    # With a debugging perl STDERR is written
    local *REALSTDOUT;
    local *REALSTDERR unless $DEBUGGING;
    open(REALSTDOUT,">&STDOUT");
    open(REALSTDERR,">&STDERR") unless $DEBUGGING;
    open(STDOUT,">","/dev/null");
    open(STDERR,">","/dev/null") unless $DEBUGGING;
    warn "eval \&$cvstashname\::AUTOLOAD\n" if $debug{cv};
    eval { &$auto };
    open(STDOUT,">&REALSTDOUT");
    open(STDERR,">&REALSTDERR") unless $DEBUGGING;

    unless ($@) {
      # we need just the empty auto GV, $cvname->ROOT and $cvname->XSUB,
      # but not the whole CV optree. XXX This still fails with 5.8
      my $cv = svref_2object( \&{$fullname} );
      return $cv;
    }
  }

  # XXX TODO Check Selfloader (test 31?)
  svref_2object( \*{$cvstashname.'::AUTOLOAD'} )->save
    if $cvstashname and exists ${$cvstashname.'::'}{AUTOLOAD};
  svref_2object( \*{$cvstashname.'::CLONE'} )->save
    if $cvstashname and exists ${$cvstashname.'::'}{CLONE};
}
sub Dummy_initxs { }

# A lexical sub contains no CvGV, just a NAME_HEK, thus the name CvNAMED.
# More problematically $cv->GV vivifies the GV of a NAMED cv from an RV, so avoid !$cv->GV
# See https://github.com/perl11/cperl/issues/63
sub B::CV::is_named {
  my ($cv) = @_;
  return 0 unless $PERL518;
  return $cv->NAME_HEK if $cv->can('NAME_HEK');
  return 0;
  # my $gv = $cv->GV;
  # return (!$gv or ref($gv) eq 'B::SPECIAL')) ? 1 : 0;
}

sub is_phase_name {
  $_[0] =~ /^(BEGIN|INIT|UNITCHECK|CHECK|END)$/ ? 1 : 0;
}

sub B::CV::save {
  my ($cv, $origname) = @_;
  my $sym = objsym($cv);
  if ( defined($sym) ) {
    warn sprintf( "CV 0x%x already saved as $sym\n", $$cv ) if $$cv and $debug{cv};
    return $sym;
  }
  my $gv = $cv->is_named ? undef : $cv->GV;
  my ( $cvname, $cvstashname, $fullname, $isutf8 );
  $fullname = '';
  my $CvFLAGS = $cv->CvFLAGS;
  if (!$gv and $cv->is_named) {
    $fullname = $cv->NAME_HEK;
    $fullname = '' unless defined $fullname;
    $isutf8   = $cv->FLAGS & SVf_UTF8;
    warn sprintf( "CV lexsub NAME_HEK $fullname\n") if $debug{cv};
    if ($fullname =~ /^(.*)::(.*?)$/) {
      $cvstashname = $1;
      $cvname      = $2;
    }
  }
  elsif ($gv and $$gv) {
    $cvstashname = $gv->STASH->NAME;
    $cvname      = $gv->NAME;
    $isutf8      = ($gv->FLAGS & SVf_UTF8) || ($gv->STASH->FLAGS & SVf_UTF8);
    $fullname    = $cvstashname.'::'.$cvname;
    # XXX gv->EGV does not really help here
    if ($PERL522 and $cvname eq '__ANON__') {
      if ($origname) {
        warn sprintf( "CV with empty PVGV %s -> %s\n",
                      $fullname, $origname) if $debug{cv};
        $cvname = $fullname = $origname;
        $cvname =~ s/^\Q$cvstashname\E::(.*)( :pad\[.*)?$/$1/ if $cvstashname;
        $cvname =~ s/^.*:://;
        if ($cvname =~ m/ :pad\[.*$/) {
          $cvname =~ s/ :pad\[.*$//;
          $cvname = '__ANON__' if is_phase_name($cvname);
          $fullname  = $cvstashname.'::'.$cvname;
        }
        warn sprintf( "empty -> %s\n", $cvname) if $debug{cv};
      } else {
        $cvname = $gv->EGV->NAME;
        warn sprintf( "CV with empty PVGV %s -> %s::%s\n",
                      $fullname, $cvstashname, $cvname) if $debug{cv};
        $fullname  = $cvstashname.'::'.$cvname;
      }
    }
    warn sprintf( "CV 0x%x as PVGV 0x%x %s CvFLAGS=0x%x\n",
                  $$cv, $$gv, $fullname, $CvFLAGS ) if $debug{cv};
    # XXX not needed, we already loaded utf8_heavy
    #return if $fullname eq 'utf8::AUTOLOAD';
    return '0' if $all_bc_subs{$fullname} or skip_pkg($cvstashname);
    $CvFLAGS &= ~0x400 if $PERL514; # no CVf_CVGV_RC otherwise we cannot set the GV
    mark_package($cvstashname, 1) unless $include_package{$cvstashname};
  }
  $cvstashname = '' unless defined $cvstashname;

  # XXX TODO need to save the gv stash::AUTOLOAD if exists