Program Password Multi User dengan Pascal

Tips dan Trik IlmuKomputer.Com
Copyright © 2003 IlmuKomputer.Com

Mochammad Rivai
mrivai@telkom.net
Lisensi Dokumen:
Copyright © 2003 IlmuKomputer.Com
Seluruh dokumen di IlmuKomputer.Com dapat digunakan, dimodifikasi dan disebarkan
secara bebas untuk tujuan bukan komersial (nonprofit), dengan syarat tidak menghapus
atau merubah atribut penulis dan pernyataan copyright yang disertakan dalam setiap
dokumen. Tidak diperbolehkan melakukan penulisan ulang, kecuali mendapatkan ijin
terlebih dahulu dari IlmuKomputer.Com.
Sesuai dengan judulnya "multi user", program ini akan menampung lebih dari satu password
(dapat ditambah dan dikurang), semua password akan disimpan dalam satu file, tentu saja
password-password tersebut di encrypt terlebih dahulu sehingga password yang disimpan susah
dibaca.
Untuk meng-encrypt data, kita menggunakan cara sederhana dengan menambahkan kode ASCII
suatu karakter dengan angka-angka dalam konstanta SEED setelah kata itu dibalik, untuk huruf
pertama ditambahkan dengan 2, huruf kedua dengan 1 dan seterusnya. Contoh, kata "TURBO
PASCAL" akan dibalik menjadi "LACSAP OBRUT" lalu menjadi "LBEZAX)PIRVL" dengan
langkah-langkah :
L
A
C
S
A
P
[spasi]
O
B
R
U
T
= 76
= 65
= 67
= 83
= 65
= 80
= 32
= 79
= 66
= 82
= 85
= 84
76 + 0 = 76 =
65 + 1 = 66 =
67 + 2 = 69 =
83 + 7 = 90 =
65 + 0 = 65 =
80 + 8 = 88 =
32 + 9 = 41 =
79 + 1 = 80 =
66 + 7 = 73 =
82 + 0 = 82 =
85 + 1 = 86 =
74 + 2 = 76 =
L
B
E
Z
A
X
)
P
I
R
V
L
Orang lain akan susah menelusurinya, kecuali dia telah membaca source code programnya.
Anda dapat mengubah konstanta SEED menjadi angka-angka yang lain sesuai keinginan.
Setelah dikompilasi, panggil program ini melalui AUTOEXEC.BAT, sehingga program ini akan
dipanggil setiap anda menyalakan (atau merestart) komputer.
Pertama kali program dijalankan, program akan menanyakan data pertama. Untuk selanjutnya,
apabila ingin menambah user baru panggil program dengan parameter "+", dan untuk
menghapus gunakan parameter "-".
1

Tips dan Trik IlmuKomputer.Com
Copyright © 2003 IlmuKomputer.Com
Program ini bersifat case sensitive, maksudnya untuk USERID dan PASSWORD huruf besar
dianggap tidak sama dengan huruf kecil. Contoh, USERID "Hairuddin" berbeda dengan
"HAIRUDDIN", hal ini berlaku juga untuk penulisan PASSWORD.
Program Password;
Uses Crt;
Const
Seed : Array[1..9] of Integer = (2,1,0,7,1,9,8,0,7);
Type
Fields = Record
UserID : String[33];
Sandi : String[33];
End;
Var
User, Sandi: String;
P, F: File Of Fields;
Records: Fields;
NoRec: Integer;
Opened: Boolean;
Procedure FillChar(x1,y1,x2,y2 : integer; tembok, attr:byte);
var
q,w:integer;
begin
textattr:=attr;
for q := 0 to x2-x1 do
for w := 0 to y2-y1 do
begin
gotoxy(x1+q, y1+w);
write(chr(tembok));
end;
end;
Function Balik(Kata:String):String;
var
Hasil : String;
N : Integer;
Begin
Hasil := '';
For n := Length(Kata) Downto 1 do
Hasil := Hasil+Kata[n];
Balik := Hasil;
end;
Function Acak(Kata:string):String;
var
Hasil : string;
N, I : integer;
B : Byte;
Begin
I := 1;
Hasil := '';
For n := length(kata) downto 1 do
begin
b := ord(kata[n]);
b := b+seed[i];
If i < 9 then inc(i) else i:=1;
Hasil := Hasil + Chr(b);
end;
2

Tips dan Trik IlmuKomputer.Com
Copyright © 2003 IlmuKomputer.Com
Acak := Hasil;
End;
Function Pulih(Kata:string):String;
var
Hasil: string;
N, B, I : Integer;
Begin
I := 1;
Hasil := '';
For n := 1 to length(kata) do
begin
b := ord(Kata[n]);
b := b-seed[i];
If i < 9 then inc(i) else i:=1;
Hasil := Hasil + Chr(b);
end;
Pulih := Balik(Hasil);
End;
Procedure Input (Wd, X, Y : Byte; Var VarStr : String;
Kode, Attr : Byte);
var
I : Integer;
C : Char;
Begin
VarStr := '';
gotoxy(x,y);
textattr := Attr;
For I := 1 to Wd do
begin
Write(#32);
gotoxy(x+i,y);
end;
gotoxy(x,y);
I := 0;
Repeat
C := Readkey;
If c = #13 then exit else
If ((i>0) and (c = #08)) then
Begin
I := I-1;
Delete(Varstr, Length(Varstr), 1);
Write(c);
write(#32);
write(c);
End else
If c = #27 then
Begin
VarStr := '';
Exit;
End else
If ((c<>#13) and (c<>#08) and (c<>#27)) then
Begin
I := I+1;
VarStr := VarStr + C;
If Kode = 0 then Write(c) else Write(#254);
End;
Until I=Wd;
3

Tips dan Trik IlmuKomputer.Com
Copyright © 2003 IlmuKomputer.Com
End;
Function EFP(Param:String):String; {Extract File Path}
var
tempor : string;
l : integer;
Begin
Tempor := Balik(Param);
L := Pos('\',Tempor);
If L=0 then Efp := '' else
Efp := Copy(Param,1,Length(Param)-L+1);
end;
Procedure Block(x1,y1,x2,y2 : integer; Attr : byte);
Begin
window(x1,y1,x2,y2);
textattr := attr;
clrscr;
window(1,1,80,25);
end;
Procedure Ask(Judul:string);
var i : integer;
Begin
Block(1,1,80,25,$1e);
Gotoxy(1,1);
Write(#32#254#32,'PC SECURITY SYSTEM v1.09');
Gotoxy(56,25);
Write('Copyright by Hairuddin',#32#254);
Block(1,2,80,24,$3e);
i:=1;
repeat
FillChar(i,2,i,24,168,$3e);
inc(i,4);
Until i>79;
i:=2;
repeat
FillChar(i,2,i,24,88,$3e);
inc(i,2);
Until i>80;
i:=3;
repeat
FillChar(i,2,i,24,63,$3e);
inc(i,4);
Until i>79;
Block(22,7,58,7,$4f);
gotoxy(23,7);
Write(Judul);
Block(24,8,60,19,$8);
Block(22,8,58,18,$6f);
Gotoxy(24,10); Write('User ID');
Gotoxy(24,15); Write('Password');
Block(24,11,56,11,$1f);
Block(24,16,56,16,$1f);
Input(33,24,11,USER,0,$1f);
Input(33,24,16,SANDI,1,$1f);
end;
Procedure OpenPWL;
4

Tips dan Trik IlmuKomputer.Com
Copyright © 2003 IlmuKomputer.Com
Begin
Assign(f,EFP(Paramstr(0))+'PSWPRO.PWL');
{$I-} Reset(f); {$I+}
If IOresult <> 0 then
Begin
Rewrite(f);
Ask('Add new record');
Records.UserID := Acak(User);
Records.Sandi := Acak(Sandi);
Write(f,Records);
end;
Opened := true;
End;
Procedure ClosePWL;
Begin
Close(f);
End;
Function SearchList(Nama:String):Integer;
var
namarec : string;
i,n:integer;
Begin
I := 0;
Seek(f,0);
For n := 1 to filesize(f) do
Begin
Read(f,Records);
NamaRec := Pulih(Records.UserID);
If Namarec = Nama then
begin
i := n;
end;
end;
SearchList := I;
end;
Procedure AddToList(Add : Fields);
Begin
Seek(f,filesize(f));
Records.UserID := Acak(Add.UserID);
Records.Sandi := Acak(Add.Sandi);
Write(f,Records);
end;
Procedure DeleteRec(Nama : String);
var
namarec : string;
n : integer;
Begin
Assign(P,EFP(Paramstr(0))+'PSWNEW.PWL');
Rewrite(p);
Seek(f,0);
For n := 1 to filesize(f) do
Begin
Read(f,records);
NamaRec := pulih(records.Userid);
if NamaRec <> Nama then write(p,records);
5

Tips dan Trik IlmuKomputer.Com
Copyright © 2003 IlmuKomputer.Com
end;
Close(f);
Close(p);
Erase(f);
Rename(p,EFP(Paramstr(0))+'PSWPRO.PWL');
Opened := false;
End;
Procedure Pass(kode : integer);
Begin
If Opened then ClosePWL;
Textattr := $7;
Clrscr;
writeln(#254#32'PC Security System v1.09');
Write('The USERID and PASSWORD are correct,'#32);
Case kode of
0 : writeln('you may continue...');
1 : writeln('new record added.');
2 : writeln('one record deleted.');
end;
Halt;
End;
Procedure Error(Kode:integer);
Begin
If opened then ClosePWL;
Textattr := $7;
Clrscr;
writeln(#254#32'PC Security System v1.09');
Case Kode of
0 : Inline($B8/$00/$00/$50/$1F/$BB/$72/$04/$B8/
$34/$12/$89/$07/$EA/$00/$00/$FF/$FF);
1 : Writeln('You have no authority to add a new record.');
2 : Writeln('You have no authority to delete a record.');
3 : Writeln('Duplicate USERID. No record added.');
4 : writeln('The USERID not listed yet.');
5 : writeln('I don''t understand that command.');
end;
Halt;
End;
Procedure PlusRec;
var baru : fields;
Begin
OpenPWL;
ASK('Login Password');
NoRec := 0;
NoRec := SearchList(User);
If NoRec > 0 then
begin
Seek(f,Norec-1);
Read(f,Records);
If Pulih(Records.sandi)=Sandi then
begin
Ask('Add new user');
NoRec := 0;
NoRec := SearchList(User);
If Norec <> 0 then error(3) else
begin
6

Tips dan Trik IlmuKomputer.Com
Copyright © 2003 IlmuKomputer.Com
Baru.userid := user;
Baru.sandi := sandi;
AddToList(Baru);
Pass(1);
end;
end else Error(1);
end else Error(4);
End;
Procedure MinRec;
Begin
OpenPWL;
ASK('Login Password');
NoRec := 0;
NoRec := SearchList(User);
If NoRec > 0 then
begin
Seek(f,Norec-1);
Read(f,Records);
If Pulih(Records.sandi)=Sandi then
begin
ASK('Record to delete');
NoRec := 0;
NoRec := SearchList(User);
If NoRec > 0 then
begin
Seek(f,Norec-1);
Read(f,Records);
If Pulih(Records.sandi)=Sandi then
begin
DeleteRec(Pulih(Records.userid));
Pass(2);
end else error(2);
end else error(4);
end else error(2);
end else error(4);
End;
Begin
CheckBreak := False;
If Paramcount < 1 then
begin
OpenPWL;
ASK('Login Password');
NoRec := 0;
NoRec := SearchList(User);
If (NoRec > 0) and (Norec<=filesize(f)) then
begin
Seek(f,Norec-1);
Read(f,Records);
If Pulih(Records.sandi)=Sandi then Pass(0) else Error(0);
end else error(0);
end else
Begin
if Paramstr(1) = '+' then PlusRec else
If paramstr(1) = '-' then MinRec else Error(5);
End;
End.