home *** CD-ROM | disk | FTP | other *** search
/ PC Underground / UNDERGROUND.ISO / password / passwd1.pas < prev    next >
Pascal/Delphi Source File  |  1995-07-28  |  4KB  |  174 lines
  1. program PASSWORD_TYPE1;
  2.  
  3. Uses Crt, Design;
  4.  
  5. var password : string;
  6.     passwordcheck : boolean;
  7.  
  8. procedure Secret_readln(var s : string);
  9. var c : char;
  10.    li : integer;
  11. begin
  12.   repeat
  13.     c := readkey;
  14.     if c <> #8 then begin;
  15.       s := s + c;
  16.       gotoxy(24,12);
  17.       for li := 1 to length(s) do write('*');
  18.     end else begin;
  19.       s := copy(s,1,length(s)-1);
  20.       gotoxy(24,12);
  21.       for li := 1 to length(s) do write('*');
  22.       write(' ');
  23.       gotoxy(wherex-1,wherey);
  24.     end;
  25.   until c = #13;
  26. end;
  27.  
  28. procedure Change_password;
  29. begin
  30.   save_screen;
  31.   window(10,8,60,7,' Change password ',black,7);
  32.   writexy(13,10,'Please enter your new password');
  33.   writexy(13,12,'Password: ');
  34.   password := '';
  35.   secret_readln(password);
  36.   restore_screen;
  37.   textcolor(7);
  38.   textbackground(black);
  39. end;
  40.  
  41. Function Gen_checksum(pasw : string) : word;
  42. var sum : word;
  43.     li : integer;
  44. begin
  45.   sum := 0;
  46.   for li := 1 to ord(pasw[0]) do begin
  47.     sum := sum + ord(pasw[li]);
  48.   end;
  49.   Gen_checksum := sum;
  50. end;
  51.  
  52. function Encrypt(pasw : string;add : char) : string;
  53. var li : integer;
  54. begin
  55.   for li := 1 to 255 do begin
  56.     pasw[li] := char(255 xor (ord(pasw[li]) + ord(add)));
  57.   end;
  58.   encrypt := pasw;
  59. end;
  60.  
  61. procedure Save_password;
  62. var pwf : file;
  63.     key : char;
  64.     check : word;
  65. begin
  66.   check := gen_checksum(password);
  67.   password := encrypt(password,key);
  68.   assign(pwf,'password.dat');
  69.   rewrite(pwf,1);
  70.   blockwrite(pwf,key,1);
  71.   blockwrite(pwf,password,256);
  72.   blockwrite(pwf,check,2);
  73.   close(pwf);
  74. end;
  75.  
  76. procedure QueryPassword;
  77. begin
  78.   save_screen;
  79.   window(10,8,60,7,'Query Password',black,7);
  80.   writexy(13,10,'Please enter your password');
  81.   writexy(13,12,'Password: ');
  82.   password := '';
  83.   secret_readln(password);
  84.   restore_screen;
  85.   textcolor(7);
  86.   textbackground(black);
  87. end;
  88.  
  89. function Decrypt(pasw : string;add : char) : string;
  90. var li : integer;
  91. begin
  92.   for li := 1 to 255 do begin
  93.     pasw[li] := char((255 xor ord(pasw[li])) - ord(add));
  94.   end;
  95.   decrypt := pasw;
  96. end;
  97.  
  98. function Checksum_Ok(pasw : string; Key: char; sum : word) : boolean;
  99. var tsum : word;
  100.     li : integer;
  101.     h : char;
  102. begin
  103.   tsum := 0;
  104.   for li := 1 to ord(pasw[0]) do begin;
  105.     tsum := tsum + ord(pasw[li]);
  106.   end;
  107.   if sum = tsum then
  108.     Checksum_Ok := true
  109.   else
  110.     Checksum_Ok := false;
  111. end;
  112.  
  113. procedure CheckPassword;
  114. var pwf : file;
  115.     key : char;
  116.     check : word;
  117.     should_pass : string;
  118. begin
  119.   assign(pwf,'password.dat');
  120.   reset(pwf,1);
  121.   blockread(pwf,key,1);
  122.   blockread(pwf,should_pass,256);
  123.   blockread(pwf,check,2);
  124.   close(pwf);
  125.   should_pass := decrypt(should_pass,key);
  126.   if Checksum_Ok(should_pass,key,check) and (should_pass = password) then
  127.     PasswordCheck := true
  128.   else
  129.     PasswordCheck := false;
  130. end;
  131.  
  132. procedure RespondPassword;
  133. begin
  134.   save_screen;
  135.   window(10,8,40,7,'',black,7);
  136.   If PasswordCheck then begin
  137.     writexy(13,11,'Password correct - Access granted');
  138.   end else begin
  139.     writexy(13,11,'Password WRONG ! - No access !');
  140.   end;
  141.   repeat until keypressed; readkey;
  142.   restore_screen;
  143.   textcolor(7);
  144.   textbackground(black);
  145. end;
  146.  
  147. procedure Menu;
  148. var choice : byte;
  149. begin
  150.   repeat
  151.     clrscr;
  152.     writexy(10,1,'Example program for password type 1  (c) ''95 by ABACUS ');
  153.     writexy(20,4,'M E N U');
  154.     writexy(20,5,'~~~~~~~');
  155.     writexy(15,6,'1)  Change Password');
  156.     writexy(15,8,'2)  Query Password');
  157.     writexy(15,10,'3)  End');
  158.     writexy(15,13,'Your Choice: ');
  159.     readln(choice);
  160.     if choice = 1 then begin
  161.       Change_password;
  162.       Save_password;
  163.     end;
  164.     if choice = 2 then begin
  165.       QueryPassword;
  166.       CheckPassword;
  167.       RespondPassword;
  168.     end;
  169.   until choice = 3;
  170. end;
  171.  
  172. begin
  173.   Menu;
  174. end.