lib/validate.pl Perl library supporting wholesale file mode validation
lib/vars.pm Declare pseudo-imported global variables
lib/vars.t See if "use vars" work
+lib/vmsish.pm Control VMS-specific behavior of Perl core
+lib/vmsish.t Tests for vmsish.pm
lib/warnings.pm For "use warnings"
lib/warnings.t See if warning controls work
lib/warnings/register.pm For "use warnings::register"
vms/ext/Stdio/Stdio.pm VMS options to stdio routines
vms/ext/Stdio/Stdio.xs VMS options to stdio routines
vms/ext/Stdio/test.pl regression tests for VMS::Stdio
-vms/ext/vmsish.pm Control VMS-specific behavior of Perl core
-vms/ext/vmsish.t Tests for vmsish.pm
vms/ext/XSSymSet.pm manage linker symbols when building extensions
vms/genconfig.pl retcon config.sh from config.h
vms/genopt.com hack to write options files in case of broken makes
--- /dev/null
+package vmsish;
+
+=head1 NAME
+
+vmsish - Perl pragma to control VMS-specific language features
+
+=head1 SYNOPSIS
+
+ use vmsish;
+
+ use vmsish 'status'; # or '$?'
+ use vmsish 'exit';
+ use vmsish 'time';
+
+ use vmsish 'hushed';
+ no vmsish 'hushed';
+ vmsish::hushed($hush);
+
+ use vmsish;
+ no vmsish 'time';
+
+=head1 DESCRIPTION
+
+If no import list is supplied, all possible VMS-specific features are
+assumed. Currently, there are four VMS-specific features available:
+'status' (a.k.a '$?'), 'exit', 'time' and 'hushed'.
+
+If you're not running VMS, this module does nothing.
+
+=over 6
+
+=item C<vmsish status>
+
+This makes C<$?> and C<system> return the native VMS exit status
+instead of emulating the POSIX exit status.
+
+=item C<vmsish exit>
+
+This makes C<exit 1> produce a successful exit (with status SS$_NORMAL),
+instead of emulating UNIX exit(), which considers C<exit 1> to indicate
+an error. As with the CRTL's exit() function, C<exit 0> is also mapped
+to an exit status of SS$_NORMAL, and any other argument to exit() is
+used directly as Perl's exit status.
+
+=item C<vmsish time>
+
+This makes all times relative to the local time zone, instead of the
+default of Universal Time (a.k.a Greenwich Mean Time, or GMT).
+
+=item C<vmsish hushed>
+
+This suppresses printing of VMS status messages to SYS$OUTPUT and
+SYS$ERROR if Perl terminates with an error status. and allows
+programs that are expecting "unix-style" Perl to avoid having to parse
+VMS error messages. It does not supress any messages from Perl
+itself, just the messages generated by DCL after Perl exits. The DCL
+symbol $STATUS will still have the termination status, but with a
+high-order bit set:
+
+EXAMPLE:
+ $ perl -e"exit 44;" Non-hushed error exit
+ %SYSTEM-F-ABORT, abort DCL message
+ $ show sym $STATUS
+ $STATUS == "%X0000002C"
+
+ $ perl -e"use vmsish qw(hushed); exit 44;" Hushed error exit
+ $ show sym $STATUS
+ $STATUS == "%X1000002C"
+
+The 'hushed' flag has a global scope during compilation: the exit() or
+die() commands that are compiled after 'vmsish hushed' will be hushed
+when they are executed. Doing a "no vmsish 'hushed'" turns off the
+hushed flag.
+
+The status of the hushed flag also affects output of VMS error
+messages from compilation errors. Again, you still get the Perl
+error message (and the code in $STATUS)
+
+EXAMPLE:
+ use vmsish 'hushed'; # turn on hushed flag
+ use Carp; # Carp compiled hushed
+ exit 44; # will be hushed
+ croak('I die'); # will be hushed
+ no vmsish 'hushed'; # turn off hushed flag
+ exit 44; # will not be hushed
+ croak('I die2'): # WILL be hushed, croak was compiled hushed
+
+You can also control the 'hushed' flag at run-time, using the built-in
+routine vmsish::hushed(). Without argument, it returns the hushed status.
+Since vmsish::hushed is built-in, you do not need to "use vmsish" to call
+it.
+
+EXAMPLE:
+ if ($quiet_exit) {
+ vmsish::hushed(1);
+ }
+ print "Sssshhhh...I'm hushed...\n" if vmsish::hushed();
+ exit 44;
+
+Note that an exit() or die() that is compiled 'hushed' because of "use
+vmsish" is not un-hushed by calling vmsish::hushed(0) at runtime.
+
+The messages from error exits from inside the Perl core are generally
+more serious, and are not supressed.
+
+=back
+
+See L<perlmod/Pragmatic Modules>.
+
+=cut
+
+my $IsVMS = $^O eq 'VMS';
+
+sub bits {
+ my $bits = 0;
+ my $sememe;
+ foreach $sememe (@_) {
+ $bits |= 0x40000000, next if $sememe eq 'status' || $sememe eq '$?';
+ $bits |= 0x80000000, next if $sememe eq 'time';
+ }
+ $bits;
+}
+
+sub import {
+ return unless $IsVMS;
+
+ shift;
+ $^H |= bits(@_ ? @_ : qw(status time));
+ my $sememe;
+
+ foreach $sememe (@_ ? @_ : qw(exit hushed)) {
+ $^H{'vmsish_exit'} = 1 if $sememe eq 'exit';
+ vmsish::hushed(1) if $sememe eq 'hushed';
+ }
+}
+
+sub unimport {
+ return unless $IsVMS;
+
+ shift;
+ $^H &= ~ bits(@_ ? @_ : qw(status time));
+ my $sememe;
+
+ foreach $sememe (@_ ? @_ : qw(exit hushed)) {
+ $^H{'vmsish_exit'} = 0 if $sememe eq 'exit';
+ vmsish::hushed(0) if $sememe eq 'hushed';
+ }
+}
+
+1;
--- /dev/null
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+my $Invoke_Perl = qq(MCR $^X "-I[-.lib]");
+
+require "./test.pl";
+plan(tests => 25);
+
+SKIP: {
+ skip("tests for non-VMS only", 1) if $^O eq 'VMS';
+
+ BEGIN { $Orig_Bits = $^H }
+
+ # make sure that all those 'use vmsish' calls didn't do anything.
+ is( $Orig_Bits, $^H, 'use vmsish a no-op' );
+}
+
+SKIP: {
+ skip("tests for VMS only", 24) unless $^O eq 'VMS';
+
+#========== vmsish status ==========
+`$Invoke_Perl -e 1`; # Avoid system() from a pipe from harness. Mutter.
+is($?,0,"simple Perl invokation: POSIX success status");
+{
+ use vmsish qw(status);
+ is(($? & 1),1, "importing vmsish [vmsish status]");
+ {
+ no vmsish qw(status); # check unimport function
+ is($?,0, "unimport vmsish [POSIX STATUS]");
+ }
+ # and lexical scoping
+ is(($? & 1),1,"lex scope of vmsish [vmsish status]");
+}
+is($?,0,"outer lex scope of vmsish [POSIX status]");
+
+{
+ use vmsish qw(exit); # check import function
+ is($?,0,"importing vmsish exit [POSIX status]");
+}
+
+#========== vmsish exit, messages ==========
+{
+ use vmsish qw(status);
+
+ $msg = do_a_perl('-e "exit 1"');
+ $msg =~ s/\n/\\n/g; # keep output on one line
+ like($msg,'ABORT', "POSIX ERR exit, DCL error message check");
+ is($?&1,0,"vmsish status check, POSIX ERR exit");
+
+ $msg = do_a_perl('-e "use vmsish qw(exit); exit 1"');
+ $msg =~ s/\n/\\n/g; # keep output on one line
+ ok(length($msg)==0,"vmsish OK exit, DCL error message check");
+ is($?&1,1, "vmsish status check, vmsish OK exit");
+
+ $msg = do_a_perl('-e "use vmsish qw(exit); exit 44"');
+ $msg =~ s/\n/\\n/g; # keep output on one line
+ like($msg, 'ABORT', "vmsish ERR exit, DCL error message check");
+ is($?&1,0,"vmsish ERR exit, vmsish status check");
+
+ $msg = do_a_perl('-e "use vmsish qw(hushed); exit 1"');
+ $msg =~ s/\n/\\n/g; # keep output on one line
+ ok(($msg !~ /ABORT/),"POSIX ERR exit, vmsish hushed, DCL error message check");
+
+ $msg = do_a_perl('-e "use vmsish qw(exit hushed); exit 44"');
+ $msg =~ s/\n/\\n/g; # keep output on one line
+ ok(($msg !~ /ABORT/),"vmsish ERR exit, vmsish hushed, DCL error message check");
+
+ $msg = do_a_perl('-e "use vmsish qw(exit hushed); no vmsish qw(hushed); exit 44"');
+ $msg =~ s/\n/\\n/g; # keep output on one line
+ like($msg,'ABORT',"vmsish ERR exit, no vmsish hushed, DCL error message check");
+
+ $msg = do_a_perl('-e "use vmsish qw(hushed); die(qw(blah));"');
+ $msg =~ s/\n/\\n/g; # keep output on one line
+ ok(($msg !~ /ABORT/),"die, vmsish hushed, DCL error message check");
+
+ $msg = do_a_perl('-e "use vmsish qw(hushed); use Carp; croak(qw(blah));"');
+ $msg =~ s/\n/\\n/g; # keep output on one line
+ ok(($msg !~ /ABORT/),"croak, vmsish hushed, DCL error message check");
+
+ $msg = do_a_perl('-e "use vmsish qw(exit); vmsish::hushed(1); exit 44;"');
+ $msg =~ s/\n/\\n/g; # keep output on one line
+ ok(($msg !~ /ABORT/),"vmsish ERR exit, vmsish hushed at runtime, DCL error message check");
+
+ local *TEST;
+ open(TEST,'>vmsish_test.pl') || die('not ok ?? : unable to open "vmsish_test.pl" for writing');
+ print TEST "#! perl\n";
+ print TEST "use vmsish qw(hushed);\n";
+ print TEST "\$obvious = (\$compile(\$error;\n";
+ close TEST;
+ $msg = do_a_perl('vmsish_test.pl');
+ $msg =~ s/\n/\\n/g; # keep output on one line
+ ok(($msg !~ /ABORT/),"compile ERR exit, vmsish hushed, DCL error message check");
+ unlink 'vmsish_test.pl';
+}
+
+
+#========== vmsish time ==========
+{
+ my($utctime, @utclocal, @utcgmtime, $utcmtime,
+ $vmstime, @vmslocal, @vmsgmtime, $vmsmtime,
+ $utcval, $vmaval, $offset);
+ # Make sure apparent local time isn't GMT
+ if (not $ENV{'SYS$TIMEZONE_DIFFERENTIAL'}) {
+ $oldtz = $ENV{'SYS$TIMEZONE_DIFFERENTIAL'};
+ $ENV{'SYS$TIMEZONE_DIFFERENTIAL'} = 3600;
+ eval "END { \$ENV{'SYS\$TIMEZONE_DIFFERENTIAL'} = $oldtz; }";
+ gmtime(0); # Force reset of tz offset
+ }
+ {
+ use_ok('vmsish qw(time)');
+ $vmstime = time;
+ @vmslocal = localtime($vmstime);
+ @vmsgmtime = gmtime($vmstime);
+ $vmsmtime = (stat $0)[9];
+ }
+ $utctime = time;
+ @utclocal = localtime($vmstime);
+ @utcgmtime = gmtime($vmstime);
+ $utcmtime = (stat $0)[9];
+
+ $offset = $ENV{'SYS$TIMEZONE_DIFFERENTIAL'};
+
+ # We allow lots of leeway (10 sec) difference for these tests,
+ # since it's unlikely local time will differ from UTC by so small
+ # an amount, and it renders the test resistant to delays from
+ # things like stat() on a file mounted over a slow network link.
+ ok($utctime - $vmstime +$offset <= 10,"(time) UTC:$utctime VMS:$vmstime");
+
+ $utcval = $utclocal[5] * 31536000 + $utclocal[7] * 86400 +
+ $utclocal[2] * 3600 + $utclocal[1] * 60 + $utclocal[0];
+ $vmsval = $vmslocal[5] * 31536000 + $vmslocal[7] * 86400 +
+ $vmslocal[2] * 3600 + $vmslocal[1] * 60 + $vmslocal[0];
+ ok($vmsval - $utcval + $offset <= 10, "(localtime)\n# UTC: @utclocal\n# VMS: @vmslocal");
+
+ $utcval = $utcgmtime[5] * 31536000 + $utcgmtime[7] * 86400 +
+ $utcgmtime[2] * 3600 + $utcgmtime[1] * 60 + $utcgmtime[0];
+ $vmsval = $vmsgmtime[5] * 31536000 + $vmsgmtime[7] * 86400 +
+ $vmsgmtime[2] * 3600 + $vmsgmtime[1] * 60 + $vmsgmtime[0];
+ ok($vmsval - $utcval + $offset <= 10, "(gmtime)\n# UTC: @utcgmtime\n# VMS: @vmsgmtime");
+
+ ok($vmsmtime - $utcmtime + $offset <= 10,"(stat) UTC: $utcmtime VMS: $vmsmtime");
+}
+}
+
+#====== need this to make sure error messages come out, even if
+# they were turned off in invoking procedure
+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`;
+ unlink 'vmsish_test.com';
+ return $x;
+}
+
.endif
# Modules which must be installed before we can build extensions
-LIBPREREQ = $(ARCHDIR)Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm [.lib]XSLoader.pm [.lib]lib.pm [.lib]vmsish.pm [.lib.ExtUtils]XSSymSet.pm $(ARCHDIR)vmspipe.com [.lib]re.pm
+LIBPREREQ = $(ARCHDIR)Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm [.lib]XSLoader.pm [.lib]lib.pm [.lib.ExtUtils]XSSymSet.pm $(ARCHDIR)vmspipe.com [.lib]re.pm
utils1 = [.lib.pod]perldoc.com [.lib.ExtUtils]Miniperl.pm [.utils]c2ph.com [.utils]h2ph.com [.utils]h2xs.com [.lib]perlbug.com [.lib]perlcc.com [.utils]dprofpp.com
utils2 = [.utils]perlivp.com [.lib]splain.com [.utils]pl2pm.com
dynext : $(LIBPREREQ) $(DBG)perlshr$(E) preplibrary
@make_ext "$(MINIPERL_EXE)" "$(MMS)"
-[.lib]vmsish.pm : [.vms.ext]vmsish.pm
- Copy/Log/NoConfirm $(MMS$SOURCE) $(MMS$TARGET)
-
[.lib]lib.pm : [.lib]lib_pm.PL
$(MINIPERL) $(MMS$SOURCE)
[.t.lib]vmsfspec.t : [.vms.ext]filespec.t
Copy/Log/NoConfirm $(MMS$SOURCE) $(MMS$TARGET)
-[.t.lib]vmsish.t : [.vms.ext]vmsish.t
- Copy/Log/NoConfirm $(MMS$SOURCE) $(MMS$TARGET)
-
[.t.lib]vms_dclsym.t : [.vms.ext.DCLsym]test.pl
Copy/Log/NoConfirm $(MMS$SOURCE) $(MMS$TARGET)
check : test
@ Continue
-test : all [.t.lib]vmsfspec.t [.t.lib]vmsish.t [.t.lib]vms_dclsym.t [.t.lib]vms_stdio.t
+test : all [.t.lib]vmsfspec.t [.t.lib]vms_dclsym.t [.t.lib]vms_stdio.t
- @[.VMS]Test.Com "$(E)" "$(__DEBUG__)"
@ $(MINIPERL) -e "print ""Ran tests"";" > [.t]rantests.
+++ /dev/null
-package vmsish;
-
-=head1 NAME
-
-vmsish - Perl pragma to control VMS-specific language features
-
-=head1 SYNOPSIS
-
- use vmsish;
-
- use vmsish 'status'; # or '$?'
- use vmsish 'exit';
- use vmsish 'time';
-
- use vmsish 'hushed';
- no vmsish 'hushed';
- vmsish::hushed($hush);
-
- use vmsish;
- no vmsish 'time';
-
-=head1 DESCRIPTION
-
-If no import list is supplied, all possible VMS-specific features are
-assumed. Currently, there are four VMS-specific features available:
-'status' (a.k.a '$?'), 'exit', 'time' and 'hushed'.
-
-=over 6
-
-=item C<vmsish status>
-
-This makes C<$?> and C<system> return the native VMS exit status
-instead of emulating the POSIX exit status.
-
-=item C<vmsish exit>
-
-This makes C<exit 1> produce a successful exit (with status SS$_NORMAL),
-instead of emulating UNIX exit(), which considers C<exit 1> to indicate
-an error. As with the CRTL's exit() function, C<exit 0> is also mapped
-to an exit status of SS$_NORMAL, and any other argument to exit() is
-used directly as Perl's exit status.
-
-=item C<vmsish time>
-
-This makes all times relative to the local time zone, instead of the
-default of Universal Time (a.k.a Greenwich Mean Time, or GMT).
-
-=item C<vmsish hushed>
-
-This suppresses printing of VMS status messages to SYS$OUTPUT and
-SYS$ERROR if Perl terminates with an error status. and allows
-programs that are expecting "unix-style" Perl to avoid having to parse
-VMS error messages. It does not supress any messages from Perl
-itself, just the messages generated by DCL after Perl exits. The DCL
-symbol $STATUS will still have the termination status, but with a
-high-order bit set:
-
-EXAMPLE:
- $ perl -e"exit 44;" Non-hushed error exit
- %SYSTEM-F-ABORT, abort DCL message
- $ show sym $STATUS
- $STATUS == "%X0000002C"
-
- $ perl -e"use vmsish qw(hushed); exit 44;" Hushed error exit
- $ show sym $STATUS
- $STATUS == "%X1000002C"
-
-The 'hushed' flag has a global scope during compilation: the exit() or
-die() commands that are compiled after 'vmsish hushed' will be hushed
-when they are executed. Doing a "no vmsish 'hushed'" turns off the
-hushed flag.
-
-The status of the hushed flag also affects output of VMS error
-messages from compilation errors. Again, you still get the Perl
-error message (and the code in $STATUS)
-
-EXAMPLE:
- use vmsish 'hushed'; # turn on hushed flag
- use Carp; # Carp compiled hushed
- exit 44; # will be hushed
- croak('I die'); # will be hushed
- no vmsish 'hushed'; # turn off hushed flag
- exit 44; # will not be hushed
- croak('I die2'): # WILL be hushed, croak was compiled hushed
-
-You can also control the 'hushed' flag at run-time, using the built-in
-routine vmsish::hushed(). Without argument, it returns the hushed status.
-Since vmsish::hushed is built-in, you do not need to "use vmsish" to call
-it.
-
-EXAMPLE:
- if ($quiet_exit) {
- vmsish::hushed(1);
- }
- print "Sssshhhh...I'm hushed...\n" if vmsish::hushed();
- exit 44;
-
-Note that an exit() or die() that is compiled 'hushed' because of "use
-vmsish" is not un-hushed by calling vmsish::hushed(0) at runtime.
-
-The messages from error exits from inside the Perl core are generally
-more serious, and are not supressed.
-
-=back
-
-See L<perlmod/Pragmatic Modules>.
-
-=cut
-
-if ($^O ne 'VMS') {
- require Carp;
- Carp::croak("This isn't VMS");
-}
-
-sub bits {
- my $bits = 0;
- my $sememe;
- foreach $sememe (@_) {
- $bits |= 0x40000000, next if $sememe eq 'status' || $sememe eq '$?';
- $bits |= 0x80000000, next if $sememe eq 'time';
- }
- $bits;
-}
-
-sub import {
- shift;
- $^H |= bits(@_ ? @_ : qw(status time));
- my $sememe;
-
- foreach $sememe (@_ ? @_ : qw(exit hushed)) {
- $^H{'vmsish_exit'} = 1 if $sememe eq 'exit';
- vmsish::hushed(1) if $sememe eq 'hushed';
- }
-}
-
-sub unimport {
- shift;
- $^H &= ~ bits(@_ ? @_ : qw(status time));
- my $sememe;
-
- foreach $sememe (@_ ? @_ : qw(exit hushed)) {
- $^H{'vmsish_exit'} = 0 if $sememe eq 'exit';
- vmsish::hushed(0) if $sememe eq 'hushed';
- }
-}
-
-1;
+++ /dev/null
-
-BEGIN { unshift @INC, '[-.lib]'; }
-
-my $Invoke_Perl = qq(MCR $^X "-I[-.lib]");
-
-require "test.pl";
-plan(tests => 24);
-
-#========== vmsish status ==========
-`$Invoke_Perl -e 1`; # Avoid system() from a pipe from harness. Mutter.
-is($?,0,"simple Perl invokation: POSIX success status");
-{
- use vmsish qw(status);
- is(($? & 1),1, "importing vmsish [vmsish status]");
- {
- no vmsish qw(status); # check unimport function
- is($?,0, "unimport vmsish [POSIX STATUS]");
- }
- # and lexical scoping
- is(($? & 1),1,"lex scope of vmsish [vmsish status]");
-}
-is($?,0,"outer lex scope of vmsish [POSIX status]");
-
-{
- use vmsish qw(exit); # check import function
- is($?,0,"importing vmsish exit [POSIX status]");
-}
-
-#========== vmsish exit, messages ==========
-{
- use vmsish qw(status);
-
- $msg = do_a_perl('-e "exit 1"');
- $msg =~ s/\n/\\n/g; # keep output on one line
- like($msg,'ABORT', "POSIX ERR exit, DCL error message check");
- is($?&1,0,"vmsish status check, POSIX ERR exit");
-
- $msg = do_a_perl('-e "use vmsish qw(exit); exit 1"');
- $msg =~ s/\n/\\n/g; # keep output on one line
- ok(length($msg)==0,"vmsish OK exit, DCL error message check");
- is($?&1,1, "vmsish status check, vmsish OK exit");
-
- $msg = do_a_perl('-e "use vmsish qw(exit); exit 44"');
- $msg =~ s/\n/\\n/g; # keep output on one line
- like($msg, 'ABORT', "vmsish ERR exit, DCL error message check");
- is($?&1,0,"vmsish ERR exit, vmsish status check");
-
- $msg = do_a_perl('-e "use vmsish qw(hushed); exit 1"');
- $msg =~ s/\n/\\n/g; # keep output on one line
- ok(($msg !~ /ABORT/),"POSIX ERR exit, vmsish hushed, DCL error message check");
-
- $msg = do_a_perl('-e "use vmsish qw(exit hushed); exit 44"');
- $msg =~ s/\n/\\n/g; # keep output on one line
- ok(($msg !~ /ABORT/),"vmsish ERR exit, vmsish hushed, DCL error message check");
-
- $msg = do_a_perl('-e "use vmsish qw(exit hushed); no vmsish qw(hushed); exit 44"');
- $msg =~ s/\n/\\n/g; # keep output on one line
- like($msg,'ABORT',"vmsish ERR exit, no vmsish hushed, DCL error message check");
-
- $msg = do_a_perl('-e "use vmsish qw(hushed); die(qw(blah));"');
- $msg =~ s/\n/\\n/g; # keep output on one line
- ok(($msg !~ /ABORT/),"die, vmsish hushed, DCL error message check");
-
- $msg = do_a_perl('-e "use vmsish qw(hushed); use Carp; croak(qw(blah));"');
- $msg =~ s/\n/\\n/g; # keep output on one line
- ok(($msg !~ /ABORT/),"croak, vmsish hushed, DCL error message check");
-
- $msg = do_a_perl('-e "use vmsish qw(exit); vmsish::hushed(1); exit 44;"');
- $msg =~ s/\n/\\n/g; # keep output on one line
- ok(($msg !~ /ABORT/),"vmsish ERR exit, vmsish hushed at runtime, DCL error message check");
-
- local *TEST;
- open(TEST,'>vmsish_test.pl') || die('not ok ?? : unable to open "vmsish_test.pl" for writing');
- print TEST "#! perl\n";
- print TEST "use vmsish qw(hushed);\n";
- print TEST "\$obvious = (\$compile(\$error;\n";
- close TEST;
- $msg = do_a_perl('vmsish_test.pl');
- $msg =~ s/\n/\\n/g; # keep output on one line
- ok(($msg !~ /ABORT/),"compile ERR exit, vmsish hushed, DCL error message check");
- unlink 'vmsish_test.pl';
-}
-
-
-#========== vmsish time ==========
-{
- my($utctime, @utclocal, @utcgmtime, $utcmtime,
- $vmstime, @vmslocal, @vmsgmtime, $vmsmtime,
- $utcval, $vmaval, $offset);
- # Make sure apparent local time isn't GMT
- if (not $ENV{'SYS$TIMEZONE_DIFFERENTIAL'}) {
- $oldtz = $ENV{'SYS$TIMEZONE_DIFFERENTIAL'};
- $ENV{'SYS$TIMEZONE_DIFFERENTIAL'} = 3600;
- eval "END { \$ENV{'SYS\$TIMEZONE_DIFFERENTIAL'} = $oldtz; }";
- gmtime(0); # Force reset of tz offset
- }
- {
- use_ok('vmsish qw(time)');
- $vmstime = time;
- @vmslocal = localtime($vmstime);
- @vmsgmtime = gmtime($vmstime);
- $vmsmtime = (stat $0)[9];
- }
- $utctime = time;
- @utclocal = localtime($vmstime);
- @utcgmtime = gmtime($vmstime);
- $utcmtime = (stat $0)[9];
-
- $offset = $ENV{'SYS$TIMEZONE_DIFFERENTIAL'};
-
- # We allow lots of leeway (10 sec) difference for these tests,
- # since it's unlikely local time will differ from UTC by so small
- # an amount, and it renders the test resistant to delays from
- # things like stat() on a file mounted over a slow network link.
- ok($utctime - $vmstime +$offset <= 10,"(time) UTC:$utctime VMS:$vmstime");
-
- $utcval = $utclocal[5] * 31536000 + $utclocal[7] * 86400 +
- $utclocal[2] * 3600 + $utclocal[1] * 60 + $utclocal[0];
- $vmsval = $vmslocal[5] * 31536000 + $vmslocal[7] * 86400 +
- $vmslocal[2] * 3600 + $vmslocal[1] * 60 + $vmslocal[0];
- ok($vmsval - $utcval + $offset <= 10, "(localtime)\n# UTC: @utclocal\n# VMS: @vmslocal");
-
- $utcval = $utcgmtime[5] * 31536000 + $utcgmtime[7] * 86400 +
- $utcgmtime[2] * 3600 + $utcgmtime[1] * 60 + $utcgmtime[0];
- $vmsval = $vmsgmtime[5] * 31536000 + $vmsgmtime[7] * 86400 +
- $vmsgmtime[2] * 3600 + $vmsgmtime[1] * 60 + $vmsgmtime[0];
- ok($vmsval - $utcval + $offset <= 10, "(gmtime)\n# UTC: @utcgmtime\n# VMS: @vmsgmtime");
-
- ok($vmsmtime - $utcmtime + $offset <= 10,"(stat) UTC: $utcmtime VMS: $vmsmtime");
-}
-
-#====== need this to make sure error messages come out, even if
-# they were turned off in invoking procedure
-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`;
- unlink 'vmsish_test.com';
- return $x;
-}
-
projects / platform / upstream / perl.git / commitdiff