107
108
Приложение 5
Программный код разработанного модуля по тестированию стабильности
сайта
unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil,
Forms, Controls, Graphics, Dialogs, StdCtrls, LazHelpHTML, ExtCtrls,
fphttpclient, LCLProc, Buttons, lclintf, Unit3, mmSystem;
type
{ TForm1 }
TForm1 = class(TForm)
BitBtn1: TBitBtn;
BitBtn2: TBitBtn;
BitBtn3: TBitBtn;
BitBtn4: TBitBtn;
Button1: TButton;
Button10: TButton;
Button11: TButton;
Button12: TButton;
Button13: TButton;
Button14: TButton;
Button15: TButton;
Button16: TButton;
Button2: TButton;
Button3: TButton;
Button4: TButton;
Button5: TButton;
Button6: TButton;
Button7: TButton;
Button8: TButton;
109
Button9: TButton;
Edit6: TEdit;
Edit7: TEdit;
Edit8: TEdit;
get_users: TButton;
CB_Mails: TCheckBox;
CBthrough_server: TCheckBox;
CB_whoNow: TCheckBox;
Edit5: TEdit;
GroupBox1: TGroupBox;
GroupBox2: TGroupBox;
GroupBox3: TGroupBox;
GroupBox4: TGroupBox;
Label10: TLabel;
Label11: TLabel;
Label6: TLabel;
Label7: TLabel;
Label8: TLabel;
Label9: TLabel;
LabeledEdit1: TLabeledEdit;
Memo2_name: TMemo;
Memo2_whoNow: TMemo;
Memo2_Emails: TMemo;
Panel1: TPanel;
Panel2: TPanel;
Panel3: TPanel;
StopTimer: TButton;
Edit1: TEdit;
Edit2: TEdit;
Edit3: TEdit;
Edit4: TEdit;
Label1: TLabel;
110
Label2: TLabel;
Label3: TLabel;
Label4: TLabel;
Label5: TLabel;
Memo1: TMemo;
Timer1: TTimer;
Timer2: TTimer;
procedure beepClick(Sender: TObject);
procedure BitBtn1Click(Sender: TObject);
procedure BitBtn2Click(Sender: TObject);
procedure BitBtn3Click(Sender: TObject);
procedure BitBtn4Click(Sender: TObject);
procedure Button10Click(Sender: TObject);
procedure Button11Click(Sender: TObject);
procedure Button12Click(Sender: TObject);
procedure Button13Click(Sender: TObject);
procedure Button14Click(Sender: TObject);
procedure Button15Click(Sender: TObject);
procedure Button16Click(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure Button4Click(Sender: TObject);
procedure Button5Click(Sender: TObject);
procedure Button6Click(Sender: TObject);
procedure Button7Click(Sender: TObject);
procedure Button8Click(Sender: TObject);
procedure Button9Click(Sender: TObject);
procedure Edit6Change(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure get_usersClick(Sender: TObject);
procedure CBthrough_serverChange(Sender: TObject);
111
procedure CB_whoNowChange(Sender: TObject);
procedure Label5Click(Sender: TObject);
procedure LabeledEdit1Change(Sender: TObject);
procedure Memo2_EmailsChange(Sender: TObject);
procedure Panel3Click(Sender: TObject);
procedure StopTimerClick(Sender: TObject);
procedure CB_MailsChange(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure Timer2Timer(Sender: TObject);
Procedure SearchText (Sender: TObject) ;
procedure ToggleBox1Change(Sender: TObject);
private
public
end;
var
Form1: TForm1;
cicle, counter, counter2, noConnection, Memo2_Emails_Canged, noInternet:
integer;
httpurl: string;
Emails_arr: array [1..100] of String;
Emails_str: String;
no_form: integer;
web_module_link: String;
implementation
{$R *.lfm}
{TForm1}
Function ShMess (typeOfMess : String; url: String; text: String) : String;
Begin
If (typeOfMess = '1') Then
ShMess := 'Не найден текст'+#13#10+'"'+text+'"'+#13#10+' на стр
'+#13#10+'"'+url+'"';
112
If (typeOfMess = '0') Then
ShMess := 'Нет связи с проверяемым сервером или исчезла веб-
страница '+#13#10+'"'+url+'"';
End;
// Перекодировка символов
Function codText (txt : String) : String;
Begin
codText:= StringReplace(txt, ' ', '0PROBEL0', [rfReplaceAll, rfIgnoreCase]);
End;
Function check_through_server (url: String; text_string: String): String;
Var
urlget, html: String;
httpclient: TFPHTTPClient;
Begin
text_string := codText (text_string);
urlget:=
web_module_link+'/mind/check_through_server.php?url='+url+'&text_string='+text_s
tring;
httpclient := TFPHttpClient.Create(Nil);
try
try
html := httpclient.Get(urlget);
except
{ Label5.Caption := 'Нет связи с главным сервером';
Label5.Font.Color := clMaroon;
Label7.Caption := 'Нет связи с главным сервером';}
End;
finally
httpclient.Free;
end;
check_through_server := html;
End;
113
procedure Fill_Array(L : TStrings; var Arr : array of String);
var
s : string;
i : integer;
begin
// тут же можно проверить, хватит ли емкости массива,
// чтобы вместить все данные (if L.Count < High(Arr))
Emails_str:= '';
i := 0;
for s in L do
begin
Arr[i] := s;
Emails_str := Emails_str + '|' + s;
Inc(i);
end;
end;
procedure TForm1.beepClick(Sender: TObject);
begin
end;
procedure TForm1.BitBtn1Click(Sender: TObject);
begin
Memo2_Emails.Lines.SaveToFile('emails.txt');
Label8.Caption := 'Сохранено в файл';
end;
procedure TForm1.BitBtn2Click(Sender: TObject);
begin
Memo2_Emails.Lines.LoadFromFile('emails.txt');
Label8.Caption := 'Восстановлено из файла';
end;
procedure TForm1.BitBtn3Click(Sender: TObject);
begin
end;
114
procedure TForm1.BitBtn4Click(Sender: TObject);
begin
OpenURL(Edit1.Text);
end;
procedure TForm1.Button10Click(Sender: TObject);
begin
Fill_Array(Memo2_Emails.Lines, Emails_arr); // создает строку Emails_str из
строк Memo2_Emails
Label8.Caption := 'Применено';
end;
procedure TForm1.Button11Click(Sender: TObject);
begin
OpenURL(web_module_link+'/mail/log.php');
end;
procedure TForm1.Button12Click(Sender: TObject);
begin
Form3.show;
// Form3.msc('s');
Form3.Button2Click(Button2); //запуск музыки
end;
procedure TForm1.Button13Click(Sender: TObject);
var httpclient: TFPHTTPClient;
url, html, result: String;
duration: Integer;
begin
If ( StrToInt(Edit5.Text) > 0) Then
begin
result := 'no';
duration := StrToInt(Edit5.Text) * StrToInt(Edit3.Text); // сколько неудач *
Интервал
end;
If ( StrToInt(Edit8.Text) > 0) Then
115
begin
result := 'ok';
duration := StrToInt(Edit8.Text) * StrToInt(Edit3.Text); // сколько удач *
Интервал
end;
url:=
web_module_link+'/mind/isok.php?isok='+result+'&nomber='+Edit6.Text+'&duration
='+IntToStr(duration);
httpclient := TFPHttpClient.Create(Nil);
try
try
html := httpclient.Get(url);
except
Label5.Caption := 'Нет связи с главным сервером';
Label5.Font.Color := clMaroon;
Label7.Caption := 'Нет связи с главным сервером';
End;
finally
httpclient.Free;
end;
// ShowMessage(html);
end;
procedure TForm1.Button14Click(Sender: TObject);
begin
Form3.show;
Form3.label2.caption := ShMess ('0', Edit1.Text, Edit4.Text); // показ сообщ
"Нет связи с сервером или исчезла web-страница"
Form3.Button2Click(Button2);
end;
procedure TForm1.Button15Click(Sender: TObject);
begin
with TForm1.Create(Application) do
116
begin
// Parent := Self;
// Top := Top + 100; Left := Left + 100;
Caption := '№'+intToStr(no_form)+' '+'Проверка текста на сайте';
Visible := True;
no_form:= no_form+1;
end;
end;
procedure TForm1.Button16Click(Sender: TObject);
begin
(Sender as TButton).Caption := '1';
end;
// Отправка почты
Procedure SendMail (svyaz: String; text: String; url: String; text_string: String;
emails: String; name: String);
var httpclient: TFPHTTPClient;
urlmail, html: String;
begin
text_string := codText (text_string);
emails := codText (emails);
name := codText (name);
urlmail :=
web_module_link+'/mail/index.php?svyaz='+svyaz+'&text='+text+'&text_string='+tex
t_string+'&url='+url+'&emails='+emails+'&name='+name;
httpclient := TFPHttpClient.Create(Nil);
try
try
html := httpclient.Get(urlmail);
except
{ Label5.Caption := 'Нет связи с главным сервером';