Visit our newest sister site!
Hundreds of free aircraft flight manuals
Civilian • Historical • Military • Declassified • FREE!


TUCoPS :: Hardware Hacks :: magcard3.pas

Pascal Source for a Magnetic Stripe Card Reader




{
*****************************************************************************
* 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-2014 AOH