unit Reader;

interface
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls,WinSCard, SCardErr, WinSmCrd;

type
  TDelimiters        = set of Char;

//Buffer size
const
  NUMBER_OF_READERS =4;
  NAME_LENGTH       =100;
  MAX_RESPONSE      =600;
  MAX_APDU_BUFFER   =1024;

//Error
  ERROR_GENERAL     =$FFFE;
  SUCCESS           =$9000;

//Get Data type
  GET_MIFAREONE     =$0000;
  GET_TYPEA_SMART_CARD=$0100;
  GET_ULTRALIGHT    =$0200;
  GET_MIFAREPLUS_L0 =$0300;
  GET_MIFAREPLUS_L1 =$0301;
  GET_MIFAREPLUS_L2 =$0302;
  GET_MIFAREPLUS_L3 =$0303;
  GET_MIFAREPLUS_L0S=$0304;
  GET_TYPEB_SMART_CARD=$2000;
  GET_SR176         =$2100;
  GET_SRIX4K        =$2200;
  GET_AT88F020      =$2300;
  GET_SRI512        =$2200;
  GET_ISO15693      =$4000;
  GET_SAM_1         =$6000;
  GET_SAM_2         =$6001;
  GET_SAM_3         =$6002;
  GET_SAM_4         =$6003;

//Protocol
  SCARD_PCI_T0       : SCARD_IO_REQUEST = (dwProtocol:1; dbPciLength:8);
  SCARD_PCI_T1       : SCARD_IO_REQUEST = (dwProtocol:2; dbPciLength:8);

//变量定义
var
m_bProtocolType:Longint;							            //PC/SC Reader 当前协议
DeviceContext:cardinal;						                //PC/SC Reader 设备描述符
m_bReaderCounter:Word;				                    //Reader 个数
m_bActiveNO:Word;						                      //当前激活的Reader是哪一个
m_bActiveFlag:Boolean = FALSE;								    //是否有激活Reader
ReaderName: array[0..NUMBER_OF_READERS] of string;//所有Reader名字
SendAPDU: array[0..MAX_APDU_BUFFER] of Byte;			//发送APDU Buffer
ReceiveAPDU: array[0..MAX_APDU_BUFFER] of Byte;		//接收APDU Buffer
hScardHandle:Integer;						                  //Reader 句柄   THandle= Cardinal

//函数申明
function UpdataReader():Word;
function DisconnectReader():Boolean;
function ConnectReader(ReaderNo: Word): Boolean;
function APDUCommand(APDU:PByte; iLen: Word; cReceiveData: PByte; var iReceiveLen: Word): Word;
function GetData(iCardType:Word; cReceiveData: PByte; var iReceiveLen:Word):Word;
function Authentication(iBlockAddr:Word; cKeyType:Byte; cKeyCofig:Byte; cpKeyData:PByte):Word;
function ReadBinaryBlock(iBlockAddr:Word; cReceiveData:PByte; var iReceiveLen:Word):Word;
function UpdataBinaryBlock(iBlockAddr:Word; cSendData:PByte; iDataLen:Word):Word;
function ValueBlockOperation(iBlockAddr:Word; cOperateType:Byte; iValue:Longint):Word;
function ReadValueBlock(iBlockAddr:Word; var iValue:Longint):Word;
function RestoreValueBlock(iSrcAddr:Word; iTargetAddr:Word):Word;
function TypeA_Halt():Word;

implementation

//字符串
function SortOutSubstrings(const From:string; var t:array of string; const Delim:TDelimiters = [' ',';']; const ConcatDelim:boolean = true):integer;
var a,b,s,i : integer;
    sep     : boolean;
begin
  a := 1;
  b := Low(t);
  s := 1;
  i := 0;
  sep := ConcatDelim;
  t[b] := '';

  while a <= Length(From) do
    begin
      if not (From[a] in Delim) then
      begin
        Inc(i);
        sep := false;
      end else
      begin
        if not sep then
        begin
          t[b] := Copy(From, s, i);
          Inc(b);
          if b > High(t) then Break;
          t[b] := '';
        end;
        if ConcatDelim then sep := true;
        s := a + 1;
        i := 0;
      end;
      Inc(a);
    end;

    if (b <= High(t)) and (i > 0) then
    begin
      t[b] := Copy(From, s, i);
      Inc(b);
    end;

    for a := b + 1 to High(t) do t[a] := '';
      Result := b;
end;

//Updata Reader number
//Return Reader number
function UpdataReader():Word;
var
  lReturn:Longint;
  ReaderListSize : integer;
  ReaderList     : string;
  i              : integer;
begin
	//Get PC/SC devicecontext
	m_bActiveFlag     := FALSE;
	m_bActiveNO       := 0;
	m_bReaderCounter  := 0;

	//Is connected
	if(m_bActiveFlag) then
	begin
		//Connected
		SCardDisconnect(hScardHandle,SCARD_EJECT_CARD);
		SCardReleaseContext(DeviceContext);
	end;

	//Establish deveice context
	lReturn := SCardEstablishContext(SCARD_SCOPE_USER,nil,nil,@DeviceContext);
	if(SCARD_S_SUCCESS = lReturn) then
	begin
		//success：List all device context
    lReturn := SCardListReadersA(DeviceContext, nil, nil,ReaderListSize);
    if lReturn = SCARD_S_SUCCESS then
    begin
      SetLength(ReaderList, ReaderListSize);
      SCardListReadersA(DeviceContext, nil, Pointer(ReaderList), ReaderListSize);

     SortOutSubstrings(ReaderList,ReaderName,[#0]);
      for i := 0 to NUMBER_OF_READERS do
      begin
        if ReaderName[i] <> '' then m_bReaderCounter := m_bReaderCounter+1;
      end;
			Result := m_bReaderCounter;
      Exit;
    end;
	end;
	Result := 0;
end;

//Connect Reader
function ConnectReader(ReaderNo: Word): Boolean;
var
  lReturn:Longint;
  ActiveProtocol:Longword;
begin
	//Reader count
	if (m_bReaderCounter < (ReaderNO+1)) then
	begin
		Result := FALSE;
    Exit;
	end;

	if(m_bActiveFlag = FALSE) then
	begin
		//Connect Reader
		SCardDisconnect(hScardHandle,SCARD_EJECT_CARD);
		m_bProtocolType := SCARD_PROTOCOL_T0 or SCARD_PROTOCOL_T1;
		lReturn := SCardConnectA(DeviceContext,PChar(ReaderName[ReaderNO]),SCARD_SHARE_EXCLUSIVE, m_bProtocolType, hScardHandle, @ActiveProtocol);
		if(SCARD_S_SUCCESS = lReturn) then
		begin
			m_bProtocolType := ActiveProtocol;
			m_bActiveNO     := ReaderNO;
			m_bActiveFlag   := TRUE;

			Result := TRUE;
      Exit;
		end;
	end;
	Result := FALSE;
end;

//Disconnect reader
function DisconnectReader():Boolean;
var
  lReturn:Longint;
begin
	if(m_bActiveFlag) then
	begin
		lReturn := SCardDisconnect(hScardHandle,SCARD_EJECT_CARD);
		if(SCARD_S_SUCCESS <> lReturn) then
		begin
			Result := FALSE;
      Exit;
		end;
	end;

	m_bActiveFlag := FALSE;
	Result :=  TRUE;
end;

//Send APDU
function APDUCommand(APDU:PByte; iLen: Word; cReceiveData: PByte; var iReceiveLen: Word): Word;
var
  cReceive:array[0..MAX_RESPONSE] of Byte;
  lReturn:Longint;
  SW1,SW2:Byte;
  IO_Request:Pointer;
  ReceiveLen:DWORD;
begin
  case m_bProtocolType of
    SCARD_PROTOCOL_T0 : IO_Request := @SCARD_PCI_T0;
    SCARD_PROTOCOL_T1 : IO_Request := @SCARD_PCI_T1;
    else                IO_Request := nil;
    end;
	ReceiveLen := MAX_RESPONSE+1;

	lReturn := SCardTransmit(hScardHandle, IO_Request, APDU, iLen, nil, @cReceive[0], @ReceiveLen);

	if(lReturn <> SCARD_S_SUCCESS) then
	begin
	  iReceiveLen := 0;
		Result := $FFFF;
    Exit;
	end;
  CopyMemory(cReceiveData, @cReceive[0], ReceiveLen);
	iReceiveLen := ReceiveLen-2;
	SW1 := cReceive[ReceiveLen - 2];
	SW2 := cReceive[ReceiveLen - 1];
	Result := makeword(SW2,SW1);
end;

//Get DATA APDU
function GetData(iCardType:Word; cReceiveData: PByte; var iReceiveLen:Word):Word;
var
  iSW:Word;
begin
	iSW := ERROR_GENERAL;

	if(m_bActiveFlag) then
	begin
		SendAPDU[0] :=$FF;
		SendAPDU[1] :=$CA;
		SendAPDU[2] :=(iCardType shr 8) and $FF;
		SendAPDU[3] :=iCardType and $FF;
		SendAPDU[4] :=$00;

		iSW := APDUCommand(@SendAPDU[0], 5, cReceiveData, iReceiveLen);
	end;
	Result := iSW;
end;

//Authentication APDU
function Authentication(iBlockAddr:Word; cKeyType:Byte; cKeyCofig:Byte; cpKeyData:PByte):Word;
var
  iSW,iReceiveLen,iSendLen:Word;
begin
	iSW := ERROR_GENERAL;
	iReceiveLen := 0;

	if(m_bActiveFlag) then
	begin
		SendAPDU[0] :=$FF;
		SendAPDU[1] :=$88;
		SendAPDU[2] :=(iBlockAddr shr 8) and $FF;
		SendAPDU[3] :=iBlockAddr and $FF;
		SendAPDU[4] :=cKeyType;
		SendAPDU[5] :=cKeyCofig;

		if((cKeyCofig and $80) <> 0) then
		begin
			//Authentication use saved key in flash
 			SendAPDU[6] := cpKeyData^;
			iSendLen := 7;
		end
		else
		begin
			//Authentication use current inputing key
			iSendLen := 6+cKeyCofig;
			CopyMemory(@SendAPDU[6], cpKeyData, cKeyCofig);
		end;

		iSW := APDUCommand(@SendAPDU[0], iSendLen, @ReceiveAPDU[0], iReceiveLen);
	end;
	
	Result := iSW;
end;

//Read card block
function ReadBinaryBlock(iBlockAddr:Word; cReceiveData:PByte; var iReceiveLen:Word):Word;
var
  iSW:Word;
begin
	iSW := ERROR_GENERAL;

	if(m_bActiveFlag) then
	begin
		SendAPDU[0] :=$FF;
		SendAPDU[1] :=$B0;
		SendAPDU[2] :=(iBlockAddr shr 8) and $FF;
		SendAPDU[3] := iBlockAddr and $FF;
 		SendAPDU[4] := iReceiveLen and $FF;

		iSW := APDUCommand(@SendAPDU[0], 5, @ReceiveAPDU[0], iReceiveLen);
		if(SUCCESS = iSW) then
		begin
			CopyMemory(cReceiveData, @ReceiveAPDU[0], iReceiveLen);
		end;
	end;

	Result := iSW;
end;

//Write card block
function UpdataBinaryBlock(iBlockAddr:Word; cSendData:PByte; iDataLen:Word):Word;
var
  iSW,iReceiveLen,iSendLen:Word;
begin
	iSW := ERROR_GENERAL;
	iReceiveLen := 0;
	
	if(m_bActiveFlag) then
	begin
		SendAPDU[0] :=$FF;
		SendAPDU[1] :=$D6;
		SendAPDU[2] :=(iBlockAddr shr 8)and $FF;
		SendAPDU[3] :=iBlockAddr and $FF;
		SendAPDU[4] :=iDataLen and $FF;

 		CopyMemory(@SendAPDU[5], cSendData, iDataLen);
		iSendLen := 5+iDataLen;
		
		iSW := APDUCommand(@SendAPDU[0], iSendLen, @ReceiveAPDU[0], iReceiveLen);
	end;

	Result := iSW;
end;

//Value operation: Initialize purse(00), increase purse(01), decrease purse(02)
function ValueBlockOperation(iBlockAddr:Word; cOperateType:Byte; iValue:Longint):Word;
var
  iSW,iReceiveLen:Word;
begin
	iSW := ERROR_GENERAL;
	iReceiveLen := 0;

	if(m_bActiveFlag) then
	begin
		SendAPDU[0] :=$FF;
		SendAPDU[1] :=$D7;
		SendAPDU[2] :=(iBlockAddr shr 8) and $FF;
		SendAPDU[3] :=iBlockAddr and $FF;
		SendAPDU[4] :=$05;
		SendAPDU[5] := cOperateType;
		SendAPDU[9] :=(iValue shr 24) and $FF;
		SendAPDU[8] :=(iValue shr 16) and $FF;
		SendAPDU[7] :=(iValue shr 8) and $FF;
		SendAPDU[6] :=iValue and $FF;
		
		iSW := APDUCommand(@SendAPDU[0], 10, @ReceiveAPDU[0], iReceiveLen);
	end;
	
	Result := iSW;
end;

//read purse
function ReadValueBlock(iBlockAddr:Word; var iValue:Longint):Word;
var
  iSW, iReceiveLen:Word;
begin
	iSW := ERROR_GENERAL;
	iReceiveLen := 0;
	
	if(m_bActiveFlag) then
	begin
		SendAPDU[0] :=$FF;
		SendAPDU[1] :=$B1;
		SendAPDU[2] :=(iBlockAddr shr 8) and $FF;
		SendAPDU[3] := iBlockAddr and $FF;
		SendAPDU[4] :=$04;
		
		iSW := APDUCommand(@SendAPDU[0], 5, @ReceiveAPDU[0], iReceiveLen);
		if(SUCCESS = iSW) then
		begin
      CopyMemory(Pointer(iValue),@ReceiveAPDU[0],4);
		end;
	end;

	Result := iSW;
end;

//backup purse
function RestoreValueBlock(iSrcAddr:Word; iTargetAddr:Word):Word;
var
  iSW, iReceiveLen:Word;
begin
	iSW := ERROR_GENERAL;
	iReceiveLen := 0;
	
	if(m_bActiveFlag) then
	begin
		SendAPDU[0] :=$FF;
		SendAPDU[1] :=$D7;
		SendAPDU[2] :=(iSrcAddr shr 8) and $FF;;
		SendAPDU[3] := iSrcAddr and $FF;
		SendAPDU[4] :=$03;
		SendAPDU[5] :=$03;
		SendAPDU[6] := (iTargetAddr shr 8) and $FF;
		SendAPDU[7] := iTargetAddr and $FF;

		iSW := APDUCommand(@SendAPDU[0], 8, @ReceiveAPDU[0], iReceiveLen);
	end;

	Result := iSW;
end;

//TypeA card Halt
function TypeA_Halt():Word;
var
  iSW,iReceiveLen:Word;
begin
  iSW := ERROR_GENERAL;
	iReceiveLen := 0;

	if(m_bActiveFlag) then
	begin
		SendAPDU[0] :=$FF;
		SendAPDU[1] :=$00;
		SendAPDU[2] :=$00;
		SendAPDU[3] :=$01;
		SendAPDU[4] :=$00;

		iSW := APDUCommand(@SendAPDU[0], 5, @ReceiveAPDU[0], iReceiveLen);
	end;

	Result := iSW;
end;
end.
