File Coverage

blib/lib/Devel/CheckApplicationCapabilities.pm

Criterion	Covered	Total	%
statement	184	185	99.4
branch	24	30	80.0
condition	2	3	66.6
subroutine	53	53	100.0
pod	6	6	100.0
total	269	277	97.1

package Devel::CheckApplicationCapabilities;

use strict;
use Exporter;
use Config;
use File::Spec;
use Cwd;

use vars qw($VERSION @ISA @EXPORT_OK %EXPORT_TAGS);

$VERSION = '1.1';

# localising prevents the warningness leaking out of this module
local $^W = 1;    # use warnings is a 5.6-ism

@ISA = qw(Exporter);
@EXPORT_OK = qw(
  app_is app_isnt
  die_if_app_is die_if_app_isnt
  die_unsupported
  list_app_checks
);
%EXPORT_TAGS = (
    all      => \@EXPORT_OK,
    booleans => [qw(app_is app_isnt die_unsupported)],
    fatal    => [qw(die_if_app_is die_if_app_isnt)]
);

=head1 NAME

Devel::CheckApplicationCapabilities - check what an external application
is capable of.

=head1 DESCRIPTION

Devel::CheckApplicationCapabilities provides a nice user-friendly interface
to back-end modules for doing things like checking whether tar(1) supports
the -z argument and so can be expected to support .tar.gz files.

=head1 SYNOPSIS

    use Devel::CheckApplicationCapabilities qw(app_is);
    print "Yay, I can gzip!\n"
      if(app_is('tar' => qw(TarMinusZ)));
    print "Yay, I can bzip too!\n"
      if(app_is('tar' => qw(TarMinusJ TarMinusZ)));

=head1 FUNCTIONS

Devel::CheckApplicationCapabilities implements the following functions, which load subsidiary
modules on demand to do the real work.  They can be exported
by listing their names after C.  You can also export
groups of functions thus:

    use Devel::CheckApplicationCapabilities qw(:booleans); # export the boolean functions
                                      # and 'die_unsupported'

    use Devel::CheckApplicationCapabilities qw(:fatal);    # export those that die on no match

    use Devel::CheckApplicationCapabilities qw(:all);      # export everything

=head2 Boolean functions

=head3 app_is

Takes an application name and a list of capabilities and returns true
if the application has all the capabilities, false otherwise.  The
application can be
specified as a relative path, a full path, or with no path at all in
which case C<$ENV{PATH}> will be searched.

Each capability corresponds to a
Devel::AssertApplicationCapabilities::whatever module.

=cut

# look in $PATH for $app
sub _find_app {
  my $app = shift;
  return $app if(-f $app);

  foreach my $path (split(/$Config{path_sep}/, $ENV{PATH})) {
    return File::Spec->catfile($path, $app) if(-f File::Spec->catfile($path, $app))
  }
  return $app;
}

sub app_is {
  my $app = shift;
  $app = _find_app($app);
  die("Devel::CheckApplicationCapabilities: $app doesn't exist\n")
    unless(-f $app);

  my @targets = @_;
  my $rval = 1;
  foreach my $target (@targets) {
    die("Devel::CheckApplicationCapabilities: $target isn't a legal capability name\n")
      unless($target =~ /^\w+(::\w+)*$/);
    eval "use Devel::AssertApplicationCapabilities::$target '$app'";
    $rval = 0 if($@);
  }
  return $rval;
}

=head3 app_isnt

Exactly the same as C, except that it returns true if the
app does not have all the capabilities, otherwise it returns false.

=cut

sub app_isnt {
    my $app = shift;
    my @targets = @_;
    app_is($app, @targets) ? 0 : 1;
}

=head2 Fatal functions

=head3 die_if_app_isnt

As C, except that it dies instead of returning false.  The die()
message matches what the CPAN-testers look for to determine if a module
doesn't support a particular platform.

=cut

sub die_if_app_isnt {
    app_is(@_) ? 1 : die_unsupported();
}

=head3 die_if_app_is

As C, except that it dies instead of returning false.

=cut

sub die_if_app_is {
    app_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.  Yes, it says "OS", not "application".  Sorry, that's just the way
things are.

=cut

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

# takes a subref as its argument.  It temporarily closes
# STDERR, runs the subref, then restores STDERR.
sub _with_STDERR_closed {
  open(my $REALSTDERR, ">&STDERR") || die("Can't dup STDERR\n");
  close(STDERR);

  my $rval = shift->();

  open(STDERR, '>&', $REALSTDERR) || die("Can't dup saved STDERR\n");
  return $rval;
}

=head3 list_app_checks

When called in list context,
return a list of all the capabilities that can be checked, or
Devel::AssertApplicationCapabilities::* modules that are available.
That includes both those bundled with this module and any third-party
add-ons you have installed.

In scalar context, returns a hashref keyed by capability with the filename
of the most recent version of the supporting module that is available to you.

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

=cut

my ($re_Devel, $re_AssertApplicationCapabilities);
sub list_app_checks {
    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_AssertApplicationCapabilities = qr/$case_flag ^AssertApplicationCapabilities$/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_AssertApplicationCapabilities
                && $dirs[$i - 1] =~ $re_Devel;
            splice @dirs, 0, $i + 1;
            last;
        }
        {
            module => join('::', @dirs, $file_part),
            file   => File::Spec->canonpath($_)
        }
    } File::Find::Rule->file()->not(File::Find::Rule->name('_*'))->name('*.pm')->in(
        grep { -d }
        map { File::Spec->catdir($_, qw(Devel AssertApplicationCapabilities)) }
        @INC
    );

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

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

=head1 CAPABILITIES SUPPORTED

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

    perl -MDevel::CheckApplicationCapabilities=:all -le 'print join(", ", list_app_checks())'

Note that capitalisation is important.  These are the names of the
underlying Devel::AssertApplicationCapabilities::* modules
which do the actual platform detection, so they have to
be 'legal' filenames and module names, which unfortunately precludes
funny characters, so we check for 'tar -z' with 'TarMinusZ'.
Sorry.

If you want to add your own OSes or families, see L
and please feel free to upload the results to the CPAN.

=head1 BUGS and FEEDBACK

I welcome feedback about my code, including constructive criticism.
Bug reports should be made using L or by email.

If you are feeling particularly generous you can encourage me in my
open source endeavours by buying me something from my wishlist:
  L

=head1 SEE ALSO

L

L

L

=head1 AUTHOR

David Cantrell EFE

=head1 SOURCE CODE REPOSITORY

L

=head1 COPYRIGHT and LICENCE

Copyright 2010 David Cantrell

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.

=head1 TWEED

I recommend buying splendiferous cloth from , especially from their "lumatwill" range.

=head1 CONSPIRACY

This module is also free-as-in-mason software.

=cut

1;