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     char *arg0 = argv[0];
 215     char *ansi = NULL;
 216     bool use_environ = (env == environ);
 217
 218     WCHAR widename[MAX_PATH];
 219     GetModuleFileNameW(NULL, widename, sizeof(widename)/sizeof(WCHAR));
 220     argv[0] = ansi = win32_ansipath(widename);
 221
 222 #ifdef PERL_GLOBAL_STRUCT
 223 #define PERLVAR(prefix,var,type) /**/
 224 #define PERLVARA(prefix,var,type) /**/
 225 #define PERLVARI(prefix,var,type,init) PL_Vars.prefix##var = init;
 226 #define PERLVARIC(prefix,var,type,init) PL_Vars.prefix##var = init;
 227 #include "perlvars.h"
 228 #undef PERLVAR
 229 #undef PERLVARA
 230 #undef PERLVARI
 231 #undef PERLVARIC
 232 #endif
 233
 234     PERL_SYS_INIT(&argc,&argv);
 235
 236     if (!(my_perl = perl_alloc()))
 237         return (1);
 238     perl_construct(my_perl);
 239     PL_perl_destruct_level = 0;
 240
 241     /* PERL_SYS_INIT() may update the environment, e.g. via ansify_path().
 242      * This may reallocate the RTL environment block. Therefore we need
 243      * to make sure that `env` continues to have the same value as `environ`
 244      * if we have been called this way.  If we have been called with any
 245      * other value for `env` then all environment munging by PERL_SYS_INIT()
 246      * will be lost again.
 247      */
 248     if (use_environ)
 249         env = environ;
 250
 251     exitstatus = perl_parse(my_perl, xs_init, argc, argv, env);
 252     if (!exitstatus) {
 253 #if defined(TOP_CLONE) && defined(USE_ITHREADS)         /* XXXXXX testing */
 254         new_perl = perl_clone(my_perl, 1);
 255         exitstatus = perl_run(new_perl);
 256         PERL_SET_THX(my_perl);
 257 #else
 258         exitstatus = perl_run(my_perl);
 259 #endif
 260     }
 261
 262     perl_destruct(my_perl);
 263     perl_free(my_perl);
 264 #ifdef USE_ITHREADS
 265     if (new_perl) {
 266         PERL_SET_THX(new_perl);
 267         perl_destruct(new_perl);
 268         perl_free(new_perl);
 269     }
 270 #endif
 271
 272     /* Some RTLs may want to free argv[] after main() returns. */
 273     argv[0] = arg0;
 274     if (ansi)
 275         win32_free(ansi);
 276
 277     PERL_SYS_TERM();
 278
 279     return (exitstatus);
 280 }
 281
 282 EXTERN_C void
 283 set_w32_module_name(void);
 284
 285 EXTERN_C void
 286 EndSockets(void);
 287
 288
 289 #ifdef __MINGW32__
 290 EXTERN_C                /* GCC in C++ mode mangles the name, otherwise */
 291 #endif
 292 BOOL APIENTRY
 293 DllMain(HINSTANCE hModule,      /* DLL module handle */
 294         DWORD fdwReason,        /* reason called */
 295         LPVOID lpvReserved)     /* reserved */
 296 {
 297     switch (fdwReason) {
 298         /* The DLL is attaching to a process due to process
 299          * initialization or a call to LoadLibrary.
 300          */
 301     case DLL_PROCESS_ATTACH:
 302 #ifndef UNDER_CE
 303         DisableThreadLibraryCalls((HMODULE)hModule);
 304 #endif
 305
 306         w32_perldll_handle = hModule;
 307         set_w32_module_name();
 308         break;
 309
 310         /* The DLL is detaching from a process due to
 311          * process termination or call to FreeLibrary.
 312          */
 313     case DLL_PROCESS_DETACH:
 314         /* As long as we use TerminateProcess()/TerminateThread() etc. for mimicing kill()
 315            anything here had better be harmless if:
 316             A. Not called at all.
 317             B. Called after memory allocation for Heap has been forcibly removed by OS.
 318             PerlIO_cleanup() was done here but fails (B).
 319          */
 320         EndSockets();
 321 #if defined(USE_ITHREADS)
 322         if (PL_curinterp)
 323             FREE_THREAD_KEY;
 324 #endif
 325         break;
 326
 327         /* The attached process creates a new thread. */
 328     case DLL_THREAD_ATTACH:
 329         break;
 330
 331         /* The thread of the attached process terminates. */
 332     case DLL_THREAD_DETACH:
 333         break;
 334
 335     default:
 336         break;
 337     }
 338     return TRUE;
 339 }
 340
 341
 342 #if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
 343 EXTERN_C PerlInterpreter *
 344 perl_clone_host(PerlInterpreter* proto_perl, UV flags) {
 345     dTHX;
 346     CPerlHost *h;
 347     h = new CPerlHost(*(CPerlHost*)PL_sys_intern.internal_host);
 348     proto_perl = perl_clone_using(proto_perl, flags,
 349                         h->m_pHostperlMem,
 350                         h->m_pHostperlMemShared,
 351                         h->m_pHostperlMemParse,
 352                         h->m_pHostperlEnv,
 353                         h->m_pHostperlStdIO,
 354                         h->m_pHostperlLIO,
 355                         h->m_pHostperlDir,
 356                         h->m_pHostperlSock,
 357                         h->m_pHostperlProc
 358     );
 359     proto_perl->Isys_intern.internal_host = h;
 360     h->host_perl  = proto_perl;
 361     return proto_perl;
 362
 363 }
 364 #endif