{
*****************************************************************************
* Magnetic Strip Card Reader for PC Compatible Computers using the LPT Port *
* and the Mitsubishi M54914/M56710 series of F2F decoder circuits. This *
* program is Public Domain and may be copied & used freely by anyone who *
* wants to. Connect the card reader chip to the PC LPT port like this: *
* *
* (See the data sheet for the Mitsubishi M54914/M56710 Chip for more info!) *
* *
* CLS ---> LPT Pin 13 = Orange *
* RCP ---> LPT Pin 12 = Red *
* RDT ---> LPT Pin 11 = Brown *
* +5V ---> LPT Pin 02-09 = Yellow *
* GND ---> LPT Pin 25 = Green *
* *
*****************************************************************************
}
Program Magstrip_Read;
Uses Crt, Dos;
Type Smallarray1=Array[1..16] of Byte;
SmallArray2=Array[1..16] of Char;
SmallArray3=Array[1..64] of Byte;
SmallArray4=Array[1..64] of Char;
Const ISO_BCD1:SmallArray1=($01,$10,$08,$19,$04,$15,$0d,$1c,$02,$13,$0b,$1a,$07,$16,$0e,$1f);
ISO_BCD2:SmallArray2=('0','1','2','3','4','5','6','7','8','9',':',';','<','=','>','?');
ISO_ALP1:SmallArray3=($01,$40,$20,$61,$10,$51,$31,$70,$08,$49,$29,$68,$19,$58,$38,
$79,$04,$45,$25,$64,$15,$54,$34,$75,$0d,$4c,$2c,$6d,$1c,$5d,$3d,$7c,$02,$43,$23,$62,
$13,$52,$32,$73,$0b,$4a,$2a,$6b,$1a,$5b,$3b,$7a,$07,$46,$26,$67,$16,$57,$37,$76,$0e,
$4f,$2f,$6e,$1f,$5e,$3e,$7f);
ISO_ALP2:SmallArray4=(' ','!','"','#','$','%','&',chr(39),'(',')','*','+',',','-','.',
'/','0','1','2','3','4','5','6','7','8','9',':',';','<','=','>','?','@','A','B','C','D',
'E','F','G','H','I','J','K','L','M','N','O','P','Q','R','S','T','U','V','W','X','Y','Z',
'[','\',']','~','_');
Var
Card_Bin:Array[1..4096] of Byte;
Card_BCD:Array[1..128] of Byte;
Card_Par:Array[1..128] of Boolean;
Card_ASC:Array[1..128] of Char;
Tbyte,ISO,Par_Chk,Par_Clc:Byte;
X,Y,Z,Bitcount,Ch_Count,Chstart,LPT:Integer;
Eflag,P_Err:Boolean;
Fpnt:Text;
Fpnt2:Text;
Key:Char;
Procedure Cardwait;
begin;
repeat
until port[LPT+1] and 16=0;
end;
Function Cardread:Integer;
Var X,Bitcount:Integer;
Begin;
X:=1;
repeat
repeat
If port[LPT+1] and 16=16 then break;
until port[LPT+1] and 32=0;
If port[LPT+1] and 128=128 then begin
Card_Bin[X]:=1;
end;
If port[LPT+1] and 128=0 then begin;
Card_Bin[X]:=0;
end;
repeat
If port[LPT+1] and 16=16 then break;
until port[LPT+1] and 32=32;
Bitcount:=X;
X:=X+1;
until port[LPT+1] and 16=16;
Cardread:=Bitcount;
end;
Function CardType:Byte;
Var Tbyte:Byte;
X:Integer;
Begin;
Tbyte:=0;
For X:=1 to Bitcount do begin
Tbyte:=Tbyte Shl 1;
If Card_Bin[X]=1 then Tbyte:=Tbyte or 1;
If (Tbyte and $1f)=$1a then begin;
Chstart:=(X-4);
Cardtype:=$1a;
Break;
end;
If (Tbyte and $7f)=$51 then begin;
Chstart:=(X-6);
Cardtype:=$51;
Break;
end;
end;
end;
Procedure ISO_BCD_2_ASC;
Var X,Y,Z:Integer;
Tbyte,P_Chk2,P_Chk3,P_Chk4,P_Chk5:Byte;
Eflag:Boolean;
Begin;
Z:=1;
Y:=Chstart;
Eflag:=False;
repeat
If Tbyte=$1f then Eflag:=True;
Tbyte:=0;
For X:=1 to 5 do begin
Tbyte:=Tbyte Shl 1;
If Card_Bin[Y]=1 then begin;
Tbyte:=Tbyte or 1;
end;
inc(y);
If Y>Bitcount then break;
end;
Card_BCD[Z]:=Tbyte;
Z:=Z+1;
If Y>Bitcount then break;
until Eflag=True;
Ch_Count:=Z-1;
Par_Chk:=Card_BCD[Z-1];
P_Err:=False;
For X:=1 to Ch_Count do begin;
Tbyte:=Card_BCD[X];
Y:=0;
For Z:=1 to 5 do begin;
Y:=Y+(Tbyte and 1);
Tbyte:=Tbyte Shr 1;
end;
If Y and 1<>0 then Card_Par[X]:=False
Else Card_Par[X]:=True;
end;
P_Chk5:=0;
P_Chk4:=0;
P_Chk3:=0;
P_Chk2:=0;
For X:=1 to Ch_Count-1 do begin;
Tbyte:=Card_BCD[X];
If Tbyte and 16<>0 then inc(P_Chk5);
If Tbyte and 8<>0 then inc(P_Chk4);
If Tbyte and 4<>0 then inc(P_Chk3);
If Tbyte and 2<>0 then inc(P_Chk2);
end;
Tbyte:=0;
If P_Chk5 and 1<>0 then Tbyte:=Tbyte or 16;
If P_Chk4 and 1<>0 then Tbyte:=Tbyte or 8;
If P_Chk3 and 1<>0 then Tbyte:=Tbyte or 4;
If P_Chk2 and 1<>0 then Tbyte:=Tbyte or 2;
Par_Clc:=Tbyte;
Z:=0;
For X:=1 to 5 do begin;
Z:=Z+(Tbyte and 1);
Tbyte:=Tbyte shr 1;
end;
If (Z and 1)=0 then Par_Clc:=Par_Clc or 1;
If Par_Chk<>Par_Clc then P_Err:=True;
Z:=0;
repeat
X:=0;
inc(z);
repeat
inc(x);
If (Card_BCD[Z] and $1e=ISO_BCD1[X] and $1e) then begin
Card_ASC[Z]:=ISO_BCD2[X];
Break;
end;
until X>16;
until Z=Ch_Count;
end;
Procedure ISO_ALP_2_ASC;
Var X,Y,Z:Integer;
Tbyte,P_Chk2,P_Chk3,P_Chk4,P_Chk5,P_Chk6,P_Chk7:Byte;
Eflag:Boolean;
Begin;
Z:=1;
Y:=Chstart;
Eflag:=False;
repeat
If Tbyte=$7c then Eflag:=True;
Tbyte:=0;
For X:=1 to 7 do begin
Tbyte:=Tbyte Shl 1;
If Card_Bin[Y]=1 then begin;
Tbyte:=Tbyte or 1;
end;
inc(y);
If Y>Bitcount then break;
end;
Card_BCD[Z]:=Tbyte;
Z:=Z+1;
If Y>Bitcount then break;
until Eflag=True;
Ch_Count:=Z-1;
Par_Chk:=Card_BCD[Z-1];
P_Err:=False;
For X:=1 to Ch_Count do begin;
Tbyte:=Card_BCD[X];
Y:=0;
For Z:=1 to 7 do begin;
Y:=Y+(Tbyte and 1);
Tbyte:=Tbyte Shr 1;
end;
If Y and 1<>0 then Card_Par[X]:=False
Else Card_Par[X]:=True;
end;
P_Chk7:=0;
P_Chk6:=0;
P_Chk5:=0;
P_Chk4:=0;
P_Chk3:=0;
P_Chk2:=0;
For X:=1 to Ch_Count-1 do begin;
Tbyte:=Card_BCD[X];
If Tbyte and 64<>0 then inc(P_Chk7);
If Tbyte and 32<>0 then inc(P_Chk6);
If Tbyte and 16<>0 then inc(P_Chk5);
If Tbyte and 8<>0 then inc(P_Chk4);
If Tbyte and 4<>0 then inc(P_Chk3);
If Tbyte and 2<>0 then inc(P_Chk2);
end;
Tbyte:=0;
If P_Chk7 and 1<>0 then Tbyte:=Tbyte or 64;
If P_Chk6 and 1<>0 then Tbyte:=Tbyte or 32;
If P_Chk5 and 1<>0 then Tbyte:=Tbyte or 16;
If P_Chk4 and 1<>0 then Tbyte:=Tbyte or 8;
If P_Chk3 and 1<>0 then Tbyte:=Tbyte or 4;
If P_Chk2 and 1<>0 then Tbyte:=Tbyte or 2;
Par_Clc:=Tbyte;
Z:=0;
For X:=1 to 7 do begin;
Z:=Z+(Tbyte and 1);
Tbyte:=Tbyte shr 1;
end;
If (Z and 1)=0 then Par_Clc:=Par_Clc or 1;
If Par_Chk<>Par_Clc then P_Err:=True;
Z:=0;
repeat
X:=0;
inc(z);
repeat
inc(x);
If (Card_BCD[Z] and $7e=ISO_ALP1[X] and $7e) then begin
Card_ASC[Z]:=ISO_ALP2[X];
Break;
end;
until X>64;
until Z=Ch_Count;
end;
Procedure Writebin;
Var X:Integer;
Begin;
writeln;
For X:=1 to Bitcount do begin;
If Card_Bin[X]=1 then write('1')
Else write('0');
end;
writeln;
end;
Procedure WriteASC;
Var X,Y,Z:Integer;
Begin;
For X:=1 to Ch_Count do begin;
write(Card_ASC[X]);
end;
writeln;
For X:=1 to Ch_Count do begin;
If Card_Par[X]=False then begin textcolor(Green);write('*');textcolor(white);end;
If Card_Par[X]=True then begin textcolor(Red+128);write('*');textcolor(white);end;
end;
writeln;
writeln;
write('Card Parity Checksum Status: ');
If P_Err=True then begin textcolor(Red+128);writeln('Error!!!');textcolor(white);end;
If P_Err=False then begin textcolor(Green+128);writeln('Okay!!!');textcolor(white);end;
end;
Begin;
repeat;
Clrscr;
write('Which LPT Port is the Cardreader Connected to? (1-3): ');
Key:=Readkey;
Case Key of
'1':LPT:=$3bc;
'2':LPT:=$378;
'3':LPT:=$278;
else
LPT:=$000;
end;
until LPT<>$000;
Port[LPT]:=$FF;
Assign(Fpnt,'CARDDATA.TXT');
Rewrite(Fpnt);
Repeat
ClrScr;
For X:=1 to 4096 do Card_BIN[X]:=0;
Textcolor(White+128);
Writeln('Please Swipe your card through the reader now!');
Textcolor(White);
Writeln;
Writeln;
Cardwait;
Bitcount:=Cardread;
Writebin;
writeln;
writeln;
ISO:=Cardtype;
If ISO=$1a then ISO_BCD_2_ASC;
If ISO=$51 then ISO_ALP_2_ASC;
WriteASC;
writeln;
writeln;
If (P_Err=False) and (Card_BCD[1]=$1a) then begin;
For X:=1 to Ch_Count do write(Fpnt,Card_ASC[X]);
Writeln(Fpnt);
end;
Assign(Fpnt2,'CARDBIN.TXT');
Rewrite(Fpnt2);
For X:=1 to Bitcount do begin;
If Card_Bin[X]=1 then write(Fpnt2,'1')
Else write(Fpnt2,'0');
end;
writeln(Fpnt2);
Close(Fpnt2);
Key:=Readkey;
Until Key=Chr(27);
Close(Fpnt);
Port[LPT]:=$00;
end.
TUCoPS is optimized to look best in Firefox® on a widescreen monitor (1440x900 or better).
Site design & layout copyright © 1986-2025 AOH
