+arm/wince more fcl units : process, fileinfo

*types.pp : new define Win32orCE added

git-svn-id: trunk@2051 -

.gitattributes

@@ -1041,7 +1041,9 @@ fcl/win32/syncobjs.pp svneol=native#text/plain
 fcl/win32/winreg.inc svneol=native#text/plain
 fcl/wince/eventlog.inc svneol=native#text/plain
 fcl/wince/ezcgi.inc svneol=native#text/plain
+fcl/wince/fileinfo.pp svneol=native#text/plain
 fcl/wince/pipes.inc svneol=native#text/plain
+fcl/wince/process.inc svneol=native#text/plain
 fcl/xml/Makefile svneol=native#text/plain
 fcl/xml/Makefile.fpc svneol=native#text/plain
 fcl/xml/README -text

fcl/Makefile

@@ -1,5 +1,5 @@
 #
-# Don't edit, this file is generated by FPCMake Version 2.0.0 [2005/12/10]
+# Don't edit, this file is generated by FPCMake Version 2.0.0 [2005/12/26]
 #
 default: all
 MAKEFILETARGETS=i386-linux i386-go32v2 i386-win32 i386-os2 i386-freebsd i386-beos i386-netbsd i386-solaris i386-qnx i386-netware i386-openbsd i386-wdosx i386-emx i386-watcom i386-netwlibc i386-wince m68k-linux m68k-freebsd m68k-netbsd m68k-amiga m68k-atari m68k-openbsd m68k-palmos powerpc-linux powerpc-netbsd powerpc-macos powerpc-darwin powerpc-morphos sparc-linux sparc-netbsd sparc-solaris x86_64-linux x86_64-freebsd x86_64-win64 arm-linux arm-wince powerpc64-linux
@@ -392,7 +392,7 @@ ifeq ($(FULL_TARGET),i386-netwlibc)
 override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex  resolve ssockets syncobjs
 endif
 ifeq ($(FULL_TARGET),i386-wince)
-override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex
+override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex  process fileinfo
 endif
 ifeq ($(FULL_TARGET),m68k-linux)
 override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex  process resolve ssockets fpasync syncobjs simpleipc msgintf dbugintf
@@ -452,7 +452,7 @@ ifeq ($(FULL_TARGET),arm-linux)
 override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex  process resolve ssockets fpasync syncobjs simpleipc msgintf dbugintf
 endif
 ifeq ($(FULL_TARGET),arm-wince)
-override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex
+override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex  process fileinfo
 endif
 ifeq ($(FULL_TARGET),powerpc64-linux)
 override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex  process resolve ssockets fpasync syncobjs simpleipc msgintf dbugintf
@@ -2035,8 +2035,8 @@ ifeq ($(FULL_TARGET),i386-wince)
 REQUIRE_PACKAGES_RTL=1
 REQUIRE_PACKAGES_HASH=1
 REQUIRE_PACKAGES_PASZLIB=1
-REQUIRE_PACKAGES_PASJPEG=1
 REQUIRE_PACKAGES_NETDB=1
+REQUIRE_PACKAGES_PASJPEG=1
 REQUIRE_PACKAGES_LIBASYNC=1
 endif
 ifeq ($(FULL_TARGET),m68k-linux)
@@ -2263,8 +2263,8 @@ ifeq ($(FULL_TARGET),arm-wince)
 REQUIRE_PACKAGES_RTL=1
 REQUIRE_PACKAGES_HASH=1
 REQUIRE_PACKAGES_PASZLIB=1
-REQUIRE_PACKAGES_PASJPEG=1
 REQUIRE_PACKAGES_NETDB=1
+REQUIRE_PACKAGES_PASJPEG=1
 REQUIRE_PACKAGES_LIBASYNC=1
 endif
 ifeq ($(FULL_TARGET),powerpc64-linux)

fcl/Makefile.fpc

@@ -14,6 +14,7 @@ packages_darwin=netdb libasync pthreads
 packages_netbsd=netdb libasync
 packages_openbsd=netdb libasync
 packages_win32=netdb
+packages_wince=netdb
 packages_os2=netdb
 packages_emx=netdb
 
@@ -32,6 +33,7 @@ units_netbsd=process ssockets resolve fpasync simpleipc msgintf dbugintf
 units_openbsd=process ssockets resolve fpasync simpleipc msgintf dbugintf
 units_linux=process resolve ssockets fpasync syncobjs simpleipc msgintf dbugintf
 units_win32=process fileinfo resolve ssockets syncobjs simpleipc msgintf dbugintf
+units_wince=process fileinfo
 units_os2=resolve ssockets
 units_emx=resolve ssockets
 units_netware=resolve ssockets

fcl/wince/fileinfo.pp

@@ -0,0 +1,172 @@
+{
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 1999-2000 by the Free Pascal development team
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    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.
+
+ **********************************************************************}
+
+{
+
+ Based on getver by Bernd Juergens - Munich, Germany
+ email :bernd@promedico.com
+
+ Usage : Drop component on form. Set desired file name using
+         FileVersionInfo.filename := 'c:\winnt\system32\comctl32.dll'
+         or something like that.
+         Read StringLists VersionStrings and VersionCategories.
+
+         or check a single entry:
+         FileVersionInfo1.fileName := 'd:\winnt\system32\comctl32.dll';
+         showMessage(FileVersionInfo1.getVersionSetting('ProductVersion'));
+}
+unit fileinfo;
+{$mode objfpc}
+interface
+
+uses
+  Windows, SysUtils, Classes;
+
+
+{ Record to receive charset }
+type TTranslation = record
+   langID  : WORD;
+   charset  : WORD;
+end;
+
+type
+  TFileVersionInfo = class(TComponent)
+  private
+    FFileName : WideString;
+    FmyVersionStrings : TStringList;
+    FmyVersionCategories    : TStringList;
+
+    procedure SetFileName (const cwsFile : Widestring);
+    procedure readVersionFromFile;
+  protected
+  public
+     constructor Create(AOwner: TComponent);  override;
+     destructor Destroy; override;
+     function getVersionSetting(inp : string): String;
+  published
+    property fileName : widestring  read FFileName write SetFileName;
+    property VersionStrings  : TStringList  read FmyVersionStrings;
+    property VersionCategories : TStringList read FmyVersionCategories;
+  end;
+
+implementation
+
+
+{ initialize everything }
+constructor TFileVersionInfo.Create(AOwner: TComponent);
+begin
+  inherited Create(AOwner);
+  FmyVersionStrings := TStringList.Create;
+  FmyVersionCategories  := TStringList.Create;
+  FFileName := '';
+end;
+
+destructor TFileVersionInfo.Destroy;
+begin
+  FmyVersionCategories.Free;
+  FmyVersionStrings.Free;
+  inherited;
+end;
+
+{ Get filename, check if file exists and read info from file }
+procedure TFileVersionInfo.SetFileName (const cwsFile : Widestring);
+begin
+    FmyVersionStrings.clear;
+    FmyVersionCategories.clear;
+
+    if fileexists(cwsFile) then
+    begin
+         FFileName := cwsFile;
+         readVersionFromFile;
+    end
+    else
+    begin
+         FFileName := '';
+    end;
+end;
+
+{ read info from file }
+procedure TFileVersionInfo.readVersionFromFile;
+var dwHandle, dwSize : Longword;
+    p : pwidechar;
+    i : integer;
+    pp : pointer;
+    theFixedInfo : TVSFixedFileInfo;
+    theTrans : TTranslation;
+    s : widestring;
+    ts  : TStringList;
+begin
+  ts := TStringList.Create;
+  try
+    ts.add('CompanyName');
+    ts.add('FileDescription');
+    ts.add('FileVersion');
+    ts.add('InternalName');
+    ts.add('LegalCopyright');
+    ts.add('OriginalFilename');
+    ts.add('ProductName');
+    ts.add('ProductVersion');
+
+    { get size of data }
+    dwSize := GetFileVersionInfoSize(PWidechar(FFilename),@dwHandle);
+    if dwSize=0 then exit;
+    p := NIL;
+    try
+      { get memory }
+      GetMem(p,dwSize+10);
+      { get data }
+      if not GetFileVersionInfo(PWidechar(FFilename),0,dwSize,p) then exit;
+      { get root info }
+      if not VerQueryValue(p,'\',pp,PUINT(dwSize)) then exit;
+      move(pp^,theFixedInfo,dwSize);
+
+      { get translation info }
+      if not VerQueryValue(p,'\VarFileInfo\Translation',pp,PUINT(dwSize)) then
+        exit;
+      move(pp^,theTrans,dwSize);
+
+      { iterate over defined items }
+      for i:=0 to ts.count-1 do
+      begin
+        s := WideFormat('\StringFileInfo\%4x%4x\%s',[theTrans.langID,theTrans.charset,ts[i]]);
+        if not VerQueryValue(p,PWideChar(s),pp,PUINT(dwSize)) then Continue;
+        if dwSize>0 then
+        begin
+         SetLength(s,dwSize);
+         move(pp^,s,dwSize);
+         FmyVersionCategories.add(ts[i]);
+         FmyVersionStrings.add(s);
+        end
+      end;
+    finally
+      { release memory }
+      FreeMem(p);
+    end;
+  finally ts.Free end;
+end;
+
+{ get single version string }
+function TFileVersionInfo.getVersionSetting(inp : string): String;
+var i : integer;
+begin
+  inp:=LowerCase(inp);
+  for i:= 0 to FmyVersionCategories.Count -1 do
+    if LowerCase(FmyVersionCategories[i])=inp then
+    begin
+      result := FmyVersionStrings[i];
+      Exit;
+    end;
+  result := '';
+end;
+
+end.

fcl/wince/process.inc

@@ -0,0 +1,267 @@
+{
+  Wince Process .inc.
+}
+
+uses Windows;
+
+Const
+  PriorityConstants : Array [TProcessPriority] of Cardinal =
+                      (HIGH_PRIORITY_CLASS,IDLE_PRIORITY_CLASS,
+                       NORMAL_PRIORITY_CLASS,REALTIME_PRIORITY_CLASS);
+
+procedure TProcess.CloseProcessHandles;
+begin
+  if (FProcessHandle<>0) then
+    CloseHandle(FProcessHandle);
+  if (FThreadHandle<>0) then
+    CloseHandle(FThreadHandle);
+end;
+
+Function TProcess.PeekExitStatus : Boolean;
+
+begin
+  GetExitCodeProcess(ProcessHandle,FExitCode);
+  Result:=(FExitCode<>Still_Active);
+end;
+
+Function GetStartupFlags (P : TProcess): Cardinal;
+
+begin
+  With P do
+    begin
+    Result:=0;
+    if poUsePipes in FProcessOptions then
+       Result:=Result or Startf_UseStdHandles;
+    if suoUseShowWindow in FStartupOptions then
+      Result:=Result or startf_USESHOWWINDOW;
+    if suoUSESIZE in FStartupOptions then
+      Result:=Result or startf_usesize;
+    if suoUsePosition in FStartupOptions then
+      Result:=Result or startf_USEPOSITION;
+    if suoUSECOUNTCHARS in FStartupoptions then
+      Result:=Result or startf_usecountchars;
+    if suoUsefIllAttribute in FStartupOptions then
+      Result:=Result or startf_USEFILLATTRIBUTE;
+    end;
+end;
+
+Function GetCreationFlags(P : TProcess) : Cardinal;
+
+begin
+  With P do
+    begin
+    Result:=0;
+    if poNoConsole in FProcessOptions then
+      Result:=Result or Detached_Process;
+    if poNewConsole in FProcessOptions then
+      Result:=Result or Create_new_console;
+    if poNewProcessGroup in FProcessOptions then
+      Result:=Result or CREATE_NEW_PROCESS_GROUP;
+    If poRunSuspended in FProcessOptions Then
+      Result:=Result or Create_Suspended;
+    if poDebugProcess in FProcessOptions Then
+      Result:=Result or DEBUG_PROCESS;
+    if poDebugOnlyThisProcess in FProcessOptions Then
+      Result:=Result or DEBUG_ONLY_THIS_PROCESS;
+    if poDefaultErrorMode in FProcessOptions Then
+      Result:=Result or CREATE_DEFAULT_ERROR_MODE;
+    result:=result or PriorityConstants[FProcessPriority];
+    end;
+end;
+
+Function StringsToPWidechars(List : TStrings): pointer;
+
+var
+  EnvBlock: Widestring;
+  I: Integer;
+
+begin
+  EnvBlock := '';
+  For I:=0 to List.Count-1 do
+    EnvBlock := EnvBlock + List[i] + #0;
+  EnvBlock := EnvBlock + #0;
+  GetMem(Result, Length(EnvBlock));
+  CopyMemory(Result, @EnvBlock[1], Length(EnvBlock));
+end;
+
+Procedure InitProcessAttributes(P : TProcess; Var PA : TSecurityAttributes);
+
+begin
+  FillChar(PA,SizeOf(PA),0);
+  PA.nLength := SizeOf(PA);
+end;
+
+Procedure InitThreadAttributes(P : TProcess; Var TA : TSecurityAttributes);
+
+begin
+  FillChar(TA,SizeOf(TA),0);
+  TA.nLength := SizeOf(TA);
+end;
+
+Procedure InitStartupInfo(P : TProcess; Var SI : STARTUPINFO);
+
+Const
+  SWC : Array [TShowWindowOptions] of Cardinal =
+             (0,SW_HIDE,SW_Maximize,SW_Minimize,SW_Restore,SW_Show,
+             SW_ShowDefault,SW_ShowMaximized,SW_ShowMinimized,
+               SW_showMinNOActive,SW_ShowNA,SW_ShowNoActivate,SW_ShowNormal);
+
+begin
+  FillChar(SI,SizeOf(SI),0);
+  With SI do
+    begin
+    dwFlags:=GetStartupFlags(P);
+    if P.FShowWindow<>swoNone then
+     dwFlags:=dwFlags or Startf_UseShowWindow
+    else
+      dwFlags:=dwFlags and not Startf_UseShowWindow;
+    wShowWindow:=SWC[P.FShowWindow];
+    if (poUsePipes in P.Options) then
+      begin
+      dwFlags:=dwFlags or Startf_UseStdHandles;
+      end;
+    if P.FillAttribute<>0 then
+      begin
+      dwFlags:=dwFlags or Startf_UseFillAttribute;
+      dwFillAttribute:=P.FillAttribute;
+      end;
+     dwXCountChars:=P.WindowColumns;
+     dwYCountChars:=P.WindowRows;
+     dwYsize:=P.WindowHeight;
+     dwXsize:=P.WindowWidth;
+     dwy:=P.WindowTop;
+     dwX:=P.WindowLeft;
+     end;
+end;
+
+Procedure CreatePipes(Var HI,HO,HE : Thandle; Var SI : TStartupInfo; CE : Boolean);
+
+  Procedure DoCreatePipeHandles(Var H1,H2 : THandle);
+
+  Var
+    I,O : Longint;
+
+  begin
+    CreatePipeHandles(I,O);
+    H1:=Thandle(I);
+    H2:=THandle(O);
+  end;
+
+
+
+
+begin
+  DoCreatePipeHandles(SI.hStdInput,HI);
+  DoCreatePipeHandles(HO,Si.hStdOutput);
+  if CE then
+    DoCreatePipeHandles(HE,SI.hStdError)
+  else
+    begin
+    SI.hStdError:=SI.hStdOutput;
+    HE:=HO;
+    end;
+end;
+
+
+Procedure TProcess.Execute;
+
+
+Var
+  PName,PDir,PCommandLine : PWidechar;
+  FEnv: pointer;
+  FCreationFlags : Cardinal;
+  FProcessAttributes : TSecurityAttributes;
+  FThreadAttributes : TSecurityAttributes;
+  FProcessInformation : TProcessInformation;
+  FStartupInfo : STARTUPINFO;
+  HI,HO,HE : THandle;
+
+begin
+  FInheritHandles:=True;
+  PName:=Nil;
+  PCommandLine:=Nil;
+  PDir:=Nil;
+  If FApplicationName<>'' then
+    PName:=PWidechar(FApplicationName);
+  If FCommandLine<>'' then
+    PCommandLine:=PWidechar(FCommandLine);
+  If FCurrentDirectory<>'' then
+    PDir:=PWidechar(FCurrentDirectory);
+  if FEnvironment.Count<>0 then
+    FEnv:=StringsToPWideChars(FEnvironment)
+  else
+    FEnv:=Nil;
+  Try
+    FCreationFlags:=GetCreationFlags(Self);
+    InitProcessAttributes(Self,FProcessAttributes);
+    InitThreadAttributes(Self,FThreadAttributes);
+    InitStartupInfo(Self,FStartUpInfo);
+    If poUsePipes in FProcessOptions then
+      CreatePipes(HI,HO,HE,FStartupInfo,Not(poStdErrToOutPut in FProcessOptions));
+    Try
+      If Not CreateProcess (PName,PCommandLine,@FProcessAttributes,@FThreadAttributes,
+                   FInheritHandles,FCreationFlags,FEnv,PDir,@FStartupInfo,
+                   fProcessInformation) then
+        Raise Exception.CreateFmt('Failed to execute %s : %d',[FCommandLine,GetLastError]);
+      FProcessHandle:=FProcessInformation.hProcess;
+      FThreadHandle:=FProcessInformation.hThread;
+      FProcessID:=FProcessINformation.dwProcessID;
+    Finally
+      if POUsePipes in FProcessOptions then
+        begin
+        FileClose(FStartupInfo.hStdInput);
+        FileClose(FStartupInfo.hStdOutput);
+        if Not (poStdErrToOutPut in FProcessOptions) then
+          FileClose(FStartupInfo.hStdError);
+        CreateStreams(HI,HO,HE);
+        end;
+    end;
+    FRunning:=True;
+  Finally
+    If FEnv<>Nil then
+      FreeMem(FEnv);
+  end;
+  if not (csDesigning in ComponentState) and // This would hang the IDE !
+     (poWaitOnExit in FProcessOptions) and
+      not (poRunSuspended in FProcessOptions) then
+    WaitOnExit;
+end;
+
+Function TProcess.WaitOnExit : Dword;
+
+begin
+  Result:=WaitForSingleObject (FProcessHandle,Infinite);
+  If Result<>Wait_Failed then
+    GetExitStatus;
+  FRunning:=False;
+end;
+
+Function TProcess.Suspend : Longint;
+
+begin
+  Result:=SuspendThread(ThreadHandle);
+end;
+
+Function TProcess.Resume : LongInt;
+
+begin
+  Result:=ResumeThread(ThreadHandle);
+end;
+
+Function TProcess.Terminate(AExitCode : Integer) : Boolean;
+
+begin
+  Result:=False;
+  If ExitStatus=Still_active then
+    Result:=TerminateProcess(Handle,AexitCode);
+end;
+
+Procedure TProcess.SetShowWindow (Value : TShowWindowOptions);
+
+
+begin
+  FShowWindow:=Value;
+end;
+
+
+

rtl/objpas/types.pp

@@ -17,9 +17,17 @@ unit types;
   interface
 
 {$ifdef Win32}
+ {$define Win32orCE}
+{$endif Win32}
+
+{$ifdef Wince}
+ {$define Win32orCE}
+{$endif Wince}
+
+{$ifdef Win32orCE}
     uses
        Windows;
-{$endif Win32}
+{$endif Win32orCE}
 
 const
   RT_RCDATA = PChar(10);
@@ -48,7 +56,7 @@ type
   TStringDynArray = array of AnsiString;
   TWideStringDynArray   = array of WideString;
 
-{$ifdef Win32}
+{$ifdef Win32orCE}
   TPoint = Windows.TPoint;
 {$else}
   TPoint =
@@ -63,7 +71,7 @@ type
   PPoint = ^TPoint;
   tagPOINT = TPoint;
 
-{$ifdef Win32}
+{$ifdef Win32orCE}
   TRect = Windows.TRect;
 {$else}
   TRect =
@@ -75,10 +83,10 @@ type
       0: (Left,Top,Right,Bottom : Longint);
       1: (TopLeft,BottomRight : TPoint);
     end;
-{$endif Win32}
+{$endif Win32orCE}
   PRect = ^TRect;
 
-{$ifdef Win32}
+{$ifdef Win32orCE}
   TSize = Windows.TSize;
 {$else}
   TSize =
@@ -89,7 +97,7 @@ type
      cx : Longint;
      cy : Longint;
   end;
-{$endif Win32}
+{$endif Win32orCE}
   PSize = ^TSize;
   tagSIZE = TSize;
   SIZE = TSize;
@@ -110,7 +118,7 @@ type
   POleStr = PWideChar;
   PPOleStr = ^POleStr;
 
-{$ifndef win32}
+{$ifndef win32orCE}
 const
 
   STGTY_STORAGE   = 1;
@@ -252,7 +260,7 @@ type
      Function Stat(out statstg : TStatStg;grfStatFlag : Longint) : HRESULT;stdcall;
      function Clone(out stm : IStream) : HRESULT;stdcall;
   end;
-{$endif win32}
+{$endif win32orCE}
 
 function EqualRect(const r1,r2 : TRect) : Boolean;
 function Rect(Left,Top,Right,Bottom : Integer) : TRect;