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