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