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 #include "EXTERN.h"
  10 #include "perl.h"
  11
  12 #include "XSUB.h"
  13
  14 #ifdef PERL_IMPLICIT_SYS
  15 #include "win32iop.h"
  16 #include <fcntl.h>
  17 #endif /* PERL_IMPLICIT_SYS */
  18
  19
  20 /* Register any extra external extensions */
  21 const char * const staticlinkmodules[] = {
  22     "DynaLoader",
  23     /* other similar records will be included from "perllibst.h" */
  24 #define STATIC1
  25 #include "perllibst.h"
  26     NULL,
  27 };
  28
  29 EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
  30 /* other similar records will be included from "perllibst.h" */
  31 #define STATIC2
  32 #include "perllibst.h"
  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 #define STATIC3
  42 #include "perllibst.h"
  43 }
  44
  45 #ifdef PERL_IMPLICIT_SYS
  46
  47 /* WINCE: include replaced by:
  48 extern "C" void win32_checkTLS(PerlInterpreter *host_perl);
  49 */
  50 #include "perlhost.h"
  51
  52 void
  53 win32_checkTLS(PerlInterpreter *host_perl)
  54 {
  55     dTHX;
  56     if (host_perl != my_perl) {
  57         int *nowhere = NULL;
  58 #ifdef UNDER_CE
  59         printf(" ... bad in win32_checkTLS\n");
  60         printf("  %08X ne %08X\n",host_perl,my_perl);
  61 #endif
  62         abort();
  63     }
  64 }
  65
  66 #ifdef UNDER_CE
  67 int GetLogicalDrives() {
  68     return 0; /* no logical drives on CE */
  69 }
  70 int GetLogicalDriveStrings(int size, char addr[]) {
  71     return 0; /* no logical drives on CE */
  72 }
  73 /* TBD */
  74 DWORD GetFullPathNameA(LPCSTR fn, DWORD blen, LPTSTR buf,  LPSTR *pfile) {
  75     return 0;
  76 }
  77 /* TBD */
  78 DWORD GetFullPathNameW(CONST WCHAR *fn, DWORD blen, WCHAR * buf,  WCHAR **pfile) {
  79     return 0;
  80 }
  81 /* TBD */
  82 DWORD SetCurrentDirectoryA(LPSTR pPath) {
  83     return 0;
  84 }
  85 /* TBD */
  86 DWORD SetCurrentDirectoryW(CONST WCHAR *pPath) {
  87     return 0;
  88 }
  89 int xcesetuid(uid_t id){return 0;}
  90 int xceseteuid(uid_t id){  return 0;}
  91 int xcegetuid() {return 0;}
  92 int xcegeteuid(){ return 0;}
  93 #endif
  94
  95 /* WINCE??: include "perlhost.h" */
  96
  97 EXTERN_C void
  98 perl_get_host_info(struct IPerlMemInfo* perlMemInfo,
  99                    struct IPerlMemInfo* perlMemSharedInfo,
 100                    struct IPerlMemInfo* perlMemParseInfo,
 101                    struct IPerlEnvInfo* perlEnvInfo,
 102                    struct IPerlStdIOInfo* perlStdIOInfo,
 103                    struct IPerlLIOInfo* perlLIOInfo,
 104                    struct IPerlDirInfo* perlDirInfo,
 105                    struct IPerlSockInfo* perlSockInfo,
 106                    struct IPerlProcInfo* perlProcInfo)
 107 {
 108     if (perlMemInfo) {
 109         Copy(&perlMem, &perlMemInfo->perlMemList, perlMemInfo->nCount, void*);
 110         perlMemInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*));
 111     }
 112     if (perlMemSharedInfo) {
 113         Copy(&perlMem, &perlMemSharedInfo->perlMemList, perlMemSharedInfo->nCount, void*);
 114         perlMemSharedInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*));
 115     }
 116     if (perlMemParseInfo) {
 117         Copy(&perlMem, &perlMemParseInfo->perlMemList, perlMemParseInfo->nCount, void*);
 118         perlMemParseInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*));
 119     }
 120     if (perlEnvInfo) {
 121         Copy(&perlEnv, &perlEnvInfo->perlEnvList, perlEnvInfo->nCount, void*);
 122         perlEnvInfo->nCount = (sizeof(struct IPerlEnv)/sizeof(void*));
 123     }
 124     if (perlStdIOInfo) {
 125         Copy(&perlStdIO, &perlStdIOInfo->perlStdIOList, perlStdIOInfo->nCount, void*);
 126         perlStdIOInfo->nCount = (sizeof(struct IPerlStdIO)/sizeof(void*));
 127     }
 128     if (perlLIOInfo) {
 129         Copy(&perlLIO, &perlLIOInfo->perlLIOList, perlLIOInfo->nCount, void*);
 130         perlLIOInfo->nCount = (sizeof(struct IPerlLIO)/sizeof(void*));
 131     }
 132     if (perlDirInfo) {
 133         Copy(&perlDir, &perlDirInfo->perlDirList, perlDirInfo->nCount, void*);
 134         perlDirInfo->nCount = (sizeof(struct IPerlDir)/sizeof(void*));
 135     }
 136     if (perlSockInfo) {
 137         Copy(&perlSock, &perlSockInfo->perlSockList, perlSockInfo->nCount, void*);
 138         perlSockInfo->nCount = (sizeof(struct IPerlSock)/sizeof(void*));
 139     }
 140     if (perlProcInfo) {
 141         Copy(&perlProc, &perlProcInfo->perlProcList, perlProcInfo->nCount, void*);
 142         perlProcInfo->nCount = (sizeof(struct IPerlProc)/sizeof(void*));
 143     }
 144 }
 145
 146 EXTERN_C PerlInterpreter*
 147 perl_alloc_override(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared,
 148                  struct IPerlMem** ppMemParse, struct IPerlEnv** ppEnv,
 149                  struct IPerlStdIO** ppStdIO, struct IPerlLIO** ppLIO,
 150                  struct IPerlDir** ppDir, struct IPerlSock** ppSock,
 151                  struct IPerlProc** ppProc)
 152 {
 153     PerlInterpreter *my_perl = NULL;
 154     CPerlHost* pHost = new CPerlHost(ppMem, ppMemShared, ppMemParse, ppEnv,
 155                                      ppStdIO, ppLIO, ppDir, ppSock, ppProc);
 156
 157     if (pHost) {
 158         my_perl = perl_alloc_using(pHost->m_pHostperlMem,
 159                                    pHost->m_pHostperlMemShared,
 160                                    pHost->m_pHostperlMemParse,
 161                                    pHost->m_pHostperlEnv,
 162                                    pHost->m_pHostperlStdIO,
 163                                    pHost->m_pHostperlLIO,
 164                                    pHost->m_pHostperlDir,
 165                                    pHost->m_pHostperlSock,
 166                                    pHost->m_pHostperlProc);
 167         if (my_perl) {
 168             w32_internal_host = pHost;
 169             pHost->host_perl  = my_perl;
 170         }
 171     }
 172     return my_perl;
 173 }
 174
 175 EXTERN_C PerlInterpreter*
 176 perl_alloc(void)
 177 {
 178     PerlInterpreter* my_perl = NULL;
 179     CPerlHost* pHost = new CPerlHost();
 180     if (pHost) {
 181         my_perl = perl_alloc_using(pHost->m_pHostperlMem,
 182                                    pHost->m_pHostperlMemShared,
 183                                    pHost->m_pHostperlMemParse,
 184                                    pHost->m_pHostperlEnv,
 185                                    pHost->m_pHostperlStdIO,
 186                                    pHost->m_pHostperlLIO,
 187                                    pHost->m_pHostperlDir,
 188                                    pHost->m_pHostperlSock,
 189                                    pHost->m_pHostperlProc);
 190         if (my_perl) {
 191             w32_internal_host = pHost;
 192             pHost->host_perl  = my_perl;
 193         }
 194     }
 195     return my_perl;
 196 }
 197
 198 EXTERN_C void
 199 win32_delete_internal_host(void *h)
 200 {
 201     CPerlHost *host = (CPerlHost*)h;
 202     delete host;
 203 }
 204
 205 #endif /* PERL_IMPLICIT_SYS */
 206
 207 EXTERN_C HANDLE w32_perldll_handle;
 208
 209 EXTERN_C DllExport int
 210 RunPerl(int argc, char **argv, char **env)
 211 {
 212     int exitstatus;
 213     PerlInterpreter *my_perl, *new_perl = NULL;
 214     bool use_environ = (env == environ);
 215
 216 #ifdef PERL_GLOBAL_STRUCT
 217 #define PERLVAR(prefix,var,type) /**/
 218 #define PERLVARA(prefix,var,type) /**/
 219 #define PERLVARI(prefix,var,type,init) PL_Vars.prefix##var = init;
 220 #define PERLVARIC(prefix,var,type,init) PL_Vars.prefix##var = init;
 221 #include "perlvars.h"
 222 #undef PERLVAR
 223 #undef PERLVARA
 224 #undef PERLVARI
 225 #undef PERLVARIC
 226 #endif
 227
 228     PERL_SYS_INIT(&argc,&argv);
 229
 230     if (!(my_perl = perl_alloc()))
 231         return (1);
 232     perl_construct(my_perl);
 233     PL_perl_destruct_level = 0;
 234
 235     /* PERL_SYS_INIT() may update the environment, e.g. via ansify_path().
 236      * This may reallocate the RTL environment block. Therefore we need
 237      * to make sure that `env` continues to have the same value as `environ`
 238      * if we have been called this way.  If we have been called with any
 239      * other value for `env` then all environment munging by PERL_SYS_INIT()
 240      * will be lost again.
 241      */
 242     if (use_environ)
 243         env = environ;
 244
 245     exitstatus = perl_parse(my_perl, xs_init, argc, argv, env);
 246     if (!exitstatus) {
 247 #if defined(TOP_CLONE) && defined(USE_ITHREADS)         /* XXXXXX testing */
 248         new_perl = perl_clone(my_perl, 1);
 249         exitstatus = perl_run(new_perl);
 250         PERL_SET_THX(my_perl);
 251 #else
 252         exitstatus = perl_run(my_perl);
 253 #endif
 254     }
 255
 256     perl_destruct(my_perl);
 257     perl_free(my_perl);
 258 #ifdef USE_ITHREADS
 259     if (new_perl) {
 260         PERL_SET_THX(new_perl);
 261         perl_destruct(new_perl);
 262         perl_free(new_perl);
 263     }
 264 #endif
 265
 266     PERL_SYS_TERM();
 267
 268     return (exitstatus);
 269 }
 270
 271 EXTERN_C void
 272 set_w32_module_name(void);
 273
 274 EXTERN_C void
 275 EndSockets(void);
 276
 277
 278 #ifdef __MINGW32__
 279 EXTERN_C                /* GCC in C++ mode mangles the name, otherwise */
 280 #endif
 281 BOOL APIENTRY
 282 DllMain(HINSTANCE hModule,      /* DLL module handle */
 283         DWORD fdwReason,        /* reason called */
 284         LPVOID lpvReserved)     /* reserved */
 285 {
 286     switch (fdwReason) {
 287         /* The DLL is attaching to a process due to process
 288          * initialization or a call to LoadLibrary.
 289          */
 290     case DLL_PROCESS_ATTACH:
 291 #ifndef UNDER_CE
 292         DisableThreadLibraryCalls((HMODULE)hModule);
 293 #endif
 294
 295         w32_perldll_handle = hModule;
 296         set_w32_module_name();
 297         break;
 298
 299         /* The DLL is detaching from a process due to
 300          * process termination or call to FreeLibrary.
 301          */
 302     case DLL_PROCESS_DETACH:
 303         /* As long as we use TerminateProcess()/TerminateThread() etc. for mimicing kill()
 304            anything here had better be harmless if:
 305             A. Not called at all.
 306             B. Called after memory allocation for Heap has been forcibly removed by OS.
 307             PerlIO_cleanup() was done here but fails (B).
 308          */
 309         EndSockets();
 310 #if defined(USE_ITHREADS)
 311         if (PL_curinterp)
 312             FREE_THREAD_KEY;
 313 #endif
 314         break;
 315
 316         /* The attached process creates a new thread. */
 317     case DLL_THREAD_ATTACH:
 318         break;
 319
 320         /* The thread of the attached process terminates. */
 321     case DLL_THREAD_DETACH:
 322         break;
 323
 324     default:
 325         break;
 326     }
 327     return TRUE;
 328 }
 329
 330
 331 #if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
 332 EXTERN_C PerlInterpreter *
 333 perl_clone_host(PerlInterpreter* proto_perl, UV flags) {
 334     dTHX;
 335     CPerlHost *h;
 336     h = new CPerlHost(*(CPerlHost*)PL_sys_intern.internal_host);
 337     proto_perl = perl_clone_using(proto_perl, flags,
 338                         h->m_pHostperlMem,
 339                         h->m_pHostperlMemShared,
 340                         h->m_pHostperlMemParse,
 341                         h->m_pHostperlEnv,
 342                         h->m_pHostperlStdIO,
 343                         h->m_pHostperlLIO,
 344                         h->m_pHostperlDir,
 345                         h->m_pHostperlSock,
 346                         h->m_pHostperlProc
 347     );
 348     proto_perl->Isys_intern.internal_host = h;
 349     h->host_perl  = proto_perl;
 350     return proto_perl;
 351
 352 }
 353 #endif