view release on metacpan or  search on metacpan

inc/Devel/CheckOS.pm  view on Meta::CPAN

As C<os_isnt()>, except that it dies instead of returning false.

=cut

sub die_if_os_is {
    os_isnt(@_) ? 1 : die_unsupported();
}

=head2 And some utility functions ...

=head3 die_unsupported

This function simply dies with the message "OS unsupported", which is what
the CPAN testers look for to figure out whether a platform is supported or
not.

=cut

sub die_unsupported { die("OS unsupported\n"); }

=head3 list_platforms

When called in list context,
return a list of all the platforms for which the corresponding
Devel::AssertOS::* module is available.  This includes both OSes and OS
families, and both those bundled with this module and any third-party
add-ons you have installed.

In scalar context, returns a hashref keyed by platform with the filename
of the most recent version of the supporting module that is available to you.
This is to make sure that the use-devel-assertos script Does The Right Thing
in the case where you have installed the module in one version of perl, then
upgraded perl, and installed it again in the new version.  Sometimes the old
version of perl and all its modules will still be hanging around and perl
"helpfully" includes the old perl's search path in its own.

Unfortunately, on some platforms this list may have file case
broken.  eg, some platforms might return 'freebsd' instead of 'FreeBSD'.
This is because they have case-insensitive filesystems so things
should Just Work anyway.

=cut

my ($re_Devel, $re_AssertOS);

sub list_platforms {
    eval " # only load these if needed
        use File::Find::Rule;
        use File::Spec;
    ";
    
    die($@) if($@);
    if (!$re_Devel) {
        my $case_flag = File::Spec->case_tolerant ? '(?i)' : '';
        $re_Devel    = qr/$case_flag ^Devel$/x;
        $re_AssertOS = qr/$case_flag ^AssertOS$/x;
    }

    # sort by mtime, so oldest last
    my @modules = sort {
        (stat($a->{file}))[9] <=> (stat($b->{file}))[9]
    } map {
        my (undef, $dir_part, $file_part) = File::Spec->splitpath($_);
        $file_part =~ s/\.pm$//;
        my (@dirs) = grep {+length} File::Spec->splitdir($dir_part);
        foreach my $i (reverse 1..$#dirs) {
            next unless $dirs[$i] =~ $re_AssertOS
                && $dirs[$i - 1] =~ $re_Devel;
            splice @dirs, 0, $i + 1;
            last;
        }
        {
            module => join('::', @dirs, $file_part),
            file   => File::Spec->canonpath($_)
        }
    } File::Find::Rule->file()->name('*.pm')->in(
        grep { -d }
        map { File::Spec->catdir($_, qw(Devel AssertOS)) }
        @INC
    );

    my %modules = map {
        $_->{module} => $_->{file}
    } @modules;

    if(wantarray()) {
        return sort keys %modules;
    } else {
        return \%modules;
    }
}

=head3 list_family_members

Takes the name of an OS 'family' and returns a list of all its members.
In list context, you get a list, in scalar context you get an arrayref.

If called on something that isn't a family, you get an empty list (or
a ref to an empty array).

=cut

sub list_family_members {
    my $family = shift() ||
        die(__PACKAGE__."::list_family_members needs a parameter\n");

    # this will die if it's the wrong OS, but the module is loaded ...
    eval qq{use Devel::AssertOS::$family};
    # ... so we can now query it
    my @members = eval qq{
        no strict 'refs';
	&{"Devel::AssertOS::${family}::matches"}()
    };
    return wantarray() ? @members : \@members;
}

=head1 PLATFORMS SUPPORTED

To see the list of platforms for which information is available, run this:

    perl -MDevel::CheckOS -e 'print join(", ", Devel::CheckOS::list_platforms())'