mkdef.pl

一个用于点对点传输加密的工具包源码

		my $algs;
		my $plays;

		foreach (split /;/, $def) {
			my $s; my $k = "FUNCTION"; my $p; my $a;
			s/^[\n\s]*//g;
			s/[\n\s]*$//g;
			next if(/\#undef/);
			next if(/typedef\W/);
			next if(/\#define/);

			if (/^\#INFO:([^:]*):(.*)$/) {
				$plats = $1;
				$algs = $2;
				next;
			} elsif (/^\s*OPENSSL_EXTERN\s.*?(\w+)(\[[0-9]*\])*\s*$/) {
				$s = $1;
				$k = "VARIABLE";
			} elsif (/\(\*(\w*)\([^\)]+/) {
				$s = $1;
			} elsif (/\w+\W+(\w+)\W*\(\s*\)$/s) {
				# K&R C
				next;
			} elsif (/\w+\W+\w+\W*\(.*\)$/s) {
				while (not /\(\)$/s) {
					s/[^\(\)]*\)$/\)/s;
					s/\([^\(\)]*\)\)$/\)/s;
				}
				s/\(void\)//;
				/(\w+)\W*\(\)/s;
				$s = $1;
			} elsif (/\(/ and not (/=/)) {
				print STDERR "File $file: cannot parse: $_;\n";
				next;
			} else {
				next;
			}

			$syms{$s} = 1;
			$kind{$s} = $k;

			$p = $plats;
			$a = $algs;
			$a .= ",BF" if($s =~ /EVP_bf/);
			$a .= ",CAST" if($s =~ /EVP_cast/);
			$a .= ",DES" if($s =~ /EVP_des/);
			$a .= ",DSA" if($s =~ /EVP_dss/);
			$a .= ",IDEA" if($s =~ /EVP_idea/);
			$a .= ",MD2" if($s =~ /EVP_md2/);
			$a .= ",MD4" if($s =~ /EVP_md4/);
			$a .= ",MD5" if($s =~ /EVP_md5/);
			$a .= ",RC2" if($s =~ /EVP_rc2/);
			$a .= ",RC4" if($s =~ /EVP_rc4/);
			$a .= ",RC5" if($s =~ /EVP_rc5/);
			$a .= ",RIPEMD" if($s =~ /EVP_ripemd/);
			$a .= ",SHA" if($s =~ /EVP_sha/);
			$a .= ",RSA" if($s =~ /EVP_(Open|Seal)(Final|Init)/);
			$a .= ",RSA" if($s =~ /PEM_Seal(Final|Init|Update)/);
			$a .= ",RSA" if($s =~ /RSAPrivateKey/);
			$a .= ",RSA" if($s =~ /SSLv23?_((client|server)_)?method/);

			$platform{$s} .= ','.$p;
			$algorithm{$s} .= ','.$a;

			if (defined($rename{$s})) {
				(my $r, my $p) = split(/:/,$rename{$s});
				my @ip = map { /^!(.*)$/ ? $1 : "!".$_ } split /,/, $p;
				$syms{$r} = 1;
				$kind{$r} = $kind{$s}."(".$s.")";
				$algorithm{$r} = $algorithm{$s};
				$platform{$r} = $platform{$s}.",".$p;
				$platform{$s} .= ','.join(',', @ip).','.join(',', @ip);
			}
		}
	}

	# Prune the returned symbols

	$platform{"crypt"} .= ",!PERL5,!__FreeBSD__,!NeXT";

        delete $syms{"SSL_add_dir_cert_subjects_to_stack"};
        delete $syms{"bn_dump1"};

	$platform{"BIO_s_file_internal"} .= ",WIN16";
	$platform{"BIO_new_file_internal"} .= ",WIN16";
	$platform{"BIO_new_fp_internal"} .= ",WIN16";

	$platform{"BIO_s_file"} .= ",!WIN16";
	$platform{"BIO_new_file"} .= ",!WIN16";
	$platform{"BIO_new_fp"} .= ",!WIN16";

	$platform{"BIO_s_log"} .= ",!WIN32,!WIN16,!macintosh";

	if(exists $syms{"ERR_load_CRYPTO_strings"}) {
		$platform{"ERR_load_CRYPTO_strings"} .= ",!VMS,!WIN16";
		$syms{"ERR_load_CRYPTOlib_strings"} = 1;
		$platform{"ERR_load_CRYPTOlib_strings"} .= ",VMS,WIN16";
	}

	# Info we know about

	$platform{"RSA_PKCS1_RSAref"} = "RSAREF";
	$algorithm{"RSA_PKCS1_RSAref"} = "RSA";

	push @ret, map { $_."\\".&info_string($_,"EXIST",
					      $platform{$_},
					      $kind{$_},
					      $algorithm{$_}) } keys %syms;

	return(@ret);
}

sub info_string {
	(my $symbol, my $exist, my $platforms, my $kind, my $algorithms) = @_;

	my %a = defined($algorithms) ?
	    map { $_ => 1 } split /,/, $algorithms : ();
	my $pl = defined($platforms) ? $platforms : "";
	my %p = map { $_ => 0 } split /,/, $pl;
	my $k = defined($kind) ? $kind : "FUNCTION";
	my $ret;

	# We do this, because if there's code like the following, it really
	# means the function exists in all cases and should therefore be
	# everywhere.  By increasing and decreasing, we may attain 0:
	#
	# ifndef WIN16
	#    int foo();
	# else
	#    int _fat foo();
	# endif
	foreach $platform (split /,/, $pl) {
		if ($platform =~ /^!(.*)$/) {
			$p{$1}--;
		} else {
			$p{$platform}++;
		}
	}
	foreach $platform (keys %p) {
		if ($p{$platform} == 0) { delete $p{$platform}; }
	}

	delete $p{""};
	delete $a{""};

	$ret = $exist;
	$ret .= ":".join(',',map { $p{$_} < 0 ? "!".$_ : $_ } keys %p);
	$ret .= ":".$k;
	$ret .= ":".join(',',keys %a);
	return $ret;
}

sub maybe_add_info {
	(my $name, *nums, my @symbols) = @_;
	my $sym;
	my $new_info = 0;

	print STDERR "Updating $name info\n";
	foreach $sym (@symbols) {
		(my $s, my $i) = split /\\/, $sym;
		$i =~ s/^(.*?:.*?:\w+)(\(\w+\))?/$1/;
		if (defined($nums{$s})) {
			(my $n, my $dummy) = split /\\/, $nums{$s};
			if (!defined($dummy) || $i ne $dummy) {
				$nums{$s} = $n."\\".$i;
				$new_info++;
				#print STDERR "DEBUG: maybe_add_info for $s: \"$dummy\" => \"$i\"\n";
			}
		}
	}
	if ($new_info) {
		print STDERR "$new_info old symbols got an info update\n";
		if (!$do_rewrite) {
			print STDERR "You should do a rewrite to fix this.\n";
		}
	} else {
		print STDERR "No old symbols needed info update\n";
	}
}

sub print_test_file
{
	(*OUT,my $name,*nums,my @symbols)=@_;
	my $n = 1; my @e; my @r;
	my $sym; my $prev = ""; my $prefSSLeay;

	(@e)=grep(/^SSLeay\\.*?:.*?:FUNCTION/,@symbols);
	(@r)=grep(/^\w+\\.*?:.*?:FUNCTION/ && !/^SSLeay\\.*?:.*?:FUNCTION/,@symbols);
	@symbols=((sort @e),(sort @r));

	foreach $sym (@symbols) {
		(my $s, my $i) = $sym =~ /^(.*?)\\(.*)$/;
		if ($s ne $prev) {
			if (!defined($nums{$sym})) {
				printf STDERR "Warning: $sym does not have a number assigned\n"
						if(!$do_update);
			} else {
				$n=$nums{$s};
				print OUT "\t$s();\n";
			}
		}
		$prev = $s;	# To avoid duplicates...
	}
}

sub print_def_file
{
	(*OUT,my $name,*nums,my @symbols)=@_;
	my $n = 1; my @e; my @r;

	if ($W32)
		{ $name.="32"; }
	else
		{ $name.="16"; }

	print OUT <<"EOF";
;
; Definition file for the DLL version of the $name library from OpenSSL
;

LIBRARY         $name

DESCRIPTION     'OpenSSL $name - http://www.openssl.org/'

EOF

	if (!$W32) {
		print <<"EOF";
CODE            PRELOAD MOVEABLE
DATA            PRELOAD MOVEABLE SINGLE

EXETYPE		WINDOWS

HEAPSIZE	4096
STACKSIZE	8192

EOF
	}

	print "EXPORTS\n";

	(@e)=grep(/^SSLeay\\.*?:.*?:FUNCTION/,@symbols);
	(@r)=grep(/^\w+\\.*?:.*?:FUNCTION/ && !/^SSLeay\\.*?:.*?:FUNCTION/,@symbols);
	@symbols=((sort @e),(sort @r));


	foreach $sym (@symbols) {
		(my $s, my $i) = $sym =~ /^(.*?)\\(.*)$/;
		if (!defined($nums{$s})) {
			printf STDERR "Warning: $s does not have a number assigned\n"
					if(!$do_update);
		} else {
			(my $n, my $i) = split /\\/, $nums{$s};
			my %pf = ();
			my @p = split(/,/, ($i =~ /^.*?:(.*?):/,$1));
			# @p_purged must contain hardware platforms only
			my @p_purged = ();
			foreach $ptmp (@p) {
				next if $ptmp =~ /^!?RSAREF$/;
				push @p_purged, $ptmp;
			}
			my $negatives = !!grep(/^!/,@p);
			# It is very important to check NT before W32
			if ((($NT && (!@p_purged
				      || (!$negatives && grep(/^WINNT$/,@p))
				      || ($negatives && !grep(/^!WINNT$/,@p))))
			     || ($W32 && (!@p_purged
					  || (!$negatives && grep(/^WIN32$/,@p))
					  || ($negatives && !grep(/^!WIN32$/,@p))))
			     || ($W16 && (!@p_purged
					  || (!$negatives && grep(/^WIN16$/,@p))
					  || ($negatives && !grep(/^!WIN16$/,@p)))))
			    && (!@p
				|| (!$negatives
				    && ($rsaref || !grep(/^RSAREF$/,@p)))
				|| ($negatives
				    && (!$rsaref || !grep(/^!RSAREF$/,@p))))) {
				printf OUT "    %s%-40s@%d\n",($W32)?"":"_",$s,$n;
#			} else {
#				print STDERR "DEBUG: \"$sym\" (@p):",
#				" rsaref:", !!(!@p
#					       || (!$negatives
#						   && ($rsaref || !grep(/^RSAREF$/,@p)))
#					       || ($negatives
#						   && (!$rsaref || !grep(/^!RSAREF$/,@p))))?1:0,
#				" 16:", !!($W16 && (!@p_purged
#						    || (!$negatives && grep(/^WIN16$/,@p))
#						    || ($negatives && !grep(/^!WIN16$/,@p)))),
#				" 32:", !!($W32 && (!@p_purged
#						    || (!$negatives && grep(/^WIN32$/,@p))
#						    || ($negatives && !grep(/^!WIN32$/,@p)))),
#				" NT:", !!($NT && (!@p_purged
#						   || (!$negatives && grep(/^WINNT$/,@p))
#						   || ($negatives && !grep(/^!WINNT$/,@p)))),
#				"\n";
			}
		}
	}
	printf OUT "\n";
}

sub load_numbers
{
	my($name)=@_;
	my(@a,%ret);

	$max_num = 0;
	$num_noinfo = 0;
	$prev = "";

	open(IN,"<$name") || die "unable to open $name:$!\n";
	while (<IN>) {
		chop;
		s/#.*$//;
		next if /^\s*$/;
		@a=split;
		if (defined $ret{$a[0]}) {
			print STDERR "Warning: Symbol '",$a[0],"' redefined. old=",$ret{$a[0]},", new=",$a[1],"\n";
		}
		if ($max_num > $a[1]) {
			print STDERR "Warning: Number decreased from ",$max_num," to ",$a[1],"\n";
		}
		if ($max_num == $a[1]) {
			# This is actually perfectly OK
			#print STDERR "Warning: Symbol ",$a[0]," has same number as previous ",$prev,": ",$a[1],"\n";
		}
		if ($#a < 2) {
			# Existence will be proven later, in do_defs
			$ret{$a[0]}=$a[1];
			$num_noinfo++;
		} else {
			$ret{$a[0]}=$a[1]."\\".$a[2]; # \\ is a special marker
		}
		$max_num = $a[1] if $a[1] > $max_num;
		$prev=$a[0];
	}
	if ($num_noinfo) {
		print STDERR "Warning: $num_noinfo symbols were without info.";
		if ($do_rewrite) {
			printf STDERR "  The rewrite will fix this.\n";
		} else {
			printf STDERR "  You should do a rewrite to fix this.\n";
		}
	}
	close(IN);
	return(%ret);
}

sub parse_number
{
	(my $str, my $what) = @_;
	(my $n, my $i) = split(/\\/,$str);
	if ($what eq "n") {
		return $n;
	} else {
		return $i;
	}
}

sub rewrite_numbers
{
	(*OUT,$name,*nums,@symbols)=@_;
	my $thing;

	print STDERR "Rewriting $name\n";

	my @r = grep(/^\w+\\.*?:.*?:\w+\(\w+\)/,@symbols);
	my $r; my %r; my %rsyms;
	foreach $r (@r) {
		(my $s, my $i) = split /\\/, $r;
		my $a = $1 if $i =~ /^.*?:.*?:\w+\((\w+)\)/;
		$i =~ s/^(.*?:.*?:\w+)\(\w+\)/$1/;
		$r{$a} = $s."\\".$i;
		$rsyms{$s} = 1;
	}

	my @s=sort { &parse_number($nums{$a},"n") <=> &parse_number($nums{$b},"n") } keys %nums;
	foreach $sym (@s) {
		(my $n, my $i) = split /\\/, $nums{$sym};
		next if defined($i) && $i =~ /^.*?:.*?:\w+\(\w+\)/;
		next if defined($rsyms{$sym});
		$i="NOEXIST::FUNCTION:" if !defined($i) || $i eq "";
		printf OUT "%s%-40s%d\t%s\n","",$sym,$n,$i;
		if (exists $r{$sym}) {
			(my $s, $i) = split /\\/,$r{$sym};
			printf OUT "%s%-40s%d\t%s\n","",$s,$n,$i;
		}
	}
}

sub update_numbers
{
	(*OUT,$name,*nums,my $start_num, my @symbols)=@_;
	my $new_syms = 0;

	print STDERR "Updating $name numbers\n";

	my @r = grep(/^\w+\\.*?:.*?:\w+\(\w+\)/,@symbols);
	my $r; my %r; my %rsyms;
	foreach $r (@r) {
		(my $s, my $i) = split /\\/, $r;
		my $a = $1 if $i =~ /^.*?:.*?:\w+\((\w+)\)/;
		$i =~ s/^(.*?:.*?:\w+)\(\w+\)/$1/;
		$r{$a} = $s."\\".$i;
		$rsyms{$s} = 1;
	}

	foreach $sym (@symbols) {
		(my $s, my $i) = $sym =~ /^(.*?)\\(.*)$/;
		next if $i =~ /^.*?:.*?:\w+\(\w+\)/;
		next if defined($rsyms{$sym});
		die "ERROR: Symbol $sym had no info attached to it."
		    if $i eq "";
		if (!exists $nums{$s}) {
			$new_syms++;
			printf OUT "%s%-40s%d\t%s\n","",$s, ++$start_num,$i;
			if (exists $r{$s}) {
				($s, $i) = split /\\/,$r{$s};
				printf OUT "%s%-40s%d\t%s\n","",$s, $start_num,$i;
			}
		}
	}
	if($new_syms) {
		print STDERR "$new_syms New symbols added\n";
	} else {
		print STDERR "No New symbols Added\n";
	}
}

sub check_existing
{
	(*nums, my @symbols)=@_;
	my %existing; my @remaining;
	@remaining=();
	foreach $sym (@symbols) {
		(my $s, my $i) = $sym =~ /^(.*?)\\(.*)$/;
		$existing{$s}=1;
	}
	foreach $sym (keys %nums) {
		if (!exists $existing{$sym}) {
			push @remaining, $sym;
		}
	}
	if(@remaining) {
		print STDERR "The following symbols do not seem to exist:\n";
		foreach $sym (@remaining) {
			print STDERR "\t",$sym,"\n";
		}
	}
}