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