This adds a functionality to Perl on VMS. I suppose that there is a
test already for this that is being skipped or marked TODO on VMS, since
it was not showing up as a test failure.
Also start of internal enhancements to rmsexpand(). Several internal
VMS Perl operations need a VMS file specification that fits in 255
characters, so option flags are added. Symbolic link support means that
rmsexpand() has to know when to report on the symbolic link path and not
the target as would be the default behavior.
I cobbled up the following to test it in the mean time:
With no PERL verb or /USR available.
$ mcr []ndbgperl parent.pl
%DCL-W-IVVERB, unrecognized command verb - check validity and spelling
\PERL\
Show the versions involved:
$ perl :== $gnu:[usr.bin]perl.
$ perl --version
This is perl, v5.8.7 built for VMS_AXP
$ mcr []ndbgperl --version
This is perl, v5.9.3 built for VMS_AXP
Demonstration of fall back to DCL verb working if the requested program
can not be found from the name in the script.
$ show log usr
%SHOW-S-NOTRAN, no translation for logical name USR
$ show sym perl
PERL == "$GNU:[USR.BIN]PERL."
$ mcr []ndbgperl parent.pl
child has run
hello world
Make the path /usr/bin/perl resolve and get rid of the fallback definition.
$ def usr gnu:[usr]
$ del/sym/glo perl
$ mcr []ndbgperl parent.pl
child has run
hello world
Test files:
$ type parent.pl
my $filename = "child.pl foo|";
open (CHILD_PROC, $filename) or print STDERR "Can't open `$filename'\n";
my @lines = <CHILD_PROC>;
print @lines if @lines;
close CHILD_PROC;
$ type child.pl
#! /usr/bin/perl -t
print "\n hello world\n";
print STDERR "\n child has run\n";
-John
[EMAIL PROTECTED]
Personal Opinion Only
--- /rsync_root/perl/vms/vmsish.h Tue Oct 18 05:08:00 2005
+++ vms/vmsish.h Tue Oct 18 12:43:43 2005
@@ -5,7 +5,7 @@
* revised: 16-Sep-1998 by Charles Bailey [EMAIL PROTECTED]
* Version: 5.5.2
*
- * Last revised: 01-Feb-2005 by John Malmberg (HP OpenVMS) [EMAIL PROTECTED]
+ * Last revised: 10-Oct-2005 by John Malmberg (HP OpenVMS) [EMAIL PROTECTED]
* Add SYMLINK support, and updated Craig Berry's
* largefile support.
*/
@@ -936,5 +936,10 @@
#endif
#define NO_ENVIRON_ARRAY
+
+/* RMSEXPAND options */
+#define PERL_RMSEXPAND_M_VMS 0x02 /* Force output to VMS format */
+#define PERL_RMSEXPAND_M_LONG 0x04 /* Expand to long name format */
+#define PERL_RMSEXPAND_M_SYMLINK 0x20 /* Use symbolic link, not target */
#endif /* __vmsish_h_included */
--- /rsync_root/perl/vms/vms.c Tue Oct 18 05:07:59 2005
+++ vms/vms.c Tue Oct 18 13:16:27 2005
@@ -1268,7 +1268,7 @@
}
else {
Newx(rspec, NAM$C_MAXRSS+1, char);
- if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) {
+ if (do_rmsexpand(vmsname, rspec, 1, NULL, PERL_RMSEXPAND_M_VMS) == NULL)
{
Safefree(rspec);
Safefree(vmsname);
return -1;
@@ -3747,6 +3747,9 @@
* specification string. The fourth argument is unused at present.
* rmesexpand() returns the address of the resultant string if
* successful, and NULL on error.
+ *
+ * New functionality for previously unused opts value:
+ * PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
*/
static char *mp_do_tounixspec(pTHX_ const char *, char *, int);
@@ -3898,6 +3901,9 @@
/* Have we been working with an expanded, but not resultant, spec? */
/* Also, convert back to Unix syntax if necessary. */
+ if ((opts & PERL_RMSEXPAND_M_VMS) != 0)
+ isunix = 0;
+
if (!mynam.nam$b_rsl) {
if (isunix) {
if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
@@ -7218,6 +7224,8 @@
struct dsc$descriptor_s **pvmscmd)
{
char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
+ char image_name[NAM$C_MAXRSS+1];
+ char image_argv[NAM$C_MAXRSS+1];
$DESCRIPTOR(defdsc,".EXE");
$DESCRIPTOR(defdsc2,".");
$DESCRIPTOR(resdsc,resspec);
@@ -7236,6 +7244,8 @@
Newx(cmd, cmdlen+1, char);
strncpy(cmd, incmd, cmdlen);
cmd[cmdlen] = 0;
+ image_name[0] = 0;
+ image_argv[0] = 0;
vmscmd->dsc$a_pointer = NULL;
vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
@@ -7320,16 +7330,107 @@
*s = '\0';
/* check that it's really not DCL with no file extension */
- fp = fopen(resspec,"r","ctx=bin","shr=get");
+ fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
if (fp) {
char b[256] = {0,0,0,0};
read(fileno(fp), b, 256);
isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) &&
isprint(b[3]);
if (isdcl) {
+ int shebang_len;
+
/* Check for script */
- if ((b[0] == '#') && (b[1] == '!')) {
- /* Image is following after white space */
+ shebang_len = 0;
+ if ((b[0] == '#') && (b[1] == '!'))
+ shebang_len = 2;
+#ifdef ALTERNATE_SHEBANG
+ else {
+ shebang_len = strlen(ALTERNATE_SHEBANG);
+ if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
+ char * perlstr;
+ perlstr = strstr("perl",b);
+ if (perlstr == NULL)
+ shebang_len = 0;
+ }
+ else
+ shebang_len = 0;
+ }
+#endif
+
+ if (shebang_len > 0) {
+ int i;
+ int j;
+ char tmpspec[NAM$C_MAXRSS + 1];
+
+ i = shebang_len;
+ /* Image is following after white space */
+ /*--------------------------------------*/
+ while (isprint(b[i]) && isspace(b[i]))
+ i++;
+
+ j = 0;
+ while (isprint(b[i]) && !isspace(b[i])) {
+ tmpspec[j++] = b[i++];
+ if (j >= NAM$C_MAXRSS)
+ break;
+ }
+ tmpspec[j] = '\0';
+
+ /* There may be some default parameters to the image */
+ /*---------------------------------------------------*/
+ j = 0;
+ while (isprint(b[i])) {
+ image_argv[j++] = b[i++];
+ if (j >= NAM$C_MAXRSS)
+ break;
+ }
+ while ((j > 0) && !isprint(image_argv[j-1]))
+ j--;
+ image_argv[j] = 0;
+
/* It will need to be converted to VMS format and validated */
+ if (tmpspec[0] != '\0') {
+ char * iname;
+
+ /* Try to find the exact program requested to be run */
+ /*---------------------------------------------------*/
+ iname = do_rmsexpand
+ (tmpspec, image_name, 0, ".exe", PERL_RMSEXPAND_M_VMS);
+ if (iname != NULL) {
+ if (cando_by_name(S_IXUSR,0,image_name)) {
+ /* MCR prefix needed */
+ isdcl = 0;
+ }
+ else {
+ /* Try again with a null type */
+ /*----------------------------*/
+ iname = do_rmsexpand
+ (tmpspec, image_name, 0, ".", PERL_RMSEXPAND_M_VMS);
+ if (iname != NULL) {
+ if (cando_by_name(S_IXUSR,0,image_name)) {
+ /* MCR prefix needed */
+ isdcl = 0;
+ }
+ }
+ }
+
+ /* Did we find the image to run the script? */
+ /*------------------------------------------*/
+ if (isdcl) {
+ char *tchr;
+
+ /* Assume DCL or foreign command exists */
+ /*--------------------------------------*/
+ tchr = strrchr(tmpspec, '/');
+ if (tchr != NULL) {
+ tchr++;
+ }
+ else {
+ tchr = tmpspec;
+ }
+ strcpy(image_name, tchr);
+ }
+ }
+ }
}
}
fclose(fp);
@@ -7337,16 +7438,44 @@
if (check_img && isdcl) return RMS$_FNF;
if (cando_by_name(S_IXUSR,0,resspec)) {
- Newx(vmscmd->dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) :
0),char);
+ Newx(vmscmd->dsc$a_pointer, MAX_DCL_LINE_LENGTH ,char);
if (!isdcl) {
strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
- if (suggest_quote) *suggest_quote = 1;
+ if (image_name[0] != 0) {
+ strcat(vmscmd->dsc$a_pointer, image_name);
+ strcat(vmscmd->dsc$a_pointer, " ");
+ }
+ } else if (image_name[0] != 0) {
+ strcpy(vmscmd->dsc$a_pointer, image_name);
+ strcat(vmscmd->dsc$a_pointer, " ");
} else {
strcpy(vmscmd->dsc$a_pointer,"@");
- if (suggest_quote) *suggest_quote = 1;
}
- strcat(vmscmd->dsc$a_pointer,resspec);
- if (rest) strcat(vmscmd->dsc$a_pointer,rest);
+ if (suggest_quote) *suggest_quote = 1;
+
+ /* If there is an image name, use original command */
+ if (image_name[0] == 0)
+ strcat(vmscmd->dsc$a_pointer,resspec);
+ else {
+ rest = cmd;
+ while (*rest && isspace(*rest)) rest++;
+ }
+
+ if (image_argv[0] != 0) {
+ strcat(vmscmd->dsc$a_pointer,image_argv);
+ strcat(vmscmd->dsc$a_pointer, " ");
+ }
+ if (rest) {
+ int rest_len;
+ int vmscmd_len;
+
+ rest_len = strlen(rest);
+ vmscmd_len = strlen(vmscmd->dsc$a_pointer);
+ if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
+ strcat(vmscmd->dsc$a_pointer,rest);
+ else
+ retsts = CLI$_BUFOVF;
+ }
vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
Safefree(cmd);
return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF :
retsts);
