This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
-t should only return TRUE for file handles connected to a TTY
[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*
adb71456 666PerlStdIOGets(struct IPerlStdIO* piPerl, FILE* pf, char* s, int n)
7766f137 667{
adb71456 668 return win32_fgets(s, n, pf);
7766f137
GS
669}
670
671int
adb71456 672PerlStdIOPutc(struct IPerlStdIO* piPerl, FILE* pf, int c)
7766f137 673{
adb71456 674 return win32_fputc(c, pf);
7766f137
GS
675}
676
677int
adb71456 678PerlStdIOPuts(struct IPerlStdIO* piPerl, FILE* pf, const char *s)
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{
827da6a3
JD
1007 /* The Microsoft isatty() function returns true for *all*
1008 * character mode devices, including "nul". Our implementation
1009 * should only return true if the handle has a console buffer.
1010 */
1011 DWORD mode;
1012 HANDLE fh = (HANDLE)_get_osfhandle(fd);
1013 if (fh == (HANDLE)-1) {
1014 /* errno is already set to EBADF */
1015 return 0;
1016 }
1017
1018 if (GetConsoleMode(fh, &mode))
1019 return 1;
1020
1021 errno = ENOTTY;
1022 return 0;
7766f137
GS
1023}
1024
1025int
1026PerlLIOLink(struct IPerlLIO* piPerl, const char*oldname, const char *newname)
1027{
1028 return win32_link(oldname, newname);
1029}
1030
c623ac67
GS
1031Off_t
1032PerlLIOLseek(struct IPerlLIO* piPerl, int handle, Off_t offset, int origin)
7766f137
GS
1033{
1034 return win32_lseek(handle, offset, origin);
1035}
1036
1037int
c623ac67 1038PerlLIOLstat(struct IPerlLIO* piPerl, const char *path, Stat_t *buffer)
7766f137
GS
1039{
1040 return win32_stat(path, buffer);
1041}
1042
1043char*
1044PerlLIOMktemp(struct IPerlLIO* piPerl, char *Template)
1045{
1046 return mktemp(Template);
1047}
1048
1049int
1050PerlLIOOpen(struct IPerlLIO* piPerl, const char *filename, int oflag)
1051{
1052 return win32_open(filename, oflag);
1053}
1054
1055int
1056PerlLIOOpen3(struct IPerlLIO* piPerl, const char *filename, int oflag, int pmode)
1057{
1058 return win32_open(filename, oflag, pmode);
1059}
1060
1061int
1062PerlLIORead(struct IPerlLIO* piPerl, int handle, void *buffer, unsigned int count)
1063{
1064 return win32_read(handle, buffer, count);
1065}
1066
1067int
1068PerlLIORename(struct IPerlLIO* piPerl, const char *OldFileName, const char *newname)
1069{
1070 return win32_rename(OldFileName, newname);
1071}
1072
1073int
1074PerlLIOSetmode(struct IPerlLIO* piPerl, int handle, int mode)
1075{
1076 return win32_setmode(handle, mode);
1077}
1078
1079int
c623ac67 1080PerlLIONameStat(struct IPerlLIO* piPerl, const char *path, Stat_t *buffer)
7766f137
GS
1081{
1082 return win32_stat(path, buffer);
1083}
1084
1085char*
1086PerlLIOTmpnam(struct IPerlLIO* piPerl, char *string)
1087{
1088 return tmpnam(string);
1089}
1090
1091int
1092PerlLIOUmask(struct IPerlLIO* piPerl, int pmode)
1093{
1094 return umask(pmode);
1095}
1096
1097int
1098PerlLIOUnlink(struct IPerlLIO* piPerl, const char *filename)
1099{
1100 return win32_unlink(filename);
1101}
1102
1103int
c3ff6b30 1104PerlLIOUtime(struct IPerlLIO* piPerl, const char *filename, struct utimbuf *times)
7766f137
GS
1105{
1106 return win32_utime(filename, times);
1107}
1108
1109int
1110PerlLIOWrite(struct IPerlLIO* piPerl, int handle, const void *buffer, unsigned int count)
1111{
1112 return win32_write(handle, buffer, count);
1113}
1114
1115struct IPerlLIO perlLIO =
1116{
1117 PerlLIOAccess,
1118 PerlLIOChmod,
1119 PerlLIOChown,
1120 PerlLIOChsize,
1121 PerlLIOClose,
1122 PerlLIODup,
1123 PerlLIODup2,
1124 PerlLIOFlock,
1125 PerlLIOFileStat,
1126 PerlLIOIOCtl,
1127 PerlLIOIsatty,
1128 PerlLIOLink,
1129 PerlLIOLseek,
1130 PerlLIOLstat,
1131 PerlLIOMktemp,
1132 PerlLIOOpen,
1133 PerlLIOOpen3,
1134 PerlLIORead,
1135 PerlLIORename,
1136 PerlLIOSetmode,
1137 PerlLIONameStat,
1138 PerlLIOTmpnam,
1139 PerlLIOUmask,
1140 PerlLIOUnlink,
1141 PerlLIOUtime,
1142 PerlLIOWrite,
1143};
1144
1145
1146#undef IPERL2HOST
1147#define IPERL2HOST(x) IPerlDir2Host(x)
1148
1149/* IPerlDIR */
1150int
1151PerlDirMakedir(struct IPerlDir* piPerl, const char *dirname, int mode)
1152{
1153 return win32_mkdir(dirname, mode);
1154}
1155
1156int
1157PerlDirChdir(struct IPerlDir* piPerl, const char *dirname)
1158{
1159 return IPERL2HOST(piPerl)->Chdir(dirname);
1160}
1161
1162int
1163PerlDirRmdir(struct IPerlDir* piPerl, const char *dirname)
1164{
1165 return win32_rmdir(dirname);
1166}
1167
1168int
1169PerlDirClose(struct IPerlDir* piPerl, DIR *dirp)
1170{
1171 return win32_closedir(dirp);
1172}
1173
1174DIR*
0e06f75d 1175PerlDirOpen(struct IPerlDir* piPerl, const char *filename)
7766f137
GS
1176{
1177 return win32_opendir(filename);
1178}
1179
1180struct direct *
1181PerlDirRead(struct IPerlDir* piPerl, DIR *dirp)
1182{
1183 return win32_readdir(dirp);
1184}
1185
1186void
1187PerlDirRewind(struct IPerlDir* piPerl, DIR *dirp)
1188{
1189 win32_rewinddir(dirp);
1190}
1191
1192void
1193PerlDirSeek(struct IPerlDir* piPerl, DIR *dirp, long loc)
1194{
1195 win32_seekdir(dirp, loc);
1196}
1197
1198long
1199PerlDirTell(struct IPerlDir* piPerl, DIR *dirp)
1200{
1201 return win32_telldir(dirp);
1202}
1203
1204char*
1205PerlDirMapPathA(struct IPerlDir* piPerl, const char* path)
1206{
1207 return IPERL2HOST(piPerl)->MapPathA(path);
1208}
1209
1210WCHAR*
1211PerlDirMapPathW(struct IPerlDir* piPerl, const WCHAR* path)
1212{
1213 return IPERL2HOST(piPerl)->MapPathW(path);
1214}
1215
1216struct IPerlDir perlDir =
1217{
1218 PerlDirMakedir,
1219 PerlDirChdir,
1220 PerlDirRmdir,
1221 PerlDirClose,
1222 PerlDirOpen,
1223 PerlDirRead,
1224 PerlDirRewind,
1225 PerlDirSeek,
1226 PerlDirTell,
1227 PerlDirMapPathA,
1228 PerlDirMapPathW,
1229};
1230
1231
1232/* IPerlSock */
1233u_long
1234PerlSockHtonl(struct IPerlSock* piPerl, u_long hostlong)
1235{
1236 return win32_htonl(hostlong);
1237}
1238
1239u_short
1240PerlSockHtons(struct IPerlSock* piPerl, u_short hostshort)
1241{
1242 return win32_htons(hostshort);
1243}
1244
1245u_long
1246PerlSockNtohl(struct IPerlSock* piPerl, u_long netlong)
1247{
1248 return win32_ntohl(netlong);
1249}
1250
1251u_short
1252PerlSockNtohs(struct IPerlSock* piPerl, u_short netshort)
1253{
1254 return win32_ntohs(netshort);
1255}
1256
1257SOCKET PerlSockAccept(struct IPerlSock* piPerl, SOCKET s, struct sockaddr* addr, int* addrlen)
1258{
1259 return win32_accept(s, addr, addrlen);
1260}
1261
1262int
1263PerlSockBind(struct IPerlSock* piPerl, SOCKET s, const struct sockaddr* name, int namelen)
1264{
1265 return win32_bind(s, name, namelen);
1266}
1267
1268int
1269PerlSockConnect(struct IPerlSock* piPerl, SOCKET s, const struct sockaddr* name, int namelen)
1270{
1271 return win32_connect(s, name, namelen);
1272}
1273
1274void
1275PerlSockEndhostent(struct IPerlSock* piPerl)
1276{
1277 win32_endhostent();
1278}
1279
1280void
1281PerlSockEndnetent(struct IPerlSock* piPerl)
1282{
1283 win32_endnetent();
1284}
1285
1286void
1287PerlSockEndprotoent(struct IPerlSock* piPerl)
1288{
1289 win32_endprotoent();
1290}
1291
1292void
1293PerlSockEndservent(struct IPerlSock* piPerl)
1294{
1295 win32_endservent();
1296}
1297
1298struct hostent*
1299PerlSockGethostbyaddr(struct IPerlSock* piPerl, const char* addr, int len, int type)
1300{
1301 return win32_gethostbyaddr(addr, len, type);
1302}
1303
1304struct hostent*
1305PerlSockGethostbyname(struct IPerlSock* piPerl, const char* name)
1306{
1307 return win32_gethostbyname(name);
1308}
1309
1310struct hostent*
1311PerlSockGethostent(struct IPerlSock* piPerl)
1312{
acfe0abc 1313 dTHX;
7766f137
GS
1314 Perl_croak(aTHX_ "gethostent not implemented!\n");
1315 return NULL;
1316}
1317
1318int
1319PerlSockGethostname(struct IPerlSock* piPerl, char* name, int namelen)
1320{
1321 return win32_gethostname(name, namelen);
1322}
1323
1324struct netent *
1325PerlSockGetnetbyaddr(struct IPerlSock* piPerl, long net, int type)
1326{
1327 return win32_getnetbyaddr(net, type);
1328}
1329
1330struct netent *
1331PerlSockGetnetbyname(struct IPerlSock* piPerl, const char *name)
1332{
1333 return win32_getnetbyname((char*)name);
1334}
1335
1336struct netent *
1337PerlSockGetnetent(struct IPerlSock* piPerl)
1338{
1339 return win32_getnetent();
1340}
1341
1342int PerlSockGetpeername(struct IPerlSock* piPerl, SOCKET s, struct sockaddr* name, int* namelen)
1343{
1344 return win32_getpeername(s, name, namelen);
1345}
1346
1347struct protoent*
1348PerlSockGetprotobyname(struct IPerlSock* piPerl, const char* name)
1349{
1350 return win32_getprotobyname(name);
1351}
1352
1353struct protoent*
1354PerlSockGetprotobynumber(struct IPerlSock* piPerl, int number)
1355{
1356 return win32_getprotobynumber(number);
1357}
1358
1359struct protoent*
1360PerlSockGetprotoent(struct IPerlSock* piPerl)
1361{
1362 return win32_getprotoent();
1363}
1364
1365struct servent*
1366PerlSockGetservbyname(struct IPerlSock* piPerl, const char* name, const char* proto)
1367{
1368 return win32_getservbyname(name, proto);
1369}
1370
1371struct servent*
1372PerlSockGetservbyport(struct IPerlSock* piPerl, int port, const char* proto)
1373{
1374 return win32_getservbyport(port, proto);
1375}
1376
1377struct servent*
1378PerlSockGetservent(struct IPerlSock* piPerl)
1379{
1380 return win32_getservent();
1381}
1382
1383int
1384PerlSockGetsockname(struct IPerlSock* piPerl, SOCKET s, struct sockaddr* name, int* namelen)
1385{
1386 return win32_getsockname(s, name, namelen);
1387}
1388
1389int
1390PerlSockGetsockopt(struct IPerlSock* piPerl, SOCKET s, int level, int optname, char* optval, int* optlen)
1391{
1392 return win32_getsockopt(s, level, optname, optval, optlen);
1393}
1394
1395unsigned long
1396PerlSockInetAddr(struct IPerlSock* piPerl, const char* cp)
1397{
1398 return win32_inet_addr(cp);
1399}
1400
1401char*
1402PerlSockInetNtoa(struct IPerlSock* piPerl, struct in_addr in)
1403{
1404 return win32_inet_ntoa(in);
1405}
1406
1407int
1408PerlSockListen(struct IPerlSock* piPerl, SOCKET s, int backlog)
1409{
1410 return win32_listen(s, backlog);
1411}
1412
1413int
1414PerlSockRecv(struct IPerlSock* piPerl, SOCKET s, char* buffer, int len, int flags)
1415{
1416 return win32_recv(s, buffer, len, flags);
1417}
1418
1419int
1420PerlSockRecvfrom(struct IPerlSock* piPerl, SOCKET s, char* buffer, int len, int flags, struct sockaddr* from, int* fromlen)
1421{
1422 return win32_recvfrom(s, buffer, len, flags, from, fromlen);
1423}
1424
1425int
1426PerlSockSelect(struct IPerlSock* piPerl, int nfds, char* readfds, char* writefds, char* exceptfds, const struct timeval* timeout)
1427{
1428 return win32_select(nfds, (Perl_fd_set*)readfds, (Perl_fd_set*)writefds, (Perl_fd_set*)exceptfds, timeout);
1429}
1430
1431int
1432PerlSockSend(struct IPerlSock* piPerl, SOCKET s, const char* buffer, int len, int flags)
1433{
1434 return win32_send(s, buffer, len, flags);
1435}
1436
1437int
1438PerlSockSendto(struct IPerlSock* piPerl, SOCKET s, const char* buffer, int len, int flags, const struct sockaddr* to, int tolen)
1439{
1440 return win32_sendto(s, buffer, len, flags, to, tolen);
1441}
1442
1443void
1444PerlSockSethostent(struct IPerlSock* piPerl, int stayopen)
1445{
1446 win32_sethostent(stayopen);
1447}
1448
1449void
1450PerlSockSetnetent(struct IPerlSock* piPerl, int stayopen)
1451{
1452 win32_setnetent(stayopen);
1453}
1454
1455void
1456PerlSockSetprotoent(struct IPerlSock* piPerl, int stayopen)
1457{
1458 win32_setprotoent(stayopen);
1459}
1460
1461void
1462PerlSockSetservent(struct IPerlSock* piPerl, int stayopen)
1463{
1464 win32_setservent(stayopen);
1465}
1466
1467int
1468PerlSockSetsockopt(struct IPerlSock* piPerl, SOCKET s, int level, int optname, const char* optval, int optlen)
1469{
1470 return win32_setsockopt(s, level, optname, optval, optlen);
1471}
1472
1473int
1474PerlSockShutdown(struct IPerlSock* piPerl, SOCKET s, int how)
1475{
1476 return win32_shutdown(s, how);
1477}
1478
1479SOCKET
1480PerlSockSocket(struct IPerlSock* piPerl, int af, int type, int protocol)
1481{
1482 return win32_socket(af, type, protocol);
1483}
1484
1485int
1486PerlSockSocketpair(struct IPerlSock* piPerl, int domain, int type, int protocol, int* fds)
1487{
e10bb1e9 1488 return Perl_my_socketpair(domain, type, protocol, fds);
7766f137
GS
1489}
1490
1491int
1492PerlSockClosesocket(struct IPerlSock* piPerl, SOCKET s)
1493{
1494 return win32_closesocket(s);
1495}
1496
1497int
1498PerlSockIoctlsocket(struct IPerlSock* piPerl, SOCKET s, long cmd, u_long *argp)
1499{
1500 return win32_ioctlsocket(s, cmd, argp);
1501}
1502
1503struct IPerlSock perlSock =
1504{
1505 PerlSockHtonl,
1506 PerlSockHtons,
1507 PerlSockNtohl,
1508 PerlSockNtohs,
1509 PerlSockAccept,
1510 PerlSockBind,
1511 PerlSockConnect,
1512 PerlSockEndhostent,
1513 PerlSockEndnetent,
1514 PerlSockEndprotoent,
1515 PerlSockEndservent,
1516 PerlSockGethostname,
1517 PerlSockGetpeername,
1518 PerlSockGethostbyaddr,
1519 PerlSockGethostbyname,
1520 PerlSockGethostent,
1521 PerlSockGetnetbyaddr,
1522 PerlSockGetnetbyname,
1523 PerlSockGetnetent,
1524 PerlSockGetprotobyname,
1525 PerlSockGetprotobynumber,
1526 PerlSockGetprotoent,
1527 PerlSockGetservbyname,
1528 PerlSockGetservbyport,
1529 PerlSockGetservent,
1530 PerlSockGetsockname,
1531 PerlSockGetsockopt,
1532 PerlSockInetAddr,
1533 PerlSockInetNtoa,
1534 PerlSockListen,
1535 PerlSockRecv,
1536 PerlSockRecvfrom,
1537 PerlSockSelect,
1538 PerlSockSend,
1539 PerlSockSendto,
1540 PerlSockSethostent,
1541 PerlSockSetnetent,
1542 PerlSockSetprotoent,
1543 PerlSockSetservent,
1544 PerlSockSetsockopt,
1545 PerlSockShutdown,
1546 PerlSockSocket,
1547 PerlSockSocketpair,
1548 PerlSockClosesocket,
1549};
1550
1551
1552/* IPerlProc */
1553
1554#define EXECF_EXEC 1
1555#define EXECF_SPAWN 2
1556
1557void
1558PerlProcAbort(struct IPerlProc* piPerl)
1559{
1560 win32_abort();
1561}
1562
1563char *
1564PerlProcCrypt(struct IPerlProc* piPerl, const char* clear, const char* salt)
1565{
1566 return win32_crypt(clear, salt);
1567}
1568
1569void
1570PerlProcExit(struct IPerlProc* piPerl, int status)
1571{
1572 exit(status);
1573}
1574
1575void
1576PerlProc_Exit(struct IPerlProc* piPerl, int status)
1577{
1578 _exit(status);
1579}
1580
1581int
1582PerlProcExecl(struct IPerlProc* piPerl, const char *cmdname, const char *arg0, const char *arg1, const char *arg2, const char *arg3)
1583{
1584 return execl(cmdname, arg0, arg1, arg2, arg3);
1585}
1586
1587int
1588PerlProcExecv(struct IPerlProc* piPerl, const char *cmdname, const char *const *argv)
1589{
1590 return win32_execvp(cmdname, argv);
1591}
1592
1593int
1594PerlProcExecvp(struct IPerlProc* piPerl, const char *cmdname, const char *const *argv)
1595{
1596 return win32_execvp(cmdname, argv);
1597}
1598
1599uid_t
1600PerlProcGetuid(struct IPerlProc* piPerl)
1601{
1602 return getuid();
1603}
1604
1605uid_t
1606PerlProcGeteuid(struct IPerlProc* piPerl)
1607{
1608 return geteuid();
1609}
1610
1611gid_t
1612PerlProcGetgid(struct IPerlProc* piPerl)
1613{
1614 return getgid();
1615}
1616
1617gid_t
1618PerlProcGetegid(struct IPerlProc* piPerl)
1619{
1620 return getegid();
1621}
1622
1623char *
1624PerlProcGetlogin(struct IPerlProc* piPerl)
1625{
1626 return g_getlogin();
1627}
1628
1629int
1630PerlProcKill(struct IPerlProc* piPerl, int pid, int sig)
1631{
1632 return win32_kill(pid, sig);
1633}
1634
1635int
1636PerlProcKillpg(struct IPerlProc* piPerl, int pid, int sig)
1637{
542cb85f 1638 return win32_kill(pid, -sig);
7766f137
GS
1639}
1640
1641int
1642PerlProcPauseProc(struct IPerlProc* piPerl)
1643{
1644 return win32_sleep((32767L << 16) + 32767);
1645}
1646
1647PerlIO*
1648PerlProcPopen(struct IPerlProc* piPerl, const char *command, const char *mode)
1649{
acfe0abc 1650 dTHX;
7766f137 1651 PERL_FLUSHALL_FOR_CHILD;
adb71456 1652 return win32_popen(command, mode);
7766f137
GS
1653}
1654
8c0134a8
NIS
1655PerlIO*
1656PerlProcPopenList(struct IPerlProc* piPerl, const char *mode, IV narg, SV **args)
1657{
acfe0abc 1658 dTHX;
8c0134a8
NIS
1659 PERL_FLUSHALL_FOR_CHILD;
1660 return win32_popenlist(mode, narg, args);
1661}
1662
7766f137
GS
1663int
1664PerlProcPclose(struct IPerlProc* piPerl, PerlIO *stream)
1665{
adb71456 1666 return win32_pclose(stream);
7766f137
GS
1667}
1668
1669int
1670PerlProcPipe(struct IPerlProc* piPerl, int *phandles)
1671{
1672 return win32_pipe(phandles, 512, O_BINARY);
1673}
1674
1675int
1676PerlProcSetuid(struct IPerlProc* piPerl, uid_t u)
1677{
1678 return setuid(u);
1679}
1680
1681int
1682PerlProcSetgid(struct IPerlProc* piPerl, gid_t g)
1683{
1684 return setgid(g);
1685}
1686
1687int
1688PerlProcSleep(struct IPerlProc* piPerl, unsigned int s)
1689{
1690 return win32_sleep(s);
1691}
1692
1693int
1694PerlProcTimes(struct IPerlProc* piPerl, struct tms *timebuf)
1695{
1696 return win32_times(timebuf);
1697}
1698
1699int
1700PerlProcWait(struct IPerlProc* piPerl, int *status)
1701{
1702 return win32_wait(status);
1703}
1704
1705int
1706PerlProcWaitpid(struct IPerlProc* piPerl, int pid, int *status, int flags)
1707{
1708 return win32_waitpid(pid, status, flags);
1709}
1710
1711Sighandler_t
1712PerlProcSignal(struct IPerlProc* piPerl, int sig, Sighandler_t subcode)
1713{
3fadfdf1 1714 return win32_signal(sig, subcode);
7766f137
GS
1715}
1716
57ab3dfe
GS
1717int
1718PerlProcGetTimeOfDay(struct IPerlProc* piPerl, struct timeval *t, void *z)
1719{
1720 return win32_gettimeofday(t, z);
1721}
1722
8454a2ba 1723#ifdef USE_ITHREADS
c00206c8 1724static THREAD_RET_TYPE
7766f137
GS
1725win32_start_child(LPVOID arg)
1726{
1727 PerlInterpreter *my_perl = (PerlInterpreter*)arg;
1728 GV *tmpgv;
1729 int status;
aeecf691 1730 HWND parent_message_hwnd;
7766f137
GS
1731#ifdef PERL_SYNC_FORK
1732 static long sync_fork_id = 0;
1733 long id = ++sync_fork_id;
1734#endif
1735
1736
ba869deb 1737 PERL_SET_THX(my_perl);
222c300a 1738 win32_checkTLS(my_perl);
7766f137
GS
1739
1740 /* set $$ to pseudo id */
1741#ifdef PERL_SYNC_FORK
1742 w32_pseudo_id = id;
1743#else
1744 w32_pseudo_id = GetCurrentThreadId();
922b1888
GS
1745 if (IsWin95()) {
1746 int pid = (int)w32_pseudo_id;
1747 if (pid < 0)
1748 w32_pseudo_id = -pid;
1749 }
7766f137 1750#endif
e10bb1e9
NIS
1751 if (tmpgv = gv_fetchpv("$", TRUE, SVt_PV)) {
1752 SV *sv = GvSV(tmpgv);
1753 SvREADONLY_off(sv);
1754 sv_setiv(sv, -(IV)w32_pseudo_id);
1755 SvREADONLY_on(sv);
1756 }
6a04c246 1757#ifdef PERL_USES_PL_PIDSTATUS
7766f137 1758 hv_clear(PL_pidstatus);
6a04c246 1759#endif
7766f137 1760
aeecf691
JD
1761 /* create message window and tell parent about it */
1762 parent_message_hwnd = w32_message_hwnd;
1763 w32_message_hwnd = win32_create_message_window();
1764 if (parent_message_hwnd != NULL)
fa58a56f 1765 PostMessage(parent_message_hwnd, WM_USER_MESSAGE, w32_pseudo_id, (LPARAM)w32_message_hwnd);
aeecf691 1766
7766f137
GS
1767 /* push a zero on the stack (we are the child) */
1768 {
39644a26 1769 dSP;
7766f137
GS
1770 dTARGET;
1771 PUSHi(0);
1772 PUTBACK;
1773 }
1774
1775 /* continue from next op */
1776 PL_op = PL_op->op_next;
1777
1778 {
1779 dJMPENV;
f90117a9 1780 volatile int oldscope = 1; /* We are responsible for all scopes */
7766f137
GS
1781
1782restart:
1783 JMPENV_PUSH(status);
1784 switch (status) {
1785 case 0:
1786 CALLRUNOPS(aTHX);
adab9969
JD
1787 /* We may have additional unclosed scopes if fork() was called
1788 * from within a BEGIN block. See perlfork.pod for more details.
1cb985b0
JD
1789 * We cannot clean up these other scopes because they belong to a
1790 * different interpreter, but we also cannot leave PL_scopestack_ix
1791 * dangling because that can trigger an assertion in perl_destruct().
adab9969 1792 */
1cb985b0
JD
1793 if (PL_scopestack_ix > oldscope) {
1794 PL_scopestack[oldscope-1] = PL_scopestack[PL_scopestack_ix-1];
1795 PL_scopestack_ix = oldscope;
1796 }
7766f137
GS
1797 status = 0;
1798 break;
1799 case 2:
1800 while (PL_scopestack_ix > oldscope)
1801 LEAVE;
1802 FREETMPS;
1803 PL_curstash = PL_defstash;
1804 if (PL_endav && !PL_minus_c)
1805 call_list(oldscope, PL_endav);
37038d91 1806 status = STATUS_EXIT;
7766f137
GS
1807 break;
1808 case 3:
1809 if (PL_restartop) {
1810 POPSTACK_TO(PL_mainstack);
1811 PL_op = PL_restartop;
bcabcc50 1812 PL_restartop = (OP*)NULL;
7766f137
GS
1813 goto restart;
1814 }
1815 PerlIO_printf(Perl_error_log, "panic: restartop\n");
1816 FREETMPS;
1817 status = 1;
1818 break;
1819 }
1820 JMPENV_POP;
1821
1822 /* XXX hack to avoid perl_destruct() freeing optree */
222c300a 1823 win32_checkTLS(my_perl);
bcabcc50 1824 PL_main_root = (OP*)NULL;
7766f137
GS
1825 }
1826
222c300a 1827 win32_checkTLS(my_perl);
1c0ca838
GS
1828 /* close the std handles to avoid fd leaks */
1829 {
8fde6460
CS
1830 do_close(PL_stdingv, FALSE);
1831 do_close(gv_fetchpv("STDOUT", TRUE, SVt_PVIO), FALSE); /* PL_stdoutgv - ISAGN */
1832 do_close(PL_stderrgv, FALSE);
1c0ca838
GS
1833 }
1834
7766f137 1835 /* destroy everything (waits for any pseudo-forked children) */
222c300a 1836 win32_checkTLS(my_perl);
7766f137 1837 perl_destruct(my_perl);
222c300a 1838 win32_checkTLS(my_perl);
7766f137
GS
1839 perl_free(my_perl);
1840
1841#ifdef PERL_SYNC_FORK
1842 return id;
1843#else
1844 return (DWORD)status;
1845#endif
1846}
8454a2ba 1847#endif /* USE_ITHREADS */
7766f137
GS
1848
1849int
1850PerlProcFork(struct IPerlProc* piPerl)
1851{
acfe0abc 1852 dTHX;
8454a2ba 1853#ifdef USE_ITHREADS
7766f137
GS
1854 DWORD id;
1855 HANDLE handle;
7a955601
GS
1856 CPerlHost *h;
1857
1858 if (w32_num_pseudo_children >= MAXIMUM_WAIT_OBJECTS) {
1859 errno = EAGAIN;
1860 return -1;
1861 }
1862 h = new CPerlHost(*(CPerlHost*)w32_internal_host);
46a76da7 1863 PerlInterpreter *new_perl = perl_clone_using((PerlInterpreter*)aTHX,
682bcedc 1864 CLONEf_COPY_STACKS,
7766f137
GS
1865 h->m_pHostperlMem,
1866 h->m_pHostperlMemShared,
1867 h->m_pHostperlMemParse,
1868 h->m_pHostperlEnv,
1869 h->m_pHostperlStdIO,
1870 h->m_pHostperlLIO,
1871 h->m_pHostperlDir,
1872 h->m_pHostperlSock,
1873 h->m_pHostperlProc
1874 );
ad4e2db7 1875 new_perl->Isys_intern.internal_host = h;
222c300a 1876 h->host_perl = new_perl;
8454a2ba 1877# ifdef PERL_SYNC_FORK
7766f137 1878 id = win32_start_child((LPVOID)new_perl);
acfe0abc 1879 PERL_SET_THX(aTHX);
8454a2ba 1880# else
aeecf691
JD
1881 if (w32_message_hwnd == INVALID_HANDLE_VALUE)
1882 w32_message_hwnd = win32_create_message_window();
1883 new_perl->Isys_intern.message_hwnd = w32_message_hwnd;
1884 w32_pseudo_child_message_hwnds[w32_num_pseudo_children] =
777c9af2 1885 (w32_message_hwnd == NULL) ? (HWND)NULL : (HWND)INVALID_HANDLE_VALUE;
c00206c8
GS
1886# ifdef USE_RTL_THREAD_API
1887 handle = (HANDLE)_beginthreadex((void*)NULL, 0, win32_start_child,
1888 (void*)new_perl, 0, (unsigned*)&id);
1889# else
7766f137
GS
1890 handle = CreateThread(NULL, 0, win32_start_child,
1891 (LPVOID)new_perl, 0, &id);
c00206c8 1892# endif
acfe0abc 1893 PERL_SET_THX(aTHX); /* XXX perl_clone*() set TLS */
60fa28ff
GS
1894 if (!handle) {
1895 errno = EAGAIN;
1896 return -1;
1897 }
922b1888
GS
1898 if (IsWin95()) {
1899 int pid = (int)id;
1900 if (pid < 0)
1901 id = -pid;
1902 }
7766f137
GS
1903 w32_pseudo_child_handles[w32_num_pseudo_children] = handle;
1904 w32_pseudo_child_pids[w32_num_pseudo_children] = id;
1905 ++w32_num_pseudo_children;
8454a2ba 1906# endif
7766f137 1907 return -(int)id;
8454a2ba
GS
1908#else
1909 Perl_croak(aTHX_ "fork() not implemented!\n");
1910 return -1;
1911#endif /* USE_ITHREADS */
7766f137
GS
1912}
1913
1914int
1915PerlProcGetpid(struct IPerlProc* piPerl)
1916{
1917 return win32_getpid();
1918}
1919
1920void*
1921PerlProcDynaLoader(struct IPerlProc* piPerl, const char* filename)
1922{
1923 return win32_dynaload(filename);
1924}
1925
1926void
1927PerlProcGetOSError(struct IPerlProc* piPerl, SV* sv, DWORD dwErr)
1928{
1929 win32_str_os_error(sv, dwErr);
1930}
1931
7766f137
GS
1932int
1933PerlProcSpawnvp(struct IPerlProc* piPerl, int mode, const char *cmdname, const char *const *argv)
1934{
1935 return win32_spawnvp(mode, cmdname, argv);
1936}
1937
1938int
5f1a76d0
NIS
1939PerlProcLastHost(struct IPerlProc* piPerl)
1940{
acfe0abc 1941 dTHX;
5f1a76d0
NIS
1942 CPerlHost *h = (CPerlHost*)w32_internal_host;
1943 return h->LastHost();
1944}
1945
7766f137
GS
1946struct IPerlProc perlProc =
1947{
1948 PerlProcAbort,
1949 PerlProcCrypt,
1950 PerlProcExit,
1951 PerlProc_Exit,
1952 PerlProcExecl,
1953 PerlProcExecv,
1954 PerlProcExecvp,
1955 PerlProcGetuid,
1956 PerlProcGeteuid,
1957 PerlProcGetgid,
1958 PerlProcGetegid,
1959 PerlProcGetlogin,
1960 PerlProcKill,
1961 PerlProcKillpg,
1962 PerlProcPauseProc,
1963 PerlProcPopen,
1964 PerlProcPclose,
1965 PerlProcPipe,
1966 PerlProcSetuid,
1967 PerlProcSetgid,
1968 PerlProcSleep,
1969 PerlProcTimes,
1970 PerlProcWait,
1971 PerlProcWaitpid,
1972 PerlProcSignal,
1973 PerlProcFork,
1974 PerlProcGetpid,
1975 PerlProcDynaLoader,
1976 PerlProcGetOSError,
7766f137 1977 PerlProcSpawnvp,
8c0134a8 1978 PerlProcLastHost,
57ab3dfe
GS
1979 PerlProcPopenList,
1980 PerlProcGetTimeOfDay
7766f137
GS
1981};
1982
1983
1984/*
1985 * CPerlHost
1986 */
1987
1988CPerlHost::CPerlHost(void)
1989{
5f1a76d0
NIS
1990 /* Construct a host from scratch */
1991 InterlockedIncrement(&num_hosts);
7766f137
GS
1992 m_pvDir = new VDir();
1993 m_pVMem = new VMem();
1994 m_pVMemShared = new VMem();
1995 m_pVMemParse = new VMem();
1996
1997 m_pvDir->Init(NULL, m_pVMem);
1998
1999 m_dwEnvCount = 0;
2000 m_lppEnvList = NULL;
85fdc8b6 2001 m_bTopLevel = TRUE;
7766f137
GS
2002
2003 CopyMemory(&m_hostperlMem, &perlMem, sizeof(perlMem));
2004 CopyMemory(&m_hostperlMemShared, &perlMemShared, sizeof(perlMemShared));
2005 CopyMemory(&m_hostperlMemParse, &perlMemParse, sizeof(perlMemParse));
2006 CopyMemory(&m_hostperlEnv, &perlEnv, sizeof(perlEnv));
2007 CopyMemory(&m_hostperlStdIO, &perlStdIO, sizeof(perlStdIO));
2008 CopyMemory(&m_hostperlLIO, &perlLIO, sizeof(perlLIO));
2009 CopyMemory(&m_hostperlDir, &perlDir, sizeof(perlDir));
2010 CopyMemory(&m_hostperlSock, &perlSock, sizeof(perlSock));
2011 CopyMemory(&m_hostperlProc, &perlProc, sizeof(perlProc));
2012
2013 m_pHostperlMem = &m_hostperlMem;
2014 m_pHostperlMemShared = &m_hostperlMemShared;
2015 m_pHostperlMemParse = &m_hostperlMemParse;
2016 m_pHostperlEnv = &m_hostperlEnv;
2017 m_pHostperlStdIO = &m_hostperlStdIO;
2018 m_pHostperlLIO = &m_hostperlLIO;
2019 m_pHostperlDir = &m_hostperlDir;
2020 m_pHostperlSock = &m_hostperlSock;
2021 m_pHostperlProc = &m_hostperlProc;
2022}
2023
2024#define SETUPEXCHANGE(xptr, iptr, table) \
2025 STMT_START { \
2026 if (xptr) { \
2027 iptr = *xptr; \
2028 *xptr = &table; \
2029 } \
2030 else { \
2031 iptr = &table; \
2032 } \
2033 } STMT_END
2034
2035CPerlHost::CPerlHost(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared,
2036 struct IPerlMem** ppMemParse, struct IPerlEnv** ppEnv,
2037 struct IPerlStdIO** ppStdIO, struct IPerlLIO** ppLIO,
2038 struct IPerlDir** ppDir, struct IPerlSock** ppSock,
2039 struct IPerlProc** ppProc)
2040{
5f1a76d0 2041 InterlockedIncrement(&num_hosts);
f7aeb604 2042 m_pvDir = new VDir(0);
7766f137
GS
2043 m_pVMem = new VMem();
2044 m_pVMemShared = new VMem();
2045 m_pVMemParse = new VMem();
2046
2047 m_pvDir->Init(NULL, m_pVMem);
2048
2049 m_dwEnvCount = 0;
2050 m_lppEnvList = NULL;
85fdc8b6 2051 m_bTopLevel = FALSE;
7766f137
GS
2052
2053 CopyMemory(&m_hostperlMem, &perlMem, sizeof(perlMem));
2054 CopyMemory(&m_hostperlMemShared, &perlMemShared, sizeof(perlMemShared));
2055 CopyMemory(&m_hostperlMemParse, &perlMemParse, sizeof(perlMemParse));
2056 CopyMemory(&m_hostperlEnv, &perlEnv, sizeof(perlEnv));
2057 CopyMemory(&m_hostperlStdIO, &perlStdIO, sizeof(perlStdIO));
2058 CopyMemory(&m_hostperlLIO, &perlLIO, sizeof(perlLIO));
2059 CopyMemory(&m_hostperlDir, &perlDir, sizeof(perlDir));
2060 CopyMemory(&m_hostperlSock, &perlSock, sizeof(perlSock));
2061 CopyMemory(&m_hostperlProc, &perlProc, sizeof(perlProc));
2062
2063 SETUPEXCHANGE(ppMem, m_pHostperlMem, m_hostperlMem);
2064 SETUPEXCHANGE(ppMemShared, m_pHostperlMemShared, m_hostperlMemShared);
2065 SETUPEXCHANGE(ppMemParse, m_pHostperlMemParse, m_hostperlMemParse);
2066 SETUPEXCHANGE(ppEnv, m_pHostperlEnv, m_hostperlEnv);
2067 SETUPEXCHANGE(ppStdIO, m_pHostperlStdIO, m_hostperlStdIO);
2068 SETUPEXCHANGE(ppLIO, m_pHostperlLIO, m_hostperlLIO);
2069 SETUPEXCHANGE(ppDir, m_pHostperlDir, m_hostperlDir);
2070 SETUPEXCHANGE(ppSock, m_pHostperlSock, m_hostperlSock);
2071 SETUPEXCHANGE(ppProc, m_pHostperlProc, m_hostperlProc);
2072}
2073#undef SETUPEXCHANGE
2074
2075CPerlHost::CPerlHost(CPerlHost& host)
2076{
5f1a76d0
NIS
2077 /* Construct a host from another host */
2078 InterlockedIncrement(&num_hosts);
7766f137
GS
2079 m_pVMem = new VMem();
2080 m_pVMemShared = host.GetMemShared();
2081 m_pVMemParse = host.GetMemParse();
2082
2083 /* duplicate directory info */
f7aeb604 2084 m_pvDir = new VDir(0);
7766f137
GS
2085 m_pvDir->Init(host.GetDir(), m_pVMem);
2086
2087 CopyMemory(&m_hostperlMem, &perlMem, sizeof(perlMem));
2088 CopyMemory(&m_hostperlMemShared, &perlMemShared, sizeof(perlMemShared));
2089 CopyMemory(&m_hostperlMemParse, &perlMemParse, sizeof(perlMemParse));
2090 CopyMemory(&m_hostperlEnv, &perlEnv, sizeof(perlEnv));
2091 CopyMemory(&m_hostperlStdIO, &perlStdIO, sizeof(perlStdIO));
2092 CopyMemory(&m_hostperlLIO, &perlLIO, sizeof(perlLIO));
2093 CopyMemory(&m_hostperlDir, &perlDir, sizeof(perlDir));
2094 CopyMemory(&m_hostperlSock, &perlSock, sizeof(perlSock));
2095 CopyMemory(&m_hostperlProc, &perlProc, sizeof(perlProc));
ad4e2db7
GS
2096 m_pHostperlMem = &m_hostperlMem;
2097 m_pHostperlMemShared = &m_hostperlMemShared;
2098 m_pHostperlMemParse = &m_hostperlMemParse;
2099 m_pHostperlEnv = &m_hostperlEnv;
2100 m_pHostperlStdIO = &m_hostperlStdIO;
2101 m_pHostperlLIO = &m_hostperlLIO;
2102 m_pHostperlDir = &m_hostperlDir;
2103 m_pHostperlSock = &m_hostperlSock;
2104 m_pHostperlProc = &m_hostperlProc;
7766f137
GS
2105
2106 m_dwEnvCount = 0;
2107 m_lppEnvList = NULL;
85fdc8b6 2108 m_bTopLevel = FALSE;
7766f137
GS
2109
2110 /* duplicate environment info */
2111 LPSTR lpPtr;
2112 DWORD dwIndex = 0;
2113 while(lpPtr = host.GetIndex(dwIndex))
2114 Add(lpPtr);
2115}
2116
2117CPerlHost::~CPerlHost(void)
2118{
2b93cd4d 2119 Reset();
5f1a76d0 2120 InterlockedDecrement(&num_hosts);
7766f137
GS
2121 delete m_pvDir;
2122 m_pVMemParse->Release();
2123 m_pVMemShared->Release();
2124 m_pVMem->Release();
2125}
2126
2127LPSTR
2128CPerlHost::Find(LPCSTR lpStr)
2129{
2130 LPSTR lpPtr;
2131 LPSTR* lppPtr = Lookup(lpStr);
2132 if(lppPtr != NULL) {
2133 for(lpPtr = *lppPtr; *lpPtr != '\0' && *lpPtr != '='; ++lpPtr)
2134 ;
2135
2136 if(*lpPtr == '=')
2137 ++lpPtr;
2138
2139 return lpPtr;
2140 }
2141 return NULL;
2142}
2143
2144int
2145lookup(const void *arg1, const void *arg2)
52cbf511 2146{ // Compare strings
7766f137
GS
2147 char*ptr1, *ptr2;
2148 char c1,c2;
2149
2150 ptr1 = *(char**)arg1;
2151 ptr2 = *(char**)arg2;
2152 for(;;) {
2153 c1 = *ptr1++;
2154 c2 = *ptr2++;
2155 if(c1 == '\0' || c1 == '=') {
2156 if(c2 == '\0' || c2 == '=')
2157 break;
2158
52cbf511 2159 return -1; // string 1 < string 2
7766f137
GS
2160 }
2161 else if(c2 == '\0' || c2 == '=')
52cbf511 2162 return 1; // string 1 > string 2
7766f137
GS
2163 else if(c1 != c2) {
2164 c1 = toupper(c1);
2165 c2 = toupper(c2);
2166 if(c1 != c2) {
2167 if(c1 < c2)
52cbf511 2168 return -1; // string 1 < string 2
7766f137 2169
52cbf511 2170 return 1; // string 1 > string 2
7766f137
GS
2171 }
2172 }
2173 }
2174 return 0;
2175}
2176
2177LPSTR*
2178CPerlHost::Lookup(LPCSTR lpStr)
2179{
7bd379e8
YO
2180#ifdef UNDER_CE
2181 if (!m_lppEnvList || !m_dwEnvCount)
2182 return NULL;
2183#endif
2b93cd4d
GS
2184 if (!lpStr)
2185 return NULL;
7766f137
GS
2186 return (LPSTR*)bsearch(&lpStr, m_lppEnvList, m_dwEnvCount, sizeof(LPSTR), lookup);
2187}
2188
2189int
2190compare(const void *arg1, const void *arg2)
52cbf511 2191{ // Compare strings
7766f137
GS
2192 char*ptr1, *ptr2;
2193 char c1,c2;
2194
2195 ptr1 = *(char**)arg1;
2196 ptr2 = *(char**)arg2;
2197 for(;;) {
2198 c1 = *ptr1++;
2199 c2 = *ptr2++;
2200 if(c1 == '\0' || c1 == '=') {
2201 if(c1 == c2)
2202 break;
2203
52cbf511 2204 return -1; // string 1 < string 2
7766f137
GS
2205 }
2206 else if(c2 == '\0' || c2 == '=')
52cbf511 2207 return 1; // string 1 > string 2
7766f137
GS
2208 else if(c1 != c2) {
2209 c1 = toupper(c1);
2210 c2 = toupper(c2);
2211 if(c1 != c2) {
2212 if(c1 < c2)
52cbf511 2213 return -1; // string 1 < string 2
3fadfdf1 2214
52cbf511 2215 return 1; // string 1 > string 2
7766f137
GS
2216 }
2217 }
2218 }
2219 return 0;
2220}
2221
2222void
2223CPerlHost::Add(LPCSTR lpStr)
2224{
acfe0abc 2225 dTHX;
7766f137
GS
2226 char szBuffer[1024];
2227 LPSTR *lpPtr;
2228 int index, length = strlen(lpStr)+1;
2229
2230 for(index = 0; lpStr[index] != '\0' && lpStr[index] != '='; ++index)
2231 szBuffer[index] = lpStr[index];
2232
2233 szBuffer[index] = '\0';
2234
52cbf511 2235 // replacing ?
7766f137 2236 lpPtr = Lookup(szBuffer);
2b93cd4d
GS
2237 if (lpPtr != NULL) {
2238 // must allocate things via host memory allocation functions
2239 // rather than perl's Renew() et al, as the perl interpreter
2240 // may either not be initialized enough when we allocate these,
2241 // or may already be dead when we go to free these
2242 *lpPtr = (char*)Realloc(*lpPtr, length * sizeof(char));
7766f137
GS
2243 strcpy(*lpPtr, lpStr);
2244 }
2245 else {
2b93cd4d
GS
2246 m_lppEnvList = (LPSTR*)Realloc(m_lppEnvList, (m_dwEnvCount+1) * sizeof(LPSTR));
2247 if (m_lppEnvList) {
2248 m_lppEnvList[m_dwEnvCount] = (char*)Malloc(length * sizeof(char));
2249 if (m_lppEnvList[m_dwEnvCount] != NULL) {
2250 strcpy(m_lppEnvList[m_dwEnvCount], lpStr);
2251 ++m_dwEnvCount;
2252 qsort(m_lppEnvList, m_dwEnvCount, sizeof(LPSTR), compare);
2253 }
7766f137 2254 }
7766f137
GS
2255 }
2256}
2257
2258DWORD
2259CPerlHost::CalculateEnvironmentSpace(void)
2260{
2261 DWORD index;
2262 DWORD dwSize = 0;
2263 for(index = 0; index < m_dwEnvCount; ++index)
2264 dwSize += strlen(m_lppEnvList[index]) + 1;
2265
2266 return dwSize;
2267}
2268
2269void
2270CPerlHost::FreeLocalEnvironmentStrings(LPSTR lpStr)
2271{
acfe0abc 2272 dTHX;
7766f137
GS
2273 Safefree(lpStr);
2274}
2275
2276char*
2277CPerlHost::GetChildDir(void)
2278{
acfe0abc 2279 dTHX;
7766f137 2280 char* ptr;
d684b162
JD
2281 size_t length;
2282
aa2b96ec
JD
2283 Newx(ptr, MAX_PATH+1, char);
2284 m_pvDir->GetCurrentDirectoryA(MAX_PATH+1, ptr);
d684b162
JD
2285 length = strlen(ptr);
2286 if (length > 3) {
2287 if ((ptr[length-1] == '\\') || (ptr[length-1] == '/'))
2288 ptr[length-1] = 0;
7766f137
GS
2289 }
2290 return ptr;
2291}
2292
2293void
2294CPerlHost::FreeChildDir(char* pStr)
2295{
acfe0abc 2296 dTHX;
7766f137
GS
2297 Safefree(pStr);
2298}
2299
2300LPSTR
2301CPerlHost::CreateLocalEnvironmentStrings(VDir &vDir)
2302{
acfe0abc 2303 dTHX;
7766f137
GS
2304 LPSTR lpStr, lpPtr, lpEnvPtr, lpTmp, lpLocalEnv, lpAllocPtr;
2305 DWORD dwSize, dwEnvIndex;
2306 int nLength, compVal;
2307
52cbf511 2308 // get the process environment strings
7766f137
GS
2309 lpAllocPtr = lpTmp = (LPSTR)GetEnvironmentStrings();
2310
52cbf511 2311 // step over current directory stuff
7766f137
GS
2312 while(*lpTmp == '=')
2313 lpTmp += strlen(lpTmp) + 1;
2314
52cbf511 2315 // save the start of the environment strings
7766f137
GS
2316 lpEnvPtr = lpTmp;
2317 for(dwSize = 1; *lpTmp != '\0'; lpTmp += strlen(lpTmp) + 1) {
52cbf511 2318 // calculate the size of the environment strings
7766f137
GS
2319 dwSize += strlen(lpTmp) + 1;
2320 }
2321
52cbf511 2322 // add the size of current directories
7766f137
GS
2323 dwSize += vDir.CalculateEnvironmentSpace();
2324
52cbf511 2325 // add the additional space used by changes made to the environment
7766f137
GS
2326 dwSize += CalculateEnvironmentSpace();
2327
a02a5408 2328 Newx(lpStr, dwSize, char);
7766f137
GS
2329 lpPtr = lpStr;
2330 if(lpStr != NULL) {
52cbf511 2331 // build the local environment
7766f137
GS
2332 lpStr = vDir.BuildEnvironmentSpace(lpStr);
2333
2334 dwEnvIndex = 0;
2335 lpLocalEnv = GetIndex(dwEnvIndex);
2336 while(*lpEnvPtr != '\0') {
ec00bdd8 2337 if(!lpLocalEnv) {
52cbf511
JH
2338 // all environment overrides have been added
2339 // so copy string into place
7766f137
GS
2340 strcpy(lpStr, lpEnvPtr);
2341 nLength = strlen(lpEnvPtr) + 1;
2342 lpStr += nLength;
2343 lpEnvPtr += nLength;
2344 }
3fadfdf1 2345 else {
52cbf511 2346 // determine which string to copy next
7766f137
GS
2347 compVal = compare(&lpEnvPtr, &lpLocalEnv);
2348 if(compVal < 0) {
2349 strcpy(lpStr, lpEnvPtr);
2350 nLength = strlen(lpEnvPtr) + 1;
2351 lpStr += nLength;
2352 lpEnvPtr += nLength;
2353 }
2354 else {
2355 char *ptr = strchr(lpLocalEnv, '=');
2356 if(ptr && ptr[1]) {
2357 strcpy(lpStr, lpLocalEnv);
2358 lpStr += strlen(lpLocalEnv) + 1;
2359 }
2360 lpLocalEnv = GetIndex(dwEnvIndex);
2361 if(compVal == 0) {
52cbf511 2362 // this string was replaced
7766f137
GS
2363 lpEnvPtr += strlen(lpEnvPtr) + 1;
2364 }
2365 }
2366 }
2367 }
2368
ec00bdd8 2369 while(lpLocalEnv) {
52cbf511
JH
2370 // still have environment overrides to add
2371 // so copy the strings into place if not an override
1784c7b8
JH
2372 char *ptr = strchr(lpLocalEnv, '=');
2373 if(ptr && ptr[1]) {
2374 strcpy(lpStr, lpLocalEnv);
2375 lpStr += strlen(lpLocalEnv) + 1;
2376 }
ec00bdd8
GS
2377 lpLocalEnv = GetIndex(dwEnvIndex);
2378 }
2379
52cbf511 2380 // add final NULL
7766f137
GS
2381 *lpStr = '\0';
2382 }
2383
52cbf511 2384 // release the process environment strings
7766f137
GS
2385 FreeEnvironmentStrings(lpAllocPtr);
2386
2387 return lpPtr;
2388}
2389
2390void
2391CPerlHost::Reset(void)
2392{
acfe0abc 2393 dTHX;
7766f137
GS
2394 if(m_lppEnvList != NULL) {
2395 for(DWORD index = 0; index < m_dwEnvCount; ++index) {
2b93cd4d 2396 Free(m_lppEnvList[index]);
7766f137
GS
2397 m_lppEnvList[index] = NULL;
2398 }
2399 }
2400 m_dwEnvCount = 0;
2b93cd4d
GS
2401 Free(m_lppEnvList);
2402 m_lppEnvList = NULL;
7766f137
GS
2403}
2404
2405void
2406CPerlHost::Clearenv(void)
2407{
acfe0abc 2408 dTHX;
7766f137
GS
2409 char ch;
2410 LPSTR lpPtr, lpStr, lpEnvPtr;
2fb9ab56 2411 if (m_lppEnvList != NULL) {
7766f137
GS
2412 /* set every entry to an empty string */
2413 for(DWORD index = 0; index < m_dwEnvCount; ++index) {
2414 char* ptr = strchr(m_lppEnvList[index], '=');
2415 if(ptr) {
2416 *++ptr = 0;
2417 }
2418 }
2419 }
2420
2421 /* get the process environment strings */
2422 lpStr = lpEnvPtr = (LPSTR)GetEnvironmentStrings();
2423
2424 /* step over current directory stuff */
2425 while(*lpStr == '=')
2426 lpStr += strlen(lpStr) + 1;
2427
2428 while(*lpStr) {
2429 lpPtr = strchr(lpStr, '=');
2430 if(lpPtr) {
2431 ch = *++lpPtr;
2432 *lpPtr = 0;
2433 Add(lpStr);
85fdc8b6 2434 if (m_bTopLevel)
2fb9ab56 2435 (void)win32_putenv(lpStr);
7766f137
GS
2436 *lpPtr = ch;
2437 }
2438 lpStr += strlen(lpStr) + 1;
2439 }
2440
2441 FreeEnvironmentStrings(lpEnvPtr);
2442}
2443
2444
2445char*
2446CPerlHost::Getenv(const char *varname)
2447{
acfe0abc 2448 dTHX;
85fdc8b6 2449 if (!m_bTopLevel) {
2fb9ab56 2450 char *pEnv = Find(varname);
4354e59a 2451 if (pEnv && *pEnv)
2fb9ab56 2452 return pEnv;
7766f137 2453 }
2fb9ab56 2454 return win32_getenv(varname);
7766f137
GS
2455}
2456
2457int
2458CPerlHost::Putenv(const char *envstring)
2459{
acfe0abc 2460 dTHX;
7766f137 2461 Add(envstring);
85fdc8b6 2462 if (m_bTopLevel)
2fb9ab56
NIS
2463 return win32_putenv(envstring);
2464
7766f137
GS
2465 return 0;
2466}
2467
2468int
2469CPerlHost::Chdir(const char *dirname)
2470{
acfe0abc 2471 dTHX;
7766f137 2472 int ret;
9ec3348a
JH
2473 if (!dirname) {
2474 errno = ENOENT;
2475 return -1;
2476 }
8c56068e 2477 ret = m_pvDir->SetCurrentDirectoryA((char*)dirname);
7766f137
GS
2478 if(ret < 0) {
2479 errno = ENOENT;
2480 }
2481 return ret;
2482}
2483
2484#endif /* ___PerlHost_H___ */