#!/usr/bin/perl -w

# original copyright:

##############################################################################
#    scriptor.pl: text interface to send APDU commands to a smart card
#    Copyright (C) 2001  Lionel Victor
#             2002-2003  Ludovic Rousseau
#
#    This program is free software; you can redistribute it and/or modify
#    it under the terms of the GNU General Public License as published by
#    the Free Software Foundation; either version 2 of the License, or
#    (at your option) any later version.
#
#    This program is distributed in the hope that it will be useful,
#    but WITHOUT ANY WARRANTY; without even the implied warranty of
#    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#    GNU General Public License for more details.
#
#    You should have received a copy of the GNU General Public License
#    along with this program; if not, write to the Free Software
#    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

# $Id: scriptor,v 1.15 2004/07/19 15:02:51 rousseau Exp $
##############################################################################

# this is a modified version of scriptor to automatically read
# french credit cards.
#
# in 2005, cards do not look to have any more 320 bit RSA key, but just an
# 768 encrypted one.
#
# I added a section to compute the PIN ready to send, but I have not
# been able to send it to my card. I left the code, just hack and
# find how to send it.
#
# atm, I did not find very good docs about modern cards; I cannot print
# many peaces of info; here is what I can do. Its better than nothing,
# and may be a starting point for many projects.
#
# specifications about cards come from
# http://parodie.com/monetique/explorer.htm
# ( written in 2000 - quiet out of date in 2005 )
# if you find newer doc, please mail me:
# you find my current email on http://www.demaine.info/
#
# My perl tutorial is
# http://www.sthomas.net/roberts-perl-tutorial.htm
# mirrored from
# http://www.netcat.co.uk/rob/perl/win32perltut.html
#
# I done that for french cards, because I have nothing else by hand.
# But if you tweak the magic numbers ( look in the if() statements )
# then I am pretty sure you can support more cards.
# 
# sice this script do not try (yet) to access protected zones,
# it should not damage any card, but any way, before using it, you should
# read the disclaimer in the above URL.
#
# Happy hacking to every body :)

use Getopt::Std;
use Chipcard::PCSC;
use Chipcard::PCSC::Card;

use strict;
use warnings;

my %options;

my $hContext = new Chipcard::PCSC();
my $hCard;
my @out_buffer;
my $in_buffer;

my @s;
my $res;

sub pass {
	$_=$_[0];
	my $tmp_value;
	my ($SendData, $RecvData, $cmd);

	last if /exit/i;
	next if /^\s*$/;
	next if /^#/;

	if (/reset/i) {
#		print OUT_FILEHANDLE "> RESET\n";
		if (defined $hCard->Reconnect ($Chipcard::PCSC::SCARD_SHARE_EXCLUSIVE,
		                   $options{p},
						   $Chipcard::PCSC::SCARD_RESET_CARD)) {
			@s = $hCard->Status();
#			print OUT_FILEHANDLE "< OK: ";
#			print map { sprintf ("%02X ", $_) } @{$s[3]};
#			print OUT_FILEHANDLE "\n";
			return;
			
		} else {
			print "Nok: $Chipcard::PCSC::errno\n";
			exit;
		}
#		next;
#		next;
	}
	chomp;

	# if the command does not contains spaces (00A4030000) we expand it
	s/(..)/$1 /g if (! m/ /);
	$cmd = $_;

	# convert in an array (internal format)
	$SendData = Chipcard::PCSC::ascii_to_array($cmd);

#	print OUT_FILEHANDLE "> $cmd\n";
	$RecvData = $hCard->Transmit($SendData);
	die ("Can't get info: $Chipcard::PCSC::errno\n") unless defined $RecvData;
	$res = Chipcard::PCSC::array_to_ascii($RecvData);
#	print OUT_FILEHANDLE "< $res : " .  Chipcard::PCSC::Card::ISO7816Error(substr($res, -5)) . "\n";
}

die ("Could not create Chipcard::PCSC object: $Chipcard::PCSC::errno\n") unless defined $hContext;

getopt ("r:p:" , \%options);

if ($options{h}) {
	print "Usage: $0 [-h] [-r reader] [-p protocol] [file]\n";
	print "          -h: this help\n";
	print "   -r reader: specify to use the PCSC smart card reader named reader\n";
	print "              By defaults the first one found is used so you\n";
	print "              don't have to specify anything if you just have\n";
	print "              one reader\n";
	exit (0);
}

# protocol option
	$options{p} = $Chipcard::PCSC::SCARD_PROTOCOL_T0 | $Chipcard::PCSC::SCARD_PROTOCOL_T1;

# reader option
if ($options{r}) {
	print STDERR "Using given card reader: $options{r}\n";
} else {
	my @readers_list = $hContext->ListReaders ();
	die ("Can't get readers list\n") unless defined $readers_list[0];
	print STDERR "No reader given: using $readers_list[0]\n";
	$options{r} = $readers_list[0];
}

$hCard = new Chipcard::PCSC::Card ($hContext, $options{r}, $Chipcard::PCSC::SCARD_SHARE_EXCLUSIVE, $options{p});
die ("Can't allocate Chipcard::PCSC::Card object: $Chipcard::PCSC::errno\n") unless defined $hCard;

if ($hCard->{dwProtocol} == $Chipcard::PCSC::SCARD_PROTOCOL_T0) {
	print "Using T=0 protocol\n";
} else {
	if ($hCard->{dwProtocol} == $Chipcard::PCSC::SCARD_PROTOCOL_T1) {
		print "Using T=1 protocol\n";
	}
	else {
		print "Using an unknown protocol (not T=0 or T=1)\n";
	}
}

# file option

#my $res;
pass("reset");
# printgn ATR:
#print map { sprintf ("%02X ", $_) } @{$s[3]};
print "Checking French CB card ... ";
pass("BC B0 09 E0 02");
if($res ne '3F E5 90 00' )
{
	print "\n\nNot a french CB card !\n";
	exit__();
}
print "OK\n";
print "Reading various addresses ... ";
pass("BC B0 09 C8 02");
chr_to_add($res);
my $aadl=$res;

pass("BC B0 09 CC 02");
chr_to_add($res);
my $aadt=$res;

pass("BC B0 09 D0 02");
chr_to_add($res);
my $aadc=$res;

pass("BC B0 09 D4 02");
chr_to_add($res);
my $aadm=$res;

pass("BC B0 09 D8 02");
chr_to_add($res);
my $aad2=$res;

pass("BC B0 09 DC 02");
chr_to_add($res);
my $aads=$res;

pass("BC B0 09 E8 02");
chr_to_add($res);
my $aad1=$res;

print "\n";

print "0x0200h is the secret zone\n";
print "ADL: $aadl no D, full R, no W.\n";
print "ADT: $aadt zone 1\n";
print "ADC: $aadc no D, prot R, no W, or user zone 2.\n";
print "ADM: $aadm no Delete, protected Read, no Write.\n";
print "AD2: $aad2\n";
print "ADS: $aads\n";
print "AD1: $aad1\n";

print "\nReading zone 'P 3' ... should contain the authentification code ( 320 bits )\n";
$res="BC B0 ".$aadl." 40";
#print $res."\n";
pass($res);
$res=~s/ //g;
$res=substr($res,0, length($res)-4);
$res=join(" ", unpack "(a4)*", $res);
$res=join("\n", unpack "(a40)*", $res);
print $res."\n\n";

# compute address of zone 'Persat 2'
print "Reading zone 'P 2' ...\n";
my $tmp;
$tmp=$aadl;
$tmp=~s/ //g;
# @ADL + #68h
$tmp=hex($tmp)+104;
my $presta2=$tmp;
$tmp=sprintf("%2.2X %2.2X",$tmp>>8,$tmp-(($tmp>>8)<<8));
# pestatair2 = $addl+ #68h ( size of presta3@ addl )
# just read header and size.
pass("BC B0 ".$tmp." 04");
my $t1;
my $t2;
my $t3;
my $t4;
($t1,$t2,$t3,$t4)=split(/ /,$res);
if( $t1.$t2 ne '2E02' )
{
	print "\n'Zone prestataire 2' is not valid ! Maybe the address on this zone is not ADL+68h any more.\n";
	exit__();
}
# compute address of DATAS.
$tmp=~s/ //g;
$tmp=hex($tmp)+8;
$tmp=sprintf("%2.2X %2.2X",$tmp>>8,$tmp-(($tmp>>8)<<8));
# read DATAs
pass("BC B0 ".$tmp." ".$t3);
$res=~s/ //g;

$res=substr($res,0, length($res)-4);
#$res = map substr($_, 1), unpack "(a4)*", $res;
$res=join("", unpack "(xa7)*", $res);

# get the number
my $CB_num;
$CB_num=substr($res,2,16);

# get issue date
my $CB_begin=substr($res,24,4);
my $CB_b_y=substr($CB_begin,0,2);
my $CB_b_m=substr($CB_begin,2,2);

# get country
my $country=substr($res,28,3);

# get end date
my $CB_end=substr($res,31,4);
my $CB_e_y=substr($CB_end,0,2);
my $CB_e_m=substr($CB_end,2,2);

# get the currency
my $CB_currency=substr($res,35,3);

# get exposant
my $CB_exp=substr($res,38,1);

## in 39-41 lays an unknown number.

# get owner name
my $CB_owner_full_name=substr($res,42,52);
my $CB_owner_name;
foreach(split(/(..)/,$CB_owner_full_name))
{
	$CB_owner_name=$CB_owner_name.chr(hex($_));
##	print "_".chr(hex($_))."_\n";
}


#print "Please enter your PIN:\n";
#my $pin=<STDIN>;
my $pin="0000";
chop $pin;
$pin=sprintf("%4.4i",$pin);
my $p1;
my $p2;
my $p3;
my $p4;
($p1,$p2,$p3,$p4)=split //,$pin;
#print ":_".$p1.$p2.$p3.$p4."_\n";
$p1=hex($p1);
$p2=hex($p2);
$p3=hex($p3);
$p4=hex($p4);
$p1=($p1<<12)+($p2<<8)+($p3<<4)+($p4);
$p1=($p1<<14)+0x3FFF;
$p1=sprintf("%8.8X",$p1);
$p1=join(' ',split(/(..)/,$p1));
#print "_".$p1."_";
# $p1 now contains the code to send

# I did not find ho to send this code to the card.

# extended zone:
$presta2=$presta2+120;
# pestatair2_VA = $addl+ #78h ( 120d)
print "Extended zone starts at: $tmp\n";
$tmp=sprintf("%2.2X %2.2X",$presta2>>8,$presta2-(($presta2>>8)<<8));
# just read header and size.
pass("BC B0 ".$tmp." 04");
($t1,$t2,$t3,$t4)=split(/ /,$res);
if( $t1.$t2 ne '2E16' )
{
	print "\n'Zone prestataire 2 etendue' is not valid ! Maybe the address on this zone is not ADL+68h any more.\n";
	exit__();
}
$tmp=~s/ //g;
$tmp=hex($tmp)+8;
$tmp=sprintf("%2.2X %2.2X",$tmp>>8,$tmp-(($tmp>>8)<<8));
# read DATAs
pass("BC B0 ".$tmp." ".$t3);
$res=~s/ //g;
$res=substr($res,0, length($res)-4);
$res=join("", unpack "(xa7)*", $res);
my $p2_ext=$res;

print "\nResume (the syntax is three equal, tab, name, semi column, value)\n\n";
print "===\tThe card number is: ";
#print join(' ',split(/(....)/,$CB_num));
print join(" ", unpack "(a4)*", $CB_num);;
print "\n";
print "===\tThe card was issued in: $CB_b_m/$CB_b_y\n";
print "===\tThe card was emitted in country: $country\n";
print "250=France \n";
print "===\tThe card is valid until: $CB_e_m/$CB_e_y\n";
print "===\tThe currency is: $CB_currency\n";
print "250=Francs \n";
print "===\tExposant is: $CB_exp\n";
print "===\tOwner name: $CB_owner_name\n";
print "Content of extended zone is:\n";
$tmp=join(" ", unpack "(a4)*", $p2_ext);
$tmp=join("\n", unpack "(a40)*", $tmp);
print $tmp;
print "\n\n";
print "Extended zone is ".(length($p2_ext)/2)." bytes, what are ".(length($p2_ext)*4)." bits. If this is bigger than 768, then it may contain a big RSA key.\n";
print "\nDone\n";

sub exit__ {
#close (IN_FILEHANDLE);
$hCard->Disconnect($Chipcard::PCSC::SCARD_LEAVE_CARD);
$hCard = undef;
$hContext = undef;
exit;
}

sub chr_to_add{
	my $j=$_[0];
	$j=~s/ //g;
	$j=~s/(....)/$1 /g;
	my $raw = pack( 'h*' , $j);
#	print "J: ".$j."\n";
	my $r;
#	foreach(split(/ /,$j))
#	{
#		$r=hex($_)>>5;
#		$r=$r<<3;
#		printf(": %4.4X\n",$r);
#	}
#	print "\n";
	($j)=split(/ /,$j);
	$j=((hex($j) >> 5 ) << 3);
	$res=sprintf("%2.2X %2.2X",$j>>8,$j-(($j>>8)<<8));
}

# End of File