| 1 | package vmsish; |
| 2 | |
| 3 | our $VERSION = '1.02'; |
| 4 | |
| 5 | =head1 NAME |
| 6 | |
| 7 | vmsish - Perl pragma to control VMS-specific language features |
| 8 | |
| 9 | =head1 SYNOPSIS |
| 10 | |
| 11 | use vmsish; |
| 12 | |
| 13 | use vmsish 'status'; # or '$?' |
| 14 | use vmsish 'exit'; |
| 15 | use vmsish 'time'; |
| 16 | |
| 17 | use vmsish 'hushed'; |
| 18 | no vmsish 'hushed'; |
| 19 | vmsish::hushed($hush); |
| 20 | |
| 21 | use vmsish; |
| 22 | no vmsish 'time'; |
| 23 | |
| 24 | =head1 DESCRIPTION |
| 25 | |
| 26 | If no import list is supplied, all possible VMS-specific features are |
| 27 | assumed. Currently, there are four VMS-specific features available: |
| 28 | 'status' (a.k.a '$?'), 'exit', 'time' and 'hushed'. |
| 29 | |
| 30 | If you're not running VMS, this module does nothing. |
| 31 | |
| 32 | =over 6 |
| 33 | |
| 34 | =item C<vmsish status> |
| 35 | |
| 36 | This makes C<$?> and C<system> return the native VMS exit status |
| 37 | instead of emulating the POSIX exit status. |
| 38 | |
| 39 | =item C<vmsish exit> |
| 40 | |
| 41 | This makes C<exit 1> produce a successful exit (with status SS$_NORMAL), |
| 42 | instead of emulating UNIX exit(), which considers C<exit 1> to indicate |
| 43 | an error. As with the CRTL's exit() function, C<exit 0> is also mapped |
| 44 | to an exit status of SS$_NORMAL, and any other argument to exit() is |
| 45 | used directly as Perl's exit status. |
| 46 | |
| 47 | =item C<vmsish time> |
| 48 | |
| 49 | This makes all times relative to the local time zone, instead of the |
| 50 | default of Universal Time (a.k.a Greenwich Mean Time, or GMT). |
| 51 | |
| 52 | =item C<vmsish hushed> |
| 53 | |
| 54 | This suppresses printing of VMS status messages to SYS$OUTPUT and |
| 55 | SYS$ERROR if Perl terminates with an error status. and allows |
| 56 | programs that are expecting "unix-style" Perl to avoid having to parse |
| 57 | VMS error messages. It does not suppress any messages from Perl |
| 58 | itself, just the messages generated by DCL after Perl exits. The DCL |
| 59 | symbol $STATUS will still have the termination status, but with a |
| 60 | high-order bit set: |
| 61 | |
| 62 | EXAMPLE: |
| 63 | $ perl -e"exit 44;" Non-hushed error exit |
| 64 | %SYSTEM-F-ABORT, abort DCL message |
| 65 | $ show sym $STATUS |
| 66 | $STATUS == "%X0000002C" |
| 67 | |
| 68 | $ perl -e"use vmsish qw(hushed); exit 44;" Hushed error exit |
| 69 | $ show sym $STATUS |
| 70 | $STATUS == "%X1000002C" |
| 71 | |
| 72 | The 'hushed' flag has a global scope during compilation: the exit() or |
| 73 | die() commands that are compiled after 'vmsish hushed' will be hushed |
| 74 | when they are executed. Doing a "no vmsish 'hushed'" turns off the |
| 75 | hushed flag. |
| 76 | |
| 77 | The status of the hushed flag also affects output of VMS error |
| 78 | messages from compilation errors. Again, you still get the Perl |
| 79 | error message (and the code in $STATUS) |
| 80 | |
| 81 | EXAMPLE: |
| 82 | use vmsish 'hushed'; # turn on hushed flag |
| 83 | use Carp; # Carp compiled hushed |
| 84 | exit 44; # will be hushed |
| 85 | croak('I die'); # will be hushed |
| 86 | no vmsish 'hushed'; # turn off hushed flag |
| 87 | exit 44; # will not be hushed |
| 88 | croak('I die2'): # WILL be hushed, croak was compiled hushed |
| 89 | |
| 90 | You can also control the 'hushed' flag at run-time, using the built-in |
| 91 | routine vmsish::hushed(). Without argument, it returns the hushed status. |
| 92 | Since vmsish::hushed is built-in, you do not need to "use vmsish" to call |
| 93 | it. |
| 94 | |
| 95 | EXAMPLE: |
| 96 | if ($quiet_exit) { |
| 97 | vmsish::hushed(1); |
| 98 | } |
| 99 | print "Sssshhhh...I'm hushed...\n" if vmsish::hushed(); |
| 100 | exit 44; |
| 101 | |
| 102 | Note that an exit() or die() that is compiled 'hushed' because of "use |
| 103 | vmsish" is not un-hushed by calling vmsish::hushed(0) at runtime. |
| 104 | |
| 105 | The messages from error exits from inside the Perl core are generally |
| 106 | more serious, and are not suppressed. |
| 107 | |
| 108 | =back |
| 109 | |
| 110 | See L<perlmod/Pragmatic Modules>. |
| 111 | |
| 112 | =cut |
| 113 | |
| 114 | my $IsVMS = $^O eq 'VMS'; |
| 115 | |
| 116 | sub bits { |
| 117 | my $bits = 0; |
| 118 | my $sememe; |
| 119 | foreach $sememe (@_) { |
| 120 | # Those hints are defined in vms/vmsish.h : |
| 121 | # HINT_M_VMSISH_STATUS and HINT_M_VMSISH_TIME |
| 122 | $bits |= 0x40000000, next if $sememe eq 'status' || $sememe eq '$?'; |
| 123 | $bits |= 0x80000000, next if $sememe eq 'time'; |
| 124 | } |
| 125 | $bits; |
| 126 | } |
| 127 | |
| 128 | sub import { |
| 129 | return unless $IsVMS; |
| 130 | |
| 131 | shift; |
| 132 | $^H |= bits(@_ ? @_ : qw(status time)); |
| 133 | my $sememe; |
| 134 | |
| 135 | foreach $sememe (@_ ? @_ : qw(exit hushed)) { |
| 136 | $^H{'vmsish_exit'} = 1 if $sememe eq 'exit'; |
| 137 | vmsish::hushed(1) if $sememe eq 'hushed'; |
| 138 | } |
| 139 | } |
| 140 | |
| 141 | sub unimport { |
| 142 | return unless $IsVMS; |
| 143 | |
| 144 | shift; |
| 145 | $^H &= ~ bits(@_ ? @_ : qw(status time)); |
| 146 | my $sememe; |
| 147 | |
| 148 | foreach $sememe (@_ ? @_ : qw(exit hushed)) { |
| 149 | $^H{'vmsish_exit'} = 0 if $sememe eq 'exit'; |
| 150 | vmsish::hushed(0) if $sememe eq 'hushed'; |
| 151 | } |
| 152 | } |
| 153 | |
| 154 | 1; |