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;
|
---|