к 4GL - визуальному программированию   Kylix   RUNTU   ОС  

Приложение 2. Листинги модулей для создания системы помощи

Здесь представлены листинги модулей для создания системы помощи.

Листинг П2.1. Модуль WinHelpViewer. pas
unit WinHelpViewer;
{**********************************************************************************}
{ }
( Этот модуль обеспечивает поддержку просмотрщика помощи WinHelp (под
{ Windows) или HyperHelp (эмулятор WinHelp) под Linux.}
{ }
{ **********************************************************************************}
interface
uses Classes;
type
IWinHelpTester = interface(Ilnterface)
['{BOFC9354-5FOE-11D3-A3B9-00C04F79AD3A)']
function CanShowALink(const ALink, FileName: String): Boolean;
function CanShowTopic(const Topic, FileName: String): Boolean;
function CanShowContext(const Context: Integer;
const FileName: String): Boolean;
function GetHelpStrings(const ALink: String): TStringList;
function GetHelpPath : String;
function GetDefaultHelpFile: String;
end;
var
WinHelpTester : IWinHelpTester;
ViewerName : String;
{$IFDEF LINUX}
HyperHelpWindowName : String;
{$ENDIF}
{=========================================================================}
implementation
($IFDEF MSWINDOWS}
uses Helplntfs, SysUtils, Windows;
{$ENDIF}
{$IFDEF LINUX}
uses Helplntfs, SysUtils, Libc;
{$ENDIF}
($IFDEF LINUX)
const
winhelpmodulename = 'winhelp.so';
function WinHelp(HWND: Longlnt; HelpFile: PChar; Command: Longlnt;
Data: LongWord): Boolean; cdecl;
external winhelpmodulename name 'WinHelp';
($ENDIF}
type
TWinHelpViewer = class(TInterfacedobject, ICustomHelpViewer, lExtended-HelpViewer, ISpecialWinHelpViewer)
private
FViewerlD: Integer;
public
FHelpManager: IHelpManager;
constructor Create;
function HelpFile(const Name: String) : String;
procedure InternalShutDown;
{ ICustomHelpViewer }
function GetViewerName : String;
function UnderstandsKeyword(const HelpString: String): Integer;
function GetHelpStrings(const HelpString: String): TStringList;
function CanShowTableOfContents: Boolean;
procedure ShowTableOfContents;
procedure ShowHelp(const HelpString: String);
procedure NotifylD(const ViewerlD: Integer);
procedure SoftShutDown;
procedure ShutDown;
{ lExtendedHelpViewer }
function UnderstandsTopic(const Topic: String): Boolean;
procedure DisplayTopic(const Topic: String);
function UnderstandsContext(const ContextID: Integer;
const HelpFileName: String): Boolean;
procedure DisplayHelpByContext(const ContextID: Integer;
const HelpFileName: String);
( ISpecialWinHelpViewer }
function CallWinHelp(Handle: Longlnt; const HelpFileName: String;
Command: Word; Data: Longlnt) : Boolean;
property ViewerlD : Integer read FViewerlD;
property HelpManager : IHelpManager read FHelpManager write FHelpManager;
destructor Destroy; override;
end;
var
HelpViewer : TWinHelpViewer;
{---------------------------------------------------------------------------------------------------------------------------}
{ TWinHelpViewer }
constructor TWinHelpViewer.Create;
begin
inherited Create;
end;
function TWinHelpViewer.HelpFile(const Name: String): String;
var
FileName : String;
begin
Result := " ;
if (Name = '') and Assigned(FHelpManager) then
FileName := HelpManager.GetHelpFile
else FileName := Name;
if FileName = '' then
if Assigned(WinHelpTester) then
FileName := WinHelpTester.GetDefaultHelpFile;
{$IFDEF LINUX}
if Assigned(WinHelpTester) then
FileName := WinHelpTester.GetHelpPath + PathDelim + FileName;
{$ENDIF}
Result := FileName;
end;
procedure TWinHelpViewer.InternalShutDown;
begin
SoftShutDown;
if Assigned(FHelpManager) then
begin
HelpManager.Release(ViewerlD);
if Assigned(FHelpManager) then HelpManager := nil;
end;
end;
{-------------------------------------------------------------------------------------------------------------------------------}
{ TWinHelpViewer - ICustomHelpViewer }
function TWinHelpViewer.GetViewerName : String;
begin
Result := ViewerName;
end;
function TWinHelpViewer.UnderstandsKeyword(const HelpString: String):
Integer;
var
CanShowHelp : Boolean;
begin
if Assigned(WinHelpTester) then
begin
CanShowHelp := WinHelpTester.CanShowALink(HelpString, HelpFile(''));
if CanShowHelp then Result := 1
else Result := 0;
end
else begin
{$IFDEF WINDOWS}
Result := 1;
{$ENDIF}
{$IFDEF LINUX}
Result := 0;
{$ENDIF}
end;
end;
function TWinHelpViewer.GetHelpStrings(const HelpString: String):
TStringList;
begin
if Assigned(WinHelpTester) then
begin
Result := WinHelpTester.GetHelpStrings(HelpString);
end else
begin
Result := TStringList.Create;
{$IFDEF MSWINDOWS}
Result.Add(GetViewerName + ': ' + , HelpString);
{SENDIF}
end;
end;
function TWinHelpViewer.CanShowTableOfContents : Boolean;
begin
Result := true;
end;
procedure TWinHelpViewer.ShowTableOfContents;
begin
WinHelp(HelpManager.GetHandle, PChar(HelpFile(HelpManager.GetHelpFile)
HELP_CONTENTS, 0);
end;
{$IFDEF MSWINDOWS}
procedure TWinHelpViewer.ShowHelpfconst HelpString: String);
const
Macro = 4E(AL("%s",4),"AL(\"%0:s\",3)","JK(\"%l:s\",\"%0:s\")")';
begin
WinHelp(HelpManager.GetHandle, PChar(HelpFile('')), HELP_COMMAND,
Longlnt(PChar(Format(Macro, [HelpString, HelpFile(")]))));
end;
{$ENDIF}
($IFDEF LINUX}
procedure TWinHelpViewer.ShowHelp(const HelpString: String);
const
Macro = 'AL(%Os,3,,%ls)';
begin
WinHelp(HelpManager.GetHandle, PChar(HelpFile('')), HELP_COMMAND,
Longlnt(Pchar(Format(Macro, [HelpString, HyperHelpWindowName]))));
end;
{$ENDIF}
procedure TWinHelpViewer.NotifylD(const ViewerlD: Integer);
begin
FViewerlD := ViewerlD;
end;
procedure TWinHelpViewer.SoftShutDown;
begin
WinHelp(0, PChar(''), HELP_QUIT, 0);
end;
procedure TWinHelpViewer.ShutDown;
begin
SoftShutDown;
if Assigned(FHelpManager) then HelpManager := nil;
if Assigned(WinHelpTester) then WinHelpTester := nil;
end;
{--------------------------------------------------------------------------------------------------------------------}
{ TWinHelpViewer --- lExtendedHelpViewer }
function TWinHelpViewer.UnderstandsTopic(const Topic: String): Boolean;
begin
{5IFDEF MSWINDOWS}
Result := true;
{$ENDIF}
{$IFDEF LINUX)
Result := false;
{$ENDIF}
if Assigned(WinHelpTester} then
Result := WinHelpTester.CanShowTopic(Topic, HelpFile(''));
end;
procedure TWinHelpViewer.DisplayTopic(const Topic: String);
var
HelpCommand: array[0..255 of Char;
begin
StrLFmt(HelpCommand, SizeOf(HelpCommand) -I, 'JumpID("","%s")', [Topic]);
WinHelp(HelpManager.GetHandle, PChar(HelpFile('')), HELP_COMMAND,
Longint(@HelpCommand));
end;
function TWinHelpViewer.UnderstandsContext(const ContextID: Integer;
const HelpFileName: String): Boolean;
begin
{$IFDEF MSWINDOWS}
Result := true;
{$ENDIF}
($IFDEF LINUX}
Result := false;
{$ENDIF}
if Assigned(WinHelpTester) then
Result := WinHelpTester.CanShowContext(ContextID, Help-File (HelpFileName));
end;
procedure TWinHelpViewer.DisplayHelpByContext(const ContextID: Integer;
const HelpFileName: String);
begin
WinHelpfHelpManager.GetHandle, PChar(HelpFile(HelpFileName)),
HELP_CONTEXT, ContextID);
end;
{----------------------------------------------------------------------------------------------------------------}
{ TWinHelpViewer --- ISpecialWinHelpViewer }
function TWinHelpViewer.CallWinHelp(Handle: Longlnt; const HelpFileName: String;
Command: Word; Data: Longlnt) : Boolean;
begin
Result := WinHelp(Handle, PChar(HelpFile(HelpFileName)), Command, Data);
end;
destructor TWinHelpViewer.Destroy;
begin
inherited Destroy;
end;
{==================================================================================}
initialization
HelpViewer := TWinHelpViewer.Create;
Helplntfs.RegisterViewer(HelpViewer, HelpViewer.FHelpManager);
WinHelpTester := nil;
finalization
if Assigned(HelpViewer.FHelpManager) then
begin
HelpViewer.InternalShutDown;
end;
if Assigned(WinHelpTester) then
begin
WinHelpTester := nil;
end;
end.

Листинг П2.2. Модуль Man Viewer, pas
unit ManViewer;
{ ***************************************************************************************************}
{ }
{ Этот модуль поддерживает просмотрщик страниц man в среде Linux. }
{ Он не был опробован на различных unix-системах и формах Linux, }
{ за исключением RedHat. }
{ }
{ ********************************************************************* ********************************}
interface
{=====================================================================}
implementation
uses Helplntfs, Classes, SysUtils, LibC;
type
TManPageViewer = class(TlnterfacedObject, ICustomHelpViewer)
private
FHelpStrings : TStringList;
FLastQuery : String;
FViewerlD : Integer;
ChildPid : Integer;
procedure ProcessHelpStrings(StringBuf: PChar; HelpString: String);
procedure KillChild;
public
FHelpManager : IHelpManager;
constructor Create;
procedure InternalShutDown;
{ ICustomHelpViewer }
function GetViewerName : String;
function UnderstandsKeyword(const HelpString: String): Integer;
function GetHelpStrings(const HelpString: String): TStringList;
function CanShowTableOfContents : Boolean;
procedure ShowHelp(const HelpString: String);
procedure ShowTableOfContents;
procedure NotifyID(const ViewerlD: Integer);
procedure SoftShutDown;
procedure ShutDown;
property HelpManager : IHelpManager read FHelpManager write FHelpManager;
property ViewerlD : Integer read FViewerlD;
destructor Destroy; override;
end;
var
HelpViewer : TManPageViewer;
const
{ man and its switches }
ExeName = 'man';
AllSwitch = '-a'; { отображает все man-страницы раздела }
WhereSwitch = '-w'; { где располагается man-страница? }
ViewerName = 'xterm';
MoreBugSwitch = '-cu';
ExecSwitch = '-e';
TitleSwitch = '-Т'; {установка заголовка окна }
ViewerTitle = 'Kylix man page viewer';
{ сигнал, используемый для завершения дочерних процессов }
KillSignal = SIGINT;
sFatalFork = 'Unable to fork(). Please consult the disaster manual.';
sNoTableOfContents = 'Unable to provide table of contents for man pages. ' ;
{--------------------------------------------------------------------------------------------------------------------------------------------------}
{ TManPageViewer }
constructor TManPageViewer.Create;
begin
inherited Create;
end;
procedure TManPageViewer.ProcessHelpStrings(StringBuf: PChar;
HelpString: String);
var
bufptr, lineptr, valptr, delim: PChar;
searching: boolean;
addstr : String;
begin
bufptr := StringBuf;
searching := true;
while searching do
begin
delim := #10#13;
lineptr := strsep(@bufptr, delim);
if (lineptr = nil) then
begin
searching := false;
end else
begin
delim := ' . ' ;
strsep(Slineptr, delim);
valptr := strsep(Slineptr, delim);
if valptr <> nil then
begin
addstr := HelpString + ' (' + valptr + ') (' + GetViewerName + ')';
FHelpStrings.Add(addstr);
end;
end;
end;
end;
procedure TManPageViewer.KillChild;
begin
if ChildPid <> 0 then
begin
kill(ChildPid, KillSignal);
waitpid(ChildPid, nil, WNOHANG or WUNTRACED);
ChildPid := 0;
end;
end;
procedure TManPageViewer.InternalShutDown;
begin
KillChild;
if Assigned(FHelpManager) then FHelpManager.Release(ViewerlD);
ShutDown;
end;
{--------------------------------------------------------------------------------------------------------------------------------------------------------------}
( TManPageViewer --- ICustomHelpViewer }
function TManPageViewer.GetViewerName;
begin
Result := ExeName;
end;
function TManPageViewer.UnderstandsKeyword(const HelpString: String):
Integer;
var
SuccDescr, ErrDescr : TPipeDescriptors;
pid: Integer;
Args : array of PChar;
DescriptorSet : TFDSet;
WaitTime : TTimeVal;
WaitStatus: Integer;
PipeStream : THandleStream;
ReadBuf : Pointer;
BytesRead: Integer;
Reading : Boolean;
begin
Result := 0;
if FHelpStrings <> nil then FHelpStrings := nil;
SetLength(Args, 5);
Args[0] := ExeName;
Args[l] := AllSwitch;
Args[2] := WhereSwitch;
Args[3] := PChar(HelpString);
Args[4] := nil;
pipe(SuccDescr);
pipe(ErrDescr);
pid := fork;
if pid = 0 then
begin
__close(SuccDescr.ReadDes);
__close(ErrDescr.ReadDes);
dup2(SuccDescr.WriteDes, stdout);
dup2(ErrDescr.WriteDes, stderr);
execvp (PChar (Args [ 0 ] ) , @Args [ 0 ].) ;
end
else begin
if pid = -1 then
begin
raise EHelpSystemException.Create(sFatalFork);
end else
begin
WaitStatus := waitpid(pid, nil, WUNTRACED);
if WaitStatus > 0 then
begin
WaitTime.tv sec := 0;
WaitTime.tv_usec := 0;
FD_ZERO(DescriptorSet);
FD_SET(TSocket(SuccDescr.ReadDes), DescriptorSet);
FD_SET(TSocket(ErrDescr.ReadDes), DescriptorSet);
select(__FD_SETSIZE, @DescriptorSet, nil, nil, @WaitTime);
if FD_ISSET(TSocket(SuccDescr.ReadDes), DescriptorSet) then
begin
if FHelpStrings = nil then FHelpStrings := TStringList.Create;
PipeStream := THandleStream.Create(SuccDescr.ReadDes);
ReadBuf := Libc.malloc(1024);
memset(ReadBuf, 0, 1024);
Reading := true;
while Reading do
begin
BytesRead := PipeStream.Read(ReadBuf^, 1024);
if (BytesRead < 1024) then Reading := false;
ProcessHelpStrings (ReadBuf-, HelpString) ;
memset(ReadBuf, 0, 1024);
end;
Libc.free(ReadBuf);
PipeStream.Free;
Result := FHelpStrings.Count;
FLastQuery := HelpString;
end else
begin
end;
end else
begin
if FHelpStrings = nil then FHelpStrings := TStringList.Create;
end;
end;
end;
__close(SuccDescr.WriteDes);
__close(ErrDescr.WriteDes);
__close(SuccDescr.ReadDes);
__close(ErrDescr.ReadDes);
end;
function TManPageViewer.GetHelpStrings(const HelpString: String):
TStringList;
begin
Result := FHelpStrings;
end;
function TManPageViewer.CanShowTableOfContents: Boolean;
begin
Result := false;
end;
procedure TManPageViewer.ShowTableOfContents;
begin
raise EHelpSystemException.Create(sNoTableOfContents);
end;
procedure TManPageViewer.ShowHelp(const HelpString: String);
var
KeywordEnd, Section, CompResult, CompString, Comparator: PChar;
Args : array of PChar;
pid : Integer;
begin
KillChild;
SetLength(Args, 9);
Args[0] := ViewerName;
Args[l] := MoreBugSwitch;
Args[2] := TitleSwitch;
Args[3] := ViewerTitle;
Args[4] := ExecSwitch;
Args[5] := ExeName;
Args[6] := AllSwitch;
Args[7] := PChar(HelpString);
Args[8] := nil;
CompString := PChar(HelpString) ;
Comparator := Libc.malloc(2);
Comparator[0] := ' (' ;
Comparator[1] := #0;
CompResult := strstr(CompString, Comparator);
Libc.free(Comparator);
if (CompResult <> nil) then
begin
Section := Libc.malloc(2) ;
KeywordEnd := AnsiStrPos(PChar(HelpString) , '(');
Section[0] := KeywordEnd[1];
Section[1] := #0;
Args[6] := Section;
{ #DEFINE DUMB_HACK_BY_TIRED_PROGRAMMER }
Args[7] := PChar(FLastQuery);
end
else begin
Section := nil;
end;
pid := fork;
if pid = 0 then
begin
execvp(PChar(Args[0]), @Args[0]);
end
else begin
if pid = -1 then
begin
raise EHelpSystemException.Create(sFatalFork) ;
end
else begin
ChildPid := pid;
end;
end;
if Section <> nil then Libc.free(Section) ;
end;
procedure TManPageViewer.NotifylD(const ViewerlD: Integer);
begin
FViewerlD := ViewerlD;
end;
procedure TManPageViewer.SoftShutDown;
begin KillChild;
end;
procedure TManPageViewer.ShutDown;
begin
KillChild;
if Assigned(FHelpManager) then FHelpManager := nil;
end;
destructor TManPageViewer.Destroy;
begin
inherited Destroy;
end;
{================================================================================}
initialization
if not Assigned(HelpViewer) then
begin
HelpViewer := TManPageViewer.Create;
HelpIntfs.RegisterViewer(HelpViewer, HelpViewer.FHelpManager);
end;
finalization
if Assigned(HelpViewer) then
begin
HelpViewer.InternalShutDown;
end;
end.

к 4GL - визуальному программированию   Kylix   RUNTU   ОС  

Знаете ли Вы, что релятивизм (СТО и ОТО) не является истинной наукой? - Истинная наука обязательно опирается на причинность и законы природы, данные нам в физических явлениях (фактах). В отличие от этого СТО и ОТО построены на аксиоматических постулатах, то есть принципиально недоказуемых догматах, в которые обязаны верить последователи этих учений. То есть релятивизм есть форма религии, культа, раздуваемого политической машиной мифического авторитета Эйнштейна и верных его последователей, возводимых в ранг святых от релятивистской физики. Подробнее читайте в FAQ по эфирной физике.

НОВОСТИ ФОРУМА

Форум Рыцари теории эфира

Рыцари теории эфира
 10.11.2021 - 12:37: ПЕРСОНАЛИИ - Personalias -> WHO IS WHO - КТО ЕСТЬ КТО - Карим_Хайдаров.
10.11.2021 - 12:36: СОВЕСТЬ - Conscience -> РАСЧЕЛОВЕЧИВАНИЕ ЧЕЛОВЕКА. КОМУ ЭТО НАДО? - Карим_Хайдаров.
10.11.2021 - 12:36: ВОСПИТАНИЕ, ПРОСВЕЩЕНИЕ, ОБРАЗОВАНИЕ - Upbringing, Inlightening, Education -> Просвещение от д.м.н. Александра Алексеевича Редько - Карим_Хайдаров.
10.11.2021 - 12:35: ЭКОЛОГИЯ - Ecology -> Биологическая безопасность населения - Карим_Хайдаров.
10.11.2021 - 12:34: ВОЙНА, ПОЛИТИКА И НАУКА - War, Politics and Science -> Проблема государственного терроризма - Карим_Хайдаров.
10.11.2021 - 12:34: ВОЙНА, ПОЛИТИКА И НАУКА - War, Politics and Science -> ПРАВОСУДИЯ.НЕТ - Карим_Хайдаров.
10.11.2021 - 12:34: ВОСПИТАНИЕ, ПРОСВЕЩЕНИЕ, ОБРАЗОВАНИЕ - Upbringing, Inlightening, Education -> Просвещение от Вадима Глогера, США - Карим_Хайдаров.
10.11.2021 - 09:18: НОВЫЕ ТЕХНОЛОГИИ - New Technologies -> Волновая генетика Петра Гаряева, 5G-контроль и управление - Карим_Хайдаров.
10.11.2021 - 09:18: ЭКОЛОГИЯ - Ecology -> ЭКОЛОГИЯ ДЛЯ ВСЕХ - Карим_Хайдаров.
10.11.2021 - 09:16: ЭКОЛОГИЯ - Ecology -> ПРОБЛЕМЫ МЕДИЦИНЫ - Карим_Хайдаров.
10.11.2021 - 09:15: ВОСПИТАНИЕ, ПРОСВЕЩЕНИЕ, ОБРАЗОВАНИЕ - Upbringing, Inlightening, Education -> Просвещение от Екатерины Коваленко - Карим_Хайдаров.
10.11.2021 - 09:13: ВОСПИТАНИЕ, ПРОСВЕЩЕНИЕ, ОБРАЗОВАНИЕ - Upbringing, Inlightening, Education -> Просвещение от Вильгельма Варкентина - Карим_Хайдаров.
Bourabai Research - Технологии XXI века Bourabai Research Institution