Commit | Line | Data |
---|---|---|
ff0cee69 | 1 | package vmsish; |
2 | ||
28b605d8 JH |
3 | our $VERSION = '1.00'; |
4 | ||
ff0cee69 | 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'; | |
96e176bf | 16 | |
925fd5a3 | 17 | use vmsish 'hushed'; |
96e176bf CL |
18 | no vmsish 'hushed'; |
19 | vmsish::hushed($hush); | |
ff0cee69 | 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 | |
925fd5a3 | 27 | assumed. Currently, there are four VMS-specific features available: |
ee8c7f54 | 28 | 'status' (a.k.a '$?'), 'exit', 'time' and 'hushed'. |
ff0cee69 | 29 | |
9f84c005 MS |
30 | If you're not running VMS, this module does nothing. |
31 | ||
ff0cee69 | 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 | ||
925fd5a3 CB |
52 | =item C<vmsish hushed> |
53 | ||
96e176bf CL |
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 supress 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 supressed. | |
925fd5a3 | 107 | |
ff0cee69 | 108 | =back |
109 | ||
110 | See L<perlmod/Pragmatic Modules>. | |
111 | ||
112 | =cut | |
113 | ||
9f84c005 | 114 | my $IsVMS = $^O eq 'VMS'; |
ff0cee69 | 115 | |
116 | sub bits { | |
117 | my $bits = 0; | |
118 | my $sememe; | |
119 | foreach $sememe (@_) { | |
744a34f9 | 120 | $bits |= 0x40000000, next if $sememe eq 'status' || $sememe eq '$?'; |
a12fb911 | 121 | $bits |= 0x80000000, next if $sememe eq 'time'; |
ff0cee69 | 122 | } |
123 | $bits; | |
124 | } | |
125 | ||
126 | sub import { | |
9f84c005 MS |
127 | return unless $IsVMS; |
128 | ||
ff0cee69 | 129 | shift; |
96e176bf | 130 | $^H |= bits(@_ ? @_ : qw(status time)); |
744a34f9 CB |
131 | my $sememe; |
132 | ||
96e176bf | 133 | foreach $sememe (@_ ? @_ : qw(exit hushed)) { |
744a34f9 | 134 | $^H{'vmsish_exit'} = 1 if $sememe eq 'exit'; |
96e176bf | 135 | vmsish::hushed(1) if $sememe eq 'hushed'; |
744a34f9 | 136 | } |
ff0cee69 | 137 | } |
138 | ||
139 | sub unimport { | |
9f84c005 MS |
140 | return unless $IsVMS; |
141 | ||
ff0cee69 | 142 | shift; |
96e176bf | 143 | $^H &= ~ bits(@_ ? @_ : qw(status time)); |
744a34f9 CB |
144 | my $sememe; |
145 | ||
96e176bf | 146 | foreach $sememe (@_ ? @_ : qw(exit hushed)) { |
744a34f9 | 147 | $^H{'vmsish_exit'} = 0 if $sememe eq 'exit'; |
96e176bf | 148 | vmsish::hushed(0) if $sememe eq 'hushed'; |
744a34f9 | 149 | } |
ff0cee69 | 150 | } |
151 | ||
152 | 1; |