paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-10-18 05:01:42 +02:00
Code Issues Packages Projects Releases Wiki Activity

Merged revision(s) 31988, 31991-31993, 32136, 32308-32309, 32312, 32318 from branches/svenbarth/packages:

Browse Source 
Correctly parse the directives DenyPackageUnit and WeakPackageUnit

ppu.pas:
  + add flags uf_packagedeny and uf_packageweak
scandir.pas:
  + new procedure do_moduleflagswitch() which parses a ON/OFF/+/- argument and sets or clears a flag in the current module
  + new procedure dir_denypackageunit which handles DenyPackageUnit
  * implement dir_weakpackageunit (and move to the correct location ;) )
  * InitScannerDirectives: add dir_denypackageunit handler
........
Respect DenyPackageUnit flag.

pmodules.pas, proc_package:
  * check all contained units that are not already part of a package for their uf_package_deny flag and report an error for each that has it set
........
Do not check whether all units are used as by definition all units of a package are considered as used.

pmodules.pas, proc_package:
  - remove call to current_module.allunitsused
........
Check whether a unit has been implicitely imported in a package. A unit is considered as implicitely imported if it is not part of a required package nor part of the units listed in the contains section. This note is useful (Delphi even provides a dialog in that case) as a package with implicitely imported units /might/ become incompatible with other packages (e.g. if another package includes that unit uses that package and includes that unit explicitely; of course that is the same as if both package included it explicitely, but with the hint one knows where to look).

pmodules.pas, proc_package:
  * while walking the loaded units also check whether any of them not contained in a package was part of the contained units which are the same as the current module's used units
........
Generate CRC for package files

pcp.pas, tpcpfile:
  + new field do_crc which controls CRC generation
  + override putdata() method to generate CRC when data is written
  * resetfile: enable do_crc by default
........fppu.pas, tppumodule:
  * loadfrompackage: mention if a unit is loaded from a package
........
fpkg.pas, tcontainedunit:
  + new fields offset and size for the PPU data stored inside the PCP
fpcp.pas, tpcppackage:
  * readcontainedunits & addunit: correctly initialize offset and size to 0
........
Store the modified PPU files directly inside the PCP and thus get finally rid of the .ppl.ppu files.

entfile.pas:
  + new entry type ibpputable
pkgutil.pas:
  * adjust RewritePPU to work on a stream as output instead of a filename
fpcp.pas, tpcppackage:
  + new method writepputable() which writes the offsets and sizes of all contained units (not part of CRC!)
  + new method writeppudata() which rewrites all contained PPUs directly into the PCP after the ibend entry (Note: the data is written 16 Byte aligned to ease viewing of the PCP and its contained PPUs in a hex editor)
  + new method readpputable() which reads the offsets and sizes of all contained units
  + new method getmodulestream() which returns a substream for a contained module
  * loadpcp: also call readpputable()
  * writepcp: first write an empty pputable, then finish writing all data that requires the put*/write* methods of the pcpfile, then use writeppudata() to write all PPUs and finally write the correct pputable at the original location
fppu.pas, tppumodule:
  * loadfrompackage: don't read the PPU from a file if it is contained in a package, but using the new tpcppackage.getmodulestream() and tppumodule.openppustream() methods
pmodules.pas, proc_package:
  * don't rewrite the PPUs here
pcp.pas:
  * increase CurrentPCPVersion
........
Fix cycling

........

git-svn-id: trunk@33514 -
This commit is contained in:
svenbarth 2016-04-15 13:39:41 +00:00
parent fca1a74244
commit 7d8d0340b9
9 changed files with 211 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
compiler/entfile.pas
View File

@ -38,6 +38,7 @@ const
subentryid = 2;
{special}
iberror = 0;
ibpputable = 243;
ibstartrequireds = 244;
ibendrequireds = 245;
ibstartcontained = 246;

130
compiler/fpcp.pas
View File

@ -26,7 +26,7 @@ unit fpcp;
interface
uses
cclasses,
cclasses,cstreams,
globtype,
pcp,finput,fpkg;
@ -43,14 +43,18 @@ interface
procedure writecontainernames;
procedure writecontainedunits;
procedure writerequiredpackages;
procedure writepputable;
procedure writeppudata;
procedure readcontainernames;
procedure readcontainedunits;
procedure readrequiredpackages;
procedure readpputable;
public
constructor create(const pn:string);
destructor destroy; override;
procedure loadpcp;
procedure savepcp;
function getmodulestream(module:tmodulebase):tcstream;
procedure initmoduleinfo(module:tmodulebase);
procedure addunit(module:tmodulebase);
end;
@ -62,7 +66,7 @@ implementation
cfileutl,cutils,
systems,globals,version,
verbose,
entfile,fppu,ppu;
entfile,fppu,ppu,pkgutil;
{ tpcppackage }
@ -265,6 +269,59 @@ implementation
pcpfile.writeentry(ibendrequireds);
end;
procedure tpcppackage.writepputable;
var
module : pcontainedunit;
i : longint;
begin
{ no need to write the count again; it's the same as for the contained units }
for i:=0 to containedmodules.count-1 do
begin
module:=pcontainedunit(containedmodules[i]);
pcpfile.putlongint(module^.offset);
pcpfile.putlongint(module^.size);
end;
pcpfile.writeentry(ibpputable);
end;
procedure tpcppackage.writeppudata;
const
align: array[0..15] of byte = (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0);
var
i,j,
pos,
rem : longint;
module : pcontainedunit;
stream : TCStream;
begin
pcpfile.flush;
for i:=0 to containedmodules.count-1 do
begin
module:=pcontainedunit(containedmodules[i]);
pos:=pcpfile.position;
{ align to 16 byte so that it can be nicely viewed in hex editors;
maybe we could also use 512 byte alignment instead }
rem:=$f-(pos and $f);
pcpfile.stream.write(align[0],rem+1);
pcpfile.flush;
module^.offset:=pcpfile.position;
{ retrieve substream for the current position }
stream:=pcpfile.substream(module^.offset,-1);
rewriteppu(module^.module.ppufilename,stream);
module^.size:=stream.position;
stream.free;
end;
pos:=pcpfile.position;
{ align to 16 byte so that it can be nicely viewed in hex editors;
maybe we could also use 512 byte alignment instead }
rem:=$f-(pos and $f);
pcpfile.stream.write(align[0],rem+1);
end;
procedure tpcppackage.readcontainernames;
begin
if pcpfile.readentry<>ibpackagefiles then
@ -297,10 +354,12 @@ implementation
for i:=0 to cnt-1 do
begin
name:=pcpfile.getstring;
path:=ChangeFileExt(pcpfile.getstring,'.ppl.ppu');
path:=pcpfile.getstring;
new(p);
p^.module:=nil;
p^.ppufile:=path;
p^.offset:=0;
p^.size:=0;
containedmodules.add(name,p);
message1(package_u_contained_unit,name);
end;
@ -330,6 +389,24 @@ implementation
end;
end;
procedure tpcppackage.readpputable;
var
module : pcontainedunit;
i : longint;
begin
if pcpfile.readentry<>ibpputable then
begin
message(package_f_pcp_read_error);
internalerror(2015103001);
end;
for i:=0 to containedmodules.count-1 do
begin
module:=pcontainedunit(containedmodules[i]);
module^.offset:=pcpfile.getlongint;
module^.size:=pcpfile.getlongint;
end;
end;
constructor tpcppackage.create(const pn: string);
begin
inherited create(pn);
@ -371,9 +448,14 @@ implementation
readrequiredpackages;
readcontainedunits;
readpputable;
end;
procedure tpcppackage.savepcp;
var
tablepos,
oldpos : longint;
begin
{ create new ppufile }
pcpfile:=tpcpfile.create(pcpfilename);
@ -389,7 +471,16 @@ implementation
writecontainedunits;
//writeppus;
{ the offsets and the contents of the ppus are not crc'd }
pcpfile.do_crc:=false;
pcpfile.flush;
tablepos:=pcpfile.position;
{ this will write a table with empty entries }
writepputable;
pcpfile.do_crc:=true;
{ the last entry ibend is written automatically }
@ -406,6 +497,18 @@ implementation
pcpfile.header.requiredlistsize:=requiredpackages.count;
pcpfile.writeheader;
{ write the ppu table which will also fill the offsets/sizes }
writeppudata;
pcpfile.flush;
oldpos:=pcpfile.position;
{ now write the filled PPU table at the previously stored position }
pcpfile.position:=tablepos;
writepputable;
pcpfile.position:=oldpos;
{ save crc in current module also }
//crc:=pcpfile.crc;
@ -414,6 +517,23 @@ implementation
pcpfile:=nil;
end;
function tpcppackage.getmodulestream(module:tmodulebase):tcstream;
var
i : longint;
contained : pcontainedunit;
begin
for i:=0 to containedmodules.count-1 do
begin
contained:=pcontainedunit(containedmodules[i]);
if contained^.module=module then
begin
result:=pcpfile.substream(contained^.offset,contained^.size);
exit;
end;
end;
result:=nil;
end;
procedure tpcppackage.initmoduleinfo(module: tmodulebase);
begin
pplfilename:=extractfilename(module.sharedlibfilename);
@ -426,6 +546,8 @@ implementation
new(containedunit);
containedunit^.module:=module;
containedunit^.ppufile:=extractfilename(module.ppufilename);
containedunit^.offset:=0;
containedunit^.size:=0;
containedmodules.add(module.modulename^,containedunit);
end;

2
compiler/fpkg.pas
View File

@ -34,6 +34,8 @@ interface
tcontainedunit=record
module:tmodulebase;
ppufile:tpathstr;
offset:longint;
size:longint;
end;
pcontainedunit=^tcontainedunit;

18
compiler/fppu.pas
View File

@ -127,7 +127,7 @@ uses
aasmbase,ogbase,
parser,
comphook,
entfile,fpkg;
entfile,fpkg,fpcp;
var
@ -517,7 +517,7 @@ var
end;
function tppumodule.loadfrompackage: boolean;
var
(*var
singlepathstring,
filename : TCmdStr;
@ -540,7 +540,7 @@ var
if Found then
Begin
SetFileName(hs,false);
Found:=openppufile;
//Found:=OpenPPU;
End;
PPUSearchPath:=Found;
end;
@ -560,12 +560,13 @@ var
hp:=TCmdStrListItem(hp.next);
end;
SearchPathList:=found;
end;
end;*)
var
pkg : ppackageentry;
pkgunit : pcontainedunit;
i,idx : longint;
strm : TCStream;
begin
result:=false;
for i:=0 to packagelist.count-1 do
@ -580,10 +581,17 @@ var
pkgunit:=pcontainedunit(pkg^.package.containedmodules[idx]);
if not assigned(pkgunit^.module) then
pkgunit^.module:=self;
filename:=pkgunit^.ppufile;
{ ToDo: check whether we really don't need this anymore }
{filename:=pkgunit^.ppufile;
if not SearchPathList(unitsearchpath) then
exit};
strm:=tpcppackage(pkg^.package).getmodulestream(self);
if not assigned(strm) then
internalerror(2015103002);
if not openppustream(strm) then
exit;
package:=pkg^.package;
Message2(unit_u_loading_from_package,modulename^,pkg^.package.packagename^);
{ now load the unit and all used units }
load_interface;

18
compiler/pcp.pas
View File

@ -29,7 +29,7 @@ interface
cstreams,entfile;
const
CurrentPCPVersion=2;
CurrentPCPVersion=3;
{ unit flags }
//uf_init = $000001; { unit has initialization section }
@ -59,6 +59,7 @@ interface
header : tpcpheader;
{ crc for the entire package }
crc : cardinal;
do_crc : boolean;
protected
function getheadersize:longint;override;
function getheaderaddr:pentryheader;override;
@ -68,10 +69,14 @@ interface
public
procedure writeheader;override;
function checkpcpid:boolean;
procedure putdata(const b;len:integer);override;
end;
implementation
uses
fpccrc;
{ tpcpfile }
function tpcpfile.getheadersize: longint;
@ -142,6 +147,7 @@ implementation
procedure tpcpfile.resetfile;
begin
crc:=0;
do_crc:=true;
end;
@ -184,5 +190,15 @@ implementation
end;
procedure tpcpfile.putdata(const b;len:integer);
begin
if do_crc then
begin
crc:=UpdateCrc32(crc,b,len);
end;
inherited putdata(b, len);
end;
end.

24
compiler/pkgutil.pas
View File

@ -27,10 +27,10 @@ unit pkgutil;
interface
uses
fmodule,fpkg,link;
fmodule,fpkg,link,cstreams;
procedure createimportlibfromexternals;
Function RewritePPU(const PPUFn,PPLFn:String):Boolean;
Function RewritePPU(const PPUFn:String;OutStream:TCStream):Boolean;
procedure export_unit(u:tmodule);
procedure load_packages;
procedure add_package(const name:string;ignoreduplicates:boolean);
@ -195,7 +195,7 @@ implementation
varexport(make_mangledname('THREADVARLIST',u.globalsymtable,''));
end;
Function RewritePPU(const PPUFn,PPLFn:String):Boolean;
Function RewritePPU(const PPUFn:String;OutStream:TCStream):Boolean;
Var
MakeStatic : Boolean;
Var
@ -261,11 +261,8 @@ implementation
MakeStatic:=true;
end;
{ Create the new ppu }
if PPUFn=PPLFn then
outppu:=tppufile.create('ppumove.$$$')
else
outppu:=tppufile.create(PPLFn);
outppu.createfile;
outppu:=tppufile.create(PPUFn);
outppu.createstream(OutStream);
{ Create new header, with the new flags }
outppu.header:=inppu.header;
outppu.header.common.flags:=outppu.header.common.flags or uf_in_library;
@ -379,17 +376,6 @@ implementation
outppu.writeheader;
outppu.free;
inppu.free;
{ rename }
if PPUFn=PPLFn then
begin
{$push}{$I-}
assign(f,PPUFn);
erase(f);
assign(f,'ppumove.$$$');
rename(f,PPUFn);
{$pop}
if ioresult<>0 then;
end;
Result:=True;
end;

32
compiler/pmodules.pas
View File

@ -1534,6 +1534,27 @@ type
{ All units are read, now give them a number }
current_module.updatemaps;
hp:=tmodule(loaded_units.first);
while assigned(hp) do
begin
if (hp<>current_module) and not assigned(hp.package) then
begin
if (hp.flags and uf_package_deny) <> 0 then
message1(package_e_unit_deny_package,hp.realmodulename^);
{ part of the package's used, aka contained units? }
uu:=tused_unit(current_module.used_units.first);
while assigned(uu) do
begin
if uu.u=hp then
break;
uu:=tused_unit(uu.next);
end;
if not assigned(uu) then
message2(package_n_implicit_unit_import,hp.realmodulename^,current_module.realmodulename^);
end;
hp:=tmodule(hp.next);
end;
{Insert the name of the main program into the symbol table.}
if current_module.realmodulename^<>'' then
tabstractunitsymtable(current_module.localsymtable).insertunit(cunitsym.create(current_module.realmodulename^,current_module));
@ -1574,7 +1595,7 @@ type
tstoredsymtable(current_module.localsymtable).allprivatesused;
tstoredsymtable(current_module.localsymtable).check_forwards;
current_module.allunitsused;
{ Note: all contained units are considered as used }
end;
if target_info.system in systems_windows then
@ -1693,15 +1714,6 @@ type
pkg.initmoduleinfo(current_module);
{ finally rewrite all units included into the package }
uu:=tused_unit(usedunits.first);
while assigned(uu) do
begin
if not assigned(uu.u.package) then
RewritePPU(uu.u.ppufilename,uu.u.ppufilename);
uu:=tused_unit(uu.next);
end;
{ create the executable when we are at level 1 }
if (compile_level=1) then
begin

2
compiler/ppu.pas
View File

@ -76,6 +76,8 @@ const
uf_i8086_far_data = $4000000; { this unit uses an i8086 memory model with far data (i.e. compact or large) }
uf_i8086_huge_data = $8000000; { this unit uses an i8086 memory model with huge data (i.e. huge) }
uf_i8086_cs_equals_ds = $10000000; { this unit uses an i8086 memory model with CS=DS (i.e. tiny) }
uf_package_deny = $20000000; { this unit must not be part of a package }
uf_package_weak = $40000000; { this unit may be completely contained in a package }
type
{ bestreal is defined based on the target architecture }

27
compiler/scandir.pas
View File

@ -118,6 +118,18 @@ unit scandir;
end;
procedure do_moduleflagswitch(flag:cardinal);
var
state : char;
begin
state:=current_scanner.readstate;
if state='-' then
current_module.flags:=current_module.flags and not flag
else
current_module.flags:=current_module.flags or flag;
end;
procedure do_message(w:integer);
begin
current_scanner.skipspace;
@ -367,6 +379,11 @@ unit scandir;
do_delphiswitch('D');
end;
procedure dir_denypackageunit;
begin
do_moduleflagswitch(uf_package_deny);
end;
procedure dir_description;
begin
if not (target_info.system in systems_all_windows+[system_i386_os2,system_i386_emx,
@ -1565,6 +1582,11 @@ unit scandir;
do_setverbose('W');
end;
procedure dir_weakpackageunit;
begin
do_moduleflagswitch(uf_package_weak);
end;
procedure dir_writeableconst;
begin
do_delphiswitch('J');
@ -1663,10 +1685,6 @@ unit scandir;
do_localswitch(cs_hugeptr_comparison_normalization);
end;
procedure dir_weakpackageunit;
begin
end;
procedure dir_codealign;
var
s : string;
@ -1755,6 +1773,7 @@ unit scandir;
AddDirective('COPYRIGHT',directive_all, @dir_copyright);
AddDirective('D',directive_all, @dir_description);
AddDirective('DEBUGINFO',directive_all, @dir_debuginfo);
AddDirective('DENYPACKAGEUNIT',directive_all,@dir_denypackageunit);
AddDirective('DESCRIPTION',directive_all, @dir_description);
AddDirective('ENDREGION',directive_all, @dir_endregion);
AddDirective('ERROR',directive_all, @dir_error);