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