File Coverage

blib/lib/AppConfig/Sys.pm
Criterion Covered Total %
statement n/a
branch n/a
condition n/a
subroutine n/a
pod n/a
total n/a


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