blob: 03d09cb5b233a844dff61df02e00e9b24e1338b7 [file] [log] [blame]
lh9ed821d2023-04-07 01:36:19 -07001#!/usr/bin/env perl
2# Prepare a directory with known files and clean up afterwards
3use Time::Local;
4
5if ( $#ARGV < 1 )
6{
7 print "Usage: $0 prepare|postprocess dir [logfile]\n";
8 exit 1;
9}
10
11# <precheck> expects an error message on stdout
12sub errout {
13 print $_[0] . "\n";
14 exit 1;
15}
16
17if ($ARGV[0] eq "prepare")
18{
19 my $dirname = $ARGV[1];
20 mkdir $dirname || errout "$!";
21 chdir $dirname;
22
23 # Create the files in alphabetical order, to increase the chances
24 # of receiving a consistent set of directory contents regardless
25 # of whether the server alphabetizes the results or not.
26 mkdir "asubdir" || errout "$!";
27 chmod 0777, "asubdir";
28
29 open(FILE, ">plainfile.txt") || errout "$!";
30 binmode FILE;
31 print FILE "Test file to support curl test suite\n";
32 close(FILE);
33 # The mtime is specifically chosen to be an even number so that it can be
34 # represented exactly on a FAT filesystem.
35 utime time, timegm(0,0,12,1,0,100), "plainfile.txt";
36 chmod 0666, "plainfile.txt";
37
38 open(FILE, ">rofile.txt") || errout "$!";
39 binmode FILE;
40 print FILE "Read-only test file to support curl test suite\n";
41 close(FILE);
42 # The mtime is specifically chosen to be an even number so that it can be
43 # represented exactly on a FAT filesystem.
44 utime time, timegm(0,0,12,31,11,100), "rofile.txt";
45 chmod 0444, "rofile.txt";
46
47 exit 0;
48}
49elsif ($ARGV[0] eq "postprocess")
50{
51 my $dirname = $ARGV[1];
52 my $logfile = $ARGV[2];
53
54 # Clean up the test directory
55 unlink "$dirname/rofile.txt";
56 unlink "$dirname/plainfile.txt";
57 rmdir "$dirname/asubdir";
58
59 rmdir $dirname || die "$!";
60
61 if ($logfile) {
62 # Process the directory file to remove all information that
63 # could be inconsistent from one test run to the next (e.g.
64 # file date) or may be unsupported on some platforms (e.g.
65 # Windows). Also, since 7.17.0, the sftp directory listing
66 # format can be dependent on the server (with a recent
67 # enough version of libssh2) so this script must also
68 # canonicalize the format. Here are examples of the general
69 # format supported:
70 # -r--r--r-- 12 ausername grp 47 Dec 31 2000 rofile.txt
71 # -r--r--r-- 1 1234 4321 47 Dec 31 2000 rofile.txt
72 # The "canonical" format is similar to the first (which is
73 # the one generated on a typical Linux installation):
74 # -r-?r-?r-? 12 U U 47 Dec 31 2000 rofile.txt
75
76 my @canondir;
77 open(IN, "<$logfile") || die "$!";
78 while (<IN>) {
79 /^(.)(..).(..).(..).\s*(\S+)\s+\S+\s+\S+\s+(\S+)\s+(\S+\s+\S+\s+\S+)(.*)$/;
80 if ($1 eq "d") {
81 # Erase all directory metadata except for the name, as it is not
82 # consistent for across all test systems and filesystems
83 push @canondir, "d????????? N U U N ??? N NN:NN$8\n";
84 } elsif ($1 eq "-") {
85 # Erase user and group names, as they are not consistent across
86 # all test systems
87 my $line = sprintf("%s%s?%s?%s?%5d U U %15d %s%s\n", $1,$2,$3,$4,$5,$6,$7,$8);
88 push @canondir, $line;
89 } else {
90 # Unexpected format; just pass it through and let the test fail
91 push @canondir, $_;
92 }
93 }
94 close(IN);
95
96 @canondir = sort {substr($a,57) cmp substr($b,57)} @canondir;
97 my $newfile = $logfile . ".new";
98 open(OUT, ">$newfile") || die "$!";
99 print OUT join('', @canondir);
100 close(OUT);
101
102 unlink $logfile;
103 rename $newfile, $logfile;
104 }
105
106 exit 0;
107}
108print "Unsupported command $ARGV[0]\n";
109exit 1;