[perl5.git] / djgpp / djgpp.c

#define PERLIO_NOT_STDIO 0
#include "djgpp.h"

/* hold file pointer, command, mode, and the status of the command */
struct pipe_list {
  FILE *fp;
  int exit_status;
  struct pipe_list *next;
  char *command, mode;
};

/* static, global list pointer */
static struct pipe_list *pl = NULL;

FILE *
djgpp_popen (const char *cm, const char *md) /* program name, pipe mode */
{
  struct pipe_list *l1;
  int fd;
  char *temp_name=NULL;

  /* make new node */
  if ((l1 = (struct pipe_list *) malloc (sizeof (*l1)))
     && (temp_name = malloc (L_tmpnam)) && tmpnam (temp_name))
  {
    l1->fp = NULL;
    l1->command = NULL;
    l1->next = pl;
    l1->exit_status = -1;
    l1->mode = md[0];

    /* if caller wants to read */
    if (md[0] == 'r' && (fd = dup (fileno (stdout))) >= 0)
    {
      if ((l1->fp = freopen (temp_name, "wb", stdout)))
      {
        l1->exit_status = system (cm);
        if (dup2 (fd, fileno (stdout)) >= 0)
          l1->fp = fopen (temp_name, md);
      }
      close (fd);
    }
    /* if caller wants to write */
    else if (md[0] == 'w' && (l1->command = malloc (1 + strlen (cm))))
    {
      strcpy (l1->command, cm);
      l1->fp = fopen (temp_name, md);
    }

    if (l1->fp)
    {
      l1->fp->_flag |= _IORMONCL; /* remove on close */
      l1->fp->_name_to_remove = temp_name;
      return (pl = l1)->fp;
    }
    free (l1->command);
  }
  free (temp_name);
  free (l1);
  return NULL;
}

int
djgpp_pclose (FILE *pp)
{
  struct pipe_list *l1, **l2;   /* list pointers */
  int retval=-1;		/* function return value */

  for (l2 = &pl; *l2 && (*l2)->fp != pp; l2 = &((*l2)->next))
    ;
  if (!(l1 = *l2))
    return retval;
  *l2 = l1->next;

  /* if pipe was opened to write */
  if (l1->mode == 'w')
  {
    int fd;
    fflush (l1->fp);
    close (fileno (l1->fp)); 

    if ((fd = dup (fileno (stdin))) >= 0
       && (freopen (l1->fp->_name_to_remove, "rb", stdin)))
    {
      retval = system (l1->command);
      dup2 (fd, fileno (stdin));
    }
    close (fd);
    free (l1->command);
  }
  else
    /* if pipe was opened to read, return the exit status we saved */
    retval = l1->exit_status;

  fclose (l1->fp);              /* this removes the temp file */
  free (l1);
  return retval;                /* retval==0 ? OK : ERROR */
}

/**/

#define EXECF_SPAWN 0
#define EXECF_EXEC 1

static int
convretcode (pTHX_ int rc,char *prog,int fl)
{
    if (rc < 0 && ckWARN(WARN_EXEC))
        Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't %s \"%s\": %s",
		    fl ? "exec" : "spawn",prog,Strerror (errno));
    if (rc >= 0)
        return rc << 8;
    return -1;
}

int
do_aspawn (pTHX_ SV *really,SV **mark,SV **sp)
{
    int  rc;
    char **a,*tmps,**argv; 
    STRLEN n_a;

    if (sp<=mark)
        return -1;
    a=argv=(char**) alloca ((sp-mark+3)*sizeof (char*));

    while (++mark <= sp)
        if (*mark)
            *a++ = SvPVx(*mark, n_a);
        else
            *a++ = "";
    *a = NULL;

    if (argv[0][0] != '/' && argv[0][0] != '\\'
        && !(argv[0][0] && argv[0][1] == ':'
        && (argv[0][2] == '/' || argv[0][2] != '\\'))
     ) /* will swawnvp use PATH? */
         TAINT_ENV();	/* testing IFS here is overkill, probably */

    if (really && *(tmps = SvPV(really, n_a)))
        rc=spawnvp (P_WAIT,tmps,argv);
    else
        rc=spawnvp (P_WAIT,argv[0],argv);

    return convretcode (rc,argv[0],EXECF_SPAWN);
}

#define EXTRA "\x00\x00\x00\x00\x00\x00"

int
do_spawn2 (pTHX_ char *cmd,int execf)
{
    char **a,*s,*shell,*metachars;
    int  rc,unixysh;

    if ((shell=getenv("SHELL"))==NULL && (shell=getenv("COMSPEC"))==NULL)
    	shell="c:\\command.com" EXTRA;

    unixysh=_is_unixy_shell (shell);
    metachars=unixysh ? "$&*(){}[]'\";\\?>|<~`\n" EXTRA : "*?[|<>\"\\" EXTRA;

    while (*cmd && isSPACE(*cmd))
	cmd++;

    if (strnEQ (cmd,"/bin/sh",7) && isSPACE (cmd[7]))
        cmd+=5;

    /* save an extra exec if possible */
    /* see if there are shell metacharacters in it */
    if (strstr (cmd,"..."))
        goto doshell;
    if (unixysh)
    {
        if (*cmd=='.' && isSPACE (cmd[1]))
            goto doshell;
        if (strnEQ (cmd,"exec",4) && isSPACE (cmd[4]))
            goto doshell;
        for (s=cmd; *s && isALPHA (*s); s++) ;	/* catch VAR=val gizmo */
            if (*s=='=')
                goto doshell;
    }
    for (s=cmd; *s; s++)
	if (strchr (metachars,*s))
	{
	    if (*s=='\n' && s[1]=='\0')
	    {
		*s='\0';
		break;
	    }
doshell:
	    if (execf==EXECF_EXEC)
                return convretcode (execl (shell,shell,unixysh ? "-c" : "/c",cmd,NULL),cmd,execf);
            return convretcode (system (cmd),cmd,execf);
	}

    Newx (PL_Argv,(s-cmd)/2+2,char*);
    PL_Cmd=savepvn (cmd,s-cmd);
    a=PL_Argv;
    for (s=PL_Cmd; *s;) {
	while (*s && isSPACE (*s)) s++;
	if (*s)
	    *(a++)=s;
	while (*s && !isSPACE (*s)) s++;
	if (*s)
	    *s++='\0';
    }
    *a=NULL;
    if (!PL_Argv[0])
        return -1;

    if (execf==EXECF_EXEC)
        rc=execvp (PL_Argv[0],PL_Argv);
    else
        rc=spawnvp (P_WAIT,PL_Argv[0],PL_Argv);
    return convretcode (rc,PL_Argv[0],execf);
}

int
do_spawn (pTHX_ char *cmd)
{
    return do_spawn2 (aTHX_ cmd,EXECF_SPAWN);
}

bool
Perl_do_exec (pTHX_ const char *cmd)
{
    do_spawn2 (aTHX_ cmd,EXECF_EXEC);
    return FALSE;
}

/**/

struct globinfo
{
    int    fd;
    char   *matches;
    size_t size;
    fpos_t pos;
};

#define MAXOPENGLOBS 10

static struct globinfo myglobs[MAXOPENGLOBS];

static struct globinfo *
searchfd (int fd)
{
    int ic;
    for (ic=0; ic<MAXOPENGLOBS; ic++)
        if (myglobs[ic].fd==fd)
            return myglobs+ic;
    return NULL;
}

static int
glob_handler (__FSEXT_Fnumber n,int *rv,va_list args)
{
    unsigned ic;
    struct globinfo *gi;
    switch (n)
    {
        case __FSEXT_open:
        {
            char   *p1,*pattern,*name=va_arg (args,char*);
            STRLEN len;
            glob_t pglob;

            if (strnNE (name,"/dev/dosglob/",13))
                break;
            if ((gi=searchfd (-1)) == NULL)
                break;

            gi->pos=0;
            pattern=alloca (strlen (name+=13)+1);
            strcpy (pattern,name);
            if (!_USE_LFN)
                strlwr (pattern);
            ic=pglob.gl_pathc=0;
            pglob.gl_pathv=NULL;
            while (pattern)
            {
                if ((p1=strchr (pattern,' '))!=NULL)
                    *p1=0;
                glob (pattern,ic,0,&pglob);
                ic=GLOB_APPEND;
                if ((pattern=p1)!=NULL)
                    pattern++;
            }
            for (ic=len=0; ic<pglob.gl_pathc; ic++)
                len+=1+strlen (pglob.gl_pathv[ic]);
            if (len)
            {
                if ((gi->matches=p1=(char*) malloc (gi->size=len))==NULL)
                    break;
                for (ic=0; ic<pglob.gl_pathc; ic++)
                {
                    strcpy (p1,pglob.gl_pathv[ic]);
                    p1+=strlen (p1)+1;
                }
            }
            else
            {
                if ((gi->matches=strdup (name))==NULL)
                    break;
                gi->size=strlen (name)+1;
            }
            globfree (&pglob);
            gi->fd=*rv=__FSEXT_alloc_fd (glob_handler);
            return 1;
        }
        case __FSEXT_read:
        {
            int      fd=va_arg (args,int);
            char   *buf=va_arg (args,char*);
            size_t  siz=va_arg (args,size_t);

            if ((gi=searchfd (fd))==NULL)
                break;

            if (siz+gi->pos > gi->size)
                siz = gi->size - gi->pos;
            memcpy (buf,gi->pos+gi->matches,siz);
            gi->pos += siz;
            *rv=siz;
            return 1;
        }
        case __FSEXT_close:
        {
            int fd=va_arg (args,int);

            if ((gi=searchfd (fd))==NULL)
                break;
            free (gi->matches);
            gi->fd=-1;
            break;
        }
        default:
            break;
    }
    return 0;
}

static
XS(dos_GetCwd)
{
    dXSARGS;

    if (items)
        Perl_croak (aTHX_ "Usage: Dos::GetCwd()");
    {
        char tmp[PATH_MAX+2];
        ST(0)=sv_newmortal ();
        if (getcwd (tmp,PATH_MAX+1)!=NULL)
            sv_setpv ((SV*)ST(0),tmp);
	SvTAINTED_on(ST(0));
    }
    XSRETURN (1);
}

static
XS(dos_UseLFN)
{
    dXSARGS;
    XSRETURN_IV (_USE_LFN);
}

XS(XS_Cwd_sys_cwd)
{
    dXSARGS;
    if (items != 0)
	Perl_croak_nocontext("Usage: Cwd::sys_cwd()");
    {
	char p[MAXPATHLEN];
	char *	RETVAL;
	RETVAL = getcwd(p, MAXPATHLEN);
	ST(0) = sv_newmortal();
	sv_setpv((SV*)ST(0), RETVAL);
	SvTAINTED_on(ST(0));
    }
    XSRETURN(1);
}

void
Perl_init_os_extras(pTHX)
{
    char *file = __FILE__;

    dXSUB_SYS;
    
    newXS ("Dos::GetCwd",dos_GetCwd,file);
    newXS ("Dos::UseLFN",dos_UseLFN,file);
    newXS ("Cwd::sys_cwd",XS_Cwd_sys_cwd,file);

    /* install my File System Extension for globbing */
    __FSEXT_add_open_handler (glob_handler);
    memset (myglobs,-1,sizeof (myglobs));
}

static char *perlprefix;

#define PERL5 "/perl5"

char *
djgpp_pathexp (const char *p)
{
    static char expp[PATH_MAX];
    strcpy (expp,perlprefix);
    switch (p[0])
    {
        case 'B':
            strcat (expp,"/bin");
            break;
        case 'S':
            strcat (expp,"/lib" PERL5 "/site");
            break;
        default:
            strcat (expp,"/lib" PERL5);
            break;
    }
    return expp;
}

void
Perl_DJGPP_init (int *argcp,char ***argvp)
{
    char *p;

    perlprefix=strdup (**argvp);
    strlwr (perlprefix);
    if ((p=strrchr (perlprefix,'/'))!=NULL)
    {
        *p=0;
        if (strEQ (p-4,"/bin"))
            p[-4]=0;
    }
    else
        strcpy (perlprefix,"..");
}

int
djgpp_fflush (FILE *fp)
{
    int res;

    if ((res = fflush(fp)) == 0 && fp) {
	Stat_t s;
	if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
	    res = fsync(fileno(fp));
    }
/*
 * If the flush succeeded but set end-of-file, we need to clear
 * the error because our caller may check ferror().  BTW, this
 * probably means we just flushed an empty file.
 */
    if (res == 0 && fp && ferror(fp) == EOF) clearerr(fp);

    return res;
}

int djgpp_get_stream_mode(FILE *f)
{
    extern char *__file_handle_modes;

    int mode = __file_handle_modes[fileno(f)];
    if (f->_flag & _IORW)
        return mode | O_RDWR;
    if (f->_flag & _IOWRT)
        return mode | O_WRONLY;
    return mode | O_RDONLY;
}
Commit	Line	Data
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 LM	5	struct pipe_list {
39e571d4 LM	6	FILE *fp;
39e571d4	7	int exit_status;
39e571d4	8	struct pipe_list *next;
9731c6ca	9	char *command, mode;
39e571d4 LM	10	};
	11
	12	/* static, global list pointer */
	13	static struct pipe_list *pl = NULL;
	14
	15	FILE *
2b96b0a5	16	djgpp_popen (const char cm, const char md) /* program name, pipe mode */
39e571d4 LM	17	{
39e571d4 LM	18	struct pipe_list *l1;
9731c6ca LM	19	int fd;
9731c6ca LM	20	char *temp_name=NULL;
39e571d4 LM	21
39e571d4 LM	22	/* make new node */
9731c6ca LM	23	if ((l1 = (struct pipe_list ) malloc (sizeof (l1)))
9731c6ca LM	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 LM	61	}
	62
	63	int
2b96b0a5	64	djgpp_pclose (FILE *pp)
39e571d4	65	{
9731c6ca LM	66	struct pipe_list l1, l2; / list pointers */
9731c6ca LM	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 */
9731c6ca LM	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
9731c6ca LM	83	&& (freopen (l1->fp->_name_to_remove, "rb", stdin)))
39e571d4	84	{
9731c6ca LM	85	retval = system (l1->command);
9731c6ca LM	86	dup2 (fd, fileno (stdin));
39e571d4	87	}
9731c6ca LM	88	close (fd);
9731c6ca LM	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 LM	98	}
39e571d4 LM	99
39e571d4 LM	100	/**/
	101
	102	#define EXECF_SPAWN 0
	103	#define EXECF_EXEC 1
	104
	105	static int
41cd3736	106	convretcode (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 LM	114	}
	115
	116	int
41cd3736	117	do_aspawn (pTHX_ SV really,SV mark,SV *sp)
39e571d4	118	{
39e571d4 LM	119	int rc;
39e571d4 LM	120	char *a,tmps,**argv;
2d8e6c8d	121	STRLEN n_a;
39e571d4 LM	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 LM	130	else
39e571d4 LM	131	*a++ = "";
4e205ed6	132	*a = NULL;
39e571d4 LM	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 LM	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
41cd3736	151	do_spawn2 (pTHX_ char *cmd,int execf)
39e571d4 LM	152	{
	153	char *a,s,shell,metachars;
	154	int rc,unixysh;
	155
	156	if ((shell=getenv("SHELL"))==NULL && (shell=getenv("COMSPEC"))==NULL)
	157	shell="c:\\command.com" EXTRA;
	158
	159	unixysh=_is_unixy_shell (shell);
	160	metachars=unixysh ? "$&(){}[]'\";\\?>\|<~`\n" EXTRA : "?[\|<>\"\\" EXTRA;
	161
	162	while (cmd && isSPACE(cmd))
	163	cmd++;
	164
	165	if (strnEQ (cmd,"/bin/sh",7) && isSPACE (cmd[7]))
	166	cmd+=5;
	167
	168	/* save an extra exec if possible */
	169	/* see if there are shell metacharacters in it */
	170	if (strstr (cmd,"..."))
	171	goto doshell;
	172	if (unixysh)
	173	{
	174	if (*cmd=='.' && isSPACE (cmd[1]))
	175	goto doshell;
	176	if (strnEQ (cmd,"exec",4) && isSPACE (cmd[4]))
	177	goto doshell;
	178	for (s=cmd; s && isALPHA (s); s++) ; /* catch VAR=val gizmo */
	179	if (*s=='=')
	180	goto doshell;
	181	}
	182	for (s=cmd; *s; s++)
	183	if (strchr (metachars,*s))
	184	{
	185	if (*s=='\n' && s[1]=='\0')
	186	{
	187	*s='\0';
	188	break;
	189	}
	190	doshell:
	191	if (execf==EXECF_EXEC)
	192	return convretcode (execl (shell,shell,unixysh ? "-c" : "/c",cmd,NULL),cmd,execf);
	193	return convretcode (system (cmd),cmd,execf);
	194	}
	195
a02a5408	196	Newx (PL_Argv,(s-cmd)/2+2,char*);
6b88bc9c GS	197	PL_Cmd=savepvn (cmd,s-cmd);
	198	a=PL_Argv;
	199	for (s=PL_Cmd; *s;) {
39e571d4 LM	200	while (s && isSPACE (s)) s++;
	201	if (*s)
	202	*(a++)=s;
	203	while (s && !isSPACE (s)) s++;
	204	if (*s)
	205	*s++='\0';
	206	}
4e205ed6	207	*a=NULL;
6b88bc9c	208	if (!PL_Argv[0])
39e571d4 LM	209	return -1;
	210
	211	if (execf==EXECF_EXEC)
6b88bc9c	212	rc=execvp (PL_Argv[0],PL_Argv);
39e571d4	213	else
6b88bc9c GS	214	rc=spawnvp (P_WAIT,PL_Argv[0],PL_Argv);
6b88bc9c GS	215	return convretcode (rc,PL_Argv[0],execf);
39e571d4 LM	216	}
	217
	218	int
41cd3736	219	do_spawn (pTHX_ char *cmd)
39e571d4	220	{
41cd3736	221	return do_spawn2 (aTHX_ cmd,EXECF_SPAWN);
39e571d4 LM	222	}
	223
	224	bool
e670e57a	225	Perl_do_exec (pTHX_ const char *cmd)
39e571d4	226	{
41cd3736	227	do_spawn2 (aTHX_ cmd,EXECF_EXEC);
39e571d4 LM	228	return FALSE;
	229	}
	230
	231	/**/
	232
	233	struct globinfo
	234	{
	235	int fd;
	236	char *matches;
	237	size_t size;
933fea7f	238	fpos_t pos;
39e571d4 LM	239	};
	240
	241	#define MAXOPENGLOBS 10
	242
	243	static struct globinfo myglobs[MAXOPENGLOBS];
	244
	245	static struct globinfo *
	246	searchfd (int fd)
	247	{
	248	int ic;
	249	for (ic=0; ic<MAXOPENGLOBS; ic++)
	250	if (myglobs[ic].fd==fd)
	251	return myglobs+ic;
	252	return NULL;
	253	}
	254
	255	static int
	256	glob_handler (__FSEXT_Fnumber n,int *rv,va_list args)
	257	{
	258	unsigned ic;
	259	struct globinfo *gi;
	260	switch (n)
	261	{
	262	case __FSEXT_open:
	263	{
	264	char p1,pattern,name=va_arg (args,char);
	265	STRLEN len;
	266	glob_t pglob;
	267
	268	if (strnNE (name,"/dev/dosglob/",13))
	269	break;
	270	if ((gi=searchfd (-1)) == NULL)
	271	break;
	272
933fea7f	273	gi->pos=0;
39e571d4 LM	274	pattern=alloca (strlen (name+=13)+1);
	275	strcpy (pattern,name);
	276	if (!_USE_LFN)
	277	strlwr (pattern);
	278	ic=pglob.gl_pathc=0;
	279	pglob.gl_pathv=NULL;
	280	while (pattern)
	281	{
	282	if ((p1=strchr (pattern,' '))!=NULL)
	283	*p1=0;
	284	glob (pattern,ic,0,&pglob);
	285	ic=GLOB_APPEND;
	286	if ((pattern=p1)!=NULL)
	287	pattern++;
	288	}
	289	for (ic=len=0; ic<pglob.gl_pathc; ic++)
	290	len+=1+strlen (pglob.gl_pathv[ic]);
	291	if (len)
	292	{
	293	if ((gi->matches=p1=(char*) malloc (gi->size=len))==NULL)
	294	break;
	295	for (ic=0; ic<pglob.gl_pathc; ic++)
	296	{
	297	strcpy (p1,pglob.gl_pathv[ic]);
	298	p1+=strlen (p1)+1;
	299	}
	300	}
	301	else
	302	{
	303	if ((gi->matches=strdup (name))==NULL)
	304	break;
	305	gi->size=strlen (name)+1;
	306	}
	307	globfree (&pglob);
	308	gi->fd=*rv=__FSEXT_alloc_fd (glob_handler);
	309	return 1;
	310	}
	311	case __FSEXT_read:
	312	{
	313	int fd=va_arg (args,int);
	314	char buf=va_arg (args,char);
	315	size_t siz=va_arg (args,size_t);
	316
	317	if ((gi=searchfd (fd))==NULL)
	318	break;
	319
933fea7f GS	320	if (siz+gi->pos > gi->size)
	321	siz = gi->size - gi->pos;
	322	memcpy (buf,gi->pos+gi->matches,siz);
	323	gi->pos += siz;
39e571d4 LM	324	*rv=siz;
	325	return 1;
	326	}
	327	case __FSEXT_close:
	328	{
	329	int fd=va_arg (args,int);
	330
	331	if ((gi=searchfd (fd))==NULL)
	332	break;
	333	free (gi->matches);
	334	gi->fd=-1;
	335	break;
	336	}
	337	default:
	338	break;
	339	}
	340	return 0;
	341	}
	342
	343	static
	344	XS(dos_GetCwd)
	345	{
	346	dXSARGS;
	347
	348	if (items)
41cd3736	349	Perl_croak (aTHX_ "Usage: Dos::GetCwd()");
39e571d4 LM	350	{
	351	char tmp[PATH_MAX+2];
	352	ST(0)=sv_newmortal ();
	353	if (getcwd (tmp,PATH_MAX+1)!=NULL)
	354	sv_setpv ((SV*)ST(0),tmp);
ebdd4fa0	355	SvTAINTED_on(ST(0));
39e571d4 LM	356	}
	357	XSRETURN (1);
	358	}
	359
	360	static
	361	XS(dos_UseLFN)
	362	{
	363	dXSARGS;
	364	XSRETURN_IV (_USE_LFN);
	365	}
	366
d835d330 JH	367	XS(XS_Cwd_sys_cwd)
	368	{
	369	dXSARGS;
	370	if (items != 0)
	371	Perl_croak_nocontext("Usage: Cwd::sys_cwd()");
	372	{
	373	char p[MAXPATHLEN];
	374	char * RETVAL;
	375	RETVAL = getcwd(p, MAXPATHLEN);
	376	ST(0) = sv_newmortal();
	377	sv_setpv((SV*)ST(0), RETVAL);
d835d330	378	SvTAINTED_on(ST(0));
d835d330 JH	379	}
	380	XSRETURN(1);
	381	}
	382
39e571d4	383	void
41cd3736	384	Perl_init_os_extras(pTHX)
39e571d4 LM	385	{
	386	char *file = __FILE__;
	387
	388	dXSUB_SYS;
	389
	390	newXS ("Dos::GetCwd",dos_GetCwd,file);
	391	newXS ("Dos::UseLFN",dos_UseLFN,file);
d835d330	392	newXS ("Cwd::sys_cwd",XS_Cwd_sys_cwd,file);
39e571d4 LM	393
	394	/* install my File System Extension for globbing */
	395	__FSEXT_add_open_handler (glob_handler);
	396	memset (myglobs,-1,sizeof (myglobs));
	397	}
	398
	399	static char *perlprefix;
	400
	401	#define PERL5 "/perl5"
	402
af89d9af JH	403	char *
af89d9af JH	404	djgpp_pathexp (const char *p)
39e571d4 LM	405	{
	406	static char expp[PATH_MAX];
	407	strcpy (expp,perlprefix);
	408	switch (p[0])
	409	{
	410	case 'B':
	411	strcat (expp,"/bin");
	412	break;
	413	case 'S':
	414	strcat (expp,"/lib" PERL5 "/site");
	415	break;
	416	default:
	417	strcat (expp,"/lib" PERL5);
	418	break;
	419	}
	420	return expp;
	421	}
	422
	423	void
	424	Perl_DJGPP_init (int argcp,char **argvp)
	425	{
	426	char *p;
	427
	428	perlprefix=strdup (**argvp);
	429	strlwr (perlprefix);
	430	if ((p=strrchr (perlprefix,'/'))!=NULL)
	431	{
	432	*p=0;
	433	if (strEQ (p-4,"/bin"))
	434	p[-4]=0;
	435	}
	436	else
	437	strcpy (perlprefix,"..");
	438	}
	439
05af4e39 PFI	440	int
	441	djgpp_fflush (FILE *fp)
	442	{
	443	int res;
	444
	445	if ((res = fflush(fp)) == 0 && fp) {
	446	Stat_t s;
	447	if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
	448	res = fsync(fileno(fp));
	449	}
	450	/*
	451	* If the flush succeeded but set end-of-file, we need to clear
	452	* the error because our caller may check ferror(). BTW, this
	453	* probably means we just flushed an empty file.
	454	*/
	455	if (res == 0 && fp && ferror(fp) == EOF) clearerr(fp);
	456
	457	return res;
	458	}
a5936e02 JH	459
	460	int djgpp_get_stream_mode(FILE *f)
	461	{
	462	extern char *__file_handle_modes;
	463
	464	int mode = __file_handle_modes[fileno(f)];
	465	if (f->_flag & _IORW)
	466	return mode \| O_RDWR;
	467	if (f->_flag & _IOWRT)
	468	return mode \| O_WRONLY;
	469	return mode \| O_RDONLY;
	470	}
	471