forked from schacon/perl
-
Notifications
You must be signed in to change notification settings - Fork 1
/
Copy pathos2.c
5471 lines (4920 loc) · 143 KB
/
os2.c
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
#define INCL_DOS
#define INCL_NOPM
#define INCL_DOSFILEMGR
#define INCL_DOSMEMMGR
#define INCL_DOSERRORS
#define INCL_WINERRORS
#define INCL_WINSYS
/* These 3 are needed for compile if os2.h includes os2tk.h, not os2emx.h */
#define INCL_DOSPROCESS
#define SPU_DISABLESUPPRESSION 0
#define SPU_ENABLESUPPRESSION 1
#include <os2.h>
#include "dlfcn.h"
#include <emx/syscalls.h>
#include <sys/emxload.h>
#include <sys/uflags.h>
/*
* Various Unix compatibility functions for OS/2
*/
#include <stdio.h>
#include <errno.h>
#include <limits.h>
#include <process.h>
#include <fcntl.h>
#include <pwd.h>
#include <grp.h>
#define PERLIO_NOT_STDIO 0
#include "EXTERN.h"
#include "perl.h"
enum module_name_how { mod_name_handle, mod_name_shortname, mod_name_full,
mod_name_C_function = 0x100, mod_name_HMODULE = 0x200};
/* Find module name to which *this* subroutine is compiled */
#define module_name(how) module_name_at(&module_name_at, how)
static SV* module_name_at(void *pp, enum module_name_how how);
void
croak_with_os2error(char *s)
{
Perl_croak_nocontext("%s: %s", s, os2error(Perl_rc));
}
struct PMWIN_entries_t PMWIN_entries;
/*****************************************************************************/
/* 2.1 would not resolve symbols on demand, and has no ExtLIBPATH. */
struct dll_handle_t {
const char *modname;
HMODULE handle;
int requires_pm;
};
static struct dll_handle_t dll_handles[] = {
{"doscalls", 0, 0},
{"tcp32dll", 0, 0},
{"pmwin", 0, 1},
{"rexx", 0, 0},
{"rexxapi", 0, 0},
{"sesmgr", 0, 0},
{"pmshapi", 0, 1},
{"pmwp", 0, 1},
{"pmgpi", 0, 1},
{NULL, 0},
};
enum dll_handle_e {
dll_handle_doscalls,
dll_handle_tcp32dll,
dll_handle_pmwin,
dll_handle_rexx,
dll_handle_rexxapi,
dll_handle_sesmgr,
dll_handle_pmshapi,
dll_handle_pmwp,
dll_handle_pmgpi,
dll_handle_LAST,
};
#define doscalls_handle (dll_handles[dll_handle_doscalls])
#define tcp_handle (dll_handles[dll_handle_tcp32dll])
#define pmwin_handle (dll_handles[dll_handle_pmwin])
#define rexx_handle (dll_handles[dll_handle_rexx])
#define rexxapi_handle (dll_handles[dll_handle_rexxapi])
#define sesmgr_handle (dll_handles[dll_handle_sesmgr])
#define pmshapi_handle (dll_handles[dll_handle_pmshapi])
#define pmwp_handle (dll_handles[dll_handle_pmwp])
#define pmgpi_handle (dll_handles[dll_handle_pmgpi])
/* The following local-scope data is not yet included:
fargs.140 // const => OK
ino.165 // locked - and the access is almost cosmetic
layout_table.260 // startup only, locked
osv_res.257 // startup only, locked
old_esp.254 // startup only, locked
priors // const ==> OK
use_my_flock.283 // locked
emx_init_done.268 // locked
dll_handles // locked
hmtx_emx_init.267 // THIS is the lock for startup
perlos2_state_mutex // THIS is the lock for all the rest
BAD:
perlos2_state // see below
*/
/* The following global-scope data is not yet included:
OS2_Perl_data
pthreads_states // const now?
start_thread_mutex
thread_join_count // protected
thread_join_data // protected
tmppath
pDosVerifyPidTid
Perl_OS2_init3() - should it be protected?
*/
OS2_Perl_data_t OS2_Perl_data;
static struct perlos2_state_t {
int po2__my_pwent; /* = -1; */
int po2_DOS_harderr_state; /* = -1; */
signed char po2_DOS_suppression_state; /* = -1; */
PFN po2_ExtFCN[ORD_NENTRIES]; /* Labeled by ord ORD_*. */
/* struct PMWIN_entries_t po2_PMWIN_entries; */
int po2_emx_wasnt_initialized;
char po2_fname[9];
int po2_rmq_cnt;
int po2_grent_cnt;
char *po2_newp;
char *po2_oldp;
int po2_newl;
int po2_oldl;
int po2_notfound;
char po2_mangle_ret[STATIC_FILE_LENGTH+1];
ULONG po2_os2_dll_fake;
ULONG po2_os2_mytype;
ULONG po2_os2_mytype_ini;
int po2_pidtid_lookup;
struct passwd po2_pw;
int po2_pwent_cnt;
char po2_pthreads_state_buf[80];
char po2_os2error_buf[300];
/* There is no big sense to make it thread-specific, since signals
are delivered to thread 1 only. XXXX Maybe make it into an array? */
int po2_spawn_pid;
int po2_spawn_killed;
jmp_buf po2_at_exit_buf;
int po2_longjmp_at_exit;
int po2_emx_runtime_init; /* If 1, we need to manually init it */
int po2_emx_exception_init; /* If 1, we need to manually set it */
int po2_emx_runtime_secondary;
char* (*po2_perllib_mangle_installed)(char *s, unsigned int l);
char* po2_perl_sh_installed;
PGINFOSEG po2_gTable;
PLINFOSEG po2_lTable;
} perlos2_state = {
-1, /* po2__my_pwent */
-1, /* po2_DOS_harderr_state */
-1, /* po2_DOS_suppression_state */
};
#define Perl_po2() (&perlos2_state)
#define ExtFCN (Perl_po2()->po2_ExtFCN)
/* #define PMWIN_entries (Perl_po2()->po2_PMWIN_entries) */
#define emx_wasnt_initialized (Perl_po2()->po2_emx_wasnt_initialized)
#define fname (Perl_po2()->po2_fname)
#define rmq_cnt (Perl_po2()->po2_rmq_cnt)
#define grent_cnt (Perl_po2()->po2_grent_cnt)
#define newp (Perl_po2()->po2_newp)
#define oldp (Perl_po2()->po2_oldp)
#define newl (Perl_po2()->po2_newl)
#define oldl (Perl_po2()->po2_oldl)
#define notfound (Perl_po2()->po2_notfound)
#define mangle_ret (Perl_po2()->po2_mangle_ret)
#define os2_dll_fake (Perl_po2()->po2_os2_dll_fake)
#define os2_mytype (Perl_po2()->po2_os2_mytype)
#define os2_mytype_ini (Perl_po2()->po2_os2_mytype_ini)
#define pidtid_lookup (Perl_po2()->po2_pidtid_lookup)
#define pw (Perl_po2()->po2_pw)
#define pwent_cnt (Perl_po2()->po2_pwent_cnt)
#define _my_pwent (Perl_po2()->po2__my_pwent)
#define pthreads_state_buf (Perl_po2()->po2_pthreads_state_buf)
#define os2error_buf (Perl_po2()->po2_os2error_buf)
/* There is no big sense to make it thread-specific, since signals
are delivered to thread 1 only. XXXX Maybe make it into an array? */
#define spawn_pid (Perl_po2()->po2_spawn_pid)
#define spawn_killed (Perl_po2()->po2_spawn_killed)
#define DOS_harderr_state (Perl_po2()->po2_DOS_harderr_state)
#define DOS_suppression_state (Perl_po2()->po2_DOS_suppression_state)
#define at_exit_buf (Perl_po2()->po2_at_exit_buf)
#define longjmp_at_exit (Perl_po2()->po2_longjmp_at_exit)
#define emx_runtime_init (Perl_po2()->po2_emx_runtime_init)
#define emx_exception_init (Perl_po2()->po2_emx_exception_init)
#define emx_runtime_secondary (Perl_po2()->po2_emx_runtime_secondary)
#define perllib_mangle_installed (Perl_po2()->po2_perllib_mangle_installed)
#define perl_sh_installed (Perl_po2()->po2_perl_sh_installed)
#define gTable (Perl_po2()->po2_gTable)
#define lTable (Perl_po2()->po2_lTable)
const Perl_PFN * const pExtFCN = (Perl_po2()->po2_ExtFCN);
#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
typedef void (*emx_startroutine)(void *);
typedef void* (*pthreads_startroutine)(void *);
enum pthreads_state {
pthreads_st_none = 0,
pthreads_st_run,
pthreads_st_exited,
pthreads_st_detached,
pthreads_st_waited,
pthreads_st_norun,
pthreads_st_exited_waited,
};
const char * const pthreads_states[] = {
"uninit",
"running",
"exited",
"detached",
"waited for",
"could not start",
"exited, then waited on",
};
enum pthread_exists { pthread_not_existant = -0xff };
static const char*
pthreads_state_string(enum pthreads_state state)
{
if (state < 0 || state >= sizeof(pthreads_states)/sizeof(*pthreads_states)) {
snprintf(pthreads_state_buf, sizeof(pthreads_state_buf),
"unknown thread state %d", (int)state);
return pthreads_state_buf;
}
return pthreads_states[state];
}
typedef struct {
void *status;
perl_cond cond;
enum pthreads_state state;
} thread_join_t;
thread_join_t *thread_join_data;
int thread_join_count;
perl_mutex start_thread_mutex;
static perl_mutex perlos2_state_mutex;
int
pthread_join(perl_os_thread tid, void **status)
{
MUTEX_LOCK(&start_thread_mutex);
if (tid < 1 || tid >= thread_join_count) {
MUTEX_UNLOCK(&start_thread_mutex);
if (tid != pthread_not_existant)
Perl_croak_nocontext("panic: join with a thread with strange ordinal %d", (int)tid);
Perl_warn_nocontext("panic: join with a thread which could not start");
*status = 0;
return 0;
}
switch (thread_join_data[tid].state) {
case pthreads_st_exited:
thread_join_data[tid].state = pthreads_st_exited_waited;
*status = thread_join_data[tid].status;
MUTEX_UNLOCK(&start_thread_mutex);
COND_SIGNAL(&thread_join_data[tid].cond);
break;
case pthreads_st_waited:
MUTEX_UNLOCK(&start_thread_mutex);
Perl_croak_nocontext("join with a thread with a waiter");
break;
case pthreads_st_norun:
{
int state = (int)thread_join_data[tid].status;
thread_join_data[tid].state = pthreads_st_none;
MUTEX_UNLOCK(&start_thread_mutex);
Perl_croak_nocontext("panic: join with a thread which could not run"
" due to attempt of tid reuse (state='%s')",
pthreads_state_string(state));
break;
}
case pthreads_st_run:
{
perl_cond cond;
thread_join_data[tid].state = pthreads_st_waited;
thread_join_data[tid].status = (void *)status;
COND_INIT(&thread_join_data[tid].cond);
cond = thread_join_data[tid].cond;
COND_WAIT(&thread_join_data[tid].cond, &start_thread_mutex);
COND_DESTROY(&cond);
MUTEX_UNLOCK(&start_thread_mutex);
break;
}
default:
MUTEX_UNLOCK(&start_thread_mutex);
Perl_croak_nocontext("panic: join with thread in unknown thread state: '%s'",
pthreads_state_string(thread_join_data[tid].state));
break;
}
return 0;
}
typedef struct {
pthreads_startroutine sub;
void *arg;
void *ctx;
} pthr_startit;
/* The lock is used:
a) Since we temporarily usurp the caller interp, so malloc() may
use it to decide on debugging the call;
b) Since *args is on the caller's stack.
*/
void
pthread_startit(void *arg1)
{
/* Thread is already started, we need to transfer control only */
pthr_startit args = *(pthr_startit *)arg1;
int tid = pthread_self();
void *rc;
int state;
if (tid <= 1) {
/* Can't croak, the setjmp() is not in scope... */
char buf[80];
snprintf(buf, sizeof(buf),
"panic: thread with strange ordinal %d created\n\r", tid);
write(2,buf,strlen(buf));
MUTEX_UNLOCK(&start_thread_mutex);
return;
}
/* Until args.sub resets it, makes debugging Perl_malloc() work: */
PERL_SET_CONTEXT(0);
if (tid >= thread_join_count) {
int oc = thread_join_count;
thread_join_count = tid + 5 + tid/5;
if (thread_join_data) {
Renew(thread_join_data, thread_join_count, thread_join_t);
Zero(thread_join_data + oc, thread_join_count - oc, thread_join_t);
} else {
Newxz(thread_join_data, thread_join_count, thread_join_t);
}
}
if (thread_join_data[tid].state != pthreads_st_none) {
/* Can't croak, the setjmp() is not in scope... */
char buf[80];
snprintf(buf, sizeof(buf),
"panic: attempt to reuse thread id %d (state='%s')\n\r",
tid, pthreads_state_string(thread_join_data[tid].state));
write(2,buf,strlen(buf));
thread_join_data[tid].status = (void*)thread_join_data[tid].state;
thread_join_data[tid].state = pthreads_st_norun;
MUTEX_UNLOCK(&start_thread_mutex);
return;
}
thread_join_data[tid].state = pthreads_st_run;
/* Now that we copied/updated the guys, we may release the caller... */
MUTEX_UNLOCK(&start_thread_mutex);
rc = (*args.sub)(args.arg);
MUTEX_LOCK(&start_thread_mutex);
switch (thread_join_data[tid].state) {
case pthreads_st_waited:
COND_SIGNAL(&thread_join_data[tid].cond);
thread_join_data[tid].state = pthreads_st_none;
*((void**)thread_join_data[tid].status) = rc;
break;
case pthreads_st_detached:
thread_join_data[tid].state = pthreads_st_none;
break;
case pthreads_st_run:
/* Somebody can wait on us; cannot exit, since OS can reuse the tid
and our waiter will get somebody else's status. */
thread_join_data[tid].state = pthreads_st_exited;
thread_join_data[tid].status = rc;
COND_INIT(&thread_join_data[tid].cond);
COND_WAIT(&thread_join_data[tid].cond, &start_thread_mutex);
COND_DESTROY(&thread_join_data[tid].cond);
thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */
break;
default:
state = thread_join_data[tid].state;
MUTEX_UNLOCK(&start_thread_mutex);
Perl_croak_nocontext("panic: unexpected thread state on exit: '%s'",
pthreads_state_string(state));
}
MUTEX_UNLOCK(&start_thread_mutex);
}
int
pthread_create(perl_os_thread *tidp, const pthread_attr_t *attr,
void *(*start_routine)(void*), void *arg)
{
dTHX;
pthr_startit args;
args.sub = (void*)start_routine;
args.arg = arg;
args.ctx = PERL_GET_CONTEXT;
MUTEX_LOCK(&start_thread_mutex);
/* Test suite creates 31 extra threads;
on machine without shared-memory-hogs this stack sizeis OK with 31: */
*tidp = _beginthread(pthread_startit, /*stack*/ NULL,
/*stacksize*/ 4*1024*1024, (void*)&args);
if (*tidp == -1) {
*tidp = pthread_not_existant;
MUTEX_UNLOCK(&start_thread_mutex);
return EINVAL;
}
MUTEX_LOCK(&start_thread_mutex); /* Wait for init to proceed */
MUTEX_UNLOCK(&start_thread_mutex);
return 0;
}
int
pthread_detach(perl_os_thread tid)
{
MUTEX_LOCK(&start_thread_mutex);
if (tid < 1 || tid >= thread_join_count) {
MUTEX_UNLOCK(&start_thread_mutex);
if (tid != pthread_not_existant)
Perl_croak_nocontext("panic: detach of a thread with strange ordinal %d", (int)tid);
Perl_warn_nocontext("detach of a thread which could not start");
return 0;
}
switch (thread_join_data[tid].state) {
case pthreads_st_waited:
MUTEX_UNLOCK(&start_thread_mutex);
Perl_croak_nocontext("detach on a thread with a waiter");
break;
case pthreads_st_run:
thread_join_data[tid].state = pthreads_st_detached;
MUTEX_UNLOCK(&start_thread_mutex);
break;
case pthreads_st_exited:
MUTEX_UNLOCK(&start_thread_mutex);
COND_SIGNAL(&thread_join_data[tid].cond);
break;
case pthreads_st_detached:
MUTEX_UNLOCK(&start_thread_mutex);
Perl_warn_nocontext("detach on an already detached thread");
break;
case pthreads_st_norun:
{
int state = (int)thread_join_data[tid].status;
thread_join_data[tid].state = pthreads_st_none;
MUTEX_UNLOCK(&start_thread_mutex);
Perl_croak_nocontext("panic: detaching thread which could not run"
" due to attempt of tid reuse (state='%s')",
pthreads_state_string(state));
break;
}
default:
MUTEX_UNLOCK(&start_thread_mutex);
Perl_croak_nocontext("panic: detach of a thread with unknown thread state: '%s'",
pthreads_state_string(thread_join_data[tid].state));
break;
}
return 0;
}
/* This is a very bastardized version; may be OK due to edge trigger of Wait */
int
os2_cond_wait(perl_cond *c, perl_mutex *m)
{
int rc;
STRLEN n_a;
if ((rc = DosResetEventSem(*c,&n_a)) && (rc != ERROR_ALREADY_RESET))
Perl_rc = CheckOSError(rc), croak_with_os2error("panic: COND_WAIT-reset");
if (m) MUTEX_UNLOCK(m);
if (CheckOSError(DosWaitEventSem(*c,SEM_INDEFINITE_WAIT))
&& (rc != ERROR_INTERRUPT))
croak_with_os2error("panic: COND_WAIT");
if (rc == ERROR_INTERRUPT)
errno = EINTR;
if (m) MUTEX_LOCK(m);
return 0;
}
#endif
static int exe_is_aout(void);
/* This should match enum entries_ordinals defined in os2ish.h. */
static const struct {
struct dll_handle_t *dll;
const char *entryname;
int entrypoint;
} loadOrdinals[] = {
{&doscalls_handle, NULL, 874}, /* DosQueryExtLibpath */
{&doscalls_handle, NULL, 873}, /* DosSetExtLibpath */
{&doscalls_handle, NULL, 460}, /* DosVerifyPidTid */
{&tcp_handle, "SETHOSTENT", 0},
{&tcp_handle, "SETNETENT" , 0},
{&tcp_handle, "SETPROTOENT", 0},
{&tcp_handle, "SETSERVENT", 0},
{&tcp_handle, "GETHOSTENT", 0},
{&tcp_handle, "GETNETENT" , 0},
{&tcp_handle, "GETPROTOENT", 0},
{&tcp_handle, "GETSERVENT", 0},
{&tcp_handle, "ENDHOSTENT", 0},
{&tcp_handle, "ENDNETENT", 0},
{&tcp_handle, "ENDPROTOENT", 0},
{&tcp_handle, "ENDSERVENT", 0},
{&pmwin_handle, NULL, 763}, /* WinInitialize */
{&pmwin_handle, NULL, 716}, /* WinCreateMsgQueue */
{&pmwin_handle, NULL, 726}, /* WinDestroyMsgQueue */
{&pmwin_handle, NULL, 918}, /* WinPeekMsg */
{&pmwin_handle, NULL, 915}, /* WinGetMsg */
{&pmwin_handle, NULL, 912}, /* WinDispatchMsg */
{&pmwin_handle, NULL, 753}, /* WinGetLastError */
{&pmwin_handle, NULL, 705}, /* WinCancelShutdown */
/* These are needed in extensions.
How to protect PMSHAPI: it comes through EMX functions? */
{&rexx_handle, "RexxStart", 0},
{&rexx_handle, "RexxVariablePool", 0},
{&rexxapi_handle, "RexxRegisterFunctionExe", 0},
{&rexxapi_handle, "RexxDeregisterFunction", 0},
{&sesmgr_handle, "DOSSMSETTITLE", 0}, /* Would not work runtime-loaded */
{&pmshapi_handle, "PRF32QUERYPROFILESIZE", 0},
{&pmshapi_handle, "PRF32OPENPROFILE", 0},
{&pmshapi_handle, "PRF32CLOSEPROFILE", 0},
{&pmshapi_handle, "PRF32QUERYPROFILE", 0},
{&pmshapi_handle, "PRF32RESET", 0},
{&pmshapi_handle, "PRF32QUERYPROFILEDATA", 0},
{&pmshapi_handle, "PRF32WRITEPROFILEDATA", 0},
/* At least some of these do not work by name, since they need
WIN32 instead of WIN... */
#if 0
These were generated with
nm I:\emx\lib\os2.a | fgrep -f API-list | grep = > API-list-entries
perl -wnle "next unless /^0+\s+E\s+_(\w+)=(\w+).(\d+)/; print qq( ORD_$1,)" API-list-entries > API-list-ORD_
perl -wnle "next unless /^0+\s+E\s+_(\w+)=(\w+).(\d+)/; print qq( {${2}_handle, NULL, $3},\t\t/* $1 */)" WinSwitch-API-list-entries >API-list-entry
#endif
{&pmshapi_handle, NULL, 123}, /* WinChangeSwitchEntry */
{&pmshapi_handle, NULL, 124}, /* WinQuerySwitchEntry */
{&pmshapi_handle, NULL, 125}, /* WinQuerySwitchHandle */
{&pmshapi_handle, NULL, 126}, /* WinQuerySwitchList */
{&pmshapi_handle, NULL, 131}, /* WinSwitchToProgram */
{&pmwin_handle, NULL, 702}, /* WinBeginEnumWindows */
{&pmwin_handle, NULL, 737}, /* WinEndEnumWindows */
{&pmwin_handle, NULL, 740}, /* WinEnumDlgItem */
{&pmwin_handle, NULL, 756}, /* WinGetNextWindow */
{&pmwin_handle, NULL, 768}, /* WinIsChild */
{&pmwin_handle, NULL, 799}, /* WinQueryActiveWindow */
{&pmwin_handle, NULL, 805}, /* WinQueryClassName */
{&pmwin_handle, NULL, 817}, /* WinQueryFocus */
{&pmwin_handle, NULL, 834}, /* WinQueryWindow */
{&pmwin_handle, NULL, 837}, /* WinQueryWindowPos */
{&pmwin_handle, NULL, 838}, /* WinQueryWindowProcess */
{&pmwin_handle, NULL, 841}, /* WinQueryWindowText */
{&pmwin_handle, NULL, 842}, /* WinQueryWindowTextLength */
{&pmwin_handle, NULL, 860}, /* WinSetFocus */
{&pmwin_handle, NULL, 875}, /* WinSetWindowPos */
{&pmwin_handle, NULL, 877}, /* WinSetWindowText */
{&pmwin_handle, NULL, 883}, /* WinShowWindow */
{&pmwin_handle, NULL, 772}, /* WinIsWindow */
{&pmwin_handle, NULL, 899}, /* WinWindowFromId */
{&pmwin_handle, NULL, 900}, /* WinWindowFromPoint */
{&pmwin_handle, NULL, 919}, /* WinPostMsg */
{&pmwin_handle, NULL, 735}, /* WinEnableWindow */
{&pmwin_handle, NULL, 736}, /* WinEnableWindowUpdate */
{&pmwin_handle, NULL, 773}, /* WinIsWindowEnabled */
{&pmwin_handle, NULL, 774}, /* WinIsWindowShowing */
{&pmwin_handle, NULL, 775}, /* WinIsWindowVisible */
{&pmwin_handle, NULL, 839}, /* WinQueryWindowPtr */
{&pmwin_handle, NULL, 843}, /* WinQueryWindowULong */
{&pmwin_handle, NULL, 844}, /* WinQueryWindowUShort */
{&pmwin_handle, NULL, 874}, /* WinSetWindowBits */
{&pmwin_handle, NULL, 876}, /* WinSetWindowPtr */
{&pmwin_handle, NULL, 878}, /* WinSetWindowULong */
{&pmwin_handle, NULL, 879}, /* WinSetWindowUShort */
{&pmwin_handle, NULL, 813}, /* WinQueryDesktopWindow */
{&pmwin_handle, NULL, 851}, /* WinSetActiveWindow */
{&doscalls_handle, NULL, 360}, /* DosQueryModFromEIP */
{&doscalls_handle, NULL, 582}, /* Dos32QueryHeaderInfo */
{&doscalls_handle, NULL, 362}, /* DosTmrQueryFreq */
{&doscalls_handle, NULL, 363}, /* DosTmrQueryTime */
{&pmwp_handle, NULL, 262}, /* WinQueryActiveDesktopPathname */
{&pmwin_handle, NULL, 765}, /* WinInvalidateRect */
{&pmwin_handle, NULL, 906}, /* WinCreateFrameControl */
{&pmwin_handle, NULL, 807}, /* WinQueryClipbrdFmtInfo */
{&pmwin_handle, NULL, 808}, /* WinQueryClipbrdOwner */
{&pmwin_handle, NULL, 809}, /* WinQueryClipbrdViewer */
{&pmwin_handle, NULL, 806}, /* WinQueryClipbrdData */
{&pmwin_handle, NULL, 793}, /* WinOpenClipbrd */
{&pmwin_handle, NULL, 707}, /* WinCloseClipbrd */
{&pmwin_handle, NULL, 854}, /* WinSetClipbrdData */
{&pmwin_handle, NULL, 855}, /* WinSetClipbrdOwner */
{&pmwin_handle, NULL, 856}, /* WinSetClipbrdViewer */
{&pmwin_handle, NULL, 739}, /* WinEnumClipbrdFmts */
{&pmwin_handle, NULL, 733}, /* WinEmptyClipbrd */
{&pmwin_handle, NULL, 700}, /* WinAddAtom */
{&pmwin_handle, NULL, 744}, /* WinFindAtom */
{&pmwin_handle, NULL, 721}, /* WinDeleteAtom */
{&pmwin_handle, NULL, 803}, /* WinQueryAtomUsage */
{&pmwin_handle, NULL, 802}, /* WinQueryAtomName */
{&pmwin_handle, NULL, 801}, /* WinQueryAtomLength */
{&pmwin_handle, NULL, 830}, /* WinQuerySystemAtomTable */
{&pmwin_handle, NULL, 714}, /* WinCreateAtomTable */
{&pmwin_handle, NULL, 724}, /* WinDestroyAtomTable */
{&pmwin_handle, NULL, 794}, /* WinOpenWindowDC */
{&pmgpi_handle, NULL, 610}, /* DevOpenDC */
{&pmgpi_handle, NULL, 606}, /* DevQueryCaps */
{&pmgpi_handle, NULL, 604}, /* DevCloseDC */
{&pmwin_handle, NULL, 789}, /* WinMessageBox */
{&pmwin_handle, NULL, 1015}, /* WinMessageBox2 */
{&pmwin_handle, NULL, 829}, /* WinQuerySysValue */
{&pmwin_handle, NULL, 873}, /* WinSetSysValue */
{&pmwin_handle, NULL, 701}, /* WinAlarm */
{&pmwin_handle, NULL, 745}, /* WinFlashWindow */
{&pmwin_handle, NULL, 780}, /* WinLoadPointer */
{&pmwin_handle, NULL, 828}, /* WinQuerySysPointer */
{&doscalls_handle, NULL, 417}, /* DosReplaceModule */
{&doscalls_handle, NULL, 976}, /* DosPerfSysCall */
{&rexxapi_handle, "RexxRegisterSubcomExe", 0},
};
HMODULE
loadModule(const char *modname, int fail)
{
HMODULE h = (HMODULE)dlopen(modname, 0);
if (!h && fail)
Perl_croak_nocontext("Error loading module '%s': %s",
modname, dlerror());
return h;
}
/* const char* const ptypes[] = { "FS", "DOS", "VIO", "PM", "DETACH" }; */
static int
my_type()
{
int rc;
TIB *tib;
PIB *pib;
if (!(_emx_env & 0x200)) return 1; /* not OS/2. */
if (CheckOSError(DosGetInfoBlocks(&tib, &pib)))
return -1;
return (pib->pib_ultype);
}
static void
my_type_set(int type)
{
int rc;
TIB *tib;
PIB *pib;
if (!(_emx_env & 0x200))
Perl_croak_nocontext("Can't set type on DOS"); /* not OS/2. */
if (CheckOSError(DosGetInfoBlocks(&tib, &pib)))
croak_with_os2error("Error getting info blocks");
pib->pib_ultype = type;
}
PFN
loadByOrdinal(enum entries_ordinals ord, int fail)
{
if (sizeof(loadOrdinals)/sizeof(loadOrdinals[0]) != ORD_NENTRIES)
Perl_croak_nocontext(
"Wrong size of loadOrdinals array: expected %d, actual %d",
sizeof(loadOrdinals)/sizeof(loadOrdinals[0]), ORD_NENTRIES);
if (ExtFCN[ord] == NULL) {
PFN fcn = (PFN)-1;
APIRET rc;
if (!loadOrdinals[ord].dll->handle) {
if (loadOrdinals[ord].dll->requires_pm && my_type() < 2) { /* FS */
char *s = getenv("PERL_ASIF_PM");
if (!s || !atoi(s)) {
/* The module will not function well without PM.
The usual way to detect PM is the existence of the mutex
\SEM32\PMDRAG.SEM. */
HMTX hMtx = 0;
if (CheckOSError(DosOpenMutexSem("\\SEM32\\PMDRAG.SEM",
&hMtx)))
Perl_croak_nocontext("Looks like we have no PM; will not load DLL %s without $ENV{PERL_ASIF_PM}",
loadOrdinals[ord].dll->modname);
DosCloseMutexSem(hMtx);
}
}
MUTEX_LOCK(&perlos2_state_mutex);
loadOrdinals[ord].dll->handle
= loadModule(loadOrdinals[ord].dll->modname, fail);
MUTEX_UNLOCK(&perlos2_state_mutex);
}
if (!loadOrdinals[ord].dll->handle)
return 0; /* Possible with FAIL==0 only */
if (CheckOSError(DosQueryProcAddr(loadOrdinals[ord].dll->handle,
loadOrdinals[ord].entrypoint,
loadOrdinals[ord].entryname,&fcn))) {
char buf[20], *s = (char*)loadOrdinals[ord].entryname;
if (!fail)
return 0;
if (!s)
sprintf(s = buf, "%d", loadOrdinals[ord].entrypoint);
Perl_croak_nocontext(
"This version of OS/2 does not support %s.%s",
loadOrdinals[ord].dll->modname, s);
}
ExtFCN[ord] = fcn;
}
if ((long)ExtFCN[ord] == -1)
Perl_croak_nocontext("panic queryaddr");
return ExtFCN[ord];
}
void
init_PMWIN_entries(void)
{
int i;
for (i = ORD_WinInitialize; i <= ORD_WinCancelShutdown; i++)
((PFN*)&PMWIN_entries)[i - ORD_WinInitialize] = loadByOrdinal(i, 1);
}
/*****************************************************/
/* socket forwarders without linking with tcpip DLLs */
DeclFuncByORD(struct hostent *, gethostent, ORD_GETHOSTENT, (void), ())
DeclFuncByORD(struct netent *, getnetent, ORD_GETNETENT, (void), ())
DeclFuncByORD(struct protoent *, getprotoent, ORD_GETPROTOENT, (void), ())
DeclFuncByORD(struct servent *, getservent, ORD_GETSERVENT, (void), ())
DeclVoidFuncByORD(sethostent, ORD_SETHOSTENT, (int x), (x))
DeclVoidFuncByORD(setnetent, ORD_SETNETENT, (int x), (x))
DeclVoidFuncByORD(setprotoent, ORD_SETPROTOENT, (int x), (x))
DeclVoidFuncByORD(setservent, ORD_SETSERVENT, (int x), (x))
DeclVoidFuncByORD(endhostent, ORD_ENDHOSTENT, (void), ())
DeclVoidFuncByORD(endnetent, ORD_ENDNETENT, (void), ())
DeclVoidFuncByORD(endprotoent, ORD_ENDPROTOENT, (void), ())
DeclVoidFuncByORD(endservent, ORD_ENDSERVENT, (void), ())
/* priorities */
static const signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged,
self inverse. */
#define QSS_INI_BUFFER 1024
ULONG (*pDosVerifyPidTid) (PID pid, TID tid);
PQTOPLEVEL
get_sysinfo(ULONG pid, ULONG flags)
{
char *pbuffer;
ULONG rc, buf_len = QSS_INI_BUFFER;
PQTOPLEVEL psi;
if (pid) {
if (!pidtid_lookup) {
pidtid_lookup = 1;
*(PFN*)&pDosVerifyPidTid = loadByOrdinal(ORD_DosVerifyPidTid, 0);
}
if (pDosVerifyPidTid) { /* Warp3 or later */
/* Up to some fixpak QuerySysState() kills the system if a non-existent
pid is used. */
if (CheckOSError(pDosVerifyPidTid(pid, 1)))
return 0;
}
}
Newx(pbuffer, buf_len, char);
/* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */
rc = QuerySysState(flags, pid, pbuffer, buf_len);
while (rc == ERROR_BUFFER_OVERFLOW) {
Renew(pbuffer, buf_len *= 2, char);
rc = QuerySysState(flags, pid, pbuffer, buf_len);
}
if (rc) {
FillOSError(rc);
Safefree(pbuffer);
return 0;
}
psi = (PQTOPLEVEL)pbuffer;
if (psi && pid && psi->procdata && pid != psi->procdata->pid) {
Safefree(psi);
Perl_croak_nocontext("panic: wrong pid in sysinfo");
}
return psi;
}
#define PRIO_ERR 0x1111
static ULONG
sys_prio(pid)
{
ULONG prio;
PQTOPLEVEL psi;
if (!pid)
return PRIO_ERR;
psi = get_sysinfo(pid, QSS_PROCESS);
if (!psi)
return PRIO_ERR;
prio = psi->procdata->threads->priority;
Safefree(psi);
return prio;
}
int
setpriority(int which, int pid, int val)
{
ULONG rc, prio = sys_prio(pid);
if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) {
/* Do not change class. */
return CheckOSError(DosSetPriority((pid < 0)
? PRTYS_PROCESSTREE : PRTYS_PROCESS,
0,
(32 - val) % 32 - (prio & 0xFF),
abs(pid)))
? -1 : 0;
} else /* if ((32 - val) % 32 == (prio & 0xFF)) */ {
/* Documentation claims one can change both class and basevalue,
* but I find it wrong. */
/* Change class, but since delta == 0 denotes absolute 0, correct. */
if (CheckOSError(DosSetPriority((pid < 0)
? PRTYS_PROCESSTREE : PRTYS_PROCESS,
priors[(32 - val) >> 5] + 1,
0,
abs(pid))))
return -1;
if ( ((32 - val) % 32) == 0 ) return 0;
return CheckOSError(DosSetPriority((pid < 0)
? PRTYS_PROCESSTREE : PRTYS_PROCESS,
0,
(32 - val) % 32,
abs(pid)))
? -1 : 0;
}
}
int
getpriority(int which /* ignored */, int pid)
{
ULONG ret;
if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
ret = sys_prio(pid);
if (ret == PRIO_ERR) {
return -1;
}
return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF);
}
/*****************************************************************************/
/* spawn */
static Signal_t
spawn_sighandler(int sig)
{
/* Some programs do not arrange for the keyboard signals to be
delivered to them. We need to deliver the signal manually. */
/* We may get a signal only if
a) kid does not receive keyboard signal: deliver it;
b) kid already died, and we get a signal. We may only hope
that the pid number was not reused.
*/
if (spawn_killed)
sig = SIGKILL; /* Try harder. */
kill(spawn_pid, sig);
spawn_killed = 1;
}
static int
result(pTHX_ int flag, int pid)
{
int r, status;
Signal_t (*ihand)(); /* place to save signal during system() */
Signal_t (*qhand)(); /* place to save signal during system() */
#ifndef __EMX__
RESULTCODES res;
int rpid;
#endif
if (pid < 0 || flag != 0)
return pid;
#ifdef __EMX__
spawn_pid = pid;
spawn_killed = 0;
ihand = rsignal(SIGINT, &spawn_sighandler);
qhand = rsignal(SIGQUIT, &spawn_sighandler);
do {
r = wait4pid(pid, &status, 0);
} while (r == -1 && errno == EINTR);
rsignal(SIGINT, ihand);
rsignal(SIGQUIT, qhand);
PL_statusvalue = (U16)status;
if (r < 0)
return -1;
return status & 0xFFFF;
#else
ihand = rsignal(SIGINT, SIG_IGN);
r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid);
rsignal(SIGINT, ihand);
PL_statusvalue = res.codeResult << 8 | res.codeTerminate;
if (r)
return -1;
return PL_statusvalue;
#endif
}
enum execf_t {
EXECF_SPAWN,
EXECF_EXEC,
EXECF_TRUEEXEC,
EXECF_SPAWN_NOWAIT,
EXECF_SPAWN_BYFLAG,
EXECF_SYNC
};
static ULONG
file_type(char *path)
{
int rc;
ULONG apptype;
if (!(_emx_env & 0x200))
Perl_croak_nocontext("file_type not implemented on DOS"); /* not OS/2. */
if (CheckOSError(DosQueryAppType(path, &apptype))) {
switch (rc) {
case ERROR_FILE_NOT_FOUND:
case ERROR_PATH_NOT_FOUND:
return -1;
case ERROR_ACCESS_DENIED: /* Directory with this name found? */
return -3;
default: /* Found, but not an
executable, or some other
read error. */
return -2;
}
}
return apptype;
}
/* Spawn/exec a program, revert to shell if needed. */
/* global PL_Argv[] contains arguments. */
extern ULONG _emx_exception ( EXCEPTIONREPORTRECORD *,
EXCEPTIONREGISTRATIONRECORD *,
CONTEXTRECORD *,
void *);
int
do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag)
{
int trueflag = flag;
int rc, pass = 1;
char *real_name = NULL; /* Shut down the warning */
char const * args[4];
static const char * const fargs[4]
= { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", };
const char * const *argsp = fargs;
int nargs = 4;
int force_shell;
int new_stderr = -1, nostderr = 0;
int fl_stderr = 0;
STRLEN n_a;
char *buf;
PerlIO *file;
if (flag == P_WAIT)
flag = P_NOWAIT;
if (really && !*(real_name = SvPV(really, n_a)))