SWAGOLX.EXE (c) 1993 GDSOFT ALL RIGHTS RESERVED 00057 FILE HANDLING ROUTINES 1 05-28-9313:46ALL SWAG SUPPORT TEAM Change File Attribute IMPORT 11 .l╟√ {> How does one go about changing a File attributeπ> from hidden to unhidden using SetFAttr ?ππTry these two Procedures on For size:π}πGetFAttr(FName:String;Var RdOnly,Hid,Sys,Arch:Boolean);πVar R:Registers;πbeginπ FillChar(R,Sizeof(R),0);π FName := FName+#0; { set up as a null-terminated String For Dos }π With R Do beginπ AH := $43;π DS := Seg(FName); DX := ofs(FName)+1; { skip pascal length Byte }π MsDos(R);π RdOnly := (CL and $01) > 0;π Hid := (CL and $02) > 0;π Sys := (CL and $04) > 0;π Arch := (CL and $20) > 0;π end; { With }πend; { GetFAttr }ππPutFAttr(FName:String;RdOnly,Hid,Sys,Arch:Boolean);πVar R:Registers;πbeginπ FillChar(R,Sizeof(R),0);π FName := FName+#0; { set up as a null-terminated String For Dos }π With R Do beginπ AH := $43; AL := 1;π DS := Seg(FName); DX := ofs(FName)+1; { skip pascal length Byte }π if RdOnly then CL := CL or $01;π if Hid then CL := CL or $02;π if Sys then CL := CL or $04;π if Arch then CL := CL or $20;π MsDos(R);π end; { With }πend; { PutFAttr }ππ{The File FName does not have to be opened For this to work. In fact, itπwould probably be better if it were not.π}π 2 05-28-9313:46ALL SWAG SUPPORT TEAM Change File Attribute #2 IMPORT 6 .l▄┘ {πJOE DICKSONππ> I was wondering if someone could tell me how to change the Time and Dateπ> and maybe the Attribute of a File? Lets say I want to Change:π> FileNAME.EXT 1024 01-24-93 12:33p A to:π> FileNAME.EXT 1024 01-01-93 01:00a ARπ}ππProgram change_sample_Files_attribs;ππUsesπ Dos;ππVarπ f : File;π attr : Word;π time : LongInt;π DT : datetime;ππbeginπ assign(f, 'FileNAME.EXT');π DT.year := 93;π DT.month := 1;π DT.day := 1;π dt.hour := 1;π dt.min := 0;π dt.sec := 0;π packtime(dt, time);π attr := ReadOnly;π setftime(f, time);π setfattr(f, attr);πend.π 3 05-28-9313:46ALL SWAG SUPPORT TEAM FILEMODE.PAS IMPORT 16 .lΣM RB > I use a shared File to transfer info betweenπ > multitasker Windows that are running the same application.π > Lately, I have been getting Runtime errors 2, 5 & 162 in the following spoππTry to set the "FileMode" Constant to 66 (read/Write) orπ64 (read) beFore opening it. Here's a map of valid valuesπto FileMode:ππ ----- Sharing Method -----πAccess Compatibility Deny Deny Deny DenyπMethod Mode Both Write Read Noneπ___------------------------------------------------------πRead Only 0 16 32 48 64πWrite Only 1 17 33 49 65πRead/Write 2* 18 34 50 66ππ * = defaultππFile locking is seldom useful For Real life applications.πSometimes however, File locking MAY be appropriate, such asπwhen a Compiled list is produced at the Printer; if usersπare allowed to update the database then, the list can containπmultiple instances of a Record or reference... :-)ππUse Record locking instead, when required, For most purposesπand add logic to prevent disasters and user misunderstandings.πUsers will generally be more happy if they're not deniedπWrite access all the time... :-)ππRB > Perhaps I need to disable I/O checking and put in some Delays ifπ > this File is being accessed simulataneously. Also, the size of this FileππDefinately disable I/O checking. Don't add Delays if youπcan avoid it. Beware of dead-lock situations which occurπwhen two or more users access the same File With inadequateπaccess rights and they're all put on hold Until the Fileπis released by the other... One way to catch these situationsπis to retry a specified number of times and then cancel theπoperation With an error message perhaps.π 4 05-28-9313:46ALL SWAG SUPPORT TEAM FILENAME.PAS IMPORT 4 .l76 if you want to remove the period, and all Characters after it inπa valid Dos Filename, do the following...ππFileName := 'MYFile.TXT';πName := Copy(FileName, 1, Pos('.', FileName) - 1);ππThat will do it. or you can use FSplit to break out all theπdifferent parts of a Filename/path and get it that way.ππ 5 05-28-9313:46ALL SWAG SUPPORT TEAM FILESTMP.PAS IMPORT 10 .l-╩ { Example For GetFTime, PackTime,π SetFTime, and UnpackTime }ππUses Dos;πVarπ f: Text;π h, m, s, hund : Word; { For GetTime}π ftime : LongInt; { For Get/SetFTime}π dt : DateTime; { For Pack/UnpackTime}πFunction LeadingZero(w : Word) : String;πVarπ s : String;πbeginπ Str(w:0,s);π if Length(s) = 1 thenπ s := '0' + s;π LeadingZero := s;πend;πbeginπ Assign(f, 'RECURSEP.PAS');π GetTime(h,m,s,hund);π ReWrite(f); { Create new File }π GetFTime(f,ftime); { Get creation time }π WriteLn('File created at ',LeadingZero(h),π ':',LeadingZero(m),':',π LeadingZero(s));π UnpackTime(ftime,dt);π With dt doπ beginπ WriteLn('File timestamp is ',π LeadingZero(hour),':',π LeadingZero(min),':',π LeadingZero(sec));π hour := 0;π min := 1;π sec := 0;π PackTime(dt,ftime);π WriteLn('Setting File timestamp ',π 'to one minute after midnight');π Reset(f); { Reopen File For reading }π { (otherwise, close will update time) }π SetFTime(f,ftime);π end;π Close(f); { Close File }πend.π 6 05-28-9313:46ALL SWAG SUPPORT TEAM FILESTR.PAS IMPORT 10 .l╟í {$B-,D-,F-,I-,L-,N-,O-,R-,S-,V-}ππUnit Filestr;ππInterfaceππUses Dos;ππFunction GetFstr(Var f: Text): String;πProcedure OpenFStr(Var f: Text);ππImplementationππVarπ FStrBuff : String;ππFunction GetFStr(Var f: Text): String;π beginπ GetFStr := FStrBuff;π FStrBuff[0] := #0;π TextRec(f).BufPos := 0;π end; { GetFStr }π π{$F+}πFunction FStrOpen(Var f: TextRec):Word;π { This does nothing except return zero to indicate success }π beginπ FStrOpen := 0;π end; { FStrOpen }π πFunction FStrInOut(Var f: TextRec):Word;π beginπ FStrBuff[0] := chr(F.BufPos); π FStrInOut := 0;π end; { FStrInOut } π{$F-}ππProcedure OpenFStr(Var f: Text);π beginπ With TextRec(f) do beginπ mode := fmClosed;π BufSize := Sizeof(buffer);π OpenFunc := @FStrOpen;π InOutFunc := @FStrInOut;π FlushFunc := @FStrInOut;π CloseFunc := @FStrOpen;π BufPos := 0;π Bufend := 0;π BufPtr := @FStrBuff[1];π Name[0] := #0;π end; { With }π FStrBuff[0] := #0;π reWrite(f);π end; { AssignFStr } πππend. π 7 05-28-9313:46ALL SWAG SUPPORT TEAM FILEXIST.PAS IMPORT 6 .l*ä { 1 }ππFunction FileExist(FileName : String) : Boolean;πbeginπ FileExist := (FSearch(FileName, '') <> '')πend; (* FileExist. *)ππ{ 2 }ππFunction FileExist(FileName : String) : Boolean;πVarπ SRec : SearchRec;πbeginπ FindFirst(FileName, AnyFile, SRec);π FileExist := (DosError = 0);πend;ππ{ 3 }ππFunction FileExists(FileName : String) : Boolean;πVarπ DirInfo : SearchRec;πbeginπ FindFirst(FileName, AnyFile, DirInfo);π if (DosError = 0) thenπ FileExists := Trueπ elseπ FileExists := False;πend;ππ 8 05-28-9313:46ALL SWAG SUPPORT TEAM FILSHAR1.PAS IMPORT 6 .lµΘ Program ShareVolation;πUses Dos,Crt;πVarπ Dummy: Boolean;ππFunction FileOpen(F:String):Boolean;πVarπ Regs: Registers;π I: Byte;πbeginπ With Regs doπ beginπ Ah := $3d;π Al := 2;π Ds := Seg(F);π Dx := Ofs(F)+1;π end;π Intr($21,Regs);ππ WriteLn(F,' open: ',Regs.Ax = 5);π FileOpen := (Regs.Ax = 5);πend; { FileOpen }ππbeginπ Dummy := FileOpen('D:\FILSHARE.EXE'+#0);π Dummy := FileOpen('C:\CONFIG.SYS'+#0);π Dummy := FileOpen('C:\IO.SYS'+#0);π Dummy := FileOpen('C:\MSDos.SYS'+#0);πend.ππ{πAnd the funny thing was that it worked..π(But it returns error code 6 [Invalide handle] on closed Files)..π} 9 05-28-9313:46ALL SWAG SUPPORT TEAM FILSHAR2.PAS IMPORT 7 .lΘr Program ShareVolation;πUses Dos,Crt;ππFunction FileOpen(S:String):Boolean; Assembler;π{ -returns True if File already is open (Access denied) ..}πAsmπ PUSH DS { changes are in all caps }π mov ah,03dhπ xor al,alπ LDS DX, Sπ INC DX { point to contents of String }π int 21hπ mov bx,axπ mov al,0 { FileOpen = False }π jnc @endπ cmp bx,05h { Access denied}π jz @Openπ jmp @endππ@Open:π mov al,1 { FileOpen = True}π@end:π POP DSπend; { FileOpen }πππVarπ F : Text ;ππbeginπ FileMode := $10 ; { deny read/Write ?? }π Assign( F, 'C:\TEST.TXT' ) ;π ReWrite( F ) ;ππ WriteLn(FileOpen('C:\TEST.TXT'+ #0)); { SHARE is loaded }π Close( F ) ;πend.π 10 05-28-9313:46ALL SWAG SUPPORT TEAM FILSHAR3.PAS IMPORT 18 .l)╜ FileSHARinG !πππWhen sharing Files concurrently, by means of For example a multitasker or aπnetwork, it is necessary to use the File sharing as provided by the Dosπcommand SHARE, or as provided by a Network shell (In Novell File sharing isπsupported by the network shell on Servers, not locally. Check your networkπdocumentation For more inFormation).ππFile sharing is simple in TP/BP, since the system Variable FileMode definesπin what mode a certain File is opened in:ππConstπ fmReadOnly = $00; (* *)π fmWriteOnly = $01; (* Only one of these should be used *)π fmReadWrite = $02; (* *)ππ fmDenyAll = $10; (* together With only one of these *)π fmDenyWrite = $20; (* *)π fmDenyRead = $30; (* *)π fmDenyNone = $40; (* *)ππ fmNoInherit = $70; (* Set For "No inheritance" *)πππConstruction the FileMode Variable is easy, just add the appropriate values:ππFileMode:=fmReadOnly+fmDenyNone;π (Open File For reading only, allow read and Write.)ππFileMode:=fmReadWrite+fmDenyWrite;π (Open File For both read and Write, deny Write.)ππFileMode:=fmReadWrite+fmDenyAll;π (Open File For both read and Write, deny all.)ππSay you open the File in "fmReadWrite+fmDenyWrite". This will let you readπand Write freely in the File, While other processes can freely read the File.πif another process tries to open the File For writing, that process will getπthe error "Access denied".ππ(fmNoInherit is seldom used - it defines if a childprocess spawn from yourπprocess will be able to use the Filehandle provided by your process.)ππThe FileMode Variable is only used when the File is opened;ππ ...πAssign(F,FileName);πFileMode:=fmReadOnly+fmDenyNone;πReset(F);πFileMode:=<Whatever> (* Changing FileMode here does not affect theπ Files already opened *)ππBy default, FileMode is defined as FileMode:=$02 in TP/BP, this is referredπto as "Compatibility mode" in the TP/BP docs. Two processes accessing theπsame File With this Filemode results in the critical error "Sharingπviolation".π----------------------------------------------------------------------π 11 05-28-9313:46ALL SWAG SUPPORT TEAM LOCKFILE.PAS IMPORT 12 .lë( {π> Does anyone have any multi-tasking/File sharing Units (preferablyπ> With well documented code). Specifically, I need to Write a Programπ> that _may_ be active on one node, and I'd like to open the Files inπ> read-only Form, amung other things, so that I can load that inπ> multi-node (shared) environment.ππ}ππFunction LockFile(f : File) : Boolean; { returns True if lock achieved. }π { if not, File locked by other }π { application running. }ππVarπ r : Registers; {Defined in Dos Unit}π l : LongInt;ππbeginπ r.ah := $5C;π r.al := 0;π Move(f,r.bx,2); {Places File handle into BX register.}π r.cx := 0; {Most significant, region offset (0 - beginning of File)}π r.dx := 0; {Least significant, region offset (0 - beginning of File)}π l := FileSize(f); { Get File size }π r.di := l and $ffff; { Devide File size to most/least parts }π r.si := l div $10000; { For locking the entire File. }π MsDos(r);π LockFile := ((r.flags and 1)=0);π { if carry flag is set File locking failed, reason in AX }πend;ππ{πBTW: to unlock it use the same routine, but change the r.al to 1.ππif this routine fails, it means that the File is locked in the otherπtask, and cannot be used.π} 12 05-28-9313:46ALL SWAG SUPPORT TEAM MAXFILES.PAS IMPORT 9 .lI5 {π>I'm searching For a possibility to access more then 20 (I don't know the exactπ>number) Files at once With TP 7.0 (Real mode). I'll be happy if anyone can postπ>me sourcecode and technical information - technical information alone would beπ>enough, too.ππBoland Magazin 6/92 (Hot Line) Writes:ππThere is error in Dos: it's equal what you in Config.sys after Files= Write,πit can manage only 15 (!) open Files. Here is an Unit to outwit it:π(should be as first, can be not in overlay, entry also in config.sys)π}ππUnit maxFiles;ππInterfaceππConstπ maxFile = 255;π {for 250 open Files}πVarπ index: Integer;π puffer: Array[1..maxFile] of Byte;ππbeginπ For index := 1 to maxFile doπ puffer[index] := $FF;π For index := 1 to 5 doπ puffer[index] := mem[prefixseg:$18 + pred(index)];π memw[prefixseg:$32] := maxFile;π memw[prefixseg:$34] := ofs(puffer);π memw[prefixseg:$36] := seg(puffer);πend.π 13 05-28-9313:46ALL SWAG SUPPORT TEAM TRUENAME.PAS IMPORT 8 .lπ6 {πNORBERT IGLππ> Anyone has got an idea on how to know if a drive is a real one or theπ> result of a SUBST command Any help... welcome :-)ππWell, DOS ( esp. COMMAND.COM ) has a undocumented Commandπcalled TRUENAME, which takes wildcards also.π}ππProgram TrueName;ππusesπ DOS;ππfunction RealName(FakeName : String) : String;πVarπ Temp : String;π Regs : Registers;πbeginπ FakeName := FakeName + #0; { ASCIIZ }π With Regs doπ beginπ AH := $60;π DS := Seg(FakeName);π SI := Ofs(FakeName[1]);π ES := Seg(Temp);π DI := OfS(Temp[1]);π INTR($21, Regs);π DOSERROR := AX * ((Flags And FCarry) shr 7);π Temp[0] := #255;π Temp[0] := CHAR(POS(#0, Temp) - 1);π end;π If DosError <> 0 thenπ Temp := '';π RealName := Temp;πend;ππbeginπ writeln(RealName(Paramstr(0)));πend.π 14 05-29-9322:21ALL GAYLE DAVIS Set File Time (TOUCH) IMPORT 13 .lº& (* FT.PAS *)π(* Set file to a specific date *)ππUSES TPCrt, Dos, Misc, TimeDate;πVARπ f : TEXT;π h, m, s, hund : WORD; { For GetTime}π ftime : LONGINT; { For Get/SetFTime}π dt : DateTime; { For Pack/UnpackTime}π DateS : DateStr;π FName : STRING;ππPROCEDURE Syntax;πBEGINπ ResetAttr (7);π CLRSCR;π GOTOXY (1, 24);π WRITELN ('FT.EXE GDSOFT (c) 1992');π WRITELN ('Usage : FT filename date', #07);π HALT (1);πEND;ππFUNCTION UpperCase (InpStr : STRING) : STRING;ππVAR i : INTEGER;ππBEGINπ FOR i := 1 TO LENGTH (InpStr) DOπ UpperCase [i] := UPCASE (InpStr [i]);π UpperCase [0] := InpStr [0]πEND;ππFUNCTION LeadingZero (w : WORD) : STRING;πVARπ s : STRING;πBEGINπ STR (w : 0, s);π IF LENGTH (s) = 1 THENπ s := '0' + s;π LeadingZero := s;πEND;ππBEGINπ ResetAttr (7);π CLRSCR;π IF (PARAMCOUNT < 1) OR NOT Exist (PARAMSTR (1) ) THEN Syntax;π FName := UpperCase (PARAMSTR (1) );π IF NOT ValidDate (PARAMSTR (2) ) THEN DateS := PlainDate ELSE DateS := PARAMSTR (2);π ASSIGN (f, FName);π RESET (f);π GETFTIME (f, ftime); { Get creation time }π UNPACKTIME (ftime, dt);π WRITELN ('File ', FName, ' created at ', LeadingZero (dt.hour),π ':', LeadingZero (dt.min), ':',π LeadingZero (dt.sec), ' on ', dt.Month, '/', dt.day, '/', dt.year);π WITH dt DOπ BEGINπ FTime := PackDateTime (DateS, PlainTime);π WRITELN ('Setting file datestamp to ', MakeSlashDate (DateS) );π SETFTIME (f, ftime);π END;π CLOSE (f); { Close file }πEND.ππππ 15 06-08-9308:24ALL SWAG SUPPORT TEAM File Exist in Assembler IMPORT 13 .l8« {$A+,B-,D+,E+,F-,G+,I+,L+,N-,O-,P-,Q-,R-,S+,T-,V-,X+,Y+}π{$M 16384,0,655360}ππ{─ Fido Pascal Conference ────────────────────────────────────────────── PASCAL ─πMsg : 193 of 292πFrom : Wilbert van Leijen 2:281/256.14 14 May 93 19:29πTo : Vince Laurent 1:382/10.0πSubj : a few questions...π────────────────────────────────────────────────────────────────────────────────π07 May 93, Vince Laurent writes to All:ππ VL> 1. What is the quickest way to check for the existance of a file?π VL> I am going to be running the application on a network and wouldπ VL> like to minimize network traffic.ππYou cannot bypass the file server for this purpose, the reason should beπobvious. So peer-to-peer communication protocols are out.ππSuggestion: obtain the file's attributes using INT 21h, AH=43h, DS:DX -> ASCIIZπfilename.πIf this call sets the carry flag, the file doesn't exist. Otherwise, it does.πAdvantage: no need for an attempt to open it.}ππFunction FileExist(filename : String) : Boolean; Assembler;ππASMπ PUSH DSπ LDS SI, [filename] { make ASCIIZ }π XOR AH, AHπ LODSBπ XCHG AX, BXπ MOV Byte Ptr [SI+BX], 0π MOV DX, SIπ MOV AX, 4300h { get file attributes }π INT 21hπ MOV AL, Falseπ JC @1 { fail? }π INC AXπ@1: POP DSπend; { FileExist }ππ 16 06-08-9308:25ALL SWAG SUPPORT TEAM Binary Key Search - File IMPORT 27 .ld« {===========================================================================π BBS: Canada Remote SystemsπDate: 05-31-93 (20:29) Number: 24331πFrom: HERB BROWN Refer#: NONEπ To: ERIC GIVLER Recvd: NOπSubj: USERS FILE Conf: (1221) F-PASCALπ---------------------------------------------------------------------------πOn this day, <May 28 17:32>, Eric Givler (1:270/101.15@fidonet) noted:π EG> How would this help? You'd still have to search the entireπ EG> INDEX file LINEARLY, correct? Or would you have the INDEX sorted?π EG> If so, how would you keep it sorted? More input would REALLY beπ EG> appreciated!ππThis is code for a binary "split and search" method. Anyways, thats justπsomething I call it. Actually, it's a rudimentary binary search.ππSuppose you had a key record of }ππ key = recordπ reference : Longint; { room for a lot of records }π KeySearchField : String30; { The key string to be stored}π end; { Note, several smaller strings could be put together to make theπ search critical, i.e., keysearchField:=First+second+ThirdName;π As long as the field length stays less than or equal to what youπ defined }ππ{Then using a function that would return a boolean value, i.e., true if dataπmatches, false if not found, then it would look like so.. }ππFunction FindKey( VAR AKey : AKeyFile;π VAR AKeyRef : Longint;π FindMe : String80): Boolean;ππVAR High,Low,Mid : Longint; { For collision processing }π Target : Key;π Gotit : Boolean;π Collison : Boolean;π NumRecs : Longint;πππbeginπ AKeyRef :=0;π NumRecs := FileSize(AKey); {Get the number of records stored in file}ππ High := NumRecs;π Low := 0;π Mid := (Low + High) DIV 2 { Split point }π FindKey := False;π Gotit := False;π Collision := False;π If NumRecs > 0 Then {the file is not empty }π Repeatπ Seek(AKey,Mid);π Read(Akey,Target);π {Was there a position collision ??}π IF (Low = Mid) OR (High = Mid) the Collision := True;π IF Findme := Target.KeySearchField Then { Yay ! }π beginπ Gotit := True;π FindKey := True;π AKeyRef := Target.Reference;π Endπ Else { Divide in half and try it again..}π Beginπ If FindMe > Target.KeySearchField then Low := Midπ Else High := Mid;π Mid := (Low + High + 1) DIV 2;π AKeyRef := Midπ Endπ Until Collision or Gotit;πEnd;ππ(*πThis is a working example. There are some minor precautions that need to beπnoted, though. This will only work on sorted data, for one. The data can beπsorted with a Quick Sort and the key file re-written in sorted order. Theπadvantage here is the actual data file need not be sorted at all.ππAny time you work with a data base, get into the habit of ALWAYS including aπdeleted tag field. The above example lacks this, though.ππThis is just one of many ways of searching a database. Professional <grin>πapplications would probably be better suited for AVL trees or Btrees.ππBuilding an array "cache" helps speed up processing as well. That is wholeπ'nuder ball game, though.. *)π 17 06-22-9309:22ALL SWAG SUPPORT TEAM View File Object IMPORT 65 .lÇV { File Viewer Object }ππuses Dos, Crt;ππconstπ PrintSet: set of $20..$7E = [ $20..$7E ];π ExtenSet: set of $80..$FE = [ $80..$FE ];π NoPrnSet: set of $09..$0D = [ $09, $0A, $0D ];ππtypeπ CharType = ( Unknown, Ascii, Hex );π DataBlock = array[1..256] of byte;π Viewer = objectπ XOrg, YOrg,π LineLen, LineCnt, BlockCount : integer;π FileName : string;π FileType : CharType;π procedure FileOpen( Fn : string;π X1, Y1, X2, Y2 : integer );π function TestBlock( FileBlock : DataBlock;π Count : integer ): CharType;π procedure ListHex( FileBlock : DataBlock;π Count, Ofs : integer );π procedure ListAscii( FileBlock : DataBlock;π Count : integer );π end;ππ Finder = object( Viewer )π procedure Search( Fn, SearchStr : string;π X1, Y1, X2, Y2 : integer );π end;ππprocedure Finder.Search;π varπ VF : file; Result1, Result2 : word;π BlkOfs, i, j, SearchLen : integer;π SearchArray : array[1..128] of byte;π EndFlag, BlkDone, SearchResult : boolean;π FileBlock1, FileBlock2, ResultArray : DataBlock;π beginπ BlockCount := 0;π XOrg := X1;π YOrg := Y1;π LineLen := X2;π LineCnt := Y2;π FileType := Unknown;π SearchLen := ord( SearchStr[0] );π for i := 1 to Searchlen doπ SearchArray[i] := ord( SearchStr[i] );π for i := 1 to sizeof( ResultArray ) doπ ResultArray[i] := $00;ππ assign( VF, Fn );π {$I-} reset( VF, 1 ); {$I+}π if IOresult = 0 thenπ beginπ EndFlag := false;π BlkDone := false;π SearchResult := false;π BlockRead( VF, FileBlock2, sizeof( FileBlock2 ), Result2 );π EndFlag := Result2 <> sizeof( FileBlock2 );π repeatπ FileBlock1 := FileBlock2;π Result1 := Result2;π FileBlock2 := ResultArray;π if not EndFlag thenπ beginπ BlockRead( VF, FileBlock2, sizeof( FileBlock2 ), Result2 );π inc( BlockCount );π EndFlag := Result2 <> sizeof( FileBlock2 );π end else BlkDone := True;π for i := 1 to Result1 doπ beginπ if SearchArray[1] = FileBlock1[i] thenπ beginπ BlkOfs := i-1;π SearchResult := true;π for j := 1 to SearchLen doπ beginπ if i+j-1 <= Result1 thenπ beginπ if SearchArray[j] = FileBlock1[i+j-1] thenπ ResultArray[j] := FileBlock1[i+j-1] elseπ beginπ SearchResult := false;π j := SearchLen;π end;π end elseπ if SearchArray[j] = FileBlock2[i+j-257] thenπ ResultArray[j] := FileBlock2[i+j-257] elseπ beginπ SearchResult := false;π j := SearchLen;π end;π end;π if SearchResult thenπ beginπ for j := SearchLen+1 to sizeof( ResultArray ) doπ if i+j-1 <= Result1π then ResultArray[j] := FileBlock1[i+j-1]π else ResultArray[j] := FileBlock2[i+j-257];π i := Result1;π end;π end;π end;π until BlkDone or SearchResult;π if SearchResult thenπ beginπ writeln( 'Search string found in file block ', BlockCount,π ' beginning at byte offset ', BlkOfs, ' ...' );π writeln;π if FileType = Unknown thenπ FileType := TestBlock( ResultArray,π sizeof( ResultArray ) );π case FileType ofπ Hex : ListHex( ResultArray, sizeof( ResultArray ), BlkOfs );π Ascii : ListAscii( ResultArray, sizeof( ResultArray ) );π end;π end else writeln( '"', SearchStr, '" not found in ', FN );π close( VF );π window( 1, 1, 80, 25 );π end else writeln( Fn, ' invalid file name!' );π end;ππprocedure Viewer.FileOpen;π varπ VF : file; Ch : char;π Result, CrtX, CrtY : word;π EndFlag : boolean;π FileBlock : DataBlock;π beginπ BlockCount := 0;π XOrg := X1;π YOrg := Y1;π LineLen := X2;π LineCnt := Y2;π FileType := Unknown;π assign( VF, Fn );π {$I-} reset( VF, 1 ); {$I+}π if IOresult = 0 thenπ beginπ window( X1, Y1, X1+X2-1, Y1+Y2-1 );π writeln;π EndFlag := false;π repeatπ BlockRead( VF, FileBlock, sizeof( FileBlock ), Result );π inc( BlockCount );π EndFlag := Result <> sizeof( FileBlock );π if FileType = Unknown thenπ FileType := TestBlock( FileBlock, Result );π case FileType ofπ Hex : ListHex( FileBlock, Result, 0 );π Ascii : ListAscii( FileBlock, Result );π end;π if not EndFlag thenπ beginπ CrtX := WhereX; CrtY := WhereY;π if WhereY = LineCnt thenπ begin writeln;π dec( CrtY ); end;π gotoxy( 1, 1 ); clreol;π write(' Viewing: ', FN );π gotoxy( 1, LineCnt ); clreol;π write(' Press (+) to continue, (Enter) to exit: ');π Ch := ReadKey; EndFlag := Ch <> '+';π gotoxy( 1, LineCnt ); clreol;π gotoxy( CrtX, CrtY );π end;π until EndFlag;π close( VF );π sound( 440 ); delay( 100 );π sound( 220 ); delay( 100 ); nosound;π window( 1, 1, 80, 25 );π end else writeln( Fn, ' invalid file name!' );π end;ππfunction Viewer.TestBlock;π varπ i : integer;π beginπ FileType := Ascii;π for i := 1 to Count doπ if not FileBlock[i] in NoPrnSet+PrintSet thenπ FileType := Hex;π TestBlock := FileType;π end;ππprocedure Viewer.ListHex;π constπ HexStr: string[16] = '0123456789ABCDEF';π varπ i, j, k : integer;π beginπ k := 1;π repeatπ write(' ');π j := (BlockCount-1) * sizeof( FileBlock ) + ( k - 1 ) + Ofs;π for i := 3 downto 0 doπ write( HexStr[ j shr (i*4) AND $0F + 1 ] );π write(': ');π for i := 1 to 16 doπ beginπ if k <= Count thenπ write( HexStr[ FileBlock[k] shr 4 + 1 ],π HexStr[ FileBlock[k] AND $0F + 1 ], ' ' )π else write( ' ' );π inc( k );π if( i div 4 = i / 4 ) then write(' ');π end;π for i := k-16 to k-1 doπ if i <= Count thenπ if FileBlock[i] in PrintSet+ExtenSetπ then write( chr( FileBlock[i] ) )π else write('.');π writeln;π until k >= Count;π end;ππprocedure Viewer.ListAscii;π varπ i : integer;π beginπ for i := 1 to Count doπ beginπ write( chr( FileBlock[i] ) );π if WhereX > LineLen then writeln;π if WhereY >= LineCnt thenπ beginπ writeln;π gotoxy( 1, LineCnt-1 );π end;π end;π end;ππ{=============== end Viewer object ==============}ππvarπ FileFind : Finder;πbeginπ clrscr;π FileFind.Search( ParamStr(0), { file to search }π 'Press any key', { search string }π 1, 1, 80, 25 ); { display window }π gotoxy( 1, 25 ); clreol;π write( 'Press any key to continue: ');π while not KeyPressed do;πend. 18 07-16-9306:07ALL ROB PERELMAN Find Data at end of EXE IMPORT 21 .lQc ===========================================================================π BBS: Canada Remote SystemsπDate: 06-24-93 (15:37) Number: 27580πFrom: ROB PERELMAN Refer#: NONEπ To: ALL Recvd: NO πSubj: End of EXE Conf: (1221) F-PASCALπ---------------------------------------------------------------------------πThis is a unit I wrote but it crashed a few times on me, so here is anπupdated unit for anyone's use. Remember not to use it from the TPπeditor because if you compile to memory, PARAMSTR(0) is the editor, andπif you compile to disk, you will not have any data.ππUnit ExeEnd;ππInterfaceππVar EndOfExe: LongInt; {Shows the end of the EXE file}π ExeFile: File; {The EXE file positioned at the end}π Data: Boolean; {If there is data after the EXE}ππImplementationππType EXEHeader=Recordπ ID: Word; { EXE file id }π ByteMod: Word; { Load module image size mod 512 }π Pages: Word; { File size (including header) div 512 }π RelocItems: Word; { Number of relocation table items }π Size: word; { Header size in 16-byte paragraphs }π MinParagraphs: Word; { Minimum number of paragraphs above program }π MaxParagraphs: Word; { Maximum number of paragraphs above program }π StackSeg: Word; { Displacement of stack segment }π SPReg: Word; { Initial SP register value }π CheckSum: Integer; { Word checksum - negative sum (not used) }π IPReg: Word; { Initial IP register value }π CodeSeg: Word; { Displacement of code segment }π FirstReloc: Word; { First relocation item }π OvlN: Word { Overlay number }π End;ππConst CorrectExe=$5A4D;ππVar Exe: EXEHeader;π ReadIn: Integer;π OldExitProc: Pointer;ππProcedure CloseExe; Far;πBeginπ ExitProc:=OldExitProc;π Close(ExeFile);πEnd;ππBeginπ OldExitProc:=ExitProc;π ExitProc:=@CloseExe;π Assign(ExeFile, ParamStr(0));π Reset(ExeFile, 1);π BlockRead(ExeFile, Exe, SizeOf(Exe), ReadIn);π With Exe do If (ReadIn<>SizeOf(Exe)) or (ID<>CorrectExe) then EndOfExe:=0π Else EndOfExe:=Pages*512+ByteMod-512;π Seek(ExeFile, EndOfExe);π Data:=Not EOF(ExeFile);πEnd.ππ * QMPro 1.50 4 * "Call waiting", great if you have two friendsπππ--- WM v3.00/92-0215π * Origin: High Country East, Ramona, CA (619)-789-4391 (1:202/1308.0)π 19 07-16-9306:11ALL KELD R. HANSEN Self Modify EXE File IMPORT 52 .lQc ===========================================================================π BBS: Canada Remote SystemsπDate: 07-03-93 (11:56) Number: 29412πFrom: KELD R. HANSEN Refer#: NONEπ To: JON JASIUNAS Recvd: NO πSubj: Re: Self-modifying .EXEs Conf: (1221) F-PASCALπ---------------------------------------------------------------------------πIn a message dated 28 Jun 93, Jon Jasiunas (1:273/216.0) wrote:ππ > Here's the code I use for my self-modifying .EXEs. I've used itπ > successfully in several applications.ππIt works fine (I have one similar of my own), but it doesn't take care of DPMIπprograms and won't work if your "customer" PKLITEs the program.ππTYPEπ ExeHeaderDOS = RECORDπ { 00 } Signature : ARRAY[1..2] OF CHAR;π { 02 } LastPageSize : WORD;π { 04 } Pages : WORD;π { 06 } RelocItems : WORD;π { 08 } HeaderSizePara : WORD;π { 0A } MinMemPara : WORD;π { 0C } MaxMemPara : WORD;π { 0E } EntrySS : WORD;π { 10 } EntrySP : WORD;π { 12 } CheckSum : WORD;π { 14 } EntryIP : WORD;π { 16 } EntryCS : WORD;π { 18 } FirstRelocItemOfs : WORD;π { 1A } OverlayNumber : WORD;π Reserved : ARRAY[$1C..$23] OF BYTE;π { 24 } IdentifierOEM : WORD;π { 26 } InformationOEM : WORD;π ReservedToo : ARRAY[$28..$3B] OF BYTE;π { 3C } NewExeHeaderOfs : LONGINTπ END;π ExeHeaderOS2 = RECORDπ Signature : ARRAY[1..2] OF CHAR;π LinkerMajorVers : BYTE;π LinkerMinorVers : BYTE;π EntryTableOfs : WORD;π EntryTableSize : WORD;π CRC : LONGINT;π ModuleFlags : WORD;π SegmentNoDGROUP : WORD;π HeapSize : WORD;π StackSize : WORD;π EntryIP : WORD;π EntryCS : WORD;π EntrySP : WORD;π EntrySS : WORD;π SegmentTableEntries : WORD;π ModuleRefEntries : WORD;π NonResNameTableSize : WORD;π SegTableOfs : WORD;π ResourceTableOfs : WORD;π ResNamesTableOfs : WORD;π ModuleRefTableOfs : WORD;π ImpNamesTableOfs : WORD;π NonResNamesTableOfs : LONGINT;π MovableEntryPoints : WORD;π AlignmentUnitPower : WORD;π ResourceTableEntries: WORD;π TargetOS : BYTE;π WindowsFlags : BYTE;π FastLoadStart : WORD;π FastLoadSize : WORD;π Reserved : WORD;π WindowsVers : WORDπ END;π SegTableRec = RECORDπ Start : WORD;π Size : WORD;π Flags : WORD;π MinSize : WORDπ END;π FileOffset = LONGINT;ππPROCEDURE ReadOnly;π INLINE($C6/$06/FileMode/$A0);ππPROCEDURE ReadWrite;π INLINE($C6/$06/FileMode/$02);ππ{ ExeOfs returns the offset of the item V in the .EXE file of the currently }π{ running program. Use this to get the offset of a configuration record that }π{ is located in the .EXE file (remember that you must declare it as a typed }π{ constant to include it in the .EXE file) }ππ{$IFDEF DPMI }πFUNCTION ExeOfs(CONST V) : FileOffset;π VARπ HeaderDOS : ExeHeaderDOS;π HeaderOS2 : ExeHeaderOS2;π FIL : FILE;π CodeSeg,Seg : WORD;π SegTab : SegTableRec;ππ BEGINπ ReadOnly;π ASSIGN(FIL,ParamStr(0)); RESET(FIL,1);π BLOCKREAD(FIL,HeaderDOS,SizeOf(ExeHeaderDOS));π IF HeaderDOS.Signature<>'MZ' THENπ ExeOfs:=-1π ELSE BEGINπ SEEK(FIL,HeaderDOS.NewExeHeaderOfs);π BLOCKREAD(FIL,HeaderOS2,SizeOf(ExeHeaderOS2));π IF HeaderOS2.Signature<>'NE' THENπ ExeOfs:=-1π ELSE BEGINπ ASMπ MOV BX,WORD PTR V+2π MOV CX,SSπ CMP BX,CXπ JE @STACKπ XOR AX,AXπ VERW BXπ JZ @OUTπ MOV ES,BXπ MOV AX,ES:[0000h]π JMP @OUTπ @STACK: MOV AX,HeaderOS2.EntrySSπ @OUT: MOV CodeSeg,AXπ END;π IF CodeSeg<>0 THEN BEGINπ SEEK(FIL,HeaderDOS.NewExeHeaderOfs+HeaderOS2.SegTableOfs+π PRED(CodeSeg)*SizeOf(SegTableRec));π BLOCKREAD(FIL,SegTab,SizeOf(SegTableRec)) ENDπ ELSE BEGINπ SEEK(FIL,HeaderDOS.NewExeHeaderOfs+HeaderOS2.SegTableOfs);π FOR Seg:=1 TO HeaderOS2.SegmentTableEntries DO BEGINπ BLOCKREAD(FIL,SegTab,SizeOf(SegTableRec));π IF (SegTab.Start>0) AND (SegTab.Flags AND $0001=$0001) THEN BREAKπ ENDπ END;π ExeOfs:=SegTab.Start SHL HeaderOS2.AlignmentUnitPower+OFS(V)π ENDπ END;π CLOSE(FIL);π ReadWriteπ END;π{$ELSE }πFUNCTION ExeOfs(CONST V) : FileOffset;π VARπ HeaderDOS : ExeHeaderDOS;π FIL : FILE;ππ BEGINπ ReadOnly;π ASSIGN(FIL,ParamStr(0)); RESET(FIL,1);π BLOCKREAD(FIL,HeaderDOS,SizeOf(ExeHeaderDOS));π CLOSE(FIL);π ExeOfs:=(HeaderDOS.HeaderSizePara+(SEG(V)-(PrefixSeg+$0010)))*16+OFS(V)π END;π{$ENDIF }π 20 08-18-9312:21ALL JOSE ALMEIDA Check for a file IMPORT 8 .l∞Φ { Checks the existance of a file.π Part of the Heartware Toolkit v2.00 (HTfile.PAS) for Turbo Pascal.π Author: Jose Almeida. P.O.Box 4185. 1504 Lisboa Codex. Portugal.π I can also be reached at RIME network, site ->TIB or #5314.π Feel completely free to use this source code in any way you want, and, ifπ you do, please don't forget to mention my name, and, give me and Swag theπ proper credits. }ππFUNCTION File_Found(FName : string) : integer;π{ DESCRIPTION:π Checks the existance of a file.π SAMPLE CALL:π I := File_Found('C:\COMMAND.COM');π RETURNS:π 0 : file was foundπ 18 : file was NOT foundπ else : DosError code }ππvarπ SR : SearchRec;ππBEGIN { File_Found }π {$I-}π FindFirst(FName,Archive,SR);π File_Found := DosError;π {$I+}πEND; { File_Found }π 21 08-18-9312:22ALL JOSE ALMEIDA Get size of file IMPORT 9 .l╗ { Gets size of existing file, in bytes.π Part of the Heartware Toolkit v2.00 (HTfile.PAS) for Turbo Pascal.π Author: Jose Almeida. P.O.Box 4185. 1504 Lisboa Codex. Portugal.π I can also be reached at RIME network, site ->TIB or #5314.π Feel completely free to use this source code in any way you want, and, ifπ you do, please don't forget to mention my name, and, give me and Swag theπ proper credits. }ππPROCEDURE Get_File_Size(FName : string;π var FSize : longint;π var Error : word);π{ DESCRIPTION:π Gets size of existing file, in bytes.π SAMPLE CALL:π Get_File_Size('C:\COMMAND.COM',FSize,Error);π RETURNS:π FSize : 0 if errorπ else file sizeπ Error : DosError code }ππvarπ SR : SearchRec;ππBEGIN { Get_File_Size }π {$I-}π FindFirst(FName,Archive,SR);π Error := DosError;π {$I+}π if Error = 0 thenπ FSize := SR.Sizeπ elseπ FSize := 0;πEND; { Get_File_Size }π 22 08-27-9321:20ALL MARCO MILTENBURG File and Record Locks IMPORT 26 .l┬π {πMARCO MILTENBURGππ> Currently I'm writing a Program which must be able to handle multitaskπ> evironments. But as I'm trying to Write a Record which is open in anotherπ> Window (of DesqView for instance) than a runtime error 5 appears. Seemsπ> logical. But how do I 'lock' the Record, what are the attibutes, and whatπ> must the Program do if it can't open a Record???ππ Locking isn't that difficult... First of all, do you have to keep theπFile available For anybody else (in another task) or not. if not, use theπFilesharing bits when you're opening the File. They are :ππbit 0-2 = 000 - read permission For your own applictionπ 001 - Write permission For you own applicationπ 010 - both read and Write permission For you own applicationππbit 3 = 0 - Always zero!ππbit 4-6 = 000 - compatibilty mode. Share the File whenever possible.π 001 - reading and writing not allowed For other applicationsπ 010 - writing not allowed For other applications (usefull whenπ you're gonna read the File, so others can not update it)π 011 - reading not allowed For other applications (usefull whenπ you're gonna update the File and others may not read it).π 100 - Full access For other applications (dangerous in my point ofπ view!).ππbit 7 = 0 - Lower process owns Fileπ 1 - File only For current process.ππSet the bits to your needs and assign the value to FileMode before opening theπFile. For example, I want to read a File which must be locked completly. Isπmust use the value 00010000b which is $10. So use FileMode = $10 before openingπthe File. Please note that FileMode only take affect on Files which areπdeclared as ': File' or ': File of ....'. It's not supported on ': Text' Files.πif you want to lock these Files, use the next method.ππif you only want to lock a single Record of a File (or an entier File) you canπuse the following Function :πππOoh BTW: This will only work With Dos 3.0+ (of course ;-) With SHARE loaded.π}ππFunction FileLocking(Action : Byte;π Handle : Word;π Start, end : LongInt) : Boolean;πVarπ Regs : Registers;πbeginπ Regs.AH := $5C;π Regs.AL := Action;π Regs.BX := Handle;π Regs.CX := Hi(Start);π Regs.DX := Lo(Start);π Regs.DI := Lo(end);π Regs.SI := Hi(end);π Intr($21, Regs);π FileLocking := ((Regs.FLAGS and $01) = 0);πend;ππ{πUse For Action '0' to lock or '1' to unlock the File. The funtion returns Trueπwhen succesfull. The Handle Variable must contain the Filehandle, assigned byπDos. For TextFiles you can obtain this handle With :ππ TextRec(T).Handleππwhere T is the TextFile (declared With T : Text). I don't know how to obtainπthe Filehandle of another FileType at the moment. I will have to look For it.πStart and end contain the starting and ending position (in Bytes) from what youπwant to lock (for Typed Files, they can easaly be calculated using FilePos andπSizeOf(....Record) etc..). if you want to lock the entire File, use 0 For startπand $FFFFFFFF For end. Locking beyond the end of the File doesn't result in anπerror!π}π 23 08-27-9321:22ALL JASON GROOMS Delete a file QUICK IMPORT 11 .lL {πJASON GROOMSππ| Can anyone give me some code for a procedure to delete a file? Iπ| cannot use the DOS EXEC procedure, due to memory conflicts, but I canπ| call on interrupts.ππHere is a routine to add to your toolbox which will delete a fileπthrough DOS.π}ππfunction DeleteFile(FN : PathStr) : Boolean;πvarπ Regs : Registers;πbeginπ FN := FN + #0; { Add NUL chr for DOS }π Regs.AH := $41;π Regs.DX := Ofs(FN) + 1; { Add 1 to bypass length byte }π Regs.DS := Seg(FN);π MsDos(Regs);π DeleteFile := NOT (Regs.Flags AND $0 = $0)πend;ππ{ Here is another routine to rename a file through DOS. }ππfunction RenameFile(ON, NN : PathStr) : Boolean;πvarπ Regs : Registers;πbeginπ ON := ON + #0; { Add NUL chr for DOS }π NN := NN + #0; { Add NUL chr for DOS }π Regs.AH := $56;π Regs.DX := Ofs(ON) + 1; { Add 1 to bypass length byte }π Regs.DS := Seg(ON);π Regs.DI := Ofs(NN) + 1; { Add 1 to bypass length byte }π Regs.ES := Seg(NN);π MsDos(Regs);π RenameFile := NOT (Regs.Flags AND $0 = $0)πend;ππ{πThese two routines require the Dos unit.ππ ** Be warned that the delete file routine does not confirm theπ delete, meaning it WILL delete the file if it exists so useπ with care.ππ} 24 08-27-9321:22ALL SEAN PALMER Faster File Exists IMPORT 15 .l¬ε {πSEAN PALMERππI just ran some timings, which are gonna be affected by SMARTDRV.EXEπbeing loaded, but I took that into account (ran multiple times on sameπfile, and took timings on second/subsequent runs, to make sure alwaysπgot cache hits)ππWhat I got was that FileExists below and my modified version of thatπfileExist3 function that's been floating around this echo for a whileπ(no bug) both run neck and neck... it's amazing... both are slightlyπfaster than FileExist2 and lots lots faster than the 'reset,πfileExist=(ioresult=0)' type thing that most people still seem to use...ππI'd recommend using the first one below as it's really short...π}ππusesπ dos;ππ{ Tied for fastest }πfunction fileExists(var s : string) : boolean;πbeginπ fileExists := fSearch(s, '') <> '';πend;ππ{ 2nd }πfunction fileExist2(var s : string) : boolean;πvarπ r : searchrec;πbeginπ findfirst(s, anyfile, r);π fileExist2 := (dosError = 0);πend;ππ{ Tied for fastest }πfunction fileExist3(var s : string) : boolean; assembler;πasmπ push dsπ lds si, s { need to make ASCIIZ }π cldπ lodsb { get length; si now points to first char }π xor ah, ahπ mov bx, axπ mov al, [si+bx] { save byte before placing terminating null }π push axπ mov byte ptr [si+bx],0π mov dx, siπ mov ax, $4300 { get file attributes }π int $21π mov al, 1 { if carry set, fail }π pop dxπ mov [si+bx], dl { restore byte }π pop dsπend;ππ{ Slowest }πfunction fileExist4(var s : string) : boolean;πvarπ f : file;πbeginπ assign(f,s);π {$I-}π reset(f);π {$I+}π if ioresult = 0 thenπ beginπ close(f);π fileExist4 := true;π endπ elseπ fileExist4 := false;πend;ππ 25 08-27-9321:23ALL LOU DUCHEZ Set DOS Filemode IMPORT 7 .lF∩ LOU DUCHEZππ>Could someone post all the different File Modes availl with FileMode, and aπ>short descript of each one?ππThe FileMode byte reserves certain bits to specify different capabilities.πThey are:ππ76543210π--------π.....000 - Read accessπ.....001 - Write accessπ.....010 - Read/write accessπ....0... - Reserved - must be zeroπ.000.... - Sharing mode - compatibility mode ["no sharing"?]π.001.... - Sharing mode - read/write access deniedπ.010.... - Sharing mode - write access deniedπ.011.... - Sharing mode - read access deniedπ.100.... - Sharing mode - full access permittedπ0....... - Inherited by child processesπ1....... - Private to current processππI got this out of a pocket DOS/BIOS reference -- hope it helps.π 26 08-27-9321:59ALL MICHAEL REECE File spliting IMPORT 26 .lÄ3 {πMICHAEL REECEππ> Hi! I was wondering. How would you in Turbo Pascal be able to split aπ> single File into two. I want it to split it to a precise Byte For bothπ> Files. I want to be able to combine to Files together and split it to itsπ> original sizes and still be able to work (that no codes are missing etc.).ππThe following is kludgy and only semi tested, but may help you get started.πIt's an old little thing I wrote to split large Files to put on a floppy, andπthen put it back together again.π}ππ(* usage: split <Filename> <new-name-for-second-half>π ex: split nodelist.zip nodelist.zi2π*)πProgram Split;ππConstπ MaxBuffSize = 61140;ππTypeπ BuffType = Array[1..MaxBuffSize] of Byte;ππVarπ F1, F2 : File;π Mid : LongInt;π Buffer : ^BuffType;π BuffSize : LongInt;π NumRead,π NumWrite : Word;ππbeginπ Writeln('Splitting File "', ParamStr(1), '"');π Assign(F1, ParamStr(1));π Reset(F1, 1);π Mid:=FileSize(F1) div 2; { calculate midpoint }π Writeln(' Original size: ', FileSize(F1));π Writeln(' File midpoint: ', Mid);π Writeln('Creating File "', ParamStr(2), '"');π Assign(F2, ParamStr(2));π ReWrite(F2, 1);π Writeln('Memory available: ', MaxAvail); { allocate max buffer }π BuffSize:=MaxAvail;π if (BuffSize > MaxBuffSize) thenπ BuffSize:=MaxBuffSize;π GetMem(Buffer, BuffSize);π Writeln(' Buffer size: ', BuffSize);π Writeln('Seeking to midpoint');π Seek(F1, Mid);π Writeln(' Copying remainder of File');π While (not Eof(F1)) doπ beginπ BlockRead(F1, Buffer^, BuffSize, NumRead);π BlockWrite(F2, Buffer^, NumRead, NumWrite);π if (NumRead <> NumWrite) thenπ beginπ Writeln('Error in copy');π Halt(1);π end;π end;π Writeln('Seeking to midpoint');π Seek(F1, Mid);π Writeln(' Truncating File');π Truncate(F1);π Writeln('Closing Files');π Close(F2);π Close(F1);π Writeln('Done.');πend.ππ{ That one splits a File in half. }ππ(* usage: splice <Filename> <name-of-second-half>π ex: split nodelist.zip nodelist.zi2π this will append/splice nodelist.zi1 to nodelist.zipπ*)πProgram Splice;ππConstπ MaxBuffSize = 61140;ππTypeπ BuffType = Array[1..MaxBuffSize] of Byte;ππVarπ F1, F2 : File;π Buffer : ^BuffType;π BuffSize : LongInt;π NumRead,π NumWrite : Word;ππbeginπ Writeln('Splicing File "', ParamStr(1), '"');π Assign(F1, ParamStr(1));π Reset(F1, 1);π Writeln(' Original size: ', FileSize(F1));π Writeln('Appending File "', ParamStr(2), '"');π Assign(F2, ParamStr(2));π Reset(F2, 1);π Writeln(' Original size: ', FileSize(F1));π Writeln('Memory available: ', MaxAvail); { allocate max buffer }π BuffSize:=MaxAvail;π if (BuffSize > MaxBuffSize) thenπ BuffSize:=MaxBuffSize;π GetMem(Buffer, BuffSize);π Writeln(' Buffer size: ', BuffSize);π Writeln('Seeking to end');π Seek(F1, FileSize(F1));π Writeln(' Copying File');π While (not Eof(F2)) doπ beginπ BlockRead(F2, Buffer^, BuffSize, NumRead);π BlockWrite(F1, Buffer^, NumRead, NumWrite);π if (NumRead <> NumWrite) thenπ beginπ Writeln('Error in copy');π Halt(1);π end;π end;π Writeln('Closing Files');π Writeln('Done.');π Close(F2);π Close(F1);πend.ππ 27 08-27-9322:11ALL SWAG SUPPORT TEAM Wipe file from Disk IMPORT 17 .lç√ {π> I'm looking For a turbo pascal routine that will wipe Filesπ> off of disks the way (or similar to the way) that Norton'sπ> Wipeinfo wipe's Files. I'd like the call to be somethingπ> like wipeFile(fn:String); Preferrably, I would also likeπ> the deleted directory entry wiped to prevent one from seeingπ> what the File that used to be there was named, or how largeπ> it was. Any help would greatly be appreciated.ππ> Here is my wipe File. The directory entry is not cleared.πWell, today an idea occured: clearing directory entries is not asπdifficult as I tought. No Assembler needed, no strange Dos calls, justπplain TP. Here an updated version. Even the CIA won't get your Filesπback!π}ππProcedure DosWipe(Path : PathStr);π{ wipes Files according to Department of Defense standard DOD 5220.22-M }πVarπ DataFile : File;π DirInfo : SearchRec;ππ Procedure WipeFile(Var DataFile : File);π Constπ NullByte : Byte = 0;π FFByte : Byte = $FF;π F6Byte : Byte = $F6;π Varπ Result : Word;π Count : Byte;π Count2 : LongInt;π beginπ Reset(DataFile, 1);π For Count := 1 to 3 doπ beginπ Seek(DataFile,0);π For Count2 := 0 to FileSize(DataFile) - 1 doπ BlockWrite(DataFile, FFByte, 1, result);π Seek(DataFile,0);π For Count2 := 0 to FileSize(DataFile) - 1 doπ BlockWrite(DataFile, NullByte, 1, result);π end;ππ Seek(DataFile, 0);π For Count := 0 to FileSize(DataFile) - 1 doπ BlockWrite(DataFile, F6Byte, 1, result);π Close(DataFile);π end;ππ Procedure ClearDirEntry;π beginπ Reset(DataFile);π Truncate(DataFile); { erase size entry }π Close(DataFile);π Rename(DataFile, 'TMP00000.$$$'); { erase name entry }π end;ππVarπ D : DirStr;π N : NameStr;π E : ExtStr;πbeginπ FSplit(Path, D, N, E);π FindFirst(Path, Archive, DirInfo);ππ While DosError = 0 doπ beginπ Assign(DataFile, D+DirInfo.Name);π WipeFile(DataFile);π ClearDirEntry;π Erase(DataFile);π FindNext(DirInfo);π end;πend;ππ 28 09-26-9309:04ALL MARTIN RICHARDSON Check for file EXIST IMPORT 6 .l"; {*****************************************************************************π * Function ...... Exist()π * Purpose ....... Checks for the existance of a file/directoryπ * Parameters .... sExp File/directory name to check forπ * Returns ....... TRUE if sExp existsπ * Notes ......... Not picky, will even accept wild cardsπ * Author ........ Martin Richardsonπ * Date .......... May 13, 1992π *****************************************************************************}πFUNCTION Exist( sExp: STRING ): BOOLEAN;πVAR s : SearchRec;πBEGINπ FINDFIRST( sExp, AnyFile, s );π Exist := (DOSError = 0);πEND;ππ 29 09-26-9309:11ALL MARTIN RICHARDSON Check if IS File IMPORT 7 .l"█ {*****************************************************************************π * Function ...... IsFile()π * Purpose ....... Checks for the existance of a fileπ * Parameters .... sFile File to check forπ * Returns ....... TRUE if sFile existsπ * Notes ......... Noneπ * Author ........ Martin Richardsonπ * Date .......... May 13, 1992π *****************************************************************************}π{ Checks for existance of a file }πFUNCTION IsFile( sFile: STRING ): BOOLEAN;πVAR s : SearchRec;πBEGINπ FINDFIRST( sFile, directory, s );π IsFile := (DOSError = 0) ANDπ (s.Attr AND Directory <> Directory) ANDπ (POS( '?', sFile ) = 0) ANDπ (POS( '*', sFile ) = 0);πEND;ππ 30 09-26-9309:30ALL MARTIN RICHARDSON Create a TEMP filename IMPORT 10 .l"s {*****************************************************************************π * Function ...... TempFile()π * Purpose ....... To create a unique file name for use as a temporary workπ * fileπ * Parameters .... Path Location to create the fileπ * Returns ....... Name of temporary fileπ * Notes ......... Uses the functions Right, ItoS, Exist, and Emptyπ * Author ........ Martin Richardsonπ * Date .......... May 13, 1992π *****************************************************************************}πFUNCTION TempFile( Path: STRING ): STRING;πVAR π DateStr : DateTime;π Trash : WORD;π Time : LONGINT;π FileName : STRING;πBEGINπ IF (NOT Empty( Path )) AND (Right( Path, 1 ) <> '\') THENπ Path := Path + '\';π REPEATπ WITH DateStr DO BEGINπ GETDATE( Year, Month, Day, Trash );π GETTIME( Hour, Min, Sec, Trash );π END;π PackTime( DateStr, Time );π FileName := Right( ItoS( Time, 0 ), 8 ) + '.$$$';π UNTIL NOT Exist( Path + FileName );π TempFile := Path + FileName;πEND;π 31 09-26-9310:17ALL DAVID DANIEL ANDERSON Filesize & ZeroByte FilesIMPORT 21 .lPÆ (*πFrom: DAVIDDANIEL ANDERSON Refer#: 2239πSubj: FileSize in DOS Conf: (232) T_Pascal_RππThe FileSize "returns the number of components" in a file. Thus, itπmay not work as you might assume on untyped files, or files of records.ππThe file should be declared as a file of byte or char or as a textπfile, in order to use FileSize.ππAn alternative to FileSize is to use the SearchRec type in the DOSπunit. This program deletes a file if it is 0 bytes. The filespec isπprovided by the user on the command line, and can contain wildcards.π*)ππPROGRAM delete_0_byte_files;πUSES Dos;πVARπ MaybeZero : File of Byte; { the file in question }π DirInfo : SearchRec; { a record of the file }π FMask : PathStr; { entire path as specified by user }π MZName : PathStr; { path of file in question }π FDir : DirStr; { dir of file in question }π FName : NameStr; { name of file in question }π FExt : ExtStr; { ext of file in question }π NZero : Word; { number of files deleted }ππBEGINπ NZero := 0;π IF ParamCount = 1 THENπ FMask := ParamStr(1) { use command line info, if it exists }π ELSE BEGINπ Writeln('You must specify a file_mask, such as "*.*"!');π Halt;π END;π FSplit(FExpand(FMask),FDir,FName,FExt); { split cmdlind info into }π IF (FName = '') THEN { components }π FMask := FMask + '*.*'; { if only a DOS path was specified, }π FindFirst(FMask, Archive, DirInfo); { append a wildcard spec }ππ WHILE DosError = 0 DO { check every valid file for size }π BEGIN { append path to name, to allow }π MZName := FDir+DirInfo.Name; { paths and drives other than current }π Assign(MaybeZero,MZName); { use Assign since Erase can only work }π { on *files*, -not- file names }π IF (DirInfo.Size = 0) THEN BEGIN { THE MEAT! use the SearchRec }π Writeln('Deleting ',MZName); { for determining file size }π Erase(MaybeZero); { give a message and delete it }π NZero := NZero + 1; { incremented counter, of course }π END;ππ FindNext(DirInfo); { look for another matching file }π END;π Writeln('Files Deleted: ',NZero); { simply display total # deleted }πEND.π 32 11-02-9305:25ALL ANDREW VICTOR Change File Attr IMPORT 8 .l │ {πavictor@cs.sun.ac.za (Andrew Victor 93-42265)ππI want this Program to change the hidden attributes of a directory.ππ - Parameter FileName of Type String is the Name of theπ - subdirectory to hide or un-hide, it can include a path.π}πππProcedure ChangeAttributes(FileName : String);πVarπ AttrFile : File;π Attribute : Word;πbeginπ Assign(AttrFile, FileName);π GetFAttr(AttrFile, Attribute);π if not ((Attribute = $10) or (Attribute = $12)) thenπ beginπ WriteLn;π WriteLn('Not a Directory');π WriteLn;π Exit;π end;π if Attribute = $10 thenπ beginπ SetFAttr(AttrFile, Hidden);π WriteLn;π WriteLn('Directory ', FileName, ' hidden.');π WriteLn;π endπ elseπ beginπ SetFAttr(AttrFile, Directory and not Hidden);π WriteLn;π WriteLn('Directory ', FileName, ' shown.');π WriteLn;π end;πend;π 33 11-02-9305:42ALL GUY MCLOUGHLIN General File Handler IMPORT 42 .l}p {πGUY MCLOUGHLINππ ...Here's one way of creating generic routines to handle any typeπ of file...π}ππprogram Demo_Handle_Many_File_Types;ππusesπ crt;ππtype (* Path string type definition. *)π st_79 = string[79];ππ (* Enumerated type of the file types we want to handle. *)π FileType = (Fchar, FrecA, FrecB, Ftext, Funty);ππ (* First record type definition. *)π recA = recordπ Name : string;π Age : wordπ end;ππ (* Second record type definition. *)π recB = recordπ Unit : word;π City : stringπ end;ππ (* Case-varient multi-file type definition. *)π rc_FileType = recordπ case FT : FileType ofπ Fchar : (Fchar1 : file of char);π FrecA : (FrecA1 : file of recA);π FrecB : (FrecB1 : file of recB);π Ftext : (Ftext1 : text);π Funty : (Funty1 : file)π end;πππ (***** Display I/O error message. *)π (* *)πprocedure ErrorMessage({input }π by_Error : byte;π st_Path : st_79);πvarπ ch_Temp : char;πbeginπ (* If an I/O error occured, then... *)π if (by_Error <> 0) thenπ beginπ writeln;π case by_Error ofπ 2 : writeln('File not found ---> ', st_Path);π 3 : writeln('Path not found ---> ', st_Path);π 4 : writeln('Too many files open');π 5 : writeln('File access denied ---> ', st_Path);π 100 : writeln('Disk read error');π 103 : writeln('File not open ---> ', st_Path)π (* NOTE: The full error code listing code be *)π (* implemented if you like. *)π end;π (* Clear keyboard-buffer. *)π while keypressed doπ ch_Temp := readkey;ππ (* Pause for key-press. *)π writeln('Press any key to continue');π repeat until keypressedπ endπend; (* ErrorMessage. *)ππ(***** Generic open routine to handle many different file types. *)π(* *)πprocedure OpenFile({input } st_Path : st_79;π bo_Create : boolean;π var rc_File : rc_FileType);πbeginπ {$I-}π (* Handle appropriate file type. *)π case rc_File.FT ofπ Fchar : beginπ assign(rc_File.Fchar1, st_Path);π if bo_Create thenπ rewrite(rc_File.Fchar1)π elseπ reset(rc_File.Fchar1)π end;π FrecA : beginπ assign(rc_File.FrecA1, st_Path);π if bo_Create thenπ rewrite(rc_File.FrecA1)π elseπ reset(rc_File.FrecA1)π end;π FrecB : beginπ assign(rc_File.FrecB1, st_Path);π if bo_Create thenπ rewrite(rc_File.FrecB1)π elseπ reset(rc_File.FrecB1)π end;π Ftext : beginπ assign(rc_File.Ftext1, st_Path);π if bo_Create thenπ rewrite(rc_File.Ftext1)π elseπ reset(rc_File.Ftext1)π end;π Funty : beginπ assign(rc_File.Funty1, st_Path);π if bo_Create thenπ rewrite(rc_File.Funty1, 1)π elseπ reset(rc_File.Funty1, 1)π endπ end;π {$I+}π (* Check for I/O error, and display message if needed. *)π ErrorMessage(ioresult, st_Path)ππend; (* OpenFile. *)πππvar (* Array of 5 mulit-file type records. *)π FileArray : array[1..5] of rc_FileType;ππ (* Main program execution block. *)πBEGINπ (* Clear the screen. *)π clrscr;π (* Clear the multi-file type array. *)π fillchar(FileArray, sizeof(FileArray), 0);ππ (* Initialize each file-variable to it's own type. *)π FileArray[1].FT := Fchar;π FileArray[2].FT := FrecA;π FileArray[3].FT := FrecB;π FileArray[4].FT := Ftext;π FileArray[5].FT := Funty;ππ (* Create a new file of type CHAR. *)π OpenFile('D:\TMP18\CHAR.TST', true, FileArray[1]);ππ (* Create a new file of type RecA. *)π OpenFile('D:\TMP18\RECA.TST', true, FileArray[2]);ππ (* Open an existing file of type RecB. *)π OpenFile('D:\TMP18\RECB.TST', false, FileArray[3]);ππ (* Open an existing TEXT file. *)π OpenFile('D:\TMP18\TEXT.TST', false, FileArray[4]);ππ (* Open an existing un-typed file. *)π OpenFile('D:\TMP18\BIN.DAT', false, FileArray[5]);ππEND.π 34 11-02-9305:46ALL ERIC MILLER Reading GIF File Header IMPORT 8 .l░P {πERIC MILLERππ> How does one read/Write a header on a File in TPascal?ππ Easy. Write the header structure as a Type. Then openπ the File as unTyped and blockread the data into a Variableπ of the structure Type. Take GIFs For example:π}ππTypeπ Gif_Header = Record { first 13 Bytes of a Gif }π Sig, Ver : Array[1..3] of Char;π Screen_X,π Screen_Y : Word;π _Packed,π Background,π Pixel_Aspect : Byte;π end;πVarπ F : File; { unTyped File }π G : GIF_Header;πbeginπ Assign(F, 'Filename.gif');π Reset(F, 1); { blockread in Units of one Byte }π Blockread(F, G, SizeOf(G)); { read from File }π Close(F);π With G DOπ beginπ Writeln('Version: ', Sig, Ver);π Writeln('Res: ', Screen_X, 'x', Screen_Y, 'x', 2 SHL (_Packed and 7));π end;πend.π 35 11-02-9305:54ALL HERBERT ZARB Hiding/Unhiding Files IMPORT 7 .lë) {πHerbert Zarb <panther!jaguar!hzarb@relay.iunet.it>ππ This simple Program changes the attribute of the File or directory fromπ hidden to archive or vice-versa...π}ππProgram hide_unhide;π{ Accepts two command line parameters :π 1st parameter can be either +h (hide) or -h(unhide).π 2nd parameter must be the full path }πUsesπ Dos;ππConstπ bell = #07;π hidden = $02;π archive = $20;ππVarπ f : File;ππbeginπ if paramcount >= 2 thenπ beginπ Assign(f, paramstr(2));π if paramstr(1) = '+h' thenπ SetFAttr(f, hidden)π elseπ if paramstr(1) = '-h' thenπ SetFAttr(f, Archive)π elseπ Write(bell);π endπ elseπ Write(bell);πend.π 36 11-02-9305:54ALL TIMO SALMI Another File Hider IMPORT 10 .l╨ {πts@uwasa.fi (Timo Salmi)ππ Q: How can one hide (or unhide) a directory using a TP Program?ππ A: SetFAttr which first comes to mind cannot be used For this.πInstead interrupt Programming is required. Here is the code.πIncidentally, since MsDos 5.0 the attrib command can be used to hideπand unhide directories.π(* Hide a directory. Before using it would be prudent to checkπ that the directory exists, and that it is a directory.π With a contribution from Jan Nielsen jak@hdc.hha.dkπ Based on information from Duncan (1986), p. 410 *)π}πProcedure HIDE(dirname : String);πVarπ regs : Registers;πbeginπ FillChar(regs, SizeOf(regs), 0); { standard precaution }π dirname := dirname + #0; { requires ASCII Strings }π regs.ah := $43; { Function }π regs.al := $01; { subFunction }π regs.ds := Seg(dirname[1]); { point to the name }π regs.dx := Ofs(dirname[1]);π regs.cx := 2; { set bit 1 on } { to unhide set regs.cx := 0 }π Intr ($21, regs); { call the interrupt }π if regs.Flags and FCarry <> 0 then { were we successful }π Writeln('Failed to hide');πend;π 37 11-02-9305:58ALL IAN LIN Increasing a files size IMPORT 13 .l0/ {πIAN LINππAdd junk to file to increase size. v.2.2. }ππ{$I-,G+,R-,D-,L-}ππUsesπ dos;ππTypeπ buf = array [1..$ffff] of byte;ππVarπ c, k,π size : longint;π s, v : word;π f : file;π b : ^buf;ππBeginπ writeln('JUNK v2.2');π if paramcount = 0 thenπ beginπ writeln('Help screen. Syntax:');π writeln(paramstr(0),' <infile> <bytes>');π writeln('<infile>: source file -- <bytes>: bytes to add to source file');π writeln('Error level codes');π writeln('0: Normal execution or show help screen (no parameters)');π writeln('1: Not enough parameters. Must have specify a file and size.');π writeln('2: Invalid size specified for <bytes>');π halt(0);π End;ππ if paramcount = 1 thenπ beginπ writeln('Not enough parameters.');π halt(1);π End;ππ assign(f, paramstr(1));π val(paramstr(2), size, v);π if (v <> 0) or (size < 0) thenπ beginπ writeln('Invalid number in <bytes>. Run ', paramstr(0), ' alone for help.');π halt(2);π end;ππ reset(f, 1);π if ioresult = 0 thenπ seek(f, filesize(f))π elseπ rewrite(f, 1);π k := size div sizeof(buf);π s := size mod sizeof(buf);π randomize;π new(b);π for c := 1 to sizeof(buf) doπ b^[c] := random(128) + 128;ππ while k > 0 doπ beginπ blockwrite(f, b^, sizeof(buf));π dec(k);π end;ππ if s > 0 thenπ blockwrite(f, b^, s);π writeln('Wrote ', size, ' bytes to ', fexpand(paramstr(1)));π writeln('Total size of ', fexpand(paramstr(1)), ' is ', filesize(f));π close(f);π dispose(b);πend.ππ 38 11-02-9306:33ALL SWAG SUPPORT TEAM Reading User/IDX Files IMPORT 67 .lHτ {π Here's the demo Program I promised. You'll have to add the missingπ Type definitions before you will be able to run this Program.π}ππProgram Demo_Read_User_Files;ππTypeππ (* NOTE: Missing Type definitions need to go here, before this *)π (* Program will compile. *)π (* *)π (* ie: uflags, suflags, acrq, mhireadr, mzscanr, fzscanr, *)π (* colors. *)π (* *)ππ (* USERS.IDX : Sorted names listing *)π UserIdxRec = Recordπ Name : String[36]; (* Name (Real or handle) *)π Number : Integer; (* User number *)π RealName : Boolean; (* User's Real name? *)π Deleted : Boolean; (* Deleted or not *)π Left : Integer; (* Record or -1 *)π Right : Integer; (* Record or -1 *)π end;ππ (* USERS.DAT : User Records *)π UserRec = Recordπ Name : String[36]; (* System name *)π RealName : String[36]; (* Real name *)π PW : String[20]; (* PassWord *)π Ph : String[12]; (* Phone # *)π BDay : String[8]; (* Birthdate *)π FirstOn : String[8]; (* First on date *)π LastOn : String[8]; (* Last on date *)π Street : String[30]; (* Street address *)π CityState : String[30]; (* City, State *)π ZipCode : String[10]; (* Zipcode *)ππ (* Type of computer *)π UsrDefStr : Array[1..3] of String[35];ππ (* Occupation *)ππ (* BBS reference *)π Note : String[35]; (* SysOp note *)π UserStartMenu : String[8]; (* Menu to start at *)π LockedFile : String[8]; (* Print lockout msg*)π Flags : set of uflags; (* Flags *)π SFlags : set of suflags; (* Status flags *)π AR : set of acrq; (* AR flags *)ππ (* Voting data *)π Vote : Array[1..25] of Byte;ππ Sex : Char; (* Gender *)π TTimeOn, (* Total time on *)π UK, (* UL k *)π DK : LongInt; (* DL k *)π TLToday, (* # Min left today *)π ForUsr, (* Forward mail to *)π FilePoints : Integer; (* # Of File points *)ππ UpLoads, DownLoads, (* # Of ULs/# of DLs*)π LoggedOn, (* # Times on *)π MsgPost, (* # Message posts *)π EmailSent, (* # Email sent *)π Feedback, (* # Feedback sent *)π Timebank, (* # Mins in bank *)π TimebankAdd, (* # Added today *)π DlKToday, (* # KBytes dl today*)π DlToday : Word; (* # Files dl today *)ππ Waiting, (* Mail waiting *)π LineLen, (* Line length *)π PageLen, (* Page length *)π OnToday, (* # Times on today *)π Illegal, (* # Illegal logons *)π Barf,π LastMBase, (* # Last msg base *)π LastFBase, (* # Last File base *)π SL, DSL : Byte; (* SL / DSL *)ππ (* Message last read date ptrs *)π MHiRead : mhireadr;π (* Which message bases to scan *)π MzScan : mzscanr;π (* Which File bases to scan *)π FzScan : fzscanr;ππ (* User colors *)π Cols : colors;ππ Garbage : Byte;ππ (* Amount of time Withdrawn today *)π TimebankWith : Word;π (* Last day PassWord changed *)π PassWordChanged : Word;π (* Default QWK archive Type *)π DefArcType : Byte;π (* Last conference they were in *)π LastConf : Char;π (* Date/time of last qwk packet *)π LastQwk : LongInt;π (* Add own messages to qwk packet? *)π GetOwnQwk : Boolean;π (* Scan File bases For qwk packets? *)π ScanFilesQwk : Boolean;π (* Get private mail in qwk packets? *)π PrivateQwk : Boolean;π (* Amount of credit a User has *)π Credit : LongInt;π (* Amount of debit a User has *)π Debit : LongInt;π (* Expiration date of this User *)π Expiration : LongInt;π (* Subscription level to expire to *)π ExpireTo : Char;π (* User's color scheme # *)π ColorScheme : Byte;π (* Echo Teleconf lines? *)π TeleConfEcho : Boolean;π (* Interrupt during typing? *)π TeleConfInt : Boolean;π end;πππ(***** Check For IO error, and take some sort of action? *)π(* *)πProcedure CheckForIOerror;πVarπ in_Error : Integer;πbeginπ in_Error := ioresult;π if (in_Error <> 0) thenπ beginπ Writeln(' I/O Error = ', in_Error);ππ (* Take some sort of action to correct error, or halt Program *)ππ endπend; (* CheckForIOerror. *)πππVarπ rc_TempUI : UserIdxRec;π rc_TempUR : UserRec;ππ fi_UsersIdx : File of UserIdxRec;π fi_UsersDat : File of UserRec;ππbeginπ (* Open USERS.IDX File. *)π assign(fi_UsersIdx, 'USERS.IDX');π {$I-}π reset(fi_UsersIdx);π {$I+}π CheckForIOerror;ππ (* Read first Record from File. *)π read(fi_UsersIdx, rc_TempUI);π CheckForIOerror;ππ (* Display data from the first Record. *)π With rc_TempUI doπ beginπ Writeln('Name = ', Name);π Writeln('Number = ', Number);π Writeln('Real Name = ', RealName);π Writeln('Deleted = ', Deleted);π Writeln('Left = ', Left);π Writeln('Right = ', Right)π end;ππ (* Read 10th Record from File. *)π seek(fi_UsersIdx, pred(10));π read(fi_UsersIdx, rc_TempUI);π CheckForIOerror;ππ (* Display data from the 10th Record. *)π With rc_TempUI doπ beginπ Writeln('Name = ', Name);π Writeln('Number = ', Number);π Writeln('Real Name = ', RealName);π Writeln('Deleted = ', Deleted);π Writeln('Left = ', Left);π Writeln('Right = ', Right)π end;ππ (* Close USERS.IDX File. *)π close(fi_UsersIdx);π CheckForIOerror;ππ (* Open USERS.DAT File. *)π assign(fi_UsersDat, 'USERS.DAT');π {$I-}π reset(fi_UsersDat);π {$I+}π CheckForIOerror;ππ (* Read first Record from File. *)π read(fi_UsersDat, rc_TempUR);π CheckForIOerror;ππ (* Display data from the first Record. *)π With rc_TempUR doπ beginπ Writeln('Name = ', Name);π Writeln('Real Name = ', RealName);π Writeln('Street = ', Street);π Writeln('CityState = ', CityState);π Writeln('ZipCode = ', ZipCode);π Writeln('Sex = ', Sex)π end;ππ (* Read 10th Record from File. *)π seek(fi_UsersDat, pred(10));π read(fi_UsersDat, rc_TempUR);π CheckForIOerror;ππ (* Display data from the 10th Record. *)π With rc_TempUR doπ beginπ Writeln('Name = ', Name);π Writeln('Real Name = ', RealName);π Writeln('Street = ', Street);π Writeln('CityState = ', CityState);π Writeln('ZipCode = ', ZipCode);π Writeln('Sex = ', Sex)π end;ππ (* Close USERS.DAT File. *)π close(fi_UsersDat);π CheckForIOerror;ππend.ππ 39 11-21-9309:30ALL GUY MCLOUGHLIN Checking File Open IMPORT 21 .l∞ {πFrom: GUY MCLOUGHLINπSubj: Checking file openππI'm looking for a way of detecting if a file is currently open,πso my ExitProc can close it when open and not fail when tryingπto close a file that is not open.ππ (* Public-domain demo to check a file variable's *)π (* current file mode. Guy McLoughlin - Oct '93. *)π}ππprogram Test_FileMode_Demo;πusesπ dos;ππ (**** Display current filemode for a file variable. *)π (* *)π procedure DisplayFileMode({input } const fi_IN);π beginπ case textrec(fi_IN).mode ofπ FMclosed : writeln('* File closed');π FMinput : writeln('* File open in read-only mode');π FMoutput : writeln('* File open in write-only mode');π FMinout : writeln('* File open in read/write mode')π elseπ writeln('* File not assigned')π endπ end; (* DisplayFileMode. *)πππ (**** Check for IO file errors. *)π (* *)π procedure CheckForIOerror;π varπ in_Error : integer;π beginπ in_Error := ioresult;π if (ioresult <> 0) thenπ beginπ writeln('Error creating file');π halt(1)π endπ end; (* CheckForIOerror. *)πππvarπ fi_Temp1 : text;π fi_Temp2 : file;ππBEGINπ (* Demo filemodes for a TEXT file variable. *)π writeln('TEXT file variable test');π DisplayFileMode(fi_Temp1);π assign(fi_Temp1, 'TEST.DAT');π DisplayFileMode(fi_Temp1);π {$I-} rewrite(fi_Temp1); {$I+}π CheckForIOerror;π DisplayFileMode(fi_Temp1);π {$I-} close(fi_Temp1); {$I+}π CheckForIOerror;π DisplayFileMode(fi_Temp1);ππ (* Demo filemodes for an UNTYPED file variable. *)π writeln;π writeln('UNTYPED file variable test');π DisplayFileMode(fi_Temp2);π assign(fi_Temp2, 'TEST.DAT');π DisplayFileMode(fi_Temp2);π {$I-} rewrite(fi_Temp2); {$I+}π CheckForIOerror;π DisplayFileMode(fi_Temp2);π {$I-} close(fi_Temp2); {$I+}π CheckForIOerror;π DisplayFileMode(fi_Temp2)πEND.ππ *** NOTE: If you are not using version 7 of Turbo Pascal, changeπ the input parameter of the DisplayFileMode routine fromπ a CONSTANT parameter to a VAR parameter.ππ ie: TP7+ : DisplayFileMode({input } const fi_IN);ππ TP4+ : DisplayFileMode({input } var fi_IN);ππ - Guyπ 40 01-27-9411:57ALL TOM CARROLL Deleting Chars from FilesIMPORT 17 .l* {π> A friend of mine has a small problem with Binkley connecting, and wheneverπ> this happens, Binkley writes a bunch of Line noise characters in his log fπ> Some of these characters are EOF and EOL markers. I am trying to write a sπ> program that will read it, and write the contents to a new file, without aπ> the garbage in it. Of course, when I get to the first EOF, my program thinπ> it's done.π}ππProgram KillChar;ππ{ Written by Tom Carroll and released to the public domainπ on 12/11/93.ππ This program will read any file and delete any characters passed onπ the command line.ππ For example: KillChar InFile OutFile ASCII Value (of character)ππ i.e.: KILLCHAR MYFILE.TXT NEWFILE.TXT 12ππ This will remove all form feeds from a text file.ππ No error control is included.ππ}ππVARπ Buffer : ARRAY[0..255] OF Char;π TmpString,π StringVar : STRING;π FileLoc,π NumBytes : LongInt;π InFile,π OutFile : FILE;π NumRead : Integer;π StringPos : Integer;ππBEGINπ Val(ParamStr(3), NumRead, StringPos);π TmpString := Chr(NumRead); {#26;}π Assign(InFile, ParamStr(1));π Reset(InFile, 1);π Assign(OutFile, ParamStr(2));π Rewrite(OutFile, 1);π NumBytes := FileSize(InFIle);π WHILE FilePos(InFile) < NumBytes DOπ BEGINπ FileLoc := FilePos(InFile);π IF FileLoc < (NumBytes - 255) THENπ BlockRead(InFile, Buffer, 255, NumRead)π ELSEπ BlockRead(InFile, Buffer, FileSize(InFile) - FileLoc,π NumRead);π Move(Buffer[0], StringVar[1], NumRead);π StringVar[0] := Chr(NumRead);π StringPos := Pos(TmpString, StringVar);π WHILE StringPos > 0 DOπ BEGINπ StringPos := Pos(TmpString, StringVar);π Delete(StringVar, StringPos, 1);π END;π StringPos := Length(StringVar);π Move(StringVar[1], Buffer, Length(StringVar));π BlockWrite(OutFile, Buffer, Length(StringVar));π END;π Close(InFile);π Close(OutFIle);πEND.π 41 01-27-9412:00ALL KOLYA RICE Counting Lines IMPORT 12 .l⌠ {π>The subroutine opened a text file (in this case the Telix.USE file) inπ>binary mode, and then searched through the file for the CR/LF pair andπ>then incremented a counter. At the end I knew the number of lines inπ>the text file. I suppose in Pascal I could open the file do a whileπ>loop and count the lines -- but that would require me to read everyπ>single line where the basic subroutine did all the searching withoutπ>having to read the file line by line.ππ>I guess what I'm asking is how is a fast way to determine the number ofπ>lines in a text file using Pascal.ππFWIW, This routine takes a little over 6 seconds on a 330K TELIX.USE on aπ386/33π}ππprogram countlines;ππvarπ usefile : file;π buffer : array[0..8191] of byte;π counter, numw, numr : word;π size, numlines : longint;πππbeginπ numlines := 0;π counter := 0;π fillchar(buffer, sizeof(buffer), #0);π assign(usefile,'TELIX.USE');π reset(usefile,1);π size := filesize(usefile);π repeatπ blockread(usefile,buffer,sizeof(buffer),numr);π for counter := 0 to 8191 doπ if buffer[counter] = ord(13)π then beginπ inc(numlines);π write(round((filepos(usefile)/size)*100),'%',chr(13));π end;π until numr = 0;π close(usefile);π writeln('Your TELIX.USE has ',numlines,' lines.');πend.π 42 01-27-9412:00ALL BRIAN PAPE Close All Files IMPORT 28 .l4` {π>>DOS will automatically close all open files that belong to yourπ>>process upon termination. The only way I know of to do it manually,π>>if you don't know what the actual file variables will be, is to searchπ>>your PSPππ> I was doing fine until this point, what's a psp?πPSP stands for Program Segment Prefix. It contains a lot of informationπabout your program that is important to DOS. Some of the things itπcontains is the file handle table for open files, the command line tail,πinformation carried over from CP/M, an ISR table, a pointer to a copy ofπthe master environment, and more.ππ>for any open file handles, then explicitly call DOS, passingπ>>each file handle number. If nobody has a better suggestion, I couldπ>>probably think up some code to do that.ππ> at least psuedo code would be appreciated..πHere is some code that will close all of the files that your programπactually opened. It won't clear the run-time error; you'll have toπput that code into the exit-proc, or write your own.ππ{ FCLOSALL.PASπ file close unitπ 12-5-93π (c) 1993 Brian Papeππ This code may be distributed freely. However, I would appreciate itπ if modifications made to the code would be noted with the name of theπ modifier and the date.ππ This program will demonstrate how to close all open files inπ your program without knowing what the names of the associatedπ file variables are. All that you need to do in order to implementπ this code is put the statement USES FCLOSALL in your main program.ππ When your program ends, whether through a run-time error or throughπ normal termination, this procedure will attempt to close all open filesπ that were opened by your program. It will not close the standard i/oπ file handles that are maintained by DOS. In fact, the Turbo RTL willπ automatically close the INPUT and OUTPUT standard files in the standardπ exit procedure. The other DOS standard I/O files are StdErr, AUX,π and PRN.ππ This code does not clear the ExitCode variable, so if your program isπ terminating with a run-time error, the turbo ExitProc will stillπ print the "Runtime Error at xxxx:xxxx" message. If you want toπ prevent this message from occuring, then write another exitproc toπ clear the ExitCode variable in certain cases.ππ This code requires TP 6.0 or greater since it uses BASMπ}ππunit fclosall;πinterfaceπimplementationπvarπ saveexit:pointer;ππprocedure close_files_exit_proc; far;πvarπ numhandles : byte;π hp : ^byte;πbeginππ exitproc := saveexit;ππ { get number of file handles available }π numhandles := byte(ptr(prefixseg,$32)^);ππ { get the location of the fht, in case it is moved }π hp := pointer(ptr(prefixseg,$34)^);π inc(hp,5);ππ { skip the first 5 handles because they are standard DOS handles }π for numhandles := 5 to pred(numhandles) doπ beginπ asmπ mov ah,3ehπ xor bh,bhπ push dsπ lds si,hpπ mov bl,[si]π cmp bl,0ffh { don't close invalid handle; it will close INPUT }π je @invalidhandleπ int $21π @invalidhandle:π pop dsπ end;π inc(hp);π end;πend;ππbeginπ saveexit := exitproc;π exitproc := @close_files_exit_proc;πend. { FCLOSALL }πππ{ tests the FCLOSALL unit }πprogram test_fcloseall;πuses fclosall;πvarπ f : file;π i : byte;πbeginπ for i := 1 to 16 doπ beginπ assign(f,'a.a');π rewrite(f);π end; { for }πend.ππ 43 01-27-9412:22ALL HYPERDRIVE SOFTWARE File Sharing IMPORT 61 .löU {πAlso, please note, this unit has not been completely tested. It mayπ(and most probably does) have bugs in it. If (and when) any areπdiscovered, please contact me, so I can update my routines also.ππ**************************π* SHARE.PAS v1.0 *π* *π* General purpose file *π* sharing routines *π**************************ππ1992-93 HyperDrive SoftwareπReleased into the public domain.π}ππ{$S-,R-,D-}π{$IFOPT O+}π {$F+}π{$ENDIF}ππunit Share;ππinterfaceππconstπ MaxLockRetries : Byte = 10;ππ NormalMode = $02; { ---- 0010 }π ReadOnly = $00; { ---- 0000 }π WriteOnly = $01; { ---- 0001 }π ReadWrite = $02; { ---- 0010 }π DenyAll = $10; { 0001 ---- }π DenyWrite = $20; { 0010 ---- }π DenyRead = $30; { 0011 ---- }π DenyNone = $40; { 0100 ---- }π NoInherit = $70; { 1000 ---- }ππtypeπ Taskers = (NoTasker, DesqView, DoubleDOS, Windows, OS2, NetWare);ππvarπ MultiTasking : Boolean;π MultiTasker : Taskers;π VideoSeg : Word;π VideoOfs : Word;ππprocedure SetFileMode(Mode : Word);π{- Set filemode for typed/untyped files }πprocedure ResetFileMode;π{- Reset filemode to ReadWrite (02h) }πprocedure LockFile(var F);π{- Lock file F }πprocedure UnLockFile(var F);π{- Unlock file F }πprocedure LockBytes(var F; Start, Bytes : LongInt);π{- Lock Bytes bytes of file F, starting with Start }πprocedure UnLockBytes(var F; Start, Bytes : LongInt);π{- Unlock Bytes bytes of file F, starting with Start }πprocedure LockRecords(var F; Start, Records : LongInt);π{- Lock Records records of file F, starting with Start }πprocedure UnLockRecords(var F; Start, Records : LongInt);π{- Unlock Records records of file F, starting with Start }πfunction TimeOut : Boolean;π{- Check for LockRetry timeout }πprocedure TimeOutReset;π{- Reset internal LockRetry counter }πfunction InDos: Boolean;π{- Is DOS busy? }πprocedure GiveTimeSlice;π{- Give up remaining CPU time slice }πprocedure BeginCrit;π{- Enter critical region }πprocedure EndCrit;π{- End critical region }ππimplementationππusesπ Dos;ππvarπ InDosFlag : ^Word;π LockRetry : Byte;ππprocedure FLock(Handle : Word; Pos, Len : LongInt);πInline(π $B8/$00/$5C/ { mov AX,$5C00 ;DOS FLOCK, Lock subfunction}π $8B/$5E/$04/ { mov BX,[BP + 04] ;Place file handle in Bx register}π $C4/$56/$06/ { les DX,[BP + 06] ;Load position in ES:DX}π $8C/$C1/ { mov CX,ES ;Move ES pointer to CX register}π $C4/$7E/$08/ { les DI,[BP + 08] ;Load length in ES:DI}π $8C/$C6/ { mov SI,ES ;Move ES pointer to SI register}π $CD/$21); { int $21 ;Call DOS}ππprocedure FUnlock(Handle : Word; Pos, Len : LongInt);πInline(π $B8/$01/$5C/ { mov AX,$5C01 ;DOS FLOCK, Unlock subfunction}π $8B/$5E/$04/ { mov BX,[BP + 04] ;Place file handle in Bx register}π $C4/$56/$06/ { les DX,[BP + 06] ;Load position in ES:DX}π $8C/$C1/ { mov CX,ES ;Move ES pointer to CX register}π $C4/$7E/$08/ { les DI,[BP + 08] ;Load length in ES:DI}π $8C/$C6/ { mov SI,ES ;Move ES pointer to SI register}π $CD/$21); { int $21 ;Call DOS}ππprocedure SetFileMode(Mode : Word);πbeginπ FileMode := Mode;πend;ππprocedure ResetFileMode;πbeginπ FileMode := NormalMode;πend;ππprocedure LockFile(var F);πbeginπ If not MultiTasking thenπ Exit;ππ While InDos doπ GiveTimeSlice;ππ FLock(FileRec(F).Handle, 0, FileSize(File(F)));πend;ππprocedure UnLockFile(var F);πbeginπ If not MultiTasking thenπ Exit;ππ While InDos doπ GiveTimeSlice;ππ FLock(FileRec(F).Handle, 0, FileSize(File(F)));πend;ππprocedure LockBytes(var F; Start, Bytes : LongInt);πbeginπ If not MultiTasking thenπ Exit;ππ While InDos doπ GiveTimeSlice;ππ FLock(FileRec(F).Handle, Start, Bytes);πend;ππprocedure UnLockBytes(var F; Start, Bytes : LongInt);πbeginπ If not MultiTasking thenπ Exit;ππ While InDos doπ GiveTimeSlice;ππ FLock(FileRec(F).Handle, Start, Bytes);πend;ππprocedure LockRecords(var F; Start, Records : LongInt);πbeginπ If not MultiTasking thenπ Exit;ππ While InDos doπ GiveTimeSlice;ππ FLock(FileRec(F).Handle, Start * FileRec(F).RecSize, Records * FileRec(F).RecSize);πend;ππprocedure UnLockRecords(var F; Start, Records : LongInt);πbeginπ If not MultiTasking thenπ Exit;ππ While InDos doπ GiveTimeSlice;ππ FLock(FileRec(F).Handle, Start * FileRec(F).RecSize, Records * FileRec(F).RecSize);πend;ππfunction TimeOut : Boolean;πbeginπ GiveTimeSlice;π TimeOut := True;ππ If MultiTasking and (LockRetry < MaxLockRetries) thenπ beginπ TimeOut := False;π Inc(LockRetry);π end;πend;ππprocedure TimeOutReset;πbeginπ LockRetry := 0;πend;ππfunction InDos : Boolean;πbeginπ InDos := InDosFlag^ > 0;πend;ππprocedure GiveTimeSlice; ASSEMBLER;πasmπ cmp MultiTasker, DesqViewπ je @DVwaitπ cmp MultiTasker, DoubleDOSπ je @DoubleDOSwaitπ cmp MultiTasker, Windowsπ je @WinOS2waitπ cmp MultiTasker, OS2π je @WinOS2waitπ cmp MultiTasker, NetWareπ je @Netwarewaitπ @Doswait:π int $28π jmp @WaitDoneπ @DVwait:π mov AX,$1000π int $15π jmp @WaitDoneπ @DoubleDOSwait:π mov AX,$EE01π int $21π jmp @WaitDoneπ @WinOS2wait:π mov AX,$1680π int $2Fπ jmp @WaitDoneπ @Netwarewait:π mov BX,$000Aπ int $7Aπ jmp @WaitDoneπ @WaitDone:πend;ππprocedure BeginCrit; ASSEMBLER;πasmπ cmp MultiTasker, DesqViewπ je @DVCritπ cmp MultiTasker, DoubleDOSπ je @DoubleDOSCritπ cmp MultiTasker, Windowsπ je @WinCritπ jmp @EndCritπ @DVCrit:π mov AX,$101Bπ int $15π jmp @EndCritπ @DoubleDOSCrit:π mov AX,$EA00π int $21π jmp @EndCritπ @WinCrit:π mov AX,$1681π int $2Fπ jmp @EndCritπ @EndCrit:πend;ππprocedure EndCrit; ASSEMBLER;πasmπ cmp MultiTasker, DesqViewπ je @DVCritπ cmp MultiTasker, DoubleDOSπ je @DoubleDOSCritπ cmp MultiTasker, Windowsπ je @WinCritπ jmp @EndCritπ @DVCrit:π mov AX,$101Cπ int $15π jmp @EndCritπ @DoubleDOSCrit:π mov AX,$EB00π int $21π jmp @EndCritπ @WinCrit:π mov AX,$1682π int $2Fπ jmp @EndCritπ @EndCrit:πend;ππbeginπ {- Init }π LockRetry:= 0;ππ asmπ @CheckDV:π mov AX, $2B01π mov CX, $4445π mov DX, $5351π int $21π cmp AL, $FFπ je @CheckDoubleDOSπ mov MultiTasker, DesqViewπ jmp @CheckDoneπ @CheckDoubleDOS:π mov AX, $E400π int $21π cmp AL, $00π je @CheckWindowsπ mov MultiTasker, DoubleDOSπ jmp @CheckDoneπ @CheckWindows:π mov AX, $1600π int $2Fπ cmp AL, $00π je @CheckOS2π cmp AL, $80π je @CheckOS2π mov MultiTasker, Windowsπ jmp @CheckDoneπ @CheckOS2:π mov AX, $3001π int $21π cmp AL, $0Aπ je @InOS2π cmp AL, $14π jne @CheckNetwareπ @InOS2:π mov MultiTasker, OS2π jmp @CheckDoneπ @CheckNetware:π mov AX,$7A00π int $2Fπ cmp AL,$FFπ jne @NoTaskerπ mov MultiTasker, NetWareπ jmp @CheckDoneπ @NoTasker:π mov MultiTasker, NoTaskerπ @CheckDone:π {-Set MultiTasking }π cmp MultiTasker, NoTaskerπ mov VideoSeg, $B800π mov VideoOfs, $0000π je @NoMultiTaskerπ mov MultiTasking, $01π {-Get video address }π mov AH, $FEπ les DI, [$B8000000]π int $10π mov VideoSeg, ESπ mov VideoOfs, DIπ jmp @Doneπ @NoMultiTasker:π mov MultiTasking, $00π @Done:π {-Get InDos flag }π mov AH, $34π int $21π mov WORD PTR InDosFlag, BXπ mov WORD PTR InDosFlag + 2, ESπ end;πend.ππ 44 01-27-9413:32ALL GREG ESTABROOKS File Date/Time ManagementIMPORT 13 .l9╕ {*******************************************************************}πProgram File_Date_Time_Demo; { Aug 21/93, Greg Estabrooks. }πUSES CRT, { Clrscr,}π DOS; { GetFTime, UnPackTime, DateTime,}ππVARπ FileName :STRING[12]; { Holds the name of file to check}π F :FILE; { Holds file handle. }π FileT :LONGINT;π FTime :DateTime;ππBEGINπ Clrscr; { Clear the screen up. }π FileName := ParamStr(1); { Get name of file name. }π IF Length(FileName) = 0 THEN { If no name send error msg. }π Writeln('FileName must be specified!',^G)π ELSEπ BEGINπ Assign(F,FileName); { Assign handle to F. }π Reset(F); { Open File. }π GetFTime(F,FileT); { Get the Time and Date for file.}π Close(F); { Close The File. }π UnPackTime(FileT,FTime); { Unpack the time+date into fTime}π Write(' File : ',FileName); { Display Info for user. }π Write(' was last modified on ');π Write(FTime.Month,'-',FTime.Day,'-',FTime.Year,' at ');π Write(FTime.Hour,':',FTime.Min,':',FTime.Sec);π END;{IF}πEND.{File_Date_Time_Demo}π{*******************************************************************}π 45 01-27-9417:43ALL BRIAN GRAINGER More File Handles IMPORT 15 .l═W {πFrom: BRIAN GRAINGER Refer#: NONEπSubj: Multiple open files Conf: (58) Pascalπ---------------------------------------------------------------------------πRL▒I would like to open 20-50 silumtaneous files (in TP 6.0 or 7.0).ππTwo ways that I know of. The first involves sleuthing around in theπProgram Segment Prefix prepended to the memory image of a program's .EXEπfile. This involves undocumented DOS calls, but is known to work.ππThe second is to use Interrupt 21h, Function 67h, Set Handle Count.πThis is buggy in the original release of DOS 3.3, but is apparentlyπreliable in later versions.π}ππUSESπ Dos;ππCONSTπ LotsaHandles = 24861;ππFUNCTION SetHandleCount(Count : WORD) : WORD;π VARπ Regs : Registers;π BEGINπ SetHandleCount := 0;π WITH Regs DOπ BEGINπ AH := $67;π BX := Count;π Intr($21, Regs);π IF Flags AND fCarry <> 0 THEN (* Error? *)π SetHandleCount := AX; (* AX returns error code *)π END;π END;ππBEGINπ IF SetHandleCount(LotsaHandles) <> 0 THENπ WriteLn('Sorry. Better luck next time.')π ELSEπ WriteLn('What do think I am, a mainframe?');πEND.ππ{ ASSEMBLER TO DO THE SAME THINGππ(If you are not using protected mode you have to limit the use of DOS memoryπby using compiler direvtive $M in BP. DOS steals the first 5 handles for std.πdevices. This require at least DOS 3.3)π}πππprocedure SetHandleCount( wInAnt: WORD );πvarπ err : Boolean;πbeginπasmππ MOV AX, $6700;π MOV BX, wInAntπ INT $21π MOV err, 0π JNC @l1π MOV err, 1 { Error! }π@l1:πend;π if err then beginπ ClrScr;π writeln('Not enough memory');π halt(0);π end;πend;π 46 02-03-9410:55ALL SWAG SUPPORT TEAM Basic DOS File ManagementIMPORT 52 .lε Unit Fmanage;π{=========================================================}π{ A TP unit containing some basic file handling routines. }π{ }π{ Fmanage has been checked on TP 6.0, but may work on }π{ other versions as well. }π{=========================================================}πππInterfaceππVarπ FileNameSet: set of char;π { A character set containing all characters valid in DOS file names. }ππfunction IsDirName(DirName: string): boolean;π{================================================================}π{ Returns TRUE if DirName is a valid (not necessarily existing!) }π{ directory string. }π{================================================================}ππfunction IsFileName(FileName: string): boolean;π{=================================================================}π{ Returns TRUE if FileName is a valid (not necessarily existing!) }π{ file name string. }π{=================================================================}ππfunction FileExist(FileName: string): Boolean;π{==================================}π{ Returns TRUE if FileName exists. }π{==================================}ππfunction TextFileSize(FileName: String): LongInt;π{======================================================}π{ Returns the size in bytes of the text file FileName. }π{======================================================}ππprocedure Fdel(FileName: string; Var ErrCode: byte);π{===================================================================}π{ Deletes the file FileName. ErrCode returns the standard DOS error }π{ codes if unsuccessful. }π{===================================================================}ππprocedure Frename(SourceFile,TargetFile: string; Var ErrCode: byte);π{===============================================================}π{ Rename the file SourceName to TargetName. ErrCode returns the }π{ standard DOS error codes if unsuccessful. }π{===============================================================}ππprocedure Unique(Path: String; Var FileName: String);π{==============================================================}π{ Return a unique file name in the directory Path. FileName is }π{ empty if unsuccessful. }π{===============================================================}πππImplementationππUses Dos;ππFunction IsDirName(DirName: string): boolean;πVarπ i: byte;π ch: char;π ok: boolean;πbegin { IsDirName }π ok:=true; ch:=DirName[1];π if Pos(':',DirName)>0 then ok:=(ch in ['A'..'Z','a'..'z']);π if ok and (Pos(':',DirName)>2) then ok:=false;π if ok and (Pos(':',DirName)=2) thenπ beginπ Delete(DirName,1,2);π if Pos(':',DirName)>0 then ok:=false;π end;π if ok thenπ for i:=1 to length(DirName) doπ beginπ ch:=DirName[i];π if not (ch in FileNameSet) then ok:=false;π end;π IsDirName:=ok;πend; { IsDirName }ππFunction IsFileName(FileName: string): boolean;πVarπ i: byte;π ch: char;π ok: boolean;π Dir: DirStr;π Name: NameStr;π Ext: ExtStr;π tmp: string;πbegin { IsFileName }π ok:=true;π Fsplit(FileName,Dir,Name,Ext);π if Name='' thenπ beginπ IsFileName:=false;π Exit;π end;π ok:=IsDirName(Dir);π if ok thenπ for i:=1 to length(Name) doπ beginπ ch:=Name[i];π if not (ch in FileNameSet-[':']) then ok:=false;π end;π if ok thenπ beginπ if (length(Ext)>0) and (Ext[length(Ext)]='.') thenπ beginπ tmp:=Ext; Delete(tmp,length(tmp),1); Ext:=tmp;π end;π if Ext[1]='.' thenπ for i:=2 to length(Ext) doπ beginπ ch:=Ext[i];π if not (ch in FileNameSet-[':','.','\']) then ok:=false;π endπ else if length(Ext)>0 then ok:=false;π end;π isfilename:=ok;πend; { IsFileName }ππfunction FileExist(FileName: string): Boolean;πVarπ tmpfile: Text;π Attrib: Word;πbegin { FileExist }π if FileName='' thenπ beginπ FileExist:=false; Exit;π end;π assign(tmpfile,FileName);π GetFAttr(tmpfile,Attrib);π FileExist:=(DosError=0);πend; { FileExist }ππFunction TextFileSize(FileName: String): LongInt;πvarπ Attrib: Word;π Sr: SearchRec;πbeginπ if IsFileName(FileName) thenπ beginπ FindFirst(FileName,AnyFile and (not (sysfile or Directory)),Sr);π if DosError=0 then TextFileSize:=Sr.sizeπ else TextFileSize:=-1;π end else TextFileSize:=-1;πend;ππprocedure Fdel(FileName: string; Var ErrCode: byte);πvarπ reg: registers;πbegin { Fdel }π FileName:=concat(FileName,#0);π reg.ds:=Seg(FileName[1]); reg.dx:=Ofs(FileName[1]);π reg.ah:=$41;π MsDos(reg);π ErrCode:=0;π if (reg.flags AND FCarry)=1 then ErrCode:=reg.ax;πend; { Fdel }ππprocedure Frename(SourceFile,TargetFile: string; Var ErrCode: byte);πvarπ reg: registers;πbegin { Frename }π SourceFile:=concat(SourceFile,#0);π TargetFile:=concat(TargetFile,#0);π reg.ds:=Seg(SourceFile[1]); reg.dx:=Ofs(SourceFile[1]);π reg.es:=Seg(TargetFile[1]); reg.di:=Ofs(TargetFile[1]);π reg.ah:=$56;π MsDos(reg);π ErrCode:=0;π if (reg.flags AND FCarry)=1 then ErrCode:=reg.ax;πend; { Frename }ππProcedure Unique(Path: String; Var FileName: String);πVarπ reg: Registers;π i: integer;π ErrCode: Byte;πbegin { Unique }π FileName:='';π if Path='' then Exit;π for i:=1 to 15 do Path:=concat(Path,#0);π reg.ds:=Seg(Path[1]); reg.dx:=Ofs(Path[1]);π reg.cx:=0;π reg.ah:=$5A;π MsDos(reg);π ErrCode:=0;π if (reg.flags AND FCarry)=1 then ErrCode:=reg.ax;π if ErrCode=0 thenπ beginπ FileName:=Path;π i:=1;π while (i<length(FileName)) and (FileName[i]<>#0) do Inc(i);π if FileName[i]=#0 then Delete(FileName,i,length(FileName)-i+1);π {π Now delete the zero length file created by DOSπ }π reg.ds:=Seg(Path[1]); reg.dx:=Ofs(Path[1]);π reg.ah:=$3E;π reg.bx:=reg.ax;π MsDos(reg);π end;πend; { Unique }ππbeginπ FileNameSet:=['!','#'..')',#45,#46,'0'..':','@'..'Z','\','`'..#123,π #125,'~','_'];πend.π 47 02-03-9410:57ALL GREG ESTABROOKS Filedate and Time IMPORT 21 .lg' {πET>How can I change the file's date and time without opening that file??πET>I appreciate (some) example source code, so I can look how it is done.πET>Thanks.ππ In order to change a files date/timestamp you'll have open the fileπ whether you use the TP SetFTime routine or use Int 21h Function 5701π BUT by Opening it for reading you can change it to whatever you want.π If you open it for writing then the TimeStamp will automatically beπ changed to whatever the time was when you closed it.ππ Here's a little demo that changes the files timestamp to whatever theπ current time is:π (NOTE this does not test for existance of the file before settingthe time.)}ππ{*******************************************************************}πPROGRAM SetFileDateAndTimeDemo; { Jan 8/93, Greg Estabrooks. }πUSES CRT, { IMPORT Clrscr,Writeln. }π DOS; { IMPORT SetFTime,PackTime,DateTime,}π { GetTime,GetDate. }πVARπ Hour,Min,Sec,Sec100 :WORD; { Variables to hold current time. }π Year,Mon,Day,DayoW :WORD; { Variables to hold current date. }π F2Change :FILE; { Handle for file to change. }π NewTime :LONGINT; { Longint Holding new Date/Time. }π FTime :DateTime; { For use with packtime. }πBEGINπ Clrscr; { Clear the screen. }π GetTime(Hour,Min,Sec,Sec100); { Get Current System Time. }π GetDate(Year,Mon,Day,DayoW); { Get Current System Date. }π FTime.Year := Year; { Assign new year. }π FTime.Month:= Mon; { Assign new month. }π FTime.Day := Day; { Assign New Day. }π FTime.Hour:= Hour; { Assign New hour. }π FTime.Min := Min; { Assign New Minute. }π FTime.Sec := Sec; { Assign New Seconds. }π PackTime(FTime,NewTime); { Now covert Time/Date to a longint.}π Assign(F2Change,ParamStr(1)); { Assign file handle to file to change.}π Reset(F2Change); { Open file for reading. }π SetFTime(F2Change,NewTime); { Now change to our time. }π Close(F2Change); { Close File. }πEND.{SetFileDateAndTimeDemo}π{*******************************************************************}π 48 02-03-9416:18ALL GAYLE DAVIS Change File Extensions IMPORT 23 .l6= {$S-,V-,R-,F+}ππPROGRAM REX;ππ { Rename all files matching one extension with anotherπ CAUTION !!! This program will rename FILES !!!!!!!!π Takes to parameters : Ext1(current) and Ext2(whatever)π i.e. *.XXX to *.PAS or *.MOD to *.INTπ Uses some of the routines from EDDY THILLEMAN'S recursive directory roamπ whice can be found in the SWAG distributionπ Gayle Davis 1/26/94 }ππUSES DOS, CRT;ππTYPEπ ProcessType = PROCEDURE (Path : PathStr; FR : SearchRec);ππCONSTπ NotGoodFile : WORD = Directory + Hidden + Readonly + VolumeID + Sysfile;ππVARπ Ext1 : Pathstr;π Ext2 : Pathstr;π ExitSave : POINTER;ππPROCEDURE Frename (SourceFile, TargetFile : STRING; VAR ErrCode : BYTE);πVARπ reg : REGISTERS;πBEGIN { Frename }π SourceFile := CONCAT (SourceFile, #0);π TargetFile := CONCAT (TargetFile, #0);π reg.ds := SEG (SourceFile [1]); reg.dx := OFS (SourceFile [1]);π reg.es := SEG (TargetFile [1]); reg.di := OFS (TargetFile [1]);π reg.ah := $56;π MSDOS (reg);π ErrCode := 0;π IF (reg.flags AND FCarry) = 1 THEN ErrCode := reg.ax;πEND; { Frename }ππPROCEDURE DoitHere (Path : PathStr; FR : SearchRec); FAR;πVARπ Name1,π Name2 : PathStr;π D : PathStr;π N : NameStr;π E : ExtStr;π Err : BYTE;ππBEGINπIF (FR.Attr AND NotGoodFile) <> 0 THEN EXIT;πFSplit(FR.Name, D, N, E);πName1 := Path + FR.Name;πName2 := Path + N + Ext2;πWRITELN (Name1, ' ', Name2);πFRename(Name1,Name2,Err);πEND;ππFUNCTION Wildcard (Name : PathStr) : BOOLEAN ;ππBEGINπWildcard := (POS ('*', Name) <> 0) OR (POS ('?', Name) <> 0) AND (POS('.',Name) > 0);πEND ;πππProcedure PathAnalyze (P: PathStr; Var D: DirStr; Var Name: NameStr);πVarπ N: NameStr;π E: ExtStr;ππbeginπ FSplit(P, D, N, E);π Name := N + E;πend;ππPROCEDURE FindFiles (fMask : PathStr; fAttr : WORD; Process : ProcessType);πVARπ FR : SearchRec;π Path : PathStr;π Mask : NameStr;ππBEGINπ PathAnalyze(fMask,Path,Mask);π FINDFIRST (FMask, FAttr, FR);π WHILE DosError = 0 DOπ BEGINπ Process (Path,FR);π FINDNEXT (FR);π END;πEND;ππPROCEDURE ExitHandler; FAR;π { Return the cursor to its original shape }π BEGINπ ExitProc := ExitSaveπ END;πππBEGINπExitSave := ExitProc;πExitProc := @ExitHandler;πClrScr;πIF PARAMCOUNT < 2 THENπ BEGINπ WriteLn('REX : Rename all files matching Ext1 to Ext2');π WRITELN('Needs 2 Parameters .. *.ext1 *.ext2');π HALT;π END;πExt1 := ParamStr(1);πExt2 := ParamStr(2);πIF NOT WildCard(Ext1) THEN HALT; { must contain a wildcard }πIF NOT WildCard(Ext2) THEN HALT;πExt2 := COPY(Ext2,POS('.',Ext2),$FF); { only want the extension }πFindFiles (Ext1, Anyfile, DoitHere);πEND. 49 02-09-9407:25ALL GREG ESTABROOKS Low Level File Routines IMPORT 233 .lt UNIT FILEIO; { Low Level File handling routines. Jan 18/94 }π { Copyright (C) 1993,1994 Greg Estabrooks }π { NOTE: Requires TP 6.0+ to compile. }πINTERFACEπ{***********************************************************************}πUSES DOS; { IMPORT FSearch. }πCONST { Handles PreDefined by DOS. }π fStdIn = $00; { STD Input Device, (Keyboard). }π fStdOut = $01; { STD Output Device,(CRT). }π fStdErr = $02; { STD Error Device, (CRT). }π fStdCom = $03; { STD Comm. }π fStdPrn = $04; { STD Printer. }π oRead = $00; { Opens a file for read only. }π oWrite = $01; { Opens a file for writing only. }π oReadWrite = $02; { Opens a file for reading and writing. }π oDenyAll = $10; { Deny access to other processes. }π oDenyWrite = $20; { Deny write access to other processes. }π oDenyRead = $30; { Deny read access to other processes. }π oDenyNone = $40; { Allow free access to other processes. }π { Possible file attribs,can be combined.}π aNormal = $00; aSystem = $04; aArchive = $20;π aReadOnly = $01; aVolume = $08;π aHidden = $02; aDir = $10;πTYPEπ LockType = (Lock,UnLock); { Ordinal Type for use with 'fLock'. }πVARπ fError :WORD; { Holds any error codes from routines. }ππPROCEDURE ASCIIZ( VAR fName :STRING );π { Routine to add a NULL to a string to make it }π { ASCIIZ compatible. }π { File routines automatically call this routine}π { usage : }π { ASCIIZ(fName); }ππFUNCTION fCreate( fName :STRING; Attr :BYTE ) :WORD;π { Routine to Create 'fName' with an attribute }π { of 'Attr'. If the file already exists then it}π { will be truncated to a zero length file. }π { Returns a WORD value containing the handle. }π { Uses Int 21h/AH=3Ch. }π { usage : }π { handle := fCreate('Temp.Dat',aNormal); }ππFUNCTION fOpen( fName :STRING; Mode :BYTE ) :WORD;π { Routine to open already existing file defined}π { in 'fName' with an opening mode of 'Mode'. }π { Returns a WORD value containing the handle. }π { Uses Int 21h/AH=3Dh. }π { usage : }π { handle := fOpen('Temp.Dat',oRead); }ππPROCEDURE fRead( fHandle :WORD; VAR Buff; NTRead:WORD; VAR ARead :WORD );π { Reads 'NTRead' bytes of data from 'fHandle' }π { and puts it in 'Buff'. The actually amount }π { of bytes read is returned in 'ARead'. }π { Uses Int 21h/AH=3Fh. }π { usage : }π { fRead(handle,Buffer,SizeOf(Buffer),ARead); }ππPROCEDURE fWrite( fHandle :WORD; VAR Buff; NTWrite:WORD; VAR AWrite :WORD );π { Writes 'NTWrite' bytes of info from 'Buff' }π { to 'fHandle'. The actually amount written is }π { returned in 'AWrite'. }π { Uses Int 21h/AH=40h. }π { usage : }π { fWrite(handle,Buffer,SizeOf(Buffer),AWrite);}ππPROCEDURE fClose( fHandle :WORD );π { Routine to close file 'fHandle'. This updates}π { the directory time and size enteries. }π { Uses Int 21h/AH=3Eh. }π { usage : }π { fClose(handle); }ππPROCEDURE fReset( fHandle :WORD );π { Routine to reset file position pointer to the}π { beginning of 'fHandle'. }π { Uses Int 21h/AH=42h. }π { usage : }π { fReset(handle); }ππPROCEDURE fAppend( fHandle :WORD );π { Routine to move the File position pointer of }π { 'fHandle' to the end of the file. Any further}π { writing is added to the end of the file. }π { Uses Int 21h/AH=42h. }π { usage : }π { fAppend(handle); }ππPROCEDURE fSeek( fHandle :WORD; fOfs :LONGINT );π { Routine to move the file position pointer for}π { 'fHandle' to 'fOfs'. 'fOfs' is the actual }π { byte position in the file to move to. }π { Uses Int 21h/AH=42h. }π { usage : }π { fSeek(handle,1023); }ππPROCEDURE fErase( fName :STRING );π { Routine to erase 'fName'. }π { Uses Int 21h/AH=41h. }π { usage : }π { fErase('Temp.Dat'); }ππFUNCTION fPos( fHandle :WORD ) :LONGINT;π { Routine to return the current position within}π { 'fHandle'. }π { Uses Int 21h/AH=42. }π { usage : }π { CurPos := fPos(handle); }ππFUNCTION fEof( fHandle :WORD ) :BOOLEAN;π { Routine to determine whether or not we're }π { currently at the end of file 'fHandle'. }π { usage : }π { IsEnd := fEof(handle); }ππFUNCTION fExist( fName :STRING ) :BOOLEAN;π { Routine to determine whether or not 'fName' }π { exists. }π { usage : }π { Exist := fExist('Temp.Dat'); }ππFUNCTION fGetAttr( fName :STRING ) :BYTE;π { Routine to return the current file attribute }π { of 'fName'. }π { Uses Int 21h/AH=43h,AL=00h. }π { usage : }π { CurAttr := fGetAttr('Temp.Dat'); }ππPROCEDURE fSetAttr( fName :STRING; NAttr :BYTE );π { Routine to set file attribute of 'fName' to }π { 'NAttr'. }π { Uses Int 21h/AH=43h,AL=01h. }π { usage : }π { fSetAttr('Temp.Dat',aArchive OR aReadOnly); }ππPROCEDURE fSetVerify( On_Off :BOOLEAN );π { Routine to set the DOS verify flag ON or OFF.}π { depending on 'On_Off'. }π { TRUE = ON, FALSE = OFF. }π { Uses Int 21h/AH=2Eh. }π { usage : }π { fSetVerify( TRUE ); }ππFUNCTION fGetVerify :BOOLEAN;π { Routine to return the current state of the }π { DOS verify flag. }π { Uses Int 21h/AH=54h. }π { usage : }π { IsVerify := fGetVerify; }ππFUNCTION fSize( fHandle :WORD ) :LONGINT;π { Routine to determine the size in bytes of }π { 'fHandle'. }π { usage : }π { CurSize := fSize(handle); }ππPROCEDURE fFlush( fHandle :WORD );π { Flushes any File buffers for 'fHandle' }π { immediately and updates the directory entry. }π { Uses Int 21h/AH=68h. }π { usage : }π { fFlush(handle); }ππPROCEDURE fLock( fHandle :WORD; LockInf :LockType; StartOfs,Len :LONGINT );π { Routine to lock/unlock parts of a open file. }π { Locking or unlock is determined by 'LockInf'. }π { Uses Int 21h/AH=5Ch. }π { usage : }π { fLock(handle,Lock,1000,500); }π{***********************************************************************}πIMPLEMENTATIONπππPROCEDURE ASCIIZ( VAR fName :STRING ); ASSEMBLER;π { Routine to add a NULL to a string to make it }π { ASCIIZ compatible. }π { File routines automatically call this routine}πASMπ Push DS { Push DS onto the stack. }π LDS DI,fname { Point DS:DI ---> fName. }π Xor BX,BX { Clear BX. }π Mov BL,BYTE PTR DS:[DI] { Load length of string into BL. }π Inc BL { Point to char after last one in name. }π Mov BYTE PTR DS:[DI+BX],0 { Now make it a ASCIIZ string. }π Pop DS { Pop DS off the stack. }πEND;{ASCIIZ}ππFUNCTION fCreate( fName :STRING; Attr :BYTE ) :WORD;π { Routine to Create 'fName' with an attribute }π { of 'Attr'. If the file already exists then it}π { will be truncated to a zero length file. }π { Returns a WORD value containing the handle. }π { Uses Int 21h/AH=3Ch. }πBEGINπ ASCIIZ(fName); { Convert fName to an ASCIIZ string. }π ASMπ Push DS { Push DS Onto stack. }π Mov fError,0 { Clear Error Flag. }π Mov AX,SS { Load AX with SS. }π Mov DS,AX { Now load that value into DS. }π Lea DX,fName { Now load DX with the offset of DX. }π Inc DX { Move past length byte. }π Xor CH,CH { Clear High byte of CX. }π Mov CL,Attr { Load attribute to give new file. }π Mov AH,$3C { Function to create a file. }π Int $21 { Call dos to create file. }π Jnc @Exit { If no error exit. }π Mov fError,AX { If there was an error save it. }π @Exit:π Mov @Result,AX { Return proper result to user. }π Pop DS { Pop DS Off the Stack. }π END;πEND;{fCreate}ππFUNCTION fOpen( fName :STRING; Mode :BYTE ) :WORD;π { Routine to open already existing file defined}π { in 'fName' with an opening mode of 'Mode'. }π { Returns a WORD value containing the handle. }π { Uses Int 21h/AH=3Dh. }πBEGINπ ASCIIZ(fName); { Convert fName to an ASCIIZ string. }π ASMπ Push DS { Push DS onto stack. }π Mov fError,0 { Clear Error Flag. }π Mov AX,SS { Load AX with SS. }π Mov DS,AX { Now load that value into DS. }π Lea DX,fName { Now load DX with the offset of DX. }π Inc DX { Move past length byte. }π Mov AL,Mode { File Opening mode. }π Mov AH,$3D { Function to open a file. }π Int $21 { Call dos to open file. }π Jnc @Exit { If no error exit. }π Mov fError,AX { If there was an error save it. }π @Exit:π Mov @Result,AX { Return proper result to user. }π Pop DS { Restore DS from stack. }π END;πEND;{fOpen}ππPROCEDURE fRead( fHandle :WORD; VAR Buff; NTRead:WORD; VAR ARead :WORD );πASSEMBLER; { Reads 'NTRead' bytes of data from 'fHandle' }π { and puts it in 'Buff'. The actually amount }π { of bytes read is returned in 'ARead'. }π { Uses Int 21h/AH=3Fh. }πASMπ Push DS { Push DS onto the stack. }π Mov fError,0 { Clear Error flag. }π Mov AH,$3F { Function to read from a file. }π Mov BX,fHandle { load handle of file to read. }π Mov CX,NTRead { # of bytes to read. }π LDS DX,Buff { Point DS:DX to buffer. }π Int $21 { Call Dos to read file. }π LDS DI,ARead { Point to amount read. }π Mov WORD PTR DS:[DI],AX { Save amount actually read. }π Jnc @Exit { if there was no error exit. }π Mov fError,AX { If there was Save error code. }π@Exit:π Pop DS { Pop DS off the stack. }πEND;{fRead}ππPROCEDURE fWrite( fHandle :WORD; VAR Buff; NTWrite:WORD; VAR AWrite :WORD );πASSEMBLER; { Writes 'NTWrite' bytes of info from 'Buff' }π { to 'fHandle'. The actually amount written is }π { returned in 'AWrite'. }π { Uses Int 21h/AH=40h. }πASMπ Push DS { Push DS onto the stack. }π Mov fError,0 { Clear Error flag. }π Mov AH,$40 { Function to write to file. }π Mov BX,fHandle { Handle of file to write to. }π Mov CX,NTWrite { # of bytes to read. }π LDS DX,Buff { Point DS:DX -> Buffer. }π Int $21 { Call Dos to write to file. }π LDS DI,AWrite { Point to amount write. }π Mov WORD PTR DS:[DI],AX { Save amount actually written. }π Jnc @Exit { If there was no error exit. }π Mov fError,AX { if there was save error code. }π@Exit:π Pop DS { Pop DS off the stack. }πEND;{fWrite}ππPROCEDURE fClose( fHandle :WORD ); ASSEMBLER;π { Routine to close file 'fHandle'. This updates}π { the directory time and size enteries. }π { Uses Int 21h/AH=3Eh. }πASMπ Mov fError,0 { Clear Error flag }π Mov AH,$3E { Function to close file }π Mov BX,fHandle { load handle of file to close }π Int $21 { call Dos to close file }π Jnc @Exit { If there was no error exit }π Mov fError,AX { if there was save error code }π@Exit:πEND;{fClose}ππPROCEDURE fReset( fHandle :WORD ); ASSEMBLER;π { Routine to reset file position pointer to the}π { beginning of 'fHandle'. }π { Uses Int 21h/AH=42h. }πASMπ Mov fError,0 { Clear error flag. }π Mov AH,$42 { Function to move file pointer. }π Mov BX,fHandle { Handle of file. }π Mov AL,0 { Offset relative to begining. }π Mov CX,0 { CX:DX = offset from begining of file }π Mov DX,0 { to move to. }π Int $21 { Call dos to change file pointer. }π Jnc @Exit { If there was no error exit. }π Mov fError,AX { If there was save error code. }π@Exit:πEND;{fReset}ππPROCEDURE fAppend( fHandle :WORD); ASSEMBLER;π { Routine to move the File position pointer of }π { 'fHandle' to the end of the file. Any further}π { writing is added to the end of the file. }π { Uses Int 21h/AH=42h. }πASMπ Mov fError,0 { Clear error flag. }π Mov AH,$42 { Function to change file ptr position. }π Mov BX,fHandle { handle of file to change. }π Mov AL,$02 { Change relative to end of file. }π Mov CX,0 { CX:DX = offset from end of file }π Mov DX,0 { to move to. }π Int $21 { Call dos to move file ptr. }π Jnc @Exit { If there was no error exit. }π Mov fError,AX { If there was save error code. }π@Exit:πEND;{fAppend}ππPROCEDURE fSeek( fHandle :WORD; fOfs :LONGINT ); ASSEMBLER;π { Routine to move the file position pointer for}π { 'fHandle' to 'fOfs'. 'fOfs' is the actual }π { byte position in the file to move to. }π { Uses Int 21h/AH=42h. }πASMπ Mov fError,0 { Clear error flag. }π Mov AH,$42 { Function to change file ptr position. }π Mov BX,fHandle { handle of file to change. }π Mov AL,$00 { Change relative to start of file. }π Mov CX,fOfs[2].WORD { CX:DX = offset from start of file }π Mov DX,fOfs.WORD { to move to. }π Int $21 { Call dos to move file ptr. }π Jnc @Exit { If there was no error exit. }π Mov fError,AX { If there was save error code. }π@Exit:πEND;{fSeek}ππPROCEDURE fErase( fName :STRING );π { Routine to erase 'fName'. }π { Uses Int 21h/AH=41h. }πBEGINπ ASCIIZ(fName); { Convert fName to an ASCIIZ string. }π ASMπ Push DS { Push DS onto the stack. }π Mov fError,0 { Clear error flag. }π Mov AX,SS { Load AX with SS. }π Mov DS,AX { Now load that value into DS. }π Lea DX,fName { Now load DX with the offset of DX. }π Inc DXπ Mov AH,$41 { Function to erase a file. }π Int $21 { Call dos to erase file. }π Jnc @Exit { If no error exit. }π Mov fError,AX { if there was error save error code. }π @Exit:π Pop DS { Pop DS off the stack. }π END;πEND;{fErase}ππFUNCTION fPos( fHandle :WORD ) :LONGINT; ASSEMBLER;π { Routine to return the current position within}π { 'fHandle'. }π { Uses Int 21h/AH=42. }πASMπ Mov fError,0 { Clear error flag. }π Mov AH,$42 { Function to move file pointer. }π Mov BX,fHandle { Handle of file. }π Mov AL,1 { Offset relative to current pos. }π Mov CX,0 { CX:DX = offset from current position }π Mov DX,0 { to move to. }π Int $21 { Call dos to change file pointer. }π Jnc @Exit { If there was no error return result. }π Mov fError,AX { If there was save error code. }π@Exit: { Int already returns DX:AX as file pos.}πEND;{fPos}ππFUNCTION fEof( fHandle :WORD ) :BOOLEAN;π { Routine to determine whether or not we're }π { currently at the end of file 'fHandle'. }πVARπ CurOfs :LONGINT; { current file offset. }πBEGINπ CurOfs := fPos(fHandle); { Save Current Pos. }π fAppend(fHandle); { Move to the end of the file. }π fEof := (CurOfs = fPos(fHandle)); { was current pos = end pos?. }π fSeek(fHandle,CurOfs); { Restore to original file position. }πEND;{fEof}ππFUNCTION fExist( fName :STRING ) :BOOLEAN;π { Routine to determine whether or not 'fName' }π { exists. }πBEGINπ fExist := ( FSearch(fName,'') <> '');πEND;{fExist}ππFUNCTION fGetAttr( fName :STRING ) :BYTE;π { Routine to return the current file attribute }π { of 'fName'. }π { Uses Int 21h/AH=43h,AL=00h. }πBEGINπ ASCIIZ(fName); { Convert fName to an ASCIIZ string. }π ASMπ Push DS { Push DS onto the stack. }π Mov fError,0 { Clear error flag. }π Mov AX,SS { Load AX with SS. }π Mov DS,AX { Now load that value into DS. }π Lea DX,fName { Now load DX with the offset of DX. }π Inc DXπ Mov AX,$4300 { Function to Get file Attrib. }π Int $21 { Call dos to get attr. }π Jnc @Success { If no error return proper info. }π Mov fError,AX { if there was error save error code. }π @Success:π Mov AX,CXπ Mov @Result,AL { Return proper result to user. }π Pop DS { Pop DS off the stack. }π END;πEND;{fGetAttr}ππPROCEDURE fSetAttr( fName :STRING; NAttr :BYTE );π { Routine to set file attribute of 'fName' to }π { 'NAttr'. }π { Uses Int 21h/AH=43h,AL=01h. }πBEGINπ ASCIIZ(fName); { Convert fName to an ASCIIZ string. }π ASMπ Push DS { Push DS onto the stack. }π Mov fError,0 { Clear error flag. }π Mov AX,SS { Load AX with SS. }π Mov DS,AX { Now load that value into DS. }π Lea DX,fName { Now load DX with the offset of DX. }π Inc DX { Point to first char after length byte.}π Xor CX,CX { Clear CX. }π Mov CL,NAttr { Load New attribute byte. }π Mov AX,$4301 { Function to Set file Attrib. }π Int $21 { Call dos to set attrib. }π Jnc @Exit { If no error exit. }π Mov fError,AX { if there was error save error code. }π @Exit:π Pop DS { Pop DS off the stack. }π END;πEND;{fSetAttr}ππPROCEDURE fSetVerify( On_Off :BOOLEAN ); ASSEMBLER;π { Routine to set the DOS verify flag ON or OFF.}π { depending on 'On_Off'. }π { TRUE = ON, FALSE = OFF. }π { Uses Int 21h/AH=2Eh. }πASMπ Mov AH,$2E { Interrupt Subfunction. }π Mov DL,0 { Clear DL. }π Mov AL,On_Off { 0(FALSE) = off, 1(TRUE) = on. }π Int $21 { Call Dos. }πEND;{fSetVerify}ππFUNCTION fGetVerify :BOOLEAN; ASSEMBLER;π { Routine to return the current state of the }π { DOS verify flag. }π { Uses Int 21h/AH=54h. }πASMπ Mov AH,$54 { Interrupt Subfunction }π Int $21 { Call Dos }πEND;{fGetVerify}ππFUNCTION fSize( fHandle :WORD ) :LONGINT;π { Routine to determine the size in bytes of }π { 'fHandle'. }πVARπ CurOfs :LONGINT; { Holds original file pointer. }πBEGINπ CurOfs := fPos(fHandle); { Save current file pointer. }π fAppend(fHandle); { Move to end of file. }π fSize := fPos(fHandle); { Save current pos which equals size. }π fSeek(fHandle,CurOfs); { Restore original file pos. }πEND;{fSize}ππPROCEDURE fFlush( fHandle :WORD ); ASSEMBLER;π { Flushes any File buffers for 'fHandle' }π { immediately and updates the directory entry. }π { Uses Int 21h/AH=68h. }πASMπ Mov fError,0 { Clear error flag. }π Mov AH,$68 { Function to Commit file to disk. }π Mov BX,fHandle { Load handle of file to Commit. }π Int $21 { Call dos to flush file. }π Jnc @Exit { If no error exit. }π Mov fError,AX { if there was error save error code. }π@Exit:πEND;{fSetAttr}ππPROCEDURE fLock( fHandle :WORD; LockInf :LockType; StartOfs,Len :LONGINT );π { Routine to lock/unlock parts of a open file. }πASSEMBLER; { Locking or unlock is determined by 'LockInf'. }π { Uses Int 21h/AH=5Ch. }ππASMπ Mov fError,0 { Clear Error Flag. }π Mov AH,$5C { Function to lock/unlock part of a file.}π Mov AL,LockInf { Load whether to lock/unlock file area.}π Mov BX,fHandle { Handle of file to lock. }π Mov CX,StartOfs.WORD[0] { Load StartOfs Into CX:DX. }π Mov DX,StartOfs.WORD[2]π Mov SI,Len.WORD[0] { Load Len Into SI:DI. }π Mov DI,Len.WORD[2]π Int $21 { Call dos to lock area. }π Jnc @Exit { If no error exit. }π Mov fError,AX { If there was an error save it. }π@Exit:πEND;{fLock}ππBEGINπEND.{FileIO}π 50 02-15-9407:51ALL TOM CLANCY Low Level File Read Obj IMPORT 60 .l {*************************************************************************π * LOW LEVEL FILE READING OBJECT *π * *π * Copyright 1992 Tom Clancy *π * *π * Description: *π * *π * This library allows you to create a file of any type record *π * by passing in the record size. You must also pass in a record of *π * the same type that the object has been initialized with so that *π * you don't get errors when reading and writing. *π * *π * There is no internal buffering, but the routines are fairly *π * fast and because each file is actually an object, you can create *π * higher level objects of this object type that allow more *π * flexibility, such as indexing and sorting. *π * *π *************************************************************************}ππ{$I-} {Turn off I/O checking}π{$S-} {Turn off Stack checking}π{$R-} {Turn off Range checking}π{$V-} {No strict VAR string checking allowed here!}ππUnit FileRead;ππInterfaceππConstππ Open = 1;π Create = 2;π OpenCreate = 3;ππTypeππ TFreadPtr = ^TFreadObj;π TFreadObj = Objectπ Constructor Init(fn : string; mode:integer; recsize : longint);π Destructor Done;ππ { random access methods. }π Procedure ReadRec(var frec; fpos:longint); virtual;π Procedure WriteRec(var frec; fpos:longint); virtual;ππ { sequential access methods. }π Procedure AppendRec(var frec);π Procedure ReadNext(var frec);π Procedure ReadPrevious(var frec);π Procedure ReadCurrent(var frec);ππ { various file modification methods. }π Procedure EraseFile;π Function RenameFile(fn:string):boolean;ππ { miscellaneous functions and error flag functions. }π Procedure Rewind;π Function NumRecs : Longint;π Function GetFilename : String;π Function GetCurrent : Longint;π Function OpenError : boolean;π Function ReadError : boolean;π Function WriteError : boolean;ππ privateπ Ifile : File; {file variable}π Rsize : Longint; {the internal record size}π FileName : String; {physical file name}π Oerror, {open error flag}π Rerror, {read error flag}π Werror : Boolean; {write error flag}π Current : Longint; {current file pointer location}ππ { methods used internally. No access allowed! }π Procedure OpenFile;π Procedure CreateFile;π Procedure CloseFile;π end;ππFunction Exist(fn:string):Boolean;ππImplementationππusesπ Dos;ππ{ Pass in a string which contains a file name to see if that file exists.}πFunction Exist(fn:string):Boolean;πVarπ DirInfo : SearchRec;πBeginπ FindFirst(fn,Archive,DirInfo);π Exist:=DosError=0;πEnd;ππ{π Initialize the object.ππ Fn = File nameπ Mode = Open, Create, or OpenCreateπ - Open will try to open the file. An error is set if the file does notπ exist.π - Create will create the file regardless if it's there or not.π - OpenCreate will attemp to open the file first, then create it if it'sπ not there.π RecSize = The size of the records that the file will contain.π - Use Sizeof(Rec) for safety.π}πConstructor TFreadObj.Init(fn:string; mode:integer; recsize:longint);πBeginπ Oerror:=true;π Rerror:=false;π Werror:=false;π Rsize:=recsize;π FileName := fn;π Assign(Ifile,FileName);π case mode ofπ Open : openfile;π Create : createfile;π OpenCreate :π beginπ OpenFile;π if Oerror thenπ CreateFile;π end;π end;πEnd;ππ{ Close the file when disposing object. }πDestructor TFreadObj.done;πbeginπ CloseFile;πend;ππ{ Open the file. Set an error if it could not open. }πProcedure TFreadObj.OpenFile;πBeginπ if Exist(FileName) thenπ beginπ Oerror:=false;π Reset(Ifile,Rsize);π Current:=0;π endπ elseπ Oerror:=true;πEnd;ππ{ Create a new file, zeroing out an existing file.}πProcedure TFreadObj.CreateFile;πBeginπ Rewrite(Ifile,Rsize);π Current:=0;π Oerror:=Ioresult<>0;πend;ππ{ Close the file only if it has been successfully opened.}πProcedure TFreadObj.CloseFile;πBeginπ if not Oerror thenπ beginπ Close(Ifile);π Oerror:=true;π end;πEnd;ππ{ Will erase the file.}πProcedure TFreadObj.EraseFile;πBeginπ if not Oerror thenπ beginπ CloseFile;π Erase(Ifile);π end;πEnd;ππ{ Renames the file.}πFunction TFreadObj.RenameFile(fn:string):Boolean;πVarπ Temp : Longint; {Save the current file pointer}πBeginπ CloseFile;π FileName:=fn;π Rename(Ifile,FileName);π if ioresult=0 thenπ beginπ Temp:=Current;π Assign(Ifile,FileName);π OpenFile;π Current:=Temp;π end;π RenameFile := not Oerror;πend;ππ{ Rewinds the file pointer back to the beginning.}πProcedure TFreadObj.Rewind;πBeginπ if not Oerror thenπ beginπ Seek(Ifile,0);π Current:=0;π end;πend;πππFunction TFreadObj.OpenError:Boolean;πBeginπ OpenError:=Oerror;πEnd;ππFunction TFreadObj.ReadError:Boolean;πBeginπ ReadError:=Rerror;πEnd;ππFunction TFreadObj.WriteError:Boolean;πBeginπ WriteError:=Werror;πEnd;ππ{ Reads a record from the file at location FPOS. Returns the record inπ Frec.}πProcedure TFreadObj.ReadRec(var frec; fpos:longint);πVarπ numread : word;πBeginπ Rerror:=false;π if not Oerror thenπ beginπ Seek(Ifile,fpos);π if ioresult<>0 thenπ Rerror:=trueπ elseπ beginπ Blockread(Ifile,frec,1,numread);π if (numread<>1) or (ioresult<>0) thenπ Rerror:=trueπ elseπ Current:=fpos;π end;π end;πEnd;ππ{ Writes a record to the file at location Fpos.}πProcedure TFreadObj.WriteRec(var frec; fpos:longint);πVarπ numwritten : word;π i:integer;πBeginπ Werror:=false;π if not Oerror thenπ beginπ Seek(Ifile,fpos);π if Ioresult<>0 thenπ Werror:=trueπ elseπ beginπ Blockwrite(Ifile,frec,1,numwritten);π if (numwritten<>1) or (ioresult<>0) thenπ Werror:=trueπ elseπ Current:=fpos;π end;π end;πEnd;ππ{ Appends a record to the end of the file.}πProcedure TFreadObj.AppendRec(var frec);πBeginπ WriteRec(frec,NumRecs);πEnd;ππ{ Reads the next record from the file, allowing sequential access.}πProcedure TFreadObj.ReadNext(var frec);πBeginπ ReadRec(frec,Current+1);πEnd;ππ{ Reads the previous record from the file. }πProcedure TFreadObj.ReadPrevious(var frec);πBeginπ ReadRec(frec,Current-1);πEnd;ππ{ Reads the record pointed to by current. }πProcedure TFreadObj.ReadCurrent(var frec);πBeginπ ReadRec(frec,Current);πEnd;ππ{ Returns the number of records in the file.}πFunction TFreadObj.NumRecs:Longint;πBeginπ if not Oerror thenπ NumRecs:=Filesize(Ifile);πEnd;ππ{ Returns the file name of the file.}πFunction TFreadObj.GetFilename : String;πBeginπ GetFilename:=FileName;πEnd;ππ{ Returns the number of the current record. }πFunction TFreadObj.GetCurrent : Longint;πBeginπ GetCurrent:=Current;πEnd;ππ{ No initialization required.}πend. 51 02-18-9406:59ALL DIRK PAESSLER INI File Handler IMPORT 49 .l π{**********************************************************************π ** UNIT SETUP2 **π ** Handles an *.INI-File similiar to Windows **π **********************************************************************π ** The Setup-variables all have a unique name an can be retrieved **π ** by using the name. A default-value must be given when retrieving **π ** a value, so that the returned value is always valid! **π ** There are different functions for different data types **π ** A BAK-file is created when touching the INI-file **π ** For added speed a copy of the INI file is held in variable SETUP **π **********************************************************************π ** This is untested stuff, it runs flawlessly here in my programs **π ** (c) 1994 by Dirk Paessler, given to the public domain **π ** if you change anything please note; leave my name in here!! **π ** if you have questions or suggestions, please contact me **π┌───────────────────┬─────────────┬───────────────────────────────────┐π│ Dirk Paessler │ │ E-Mail: FIDO 2:2490/1145.15 │π│ Laerchenweg 8 │Fax │ CIS 100114,42 2:2490/2091.5 │π│ D-91058 Erlangen │+499131601169│ internet 100114.42@compuserve.com │π└───────────────────┴─────────────┴───────────────────────────────────┘ππ usage:ππ USES setup2;π VAR MyData:string;π BEGINπ Mydata:=GetStrProfile('MyData','nothing yet');π WriteLn(mydata);π PutStrProfile('MyData','New stuff');π Mydata:=GetStrProfile('MyData','nothing yet');π WriteLn(mydata);π END.πππ }ππUNIT Setup2;πINTERFACEπ πFUNCTION GetIntProfile(name:STRING; default:INTEGER):INTEGER;πPROCEDURE PutRealProfile(name:STRING; wert:REAL);πFUNCTION GetRealProfile(name:STRING; default:REAL):REAL;πPROCEDURE PutStrProfile(name,wert:STRING);πPROCEDURE PutBoolProfile(name:STRING; wert:BOOLEAN);πFUNCTION GetStrProfile(name,default:STRING):STRING;πFUNCTION GetNumProfile(name:STRING):REAL;πFUNCTION GetBoolProfile(name:STRING; default:BOOLEAN):BOOLEAN;π πTYPE PSetup = ^Setuptype;πSetupType = ARRAY [1 .. 70] OF STRING[140];π πVAR Setup : PSetup;πIMPLEMENTATIONπ πVAR q:INTEGER;πCONST anzsetups:INTEGER=0;π newsetup:BOOLEAN=TRUE;π π πFUNCTION ReadALine(VAR Fil:TEXT):STRING;π VAR a:CHAR; b:STRING;πBEGINπ b:='';π a:=#13;π π WHILE (a<>#10) AND NOT (EOF(FIL)) DOπ BEGINπ IF a<>#13 THEN b:=b+a;π Read(fil,a);π END;π ReadAline:=b;πEND;π πPROCEDURE Zerleg(a:STRING; VAR b,c:STRING);π VAR i:INTEGER;πBEGINπ i:=0;π REPEATπ i:=i+1;π UNTIL (a[i]='=') OR (i>length(a));ππ IF i>length(a) THEN i:=length(a);π b:=copy(a,1,i-1);π c:=copy(a,i+1,length(a)-i);πEND;ππFUNCTION FileExist(Fname:string):BOOLEAN;πVAR f:file;πBEGINπ{$I-}π Assign(f,fname);π Reset(f);π Close(f);π{$I+}π FileExist := (IOResult=0) and (fname<>'');πEND;πππPROCEDURE ReadSetup;π VAR MyFil:TEXT;a,myname,wert:STRING;πBEGINπ IF NOT Fileexist('astro5.ini') THENπ BEGINπ Assign(MyFil,'astro5.ini');π Rewrite(MyFil);π WriteLn(MyFil,'; *** PSCS-Astro V5 INI ***');π Close(MyFil);π END;π IF Setup=NIL THENπ BEGINπ New(setup);π END;π Assign(MyFil,'astro5.ini');π Reset(MyFil);π q:=1;π REPEATπ REPEATπ a:=ReadALine(MyFil);π UNTIL (a[1]<>';') OR (eof(myfil));π setup^[q]:=a;π q:=q+1;π UNTIL (EOF(MyFil));π anzsetups:=q-1;π Close(MyFil);π NewSetup:=FALSE;πEND;π π πFUNCTION GetStrProfile(name,default:STRING):STRING;π VAR MyFil:TEXT;a,myname,wert:STRING;πBEGINπ GetStrProfile:=default;π π IF Fileexist('astro5.ini') THENπ BEGINπ IF Setup=NIL THENπ BEGINπ New(setup);π END;π IF NewSetup THEN ReadSetup;π q:=1;π REPEATπ Zerleg(setup^[q],MyName,wert);π q:=q+1;π UNTIL (name=MyName) OR (q>anzsetups);π IF name=MyName THEN GetStrProfile:=wert;π END;πEND;π πFUNCTION GetBoolProfile(name:STRING; default:BOOLEAN):BOOLEAN;π VAR hlpstrg:STRING;πBEGINπ hlpstrg:=GetStrProfile(name,'t');π GetBoolProfile := default;π IF hlpstrg='TRUE' THEN GetBoolProfile := TRUE;π IF hlpstrg='FALSE' THEN GetBoolProfile := FALSE;πEND;π πPROCEDURE PutBoolProfile(name:STRING; wert:BOOLEAN);π VAR hlpstrg:STRING;πBEGINπ hlpstrg:='FALSE';π IF wert THEN hlpstrg:='TRUE';π PutStrProfile(name,hlpstrg);πEND;π πFUNCTION GetIntProfile(name:STRING; default:INTEGER):INTEGER;πBEGINπ GetIntProfile:=Round(GetRealProfile(name,default*1.0));πEND;π πFUNCTION GetRealProfile(name:STRING; default:REAL):REAL;π VAR hlpstrg:STRING; i:INTEGER; a:REAL;πBEGINπ str(default,hlpstrg);π hlpstrg:=GetStrProfile(name,hlpstrg);π val(hlpstrg,a,i);π GetRealProfile:=a;πEND;π πPROCEDURE PutRealProfile(name:STRING; wert:REAL);π VAR hlpstrg:STRING;πBEGINπ Str(wert:1:10,hlpstrg);π PutStrProfile(name,hlpstrg);πEND;π π πPROCEDURE PutStrProfile(name,wert:STRING);π VAR MyFil,my2fil,my3fil:TEXT;a,myname,altwert,Mywert:STRING; WasIt:BOOLEAN;πBEGINπ altwert:=getStrProfile(name,'#*äöü');π IF altwert=wert THEN exit;π π IF NOT Fileexist('astro5.ini') THENπ BEGINπ Assign(MyFil,'astro5.ini');π Rewrite(MyFil);π WriteLn(MyFil,'; *** PSCS-Astro V5 INI ***');π Close(MyFil);π END;π Assign(MyFil,'astro5ini.tmp');π Rewrite(MyFil);π Assign(My2Fil,'astro5.ini');π ReSet(My2Fil);π WasIt:=FALSE;π REPEATπ a:=ReadALine(My2fil);π Zerleg(a,myname,mywert);π IF myname=name THEN BEGINπ WriteLn(myfil,name,'=',wert);π WasIt:=TRUE;π ENDπ ELSE WriteLn(myfil,a)π UNTIL EOF(my2fil);π IF NOT WasIt THEN WriteLn(myfil,name,'=',wert);π Close(MyFil);π Close(My2Fil);π IF Fileexist('astro5.bak') THENπ BEGINπ Assign (my3fil,'astro5.bak');π erase(my3fil);π END;π Rename(My2Fil,'astro5.bak');π Rename(MyFil,'astro5.ini');π ReadSetup;πEND;π πFUNCTION GetNumProfile(name:STRING):REAL;πBEGINπEND;π πBEGINπ π πEND.π π{be sure to insert the following line into your exit-code!!!}ππIF setup<>NIL THEN Dispose(setup);π 52 05-25-9408:08ALL LEE KIRBY DOS pipe as input SWAG9405 15 .l πPROGRAM DFile;ππ{ Purpose: Given, DIR [filespec] /S /B, delete all occurrences of [filespec] }π{ from the current directory on. }π{ Example: dir *.bak /s /b | dfile }ππVARπ In_File : TEXT; { for standard input }π Key : CHAR; { for user confirmation }π Files_Deleted : INTEGER; { for number of files deleted }ππFUNCTION GetKey : CHAR;ππ{ The ASCII code is in AL, which is the place you need }π{ it to be as the byte return value of a function. }π{ Provided by Drew Veliath of 1:272/60@fidonet.org }ππINLINE ( $B4 / $00 / { MOV AH,0 }π $CD / $16 ); { INT $16 }ππPROCEDURE Delete_Files ( VAR In_File : TEXT;π VAR Files_Deleted : INTEGER );πVARπ Trgt_File : TEXT; { for file to be deleted }π File_Spec : STRING; { for filespec entered by user }ππBEGINπ WHILE NOT EOF ( In_File ) DO BEGINπ READLN ( In_File, File_Spec );π ASSIGN ( Trgt_File, File_Spec );π {$I-}π ERASE ( Trgt_File );π {$I+}π IF IORESULT = 0 THEN BEGINπ INC ( Files_Deleted );π WRITELN ( 'Deleted ', File_Spec )π END { IF IORESULT = 0 }π END { WHILE NOT EOF ( In_File ) }πEND; { PROCEDURE Delete_Files }ππBEGIN { main program }π WRITE ( 'Are you sure [yn]? ' );π Key := GetKey;π WRITELN;π Files_Deleted := 0;π IF UPCASE ( Key ) = 'Y' THEN BEGINπ ASSIGN ( In_File, '' ); { assign In_File to standard input }π RESET ( In_File );π Delete_Files ( In_File, Files_Deleted );π CLOSE ( In_File )π END; { IF UPCASE ( Key ) = 'Y' }π WRITELN;π WRITELN ( Files_Deleted, ' file(s) deleted.' )πEND. { main program }π 53 05-25-9408:19ALL RONEN MAGID File and Record Locks SWAG9405 31 .l {πThis is a demonstration of a network unit capable of lockingπpascal records or any set of bytes on a file.ππProgrammer: Ronen Magid, Qiyat-Ono Israel.πContributed to the SWAG.π}ππUnit Network;πInterfaceπUses Dos;ππVarπ Regs : Registers;π RegSize : Byte;π RecSize : Longint;π OffSet : LongInt;π FileHandle : word;ππConstπ SH_COMPAT = $0000;π SH_DENYRW = $0010;π SH_DENYWR = $0020;π SH_DENYRD = $0030;π SH_DENYNONE = $0040;π SH_DENYNO = SH_DENYNONE;π O_RDONLY = $0;π O_WRITE = $1;π O_RDWR = $2;ππfunction Lock(Var Handle: Word; Var Offset, BufLen: Longint): Word;πfunction Unlock(Var Handle: Word; Var OffSet, BufLen: Longint): Word;ππImplementationππfunction Lock(var handle: word; var offset, buflen: longint): word;πvarπ TempOffset:longint;πbeginπ Lock := 0;π TempOffset:=1000000000+Offset;π fillchar(regs, sizeof(regs), 0);π regs.ah := $5C; { Lock file access }π regs.al := 0;π regs.bx := handle;π regs.cx := TempOffset shr RegSize; {and $ffff;}π regs.dx := TempOffset and $ffff;π regs.si := buflen shr RegSize; {and $ffff;}π regs.di := buflen and $ffff;π MsDos(regs);π if (regs.Flags and 1) <> 0 thenπ Lock := regs.ax;πend;ππfunction Unlock(var handle: word; var offset, buflen: longint): word;πvarπ TempOffset:longint;πbeginπ Unlock := 0;π TempOffset:=1000000000+Offset;π regs.ah := $5C; { Unlock file access }π regs.al := 1;π regs.bx := handle;π regs.cx := TempOffset shr RegSize; {and $ffff;}π regs.dx := TempOffset and $ffff;π regs.si := buflen shr RegSize; {and $ffff;}π regs.di := buflen and $ffff;π MsDos(regs);π if (regs.Flags and 1) <> 0 thenπ Unlock := regs.ax;πend;ππEnd.ππ{ --------------------- TEST CODE ... CUT HERE -------------------}ππ{πThis demonstartion will show how to use the NETWORK file-lockπunit to allow lock and lock-check of records in a regularπpascal database file.ππProgrammer: Ronen Magid, Qiyat-Ono Israel.πContributed to the SWAG.π}ππProgram NetTest;πuses Dos,Network;ππTypeπ PhoneRecord = Recordπ Name : String[30];π Address : String[35];π Phone : String[15];π End;ππVarπ PhoneRec : PhoneRecord;π PhoneFile : File of PhoneRecord;π FileHandle : word;π LockStatus : Word;π I : Byte;π Ok : Boolean;ππFunction LockPhoneRec(which: LongInt): Boolean;πBeginπ recsize := SizeOf(PhoneRec);π OffSet := RecSize * Which - Recsize;π FileHandle := FileRec(PhoneFile).handle;π LockStatus := Lock(FileHandle, offset, recsize);π if LockStatus = 0 thenπ beginπ LockPhoneRec:=True;π end elseπ beginπ LockPhoneRec:=False;π end;πend;ππfunction UnLockPhoneRec(Which: Byte): boolean;πvarπ ok: boolean;πbeginπ recsize := SizeOf(PhoneRec);π OffSet := Which * RecSize - RecSize;π FileHandle := FileRec(PhoneFile).handle;π LockStatus := Unlock(FileHandle, offset, recsize);π if LockStatus <> 0 thenπ beginπ UnlockPhoneRec := false;π end elseπ beginπ UnlockPhoneRec := true;π end;πend;ππbeginπ Assign(Phonefile,'PHONE.SMP');π Rewrite(Phonefile);π For I:=1 to 5 do Write(Phonefile,phoneRec);π Close(Phonefile);ππ FileMode := SH_DENYNO + O_RDWR; {Important, Before RESET!}π Reset(Phonefile);ππ { And now lets begin to lock... }ππ Ok:=LockPhoneRec(2);π {Locking phone rec 2}ππ {Now lets see if its locked... }ππ Ok:=LockPhoneRec(2);π {a record is already locked if weπ cant lock it. This locking procedureπ can be performed by other PCs & otherπ tasks.}ππ If Not Ok then writeln('#2 locked');ππ Ok:=UnlockPhoneRec(2);π { lets release it. This will enableπ other tasks or LAN PCs to lockπ (& obtain) this record again...}ππ If Ok then Writeln('Rec #2 unlocked');ππ {thats it...}π Ok:=LockPhoneRec(2);π If Ok then Writeln('And since its free we can relock it !');π Close(phoneFile);πEnd.π 54 05-26-9406:11ALL MARTIN ISREALSEN Buffered Fileread IMPORT 62 .l π(************************************************************************)π(* *)π(* Program ex. to : "Tips & Tricks in Turbo Pascal", SysTime 1993 *)π(* *)π(* By : Martin Israelsen *)π(* *)π(* Title : BUFFER.PAS *)π(* *)π(* Chapter : 5 *)π(* *)π(* Description : Quicker than Turbo fileread *)π(* *)π(************************************************************************)π(*$I-*) (* Iocheck off *)π(*$F+*) (* Force FAR call *)π(*$V-*) (* Relaxed VAR check *)π(*$R-*) (* Range check off *)π(*$S-*) (* Stack check off *)π(*$Q-*) (* Overflow off *)π(*$D-*) (* Debug off *)π(*$L-*) (* Linenumber off *)ππUnitπ Buffer;ππInterfaceππTypeππ PByte = ^Byte;π PWord = ^Word;π PLong = ^Longint;ππ PByteArr = ^TByteArr;π TByteArr = Array[1..64000] Of Byte;π PfStr = String[100];ππ PBuffer = ^TBuffer;π TBuffer = Recordπ BufFil : File;π BufPtr : PByteArr;ππ BufSize,π BufIndex,π BufUsed : Word;ππ BufFPos,π BufFSize : Longint;π End;ππFunction BufferInit(Var Br: PBuffer; MemSize: Word;π FilName: PfStr): Boolean;πProcedure BufferClose(Var Br: PBuffer);ππFunction BufferGetByte(Br: PBuffer): Byte;πFunction BufferGetByteAsm(Br: PBuffer): Byte;ππFunction BufferGetWord(Br: PBuffer): Word;πProcedure BufferGetBlock(Br: PBuffer; Var ToAdr; BlockSize: Word);πFunction BufferGetStringAsm(Br: PBuffer): String;ππFunction BufferEof(Br: PBuffer): Boolean;ππImplementationππ(*$I-,F+*)ππFunction BufferInit(Var Br: PBuffer; MemSize: Word;π FilName: PfStr): Boolean;πBeginπ BufferInit:=False;ππ (* Check if there's enough memory *)ππ If MemSize<500 Then Exit;π If MaxAvail<Sizeof(TBuffer)+MemSize+32 Then Exit;ππ New(Br);ππ With BR^ Doπ Beginπ BufSize:=MemSize; BufIndex:=1; BufFPos:=0;ππ (* Open the filen. Exit if there's an error *)ππ Assign(BufFil,Filname); Reset(BufFil,1);ππ If IoResult<>0 Thenπ Beginπ Dispose(Br);π Exit;π End;ππ (* Ok, the file is there, and there's enough *)π (* memory. So allocate the memory and read *)π (* as much as possible *)ππ GetMem(BufPtr,BufSize);π BlockRead(BufFil,BufPtr^,BufSize,BufUsed);ππ BufFSize:=FileSize(BufFil); Inc(BufFPos,BufUsed);π End;ππ BufferInit:=True;πEnd;ππProcedure BufferClose(Var Br: PBuffer);πBeginπ With Br^ Doπ Beginπ Close(BufFil);π Freemem(BufPtr,BufSize);π End;ππ Dispose(Br);πEnd;ππProcedure BufferCheck(Br: PBuffer; ReqBytes: Word);πVarπ W,Rest: Word;πBeginπ With Br^ Doπ Beginπ If (BufIndex+ReqBytes>BufUsed) And (BufUsed=BufSize) Thenπ Beginπ Rest:=Succ(BufSize-BufIndex);ππ Move(BufPtr^[BufIndex],BufPtr^[1],Rest);π BufIndex:=1;ππ BlockRead(BufFil,BufPtr^[Succ(Rest)],BufSize-Rest,W);π BufUsed:=Rest+W; Inc(BufFPos,W);π End;π End;πEnd;ππFunction BufferGetByte(Br: PBuffer): Byte;πBeginπ With Br^ Doπ Beginπ BufferCheck(Br,1);ππ BufferGetByte:=BufPtr^[BufIndex];π Inc(BufIndex);π End;πEnd;ππFunction BufferGetByteAsm(Br: PBuffer): Byte; Assembler;πAsmπ Les Di,Br (* ES:DI -> BRecPtr *)ππ Mov Ax,Es:[Di.TBuffer.BufIndex] (* Check wheather the buffer should be updated *)π Cmp Ax,Es:[Di.TBuffer.BufUsed]π Jle @@NoBufCheck (* If not jump on *)ππ Push Word Ptr Br[2] (* Push BR to BufferCheck *)π Push Word Ptr Brπ Mov Ax,0001 (* Check for one byte *)π Push Ax (* Push it *)π Push CS (* Push CS, and make a *)π Call Near Ptr BufferCheck (* NEAR call - it's quicker *)ππ Les Di,Br (* ES:DI-> BRecPtr *)ππ @@NoBufCheck:ππ Mov Bx,Es:[Di.TBuffer.BufIndex] (* BufferIndex in BX *)π Inc Es:[Di.TBuffer.BufIndex] (* Inc BufferIndex directly *)π Les Di,Es:[Di.TBuffer.BufPtr] (* ES:DI -> BufPtr *)ππ Xor Ax,Ax (* Now get the byte *)π Mov Al,Byte Ptr Es:[Di+Bx-1]πEnd;ππFunction BufferGetWord(Br: PBuffer): Word;πBeginπ With Br^ Doπ Beginπ BufferCheck(Br,2);ππ BufferGetWord:=PWord(@BufPtr^[BufIndex])^;π Inc(BufIndex,2);π End;πEnd;ππProcedure BufferGetBlock(Br: PBuffer; Var ToAdr; BlockSize: Word);πBeginπ With Br^ Doπ Beginπ BufferCheck(Br,BlockSize);ππ Move(BufPtr^[BufIndex],ToAdr,BlockSize);π Inc(BufIndex,BlockSize);π End;πEnd;ππFunction BufferGetStringAsm(Br: PBuffer): String; Assembler;πAsmπ Push Dsππ Les Di,Br (* es:di -> Br *)π Mov Bx,Es:[Di.TBuffer.BufUsed] (* check for buffercheck *)π Sub Bx,Es:[Di.TBuffer.BufIndex]π Cmp Bx,257π Jae @NoBufCheck (* Jump on if not *)ππ Push Word Ptr Br[2]π Push Word Ptr Brππ Mov Ax,257π Push Axππ Push Csπ Call Near Ptr BufferCheckππ Les Di,Brππ @NoBufCheck:ππ Mov Bx,Es:[Di.TBuffer.BufIndex] (* Get index in buffer *)π Dec Bx (* Adjust for 0 *)ππ Les Di,Es:[Di.TBuffer.BufPtr] (* Point to the buffer *)π Add Di,Bx (* Add Index *)π Push Di (* Save currect position *)ππ Mov Al,$0a (* Search for CR = 0ah *)π Mov Cx,$ff (* max. 255 chars *)ππ Cld (* Remember *)π RepNz Scasb (* and do the search *)π Jz @Fundet (* Jump if we found one *)ππ Mov Cx,0 (* Otherwise set length to 0 *)π @Fundet:π Sub Cx,$ff (* Which will be recalculated *)π Neg Cx (* to nomal length *)π Dec Cx (* Dec, to avoid CR *)ππ Push Es (* DS:SI->Buffer *)π Pop Dsπ Pop Siππ Les Di,@Result (* ES:DI->result string *)π Mov Ax,Cxππ Stosb (* Set length *)ππ Shr Cx,1 (* Copy the string *)π Rep MovSwπ Adc Cx,Cxπ Rep MovSbππ Pop Ds (* Restore DS *)ππ Les Di,Br (* ES:DI->Br *)π Inc Ax (* Inc Ax, point to LF *)ππ Add Es:[Di.TBuffer.BufIndex],Ax (* and set BufferIndex *)πEnd;πππFunction BufferEof(Br: PBuffer): Boolean;πBeginπ With Br^ Doπ BufferEof:=(BufIndex>BufUsed) And (BufFPos=BufFSize);πEnd;ππEnd.ππ 55 08-24-9413:31ALL RAPHAEL VANNEY Remove Records from File SWAG9408 f¼▌k 19 .l π{ The following procedure physically removes record(s) from any file,π then truncate the file. I use it to shrink log files and to removeπ index entries from Squish .SQI files, but many other uses may be found. }ππ{ Donated to the public domain by Raphaël Vanney. }ππUses DOS ;ππFunction DeleteRecs( Var AFile ;π From : LongInt ;π Count : LongInt ;π BufSize : Word) : Integer ;ππ{ AFile : any typed or untyped file (not Text), must be opened }π{ From : number of 1st record to delete, 0-based }π{ Count : number of record(s) to delete }π{ BufSize : size of the buffer to allocate. Must be > record size }ππVar Buffer : Pointer ; { pointer to buffer }π Src : LongInt ; { source record pointer }π Cnt : LongInt ; { scratch }π Last : LongInt ; { last record to move }π f : File Absolute AFile ; { file we're going to work on }π Err : Integer ; { error code }ππLabelπ Sortie ;ππBeginπ Last:=FileSize(f) ;π Src:=From+Count ;π If Count>(Last-From) Then Count:=Last-From ;ππ { check BufSize against FileRec(f).RecSize }π If (BufSize<FileRec(f).RecSize) Orπ (MaxAvail<BufSize) Thenπ Beginπ DeleteRecs:=1 ; { error }π Exit ;π End ;ππ GetMem(Buffer, BufSize) ;ππ While Src<Last Doπ Beginπ Cnt:=BufSize Div FileRec(f).RecSize ;π If (Src+Cnt)>Last Then Cnt:=Last-Src ;π Seek(f, Src) ;π BlockRead(f, Buffer^, Cnt) ;π { error check }π Err:=IOResult ;π If Err<>0 Then GoTo Sortie ;π Seek(f, From) ;π BlockWrite(f, Buffer^, Cnt) ;π { error check }π Err:=IOResult ;π If Err<>0 Then GoTo Sortie ;π Inc(Src, Cnt) ;π Inc(From, Cnt) ;π End ;ππ Seek(f, Last-Count) ;π Truncate(f) ;πSortie:π DeleteRecs:=Err ;π FreeMem(Buffer, BufSize) ;πEnd;ππBEGINπEND. 56 08-24-9413:44ALL JOHN HOWARD Is String in File SWAG9408 >: V 31 .l πPROGRAM HI_There;π(* Syntax: there textfile number /quotedstringπ where textfile is filename, number is a line offset, & quotedstring is aπ group of characters without embedded control codes. Purpose is to go to aπ given line offset in the text file, search that line for the string, andπ report via DOS error 1=True or 0=False depending upon if it was there.ππExample: there.exe there.pas 0 /'program'π would return error level 1 (True) since 'program' is on the first line.ππAuthor: John Howard Date: January 5, 1994πCopyright 1994 Howard International, P.O. Box 34633, NKC, MO 64116ππRestrictions: You are free to use this program but I retain commercialπ ownership. You may not charge someone to use this program.πNote: Case sensitive. Front or Back quote is removed. No trailingπ whitespace is removed from the string. Zero-based line offset.π Returns DOS error level values: 0 thru 4 ******* *)π{$DEFINE debug}πVARπ F: text; (* CHAIN.TXT dropfile used by WWIV BBS *)π LineNo: word; (* Line Number from 0..65535 *)π S: string; (* Substring of 1..255 characters *)π CmdLine: string; (* string[127] command-line string *)ππ Test: string; (* temporary search line *)π Code: integer; (* temporary result of VAL conversion *)π I: word; (* temporary index of current line *)π B: byte; (* temporary index of command-line string *)πBEGIN { MAIN }π {$I-} (* Turn OFF input/output checking to prevent run-time error *)π (* Open an existing text file *)π Assign(F, ParamStr(1));π Reset(F);π {$I+} (* Turn ON I/O *)π if (IOResult <> 0) then Halt(2); {writeln('File not found');}π (* Get text from command line and convert into a number *)π Val(ParamStr(2), LineNo, Code);π if Code <> 0 then Halt(3); {writeln('Bad number at position: ', Code);}π (* Get quoted string or un-broken string. NO end whitespace removed! *)π Move(Mem[PrefixSeg:$80], CmdLine, Mem[PrefixSeg:$80] + 1);π S := CmdLine;π{$IFDEF debug} writeln(S); {$ENDIF}π B := Pos( '/', S);π{$IFDEF debug} writeln('CmdLine pos ', B); {$ENDIF}π Delete(S, 1, B);π if S[1] = #39 then Delete(S, 1, 1); (* start quote *)π if S[Length(S)] = #39 then Delete(S, Length(S), 1); (* end quote *)π if S = '' then Halt(4); {writeln('Empty string not allowed');}π{$IFDEF debug} writeln('Line: ', LineNo); {$ENDIF}π{$IFDEF debug} writeln(S); {$ENDIF}π (* Go to specified line within text file *)π I := 0;π while not Eof(F) doπ beginπ Readln(F, Test);π{$IFDEF debug} writeln(Test); {$ENDIF}π if (I = LineNo) thenπ beginπ if Pos(S, Test) > 0 thenπ (* String S matched substr Test at position *)π beginπ Close(F);π{$IFDEF debug} writeln('True ', I); {$ENDIF}π Halt(1); (* Return True *)π endπ elseπ (* Search string not found *)π beginπ Close(F);π{$IFDEF debug} writeln('False ', I); {$ENDIF}π Halt(0); (* Return False *)π end;π end;π (* Move to the next line *)π if (I < 65535) thenπ INC(I) {I := I + 1}π elseπ beginπ Close(F);π Halt(0);π end;π end; {while}π (* Close the existing text file *)π Close(F);π Halt(0); (* Return False *)πEND. { MAIN }ππ 57 08-25-9409:04ALL JOSE CAMPIONE >64K Blockread/BlockwriteSWAG9408 ╙î╬ 65 .l (*************************************************************************ππ =====================================================π Breaking the 64K barrier for BlockRead and BlockWriteπ =====================================================π Copyright (c) 1992,1994 by José Campioneπ Ottawa-Orleans Personal Systems Groupπ Fidonet: 1:163/513.3ππ Turbo Pascal implements two procedures for fast transfer of data from π files to memory blocks and viceversa: Blockread and Blockwrite. One of π the commonly encountered limitation in these procedures is the fact that π they can only handle blocks not exceeding 65535 bytes.ππ This limitation bears a connection with the often asked question on how π to brake the 64K barrier for arrays declared in Pascal. Several answers π have been proposed to this effect. Perhaps one of the most elegant is π the one proposed by Neil Rubenking in his book on Turbo Pascal 6.0 π Techniques and Utilities (Ziff-Davis Press, 1991). Albeit elegant, π Neil's approach uses OOP which may not be fully appreciated by many π Pascal users. ππ So, here is a less ambitious approach with several procedures and π functions permitting the direct handling of large memory blocks. In the π following unit large memory blocks are defined as arrays of blocks eachπ not exceeding 64K. The only limitation for the size of the overall large π block is that it must not exceed the normal RAM. A longint pointer is π then used to access individual positions. ππ This unit uses a modified heapfunc that permits the replacement of "new" π with "getmem". This, together with range checking off, allows an array π to be declared as a single byte. During runtime it can be assigned any π size determined by the program. This ensures that the "tail" of the big π block will never be larger than strictly necessary. ππ Functions BigBlockRead and BigBlockWrite permit the reading and writing π of blocks from and to a file much in the same way as Pascal's BlockReadπ and BlockWrite. Only difference is that the 64K limit is not a problem π anymore. Note that the size of the blocks can only be defined in terms π of bytes and that the file being read or write must have been previously π assigned to variable f (an untyped file declared within the unit). Also, π these are not procedures but functions returning false if the reading or π the writing of the big block was not completed. ππ In the present implementation only one array of big blocks is permitted. π Variable BigBlkExist ensures that MakeBig will only work if a previous π big block has not been created. BigBlk is the array of blocks reserved π in the heap. SizBlk is an array containing the sizes in bytes of each π block reserved in the heap as part of the big block. NumVec contains theπ number of blocks used by the big block. ππ And last, some acknowledgements:ππ Part of this unit was inspired by code contained in a file posted at π garbo.uwasa.fi by Prof. Timo Salmi. The code itself was based on a π submission by Naji Moawad. Prof. Salmi's code contained the following π message: ππ The code below is based on a UseNet posting in comp.lang.pascal by π Naji Mouawad nmouawad@watmath.waterloo.edu. Naji's idea was for a π vector, my adaptation is for a two-dimensional matrix. The realizationπ of the idea is simpler than the one presented by Kent Porter in π Dr.Dobb's Journal, March 1988. π***************************************************************************)ππ{$R-} { R has to be off... }π{$M 8096,0,655360}ππunit bigarru;ππinterfaceππ uses crt,dos;ππ constπ SizVec = $FFFF;π MaxBlk = $FF;ππ typeπ Vec = array [0..0] of byte;ππ varπ BigBlk : array[0..MaxBlk] of ^Vec;π SizBlk : array[0..MaxBlk] of word;π TotSizBlk : longint;π NumVec : byte;π HeapTop : pointer;π BigBlkExist : boolean;ππ {$F+} function HeapFunc(Size: word) : integer; {$F-}π function MakeBig(HeapNeeded: longint): boolean;π function Peek(p: longint; var error: boolean): byte;π procedure Poke(b : byte; p: longint; var error: boolean);π procedure FillRange(fromby, toby :longint; b : byte);π procedure FillAll(b: byte);π function BigBlockRead (var f: file): boolean;π function BigBlockWrite(var f: file): boolean;ππimplementationππ {$F+} function HeapFunc(Size: word) : integer; {$F-}π beginπ HeapFunc:= 1;π end;ππ { Create the dynamic variables }π { HeapNeeded is the needed number of BYTES }π function MakeBig(HeapNeeded: longint): boolean;π varπ i : integer;π error : boolean;π beginπ error:= false;π if BigBlkExist then beginπ Makebig:= false;π exit;π end;π fillchar(sizblk,sizeof(sizblk),0);π NumVec:= (HeapNeeded div SizVec);π if (HeapNeeded < SizVec) then beginπ SizBlk[NumVec]:= HeapNeeded;π BigBlk[NumVec]:= nil;π GetMem(BigBlk[NumVec], SizBlk[NumVec]);π if BigBlk[NumVec] = nil then error:= true;π end else beginπ i:= -1;π while not error and (i < NumVec - 1) do beginπ inc(i,1);π SizBlk[i]:= SizVec;π BigBlk[i]:= nil;π GetMem(BigBlk[i],SizBlk[i]);π if BigBlk[i] = nil then error:= true;π end;π if not error then beginπ SizBlk[NumVec]:= HeapNeeded - ((i + 1) * SizVec);π BigBlk[NumVec]:= nil;π GetMem(BigBlk[NumVec], SizBlk[NumVec]);π if BigBlk[NumVec] = nil then error:= true;π end;π end;π if not error then beginπ TotSizBlk:= HeapNeeded;π BigBlkExist:= true;π MakeBig:= true;π end else beginπ MakeBig:= false;π release(heaptop);π end;π end; { makebig }ππ function Peek(p: longint; var error: boolean): byte;π varπ VecNum: byte;π BytNum: word;π beginπ if BigBlkExist and not (p > totsizblk) then beginπ error:= false;π VecNum:= p div SizVec;π BytNum:= p - (VecNum * SizVec);π peek:= BigBlk[VecNum]^[BytNum];π end else beginπ error:= true;π peek:= 0;π end;π end;ππ procedure Poke(b: byte; p: longint; var error: boolean);π varπ VecNum: byte;π BytNum: word;π beginπ if BigBlkExist and not (p > totsizblk) then beginπ error:= false;π VecNum:= p div SizVec;π BytNum:= p - (VecNum * SizVec);π BigBlk[VecNum]^[BytNum]:= b;π end else error:= true;π end;ππ procedure FillRange(fromby, toby :longint; b : byte);π varπ p: longint;π VecNum: byte;π BytNum: word;π beginπ If BigBlkExist then beginπ for p:= fromby to toby do beginπ VecNum:= p div SizVec;π BytNum:= p - (VecNum * SizVec);π BigBlk[VecNum]^[BytNum]:= b;π end;π end;π end;ππ procedure FillAll(b: byte);π varπ i : byte;π beginπ if BigBlkExist thenπ for i:= 0 to NumVec doπ fillchar(BigBlk[i]^,SizBlk[i],b);π end;ππ function BigBlockRead (var f: file): boolean;π varπ i : integer;π error : boolean;π beginπ error:= false;π BigBlockRead:= true;π {$I-} reset(f,1); {$I+}π if (ioresult = 0) and bigblkexist then beginπ i:= -1;π while not error and (i < NumVec) do beginπ inc(i,1);π {$I-} BlockRead(f,BigBlk[i]^,SizBlk[i]); {$I+}π if ioresult <> 0 then error:= true;π end;π if not error then {$I-}close(f){$I+} else BigBlockRead:= false;π end else BigBlockRead:= false;π end;ππ function BigBlockWrite(var f: file): boolean;π varπ i : integer;π error : boolean;π beginπ error:= false;π BigBlockWrite:= true;π {$I-} rewrite(f,1); {$I+}π if (ioresult = 0) and bigblkexist then beginπ i:= -1;π while not error and (i < NumVec) do beginπ inc(i,1);π {$I-} BlockWrite(f,BigBlk[i]^,SizBlk[i]); {$I+}π if ioresult <> 0 then error:= true;π end;π if not error then {$I-}close(f){$I+} else BigBlockWrite:= false;π end else BigBlockWrite:= false;π end;ππbeginπ heaperror:= @heapfunc;π BigBlkExist:= false;π mark(heaptop);πend.ππ
