binni@ed.ecn.purdue.edu (Brynjolfur Thorsson) (04/09/91)
Dave Sisson asked me to post this in response to previously posted article.
Pls. contact him directly if you have questions/comments.
Brynjolfur.
(binni@ecn.purdue.edu)
----------------------------------------------------------------------
From daves@vtcosy.cns.vt.edu Mon Apr 8 13:42:26 1991
Received: from vtcosy.cns.vt.edu by ed.ecn.purdue.edu (5.65/1.30jrs)
id AA25441; Mon, 8 Apr 91 13:42:06 -0500
Received: by vtcosy.cns.vt.edu (AIX 2.1.2/4.03)
id AA10592; Mon, 8 Apr 91 14:42:55 EDT
From: daves@vtcosy.cns.vt.edu (Dave Sisson)
Message-Id: <9104081842.AA10592@vtcosy.cns.vt.edu>
Subject: Cursor On/Off Code plus ...
To: binni@ed.ecn.purdue.edu
Date: Mon, 8 Apr 91 14:42:53 EDT
X-Mailer: ELM [version 2.3 PL0]
Status: OR
Here's the code I use to do it. This unit grew as I developed
a BBS front end program. The code contains a lot of extra functions,
most of which you probably won't use, but enjoy!
unit Exists;
(**************************************************************************)
(*
(* Unit Exists
(*
(* Description: Contains the FileExists and the ScrollLock functions
(* in addition to ToggleScrollLock function and the Strng
(* function with Cursor On/Off routines added in on the side
(* Also includes string lengthening and shortening routines
(* Includes a fancy little alarm or beeper.
(*
(* Author: Brian Martin and David Sisson
(*
(* Revisions: None
(*
(* Version: 1.32
(*
(**************************************************************************)
interface
{$D-}
function FileExists(str: string): boolean;
function DirExists(str: string): boolean;
function ScrollLock:boolean;
procedure ToggleScroll;
function Strng(num: longint): string;
procedure CursorOn;
procedure CursorOff;
function Shorten(astr: string): string;
function Lengthen(str: string; num: integer): string;
procedure Beeper;
function UpperString(astr: string): string;
implementation
uses Crt, Dos;
(**************************************************************************)
(*
(* Procedure ToggleScroll
(*
(* Description: Toggles the Scroll Lock key
(*
(* Author: Brian Martin and David Sisson
(*
(* Revisions: None
(*
(* Version: 1.00
(*
(**************************************************************************)
Procedure ToggleScroll;
var kbflag: byte absolute $0040:$0017;
begin
KbFlag:=(KbFlag XOR $10)
end;
(**************************************************************************)
(*
(* Function Strng
(*
(* Description: Returns the string of a numeric value
(*
(* Author: Brian Martin and David Sisson
(*
(* Revisions: None
(*
(* Version: 1.00
(*
(**************************************************************************)
function Strng;
var str2: string;
begin
Str(num, str2);
Strng:=str2;
end;
(**************************************************************************)
(*
(* Function ScrollLock
(*
(* Description: Returns True if Scroll Lock is enabled
(*
(* Author: Brian Martin and David Sisson
(*
(* Revisions: None
(*
(* Version: 1.00
(*
(**************************************************************************)
function ScrollLock;
var kbflag: byte absolute $0040:$0017;
begin
ScrollLock:=(Kbflag and $10)>0;
end;
(**************************************************************************)
(*
(* Function FileExists
(*
(* Description: Returns True if the file exists
(*
(* Author: David Sisson
(*
(* Revisions: None
(*
(* Version: 1.00
(*
(**************************************************************************)
function FileExists;
var fil:text;
begin
{$I-}
Assign(fil,str);
Reset(fil);
if IOResult<>0 then FileExists:=False else FileExists:=True;
{$I+}
end;
(**************************************************************************)
(*
(* Function DirExists
(*
(* Description: Returns True if the given directory exists
(*
(* Author: David Sisson
(*
(* Revisions: None
(*
(* Version: 1.00
(*
(**************************************************************************)
function DirExists;
var SR: SearchRec;
begin
FindFirst(str, Directory, SR);
if DosError=0 then DirExists:=True else DirExists:=False;
end;
(**************************************************************************)
(*
(* Procedure CursorOn
(*
(* Description: Turns the cursor on
(*
(* Author: David Sisson
(*
(* Revisions: None
(*
(* Version: 1.00
(*
(**************************************************************************)
procedure CursorOn;
var Regs: Registers;
begin
Regs.AH:=1;
Regs.CH:=11;
Regs.CL:=13;
Intr($10, Regs);
end;
(**************************************************************************)
(*
(* Procedure CursorOff
(*
(* Description: Turns the cursor off
(*
(* Author: Brian Martin
(*
(* Revisions: None
(*
(* Version: 1.00
(*
(**************************************************************************)
procedure CursorOff;
var Regs: Registers;
begin
Regs.CH:=Regs.CH or $20;
Regs.AH:=1;
Intr($10, Regs);
end;
(**************************************************************************)
(*
(* Function Shorten
(*
(* Description: Removes trailing spaces from the end of a string
(*
(* Author: David Sisson
(*
(* Revisions: None
(*
(* Version: 1.00
(*
(**************************************************************************)
function Shorten(astr: string): string;
begin
while (Length(astr)>0) and (astr[Length(astr)]=' ') do begin
astr:=Copy(astr,1,Length(astr)-1);
end;
Shorten:=astr;
end;
(**************************************************************************)
(*
(* Function Lengthen
(*
(* Description: Puts trailing spaces from the end of a string to make
(* it as long as you want
(*
(* Author: David Sisson
(*
(* Revisions: None
(*
(* Version: 1.00
(*
(**************************************************************************)
function Lengthen(str: string; num: integer): string;
var str2: string;
begin
str2:=str;
while Length(str2)<num do str2:=str2+' ';
Lengthen:=str2;
end;
(**************************************************************************)
(*
(* Procedure Beeper
(*
(* Description: Does a fancy little beep
(*
(* Author: Brian Martin
(*
(* Revisions: None
(*
(* Version: 1.00
(*
(**************************************************************************)
Procedure Beeper;
var i:integer;
begin
For i:= 1 to 4 do begin
Delay(90);
Sound(1500);
Delay(90);
Sound(1600);
Delay(90);
Sound(1800);
Delay(90);
Sound(1600);
end;
NoSound;
end;
(**************************************************************************)
(*
(* Function UpperString
(*
(* Description: Capitalizes a string
(*
(* Author: David Sisson
(*
(* Revisions: None
(*
(* Version: 1.00
(*
(**************************************************************************)
function UpperString(astr: string): string;
var i: integer;
begin
if Length(astr)>0 then begin
for i:=1 to Length(astr) do astr[i]:=UpCase(astr[i]);
UpperString:=astr;
end;
end;
end.
--
Dave Sisson @vtcosy.cns.vt.edu
Gamemaster, Graphics enthusiast, Other.winfave@dutrun.UUCP (Alexander Verbraeck) (04/17/91)
The FileExists function as posted in the "Cursor On/Off Code Plus"
posting (originating from Dave Sisson) contains a slight but extremely
boresome error, as far as I can see. My first attempt to write a
FileExists function contained the same error, and it took me quite a
while to find it. The original FE routing looked something like:
function FE(n:string):boolean; {a little bit abbreviated}
var f:text;
begin
{$I-} assign(f,n); reset(f);
if IOresult<>0 then FE:=false else FE:=true;
{$I+}
end;
When I include the above function in a program like:
program TestFE;
var
i : integer;
function FE { as above }
begin
writeln;
for i:=1 to 40 do if FE('C:\CONFIG.SYS') then
write('E')
else
write('N');
writeln;
end.
The output of this little program is (when C:\CONFIG.SYS exists):
EEEEEEEEEEEEEEENNNNNNNNNNNNNNNNNNNNNNNNN
which means that the file existed the first 15 times, and not anymore
afterward. What's the flaw? Not closing the file in FileExists, which
occupies a DOS file handler when it exists. What's the solution? Either
always closing the file between the {$I-} and {$I+} directives, or
closing it after testing if IOresult reports that the file exists and
THEN closing the file.
I used the first method, resulting in the following function:
function FileExists(fn:string) : boolean;
var
f : text;
begin
{$I-}
assign(f,fn);
reset(f);
close(f);
FileExists:=(IOresult=0);
{$I+}
end;
Sincerely,
-------------------------------------------------------------------------
Alexander Verbraeck e-mail: winfave@duticai.tudelft.nl
Delft University of Technology winfave@hdetud1.bitnet
Department of Information Systems winfave@duticai.uucp
PO Box 356, 2600 AJ The Netherlands winfave@dutrun.tudelft.nl
Tel: +31 15 783805 Fax: +31 15 786632/787022 winfave@dutrun.uucp
-------------------------------------------------------------------------