view release on metacpan or  search on metacpan

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

          $init2->add( "", sprintf("  handle = dlopen(%s, %s);", cstring($init2_remap{$pkg}{FILE}), $ldopt));
        }
        else {
          $init2->add("  PUSHMARK(SP);",
              sprintf("  XPUSHs(newSVpvs(%s));", cstring($init2_remap{$pkg}{FILE})),
                      "  PUTBACK;",
                      "  XS_DynaLoader_dl_load_file(aTHX_ NULL);",
                      "  SPAGAIN;",
                      "  handle = INT2PTR(void*,POPi);",
                      "  PUTBACK;",
                     );
        }
        for my $mg (@{$init2_remap{$pkg}{MG}}) {
          warn "init2 remap xpvmg_list[$mg->{ID}].xiv_iv to dlsym of $pkg\: $mg->{NAME}\n"
            if $verbose;
          if ($HAVE_DLFCN_DLOPEN) {
            $init2->add(sprintf("  xpvmg_list[%d].xiv_iv = PTR2IV( dlsym(handle, %s) );",
                                $mg->{ID}, cstring($mg->{NAME})));
          } else {
            $init2->add("  PUSHMARK(SP);",
                        "  XPUSHi(PTR2IV(handle));",
                sprintf("  XPUSHs(newSVpvs(%s));", cstring($mg->{NAME})),
                        "  PUTBACK;",
                        "  XS_DynaLoader_dl_find_symbol(aTHX_ NULL);",
                        "  SPAGAIN;",
                sprintf("  xpvmg_list[%d].xiv_iv = POPi;", $mg->{ID}),
                        "  PUTBACK;",
                       );
          }
        }
      }
    }
    $init2->add("}");
    $init2->split;
  }
  $init2->output( \*STDOUT, "\t%s\n", $init2_name );
  if ($verbose) {
    my $caller = caller;
    warn $caller eq 'B::CC' ? B::CC::compile_stats() : compile_stats();
    warn "NULLOP count: $nullop_count\n";
  }
}

sub output_declarations {
  print <<'EOT';
#define UNUSED 0
#define sym_0 0

static void
my_mg_RC_off(pTHX_ SV* sv, int type) {
  MAGIC *mg;
  for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
    if (mg->mg_type == type && (mg->mg_flags | MGf_REFCOUNTED))
      mg->mg_flags &= ~MGf_REFCOUNTED;
  }
}

EOT
  if ($PERL510 and IS_MSVC) {
    # initializing char * differs in levels of indirection from int
    print "#pragma warning( disable : 4047 )\n";
    # targ: unreferenced local variable
    print "#pragma warning( disable : 4101 )\n";
  }

  # Need fresh re-hash of strtab. share_hek does not allow hash = 0
  if ( $PERL510 ) {
     print <<'_EOT0';
PERL_STATIC_INLINE HEK *
my_share_hek( pTHX_ const char *str, I32 len );
#undef share_hek
#define share_hek(str, len) my_share_hek( aTHX_ str, len );

PERL_STATIC_INLINE HEK *
my_share_hek_0( pTHX_ const char *str, I32 len);

#define HEK_HE(hek)							\
    ((struct shared_he *)(((char *)(hek))				\
			      - STRUCT_OFFSET(struct shared_he,		\
					      shared_he_hek)))
#define HEK_shared_he(hek)						\
    ((struct shared_he *)(((char *)(hek))				\
			      - STRUCT_OFFSET(struct shared_he,		\
					      shared_he_hek)))		\
	->shared_he_he

#define hek_hek_refcount(hek)						\
    HEK_shared_he(hek).he_valu.hent_refcount

#define unshare_hek_hek(hek)   --(hek_hek_refcount(hek))

_EOT0

  }
  if ($PERL522) {
    print <<'EOF';
/* unfortunately we have to override this perl5.22 struct.
   The Padname string buffer in xpadn_str is pointed by xpadn_pv.
    */
#define _PADNAME_BASE \
    char *	xpadn_pv;		\
    HV *	xpadn_ourstash;		\
    union {				\
	HV *	xpadn_typestash;	\
	CV *	xpadn_protocv;		\
    } xpadn_type_u;			\
    U32		xpadn_low;		\
    U32		xpadn_high;		\
    U32		xpadn_refcnt;		\
    int		xpadn_gen;		\
    U8		xpadn_len;		\
    U8		xpadn_flags

#ifdef PERL_PADNAME_MINIMAL
#define MY_PADNAME_BASE _PADNAME_BASE
#else
#define MY_PADNAME_BASE struct padname	xpadn_padname
#endif

EOF