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