libapp-info-perl 0.57-1 / usr / share / perl5 / App / Info / Util.pm

package App::Info::Util;

=head1 NAME

App::Info::Util - Utility class for App::Info subclasses

=head1 SYNOPSIS

  use App::Info::Util;

  my $util = App::Info::Util->new;

  # Subclasses File::Spec.
  my @paths = $util->paths;

  # First directory that exists in a list.
  my $dir = $util->first_dir(@paths);

  # First directory that exists in a path.
  $dir = $util->first_path($ENV{PATH});

  # First file that exists in a list.
  my $file = $util->first_file('this.txt', '/that.txt', 'C:\\foo.txt');

  # First file found among file base names and directories.
  my $files = ['this.txt', 'that.txt'];
  $file = $util->first_cat_file($files, @paths);

=head1 DESCRIPTION

This class subclasses L<File::Spec|File::Spec> and adds its own methods in
order to offer utility methods to L<App::Info|App::Info> classes. Although
intended to be used by App::Info subclasses, in truth App::Info::Util's
utility may be considered more general, so feel free to use it elsewhere.

The methods added in addition to the usual File::Spec suspects are designed to
facilitate locating files and directories on the file system, as well as
searching those files. The assumption is that, in order to provide useful
meta data about a given software package, an App::Info subclass must find
relevant files and directories and parse them with regular expressions. This
class offers methods that simplify those tasks.

=cut

use strict;
use File::Spec ();
use Config;
use vars qw(@ISA $VERSION);
@ISA = qw(File::Spec);
$VERSION = '0.57';

my %path_dems = (
    MacOS   => qr',',
    MSWin32 => qr';',
    os2     => qr';',
    VMS     => undef,
    epoc    => undef
);

my $path_dem = exists $path_dems{$^O} ? $path_dems{$^O} : qr':';

=head1 CONSTRUCTOR

=head2 new

  my $util = App::Info::Util->new;

This is a very simple constructor that merely returns an App::Info::Util
object. Since, like its File::Spec super class, App::Info::Util manages no
internal data itself, all methods may be used as class methods, if one prefers
to. The constructor here is provided merely as a convenience.

=cut

sub new { bless {}, ref $_[0] || $_[0] }

##############################################################################

=head1 OBJECT METHODS

In addition to all of the methods offered by its super class,
L<File::Spec|File::Spec>, App::Info::Util offers the following methods.

=head2 first_dir

  my @paths = $util->paths;
  my $dir = $util->first_dir(@dirs);

Returns the first file system directory in @paths that exists on the local
file system. Only the first item in @paths that exists as a directory will be
returned; any other paths leading to non-directories will be ignored.

=cut

sub first_dir {
    shift;
    foreach (@_) { return $_ if -d }
    return;
}

##############################################################################

=head2 first_path

  my $path = $ENV{PATH};
  $dir = $util->first_path($path);

Takes the $path string and splits it into a list of directory paths, based on
the path delimiter on the local file system. Then calls C<first_dir()> to
return the first directory in the path list that exists on the local file
system. The path delimiter is specified for the following file systems:

=over 4

=item * MacOS: ","

=item * MSWin32: ";"

=item * os2: ";"

=item * VMS: undef

This method always returns undef on VMS. Patches welcome.

=item * epoc: undef

This method always returns undef on epoch. Patches welcome.

=item * Unix: ":"

All other operating systems are assumed to be Unix-based.

=back

=cut

sub first_path {
    return unless $path_dem;
    shift->first_dir(split /$path_dem/, shift)
}

##############################################################################

=head2 first_file

  my $file = $util->first_file(@filelist);

Examines each of the files in @filelist and returns the first one that exists
on the file system. The file must be a regular file -- directories will be
ignored.

=cut

sub first_file {
    shift;
    foreach (@_) { return $_ if -f }
    return;
}

##############################################################################

=head2 first_exe

  my $exe = $util->first_exe(@exelist);

Examines each of the files in @exelist and returns the first one that exists
on the file system as an executable file. Directories will be ignored.

=cut

sub first_exe {
    shift;
    foreach (@_) { return $_ if -f && -x }
    return;
}

##############################################################################

=head2 first_cat_path

  my $file = $util->first_cat_path('ick.txt', @paths);
  $file = $util->first_cat_path(['this.txt', 'that.txt'], @paths);

The first argument to this method may be either a file or directory base name
(that is, a file or directory name without a full path specification), or a
reference to an array of file or directory base names. The remaining arguments
constitute a list of directory paths. C<first_cat_path()> processes each of
these directory paths, concatenates (by the method native to the local
operating system) each of the file or directory base names, and returns the
first one that exists on the file system.

For example, let us say that we were looking for a file called either F<httpd>
or F<apache>, and it could be in any of the following paths:
F</usr/local/bin>, F</usr/bin/>, F</bin>. The method call looks like this:

  my $httpd = $util->first_cat_path(['httpd', 'apache'], '/usr/local/bin',
                                    '/usr/bin/', '/bin');

If the OS is a Unix variant, C<first_cat_path()> will then look for the first
file that exists in this order:

=over 4

=item /usr/local/bin/httpd

=item /usr/local/bin/apache

=item /usr/bin/httpd

=item /usr/bin/apache

=item /bin/httpd

=item /bin/apache

=back

The first of these complete paths to be found will be returned. If none are
found, then undef will be returned.

=cut

sub first_cat_path {
    my $self = shift;
    my $files = ref $_[0] ? shift() : [shift()];
    foreach my $p (@_) {
        foreach my $f (@$files) {
            my $path = $self->catfile($p, $f);
            return $path if -e $path;
        }
    }
    return;
}

##############################################################################

=head2 first_cat_dir

  my $dir = $util->first_cat_dir('ick.txt', @paths);
  $dir = $util->first_cat_dir(['this.txt', 'that.txt'], @paths);

Functionally identical to C<first_cat_path()>, except that it returns the
directory path in which the first file was found, rather than the full
concatenated path. Thus, in the above example, if the file found was
F</usr/bin/httpd>, while C<first_cat_path()> would return that value,
C<first_cat_dir()> would return F</usr/bin> instead.

=cut

sub first_cat_dir {
    my $self = shift;
    my $files = ref $_[0] ? shift() : [shift()];
    foreach my $p (@_) {
        foreach my $f (@$files) {
            my $path = $self->catfile($p, $f);
            return $p if -e $path;
        }
    }
    return;
}

##############################################################################

=head2 first_cat_exe

  my $exe = $util->first_cat_exe('ick.exe', @paths);
  $exe = $util->first_cat_exe(['this.exe', 'that.exe'], @paths);

Functionally identical to C<first_cat_path()>, except that it returns the full
path to the first executable file found, rather than simply the first file
found.

=cut

sub first_cat_exe {
    my $self = shift;
    my $files = ref $_[0] ? shift() : [shift()];
    foreach my $p (@_) {
        foreach my $f (@$files) {
            my $path = $self->catfile($p, $f);
            return $path if -f $path && -x $path;
        }
    }
    return;
}

##############################################################################

=head2 search_file

  my $file = 'foo.txt';
  my $regex = qr/(text\s+to\s+find)/;
  my $value = $util->search_file($file, $regex);

Opens C<$file> and executes the C<$regex> regular expression against each line
in the file. Once the line matches and one or more values is returned by the
match, the file is closed and the value or values returned.

For example, say F<foo.txt> contains the line "Version 6.5, patch level 8",
and you need to grab each of the three version parts. All three parts can
be grabbed like this:

  my $regex = qr/Version\s+(\d+)\.(\d+),[^\d]*(\d+)/;
  my @nums = $util->search_file($file, $regex);

Now C<@nums> will contain the values C<(6, 5, 8)>. Note that in a scalar
context, the above search would yield an array reference:

  my $regex = qr/Version\s+(\d+)\.(\d+),[^\d]*(\d+)/;
  my $nums = $util->search_file($file, $regex);

So now C<$nums> contains C<[6, 5, 8]>. The same does not hold true if the
match returns only one value, however. Say F<foo.txt> contains the line
"king of the who?", and you wish to know who the king is king of. Either
of the following two calls would get you the data you need:

  my $minions = $util->search_file($file, qr/King\s+of\s+(.*)/);
  my @minions = $util->search_file($file, qr/King\s+of\s+(.*)/);

In the first case, because the regular expression contains only one set of
parentheses, C<search_file()> will simply return that value: C<$minions>
contains the string "the who?". In the latter case, C<@minions> of course
contains a single element: C<("the who?")>.

Note that a regular expression without parentheses -- that is, one that
doesn't grab values and put them into $1, $2, etc., will never successfully
match a line in this method. You must include something to parenthetically
match. If you just want to know the value of what was matched, parenthesize
the whole thing and if the value returns, you have a match. Also, if you need
to match patterns across lines, try using multiple regular expressions with
C<multi_search_file()>, instead.

=cut

sub search_file {
    my ($self, $file, $regex) = @_;
    return unless $file && $regex;
    open F, "<$file" or require Carp && Carp::croak("Cannot open $file: $!\n");
    my @ret;
    while (<F>) {
        # If we find a match, we're done.
        (@ret) = /$regex/ and last;
    }
    close F;
    # If the match returned an more than one value, always return the full
    # array. Otherwise, return just the first value in a scalar context.
    return unless @ret;
    return wantarray ? @ret : $#ret <= 0 ? $ret[0] : \@ret;
}

##############################################################################

=head2 files_in_dir

  my @files = $util->files_in_dir($dir);
     @files = $util->files_in_dir($dir, $filter);
  my $files = $util->files_in_dir($dir);
     $files = $util->files_in_dir($dir, $filter);

Returns an list or array reference of all of the files and directories in the
file system directory C<$dir>. An optional second argument is a code reference
that filters the files. The code reference should examine the C<$_> for a file
name and return true if it's a file that you're interested and false if it's
not.

=cut

sub files_in_dir {
    my ($self, $dir, $code) = @_;
    return unless $dir;
    local *DIR;
    opendir DIR, $dir or require Carp && Carp::croak("Cannot open $dir: $!\n");
    my @files = $code
        ? grep { $code->() } readdir DIR
        : readdir DIR;
    closedir DIR;
    return wantarray ? @files : \@files;
}

##############################################################################

=head2 multi_search_file

  my @regexen = (qr/(one)/, qr/(two)\s+(three)/);
  my @matches = $util->multi_search_file($file, @regexen);

Like C<search_file()>, this method opens C<$file> and parses it for regular
expression matches. This method, however, can take a list of regular
expressions to look for, and will return the values found for all of them.
Regular expressions that match and return multiple values will be returned as
array references, while those that match and return a single value will return
just that single value.

For example, say you are parsing a file with lines like the following:

  #define XML_MAJOR_VERSION 1
  #define XML_MINOR_VERSION 95
  #define XML_MICRO_VERSION 2

You need to get each of these numbers, but calling C<search_file()> for each
of them would be wasteful, as each call to C<search_file()> opens the file and
parses it. With C<multi_search_file()>, on the other hand, the file will be
opened only once, and, once all of the regular expressions have returned
matches, the file will be closed and the matches returned.

Thus the above values can be collected like this:

  my @regexen = ( qr/XML_MAJOR_VERSION\s+(\d+)$/,
                  qr/XML_MINOR_VERSION\s+(\d+)$/,
                  qr/XML_MICRO_VERSION\s+(\d+)$/ );

  my @nums = $file->multi_search_file($file, @regexen);

The result will be that C<@nums> contains C<(1, 95, 2)>. Note that
C<multi_file_search()> tries to do the right thing by only parsing the file
until all of the regular expressions have been matched. Thus, a large file
with the values you need near the top can be parsed very quickly.

As with C<search_file()>, C<multi_search_file()> can take regular expressions
that match multiple values. These will be returned as array references. For
example, say the file you're parsing has files like this:

  FooApp Version 4
  Subversion 2, Microversion 6

To get all of the version numbers, you can either use three regular
expressions, as in the previous example:

  my @regexen = ( qr/FooApp\s+Version\s+(\d+)$/,
                  qr/Subversion\s+(\d+),/,
                  qr/Microversion\s+(\d$)$/ );

  my @nums = $file->multi_search_file($file, @regexen);

In which case C<@nums> will contain C<(4, 2, 6)>. Or, you can use just two
regular expressions:

  my @regexen = ( qr/FooApp\s+Version\s+(\d+)$/,
                  qr/Subversion\s+(\d+),\s+Microversion\s+(\d$)$/ );

  my @nums = $file->multi_search_file($file, @regexen);

In which case C<@nums> will contain C<(4, [2, 6])>. Note that the two
parentheses that return values in the second regular expression cause the
matches to be returned as an array reference.

=cut

sub multi_search_file {
    my ($self, $file, @regexen) = @_;
    return unless $file && @regexen;
    my @each = @regexen;
    open F, "<$file" or require Carp && Carp::croak("Cannot open $file: $!\n");
    my %ret;
    while (my $line = <F>) {
        my @splice;
        # Process each of the regular expresssions.
        for (my $i = 0; $i < @each; $i++) {
            if ((my @ret) = $line =~ /$each[$i]/) {
                # We have a match! If there's one match returned, just grab
                # it. If there's more than one, keep it as an array ref.
                $ret{$each[$i]} = $#ret > 0 ? \@ret : $ret[0];
                # We got values for this regex, so not its place in the @each
                # array.
                push @splice, $i;
            }
        }
        # Remove any regexen that have already found a match.
        for (@splice) { splice @each, $_, 1 }
        # If there are no more regexes, we're done -- no need to keep
        # processing lines in the file!
        last unless @each;
    }
    close F;
    return unless %ret;
    return wantarray ? @ret{@regexen} : \@ret{@regexen};
}

##############################################################################

=head2 lib_dirs

  my @dirs = $util->lib_dirs;

Returns a list of possible library directories to be searched. These are
gathered from the C<libsdirs> and C<loclibpth> Config settings. These are
useful for passing to C<first_cat_dir()> to search typical directories for
library files.

=cut

sub lib_dirs {
    grep { defined and length }
    map { split ' ' }
    grep { defined }
    # Quote Config access to work around
    # http://bugs.activestate.com/show_bug.cgi?id=89447
    "$Config{libsdirs}",
    "$Config{loclibpth}",
    '/sw/lib';
}

1;
__END__

=head1 SUPPORT

This module is stored in an open L<GitHub
repository|http://github.com/theory/app-info/>. Feel free to fork and
contribute!

Please file bug reports via L<GitHub
Issues|http://github.com/theory/app-info/issues/> or by sending mail to
L<bug-App-Info@rt.cpan.org|mailto:bug-App-Info@rt.cpan.org>.

=head1 AUTHOR

David E. Wheeler <david@justatheory.com>

=head1 SEE ALSO

L<App::Info|App::Info>, L<File::Spec|File::Spec>,
L<App::Info::HTTPD::Apache|App::Info::HTTPD::Apache>
L<App::Info::RDBMS::PostgreSQL|App::Info::RDBMS::PostgreSQL>

=head1 COPYRIGHT AND LICENSE

Copyright (c) 2002-2011, David E. Wheeler. Some Rights Reserved.

This module is free software; you can redistribute it and/or modify it under
the same terms as Perl itself.

=cut