{$IFNDEF OS2}
{$O+,F+}
{$ENDIF}
{$I-}

Unit Users;

{*********************************************************}
{*                     USERS.PAS                         *}
{*                                                       *}
{*  Copyright (c) Konstantin Klyagin, 1995-98,           *}
{*                exspecially for Tornado BBS System     *}
{*                                                       *}
{*********************************************************}

Interface

Uses
  tMisc,
  Log,
  Objects,
{$IFNDEF WIN32}
  DOS,
{$ELSE}
  Classes,
  OpCrt,
{$ENDIF}
{$IFDEF OS2}
  Os2Base,
{$ENDIF}
  tGlob,
  Resource;

Procedure SetBaseName (Name: String);
Function Is_User (Name: String; AliasAllowed: Boolean): Boolean;
Procedure SaveUser (User: tUser);
Procedure GetUser (Name: String; Var R: tUser; AliasAllowed: Boolean);
Procedure GetUserByNum (N: LongInt; Var R: tUser);
Function GetUserRecNum (Name: String; AliasAllowed: Boolean): LongInt;
Function GetUserName (Num: LongInt): String;
Function UsersNum: LongInt;
Function NextLastRead: LongInt;

Implementation

Var
  BaseName      : PathStr;

Procedure SetBaseName;
Begin
  BaseName := Name;
End;

Function Is_User;
Var
  F     : File Of tUser;
  R     : tUser;

Label
  EndF;

Begin
  Is_User := False;

  Name := Trim (UpString (Name));
  If Name = '' Then Exit;

  Wait4Flag ('userbase.tbf');
  SetFlag ('userbase.tbf');

  If Not FileExists (BaseName) Then Goto EndF;

  System. FileMode := Open_Access_ReadOnly;

  Assign (F, BaseName);
  Reset (F);

  System. FileMode := Open_Access_ReadWrite;

  Is_User := False;
  While Not EoF (F) Do
  Begin
    Read (F, R);

    If IOResult = 100 Then
    Begin
      LogWrite ('!', sm (smReadError) + BaseName);
    {$IFDEF WIN32}
      NormExit;
      Exit;
    {$ELSE}
      Halt (207);
    {$ENDIF}
    End;

    If (UpString (R. Name) = Name) Or
      ((UpString (R. Alias) = Name) And
        AliasAllowed) Then
    Begin
      Is_User := True;
      Break;
    End;
  End;
  Close (F);

  EndF:
  DelFlag ('userbase.tbf');
End;

Procedure SaveUser;
Var
  UsersFile, tUsersFile : File Of tUser;
  R                     : tUser;
  Found                 : Boolean;

Begin
  Wait4Flag  ('userbase.tbf');
  SetFlag ('userbase.tbf');
  Found := False;

  Assign (tUsersFile, Cnf. Path + 'users.t$$');
  ReWrite (tUsersFile);

  Assign (UsersFile, BaseName);

  Reset (UsersFile);
  ioRez := IOResult;

  If ioRez = 2 Then
  Begin
    ReWrite (UsersFile);
    ioRez := IOResult;
    Close (UsersFile);
    ReSet (UsersFile);
  End;

  If ioRez = 0 Then
  Begin
    While Not EoF (UsersFile) Do
    Begin
      Read (UsersFile, R);

      If IOResult = 100 Then
      Begin
        LogWrite ('!', sm (smReadError) + BaseName);
      {$IFDEF WIN32}
        NormExit;
        Exit;
      {$ELSE}
        Halt (207);
      {$ENDIF}
      End;

      If R. Name <> User. Name
      Then
        Write (tUsersFile, R)
      Else
      Begin
        Write (tUsersFile, User);
        Found := True;
      End;
    End;

    If Not Found Then Write (tUsersFile, User);
    Close (UsersFile); Close (tUsersFile);
    Erase (UsersFile);
    Rename (tUsersFile, BaseName);

  End Else
  Begin
    LogWrite ('!', 'Users base file open error: ' + Long2Str (ioRez));
    Close (tUsersFile);
  End;

  DelFlag ('userbase.tbf');
End;

Procedure GetUser;
Var
  F     : File Of tUser;
  Rec   : tUser;

Begin
  Wait4Flag  ('userbase.tbf');
  SetFlag ('userbase.tbf');

  Name := UpString (Trim (Name));
  System. FileMode := Open_Access_ReadOnly;

  Assign (F, BaseName);
  Reset (F);

  System. FileMode := Open_Access_ReadWrite;

  While Not EoF (F) Do
  Begin
    Read (F, Rec);

    If IOResult = 100 Then
    Begin
      LogWrite ('!', sm (smReadError) + BaseName);
    {$IFDEF WIN32}
      NormExit;
      Exit;
    {$ELSE}
      Halt (207);
    {$ENDIF}
    End;

    If (UpString (Rec. Name) = Name) Or
      ((UpString (Rec. Alias) = Name) And
        AliasAllowed) Then
    Begin
      R := Rec;
      R. Password := LoString (R. Password);
      Break;
    End;

  End;

  If Not AliasAllowed Then R. Alias := '';

  Close (F);
  DelFlag ('userbase.tbf');
End;

Procedure GetUserByNum (N: LongInt; Var R: tUser);
Var
  F     : File Of tUser;

Begin
  FillChar (R, SizeOf (R), 0);
  Wait4Flag  ('userbase.tbf');
  SetFlag ('userbase.tbf');

  System. FileMode := Open_Access_ReadOnly;
  Assign (F, BaseName);
  Reset (F);
  System. FileMode := Open_Access_ReadWrite;
  Dec (N);

  If N <= FileSize (F) Then
  Begin
    Seek (F, N);
    Read (F, R);

    If IOResult <> 0 Then
    Begin
      LogWrite ('!', sm (smReadError) + BaseName);
    {$IFDEF WIN32}
      NormExit;
      Exit;
    {$ELSE}
      Halt (207);
    {$ENDIF}
    End;
  End;

  Close (F);
  DelFlag ('userbase.tbf');
End;

Function UsersNum;
Var
  F     : File Of tUser;

Begin
  System. FileMode := Open_Access_ReadOnly;

  Assign (F, BaseName);
  If FileExists (BaseName) Then ReSet (F) Else ReWrite (F);
  System. FileMode := Open_Access_ReadWrite;

  UsersNum := FileSize (F);
  Close (F);
End;

Function GetUserName;
Var
  F     : File Of tUser;
  Rec   : tUser;

Label
  1;

Begin
  Wait4Flag  ('userbase.tbf');
  SetFlag ('userbase.tbf');

  System. FileMode := Open_Access_ReadOnly;

  Assign (F, BaseName);
  Reset (F);

  System. FileMode := Open_Access_ReadWrite;

  Seek (F, Num - 1);
  Read (F, Rec);

  If IOResult = 100 Then
  Begin
    LogWrite ('!', sm (smReadError) + BaseName);
  {$IFDEF WIN32}
    NormExit;
    Exit;
  {$ELSE}
    Halt (207);
  {$ENDIF}
  End;

  GetUserName := Rec. Name;
  Close (F);
  DelFlag ('userbase.tbf');
End;

Type
  PLRCollection = ^TLRCollection;
  TLRCollection = Object (TSortedCollection)
    Function Compare (Key1, Key2: Pointer): {$IFNDEF OS2}
    Integer {$ELSE} LongInt {$ENDIF}; Virtual;
  End;

Function LRCompare (Key1, Key2: Pointer): Integer;
Begin
  If pLongInt (Key1)^ < pLongInt (Key2)^ Then LRCompare := -1 Else
  If pLongInt (Key1)^ > pLongInt (Key2)^ Then LRCompare := 1 Else LRCompare := 0;
End;

Function TLRCollection. Compare (Key1, Key2: Pointer): {$IFNDEF OS2} Integer {$ELSE} LongInt {$ENDIF};
Begin
  Compare := LRCompare (Key1, Key2);
End;

Function NextLastRead: LongInt;
Var
  F                   : File Of tUser;
  Rec                 : tUser;
  cLR                 : PLRCollection;
  i, Res              : LongInt;
  LRset               : Boolean;

Label
  EoP;

Begin
  Wait4Flag  ('userbase.tbf');
  SetFlag ('userbase.tbf');

  Res := 1;

  cLR := New (PLRCollection, Init (10, 2));
  cLR^. Insert (NewPLongInt (1));

  System. FileMode := Open_Access_ReadOnly;
  Assign (F, BaseName);
  Reset (F);
  If IOResult <> 0 Then GoTo EoP;
  System. FileMode := Open_Access_ReadWrite;

  While Not EoF (F) Do
  Begin
    Read (F, Rec);
    If IOResult = 100 Then
    Begin
      LogWrite ('!', sm (smReadError) + BaseName);
    {$IFDEF WIN32}
      NormExit;
      Exit;
    {$ELSE}
      Halt (207);
    {$ENDIF}
    End;
    cLR^. Insert (NewPLongInt (Rec. LastRead));
  End;

  (*
  {$IFDEF WIN32}
  cLR^. L. Sort (LRCompare);
  {$ENDIF}
  *)

  LRset := False;
  If cLR^. Count > 1 Then
  Begin
    For i := 1 To cLR^ . Count-1 Do
    If pLongInt (cLR^. At (i))^ - pLongInt (cLR^. At (i-1))^ > 1 Then
    Begin
      Res := pLongInt (cLR^. At (i-1))^ + 1;
      LRset := True;
      Break;
    End;
  End;

  If Not LRset Then
  Res := pLongInt (cLR^. At (cLR^. Count-1))^ + 1;

  If cLR^. Count > 0 Then
  While cLR^. Count > 0 Do
  Begin
    DisposePLongInt (cLR^. At (0));
    cLR^. AtDelete (0);
  End;

  Dispose (cLR, Done);
  Close (F);

  EoP:
  DelFlag ('userbase.tbf');
  NextLastRead := Res;
End;

Function GetUserRecNum (Name: String; AliasAllowed: Boolean): LongInt;
Var
  F     : File Of tUser;
  Rec   : tUser;
  i     : LongInt;

Begin
  Wait4Flag  ('userbase.tbf');
  SetFlag ('userbase.tbf');

  Name := UpString (Trim (Name));
  GetUserRecNum := 0;
  System. FileMode := Open_Access_ReadOnly;

  Assign (F, BaseName);
  Reset (F);

  System. FileMode := Open_Access_ReadWrite;
  i := 0;

  While Not EoF (F) Do
  Begin
    Read (F, Rec);
    If IOResult = 100 Then
    Begin
      LogWrite ('!', sm (smReadError) + BaseName);
    {$IFDEF WIN32}
      NormExit;
      Exit;
    {$ELSE}
      Halt (207);
    {$ENDIF}
    End;

    If (UpString (Rec. Name) = Name) Or
      ((UpString (Rec. Alias) = Name) And
        AliasAllowed) Then
    Begin
      GetUserRecNum := i;
      Break;
    End;

    Inc (i);
  End;

  Close (F);
  DelFlag ('userbase.tbf');
End;

End.