xref: /curl/tests/testutil.pm (revision fc3e1cbc) 
1#***************************************************************************
2#                                  _   _ ____  _
3#  Project                     ___| | | |  _ \| |
4#                             / __| | | | |_) | |
5#                            | (__| |_| |  _ <| |___
6#                             \___|\___/|_| \_\_____|
7#
8# Copyright (C) Daniel Stenberg, <daniel@haxx.se>, et al.
9#
10# This software is licensed as described in the file COPYING, which
11# you should have received as part of this distribution. The terms
12# are also available at https://curl.se/docs/copyright.html.
13#
14# You may opt to use, copy, modify, merge, publish, distribute and/or sell
15# copies of the Software, and permit persons to whom the Software is
16# furnished to do so, under the terms of the COPYING file.
17#
18# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY
19# KIND, either express or implied.
20#
21# SPDX-License-Identifier: curl
22#
23###########################################################################
24
25# This module contains miscellaneous functions needed in several parts of
26# the test suite.
27
28package testutil;
29
30use strict;
31use warnings;
32
33BEGIN {
34    use base qw(Exporter);
35
36    our @EXPORT = qw(
37        runclient
38        runclientoutput
39        setlogfunc
40        shell_quote
41        subbase64
42        subnewlines
43        subsha256base64file
44        substrippemfile
45    );
46
47    our @EXPORT_OK = qw(
48        clearlogs
49        logmsg
50    );
51}
52
53use Digest::SHA qw(sha256);
54use MIME::Base64;
55
56use globalconfig qw(
57    $torture
58    $verbose
59    $dev_null
60);
61
62my $logfunc;      # optional reference to function for logging
63my @logmessages;  # array holding logged messages
64
65
66#######################################################################
67# Log an informational message
68# If a log callback function was set in setlogfunc, it is called. If not,
69# then the log message is buffered until retrieved by clearlogs.
70#
71# logmsg must only be called by one of the runner_* entry points and functions
72# called by them, or else logs risk being lost, since those are the only
73# functions that know about and will return buffered logs.
74sub logmsg {
75    if(!scalar(@_)) {
76        return;
77    }
78    if(defined $logfunc) {
79        &$logfunc(@_);
80        return;
81    }
82    push @logmessages, @_;
83}
84
85#######################################################################
86# Set the function to use for logging
87sub setlogfunc {
88    ($logfunc)=@_;
89}
90
91#######################################################################
92# Clear the buffered log messages after returning them
93sub clearlogs {
94    my $loglines = join('', @logmessages);
95    undef @logmessages;
96    return $loglines;
97}
98
99
100#######################################################################
101
102sub includefile {
103    my ($f) = @_;
104    open(F, "<$f");
105    my @a = <F>;
106    close(F);
107    return join("", @a);
108}
109
110sub subbase64 {
111    my ($thing) = @_;
112
113    # cut out the base64 piece
114    while($$thing =~ s/%b64\[(.*?)\]b64%/%%B64%%/i) {
115        my $d = $1;
116        # encode %NN characters
117        $d =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
118        my $enc = encode_base64($d, "");
119        # put the result into there
120        $$thing =~ s/%%B64%%/$enc/;
121    }
122    # hex decode
123    while($$thing =~ s/%hex\[(.*?)\]hex%/%%HEX%%/i) {
124        # decode %NN characters
125        my $d = $1;
126        $d =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
127        $$thing =~ s/%%HEX%%/$d/;
128    }
129    # repeat
130    while($$thing =~ s/%repeat\[(\d+) x (.*?)\]%/%%REPEAT%%/i) {
131        # decode %NN characters
132        my ($d, $n) = ($2, $1);
133        $d =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
134        $n =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
135        my $all = $d x $n;
136        $$thing =~ s/%%REPEAT%%/$all/;
137    }
138
139    # include a file
140    $$thing =~ s/%include ([^%]*)%[\n\r]+/includefile($1)/ge;
141}
142
143my $prevupdate;  # module scope so it remembers the last value
144sub subnewlines {
145    my ($force, $thing) = @_;
146
147    if($force) {
148        # enforce CRLF newline
149        $$thing =~ s/\x0d*\x0a/\x0d\x0a/;
150        return;
151    }
152
153    if(($$thing =~ /^HTTP\/(1.1|1.0|2|3) [1-5][^\x0d]*\z/) ||
154       ($$thing =~ /^(GET|POST|PUT|DELETE) \S+ HTTP\/\d+(\.\d+)?/) ||
155       (($$thing =~ /^[a-z0-9_-]+: [^\x0d]*\z/i) &&
156        # skip curl error messages
157        ($$thing !~ /^curl: \(\d+\) /))) {
158        # enforce CRLF newline
159        $$thing =~ s/\x0d*\x0a/\x0d\x0a/;
160        $prevupdate = 1;
161    }
162    else {
163        if(($$thing =~ /^\n\z/) && $prevupdate) {
164            # if there's a blank link after a line we update, we hope it is
165            # the empty line following headers
166            $$thing =~ s/\x0a/\x0d\x0a/;
167        }
168        $prevupdate = 0;
169    }
170}
171
172#######################################################################
173# Run the application under test and return its return code
174#
175sub runclient {
176    my ($cmd)=@_;
177    my $ret = system($cmd);
178    print "CMD ($ret): $cmd\n" if($verbose && !$torture);
179    return $ret;
180
181# This is one way to test curl on a remote machine
182#    my $out = system("ssh $CLIENTIP cd \'$pwd\' \\; \'$cmd\'");
183#    sleep 2;    # time to allow the NFS server to be updated
184#    return $out;
185}
186
187#######################################################################
188# Run the application under test and return its stdout
189#
190sub runclientoutput {
191    my ($cmd)=@_;
192    return `$cmd 2>$dev_null`;
193
194# This is one way to test curl on a remote machine
195#    my @out = `ssh $CLIENTIP cd \'$pwd\' \\; \'$cmd\'`;
196#    sleep 2;    # time to allow the NFS server to be updated
197#    return @out;
198}
199
200
201#######################################################################
202# Quote an argument for passing safely to a Bourne shell
203# This does the same thing as String::ShellQuote but doesn't need a package.
204#
205sub shell_quote {
206    my ($s)=@_;
207    if($^O eq 'MSWin32') {
208        $s = '"' . $s . '"';
209    }
210    else {
211        if($s !~ m/^[-+=.,_\/:a-zA-Z0-9]+$/) {
212            # string contains a "dangerous" character--quote it
213            $s =~ s/'/'"'"'/g;
214            $s = "'" . $s . "'";
215        }
216    }
217    return $s;
218}
219
220sub get_sha256_base64 {
221    my ($file_path) = @_;
222    return encode_base64(sha256(do { local $/; open my $fh, '<:raw', $file_path or die $!; <$fh> }), "");
223}
224
225sub subsha256base64file {
226    my ($thing) = @_;
227
228    # SHA-256 base64
229    while ($$thing =~ s/%sha256b64file\[(.*?)\]sha256b64file%/%%SHA256B64FILE%%/i) {
230        my $file_path = $1;
231        $file_path =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
232        my $hash_b64 = get_sha256_base64($file_path);
233        $$thing =~ s/%%SHA256B64FILE%%/$hash_b64/;
234    }
235}
236
237sub get_file_content {
238    my ($file_path) = @_;
239    my $content = do { local $/; open my $fh, '<', $file_path or die $!; <$fh> };
240    $content =~ s/(^|-----END .*?-----[\r\n]?)(.*?)(-----BEGIN .*?-----|$)/$1$3/gs;
241    $content =~ s/\r\n/\n/g;
242    chomp($content);
243    return $content;
244}
245
246sub substrippemfile {
247    my ($thing) = @_;
248
249    # File content substitution
250    while ($$thing =~ s/%strippemfile\[(.*?)\]strippemfile%/%%FILE%%/i) {
251        my $file_path = $1;
252        $file_path =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
253        my $file_content = get_file_content($file_path);
254        $$thing =~ s/%%FILE%%/$file_content/;
255    }
256}
2571;
258