| #! /usr/bin/env perl |
| # Copyright 2026 The OpenSSL Project Authors. All Rights Reserved. |
| # |
| # Licensed under the Apache License 2.0 (the "License"). You may not use |
| # this file except in compliance with the License. You can obtain a copy |
| # in the file LICENSE in the source distribution or at |
| # https://www.openssl.org/source/license.html |
| |
| use strict; |
| use warnings; |
| |
| use Getopt::Long; |
| use File::Spec::Functions qw(catdir catfile file_name_is_absolute rel2abs); |
| use File::Basename qw(dirname); |
| |
| my $build_info_file; |
| my $target; |
| my @extra_includes; |
| my $output_file; |
| my $mode = 'both'; |
| my $cc; |
| my $use_system = 1; |
| my $verbose = 0; |
| my $help = 0; |
| |
| GetOptions('build-info=s' => \$build_info_file, |
| 'target=s' => \$target, |
| 'include=s' => \@extra_includes, |
| 'output=s' => \$output_file, |
| 'mode=s' => \$mode, |
| 'cc=s' => \$cc, |
| 'system!' => \$use_system, |
| 'verbose' => \$verbose, |
| 'help' => \$help) |
| or die "Error in command line arguments\n"; |
| |
| $cc = $ENV{CC} || 'cc' unless defined $cc; |
| |
| sub help |
| { |
| print STDERR <<"EOF"; |
| mkwraps.pl [options] |
| |
| Options: |
| |
| --build-info FILE build.info file containing a WRAP[<target>] entry. |
| |
| --target NAME Test program name used as the WRAP[]/INCLUDE[] key. |
| |
| --include DIR Extra include directory to search. Cumulative. |
| |
| --output FILE Output file. Defaults to stdout. |
| |
| --mode MODE What to emit: 'wraps', 'expects' or 'both'. |
| Defaults to 'both'. |
| |
| --cc NAME C compiler used to discover the default system |
| include search paths. Defaults to \$CC or 'cc'. |
| |
| --no-system Do not fall back to the compiler's default system |
| include directories. By default, functions not |
| found in the project headers (typically libc/POSIX |
| functions) are looked up there. |
| |
| --verbose Print progress to stderr. |
| |
| --help Show this help text. |
| |
| For each function name listed in WRAP[<target>], the script searches |
| the headers (*.h) under each directory in INCLUDE[<target>], resolved |
| relative to the directory containing the build.info file, plus any |
| extra --include directories. The search recurses into subdirectories, |
| mirroring how the compiler resolves <subdir/header.h> via -I flags. |
| The first header containing a matching declaration provides the |
| prototype. |
| |
| Functions not found in those directories (typically system functions |
| such as read() or socket()) are then looked up under the compiler's |
| default include search paths, as reported by the C compiler. System |
| prototypes are emitted with angle-bracket #include directives. Use |
| --no-system to disable this fallback. |
| |
| The output is meant as a stub for further editing. Custom logic |
| (out-parameters, variadic forwarding, side effects on globals) still |
| needs to be written manually, and the emitted #include directives may |
| need to be adjusted (e.g. to add internal headers for opaque types). |
| Long lines in the output are not wrapped. |
| EOF |
| } |
| |
| if ($help) { |
| &help(); |
| exit 0; |
| } |
| |
| unless (defined $build_info_file && defined $target) { |
| &help(); |
| exit 1; |
| } |
| |
| die "--mode must be 'wraps', 'expects' or 'both'\n" |
| unless $mode =~ /^(?:wraps|expects|both)$/; |
| |
| my @t = localtime(); |
| my $YEAR = $t[5] + 1900; |
| |
| # Parse the build.info file. We are only interested in two directives, |
| # WRAP[<target>] and INCLUDE[<target>], either of which may be split |
| # across several physical lines using the usual backslash continuation. |
| |
| my @wraps; |
| my @includes; |
| |
| open(IN, "<$build_info_file") || die "Can't open $build_info_file, $!,"; |
| my $content = do { local $/; <IN> }; |
| close IN; |
| |
| $content =~ s/\\\n\s*/ /g; |
| |
| foreach (split /\n/, $content) { |
| next if /^\s*#/ || /^\s*$/; |
| if (/^\s*WRAP\[\Q$target\E\]\s*=\s*(.+?)\s*$/) { |
| push @wraps, split(/\s+/, $1); |
| } elsif (/^\s*INCLUDE\[\Q$target\E\]\s*=\s*(.+?)\s*$/) { |
| push @includes, split(/\s+/, $1); |
| } |
| } |
| |
| die "No WRAP[$target] entry found in $build_info_file\n" unless @wraps; |
| |
| my $bi_dir = dirname($build_info_file); |
| my @search_dirs; |
| foreach my $inc (@includes, @extra_includes) { |
| push @search_dirs, |
| file_name_is_absolute($inc) ? $inc : rel2abs(catdir($bi_dir, $inc)); |
| } |
| |
| print STDERR "Wraps:\n ", join("\n ", @wraps), "\n" if $verbose; |
| print STDERR "Search dirs:\n ", join("\n ", @search_dirs), "\n" if $verbose; |
| |
| # Walk all search directories and get them in the order that level ones are |
| # first followed by subdirs so if there are nested includes, we get the |
| # shortest ones first searched. Each base is a [dir, is_system] pair and the |
| # is_system flag is carried onto every header found beneath it, so that system |
| # prototypes can later be emitted with angle-bracket includes. |
| sub find_headers |
| { |
| my (@bases) = @_; |
| my @found; |
| my @queue = map { [$_->[0], '', $_->[1]] } @bases; |
| |
| while (@queue) { |
| my @next; |
| my @level_files; |
| foreach my $entry (@queue) { |
| my ($dir, $rel, $sys) = @$entry; |
| next unless -d $dir; |
| opendir(my $dh, $dir) or next; |
| foreach my $name (readdir $dh) { |
| next if $name =~ /^\./; |
| my $full = catfile($dir, $name); |
| my $newrel = $rel eq '' ? $name : "$rel/$name"; |
| if (-d $full) { |
| push @next, [$full, $newrel, $sys]; |
| } elsif (-f $full && $name =~ /\.h$/) { |
| push @level_files, [$full, $newrel, $sys]; |
| } |
| } |
| closedir $dh; |
| } |
| # Stable sort within a level for deterministic ordering. |
| push @found, sort { $a->[1] cmp $b->[1] } @level_files; |
| @queue = sort { $a->[1] cmp $b->[1] } @next; |
| } |
| return @found; |
| } |
| |
| # Ask the C compiler for its default "#include <...>" search paths. Returns |
| # the list of existing directories, in search order. Empty on failure. |
| sub system_include_dirs |
| { |
| my ($compiler) = @_; |
| my $out = `$compiler -xc -E -v /dev/null 2>&1`; |
| return () unless defined $out |
| && $out =~ /search starts here:(.*?)End of search list\./s; |
| my @dirs; |
| foreach my $line (split /\n/, $1) { |
| $line =~ s/^\s+//; |
| $line =~ s/\s+$//; |
| # clang annotates framework directories; skip those. |
| next if $line eq '' || $line =~ /\(framework directory\)$/; |
| push @dirs, $line if -d $line; |
| } |
| return @dirs; |
| } |
| |
| # Project headers are searched first (with is_system = 0) so that a project |
| # declaration always wins over a colliding system one. The system headers are |
| # appended lazily, only if some function is not found in the project headers. |
| my @search_files = find_headers(map { [$_, 0] } @search_dirs); |
| my $system_loaded = 0; |
| |
| sub load_system_headers |
| { |
| return if $system_loaded; |
| $system_loaded = 1; |
| return unless $use_system; |
| my @sys_dirs = system_include_dirs($cc); |
| unless (@sys_dirs) { |
| warn "WARNING: could not determine system include dirs from '$cc'\n"; |
| return; |
| } |
| print STDERR "System include dirs:\n ", join("\n ", @sys_dirs), "\n" |
| if $verbose; |
| push @search_files, find_headers(map { [$_, 1] } @sys_dirs); |
| } |
| |
| my %file_cache; |
| |
| sub strip_c_comments |
| { |
| my $s = shift; |
| $s =~ s{/\*.*?\*/}{}sg; |
| $s =~ s{//[^\n]*}{}g; |
| return $s; |
| } |
| |
| # Drop attribute and qualifier macros that should not appear in the |
| # emitted return type. |
| sub strip_attribute_macros |
| { |
| my $s = shift; |
| foreach my $kw (qw(__owur __pure __malloc__ ossl_inline static inline |
| extern OSSL_DEPRECATEDIN_0_9_8 |
| OSSL_DEPRECATEDIN_1_0_0 OSSL_DEPRECATEDIN_1_1_0 |
| OSSL_DEPRECATEDIN_3_0 OSSL_DEPRECATEDIN_3_1 |
| OSSL_DEPRECATEDIN_3_2 OSSL_DEPRECATEDIN_3_3 |
| OSSL_DEPRECATEDIN_3_4 OSSL_DEPRECATEDIN_3_5)) { |
| $s =~ s/\b\Q$kw\E\b//g; |
| } |
| $s =~ s/\b__attribute__\s*\(\([^)]*\)\)//g; |
| $s =~ s/\s+/ /g; |
| $s =~ s/^\s+|\s+$//g; |
| return $s; |
| } |
| |
| # Consume reserved-namespace decorations between a declaration's closing |
| # parenthesis and its semicolon, e.g. glibc's __THROW, __wur or |
| # __attr_access ((...)). Only __-prefixed tokens (with an optional balanced |
| # argument list) are eaten, so a genuine following declaration is left alone. |
| sub skip_trailing_attributes |
| { |
| my $s = shift; |
| while (1) { |
| $s =~ s/^\s+//; |
| last unless $s =~ /^(__\w+)/; |
| $s = substr($s, length($1)); |
| $s =~ s/^\s+//; |
| if ($s =~ /^\(/) { |
| my $depth = 0; |
| my $i = 0; |
| while ($i < length($s)) { |
| my $c = substr($s, $i, 1); |
| $depth++ if $c eq '('; |
| $depth-- if $c eq ')'; |
| $i++; |
| last if $depth == 0; |
| } |
| return $s if $depth != 0; |
| $s = substr($s, $i); |
| } |
| } |
| return $s; |
| } |
| |
| sub find_function_decl |
| { |
| my ($funcname) = @_; |
| |
| foreach my $entry (@search_files) { |
| my ($file, $relpath, $is_system) = @$entry; |
| unless (exists $file_cache{$file}) { |
| my $text = ''; |
| if (open(my $fh, '<', $file)) { |
| local $/; |
| $text = <$fh>; |
| close $fh; |
| } |
| $file_cache{$file} = strip_c_comments($text); |
| } |
| my $text = $file_cache{$file}; |
| |
| while ($text =~ /\b\Q$funcname\E\s*\(/g) { |
| my $name_start = $-[0]; |
| my $paren_start = pos($text); |
| |
| # Find matching closing paren, respecting nesting. |
| my $depth = 1; |
| my $cursor = $paren_start; |
| while ($cursor < length($text) && $depth > 0) { |
| my $c = substr($text, $cursor, 1); |
| $depth++ if $c eq '('; |
| $depth-- if $c eq ')'; |
| $cursor++; |
| } |
| next if $depth != 0; |
| my $params_str = |
| substr($text, $paren_start, $cursor - $paren_start - 1); |
| |
| # What follows must be ; for this to be a declaration, possibly |
| # after trailing attribute macros (__THROW, __wur, ...). |
| my $after = substr($text, $cursor); |
| $after = skip_trailing_attributes($after); |
| next unless $after =~ /^;/; |
| |
| # Anything since the previous statement terminator is the return |
| # type expression. |
| my $pre = substr($text, 0, $name_start); |
| $pre =~ s/\s+$//; |
| my $ret_start = 0; |
| $ret_start = $-[2] if $pre =~ /([;}\n])([^;}\n]*)$/s; |
| my $rettype = strip_attribute_macros(substr($pre, $ret_start)); |
| |
| # Normalise to forward slashes for use as an #include path. |
| my $include_path = $relpath; |
| $include_path =~ s|\\|/|g; |
| |
| return { name => $funcname, |
| rettype => $rettype, |
| params => $params_str, |
| file => $file, |
| include_path => $include_path, |
| system => $is_system }; |
| } |
| } |
| return undef; |
| } |
| |
| # Split a parameter list on top-level commas, respecting parentheses |
| sub split_params |
| { |
| my $str = shift; |
| $str =~ s/^\s+|\s+$//g; |
| return () if $str eq '' || $str eq 'void'; |
| |
| my @parts; |
| my $current = ''; |
| my $depth = 0; |
| foreach my $c (split //, $str) { |
| if ($c eq '(') { |
| $depth++; |
| $current .= $c; |
| } elsif ($c eq ')') { |
| $depth--; |
| $current .= $c; |
| } elsif ($c eq ',' && $depth == 0) { |
| push @parts, $current; |
| $current = ''; |
| } else { |
| $current .= $c; |
| } |
| } |
| push @parts, $current if $current ne ''; |
| foreach my $p (@parts) { |
| $p =~ s/^\s+|\s+$//g; |
| } |
| return @parts; |
| } |
| |
| sub parse_param |
| { |
| my $param = shift; |
| return { type => '', name => '', is_variadic => 1, is_ptr => 0 } |
| if $param eq '...'; |
| |
| # Drop the restrict qualifier; it plays no role in a mock signature. |
| $param =~ s/\b(?:__restrict(?:__)?|restrict)\b//g; |
| |
| # Reduce TYPE NAME[size] to TYPE * NAME for our purposes. |
| my $is_array = 0; |
| $is_array = 1 if $param =~ s/\[\s*[^\]]*\s*\]\s*$//; |
| |
| my ($type, $name); |
| if ($param =~ /^(.*?)([A-Za-z_]\w*)\s*$/) { |
| $type = $1; |
| $name = $2; |
| $type =~ s/\s+$//; |
| } else { |
| $type = $param; |
| $name = ''; |
| } |
| |
| # System headers name parameters in the reserved __ namespace; strip the |
| # leading underscores so the generated wrap uses ordinary local names. |
| $name =~ s/^_+//; |
| |
| return { type => $type, |
| name => $name, |
| is_ptr => (($type =~ /\*/) || $is_array) ? 1 : 0, |
| is_variadic => 0, |
| is_array => $is_array }; |
| } |
| |
| sub is_void_type |
| { |
| my $t = shift; |
| $t =~ s/^\s+|\s+$//g; |
| $t =~ s/\s+/ /g; |
| return $t eq 'void'; |
| } |
| |
| sub is_ptr_type { return $_[0] =~ /\*/; } |
| |
| # Look up each WRAP entry's signature. Functions we cannot find are |
| # skipped with a warning rather than aborting. |
| my @signatures; |
| my @found_includes; |
| my %seen_include; |
| foreach my $func (@wraps) { |
| my $info = find_function_decl($func); |
| if (!defined $info && !$system_loaded) { |
| # Not in the project headers: pull in the system ones and retry. |
| load_system_headers(); |
| $info = find_function_decl($func); |
| } |
| unless (defined $info) { |
| warn "WARNING: $func: declaration not found in any include dir\n"; |
| next; |
| } |
| |
| my @params = map { parse_param($_) } split_params($info->{params}); |
| |
| my $idx = 0; |
| foreach my $p (@params) { |
| next if $p->{is_variadic}; |
| $p->{name} = "arg$idx" if $p->{name} eq ''; |
| $idx++; |
| } |
| |
| push @signatures, { name => $func, |
| rettype => $info->{rettype}, |
| params => \@params }; |
| |
| unless ($seen_include{$info->{include_path}}) { |
| $seen_include{$info->{include_path}} = 1; |
| push @found_includes, { path => $info->{include_path}, |
| system => $info->{system} }; |
| } |
| print STDERR " found $func in $info->{file}\n" if $verbose; |
| } |
| |
| die "No declarations found, nothing to emit\n" unless @signatures; |
| |
| my $out_fh; |
| if (defined $output_file) { |
| open($out_fh, '>', $output_file) or die "$output_file: $!\n"; |
| } else { |
| $out_fh = \*STDOUT; |
| } |
| |
| print $out_fh <<"EOF"; |
| /* |
| * Copyright $YEAR The OpenSSL Project Authors. All Rights Reserved. |
| * |
| * Licensed under the Apache License 2.0 (the "License"). You may not use |
| * this file except in compliance with the License. You can obtain a copy |
| * in the file LICENSE in the source distribution or at |
| * https://www.openssl.org/source/license.html |
| */ |
| |
| EOF |
| |
| print $out_fh "#include <cmocka.h>\n"; |
| print $out_fh "\n"; |
| if (@found_includes) { |
| my @angle; |
| my @local; |
| foreach my $inc (sort { $a->{path} cmp $b->{path} } @found_includes) { |
| if ($inc->{system} || $inc->{path} =~ m|^openssl/|) { |
| push @angle, $inc->{path}; |
| } else { |
| push @local, $inc->{path}; |
| } |
| } |
| foreach my $inc (@angle) { |
| print $out_fh "#include <$inc>\n"; |
| } |
| print $out_fh "\n" if @angle && @local; |
| foreach my $inc (@local) { |
| print $out_fh "#include \"$inc\"\n"; |
| } |
| print $out_fh "\n"; |
| } |
| |
| if ($mode eq 'wraps' || $mode eq 'both') { |
| print $out_fh "/* wraps */\n\n"; |
| foreach my $f (@signatures) { |
| print $out_fh format_signature($f->{rettype}, |
| "__wrap_$f->{name}", |
| $f->{params}), ";\n"; |
| } |
| print $out_fh "\n"; |
| |
| foreach my $f (@signatures) { |
| emit_wrap($out_fh, $f); |
| print $out_fh "\n"; |
| } |
| } |
| |
| if ($mode eq 'expects' || $mode eq 'both') { |
| print $out_fh "/* expectations */\n\n"; |
| foreach my $f (@signatures) { |
| emit_expect($out_fh, $f); |
| print $out_fh "\n"; |
| } |
| } |
| |
| close $out_fh if defined $output_file; |
| |
| exit 0; |
| |
| sub format_decl |
| { |
| my ($type, $name) = @_; |
| return $type =~ /\*$/ ? "$type$name" : "$type $name"; |
| } |
| |
| sub format_param |
| { |
| my $p = shift; |
| return '...' if $p->{is_variadic}; |
| return format_decl($p->{type}, $p->{name}); |
| } |
| |
| sub format_signature |
| { |
| my ($rettype, $name, $params) = @_; |
| my $param_str = @$params |
| ? join(', ', map { format_param($_) } @$params) |
| : 'void'; |
| return format_decl($rettype, $name) . "($param_str)"; |
| } |
| |
| sub emit_wrap |
| { |
| my ($fh, $f) = @_; |
| print $fh format_signature($f->{rettype}, "__wrap_$f->{name}", |
| $f->{params}), "\n{\n"; |
| print $fh " function_called();\n"; |
| foreach my $p (@{$f->{params}}) { |
| next if $p->{is_variadic}; |
| if ($p->{is_ptr}) { |
| print $fh " check_expected_ptr($p->{name});\n"; |
| } else { |
| print $fh " check_expected($p->{name});\n"; |
| } |
| } |
| if ( ! is_void_type($f->{rettype})) { |
| if (is_ptr_type($f->{rettype})) { |
| print $fh "\n return mock_ptr_type($f->{rettype});\n"; |
| } else { |
| print $fh "\n return mock_type($f->{rettype});\n"; |
| } |
| } |
| print $fh "}\n"; |
| } |
| |
| sub emit_expect |
| { |
| my ($fh, $f) = @_; |
| my $name = $f->{name}; |
| my @params = @{$f->{params}}; |
| |
| my @sig_parts; |
| foreach my $p (@params) { |
| next if $p->{is_variadic}; |
| push @sig_parts, format_param($p); |
| } |
| |
| my $needs_rc = !is_void_type($f->{rettype}); |
| push @sig_parts, format_decl($f->{rettype}, 'rc') if $needs_rc; |
| |
| my $param_str = @sig_parts ? join(', ', @sig_parts) : 'void'; |
| print $fh "static void expect_$name($param_str)\n{\n"; |
| print $fh " expect_function_call(__wrap_$name);\n"; |
| foreach my $p (@params) { |
| next if $p->{is_variadic}; |
| print $fh " expect_value(__wrap_$name, $p->{name}, $p->{name});\n"; |
| } |
| print $fh " will_return(__wrap_$name, rc);\n" if $needs_rc; |
| print $fh "}\n"; |
| } |