#
# $Id: typemap.PL,v 25.2 2004/01/14 19:10:12 biersma Exp $
#
# (c) 1999-2004 Morgan Stanley Dean Witter and Co.
# See ..../src/LICENSE for terms of distribution.
#
# Script to generate a typemap from the MQSeries header files
#
# Whenever it encounters a new type, it starts building up two hashes,
# %input, and %output.  $input{TYPE} is the input section of the
# typemap for the TYPE, and $output{TYPE} is the output section of the
# typemap.
#
# The actual code used to convert a field can be found in:
#
#	&long_output, &long_input		for MQLONG types
#	&string_output, &string_input		for MQCHARn types
#	&byte_output, &byte_input		for MQBYTE types
#
# Other types are not yet supported, and those that are not relevant
# are skipped intentionally.  Warnings should be due to new
# structures, and should be reviewed.
#

$input{'MQCHAR48'} = join('',
			  '/*' . '=' x 75 . "*/\n",
			  "T_MQCHAR48\n",
			  "    strncpy(\$var, (char*)SvPV(\$arg, PL_na), 48)\n",
			  );

require "../util/parse_config";
require "../util/parse_headers";

@ARGV = @headers;

$debug = $ENV{DEBUG_TYPEMAP_PL};

open(STDOUT, "> typemap") || die "$0: error writing typemap: $!\n";

while ( <> ) {

    if (/typedef\s+struct\s+tag(\w+)/) {
	# entry into a new type
	$type = $1;
	print "#we're starting a $type\n" if $debug;
	$input{$type} = &input_header($type);
        $output{$type} = &output_header($type);
    }
    elsif (/\}\s+(MQ\w+);/) {
	# exit of a type.  Probably should assert that $type2 eq $type
	$type2 = $1;
	print "#we're ending a $type ($type2)\n" if $debug;
	$input{$type} .= &input_footer($type);
	undef $type;
    }
    elsif ($type && /^\s*\}\s*;\s*$/) {
        # exit of a type in 5.3 headers
	print "#we're ending a $type\n" if $debug;
	$input{$type} .= &input_footer($type);
	undef $type;
    }
    elsif ($type && ($_ =~ /\s+(MQ\w+)\s+(\w+);/)) {
	# found a new field of type $fieldt and name $field:
	$fieldt = $1;
	$field = $2;

	next if $field eq "StrucId";
	print "#Found a $field of type $fieldt\n" if $debug;

	#
	# A list of known types we don't support.  Ignore them.
	#
	next if (grep { $fieldt eq $_ }
                 qw(MQPTR MQMD1 MQHCONN MQPOINTER MQPID MQTID MQHCONFIG));

	if ($fieldt eq 'MQLONG' ||
	    $fieldt eq 'MQHOBJ') {
	    $strlen = length($field);

	    $input{$type} .= &long_input($field);
	    $output{$type} .= &long_output($field);

	}
	elsif ($fieldt =~ /^MQCHAR(\d*)$/) {
	    $size = $1;

	    if ($size == 0) {
	   	$size = 1;
	    }
	    $output{$type} .= &string_output($field, $size);
	    $input{$type} .= &string_input($field, $size);
	}
	elsif ($fieldt =~ /^MQBYTE(\d*)$/) {
	    $size = $1;

	    if ($size == 0) {
	   	$size = 1;
	    }
	    $output{$type} .= &byte_output($field, $size);
	    $input{$type} .= &byte_input($field, $size);
	}
	else {
	    warn "$0: warning: type $type.$field ($fieldt) not supported\n";
	}

    }

}


print <<"EOF";
MQBYTE		T_U_CHAR
PMQBYTE		T_PV
MQBYTE16	T_PV
PMQBYTE16	T_PV
MQBYTE24	T_PV
PMQBYTE24	T_PV
MQBYTE32	T_PV
PMQBYTE32	T_PV
# Character Datatypes
MQCHAR		T_CHAR
PMQCHAR		T_PV
MQCHAR4		T_PV
PMQCHAR4	T_PV
MQCHAR8		T_PV
PMQCHAR8	T_PV
MQCHAR12	T_PV
PMQCHAR12	T_PV
MQCHAR28	T_PV
PMQCHAR28	T_PV
MQCHAR32	T_PV
PMQCHAR32	T_PV
MQCHAR48	T_MQCHAR48
PMQCHAR48	T_PV
MQCHAR64	T_PV
PMQCHAR64	T_PV
MQCHAR128	T_PV
PMQCHAR128	T_PV
MQCHAR256	T_PV
PMQCHAR256	T_PV
# Other Datatypes
MQLONG		T_IV
PMQLONG		T_OPAQUEPTR
MQULONG		T_UV
MQHCONN		T_IV
PMQHCONN	T_OPAQUEPTR
MQHOBJ		T_IV
PMQHOBJ		T_OPAQUEPTR
MQPTR		T_PV
PMQPTR		T_PV
PMQVOID		T_PV
PPMQVOID	T_PV

# Structures
MQAIR           T_MQAIR
MQBO		T_MQBO
MQCNO		T_MQCNO
MQDH		T_MQDH
MQDLH		T_MQDLH
MQGMO		T_MQGMO
MQIIH		T_MQIIH
MQMD		T_MQMD
MQMDE		T_MQMDE
MQMD1		T_MQMD1
MQOD		T_MQOD
MQOR		T_MQOR
MQPMO		T_MQPMO
MQRFH		T_MQRFH
MQRMH		T_MQRMH
MQRR		T_MQRR
MQSCO           T_MQSCO
MQTM		T_MQTM
MQTMC2		T_MQTMC2
MQXQH		T_MQXQH

MQCFH		T_MQCFH
MQCFIL		T_MQCFIL
MQCFIN		T_MQCFIN
MQCFSL		T_MQCFSL
MQCFST		T_MQCFST

# Input of the above types:
INPUT
EOF

foreach $type (sort keys %input) {
    print $input{$type}, "\n";
}

print "# Output of the above types:\nOUTPUT\n";
foreach $type (sort keys %output) {
    print $output{$type}, "\n";
}


#==============================================================================
sub long_input {
    my($field) = @_;
    my($strlen) = length($field);

    return <<"EOF";
	if (hv_exists((HV*)SvRV(\$arg),\\"$field\\",$strlen))
	  \$var.$field = SvIV(*(hv_fetch((HV*)SvRV(\$arg),
		\\"$field\\",$strlen,0)));
EOF
}
#==============================================================================
sub long_output {
    my($field, $hash) = @_;
    my($strlen) = length($field);

    $hash = 0 unless $hash;
    return <<"EOF";
        hv_store((HV*)SvRV(\$arg),\\"$field\\",$strlen,
		 (newSViv(\$var.$field)),$hash);
EOF
}
#==============================================================================
sub string_output {
    my($field, $fieldsize, $hash) = @_;
    my($fieldnamelen) = length($field);
    my($isptr);

    $hash = 0 unless $hash;
    if ($fieldsize == 1) {
	$isptr = "&";
    }

    return <<"EOF";
	hv_store((HV*)SvRV(\$arg),\\"$field\\",$fieldnamelen,
		 (newSVpv($isptr\$var.$field, $fieldsize)),$hash);
EOF
}
#==============================================================================
sub string_input {
    my($field, $fieldsize) = @_;
    my($fieldnamelen) = length($field);
    my($isptr);

    if ($fieldsize == 1) {
	$isptr = "&";
    }

    return <<"EOF";
        if (hv_exists((HV*)SvRV(\$arg), \\"$field\\", $fieldnamelen)) {
	    SV        **scalar;
            STRLEN      StringLength;
	    const char *StringData;

            /* Need to deal with undersized data.  Only copy supplied bytes. */
	    scalar = hv_fetch((HV *)SvRV(\$arg), \\"$field\\", $fieldnamelen, 0);
            StringData = SvPV(*scalar, StringLength);
	    strncpy($isptr\$var.$field,
		    StringData,
                    StringLength > $fieldsize ? $fieldsize : StringLength);
	}


EOF
}
#==============================================================================
sub input_header {
    my($type) = @_;

    return <<"EOF";
/*===========================================================================*/
T_$type
    {
	/* input a $type */
        STRLEN len = 0;
	$type default_$type = { ${type}_DEFAULT };

	if (!SvROK(\$arg))
	    croak(\\"Reference expected for parameter \$var\\");
	/* copy in the default value of structure... */
	memcpy((char *)&\$var, &default_$type, sizeof($type));

EOF
}
#==============================================================================
sub input_footer { "    }\n"; }
#==============================================================================
sub output_header {
    my($type) = @_;

    return <<"EOF";
/*===========================================================================*/
T_$type
    /* output a $type: */


EOF
}
#==============================================================================
sub byte_output {
    my($field, $fieldsize, $hash) = @_;
    my($fieldnamelen) = length($field);

    $hash = 0 unless $hash;
    return <<"EOF";
        hv_store((HV*)SvRV(\$arg),\\"$field\\",$fieldnamelen,
		 (newSVpv((char *)\$var.$field,$fieldsize)),$hash);
EOF
}
#==============================================================================
sub byte_input {
    my($field, $fieldsize) = @_;
    my($fieldnamelen) = length($field);

    return <<"EOF";
        if (hv_exists((HV*)SvRV(\$arg), \\"$field\\", $fieldnamelen)) {
	    SV        **scalar;
            STRLEN      ByteLength;
	    const char *ByteData;

            /* Need to deal with undersized data.  Only copy supplied bytes. */
	    scalar = hv_fetch((HV *)SvRV(\$arg), \\"$field\\", $fieldnamelen, 0);
            ByteData = SvPV(*scalar, ByteLength);
	    memcpy(\$var.$field,
		   ByteData,
                   ByteLength > $fieldsize ? $fieldsize : ByteLength);
	}
EOF
}