From: Jarkko Hietaniemi Date: Fri, 28 Jun 2002 13:15:17 +0000 (+0000) Subject: NetWare update from Ananth Kesari. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=1a95e36d92295cabb6c213a2f397c4cb7614d12c;p=p5sagit%2Fp5-mst-13.2.git NetWare update from Ananth Kesari. p4raw-id: //depot/perl@17376 --- diff --git a/NetWare/Makefile b/NetWare/Makefile index 21136d8..8ae8f50 100644 --- a/NetWare/Makefile +++ b/NetWare/Makefile @@ -360,8 +360,8 @@ EXTENSION_NLM = \ # Begin - Following is required to build NetWare specific extensions CGI2Perl, Perl2UCS and UCSExt CGI2PERL = CGI2Perl\CGI2Perl -PERL2UCS = $(EXTDIR)\Perl2UCS\Perl2UCS -UCSExt = $(EXTDIR)\Perl2UCS\UCSExt +PERL2UCS = Perl2UCS\Perl2UCS +UCSExt = Perl2UCS\UCSExt CGI2PERL_NLM = \CGI2Perl\CGI2Perl.NLM PERL2UCS_NLM = $(AUTODIR)\Perl2UCS\Perl2UCS.NLM @@ -1375,7 +1375,7 @@ $(CGI2PERL_NLM): $(PERL2UCS_NLM): !if "$(NW_EXTNS)"=="yes" - cd $(EXTDIR)\$(*B) + cd $(*B) ..\..\miniperl -I..\..\lib Makefile.PL "CCCDLFLAGS=-bool on -lang c++" PERL_CORE=1 INSTALLDIRS=perl $(MAKE) cd ..\..\netware @@ -1383,7 +1383,7 @@ $(PERL2UCS_NLM): $(UCSExt_NLM): !if "$(NW_EXTNS)"=="yes" - cd $(EXTDIR)\$(*B) + cd $(*B) ..\..\miniperl -I..\..\lib Makefile.PL "CCCDLFLAGS=-bool on -lang c++" PERL_CORE=1 INSTALLDIRS=perl $(MAKE) cd ..\..\netware @@ -1464,10 +1464,10 @@ distclean: clean nwclean cd cgi2perl -del /f /q *.obj *.bs Makefile *$(o) *.c pm_to_blib *.xdc *.err *.sym *.map *.def *.lib *.pdb cd .. - cd $(EXTDIR)\Perl2UCS + cd Perl2UCS -del /f /q *.obj *.bs Makefile *$(o) *.c pm_to_blib *.xdc *.err *.sym *.map *.def *.lib *.pdb cd ..\..\netware - cd $(EXTDIR)\UCSExt + cd UCSExt -del /f /q *.obj *.bs Makefile *$(o) *.c pm_to_blib *.xdc *.err *.sym *.map *.c cd ..\..\netware !endif diff --git a/NetWare/netware.h b/NetWare/netware.h index 6f65560..18089d5 100644 --- a/NetWare/netware.h +++ b/NetWare/netware.h @@ -49,6 +49,9 @@ struct tms { struct interp_intern { void * internal_host; long perlshell_items; // For system() ; Ananth, 3 Sept 2001 + + char * perlshell_tokens; // For system() ; From Win32 of Perl 5.8 on 24 June 2002 + char ** perlshell_vec; // For system() ; From Win32 of Perl 5.8 on 24 June 2002 }; /* @@ -69,6 +72,9 @@ typedef u_int SOCKET; #define nw_internal_host (PL_sys_intern.internal_host) #define nw_perlshell_items (PL_sys_intern.perlshell_items) // For system() ; Ananth, 3 Sept 2001 +#define nw_perlshell_tokens (PL_sys_intern.perlshell_tokens) // For system() ; From Win32 of Perl 5.8 on 24 June 2002 +#define nw_perlshell_vec (PL_sys_intern.perlshell_vec) // For system() ; From Win32 of Perl 5.8 on 24 June 2002 + EXTERN_C void Perl_nw5_init(int *argcp, char ***argvp); #define PTHREAD_ATFORK(prepare,parent,child) NOOP diff --git a/NetWare/nw5.c b/NetWare/nw5.c index fa57c6e..488111c 100644 --- a/NetWare/nw5.c +++ b/NetWare/nw5.c @@ -31,6 +31,12 @@ #define P_NOWAIT 1 #endif +#define EXECF_EXEC 1 +#define EXECF_SPAWN 2 +#define EXECF_SPAWN_NOWAIT 3 + +static BOOL has_shell_metachars(char *ptr); + // The array is used to store pointer to the memory allocated to the TempPipeFile structure everytime // a call to the function, nw_Popen. If a simple variable is used, everytime the memory is allocated before // the previously allocated memory is freed, the pointer will get overwritten and the previous memory allocations @@ -44,7 +50,6 @@ PTEMPPIPEFILE ptpf1[MAX_PIPE_RECURSION] = {'\0'}; int iPopenCount = 0; FILE* File1[MAX_PIPE_RECURSION] = {'\0'}; - /** General: @@ -917,7 +922,8 @@ do_aspawn(void *vreally, void **vmark, void **vsp) return -1; nw_perlshell_items = 0; // No Shell - New(1306, argv, (sp - mark) + nw_perlshell_items + 3, char*); +// New(1306, argv, (sp - mark) + nw_perlshell_items + 3, char*); // In the old code of 5.6.1 + New(1306, argv, (sp - mark) + nw_perlshell_items + 2, char*); if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) { ++mark; @@ -944,10 +950,9 @@ do_aspawn(void *vreally, void **vmark, void **vsp) (char*)(really ? SvPV_nolen(really) : argv[0]), (char**)argv); - if (flag != P_NOWAIT) { if (status < 0) { - dTHR; +// dTHR; // Only in old code of 5.6.1 if (ckWARN(WARN_EXEC)) Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't spawn \"%s\": %s", argv[0], strerror(errno)); status = 255 * 256; @@ -967,13 +972,145 @@ do_spawn2(char *cmd, int exectype) // This feature needs to be implemented. // _asm is commented out since it goes into the internal debugger. // _asm {int 3}; - return(0); +//// return(0); + + // Below added to make system() work for NetWare + + dTHX; + char **a; + char *s; + char **argv; + int status = -1; + BOOL needToTry = TRUE; + char *cmd2; + + /* Save an extra exec if possible. See if there are shell + * metacharacters in it */ + if (!has_shell_metachars(cmd)) { + New(1301,argv, strlen(cmd) / 2 + 2, char*); + New(1302,cmd2, strlen(cmd) + 1, char); + strcpy(cmd2, cmd); + a = argv; + for (s = cmd2; *s;) { + while (*s && isSPACE(*s)) + s++; + if (*s) + *(a++) = s; + while (*s && !isSPACE(*s)) + s++; + if (*s) + *s++ = '\0'; + } + *a = Nullch; + if (argv[0]) { + switch (exectype) { + case EXECF_SPAWN: + status = nw_spawnvp(P_WAIT, argv[0], (char **)argv); + break; + + case EXECF_SPAWN_NOWAIT: + status = nw_spawnvp(P_NOWAIT, argv[0], (char **)argv); + break; + + case EXECF_EXEC: + status = nw_execvp(argv[0], (char **)argv); + break; + } + if (status != -1 || errno == 0) + needToTry = FALSE; + } + Safefree(argv); + Safefree(cmd2); + } + + if (needToTry) { + char **argv = NULL; + int i = -1; + + New(1306, argv, nw_perlshell_items + 2, char*); + while (++i < nw_perlshell_items) + argv[i] = nw_perlshell_vec[i]; + argv[i++] = cmd; + argv[i] = Nullch; + switch (exectype) { + case EXECF_SPAWN: + status = nw_spawnvp(P_WAIT, argv[0], (char **)argv); + break; + + case EXECF_SPAWN_NOWAIT: + status = nw_spawnvp(P_NOWAIT, argv[0], (char **)argv); + break; + + case EXECF_EXEC: + status = nw_execvp(argv[0], (char **)argv); + break; + } + cmd = argv[0]; + Safefree(argv); + } + + if (exectype != EXECF_SPAWN_NOWAIT) { + if (status < 0) { + dTHR; + if (ckWARN(WARN_EXEC)) + Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s", + (exectype == EXECF_EXEC ? "exec" : "spawn"), + cmd, strerror(errno)); + status = 255 * 256; + } + else + status *= 256; + PL_statusvalue = status; + } + return (status); } int do_spawn(char *cmd) { - return do_spawn2(cmd, 2); + return do_spawn2(cmd, EXECF_SPAWN); +} + +// Added to make system() work for NetWare +static BOOL +has_shell_metachars(char *ptr) +{ + int inquote = 0; + char quote = '\0'; + + /* + * Scan string looking for redirection (< or >) or pipe + * characters (|) that are not in a quoted string. + * Shell variable interpolation (%VAR%) can also happen inside strings. + */ + while (*ptr) { + switch(*ptr) { + case '%': + return TRUE; + case '\'': + case '\"': + if (inquote) { + if (quote == *ptr) { + inquote = 0; + quote = '\0'; + } + } + else { + quote = *ptr; + inquote++; + } + break; + case '>': + case '<': + case '|': + if (!inquote) + return TRUE; + default: + break; + } + ++ptr; + } + return FALSE; } int diff --git a/ext/DynaLoader/DynaLoader_pm.PL b/ext/DynaLoader/DynaLoader_pm.PL index 2bed991..05fe3f7 100644 --- a/ext/DynaLoader/DynaLoader_pm.PL +++ b/ext/DynaLoader/DynaLoader_pm.PL @@ -237,6 +237,7 @@ sub bootstrap { # It may also edit @modparts if required. $modfname = &mod2fname(\@modparts) if defined &mod2fname; + # Truncate the module name to 8.3 format for NetWare if (($^O eq 'NetWare') && (length($modfname) > 8)) { $modfname = substr($modfname, 0, 8); } @@ -262,22 +263,13 @@ sub bootstrap { } else { $dir = "$_/auto/$modpname"; } - if ($^O ne 'NetWare') { - next unless -d $dir; # skip over uninteresting directories - } - else { - next if -f $dir; # skip over uninteresting directories - } - + + next unless -d $dir; # skip over uninteresting directories + # check for common cases to avoid autoload of dl_findfile my $try = $Is_MacOS ? "$dir:$modfname.$dl_dlext" : "$dir/$modfname.$dl_dlext"; - if ($^O ne 'NetWare') { - last if $file = ($do_expand) ? dl_expandspec($try) : ((-f $try) && $try); - } - elsif (!(-d $try)) { - last if $file = ($do_expand) ? dl_expandspec($try) : ($try); - } - + last if $file = ($do_expand) ? dl_expandspec($try) : ((-f $try) && $try); + # no luck here, save dir for possible later dl_findfile search push @dirs, $dir; } diff --git a/lib/ExtUtils/MM_NW5.pm b/lib/ExtUtils/MM_NW5.pm index 03a565f..a91e09b 100644 --- a/lib/ExtUtils/MM_NW5.pm +++ b/lib/ExtUtils/MM_NW5.pm @@ -124,10 +124,10 @@ XS_DEFINE_VERSION = -D\$(XS_VERSION_MACRO)=\\\"\$(XS_VERSION)\\\" # Copy this to makefile as INCLUDE = d:\...;d:\; (my $inc = $Config{'incpath'}) =~ s/([ ]*)-I/;/g; - # Get the additional include path and append to INCLUDE, keeping it - # in INC will give problems during compilation, hence reset it - # after getting the value - $self->{INC} = ''; + # Get the additional include path from the user through the command prompt + # and append to INCLUDE +# $self->{INC} = ''; + push @m, "INC = $self->{'INC'}\n"; push @m, qq{ INCLUDE = $inc;