Anonymous Monk has asked for the wisdom of the Perl Monks concerning the following question:

Monks, thank you so much for the help a while back on decoding my packed (BCD) data file. I thought with the examples, etc. that I could handle the reverse myself, but alas...I am STILL a trainee. I've learned a TON, just not yet the RIGHT ton. So, here's my code- can you explain why my Encode fails? In the .OUT file, it looks like I'm just not going far enough. I'm not quite getting back to the original representation. Thanks again for your patience. 
# !perl      Test_BCD.pl
# The first 6 bytes of my test file contain the 12 digit BCD 
# (Binary Coded Decimal) UPC Barcode 123456781020.  This needs 
# to be broken down into 3 testable/printable fileds and printed 
# as 12-34567-81020. Then re-assembled back into the 2 digits per 
# byte BCD format. I'm trying to use the Decode_BCD & Encode_BCD 
# subroutines below to do this.

open (inFILE, "<C:/Dev/Perl_Dev/ItemExp/TESTFILE.DAT") || 
                    die "Cannot open file\n";

# First 6 bytes are "\x12\x34\x56\x78\x10\x20"
binmode (inFILE);
open (outFILE, ">C:/Dev/Perl_Dev/ItemExp/TESTFILE.OUT") || 
                    die "Cannot open file\n";
binmode (outFILE);
seek (inFILE,0,0);
read (inFILE,$inBuf,6);

$test1 = Decode_BCD($inBuf);
$first2 = substr($test1,0,2);
$MfgID = substr($test1,2,5);
$Item = substr($test1,7.5);
$test2 = Encode_BCD(join('',$first,$MfgID,$Item));
                   
if ($test1 = $test2) {
   $comp = "EQUALS";
}  else  {
   $comp = "Does NOT Equal";
}

print "\n\n ..and the results are.... drum roll....";
print "\n\tFirst 2 chars = $first2";
print "\n\tManufactur ID = $MfgID";    # these print correctly
print "\n\tItem Code     = $Item";

print "\n\n test1 $comp test2";   # This prints that they're EQUAL.
print "\n";

seek (outFILE,0,0);
print outFILE "$inBuf"; # In the output file, this shows the correct d
+ata
seek (outFILE,16,0);
print outFILE "$test1"; # This is strange-ness CE 0A 47 46 00 00
seek (outFILE,32,0);
print outFILE "$test2"; # This is the same strange-ness CE 0A 47 46 00
+ 00

close inFILE;
close outFILE;

sub Decode_BCD
{
   my $str = shift;
   my $hex;
   $hex .= sprintf "%02x", ord
       for split //, $str;
   return $hex;
}

sub Encode_BCD
{
   my $str = shift;
   my $hex;

   $hex .= pack("N", $str), 
       for substr($str,0,2);

   return $hex;
}

[download]

Replies are listed 'Best First'.
Re: Encoding BCD
by Corion (Patriarch) on Jun 13, 2007 at 15:49 UTC

    This code:

    if ($test1 = $test2) {
   $comp = "EQUALS";
}  else  {
   $comp = "Does NOT Equal";
}

    [download]

    does not do what you think it does. Most likely you want to use one of the comparison operators, eq for string comparison or == for numerical comparison. Look at:

    my $test1 = 123;
my $test2 = 456;
print "1. Test1: '$test1', test2: '$test2'\n";
if ($test1 = $test2) {
   print "2a. Test1: '$test1', test2: '$test2'\n";
   $comp = "EQUALS";
}  else  {
   print "2b. Test1: '$test1', test2: '$test2'\n";
   $comp = "Does NOT Equal";
}
print "3. Test1: '$test1', test2: '$test2'\n";

    [download]

    I use the following to convert a BCD string to a Perl number/string:

    =head2 C<decode_COMP3>

Decodes a COMP3 BCD-number with trailing sign

=cut

sub decode_COMP3 {
    # Cut off the last nibble
    # 0C -> +
    # 0D -> -
    # 0F -> (unsigned number)
    my $digits = unpack "H*", $_[0];
    my $sign = chop $digits;
    #print "$digits\n";
       if ($sign eq 'D' or $sign eq 'd') { $sign = '-' }
    elsif ($sign eq 'C' or $sign eq 'c') { $sign = '+' }
    elsif ($sign eq 'F' or $sign eq 'f') { $sign = ' ' }
    else { $digits .= $sign; $sign = '?' };
    "$sign$digits"
};

    [download]

    In your case, maybe you want to throw away all the sign handling. The code could then be:

    sub decode_BCD {
    unpack "H*", $_[0];
};

    [download]

    When debugging string packing/unpacking problems, I often write me a test suite to make sure all my assumptions about the data get documented somewhere. You might want to use something like the following:

    use strict;
use Test::More tests => 4;
use_ok 'MyBCDDecodePackage';

is decode_BCD("\x12\x34\x56","123456");
is decode_BCD("\x00\x34\x56","003456");
is decode_BCD("\x12","12");

    [download]

    and then add all cases from your actual input data that you find interesting/problematic.

[reply]
[d/l]
[select]
      Corion, Thanks for the help, I especially like the debug piece at the end. My DecodeBCD is working (thanks in no small part to FunkyMonk), it's the ENcoding I'm having a problem with. getting from the 3 substrings, BACK to the \x12\x34..etc. Thanks.
[reply]

        The following code works for me:

        use strict;
use Test::More tests => 3;

sub encode_BCD {
    return pack 'H*', join '', @_
};

is encode_BCD("123456"), "\x12\x34\x56";
is encode_BCD("00",3456),"\x00\x34\x56";
is encode_BCD("1",2),"\x12";

        [download]
[reply]
[d/l]

Back to Seekers of Perl Wisdom