1 #!/usr/bin/env perl 2 # Prepare a directory with known files and clean up afterwards 3 use Time::Local; 4 5 if ( $#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 12 sub errout { 13 print $_[0] . "\n"; 14 exit 1; 15 } 16 17 if ($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 } 49 elsif ($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 } 108 print "Unsupported command $ARGV[0]\n"; 109 exit 1; 110
