home *** CD-ROM | disk | FTP | other *** search
/ Total Network Tools 2002 / NextStepPublishing-TotalNetworkTools2002-Win95.iso / Archive / Web Server / TinyWeb Server.EXE / CGITEST.ZIP / LOGINU.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1999-03-25  |  3.8 KB  |  170 lines
  1. //////////////////////////////////////////////////////////////////////////
  2. //
  3. //  CGI Testing Example
  4. //
  5. //  Copyright (C) 1997 RIT Research Labs
  6. //
  7. //////////////////////////////////////////////////////////////////////////
  8.  
  9.  
  10.  
  11. unit LoginU;
  12.  
  13. interface
  14.  
  15. procedure ComeOn;
  16.  
  17.  
  18. implementation
  19.  
  20. uses
  21.   Windows,
  22.   SysUtils;
  23.  
  24.  
  25. var
  26.     StdIn,
  27.     StdOut: Integer;
  28.  
  29.     UserName: String;
  30.     UserPsw: String;
  31.  
  32. procedure OutWriteLn(const S: String);
  33.  var SS: String;
  34.      DW: DWord;
  35. begin
  36.   SS := S+#13#10;
  37.   WriteFile(StdOut, SS[1], Length(SS), DW, nil);
  38. end;
  39.  
  40.  
  41. procedure ShowError(const ErrorStr: String);
  42. var
  43.   S: string;
  44. begin
  45.   S := 'Error: '+ErrorStr;
  46.  
  47.   OutWriteLn('Content-Type: text/html');
  48.   OutWriteLn('');
  49.   OutWriteLn('<HTML>');
  50.   OutWriteLn('<HEAD>');
  51.   OutWriteLn('<TITLE>Error</TITLE>');
  52.   OutWriteLn('</HEAD>');
  53.   OutWriteLn('<BODY>');
  54.   OutWriteLn('');
  55.   OutWriteLn('<H1>'+ ErrorStr+ '</H1>');
  56.   OutWriteLn('<H2>Press BACK button on your browser and fill the form properly');
  57.   OutWriteLn('');
  58.   OutWriteLn('</BODY>');
  59.   OutWriteLn('</HTML>');
  60.  
  61.   Halt;
  62. end;
  63.  
  64.  
  65.  
  66. procedure DecodeParams(S: string);
  67.   var I,J: Integer;
  68.  
  69.   procedure Decode(const S: String);
  70.     var A, K: ShortString;
  71.         I,J: Integer;
  72.   begin
  73.     A := '';
  74.     I := 1; J := 0;
  75.     while (J < 255) and (I <= Length(S)) do
  76.      begin
  77.        Inc(J);
  78.        case S[I] of
  79.          '%': begin
  80.                 A[J] := Char(StrToInt('$'+Copy(S, I+1, 2)));
  81.                 Inc(I, 3);
  82.               end;
  83.          '+': begin A[J] := ' '; Inc(I) end;
  84.             else begin A[J] := S[I]; Inc(I) end;
  85.        end;
  86.      end;
  87.     A[0] := Char(J);
  88.     I := Pos('=', A);
  89.     if I > 0 then
  90.       begin
  91.         K := UpperCase(Copy(A, 1, I-1));
  92.         if K = 'USERID' then UserName := Copy(A, I+1, Length(A)) else
  93.         if K = 'PASSWORD' then UserPsw := Copy(A, I+1, Length(A)) else
  94.         ShowError(Format('Invalid field "%s"', [K]));
  95.       end;
  96.   end;
  97.  
  98.  
  99. begin
  100.   UserName := '';
  101.   UserPsw := '';
  102.   I := 1;
  103.   while (I <= Length(S)) do
  104.     begin
  105.       J := 1;
  106.       while (I+J <= Length(S)) and (S[I+J] <> '&') do Inc(J);
  107.       Decode(Copy(S, I, J));
  108.       Inc(I, J+1);
  109.     end;
  110. end;
  111.  
  112. procedure UserOK;
  113. var
  114.   S: string;
  115. begin
  116.   S := 'OK: '+UserName;
  117.  
  118.   OutWriteLn('Content-Type: text/html');
  119.   OutWriteLn('');
  120.   OutWriteLn('<HTML>');
  121.   OutWriteLn('<HEAD>');
  122.   OutWriteLn('<TITLE>You were successfully logged in!</TITLE>');
  123.   OutWriteLn('</HEAD>');
  124.   OutWriteLn('<BODY>');
  125.   OutWriteLn('');
  126.   OutWriteLn('<H1>Congratulations, '+UserName+'!</H1>');
  127.   OutWriteLn('<H2>You were successfully logged in!</H2>');
  128.   OutWriteLn('<H2>It means nothing except TinyWeb CGI does work!</H2>');
  129.   OutWriteLn('');
  130.   OutWriteLn('</BODY>');
  131.   OutWriteLn('</HTML>');
  132.  
  133.   Halt;
  134. end;
  135.  
  136.  
  137.  
  138. procedure ComeOn;
  139. var
  140.   I, J: Integer;
  141.   S: string;
  142.  
  143. // It was unable to retrieve the posted information
  144. // because the seek to the end of the standard input file always returns zero
  145. // on Windows 95/98 system. Thanks to David Gommeren for fixing that.
  146.  
  147.  
  148.   Variable:string;
  149.   Buffer:array [0..4095] of char;
  150. begin
  151.   StdIn  := GetStdHandle(STD_INPUT_HANDLE);
  152.   StdOut := GetStdHandle(STD_OUTPUT_HANDLE);
  153.   S := '';
  154.   SetString(Variable, Buffer, GetEnvironmentVariable(PChar('CONTENT_LENGTH'), Buffer, SizeOf(Buffer)));
  155.   I := StrToInt(Variable);
  156.   if I <= 0 then ShowError('Internal script error reading StdIn');
  157.   FileSeek(StdIn, 0, FILE_BEGIN);
  158.   SetString(S, nil, I);
  159.   FileRead(StdIn, S[1], I);
  160.   DecodeParams(S);
  161.   if UserName = '' then ShowError('User ID field is blank');
  162.   if UserPsw  = '' then ShowError('Password field is blank');
  163.   if UserName <> 'Jimmi' then ShowError(Format('User %s is not allowed to log in', [UserName]));
  164.   if UserPsw <> 'Hendrix' then ShowError(Format('Invalid password for user %s', [UserName]));
  165.   UserOK;
  166. end;
  167.  
  168. end.
  169.  
  170.