perl5.git.perl.org Git - perl5.git/blame_incremental

... / ...

Commit	Line	Data
	1	/*
	2	* Cygwin extras
	3	*/
	4
	5	#include "EXTERN.h"
	6	#include "perl.h"
	7	#undef USE_DYNAMIC_LOADING
	8	#include "XSUB.h"
	9
	10	#include <unistd.h>
	11	#include <process.h>
	12
	13	/*
	14	* pp_system() implemented via spawn()
	15	* - more efficient and useful when embedding Perl in non-Cygwin apps
	16	* - code mostly borrowed from djgpp.c
	17	*/
	18	static int
	19	do_spawnvp (const char path, const char const *argv)
	20	{
	21	dTHXo;
	22	Sigsave_t ihand,qhand;
	23	int childpid, result, status;
	24
	25	rsignal_save(SIGINT, SIG_IGN, &ihand);
	26	rsignal_save(SIGQUIT, SIG_IGN, &qhand);
	27	childpid = spawnvp(_P_NOWAIT,path,argv);
	28	if (childpid < 0) {
	29	status = -1;
	30	if(ckWARN(WARN_EXEC))
	31	Perl_warner(aTHX_ WARN_EXEC,"Can't spawn \"%s\": %s",
	32	path,Strerror (errno));
	33	} else {
	34	do {
	35	result = wait4pid(childpid, &status, 0);
	36	} while (result == -1 && errno == EINTR);
	37	if(result < 0)
	38	status = -1;
	39	}
	40	(void)rsignal_restore(SIGINT, &ihand);
	41	(void)rsignal_restore(SIGQUIT, &qhand);
	42	return status;
	43	}
	44
	45	int
	46	do_aspawn (SV really, void mark, void *sp)
	47	{
	48	dTHXo;
	49	int rc;
	50	char *a,tmps,**argv;
	51	STRLEN n_a;
	52
	53	if (sp<=mark)
	54	return -1;
	55	a=argv=(char*) alloca ((sp-mark+3)sizeof (char*));
	56
	57	while (++mark <= sp)
	58	if (*mark)
	59	a++ = SvPVx(mark, n_a);
	60	else
	61	*a++ = "";
	62	*a = Nullch;
	63
	64	if (argv[0][0] != '/' && argv[0][0] != '\\'
	65	&& !(argv[0][0] && argv[0][1] == ':'
	66	&& (argv[0][2] == '/' \|\| argv[0][2] != '\\'))
	67	) /* will swawnvp use PATH? */
	68	TAINT_ENV(); /* testing IFS here is overkill, probably */
	69
	70	if (really && *(tmps = SvPV(really, n_a)))
	71	rc=do_spawnvp (tmps,(const char * const *)argv);
	72	else
	73	rc=do_spawnvp (argv[0],(const char const )argv);
	74
	75	return rc;
	76	}
	77
	78	int
	79	do_spawn (char *cmd)
	80	{
	81	dTHXo;
	82	char *a,s,metachars = "$&(){}[]'\";\\?>\|<~`\n";
	83	const char *command[4];
	84
	85	while (cmd && isSPACE(cmd))
	86	cmd++;
	87
	88	if (strnEQ (cmd,"/bin/sh",7) && isSPACE (cmd[7]))
	89	cmd+=5;
	90
	91	/* save an extra exec if possible */
	92	/* see if there are shell metacharacters in it */
	93	if (strstr (cmd,"..."))
	94	goto doshell;
	95	if (*cmd=='.' && isSPACE (cmd[1]))
	96	goto doshell;
	97	if (strnEQ (cmd,"exec",4) && isSPACE (cmd[4]))
	98	goto doshell;
	99	for (s=cmd; s && isALPHA (s); s++) ; /* catch VAR=val gizmo */
	100	if (*s=='=')
	101	goto doshell;
	102
	103	for (s=cmd; *s; s++)
	104	if (strchr (metachars,*s))
	105	{
	106	if (*s=='\n' && s[1]=='\0')
	107	{
	108	*s='\0';
	109	break;
	110	}
	111	doshell:
	112	command[0] = "sh";
	113	command[1] = "-c";
	114	command[2] = cmd;
	115	command[3] = NULL;
	116
	117	return do_spawnvp("sh",command);
	118	}
	119
	120	New (1303,PL_Argv,(s-cmd)/2+2,char*);
	121	PL_Cmd=savepvn (cmd,s-cmd);
	122	a=PL_Argv;
	123	for (s=PL_Cmd; *s;) {
	124	while (s && isSPACE (s)) s++;
	125	if (*s)
	126	*(a++)=s;
	127	while (s && !isSPACE (s)) s++;
	128	if (*s)
	129	*s++='\0';
	130	}
	131	*a=Nullch;
	132	if (!PL_Argv[0])
	133	return -1;
	134
	135	return do_spawnvp(PL_Argv[0],(const char * const *)PL_Argv);
	136	}
	137
	138	/* see also Cwd.pm */
	139	static
	140	XS(Cygwin_cwd)
	141	{
	142	dXSARGS;
	143	char *cwd;
	144
	145	if(items != 0)
	146	Perl_croak(aTHX_ "Usage: Cwd::cwd()");
	147	if((cwd = getcwd(NULL, -1))) {
	148	ST(0) = sv_2mortal(newSVpv(cwd, 0));
	149	safesysfree(cwd);
	150	XSRETURN(1);
	151	}
	152	XSRETURN_UNDEF;
	153	}
	154
	155	void
	156	init_os_extras(void)
	157	{
	158	char *file = __FILE__;
	159	dTHX;
	160
	161	newXS("Cwd::cwd", Cygwin_cwd, file);
	162	}