From 5d72fea2bab41b4c40a364413985158d83c3c202 Mon Sep 17 00:00:00 2001
From: pierre <pierre@freepascal.org>
Date: Thu, 5 Dec 2002 16:04:26 +0000
Subject: [PATCH]  * new files for checking if ComSpec returns error

---
 tests/utils/fail.pp     |  5 +++
 tests/utils/testfail.pp | 75 +++++++++++++++++++++++++++++++++++++++++
 2 files changed, 80 insertions(+)
 create mode 100644 tests/utils/fail.pp
 create mode 100644 tests/utils/testfail.pp

diff --git a/tests/utils/fail.pp b/tests/utils/fail.pp
new file mode 100644
index 0000000000..f24dcf2f95
--- /dev/null
+++ b/tests/utils/fail.pp
@@ -0,0 +1,5 @@
+program fail;
+
+begin
+  halt(1);
+end.
diff --git a/tests/utils/testfail.pp b/tests/utils/testfail.pp
new file mode 100644
index 0000000000..257396c4b9
--- /dev/null
+++ b/tests/utils/testfail.pp
@@ -0,0 +1,75 @@
+{
+  $Id$
+    This file is part of the Free Pascal test suite.
+    Copyright (c) 1999-2002 by the Free Pascal development team.
+
+    Check if redir can use COMSPEC environment variable.
+
+    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.
+
+ **********************************************************************}
+
+program dotest;
+uses
+  dos,
+  redir;
+
+Const
+  FailName = 'fail';
+{$ifdef UNIX}
+  ExeExt='';
+{$else UNIX}
+  ExeExt='exe';
+{$endif UNIX}
+
+
+function ForceExtension(Const HStr,ext:String):String;
+{
+  Return a filename which certainly has the extension ext
+}
+var
+  j : longint;
+begin
+  j:=length(Hstr);
+  while (j>0) and (Hstr[j]<>'.') do
+   dec(j);
+  if j=0 then
+   j:=255;
+  if Ext<>'' then
+   ForceExtension:=Copy(Hstr,1,j-1)+'.'+Ext
+  else
+   ForceExtension:=Copy(Hstr,1,j-1);
+end;
+
+
+
+procedure RunFail;
+var
+  outname,
+  TestExe : string;
+begin
+  TestExe:=ForceExtension(FailName,ExeExt);
+  ExecuteRedir(TestExe,'','','','');
+  if (DosError<>0) or (ExecuteResult<>1) then
+    writeln('exit code not returned correctly');
+end;
+
+
+begin
+  if (paramcount>0) and (paramstr(1)='-x') then
+    UseComSpec:=false
+  else
+    UseComSpec:=true;
+  RunFail;
+end.
+{
+  $Log$
+  Revision 1.1  2002-12-05 16:04:26  pierre
+   * new files for checking if ComSpec returns error
+
+}