paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-06-02 11:32:49 +02:00
Code Issues Packages Projects Releases Wiki Activity

ipro now shows simple HTML pages

Browse Source 
git-svn-id: trunk@3986 -
This commit is contained in:
mattias 2003-03-30 20:37:15 +00:00
parent bf00013ac6
commit 4ea511b8e8
6 changed files with 190 additions and 143 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
components/codetools/definetemplates.pas
View File

@ -2743,6 +2743,18 @@ begin
,da_DefineRecurse));
MainDir.AddChild(DirTempl);
// components/units
SubDirTempl:=TDefineTemplate.Create('units',
'compiled components for the IDE',
'','units',da_Directory);
SubDirTempl.AddChild(TDefineTemplate.Create('CompiledSrcPath',
ctsSrcPathForCompiledUnits,
ExternalMacroStart+'CompiledSrcPath',
'..'+ds+'synedit;'
+'..'+ds+'codetools'
,da_Define));
DirTempl.AddChild(SubDirTempl);
// components/htmllite
SubDirTempl:=TDefineTemplate.Create('HTMLLite',
'HTMLLite',
@ -2757,6 +2769,12 @@ begin
'','turbopower_ipro',da_Directory);
SubDirTempl.AddChild(TDefineTemplate.Create('IP_LAZARUS',
'Define IP_LAZARUS','IP_LAZARUS','',da_DefineRecurse));
SubDirTempl.AddChild(TDefineTemplate.Create('codetools',
Format(ctsAddsDirToSourcePath,['../codetools']),
ExternalMacroStart+'SrcPath',
'..'+ds+'codetools'
+';'+SrcPath
,da_DefineRecurse));
DirTempl.AddChild(SubDirTempl);
// components/custom

194
components/codetools/memcheck.pas
View File

@ -1,7 +1,8 @@
{
***************************************************************************
* *
* This unit is an altered heaptrc.pp from the fpc sources *
* This unit is a combined and improved heaptrc.pp from the fpc sources *
* It works with fpc 1.0.7 and 1.1. *
* *
***************************************************************************
}
@ -24,6 +25,17 @@ unit MemCheck;
interface
{ define EXTRA to add more
tests :
- keep all memory after release and
check by CRC value if not changed after release
WARNING this needs extremely much memory (PM) }
{off $DEFINE Extra}
procedure MemError;
{ 1.0.x doesn't have good rangechecking for cardinals }
{$ifdef VER1_0}
@ -32,12 +44,6 @@ interface
Procedure DumpHeap;
Procedure MarkHeap;
{ define EXTRA to add more
tests :
- keep all memory after release and
check by CRC value if not changed after release
WARNING this needs extremely much memory (PM) }
type
FillExtraInfoType = procedure(p : pointer);
ExtraInfoStringType = function(p : pointer) : string;
@ -58,8 +64,10 @@ const
tracesize = 8;
{$endif EXTRA}
quicktrace : boolean=true;
{ calls halt() on error by default !! }
HaltOnError : boolean = true;
{ calls halt() on error }
HaltOnError : boolean = false;
{ raise gdb catchable exception on error }
ExceptOnError: boolean = true;
{ set this to true if you suspect that memory
is freed several times }
{$ifdef EXTRA}
@ -153,23 +161,29 @@ var
// StartAddition for CodeTools
procedure CheckHeap;
var p: pointer;
var
p: pointer;
OldQuickTrace: boolean;
begin
writeln('>>> memcheck.pp - CheckHeap');
OldQuickTrace:=QuickTrace;
QuickTrace:=false;
GetMem(p,4);
FreeMem(p);
QuickTrace:=true;
QuickTrace:=OldQuickTrace;
end;
procedure CheckHeap(const txt: ansistring);
var p: pointer;
var
p: pointer;
OldQuickTrace: boolean;
begin
writeln('>>> memcheck.pp - CheckHeap "',txt,'"');
OldQuickTrace:=QuickTrace;
QuickTrace:=false;
GetMem(p,4);
FreeMem(p);
QuickTrace:=true;
QuickTrace:=OldQuickTrace;
end;
const
@ -180,6 +194,7 @@ procedure CheckHeapWrtMemCnt(const txt: ansistring);
var
p: pointer;
StartGetMemCnt, CurGetMemCount, DiffGetMemCount: longint;
OldQuickTrace: boolean;
begin
StartGetMemCnt:=MemCheck_getmem_cnt;
CurGetMemCount:=StartGetMemCnt-HiddenGetMemCnt;
@ -188,10 +203,11 @@ begin
writeln('>>> memcheck.pp - CheckHeap2 "',txt,'" ',
CurGetMemCount,'(',StartGetMemCnt,') +',DiffGetMemCount);
OldQuickTrace:=QuickTrace;
QuickTrace:=false;
GetMem(p,4);
FreeMem(p);
QuickTrace:=true;
QuickTrace:=OldQuickTrace;
// don't count mem counts of this proc
inc(HiddenGetMemCnt,MemCheck_getmem_cnt-StartGetMemCnt);
@ -369,7 +385,6 @@ end;
procedure call_free_stack(pp : pheap_mem_info;var ptext : text);
var
i : longint;
begin
writeln(ptext,'Call trace for block at 0x',
hexstr(longint(pointer(pp)+sizeof(theap_mem_info))
@ -453,7 +468,8 @@ begin
(pp^.sig <> $AAAAAAAA) then
begin
writeln(ptext^,'error in linked list of heap_mem_info');
RunError(204);
// MG: changes for codetools:
MemError;
end;
if pp=p then
is_in_getmem_list:=true;
@ -462,7 +478,8 @@ begin
if i>getmem_cnt-freemem_cnt then begin
writeln(ptext^,'error in linked list of heap_mem_info',
' FreedCnt=',getmem_cnt-freemem_cnt,' RealCnt=',i);
RunError(204);
// MG: changes for codetools:
MemError;
end;
pp:=pp^.previous;
end;
@ -550,12 +567,13 @@ begin
dec(p,sizeof(theap_mem_info)+extra_info_size);
pp:=pheap_mem_info(p);
if not quicktrace and not(is_in_getmem_list(pp)) then
RunError(204);
// MG: changes for codetools:
MemError;
if (pp^.sig=$AAAAAAAA) and not usecrc then
begin
error_in_heap:=true;
dump_already_free(pp,ptext^);
if haltonerror then halt(1);
MemError;
end
else if ((pp^.sig<>$DEADBEEF) or usecrc) and
((pp^.sig<>calculate_sig(pp)) or not usecrc) then
@ -566,7 +584,7 @@ begin
dump_error(pp,error_file);
{$endif EXTRA}
{ don't release anything in this case !! }
if haltonerror then halt(1);
MemError;
exit;
end
else if pp^.size<>size then
@ -576,7 +594,7 @@ begin
{$ifdef EXTRA}
dump_wrong_size(pp,size,error_file);
{$endif EXTRA}
if haltonerror then halt(1);
MemError;
{ don't release anything in this case !! }
exit;
end;
@ -719,7 +737,7 @@ begin
dump_error(pp,error_file);
{$endif EXTRA}
{ don't release anything in this case !! }
if haltonerror then halt(1);
MemError;
exit;
end;
{ Do the real ReAllocMem, but alloc also for the info block }
@ -829,7 +847,8 @@ begin
{$ifdef go32v2}
if cardinal(p)<$1000 then
runerror(216);
// MG: changes for codetools:
MemError;
asm
movl %ebp,get_ebp
leal edata,%eax
@ -961,7 +980,8 @@ begin
begin
writeln(ptext^,'corrupted heap_mem_info');
dump_error(pp,ptext^);
halt(1);
ExceptOnError:=true;
MemError;
end;
end
else
@ -970,7 +990,8 @@ begin
if i>getmem_cnt-freemem_cnt then
begin
writeln(ptext^,'error in linked list of heap_mem_info');
halt(1);
ExceptOnError:=true;
MemError;
end;
end;
i:=0;
@ -989,14 +1010,16 @@ begin
begin
writeln(ptext^,'pointer $',hexstr(longint(p),8),' points into invalid memory block');
dump_error(pp,ptext^);
runerror(204);
// MG: changes for codetools:
MemError;
end;
pp:=pp^.previous;
inc(i);
if i>getmem_cnt then
begin
writeln(ptext^,'error in linked list of heap_mem_info');
halt(1);
ExceptOnError:=true;
MemError;
end;
end;
{$ifdef win32}
@ -1012,14 +1035,16 @@ begin
(MemInfo.Protect <> PAGE_EXECUTE_WRITECOPY)) then
begin
writeln(ptext^,'pointer $',hexstr(longint(p),8),' does not point to valid memory block');
runerror(204);
// MG: changes for codetools:
MemError;
end
else
exit;
{$else not win32}
writeln(ptext^,'pointer $',hexstr(longint(p),8),' does not point to valid memory block');
runerror(204);
// MG: changes for codetools:
MemError;
{$endif not win32}
_exit:
end;
@ -1226,6 +1251,12 @@ Procedure SetExtraInfoString(func : ExtraInfoStringType);
extra_info_string_func:=func;
end;
procedure MemError;
begin
if HaltOnError then Halt(1);
if ExceptOnError then if 0=(1 div ((ord(ExceptOnError) and 1) shr 1)) then ;
end;
Initialization
EntryMemUsed:=System.HeapSize-MemAvail;
MakeCRC32Tbl;
@ -1244,7 +1275,7 @@ finalization
end.
{$endif}
//==============================================================================
{$ifdef VER1_1}
{$goto on}
@ -1283,8 +1314,10 @@ const
useheaptrace : boolean=true;
{ less checking }
quicktrace : boolean=true;
{ calls halt() on error by default !! }
HaltOnError : boolean = true;
{ calls halt() on error }
HaltOnError : boolean = false;
{ raise gdb catchable exception on error }
ExceptOnError: boolean = true;
{ set this to true if you suspect that memory
is freed several times }
{$ifdef EXTRA}
@ -1384,23 +1417,29 @@ var
// StartAddition for CodeTools
procedure CheckHeap;
var p: pointer;
var
p: pointer;
OldQuickTrace: boolean;
begin
writeln('>>> memcheck.pp - CheckHeap');
OldQuickTrace:=QuickTrace;
QuickTrace:=false;
GetMem(p,4);
FreeMem(p);
QuickTrace:=true;
QuickTrace:=OldQuickTrace;
end;
procedure CheckHeap(const txt: ansistring);
var p: pointer;
var
p: pointer;
OldQuickTrace: boolean;
begin
writeln('>>> memcheck.pp - CheckHeap "',txt,'"');
OldQuickTrace:=QuickTrace;
QuickTrace:=false;
GetMem(p,4);
FreeMem(p);
QuickTrace:=true;
QuickTrace:=OldQuickTrace;
end;
const
@ -1411,6 +1450,7 @@ procedure CheckHeapWrtMemCnt(const txt: ansistring);
var
p: pointer;
StartGetMemCnt, CurGetMemCount, DiffGetMemCount: longint;
OldQuickTrace: boolean;
begin
StartGetMemCnt:=MemCheck_getmem_cnt;
CurGetMemCount:=StartGetMemCnt-HiddenGetMemCnt;
@ -1419,10 +1459,11 @@ begin
writeln('>>> memcheck.pp - CheckHeap2 "',txt,'" ',
CurGetMemCount,'(',StartGetMemCnt,') +',DiffGetMemCount);
OldQuickTrace:=QuickTrace;
QuickTrace:=false;
GetMem(p,4);
FreeMem(p);
QuickTrace:=true;
QuickTrace:=OldQuickTrace;
// don't count mem counts of this proc
inc(HiddenGetMemCnt,MemCheck_getmem_cnt-StartGetMemCnt);
@ -1575,7 +1616,7 @@ begin
if assigned(pp^.extra_info) and
(pp^.extra_info^.check=$12345678) and
assigned(pp^.extra_info^.displayproc) then
pp^.extra_info^.displayproc(ptext,@pp^.extra_info^.data);
pp^.extra_info^.displayproc(ptext,@pp^.extra_info^.data);
end;
@ -1659,7 +1700,8 @@ begin
(pp^.sig <>$AAAAAAAA) then
begin
writeln(ptext^,'error in linked list of heap_mem_info');
RunError(204);
// MG: changes for codetools:
MemError;
end;
if pp=p then
is_in_getmem_list:=true;
@ -1668,7 +1710,8 @@ begin
if i>getmem_cnt-freemem_cnt then begin
writeln(ptext^,'error in linked list of heap_mem_info',
' FreedCnt=',getmem_cnt-freemem_cnt,' RealCnt=',i);
RunError(204);
// MG: changes for codetools:
MemError;
end;
pp:=pp^.previous;
end;
@ -1780,36 +1823,40 @@ begin
if not quicktrace then
begin
if not(is_in_getmem_list(pp)) then
RunError(204);
// MG: changes for codetools:
MemError;
end;
if (pp^.sig=$AAAAAAAA) and not usecrc then
begin
error_in_heap:=true;
dump_already_free(pp,ptext^);
if haltonerror then halt(1);
error_in_heap:=true;
dump_already_free(pp,ptext^);
// MG: changes for codetools:
MemError;
end
else if ((pp^.sig<>$DEADBEEF) or usecrc) and
((pp^.sig<>calculate_sig(pp)) or not usecrc) then
begin
error_in_heap:=true;
dump_error(pp,ptext^);
error_in_heap:=true;
dump_error(pp,ptext^);
{$ifdef EXTRA}
dump_error(pp,error_file);
dump_error(pp,error_file);
{$endif EXTRA}
{ don't release anything in this case !! }
if haltonerror then halt(1);
exit;
{ don't release anything in this case !! }
// MG: changes for codetools:
MemError;
exit;
end
else if pp^.size<>size then
begin
error_in_heap:=true;
dump_wrong_size(pp,size,ptext^);
error_in_heap:=true;
dump_wrong_size(pp,size,ptext^);
{$ifdef EXTRA}
dump_wrong_size(pp,size,error_file);
dump_wrong_size(pp,size,error_file);
{$endif EXTRA}
if haltonerror then halt(1);
{ don't release anything in this case !! }
exit;
// MG: changes for codetools:
MemError;
{ don't release anything in this case !! }
exit;
end;
{ save old values }
extra_size:=pp^.extra_info_size;
@ -1957,7 +2004,7 @@ begin
dump_error(pp,error_file);
{$endif EXTRA}
{ don't release anything in this case !! }
if haltonerror then halt(1);
MemError;
exit;
end;
{ save info }
@ -2071,13 +2118,15 @@ label
_exit;
begin
if p=nil then
runerror(204);
// MG: changes for codetools:
MemError;
i:=0;
{$ifdef go32v2}
if cardinal(p)<$1000 then
runerror(216);
// MG: changes for codetools:
MemError;
asm
movl %ebp,get_ebp
leal edata,%eax
@ -2131,7 +2180,8 @@ begin
begin
writeln(ptext^,'corrupted heap_mem_info');
dump_error(pp,ptext^);
halt(1);
ExceptOnError:=true;
MemError;
end;
end
else
@ -2140,7 +2190,8 @@ begin
if i>getmem_cnt-freemem_cnt then
begin
writeln(ptext^,'error in linked list of heap_mem_info');
halt(1);
ExceptOnError:=true;
MemError;
end;
end;
i:=0;
@ -2159,18 +2210,21 @@ begin
begin
writeln(ptext^,'pointer $',hexstr(longint(p),8),' points into invalid memory block');
dump_error(pp,ptext^);
runerror(204);
// MG: changes for codetools:
MemError;
end;
pp:=pp^.previous;
inc(i);
if i>getmem_cnt then
begin
writeln(ptext^,'error in linked list of heap_mem_info');
halt(1);
ExceptOnError:=true;
MemError;
end;
end;
writeln(ptext^,'pointer $',hexstr(longint(p),8),' does not point to valid memory block');
runerror(204);
// MG: changes for codetools:
MemError;
_exit:
end;
@ -2476,6 +2530,11 @@ begin
end;
end;
procedure MemError;
begin
if HaltOnError then Halt(1);
if ExceptOnError then if 0=(1 div ((ord(ExceptOnError) and 1) shr 1)) then ;
end;
Initialization
LoadEnvironment;
@ -2487,9 +2546,14 @@ finalization
TraceExit;
end.
{$endif}
{$endif VER1_1}
{
$Log$
Revision 1.18 2003/03/30 20:37:15 mattias
ipro now shows simple HTML pages
Revision 1.17 2002/12/24 12:52:53 mattias
fixed ReAllocmem of memcheck and added memcheck for fpc 1.1

65
components/turbopower_ipro/iphtml.pas
View File

@ -40,6 +40,7 @@ interface
uses
{$IFDEF IP_LAZARUS}
//MemCheck,
VCLGlobals,
LCLType,
GraphType,
@ -3320,7 +3321,6 @@ end;
procedure SetWordRect(Element: PIpHtmlElement; const Value: TRect);
begin
writeln('SetWordRect A Element=',HexStr(Cardinal(Element),8),' ',Value.Left,',',Value.Top);
Element.WordRect2 := Value;
if Element.ElementType = etObject then begin
if (Value.Left < Value.Right)
@ -3737,7 +3737,7 @@ end;
procedure TIpHtmlNode.Enqueue;
begin
writeln('TIpHtmlNode.Enqueue A ',ClassName);
end;
procedure TIpHtmlNode.EnqueueElement(const Entry: PIpHtmlElement);
@ -4107,9 +4107,7 @@ procedure TIpHtmlNodeMulti.Enqueue;
var
i : Integer;
begin
writeln('TIpHtmlNodeMulti.Enqueue A ',ClassName);
for i := 0 to pred(FChildren.Count) do begin
writeln('TIpHtmlNodeMulti.Enqueue B ',i,'/',FChildren.Count,' ',HexStr(Cardinal(TIpHtmlNode(FChildren[i])),8),' ',TIpHtmlNode(FChildren[i]).ClassName);
TIpHtmlNode(FChildren[i]).Enqueue;
end;
end;
@ -4177,14 +4175,12 @@ var
X, Y : Integer;
P : TPoint;
begin
writeln('TIpHtmlNodeBODY.Render A ',ClassName);
if ScaleBitmaps then begin {!!.10}
Owner.Target.Brush.Color := clWhite;
Owner.Target.FillRect(Owner.ClientRect);
end else begin
if BackGround = '' then begin
Owner.Target.Brush.Color := clWhite;
writeln('TIpHtmlNodeBODY.Render B BackGround=',BackGround,' ',Owner.ClientRect.Left,',',Owner.ClientRect.Top,',',Owner.ClientRect.Right,',',Owner.ClientRect.Bottom,' ',HexStr(Cardinal(Owner.Target.Handle),8));
Owner.Target.FillRect(Owner.ClientRect);
end;
if BGColor <> $FFFFFFFF then begin
@ -4294,7 +4290,6 @@ var
i : Integer;
begin
for i := 0 to pred(PropACache.Count) do begin
writeln('TIpHtml.ClearCache ',i,'/',PropACache.Count,' ',HexStr(Cardinal(TIpHtmlPropA(PropACache[i])),8));
TIpHtmlPropA(PropACache[i]).Free;
end;
PropACache.Free;
@ -7244,6 +7239,7 @@ end;
procedure TIpHtml.ParseFrameSet(Parent : TIpHtmlNode;
const EndTokens: TIpHtmlTokenSet);
begin
writeln('TIpHtml.ParseFrameSet A');
FHasFrames := True;
while CurToken = IpHtmlTagFRAMESET do begin
CurFrameSet := TIpHtmlNodeFRAMESET.Create(Parent);
@ -7283,10 +7279,7 @@ begin
end;
{lead token is optional}
if CurToken = IpHtmlTagBODY then begin
writeln('TIpHtml.ParseBody A ',TIpHtmlNodeMulti(HtmlNode).ChildCount);
TIpHtmlNodeBODY.Create(Parent);
writeln('TIpHtml.ParseBody B ',TIpHtmlNodeMulti(HtmlNode).ChildCount,
' ',TIpHtmlNodeMulti(HtmlNode).ChildNode[0].ClassName,' ',HexStr(Cardinal(TIpHtmlNodeMulti(HtmlNode).ChildNode[0]),8));
with Body do begin
BgColor := ColorFromString(FindAttribute('BGCOLOR'));
Text := ColorFromString(FindAttribute('TEXT'));
@ -7825,15 +7818,12 @@ procedure TIpHtml.RequestImageNodes(Node : TIpHtmlNode);
var
i : Integer;
begin
writeln('TIpHtml.RequestImageNodes ',Node.ClassName);
if Node is TIpHtmlNodeIMG then begin
if TIpHtmlNodeIMG(Node).FPicture = nil then
TIpHtmlNodeIMG(Node).LoadImage;
end;
writeln('TIpHtml.RequestImageNodes B ',Node.ClassName,' ',Node is TIpHtmlNodeMulti);
if Node is TIpHtmlNodeMulti then
for i := 0 to pred(TIpHtmlNodeMulti(Node).ChildCount) do begin
writeln('TIpHtml.RequestImageNodes C ',i,' ',HexStr(Cardinal(TIpHtmlNodeMulti(Node).ChildNode[i]),8));
RequestImageNodes(TIpHtmlNodeMulti(Node).ChildNode[i]);
end;
end;
@ -7843,8 +7833,6 @@ procedure TIpHtml.Render(TargetCanvas: TCanvas; TargetPageRect : TRect;
var
i : Integer;
begin
writeln('TIpHtml.Render A ',ClassName,' DoneLoading=',DoneLoading,' ',TIpHtmlNodeMulti(HtmlNode).ChildCount,
' ',TIpHtmlNodeMulti(HtmlNode).ChildNode[0].ClassName,' ',HexStr(Cardinal(TIpHtmlNodeMulti(HtmlNode).ChildNode[0]),8));
ClientRect.TopLeft := TopLeft; {Point(0, 0);} {!!.10}
ClientRect.Right := TargetPageRect.Right - TargetPageRect.Left;
ClientRect.Bottom := TargetPageRect.Bottom - TargetPageRect.Top;
@ -7884,16 +7872,11 @@ begin
FTarget := TargetCanvas;
end;
ClearRectList;
writeln('TIpHtml.Render C2 ',TIpHtmlNodeMulti(HtmlNode).ChildCount,
' ',TIpHtmlNodeMulti(HtmlNode).ChildNode[0].ClassName,' ',HexStr(Cardinal(TIpHtmlNodeMulti(HtmlNode).ChildNode[0]),8));
if FHtml <> nil then
FHtml.Render(DefaultProps);
writeln('TIpHtml.Render D ',TIpHtmlNodeMulti(HtmlNode).ChildCount,
' ',TIpHtmlNodeMulti(HtmlNode).ChildNode[0].ClassName,' ',HexStr(Cardinal(TIpHtmlNodeMulti(HtmlNode).ChildNode[0]),8));
for i := 0 to pred(ControlList.Count) do
TIpHtmlNode(ControlList[i]).HideUnmarkedControl;
writeln('TIpHtml.Render E ',TIpHtmlNodeMulti(HtmlNode).ChildCount);
PaintSelection;
if UsePaintBuffer then
TargetCanvas.CopyRect(ClientRect, PaintBuffer, ClientRect)
@ -7902,10 +7885,8 @@ begin
PaintBuffer := PaintBufferBitmap.Canvas
else
PaintBuffer := nil;
writeln('TIpHtml.Render F ',TIpHtmlNodeMulti(HtmlNode).ChildCount);
StartGifPaint(TargetCanvas);
{Request all non-visible images}
writeln('TIpHtml.Render G ',TIpHtmlNodeMulti(HtmlNode).ChildCount);
RequestImageNodes(HtmlNode);
end;
@ -7975,7 +7956,6 @@ var
DefPageRect : TRect;
Min, Max, W, H : Integer;
begin
writeln('TIpHtml.GetPageRect A ',ClassName,' ',Width,',',Height,' DoneLoading=',DoneLoading);
if not DoneLoading then begin
{$IFDEF IP_LAZARUS}
SetRectEmpty(Result);
@ -8010,7 +7990,6 @@ writeln('TIpHtml.GetPageRect A ',ClassName,' ',Width,',',Height,' DoneLoading=',
end;
Result := FPageRect;
DoneLoading := True;
writeln('TIpHtml.GetPageRect B ',ClassName,' ',Result.Left,',',Result.Top,',',Result.Right,',',Result.Bottom);
end;
procedure TIpHtml.InvalidateSize;
@ -8479,7 +8458,6 @@ var
Ch : AnsiChar;
ImplicitLF: Boolean; {!!.10}
begin
writeln('TIpHtmlNodeText.BuildWordList A PropsR.Preformatted=',PropsR.Preformatted);
First := True;
ImplicitLF := False; {!!.10}
if PropsR.Preformatted then begin
@ -8545,7 +8523,6 @@ writeln('TIpHtmlNodeText.BuildWordList A PropsR.Preformatted=',PropsR.Preformatt
end;
end else begin
l := length(EscapedText);
writeln('TIpHtmlNodeText.BuildWordList B l=',l,' EscapedText="',EscapedText,'"');
if l > 0 then begin
Getmem(B, l + 1);
try
@ -8555,14 +8532,12 @@ writeln('TIpHtmlNodeText.BuildWordList B l=',l,' EscapedText="',EscapedText,'"')
case N^ of
LF :
begin
writeln('TIpHtmlNodeText.BuildWordList C LF');
EnqueueElement(Owner.HardLF);
inc(N);
end;
' ' :
begin
if not ElementQueueIsEmpty then begin {!!.10}
writeln('TIpHtmlNodeText.BuildWordList C space Owner=',Owner.ClassName);
NewEntry := Owner.NewElement(etWord, Self);
NewEntry.AnsiWord := ' ';
NewEntry.IsBlank := 1;
@ -8571,14 +8546,12 @@ writeln('TIpHtmlNodeText.BuildWordList C space Owner=',Owner.ClassName);
else
NewEntry.Props := nil;
EnqueueElement(NewEntry);
writeln('TIpHtmlNodeText.BuildWordList C2 NewEntry.WordRect2=',NewEntry.WordRect2.Left,',',NewEntry.WordRect2.Top);
First := False;
end; {!!.10}
inc(N);
end;
else
begin
writeln('TIpHtmlNodeText.BuildWordList C char');
N2 := N;
while not (N2^ in [#0, ' ', LF]) do
inc(N2);
@ -8809,7 +8782,6 @@ begin
for i := 0 to pred(ElementQueue.Count) do begin
CurWord := PIpHtmlElement(ElementQueue[i]);
writeln('TIpHtmlNodeBlock.RenderQueue A ',ClassName,' ',i,'/',ElementQueue.Count);
if (CurWord.Props <> nil) and (CurWord.Props <> LastProp) then begin
@ -8834,18 +8806,13 @@ writeln('TIpHtmlNodeBlock.RenderQueue A ',ClassName,' ',i,'/',ElementQueue.Count
Owner.Target.Font.EndUpdate;
{$ENDIF}
LastProp := CurWord.Props;
writeln('TIpHtmlNodeBlock.RenderQueue B Font.Name="',Owner.Target.Font.Name,'" Size=',Owner.Target.Font.Size);
end;
writeln('TIpHtmlNodeBlock.RenderQueue C CurWord.WordRect2=',CurWord.WordRect2.Left,',',CurWord.WordRect2.Top,',',CurWord.WordRect2.Right,',',CurWord.WordRect2.Bottom,
' Owner.PageViewRect=',Owner.PageViewRect.Left,',',Owner.PageViewRect.Top,',',Owner.PageViewRect.Right,',',Owner.PageViewRect.Bottom,
' Intersect=',IntersectRect(R, CurWord.WordRect2, Owner.PageViewRect));
if IntersectRect(R, CurWord.WordRect2, Owner.PageViewRect) then
case CurWord.ElementType of
etWord :
begin
P := Owner.PagePtToScreen(CurWord.WordRect2.TopLeft);
writeln('TIpHtmlNodeBlock.RenderQueue D etWord CurWord.AnsiWord="',CurWord.AnsiWord,'" P=',P.x,',',P.y);
Owner.Target.Brush.Style := bsClear;
Owner.Target.TextOut(P.x, P.y, NoBreakToSpace(CurWord.AnsiWord));
Owner.AddRect(CurWord.WordRect2, CurWord, Self);
@ -8879,15 +8846,12 @@ end;
procedure TIpHtmlNodeBlock.Render(
const RenderProps: TIpHtmlProps);
begin
writeln('TIpHtmlNodeBlock.Render A ',ClassName);
if not RenderProps.IsEqualTo(Props) then begin
SetProps(RenderProps);
Props.Assign(RenderProps);
end;
writeln('TIpHtmlNodeBlock.Render C ElementQueue.Count=',ElementQueue.Count);
if ElementQueue.Count = 0 then
Enqueue;
writeln('TIpHtmlNodeBlock.Render D ElementQueue.Count=',ElementQueue.Count);
RenderQueue;
end;
@ -9188,7 +9152,6 @@ end;
function TIpHtmlNodeBlock.GetHeight(const RenderProps: TIpHtmlProps;
const Width: Integer): Integer;
begin
writeln('TIpHtmlNodeBlock.GetHeight A ',ClassName);
if LastW = Width then begin
Result := LastH;
exit;
@ -9203,7 +9166,6 @@ end;
procedure TIpHtmlNodeBlock.Layout(const RenderProps: TIpHtmlProps;
const TargetRect: TRect);
begin
writeln('TIpHtmlNodeBlock.Layout A');
if EqualRect(TargetRect, PageRect) then exit;
if not RenderProps.IsEqualTo(Props) then begin
SetProps(RenderProps);
@ -9223,7 +9185,6 @@ var
CurElement : PIpHtmlElement;
R : TRect;
begin
writeln('TIpHtmlNodeBlock.RelocateQueue A');
OffsetRect(FPageRect, dx, dy);
for i := 0 to pred(ElementQueue.Count) do begin
CurElement := PIpHtmlElement(ElementQueue[i]);
@ -9620,7 +9581,6 @@ var
*)
begin
writeln('TIpHtmlNodeBlock.LayoutQueue A');
if ElementQueue.Count = 0 then exit;
{DumpQueue;} {debug}
LeftQueue := nil;
@ -13796,9 +13756,10 @@ var
i : Integer;
begin
for i := 0 to FChildren.Count - 1 do
if TIpHtmlNode(FChildren[i]) is TIpHtmlNodeBody then
if TIpHtmlNode(FChildren[i]) is TIpHtmlNodeBody then begin
TIpHtmlNodeBody(FChildren[i]).CalcMinMaxWidth(RenderProps,
Min, Max);
end;
end;
function TIpHtmlNodeHtml.GetHeight(const RenderProps: TIpHtmlProps;
@ -13808,9 +13769,10 @@ var
begin
Result := 0;
for i := 0 to FChildren.Count - 1 do
if TIpHtmlNode(FChildren[i]) is TIpHtmlNodeBody then
if TIpHtmlNode(FChildren[i]) is TIpHtmlNodeBody then begin
Result := TIpHtmlNodeBody(FChildren[i]).
GetHeight(RenderProps, Width);
end;
end;
{Begin !!.12}
@ -13842,7 +13804,6 @@ procedure TIpHtmlNodeHtml.Render(const RenderProps: TIpHtmlProps);
var
i : Integer;
begin
writeln('TIpHtmlNodeHtml.Render A ',ClassName);
for i := 0 to FChildren.Count - 1 do
if TIpHtmlNode(FChildren[i]) is TIpHtmlNodeBody then
TIpHtmlNodeBody(FChildren[i]).
@ -16400,8 +16361,9 @@ begin
Parent := HyperPanel;
Anchor := Html.AnchorList[i];
end;
for i := 0 to pred(Html.ControlList.Count) do
for i := 0 to pred(Html.ControlList.Count) do begin
TIpHtmlNode(Html.ControlList[i]).CreateControl(HyperPanel);
end;
HyperPanel.Hyper := Html;
end;
end;
@ -16846,7 +16808,6 @@ begin
RelURL := copy(HRef, 2, length(HRef) - 1);
BaseURL := '';
end else begin
writeln('TIpHtmlCustomPanel.InternalOpenURL A ');
if MasterFrame <> nil then begin
if Assigned(FDataProvider) then
URL := FDataProvider.BuildURL(MasterFrame.Html.CURURL, HRef)
@ -16855,7 +16816,6 @@ writeln('TIpHtmlCustomPanel.InternalOpenURL A ');
end
else
URL := HRef;
writeln('TIpHtmlCustomPanel.InternalOpenURL B URL=',URL);
P := CharPos('#', URL);
if P = 0 then begin
RelURL := '';
@ -16865,7 +16825,6 @@ writeln('TIpHtmlCustomPanel.InternalOpenURL B URL=',URL);
RelURL := copy(URL, P + 1, length(URL));
end;
end;
writeln('TIpHtmlCustomPanel.InternalOpenURL C ',BaseURL);
if BaseURL <> '' then begin
if VisitedList.IndexOf(BaseURL) = -1 then
VisitedList.Add(BaseURL);
@ -16902,16 +16861,13 @@ writeln('TIpHtmlCustomPanel.InternalOpenURL C ',BaseURL);
TargetFrame.OpenURL(BaseURL, False);
end;
end;
writeln('TIpHtmlCustomPanel.InternalOpenURL D ');
if RelURL <> '' then
MasterFrame.MakeAnchorVisible(RelURL)
else
if MasterFrame <> nil then {!!.02}
MasterFrame.Home;
writeln('TIpHtmlCustomPanel.InternalOpenURL E ');
if assigned(FDocumentOpen) then {!!.10}
FDocumentOpen(Self); {!!.10}
writeln('TIpHtmlCustomPanel.InternalOpenURL END ');
end;
procedure TIpHtmlCustomPanel.HotClick(Sender: TObject);
@ -17592,6 +17548,9 @@ initialization
InitScrollProcs;
{
$Log$
Revision 1.5 2003/03/30 20:37:15 mattias
ipro now shows simple HTML pages
Revision 1.4 2003/03/29 23:52:25 mattias
IpHtmlPanel can show simple HTML pages, but there are mem bugs

39
ide/outputfilter.pas
View File

@ -148,11 +148,9 @@ var
begin
Clear;
TheProcess.Execute;
fCurrentDirectory:=TheProcess.CurrentDirectory;
fCurrentDirectory:=TrimFilename(TheProcess.CurrentDirectory);
if fCurrentDirectory='' then fCurrentDirectory:=GetCurrentDir;
if (fCurrentDirectory<>'')
and (fCurrentDirectory[length(fCurrentDirectory)]<>PathDelim) then
fCurrentDirectory:=fCurrentDirectory+PathDelim;
fCurrentDirectory:=AppendPathDelim(fCurrentDirectory);
SetLength(Buf,BufSize);
OutputLine:='';
@ -234,7 +232,7 @@ begin
i:=length('Compiling ');
if (length(s)>=i+2) and (s[i+1]='.') and (s[i+2]=PathDelim) then
inc(i,2);
fCompilingHistory.Add(copy(s,i+1,length(s)-i));
fCompilingHistory.Add(TrimFilename(copy(s,i+1,length(s)-i)));
exit;
end;
if ('Assembling '=copy(s,1,length('Assembling ')))
@ -341,17 +339,22 @@ begin
SkipMessage:=false;
// beautify compiler message
// the compiler always gives short filenames, even if it has gone into a
// the compiler always gives short filenames, even if it went into a
// subdirectory
// -> prepend the current subdirectory
Msg:=s;
if (fCompilingHistory<>nil) then begin
Filename:=copy(Msg,1,FilenameEndPos);
Filename:=TrimFilename(copy(Msg,1,FilenameEndPos));
if not FilenameIsAbsolute(Filename) then begin
// filename is relative
// the compiler writes a line compiling ./subdir/unit.pas
// and then writes the messages without any path
// -> prepend this subdirectory
i:=fCompilingHistory.Count-1;
while (i>=0) do begin
j:=length(fCompilingHistory[i])-FilenameEndPos;
if copy(fCompilingHistory[i],j+1,FilenameEndPos)=Filename then
j:=length(fCompilingHistory[i])-length(Filename);
if CompareFilenames(
copy(fCompilingHistory[i],j+1,length(Filename)),Filename)=0 then
begin
Msg:=copy(fCompilingHistory[i],1,j)+Msg;
inc(FilenameEndPos,j);
@ -360,7 +363,7 @@ begin
dec(i);
end;
if i<0 then begin
// this file is not a compiled pascal soure
// this file is not a compiled pascal source
// -> search for include files
Filename:=SearchIncludeFile(Filename);
Msg:=Filename+copy(Msg,FileNameEndPos+1,length(Msg)-FileNameEndPos);
@ -373,7 +376,8 @@ begin
if (ofoMakeFilenamesAbsolute in Options) then begin
Filename:=copy(Msg,1,FilenameEndPos);
if not FilenameIsAbsolute(Filename) then begin
Msg:=fCurrentDirectory+Msg;
Msg:=TrimFilename(AppendPathDelim(fCurrentDirectory)+Filename)
+copy(Msg,FilenameEndPos+1,length(Msg)-FilenameEndPos);
end;
end;
@ -531,12 +535,13 @@ begin
// try every compiled pascal source
for p:=fCompilingHistory.Count-1 downto 0 do begin
RelativeDir:=AppendPathDelim(ExtractFilePath(fCompilingHistory[p]));
FullDir:=AppendPathDelim(ExpandFilename(fCurrentDirectory+RelativeDir));
FullDir:=CleanAndExpandDirectory(
AppendPathDelim(fCurrentDirectory)+RelativeDir);
if SearchedDirectories.IndexOf(FullDir)>=0 then continue;
// new directory start a search
if FileExists(FullDir+ShortIncFilename) then begin
// file found in search dir
Result:=RelativeDir+ShortIncFilename;
Result:=CleanAndExpandFilename(RelativeDir+ShortIncFilename);
exit;
end;
if Assigned(OnGetIncludePath) then begin
@ -545,7 +550,8 @@ begin
Result:=SearchFileInPath(ShortIncFilename,FullDir,IncludePath,';',[]);
if Result<>'' then begin
if LeftStr(Result,length(fCurrentDirectory))=fCurrentDirectory then
Result:=RightStr(Result,length(Result)-length(fCurrentDirectory));
Result:=TrimFilename(
RightStr(Result,length(Result)-length(fCurrentDirectory)));
exit;
end;
end;
@ -610,10 +616,7 @@ begin
if (fMakeDirHistory=nil) then fMakeDirHistory:=TStringList.Create;
fMakeDirHistory.Add(fCurrentDirectory);
end;
fCurrentDirectory:=copy(s,i,length(s)-i);
if (fCurrentDirectory<>'')
and (fCurrentDirectory[length(fCurrentDirectory)]<>PathDelim) then
fCurrentDirectory:=fCurrentDirectory+PathDelim;
fCurrentDirectory:=AppendPathDelim(copy(s,i,length(s)-i));
Result:=true;
exit;
end;

15
lcl/include/filectrl.inc
View File

@ -787,24 +787,24 @@ var
begin
//writeln('[SearchFileInPath] Filename="',Filename,'" BasePath="',BasePath,'" SearchPath="',SearchPath,'" Delimiter="',Delimiter,'"');
if (Filename='') then begin
Result:=Filename;
Result:='';
exit;
end;
// check if filename absolute
if FilenameIsAbsolute(Filename) then begin
if FileExists(Filename) then begin
Result:=ExpandFilename(Filename);
Result:=CleanAndExpandFilename(Filename);
exit;
end else begin
Result:='';
exit;
end;
end;
Base:=ExpandFilename(AppendPathDelim(BasePath));
Base:=CleanAndExpandDirectory(BasePath);
// search in current directory
if (not (sffDontSearchInBasePath in Flags))
and FileExists(Base+Filename) then begin
Result:=Base+Filename;
Result:=CleanAndExpandFilename(Base+Filename);
exit;
end;
// search in search path
@ -813,11 +813,11 @@ begin
while StartPos<=l do begin
p:=StartPos;
while (p<=l) and (pos(SearchPath[p],Delimiter)<1) do inc(p);
CurPath:=Trim(copy(SearchPath,StartPos,p-StartPos));
CurPath:=TrimFilename(copy(SearchPath,StartPos,p-StartPos));
if CurPath<>'' then begin
if not FilenameIsAbsolute(CurPath) then
CurPath:=Base+CurPath;
Result:=ExpandFilename(AppendPathDelim(CurPath)+Filename);
Result:=CleanAndExpandFilename(AppendPathDelim(CurPath)+Filename);
if FileExists(Result) then exit;
end;
StartPos:=p+1;
@ -850,6 +850,9 @@ end;
{
$Log$
Revision 1.22 2003/03/30 20:37:15 mattias
ipro now shows simple HTML pages
Revision 1.21 2003/03/29 21:41:19 mattias
fixed path delimiters for environment directories

2
lcl/lclmemmanager.pas
View File

@ -226,7 +226,7 @@ begin
GetMem(FCurItem,FCurSize);
if FItems=nil then FItems:=TList.Create;
FItems.Add(FCurItem);
FEndItem:=Pointer(integer(FCurSize)+FCurSize);
FEndItem:=Pointer(integer(FCurItem)+FCurSize);
end;
Result:=FCurItem;
inc(integer(FCurItem),FItemSize);