# COBOLIO.pm # # Copyright (c) 2002 Harry Holt . 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) #* Version 0.2.1p 9-Feb-2007 Bug fixes for OCCURS clauses #* #***************************************************************************************** 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() { 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; #################################################################### # HGH 9-Feb-2007 # This handles the case where the upper-level record has the # "OCCURS" clause, and the next record is also a record-level # line. The above check for the occurs flag would get bypassed # in that case, and the following block will set the correct # "nextPos" (next position) value. #################################################################### if( ($occFlag == 1) && ($nextPos > 0) ) { $nextPos += ($charCount * ($occMult - 1)); $occFlag = 0; $occLen = 0; } 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}; } ############################################################################## # HGH 9-Feb-2007 # It may be erroneous in some cases to reset the "$occFlag" (occurs flag) # variable on every check of the record-level clauses, since in some cases # the flag was set but the table count for file position was never processed. # # This needs some regression testing to ensure that we don't need to reset # the "$occFlag" somewhere else in the loop, such as when we pop levels # off the stack. ############################################################################## 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;