"Fossies" - the Fresh Open Source Software Archive

Member "install-tl-20200916/tlpkg/tlperl/lib/CORE/perlhost.h" (7 Mar 2020, 53396 Bytes) of package /windows/misc/install-tl.zip:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) C and C++ source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

    1 /* perlhost.h
    2  *
    3  * (c) 1999 Microsoft Corporation. All rights reserved.
    4  * Portions (c) 1999 ActiveState Tool Corp, http://www.ActiveState.com/
    5  *
    6  *    You may distribute under the terms of either the GNU General Public
    7  *    License or the Artistic License, as specified in the README file.
    8  */
    9 
   10 #ifndef UNDER_CE
   11 #define CHECK_HOST_INTERP
   12 #endif
   13 
   14 #ifndef ___PerlHost_H___
   15 #define ___PerlHost_H___
   16 
   17 #ifndef UNDER_CE
   18 #include <signal.h>
   19 #endif
   20 #include "iperlsys.h"
   21 #include "vmem.h"
   22 #include "vdir.h"
   23 
   24 #ifndef WC_NO_BEST_FIT_CHARS
   25 #  define WC_NO_BEST_FIT_CHARS 0x00000400
   26 #endif
   27 
   28 START_EXTERN_C
   29 extern char *   g_getlogin(void);
   30 END_EXTERN_C
   31 
   32 class CPerlHost
   33 {
   34 public:
   35     /* Constructors */
   36     CPerlHost(void);
   37     CPerlHost(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared,
   38          struct IPerlMem** ppMemParse, struct IPerlEnv** ppEnv,
   39          struct IPerlStdIO** ppStdIO, struct IPerlLIO** ppLIO,
   40          struct IPerlDir** ppDir, struct IPerlSock** ppSock,
   41          struct IPerlProc** ppProc);
   42     CPerlHost(CPerlHost& host);
   43     ~CPerlHost(void);
   44 
   45     static CPerlHost* IPerlMem2Host(struct IPerlMem* piPerl);
   46     static CPerlHost* IPerlMemShared2Host(struct IPerlMem* piPerl);
   47     static CPerlHost* IPerlMemParse2Host(struct IPerlMem* piPerl);
   48     static CPerlHost* IPerlEnv2Host(struct IPerlEnv* piPerl);
   49     static CPerlHost* IPerlStdIO2Host(struct IPerlStdIO* piPerl);
   50     static CPerlHost* IPerlLIO2Host(struct IPerlLIO* piPerl);
   51     static CPerlHost* IPerlDir2Host(struct IPerlDir* piPerl);
   52     static CPerlHost* IPerlSock2Host(struct IPerlSock* piPerl);
   53     static CPerlHost* IPerlProc2Host(struct IPerlProc* piPerl);
   54 
   55     BOOL PerlCreate(void);
   56     int PerlParse(int argc, char** argv, char** env);
   57     int PerlRun(void);
   58     void PerlDestroy(void);
   59 
   60 /* IPerlMem */
   61     /* Locks provided but should be unnecessary as this is private pool */
   62     inline void* Malloc(size_t size) { return m_pVMem->Malloc(size); };
   63     inline void* Realloc(void* ptr, size_t size) { return m_pVMem->Realloc(ptr, size); };
   64     inline void Free(void* ptr) { m_pVMem->Free(ptr); };
   65     inline void* Calloc(size_t num, size_t size)
   66     {
   67     size_t count = num*size;
   68     void* lpVoid = Malloc(count);
   69     if (lpVoid)
   70         ZeroMemory(lpVoid, count);
   71     return lpVoid;
   72     };
   73     inline void GetLock(void) { m_pVMem->GetLock(); };
   74     inline void FreeLock(void) { m_pVMem->FreeLock(); };
   75     inline int IsLocked(void) { return m_pVMem->IsLocked(); };
   76 
   77 /* IPerlMemShared */
   78     /* Locks used to serialize access to the pool */
   79     inline void GetLockShared(void) { m_pVMemShared->GetLock(); };
   80     inline void FreeLockShared(void) { m_pVMemShared->FreeLock(); };
   81     inline int IsLockedShared(void) { return m_pVMemShared->IsLocked(); };
   82     inline void* MallocShared(size_t size)
   83     {
   84     void *result;
   85     GetLockShared();
   86     result = m_pVMemShared->Malloc(size);
   87     FreeLockShared();
   88     return result;
   89     };
   90     inline void* ReallocShared(void* ptr, size_t size)
   91     {
   92     void *result;
   93     GetLockShared();
   94     result = m_pVMemShared->Realloc(ptr, size);
   95     FreeLockShared();
   96     return result;
   97     };
   98     inline void FreeShared(void* ptr)
   99     {
  100     GetLockShared();
  101     m_pVMemShared->Free(ptr);
  102     FreeLockShared();
  103     };
  104     inline void* CallocShared(size_t num, size_t size)
  105     {
  106     size_t count = num*size;
  107     void* lpVoid = MallocShared(count);
  108     if (lpVoid)
  109         ZeroMemory(lpVoid, count);
  110     return lpVoid;
  111     };
  112 
  113 /* IPerlMemParse */
  114     /* Assume something else is using locks to mangaging serialize
  115        on a batch basis
  116      */
  117     inline void GetLockParse(void) { m_pVMemParse->GetLock(); };
  118     inline void FreeLockParse(void) { m_pVMemParse->FreeLock(); };
  119     inline int IsLockedParse(void) { return m_pVMemParse->IsLocked(); };
  120     inline void* MallocParse(size_t size) { return m_pVMemParse->Malloc(size); };
  121     inline void* ReallocParse(void* ptr, size_t size) { return m_pVMemParse->Realloc(ptr, size); };
  122     inline void FreeParse(void* ptr) { m_pVMemParse->Free(ptr); };
  123     inline void* CallocParse(size_t num, size_t size)
  124     {
  125     size_t count = num*size;
  126     void* lpVoid = MallocParse(count);
  127     if (lpVoid)
  128         ZeroMemory(lpVoid, count);
  129     return lpVoid;
  130     };
  131 
  132 /* IPerlEnv */
  133     char *Getenv(const char *varname);
  134     int Putenv(const char *envstring);
  135     inline char *Getenv(const char *varname, unsigned long *len)
  136     {
  137     *len = 0;
  138     char *e = Getenv(varname);
  139     if (e)
  140         *len = strlen(e);
  141     return e;
  142     }
  143     void* CreateChildEnv(void) { return CreateLocalEnvironmentStrings(*m_pvDir); };
  144     void FreeChildEnv(void* pStr) { FreeLocalEnvironmentStrings((char*)pStr); };
  145     char* GetChildDir(void);
  146     void FreeChildDir(char* pStr);
  147     void Reset(void);
  148     void Clearenv(void);
  149 
  150     inline LPSTR GetIndex(DWORD &dwIndex)
  151     {
  152     if(dwIndex < m_dwEnvCount)
  153     {
  154         ++dwIndex;
  155         return m_lppEnvList[dwIndex-1];
  156     }
  157     return NULL;
  158     };
  159 
  160 protected:
  161     LPSTR Find(LPCSTR lpStr);
  162     void Add(LPCSTR lpStr);
  163 
  164     LPSTR CreateLocalEnvironmentStrings(VDir &vDir);
  165     void FreeLocalEnvironmentStrings(LPSTR lpStr);
  166     LPSTR* Lookup(LPCSTR lpStr);
  167     DWORD CalculateEnvironmentSpace(void);
  168 
  169 public:
  170 
  171 /* IPerlDIR */
  172     virtual int Chdir(const char *dirname);
  173 
  174 /* IPerllProc */
  175     void Abort(void);
  176     void Exit(int status);
  177     void _Exit(int status);
  178     int Execl(const char *cmdname, const char *arg0, const char *arg1, const char *arg2, const char *arg3);
  179     int Execv(const char *cmdname, const char *const *argv);
  180     int Execvp(const char *cmdname, const char *const *argv);
  181 
  182     inline VMem* GetMemShared(void) { m_pVMemShared->AddRef(); return m_pVMemShared; };
  183     inline VMem* GetMemParse(void) { m_pVMemParse->AddRef(); return m_pVMemParse; };
  184     inline VDir* GetDir(void) { return m_pvDir; };
  185 
  186 public:
  187 
  188     struct IPerlMem     m_hostperlMem;
  189     struct IPerlMem     m_hostperlMemShared;
  190     struct IPerlMem     m_hostperlMemParse;
  191     struct IPerlEnv     m_hostperlEnv;
  192     struct IPerlStdIO       m_hostperlStdIO;
  193     struct IPerlLIO     m_hostperlLIO;
  194     struct IPerlDir     m_hostperlDir;
  195     struct IPerlSock        m_hostperlSock;
  196     struct IPerlProc        m_hostperlProc;
  197 
  198     struct IPerlMem*        m_pHostperlMem;
  199     struct IPerlMem*        m_pHostperlMemShared;
  200     struct IPerlMem*        m_pHostperlMemParse;
  201     struct IPerlEnv*        m_pHostperlEnv;
  202     struct IPerlStdIO*      m_pHostperlStdIO;
  203     struct IPerlLIO*        m_pHostperlLIO;
  204     struct IPerlDir*        m_pHostperlDir;
  205     struct IPerlSock*       m_pHostperlSock;
  206     struct IPerlProc*       m_pHostperlProc;
  207 
  208     inline char* MapPathA(const char *pInName) { return m_pvDir->MapPathA(pInName); };
  209     inline WCHAR* MapPathW(const WCHAR *pInName) { return m_pvDir->MapPathW(pInName); };
  210 protected:
  211 
  212     VDir*   m_pvDir;
  213     VMem*   m_pVMem;
  214     VMem*   m_pVMemShared;
  215     VMem*   m_pVMemParse;
  216 
  217     DWORD   m_dwEnvCount;
  218     LPSTR*  m_lppEnvList;
  219     BOOL    m_bTopLevel;    // is this a toplevel host?
  220     static long num_hosts;
  221 public:
  222     inline  int LastHost(void) { return num_hosts == 1L; };
  223     struct interpreter *host_perl;
  224 };
  225 
  226 long CPerlHost::num_hosts = 0L;
  227 
  228 extern "C" void win32_checkTLS(struct interpreter *host_perl);
  229 
  230 #define STRUCT2RAWPTR(x, y) (CPerlHost*)(((LPBYTE)x)-offsetof(CPerlHost, y))
  231 #ifdef CHECK_HOST_INTERP
  232 inline CPerlHost* CheckInterp(CPerlHost *host)
  233 {
  234  win32_checkTLS(host->host_perl);
  235  return host;
  236 }
  237 #define STRUCT2PTR(x, y) CheckInterp(STRUCT2RAWPTR(x, y))
  238 #else
  239 #define STRUCT2PTR(x, y) STRUCT2RAWPTR(x, y)
  240 #endif
  241 
  242 inline CPerlHost* IPerlMem2Host(struct IPerlMem* piPerl)
  243 {
  244     return STRUCT2RAWPTR(piPerl, m_hostperlMem);
  245 }
  246 
  247 inline CPerlHost* IPerlMemShared2Host(struct IPerlMem* piPerl)
  248 {
  249     return STRUCT2RAWPTR(piPerl, m_hostperlMemShared);
  250 }
  251 
  252 inline CPerlHost* IPerlMemParse2Host(struct IPerlMem* piPerl)
  253 {
  254     return STRUCT2RAWPTR(piPerl, m_hostperlMemParse);
  255 }
  256 
  257 inline CPerlHost* IPerlEnv2Host(struct IPerlEnv* piPerl)
  258 {
  259     return STRUCT2PTR(piPerl, m_hostperlEnv);
  260 }
  261 
  262 inline CPerlHost* IPerlStdIO2Host(struct IPerlStdIO* piPerl)
  263 {
  264     return STRUCT2PTR(piPerl, m_hostperlStdIO);
  265 }
  266 
  267 inline CPerlHost* IPerlLIO2Host(struct IPerlLIO* piPerl)
  268 {
  269     return STRUCT2PTR(piPerl, m_hostperlLIO);
  270 }
  271 
  272 inline CPerlHost* IPerlDir2Host(struct IPerlDir* piPerl)
  273 {
  274     return STRUCT2PTR(piPerl, m_hostperlDir);
  275 }
  276 
  277 inline CPerlHost* IPerlSock2Host(struct IPerlSock* piPerl)
  278 {
  279     return STRUCT2PTR(piPerl, m_hostperlSock);
  280 }
  281 
  282 inline CPerlHost* IPerlProc2Host(struct IPerlProc* piPerl)
  283 {
  284     return STRUCT2PTR(piPerl, m_hostperlProc);
  285 }
  286 
  287 
  288 
  289 #undef IPERL2HOST
  290 #define IPERL2HOST(x) IPerlMem2Host(x)
  291 
  292 /* IPerlMem */
  293 void*
  294 PerlMemMalloc(struct IPerlMem* piPerl, size_t size)
  295 {
  296     return IPERL2HOST(piPerl)->Malloc(size);
  297 }
  298 void*
  299 PerlMemRealloc(struct IPerlMem* piPerl, void* ptr, size_t size)
  300 {
  301     return IPERL2HOST(piPerl)->Realloc(ptr, size);
  302 }
  303 void
  304 PerlMemFree(struct IPerlMem* piPerl, void* ptr)
  305 {
  306     IPERL2HOST(piPerl)->Free(ptr);
  307 }
  308 void*
  309 PerlMemCalloc(struct IPerlMem* piPerl, size_t num, size_t size)
  310 {
  311     return IPERL2HOST(piPerl)->Calloc(num, size);
  312 }
  313 
  314 void
  315 PerlMemGetLock(struct IPerlMem* piPerl)
  316 {
  317     IPERL2HOST(piPerl)->GetLock();
  318 }
  319 
  320 void
  321 PerlMemFreeLock(struct IPerlMem* piPerl)
  322 {
  323     IPERL2HOST(piPerl)->FreeLock();
  324 }
  325 
  326 int
  327 PerlMemIsLocked(struct IPerlMem* piPerl)
  328 {
  329     return IPERL2HOST(piPerl)->IsLocked();
  330 }
  331 
  332 const struct IPerlMem perlMem =
  333 {
  334     PerlMemMalloc,
  335     PerlMemRealloc,
  336     PerlMemFree,
  337     PerlMemCalloc,
  338     PerlMemGetLock,
  339     PerlMemFreeLock,
  340     PerlMemIsLocked,
  341 };
  342 
  343 #undef IPERL2HOST
  344 #define IPERL2HOST(x) IPerlMemShared2Host(x)
  345 
  346 /* IPerlMemShared */
  347 void*
  348 PerlMemSharedMalloc(struct IPerlMem* piPerl, size_t size)
  349 {
  350     return IPERL2HOST(piPerl)->MallocShared(size);
  351 }
  352 void*
  353 PerlMemSharedRealloc(struct IPerlMem* piPerl, void* ptr, size_t size)
  354 {
  355     return IPERL2HOST(piPerl)->ReallocShared(ptr, size);
  356 }
  357 void
  358 PerlMemSharedFree(struct IPerlMem* piPerl, void* ptr)
  359 {
  360     IPERL2HOST(piPerl)->FreeShared(ptr);
  361 }
  362 void*
  363 PerlMemSharedCalloc(struct IPerlMem* piPerl, size_t num, size_t size)
  364 {
  365     return IPERL2HOST(piPerl)->CallocShared(num, size);
  366 }
  367 
  368 void
  369 PerlMemSharedGetLock(struct IPerlMem* piPerl)
  370 {
  371     IPERL2HOST(piPerl)->GetLockShared();
  372 }
  373 
  374 void
  375 PerlMemSharedFreeLock(struct IPerlMem* piPerl)
  376 {
  377     IPERL2HOST(piPerl)->FreeLockShared();
  378 }
  379 
  380 int
  381 PerlMemSharedIsLocked(struct IPerlMem* piPerl)
  382 {
  383     return IPERL2HOST(piPerl)->IsLockedShared();
  384 }
  385 
  386 const struct IPerlMem perlMemShared =
  387 {
  388     PerlMemSharedMalloc,
  389     PerlMemSharedRealloc,
  390     PerlMemSharedFree,
  391     PerlMemSharedCalloc,
  392     PerlMemSharedGetLock,
  393     PerlMemSharedFreeLock,
  394     PerlMemSharedIsLocked,
  395 };
  396 
  397 #undef IPERL2HOST
  398 #define IPERL2HOST(x) IPerlMemParse2Host(x)
  399 
  400 /* IPerlMemParse */
  401 void*
  402 PerlMemParseMalloc(struct IPerlMem* piPerl, size_t size)
  403 {
  404     return IPERL2HOST(piPerl)->MallocParse(size);
  405 }
  406 void*
  407 PerlMemParseRealloc(struct IPerlMem* piPerl, void* ptr, size_t size)
  408 {
  409     return IPERL2HOST(piPerl)->ReallocParse(ptr, size);
  410 }
  411 void
  412 PerlMemParseFree(struct IPerlMem* piPerl, void* ptr)
  413 {
  414     IPERL2HOST(piPerl)->FreeParse(ptr);
  415 }
  416 void*
  417 PerlMemParseCalloc(struct IPerlMem* piPerl, size_t num, size_t size)
  418 {
  419     return IPERL2HOST(piPerl)->CallocParse(num, size);
  420 }
  421 
  422 void
  423 PerlMemParseGetLock(struct IPerlMem* piPerl)
  424 {
  425     IPERL2HOST(piPerl)->GetLockParse();
  426 }
  427 
  428 void
  429 PerlMemParseFreeLock(struct IPerlMem* piPerl)
  430 {
  431     IPERL2HOST(piPerl)->FreeLockParse();
  432 }
  433 
  434 int
  435 PerlMemParseIsLocked(struct IPerlMem* piPerl)
  436 {
  437     return IPERL2HOST(piPerl)->IsLockedParse();
  438 }
  439 
  440 const struct IPerlMem perlMemParse =
  441 {
  442     PerlMemParseMalloc,
  443     PerlMemParseRealloc,
  444     PerlMemParseFree,
  445     PerlMemParseCalloc,
  446     PerlMemParseGetLock,
  447     PerlMemParseFreeLock,
  448     PerlMemParseIsLocked,
  449 };
  450 
  451 
  452 #undef IPERL2HOST
  453 #define IPERL2HOST(x) IPerlEnv2Host(x)
  454 
  455 /* IPerlEnv */
  456 char*
  457 PerlEnvGetenv(struct IPerlEnv* piPerl, const char *varname)
  458 {
  459     return IPERL2HOST(piPerl)->Getenv(varname);
  460 };
  461 
  462 int
  463 PerlEnvPutenv(struct IPerlEnv* piPerl, const char *envstring)
  464 {
  465     return IPERL2HOST(piPerl)->Putenv(envstring);
  466 };
  467 
  468 char*
  469 PerlEnvGetenv_len(struct IPerlEnv* piPerl, const char* varname, unsigned long* len)
  470 {
  471     return IPERL2HOST(piPerl)->Getenv(varname, len);
  472 }
  473 
  474 int
  475 PerlEnvUname(struct IPerlEnv* piPerl, struct utsname *name)
  476 {
  477     return win32_uname(name);
  478 }
  479 
  480 void
  481 PerlEnvClearenv(struct IPerlEnv* piPerl)
  482 {
  483     IPERL2HOST(piPerl)->Clearenv();
  484 }
  485 
  486 void*
  487 PerlEnvGetChildenv(struct IPerlEnv* piPerl)
  488 {
  489     return IPERL2HOST(piPerl)->CreateChildEnv();
  490 }
  491 
  492 void
  493 PerlEnvFreeChildenv(struct IPerlEnv* piPerl, void* childEnv)
  494 {
  495     IPERL2HOST(piPerl)->FreeChildEnv(childEnv);
  496 }
  497 
  498 char*
  499 PerlEnvGetChilddir(struct IPerlEnv* piPerl)
  500 {
  501     return IPERL2HOST(piPerl)->GetChildDir();
  502 }
  503 
  504 void
  505 PerlEnvFreeChilddir(struct IPerlEnv* piPerl, char* childDir)
  506 {
  507     IPERL2HOST(piPerl)->FreeChildDir(childDir);
  508 }
  509 
  510 unsigned long
  511 PerlEnvOsId(struct IPerlEnv* piPerl)
  512 {
  513     return win32_os_id();
  514 }
  515 
  516 char*
  517 PerlEnvLibPath(struct IPerlEnv* piPerl, WIN32_NO_REGISTRY_M_(const char *pl) STRLEN *const len)
  518 {
  519     return win32_get_privlib(WIN32_NO_REGISTRY_M_(pl) len);
  520 }
  521 
  522 char*
  523 PerlEnvSiteLibPath(struct IPerlEnv* piPerl, const char *pl, STRLEN *const len)
  524 {
  525     return win32_get_sitelib(pl, len);
  526 }
  527 
  528 char*
  529 PerlEnvVendorLibPath(struct IPerlEnv* piPerl, const char *pl,
  530              STRLEN *const len)
  531 {
  532     return win32_get_vendorlib(pl, len);
  533 }
  534 
  535 void
  536 PerlEnvGetChildIO(struct IPerlEnv* piPerl, child_IO_table* ptr)
  537 {
  538     win32_get_child_IO(ptr);
  539 }
  540 
  541 const struct IPerlEnv perlEnv =
  542 {
  543     PerlEnvGetenv,
  544     PerlEnvPutenv,
  545     PerlEnvGetenv_len,
  546     PerlEnvUname,
  547     PerlEnvClearenv,
  548     PerlEnvGetChildenv,
  549     PerlEnvFreeChildenv,
  550     PerlEnvGetChilddir,
  551     PerlEnvFreeChilddir,
  552     PerlEnvOsId,
  553     PerlEnvLibPath,
  554     PerlEnvSiteLibPath,
  555     PerlEnvVendorLibPath,
  556     PerlEnvGetChildIO,
  557 };
  558 
  559 #undef IPERL2HOST
  560 #define IPERL2HOST(x) IPerlStdIO2Host(x)
  561 
  562 /* PerlStdIO */
  563 FILE*
  564 PerlStdIOStdin(struct IPerlStdIO* piPerl)
  565 {
  566     return win32_stdin();
  567 }
  568 
  569 FILE*
  570 PerlStdIOStdout(struct IPerlStdIO* piPerl)
  571 {
  572     return win32_stdout();
  573 }
  574 
  575 FILE*
  576 PerlStdIOStderr(struct IPerlStdIO* piPerl)
  577 {
  578     return win32_stderr();
  579 }
  580 
  581 FILE*
  582 PerlStdIOOpen(struct IPerlStdIO* piPerl, const char *path, const char *mode)
  583 {
  584     return win32_fopen(path, mode);
  585 }
  586 
  587 int
  588 PerlStdIOClose(struct IPerlStdIO* piPerl, FILE* pf)
  589 {
  590     return win32_fclose((pf));
  591 }
  592 
  593 int
  594 PerlStdIOEof(struct IPerlStdIO* piPerl, FILE* pf)
  595 {
  596     return win32_feof(pf);
  597 }
  598 
  599 int
  600 PerlStdIOError(struct IPerlStdIO* piPerl, FILE* pf)
  601 {
  602     return win32_ferror(pf);
  603 }
  604 
  605 void
  606 PerlStdIOClearerr(struct IPerlStdIO* piPerl, FILE* pf)
  607 {
  608     win32_clearerr(pf);
  609 }
  610 
  611 int
  612 PerlStdIOGetc(struct IPerlStdIO* piPerl, FILE* pf)
  613 {
  614     return win32_getc(pf);
  615 }
  616 
  617 STDCHAR*
  618 PerlStdIOGetBase(struct IPerlStdIO* piPerl, FILE* pf)
  619 {
  620 #ifdef FILE_base
  621     FILE *f = pf;
  622     return FILE_base(f);
  623 #else
  624     return NULL;
  625 #endif
  626 }
  627 
  628 int
  629 PerlStdIOGetBufsiz(struct IPerlStdIO* piPerl, FILE* pf)
  630 {
  631 #ifdef FILE_bufsiz
  632     FILE *f = pf;
  633     return FILE_bufsiz(f);
  634 #else
  635     return (-1);
  636 #endif
  637 }
  638 
  639 int
  640 PerlStdIOGetCnt(struct IPerlStdIO* piPerl, FILE* pf)
  641 {
  642 #ifdef USE_STDIO_PTR
  643     FILE *f = pf;
  644     return FILE_cnt(f);
  645 #else
  646     return (-1);
  647 #endif
  648 }
  649 
  650 STDCHAR*
  651 PerlStdIOGetPtr(struct IPerlStdIO* piPerl, FILE* pf)
  652 {
  653 #ifdef USE_STDIO_PTR
  654     FILE *f = pf;
  655     return FILE_ptr(f);
  656 #else
  657     return NULL;
  658 #endif
  659 }
  660 
  661 char*
  662 PerlStdIOGets(struct IPerlStdIO* piPerl, char* s, int n, FILE* pf)
  663 {
  664     return win32_fgets(s, n, pf);
  665 }
  666 
  667 int
  668 PerlStdIOPutc(struct IPerlStdIO* piPerl, int c, FILE* pf)
  669 {
  670     return win32_fputc(c, pf);
  671 }
  672 
  673 int
  674 PerlStdIOPuts(struct IPerlStdIO* piPerl, const char *s, FILE* pf)
  675 {
  676     return win32_fputs(s, pf);
  677 }
  678 
  679 int
  680 PerlStdIOFlush(struct IPerlStdIO* piPerl, FILE* pf)
  681 {
  682     return win32_fflush(pf);
  683 }
  684 
  685 int
  686 PerlStdIOUngetc(struct IPerlStdIO* piPerl,int c, FILE* pf)
  687 {
  688     return win32_ungetc(c, pf);
  689 }
  690 
  691 int
  692 PerlStdIOFileno(struct IPerlStdIO* piPerl, FILE* pf)
  693 {
  694     return win32_fileno(pf);
  695 }
  696 
  697 FILE*
  698 PerlStdIOFdopen(struct IPerlStdIO* piPerl, int fd, const char *mode)
  699 {
  700     return win32_fdopen(fd, mode);
  701 }
  702 
  703 FILE*
  704 PerlStdIOReopen(struct IPerlStdIO* piPerl, const char*path, const char*mode, FILE* pf)
  705 {
  706     return win32_freopen(path, mode, (FILE*)pf);
  707 }
  708 
  709 SSize_t
  710 PerlStdIORead(struct IPerlStdIO* piPerl, void *buffer, Size_t size, Size_t count, FILE* pf)
  711 {
  712     return win32_fread(buffer, size, count, pf);
  713 }
  714 
  715 SSize_t
  716 PerlStdIOWrite(struct IPerlStdIO* piPerl, const void *buffer, Size_t size, Size_t count, FILE* pf)
  717 {
  718     return win32_fwrite(buffer, size, count, pf);
  719 }
  720 
  721 void
  722 PerlStdIOSetBuf(struct IPerlStdIO* piPerl, FILE* pf, char* buffer)
  723 {
  724     win32_setbuf(pf, buffer);
  725 }
  726 
  727 int
  728 PerlStdIOSetVBuf(struct IPerlStdIO* piPerl, FILE* pf, char* buffer, int type, Size_t size)
  729 {
  730     return win32_setvbuf(pf, buffer, type, size);
  731 }
  732 
  733 void
  734 PerlStdIOSetCnt(struct IPerlStdIO* piPerl, FILE* pf, int n)
  735 {
  736 #ifdef STDIO_CNT_LVALUE
  737     FILE *f = pf;
  738     FILE_cnt(f) = n;
  739 #endif
  740 }
  741 
  742 void
  743 PerlStdIOSetPtr(struct IPerlStdIO* piPerl, FILE* pf, STDCHAR * ptr)
  744 {
  745 #ifdef STDIO_PTR_LVALUE
  746     FILE *f = pf;
  747     FILE_ptr(f) = ptr;
  748 #endif
  749 }
  750 
  751 void
  752 PerlStdIOSetlinebuf(struct IPerlStdIO* piPerl, FILE* pf)
  753 {
  754     win32_setvbuf(pf, NULL, _IOLBF, 0);
  755 }
  756 
  757 int
  758 PerlStdIOPrintf(struct IPerlStdIO* piPerl, FILE* pf, const char *format,...)
  759 {
  760     va_list(arglist);
  761     va_start(arglist, format);
  762     return win32_vfprintf(pf, format, arglist);
  763 }
  764 
  765 int
  766 PerlStdIOVprintf(struct IPerlStdIO* piPerl, FILE* pf, const char *format, va_list arglist)
  767 {
  768     return win32_vfprintf(pf, format, arglist);
  769 }
  770 
  771 Off_t
  772 PerlStdIOTell(struct IPerlStdIO* piPerl, FILE* pf)
  773 {
  774     return win32_ftell(pf);
  775 }
  776 
  777 int
  778 PerlStdIOSeek(struct IPerlStdIO* piPerl, FILE* pf, Off_t offset, int origin)
  779 {
  780     return win32_fseek(pf, offset, origin);
  781 }
  782 
  783 void
  784 PerlStdIORewind(struct IPerlStdIO* piPerl, FILE* pf)
  785 {
  786     win32_rewind(pf);
  787 }
  788 
  789 FILE*
  790 PerlStdIOTmpfile(struct IPerlStdIO* piPerl)
  791 {
  792     return win32_tmpfile();
  793 }
  794 
  795 int
  796 PerlStdIOGetpos(struct IPerlStdIO* piPerl, FILE* pf, Fpos_t *p)
  797 {
  798     return win32_fgetpos(pf, p);
  799 }
  800 
  801 int
  802 PerlStdIOSetpos(struct IPerlStdIO* piPerl, FILE* pf, const Fpos_t *p)
  803 {
  804     return win32_fsetpos(pf, p);
  805 }
  806 void
  807 PerlStdIOInit(struct IPerlStdIO* piPerl)
  808 {
  809 }
  810 
  811 void
  812 PerlStdIOInitOSExtras(struct IPerlStdIO* piPerl)
  813 {
  814     Perl_init_os_extras();
  815 }
  816 
  817 int
  818 PerlStdIOOpenOSfhandle(struct IPerlStdIO* piPerl, intptr_t osfhandle, int flags)
  819 {
  820     return win32_open_osfhandle(osfhandle, flags);
  821 }
  822 
  823 intptr_t
  824 PerlStdIOGetOSfhandle(struct IPerlStdIO* piPerl, int filenum)
  825 {
  826     return win32_get_osfhandle(filenum);
  827 }
  828 
  829 FILE*
  830 PerlStdIOFdupopen(struct IPerlStdIO* piPerl, FILE* pf)
  831 {
  832 #ifndef UNDER_CE
  833     FILE* pfdup;
  834     fpos_t pos;
  835     char mode[3];
  836     int fileno = win32_dup(win32_fileno(pf));
  837 
  838     /* open the file in the same mode */
  839     if (PERLIO_FILE_flag(pf) & PERLIO_FILE_flag_RD) {
  840     mode[0] = 'r';
  841     mode[1] = 0;
  842     }
  843     else if (PERLIO_FILE_flag(pf) & PERLIO_FILE_flag_WR) {
  844     mode[0] = 'a';
  845     mode[1] = 0;
  846     }
  847     else if (PERLIO_FILE_flag(pf) & PERLIO_FILE_flag_RW) {
  848     mode[0] = 'r';
  849     mode[1] = '+';
  850     mode[2] = 0;
  851     }
  852 
  853     /* it appears that the binmode is attached to the
  854      * file descriptor so binmode files will be handled
  855      * correctly
  856      */
  857     pfdup = win32_fdopen(fileno, mode);
  858 
  859     /* move the file pointer to the same position */
  860     if (!fgetpos(pf, &pos)) {
  861     fsetpos(pfdup, &pos);
  862     }
  863     return pfdup;
  864 #else
  865     return 0;
  866 #endif
  867 }
  868 
  869 const struct IPerlStdIO perlStdIO =
  870 {
  871     PerlStdIOStdin,
  872     PerlStdIOStdout,
  873     PerlStdIOStderr,
  874     PerlStdIOOpen,
  875     PerlStdIOClose,
  876     PerlStdIOEof,
  877     PerlStdIOError,
  878     PerlStdIOClearerr,
  879     PerlStdIOGetc,
  880     PerlStdIOGetBase,
  881     PerlStdIOGetBufsiz,
  882     PerlStdIOGetCnt,
  883     PerlStdIOGetPtr,
  884     PerlStdIOGets,
  885     PerlStdIOPutc,
  886     PerlStdIOPuts,
  887     PerlStdIOFlush,
  888     PerlStdIOUngetc,
  889     PerlStdIOFileno,
  890     PerlStdIOFdopen,
  891     PerlStdIOReopen,
  892     PerlStdIORead,
  893     PerlStdIOWrite,
  894     PerlStdIOSetBuf,
  895     PerlStdIOSetVBuf,
  896     PerlStdIOSetCnt,
  897     PerlStdIOSetPtr,
  898     PerlStdIOSetlinebuf,
  899     PerlStdIOPrintf,
  900     PerlStdIOVprintf,
  901     PerlStdIOTell,
  902     PerlStdIOSeek,
  903     PerlStdIORewind,
  904     PerlStdIOTmpfile,
  905     PerlStdIOGetpos,
  906     PerlStdIOSetpos,
  907     PerlStdIOInit,
  908     PerlStdIOInitOSExtras,
  909     PerlStdIOFdupopen,
  910 };
  911 
  912 
  913 #undef IPERL2HOST
  914 #define IPERL2HOST(x) IPerlLIO2Host(x)
  915 
  916 /* IPerlLIO */
  917 int
  918 PerlLIOAccess(struct IPerlLIO* piPerl, const char *path, int mode)
  919 {
  920     return win32_access(path, mode);
  921 }
  922 
  923 int
  924 PerlLIOChmod(struct IPerlLIO* piPerl, const char *filename, int pmode)
  925 {
  926     return win32_chmod(filename, pmode);
  927 }
  928 
  929 int
  930 PerlLIOChown(struct IPerlLIO* piPerl, const char *filename, uid_t owner, gid_t group)
  931 {
  932     return chown(filename, owner, group);
  933 }
  934 
  935 int
  936 PerlLIOChsize(struct IPerlLIO* piPerl, int handle, Off_t size)
  937 {
  938     return win32_chsize(handle, size);
  939 }
  940 
  941 int
  942 PerlLIOClose(struct IPerlLIO* piPerl, int handle)
  943 {
  944     return win32_close(handle);
  945 }
  946 
  947 int
  948 PerlLIODup(struct IPerlLIO* piPerl, int handle)
  949 {
  950     return win32_dup(handle);
  951 }
  952 
  953 int
  954 PerlLIODup2(struct IPerlLIO* piPerl, int handle1, int handle2)
  955 {
  956     return win32_dup2(handle1, handle2);
  957 }
  958 
  959 int
  960 PerlLIOFlock(struct IPerlLIO* piPerl, int fd, int oper)
  961 {
  962     return win32_flock(fd, oper);
  963 }
  964 
  965 int
  966 PerlLIOFileStat(struct IPerlLIO* piPerl, int handle, Stat_t *buffer)
  967 {
  968     return win32_fstat(handle, buffer);
  969 }
  970 
  971 int
  972 PerlLIOIOCtl(struct IPerlLIO* piPerl, int i, unsigned int u, char *data)
  973 {
  974     u_long u_long_arg;
  975     int retval;
  976 
  977     /* mauke says using memcpy avoids alignment issues */
  978     memcpy(&u_long_arg, data, sizeof u_long_arg); 
  979     retval = win32_ioctlsocket((SOCKET)i, (long)u, &u_long_arg);
  980     memcpy(data, &u_long_arg, sizeof u_long_arg);
  981     return retval;
  982 }
  983 
  984 int
  985 PerlLIOIsatty(struct IPerlLIO* piPerl, int fd)
  986 {
  987     return win32_isatty(fd);
  988 }
  989 
  990 int
  991 PerlLIOLink(struct IPerlLIO* piPerl, const char*oldname, const char *newname)
  992 {
  993     return win32_link(oldname, newname);
  994 }
  995 
  996 Off_t
  997 PerlLIOLseek(struct IPerlLIO* piPerl, int handle, Off_t offset, int origin)
  998 {
  999     return win32_lseek(handle, offset, origin);
 1000 }
 1001 
 1002 int
 1003 PerlLIOLstat(struct IPerlLIO* piPerl, const char *path, Stat_t *buffer)
 1004 {
 1005     return win32_stat(path, buffer);
 1006 }
 1007 
 1008 char*
 1009 PerlLIOMktemp(struct IPerlLIO* piPerl, char *Template)
 1010 {
 1011     return mktemp(Template);
 1012 }
 1013 
 1014 int
 1015 PerlLIOOpen(struct IPerlLIO* piPerl, const char *filename, int oflag)
 1016 {
 1017     return win32_open(filename, oflag);
 1018 }
 1019 
 1020 int
 1021 PerlLIOOpen3(struct IPerlLIO* piPerl, const char *filename, int oflag, int pmode)
 1022 {
 1023     return win32_open(filename, oflag, pmode);
 1024 }
 1025 
 1026 int
 1027 PerlLIORead(struct IPerlLIO* piPerl, int handle, void *buffer, unsigned int count)
 1028 {
 1029     return win32_read(handle, buffer, count);
 1030 }
 1031 
 1032 int
 1033 PerlLIORename(struct IPerlLIO* piPerl, const char *OldFileName, const char *newname)
 1034 {
 1035     return win32_rename(OldFileName, newname);
 1036 }
 1037 
 1038 int
 1039 PerlLIOSetmode(struct IPerlLIO* piPerl, int handle, int mode)
 1040 {
 1041     return win32_setmode(handle, mode);
 1042 }
 1043 
 1044 int
 1045 PerlLIONameStat(struct IPerlLIO* piPerl, const char *path, Stat_t *buffer)
 1046 {
 1047     return win32_stat(path, buffer);
 1048 }
 1049 
 1050 char*
 1051 PerlLIOTmpnam(struct IPerlLIO* piPerl, char *string)
 1052 {
 1053     return tmpnam(string);
 1054 }
 1055 
 1056 int
 1057 PerlLIOUmask(struct IPerlLIO* piPerl, int pmode)
 1058 {
 1059     return umask(pmode);
 1060 }
 1061 
 1062 int
 1063 PerlLIOUnlink(struct IPerlLIO* piPerl, const char *filename)
 1064 {
 1065     return win32_unlink(filename);
 1066 }
 1067 
 1068 int
 1069 PerlLIOUtime(struct IPerlLIO* piPerl, const char *filename, struct utimbuf *times)
 1070 {
 1071     return win32_utime(filename, times);
 1072 }
 1073 
 1074 int
 1075 PerlLIOWrite(struct IPerlLIO* piPerl, int handle, const void *buffer, unsigned int count)
 1076 {
 1077     return win32_write(handle, buffer, count);
 1078 }
 1079 
 1080 const struct IPerlLIO perlLIO =
 1081 {
 1082     PerlLIOAccess,
 1083     PerlLIOChmod,
 1084     PerlLIOChown,
 1085     PerlLIOChsize,
 1086     PerlLIOClose,
 1087     PerlLIODup,
 1088     PerlLIODup2,
 1089     PerlLIOFlock,
 1090     PerlLIOFileStat,
 1091     PerlLIOIOCtl,
 1092     PerlLIOIsatty,
 1093     PerlLIOLink,
 1094     PerlLIOLseek,
 1095     PerlLIOLstat,
 1096     PerlLIOMktemp,
 1097     PerlLIOOpen,
 1098     PerlLIOOpen3,
 1099     PerlLIORead,
 1100     PerlLIORename,
 1101     PerlLIOSetmode,
 1102     PerlLIONameStat,
 1103     PerlLIOTmpnam,
 1104     PerlLIOUmask,
 1105     PerlLIOUnlink,
 1106     PerlLIOUtime,
 1107     PerlLIOWrite,
 1108 };
 1109 
 1110 
 1111 #undef IPERL2HOST
 1112 #define IPERL2HOST(x) IPerlDir2Host(x)
 1113 
 1114 /* IPerlDIR */
 1115 int
 1116 PerlDirMakedir(struct IPerlDir* piPerl, const char *dirname, int mode)
 1117 {
 1118     return win32_mkdir(dirname, mode);
 1119 }
 1120 
 1121 int
 1122 PerlDirChdir(struct IPerlDir* piPerl, const char *dirname)
 1123 {
 1124     return IPERL2HOST(piPerl)->Chdir(dirname);
 1125 }
 1126 
 1127 int
 1128 PerlDirRmdir(struct IPerlDir* piPerl, const char *dirname)
 1129 {
 1130     return win32_rmdir(dirname);
 1131 }
 1132 
 1133 int
 1134 PerlDirClose(struct IPerlDir* piPerl, DIR *dirp)
 1135 {
 1136     return win32_closedir(dirp);
 1137 }
 1138 
 1139 DIR*
 1140 PerlDirOpen(struct IPerlDir* piPerl, const char *filename)
 1141 {
 1142     return win32_opendir(filename);
 1143 }
 1144 
 1145 struct direct *
 1146 PerlDirRead(struct IPerlDir* piPerl, DIR *dirp)
 1147 {
 1148     return win32_readdir(dirp);
 1149 }
 1150 
 1151 void
 1152 PerlDirRewind(struct IPerlDir* piPerl, DIR *dirp)
 1153 {
 1154     win32_rewinddir(dirp);
 1155 }
 1156 
 1157 void
 1158 PerlDirSeek(struct IPerlDir* piPerl, DIR *dirp, long loc)
 1159 {
 1160     win32_seekdir(dirp, loc);
 1161 }
 1162 
 1163 long
 1164 PerlDirTell(struct IPerlDir* piPerl, DIR *dirp)
 1165 {
 1166     return win32_telldir(dirp);
 1167 }
 1168 
 1169 char*
 1170 PerlDirMapPathA(struct IPerlDir* piPerl, const char* path)
 1171 {
 1172     return IPERL2HOST(piPerl)->MapPathA(path);
 1173 }
 1174 
 1175 WCHAR*
 1176 PerlDirMapPathW(struct IPerlDir* piPerl, const WCHAR* path)
 1177 {
 1178     return IPERL2HOST(piPerl)->MapPathW(path);
 1179 }
 1180 
 1181 const struct IPerlDir perlDir =
 1182 {
 1183     PerlDirMakedir,
 1184     PerlDirChdir,
 1185     PerlDirRmdir,
 1186     PerlDirClose,
 1187     PerlDirOpen,
 1188     PerlDirRead,
 1189     PerlDirRewind,
 1190     PerlDirSeek,
 1191     PerlDirTell,
 1192     PerlDirMapPathA,
 1193     PerlDirMapPathW,
 1194 };
 1195 
 1196 
 1197 /* IPerlSock */
 1198 u_long
 1199 PerlSockHtonl(struct IPerlSock* piPerl, u_long hostlong)
 1200 {
 1201     return win32_htonl(hostlong);
 1202 }
 1203 
 1204 u_short
 1205 PerlSockHtons(struct IPerlSock* piPerl, u_short hostshort)
 1206 {
 1207     return win32_htons(hostshort);
 1208 }
 1209 
 1210 u_long
 1211 PerlSockNtohl(struct IPerlSock* piPerl, u_long netlong)
 1212 {
 1213     return win32_ntohl(netlong);
 1214 }
 1215 
 1216 u_short
 1217 PerlSockNtohs(struct IPerlSock* piPerl, u_short netshort)
 1218 {
 1219     return win32_ntohs(netshort);
 1220 }
 1221 
 1222 SOCKET PerlSockAccept(struct IPerlSock* piPerl, SOCKET s, struct sockaddr* addr, int* addrlen)
 1223 {
 1224     return win32_accept(s, addr, addrlen);
 1225 }
 1226 
 1227 int
 1228 PerlSockBind(struct IPerlSock* piPerl, SOCKET s, const struct sockaddr* name, int namelen)
 1229 {
 1230     return win32_bind(s, name, namelen);
 1231 }
 1232 
 1233 int
 1234 PerlSockConnect(struct IPerlSock* piPerl, SOCKET s, const struct sockaddr* name, int namelen)
 1235 {
 1236     return win32_connect(s, name, namelen);
 1237 }
 1238 
 1239 void
 1240 PerlSockEndhostent(struct IPerlSock* piPerl)
 1241 {
 1242     win32_endhostent();
 1243 }
 1244 
 1245 void
 1246 PerlSockEndnetent(struct IPerlSock* piPerl)
 1247 {
 1248     win32_endnetent();
 1249 }
 1250 
 1251 void
 1252 PerlSockEndprotoent(struct IPerlSock* piPerl)
 1253 {
 1254     win32_endprotoent();
 1255 }
 1256 
 1257 void
 1258 PerlSockEndservent(struct IPerlSock* piPerl)
 1259 {
 1260     win32_endservent();
 1261 }
 1262 
 1263 struct hostent*
 1264 PerlSockGethostbyaddr(struct IPerlSock* piPerl, const char* addr, int len, int type)
 1265 {
 1266     return win32_gethostbyaddr(addr, len, type);
 1267 }
 1268 
 1269 struct hostent*
 1270 PerlSockGethostbyname(struct IPerlSock* piPerl, const char* name)
 1271 {
 1272     return win32_gethostbyname(name);
 1273 }
 1274 
 1275 struct hostent*
 1276 PerlSockGethostent(struct IPerlSock* piPerl)
 1277 {
 1278     win32_croak_not_implemented("gethostent");
 1279     return NULL;
 1280 }
 1281 
 1282 int
 1283 PerlSockGethostname(struct IPerlSock* piPerl, char* name, int namelen)
 1284 {
 1285     return win32_gethostname(name, namelen);
 1286 }
 1287 
 1288 struct netent *
 1289 PerlSockGetnetbyaddr(struct IPerlSock* piPerl, long net, int type)
 1290 {
 1291     return win32_getnetbyaddr(net, type);
 1292 }
 1293 
 1294 struct netent *
 1295 PerlSockGetnetbyname(struct IPerlSock* piPerl, const char *name)
 1296 {
 1297     return win32_getnetbyname((char*)name);
 1298 }
 1299 
 1300 struct netent *
 1301 PerlSockGetnetent(struct IPerlSock* piPerl)
 1302 {
 1303     return win32_getnetent();
 1304 }
 1305 
 1306 int PerlSockGetpeername(struct IPerlSock* piPerl, SOCKET s, struct sockaddr* name, int* namelen)
 1307 {
 1308     return win32_getpeername(s, name, namelen);
 1309 }
 1310 
 1311 struct protoent*
 1312 PerlSockGetprotobyname(struct IPerlSock* piPerl, const char* name)
 1313 {
 1314     return win32_getprotobyname(name);
 1315 }
 1316 
 1317 struct protoent*
 1318 PerlSockGetprotobynumber(struct IPerlSock* piPerl, int number)
 1319 {
 1320     return win32_getprotobynumber(number);
 1321 }
 1322 
 1323 struct protoent*
 1324 PerlSockGetprotoent(struct IPerlSock* piPerl)
 1325 {
 1326     return win32_getprotoent();
 1327 }
 1328 
 1329 struct servent*
 1330 PerlSockGetservbyname(struct IPerlSock* piPerl, const char* name, const char* proto)
 1331 {
 1332     return win32_getservbyname(name, proto);
 1333 }
 1334 
 1335 struct servent*
 1336 PerlSockGetservbyport(struct IPerlSock* piPerl, int port, const char* proto)
 1337 {
 1338     return win32_getservbyport(port, proto);
 1339 }
 1340 
 1341 struct servent*
 1342 PerlSockGetservent(struct IPerlSock* piPerl)
 1343 {
 1344     return win32_getservent();
 1345 }
 1346 
 1347 int
 1348 PerlSockGetsockname(struct IPerlSock* piPerl, SOCKET s, struct sockaddr* name, int* namelen)
 1349 {
 1350     return win32_getsockname(s, name, namelen);
 1351 }
 1352 
 1353 int
 1354 PerlSockGetsockopt(struct IPerlSock* piPerl, SOCKET s, int level, int optname, char* optval, int* optlen)
 1355 {
 1356     return win32_getsockopt(s, level, optname, optval, optlen);
 1357 }
 1358 
 1359 unsigned long
 1360 PerlSockInetAddr(struct IPerlSock* piPerl, const char* cp)
 1361 {
 1362     return win32_inet_addr(cp);
 1363 }
 1364 
 1365 char*
 1366 PerlSockInetNtoa(struct IPerlSock* piPerl, struct in_addr in)
 1367 {
 1368     return win32_inet_ntoa(in);
 1369 }
 1370 
 1371 int
 1372 PerlSockListen(struct IPerlSock* piPerl, SOCKET s, int backlog)
 1373 {
 1374     return win32_listen(s, backlog);
 1375 }
 1376 
 1377 int
 1378 PerlSockRecv(struct IPerlSock* piPerl, SOCKET s, char* buffer, int len, int flags)
 1379 {
 1380     return win32_recv(s, buffer, len, flags);
 1381 }
 1382 
 1383 int
 1384 PerlSockRecvfrom(struct IPerlSock* piPerl, SOCKET s, char* buffer, int len, int flags, struct sockaddr* from, int* fromlen)
 1385 {
 1386     return win32_recvfrom(s, buffer, len, flags, from, fromlen);
 1387 }
 1388 
 1389 int
 1390 PerlSockSelect(struct IPerlSock* piPerl, int nfds, char* readfds, char* writefds, char* exceptfds, const struct timeval* timeout)
 1391 {
 1392     return win32_select(nfds, (Perl_fd_set*)readfds, (Perl_fd_set*)writefds, (Perl_fd_set*)exceptfds, timeout);
 1393 }
 1394 
 1395 int
 1396 PerlSockSend(struct IPerlSock* piPerl, SOCKET s, const char* buffer, int len, int flags)
 1397 {
 1398     return win32_send(s, buffer, len, flags);
 1399 }
 1400 
 1401 int
 1402 PerlSockSendto(struct IPerlSock* piPerl, SOCKET s, const char* buffer, int len, int flags, const struct sockaddr* to, int tolen)
 1403 {
 1404     return win32_sendto(s, buffer, len, flags, to, tolen);
 1405 }
 1406 
 1407 void
 1408 PerlSockSethostent(struct IPerlSock* piPerl, int stayopen)
 1409 {
 1410     win32_sethostent(stayopen);
 1411 }
 1412 
 1413 void
 1414 PerlSockSetnetent(struct IPerlSock* piPerl, int stayopen)
 1415 {
 1416     win32_setnetent(stayopen);
 1417 }
 1418 
 1419 void
 1420 PerlSockSetprotoent(struct IPerlSock* piPerl, int stayopen)
 1421 {
 1422     win32_setprotoent(stayopen);
 1423 }
 1424 
 1425 void
 1426 PerlSockSetservent(struct IPerlSock* piPerl, int stayopen)
 1427 {
 1428     win32_setservent(stayopen);
 1429 }
 1430 
 1431 int
 1432 PerlSockSetsockopt(struct IPerlSock* piPerl, SOCKET s, int level, int optname, const char* optval, int optlen)
 1433 {
 1434     return win32_setsockopt(s, level, optname, optval, optlen);
 1435 }
 1436 
 1437 int
 1438 PerlSockShutdown(struct IPerlSock* piPerl, SOCKET s, int how)
 1439 {
 1440     return win32_shutdown(s, how);
 1441 }
 1442 
 1443 SOCKET
 1444 PerlSockSocket(struct IPerlSock* piPerl, int af, int type, int protocol)
 1445 {
 1446     return win32_socket(af, type, protocol);
 1447 }
 1448 
 1449 int
 1450 PerlSockSocketpair(struct IPerlSock* piPerl, int domain, int type, int protocol, int* fds)
 1451 {
 1452     return Perl_my_socketpair(domain, type, protocol, fds);
 1453 }
 1454 
 1455 int
 1456 PerlSockClosesocket(struct IPerlSock* piPerl, SOCKET s)
 1457 {
 1458     return win32_closesocket(s);
 1459 }
 1460 
 1461 int
 1462 PerlSockIoctlsocket(struct IPerlSock* piPerl, SOCKET s, long cmd, u_long *argp)
 1463 {
 1464     return win32_ioctlsocket(s, cmd, argp);
 1465 }
 1466 
 1467 const struct IPerlSock perlSock =
 1468 {
 1469     PerlSockHtonl,
 1470     PerlSockHtons,
 1471     PerlSockNtohl,
 1472     PerlSockNtohs,
 1473     PerlSockAccept,
 1474     PerlSockBind,
 1475     PerlSockConnect,
 1476     PerlSockEndhostent,
 1477     PerlSockEndnetent,
 1478     PerlSockEndprotoent,
 1479     PerlSockEndservent,
 1480     PerlSockGethostname,
 1481     PerlSockGetpeername,
 1482     PerlSockGethostbyaddr,
 1483     PerlSockGethostbyname,
 1484     PerlSockGethostent,
 1485     PerlSockGetnetbyaddr,
 1486     PerlSockGetnetbyname,
 1487     PerlSockGetnetent,
 1488     PerlSockGetprotobyname,
 1489     PerlSockGetprotobynumber,
 1490     PerlSockGetprotoent,
 1491     PerlSockGetservbyname,
 1492     PerlSockGetservbyport,
 1493     PerlSockGetservent,
 1494     PerlSockGetsockname,
 1495     PerlSockGetsockopt,
 1496     PerlSockInetAddr,
 1497     PerlSockInetNtoa,
 1498     PerlSockListen,
 1499     PerlSockRecv,
 1500     PerlSockRecvfrom,
 1501     PerlSockSelect,
 1502     PerlSockSend,
 1503     PerlSockSendto,
 1504     PerlSockSethostent,
 1505     PerlSockSetnetent,
 1506     PerlSockSetprotoent,
 1507     PerlSockSetservent,
 1508     PerlSockSetsockopt,
 1509     PerlSockShutdown,
 1510     PerlSockSocket,
 1511     PerlSockSocketpair,
 1512     PerlSockClosesocket,
 1513 };
 1514 
 1515 
 1516 /* IPerlProc */
 1517 
 1518 #define EXECF_EXEC 1
 1519 #define EXECF_SPAWN 2
 1520 
 1521 void
 1522 PerlProcAbort(struct IPerlProc* piPerl)
 1523 {
 1524     win32_abort();
 1525 }
 1526 
 1527 char *
 1528 PerlProcCrypt(struct IPerlProc* piPerl, const char* clear, const char* salt)
 1529 {
 1530     return win32_crypt(clear, salt);
 1531 }
 1532 
 1533 PERL_CALLCONV_NO_RET void
 1534 PerlProcExit(struct IPerlProc* piPerl, int status)
 1535 {
 1536     exit(status);
 1537 }
 1538 
 1539 PERL_CALLCONV_NO_RET void
 1540 PerlProc_Exit(struct IPerlProc* piPerl, int status)
 1541 {
 1542     _exit(status);
 1543 }
 1544 
 1545 int
 1546 PerlProcExecl(struct IPerlProc* piPerl, const char *cmdname, const char *arg0, const char *arg1, const char *arg2, const char *arg3)
 1547 {
 1548     return execl(cmdname, arg0, arg1, arg2, arg3);
 1549 }
 1550 
 1551 int
 1552 PerlProcExecv(struct IPerlProc* piPerl, const char *cmdname, const char *const *argv)
 1553 {
 1554     return win32_execvp(cmdname, argv);
 1555 }
 1556 
 1557 int
 1558 PerlProcExecvp(struct IPerlProc* piPerl, const char *cmdname, const char *const *argv)
 1559 {
 1560     return win32_execvp(cmdname, argv);
 1561 }
 1562 
 1563 uid_t
 1564 PerlProcGetuid(struct IPerlProc* piPerl)
 1565 {
 1566     return getuid();
 1567 }
 1568 
 1569 uid_t
 1570 PerlProcGeteuid(struct IPerlProc* piPerl)
 1571 {
 1572     return geteuid();
 1573 }
 1574 
 1575 gid_t
 1576 PerlProcGetgid(struct IPerlProc* piPerl)
 1577 {
 1578     return getgid();
 1579 }
 1580 
 1581 gid_t
 1582 PerlProcGetegid(struct IPerlProc* piPerl)
 1583 {
 1584     return getegid();
 1585 }
 1586 
 1587 char *
 1588 PerlProcGetlogin(struct IPerlProc* piPerl)
 1589 {
 1590     return g_getlogin();
 1591 }
 1592 
 1593 int
 1594 PerlProcKill(struct IPerlProc* piPerl, int pid, int sig)
 1595 {
 1596     return win32_kill(pid, sig);
 1597 }
 1598 
 1599 int
 1600 PerlProcKillpg(struct IPerlProc* piPerl, int pid, int sig)
 1601 {
 1602     return win32_kill(pid, -sig);
 1603 }
 1604 
 1605 int
 1606 PerlProcPauseProc(struct IPerlProc* piPerl)
 1607 {
 1608     return win32_pause();
 1609 }
 1610 
 1611 PerlIO*
 1612 PerlProcPopen(struct IPerlProc* piPerl, const char *command, const char *mode)
 1613 {
 1614     dTHX;
 1615     PERL_FLUSHALL_FOR_CHILD;
 1616     return win32_popen(command, mode);
 1617 }
 1618 
 1619 PerlIO*
 1620 PerlProcPopenList(struct IPerlProc* piPerl, const char *mode, IV narg, SV **args)
 1621 {
 1622     dTHX;
 1623     PERL_FLUSHALL_FOR_CHILD;
 1624     return win32_popenlist(mode, narg, args);
 1625 }
 1626 
 1627 int
 1628 PerlProcPclose(struct IPerlProc* piPerl, PerlIO *stream)
 1629 {
 1630     return win32_pclose(stream);
 1631 }
 1632 
 1633 int
 1634 PerlProcPipe(struct IPerlProc* piPerl, int *phandles)
 1635 {
 1636     return win32_pipe(phandles, 512, O_BINARY);
 1637 }
 1638 
 1639 int
 1640 PerlProcSetuid(struct IPerlProc* piPerl, uid_t u)
 1641 {
 1642     return setuid(u);
 1643 }
 1644 
 1645 int
 1646 PerlProcSetgid(struct IPerlProc* piPerl, gid_t g)
 1647 {
 1648     return setgid(g);
 1649 }
 1650 
 1651 int
 1652 PerlProcSleep(struct IPerlProc* piPerl, unsigned int s)
 1653 {
 1654     return win32_sleep(s);
 1655 }
 1656 
 1657 int
 1658 PerlProcTimes(struct IPerlProc* piPerl, struct tms *timebuf)
 1659 {
 1660     return win32_times(timebuf);
 1661 }
 1662 
 1663 int
 1664 PerlProcWait(struct IPerlProc* piPerl, int *status)
 1665 {
 1666     return win32_wait(status);
 1667 }
 1668 
 1669 int
 1670 PerlProcWaitpid(struct IPerlProc* piPerl, int pid, int *status, int flags)
 1671 {
 1672     return win32_waitpid(pid, status, flags);
 1673 }
 1674 
 1675 Sighandler_t
 1676 PerlProcSignal(struct IPerlProc* piPerl, int sig, Sighandler_t subcode)
 1677 {
 1678     return win32_signal(sig, subcode);
 1679 }
 1680 
 1681 int
 1682 PerlProcGetTimeOfDay(struct IPerlProc* piPerl, struct timeval *t, void *z)
 1683 {
 1684     return win32_gettimeofday(t, z);
 1685 }
 1686 
 1687 #ifdef USE_ITHREADS
 1688 static THREAD_RET_TYPE
 1689 win32_start_child(LPVOID arg)
 1690 {
 1691     PerlInterpreter *my_perl = (PerlInterpreter*)arg;
 1692     int status;
 1693     HWND parent_message_hwnd;
 1694 #ifdef PERL_SYNC_FORK
 1695     static long sync_fork_id = 0;
 1696     long id = ++sync_fork_id;
 1697 #endif
 1698 
 1699 
 1700     PERL_SET_THX(my_perl);
 1701     win32_checkTLS(my_perl);
 1702 
 1703 #ifdef PERL_SYNC_FORK
 1704     w32_pseudo_id = id;
 1705 #else
 1706     w32_pseudo_id = GetCurrentThreadId();
 1707 #endif
 1708 #ifdef PERL_USES_PL_PIDSTATUS    
 1709     hv_clear(PL_pidstatus);
 1710 #endif    
 1711 
 1712     /* create message window and tell parent about it */
 1713     parent_message_hwnd = w32_message_hwnd;
 1714     w32_message_hwnd = win32_create_message_window();
 1715     if (parent_message_hwnd != NULL)
 1716         PostMessage(parent_message_hwnd, WM_USER_MESSAGE, w32_pseudo_id, (LPARAM)w32_message_hwnd);
 1717 
 1718     /* push a zero on the stack (we are the child) */
 1719     {
 1720     dSP;
 1721     dTARGET;
 1722     PUSHi(0);
 1723     PUTBACK;
 1724     }
 1725 
 1726     /* continue from next op */
 1727     PL_op = PL_op->op_next;
 1728 
 1729     {
 1730     dJMPENV;
 1731     volatile int oldscope = 1; /* We are responsible for all scopes */
 1732 
 1733 restart:
 1734     JMPENV_PUSH(status);
 1735     switch (status) {
 1736     case 0:
 1737         CALLRUNOPS(aTHX);
 1738             /* We may have additional unclosed scopes if fork() was called
 1739              * from within a BEGIN block.  See perlfork.pod for more details.
 1740              * We cannot clean up these other scopes because they belong to a
 1741              * different interpreter, but we also cannot leave PL_scopestack_ix
 1742              * dangling because that can trigger an assertion in perl_destruct().
 1743              */
 1744             if (PL_scopestack_ix > oldscope) {
 1745                 PL_scopestack[oldscope-1] = PL_scopestack[PL_scopestack_ix-1];
 1746                 PL_scopestack_ix = oldscope;
 1747             }
 1748         status = 0;
 1749         break;
 1750     case 2:
 1751         while (PL_scopestack_ix > oldscope)
 1752         LEAVE;
 1753         FREETMPS;
 1754         PL_curstash = PL_defstash;
 1755         if (PL_curstash != PL_defstash) {
 1756         SvREFCNT_dec(PL_curstash);
 1757         PL_curstash = (HV *)SvREFCNT_inc(PL_defstash);
 1758         }
 1759         if (PL_endav && !PL_minus_c) {
 1760         PERL_SET_PHASE(PERL_PHASE_END);
 1761         call_list(oldscope, PL_endav);
 1762         }
 1763         status = STATUS_EXIT;
 1764         break;
 1765     case 3:
 1766         if (PL_restartop) {
 1767         POPSTACK_TO(PL_mainstack);
 1768         PL_op = PL_restartop;
 1769         PL_restartop = (OP*)NULL;
 1770         goto restart;
 1771         }
 1772         PerlIO_printf(Perl_error_log, "panic: restartop\n");
 1773         FREETMPS;
 1774         status = 1;
 1775         break;
 1776     }
 1777     JMPENV_POP;
 1778 
 1779     /* XXX hack to avoid perl_destruct() freeing optree */
 1780         win32_checkTLS(my_perl);
 1781     PL_main_root = (OP*)NULL;
 1782     }
 1783 
 1784     win32_checkTLS(my_perl);
 1785     /* close the std handles to avoid fd leaks */
 1786     {
 1787     do_close(PL_stdingv, FALSE);
 1788     do_close(gv_fetchpv("STDOUT", TRUE, SVt_PVIO), FALSE); /* PL_stdoutgv - ISAGN */
 1789     do_close(PL_stderrgv, FALSE);
 1790     }
 1791 
 1792     /* destroy everything (waits for any pseudo-forked children) */
 1793     win32_checkTLS(my_perl);
 1794     perl_destruct(my_perl);
 1795     win32_checkTLS(my_perl);
 1796     perl_free(my_perl);
 1797 
 1798 #ifdef PERL_SYNC_FORK
 1799     return id;
 1800 #else
 1801     return (DWORD)status;
 1802 #endif
 1803 }
 1804 #endif /* USE_ITHREADS */
 1805 
 1806 int
 1807 PerlProcFork(struct IPerlProc* piPerl)
 1808 {
 1809 #ifdef USE_ITHREADS
 1810     dTHX;
 1811     DWORD id;
 1812     HANDLE handle;
 1813     CPerlHost *h;
 1814 
 1815     if (w32_num_pseudo_children >= MAXIMUM_WAIT_OBJECTS) {
 1816     errno = EAGAIN;
 1817     return -1;
 1818     }
 1819     h = new CPerlHost(*(CPerlHost*)w32_internal_host);
 1820     PerlInterpreter *new_perl = perl_clone_using((PerlInterpreter*)aTHX,
 1821                          CLONEf_COPY_STACKS,
 1822                          h->m_pHostperlMem,
 1823                          h->m_pHostperlMemShared,
 1824                          h->m_pHostperlMemParse,
 1825                          h->m_pHostperlEnv,
 1826                          h->m_pHostperlStdIO,
 1827                          h->m_pHostperlLIO,
 1828                          h->m_pHostperlDir,
 1829                          h->m_pHostperlSock,
 1830                          h->m_pHostperlProc
 1831                          );
 1832     new_perl->Isys_intern.internal_host = h;
 1833     h->host_perl = new_perl;
 1834 #  ifdef PERL_SYNC_FORK
 1835     id = win32_start_child((LPVOID)new_perl);
 1836     PERL_SET_THX(aTHX);
 1837 #  else
 1838     if (w32_message_hwnd == INVALID_HANDLE_VALUE)
 1839         w32_message_hwnd = win32_create_message_window();
 1840     new_perl->Isys_intern.message_hwnd = w32_message_hwnd;
 1841     w32_pseudo_child_message_hwnds[w32_num_pseudo_children] =
 1842         (w32_message_hwnd == NULL) ? (HWND)NULL : (HWND)INVALID_HANDLE_VALUE;
 1843 #    ifdef USE_RTL_THREAD_API
 1844     handle = (HANDLE)_beginthreadex((void*)NULL, 0, win32_start_child,
 1845                     (void*)new_perl, 0, (unsigned*)&id);
 1846 #    else
 1847     handle = CreateThread(NULL, 0, win32_start_child,
 1848               (LPVOID)new_perl, 0, &id);
 1849 #    endif
 1850     PERL_SET_THX(aTHX); /* XXX perl_clone*() set TLS */
 1851     if (!handle) {
 1852     errno = EAGAIN;
 1853     return -1;
 1854     }
 1855     w32_pseudo_child_handles[w32_num_pseudo_children] = handle;
 1856     w32_pseudo_child_pids[w32_num_pseudo_children] = id;
 1857     w32_pseudo_child_sigterm[w32_num_pseudo_children] = 0;
 1858     ++w32_num_pseudo_children;
 1859 #  endif
 1860     return -(int)id;
 1861 #else
 1862     win32_croak_not_implemented("fork()");
 1863     return -1;
 1864 #endif /* USE_ITHREADS */
 1865 }
 1866 
 1867 int
 1868 PerlProcGetpid(struct IPerlProc* piPerl)
 1869 {
 1870     return win32_getpid();
 1871 }
 1872 
 1873 void*
 1874 PerlProcDynaLoader(struct IPerlProc* piPerl, const char* filename)
 1875 {
 1876     return win32_dynaload(filename);
 1877 }
 1878 
 1879 void
 1880 PerlProcGetOSError(struct IPerlProc* piPerl, SV* sv, DWORD dwErr)
 1881 {
 1882     win32_str_os_error(sv, dwErr);
 1883 }
 1884 
 1885 int
 1886 PerlProcSpawnvp(struct IPerlProc* piPerl, int mode, const char *cmdname, const char *const *argv)
 1887 {
 1888     return win32_spawnvp(mode, cmdname, argv);
 1889 }
 1890 
 1891 int
 1892 PerlProcLastHost(struct IPerlProc* piPerl)
 1893 {
 1894  /* this dTHX is unused in an optimized build since CPerlHost::num_hosts
 1895     is a static */
 1896  dTHX;
 1897  CPerlHost *h = (CPerlHost*)w32_internal_host;
 1898  return h->LastHost();
 1899 }
 1900 
 1901 const struct IPerlProc perlProc =
 1902 {
 1903     PerlProcAbort,
 1904     PerlProcCrypt,
 1905     PerlProcExit,
 1906     PerlProc_Exit,
 1907     PerlProcExecl,
 1908     PerlProcExecv,
 1909     PerlProcExecvp,
 1910     PerlProcGetuid,
 1911     PerlProcGeteuid,
 1912     PerlProcGetgid,
 1913     PerlProcGetegid,
 1914     PerlProcGetlogin,
 1915     PerlProcKill,
 1916     PerlProcKillpg,
 1917     PerlProcPauseProc,
 1918     PerlProcPopen,
 1919     PerlProcPclose,
 1920     PerlProcPipe,
 1921     PerlProcSetuid,
 1922     PerlProcSetgid,
 1923     PerlProcSleep,
 1924     PerlProcTimes,
 1925     PerlProcWait,
 1926     PerlProcWaitpid,
 1927     PerlProcSignal,
 1928     PerlProcFork,
 1929     PerlProcGetpid,
 1930     PerlProcDynaLoader,
 1931     PerlProcGetOSError,
 1932     PerlProcSpawnvp,
 1933     PerlProcLastHost,
 1934     PerlProcPopenList,
 1935     PerlProcGetTimeOfDay
 1936 };
 1937 
 1938 
 1939 /*
 1940  * CPerlHost
 1941  */
 1942 
 1943 CPerlHost::CPerlHost(void)
 1944 {
 1945     /* Construct a host from scratch */
 1946     InterlockedIncrement(&num_hosts);
 1947     m_pvDir = new VDir();
 1948     m_pVMem = new VMem();
 1949     m_pVMemShared = new VMem();
 1950     m_pVMemParse =  new VMem();
 1951 
 1952     m_pvDir->Init(NULL, m_pVMem);
 1953 
 1954     m_dwEnvCount = 0;
 1955     m_lppEnvList = NULL;
 1956     m_bTopLevel = TRUE;
 1957 
 1958     CopyMemory(&m_hostperlMem, &perlMem, sizeof(perlMem));
 1959     CopyMemory(&m_hostperlMemShared, &perlMemShared, sizeof(perlMemShared));
 1960     CopyMemory(&m_hostperlMemParse, &perlMemParse, sizeof(perlMemParse));
 1961     CopyMemory(&m_hostperlEnv, &perlEnv, sizeof(perlEnv));
 1962     CopyMemory(&m_hostperlStdIO, &perlStdIO, sizeof(perlStdIO));
 1963     CopyMemory(&m_hostperlLIO, &perlLIO, sizeof(perlLIO));
 1964     CopyMemory(&m_hostperlDir, &perlDir, sizeof(perlDir));
 1965     CopyMemory(&m_hostperlSock, &perlSock, sizeof(perlSock));
 1966     CopyMemory(&m_hostperlProc, &perlProc, sizeof(perlProc));
 1967 
 1968     m_pHostperlMem      = &m_hostperlMem;
 1969     m_pHostperlMemShared    = &m_hostperlMemShared;
 1970     m_pHostperlMemParse     = &m_hostperlMemParse;
 1971     m_pHostperlEnv      = &m_hostperlEnv;
 1972     m_pHostperlStdIO        = &m_hostperlStdIO;
 1973     m_pHostperlLIO      = &m_hostperlLIO;
 1974     m_pHostperlDir      = &m_hostperlDir;
 1975     m_pHostperlSock     = &m_hostperlSock;
 1976     m_pHostperlProc     = &m_hostperlProc;
 1977 }
 1978 
 1979 #define SETUPEXCHANGE(xptr, iptr, table) \
 1980     STMT_START {                \
 1981     if (xptr) {             \
 1982         iptr = *xptr;           \
 1983         *xptr = &table;         \
 1984     }                   \
 1985     else {                  \
 1986         iptr = &table;          \
 1987     }                   \
 1988     } STMT_END
 1989 
 1990 CPerlHost::CPerlHost(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared,
 1991          struct IPerlMem** ppMemParse, struct IPerlEnv** ppEnv,
 1992          struct IPerlStdIO** ppStdIO, struct IPerlLIO** ppLIO,
 1993          struct IPerlDir** ppDir, struct IPerlSock** ppSock,
 1994          struct IPerlProc** ppProc)
 1995 {
 1996     InterlockedIncrement(&num_hosts);
 1997     m_pvDir = new VDir(0);
 1998     m_pVMem = new VMem();
 1999     m_pVMemShared = new VMem();
 2000     m_pVMemParse =  new VMem();
 2001 
 2002     m_pvDir->Init(NULL, m_pVMem);
 2003 
 2004     m_dwEnvCount = 0;
 2005     m_lppEnvList = NULL;
 2006     m_bTopLevel = FALSE;
 2007 
 2008     CopyMemory(&m_hostperlMem, &perlMem, sizeof(perlMem));
 2009     CopyMemory(&m_hostperlMemShared, &perlMemShared, sizeof(perlMemShared));
 2010     CopyMemory(&m_hostperlMemParse, &perlMemParse, sizeof(perlMemParse));
 2011     CopyMemory(&m_hostperlEnv, &perlEnv, sizeof(perlEnv));
 2012     CopyMemory(&m_hostperlStdIO, &perlStdIO, sizeof(perlStdIO));
 2013     CopyMemory(&m_hostperlLIO, &perlLIO, sizeof(perlLIO));
 2014     CopyMemory(&m_hostperlDir, &perlDir, sizeof(perlDir));
 2015     CopyMemory(&m_hostperlSock, &perlSock, sizeof(perlSock));
 2016     CopyMemory(&m_hostperlProc, &perlProc, sizeof(perlProc));
 2017 
 2018     SETUPEXCHANGE(ppMem,    m_pHostperlMem,     m_hostperlMem);
 2019     SETUPEXCHANGE(ppMemShared,  m_pHostperlMemShared,   m_hostperlMemShared);
 2020     SETUPEXCHANGE(ppMemParse,   m_pHostperlMemParse,    m_hostperlMemParse);
 2021     SETUPEXCHANGE(ppEnv,    m_pHostperlEnv,     m_hostperlEnv);
 2022     SETUPEXCHANGE(ppStdIO,  m_pHostperlStdIO,   m_hostperlStdIO);
 2023     SETUPEXCHANGE(ppLIO,    m_pHostperlLIO,     m_hostperlLIO);
 2024     SETUPEXCHANGE(ppDir,    m_pHostperlDir,     m_hostperlDir);
 2025     SETUPEXCHANGE(ppSock,   m_pHostperlSock,    m_hostperlSock);
 2026     SETUPEXCHANGE(ppProc,   m_pHostperlProc,    m_hostperlProc);
 2027 }
 2028 #undef SETUPEXCHANGE
 2029 
 2030 CPerlHost::CPerlHost(CPerlHost& host)
 2031 {
 2032     /* Construct a host from another host */
 2033     InterlockedIncrement(&num_hosts);
 2034     m_pVMem = new VMem();
 2035     m_pVMemShared = host.GetMemShared();
 2036     m_pVMemParse =  host.GetMemParse();
 2037 
 2038     /* duplicate directory info */
 2039     m_pvDir = new VDir(0);
 2040     m_pvDir->Init(host.GetDir(), m_pVMem);
 2041 
 2042     CopyMemory(&m_hostperlMem, &perlMem, sizeof(perlMem));
 2043     CopyMemory(&m_hostperlMemShared, &perlMemShared, sizeof(perlMemShared));
 2044     CopyMemory(&m_hostperlMemParse, &perlMemParse, sizeof(perlMemParse));
 2045     CopyMemory(&m_hostperlEnv, &perlEnv, sizeof(perlEnv));
 2046     CopyMemory(&m_hostperlStdIO, &perlStdIO, sizeof(perlStdIO));
 2047     CopyMemory(&m_hostperlLIO, &perlLIO, sizeof(perlLIO));
 2048     CopyMemory(&m_hostperlDir, &perlDir, sizeof(perlDir));
 2049     CopyMemory(&m_hostperlSock, &perlSock, sizeof(perlSock));
 2050     CopyMemory(&m_hostperlProc, &perlProc, sizeof(perlProc));
 2051     m_pHostperlMem      = &m_hostperlMem;
 2052     m_pHostperlMemShared    = &m_hostperlMemShared;
 2053     m_pHostperlMemParse     = &m_hostperlMemParse;
 2054     m_pHostperlEnv      = &m_hostperlEnv;
 2055     m_pHostperlStdIO        = &m_hostperlStdIO;
 2056     m_pHostperlLIO      = &m_hostperlLIO;
 2057     m_pHostperlDir      = &m_hostperlDir;
 2058     m_pHostperlSock     = &m_hostperlSock;
 2059     m_pHostperlProc     = &m_hostperlProc;
 2060 
 2061     m_dwEnvCount = 0;
 2062     m_lppEnvList = NULL;
 2063     m_bTopLevel = FALSE;
 2064 
 2065     /* duplicate environment info */
 2066     LPSTR lpPtr;
 2067     DWORD dwIndex = 0;
 2068     while(lpPtr = host.GetIndex(dwIndex))
 2069     Add(lpPtr);
 2070 }
 2071 
 2072 CPerlHost::~CPerlHost(void)
 2073 {
 2074     Reset();
 2075     InterlockedDecrement(&num_hosts);
 2076     delete m_pvDir;
 2077     m_pVMemParse->Release();
 2078     m_pVMemShared->Release();
 2079     m_pVMem->Release();
 2080 }
 2081 
 2082 LPSTR
 2083 CPerlHost::Find(LPCSTR lpStr)
 2084 {
 2085     LPSTR lpPtr;
 2086     LPSTR* lppPtr = Lookup(lpStr);
 2087     if(lppPtr != NULL) {
 2088     for(lpPtr = *lppPtr; *lpPtr != '\0' && *lpPtr != '='; ++lpPtr)
 2089         ;
 2090 
 2091     if(*lpPtr == '=')
 2092         ++lpPtr;
 2093 
 2094     return lpPtr;
 2095     }
 2096     return NULL;
 2097 }
 2098 
 2099 int
 2100 lookup(const void *arg1, const void *arg2)
 2101 {   // Compare strings
 2102     char*ptr1, *ptr2;
 2103     char c1,c2;
 2104 
 2105     ptr1 = *(char**)arg1;
 2106     ptr2 = *(char**)arg2;
 2107     for(;;) {
 2108     c1 = *ptr1++;
 2109     c2 = *ptr2++;
 2110     if(c1 == '\0' || c1 == '=') {
 2111         if(c2 == '\0' || c2 == '=')
 2112         break;
 2113 
 2114         return -1; // string 1 < string 2
 2115     }
 2116     else if(c2 == '\0' || c2 == '=')
 2117         return 1; // string 1 > string 2
 2118     else if(c1 != c2) {
 2119         c1 = toupper(c1);
 2120         c2 = toupper(c2);
 2121         if(c1 != c2) {
 2122         if(c1 < c2)
 2123             return -1; // string 1 < string 2
 2124 
 2125         return 1; // string 1 > string 2
 2126         }
 2127     }
 2128     }
 2129     return 0;
 2130 }
 2131 
 2132 LPSTR*
 2133 CPerlHost::Lookup(LPCSTR lpStr)
 2134 {
 2135 #ifdef UNDER_CE
 2136     if (!m_lppEnvList || !m_dwEnvCount)
 2137     return NULL;
 2138 #endif
 2139     if (!lpStr)
 2140     return NULL;
 2141     return (LPSTR*)bsearch(&lpStr, m_lppEnvList, m_dwEnvCount, sizeof(LPSTR), lookup);
 2142 }
 2143 
 2144 int
 2145 compare(const void *arg1, const void *arg2)
 2146 {   // Compare strings
 2147     char*ptr1, *ptr2;
 2148     char c1,c2;
 2149 
 2150     ptr1 = *(char**)arg1;
 2151     ptr2 = *(char**)arg2;
 2152     for(;;) {
 2153     c1 = *ptr1++;
 2154     c2 = *ptr2++;
 2155     if(c1 == '\0' || c1 == '=') {
 2156         if(c1 == c2)
 2157         break;
 2158 
 2159         return -1; // string 1 < string 2
 2160     }
 2161     else if(c2 == '\0' || c2 == '=')
 2162         return 1; // string 1 > string 2
 2163     else if(c1 != c2) {
 2164         c1 = toupper(c1);
 2165         c2 = toupper(c2);
 2166         if(c1 != c2) {
 2167         if(c1 < c2)
 2168             return -1; // string 1 < string 2
 2169 
 2170         return 1; // string 1 > string 2
 2171         }
 2172     }
 2173     }
 2174     return 0;
 2175 }
 2176 
 2177 void
 2178 CPerlHost::Add(LPCSTR lpStr)
 2179 {
 2180     LPSTR *lpPtr;
 2181     STRLEN length = strlen(lpStr)+1;
 2182 
 2183     // replacing ?
 2184     lpPtr = Lookup(lpStr);
 2185     if (lpPtr != NULL) {
 2186     // must allocate things via host memory allocation functions 
 2187     // rather than perl's Renew() et al, as the perl interpreter
 2188     // may either not be initialized enough when we allocate these,
 2189     // or may already be dead when we go to free these
 2190     *lpPtr = (char*)Realloc(*lpPtr, length * sizeof(char));
 2191     strcpy(*lpPtr, lpStr);
 2192     }
 2193     else {
 2194     m_lppEnvList = (LPSTR*)Realloc(m_lppEnvList, (m_dwEnvCount+1) * sizeof(LPSTR));
 2195     if (m_lppEnvList) {
 2196         m_lppEnvList[m_dwEnvCount] = (char*)Malloc(length * sizeof(char));
 2197         if (m_lppEnvList[m_dwEnvCount] != NULL) {
 2198         strcpy(m_lppEnvList[m_dwEnvCount], lpStr);
 2199         ++m_dwEnvCount;
 2200         qsort(m_lppEnvList, m_dwEnvCount, sizeof(LPSTR), compare);
 2201         }
 2202     }
 2203     }
 2204 }
 2205 
 2206 DWORD
 2207 CPerlHost::CalculateEnvironmentSpace(void)
 2208 {
 2209     DWORD index;
 2210     DWORD dwSize = 0;
 2211     for(index = 0; index < m_dwEnvCount; ++index)
 2212     dwSize += strlen(m_lppEnvList[index]) + 1;
 2213 
 2214     return dwSize;
 2215 }
 2216 
 2217 void
 2218 CPerlHost::FreeLocalEnvironmentStrings(LPSTR lpStr)
 2219 {
 2220     Safefree(lpStr);
 2221 }
 2222 
 2223 char*
 2224 CPerlHost::GetChildDir(void)
 2225 {
 2226     char* ptr;
 2227     size_t length;
 2228 
 2229     Newx(ptr, MAX_PATH+1, char);
 2230     m_pvDir->GetCurrentDirectoryA(MAX_PATH+1, ptr);
 2231     length = strlen(ptr);
 2232     if (length > 3) {
 2233         if ((ptr[length-1] == '\\') || (ptr[length-1] == '/'))
 2234             ptr[length-1] = 0;
 2235     }
 2236     return ptr;
 2237 }
 2238 
 2239 void
 2240 CPerlHost::FreeChildDir(char* pStr)
 2241 {
 2242     Safefree(pStr);
 2243 }
 2244 
 2245 LPSTR
 2246 CPerlHost::CreateLocalEnvironmentStrings(VDir &vDir)
 2247 {
 2248     LPSTR lpStr, lpPtr, lpEnvPtr, lpTmp, lpLocalEnv, lpAllocPtr;
 2249     DWORD dwSize, dwEnvIndex;
 2250     int nLength, compVal;
 2251 
 2252     // get the process environment strings
 2253     lpAllocPtr = lpTmp = (LPSTR)win32_getenvironmentstrings();
 2254 
 2255     // step over current directory stuff
 2256     while(*lpTmp == '=')
 2257     lpTmp += strlen(lpTmp) + 1;
 2258 
 2259     // save the start of the environment strings
 2260     lpEnvPtr = lpTmp;
 2261     for(dwSize = 1; *lpTmp != '\0'; lpTmp += strlen(lpTmp) + 1) {
 2262     // calculate the size of the environment strings
 2263     dwSize += strlen(lpTmp) + 1;
 2264     }
 2265 
 2266     // add the size of current directories
 2267     dwSize += vDir.CalculateEnvironmentSpace();
 2268 
 2269     // add the additional space used by changes made to the environment
 2270     dwSize += CalculateEnvironmentSpace();
 2271 
 2272     Newx(lpStr, dwSize, char);
 2273     lpPtr = lpStr;
 2274     if(lpStr != NULL) {
 2275     // build the local environment
 2276     lpStr = vDir.BuildEnvironmentSpace(lpStr);
 2277 
 2278     dwEnvIndex = 0;
 2279     lpLocalEnv = GetIndex(dwEnvIndex);
 2280     while(*lpEnvPtr != '\0') {
 2281         if(!lpLocalEnv) {
 2282         // all environment overrides have been added
 2283         // so copy string into place
 2284         strcpy(lpStr, lpEnvPtr);
 2285         nLength = strlen(lpEnvPtr) + 1;
 2286         lpStr += nLength;
 2287         lpEnvPtr += nLength;
 2288         }
 2289         else {
 2290         // determine which string to copy next
 2291         compVal = compare(&lpEnvPtr, &lpLocalEnv);
 2292         if(compVal < 0) {
 2293             strcpy(lpStr, lpEnvPtr);
 2294             nLength = strlen(lpEnvPtr) + 1;
 2295             lpStr += nLength;
 2296             lpEnvPtr += nLength;
 2297         }
 2298         else {
 2299             char *ptr = strchr(lpLocalEnv, '=');
 2300             if(ptr && ptr[1]) {
 2301             strcpy(lpStr, lpLocalEnv);
 2302             lpStr += strlen(lpLocalEnv) + 1;
 2303             }
 2304             lpLocalEnv = GetIndex(dwEnvIndex);
 2305             if(compVal == 0) {
 2306             // this string was replaced
 2307             lpEnvPtr += strlen(lpEnvPtr) + 1;
 2308             }
 2309         }
 2310         }
 2311     }
 2312 
 2313     while(lpLocalEnv) {
 2314         // still have environment overrides to add
 2315         // so copy the strings into place if not an override
 2316         char *ptr = strchr(lpLocalEnv, '=');
 2317         if(ptr && ptr[1]) {
 2318         strcpy(lpStr, lpLocalEnv);
 2319         lpStr += strlen(lpLocalEnv) + 1;
 2320         }
 2321         lpLocalEnv = GetIndex(dwEnvIndex);
 2322     }
 2323 
 2324     // add final NULL
 2325     *lpStr = '\0';
 2326     }
 2327 
 2328     // release the process environment strings
 2329     win32_freeenvironmentstrings(lpAllocPtr);
 2330 
 2331     return lpPtr;
 2332 }
 2333 
 2334 void
 2335 CPerlHost::Reset(void)
 2336 {
 2337     if(m_lppEnvList != NULL) {
 2338     for(DWORD index = 0; index < m_dwEnvCount; ++index) {
 2339         Free(m_lppEnvList[index]);
 2340         m_lppEnvList[index] = NULL;
 2341     }
 2342     }
 2343     m_dwEnvCount = 0;
 2344     Free(m_lppEnvList);
 2345     m_lppEnvList = NULL;
 2346 }
 2347 
 2348 void
 2349 CPerlHost::Clearenv(void)
 2350 {
 2351     char ch;
 2352     LPSTR lpPtr, lpStr, lpEnvPtr;
 2353     if (m_lppEnvList != NULL) {
 2354     /* set every entry to an empty string */
 2355     for(DWORD index = 0; index < m_dwEnvCount; ++index) {
 2356         char* ptr = strchr(m_lppEnvList[index], '=');
 2357         if(ptr) {
 2358         *++ptr = 0;
 2359         }
 2360     }
 2361     }
 2362 
 2363     /* get the process environment strings */
 2364     lpStr = lpEnvPtr = (LPSTR)win32_getenvironmentstrings();
 2365 
 2366     /* step over current directory stuff */
 2367     while(*lpStr == '=')
 2368     lpStr += strlen(lpStr) + 1;
 2369 
 2370     while(*lpStr) {
 2371     lpPtr = strchr(lpStr, '=');
 2372     if(lpPtr) {
 2373         ch = *++lpPtr;
 2374         *lpPtr = 0;
 2375         Add(lpStr);
 2376         if (m_bTopLevel)
 2377         (void)win32_putenv(lpStr);
 2378         *lpPtr = ch;
 2379     }
 2380     lpStr += strlen(lpStr) + 1;
 2381     }
 2382 
 2383     win32_freeenvironmentstrings(lpEnvPtr);
 2384 }
 2385 
 2386 
 2387 char*
 2388 CPerlHost::Getenv(const char *varname)
 2389 {
 2390     if (!m_bTopLevel) {
 2391     char *pEnv = Find(varname);
 2392     if (pEnv && *pEnv)
 2393         return pEnv;
 2394     }
 2395     return win32_getenv(varname);
 2396 }
 2397 
 2398 int
 2399 CPerlHost::Putenv(const char *envstring)
 2400 {
 2401     Add(envstring);
 2402     if (m_bTopLevel)
 2403     return win32_putenv(envstring);
 2404 
 2405     return 0;
 2406 }
 2407 
 2408 int
 2409 CPerlHost::Chdir(const char *dirname)
 2410 {
 2411     int ret;
 2412     if (!dirname) {
 2413     errno = ENOENT;
 2414     return -1;
 2415     }
 2416     ret = m_pvDir->SetCurrentDirectoryA((char*)dirname);
 2417     if(ret < 0) {
 2418     errno = ENOENT;
 2419     }
 2420     return ret;
 2421 }
 2422 
 2423 #endif /* ___PerlHost_H___ */