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