mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-05 21:28:21 +02:00
fcl-res: move rcparser code to include file
- no need to recompile the grammar on process changes - full codetools in Lazarus Reintegrate fpcres-rc branch by Martok git-svn-id: trunk@46381 -
This commit is contained in:
svenbarth
parent
d01d35fb74
commit
b88adc8e64
1
.gitattributes
vendored
1
.gitattributes
vendored
@ -4124,6 +4124,7 @@ packages/fcl-res/src/rclex.inc svneol=native#text/plain
|
||||
packages/fcl-res/src/rclex.l svneol=native#text/plain
|
||||
packages/fcl-res/src/rcparser.pas svneol=native#text/pascal
|
||||
packages/fcl-res/src/rcparser.y svneol=native#text/plain
|
||||
packages/fcl-res/src/rcparserfn.inc svneol=native#text/plain
|
||||
packages/fcl-res/src/rcreader.pp svneol=native#text/pascal
|
||||
packages/fcl-res/src/resdatastream.pp svneol=native#text/plain
|
||||
packages/fcl-res/src/resfactory.pp svneol=native#text/plain
|
||||
|
||||
@ -9,387 +9,7 @@ Vorspann
|
||||
|
||||
unit rcparser;
|
||||
|
||||
{$modeswitch advancedrecords}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
SysUtils, Classes, StrUtils, lexlib, yacclib, resource,
|
||||
acceleratorsresource, groupiconresource, stringtableresource,
|
||||
bitmapresource, versionresource, versiontypes, groupcursorresource;
|
||||
|
||||
function yyparse : Integer;
|
||||
|
||||
var
|
||||
aktresources: TResources;
|
||||
opt_code_page: TSystemCodePage;
|
||||
yyfilename: AnsiString;
|
||||
yyparseresult: YYSType;
|
||||
|
||||
procedure PragmaCodePage(cp: string);
|
||||
|
||||
{$DEFINE INC_HEADER}
|
||||
{$I yyinclude.pp}
|
||||
{$I yypreproc.pp}
|
||||
{$UNDEF INC_HEADER}
|
||||
|
||||
implementation
|
||||
|
||||
procedure yyerror ( msg : String );
|
||||
begin
|
||||
writeln(ErrOutput, yyfilename, '(',yylineno,':',yycolno,'): at "',yytext,'": ', msg);
|
||||
WriteLn(ErrOutput, yyline);
|
||||
WriteLn(ErrOutput, '^':yycolno);
|
||||
end(*yyerrmsg*);
|
||||
|
||||
{$I yyinclude.pp}
|
||||
{$I yypreproc.pp}
|
||||
|
||||
(* I/O routines: *)
|
||||
|
||||
const nl = #10; (* newline character *)
|
||||
|
||||
const max_chars = 2048;
|
||||
|
||||
var
|
||||
bufptr : Integer;
|
||||
buf : array [1..max_chars] of Char;
|
||||
|
||||
function rc_get_char : Char;
|
||||
var i : Integer;
|
||||
ok : boolean;
|
||||
begin
|
||||
if (bufptr=0) and not eof(yyinput) then
|
||||
begin
|
||||
repeat
|
||||
readln(yyinput, yyline);
|
||||
inc(yylineno); yycolno := 1;
|
||||
ok:= ypreproc.useline(yyline);
|
||||
until (ok or eof(yyinput));
|
||||
if ok then begin
|
||||
buf[1] := nl;
|
||||
for i := 1 to length(yyline) do
|
||||
buf[i+1] := yyline[length(yyline)-i+1];
|
||||
inc(bufptr, length(yyline)+1);
|
||||
end;
|
||||
end;
|
||||
if bufptr>0 then
|
||||
begin
|
||||
rc_get_char := buf[bufptr];
|
||||
dec(bufptr);
|
||||
inc(yycolno);
|
||||
end
|
||||
else
|
||||
rc_get_char := #0;
|
||||
end(*get_char*);
|
||||
|
||||
procedure rc_unget_char ( c : Char );
|
||||
begin
|
||||
if bufptr=max_chars then yyerror('input buffer overflow');
|
||||
inc(bufptr);
|
||||
dec(yycolno);
|
||||
buf[bufptr] := c;
|
||||
end(*unget_char*);
|
||||
|
||||
procedure unget_string(s: string);
|
||||
var
|
||||
i: integer;
|
||||
begin
|
||||
for i:= Length(s) downto 1 do
|
||||
rc_unget_char(s[i]);
|
||||
end;
|
||||
|
||||
procedure PragmaCodePage(cp: string);
|
||||
var cpi: integer;
|
||||
begin
|
||||
if Uppercase(cp) = 'DEFAULT' then
|
||||
opt_code_page:= DefaultFileSystemCodePage
|
||||
else begin
|
||||
if TryStrToInt(cp, cpi) and (cpi>=0) and (cpi<=high(TSystemCodePage)) then
|
||||
opt_code_page:= cpi
|
||||
else
|
||||
yyerror('Invalid code_page pragma: "' + cp + '"');
|
||||
end;
|
||||
end;
|
||||
|
||||
type
|
||||
rcnumtype = record
|
||||
v: LongWord;
|
||||
long: boolean;
|
||||
end;
|
||||
|
||||
rcstrtype = record
|
||||
v: PUnicodeString;
|
||||
cp: TSystemCodePage;
|
||||
end;
|
||||
|
||||
function str_to_cbase(s: string): LongWord;
|
||||
begin
|
||||
if s = '0' then
|
||||
Exit(0);
|
||||
if Copy(s, 1, 2) = '0x' then
|
||||
Exit(StrToInt('$' + Copy(s, 3, Maxint)));
|
||||
if Copy(s, 1, 1) = '0' then
|
||||
Exit(StrToInt('&' + Copy(s, 2, Maxint)));
|
||||
Result:= StrToInt(s);
|
||||
end;
|
||||
|
||||
function str_to_num(s:string): rcnumtype;
|
||||
begin
|
||||
// this does not handle empty strings - should never get them from the lexer
|
||||
Result.long:= s[Length(s)] = 'L';
|
||||
if Result.long then
|
||||
setlength(s, Length(s) - 1);
|
||||
Result.v:= str_to_cbase(s);
|
||||
end;
|
||||
|
||||
const
|
||||
MAX_RCSTR_LEN = 4096;
|
||||
var
|
||||
strbuf: array[0..MAX_RCSTR_LEN + 1] of char;
|
||||
strbuflen: Integer;
|
||||
|
||||
procedure strbuf_begin();
|
||||
begin
|
||||
FillChar(strbuf[0], sizeof(strbuf), 0);
|
||||
strbuflen:= 0;
|
||||
end;
|
||||
|
||||
procedure strbuf_append(s: string);
|
||||
var
|
||||
rem: integer;
|
||||
begin
|
||||
rem:= MAX_RCSTR_LEN - strbuflen;
|
||||
if Length(s) < rem then
|
||||
rem:= Length(s);
|
||||
Move(s[1], strbuf[strbuflen], rem);
|
||||
inc(strbuflen, rem);
|
||||
end;
|
||||
|
||||
procedure string_new(var str: rcstrtype; val: UnicodeString; cp: TSystemCodePage);
|
||||
begin
|
||||
New(str.v);
|
||||
str.v^:= val;
|
||||
str.cp:= cp;
|
||||
end;
|
||||
|
||||
procedure string_new_uni(var str: rcstrtype; val: PAnsiChar; len: integer; cp: TSystemCodePage; escapes: boolean);
|
||||
function translateChar(c: AnsiChar): UnicodeChar;
|
||||
var
|
||||
u: UnicodeString = '';
|
||||
begin
|
||||
if cp = CP_UTF16 then
|
||||
Result:= c
|
||||
else begin
|
||||
// TODO: there has to be a better way to translate a single codepoint
|
||||
widestringmanager.Ansi2UnicodeMoveProc(@c, cp, u, 1);
|
||||
Result:= u[1];
|
||||
end;
|
||||
end;
|
||||
|
||||
var
|
||||
uni: UnicodeString;
|
||||
wc: PUnicodeChar;
|
||||
rc, endin: PAnsiChar;
|
||||
h: string;
|
||||
hexlen, i: integer;
|
||||
begin
|
||||
uni:= '';
|
||||
if not escapes then
|
||||
widestringmanager.Ansi2UnicodeMoveProc(val, cp, uni, len)
|
||||
else begin
|
||||
if cp = CP_UTF16 then
|
||||
hexlen:= 4
|
||||
else
|
||||
hexlen:= 2;
|
||||
setlength(uni, len);
|
||||
wc:= @uni[1];
|
||||
rc:= val;
|
||||
endin:= @val[len];
|
||||
while rc <= endin do begin // val must contain the final #0!
|
||||
// treat as null-terminated - nulls may exist *after* this proc, but not before
|
||||
if (rc^ = '\') then begin
|
||||
inc(rc);
|
||||
case rc^ of
|
||||
#0: exit {Error: End too soon};
|
||||
'\': wc^:= '\';
|
||||
'f': wc^:= #&14;
|
||||
'n': wc^:= #&12;
|
||||
'r': wc^:= #&15;
|
||||
't': wc^:= #&11;
|
||||
'x',
|
||||
'X': begin
|
||||
h:= '$';
|
||||
for i:= 1 to hexlen do begin
|
||||
inc(rc);
|
||||
if rc >= endin then
|
||||
exit {Error: End too soon};
|
||||
h += rc^;
|
||||
end;
|
||||
if cp = CP_UTF16 then
|
||||
wc^:= WideChar(StrToInt(h))
|
||||
else
|
||||
wc^:= translateChar(Char(StrToInt(h)));
|
||||
end;
|
||||
'0'..'7': begin
|
||||
h:= '&' + rc^;
|
||||
for i:= 2 to 3 do begin
|
||||
inc(rc);
|
||||
if (rc >= endin) or not (rc^ in ['0'..'7']) then begin
|
||||
dec(rc);
|
||||
break;
|
||||
end;
|
||||
h += rc^;
|
||||
end;
|
||||
if cp = CP_UTF16 then
|
||||
wc^:= WideChar(StrToInt(h))
|
||||
else
|
||||
wc^:= translateChar(Char(StrToInt(h)));
|
||||
end;
|
||||
else
|
||||
wc^:= translateChar(rc^);
|
||||
end;
|
||||
end else
|
||||
wc^:= translateChar(rc^);
|
||||
inc(wc);
|
||||
inc(rc);
|
||||
end;
|
||||
i:= (PtrUInt(wc) - PtrUInt(@uni[1])) div 2; // includes final wc that was not written to
|
||||
SetLength(uni, i - 1);
|
||||
end;
|
||||
string_new(str, uni, cp);
|
||||
end;
|
||||
|
||||
function Max(a, b: LongWord): LongWord; inline;
|
||||
begin
|
||||
if a > b then
|
||||
Result:= a
|
||||
else
|
||||
Result:= b;
|
||||
end;
|
||||
|
||||
var
|
||||
aktresource: TAbstractResource;
|
||||
language: TLangID;
|
||||
|
||||
procedure create_resource(aId, aType: TResourceDesc; aClass: TResourceClass);
|
||||
var
|
||||
r: TAbstractResource;
|
||||
begin
|
||||
r:= aClass.Create(aType, aId);
|
||||
r.LangID:= language;
|
||||
aktresources.Add(r);
|
||||
aktresource:= r;
|
||||
end;
|
||||
|
||||
procedure create_resource(aId, aType: TResourceDesc); overload;
|
||||
begin
|
||||
create_resource(aId, aType, TGenericResource);
|
||||
end;
|
||||
|
||||
procedure create_resource(aId: TResourceDesc; aType: Word); overload;
|
||||
var
|
||||
cls: TResourceClass;
|
||||
begin
|
||||
case aType of
|
||||
RT_BITMAP: cls:= TBitmapResource;
|
||||
RT_ICON: cls:= TGroupIconResource;
|
||||
RT_CURSOR: cls:= TGroupCursorResource;
|
||||
RT_VERSION: cls:= TVersionResource;
|
||||
else
|
||||
raise EResourceDescTypeException.CreateFmt('Resource type not supported: %d', [aType]);
|
||||
end;
|
||||
create_resource(aId, nil, cls);
|
||||
end;
|
||||
|
||||
procedure raw_write_string(Stream: TMemoryStream; str: rcstrtype);
|
||||
var
|
||||
i: integer;
|
||||
u: UnicodeString;
|
||||
r: RawByteString = '';
|
||||
begin
|
||||
u:= str.v^;
|
||||
if str.cp = CP_UTF16 then begin
|
||||
for i:=1 to length(u) do
|
||||
Stream.WriteWord(NtoLE(Word(u[i])));
|
||||
end else begin
|
||||
widestringmanager.Unicode2AnsiMoveProc(@u[1], r, str.cp, Length(u));
|
||||
Stream.WriteBuffer(r[1], Length(r));
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure raw_write_int(Stream: TMemoryStream; num: rcnumtype);
|
||||
begin
|
||||
if num.long then
|
||||
Stream.WriteDWord(NtoLE(num.v))
|
||||
else
|
||||
Stream.WriteWord(NtoLE(Word(num.v)));
|
||||
end;
|
||||
|
||||
procedure stringtable_begin();
|
||||
begin
|
||||
// create dummy resource that we will use to capture suboptions
|
||||
create_resource(TResourceDesc.create(1), TResourceDesc.create(1));
|
||||
aktresources.Remove(aktresource);
|
||||
end;
|
||||
|
||||
procedure stringtable_add(ident: Word; str: AnsiString);
|
||||
var
|
||||
table: word;
|
||||
r: TStringTableResource;
|
||||
begin
|
||||
table:= (ident div 16) + 1;
|
||||
try
|
||||
{ TODO : This is stupid }
|
||||
r:= aktresources.Find(RT_STRING, table, aktresource.LangID) as TStringTableResource;
|
||||
except
|
||||
on e: EResourceNotFoundException do begin
|
||||
r:= TStringTableResource.Create;
|
||||
r.LangID:= aktresource.LangID;
|
||||
r.MemoryFlags:= aktresource.MemoryFlags;
|
||||
r.Characteristics:= aktresource.Characteristics;
|
||||
r.Version:= aktresource.Version;
|
||||
r.FirstID:= ident;
|
||||
aktresources.Add(r);
|
||||
end;
|
||||
end;
|
||||
r.Strings[ident]:= str;
|
||||
end;
|
||||
|
||||
procedure stringtable_end();
|
||||
begin
|
||||
FreeAndNil(aktresource);
|
||||
end;
|
||||
|
||||
function make_version(a, b, c, d: Word): TFileProductVersion;
|
||||
begin
|
||||
Result[0]:= a;
|
||||
Result[1]:= b;
|
||||
Result[2]:= c;
|
||||
Result[3]:= d;
|
||||
end;
|
||||
|
||||
procedure version_string_tab_begin(lcs: AnsiString);
|
||||
var
|
||||
vst: TVersionStringTable;
|
||||
begin
|
||||
vst:= TVersionStringTable.Create(lcs);
|
||||
TVersionResource(aktresource).StringFileInfo.Add(vst);
|
||||
end;
|
||||
|
||||
procedure version_string_tab_add(key, value: AnsiString);
|
||||
begin
|
||||
TVersionResource(aktresource).StringFileInfo.Items[TVersionResource(aktresource).StringFileInfo.Count-1].Add(key, value);
|
||||
end;
|
||||
|
||||
procedure version_var_translation_add(langid, cpid: word);
|
||||
var
|
||||
ti: TVerTranslationInfo;
|
||||
begin
|
||||
ti.language:= langid;
|
||||
ti.codepage:= cpid;
|
||||
TVersionResource(aktresource).VarFileInfo.Add(ti);
|
||||
end;
|
||||
{$I rcparserfn.inc}
|
||||
|
||||
const _ILLEGAL = 257;
|
||||
const _NUMBER = 258;
|
||||
|
||||
@ -5,387 +5,7 @@ Vorspann
|
||||
|
||||
unit rcparser;
|
||||
|
||||
{$modeswitch advancedrecords}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
SysUtils, Classes, StrUtils, lexlib, yacclib, resource,
|
||||
acceleratorsresource, groupiconresource, stringtableresource,
|
||||
bitmapresource, versionresource, versiontypes, groupcursorresource;
|
||||
|
||||
function yyparse : Integer;
|
||||
|
||||
var
|
||||
aktresources: TResources;
|
||||
opt_code_page: TSystemCodePage;
|
||||
yyfilename: AnsiString;
|
||||
yyparseresult: YYSType;
|
||||
|
||||
procedure PragmaCodePage(cp: string);
|
||||
|
||||
{$DEFINE INC_HEADER}
|
||||
{$I yyinclude.pp}
|
||||
{$I yypreproc.pp}
|
||||
{$UNDEF INC_HEADER}
|
||||
|
||||
implementation
|
||||
|
||||
procedure yyerror ( msg : String );
|
||||
begin
|
||||
writeln(ErrOutput, yyfilename, '(',yylineno,':',yycolno,'): at "',yytext,'": ', msg);
|
||||
WriteLn(ErrOutput, yyline);
|
||||
WriteLn(ErrOutput, '^':yycolno);
|
||||
end(*yyerrmsg*);
|
||||
|
||||
{$I yyinclude.pp}
|
||||
{$I yypreproc.pp}
|
||||
|
||||
(* I/O routines: *)
|
||||
|
||||
const nl = #10; (* newline character *)
|
||||
|
||||
const max_chars = 2048;
|
||||
|
||||
var
|
||||
bufptr : Integer;
|
||||
buf : array [1..max_chars] of Char;
|
||||
|
||||
function rc_get_char : Char;
|
||||
var i : Integer;
|
||||
ok : boolean;
|
||||
begin
|
||||
if (bufptr=0) and not eof(yyinput) then
|
||||
begin
|
||||
repeat
|
||||
readln(yyinput, yyline);
|
||||
inc(yylineno); yycolno := 1;
|
||||
ok:= ypreproc.useline(yyline);
|
||||
until (ok or eof(yyinput));
|
||||
if ok then begin
|
||||
buf[1] := nl;
|
||||
for i := 1 to length(yyline) do
|
||||
buf[i+1] := yyline[length(yyline)-i+1];
|
||||
inc(bufptr, length(yyline)+1);
|
||||
end;
|
||||
end;
|
||||
if bufptr>0 then
|
||||
begin
|
||||
rc_get_char := buf[bufptr];
|
||||
dec(bufptr);
|
||||
inc(yycolno);
|
||||
end
|
||||
else
|
||||
rc_get_char := #0;
|
||||
end(*get_char*);
|
||||
|
||||
procedure rc_unget_char ( c : Char );
|
||||
begin
|
||||
if bufptr=max_chars then yyerror('input buffer overflow');
|
||||
inc(bufptr);
|
||||
dec(yycolno);
|
||||
buf[bufptr] := c;
|
||||
end(*unget_char*);
|
||||
|
||||
procedure unget_string(s: string);
|
||||
var
|
||||
i: integer;
|
||||
begin
|
||||
for i:= Length(s) downto 1 do
|
||||
rc_unget_char(s[i]);
|
||||
end;
|
||||
|
||||
procedure PragmaCodePage(cp: string);
|
||||
var cpi: integer;
|
||||
begin
|
||||
if Uppercase(cp) = 'DEFAULT' then
|
||||
opt_code_page:= DefaultFileSystemCodePage
|
||||
else begin
|
||||
if TryStrToInt(cp, cpi) and (cpi>=0) and (cpi<=high(TSystemCodePage)) then
|
||||
opt_code_page:= cpi
|
||||
else
|
||||
yyerror('Invalid code_page pragma: "' + cp + '"');
|
||||
end;
|
||||
end;
|
||||
|
||||
type
|
||||
rcnumtype = record
|
||||
v: LongWord;
|
||||
long: boolean;
|
||||
end;
|
||||
|
||||
rcstrtype = record
|
||||
v: PUnicodeString;
|
||||
cp: TSystemCodePage;
|
||||
end;
|
||||
|
||||
function str_to_cbase(s: string): LongWord;
|
||||
begin
|
||||
if s = '0' then
|
||||
Exit(0);
|
||||
if Copy(s, 1, 2) = '0x' then
|
||||
Exit(StrToInt('$' + Copy(s, 3, Maxint)));
|
||||
if Copy(s, 1, 1) = '0' then
|
||||
Exit(StrToInt('&' + Copy(s, 2, Maxint)));
|
||||
Result:= StrToInt(s);
|
||||
end;
|
||||
|
||||
function str_to_num(s:string): rcnumtype;
|
||||
begin
|
||||
// this does not handle empty strings - should never get them from the lexer
|
||||
Result.long:= s[Length(s)] = 'L';
|
||||
if Result.long then
|
||||
setlength(s, Length(s) - 1);
|
||||
Result.v:= str_to_cbase(s);
|
||||
end;
|
||||
|
||||
const
|
||||
MAX_RCSTR_LEN = 4096;
|
||||
var
|
||||
strbuf: array[0..MAX_RCSTR_LEN + 1] of char;
|
||||
strbuflen: Integer;
|
||||
|
||||
procedure strbuf_begin();
|
||||
begin
|
||||
FillChar(strbuf[0], sizeof(strbuf), 0);
|
||||
strbuflen:= 0;
|
||||
end;
|
||||
|
||||
procedure strbuf_append(s: string);
|
||||
var
|
||||
rem: integer;
|
||||
begin
|
||||
rem:= MAX_RCSTR_LEN - strbuflen;
|
||||
if Length(s) < rem then
|
||||
rem:= Length(s);
|
||||
Move(s[1], strbuf[strbuflen], rem);
|
||||
inc(strbuflen, rem);
|
||||
end;
|
||||
|
||||
procedure string_new(var str: rcstrtype; val: UnicodeString; cp: TSystemCodePage);
|
||||
begin
|
||||
New(str.v);
|
||||
str.v^:= val;
|
||||
str.cp:= cp;
|
||||
end;
|
||||
|
||||
procedure string_new_uni(var str: rcstrtype; val: PAnsiChar; len: integer; cp: TSystemCodePage; escapes: boolean);
|
||||
function translateChar(c: AnsiChar): UnicodeChar;
|
||||
var
|
||||
u: UnicodeString = '';
|
||||
begin
|
||||
if cp = CP_UTF16 then
|
||||
Result:= c
|
||||
else begin
|
||||
// TODO: there has to be a better way to translate a single codepoint
|
||||
widestringmanager.Ansi2UnicodeMoveProc(@c, cp, u, 1);
|
||||
Result:= u[1];
|
||||
end;
|
||||
end;
|
||||
|
||||
var
|
||||
uni: UnicodeString;
|
||||
wc: PUnicodeChar;
|
||||
rc, endin: PAnsiChar;
|
||||
h: string;
|
||||
hexlen, i: integer;
|
||||
begin
|
||||
uni:= '';
|
||||
if not escapes then
|
||||
widestringmanager.Ansi2UnicodeMoveProc(val, cp, uni, len)
|
||||
else begin
|
||||
if cp = CP_UTF16 then
|
||||
hexlen:= 4
|
||||
else
|
||||
hexlen:= 2;
|
||||
setlength(uni, len);
|
||||
wc:= @uni[1];
|
||||
rc:= val;
|
||||
endin:= @val[len];
|
||||
while rc <= endin do begin // val must contain the final #0!
|
||||
// treat as null-terminated - nulls may exist *after* this proc, but not before
|
||||
if (rc^ = '\') then begin
|
||||
inc(rc);
|
||||
case rc^ of
|
||||
#0: exit {Error: End too soon};
|
||||
'\': wc^:= '\';
|
||||
'f': wc^:= #&14;
|
||||
'n': wc^:= #&12;
|
||||
'r': wc^:= #&15;
|
||||
't': wc^:= #&11;
|
||||
'x',
|
||||
'X': begin
|
||||
h:= '$';
|
||||
for i:= 1 to hexlen do begin
|
||||
inc(rc);
|
||||
if rc >= endin then
|
||||
exit {Error: End too soon};
|
||||
h += rc^;
|
||||
end;
|
||||
if cp = CP_UTF16 then
|
||||
wc^:= WideChar(StrToInt(h))
|
||||
else
|
||||
wc^:= translateChar(Char(StrToInt(h)));
|
||||
end;
|
||||
'0'..'7': begin
|
||||
h:= '&' + rc^;
|
||||
for i:= 2 to 3 do begin
|
||||
inc(rc);
|
||||
if (rc >= endin) or not (rc^ in ['0'..'7']) then begin
|
||||
dec(rc);
|
||||
break;
|
||||
end;
|
||||
h += rc^;
|
||||
end;
|
||||
if cp = CP_UTF16 then
|
||||
wc^:= WideChar(StrToInt(h))
|
||||
else
|
||||
wc^:= translateChar(Char(StrToInt(h)));
|
||||
end;
|
||||
else
|
||||
wc^:= translateChar(rc^);
|
||||
end;
|
||||
end else
|
||||
wc^:= translateChar(rc^);
|
||||
inc(wc);
|
||||
inc(rc);
|
||||
end;
|
||||
i:= (PtrUInt(wc) - PtrUInt(@uni[1])) div 2; // includes final wc that was not written to
|
||||
SetLength(uni, i - 1);
|
||||
end;
|
||||
string_new(str, uni, cp);
|
||||
end;
|
||||
|
||||
function Max(a, b: LongWord): LongWord; inline;
|
||||
begin
|
||||
if a > b then
|
||||
Result:= a
|
||||
else
|
||||
Result:= b;
|
||||
end;
|
||||
|
||||
var
|
||||
aktresource: TAbstractResource;
|
||||
language: TLangID;
|
||||
|
||||
procedure create_resource(aId, aType: TResourceDesc; aClass: TResourceClass);
|
||||
var
|
||||
r: TAbstractResource;
|
||||
begin
|
||||
r:= aClass.Create(aType, aId);
|
||||
r.LangID:= language;
|
||||
aktresources.Add(r);
|
||||
aktresource:= r;
|
||||
end;
|
||||
|
||||
procedure create_resource(aId, aType: TResourceDesc); overload;
|
||||
begin
|
||||
create_resource(aId, aType, TGenericResource);
|
||||
end;
|
||||
|
||||
procedure create_resource(aId: TResourceDesc; aType: Word); overload;
|
||||
var
|
||||
cls: TResourceClass;
|
||||
begin
|
||||
case aType of
|
||||
RT_BITMAP: cls:= TBitmapResource;
|
||||
RT_ICON: cls:= TGroupIconResource;
|
||||
RT_CURSOR: cls:= TGroupCursorResource;
|
||||
RT_VERSION: cls:= TVersionResource;
|
||||
else
|
||||
raise EResourceDescTypeException.CreateFmt('Resource type not supported: %d', [aType]);
|
||||
end;
|
||||
create_resource(aId, nil, cls);
|
||||
end;
|
||||
|
||||
procedure raw_write_string(Stream: TMemoryStream; str: rcstrtype);
|
||||
var
|
||||
i: integer;
|
||||
u: UnicodeString;
|
||||
r: RawByteString = '';
|
||||
begin
|
||||
u:= str.v^;
|
||||
if str.cp = CP_UTF16 then begin
|
||||
for i:=1 to length(u) do
|
||||
Stream.WriteWord(NtoLE(Word(u[i])));
|
||||
end else begin
|
||||
widestringmanager.Unicode2AnsiMoveProc(@u[1], r, str.cp, Length(u));
|
||||
Stream.WriteBuffer(r[1], Length(r));
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure raw_write_int(Stream: TMemoryStream; num: rcnumtype);
|
||||
begin
|
||||
if num.long then
|
||||
Stream.WriteDWord(NtoLE(num.v))
|
||||
else
|
||||
Stream.WriteWord(NtoLE(Word(num.v)));
|
||||
end;
|
||||
|
||||
procedure stringtable_begin();
|
||||
begin
|
||||
// create dummy resource that we will use to capture suboptions
|
||||
create_resource(TResourceDesc.create(1), TResourceDesc.create(1));
|
||||
aktresources.Remove(aktresource);
|
||||
end;
|
||||
|
||||
procedure stringtable_add(ident: Word; str: AnsiString);
|
||||
var
|
||||
table: word;
|
||||
r: TStringTableResource;
|
||||
begin
|
||||
table:= (ident div 16) + 1;
|
||||
try
|
||||
{ TODO : This is stupid }
|
||||
r:= aktresources.Find(RT_STRING, table, aktresource.LangID) as TStringTableResource;
|
||||
except
|
||||
on e: EResourceNotFoundException do begin
|
||||
r:= TStringTableResource.Create;
|
||||
r.LangID:= aktresource.LangID;
|
||||
r.MemoryFlags:= aktresource.MemoryFlags;
|
||||
r.Characteristics:= aktresource.Characteristics;
|
||||
r.Version:= aktresource.Version;
|
||||
r.FirstID:= ident;
|
||||
aktresources.Add(r);
|
||||
end;
|
||||
end;
|
||||
r.Strings[ident]:= str;
|
||||
end;
|
||||
|
||||
procedure stringtable_end();
|
||||
begin
|
||||
FreeAndNil(aktresource);
|
||||
end;
|
||||
|
||||
function make_version(a, b, c, d: Word): TFileProductVersion;
|
||||
begin
|
||||
Result[0]:= a;
|
||||
Result[1]:= b;
|
||||
Result[2]:= c;
|
||||
Result[3]:= d;
|
||||
end;
|
||||
|
||||
procedure version_string_tab_begin(lcs: AnsiString);
|
||||
var
|
||||
vst: TVersionStringTable;
|
||||
begin
|
||||
vst:= TVersionStringTable.Create(lcs);
|
||||
TVersionResource(aktresource).StringFileInfo.Add(vst);
|
||||
end;
|
||||
|
||||
procedure version_string_tab_add(key, value: AnsiString);
|
||||
begin
|
||||
TVersionResource(aktresource).StringFileInfo.Items[TVersionResource(aktresource).StringFileInfo.Count-1].Add(key, value);
|
||||
end;
|
||||
|
||||
procedure version_var_translation_add(langid, cpid: word);
|
||||
var
|
||||
ti: TVerTranslationInfo;
|
||||
begin
|
||||
ti.language:= langid;
|
||||
ti.codepage:= cpid;
|
||||
TVersionResource(aktresource).VarFileInfo.Add(ti);
|
||||
end;
|
||||
{$I rcparserfn.inc}
|
||||
|
||||
%}
|
||||
|
||||
|
||||
385
packages/fcl-res/src/rcparserfn.inc
Normal file
385
packages/fcl-res/src/rcparserfn.inc
Normal file
@ -0,0 +1,385 @@
|
||||
{%MainUnit rcparser.pas}
|
||||
|
||||
{$modeswitch advancedrecords}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
SysUtils, Classes, StrUtils, lexlib, yacclib, resource,
|
||||
acceleratorsresource, groupiconresource, stringtableresource,
|
||||
bitmapresource, versionresource, versiontypes, groupcursorresource;
|
||||
|
||||
function yyparse : Integer;
|
||||
|
||||
var
|
||||
aktresources: TResources;
|
||||
opt_code_page: TSystemCodePage;
|
||||
yyfilename: AnsiString;
|
||||
yyparseresult: YYSType;
|
||||
|
||||
procedure PragmaCodePage(cp: string);
|
||||
|
||||
{$DEFINE INC_HEADER}
|
||||
{$I yyinclude.pp}
|
||||
{$I yypreproc.pp}
|
||||
{$UNDEF INC_HEADER}
|
||||
|
||||
implementation
|
||||
|
||||
procedure yyerror ( msg : String );
|
||||
begin
|
||||
writeln(ErrOutput, yyfilename, '(',yylineno,':',yycolno,'): at "',yytext,'": ', msg);
|
||||
WriteLn(ErrOutput, yyline);
|
||||
WriteLn(ErrOutput, '^':yycolno);
|
||||
end(*yyerrmsg*);
|
||||
|
||||
{$I yyinclude.pp}
|
||||
{$I yypreproc.pp}
|
||||
|
||||
(* I/O routines: *)
|
||||
|
||||
const nl = #10; (* newline character *)
|
||||
|
||||
const max_chars = 2048;
|
||||
|
||||
var
|
||||
bufptr : Integer;
|
||||
buf : array [1..max_chars] of Char;
|
||||
|
||||
function rc_get_char : Char;
|
||||
var i : Integer;
|
||||
ok : boolean;
|
||||
begin
|
||||
if (bufptr=0) and not eof(yyinput) then
|
||||
begin
|
||||
repeat
|
||||
readln(yyinput, yyline);
|
||||
inc(yylineno); yycolno := 1;
|
||||
ok:= ypreproc.useline(yyline);
|
||||
until (ok or eof(yyinput));
|
||||
if ok then begin
|
||||
buf[1] := nl;
|
||||
for i := 1 to length(yyline) do
|
||||
buf[i+1] := yyline[length(yyline)-i+1];
|
||||
inc(bufptr, length(yyline)+1);
|
||||
end;
|
||||
end;
|
||||
if bufptr>0 then
|
||||
begin
|
||||
rc_get_char := buf[bufptr];
|
||||
dec(bufptr);
|
||||
inc(yycolno);
|
||||
end
|
||||
else
|
||||
rc_get_char := #0;
|
||||
end(*get_char*);
|
||||
|
||||
procedure rc_unget_char ( c : Char );
|
||||
begin
|
||||
if bufptr=max_chars then yyerror('input buffer overflow');
|
||||
inc(bufptr);
|
||||
dec(yycolno);
|
||||
buf[bufptr] := c;
|
||||
end(*unget_char*);
|
||||
|
||||
procedure unget_string(s: string);
|
||||
var
|
||||
i: integer;
|
||||
begin
|
||||
for i:= Length(s) downto 1 do
|
||||
rc_unget_char(s[i]);
|
||||
end;
|
||||
|
||||
procedure PragmaCodePage(cp: string);
|
||||
var cpi: integer;
|
||||
begin
|
||||
if Uppercase(cp) = 'DEFAULT' then
|
||||
opt_code_page:= DefaultFileSystemCodePage
|
||||
else begin
|
||||
if TryStrToInt(cp, cpi) and (cpi>=0) and (cpi<=high(TSystemCodePage)) then
|
||||
opt_code_page:= cpi
|
||||
else
|
||||
yyerror('Invalid code_page pragma: "' + cp + '"');
|
||||
end;
|
||||
end;
|
||||
|
||||
type
|
||||
rcnumtype = record
|
||||
v: LongWord;
|
||||
long: boolean;
|
||||
end;
|
||||
|
||||
rcstrtype = record
|
||||
v: PUnicodeString;
|
||||
cp: TSystemCodePage;
|
||||
end;
|
||||
|
||||
function str_to_cbase(s: string): LongWord;
|
||||
begin
|
||||
if s = '0' then
|
||||
Exit(0);
|
||||
if Copy(s, 1, 2) = '0x' then
|
||||
Exit(StrToInt('$' + Copy(s, 3, Maxint)));
|
||||
if Copy(s, 1, 1) = '0' then
|
||||
Exit(StrToInt('&' + Copy(s, 2, Maxint)));
|
||||
Result:= StrToInt(s);
|
||||
end;
|
||||
|
||||
function str_to_num(s:string): rcnumtype;
|
||||
begin
|
||||
// this does not handle empty strings - should never get them from the lexer
|
||||
Result.long:= s[Length(s)] = 'L';
|
||||
if Result.long then
|
||||
setlength(s, Length(s) - 1);
|
||||
Result.v:= str_to_cbase(s);
|
||||
end;
|
||||
|
||||
const
|
||||
MAX_RCSTR_LEN = 4096;
|
||||
var
|
||||
strbuf: array[0..MAX_RCSTR_LEN + 1] of char;
|
||||
strbuflen: Integer;
|
||||
|
||||
procedure strbuf_begin();
|
||||
begin
|
||||
FillChar(strbuf[0], sizeof(strbuf), 0);
|
||||
strbuflen:= 0;
|
||||
end;
|
||||
|
||||
procedure strbuf_append(s: string);
|
||||
var
|
||||
rem: integer;
|
||||
begin
|
||||
rem:= MAX_RCSTR_LEN - strbuflen;
|
||||
if Length(s) < rem then
|
||||
rem:= Length(s);
|
||||
Move(s[1], strbuf[strbuflen], rem);
|
||||
inc(strbuflen, rem);
|
||||
end;
|
||||
|
||||
procedure string_new(var str: rcstrtype; val: UnicodeString; cp: TSystemCodePage);
|
||||
begin
|
||||
New(str.v);
|
||||
str.v^:= val;
|
||||
str.cp:= cp;
|
||||
end;
|
||||
|
||||
procedure string_new_uni(var str: rcstrtype; val: PAnsiChar; len: integer; cp: TSystemCodePage; escapes: boolean);
|
||||
function translateChar(c: AnsiChar): UnicodeChar;
|
||||
var
|
||||
u: UnicodeString = '';
|
||||
begin
|
||||
if cp = CP_UTF16 then
|
||||
Result:= c
|
||||
else begin
|
||||
// TODO: there has to be a better way to translate a single codepoint
|
||||
widestringmanager.Ansi2UnicodeMoveProc(@c, cp, u, 1);
|
||||
Result:= u[1];
|
||||
end;
|
||||
end;
|
||||
|
||||
var
|
||||
uni: UnicodeString;
|
||||
wc: PUnicodeChar;
|
||||
rc, endin: PAnsiChar;
|
||||
h: string;
|
||||
hexlen, i: integer;
|
||||
begin
|
||||
uni:= '';
|
||||
if not escapes then
|
||||
widestringmanager.Ansi2UnicodeMoveProc(val, cp, uni, len)
|
||||
else begin
|
||||
if cp = CP_UTF16 then
|
||||
hexlen:= 4
|
||||
else
|
||||
hexlen:= 2;
|
||||
setlength(uni, len);
|
||||
wc:= @uni[1];
|
||||
rc:= val;
|
||||
endin:= @val[len];
|
||||
while rc <= endin do begin // val must contain the final #0!
|
||||
// treat as null-terminated - nulls may exist *after* this proc, but not before
|
||||
if (rc^ = '\') then begin
|
||||
inc(rc);
|
||||
case rc^ of
|
||||
#0: exit {Error: End too soon};
|
||||
'\': wc^:= '\';
|
||||
'f': wc^:= #&14;
|
||||
'n': wc^:= #&12;
|
||||
'r': wc^:= #&15;
|
||||
't': wc^:= #&11;
|
||||
'x',
|
||||
'X': begin
|
||||
h:= '$';
|
||||
for i:= 1 to hexlen do begin
|
||||
inc(rc);
|
||||
if rc >= endin then
|
||||
exit {Error: End too soon};
|
||||
h += rc^;
|
||||
end;
|
||||
if cp = CP_UTF16 then
|
||||
wc^:= WideChar(StrToInt(h))
|
||||
else
|
||||
wc^:= translateChar(Char(StrToInt(h)));
|
||||
end;
|
||||
'0'..'7': begin
|
||||
h:= '&' + rc^;
|
||||
for i:= 2 to 3 do begin
|
||||
inc(rc);
|
||||
if (rc >= endin) or not (rc^ in ['0'..'7']) then begin
|
||||
dec(rc);
|
||||
break;
|
||||
end;
|
||||
h += rc^;
|
||||
end;
|
||||
if cp = CP_UTF16 then
|
||||
wc^:= WideChar(StrToInt(h))
|
||||
else
|
||||
wc^:= translateChar(Char(StrToInt(h)));
|
||||
end;
|
||||
else
|
||||
wc^:= translateChar(rc^);
|
||||
end;
|
||||
end else
|
||||
wc^:= translateChar(rc^);
|
||||
inc(wc);
|
||||
inc(rc);
|
||||
end;
|
||||
i:= (PtrUInt(wc) - PtrUInt(@uni[1])) div 2; // includes final wc that was not written to
|
||||
SetLength(uni, i - 1);
|
||||
end;
|
||||
string_new(str, uni, cp);
|
||||
end;
|
||||
|
||||
function Max(a, b: LongWord): LongWord; inline;
|
||||
begin
|
||||
if a > b then
|
||||
Result:= a
|
||||
else
|
||||
Result:= b;
|
||||
end;
|
||||
|
||||
var
|
||||
aktresource: TAbstractResource;
|
||||
language: TLangID;
|
||||
|
||||
procedure create_resource(aId, aType: TResourceDesc; aClass: TResourceClass);
|
||||
var
|
||||
r: TAbstractResource;
|
||||
begin
|
||||
r:= aClass.Create(aType, aId);
|
||||
r.LangID:= language;
|
||||
aktresources.Add(r);
|
||||
aktresource:= r;
|
||||
end;
|
||||
|
||||
procedure create_resource(aId, aType: TResourceDesc); overload;
|
||||
begin
|
||||
create_resource(aId, aType, TGenericResource);
|
||||
end;
|
||||
|
||||
procedure create_resource(aId: TResourceDesc; aType: Word); overload;
|
||||
var
|
||||
cls: TResourceClass;
|
||||
begin
|
||||
case aType of
|
||||
RT_BITMAP: cls:= TBitmapResource;
|
||||
RT_ICON: cls:= TGroupIconResource;
|
||||
RT_CURSOR: cls:= TGroupCursorResource;
|
||||
RT_VERSION: cls:= TVersionResource;
|
||||
else
|
||||
raise EResourceDescTypeException.CreateFmt('Resource type not supported: %d', [aType]);
|
||||
end;
|
||||
create_resource(aId, nil, cls);
|
||||
end;
|
||||
|
||||
procedure raw_write_string(Stream: TMemoryStream; str: rcstrtype);
|
||||
var
|
||||
i: integer;
|
||||
u: UnicodeString;
|
||||
r: RawByteString = '';
|
||||
begin
|
||||
u:= str.v^;
|
||||
if str.cp = CP_UTF16 then begin
|
||||
for i:=1 to length(u) do
|
||||
Stream.WriteWord(NtoLE(Word(u[i])));
|
||||
end else begin
|
||||
widestringmanager.Unicode2AnsiMoveProc(@u[1], r, str.cp, Length(u));
|
||||
Stream.WriteBuffer(r[1], Length(r));
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure raw_write_int(Stream: TMemoryStream; num: rcnumtype);
|
||||
begin
|
||||
if num.long then
|
||||
Stream.WriteDWord(NtoLE(num.v))
|
||||
else
|
||||
Stream.WriteWord(NtoLE(Word(num.v)));
|
||||
end;
|
||||
|
||||
procedure stringtable_begin();
|
||||
begin
|
||||
// create dummy resource that we will use to capture suboptions
|
||||
create_resource(TResourceDesc.create(1), TResourceDesc.create(1));
|
||||
aktresources.Remove(aktresource);
|
||||
end;
|
||||
|
||||
procedure stringtable_add(ident: Word; str: AnsiString);
|
||||
var
|
||||
table: word;
|
||||
r: TStringTableResource;
|
||||
begin
|
||||
table:= (ident div 16) + 1;
|
||||
try
|
||||
{ TODO : This is stupid }
|
||||
r:= aktresources.Find(RT_STRING, table, aktresource.LangID) as TStringTableResource;
|
||||
except
|
||||
on e: EResourceNotFoundException do begin
|
||||
r:= TStringTableResource.Create;
|
||||
r.LangID:= aktresource.LangID;
|
||||
r.MemoryFlags:= aktresource.MemoryFlags;
|
||||
r.Characteristics:= aktresource.Characteristics;
|
||||
r.Version:= aktresource.Version;
|
||||
r.FirstID:= ident;
|
||||
aktresources.Add(r);
|
||||
end;
|
||||
end;
|
||||
r.Strings[ident]:= str;
|
||||
end;
|
||||
|
||||
procedure stringtable_end();
|
||||
begin
|
||||
FreeAndNil(aktresource);
|
||||
end;
|
||||
|
||||
function make_version(a, b, c, d: Word): TFileProductVersion;
|
||||
begin
|
||||
Result[0]:= a;
|
||||
Result[1]:= b;
|
||||
Result[2]:= c;
|
||||
Result[3]:= d;
|
||||
end;
|
||||
|
||||
procedure version_string_tab_begin(lcs: AnsiString);
|
||||
var
|
||||
vst: TVersionStringTable;
|
||||
begin
|
||||
vst:= TVersionStringTable.Create(lcs);
|
||||
TVersionResource(aktresource).StringFileInfo.Add(vst);
|
||||
end;
|
||||
|
||||
procedure version_string_tab_add(key, value: AnsiString);
|
||||
begin
|
||||
TVersionResource(aktresource).StringFileInfo.Items[TVersionResource(aktresource).StringFileInfo.Count-1].Add(key, value);
|
||||
end;
|
||||
|
||||
procedure version_var_translation_add(langid, cpid: word);
|
||||
var
|
||||
ti: TVerTranslationInfo;
|
||||
begin
|
||||
ti.language:= langid;
|
||||
ti.codepage:= cpid;
|
||||
TVersionResource(aktresource).VarFileInfo.Add(ti);
|
||||
end;
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user