diff options
| -rw-r--r-- | lib/ExtUtils/MM_VMS.pm | 32 | ||||
| -rw-r--r-- | lib/File/Spec/VMS.pm | 11 | ||||
| -rwxr-xr-x | t/op/lex_assign.t | 2 | ||||
| -rw-r--r-- | vms/ext/vmsish.pm | 6 | ||||
| -rw-r--r-- | vms/ext/vmsish.t | 1 | ||||
| -rw-r--r-- | vms/test.com | 2 | ||||
| -rw-r--r-- | vms/vms.c | 94 | ||||
| -rw-r--r-- | vms/vmsish.h | 2 |
8 files changed, 91 insertions, 59 deletions
diff --git a/lib/ExtUtils/MM_VMS.pm b/lib/ExtUtils/MM_VMS.pm index 57a8146dae..1e6c61a4c8 100644 --- a/lib/ExtUtils/MM_VMS.pm +++ b/lib/ExtUtils/MM_VMS.pm @@ -231,7 +231,9 @@ invoke Perl images. sub find_perl { my($self, $ver, $names, $dirs, $trace) = @_; my($name,$dir,$vmsfile,@sdirs,@snames,@cand); + my($rslt); my($inabs) = 0; + local *TCF; # Check in relative directories first, so we pick up the current # version of Perl if we're running MakeMaker as part of the main build. @sdirs = sort { my($absa) = $self->file_name_is_absolute($a); @@ -277,15 +279,28 @@ sub find_perl { foreach $name (@cand) { print "Checking $name\n" if ($trace >= 2); # If it looks like a potential command, try it without the MCR - if ($name =~ /^[\w\-\$]+$/ && - `$name -e "require $ver; print ""VER_OK\\n"""` =~ /VER_OK/) { + if ($name =~ /^[\w\-\$]+$/) { + open(TCF,">temp_mmvms.com") || die('unable to open temp file'); + print TCF "\$ set message/nofacil/nosever/noident/notext\n"; + print TCF "\$ $name -e \"require $ver; print \"\"VER_OK\\n\"\"\"\n"; + close TCF; + $rslt = `\@temp_mmvms.com` ; + unlink('temp_mmvms.com'); + if ($rslt =~ /VER_OK/) { print "Using PERL=$name\n" if $trace; return $name; } + } next unless $vmsfile = $self->maybe_command($name); $vmsfile =~ s/;[\d\-]*$//; # Clip off version number; we can use a newer version as well print "Executing $vmsfile\n" if ($trace >= 2); - if (`MCR $vmsfile -e "require $ver; print ""VER_OK\\n"""` =~ /VER_OK/) { + open(TCF,">temp_mmvms.com") || die('unable to open temp file'); + print TCF "\$ set message/nofacil/nosever/noident/notext\n"; + print TCF "\$ mcr $vmsfile -e \"require $ver; print \"\"VER_OK\\n\"\"\" \n"; + close TCF; + $rslt = `\@temp_mmvms.com`; + unlink('temp_mmvms.com'); + if ($rslt =~ /VER_OK/) { print "Using PERL=MCR $vmsfile\n" if $trace; return "MCR $vmsfile"; } @@ -1018,7 +1033,7 @@ sub dist { # Sanitize these for use in $(DISTVNAME) filespec $attribs{VERSION} =~ s/[^\w\$]/_/g; - $attribs{NAME} =~ s/[^\w\$]/_/g; + $attribs{NAME} =~ s/[^\w\$]/-/g; return ExtUtils::MM_Unix::dist($self,%attribs); } @@ -1194,8 +1209,8 @@ $(BASEEXT).opt : Makefile.PL s/.*[:>\/\]]//; # Trim off dir spec $upcase ? uc($_) : $_; } split ' ', $self->eliminate_macros($self->{OBJECT}); - my($tmp,@lines,$elt) = ''; - my $tmp = shift @omods; + my($tmp, @lines,$elt) = ''; + $tmp = shift @omods; foreach $elt (@omods) { $tmp .= ",$elt"; if (length($tmp) > 80) { push @lines, $tmp; $tmp = ''; } @@ -1652,6 +1667,9 @@ dist : $(DIST_DEFAULT) zipdist : $(DISTVNAME).zip $(NOECHO) $(NOOP) +tardist : $(DISTVNAME).tar$(SUFFIX) + $(NOECHO) $(NOOP) + $(DISTVNAME).zip : distdir $(PREOP) $(ZIP) "$(ZIPFLAGS)" $(MMS$TARGET) [.$(DISTVNAME)...]*.*; @@ -1661,7 +1679,7 @@ $(DISTVNAME).zip : distdir $(DISTVNAME).tar$(SUFFIX) : distdir $(PREOP) $(TO_UNIX) - $(TAR) "$(TARFLAGS)" $(DISTVNAME).tar [.$(DISTVNAME)] + $(TAR) "$(TARFLAGS)" $(DISTVNAME).tar [.$(DISTVNAME)...] $(RM_RF) $(DISTVNAME) $(COMPRESS) $(DISTVNAME).tar $(POSTOP) diff --git a/lib/File/Spec/VMS.pm b/lib/File/Spec/VMS.pm index d2be87c660..cc06ca636d 100644 --- a/lib/File/Spec/VMS.pm +++ b/lib/File/Spec/VMS.pm @@ -40,6 +40,11 @@ sub eliminate_macros { my($self,$path) = @_; return '' unless $path; $self = {} unless ref $self; + + if ($path =~ /\s/) { + return join ' ', map { $self->eliminate_macros($_) } split /\s+/, $path; + } + my($npath) = unixify($path); my($complex) = 0; my($head,$macro,$tail); @@ -89,6 +94,12 @@ sub fixpath { $self = bless {} unless ref $self; my($fixedpath,$prefix,$name); + if ($path =~ /\s/) { + return join ' ', + map { $self->fixpath($_,$force_path) } + split /\s+/, $path; + } + if ($path =~ m#^\$\([^\)]+\)\Z(?!\n)#s || $path =~ m#[/:>\]]#) { if ($force_path or $path =~ /(?:DIR\)|\])\Z(?!\n)/) { $fixedpath = vmspath($self->eliminate_macros($path)); diff --git a/t/op/lex_assign.t b/t/op/lex_assign.t index 836cdba4cc..f3f205e746 100755 --- a/t/op/lex_assign.t +++ b/t/op/lex_assign.t @@ -173,7 +173,7 @@ EOE __END__ ref $xref # ref ref $cstr # ref nonref -`$runme -e "print qq[1\n]"` # backtick skip(MSWin32) +`$runme -e "print qq[1\\n]"` # backtick skip(MSWin32) `$undefed` # backtick undef skip(MSWin32) <*> # glob <OP> # readline diff --git a/vms/ext/vmsish.pm b/vms/ext/vmsish.pm index 2fc48530c0..c51863a4f3 100644 --- a/vms/ext/vmsish.pm +++ b/vms/ext/vmsish.pm @@ -44,12 +44,12 @@ default of Universal Time (a.k.a Greenwich Mean Time, or GMT). =item C<vmsish hushed> -This supresses printing of VMS status messages to SYS$OUTPUT and SYS$ERROR +This suppresses printing of VMS status messages to SYS$OUTPUT and SYS$ERROR if Perl terminates with an error status. This primarily effects error -exits from things like compiler errors or "standard Perl" runtime errors, +exits from things like Perl compiler errors or "standard Perl" runtime errors, where text error messages are also generated by Perl. -The error exits from inside VMS.C are generally more serious, and are +The error exits from inside the core are generally more serious, and are not supressed. =back diff --git a/vms/ext/vmsish.t b/vms/ext/vmsish.t index 2a5b580bda..d63da57235 100644 --- a/vms/ext/vmsish.t +++ b/vms/ext/vmsish.t @@ -136,6 +136,7 @@ sub do_a_perl { local *P; open(P,'>vmsish_test.com') || die('not ok ?? : unable to open "vmsish_test.com" for writing'); print P "\$ set message/facil/sever/ident/text\n"; + print P "\$ define/nolog/user sys\$error _nla0:\n"; print P "\$ $Invoke_Perl @_\n"; close P; my $x = `\@vmsish_test.com`; diff --git a/vms/test.com b/vms/test.com index bda5f7d07e..a040427d5c 100644 --- a/vms/test.com +++ b/vms/test.com @@ -41,7 +41,7 @@ $ if p2.nes."" then dbg = "dbg" $ if p2.nes."" then ndbg = "ndbg" $! $! Pick up a copy of perl to use for the tests -$ Delete/Log/NoConfirm Perl.;* +$ If F$Search("Perl.").nes."" Then Delete/Log/NoConfirm Perl.;* $ Copy/Log/NoConfirm [-]'ndbg'Perl'exe' []Perl. $ $! Make the environment look a little friendlier to tests which assume Unix @@ -732,8 +732,7 @@ my_crypt(const char *textpasswd, const char *usrname) usrdsc.dsc$a_pointer = usrname; if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) { switch (sts) { - case SS$_NOGRPPRV: - case SS$_NOSYSPRV: + case SS$_NOGRPPRV: case SS$_NOSYSPRV: set_errno(EACCES); break; case RMS$_RNF: @@ -832,15 +831,13 @@ kill_file(char *name) newace.myace$l_ident = oldace.myace$l_ident; if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) { switch (aclsts) { - case RMS$_FNF: - case RMS$_DNF: - case RMS$_DIR: - case SS$_NOSUCHOBJECT: + case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT: set_errno(ENOENT); break; + case RMS$_DIR: + set_errno(ENOTDIR); break; case RMS$_DEV: set_errno(ENODEV); break; - case RMS$_SYN: - case SS$_INVFILFOROP: + case RMS$_SYN: case SS$_INVFILFOROP: set_errno(EINVAL); break; case RMS$_PRV: set_errno(EACCES); break; @@ -897,6 +894,9 @@ my_mkdir(char *dir, Mode_t mode) STRLEN dirlen = strlen(dir); dTHX; + /* zero length string sometimes gives ACCVIO */ + if (dirlen == 0) return -1; + /* CRTL mkdir() doesn't tolerate trailing /, since that implies * null file name/type. However, it's commonplace under Unix, * so we'll allow it for a gain in portability. @@ -1340,8 +1340,7 @@ do_rmsexpand(char *filespec, char *outbuf, int ts, char *defspec, unsigned opts) retsts = sys$parse(&myfab,0,0); if (!(retsts & 1)) { mynam.nam$b_nop |= NAM$M_SYNCHK; - if (retsts == RMS$_DNF || retsts == RMS$_DIR || - retsts == RMS$_DEV || retsts == RMS$_DEV) { + if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) { retsts = sys$parse(&myfab,0,0); if (retsts & 1) goto expanded; } @@ -1484,7 +1483,7 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts) set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL; } dirlen = strlen(dir); - while (dir[dirlen-1] == '/') --dirlen; + while (dirlen && dir[dirlen-1] == '/') --dirlen; if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */ strcpy(trndir,"/sys$disk/000000"); dir = trndir; @@ -1510,7 +1509,7 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts) * ... do_fileify_dirspec("myroot",buf,1) ... * does something useful. */ - if (!strcmp(dir+dirlen-2,".]")) { + if (dirlen >= 2 && !strcmp(dir+dirlen-2,".]")) { dir[--dirlen] = '\0'; dir[dirlen-1] = ']'; } @@ -1540,7 +1539,7 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts) (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0'))) return do_fileify_dirspec("[-]",buf,ts); } - if (dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */ + if (dirlen && dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */ dirlen -= 1; /* to last element */ lastdir = strrchr(dir,'/'); } @@ -1567,7 +1566,7 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts) } while ((cp1 = strstr(cp1,"/.")) != NULL); lastdir = strrchr(dir,'/'); } - else if (!strcmp(&dir[dirlen-7],"/000000")) { + else if (dirlen >= 7 && !strcmp(&dir[dirlen-7],"/000000")) { /* Ditto for specs that end in an MFD -- let the VMS code * figure out whether it's a real device or a rooted logical. */ dir[dirlen] = '/'; dir[dirlen+1] = '\0'; @@ -2687,14 +2686,13 @@ unsigned long int zero = 0, sts; set_vaxc_errno(sts); switch (sts) { - case RMS$_FNF: - case RMS$_DNF: - case RMS$_DIR: + case RMS$_FNF: case RMS$_DNF: set_errno(ENOENT); break; + case RMS$_DIR: + set_errno(ENOTDIR); break; case RMS$_DEV: set_errno(ENODEV); break; - case RMS$_FNM: - case RMS$_SYN: + case RMS$_FNM: case RMS$_SYN: set_errno(EINVAL); break; case RMS$_PRV: set_errno(EACCES); break; @@ -3264,7 +3262,8 @@ readdir(DIR *dd) case RMS$_DEV: set_errno(ENODEV); break; case RMS$_DIR: - case RMS$_FNF: + set_errno(ENOTDIR); break; + case RMS$_FNF: case RMS$_DNF: set_errno(ENOENT); break; default: set_errno(EVMSERR); @@ -3604,10 +3603,12 @@ vms_do_exec(char *cmd) retsts = lib$do_command(&VMScmd); switch (retsts) { - case RMS$_FNF: + case RMS$_FNF: case RMS$_DNF: set_errno(ENOENT); break; - case RMS$_DNF: case RMS$_DIR: case RMS$_DEV: + case RMS$_DIR: set_errno(ENOTDIR); break; + case RMS$_DEV: + set_errno(ENODEV); break; case RMS$_PRV: set_errno(EACCES); break; case RMS$_SYN: @@ -3664,10 +3665,12 @@ do_spawn(char *cmd) if (!(sts & 1)) { switch (sts) { - case RMS$_FNF: + case RMS$_FNF: case RMS$_DNF: set_errno(ENOENT); break; - case RMS$_DNF: case RMS$_DIR: case RMS$_DEV: + case RMS$_DIR: set_errno(ENOTDIR); break; + case RMS$_DEV: + set_errno(ENODEV); break; case RMS$_PRV: set_errno(EACCES); break; case RMS$_SYN: @@ -4645,26 +4648,14 @@ cando_by_name(I32 bit, Uid_t effective, char *fname) } switch (bit) { - case S_IXUSR: - case S_IXGRP: - case S_IXOTH: - access = ARM$M_EXECUTE; - break; - case S_IRUSR: - case S_IRGRP: - case S_IROTH: - access = ARM$M_READ; - break; - case S_IWUSR: - case S_IWGRP: - case S_IWOTH: - access = ARM$M_WRITE; - break; - case S_IDUSR: - case S_IDGRP: - case S_IDOTH: - access = ARM$M_DELETE; - break; + case S_IXUSR: case S_IXGRP: case S_IXOTH: + access = ARM$M_EXECUTE; break; + case S_IRUSR: case S_IRGRP: case S_IROTH: + access = ARM$M_READ; break; + case S_IWUSR: case S_IWGRP: case S_IWOTH: + access = ARM$M_WRITE; break; + case S_IDUSR: case S_IDGRP: case S_IDOTH: + access = ARM$M_DELETE; break; default: return FALSE; } @@ -4695,6 +4686,12 @@ cando_by_name(I32 bit, Uid_t effective, char *fname) if (retsts == SS$_ACCONFLICT) { return TRUE; } + +#if defined(__ALPHA) && defined(__VMS_VER) && __VMS_VER == 70100022 && defined(__DECC_VER) && __DECC_VER == 6009001 + /* XXX Hideous kluge to accomodate error in specific version of RTL; + we hope it'll be buried soon */ + if (retsts == 114762) return TRUE; +#endif _ckvmssts(retsts); return FALSE; /* Should never get here */ @@ -4885,9 +4882,10 @@ rmscopy(char *spec_in, char *spec_out, int preserve_dates) if (!((sts = sys$open(&fab_in)) & 1)) { set_vaxc_errno(sts); switch (sts) { - case RMS$_FNF: - case RMS$_DIR: + case RMS$_FNF: case RMS$_DNF: set_errno(ENOENT); break; + case RMS$_DIR: + set_errno(ENOTDIR); break; case RMS$_DEV: set_errno(ENODEV); break; case RMS$_SYN: @@ -4929,8 +4927,10 @@ rmscopy(char *spec_in, char *spec_out, int preserve_dates) if (!((sts = sys$create(&fab_out)) & 1)) { set_vaxc_errno(sts); switch (sts) { - case RMS$_DIR: + case RMS$_DNF: set_errno(ENOENT); break; + case RMS$_DIR: + set_errno(ENOTDIR); break; case RMS$_DEV: set_errno(ENODEV); break; case RMS$_SYN: diff --git a/vms/vmsish.h b/vms/vmsish.h index c21f8f329e..a181e7c3d9 100644 --- a/vms/vmsish.h +++ b/vms/vmsish.h @@ -254,6 +254,8 @@ #ifdef VMS_DO_SOCKETS #include "sockadapt.h" +#define PERL_SOCK_SYSREAD_IS_RECV +#define PERL_SOCK_SYSWRITE_IS_SEND #endif #define BIT_BUCKET "_NLA0:" |