This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perlapi: Remove per-thread section; move to real scns
[perl5.git] / djgpp / djgpp.c
CommitLineData
2b96b0a5 1#define PERLIO_NOT_STDIO 0
af89d9af 2#include "djgpp.h"
39e571d4 3
9731c6ca 4/* hold file pointer, command, mode, and the status of the command */
39e571d4
ML
5struct pipe_list {
6 FILE *fp;
39e571d4 7 int exit_status;
39e571d4 8 struct pipe_list *next;
9731c6ca 9 char *command, mode;
39e571d4
ML
10};
11
12/* static, global list pointer */
13static struct pipe_list *pl = NULL;
14
15FILE *
2b96b0a5 16djgpp_popen (const char *cm, const char *md) /* program name, pipe mode */
39e571d4
ML
17{
18 struct pipe_list *l1;
9731c6ca
LM
19 int fd;
20 char *temp_name=NULL;
39e571d4
ML
21
22 /* make new node */
9731c6ca
LM
23 if ((l1 = (struct pipe_list *) malloc (sizeof (*l1)))
24 && (temp_name = malloc (L_tmpnam)) && tmpnam (temp_name))
39e571d4 25 {
9731c6ca
LM
26 l1->fp = NULL;
27 l1->command = NULL;
28 l1->next = pl;
29 l1->exit_status = -1;
30 l1->mode = md[0];
31
39e571d4 32 /* if caller wants to read */
9731c6ca 33 if (md[0] == 'r' && (fd = dup (fileno (stdout))) >= 0)
39e571d4 34 {
9731c6ca 35 if ((l1->fp = freopen (temp_name, "wb", stdout)))
39e571d4 36 {
9731c6ca
LM
37 l1->exit_status = system (cm);
38 if (dup2 (fd, fileno (stdout)) >= 0)
39 l1->fp = fopen (temp_name, md);
39e571d4 40 }
9731c6ca
LM
41 close (fd);
42 }
43 /* if caller wants to write */
44 else if (md[0] == 'w' && (l1->command = malloc (1 + strlen (cm))))
45 {
46 strcpy (l1->command, cm);
47 l1->fp = fopen (temp_name, md);
48 }
49
50 if (l1->fp)
51 {
52 l1->fp->_flag |= _IORMONCL; /* remove on close */
53 l1->fp->_name_to_remove = temp_name;
54 return (pl = l1)->fp;
39e571d4 55 }
9731c6ca 56 free (l1->command);
39e571d4 57 }
9731c6ca
LM
58 free (temp_name);
59 free (l1);
60 return NULL;
39e571d4
ML
61}
62
63int
2b96b0a5 64djgpp_pclose (FILE *pp)
39e571d4 65{
9731c6ca
LM
66 struct pipe_list *l1, **l2; /* list pointers */
67 int retval=-1; /* function return value */
39e571d4 68
9731c6ca
LM
69 for (l2 = &pl; *l2 && (*l2)->fp != pp; l2 = &((*l2)->next))
70 ;
71 if (!(l1 = *l2))
72 return retval;
73 *l2 = l1->next;
39e571d4 74
9731c6ca
LM
75 /* if pipe was opened to write */
76 if (l1->mode == 'w')
39e571d4 77 {
9731c6ca
LM
78 int fd;
79 fflush (l1->fp);
80 close (fileno (l1->fp));
39e571d4 81
9731c6ca
LM
82 if ((fd = dup (fileno (stdin))) >= 0
83 && (freopen (l1->fp->_name_to_remove, "rb", stdin)))
39e571d4 84 {
9731c6ca
LM
85 retval = system (l1->command);
86 dup2 (fd, fileno (stdin));
39e571d4 87 }
9731c6ca
LM
88 close (fd);
89 free (l1->command);
39e571d4 90 }
9731c6ca
LM
91 else
92 /* if pipe was opened to read, return the exit status we saved */
93 retval = l1->exit_status;
39e571d4 94
9731c6ca
LM
95 fclose (l1->fp); /* this removes the temp file */
96 free (l1);
97 return retval; /* retval==0 ? OK : ERROR */
39e571d4
ML
98}
99
39e571d4
ML
100/**/
101
102#define EXECF_SPAWN 0
103#define EXECF_EXEC 1
104
105static int
41cd3736 106convretcode (pTHX_ int rc,char *prog,int fl)
39e571d4 107{
0453d815 108 if (rc < 0 && ckWARN(WARN_EXEC))
f98bc0c6 109 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't %s \"%s\": %s",
0453d815 110 fl ? "exec" : "spawn",prog,Strerror (errno));
706de38c 111 if (rc >= 0)
933fea7f 112 return rc << 8;
706de38c 113 return -1;
39e571d4
ML
114}
115
116int
41cd3736 117do_aspawn (pTHX_ SV *really,SV **mark,SV **sp)
39e571d4 118{
39e571d4
ML
119 int rc;
120 char **a,*tmps,**argv;
2d8e6c8d 121 STRLEN n_a;
39e571d4
ML
122
123 if (sp<=mark)
124 return -1;
125 a=argv=(char**) alloca ((sp-mark+3)*sizeof (char*));
126
127 while (++mark <= sp)
128 if (*mark)
2d8e6c8d 129 *a++ = SvPVx(*mark, n_a);
39e571d4
ML
130 else
131 *a++ = "";
4e205ed6 132 *a = NULL;
39e571d4
ML
133
134 if (argv[0][0] != '/' && argv[0][0] != '\\'
135 && !(argv[0][0] && argv[0][1] == ':'
136 && (argv[0][2] == '/' || argv[0][2] != '\\'))
137 ) /* will swawnvp use PATH? */
138 TAINT_ENV(); /* testing IFS here is overkill, probably */
139
2d8e6c8d 140 if (really && *(tmps = SvPV(really, n_a)))
39e571d4
ML
141 rc=spawnvp (P_WAIT,tmps,argv);
142 else
143 rc=spawnvp (P_WAIT,argv[0],argv);
144
145 return convretcode (rc,argv[0],EXECF_SPAWN);
146}
147
148#define EXTRA "\x00\x00\x00\x00\x00\x00"
149
150int
41cd3736 151do_spawn2 (pTHX_ char *cmd,int execf)
39e571d4 152{
282fc0b3
Z
153 char **argv,**a,*s,*shell,*metachars;
154 int rc,unixysh,result;
39e571d4 155
282fc0b3 156 ENTER;
39e571d4
ML
157 if ((shell=getenv("SHELL"))==NULL && (shell=getenv("COMSPEC"))==NULL)
158 shell="c:\\command.com" EXTRA;
159
160 unixysh=_is_unixy_shell (shell);
161 metachars=unixysh ? "$&*(){}[]'\";\\?>|<~`\n" EXTRA : "*?[|<>\"\\" EXTRA;
162
163 while (*cmd && isSPACE(*cmd))
164 cmd++;
165
f55ac4a4 166 if (strBEGINs (cmd,"/bin/sh") && isSPACE (cmd[7]))
39e571d4
ML
167 cmd+=5;
168
169 /* save an extra exec if possible */
170 /* see if there are shell metacharacters in it */
171 if (strstr (cmd,"..."))
172 goto doshell;
173 if (unixysh)
174 {
175 if (*cmd=='.' && isSPACE (cmd[1]))
176 goto doshell;
f55ac4a4 177 if (strBEGINs (cmd,"exec") && isSPACE (cmd[4]))
39e571d4
ML
178 goto doshell;
179 for (s=cmd; *s && isALPHA (*s); s++) ; /* catch VAR=val gizmo */
180 if (*s=='=')
181 goto doshell;
182 }
183 for (s=cmd; *s; s++)
184 if (strchr (metachars,*s))
185 {
186 if (*s=='\n' && s[1]=='\0')
187 {
188 *s='\0';
189 break;
190 }
191doshell:
192 if (execf==EXECF_EXEC)
282fc0b3
Z
193 result = convretcode (execl (shell,shell,unixysh ? "-c" : "/c",cmd,NULL),cmd,execf);
194 else
195 result = convretcode (system (cmd),cmd,execf);
196 goto leave;
39e571d4
ML
197 }
198
282fc0b3
Z
199 Newx (argv,(s-cmd)/2+2,char*);
200 SAVEFREEPV(argv);
201 cmd=savepvn (cmd,s-cmd);
202 SAVEFREEPV(cmd);
203 a=argv;
204 for (s=cmd; *s;) {
39e571d4
ML
205 while (*s && isSPACE (*s)) s++;
206 if (*s)
207 *(a++)=s;
208 while (*s && !isSPACE (*s)) s++;
209 if (*s)
210 *s++='\0';
211 }
4e205ed6 212 *a=NULL;
282fc0b3
Z
213 if (!argv[0]) {
214 result = -1;
215 goto leave;
216 }
39e571d4
ML
217
218 if (execf==EXECF_EXEC)
282fc0b3 219 rc=execvp (argv[0],argv);
39e571d4 220 else
282fc0b3
Z
221 rc=spawnvp (P_WAIT,argv[0],argv);
222 result = convretcode (rc,argv[0],execf);
223leave:
224 LEAVE;
225 return result;
39e571d4
ML
226}
227
228int
41cd3736 229do_spawn (pTHX_ char *cmd)
39e571d4 230{
41cd3736 231 return do_spawn2 (aTHX_ cmd,EXECF_SPAWN);
39e571d4
ML
232}
233
234bool
e670e57a 235Perl_do_exec (pTHX_ const char *cmd)
39e571d4 236{
41cd3736 237 do_spawn2 (aTHX_ cmd,EXECF_EXEC);
39e571d4
ML
238 return FALSE;
239}
240
241/**/
242
243struct globinfo
244{
245 int fd;
246 char *matches;
247 size_t size;
933fea7f 248 fpos_t pos;
39e571d4
ML
249};
250
251#define MAXOPENGLOBS 10
252
253static struct globinfo myglobs[MAXOPENGLOBS];
254
255static struct globinfo *
256searchfd (int fd)
257{
258 int ic;
259 for (ic=0; ic<MAXOPENGLOBS; ic++)
260 if (myglobs[ic].fd==fd)
261 return myglobs+ic;
262 return NULL;
263}
264
265static int
266glob_handler (__FSEXT_Fnumber n,int *rv,va_list args)
267{
268 unsigned ic;
269 struct globinfo *gi;
270 switch (n)
271 {
272 case __FSEXT_open:
273 {
274 char *p1,*pattern,*name=va_arg (args,char*);
275 STRLEN len;
276 glob_t pglob;
277
f55ac4a4 278 if (! strBEGINs (name,"/dev/dosglob/"))
39e571d4
ML
279 break;
280 if ((gi=searchfd (-1)) == NULL)
281 break;
282
933fea7f 283 gi->pos=0;
39e571d4
ML
284 pattern=alloca (strlen (name+=13)+1);
285 strcpy (pattern,name);
286 if (!_USE_LFN)
287 strlwr (pattern);
288 ic=pglob.gl_pathc=0;
289 pglob.gl_pathv=NULL;
290 while (pattern)
291 {
292 if ((p1=strchr (pattern,' '))!=NULL)
293 *p1=0;
294 glob (pattern,ic,0,&pglob);
295 ic=GLOB_APPEND;
296 if ((pattern=p1)!=NULL)
297 pattern++;
298 }
299 for (ic=len=0; ic<pglob.gl_pathc; ic++)
300 len+=1+strlen (pglob.gl_pathv[ic]);
301 if (len)
302 {
303 if ((gi->matches=p1=(char*) malloc (gi->size=len))==NULL)
304 break;
305 for (ic=0; ic<pglob.gl_pathc; ic++)
306 {
307 strcpy (p1,pglob.gl_pathv[ic]);
308 p1+=strlen (p1)+1;
309 }
310 }
311 else
312 {
313 if ((gi->matches=strdup (name))==NULL)
314 break;
315 gi->size=strlen (name)+1;
316 }
317 globfree (&pglob);
318 gi->fd=*rv=__FSEXT_alloc_fd (glob_handler);
319 return 1;
320 }
321 case __FSEXT_read:
322 {
323 int fd=va_arg (args,int);
324 char *buf=va_arg (args,char*);
325 size_t siz=va_arg (args,size_t);
326
327 if ((gi=searchfd (fd))==NULL)
328 break;
329
933fea7f
GS
330 if (siz+gi->pos > gi->size)
331 siz = gi->size - gi->pos;
332 memcpy (buf,gi->pos+gi->matches,siz);
333 gi->pos += siz;
39e571d4
ML
334 *rv=siz;
335 return 1;
336 }
337 case __FSEXT_close:
338 {
339 int fd=va_arg (args,int);
340
341 if ((gi=searchfd (fd))==NULL)
342 break;
343 free (gi->matches);
344 gi->fd=-1;
345 break;
346 }
347 default:
348 break;
349 }
350 return 0;
351}
352
353static
354XS(dos_GetCwd)
355{
356 dXSARGS;
357
358 if (items)
41cd3736 359 Perl_croak (aTHX_ "Usage: Dos::GetCwd()");
39e571d4
ML
360 {
361 char tmp[PATH_MAX+2];
362 ST(0)=sv_newmortal ();
363 if (getcwd (tmp,PATH_MAX+1)!=NULL)
364 sv_setpv ((SV*)ST(0),tmp);
ebdd4fa0 365 SvTAINTED_on(ST(0));
39e571d4
ML
366 }
367 XSRETURN (1);
368}
369
370static
371XS(dos_UseLFN)
372{
373 dXSARGS;
374 XSRETURN_IV (_USE_LFN);
375}
376
d835d330
JH
377XS(XS_Cwd_sys_cwd)
378{
379 dXSARGS;
380 if (items != 0)
381 Perl_croak_nocontext("Usage: Cwd::sys_cwd()");
382 {
383 char p[MAXPATHLEN];
384 char * RETVAL;
385 RETVAL = getcwd(p, MAXPATHLEN);
386 ST(0) = sv_newmortal();
387 sv_setpv((SV*)ST(0), RETVAL);
d835d330 388 SvTAINTED_on(ST(0));
d835d330
JH
389 }
390 XSRETURN(1);
391}
392
39e571d4 393void
41cd3736 394Perl_init_os_extras(pTHX)
39e571d4
ML
395{
396 char *file = __FILE__;
397
398 dXSUB_SYS;
399
400 newXS ("Dos::GetCwd",dos_GetCwd,file);
401 newXS ("Dos::UseLFN",dos_UseLFN,file);
d835d330 402 newXS ("Cwd::sys_cwd",XS_Cwd_sys_cwd,file);
39e571d4
ML
403
404 /* install my File System Extension for globbing */
405 __FSEXT_add_open_handler (glob_handler);
406 memset (myglobs,-1,sizeof (myglobs));
407}
408
409static char *perlprefix;
410
411#define PERL5 "/perl5"
412
af89d9af
JH
413char *
414djgpp_pathexp (const char *p)
39e571d4
ML
415{
416 static char expp[PATH_MAX];
417 strcpy (expp,perlprefix);
418 switch (p[0])
419 {
420 case 'B':
421 strcat (expp,"/bin");
422 break;
423 case 'S':
424 strcat (expp,"/lib" PERL5 "/site");
425 break;
426 default:
427 strcat (expp,"/lib" PERL5);
428 break;
429 }
430 return expp;
431}
432
433void
434Perl_DJGPP_init (int *argcp,char ***argvp)
435{
436 char *p;
437
438 perlprefix=strdup (**argvp);
439 strlwr (perlprefix);
440 if ((p=strrchr (perlprefix,'/'))!=NULL)
441 {
442 *p=0;
443 if (strEQ (p-4,"/bin"))
444 p[-4]=0;
445 }
446 else
447 strcpy (perlprefix,"..");
448}
449
05af4e39
PFI
450int
451djgpp_fflush (FILE *fp)
452{
453 int res;
454
455 if ((res = fflush(fp)) == 0 && fp) {
456 Stat_t s;
457 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
458 res = fsync(fileno(fp));
459 }
460/*
461 * If the flush succeeded but set end-of-file, we need to clear
462 * the error because our caller may check ferror(). BTW, this
463 * probably means we just flushed an empty file.
464 */
465 if (res == 0 && fp && ferror(fp) == EOF) clearerr(fp);
466
467 return res;
468}
a5936e02
JH
469
470int djgpp_get_stream_mode(FILE *f)
471{
472 extern char *__file_handle_modes;
473
474 int mode = __file_handle_modes[fileno(f)];
475 if (f->_flag & _IORW)
476 return mode | O_RDWR;
477 if (f->_flag & _IOWRT)
478 return mode | O_WRONLY;
479 return mode | O_RDONLY;
480}
481