tests/testutil.pm - third_party/curl - Git at Google

 #***************************************************************************
 #                                  _   _ ____  _
 #  Project                     ___| | | |  _ \| |
 #                             / __| | | | |_) | |
 #                            | (__| |_| |  _ <| |___
 #                             \___|\___/|_| \_\_____|
 #
 # Copyright (C) Daniel Stenberg, <daniel@haxx.se>, et al.
 #
 # This software is licensed as described in the file COPYING, which
 # you should have received as part of this distribution. The terms
 # are also available at https://curl.se/docs/copyright.html.
 #
 # You may opt to use, copy, modify, merge, publish, distribute and/or sell
 # copies of the Software, and permit persons to whom the Software is
 # furnished to do so, under the terms of the COPYING file.
 #
 # This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY
 # KIND, either express or implied.
 #
 # SPDX-License-Identifier: curl
 #
 ###########################################################################

 # This module contains miscellaneous functions needed in several parts of
 # the test suite.

 package testutil;

 use strict;
 use warnings;

 BEGIN {
     use base qw(Exporter);

     our @EXPORT = qw(
         runclient
         runclientoutput
         setlogfunc
         exerunner
         subbase64
         subnewlines
         subsha256base64file
         substrippemfile
     );

     our @EXPORT_OK = qw(
         clearlogs
         logmsg
     );
 }

 use Digest::SHA qw(sha256);
 use MIME::Base64;

 use globalconfig qw(
     $torture
     $verbose
     $dev_null
     );

 my $logfunc;      # optional reference to function for logging
 my @logmessages;  # array holding logged messages


 #######################################################################
 # Log an informational message
 # If a log callback function was set in setlogfunc, it is called. If not,
 # then the log message is buffered until retrieved by clearlogs.
 #
 # logmsg must only be called by one of the runner_* entry points and functions
 # called by them, or else logs risk being lost, since those are the only
 # functions that know about and will return buffered logs.
 sub logmsg {
     if(!scalar(@_)) {
         return;
     }
     if(defined $logfunc) {
         &$logfunc(@_);
         return;
     }
     push @logmessages, @_;
 }

 #######################################################################
 # Set the function to use for logging
 sub setlogfunc {
     ($logfunc)=@_;
 }

 #######################################################################
 # Clear the buffered log messages after returning them
 sub clearlogs {
     my $loglines = join('', @logmessages);
     undef @logmessages;
     return $loglines;
 }


 #######################################################################

 sub includefile {
     my ($f, $text) = @_;
     open(F, "<$f");
     if($text) {
         binmode F, ':crlf';
     }
     my @a = <F>;
     close(F);
     return join("", @a);
 }

 sub subbase64 {
     my ($thing) = @_;

     # cut out the base64 piece
     while($$thing =~ s/%b64\[(.*?)\]b64%/%%B64%%/i) {
         my $d = $1;
         # encode %NN characters
         $d =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
         my $enc = encode_base64($d, "");
         # put the result into there
         $$thing =~ s/%%B64%%/$enc/;
     }
     # hex decode
     while($$thing =~ s/%hex\[(.*?)\]hex%/%%HEX%%/i) {
         # decode %NN characters
         my $d = $1;
         $d =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
         $$thing =~ s/%%HEX%%/$d/;
     }
     # repeat
     while($$thing =~ s/%repeat\[(\d+) x (.*?)\]%/%%REPEAT%%/i) {
         # decode %NN characters
         my ($d, $n) = ($2, $1);
         $d =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
         $n =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
         my $all = $d x $n;
         $$thing =~ s/%%REPEAT%%/$all/;
     }

     # days
     while($$thing =~ s/%days\[(.*?)\]/%%DAYS%%/i) {
         # convert to now + given days in epoch seconds, align to a 60 second
         # boundary. Then provide two alternatives.
         my $now = time();
         my $d = ($1 * 24 * 3600) + $now + 30;
         $d = int($d/60) * 60;
         my $d2 = $d + 60;
         $$thing =~ s/%%DAYS%%/%alternatives[$d,$d2]/;
     }

     # include a file, expand space macros
     $$thing =~ s/%includetext ([^%]*)%[\n\r]+/includefile($1, 1)/ge;

     $$thing =~ s/%SP/ /g;    # space
     $$thing =~ s/%TAB/\t/g;  # horizontal tab
     $$thing =~ s/%CR/\r/g;   # carriage return aka \r aka 0x0d
     $$thing =~ s/%LT/</g;
     $$thing =~ s/%GT/>/g;

     # include a file
     $$thing =~ s/%include ([^%]*)%[\n\r]+/includefile($1, 0)/ge;
 }

 my $prevupdate;  # module scope so it remembers the last value
 sub subnewlines {
     my ($force, $thing) = @_;

     if($force) {
         # enforce CRLF newline
         $$thing =~ s/\x0d*\x0a/\x0d\x0a/;
         return;
     }

     if(($$thing =~ /^HTTP\/(1.1|1.0|2|3) ([1-5]|9)[^\x0d]*\z/) ||
        ($$thing =~ /^(GET|HEAD|POST|PUT|DELETE|CONNECT) \S+ HTTP\/\d+(\.\d+)?/) ||
        ($$thing =~ /^(SETUP|GET_PARAMETER|OPTIONS|ANNOUNCE|DESCRIBE) \S+ RTSP\/\d+(\.\d+)?/) ||
        (($$thing =~ /^[a-z0-9_-]+: [^\x0d]*\z/i) &&
         # skip curl error messages
         ($$thing !~ /^curl: \(\d+\) /))) {
         # enforce CRLF newline
         $$thing =~ s/\x0d*\x0a/\x0d\x0a/;
         $prevupdate = 1;
     }
     else {
         if(($$thing =~ /^\n\z/) && $prevupdate) {
             # if there is a blank link after a line we update, we hope it is
             # the empty line following headers
             $$thing =~ s/\x0a/\x0d\x0a/;
         }
         $prevupdate = 0;
     }
 }

 #######################################################################
 # Run the application under test and return its return code
 #
 sub runclient {
     my ($cmd)=@_;
     my $ret = system($cmd);
     print "CMD ($ret): $cmd\n" if($verbose && !$torture);
     return $ret;

 # This is one way to test curl on a remote machine
 #    my $out = system("ssh $CLIENTIP cd \'$pwd\' \\; \'$cmd\'");
 #    sleep 2;    # time to allow the NFS server to be updated
 #    return $out;
 }

 #######################################################################
 # Run the application under test and return its stdout
 #
 sub runclientoutput {
     my ($cmd)=@_;
     return `$cmd 2>$dev_null`;

 # This is one way to test curl on a remote machine
 #    my @out = `ssh $CLIENTIP cd \'$pwd\' \\; \'$cmd\'`;
 #    sleep 2;    # time to allow the NFS server to be updated
 #    return @out;
 }

 #######################################################################
 # Return custom tool (e.g. wine or qemu) to run curl binaries.
 #
 sub exerunner {
     if($ENV{'CURL_TEST_EXE_RUNNER'}) {
         return $ENV{'CURL_TEST_EXE_RUNNER'} . ' ';
     }
     return '';
 }

 sub get_sha256_base64 {
     my ($file_path) = @_;
     return encode_base64(sha256(do { local $/; open my $fh, '<:raw', $file_path or die $!; <$fh> }), "");
 }

 sub subsha256base64file {
     my ($thing) = @_;

     # SHA-256 base64
     while($$thing =~ s/%sha256b64file\[(.*?)\]sha256b64file%/%%SHA256B64FILE%%/i) {
         my $file_path = $1;
         $file_path =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
         my $hash_b64 = get_sha256_base64($file_path);
         $$thing =~ s/%%SHA256B64FILE%%/$hash_b64/;
     }
 }

 sub get_file_content {
     my ($file_path) = @_;
     my $content = do { local $/; open my $fh, '<', $file_path or die $!; <$fh> };
     $content =~ s/(^|-----END .*?-----[\r\n]?)(.*?)(-----BEGIN .*?-----|$)/$1$3/gs;
     $content =~ s/\r\n/\n/g;
     chomp($content);
     return $content;
 }

 sub substrippemfile {
     my ($thing) = @_;

     # File content substitution
     while($$thing =~ s/%strippemfile\[(.*?)\]strippemfile%/%%FILE%%/i) {
         my $file_path = $1;
         $file_path =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
         my $file_content = get_file_content($file_path);
         $$thing =~ s/%%FILE%%/$file_content/;
     }
 }
 1;
	#***************************************************************************
	# _ _ ____ _
	# Project ___\| \| \| \| _ \\| \|
	# / __\| \| \| \| \|_) \| \|
	# \| (__\| \|_\| \| _ <\| \|___
	# \___\|\___/\|_\| \_\_____\|
	#
	# Copyright (C) Daniel Stenberg, <daniel@haxx.se>, et al.
	#
	# This software is licensed as described in the file COPYING, which
	# you should have received as part of this distribution. The terms
	# are also available at https://curl.se/docs/copyright.html.
	#
	# You may opt to use, copy, modify, merge, publish, distribute and/or sell
	# copies of the Software, and permit persons to whom the Software is
	# furnished to do so, under the terms of the COPYING file.
	#
	# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY
	# KIND, either express or implied.
	#
	# SPDX-License-Identifier: curl
	#
	###########################################################################

	# This module contains miscellaneous functions needed in several parts of
	# the test suite.

	package testutil;

	use strict;
	use warnings;

	BEGIN {
	use base qw(Exporter);

	our @EXPORT = qw(
	runclient
	runclientoutput
	setlogfunc
	exerunner
	subbase64
	subnewlines
	subsha256base64file
	substrippemfile
	);

	our @EXPORT_OK = qw(
	clearlogs
	logmsg
	);
	}

	use Digest::SHA qw(sha256);
	use MIME::Base64;

	use globalconfig qw(
	$torture
	$verbose
	$dev_null
	);

	my $logfunc; # optional reference to function for logging
	my @logmessages; # array holding logged messages


	#######################################################################
	# Log an informational message
	# If a log callback function was set in setlogfunc, it is called. If not,
	# then the log message is buffered until retrieved by clearlogs.
	#
	# logmsg must only be called by one of the runner_* entry points and functions
	# called by them, or else logs risk being lost, since those are the only
	# functions that know about and will return buffered logs.
	sub logmsg {
	if(!scalar(@_)) {
	return;
	}
	if(defined $logfunc) {
	&$logfunc(@_);
	return;
	}
	push @logmessages, @_;
	}

	#######################################################################
	# Set the function to use for logging
	sub setlogfunc {
	($logfunc)=@_;
	}

	#######################################################################
	# Clear the buffered log messages after returning them
	sub clearlogs {
	my $loglines = join('', @logmessages);
	undef @logmessages;
	return $loglines;
	}


	#######################################################################

	sub includefile {
	my ($f, $text) = @_;
	open(F, "<$f");
	if($text) {
	binmode F, ':crlf';
	}
	my @a = <F>;
	close(F);
	return join("", @a);
	}

	sub subbase64 {
	my ($thing) = @_;

	# cut out the base64 piece
	while($$thing =~ s/%b64\[(.*?)\]b64%/%%B64%%/i) {
	my $d = $1;
	# encode %NN characters
	$d =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
	my $enc = encode_base64($d, "");
	# put the result into there
	$$thing =~ s/%%B64%%/$enc/;
	}
	# hex decode
	while($$thing =~ s/%hex\[(.*?)\]hex%/%%HEX%%/i) {
	# decode %NN characters
	my $d = $1;
	$d =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
	$$thing =~ s/%%HEX%%/$d/;
	}
	# repeat
	while($$thing =~ s/%repeat\[(\d+) x (.*?)\]%/%%REPEAT%%/i) {
	# decode %NN characters
	my ($d, $n) = ($2, $1);
	$d =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
	$n =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
	my $all = $d x $n;
	$$thing =~ s/%%REPEAT%%/$all/;
	}

	# days
	while($$thing =~ s/%days\[(.*?)\]/%%DAYS%%/i) {
	# convert to now + given days in epoch seconds, align to a 60 second
	# boundary. Then provide two alternatives.
	my $now = time();
	my $d = ($1 * 24 * 3600) + $now + 30;
	$d = int($d/60) * 60;
	my $d2 = $d + 60;
	$$thing =~ s/%%DAYS%%/%alternatives[$d,$d2]/;
	}

	# include a file, expand space macros
	$$thing =~ s/%includetext ([^%]*)%[\n\r]+/includefile($1, 1)/ge;

	$$thing =~ s/%SP/ /g; # space
	$$thing =~ s/%TAB/\t/g; # horizontal tab
	$$thing =~ s/%CR/\r/g; # carriage return aka \r aka 0x0d
	$$thing =~ s/%LT/</g;
	$$thing =~ s/%GT/>/g;

	# include a file
	$$thing =~ s/%include ([^%]*)%[\n\r]+/includefile($1, 0)/ge;
	}

	my $prevupdate; # module scope so it remembers the last value
	sub subnewlines {
	my ($force, $thing) = @_;

	if($force) {
	# enforce CRLF newline
	$$thing =~ s/\x0d*\x0a/\x0d\x0a/;
	return;
	}

	if(($$thing =~ /^HTTP\/(1.1\|1.0\|2\|3) ([1-5]\|9)[^\x0d]*\z/) \|\|
	($$thing =~ /^(GET\|HEAD\|POST\|PUT\|DELETE\|CONNECT) \S+ HTTP\/\d+(\.\d+)?/) \|\|
	($$thing =~ /^(SETUP\|GET_PARAMETER\|OPTIONS\|ANNOUNCE\|DESCRIBE) \S+ RTSP\/\d+(\.\d+)?/) \|\|
	(($$thing =~ /^[a-z0-9_-]+: [^\x0d]*\z/i) &&
	# skip curl error messages
	($$thing !~ /^curl: \(\d+\) /))) {
	# enforce CRLF newline
	$$thing =~ s/\x0d*\x0a/\x0d\x0a/;
	$prevupdate = 1;
	}
	else {
	if(($$thing =~ /^\n\z/) && $prevupdate) {
	# if there is a blank link after a line we update, we hope it is
	# the empty line following headers
	$$thing =~ s/\x0a/\x0d\x0a/;
	}
	$prevupdate = 0;
	}
	}

	#######################################################################
	# Run the application under test and return its return code
	#
	sub runclient {
	my ($cmd)=@_;
	my $ret = system($cmd);
	print "CMD ($ret): $cmd\n" if($verbose && !$torture);
	return $ret;

	# This is one way to test curl on a remote machine
	# my $out = system("ssh $CLIENTIP cd \'$pwd\' \\; \'$cmd\'");
	# sleep 2; # time to allow the NFS server to be updated
	# return $out;
	}

	#######################################################################
	# Run the application under test and return its stdout
	#
	sub runclientoutput {
	my ($cmd)=@_;
	return `$cmd 2>$dev_null`;

	# This is one way to test curl on a remote machine
	# my @out = `ssh $CLIENTIP cd \'$pwd\' \\; \'$cmd\'`;
	# sleep 2; # time to allow the NFS server to be updated
	# return @out;
	}

	#######################################################################
	# Return custom tool (e.g. wine or qemu) to run curl binaries.
	#
	sub exerunner {
	if($ENV{'CURL_TEST_EXE_RUNNER'}) {
	return $ENV{'CURL_TEST_EXE_RUNNER'} . ' ';
	}
	return '';
	}

	sub get_sha256_base64 {
	my ($file_path) = @_;
	return encode_base64(sha256(do { local $/; open my $fh, '<:raw', $file_path or die $!; <$fh> }), "");
	}

	sub subsha256base64file {
	my ($thing) = @_;

	# SHA-256 base64
	while($$thing =~ s/%sha256b64file\[(.*?)\]sha256b64file%/%%SHA256B64FILE%%/i) {
	my $file_path = $1;
	$file_path =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
	my $hash_b64 = get_sha256_base64($file_path);
	$$thing =~ s/%%SHA256B64FILE%%/$hash_b64/;
	}
	}

	sub get_file_content {
	my ($file_path) = @_;
	my $content = do { local $/; open my $fh, '<', $file_path or die $!; <$fh> };
	$content =~ s/(^\|-----END .?-----[\r\n]?)(.?)(-----BEGIN .*?-----\|$)/$1$3/gs;
	$content =~ s/\r\n/\n/g;
	chomp($content);
	return $content;
	}

	sub substrippemfile {
	my ($thing) = @_;

	# File content substitution
	while($$thing =~ s/%strippemfile\[(.*?)\]strippemfile%/%%FILE%%/i) {
	my $file_path = $1;
	$file_path =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
	my $file_content = get_file_content($file_path);
	$$thing =~ s/%%FILE%%/$file_content/;
	}
	}
	1;