#!/usr/local/bin/perl
#
#  An implementation of the USPS Intelligent Mail Barcode in perl
#
#
#  September 2010   Chris Howard   chris@elfpen.com
##############################################################
#  Version 1.2 - Jan 2011
#
#  Fixed bug in regex match/replacement.
##############################################################
#  Version 1.3 - Nov 2011
#
#  A few more comments added.  Routines basically unchanged.
##############################################################
#  Version 1.4 - 28 Nov 2011
#
#  Bug in boundry case in table_lookup routine was leading
#  to bad barcodes being generated in some cases
#  Author is gratified that someone in the googlesphere is
#  actually looking (and tested!).
##############################################################
#
#  Tested using the examples given in the IMB specification
#   available on the USPS website.  Otherwise... beware!
#
# Input: on STDIN, tracking code and routing code
#
#  Notes:  This thing follows the USPS Intelligent Mail Barcode
#  algorithm as given in the IMB specification doc available online.
#
#  The guts of it are in the USPS4CB subroutine.  The while
#  loop is just dressing to make it a complete program.
#  Run it and you can enter tracking and routing codes interactively.
#
#  You will probably need to change the path to the perl
#  executable on line #1 above.
#
#  This is intended as a teaching tool for formal
#  or informal teaching and personal enlightenment.
#  (possibly only as an example to be emulated
#  or avoided.) And as an easy way to get the table
#  data already in editable form.
#
#  There is no warranty, no fitness to a purpose, not any
#  implied usefulness, safety, nor reliability.
#  Therefore you are, and will remain, completely on your own.
#  If this scares you, find an expert and pay him for comfort
#  and direction.
#
##############################################################
#
#  Copyright and License
#
# This code is copyright 2010-2011, 2016  by Chris Howard
#
# This code is free software; you can redistribute it and/or
# modify it under the same terms as Perl 5.10.0. 
# For more details,  go to the perlfoundation.org website.
#
#

use Math::BigInt lib => 'GMP';

@table1 = (
31, 7936, 47, 7808, 55, 7552, 59, 7040, 61, 6016,
62, 3968, 79, 7744, 87, 7488, 91, 6976, 93, 5952,
94, 3904, 103, 7360, 107, 6848, 109, 5824, 110, 3776,
115, 6592, 117, 5568, 118, 3520, 121, 5056, 122, 3008,
124, 1984, 143, 7712, 151, 7456, 155, 6944, 157, 5920,
158, 3872, 167, 7328, 171, 6816, 173, 5792, 174, 3744,
179, 6560, 181, 5536, 182, 3488, 185, 5024, 186, 2976,
188, 1952, 199, 7264, 203, 6752, 205, 5728, 206, 3680,
211, 6496, 213, 5472, 214, 3424, 217, 4960, 218, 2912,
220, 1888, 227, 6368, 229, 5344, 230, 3296, 233, 4832,
234, 2784, 236, 1760, 241, 4576, 242, 2528, 244, 1504,
248, 992, 271, 7696, 279, 7440, 283, 6928, 285, 5904,
286, 3856, 295, 7312, 299, 6800, 301, 5776, 302, 3728,
307, 6544, 309, 5520, 310, 3472, 313, 5008, 314, 2960,
316, 1936, 327, 7248, 331, 6736, 333, 5712, 334, 3664,
339, 6480, 341, 5456, 342, 3408, 345, 4944, 346, 2896,
348, 1872, 355, 6352, 357, 5328, 358, 3280, 361, 4816,
362, 2768, 364, 1744, 369, 4560, 370, 2512, 372, 1488,
376, 976, 391, 7216, 395, 6704, 397, 5680, 398, 3632,
403, 6448, 405, 5424, 406, 3376, 409, 4912, 410, 2864,
412, 1840, 419, 6320, 421, 5296, 422, 3248, 425, 4784,
426, 2736, 428, 1712, 433, 4528, 434, 2480, 436, 1456,
440, 944, 451, 6256, 453, 5232, 454, 3184, 457, 4720,
458, 2672, 460, 1648, 465, 4464, 466, 2416, 468, 1392,
472, 880, 481, 4336, 482, 2288, 484, 1264, 488, 752,
527, 7688, 535, 7432, 539, 6920, 541, 5896, 542, 3848,
551, 7304, 555, 6792, 557, 5768, 558, 3720, 563, 6536,
565, 5512, 566, 3464, 569, 5000, 570, 2952, 572, 1928,
583, 7240, 587, 6728, 589, 5704, 590, 3656, 595, 6472,
597, 5448, 598, 3400, 601, 4936, 602, 2888, 604, 1864,
611, 6344, 613, 5320, 614, 3272, 617, 4808, 618, 2760,
620, 1736, 625, 4552, 626, 2504, 628, 1480, 632, 968,
647, 7208, 651, 6696, 653, 5672, 654, 3624, 659, 6440,
661, 5416, 662, 3368, 665, 4904, 666, 2856, 668, 1832,
675, 6312, 677, 5288, 678, 3240, 681, 4776, 682, 2728,
684, 1704, 689, 4520, 690, 2472, 692, 1448, 696, 936,
707, 6248, 709, 5224, 710, 3176, 713, 4712, 714, 2664,
716, 1640, 721, 4456, 722, 2408, 724, 1384, 728, 872,
737, 4328, 738, 2280, 740, 1256, 775, 7192, 779, 6680,
781, 5656, 782, 3608, 787, 6424, 789, 5400, 790, 3352,
793, 4888, 794, 2840, 796, 1816, 803, 6296, 805, 5272,
806, 3224, 809, 4760, 810, 2712, 812, 1688, 817, 4504,
818, 2456, 820, 1432, 824, 920, 835, 6232, 837, 5208,
838, 3160, 841, 4696, 842, 2648, 844, 1624, 849, 4440,
850, 2392, 852, 1368, 865, 4312, 866, 2264, 868, 1240,
899, 6200, 901, 5176, 902, 3128, 905, 4664, 906, 2616,
908, 1592, 913, 4408, 914, 2360, 916, 1336, 929, 4280,
930, 2232, 932, 1208, 961, 4216, 962, 2168, 964, 1144,
1039, 7684, 1047, 7428, 1051, 6916, 1053, 5892, 1054, 3844,
1063, 7300, 1067, 6788, 1069, 5764, 1070, 3716, 1075, 6532,
1077, 5508, 1078, 3460, 1081, 4996, 1082, 2948, 1084, 1924,
1095, 7236, 1099, 6724, 1101, 5700, 1102, 3652, 1107, 6468,
1109, 5444, 1110, 3396, 1113, 4932, 1114, 2884, 1116, 1860,
1123, 6340, 1125, 5316, 1126, 3268, 1129, 4804, 1130, 2756,
1132, 1732, 1137, 4548, 1138, 2500, 1140, 1476, 1159, 7204,
1163, 6692, 1165, 5668, 1166, 3620, 1171, 6436, 1173, 5412,
1174, 3364, 1177, 4900, 1178, 2852, 1180, 1828, 1187, 6308,
1189, 5284, 1190, 3236, 1193, 4772, 1194, 2724, 1196, 1700,
1201, 4516, 1202, 2468, 1204, 1444, 1219, 6244, 1221, 5220,
1222, 3172, 1225, 4708, 1226, 2660, 1228, 1636, 1233, 4452,
1234, 2404, 1236, 1380, 1249, 4324, 1250, 2276, 1287, 7188,
1291, 6676, 1293, 5652, 1294, 3604, 1299, 6420, 1301, 5396,
1302, 3348, 1305, 4884, 1306, 2836, 1308, 1812, 1315, 6292,
1317, 5268, 1318, 3220, 1321, 4756, 1322, 2708, 1324, 1684,
1329, 4500, 1330, 2452, 1332, 1428, 1347, 6228, 1349, 5204,
1350, 3156, 1353, 4692, 1354, 2644, 1356, 1620, 1361, 4436,
1362, 2388, 1377, 4308, 1378, 2260, 1411, 6196, 1413, 5172,
1414, 3124, 1417, 4660, 1418, 2612, 1420, 1588, 1425, 4404,
1426, 2356, 1441, 4276, 1442, 2228, 1473, 4212, 1474, 2164,
1543, 7180, 1547, 6668, 1549, 5644, 1550, 3596, 1555, 6412,
1557, 5388, 1558, 3340, 1561, 4876, 1562, 2828, 1564, 1804,
1571, 6284, 1573, 5260, 1574, 3212, 1577, 4748, 1578, 2700,
1580, 1676, 1585, 4492, 1586, 2444, 1603, 6220, 1605, 5196,
1606, 3148, 1609, 4684, 1610, 2636, 1617, 4428, 1618, 2380,
1633, 4300, 1634, 2252, 1667, 6188, 1669, 5164, 1670, 3116,
1673, 4652, 1674, 2604, 1681, 4396, 1682, 2348, 1697, 4268,
1698, 2220, 1729, 4204, 1730, 2156, 1795, 6172, 1797, 5148,
1798, 3100, 1801, 4636, 1802, 2588, 1809, 4380, 1810, 2332,
1825, 4252, 1826, 2204, 1857, 4188, 1858, 2140, 1921, 4156,
1922, 2108, 2063, 7682, 2071, 7426, 2075, 6914, 2077, 5890,
2078, 3842, 2087, 7298, 2091, 6786, 2093, 5762, 2094, 3714,
2099, 6530, 2101, 5506, 2102, 3458, 2105, 4994, 2106, 2946,
2119, 7234, 2123, 6722, 2125, 5698, 2126, 3650, 2131, 6466,
2133, 5442, 2134, 3394, 2137, 4930, 2138, 2882, 2147, 6338,
2149, 5314, 2150, 3266, 2153, 4802, 2154, 2754, 2161, 4546,
2162, 2498, 2183, 7202, 2187, 6690, 2189, 5666, 2190, 3618,
2195, 6434, 2197, 5410, 2198, 3362, 2201, 4898, 2202, 2850,
2211, 6306, 2213, 5282, 2214, 3234, 2217, 4770, 2218, 2722,
2225, 4514, 2226, 2466, 2243, 6242, 2245, 5218, 2246, 3170,
2249, 4706, 2250, 2658, 2257, 4450, 2258, 2402, 2273, 4322,
2311, 7186, 2315, 6674, 2317, 5650, 2318, 3602, 2323, 6418,
2325, 5394, 2326, 3346, 2329, 4882, 2330, 2834, 2339, 6290,
2341, 5266, 2342, 3218, 2345, 4754, 2346, 2706, 2353, 4498,
2354, 2450, 2371, 6226, 2373, 5202, 2374, 3154, 2377, 4690,
2378, 2642, 2385, 4434, 2401, 4306, 2435, 6194, 2437, 5170,
2438, 3122, 2441, 4658, 2442, 2610, 2449, 4402, 2465, 4274,
2497, 4210, 2567, 7178, 2571, 6666, 2573, 5642, 2574, 3594,
2579, 6410, 2581, 5386, 2582, 3338, 2585, 4874, 2586, 2826,
2595, 6282, 2597, 5258, 2598, 3210, 2601, 4746, 2602, 2698,
2609, 4490, 2627, 6218, 2629, 5194, 2630, 3146, 2633, 4682,
2641, 4426, 2657, 4298, 2691, 6186, 2693, 5162, 2694, 3114,
2697, 4650, 2705, 4394, 2721, 4266, 2753, 4202, 2819, 6170,
2821, 5146, 2822, 3098, 2825, 4634, 2833, 4378, 2849, 4250,
2881, 4186, 2945, 4154, 3079, 7174, 3083, 6662, 3085, 5638,
3086, 3590, 3091, 6406, 3093, 5382, 3094, 3334, 3097, 4870,
3107, 6278, 3109, 5254, 3110, 3206, 3113, 4742, 3121, 4486,
3139, 6214, 3141, 5190, 3145, 4678, 3153, 4422, 3169, 4294,
3203, 6182, 3205, 5158, 3209, 4646, 3217, 4390, 3233, 4262,
3265, 4198, 3331, 6166, 3333, 5142, 3337, 4630, 3345, 4374,
3361, 4246, 3393, 4182, 3457, 4150, 3587, 6158, 3589, 5134,
3593, 4622, 3601, 4366, 3617, 4238, 3649, 4174, 3713, 4142,
3841, 4126, 4111, 7681, 4119, 7425, 4123, 6913, 4125, 5889,
4135, 7297, 4139, 6785, 4141, 5761, 4147, 6529, 4149, 5505,
4153, 4993, 4167, 7233, 4171, 6721, 4173, 5697, 4179, 6465,
4181, 5441, 4185, 4929, 4195, 6337, 4197, 5313, 4201, 4801,
4209, 4545, 4231, 7201, 4235, 6689, 4237, 5665, 4243, 6433,
4245, 5409, 4249, 4897, 4259, 6305, 4261, 5281, 4265, 4769,
4273, 4513, 4291, 6241, 4293, 5217, 4297, 4705, 4305, 4449,
4359, 7185, 4363, 6673, 4365, 5649, 4371, 6417, 4373, 5393,
4377, 4881, 4387, 6289, 4389, 5265, 4393, 4753, 4401, 4497,
4419, 6225, 4421, 5201, 4425, 4689, 4483, 6193, 4485, 5169,
4489, 4657, 4615, 7177, 4619, 6665, 4621, 5641, 4627, 6409,
4629, 5385, 4633, 4873, 4643, 6281, 4645, 5257, 4649, 4745,
4675, 6217, 4677, 5193, 4739, 6185, 4741, 5161, 4867, 6169,
4869, 5145, 5127, 7173, 5131, 6661, 5133, 5637, 5139, 6405,
5141, 5381, 5155, 6277, 5157, 5253, 5187, 6213, 5251, 6181,
5379, 6165, 5635, 6157, 6151, 7171, 6155, 6659, 6163, 6403,
6179, 6275, 6211, 5189, 4681, 4433, 4321, 3142, 2634, 2386,
2274, 1612, 1364, 1252, 856, 744, 496
);


@table2 = (
3, 6144, 5, 5120, 6, 3072, 9, 4608, 10, 2560,
12, 1536, 17, 4352, 18, 2304, 20, 1280, 24, 768,
33, 4224, 34, 2176, 36, 1152, 40, 640, 48, 384,
65, 4160, 66, 2112, 68, 1088, 72, 576, 80, 320,
96, 192, 129, 4128, 130, 2080, 132, 1056, 136, 544,
144, 288, 257, 4112, 258, 2064, 260, 1040, 264, 528,
513, 4104, 514, 2056, 516, 1032, 1025, 4100, 1026, 2052,
2049, 4098, 4097, 2050, 1028, 520, 272, 160
);

@descenders = (
H, B, J, F, I, A, C, E, G, D,
F, I, J, H, D, A, G, B, H, E,
G, I, J, C, F, B, H, F, E, D,
I, H, G, A, C, F, E, J, D, A,
B, G, I, C, A, E, F, J, G, H,
F, C, G, D, I, F, B, J, I, H,
E, A, C, G, D
);

@dbit = (
0x0004, 0x0400, 0x1000, 0x0020, 0x0200, 0x0002, 0x0020, 0x0010, 0x0008, 0x0200,
0x0800, 0x0020, 0x0400, 0x0002, 0x0040, 0x0008, 0x0010, 0x0002, 0x0400, 0x0001,
0x0004, 0x0800, 0x0100, 0x0040, 0x0002, 0x1000, 0x0008, 0x0100, 0x0040, 0x0010,
0x0010, 0x0800, 0x0001, 0x0040, 0x0002, 0x0200, 0x0800, 0x0020, 0x0008, 0x0080,
0x0008, 0x0400, 0x0080, 0x0800, 0x0100, 0x0004, 0x0400, 0x0008, 0x0020, 0x0100,
0x0001, 0x0008, 0x1000, 0x0800, 0x0100, 0x0010, 0x0020, 0x0002, 0x0008, 0x0001,
0x0080, 0x1000, 0x0200, 0x0100, 0x0400
);


@ascenders = (
E, A, C, G, D, F, B, J, I, H,
B, C, A, G, E, I, C, J, F, D,
A, B, D, H, E, G, I, J, C, A,
F, B, J, E, D, I, G, H, B, C,
E, D, J, F, H, I, D, A, C, B,
E, A, J, B, H, A, C, E, G, D,
H, B, J, F, I
);

@abit = (
0x0008, 0x0001, 0x0100, 0x0800, 0x0002, 0x1000, 0x0100, 0x0800, 0x0400, 0x0040,
0x0010, 0x1000, 0x0004, 0x0080, 0x0200, 0x0040, 0x0080, 0x0200, 0x0004, 0x0100,
0x0010, 0x0001, 0x1000, 0x0080, 0x0400, 0x0200, 0x0001, 0x0080, 0x0400, 0x0020,
0x0080, 0x0200, 0x0040, 0x0100, 0x0004, 0x1000, 0x0002, 0x0010, 0x0004, 0x0001,
0x0002, 0x0020, 0x0010, 0x0040, 0x1000, 0x0002, 0x0001, 0x0200, 0x0010, 0x0080,
0x0020, 0x0400, 0x0004, 0x0040, 0x0200, 0x0800, 0x0004, 0x1000, 0x0040, 0x0080,
0x0020, 0x0800, 0x0001, 0x0008, 0x0004
);

%FCS_MAP = (
	A => 0x001,
	B => 0x002,
	C => 0x004,
	D => 0x008,
	E => 0x010,
	F => 0x020,
	G => 0x040,
	H => 0x080,
	I => 0x100,
	J => 0x200
);

foreach $key (keys %FCS_MAP)
{
	$values{$key} = 0;
}



while(<>)
{
	($t,$r) = split();

	$return_code = USPS4CB($t,$r);
	if( $return_code == 1 )
	{
		printf "Selftest failed\n";
	} elsif( $return_code == 2 ) {
		printf "Output barcode string is null\n";
	} elsif( $return_code == 3 ) {
		printf "Encoder byte conversion failed\n";
	} elsif( $return_code == 4 ) {
		printf "Encoder retrieve table failed\n";
	} elsif( $return_code == 5 ) {
		printf "Encoder codeword conversion failed\n";
	} elsif( $return_code == 6 ) {
		printf "Encoder character range error\n";
	} elsif( $return_code == 7 ) {
		printf "Input Tracking Code is null\n";
	} elsif( $return_code == 8 ) {
		printf "Input Routing Code is null\n";
	} elsif( $return_code == 9 ) {
		printf "Input Tracking Code must have 20 digits\n";
	} elsif( $return_code == 10 ) {
		printf "Input Tracking Code must contain digits 0-9\n";
	} elsif( $return_code == 11 ) {
		printf "Input Tracking Code second digit must contain digits 0-4\n";
	} elsif( $return_code == 12 ) {
		printf "Input Routing Code must be 0,5,9 or 11 digits in length\n";
	} elsif( $return_code == 13 ) {
		printf "Input Routing Code must contain digits 0-9\n";
	} else {
		printf "%s\n\n", $return_code;
	}
}

	


sub USPS4CB
{
	my($t,$r) = @_;   # tracking code, routing code

	my($answer) = '';
	

printf STDERR " Tracking: |$t|  Routing: |$r|   ";
	if( $t =~ m/^$/ )
	{
		return 7; #tracking code is null
	}
	if( $t !~ m/^[0-9]*$/ )
	{
		return 10;   # something other than 0-9
	}
	if( $t !~ m/^\d\d\d\d\d\d\d\d\d\d\d\d\d\d\d\d\d\d\d\d$/ )
	{
		return 9;   # not 20 digits
	}
	my $tB = Math::BigInt->new($t);


	if( $r =~ m/^$/ )
	{
		# return 8;   # empty routing code  ... this is OK!
	}
	if( $r !~ m/^[0-9]*$/ )
	{
		return 13;   # something other than 0-9
	}
	if( $r =~ m/^\d\d\d\d\d\d\d\d\d\d\d$/ )
	{
		 printf STDERR  "11 digits\n";
		$bd = $r + 1000000000 + 100000 + 1;
	}
	elsif( $r =~ m/^\d\d\d\d\d\d\d\d\d$/ )
	{
		 printf STDERR  "9 digits\n";
		$bd = $r + 100000 + 1;
	}
	elsif( $r =~ m/^\d\d\d\d\d$/ )
	{
		 printf STDERR  "5 digits\n";
		$bd = $r + 1;
	}
	elsif( $r =~ m/^$/ )
	{
		 printf STDERR  "0 digits\n";
		$bd = 0;
	}
	else
	{
		printf STDERR  "Routing code error\n";
		return 12;
	}
	my $rB = Math::BigInt->new($bd);
# printf STDERR  " %s %s\n",$rB->bstr(), $rB->as_hex();

 	$one = substr($t,0,1);
 	$two = substr($t,1,1);
	$rest = substr($t,2,18);

	if( $two !~ m/^[01234]$/ )
	{
		return 11;    #  second ditit of tracking code must be 0-4
	}

	$oneB =  Math::BigInt->new($one);
	$twoB =  Math::BigInt->new($two);
	$restB =  Math::BigInt->new($rest);

# printf STDERR  "one %s  two %s rest %s\n", $one, $two, $rest;

	$rB -> bmul(10);
	$rB -> badd($oneB);

	$rB -> bmul(5);
	$rB -> badd($twoB);

	$rB->blsft(18,10);        # left shift by $y places in base $n
	$rB -> badd($restB);

	$r_hex =  $rB->as_hex();
	$r_hex =~ s/^0x//;

	$ok = sprintf "%026s", $r_hex;

 printf STDERR "  Binary: %026s\n", $r_hex;

	$raw = pack('H26',$ok);

#	$hex = unpack('H*',$raw);
# printf  STDERR  $hex ."\n"; 

	$FCS = fcs($raw);
 printf  STDERR " FCS: %04x %#b\n", $FCS,$FCS;

	($quo,$values{'J'}) = $rB->bdiv(636);
	($quo,$values{'I'}) = $rB->bdiv(1365);
	($quo,$values{'H'}) = $rB->bdiv(1365);
	($quo,$values{'G'}) = $rB->bdiv(1365);
	($quo,$values{'F'}) = $rB->bdiv(1365);
	($quo,$values{'E'}) = $rB->bdiv(1365);
	($quo,$values{'D'}) = $rB->bdiv(1365);
	($quo,$values{'C'}) = $rB->bdiv(1365);
	($quo,$values{'B'}) = $rB->bdiv(1365);
	$values{'A'} = $rB->bstr();

	foreach $key (sort(keys %values))
	{
		printf STDERR  "%s %04d ", $key, $values{$key};
	}
	printf STDERR  "\n";

	$values{'J'} = $values{'J'} * 2;

	if( $FCS & 0x0400 )
	{
		$values{'A'} += 659;
	}

	foreach $key (sort(keys %values))
	{
		printf STDERR  "%s %04d ", $key, $values{$key};
	}
	printf STDERR "\n";

	foreach $key (sort(keys %values))
	{
		$values{$key} = table_lookup($values{$key});
	}

	foreach $key (sort(keys %values))
	{
		printf STDERR "%s %04x :", $key, $values{$key};
	}
	printf STDERR "\n";

	foreach $key (keys %values)
	{
		$values{$key} = flip($values{$key},($FCS_MAP{$key} & $FCS));
	}

	foreach $key (sort(keys %values))
	{
		printf STDERR "%s %04x :", $key, $values{$key};
	}
	printf STDERR "\n";

	for( $bar = 0; $bar < 65; $bar++ )
	{

# printf STDERR "bar $bar \td $descenders[$bar]\tm $dmasks[$bar]\n";
		if( $values{$descenders[$bar]} & $dbit[$bar] )
		{
			if( $values{$ascenders[$bar]} & $abit[$bar] )
			{
				$bars[$bar] = 'F';   # both ascender and descender
			}
			else
			{
				$bars[$bar] = 'D';   # only descender
			}
		}
		else
		{
			if( $values{$ascenders[$bar]} & $abit[$bar] )
			{
				$bars[$bar] = 'A';   # only ascender
			}
			else
			{
				$bars[$bar] = 'T';   # neither 
			}
		}

	#	printf "$bars[$bar]";
	#	if( $bar % 5 == 0 )
	#	{
	#		print ' ';
	#	}
		$answer .= $bars[$bar];
	}

	
	

	return  $answer;


	# printf "\n\n";
	
}

sub table_lookup
{
	my($num) = @_;
	my($othernum) = $num - 1287;
	my($rc);


# printf "table_lookup:  $num |";
	# 28-NOV-2011  this test changed to >= 
	if( $othernum >= 0 )
	{ 
		$rc =  $table2[$othernum];
# printf " table2 by $othernum :: $rc\n";
	}
	else
	{
		$rc = $table1[$num];
# printf " table1 $num  :: $rc\n";
	}
	return $rc;
}

sub flip
{
	my($num, $flag) = @_;

	if( $flag )
	{
# printf "flip $key \n";
		return (~$num & 0x1FFF);   #mask at 13 bits
	}
	else
	{
		return ($num);
	}
}
sub fcs
{
	my($raw) = @_;    # an packed string of 13 bytes of binary data

	my $GeneratorPolynomial = 0x0F35;
	my $FrameCheckSequence = 0x07FF;
	my $FCConstant = 0x07FF;
	my $Constant = 0x0400;
	my $byte, $bit;
	my @bytes = unpack('C13',$raw);
	my $Data = 0;

	$hex = unpack('H*',$raw);
# printf "fcs: |%#x|%#x|%#x|%#x|%#x|%#x|%#x|%#x|%#x|%#x|%#x|%#x|%#x| scalar $hex %x  \n",
#			$bytes[0], $bytes[1], $bytes[2], $bytes[3], 
#			$bytes[4], $bytes[5], $bytes[6], $bytes[7], 
#			$bytes[8], $bytes[9], $bytes[10], $bytes[11], $bytes[12] ;

	$Data = $bytes[0] << 5;
	for( $bit = 2; $bit < 8; $bit++ )
	{
# printf "fcs:\t\t\t\t $bit FC |%#x|%#b| data |%#x|%#b|\n", $FrameCheckSequence,$FrameCheckSequence,$Data,$Data;
		if( (($FrameCheckSequence ^ $Data) & $Constant) > 1 )
		{
			$FrameCheckSequence = (($FrameCheckSequence << 1) ^ $GeneratorPolynomial);
		}
		else
		{
			$FrameCheckSequence <<= 1;
		}
		$FrameCheckSequence &= $FCConstant;
		$Data <<= 1;
	}

# printf "fcs:\t\t  FC |%#x|%#b| \n", $FrameCheckSequence,$FrameCheckSequence;
	for( $byte = 1; $byte < 13; $byte++ )
	{
		$Data = $bytes[$byte] << 3;
		for( $bit = 0; $bit < 8; $bit++ )
		{
# printf "fcs:\t\t\t\t $bit FC |%#x|%#b| data |%#x|%#b| xor |%#x|%#b|\n",
#		$FrameCheckSequence,$FrameCheckSequence,$Data,$Data,
#		($FrameCheckSequence ^ $Data), ($FrameCheckSequence ^ $Data);

			if( (($FrameCheckSequence ^ $Data) & $Constant) > 1 )
			{
				$FrameCheckSequence = (($FrameCheckSequence << 1) ^ $GeneratorPolynomial);
# printf "fcs:\t\t  G FC |%#x|%#b| \n", $FrameCheckSequence,$FrameCheckSequence;
			}
			else
			{
				$FrameCheckSequence <<= 1;
# printf "fcs:\t\t  FC |%#x|%#b| \n", $FrameCheckSequence,$FrameCheckSequence;
			}
			$FrameCheckSequence &= $FCConstant;
			$Data <<= 1;
		}
	}
# printf "fcs returning $FrameCheckSequence\n";
	return $FrameCheckSequence;
}