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