1 #define INCL_DOS 2 #define INCL_NOPM 3 #define INCL_DOSFILEMGR 4 #define INCL_DOSMEMMGR 5 #define INCL_DOSERRORS 6 #include <os2.h> 7 8 /* 9 * Various Unix compatibility functions for OS/2 10 */ 11 12 #include <stdio.h> 13 #include <errno.h> 14 #include <limits.h> 15 #include <process.h> 16 #include <fcntl.h> 17 18 #include "EXTERN.h" 19 #include "perl.h" 20 21 /*****************************************************************************/ 22 /* 2.1 would not resolve symbols on demand, and has no ExtLIBPATH. */ 23 static PFN ExtFCN[2]; /* Labeled by ord below. */ 24 static USHORT loadOrd[2] = { 874, 873 }; /* Query=874, Set=873. */ 25 #define ORD_QUERY_ELP 0 26 #define ORD_SET_ELP 1 27 28 APIRET 29 loadByOrd(ULONG ord) 30 { 31 if (ExtFCN[ord] == NULL) { 32 static HMODULE hdosc = 0; 33 BYTE buf[20]; 34 PFN fcn; 35 APIRET rc; 36 37 if ((!hdosc && CheckOSError(DosLoadModule(buf, sizeof buf, 38 "doscalls", &hdosc))) 39 || CheckOSError(DosQueryProcAddr(hdosc, loadOrd[ord], NULL, &fcn))) 40 die("This version of OS/2 does not support doscalls.%i", 41 loadOrd[ord]); 42 ExtFCN[ord] = fcn; 43 } 44 if ((long)ExtFCN[ord] == -1) die("panic queryaddr"); 45 } 46 47 /* priorities */ 48 static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged, 49 self inverse. */ 50 #define QSS_INI_BUFFER 1024 51 52 PQTOPLEVEL 53 get_sysinfo(ULONG pid, ULONG flags) 54 { 55 char *pbuffer; 56 ULONG rc, buf_len = QSS_INI_BUFFER; 57 58 New(1322, pbuffer, buf_len, char); 59 /* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */ 60 rc = QuerySysState(flags, pid, pbuffer, buf_len); 61 while (rc == ERROR_BUFFER_OVERFLOW) { 62 Renew(pbuffer, buf_len *= 2, char); 63 rc = QuerySysState(flags, pid, pbuffer, buf_len); 64 } 65 if (rc) { 66 FillOSError(rc); 67 Safefree(pbuffer); 68 return 0; 69 } 70 return (PQTOPLEVEL)pbuffer; 71 } 72 73 #define PRIO_ERR 0x1111 74 75 static ULONG 76 sys_prio(pid) 77 { 78 ULONG prio; 79 PQTOPLEVEL psi; 80 81 psi = get_sysinfo(pid, QSS_PROCESS); 82 if (!psi) { 83 return PRIO_ERR; 84 } 85 if (pid != psi->procdata->pid) { 86 Safefree(psi); 87 croak("panic: wrong pid in sysinfo"); 88 } 89 prio = psi->procdata->threads->priority; 90 Safefree(psi); 91 return prio; 92 } 93 94 int 95 setpriority(int which, int pid, int val) 96 { 97 ULONG rc, prio; 98 PQTOPLEVEL psi; 99 100 prio = sys_prio(pid); 101 102 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */ 103 if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) { 104 /* Do not change class. */ 105 return CheckOSError(DosSetPriority((pid < 0) 106 ? PRTYS_PROCESSTREE : PRTYS_PROCESS, 107 0, 108 (32 - val) % 32 - (prio & 0xFF), 109 abs(pid))) 110 ? -1 : 0; 111 } else /* if ((32 - val) % 32 == (prio & 0xFF)) */ { 112 /* Documentation claims one can change both class and basevalue, 113 * but I find it wrong. */ 114 /* Change class, but since delta == 0 denotes absolute 0, correct. */ 115 if (CheckOSError(DosSetPriority((pid < 0) 116 ? PRTYS_PROCESSTREE : PRTYS_PROCESS, 117 priors[(32 - val) >> 5] + 1, 118 0, 119 abs(pid)))) 120 return -1; 121 if ( ((32 - val) % 32) == 0 ) return 0; 122 return CheckOSError(DosSetPriority((pid < 0) 123 ? PRTYS_PROCESSTREE : PRTYS_PROCESS, 124 0, 125 (32 - val) % 32, 126 abs(pid))) 127 ? -1 : 0; 128 } 129 /* else return CheckOSError(DosSetPriority((pid < 0) */ 130 /* ? PRTYS_PROCESSTREE : PRTYS_PROCESS, */ 131 /* priors[(32 - val) >> 5] + 1, */ 132 /* (32 - val) % 32 - (prio & 0xFF), */ 133 /* abs(pid))) */ 134 /* ? -1 : 0; */ 135 } 136 137 int 138 getpriority(int which /* ignored */, int pid) 139 { 140 TIB *tib; 141 PIB *pib; 142 ULONG rc, ret; 143 144 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */ 145 /* DosGetInfoBlocks has old priority! */ 146 /* if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) return -1; */ 147 /* if (pid != pib->pib_ulpid) { */ 148 ret = sys_prio(pid); 149 if (ret == PRIO_ERR) { 150 return -1; 151 } 152 /* } else */ 153 /* ret = tib->tib_ptib2->tib2_ulpri; */ 154 return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF); 155 } 156 157 /*****************************************************************************/ 158 /* spawn */ 159 typedef void (*Sigfunc) _((int)); 160 161 static int 162 result(int flag, int pid) 163 { 164 int r, status; 165 Signal_t (*ihand)(); /* place to save signal during system() */ 166 Signal_t (*qhand)(); /* place to save signal during system() */ 167 #ifndef __EMX__ 168 RESULTCODES res; 169 int rpid; 170 #endif 171 172 if (pid < 0 || flag != 0) 173 return pid; 174 175 #ifdef __EMX__ 176 ihand = rsignal(SIGINT, SIG_IGN); 177 qhand = rsignal(SIGQUIT, SIG_IGN); 178 do { 179 r = wait4pid(pid, &status, 0); 180 } while (r == -1 && errno == EINTR); 181 rsignal(SIGINT, ihand); 182 rsignal(SIGQUIT, qhand); 183 184 statusvalue = (U16)status; 185 if (r < 0) 186 return -1; 187 return status & 0xFFFF; 188 #else 189 ihand = rsignal(SIGINT, SIG_IGN); 190 r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid); 191 rsignal(SIGINT, ihand); 192 statusvalue = res.codeResult << 8 | res.codeTerminate; 193 if (r) 194 return -1; 195 return statusvalue; 196 #endif 197 } 198 199 int 200 do_aspawn(really,mark,sp) 201 SV *really; 202 register SV **mark; 203 register SV **sp; 204 { 205 register char **a; 206 char *tmps = NULL; 207 int rc; 208 int flag = P_WAIT, trueflag, err, secondtry = 0; 209 210 if (sp > mark) { 211 New(1301,Argv, sp - mark + 3, char*); 212 a = Argv; 213 214 if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) { 215 ++mark; 216 flag = SvIVx(*mark); 217 } 218 219 while (++mark <= sp) { 220 if (*mark) 221 *a++ = SvPVx(*mark, na); 222 else 223 *a++ = ""; 224 } 225 *a = Nullch; 226 227 trueflag = flag; 228 if (flag == P_WAIT) 229 flag = P_NOWAIT; 230 231 if (strEQ(Argv[0],"/bin/sh")) Argv[0] = sh_path; 232 233 if (Argv[0][0] != '/' && Argv[0][0] != '\\' 234 && !(Argv[0][0] && Argv[0][1] == ':' 235 && (Argv[0][2] == '/' || Argv[0][2] != '\\')) 236 ) /* will swawnvp use PATH? */ 237 TAINT_ENV(); /* testing IFS here is overkill, probably */ 238 /* We should check PERL_SH* and PERLLIB_* as well? */ 239 retry: 240 if (really && *(tmps = SvPV(really, na))) 241 rc = result(trueflag, spawnvp(flag,tmps,Argv)); 242 else 243 rc = result(trueflag, spawnvp(flag,Argv[0],Argv)); 244 245 if (rc < 0 && secondtry == 0 246 && (!tmps || !*tmps)) { /* Cannot transfer `really' via shell. */ 247 err = errno; 248 if (err == ENOENT) { /* No such file. */ 249 /* One reason may be that EMX added .exe. We suppose 250 that .exe-less files are automatically shellable. */ 251 char *no_dir; 252 (no_dir = strrchr(Argv[0], '/')) 253 || (no_dir = strrchr(Argv[0], '\\')) 254 || (no_dir = Argv[0]); 255 if (!strchr(no_dir, '.')) { 256 struct stat buffer; 257 if (stat(Argv[0], &buffer) != -1) { /* File exists. */ 258 /* Maybe we need to specify the full name here? */ 259 goto doshell; 260 } 261 } 262 } else if (err == ENOEXEC) { /* Need to send to shell. */ 263 doshell: 264 while (a >= Argv) { 265 *(a + 2) = *a; 266 a--; 267 } 268 *Argv = sh_path; 269 *(Argv + 1) = "-c"; 270 secondtry = 1; 271 goto retry; 272 } 273 } 274 if (rc < 0 && dowarn) 275 warn("Can't spawn \"%s\": %s", Argv[0], Strerror(errno)); 276 if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */ 277 } else 278 rc = -1; 279 do_execfree(); 280 return rc; 281 } 282 283 #define EXECF_SPAWN 0 284 #define EXECF_EXEC 1 285 #define EXECF_TRUEEXEC 2 286 #define EXECF_SPAWN_NOWAIT 3 287 288 int 289 do_spawn2(cmd, execf) 290 char *cmd; 291 int execf; 292 { 293 register char **a; 294 register char *s; 295 char flags[10]; 296 char *shell, *copt, *news = NULL; 297 int rc, added_shell = 0, err, seenspace = 0; 298 char fullcmd[MAXNAMLEN + 1]; 299 300 #ifdef TRYSHELL 301 if ((shell = getenv("EMXSHELL")) != NULL) 302 copt = "-c"; 303 else if ((shell = getenv("SHELL")) != NULL) 304 copt = "-c"; 305 else if ((shell = getenv("COMSPEC")) != NULL) 306 copt = "/C"; 307 else 308 shell = "cmd.exe"; 309 #else 310 /* Consensus on perl5-porters is that it is _very_ important to 311 have a shell which will not change between computers with the 312 same architecture, to avoid "action on a distance". 313 And to have simple build, this shell should be sh. */ 314 shell = sh_path; 315 copt = "-c"; 316 #endif 317 318 while (*cmd && isSPACE(*cmd)) 319 cmd++; 320 321 if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) { 322 STRLEN l = strlen(sh_path); 323 324 New(1302, news, strlen(cmd) - 7 + l + 1, char); 325 strcpy(news, sh_path); 326 strcpy(news + l, cmd + 7); 327 cmd = news; 328 added_shell = 1; 329 } 330 331 /* save an extra exec if possible */ 332 /* see if there are shell metacharacters in it */ 333 334 if (*cmd == '.' && isSPACE(cmd[1])) 335 goto doshell; 336 337 if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4])) 338 goto doshell; 339 340 for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */ 341 if (*s == '=') 342 goto doshell; 343 344 for (s = cmd; *s; s++) { 345 if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) { 346 if (*s == '\n' && s[1] == '\0') { 347 *s = '\0'; 348 break; 349 } else if (*s == '\\' && !seenspace) { 350 continue; /* Allow backslashes in names */ 351 } 352 doshell: 353 if (execf == EXECF_TRUEEXEC) 354 return execl(shell,shell,copt,cmd,(char*)0); 355 else if (execf == EXECF_EXEC) 356 return spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0); 357 else if (execf == EXECF_SPAWN_NOWAIT) 358 return spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0); 359 /* In the ak code internal P_NOWAIT is P_WAIT ??? */ 360 rc = result(P_WAIT, 361 spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0)); 362 if (rc < 0 && dowarn) 363 warn("Can't %s \"%s\": %s", 364 (execf == EXECF_SPAWN ? "spawn" : "exec"), 365 shell, Strerror(errno)); 366 if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */ 367 if (news) Safefree(news); 368 return rc; 369 } else if (*s == ' ' || *s == '\t') { 370 seenspace = 1; 371 } 372 } 373 374 New(1303,Argv, (s - cmd) / 2 + 2, char*); 375 Cmd = savepvn(cmd, s-cmd); 376 a = Argv; 377 for (s = Cmd; *s;) { 378 while (*s && isSPACE(*s)) s++; 379 if (*s) 380 *(a++) = s; 381 while (*s && !isSPACE(*s)) s++; 382 if (*s) 383 *s++ = '\0'; 384 } 385 *a = Nullch; 386 if (Argv[0]) { 387 int err; 388 389 if (execf == EXECF_TRUEEXEC) 390 rc = execvp(Argv[0],Argv); 391 else if (execf == EXECF_EXEC) 392 rc = spawnvp(P_OVERLAY,Argv[0],Argv); 393 else if (execf == EXECF_SPAWN_NOWAIT) 394 rc = spawnvp(P_NOWAIT,Argv[0],Argv); 395 else 396 rc = result(P_WAIT, spawnvp(P_NOWAIT,Argv[0],Argv)); 397 if (rc < 0) { 398 err = errno; 399 if (err == ENOENT) { /* No such file. */ 400 /* One reason may be that EMX added .exe. We suppose 401 that .exe-less files are automatically shellable. */ 402 char *no_dir; 403 (no_dir = strrchr(Argv[0], '/')) 404 || (no_dir = strrchr(Argv[0], '\\')) 405 || (no_dir = Argv[0]); 406 if (!strchr(no_dir, '.')) { 407 struct stat buffer; 408 if (stat(Argv[0], &buffer) != -1) { /* File exists. */ 409 /* Maybe we need to specify the full name here? */ 410 goto doshell; 411 } 412 } 413 } else if (err == ENOEXEC) { /* Need to send to shell. */ 414 goto doshell; 415 } 416 } 417 if (rc < 0 && dowarn) 418 warn("Can't %s \"%s\": %s", 419 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC) 420 ? "spawn" : "exec"), 421 Argv[0], Strerror(err)); 422 if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */ 423 } else 424 rc = -1; 425 if (news) Safefree(news); 426 do_execfree(); 427 return rc; 428 } 429 430 int 431 do_spawn(cmd) 432 char *cmd; 433 { 434 return do_spawn2(cmd, EXECF_SPAWN); 435 } 436 437 int 438 do_spawn_nowait(cmd) 439 char *cmd; 440 { 441 return do_spawn2(cmd, EXECF_SPAWN_NOWAIT); 442 } 443 444 bool 445 do_exec(cmd) 446 char *cmd; 447 { 448 return do_spawn2(cmd, EXECF_EXEC); 449 } 450 451 bool 452 os2exec(cmd) 453 char *cmd; 454 { 455 return do_spawn2(cmd, EXECF_TRUEEXEC); 456 } 457 458 PerlIO * 459 my_syspopen(cmd,mode) 460 char *cmd; 461 char *mode; 462 { 463 #ifndef USE_POPEN 464 465 int p[2]; 466 register I32 this, that, newfd; 467 register I32 pid, rc; 468 PerlIO *res; 469 SV *sv; 470 471 if (pipe(p) < 0) 472 return Nullfp; 473 /* `this' is what we use in the parent, `that' in the child. */ 474 this = (*mode == 'w'); 475 that = !this; 476 if (tainting) { 477 taint_env(); 478 taint_proper("Insecure %s%s", "EXEC"); 479 } 480 /* Now we need to spawn the child. */ 481 newfd = dup(*mode == 'r'); /* Preserve std* */ 482 if (p[that] != (*mode == 'r')) { 483 dup2(p[that], *mode == 'r'); 484 close(p[that]); 485 } 486 /* Where is `this' and newfd now? */ 487 fcntl(p[this], F_SETFD, FD_CLOEXEC); 488 fcntl(newfd, F_SETFD, FD_CLOEXEC); 489 pid = do_spawn_nowait(cmd); 490 if (newfd != (*mode == 'r')) { 491 dup2(newfd, *mode == 'r'); /* Return std* back. */ 492 close(newfd); 493 } 494 close(p[that]); 495 if (pid == -1) { 496 close(p[this]); 497 return NULL; 498 } 499 if (p[that] < p[this]) { 500 dup2(p[this], p[that]); 501 close(p[this]); 502 p[this] = p[that]; 503 } 504 sv = *av_fetch(fdpid,p[this],TRUE); 505 (void)SvUPGRADE(sv,SVt_IV); 506 SvIVX(sv) = pid; 507 forkprocess = pid; 508 return PerlIO_fdopen(p[this], mode); 509 510 #else /* USE_POPEN */ 511 512 PerlIO *res; 513 SV *sv; 514 515 # ifdef TRYSHELL 516 res = popen(cmd, mode); 517 # else 518 char *shell = getenv("EMXSHELL"); 519 520 my_setenv("EMXSHELL", sh_path); 521 res = popen(cmd, mode); 522 my_setenv("EMXSHELL", shell); 523 # endif 524 sv = *av_fetch(fdpid, PerlIO_fileno(res), TRUE); 525 (void)SvUPGRADE(sv,SVt_IV); 526 SvIVX(sv) = -1; /* A cooky. */ 527 return res; 528 529 #endif /* USE_POPEN */ 530 531 } 532 533 /******************************************************************/ 534 535 #ifndef HAS_FORK 536 int 537 fork(void) 538 { 539 die(no_func, "Unsupported function fork"); 540 errno = EINVAL; 541 return -1; 542 } 543 #endif 544 545 /*******************************************************************/ 546 /* not implemented in EMX 0.9a */ 547 548 void * ctermid(x) { return 0; } 549 550 #ifdef MYTTYNAME /* was not in emx0.9a */ 551 void * ttyname(x) { return 0; } 552 #endif 553 554 /******************************************************************/ 555 /* my socket forwarders - EMX lib only provides static forwarders */ 556 557 static HMODULE htcp = 0; 558 559 static void * 560 tcp0(char *name) 561 { 562 static BYTE buf[20]; 563 PFN fcn; 564 565 if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */ 566 if (!htcp) 567 DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp); 568 if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0) 569 return (void *) ((void * (*)(void)) fcn) (); 570 return 0; 571 } 572 573 static void 574 tcp1(char *name, int arg) 575 { 576 static BYTE buf[20]; 577 PFN fcn; 578 579 if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */ 580 if (!htcp) 581 DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp); 582 if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0) 583 ((void (*)(int)) fcn) (arg); 584 } 585 586 void * gethostent() { return tcp0("GETHOSTENT"); } 587 void * getnetent() { return tcp0("GETNETENT"); } 588 void * getprotoent() { return tcp0("GETPROTOENT"); } 589 void * getservent() { return tcp0("GETSERVENT"); } 590 void sethostent(x) { tcp1("SETHOSTENT", x); } 591 void setnetent(x) { tcp1("SETNETENT", x); } 592 void setprotoent(x) { tcp1("SETPROTOENT", x); } 593 void setservent(x) { tcp1("SETSERVENT", x); } 594 void endhostent() { tcp0("ENDHOSTENT"); } 595 void endnetent() { tcp0("ENDNETENT"); } 596 void endprotoent() { tcp0("ENDPROTOENT"); } 597 void endservent() { tcp0("ENDSERVENT"); } 598 599 /*****************************************************************************/ 600 /* not implemented in C Set++ */ 601 602 #ifndef __EMX__ 603 int setuid(x) { errno = EINVAL; return -1; } 604 int setgid(x) { errno = EINVAL; return -1; } 605 #endif 606 607 /*****************************************************************************/ 608 /* stat() hack for char/block device */ 609 610 #if OS2_STAT_HACK 611 612 /* First attempt used DosQueryFSAttach which crashed the system when 613 used with 5.001. Now just look for /dev/. */ 614 615 int 616 os2_stat(char *name, struct stat *st) 617 { 618 static int ino = SHRT_MAX; 619 620 if (stricmp(name, "/dev/con") != 0 621 && stricmp(name, "/dev/tty") != 0) 622 return stat(name, st); 623 624 memset(st, 0, sizeof *st); 625 st->st_mode = S_IFCHR|0666; 626 st->st_ino = (ino-- & 0x7FFF); 627 st->st_nlink = 1; 628 return 0; 629 } 630 631 #endif 632 633 #ifdef USE_PERL_SBRK 634 635 /* SBRK() emulation, mostly moved to malloc.c. */ 636 637 void * 638 sys_alloc(int size) { 639 void *got; 640 APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE); 641 642 if (rc == ERROR_NOT_ENOUGH_MEMORY) { 643 return (void *) -1; 644 } else if ( rc ) die("Got an error from DosAllocMem: %li", (long)rc); 645 return got; 646 } 647 648 #endif /* USE_PERL_SBRK */ 649 650 /* tmp path */ 651 652 char *tmppath = TMPPATH1; 653 654 void 655 settmppath() 656 { 657 char *p = getenv("TMP"), *tpath; 658 int len; 659 660 if (!p) p = getenv("TEMP"); 661 if (!p) return; 662 len = strlen(p); 663 tpath = (char *)malloc(len + strlen(TMPPATH1) + 2); 664 strcpy(tpath, p); 665 tpath[len] = '/'; 666 strcpy(tpath + len + 1, TMPPATH1); 667 tmppath = tpath; 668 } 669 670 #include "XSUB.h" 671 672 XS(XS_File__Copy_syscopy) 673 { 674 dXSARGS; 675 if (items < 2 || items > 3) 676 croak("Usage: File::Copy::syscopy(src,dst,flag=0)"); 677 { 678 char * src = (char *)SvPV(ST(0),na); 679 char * dst = (char *)SvPV(ST(1),na); 680 U32 flag; 681 int RETVAL, rc; 682 683 if (items < 3) 684 flag = 0; 685 else { 686 flag = (unsigned long)SvIV(ST(2)); 687 } 688 689 RETVAL = !CheckOSError(DosCopy(src, dst, flag)); 690 ST(0) = sv_newmortal(); 691 sv_setiv(ST(0), (IV)RETVAL); 692 } 693 XSRETURN(1); 694 } 695 696 char * 697 mod2fname(sv) 698 SV *sv; 699 { 700 static char fname[9]; 701 int pos = 6, len, avlen; 702 unsigned int sum = 0; 703 AV *av; 704 SV *svp; 705 char *s; 706 707 if (!SvROK(sv)) croak("Not a reference given to mod2fname"); 708 sv = SvRV(sv); 709 if (SvTYPE(sv) != SVt_PVAV) 710 croak("Not array reference given to mod2fname"); 711 712 avlen = av_len((AV*)sv); 713 if (avlen < 0) 714 croak("Empty array reference given to mod2fname"); 715 716 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), na); 717 strncpy(fname, s, 8); 718 len = strlen(s); 719 if (len < 6) pos = len; 720 while (*s) { 721 sum = 33 * sum + *(s++); /* Checksumming first chars to 722 * get the capitalization into c.s. */ 723 } 724 avlen --; 725 while (avlen >= 0) { 726 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), na); 727 while (*s) { 728 sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */ 729 } 730 avlen --; 731 } 732 fname[pos] = 'A' + (sum % 26); 733 fname[pos + 1] = 'A' + (sum / 26 % 26); 734 fname[pos + 2] = '\0'; 735 return (char *)fname; 736 } 737 738 XS(XS_DynaLoader_mod2fname) 739 { 740 dXSARGS; 741 if (items != 1) 742 croak("Usage: DynaLoader::mod2fname(sv)"); 743 { 744 SV * sv = ST(0); 745 char * RETVAL; 746 747 RETVAL = mod2fname(sv); 748 ST(0) = sv_newmortal(); 749 sv_setpv((SV*)ST(0), RETVAL); 750 } 751 XSRETURN(1); 752 } 753 754 char * 755 os2error(int rc) 756 { 757 static char buf[300]; 758 ULONG len; 759 760 if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */ 761 if (rc == 0) 762 return NULL; 763 if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len)) 764 sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc); 765 else 766 buf[len] = '\0'; 767 return buf; 768 } 769 770 char * 771 perllib_mangle(char *s, unsigned int l) 772 { 773 static char *newp, *oldp; 774 static int newl, oldl, notfound; 775 static char ret[STATIC_FILE_LENGTH+1]; 776 777 if (!newp && !notfound) { 778 newp = getenv("PERLLIB_PREFIX"); 779 if (newp) { 780 char *s; 781 782 oldp = newp; 783 while (*newp && !isSPACE(*newp) && *newp != ';') { 784 newp++; oldl++; /* Skip digits. */ 785 } 786 while (*newp && (isSPACE(*newp) || *newp == ';')) { 787 newp++; /* Skip whitespace. */ 788 } 789 newl = strlen(newp); 790 if (newl == 0 || oldl == 0) { 791 die("Malformed PERLLIB_PREFIX"); 792 } 793 strcpy(ret, newp); 794 s = ret; 795 while (*s) { 796 if (*s == '\\') *s = '/'; 797 s++; 798 } 799 } else { 800 notfound = 1; 801 } 802 } 803 if (!newp) { 804 return s; 805 } 806 if (l == 0) { 807 l = strlen(s); 808 } 809 if (l < oldl || strnicmp(oldp, s, oldl) != 0) { 810 return s; 811 } 812 if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) { 813 die("Malformed PERLLIB_PREFIX"); 814 } 815 strcpy(ret + newl, s + oldl); 816 return ret; 817 } 818 819 extern void dlopen(); 820 void *fakedl = &dlopen; /* Pull in dynaloading part. */ 821 822 #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \ 823 && ((path)[2] == '/' || (path)[2] == '\\')) 824 #define sys_is_rooted _fnisabs 825 #define sys_is_relative _fnisrel 826 #define current_drive _getdrive 827 828 #undef chdir /* Was _chdir2. */ 829 #define sys_chdir(p) (chdir(p) == 0) 830 #define change_drive(d) (_chdrive(d), (current_drive() == toupper(d))) 831 832 XS(XS_Cwd_current_drive) 833 { 834 dXSARGS; 835 if (items != 0) 836 croak("Usage: Cwd::current_drive()"); 837 { 838 char RETVAL; 839 840 RETVAL = current_drive(); 841 ST(0) = sv_newmortal(); 842 sv_setpvn(ST(0), (char *)&RETVAL, 1); 843 } 844 XSRETURN(1); 845 } 846 847 XS(XS_Cwd_sys_chdir) 848 { 849 dXSARGS; 850 if (items != 1) 851 croak("Usage: Cwd::sys_chdir(path)"); 852 { 853 char * path = (char *)SvPV(ST(0),na); 854 bool RETVAL; 855 856 RETVAL = sys_chdir(path); 857 ST(0) = boolSV(RETVAL); 858 if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); 859 } 860 XSRETURN(1); 861 } 862 863 XS(XS_Cwd_change_drive) 864 { 865 dXSARGS; 866 if (items != 1) 867 croak("Usage: Cwd::change_drive(d)"); 868 { 869 char d = (char)*SvPV(ST(0),na); 870 bool RETVAL; 871 872 RETVAL = change_drive(d); 873 ST(0) = boolSV(RETVAL); 874 if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); 875 } 876 XSRETURN(1); 877 } 878 879 XS(XS_Cwd_sys_is_absolute) 880 { 881 dXSARGS; 882 if (items != 1) 883 croak("Usage: Cwd::sys_is_absolute(path)"); 884 { 885 char * path = (char *)SvPV(ST(0),na); 886 bool RETVAL; 887 888 RETVAL = sys_is_absolute(path); 889 ST(0) = boolSV(RETVAL); 890 if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); 891 } 892 XSRETURN(1); 893 } 894 895 XS(XS_Cwd_sys_is_rooted) 896 { 897 dXSARGS; 898 if (items != 1) 899 croak("Usage: Cwd::sys_is_rooted(path)"); 900 { 901 char * path = (char *)SvPV(ST(0),na); 902 bool RETVAL; 903 904 RETVAL = sys_is_rooted(path); 905 ST(0) = boolSV(RETVAL); 906 if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); 907 } 908 XSRETURN(1); 909 } 910 911 XS(XS_Cwd_sys_is_relative) 912 { 913 dXSARGS; 914 if (items != 1) 915 croak("Usage: Cwd::sys_is_relative(path)"); 916 { 917 char * path = (char *)SvPV(ST(0),na); 918 bool RETVAL; 919 920 RETVAL = sys_is_relative(path); 921 ST(0) = boolSV(RETVAL); 922 if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); 923 } 924 XSRETURN(1); 925 } 926 927 XS(XS_Cwd_sys_cwd) 928 { 929 dXSARGS; 930 if (items != 0) 931 croak("Usage: Cwd::sys_cwd()"); 932 { 933 char p[MAXPATHLEN]; 934 char * RETVAL; 935 RETVAL = _getcwd2(p, MAXPATHLEN); 936 ST(0) = sv_newmortal(); 937 sv_setpv((SV*)ST(0), RETVAL); 938 } 939 XSRETURN(1); 940 } 941 942 XS(XS_Cwd_sys_abspath) 943 { 944 dXSARGS; 945 if (items < 1 || items > 2) 946 croak("Usage: Cwd::sys_abspath(path, dir = NULL)"); 947 { 948 char * path = (char *)SvPV(ST(0),na); 949 char * dir; 950 char p[MAXPATHLEN]; 951 char * RETVAL; 952 953 if (items < 2) 954 dir = NULL; 955 else { 956 dir = (char *)SvPV(ST(1),na); 957 } 958 if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) { 959 path += 2; 960 } 961 if (dir == NULL) { 962 if (_abspath(p, path, MAXPATHLEN) == 0) { 963 RETVAL = p; 964 } else { 965 RETVAL = NULL; 966 } 967 } else { 968 /* Absolute with drive: */ 969 if ( sys_is_absolute(path) ) { 970 if (_abspath(p, path, MAXPATHLEN) == 0) { 971 RETVAL = p; 972 } else { 973 RETVAL = NULL; 974 } 975 } else if (path[0] == '/' || path[0] == '\\') { 976 /* Rooted, but maybe on different drive. */ 977 if (isALPHA(dir[0]) && dir[1] == ':' ) { 978 char p1[MAXPATHLEN]; 979 980 /* Need to prepend the drive. */ 981 p1[0] = dir[0]; 982 p1[1] = dir[1]; 983 Copy(path, p1 + 2, strlen(path) + 1, char); 984 RETVAL = p; 985 if (_abspath(p, p1, MAXPATHLEN) == 0) { 986 RETVAL = p; 987 } else { 988 RETVAL = NULL; 989 } 990 } else if (_abspath(p, path, MAXPATHLEN) == 0) { 991 RETVAL = p; 992 } else { 993 RETVAL = NULL; 994 } 995 } else { 996 /* Either path is relative, or starts with a drive letter. */ 997 /* If the path starts with a drive letter, then dir is 998 relevant only if 999 a/b) it is absolute/x:relative on the same drive. 1000 c) path is on current drive, and dir is rooted 1001 In all the cases it is safe to drop the drive part 1002 of the path. */ 1003 if ( !sys_is_relative(path) ) { 1004 int is_drived; 1005 1006 if ( ( ( sys_is_absolute(dir) 1007 || (isALPHA(dir[0]) && dir[1] == ':' 1008 && strnicmp(dir, path,1) == 0)) 1009 && strnicmp(dir, path,1) == 0) 1010 || ( !(isALPHA(dir[0]) && dir[1] == ':') 1011 && toupper(path[0]) == current_drive())) { 1012 path += 2; 1013 } else if (_abspath(p, path, MAXPATHLEN) == 0) { 1014 RETVAL = p; goto done; 1015 } else { 1016 RETVAL = NULL; goto done; 1017 } 1018 } 1019 { 1020 /* Need to prepend the absolute path of dir. */ 1021 char p1[MAXPATHLEN]; 1022 1023 if (_abspath(p1, dir, MAXPATHLEN) == 0) { 1024 int l = strlen(p1); 1025 1026 if (p1[ l - 1 ] != '/') { 1027 p1[ l ] = '/'; 1028 l++; 1029 } 1030 Copy(path, p1 + l, strlen(path) + 1, char); 1031 if (_abspath(p, p1, MAXPATHLEN) == 0) { 1032 RETVAL = p; 1033 } else { 1034 RETVAL = NULL; 1035 } 1036 } else { 1037 RETVAL = NULL; 1038 } 1039 } 1040 done: 1041 } 1042 } 1043 ST(0) = sv_newmortal(); 1044 sv_setpv((SV*)ST(0), RETVAL); 1045 } 1046 XSRETURN(1); 1047 } 1048 typedef APIRET (*PELP)(PSZ path, ULONG type); 1049 1050 APIRET 1051 ExtLIBPATH(ULONG ord, PSZ path, ULONG type) 1052 { 1053 loadByOrd(ord); /* Guarantied to load or die! */ 1054 return (*(PELP)ExtFCN[ord])(path, type); 1055 } 1056 1057 #define extLibpath(type) \ 1058 (CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, to, ((type) ? END_LIBPATH \ 1059 : BEGIN_LIBPATH))) \ 1060 ? NULL : to ) 1061 1062 #define extLibpath_set(p,type) \ 1063 (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), ((type) ? END_LIBPATH \ 1064 : BEGIN_LIBPATH)))) 1065 1066 XS(XS_Cwd_extLibpath) 1067 { 1068 dXSARGS; 1069 if (items < 0 || items > 1) 1070 croak("Usage: Cwd::extLibpath(type = 0)"); 1071 { 1072 bool type; 1073 char to[1024]; 1074 U32 rc; 1075 char * RETVAL; 1076 1077 if (items < 1) 1078 type = 0; 1079 else { 1080 type = (int)SvIV(ST(0)); 1081 } 1082 1083 RETVAL = extLibpath(type); 1084 ST(0) = sv_newmortal(); 1085 sv_setpv((SV*)ST(0), RETVAL); 1086 } 1087 XSRETURN(1); 1088 } 1089 1090 XS(XS_Cwd_extLibpath_set) 1091 { 1092 dXSARGS; 1093 if (items < 1 || items > 2) 1094 croak("Usage: Cwd::extLibpath_set(s, type = 0)"); 1095 { 1096 char * s = (char *)SvPV(ST(0),na); 1097 bool type; 1098 U32 rc; 1099 bool RETVAL; 1100 1101 if (items < 2) 1102 type = 0; 1103 else { 1104 type = (int)SvIV(ST(1)); 1105 } 1106 1107 RETVAL = extLibpath_set(s, type); 1108 ST(0) = boolSV(RETVAL); 1109 if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); 1110 } 1111 XSRETURN(1); 1112 } 1113 1114 int 1115 Xs_OS2_init() 1116 { 1117 char *file = __FILE__; 1118 { 1119 GV *gv; 1120 1121 if (_emx_env & 0x200) { /* OS/2 */ 1122 newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file); 1123 newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file); 1124 newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file); 1125 } 1126 newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file); 1127 newXS("Cwd::current_drive", XS_Cwd_current_drive, file); 1128 newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file); 1129 newXS("Cwd::change_drive", XS_Cwd_change_drive, file); 1130 newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file); 1131 newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file); 1132 newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file); 1133 newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file); 1134 newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file); 1135 gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV); 1136 GvMULTI_on(gv); 1137 #ifdef PERL_IS_AOUT 1138 sv_setiv(GvSV(gv), 1); 1139 #endif 1140 } 1141 } 1142 1143 OS2_Perl_data_t OS2_Perl_data; 1144 1145 void 1146 Perl_OS2_init(char **env) 1147 { 1148 char *shell; 1149 1150 settmppath(); 1151 OS2_Perl_data.xs_init = &Xs_OS2_init; 1152 if (environ == NULL) { 1153 environ = env; 1154 } 1155 if ( (shell = getenv("PERL_SH_DRIVE")) ) { 1156 New(1304, sh_path, strlen(SH_PATH) + 1, char); 1157 strcpy(sh_path, SH_PATH); 1158 sh_path[0] = shell[0]; 1159 } else if ( (shell = getenv("PERL_SH_DIR")) ) { 1160 int l = strlen(shell), i; 1161 if (shell[l-1] == '/' || shell[l-1] == '\\') { 1162 l--; 1163 } 1164 New(1304, sh_path, l + 8, char); 1165 strncpy(sh_path, shell, l); 1166 strcpy(sh_path + l, "/sh.exe"); 1167 for (i = 0; i < l; i++) { 1168 if (sh_path[i] == '\\') sh_path[i] = '/'; 1169 } 1170 } 1171 } 1172 1173 #undef tmpnam 1174 #undef tmpfile 1175 1176 char * 1177 my_tmpnam (char *str) 1178 { 1179 char *p = getenv("TMP"), *tpath; 1180 int len; 1181 1182 if (!p) p = getenv("TEMP"); 1183 tpath = tempnam(p, "pltmp"); 1184 if (str && tpath) { 1185 strcpy(str, tpath); 1186 return str; 1187 } 1188 return tpath; 1189 } 1190 1191 FILE * 1192 my_tmpfile () 1193 { 1194 struct stat s; 1195 1196 stat(".", &s); 1197 if (s.st_mode & S_IWOTH) { 1198 return tmpfile(); 1199 } 1200 return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but 1201 grants TMP. */ 1202 } 1203 1204 #undef flock 1205 1206 /* This code was contributed by Rocco Caputo. */ 1207 int 1208 my_flock(int handle, int op) 1209 { 1210 FILELOCK rNull, rFull; 1211 ULONG timeout, handle_type, flag_word; 1212 APIRET rc; 1213 int blocking, shared; 1214 static int use_my = -1; 1215 1216 if (use_my == -1) { 1217 char *s = getenv("USE_PERL_FLOCK"); 1218 if (s) 1219 use_my = atoi(s); 1220 else 1221 use_my = 1; 1222 } 1223 if (!(_emx_env & 0x200) || !use_my) 1224 return flock(handle, op); /* Delegate to EMX. */ 1225 1226 // is this a file? 1227 if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) || 1228 (handle_type & 0xFF)) 1229 { 1230 errno = EBADF; 1231 return -1; 1232 } 1233 // set lock/unlock ranges 1234 rNull.lOffset = rNull.lRange = rFull.lOffset = 0; 1235 rFull.lRange = 0x7FFFFFFF; 1236 // set timeout for blocking 1237 timeout = ((blocking = !(op & LOCK_NB))) ? 100 : 1; 1238 // shared or exclusive? 1239 shared = (op & LOCK_SH) ? 1 : 0; 1240 // do not block the unlock 1241 if (op & (LOCK_UN | LOCK_SH | LOCK_EX)) { 1242 rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared); 1243 switch (rc) { 1244 case 0: 1245 errno = 0; 1246 return 0; 1247 case ERROR_INVALID_HANDLE: 1248 errno = EBADF; 1249 return -1; 1250 case ERROR_SHARING_BUFFER_EXCEEDED: 1251 errno = ENOLCK; 1252 return -1; 1253 case ERROR_LOCK_VIOLATION: 1254 break; // not an error 1255 case ERROR_INVALID_PARAMETER: 1256 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED: 1257 case ERROR_READ_LOCKS_NOT_SUPPORTED: 1258 errno = EINVAL; 1259 return -1; 1260 case ERROR_INTERRUPT: 1261 errno = EINTR; 1262 return -1; 1263 default: 1264 errno = EINVAL; 1265 return -1; 1266 } 1267 } 1268 // lock may block 1269 if (op & (LOCK_SH | LOCK_EX)) { 1270 // for blocking operations 1271 for (;;) { 1272 rc = 1273 DosSetFileLocks( 1274 handle, 1275 &rNull, 1276 &rFull, 1277 timeout, 1278 shared 1279 ); 1280 switch (rc) { 1281 case 0: 1282 errno = 0; 1283 return 0; 1284 case ERROR_INVALID_HANDLE: 1285 errno = EBADF; 1286 return -1; 1287 case ERROR_SHARING_BUFFER_EXCEEDED: 1288 errno = ENOLCK; 1289 return -1; 1290 case ERROR_LOCK_VIOLATION: 1291 if (!blocking) { 1292 errno = EWOULDBLOCK; 1293 return -1; 1294 } 1295 break; 1296 case ERROR_INVALID_PARAMETER: 1297 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED: 1298 case ERROR_READ_LOCKS_NOT_SUPPORTED: 1299 errno = EINVAL; 1300 return -1; 1301 case ERROR_INTERRUPT: 1302 errno = EINTR; 1303 return -1; 1304 default: 1305 errno = EINVAL; 1306 return -1; 1307 } 1308 // give away timeslice 1309 DosSleep(1); 1310 } 1311 } 1312 1313 errno = 0; 1314 return 0; 1315 } 1316