Return to test613.pl CVS log

Up to [ELWIX - Embedded LightWeight unIX -] / embedaddon / curl / tests / libtest

curl

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