File Coverage

blib/lib/Devel/CheckOS.pm
Criterion Covered Total %
statement 410 606 67.6
branch 28 30 93.3
condition 6 11 54.5
subroutine 202 202 100.0
pod 8 8 100.0
total 654 857 76.3


line stmt bran cond sub pod time code
1             package Devel::CheckOS;
2              
3 49     49   650586 use strict;
  29         129  
  29         658  
4 49     49   7712 use warnings;
  31         55  
  31         654  
5              
6 48     48   7126 use Exporter;
  31         60  
  31         1023  
7             # if we're loading this from Makefile.PL, FFR might not yet be installed
8 37     37   13471 eval 'use File::Find::Rule';
  26         165342  
  26         184  
9 49     49   5634 use File::Spec;
  33         88  
  33         897  
10              
11 38     38   4431 use vars qw(@ISA @EXPORT_OK %EXPORT_TAGS %OS_ALIASES);
  29         213  
  29         11908  
12              
13             our $VERSION = '1.94';
14              
15             @ISA = qw(Exporter);
16             @EXPORT_OK = qw(
17             os_is os_isnt die_if_os_is die_if_os_isnt die_unsupported
18             list_platforms list_family_members register_alias
19             );
20             %EXPORT_TAGS = (
21             all => \@EXPORT_OK,
22             booleans => [qw(os_is os_isnt die_unsupported)],
23             fatal => [qw(die_if_os_is die_if_os_isnt)]
24             );
25              
26             # get a list of the .pm files under a list of dirs, or the empty list
27             # in taint mode
28             sub _find_pm_files_in_dirs {
29 653     653   4983 my @files;
30 647         1060 eval { @files = File::Find::Rule->file()->name('*.pm')->in(@_) };
  647         18147  
31 652         7347777 return @files;
32             }
33              
34             if(exists($INC{'File/Find/Rule.pm'})) {
35             foreach my $alias_module (
36             _find_pm_files_in_dirs(
37             grep { -d }
38             map { File::Spec->catdir($_, qw(Devel AssertOS Alias)) }
39             @INC
40             )
41             ) {
42             my(undef, undef, $file_part) = File::Spec->splitpath($alias_module);
43             $file_part =~ s/\.pm$//;
44 36     36   11138 eval "use Devel::AssertOS::Alias::$file_part";
  29     36   82  
  29     27   484  
  36         1874  
  26         49  
  26         266  
  27         2603  
  18         28  
  18         183  
45             warn("Bad alias module 'Devel::AssertOS::Alias::$file_part' ignored\n") if($@);
46             }
47             }
48              
49             =head1 NAME
50              
51             Devel::CheckOS - check what OS we're running on
52              
53             =head1 DESCRIPTION
54              
55             A learned sage once wrote on IRC:
56              
57             $^O is stupid and ugly, it wears its pants as a hat
58              
59             Devel::CheckOS provides a more friendly interface to $^O, and also lets
60             you check for various OS "families" such as "Unix", which includes things
61             like Linux, Solaris, AIX etc.
62              
63             It spares perl the embarrassment of wearing its pants on its head by
64             covering them with a splendid Fedora.
65              
66             =head1 SYNOPSIS
67              
68             use Devel::CheckOS qw(os_is);
69             print "Hey, I know this, it's a Unix system\n" if(os_is('Unix'));
70              
71             print "You've got Linux 2.6\n" if(os_is('Linux::v2_6'));
72              
73             =head1 USING IT IN Makefile.PL or Build.PL
74              
75             If you want to use this from Makefile.PL or Build.PL, do
76             not simply copy the module into your distribution as this may cause
77             problems when PAUSE and search.cpan.org index the distro. Instead, use
78             the use-devel-assertos script.
79              
80             =head1 FUNCTIONS
81              
82             Devel::CheckOS implements the following functions, which load subsidiary
83             OS-specific modules on demand to do the real work. They can all be exported
84             by listing their names after C. You can also export
85             groups of functions thus:
86              
87             use Devel::CheckOS qw(:booleans); # export the boolean functions
88             # and 'die_unsupported'
89            
90             use Devel::CheckOS qw(:fatal); # export those that die on no match
91              
92             use Devel::CheckOS qw(:all); # export everything exportable
93              
94             =head2 Boolean functions
95              
96             =head3 os_is
97              
98             Takes a list of OS names. If the current platform matches any of them,
99             it returns true, otherwise it returns false. The names can be a mixture
100             of OSes and OS families, eg ...
101              
102             os_is(qw(Unix VMS)); # Unix is a family, VMS is an OS
103              
104             Matching is case-insensitive provided that Taint-mode is not enabled, so the
105             above could also be written:
106              
107             os_is(qw(unix vms));
108              
109             =cut
110              
111             sub os_is {
112 296     307 1 21525 my @targets = @_;
113 296         556 my $rval = 0;
114              
115 307         2899 TARGET: foreach my $target (@targets) {
116             # resolve aliases
117 608         2052 ALIAS: foreach my $alias (keys %OS_ALIASES) {
118 608 100       3563 if($target =~ /^$alias$/i) {
119 15         3002 $target = $OS_ALIASES{$alias};
120 3         8 last ALIAS;
121             }
122             }
123              
124             # resolve case-insensitive names (no-op in taint-mode as list_platforms
125             # won't work)
126 605         1600 my @available_platforms = list_platforms();
127 615         4680 CANDIDATE: foreach my $candidate (@available_platforms) {
128 20972 100       121093 if($target =~ /^\Q$candidate\E$/i) {
129 605         1153 $target = $candidate;
130 614         4220 last CANDIDATE;
131             }
132             }
133              
134 606 100       4171 die("Devel::CheckOS: $target isn't a legal OS name\n")
135             unless($target =~ /^\w+(::\w+)*$/);
136 34     34   12750 eval "use Devel::AssertOS::$target";
  12     30   1220  
  12     26   227  
  30     12   8216  
  9     12   133  
  9     11   148  
  26     11   7085  
  6     10   129  
  6     10   99  
  605     10   58695  
  8     8   1872  
  13     8   1210  
  5     9   55  
  7     10   99  
  15     11   949  
  9     11   172  
  8     11   876  
  13     11   1156  
  5     11   39  
  6     11   85  
  14     11   945  
  8     11   71  
  8     10   755  
  11     3   995  
  4     1   9  
  7     4   97  
  14     1   820  
  7     1   88  
  7     4   403  
  11     1   1561  
  4     1   8  
  4     4   106  
  10     1   865  
  4     1   8  
  4     4   82  
  3     1   704  
  1     1   1  
  1     4   25  
  1     1   328  
  0     1   0  
  0     4   0  
  4     1   72  
  0     1   0  
  0     4   0  
  1     1   5  
  1     1   2  
  1     1   23  
  1     1   343  
  0     1   0  
  0     1   0  
  4     1   62  
  1     1   5  
  1     1   14  
  1     1   8  
  1     1   3  
  1     1   23  
  1     1   335  
  0     1   0  
  0     1   0  
  4         66  
  1         4  
  1         14  
  1         6  
  1         2  
  1         27  
  1         322  
  0         0  
  0         0  
  4         69  
  1         2  
  1         14  
  1         6  
  1         3  
  1         22  
  1         325  
  0         0  
  0         0  
  4         70  
  1         2  
  1         15  
  1         6  
  1         4  
  1         23  
  1         338  
  0         0  
  0         0  
  4         69  
  1         2  
  1         15  
  1         5  
  1         2  
  1         23  
  1         343  
  0         0  
  0         0  
  4         57  
  1         5  
  1         17  
  1         5  
  1         2  
  1         24  
  1         15  
  0         0  
  0         0  
  1         5  
  1         4  
  1         20  
  1         396  
  0         0  
  0         0  
  1         9  
  1         2  
  1         20  
  1         323  
  0         0  
  0         0  
  4         64  
  1         3  
  1         16  
  4         89  
  1         2  
  1         16  
  4         64  
  1         2  
  1         21  
  1         7  
  1         3  
  1         32  
  1         432  
  0         0  
  0         0  
  1         7  
  1         1  
  1         21  
  1         312  
  0         0  
  0         0  
  1         6  
  1         1  
  1         20  
  1         316  
  0         0  
  0         0  
  1         8  
  1         4  
  1         22  
  1         323  
  0         0  
  1         19  
  1         14  
  0         0  
  0         0  
  1         5  
  1         1  
  0         0  
  1         6  
  1         1  
  1         20  
  1         13  
  0         0  
  0         0  
  1         15  
  0         0  
  1         25  
  1         14  
  0         0  
  0         0  
  1         4  
  1         2  
  1         17  
  1         14  
  0         0  
  0         0  
  1         5  
  1         2  
  1         18  
  1         13  
  0         0  
137 611 100       8482 if(!$@) {
138 38     38   2800 no strict 'refs';
  31         72  
  31         17463  
139 135 100       249 $rval = 1 if(&{"Devel::AssertOS::${target}::os_is"}());
  135         974  
140             }
141             }
142 301         50464 return $rval;
143             }
144              
145             =head3 os_isnt
146              
147             If the current platform matches (case-insensitively) any of the parameters it
148             returns false, otherwise it returns true.
149              
150             =cut
151              
152             sub os_isnt {
153 30     41 1 118 my @targets = @_;
154 30         91 my $rval = 1;
155 36         2938 foreach my $target (@targets) {
156 59 100       128 $rval = 0 if(os_is($target));
157             }
158 28         492 return $rval;
159             }
160              
161             =head2 Fatal functions
162              
163             =head3 die_if_os_isnt
164              
165             As C, except that it dies instead of returning false. The die()
166             message matches what the CPAN-testers look for to determine if a module
167             doesn't support a particular platform.
168              
169             =cut
170              
171             sub die_if_os_isnt {
172 16 100   21 1 2704 os_is(@_) ? 1 : die_unsupported();
173             }
174              
175             =head3 die_if_os_is
176              
177             As C, except that it dies instead of returning false.
178              
179             =cut
180              
181             sub die_if_os_is {
182 12 100   21 1 1673 os_isnt(@_) ? 1 : die_unsupported();
183             }
184              
185             =head2 And some utility functions ...
186              
187             =head3 die_unsupported
188              
189             This function simply dies with the message "OS unsupported", which is what
190             the CPAN testers look for to figure out whether a platform is supported or
191             not.
192              
193             =cut
194              
195 299     308 1 9529 sub die_unsupported { die("OS unsupported\n"); }
196              
197             =head3 list_platforms
198              
199             When called in list context,
200             return a list of all the platforms for which the corresponding
201             Devel::AssertOS::* module is available. This includes both OSes and OS
202             families, and both those bundled with this module and any third-party
203             add-ons you have installed.
204              
205             In scalar context, returns a hashref keyed by platform with the filename
206             of the most recent version of the supporting module that is available to you.
207             This behaviour is deprecated.
208              
209             Unfortunately, on some platforms this list may have file case
210             broken. eg, some platforms might return 'freebsd' instead of 'FreeBSD'.
211             This is because they have case-insensitive filesystems so things
212             should Just Work anyway.
213              
214             This function does not work in taint-mode.
215              
216             =cut
217              
218             my $case_flag = File::Spec->case_tolerant ? '(?i)' : '';
219             my $re_Devel = qr/$case_flag ^Devel$/x;
220             my $re_AssertOS = qr/$case_flag ^AssertOS$/x;
221             my $re_Alias = qr/$case_flag ^Alias\b/x;
222              
223             sub list_platforms {
224             # sort by mtime, so oldest last. This was necessary so that if a module
225             # appears twice in @INC we pick the newer one but that functionality is
226             # no longer needed. We do need to de-dupe the list though
227             my @modules = sort {
228 550578         8981291 (stat($a->{file}))[9] <=> (stat($b->{file}))[9]
229             } grep {
230 140074         273774 $_->{module} !~ $re_Alias
231             } map {
232 140079         758493 my (undef, $dir_part, $file_part) = File::Spec->splitpath($_);
233 140073         360195 $file_part =~ s/\.pm$//;
234 140073         435812 my (@dirs) = grep {+length} File::Spec->splitdir($dir_part);
  1445257         1645911  
235 140072         283778 foreach my $i (reverse 1..$#dirs) {
236             next unless(
237 187966 100 66     873686 $dirs[$i] =~ $re_AssertOS &&
238             $dirs[$i - 1] =~ $re_Devel
239             );;
240 140078         244150 splice @dirs, 0, $i + 1;
241 140073         157756 last;
242             }
243             {
244 140073         553591 module => join('::', @dirs, $file_part),
245             file => File::Spec->canonpath($_)
246             }
247             } _find_pm_files_in_dirs(
248 6532         58915 grep { -d }
249 623     623 1 2116900 map { File::Spec->catdir($_, qw(Devel AssertOS)) }
  6526         27373  
250             @INC
251             );
252              
253             my %modules = map {
254 616         20563 $_->{module} => $_->{file}
255 138438         216681 } @modules;
256              
257 617 100       9503 if(wantarray()) {
258 615         54539 return sort keys %modules;
259             } else {
260 10 100       497 warn("Calling list_platforms in scalar context and getting back a reference is deprecated and will go away some time after April 2024. To disable this warning set \$Devel::CheckOS::NoDeprecationWarnings::Context to a true value.\n") unless($Devel::CheckOS::NoDeprecationWarnings::Context);
261 5         105 return \%modules;
262             }
263             }
264              
265             =head3 list_family_members
266              
267             Takes the name of an OS 'family' and returns a list of all its members.
268             In list context, you get a list, in scalar context you get an arrayref.
269              
270             If called on something that isn't a family, you get an empty list (or
271             a ref to an empty array).
272              
273             =cut
274              
275             sub list_family_members {
276 99   100 104 1 4831796 my $family = shift() ||
277             die(__PACKAGE__."::list_family_members needs a parameter\n");
278              
279             # this will die if it's the wrong OS, but the module is loaded ...
280 103     1   5219 eval qq{use Devel::AssertOS::$family};
  0     4   0  
  1     1   5  
  1     1   1  
  0     1   0  
  1     1   6  
  1     1   1  
  0     1   0  
  1     1   5  
  1     1   2  
  0     1   0  
  1     1   5  
  1     1   4  
  0     4   0  
  1     4   5  
  1     4   2  
  0     4   0  
  1     4   5  
  1     1   2  
  0     1   0  
  1     1   4  
  1     1   3  
  1     1   28  
  4     1   386  
  2     1   13  
  0     1   0  
  4     1   68  
  1     1   2  
  1     1   16  
  4     1   75  
  1     1   3  
  1     1   16  
  4     1   925  
  1     1   2  
  1     1   15  
  4     1   937  
  1     1   3  
  0     1   0  
  1     1   18  
  0     1   0  
  0     1   0  
  1     1   17  
  0     1   0  
  0     1   0  
  1     1   7  
  1     1   3  
  0     1   0  
  1     1   18  
  0     1   0  
  0     1   0  
  1     1   20  
  0     1   0  
  0     1   0  
  1     1   19  
  0     1   0  
  0     1   0  
  1     1   18  
  0     1   0  
  0     1   0  
  1     1   356  
  0     1   0  
  0     1   0  
  1         388  
  0         0  
  0         0  
  1         396  
  0         0  
  0         0  
  1         432  
  0         0  
  0         0  
  1         18  
  0         0  
  0         0  
  1         32  
  0         0  
  0         0  
  1         17  
  0         0  
  0         0  
  1         23  
  0         0  
  0         0  
  1         20  
  0         0  
  0         0  
  1         26  
  0         0  
  0         0  
  1         18  
  0         0  
  0         0  
  1         8  
  1         9  
  0         0  
  1         23  
  0         0  
  0         0  
  1         18  
  0         0  
  0         0  
  1         23  
  0         0  
  0         0  
  1         19  
  0         0  
  0         0  
  1         19  
  0         0  
  0         0  
  1         40  
  0         0  
  0         0  
  1         17  
  0         0  
  0         0  
  1         17  
  0         0  
  0         0  
  1         17  
  0         0  
  0         0  
  1         7  
  1         2  
  0         0  
  1         5  
  1         1  
  0         0  
  1         6  
  1         3  
  0         0  
  1         5  
  1         6  
  0         0  
  1         5  
  1         2  
  1         20  
  1         329  
  0         0  
  0         0  
  1         16  
  0         0  
  0         0  
  1         9  
  1         6  
  1         17  
  1         320  
  0         0  
  0         0  
  1         7  
  1         2  
  1         21  
  1         12  
  0         0  
  0         0  
  1         5  
  1         2  
  0         0  
  1         4  
  1         2  
  1         12  
  1         4  
  1         2  
  1         16  
  1         11  
  0         0  
  1         17  
  1         12  
  0         0  
  1         16  
281             # ... so we can now query it
282 97     4   4338 my @members = eval qq{
  1     4   19  
  1     1   310  
  0     1   0  
  1     1   19  
  1     1   313  
  0     1   0  
  1     1   18  
  1     1   342  
  0     1   0  
  1     1   19  
  1     1   12  
  0     1   0  
  1     4   17  
  1     4   13  
  0     4   0  
  1     4   18  
  1     1   14  
  0     1   0  
  1     1   17  
  1     1   423  
  1     1   8  
  2     1   42  
  4     1   71  
  0     1   0  
  1     1   18  
  4     1   63  
  1     1   2  
  1     1   16  
  4     1   1008  
  1     1   2  
  1     1   18  
  4     1   890  
  1     1   2  
  1     1   17  
  1     1   17  
  0     1   0  
  0     1   0  
  1     1   17  
  0     1   0  
  0     1   0  
  1     1   18  
  0     1   0  
  1     1   17  
  1     1   21  
  0     1   0  
  0     1   0  
  1     1   18  
  0     1   0  
  0     1   0  
  1     1   20  
  0     1   0  
  0     1   0  
  1     1   526  
  0     1   0  
  0     1   0  
  1     1   444  
  0     1   0  
  0     1   0  
  1     1   408  
  0     1   0  
  0     1   0  
  1         365  
  0         0  
  0         0  
  1         442  
  0         0  
  0         0  
  1         450  
  0         0  
  0         0  
  1         24  
  0         0  
  0         0  
  1         19  
  0         0  
  0         0  
  1         20  
  0         0  
  0         0  
  1         21  
  0         0  
  0         0  
  1         22  
  0         0  
  0         0  
  1         31  
  0         0  
  0         0  
  1         21  
  0         0  
  1         21  
  1         31  
  0         0  
  0         0  
  1         21  
  0         0  
  0         0  
  1         22  
  0         0  
  0         0  
  1         20  
  0         0  
  0         0  
  1         24  
  0         0  
  0         0  
  1         22  
  0         0  
  0         0  
  1         21  
  0         0  
  0         0  
  1         17  
  0         0  
  0         0  
  1         18  
  0         0  
  0         0  
  1         527  
  0         0  
  1         31  
  1         16  
  0         0  
  1         23  
  1         14  
  0         0  
  1         18  
  1         13  
  0         0  
  1         18  
  1         14  
  0         0  
  0         0  
  1         6  
  1         2  
  1         20  
  1         315  
  0         0  
  1         24  
  1         15  
  0         0  
  0         0  
  1         4  
  1         2  
  0         0  
  1         16  
  0         0  
  0         0  
  1         5  
  1         1  
  1         18  
  1         12  
  0         0  
  1         18  
  1         11  
  0         0  
  1         16  
  1         5  
  1         1  
  0         0  
  1         4  
  1         2  
  0         0  
  1         5  
  1         1  
  0         0  
  1         4  
  1         2  
283             no strict 'refs';
284             &{"Devel::AssertOS::${family}::matches"}()
285             };
286 97 100       364 if(wantarray()) {
287 101         834 return @members;
288             } else {
289 6 100       39 warn("Calling list_family_members in scalar context and getting back a reference is deprecated and will go away some time after April 2024. To disable this warning set \$Devel::CheckOS::NoDeprecationWarnings::Context to a true value.\n") unless($Devel::CheckOS::NoDeprecationWarnings::Context);
290 6         149 return \@members;
291             }
292             }
293              
294             =head3 register_alias
295              
296             It takes two arguments, the first being an alias name, the second being the
297             name of an OS. After the alias has been registered, any queries about the
298             alias will return the appropriate result for the named OS.
299              
300             It returns true unless you invoke it incorrectly or you attempt to change
301             an existing alias.
302              
303             Aliases don't work under taint-mode.
304              
305             See L.
306              
307             =cut
308              
309             sub register_alias {
310 34     32 1 1716 my($alias, $os) = @_;
311 27 50 33     1510 ($alias && $os) || return 0;
312 27 50 33     3892 if(!exists($OS_ALIASES{$alias}) || $OS_ALIASES{$alias} eq $os) {
313 35         2192 return $OS_ALIASES{$alias} = $os;
314             } else {
315 4         11 return 0
316             }
317             }
318              
319             =head1 PLATFORMS SUPPORTED
320              
321             To see the list of platforms for which information is available, run this:
322              
323             perl -MDevel::CheckOS -e 'print join(", ", Devel::CheckOS::list_platforms())'
324              
325             These are the names of the underlying Devel::AssertOS::* modules
326             which do the actual platform detection, so they have to
327             be 'legal' filenames and module names, which unfortunately precludes
328             funny characters, so platforms like OS/2 are mis-spelt deliberately.
329             Sorry.
330              
331             Also be aware that not all of them have been properly tested. I don't
332             have access to most of them and have had to work from information
333             gleaned from L and a few other places. For a complete list of
334             OS families, see L.
335              
336             If you want to add your own OSes or families, see L
337             and please feel free to upload the results to the CPAN.
338              
339             =head1 BUGS and FEEDBACK
340              
341             I welcome feedback about my code, including constructive criticism.
342             Bug reports should be made using L.
343              
344             You will need to include in your bug report the exact value of $^O, what
345             the OS is called (eg Windows Vista 64 bit Ultimate Home Edition), and,
346             if relevant, what "OS family" it should be in and who wrote it.
347              
348             If you are feeling particularly generous you can encourage me in my
349             open source endeavours by buying me something from my wishlist:
350             L
351              
352             =head1 COMPATIBILITY
353              
354             Version 1.90 made all matches case-insensitive. This is a change in behaviour, but
355             if it breaks your code then your code was already broken, you just didn't know it.
356              
357             =head1 DEPRECATIONS
358              
359             At some point after April 2024 the C and C
360             functions will stop being sensitive to whether they are called in list context or
361             not, and will always return a list. From now until then calling them in non-list
362             context will emit a warning. You can turn that off by setting
363             C<$Devel::CheckOS::NoDeprecationWarnings::Context> to a true value.
364              
365             =head1 SEE ALSO
366              
367             $^O in L
368              
369             L
370              
371             L
372              
373             L
374              
375             L
376              
377             The use-devel-assertos script
378              
379             L
380              
381             =head1 AUTHOR
382              
383             David Cantrell EFE
384              
385             Thanks to David Golden for the name and ideas about the interface, and
386             to the cpan-testers-discuss mailing list for prompting me to write it
387             in the first place.
388              
389             Thanks to Ken Williams, from whose L I lifted some of the
390             information about what should be in the Unix family.
391              
392             Thanks to Billy Abbott for finding some bugs for me on VMS.
393              
394             Thanks to Matt Kraai for information about QNX.
395              
396             Thanks to Kenichi Ishigaki and Gabor Szabo for reporting a bug on Windows,
397             and to the former for providing a patch.
398              
399             Thanks to Paul Green for some information about VOS.
400              
401             Thanks to Yanick Champoux for a patch to let Devel::AssertOS support
402             negative assertions.
403              
404             Thanks to Brian Fraser for adding Android support.
405              
406             Thanks to Dale Evans for Debian detection, a bunch of Mac OS X specific version
407             detection modules, and perl 5.6 support.
408              
409             Thanks to Graham Knop for fixing a build bug on perl 5.8.
410              
411             =head1 SOURCE CODE REPOSITORY
412              
413             L
414              
415             =head1 COPYRIGHT and LICENCE
416              
417             Copyright 2007-2022 David Cantrell
418              
419             This software is free-as-in-speech software, and may be used, distributed, and modified under the terms of either the GNU General Public Licence version 2 or the Artistic Licence. It's up to you which one you use. The full text of the licences can be found in the files GPL2.txt and ARTISTIC.txt, respectively.
420              
421             =head1 HATS
422              
423             I recommend buying a Fedora from L.
424              
425             =head1 CONSPIRACY
426              
427             This module is also free-as-in-mason software.
428              
429             =cut
430              
431             1;