Category : BBS Programs+Doors
Archive   : FILEDR31.ZIP
Filename : FILEDOOR.PAS

program FileDoor (input, output);


{
File Door, version 3.0, gives the shareware version of Searchlight external
file transfer protocol support. See filedoor.doc for instructions.
}


{$m 32768, 0, 0}
{$v-}


uses
crt,
dos;


{$i slstuff.inc}


{-----------------------------------------------------------------------------}


const
Null = 0;
CR = chr (13); { carriage return }
SP = chr (32); { space }
BS = chr (08); { backspace }
DefaultTime = 20; { default to 20 min time limit if not specified }
MaxProtocols = 20;
ProtocolSpec = 'FILEDOOR.DEF';
MaxMenuItems = 9;
Menu : array [1..MaxMenuItems] of string [8] =
('Help',
'Download',
'Files',
'Jump',
'List',
'New',
'Quit',
'Space',
'Upload');
ValidChoices : set of char = [CR, SP, BS, 'H', 'D', 'F', 'J', 'L', 'N',
'Q', 'S', 'U'];


type
TypeDirectory =
record
Name:
string [8];
Access:
byte;
Path:
string [63];
Description:
string [60]
end;
TypeDirectoryList =
record
LastDirectory:
char;
DirectoryArray:
array ['A'..'X'] of TypeDirectory
end;
TypeProtocol =
record
Name:
string [40];
FileSpec,
UploadCommand,
DownloadCommand:
string [63]
end;
TypeProtocolList =
record
NumberOfProtocols:
integer;
ProtocolArray:
array [1..MaxProtocols] of TypeProtocol
end;
TypeCharacterSet = set of char;
TypeUserInfo =
record
StartTime:
datetime;
TimeLimit:
byte;
Config:
ConfigType;
User:
UserType;
CurrentDirectory:
char
end;


var
DirectoryList:
TypeDirectoryList;
ProtocolList:
TypeProtocolList;
UserInfo:
TypeUserInfo;
MenuChoice:
integer;


{-----------------------------------------------------------------------------}


procedure UseColor ( Color:
ColorType);

begin
if (paramstr (2) <> 'N') then
begin
textcolor (UserInfo.Config.ColorChart [Color] and $8F);
textbackground ((UserInfo.Config.ColorChart [Color] and $70) shr 4)
end
end;


procedure ClearScreen;

begin
clrscr
end;


{-----------------------------------------------------------------------------}


function ValueOf ( AString:
string): integer;

var
Result,
ErrorCode:
integer;

begin
val (AString, Result, ErrorCode);
ValueOf := Result
end;


function StringOf ( Character:
char;
NumberOfCharacters:
integer): string;

var
Result:
string;

begin
fillchar (Result [1], NumberOfCharacters, Character);
Result [0] := chr (NumberOfCharacters);
StringOf := Result
end;


procedure ReadLnString (var AString:
string;
MaxLength:
integer;
OkSet:
TypeCharacterSet;
ForceCAPS,
Hidden:
boolean;
Color:
ColorType);

var
Key:
char;

begin
UseColor (Color);
write (output, StringOf (SP, MaxLength), StringOf (BS, MaxLength));
AString := '';
repeat
Key := readkey;
if ForceCAPS then
Key := upcase (Key);
if (Key = BS) and (AString <> '') then
begin
write (output, BS, SP, BS);
delete (AString, length (AString), 1)
end
else
if (Key in OkSet) and (length (AString) < MaxLength) then
begin
if Hidden then
write (output, '.')
else
write (output, Key);
AString := AString + Key
end
until (Key = CR);
writeln (output);
UseColor (Normal)
end;


{-----------------------------------------------------------------------------}


procedure GetCurrentTime (var Time:
datetime);

var
Unused:
word;

begin
with Time do
begin
getdate (Year, Month, Day, Unused);
gettime (Hour, Min, Sec, Unused)
end
end;


function ElapsedTime ( Time:
datetime): integer;

var
Current:
datetime;

begin
GetCurrentTime (Current);
if (Current.Hour < Time.Hour) then
inc (Current.Hour, 24);
if (Current.Min < Time.Min) then
inc (Current.Min, 60);
ElapsedTime :=
((Current.Hour - Time.Hour) * 60) + (Current.Min - Time.Min)
end;


{-----------------------------------------------------------------------------}


procedure Abort ( ErrorMessage:
string);

begin
writeln (output, ErrorMessage);
halt
end;


function FileExists ( FileName:
string): boolean;

var
TestFile:
file;

begin
assign (TestFile, Filename);
{$i-} reset (TestFile); {$i+}
if (ioresult = 0) then
begin
close (TestFile);
FileExists := true
end
else
FileExists := false
end;


{-----------------------------------------------------------------------------}


function DirectoryFileName ( Directory:
TypeDirectory): string;

begin
with Directory do
DirectoryFileName := Path + '\' + Name + '.DIR'
end;


procedure CreateDirectoryFile (var DirectoryFile:
file;
Directory:
TypeDirectory);

var
RootEntry:
DirType;

begin
with RootEntry do
begin
Active := true;
DataRoot := Null;
DateRoot := Null;
FreeRoot := Null;
Files := 0
end;
rewrite (DirectoryFile);
blockwrite (DirectoryFile, RootEntry, 1);
close (DirectoryFile);
reset (DirectoryFile)
end;


procedure OpenDirectoryFile (var DirectoryFile:
file;
Directory:
TypeDirectory);

{
pre: DirectoryFile may be undefined. Directory contains the directory
information which will be used to open the file.
post: If the directory's entry file does not exist, it is created and
written to disk. In all cases, DirectoryFile is open.
}

begin
assign (DirectoryFile, DirectoryFileName (Directory));
if not FileExists (DirectoryFileName (Directory)) then
CreateDirectoryFile (DirectoryFile, Directory)
else
reset (DirectoryFile, sizeof (DirType))
end;


procedure ReadEntry (var DirectoryFile:
file;
Index:
integer;
var Entry:
DirType);

{
pre: DirectoryFile is open. Index contains the index of the entry which is
to be read into Entry.
post: The entry at the Index'th position of DirectoryFile has been read into
Entry.
}

begin
seek (DirectoryFile, Index);
blockread (DirectoryFile, Entry, 1)
end;


procedure UpdateEntry (var DirectoryFile:
file;
Index:
integer;
Entry:
DirType);

{
pre: DirectoryFile is open. Index contains the position in DirectoryFile
where the entry will be written. Entry contains the entry which will
be written to the file.
post: Entry has been written in the Index'th position of DirectoryFile.
}

begin
seek (DirectoryFile, Index);
blockwrite (DirectoryFile, Entry, 1)
end;


procedure SearchDirectoryFile (var DirectoryFile:
file;
EntryName:
string;
var Lead,
Back:
integer);

{
pre: DirectoryFile is open. EntryName contains the name of the Entry to
search for in DirectoryFile. Lead and Back may be undefined.
post: DirectoryFile has been searched. Lead contains either Null, meaning
that EntryName was not found, or the index of the entry in the file.
Back contains the index of the entry's parent, or Null if the entry
has no parent.
}

var
Entry:
DirType;
Found:
boolean;

begin
ReadEntry (DirectoryFile, 0, Entry);
Lead := Entry.DataRoot;
Back := Null;
Found := false;
while (Lead <> Null) and (not Found) do
begin
ReadEntry (DirectoryFile, Lead, Entry);
if (EntryName = Entry.Name) then
Found := true
else
begin
Back := Lead;
if (EntryName < Entry.Name) then
Lead := Entry.Left
else
Lead := Entry.Right
end
end;
end;


procedure AddEntry (var DirectoryFile:
file;
Entry:
DirType);

{
pre: DirectoryFile is open. Entry contains the entry that will be added to
DirectoryFile.
post: If the entry doesn't already exist, it is added to DirectoryFile.
Being lazy, I don't check the Free list to use dead records.
}

var
RootEntry,
Temp:
DirType;
Lead,
Back:
integer;

begin
Entry.Left := Null;
Entry.Right := Null;
Entry.Next := Null;
ReadEntry (DirectoryFile, 0, RootEntry);
inc (RootEntry.Files);
SearchDirectoryFile (DirectoryFile, Entry.Name, Lead, Back);
if (Lead = Null) then
if (Back = Null) then
begin
RootEntry.DataRoot := filesize (DirectoryFile);
RootEntry.DateRoot := filesize (DirectoryFile);
Entry.Last := Null;
seek (DirectoryFile, filesize (DirectoryFile));
blockwrite (DirectoryFile, Entry, 1)
end
else
begin
{ update date linked list }
ReadEntry (DirectoryFile, RootEntry.DateRoot, Temp);
Entry.Last := RootEntry.DateRoot;
while (Temp.Next <> Null) do
begin
Entry.Last := Temp.Next;
ReadEntry (DirectoryFile, Temp.Next, Temp)
end;
Temp.Next := filesize (DirectoryFile);
UpdateEntry (DirectoryFile, Entry.Last, Temp);

{ update data tree }
ReadEntry (DirectoryFile, Back, Temp);
if (Entry.Name < Temp.Name) then
Temp.Left := filesize (DirectoryFile)
else
Temp.Right := filesize (DirectoryFile);
UpdateEntry (DirectoryFile, Back, Temp);
seek (DirectoryFile, filesize (DirectoryFile));
blockwrite (DirectoryFile, Entry, 1)
end;
UpdateEntry (DirectoryFile, 0, RootEntry)
end;


{-----------------------------------------------------------------------------}


procedure DivideAtSemicolon (var String1,
String2:
string);

begin
String2 := copy (String1, 1, (pos (';', String1) - 1));
delete (String1, 1, pos (';', String1))
end;


procedure GetDirectoryList (var DirectoryList:
TypeDirectoryList);

var
DirectoryListFile:
text;

procedure ReadLnDirectory (var DirectoryListFile:
text;
var Directory:
TypeDirectory);

var
WorkString,
AccessString:
string;

begin
readln (DirectoryListFile, WorkString);
with Directory do
begin
DivideAtSemicolon (WorkString, Name);
DivideAtSemicolon (WorkString, AccessString);
Access := ValueOf (AccessString);

DivideAtSemicolon (WorkString, Path);
Description := WorkString
end
end;

begin
if not FileExists (DirSpec) then
Abort ('Error: Cannot find FILEDIR.DEF file. Please inform sysop.');
assign (DirectoryListFile, DirSpec);
reset (DirectoryListFile);
with DirectoryList do
begin
LastDirectory := pred ('A');
while not eof (DirectoryListFile) do
begin
LastDirectory := succ (LastDirectory);
ReadLnDirectory (DirectoryListFile, DirectoryArray [LastDirectory])
end;
if (LastDirectory < 'A') then
Abort ('No file directories exist.')
end;
close (DirectoryListFile)
end;


procedure GetProtocolList (var ProtocolList:
TypeProtocolList);

var
ProtocolListFile:
text;

procedure ReadLnProtocol (var ProtocolListFile:
text;
var Protocol:
TypeProtocol);


var
WorkString:
string;

begin
readln (ProtocolListFile, WorkString);
with Protocol do
begin
DivideAtSemicolon (WorkString, Name);
DivideAtSemicolon (WorkString, Filespec);
DivideAtSemicolon (WorkString, UploadCommand);
DownloadCommand := WorkString
end
end;

begin
if not FileExists (ProtocolSpec) then
Abort ('Error: Cannot find FILEDOOR.DEF file. Please inform sysop.');
assign (ProtocolListFile, ProtocolSpec);
reset (ProtocolListFile);
with ProtocolList do
begin
NumberOfProtocols := 0;
while not eof (ProtocolListFile) do
begin
NumberOfProtocols := (NumberOfProtocols + 1);
ReadLnProtocol (ProtocolListFile, ProtocolArray [NumberOfProtocols])
end;
if (NumberOfProtocols = 0) then
Abort ('No external file transfer protocols are installed.')
end;
close (ProtocolListFile)
end;


procedure GetTimeLimit (var TimeLimit:
byte);

begin
if (paramcount < 1) then
TimeLimit := DefaultTime
else
TimeLimit := ValueOf (paramstr (1))
end;


procedure GetConfig (var Config:
ConfigType);

var
ConfigFile:
file;

begin
if not FileExists (ConfigSpec) then
Abort ('Error: Cannot find CONFIG.BBS file. Please inform sysop.');
assign (ConfigFile, ConfigSpec);
reset (ConfigFile, sizeof (ConfigType));
blockread (ConfigFile, Config, 1);
close (ConfigFile)
end;


procedure GetUser (var User:
UserType;
UserIndex:
integer);

var
UserFile:
file;

begin
if not FileExists (UserSpec) then
Abort ('Error: Cannot find USER.BBS file. Please inform sysop.');
assign (UserFile, UserSpec);
reset (UserFile, sizeof (UserType));
seek (UserFile, UserIndex);
blockread (UserFile, User, 1);
close (UserFile)
end;


procedure FindCurrentDirectory ( DirectoryList:
TypeDirectoryList;
FileAccess:
byte;
var CurrentDirectory:
char);

begin
with DirectoryList do
begin
CurrentDirectory := 'A';
while (FileAccess < DirectoryArray [CurrentDirectory].Access) and
(CurrentDirectory < LastDirectory) do
CurrentDirectory := succ (CurrentDirectory);
if (FileAccess < DirectoryArray [CurrentDirectory].Access) then
Abort ('No file directories available to you.')
end
end;


procedure GetUserInfo (var UserInfo:
TypeUserInfo;
DirectoryList:
TypeDirectoryList);

begin
with UserInfo do
begin
GetCurrentTime (StartTime);
GetTimeLimit (TimeLimit);
GetConfig (Config);
GetUser (User, Config.CurrUser);
FindCurrentDirectory (DirectoryList, User.FAccess, CurrentDirectory)
end
end;


procedure Initialize (var DirectoryList:
TypeDirectoryList;
var ProtocolList:
TypeProtocolList;
var UserInfo:
TypeUserInfo;
var MenuChoice:
integer);

BEGIN
TextColor (White);
TextBackground (Blue);
clrscr;
TextBackground (Black);
directvideo := false;
UseColor (Normal);
window (1, 1, 80, 24);
ClearScreen;
writeln (output, 'File Door version 3.1');
GetDirectoryList (DirectoryList);
GetProtocolList (ProtocolList);
GetUserInfo (UserInfo, DirectoryList);
MenuChoice := 1;
directvideo := true;
TextColor (White);
TextBackground (Blue);
window (1, 1, 80, 25);
gotoxy (1, 25);
write ('File Door ', UserInfo.User.Name);
directvideo := false;
window (1, 1, 80, 24);
UseColor (Normal);
END;


{-----------------------------------------------------------------------------}


function NewMenuChoice ( CurrentChoice:
integer;
Key:
char): integer;

begin
case Key of
CR : ;
SP : NewMenuChoice := ((CurrentChoice mod MaxMenuItems) + 1);
BS : if (CurrentChoice = 1) then
NewMenuChoice := MaxMenuItems
else
NewMenuChoice := (CurrentChoice - 1)
else
for CurrentChoice := 1 to MaxMenuItems do
if (Menu [CurrentChoice, 1] = Key) then
NewMenuChoice := CurrentChoice
end
end;


procedure GetMenuChoice (var MenuChoice:
integer;
DirectoryList:
TypeDirectoryList;
CurrentDirectory:
char);

var
Key:
char;

begin
UseColor (SubColor);
write (output, '[', CurrentDirectory, '] ');
UseColor (Normal);
write (output, DirectoryList.DirectoryArray [CurrentDirectory].Name, ' >');
UseColor (ComColor);
write (output, Menu [MenuChoice]);
repeat
Key := upcase (readkey);
if (Key in ValidChoices) and (Key <> CR) then
begin
write (output, StringOf (BS, length (Menu [MenuChoice])));
write (output, StringOf (SP, length (Menu [MenuChoice])));
write (output, StringOf (BS, length (Menu [MenuChoice])));
MenuChoice := NewMenuChoice (MenuChoice, Key);
write (output, Menu [MenuChoice])
end
until (Key = CR);
writeln (output);
writeln (output);
UseColor (Normal)
end;


{-----------------------------------------------------------------------------}


procedure Help;

begin
write (output, '-----------------------');
UseColor (HeadColor);
write (output, ' [ File Door Command Summary ] ');
UseColor (Normal);
writeln (output, '----------------------');
writeln (output);
writeln (output, ' Download .. Download File New ....... New Files by Date');
writeln (output, ' Files ..... Directory of Files Quit ...... Return to BBS');
writeln (output, ' Jump ...... Jump to Directory Space ..... Show Free Disk Space');
writeln (output, ' List ...... List of Directories Upload .... Upload File');
writeln (output);
writeln (output, '----------------------------------------------------------------------------');
writeln (output)
end;


procedure Jump (var CurrentDirectory:
char;
DirectoryList:
TypeDirectoryList;
FileAccess:
byte);

forward;


procedure List ( DirectoryList:
TypeDirectoryList;
FileAccess:
byte);

var
I:
char;

begin
ClearScreen;
UseColor (HeadColor);
writeln (output, 'Directory of Files');
writeln (output);
UseColor (Normal);
writeln (output, ' Name Description');
with DirectoryList do
for I := 'A' to LastDirectory do
if (FileAccess >= DirectoryArray [I].Access) then
with DirectoryArray [I] do
begin
UseColor (Normal);
write (output, I, '- ');
UseColor (SubColor);
write (output, Name, SP);
write (output, StringOf ('.', (11 - length (Name))));
UseColor (HeadColor);
writeln (output, SP, Description)
end;
writeln (output);
UseColor (Normal)
end;


procedure ShowNumFiles ( Directory:
TypeDirectory);

var
DirectoryFile:
file;
RootEntry:
DirType;

begin
UseColor (SubColor);
writeln (output, 'Active Directory: ', Directory.Name);
if FileExists (DirectoryFileName (Directory)) then
begin
OpenDirectoryFile (DirectoryFile, Directory);
ReadEntry (DirectoryFile, 0, RootEntry);
writeln (output, RootEntry.Files:4, ' files')
end
else
writeln (output, ' 0 files');
writeln (output);
UseColor (Normal)
end;


procedure Jump;

var
NewDirectory:
char;

begin
write (output, 'Enter Dir Letter [A-', DirectoryList.LastDirectory, ',?]: ');
repeat
NewDirectory := upcase (readkey);
if (NewDirectory = '?') then
begin
List (DirectoryList, FileAccess);
write (output, 'Enter Dir Letter [A-',
DirectoryList.LastDirectory, ',?]: ')
end
until (NewDirectory in [CR, 'A'..DirectoryList.LastDirectory]);
writeln (output, NewDirectory);
writeln (output);
if (NewDirectory <> CR) then
if (FileAccess < DirectoryList.DirectoryArray [NewDirectory].Access) then
writeln (output, 'Access denied.', CR)
else
begin
CurrentDirectory := NewDirectory;
ShowNumFiles (DirectoryList.DirectoryArray [CurrentDirectory])
end
end;


procedure WriteFilesHeading;

begin
ClearScreen;
UseColor (HeadColor);
writeln (output, 'Directory of Files');
writeln (output);
writeln (output, 'Filename Pw Size Description');
writeln (output, '----------------------------------------------------------');
UseColor (Normal)
end;


function NoPassword ( Pw:
PwType): boolean;

begin
NoPassword := (Pw [1] = 0) and (Pw [2] = 0) and (Pw [3] = 0)
end;


procedure DisplayEntry ( Entry:
DirType;
var ScreenLine:
integer);

procedure Pause;

var
Dummy:
char;

begin
UseColor (Special);
write (output, '---more---');
if (readkey = chr (0)) then
Dummy := readkey;
write (output, StringOf (BS, length ('---more---')));
UseColor (Normal)
end;

begin
if (ScreenLine = 24) then
begin
Pause;
ScreenLine := 1
end;
if NoPassword (Entry.Passwd) then
write (output, Entry.Name, SP:(18 - length (Entry.Name)))
else
write (output, Entry.Name, SP:(15 - length (Entry.Name)), '+ ');
write (output, (Entry.Length / 1024 * 128):8:1);
writeln (output, 'K ', Entry.Descrip);
ScreenLine := ScreenLine + 1
end;


procedure CheckForUserInterrupt (var Stop:
boolean);

var
Key:
char;

begin
if keypressed then
begin
Key := readkey;
if (Key = SP) then
begin
UseColor (Special);
writeln (output, '^C');
UseColor (Normal);
Stop := true
end
else
if (Key = chr (0)) then
Key := readkey
end;
end;


function PastDate (var TestDate,
ControlDate:
DateType): boolean;

begin
if (TestDate.Year = ControlDate.Year) then
if (TestDate.Month = ControlDate.Month) then
PastDate := (TestDate.Day >= ControlDate.Day)
else
PastDate := (TestDate.Month > ControlDate.Month)
else
PastDate := (TestDate.Year > ControlDate.Year)
end;


procedure GetAndDisplayEntry (var DirectoryFile:
file;
Index:
integer;
var Date:
DateType;
var ScreenLine:
integer;
var Stop:
boolean);

var
Entry:
DirType;

begin
CheckForUserInterrupt (Stop);
if (not Stop) and (Index <> Null) then
begin
ReadEntry (DirectoryFile, Index, Entry);
GetAndDisplayEntry (DirectoryFile, Entry.Left, Date, ScreenLine, Stop);
if Entry.Active then
if PastDate (Entry.Date, Date) then
DisplayEntry (Entry, ScreenLine);
GetAndDisplayEntry (DirectoryFile, Entry.Right, Date, ScreenLine, Stop)
end
end;


procedure Files ( Directory:
TypeDirectory);

var
DirectoryFile:
file;
RootEntry:
DirType;
ScreenLine:
integer;
Stop:
boolean;
Date:
DateType;


begin
WriteFilesHeading;
if FileExists (DirectoryFileName (Directory)) then
begin
OpenDirectoryFile (DirectoryFile, Directory);
ScreenLine := 5;
Stop := false;
ReadEntry (DirectoryFile, 0, RootEntry);
Date.Year := 0;
Date.Month := 0;
Date.Day := 0;
GetAndDisplayEntry (DirectoryFile, RootEntry.DataRoot, Date, ScreenLine, Stop);
close (DirectoryFile)
end;
writeln (output);
writeln (output)
end;


procedure ConvertDate (var DateString:
string;
var Date:
DateType;
var Valid:
boolean);

var
ErrorCode:
integer;

begin
Valid := true;
if (pos ('-', DateString) < 2) then
Valid := false
else
begin
val (copy (DateString, 1, pos ('-', DateString) - 1), Date.Month, ErrorCode);
delete (DateString, 1, pos ('-', DateString));
if (pos ('-', DateString) < 2) then
Valid := false
else
begin
val (copy (DateString, 1, pos ('-', DateString) - 1), Date.Day, ErrorCode);
delete (DateString, 1, pos ('-', DateString));
if (DateString = '') then
Valid := false
else
val (DateString, Date.Year, ErrorCode)
end
end
end;


procedure GetNewDate (var Date:
DateType;
LastCalled:
DateType;
var Valid:
boolean);

var
DateString:
string [8];

begin
ClearScreen;
UseColor (HeadColor);
writeln (output, 'New Files by Date');
writeln (output);
UseColor (Normal);
with LastCalled do
write (output, 'Enter target date MM-DD-YY [RETURN for ', Month, '-', Day, '-', Year, ']: ');
ReadLnString (DateString, 8, ['-', '0'..'9'], false, false, ChatColor);
if (DateString = '') then
begin
Valid := true;
Date := LastCalled
end
else
ConvertDate (DateString, Date, Valid)
end;


procedure NewFiles ( Directory:
TypeDirectory;
LastCalled:
DateType);

var
Date:
DateType;
DirectoryFile:
file;
RootEntry:
DirType;
ScreenLine:
integer;
Stop:
boolean;
Valid:
boolean;

begin
GetNewDate (Date, LastCalled, Valid);
if Valid then
begin
WriteFilesHeading;
if FileExists (DirectoryFileName (Directory)) then
begin
OpenDirectoryFile (DirectoryFile, Directory);
ScreenLine := 5;
Stop := false;
ReadEntry (DirectoryFile, 0, RootEntry);
GetAndDisplayEntry (DirectoryFile, RootEntry.DataRoot, Date, ScreenLine, Stop);
close (DirectoryFile)
end;
writeln (output)
end
else
writeln (output, 'Invalid date format.');
writeln (output)
end;


procedure Space;

begin
writeln (output, 'Space Available ', diskfree (0):10, ' bytes');
writeln (output, 'Total Space ', disksize (0):10, ' bytes');
writeln (output)
end;


{-----------------------------------------------------------------------------}


procedure GetProtocolToUse ( ProtocolList:
TypeProtocolList;
var ProtocolToUse:
TypeProtocol;
var Stop:
boolean);

var
I:
integer;
ProtocolNumber:
string [2];

begin
writeln (output, 'Select Transfer Protocol:');
writeln (output);

with ProtocolList do
for I := 1 to NumberOfProtocols do
writeln (output, I:2, '. ', ProtocolArray [I].Name);
writeln (output);
write (output, 'Choice: ');
ReadLnString (ProtocolNumber, 2, ['0'..'9'], false, false, ChatColor);
writeln (output);
with ProtocolList do
if (ValueOf (ProtocolNumber) in [1..NumberOfProtocols]) then
begin
Stop := false;
ProtocolToUse := ProtocolArray [ValueOf (ProtocolNumber)]
end
else
Stop := true;
end;


procedure ReadLnFileName (var FileName:
string);

begin
write (output, 'Enter Filename: ');
ReadLnString (FileName, 12, ['0'..'9', 'A'..'Z', '.', '!', '@', '#', '$', '&'],
true, false, ChatColor)
end;


procedure TransferFile ( FileSpec,
CommandLine,
FileName:
string;
DirectoryPath:
string);

var
CmdLine:
string;

begin
window (1, 1, 80, 25);
SetSearchlightIO (false);
FileName := DirectoryPath + '\' + FileName;
swapvectors;
CmdLine := copy (CommandLine, 1, pos ('%FILE', CommandLine) - 1) +
FileName + copy (CommandLine, pos ('%FILE', CommandLine) + 6, 255);
exec (FileSpec, CmdLine);
swapvectors;
SetSearchlightIO (true);
window (1, 1, 80, 24);
writeln (output);
writeln (output)
end;


procedure UpdateUserFile ( UserInfo:
TypeUserInfo);

var
UserFile:
file;

begin
assign (UserFile, UserSpec);
reset (UserFile, sizeof (UserType));
seek (UserFile, UserInfo.Config.CurrUser);
blockwrite (UserFile, UserInfo.User, 1);
close (UserFile)
end;


function PasswordOk ( Password:
PwType): boolean;

var
AttemptString:
PwStr;
Attempt:
PwType;

begin
if NoPassword (Password) then
PasswordOk := true
else
begin
write (output, 'Password: ');
ReadLnString (AttemptString, 60, [#32..#126], true, true, ChatColor);
Hash (AttemptString, Attempt);
if (Attempt [1] = Password [1]) and
(Attempt [2] = Password [2]) and
(Attempt [3] = Password [3]) then
PasswordOk := true
else
begin
writeln (output);
UseColor (ErrColor);
writeln (output, 'Access denied');
UseColor (Normal);
writeln (output);
PasswordOk := false
end
end
end;


procedure WriteDownloadHeader ( NumBlocks:
integer;
ProtocolToUse:
TypeProtocol);

begin
writeln (output);
writeln (output, 'File size = ', (NumBlocks / 1024 * 128):0:1, 'K');
writeln (output, 'Ready to send via ', ProtocolToUse.Name)
end;


procedure PrepareToDownload (var DirectoryFile:
file;
DirectoryPath:
string;
ProtocolList:
TypeProtocolList;
var ProtocolToUse:
TypeProtocol;
var Index:
integer;
var Entry:
DirType;
var Stop:
boolean);

var
FileName:
string;
Back:
integer;

begin
GetProtocolToUse (ProtocolList, ProtocolToUse, Stop);
if not Stop then
begin
ReadLnFileName (FileName);
SearchDirectoryFile (DirectoryFile, FileName, Index, Back);
if (Index = Null) then
begin
UseColor (ErrColor);
writeln (output, 'File not found');
UseColor (Normal);
writeln (output);
Stop := true
end
else
if not FileExists (DirectoryPath + '\' + FileName) then
begin
UseColor (ErrColor);
writeln (output, 'Sorry, file is not');
writeln (output, 'available on disk.');
UseColor (Normal);
Stop := true
end
else
begin
ReadEntry (DirectoryFile, Index, Entry);
Stop := not PasswordOk (Entry.Passwd);
if not Stop then
WriteDownloadHeader (Entry.Length, ProtocolToUse)
end
end
end;


procedure Download ( Directory:
TypeDirectory;
ProtocolList:
TypeProtocolList;
var UserInfo:
TypeUserInfo);

var
DirectoryFile:
file;
ProtocolToUse:
TypeProtocol;
Index:
integer;
Entry:
DirType;
Stop:
boolean;

begin
OpenDirectoryFile (DirectoryFile, Directory);
PrepareToDownload (DirectoryFile, Directory.Path, ProtocolList,
ProtocolToUse, Index, Entry, Stop);
if not Stop then
begin
with ProtocolToUse do
TransferFile (FileSpec, DownloadCommand, Entry.Name, Directory.Path);
if (dosexitcode = 0) then
begin
inc (UserInfo.User.Downloads, round (Entry.Length / 1024 * 128));
UpdateUserFile (UserInfo);
inc (Entry.Times.Low, 1);
UpdateEntry (DirectoryFile, Index, Entry)
end
end;
close (DirectoryFile)
end;


procedure CheckDiskSpace (var Stop:
boolean);

var
Answer:
char;

begin
if (diskfree (0) < 163840) then {160k}
begin
writeln (output, 'Disk space = ', diskfree (0), '.');
write (output, 'Is this enough (Y/N)? ');
repeat
Answer := upcase (readkey)
until (Answer in ['Y', 'N']);
UseColor (ChatColor);
writeln (output, Answer);
UseColor (Normal);
Stop := (Answer = 'N')
end
else
Stop := false
end;


procedure PrepareToUpload (var DirectoryFile:
file;
DirectoryPath:
string;
ProtocolList:
TypeProtocolList;
var ProtocolToUse:
TypeProtocol;
var FileName:
string;
var Stop:
boolean);

begin
CheckDiskSpace (Stop);
if not Stop then
begin
GetProtocolToUse (ProtocolList, ProtocolToUse, Stop);
if not Stop then
begin
ReadLnFileName (FileName);
if (FileName = '') then
Stop := true
else
if FileExists (DirectoryPath + '\' + FileName) then
begin
writeln (output, 'File is already in directory');
writeln (output, 'Thanks anyways');
writeln (output);
Stop := true
end
else
begin
writeln (output);
writeln (output, 'Ready to receive ', FileName, ' via ',
ProtocolToUse.Name)
end
end
end
end;


procedure UpdateConfigFile ( Config:
ConfigType);

var
ConfigFile:
file;

begin
assign (ConfigFile, ConfigSpec);
rewrite (ConfigFile, sizeof (ConfigType));
blockwrite (ConfigFile, Config, 1);
close (ConfigFile)
end;


procedure GetUploadDate (var Date:
DateType);

var
BigYear,
BigMonth,
BigDay,
Unused:
word;

begin
getdate (BigYear, BigMonth, BigDay, Unused);
Date.Year := (BigYear - 1900);
Date.Month := lo (BigMonth);
Date.Day := lo (BigDay)
end;


procedure CreateAndAddEntry (var DirectoryFile:
file;
Directory:
TypeDirectory;
FileName:
string;
UserID:
integer;
var Entry:
DirType);
var
SearchRecord:
searchrec;

begin
findfirst (Directory.Path + '\' + FileName, Archive, SearchRecord);
with Entry do
begin
Active := true;
Name := FileName;
writeln (output);
writeln (output, 'Upload successful.');
writeln (output);
writeln (output, 'Description:');
ReadLnString (Descrip, 40, [#32..#126], false, false, Inverse);
Length := (SearchRecord.Size div 128);
ID := UserID;
GetUploadDate (Date);
Times.Hi := 0;
Times.Low := 0;
Hash ('', Passwd)
end;
AddEntry (DirectoryFile, Entry)
end;



procedure Upload ( Directory:
TypeDirectory;
ProtocolList:
TypeProtocolList;
var UserInfo:
TypeUserInfo);

var
DirectoryFile:
file;
ProtocolToUse:
TypeProtocol;
FileName:
string;
Stop:
boolean;
BonusTime:
DateTime;
Entry:
DirType;

begin
OpenDirectoryFile (DirectoryFile, Directory);
PrepareToUpload (DirectoryFile, Directory.Path, ProtocolList, ProtocolToUse,
FileName, Stop);
if not Stop then
begin
GetCurrentTime (BonusTime);
with ProtocolToUse do
TransferFile (FileSpec, UploadCommand, FileName, Directory.Path);
inc (UserInfo.TimeLimit, ElapsedTime (BonusTime));
inc (UserInfo.Config.TimeLimit, ElapsedTime (BonusTime));
UpdateConfigFile (UserInfo.Config);
if FileExists (Directory.Path + '\' + FileName) then
begin
CreateAndAddEntry (DirectoryFile, Directory, FileName, UserInfo.Config.CurrUser, Entry);
inc (UserInfo.User.Uploads, round (Entry.Length / 1024 * 128));
UpdateUserFile (UserInfo)
end
end;
close (DirectoryFile)
end;


{-----------------------------------------------------------------------------}


procedure DoMenuChoice ( MenuChoice:
integer;
DirectoryList:
TypeDirectoryList;
ProtocolList:
TypeProtocolList;
var UserInfo:
TypeUserInfo);

begin
if (Menu [MenuChoice] = 'Help') then
Help
else if (Menu [MenuChoice] = 'Download') then
Download (DirectoryList.DirectoryArray [UserInfo.CurrentDirectory], ProtocolList, UserInfo)
else if (Menu [MenuChoice] = 'Files') then
Files (DirectoryList.DirectoryArray [UserInfo.CurrentDirectory])
else if (Menu [MenuChoice] = 'Jump') then
Jump (UserInfo.CurrentDirectory, DirectoryList, UserInfo.User.FAccess)
else if (Menu [MenuChoice] = 'List') then
begin
List (DirectoryList, UserInfo.User.FAccess);
Jump (UserInfo.CurrentDirectory, DirectoryList, UserInfo.User.FAccess)
end
else if (Menu [MenuChoice] = 'New') then
NewFiles (DirectoryList.DirectoryArray [UserInfo.CurrentDirectory], UserInfo.User.LastOn)
else if (Menu [MenuChoice] = 'Space') then
Space
else if (Menu [MenuChoice] = 'Upload') then
Upload (DirectoryList.DirectoryArray [UserInfo.CurrentDirectory], ProtocolList, UserInfo)
else if (Menu [MenuChoice] <> 'Quit') then
writeln (output, 'Command invalid.')
end;


begin
Initialize (DirectoryList, ProtocolList, UserInfo, MenuChoice);
ShowNumFiles (DirectoryList.DirectoryArray [UserInfo.CurrentDirectory]);
repeat
GetMenuChoice (MenuChoice, DirectoryList, UserInfo.CurrentDirectory);
DoMenuChoice (MenuChoice, DirectoryList, ProtocolList, UserInfo)
until (Menu [MenuChoice] = 'Quit') or
(ElapsedTime (UserInfo.StartTime) > UserInfo.TimeLimit)
end.