test613.pl 5.3 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144
  1. #!/usr/bin/env perl
  2. #***************************************************************************
  3. # _ _ ____ _
  4. # Project ___| | | | _ \| |
  5. # / __| | | | |_) | |
  6. # | (__| |_| | _ <| |___
  7. # \___|\___/|_| \_\_____|
  8. #
  9. # Copyright (C) 1998 - 2020, Daniel Stenberg, <daniel@haxx.se>, et al.
  10. #
  11. # This software is licensed as described in the file COPYING, which
  12. # you should have received as part of this distribution. The terms
  13. # are also available at https://curl.haxx.se/docs/copyright.html.
  14. #
  15. # You may opt to use, copy, modify, merge, publish, distribute and/or sell
  16. # copies of the Software, and permit persons to whom the Software is
  17. # furnished to do so, under the terms of the COPYING file.
  18. #
  19. # This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY
  20. # KIND, either express or implied.
  21. #
  22. ###########################################################################
  23. # Prepare a directory with known files and clean up afterwards
  24. use Time::Local;
  25. if ( $#ARGV < 1 )
  26. {
  27. print "Usage: $0 prepare|postprocess dir [logfile]\n";
  28. exit 1;
  29. }
  30. # <precheck> expects an error message on stdout
  31. sub errout {
  32. print $_[0] . "\n";
  33. exit 1;
  34. }
  35. if ($ARGV[0] eq "prepare")
  36. {
  37. my $dirname = $ARGV[1];
  38. mkdir $dirname || errout "$!";
  39. chdir $dirname;
  40. # Create the files in alphabetical order, to increase the chances
  41. # of receiving a consistent set of directory contents regardless
  42. # of whether the server alphabetizes the results or not.
  43. mkdir "asubdir" || errout "$!";
  44. chmod 0777, "asubdir";
  45. open(FILE, ">plainfile.txt") || errout "$!";
  46. binmode FILE;
  47. print FILE "Test file to support curl test suite\n";
  48. close(FILE);
  49. # The mtime is specifically chosen to be an even number so that it can be
  50. # represented exactly on a FAT filesystem.
  51. utime time, timegm(0,0,12,1,0,100), "plainfile.txt";
  52. chmod 0666, "plainfile.txt";
  53. open(FILE, ">rofile.txt") || errout "$!";
  54. binmode FILE;
  55. print FILE "Read-only test file to support curl test suite\n";
  56. close(FILE);
  57. # The mtime is specifically chosen to be an even number so that it can be
  58. # represented exactly on a FAT filesystem.
  59. utime time, timegm(0,0,12,31,11,100), "rofile.txt";
  60. chmod 0444, "rofile.txt";
  61. exit 0;
  62. }
  63. elsif ($ARGV[0] eq "postprocess")
  64. {
  65. my $dirname = $ARGV[1];
  66. my $logfile = $ARGV[2];
  67. # Clean up the test directory
  68. unlink "$dirname/rofile.txt";
  69. unlink "$dirname/plainfile.txt";
  70. rmdir "$dirname/asubdir";
  71. rmdir $dirname || die "$!";
  72. if ($logfile) {
  73. # Process the directory file to remove all information that
  74. # could be inconsistent from one test run to the next (e.g.
  75. # file date) or may be unsupported on some platforms (e.g.
  76. # Windows). Also, since 7.17.0, the sftp directory listing
  77. # format can be dependent on the server (with a recent
  78. # enough version of libssh2) so this script must also
  79. # canonicalize the format. Here are examples of the general
  80. # format supported:
  81. # -r--r--r-- 12 ausername grp 47 Dec 31 2000 rofile.txt
  82. # -r--r--r-- 1 1234 4321 47 Dec 31 2000 rofile.txt
  83. # The "canonical" format is similar to the first (which is
  84. # the one generated on a typical Linux installation):
  85. # -r-?r-?r-? 12 U U 47 Dec 31 2000 rofile.txt
  86. my @canondir;
  87. open(IN, "<$logfile") || die "$!";
  88. while (<IN>) {
  89. /^(.)(..).(..).(..).\s*(\S+)\s+\S+\s+\S+\s+(\S+)\s+(\S+\s+\S+\s+\S+)\s+(.*)$/;
  90. if ($1 eq "d") {
  91. # Skip current and parent directory listing, because some SSH
  92. # servers (eg. OpenSSH for Windows) are not listing those
  93. if ($8 eq "." || $8 eq "..") {
  94. next;
  95. }
  96. # Erase all directory metadata except for the name, as it is not
  97. # consistent for across all test systems and filesystems
  98. push @canondir, "d????????? N U U N ??? N NN:NN $8\n";
  99. } elsif ($1 eq "-") {
  100. # Replace missing group and other permissions with user
  101. # permissions (eg. on Windows) due to them being shown as *
  102. my ($u, $g, $o) = ($2, $3, $4);
  103. if($g eq "**") {
  104. $g = $u;
  105. }
  106. if($o eq "**") {
  107. $o = $u;
  108. }
  109. # Erase user and group names, as they are not consistent across
  110. # all test systems
  111. my $line = sprintf("%s%s?%s?%s?%5d U U %15d %s %s\n", $1,$u,$g,$o,$5,$6,$7,$8);
  112. push @canondir, $line;
  113. } else {
  114. # Unexpected format; just pass it through and let the test fail
  115. push @canondir, $_;
  116. }
  117. }
  118. close(IN);
  119. @canondir = sort {substr($a,57) cmp substr($b,57)} @canondir;
  120. my $newfile = $logfile . ".new";
  121. open(OUT, ">$newfile") || die "$!";
  122. print OUT join('', @canondir);
  123. close(OUT);
  124. unlink $logfile;
  125. rename $newfile, $logfile;
  126. }
  127. exit 0;
  128. }
  129. print "Unsupported command $ARGV[0]\n";
  130. exit 1;