vms/ext/vmsish.pm

   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     use vmsish 'hushed';
  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
  22 assumed.  Currently, there are four VMS-specific features available:
  23 'status' (a.k.a '$?'), 'exit', 'time' and 'messages' (a.k.a 'message').
  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
  45 =item C<vmsish hushed>
  46
  47 This supresses printing of VMS status messages to SYS$OUTPUT and SYS$ERROR
  48 if Perl terminates with an error status.
  49
  50 =back
  51
  52 See L<perlmod/Pragmatic Modules>.
  53
  54 =cut
  55
  56 if ($^O ne 'VMS') {
  57     require Carp;
  58     Carp::croak("This isn't VMS");
  59 }
  60
  61 sub bits {
  62     my $bits = 0;
  63     my $sememe;
  64     foreach $sememe (@_) {
  65         $bits |= 0x10000000, next if $sememe eq 'hushed';
  66         $bits |= 0x20000000, next if $sememe eq 'status' || $sememe eq '$?';
  67         $bits |= 0x40000000, next if $sememe eq 'exit';
  68         $bits |= 0x80000000, next if $sememe eq 'time';
  69     }
  70     $bits;
  71 }
  72
  73 sub import {
  74     shift;
  75     $^H |= bits(@_ ? @_ : qw(status exit time hushed));
  76 }
  77
  78 sub unimport {
  79     shift;
  80     $^H &= ~ bits(@_ ? @_ : qw(status exit time hushed));
  81 }
  82
  83 1;