# COBOLIO.pm
#
# Copyright (c) 2002 Harry Holt <hholt@comcast.net>.  All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#
#  THIS PROGRAM IS PROVIDED "AS IS" WITHOUT WARRANTY OF ANY KIND, 
#  EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
#  AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, 
#  YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
#
# Reading and interpretation of COBOL copylibs into perl data structures
#
# All variable names are the same as the cobol names, but with the '-'
# changed to a '_' to avoid operator/keyword issues.
#
# SIGNS: Signs may be added to a COBOL pic clause and require special
#	processing (all OVER the place!!), so each name is given a SIGN attribute.  
#	The possible values are:
#		R - No PIC clause for this var (a record-level variable)
#		X - No SIGN specified, non-numeric
#		9 - No SIGN specified, but variable is numeric
#		+ - SIGN is specified.
#		C - Comp-3 (packed decimal), no sign.
#		3 - Comp-3 (packed decimal), WITH sign.
#	When the sign is specified, reading the data will require bit-shifting.
#	The LAST digit of the number is the sign and the last number.  If we
#	were still working in EBCDIC, would could do a straight bit-shift and
#	get the sign and the number, but because of the ASCII translation, things
#	don't work out like they should:
#		A-I = + 1-9
#		{	= + 0
#		J-R = - 1-9
#	I'm not sure what to look for if the value was a 0 with a negative sign.
#	It SHOULD be Hex D0, but since this has no representation in EBCDIC, I
#	don't know how it's represented.  +0 should be Hex C0, but it is 
#	represented as { anyway.
#	To make things simple for the Perl programmer, we will handle all the translations,
#	and often add an extra byte to the numeric variable to allow for the "-" sign.
#	Then we strip in off to update the variable value (THIS NEEDS REFACTORING).
#
# DECIMALS:  There may be a "V" in the PIC clause.  If so, this value will be greater 
#    than 0, specifying the number of "9"s after the "V" (to the right of the decimal)
#    
#*****************************************************************************************
#* Version 0.1		11-16-2002
#* Version 0.2		05-05-2004	Bug fixes and contributions by Steve Tolkin (Steve.Tolkin@FMR.COM)
#*
#*****************************************************************************************
use strict;
package COBOLIO;
#
#
#
require Exporter;
require DynaLoader;
#
our $COBOLIOPackage = "COBOLIO";
#
our @ISA = qw( Exporter DynaLoader );
#
#
#
our $FD;
our %FD;
our $FDVals;
our %FDVals;
our $self;
our $glFDRec;
our $glFDL;
#
#
sub new {
	(my $class, my $copyLibName, my $fdRec, my $isFD, my $rec01) = @_;
	
	my $recList = {};
	#$FD{$fdRec} = $recList;
	$FD{$fdRec} = CreateCobolRec( $copyLibName, $fdRec, $isFD, $rec01);
	$FDVals{$fdRec}->{VAL} = "";

#	$self = { $class, $FD, $FDVals };
	$self = { $class, $FD };
	bless $self;

return $self;
}

sub PrintLayouts {
	($self, my $FDName) = @_;

	# Show the layouts of the existing copylib members	
	my $filedesc;
	my $recList;
	for $glFDRec (keys %FD) {
		print "**********************  $glFDRec  **********************\n";
#		printf "%-28s  %7s  %7s  %7s  %6s  %7s \n", "Name", "Level", "Start", "Len", "Sign", "Parts";
                # Steven Tolkin changed 29 to 30 in next several lines.
                # Cobol allows 30 chars in a name, and without this
                # change the output report is not fixed width.
                # This matters because in some cases a value, e.g. for Start,
                # might be omitted.
		printf "%-30s %7s %7s %7s %6s %7s %5s \n", "Name", "Level", "Start", "Len", "Sign", "Decimals", "Parts";
		printf "%-30s %7s %7s %7s %6s %7s %5s \n", "-" x 29, "-----", "-----", "---", "----", "-----", "-----";
		for $recList (sort BySRT keys %{ $FD{$glFDRec} }) {
			printf "%-30s %7s %7s %7s %6s %7s %5s \n", 
				$recList, 
				$FD{$glFDRec}{$recList}->{LEVEL},
				$FD{$glFDRec}{$recList}->{STARTPOS},
				$FD{$glFDRec}{$recList}->{LEN},
				$FD{$glFDRec}{$recList}->{SIGN},
				$FD{$glFDRec}{$recList}->{DECIMALS},
				$FD{$glFDRec}{$recList}->{PARTS} ;
		}
		print "\n\n";
	}
}



sub GetRec {
	(my $self, my $fdRec) = @_;
	my $recList = $FD{$fdRec};
	return $recList;
}

#sub DESTROY {
#	my ($self) = shift;
#	if(!undef($self->{cbNames})) {
#		undef $self->{cbNames};
#	}
#	return 1;
#}

sub ReadRecInto {
	# Start by setting up the record structure
	($self, my $inputLine, my $fdRec) = @_;

	my $recList;
	my $recInLen = 80;
	my $this01Name;
	for $recList ( %{$FD{$fdRec} } ) {
		if(defined($FD{$fdRec}{$recList}->{REC01})) {
			$this01Name = $FD{$fdRec}{$recList}->{REC01};
			last();
		}
	}
	$recInLen = $FD{$fdRec}{$this01Name}->{LEN};
	
	$FDVals{$fdRec}->{VAL} = substr($inputLine.(' ' x $recInLen),0,$recInLen);
	return 1;
} #### End sub ReadRecInto


sub GetVal {
	($self, my $dataItemName, my $fd, my $dataRecName) = @_;

	my $fdRec;
	my $actualLen;
	my $actualPos;
	my $retVal;

	# If the item has an "Occurs" clause, we may need a subscript
	# of the value, so we need to parse the name to get the name and subscript
	($dataItemName, my $subScr, my $post) = split /[(,)]/, $dataItemName;
	if(defined($subScr)) {
		if($subScr < 1) { $subScr = 1; }
	} else {
		$subScr = 1;
	}

	# If the FD is not passed, we will look it up
	if(defined($fd)) {
		$fdRec = $fd;
	} else {
		$fdRec = FindFDForRecord($dataItemName);
	}

	if(!(defined($dataRecName))) {
		$dataRecName = $FD{$fdRec}{$dataItemName}->{REC01};
	}

	# Get the part of the major record that contains the record being asked for.
	if(defined($FD{$fdRec}{$dataItemName}->{PARTS})) {
		if($FD{$fdRec}{$dataItemName}->{PARTS} > 0) {
			$actualLen = $FD{$fdRec}{$dataItemName}->{LEN} / $FD{$fdRec}{$dataItemName}->{PARTS};
		} else {
			$actualLen = $FD{$fdRec}{$dataItemName}->{LEN}
		}
	} else {
		$actualLen = $FD{$fdRec}{$dataItemName}->{LEN}
	}
	$actualPos = $FD{$fdRec}{$dataItemName}->{STARTPOS} + ($actualLen * ($subScr - 1));
	$retVal = substr( $FDVals{$fdRec}->{VAL}, $actualPos, $actualLen);


	if($FD{$fdRec}{$dataItemName}->{SIGN} eq "9") { 
		$retVal =~ s/ /0/g; 
		$retVal =~ s/\x00/0/g;
	}

	# Deal with an signed numeric data
	if($FD{$fdRec}{$dataItemName}->{SIGN} eq "+") {
		$retVal =~ s/ /0/g; 
		$retVal =~ s/\x00/0/g;
		if(substr($retVal,$actualLen - 1,1) eq "{") {
			$retVal = substr($retVal,0,$actualLen - 1)."0";
		} else {
			if(substr($retVal,$actualLen - 1,1) eq "}") {
				$retVal = '-'.substr($retVal,0,$actualLen - 1)."0";
			} else {
				if($retVal =~ m/[A-I]/) {
					$retVal =~ tr/[ABCDEFGHI]/[123456789]/;
				}
				if($retVal =~ m/[J-R]/) {
					$retVal =~ tr/[JKLMNOPQR]/[123456789]/;
					$retVal = '-'.$retVal;
				}
			}
		}
	} 	# End of SIGN logic

	# If decimals are specified, we will need to add a "." in the right spot
	if($FD{$fdRec}{$dataItemName}->{DECIMALS} > 0) {
		$retVal = substr($retVal,0,length($retVal) - $FD{$fdRec}{$dataItemName}->{DECIMALS}).
				".".substr($retVal,length($retVal) - $FD{$fdRec}{$dataItemName}->{DECIMALS});
	}	# End of DECIMAL logic

	return $retVal;
}
	

sub GetCSVRecord {
	($self, my $fd, my $name01) = @_;
	#********
	# We are asked to Comma-separate the entire record and return it in that
	# format.  The loop below will roll through each entry at the field record,
	# sorted in natural (copylib) order.  A specific "01 Level" record name 
	# can be specified, so we make sure that we have found that record before
	# pulling values.  The '$in01' variable is a flag that tells us if we are
	# in the right record.
	#
	# We don't pull values for record-level field names, but we may need to pull
	# the values within a record several times if the record contains an "OCCURS"
	# clause.  The value of the OCCURS is stored in the ->{PARTS} item, so we
	# use that to create extra loops for records or data items.
	my $filedesc;
	my $reclist;
	my $fdRec = $fd;
	my $outRec = "";
	my $flNeedSep = 0;
	my $in01 = 0;
	my $i = 1;
	my $inRR = 0;
	my $RRLevel = "00";
	my $RRcnt = 0;
	my @RRRecs;
	my $RRParts = 1;
	my $currRRRec;

	if(!(defined($name01))) { $in01 = 1; $name01 = ""; }

	for $filedesc (keys %FD) {
		if($filedesc eq $fdRec) {
			$glFDRec = $filedesc;
			for $reclist (sort BySRT keys %{ $FD{$filedesc} }) {
				if($reclist eq $name01) { $in01 = 1; }
				if($in01 == 1) {
					if($flNeedSep == 1) {
						$outRec .= ",";
						$flNeedSep = 0;
					}
#					if($inRR == 1) {
#						if($FD{$filedesc}{$reclist}->{LEVEL} le $RRLevel) {
#							$inRR = 0;
#							for($i = 2; $i <= $RRParts; $i++) {
#								foreach $currRRRec (@RRRecs) {
#									$outRec .= "\"".GetVal("",$currRRRec)."\",";
#								}
#							}
#						} else {
#							$RRRecs[$RRcnt] = $reclist;
#							$RRcnt++;
#						}
#					}
							
#					if( ($FD{$filedesc}{$reclist}->{SIGN} eq "R") && ($FD{$filedesc}{$reclist}->{PARTS} > 1) ) {
#						$inRR = 1;
#						$RRLevel = $FD{$filedesc}{$reclist}->{LEVEL};
#						$RRParts = $FD{$filedesc}{$reclist}->{PARTS};
#					}
					if($FD{$filedesc}{$reclist}->{SIGN} ne "R") {
						if($FD{$filedesc}{$reclist}->{PARTS} > 1) {
							for($i = 1; $i <= $FD{$filedesc}{$reclist}->{PARTS}; $i++) {
								if($flNeedSep == 1) {
									$outRec .= ",";
									$flNeedSep = 0;
								}
								$outRec .= "\"".GetVal("",$reclist."(".$i.")")."\"";
								$flNeedSep = 1;
							}
						} else {
							$outRec .= "\"".GetVal("", $reclist)."\"";
							$flNeedSep = 1;
						}
					}
				}
			}
		}
	}	
	return $outRec;
}

sub GetFFRecord {
	($self, my $fd, my $name01) = @_;
	
	my $filedesc;
	my $reclist;
	my $curGotVal;
	my $outLen = 0;
	my $fdRec = $fd;
	my $outRec = "";
	my $in01 = 0;
	if(!(defined($name01))) { $in01 = 1; }
	
	for $filedesc (keys %FD) {
		if($filedesc eq $fdRec) {
			$glFDRec = $filedesc;
			for $reclist (sort BySRT keys %{ $FD{$filedesc} }) {
				if($reclist eq $name01) { $in01 = 1; }
				if($in01 == 1) {
					$outLen = $FD{$filedesc}{$reclist}->{LEN};
					$curGotVal = GetVal("", $reclist);
					if(substr($curGotVal,0,0) eq "-") { 
						$outLen += 1; 
					}
					if($curGotVal =~ m/\./g) { 
						$outLen += 1; 
					}
					$curGotVal .= " " x $outLen;
					$outRec .= substr($curGotVal,0,$outLen);
				}
			}
		}
	}
	
	return $outRec;
}

sub GetCSVHeader {
	($self, my $fd, my $name01) = @_;
	
	my $filedesc;
	my $reclist;
	my $fdRec = $fd;
	my $outRec = "";
	my $flNeedSep = 0;
	my $in01 = 0;
	if(!(defined($name01))) { $in01 = 1; $name01 = ""; }
	
	for $filedesc (keys %FD) {
		if($filedesc eq $fdRec) {
			$glFDRec = $filedesc;
			for $reclist (sort BySRT keys %{ $FD{$filedesc} }) {
				if($reclist eq $name01) { $in01 = 1; }
				if($in01 == 1) {
					if($flNeedSep == 1) {
						$outRec .= ", ";
						$flNeedSep = 0;
					}
					if($FD{$filedesc}{$reclist}->{SIGN} ne "R") {
						$outRec .= $reclist;
						$flNeedSep = 1;
					}
				}
			}
		}
	}
	
	return $outRec;
}
	
sub SetVal {
	($self,	my $dataItemName, my $newValue, my $fd, my $dataRecName) = @_;

	my $fdRec;
	my $dataLen;
	my $strMask;
	my $packTempl;
	
	if(defined($fd)) {
		$fdRec = $fd;
	} else {
		$fdRec = FindFDForRecord($dataItemName);
	}
	if(length($dataRecName) < 1) {
		$dataRecName = $FD{$fdRec}{$dataItemName}->{REC01};
	}

	if((substr($newValue,0,5)) eq "SPACE") {
		$newValue = " " x $FD{$fdRec}{$dataItemName}->{LEN};
	}
	
	# Fix any numerics.  Allow an extra space in case of a sign
	if($FD{$fdRec}{$dataItemName}->{SIGN} =~ m/\+|9/) {
		$dataLen = $FD{$fdRec}{$dataItemName}->{LEN} + 1;
		$strMask = 'sprintf("%0'.$dataLen.'d", $newValue);';
		$newValue = eval($strMask);
	}
	
	# We need to deal with Signed numerics somehow.  This logic seems easily breakable, though
	if($FD{$fdRec}{$dataItemName}->{SIGN} eq "+") {
		if(substr($newValue,0,1) eq "+") { $newValue = substr($newValue,1); }
		if(substr($newValue,0,1) eq "-") {
			for($newValue) {
				s/0\z/\}/g;
				s/1\z/J/g;
				s/2\z/K/g;
				s/3\z/L/g;
				s/4\z/M/g;
				s/5\z/N/g;
				s/6\z/O/g;
				s/7\z/P/g;
				s/8\z/Q/g;
				s/9\z/R/g;
			}

		} else {
			for($newValue) {
				s/0\z/\{/g;
				s/1\z/A/g;
				s/2\z/B/g;
				s/3\z/C/g;
				s/4\z/D/g;
				s/5\z/E/g;
				s/6\z/F/g;
				s/7\z/G/g;
				s/8\z/H/g;
				s/9\z/I/g;
			}
		}
	}	# Finished dealing with signed numerics ###################################
	
	# Get rid of extra place for sign
	if(substr($newValue,0,1) eq "-") { $newValue = substr($newValue,1); }

	$newValue =~ s/'.'//g;
	
	$packTempl = 'A'.$FD{$fdRec}{$dataItemName}->{LEN};
	$newValue = pack($packTempl,$newValue);

	# In case the VAL is not large enough for the data item, add enough spaces
	if(length($FDVals{$fdRec}->{VAL}) < $FD{$fdRec}{$dataItemName}->{STARTPOS}) {
		$FDVals{$fdRec}->{VAL} .= " " x $FD{$fdRec}{$dataItemName}->{STARTPOS};
	}

	# Set the actual value within the larger record
	$FDVals{$fdRec}->{VAL} = 
		substr($FDVals{$fdRec}->{VAL},0,$FD{$fdRec}{$dataItemName}->{STARTPOS}).
		$newValue.
		substr($FDVals{$fdRec}->{VAL},$FD{$fdRec}{$dataItemName}->{STARTPOS} +
							$FD{$fdRec}{$dataItemName}->{LEN});
	return 1;
}
			
sub CreateCobolRec {
	(my $copyLibName, my $fdRec, my $isFD, my $rec01) = @_;

	#################################################################################
	# Here we create the "Data Division" interpretations for the 
	# perl variables.  Each name found in the COBOL code becomes a 
	# data element name with the following attributes:  
	#	
	#	LEVEL - The COBOL "record level", 01, 03, 05, 88, etc.
	#	STARTPOS - The starting position of the data element within the overall record
	#	LEN - The character length of the data element
	#	SIGN - Whether a +/- sign is used for a numeric value
	#	REC01 - The top-level (01) data element name that this element is in.
	#
	# The File Descriptor (FD) of the COBOL source also contains a VAL attribute,
	# which holds the value of a single record when it is read in.  To 
	# find or set the value of any other record or data element, the 
	# appropriate section of the complete record is used.
	#
	# To accomodate different styles of using COBOL "copy" statements, the initial
	# 01 level record can either be included in the copy member file, or it can
	# be supplied on the command line.
	# NOTE: COBOL "01" record-level intries subordinate to an "FD" clause are 
	#		implicit "REDEFINES".
	##################################################################################
	### Initializations
	my $periodAt;
	my $nextPos = 0;
	my $currLevelLen = 0;
	my $currentLevel = 01;
	my $fillerCount = 0;
	my $recStarted = 0;
	my $charCount = 0;
	my $currLevel = 01;
	my $cnt = 0;
	my $name;
	my $picChars = "";
	my $rec01Name;
	my $recName;
	my $level;
	my @recNames;
	my @recLevel;
	my @recLen;
	my @cplLines = ();
	my @cpl = ();
	my @vals = ();
	my $initVal = "";
	my $cplLine = "";
	my $rl;
	my $occurring = 0;
	my @occurringLevel;
	my @stuff;
	my $parts;
	my $picClause;
	my $recList;
	my @recParts;
	my $sign;
	my $other;
	my $decimals;
	my $filePos;
	my $rLevel;
	my $dataName;
	my $occFlag = 0;
	my $occLen = 0;
	my $occLevel = "01";
	my $occMult = 0;

	if(defined($rec01)) {
		$rec01Name = $rec01;
		push @cplLines, "       01  ".$rec01Name.'.';
	}

	#### Read the COPYLIB file
	die "I can't open the file $copyLibName because $!" unless
		open(COPYLIB, $copyLibName);
	while(<COPYLIB>) {
		push @cplLines, $_;
	}
	close(COPYLIB);

	#### Concatenate all COPYLIB lines into 1 line-per-sentence 
	for($cnt = 0; $cnt <= $#cplLines; $cnt++) {
		if(defined $cplLines[$cnt]) {
			while( (substr($cplLines[$cnt],6,1) eq "*") && ($cnt <= $#cplLines) ) { 
				$cnt++; 
			}  	# Ignore any starting comments
		}
		last if($cnt > $#cplLines);						# exit for if end of file
		$cplLine = substr($cplLines[$cnt],6,66);			# get rid of line #'s & comments
		if($cplLine =~ m/\S/) {							# skip all-whitespace (blank) lines
			while($cplLine !~ /\./) {					# concatenation based on the period
				if($cplLine =~ "\"") {
					$cplLines[$cnt + 1] =~ s/\"//;		# remove redundant quotes on next line
				}
				if(substr($cplLines[$cnt + 1],6,1) ne "*") {
					$cplLine .= substr($cplLines[$cnt + 1],11,61);
				}
				$cnt += 1;
			}
			if($cplLine =~ m/\./g) {			# chop line after the period
				$periodAt = pos($cplLine);
				$cplLine = substr($cplLine,0,$periodAt);
			}
			push @cpl, $cplLine;
		}
	}

	##########################################################################
	# Next starts the loop to interpret the COBOL data members and create the
	# hash of hashes to store the attributes of the data items.
	#
	##########################################################################
	my $cplSub = 0;
	for (@cpl) {
		@stuff = ();
		s/-/_/g;		# Change all "-" (dashes) to "_" (underscores)
		s/\.//g;		# Eliminate all periods
		if($_ =~ "PIC") {	# Get the position, length of defined data member
			@stuff = split;
			$level = $stuff[0];
			$name = $stuff[1];
			if($name eq "FILLER") { 	# Make "FILLER" fields have unique names
				$name = "FILLER".$fillerCount;
				$fillerCount++;
			}

			if(defined $stuff[2]) {
				if($stuff[2] =~ "OCCURS") { 	# Check for "OCCURS" clause
					$parts = $stuff[3];			# PARTS = 1 unless the "OCCURS"
					$picClause = $stuff[6];		# clause defines multiples.
				} else {
					$parts = 1;
					$picClause = $stuff[3];
				}
				if($stuff[2] =~ "REDEFINES")  {						# Check for a "REDEFINES" clause
					$nextPos = $recList->{$stuff[3]}->{STARTPOS};	# which will reset the $nextPos counter
					$picClause = $stuff[5];
				}
			}			
			if(substr($picClause,0,1) eq "S") { 	# Look for a signed numeric
				$sign = "+";
			} else {
				if(substr($picClause,0,1) eq "9") {
					$sign = "9";
				} else {
					$sign = "X";
				}
			}
			###########
			# Next, the PICTURE clause is parsed to determine the data type
			# and the size of the field.
                        
                        # Tolkin bug fix part 1.
                        # Added the third parm (LIMIT of 3) to split.
                        # Without this it used to produces $other of V9
                        # from 9(03)V9(02) which is wrong.
                        # After the fix it produces V9(02)
                        # Another way to solve this would set limit of 4 and
                        # get that last piece now, but we do it below.
			($picChars, $charCount, $other) = split /[(,)]/ ,$picClause, 3;
                        #warn "dbg 1 Tolkin:$picChars, $charCount, $other\n"; 
			if(!(defined $charCount)) { 
				($picChars, $other) = split /V/, $picChars;
				$picChars =~ s/S//g;
				$charCount = length($picChars);
				if(defined $other) { $charCount += length($other); }
			} else {
				$other =~ s/V//g
					if defined $other;
                                # Tolkin bug fix part 2 We change
                                # e.g. 9(02) into 99 using Perl
                                # operator x which "returns a string
                                # consisting of the left operand
                                # repeated the number of times
                                # specified by the right operand"
                                if (defined $other &&
                                    $other =~ m/^(.)\((\d+)\)$/) {
                                    $other = $1 x $2;
                                    #warn "dbg o Tolkin:$other\n";
                                }
                                # end fix part 2
				$charCount = $charCount + length($other);
				$charCount = $charCount * $parts;
			}
			$decimals = 0;
			$decimals = length($other)
				if defined $other;
                        #warn "dbg 2 Tolkin:$picChars, $charCount, $other\n";
                        #warn "dbg 3 Tolkin:$decimals\n"; 
			if(defined $stuff[4]) {									# Need to make adjustments 
				if($stuff[4] =~ "COMP_3") {							# to the length of 
					if($recList->{$name}->{SIGN} == "+") {			# the variable if 
						$recList->{$name}->{SIGN} = "3";			# it is defined as a 
					} else {										# COMP-3, which 
						$recList->{$name}->{SIGN} = "C";			# compresses the data
					}
					if($charCount % 2 > 0) {
						$charCount = (int ($charCount / 2)) + 1;
					} else {
						$charCount = $charCount / 2;
					}
				}
			}
				
			if($occFlag == 1) {
				if($level < $occLevel) {
					$nextPos += ($occLen  * ($occMult - 1));
					$occFlag = 0;
					$occLen = 0;
				}
			}
			$recList->{ $name } = { 			# Set all the hash values
				LEVEL => $level,				# for this variable
				STARTPOS => $nextPos,
				LEN => $charCount,
				SIGN => $sign,
				REC01 => $rec01Name,
				PARTS => $parts,
				DECIMALS => $decimals,
				SRT => $cplSub,
			};
			if(defined $stuff[4]) {
				if($stuff[4] =~ "VALUE") {
					@vals = split/VALUE/;
					$initVal = $vals[1];
					if($initVal =~ "SPACE") {
						$initVal = " " x $charCount;
					}
					if($initVal =~ "ZERO") {
						$initVal = "0" x $charCount;
					}
					$initVal =~ s/\s+//x;
					$initVal =~ s/\"//g;
					SetVal("", $name, $initVal, $fdRec);
				}
			}
			$nextPos += $charCount;
			
			while($currLevel > $level) {
				$recName = pop @recNames;
				$currLevel = pop @recLevel;
				pop @recLen;
				pop @recParts;
				
			}
			if($occFlag == 1) { $occLen += $charCount; }
		#
		##########  Record-level data variables are dealt with in the "else" clause ##############
		#
		} else {		# Deal with record-level data variables
			@stuff = split;
			$level = $stuff[0];
			if($level == 01) { 
				$rec01Name = $stuff[1];
				if($isFD == 1) { $nextPos = 0; }
			}
			if(!(defined($currLevel))) {
				$currLevel = "01";
			}
			while($currLevel > $level) {
				if($#recNames > -1) {
					$recName = pop @recNames;
					if(defined($recList->{$recName}->{LEN})) {
						$recList->{$recName}->{LEN} += (pop @recLen) * (pop @recParts);
					} else {
						$recList->{$recName}->{LEN} = (pop @recLen) * (pop @recParts);
					}
				}
				$currLevel = pop @recLevel;
			}
			if(defined $stuff[2]) {
				if($stuff[2] =~ "REDEFINES")  {
					$nextPos = $recList->{$stuff[3]}->{STARTPOS};
				}
				if($stuff[2] =~ "OCCURS") { 
					$parts = $stuff[3];
					$occFlag = 1;
					$occLevel = $level;
					$occMult = $parts;
				} else {
					$parts = 1;
					$occFlag = 0;
				}
			} else {
				$parts = 1;
				$occFlag = 0;
			}
			$recList->{$stuff[1]} = {
				LEVEL => $level,
				STARTPOS => $nextPos,
				LEN => 0,
				SIGN => "R",
				REC01 => $rec01Name,
				PARTS => $parts,
				DECIMALS => 0,
				SRT => $cplSub,
			};
			push @recNames, $stuff[1];
			push @recLevel, $level;
			push @recLen, 0;
			push @recParts, $parts;
		}
		$currLevel = $level;
		NEXTREC:
		$cplSub++;
	}

	while($recName = pop @recNames) {   # Get lengths for remaining levels.
		pop @recLevel;
		pop @recParts;
	}
	
	my @rns = ();
	$glFDL = $recList;
	for $recName (sort ByPreSRT keys %$recList) {
		if($recList->{$recName}->{SIGN} eq "R") {
			push @rns, $recName;
		}
	}
	for $recName (@rns) {
		$filePos = $recList->{$recName}->{STARTPOS};
		$rLevel = $recList->{$recName}->{LEVEL};
		$glFDL = $recList;
		for $dataName (sort ByPreSRT keys %$recList) {
			if($recList->{$dataName}->{SRT} > $recList->{$recName}->{SRT}) {
				if($rLevel < $recList->{$dataName}->{LEVEL}) {
					if($recList->{$dataName}->{SIGN} ne "R") {
						if($recList->{$dataName}->{STARTPOS} >= $filePos) {
							$recList->{$recName}->{LEN} += ($recList->{$dataName}->{LEN} * $recList->{$recName}->{PARTS});
							$filePos = $recList->{$dataName}->{STARTPOS} + $recList->{$dataName}->{LEN};
						} 
					}
				} else { 	# Exit loop if new record at the same level
					last; 
				}
			}
		}
	}
	return $recList;
}	# sub CreateCobolRec()


sub ByLevel { 
	my $fdRec;
	$FD{$fdRec}{$a}->{LEVEL} <=> $FD{$fdRec}{$b}->{LEVEL}; 
}

sub BySRT { 
		$FD{$glFDRec}{$a}->{SRT} <=> $FD{$glFDRec}{$b}->{SRT};
}

sub ByPreSRT {
	$glFDL->{$a}->{SRT} <=> $glFDL->{$b}->{SRT};
}

sub ByPosition {
	$FD{$glFDRec}{$a}->{STARTPOS} <=> $FD{$glFDRec}{$b}->{STARTPOS}
		||
	$FD{$glFDRec}{$a}->{LEVEL} <=> $FD{$glFDRec}{$b}->{LEVEL};
}

sub FindFDForRecord {
	my $recordName = shift;
	my $returnValue = "";
	my $foundCount = 0;
	my $dataName;
	my $filedesc;
	my $reclist;
	
	for $filedesc (keys %FD) {
		for $reclist (keys %{ $FD{$filedesc} }) {
			if($reclist eq $recordName) {
				$returnValue = $filedesc;
				$foundCount += 1;
##				print "Found $recordName in $filedesc\n";
##				return $returnValue;
			}
		}
	}
	if($foundCount > 1) {
		die "Ambiguous record name specified $recordName\n";
	}
	return $returnValue;
}

1;