[Back to FILES SWAG index] [Back to Main SWAG index] [Original]
unit openfiles;
(*
OPENFILES - Print list of all open files
Written by D.J. Murdoch for the public domain.
This unit interfaces three routines, which look in the (undocumented) DOS list
of open files for the filenames. One routine prints a list of open files,
another returns the list in a collection of strings, and the third calls a
user routine once for each open file. If compiled for DOS, it automatically
installs an exit handler to call the print routine, so if your program bombs
because it runs out of file handles, you'll see the list of what's open.
I've tested this unit in MSDOS 3.2, 4.01, 5 and 6; it should work in the
other versions from 2 to 6, but I'd like to hear from you if it doesn't.
Fidonet: DJ Murdoch at 1:249/99.5
Internet: dmurdoch@mast.queensu.ca
CIS: 71631,122
History:
1. 21 Oct 91 - First release to PDN echo.
2. 26 Oct 91 - Added check of PSP segment, and DOS 3.0 record format.
Set Allfiles to true to get previous behaviour.
3. 24 Jun 93 - Added DOS 6 and DPMI support
4. 24 Aug 94 - Added BP 7 Windows support, a bit more flexibility
in ways to call
Thanks are due to Berend de Boer for a series of articles explaining how to
make real mode interrupt calls from protected mode. His hints let me add the
DPMI and Windows support.
*)
{#Z+ Don't add these comments to the help file }
interface
uses
{$ifdef windows}
{$ifdef ver15}
wobjects,winprocs,win31,windos; { For TPW 1.5 }
{$else}
objects,winapi,windos; { For BP 7 Windows. }
{$endif}
{$else}
{$ifdef dpmi}
winapi, { For BP 7 pmode }
{$endif}
objects,dos; { For BP 7 DOS }
{$endif}
{#Z-}
const
version = 4;
Allfiles : boolean = false; { Whether to print files belonging
to other processes }
procedure print_open_files(var where:text);
{ Print open file list to given file }
function get_open_files:PCollection;
{ Returns a new collection containing pointers to strings holding the
filenames. Note that you'll need to use DisposeStr on each element
to release them. }
procedure For_each_open_file(Action:pointer);
{ Calls the far local procedure Action once per open file. Action should be
declared as
procedure Action(filename:string;openmode:word); far;
if it's a local procedure, or
procedure Action(filename:string; openmode,dummy:word); far;
if not. (Local procedures are procedures defined within other procedures.)
The filename will be the name of the file (no path), the openmode will be the
mode used to open the file.
}
implementation
{$ifdef windows}
{$define dpmi} { Everything else about Windows is
the same as DPMI }
{$endif}
type
ptrrec = record
ofs, seg : word;
end;
var
MyPrefixSeg : word;
{$ifdef dpmi}
{ This type was given by Berend de Boer, who credited the
DPMI unit from Borland's Open Architecture book }
type
TRealModeRegs = record
case Integer of
0: (
EDI, ESI, EBP, EXX, EBX, EDX, ECX, EAX: Longint;
Flags, ES, DS, FS, GS, IP, CS, SP, SS: Word);
1: (
DI,DIH, SI, SIH, BP, BPH, XX, XXH: Word;
case Integer of
0: (
BX, BXH, DX, DXH, CX, CXH, AX, AXH: Word);
1: (
BL, BH, BLH, BHH, DL, DH, DLH, DHH,
CL, CH, CLH, CHH, AL, AH, ALH, AHH: Byte));
end;
function MakePointer(seg,ofs:word):pointer;
var
sel,junk : word;
begin
sel := AllocSelector(Dseg); { !!4 Copy Dseg attributes }
sel := SetSelectorBase(sel, longint(16)*seg);
if sel <> 0 then
begin
junk := SetSelectorLimit(sel, $ffff);
MakePointer := Ptr(sel,ofs);
end
else
MakePointer := nil;
end;
procedure ReleasePointer(p:pointer);
var
junk : word;
begin
junk := FreeSelector(ptrrec(p).seg);
end;
procedure RealModeInterrupt(int:byte;var regs:TRealModeRegs);
label
okay;
begin
asm
mov ax,$0300
mov bl,int
mov bh,0
mov cx,0
les di,regs
int $31
jnc okay
end;
writeln('Real mode call failed!');
okay:
end;
function GetListOfLists:pointer;
{ Calls DOS service $52 to get pointer to list of lists, and
translates pointer to a pmode pointer }
var
regs : TRealModeRegs;
begin
fillchar(regs,sizeof(regs),0);
regs.ah := $52;
RealModeInterrupt($21,regs);
GetListOfLists := MakePointer(regs.es,regs.bx);
end;
procedure GetPrefixSeg;
{ Stores real mode segment of the PSP in MyPrefixSeg}
begin
MyPrefixSeg := GetSelectorBase(system.prefixseg) div 16;
end;
{$else}
function MakePointer(seg,ofs:word):pointer;
begin
MakePointer := Ptr(seg,ofs);
end;
procedure ReleasePointer(p:pointer);
begin
end;
function GetListOfLists:pointer;
var
regs : Registers;
begin
fillchar(regs,sizeof(regs),0);
regs.ah := $52;
msdos(regs);
GetListOfLists := MakePointer(regs.es,regs.bx);
end;
procedure GetPrefixSeg;
begin
MyPrefixSeg := PrefixSeg;
end;
{$endif}
type
dos2openfilerec = record
numhandles,
openmode : byte;
junk1 : array[2..3] of byte;
filename : array[4..$e] of char;
junk2 : array[$f..$27] of byte;
end;
dos30openfilerec = record {!!2}
numhandles,
openmode : word;
junk1 : array[4..$20] of byte; {!!2}
filename : array[$21..$2b] of char; {!!2}
junk2 : array[$2c..$31] of byte; {!!2}
pspseg : word; {!!2}
junk3 : array[$34..$37] of byte; {!!2}
end;
dos3openfilerec = record
numhandles,
openmode : word;
junk1 : array[4..$1f] of byte;
filename : array[$20..$2a] of char;
junk2 : array[$2b..$30] of byte; {!!2}
pspseg : word; {!!2}
junk3 : array[$33..$34] of byte; {!!2}
end;
dos4openfilerec = record
numhandles,
openmode : word;
junk1 : array[4..$1f] of byte;
filename : array[$20..$2a] of char;
junk2 : array[$2b..$30] of byte; {!!2}
pspseg : word; {!!2}
junk3 : array[$33..$3a] of byte; {!!2}
end;
filelistptr = ^filelistrec;
filelistrec = record
next : filelistptr;
numfiles : word;
case byte of
2 : (dos2files : array[1..1] of dos2openfilerec);
30 : (dos30files: array[1..1] of dos30openfilerec); {!!2}
3 : (dos3files : array[1..1] of dos3openfilerec);
4 : (dos4files : array[1..1] of dos4openfilerec);
end;
Tfilename = String[12];
function NiceName(filename:TFilename):TFilename;
var
result : string;
blankpos : byte;
begin
result := filename;
insert('.',result,9);
repeat
blankpos := pos(' ',result);
if blankpos > 0 then
delete(result,blankpos,1);
until blankpos = 0;
NiceName := result;
end;
procedure WalkList(var where:text;C:PCollection;Action:pointer;frame:word);
procedure Doit(filename:TFilename;openmode:word);
var
DoAction : procedure(f:string;openmode:word;dummy:word) absolute Action;
begin
filename := NiceName(filename);
if C <> Nil then
C^.Insert(NewStr(filename))
else if Action <> Nil then
DoAction(filename,openmode,frame)
else
writeln(where,filename);
end;
var
p : pointer;
list : filelistptr;
i : word;
begin
GetPrefixSeg; {!!3}
p := GetListOfLists; {!!3}
inc(longint(p),4); {!!3}
if ptrrec(p^).ofs <> $ffff then
list := MakePointer(ptrrec(p^).seg,ptrrec(p^).ofs) {!!3}
else
list := nil;
releasePointer(p); {!!3}
while list <> nil do
begin
with list^ do
for i:=1 to numfiles do
case lo(dosversion) of
2 : with dos2files[i] do
if numhandles > 0 then
doit(filename,openmode); {!!4}
3 : if hi(dosversion) = 0 then {!!2}
begin {!!2}
with dos30files[i] do {!!2}
if (numhandles > 0) and (allfiles or {!!2}
(pspseg = myprefixseg)) then{!!3}
doit(filename,openmode) {!!4}
end {!!2}
else {!!2}
with dos3files[i] do
if (numhandles > 0) and (allfiles or
(pspseg = myprefixseg)) then{!!3}
doit(filename,openmode); {!!4}
4..6 : with dos4files[i] do
if (numhandles > 0) and (allfiles or {!!2}
(pspseg = myprefixseg)) then {!!3}
doit(filename,openmode); {!!4}
end;
p := list;
if ptrrec(list^.next).ofs <> $ffff then
list := MakePointer(ptrrec(list^.next).seg,ptrrec(list^.next).ofs) {!!3}
else
list := nil;
ReleasePointer(p); {!!3}
end;
ReleasePointer(list); {!!3}
end;
procedure print_open_files(var where:text);
{ Print open file list to given file }
begin
WalkList(where,nil,nil,0);
end;
function get_open_files:PCollection;
{ Returns a new collection containing pointers to strings holding the
filenames }
var
result : PCollection;
junk : text;
begin
result := New(PCollection,init(16,16));
if result <> nil then
WalkList(junk,result,nil,0);
get_open_files := result;
end;
function CallerFrame:word;
Inline(
$8B/$46/$00/ { MOV AX,[BP]}
$24/$FE); { AND AL,$0FE}
procedure For_each_open_file(Action:pointer);
var
junk : text;
begin
WalkList(junk,nil,Action,CallerFrame);
end;
{$ifndef windows} { We don't use an exitproc in Windows}
var
exit_save : pointer;
procedure my_exit_proc; far;
var
junk : word;
begin
ExitProc := Exit_save;
junk := ioresult;
assign(output,'');
rewrite(output);
writeln('Files open as program terminates:');
print_open_files(output);
end;
{$endif}
begin
if not (lo(dosversion) in [2..6]) then
writeln('OPENFILES only works with DOS 2 to 6')
{$ifndef Windows}
else
begin
exit_save := ExitProc;
ExitProc := @my_exit_proc;
end
{$endif}
end.
{ ------------------ DEMO PROGRAM ----------------------- }
program test;
{ Test program for Openfiles unit. Should be compilable in TP/BP 6+, TPW 1.5+ }
uses
{$ifdef windows}
{$ifdef ver15}
wincrt,wobjects,openfiles;
{$else}
wincrt,objects,openfiles;
{$endif}
{$else}
objects,openfiles;
{$endif}
{ This routine uses the callback function "for_each_open_file". It's the
only way to get the file open mode. }
procedure doit(prefix:string);
procedure printone(f:string;openmode:word); far;
begin
writeln(prefix,f:12,' mode ',openmode);
end;
begin
for_each_open_file(@printone);
end;
{ This routine builds the collection of strings and prints it }
procedure doit2(prefix:string);
var
c:Pcollection;
{ Print each filename }
procedure printone(f:PString); far;
begin
writeln(prefix,f^);
end;
{ Release each string }
procedure disposeone(f:PString); far;
begin
DisposeStr(f);
end;
begin
c:=get_open_files;
if c <> nil then
begin
c^.foreach(@printone);
{ This shows the proper way to dispose of the collection }
c^.foreach(@disposeone);
c^.deleteall;
dispose(c,done);
end;
end;
var
f:file;
i : longint;
begin
assign(f,'test.pas');
reset(f);
allfiles := true;
doit('Open by some process: ');
allfiles := false;
doit2('Open by us: ');
{ At the end, the exitproc will print one more list (in DOS). }
end.
[Back to FILES SWAG index] [Back to Main SWAG index] [Original]