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