| Commit | Line | Data |
|---|
| 4633a7c4 |
1 | #define INCL_DOS |
| 2 | #define INCL_NOPM |
| 7a2f0d5b |
3 | #define INCL_DOSFILEMGR |
| 760ac839 |
4 | #define INCL_DOSMEMMGR |
| 5 | #define INCL_DOSERRORS |
| 4633a7c4 |
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 | |
| 17 | #include "EXTERN.h" |
| 18 | #include "perl.h" |
| 19 | |
| 20 | /*****************************************************************************/ |
| 21 | /* priorities */ |
| 6f064249 |
22 | static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged, |
| 23 | self inverse. */ |
| 24 | #define QSS_INI_BUFFER 1024 |
| 4633a7c4 |
25 | |
| 6f064249 |
26 | PQTOPLEVEL |
| 27 | get_sysinfo(ULONG pid, ULONG flags) |
| 4633a7c4 |
28 | { |
| 6f064249 |
29 | char *pbuffer; |
| 30 | ULONG rc, buf_len = QSS_INI_BUFFER; |
| 31 | |
| 32 | New(1022, pbuffer, buf_len, char); |
| 33 | /* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */ |
| 34 | rc = QuerySysState(flags, pid, pbuffer, buf_len); |
| 35 | while (rc == ERROR_BUFFER_OVERFLOW) { |
| 36 | Renew(pbuffer, buf_len *= 2, char); |
| 37 | rc = QuerySysState(QSS_PROCESS, pid, pbuffer, buf_len); |
| 38 | } |
| 39 | if (rc) { |
| 40 | FillOSError(rc); |
| 41 | Safefree(pbuffer); |
| 42 | return 0; |
| 43 | } |
| 44 | return (PQTOPLEVEL)pbuffer; |
| 45 | } |
| 46 | |
| 47 | #define PRIO_ERR 0x1111 |
| 48 | |
| 49 | static ULONG |
| 50 | sys_prio(pid) |
| 51 | { |
| 52 | ULONG prio; |
| 53 | PQTOPLEVEL psi; |
| 54 | |
| 55 | psi = get_sysinfo(pid, QSS_PROCESS); |
| 56 | if (!psi) { |
| 57 | return PRIO_ERR; |
| 58 | } |
| 59 | if (pid != psi->procdata->pid) { |
| 60 | Safefree(psi); |
| 61 | croak("panic: wrong pid in sysinfo"); |
| 62 | } |
| 63 | prio = psi->procdata->threads->priority; |
| 64 | Safefree(psi); |
| 65 | return prio; |
| 66 | } |
| 67 | |
| 68 | int |
| 69 | setpriority(int which, int pid, int val) |
| 70 | { |
| 71 | ULONG rc, prio; |
| 72 | PQTOPLEVEL psi; |
| 73 | |
| 74 | prio = sys_prio(pid); |
| 75 | |
| 76 | if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) { |
| 77 | /* Do not change class. */ |
| 78 | return CheckOSError(DosSetPriority((pid < 0) |
| 79 | ? PRTYS_PROCESSTREE : PRTYS_PROCESS, |
| 80 | 0, |
| 81 | (32 - val) % 32 - (prio & 0xFF), |
| 82 | abs(pid))) |
| 83 | ? -1 : 0; |
| 84 | } else /* if ((32 - val) % 32 == (prio & 0xFF)) */ { |
| 85 | /* Documentation claims one can change both class and basevalue, |
| 86 | * but I find it wrong. */ |
| 87 | /* Change class, but since delta == 0 denotes absolute 0, correct. */ |
| 88 | if (CheckOSError(DosSetPriority((pid < 0) |
| 89 | ? PRTYS_PROCESSTREE : PRTYS_PROCESS, |
| 90 | priors[(32 - val) >> 5] + 1, |
| 91 | 0, |
| 92 | abs(pid)))) |
| 93 | return -1; |
| 94 | if ( ((32 - val) % 32) == 0 ) return 0; |
| 95 | return CheckOSError(DosSetPriority((pid < 0) |
| 96 | ? PRTYS_PROCESSTREE : PRTYS_PROCESS, |
| 97 | 0, |
| 98 | (32 - val) % 32, |
| 99 | abs(pid))) |
| 100 | ? -1 : 0; |
| 101 | } |
| 102 | /* else return CheckOSError(DosSetPriority((pid < 0) */ |
| 103 | /* ? PRTYS_PROCESSTREE : PRTYS_PROCESS, */ |
| 104 | /* priors[(32 - val) >> 5] + 1, */ |
| 105 | /* (32 - val) % 32 - (prio & 0xFF), */ |
| 106 | /* abs(pid))) */ |
| 107 | /* ? -1 : 0; */ |
| 4633a7c4 |
108 | } |
| 109 | |
| 6f064249 |
110 | int |
| 111 | getpriority(int which /* ignored */, int pid) |
| 4633a7c4 |
112 | { |
| 113 | TIB *tib; |
| 114 | PIB *pib; |
| 6f064249 |
115 | ULONG rc, ret; |
| 116 | |
| 117 | /* DosGetInfoBlocks has old priority! */ |
| 118 | /* if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) return -1; */ |
| 119 | /* if (pid != pib->pib_ulpid) { */ |
| 120 | ret = sys_prio(pid); |
| 121 | if (ret == PRIO_ERR) { |
| 122 | return -1; |
| 123 | } |
| 124 | /* } else */ |
| 125 | /* ret = tib->tib_ptib2->tib2_ulpri; */ |
| 126 | return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF); |
| 4633a7c4 |
127 | } |
| 128 | |
| 129 | /*****************************************************************************/ |
| 130 | /* spawn */ |
| 131 | |
| 132 | static int |
| 133 | result(int flag, int pid) |
| 134 | { |
| 135 | int r, status; |
| 136 | Signal_t (*ihand)(); /* place to save signal during system() */ |
| 137 | Signal_t (*qhand)(); /* place to save signal during system() */ |
| 760ac839 |
138 | #ifndef __EMX__ |
| 139 | RESULTCODES res; |
| 140 | int rpid; |
| 141 | #endif |
| 4633a7c4 |
142 | |
| 760ac839 |
143 | if (pid < 0 || flag != 0) |
| 4633a7c4 |
144 | return pid; |
| 145 | |
| 760ac839 |
146 | #ifdef __EMX__ |
| 4633a7c4 |
147 | ihand = signal(SIGINT, SIG_IGN); |
| 148 | qhand = signal(SIGQUIT, SIG_IGN); |
| c0c09dfd |
149 | do { |
| 150 | r = wait4pid(pid, &status, 0); |
| 151 | } while (r == -1 && errno == EINTR); |
| 4633a7c4 |
152 | signal(SIGINT, ihand); |
| 153 | signal(SIGQUIT, qhand); |
| 154 | |
| 155 | statusvalue = (U16)status; |
| 156 | if (r < 0) |
| 157 | return -1; |
| 158 | return status & 0xFFFF; |
| 760ac839 |
159 | #else |
| 160 | ihand = signal(SIGINT, SIG_IGN); |
| 161 | r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid); |
| 162 | signal(SIGINT, ihand); |
| 163 | statusvalue = res.codeResult << 8 | res.codeTerminate; |
| 164 | if (r) |
| 165 | return -1; |
| 166 | return statusvalue; |
| 167 | #endif |
| 4633a7c4 |
168 | } |
| 169 | |
| 170 | int |
| 171 | do_aspawn(really,mark,sp) |
| 172 | SV *really; |
| 173 | register SV **mark; |
| 174 | register SV **sp; |
| 175 | { |
| 176 | register char **a; |
| 177 | char *tmps; |
| 178 | int rc; |
| 179 | int flag = P_WAIT, trueflag; |
| 180 | |
| 181 | if (sp > mark) { |
| 182 | New(401,Argv, sp - mark + 1, char*); |
| 183 | a = Argv; |
| 184 | |
| 760ac839 |
185 | if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) { |
| 4633a7c4 |
186 | ++mark; |
| 187 | flag = SvIVx(*mark); |
| 188 | } |
| 189 | |
| 190 | while (++mark <= sp) { |
| 191 | if (*mark) |
| 192 | *a++ = SvPVx(*mark, na); |
| 193 | else |
| 194 | *a++ = ""; |
| 195 | } |
| 196 | *a = Nullch; |
| 197 | |
| 198 | trueflag = flag; |
| 199 | if (flag == P_WAIT) |
| 200 | flag = P_NOWAIT; |
| 201 | |
| 3bbf9c2b |
202 | if (strEQ(Argv[0],"/bin/sh")) Argv[0] = SH_PATH; |
| 203 | |
| 204 | if (Argv[0][0] != '/' && Argv[0][0] != '\\' |
| 205 | && !(Argv[0][0] && Argv[0][1] == ':' |
| 206 | && (Argv[0][2] == '/' || Argv[0][2] != '\\')) |
| 760ac839 |
207 | ) /* will swawnvp use PATH? */ |
| c0c09dfd |
208 | TAINT_ENV(); /* testing IFS here is overkill, probably */ |
| 760ac839 |
209 | /* We should check PERL_SH* and PERLLIB_* as well? */ |
| 4633a7c4 |
210 | if (really && *(tmps = SvPV(really, na))) |
| 211 | rc = result(trueflag, spawnvp(flag,tmps,Argv)); |
| 212 | else |
| 213 | rc = result(trueflag, spawnvp(flag,Argv[0],Argv)); |
| 214 | |
| 215 | if (rc < 0 && dowarn) |
| 216 | warn("Can't spawn \"%s\": %s", Argv[0], Strerror(errno)); |
| c0c09dfd |
217 | if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */ |
| 4633a7c4 |
218 | } else |
| 219 | rc = -1; |
| 220 | do_execfree(); |
| 221 | return rc; |
| 222 | } |
| 223 | |
| 760ac839 |
224 | #define EXECF_SPAWN 0 |
| 225 | #define EXECF_EXEC 1 |
| 226 | #define EXECF_TRUEEXEC 2 |
| 227 | |
| 4633a7c4 |
228 | int |
| 760ac839 |
229 | do_spawn2(cmd, execf) |
| 4633a7c4 |
230 | char *cmd; |
| 760ac839 |
231 | int execf; |
| 4633a7c4 |
232 | { |
| 233 | register char **a; |
| 234 | register char *s; |
| 235 | char flags[10]; |
| 3bbf9c2b |
236 | char *shell, *copt, *news = NULL; |
| 4633a7c4 |
237 | int rc; |
| 238 | |
| c0c09dfd |
239 | #ifdef TRYSHELL |
| 240 | if ((shell = getenv("EMXSHELL")) != NULL) |
| 241 | copt = "-c"; |
| 242 | else if ((shell = getenv("SHELL")) != NULL) |
| 4633a7c4 |
243 | copt = "-c"; |
| 244 | else if ((shell = getenv("COMSPEC")) != NULL) |
| 245 | copt = "/C"; |
| 246 | else |
| 247 | shell = "cmd.exe"; |
| c0c09dfd |
248 | #else |
| 249 | /* Consensus on perl5-porters is that it is _very_ important to |
| 250 | have a shell which will not change between computers with the |
| 251 | same architecture, to avoid "action on a distance". |
| 252 | And to have simple build, this shell should be sh. */ |
| 6f064249 |
253 | shell = SH_PATH; |
| c0c09dfd |
254 | copt = "-c"; |
| 255 | #endif |
| 256 | |
| 257 | while (*cmd && isSPACE(*cmd)) |
| 258 | cmd++; |
| 4633a7c4 |
259 | |
| 3bbf9c2b |
260 | if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) { |
| 261 | STRLEN l = strlen(SH_PATH); |
| 262 | |
| 263 | New(4545, news, strlen(cmd) - 7 + l, char); |
| 264 | strcpy(news, SH_PATH); |
| 265 | strcpy(news + l, cmd + 7); |
| 266 | cmd = news; |
| 267 | } |
| 268 | |
| 4633a7c4 |
269 | /* save an extra exec if possible */ |
| 270 | /* see if there are shell metacharacters in it */ |
| 271 | |
| c0c09dfd |
272 | if (*cmd == '.' && isSPACE(cmd[1])) |
| 273 | goto doshell; |
| 274 | |
| 275 | if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4])) |
| 276 | goto doshell; |
| 277 | |
| 278 | for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */ |
| 279 | if (*s == '=') |
| 280 | goto doshell; |
| 281 | |
| 4633a7c4 |
282 | for (s = cmd; *s; s++) { |
| c0c09dfd |
283 | if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) { |
| 3bbf9c2b |
284 | if (*s == '\n' && s[1] == '\0') { |
| 4633a7c4 |
285 | *s = '\0'; |
| 286 | break; |
| 287 | } |
| c0c09dfd |
288 | doshell: |
| 760ac839 |
289 | if (execf == EXECF_TRUEEXEC) |
| 290 | return execl(shell,shell,copt,cmd,(char*)0); |
| 291 | else if (execf == EXECF_EXEC) |
| 292 | return spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0); |
| 293 | /* In the ak code internal P_NOWAIT is P_WAIT ??? */ |
| c0c09dfd |
294 | rc = result(P_WAIT, |
| 760ac839 |
295 | spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0)); |
| c0c09dfd |
296 | if (rc < 0 && dowarn) |
| 760ac839 |
297 | warn("Can't %s \"%s\": %s", |
| 298 | (execf == EXECF_SPAWN ? "spawn" : "exec"), |
| 299 | shell, Strerror(errno)); |
| c0c09dfd |
300 | if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */ |
| 3bbf9c2b |
301 | if (news) Safefree(news); |
| c0c09dfd |
302 | return rc; |
| 4633a7c4 |
303 | } |
| 304 | } |
| c0c09dfd |
305 | |
| 4633a7c4 |
306 | New(402,Argv, (s - cmd) / 2 + 2, char*); |
| 307 | Cmd = savepvn(cmd, s-cmd); |
| 308 | a = Argv; |
| 309 | for (s = Cmd; *s;) { |
| 310 | while (*s && isSPACE(*s)) s++; |
| 311 | if (*s) |
| 312 | *(a++) = s; |
| 313 | while (*s && !isSPACE(*s)) s++; |
| 314 | if (*s) |
| 315 | *s++ = '\0'; |
| 316 | } |
| 317 | *a = Nullch; |
| 318 | if (Argv[0]) { |
| 760ac839 |
319 | if (execf == EXECF_TRUEEXEC) |
| 320 | rc = execvp(Argv[0],Argv); |
| 321 | else if (execf == EXECF_EXEC) |
| 322 | rc = spawnvp(P_OVERLAY,Argv[0],Argv); |
| 323 | else |
| 324 | rc = result(P_WAIT, spawnvp(P_NOWAIT,Argv[0],Argv)); |
| 4633a7c4 |
325 | if (rc < 0 && dowarn) |
| 760ac839 |
326 | warn("Can't %s \"%s\": %s", |
| 327 | (execf == EXECF_SPAWN ? "spawn" : "exec"), |
| 328 | Argv[0], Strerror(errno)); |
| c0c09dfd |
329 | if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */ |
| 4633a7c4 |
330 | } else |
| 331 | rc = -1; |
| 3bbf9c2b |
332 | if (news) Safefree(news); |
| 4633a7c4 |
333 | do_execfree(); |
| 334 | return rc; |
| 335 | } |
| 336 | |
| 760ac839 |
337 | int |
| 338 | do_spawn(cmd) |
| 339 | char *cmd; |
| 340 | { |
| 341 | return do_spawn2(cmd, EXECF_SPAWN); |
| 342 | } |
| 343 | |
| 344 | bool |
| 345 | do_exec(cmd) |
| 346 | char *cmd; |
| 347 | { |
| 348 | return do_spawn2(cmd, EXECF_EXEC); |
| 349 | } |
| 350 | |
| 351 | bool |
| 352 | os2exec(cmd) |
| 353 | char *cmd; |
| 354 | { |
| 355 | return do_spawn2(cmd, EXECF_TRUEEXEC); |
| 356 | } |
| 357 | |
| 3bbf9c2b |
358 | PerlIO * |
| 359 | my_syspopen(cmd,mode) |
| c0c09dfd |
360 | char *cmd; |
| 361 | char *mode; |
| 362 | { |
| 3bbf9c2b |
363 | PerlIO *res; |
| 364 | SV *sv; |
| 365 | |
| 760ac839 |
366 | #ifdef TRYSHELL |
| 3bbf9c2b |
367 | res = popen(cmd, mode); |
| 760ac839 |
368 | #else |
| c0c09dfd |
369 | char *shell = getenv("EMXSHELL"); |
| 3bbf9c2b |
370 | |
| 6f064249 |
371 | my_setenv("EMXSHELL", SH_PATH); |
| c0c09dfd |
372 | res = popen(cmd, mode); |
| 373 | my_setenv("EMXSHELL", shell); |
| 760ac839 |
374 | #endif |
| 3bbf9c2b |
375 | sv = *av_fetch(fdpid, PerlIO_fileno(res), TRUE); |
| 376 | (void)SvUPGRADE(sv,SVt_IV); |
| 377 | SvIVX(sv) = -1; /* A cooky. */ |
| 378 | return res; |
| c0c09dfd |
379 | } |
| 380 | |
| 3bbf9c2b |
381 | /******************************************************************/ |
| 4633a7c4 |
382 | |
| 383 | #ifndef HAS_FORK |
| 384 | int |
| 385 | fork(void) |
| 386 | { |
| 387 | die(no_func, "Unsupported function fork"); |
| 388 | errno = EINVAL; |
| 389 | return -1; |
| 390 | } |
| 391 | #endif |
| 392 | |
| 3bbf9c2b |
393 | /*******************************************************************/ |
| 4633a7c4 |
394 | /* not implemented in EMX 0.9a */ |
| 395 | |
| 396 | void * ctermid(x) { return 0; } |
| eacfb5f1 |
397 | |
| 398 | #ifdef MYTTYNAME /* was not in emx0.9a */ |
| 4633a7c4 |
399 | void * ttyname(x) { return 0; } |
| eacfb5f1 |
400 | #endif |
| 4633a7c4 |
401 | |
| 3bbf9c2b |
402 | /******************************************************************/ |
| 760ac839 |
403 | /* my socket forwarders - EMX lib only provides static forwarders */ |
| 404 | |
| 405 | static HMODULE htcp = 0; |
| 406 | |
| 407 | static void * |
| 408 | tcp0(char *name) |
| 409 | { |
| 410 | static BYTE buf[20]; |
| 411 | PFN fcn; |
| 412 | if (!htcp) |
| 413 | DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp); |
| 414 | if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0) |
| 415 | return (void *) ((void * (*)(void)) fcn) (); |
| 416 | return 0; |
| 417 | } |
| 418 | |
| 419 | static void |
| 420 | tcp1(char *name, int arg) |
| 421 | { |
| 422 | static BYTE buf[20]; |
| 423 | PFN fcn; |
| 424 | if (!htcp) |
| 425 | DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp); |
| 426 | if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0) |
| 427 | ((void (*)(int)) fcn) (arg); |
| 428 | } |
| 429 | |
| 430 | void * gethostent() { return tcp0("GETHOSTENT"); } |
| 431 | void * getnetent() { return tcp0("GETNETENT"); } |
| 432 | void * getprotoent() { return tcp0("GETPROTOENT"); } |
| 433 | void * getservent() { return tcp0("GETSERVENT"); } |
| 434 | void sethostent(x) { tcp1("SETHOSTENT", x); } |
| 435 | void setnetent(x) { tcp1("SETNETENT", x); } |
| 436 | void setprotoent(x) { tcp1("SETPROTOENT", x); } |
| 437 | void setservent(x) { tcp1("SETSERVENT", x); } |
| 438 | void endhostent() { tcp0("ENDHOSTENT"); } |
| 439 | void endnetent() { tcp0("ENDNETENT"); } |
| 440 | void endprotoent() { tcp0("ENDPROTOENT"); } |
| 441 | void endservent() { tcp0("ENDSERVENT"); } |
| 442 | |
| 443 | /*****************************************************************************/ |
| 444 | /* not implemented in C Set++ */ |
| 445 | |
| 446 | #ifndef __EMX__ |
| 447 | int setuid(x) { errno = EINVAL; return -1; } |
| 448 | int setgid(x) { errno = EINVAL; return -1; } |
| 449 | #endif |
| 4633a7c4 |
450 | |
| 451 | /*****************************************************************************/ |
| 452 | /* stat() hack for char/block device */ |
| 453 | |
| 454 | #if OS2_STAT_HACK |
| 455 | |
| 456 | /* First attempt used DosQueryFSAttach which crashed the system when |
| 457 | used with 5.001. Now just look for /dev/. */ |
| 458 | |
| 459 | int |
| 460 | os2_stat(char *name, struct stat *st) |
| 461 | { |
| 462 | static int ino = SHRT_MAX; |
| 463 | |
| 464 | if (stricmp(name, "/dev/con") != 0 |
| 465 | && stricmp(name, "/dev/tty") != 0) |
| 466 | return stat(name, st); |
| 467 | |
| 468 | memset(st, 0, sizeof *st); |
| 469 | st->st_mode = S_IFCHR|0666; |
| 470 | st->st_ino = (ino-- & 0x7FFF); |
| 471 | st->st_nlink = 1; |
| 472 | return 0; |
| 473 | } |
| 474 | |
| 475 | #endif |
| c0c09dfd |
476 | |
| 760ac839 |
477 | #ifdef USE_PERL_SBRK |
| c0c09dfd |
478 | |
| 760ac839 |
479 | /* SBRK() emulation, mostly moved to malloc.c. */ |
| c0c09dfd |
480 | |
| 481 | void * |
| 760ac839 |
482 | sys_alloc(int size) { |
| 483 | void *got; |
| 484 | APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE); |
| 485 | |
| c0c09dfd |
486 | if (rc == ERROR_NOT_ENOUGH_MEMORY) { |
| 487 | return (void *) -1; |
| 488 | } else if ( rc ) die("Got an error from DosAllocMem: %li", (long)rc); |
| 760ac839 |
489 | return got; |
| c0c09dfd |
490 | } |
| 760ac839 |
491 | |
| 492 | #endif /* USE_PERL_SBRK */ |
| c0c09dfd |
493 | |
| 494 | /* tmp path */ |
| 495 | |
| 496 | char *tmppath = TMPPATH1; |
| 497 | |
| 498 | void |
| 499 | settmppath() |
| 500 | { |
| 501 | char *p = getenv("TMP"), *tpath; |
| 502 | int len; |
| 503 | |
| 504 | if (!p) p = getenv("TEMP"); |
| 505 | if (!p) return; |
| 506 | len = strlen(p); |
| 507 | tpath = (char *)malloc(len + strlen(TMPPATH1) + 2); |
| 508 | strcpy(tpath, p); |
| 509 | tpath[len] = '/'; |
| 510 | strcpy(tpath + len + 1, TMPPATH1); |
| 511 | tmppath = tpath; |
| 512 | } |
| 7a2f0d5b |
513 | |
| 514 | #include "XSUB.h" |
| 515 | |
| 516 | XS(XS_File__Copy_syscopy) |
| 517 | { |
| 518 | dXSARGS; |
| 519 | if (items < 2 || items > 3) |
| 520 | croak("Usage: File::Copy::syscopy(src,dst,flag=0)"); |
| 521 | { |
| 522 | char * src = (char *)SvPV(ST(0),na); |
| 523 | char * dst = (char *)SvPV(ST(1),na); |
| 524 | U32 flag; |
| 525 | int RETVAL, rc; |
| 526 | |
| 527 | if (items < 3) |
| 528 | flag = 0; |
| 529 | else { |
| 530 | flag = (unsigned long)SvIV(ST(2)); |
| 531 | } |
| 532 | |
| 6f064249 |
533 | RETVAL = !CheckOSError(DosCopy(src, dst, flag)); |
| 7a2f0d5b |
534 | ST(0) = sv_newmortal(); |
| 535 | sv_setiv(ST(0), (IV)RETVAL); |
| 536 | } |
| 537 | XSRETURN(1); |
| 538 | } |
| 539 | |
| 6f064249 |
540 | char * |
| 541 | mod2fname(sv) |
| 542 | SV *sv; |
| 543 | { |
| 544 | static char fname[9]; |
| 760ac839 |
545 | int pos = 6, len, avlen; |
| 546 | unsigned int sum = 0; |
| 6f064249 |
547 | AV *av; |
| 548 | SV *svp; |
| 549 | char *s; |
| 550 | |
| 551 | if (!SvROK(sv)) croak("Not a reference given to mod2fname"); |
| 552 | sv = SvRV(sv); |
| 553 | if (SvTYPE(sv) != SVt_PVAV) |
| 554 | croak("Not array reference given to mod2fname"); |
| 760ac839 |
555 | |
| 556 | avlen = av_len((AV*)sv); |
| 557 | if (avlen < 0) |
| 6f064249 |
558 | croak("Empty array reference given to mod2fname"); |
| 760ac839 |
559 | |
| 560 | s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), na); |
| 6f064249 |
561 | strncpy(fname, s, 8); |
| 760ac839 |
562 | len = strlen(s); |
| 563 | if (len < 6) pos = len; |
| 564 | while (*s) { |
| 565 | sum = 33 * sum + *(s++); /* Checksumming first chars to |
| 566 | * get the capitalization into c.s. */ |
| 567 | } |
| 568 | avlen --; |
| 569 | while (avlen >= 0) { |
| 570 | s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), na); |
| 571 | while (*s) { |
| 572 | sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */ |
| 573 | } |
| 574 | avlen --; |
| 575 | } |
| 576 | fname[pos] = 'A' + (sum % 26); |
| 577 | fname[pos + 1] = 'A' + (sum / 26 % 26); |
| 578 | fname[pos + 2] = '\0'; |
| 6f064249 |
579 | return (char *)fname; |
| 580 | } |
| 581 | |
| 582 | XS(XS_DynaLoader_mod2fname) |
| 583 | { |
| 584 | dXSARGS; |
| 585 | if (items != 1) |
| 586 | croak("Usage: DynaLoader::mod2fname(sv)"); |
| 587 | { |
| 588 | SV * sv = ST(0); |
| 589 | char * RETVAL; |
| 590 | |
| 591 | RETVAL = mod2fname(sv); |
| 592 | ST(0) = sv_newmortal(); |
| 593 | sv_setpv((SV*)ST(0), RETVAL); |
| 594 | } |
| 595 | XSRETURN(1); |
| 596 | } |
| 597 | |
| 598 | char * |
| 599 | os2error(int rc) |
| 600 | { |
| 601 | static char buf[300]; |
| 602 | ULONG len; |
| 603 | |
| 604 | if (rc == 0) |
| 605 | return NULL; |
| 606 | if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len)) |
| 607 | sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc); |
| 608 | else |
| 609 | buf[len] = '\0'; |
| 610 | return buf; |
| 611 | } |
| 612 | |
| 89078e0f |
613 | char sh_path[STATIC_FILE_LENGTH+1] = SH_PATH_INI; |
| 760ac839 |
614 | |
| 615 | char * |
| 616 | perllib_mangle(char *s, unsigned int l) |
| 617 | { |
| 618 | static char *newp, *oldp; |
| 619 | static int newl, oldl, notfound; |
| 620 | static char ret[STATIC_FILE_LENGTH+1]; |
| 621 | |
| 622 | if (!newp && !notfound) { |
| 623 | newp = getenv("PERLLIB_PREFIX"); |
| 624 | if (newp) { |
| 625 | oldp = newp; |
| 89078e0f |
626 | while (*newp && !isSPACE(*newp) && *newp != ';') { |
| 760ac839 |
627 | newp++; oldl++; /* Skip digits. */ |
| 628 | } |
| 629 | while (*newp && (isSPACE(*newp) || *newp == ';')) { |
| 630 | newp++; /* Skip whitespace. */ |
| 631 | } |
| 632 | newl = strlen(newp); |
| 633 | if (newl == 0 || oldl == 0) { |
| 634 | die("Malformed PERLLIB_PREFIX"); |
| 635 | } |
| 636 | } else { |
| 637 | notfound = 1; |
| 638 | } |
| 639 | } |
| 640 | if (!newp) { |
| 641 | return s; |
| 642 | } |
| 643 | if (l == 0) { |
| 644 | l = strlen(s); |
| 645 | } |
| 3bbf9c2b |
646 | if (l < oldl || strnicmp(oldp, s, oldl) != 0) { |
| 760ac839 |
647 | return s; |
| 648 | } |
| 649 | if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) { |
| 650 | die("Malformed PERLLIB_PREFIX"); |
| 651 | } |
| 652 | strncpy(ret, newp, newl); |
| 89078e0f |
653 | strcpy(ret + newl, s + oldl); |
| 760ac839 |
654 | return ret; |
| 655 | } |
| 6f064249 |
656 | |
| 657 | extern void dlopen(); |
| 658 | void *fakedl = &dlopen; /* Pull in dynaloading part. */ |
| 3bbf9c2b |
659 | |
| 660 | #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \ |
| 661 | && ((path)[2] == '/' || (path)[2] == '\\')) |
| 662 | #define sys_is_rooted _fnisabs |
| 663 | #define sys_is_relative _fnisrel |
| 664 | #define current_drive _getdrive |
| 665 | |
| 666 | #undef chdir /* Was _chdir2. */ |
| 667 | #define sys_chdir(p) (chdir(p) == 0) |
| 668 | #define change_drive(d) (_chdrive(d), (current_drive() == toupper(d))) |
| 669 | |
| 670 | XS(XS_Cwd_current_drive) |
| 671 | { |
| 672 | dXSARGS; |
| 673 | if (items != 0) |
| 674 | croak("Usage: Cwd::current_drive()"); |
| 675 | { |
| 676 | char RETVAL; |
| 677 | |
| 678 | RETVAL = current_drive(); |
| 679 | ST(0) = sv_newmortal(); |
| 680 | sv_setpvn(ST(0), (char *)&RETVAL, 1); |
| 681 | } |
| 682 | XSRETURN(1); |
| 683 | } |
| 684 | |
| 685 | XS(XS_Cwd_sys_chdir) |
| 686 | { |
| 687 | dXSARGS; |
| 688 | if (items != 1) |
| 689 | croak("Usage: Cwd::sys_chdir(path)"); |
| 690 | { |
| 691 | char * path = (char *)SvPV(ST(0),na); |
| 692 | bool RETVAL; |
| 693 | |
| 694 | RETVAL = sys_chdir(path); |
| 695 | ST(0) = RETVAL ? &sv_yes : &sv_no; |
| 696 | if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); |
| 697 | } |
| 698 | XSRETURN(1); |
| 699 | } |
| 700 | |
| 701 | XS(XS_Cwd_change_drive) |
| 702 | { |
| 703 | dXSARGS; |
| 704 | if (items != 1) |
| 705 | croak("Usage: Cwd::change_drive(d)"); |
| 706 | { |
| 707 | char d = (char)*SvPV(ST(0),na); |
| 708 | bool RETVAL; |
| 709 | |
| 710 | RETVAL = change_drive(d); |
| 711 | ST(0) = RETVAL ? &sv_yes : &sv_no; |
| 712 | if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); |
| 713 | } |
| 714 | XSRETURN(1); |
| 715 | } |
| 716 | |
| 717 | XS(XS_Cwd_sys_is_absolute) |
| 718 | { |
| 719 | dXSARGS; |
| 720 | if (items != 1) |
| 721 | croak("Usage: Cwd::sys_is_absolute(path)"); |
| 722 | { |
| 723 | char * path = (char *)SvPV(ST(0),na); |
| 724 | bool RETVAL; |
| 725 | |
| 726 | RETVAL = sys_is_absolute(path); |
| 727 | ST(0) = RETVAL ? &sv_yes : &sv_no; |
| 728 | if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); |
| 729 | } |
| 730 | XSRETURN(1); |
| 731 | } |
| 732 | |
| 733 | XS(XS_Cwd_sys_is_rooted) |
| 734 | { |
| 735 | dXSARGS; |
| 736 | if (items != 1) |
| 737 | croak("Usage: Cwd::sys_is_rooted(path)"); |
| 738 | { |
| 739 | char * path = (char *)SvPV(ST(0),na); |
| 740 | bool RETVAL; |
| 741 | |
| 742 | RETVAL = sys_is_rooted(path); |
| 743 | ST(0) = RETVAL ? &sv_yes : &sv_no; |
| 744 | if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); |
| 745 | } |
| 746 | XSRETURN(1); |
| 747 | } |
| 748 | |
| 749 | XS(XS_Cwd_sys_is_relative) |
| 750 | { |
| 751 | dXSARGS; |
| 752 | if (items != 1) |
| 753 | croak("Usage: Cwd::sys_is_relative(path)"); |
| 754 | { |
| 755 | char * path = (char *)SvPV(ST(0),na); |
| 756 | bool RETVAL; |
| 757 | |
| 758 | RETVAL = sys_is_relative(path); |
| 759 | ST(0) = RETVAL ? &sv_yes : &sv_no; |
| 760 | if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); |
| 761 | } |
| 762 | XSRETURN(1); |
| 763 | } |
| 764 | |
| 765 | XS(XS_Cwd_sys_cwd) |
| 766 | { |
| 767 | dXSARGS; |
| 768 | if (items != 0) |
| 769 | croak("Usage: Cwd::sys_cwd()"); |
| 770 | { |
| 771 | char p[MAXPATHLEN]; |
| 772 | char * RETVAL; |
| 773 | RETVAL = _getcwd2(p, MAXPATHLEN); |
| 774 | ST(0) = sv_newmortal(); |
| 775 | sv_setpv((SV*)ST(0), RETVAL); |
| 776 | } |
| 777 | XSRETURN(1); |
| 778 | } |
| 779 | |
| 780 | XS(XS_Cwd_sys_abspath) |
| 781 | { |
| 782 | dXSARGS; |
| 783 | if (items < 1 || items > 2) |
| 784 | croak("Usage: Cwd::sys_abspath(path, dir = NULL)"); |
| 785 | { |
| 786 | char * path = (char *)SvPV(ST(0),na); |
| 787 | char * dir; |
| 788 | char p[MAXPATHLEN]; |
| 789 | char * RETVAL; |
| 790 | |
| 791 | if (items < 2) |
| 792 | dir = NULL; |
| 793 | else { |
| 794 | dir = (char *)SvPV(ST(1),na); |
| 795 | } |
| 796 | if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) { |
| 797 | path += 2; |
| 798 | } |
| 799 | if (dir == NULL) { |
| 800 | if (_abspath(p, path, MAXPATHLEN) == 0) { |
| 801 | RETVAL = p; |
| 802 | } else { |
| 803 | RETVAL = NULL; |
| 804 | } |
| 805 | } else { |
| 806 | /* Absolute with drive: */ |
| 807 | if ( sys_is_absolute(path) ) { |
| 808 | if (_abspath(p, path, MAXPATHLEN) == 0) { |
| 809 | RETVAL = p; |
| 810 | } else { |
| 811 | RETVAL = NULL; |
| 812 | } |
| 813 | } else if (path[0] == '/' || path[0] == '\\') { |
| 814 | /* Rooted, but maybe on different drive. */ |
| 815 | if (isALPHA(dir[0]) && dir[1] == ':' ) { |
| 816 | char p1[MAXPATHLEN]; |
| 817 | |
| 818 | /* Need to prepend the drive. */ |
| 819 | p1[0] = dir[0]; |
| 820 | p1[1] = dir[1]; |
| 821 | Copy(path, p1 + 2, strlen(path) + 1, char); |
| 822 | RETVAL = p; |
| 823 | if (_abspath(p, p1, MAXPATHLEN) == 0) { |
| 824 | RETVAL = p; |
| 825 | } else { |
| 826 | RETVAL = NULL; |
| 827 | } |
| 828 | } else if (_abspath(p, path, MAXPATHLEN) == 0) { |
| 829 | RETVAL = p; |
| 830 | } else { |
| 831 | RETVAL = NULL; |
| 832 | } |
| 833 | } else { |
| 834 | /* Either path is relative, or starts with a drive letter. */ |
| 835 | /* If the path starts with a drive letter, then dir is |
| 836 | relevant only if |
| 837 | a/b) it is absolute/x:relative on the same drive. |
| 838 | c) path is on current drive, and dir is rooted |
| 839 | In all the cases it is safe to drop the drive part |
| 840 | of the path. */ |
| 841 | if ( !sys_is_relative(path) ) { |
| 842 | int is_drived; |
| 843 | |
| 844 | if ( ( ( sys_is_absolute(dir) |
| 845 | || (isALPHA(dir[0]) && dir[1] == ':' |
| 846 | && strnicmp(dir, path,1) == 0)) |
| 847 | && strnicmp(dir, path,1) == 0) |
| 848 | || ( !(isALPHA(dir[0]) && dir[1] == ':') |
| 849 | && toupper(path[0]) == current_drive())) { |
| 850 | path += 2; |
| 851 | } else if (_abspath(p, path, MAXPATHLEN) == 0) { |
| 852 | RETVAL = p; goto done; |
| 853 | } else { |
| 854 | RETVAL = NULL; goto done; |
| 855 | } |
| 856 | } |
| 857 | { |
| 858 | /* Need to prepend the absolute path of dir. */ |
| 859 | char p1[MAXPATHLEN]; |
| 860 | |
| 861 | if (_abspath(p1, dir, MAXPATHLEN) == 0) { |
| 862 | int l = strlen(p1); |
| 863 | |
| 864 | if (p1[ l - 1 ] != '/') { |
| 865 | p1[ l ] = '/'; |
| 866 | l++; |
| 867 | } |
| 868 | Copy(path, p1 + l, strlen(path) + 1, char); |
| 869 | if (_abspath(p, p1, MAXPATHLEN) == 0) { |
| 870 | RETVAL = p; |
| 871 | } else { |
| 872 | RETVAL = NULL; |
| 873 | } |
| 874 | } else { |
| 875 | RETVAL = NULL; |
| 876 | } |
| 877 | } |
| 878 | done: |
| 879 | } |
| 880 | } |
| 881 | ST(0) = sv_newmortal(); |
| 882 | sv_setpv((SV*)ST(0), RETVAL); |
| 883 | } |
| 884 | XSRETURN(1); |
| 885 | } |
| 886 | |
| 887 | #define extLibpath(type) \ |
| 888 | (CheckOSError(DosQueryExtLIBPATH(to, ((type) ? END_LIBPATH \ |
| 889 | : BEGIN_LIBPATH))) \ |
| 890 | ? NULL : to ) |
| 891 | |
| 892 | #define extLibpath_set(p,type) \ |
| 893 | (!CheckOSError(DosSetExtLIBPATH((p), ((type) ? END_LIBPATH \ |
| 894 | : BEGIN_LIBPATH)))) |
| 895 | |
| 896 | XS(XS_Cwd_extLibpath) |
| 897 | { |
| 898 | dXSARGS; |
| 899 | if (items < 0 || items > 1) |
| 900 | croak("Usage: Cwd::extLibpath(type = 0)"); |
| 901 | { |
| 902 | bool type; |
| 903 | char to[1024]; |
| 904 | U32 rc; |
| 905 | char * RETVAL; |
| 906 | |
| 907 | if (items < 1) |
| 908 | type = 0; |
| 909 | else { |
| 910 | type = (int)SvIV(ST(0)); |
| 911 | } |
| 912 | |
| 913 | RETVAL = extLibpath(type); |
| 914 | ST(0) = sv_newmortal(); |
| 915 | sv_setpv((SV*)ST(0), RETVAL); |
| 916 | } |
| 917 | XSRETURN(1); |
| 918 | } |
| 919 | |
| 920 | XS(XS_Cwd_extLibpath_set) |
| 921 | { |
| 922 | dXSARGS; |
| 923 | if (items < 1 || items > 2) |
| 924 | croak("Usage: Cwd::extLibpath_set(s, type = 0)"); |
| 925 | { |
| 926 | char * s = (char *)SvPV(ST(0),na); |
| 927 | bool type; |
| 928 | U32 rc; |
| 929 | bool RETVAL; |
| 930 | |
| 931 | if (items < 2) |
| 932 | type = 0; |
| 933 | else { |
| 934 | type = (int)SvIV(ST(1)); |
| 935 | } |
| 936 | |
| 937 | RETVAL = extLibpath_set(s, type); |
| 938 | ST(0) = RETVAL ? &sv_yes : &sv_no; |
| 939 | if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); |
| 940 | } |
| 941 | XSRETURN(1); |
| 942 | } |
| 943 | |
| 944 | int |
| 945 | Xs_OS2_init() |
| 946 | { |
| 947 | char *file = __FILE__; |
| 948 | { |
| 949 | GV *gv; |
| 950 | |
| 951 | newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file); |
| 952 | newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file); |
| 953 | newXS("Cwd::current_drive", XS_Cwd_current_drive, file); |
| 954 | newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file); |
| 955 | newXS("Cwd::change_drive", XS_Cwd_change_drive, file); |
| 956 | newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file); |
| 957 | newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file); |
| 958 | newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file); |
| 959 | newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file); |
| 960 | newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file); |
| 961 | newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file); |
| 962 | newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file); |
| 963 | gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV); |
| 964 | GvMULTI_on(gv); |
| 965 | #ifdef PERL_IS_AOUT |
| 966 | sv_setiv(GvSV(gv), 1); |
| 967 | #endif |
| 968 | } |
| 969 | } |
| 970 | |
| 971 | OS2_Perl_data_t OS2_Perl_data; |
| 972 | |
| 973 | void |
| 974 | Perl_OS2_init() |
| 975 | { |
| 976 | char *shell; |
| 977 | |
| 978 | settmppath(); |
| 979 | OS2_Perl_data.xs_init = &Xs_OS2_init; |
| 980 | if ( (shell = getenv("PERL_SH_DRIVE")) ) { |
| 981 | sh_path[0] = shell[0]; |
| 982 | } else if ( (shell = getenv("PERL_SH_DIR")) ) { |
| 983 | int l = strlen(shell); |
| 984 | if (shell[l-1] == '/' || shell[l-1] == '\\') { |
| 985 | l--; |
| 986 | } |
| 987 | if (l > STATIC_FILE_LENGTH - 7) { |
| 988 | die("PERL_SH_DIR too long"); |
| 989 | } |
| 990 | strncpy(sh_path, shell, l); |
| 991 | strcpy(sh_path + l, "/sh.exe"); |
| 992 | } |
| 993 | } |
| 994 | |
projects / p5sagit/p5-mst-13.2.git / blame