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