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