summaryrefslogtreecommitdiff
path: root/tests/convsrctest.pl
blob: 11237448f6325ed1f5d81a7fe931879c3735e6e2 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
#!/usr/bin/env perl
#***************************************************************************
#                                  _   _ ____  _
#  Project                     ___| | | |  _ \| |
#                             / __| | | | |_) | |
#                            | (__| |_| |  _ <| |___
#                             \___|\___/|_| \_\_____|
#
# Copyright (C) 1998 - 2011, 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.haxx.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.
#
#***************************************************************************

#=======================================================================
# Read a test definition which exercises curl's --libcurl option.
# Generate either compilable source code for a new test tool,
# or a new test definition which runs the tool and expects the
# same output.
# This should verify that the --libcurl code really does perform
# the same actions as the original curl invocation.
#-----------------------------------------------------------------------
# The output of curl's --libcurl option differs in several ways from
# the code needed to integrate with the test tool environment:
# - #include "test.h"
# - no call of curl_global_init & curl_global_cleanup
# - main() function vs. test() function
# - no checking of curl_easy_setopt calls vs. test_setopt wrapper
# - handling of stdout
# - variable names ret & hnd vs. res & curl
# - URL as literal string vs. passed as argument
#=======================================================================
use strict;
require "getpart.pm";

# Boilerplate code for test tool
my $head =
'#include "test.h"
#include "memdebug.h"

int test(char *URL)
{
  CURLcode res;
  CURL *curl;
';
# Other declarations from --libcurl come here
# e.g. curl_slist
my $init =
'
  if (curl_global_init(CURL_GLOBAL_ALL) != CURLE_OK) {
    fprintf(stderr, "curl_global_init() failed\n");
    return TEST_ERR_MAJOR_BAD;
  }

  if ((curl = curl_easy_init()) == NULL) {
    fprintf(stderr, "curl_easy_init() failed\n");
    curl_global_cleanup();
    return TEST_ERR_MAJOR_BAD;
  }
';
# Option setting, perform and cleanup come here
my $exit =
'  curl_global_cleanup();

  return (int)res;
}
';

my $myname = leaf($0);
sub usage {die "Usage: $myname -c|-test=num testfile\n";}

sub main {
    @ARGV == 2
        or usage;
    my($opt,$testfile) = @ARGV;

    if(loadtest($testfile)) {
        die "$myname: $testfile doesn't look like a test case\n";
    }

    my $comment = sprintf("DO NOT EDIT - generated from %s by %s",
                          leaf($testfile), $myname);
    if($opt eq '-c') {
        generate_c($comment);
    }
    elsif(my($num) = $opt =~ /^-test=(\d+)$/) {
        generate_test($comment, $num);
    }
    else {
        usage;
    }
}

sub generate_c {
    my($comment) = @_;
    # Fetch the generated code, which is the output file checked by
    # the old test.
    my @libcurl = getpart("verify", "file")
        or die "$myname: no <verify><file> section found\n";

    # Mangle the code into a suitable form for a test tool.
    # We want to extract the important parts (declarations,
    # URL, setopt calls, cleanup code) from the --libcurl
    # boilerplate and insert them into a new boilerplate.
    my(@decl,@code);
    # First URL passed in as argument, others as global
    my @urlvars = ('URL', 'libtest_arg2', 'libtest_arg3');
    my($seen_main,$seen_setopt,$seen_return);
    foreach (@libcurl) {
        # Check state changes first (even though it
        # duplicates some matches) so that the other tests
        # are in a logical order).
        if(/^int main/) {
            $seen_main = 1;
        }
        if($seen_main and /curl_easy_setopt/) {
            # Don't match 'curl_easy_setopt' in comment!
            $seen_setopt = 1;
        }
        if(/^\s*return/) {
            $seen_return = 1;
        }

        # Now filter the code according to purpose
        if(! $seen_main) {
            next;
        }
        elsif(! $seen_setopt) {
            if(/^\s*(int main|\{|CURLcode |CURL |hnd = curl_easy_init)/) {
                # Initialisations handled by boilerplate
                next;
            }
            else {
                push @decl, $_;
            }
        }
        elsif(! $seen_return) {
            if(/CURLOPT_URL/) {
                # URL is passed in as argument or by global
		my $var = shift @urlvars;
                s/\"[^\"]*\"/$var/;
            }
	    s/\bhnd\b/curl/;
            # Convert to macro wrapper
            s/curl_easy_setopt/test_setopt/;
	    if(/curl_easy_perform/) {
		s/\bret\b/res/;
		push @code, $_;
		push @code, "test_cleanup:\n";
	    }
	    else {
		push @code, $_;
	    }
        }
    }

    print ("/* $comment */\n",
           $head,
           @decl,
           $init,
           @code,
           $exit);
}

# Read the original test data file and transform it
# - add a "DO NOT EDIT comment"
# - replace CURLOPT_URL string with URL variable
# - remove <verify><file> section (was the --libcurl output)
# - insert a <client><tool> section with our new C program name
# - replace <client><command> section with the URL
sub generate_test {
    my($comment,$newnumber) = @_;
    my @libcurl = getpart("verify", "file")
        or die "$myname: no <verify><file> section found\n";
    # Scan the --libcurl code to find the URL used.
    my $url;
    foreach (@libcurl) {
        if(my($u) = /CURLOPT_URL, \"([^\"]*)\"/) {
            $url = $u;
        }
    }
    die "$myname: CURLOPT_URL not found\n"
        unless defined $url;

    # Traverse the pseudo-XML transforming as required
    my @new;
    my(@path,$path,$skip);
    foreach (getall()) {
        if(my($end) = /\s*<(\/?)testcase>/) {
            push @new, $_;
            push @new, "# $comment\n"
                unless $end;
        }
        elsif(my($tag) = /^\s*<(\w+)/) {
            push @path, $tag;
            $path = join '/', @path;
            if($path eq 'verify/file') {
                $skip = 1;
            }
            push @new, $_
                unless $skip;
            if($path eq 'client') {
                push @new, ("<tool>\n",
                            "lib$newnumber\n",
                            "</tool>\n");
            }
            elsif($path eq 'client/command') {
                push @new, sh_quote($url)."\n";
            }
        }
        elsif(my($etag) = /^\s*<\/(\w+)/) {
            my $tag = pop @path;
            die "$myname: mismatched </$etag>\n"
                unless $tag eq $etag;
            push @new, $_
                unless $skip;
            $skip --
                if $path eq 'verify/file';
            $path = join '/', @path;
        }
        else {
            if($path eq 'client/command') {
                # Replaced above
            }
            else {
                push @new, $_
                    unless $skip;
            }
        }
    }
    print @new;
}

sub leaf {
    # Works for POSIX filenames
    (my $path = shift) =~ s!.*/!!;
    return $path;
}

sub sh_quote {
    my $word = shift;
    $word =~ s/[\$\"\'\\]/\\$&/g;
    return '"' . $word . '"';
}

main;