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