NetWare update from Ananth Kesari.
authorJarkko Hietaniemi <jhi@iki.fi>
Fri, 28 Jun 2002 13:15:17 +0000 (13:15 +0000)
committerJarkko Hietaniemi <jhi@iki.fi>
Fri, 28 Jun 2002 13:15:17 +0000 (13:15 +0000)
p4raw-id: //depot/perl@17376

NetWare/Makefile
NetWare/netware.h
NetWare/nw5.c
ext/DynaLoader/DynaLoader_pm.PL
lib/ExtUtils/MM_NW5.pm

index 21136d8..8ae8f50 100644 (file)
@@ -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
index 6f65560..18089d5 100644 (file)
@@ -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
index fa57c6e..488111c 100644 (file)
 #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
index 2bed991..05fe3f7 100644 (file)
@@ -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;
     }
index 03a565f..a91e09b 100644 (file)
@@ -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;