* More flexible fileinfo unit (bug 17252)

git-svn-id: trunk@17753 -

packages/fcl-base/src/win/fileinfo.pp

@@ -15,6 +15,12 @@
 
  Based on getver by Bernd Juergens - Munich, Germany
  email :[email protected]
+ 
+ reworked by Stoian Ivanov ([email protected])
+     Added ExtraVersionStrings,TryHardcodedTrans.
+     Using VersionCategories.Objects as TransID storage,
+     which is used later by getVersionSetting
+
 
  Usage : Drop component on form. Set desired file name using
          FileVersionInfo.filename := 'c:\winnt\system32\comctl32.dll'
@@ -26,7 +32,9 @@
          showMessage(FileVersionInfo1.getVersionSetting('ProductVersion'));
 }
 unit fileinfo;
+
 {$mode objfpc}
+{$h+}
 interface
 
 uses
@@ -35,28 +43,39 @@ uses
 
 { Record to receive charset }
 type TTranslation = record
-   langID  : WORD;
-   charset  : WORD;
+  case byte of 
+   1: (langID,charset  : WORD);
+   2: (transid:Dword);
 end;
 
+PTranslation=^TTranslation;
+
 type
+  { TFileVersionInfo }
+
   TFileVersionInfo = class(TComponent)
   private
     FFileName : String;
     FmyVersionStrings : TStringList;
-    FmyVersionCategories    : TStringList;
+    FmyVersionCategories : TStringList;
 
-    procedure SetFileName (inp : string);
+    FmyExtraVersionStrings :TStringList;
+    FmyTryHardcodedTrans :TStringList;
+  
+    procedure SetFileName (Const inp : string);
     procedure readVersionFromFile;
-  protected
   public
-     constructor Create(AOwner: TComponent);  override;
-     destructor Destroy; override;
-     function getVersionSetting(inp : string): String;
+    constructor Create(AOwner: TComponent);  override;
+    destructor Destroy; override;
+    procedure AddExtraVersionString (Const extrafield:string);
+    procedure AddTryHardcodedTrans (Const hardtrans:string);
+    function getVersionSetting(Const inp : string; transid:dword=0): String;
   published
     property fileName : string  read FFileName write SetFileName;
     property VersionStrings  : TStringList  read FmyVersionStrings;
     property VersionCategories : TStringList read FmyVersionCategories;
+    property ExtraVersionStrings : TStringList read FmyExtraVersionStrings;
+    property TryHardcodedTrans :TStringList read FmyTryHardcodedTrans;
   end;
 
 implementation
@@ -67,7 +86,13 @@ constructor TFileVersionInfo.Create(AOwner: TComponent);
 begin
   inherited Create(AOwner);
   FmyVersionStrings := TStringList.Create;
+  FmyVersionStrings.Duplicates:=dupAccept;
   FmyVersionCategories  := TStringList.Create;
+  FmyVersionCategories.Duplicates:=dupAccept;
+  FmyExtraVersionStrings := TStringList.Create;
+  FmyExtraVersionStrings.Duplicates:= dupIgnore;
+  FmyTryHardcodedTrans:=TStringList.Create;
+  FmyTryHardcodedTrans.Duplicates:=dupIgnore;
   FFileName := '';
 end;
 
@@ -75,42 +100,56 @@ destructor TFileVersionInfo.Destroy;
 begin
   FmyVersionCategories.Free;
   FmyVersionStrings.Free;
+  FmyExtraVersionStrings.Free;
+  FmyTryHardcodedTrans.free;
   inherited;
 end;
 
-{ Get filename, check if file exists and read info from file }
-procedure TFileVersionInfo.SetFileName (inp : string);
+{if you need other version strings extracted you add them here}
+procedure TFileVersionInfo.AddExtraVersionString(Const extrafield: string); 
 begin
-    FmyVersionStrings.clear;
-    FmyVersionCategories.clear;
+  FmyExtraVersionStrings.add (extrafield);
+end;
 
-    if fileexists(inp) then
+{some broken DLLs report wrong translations and you need to try some hardcoded transes
+like NPSWF32.dll reports 040904b0(English/Unicode) but they are actualy 040904E4 (English/Latin1)}
+procedure TFileVersionInfo.AddTryHardcodedTrans(Const hardtrans: string);
+begin
+  FmyTryHardcodedTrans.add(hardtrans);
+end;
+
+{ Get filename, check if file exists and read info from file }
+procedure TFileVersionInfo.SetFileName (Const inp : string);
+begin
+  FmyVersionStrings.clear;
+  FmyVersionCategories.clear;
+  if FileExists(inp) then
     begin
-         FFileName := inp;
-         readVersionFromFile;
+    FFileName := inp;
+    readVersionFromFile;
     end
-    else
-    begin
-         FFileName := '';
-    end;
+  else
+    FFileName := '';
 end;
 
 { read info from file }
 procedure TFileVersionInfo.readVersionFromFile;
-var struSize : Dword;
-    dwBytes,someDummy : Dword;
-    a,txt : array[0..256] of char;
-    p : pchar;
-    i : integer;
-    pp : pointer;
-    theFixedInfo : TVSFixedFileInfo;
-    theTrans : TTranslation;
-    s : string;
-    ts  : TStringList;
+var
+  struSize : Dword;
+  dwBytes : Dword;
+  dwTransBytes:Dword;
+  vi : pointer;
+  ti,i,hti : integer;
+  pp : pointer;
+  theTrans : PTranslation;
+  s : string;
+  ts  : TStringList;
+  transstr:String;
+  //s_w : Widestring; //urf or not really does not matter
 begin
   ts := TStringList.Create;
   try
-    ts.add('Comments');
+    ts.Assign(FmyExtraVersionStrings);
     ts.add('CompanyName');
     ts.add('FileDescription');
     ts.add('FileVersion');
@@ -119,58 +158,80 @@ begin
     ts.add('OriginalFilename');
     ts.add('ProductName');
     ts.add('ProductVersion');
-
-    strPCopy(a,FFileName);
-    { get size of data }
-    struSize := GetFileVersionInfoSize(a,@someDummy);
+    struSize := GetFileVersionInfoSize(Pchar(FFileName),nil);
     if struSize=0 then exit;
-    p := NIL;
+    vi := NIL;
+    { get memory }
+    GetMem(vi,struSize+10);
     try
-      { get memory }
-      GetMem(p,struSize+10);
+      if (vi=nil) then
+        exit;
       { get data }
-      if not GetFileVersionInfo(a,0,struSize,p) then exit;
-      { get root info }
-      if not VerQueryValue(p,'\',pp,dwBytes) then exit;
-      move(pp^,theFixedInfo,dwBytes);
-
+      if not GetFileVersionInfo(PChar(FFileName),0,struSize,vi) then
+        exit;
       { get translation info }
-      if not VerQueryValue(p,'\VarFileInfo\Translation',pp,dwBytes) then
+      if not VerQueryValue(vi,'\VarFileInfo\Translation',theTrans,dwTransBytes) then 
         exit;
-      move(pp^,theTrans,dwBytes);
-
-      { iterate over defined items }
-      for i:=0 to ts.count-1 do
-      begin
-        s := '\StringFileInfo\'+inttohex(theTrans.langID,4)+inttohex(theTrans.charset,4)+'\'+ts[i];
-        StrPCopy(a,s);
-        if not VerQueryValue(p,a,pp,dwBytes) then Continue;
-        if dwBytes>0 then
+      while (dwTransBytes>=sizeof(TTranslation)) do 
         begin
-         move(pp^,txt,dwBytes);
-         FmyVersionCategories.add(ts[i]);
-         FmyVersionStrings.add(StrPas(txt));
-        end
-      end;
+        transstr:=inttohex(theTrans^.langID,4)+inttohex(theTrans^.charset,4);
+        { iterate over defined items }
+        for i:=0 to ts.count-1 do 
+          begin
+          s:='\StringFileInfo\'+transstr+'\'+ts[i]+#0;
+          if not VerQueryValue(vi,@s[1],pp,dwBytes) then continue;
+          if dwBytes>0 then 
+            begin
+            SetLength(s,dwBytes-1);
+            move(pp^,s[1],dwBytes-1);
+            FmyVersionCategories.AddObject(LowerCase(ts[i]),TObject(pointer(theTrans^.transid)));
+            FmyVersionStrings.add(s);
+            end
+          end;
+        inc (theTrans);
+        dec (dwTransBytes,sizeof(TTranslation));
+        end;
+        
+      {Now with the dirty hardcoded hack}
+      for hti:=0 to FmyTryHardcodedTrans.Count-1 do 
+        begin
+        transstr:=FmyTryHardcodedTrans[hti];
+        for i:=0 to ts.count-1 do 
+          begin
+          s := '\StringFileInfo\'+transstr+'\'+ts[i]+#0;
+          if VerQueryValue(vi,@s[1],pp,dwBytes) and (dwbytes>0) then
+            begin
+            SetLength(s,dwBytes-1);
+            move(pp^,s[1],dwBytes-1);
+            FmyVersionCategories.AddObject(LowerCase(ts[i]),TObject(pointer(theTrans^.transid)));
+            FmyVersionStrings.add(s);
+            end
+          end;
+        end;
     finally
-      { release memory }
-      FreeMem(p);
-    end;
-  finally ts.Free end;
+      FreeMem(vi);
+    end;  
+  Finally  
+    ts.Free
+  end;  
 end;
 
 { get single version string }
-function TFileVersionInfo.getVersionSetting(inp : string): String;
-var i : integer;
+function TFileVersionInfo.getVersionSetting(Const inp : string; transid:dword=0): String;
+var
+  i : integer;
+  s,v : string;
 begin
-  inp:=LowerCase(inp);
-  for i:= 0 to FmyVersionCategories.Count -1 do
-    if LowerCase(FmyVersionCategories[i])=inp then
+  s:=LowerCase(inp);
+  I:=0;
+  Result:='';
+  While (Result='') and (i<FmyVersionCategories.Count -1) do
     begin
-      result := FmyVersionStrings[i];
-      Exit;
+    V:=FmyVersionCategories[i];
+    if (V=S) and ((transid=0) or (transid=dword(pointer(FmyVersionCategories.Objects[i])))) then
+      Result:=V;
+    inc(I);
     end;
-  result := '';
 end;
 
 end.