source: trunk/essentials/dev-lang/perl/vmesa/vmesa.c@ 3221

Last change on this file since 3221 was 3181, checked in by bird, 19 years ago

perl 5.8.8
File size: 20.5 KB
Line 
1/************************************************************/
2/* */
3/* Module ID - vmesa.c */
4/* */
5/* Function - Provide operating system dependent process- */
6/* ing for perl under VM/ESA. */
7/* */
8/* Parameters - See individual entry points. */
9/* */
10/* Called By - N/A - see individual entry points. */
11/* */
12/* Calling To - N/A - see individual entry points. */
13/* */
14/* Notes - (1) ....................................... */
15/* */
16/* (2) ....................................... */
17/* */
18/* Name - Neale Ferguson. */
19/* */
20/* Date - August, 1998. */
21/* */
22/* */
23/* Associated - (1) Refer To ........................... */
24/* Documentation */
25/* (2) Refer To ........................... */
26/* */
27/************************************************************/
28/************************************************************/
29/* */
30/* MODULE MAINTENANCE HISTORY */
31/* -------------------------- */
32/* */
33static char REQ_REL_WHO [13] =
34/*-------------- -------------------------------------*/
35 "9999_99 NAF "; /* Original module */
36/* */
37/*============ End of Module Maintenance History ===========*/
38
39/************************************************************/
40/* */
41/* DEFINES */
42/* ------- */
43/* */
44/************************************************************/
45
46#define FAIL 65280
47
48/*=============== END OF DEFINES ===========================*/
49
50/************************************************************/
51/* */
52/* INCLUDE STATEMENTS */
53/* ------------------ */
54/* */
55/************************************************************/
56
57#include <stdio.h>
58#include <stdlib.h>
59#include <spawn.h>
60#include <fcntl.h>
61#include <unistd.h>
62#include <pthread.h>
63#include <dll.h>
64#include "EXTERN.h"
65#include "perl.h"
66#pragma map(truncate, "@@TRUNC")
67
68/*================== End of Include Statements =============*/
69
70/************************************************************/
71/* */
72/* Global Variables */
73/* ---------------- */
74/* */
75/************************************************************/
76
77static int Perl_stdin_fd = STDIN_FILENO,
78 Perl_stdout_fd = STDOUT_FILENO;
79
80static long dl_retcode = 0;
81
82/*================== End of Global Variables ===============*/
83
84/************************************************************/
85/* */
86/* FUNCTION PROTOTYPES */
87/* ------------------- */
88/* */
89/************************************************************/
90
91int do_aspawn(SV *, SV **, SV **);
92int do_spawn(char *, int);
93static int spawnit(char *);
94static pid_t spawn_cmd(char *, int, int);
95struct perl_thread * getTHR(void);
96
97/*================== End of Prototypes =====================*/
98
99/************************************************************/
100/* */
101/* D O _ A S P A W N */
102/* ----------------- */
103/* */
104/************************************************************/
105
106int
107do_aspawn(SV* really, SV **mark, SV **sp)
108{
109 char **a,
110 *tmps;
111 struct inheritance inherit;
112 pid_t pid;
113 int status,
114 fd,
115 nFd,
116 fdMap[3];
117 SV *sv,
118 **p_sv;
119 STRLEN n_a;
120
121 status = FAIL;
122 if (sp > mark)
123 {
124 Newx(PL_Argv, sp - mark + 1, char*);
125 a = PL_Argv;
126 while (++mark <= sp)
127 {
128 if (*mark)
129 *a++ = SvPVx(*mark, n_a);
130 else
131 *a++ = "";
132 }
133 inherit.flags = SPAWN_SETGROUP;
134 inherit.pgroup = SPAWN_NEWPGROUP;
135 fdMap[STDIN_FILENO] = Perl_stdin_fd;
136 fdMap[STDOUT_FILENO] = Perl_stdout_fd;
137 fdMap[STDERR_FILENO] = STDERR_FILENO;
138 nFd = 3;
139 *a = Nullch;
140 /*-----------------------------------------------------*/
141 /* Will execvp() use PATH? */
142 /*-----------------------------------------------------*/
143 if (*PL_Argv[0] != '/')
144 TAINT_ENV();
145 if (really && *(tmps = SvPV(really, n_a)))
146 pid = spawnp(tmps, nFd, fdMap, &inherit,
147 (const char **) PL_Argv,
148 (const char **) environ);
149 else
150 pid = spawnp(PL_Argv[0], nFd, fdMap, &inherit,
151 (const char **) PL_Argv,
152 (const char **) environ);
153 if (pid < 0)
154 {
155 status = FAIL;
156 if (ckWARN(WARN_EXEC))
157 warner(WARN_EXEC,"Can't exec \"%s\": %s",
158 PL_Argv[0],
159 Strerror(errno));
160 }
161 else
162 {
163 /*------------------------------------------------*/
164 /* If the file descriptors have been remapped then*/
165 /* we've been called following a my_popen request */
166 /* therefore we don't want to wait for spawnned */
167 /* program to complete. We need to set the fdpid */
168 /* value to the value of the spawnned process' pid*/
169 /*------------------------------------------------*/
170 fd = 0;
171 if (Perl_stdin_fd != STDIN_FILENO)
172 fd = Perl_stdin_fd;
173 else
174 if (Perl_stdout_fd != STDOUT_FILENO)
175 fd = Perl_stdout_fd;
176 if (fd != 0)
177 {
178 /*---------------------------------------------*/
179 /* Get the fd of the other end of the pipe, */
180 /* use this to reference the fdpid which will */
181 /* be used by my_pclose */
182 /*---------------------------------------------*/
183 close(fd);
184 MUTEX_LOCK(&PL_fdpid_mutex);
185 p_sv = av_fetch(PL_fdpid,fd,TRUE);
186 fd = (int) SvIVX(*p_sv);
187 SvREFCNT_dec(*p_sv);
188 *p_sv = &PL_sv_undef;
189 sv = *av_fetch(PL_fdpid,fd,TRUE);
190 MUTEX_UNLOCK(&PL_fdpid_mutex);
191 (void) SvUPGRADE(sv, SVt_IV);
192 SvIVX(sv) = pid;
193 status = 0;
194 }
195 else
196 wait4pid(pid, &status, 0);
197 }
198 do_execfree();
199 }
200 return (status);
201}
202
203/*===================== End of do_aspawn ===================*/
204
205/************************************************************/
206/* */
207/* D O _ S P A W N */
208/* --------------- */
209/* */
210/************************************************************/
211
212int
213do_spawn(char *cmd, int execf)
214{
215 char **a,
216 *s,
217 flags[10];
218 int status,
219 nFd,
220 fdMap[3];
221 struct inheritance inherit;
222 pid_t pid;
223
224 while (*cmd && isSPACE(*cmd))
225 cmd++;
226
227 /*------------------------------------------------------*/
228 /* See if there are shell metacharacters in it */
229 /*------------------------------------------------------*/
230
231 if (*cmd == '.' && isSPACE(cmd[1]))
232 return (spawnit(cmd));
233 else
234 {
235 if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
236 return (spawnit(cmd));
237 else
238 {
239 /*------------------------------------------------*/
240 /* Catch VAR=val gizmo */
241 /*------------------------------------------------*/
242 for (s = cmd; *s && isALPHA(*s); s++);
243 if (*s != '=')
244 {
245 for (s = cmd; *s; s++)
246 {
247 if (*s != ' ' &&
248 !isALPHA(*s) &&
249 strchr("$&*(){}[]'\";\\|?<>~`\n",*s))
250 {
251 if (*s == '\n' && !s[1])
252 {
253 *s = '\0';
254 break;
255 }
256 return(spawnit(cmd));
257 }
258 }
259 }
260 }
261 }
262
263 Newx(PL_Argv, (s - cmd) / 2 + 2, char*);
264 PL_Cmd = savepvn(cmd, s-cmd);
265 a = PL_Argv;
266 for (s = PL_Cmd; *s;)
267 {
268 while (*s && isSPACE(*s)) s++;
269 if (*s)
270 *(a++) = s;
271 while (*s && !isSPACE(*s)) s++;
272 if (*s)
273 *s++ = '\0';
274 }
275 *a = Nullch;
276 fdMap[STDIN_FILENO] = Perl_stdin_fd;
277 fdMap[STDOUT_FILENO] = Perl_stdout_fd;
278 fdMap[STDERR_FILENO] = STDERR_FILENO;
279 nFd = 3;
280 inherit.flags = 0;
281 if (PL_Argv[0])
282 {
283 pid = spawnp(PL_Argv[0], nFd, fdMap, &inherit,
284 (const char **) PL_Argv,
285 (const char **) environ);
286 if (pid < 0)
287 {
288 status = FAIL;
289 if (ckWARN(WARN_EXEC))
290 warner(WARN_EXEC,"Can't exec \"%s\": %s",
291 PL_Argv[0],
292 Strerror(errno));
293 }
294 else
295 wait4pid(pid, &status, 0);
296 }
297 do_execfree();
298 return (status);
299}
300
301/*===================== End of do_spawn ====================*/
302
303/************************************************************/
304/* */
305/* Name - spawnit. */
306/* */
307/* Function - Spawn command and return status. */
308/* */
309/* On Entry - cmd - command to be spawned. */
310/* */
311/* On Exit - status returned. */
312/* */
313/************************************************************/
314
315int
316spawnit(char *cmd)
317{
318 pid_t pid;
319 int status;
320
321 pid = spawn_cmd(cmd, STDIN_FILENO, STDOUT_FILENO);
322 if (pid < 0)
323 status = FAIL;
324 else
325 wait4pid(pid, &status, 0);
326
327 return (status);
328}
329
330/*===================== End of spawnit =====================*/
331
332/************************************************************/
333/* */
334/* Name - spawn_cmd. */
335/* */
336/* Function - Spawn command and return pid. */
337/* */
338/* On Entry - cmd - command to be spawned. */
339/* */
340/* On Exit - pid returned. */
341/* */
342/************************************************************/
343
344pid_t
345spawn_cmd(char *cmd, int inFd, int outFd)
346{
347 struct inheritance inherit;
348 pid_t pid;
349 const char *argV[4] = {"/bin/sh","-c",NULL,NULL};
350 int nFd,
351 fdMap[3];
352
353 argV[2] = cmd;
354 fdMap[STDIN_FILENO] = inFd;
355 fdMap[STDOUT_FILENO] = outFd;
356 fdMap[STDERR_FILENO] = STDERR_FILENO;
357 nFd = 3;
358 inherit.flags = SPAWN_SETGROUP;
359 inherit.pgroup = SPAWN_NEWPGROUP;
360 pid = spawn(argV[0], nFd, fdMap, &inherit,
361 argV, (const char **) environ);
362 return (pid);
363}
364
365/*===================== End of spawnit =====================*/
366
367/************************************************************/
368/* */
369/* Name - my_popen. */
370/* */
371/* Function - Use popen to execute a command return a */
372/* file descriptor. */
373/* */
374/* On Entry - cmd - command to be executed. */
375/* */
376/* On Exit - FILE * returned. */
377/* */
378/************************************************************/
379
380#include <ctest.h>
381PerlIO *
382my_popen(char *cmd, char *mode)
383{
384 FILE *fd;
385 int pFd[2],
386 this,
387 that,
388 pid;
389 SV *sv;
390
391 if (PerlProc_pipe(pFd) >= 0)
392 {
393 this = (*mode == 'w');
394 that = !this;
395 /*-------------------------------------------------*/
396 /* If this is a read mode pipe */
397 /* - map the write end of the pipe to STDOUT */
398 /* - return the *FILE for the read end of the pipe */
399 /*-------------------------------------------------*/
400 if (!this)
401 Perl_stdout_fd = pFd[that];
402 /*-------------------------------------------------*/
403 /* Else */
404 /* - map the read end of the pipe to STDIN */
405 /* - return the *FILE for the write end of the pipe*/
406 /*-------------------------------------------------*/
407 else
408 Perl_stdin_fd = pFd[that];
409 if (strNE(cmd,"-"))
410 {
411 PERL_FLUSHALL_FOR_CHILD;
412 pid = spawn_cmd(cmd, Perl_stdin_fd, Perl_stdout_fd);
413 if (pid >= 0)
414 {
415 MUTEX_LOCK(&PL_fdpid_mutex);
416 sv = *av_fetch(PL_fdpid,pFd[this],TRUE);
417 MUTEX_UNLOCK(&PL_fdpid_mutex);
418 (void) SvUPGRADE(sv, SVt_IV);
419 SvIVX(sv) = pid;
420 fd = PerlIO_fdopen(pFd[this], mode);
421 close(pFd[that]);
422 }
423 else
424 fd = Nullfp;
425 }
426 else
427 {
428 MUTEX_LOCK(&PL_fdpid_mutex);
429 sv = *av_fetch(PL_fdpid,pFd[that],TRUE);
430 MUTEX_UNLOCK(&PL_fdpid_mutex);
431 (void) SvUPGRADE(sv, SVt_IV);
432 SvIVX(sv) = pFd[this];
433 fd = PerlIO_fdopen(pFd[this], mode);
434 }
435 }
436 else
437 fd = Nullfp;
438 return (fd);
439}
440
441/*===================== End of my_popen ====================*/
442
443/************************************************************/
444/* */
445/* Name - my_pclose. */
446/* */
447/* Function - Use pclose to terminate a piped command */
448/* file stream. */
449/* */
450/* On Entry - fd - FILE pointer. */
451/* */
452/* On Exit - Status returned. */
453/* */
454/************************************************************/
455
456long
457my_pclose(FILE *fp)
458{
459 int pid,
460 saveErrno,
461 status;
462 long rc,
463 wRc;
464 SV **sv;
465 FILE *other;
466
467 MUTEX_LOCK(&PL_fdpid_mutex);
468 sv = av_fetch(PL_fdpid,PerlIO_fileno(fp),TRUE);
469 MUTEX_UNLOCK(&PL_fdpid_mutex);
470 pid = (int) SvIVX(*sv);
471 SvREFCNT_dec(*sv);
472 *sv = &PL_sv_undef;
473 rc = PerlIO_close(fp);
474 saveErrno = errno;
475 do
476 {
477 wRc = waitpid(pid, &status, 0);
478 } while ((wRc == -1) && (errno == EINTR));
479 Perl_stdin_fd = STDIN_FILENO;
480 Perl_stdout_fd = STDOUT_FILENO;
481 errno = saveErrno;
482 if (rc != 0)
483 SETERRNO(errno, garbage);
484 return (rc);
485
486}
487
488/************************************************************/
489/* */
490/* Name - dlopen. */
491/* */
492/* Function - Load a DLL. */
493/* */
494/* On Exit - */
495/* */
496/************************************************************/
497
498void *
499dlopen(const char *path)
500{
501 dllhandle *handle;
502
503fprintf(stderr,"Loading %s\n",path);
504 handle = dllload(path);
505 dl_retcode = errno;
506fprintf(stderr,"Handle %08X %s\n",handle,strerror(errno));
507 return ((void *) handle);
508}
509
510/*===================== End of dlopen ======================*/
511
512/************************************************************/
513/* */
514/* Name - dlsym. */
515/* */
516/* Function - Locate a DLL symbol. */
517/* */
518/* On Exit - */
519/* */
520/************************************************************/
521
522void *
523dlsym(void *handle, const char *symbol)
524{
525 void *symLoc;
526
527fprintf(stderr,"Finding %s\n",symbol);
528 symLoc = dllqueryvar((dllhandle *) handle, (char *) symbol);
529 if (symLoc == NULL)
530 symLoc = (void *) dllqueryfn((dllhandle *) handle,
531 (char *) symbol);
532 dl_retcode = errno;
533 return(symLoc);
534}
535
536/*===================== End of dlsym =======================*/
537
538/************************************************************/
539/* */
540/* Name - dlerror. */
541/* */
542/* Function - Return the last errno pertaining to a DLL */
543/* operation. */
544/* */
545/* On Exit - */
546/* */
547/************************************************************/
548
549void *
550dlerror(void)
551{
552 char * dlEmsg;
553
554 dlEmsg = strerror(dl_retcode);
555 dl_retcode = 0;
556 return(dlEmsg);
557}
558
559/*===================== End of dlerror =====================*/
560
561/************************************************************/
562/* */
563/* Name - TRUNCATE. */
564/* */
565/* Function - Truncate a file identified by 'path' to */
566/* a given length. */
567/* */
568/* On Entry - path - Path of file to be truncated. */
569/* length - length of truncated file. */
570/* */
571/* On Exit - retC - return code. */
572/* */
573/************************************************************/
574
575int
576truncate(const unsigned char *path, off_t length)
577{
578 int fd,
579 retC;
580
581 fd = open((const char *) path, O_RDWR);
582 if (fd > 0)
583 {
584 retC = ftruncate(fd, length);
585 close(fd);
586 }
587 else
588 retC = fd;
589 return(retC);
590}
591
592/*===================== End of trunc =======================*/
Note: See TracBrowser for help on using the repository browser.