From 9f84c00564fd021b1da47513d58d337c301b73aa Mon Sep 17 00:00:00 2001 From: "Michael G. Schwern" Date: Mon, 12 Nov 2001 15:50:34 -0500 Subject: Making vmsish.pm a no-op on non-VMS Message-ID: <20011112205034.H2888@blackrider> p4raw-id: //depot/perl@12971 --- vms/ext/vmsish.pm | 147 ------------------------------------------------------ vms/ext/vmsish.t | 145 ----------------------------------------------------- 2 files changed, 292 deletions(-) delete mode 100644 vms/ext/vmsish.pm delete mode 100644 vms/ext/vmsish.t (limited to 'vms/ext') diff --git a/vms/ext/vmsish.pm b/vms/ext/vmsish.pm deleted file mode 100644 index 89ec72c28c..0000000000 --- a/vms/ext/vmsish.pm +++ /dev/null @@ -1,147 +0,0 @@ -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 - -This makes C<$?> and C return the native VMS exit status -instead of emulating the POSIX exit status. - -=item C - -This makes C produce a successful exit (with status SS$_NORMAL), -instead of emulating UNIX exit(), which considers C to indicate -an error. As with the CRTL's exit() function, C 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 - -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 - -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. - -=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; diff --git a/vms/ext/vmsish.t b/vms/ext/vmsish.t deleted file mode 100644 index 0f3c0ec1eb..0000000000 --- a/vms/ext/vmsish.t +++ /dev/null @@ -1,145 +0,0 @@ - -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; -} - -- cgit v1.2.1