sprintf2.t: mark TODO bad denorm values under g++
[perl.git] / djgpp / djgpp.c
1 #define PERLIO_NOT_STDIO 0
2 #include "djgpp.h"
3
4 /* hold file pointer, command, mode, and the status of the command */
5 struct pipe_list {
6   FILE *fp;
7   int exit_status;
8   struct pipe_list *next;
9   char *command, mode;
10 };
11
12 /* static, global list pointer */
13 static struct pipe_list *pl = NULL;
14
15 FILE *
16 djgpp_popen (const char *cm, const char *md) /* program name, pipe mode */
17 {
18   struct pipe_list *l1;
19   int fd;
20   char *temp_name=NULL;
21
22   /* make new node */
23   if ((l1 = (struct pipe_list *) malloc (sizeof (*l1)))
24      && (temp_name = malloc (L_tmpnam)) && tmpnam (temp_name))
25   {
26     l1->fp = NULL;
27     l1->command = NULL;
28     l1->next = pl;
29     l1->exit_status = -1;
30     l1->mode = md[0];
31
32     /* if caller wants to read */
33     if (md[0] == 'r' && (fd = dup (fileno (stdout))) >= 0)
34     {
35       if ((l1->fp = freopen (temp_name, "wb", stdout)))
36       {
37         l1->exit_status = system (cm);
38         if (dup2 (fd, fileno (stdout)) >= 0)
39           l1->fp = fopen (temp_name, md);
40       }
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;
55     }
56     free (l1->command);
57   }
58   free (temp_name);
59   free (l1);
60   return NULL;
61 }
62
63 int
64 djgpp_pclose (FILE *pp)
65 {
66   struct pipe_list *l1, **l2;   /* list pointers */
67   int retval=-1;                /* function return value */
68
69   for (l2 = &pl; *l2 && (*l2)->fp != pp; l2 = &((*l2)->next))
70     ;
71   if (!(l1 = *l2))
72     return retval;
73   *l2 = l1->next;
74
75   /* if pipe was opened to write */
76   if (l1->mode == 'w')
77   {
78     int fd;
79     fflush (l1->fp);
80     close (fileno (l1->fp)); 
81
82     if ((fd = dup (fileno (stdin))) >= 0
83        && (freopen (l1->fp->_name_to_remove, "rb", stdin)))
84     {
85       retval = system (l1->command);
86       dup2 (fd, fileno (stdin));
87     }
88     close (fd);
89     free (l1->command);
90   }
91   else
92     /* if pipe was opened to read, return the exit status we saved */
93     retval = l1->exit_status;
94
95   fclose (l1->fp);              /* this removes the temp file */
96   free (l1);
97   return retval;                /* retval==0 ? OK : ERROR */
98 }
99
100 /**/
101
102 #define EXECF_SPAWN 0
103 #define EXECF_EXEC 1
104
105 static int
106 convretcode (pTHX_ int rc,char *prog,int fl)
107 {
108     if (rc < 0 && ckWARN(WARN_EXEC))
109         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't %s \"%s\": %s",
110                     fl ? "exec" : "spawn",prog,Strerror (errno));
111     if (rc >= 0)
112         return rc << 8;
113     return -1;
114 }
115
116 int
117 do_aspawn (pTHX_ SV *really,SV **mark,SV **sp)
118 {
119     int  rc;
120     char **a,*tmps,**argv; 
121     STRLEN n_a;
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)
129             *a++ = SvPVx(*mark, n_a);
130         else
131             *a++ = "";
132     *a = NULL;
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
140     if (really && *(tmps = SvPV(really, n_a)))
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
150 int
151 do_spawn2 (pTHX_ char *cmd,int execf)
152 {
153     char **argv,**a,*s,*shell,*metachars;
154     int  rc,unixysh,result;
155
156     ENTER;
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
166     if (strBEGINs (cmd,"/bin/sh") && isSPACE (cmd[7]))
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;
177         if (strBEGINs (cmd,"exec") && isSPACE (cmd[4]))
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             }
191 doshell:
192             if (execf==EXECF_EXEC)
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;
197         }
198
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;) {
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     }
212     *a=NULL;
213     if (!argv[0]) {
214         result = -1;
215         goto leave;
216     }
217
218     if (execf==EXECF_EXEC)
219         rc=execvp (argv[0],argv);
220     else
221         rc=spawnvp (P_WAIT,argv[0],argv);
222     result = convretcode (rc,argv[0],execf);
223 leave:
224     LEAVE;
225     return result;
226 }
227
228 int
229 do_spawn (pTHX_ char *cmd)
230 {
231     return do_spawn2 (aTHX_ cmd,EXECF_SPAWN);
232 }
233
234 bool
235 Perl_do_exec (pTHX_ const char *cmd)
236 {
237     do_spawn2 (aTHX_ cmd,EXECF_EXEC);
238     return FALSE;
239 }
240
241 /**/
242
243 struct globinfo
244 {
245     int    fd;
246     char   *matches;
247     size_t size;
248     fpos_t pos;
249 };
250
251 #define MAXOPENGLOBS 10
252
253 static struct globinfo myglobs[MAXOPENGLOBS];
254
255 static struct globinfo *
256 searchfd (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
265 static int
266 glob_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
278             if (! strBEGINs (name,"/dev/dosglob/"))
279                 break;
280             if ((gi=searchfd (-1)) == NULL)
281                 break;
282
283             gi->pos=0;
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
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;
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
353 static
354 XS(dos_GetCwd)
355 {
356     dXSARGS;
357
358     if (items)
359         Perl_croak (aTHX_ "Usage: Dos::GetCwd()");
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);
365         SvTAINTED_on(ST(0));
366     }
367     XSRETURN (1);
368 }
369
370 static
371 XS(dos_UseLFN)
372 {
373     dXSARGS;
374     XSRETURN_IV (_USE_LFN);
375 }
376
377 XS(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);
388         SvTAINTED_on(ST(0));
389     }
390     XSRETURN(1);
391 }
392
393 void
394 Perl_init_os_extras(pTHX)
395 {
396     char *file = __FILE__;
397
398     dXSUB_SYS;
399     
400     newXS ("Dos::GetCwd",dos_GetCwd,file);
401     newXS ("Dos::UseLFN",dos_UseLFN,file);
402     newXS ("Cwd::sys_cwd",XS_Cwd_sys_cwd,file);
403
404     /* install my File System Extension for globbing */
405     __FSEXT_add_open_handler (glob_handler);
406     memset (myglobs,-1,sizeof (myglobs));
407 }
408
409 static char *perlprefix;
410
411 #define PERL5 "/perl5"
412
413 char *
414 djgpp_pathexp (const char *p)
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
433 void
434 Perl_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
450 int
451 djgpp_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 }
469
470 int 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