From f0963acb6df75767aaf57c94e1e7509003ff1543 Mon Sep 17 00:00:00 2001 From: Gurusamy Sarathy Date: Wed, 1 Mar 2000 06:44:42 +0000 Subject: [PATCH] consolidated VMS patches (from Craig A. Berry ); Glob.pm patch modified to use $DEFAULT_FLAGS, and iff no flags were supplied p4raw-id: //depot/perl@5397 --- configure.com | 133 ++++++++++++++++++++++++++++------------------- ext/File/Glob/Glob.pm | 4 +- ext/File/Glob/bsd_glob.c | 15 ++++++ installperl | 2 +- lib/ExtUtils/MM_VMS.pm | 4 +- lib/File/Find.pm | 5 +- lib/Pod/Checker.pm | 3 ++ lib/Pod/Parser.pm | 3 ++ t/io/open.t | 8 +-- t/io/openpid.t | 3 +- t/lib/glob-basic.t | 6 +-- t/op/goto.t | 2 +- t/op/runlevel.t | 2 +- t/op/split.t | 2 +- t/pod/testp2pt.pl | 3 ++ t/pragma/strict.t | 4 +- t/pragma/subs.t | 2 +- t/pragma/warn/8signal | 2 +- t/pragma/warn/pp_sys | 10 ++++ t/pragma/warnings.t | 4 +- vms/descrip_mms.template | 9 ++-- vms/subconfigure.com | 13 +++-- vms/test.com | 6 +-- vms/vms.c | 2 +- 24 files changed, 154 insertions(+), 93 deletions(-) diff --git a/configure.com b/configure.com index deb4d11..c34389e 100644 --- a/configure.com +++ b/configure.com @@ -45,7 +45,8 @@ $ use_debugging_perl = "y" $ use_ieee_math = "n" $ be_case_sensitive = "n" $ use_vmsdebug_perl = "n" -$ use_64bitint = "n" +$ use64bitall = "n" +$ use64bitint = "n" $ C_Compiler_Replace = "CC=" $ Thread_Live_Dangerously = "MT=" $ use_two_pot_malloc = "N" @@ -55,8 +56,8 @@ $ d_secintgenv = "N" $ cc_flags = "" $ use_multiplicity = "N" $ vms_default_directory_name = F$ENVIRONMENT("DEFAULT") -$ max_allowed_dir_depth = 3 ! e.g. [A.B.PERL5_00n] not [A.B.C.PERL5_00n] -$! max_allowed_dir_depth = 2 ! e.g. [FOO.PERL5_00n] not [FOO.BAR.PERL5_00n] +$ max_allowed_dir_depth = 3 ! e.g. [A.B.PERL5_xxx] not [A.B.C.PERL5_xxx] +$! max_allowed_dir_depth = 2 ! e.g. [A.PERL5_xxx] not [A.B.PERL5_xxx] $! $ vms_filcnt = F$GETJPI ("","FILCNT") $! @@ -360,6 +361,7 @@ $! maybe someday $! $!: set package name $ package = "perl5" +$ packageup = F$EDIT((package - "5"),"UPCASE") $! $!: Eunice requires " " instead of "", can you believe it $ echo "" @@ -929,44 +931,44 @@ $!: set up shell script to do ~ expansion !sfn $!: expand filename !sfn $!: now set up to get a file name !sfn $! +$ prefix = F$ENVIRONMENT("DEFAULT") - ".UU]" + "]" +$ prefix = F$PARSE(prefix,,,,"NO_CONCEAL") - "][" - ".;" +$ prefixbase = prefix - "]" +$ prefix = prefixbase + ".]" +$!: determine root of directory hierarchy where package will be installed. +$ dflt = prefix +$ IF .NOT.silent +$ THEN +$ echo "" +$ echo "By default, ''package' will be installed in ''dflt', pod" +$ echo "pages under ''prefixbase'LIB.POD], etc..., i.e. with ''dflt' as prefix for" +$ echo "all installation directories." +$ echo "On ''osname' the ''prefix' is used to DEFINE the ''packageup'_ROOT prior to installation" +$ echo "as well as during subsequent use of ''package' via ''packageup'_SETUP.COM." +$ ENDIF +$ rp = "Installation prefix to use (for ''packageup'_ROOT)? [ ''dflt' ] " +$ GOSUB myread +$ IF ans.NES."" +$ THEN +$ prefix = ans +$ IF F$LOCATE(".]",ans) .EQ. F$LENGTH(ans) THEN prefix = prefix - "]" + ".]" +$ ELSE +$ prefix = dflt +$ ENDIF +$! +$! Check here for pre-existing PERL_ROOT. +$! -> ask if removal desired. +$! Check here for writability of requested PERL_ROOT if it is not the default (cwd). +$! -> recommend letting PERL_ROOT be PERL_SRC if requested PERL_ROOT is not writable. +$! $ vms_skip_install = "true" $ dflt = "y" $! echo "" -$ rp = "%Config-I-VMS, Do you wish to skip the """"where install"""" questions? [''dflt'] " +$ rp = "%Config-I-VMS, Do you wish to skip the remaining """"where install"""" questions? [''dflt'] " $ GOSUB myread $ IF (.NOT.ans).AND.(ans.NES."") THEN vms_skip_install = "false" -$ prefix = F$ENVIRONMENT("DEFAULT") - ".UU]" + "]" -$ prefix = f$parse(prefix,,,,"NO_CONCEAL") - "][" - ".;" -$ prefix = prefix - "]" + ".]" $ IF (.NOT.vms_skip_install) $ THEN -$!: determine root of directory hierarchy where package will be installed. -$ dflt = "default" -$ IF .NOT.silent -$ THEN -$ echo "" -$ echo "By default, ''package' will be installed in ''dflt'/bin, manual" -$ echo "pages under ''dflt'/man, etc..., i.e. with ''dflt' as prefix for" -$ echo "all installation directories. Typically set to /usr/local, but you" -$ echo "may choose /usr if you wish to install ''package' among your system -$ ENDIF -$ IF .NOT.silent -$ THEN TYPE SYS$INPUT: -binaries. If you wish to have binaries under /bin but manual pages -under /usr/local/man, that's ok: you will be prompted separately -for each of the installation directories, the prefix being only used -to set the defaults. -$ ENDIF -$ dflt = prefix -$ rp = "Installation prefix to use? [ ''dflt' ] " -$ GOSUB myread -$ IF ans.NES."" -$ THEN -$ prefix = ans -$ IF F$LOCATE(".]",ans) .EQ. F$LENGTH(ans) THEN prefix = prefix - "]" + ".]" -$ ELSE -$ prefix = dflt -$ ENDIF $! $!: set the prefixit variable, to compute a suitable default value $! @@ -988,7 +990,7 @@ $ THEN privlib = ans $ ELSE privlib = dflt $ ENDIF $! -$ ENDIF !%Config-I-VMS, skip "where install" questions +$ ENDIF !%Config-I-VMS, skip remaining "where install" questions $! $!: set the base revision $ baserev="5" @@ -1744,25 +1746,51 @@ $ use_multiplicity="N" $ ENDIF $! $! Ask if they want to build with 64-bit support -$ if (Archname.eqs."VMS_AXP").and.("''f$extract(1,3, f$getsyi(""version""))'".ges."7.1") +$ IF (Archname.eqs."VMS_AXP").and.("''f$extract(1,3, f$getsyi(""version""))'".ges."7.1") $ THEN +$ dflt = use64bitint $ echo "" -$ echo "This version of perl has experimental support for building with -$ echo "64 bit integers and 128 bit floating point variables. This gives -$ echo "a much larger range for perl's mathematical operations. (Note that -$ echo "does *not* enable 64-bit fileops at the moment, as Dec C doesn't -$ echo "do that yet)" -$ dflt = use_64bitint -$ rp = "Build with 64 bit integers and 128 bit floating point variable? [''dflt'] " +$ echo "You can have native 64-bit long integers. +$ echo "" +$ echo "Perl can be built to take advantage of 64-bit integer types +$ echo "on some systems, which provide a much larger range for perl's +$ echo "mathematical operations. (Note that does *not* enable 64-bit +$ echo "fileops at the moment, as Dec C doesn't do that yet)." +$ echo "Choosing this option will most probably introduce binary incompatibilities. +$ echo "" +$ echo "If this doesn't make any sense to you, just accept the default ''dflt'. +$ rp = "Try to use 64-bit integers, if available? [''dflt'] " $ GOSUB myread -$ if ans.eqs."" then ans = dflt -$ if (f$extract(0, 1, "''ans'").eqs."Y").or.(f$extract(0, 1, "''ans'").eqs."y") +$ IF ans .EQS. "" THEN ans = dflt +$ IF (f$extract(0, 1, f$edit(ans,"COLLAPSE,UPCASE")) .EQS. "Y") $ THEN -$ use_64bitint="Y" +$ use64bitint="Y" $ ELSE -$ use_64bitint="N" +$ use64bitint="N" $ ENDIF -$ ENDIF +$ IF (use64bitint) +$ THEN +$ dflt = use64bitall +$ echo "" +$ echo "Since you chose 64-bitness you may want to try maximal 64-bitness. +$ echo "What you have chosen is minimal 64-bitness which means just enough +$ echo "to get 64-bit integers. The maximal means using as much 64-bitness +$ echo "as is possible on the platform. This in turn means even more binary +$ echo "incompatibilities. On the other hand, your platform may not have +$ echo "any more maximal 64-bitness than what you already have chosen. +$ echo "" +$ echo "If this doesn't make any sense to you, just accept the default ''dflt'. +$ rp = "Try to use full 64-bit support, if available? [''dflt'] " +$ GOSUB myread +$ IF ans .EQS. "" THEN ans = dflt +$ IF (f$extract(0, 1, f$edit(ans,"COLLAPSE,UPCASE")) .EQS. "Y") +$ THEN +$ use64bitall="Y" +$ ELSE +$ use64bitall="N" +$ ENDIF +$ ENDIF +$ ENDIF ! AXP && >= 7.1 $! $! Ask about threads, if appropriate $ if (Using_Dec_C.eqs."Yes") @@ -1839,9 +1867,8 @@ $ echo "is really PERL_FOO. There are some packages that use an $ echo "embedded perl interpreter that instead require case-sensitive $ echo "linker symbols. $ echo "" -$ echo "If you have no idea what the heck this means, and don't have +$ echo "If you have no idea what this means, and don't have $ echo "any program requiring anything, choose the default. -$ echo "" $ dflt = be_case_sensitive $ rp = "Case-sensitive symbols [''dflt'] " $ gosub myread @@ -1853,7 +1880,6 @@ $ echo "" $ echo "Perl normally uses G_FLOAT format floating point numbers $ echo "internally, as do most things on VMS. You can, however, build $ echo "with IEEE floating point numbers instead if you need to. -$ echo "" $ dflt = use_ieee_math $ rp = "Use IEEE math [''dflt'] " $ gosub myread @@ -1865,9 +1891,8 @@ $ echo "" $ echo "You can, if you need to, pass extra flags on to the C $ echo "compiler. In general you should only do this if you really, $ echo "really know what you're doing. -$ echo "" $ dflt = user_c_flags -$ rp = "Flags [''dflt'] " +$ rp = "Extra C flags [''dflt'] " $ gosub myread $ if ans.eqs."" then ans="''dflt'" $ user_c_flags = "''ans'" @@ -1961,7 +1986,7 @@ $ echo "break badly" $ echo " $ echo "Which modules do you want to build into perl?" $! dflt = "Fcntl Errno File::Glob IO Opcode Byteloader Devel::Peek Devel::DProf Data::Dumper attrs re VMS::Stdio VMS::DCLsym B SDBM_File" -$ dflt = "re Fcntl Errno File::Glob IO Opcode Devel::Peek Devel::DProf Data::Dumper attrs VMS::Stdio VMS::DCLsym B SDBM_File Thread" +$ dflt = "re Fcntl Errno File::Glob IO Opcode Devel::Peek Devel::DProf Data::Dumper attrs VMS::Stdio VMS::DCLsym B SDBM_File Thread Sys::Hostname" $ if Using_Dec_C.eqs."Yes" $ THEN $ dflt = dflt + " POSIX" diff --git a/ext/File/Glob/Glob.pm b/ext/File/Glob/Glob.pm index f703a0b..3c3ea6c 100644 --- a/ext/File/Glob/Glob.pm +++ b/ext/File/Glob/Glob.pm @@ -109,7 +109,9 @@ if ($^O =~ /^(?:MSWin32|VMS|os2|dos|riscos|MacOS)$/) { # Autoload methods go after =cut, and are processed by the autosplit program. sub glob { - return doglob(@_); + my ($pat,$flags) = @_; + $flags = $DEFAULT_FLAGS if @_ < 2; + return doglob($pat,$flags); } ## borrowed heavily from gsar's File::DosGlob diff --git a/ext/File/Glob/bsd_glob.c b/ext/File/Glob/bsd_glob.c index c422d60..62bfe4f 100644 --- a/ext/File/Glob/bsd_glob.c +++ b/ext/File/Glob/bsd_glob.c @@ -658,6 +658,21 @@ glob3(Char *pathbuf, Char *pathend, Char *pattern, *pathend = BG_EOS; errno = 0; +#ifdef VMS + { + Char *q = pathend; + if (q - pathbuf > 5) { + q -= 5; + if (q[0] == '.' && tolower(q[1]) == 'd' && tolower(q[2]) == 'i' + && tolower(q[3]) == 'r' && q[4] == '/') + { + q[0] = '/'; + q[1] = BG_EOS; + pathend = q+1; + } + } + } +#endif if ((dirp = g_opendir(pathbuf, pglob)) == NULL) { /* TODO: don't call for ENOENT or ENOTDIR? */ if (pglob->gl_errfunc) { diff --git a/installperl b/installperl index 387f4b3..dd6d663 100755 --- a/installperl +++ b/installperl @@ -631,7 +631,7 @@ sub installlib { sub copy_if_diff { my($from,$to)=@_; return 1 if (($^O eq 'VMS') && (-d $from)); - -f $from || die "$0: $from not found"; + -f $from || warn "$0: $from not found"; $packlist->{$to} = { type => 'file' }; if (compare($from, $to) || $nonono) { safe_unlink($to); # In case we don't have write permissions. diff --git a/lib/ExtUtils/MM_VMS.pm b/lib/ExtUtils/MM_VMS.pm index 5f54b10..57a8146 100644 --- a/lib/ExtUtils/MM_VMS.pm +++ b/lib/ExtUtils/MM_VMS.pm @@ -278,14 +278,14 @@ sub find_perl { 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/) { + `$name -e "require $ver; print ""VER_OK\\n"""` =~ /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/) { + if (`MCR $vmsfile -e "require $ver; print ""VER_OK\\n"""` =~ /VER_OK/) { print "Using PERL=MCR $vmsfile\n" if $trace; return "MCR $vmsfile"; } diff --git a/lib/File/Find.pm b/lib/File/Find.pm index 71cc0e6..a5e750e 100644 --- a/lib/File/Find.pm +++ b/lib/File/Find.pm @@ -511,8 +511,9 @@ sub _find_dir($$$) { while ( defined ($SE = pop @Stack) ) { ($Level, $p_dir, $dir_rel, $nlink) = @$SE; if ($CdLvl > $Level && !$no_chdir) { - die "Can't cd to $dir_name" . '../' x ($CdLvl-$Level) - unless chdir '../' x ($CdLvl-$Level); + my $tmp = join('/',('..') x ($CdLvl-$Level)); + die "Can't cd to $dir_name" . $tmp + unless chdir ($tmp); $CdLvl = $Level; } $dir_name = ($p_dir eq '/' ? "/$dir_rel" : "$p_dir/$dir_rel"); diff --git a/lib/Pod/Checker.pm b/lib/Pod/Checker.pm index 281bd11..6611a05 100644 --- a/lib/Pod/Checker.pm +++ b/lib/Pod/Checker.pm @@ -307,6 +307,7 @@ use strict; use Carp; use Exporter; use Pod::Parser; +require VMS::Filespec if $^O eq 'VMS'; use vars qw(@ISA @EXPORT); @ISA = qw(Pod::Parser); @@ -546,6 +547,7 @@ The error level, should be 'WARNING' or 'ERROR'. sub poderror { my $self = shift; my %opts = (ref $_[0]) ? %{shift()} : (); + $opts{-file} = VMS::Filespec::unixify($opts{-file}) if (exists($opts{-file}) && $^O eq 'VMS'); ## Retrieve options chomp( my $msg = ($opts{-msg} || "")."@_" ); @@ -670,6 +672,7 @@ sub end_pod { ## print the number of errors found my $self = shift; my $infile = $self->input_file(); + $infile = VMS::Filespec::unixify($infile) if $^O eq 'VMS'; my $out_fh = $self->output_handle(); if(@{$self->{_list_stack}}) { diff --git a/lib/Pod/Parser.pm b/lib/Pod/Parser.pm index a00f0ee..1abd690 100644 --- a/lib/Pod/Parser.pm +++ b/lib/Pod/Parser.pm @@ -196,6 +196,7 @@ use strict; use Pod::InputObjects; use Carp; use Exporter; +require VMS::Filespec if $^O eq 'VMS'; @ISA = qw(Exporter); ## These "variables" are used as local "glob aliases" for performance @@ -832,6 +833,7 @@ sub parse_text { my $errorsub = (@seq_stack > 1) ? $self->errorsub() : undef; while (@seq_stack > 1) { ($cmd, $file, $line) = ($seq->name, $seq->file_line); + $file = VMS::Filespec::unixify($file) if $^O eq 'VMS'; $ldelim = $seq->ldelim; ($rdelim = $ldelim) =~ tr//; $rdelim =~ s/^(\S+)(\s*)$/$2$1/; @@ -1065,6 +1067,7 @@ sub parse_from_filehandle { if (length($1) > 1 and ! $self->{_CUTTING}) { my $errorsub = $self->errorsub(); my $file = $self->input_file(); + $file = VMS::Filespec::unixify($file) if $^O eq 'VMS'; my $errmsg = "*** WARNING: line containing nothing but whitespace". " in paragraph at line $nlines in file $file\n"; (ref $errorsub) and &{$errorsub}($errmsg) diff --git a/t/io/open.t b/t/io/open.t index 1e94091..531fc85 100755 --- a/t/io/open.t +++ b/t/io/open.t @@ -95,7 +95,7 @@ sub ok { print "ok $test\n"; $test++ } # 24..26 if ($Is_VMS) { - for (24..26) { print "ok $_ # skipped: not Unix fork\n"; } + for (24..26) { print "ok $_ # skipped: not Unix fork\n"; $test++;} } else { print "# \$!='$!'\nnot " unless open(my $f, '-|', <<'EOC'); @@ -111,7 +111,7 @@ EOC # 27..30 if ($Is_VMS) { - for (27..30) { print "ok $_ # skipped: not Unix fork\n"; } + for (27..30) { print "ok $_ # skipped: not Unix fork\n"; $test++;} } else { print "# \$!='$!'\nnot " unless open(my $f, '|-', <<'EOC'); @@ -219,7 +219,7 @@ ok; # 56..58 if ($Is_VMS) { - for (56..58) { print "ok $_ # skipped: not Unix fork\n"; } + for (56..58) { print "ok $_ # skipped: not Unix fork\n"; $test++;} } else { print "# \$!='$!'\nnot " unless open(local $f, '-|', <<'EOC'); @@ -235,7 +235,7 @@ EOC # 59..62 if ($Is_VMS) { - for (59..62) { print "ok $_ # skipped: not Unix fork\n"; } + for (59..62) { print "ok $_ # skipped: not Unix fork\n"; $test++;} } else { print "# \$!='$!'\nnot " unless open(local $f, '|-', <<'EOC'); diff --git a/t/io/openpid.t b/t/io/openpid.t index fc71e7a..80c6bde 100755 --- a/t/io/openpid.t +++ b/t/io/openpid.t @@ -78,9 +78,8 @@ print "ok 8\n"; # send one expected line of text to child process and then wait for it autoflush FH4 1; print FH4 "ok 9\n"; +print "ok 9 # skip VMS\n" if $^O eq 'VMS'; print "# waiting for process $pid4 to exit\n"; -#VMS: Send an EOF to convince the subprocess to exit as well -if ($^O eq 'VMS') { require VMS::Stdio; VMS::Stdio::writeof(FH4); } $reap_pid = waitpid $pid4, 0; print "# reaped pid $reap_pid != $pid4\nnot " unless $reap_pid == $pid4; diff --git a/t/lib/glob-basic.t b/t/lib/glob-basic.t index ac3abf5..2336fc0 100755 --- a/t/lib/glob-basic.t +++ b/t/lib/glob-basic.t @@ -38,7 +38,7 @@ print "ok 2\n"; # look up the user's home directory # should return a list with one item, and not set ERROR -if ($^O ne 'MSWin32') { +if ($^O ne 'MSWin32' || $^O ne 'VMS') { eval { ($name, $home) = (getpwuid($>))[0,7]; 1; @@ -72,7 +72,7 @@ print "ok 5\n"; # check bad protections # should return an empty list, and set ERROR -if ($^O eq 'mpeix' or $^O eq 'MSWin32' or $^O eq 'os2' or not $>) { +if ($^O eq 'mpeix' or $^O eq 'MSWin32' or $^O eq 'os2' or $^O eq 'VMS' or not $>) { print "ok 6 # skipped\n"; } else { @@ -99,7 +99,7 @@ print "ok 7\n"; GLOB_BRACE | GLOB_NOMAGIC ); unless (@a == 3 - and $a[0] eq 'TEST' + and $a[0] eq ($^O eq 'VMS'? 'test.' : 'TEST') and $a[1] eq 'a' and $a[2] eq 'b') { diff --git a/t/op/goto.t b/t/op/goto.t index 73fc79a..96bb8dd 100755 --- a/t/op/goto.t +++ b/t/op/goto.t @@ -30,7 +30,7 @@ print "#2\t:$foo: == 4\n"; if ($foo == 4) {print "ok 2\n";} else {print "not ok 2\n";} $PERL = ($^O eq 'MSWin32') ? '.\perl' : './perl'; -$CMD = qq[$PERL -e "goto foo;" ] . ($^O eq 'VMS' ? '' : ' 2>&1'); +$CMD = qq[$PERL -e "goto foo;" 2>&1 ]; $x = `$CMD`; if ($x =~ /label/) {print "ok 3\n";} else {print "not ok 3\n";} diff --git a/t/op/runlevel.t b/t/op/runlevel.t index 1d923cf..e988ad9 100755 --- a/t/op/runlevel.t +++ b/t/op/runlevel.t @@ -32,7 +32,7 @@ for (@prgs){ print TEST "$prog\n"; close TEST; my $results = $Is_VMS ? - `MCR $^X "-I[-.lib]" $switch $tmpfile` : + `MCR $^X "-I[-.lib]" $switch $tmpfile 2>&1` : $Is_MSWin32 ? `.\\perl -I../lib $switch $tmpfile 2>&1` : `./perl $switch $tmpfile 2>&1`; diff --git a/t/op/split.t b/t/op/split.t index 48e64e1..8b9f4ad 100755 --- a/t/op/split.t +++ b/t/op/split.t @@ -48,7 +48,7 @@ print $_ eq '1:2:3:4:5:6:::' ? "ok 10\n" : "not ok 10 $_\n"; # Does assignment to a list imply split to one more field than that? if ($^O eq 'MSWin32') { $foo = `.\\perl -D1024 -e "(\$a,\$b) = split;" 2>&1` } -elsif ($^O eq 'VMS') { $foo = `./perl "-D1024" -e "(\$a,\$b) = split;"` } +elsif ($^O eq 'VMS') { $foo = `./perl "-D1024" -e "(\$a,\$b) = split;" 2>&1` } else { $foo = `./perl -D1024 -e '(\$a,\$b) = split;' 2>&1` } print $foo =~ /DEBUGGING/ || $foo =~ /SV = (VOID|IV\(3\))/ ? "ok 11\n" : "not ok 11\n"; diff --git a/t/pod/testp2pt.pl b/t/pod/testp2pt.pl index 234a527..22bbaf8 100644 --- a/t/pod/testp2pt.pl +++ b/t/pod/testp2pt.pl @@ -32,6 +32,7 @@ BEGIN { require Pod::PlainText; @ISA = qw( Pod::PlainText ); } + require VMS::Filespec if $^O eq 'VMS'; } ## Hardcode settings for TERMCAP and COLUMNS so we can try to get @@ -41,6 +42,8 @@ BEGIN { sub catfile(@) { File::Spec->catfile(@_); } my $INSTDIR = abs_path(dirname $0); +$INSTDIR = VMS::Filespec::unixpath($INSTDIR) if $^O eq 'VMS'; +$INSTDIR =~ s#/$## if $^O eq 'VMS'; $INSTDIR = (dirname $INSTDIR) if (basename($INSTDIR) eq 'xtra'); $INSTDIR = (dirname $INSTDIR) if (basename($INSTDIR) eq 'pod'); $INSTDIR = (dirname $INSTDIR) if (basename($INSTDIR) eq 't'); diff --git a/t/pragma/strict.t b/t/pragma/strict.t index 2b8c587..c4d6416 100755 --- a/t/pragma/strict.t +++ b/t/pragma/strict.t @@ -65,9 +65,7 @@ for (@prgs){ open TEST, ">$tmpfile"; print TEST $prog,"\n"; close TEST; - my $results = $Is_VMS ? - `MCR $^X $switch $tmpfile` : - $Is_MSWin32 ? + my $results = $Is_MSWin32 ? `.\\perl -I../lib $switch $tmpfile 2>&1` : `./perl $switch $tmpfile 2>&1`; my $status = $?; diff --git a/t/pragma/subs.t b/t/pragma/subs.t index c8eb2c0..fe84f5e 100755 --- a/t/pragma/subs.t +++ b/t/pragma/subs.t @@ -46,7 +46,7 @@ for (@prgs){ print TEST $prog,"\n"; close TEST; my $results = $Is_VMS ? - `MCR $^X $switch $tmpfile` : + `./perl $switch $tmpfile 2>&1` : $Is_MSWin32 ? `.\\perl -I../lib $switch $tmpfile 2>&1` : `./perl $switch $tmpfile 2>&1`; diff --git a/t/pragma/warn/8signal b/t/pragma/warn/8signal index 0be2d13..80e6033 100644 --- a/t/pragma/warn/8signal +++ b/t/pragma/warn/8signal @@ -13,6 +13,6 @@ use warnings FATAL => qw(deprecated) ; 1 if 1 EQ 2 ; print "The End.\n" ; EXPECT -Use of EQ is deprecated at - line 8. WARN -- Use of EQ is deprecated at - line 6. DIE -- Use of EQ is deprecated at - line 8. +Use of EQ is deprecated at - line 8. diff --git a/t/pragma/warn/pp_sys b/t/pragma/warn/pp_sys index 5808536..cab1b60 100644 --- a/t/pragma/warn/pp_sys +++ b/t/pragma/warn/pp_sys @@ -195,6 +195,16 @@ syswrite() on closed filehandle main::STDIN at - line 6. (Are you trying to call syswrite() on dirhandle main::STDIN?) ######## # pp_sys.c [pp_flock] +use Config; +BEGIN { + if ( $^O eq 'VMS' and ! $Config{d_flock}) { + print <&1` : $Is_MSWin32 ? `.\\perl -I../lib $switch $tmpfile 2>&1` : `./perl -I../lib $switch $tmpfile 2>&1`; @@ -91,7 +91,7 @@ for (@prgs){ # allow all tests to run when there are leaks $results =~ s/Scalars leaked: \d+\n//g; $expected =~ s/\n+$//; - my $prefix = ($results =~ s/^PREFIX\n//) ; + my $prefix = ($results =~ s#^PREFIX(\n|$)##) ; # any special options? (OPTIONS foo bar zap) my $option_regex = 0; if ($expected =~ s/^OPTIONS? (.+)\n//) { diff --git a/vms/descrip_mms.template b/vms/descrip_mms.template index a2b57fa..6f93a9b 100644 --- a/vms/descrip_mms.template +++ b/vms/descrip_mms.template @@ -293,7 +293,7 @@ obj = $(obj0) $(obj1) $(obj2) $(obj3) $(obj4) h0 = $(SOCKH) $(THREADH) av.h cc_runtime.h config.h cop.h cv.h embed.h h1 = embedvar.h extern.h form.h gv.h handy.h hv.h intern.h intrpvar.h h2 = iperlsys.h mg.h nostdio.h objxsub.h op.h opcode.h opnames.h -h3 = patchlevel.h perl.h perlio.h perlsdio.h perlvars.h perly.h pp.h +h3 = patchlevel.h perl.h perlapi.h perlio.h perlsdio.h perlvars.h perly.h pp.h h4 = pp_proto.h proto.h regexp.h scope.h sv.h thrdvar.h thread.h utf8.h h5 = util.h vmsish.h warnings.h xsub.h h6 = regcomp.h regcomp.h @@ -308,14 +308,14 @@ ac3 = $(ARCHCORE)form.h $(ARCHCORE)gv.h $(ARCHCORE)handy.h $(ARCHCORE)hv.h ac4 = $(ARCHCORE)intern.h $(ARCHCORE)intrpvar.h $(ARCHCORE)iperlsys.h ac5 = $(ARCHCORE)keywords.h $(ARCHCORE)mg.h $(ARCHCORE)nostdio.h ac6 = $(ARCHCORE)op.h $(ARCHCORE)opcode.h $(ARCHCORE)patchlevel.h -ac7 = $(ARCHCORE)perl.h $(ARCHCORE)perlio.h $(ARCHCORE)perlsdio.h +ac7 = $(ARCHCORE)perl.h $(ARCHCORE)perlapi.h $(ARCHCORE)perlio.h $(ARCHCORE)perlsdio.h ac8 = $(ARCHCORE)perlvars.h $(ARCHCORE)perly.h $(ARCHCORE)pp.h ac9 = $(ARCHCORE)pp_proto.h $(ARCHCORE)proto.h $(ARCHCORE)regcomp.h ac10 = $(ARCHCORE)regexp.h $(ARCHCORE)regnodes.h $(ARCHCORE)scope.h ac11 = $(ARCHCORE)sv.h $(ARCHCORE)thrdvar.h $(ARCHCORE)opnames.h ac12 = $(ARCHCORE)thread.h $(ARCHCORE)utf8.h $(ARCHCORE)util.h ac13 = $(ARCHCORE)vmsish.h $(ARCHCORE)warnings.h $(ARCHCORE)xsub.h -ac14 = $(ARCHCORE)perlshr_attr.opt $(ARCHCORE)perlshr_bld.opt +ac14 = $(ARCHCORE)perlshr_attr.opt $(ARCHCORE)$(DBG)perlshr_bld.opt ac = $(ac0) $(ac1) $(ac2) $(ac3) $(ac4) $(ac5) $(ac6) $(ac7) $(ac8) $(ac9) $(ac10) $(ac11) $(ac12) $(ac13) $(ac14) CRTL = []crtl.opt @@ -1031,6 +1031,9 @@ $(ARCHCORE)patchlevel.h : patchlevel.h $(ARCHCORE)perl.h : perl.h @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE) Copy/Log $(MMS$SOURCE) $(MMS$TARGET) +$(ARCHCORE)perlapi.h : perlapi.h + @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE) + Copy/Log $(MMS$SOURCE) $(MMS$TARGET) $(ARCHCORE)perlio.h : perlio.h @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE) Copy/Log $(MMS$SOURCE) $(MMS$TARGET) diff --git a/vms/subconfigure.com b/vms/subconfigure.com index 585ab64..ef81968 100644 --- a/vms/subconfigure.com +++ b/vms/subconfigure.com @@ -137,7 +137,7 @@ $ perl_d_sendmsg = "undef" $ perl_d_recvmsg = "undef" $ perl_d_msghdr_s = "undef" $ perl_d_cmsghdr_s = "undef" -$ IF use_64bitint .eqs. "Y" +$ IF (use64bitint) $ THEN $ perl_use64bitint = "define" $ perl_uselargefiles = "define" @@ -149,8 +149,7 @@ $ perl_uselargefiles = "undef" $ perl_uselongdouble = "undef" $ perl_usemorebits = "undef" $ ENDIF -$ use_64bitall = use_64bitint ! until configure.com question is reworded? -$ IF use_64bitall .eqs. "Y" +$ IF (use64bitall) $ THEN $ perl_use64bitall = "define" $ ELSE @@ -448,7 +447,7 @@ $ perl_pager="most" $! $! Are we 64 bit? $! -$ if (use_64bitint .eqs. "Y") +$ if (use64bitint) $ THEN $ perl_d_PRIfldbl = "define" $ perl_d_PRIgldbl = "define" @@ -4112,7 +4111,7 @@ $ WC "uselargefiles='" + perl_uselargefiles + "'" $ WC "uselongdouble='" + perl_uselongdouble + "'" $ WC "usemorebits='" + perl_usemorebits + "'" $ WC "d_quad='" + perl_d_quad + "'" -$ if (use_64bitint .eqs. "Y") +$ IF (use64bitint) $ THEN $ WC "quadtype='" + perl_quadtype + "'" $ WC "uquadtype='" + perl_uquadtype + "'" @@ -4232,12 +4231,12 @@ $ WRITE CONFIG "#define ALWAYS_DEFTYPES" $ ELSE $ WRITE CONFIG "#undef ALWAYS_DEFTYPES" $ ENDIF -$ if use_64bitint.eqs."Y" +$ IF (use64bitint) $ THEN $ WRITE CONFIG "#define USE_64_BIT_INT" $ WRITE CONFIG "#define USE_LONG_DOUBLE" $ ENDIF -$ if use_64bitall.eqs."Y" +$ IF (use64bitall) $ THEN $ WRITE CONFIG "#define USE_64_BIT_ALL" $ ENDIF diff --git a/vms/test.com b/vms/test.com index 039d844..b1d270d 100644 --- a/vms/test.com +++ b/vms/test.com @@ -45,7 +45,7 @@ $ Delete/Log/NoConfirm Perl.;* $ Copy/Log/NoConfirm [-]'ndbg'Perl'exe' []Perl. $ $! Make the environment look a little friendlier to tests which assume Unix -$ cat = "Type" +$ cat == "Type" $ Macro/NoDebug/NoList/Object=Echo.Obj Sys$Input .title echo .psect data,wrt,noexe @@ -88,7 +88,7 @@ $ Macro/NoDebug/NoList/Object=Echo.Obj Sys$Input .end echo $ Link/NoMap/NoTrace/Exe=Echo.Exe Echo.Obj; $ Delete/Log/NoConfirm Echo.Obj;* -$ echo = "$" + F$Parse("Echo.Exe") +$ echo == "$" + F$Parse("Echo.Exe") $ $! And do it $ Show Process/Accounting @@ -112,7 +112,7 @@ use Config; @libexcl=('db-btree.t','db-hash.t','db-recno.t', 'gdbm.t','io_dup.t', 'io_pipe.t', 'io_poll.t', 'io_sel.t', 'io_sock.t', 'io_unix.t', - 'ndbm.t','odbm.t','open2.t','open3.t', 'ph.t', 'posix.t'); + 'ndbm.t','odbm.t','open2.t','open3.t', 'ph.t', 'posix.t', 'dprof.t'); # Note: POSIX is not part of basic build, but can be built # separately if you're using DECC diff --git a/vms/vms.c b/vms/vms.c index 7327b75..338db262 100644 --- a/vms/vms.c +++ b/vms/vms.c @@ -4273,7 +4273,7 @@ int my_utime(char *file, struct utimbuf *utimes) /* If input was UTC; convert to local for sys svc */ if (!VMSISH_TIME) unixtime = _toloc(unixtime); # endif - unixtime >> 1; secscale << 1; + unixtime >>= 1; secscale <<= 1; retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime); if (!(retsts & 1)) { set_errno(EVMSERR); -- 1.8.3.1