win32/perllib.c

   1 /*
   2  *      The Road goes ever on and on
   3  *          Down from the door where it began.
   4  *
   5  *     [Bilbo on p.35 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
   6  *     [Frodo on p.73 of _The Lord of the Rings_, I/iii: "Three Is Company"]
   7  */
   8 #define PERLIO_NOT_STDIO 0
   9 #define PERL_IN_WIN32_PERLLIB_C
  10 #include "EXTERN.h"
  11 #include "perl.h"
  12
  13 #include "XSUB.h"
  14 #include <winuser.h>
  15
  16 #ifdef PERL_IMPLICIT_SYS
  17 #include "win32iop.h"
  18 #include <fcntl.h>
  19 #endif /* PERL_IMPLICIT_SYS */
  20
  21
  22 /* Register any extra external extensions */
  23 const char * const staticlinkmodules[] = {
  24     "DynaLoader",
  25     /* other similar records will be included from "perllibst.h" */
  26 #define STATIC1
  27 #include "perllibst.h"
  28     NULL,
  29 };
  30
  31 EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
  32 /* other similar records will be included from "perllibst.h" */
  33 #define STATIC2
  34 #include "perllibst.h"
  35
  36 static void
  37 xs_init(pTHX)
  38 {
  39     const char *file = __FILE__;
  40     dXSUB_SYS;
  41     newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
  42     /* other similar records will be included from "perllibst.h" */
  43 #define STATIC3
  44 #include "perllibst.h"
  45 }
  46
  47 #ifdef PERL_IMPLICIT_SYS
  48
  49 #include "perlhost.h"
  50
  51 void
  52 win32_checkTLS(PerlInterpreter *host_perl)
  53 {
  54 /* GCurThdId() is lightweight, but b/c of the ctrl-c/signals sometimes firing
  55   in other random WinOS threads, that make the TIDs go out of sync.
  56   This isn't always an error, although high chance of a SEGV in the next
  57   couple milliseconds b/c of "Day 1 of Win32 port" Ctrl-C vs Perl bugs.
  58   Google it for details.  So this code, if TIDs don't match, do the full heavy
  59   TlsGetValue() + misc fn calls.  Then resync TIDs to keep this fast for
  60   future calls to this fn. */
  61     DWORD tid = GetCurrentThreadId();
  62     if(tid != host_perl->Isys_intern.cur_tid) {
  63         dTHX; /* heavyweight */
  64         if (host_perl != my_perl) {
  65             int *nowhere = NULL;
  66             abort();
  67         }
  68         host_perl->Isys_intern.cur_tid = tid;
  69     }
  70 }
  71
  72 EXTERN_C void
  73 perl_get_host_info(struct IPerlMemInfo* perlMemInfo,
  74                    struct IPerlMemInfo* perlMemSharedInfo,
  75                    struct IPerlMemInfo* perlMemParseInfo,
  76                    struct IPerlEnvInfo* perlEnvInfo,
  77                    struct IPerlStdIOInfo* perlStdIOInfo,
  78                    struct IPerlLIOInfo* perlLIOInfo,
  79                    struct IPerlDirInfo* perlDirInfo,
  80                    struct IPerlSockInfo* perlSockInfo,
  81                    struct IPerlProcInfo* perlProcInfo)
  82 {
  83     if (perlMemInfo) {
  84         Copy(&perlMem, &perlMemInfo->perlMemList, perlMemInfo->nCount, void*);
  85         perlMemInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*));
  86     }
  87     if (perlMemSharedInfo) {
  88         Copy(&perlMem, &perlMemSharedInfo->perlMemList, perlMemSharedInfo->nCount, void*);
  89         perlMemSharedInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*));
  90     }
  91     if (perlMemParseInfo) {
  92         Copy(&perlMem, &perlMemParseInfo->perlMemList, perlMemParseInfo->nCount, void*);
  93         perlMemParseInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*));
  94     }
  95     if (perlEnvInfo) {
  96         Copy(&perlEnv, &perlEnvInfo->perlEnvList, perlEnvInfo->nCount, void*);
  97         perlEnvInfo->nCount = (sizeof(struct IPerlEnv)/sizeof(void*));
  98     }
  99     if (perlStdIOInfo) {
 100         Copy(&perlStdIO, &perlStdIOInfo->perlStdIOList, perlStdIOInfo->nCount, void*);
 101         perlStdIOInfo->nCount = (sizeof(struct IPerlStdIO)/sizeof(void*));
 102     }
 103     if (perlLIOInfo) {
 104         Copy(&perlLIO, &perlLIOInfo->perlLIOList, perlLIOInfo->nCount, void*);
 105         perlLIOInfo->nCount = (sizeof(struct IPerlLIO)/sizeof(void*));
 106     }
 107     if (perlDirInfo) {
 108         Copy(&perlDir, &perlDirInfo->perlDirList, perlDirInfo->nCount, void*);
 109         perlDirInfo->nCount = (sizeof(struct IPerlDir)/sizeof(void*));
 110     }
 111     if (perlSockInfo) {
 112         Copy(&perlSock, &perlSockInfo->perlSockList, perlSockInfo->nCount, void*);
 113         perlSockInfo->nCount = (sizeof(struct IPerlSock)/sizeof(void*));
 114     }
 115     if (perlProcInfo) {
 116         Copy(&perlProc, &perlProcInfo->perlProcList, perlProcInfo->nCount, void*);
 117         perlProcInfo->nCount = (sizeof(struct IPerlProc)/sizeof(void*));
 118     }
 119 }
 120
 121 EXTERN_C PerlInterpreter*
 122 perl_alloc_override(const struct  IPerlMem** ppMem, const struct  IPerlMem** ppMemShared,
 123                  const struct  IPerlMem** ppMemParse, const struct  IPerlEnv** ppEnv,
 124                  const struct  IPerlStdIO** ppStdIO, const struct  IPerlLIO** ppLIO,
 125                  const struct  IPerlDir** ppDir, const struct  IPerlSock** ppSock,
 126                  const struct  IPerlProc** ppProc)
 127 {
 128     PerlInterpreter *my_perl = NULL;
 129     CPerlHost* pHost = new CPerlHost(ppMem, ppMemShared, ppMemParse, ppEnv,
 130                                      ppStdIO, ppLIO, ppDir, ppSock, ppProc);
 131
 132     if (pHost) {
 133         my_perl = perl_alloc_using(&pHost->m_pHostperlMem,
 134                                    &pHost->m_pHostperlMemShared,
 135                                    &pHost->m_pHostperlMemParse,
 136                                    &pHost->m_pHostperlEnv,
 137                                    &pHost->m_pHostperlStdIO,
 138                                    &pHost->m_pHostperlLIO,
 139                                    &pHost->m_pHostperlDir,
 140                                    &pHost->m_pHostperlSock,
 141                                    &pHost->m_pHostperlProc);
 142         if (my_perl) {
 143             w32_internal_host = pHost;
 144             pHost->host_perl  = my_perl;
 145         }
 146     }
 147     return my_perl;
 148 }
 149
 150 EXTERN_C PerlInterpreter*
 151 perl_alloc(void)
 152 {
 153     PerlInterpreter* my_perl = NULL;
 154     CPerlHost* pHost = new CPerlHost();
 155     if (pHost) {
 156         my_perl = perl_alloc_using(&pHost->m_pHostperlMem,
 157                                    &pHost->m_pHostperlMemShared,
 158                                    &pHost->m_pHostperlMemParse,
 159                                    &pHost->m_pHostperlEnv,
 160                                    &pHost->m_pHostperlStdIO,
 161                                    &pHost->m_pHostperlLIO,
 162                                    &pHost->m_pHostperlDir,
 163                                    &pHost->m_pHostperlSock,
 164                                    &pHost->m_pHostperlProc);
 165         if (my_perl) {
 166             w32_internal_host = pHost;
 167             pHost->host_perl  = my_perl;
 168         }
 169     }
 170     return my_perl;
 171 }
 172
 173 EXTERN_C void
 174 win32_delete_internal_host(void *h)
 175 {
 176     CPerlHost *host = (CPerlHost*)h;
 177     delete host;
 178 }
 179
 180 #endif /* PERL_IMPLICIT_SYS */
 181
 182 EXTERN_C HANDLE w32_perldll_handle;
 183
 184 EXTERN_C DllExport int
 185 RunPerl(int argc, char **argv, char **env)
 186 {
 187     int exitstatus;
 188     PerlInterpreter *my_perl, *new_perl = NULL;
 189     bool use_environ = (env == environ);
 190
 191     PERL_SYS_INIT(&argc,&argv);
 192
 193     if (!(my_perl = perl_alloc()))
 194         return (1);
 195     perl_construct(my_perl);
 196     PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
 197     PL_perl_destruct_level = 0;
 198
 199     /* PERL_SYS_INIT() may update the environment, e.g. via ansify_path().
 200      * This may reallocate the RTL environment block. Therefore we need
 201      * to make sure that `env` continues to have the same value as `environ`
 202      * if we have been called this way.  If we have been called with any
 203      * other value for `env` then all environment munging by PERL_SYS_INIT()
 204      * will be lost again.
 205      */
 206     if (use_environ)
 207         env = environ;
 208
 209     if (!perl_parse(my_perl, xs_init, argc, argv, env)) {
 210 #if defined(TOP_CLONE) && defined(USE_ITHREADS)         /* XXXXXX testing */
 211         new_perl = perl_clone(my_perl, 1);
 212         (void) perl_run(new_perl);
 213         PERL_SET_THX(my_perl);
 214 #else
 215         (void) perl_run(my_perl);
 216 #endif
 217     }
 218
 219     exitstatus = perl_destruct(my_perl);
 220     perl_free(my_perl);
 221 #ifdef USE_ITHREADS
 222     if (new_perl) {
 223         PERL_SET_THX(new_perl);
 224         exitstatus = perl_destruct(new_perl);
 225         perl_free(new_perl);
 226     }
 227 #endif
 228
 229     PERL_SYS_TERM();
 230
 231     return (exitstatus);
 232 }
 233
 234 EXTERN_C void
 235 set_w32_module_name(void);
 236
 237 EXTERN_C void
 238 EndSockets(void);
 239
 240
 241 #ifdef __MINGW32__
 242 EXTERN_C                /* GCC in C++ mode mangles the name, otherwise */
 243 #endif
 244 BOOL APIENTRY
 245 DllMain(HINSTANCE hModule,      /* DLL module handle */
 246         DWORD fdwReason,        /* reason called */
 247         LPVOID lpvReserved)     /* reserved */
 248 {
 249     switch (fdwReason) {
 250         /* The DLL is attaching to a process due to process
 251          * initialization or a call to LoadLibrary.
 252          */
 253     case DLL_PROCESS_ATTACH:
 254         DisableThreadLibraryCalls((HMODULE)hModule);
 255
 256         w32_perldll_handle = hModule;
 257         set_w32_module_name();
 258         break;
 259
 260         /* The DLL is detaching from a process due to
 261          * process termination or call to FreeLibrary.
 262          */
 263     case DLL_PROCESS_DETACH:
 264         /* As long as we use TerminateProcess()/TerminateThread() etc. for mimicking kill()
 265            anything here had better be harmless if:
 266             A. Not called at all.
 267             B. Called after memory allocation for Heap has been forcibly removed by OS.
 268             PerlIO_cleanup() was done here but fails (B).
 269          */
 270         EndSockets();
 271 #if defined(USE_ITHREADS)
 272         if (PL_curinterp)
 273             FREE_THREAD_KEY;
 274 #endif
 275         break;
 276
 277         /* The attached process creates a new thread. */
 278     case DLL_THREAD_ATTACH:
 279         break;
 280
 281         /* The thread of the attached process terminates. */
 282     case DLL_THREAD_DETACH:
 283         break;
 284
 285     default:
 286         break;
 287     }
 288     return TRUE;
 289 }
 290
 291
 292 #if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
 293 EXTERN_C PerlInterpreter *
 294 perl_clone_host(PerlInterpreter* proto_perl, UV flags) {
 295     dTHX;
 296     CPerlHost *h;
 297     h = new CPerlHost(*(CPerlHost*)PL_sys_intern.internal_host);
 298     proto_perl = perl_clone_using(proto_perl, flags,
 299                         &h->m_pHostperlMem,
 300                         &h->m_pHostperlMemShared,
 301                         &h->m_pHostperlMemParse,
 302                         &h->m_pHostperlEnv,
 303                         &h->m_pHostperlStdIO,
 304                         &h->m_pHostperlLIO,
 305                         &h->m_pHostperlDir,
 306                         &h->m_pHostperlSock,
 307                         &h->m_pHostperlProc
 308     );
 309     proto_perl->Isys_intern.internal_host = h;
 310     h->host_perl  = proto_perl;
 311     return proto_perl;
 312
 313 }
 314 #endif