win32/perllib.c

   1 /*
   2  * "The Road goes ever on and on, down from the door where it began."
   3  */
   4 #define PERLIO_NOT_STDIO 0
   5 #include "EXTERN.h"
   6 #include "perl.h"
   7
   8 #include "XSUB.h"
   9
  10 #ifdef PERL_IMPLICIT_SYS
  11 #include "win32iop.h"
  12 #include <fcntl.h>
  13 #endif /* PERL_IMPLICIT_SYS */
  14
  15
  16 /* Register any extra external extensions */
  17 char *staticlinkmodules[] = {
  18     "DynaLoader",
  19     /* other similar records will be included from "perllibst.h" */
  20 #ifdef WITH_STATIC
  21 #define STATIC1
  22 #include "perllibst.h"
  23 #endif
  24     NULL,
  25 };
  26
  27 EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
  28 /* other similar records will be included from "perllibst.h" */
  29 #ifdef WITH_STATIC
  30 #define STATIC2
  31 #include "perllibst.h"
  32 #endif
  33
  34 static void
  35 xs_init(pTHX)
  36 {
  37     char *file = __FILE__;
  38     dXSUB_SYS;
  39     newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
  40     /* other similar records will be included from "perllibst.h" */
  41 #ifdef WITH_STATIC
  42 #define STATIC3
  43 #include "perllibst.h"
  44 #endif
  45 }
  46
  47 #ifdef PERL_IMPLICIT_SYS
  48
  49 #include "perlhost.h"
  50
  51 void
  52 win32_checkTLS(PerlInterpreter *host_perl)
  53 {
  54     dTHX;
  55     if (host_perl != my_perl) {
  56         int *nowhere = NULL;
  57         *nowhere = 0;
  58         abort();
  59     }
  60 }
  61
  62 EXTERN_C void
  63 perl_get_host_info(struct IPerlMemInfo* perlMemInfo,
  64                    struct IPerlMemInfo* perlMemSharedInfo,
  65                    struct IPerlMemInfo* perlMemParseInfo,
  66                    struct IPerlEnvInfo* perlEnvInfo,
  67                    struct IPerlStdIOInfo* perlStdIOInfo,
  68                    struct IPerlLIOInfo* perlLIOInfo,
  69                    struct IPerlDirInfo* perlDirInfo,
  70                    struct IPerlSockInfo* perlSockInfo,
  71                    struct IPerlProcInfo* perlProcInfo)
  72 {
  73     if (perlMemInfo) {
  74         Copy(&perlMem, &perlMemInfo->perlMemList, perlMemInfo->nCount, void*);
  75         perlMemInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*));
  76     }
  77     if (perlMemSharedInfo) {
  78         Copy(&perlMem, &perlMemSharedInfo->perlMemList, perlMemSharedInfo->nCount, void*);
  79         perlMemSharedInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*));
  80     }
  81     if (perlMemParseInfo) {
  82         Copy(&perlMem, &perlMemParseInfo->perlMemList, perlMemParseInfo->nCount, void*);
  83         perlMemParseInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*));
  84     }
  85     if (perlEnvInfo) {
  86         Copy(&perlEnv, &perlEnvInfo->perlEnvList, perlEnvInfo->nCount, void*);
  87         perlEnvInfo->nCount = (sizeof(struct IPerlEnv)/sizeof(void*));
  88     }
  89     if (perlStdIOInfo) {
  90         Copy(&perlStdIO, &perlStdIOInfo->perlStdIOList, perlStdIOInfo->nCount, void*);
  91         perlStdIOInfo->nCount = (sizeof(struct IPerlStdIO)/sizeof(void*));
  92     }
  93     if (perlLIOInfo) {
  94         Copy(&perlLIO, &perlLIOInfo->perlLIOList, perlLIOInfo->nCount, void*);
  95         perlLIOInfo->nCount = (sizeof(struct IPerlLIO)/sizeof(void*));
  96     }
  97     if (perlDirInfo) {
  98         Copy(&perlDir, &perlDirInfo->perlDirList, perlDirInfo->nCount, void*);
  99         perlDirInfo->nCount = (sizeof(struct IPerlDir)/sizeof(void*));
 100     }
 101     if (perlSockInfo) {
 102         Copy(&perlSock, &perlSockInfo->perlSockList, perlSockInfo->nCount, void*);
 103         perlSockInfo->nCount = (sizeof(struct IPerlSock)/sizeof(void*));
 104     }
 105     if (perlProcInfo) {
 106         Copy(&perlProc, &perlProcInfo->perlProcList, perlProcInfo->nCount, void*);
 107         perlProcInfo->nCount = (sizeof(struct IPerlProc)/sizeof(void*));
 108     }
 109 }
 110
 111 EXTERN_C PerlInterpreter*
 112 perl_alloc_override(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared,
 113                  struct IPerlMem** ppMemParse, struct IPerlEnv** ppEnv,
 114                  struct IPerlStdIO** ppStdIO, struct IPerlLIO** ppLIO,
 115                  struct IPerlDir** ppDir, struct IPerlSock** ppSock,
 116                  struct IPerlProc** ppProc)
 117 {
 118     PerlInterpreter *my_perl = NULL;
 119     CPerlHost* pHost = new CPerlHost(ppMem, ppMemShared, ppMemParse, ppEnv,
 120                                      ppStdIO, ppLIO, ppDir, ppSock, ppProc);
 121
 122     if (pHost) {
 123         my_perl = perl_alloc_using(pHost->m_pHostperlMem,
 124                                    pHost->m_pHostperlMemShared,
 125                                    pHost->m_pHostperlMemParse,
 126                                    pHost->m_pHostperlEnv,
 127                                    pHost->m_pHostperlStdIO,
 128                                    pHost->m_pHostperlLIO,
 129                                    pHost->m_pHostperlDir,
 130                                    pHost->m_pHostperlSock,
 131                                    pHost->m_pHostperlProc);
 132         if (my_perl) {
 133             w32_internal_host = pHost;
 134             pHost->host_perl  = my_perl;
 135         }
 136     }
 137     return my_perl;
 138 }
 139
 140 EXTERN_C PerlInterpreter*
 141 perl_alloc(void)
 142 {
 143     PerlInterpreter* my_perl = NULL;
 144     CPerlHost* pHost = new CPerlHost();
 145     if (pHost) {
 146         my_perl = perl_alloc_using(pHost->m_pHostperlMem,
 147                                    pHost->m_pHostperlMemShared,
 148                                    pHost->m_pHostperlMemParse,
 149                                    pHost->m_pHostperlEnv,
 150                                    pHost->m_pHostperlStdIO,
 151                                    pHost->m_pHostperlLIO,
 152                                    pHost->m_pHostperlDir,
 153                                    pHost->m_pHostperlSock,
 154                                    pHost->m_pHostperlProc);
 155         if (my_perl) {
 156             w32_internal_host = pHost;
 157             pHost->host_perl  = my_perl;
 158         }
 159     }
 160     return my_perl;
 161 }
 162
 163 EXTERN_C void
 164 win32_delete_internal_host(void *h)
 165 {
 166     CPerlHost *host = (CPerlHost*)h;
 167     delete host;
 168 }
 169
 170 #endif /* PERL_IMPLICIT_SYS */
 171
 172 EXTERN_C HANDLE w32_perldll_handle;
 173
 174 EXTERN_C DllExport int
 175 RunPerl(int argc, char **argv, char **env)
 176 {
 177     int exitstatus;
 178     PerlInterpreter *my_perl, *new_perl = NULL;
 179
 180 #ifndef __BORLANDC__
 181     /* XXX this _may_ be a problem on some compilers (e.g. Borland) that
 182      * want to free() argv after main() returns.  As luck would have it,
 183      * Borland's CRT does the right thing to argv[0] already. */
 184     char szModuleName[MAX_PATH];
 185
 186     GetModuleFileName(NULL, szModuleName, sizeof(szModuleName));
 187     (void)win32_longpath(szModuleName);
 188     argv[0] = szModuleName;
 189 #endif
 190
 191 #ifdef PERL_GLOBAL_STRUCT
 192 #define PERLVAR(var,type) /**/
 193 #define PERLVARA(var,type) /**/
 194 #define PERLVARI(var,type,init) PL_Vars.var = init;
 195 #define PERLVARIC(var,type,init) PL_Vars.var = init;
 196 #include "perlvars.h"
 197 #undef PERLVAR
 198 #undef PERLVARA
 199 #undef PERLVARI
 200 #undef PERLVARIC
 201 #endif
 202
 203     PERL_SYS_INIT(&argc,&argv);
 204
 205     if (!(my_perl = perl_alloc()))
 206         return (1);
 207     perl_construct(my_perl);
 208     PL_perl_destruct_level = 0;
 209
 210     exitstatus = perl_parse(my_perl, xs_init, argc, argv, env);
 211     if (!exitstatus) {
 212 #if defined(TOP_CLONE) && defined(USE_ITHREADS)         /* XXXXXX testing */
 213         new_perl = perl_clone(my_perl, 1);
 214         exitstatus = perl_run(new_perl);
 215         PERL_SET_THX(my_perl);
 216 #else
 217         exitstatus = perl_run(my_perl);
 218 #endif
 219     }
 220
 221     perl_destruct(my_perl);
 222     perl_free(my_perl);
 223 #ifdef USE_ITHREADS
 224     if (new_perl) {
 225         PERL_SET_THX(new_perl);
 226         perl_destruct(new_perl);
 227         perl_free(new_perl);
 228     }
 229 #endif
 230
 231     PERL_SYS_TERM();
 232
 233     return (exitstatus);
 234 }
 235
 236 EXTERN_C void
 237 set_w32_module_name(void);
 238
 239 EXTERN_C void
 240 EndSockets(void);
 241
 242
 243 #ifdef __MINGW32__
 244 EXTERN_C                /* GCC in C++ mode mangles the name, otherwise */
 245 #endif
 246 BOOL APIENTRY
 247 DllMain(HANDLE hModule,         /* DLL module handle */
 248         DWORD fdwReason,        /* reason called */
 249         LPVOID lpvReserved)     /* reserved */
 250 {
 251     switch (fdwReason) {
 252         /* The DLL is attaching to a process due to process
 253          * initialization or a call to LoadLibrary.
 254          */
 255     case DLL_PROCESS_ATTACH:
 256 /* #define DEFAULT_BINMODE */
 257 #ifdef DEFAULT_BINMODE
 258         setmode( fileno( stdin  ), O_BINARY );
 259         setmode( fileno( stdout ), O_BINARY );
 260         setmode( fileno( stderr ), O_BINARY );
 261         _fmode = O_BINARY;
 262 #endif
 263         DisableThreadLibraryCalls((HMODULE)hModule);
 264         w32_perldll_handle = hModule;
 265         set_w32_module_name();
 266         break;
 267
 268         /* The DLL is detaching from a process due to
 269          * process termination or call to FreeLibrary.
 270          */
 271     case DLL_PROCESS_DETACH:
 272         /* As long as we use TerminateProcess()/TerminateThread() etc. for mimicing kill()
 273            anything here had better be harmless if:
 274             A. Not called at all.
 275             B. Called after memory allocation for Heap has been forcibly removed by OS.
 276             PerlIO_cleanup() was done here but fails (B).
 277          */
 278         EndSockets();
 279 #if defined(USE_ITHREADS)
 280         if (PL_curinterp)
 281             FREE_THREAD_KEY;
 282 #endif
 283         break;
 284
 285         /* The attached process creates a new thread. */
 286     case DLL_THREAD_ATTACH:
 287         break;
 288
 289         /* The thread of the attached process terminates. */
 290     case DLL_THREAD_DETACH:
 291         break;
 292
 293     default:
 294         break;
 295     }
 296     return TRUE;
 297 }
 298
 299 #if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
 300 EXTERN_C PerlInterpreter *
 301 perl_clone_host(PerlInterpreter* proto_perl, UV flags) {
 302     dTHX;
 303     CPerlHost *h;
 304     h = new CPerlHost(*(CPerlHost*)PL_sys_intern.internal_host);
 305     proto_perl = perl_clone_using(proto_perl, flags,
 306                         h->m_pHostperlMem,
 307                         h->m_pHostperlMemShared,
 308                         h->m_pHostperlMemParse,
 309                         h->m_pHostperlEnv,
 310                         h->m_pHostperlStdIO,
 311                         h->m_pHostperlLIO,
 312                         h->m_pHostperlDir,
 313                         h->m_pHostperlSock,
 314                         h->m_pHostperlProc
 315     );
 316     proto_perl->Isys_intern.internal_host = h;
 317     h->host_perl  = proto_perl;
 318     return proto_perl;
 319
 320 }
 321 #endif