paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-08-05 21:45:55 +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)); ,da_DefineRecurse));
MainDir.AddChild(DirTempl); 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 // components/htmllite
SubDirTempl:=TDefineTemplate.Create('HTMLLite', SubDirTempl:=TDefineTemplate.Create('HTMLLite',
'HTMLLite', 'HTMLLite',
@ -2757,6 +2769,12 @@ begin
'','turbopower_ipro',da_Directory); '','turbopower_ipro',da_Directory);
SubDirTempl.AddChild(TDefineTemplate.Create('IP_LAZARUS', SubDirTempl.AddChild(TDefineTemplate.Create('IP_LAZARUS',
'Define IP_LAZARUS','IP_LAZARUS','',da_DefineRecurse)); '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); DirTempl.AddChild(SubDirTempl);
// components/custom // 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 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 } { 1.0.x doesn't have good rangechecking for cardinals }
{$ifdef VER1_0} {$ifdef VER1_0}
@ -32,12 +44,6 @@ interface
Procedure DumpHeap; Procedure DumpHeap;
Procedure MarkHeap; 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 type
FillExtraInfoType = procedure(p : pointer); FillExtraInfoType = procedure(p : pointer);
ExtraInfoStringType = function(p : pointer) : string; ExtraInfoStringType = function(p : pointer) : string;
@ -58,8 +64,10 @@ const
tracesize = 8; tracesize = 8;
{$endif EXTRA} {$endif EXTRA}
quicktrace : boolean=true; quicktrace : boolean=true;
{ calls halt() on error by default !! } { calls halt() on error }
HaltOnError : boolean = true; HaltOnError : boolean = false;
{ raise gdb catchable exception on error }
ExceptOnError: boolean = true;
{ set this to true if you suspect that memory { set this to true if you suspect that memory
is freed several times } is freed several times }
{$ifdef EXTRA} {$ifdef EXTRA}
@ -153,23 +161,29 @@ var
// StartAddition for CodeTools // StartAddition for CodeTools
procedure CheckHeap; procedure CheckHeap;
var p: pointer; var
p: pointer;
OldQuickTrace: boolean;
begin begin
writeln('>>> memcheck.pp - CheckHeap'); writeln('>>> memcheck.pp - CheckHeap');
OldQuickTrace:=QuickTrace;
QuickTrace:=false; QuickTrace:=false;
GetMem(p,4); GetMem(p,4);
FreeMem(p); FreeMem(p);
QuickTrace:=true; QuickTrace:=OldQuickTrace;
end; end;
procedure CheckHeap(const txt: ansistring); procedure CheckHeap(const txt: ansistring);
var p: pointer; var
p: pointer;
OldQuickTrace: boolean;
begin begin
writeln('>>> memcheck.pp - CheckHeap "',txt,'"'); writeln('>>> memcheck.pp - CheckHeap "',txt,'"');
OldQuickTrace:=QuickTrace;
QuickTrace:=false; QuickTrace:=false;
GetMem(p,4); GetMem(p,4);
FreeMem(p); FreeMem(p);
QuickTrace:=true; QuickTrace:=OldQuickTrace;
end; end;
const const
@ -180,6 +194,7 @@ procedure CheckHeapWrtMemCnt(const txt: ansistring);
var var
p: pointer; p: pointer;
StartGetMemCnt, CurGetMemCount, DiffGetMemCount: longint; StartGetMemCnt, CurGetMemCount, DiffGetMemCount: longint;
OldQuickTrace: boolean;
begin begin
StartGetMemCnt:=MemCheck_getmem_cnt; StartGetMemCnt:=MemCheck_getmem_cnt;
CurGetMemCount:=StartGetMemCnt-HiddenGetMemCnt; CurGetMemCount:=StartGetMemCnt-HiddenGetMemCnt;
@ -188,10 +203,11 @@ begin
writeln('>>> memcheck.pp - CheckHeap2 "',txt,'" ', writeln('>>> memcheck.pp - CheckHeap2 "',txt,'" ',
CurGetMemCount,'(',StartGetMemCnt,') +',DiffGetMemCount); CurGetMemCount,'(',StartGetMemCnt,') +',DiffGetMemCount);
OldQuickTrace:=QuickTrace;
QuickTrace:=false; QuickTrace:=false;
GetMem(p,4); GetMem(p,4);
FreeMem(p); FreeMem(p);
QuickTrace:=true; QuickTrace:=OldQuickTrace;
// don't count mem counts of this proc // don't count mem counts of this proc
inc(HiddenGetMemCnt,MemCheck_getmem_cnt-StartGetMemCnt); inc(HiddenGetMemCnt,MemCheck_getmem_cnt-StartGetMemCnt);
@ -369,7 +385,6 @@ end;
procedure call_free_stack(pp : pheap_mem_info;var ptext : text); procedure call_free_stack(pp : pheap_mem_info;var ptext : text);
var var
i : longint; i : longint;
begin begin
writeln(ptext,'Call trace for block at 0x', writeln(ptext,'Call trace for block at 0x',
hexstr(longint(pointer(pp)+sizeof(theap_mem_info)) hexstr(longint(pointer(pp)+sizeof(theap_mem_info))
@ -453,7 +468,8 @@ begin
(pp^.sig <> $AAAAAAAA) then (pp^.sig <> $AAAAAAAA) then
begin begin
writeln(ptext^,'error in linked list of heap_mem_info'); writeln(ptext^,'error in linked list of heap_mem_info');
RunError(204); // MG: changes for codetools:
MemError;
end; end;
if pp=p then if pp=p then
is_in_getmem_list:=true; is_in_getmem_list:=true;
@ -462,7 +478,8 @@ begin
if i>getmem_cnt-freemem_cnt then begin if i>getmem_cnt-freemem_cnt then begin
writeln(ptext^,'error in linked list of heap_mem_info', writeln(ptext^,'error in linked list of heap_mem_info',
' FreedCnt=',getmem_cnt-freemem_cnt,' RealCnt=',i); ' FreedCnt=',getmem_cnt-freemem_cnt,' RealCnt=',i);
RunError(204); // MG: changes for codetools:
MemError;
end; end;
pp:=pp^.previous; pp:=pp^.previous;
end; end;
@ -550,12 +567,13 @@ begin
dec(p,sizeof(theap_mem_info)+extra_info_size); dec(p,sizeof(theap_mem_info)+extra_info_size);
pp:=pheap_mem_info(p); pp:=pheap_mem_info(p);
if not quicktrace and not(is_in_getmem_list(pp)) then 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 if (pp^.sig=$AAAAAAAA) and not usecrc then
begin begin
error_in_heap:=true; error_in_heap:=true;
dump_already_free(pp,ptext^); dump_already_free(pp,ptext^);
if haltonerror then halt(1); MemError;
end end
else if ((pp^.sig<>$DEADBEEF) or usecrc) and else if ((pp^.sig<>$DEADBEEF) or usecrc) and
((pp^.sig<>calculate_sig(pp)) or not usecrc) then ((pp^.sig<>calculate_sig(pp)) or not usecrc) then
@ -566,7 +584,7 @@ begin
dump_error(pp,error_file); dump_error(pp,error_file);
{$endif EXTRA} {$endif EXTRA}
{ don't release anything in this case !! } { don't release anything in this case !! }
if haltonerror then halt(1); MemError;
exit; exit;
end end
else if pp^.size<>size then else if pp^.size<>size then
@ -576,7 +594,7 @@ begin
{$ifdef EXTRA} {$ifdef EXTRA}
dump_wrong_size(pp,size,error_file); dump_wrong_size(pp,size,error_file);
{$endif EXTRA} {$endif EXTRA}
if haltonerror then halt(1); MemError;
{ don't release anything in this case !! } { don't release anything in this case !! }
exit; exit;
end; end;
@ -719,7 +737,7 @@ begin
dump_error(pp,error_file); dump_error(pp,error_file);
{$endif EXTRA} {$endif EXTRA}
{ don't release anything in this case !! } { don't release anything in this case !! }
if haltonerror then halt(1); MemError;
exit; exit;
end; end;
{ Do the real ReAllocMem, but alloc also for the info block } { Do the real ReAllocMem, but alloc also for the info block }
@ -829,7 +847,8 @@ begin
{$ifdef go32v2} {$ifdef go32v2}
if cardinal(p)<$1000 then if cardinal(p)<$1000 then
runerror(216); // MG: changes for codetools:
MemError;
asm asm
movl %ebp,get_ebp movl %ebp,get_ebp
leal edata,%eax leal edata,%eax
@ -961,7 +980,8 @@ begin
begin begin
writeln(ptext^,'corrupted heap_mem_info'); writeln(ptext^,'corrupted heap_mem_info');
dump_error(pp,ptext^); dump_error(pp,ptext^);
halt(1); ExceptOnError:=true;
MemError;
end; end;
end end
else else
@ -970,7 +990,8 @@ begin
if i>getmem_cnt-freemem_cnt then if i>getmem_cnt-freemem_cnt then
begin begin
writeln(ptext^,'error in linked list of heap_mem_info'); writeln(ptext^,'error in linked list of heap_mem_info');
halt(1); ExceptOnError:=true;
MemError;
end; end;
end; end;
i:=0; i:=0;
@ -989,14 +1010,16 @@ begin
begin begin
writeln(ptext^,'pointer $',hexstr(longint(p),8),' points into invalid memory block'); writeln(ptext^,'pointer $',hexstr(longint(p),8),' points into invalid memory block');
dump_error(pp,ptext^); dump_error(pp,ptext^);
runerror(204); // MG: changes for codetools:
MemError;
end; end;
pp:=pp^.previous; pp:=pp^.previous;
inc(i); inc(i);
if i>getmem_cnt then if i>getmem_cnt then
begin begin
writeln(ptext^,'error in linked list of heap_mem_info'); writeln(ptext^,'error in linked list of heap_mem_info');
halt(1); ExceptOnError:=true;
MemError;
end; end;
end; end;
{$ifdef win32} {$ifdef win32}
@ -1012,14 +1035,16 @@ begin
(MemInfo.Protect <> PAGE_EXECUTE_WRITECOPY)) then (MemInfo.Protect <> PAGE_EXECUTE_WRITECOPY)) then
begin begin
writeln(ptext^,'pointer $',hexstr(longint(p),8),' does not point to valid memory block'); writeln(ptext^,'pointer $',hexstr(longint(p),8),' does not point to valid memory block');
runerror(204); // MG: changes for codetools:
MemError;
end end
else else
exit; exit;
{$else not win32} {$else not win32}
writeln(ptext^,'pointer $',hexstr(longint(p),8),' does not point to valid memory block'); writeln(ptext^,'pointer $',hexstr(longint(p),8),' does not point to valid memory block');
runerror(204); // MG: changes for codetools:
MemError;
{$endif not win32} {$endif not win32}
_exit: _exit:
end; end;
@ -1226,6 +1251,12 @@ Procedure SetExtraInfoString(func : ExtraInfoStringType);
extra_info_string_func:=func; extra_info_string_func:=func;
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 Initialization
EntryMemUsed:=System.HeapSize-MemAvail; EntryMemUsed:=System.HeapSize-MemAvail;
MakeCRC32Tbl; MakeCRC32Tbl;
@ -1244,7 +1275,7 @@ finalization
end. end.
{$endif} {$endif}
//==============================================================================
{$ifdef VER1_1} {$ifdef VER1_1}
{$goto on} {$goto on}
@ -1283,8 +1314,10 @@ const
useheaptrace : boolean=true; useheaptrace : boolean=true;
{ less checking } { less checking }
quicktrace : boolean=true; quicktrace : boolean=true;
{ calls halt() on error by default !! } { calls halt() on error }
HaltOnError : boolean = true; HaltOnError : boolean = false;
{ raise gdb catchable exception on error }
ExceptOnError: boolean = true;
{ set this to true if you suspect that memory { set this to true if you suspect that memory
is freed several times } is freed several times }
{$ifdef EXTRA} {$ifdef EXTRA}
@ -1384,23 +1417,29 @@ var
// StartAddition for CodeTools // StartAddition for CodeTools
procedure CheckHeap; procedure CheckHeap;
var p: pointer; var
p: pointer;
OldQuickTrace: boolean;
begin begin
writeln('>>> memcheck.pp - CheckHeap'); writeln('>>> memcheck.pp - CheckHeap');
OldQuickTrace:=QuickTrace;
QuickTrace:=false; QuickTrace:=false;
GetMem(p,4); GetMem(p,4);
FreeMem(p); FreeMem(p);
QuickTrace:=true; QuickTrace:=OldQuickTrace;
end; end;
procedure CheckHeap(const txt: ansistring); procedure CheckHeap(const txt: ansistring);
var p: pointer; var
p: pointer;
OldQuickTrace: boolean;
begin begin
writeln('>>> memcheck.pp - CheckHeap "',txt,'"'); writeln('>>> memcheck.pp - CheckHeap "',txt,'"');
OldQuickTrace:=QuickTrace;
QuickTrace:=false; QuickTrace:=false;
GetMem(p,4); GetMem(p,4);
FreeMem(p); FreeMem(p);
QuickTrace:=true; QuickTrace:=OldQuickTrace;
end; end;
const const
@ -1411,6 +1450,7 @@ procedure CheckHeapWrtMemCnt(const txt: ansistring);
var var
p: pointer; p: pointer;
StartGetMemCnt, CurGetMemCount, DiffGetMemCount: longint; StartGetMemCnt, CurGetMemCount, DiffGetMemCount: longint;
OldQuickTrace: boolean;
begin begin
StartGetMemCnt:=MemCheck_getmem_cnt; StartGetMemCnt:=MemCheck_getmem_cnt;
CurGetMemCount:=StartGetMemCnt-HiddenGetMemCnt; CurGetMemCount:=StartGetMemCnt-HiddenGetMemCnt;
@ -1419,10 +1459,11 @@ begin
writeln('>>> memcheck.pp - CheckHeap2 "',txt,'" ', writeln('>>> memcheck.pp - CheckHeap2 "',txt,'" ',
CurGetMemCount,'(',StartGetMemCnt,') +',DiffGetMemCount); CurGetMemCount,'(',StartGetMemCnt,') +',DiffGetMemCount);
OldQuickTrace:=QuickTrace;
QuickTrace:=false; QuickTrace:=false;
GetMem(p,4); GetMem(p,4);
FreeMem(p); FreeMem(p);
QuickTrace:=true; QuickTrace:=OldQuickTrace;
// don't count mem counts of this proc // don't count mem counts of this proc
inc(HiddenGetMemCnt,MemCheck_getmem_cnt-StartGetMemCnt); inc(HiddenGetMemCnt,MemCheck_getmem_cnt-StartGetMemCnt);
@ -1575,7 +1616,7 @@ begin
if assigned(pp^.extra_info) and if assigned(pp^.extra_info) and
(pp^.extra_info^.check=$12345678) and (pp^.extra_info^.check=$12345678) and
assigned(pp^.extra_info^.displayproc) then 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; end;
@ -1659,7 +1700,8 @@ begin
(pp^.sig <>$AAAAAAAA) then (pp^.sig <>$AAAAAAAA) then
begin begin
writeln(ptext^,'error in linked list of heap_mem_info'); writeln(ptext^,'error in linked list of heap_mem_info');
RunError(204); // MG: changes for codetools:
MemError;
end; end;
if pp=p then if pp=p then
is_in_getmem_list:=true; is_in_getmem_list:=true;
@ -1668,7 +1710,8 @@ begin
if i>getmem_cnt-freemem_cnt then begin if i>getmem_cnt-freemem_cnt then begin
writeln(ptext^,'error in linked list of heap_mem_info', writeln(ptext^,'error in linked list of heap_mem_info',
' FreedCnt=',getmem_cnt-freemem_cnt,' RealCnt=',i); ' FreedCnt=',getmem_cnt-freemem_cnt,' RealCnt=',i);
RunError(204); // MG: changes for codetools:
MemError;
end; end;
pp:=pp^.previous; pp:=pp^.previous;
end; end;
@ -1780,36 +1823,40 @@ begin
if not quicktrace then if not quicktrace then
begin begin
if not(is_in_getmem_list(pp)) then if not(is_in_getmem_list(pp)) then
RunError(204); // MG: changes for codetools:
MemError;
end; end;
if (pp^.sig=$AAAAAAAA) and not usecrc then if (pp^.sig=$AAAAAAAA) and not usecrc then
begin begin
error_in_heap:=true; error_in_heap:=true;
dump_already_free(pp,ptext^); dump_already_free(pp,ptext^);
if haltonerror then halt(1); // MG: changes for codetools:
MemError;
end end
else if ((pp^.sig<>$DEADBEEF) or usecrc) and else if ((pp^.sig<>$DEADBEEF) or usecrc) and
((pp^.sig<>calculate_sig(pp)) or not usecrc) then ((pp^.sig<>calculate_sig(pp)) or not usecrc) then
begin begin
error_in_heap:=true; error_in_heap:=true;
dump_error(pp,ptext^); dump_error(pp,ptext^);
{$ifdef EXTRA} {$ifdef EXTRA}
dump_error(pp,error_file); dump_error(pp,error_file);
{$endif EXTRA} {$endif EXTRA}
{ don't release anything in this case !! } { don't release anything in this case !! }
if haltonerror then halt(1); // MG: changes for codetools:
exit; MemError;
exit;
end end
else if pp^.size<>size then else if pp^.size<>size then
begin begin
error_in_heap:=true; error_in_heap:=true;
dump_wrong_size(pp,size,ptext^); dump_wrong_size(pp,size,ptext^);
{$ifdef EXTRA} {$ifdef EXTRA}
dump_wrong_size(pp,size,error_file); dump_wrong_size(pp,size,error_file);
{$endif EXTRA} {$endif EXTRA}
if haltonerror then halt(1); // MG: changes for codetools:
{ don't release anything in this case !! } MemError;
exit; { don't release anything in this case !! }
exit;
end; end;
{ save old values } { save old values }
extra_size:=pp^.extra_info_size; extra_size:=pp^.extra_info_size;
@ -1957,7 +2004,7 @@ begin
dump_error(pp,error_file); dump_error(pp,error_file);
{$endif EXTRA} {$endif EXTRA}
{ don't release anything in this case !! } { don't release anything in this case !! }
if haltonerror then halt(1); MemError;
exit; exit;
end; end;
{ save info } { save info }
@ -2071,13 +2118,15 @@ label
_exit; _exit;
begin begin
if p=nil then if p=nil then
runerror(204); // MG: changes for codetools:
MemError;
i:=0; i:=0;
{$ifdef go32v2} {$ifdef go32v2}
if cardinal(p)<$1000 then if cardinal(p)<$1000 then
runerror(216); // MG: changes for codetools:
MemError;
asm asm
movl %ebp,get_ebp movl %ebp,get_ebp
leal edata,%eax leal edata,%eax
@ -2131,7 +2180,8 @@ begin
begin begin
writeln(ptext^,'corrupted heap_mem_info'); writeln(ptext^,'corrupted heap_mem_info');
dump_error(pp,ptext^); dump_error(pp,ptext^);
halt(1); ExceptOnError:=true;
MemError;
end; end;
end end
else else
@ -2140,7 +2190,8 @@ begin
if i>getmem_cnt-freemem_cnt then if i>getmem_cnt-freemem_cnt then
begin begin
writeln(ptext^,'error in linked list of heap_mem_info'); writeln(ptext^,'error in linked list of heap_mem_info');
halt(1); ExceptOnError:=true;
MemError;
end; end;
end; end;
i:=0; i:=0;
@ -2159,18 +2210,21 @@ begin
begin begin
writeln(ptext^,'pointer $',hexstr(longint(p),8),' points into invalid memory block'); writeln(ptext^,'pointer $',hexstr(longint(p),8),' points into invalid memory block');
dump_error(pp,ptext^); dump_error(pp,ptext^);
runerror(204); // MG: changes for codetools:
MemError;
end; end;
pp:=pp^.previous; pp:=pp^.previous;
inc(i); inc(i);
if i>getmem_cnt then if i>getmem_cnt then
begin begin
writeln(ptext^,'error in linked list of heap_mem_info'); writeln(ptext^,'error in linked list of heap_mem_info');
halt(1); ExceptOnError:=true;
MemError;
end; end;
end; end;
writeln(ptext^,'pointer $',hexstr(longint(p),8),' does not point to valid memory block'); writeln(ptext^,'pointer $',hexstr(longint(p),8),' does not point to valid memory block');
runerror(204); // MG: changes for codetools:
MemError;
_exit: _exit:
end; end;
@ -2476,6 +2530,11 @@ begin
end; end;
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 Initialization
LoadEnvironment; LoadEnvironment;
@ -2487,9 +2546,14 @@ finalization
TraceExit; TraceExit;
end. end.
{$endif} {$endif VER1_1}
{ {
$Log$ $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 Revision 1.17 2002/12/24 12:52:53 mattias
fixed ReAllocmem of memcheck and added memcheck for fpc 1.1 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 uses
{$IFDEF IP_LAZARUS} {$IFDEF IP_LAZARUS}
//MemCheck,
VCLGlobals, VCLGlobals,
LCLType, LCLType,
GraphType, GraphType,
@ -3320,7 +3321,6 @@ end;
procedure SetWordRect(Element: PIpHtmlElement; const Value: TRect); procedure SetWordRect(Element: PIpHtmlElement; const Value: TRect);
begin begin
writeln('SetWordRect A Element=',HexStr(Cardinal(Element),8),' ',Value.Left,',',Value.Top);
Element.WordRect2 := Value; Element.WordRect2 := Value;
if Element.ElementType = etObject then begin if Element.ElementType = etObject then begin
if (Value.Left < Value.Right) if (Value.Left < Value.Right)
@ -3737,7 +3737,7 @@ end;
procedure TIpHtmlNode.Enqueue; procedure TIpHtmlNode.Enqueue;
begin begin
writeln('TIpHtmlNode.Enqueue A ',ClassName);
end; end;
procedure TIpHtmlNode.EnqueueElement(const Entry: PIpHtmlElement); procedure TIpHtmlNode.EnqueueElement(const Entry: PIpHtmlElement);
@ -4107,9 +4107,7 @@ procedure TIpHtmlNodeMulti.Enqueue;
var var
i : Integer; i : Integer;
begin begin
writeln('TIpHtmlNodeMulti.Enqueue A ',ClassName);
for i := 0 to pred(FChildren.Count) do begin 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; TIpHtmlNode(FChildren[i]).Enqueue;
end; end;
end; end;
@ -4177,14 +4175,12 @@ var
X, Y : Integer; X, Y : Integer;
P : TPoint; P : TPoint;
begin begin
writeln('TIpHtmlNodeBODY.Render A ',ClassName);
if ScaleBitmaps then begin {!!.10} if ScaleBitmaps then begin {!!.10}
Owner.Target.Brush.Color := clWhite; Owner.Target.Brush.Color := clWhite;
Owner.Target.FillRect(Owner.ClientRect); Owner.Target.FillRect(Owner.ClientRect);
end else begin end else begin
if BackGround = '' then begin if BackGround = '' then begin
Owner.Target.Brush.Color := clWhite; 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); Owner.Target.FillRect(Owner.ClientRect);
end; end;
if BGColor <> $FFFFFFFF then begin if BGColor <> $FFFFFFFF then begin
@ -4294,7 +4290,6 @@ var
i : Integer; i : Integer;
begin begin
for i := 0 to pred(PropACache.Count) do 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; TIpHtmlPropA(PropACache[i]).Free;
end; end;
PropACache.Free; PropACache.Free;
@ -7244,6 +7239,7 @@ end;
procedure TIpHtml.ParseFrameSet(Parent : TIpHtmlNode; procedure TIpHtml.ParseFrameSet(Parent : TIpHtmlNode;
const EndTokens: TIpHtmlTokenSet); const EndTokens: TIpHtmlTokenSet);
begin begin
writeln('TIpHtml.ParseFrameSet A');
FHasFrames := True; FHasFrames := True;
while CurToken = IpHtmlTagFRAMESET do begin while CurToken = IpHtmlTagFRAMESET do begin
CurFrameSet := TIpHtmlNodeFRAMESET.Create(Parent); CurFrameSet := TIpHtmlNodeFRAMESET.Create(Parent);
@ -7283,10 +7279,7 @@ begin
end; end;
{lead token is optional} {lead token is optional}
if CurToken = IpHtmlTagBODY then begin if CurToken = IpHtmlTagBODY then begin
writeln('TIpHtml.ParseBody A ',TIpHtmlNodeMulti(HtmlNode).ChildCount);
TIpHtmlNodeBODY.Create(Parent); 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 with Body do begin
BgColor := ColorFromString(FindAttribute('BGCOLOR')); BgColor := ColorFromString(FindAttribute('BGCOLOR'));
Text := ColorFromString(FindAttribute('TEXT')); Text := ColorFromString(FindAttribute('TEXT'));
@ -7825,15 +7818,12 @@ procedure TIpHtml.RequestImageNodes(Node : TIpHtmlNode);
var var
i : Integer; i : Integer;
begin begin
writeln('TIpHtml.RequestImageNodes ',Node.ClassName);
if Node is TIpHtmlNodeIMG then begin if Node is TIpHtmlNodeIMG then begin
if TIpHtmlNodeIMG(Node).FPicture = nil then if TIpHtmlNodeIMG(Node).FPicture = nil then
TIpHtmlNodeIMG(Node).LoadImage; TIpHtmlNodeIMG(Node).LoadImage;
end; end;
writeln('TIpHtml.RequestImageNodes B ',Node.ClassName,' ',Node is TIpHtmlNodeMulti);
if Node is TIpHtmlNodeMulti then if Node is TIpHtmlNodeMulti then
for i := 0 to pred(TIpHtmlNodeMulti(Node).ChildCount) do begin 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]); RequestImageNodes(TIpHtmlNodeMulti(Node).ChildNode[i]);
end; end;
end; end;
@ -7843,8 +7833,6 @@ procedure TIpHtml.Render(TargetCanvas: TCanvas; TargetPageRect : TRect;
var var
i : Integer; i : Integer;
begin 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.TopLeft := TopLeft; {Point(0, 0);} {!!.10}
ClientRect.Right := TargetPageRect.Right - TargetPageRect.Left; ClientRect.Right := TargetPageRect.Right - TargetPageRect.Left;
ClientRect.Bottom := TargetPageRect.Bottom - TargetPageRect.Top; ClientRect.Bottom := TargetPageRect.Bottom - TargetPageRect.Top;
@ -7884,16 +7872,11 @@ begin
FTarget := TargetCanvas; FTarget := TargetCanvas;
end; end;
ClearRectList; ClearRectList;
writeln('TIpHtml.Render C2 ',TIpHtmlNodeMulti(HtmlNode).ChildCount,
' ',TIpHtmlNodeMulti(HtmlNode).ChildNode[0].ClassName,' ',HexStr(Cardinal(TIpHtmlNodeMulti(HtmlNode).ChildNode[0]),8));
if FHtml <> nil then if FHtml <> nil then
FHtml.Render(DefaultProps); 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 for i := 0 to pred(ControlList.Count) do
TIpHtmlNode(ControlList[i]).HideUnmarkedControl; TIpHtmlNode(ControlList[i]).HideUnmarkedControl;
writeln('TIpHtml.Render E ',TIpHtmlNodeMulti(HtmlNode).ChildCount);
PaintSelection; PaintSelection;
if UsePaintBuffer then if UsePaintBuffer then
TargetCanvas.CopyRect(ClientRect, PaintBuffer, ClientRect) TargetCanvas.CopyRect(ClientRect, PaintBuffer, ClientRect)
@ -7902,10 +7885,8 @@ begin
PaintBuffer := PaintBufferBitmap.Canvas PaintBuffer := PaintBufferBitmap.Canvas
else else
PaintBuffer := nil; PaintBuffer := nil;
writeln('TIpHtml.Render F ',TIpHtmlNodeMulti(HtmlNode).ChildCount);
StartGifPaint(TargetCanvas); StartGifPaint(TargetCanvas);
{Request all non-visible images} {Request all non-visible images}
writeln('TIpHtml.Render G ',TIpHtmlNodeMulti(HtmlNode).ChildCount);
RequestImageNodes(HtmlNode); RequestImageNodes(HtmlNode);
end; end;
@ -7975,7 +7956,6 @@ var
DefPageRect : TRect; DefPageRect : TRect;
Min, Max, W, H : Integer; Min, Max, W, H : Integer;
begin begin
writeln('TIpHtml.GetPageRect A ',ClassName,' ',Width,',',Height,' DoneLoading=',DoneLoading);
if not DoneLoading then begin if not DoneLoading then begin
{$IFDEF IP_LAZARUS} {$IFDEF IP_LAZARUS}
SetRectEmpty(Result); SetRectEmpty(Result);
@ -8010,7 +7990,6 @@ writeln('TIpHtml.GetPageRect A ',ClassName,' ',Width,',',Height,' DoneLoading=',
end; end;
Result := FPageRect; Result := FPageRect;
DoneLoading := True; DoneLoading := True;
writeln('TIpHtml.GetPageRect B ',ClassName,' ',Result.Left,',',Result.Top,',',Result.Right,',',Result.Bottom);
end; end;
procedure TIpHtml.InvalidateSize; procedure TIpHtml.InvalidateSize;
@ -8479,7 +8458,6 @@ var
Ch : AnsiChar; Ch : AnsiChar;
ImplicitLF: Boolean; {!!.10} ImplicitLF: Boolean; {!!.10}
begin begin
writeln('TIpHtmlNodeText.BuildWordList A PropsR.Preformatted=',PropsR.Preformatted);
First := True; First := True;
ImplicitLF := False; {!!.10} ImplicitLF := False; {!!.10}
if PropsR.Preformatted then begin if PropsR.Preformatted then begin
@ -8545,7 +8523,6 @@ writeln('TIpHtmlNodeText.BuildWordList A PropsR.Preformatted=',PropsR.Preformatt
end; end;
end else begin end else begin
l := length(EscapedText); l := length(EscapedText);
writeln('TIpHtmlNodeText.BuildWordList B l=',l,' EscapedText="',EscapedText,'"');
if l > 0 then begin if l > 0 then begin
Getmem(B, l + 1); Getmem(B, l + 1);
try try
@ -8555,14 +8532,12 @@ writeln('TIpHtmlNodeText.BuildWordList B l=',l,' EscapedText="',EscapedText,'"')
case N^ of case N^ of
LF : LF :
begin begin
writeln('TIpHtmlNodeText.BuildWordList C LF');
EnqueueElement(Owner.HardLF); EnqueueElement(Owner.HardLF);
inc(N); inc(N);
end; end;
' ' : ' ' :
begin begin
if not ElementQueueIsEmpty then begin {!!.10} if not ElementQueueIsEmpty then begin {!!.10}
writeln('TIpHtmlNodeText.BuildWordList C space Owner=',Owner.ClassName);
NewEntry := Owner.NewElement(etWord, Self); NewEntry := Owner.NewElement(etWord, Self);
NewEntry.AnsiWord := ' '; NewEntry.AnsiWord := ' ';
NewEntry.IsBlank := 1; NewEntry.IsBlank := 1;
@ -8571,14 +8546,12 @@ writeln('TIpHtmlNodeText.BuildWordList C space Owner=',Owner.ClassName);
else else
NewEntry.Props := nil; NewEntry.Props := nil;
EnqueueElement(NewEntry); EnqueueElement(NewEntry);
writeln('TIpHtmlNodeText.BuildWordList C2 NewEntry.WordRect2=',NewEntry.WordRect2.Left,',',NewEntry.WordRect2.Top);
First := False; First := False;
end; {!!.10} end; {!!.10}
inc(N); inc(N);
end; end;
else else
begin begin
writeln('TIpHtmlNodeText.BuildWordList C char');
N2 := N; N2 := N;
while not (N2^ in [#0, ' ', LF]) do while not (N2^ in [#0, ' ', LF]) do
inc(N2); inc(N2);
@ -8809,7 +8782,6 @@ begin
for i := 0 to pred(ElementQueue.Count) do begin for i := 0 to pred(ElementQueue.Count) do begin
CurWord := PIpHtmlElement(ElementQueue[i]); CurWord := PIpHtmlElement(ElementQueue[i]);
writeln('TIpHtmlNodeBlock.RenderQueue A ',ClassName,' ',i,'/',ElementQueue.Count);
if (CurWord.Props <> nil) and (CurWord.Props <> LastProp) then begin 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; Owner.Target.Font.EndUpdate;
{$ENDIF} {$ENDIF}
LastProp := CurWord.Props; LastProp := CurWord.Props;
writeln('TIpHtmlNodeBlock.RenderQueue B Font.Name="',Owner.Target.Font.Name,'" Size=',Owner.Target.Font.Size);
end; 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 if IntersectRect(R, CurWord.WordRect2, Owner.PageViewRect) then
case CurWord.ElementType of case CurWord.ElementType of
etWord : etWord :
begin begin
P := Owner.PagePtToScreen(CurWord.WordRect2.TopLeft); 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.Brush.Style := bsClear;
Owner.Target.TextOut(P.x, P.y, NoBreakToSpace(CurWord.AnsiWord)); Owner.Target.TextOut(P.x, P.y, NoBreakToSpace(CurWord.AnsiWord));
Owner.AddRect(CurWord.WordRect2, CurWord, Self); Owner.AddRect(CurWord.WordRect2, CurWord, Self);
@ -8879,15 +8846,12 @@ end;
procedure TIpHtmlNodeBlock.Render( procedure TIpHtmlNodeBlock.Render(
const RenderProps: TIpHtmlProps); const RenderProps: TIpHtmlProps);
begin begin
writeln('TIpHtmlNodeBlock.Render A ',ClassName);
if not RenderProps.IsEqualTo(Props) then begin if not RenderProps.IsEqualTo(Props) then begin
SetProps(RenderProps); SetProps(RenderProps);
Props.Assign(RenderProps); Props.Assign(RenderProps);
end; end;
writeln('TIpHtmlNodeBlock.Render C ElementQueue.Count=',ElementQueue.Count);
if ElementQueue.Count = 0 then if ElementQueue.Count = 0 then
Enqueue; Enqueue;
writeln('TIpHtmlNodeBlock.Render D ElementQueue.Count=',ElementQueue.Count);
RenderQueue; RenderQueue;
end; end;
@ -9188,7 +9152,6 @@ end;
function TIpHtmlNodeBlock.GetHeight(const RenderProps: TIpHtmlProps; function TIpHtmlNodeBlock.GetHeight(const RenderProps: TIpHtmlProps;
const Width: Integer): Integer; const Width: Integer): Integer;
begin begin
writeln('TIpHtmlNodeBlock.GetHeight A ',ClassName);
if LastW = Width then begin if LastW = Width then begin
Result := LastH; Result := LastH;
exit; exit;
@ -9203,7 +9166,6 @@ end;
procedure TIpHtmlNodeBlock.Layout(const RenderProps: TIpHtmlProps; procedure TIpHtmlNodeBlock.Layout(const RenderProps: TIpHtmlProps;
const TargetRect: TRect); const TargetRect: TRect);
begin begin
writeln('TIpHtmlNodeBlock.Layout A');
if EqualRect(TargetRect, PageRect) then exit; if EqualRect(TargetRect, PageRect) then exit;
if not RenderProps.IsEqualTo(Props) then begin if not RenderProps.IsEqualTo(Props) then begin
SetProps(RenderProps); SetProps(RenderProps);
@ -9223,7 +9185,6 @@ var
CurElement : PIpHtmlElement; CurElement : PIpHtmlElement;
R : TRect; R : TRect;
begin begin
writeln('TIpHtmlNodeBlock.RelocateQueue A');
OffsetRect(FPageRect, dx, dy); OffsetRect(FPageRect, dx, dy);
for i := 0 to pred(ElementQueue.Count) do begin for i := 0 to pred(ElementQueue.Count) do begin
CurElement := PIpHtmlElement(ElementQueue[i]); CurElement := PIpHtmlElement(ElementQueue[i]);
@ -9620,7 +9581,6 @@ var
*) *)
begin begin
writeln('TIpHtmlNodeBlock.LayoutQueue A');
if ElementQueue.Count = 0 then exit; if ElementQueue.Count = 0 then exit;
{DumpQueue;} {debug} {DumpQueue;} {debug}
LeftQueue := nil; LeftQueue := nil;
@ -13796,9 +13756,10 @@ var
i : Integer; i : Integer;
begin begin
for i := 0 to FChildren.Count - 1 do 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, TIpHtmlNodeBody(FChildren[i]).CalcMinMaxWidth(RenderProps,
Min, Max); Min, Max);
end;
end; end;
function TIpHtmlNodeHtml.GetHeight(const RenderProps: TIpHtmlProps; function TIpHtmlNodeHtml.GetHeight(const RenderProps: TIpHtmlProps;
@ -13808,9 +13769,10 @@ var
begin begin
Result := 0; Result := 0;
for i := 0 to FChildren.Count - 1 do 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]). Result := TIpHtmlNodeBody(FChildren[i]).
GetHeight(RenderProps, Width); GetHeight(RenderProps, Width);
end;
end; end;
{Begin !!.12} {Begin !!.12}
@ -13842,7 +13804,6 @@ procedure TIpHtmlNodeHtml.Render(const RenderProps: TIpHtmlProps);
var var
i : Integer; i : Integer;
begin begin
writeln('TIpHtmlNodeHtml.Render A ',ClassName);
for i := 0 to FChildren.Count - 1 do for i := 0 to FChildren.Count - 1 do
if TIpHtmlNode(FChildren[i]) is TIpHtmlNodeBody then if TIpHtmlNode(FChildren[i]) is TIpHtmlNodeBody then
TIpHtmlNodeBody(FChildren[i]). TIpHtmlNodeBody(FChildren[i]).
@ -16400,8 +16361,9 @@ begin
Parent := HyperPanel; Parent := HyperPanel;
Anchor := Html.AnchorList[i]; Anchor := Html.AnchorList[i];
end; 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); TIpHtmlNode(Html.ControlList[i]).CreateControl(HyperPanel);
end;
HyperPanel.Hyper := Html; HyperPanel.Hyper := Html;
end; end;
end; end;
@ -16846,7 +16808,6 @@ begin
RelURL := copy(HRef, 2, length(HRef) - 1); RelURL := copy(HRef, 2, length(HRef) - 1);
BaseURL := ''; BaseURL := '';
end else begin end else begin
writeln('TIpHtmlCustomPanel.InternalOpenURL A ');
if MasterFrame <> nil then begin if MasterFrame <> nil then begin
if Assigned(FDataProvider) then if Assigned(FDataProvider) then
URL := FDataProvider.BuildURL(MasterFrame.Html.CURURL, HRef) URL := FDataProvider.BuildURL(MasterFrame.Html.CURURL, HRef)
@ -16855,7 +16816,6 @@ writeln('TIpHtmlCustomPanel.InternalOpenURL A ');
end end
else else
URL := HRef; URL := HRef;
writeln('TIpHtmlCustomPanel.InternalOpenURL B URL=',URL);
P := CharPos('#', URL); P := CharPos('#', URL);
if P = 0 then begin if P = 0 then begin
RelURL := ''; RelURL := '';
@ -16865,7 +16825,6 @@ writeln('TIpHtmlCustomPanel.InternalOpenURL B URL=',URL);
RelURL := copy(URL, P + 1, length(URL)); RelURL := copy(URL, P + 1, length(URL));
end; end;
end; end;
writeln('TIpHtmlCustomPanel.InternalOpenURL C ',BaseURL);
if BaseURL <> '' then begin if BaseURL <> '' then begin
if VisitedList.IndexOf(BaseURL) = -1 then if VisitedList.IndexOf(BaseURL) = -1 then
VisitedList.Add(BaseURL); VisitedList.Add(BaseURL);
@ -16902,16 +16861,13 @@ writeln('TIpHtmlCustomPanel.InternalOpenURL C ',BaseURL);
TargetFrame.OpenURL(BaseURL, False); TargetFrame.OpenURL(BaseURL, False);
end; end;
end; end;
writeln('TIpHtmlCustomPanel.InternalOpenURL D ');
if RelURL <> '' then if RelURL <> '' then
MasterFrame.MakeAnchorVisible(RelURL) MasterFrame.MakeAnchorVisible(RelURL)
else else
if MasterFrame <> nil then {!!.02} if MasterFrame <> nil then {!!.02}
MasterFrame.Home; MasterFrame.Home;
writeln('TIpHtmlCustomPanel.InternalOpenURL E ');
if assigned(FDocumentOpen) then {!!.10} if assigned(FDocumentOpen) then {!!.10}
FDocumentOpen(Self); {!!.10} FDocumentOpen(Self); {!!.10}
writeln('TIpHtmlCustomPanel.InternalOpenURL END ');
end; end;
procedure TIpHtmlCustomPanel.HotClick(Sender: TObject); procedure TIpHtmlCustomPanel.HotClick(Sender: TObject);
@ -17592,6 +17548,9 @@ initialization
InitScrollProcs; InitScrollProcs;
{ {
$Log$ $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 Revision 1.4 2003/03/29 23:52:25 mattias
IpHtmlPanel can show simple HTML pages, but there are mem bugs IpHtmlPanel can show simple HTML pages, but there are mem bugs

39
ide/outputfilter.pas
View File

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

15
lcl/include/filectrl.inc
View File

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

2
lcl/lclmemmanager.pas
View File

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