+ new unit fpcp of which the class tpcppackage handles the reading and writing of package metadata from/to pcp files (equivalant to tppumodule).

git-svn-id: branches/svenbarth/packages@28842 -

.gitattributes

@@ -177,6 +177,7 @@ compiler/finput.pas svneol=native#text/plain
 compiler/fmodule.pas svneol=native#text/plain
 compiler/fpccrc.pas svneol=native#text/plain
 compiler/fpcdefs.inc svneol=native#text/plain
+compiler/fpcp.pas svneol=native#text/pascal
 compiler/fpkg.pas svneol=native#text/pascal
 compiler/fppu.pas svneol=native#text/plain
 compiler/gendef.pas svneol=native#text/plain

compiler/fpcp.pas

@@ -0,0 +1,403 @@
+{
+    Copyright (c) 2013-2014 by Free Pascal development team
+
+    This unit implements the loading and searching of package files
+
+    This program is free software; you can redistribute it and/or modify
+    it under the terms of the GNU General Public License as published by
+    the Free Software Foundation; either version 2 of the License, or
+    (at your option) any later version.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU General Public License for more details.
+
+    You should have received a copy of the GNU General Public License
+    along with this program; if not, write to the Free Software
+    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ ****************************************************************************
+}
+unit fpcp;
+
+{$i fpcdefs.inc}
+
+interface
+
+  uses
+    cclasses,
+    globtype,
+    pcp,finput,fpkg;
+
+  type
+    tpcppackage=class(tpackage)
+    private
+      loaded : boolean;
+      pcpfile : tpcpfile;
+    private
+      function openpcp:boolean;
+      function search_package(ashortname:boolean):boolean;
+      function search_package_file:boolean;
+      procedure setfilename(const fn:string;allowoutput:boolean);
+      procedure writecontainernames;
+      procedure writecontainedunits;
+      procedure readcontainernames;
+      procedure readcontainedunits;
+    public
+      constructor create(const pn:string);
+      destructor destroy; override;
+      procedure loadpcp;
+      procedure savepcp;
+      procedure initmoduleinfo(module:tmodulebase);
+      procedure addunit(module:tmodulebase);
+    end;
+
+implementation
+
+  uses
+    sysutils,
+    cfileutl,cutils,
+    systems,globals,version,
+    verbose,
+    entfile,fppu;
+
+{ tpcppackage }
+
+  function tpcppackage.openpcp: boolean;
+    var
+      pcpfiletime : longint;
+    begin
+      result:=false;
+      Writeln('Loading pcp ',pcpfilename);
+      //Message1(unit_t_ppu_loading,ppufilename,@queuecomment);
+      { Get pcpfile time (also check if the file exists) }
+      pcpfiletime:=getnamedfiletime(pcpfilename);
+      if pcpfiletime=-1 then
+       exit;
+    { Open the pcpfile }
+      //Message1(unit_u_ppu_name,ppufilename);
+      pcpfile:=tpcpfile.create(pcpfilename);
+      if not pcpfile.openfile then
+       begin
+         pcpfile.free;
+         pcpfile:=nil;
+         //Message(unit_u_ppu_file_too_short);
+         Writeln('File to short');
+         exit;
+       end;
+    { check for a valid PPU file }
+      if not pcpfile.checkpcpid then
+       begin
+         pcpfile.free;
+         pcpfile:=nil;
+         //Message(unit_u_ppu_invalid_header);
+         Writeln('Invalid PCP header');
+         exit;
+       end;
+    { check for allowed PCP versions }
+      if not (pcpfile.getversion=CurrentPCPVersion) then
+       begin
+         Writeln('Invalid PCP version: ',pcpfile.getversion);
+         //Message1(unit_u_ppu_invalid_version,tostr(ppufile.GetPPUVersion),@queuecomment);
+         pcpfile.free;
+         pcpfile:=nil;
+         exit;
+       end;
+    { check the target processor }
+      if tsystemcpu(pcpfile.header.common.cpu)<>target_cpu then
+       begin
+         pcpfile.free;
+         pcpfile:=nil;
+         Writeln('Invalid processor');
+         //Message(unit_u_ppu_invalid_processor,@queuecomment);
+         exit;
+       end;
+    { check target }
+      if tsystem(pcpfile.header.common.target)<>target_info.system then
+       begin
+         pcpfile.free;
+         pcpfile:=nil;
+         Writeln('Invalid target OS');
+         //Message(unit_u_ppu_invalid_target,@queuecomment);
+         exit;
+       end;
+  {$ifdef cpufpemu}
+     { check if floating point emulation is on?
+       fpu emulation isn't unit levelwise because it affects calling convention }
+     if ((pcpfile.header.common.flags and uf_fpu_emulation)<>0) xor
+          (cs_fp_emulation in current_settings.moduleswitches) then
+       begin
+         pcpfile.free;
+         pcpfile:=nil;
+         Writeln('Invalid FPU mode');
+         //Message(unit_u_ppu_invalid_fpumode,@queuecomment);
+         exit;
+       end;
+  {$endif cpufpemu}
+
+    { Load values to be access easier }
+      //flags:=pcpfile.header.common.flags;
+      //crc:=pcpfile.header.checksum;
+    { Show Debug info }
+      (*Message1(unit_u_ppu_time,filetimestring(ppufiletime));
+      Message1(unit_u_ppu_flags,tostr(flags));
+      Message1(unit_u_ppu_crc,hexstr(ppufile.header.checksum,8));
+      Message1(unit_u_ppu_crc,hexstr(ppufile.header.interface_checksum,8)+' (intfc)');
+      Message1(unit_u_ppu_crc,hexstr(ppufile.header.indirect_checksum,8)+' (indc)');
+      Comment(V_used,'Number of definitions: '+tostr(ppufile.header.deflistsize));
+      Comment(V_used,'Number of symbols: '+tostr(ppufile.header.symlistsize));
+      do_compile:=false;*)
+      result:=true;
+    end;
+
+  function tpcppackage.search_package(ashortname:boolean):boolean;
+    var
+      singlepathstring,
+      filename : TCmdStr;
+
+    function package_exists(const ext:string;var foundfile:TCmdStr):boolean;
+      begin
+        if CheckVerbosity(V_Tried) then
+          Writeln('Looking for package ',singlepathstring+filename+ext);
+          {Message1(unit_t_unitsearch,Singlepathstring+filename+ext)};
+        result:=FindFile(filename+ext,singlepathstring,true,foundfile);
+      end;
+
+    function package_search_path(const s:TCmdStr):boolean;
+      var
+        found : boolean;
+        hs    : TCmdStr;
+      begin
+        found:=false;
+        singlepathstring:=FixPath(s,false);
+        { Check for package file }
+        { TODO }
+        found:=package_exists({target_info.pkginfoext}'.pcp',hs);
+        if found then
+          begin
+            setfilename(hs,false);
+            found:=openpcp;
+          end;
+        result:=found;
+      end;
+
+    function search_path_list(list:TSearchPathList):boolean;
+      var
+        hp : TCmdStrListItem;
+        found : boolean;
+      begin
+        found:=false;
+        hp:=TCmdStrListItem(list.First);
+        while assigned(hp) do
+         begin
+           found:=package_search_path(hp.Str);
+           if found then
+            break;
+           hp:=TCmdStrListItem(hp.next);
+         end;
+        result:=found;
+      end;
+
+    begin
+      filename:=packagename^;
+      result:=search_path_list(packagesearchpath);
+    end;
+
+  function tpcppackage.search_package_file: boolean;
+    var
+      found : boolean;
+    begin
+      found:=false;
+      if search_package(false) then
+        found:=true;
+      if not found and
+          (length(packagename^)>8) and
+         search_package(true) then
+        found:=true;
+      result:=found;
+    end;
+
+  procedure tpcppackage.setfilename(const fn:string;allowoutput:boolean);
+    var
+      p,n : tpathstr;
+    begin
+      p:=FixPath(ExtractFilePath(fn),false);
+      n:=FixFileName(ChangeFileExt(ExtractFileName(fn),''));
+      { pcp name }
+      if allowoutput then
+        if (OutputUnitDir<>'') then
+          p:=OutputUnitDir
+        else
+          if (OutputExeDir<>'') then
+            p:=OutputExeDir;
+      pcpfilename:=p+n+{target_info.pkginfoext}'.pcp';
+    end;
+
+  procedure tpcppackage.writecontainernames;
+    begin
+      pcpfile.putstring(pplfilename);
+      //pcpfile.putstring(ppafilename);
+      pcpfile.writeentry(ibpackagefiles);
+    end;
+
+  procedure tpcppackage.writecontainedunits;
+    var
+      p : pcontainedunit;
+      i : longint;
+    begin
+      pcpfile.putlongint(containedmodules.count);
+      pcpfile.writeentry(ibstartcontained);
+      { for now we write the unit name and the ppu file name }
+      for i:=0 to containedmodules.count-1 do
+        begin
+          p:=pcontainedunit(containedmodules.items[i]);
+          pcpfile.putstring(p^.module.modulename^);
+          pcpfile.putstring(p^.ppufile);
+        end;
+      pcpfile.writeentry(ibendcontained);
+    end;
+
+  procedure tpcppackage.readcontainernames;
+    begin
+      if pcpfile.readentry<>ibpackagefiles then
+        begin
+          writeln('Error reading pcp file');
+          internalerror(424242);
+        end;
+      pplfilename:=pcpfile.getstring;
+
+      writeln('PPL filename: ',pplfilename);
+    end;
+
+  procedure tpcppackage.readcontainedunits;
+    var
+      cnt,i : longint;
+      name,path : string;
+      p : pcontainedunit;
+    begin
+      if pcpfile.readentry<>ibstartcontained then
+        begin
+          Writeln('Error reading pcp file');
+          internalerror(424242);
+        end;
+      cnt:=pcpfile.getlongint;
+      if pcpfile.readentry<>ibendcontained then
+        begin
+          Writeln('Error reading pcp file');
+          internalerror(424242);
+        end;
+      for i:=0 to cnt-1 do
+        begin
+          name:=pcpfile.getstring;
+          path:=ChangeFileExt(pcpfile.getstring,'.ppl.ppu');
+          new(p);
+          p^.module:=nil;
+          p^.ppufile:=path;
+          containedmodules.add(name,p);
+          Writeln('Found module ',name);
+        end;
+    end;
+
+    constructor tpcppackage.create(const pn: string);
+    begin
+      inherited create(pn);
+      setfilename(pn,true);
+    end;
+
+  destructor tpcppackage.destroy;
+    begin
+      pcpfile.free;
+      inherited destroy;
+    end;
+
+  procedure tpcppackage.loadpcp;
+    var
+      newpackagename : string;
+    begin
+      if loaded then
+        exit;
+
+      if not search_package_file then
+        begin
+          Comment(V_Error,'Package not found: '+realpackagename^);
+          exit;
+        end
+      else
+        Comment(V_Info,'Package found: '+realpackagename^);
+
+      if not assigned(pcpfile) then
+        internalerror(2013053101);
+
+      if pcpfile.readentry<>ibpackagename then
+        Comment(V_Error,'Error reading package: '+realpackagename^);
+      newpackagename:=pcpfile.getstring;
+      if upper(newpackagename)<>packagename^ then
+        Comment(V_Error,'Package was renamed: '+realpackagename^);
+
+      readcontainernames;
+
+      //readrequiredpackages
+
+      readcontainedunits;
+    end;
+
+  procedure tpcppackage.savepcp;
+    begin
+      { create new ppufile }
+      pcpfile:=tpcpfile.create(pcpfilename);
+      if not pcpfile.createfile then
+        Writeln('Error creating PCP file');
+        //Message(unit_f_ppu_cannot_write);
+
+      pcpfile.putstring(realpackagename^);
+      pcpfile.writeentry(ibpackagename);
+
+      writecontainernames;
+
+      //writerequiredpackages;
+
+      writecontainedunits;
+
+      //writeppus;
+
+      { the last entry ibend is written automatically }
+
+      { flush to be sure }
+      pcpfile.flush;
+      { create and write header }
+      pcpfile.header.common.size:=pcpfile.size;
+      pcpfile.header.checksum:=pcpfile.crc;
+      pcpfile.header.common.compiler:=wordversion;
+      pcpfile.header.common.cpu:=word(target_cpu);
+      pcpfile.header.common.target:=word(target_info.system);
+      //pcpfile.header.flags:=flags;
+      pcpfile.header.ppulistsize:=containedmodules.count;
+      pcpfile.header.requiredlistsize:=requiredpackages.count;
+      pcpfile.writeheader;
+
+      { save crc in current module also }
+      //crc:=pcpfile.crc;
+
+      pcpfile.closefile;
+      pcpfile.free;
+      pcpfile:=nil;
+    end;
+
+  procedure tpcppackage.initmoduleinfo(module: tmodulebase);
+    begin
+      pplfilename:=extractfilename(module.sharedlibfilename);
+    end;
+
+  procedure tpcppackage.addunit(module: tmodulebase);
+    var
+      containedunit : pcontainedunit;
+    begin
+      new(containedunit);
+      containedunit^.module:=module;
+      containedunit^.ppufile:=extractfilename(module.ppufilename);
+      containedmodules.add(module.modulename^,containedunit);
+    end;
+
+end.
+