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'; | |
925fd5a3 | 14 | use vmsish 'hushed'; |
ff0cee69 | 15 | |
16 | use vmsish; | |
17 | no vmsish 'time'; | |
18 | ||
19 | =head1 DESCRIPTION | |
20 | ||
21 | If no import list is supplied, all possible VMS-specific features are | |
925fd5a3 | 22 | assumed. Currently, there are four VMS-specific features available: |
ee8c7f54 | 23 | 'status' (a.k.a '$?'), 'exit', 'time' and 'hushed'. |
ff0cee69 | 24 | |
25 | =over 6 | |
26 | ||
27 | =item C<vmsish status> | |
28 | ||
29 | This makes C<$?> and C<system> return the native VMS exit status | |
30 | instead of emulating the POSIX exit status. | |
31 | ||
32 | =item C<vmsish exit> | |
33 | ||
34 | This makes C<exit 1> produce a successful exit (with status SS$_NORMAL), | |
35 | instead of emulating UNIX exit(), which considers C<exit 1> to indicate | |
36 | an error. As with the CRTL's exit() function, C<exit 0> is also mapped | |
37 | to an exit status of SS$_NORMAL, and any other argument to exit() is | |
38 | used directly as Perl's exit status. | |
39 | ||
40 | =item C<vmsish time> | |
41 | ||
42 | This makes all times relative to the local time zone, instead of the | |
43 | default of Universal Time (a.k.a Greenwich Mean Time, or GMT). | |
44 | ||
925fd5a3 CB |
45 | =item C<vmsish hushed> |
46 | ||
ee8c7f54 CB |
47 | This suppresses printing of VMS status messages to SYS$OUTPUT and SYS$ERROR |
48 | if Perl terminates with an error status. This primarily effects error | |
49 | exits from things like Perl compiler errors or "standard Perl" runtime errors, | |
50 | where text error messages are also generated by Perl. | |
51 | ||
52 | The error exits from inside the core are generally more serious, and are | |
53 | not supressed. | |
925fd5a3 | 54 | |
ff0cee69 | 55 | =back |
56 | ||
57 | See L<perlmod/Pragmatic Modules>. | |
58 | ||
59 | =cut | |
60 | ||
61 | if ($^O ne 'VMS') { | |
62 | require Carp; | |
63 | Carp::croak("This isn't VMS"); | |
64 | } | |
65 | ||
66 | sub bits { | |
67 | my $bits = 0; | |
68 | my $sememe; | |
69 | foreach $sememe (@_) { | |
744a34f9 CB |
70 | $bits |= 0x20000000, next if $sememe eq 'hushed'; |
71 | $bits |= 0x40000000, next if $sememe eq 'status' || $sememe eq '$?'; | |
a12fb911 | 72 | $bits |= 0x80000000, next if $sememe eq 'time'; |
ff0cee69 | 73 | } |
74 | $bits; | |
75 | } | |
76 | ||
77 | sub import { | |
78 | shift; | |
744a34f9 CB |
79 | $^H |= bits(@_ ? @_ : qw(status time hushed)); |
80 | my $sememe; | |
81 | ||
82 | foreach $sememe (@_ ? @_ : qw(exit)) { | |
83 | $^H{'vmsish_exit'} = 1 if $sememe eq 'exit'; | |
84 | } | |
ff0cee69 | 85 | } |
86 | ||
87 | sub unimport { | |
88 | shift; | |
744a34f9 CB |
89 | $^H &= ~ bits(@_ ? @_ : qw(status time hushed)); |
90 | my $sememe; | |
91 | ||
92 | foreach $sememe (@_ ? @_ : qw(exit)) { | |
93 | $^H{'vmsish_exit'} = 0 if $sememe eq 'exit'; | |
94 | } | |
ff0cee69 | 95 | } |
96 | ||
97 | 1; |