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'; |
14 | |
15 | use vmsish; |
16 | no vmsish 'time'; |
17 | |
18 | =head1 DESCRIPTION |
19 | |
20 | If no import list is supplied, all possible VMS-specific features are |
21 | assumed. Currently, there are three VMS-specific features available: |
22 | 'status' (a.k.a '$?'), 'exit', and 'time'. |
23 | |
24 | =over 6 |
25 | |
26 | =item C<vmsish status> |
27 | |
28 | This makes C<$?> and C<system> return the native VMS exit status |
29 | instead of emulating the POSIX exit status. |
30 | |
31 | =item C<vmsish exit> |
32 | |
33 | This makes C<exit 1> produce a successful exit (with status SS$_NORMAL), |
34 | instead of emulating UNIX exit(), which considers C<exit 1> to indicate |
35 | an error. As with the CRTL's exit() function, C<exit 0> is also mapped |
36 | to an exit status of SS$_NORMAL, and any other argument to exit() is |
37 | used directly as Perl's exit status. |
38 | |
39 | =item C<vmsish time> |
40 | |
41 | This makes all times relative to the local time zone, instead of the |
42 | default of Universal Time (a.k.a Greenwich Mean Time, or GMT). |
43 | |
44 | =back |
45 | |
46 | See L<perlmod/Pragmatic Modules>. |
47 | |
48 | =cut |
49 | |
50 | if ($^O ne 'VMS') { |
51 | require Carp; |
52 | Carp::croak("This isn't VMS"); |
53 | } |
54 | |
55 | sub bits { |
56 | my $bits = 0; |
57 | my $sememe; |
58 | foreach $sememe (@_) { |
a12fb911 |
59 | $bits |= 0x20000000, next if $sememe eq 'status' || $sememe eq '$?'; |
60 | $bits |= 0x40000000, next if $sememe eq 'exit'; |
61 | $bits |= 0x80000000, next if $sememe eq 'time'; |
ff0cee69 |
62 | } |
63 | $bits; |
64 | } |
65 | |
66 | sub import { |
67 | shift; |
68 | $^H |= bits(@_ ? @_ : qw(status exit time)); |
69 | } |
70 | |
71 | sub unimport { |
72 | shift; |
73 | $^H &= ~ bits(@_ ? @_ : qw(status exit time)); |
74 | } |
75 | |
76 | 1; |