home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / tsw / TSW_3.4.0.exe / Apache2 / perl / Sys.pm < prev    next >
Encoding:
Perl POD Document  |  2004-02-04  |  7.9 KB  |  305 lines
  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.  
  19. require 5.004;
  20. use strict;
  21. use vars qw( $VERSION $AUTOLOAD $OS %CAN %METHOD);
  22. use POSIX qw( getpwnam getpwuid );
  23.  
  24. $VERSION = sprintf("%d.%02d", q$Revision: 1.61 $ =~ /(\d+)\.(\d+)/);
  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. =head1 NAME
  218.  
  219. AppConfig::Sys - Perl5 module defining platform-specific information and methods for other AppConfig::* modules.
  220.  
  221. =head1 SYNOPSIS
  222.  
  223.     use AppConfig::Sys;
  224.     my $sys = AppConfig::Sys->new();
  225.  
  226.     @fields = $sys->getpwuid($userid);
  227.     @fields = $sys->getpwnam($username);
  228.  
  229. =head1 OVERVIEW
  230.  
  231. AppConfig::Sys is a Perl5 module provides platform-specific information and
  232. operations as required by other AppConfig::* modules.
  233.  
  234. AppConfig::Sys is distributed as part of the AppConfig bundle.
  235.  
  236. =head1 DESCRIPTION
  237.  
  238. =head2 USING THE AppConfig::Sys MODULE
  239.  
  240. To import and use the AppConfig::Sys module the following line should
  241. appear in your Perl script:
  242.  
  243.      use AppConfig::Sys;
  244.  
  245. AppConfig::Sys is implemented using object-oriented methods.  A new
  246. AppConfig::Sys object is created and initialised using the
  247. AppConfig::Sys->new() method.  This returns a reference to a new
  248. AppConfig::Sys object.  
  249.  
  250.     my $sys = AppConfig::Sys->new();
  251.  
  252. This will attempt to detect your operating system and create a reference to
  253. a new AppConfig::Sys object that is applicable to your platform.  You may 
  254. explicitly specify an operating system name to override this automatic 
  255. detection:
  256.  
  257.     $unix_sys = AppConfig::Sys->new("Unix");
  258.  
  259. Alternatively, the package variable $AppConfig::Sys::OS can be set to an
  260. operating system name.  The valid operating system names are: Win32, VMS,
  261. Mac, OS2 and Unix.  They are not case-specific.
  262.  
  263. =head2 AppConfig::Sys METHODS
  264.  
  265. AppConfig::Sys defines the following methods:
  266.  
  267. =over 4
  268.  
  269. =item getpwnam()
  270.  
  271. Calls the system function getpwnam() if available and returns the result.
  272. Returns undef if not available.  The can_getpwnam() method can be called to
  273. determine if this function is available.
  274.  
  275. =item getpwuid()
  276.  
  277. Calls the system function getpwuid() if available and returns the result.
  278. Returns undef if not available.  The can_getpwuid() method can be called to
  279. determine if this function is available.
  280.  
  281. =item 
  282.  
  283. =head1 AUTHOR
  284.  
  285. Andy Wardley, E<lt>abw@wardley.orgE<gt>
  286.  
  287. =head1 REVISION
  288.  
  289. $Revision: 1.61 $
  290.  
  291. =head1 COPYRIGHT
  292.  
  293. Copyright (C) 1997-2004 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
  305.