local-lib5/lib/perl5/AppConfig/Sys.pm

   1 #============================================================================
   2 #
   3 # AppConfig::Sys.pm
   4 #
   5 # Perl5 module providing platform-specific information and operations as
   6 # required by other AppConfig::* modules.
   7 #
   8 # Written by Andy Wardley <abw@wardley.org>
   9 #
  10 # Copyright (C) 1997-2003 Andy Wardley.  All Rights Reserved.
  11 # Copyright (C) 1997,1998 Canon Research Centre Europe Ltd.
  12 #
  13 # $Id: Sys.pm,v 1.61 2004/02/04 10:11:23 abw Exp $
  14 #
  15 #============================================================================
  16
  17 package AppConfig::Sys;
  18 use strict;
  19 use warnings;
  20 use POSIX qw( getpwnam getpwuid );
  21
  22 our $VERSION = '1.65';
  23 our ($AUTOLOAD, $OS, %CAN, %METHOD);
  24
  25
  26 BEGIN {
  27     # define the methods that may be available
  28     if($^O =~ m/win32/i) {
  29         $METHOD{ getpwuid } = sub {
  30             return wantarray()
  31                 ? ( (undef) x 7, getlogin() )
  32                 : getlogin();
  33         };
  34         $METHOD{ getpwnam } = sub {
  35             die("Can't getpwnam on win32");
  36         };
  37     }
  38     else
  39     {
  40         $METHOD{ getpwuid } = sub {
  41             getpwuid( defined $_[0] ? shift : $< );
  42         };
  43         $METHOD{ getpwnam } = sub {
  44             getpwnam( defined $_[0] ? shift : '' );
  45         };
  46     }
  47
  48     # try out each METHOD to see if it's supported on this platform;
  49     # it's important we do this before defining AUTOLOAD which would
  50     # otherwise catch the unresolved call
  51     foreach my $method  (keys %METHOD) {
  52         eval { &{ $METHOD{ $method } }() };
  53         $CAN{ $method } = ! $@;
  54     }
  55 }
  56
  57
  58
  59 #------------------------------------------------------------------------
  60 # new($os)
  61 #
  62 # Module constructor.  An optional operating system string may be passed
  63 # to explicitly define the platform type.
  64 #
  65 # Returns a reference to a newly created AppConfig::Sys object.
  66 #------------------------------------------------------------------------
  67
  68 sub new {
  69     my $class = shift;
  70
  71     my $self = {
  72         METHOD => \%METHOD,
  73         CAN    => \%CAN,
  74     };
  75
  76     bless $self, $class;
  77
  78     $self->_configure(@_);
  79
  80     return $self;
  81 }
  82
  83
  84 #------------------------------------------------------------------------
  85 # AUTOLOAD
  86 #
  87 # Autoload function called whenever an unresolved object method is
  88 # called.  If the method name relates to a METHODS entry, then it is
  89 # called iff the corresponding CAN_$method is set true.  If the
  90 # method name relates to a CAN_$method value then that is returned.
  91 #------------------------------------------------------------------------
  92
  93 sub AUTOLOAD {
  94     my $self = shift;
  95     my $method;
  96
  97
  98     # splat the leading package name
  99     ($method = $AUTOLOAD) =~ s/.*:://;
 100
 101     # ignore destructor
 102     $method eq 'DESTROY' && return;
 103
 104     # can_method()
 105     if ($method =~ s/^can_//i && exists $self->{ CAN }->{ $method }) {
 106         return $self->{ CAN }->{ $method };
 107     }
 108     # method()
 109     elsif (exists $self->{ METHOD }->{ $method }) {
 110         if ($self->{ CAN }->{ $method }) {
 111             return &{ $self->{ METHOD }->{ $method } }(@_);
 112         }
 113         else {
 114             return undef;
 115         }
 116     }
 117     # variable
 118     elsif (exists $self->{ uc $method }) {
 119         return $self->{ uc $method };
 120     }
 121     else {
 122         warn("AppConfig::Sys->", $method, "(): no such method or variable\n");
 123     }
 124
 125     return undef;
 126 }
 127
 128
 129 #------------------------------------------------------------------------
 130 # _configure($os)
 131 #
 132 # Uses the first parameter, $os, the package variable $AppConfig::Sys::OS,
 133 # the value of $^O, or as a last resort, the value of
 134 # $Config::Config('osname') to determine the current operating
 135 # system/platform.  Sets internal variables accordingly.
 136 #------------------------------------------------------------------------
 137
 138 sub _configure {
 139     my $self = shift;
 140
 141     # operating system may be defined as a parameter or in $OS
 142     my $os = shift || $OS;
 143
 144
 145     # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 146     # The following was lifted (and adapated slightly) from Lincoln Stein's
 147     # CGI.pm module, version 2.36...
 148     #
 149     # FIGURE OUT THE OS WE'RE RUNNING UNDER
 150     # Some systems support the $^O variable.  If not
 151     # available then require() the Config library
 152     unless ($os) {
 153         unless ($os = $^O) {
 154             require Config;
 155             $os = $Config::Config{'osname'};
 156         }
 157     }
 158     if ($os =~ /win32/i) {
 159         $os = 'WINDOWS';
 160     } elsif ($os =~ /vms/i) {
 161         $os = 'VMS';
 162     } elsif ($os =~ /mac/i) {
 163         $os = 'MACINTOSH';
 164     } elsif ($os =~ /os2/i) {
 165         $os = 'OS2';
 166     } else {
 167         $os = 'UNIX';
 168     }
 169
 170
 171     # The path separator is a slash, backslash or semicolon, depending
 172     # on the platform.
 173     my $ps = {
 174         UNIX      => '/',
 175         OS2       => '\\',
 176         WINDOWS   => '\\',
 177         MACINTOSH => ':',
 178         VMS       => '\\'
 179     }->{ $os };
 180     #
 181     # Thanks Lincoln!
 182     # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 183
 184
 185     $self->{ OS      } = $os;
 186     $self->{ PATHSEP } = $ps;
 187 }
 188
 189
 190 #------------------------------------------------------------------------
 191 # _dump()
 192 #
 193 # Dump internals for debugging.
 194 #------------------------------------------------------------------------
 195
 196 sub _dump {
 197     my $self = shift;
 198
 199     print "=" x 71, "\n";
 200     print "Status of AppConfig::Sys (Version $VERSION) object: $self\n";
 201     print "    Operating System : ", $self->{ OS      }, "\n";
 202     print "      Path Separator : ", $self->{ PATHSEP }, "\n";
 203     print "   Available methods :\n";
 204     foreach my $can (keys %{ $self->{ CAN } }) {
 205         printf "%20s : ", $can;
 206         print  $self->{ CAN }->{ $can } ? "yes" : "no", "\n";
 207     }
 208     print "=" x 71, "\n";
 209 }
 210
 211
 212
 213 1;
 214
 215 __END__
 216
 217 =pod
 218
 219 =head1 NAME
 220
 221 AppConfig::Sys - Perl5 module defining platform-specific information and methods for other AppConfig::* modules.
 222
 223 =head1 SYNOPSIS
 224
 225     use AppConfig::Sys;
 226     my $sys = AppConfig::Sys->new();
 227
 228     @fields = $sys->getpwuid($userid);
 229     @fields = $sys->getpwnam($username);
 230
 231 =head1 OVERVIEW
 232
 233 AppConfig::Sys is a Perl5 module provides platform-specific information and
 234 operations as required by other AppConfig::* modules.
 235
 236 AppConfig::Sys is distributed as part of the AppConfig bundle.
 237
 238 =head1 DESCRIPTION
 239
 240 =head2 USING THE AppConfig::Sys MODULE
 241
 242 To import and use the AppConfig::Sys module the following line should
 243 appear in your Perl script:
 244
 245      use AppConfig::Sys;
 246
 247 AppConfig::Sys is implemented using object-oriented methods.  A new
 248 AppConfig::Sys object is created and initialised using the
 249 AppConfig::Sys->new() method.  This returns a reference to a new
 250 AppConfig::Sys object.
 251
 252     my $sys = AppConfig::Sys->new();
 253
 254 This will attempt to detect your operating system and create a reference to
 255 a new AppConfig::Sys object that is applicable to your platform.  You may
 256 explicitly specify an operating system name to override this automatic
 257 detection:
 258
 259     $unix_sys = AppConfig::Sys->new("Unix");
 260
 261 Alternatively, the package variable $AppConfig::Sys::OS can be set to an
 262 operating system name.  The valid operating system names are: Win32, VMS,
 263 Mac, OS2 and Unix.  They are not case-specific.
 264
 265 =head2 AppConfig::Sys METHODS
 266
 267 AppConfig::Sys defines the following methods:
 268
 269 =over 4
 270
 271 =item getpwnam()
 272
 273 Calls the system function getpwnam() if available and returns the result.
 274 Returns undef if not available.  The can_getpwnam() method can be called to
 275 determine if this function is available.
 276
 277 =item getpwuid()
 278
 279 Calls the system function getpwuid() if available and returns the result.
 280 Returns undef if not available.  The can_getpwuid() method can be called to
 281 determine if this function is available.
 282
 283 =item
 284
 285 =back
 286
 287 =head1 AUTHOR
 288
 289 Andy Wardley, E<lt>abw@wardley.orgE<gt>
 290
 291 =head1 COPYRIGHT
 292
 293 Copyright (C) 1997-2007 Andy Wardley.  All Rights Reserved.
 294
 295 Copyright (C) 1997,1998 Canon Research Centre Europe Ltd.
 296
 297 This module is free software; you can redistribute it and/or modify it under
 298 the term of the Perl Artistic License.
 299
 300 =head1 SEE ALSO
 301
 302 AppConfig, AppConfig::File
 303
 304 =cut