Accept filespecs as command verbs for subprocesses

p4raw-id: //depot/vmsperl@5280

diff --git a/vms/perlvms.pod b/vms/perlvms.pod
index 1705bf8..53925b2 100644 (file)
--- a/vms/perlvms.pod
+++ b/vms/perlvms.pod
@@ -194,11 +194,13 @@ so we can try to work around them.
 =head2 Wildcard expansion
 
 File specifications containing wildcards are allowed both on 
-the command line and within Perl globs (e.g. <CE<lt>*.cE<gt>>).  If 
+the command line and within Perl globs (e.g. <CE<lt>*.cE<gt>>).  If
 the wildcard filespec uses VMS syntax, the resultant 
 filespecs will follow VMS syntax; if a Unix-style filespec is 
 passed in, Unix-style filespecs will be returned.
 
+In both cases, VMS wildcard expansion is performed. (csh-style
+wildcard expansion is available if you use C<File::Glob::glob>.)
 If the wildcard filespec contains a device or directory 
 specification, then the resultant filespecs will also contain 
 a device and directory; otherwise, device and directory 
@@ -225,9 +227,9 @@ subprocesses around when Perl exits.
 
 You may also use backticks to invoke a DCL subprocess, whose 
 output is used as the return value of the expression.  The 
-string between the backticks is passed directly to lib$spawn 
-as the command to execute.  In this case, Perl will wait for 
-the subprocess to complete before continuing. 
+string between the backticks is handled as if it were the
+argument to the C<system> operator (see below).  In this case,
+Perl will wait for the subprocess to complete before continuing. 
 
 =head1 PERL5LIB and PERLLIB
 
@@ -456,7 +458,7 @@ handlers to the subprocess are limited.)
 If the call to C<exec> does not follow a call to C<fork>, it 
 will cause Perl to exit, and to invoke the command given as 
 an argument to C<exec> via C<lib$do_command>.  If the argument 
-begins with a '$' (other than as part of a filespec), then it 
+begins with '@' or '$' (other than as part of a filespec), then it 
 is executed as a DCL command.  Otherwise, the first token on 
 the command line is treated as the filespec of an image to 
 run, and an attempt is made to invoke it (using F<.Exe> and 
@@ -549,7 +551,14 @@ though, so caveat scriptor.
 The C<system> operator creates a subprocess, and passes its 
 arguments to the subprocess for execution as a DCL command.  
 Since the subprocess is created directly via C<lib$spawn()>, any 
-valid DCL command string may be specified.  If LIST consists
+valid DCL command string may be specified.  If the string begins with
+'@', it is treated as a DCL command unconditionally.  Otherwise, if
+the first token contains a character used as a delimiter in file
+specification (e.g. C<:> or C<]>), an attempt is made to expand it
+using  a default type of F<.Exe> and the process defaults, and if
+successful, the resulting file is invoked via C<MCR>. This allows you
+to invoke an image directly simply by passing the file specification
+to C<system>, a common Unixish idiom.  If LIST consists
 of the empty string, C<system> spawns an interactive DCL subprocess,
 in the same fashion as typiing B<SPAWN> at the DCL prompt.
 Perl waits for the subprocess to complete before continuing
@@ -846,11 +855,10 @@ problems.
 
 =head1 Revision date
 
-This document was last updated on 26-Feb-1998, for Perl 5, 
-patchlevel 5.
+This document was last updated on 26-Feb-2000, for Perl 5, 
+patchlevel 6.
 
 =head1 AUTHOR
 
-Charles Bailey  bailey@cor.newman.upenn.edu
-
-Last revision by Dan Sugalski  sugalskd@ous.edu
+Charles Bailey  <bailey@cor.newman.upenn.edu>
+Dan Sugalski  <dan@sidhe.org>

diff --git a/vms/vms.c b/vms/vms.c
index fac9243..c80de00 100644 (file)
--- a/vms/vms.c
+++ b/vms/vms.c
@@ -2,7 +2,7 @@
  *
  * VMS-specific routines for perl5
  *
- * Last revised: 15-Aug-1999 by Charles Bailey  bailey@newman.upenn.edu
+ * Last revised: 24-Feb-2000 by Charles Bailey  bailey@newman.upenn.edu
  * Version: 5.5.60
  */
 
@@ -95,6 +95,9 @@ static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */
 /* munching */ 
 static int no_translate_barewords;
 
+/* Temp for subprocess commands */
+static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
+
 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 int
 vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
@@ -1025,13 +1028,16 @@ popen_completion_ast(struct pipe_details *thispipe)
   }
 }
 
+static unsigned long int setup_cmddsc(char *cmd, int check_img);
+static void vms_execfree();
+
 static PerlIO *
 safe_popen(char *cmd, char *mode)
 {
     static int handler_set_up = FALSE;
     char mbxname[64];
     unsigned short int chan;
-    unsigned long int flags=1;  /* nowait - gnu c doesn't allow &1 */
+    unsigned long int sts, flags=1;  /* nowait - gnu c doesn't allow &1 */
     dTHX;
     struct pipe_details *info;
     struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T,
@@ -1040,13 +1046,7 @@ safe_popen(char *cmd, char *mode)
                                       DSC$K_CLASS_S, 0};
                             
 
-    cmddsc.dsc$w_length=strlen(cmd);
-    cmddsc.dsc$a_pointer=cmd;
-    if (cmddsc.dsc$w_length > 255) {
-      set_errno(E2BIG); set_vaxc_errno(CLI$_BUFOVF);
-      return Nullfp;
-    }
-
+    if (!(setup_cmddsc(cmd,0) & 1)) { set_errno(EINVAL); return Nullfp; }
     New(1301,info,1,struct pipe_details);
 
     /* create mailbox */
@@ -1066,16 +1066,17 @@ safe_popen(char *cmd, char *mode)
     info->completion=0;
         
     if (*mode == 'r') {
-      _ckvmssts(lib$spawn(&cmddsc, &nl_desc, &namdsc, &flags,
+      _ckvmssts(lib$spawn(&VMScmd, &nl_desc, &namdsc, &flags,
                      0  /* name */, &info->pid, &info->completion,
                      0, popen_completion_ast,info,0,0,0));
     }
     else {
-      _ckvmssts(lib$spawn(&cmddsc, &namdsc, 0 /* sys$output */, &flags,
+      _ckvmssts(lib$spawn(&VMScmd, &namdsc, 0 /* sys$output */, &flags,
                      0  /* name */, &info->pid, &info->completion,
                      0, popen_completion_ast,info,0,0,0));
     }
 
+    vms_execfree();
     if (!handler_set_up) {
       _ckvmssts(sys$dclexh(&pipe_exitblock));
       handler_set_up = TRUE;
@@ -3286,12 +3287,10 @@ my_vfork()
 /*}}}*/
 
 
-static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
-
 static void
 vms_execfree() {
   if (PL_Cmd) {
-    Safefree(PL_Cmd);
+    if (PL_Cmd != VMScmd.dsc$a_pointer) Safefree(PL_Cmd);
     PL_Cmd = Nullch;
   }
   if (VMScmd.dsc$a_pointer) {
@@ -3349,38 +3348,69 @@ setup_argstr(SV *really, SV **mark, SV **sp)
 static unsigned long int
 setup_cmddsc(char *cmd, int check_img)
 {
-  char resspec[NAM$C_MAXRSS+1];
+  char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
   $DESCRIPTOR(defdsc,".EXE");
   $DESCRIPTOR(resdsc,resspec);
   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
-  register char *s, *rest, *cp;
-  register int isdcl = 0;
+  register char *s, *rest, *cp, *wordbreak;
+  register int isdcl;
   dTHX;
 
+  if (strlen(cmd) >
+      (sizeof(vmsspec) > sizeof(resspec) ? sizeof(resspec) : sizeof(vmsspec)))
+    return LIB$_INVARG;
   s = cmd;
   while (*s && isspace(*s)) s++;
-  if (check_img) {
-    if (*s == '$') { /* Check whether this is a DCL command: leading $ and */
-      isdcl = 1;     /* no dev/dir separators (i.e. not a foreign command) */
-      for (cp = s; *cp && *cp != '/' && !isspace(*cp); cp++) {
-        if (*cp == ':' || *cp == '[' || *cp == '<') {
-          isdcl = 0;
-          break;
-        }
+
+  if (*s == '@' || *s == '$') {
+    vmsspec[0] = *s;  rest = s + 1;
+    for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
+  }
+  else { cp = vmsspec; rest = s; }
+  if (*rest == '.' || *rest == '/') {
+    char *cp2;
+    for (cp2 = resspec;
+         *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
+         rest++, cp2++) *cp2 = *rest;
+    *cp2 = '\0';
+    if (do_tovmsspec(resspec,cp,0)) { 
+      s = vmsspec;
+      if (*rest) {
+        for (cp2 = vmsspec + strlen(vmsspec);
+             *rest && cp2 - vmsspec < sizeof vmsspec;
+             rest++, cp2++) *cp2 = *rest;
+        *cp2 = '\0';
       }
     }
   }
-  else isdcl = 1;
+  /* Intuit whether verb (first word of cmd) is a DCL command:
+   *   - if first nonspace char is '@', it's a DCL indirection
+   * otherwise
+   *   - if verb contains a filespec separator, it's not a DCL command
+   *   - if it doesn't, caller tells us whether to default to a DCL
+   *     command, or to a local image unless told it's DCL (by leading '$')
+   */
+  if (*s == '@') isdcl = 1;
+  else {
+    register char *filespec = strpbrk(s,":<[.;");
+    rest = wordbreak = strpbrk(s," \"\t/");
+    if (!wordbreak) wordbreak = s + strlen(s);
+    if (*s == '$') check_img = 0;
+    if (filespec && (filespec < wordbreak)) isdcl = 0;
+    else isdcl = !check_img;
+  }
+
   if (!isdcl) {
-    cmd = s;
-    while (*s && !isspace(*s)) s++;
-    rest = *s ? s : 0;
-    imgdsc.dsc$a_pointer = cmd;
-    imgdsc.dsc$w_length = s - cmd;
+    imgdsc.dsc$a_pointer = s;
+    imgdsc.dsc$w_length = wordbreak - s;
     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
-    if (retsts & 1) {
+    if (!(retsts & 1) && *s == '$') {
+      imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
+      retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
       _ckvmssts(lib$find_file_end(&cxt));
+    }
+    if (retsts & 1) {
       s = resspec;
       while (*s && !isspace(*s)) s++;
       *s = '\0';
@@ -3397,10 +3427,7 @@ setup_cmddsc(char *cmd, int check_img)
   }
   /* It's either a DCL command or we couldn't find a suitable image */
   VMScmd.dsc$w_length = strlen(cmd);
-  if (cmd == PL_Cmd) {
-    VMScmd.dsc$a_pointer = PL_Cmd;
-    PL_Cmd = Nullch;  /* Don't try to free twice in vms_execfree() */
-  }
+  if (cmd == PL_Cmd) VMScmd.dsc$a_pointer = PL_Cmd;
   else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
   if (!(retsts & 1)) {
     /* just hand off status values likely to be due to user error */