diff --git a/neural.lfm b/neural.lfm
new file mode 100644
index 0000000..459b3ca
--- /dev/null
+++ b/neural.lfm
@@ -0,0 +1,69 @@
+object MainForm: TMainForm
+ Left = 530
+ Height = 611
+ Top = 632
+ Width = 891
+ Caption = 'Neural Amp Cenrtral'
+ ClientHeight = 581
+ ClientWidth = 891
+ DesignTimePPI = 144
+ Menu = MainMenu1
+ LCLVersion = '2.2.6.0'
+ object MemConsole: TRichMemo
+ Left = 16
+ Height = 344
+ Top = 216
+ Width = 865
+ HideSelection = False
+ TabOrder = 0
+ ZoomFactor = 1
+ end
+ object NAMButton: TButton
+ Left = 256
+ Height = 86
+ Top = 88
+ Width = 374
+ Caption = 'NAM!!!'
+ Color = clForm
+ OnClick = NAMButtonClick
+ ParentFont = False
+ TabOrder = 1
+ end
+ object MainMenu1: TMainMenu
+ Left = 51
+ Top = 24
+ object MenuItem2: TMenuItem
+ Caption = '&File'
+ object MenuItem7: TMenuItem
+ Caption = '-'
+ end
+ object MenuItem10: TMenuItem
+ Caption = '-'
+ end
+ object MenuItem11: TMenuItem
+ Caption = 'E&xit'
+ end
+ end
+ object MenuItem15: TMenuItem
+ Caption = '&Help'
+ object MenuItem18: TMenuItem
+ Caption = '&Online Help'
+ end
+ object MenuItem19: TMenuItem
+ Caption = '-'
+ end
+ object MenuItem20: TMenuItem
+ Caption = '&Licence Information'
+ end
+ object MenuItem21: TMenuItem
+ Caption = '&Check for Updates'
+ end
+ object MenuItem22: TMenuItem
+ Caption = '-'
+ end
+ object MenuItem23: TMenuItem
+ Caption = '&About'
+ end
+ end
+ end
+end
diff --git a/neural.pas b/neural.pas
new file mode 100644
index 0000000..db22299
--- /dev/null
+++ b/neural.pas
@@ -0,0 +1,156 @@
+unit neural;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+ Classes, SysUtils, FileUtil, process, Forms, Controls, Graphics, Dialogs, Menus,
+ StdCtrls, RTTICtrls, RichMemo, Zipper, Processutils;
+
+type
+
+ { TMainForm }
+
+ TMainForm = class(TForm)
+ MainMenu1: TMainMenu;
+ MemConsole: TRichMemo;
+ MenuItem10: TMenuItem;
+ MenuItem11: TMenuItem;
+ MenuItem15: TMenuItem;
+ MenuItem18: TMenuItem;
+ MenuItem19: TMenuItem;
+ MenuItem2: TMenuItem;
+ MenuItem20: TMenuItem;
+ MenuItem21: TMenuItem;
+ MenuItem22: TMenuItem;
+ MenuItem23: TMenuItem;
+ MenuItem7: TMenuItem;
+ NAMButton: TButton;
+ procedure NAMButtonClick(Sender: TObject);
+
+ private
+
+ public
+ procedure ProcessOutput(Sender:TProcessEx; output:string);
+ procedure ProcessError(Sender:TProcessEx; {%H-}IsException:boolean);
+
+ end;
+
+var
+ MainForm: TMainForm;
+
+implementation
+
+{$R *.lfm}
+
+{ TMainForm }
+
+
+ procedure TMainForm.NAMButtonClick(Sender: TObject);
+
+ var
+ Proc: TProcessEx;
+ namrunner:TextFile;
+ begin
+ //StartProcessAndStreamStdioToMemo('NAM-Runner.bat',MemConsole)
+ AssignFile(namrunner, 'NAM-Runner060.bat');
+ // Try
+ Rewrite(namrunner);
+ Writeln(namrunner,'');//Remember AnsiStrings are case sensitive
+ Writeln(namrunner,'@echo off');
+ Writeln(namrunner,'set NAMNAME=neural-amp-modeler-0.6.0');
+ Writeln(namrunner,'set NAMVER=0.6.0');
+ Writeln(namrunner,'if exist "%~dp0\%NAMNAME%\installed.txt" (');
+ Writeln(namrunner,'echo NAM already installed!');
+ Writeln(namrunner,'GOTO NAMISINSTALLED');
+ Writeln(namrunner,')');
+ Writeln(namrunner,'echo This program is downloading and installing the complete NAM modelling environment and all prerequisites and runtimes.');
+ Writeln(namrunner,'echo.');
+ Writeln(namrunner,'echo.');
+ Writeln(namrunner,'echo PLEASE BE PATIENT.');
+ Writeln(namrunner,'echo SOME PARTS OF THIS INSTALLATION PROCESS CAN TAKE QUITE SOME TIME!');
+ Writeln(namrunner,'echo DON''T CLOSE THIS WINDOW UNTIL YOU ARE ASKED TO DO IT.');
+ Writeln(namrunner,'echo.');
+ Writeln(namrunner,'echo Downloading and extracting Python archive...');
+ Writeln(namrunner,'curl -L https://github.com/winpython/winpython/releases/download/6.1.20230527/Winpython64-3.10.11.1dot.exe -o python.exe');
+ Writeln(namrunner,'if exist "%~dp0\%NAMNAME%" rmdir /q "%~dp0\%NAMNAME%"');
+ Writeln(namrunner,'python.exe -y');
+ Writeln(namrunner,'@echo. |call %~dp0\WPy64-310111\scripts\make_winpython_movable.bat');
+ Writeln(namrunner,'move /Y "%~dp0\WPy64-310111\python-3.10.11.amd64" "%NAMNAME%"');
+ Writeln(namrunner,'echo Removing Python archive and unused files...');
+ Writeln(namrunner,'del /f /s /q "%~dp0\WPy64-310111" 1>nul');
+ Writeln(namrunner,'rmdir /s /q "%~dp0\WPy64-310111"');
+ Writeln(namrunner,'del python.exe');
+ Writeln(namrunner,'echo Done.');
+ Writeln(namrunner,'cd %NAMNAME%');
+ Writeln(namrunner,'echo.');
+ Writeln(namrunner,'echo.');
+ Writeln(namrunner,'set PYTHONPATH=%~dp0\%NAMNAME%;%~dp0\%NAMNAME%\DLLs;%~dp0\%NAMNAME%\lib;%~dp0\%NAMNAME%\lib\plat-win;%~dp0\%NAMNAME%\lib\site-packages');
+ Writeln(namrunner,'set PATH=%~dp0%NAMNAME%;%~dp0%NAMNAME%\Scripts;%PATH%');
+ Writeln(namrunner,'echo Upgrading PIP...');
+ Writeln(namrunner,'python.exe -m pip install --upgrade pip');
+ Writeln(namrunner,'echo Done.');
+ Writeln(namrunner,'echo.');
+ Writeln(namrunner,'echo.');
+ Writeln(namrunner,'echo Installing NAM...');
+ Writeln(namrunner,'python -m pip install neural-amp-modeler==%NAMVER%');
+ Writeln(namrunner,'echo.');
+ Writeln(namrunner,'echo Installing torch gpu...');
+ Writeln(namrunner,'pip3 install scipy==1.10.1');
+ Writeln(namrunner,'pip3 install torch torchvision torchaudio --force-reinstall --index-url https://download.pytorch.org/whl/cu118');
+ Writeln(namrunner,'echo Done.');
+ Writeln(namrunner,'echo.');
+ Writeln(namrunner,'>"%~dp0%NAMNAME%\installed.txt" echo done');
+ Writeln(namrunner,'echo NAM install done.');
+ Writeln(namrunner,'echo.');
+ Writeln(namrunner,'echo.');
+ Writeln(namrunner,':NAMISINSTALLED');
+ Writeln(namrunner,'set PYTHONPATH=%~dp0\%NAMNAME%;%~dp0\%NAMNAME%\DLLs;%~dp0\%NAMNAME%\lib;%~dp0\%NAMNAME%\lib\plat-win;%~dp0\%NAMNAME%\lib\site-packages');
+ Writeln(namrunner,'set PATH=%~dp0%NAMNAME%;%~dp0%NAMNAME%\Scripts;%PATH%');
+ Writeln(namrunner,'python -c "from winpython import wppm;dist=wppm.Distribution(r''%~dp0\%NAMNAME%'');dist.patch_standard_packages(''pip'', to_movable=True)"');
+ Writeln(namrunner,'nam');
+ Writeln(namrunner,'');
+ Writeln(namrunner,'cd..');
+ Writeln(namrunner,'echo.');
+ Writeln(namrunner,'echo.');
+ Writeln(namrunner,'::echo This window can now be closed.');
+ Writeln(namrunner,'echo In case something went wrong or the installation got corrupted:');
+ Writeln(namrunner,'echo You can simply delete the folder %NAMNAME% and try a reinstall.');
+ Writeln(namrunner,'echo Note, that a reinstallation needs an internet connection.');
+ Writeln(namrunner,'echo Thank you.');
+ //Finally
+ CloseFile(namrunner);
+ //End;
+
+ try
+ Proc := TProcessEx.Create(nil);
+ Proc.Executable := 'NAM-Runner060.bat';
+ Proc.OnErrorM:=@(ProcessError);
+ Proc.OnOutputM:=@(ProcessOutput);
+ Proc.Execute();
+ finally
+ Proc.Free;
+ end;
+ DeleteFile('NAM-Runner060.bat');
+ end;
+
+
+ procedure TMainForm.ProcessError(Sender: TProcessEx; IsException: boolean);
+ begin
+ MemConsole.Lines.Append('Erreur ! ' + Sender.ExceptionInfo);
+ end;
+
+ procedure TMainForm.ProcessOutput(Sender: TProcessEx; output : String);
+ begin
+ MemConsole.Lines.Text := MemConsole.Lines.Text + output;
+ // si vous avez des problème d'accent
+ //MemConsole.Lines.Text := MemConsole.Lines.Text + ConsoleToUtf8(output);
+ // pour scroll automatique
+ MemConsole.SelStart := Length(MemConsole.Lines.Text)-1;
+ MemConsole.SelLength:=0;
+ Application.ProcessMessages;
+ end;
+
+end.
+
diff --git a/neuralampcentral.ico b/neuralampcentral.ico
new file mode 100644
index 0000000..10c5fc1
Binary files /dev/null and b/neuralampcentral.ico differ
diff --git a/neuralampcentral.lpi b/neuralampcentral.lpi
new file mode 100644
index 0000000..461807c
--- /dev/null
+++ b/neuralampcentral.lpi
@@ -0,0 +1,125 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ -
+
+
+ -
+
+
+ -
+
+
+ -
+
+
+ -
+
+
+ -
+
+
+ -
+
+
+ -
+
+
+ -
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ -
+
+
+ -
+
+
+ -
+
+
+
+
+
diff --git a/neuralampcentral.lpr b/neuralampcentral.lpr
new file mode 100644
index 0000000..8923674
--- /dev/null
+++ b/neuralampcentral.lpr
@@ -0,0 +1,26 @@
+program neuralampcentral;
+
+{$mode objfpc}{$H+}
+
+uses
+ {$IFDEF UNIX}
+ cthreads,
+ {$ENDIF}
+ {$IFDEF HASAMIGA}
+ athreads,
+ {$ENDIF}
+ Interfaces, // this includes the LCL widgetset
+ Forms, runtimetypeinfocontrols, neural
+ { you can add units after this };
+
+{$R *.res}
+
+begin
+ RequireDerivedFormResource:=True;
+ Application.Title:='Neural Amp Central';
+ Application.Scaled:=True;
+ Application.Initialize;
+ Application.CreateForm(TMainForm, MainForm);
+ Application.Run;
+end.
+
diff --git a/neuralampcentral.lps b/neuralampcentral.lps
new file mode 100644
index 0000000..ecb94c6
--- /dev/null
+++ b/neuralampcentral.lps
@@ -0,0 +1,169 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/neuralampcentral.res b/neuralampcentral.res
new file mode 100644
index 0000000..f15e049
Binary files /dev/null and b/neuralampcentral.res differ
diff --git a/processutils.pas b/processutils.pas
new file mode 100644
index 0000000..90d5ad4
--- /dev/null
+++ b/processutils.pas
@@ -0,0 +1,635 @@
+{ Process utility unit. Extends TProcess.
+Not unicode-aware (change this when FPC becomes so).
+
+Copyright (C) 2012-2014 Ludo Brands, Reinier Olislagers
+
+This unit is licensed as modified LGPL or MIT, at your choice. Licenses below
+}
+{
+This library is free software; you can redistribute it and/or modify it
+under the terms of the GNU Library General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at your
+option) any later version with the following modification:
+
+As a special exception, the copyright holders of this library give you
+permission to link this library with independent modules to produce an
+executable, regardless of the license terms of these independent modules,and
+to copy and distribute the resulting executable under terms of your choice,
+provided that you also meet, for each linked independent module, the terms
+and conditions of the license of that module. An independent module is a
+module which is not derived from or based on this library. If you modify
+this library, you may extend this exception to your version of the library,
+but you are not obligated to do so. If you do not wish to do so, delete this
+exception statement from your 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 Library General Public License
+for more details.
+
+You should have received a copy of the GNU Library General Public License
+along with this library; if not, write to the Free Software Foundation,
+Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+}
+{
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to
+deal in the Software without restriction, including without limitation the
+rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+sell copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in
+all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+IN THE SOFTWARE.
+}
+unit processutils;
+
+{$mode objfpc}{$H+}
+{not $DEFINE DEBUGCONSOLE} //define debug to get writeln output of commands called
+
+interface
+
+uses
+ Classes, SysUtils,
+ process,
+ //UTF8Process,
+ strutils;
+
+const
+ // Internal error code/result codes:
+ PROC_INTERNALERROR=-1; // error while running process code in this unit
+ PROC_INTERNALEXCEPTION=-2; //exception while running process code in this unit
+ {$IFDEF MSWINDOWS}
+ PATHVARNAME = 'Path'; //Name for path environment variable
+ {$ELSE}
+ //Unix/Linux
+ PATHVARNAME = 'PATH';
+ {$ENDIF MSWINDOWS}
+
+type
+ TProcessEx = class; //forward
+ TDumpFunc = procedure (Sender:TProcessEx; output:string);
+ TDumpMethod = procedure (Sender:TProcessEx; output:string) of object;
+ TErrorFunc = procedure (Sender:TProcessEx;IsException:boolean);
+ TErrorMethod = procedure (Sender:TProcessEx;IsException:boolean) of object;
+
+ { TProcessEnvironment }
+ TProcessEnvironment = class(TObject)
+ private
+ FEnvironmentList:TStringList;
+ FCaseSensitive:boolean;
+ function GetVarIndex(VarName:string):integer;
+ public
+ // Get environment variable
+ function GetVar(VarName:string):string;
+ // Set environment variable
+ procedure SetVar(VarName,VarValue:string);
+ // List of all environment variables (name and value)
+ property EnvironmentList:TStringList read FEnvironmentList;
+ constructor Create;
+ destructor Destroy; override;
+ end;
+
+ { TProcessEx }
+
+ TProcessEx = class(TProcess)
+ //TProcessEx = class(TProcessUTF8)
+ private
+ FExceptionInfoStrings: TstringList;
+ FExitStatus: integer; //result code/exit status that executable returned with
+ FOnError: TErrorFunc;
+ FOnErrorM: TErrorMethod;
+ FOnOutput: TDumpFunc;
+ FOnOutputM: TDumpMethod;
+ FOutputStrings: TStringList;
+ FOutStream: TMemoryStream;
+ FProcessEnvironment:TProcessEnvironment;
+ function GetResultingCommand: string;
+ function GetExceptionInfo: string;
+ function GetOutputString: string;
+ function GetOutputStrings: TStringList;
+ function GetParametersString: String;
+ function GetProcessEnvironment: TProcessEnvironment;
+ procedure SetOnError(AValue: TErrorFunc);
+ procedure SetOnErrorM(AValue: TErrorMethod);
+ procedure SetOnOutput(AValue: TDumpFunc);
+ procedure SetOnOutputM(AValue: TDumpMethod);
+ public
+ // Run executable with parameters etc. Comes in place of inherited execute.
+ {%H-}procedure Execute;
+ // Executable+parameters. Use Executable and Parameters/ParametersString to assign
+ property ResultingCommand: string read GetResultingCommand;
+ // All environment variables, e.g. PATH
+ property Environment:TProcessEnvironment read GetProcessEnvironment;
+ property ExceptionInfo:string read GetExceptionInfo;
+ property ExceptionInfoStrings:TstringList read FExceptionInfoStrings;
+ // Return code/exit status that the process returned with. Often 0 for success.
+ property ExitStatus:integer read FExitStatus;
+ // Use callback to catch error messages
+ property OnError:TErrorFunc read FOnError write SetOnError;
+ // Use callback to catch error messages
+ property OnErrorM:TErrorMethod read FOnErrorM write SetOnErrorM;
+ property OnOutput:TDumpFunc read FOnOutput write SetOnOutput;
+ property OnOutputM:TDumpMethod read FOnOutputM write SetOnOutputM;
+ property OutputString:string read GetOutputString;
+ property OutputStrings:TStringList read GetOutputStrings;
+ constructor Create(AOwner : TComponent); override;
+ destructor Destroy; override;
+ end;
+
+// Convenience functions
+
+// Runs command, returns result code. Negative codes are processutils internal error codes
+function ExecuteCommand(Commandline: string; Verbose:boolean): integer; overload;
+// Runs command, returns result code. Negative codes are processutils internal error codes
+function ExecuteCommand(Commandline: string; out Output:string; Verbose:boolean): integer; overload;
+// Runs command, returns result code. Negative codes are processutils internal error codes
+function ExecuteCommand(Commandline: string; Output : TStream; Verbose:boolean): integer; overload;
+// Runs command, returns result code. Negative codes are processutils internal error codes
+function ExecuteCommandInDir(Commandline, Directory: string; Verbose:boolean): integer; overload;
+// Runs command, returns result code. Negative codes are processutils internal error codes
+function ExecuteCommandInDir(Commandline, Directory: string; out Output:string; Verbose:boolean): integer; overload;
+// Runs command, returns result code. Negative codes are processutils internal error codes
+// PrependPath is prepended to existing path. If empty, keep current path
+function ExecuteCommandInDir(Commandline, Directory: string; out Output:string; PrependPath: string; Verbose:boolean): integer; overload;
+// Don't process comamndline
+function ExecutePlainCommand(Commandline: string; out Output: string; Verbose: boolean): integer;
+// Writes output to console
+procedure DumpConsole(Sender:TProcessEx; output:string);
+
+implementation
+
+{$ifdef LCL}
+uses
+ Forms,Controls;
+{$endif}
+
+{ TProcessEx }
+
+function TProcessEx.GetOutputString: string;
+begin
+ result:=OutputStrings.Text;
+end;
+
+function TProcessEx.GetOutputStrings: TStringList;
+begin
+ if (FOutputStrings.Count=0) and (FOutStream.Size>0) then
+ begin
+ FOutStream.Position := 0;
+ FOutputStrings.LoadFromStream(FOutStream);
+ FOutStream.Clear;
+ end;
+ result:=FOutputStrings;
+end;
+
+function TProcessEx.GetParametersString: String;
+begin
+ result:=AnsiReplaceStr(Parameters.text, LineEnding, ' ');
+end;
+
+function TProcessEx.GetExceptionInfo: string;
+begin
+ result:=FExceptionInfoStrings.Text;
+end;
+
+function TProcessEx.GetResultingCommand: string;
+var i:integer;
+begin
+ //this is not the command as executed. The quotes are surrounding individual params.
+ //the actual quoting is platform dependent
+ //perhaps better to use another quoting character to make this clear to the user.
+ result:=Executable;
+ for i:=0 to Parameters.Count-1 do
+ result:=result+' "'+Parameters[i]+'"';
+end;
+
+function TProcessEx.GetProcessEnvironment: TProcessEnvironment;
+begin
+ If not assigned(FProcessEnvironment) then
+ FProcessEnvironment:=TProcessEnvironment.Create;
+ result:=FProcessEnvironment;
+end;
+
+procedure TProcessEx.SetOnError(AValue: TErrorFunc);
+begin
+ if FOnError=AValue then Exit;
+ FOnError:=AValue;
+end;
+
+procedure TProcessEx.SetOnErrorM(AValue: TErrorMethod);
+begin
+ if FOnErrorM=AValue then Exit;
+ FOnErrorM:=AValue;
+end;
+
+procedure TProcessEx.SetOnOutput(AValue: TDumpFunc);
+begin
+ if FOnOutput=AValue then Exit;
+ FOnOutput:=AValue;
+end;
+
+procedure TProcessEx.SetOnOutputM(AValue: TDumpMethod);
+begin
+ if FOnOutputM=AValue then Exit;
+ FOnOutputM:=AValue;
+end;
+
+procedure TProcessEx.Execute;
+{$ifdef LCL}
+var
+ i:integer;
+{$endif}
+function ReadOutput: boolean;
+const
+ BufSize = 4096;
+var
+ Buffer: array[0..BufSize - 1] of byte;
+ ReadBytes: integer;
+begin
+ Result := False;
+ while Output.NumBytesAvailable > 0 do
+ begin
+ ReadBytes := Output.Read({%H-}Buffer, BufSize);
+ FOutStream.Write(Buffer, ReadBytes);
+ if Assigned(FOnOutput) then
+ FOnOutput(Self,copy(pchar(@buffer[0]),1,ReadBytes));
+ if Assigned(FOnOutputM) then
+ FOnOutputM(Self,copy(pchar(@buffer[0]),1,ReadBytes));
+ Result := True;
+ end;
+end;
+
+begin
+ try
+ // "Normal" linux and DOS exit codes are in the range 0 to 255.
+ // Windows System Error Codes are 0 to 15999
+ // Use negatives for internal errors.
+ FExitStatus:=PROC_INTERNALERROR;
+ FExceptionInfoStrings.Clear;
+ FOutputStrings.Clear;
+ FOutStream.Clear;
+ if Assigned(FProcessEnvironment) then
+ inherited Environment:=FProcessEnvironment.EnvironmentList;
+ Options := Options +[poUsePipes, poStderrToOutPut];
+ if Assigned(FOnOutput) then
+ FOnOutput(Self,'Executing: '+ResultingCommand+' (working dir: '+ CurrentDirectory +')'+ LineEnding);
+ if Assigned(FOnOutputM) then
+ FOnOutputM(Self,'Executing: '+ResultingCommand+' (working dir: '+ CurrentDirectory +')'+ LineEnding);
+
+ try
+ if CurrentDirectory<>'' then
+ begin
+ // Avoid unpredictable behaviour as well as
+ // OSX bug 26706 (fixed in FPC trunk)
+ if not(DirectoryExists(CurrentDirectory)) then
+ begin
+ FExitStatus:=PROC_INTERNALEXCEPTION;
+ FExceptionInfoStrings.Add('Invalid directory: '+CurrentDirectory);
+ FExitStatus:=PROC_INTERNALEXCEPTION;
+ if (Assigned(OnError) or Assigned(OnErrorM)) then
+ OnError(Self,false)
+ else
+ OnErrorM(Self,false);
+ exit;
+ end;
+ end;
+ {$ifdef LCL}
+ i:=0;
+ {$endif}
+ inherited Execute;
+ while Running do
+ begin
+ if not ReadOutput then
+ begin
+ {$ifdef LCL}
+ Sleep(10);
+ if (i<100) then Inc(i);
+ // process message queue after 50ms
+ if (i>5) then Application.ProcessMessages;
+ // set cursor after 1 second of execution time
+ if (i=99) then Application.MainForm.Cursor:=crHourGlass;
+ {$else}
+ Sleep(100);
+ {$endif}
+ end;
+ end;
+ ReadOutput;
+ {$ifdef LCL}
+ if Application.MainForm.Cursor=crHourGlass then
+ begin
+ Application.MainForm.Cursor:=crDefault;
+ Application.ProcessMessages;
+ end;
+ {$endif}
+
+ FExitStatus:=inherited ExitStatus;
+ except
+ // Leave exitstatus as proc_internalerror
+ // This should handle calling non-existing application etc.
+ // Note also bug 22055 TProcess ExitStatus is zero when the called process Seg Faults
+ end;
+
+ if (FExitStatus<>0) and (Assigned(OnError) or Assigned(OnErrorM)) then
+ if Assigned(OnError) then
+ OnError(Self,false)
+ else
+ OnErrorM(Self,false);
+ except
+ on E: Exception do
+ begin
+ FExceptionInfoStrings.Add('Exception calling '+Executable+' '+Parameters.Text);
+ FExceptionInfoStrings.Add('Details: '+E.ClassName+'/'+E.Message);
+ FExitStatus:=PROC_INTERNALEXCEPTION;
+ if (Assigned(OnError) or Assigned(OnErrorM)) then
+ OnError(Self,false)
+ else
+ OnErrorM(Self,false);
+ end;
+ end;
+end;
+
+constructor TProcessEx.Create(AOwner : TComponent);
+begin
+ inherited;
+ {$ifdef LCL}
+ Self.ShowWindow:=swoHIDE;
+ {$endif}
+ FExceptionInfoStrings:= TstringList.Create;
+ FOutputStrings:= TstringList.Create;
+ FOutStream := TMemoryStream.Create;
+end;
+
+destructor TProcessEx.Destroy;
+begin
+ FExceptionInfoStrings.Free;
+ FOutputStrings.Free;
+ FOutStream.Free;
+ If assigned(FProcessEnvironment) then
+ FProcessEnvironment.Free;
+ inherited Destroy;
+end;
+
+{ TProcessEnvironment }
+
+function TProcessEnvironment.GetVarIndex(VarName: string): integer;
+var
+ idx:integer;
+
+ function ExtractVar(VarVal:string):string;
+ begin
+ result:='';
+ if length(Varval)>0 then
+ begin
+ if VarVal[1] = '=' then //windows
+ delete(VarVal,1,1);
+ result:=trim(copy(VarVal,1,pos('=',VarVal)-1));
+ if not FCaseSensitive then
+ result:=UpperCase(result);
+ end
+ end;
+
+begin
+ if (Length(VarName)=0) then
+ begin
+ result:=-1;
+ end
+ else
+ begin
+ if not FCaseSensitive then
+ VarName:=UpperCase(VarName);
+ idx:=0;
+ while idx0 then
+ begin
+ if VarVal[1] = '=' then //windows
+ delete(VarVal,1,1);
+ result:=trim(copy(VarVal,pos('=',VarVal)+1,length(VarVal)));
+ end
+ end;
+
+begin
+ idx:=GetVarIndex(VarName);
+ if idx>=0 then
+ result:=ExtractVal(FEnvironmentList[idx])
+ else
+ result:='';
+end;
+
+procedure TProcessEnvironment.SetVar(VarName, VarValue: string);
+var
+ idx:integer;
+ s:string;
+begin
+ if (Length(VarName)=0) OR (Length(VarValue)=0) then exit;
+ idx:=GetVarIndex(VarName);
+ s:=trim(Varname)+'='+trim(VarValue);
+ if idx>=0 then
+ FEnvironmentList[idx]:=s
+ else
+ FEnvironmentList.Add(s);
+end;
+
+constructor TProcessEnvironment.Create;
+var
+ i: integer;
+begin
+ FEnvironmentList:=TStringList.Create;
+ {$ifdef WINDOWS}
+ FCaseSensitive:=false;
+ {$else}
+ FCaseSensitive:=true;
+ {$endif WINDOWS}
+ // GetEnvironmentVariableCount is 1 based
+ for i:=1 to GetEnvironmentVariableCount do
+ EnvironmentList.Add(trim(GetEnvironmentString(i)));
+end;
+
+destructor TProcessEnvironment.Destroy;
+begin
+ FEnvironmentList.Free;
+ inherited Destroy;
+end;
+
+procedure DumpConsole(Sender:TProcessEx; output:string);
+begin
+ write(output);
+end;
+
+function ExecuteCommand(Commandline: string; Verbose: boolean): integer;
+var
+ s:string='';
+begin
+ Result:=ExecuteCommandInDir(Commandline,'',s,Verbose);
+end;
+
+function ExecuteCommand(Commandline: string; out Output: string;
+ Verbose: boolean): integer;
+begin
+ Result:=ExecuteCommandInDir(Commandline,'',Output,Verbose);
+end;
+
+function ExecuteCommand(Commandline: string; Output : TStream;
+ Verbose: boolean): integer;
+begin
+ // to be done
+ //Result:=ExecuteCommandInDir(Commandline,'',Output,Verbose);
+end;
+
+
+function ExecuteCommandInDir(Commandline, Directory: string; Verbose: boolean
+ ): integer;
+var
+ s:string='';
+begin
+ Result:=ExecuteCommandInDir(Commandline,Directory,s,Verbose);
+end;
+
+function ExecuteCommandInDir(Commandline, Directory: string;
+ out Output: string; Verbose: boolean): integer;
+begin
+ Result:=ExecuteCommandInDir(CommandLine,Directory,Output,'',Verbose);
+end;
+
+function ExecuteCommandInDir(Commandline, Directory: string;
+ out Output: string; PrependPath: string; Verbose: boolean): integer;
+var
+ OldPath: string;
+ PE:TProcessEx;
+ s:string;
+
+ function GetFirstWord:string;
+ var
+ i:integer;
+ LastQuote:char=#0;
+ InQuote:boolean;
+ const
+ QUOTES = ['"',''''];
+ begin
+ Commandline:=trim(Commandline);
+ i:=1;
+ InQuote:=false;
+ while (i<=length(Commandline)) and (InQuote or (Commandline[i]>' ')) do
+ begin
+ // Check first and last quote:
+ if Commandline[i] in QUOTES then
+ if InQuote then
+ begin
+ if Commandline[i]=LastQuote then
+ begin
+ InQuote:=false;
+ delete(Commandline,i,1);
+ i:=i-1;
+ end;
+ end
+ else
+ begin
+ InQuote:=True;
+ LastQuote:=Commandline[i];
+ delete(Commandline,i,1);
+ i:=i-1;
+ end;
+ i:=i+1;
+ end;
+ // Copy found word and remove it from remaining command line
+ result:=trim(copy(Commandline,1,i));
+ delete(Commandline,1,i);
+ end;
+
+begin
+ PE:=TProcessEx.Create(nil);
+ try
+ if Directory<>'' then
+ PE.CurrentDirectory:=Directory;
+
+ // Prepend specified PrependPath if needed:
+ if PrependPath<>'' then
+ begin
+ OldPath:=PE.Environment.GetVar(PATHVARNAME);
+ if OldPath<>'' then
+ PE.Environment.SetVar(PATHVARNAME, PrependPath+PathSeparator+OldPath)
+ else
+ PE.Environment.SetVar(PATHVARNAME, PrependPath);
+ end;
+ PE.Executable:=GetFirstWord;
+ s:=GetFirstWord;
+ while s<>'' do
+ begin
+ if s<>'emptystring'
+ then PE.Parameters.Add(s)
+ else PE.Parameters.Add('""');
+ s:=GetFirstWord;
+ end;
+ PE.ShowWindow := swoHIDE;
+ if Verbose then
+ PE.OnOutput:=@DumpConsole;
+ {$IFDEF DEBUGCONSOLE}
+ writeln('ExecuteCommandInDir: executable '+PE.Executable);
+ writeln('ExecuteCommandInDir: params '+PE.Parameters.Text);
+ {$ENDIF DEBUGCONSOLE}
+ PE.Execute;
+
+ Output:=PE.OutputString;
+ Result:=PE.ExitStatus;
+ {$IFDEF DEBUGCONSOLE}
+ writeln('ExecuteCommandInDir: exit status: '+IntToStr(Result));
+ {$ENDIF DEBUGCONSOLE}
+ finally
+ PE.Free;
+ end;
+end;
+
+function ExecutePlainCommand(Commandline: string; out Output: string; Verbose: boolean): integer;
+var
+ PE:TProcessEx;
+ s:string;
+begin
+ PE:=TProcessEx.Create(nil);
+ try
+ PE.CommandLine:=Commandline;
+ PE.ShowWindow := swoHIDE;
+ if Verbose then
+ PE.OnOutput:=@DumpConsole;
+ {$IFDEF DEBUGCONSOLE}
+ writeln('ExecuteCommandInDir: executable '+PE.Executable);
+ writeln('ExecuteCommandInDir: params '+PE.Parameters.Text);
+ {$ENDIF DEBUGCONSOLE}
+ PE.Execute;
+ Output:=PE.OutputString;
+ Result:=PE.ExitStatus;
+ {$IFDEF DEBUGCONSOLE}
+ writeln('ExecuteCommandInDir: exit status: '+IntToStr(Result));
+ {$ENDIF DEBUGCONSOLE}
+ finally
+ PE.Free;
+ end;
+end;
+
+end.
+