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