File: find2perl.t

package info (click to toggle)
perl 5.20.2-3%2Bdeb8u11
  • links: PTS, VCS
  • area: main
  • in suites: jessie
  • size: 102,964 kB
  • sloc: perl: 555,553; ansic: 214,041; sh: 38,121; pascal: 8,783; cpp: 3,895; makefile: 2,393; xml: 2,325; yacc: 1,741
file content (229 lines) | stat: -rw-r--r-- 6,998 bytes parent folder | download | duplicates (2)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
#!./perl

# Based on ideas from x2p/s2p.t
#
# This doesn't currently test -exec etc, just the default -print on
# the platforms below.

BEGIN {
    chdir 't' if -d 't';
    @INC = ( '../lib' );
}

use strict;
use warnings;
use File::Path 'remove_tree';
use File::Spec;
require "./test.pl";

# add more platforms if you feel like it, but make sure the
# tests below are portable to the find(1) for any new platform,
# or that they skip on that platform
$^O =~ /^(?:linux|\w+bsd|darwin)$/
    or skip_all("Need something vaguely POSIX");

my $VERBOSE = grep $_ eq '-v', @ARGV;

my $tmpdir = tempfile();
my $script = tempfile();
mkdir $tmpdir
    or die "Cannot make temp dir $tmpdir: $!";

# test file names shouldn't contain any shell special characters,
# and for portability, probably shouldn't contain any high ascii or
# Unicode characters
#
# handling Unicode here would be nice, but I think handling of Unicode
# in perl's file system interfaces (open, unlink, readdir) etc needs to
# be more regular before we can expect interoperability between find2perl
# and a system find(1)
#
# keys for the test file list:
#   name - required
#   type - type of file to create:
#      "f" regular file, "d" directory, "l" link to target,
#      "s" symlink to target
#   atime, mtime - file times (default now)
#   mode - file mode (default per umask)
#   content - file content for type f files
#   target - target for link for type l and s
#
# I could have simply written code to create all the files, but I think
# this makes the file tree a little more obvious
use constant HOUR => 3600; # an hour in seconds
my @test_files =
    (
        { name => "abc" },
        { name => "acc", mtime => time() - HOUR * 48 },
        { name => "ac", content => "x" x 10 },
        { name => "somedir", type => "d" },
        { name => "link", type => "l", target => "abc" },
        { name => "symlink", type => "s", target => "brokenlink" },
    );
# make some files to search
for my $spec (@test_files) {
    my $file = File::Spec->catfile($tmpdir, split '/', $spec->{name});
    my $type = $spec->{type} || "f";
    if ($type eq "f") {
        open my $fh, ">", $file
            or die "Cannot create test file $file: $!";
        if ($spec->{content}) {
            binmode $fh;
            print $fh $spec->{content};
        }
        close $fh
            or die "Cannot close $file: $!";
    }
    elsif ($type eq "d") {
        mkdir $file
            or die "Cannot create test directory $file: $!";
    }
    elsif ($type eq "l") {
        my $target = File::Spec->catfile($tmpdir, split '/', $spec->{target});
        link $target, $file
            or die "Cannot create test link $file: $!";
    }
    elsif ($type eq "s") {
        my $target = File::Spec->catfile($tmpdir, split '/', $spec->{target});
        symlink $target, $file
            or die "Cannot create test symlink $file: $!";
    }
    if ($spec->{mode}) {
        chmod $spec->{mode}, $file
            or die "Cannot set mode of test file $file: $!";
    }
    if ($spec->{mtime} || $spec->{atime}) {
        # default the times to now, since we just created the files
        my $mtime = $spec->{mtime} || time();
        my $atime = $spec->{atime} || time();
        utime $atime, $mtime, $file
            or die "Cannot set times of test file $file: $!";
    }
}

# do we have a vaguely sane find(1)?
# BusyBox find is non-POSIX - it doesn't have -links
my @files = sort `find '$tmpdir' '(' -name 'abc' -o -name 'acc' ')' -a -links +0`;
@files == 2 && $files[0] =~ /\babc\n\z/ && $files[1] =~ /\bacc\n\z/
    or skip_all("doesn't appear to be a sane find(1)");

# required keys:
#   args - find search spec as an array ref
# optional:
#   name - short description of the test (defaults to args)
#   expect - an array ref of files expected to be found (skips the find(1) call)
#   TODO - why this test is TODO (if it is), if a code reference that is
#          called to check if the test is TODO (and why)
#   SKIP - return a message for why to skip
my @testcases =
    (
        {
            name => "all files",
            args => [],
        },
        {
            name => "mapping of *",
            args => [ "-name", "a*c" ],
        },
        {
            args => [ "-type", "d" ],
            expect => [ "", "somedir" ],
        },
        {
            args => [ "-type", "f" ],
        },
        {
            args => [ "-mtime", "+1" ],
            expect => [ "acc" ],
        },
        {
            args => [ "-mtime", "-1" ],
        },
        {
            args => [ "-size", "10c" ],
            expect => [ "ac" ],
        },
        {
            args => [ "-links", "2" ],
        },
        {
            name => "[perl #113054] mapping of ?",
            args => [ "-name", "a?c" ],
        },
    );

plan(tests => 1 + 4 * @testcases);

my $find2perl = File::Spec->catfile(File::Spec->updir(), "x2p", "find2perl");
ok (-x $find2perl, "find2perl exists");
our $TODO;

for my $test (@testcases) {
 SKIP:
    {
        local $TODO = $test->{TODO};
        $TODO = $TODO->() if ref $TODO;
        my $args = $test->{args}
            or die "Missing test args";
        my $name = $test->{name} || "@$args";

        my $skip = $test->{SKIP} && $test->{SKIP}->();
        $skip
            and skip($skip, 4);

        my $code = runperl(args => [ $find2perl, $tmpdir, @$args ]);

        ok($code, "$name: run findperl")
            or skip("", 3);

        open my $script_fh, ">", $script
            or die "Cannot create $script: $!";
        print $script_fh $code;
        close $script_fh
            or die "Cannot close $script: $!";

        my $files = runperl(progfile => $script);

        ok(length $files, "$name: run output script")
            or skip("", 2);

        my $find_files;
        my $source;
        if ($test->{expect}) {
            $find_files = join "\n",
                map { $_ eq "" ? $tmpdir : "$tmpdir/$_" }
                @{$test->{expect}};
            $source = "expected";
            # to balance the ok() in the other branch
            pass("$name: got files ok");
        }
        else {
            my $findcmd = "find $tmpdir ". join " ", map "'$_'", @$args;

            # make sure PERL_UNICODE doesn't reinterpret the output of find
            use open IN => ':raw';
            $find_files = `$findcmd`;
            ok(length $find_files, "$name: run find")
                or skip("", 1);
            $source = "find";
        }

        # is the order from find (or find2perl) guaranteed?
        # assume it isn't
        $files = join("\n", sort split /\n/, $files);
        $find_files = join("\n", sort split /\n/, $find_files);

        if ($VERBOSE) {
            note("script:\n$code");
            note("args:\n@$args");
            note("find2perl:\n$files");
            note("find:\n$find_files");
        }

        is($files, $find_files, "$name: find2perl matches $source");
    }
}

END {
    remove_tree($tmpdir);
}