genperl.pl

cryptlib安全工具包

#!/usr/bin/perl
# script to translate th cryptlib C interface into a Perl header interface module
# Copyright (C) 2007 Alvaro Livraghi

#####
#       G E N P E R L . P L   Version 0.1 (last changes 2007-06-0)
#       --------------------------------------------------------------------
#       Based upon GenVB.pl by Wolfgang Gothier
#
#       PERL script for translation of the cryptlib header file
#            into a Perl header file used by Perl interface package 
#            for Cryptlib (PerlCryptLib.pm).
#
#            This script does the translation of C-statements into
#            Perl code. (But only as much as is needed in 
#            cryptlib.h, -NOT- usable as general translation utility)
#
#       --------------------------------------------------------------------
#
#       SYNTAX:
#           perl GenPerl.pl <cryptlib.h> <PerlCryptLib.ph>
#
#               cryptlib.h ........ (optional) Pathname of crytlib header file
#                                              default is "cryptlib.h"
#               PerlCryptLib.ph ... (optional) Pathname of PerlCrytLib header file
#                                              default is "PerlCryptLib.ph"
#
#               creates the Perl interface file with same basic name 
#               and extension ".ph" in the same directory as the source file
#               default is "PerlCryptLib.ph"
#
#####

use strict;
use warnings;

use File::stat;
use File::Basename;

my $inFileName  = shift @ARGV || 'cryptlib.h';	# default filename is "cryptlib.h"
my %DEFINED = ( 1, 1,                     		# ifdef 1 is to be included
                "USE_VENDOR_ALGOS", 0 );		# set to 1 to include #IFDEF USE_VENDOR_ALGOS
my $Startline = qr{^#define C_INOUT};			# ignore all lines before this one

my ($inFileBase, $inPath, $inExt) = fileparse($inFileName, qr{\.[^.]*$});
die("\"usage: $0 cryptlib.h\"\nParameter must be a C header file\nStop") unless ($inExt =~ m/^\.h$/i) && -r $inFileName;

my $outFileName = shift @ARGV || $inPath.'PerlCryptLib.ph';		# default filename is "PerlCryptLib.ph"
my ($outFileBase, $outPath, $outExt) = fileparse($outFileName, qr{\.[^.]*$});

my ($Infile, $Outfile) = ($inPath.$inFileBase.'.h', $outPath.$outFileBase.$outExt);
my $cryptlib_version;

open(INFILE, "<$Infile") or die "Open error on $Infile: $!";
open (OUTFILE, ">$Outfile") or die "Open error on $Outfile: $!";
print "Transforming \"$Infile\" into \"$Outfile\"\n";
my $Default = select(OUTFILE);


# Ignore all input lines before (and including) $Startline
while (<INFILE>) {
	$cryptlib_version = $_ if m{#define\s+CRYPTLIB_VERSION\s+};
	last if m/$Startline/;
}

# array to contain the preprocessed input lines:
my @source;

push @source, PERLHeader($Infile);
push @source, $cryptlib_version if $cryptlib_version;

my $INACTIVE = 0;
my $LEVEL = 0;
my $COMMENT = 0;
# handle conditionals, include conditional code only if definition agrees with %DEFINED
while (<INFILE>) { 

		# remove tabs
		1 while s/\t/' ' x (length($&)*4 - length($`)%4)/e;

    if (/^\s*#if(\s|def\s)(\w+)/) {
        $LEVEL += 1;
        $INACTIVE += 1 unless $DEFINED{$2};
        next;
    }
    if (/^\s*#if\s\(/) {		#if (anyexpression) assumed always false
        $LEVEL += 1;
        $INACTIVE += 1;
        next;
    }
    if (/^\s*#ifndef\s(\w+)/) {
        $LEVEL += 1;
        $INACTIVE += 1 if $DEFINED{$1};
        next;
    }
    if (/^\s*#(else|elif)\b/) {
        $INACTIVE = 1-$INACTIVE;
        next;
    }
    if (/^\s*\#endif\b/) {
        $LEVEL -= 1;
        $INACTIVE = 0;
        next;
    }

    # translate comments
    if (/\/\*(.*)\*\/\s*$/) {
        if ($1 !~ m(\*/)) {
            s!/\*(.*)\*/\s*$!#$1\n!
        }
    }

    if ($COMMENT) {
        $_ = "#".$_ unless s/^ /#/;
        $COMMENT = 0 if s/\*\/\s*$/\n/;
        s/\*\*$/***/;
    }
    $COMMENT = 1 if s/^(\s*)\/\*\*(.*)$/#**$1$2/;
    $COMMENT = 1 if s/^(\s*)\/\*(.*)$/#$1 $2/;

    push @source, $_ unless $INACTIVE;
}

# preprocessing finished, translation to PERL code follows

my $Warn="";

while ($_ = shift @source) {

	# ignore special C++ handling
    if (/#ifdef\s+__cplusplus/) {
        $_ = shift @source  while (!(/#endif/));
        $_ = shift @source;
    }
    
    # continued lines
    if (s/\\$//) {
        $_ .= shift @source;
        redo if @source;
    }
    
    # incomplete typedef / enum lines
    if (/^\s*(typedef\s+enum|typedef\s+struct|enum)\s*\{[^}]*$/) {
        $_ .= shift @source;
        redo if @source;
    }
    
    # incomplete procedure calls
    if (/^\s*C_RET\s+\w+\s*\([^)]*$/) {
        $_ .= shift @source;
        redo if @source;
    }
	# lines are complete now, do the translation

    # hex values
    #s{0x([0-9a-fA-F]+)}{&H$1}g;
    
	# constant definitions
	#s/^\s*#define\s+(\w+)\s+(\w+|[+\-0-9]+|&H[0-9a-fA-F]+)/  Public Const $1 As Long = $2/;
	s/^\s*#define\s+(\w+)\s+(\w+|[+\-0-9]+|&H[0-9a-fA-F]+)/\tsub $1 { $2 }/;

    # typedef struct
    if (s!^(\s*)typedef\s+struct\s*{([^}]*)}\s*(\w+)\s*;!&typelist(split(/;/,$2))!e) {
        $_ = "sub $3\n{\n\t{\n$_\t}\n}\n";
    }

	# typedef enum ( with intermediate constant definitions )
    if (s!^\s*typedef\s+enum\s*{([^}]+=\s*\d+\b[^}]+)}\s*(\w+);!&enumt(split(/\n/,$1))!e) {
        $_ = "##### BEGIN ENUM $2 $_##### END ENUM $2\n";
    }

	# typedef enum
    if (s!^\s*typedef\s+enum\s*{([^}]+)}\s*(\w+);!&enumt(split(/\n/,$1))!e) {
        $_ = "##### BEGIN ENUM $2\n$_##### END ENUM $2\n";
    }

	# "simple" typedef
    s/^\s*typedef\s+(\w+)\s+(\w+);/sub $2 { 0 }/;

	# "simple" enum
    s!^\s*enum\s*{([^}]+)}\s*;!&enums(split(/,/,$1))!e;

	# translate function declarations without params
	if ( s/(\bC_RET\s*\w+\s*\(\s*[^)]+\s*\)\s*;)/#$1/ ) {
		s/\n/\n#/g;
	}

	# C-macro definitions are ignored
    if (s/\s*#define\s+(.*)/$1/) {
        s/\n/\n#/g;
        s/\s+$//;
        $_ = "# C-macro not translated to Perl code but implemented apart: \n#   #define $_\n";
    }

	# translation is done, output lines now
    print "$_" if @source;
}
print PERLFooter();

select($Default);

exit;

# subroutine definitions follow:

sub PERLHeader {
	my $Infile = shift;
	my $fstat = stat($Infile) if (-f $Infile && -r $Infile) or die "$Infile not readable";
	my $infile_size = $fstat->size;
	my $infile_time = localtime($fstat->mtime);
	my $filename = basename($Infile);
	my $now = (localtime())[5]+1900;
return <<ENDOFHEADER;

# *****************************************************************************
# *                                                                           *
# *                        cryptlib External API Interface                    *
# *                       Copyright Peter Gutmann 1997-$now                   *
# *                                                                           *
# *                 adapted for Perl Version 5.x  by Alvaro Livraghi          *
# *****************************************************************************
#
#
# ----------------------------------------------------------------------------
#
# This file has been created automatically by a perl script from the file:
#
# "$filename" dated $infile_time, filesize = $infile_size.
#
# Please check twice that the file matches the version of $filename
# in your cryptlib source! If this is not the right version, try to download an
# update from CPAN web site. If the filesize or file creation date do not match,
# then please do not complain about problems.
#
# Published by Alvaro Livraghi, 
# mailto: perlcryptlib\@gmail.com if you find errors in this file.
#
# -----------------------------------------------------------------------------
#

ENDOFHEADER

}

sub PERLFooter {
return <<ENDFOOTER;

#
# *****************************************************************************
# *                                                                           *
# *                    End of Perl Functions                                  *
# *                                                                           *
# *****************************************************************************
#

1; ##### End-of perl header file!

ENDFOOTER
}

# subroutine to handle simple enum elements
sub enums {
    my $Index = 0; # startvalue = 0 for enum entries
    my $_S;
    foreach (@_) {
        chomp;
        s/^\s+//;   # delete leading whitespace
        if (m/(\w+)\s*=\s*(\d+).*$/) {
        		# new value is being set, $index must be updated
            $_S .= "  sub $1 { $2 }\n";
            eval($Index = $2+1);
        }
        else {
            $_S .= "  sub $_ { ".$Index++." }\n";
        }
    }
    return $_S;
}

# subroutine to handle typedef enum ( with intermediate constant definitions )
sub enumt {
    my $LINES = "";
    my $parval;
	my $lastValue = 0;
    foreach $parval (@_) {
    	my ($val, $rem, $name, $value);
		$parval =~ s/^\s*(.*?)\s*$/$1/;
		($val, $rem) = split('#', $parval, 2);
		$val = '' unless $val;
		$val =~ s/^\s*(.*?)\s*$/$1/;
		$rem = '' unless $rem;
		$rem =~ s/^\s*(.*?)\s*$/$1/;
		if ( $val ne '' ) {
			($name, $value) = split('=', $val, 2);
			$name = '' unless $name;
			$name =~ s/^\s*(.*?)[\s\,]*$/$1/;
			$value = '' unless $value;
			$value =~ s/^\s*(.*?)[\s\,]*$/$1/;
			if ( $value eq ''  ||  $value =~ /^\d/ ) {
				$value = $lastValue unless $value;
				$lastValue = $value + 1;
			}
		}
		if ( $name ) {
			foreach my $curname (split(',', $name)) {
				$curname =~ s/^\s*(.*?)\s*$/$1/;
		        $LINES .= ($curname ? "\tsub $curname { $value }" : '') . ($rem ? "\t# $rem" : '') . "\n";
			}
		} else {
	        $LINES .= ($rem ? "\t# $rem" : '') . "\n";
		}
    }
    return $LINES;
}
#   handle the lines of a "typedef struct { ... } structname"
sub typelist {
    my $tmp = "";
	my $first = 0;
    foreach my $par (@_) {
        while ($par =~ s/^(\s*)\#(.+)\n(.*)/$3/) {   # embedded comments
            $tmp .= "\t# $2\n";
        }
        if ($par =~ s/^(\s*)(.*)\s(\w+)\s*\[\s*(\w+)\s*\]\s*$//) {    # index conversion
            $tmp .= $1 . (!$first++ ? ' ' : ',') . "$3 => ' ' x $4";
        }
        elsif ($par =~ s/^(\s*)(.*)\s(\w+)\s*$//) {  # normal conversion
            $tmp .= $1 . (!$first++ ? ' ' : ',') . "$3 => 0";
        }
        else {$tmp .= $par}                          # leave it alone
    }
    return $tmp;
}