Opera в Web : #"1.files/image036.gif">
Броузер написан на языке Borland Delphi
3.0.
Рис.7. Панель демонстрационного броузера.
4.2.Основные процедуры броузера
WWW-сервис:
procedure
TMainForm.Exit1Click – осуществляет выход из программы;
procedure
TMainForm.FindAddress – запрашивает HTML-файл по указанному
адресу;
procedure
TMainForm.DocumentSource1Click – выводит исходный текст полученного HTML-файла;
procedure
TMainForm.StopBtnClick – останавливает загрузку HTML-файла;
procedure
TMainForm.RefreshBtnClick – перегружает последний полученный HTML-файл;
procedure
TMainForm.BackBtnClick – вызывает предыдущий загруженный HTML-файл;
procedure
TMainForm.ForwardBtnClick – вызывает последующий загруженный HTML-файл;
procedure
TMainForm.ToolButton2Click – загружает объект TMail, ответственный за отправку
и получение почты;
procedure
TMainForm.ToolButton3Click – загружает объект TMyFtp, ответственный за обмен
данных в протоколе FTP;
procedure TMainForm.ToolButton4Click
– загружает объект TNewsForm, ответственный за получение и отправку новостей;
procedure
TMainForm.ToolButton9Click – загружает объект TChatForm, ответственный за обмен
символьной информацией между двумя удаленными компьютерами;
FTP-сервис:
procedure
TMyFtp.ConnectBtnClick – соединяется с указанным FTP-сервером;
procedure
TMyFtp.Disconnect – обрывает соединение с FTP-сервером;
procedure
TMyFtp.CopyItemClick – выполняет копирование выбранного файла с FTP-сервера;
procedure
TMyFtp.PasteFromItemClick – отсылает файл на FTP-сервер;
Chat-сервис:
procedure
TChatForm.FileConnectItemClick – выполняет запрос адреса компьютера, с которым
будет происходить обмен символльной информацией;
procedure
TChatForm.Memo1KeyDown – считывание символа с клавиатуры и отправка его в сокет
клиента;
procedure
TChatForm.Disconnect1Click – разрывает соединение с удаленным компьютером;
procedure
TChatForm.ClientSocketRead – считывание информации с удаленного компьютера;
News-сервис:
procedure
TNewsForm.FileConnectItemClick – выполняет соединение с сервером новостей;
procedure
TNewsForm.FileDisconnectItemClick – разрывает соединение с сервером новостей;
procedure
TNewsForm.NNTP1DocOutput – вывод групп новостей;
Mail-сервис:
procedure TMail.CreateHeaders – создает заголовок для почтового сообщения;
procedure TMail.SendMessage – отправляет сообщение;
procedure
TMail.SendFile – отправляет файл, “привязанный” к письму;
procedure TMail.SMTP1DocInput
– ввод текста почтового сообщения;
procedure
TMail.SMTPConnectBtnClick – выполняет соединение с почтовывм сервером;
4.3.Архитектура
имитационной модели глобальной сети
Имитационная модель глобальной корпоративной сети
имитирует пересылку пакета от одного компьютера к другому. При запуске
программы на экране возникает схема сети, показанная на рисунке 8. Затем, при
нажатии клавиши ENTER, программа переходит в текстовый режим с UNIX-подобным интерфейсом, запрашивая пользователя адрес
получателя, адрес отправителя, и данные типа “String”.
Затем каждый компьютер или маршрутизатор, по которому
проходит пакет, выводит на экран сообщение о приеме и дальнейшей отправке
пакета адресату и время, в которое он получил и отправил пакет. Оптимальный
маршрут рассчитывается на основе усовершенствованного алгоритма Форда-Беллмана.
Программа написана на языке Object Pascal 7.0.
Рис.8. Схема глобальной корпоративной сети.
4.4.Основные
процедуры имитационной модели
Типы данных и
переменные основной подпрограммы:
const AdjacencyMatrix
: array[1..VertexQuantity,1..VertexQuantity] of byte =(
(0,1,0,1,0,0,0),
(1,1,1,0,1,0,1),
(0,1,0,1,0,0,0),
(1,0,1,0,1,0,0),
(0,1,0,0,1,1,0),
(0,0,0,0,1,0,1),
(0,1,0,0,0,1,0) ) – матрица смежности маршрутизаторов;
TYPE TAddr = record
router:byte;
domain:byte;
comp :byte;
END - адрес компьютера,
состоящий из номера маршрутизатора, номера области данного маршрутизатора и
номера компьютера в этой области;
TYPE TBatch = record
from:TAddr;
to_ :TAddr;
data:string;
path:array[1..20] of
byte; {path is chain of router numbers}
END – пакет, состоящий
из адреса отправителя, адреса получателя, данных и пути следования пакета;
TYPE TComp = object -
модель компьютера, состоящая из адреса, ячейки памяти для
получения или пересылки пакета;
addr:TAddr;
mem :TBatch;
Procedure
Send2Router(batch:TBatch) – процедура посылки пакета на маршрутизатор;
Procedure
Send(batch:TBatch) – процедура посылки пакета внутри своей сети;
Procedure
Receive(batch:TBatch;byRouter:boolean) – прием пакета;
END;
TYPE TRouter = object
- модель маршрутизатора, состоящая из номера маршрутизатора,
его координат, и ячейки памяти;
num
:byte;
x,y
:integer;
memory
:Tbatch;
state
:boolean;
VAR computers :
array[1..38] of TComp - массив компьютеров глобальной сети;
routers :
array[1..7] of TRouter – массив маршрутизаторов;
OptimalPath :
array[1..49] of byte – оптимальный путь, рассчитанный
маршрутизатором;
Procedure
Receive(routerNum:byte;batch:TBatch) – прием пакета;
Procedure
Send2Comp(batch:TBatch) – отправка пакета в своей сети;
Procedure
CalcMinPath(sender,target:byte) – вычисление оптимального пути отправки;
Procedure
Send2NextRouter(batch:TBatch;currentRouter:byte) – отправка на
следующий
маршрутизатор;
END;
Заключение
В данной дипломной работе был получен следующий
результат :
1.) Разработана модель сетевого броузера и
корпоративной среды;
2.) Создана имитационная модель распределения
информации в глобальных сетях.
3.) Написано соответствующее программное обеспечение –
сетевой броузер с возможностью доступа как к WWW- протоколу, так и к сервису FTP, почтовому сервису SMTP, а также возможностью обмена символьной информацией
между двумя компьютерами в ON-LINE режиме
– CHAT и математическая
модель корпоративной сети, имитирующая передачу информации в глобальной среде,
в которой реализован разработанный усовершенствованный алгоритм поиска
оптимального пути между маршрутизаторами.
Список литературы :
1. Блэк Ю. Сети ЭВМ: протоколы, стандарты, интерфейсы. М.:Мир,1990.
–506 с.
2. Донской В.И. Компьютерные сети
и сетевые технологии.- Симферополь:
Таврида,1999.
– 135 с.
3.
Калверт Ч. Delphi 4. Самоучитель. – К.: ДиаСофт, 1999. – 192 с.
4.
Крамлиш К. Азбука Internet. К.:Юниор, 1998. –336 с.
5.
Нанс Б. Компьютерные сети. М.:Бином, 1996. –400 с.
6.
Нотон П., Шилдт Г. Полный справочник по Java. – К.: Диалектика,1997. –450 с.
7.
Сван Т. Delphi 4 – “Библия” разработчика. –К.: Диалектика,1998. –500 с.
8.
Яблонский С.В. Введение в дискретную математику. –М.: Наука,1986. –384 с.
9. Журнал «Компьютерное Обозрение», N36
(109) ‘97, N44 (117) ‘97
Приложение
1. Исходный текст программы “броузер”
файл main.pas
unit
Main;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls, Menus, ComCtrls, OleCtrls, Buttons, ToolWin, Isp3;
const
CM_HOMEPAGEREQUEST = WM_USER + $1000;
type
TMainForm = class(TForm)
StatusBar1: TStatusBar;
MainMenu1: TMainMenu;
File1: TMenuItem;
Exit1: TMenuItem;
View1: TMenuItem;
DocumentSource1: TMenuItem;
NavigatorImages: TImageList;
NavigatorHotImages: TImageList;
LinksImages: TImageList;
LinksHotImages: TImageList;
CoolBar1: TCoolBar;
ToolBar1: TToolBar;
BackBtn: TToolButton;
ForwardBtn: TToolButton;
StopBtn: TToolButton;
RefreshBtn: TToolButton;
URLs: TComboBox;
HTML1: THTML;
Help1: TMenuItem;
About1: TMenuItem;
N1: TMenuItem;
Toolbar3: TMenuItem;
Statusbar2: TMenuItem;
ToolButton1: TToolButton;
ToolButton2: TToolButton;
ToolButton3: TToolButton;
ToolButton4: TToolButton;
ToolButton9: TToolButton;
SpeedButton1: TSpeedButton;
procedure Exit1Click(Sender: TObject);
procedure About1Click(Sender: TObject);
procedure DocumentSource1Click(Sender: TObject);
procedure StopBtnClick(Sender: TObject);
procedure HTML1BeginRetrieval(Sender: TObject);
procedure HTML1EndRetrieval(Sender: TObject);
procedure URLsKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure FormCreate(Sender: TObject);
procedure LinksClick(Sender: TObject);
procedure RefreshBtnClick(Sender: TObject);
procedure BackBtnClick(Sender: TObject);
procedure ForwardBtnClick(Sender: TObject);
procedure HTML1DoRequestDoc(Sender: TObject; const URL: WideString;
const Element: HTMLElement; const DocInput: DocInput;
var EnableDefault: WordBool);
procedure FormDestroy(Sender: TObject);
procedure URLsClick(Sender: TObject);
procedure FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure Toolbar3Click(Sender: TObject);
procedure Statusbar2Click(Sender: TObject);
procedure ToolButton2Click(Sender: TObject);
procedure ToolButton3Click(Sender: TObject);
procedure ToolButton4Click(Sender: TObject);
procedure ToolButton9Click(Sender: TObject);
private
HistoryIndex: Integer;
HistoryList: TStringList;
UpdateCombo: Boolean;
procedure FindAddress;
procedure HomePageRequest(var message: tmessage); message CM_HOMEPAGEREQUEST;
end;
var
MainForm: TMainForm;
implementation
uses
DocSrc, About, SMTP, FTP, NNTP, CHAT;
{$R
*.DFM}
procedure
TMainForm.Exit1Click(Sender: TObject);
begin
Close;
end;
procedure
TMainForm.FindAddress;
begin
HTML1.RequestDoc(URLs.Text);
end;
procedure
TMainForm.About1Click(Sender: TObject);
begin
ShowAboutBox;
end;
procedure
TMainForm.DocumentSource1Click(Sender: TObject);
begin
with DocSourceFrm do
begin
Show;
Memo1.Lines.Clear;
Memo1.Lines.Add(AdjustLineBreaks(HTML1.SourceText));
Memo1.SelStart := 0;
SendMessage(Memo1.Handle, EM_ScrollCaret, 0, 0);
end;
end;
procedure
TMainForm.StopBtnClick(Sender: TObject);
begin
HTML1.Cancel('Cancel');
HTML1EndRetrieval(nil);
end;
procedure
TMainForm.HTML1BeginRetrieval(Sender: TObject);
begin
{ Turn the stop button dark red }
StopBtn.ImageIndex := 4;
{ Play the avi from the first frame indefinitely }
Animate1.Active := True;
end;
procedure
TMainForm.HTML1EndRetrieval(Sender: TObject);
begin
{ Turn the stop button grey }
StopBtn.ImageIndex := 2;
{ Stop the avi and show the first frame }
Animate1.Active := False;
end;
procedure
TMainForm.URLsKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if Key = VK_Return then
begin
UpdateCombo := True;
FindAddress;
end;
end;
procedure
TMainForm.URLsClick(Sender: TObject);
begin
UpdateCombo := True;
FindAddress;
end;
procedure
TMainForm.LinksClick(Sender: TObject);
begin
if (Sender as TToolButton).Hint = '' then Exit;
URLs.Text := (Sender as TToolButton).Hint;
FindAddress;
end;
procedure
TMainForm.RefreshBtnClick(Sender: TObject);
begin
FindAddress;
end;
procedure
TMainForm.BackBtnClick(Sender: TObject);
begin
URLs.Text := HistoryList[HistoryIndex - 1];
FindAddress;
end;
procedure
TMainForm.ForwardBtnClick(Sender: TObject);
begin
URLs.Text := HistoryList[HistoryIndex + 1];
FindAddress;
end;
procedure
TMainForm.HTML1DoRequestDoc(Sender: TObject;
const URL: WideString; const Element: HTMLElement;
const DocInput: DocInput; var EnableDefault: WordBool);
var
NewIndex: Integer;
begin
NewIndex := HistoryList.IndexOf(URL);
if NewIndex = -1 then
begin
{ Remove entries in HistoryList between last address and current address }
if (HistoryIndex >= 0) and (HistoryIndex < HistoryList.Count - 1) then
while HistoryList.Count > HistoryIndex do
HistoryList.Delete(HistoryIndex);
HistoryIndex := HistoryList.Add(URL);
end
else
HistoryIndex := NewIndex;
if HistoryList.Count > 0 then
begin
ForwardBtn.Enabled := HistoryIndex < HistoryList.Count - 1;
BackBtn.Enabled := HistoryIndex > 0;
end
else
begin
ForwardBtn.Enabled := False;
BackBtn.Enabled := False;
end;
if UpdateCombo then
begin
UpdateCombo := False;
NewIndex := URLs.Items.IndexOf(URL);
if NewIndex = -1 then
URLs.Items.Insert(0, URL)
else
URLs.Items.Move(NewIndex, 0);
end;
URLs.Text := URL;
Statusbar1.Panels[0].Text := URL;
end;
procedure
TMainForm.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if Shift = [ssAlt] then
if (Key = VK_RIGHT) and ForwardBtn.Enabled then
ForwardBtn.Click
else if (Key = VK_LEFT) and BackBtn.Enabled then
BackBtn.Click;
end;
procedure
TMainForm.Toolbar3Click(Sender: TObject);
begin
with Sender as TMenuItem do
begin
Checked := not Checked;
Coolbar1.Visible := Checked;
end;
end;
procedure
TMainForm.Statusbar2Click(Sender: TObject);
begin
with Sender as TMenuItem do
begin
Checked := not Checked;
StatusBar1.Visible := Checked;
end;
end;
procedure
TMainForm.HomePageRequest(var Message: TMessage);
begin
URLs.Text := 'http://www.altavista.com';
UpdateCombo := True;
FindAddress;
end;
procedure
TMainForm.FormCreate(Sender: TObject);
begin
HistoryIndex := -1;
HistoryList := TStringList.Create;
{ Load the animation from the AVI file in the startup directory. An
alternative to this would be to create a .RES file including the cool.avi
as an AVI resource and use the ResName or ResId properties of Animate1 to
point to it. }
Animate1.FileName := ExtractFilePath(Application.ExeName) + 'cool.avi';
{ Find the home page - needs to be posted because HTML control hasn't been
registered yet. }
PostMessage(Handle, CM_HOMEPAGEREQUEST, 0, 0);
end;
procedure
TMainForm.FormDestroy(Sender: TObject);
begin
HistoryList.Free;
end;
procedure
TMainForm.ToolButton2Click(Sender: TObject);
begin
TMail.create(Application).showmodal;
end;
procedure
TMainForm.ToolButton3Click(Sender: TObject);
begin
TMyFtp.create(Application).showmodal;
end;
procedure
TMainForm.ToolButton4Click(Sender: TObject);
begin
TNewsForm.create(Application).showmodal;
end;
procedure
TMainForm.ToolButton9Click(Sender: TObject);
begin
TChatForm.create(Application).showmodal;
end;
end.
файл chat.pas
unit
chat;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Menus, StdCtrls, Buttons, ScktComp, ExtCtrls, ComCtrls;
type
TChatForm = class(TForm)
MainMenu1: TMainMenu;
File1: TMenuItem;
Exit1: TMenuItem;
FileConnectItem: TMenuItem;
FileListenItem: TMenuItem;
StatusBar1: TStatusBar;
Bevel1: TBevel;
Panel1: TPanel;
Memo1: TMemo;
Memo2: TMemo;
N1: TMenuItem;
SpeedButton1: TSpeedButton;
Disconnect1: TMenuItem;
ServerSocket: TServerSocket;
ClientSocket: TClientSocket;
procedure FileListenItemClick(Sender: TObject);
procedure FileConnectItemClick(Sender: TObject);
procedure Exit1Click(Sender: TObject);
procedure Memo1KeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure FormCreate(Sender: TObject);
procedure ServerSocketError(Sender: TObject; Number: Smallint;
var Description: string; Scode: Integer; const Source,
HelpFile: string; HelpContext: Integer; var CancelDisplay: Wordbool);
procedure Disconnect1Click(Sender: TObject);
procedure ClientSocketConnect(Sender: TObject;
Socket: TCustomWinSocket);
procedure ClientSocketRead(Sender: TObject; Socket: TCustomWinSocket);
procedure ServerSocketClientRead(Sender: TObject;
Socket: TCustomWinSocket);
procedure ServerSocketAccept(Sender: TObject;
Socket: TCustomWinSocket);
procedure ServerSocketClientConnect(Sender: TObject;
Socket: TCustomWinSocket);
procedure ClientSocketDisconnect(Sender: TObject;
Socket: TCustomWinSocket);
procedure ClientSocketError(Sender: TObject; Socket: TCustomWinSocket;
ErrorEvent: TErrorEvent; var ErrorCode: Integer);
procedure ServerSocketClientDisconnect(Sender: TObject;
Socket: TCustomWinSocket);
protected
IsServer: Boolean;
end;
var
ChatForm: TChatForm;
Server: String;
implementation
{$R
*.DFM}
procedure
TChatForm.FileListenItemClick(Sender: TObject);
begin
FileListenItem.Checked := not FileListenItem.Checked;
if FileListenItem.Checked then
begin
ClientSocket.Active := False;
ServerSocket.Active := True;
Statusbar1.Panels[0].Text := 'Listening...'
end
else
begin
if ServerSocket.Active then
ServerSocket.Active := False;
Statusbar1.Panels[0].Text := '';
end;
end;
procedure
TChatForm.FileConnectItemClick(Sender: TObject);
begin
if ClientSocket.Active then ClientSocket.Active := False;
if InputQuery('Computer to connect to', 'Address Name:', Server) then
if Length(Server) > 0 then
with ClientSocket do
begin
Host := Server;
Active := True;
end;
end;
procedure
TChatForm.Exit1Click(Sender: TObject);
begin
ServerSocket.Close;
ClientSocket.Close;
Close;
end;
procedure
TChatForm.Memo1KeyDown(Sender: TObject; var Key: Word;
begin
if Key = VK_Return then
if IsServer then
ServerSocket.Socket.Connections[0].SendText(Memo1.Lines[Memo1.Lines.Count - 1])
else
ClientSocket.Socket.SendText(Memo1.Lines[Memo1.Lines.Count - 1]);
end;
procedure
TChatForm.FormCreate(Sender: TObject);
begin
FileListenItemClick(nil);
end;
procedure
TChatForm.ServerSocketError(Sender: TObject; Number: Smallint;
var Description: string; Scode: Integer; const Source, HelpFile: string;
HelpContext: Integer; var CancelDisplay: Wordbool);
begin
ShowMessage(Description);
end;
procedure
TChatForm.Disconnect1Click(Sender: TObject);
begin
ClientSocket.Close;
FileListenItemClick(nil);
end;
procedure
TChatForm.ClientSocketConnect(Sender: TObject;
Socket: TCustomWinSocket);
begin
Statusbar1.Panels[0].Text := 'Connected to: ' + Socket.RemoteHost;
end;
procedure
TChatForm.ClientSocketRead(Sender: TObject;
Socket: TCustomWinSocket);
begin
Memo2.Lines.Add(Socket.ReceiveText);
end;
procedure
TChatForm.ServerSocketClientRead(Sender: TObject;
Socket: TCustomWinSocket);
begin
Memo2.Lines.Add(Socket.ReceiveText);
end;
procedure
TChatForm.ServerSocketAccept(Sender: TObject;
Socket: TCustomWinSocket);
begin
IsServer := True;
Statusbar1.Panels[0].Text := 'Connected to: ' + Socket.RemoteAddress;
end;
procedure
TChatForm.ServerSocketClientConnect(Sender: TObject;
Socket: TCustomWinSocket);
begin
Memo2.Lines.Clear;
end;
procedure
TChatForm.ClientSocketDisconnect(Sender: TObject;
Socket: TCustomWinSocket);
begin
FileListenItemClick(nil);
end;
procedure
TChatForm.ClientSocketError(Sender: TObject;
Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
var ErrorCode: Integer);
begin
Memo2.Lines.Add('Error connecting to : ' + Server);
ErrorCode := 0;
end;
procedure
TChatForm.ServerSocketClientDisconnect(Sender: TObject;
Socket: TCustomWinSocket);
begin
ServerSocket.Active := False;
FileListenItem.Checked := not FileListenItem.Checked;
FileListenItemClick(nil);
end;
end.
файл ftp.pas
unit
ftp;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Buttons, StdCtrls, ComCtrls, OleCtrls, Menus, ExtCtrls, isp3;
const
FTPServer = 0;
Folder = 1;
OpenFolder = 2;
type
TMyFtp = class(TForm)
Bevel1: TBevel;
Panel1: TPanel;
Panel2: TPanel;
Panel3: TPanel;
StatusBar: TStatusBar;
FileList: TListView;
DirTree: TTreeView;
ConnectBtn: TSpeedButton;
FTP: TFTP;
RefreshBtn: TSpeedButton;
MainMenu1: TMainMenu;
FileMenu: TMenuItem;
FileNewItem: TMenuItem;
FileDeleteItem: TMenuItem;
FileRenameItem: TMenuItem;
N2: TMenuItem;
FileExitItem: TMenuItem;
View1: TMenuItem;
ViewLargeItem: TMenuItem;
ViewSmallItem: TMenuItem;
ViewListItem: TMenuItem;
ViewDetailsItem: TMenuItem;
N1: TMenuItem;
ViewRefreshItem: TMenuItem;
FilePopup: TPopupMenu;
DeleteItem: TMenuItem;
RenameItem: TMenuItem;
CopyItem: TMenuItem;
Bevel2: TBevel;
Label1: TLabel;
Bevel3: TBevel;
Bevel5: TBevel;
Label2: TLabel;
SaveDialog1: TSaveDialog;
CopyButton: TSpeedButton;
LargeBtn: TSpeedButton;
SmallBtn: TSpeedButton;
ListBtn: TSpeedButton;
DetailsBtn: TSpeedButton;
Tools1: TMenuItem;
ToolsConnectItem: TMenuItem;
ToolsDisconnectItem: TMenuItem;
FileCopyItem: TMenuItem;
PasteFromItem: TMenuItem;
OpenDialog1: TOpenDialog;
SmallImages: TImageList;
procedure ConnectBtnClick(Sender: TObject);
procedure FTPProtocolStateChanged(Sender: TObject;
ProtocolState: Smallint);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure FormCreate(Sender: TObject);
procedure FTPBusy(Sender: TObject; isBusy: Wordbool);
procedure DirTreeChange(Sender: TObject; Node: TTreeNode);
procedure RefreshBtnClick(Sender: TObject);
procedure DirTreeChanging(Sender: TObject; Node: TTreeNode;
var AllowChange: Boolean);
procedure FTPStateChanged(Sender: TObject; State: Smallint);
procedure Open1Click(Sender: TObject);
procedure FileExitItemClick(Sender: TObject);
procedure FormResize(Sender: TObject);
procedure ViewLargeItemClick(Sender: TObject);
procedure ViewSmallItemClick(Sender: TObject);
procedure ViewListItemClick(Sender: TObject);
procedure ViewDetailsItemClick(Sender: TObject);
procedure ViewRefreshItemClick(Sender: TObject);
procedure CopyItemClick(Sender: TObject);
procedure ToolsDisconnectItemClick(Sender: TObject);
procedure FileNewItemClick(Sender: TObject);
procedure DeleteItemClick(Sender: TObject);
procedure PasteFromItemClick(Sender: TObject);
procedure FilePopupPopup(Sender: TObject);
procedure FileMenuClick(Sender: TObject);
procedure FileDeleteItemClick(Sender: TObject);
procedure FTPListItem(Sender: TObject; const Item: FTPDirItem);
private
Root: TTreeNode;
function CreateItem(const FileName, Attributes, Size, Date: Variant):
TListItem;
procedure Disconnect;
public
function NodePath(Node: TTreeNode): String;
end;
var
Myftp: TMyFtp;
UserName,
Pwd: String;
implementation
{$R
*.DFM}
uses
ShellAPI, UsrInfo;
function
FixCase(Path: String): String;
var
OrdValue: byte;
begin
if Length(Path) = 0 then exit;
OrdValue := Ord(Path[1]);
if (OrdValue >= Ord('a')) and (OrdValue <= Ord('z')) then
Result := Path
else
begin
Result := AnsiLowerCaseFileName(Path);
Result[1] := UpCase(Result[1]);
end;
end;
procedure
TMyFtp.ConnectBtnClick(Sender: TObject);
begin
if FTP.State = prcConnected then
Disconnect;
ConnectForm := TConnectForm.Create(Self);
try
if ConnectForm.ShowModal = mrOk then
with FTP, ConnectForm do
begin
UserName := UserNameEdit.Text;
Pwd := PasswordEdit.Text;
RemoteHost := RemoteHostEdit.Text;
RemotePort := StrToInt(RemotePortEdit.Text);
Connect(RemoteHost, RemotePort);
Root := DirTree.Items.AddChild(nil, RemoteHost);
Root.ImageIndex := FTPServer;
Root.SelectedIndex := FTPServer;
DirTree.Selected := Root;
end;
finally
ConnectForm.Free;
end;
end;
procedure
TMyFtp.FTPProtocolStateChanged(Sender: TObject;
ProtocolState: Smallint);
begin
case ProtocolState of
ftpAuthentication: FTP.Authenticate(UserName, Pwd);
ftpTransaction: FTP.List('/');
end;
end;
procedure
TMyFtp.FormClose(Sender: TObject; var Action: TCloseAction);
begin
if FTP.Busy then
begin
FTP.Cancel;
FTP.Quit;
while FTP.Busy do
Application.ProcessMessages;
end;
end;
function
TMyFtp.CreateItem(const FileName, Attributes, Size, Date: Variant): TListItem;
var
Ext: String;
ShFileInfo: TSHFILEINFO;
begin
Result := FileList.Items.Add;
with Result do
begin
Caption := FixCase(Trim(FileName));
if Size > 0 then
begin
if Size div 1024 <> 0 then
begin
SubItems.Add(IntToStr(Size div 1024));
SubItems[0] := SubItems[0] + 'KB';
end
else
SubItems.Add(Size);
end
else
SubItems.Add('');
if Attributes = '1' then
begin
SubItems.Add('File Folder');
ImageIndex := 3;
end
else
begin
Ext := ExtractFileExt(FileName);
ShGetFileInfo(PChar('c:\*' + Ext), 0, SHFileInfo, SizeOf(SHFileInfo),
SHGFI_SMALLICON or SHGFI_SYSICONINDEX or SHGFI_TYPENAME);
if Length(SHFileInfo.szTypeName) = 0 then
begin
if Length(Ext) > 0 then
begin
System.Delete(Ext, 1, 1);
SubItems.Add(Ext + ' File');
end
else
SubItems.Add('File');
end
else
SubItems.Add(SHFileInfo.szTypeName);
ImageIndex := SHFileInfo.iIcon;
end;
SubItems.Add(Date);
end;
end;
procedure
TMyFtp.Disconnect;
begin
FTP.Quit;
Application.ProcessMessages;
end;
procedure
TMyFtp.FormCreate(Sender: TObject);
var
SHFileInfo: TSHFileInfo;
begin
with DirTree do
begin
DirTree.Images := SmallImages;
SmallImages.ResourceLoad(rtBitmap, 'IMAGES', clOlive);
end;
with FileList do
begin
SmallImages := TImageList.CreateSize(16,16);
SmallImages.ShareImages := True;
SmallImages.Handle := ShGetFileInfo('*.*', 0, SHFileInfo,
SizeOf(SHFileInfo), SHGFI_SMALLICON or SHGFI_ICON or SHGFI_SYSICONINDEX);
LargeImages := TImageList.Create(nil);
LargeImages.ShareImages := True;
LargeImages.Handle := ShGetFileInfo('*.*', 0, SHFileInfo,
SizeOf(SHFileInfo), SHGFI_LARGEICON or SHGFI_ICON or SHGFI_SYSICONINDEX);
end;
end;
procedure
TMyFtp.FTPBusy(Sender: TObject; isBusy: Wordbool);
begin
if isBusy then
begin
Screen.Cursor := crHourGlass;
FileList.Items.BeginUpdate;
FileList.Items.Clear;
end
else
begin
Screen.Cursor := crDefault;
FileList.Items.EndUpdate;
end;
end;
function
TMyFtp.NodePath(Node: TTreeNode): String;
begin
if Node = Root then
Result := '.'
else
Result := NodePath(Node.Parent) + '/' + Node.Text;
end;
var
NP: String;
begin
if (FTP.State <> prcConnected) or FTP.Busy then exit;
if Node <> nil then
begin
NP := NodePath(DirTree.Selected);
FTP.List(NP);
Label2.Caption := Format('Contents of: ''%s/''',[NP]);
end;
end;
procedure
TMyFtp.RefreshBtnClick(Sender: TObject);
begin
FTP.List(NodePath(DirTree.Selected));
end;
procedure
TMyFtp.DirTreeChanging(Sender: TObject; Node: TTreeNode;
var AllowChange: Boolean);
begin
AllowChange := not FTP.Busy;
end;
procedure
TMyFtp.FTPStateChanged(Sender: TObject; State: Smallint);
begin
with FTP, Statusbar.Panels[0] do
case State of
prcConnecting : Text := 'Connecting';
prcResolvingHost: Text := 'Connecting';
prcHostResolved : Text := 'Host resolved';
prcConnected :
begin
Text := 'Connected to: ' + RemoteHost;
ConnectBtn.Hint := 'Disconnect';
FileNewItem.Enabled := True;
ViewLargeItem.Enabled := True;
ViewSmallItem.Enabled := True;
ViewListItem.Enabled := True;
ViewDetailsItem.Enabled := True;
ViewRefreshItem.Enabled := True;
ToolsDisconnectItem.Enabled := True;
LargeBtn.Enabled := True;
SmallBtn.Enabled := True;
ListBtn.Enabled := True;
DetailsBtn.Enabled := True;
RefreshBtn.Enabled := True;
end;
prcDisconnecting: Text := 'Disconnecting';
prcDisconnected :
begin
Text := 'Disconnected';
ConnectBtn.Hint := 'Connect';
DirTree.Items.Clear;
FileNewItem.Enabled := False;
ViewLargeItem.Enabled := False;
ViewSmallItem.Enabled := False;
ViewListItem.Enabled := False;
ViewDetailsItem.Enabled := False;
ViewRefreshItem.Enabled := False;
ToolsDisconnectItem.Enabled := False;
LargeBtn.Enabled := False;
SmallBtn.Enabled := False;
ListBtn.Enabled := False;
DetailsBtn.Enabled := False;
RefreshBtn.Enabled := False;
end;
end;
end;
procedure
TMyFtp.Open1Click(Sender: TObject);
begin
FTP.Quit;
DirTree.Items.BeginUpdate;
try
DirTree.Items.Clear;
finally
DirTree.Items.EndUpdate;
end;
end;
procedure
TMyFtp.FileExitItemClick(Sender: TObject);
begin
Close;
end;
procedure
TMyFtp.FormResize(Sender: TObject);
begin
Statusbar.Panels[0].Width := Width - 150;
end;
procedure
TMyFtp.ViewLargeItemClick(Sender: TObject);
begin
FileList.ViewStyle := vsIcon;
end;
procedure
TMyFtp.ViewSmallItemClick(Sender: TObject);
begin
FileList.ViewStyle := vsSmallIcon;
end;
procedure
TMyFtp.ViewListItemClick(Sender: TObject);
begin
FileList.ViewStyle := vsList;
end;
procedure
TMyFtp.ViewDetailsItemClick(Sender: TObject);
begin
FileList.ViewStyle := vsReport;
end;
procedure
TMyFtp.ViewRefreshItemClick(Sender: TObject);
begin
DirTreeChange(nil, DirTree.Selected);
end;
procedure
TMyFtp.CopyItemClick(Sender: TObject);
begin
SaveDialog1.FileName := FileList.Selected.Caption;
if SaveDialog1.Execute then
FTP.GetFile(NodePath(DirTree.Selected) + '/' + FileList.Selected.Caption,
SaveDialog1.FileName);
end;
procedure
TMyFtp.ToolsDisconnectItemClick(Sender: TObject);
begin
DisConnect;
end;
procedure
TMyFtp.FileNewItemClick(Sender: TObject);
var
DirName: String;
begin
if InputQuery('Input Box', 'Prompt', DirName) then
FTP.CreateDir(NodePath(DirTree.Selected) + '/' + DirName);
end;
procedure
TMyFtp.DeleteItemClick(Sender: TObject);
begin
if ActiveControl = DirTree then
FTP.DeleteDir(NodePath(DirTree.Selected));
if ActiveControl = FileList then
FTP.DeleteFile(NodePath(DirTree.Selected) + '/' + FileList.Selected.Caption);
end;
procedure
TMyFtp.PasteFromItemClick(Sender: TObject);
begin
if OpenDialog1.Execute then
FTP.PutFile(OpenDialog1.FileName, NodePath(DirTree.Selected));
end;
procedure
TMyFtp.FilePopupPopup(Sender: TObject);
begin
CopyItem.Enabled := (ActiveControl = FileList) and (FileList.Selected <>
nil);
PasteFromItem.Enabled := (ActiveControl = DirTree) and (DirTree.Selected
<> nil);
DeleteItem.Enabled := (ActiveControl = FileList) and (FileList.Selected
<> nil);
RenameItem.Enabled := (ActiveControl = FileList) and (FileList.Selected
<> nil);
end;
procedure
TMyFtp.FileMenuClick(Sender: TObject);
begin
FileCopyItem.Enabled := (ActiveControl = FileList) and (FileList.Selected
<> nil);
FileDeleteItem.Enabled := (ActiveControl = FileList) and (FileList.Selected
<> nil);
FileRenameItem.Enabled := (ActiveControl = FileList) and (FileList.Selected
<> nil);
end;
procedure
TMyFtp.FileDeleteItemClick(Sender: TObject);
begin
if (DirTree.Selected <> nil) and (FileList.Selected <> nil) then
FTP.DeleteFile(FileList.Selected.Caption);
end;
procedure
TMyFtp.FTPListItem(Sender: TObject; const Item: FTPDirItem);
var
Node: TTreeNode;
begin
CreateItem(Item.FileName, Item.Attributes, Item.Size, Item.Date);
if Item.Attributes = 1 then
if DirTree.Selected <> nil then
begin
if DirTree.Selected <> nil then
Node := DirTree.Selected.GetFirstChild
else
Node := nil;
while Node <> nil do
if AnsiCompareFileName(Node.Text, Item.FileName) = 0 then
exit
else
Node := DirTree.Selected.GetNextChild(Node);
if Node = nil then
begin
Node := DirTree.Items.AddChild(DirTree.Selected,
Item.FileName);
Node.ImageIndex := Folder;
Node.SelectedIndex := OpenFolder;
end;
end
else
DirTree.Items.AddChild(Root, Item.FileName);
end;
end.
файл nntp.pas
unit
nntp;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Menus, OleCtrls, StdCtrls, ComCtrls, ExtCtrls, Buttons, ActiveX, isp3;
const
efListGroups = 0;
efGetArticleHeaders = 1;
efGetArticleNumbers = 2;
efGetArticle = 3;
type
TNewsForm = class(TForm)
NNTP1: TNNTP;
MainMenu1: TMainMenu;
File1: TMenuItem;
Exit1: TMenuItem;
N1: TMenuItem;
FileDisconnectItem: TMenuItem;
FileConnectItem: TMenuItem;
Panel1: TPanel;
Bevel1: TBevel;
StatusBar: TStatusBar;
SmallImages: TImageList;
Panel2: TPanel;
NewsGroups: TTreeView;
Bevel2: TBevel;
Panel3: TPanel;
Memo1: TMemo;
Panel5: TPanel;
Panel4: TPanel;
ConnectBtn: TSpeedButton;
RefreshBtn: TSpeedButton;
Bevel3: TBevel;
MsgHeaders: TListBox;
Label1: TLabel;
Label2: TLabel;
procedure FileConnectItemClick(Sender: TObject);
procedure NNTP1ProtocolStateChanged(Sender: TObject;
ProtocolState: Smallint);
procedure NNTP1StateChanged(Sender: TObject; State: Smallint);
procedure Exit1Click(Sender: TObject);
procedure MsgHeadersDblClick(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure NewsGroupsChange(Sender: TObject; Node: TTreeNode);
procedure RefreshBtnClick(Sender: TObject);
procedure FileDisconnectItemClick(Sender: TObject);
procedure NNTP1Banner(Sender: TObject; const Banner: WideString);
procedure NNTP1DocOutput(Sender: TObject; const DocOutput: DocOutput);
procedure NNTP1Error(Sender: TObject; Number: Smallint;
var Description: WideString; Scode: Integer; const Source,
HelpFile: WideString; HelpContext: Integer;
var CancelDisplay: WordBool);
procedure NNTP1SelectGroup(Sender: TObject;
const groupName: WideString; firstMessage, lastMessage,
msgCount: Integer);
private
EventFlag: Integer;
function NodePath(Node: TTreeNode): String;
public
Data: String;
end;
var
NewsForm: TNewsForm;
Remainder: String;
Nodes: TStringList;
CurrentGroup: String;
GroupCount: Integer;
implementation
uses
Connect;
{$R
*.DFM}
{
TParser }
type
TToken = (etEnd, etSymbol, etName, etLiteral);
TParser = class
private
FFlags: Integer;
FText: string;
FSourcePtr: PChar;
FSourceLine: Integer;
FTokenPtr: PChar;
FTokenString: string;
FToken: TToken;
procedure SkipBlanks;
procedure NextToken;
public
constructor Create(const Text: string; Groups: Boolean);
end;
const
sfAllowSpaces = 1;
constructor
TParser.Create(const Text: string; Groups: Boolean);
begin
FText := Text;
FSourceLine := 1;
FSourcePtr := PChar(Text);
if Groups then
FFlags := sfAllowSpaces
else
FFlags := 0;
NextToken;
end;
procedure
TParser.SkipBlanks;
begin
while True do
begin
case FSourcePtr^ of
#0:
begin
if FSourcePtr^ = #0 then Exit;
Continue;
end;
#10:
Inc(FSourceLine);
#33..#255:
Exit;
end;
Inc(FSourcePtr);
end;
end;
procedure
TParser.NextToken;
var
P, TokenStart: PChar;
begin
SkipBlanks;
FTokenString := '';
P := FSourcePtr;
while (P^ <> #0) and (P^ <= ' ') do Inc(P);
FTokenPtr := P;
case P^ of
'0'..'9':
begin
Inc(P);
while P^ in ['0'..'9'] do Inc(P);
SetString(FTokenString, TokenStart, P - TokenStart);
FToken := etLiteral;
end;
#13: Inc(FSourceLine);
#0:
FToken := etEnd;
else
begin
TokenStart := P;
Inc(P);
if FFlags = sfAllowSpaces then
while not (P^ in [#0, #13, ' ']) do Inc(P)
else
while not (P^ in [#0, #13]) do Inc(P);
SetString(FTokenString, TokenStart, P - TokenStart);
FToken := etSymbol;
end;
end;
FSourcePtr := P;
end;
function
FirstItem(var ItemList: ShortString): ShortString;
var
P: Integer;
begin
P := AnsiPos('.', ItemList);
if P = 0 then
begin
Result := ItemList;
P := Length(ItemList);
end
else
Result := Copy(ItemList, 1, P - 1);
Delete(ItemList, 1, P);
end;
procedure
AddItem(GroupName: ShortString);
var
Index, i: Integer;
Groups: Integer;
Item: ShortString;
TheNodes: TStringList;
begin
Groups := 1;
for i := 0 to Length(GroupName) do
if GroupName[i] = '.' then
Inc(Groups);
TheNodes := Nodes;
for i := 0 to Groups - 1 do
begin
Item := FirstItem(GroupName);
Index := TheNodes.IndexOf(Item);
if Index = -1 then
begin
Index := TheNodes.AddObject(Item, TStringList.Create);
TheNodes := TStringList(TheNodes.Objects[Index]);
TheNodes.Sorted := True;
end
else
TheNodes := TStringList(TheNodes.Objects[Index]);
end;
Inc(GroupCount);
end;
procedure
ParseGroups(Data: String);
var
Parser: TParser;
OldSrcLine: Integer;
begin
Parser := TParser.Create(Data, True);
OldSrcLine := 0;
while Parser.FToken <> etEnd do
begin
if Parser.FSourceLine <> OldSrcLine then
begin
AddItem(Parser.FTokenString);
OldSrcLine := Parser.FSourceLine;
end;
Parser.NextToken;
end;
end;
procedure
ParseHeaders(Data: String);
var
Parser: TParser;
MsgNo: LongInt;
Header: String;
OldSrcLine: Integer;
begin
Parser := TParser.Create(Data, False);
while Parser.FToken <> etEnd do
begin
MsgNo := StrToInt(Parser.FTokenString);
OldSrcLine := Parser.FSourceLine;
Parser.NextToken;
Header := '';
while (OldSrcLine = Parser.FSourceLine) do
begin
Header := Header + ' ' + Parser.FTokenString;
Parser.NextToken;
if Parser.FToken = etEnd then
Break;
end;
NewsForm.MsgHeaders.Items.AddObject(Header, Pointer(MsgNo));
end;
end;
procedure
DestroyList(AList: TStringList);
var
i: Integer;
begin
for i := 0 to AList.Count - 1 do
if AList.Objects[i] <> nil then
DestroyList(TStringList(AList.Objects[i]));
AList.Free;
end;
procedure
BuildTree(Parent: TTreeNode; List: TStrings);
var
i: Integer;
Node: TTreeNode;
begin
for i := 0 to List.Count - 1 do
if List.Objects[i] <> nil then
begin
Node := NewsForm.NewsGroups.Items.AddChild(Parent, List[i]);
Node.ImageIndex := 0;
Node.SelectedIndex := 1;
BuildTree(Node, TStrings(List.Objects[i]));
end
else
NewsForm.NewsGroups.Items.AddChild(Parent, List[i]);
end;
function
TNewsForm.NodePath(Node: TTreeNode): String;
begin
if Node.Parent = nil then
Result := Node.Text
else
Result := NodePath(Node.Parent) + '.' + Node.Text;
end;
procedure
TNewsForm.FileConnectItemClick(Sender: TObject);
begin
ConnectDlg := TConnectDlg.Create(Self);
try
if ConnectDlg.ShowModal = mrOk then
with NNTP1 do
Connect(ConnectDlg.ServerEdit.Text, RemotePort);
finally
ConnectDlg.Free;
end;
end;
procedure
TNewsForm.NNTP1ProtocolStateChanged(Sender: TObject;
ProtocolState: Smallint);
begin
case ProtocolState of
nntpBase: ;
nntpTransaction:
begin
EventFlag := efListGroups;
Nodes := TStringList.Create;
Nodes.Sorted := True;
NNTP1.ListGroups;
end;
end;
end;
procedure
TNewsForm.NNTP1StateChanged(Sender: TObject; State: Smallint);
begin
with Memo1.Lines do
case NNTP1.State of
prcConnecting : Add('Connecting');
prcResolvingHost: Add('Resolving Host: ' + NNTP1.RemoteHost);
prcHostResolved : Add('Host resolved');
prcConnected :
begin
Add('Connected to: ' + NNTP1.RemoteHost);
Statusbar.Panels[0].Text := 'Connected to: ' + NNTP1.RemoteHost;
ConnectBtn.Enabled := False;
FileConnectItem.Enabled := False;
RefreshBtn.Enabled := True;
end;
prcDisconnecting: Text := NNTP1.ReplyString;
prcDisconnected :
begin
Statusbar.Panels[0].Text := 'Disconnected';
Caption := 'News Reader';
Label1.Caption := '';
ConnectBtn.Enabled := True;
FileConnectItem.Enabled := True;
RefreshBtn.Enabled := False;
end;
end;
end;
procedure
TNewsForm.Exit1Click(Sender: TObject);
begin
if NNTP1.State <> prcDisconnected then
begin
if NNTP1.Busy then NNTP1.Cancel;
NNTP1.Quit;
while NNTP1.State <> prcDisconnected do
Application.ProcessMessages;
end;
Close;
end;
procedure
TNewsForm.MsgHeadersDblClick(Sender: TObject);
var
Article: Integer;
begin
if NNTP1.Busy then exit;
EventFlag := efGetArticle;
Memo1.Clear;
if MsgHeaders.ItemIndex = -1 then exit;
Caption := 'News Reader: ' + MsgHeaders.Items[MsgHeaders.ItemIndex];
Article := Integer(MsgHeaders.Items.Objects[MsgHeaders.ItemIndex]);
NNTP1.GetArticlebyArticleNumber(Article);
end;
procedure
TNewsForm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
if NNTP1.State <> prcDisconnected then
begin
if NNTP1.Busy then NNTP1.Cancel;
NNTP1.Quit;
while NNTP1.State <> prcDisconnected do
Application.ProcessMessages;
end;
end;
procedure
TNewsForm.NewsGroupsChange(Sender: TObject; Node: TTreeNode);
var
NP: String;
begin
if (NNTP1.State = prcConnected) and not NNTP1.Busy then
with MsgHeaders do
begin
Items.BeginUpdate;
try
Items.Clear;
Memo1.Lines.Clear;
NP := NodePath(NewsGroups.Selected);
Statusbar.Panels[2].Text := 'Bytes: 0';
Statusbar.Panels[1].Text := '0 Article(s)';
if NNTP1.Busy then
NNTP1.Cancel;
NNTP1.SelectGroup(NP);
Label1.Caption := 'Contents of ''' + NP + '''';
finally
Items.EndUpdate;
end;
end;
end;
procedure
TNewsForm.RefreshBtnClick(Sender: TObject);
begin
if NewsGroups.Selected <> nil then
NewsGroupsChange(nil, NewsGroups.Selected);
end;
procedure
TNewsForm.FileDisconnectItemClick(Sender: TObject);
begin
if NNTP1.Busy then NNTP1.Cancel;
NNTP1.Quit;
while NNTP1.Busy do
Application.ProcessMessages;
with NewsGroups.Items do
begin
BeginUpdate;
Clear;
EndUpdate;
end;
MsgHeaders.Items.Clear;
Memo1.Lines.Clear;
end;
procedure
TNewsForm.NNTP1Banner(Sender: TObject; const Banner: WideString);
begin
Memo1.Lines.Add(Banner);
end;
procedure
TNewsForm.NNTP1DocOutput(Sender: TObject;
const DocOutput: DocOutput);
begin
Statusbar.Panels[2].Text := Format('Bytes: %d',[DocOutput.BytesTransferred]);
case DocOutput.State of
icDocBegin:
begin
if EventFlag = efListGroups then
Memo1.Lines.Add('Retrieving news groups...');
Data := '';
GroupCount := 0;
end;
icDocData:
begin
Data := Data + DocOutput.DataString;
if EventFlag = efGetArticle then
Memo1.Lines.Add(Data);
end;
icDocEnd:
begin
case EventFlag of
efListGroups:
begin
ParseGroups(Data);
Memo1.Lines.Add('Done.'#13#10'Building news group tree...');
NewsGroups.Items.BeginUpdate;
try
BuildTree(nil, Nodes);
DestroyList(Nodes);
Statusbar.Panels[1].Text := Format('%d Groups',[GroupCount]);
finally
NewsGroups.Items.EndUpdate;
Memo1.Lines.Add('Done.');
end;
end;
efGetArticleHeaders: ParseHeaders(Data);
efGetArticle:
begin
Memo1.SelStart := 0;
SendMessage(Memo1.Handle, EM_ScrollCaret, 0, 0);
end;
end;
SetLength(Data, 0);
end;
end;
Refresh;
end;
procedure
TNewsForm.NNTP1Error(Sender: TObject; Number: Smallint;
var Description: WideString; Scode: Integer; const Source,
HelpFile: WideString; HelpContext: Integer; var CancelDisplay: WordBool);
begin
//
MessageDlg(Description, mtError, [mbOk], 0);
end;
procedure
TNewsForm.NNTP1SelectGroup(Sender: TObject;
const groupName: WideString; firstMessage, lastMessage,
msgCount: Integer);
begin
EventFlag := efGetArticleHeaders;
Statusbar.Panels[1].Text := Format('%d Article(s)',[msgCount]);
NNTP1.GetArticleHeaders('subject', FirstMessage, lastMessage);
end;
файл smtp.pas
unit
Smtp;
interface
uses
Windows, SysUtils, Classes, Graphics, Forms, Controls, Menus,
StdCtrls, Dialogs, Buttons, Messages, ExtCtrls, ComCtrls, OleCtrls,
ISP3;
type
TMail = class(TForm)
OpenDialog: TOpenDialog;
SMTP1: TSMTP;
POP1: TPOP;
PageControl1: TPageControl;
SendPage: TTabSheet;
RecvPage: TTabSheet;
ConPage: TTabSheet;
Panel1: TPanel;
Label1: TLabel;
Label3: TLabel;
Label2: TLabel;
eTo: TEdit;
eCC: TEdit;
eSubject: TEdit;
SendBtn: TButton;
ClearBtn: TButton;
reMessageText: TRichEdit;
SMTPStatus: TStatusBar;
Panel3: TPanel;
mReadMessage: TMemo;
POPStatus: TStatusBar;
cbSendFile: TCheckBox;
GroupBox1: TGroupBox;
ePOPServer: TEdit;
Label6: TLabel;
Label5: TLabel;
eUserName: TEdit;
ePassword: TEdit;
Label4: TLabel;
GroupBox2: TGroupBox;
Label7: TLabel;
eSMTPServer: TEdit;
SMTPConnectBtn: TButton;
POPConnectBtn: TButton;
eHomeAddr: TEdit;
Label8: TLabel;
Panel2: TPanel;
Label9: TLabel;
lMessageCount: TLabel;
Label10: TLabel;
eCurMessage: TEdit;
udCurMessage: TUpDown;
ConnectStatus: TStatusBar;
procedure FormCreate(Sender: TObject);
procedure POP1StateChanged(Sender: TObject; State: Smallint);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure SMTP1StateChanged(Sender: TObject; State: Smallint);
procedure FormResize(Sender: TObject);
procedure ClearBtnClick(Sender: TObject);
procedure SMTP1Verify(Sender: TObject);
procedure SendBtnClick(Sender: TObject);
procedure POP1ProtocolStateChanged(Sender: TObject;
ProtocolState: Smallint);
procedure SMTPConnectBtnClick(Sender: TObject);
procedure POPConnectBtnClick(Sender: TObject);
procedure eSMTPServerChange(Sender: TObject);
procedure ePOPServerChange(Sender: TObject);
procedure cbSendFileClick(Sender: TObject);
procedure udCurMessageClick(Sender: TObject; Button: TUDBtnType);
procedure POP1RefreshMessageCount(Sender: TObject; Number: Integer);
procedure POP1DocOutput(Sender: TObject; const DocOutput: DocOutput);
procedure POP1Error(Sender: TObject; Number: Smallint;
var Description: WideString; Scode: Integer; const Source,
HelpFile: WideString; HelpContext: Integer;
var CancelDisplay: WordBool);
procedure SMTP1DocInput(Sender: TObject; const DocInput: DocInput);
procedure SMTP1Error(Sender: TObject; Number: Smallint;
var Description: WideString; Scode: Integer; const Source,
HelpFile: WideString; HelpContext: Integer;
var CancelDisplay: WordBool);
private
RecvVerified,
SMTPError,
POPError: Boolean;
FMessageCount: Integer;
procedure SendFile(Filename: string);
procedure SendMessage;
procedure CreateHeaders;
end;
var
Mail: TMail;
implementation
{$R
*.DFM}
const
icDocBegin = 1;
icDocHeaders = 2;
icDocData = 3;
icDocEnd = 5;
{When
calling a component method which maps onto an OLE call, NoParam substitutes
for
an optional parameter. As an alternative to calling the component method, you
may
access the component's OLEObject directly -
i.e.,
Component.OLEObject.MethodName(,Foo,,Bar)}
function
NoParam: Variant;
begin
TVarData(Result).VType := varError;
TVarData(Result).VError := DISP_E_PARAMNOTFOUND;
end;
procedure
TMail.FormCreate(Sender: TObject);
begin
SMTPError := False;
POPError := False;
FMessageCount := 0;
end;
procedure
TMail.FormClose(Sender: TObject; var Action: TCloseAction);
begin
if POP1.State = prcConnected then POP1.Quit;
if SMTP1.State = prcConnected then SMTP1.Quit;
end;
procedure
TMail.FormResize(Sender: TObject);
begin
SendBtn.Left := ClientWidth - SendBtn.Width - 10;
ClearBtn.Left := ClientWidth - ClearBtn.Width - 10;
cbSendFile.Left := ClientWidth - cbSendFile.Width - 10;
eTo.Width := SendBtn.Left - eTo.Left - 10;
eCC.Width := SendBtn.Left - eCC.Left - 10;
eSubject.Width := SendBtn.Left - eSubject.Left - 10;
end;
procedure
TMail.ClearBtnClick(Sender: TObject);
begin
eTo.Text := '';
eCC.Text := '';
eSubject.Text := '';
OpenDialog.Filename := '';
reMessageText.Lines.Clear;
end;
procedure
TMail.eSMTPServerChange(Sender: TObject);
begin
SMTPConnectBtn.Enabled := (eSMTPServer.Text <> '') and (eHomeAddr.Text
<> '');
end;
procedure
TMail.ePOPServerChange(Sender: TObject);
begin
POPConnectBtn.Enabled := (ePOPServer.Text <> '') and (eUsername.Text
<> '')
and (ePassword.Text <> '');
end;
procedure
TMail.cbSendFileClick(Sender: TObject);
begin
if cbSendFile.Checked then
begin
if OpenDialog.Execute then
cbSendFile.Caption := cbSendFile.Caption + ': '+OpenDialog.Filename
else
cbSendFile.Checked := False;
end else
cbSendFile.Caption := '&Attach Text File';
end;
{Clear
and repopulate MIME headers, using the component's DocInput property. A
separate
DocInput OLE object could also be used. See RFC1521/1522 for complete
information
on MIME types.}
procedure
TMail.CreateHeaders;
begin
with SMTP1 do
begin
DocInput.Headers.Clear;
DocInput.Headers.Add('To', eTo.Text);
DocInput.Headers.Add('From', eHomeAddr.Text);
DocInput.Headers.Add('CC', eCC.Text);
DocInput.Headers.Add('Subject', eSubject.Text);
DocInput.Headers.Add('Message-Id', Format('%s_%s_%s', [Application.Title,
DateTimeToStr(Now), eHomeAddr.Text]));
DocInput.Headers.Add('Content-Type', 'TEXT/PLAIN charset=US-ASCII');
end;
end;
{Send
a simple mail message}
procedure
TMail.SendMessage;
begin
CreateHeaders;
with SMTP1 do
SendDoc(NoParam, DocInput.Headers, reMessageText.Text, '', '');
end;
{Send
a disk file. Leave SendDoc's InputData parameter blank and
specify
a filename for InputFile to send the contents of a disk file. You can
use
the DocInput event and GetData methods to do custom encoding (Base64, UUEncode,
etc.) }
procedure
TMail.SendFile(Filename: string);
begin
CreateHeaders;
with SMTP1 do
begin
DocInput.Filename := FileName;
SendDoc(NoParam, DocInput.Headers, NoParam, DocInput.FileName, '');
end;
end;
{Set
global flag indicating recipients are addressable (this only ensures that the
address
is in the correct format, not that it exists and is deliverable), then
send
the text part of the message}
procedure
TMail.SMTP1Verify(Sender: TObject);
begin
SendMessage;
RecvVerified := True;
end;
{Verify
addressees, send text message in the Verify event, and if an attachment is
specified,
send it}
procedure
TMail.SendBtnClick(Sender: TObject);
var
Addressees: string;
begin
if SMTP1.State = prcConnected then
begin
RecvVerified := False;
SMTPError := False;
Addressees := eTo.Text;
if eCC.Text <> '' then
Addressees := Addressees + ', '+ eCC.Text;
SMTP1.Verify(Addressees);
{wait for completion of Verify-Text message send}
while SMTP1.Busy do
Application.ProcessMessages;
{Check global flag indicating addresses are in the correct format - if true,
the text part of the message has been sent}
if not RecvVerified then
begin
MessageDlg('Incorrect address format', mtError, [mbOK], 0);
Exit;
end
else
if cbSendFile.Checked then
SendFile(OpenDialog.Filename);
end
else
MessageDlg('Not connected to SMTP server', mtError, [mbOK], 0);
end;
{SMTP
component will call this event every time its connection state changes}
procedure
TMail.SMTP1StateChanged(Sender: TObject; State: Smallint);
begin
case State of
prcConnecting:
ConnectStatus.SimpleText := 'Connecting to SMTP server:
'+SMTP1.RemoteHost+'...';
prcResolvingHost:
ConnectStatus.SimpleText := 'Resolving Host';
prcHostResolved:
ConnectStatus.SimpleText := 'Host Resolved';
prcConnected:
begin
ConnectStatus.SimpleText := 'Connected to SMTP server: '+SMTP1.RemoteHost;
SMTPConnectBtn.Caption := 'Disconnect';
end;
prcDisconnecting:
ConnectStatus.SimpleText := 'Disconnecting from SMTP server:
'+SMTP1.RemoteHost+'...';
prcDisconnected:
begin
ConnectStatus.SimpleText := 'Disconnected from SMTP server: '+SMTP1.RemoteHost;
SMTPConnectBtn.Caption := 'Connect';
end;
end;
eSMTPServer.Enabled := not (State = prcConnected);
eHomeAddr.Enabled := not (State = prcConnected);
end;
{The
DocInput event is called each time the DocInput state changes during a mail transfer.
DocInput
holds all the information about the current transfer, including the headers,
the
number
of bytes transferred, and the message data itself. Although not shown in this
example,
you
may call DocInput's SetData method if DocInput.State = icDocData to encode the
data before
each
block is sent.}
procedure
TMail.SMTP1DocInput(Sender: TObject;
const DocInput: DocInput);
begin
case DocInput.State of
icDocBegin:
SMTPStatus.SimpleText := 'Initiating document transfer';
icDocHeaders:
SMTPStatus.SimpleText := 'Sending headers';
icDocData:
if DocInput.BytesTotal > 0 then
SMTPStatus.SimpleText := Format('Sending data: %d of %d bytes (%d%%)',
[Trunc(DocInput.BytesTransferred), Trunc(DocInput.BytesTotal),
Trunc(DocInput.BytesTransferred/DocInput.BytesTotal*100)])
else
SMTPStatus.SimpleText := 'Sending...';
icDocEnd:
if SMTPError then
SMTPStatus.SimpleText := 'Transfer aborted'
else
SMTPStatus.SimpleText := Format('Mail sent to %s (%d bytes data)', [eTo.Text,
Trunc(DocInput.BytesTransferred)]);
end;
SMTPStatus.Update;
end;
{The
Error event is called whenever an error occurs in the background processing. In
addition
to providing an error code and brief description, you can also access the SMTP
component's
Errors property (of type icErrors, an OLE object) to get more detailed
information}
procedure
TMail.SMTP1Error(Sender: TObject; Number: Smallint;
var Description: WideString; Scode: Integer; const Source,
HelpFile: WideString; HelpContext: Integer; var CancelDisplay: WordBool);
var
I: Integer;
ErrorStr: string;
begin
SMTPError := True;
CancelDisplay := True;
{Get extended error information}
for I := 1 to SMTP1.Errors.Count do
ErrorStr := Format(#13'(%s)', [SMTP1.Errors.Item(I).Description]);
{Display error code, short and long error description}
MessageDlg(Format('%d - %s%s', [Number, Description, Trim(ErrorStr)]), mtError,
[mbOK], 0);
end;
{Unlike
POP, SMTP does not require a user account on the host machine, so no user
authorization
is necessary}
procedure
TMail.SMTPConnectBtnClick(Sender: TObject);
begin
if SMTP1.State = prcConnected then
SMTP1.Quit
else
if SMTP1.State = prcDisconnected then
begin
SMTP1.RemoteHost := eSMTPServer.Text;
SMTPError := False;
SMTP1.Connect(NoParam, NoParam);
end;
end;
{Unlike
SMTP, users must be authorized on the POP server. The component defines
a
special protocol state, popAuthorization, when it requests authorization. If
POP
commands can be issued. Note that server connection is independent of the
authorization
state.}
procedure
TMail.POP1ProtocolStateChanged(Sender: TObject;
ProtocolState: Smallint);
begin
case ProtocolState of
popAuthorization:
POP1.Authenticate(POP1.UserID, POP1.Password);
popTransaction:
ConnectStatus.SimpleText := Format('User %s authorized on server %s',
[eUsername.Text,
ePOPServer.Text]);
end;
end;
{This
event is called every time the connection status of the POP server changes}
procedure
TMail.POP1StateChanged(Sender: TObject; State: Smallint);
begin
case State of
prcConnecting:
ConnectStatus.SimpleText := 'Connecting to POP server: '+POP1.RemoteHost+'...';
prcResolvingHost:
ConnectStatus.SimpleText := 'Resolving Host';
prcHostResolved:
ConnectStatus.SimpleText := 'Host Resolved';
prcConnected:
begin
ConnectStatus.SimpleText := 'Connected to POP server: '+POP1.RemoteHost;
POPConnectBtn.Caption := 'Disconnect';
end;
prcDisconnecting:
ConnectStatus.SimpleText := 'Disconnecting from POP server:
'+POP1.RemoteHost+'...';
prcDisconnected:
begin
ConnectStatus.SimpleText := 'Disconnected from POP server: '+POP1.RemoteHost;
POPConnectBtn.Caption := 'Connect';
end;
end;
ePOPServer.Enabled := not (State = prcConnected);
eUsername.Enabled := not (State = prcConnected);
ePassword.Enabled := not (State = prcConnected);
end;
{The
Error event is called whenever an error occurs in the background processing. In
addition
to providing an error code and brief description, you can also access the POP
component's
Errors property (of type icErrors, an OLE object) to get more detailed
information}
procedure
TMail.POP1Error(Sender: TObject; Number: Smallint;
var Description: WideString; Scode: Integer; const Source,
HelpFile: WideString; HelpContext: Integer; var CancelDisplay: WordBool);
var
I: Integer;
ErrorStr: string;
begin
POPError := True;
CancelDisplay := True;
if POP1.ProtocolState = popAuthorization then
ConnectStatus.SimpleText := 'Authorization error';
{Get extended error information}
for I := 1 to POP1.Errors.Count do
ErrorStr := Format(#13'(%s)', [POP1.Errors.Item(I).Description]);
{Display error code, short and long error description}
MessageDlg(Format('%d - %s%s', [Number, Description, Trim(ErrorStr)]), mtError,
[mbOK], 0);
end;
{POP
requires a valid user account on the host machine}
procedure
TMail.POPConnectBtnClick(Sender: TObject);
begin
if (POP1.State = prcConnected) and (POP1.ProtocolState = popTransaction)
and not POP1.Busy then
begin
mReadMessage.Lines.Clear;
POP1.Quit;
end
else
if POP1.State = prcDisconnected then
begin
POP1.RemoteHost := ePOPServer.Text;
POP1.UserID := eUserName.Text;
POP1.Password := ePassword.Text;
POP1.Connect(NoParam, NoParam);
end;
end;
{The
DocOutput event is the just like the DocInput event in 'reverse'. It is called
each time
the
component's DocOutput state changes during retrieval of mail from the server.
When the
state
= icDocData, you can call DocOutput.GetData to decode each data block based on
the MIME
content
type specified in the headers.}
procedure
TMail.POP1DocOutput(Sender: TObject; const DocOutput: DocOutput);
var
Buffer: WideString;
I: Integer;
begin
case DocOutput.State of
icDocBegin:
POPStatus.SimpleText := 'Initiating document transfer';
icDocHeaders:
begin
POPStatus.SimpleText := 'Retrieving headers';
for I := 1 to DocOutput.Headers.Count do
mReadMessage.Lines.Add(DocOutput.Headers.Item(I).Name+': '+
DocOutput.Headers.Item(I).Value);
end;
icDocData:
begin
POPStatus.SimpleText := Format('Retrieving data - %d bytes',
[Trunc(DocOutput.BytesTransferred)]);
Buffer := DocOutput.DataString;
mReadMessage.Text := mReadMessage.Text + Buffer;
end;
icDocEnd:
if POPError then
POPStatus.SimpleText := 'Transfer aborted'
else
POPStatus.SimpleText := Format('Retrieval complete (%d bytes data)',
[Trunc(DocOutput.BytesTransferred)]);
end;
POPStatus.Update;
end;
{Retrieve
message from the server}
procedure
TMail.udCurMessageClick(Sender: TObject; Button: TUDBtnType);
begin
if (POP1.State = prcConnected) and (POP1.ProtocolState = popTransaction) then
begin
POPError := False;
mReadMessage.Lines.Clear;
POP1.RetrieveMessage(udCurMessage.Position);
end;
end;
{The
RefreshMessageCount event is called whenever the RefreshMessageCount method is
called,
and also when a connection to the POP server is first made}
procedure
TMail.POP1RefreshMessageCount(Sender: TObject;
Number: Integer);
begin
FMessageCount := Number;
udCurMessage.Max := Number;
udCurMessage.Enabled := Number <> 0;
lMessageCount.Caption := IntToStr(Number);
if Number > 0 then
begin
udCurMessage.Min := 1;
udCurMessage.Position := 1;
POP1.RetrieveMessage(udCurMessage.Position);
end;
end;
end.
файл webbrows.dpr
program
Webbrows;
uses
Forms,
main in 'Main.pas' {MainForm},
SMTP in 'Smtp.pas', {Mail}
FTP in 'ftp.pas', {MyFtp}
NNTP in 'nntp.pas', {NewsForm}
CHAT in 'chat.pas'; {ChatForm}
{$R
*.RES}
begin
Application.Initialize;
Application.CreateForm(TMainForm, MainForm);
Application.CreateForm(TDocSourceFrm, DocSourceFrm);
Application.run;
end.
Приложение
1. Исходный текст модели корпоративной сети
uses
crt,dos,graph;
CONST
VertexQuantity=7;
DelayInDomain=1000;
DelaySendToRouter=1000;
DelayRouterReceive=1000;
AdjacencyMatrix
: array[1..VertexQuantity,1..VertexQuantity] of byte =(
(0,1,0,1,0,0,0),
(1,0,1,0,1,0,1),
(0,1,0,1,0,0,0),
(1,0,1,0,1,0,0),
(0,1,0,1,0,1,0),
(0,0,0,0,1,0,1),
(0,1,0,0,0,1,0)
);
TYPE
TAddr = record {address format}
router:byte;
domain:byte;
comp
:byte;
END;
TYPE
TBatch = record {batch format}
from:TAddr;
to_
:TAddr;
data:string;
path:array[1..20]
of byte; {path is chain of router numbers}
END;
TYPE
TComp = object {terminal}
addr:TAddr; {adress}
mem :TBatch; {memory}
Procedure
Send2Router(batch:TBatch);{send batch}
Procedure
Send(batch:TBatch);{send batch into domain}
Procedure
Receive(batch:TBatch;byRouter:boolean); {receive batch}
END;
TYPE
TRouter = object
num :byte;
x,y :integer;
memory :Tbatch;
state :boolean; {active or inactive}
Procedure
Receive(routerNum:byte;batch:TBatch);
Procedure
Send2Comp(batch:TBatch);
Procedure
CalcMinPath(sender,target:byte);
Procedure
Send2NextRouter(batch:TBatch;currentRouter:byte);
END;
VAR
computers : array[1..38] of TComp; {all computers in the global net}
routers : array[1..7] of TRouter;{all routers in the global net}
OptimalPath : array[1..49] of byte;{1--> [1,2,3,4,5]}
OptPathPtr : byte;
type
TMark = record
delta
: integer;
prevPtr
: byte;
end;
type
vertex = record
mark
: TMark;
marked
: boolean;
end;
AdjacencyRec
= record
link
:byte;
weight:integer;
end;
VAR
AMatr : array[1..7,1..7] of AdjacencyRec;
vertexArr : array [1..7] of vertex;
PROCEDURE
HiddenCursor;assembler;
asm
mov
ah,01
mov
ch,20
mov
cl,18
int
10h
end;
PROCEDURE
NormalCursor;assembler;
asm
mov
ah,01
mov
ch,9
mov
cl,10
int
10h
end;
Procedure
Push(num:byte);
Begin
OptimalPath[OptPathPtr+1]:=num;inc(OptPathPtr);
End;
Procedure
Pop;
Begin
OptimalPath[OptPathPtr]:=0;dec(OptPathPtr);
End;
Procedure
ShowGraphics(second:boolean);
Var
grDr,grMode:integer;
i :integer;
Begin
grDr:=vga;grMode:=2;
InitGraph(grDr,grMode,'d:\lang\tp\bgi');
SetTextStyle(DefaultFont,HorizDir,2);SetColor(lightRed);
OutTextXY(10,20,'Arrangement scheme of routers');
SetColor(white);Rectangle(5,15,480,40);
Rectangle(5,48,480,70);SetTextStyle(DefaultFont,HorizDir,1);setcolor(lightgreen);
OutTextXY(10,55,'Main address : Router.Domain.Computer (for ex., 4.2.4)');
setcolor(white);setFillStyle(7,lightblue);floodfill(5,5,white);
setlinestyle(0,0,3);
rectangle(0,0,getmaxX-20,getmaxY-20);
setFillStyle(9,lightgray);
floodfill(getmaxX,getmaxY,white);
setlinestyle(0,0,NormWidth);
SetFillStyle(1,red);
{-------------------router circles-----------------------}
Circle(routers[1].x,routers[1].y,10);FloodFill(routers[1].x,routers[1].y,white);
Circle(routers[2].x,routers[2].y,10);FloodFill(routers[2].x,routers[2].y,white);
Circle(routers[3].x,routers[3].y,10);FloodFill(routers[3].x,routers[3].y,white);
Circle(routers[4].x,routers[4].y,10);FloodFill(routers[4].x,routers[4].y,white);
Circle(routers[5].x,routers[5].y,10);FloodFill(routers[5].x,routers[5].y,white);
Circle(routers[6].x,routers[6].y,10);FloodFill(routers[6].x,routers[6].y,white);
Circle(routers[7].x,routers[7].y,10);FloodFill(routers[7].x,routers[7].y,white);
SetFillStyle(1,yellow);
SetColor(red);{-------------------router lines-------------------------}
Line(routers[1].x,routers[1].y-10,routers[2].x-2,routers[2].y+10);
Line(routers[1].x,routers[1].y+10,routers[4].x-10,routers[4].y-6);
Line(routers[3].x,routers[3].y-10,routers[2].x+2,routers[2].y+10);
Line(routers[3].x,routers[3].y+10,routers[4].x,routers[4].y-10);
Line(routers[2].x+4,routers[2].y+10,routers[5].x-2,routers[5].y-10);
Line(routers[2].x+10,routers[2].y,routers[7].x-10,routers[7].y);
Line(routers[5].x+2,routers[5].y-10,routers[6].x,routers[6].y+10);
Line(routers[6].x,routers[6].y-10,routers[7].x,routers[7].y+10);
Line(routers[4].x+10,routers[4].y,routers[5].x-10,routers[5].y);
{domains}
{-------------domain 1.1----------------------------------}
SetTextStyle(DefaultFont,HorizDir,1);SetColor(white);
Rectangle(routers[1].x-50,routers[1].y-50,routers[1].x-30,routers[1].y-20 );
FloodFill(routers[1].x-48,routers[1].y-48,white);
Circle(20,routers[1].y-30,8);FloodFill(20,routers[1].y-30,white);
Circle(40,routers[1].y-30,8);FloodFill(40,routers[1].y-30,white);
Circle(60,routers[1].y-30,8);FloodFill(60,routers[1].y-30,white);
SetColor(white);
Line(routers[1].x-5,routers[1].y-10,routers[1].x-20,routers[1].y-30);
Line(routers[1].x-20,routers[1].y-30,routers[1].x-110,routers[1].y-30);
{-------------domain 1.2----------------------------------}
Rectangle(routers[1].x-30,routers[1].y+80,routers[1].x-5,routers[1].y+92);
FloodFill(routers[1].x-28,routers[1].y+82,white);
Line(routers[1].x-2,routers[1].y+10,routers[1].x-20,routers[1].y+80);
Circle(routers[1].x-48,routers[1].y+62,9);
FloodFill(routers[1].x-48,routers[1].y+62,white);
Line(routers[1].x-28,routers[1].y+82,routers[1].x-52,routers[1].y+62);
Circle(routers[1].x+10,routers[1].y+62,8);
FloodFill(routers[1].x+10,routers[1].y+62,white);
Circle(routers[1].x-48,routers[1].y+92,8);
FloodFill(routers[1].x-48,routers[1].y+92,white);
Line(routers[1].x-28,routers[1].y+90,routers[1].x-48,routers[1].y+92);
Circle(routers[1].x-43,routers[1].y+115,8);
FloodFill(routers[1].x-43,routers[1].y+115,white);
Line(routers[1].x-23,routers[1].y+90,routers[1].x-48,routers[1].y+115);
Circle(routers[1].x-18,routers[1].y+115,8);
FloodFill(routers[1].x-18,routers[1].y+115,white);
Line(routers[1].x-18,routers[1].y+90,routers[1].x-18,routers[1].y+115);
Circle(routers[1].x+13,routers[1].y+113,8);
FloodFill(routers[1].x+13,routers[1].y+113,white);
Line(routers[1].x-5,routers[1].y+92,routers[1].x+13,routers[1].y+113);
{-------------domain 2.1----------------------------------}
Rectangle(routers[2].x-25,routers[2].y+70,routers[2].x+16,routers[2].y+79);
FloodFill(routers[2].x-24,routers[2].y+72,white);
Line(routers[2].x,routers[2].y+10,routers[2].x-5,routers[2].y+70);
Circle(routers[2].x-24,routers[2].y+100,8);
FloodFill(routers[2].x-24,routers[2].y+100,white);
Line(routers[2].x,routers[2].y+72,routers[2].x-24,routers[2].y+100);
{-------------domain 2.2----------------------------------}
Rectangle(routers[2].x-80,routers[2].y+10,routers[2].x-60,routers[2].y+37);
FloodFill(routers[2].x-78,routers[2].y+12,white);
Line(routers[2].x-10,routers[2].y,routers[2].x-70,routers[2].y+20);
Circle(routers[2].x-110,routers[2].y+20,8);
FloodFill(routers[2].x-110,routers[2].y+20,white);
Circle(routers[2].x-140,routers[2].y+20,8);
FloodFill(routers[2].x-140,routers[2].y+20,white);
Line(routers[2].x-70,routers[2].y+20,routers[2].x-150,routers[2].y+20);
{-------------domain 3.1----------------------------------}
Rectangle(routers[3].x-45,routers[3].y-47,routers[3].x-25,routers[3].y-20);
FloodFill(routers[3].x-43,routers[3].y-45,white);
Circle(routers[3].x-60,routers[3].y-37,8);
FloodFill(routers[3].x-60,routers[3].y-37,white);
Circle(routers[3].x-80,routers[3].y-37,8);
FloodFill(routers[3].x-80,routers[3].y-37,white);
Line(routers[3].x-7,routers[3].y-8,routers[3].x-35,routers[3].y-37);
Line(routers[3].x-35,routers[3].y-37,routers[3].x-90,routers[3].y-37);
{-------------domain 4.1----------------------------------}
Rectangle(routers[4].x-39,routers[4].y-82,routers[4].x-13,routers[4].y-70);
FloodFill(routers[4].x-37,routers[4].y-81,white);
Line(routers[4].x-4,routers[4].y-10,routers[4].x-25,routers[4].y-70);
Circle(routers[4].x-40,routers[4].y-105,8);
FloodFill(routers[4].x-40,routers[4].y-105,white);
Line(routers[4].x-25,routers[4].y-75,routers[4].x-40,routers[4].y-105);
Circle(routers[4].x-60,routers[4].y-70,8);
FloodFill(routers[4].x-60,routers[4].y-70,white);
Line(routers[4].x-25,routers[4].y-75,routers[4].x-60,routers[4].y-70);
Circle(routers[4].x-40,routers[4].y-50,8);
FloodFill(routers[4].x-40,routers[4].y-50,white);
Line(routers[4].x-25,routers[4].y-75,routers[4].x-40,routers[4].y-50);
{-------------domain 4.2----------------------------------}
Rectangle(routers[4].x+25,routers[4].y-35,routers[4].x+45,routers[4].y-5);
FloodFill(routers[4].x+27,routers[4].y-33,white);
Circle(routers[4].x+57,routers[4].y-25,8);
FloodFill(routers[4].x+57,routers[4].y-25,white);
Circle(routers[4].x+77,routers[4].y-25,8);
FloodFill(routers[4].x+77,routers[4].y-25,white);
Circle(routers[4].x+97,routers[4].y-25,8);
FloodFill(routers[4].x+97,routers[4].y-25,white);
Circle(routers[4].x+117,routers[4].y-25,8);
FloodFill(routers[4].x+117,routers[4].y-25,white);
Line(routers[4].x+9,routers[4].y-7,routers[4].x+20,routers[4].y-25);
Line(routers[4].x+20,routers[4].y-25,routers[4].x+127,routers[4].y-25);
{-------------domain 5.1----------------------------------}
Rectangle(routers[5].x-30,routers[5].y-130,routers[5].x-10,routers[5].y-100);
FloodFill(routers[5].x-25,routers[5].y-128,white);
Line(routers[5].x,routers[5].y-10,routers[5].x-20,routers[5].y-120);
Circle(routers[5].x-48,routers[5].y-90,8);
FloodFill(routers[5].x-48,routers[5].y-120+30,white);
Line(routers[5].x-20,routers[5].y-120,routers[5].x-48,routers[5].y-90);
Circle(routers[5].x-50,routers[5].y-120,8);
FloodFill(routers[5].x-50,routers[5].y-120,white);
Line(routers[5].x-20,routers[5].y-120,routers[5].x-50,routers[5].y-120);
Circle(routers[5].x-25,routers[5].y-150,8);
FloodFill(routers[5].x-25,routers[5].y-150,white);
Line(routers[5].x-20,routers[5].y-120,routers[5].x-25,routers[5].y-150);
Circle(routers[5].x+2,routers[5].y-150,8);
FloodFill(routers[5].x+2,routers[5].y-150,white);
Line(routers[5].x-20,routers[5].y-120,routers[5].x+2,routers[5].y-150);
{-------------domain 6.1----------------------------------}
Rectangle(routers[6].x-30,routers[6].y-10,routers[6].x-14,routers[6].y+14);
FloodFill(routers[6].x-28,routers[6].y-8,white);
Circle(routers[6].x-42,routers[6].y,8);
FloodFill(routers[6].x-42,routers[6].y,white);
Circle(routers[6].x-62,routers[6].y,8);
FloodFill(routers[6].x-62,routers[6].y,white);
Circle(routers[6].x-82,routers[6].y,8);
FloodFill(routers[6].x-82,routers[6].y,white);
Line(routers[6].x-10,routers[6].y,routers[6].x-92,routers[6].y);
{-------------domain 7.1----------------------------------}
Rectangle(routers[7].x-10,routers[7].y-50,routers[7].x+10,routers[7].y-25);
FloodFill(routers[7].x-8,routers[7].y-48,white);
Line(routers[7].x,routers[7].y-10,routers[7].x,routers[7].y-50);
Circle(routers[7].x-35,routers[7].y-20,8);
FloodFill(routers[7].x-35,routers[7].y-20,white);
Line(routers[7].x,routers[7].y-50,routers[7].x-35,routers[7].y-20);
Circle(routers[7].x-35,routers[7].y-60,8);
FloodFill(routers[7].x-35,routers[7].y-60,white);
Circle(routers[7].x+15,routers[7].y-70,8);
FloodFill(routers[7].x+15,routers[7].y-70,white);
Line(routers[7].x,routers[7].y-50,routers[7].x+15,routers[7].y-70);
Line(routers[7].x,routers[7].y-50,routers[7].x-35,routers[7].y-60);
SetColor(cyan);
OuttextXY(18,routers[1].y-32,'4');
OuttextXY(38,routers[1].y-32,'3');OuttextXY(58,routers[1].y-32,'2');
OutTextXY(routers[1].x-48,routers[1].y-48,'FS');
OuttextXY(78,routers[1].y-32,'1');
OutTextXY(routers[1].x+8,routers[1].y+60,'1');
OutTextXY(routers[1].x-50,routers[1].y+60,'6');
OutTextXY(routers[1].x-50,routers[1].y+89,'5');
OutTextXY(routers[1].x-45,routers[1].y+113,'4');
OutTextXY(routers[1].x-20,routers[1].y+112,'3');
OutTextXY(routers[1].x-28,routers[1].y+82,'hub');
OutTextXY(routers[1].x+11,routers[1].y+111,'2');
OutTextXY(routers[2].x-24,routers[2].y+72,'modem');
OutTextXY(routers[2].x-26,routers[2].y+98,'1');
OutTextXY(routers[2].x-78,routers[2].y+12,'FS');
OutTextXY(routers[2].x-73,routers[2].y+24,'1');
OutTextXY(routers[2].x-112,routers[2].y+18,'2');
OutTextXY(routers[2].x-142,routers[2].y+18,'3');
OutTextXY(routers[3].x-42,routers[3].y-45,'FS');
OutTextXY(routers[3].x-38,routers[3].y-30,'1');
OutTextXY(routers[3].x-62,routers[3].y-40,'2');
OutTextXY(routers[3].x-82,routers[3].y-40,'3');
OutTextXY(routers[4].x-37,routers[4].y-80,'hub');
OutTextXY(routers[4].x-42,routers[4].y-107,'1');
OutTextXY(routers[4].x-62,routers[4].y-73,'2');
OutTextXY(routers[4].x-42,routers[4].y-53,'3');
OutTextXY(routers[4].x+28,routers[4].y-33,'FS');
OutTextXY(routers[4].x+33,routers[4].y-20,'1');
OutTextXY(routers[4].x+55,routers[4].y-27,'2');
OutTextXY(routers[4].x+75,routers[4].y-27,'3');
OutTextXY(routers[4].x+95,routers[4].y-27,'4');
OutTextXY(routers[4].x+115,routers[4].y-27,'5');
OutTextXY(routers[5].x-27,routers[5].y-127,'FS');
OutTextXY(routers[5].x-21,routers[5].y-110,'1');
OutTextXY(routers[5].x-51,routers[5].y-92,'2');
OutTextXY(routers[5].x-51,routers[5].y-122,'3');
OutTextXY(routers[5].x-27,routers[5].y-152,'4');
OutTextXY(routers[5].x,routers[5].y-152,'5');
OutTextXY(routers[6].x-29,routers[6].y-8,'FS');
OutTextXY(routers[6].x-25,routers[6].y+4,'1');
OutTextXY(routers[6].x-44,routers[6].y-2,'2');
OutTextXY(routers[6].x-64,routers[6].y-2,'3');
OutTextXY(routers[6].x-84,routers[6].y-2,'4');
OutTextXY(routers[7].x-7,routers[7].y-48,'FS');
OutTextXY(routers[7].x-2,routers[7].y-35,'1');
OutTextXY(routers[7].x-37,routers[7].y-22,'2');
OutTextXY(routers[7].x-37,routers[7].y-62,'3');
OutTextXY(routers[7].x+12,routers[7].y-72,'4');
SetColor(white);
OutTextXY(10,230,'Domain 1.1');OutTextXY(10,338,'Domain 1.2');
OutTextXY(200,220,'Domain 2.1');OutTextXY(110,150,'Domain 2.2');
OutTextXY(210,240,'Domain 3.1');
OutTextXY(170,320,'Domain 4.1');OutTextXY(330,370,'Domain 4.2');
OutTextXY(430,250,'Domain 5.1');
OutTextXY(450,175,'Domain 6.1');
{-------------router numbers-------------------------}
SetColor(black);
OutTextXY(routers[1].x-2,routers[1].y-2,'1');
OutTextXY(routers[2].x-2,routers[2].y-2,'2');
OutTextXY(routers[3].x-2,routers[3].y-2,'3');
OutTextXY(routers[4].x-2,routers[4].y-2,'4');
OutTextXY(routers[5].x-2,routers[5].y-2,'5');
OutTextXY(routers[6].x-2,routers[6].y-2,'6');
OutTextXY(routers[7].x-2,routers[7].y-2,'7');
if second then begin
setlinestyle(0,0,3);
setcolor({white}green);
for i:=1 to OptPathPtr-2 do
Line(routers[OptimalPath[i]].x,routers[OptimalPath[i]].y,
routers[OptimalPath[i+1]].x,routers[OptimalPath[i+1]].y);
while not keypressed do
for i:=1 to 63 do SetRGBPalette(green,0,i,0);
end;
if not second then while not keypressed do
for i:=1 to 63 do SetRGBPalette(red,i,0,0);
End;
Procedure
ShowTime(x,y :integer);
VAR
h, m, s, hund : Word;
Function
LeadingZero(w : Word) : String;
var
s : String;
begin
Str(w:0,s);
if Length(s) = 1 then s := '0' + s;
LeadingZero := s;
end;
Begin
GetTime(h,m,s,hund);TextColor(Green);GotoXY(x,y);Write(LeadingZero(h),':',
LeadingZero(m),':',LeadingZero(s),'.',LeadingZero(hund));
End;
Function
Dist (x1,y1,x2,y2:longint):longint;
var
temp:longint;
Begin
temp:=sqr(x2-x1)+sqr(y2-y1);
temp:=trunc((sqrt(temp)));
Dist:=temp;
End;
{-----------------objects
implementation part-----------------}
{---------------Computer
procedures---------------}
Procedure
TComp.Send2Router(batch:TBatch);{send batch to it's router}
VAR
i:byte;tmpFrom:TAddr;
Begin
Delay(DelaySendToRouter);
tmpFrom:=batch.from;
i:=batch.from.router;
routers[i].memory:=batch;{router receive data from his domain's computer}
showtime(wherex,wherey);
writeln('> ',tmpFrom.router,'.',tmpFrom.domain,'.',tmpFrom.comp,
' says : I send data ','"',batch.data,'"',' for
',batch.to_.router,'.',batch.to_.domain,'.',
batch.to_.comp,' to router',i);
for i:=1 to 38 do if
(computers[i].addr.router=tmpFrom.router) AND
(computers[i].addr.domain=tmpFrom.domain)
AND (computers[i].addr.comp=tmpFrom.comp) then break;
computers[i].mem.data:='';{clear memory}
End;
Procedure
TComp.Send(batch:TBatch);{into domain}
VAR
i:byte;tmpTo,tmpFrom:TAddr;
Begin
Delay(DelayInDomain);
tmpTo:=batch.to_;tmpFrom:=batch.from;
for i:=1 to 38 do if
(computers[i].addr.router=tmpTo.router) AND (computers[i].addr.domain=tmpTo.domain)
AND (computers[i].addr.comp=tmpTo.comp) then break;
computers[i].mem:=batch; {Send !}
showtime(wherex,wherey);
writeln('> ',tmpFrom.router,'.',tmpFrom.domain,'.',tmpFrom.comp,
' says : I send data ','"',batch.data,'"',' to ',batch.to_.router,'.',batch.to_.domain,'.',
batch.to_.comp);
for i:=1 to 38 do if
(computers[i].addr.router=tmpFrom.router) AND
(computers[i].addr.domain=tmpFrom.domain)
AND (computers[i].addr.comp=tmpFrom.comp) then break;
computers[i].mem.data:='';{clear memory}
End;
Procedure
TComp.Receive(batch:TBatch;byRouter:boolean);{computer receive data from his
domain's router}
VAR
tmpTo:TAddr;
Begin
Delay(DelayInDomain);
tmpTo:=batch.to_;
showtime(wherex,wherey);
write('> ',tmpTo.router,'.',tmpTo.domain,'.',tmpTo.comp,
' says : I receive data ','"',batch.data,'"',' from
',batch.from.router,'.',batch.from.domain,'.',
batch.from.comp);
if byRouter then writeln(' by router',tmpTo.router);
End;
{-------------Router
procedures-------------------}
Procedure
TRouter.CalcMinPath(sender,target:byte);
VAR
i,j:byte;
k:byte;
AllVertexMarked:boolean;
Begin
{----------------------- Initialization --------------------------}
for i:=1 to 7 do
for j:=1 to 7 do if AdjacencyMatrix[i,j]=1 then AMatr[i,j].link:=1
else AMatr[i,j].link:=0;
for i:=1 to 7 do for j:=1 to 7 do AMatr[i,j].weight:=0;
Randomize;
For j:=2 to7 do for i:=1 to j-1 do AMatr[i,j].weight:=random(50);
for i:=1 to 7 do vertexArr[i].marked:=false;
{-------------------------- Make marks -----------------------------}
{---- mark last vertex ----}
vertexArr[target].mark.delta:=0;vertexArr[target].mark.prevPtr:=target;
vertexArr[target].marked:=true;
AllVertexMarked:=false;
While not AllVertexMarked do BEGIN
For j:=1 to 7 do
For i:=1 to 7 do begin {j--->i}
if (AMatr[i,j].link<>0) AND (vertexArr[j].marked)
AND
(not vertexArr[i].marked) then begin
if not ((vertexArr[j].marked) AND (j=sender)) then begin
vertexArr[i].mark.delta:=vertexArr[j].mark.delta+AMatr[j,i].weight;
vertexArr[i].mark.prevPtr:=j;
vertexArr[i].marked:=true;
end;
end;
End;
AllVertexMarked:=true;
for i:=1 to 7 do if vertexArr[i].marked=false then AllVertexMarked:=false;
END;{While not AllVertexMarked}
{-------------------------- Main test -----------------------------}
for i:=1 to 49 do OptimalPath[i]:=0;
For i:=1 to 7 do vertexArr[i].marked:=false;
vertexArr[sender].marked:=true;
For j:=1 to 7 do
For i:=1 to 7 do begin {---- deltaA-deltaB > d(AB) then change mark}
{}
if (vertexArr[j].marked) AND (not(vertexArr[i].marked)) then begin
vertexArr[i].marked:=true;
for k:=1 to 7 do if (AMatr[k,j].link=1) then begin
if vertexArr[j].mark.delta-vertexArr[k].mark.delta>AMatr[k,j].weight
then
begin
vertexArr[j].mark.prevPtr:=k;
vertexArr[j].mark.delta:=vertexArr[k].mark.delta+AMatr[k,j].weight;
vertexArr[k].marked:=true;
end
{else vertexArr[k].marked:=true};
end;
end;
{}
end; {if adjacency vertex found}
push(sender);
k:=vertexArr[sender].mark.prevPtr;
push(k);
While k<>target do begin
push(vertexArr[k].mark.PrevPtr);
k:=vertexArr[k].mark.PrevPtr;
End;
End;
Procedure
TRouter.Send2NextRouter(batch:TBatch;currentRouter:byte);
Begin
Delay(DelayRouterReceive+AMatr[currentRouter,OptimalPath[OptPathPtr]].link);
showtime(wherex,wherey);
writeln('> router',currentRouter,
' says : I send data ','"',batch.data,'"',' from
',batch.from.router,'.',batch.from.domain,'.',
batch.from.comp,' to router',OptimalPath[OptPathPtr]);
routers[OptimalPath[OptPathPtr]].memory:=batch;
inc(OptPathPtr);
routers[currentRouter].memory.data:=''{clear memory}
End;
Procedure
TRouter.receive(routerNum:byte;batch:TBatch);
Begin
Delay(DelayRouterReceive);
showtime(wherex,wherey);
writeln('> router',routerNum,
' says : I receive data ','"',batch.data,'"',' from
',batch.from.router,'.',batch.from.domain,'.',
batch.from.comp);
End;
Procedure
TRouter.send2comp(batch:TBatch);
VAR
i:byte;tmpTo,tmpFrom:TAddr;
Begin
Delay(DelayInDomain);
tmpTo:=batch.to_;tmpFrom:=batch.from;
for i:=1 to 38 do if
(computers[i].addr.router=tmpTo.router) AND
(computers[i].addr.domain=tmpTo.domain)
AND (computers[i].addr.comp=tmpTo.comp) then break;
computers[i].mem:=batch; {Send !}
showtime(wherex,wherey);
writeln('> router',tmpTo.router,
batch.to_.comp);
routers[tmpTo.router].memory.data:='';{clear memory}
End;
Procedure
Initialization;
VAR
i,j:integer;
Begin
{------------- INITIALIZATION PART -------------}
FOR i:=1 to 7 do begin {routers initialization}
routers[i].num:=i;routers[i].state:=true;
routers[i].memory.data:='';
for j:=1 to 20 do routers[i].memory.path[j]:=0;
END;
routers[1].x:=120;routers[1].y:=300;
routers[2].x:=250;routers[2].y:=100;
routers[3].x:=320;routers[3].y:=300;
routers[4].x:=300;routers[4].y:=420;
routers[5].x:=500;routers[5].y:=420;
routers[6].x:=540;routers[6].y:=200;
routers[7].x:=550;routers[7].y:=100;
FOR i:=1 to 38 do computers[i].mem.data:='';{computers initialization}
j:=1;
for i:=1 to 4 do begin {router 1, domain 1}
computers[i].addr.router:=1;computers[i].addr.domain:=1;
computers[i].addr.comp:=j;inc(j);
end;
j:=1;
for i:=5 to 10 do begin {router 1, domain 2}
computers[i].addr.router:=1;computers[i].addr.domain:=2;
computers[i].addr.comp:=j;inc(j);
end; {router 2, domain 1}
computers[11].addr.router:=2;computers[11].addr.domain:=1;computers[11].addr.comp:=1;
j:=1;
for i:=12 to 14 do begin {router 2, domain 2}
computers[i].addr.router:=2;computers[i].addr.domain:=2;
computers[i].addr.comp:=j;inc(j);
end;
j:=1;
for i:=15 to 17 do begin {router 3, domain 1}
computers[i].addr.router:=3;computers[i].addr.domain:=1;
computers[i].addr.comp:=j;inc(j);
end;
j:=1;
for i:=18 to 20 do begin {router 4, domain 1}
computers[i].addr.router:=4;computers[i].addr.domain:=1;
computers[i].addr.comp:=j;inc(j);
end;
j:=1;
for i:=21 to 25 do begin {router 4, domain 2}
computers[i].addr.router:=4;computers[i].addr.domain:=2;
computers[i].addr.comp:=j;inc(j);
end;
j:=1;
for i:=26 to 30 do begin {router 5, domain 1}
computers[i].addr.router:=5;computers[i].addr.domain:=1;
computers[i].addr.comp:=j;inc(j);
end;
j:=1;
for i:=31 to 34 do begin {router 6, domain 1}
computers[i].addr.router:=6;computers[i].addr.domain:=1;
computers[i].addr.comp:=j;inc(j);
end;
j:=1;
for i:=35 to 38 do begin {router 7, domain 1}
computers[i].addr.router:=7;computers[i].addr.domain:=1;
computers[i].addr.comp:=j;inc(j);
end;
{------------- END OF INITIALIZATION PART -------------}
End;
Procedure
Error(ErrorNum:byte);
Begin
textcolor(lightred);
writeln(' Error !');
case ErrorNum of
1: writeln(' One (or two) of above addresses are not exist');
2: writeln(' FROM and TO are same');
end;
readln;halt;
End;
VAR
tmpStr :string;
tmpFrom :TAddr;
tmpTo :TAddr;
tmpData :string;
i,j :integer;
tmpX,tmpY:integer;
FromNum,ToNum:byte; {index FROM and TO computers in array}
BEGIN
{------------- MAIN PROGRAM ---------------}
Initialization;
ShowGraphics(false);readln;CloseGraph;
ClrScr;TextColor(LightGreen);
write(' Global Network Emulation ');ShowTime(70,1);writeln;
{------------- ADDRESS AND DATA REQUEST ---------------}
Write(' Enter FROM address (X.X.X) : ');readln(tmpStr);{FROM request-------}
Val(tmpStr[1],tmpFrom.router,i);Val(tmpStr[3],tmpFrom.domain,i);
Val(tmpStr[5],tmpFrom.comp,i);{target request-----------------------------}
Write(' Enter TO address (X.X.X) : ');readln(tmpStr);
Val(tmpStr[1],tmpTo.router,i);Val(tmpStr[3],tmpTo.domain,i);
Val(tmpStr[5],tmpTo.comp,i);
Write(' Enter string-type DATA : ');readln(tmpData);
{------------- SEARCH 'FROM' TERMINAL -------------------}
for i:=1 to 38 do if
(computers[i].addr.router=tmpFrom.router) AND
(computers[i].addr.domain=tmpFrom.domain)
AND (computers[i].addr.comp=tmpFrom.comp) then FromNum:=i;
{------------- SEARCH 'TO' TERMINAL ----------------------}
for i:=1 to 38 do if
(computers[i].addr.router=tmpTo.router) AND
(computers[i].addr.domain=tmpTo.domain)
AND (computers[i].addr.comp=tmpTo.comp) then ToNum:=i;
if (FromNum=0) OR (ToNum=0) then Error(1);
if FromNum=ToNum then Error(2);{computer cannot send batch to itself}
{------------- FILL 'ADDRESS' FIELDS-----------------------}
computers[FromNum].mem.to_.router:=tmpTo.router;
computers[FromNum].mem.to_.domain:=tmpTo.domain;
computers[FromNum].mem.to_.comp:=tmpTo.comp;
computers[FromNum].mem.from.router:=tmpFrom.router;
computers[FromNum].mem.from.domain:=tmpFrom.domain;
computers[FromNum].mem.from.comp:=tmpFrom.comp;
{------------- FILL DATA FIELDS-----------------------}
computers[FromNum].mem.data:=tmpData;
writeln;
OptPathPtr:=0;
if computers[FromNum].mem.from.router<>computers[FromNum].mem.to_.router
then routers[tmpFrom.router].CalcMinPath(tmpFrom.router,tmpTo.router);
OptPathPtr:=2;
WHILE TRUE DO BEGIN {-------------- GLOBAL NET SCANNING ------------------}
for i:=1 to 38 do {------scanning terminals for data for sending --------}
{}
if computers[i].mem.data<>'' then begin
if
(computers[i].addr.router=computers[i].mem.to_.router)
AND (computers[i].addr.domain=computers[i].mem.to_.domain)
AND (computers[i].addr.comp<>computers[i].mem.to_.comp)
then
begin
computers[i].send(computers[i].mem);{into domain sending}
break;
end
else if (computers[i].addr.router<>computers[i].mem.to_.router)
OR (computers[i].addr.domain<>computers[i].mem.to_.domain)
then
computers[i].Send2Router(computers[i].mem); {send to router}
{}
end;{if data for sending found}
for i:=1 to 7 do {------scanning routers for receiving data}
if routers[i].memory.data<>'' then begin
routers[i].receive(i,routers[i].memory);
if routers[i].memory.to_.router=i then begin {if send into domain}
routers[i].send2comp(routers[i].memory);
break;
end else begin
routers[i].send2nextRouter(routers[i].memory,i);
break;
end;
end; {-------------------------------}
for i:=1 to 38 do {------scanning terminals for receiving data}
if computers[i].mem.data<>'' then begin
if
(computers[i].addr.router=computers[i].mem.to_.router)
AND (computers[i].addr.domain=computers[i].mem.to_.domain)
then
begin {into domain receiving}
computers[i].receive(computers[i].mem,false);
break;
end;
{---------------------}
computers[i].receive(computers[i].mem,true);{receiving
from router}
break;
end;{if receive data found}
for i:=1 to 38 do
if (computers[i].mem.data<>'')
AND(computers[i].addr.router=computers[i].mem.to_.router)
AND (computers[i].addr.domain=computers[i].mem.to_.domain)
AND (computers[i].addr.comp=computers[i].mem.to_.comp)
then while true do begin {---------Batch received !---------}
HiddenCursor;
tmpX:=wherex;tmpY:=whereY;
ShowTime(70,1);
gotoXY(tmpX,tmpY);
if keypressed then begin
readkey;
ShowGraphics(true);
readln;
CloseGraph;
NormVideo;
NormalCursor;
halt;
end;
end;
tmpX:=wherex;tmpY:=whereY;
ShowTime(70,1);
gotoXY(tmpX,tmpY);
END;{-------------- END OF GLOBAL NET SCANNING ---------------------------}
END.