• Home
  • Line#
  • Scopes#
  • Navigate#
  • Raw
  • Download
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    # days
140    while($$thing =~ s/%days\[(.*?)\]/%%DAYS%%/i) {
141        # convert to now + given days in epoch seconds, align to a 60 second
142        # boundary. Then provide two alternatives.
143        my $now = time();
144        my $d = ($1 * 24 * 3600) + $now + 30;
145        $d = int($d/60) * 60;
146        my $d2 = $d + 60;
147        $$thing =~ s/%%DAYS%%/%alternatives[$d,$d2]/;
148    }
149
150    # include a file
151    $$thing =~ s/%include ([^%]*)%[\n\r]+/includefile($1)/ge;
152}
153
154my $prevupdate;  # module scope so it remembers the last value
155sub subnewlines {
156    my ($force, $thing) = @_;
157
158    if($force) {
159        # enforce CRLF newline
160        $$thing =~ s/\x0d*\x0a/\x0d\x0a/;
161        return;
162    }
163
164    if(($$thing =~ /^HTTP\/(1.1|1.0|2|3) [1-5][^\x0d]*\z/) ||
165       ($$thing =~ /^(GET|POST|PUT|DELETE) \S+ HTTP\/\d+(\.\d+)?/) ||
166       (($$thing =~ /^[a-z0-9_-]+: [^\x0d]*\z/i) &&
167        # skip curl error messages
168        ($$thing !~ /^curl: \(\d+\) /))) {
169        # enforce CRLF newline
170        $$thing =~ s/\x0d*\x0a/\x0d\x0a/;
171        $prevupdate = 1;
172    }
173    else {
174        if(($$thing =~ /^\n\z/) && $prevupdate) {
175            # if there's a blank link after a line we update, we hope it is
176            # the empty line following headers
177            $$thing =~ s/\x0a/\x0d\x0a/;
178        }
179        $prevupdate = 0;
180    }
181}
182
183#######################################################################
184# Run the application under test and return its return code
185#
186sub runclient {
187    my ($cmd)=@_;
188    my $ret = system($cmd);
189    print "CMD ($ret): $cmd\n" if($verbose && !$torture);
190    return $ret;
191
192# This is one way to test curl on a remote machine
193#    my $out = system("ssh $CLIENTIP cd \'$pwd\' \\; \'$cmd\'");
194#    sleep 2;    # time to allow the NFS server to be updated
195#    return $out;
196}
197
198#######################################################################
199# Run the application under test and return its stdout
200#
201sub runclientoutput {
202    my ($cmd)=@_;
203    return `$cmd 2>$dev_null`;
204
205# This is one way to test curl on a remote machine
206#    my @out = `ssh $CLIENTIP cd \'$pwd\' \\; \'$cmd\'`;
207#    sleep 2;    # time to allow the NFS server to be updated
208#    return @out;
209}
210
211
212#######################################################################
213# Quote an argument for passing safely to a Bourne shell
214# This does the same thing as String::ShellQuote but doesn't need a package.
215#
216sub shell_quote {
217    my ($s)=@_;
218    if($^O eq 'MSWin32') {
219        $s = '"' . $s . '"';
220    }
221    else {
222        if($s !~ m/^[-+=.,_\/:a-zA-Z0-9]+$/) {
223            # string contains a "dangerous" character--quote it
224            $s =~ s/'/'"'"'/g;
225            $s = "'" . $s . "'";
226        }
227    }
228    return $s;
229}
230
231sub get_sha256_base64 {
232    my ($file_path) = @_;
233    return encode_base64(sha256(do { local $/; open my $fh, '<:raw', $file_path or die $!; <$fh> }), "");
234}
235
236sub subsha256base64file {
237    my ($thing) = @_;
238
239    # SHA-256 base64
240    while ($$thing =~ s/%sha256b64file\[(.*?)\]sha256b64file%/%%SHA256B64FILE%%/i) {
241        my $file_path = $1;
242        $file_path =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
243        my $hash_b64 = get_sha256_base64($file_path);
244        $$thing =~ s/%%SHA256B64FILE%%/$hash_b64/;
245    }
246}
247
248sub get_file_content {
249    my ($file_path) = @_;
250    my $content = do { local $/; open my $fh, '<', $file_path or die $!; <$fh> };
251    $content =~ s/(^|-----END .*?-----[\r\n]?)(.*?)(-----BEGIN .*?-----|$)/$1$3/gs;
252    $content =~ s/\r\n/\n/g;
253    chomp($content);
254    return $content;
255}
256
257sub substrippemfile {
258    my ($thing) = @_;
259
260    # File content substitution
261    while ($$thing =~ s/%strippemfile\[(.*?)\]strippemfile%/%%FILE%%/i) {
262        my $file_path = $1;
263        $file_path =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
264        my $file_content = get_file_content($file_path);
265        $$thing =~ s/%%FILE%%/$file_content/;
266    }
267}
2681;
269