git.maemo.org Git - pkg-perl/blob - deb-src/libperl-critic-perl/libperl-critic-perl-1.088/inc/Devel/CheckOS.pm

   1 # $Id: CheckOS.pm,v 1.13 2007/10/04 20:15:05 drhyde Exp $
   2
   3 package Devel::CheckOS;
   4
   5 use strict;
   6 use Exporter;
   7
   8 use vars qw($VERSION @ISA @EXPORT_OK %EXPORT_TAGS);
   9
  10 $VERSION = '1.2';
  11
  12 # localising prevents the warningness leaking out of this module
  13 local $^W = 1;    # use warnings is a 5.6-ism
  14
  15 @ISA = qw(Exporter);
  16 @EXPORT_OK = qw(os_is os_isnt die_if_os_is die_if_os_isnt die_unsupported list_platforms);
  17 %EXPORT_TAGS = (
  18     all      => \@EXPORT_OK,
  19     booleans => [qw(os_is os_isnt die_unsupported)],
  20     fatal    => [qw(die_if_os_is die_if_os_isnt)]
  21 );
  22
  23 =head1 NAME
  24
  25 Devel::CheckOS - check what OS we're running on
  26
  27 =head1 DESCRIPTION
  28
  29 Devel::CheckOS provides a more friendly interface to $^O, and also lets
  30 you check for various OS "families" such as "Unix", which includes things
  31 like Linux, Solaris, AIX etc.
  32
  33 =head1 SYNOPSIS
  34
  35     use Devel::CheckOS;
  36     print "Hey, I know this, it's a Unix system\n" if(os_is('Unix'));
  37
  38 =head1 FUNCTIONS
  39
  40 Devel::CheckOS implements the following functions, which load subsidiary
  41 OS-specific modules on demand to do the real work.  They can be exported
  42 by listing their names after C<use Devel::CheckOS>.  You can also export
  43 groups of functions thus:
  44
  45     use Devel::CheckOS qw(:booleans); # export the boolean functions
  46                                       # and 'die_unsupported'
  47
  48     use Devel::CheckOS qw(:fatal);    # export those that die on no match
  49
  50     use Devel::CheckOS qw(:all);      # export everything
  51
  52 =head2 Boolean functions
  53
  54 =head3 os_is
  55
  56 Takes a list of OS names.  If the current platform matches any of them,
  57 it returns true, otherwise it returns false.  The names can be a mixture
  58 of OSes and OS families, eg ...
  59
  60     os_is(qw(Unix VMS)); # Unix is a family, VMS is an OS
  61
  62 =cut
  63
  64 sub os_is {
  65     my @targets = @_;
  66     foreach my $target (@targets) {
  67         die("Devel::CheckOS: $target isn't a legal OS name\n")
  68             unless($target =~ /^\w+$/);
  69         eval "use Devel::AssertOS::$target";
  70         if(!$@) {
  71             no strict 'refs';
  72             return 1 if(&{"Devel::AssertOS::${target}::os_is"}());
  73         }
  74     }
  75     return 0;
  76 }
  77
  78 =head3 os_isnt
  79
  80 If the current platform matches any of the parameters it returns false,
  81 otherwise it returns true.
  82
  83 =cut
  84
  85 sub os_isnt {
  86     my @targets = @_;
  87     foreach my $target (@targets) {
  88         return 0 if(os_is($target));
  89     }
  90     return 1;
  91 }
  92
  93 =head2 Fatal functions
  94
  95 =head3 die_if_os_isnt
  96
  97 As C<os_is()>, except that it dies instead of returning false.  The die()
  98 message matches what the CPAN-testers look for to determine if a module
  99 doesn't support a particular platform.
 100
 101 =cut
 102
 103 sub die_if_os_isnt {
 104     os_is(@_) ? 1 : die_unsupported();
 105 }
 106
 107 =head3 die_if_os_is
 108
 109 As C<os_isnt()>, except that it dies instead of returning false.
 110
 111 =cut
 112
 113 sub die_if_os_is {
 114     os_isnt(@_) ? 1 : die_unsupported();
 115 }
 116
 117 =head2 And some utility functions ...
 118
 119 =head3 die_unsupported
 120
 121 This function simply dies with the message "OS unsupported", which is what
 122 the CPAN testers look for to figure out whether a platform is supported or
 123 not.
 124
 125 =cut
 126
 127 sub die_unsupported { die("OS unsupported\n"); }
 128
 129 =head3 list_platforms
 130
 131 Return a list of all the platforms for which the corresponding
 132 Devel::AssertOS::* module is available.  This includes both OSes and OS
 133 families, and both those bundled with this module and any third-party
 134 add-ons you have installed.
 135
 136 Unfortunately, on some platforms this list may have file case
 137 broken.  eg, some platforms might return 'freebsd' instead of 'FreeBSD'.
 138 This is because they have case-insensitive filesystems so things
 139 should Just Work anyway.
 140
 141 =cut
 142
 143 sub list_platforms {
 144     eval " # only load these if needed
 145         use File::Find::Rule;
 146         use File::Spec;
 147     ";
 148
 149     die($@) if($@);
 150     return sort { $a cmp $b } map {
 151         s/^.*\///g;
 152         s/\.pm$//gi;
 153         $_;
 154     } File::Find::Rule->file()->name('*.pm')->in(
 155         grep { -d }
 156         map { File::Spec->catdir($_, qw(Devel AssertOS)) }
 157         @INC
 158     );
 159 }
 160
 161 =head1 PLATFORMS SUPPORTED
 162
 163 To see the list of platforms for which information is available, run this:
 164
 165     perl -MDevel::CheckOS -e 'print join(", ", Devel::CheckOS::list_platforms())'
 166
 167 Note that capitalisation is important.  These are the names of the
 168 underlying Devel::AssertOS::* modules
 169 which do the actual platform detection, so they have to
 170 be 'legal' filenames and module names, which unfortunately precludes
 171 funny characters, so platforms like OS/2 are mis-spelt deliberately.
 172 Sorry.
 173
 174 Also be aware that not all of them have been properly tested.  I don't
 175 have access to most of them and have had to work from information
 176 gleaned from L<perlport> and a few other places.
 177
 178 The following OS 'families' are supported 'out of the box':
 179
 180     Apple (Mac OS, both classic and OS X)
 181     DEC
 182     MicrosoftWindows (this matches either MSWin32 or Cygwin)
 183     Sun
 184     Unix
 185
 186 If you want to add your own OSes or families, see L<Devel::AssertOS::Extending>
 187 and please feel free to upload the results to the CPAN.
 188
 189 =head1 BUGS and FEEDBACK
 190
 191 I welcome feedback about my code, including constructive criticism.
 192 Bug reports should be made using L<http://rt.cpan.org/> or by email.
 193
 194 You will need to include in your bug report the exact value of $^O, what
 195 the OS is called (eg Windows Vista 64 bit Ultimate Home Edition), and,
 196 if relevant, what "OS family" it should be in and who wrote it.
 197
 198 If you are feeling particularly generous you can encourage me in my
 199 open source endeavours by buying me something from my wishlist:
 200   L<http://www.cantrell.org.uk/david/wishlist/>
 201
 202 =head1 SEE ALSO
 203
 204 $^O in L<perlvar>
 205
 206 L<perlport>
 207
 208 L<Devel::AssertOS>
 209
 210 L<Devel::AssertOS::Extending>
 211
 212 =head1 AUTHOR
 213
 214 David Cantrell E<lt>F<david@cantrell.org.uk>E<gt>
 215
 216 Thanks to David Golden for the name and ideas about the interface, and
 217 to the cpan-testers-discuss mailing list for prompting me to write it
 218 in the first place.
 219
 220 Thanks to Ken Williams, from whose L<Module::Build> I lifted some of the
 221 information about what should be in the Unix family.
 222
 223 Thanks to Billy Abbott for finding some bugs for me on VMS.
 224
 225 =head1 COPYRIGHT and LICENCE
 226
 227 Copyright 2007 David Cantrell
 228
 229 This module is free-as-in-speech software, and may be used, distributed,
 230 and modified under the same conditions as perl itself.
 231
 232 =head1 CONSPIRACY
 233
 234 This module is also free-as-in-mason software.
 235
 236 =cut
 237
 238 $^O;