File Coverage

blib/lib/File/Random.pm

Criterion	Covered	Total	%
statement	83	83	100.0
branch	44	46	95.6
condition	32	37	86.4
subroutine	17	17	100.0
pod	3	3	100.0
total	179	186	96.2

package File::Random;

use 5.006;
use strict;
use warnings;

use File::Find;
use Carp;
use Want qw/howmany/;

require Exporter;

our @ISA = qw(Exporter);

our %EXPORT_TAGS = (
  ':all' => [ qw(
	  random_file
	  content_of_random_file corf
      random_line
  ) ],
  # and for some backward compability
  'all' => [ qw(
	  random_file
   	  content_of_random_file corf
      random_line
  ) ]
);

our @EXPORT_OK = ( @{ $EXPORT_TAGS{':all'} }, 'corf' );

our @EXPORT = qw(

);
our $VERSION = '0.20';

sub _standard_dir($);
sub _dir(%);

sub random_file {
	my @params = my ($dir, $check, $recursive, $follow) = _params_random_file(@_);

	return $recursive ? _random_file_recursive    (@params)
	                  : _random_file_non_recursive(@params);
}

*corf = *content_of_random_file;

sub content_of_random_file {
	my %args = @_;
	my $rf = random_file(%args) or return undef;
	my $dir = _standard_dir _dir %args;

	open RANDOM_FILE, "<", "$dir/$rf"
		or die "Can't open the randomly selected file '$dir/$rf'";
	my @content = ();
	close RANDOM_FILE;
	return wantarray ? @content : join "", @content;
}

sub random_line {
    my ($fname, $nr_of_lines) = @_;
    defined $fname or die "Need a defined filename to read a random line";
    if (!defined($nr_of_lines) and wantarray) {
        $nr_of_lines = howmany() || 1;
    }
    unless (!defined($nr_of_lines) or $nr_of_lines =~ /^\d+$/) {
        die "Number of random_lines should be a number, not '$nr_of_lines'";
    }
    defined($nr_of_lines) and $nr_of_lines == 0 and
        carp "doesn't make a lot of sense to return 0 random lines, " .
             "you called me with random_line($fname,$nr_of_lines)";
    $nr_of_lines ||= 1;
    my @line  = ();
    open FILE, '<', $fname or die "Can't open '$fname' to read random_line";
    if ($nr_of_lines == 1) {
        # Algorithm from Cookbook, chapter 8.6
        rand($.) < 1 && ($line[0] = $_) while ();
    } else {
        wantarray or
            carp "random_line($fname,$nr_of_lines) was called in scalar context, ".
                 "what doesn't make a lot sense";
        while () {
            for my $lnr (0 .. $nr_of_lines-1) {
                $line[$lnr] = $_ if rand($.) < 1;
            }
        }
    }
    close FILE;
    return wantarray ? @line : $line[0];
}

sub _random_file_non_recursive {
	my ($dir, $check) = @_;

	opendir DIR, $dir or die "Can't open directory '$dir'";
	my @files = grep {-f "$dir/$_" and _valid_file($check, $_)} (readdir DIR);
	closedir DIR;

	return undef unless @files;
	return $files[rand @files];
}

sub _random_file_recursive {
	my ($dir, $check, $recursive, $follow) = @_;

	my $i = 1;
	my $fname;

	my $accept_routine = sub {
		return unless -f;

		# Calculate filename with relative path
		my ($f) = $File::Find::name =~ m:^$dir[/\\]*(.*)$:;
		return unless _valid_file($check,$f);
		# Algorithm from Cookbook, chapter 8.6
		# similar to selecting a random line from a file
		if (rand($i++) < 1) {
			$fname = $f;
		}
	};
	find({wanted => $accept_routine, follow => $follow}, $dir);

	return $fname;
}

sub _valid_file {
	my ($check, $name) = @_;
	for (ref($check)) {
		    /Regexp/ && return $name =~ /$check/
		or  /CODE/   && ($_ = $name, return $check->($name));
	}
}

sub _dir (%) {
    my %args = @_;
    return $args{-d} || $args{-dir} || $args{-directory};
}

sub _params_random_file {
	my %args  = @_;

	for (qw/-d -dir -directory -c -check/) {
		exists $args{$_} and ! $args{$_} and
		die "Parameter $_ is declared with a false value";
	}

    foreach (keys %args) {
        /^\-(d|dir|directory|
             c|check|
             r|rec|recursive|
             f|follow)$/x or carp "Unknown option '$_'";
    }

	my $dir   = _standard_dir _dir %args;
	my $check = $args{-c} || $args{-check} || sub {"always O.K."};
	my $recursive = $args{-r} || $args{-rec} || $args{-recursive};
    my $follow = $args{-f} || $args{-follow};

	unless (!defined($check) or (scalar ref($check) =~ /^(Regexp|CODE)$/)) {
		die "-check Parameter has to be either a Regexp or a sub routine,".
		    "not a '" . ref($check) . "'";
	}

	return ($dir, $check, $recursive, $follow);
}

sub _standard_dir($) {
	my $dir = shift() || '.';
	$dir =~ s:[/\\]+$::;
	return $dir;
}

1;
__END__