[lazarus] Request !
Peter Vreman
pfv at cooldown.demon.nl
Thu May 6 17:19:27 EDT 1999
> Peter
>
> What tool are you refering to. I am just doing a manual look and compare.
A tool that inserts the headers for implementation/interface and Styles
some of the type that are left over after h2pas for example: T_Gtk ->
TGtk
Peter
function lower(const s : string) : string;
{
return lowercased string of s
}
var
i : longint;
begin
for i:=1 to length(s) do
if s[i] in ['A'..'Z'] then
lower[i]:=char(byte(s[i])+32)
else
lower[i]:=s[i];
lower[0]:=s[0];
end;
function upper(const s : string) : string;
{
return lowercased string of s
}
var
i : longint;
begin
for i:=1 to length(s) do
if s[i] in ['a'..'z'] then
upper[i]:=char(byte(s[i])-32)
else
upper[i]:=s[i];
upper[0]:=s[0];
end;
function trimspace(const s:string):string;
var
i,j : longint;
begin
i:=length(s);
while (i>0) and (s[i] in [#9,' ']) do
dec(i);
j:=1;
while (j<i) and (s[j] in [#9,' ']) do
inc(j);
trimspace:=Copy(s,j,i-j+1);
end;
function trimbegin(const s:string):string;
var
i,j : longint;
begin
i:=length(s);
j:=1;
while (j<i) and (s[j] in [#9,' ']) do
inc(j);
trimbegin:=Copy(s,j,i-j+1);
end;
procedure Replace(var s:string;const s1,s2:string);
var
last,
i : longint;
begin
last:=0;
repeat
i:=pos(s1,upper(s));
if i=last then
i:=0;
if (i>0) then
begin
Delete(s,i,length(s1));
Insert(s2,s,i);
last:=i;
end;
until i=0;
end;
procedure fixreplace(var s:string);
begin
replace(s,'P_GTK','PGtk');
replace(s,'= ^T_GTK','= ^TGtk');
replace(s,'^T_GTK','PGtk');
replace(s,'T_GTK','TGtk');
replace(s,'External_library','gtkdll');
end;
var
t,f : text;
ssmall : string[20];
hs,
s : string;
name : string;
i : word;
func,
impl : boolean;
begin
impl:=false;
assign(t,paramstr(1));
assign(f,'fixgtk.tmp');
reset(t);
rewrite(f);
writeln(f,'{');
writeln(f,' $Id: gtk111.pp,v $');
writeln(f,'}');
writeln(f,'');
writeln(f,'{$ifndef gtk_include_files}');
writeln(f,' {$define read_interface}');
writeln(f,' {$define read_implementation}');
writeln(f,'{$endif not gtk_include_files}');
writeln(f,'');
writeln(f,'{$ifndef gtk_include_files}');
writeln(f,'');
writeln(f,' unit gtk111;');
writeln(f,' interface');
writeln(f,'');
writeln(f,' uses');
writeln(f,' glib,gdkmain,');
writeln(f,' gtkobjects;');
writeln(f,'');
writeln(f,' {$ifdef win32}');
writeln(f,' const');
writeln(f,' gtkdll=''gtk-1.1.dll''; { leave the .dll else .1.1 -> .1 !! }');
writeln(f,' {$else}');
writeln(f,' const');
writeln(f,' gtkdll=''gtk.so'';');
writeln(f,' {$linklib c}');
writeln(f,' {$endif}');
writeln(f,'');
writeln(f,' Type');
writeln(f,' PLongint = ^Longint;');
writeln(f,' PByte = ^Byte;');
writeln(f,' PWord = ^Word;');
writeln(f,' PINteger = ^Integer;');
writeln(f,' PCardinal = ^Cardinal;');
writeln(f,' PReal = ^Real;');
writeln(f,' PDouble = ^Double;');
writeln(f,'');
writeln(f,'{$endif not gtk_include_files}');
writeln(f,'');
writeln(f,'{$ifdef read_interface}');
writeln(f,'');
while not eof(t) do
begin
read(t,ssmall);
fixreplace(ssmall);
if (not impl) and (copy(trimspace(ssmall),1,14)='implementation') then
begin
impl:=true;
readln(t,s);
writeln(f,'{$endif read_interface}');
writeln(f,'');
writeln(f,'');
writeln(f,'{$ifndef gtk_include_files}');
writeln(f,' implementation');
writeln(f,'{$endif not gtk_include_files}');
writeln(f,'');
writeln(f,'{$ifdef read_implementation}');
writeln(f,'');
continue;
end;
if (impl) and (copy(trimspace(ssmall),1,4)='end.') then
begin
writeln(f,'{$endif read_implementation}');
writeln(f,'');
writeln(f,'');
writeln(f,'{$ifndef gtk_include_files}');
writeln(f,'end.');
writeln(f,'{$endif not gtk_include_files}');
writeln(f,'');
writeln(f,'{');
writeln(f,' $Log: gtk111.pp,v $');
writeln(f,'}');
continue;
end;
readln(t,s);
fixreplace(s);
func:=false;
if lower(copy(trimspace(ssmall),1,8))='function' then
begin
func:=true;
name:=trimspace(ssmall+s);
delete(name,1,9);
name:=trimspace(name);
i:=1;
while (name[i] in ['_','A'..'Z','a'..'z','0'..'9']) do
inc(i);
delete(name,i,255);
hs:=trimbegin(ssmall);
replace(hs,'FUNCTION','function ');
write(f,hs);
end
else
if lower(copy(trimspace(ssmall),1,9))='procedure' then
begin
func:=true;
name:=trimspace(ssmall+s);
delete(name,1,10);
name:=trimspace(name);
i:=1;
while (name[i] in ['_','A'..'Z','a'..'z','0'..'9']) do
inc(i);
delete(name,i,255);
write(f,trimbegin(ssmall));
end
else
write(f,ssmall);
if func and (copy(name,1,3)='gtk') then
begin
if pos('cdecl;',s)=0 then
begin
write(f,s);
readln(t,s);
end;
replace(s,'CDECL;','{$ifndef win32}cdecl;{$endif}');
writeln(f,s);
end
else
writeln(f,s);
end;
close(f);
close(t);
{ erase(t);
rename(f,paramstr(1)); }
end.
More information about the Lazarus
mailing list