SWAGOLX.EXE (c) 1993 GDSOFT ALL RIGHTS RESERVED 00076 DOS & ENVIRONMENT ROUTINES 1 05-28-9313:38ALL TREVOR CARLSEN Expand DOS File Handles IMPORT 18 ┤φá┼ Unit expfht;ππ { Author: Trevor J Carlsen Released into the public domain }π { PO Box 568 }π { Port Hedland }π { Western Australia 6721 }π { Voice +61 91 732 026 }ππ { EXPFHT: This Unit allows an application to expand the number of File }π { handles in use. It is limited to the number permitted by Dos and }π { initialised in the FileS= of the config.sys File. }ππInterfaceππConstπ NumbFiles= 105;π { Set to the number of File handles needed. 99 will be the max With }π { Dos 2.x and 254 With Dos 3.x. (I don't know why not 255!) }πTypeπ fht = Array[1..NumbFiles] of Byte;πVarπ NewFHT : fht;π OldFHT : LongInt;π OldSize : Word;π πFunction MakeNewFHT: Boolean;πProcedure RestoreOldFHT;πππImplementationππConstπ Successful : Boolean = False;ππVarπ OldExitProc : Pointer;ππ{$R-}πFunction MakeNewFHT : Boolean;π { create a new expanded File handle table - True if successful }π Constπ AlreadyUsed : Boolean = False;π beginπ if not AlreadyUsed then beginπ AlreadyUsed := True;π MakeNewFHT := True;π Successful := True;π OldFHT := MemL[PrefixSeg:$34]; { Store the old FHT address }π FillChar(NewFHT,NumbFiles,$ff); { Fill new table With 255 }π Oldsize := MemW[PrefixSeg:$32]; { Store the old FHT size }π MemW[PrefixSeg:$32] := NumbFiles; { Put new size in the psp }π MemL[PrefixSeg:$34] := LongInt(@NewFHT); { new FHT address in psp }π move(Mem[PrefixSeg:$19],NewFHT,$15); { put contents of old to new }π end { if not AllreadyUsed }π else MakeNewFHT := False;π end; { MakeNewFHT }π{$R+}ππ{$F+}πProcedure RestoreOldFHT;π beginπ ExitProc := OldExitProc;π if Successful then beginπ MemW[PrefixSeg:$32] := OldSize;π MemL[PrefixSeg:$34] := OldFHT;π end; π end;π{$F-}ππbeginπ OldExitProc := ExitProc;π ExitProc := @RestoreOldFHT;πend.ππ 2 05-28-9313:38ALL SWAG SUPPORT TEAM Assign New Environment IMPORT 29 ┤φ╖╧ {π The following TP code assigns a new Environment to the COMMand.COMπ which is invoked by TP's EXEC Function. In this Case, it is usedπ to produce a Dos PROMPT which is different from the one in the Masterπ Environment. Control is returned when the user Types Exit ...π}ππ{ Reduce Retained Memory }ππ{$M 2048,0,0}ππProgram NewEnv;πUsesπ Dos;πTypeπ String128 = String[128];πConstπ NewPrompt =π 'PROMPT=$e[32mType Exit to Return to The Fitness Profiler$e[0m$_$_$p$g' + #0;πVarπ EnvironNew,π EnvironOld,π offsetN,π offsetO,π SegBytes : Word;π TextBuff : String128;π Found,π Okay : Boolean;π Reg : Registers;ππFunction AllocateSeg( BytesNeeded : Word ) : Word;πbeginπ Reg.AH := $48;π Reg.BX := BytesNeeded div 16;π MsDos( Reg );π if Reg.Flags and FCarry <> 0 thenπ AllocateSeg := 0π elseπ AllocateSeg := Reg.AX;πend {AllocateSeg};ππProcedure DeAllocateSeg( AllocSeg : Word; Var okay : Boolean );πbeginπ Reg.ES := AllocSeg;π Reg.AH := $49;π MsDos( Reg );π if Reg.Flags and FCarry <> 0 thenπ okay := Falseπ elseπ okay := True;πend {DeAllocateSeg};ππFunction EnvReadLn( EnvSeg : Word; Var Envoffset : Word ) : String128;πVarπ tempstr : String128;π loopc : Byte;πbeginπ loopc := 0;π Repeatπ inC( loopc );π tempstr[loopc] := CHR(Mem[EnvSeg:Envoffset]);π inC( Envoffset );π Until tempstr[loopc] = #0;π tempstr[0] := CHR(loopc); {set str length}π EnvReadLn := tempstrπend {ReadEnvLn};ππProcedure EnvWriteLn( EnvSeg : Word; Var Envoffset : Word;π AsciizStr : String );πVarπ loopc : Byte;πbeginπ For loopc := 1 to Length( AsciizStr ) doπ beginπ Mem[EnvSeg:Envoffset] := orD(AsciizStr[loopc]);π inC( Envoffset )π endπend {EnvWriteLn};ππbegin {main}π WriteLn(#10,'NewEnv v0.0 Dec.25.91 Greg Vigneault');π SegBytes := 1024; { size of new environment (up to 32k)}π EnvironNew := AllocateSeg( SegBytes );π if EnvironNew = 0 thenπ begin { asked For too much memory? }π WriteLn('Can''t allocate memory segment Bytes.',#7);π Halt(1)π end;π EnvironOld := MemW[ PrefixSeg:$002c ]; { current environ }π { copy orig env, but change the PROMPT command }π Found := False;π offsetO := 0;π offsetN := 0;π Repeat { copy one env Var at a time, old env to new env}π TextBuff := EnvReadLn( EnvironOld, offsetO );π if offsetO >= SegBytes thenπ begin { not enough space? }π WriteLn('not enough new Environment space',#7);π DeAllocateSeg( EnvironNew, okay );π Halt(2) { abort to Dos }π end;π { check For the PROMPT command String }π if Pos('PROMPT=',TextBuff) = 1 thenπ begin { prompt command? }π TextBuff := NewPrompt; { set new prompt }π Found := True;π end;π { now Write the Variable to new environ }π EnvWriteLn( EnvironNew, offsetN, TextBuff );π { loop Until all Variables checked/copied }π Until Mem[EnvironOld:offsetO] = 0;π { if no prompt command found, create one }π if not Found thenπ EnvWriteLn( EnvironNew, offsetN, NewPrompt );π Mem[EnvironNew:offsetN] := 0; { delimit new environ}π MemW[ PrefixSeg:$2c ] := EnvironNew; { activate new env }π WriteLn( #10, '....Type Exit to return to normal prompt...' );π SwapVectors;π Exec( GetEnv('COMSPEC'),'/S'); {shell to Dos w/ new prompt}π SwapVectors;π MemW[ PrefixSeg:$2c ] := EnvironOld; { restore original env}π DeAllocateSeg( EnvironNew, okay );π if not okay thenπ WriteLn( 'Could not release memory!',#7 );πend {NewEnv}.π(*******************************************************************)π 3 05-28-9313:38ALL SWAG SUPPORT TEAM Warm and Cold Boot IMPORT 6 ┤φKà Procedure Warm_Boot;π Beginπ Inline($BB/$00/$01/$B8/$40/$00/$8E/$D8/π $89/$1E/$72/$00/$EA/$00/$00/$FF/$FF);π End;ππProcedure Cold_Boot;π Beginπ Inline($BB/$38/$12/$B8/$40/$00/$8E/$D8/π $89/$1E/$72/$00/$EA/$00/$00/$FF/$FF);π End;ππI saw that you were posting reboot procedures...I didn't catch what it was forπthough, but maybe these will help.πππ--- XANADU (1:124/7007)π * Origin: * XANADU * Grand Prairie, TX * (1:124/7007)π 4 05-28-9313:38ALL SWAG SUPPORT TEAM Cold Boot in BASM IMPORT 8 ┤φ5· # Der User Chris Obee@1:234/26 musste am Donnerstag, dem 22.04.93 um 12:09 Uhrπ# in der Area PASCAL folgendes seiner Tastatur antun................ππ> I would like to write a program in pascal that will accomplish anπ> complete system reboot. The moral equivilent of pressing the big redπ> button. A program that simulates the Cntr-Alt-Del sequence is notπ> sufficient. Anyone who can advise me on if this is possible of not, willπ> receive many thanks.π>π> TTFN: chrisππThat's not as hard as it might seem to be at first glance:ππprogram coldboot;πbeginπ memw[0:$0472] := 0;π asmπ mov ax,$FFFFπ mov ds,axπ jmp far ptr ds:0π end;πend.ππHope you understand the assembler code... :-)πππMichael : [NICO] : [Whoo haz broquen mei brain-waschaer?]π~~~~~~~~~~~~~~~~ππ--- CrossPoint v2.1π * Origin: Send me ALL your money - IMMEDIATELY!! (2:2401/411.2)π 5 05-28-9313:38ALL TURBOPOWER SOFTWARE Edit DOS Environment IMPORT 107 ┤φ■ê {$R-,S-,V-,I-,B-,F-}ππ{Disable the following define if you don't have Turbo Professional}π{$DEFINE UseTpro}ππ{*********************************************************}π{* TPENV.PAS 1.02 *}π{* by TurboPower Software *}π{*********************************************************}ππ{π Version 1.01 11/7/88π Find master environment in Dos 3.3 and 4.0π Version 1.02 11/14/88π Correctly find master environment when runπ Within AUTOEXEC.BATπ}ππUnit TpEnv;π {-Manipulate the environment}ππInterfaceππUses Opus;ππTypeπ EnvArray = Array[0..32767] of Char;π EnvArrayPtr = ^EnvArray;π EnvRec =π Recordπ EnvSeg : Word; {Segment of the environment}π EnvLen : Word; {Usable length of the environment}π EnvPtr : Pointer; {Nil except when allocated on heap}π end;ππConstπ ShellUserProc : Pointer = nil; {Put address of ExecDos user proc here if desiππProcedure MasterEnv(Var Env : EnvRec);π {-Return master environment Record}ππProcedure CurrentEnv(Var Env : EnvRec);π {-Return current environment Record}ππProcedure NewEnv(Var Env : EnvRec; Size : Word);π {-Allocate a new environment on the heap}ππProcedure DisposeEnv(Var Env : EnvRec);π {-Deallocate an environment previously allocated on heap}ππProcedure SetCurrentEnv(Env : EnvRec);π {-Specify a different environment For the current Program}ππProcedure CopyEnv(Src, Dest : EnvRec);π {-Copy contents of Src environment to Dest environment}ππFunction EnvFree(Env : EnvRec) : Word;π {-Return Bytes free in environment}ππFunction GetEnvStr(Env : EnvRec; Search : String) : String;π {-Return a String from the environment}ππFunction SetEnvStr(Env : EnvRec; Search, Value : String) : Boolean;π {-Set environment String, returning True if successful}ππProcedure DumpEnv(Env : EnvRec);π {-Dump the environment to StdOut}ππFunction ProgramStr : String;π {-Return the complete path to the current Program, '' if Dos < 3.0}ππFunction SetProgramStr(Env : EnvRec; Path : String) : Boolean;π {-Add a Program name to the end of an environment if sufficient space}ππ {$IFDEF UseTpro}πFunction ShellWithPrompt(Prompt : String) : Integer;π {-Shell to Dos With a new prompt}π {$endIF}ππProcedure DisposeEnv(Var Env : EnvRec);π {-Deallocate an environment previously allocated on heap}πbeginπ With Env doπ if EnvPtr <> nil then beginπ FreeMem(EnvPtr, EnvLen+31);π ClearEnvRec(Env);π end;πend;ππProcedure SetCurrentEnv(Env : EnvRec);π {-Specify a different environment For the current Program}πbeginπ With Env doπ if EnvSeg <> 0 thenπ MemW[PrefixSeg:$2C] := EnvSeg;πend;ππProcedure CopyEnv(Src, Dest : EnvRec);π {-Copy contents of Src environment to Dest environment}πVarπ Size : Word;π SPtr : EnvArrayPtr;π DPtr : EnvArrayPtr;πbeginπ if (Src.EnvSeg = 0) or (Dest.EnvSeg = 0) thenπ Exit;ππ if Src.EnvLen <= Dest.EnvLen thenπ {Space For the whole thing}π Size := Src.EnvLenπ elseπ {Take what fits}π Size := Dest.EnvLen-1;ππ SPtr := Ptr(Src.EnvSeg, 0);π DPtr := Ptr(Dest.EnvSeg, 0);π Move(SPtr^, DPtr^, Size);π FillChar(DPtr^[Size], Dest.EnvLen-Size, 0);πend;ππProcedure SkipAsciiZ(EPtr : EnvArrayPtr; Var EOfs : Word);π {-Skip to end of current AsciiZ String}πbeginπ While EPtr^[EOfs] <> #0 doπ Inc(EOfs);πend;ππFunction EnvNext(EPtr : EnvArrayPtr) : Word;π {-Return the next available location in environment at EPtr^}πVarπ EOfs : Word;πbeginπ EOfs := 0;π if EPtr <> nil then beginπ While EPtr^[EOfs] <> #0 do beginπ SkipAsciiZ(EPtr, EOfs);π Inc(EOfs);π end;π end;π EnvNext := EOfs;πend;ππFunction EnvFree(Env : EnvRec) : Word;π {-Return Bytes free in environment}πbeginπ With Env doπ if EnvSeg <> 0 thenπ EnvFree := EnvLen-EnvNext(Ptr(EnvSeg, 0))-1π elseπ EnvFree := 0;πend;ππ{$IFNDEF UseTpro}πFunction StUpcase(S : String) : String;π {-Uppercase a String}πVarπ SLen : Byte Absolute S;π I : Integer;πbeginπ For I := 1 to SLen doπ S[I] := UpCase(S[I]);π StUpcase := S;πend;πFunction SearchEnv(EPtr : EnvArrayPtr;π Var Search : String) : Word;π {-Return the position of Search in environment, or $FFFF if not found.π Prior to calling SearchEnv, assure thatπ EPtr is not nil,π Search is not emptyπ }πVarπ SLen : Byte Absolute Search;π EOfs : Word;π MOfs : Word;π SOfs : Word;π Match : Boolean;πbeginπ {Force upper Case search}π Search := Upper(Search);ππ {Assure search String ends in =}π if Search[SLen] <> '=' then beginπ Inc(SLen);π Search[SLen] := '=';π end;ππ EOfs := 0;π While EPtr^[EOfs] <> #0 do beginπ {At the start of a new environment element}π SOfs := 1;π MOfs := EOfs;π Repeatπ Match := (EPtr^[EOfs] = Search[SOfs]);π if Match then beginπ Inc(EOfs);π Inc(SOfs);π end;π Until not Match or (SOfs > SLen);ππ if Match then beginπ {Found a match, return index of start of match}π SearchEnv := MOfs;π Exit;π end;ππ {Skip to end of this environment String}π SkipAsciiZ(EPtr, EOfs);ππ {Skip to start of next environment String}π Inc(EOfs);π end;ππ {No match}π SearchEnv := $FFFF;πend;ππProcedure GetAsciiZ(EPtr : EnvArrayPtr; Var EOfs : Word; Var EStr : String);π {-Collect AsciiZ String starting at EPtr^[EOfs]}πVarπ ELen : Byte Absolute EStr;πbeginπ ELen := 0;π While (EPtr^[EOfs] <> #0) and (ELen < 255) do beginπ Inc(ELen);π EStr[ELen] := EPtr^[EOfs];π Inc(EOfs);π end;πend;ππFunction GetEnvStr(Env : EnvRec; Search : String) : String;π {-Return a String from the environment}πVarπ SLen : Byte Absolute Search;π EPtr : EnvArrayPtr;π EOfs : Word;π EStr : String;π ELen : Byte Absolute EStr;πbeginπ With Env do beginπ ELen := 0;π if (EnvSeg <> 0) and (SLen <> 0) then beginπ {Find the search String}π EPtr := Ptr(EnvSeg, 0);π EOfs := SearchEnv(EPtr, Search);π if EOfs <> $FFFF then beginπ {Skip over the search String}π Inc(EOfs, SLen);π {Build the result String}π GetAsciiZ(EPtr, EOfs, EStr);π end;π end;π GetEnvStr := EStr;π end;πend;ππImplementationππTypeπSO =π Recordπ O : Word;π S : Word;π end;ππProcedure ClearEnvRec(Var Env : EnvRec);π {-Initialize an environment Record}πbeginπ FillChar(Env, SizeOf(Env), 0);πend;ππProcedure MasterEnv(Var Env : EnvRec);π {-Return master environment Record}πVarπ Owner : Word;π Mcb : Word;π Eseg : Word;π Done : Boolean;πbeginπ With Env do beginπ ClearEnvRec(Env);ππ {Interrupt $2E points into COMMAND.COM}π Owner := MemW[0:(2+4*$2E)];ππ {Mcb points to memory control block For COMMAND}π Mcb := Owner-1;π if (Mem[Mcb:0] <> Byte('M')) or (MemW[Mcb:1] <> Owner) thenπ Exit;ππ {Read segment of environment from PSP of COMMAND}π Eseg := MemW[Owner:$2C];ππ {Earlier versions of Dos don't store environment segment there}π if Eseg = 0 then beginπ {Master environment is next block past COMMAND}π Mcb := Owner+MemW[Mcb:3];π if (Mem[Mcb:0] <> Byte('M')) or (MemW[Mcb:1] <> Owner) thenπ {Not the right memory control block}π Exit;π Eseg := Mcb+1;π end elseπ Mcb := Eseg-1;ππ {Return segment and length of environment}π EnvSeg := Eseg;π EnvLen := MemW[Mcb:3] shl 4;π end;πend;ππProcedure CurrentEnv(Var Env : EnvRec);π {-Return current environment Record}πVarπ ESeg : Word;π Mcb : Word;πbeginπ With Env do beginπ ClearEnvRec(Env);π ESeg := MemW[PrefixSeg:$2C];π Mcb := ESeg-1;π if (Mem[Mcb:0] <> Byte('M')) or (MemW[Mcb:1] <> PrefixSeg) thenπ Exit;π EnvSeg := ESeg;π EnvLen := MemW[Mcb:3] shl 4;π end;πend;ππProcedure NewEnv(Var Env : EnvRec; Size : Word);π {-Allocate a new environment (on the heap)}πVarπ Mcb : Word;πbeginπ With Env doπ if MaxAvail < Size+31 thenπ {Insufficient space}π ClearEnvRec(Env)π else beginπ {31 extra Bytes For paraGraph alignment, fake MCB}π GetMem(EnvPtr, Size+31);π EnvSeg := SO(EnvPtr).S+1;π if SO(EnvPtr).O <> 0 thenπ Inc(EnvSeg);π EnvLen := Size;π {Fill it With nulls}π FillChar(EnvPtr^, Size+31, 0);π {Make a fake MCB below it}π Mcb := EnvSeg-1;π Mem[Mcb:0] := Byte('M');π MemW[Mcb:1] := PrefixSeg;π MemW[Mcb:3] := (Size+15) shr 4;π end;πend;ππFunction SetEnvStr(Env : EnvRec; Search, Value : String) : Boolean;π {-Set environment String, returning True if successful}πVarπ SLen : Byte Absolute Search;π VLen : Byte Absolute Value;π EPtr : EnvArrayPtr;π ENext : Word;π EOfs : Word;π MOfs : Word;π OldLen : Word;π NewLen : Word;π NulLen : Word;πbeginπ With Env do beginπ SetEnvStr := False;π if (EnvSeg = 0) or (SLen = 0) thenπ Exit;π EPtr := Ptr(EnvSeg, 0);ππ {Find the search String}π EOfs := SearchEnv(EPtr, Search);ππ {Get the index of the next available environment location}π ENext := EnvNext(EPtr);ππ {Get total length of new environment String}π NewLen := SLen+VLen;ππ if EOfs <> $FFFF then beginπ {Search String exists}π MOfs := EOfs+SLen;π {Scan to end of String}π SkipAsciiZ(EPtr, MOfs);π OldLen := MOfs-EOfs;π {No extra nulls to add}π NulLen := 0;π end else beginπ OldLen := 0;π {One extra null to add}π NulLen := 1;π end;ππ if VLen <> 0 thenπ {Not a pure deletion}π if ENext+NewLen+NulLen >= EnvLen+OldLen thenπ {New String won't fit}π Exit;ππ if OldLen <> 0 then beginπ {OverWrite previous environment String}π Move(EPtr^[MOfs+1], EPtr^[EOfs], ENext-MOfs-1);π {More space free now}π Dec(ENext, OldLen+1);π end;ππ {Append new String}π if VLen <> 0 then beginπ Move(Search[1], EPtr^[ENext], SLen);π Inc(ENext, SLen);π Move(Value[1], EPtr^[ENext], VLen);π Inc(ENext, VLen);π end;ππ {Clear out the rest of the environment}π FillChar(EPtr^[ENext], EnvLen-ENext, 0);ππ SetEnvStr := True;π end;πend;ππProcedure DumpEnv(Env : EnvRec);π {-Dump the environment to StdOut}πVarπ EOfs : Word;π EPtr : EnvArrayPtr;πbeginπ With Env do beginπ if EnvSeg = 0 thenπ Exit;π EPtr := Ptr(EnvSeg, 0);π EOfs := 0;π WriteLn;π While EPtr^[EOfs] <> #0 do beginπ While EPtr^[EOfs] <> #0 do beginπ Write(EPtr^[EOfs]);π Inc(EOfs);π end;π WriteLn;π Inc(EOfs);π end;π WriteLn('Bytes free: ', EnvFree(Env));π end;πend;π{$IFDEF UseTpro}πFunction ShellWithPrompt(Prompt : String) : Integer;π {-Shell to Dos With a new prompt}πConstπ PromptStr : String[7] = 'PROMPT=';πVarπ PLen : Byte Absolute Prompt;π NSize : Word;π Status : Integer;π CE : EnvRec;π NE : EnvRec;π OldP : String;π OldPLen : Byte Absolute OldP;πbeginπ {Point to current environment}π CurrentEnv(CE);π if CE.EnvSeg = 0 then beginπ {Error getting environment}π ShellWithPrompt := -5;π Exit;π end;ππ {Compute size of new environment}π OldP := GetEnvStr(CE, PromptStr);π NSize := CE.EnvLen;π if OldPLen < PLen thenπ Inc(NSize, PLen-OldPLen);ππ {Allocate and initialize a new environment}π NewEnv(NE, NSize);π if NE.EnvSeg = 0 then beginπ {Insufficient memory For new environment}π ShellWithPrompt := -6;π Exit;π end;π CopyEnv(CE, NE);ππ {Get the Program name from the current environment}π OldP := ProgramStr;ππ {Set the new prompt String}π if not SetEnvStr(NE, PromptStr, Prompt) then beginπ {Program error, should have enough space}π ShellWithPrompt := -7;π Exit;π end;ππ {Transfer Program name to new environment if possible}π if not SetProgramStr(NE, OldP) thenπ ;ππ {Point to new environment}π SetCurrentEnv(NE);ππ {Shell to Dos With new prompt in place}π {Status := Exec('', True, ShellUserProc);}ππ {Restore previous environment}π SetCurrentEnv(CE);ππ {Release the heap space}π if Status >= 0 thenπ DisposeEnv(NE);ππ {Return exec status}π ShellWithPrompt := Status;πend;π{$endIF}ππend.ππ{ EXAMPLE PROGRAM }ππFunction DosVersion : Word;π {-Return the Dos version, major part in AX}πInline(π $B4/$30/ {mov ah,$30}π $CD/$21/ {int $21}π $86/$C4); {xchg ah,al}ππFunction ProgramStr : String;π {-Return the name of the current Program, '' if Dos < 3.0}πVarπ EOfs : Word;π Env : EnvRec;π EPtr : EnvArrayPtr;π PStr : String;πbeginπ ProgramStr := '';π if DosVersion < $0300 thenπ Exit;π CurrentEnv(Env);π if Env.EnvSeg = 0 thenπ Exit;π {Find the end of the current environment}π EPtr := Ptr(Env.EnvSeg, 0);π EOfs := EnvNext(EPtr);π {Skip to start of path name}π Inc(EOfs, 3);π {Collect the path name}π GetAsciiZ(EPtr, EOfs, PStr);π ProgramStr := PStr;πend;ππFunction SetProgramStr(Env : EnvRec; Path : String) : Boolean;π {-Add a Program name to the end of an environment if sufficient space}πVarπ PLen : Byte Absolute Path;π EOfs : Word;π Numb : Word;π EPtr : EnvArrayPtr;πbeginπ SetProgramStr := False;π With Env do beginπ if EnvSeg = 0 thenπ Exit;π {Find the end of the current environment}π EPtr := Ptr(EnvSeg, 0);π EOfs := EnvNext(EPtr);π {Assure space For path}π if EnvLen < PLen+EOfs+4 thenπ Exit;π {Put in the count field}π Inc(EOfs);π Numb := 1;π Move(Numb, EPtr^[EOfs], 2);π {Skip to start of path name}π Inc(EOfs, 2);π {Move the path into place}π Path := Upper(Path);π Move(Path[1], EPtr^[EOfs], PLen);π {Null terminate}π Inc(EOfs, PLen);π EPtr^[EOfs] := #0;π SetProgramStr := True;π end;πend;π 6 05-29-9322:24ALL GAYLE DAVIS Read Environment String IMPORT 14 ┤φ╔ô {$S-,R-,V-,I-,N-,B-,F-}ππ{$IFNDEF Ver40}π {Allow overlays}π {$F+,O-,X+,A-}π{$ENDIF}ππUNIT Self;ππINTERFACEππFUNCTION GetSelf : STRING;πFUNCTION GetSelfPath : STRING;ππIMPLEMENTATIONππFUNCTION GetSelf : STRING;ππ VARπ Temp : STRING;π I, EnvSeg : WORD;π BEGINπ I := 0;π Temp := '';π EnvSeg := memw [prefixseg : $2C]; { have to set this up like any variable! }π WHILE memw [EnvSeg : I] <> 0 DO { read through environment strings }π INC (I);π INC (I, 4); { jump around 2 null bytes & word count }π WHILE mem [EnvSeg : I] <> 0 DO { skim off path & filename }π BEGINπ Temp := Temp + UPCASE (CHR (mem [EnvSeg : I]) );π INC (I);π END;π GetSelf := Temp;πEND; { function GetSelf }πππFUNCTION GetSelfPath : STRING;ππ VARπ Temp : STRING;π I, EnvSeg : WORD;π Place : INTEGER;π BEGINπ I := 0;π Temp := '';π EnvSeg := memw [prefixseg : $2C]; { have to set this up like any variable! }π WHILE memw [EnvSeg : I] <> 0 DO { read through environment strings }π INC (I);π INC (I, 4); { jump around 2 null bytes & word count }π WHILE mem [EnvSeg : I] <> 0 DO { skim off path & filename }π BEGINπ Temp := Temp + UPCASE (CHR (mem [EnvSeg : I]) );π INC (I);π END;π Place := LENGTH (Temp);π WHILE (Place > 0) AND NOT (Temp [Place] IN [':', '\']) DOπ Place := PRED (Place);π IF Place > 0 THEN Temp [0] := CHR (Place);π GetSelfPath := Temp;πEND; { function SelfPath }ππEND.π 7 05-31-9308:06ALL MARK OUELLET Execute & Redirection IMPORT 148 ┤φ²c π------------------------------------------------------------------------ππEcho Flag : Permanent: N Export: N Personal Read: Nππ BBS: IN-TECH Conference: PASCAL Imported: 11/14/1991π To: DAVID HICKEY Num: 1442 Date: 10/31/1991πFrom: MARK OUELLET Re: 0 Time: 10:51 pmπSubj: >NUL REDIRECTION Prvt: N Read: Nππ On 27 Oct 91, you, David Hickey, of 1:261/1108.0 wrote...ππ DH> From the DOS prompt, I can redirect things easily. But when I try it in π DH> my program, it doesn't work at all. Here's what I'm doing:π DH> π DH> EXEC ('C:\Pkzip.Exe', '-o c:\ra\ra.zip c:\ra\ralogs\ra.log >nul');π DH> π DH> The problem is that the information from Pkzip is not being redirected π DH> to NULπ DH> like I want it to. It's obviously got to be something I'm not doing π DH> right. Anyone know what it is? I've tried everything I can think of.ππDavid,π This might help you,ππMsg#:20994 *> PASCAL Echo <*π03/17/89 03:15:00πFrom: ROSS WENTWORTHπ To: NORBERT LANGEπSubj: REPLY TO MSG# 20986 (RE: REDIRECTING STDERR)π > I'd appreciate seeing some code. I've tried this before,π > using a couple different methods, and couldn't seem to getπ > DOS to like redirecting StdErr. I tried the $45 (Duplicateπ > File Handle) function as well with no success.ππOk, here's a routine that can be easily modified to do the job. It replaces πEXEC from the DOS unit and checks the "command line" for the redirection πsymbols ('>' and '<'). One minor change and it will redirect STDERR to the πfile (see comment below).π{=============================================================}πUnit Execute;ππInterfaceππProcedure Exec(Path,CmdLine : String);ππImplementationππUsesπ Dos;ππFunction ExtractFileName(Var Line : String;Index : Integer) : String;ππVarπ Temp : String;ππBeginπ Delete(Line,Index,1);π While (Index <= Length(Line)) AND (Line[Index] = ' ')π Do Delete(Line,Index,1);π Temp := '';π While (Index <= Length(Line)) AND (Line[Index] <> ' ') Doπ Beginπ Temp := Temp + Line[Index];π Delete(Line,Index,1);π End;π ExtractFileName := Temp;πEnd;ππProcedure CloseHandle(Handle : Word);ππVarπ Regs : Registers;ππBeginπ With Regs Doπ Beginπ AH := $3E;π BX := Handle;π MsDos(Regs);π End;πEnd;ππProcedure Duplicate(SourceHandle : Word;Var TargetHandle : Word);ππVarπ Regs : Registers;ππBeginπ With Regs Doπ Beginπ AH := $45;π BX := SourceHandle;π MsDos(Regs);π TargetHandle := AX;π End;πEnd;ππProcedure ForceDuplicate(SourceHandle : Word;Var TargetHandle : Word);ππVarπ Regs : Registers;ππBeginπ With Regs Doπ Beginπ AH := $46;π BX := SourceHandle;π CX := TargetHandle;π MsDos(Regs);π TargetHandle := AX;π End;πEnd;ππProcedure Exec(Path,CmdLine : String);ππVarπ StdIn : Word;π Stdout : Word;π Index : Integer;π FName : String[80];π InFile : Text;π OutFile : Text;ππ InHandle : Word;π OutHandle : Word;π { ===============>>>> } { change below for STDERR }πBeginπ StdIn := 0;π StdOut := 1; { change to 2 for StdErr }π Duplicate(StdIn,InHandle); { duplicate standard input }π Duplicate(StdOut,OutHandle); { duplicate standard output }π Index := Pos('>',CmdLine);π If Index > 0 Then { check for output redirection }π Beginπ FName := ExtractFileName(CmdLine,Index); { get output file name }π Assign(OutFile,FName); { open a text file }π Rewrite(OutFile); { .. for output }π ForceDuplicate(TextRec(OutFile).Handle,StdOut);{ make output same }π End;π Index := Pos('<',CmdLine);π If Index > 0 Then { check for input redirection }π Beginπ FName := ExtractFileName(CmdLine,Index); { get input file name }π Assign(InFile,FName); { open a text file }π Reset(InFile); { for input }π ForceDuplicate(TextRec(InFile).Handle,StdIn); { make input same }π End;π DOS.Exec(Path,CmdLine); { run EXEC }π ForceDuplicate(InHandle,StdIn); { put standard input back to keyboard }π ForceDuplicate(OutHandle,StdOut); { put standard output back to screen }π CloseHandle(InHandle); { close the redirected input file }π CloseHandle(OutHandle); { close the redirected output file }πEnd;ππEnd.ππ{===============================================================}ππUse it exactly as you would the normal EXEC procedure:ππ Exec('MASM.EXE','mystuff.asm');ππTo activate redirection simply add the redirection symbols, etc:ππ Exec('MASM.EXE',mystuff.asm >err.lst');πππOne note of caution. This routine temporarily uses extra handles. It'πs eitherπtwo or four more. The various books I have are not clear as two whether πduplicated handles 'count' or not. My guess is yes. If you don't plan on πredirecting STDIN then remove all the code for duplicating it to cut yourπhandle overhead in half.ππ Ross Wentworthππ+++ FD 2.00π Origin: St Dymphna's Retreat via Torrance BBS 213-370-9027 (1:102/345.1)ππ Best regards,π Mark Ouellet.πππ--- ME2π * Origin: The Doctor's Tardis, A point in time!! (Fidonet 1:240/1.4)π==============================================================================π BBS: «« The Information and Technology Exchanπ To: BUTCH ADAMS Date: 12-10─91 (18:00)πFrom: RUSS PARKS Number: 3982 [101] PASCALπSubj: EXEC() Status: Publicπ------------------------------------------------------------------------------π* In a bleating, agonizing plea to All, Butch Adams groaned:ππBA> I'm wondering if I can get some insight as to how toπBA>use the Exec() command in TP6. What I'm trying to do is this:πBA> Exec('Type Filename|sort > newfilename', '');πBA>I've even tried this:πBA> Exec('Type', 'filename|sort > newfilename');ππ Close, but no cigar :-) Try something like this:π Exec('command.com', '/c type filename | sort > newfilename');ππ The first parameter is the path to the program to be run. In thisπcase, 'TYPE' is an internal DOS command so you need to runπCOMMAND.COM. The second parameter is a string with the commandπline arguments you want to pass to the program.π P.S.: The '/c' part of the parameters tells COMMAND.COM to executeπthe command, then exit back to the program that originallyπcalled the COMMAND.COM. It's like loading COMMAND.COM, runningπa program, then typing 'EXIT'.πBesta'Luck,πRussππ---π * Origin: Objectively.Speak('Turbo Pascal 6.0, YEAH!'); (1:170/212)π==============================================================================π BBS: «« The Information and Technology Exchanπ To: BUTCH ADAMS Date: 12-10─91 (21:07)πFrom: MIKE COPELAND Number: 4000 [101] PASCALπSubj: EXEC() Status: Publicπ------------------------------------------------------------------------------π BA> I'm wondering if I can get some insight as to how to use theπ BA>Exec() command in TP6. What I'm trying to do is this:ππ BA> Exec('Type Filename|sort > newfilename', '');ππ BA>I've even tried this:ππ BA> Exec('Type', 'filename|sort > newfilename');ππ BA>But still no result. Are we able to execute internal commands fromπ BA>within a TP program? I've tried loading Command.Com first but all I getπ BA>is the shell to come up and sit there with a C> staring back at me. Iπ BA>would appreciate any help with this.ππ The process to execute any DOS-callable program/command is more thanπyou're doing/showing here. Try the following:ππ{$M 4096,0,0} { allocate space for the child process }ππ SwapVectors;π Exec (GetEnv('COMSPEC'),'/C Type filename|sort > newfile');π SwapVectors;π if DosError > 0 then { check the result of Exec }π You_Have_A_Problem;π if DosExitCode <> 0 thenπ You_Have_A_Different_Problem;π { If you get here, everything's okay... }ππ Read the manual about SwapVectors, DosError, DosExitCode, GetEnv,πExec, the $M parameter, and all the stuff you don't understand here...πππ--- msged 2.07π * Origin: Hello, Keyboard, my old friend... (1:114/18.10)π==============================================================================π BBS: «« The Information and Technology Exchanπ To: ANDREW PARK Date: 12-10─91 (21:15)πFrom: MIKE COPELAND Number: 4001 [101] PASCALπSubj: PASCAL Status: Publicπ------------------------------------------------------------------------------π AP>It's quite simple.π AP>Here's an exampleπ AP>{$M,1025,0,0} <-- I don't know what this means but you need anywaysππ Well, it's very important: it states how much Stack, Heap_Min, andπHeap_Max space you're reserving for the program to use (and howπmuch space you're leaving for the child process to execute in).πThe last (2nd 0) is the most important, since failing to reduceπthis from the default of ALL memory will PREVENT the Exec fromπhaving any memory to do its work within. So, setting it to 0πwill say "reserve ALL of available memory (except for what'sπused by my program itself) for the DOS call I'm going to makeπfrom within my program".π If you don't do this, it defaults to 640K - meaning "reserve NOπmemory for the exec".ππ AP>Program Copying;π AP>Uses dos;π AP>beginπ AP> exec ('Command.com','copy a:*.* b:');π Exec (GetEnv('COMSPEC'),'/C copy a:* b:*');π AP>end.π AP>Something like that. See the manual for Exec section.ππ You should also wrap that Exec call within a pair of SwapVectorsπstatements...before and after. Furthermore, it's a good idea toπcheck DosError and DosExitCode after the action, so see if anyπproblems occurred.π Exec is very useful, but it carries a lot of "baggage" when used...ππ--- msged 2.07π * Origin: Hello, Keyboard, my old friend... (1:114/18.10)π==============================================================================π BBS: «« The Information and Technology Exchanπ To: KEVIN HIGGINS Date: 01-04─92 (09:58)πFrom: MARK OUELLET Number: 4088 [101] PASCALπSubj: RE: HEAP KNOWLEDGE Status: Publicπ------------------------------------------------------------------------------π On 29 Dec 91, you, Kevin Higgins, of 1:128/74.0 wrote...ππ KH> I still don't understand full use of the {$M} compiler directive.π KH> The Pascal tome I have says nothing other than if you don't use New() orπ KH> GetMem() to set the HeapMin and HeapMax to 0. But it never says what toπ KH> set it to if you DO you New or GetMem. Nor could I find any reference onπ KH> ideal settings for a small program which Exec's another fairly smallπ KH> program....ππKevin,π New() and GetMem() are used to allocate spaceπ(memory) off the heap (That which is left of the 640 K ofπdos memory after your program is loaded and DOS and yourπTSRs ect...) for variables that are created AT RUNTIME.πVariables you declare in the usual way ie: Var X : Integer;πallready have space allocated to them.ππ The heap is used to allocate memory to dynamicπvariables ie: variables accessed through the use ofπpointers. These need to have memory allocated to themπ(Unless you are using the pointer to access a region ofπmemory that allready contains information such as theπkeyboard buffer etc... those allready have memory allocatedπto them so you need NO MORE MEMORY TO USE THEM.) Those thatπ*YOU* create such as linked lists need memory. Your programπwhen compiled will only allocate 4 bytes for each pointerπ(Pointers need 2 words, one for the segment, one for theπoffset in that segment) thus the 4 bytes.ππAs a rule of thumb, if you don't create dynamic variablesπthen you can set the $M to: {$M 16384, 0, 0} which is theπminimum.ππ{$MStack space, minimum heap required to run, Max heap needed}ππStack space is the memory needed to hold the stack of yourπprogram, each time you call a function or procedure fromπanother one, the old adress is pushed onto the stack, itπwill pulled off when the called procedure finishes to findπout where to go back and continue executing. Localπvariables, parameters are also saved on the stack so theyπare not lost or modified while the other procedure isπrunning.ππSo if you have recursive procedures (procedures that callπthemselfes) or use lots of parameters you could set a largeπstack. you will find this out through trial and error. If itπdoesn't run properly and halts with a *STACK OVERFLOW* errorπ(TP runtime error 202) then you know you need to increaseπthe stack space allocated to your program.ππThe second parameter is use IF you create dynamic variables,πit tells TP you need at least this much heap memory free toπrun correctly and that it should return to DOS with an errorπif at least that much is not free when you try to load yourπprogram.ππThe last paramater is the Maximum heap memory you expect toπuse, it can be calculated if you know how much you are goingπto use like a big array. If you are using linked lists,πwhich can not allways be evaluated as to how many items theπlist will contain, then you might decide to use it all.πSetting the 3rd parameter to 655360. This won't leave anyπroom to EXEC another program though.ππSo if you intend to run another program from yours, sayπrunning PKUNZIP from a TP program of yours, then you shouldπset Maximum Heap to a value lower than 655360. If you knowπPKUNZIP needs 55k to run without problems then you couldπsimply say:ππ 655360 - (55 * 1024) = 599040ππand set $M toππ{$M 16384, 0, 599040} this will ensure you have at least 55kπfree for PKUNZIP yet giving you the maximum heap space atπthe same time.ππAs allways if you don't use dynamic variables at all don'tπbother with it simply useππ{$M 16384, 0, 0} and you will allways have enough memory toπrun other programs from your TP programs (Unless you don'tπhave enough memory to run them from DOS to begin with ;-) )πππ Best regards,π and a very Happy New Yearπ Mark Ouellet.πππ--- ME2π * Origin: BaseBall for Windows, use the disks as bases ;-) (Fidonet 1:240/1.4)π==============================================================================π BBS: «« The Info-Tech BBS »»π To: SHANE RUSSO Date: 01-24─92 (15:00)πFrom: MIKE COPELAND Number: 5922 [101] $_PASCALπSubj: TP 6.0 -- MEMORY ALLOCATI Status: Publicπ------------------------------------------------------------------------------π SR> Could anyone inform me how to use the $M directive correctly, andπ SR> what it does exactly?ππ SR> Also, what the stack size, heap min and heap max are? (How do youπ SR> calculate the stack size, heap min and heap max)ππ There is no absolute, exact answer to this question, since every TPπprogram has different characteristics and requirements.πHowever, I will try to give you (and others) some basics, fromπwhich you can probably adjust and use as you learn what's rightπfor _you_ (every programmer has different styles, which alsoπaffect the way the $M is used):ππ {$M Stack,Heap_Min,Heap_Max}ππ The Stack is used within your program for calls to subprogramsπ(functions and procedures). Its size is dependent on (1) howπdeep your calls go (or recurse) and (2) how much parameter andπlocal data is referenced during these calls. The worst caseπI've encountered is a recursive sort of strings, where eachπlevel of call requires all the resident data of the routine andπthe parameters passed (string data being so big) are saved onπthe Stack - too many levels of such action will exceed the max.πavailable Stack value, 64K.π So, if you're not making heavily-nested (or recursive) calls in yourπprogram, you won't need much Stack space - 8192 is probably plenty.ππ Heap is data _you_ explicitly ask for (unlike the implicit data usedπby subprogram calls) - by New, GetMem (in TP), or by callingπlibrary routines which do (therefore, you're not always inπcontrol of this if you're using subroutine libraries you didn'tπcreate). The two parameters stated in the $M are for (1) theπminimum value you want to reserve and (2) the maximum you want to allow.π I don't know a good reason to ever use any value > 0 for theπHeap_Min parameter, since the runtime will allocate what'sπneeded (providing the Heap_Max still has something left) -πperhaps performance. So, it's the Heap_Max that's critical forπyour consideration.π I see 2 distinct things here, which are in conflict (and thusπrequire management of this parameter): dynamic memory use inπyour program, and use of the Exec procedure to spawn a childπprocess. If you don't ever do one of these things, then you haveπmaximum use of the other; it's that simple 8<}}.π However (!), doing this is not simple, if you're doing anythingπsophistocated with TP. For instance, if you must use data >64K,πyou've _got_ to use pointers - which implies dynamic memoryπallocation (and consumes the Heap. If, OTOH, you Exec to DOS toπrun other programs or DOS calls from within your program, youπmust leave sufficient memory for DOS to load that otherπprogram, etc. This, of course, depends on what you're Exec-ing.π In either case, your program logic and application must determineπhow much Heap_Max to reserve. The default is 640K (all ofπconventional memory), which prevents _any_ child processπExec-ing. This default will allow maximum possible use ofπdynamic memory (New, GetMem); any need to Exec will require aπreduced value for Heap_Max.π I often do a bit of both in my programs, and I typically use theπfollowing $M parameter:ππ {$M 8192,0,128000}ππand I change either Stack or Heap_Max as I encounter runtime errorsπduring development. Everyone must do the same, for the reasonsπI stated above.π Note that you _won't_ be able to play with this during developmentπin the IDE, since that's a program already consuming a LOT ofπavailable memory.π Hope I made some sense/cleared up some confusion/helped.πππ--- msged 2.07π * Origin: Hello, Keyboard, my old friend... (1:114/18.10)πππ------------------------------------------------------------------------ππEcho Flag : Permanent: N Export: N Personal Read: Nππ BBS: IN-TECH Conference: PASCAL Imported: 11/11/1991π To: ZAK SMITH Num: 1295 Date: 11/03/1991πFrom: TREVOR CARLSEN Re: 0 Time: 1:58 amπSubj: >NUL REDIRECTION Prvt: N Read: Nππ ZS> Change that toπ ZS> EXEC ('C:\COMMAND.COM','c:\pkzip.exe -o ..... >nul');ππI'd reckon that will not work on a majority of systems. Better is ...ππ exec(GetEnv('COMSPEC'),'c:\pkzip...etc');ππThat way it is not command.com specific.ππTeeCeeππ--- TC-ED v2.01 π * Origin: The Pilbara's Pascal Centre (+61 91 732569) (3:690/644)π π 8 06-08-9308:25ALL BRENDEN WALKER Kill DIR Routine IMPORT 13 ┤φàÜ (*π===========================================================================π BBS: The Beta ConnectionπDate: 06-05-93 (12:54) Number: 67πFrom: BRENDEN WALKER Refer#: NONEπ To: WAYNE DOYLE Recvd: NOπSubj: DIR. SEARCH Conf: (321) Pascal___Uπ---------------------------------------------------------------------------π WD│ Hi Everyone,π │ I'm interested in finding out how to have the computer search andπ │ find all of the available directories on a disk. I have a program whichπ │ deletes all of *.BAK files on a disk and I'd like to know how it findsπ │ all of the directories.ππ The below example code, will kill a directory and all of it'sπsub-directories. This could be modified to delete all of the .BAK files inπall directories on the hard-drive.ππ Of course, this may not help much, but I rarely use pseudo-code.π*)ππprocedure Kill_Dir(p : pathstr);πvar Od, Rd : pathstr;π Sr : SearchRec;π t : file;ππbeginπ getdir(0,Od);π ChDir(p);π if length(p) > 4 then p := p + '\';π FindFirst('*.*', anyfile, Sr);π while DosError = 0 doπ beginπ temp := p + Sr.Name;π if (Sr.Attr and Directory > 0) thenπ beginπ if (Sr.Name <> '.') and (Sr.Name <> '..') thenπ beginπ Rd := temp;π Kill_Dir(temp);π RmDir(Rd);π end;π endπ elseπ beginπ assign(t,sr.name);π erase(t);π end;π FindNext(Sr);π end;π ChDir(Od);πend;π 9 06-08-9308:26ALL ANDRES CVITKOVICH National Language SupportIMPORT 32 ┤φ▀/ {─ Fido Pascal Conference ────────────────────────────────────────────── PASCAL ─πMsg : 493 of 505πFrom : Andres Cvitkovich 2:310/36.9 28 Apr 93 22:59πTo : Jon Leosson 2:391/20.0πSubj : Reading the country infoπ────────────────────────────────────────────────────────────────────────────────πHi Jon,ππWednesday, April 14 1993, Jon Leosson wrote to All:ππ JL> Does anybody know how one can read the country info which is set byπ JL> COUNTRY.SYS in DOS 4.0 and 5.0? Any help would be appreciated...ππor DOS 6.0 or DOS 3.x or ... ;-)ππhere we go:ππ---------------------------------------------------------------}πUnit NLS;ππ{ NLS.PAS - National Language Support }π{ ─────────────────────────────────── }π{ (W) Written 1992 by A. Cvitkovich }ππINTERFACEππCONSTπ DATE_USA = 0;π DATE_EUROPE = 1;π DATE_JAPAN = 2;π TIME_12HOUR = 0;π TIME_24HOUR = 1;ππTYPEπ CountryInfo = Recordπ ciDateFormat : Word;π ciCurrency : Array [1..5] Of Char;π ciThousands : Char;π ciASCIIZ_1 : Byte;π ciDecimal : Char;π ciASCIIZ_2 : Byte;π ciDateSep : Char;π ciASCIIZ_3 : Byte;π ciTimeSep : Char;π ciASCIIZ_4 : Byte;π ciBitField : Byte;π ciCurrencyPlaces: Byte;π ciTimeFormat : Byte;π ciCaseMap : Procedure;π ciDataSep : Char;π ciASCIIZ_5 : Byte;π ciReserved : Array [1..10] Of Byteπ End;ππ DateString = String [10];π TimeString = String [10];ππVAR Country : CountryInfo;πππFUNCTION GetCountryInfo (Buf: Pointer): Boolean;πFUNCTION DateStr: DateString;πFUNCTION TimeStr: TimeString;πππIMPLEMENTATIONππUSES Dos;ππFUNCTION GetCountryInfo (Buf: Pointer): Boolean; Assembler;πAsmπ mov ax, 3800hπ push dsπ lds dx, Bufπ int 21hπ mov al, TRUEπ jnc @@1π xor al, alπ@@1:π pop dsπEnd;ππFUNCTION DateStr: DateString;πVAR Year, Month, Day, Weekday : Word;π dd, mm : String[2];π yy : String[4];πBEGINπ GetDate (Year, Month, Day, WeekDay);π Str (Day:2, dd); If dd[1] = ' ' Then dd[1] := '0';π Str (Month:2, mm); If mm[1] = ' ' Then mm[1] := '0';π Str (Year:4, yy);π Case Country.ciDateFormat Ofπ DATE_USA: DateStr := mm + Country.ciDateSep + dd +π Country.ciDateSep + yy;π DATE_EUROPE: DateStr := dd + Country.ciDateSep + mm +π Country.ciDateSep + yy;π DATE_JAPAN: DateStr := yy + Country.ciDateSep + mm +π Country.ciDateSep + dd;π Else DateStr := ''π End;πEND;πππFUNCTION TimeStr: TimeString;πVAR Hour, Min, Sec, Sec100 : Word;π hh, mm, ss : String[2];π ampm : Char;πBEGINπ GetTime (Hour, Min, Sec, Sec100);π Str (Min:2, mm); If mm[1] = ' ' Then mm[1] := '0';π Str (Sec:2, ss); If ss[1] = ' ' Then ss[1] := '0';π Case Country.ciTimeFormat Ofπ TIME_12HOUR: Beginπ If Hour < 12 Then ampm := 'a' Else ampm := 'p';π Hour := Hour MOD 12;π If Hour = 0 Then Hour := 12; Str (Hour:2, hh);π TimeStr := hh + Country.ciTimeSep + mm +π Country.ciTimeSep + ss + ampm + 'm'π End;π TIME_24HOUR: Beginπ Str (Hour:2, hh);π TimeStr := hh + Country.ciTimeSep + mm +π Country.ciTimeSep + ssπ End;π Else TimeStr := ''π End;πEND;πππBEGINπ If Not GetCountryInfo (@Country) Then Beginπ Country.ciDateFormat := DATE_USA;π Country.ciDateSep := '-';π Country.ciTimeFormat := TIME_12HOUR;π Country.ciTimeSep := ':';π End;πEND. 10 06-22-9307:51ALL GREG ESTABROOKS Reboot System Warm/Cold IMPORT 24 ┤φQc ===========================================================================π BBS: Canada Remote SystemsπDate: 06-15-93 (11:09) Number: 8831πFrom: GREG ESTABROOKS Refer#: NONEπ To: KURT TAN Recvd: NO πSubj: REBOOT Conf: (58) PASCALπ---------------------------------------------------------------------------πKT>Can anybody tell me how to reboot with Turbo Pascal?ππ Below are the routines I use to reboot the system.π Hope they help ya.ππ{********************************************************************}πPROGRAM RebootSys; { June 15/93, Greg Estabrooks }πUSES CRT; { Writeln,Readkey,Clrscr }πVARπ CH :CHAR; { Hold Boot Choice }ππPROCEDURE WarmBoot;π { Routine to cause system to do a WARM Boot }πππBEGINπ Inline(π $FB/ { STI }π $B8/00/00/ { MOV AX,0000 }π $8E/$D8/ { MOV DS,AX }π $B8/$34/$12/ { MOV AX,1234 }π $A3/$72/$04/ { MOV [0472],AX }π $EA/$00/$00/$FF/$FF); { JMP FFFF:0000 }πEND;ππPROCEDURE ColdBoot;π { Routine to cause system to do a COLD Boot }πBEGINπ Inline(π $FB/ { STI }π $B8/01/00/ { MOV AX,0001 }π $8E/$D8/ { MOV DS,AX }π $B8/$34/$12/ { MOV AX,1234 }π $A3/$72/$04/ { MOV [0472],AX }π $EA/$00/$00/$FF/$FF); { JMP FFFF:0000 }πEND;ππBEGINπ Clrscr; { Clear the screen }π { Ask for which type of boot to be used }π Writeln('Would You like to do a [W]arm or [C]old Boot? ');π CH := Readkey; { Get Users Choice, }ππ CASE UpCase( CH ) OFπ 'W' : BEGINπ Writeln('Doing a Warm Boot ');π WarmBoot; { Call warm Reboot procedure }π END;π 'C' : BEGINπ Writeln('Doing a Cold Boot ');π ColdBoot; { Call cold reboot procedure }π END;π Else { Else don't reboot at all }π Writeln('Not Rebooting!');π END;πEND.π{***********************************************************************}ππGreg Estabrooks <<Message Entered on 06-15-93 at 09am>>π---π ■ OLX 2.1 TD ■ Beer. It's not just for breakfast anymore!π ■ RoseMail 2.10ß: NANET: VE1EI BBS, Halifax NS, (902)-868-2475π 11 06-22-9309:12ALL GREG VIGNEAULT Another Warm/Cold BOOT IMPORT 19 ┤φQc ===========================================================================π BBS: Canada Remote SystemsπDate: 06-17-93 (20:44) Number: 8849πFrom: GREG VIGNEAULT Refer#: NONEπ To: KURT TAN Recvd: NO πSubj: WARM & COLD TP REBOOT... Conf: (58) PASCALπ---------------------------------------------------------------------------πKT> Can anybody tell me how to reboot with Turbo Pascal?ππ Hi Kurt,ππ You may find that using interrupt $19 doesn't work on many systems.ππ The following cold and warm boot procedures should work under mostπ PC/MS-DOS environments. It doesn't use either ASM or INLINE ...ππ(*******************************************************************)πPROGRAM DemoReboot; { force a Cold or Warm Reboot }ππUSES Crt, { import ClrScr, ReadKey }π Dos; { import Intr(), Registers }ππPROCEDURE Reboot; { <- only call from Cold & WarmBoot }π VAR dummy : Registers; { Intr() needs Register TYPE }π BEGINπ MemW[0:0] := 0; { modify an interrupt vector (eg.0) }π MemW[0:2] := $FFFF; { to point to $FFFF:$0000 }π Intr(0,dummy); { and force a call to it }π END {Reboot};ππPROCEDURE ColdBoot; { like a system power-up or reset }π BEGINπ MemW[0:$472] := $7F7F; { tell the system it's a Cold boot }π Reboot; { ...we don't return from here }π END {ColdBoot};ππPROCEDURE WarmBoot; { same as Ctrl-Alt-Del reboot }π BEGINπ MemW[0:$472] := $1234; { tell the system it's a Warm boot }π Reboot; { ...bye-bye }π END {WarmBoot};ππBEGINπ ClrScr;π Write('Do you want a Warm or Cold reboot (W/C) ? ');π IF UpCase(ReadKey) = 'W' THEN WarmBoot ELSE ColdBoot;ππEND {DemoReboot}.π(*******************************************************************)πππ Greg_ππ Jun.17.1993.Toronto UUCP greg.vigneault@bville.gts.org FIDO 1:250/304π---π ■ RoseMail 2.10ß: NANET 41-62-24 Baudeville -Toronto ON - 416-283-0114π 12 06-22-9309:23ALL LARS HELLSTEN Dealing with File Share IMPORT 29 ┤φQc ===========================================================================π BBS: Canada Remote SystemsπDate: 06-16-93 (16:14) Number: 26531πFrom: LARS HELLSTEN Refer#: NONEπ To: RITO SALOMONE Recvd: NO πSubj: Re: Novell/File Locking/S Conf: (1221) F-PASCALπ---------------------------------------------------------------------------πRS> Does anyone have any samples of network file sharing/access code for TurboπRS> Pascal/Borland Pascal 6-7.ππ Here's some source that I use. I haven't had a chance to test it outπas much as I'd like to, but so far, it appears to work quite nicely:ππ--- 8< --------------------------------------------------------------------πUnit Share;ππINTERFACEππUses DOS;ππVarπ ShareInstalled : Boolean;ππFunction LockRec(Var Untyped; pos, size : LongInt) : Boolean;πFunction UnLockRec(Var Untyped; pos, size : LongInt) : Boolean;πProcedure FMode(Mode : Byte);πFunction Share : Boolean;ππIMPLEMENTATIONππFunction LockRec(Var Untyped; pos, size : LongInt) : Boolean;ππVarπ Regs : Registers;π f : File absolute Untyped;ππBeginπ pos := pos * FileRec(f).RecSize;π size := size * FileRec(f).RecSize;π Regs.AH := $5C;π Regs.AL := $00;π Regs.BX := FileRec(f).Handle;π Regs.CX := Hi(pos);π Regs.DX := Lo(pos);π Regs.SI := Hi(size);π Regs.DI := Lo(size);π Intr($21,Regs);π LockRec := (Regs.Flags AND FCarry) = 0;πEnd; { LockRec }ππFunction UnLockRec(Var Untyped; pos, size : LongInt) : Boolean;ππVarπ Regs : Registers;π f : File absolute Untyped;ππBeginπ pos := pos * FileRec(f).RecSize;π size := size * FileRec(f).RecSize;π Regs.AH := $5C;π Regs.AL := $01;π Regs.BX := FileRec(f).Handle;π Regs.CX := Hi(pos);π Regs.DX := Lo(pos);π Regs.SI := Hi(size);π Regs.DI := Lo(size);π Intr($21,Regs);π UnlockRec := (Regs.Flags AND FCarry) = 0;πEnd; { UnLockRec }ππProcedure FMode(Mode : Byte);ππBeginπ If ShareInstalled thenπ If (mode in [0..2,23..24,48..50,64..66]) thenπ FileMode := Mode;πEnd;ππfunction Share : boolean;πvar regs : registers;πbeginπ with regs doπ beginπ AH := 16;π AL := 0;π Intr($2f, regs);π Share := AL = 255;π end;πend; { IsShare }ππBeginπ ShareInstalled := Share;πEnd. { MyShare }π--- 8< ---------------------------------------------------------------------ππ By the way, the unit name should be "MyShare", there's duplicateπidentifiers in there by accident. All you do, is call the lock/unlockπroutines, passing the file variable, the record number, and the number ofπrecords (you'll see it determines the size itself, using the FileRec.RecSizeπvariable). The FMode procedure doesn't do much, I just use it instead ofπconstantly putting "If ShareInstalled then FileMode :=..." inside theπprogram(s). You should call this to set the FileMode variable to a sharingπmethod, before you reset the file. Here's a table of values you can pass:ππ Sharing MethodπAccess Method Compatibility Deny Write Deny Read Deny Noneπ-------------------------------------------------------------------πRead Only 0 32 48 64πWrite Only 1 33 49 65πRead/Write 2 34 50 66π-------------------------------------------------------------------ππ--- GEcho 1.00π * Origin: Access-PC BBS ■ Scarborough, ON ■ (416)491-9249 (1:250/320)π 13 07-16-9306:09ALL ROB GREEN DOS ICA Put/Get Routine IMPORT 24 ┤φQc ===========================================================================π BBS: Canada Remote SystemsπDate: 06-30-93 (07:05) Number: 28694πFrom: ROB GREEN Refer#: NONEπ To: RAND NOWELL Recvd: NO πSubj: CODE FOR PROGRAM Conf: (1221) F-PASCALπ---------------------------------------------------------------------------π > Another way would be to, upon program startup, is create anπ > enviornment var refering to your program. Say the program isπ > RR.EXE, create a var as Set RR = INSTALLED! then when youπ > shell, search the enviornment for RR, if it equals INSTALLED!π > then present message, if the RR var not exists, then load theπ > program. Of course when the program quits you want to seet RR =π > (nothing).....ππHeres the way i do it...ππunit AmLoaded;ππinterfaceππtypeπ ICAType = recordπ Stext : string[13];π chksum: integer;π end;ππvarπ ica : icaType absolute $0000:$04f0;ππProcedure PutICA(sText:string);ππprocedure GetIca(var stext:string);ππfunction IcaSame(Stext:string):boolean;πππimplementationππProcedure PutICA(sText:string);πvarπ j:byte;πBeginπ fillchar(ica.stext,sizeof(ica.stext),0);π ica.stext:=copy(stext,1,13);π ica.stext[0]:=#13;π Ica.ChkSum:=0;π for j:=0 to 13 doπ Ica.ChkSum:=Ica.ChkSum+ord(ica.stext[j]);πEnd;πππProcedure GetIca(var stext:string);πBeginπ stext:=ica.stext;πEnd;ππfunction IcaSame:boolean;πvarπ j:byte;π k,m:integer;πbeginπ k:=0;π m:=0;π for j:=0 to 13 doπ Beginπ k:=k+ord(ica.stext[j]);π m:=m+ord(stext[j]);π end;π if k=m thenπ Beginπ if ica.chksum=m thenπ IcaSame:=trueπ elseπ IcaSame:=False;π endπ elseπ icasame:=false;πend;ππend.π-----------------------πTest program:ππuses AmLoaded;πBeginπ PutIca('ATEST');π Writeln('ATEST, should come back as same');π {Check to see if we can read it back without changing anything}π If IcaSame('ATEST') thenπ writeln('Same')π elseπ writeln('Not Same');π PutICA('Another Test');π Writeln('Another Test, should come back as not same');π {Change the lower case 'h' into an uppercase 'H'}π Ica.Stext[5]:='H';π If IcaSame('Another Test') thenπ writeln('Same')π elseπ writeln('Not same');π PutIca('hello world');π writeln('Hello world, should come back as not same');π {Change the chksum}π ica.chksum:=111;π If IcaSame('hello world'); thenπ writeln('Same')π elseπ writeln('Not same');πEnd.π-------------------------------------------ππBefore doing EXEC do this:πPutICA('Program name'); {up to 13 chars}πEXEC(getenv('COMSPEC'),'Whatever');πPutIca(' '); {Or null}ππThen when starting your program do this:πIf ICASame('Program name') thenπ writeln('Can''t load Program name on top of itself');πππRobππ--- FMail 0.94π * Origin: The Rush Room - We OWN Orlando - (407) 678 & 0749 (1:363/166)π 14 07-17-9307:28ALL GAYLE DAVIS DOS Critical Errors IMPORT 76 ┤φ7° {$S-,R-,V-,I-,N-,B-,F-}ππ{$IFNDEF Ver40}π {Allow overlays}π {$F+,O-,X+,A-}π{$ENDIF}ππUNIT CritErr;ππINTERFACEππUSES DOS;ππTYPEπ Str10 = STRING[10];π IOErrorRec = Recordπ RoutineName : PathStr;π ErrorAddr : Str10;π ErrorType : Str10;π TurboResult : Word; { TP Error number }π IOResult : Word; { DOS Extended number }π ErrMsg : PathStr;π End;πππ{}PROCEDURE IOResultTOErrorMessage (IOCode : WORD; VAR MSG : STRING);π{}PROCEDURE GetDOSErrorMessage (VAR Msg : STRING);π{}FUNCTION UserIOError(ErrNum : INTEGER; VAR IOErr : IOErrorRec) : BOOLEAN;π{}PROCEDURE CriticalErrorDOS;π{}PROCEDURE CriticalErrorTP;π{}PROCEDURE CriticalErrorOwn(ErrAddr: POINTER);ππIMPLEMENTATIONππVARπ TurboInt24: POINTER; { Holds address of TP's error handler }ππ function Hex(v: Longint; w: Integer): String;π varπ s : String;π i : Integer;π constπ hexc : array [0 .. 15] of Char= '0123456789abcdef';π beginπ s[0] := Chr(w);π for i := w downto 1 do beginπ s[i] := hexc[v and $F];π v := v shr 4π end;π Hex := s;π end {Hex};πππPROCEDURE CriticalErrorDOS;ππ BEGINπ SetIntVec($24,SaveInt24);π END;ππππPROCEDURE CriticalErrorTP;ππ BEGINπ SetIntVec($24,TurboInt24);π END;ππππPROCEDURE CriticalErrorOwn(ErrAddr: POINTER);ππ BEGINπ SetIntVec($24,ErrAddr);π END;ππππPROCEDURE GetDOSErrorMessage (VAR Msg : STRING);ππTYPE pointerwords =π RECORDπ ofspoint, segpoint : WORD;π END;ππVARπ breakdown : pointerwords ABSOLUTE erroraddr;ππBEGINπIOResultToErrorMessage (ExitCode, MSG);π WITH breakdown DOπ Msg := Msg + ' $' + hex (SegPoint, 4) + ':' + hex (OfsPoint, 4);πEND; {Exitprogram}ππPROCEDURE IOResultToErrorMessage (IOCode : WORD; VAR MSG : STRING);πBEGINπ CASE IOCode OFπ $01 : msg := 'Invalid DOS Function Number';π $02 : msg := 'File not found ';π $03 : msg := 'Path not found ';π $04 : msg := 'Too many open files ';π $05 : msg := 'File access denied ';π $06 : msg := 'Invalid file handle ';π $07 : msg := 'Memory Control Block Destroyed';π $08 : msg := 'Not Enough Memory';π $09 : msg := 'Invalid Memory Block Address';π $0A : msg := 'Environment Scrambled';π $0B : msg := 'Bad Program EXE File';π $0C : msg := 'Invalid file access mode';π $0D : msg := 'Invalid Data';π $0E : msg := 'Unknown Unit';π $0F : msg := 'Invalid drive number ';π $10 : msg := 'Cannot remove current directory';π $11 : msg := 'Cannot rename across drives';π $12 : msg := 'Disk Read/Write Error';π $13 : msg := 'Disk Write-Protected';π $14 : msg := 'Unknown Unit';π $15 : msg := 'Drive Not Ready';π $16 : msg := 'Unknown Command';π $17 : msg := 'Data CRC Error';π $18 : msg := 'Bad Request Structure Length';π $19 : msg := 'Seek Error';π $1A : msg := 'Unknown Media Type';π $1B : msg := 'Sector Not Found';π $1C : msg := 'Printer Out Of Paper';π $1D : msg := 'Disk Write Error';π $1E : msg := 'Disk Read Error';π $1F : msg := 'General Failure';π $20 : msg := 'Sharing Violation';π $21 : msg := 'Lock Violation';π $22 : msg := 'Invalid Disk Change';π $23 : msg := 'File Control Block Gone';π $24 : msg := 'Sharing Buffer Exceeded';π $32 : msg := 'Unsupported Network Request';π $33 : msg := 'Remote Machine Not Listening';π $34 : msg := 'Duplicate Network Name';π $35 : msg := 'Network Name NOT Found';π $36 : msg := 'Network BUSY';π $37 : msg := 'Device No Longer Exists On NETWORK';π $38 : msg := 'NetBIOS Command Limit Exceeded';π $39 : msg := 'Adapter Hardware ERROR';π $3A : msg := 'Incorrect Response From NETWORK';π $3B : msg := 'Unexpected NETWORK Error';π $3C : msg := 'Remote Adapter Incompatible';π $3D : msg := 'Print QUEUE FULL';π $3E : msg := 'No space For Print File';π $3F : msg := 'Print File Cancelled';π $40 : msg := 'Network Name Deleted';π $41 : msg := 'Network Access Denied';π $42 : msg := 'Incorrect Network Device Type';π $43 : msg := 'Network Name Not Found';π $44 : msg := 'Network Name Limit Exceeded';π $45 : msg := 'NetBIOS session limit exceeded';π $46 : msg := 'Filer Sharing temporarily paused';π $47 : msg := 'Network Request Not Accepted';π $48 : msg := 'Print or Disk File Paused';π $50 : msg := 'File Already Exists';π $52 : msg := 'Cannot Make Directory';π $53 : msg := 'Fail On Critical Error';π $54 : msg := 'Too Many Redirections';π $55 : msg := 'Duplicate Redirection';π $56 : msg := 'Invalid Password';π $57 : msg := 'Invalid Parameter';π $58 : msg := 'Network Device Fault';π $59 : msg := 'Function Not Supported By NETWORK';π $5A : msg := 'Required Component NOT Installed';ππ (* Pascal Errors *)π 94 : msg := 'EMS Memory Swap Error';π 98 : msg := 'Disk Full';π 100 : msg := 'Disk read error ';π 101 : msg := 'Disk write error ';π 102 : msg := 'File not assigned ';π 103 : msg := 'File not open ';π 104 : msg := 'File not open for input ';π 105 : msg := 'File not open for output ';π 106 : msg := 'Invalid numeric format ';π 150 : msg := 'Disk is write_protected';π 151 : msg := 'Unknown unit';π 152 : msg := 'Drive not ready';π 153 : msg := 'Unknown command';π 154 : msg := 'CRC error in data';π 155 : msg := 'Bad drive request structure length';π 156 : msg := 'Disk seek error';π 157 : msg := 'Unknown media type';π 158 : msg := 'Sector not found';π 159 : msg := 'Printer out of paper';π 160 : msg := 'Device write fault';π 161 : msg := 'Device read fault';π 162 : msg := 'Hardware Failure';π 163 : msg := 'Sharing Confilct';π 200 : msg := 'Division by zero ';π 201 : msg := 'Range check error ';π 202 : msg := 'Stack overflow error ';π 203 : msg := 'Heap overflow error ';π 204 : msg := 'Invalid pointer operation ';π 205 : msg := 'Floating point overflow ';π 206 : msg := 'Floating point underflow ';π 207 : msg := 'Invalid floating point operation ';π 390 : msg := 'Serial Port TIMEOUT';π 399 : msg := 'Serial Port NOT Responding';ππ 1008 : Msg := 'EMS Memory Swap Error 'π ELSEπ GetDosErrorMessage (Msg);π END;πEND;πππFUNCTION UserIOError(ErrNum : INTEGER; VAR IOErr : IOErrorRec) : BOOLEAN;π{ RETURN ALL INFO ABOUT THE ERROR IF IT OCCURED}πCONSTπ ErrTitles : ARRAY [1..5] OF STRING [10] =π ('System', 'Disk', 'Network', 'Serial', 'Memory');ππVARπ Msg : STRING;π Regs : REGISTERS;ππ BEGINππ UserIOError := FALSE;π FILLCHAR(IOErr,SizeOf(IOErr),#0);π IF ErrNum <=0 THEN EXIT;ππ { GET DOS Extended Error }π WITH Regs DOπ BEGINπ AH := $59;π BX := $00;π MSDOS (Regs);π END;ππ IOResultToErrorMessage (Regs.AX, Msg);ππ IOErr.RoutineName := PARAMSTR (0);π IOErr.ErrorAddr := Hex (SEG (ErrorAddr^), 4) + ':' + Hex (OFS (ErrorAddr^), 4);π IOErr.ErrorType := ErrTitles[Regs.CH];π IOErr.TurboResult := ErrNum;π IOErr.IOResult := Regs.AX;π IOErr.ErrMsg := Msg;ππ UserIOError := (ErrNum > 0);π END;ππBEGINπ GetIntVec($24,TurboInt24);π CriticalErrorDOS;πEND.ππ{ -------------------------- DEMO --------------------- }ππ{ EXAMPLE FOR CRITICAL ERROR HANDLER UNIT }π{ COMPILE AND RUN FROM DOS !!! WILL NOT WORK PROPERLY FROM THE IDE }π{$I-} { A MUST FOR THE CRITICAL HANDLER TO WORK !!!! }ππUSESπ CRT, CRITERR;ππVARπ f: TEXT;π i: INTEGER;π ErrMsg : STRING;π IOErr : IOErrorRec;ππBEGINπ ClrScr;π WriteLn(' EXAMPLE PROGRAM FOR CRITICAL ERROR HANDLER ');π WriteLn;π WriteLn('Turbo Pascal replaces the operating system''s critical-error');π WriteLn('handler with its own. For this demonstration we will generate');π WriteLn('a critical error by attempting to access a diskette that is not');π WriteLn('present. Please ensure that no diskette is in drive A, then');π WriteLn('press RETURN...');π ReadLn;π CriticalErrorTP;π Assign(f,'A:NOFILE.$$$');π WriteLn;π WriteLn('Now attempting to access drive...');π Reset(f);π IF UserIOError(IOResult,IOErr) THENπ BEGINπ WriteLn(IOErr.RoutineName);π WriteLn(IOErr.ErrorAddr);π WriteLn(IOErr.ErrorType);π WriteLn(IOErr.TurboResult);π WriteLn(IOErr.IOResult);π WriteLn(IOErr.ErrMsg);π END;π WriteLn;π Write('Press RETURN to continue...');π ReadLn;π WriteLn;π CriticalErrorDOS;π WriteLn('With the DOS error handler restored, you will be presented');π WriteLn('with the usual "Abort, Retry, Ignore?" prompt when such an');π WriteLn('error occurs. (Later DOS versions allow a "Fail" option.)');π WriteLn('Run this program several times and try different responses.');π Write('Press RETURN to continue...');π ReadLn;π WriteLn('Now attempting to access drive again...');π Reset(f);π IF UserIOError(IOResult,IOErr) THENπ BEGINπ WriteLn(IOErr.RoutineName);π WriteLn(IOErr.ErrorAddr);π WriteLn(IOErr.ErrorType);π WriteLn(IOErr.TurboResult);π WriteLn(IOErr.IOResult);π WriteLn(IOErr.ErrMsg);π END;π Readkey;πEND.ππ 15 08-17-9308:41ALL SWAG SUPPORT TEAM Demostrates EXEC Proc IMPORT 18 ┤φd± {$M 8192,0,0}π{* This memory directive is used to makeπ certain there is enough memory leftπ to execute the DOS shell and anyπ other programs needed. *}ππProgram EXEC_Demo;ππ{*ππ EXEC.PASππ This program demonstrates the use ofπ Pascal's EXEC function to executeπ either an individual DOS command orπ to move into a DOS Shell.ππ You may enter any command you couldπ normally enter at a DOS prompt andπ it will execute. You may also hitπ RETURN without entering anything andπ you will enter into a DOS Shell, fromπ which you can exit by typing EXIT.ππ The program stops when you hit aπ 'Q', upper or lower case.π*}πππUses Crt, Dos;ππVarπ Command : String;ππ{**************************************}πProcedure Do_Exec; {*******************}ππ Varπ Ch : Char;ππ Beginπ If Command <> '' Thenπ Command := '/C' + Commandπ Elseπ Writeln('Type EXIT to return from the DOS Shell.');π {* The /C prefix is needed toπ execute any command other thanπ the complete DOS Shell. *}ππ SwapVectors;π Exec(GetEnv('COMSPEC'), Command);π {* GetEnv is used to read COMSPECπ from the DOS environment so theπ program knows the correct pathπ to COMMAND.COM. *}ππ SwapVectors;π Writeln;π Writeln('DOS Error = ',DosError);π If DosError <> 0 Thenπ Writeln('Could not execute COMMAND.COM');π {* We're assuming that the onlyπ reason DosError would be somethingπ other than 0 is if it couldn'tπ find the COMMAND.COM, but thereπ are other errors that can occur,π we just haven't provided for themπ here. *}ππ Writeln;π Writeln;π Writeln('Hit any key to continue...');π Ch := ReadKey;π End;πππFunction Get_Command : String;ππ Varπ Count : Integer;π Cmnd : String;ππ Beginπ Clrscr;π Write('Enter DOS Command (or Q to Quit): ');π Readln(Cmnd);π Get_Command := Cmndπ End;ππBeginπ Command := Get_Command;π While NOT ((Command = 'Q') OR (Command = 'q')) Doπ Beginπ Do_Exec;π Command := Get_Commandπ End;πEnd. 16 08-18-9312:22ALL JOSE ALMEIDA Get the program Name IMPORT 10 ┤φπ? { Gets the program name.π 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 Get_Prg_Name : String8;ππ{ DESCRIPTION:π Gets the program name.π SAMPLE CALL:π St := Get_Prg_Name;π RETURNS:π The program name, e.g., '12345678'π or '$$$$$$$$' if not available.π NOTES:π This function excludes the .EXE extension of the program. }ππvarπ St : string;π F : byte;π Found : boolean;ππBEGIN { Get_Prg_Name }π St := ParamStr(0);π Found := No;π F := Length(St);π while (F > 0) and (not Found) doπ beginπ if St[F] = '\' thenπ Found := Yesπ elseπ Dec(F);π end;π St := Copy(St,Succ(F),255);π F:= Pos('.',St);π Delete(St,F,255);π if St = '' thenπ St := '$$$$$$$$';π Get_Prg_Name := St;πEND; { Get_Prg_Name }π 17 08-18-9312:30ALL JOSE ALMEIDA Get the Country Code IMPORT 25 ┤φ╗ { Gets the current country code number.π Part of the Heartware Toolkit v2.00 (HTelse.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_Country_Code(var CC : word;π var Error_Code : byte);π{ DESCRIPTION:π Gets the current country code number.π SAMPLE CALL:π Get_Country_Code(CC,Error_Code);π RETURNS:π CC : country code numberπ or $FFFF if Error_Code <> 0π Error_Code : see The Programmers PC Source Book 3.191π NOTES:π None. }ππvarπ TmpA : array[1..34] of byte;π HTregs : registers;ππBEGIN { Get_Country_Code }π FillChar(TmpA,SizeOf(TmpA),0);π HTregs.AX := $3800;π HTregs.DX := Ofs(TmpA);π HTregs.DS := Seg(TmpA);π MsDos(HTregs);π if HTregs.Flags and FCarry <> 0 thenπ beginπ CC := $FFFF; { on error set to $FFFF }π Error_Code := HTregs.AL;π endπ elseπ beginπ CC := HTregs.BX;π Error_Code := 0;π end;πEND; { Get_Country_Code }ππππFUNCTION Get_Country_Code_Text(CC : word) : String25;ππ{ DESCRIPTION:π Gets country code in string format.π SAMPLE CALL:π St := Get_Country_Code_Text(CC);π RETURNS:π Country code name.π NOTES:π None. }ππBEGIN { Get_Country_Code_Text }π case CC ofπ 001 : Get_Country_Code_Text := 'United States';π 002 : Get_Country_Code_Text := 'Canada (French)';π 003 : Get_Country_Code_Text := 'Latin America';π 031 : Get_Country_Code_Text := 'Netherlands';π 032 : Get_Country_Code_Text := 'Belgium';π 033 : Get_Country_Code_Text := 'France';π 034 : Get_Country_Code_Text := 'Spain';π 036 : Get_Country_Code_Text := 'Hungary';π 038 : Get_Country_Code_Text := 'Yugoslavia';π 039 : Get_Country_Code_Text := 'Italy';π 041 : Get_Country_Code_Text := 'Switzerland';π 042 : Get_Country_Code_Text := 'Czechoslovakia';π 044 : Get_Country_Code_Text := 'United Kingdom';π 045 : Get_Country_Code_Text := 'Denmark';π 046 : Get_Country_Code_Text := 'Sweden';π 047 : Get_Country_Code_Text := 'Norway';π 048 : Get_Country_Code_Text := 'Poland';π 049 : Get_Country_Code_Text := 'Germany';π 055 : Get_Country_Code_Text := 'Brazil';π 061 : Get_Country_Code_Text := 'International English';π 081 : Get_Country_Code_Text := 'Japan';π 082 : Get_Country_Code_Text := 'Korea';π 086 : Get_Country_Code_Text := 'Peoples Republic of China';π 088 : Get_Country_Code_Text := 'Taiwan';π 351 : Get_Country_Code_Text := 'Portugal';π 358 : Get_Country_Code_Text := 'Finland';π 785 : Get_Country_Code_Text := 'Middle East (Arabic)';π 972 : Get_Country_Code_Text := 'Israel (Hebrew)';π elseπ Get_Country_Code_Text := 'Unknown';π end;πEND; { Get_Country_Code_Text }π 18 08-27-9320:13ALL SEAN PALMER Batch Error Level IMPORT 7 ┤φè {πSEAN PALMERππ> How would I use this Variable after I Exit the pascal Program??ππYou wouldn't. It won't work. What you COULD do though is to have it return anπerrorlevel to Dos if you cancel...π}ππProgram ruSure;πUsesπ Crt;ππProcedure yes;πbeginπ TextAttr := 12;π Writeln('Okay.'); {no error here}πend;ππProcedure no;πbeginπ TextAttr := 26;π Writeln('Aborted.');π halt(1); {report an error to Dos}πend;ππbeginπ TextAttr := 13;π Write('Do you wish to continue? [Y/N]');π Case upcase(ReadKey) ofπ 'Y' : yes;π 'N' : no;π end;πend.π{ππ Now the batch file :ππrusureπREM check For an error from the Programπif errorlevel 1 Goto NOPEπgoto EXITπ:NOPEπcd ..πetc.π 19 08-27-9320:14ALL LARS FOSDAL Self-modifying Batch FileIMPORT 34 ┤φ# LARS FOSDALππ> Hi all. I've got a little Program that brings up a Window and severalπ> buttons in TP 7. The buttons have the names of Various batch Files on themπ> which are executed when they are pressed. The batch Files start up Variousπ> other Programs. This launchpad requires about 100K of RAM as currentlyπ> written, and I'm wondering about ways to reduce this amount significantly.π> According to the BP 7 manual resource Files can be used to reduce RAM by 8-π> 10%. Right now the Various buttons' Labels and commands are stored inπ> simple Arrays, which are not the most efficient memory-wise, but I don'tπ> think that making them Records will significantly reduce RAM need. I'd likeπ> to reduce RAM usage an order of magnitude, to about 10K. Any chance ofπ> doing this?ππThere is a dirty way of doing this, and it works With every Dos /πcommand-interpreter that I've tried it under, including Dos 6.0πin a Window under Windows, and 4Dos.ππThe Really nice thing about this way to do it, is that you can evenπload TSR's etc. since the menu Program is not in memory at all and there isπno secondary command interpreter when the user executes his choice.ππThe trick is that you run your Program from a "self-modifying" batchFile.ππ--- MENU.BAT ---π:StartAgainπSET MENU=C:\Dos\MENU.BAT ; Check this environment Var from your menu-progπGOMENU.EXE ; and abort if it is not setπSET MENU=π----------------ππLets say you want to run another batchFile from a menu choice f.x MY.BAT.πLet your Program modify the MENU.BAT to:π---π:StartAgainπSET MENU=C:\Dos\MENU.BATπGOMENU.EXEπSET MENU=πCALL MY.BATπGOTO StartAgainπ---ππWhen you want to terminate your menu-loop, simply modify the MENU.BATπback to it's original state.ππThe menu Program can be shared from a network server. There is noπlimitations at all. You can do Dos commands from the menu Withoutπhaving to load a second shell.ππFollowing my .sig there is a short example Program. It can't be runπdirectly since it Uses some libraries of mine, but you'll get an ideaπof how to do it.πππProgram HitAndRun; {Menusystem}πUsesπ Dos, Crt, LFsystem, LFCrt, LFinput;π{π Written by Lars Fosdalπ May 5th, 1991ππ Released to the public domain, May 15th, 1993π}πConstπ HitAndRunMsg = 'Written by Lars Fosdal ';π Prog = 'HIT&RUN';ππVarπ path : String;ππ{----------------------------------------------------------------------------}ππProcedure Message(MessageIndex : Integer);πbeginπ Writeln(Output);π Writeln(Output, Prog, ' - ', HitAndRunMsg);π Write(Output, 'Error: ');π Case MessageIndex OFπ -1 :π beginπ Write(Output, Prog, ' must be started from ');π Writeln(Output,Path + 'MENU.BAT');π end;π end;π Write(Output,^G);πend;ππProcedure BuildBatchFile(Execute : String);πVarπ BatchFile : Text;πbeginπ Assign(BatchFile, Path + 'MENU.BAT');π ReWrite(BatchFile);π Writeln(BatchFile, '@ECHO OFF');π Writeln(BatchFile, 'REM ' + Prog + ' Menu Minder');π Writeln(BatchFile, 'REM ' + HitAndRunMsg);π Writeln(BatchFile, ':HitAgain');π Writeln(BatchFile, 'SET H&R=BATCH');π Writeln(BatchFile, path + 'HIT&RUN');π if Execute<>'' thenπ beginπ Writeln(BatchFile, Execute);π Writeln(BatchFile, 'GOTO HitAgain');π endπ elseπ Writeln(BatchFile, 'SET H&R=');π Close(BatchFile);πend;ππFunction InitOK : Boolean;πVarπ OK : Boolean;πbeginπ path := BeforeLast('\', ParamStr(0)) + '\';π OK := GetEnv('H&R') = 'BATCH';π InitOK := OK;πend;ππProcedure HitAndRunMenu;πVarπ Mnu : aMenu;π win : aWindow;πbeginπ wDef(Win, 70, 1, 80, 25, 1, Col(Blue, LightGray), Col(Blue, White));π ItemSeparator:= '`';π mBarDefault := Red * 16 + Yellow;π mNew(Mnu, 'Pick an item to run',π 'Quit Menu`COMMAND`DIR /P`D:\BIN\NI'π + '`D:\BIN\MAPMEM`D:\BIN\X3\XTG'π + '`D:\BIN\LIST C:\Dos\MENY.BAT');π Menu(Win, Mnu);π Case Mnu.Entry OFπ 1 : BuildBatchFile('');π elseπ BuildBatchFile(Mnu.Items[Mnu.Entry]^);π end;πend;{HitAndRunMenu}ππbeginπ if InitOK thenπ HitAndRunMenuπ elseπ beginπ Message(-1);π BuildBatchFile('');π end;π Writeln(OutPut);πend.π 20 08-27-9320:49ALL GUY MCLOUGHLIN Dos IPCA IMPORT 10 ┤φ;& {πGUY MCLOUGHLINππ Program to load data into 16 Byte area of RAM known asπ the Dos "Inter-Process Communication Area".π}ππProgram Load_Dos_IPCA;ππTypeπ arby16 = Array[1..16] of Byte;ππ{ "Absolute" Array Variable used to access the Dos IPCA. }πVarπ IPCA : arby16 Absolute $0000:$04F0;π Index : Byte;ππbeginπ{ Write data to the Dos IPCA. }π For Index := 1 to 16 doπ IPCA[Index] := (100 + Index)πend.ππ{ Program to read data from 16 Byte area of RAM known }π{ as the Dos "Inter-Process Communication Area". }πProgram Read_Dos_IPCA;ππTypeπ arby16 = Array[1..16] of Byte;ππ{ "Absolute" Array Variable used to access the Dos IPCA. }πVarπ IPCA : arby16 Absolute $0000:$04F0;π Index : Byte;ππbeginπ Writeln;π { Display the current data found in the Dos IPCA. }π For Index := 1 to 16 doπ Write(IPCA[Index] : 4);π Writelnπend.ππ{π NOTE:π if you plan on using this in any of your serious applications, I wouldπ recommend using the last 2 Bytes of the IPCA as a CRC-16 error-check. Asπ you have no guarantee that another Program won't use the IPCA too.π} 21 08-27-9320:54ALL SWAG SUPPORT TEAM Dos Environment Unit IMPORT 43 ┤φ▀■ {πSubject: Enviro.pas Unit to change Dos Vars permanentlyπππHad this floating round, hope it helps someone.πIt works under Dos 5, NDos 6.01, and should work For any other Dos as well,πno guarantees tho' .ππ}πUnit Enviro;ππInterfaceππVar EnvSeg,π EnvOfs,π EnvSize : Word;ππFunction FindEnv:Boolean;πFunction IsEnvVar(Variable : String;Var Value : String):Boolean;πProcedure ChangeEnvVar(Variable,NewVal : String);ππImplementationππUses Dos;ππType MemoryControlBlock = {MCB -- only needed fields are shown}π Recordπ Blocktag : Byte;π BlockOwner : Word;π BlockSize : Word;π misc : Array[1..3] of Byte;π ProgramName: Array[1..8] of Char;π end;ππ ProgramSegmentPrefix = {PSP -- only needed fields are shown}π Record { offset }π PSPtag : Word; { $20CD or $27CD if PSP} { 00 $00 }π misc : Array[1..21] of Word; { 02 $02 }π Environment: Word { 44 $2C }π end;ππVarπ MCB : ^MemoryControlBlock;π r : Registers;π Found : Boolean;π SegMent : Word;π EnvPtr : Word;π Startofs : Word;ππFunction FindEnvMCB:Boolean;πVarπ b : Char;π BlockType: String[12];π Bytes : LongInt;π i : Word;π last : Char;π MCBenv : ^MemoryControlBlock;π MCBowner : ^MemoryControlBlock;π psp : ^ProgramSegmentPrefix;ππbeginπFindEnvMCB := False;ππBytes := LongInt(MCB^.BlockSize) SHL 4; {size of MCB in Bytes}πif mcb^.blockowner = 0 then { free space }πelse beginπ psp := Ptr(MCB^.BlockOwner,0); {possible PSP}π if (psp^.PSPtag = $20CD) or (psp^.PSPtag = $27CD) then beginπ MCBenv := Ptr(psp^.Environment-1,0);π if MCB^.Blockowner <> (segment + 1) thenπ if psp^.Environment = (segment + 1) thenπ if MCB^.BlockOwner = MCBenv^.BlockOwner then beginπ EnvSize := MCBenv^.BlockSize SHL 4; {multiply by 16}π EnvSeg := PSP^.Environment;π EnvOfs := 0;π FindEnvMCB := True;π endπ endπ end;πend;ππFunction FindEnv:Boolean;πbeginπr.AH := $52; {undocumented Dos Function that returns a Pointer}πIntr ($21,r); {to the Dos 'list of lists' }πsegment := MemW[r.ES:r.BX-2]; {segment address of first MCB found at}π {offset -2 from List of List Pointer }πRepeatπMCB := Ptr(segment,0); {MCB^ points to first MCB}π Found := FindEnvMcb; {Look at each MCB}π segment := segment + MCB^.BlockSize + 1πUntil (Found) or (MCB^.Blocktag = $5A);πFindEnv := Found;πend;ππFunction IsEnvVar(Variable : String;Var Value : String):Boolean;πVar Temp : String;π ch : Char;π i : Word;π FoundIt : Boolean;πbeginπVariable := Variable + '=';πFoundIt := False;πi := EnvOfs;πRepeatπ Temp := '';π StartOfs := I;π Repeatπ ch := Char(Mem[EnvSeg:i]);π if Ch <> #0 then Temp := Temp + Ch;π inc(i);π Until (Ch = #0) or (I > EnvSize);π if Ch = #0 then beginπ FoundIt := (Pos(Variable,Temp) = 1);π if FoundIt then Value := Copy(Temp,Length(Variable)+1,255);π end;πUntil (FoundIt) or (I > EnvSize);πIsEnvVar := FoundIt;πend;ππProcedure ChangeEnvVar(Variable,NewVal : String);πVar OldVal : String;π p1,p2 : Pointer;π i,j : Word;π ch,π LastCh : Char;πbeginπif IsEnvVar(Variable,OldVal) then beginπ p1 := Ptr(EnvSeg,StartOfs + Length(Variable)+1);π if Length(OldVal) = Length(NewVal) thenπ Move(NewVal[1],p1^,Length(NewVal))π else if Length(OldVal) > Length(NewVal) then beginπ Move(NewVal[1],p1^,Length(NewVal));π p1 := ptr(EnvSeg,StartOfs + Length(Variable)+Length(OldVal)+1);π p2 := ptr(EnvSeg,StartOfs + Length(Variable)+Length(NewVal)+1);π Move(p1^,p2^,EnvSize - ofs(p1^));π endπ else begin { newVar is longer than oldVar }π p2 := ptr(EnvSeg,StartOfs + Length(Variable)+Length(NewVal)-length(OldVal)+1);π Move(p1^,p2^,EnvSize - ofs(p2^));π Move(NewVal[1],p1^,Length(NewVal));π end;π endπelse { creating a new Var }π beginπ i := EnvOfs;π ch := Char(Mem[EnvSeg:i]);π Repeatπ LastCh := Ch;π inc(i);π ch := Char(Mem[EnvSeg:i]);π Until (i > EnvSize) or ((LastCh = #0) and (Ch = #0));π if i < EnvSize then beginπ j := 1;π Variable := Variable + '=' + NewVal + #0 + #0;π While (J < Length(Variable)) and (I <= EnvSize) do beginπ Mem[EnvSeg:i] := ord(Variable[j]);π inc(i); Inc(j);π end;π end;π end;πend;ππbeginπend.ππ{ TEST Program }πUses Enviro;ππVar EnvVar : String;ππbeginπif FindEnv then beginπ Writeln('Found the Enviroment !!');π Writeln('Env is at address ',EnvSeg,':',EnvOfs);π Writeln('And is ',EnvSize,' Bytes long');ππ if IsEnvVar('COMSPEC',EnvVar) then Writeln('COMSPEC = ',EnvVar)π else Writeln('COMSPEC is not set');ππ if IsEnvVar('NewVar',EnvVar) then Writeln('NewVar = ',EnvVar)π else Writeln('NewVar is not set');ππ ChangeEnvVar('NewVar','This is a new Var');ππ if IsEnvVar('NewVar',EnvVar) then Writeln('NewVar = ',EnvVar)π else Writeln('NewVar is not set');ππ ChangeEnvVar('NewVar','NewVar is now this');ππ if IsEnvVar('NewVar',EnvVar) then Writeln('NewVar = ',EnvVar)π else Writeln('NewVar is not set');ππ end;πend.π 22 08-27-9321:02ALL MARK LEWIS Extend DOS to 255 Files IMPORT 23 ┤φp├ {πMARK LEWISππ> The problem is that Without allocating a new FCB For Dos, youπ> can't have more than 15 or so Files open at a time in TP, noπ> matter WHAT the CONFIG.SYS FileS= statement says. (By default,ππi cannot remember exactly what INT $21 Function $6700 is but here's a PD Unitπi got from borland's bbs the other day... i've trimmed the Text down forπposting... if anyone Really needs everything that comes With it, they shouldπlook For EXTend6.*π}ππUnit Extend;π{ This extends the number of File handles from 20 to 255 }π{ Dos requires 5 For itself. Applications can use up to 250 }ππInterfaceππImplementationπUsesπ Dos;ππConstπ Handles = 255;π { You can reduce the value passed to Handles if fewer Files are required. }ππVarπ Reg : Registers;π beginπ { Check the Dos Version - This technique only works For Dos 3.0 or later }π Reg.ah := $30;π MsDos(Reg);π if Reg.al<3 thenπ beginπ Writeln('Extend Unit Require Dos 3.0 or greater');π halt(1);π end;ππ {Reset the FreePtr - This reduces the heap space used by Turbo Pascal}π if HeapOrg <> HeapPtr thenπ {Checks to see if the Heap is empty}π beginπ Write('Heap must be empty before Extend Unit initializes');π Writeln;π halt(1);π end;π Heapend := ptr(Seg(Heapend^) - (Handles div 8 + 1), Ofs(Heapend^));ππ {Determine how much memory is allocated to Program}π {Reg.Bx will return how many paraGraphs used by Program}π Reg.ah := $4A;π Reg.es := PrefixSeg;π Reg.bx := $FFFF;π msDos(Reg);ππ {Set the Program size to the allow For new handles}π Reg.ah := $4A;π Reg.es := PrefixSeg;π Reg.bx := reg.bx - (Handles div 8 + 1);π msDos(Reg);ππ {Error when a Block Size is not appropriate}π if (Reg.flags and 1) = 1 thenπ beginπ Writeln('Runtime Error ', Reg.ax, ' in Extend.');π halt(1);π end;ππ {Allocate Space For Additional Handles}π reg.ah := $67;π reg.bx := Handles;π MsDos(reg);πend.ππ{πWrite the following Program to a separate File. This Program tests the EXTendπUnit. This test should be done on systems equipped With a hard disk.π}ππProgram TestEx;ππUsesπ EXTend;ππTypeπ FileArray = Array [1..250] of Text;ππVarπ f : ^FileArray;π i : Integer;π s : String;ππbeginπ {Allocate Space For fILE Variable Table}π new(f);π {oPEN 250 Files simultaneously}π For i:=1 to 250 doπ beginπ str(i,s);π Assign(f^[i],'Dum'+s+'.txt');π reWrite(f^[i]);π Writeln('Open #',s);π end;π {Write some Text to the Files}π For i:=1 to 250 doπ Write(f^[i],'This is a test File');π {Close the Files}π For i:=1 to 250 doπ beginπ close(f^[i]);π Writeln('Closing #',i);π end;π {Erase the Files}π For i:=1 to 250 doπ beginπ erase(f^[i]);π Writeln('Erasing #',i);π end;πend.ππ 23 08-27-9321:43ALL BJOERN JOENSSON Detect OS2 IMPORT 3 ┤φ¬g {πBJOERN JOENSSONππBTW, OS/2 is easy to detect because the major Dosπversion # is greater than 10:π}ππFunction DetectOs2 : Boolean;πbeginπ { if you use Tpro, then Write Hi(TpDos.DosVersion) }π DetectOs2 := (Lo(Dos.DosVersion) > 10);πend;π 24 08-27-9321:50ALL EMMANUEL CECCHET Cold/Warm Boot IMPORT 3 ┤φñ) {πFreeWare by Emmanuel CECCHETπ(C) 1992 3D CONCEPT PRODUCTIONπ}ππProcedure Cold_Boot; Assembler;πAsmπ mov AX,1700hπ int 14hπend;ππProcedure Warm_Boot; Assembler;πAsmπ mov AX,1701hπ int 14hπend;π 25 08-27-9321:57ALL LARS HELLSTEN Detecting SHARE IMPORT 12 ┤φ╢┐ {πLARS HELLSTENππ> I would like to open a few Files in READ, DENY Write mode. I can get the rπ> part (just a reset), but not the DENY Write. How can I accomplish this inπ> Turbo Pascal Without locking specific Records or parts of Files, or the whoπ> File... or is that what is required?ππYou can accomplish that by changing the FileMODE Variable. Iπdon't know if that's what you're looking for, or already know this,πbut, here's a table of FileMODE values:π Sharing MethodπAccess Method Compatibility Deny Write Deny Read Deny Noneπ--------------------------------------------------------------πRead Only 0 32 48 64πWrite Only 1 33 49 65πRead/Write 2 34 50 66π--------------------------------------------------------------ππ So, as you can see, all you need to do is set the FileMODE to 32. Justπput the satement "FileMode := 32;" in before you reset the File. This willπonly work With Dos' SHARE installed, or a compatible network BIOS. if youπneed a routine to detect SHARE, here's one:π}ππUsesπ Dos;ππFunction ShareInstalled : Boolean;πVarπ Regs : Registers;πbeginπ Regs.AH := $16;π Regs.AL := $00;π Intr($21, Regs);π ShareInstalled := (Regs.AL = $FF);πend;ππbeginπ Writeln('Share: ', ShareInstalled);πend. 26 08-27-9322:06ALL ALEXANDER KUGEL Trap DOS Error IMPORT 39 ┤φáR {πAlexander Kugelππ There was a discussion about how to trap floating point errorsπin TP. Here is the solution that traps any kind of run-timeπerrors. The idea is not mine. I saw it in a russian book about TPπand OOP.ππ The idea is quite simple. Instead of trying to trap all kind ofπerrors, we can let TP to do the job For us. Whenever TP stopsπexecution of the Program ( because of a run time error or justπbecause the Program stops in a natural way ) it executes theπdefault Procedure of Exit : ExitProc. Then TP checks the status ofπtwo Variables from the SYSTEM Unit : ErrorAddr and ExitCode. Ifπthere was a run time error then ErrorAddr is not NIL and ExitCodeπcontaines the run time error code. Otherwise ExitCode containes theπerrorlevel that will be set For Dos and ErrorAddr is NIL.πFortunatly we can easily redefine the ExitProc, and thus toπovertake the control from TP. The problem is that we got to be ableπto get back or to jump to any point of the Program ( even to jumpπinside a Procedure / Function). The author of the book claimed thatπhe took his routines from Turbo Professional.ππ Well, there are two Files you are gonna need. Save the first oneπas JUMP.PAS Compile it as a Unit. The second one is a short Programπthat shows how to use it. It asks For two numbers, divides theπfirst by the second and takes a natural logarithm of the result.πTry to divide by zero, logarithm of a negative number. Try enteringπletters instead of numbers and see how the Program recovers.ππ The trapping works fine under Windows/Dos. To run it WithπWindowS recompile the JUMP Unit For Windows target. Then add WinCrtπto the Uses statement and remove Mark/Release lines ( because thereπis no Mark/Release For Windows ).ππ------------------------------jump.pas-----------------------------π}ππUnit Jump;ππInterfaceππTypeπ JumpRecord = Recordπ SpReg,π BpReg : Word;π JmpPt : Pointer;π end;ππProcedure SetJump(Var JumpDest : JumpRecord);π{Storing SP,BP and the address}πInline(π $5F/ {pop di }π $07/ {pop es }π $26/$89/$25/ {mov es:[di],sp }π $26/$89/$6D/$02/ {mov es:[di+2],bp }π $E8/$00/$00/ {call null }π {null: }π $58/ {pop ax }π $05/$0C/$00/ {add ax,12 }π $26/$89/$45/$04/ {mov es:[di+4],ax }π $26/$8C/$4D/$06); {mov es:[di+6],cs }π {next: }ππProcedure LongJump(Var JumpDest : JumpRecord);π{Restore everything and jump}πInline(π $5F/ {pop di }π $07/ {pop es }π $26/$8B/$25/ {mov sp,es:[di] }π $26/$8B/$6D/$02/ {mov bp,es:[di+2] }π $26/$FF/$6D/$04); {jmp far es:[di+4]}ππImplementationππend.ππ{ ------------------------------try.pas------------------------------ }ππProgram Try;πUsesπ Jump; {Uses Jump,WinCrt;}ππVarπ OldExit : Pointer;π MyAddr : JumpRecord;π MyHeap : Pointer;ππ a1,a2,π a3,a4 : Real;πππ{$F+}πProcedure MyExit;π{You can add your error handler here}πbeginπ if ErrorAddr <> Nil Thenπ beginπ Case ExitCode ofπ 106 : Writeln('Invalid numeric format');π 200 : Writeln('Division by zero');π 205 : Writeln('Floating point overflow');π 206 : Writeln('Floating point underflow');π 207 : Writeln('Invalid floating point operation');π else Writeln('Hmmm... How did you do that ?');π end;π ErrorAddr := Nil;π LongJump(MyAddr);π end;π ExitProc := OldExit;πend;π{$F-}ππbeginπ OldExit := ExitProc;π Mark(MyHeap);π {Just an example of how to restore the heap }π {Actually we don't have to do that in }π {this Program, because we dont use heap }π {at all. But anyway here it goes }ππ {Don't forget to remove when compiling this }π {for Windows }ππ SetJump(MyAddr);ππ {We'll get back here whenever a run time }π {error occurs }π {This line should always be before }π { ExitProc:=MyExit; }π {Don't ask me why... It's much easier For me}π {to follow the rule then to understand it :)}ππ ExitProc := @MyExit;ππ Release(MyHeap);π {restoring the heap after a run time error }π {Remove this if you are compiling it For }π {Windows }ππ {Try entering whatever you want at the }π {prompt. It should trap every runtime error}π {you could possibly get. }ππ Repeatπ Writeln;π Write('Enter a number a1=');π Readln(a1);π Write('Enter a number a2=');π Readln(a2);π a3 := a1 / a2;π Writeln('a1/a2=', a3 : 10 : 5);π a4 := ln(a3);π Writeln('ln(a1/a2)=', a4 : 10 : 5);π Until a3 = 1;πend.π 27 08-27-9322:10ALL SWAG SUPPORT TEAM DOS Volume Labels IMPORT 30 ┤φüu {π> I need a way to find the volume Label of a drive. Any suggestions orπ> source code?π}π{$S-,R-,V-,I-,N-,B-,F-}ππUnit Volume;ππInterfaceππUsesπ Dos;ππTypeππ Drive = Byte;π VolumeName = String [11];ππ VolFCB = Recordπ FCB_Flag : Byte;π Reserved : Array [1..5] of Byte;π FileAttr : Byte;π Drive_ID : Byte;π FileName : Array [1..8] of Byte;π File_Ext : Array [1..3] of Byte;π Unused_A : Array [1..5] of Byte;π File_New : Array [1..8] of Byte;π fExt_New : Array [1..3] of Byte;π Unused_B : Array [1..9] of Byteπ end;ππFunction DelVol (D : Byte) : Boolean;πFunction AddVol (D : Byte; V : VolumeName) : Boolean;πFunction ChgVol (D : Byte; V : VolumeName) : Boolean;πFunction GetVol (D : Byte) : VolumeName;ππImplementationππProcedure Pad_Name (Var V : VolumeName);πbeginπ While LENGTH (V) <> 11 DOπ V := V + ' 'πend;ππFunction Fix_Ext_Sym (Var V : VolumeName) : Byte;πVarπ I : Byte;πbeginπ I := POS ('.', V);π if I > 0 thenπ DELETE (V, I, 1);π Fix_Ext_Sym := Iπend;ππFunction Extract_Name (S : SearchRec) : VolumeName;πVarπ H, I : Byte;πbeginπ I := Fix_Ext_Sym (S.Name);π if (I > 0) and (I < 9) thenπ For H := 1 to (9 - I) DOπ INSERT (' ', S.Name, I);π Extract_Name := S.Nameπend;ππProcedure Fix_Name (Var V : VolumeName);πVarπ I : Byte;πbeginπ Pad_Name (V);π For I := 1 to 11π do V [I] := UPCASE (V [I])πend;ππFunction Valid_Drive_Num (D : Byte) : Boolean;πbeginπ Valid_Drive_Num := (D >= 1) and (D <= 26)πend;ππFunction Find_Vol (D : Byte; Var S : SearchRec) : Boolean;πbeginπ FINDFIRST (CHR (D + 64) + ':\*.*', VolumeID, S);π Find_Vol := DosError = 0πend;ππProcedure Fix_FCB_NewFile (V : VolumeName; Var FCB : VolFCB);πVarπ I : Byte;πbeginπ For I := 1 to 8 DOπ FCB.File_New [I] := ORD (V [I]);π For I := 1 to 3 DOπ FCB.fExt_New [I] := ORD (V [I + 8])πend;ππProcedure Fix_FCB_FileName (V : VolumeName; Var FCB : VolFCB);πVarπ I : Byte;πbeginπ For I := 1 to 8 DOπ FCB.FileName [I] := ORD (V [I]);π For I := 1 to 3 DOπ FCB.File_Ext [I] := ORD (V [I + 8])πend;ππFunction Vol_Int21 (Fnxn : Word; D : Drive; Var FCB : VolFCB) : Boolean;πVarπ Regs : Registers;πbeginπ FCB.Drive_ID := D;π FCB.FCB_Flag := $FF;π FCB.FileAttr := $08;π Regs.DS := SEG (FCB);π Regs.DX := OFS (FCB);π Regs.AX := Fnxn;π MSDos (Regs);π Vol_Int21 := Regs.AL = 0πend;ππFunction DelVol (D : Byte) : Boolean;πVarπ sRec : SearchRec;π FCB : VolFCB;π V : VolumeName;πbeginπ DelVol := False;π if Valid_Drive_Num (D) thenπ beginπ if Find_Vol (D, sRec) thenπ beginπ V := Extract_Name (sRec);π Pad_Name (V);π Fix_FCB_FileName (V, FCB);π DelVol := Vol_Int21 ($1300, D, FCB)π endπ endπend;ππFunction AddVol (D : Byte; V : VolumeName) : Boolean;πVarπ sRec : SearchRec;π FCB : VolFCB;πbeginπ AddVol := False;π if Valid_Drive_Num (D) thenπ beginπ if not Find_Vol (D, sRec) thenπ beginπ Fix_Name (V);π Fix_FCB_FileName (V, FCB);π AddVol := Vol_Int21 ($1600, D, FCB)π endπ endπend;ππFunction ChgVol (D : Byte; V : VolumeName) : Boolean;πVarπ sRec : SearchRec;π FCB : VolFCB;π x : Byte;πbeginπ ChgVol := False;π if Valid_Drive_Num (D) thenπ beginπ if Find_Vol (D, sRec) thenπ beginπ x := Fix_Ext_Sym (V);π Fix_Name (V);π Fix_FCB_NewFile (V, FCB);π V := Extract_Name (sRec);π Pad_Name (V);π Fix_FCB_FileName (V, FCB);π ChgVol := Vol_Int21 ($1700, D, FCB)π endπ endπend;ππFunction GetVol (D : Byte) : VolumeName;πVarπ sRec : SearchRec;πbeginπ GetVol := '';π if Valid_Drive_Num (D) thenπ if Find_Vol (D, sRec) thenπ GetVol := Extract_Name (sRec)πend;ππend.π 28 09-26-9309:28ALL MARTIN RICHARDSON Redirect DOS I/O IMPORT 7 ┤φ"k {****************************************************************************π * Procedure ..... StandardIOπ * Purpose ....... To allow input/output redirection from the DOS commandπ * line.π * Parameters .... Noneπ * Returns ....... N/Aπ * Notes ......... Normal TP writes do not allow i/o redirection. This is aπ * fix for that.π * Author ........ Martin Richardsonπ * Date .......... May 13, 1992π ****************************************************************************}πPROCEDURE StandardIO;πBEGINπ ASSIGN( Input, '' );π RESET( Input );π ASSIGN( Output, '' );π REWRITE( Output );πEND;π 29 09-26-9310:17ALL HELGE HELGESEN SHARE Unit in ASM IMPORT 38 ┤φê⌐ (*πFrom: HELGE HELGESENπSubj: SHARE.EXEπ---------------------------------------------------------------------------π-> Can I lock the files after the RESET and unlock before / afterπ-> the close?ππYes. This is one advantage of network files. All users runningπyour program will open the files simultaneously, and when aπprocess wants to write to a record, it simply locks it. No otherπprocesses can then read or write to the record, though they canπread/write all other records.ππ(I assume you're NOT using text files!)ππ-> I'd like to add a thing that checks if the file is lockedπ-> before the reset.ππIf a record is locked, then the process still can open the file.ππ-> Does the "lock" occur on the open or the read of the file?ππWhat do you mean? You can open a file in numerous ways. If youπopen it for shDenyN, then locking is done on record(byte) basis.πIf you open it for exclusive(FileMode=2) access or shDenyRW (noπother can access the file) then locking is done on file basis.ππHere's a short unit with file locking support. It's written forπTurbo Pascal (or Borland Pascal) 7.0, but it should work withπTP60 without many modifications.πSHARE.PAS --->π*)ππUnit Share;π{π Utility to allow file sharing on a networkπ (c) 1993 Helge Olav Helgesenπ}ππinterfaceππusesπ dos;ππfunction shShareInstalled: boolean; { check if SHARE is installed }πfunction LockByte(var thefile; FirstByte, NoBytes: longint): byte;πfunction UnLockByte(var thefile; FirstByte, NoBytes: longint): byte;πfunction Lock(var thefile; FirstRec, NoRecs: word): byte;πfunction UnLock(var thefile; FirstRec, NoRecs: word): byte;ππconstπ{π Here's a list of file file modes you can open a file with. To allowπ multiple access to one file, it should either be marked R/O, or openedπ with shDenyN-mode. To open a file with a spesified mode, do:ππ FileMode:=shDenyN+shAccessRW; (Add the flags)π}π shDenyR = $30; { Deny Read to other Processes }π shDenyW = $20; { Deny Write to other Processes }π shDenyRW = $10; { Deny access to other Processes }π shDenyN = $40; { Deny none - full access to other Processes }π shAccessR = $0; { open for Read access }π shAccessW = $1; { open for Write Access }π shAccessRW = $2; { open for both read and write }π shPrivate = $80; { private mode - don't know what this is... }ππimplementation { the private part }ππfunction shShareInstalled; assembler;π{π Returns TRUE if Share is installed on the local machine!π}πasmπ mov ax,$1000 { check if SHARE is installed }π int $2f { call multiplex interrupt }πend; { shShareInstalled }ππfunction LockByte; assembler;π{π Locks a region of bytes in the specified file.π}πasmπ mov ax, $5c00π les bx, thefileπ mov bx, es:[bx].FileRec.Handleπ les dx, FirstByteπ mov cx, esπ les di, NoBytesπ mov si, esπ int $21π jc @1π xor al, alπ@1:πend;ππfunction Lock; assembler;π{π Lock records.π}πasmπ les bx, thefileπ mov cx, es:[bx].FileRec.RecSizeπ mov ax, FirstRecπ mul cxπ push axπ push dxπ mov ax, NoRecsπ mul cxπ mov si, dxπ mov di, axπ pop cxπ pop dxπ mov ax, $5c00π mov bx, es:[bx].FileRec.Handleπ int $21π jc @1π xor al, alπ@1:πend;ππfunction UnLockByte; assembler;πasmπ mov ax, $5c01π les bx, thefileπ mov bx, es:[bx].FileRec.Handleπ les dx, FirstByteπ mov cx, esπ les di, NoBytesπ mov si, esπ int $21π jc @1π xor al, alπ@1:πend;ππfunction UnLock; assembler;πasmπ les bx, thefileπ mov cx, es:[bx].FileRec.RecSizeπ mov ax, FirstRecπ mul cxπ push axπ push dxπ mov ax, NoRecsπ mul cxπ mov si, dxπ mov di, axπ pop cxπ pop dxπ mov ax, $5c01π mov bx, es:[bx].FileRec.Handleπ int $21π jc @1π xor al, alπ@1:πend;ππend.πππThey're used this way:πLock(MyFile, FirstByteToLock, NoBytesToLock);πLockByte(MyFile, FirstRecToLock, NoRecsToLock);ππSince you're working with records, you probably want to use Lock.πWhen you want to update a record, this might be the code:ππLock(MyFile, Rec, 1);πWrite(MyFile, MyRec);πUnLock(MyFile, Rec, 1);ππYou will of course have to make code to check if the lock failedπ(any result but 0), you can't write to the record. Always unlockπthe record as soon you're done!ππThe last ones are UnLock and UnLockByte. They're used the sameπway as Lock and LockByte.ππAnd a last note! You can't open a file in a mode that conflictsπwith the access other processes have to a file.ππEg.ππif you first open a file with mode shDenyN+shAccessRW, and thenπtry to open the file again (without closing the first one) withπthe mode shDenyRW+shAccessRW, the reset will fail.ππI'll see if I can make a short program to illustrate how thisπworks...ππHope this helps a litte,ππ... Helgeπ 30 09-26-9310:18ALL MIKE DICKSON Is there 4DOS installed IMPORT 5 ┤φd₧ (*πFrom: MIKE DICKSONπSubj: IS There 4DOSπ*)ππ FUNCTION Running4DOS : Boolean;π VAR Regs : Registers;π beginπ With Regs doπ beginπ ax := $D44D;π bx := $00;π end;π Intr ($2F, Regs);π if Regs.ax = $44DD then Running4DOS := TRUEπ else Running4DOS := FALSEπ end;ππ 31 10-28-9311:34ALL GREG VIGNEAULT APPEND, ASSIGN & SHARE IMPORT 26 ┤φ ä {===========================================================================πDate: 09-22-93 (08:41)πFrom: GREG VIGNEAULTπSubj: APPEND, ASSIGN, & SHAREπ---------------------------------------------------------------------------πJS> How could I determine if DOS extension utilities (eg. Append,π > Assign, and Share) are installed, using Turbo Pascal? }ππ(* Turbo/Quick/StonyBrook Pascal: Determine if extensions installed *)πPROGRAM DosExt; { DOSEXT.PAS: Greg Vigneault 93.10.02 }ππUSES Dos; { Import Intr(), MsDos(), Registers }ππTYPE Extension = (Append, Assign, Share); { the PC/MS-DOS extensions }ππVAR Reg : Registers; { to access Intel 80x86 CPU registers }π Status : WORD; { to return system extension status }π Installed : Extension; { DOS extension (Append|Assign|Share) }π Okay : BOOLEAN; { success or failure (TRUE|FALSE) }π Func : BYTE; { the multiplex function number }ππ(*------------------------------------------------------------------*)πFUNCTION DosVersion : WORD; { to check DOS version }π BEGINπ Reg.AH := $30; { function:get DOS ver }π MsDos (Reg); { call DOS services }π DosVersion := Reg.AL * 100 + Reg.AH; { ...version times 100 }π END {DosVersion};ππ(*------------------------------------------------------------------*)πFUNCTION Multiplex (Func : WORD; VAR Status : WORD) : BOOLEAN;π BEGINπ Reg.AH := Func; { function number }π Reg.AL := 0; { subfunction:get status }π Intr ($2F,Reg); { do multiplex interrupt }π IF (Reg.Flags AND 1) <> 0 THEN BEGIN { an error condition? }π Status := Reg.AX; { the DOS error code }π Multiplex := FALSE; END { and flag the error }π ELSE BEGINπ Status := WORD(Reg.AL); { the function status }π Multiplex := TRUE; { and flag success }π END;π END {Multiplex};ππ(*------------------------------------------------------------------*)πBEGIN {DosExt}ππ WriteLn;π IF DosVersion < 330 THEN BEGINπ WriteLn ('PC/MS-DOS version is too low, sorry.');π Halt (1);π END;ππ FOR Installed := Append TO Share DO BEGINπ CASE Installed OFπ Append : BEGIN Write ('APPEND '); Func := $B7; END;π Assign : BEGIN Write ('ASSIGN '); Func := $02; END;π Share : BEGIN Write ('SHARE '); Func := $10; END;π END; {CASE}π IF NOT Multiplex (Func,Status) THENπ WriteLn ('status unknown (MS-DOS error #',Status,').')π ELSEπ CASE Status OFπ 0,1 : BEGINπ Write ('not installed: ');π IF Status = 1 THEN Write ('and NOT ');π WriteLn ('okay to install.');π END;π 255 : WriteLn ('is installed.');π END; {CASE & IF}π END; {FOR}ππEND {DosExt}.π(********************************************************************)π 32 11-02-9316:48ALL RUUD UPHOFF Pascal Environment IMPORT 25 ┤φ═W {πFrom: RUUD UPHOFF Refer#: NONEπSubj: TPENV.PAS Conf: (1221) F-PASCALπ---------------------------------------------------------------------------π}ππUNIT SetEnvir;ππINTERFACEπππ USESπ DOS;πππ TYPEπ EnvSize = 0..16383;πππ PROCEDURE SetEnv( EnvVar,Value : STRING);ππ {-----------------------------------------------------------------------π{ This procedure may be used to setup or change environment variablesπ{ in the environment of the resident copy of COMMAND.COM or 4DOS.COMπ{π{ Note that this will be the ACTIVE copy of the command interpreter, NOTπ{ the primary copy!π{π{ This unit is not tested under DR-DOS.π{π{ Any call of SetEnv must be followed by checking ioresult. The procedureπ{ may return error 8 (out of memory) on too less space in te environment.π{-----------------------------------------------------------------------}πππππIMPLEMENTATIONππππ PROCEDURE SetEnv( EnvVar, Value : STRING);ππ VARπ Link,π PrevLink,π EnvirP : word;ππ Size,π Scan,π Where,π Dif : integer;ππ NewVar,π OldVar,π Test : STRING;πππ FUNCTION CheckSpace(Wanted : integer) : boolean;ππ BEGINπ IF wanted+Scan > Size THENπ inoutres:=8;π CheckSpace := inoutres=0π END;πππ BEGINπ IF inoutres >0 THENπ Exit;π FOR Scan := 1 TO Length(EnvVar) DOπ EnvVar[Scan] := UpCase(EnvVar[Scan]);π EnvVar := EnvVar + '=';π NewVar := EnvVar + Value + #0;π link := PrefixSeg;ππ REPEATπ PrevLink := Link;π Link := memw [link : $16]π UNTIL Link = prevlink;ππ EnvirP := memw [Link : $2C];π Size := memw [Envirp-1 : $03] * 16;π Scan := 0;π Where := -1;π WHILE mem[EnvirP : Scan] <>0 DOππ BEGINπ move( mem[EnvirP : scan], Test[1], 255);π Test[0] := #255;π Test[0] := chr(pos(#0,Test));π IF pos(EnvVar, Test) =1 THENππ BEGINπ Where := Scan;π OldVar := Testπ END;ππ Scan := Scan + Length(Test)π END;ππ IF Where = -1 THENππ BEGINπ Where := Scan;π NewVar := NewVar + #0#0#0;π IF NOT CheckSpace( Length(NewVar) ) THENπ Exitπ ENDππ ELSEππ BEGINπ Dif := Length(NewVar) - Length(OldVar);π IF Dif >0 THENππ BEGINπ IF NOT CheckSpace(Dif) THENπ Exit;π move( mem[ EnvirP : Where ],π mem[ EnvirP : Where + Dif ],π Scan-Where+3)π ENDππ ELSE IF Dif <0 THENπ move( mem[ EnvirP : Where - Dif ],π mem[ EnvirP : Where ],π Size-Where+Dif)π END;ππ move( NewVar[1], mem[EnvirP : Where], Length(NewVar) )π END;ππEND.π 33 11-02-9317:23ALL CHRIS PRIEDE SAFEBOOT with FLUSH IMPORT 4 ┤φ█à {πFrom: CHRIS PRIEDEπSubj: Rebooting...ππissue DOS Flush Buffers call AND reboot }ππprocedure SafeReboot; far; assembler;πasmπ mov ah, 0Dhπ int 21hπ xor cx, cxπ@1:π push cxπ int 28hπ pop cxπ loop @1π mov ds, cxπ mov word ptr [472h], 1234hπ dec cxπ push cxπ push dsπend;π 34 11-02-9317:37ALL JON JASIUNAS Share Multi-Tasking IMPORT 76 ┤φ└┬ {πFrom: JON JASIUNASπSubj: Share Multi-taskingπ}ππ{**************************π * 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; { SetFileMode }ππ{-----------------------------------------------------------------------------}ππprocedure ResetFileMode;πbeginπ FileMode := NormalMode;πend; { ResetFileMode }ππ{-----------------------------------------------------------------------------}ππprocedure LockFile(var F);πbeginπ If not MultiTasking thenπ Exit;ππ While InDos doπ GiveTimeSlice;ππ FLock(FileRec(F).Handle, 0, FileSize(File(F)));πend; { LockFile }ππ{-----------------------------------------------------------------------------}ππprocedure UnLockFile(var F);πbeginπ If not MultiTasking thenπ Exit;ππ While InDos doπ GiveTimeSlice;ππ FLock(FileRec(F).Handle, 0, FileSize(File(F)));πend; { UnLockFile }ππ{-----------------------------------------------------------------------------}ππprocedure LockBytes(var F; Start, Bytes: LongInt);πbeginπ If not MultiTasking thenπ Exit;ππ While InDos doπ GiveTimeSlice;ππ FLock(FileRec(F).Handle, Start, Bytes);πend; { LockBytes }ππ{-----------------------------------------------------------------------------}ππprocedure UnLockBytes(var F; Start, Bytes: LongInt);πbeginπ If not MultiTasking thenπ Exit;ππ While InDos doπ GiveTimeSlice;ππ FLock(FileRec(F).Handle, Start, Bytes);πend; { UnLockBytes }ππ{-----------------------------------------------------------------------------}ππ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).Recπend; { LockBytes }ππ{-----------------------------------------------------------------------------}ππ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).Recπend; { UnLockBytes }ππ{-----------------------------------------------------------------------------}ππfunction TimeOut: Boolean;πbeginπ GiveTimeSlice;π TimeOut := True;ππ If MultiTasking and (LockRetry < MaxLockRetries) thenπ beginπ TimeOut := False;π Inc(LockRetry);π end; { If }πend; { TimeOut }ππ{-----------------------------------------------------------------------------}ππprocedure TimeOutReset;πbeginπ LockRetry := 0;πend; { TimeOutReset }ππ{-----------------------------------------------------------------------------}ππfunction InDos: Boolean;πbegin { InDos }π InDos := InDosFlag^ > 0;πend; { InDos }ππ{-----------------------------------------------------------------------------}ππprocedure GiveTimeSlice; ASSEMBLER;πasm { GiveTimeSlice }π 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; { TimeSlice }ππ{----------------------------------------------------------------------------}ππprocedure BeginCrit; ASSEMBLER;πasm { BeginCrit }π 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; { BeginCrit }ππ{----------------------------------------------------------------------------}ππprocedure EndCrit; ASSEMBLER;πasm { EndCrit }π 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; { EndCrit }ππ{============================================================================}ππbegin { Share }π {- 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; { asm }πend. { Share }π 35 11-02-9318:40ALL BILL BUCHANAN More REBOOT IMPORT 7 ┤φ\p {===========================================================================πDate: 10-02-93 (04:20)πFrom: BILL BUCHANANπ To: JON DERAGONπSubj: BOOT IT!ππ> Hi everyone! Just wondering if anyone out there knows how to makeπ> the computer do a RESET using a small Pascal routine? Need it ASAP asπ> part of a pretty large project currently in the final stages ofπ> completion. }ππprogram Reboot;πbeginπ Inline ($EA/$F0/$FF/$00/$F0)πend.ππProcedure ColdBoot; Assembler;π Asmπ Xor AX, AXπ Mov ES, AXπ Mov Word PTR ES:[472h],0000h {This is NOT a WARM boot}π Mov AX, 0F000hπ Push AXπ Mov AX, 0FFF0hπ Push AXπ Retfπ End;π 36 11-21-9309:28ALL RANDALL WOODMAN Get CMOS Values IMPORT 72 ┤φ⌠M {πFrom: RANDALL WOODMANπSubj: CMOS Infoππ Does anyone know how to get the hard drive type(s) from CMOS ?π}ππUSES DOS,CRT;ππTYPEπ String80 = STRING [80]; { some general purpose string types }π String40 = STRING [40];π String30 = STRING [30];π String20 = STRING [20];π String12 = STRING [12];π String10 = STRING [10];π String5 = STRING [5];ππ CMOSRec = RECORDπ Found : BOOLEAN; { was a CMOS found to exist }π CmosDate : String30; { the date found in CMOS }π CmosTime : String30; { the time found in CMOS }π VideoType : String10; { Type of video found in CMOS }π Coproc : BOOLEAN; { does CMOS report a math coprocessor }π FloppyA : String12; { type of floppy drive for A }π FloppyB : String12; { Type of floppy drive for B }π Hard0 : BYTE; { Type of hard drive for drive 0 }π Hard1 : BYTE; { Type of hard drive for Drive 1 }π ConvenRam : WORD; { amount of conventional ram indicated }π ExtendRam : WORD; { amount of extended Ram indicated }π checkSum : BOOLEAN; { Did checksum pass }π END; { CMOS Rec }ππCONSTπ { values of constants for CMOS }π DayName : ARRAY [0..7] OF STRING [9] = ('Sunday', 'Monday', 'Tuesday',π 'Wednesday', 'Thursday', 'Friday',π 'Saturday', 'Sunday');π MonthName : ARRAY [0..12] OF STRING [9] = ('???', 'January', 'February', 'March',π 'April', 'May', 'June', 'July',π 'August', 'September', 'October',π 'November', 'December');π ScreenName : ARRAY [0..3] OF STRING [10] = ('EGA/VGA', 'CGA 40col',π 'CGA 80col', 'Monochrome');π FloppyName : ARRAY [0..5] OF STRING [11] = ('none', '5.25" 360K',π '5.25" 1.2M', '3.5" 720K',π '3.5" 1.44M', '3.5" 2.88M');π CMOSport : BYTE = $70; { port to access the CMOS }ππ Country : BYTE = 0; { used for country date format }ππ{===========================================================================}πππVARπ Regs : REGISTERS; { General purpose variable to accessπ registers }π CMOS : CMOSRec; { variable to hold CMOS data }ππFUNCTION nocarry : BOOLEAN;π{ returns the status of the carry flag }πBEGINπ nocarry := regs.flags AND fcarry = $0000πEND; {nocarry}ππ{---------------------------------------------------------------------------}ππFUNCTION ByteToWord (ByteA, ByteB : BYTE) : WORD;πBEGINπ ByteToWord := WORD (ByteB) SHL 8 + ByteAπEND; {cbw}ππ{---------------------------------------------------------------------------}ππFUNCTION BitIsSet (CheckWord : WORD; AndValue : WORD) : BOOLEAN;π{ returns true if the bit(s) indicated in AndValue are set in CheckByte }πBEGINπ BitIsSet := CheckWord AND AndValue = AndValue;πEND;ππ{---------------------------------------------------------------------------}ππFUNCTION ReadCMOS (ADDR : BYTE) : BYTE;π{ read a value from the CMOS }πBEGINπ IF CMOSport = $70 THENπ BEGINπ INLINE ($FA);π Port [CMOSport] := ADDR;π readCMOS := Port [CMOSport + 1];π INLINE ($FB)π ENDπEND; {readCMOS}ππ{---------------------------------------------------------------------------}ππFUNCTION addzero (b : BYTE) : string5;πVARπ c2 : STRING [2];πBEGINπ STR (b : 0, c2);π IF b < 10 THENπ c2 := '0' + c2;π addzero := c2πEND; {addzero}ππ{---------------------------------------------------------------------------}ππFUNCTION ChangeBCD (b : BYTE) : BYTE;π{ change a BCD into a byte structure }πBEGINπ ChangeBCD := (b AND $0F) + ( (b SHR 4) * 10)πEND; {ChangeBCD}ππ{---------------------------------------------------------------------------}ππFUNCTION Long2Str (Long : LONGINT) : STRING;πVAR Stg : STRING;πBEGINπ STR (Long, Stg);π Long2Str := Stg;πEND;ππFUNCTION HexL (argument : LONGINT) : STRING; Assembler;π asmπ cldπ les di, @resultπ mov al, 8 { store string length }π stosbπ mov cl, 4 { shift count }ππ mov dx, WORD PTR Argument + 2 { hi word }π call @1 { convert dh to ascii }π mov dh, dl { lo byte of hi word }π call @1 { convert dh to ascii }π mov dx, WORD PTR Argument { lo word }π call @1 { convert dh to ascii }π mov dh, dl { lo byte of lo word }π call @1 { convert dh to ascii }π jmp @2ππ @1 :π mov al, dh { 1 byte }π AND al, 0fh { low nybble }π add al, 90hπ daaπ adc al, 40hπ daaπ mov ah, al { store }π mov al, dh { 1 byte }π SHR al, cl { get high nybble }π add al, 90hπ daaπ adc al, 40hπ daaπ stosw { move characters to result }π retn { return near }π @2 :π END;ππFUNCTION GetCMOSDate : String30;π{ gets the date found in the CMOS and returns it in string format }πVARπ Date,π Century,π Year,π Month : BYTE;π WorkStr : String30;πBEGINπ WorkStr := '';π date := ChangeBCD (readCMOS (7) );π century := ChangeBCD (readCMOS ($32) );π year := ChangeBCD (readCMOS (9) );π month := ChangeBCD (readCMOS (8) );π CASE country OFπ 0, 3..255 :π WorkStr := WorkStr + Monthname [month] + ' ' + Long2Str (date) + ', ' + Long2Str (century) + addzero (year);π 1 :π WorkStr := WorkStr + Long2Str (date) + ', ' + Monthname [month] + ' ' + Long2Str (century) + addzero (Year);π 2 :π WorkStr := WorkStr + Long2Str (century) + addzero (Year) + ', ' + Monthname [month] + ' ' + Long2Str (date);π END; {case}π GetCMosDate := workStr;πEND; { GetCMOSDate }ππ{---------------------------------------------------------------------------}ππFUNCTION GetCmosTime : String30;π{ returns the time as found in the CMOS }πVARπ CH : CHAR;π Hour,π Min,π Sec : BYTE;π WorkStr : String30;π IsPM : BOOLEAN;πBEGINπ workStr := '';π hour := ChangeBCD (readCMOS (4) );π min := ChangeBCD (readCMOS (2) );π sec := ChangeBCD (readCMOS (0) );π IsPm := FALSE;π CASE hour OFπ 0 : hour := 12;π 1..11 : hour := hour;π 12 : IsPM := TRUE;π 13..23 : BEGINπ IsPM := TRUE;π hour := hour - 12π END;π END; {case}π WorkStr := WorkStr + AddZero (hour) + ':' + addzero (min) + ':' + addzero (sec);π IF IsPM THENπ workStr := WorkStr + ' PM'π ELSEπ WorkStr := WorkStr + ' AM';π GetCMOSTime := WorkStr;πEND; { GetCmosTime }ππ{---------------------------------------------------------------------------}ππFUNCTION GetCmosCheckSum : BOOLEAN;π{ performs checksum on CMOS and returns true if ok }πVARπ CheckSum1,π CheckSum2 : WORD;π Count : BYTE;πBEGINπ checksum1 := 0;π FOR count := $10 TO $2D DOπ INC (checksum1, readCMOS (count) );π checksum2 := (WORD (256) * readCMOS ($2E) ) + readCMOS ($2F);π IF checksum1 = checksum2 THENπ GetCmosCheckSum := TRUEπ ELSEπ GetCmosCheckSum := FALSE;πEND; { GetCmosCheckSum }ππ{---------------------------------------------------------------------------}ππPROCEDURE GetCMos;π{ gets the cmos record if it exist }πVARπ Floppy : BYTE;πBEGINπ FILLCHAR (CMOS, SIZEOF (CMos), 0);π regs.AH := $C0;π INTR ($15, regs);π IF nocarry OR (Mem [$F000 : $FFFE] <= $FC) THENπ WITH CMOS DOπ BEGINπ Found := TRUE;π CMOSDate := GetCMOSDate;π CMOSTime := GetCmosTime;π VideoType := ScreenName [ (readCMOS ($14) SHR 4) AND 3];π CoProc := BitIsSet (readCMOS ($14), 1);π Floppy := readCMOS ($10);π IF (Floppy SHR 4) < 5 THENπ FloppyA := FloppyName [floppy SHR 4]π ELSEπ FloppyA := 'Unknown ' + HexL (floppy SHR 4);π IF (floppy AND $0F) < 5 THENπ FloppyB := FloppyName [floppy AND $0F]π ELSEπ FloppyB := 'Unknown ' + HexL (floppy AND $0F);ππ Hard0 := readCMOS ($12);π Hard0 := Hard0 SHR 4;π Hard1 := ReadCmos ($12);π Hard1 := Hard1 AND $0F;π IF Hard0 = $F THENπ Hard0 := readCMOS ($19)π ELSE Hard0 := $FF; { error }π IF Hard1 = $F THENπ Hard1 := readCMOS ($1A)π ELSE Hard1 := $FF;π ConvenRam := WORD (256) * readCMOS ($16) + readCMOS ($15); { value in K }π ExtendRam := WORD (256) * readCMOS ($18) + readCMOS ($17); { value in K }π CheckSum := GetCmosCheckSum;π ENDπ ELSEπ CMOS.Found := FALSE;πEND;ππBEGINπClrScr;πGetCMos;πWith CMOS DOπ BEGINπ WriteLn('Date : ',CMosDate);π WriteLn('Time : ',CMosTime);π WriteLn('Video : ',VideoType);π WriteLn('Math : ',CoProc);π WriteLn('FloppyA : ',FloppyA);π WriteLn('FloppyB : ',FloppyB);π WriteLn('Hard #1 : ',Hard0);π WriteLn('Hard #2 : ',Hard1);π WriteLn('Base Ram : ',ConvenRam,'K');π WriteLn('Ext Ram : ',ExtendRam,'K');π ReadKey;π END;πEND. 37 11-21-9309:30ALL SWAG SUPPORT TEAM FLUSHDOS.PAS IMPORT 12 ┤φǪ PROGRAM FlushDem;ππ FUNCTION DosFlush(VAR F) : BOOLEAN; Assembler;π ASMπ MOV AX, 3000h {get DOS version}π INT 21hπ CMP AL, 3 {DOS < 3? old!}π JL @oldπ CMP AH, 1Eh {DOS < 3.3? old!}π LES DI, Fπ MOV BX, ES:[DI] {file handle is first word}π MOV AH, 68h {commit file function}π INT 21hπ JC @BadEndπ JMP @GoodEndππ @old:π LES DI, Fπ MOV BX, ES:[DI] {file handle is first word}π MOV AH, 45h {duplicate handle function}π INT 21hπ JC @BadEndπ @ok:π MOV BX, AX {put duped handle in BX...}π MOV AH, 3Eh {... and close it}π INT 21hπ JC @BadEndπ @GoodEnd:π MOV AX, 0π @BadEnd:π END;ππVARπ T1, T2 : Text;π S : String;π W : Word;πBEGINπ Assign(T1, 'DEMO1.$$$');π Rewrite(T1);π Assign(T2, 'DEMO2.$$$');π Rewrite(T2);π S := 'This is just a sample line of text.';π FOR W := 1 to 100 DOπ BEGINπ WriteLn(T1, W:4, ' ', S);π WriteLn(T2, W:4, ' ', S);π END;π IF DosFlush(T2) THENπ BEGINπ WriteLn('Successfully flushed the second demo ',π 'file. Please reboot your computer.');π ReadLn;π WriteLn('Hey, I said PLEASE reboot. Oh well... ',π ' I will erase the temporary files.');π Close(T1); Erase(T1);π Close(T2); Erase(T2);π ENDπ ELSE WriteLn('DosFlush routine failed.');πEND. 38 11-21-9309:44ALL HELGE OLAV HELGESEN National Language SupportIMPORT 129 ┤φ4+ π{π Borland Pascal 7.0 National Language Support, with support for protectedπ mode. Written in october 1993 by Helge Olav Helgesenππ The purpose of this unit is to give you the ability to write country-π dependant programs. I won't explain much how it works; since you have theπ source, feel free to explore/change the source.ππ To do so I have a written a colletion of procedures, which are describedπ here:ππ procedure CreateTable(cc: Word);π This one creates a new table with the specified country-code. if youπ specify a value of 0, the default country will be loaded. You shouldπ check for errors thru GetError and PeekError.π procedure DumpTable (const name: string);π This one was written for debugging only, and shoudn't be used. It savesπ the current translation table to the specific fileπ procedure Upper(var s: OpenString);π procedure Lower(var s: OpenString);π These two translates a string into upper or lower case only.π function GetError: word;π function PeekError: word;π These two can be used to get (and clear) the result from lastπ CreateTable. GetError clears ErrorCode afterwards, while PeekErrorπ doesn't.π function Convert2Time(const dt: DateTime): string8;π This one will create a formatted string containing the time specifiedπ in DateTime.Hour, DateTime.Min and DateTime.Sec. The string is formattedπ according to the loaded country.π function Convert2Date(const dt: DateTime): string8;π This one does the same as the one above, except that a date is returnedπ instead.π function ConvertR2Currency(no: real): string;π This one will turn a real value into a formatted string, with the county'sπ currency symbol placed right.π The line 'WriteLn(ConvertR2Currency(1234.123));' will resultπ In USA: $1,234.12π In Norway: Kr 1.234,12π function UpChar(Ch: Char): Char;π function LoChar(Ch: Char): Char;π These two are written with inline statements, and will thus place theπ expanded code into your program's code segment. Since they becameπ fairly large, you shoudn't use them too much.π procedure DumpAllCountries;π This one is only compiled in real mode, and is only intended to use withπ debugging. It writes all countries that is available to the screen.π var Table: TTranslationTable;π This is *the* 256 byte translation table, which contains the mapping toπ upper and lower chars.π var ErrorCode: word;π Result from last CreateTable. This is the Dos error code, as describedπ in 'Run-time error messages'.π var CurrTable: word;π If last CreateTable successed, this contains the country that is loaded.π var UnitOK: boolean;π Is TRUE ifπ 1) Dos 3+ is loadedπ 2) Could allocate real-mode memory (DPMI only)π var CountryInfo: PCountryInfo;π This is a pointer to the current countrys info table. This pointer shouldπ never derefenced unless UnitOK is true. It contains only valid data ifπ (CurrTable>0) and UnitOK!ππ I haven't done much to optimize the code. So even small changes mayπ increase the speed. If you have any comments, suggestion etc. feel freeπ to leave me a note.ππ You can reach me thru the following nets:π ILink - thru Qmail, Programming, ASM and Pascalπ PolarNet - thru Pascal and Postπ Rime - thru Common, Pascal and ASM. I'm located at site MIDNIGHTπ ScanNet - virtually any conferenceπ SourceNet - thru the Pascal conferenceπ WEB - thru the Pascal conferenceππ You may also reach me at the following bulletin boards:π Group One BBS - +1 312 752-1258π Midnight Sun BBS - +47 755 84 545π Programmer's BBS - +47 22 71 41 07ππ In all cases, my name is HELGE HELGESEN. My mail address is:π Helge Olav Helgesenπ Box 726π 8001 BODOEπ Norwayππ Tlf. +47 755 23 694π}π{$S-,B- Do not change these! A change will cause faults! }π{$G+,D+,R-,Q-,L+,O+}π{$IFDEF Windows}Sorry, Windows is not supported...{$ENDIF}ππunit NLS;ππinterfaceππuses {$IFDEF DPMI}WinAPI,{$ENDIF}Dos;ππtypeπ TTranslationTable = array[0..1, 0..127] of char;π AChar = record { ASCIIZ char from Country Info }π Letter: char;π Dummy: byte;π end; { AChar }π PCountryInfo = ^TCountryInfo;π TCountryInfo = recordπ DTFormat: word; { Date/Time format }π CurrSym: array[0..4] of char; { currency symbol }π ThouSep, { thousand separator }π DeciSep, { decimal separator }π DateSep, { date separator }π TimeSep: AChar; { time separator }π CurrFmt: byte; { currency format }π Digits: byte; { digits after decimal }π TimeFmt: boolean; { FALSE=12h else 24h }π CaseMap: pointer; { real mode case map }π DataSep: AChar; { data list separator }π RFU: array[0..9] of byte; { not used }π end; { TCountryInfo }π String8 = string[12];ππvarπ Table: TTranslationTable; { the translation table }π ErrorCode: word; { error code from last create table }π CurrTable: word; { current country loaded, or 0 if none }π UnitOK: boolean; { true if extentions are allowed }π CountryInfo: PCountryInfo; { NB! Protected Mode selector under DPMI! }ππprocedure CreateTable(cp: word);π { -creates new table }πprocedure DumpTable (const name: string);π { -saves table to disk, mainly written for debugging purposes }πprocedure Upper (var s: OpenString);π { -translate string to upper case (A NAME) }πprocedure Lower (var s: OpenString);π { -translate string to lower case (a name) }πfunction GetError: word;π { -get and clear error }πfunction PeekError: word;π { -get error }πfunction Convert2Time(const dt: DateTime): string8;π { -converts time part of DateTime rec info country dep. string }πfunction Convert2Date(const dt: DateTime): string8;π { -converts date part into XX:YY:ZZ country dep. }πfunction ConvertR2Currency(no: real): string;π { -converts real value to currency }πfunction UpChar(Ch: Char): Char;π { -converts char to upper case }πinline($58/ { pop ax }π $88/$c4/ { mov ah, al }π $a8/$80/ { test al, 80h }π $74/$10/ { je @1 }π $8b/$d8/ { mov bx, ax }π $32/$ff/ { xor bh, bh }π $8a/$a7/ { mov ah, [bx+ }π >Table-$80/ { Table-80h] }π $84/$e4/ { test ah, ah }π $74/$0d/ { le @2 }π $88/$e0/ { mov al, ah }π $eb/$09/ { jmp @2 }π{@1:} $f6/$d4/ { not ah }π $f6/$c4/$60/{ test ah, 60h }π $75/$02/ { jne @2 }π $34/$20 { xor al, 20h }π{@2:} );πfunction LoChar(Ch: Char): Char;π { -translates Ch to lower char }πinline($58/ { pop ax }π $a8/$80/ { test al, 80h }π $74/$10/ { le @1 }π $8b/$d8/ { mov bx, ax }π $32/$ff/ { xor bh, bh }π $8a/$a7/ { mov ah, [bx+ }π >Table/ { TABLE] }π $0a/$e4/ { or ah, ah }π $74/$0c/ { je @2 }π $88/$e0/ { mov al, ah }π $eb/$08/ { jmp @2 }π{@1:} $88/$c4/ { mov ah, al }π $a8/$c0/ { test al, 0c0h }π $74/$08/ { je @2 }π $34/$20 { xor al, 20h }π{@2:} );ππ{$IFDEF MSDOS}πprocedure DumpAllCountries;π { -dumps all country codes supported. For debugging. Works only in real mode }π{$ENDIF}ππimplementationππ{$IFDEF DPMI}πtypeπ TBit32 = recordπ Low, High: word;π end; { Bit32 }π TCallRealMode = record { DPMI structure used to call real mode procs }π EDI, ESI, EBP, RFU1, EBX,π EDX, ECX, EAX: TBit32;π Flags, rES, rDS, rFS,π rGS, rIP, rCS, rSP,π rSS: word;π end; { TCallRealMode }ππvarπ ciSelector: TBit32; { selector and segment to CountryInfo }π MyExitProc: pointer; { DPMI exit proc to deallocate Dos memory }π{$ENDIF}ππtypeπ string2 = string[2];π Pstring = ^String;ππfunction Convert2Digit(no: word): string2;πvarπ s: string8;πbeginπ Str(no:2, s);π if s[0]>#2 then delete(s, 1, byte(s[0])-2);π if s[1]=#32 then s[1]:='0';π Convert2Digit:=s;πend; { Convert2Digit }ππ{$IFDEF MSDOS}πprocedure DumpAllCountries;π function TestCountry(no: word): boolean; assembler;π var dummy: TCountryInfo;π asmπ push dsπ mov ax, ssπ mov ds, axπ lea dx, dummyπ mov ax, $38ffπ mov bx, noπ or bh, bhπ je @1π mov al, blπ@1: int $21π pop dsπ jc @xπ xor ax, axπ@x:π end; { DumpAllcountries.TestCountry }πvarπ x: word;πbeginπ for x:=0 to 900 do if not TestCountry(x) then write(x:10);πend; { DumpAllCountries }π{$ENDIF}ππfunction Convert2Time;πconstπ AM: string2 = 'AM';π PM: string2 = 'PM';π function To12(no: word): word;π beginπ if no>12 then To12:=no-12 else To12:=no;π end; { Convert2Time.To12 }π function AmPm(no: word): Pstring;π beginπ if no>12 then AmPm:=@PM else AmPm:=@AM;π end; { Convert2Time.AmPm }πvarπ Delemiter: char;πbegin { Convert2Time }π if UnitOK and (ErrorCode=0) thenπ Delemiter:=CountryInfo^.TimeSep.Letterπ elseπ Delemiter:=':';π if UnitOK and (CurrTable>0) and CountryInfo^.TimeFmt thenπ Convert2Time:=Convert2Digit(dt.Hour)+Delemiter+ { time }π Convert2Digit(dt.Min)+Delemiter+ { min }π Convert2Digit(dt.Sec)π elseπ Convert2Time:=Convert2Digit(To12(dt.Hour))+Delemiter+ { time }π Convert2Digit(dt.Min)+Delemiter+ { min }π Convert2Digit(dt.Sec)+#32+AMPM(dt.Hour)^{ sec }πend; { Convert2Time }ππfunction Convert2Date;πvarπ Dele: char;πbeginπ if UnitOK and (CurrTable>0) thenπ Dele:=CountryInfo^.DateSep.Letterπ elseπ Dele:='/';π if UnitOK and (CurrTable>0) and (CountryInfo^.DTFormat>0) thenπ case CountryInfo^.DTFormat ofπ 1: Convert2Date:=Convert2Digit(dt.Day)+Dele+ { date }π Convert2Digit(dt.Month)+Dele+ { month }π Convert2Digit(dt.Year); { year }π 2: Convert2Date:=Convert2Digit(dt.Year)+Dele+ { year }π Convert2Digit(dt.Month)+Dele+ { month }π Convert2Digit(dt.Day);π end { case }π else { if }π Convert2Date:= Convert2Digit(dt.Month)+Dele+ { month }π Convert2Digit(dt.Day)+Dele+ { day }π Convert2Digit(dt.Year); { year }πend; { Convert2Time }ππfunction ConvertR2Currency;π function GetCurrency: string8;π varπ s: string8;π beginπ s:=CountryInfo^.CurrSym;π while s[byte(s[0])]=#0 do dec(s[0]);π GetCurrency:=s;π end; { ConvertR2Currency.GetCurrency }π function FormatString(s: string): string;π varπ Comma, Digits: byte;π c: integer;π Dele: char;π beginπ Dele:=CountryInfo^.ThouSep.Letter; { get thousand delemiter }π Digits:=Pos('.', s); { digits before delemither }π Comma:=Digits; { save comma position }π if Digits=0 then Digits:=Length(s)+1; { start rightmost if no comma }π c:=Digits-3; { init counter }π while c>2 doπ beginπ Insert(Dele, s, c); { insert thousand delemither }π Dec(c, 3); { adjust pointer }π if Comma>0 then Inc(Comma); { increase comma position(if any) }π end; { while }π if Comma>0 then { adjust comma, if any }π s[Comma]:=CountryInfo^.DeciSep.Letter;π FormatString:=s;π end; { ConvertR2Currency.FormatString }π function PlaceCurrency(s: string): string;π varπ x: byte;π beginπ x:=Pos(CountryInfo^.DeciSep.Letter, s);π Delete(s, x, 1);π Insert(GetCurrency, s, x);π PlaceCurrency:=s;π end; { ConvertR2Currency.PlaceCurrency }πvarπ s: string[20];πbegin { ConvertR2Currency }π if UnitOK and (CurrTable>0) thenπ beginπ Str(no:20:CountryInfo^.Digits, s);π while s[1]=#32 do delete(s, 1, 1);π s:=FormatString(s);π endπ elseπ beginπ Str(no:20:2, s);π while s[1]=#32 do delete(s, 1, 1);π end; { if/else }π if UnitOK and (CurrTable>0) thenπ case CountryInfo^.CurrFmt ofπ 0: s:=GetCurrency+s;π 1: s:=s+GetCurrency;π 2: s:=GetCurrency+#32+s;π 3: s:=s+#32+GetCurrency;π 4: s:=PlaceCurrency(s);π end; { case }π ConvertR2Currency:=s;πend; { ConvertR2Currency }ππprocedure DumpTable;πvarπ f: file of TTranslationTable;πbeginπ assign(f, name);π rewrite(f);π write(f, Table);π close(f);πend;ππprocedure CreateTable;πvarπ b: byte;π c, d: char;π procedure GetCountryInfo(cp: word);π varπ r: Registers;π beginπ r.AX:=$38FF;π if cp>255 then r.BX:=cp else r.AL:=Lo(cp);π r.DS:=Seg(CountryInfo^);π r.DX:=Ofs(CountryInfo^);π MsDos(r);π if r.Flags and 1=1 then ErrorCode:=r.AX;π if ErrorCode=0 then CurrTable:=r.BX else CurrTable:=0;π end; { CreateTable.GetCoutryInfo }π function CallCaseMap(Letter: char): char; assembler;π{$IFNDEF MSDOS}π varπ regs: TCallRealMode;π{$ENDIF}π asmπ mov al, Letterπ {$IFNDEF MSDOS}π mov word ptr regs.EAX, axπ mov regs.rSP, 0π mov regs.rSS, 0π les di, CountryInfoπ mov ax, word ptr es:[di].TCountryInfo.CaseMapπ mov regs.RIP, axπ mov ax, word ptr es:[di].TCountryInfo.CaseMap+2π mov regs.RCS, axπ mov ax, ssπ mov es, axπ lea di, regsπ xor cx, cxπ mov ax, $301π int $31 { execute real mode proc }π mov ax, word ptr regs.EAXπ {$ELSE}π les di, CountryInfoπ call es:[di].TCountryInfo.CaseMapπ {$ENDIF}π end; { CreateTable.CallCaseMap }π procedure MapIn(NewChar, OldChar: char);π beginπ Table[0, byte(OldChar) and $7f]:=NewChar;π Table[1, byte(NewChar) and $7f]:=OldChar;π end; { CreateTable.MapIn }πbegin { CreateTable }π if (ErrorCode>0) or not UnitOK then exit; { leave if any pending error }π FillChar(Table, sizeof(Table), 0);π GetCountryInfo(cp);π if ErrorCode>0 then exit; { leave if any error occured }π for b:=0 to 127 doπ beginπ c:=CallCaseMap(char(b+128));π if c<>char(b+128) then MapIn(c, char(b+128));π end; { for }πend; { CreateTable }ππprocedure UpCase; assembler;π{π This translates the incoming char in AL into upper case if it is definedπ in the translation table.π Please note that if you enable stack checking, this proc won't work...π}πasmπ test al, $80π je @1π xor ah, ahπ mov bx, axπ mov ah, byte[Table+bx-$80]π test ah, ahπ je @xπ mov al, ahπ jmp @xπ@1:π cmp al, 'z'π jg @xπ cmp al, 'a'π jl @xπ xor al, $20π@x:πend; { UpChar }ππprocedure LowChar; assembler;πasmπ test al, $80π je @1π mov bx, axπ xor bh, bhπ mov ah, byte[Table+bx]π or ah, ahπ je @xπ mov al, ahπ jmp @xπ@1:π cmp al, 'Z'π jg @xπ cmp al, 'A'π jl @xπ xor al, $20π@x:πend; { LowChar }ππprocedure Upper; assembler;πasmπ les di, sπ mov cl, es:[di]π xor ch, chπ jcxz @xπ inc diπ@1:π mov al, es:[di]π call UpCaseπ mov es:[di], alπ inc diπ loop @1π@x:πend; { Upper }ππprocedure Lower; assembler;πasmπ les di, sπ mov cl, es:[di]π xor ch, chπ jcxz @xπ inc diπ@1:π mov al, es:[di]π call LowCharπ mov es:[di], alπ inc diπ loop @1π@x:πend; { Lower }ππfunction GetError; assembler;πasmπ mov ax, ErrorCodeπ mov ErrorCode, 0πend; { GetError }ππfunction PeekError; assembler;πasmπ mov ax, ErrorCodeπend; { PeekError }ππ{$IFNDEF MSDOS}πprocedure Leave; far;πbeginπ ExitProc:=MyExitProc; { change to old handler }π GlobalDosFree(ciSelector.High); { release Dos memory }πend; { Leave }ππprocedure InitExitProc;πbeginπ MyExitProc:=ExitProc; { save old handler }π ExitProc:=@Leave; { save my own handler }πend; { InitExitProc }π{$ENDIF}ππbegin { NLS }π UnitOk:=Lo(DosVersion)>=3; { does only work for Dos 3+ }π if UnitOK then { allocate memory }π beginπ {$IFDEF DPMI}π longint(ciSelector):=GlobalDosAlloc(sizeof(TCountryInfo));π if ciSelector.Low=0 then UnitOK:=False; { if not enough Dos memory }π CountryInfo:=Ptr(ciSelector.Low, 0); { make protected mode pointer }π if UnitOK then InitExitProc; { change exit proc }π {$ELSE}π if MaxAvail>sizeof(CountryInfo^) then{ allocate if enough memory }π New(CountryInfo)π elseπ UnitOK:=False; { or disable extentions }π {$ENDIF}π end; { if UnitOK }πend.π 39 11-26-9317:04ALL MARUIS ELLEN DOS Environment Unit IMPORT 103 ┤φ├ {πFrom: MARIUS ELLENπSubj: DOS Environmentπ}ππProgram Environment;π{$M $1000,32776,32776 }π{ 1K stack, 32k+8 bytes heap }π{$T- No @ Typed checking}π{$X+ Extended function syntax}π{$Q- No overflow checking}π{$A+ Word align data}π{$S+ Stack checking}ππusesππ dos,π strings;ππtypeππ PJFTRec = ^TJFTRec;π TJFTRec = recordπ JFTtable : array[1..20] of byte;π end;πππ PMCBrec = ^TMCBrec;π TMCBrec = recordπ Next : char; {4d "M", of 5a "Z"}π PSPOwner : word;π Length : word;π Filler : array[0..10] of byte;π end;πππ PPSPrec = ^TPSPrec;π TPSPrec = record {ofs, length }π INT20 :word; {00h 2 BYTEs INT 20 instruction for CP/M CALL 0π program termination the CDh 20hπ here is often used as a signatureπ for a valid PSP }π FreeSeg :word; {02h WORD segment of first byte beyondπ memory allocated to program}π UnUsed04:byte; {04h BYTE unused filler }π CMPCall :byte; {05h BYTE CP/M CALL 5 service requestπ (FAR JMP to 000C0h) BUG: (DOS 2+)π PSPs created by INT 21/AH=4Bhπ point at 000BEh}π CPMSize :word; {06h WORD CP/M compatibility--size ofπ first segment for .COM files}π CPMrem :word; {08h 2 BYTEs remainder of FAR JMP at 05h}π INT22 :pointer; {0Ah DWORD stored INT 22 termination address}π INT23 :pointer; {0Eh DWORD stored INT 23 control-Break addr.}π INT24 :pointer; {12h DWORD DOS 1.1+ stored INT 24 address}π ParPSP :word; {16h WORD segment of parent PSP}π JFT :TJFTRec; {18h 20 BYTEs DOS 2+ Job File Table, one byteπ per file handle, FFh = closed}π SEGEnv :word; {2Ch WORD DOS 2+ segment of environmentπ for process}π SSSP :pointer; {2Eh DWORD DOS 2+ process's SS:SP on entryπ to last INT 21 call}π JFTCount:word; {32h WORD DOS 3+ number of entries in JFTπ (default is 20)}π JFTPtr :pointer; {34h DWORD DOS 3+ pointer to JFTπ (default PSP:0018h)}π PrevPSP :pointer; {38h DWORD DOS 3+ pointer to previous PSPπ (default FFFFFFFFh in 3.x)π used by SHARE in DOS 3.3}π UnUsed3c:byte; {3Ch BYTE apparently unused by DOSπ versions <= 6.00}π UnUsed3d:byte; {3Dh BYTE apparently used by some versionsπ of APPEND}π NovFlag :byte; {3Eh BYTE (Novell NetWare) flag: next byteπ initialized if CEh}π NovTask :byte; {3Fh BYTE (Novell Netware) Novell taskπ number if previous byte is CEh}π DosVers :word; {40h 2 BYTEs DOS 5+ version to return onπ INT 21/AH=30h}π NextPSP :word; {42h WORD (MSWin3) selector of next PSPπ (PDB) in linked list. Windowsπ keeps a linked list of Windowsπ programs only}π UnUsed44:pointer; {44h 4 BYTEs unused by DOS versions <= 6.00}π WinFlag :byte; {48h BYTE (MSWindows3) bit 0 set if non-π Windows application (WINOLDAP)}π UnUsed49:string[6]; {49h 7 BYTEs unused by DOS versions <= 6.00}π RETF21 :string[2]; {50h 3 BYTEs DOS 2+ service request (INTπ 21/RETF instructions)}π UnUsed53:word; {53h 2 BYTEs unused in DOS versions <= 6.00}π UnUsed55:string[6]; {55h 7 BYTEs unused in DOS versions <= 6.00;π can be used to make first FCBπ into an extended FCB }π FCB1 :string[15]; {5Ch 16 BYTEs first default FCB, filled inπ from first commandline argumentπ overwrites second FCB if opened}π FCB2 :string[15]; {6Ch 16 BYTEs second default FCB, filled inπ from second commandlineπ argument, overwrites beginningπ of commandline if opened}π UnUsed7c:pointer; {7Ch 4 BYTEs unused}π DTAArea :string[127];{80h 128 BYTEs commandline / default DTAπ command tail is BYTE for lengthπ of tail, N BYTEs for the tail,π followed by a BYTE containingπ 0Dh}π end;πππ PMCBPSPrec = ^TMCBPSPrec;π TMCBPSPrec = recordπ MCB :TMCBRec;π PSP :TPSPRec;π end;ππvarππ MainEnvSeg:word;π MainEnvSize:word;πππ{$ifndef TryAssembler}π {Find DOS master environment, command/4dos etc...}π procedure GetMainEnvironment(var envseg,envsize:word);π var R:PMCBPSPrec;π Rrec:array[0..1] of word absolute R;π beginπ asmπ mov ah,52h {Get First MCB, }π int $21 {DOS Memory Control Block (MCB)}π mov ax,es:[bx-2] {Bevind zich 2 terug}π mov R.word[0],0 {Offset is altijd 0}π mov R.word[2],ax {MCB:=first DOS mcb}π end;ππ while true do beginπ if pos(R^.mcb.next,'MZ')=0π then halt(7); {Memory control block destroyed}ππ if R^.mcb.PSPOwner=R^.PSP.ParPSP then begin {found}π EnvSeg :=R^.PSP.SegEnv;π R:=Ptr(EnvSeg-1,0);π EnvSize:=R^.mcb.length shl 4;π if EnvSize>32767π then halt(10); {Environment invalid (usually >32K)}π exit;π end;π if R^.mcb.next='Z'π then halt(9); {Memory block address invalid}π {Er moet een environment zijn!}π R:=ptr((Rrec[1]+(R^.mcb.length)+1),0);π end;π end;πππ{$else}π procedure HaltIndirect(error:word);π beginπ halt(error);π end;πππ {Find DOS master environment, command/4dos etc...}π procedure GetMainEnvironment(var envsegP,envsizeP:word);π assembler;π var mcb:pointer;π asmπ mov ah,52h {Get First MCB, }π int $21 {DOS Memory Control Block (MCB)}π sub bx,2π xor dx,dx {offset altijd 0000}π mov ax,es:[bx]π mov mcb.word[0],dxπ mov mcb.word[2],ax {MCB:=first DOS mcb}ππ @repeat:π les di,mcbπ mov bl,es:[di]π cmp bl,4dHπ je @MCBOkπ cmp bl,5aH {was het de laatste MCB}π jne @MCBError {zo ja dan halt(9)}π @MCBOk:π mov ax,es:[01h] {is segment v/h prg bij deze MCB}π cmp ax,es:[26h] {gelijk aan EnvSegment van het prg}π je @found {zo ja dan is ie gevonden}ππ cmp bl,5ah {is dit de laatste mcb ?}π je @MCBMissing {!?!? MCB main env weg!?!?}π les di,mcb {volgende MCB zit op}π mov ax,es {oude MCB+next}π add ax,es:[3] {+volgende}π inc ax {+1}π mov mcb.word[2],axπ jmp @repeat {herhaal tot gevonden}ππ @MCBError:π mov al,7 {Memory control block destroyed}π db 0a9h {skip next mov al,xx=opcode test ax,w}π @MCBMissing:π mov al,9 {Memory block address invalid}π db 0a9h {kan ook environment not found zijn!}π @SizeErr:π mov al,10 {Environment invalid (usually >32K)}π push axπ call HaltIndirectππ @found:π mov ax,es:[3ch] {Get segment environment}π mov dx,es {save es}π les di,EnvSegP {ptr van VAR parameter}π mov es:[di],ax {Store environment segment}π mov es,dx {rest es}ππ dec ax {MCB van env. is 1 paragraaf terug}π mov es,ax {Get Size van env. uit MCB}π mov ax,es:[3] {deze is in paragrafen}π mov cl,4 {en wordt geconverteerd}π shl ax,cl {naar bytes..}ππ les di,EnvSizeP {ptr van VAR parameter}π mov es:[di],ax {Store environment size}π cmp ax,32768 {size moet <32k}π jae @SizeErr {anders een foutmelding}π end;π{$endif}ππ {Seperate Variable and return parameters}π function StripEnvVariable(Variable:pchar):pchar;π const stop='='#32#0;π beginπ While pos(Variable^,stop)=0 do inc(Variable);π StripEnvVariable:=Variable+1;π Variable^:=#0;π end;πππ {like bp's getenv, this time removing spaces}π function GetMainEnv(variable:string):string;π var MainPtr,Params:pchar;π data:array[0..512] of char;π beginπ MainPtr:=ptr(MainEnvSeg,0);π StrPCopy(@variable,variable);π StrUpper(@variable);π StripEnvVariable(@variable);ππ if variable[0]<>#0 then beginπ while (MainPtr^<>#0) do beginπ StrCopy(Data,MainPtr);π Params:=StripEnvVariable(data);π if StrComp(Data,@Variable)=0 then beginπ GetMainEnv:=StrPas(Params);π exit;π end;π MainPtr:=StrEnd(MainPtr)+1;π end;π end;π GetMainEnv:='';π end;πππ {like bp's EnvCount}π function MainEnvCount:integer;π var MainPtr:pchar;π index:integer;π beginπ index:=0;π MainPtr:=ptr(MainEnvSeg,0);π while (MainPtr^<>#0) do beginπ MainPtr:=StrEnd(MainPtr)+1;π inc(index);π end;π MainEnvCount:=index;π end;πππ {like bp's EnvStr}π function MainEnvStr(index:integer):string;π var MainPtr:pchar;π beginπ MainPtr:=ptr(MainEnvSeg,0);π while (MainPtr^<>#0) do beginπ dec(index);π if index=0 then beginπ MainEnvStr:=StrPas(MainPtr);π exit;π end;π MainPtr:=StrEnd(MainPtr)+1;π end;π MainEnvStr:='';π end;πππ {change environment "variable", returning succes}π function MainEnvChange(variable:string; param:string):boolean;π var data:array[0..512] of char;π Mem,MainPtr,EnvPtr:pchar;π NewSize:word absolute EnvPtr;π EnvPtrLong:^Longint absolute EnvPtr;πππ procedure EnvStrCopy(src:pchar);π beginπ if NewSize+StrLen(src)<=MainEnvSize-4π then beginπ StrCopy(EnvPtr,Src);π EnvPtr:=StrEnd(EnvPtr)+1;π endπ else MainEnvChange:=false;π end;ππ procedure PutVariable;π beginπ if (Variable[0]<>#0) and (param[0]<>#0) then beginπ StrCopy(Data,@variable);π StrCat(Data,'=');π StrCat(Data,@param);π EnvStrCopy(Data);π variable[0]:=#0;π end;π end;ππ beginπ getmem(Mem,MainEnvSize);π MainPtr:=ptr(MainEnvSeg,0);π EnvPtr:=Mem;ππ StrPCopy(@variable,variable);π StrUpper(@variable);π StripEnvVariable(@variable);π StrPCopy(@param,param);π MainEnvChange:=variable[0]<>#0;ππ while MainPtr^<>#0 do beginπ StrCopy(Data,MainPtr);π StripEnvVariable(data);π if StrComp(Data,@Variable)=0π then PutVariableπ else EnvStrCopy(MainPtr);π MainPtr:=StrEnd(MainPtr)+1;π end;ππ if variable[0]<>#0π then PutVariable;ππ EnvPtrLong^:=0; {4 terminating zero's}π {1 byte terminating environment}π {2 word counting trailing strings}π {1 byte terminating the strings}π {. last three disables paramstr(0)}π move(Mem^,Ptr(MainEnvSeg,0)^,NewSize+4);π freeMem(Mem,MainEnvSize);π end;πππvar oldprmp:string;πbeginπ GetMainEnvironment(MainEnvSeg,MainEnvSize);π memw[prefixseg:$2c]:=MainEnvSeg;ππ oldprmp:=GetMainEnv('fprompt');π MainEnvChange('prompt','Please type EXIT!'#13#10+'$p$g');ππ swapvectors;π exec(GetMainEnv('comspec'),'');π swapvectors;ππ MainEnvChange('prompt',oldprmp);πend.π 40 01-27-9411:59ALL RUUD UPHOFF Environment Settings IMPORT 19 ┤φg┌ {π> Who has PTENV.PASππHere is how it works:π}πUNIT SetEnvir;ππINTERFACEπππUSESπ DOS;πππTYPEπ EnvSize = 0..16383;πππPROCEDURE SetEnv(EnvVar, Value : STRING);ππ{-----------------------------------------------------------------------π This procedure may be used to setup or change environment variablesπ in the environment of the resident copy of COMMAND.COM or 4DOS.COMππ Note that this will be the ACTIVE copy of the command interpreter, NOTπ the primary copy!ππ This unit is not tested under DR-DOS.ππ Any call of SetEnv must be followed by checking ioresult. The procedureπ may return error 8 (out of memory) on too less space in te environment.π-----------------------------------------------------------------------}ππIMPLEMENTATIONππPROCEDURE SetEnv(EnvVar, Value : STRING);πVARπ Link,π PrevLink,π EnvirP : word;π Size,π Scan,π Where,π Dif : integer;π NewVar,π OldVar,π Test : STRING;ππ FUNCTION CheckSpace(Wanted : integer) : boolean;π BEGINπ IF wanted + Scan > Size THENπ inoutres := 8;π CheckSpace := inoutres = 0;π END;ππBEGINπ IF inoutres >0 THENπ Exit;π FOR Scan := 1 TO Length(EnvVar) DOπ EnvVar[Scan] := UpCase(EnvVar[Scan]);π EnvVar := EnvVar + '=';π NewVar := EnvVar + Value + #0;π link := PrefixSeg;ππ REPEATπ PrevLink := Link;π Link := memw [link : $16];π UNTIL Link = prevlink;ππ EnvirP := memw [Link : $2C];π Size := memw [Envirp - 1 : $03] * 16;π Scan := 0;π Where := -1;π WHILE mem[EnvirP : Scan] <> 0 DOπ BEGINπ move(mem[EnvirP : scan], Test[1], 255);π Test[0] := #255;π Test[0] := chr(pos(#0, Test));π IF pos(EnvVar, Test) = 1 THENπ BEGINπ Where := Scan;π OldVar := Test;π END;π Scan := Scan + Length(Test);π END;ππ IF Where = -1 THENπ BEGINπ Where := Scan;π NewVar := NewVar + #0#0#0;π IF NOT CheckSpace(Length(NewVar)) THENπ Exit;π ENDπ ELSEπ BEGINπ Dif := Length(NewVar) - Length(OldVar);π IF Dif > 0 THENπ BEGINπ IF NOT CheckSpace(Dif) THENπ Exit;π move(mem[EnvirP : Where], mem[EnvirP : Where + Dif], Scan - Where + 3);π ENDπ ELSEπ IF Dif < 0 THENπ move(mem[EnvirP : Where - Dif], mem[EnvirP : Where], Size - Where + Dif);π END;ππ move(NewVar[1], mem[EnvirP : Where], Length(NewVar));πEND;ππEND.ππ 41 01-27-9412:01ALL DESCLIN JEAN Disk Ready? IMPORT 32 ┤φ , {π some days ago, Bryan Ellis (gt6918b@prism.gatech.edu)π asked how one could, in TP, check whether a disk in aπ drive is formatted or not. I did not see any answer onπ this posted to the list, so here comes an 'extract' fromπ code of mine which might help.ππ{ The following two procedures were extracted from old fileπ copy programs of mine; Therefore they should be 'cleaned-up'π and fixed up before being included in somebody's code.π The purpose of the first one is to ensure that:π a) the target disk (to be written to) is indeedπ present in the drive;π b) the target disk is a formatted one. If it isπ not, then opportunity is provided for formatting byπ shelling to DOS (rather clumsy, but you get the idea ;-)).ππ The purpose of the second procedure is partly redundantπ with that of the first one. It checks whether the diskπ is present in the drive, and it also warns when the diskπ is write protected.π Calls to ancillary procedures for putting the cursor ontoπ the right column and row on the screen, or to clean upπ the display, save and restore the screen, or warning noisesπ etc., were removed, which explains the somewhat desultoryπ code, which I had no time to rewrite :-( }ππ { uses DOS,CRT; }ππProcedure CheckDriv(driv : string; var OK:boolean;π var cc:char );π{* driv is the string holding the letter of the drive; *}π{* OK is a global boolean var which must be true in order for *}π{* the rest of the program to proceed. *}π{* cc : checks input by the user *}π{***************************************************************}πvar IOR : integer;π jk,dr : char;π S : string;π CmdLine: PathStr;πbeginπ OK := TRUE;π IOR := 0;π{$I-}π ChDir(driv); { make the target drive current }π { the original current drive letter should be saved in order}π { to be restored afterwards }π dr := upcase(driv[1]);π IOR := IOresult;π if IOR = 152 then beginπ OK := FALSE;π writeln('No disk in ',copy(driv,1,2));π writeln(' (Insert a disk or press ESC)');π repeat until keypressed;π cc := readkeyπ endπ elseπ if IOR = 162 then beginπ OK := FALSE;π writeln('Unformatted disk in ',copy(driv,1,2));π writeln('Press ESC to cancel...');π writeln('...or press ''*'' to format...');π repeat until keypressed;π cc := readkey;π { here, for security sake, only drives A and B were takenπ into account for writing }π if ((cc = '*') AND ((dr = 'A') OR (dd = 'B'))) thenπ beginπ cc := chr(27);π { now, your Format.com file had better be in the path! }π S := FSearch('FORMAT.COM', GetEnv('PATH'));π S := FExpand(S);π CmdLine := copy(driv,1,2);π SwapVectors;π Exec(S,CmdLine);π SwapVectors;π If DosError <> 0 thenπ write('Dos error #',DosError)π elseπ write('Press any key...');π repeat until keypressed;π jk := readkey;π endπ endπend;π{$I+}ππProcedure CheckWrite(var FF: file;π var OK: boolean;π var cc: char);π{* Tests for presence of disk in drive and write protect tab, *}π{* to allow opening of untyped file for write: this file has *}π{* of course been assigned before, elsewhere in the program *}π{****************************************************************}π{$I-}πvar riteprot : boolean;π DiskAbsent : boolean;π error : integer;πbeginπ riteprot := TRUE;π DiskAbsent := TRUE;π rewrite(FF);π error := IOResult;π riteprot := error = 150;π DiskAbsent := error = 152;π if riteprot then beginπ writeln('Disk is write protected!');π writeln('Correct the situation and press any key...');π repeat until keypressed;π cc := readkeyπ end;π if DiskAbsent then beginπ writeln('No disk in the drive!');π writeln('Insert disk into drive, then press any key...');π repeat until keypressed;π cc := readkeyπ end;π OK := (Not(riteprot)) AND (Not(DiskAbsent))πend;π{$I+}π 42 01-27-9412:20ALL PETER GEDECK Relative paths IMPORT 16 ┤φ)F {πbcp100@cd4680fs.rrze.uni-erlangen.de (Peter Gedeck)ππ: Does anyone have a relative path routine? An example of what I mean by aπ: relative path routine is the Turbo Pascal IDE's editor window titles. Itπ: only displays as much of the files path name as is necessary. It should beπ: something likeπ: function RelativePath(FullPath: string): string;ππThis is what I use to get a relative file name. I think it works correctlyπand hope you will find it useful.π}ππUsesπ Dos;πππfunction GetCurDir : DirStr;πvarπ CurDir : DirStr;πbeginπ GetDir(0, CurDir);π GetCurDir := CurDir;πend;πππfunction GetCurDrive : Char; assembler;πasmπ MOV AH,19Hπ INT 21Hπ ADD AL,'A'πend;πππfunction GetRelativeFileName(F : String) : String;πvarπ D : DirStr;π N : NameStr;π E : ExtStr;π i : integer;π rd : string;ππbeginπ F := FExpand(F);π FSplit(F, D, N, E);π if GetCurDrive = D[1] thenπ beginπ { Same Drive - remove Driveinformation from D }π Delete(D, 1, 2);π F := GetCurDir + '\';π Delete(F, 1, 2);π { Maybe it is a file in a directory higher than the actual directory }π i := Pos(F, d);π if i > 0 thenπ Delete(d, 1, length(F))π elseπ beginπ rd := '';π if Pos(d, F) = 0 thenπ repeatπ repeatπ rd := d[Ord(d[0])] + rd;π dec(d[0]);π until d[Ord(d[0])] = '\';π until Pos(d, F) > 0;ππ { Maybe it is a file in a directory lower than the actual directory }π if Pos(d, F) > 0 thenπ beginπ repeatπ rd := '..\' + rd;π dec(F[0]);π while F[Ord(F[0])] <> '\' doπ dec(F[0]);π until (Pos(d, F) > 0) and not ((d = '\') and (F <> '\'));π d := rd;π end;π end;π end;π GetRelativeFileName := (D + N + E);πend;πππbeginπ Writeln(GetRelativeFileName('C:\qmpro\dl\bp\lib\ansi.pas'));πend. 43 01-27-9417:37ALL SWAG SUPPORT TEAM Critical Error Handler IMPORT 162 ┤φ▓σ {$I- $F+}πUNIT Errtrp;πINTERFACEππUSESπcrt,πdos;ππCONSTπScrSeg : WORD = $B800;πFGNorm = lightgray;πBGNorm = blue;πFGErr = white;πBGErr = red;ππVARπSaveInt24 : POINTER;πErrorRetry : BOOLEAN;πIOCode : INTEGER;πversion : INTEGER;ππPROCEDURE DisplayError (ErrNo : INTEGER);πPROCEDURE RuntimeError;πPROCEDURE DisableErrorHandler;πPROCEDURE ErrTrap (ErrNo : INTEGER);πππIMPLEMENTATIONπππVARπ ExitSave : POINTER;π regs : REGISTERS;πππ(**************************************************************************)ππCONSTπ INT59ERROR : INTEGER = 0;π ERRORACTION : BYTE = 0;π ERRORTYPE : BYTE = 0;π ERRORAREA : BYTE = 0;π ERRORRESP : BYTE = 0;π ERRORRESULT : INTEGER = 0;ππTYPEπerrmsg = ARRAY [0..89] OF STRING;πermsgPtr = ^errmsg;ππVARπErrs : ermsgPTR;ππPROCEDURE HideCursor; Assembler;πAsmπ MOV ax, $0100π MOV cx, $2607π INT $10πEND;ππPROCEDURE ShowCursor; Assembler;πAsmπ MOV ax, $0100π MOV cx, $0506π INT $10πEND;πππPROCEDURE box;πVARπ i : INTEGER;πBEGINπ TEXTCOLOR (FGErr);π TEXTBACKGROUND (BGErr);π GOTOXY (1, 1);π WRITELN ('┌─────────────── Critical Error ───────────────┐');π FOR i := 1 TO 5 DOπ WRITELN ('│ │');π WRITE ('└────────────────────────────────────────────────┘');πEND;{box}ππFUNCTION DosVer : INTEGER;πVARπ Maj : shortint;π Min : shortint;π regs : REGISTERS;ππBEGINπ regs.ah := $30;π MSDOS (Regs);π Maj := regs.al;π Min := regs.ah;π DosVer := Maj;πEND;ππPROCEDURE InitErrs;πBEGINπNEW (Errs);πErrs^ [0] := ' No error occured ';πErrs^ [1] := ' Invalid function number ';πErrs^ [2] := ' File not found ';πErrs^ [3] := ' Path not found ';πErrs^ [4] := ' No handle available ';πErrs^ [5] := ' Access denied ';πErrs^ [6] := ' Invalid handle ';πErrs^ [7] := ' Memory control blocks destroyed ';πErrs^ [8] := ' Insufficient memory ';πErrs^ [9] := ' Invalid memory block address ';πErrs^ [10] := ' Invalid SET command string ';πErrs^ [11] := ' Invalid format ';πErrs^ [12] := ' Invalid access code ';πErrs^ [13] := ' Invalid data ';πErrs^ [14] := ' Reserved ';πErrs^ [15] := ' Invalid drive specification ';πErrs^ [16] := ' Attempt to remove current directory ';πErrs^ [17] := ' Not same device ';πErrs^ [18] := ' No more files to be found ';πErrs^ [19] := ' Disk write protected ';πErrs^ [20] := ' Unknown unit ID ';πErrs^ [21] := ' Disk drive not ready ';πErrs^ [22] := ' Command not defined ';πErrs^ [23] := ' Disk data error ';πErrs^ [24] := ' Bad request structure length ';πErrs^ [25] := ' Disk seek error ';πErrs^ [26] := ' Unknown disk media type ';πErrs^ [27] := ' Disk sector not found ';πErrs^ [28] := ' Printer out of paper ';πErrs^ [29] := ' Write error - Printer Error? ';πErrs^ [30] := ' Read error ';πErrs^ [31] := ' General failure ';πErrs^ [32] := ' File sharing violation ';πErrs^ [33] := ' File locking violation ';πErrs^ [34] := ' Improper disk change ';πErrs^ [35] := ' No FCB available ';πErrs^ [36] := ' Sharing buffer overflow ';πErrs^ [37] := ' Reserved ';πErrs^ [38] := ' Reserved ';πErrs^ [39] := ' Reserved ';πErrs^ [40] := ' Reserved ';πErrs^ [41] := ' Reserved ';πErrs^ [42] := ' Reserved ';πErrs^ [43] := ' Reserved ';πErrs^ [44] := ' Reserved ';πErrs^ [45] := ' Reserved ';πErrs^ [46] := ' Reserved ';πErrs^ [47] := ' Reserved ';πErrs^ [48] := ' Reserved ';πErrs^ [49] := ' Reserved ';πErrs^ [50] := ' Network request not supported ';πErrs^ [51] := ' Remote computer not listening ';πErrs^ [52] := ' Duplicate name on network ';πErrs^ [53] := ' Network name not found ';πErrs^ [54] := ' Network busy ';πErrs^ [55] := ' Network device no longer exists ';πErrs^ [56] := ' NetBIOS command limit exceeded ';πErrs^ [57] := ' Network adapter hardware error ';πErrs^ [58] := ' Incorrect response from network ';πErrs^ [59] := ' Unexpected network error ';πErrs^ [60] := ' Incompatible remote adapter ';πErrs^ [61] := ' Print queue full ';πErrs^ [62] := ' Not enough space for print file ';πErrs^ [63] := ' Print file was deleted ';πErrs^ [64] := ' Network name was deleted ';πErrs^ [65] := ' Access denied ';πErrs^ [66] := ' Network device type incorrect ';πErrs^ [67] := ' Network name not found ';πErrs^ [68] := ' Network name limit exceeded ';πErrs^ [69] := ' NetBIOS session limit exceeded ';πErrs^ [70] := ' Temporarily paused ';πErrs^ [71] := ' Network request not accepted ';πErrs^ [72] := ' Print or disk re-direction is paused ';πErrs^ [73] := ' Reserved ';πErrs^ [74] := ' Reserved ';πErrs^ [75] := ' Reserved ';πErrs^ [76] := ' Reserved ';πErrs^ [77] := ' Reserved ';πErrs^ [78] := ' Reserved ';πErrs^ [79] := ' Reserved ';πErrs^ [80] := ' File already exists ';πErrs^ [81] := ' Reserved ';πErrs^ [82] := ' Cannot make ';πErrs^ [83] := ' Critical-error interrupt failure ';πErrs^ [84] := ' Too many redirections ';πErrs^ [85] := ' Duplicate redirection ';πErrs^ [86] := ' Duplicate password ';πErrs^ [87] := ' Invalid parameter ';πErrs^ [88] := ' Network data fault ';πErrs^ [89] := ' Undefined Error ';πEND;ππPROCEDURE CritError (Flags, CS, IP, AX, BX, CX, DX, SI, DI, DS, ES, BP : WORD);π INTERRUPT;πTYPEπScrPtr = ^ScrBuff;πScrBuff = ARRAY [1..4096] OF BYTE;ππVARπ Display,π SaveScr : ScrPtr;ππ c : CHAR;π ErrorPrompt,π msg : STRING;π ErrNum : BYTE;ππ drive,π area,π al, ah : BYTE;ππ deviceattr : ^WORD;π devicename : ^CHAR;π ch,π i : shortint;π actmsg,π tmsg,π amsg,π dname : STRING;πBEGINπ ah := HI (ax);π al := LO (ax); { in case DOS version < 3 }π ErrNum := LO (DI) + 19; { save the error and add }π msg := Errs^ [ErrNum]; { add 19 to convert to }π { standard DOS error }π tmsg := '';π actmsg := ''; { we can't suggest a response }ππ IF (ah AND $80) = 0 THEN { if a disk error then }π BEGIN { get the drive and area }π amsg := ' drive ' + CHR (al + 65) + ':';π area := (ah AND 6) SHR 1;π CASE area OFπ 0 : amsg := amsg + ' dos communications area ';π 1 : amsg := amsg + ' disk directory area ';π 2 : amsg := amsg + ' files area ';π END;π ENDπELSE { else if a device error }π BEGIN { get type of device }π deviceattr := PTR (bp, si + 4);π i := 0;π IF (deviceattr^ AND $8000) <> 0 THEN { if a character device }π BEGIN { like a printer }π amsg := 'character device';π ch := 0;π REPEATπ i := i + 1;π devicename := PTR (bp, si + $0a + ch); { get the device name }π dname [i] := devicename^;π dname [0] := CHR (i);π INC (ch);π UNTIL (devicename^ = CHR (0) ) OR (ch > 7);π ENDπ ELSE { else }π BEGIN { just inform of the error }π dname := 'disk in ' + CHR (al) + ':';π msg := ' general failure ' ;π END;π amsg := amsg + ' ' + dname;π END;ππ INLINE ($FA); { Enable interrupts }π Display := PTR (ScrSeg, $0000); { save the current screen }π NEW (SaveScr);π SaveScr^ := Display^;π WINDOW (15, 10, 65, 16); { make a box to display the}π TEXTCOLOR (FGErr); { error message }π TEXTBACKGROUND (BGErr);π CLRSCR;π box;ππ IF Version >= 3 THEN { check the DOS version }π BEGIN { major component }π regs.ah := $59; { and use DosExtErr since }π regs.bx := $00; { it is available }π MSDOS (Regs);π INT59ERROR := regs.ax;π ERRORTYPE := regs.bh;π ERRORACTION := regs.bl;π ERRORAREA := regs.ch;π msg := Errs^ [INT59ERROR]; { get the error information}π(*π case ERRORAREA ofπ 1: amsg:='Unknown';π 2: amsg:='Block Device'; { usually disk access error}π 3: amsg:='Network Problem';π 4: amsg:='Serial Device'; { printer or COM problem }π 5: amsg:='Memory'; { corrupted memory }π end;π*)π CASE ERRORTYPE OFπ 1 : tmsg := 'Out of Resource'; { no channels, space }π 2 : tmsg := 'Temporary situation'; { file locked for instance;}π { not an error and will }π { clear eventually }π 3 : tmsg := 'Authorization Violation'; { permission problem e.g. }π { write to read only file }π 4 : tmsg := 'Internal Software Error'; { system software bug }π 5 : tmsg := 'Hardware Error'; { serious trouble -- fix }π { the machine }π 6 : tmsg := 'System Error'; { serious trouble software }π { at fault -- e.g. missing }π { CONFIG file }π 7 : tmsg := 'Program Error'; { inconsistent request }π { from your program }π 8 : tmsg := 'Not found'; { as stated }π 9 : tmsg := 'Bad Format'; { as stated }π 10 : tmsg := 'Locked'; { interlock situation }π 11 : tmsg := 'Media Error'; { CRC error, wrong disk in }π { drive, bad disk cluster }π 12 : tmsg := 'Exists'; { collision with existing }π { item, e.g. duplicate }π { device name }π 13 : tmsg := 'Unknown Error';π END;ππ CASE ERRORACTION OFπ 1 : actmsg := 'Retry'; { retry a few times then }π { give user abort option }π { if not fixed }π 2 : actmsg := 'Delay Retry'; { pause, retry, then give }π { user abort option }π 3 : actmsg := 'User Action'; { ask user to reenter item }π { e.g. bad drive letter or }π { filename used }π 4 : actmsg := 'Abort'; { invoke an orderly shut }π { down -- close files, etc }π 5 : actmsg := 'Immediate Exit'; { don't clean up, you may }π { really screw something up}π 6 : actmsg := 'Ignore';π 7 : actmsg := 'Retry'; { after user intervention: }π END; { let the user fix it first}ππ END;πamsg := tmsg + amsg;πactmsg := 'Suggested Action: ' + actmsg;ππGOTOXY ( (54 - LENGTH (msg) ) DIV 2, 3);πWRITE (msg);ππGOTOXY ( (54 - LENGTH (amsg) ) DIV 2, 4);πWRITE (amsg);ππGOTOXY ( (54 - LENGTH (actmsg) ) DIV 2, 6);πWRITE (actmsg);π { display it }ππErrorPrompt := ' I)gnore R)etry A)bort F)ail ? ';πGOTOXY ( (54 - LENGTH (ErrorPrompt) ) DIV 2, 5);πWRITE (ErrorPrompt);πREPEAT { get the user response }πc := READKEY;πc := UPCASE (c);πUNTIL c IN ['A', 'R', 'I', 'F'];πWINDOW (1, 1, 80, 25); { restore the screen }πTEXTCOLOR (FGNorm);πTEXTBACKGROUND (BGNorm);πDisplay^ := SaveScr^;πDISPOSE (SaveScr);πCASE c OFπ 'I' : BEGINπ AX := 0;π ERRORRETRY := FALSE;π END;π 'R' : BEGINπ AX := 1;π ERRORRETRY := TRUE;π END;π 'A' : BEGINπ Ax := 2;π ERRORRETRY := FALSE;π Showcursor;π END;π 'F' : BEGINπ Ax := 3;π ERRORRETRY := FALSE;π Showcursor;π END;πEND;ππEND;{procedure CritError}ππ(**************************************************************************)πPROCEDURE DisplayError (ErrNo : INTEGER);πVARπmsg,πexitmsg : STRING;πBEGINπ CASE ErrNo OFπ 2 : exitmsg := 'File not found';π 3 : exitmsg := 'Path not found';π 4 : exitmsg := 'Too many open files';π 5 : exitmsg := 'Access denied';π 6 : exitmsg := 'Invalid file handle';π 12 : exitmsg := 'Invalid file access code';π 15 : exitmsg := 'Invalid drive';π 16 : exitmsg := 'Cannot remove current directory';π 17 : exitmsg := 'Cannot rename across drives';π 100 : exitmsg := 'Disk read error';π 101 : exitmsg := 'Disk write error - Disk Full ?';π 102 : exitmsg := 'File not assigned';π 103 : exitmsg := 'File not opened';π 104 : exitmsg := 'File not open for input';π 105 : exitmsg := 'File not open for output';π 106 : exitmsg := 'Invalid numeric format';π 150 : exitmsg := 'Disk is write protected';π 151 : exitmsg := 'Unknown unit';π 152 : exitmsg := 'Drive not ready';π 153 : exitmsg := 'Unkown command';π 154 : exitmsg := 'CRC error in data';π 155 : exitmsg := 'Bad drive request structure length';π 156 : exitmsg := 'Disk seek error';π 157 : exitmsg := 'Unknown media type';π 158 : exitmsg := 'Sector not found';π 159 : exitmsg := 'Printer out of paper';π 160 : exitmsg := 'Device write fault';π 161 : exitmsg := 'Device read fault';π 162 : exitmsg := 'Hardware failure';π 200 : exitmsg := 'Division by zero';π 201 : exitmsg := 'Range check error';π 202 : exitmsg := 'Stack overflow';π 203 : exitmsg := 'Heap overflow';π 204 : exitmsg := 'Invalid pointer operation';π 205 : exitmsg := 'Floating point overflow';π 206 : exitmsg := 'Floating point underflow';π 207 : exitmsg := 'Invalid floating point operation'π ELSE exitmsg := 'Unknown Error # ';π END;ππ msg := exitmsg;ππ TEXTCOLOR (FGErr);π TEXTBACKGROUND (BGErr);π GOTOXY ( (50 - LENGTH (msg) ) DIV 2, 3);π WRITE (msg);ππEND;ππPROCEDURE ErrTrap (ErrNo : INTEGER);πTYPEπScrPtr = ^ScrBuff;πScrBuff = ARRAY [1..4096] OF BYTE;ππVARπ Display,π SaveScr : ScrPtr;ππ c : CHAR;π ErrorPrompt,π msg : STRING;ππBEGINππ Display := PTR (ScrSeg, $0000); { save the current screen }π NEW (SaveScr);π SaveScr^ := Display^;π WINDOW (15, 10, 65, 16); { make a box to display the}π TEXTCOLOR (FGErr); { error message }π TEXTBACKGROUND (BGErr);π CLRSCR;π box;ππ ErrorRetry := TRUE;π DisplayError (ErrNo);ππ { display it }ππErrorPrompt := ' I)gnore R)etry A)bort F)ail ? ';πGOTOXY ( (54 - LENGTH (ErrorPrompt) ) DIV 2, 5);πWRITE (ErrorPrompt);πREPEAT { get the user response }πc := READKEY;πc := UPCASE (c);πUNTIL c IN ['A', 'R', 'I', 'F'];πCASE c OFπ 'I' : ErrorRetry := FALSE;π 'R' : ErrorRetry := TRUE;π 'A' : BEGINπ ErrorRetry := FALSE;π Showcursor;π END;π 'F' : BEGINπ ErrorRetry := FALSE;π Showcursor;π END;π END;π IF ErrorRetry = FALSE THENπ BEGINπ GOTOXY (4, 4);π WRITE ('If you are unable to correct the error');π GOTOXY (4, 5);π WRITE ('please report the error ', #40, Errno, #41, ' and ');π GOTOXY (4, 6);π WRITE ('exact circumstances when it occurred to us.');π WINDOW (1, 1, 80, 25); { restore the screen }π TEXTCOLOR (FGNorm);π TEXTBACKGROUND (BGNorm);π Display^ := SaveScr^;π DISPOSE (SaveScr);ππ ErrorAddr := NIL;π GOTOXY (1, 1);π Showcursor;π HALT;π END;πWINDOW (1, 1, 80, 25); { restore the screen }πTEXTCOLOR (FGNorm);πTEXTBACKGROUND (BGNorm);πDisplay^ := SaveScr^;πDISPOSE (SaveScr);πEND;ππPROCEDURE RuntimeError;ππTYPEπScrPtr = ^ScrBuff;πScrBuff = ARRAY [1..4096] OF BYTE;ππVARπ Display,π SaveScr : ScrPtr;ππ c : CHAR;π ErrorPrompt,π msg : STRING;ππBEGINπ IF ErrorAddr <> NIL THENπ BEGINπ Display := PTR (ScrSeg, $0000); { save the current screen }π NEW (SaveScr);π SaveScr^ := Display^;π WINDOW (15, 10, 65, 16); { make a box to display the}π TEXTCOLOR (FGErr); { error message }π TEXTBACKGROUND (BGErr);π CLRSCR;π box;π GOTOXY (15, 1);π WRITE (' Fatal Error ');π DisplayError (ExitCode);π GOTOXY (20, 2);π WRITE ('Run time error ', ExitCode);π GOTOXY (4, 4);π WRITE ('If you are unable to correct the error');π GOTOXY (4, 5);π WRITE ('Please report the error and exact');π GOTOXY (4, 6);π WRITE ('circumstances when it occurred to us.');π GOTOXY (4, 7);π WRITE ( ' Press a key to continue ');π ErrorAddr := NIL;ππ ExitProc := ExitSave;π c := READKEY;π END;π WINDOW (1, 1, 80, 25); { restore the screen }π TEXTCOLOR (FGNorm);π TEXTBACKGROUND (BGNorm);π Display^ := SaveScr^;π DISPOSE (SaveScr);ππ ShowCursor;π TEXTCOLOR (lightgray);π TEXTBACKGROUND (black);ππ SETINTVEC ($24, SaveInt24);πEND;ππPROCEDURE DisableErrorHandler;πBEGINπ SETINTVEC ($24, SaveInt24);π ExitProc := ExitSave;πEND;ππ(**************************************************************************)πBEGINπ InitErrs;π Version := DosVer;π Hidecursor;π IF mem [$0000 : $0449] <> 7 THEN ScrSeg := $B800 ELSE ScrSeg := $B000;π GETINTVEC ($24, SaveInt24);π SETINTVEC ($24, @CritError);π ExitSave := ExitProc;π ExitProc := @RuntimeError;πEND.ππ{ --------------------- DEMO PROGRAM -------------------------- }ππ{$I-} { THIS MUST BE HERE FOR THE ERROR TRAP TO WORK !! }πPROGRAM testerr;πUSES dos, crt, printer, errtrp;πVARπregs : REGISTERS;πfil : FILE;πPchar : STRING;πBEGINπCLRSCR;π(*COMMENT OUT THE FUNCTIONS NOT BEING TESTED*)π(* USING THE CRITICAL ERROR HANDLER PROCEDURE CRITERR *)ππ(* remove disc from A: drive to test this *)π(******************************************)ππWRITE ('trying to write to drive a: ');ππ ASSIGN (fil, 'A:filename.ext');π REWRITE (fil);ππDisableErrorHandler;ππ(* USING THE ERRTRAP PROCEDURE *)ππWRITE ('trying to write to drive a: using ERRTRAP');πREPEATπASSIGN (fil, 'A:filename.ext');πREWRITE (fil);πiocode := IORESULT;πIF IOCode <> 0 THEN ErrTrap (IOCode);πUNTIL ERRORRETRY = FALSE;ππEND.π 44 02-03-9409:21ALL STEVE ROGERS Rebooting IMPORT 9 ┤φs {πFrom: STEVE ROGERSπSubj: RebootingπHere's some code to make both warmboot and coldboot com files. If youπwant to make them TP procs, just enter them as inline code.ππ------------------------------------------------------------------------π{Makes two COM files: WARMBOOT & COLDBOOT }ππconstπ Warm_Boot : array[1..17] of byte = { inline code for warm boot }π ($BB,$00,$01,$B8,$40,$00,π $8E,$D8,$89,$1E,$72,$00,π $EA,$00,$00,$FF,$FF);ππ Cold_Boot : array[1..17] of byte = { inline code for cold boot }π ($BB,$38,$12,$B8,$40,$00,π $8E,$D8,$89,$1E,$72,$00,π $EA,$00,$00,$FF,$FF);ππvarπ f : file;ππbeginπ assign(f,'warmboot.com');π rewrite(f,1);π blockwrite(f,warm_boot,17);π close(f);ππ assign(f,'coldboot.com');π rewrite(f,1);π blockwrite(f,cold_boot,17);π close(f);πend.π 45 02-03-9410:53ALL MICHAEL PHILLIPS EXTEMD.PAS IMPORT 55 ┤φ∙
{π RL> I would like to open 20-50 silumtaneous files (in TP 6.0 or 7.0).ππ RL> Does anyone know how to accomplish this?ππI use the unit below for BP7 (protected mode or real mode).π}ππUnit Extend;ππ{-----------------------------------------------------------------------}π{ Author : Michael John Phillips }π{ Address : 5/5 Waddell Place }π{ Curtin ACT 2605 }π{ Tel : (06) 2811980h }π{ FidoNet : 3:620/243.70 }π{-----------------------------------------------------------------------}π{π$lgb$πv1.0 22 Apr 93 - Initial version works in REAL-MODE or DPMI mode BP7π$lge$π$nokeywords$π}π{-----------------------------------------------------------------------}π{ This unit contains routines to extend the number of files that }π{ can simultaneously be open by a program under DOS. }π{ }π{ The NON-DPMI routine was downloaded from the Borland BBS and then }π{ modified to work with TP7 and BP7. }π{ }π{ The DPMI routine was captured in the Z3_PASCAL FidoNet echo. }π{ }π{ To use these routines, make sure that your CONFIG.SYS files }π{ contains the lines FILES=255. If you use the DOS SHARE command }π{ then make sure that you have enough memory allocated for SHARE }π{ (eg SHARE /F:7168), having SHARE too low can result in a "hardware }π{ failure" (IOResult=162) when trying to open a file. }π{-----------------------------------------------------------------------}π{ These routines extend the max. number of files that can be OPEN }π{ simultaneously from 20 to 255. Files in DOS 2.0 or later are }π{ controlled by FILE handles. The number of FILE handles available }π{ to application programs is controlled by the FILES environment }π{ variable stored in a CONFIG.SYS FILE. If no FILES variable is }π{ established in a CONFIG.SYS FILE, then only 8 FILE handles are }π{ available. However, DOS requires 5 FILE handles for its own use }π{ (controlling devices such as CON, AUX, PRN, etc). This leaves }π{ only 3 handles for use by application programs. }π{ }π{ By specifying a value for the FILES environment variable, you can }π{ increase the number of possible FILE handles from 8 up to 20. }π{ Since DOS still requires 5, 15 are left for application programs. }π{ But you cannot normally increase the number of handles beyond 20. }π{ }π{ With DOS version 3.0, a new DOS function was added to increase }π{ the number of FILE handles available. However, the function must }π{ be called from application programs that have previously reserved }π{ space for the new FILE handles. }π{-----------------------------------------------------------------------}π{$IFNDEF VER70 }π Should be compiled using Turbo Pascal v7.0 or Borland Pascal v7.0π{$ENDIF }ππInterfaceππConstπ MAX_FILE_HANDLES = 255;ππ Function ExtendHandles(Handles : Byte) : Word;ππImplementationππ{$IFDEF MSDOS }πUsesπ Dos; { Dos routines - BORLAND }π{$ENDIF }ππ{$IFDEF DPMI }πUsesπ Dos, { Dos routines - BORLAND }π WinAPI; { Windows API routines - BORLAND }π{$ENDIF }ππConstπ NO_ERROR = $00;π ERROR_NOT_ENOUGH_MEMORY = $08;π ERROR_HARDWARE_FAILURE = $A2;ππVarπ Result : Word;π Regs : Registers;ππ{$IFDEF MSDOS }π Function ExtendHandles(Handles : Byte) : Word;π {---------------------------------------------------------------------}π { This routine resizes the amount of allocated memory for a Turbo }π { Pascal program to allow space for new FILE handles. In doing so, }π { it also resizes the heap by adjusting the value of FreePtr, the }π { pointer used in FreeList management. Since the FreeList is being }π { manipulated, the heap must be empty when the extend unit is }π { initialized. This can be guaranteed by including extend as one }π { of the first units in your program's USES statement. If any heap }π { has been allocated when extend initializes, the program will halt }π { with an error message. }π {---------------------------------------------------------------------}π begin { of ExtendHandles }π ExtendHandles := NO_ERROR;ππ {-------------------------------------------------------------------}π { Check that the number of file handles to extend to is greater }π { than the default number of file handles (20). }π {-------------------------------------------------------------------}π if Handles <= 20 thenπ Exit;ππ {-------------------------------------------------------------------}π { Check that the heap used by Turbo Pascal is currently empty. }π {-------------------------------------------------------------------}π if (HeapOrg <> HeapPtr) thenπ beginπ Writeln('Heap must be empty before Extend unit initializes');π Halt(1);π end;ππ {-------------------------------------------------------------------}π { Reduce the heap space used by Turbo Pascal. }π {-------------------------------------------------------------------}π HeapEnd:=ptr(Seg(HeapEnd^)-(Handles div 8 +1), Ofs(HeapEnd^));ππ {-------------------------------------------------------------------}π { Determine how much memory is allocated to the program. BX }π { returns the number of paragraphs (16 bytes) used. }π {-------------------------------------------------------------------}π with Regs doπ beginπ AH := $4A;π ES := PrefixSeg;π BX := $FFFF;π MsDos(Regs);π end; { of with Regs }ππ {-------------------------------------------------------------------}π { Set the program size to the allow for new handles. }π {-------------------------------------------------------------------}π with Regs doπ beginπ AH := $4A;π ES := PrefixSeg;π BX := BX - (Handles div 8 + 1);π MsDos(Regs);π end; { of with Regs }ππEND;π{$ENDIF}πEND. 46 02-03-9416:16ALL TREVOR CARLSON Setting DOS Prompt IMPORT 21 ┤φ╬ï π{πTF>How does one alter a DOS environment variable in PASCAL and have the changeπTF>reflected after the program terminates, leaving the user in DOS, and the useπTF>types SET? This has been bugging me for a while. I know that there are twoπTF>copies of the environment and I need to access the top one, but I don't knowπTF>how.ππThe following example shows how to change the prompt: }ππfunction MastEnvSeg(var Envlen: word): word;π {-returns the master environment segment }π varπ mcb,temp,handle : word;π lastmcb : boolean;π beginπ MastEnvSeg := 0;π Envlen := 0;π handle := MemW[0: $ba]; {-$2e * 4 + 2}π {-The interrupt vector $2e points to the first paragraph ofπ allocated to the command processor}π mcb := pred(handle);π {-mcb now points to the memory control block for the command processor}π repeatπ temp := Mcb+MemW[Mcb:3]+1;π if (Mem[temp:0] = $4d) and (MemW[temp:1] = handle) then beginπ lastmcb := false;π mcb := temp;π endπ elseπ lastmcb := true;π until lastmcb;π EnvLen := Mem[Mcb:3] shl 4;π MastEnvSeg := succ(Mcb);π end;πππ procedure InitNewPrompt;π {-set up a new prompt for shelling to dos}π typeπ _2karray = array[1..2048] of byte;π SegPtr = ^_2karray;π constπ NewPrompt : string =π ('PROMPT=Type EXIT to return to program$_$p$g'+#0);π varπ EnvSegment,π NewEnvSeg : word;π PtrSeg,π NewEnv : SegPtr;π beginπ EnvSegment := memw[prefixseg:$2C];π {-this gets the actual starting segment of the current program's env}ππ PtrSeg := ptr(pred(EnvSegment),0);π {-The segment of the program's MCB - (Memory control block) }ππ getmem(NewEnv,1072+length(NewPrompt));π {-Allocate heap memory and allow enough room for a dummy mcb }ππ if ofs(NewEnv^) <> 0 thenπ NewEnvSeg := seg(NewEnv^) + 2π elseπ NewEnvSeg := succ(seg(NewEnv^));π {-Force the new environment to start at paragraph boundary}ππ move(PtrSeg^,mem[pred(NewEnvSeg):0],16);π {-copy the old mcb and force to paragraph boundary}ππ memw[pred(NewEnvSeg):3] := (1072+length(NewPrompt)) shr 4;π {-Alter the environment length by changing the dummy mcb}ππ move(NewPrompt[1],memw[NewEnvSeg:0],length(NewPrompt));π {-install new prompt}ππ memw[prefixseg:$2C] := NewEnvSeg;π {-let the program know where the new env is}ππ move(mem[EnvSegment:0],mem[NewEnvSeg:length(NewPrompt)],1024);π {-shift the old env to the new area}π end;ππ 47 02-03-9416:17ALL REINHARDT MUELLER Loading Overlays in XMS IMPORT 99 ┤φ<H π{πWith this unit, it doesn't matter if the overlay is separate,πor tacked onto the end of the .EXE file -- the program willπrun either way.ππAs written, this unit also uses OVERXMS, a PD unit writtenπWilbert Van Leijen. Floating around the BBS's as OVERXMS.ZIPπYou may delete the references to XMS.πThe XMS stuff is in there because the program I copied thisπcode from will run on a 486 and just about all of the collegeπmachines have XMS memory -- few if any have EMS. }ππ{$A-,B+,D-,F+,I-,L-,N-,O-,Q+,R-,S-,V-}ππUNIT RVOVRLAY;ππ{ This unit starts the overlay manager }ππINTERFACEπConstπ ovrNoXMSDriver = -7; { No XMS driver installed }π ovrNoXMSMemory = -8; { Insufficient XMS memory available }πππIMPLEMENTATIONππUSES DOS, OVERLAY;ππ{ OVERXMS - Loads overlays in XMS.π Assembly-language portion written by Wilbert van Leijen }πProcedure OvrInitXMS; External;π{$L OVERXMS.OBJ }ππFunction Exist(Filename:string):boolean;π{returns true if file exists}ππvar Inf: SearchRec;ππbeginπ FindFirst(Filename,AnyFile,Inf);π Exist := (DOSError = 0);πend; {Func Exist}πππProcedure S_Write (Msg : string);ππBEGIN {Dirty trick to generate less code}π Write (msg);πEND;πππProcedure WriteOvrErrMsg;ππVARπ garbage:char;ππBEGINπ WRITE ('Overlay error: ',OvrResult,' ');π IF (OvrResult = ovrOk) THEN S_WRITE ('Ok - No error');π IF (OvrResult = ovrError) THEN S_WRITE ('Missing Overlay error');π IF (OvrResult = ovrNotFound) THEN S_WRITE ('Overlay file not found');π IF (OvrResult = ovrNoMemory) THEN S_WRITE ('No Memory for overlays');π IF (OvrResult = ovrIOError) THEN S_WRITE ('Overlay IO Error');π IF (OvrResult = ovrNoEMSDriver) THEN S_WRITE ('No EMS Driver');π IF (OvrResult = ovrNoEMSMemory) THEN S_WRITE ('No EMS Memory');π IF (OvrResult = ovrNoXMSDriver) THEN S_WRITE ('No XMS Driver');π IF (OvrResult = ovrNoXMSMemory) THEN S_WRITE ('No XMS Memory');π S_WRITE (^M^J);π read (garbage);π If OvrResult <> OvrOK THEN HALT (98);πEND; { Procedure WriteOvrErrMsg }πππBEGIN { main }ππ IF (lo(DosVersion) < 3) THENπ BEGINπ WriteLn ('You are using DOS version ',Lo(DosVersion),π '.',Hi(DosVersion));π Writeln ('Mulesoft Revenge requires DOS v3.0 or greater.');π HALT (99);π END;ππ { Start overlay manager and assume that overlay is inπ the .EXE file. If not found in .EXE file, assume theπ overlay file is separate from the .EXE file. }ππ OVRINIT (paramstr(0));ππ If (OvrResult = ovrError) THEN { Overlay not at end of .EXE file }π OVRINIT (copy(paramstr(0), 1, Length(paramstr(0))-3) + 'OVR');π IF (OvrResult <> OvrOk) THENπ WriteOvrErrMsgπ ELSE { Try to load the overlay into XMS memory }π BEGINπ OvrInitXms;π IF (OvrResult <> OvrOk) THENπ OvrInitEms;π END;πEND.ππ{------------------------- snip, snip ----------------------------}ππ Here is the .OBJ file that goes with this file ...π you will need XX3402 o decode this output:ππ Cut this out to a file named OVERXMS.XX.π Execute XX3402 d OVERXMS.XXππ You will then get the file OVERXMS.OBJ to compile this unitππ*XX3402-000913-020294--72--85-48736-----OVERXMS.OBJ--1-OF--1πU+o+0qxqNL7sPLAiEJBBFMUU++++53FpQa7j623nQqJhMalZQW+UJaJmQqZjPW+n9X8NW-A+πECafC26Q0qxqNL7sPLAiEJBBnMU1+21dH7M0++-cW+A+E84IZUM+-2F-J234a+Q+G-c++U2-πytM4++F1HoF3FNU5+0Wi+EA-+MKAJ++7I373FYZMIoJ5++V3K2ZII37DEk+7HpNGIYJHJIlIπ++hDJZ71HoF3H2ZHJ++AHpNGF2xHG23CF2l3++dDJZ76FI3EHp75++dDJZ7GFI32EZJ4+0OEπ2E+++UdDJZ77HYZIK2pHCE2+xcU2+20W+N4UgU20++093VU+h+fz5U++l+M2+8A++6k4+U19πAw+nocgS+++15U++UwAEXgAa+kM6+6DG+0O95Us+0xhptfg+-DTnYY8o0TwS+++9k5E2WFMMπ+ABJWymCFUMacEU+ckU+Aw0X0U0V4+0X1++acFM+cks+7e2M+8AE+1D+cl6+clE+7e2E+8AKπ+9E9jUU+zls+++j+R+F6ukGEiDnzLQc0+0O93UU+xw6-+5E4EWPz-UU+WFM6+1D+ckc+ckk+πcks+cE++cl++cFU+cl6+WHsI+6YS3U0o0vs6+DwS+++1ycDH++j+R+9skzb1JMjgcE++AwY1π-U++-F++Xg-EEGOV1U+9k5LhAxgnzkRFcE++7eAE+0O75VU+7cYy3U-HJkM4zls+++RTKmP5π-V++++1rq566u4jzQUBNsgy9tJr1Aw+v-U++REF6uqOEi+-1nGwwU5E4iDbzupSEi--1nGy7π5U++X+M0+CWmzbI4iDXzunyEu5PzQl093VU+h+fz5U++iDnzumeEWls++9EynG55-U++HU0Aπ1U6+l+M++8A2+6k4-U15-U++++0A1U6+Aw0X++19RdnW+AE0J+5203E-l+lI+QED-U20l-A4π+E925+M--AEU-U2-l2BI+QF9J+52KJE-l3tI+QFVJ+52N3E-l4hI+QFmJ+52RpE-l5dI+QG-πJ+52VZE-l6dI+QGiJ+52gpE-l9NI+QGtJ+52j+M--gGzJ+52kZE-lAJI+QH7J+52nJE-lB7Iπ+QHKJ+52uEM--AHj-U2-lEQ4+EP35EM--wIx-U23lJhI+QJTJ+53QpE-lLZI+QK1-U23lMg4π+ET3XJE0lN24+ET3ZEM-+gKMJ+53b3E-lO+4+E93cZE0lOM4+E93ekM-+z88+U++R+++π***** END OF BLOCK 1 *****ππ{--------------------- OVERXMS.ASM --------------------- }π{ NEED MASM,TASM to compile }ππTITLE Turbo Pascal XMS support for loading overlays - By Wilbert van LeijenπPAGE 65, 132πLOCALS @@ππData SEGMENT Word Publicπ ASSUME DS:Dataππ; XMS block move recordππXmsMoveType STRUCπ BlkSize DD ?π SrcHandle DW ?π SrcOffset DD ?π DestHandle DW ?π DestOffset DD ?πXmsMoveType ENDSππ; TP overlay manager recordππOvrHeader STRUCπ ReturnAddr DD ? ; Virtual return addressπ FileOfs DD ? ; Offset into overlay fileπ CodeSize DW ? ; Size of overlayπ FixupSize DW ? ; Size of fixup tableπ EntryPts DW ? ; Number of proceduresπ CodeListNext DW ? ; Segment of next overlayπ LoadSeg DW ? ; Start segment in memoryπ Reprieved DW ? ; Loaded in memory flagπ LoadListNext DW ? ; Segment of next in load listπ XmsOffset DD ? ; Offset into allocated XMS blockπ UserData DW 3 DUP(?)πOvrHeader ENDSππXmsDriver DD ? ; Entry point of XMS driverπExitSave DD ? ; Pointer to previous exit procπXmsMove XmsMoveType <>πOvrXmsHandle DW ? ; Returned by XMS driverππ Extrn PrefixSeg : Wordπ Extrn ExitProc : DWordπ Extrn OvrResult : Wordπ Extrn OvrCodeList : Wordπ Extrn OvrDosHandle : Wordπ Extrn OvrHeapOrg : Wordπ Extrn OvrReadBuf : DWordπData ENDSππCode SEGMENT Byte Publicπ ASSUME CS:Codeπ Public OvrInitXMSππovrIOError EQU -4πovrNoXMSDriver EQU -7πovrNoXMSMemory EQU -8ππOvrXmsExit PROCππ; Release handle and XMS memoryππ MOV DX, [OvrXmsHandle]π MOV AH, 10π CALL [XmsDriver]ππ; Restore pointer to previous exit procedureππ LES AX, [ExitSave]π MOV Word Ptr [ExitProc], AXπ MOV Word Ptr [ExitProc+2], ESπ RETFπOvrXmsExit ENDPππAllocateXms PROCππ; Determine the size of the XMS block to allocate:π; Walk the CodeListNext chainπ; Store the total codesize in DX:AXππ XOR AX, AXπ XOR DX, DXπ MOV BX, [OvrCodeList]π@@1: ADD BX, [PrefixSeg]π ADD BX, 10hπ MOV ES, BXπ ADD AX, ES:[OvrHeader.CodeSize]π ADC DX, 0π MOV BX, ES:[OvrHeader.CodeListNext]π OR BX, BXπ JNZ @@1ππ; Obtain number of kilobytes to allocateππ MOV BX, 1024π DIV BXπ XCHG DX, AXπ INC DXππ; Allocate the blockππ MOV AH, 9π CALL [XmsDriver]π OR AX, AXπ JZ @@2π MOV [OvrXmsHandle], DXπ@@2: RETNπAllocateXms ENDPππ; Function XmsReadFunc(OvrSeg : Word) : Integer; Far;ππXmsReadFunc PROCππ; Swap the code from XMS to the heapππ PUSH BPπ MOV BP, SPπ MOV ES, [BP+6]π MOV AX, ES:[OvrHeader.CodeSize]π MOV Word Ptr [XmsMove.BlkSize], AXπ XOR AX, AXπ MOV Word Ptr [XmsMove.BlkSize+2], AXπ MOV AX, [OvrXmsHandle]π MOV [XmsMove.SrcHandle], AXπ MOV AX, Word Ptr ES:[OvrHeader.XmsOffset]π MOV Word Ptr [XmsMove.SrcOffset], AXπ MOV AX, Word Ptr ES:[OvrHeader.XmsOffset+2]π MOV Word Ptr [XmsMove.SrcOffset+2], AXπ XOR AX, AXπ MOV [XmsMove.DestHandle], AXπ MOV Word Ptr [XmsMove.DestOffset], AXπ MOV AX, ES:[OvrHeader.LoadSeg]π MOV Word Ptr [XmsMove.DestOffset+2], AXπ MOV AH, 11π LEA SI, XmsMoveπ CALL [XmsDriver]π OR AX, AXπ JZ @@1π DEC AXπ JMP @@2ππ@@1: MOV AX, ovrIOErrorπ@@2: POP BPπ RETF 2πXmsReadFunc ENDPππ; Copy an overlaid unit from the heap to XMSπ; If successful, carry flag is clearedπ; In/Out:π; BX:DI = offset into XMS memory blockππCopyUnitToXms PROCππ; XMS requires that an even number of bytes is movedππ MOV DX, ES:[OvrHeader.CodeSize]π TEST DX, 1π JZ @@1π INC DXπ INC ES:[OvrHeader.CodeSize]ππ; Get the fields of the XMS block move structureππ@@1: MOV Word Ptr [XmsMove.BlkSize], DXπ XOR AX, AXπ MOV Word Ptr [XmsMove.BlkSize+2], AXπ MOV [XmsMove.SrcHandle], AXπ MOV Word Ptr [XmsMove.SrcOffset], AXπ MOV AX, [OvrHeapOrg]π MOV Word Ptr [XmsMove.SrcOffset+2], AXπ MOV AX, [OvrXmsHandle]π MOV [XmsMove.DestHandle], AXπ MOV Word Ptr [XmsMove.DestOffset], DIπ MOV Word Ptr [XmsMove.DestOffset+2], BXπ MOV AH, 11π LEA SI, XmsMoveπ CALL [XmsDriver]ππ; Bump code sizeππ ADD DI, DXπ ADC BX, 0ππ; Check return code from XMS driverππ OR AX, AXπ JZ @@2π CLCπ RETNππ@@2: STCπ RETNπCopyUnitToXms ENDPππOvrXmsLoad PROCπ PUSH BPπ MOV BP, SPππ; Walk the CodeList chainπ; First segment is PrefixSeg+10h+OvrCodeListπ; Push each element of overlaid unit list on the stackπ; Keep the size of the linked list in CXππ MOV AX, [OvrCodeList]π XOR CX, CXπ@@1: ADD AX, [PrefixSeg]π ADD AX, 10hπ MOV ES, AXπ PUSH AXπ INC CXπ MOV AX, ES:[OvrHeader.CodeListNext]π OR AX, AXπ JNZ @@1ππ; Loop:π; Pop each element of the overlaid unit list from the stackππ XOR BX, BXπ XOR DI, DIπ@@2: POP ESπ PUSH CXπ MOV AX, [OvrHeapOrg]π MOV ES:[OvrHeader.LoadSeg], AXπ MOV Word Ptr ES:[OvrHeader.XmsOffset+2], BXπ MOV Word Ptr ES:[OvrHeader.XmsOffset], DIππ; Load overlay from diskππ PUSH BXπ PUSH DIπ PUSH ESπ PUSH ESπ CALL [OvrReadBuf]π POP ESπ POP DIπ POP BXππ; Flag unit as 'unloaded'; check return codeππ MOV ES:[OvrHeader.LoadSeg], 0π NEG AXπ JC @@3ππ CALL CopyUnitToXmsπ JC @@3ππ POP CXπ LOOP @@2ππ@@3: MOV SP, BPπ POP BPπ RETNπOvrXMSLoad ENDPππOvrInitXMS PROCππ; Make sure the file's been openedππ XOR AX, AXπ CMP AX, [OvrDOSHandle]π JNE @@1π DEC AX ; ovrErrorπ JMP @@5ππ; Check presence of XMS driverππ@@1: MOV AX, 4300hπ INT 2Fhπ CMP AL, 80hπ JE @@2π MOV AX, ovrNoXmsDriverπ JMP @@5ππ; Get XMS driver's entry pointππ@@2: MOV AX, 4310hπ INT 2Fhπ MOV Word Ptr [XmsDriver], BXπ MOV Word Ptr [XmsDriver+2], ESπ CALL AllocateXmsπ JNZ @@3π MOV AX, ovrNoXMSMemoryπ JMP @@5ππ; Load the overlay into XMSππ@@3: CALL OvrXmsLoadπ JNC @@4ππ; An error occurred. Release handle and XMS memoryππ MOV DX, [OvrXmsHandle]π MOV AH, 10π CALL [XmsDriver]π MOV AX, ovrIOErrorπ JMP @@5ππ; Close fileππ@@4: MOV BX, [OvrDOSHandle]π MOV AH, 3Ehπ INT 21hππ; OvrReadBuf := XmsReadFuncππ MOV Word Ptr [OvrReadBuf], Offset XmsReadFuncπ MOV Word Ptr [OvrReadBuf+2], CSππ; ExitSave := ExitProcπ; ExitProc := OvrXmsExitππ LES AX, [ExitProc]π MOV Word Ptr [ExitSave], AXπ MOV Word Ptr [ExitSave+2], ESπ MOV Word Ptr [ExitProc], Offset OvrXmsExitπ MOV Word Ptr [ExitProc+2], CSππ; Return result of initialisationππ XOR AX, AXπ@@5: MOV [OvrResult], AXπ RETFπOvrInitXMS ENDPππCode ENDSπ ENDπ 48 02-03-9416:19ALL LEE ARONER Sharing Files IMPORT 32 ┤φ_ π{ππ I've been puzzling over Share myself the last week. Here's someπ tips from what I've found:ππ 1. Remember, if you are trying to write to the same region fromπ both processes, you will *still* get a sharing violation withπ access denied to the last one to ask ! There is a subfunc, (440Bhπ I think) for changing the default number of tries that share willπ retry for access. You might want to look into that. Otherwise youπ could use something like the OpenTxtFile routine below, modifiedπ for use on non-text files, or both. (You aren't trying to shareπ text files are you? If so, there IS a way to do it, let me know).ππ 2. Also note that you set the filemode AFTER assignment, andπ BEFORE a reset, rewrite or append.ππ 3. The following are 2 functions I've put together to handle myπ stuff. Note that the first is for non-text files, the second isπ for text files. The text file routine uses an external TFDD unitπ to set up the filemode variable so it works with text files.π Holler if you want the unit also.........ππ (* Call this to lock or unlock the ENTIRE fileπ****** use lock =$00 & unlock = $01 constants for action *********π ***** SHARE.EXE MUST be loaded ! *******π Do NOT use on Text Files ! will NOT work !πYou could modify this to only lock certain regions by passing valuesπfor a start and stop region. Load CX/DX and DI/SI as done below. *)π}ππFunction LockFile(var f; action:byte):boolean;πVarπ fsize : longint;πBeginπ if GotShare then (* Share loaded ? *)π beginπ fsize := longint(filesize(file(f))); (* Get filesize *)π Regs.AH := $5C; (* Subfunc *)π Regs.AL := Action; (* $00=Lock or $01=unlock *)π Regs.BX := FileRec(f).Handle; (* Git the handle *)π Regs.CX := Hi($00); (* Start of file *)π Regs.DX := Lo($00);π Regs.DI := Lo(fsize); (* Compute end of file *)π Regs.SI := Hi(fsize);π Intr($21, Regs);π if ((Regs.FLAGS and $01) = 0) then LockFile := trueπ elseπ beginπ IORes := regs.AX; (* If fails, errcode is in AX *)π LockFile := false; (* IORes is a global that gets *)π end; (* used in IOReport if an error *)π end;πEnd;ππ(*-------------------------------------------------------------*)π (* Share compatable Will retry if access denied, tries timesπ 5 Tries is equivilent to a 1/2 second waitππ ----- 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 *)ππFUNCTION OpenTxtFile(var f; fname:string; tries:word):boolean;πVARπ i : word;πBeginπ i := 0;π if GotShare then (* Share loaded ? *)π beginπ AssignText(text(f),Fname); (* From TxtShare unit *)π FileMode := 34; (* Open in r/w-deny write mode *)π endπ else Assign(text(f),Fname);π Repeatπ {$I-} Reset(text(f));π IORes := IoResult; {$I+}π if IORes = 5 then (* Only repeat if denied access *)π beginπ wait(100); (* Wait 1/10 second before retry *)π INC(i); (* Use your own delay routine here *)π endπ else i := tries; (* Quit if not a sharing deny *)π Until (IORes = 0) OR (i >= tries);π if GotShare then FileMode := 2; (* Set FileMode to default *)π OpenTxtFile := IORes = 0;πEnd;ππ{ ****** Here's a quick SHARE detect routine ********* }ππFunction ShareInstalled : boolean; assembler;πasmπ mov ax,$1000π int $2fπend;ππ 49 02-15-9407:42ALL TONY NELSON Check DOS Path IMPORT 11 ┤φ:b program chkpath;ππUses Dos;ππProcedure GetNextPath ( var Path, CurrPath : String );ππVarπ SemiPos : Byte;ππBeginπππ SemiPos := Pos(';',Path);ππ If SemiPos = 0 thenπ Beginπ CurrPath := Path;π Path := '';π Endπ Elseπ Beginπ CurrPath := Copy(Path,1,SemiPos - 1);π Path := Copy(Path,SemiPos + 1, Length(Path));π End;πEnd;ππFunction CheckPath( Path : String ) : Boolean;ππVarπ Result : Integer;ππBeginππ{$I-}π ChDir(Path);π{$I-}ππ Result := IOResult;ππ CheckPath := (Result = 0);ππEnd;ππVarπ PathStr : String;π CurrPath : String;π SaveDir : String;π Count : Byte;ππBeginππ WriteLn('Check Path : By Tony Nelson : FreeWare 1993');π WriteLn('Checking your current path for nonexistent entries...');π WriteLn;ππ GetDir(0,SaveDir);ππ PathStr := GetEnv('Path');ππ While (PathStr) <> '' doπ Beginπ GetNextPath(PathStr, CurrPath);ππ If not CheckPath(CurrPath) thenπ Beginπ WriteLn(CurrPath,' is invalid!');π Inc(Count);π End;π End;πππ If Count <> 0 thenπ WriteLn;ππ WriteLn('Found ',Count,' nonexistent entries.');πππ ChDir(SaveDir);ππEnd. 50 02-15-9408:02ALL KIM KOKKONEN DPMI File Extender IMPORT 22 ┤φHP {$R-,S-}ππ{PEXTENDπ ------------------------------------------------------------------π This unit provides a single function, DpmiExtendHandles, forπ extending the file handle table for DOS protected mode applicationsπ under Borland Pascal 7.0.ππ The standard DOS call for this purpose (AH = $67) does odd things toπ DOS memory when run from a BP7 pmode program. If you Exec from aπ program that has extended the handle table, DOS memory will beπ fragmented, leaving a stranded block of almost 64K at the top of DOSπ memory. The function implemented here avoids this problem.ππ If you haven't used an ExtendHandles function before, note that youπ cannot get more handles than the FILES= statement in CONFIG.SYSπ allows. (Other utilities such as FILES.COM provided with QEMM do theπ same thing.) However, even if you have FILES=255, any single programπ cannot open more than 20 files (and DOS uses up 5 of those) unlessπ you use a routine like DpmiExtendHandles. This routine allows up toπ 255 open files as long as the FILES= statement provides for them.ππ This code works only for DOS 3.0 or later. Since (to my knowledge)π DPMI cannot be used with earlier versions of DOS, the code doesn'tπ check the DOS version.ππ Don't call this function more than once in the same program.ππ Version 1.0,π Written 12/15/92, Kim Kokkonen, TurboPower Softwareπ}ππ{$IFNDEF DPMI}π !! Error: this unit for DPMI applications onlyπ{$ENDIF}ππunit PExtend;π {-Extend handle table for DOS protected mode applications}ππinterfaceππfunction DpmiExtendHandles(Handles : Byte) : Word;π {-Extend handle table to Handles size.π Returns 0 for success, else a DOS error code.π Does nothing and returns 0 if Handles <= 20.}ππimplementationππusesπ WinApi;ππfunction DpmiExtendHandles(Handles : Byte) : Word;πtypeπ DosMemRec =π recordπ Sele, Segm : Word;π end;πvarπ OldTable : Pointer;π OldSize : Word;π NewTable : Pointer;π DosMem : DosMemRec;πbeginπ DpmiExtendHandles := 0;π if Handles <= 20 thenπ Exit;ππ {Allocate new table area in DOS memory}π LongInt(DosMem) := GlobalDosAlloc(Handles);π if LongInt(DosMem) = 0 then beginπ DpmiExtendHandles := 8;π Exit;π end;ππ {Initialize new table with closed handles}π NewTable := Ptr(DosMem.Sele, 0);π FillChar(NewTable^, Handles, $FF);ππ {Copy old table to new. Assume old table in PrefixSeg}π OldTable := Ptr(PrefixSeg, MemW[PrefixSeg:$34]);π OldSize := Mem[PrefixSeg:$32];π move(OldTable^, NewTable^, OldSize);ππ {Set new handle table size and pointer}π Mem[PrefixSeg:$32] := Handles;π MemW[PrefixSeg:$34] := 0;π MemW[PrefixSeg:$36] := DosMem.Segm;πend;ππend.π 51 05-25-9408:04ALL DAVID ADAMSON IOResult Codes SWAG9405 29 ┤φ╦ πunit CustExit;π(*--------------------------------------------------------------------------π Original source code by David Drzyzga, FidoNet 1:2619/209, SysOp ofπ =>> CUTTER JOHN'S <<= (516) 234-1737 [HST/DS/v32bis/v32ter]π Offered to the public domain 04-04-1994π---------------------------------------------------------------------------*)πinterfaceπimplementationπusesπ Crt;πvarπ ExitAddress : pointer;π{$F+}πprocedure ErrorExit;π{$F-}πbeginπ if ErrorAddr <> Nil then beginπ NormVideo;π ClrScr;π Writeln('Program terminated with error number ', ExitCode:3, '.');π case ExitCode ofπ 1..18 : write( ^G + 'DOS ERROR: ');π 100..106 : write( ^G + 'I/O ERROR: ');π 150..162,π 200..216 : write( ^G + 'CRITICAL ERROR: ');π end;π Case ExitCode ofπ 1 : Writeln('Invalid function number.');π 2 : Writeln('File not found.');π 3 : Writeln('Path not found.');π 4 : Writeln('Too many open files.');π 5 : Writeln('File access denied.');π 6 : Writeln('Invalid file handle.');π 12 : Writeln('Invalid file access code.');π 15 : Writeln('Invalid drive number.');π 16 : Writeln('Cannot remove current directory.');π 17 : Writeln('Cannot rename across drives.');π 18 : Writeln('No More Files.');π 100 : Writeln('Disk read error.');π 101 : Writeln('Disk write error.');π 102 : Writeln('File not assigned.');π 103 : Writeln('File not open.');π 104 : Writeln('File not open for input.');π 105 : Writeln('File not open for output.');π 106 : Writeln('Invalid numeric format.');π 150 : Writeln('Disk is write-protected.');π 151 : Writeln('Unknown unit.');π 152 : Writeln('Drive not ready.');π 153 : Writeln('Unknown command.');π 154 : Writeln('CRC error in data.');π 155 : Writeln('Bad drive request structure length.');π 156 : Writeln('Disk seek error.');π 157 : Writeln('Unknown media type.');π 158 : Writeln('Sector not found.');π 159 : Writeln('Printer out of paper.');π 160 : Writeln('Device write fault.');π 161 : Writeln('Device read fault.');π 162 : Writeln('Hardware failure.');π 200 : Writeln('Division by zero.');π 201 : Writeln('Range check error.');π 202 : Writeln('Stack overflow error.');π 203 : Writeln('Heap overflow error.');π 204 : Writeln('Invalid pointer operation.');π 205 : Writeln('Floating point overflow.');π 206 : Writeln('Floating point underflow.');π 207 : Writeln('Invalid floating point operation.');π 208 : Writeln('Overlay manager not installed.');π 209 : Writeln('Overlay file read error.');π 210 : Writeln('Object not initialized.');π 211 : Writeln('Call to abstract method.');π 212 : Writeln('Stream registration error.');π 213 : Writeln('Collection index out of range.');π 214 : Writeln('Collection overflow error.');π 215 : Writeln('Arithmetic overflow error.');π 216 : Writeln('General Protection fault.');π elseπ Writeln( ^G + 'Unknown Error.');π end; { Case }π ErrorAddr := Nil;π end;π Exitproc := ExitAddress; { Restore original exit address }πend; { ErrorExit }πbeginπ ExitAddress := ExitProc; { Save original exit address }π ExitProc := @ErrorExit; { Install custom exit procedure }πend. { Unit CustExit }π 52 05-25-9408:17ALL DAVID DUNSON Lockup! SWAG9405 7 ┤φR╓ {πHello All!ππHere's a little procedure that just poped into mind. It's a good way toπprevent unathorized usage of a certain task.ππ{ ------- CUT HERE ------- }ππProgram LockItUp;ππConstπ Lock = $1234;ππProcedure Lockup(Key: Word); Assembler;πASMπ MOV CX, Keyπ SUB CX, Lockπ@@1: INC CXπ LOOP @@1πEnd;ππBeginπ Lockup($1234);π WriteLn('Key works!');πEnd.ππ{ ------- CUT HERE ------- }ππYou could give someone a registration code who's CRC value will result in theπsame value as your Lock and if an incorrect value is entered, their system willπlock up (at least that task will).ππTry running the program with Lockup($1235) and see what happens. (Make sureπyou don't have anything important in memory!)ππJust an idea..ππ 53 05-25-9408:20ALL WIN VAN DER VEGT No DOS Shell SWAG9405 60 ┤φ│ò {πEver been in a situation where you want to secure a PC (for example in aπnetwork environment) by using menus from which you can't exit andπuser/software companies keep coming with software with the Shell to DOSπoption?ππHere's a simple solution which works with a lot of programs which shellπby using COMSPEC.ππThis program called execute patches it's own environment with aπreplacement COMSPEC, Does an EXEC and restores the original environment.πIt's done by making fetching all environment strings, replace comspecπwith the first commandline parameter (which should be shorter than theπoriginal comspec, so I use the program called EXIT located in theπsame directory as COMMAND.COM). Than it does an plain TP Exec (withoutπswapping to EMS/XMS/DISK etc) of the second commandline parameter withπthe rest of the commandline as it's parameters.ππI used patching the original environment of EXECUTE because the programπexecuted inherits it and EXECUTE needs comspec only to exit itself (andπreturn to a menu for example). Because of this construction it'sπpossible to exit the program started normally and return to a menu butπyou'll be unable to shell to dos and type something like FORMAT C:.ππAn example EXIT.PAS is also supplied. Pressing CTRL-BREAK etc doesn'tπmatter, you'll always return to the application from which you tried toπshell. Beware that some programs like SPSS and VP-Planner haveπdifficulties with R/O attributes on EXIT.EXE (and COMMAND.COM), so keepπit R/W.ππSo to for example disable the Turbo Pascal File/Dos use :ππEXECUTE C:\DOS\EXIT.EXE C:\TURBO55\TURBO.EXE TEST.PASππinstead ofππC:\TURBO55\TURBO TEST.PASππIf COMSPEC was C:\DOS\COMMAND.COM and Turbo Pascal was located inπthe C:\TURBO55 directory.πππRemember the extensions .EXE or .COM are necessary!ππ------------------------<cut hereππ{---------------------------------------------------------}π{ Project : Exec with Temporaryly changed 'COMSPEC' }π{ : the exec routine itself }π{ Auteur : Ir. G.W. van der Vegt }π{---------------------------------------------------------}π{ Datum .tijd Revisie }π{ 921118.0930 Creatie. }π{---------------------------------------------------------}π{ This program patches the COMSPEC environment variable }π{ with a new value (ie EXIT.EXE) and executes the }π{ program. After execution it restores the environment }π{ }π{ Syntax : }π{ }π{ EXECUTE temporary_comspec program_name [paramaters] }π{ }π{ Limits :-Only maxenv environments strings can be stored,}π{ each with a maximum length of 128 characters. }π{ -The temporary comspec must be shorter than the }π{ original one. }π{ -Environment must be smaller than 32k }π{---------------------------------------------------------}ππ{$M 4096,0,0}ππProgram Execute;ππUsesπ Crt,π Dos;πππConstπ Maxenv = 64;ππTypeπ psp = Recordπ int20adr : Word;π endofmem : Word;π res1 : Byte;π callfar : Array[1..5] OF Byte;π int22 : Pointer;π Int23 : Pointer;π Int24 : Pointer;π parentpsp: Word;π handles : Array[1..20] OF Byte;π envseg : Word;π {----More follows}π End;ππ env = array[1..32678] OF Char;ππVarπ e : ^env;π p : ^psp;π addcnt : Word; {----no of additional strings}π i : Integer; {----loop counter}π envar : Array[1..maxenv] of String[128];{----environment string storage}π noenv : Integer; {----no strings in environment}π cmdline: STRING; {----command line of program to start}π comspec: STRING; {----original comspec storage}π ch : CHAR;ππ{---------------------------------------------------------}ππProcedure Read_env;ππVarπ i,k : Integer;ππbeginπ p:=Ptr(prefixseg,0);π noenv:=0;ππ{----Show environment strings}π e:=Ptr(p^.envseg,0);π i:=1;π Inc(noenv);π envar[noenv]:='';π Repeatπ If (e^[i]<>#0)π Then envar[noenv]:=envar[noenv]+e^[i]π Elseπ Beginπ Inc(noenv);π If (noenv>=maxenv)π THENπ BEGINπ Writeln('Only ',maxenv:0,' environment strings can be stored.');π Halt;π END;ππ envar[noenv]:='';π End;π Inc(i);π Until (e^[i]=#00) AND (e^[i]=e^[i-1]);ππ{----Show Additional environment strings}π Inc(i);π addcnt:=Word(Ord(e^[i])+256*Ord(e^[i+1]));π Inc(i);π Inc(i); {----eerste character additional strings}π k:=addcnt;ππ If (noenv+addcnt>=maxenv)π THENπ BEGINπ Writeln('Only ',maxenv:0,' (additional)environment strings can be stored');π Halt;π END;ππ Repeatπ If (e^[i]<>#0)π Then envar[noenv]:=envar[noenv]+e^[i]π Elseπ Beginπ Inc(noenv);π envar[noenv]:='';π Dec(k);π End;π Inc(i);π Until (k<=0);ππ dec(noenv);ππ {Writeln(' Environment Strings : ',noenv-addcnt);π for j:=1 to noenv-addcnt doπ writeln('e ',envar[j]);π Writeln(' Additional Strings : ',addcnt);π for j:=noenv-addcnt+1 to noenv doπ writeln('a ',envar[j]);π writeln;}πend; {of Read_env}ππ{---------------------------------------------------------}ππProcedure Patch_env(envst,newval : STRING);ππVarπ i,j,k : Integer;ππBEGINπ{----change an envronment string}π for i:=1 to noenv doπ beginπ if (pos(envst+'=',envar[i])=1)π THENπ beginπ Delete(envar[i],Pos('=',envar[i])+1,Length(envar[i])-Pos('=',envar[i]));π envar[i]:=envar[i]+newval;π end;π end;ππ{----patch environment strings}π i:=1;π for j:=1 to noenv-addcnt doπ beginπ for k:=1 to Length(envar[j]) doπ beginπ e^[i]:=envar[j][k];π inc(i);π end;π e^[i]:=#0;π inc(i);π end;ππ{----patch environment string end}π e^[i]:=#0; inc(i);π{----patch additional string count}π e^[i]:=Chr(addcnt mod 256); inc(i);π e^[i]:=Chr(addcnt div 256); inc(i);ππ{----patch additional strings}π for j:=noenv-addcnt+1 to noenv doπ beginπ for k:=1 to Length(envar[j]) doπ beginπ e^[i]:=envar[j][k];π inc(i);π end;π e^[i]:=#0;π inc(i);π end;πend; {of Patch_env}ππ{---------------------------------------------------------}ππBeginπ If (Paramcount<2)π THENπ BEGINπ Writeln('Syntax : EXECUTE temporary_comspec program_name [program_param]');π Halt;π END;ππ checkbreak:=false;ππ comspec:=Getenv('COMSPEC');ππ If (Length(Paramstr(1))>Length(comspec))π THENπ BEGINπ Writeln('Path&name of temporary COMSPEC should be shorter than the original');π Halt;π END;ππ Read_env;ππ Patch_env('COMSPEC',Paramstr(1));ππ cmdline:='';π FOR i:=3 to Paramcount DOπ cmdline:=cmdline+' '+Paramstr(i);ππ Swapvectors;π Exec(Paramstr(2),cmdline);π Swapvectors;ππ WHILE Keypressed DO ch:=Readkey;ππ Patch_env('COMSPEC','C:\COMMAND.COM');πend.πππ------------------------<cut hereπππProgram Exit;ππUsesπ CRT;ππBeginπ Clrscr;π GotoXY(20,12);π Write('Sorry, SHELLing to DOS not Possible.');πEnd.π 54 05-25-9408:22ALL GREG ESTABROOKS Dos Prompt SWAG9405 30 ┤φⁿ π{π There are 2 ways that I can think of off hand. One is to executeπ COMMAND.COM with the parameter '/K PROMPT [Whatever]' OR You couldπ create your own program enviroment and then add/edit as many enviromentπ variables as you have memory for. The following program demonstratesπ this. It creates its own enviroment , then copies the old info to itπ but changes the prompt to whatever you want. After the shell itπ releases the memory:π}ππ{***********************************************************************}πPROGRAM PromptDemo; { Apr 18/94, Greg Estabrooks. }π{$M 16840,0,0} { Reserved some memory for the shell. }πUSES CRT, { IMPORT Clrscr,Writeln. }π DOS; { IMPORT Exec. }ππPROCEDURE ShellWithPrompt( Prompt :STRING );π { Routine to allocate a temporary Enviroment }π { with our prompt and the execute COMMAND.COM. }π { NOTE: This does NO error checking. }πVARπ NewEnv :WORD; { Points to our newly allocated env. }π OldEnv :WORD; { Holds Old Env Segment. }π EnvPos :WORD; { Position inside our enviroment. }π EnvLp :WORD; { Variable to loop through ENVStrings. }π TempStr:STRING; { Holds temporary EnvString info. }πBEGINπ ASMπ Mov AH,$48 { Routine to allocate memory. }π Mov BX,1024 { Allocate 1024(1k) of memory. }π Int $21 { Call DOS to allocate memory. }π Mov NewEnv,AX { Save segment address of our memory. }π END;ππ EnvPos := 0; { Initiate pos within our Env. }π FOR EnvLp := 1 TO EnvCount DO { Loop through entire enviroment. }π BEGINπ TempStr := EnvStr(EnvLp); { Retrieve Envirment string. }π IF Pos('PROMPT=',TempStr) <> 0 THEN { If its our prompt THEN .... }π TempStr := 'PROMPT='+Prompt+#0 { Create our new prompt. }π ELSE { .... otherwise......... }π TempStr := TempStr + #0; { Add NUL to make it ASCIIZ compatible. }π Move(TempStr[1],Mem[NewEnv:EnvPos],Length(TempStr)); { Put in Env. }π INC(EnvPos,Length(TempStr)); { Point to new position in Enviroment. }π END;{For}ππ OldEnv := MemW[PrefixSeg:$2C];{ Save old enviroment segment. }π MemW[PrefixSeg:$2C] := NewEnv;{ Point to our new enviroment. }π SwapVectors; { Swap Int vectors in case of conflicts.}π Exec(GetEnv('COMSPEC'),''); { Call COMMAND.COM. }π SwapVectors; { Swap em back. }π MemW[PrefixSeg:$2C] := OldEnv;{ Point back to old enviroment. }ππ ASMπ Push ES { Save ES. }π Mov AH,$49 { Routine to deallocate memory. }π Mov ES,NewEnv { Point ES to area to deallocate. }π Int $21; { Call DOS to free memory. }π Pop ES { Restore ES. }π END;πEND;{ShellWithPrompt}ππBEGINπ Clrscr; { Clear the screen. }π Writeln('Type EXIT to return');{ Show message on how to exit shell. }π ShellWithPrompt('[PromptDemo] $P$G'); { shell to DOS with our prompt. }πEND.{PromptDemo}π{***********************************************************************}π 55 05-25-9408:22ALL THOMAS SKOGESTAD Customizing Run-Time! SWAG9405 37 ┤φôh πUnit SHOWREM;π{Show Runtime Error Messages}π{Written by C. Enders (1994)}π{Usage : Write the next line in your Main pascal program.π Uses Showrem;π This unit provides the meaning of the error codes while you are runningπ your pascal programs. If other users are using your program they getπ frustrated if they see a message likeπ Runtime error 200: at 1234:abcd.π This unit let your program show error messages like :π Runtime Error 200: Division by zero.π Use of this program is free and no royalties must be paid if you use thisπ routines in your (commercial) programs (perhaps some credits like thanksπ to ...).π If you need any help e-mail at C.W.G.M.ENDERS@KUB.NLπ}ππInterFaceππImplementationππProcedure WriteErrormessage;πBeginπ Writeln;π Case Exitcode ofπ 1 : Writeln('Runtime Error ',exitcode,': ','Invalid function number.');π 2 : Writeln('Runtime Error ',exitcode,': ','File not found.');π 3 : Writeln('Runtime Error ',exitcode,': ','Path not found.');π 4 : Writeln('Runtime Error ',exitcode,': ','Too many open files.');π 5 : Writeln('Runtime Error ',exitcode,': ','File access denied.');π 6 : Writeln('Runtime Error ',exitcode,': ','Invalid file handle.');π 12 : Writeln('Runtime Error ',exitcode,': ','Invalid file access code.');π 15 : Writeln('Runtime Error ',exitcode,': ','Invalid drive number.');π 16 : Writeln('Runtime Error ',exitcode,': ','Cannot remove currentπdirectory.');π 17 : Writeln('Runtime Error ',exitcode,': ','Cannot rename acrossπdrives.');π 18 : Writeln('Runtime Error ',exitcode,': ','No more files.');π 100 : Writeln('Runtime Error ',exitcode,': ','Disk read error.');π 101 : Writeln('Runtime Error ',exitcode,': ','Disk write error.');π 102 : Writeln('Runtime Error ',exitcode,': ','File not assigned.');π 103 : Writeln('Runtime Error ',exitcode,': ','File not open.');π 104 : Writeln('Runtime Error ',exitcode,': ','File not open for input.');π 105 : Writeln('Runtime Error ',exitcode,': ','File not open for output.');π 106 : Writeln('Runtime Error ',exitcode,': ','Invalid numeric format.');π 150 : Writeln('Runtime Error ',exitcode,': ','Disk is write-protected.');π 151 : Writeln('Runtime Error ',exitcode,': ','Bad drive request structπlength.');π 152 : Writeln('Runtime Error ',exitcode,': ','Drive not ready.');π 154 : Writeln('Runtime Error ',exitcode,': ','CRC error in data.');π 156 : Writeln('Runtime Error ',exitcode,': ','Disk seek error.');π 157 : Writeln('Runtime Error ',exitcode,': ','Unknown media type.');π 158 : Writeln('Runtime Error ',exitcode,': ','Sector Not Found.');π 159 : Writeln('Runtime Error ',exitcode,': ','Printer out of paper.');π 160 : Writeln('Runtime Error ',exitcode,': ','Device write fault.');π 161 : Writeln('Runtime Error ',exitcode,': ','Device read fault.');π 162 : Writeln('Runtime Error ',exitcode,': ','Hardware failure.');π 200 : Writeln('Runtime Error ',exitcode,': ','Division by zero.');π 201 : Writeln('Runtime Error ',exitcode,': ','Range check error.');π 202 : Writeln('Runtime Error ',exitcode,': ','Stack overflow error.');π 203 : Writeln('Runtime Error ',exitcode,': ','Heap overflow error.');π 204 : Writeln('Runtime Error ',exitcode,': ','Invalid pointer operation.');π 205 : Writeln('Runtime Error ',exitcode,': ','Floating point overflow.');π 206 : Writeln('Runtime Error ',exitcode,': ','Floating point underflow.');π 207 : Writeln('Runtime Error ',exitcode,': ','Invalid floating point operation.');π 208 : Writeln('Runtime Error ',exitcode,': ','Overlay manager not installed.');π 209 : Writeln('Runtime Error ',exitcode,': ','Overlay file read error.');π 210 : Writeln('Runtime Error ',exitcode,': ','Object not initialized.');π 211 : Writeln('Runtime Error ',exitcode,': ','Call to abstract method.');π 212 : Writeln('Runtime Error ',exitcode,': ','Stream registration error.');π 213 : Writeln('Runtime Error ',exitcode,': ','Collection index out of range.');π 214 : Writeln('Runtime Error ',exitcode,': ','Collection overflow error.');π 215 : Writeln('Runtime Error ',exitcode,': ','Arithmetic overflow error.');π 216 : Writeln('Runtime Error ',exitcode,': ','General Protection fault.');π End; {case}π ErrorAddr := Nil; {This can be Nil, if so you borland IDE will notπ display the Runtime Error Message}πEnd; {WriteErrorMessage}ππProcedure InitError;πBeginπ ExitProc := @WriteErrormessage;πEnd;{InitError}ππBegin{Body}π InitError;πEnd.π 56 05-26-9406:19ALL LARRY HADLEY Which Compiler IMPORT 93 ┤φ {πHi !ππ Here is some source code I acquired from a Pascal echo some timeπ ago. It shows one method of detecting which TP compiler createdπ an .EXE:ππ-------------------------------------------------------------------π{ to compile type: tpc foo.pas }π{ exe: 9776 bytes by TP5.5 }ππ{$A+,B-,E-,F-,I+,N-,O-,V+}π{$M 4500,0,0}π{$ifndef debug}π{$D-,L-,R-,S-}π{$else}π{$D+,L+,R+,S+}π{$endif}ππProgram foo;ππUsesπ DOS; { dos unit from turbo pascal }ππTYPE { normal exe file header }π EXEH = RECORDπ id, { exe signature }π Lpage, { exe file size mod 512 bytes; < 512 bytes }π Fpages, { exe file size div 512 bytes; + 1 if Lpage > 0 }π relocitems, { number of relocation table items }π size, { exe header size in 16-byte paragraphs }π minalloc, { min mem. required in additional to exe image }π maxalloc, { extra max. mem. desired beyond that requiredπ to hold exe's image }π ss, { displacement of stack segment }π sp, { initial SP register value }π chk_sum, { complemented checksum }π ip, { initial IP register value }π cs, { displacement of code segment }π ofs_rtbl, { offset to first relocation item }π ovr_num : word; { overlay numbers }π END;π { window exe file header }π WINH = RECORDπ id : word; { ignore the rest of data structures }π END;ππ str2 = string [2];π str4 = string [4];π str10 = string [10];ππCONSTπ no_error = 0; { no system error }π t = #9; { ascii: hortizon tab }π dt = t+t;π tt = t+t+t;π qt = t+t+t+t;π cr = #13#10; { ascii: carriage return and line feed }ππVARπ f : file; { source file, untyped }π exehdr : exeh; { exe header contents }π winhdr : winh; { window exe header contents }π blocks_r : word; { number of blocks actually read }ππ exe_size , { exe file length }π hdr_size , { exe header size }π img_size , { load module or exe image size }π min_xmem , { min. extra memory needed }π max_xmem , { max. extra memory wanted }π o_starup : longint; { offset to start up code }ππ dirfile : searchrec;π compressed : boolean;ππfunction Hex(B :byte) :str2;π CONST strdex :array [0..$F] of char = '0123456789ABCDEF';π BEGIN Hex := concat(strdex[B shr 4], strdex[B and $F]); END;ππfunction HexW(W :word) :str4;π VAR byt :array [0..1] of byte absolute W;π BEGIN HexW := Hex(byt[1])+Hex(byt[0]); END;ππfunction HexL(L :longint) :str10;π TYPE Cast = RECORDπ Lo :word;π Hi :word;π END;π BEGIN HexL := HexW(Cast(L).Hi)+' '+HexW(Cast(L).Lo); END;ππprocedure print_info;π CONSTπ psp_size = $100; { size of psp, bytes }π VAR i : byte;π BEGINπ hdr_size := longint(exehdr.size) shl 4; { exe header size, bytes }π img_size := longint(exe_size) - hdr_size; { exe image size, bytes }π min_xmem := longint(exehdr.minalloc) shl 4; { mim xtra mem, bytes }π max_xmem := longint(exehdr.maxalloc) shl 4; { max xtra mem, bytes }π o_starup := hdr_size + longint(exehdr.cs) shl 4π +longint(exehdr.ip); { ofs to start up code }π writeln(π qt, 'Dec':8, '':6, 'Hex', cr,π 'EXE file size:', tt, exe_size:8, '':3, hexl(exe_size), cr,π 'EXE header size:', dt, hdr_size:8, '':3, hexl(hdr_size), cr,π 'Code + initialized data size:', t, img_size:8, '':3, hexl(img_size)π );ππ writeln(π 'Pre-relocated SS:SP', tt, '':3, hexw(exehdr.ss), ':', hexw(exehdr.sp)π , cr,π 'Pre-relocated CS:IP', tt, '':3, hexw(exehdr.cs), ':', hexw(exehdr.ip)π );ππ writeln(π 'Min. extra memory required:', t, min_xmem:8, '':3, hexl(min_xmem), cr,π 'Max. extra memory wanted:', t, max_xmem:8, '':3, hexl(max_xmem), cr,π 'Offset to start up code:', dt, '':3, hexl(o_starup), cr,π 'Offset to relocation table:', dt, '':3, hexw(exehdr.ofs_rtbl):9π );ππ writeln(π 'Number of relocation pointers:', t, exehdr.relocitems:8, cr,π 'Number of MS overlays:', dt, exehdr.ovr_num:8, cr,π 'File checksum value:', tt, '':3, hexw(exehdr.chk_sum):9, cr,π 'Memory needed to start:', dt, img_size+min_xmem+psp_size:8π );πEND; { print_info }ππprocedure id_signature; { the core of this program }π CONSTπ o_01 = 14; { relative offset from cstr0 to cstr1 }π o_02 = 16; { " " " cstr0 to cstr2 }π o_03 = 47; { " " " cstr0 to cstr3 }π cstr0 = 'ntime'; { constant string existed in v4-6 }π cstr1 = 'at '#0'.'; { constant string existed in v4-6 }π cstr2 = '$4567'; { constant string existed in v5-6 }π cstr3 = '83,90'; { constant string existed in v6 only }π strlen = 5; { length of cstr? }π ar_itm = 3; { items+1 of string array }ππ { the following figures have been turn-up explicitly andπ should not be changed }ππ ofs_rte = 25 shl 4; { get close to 'run time error' str contants }π maxchar = 11 shl 4; { max. size of buffer; for scanning }ππ TYPEπ arstr = array [0..ar_itm] of string[strlen];π arbuf = array [0..maxchar] of char;ππ VARπ i, j, k : word; { index counter for array buffer }π cstr : arstr; { signatures generated by tp compiler }π o_fseg : word; { to hold segment value of any far call }π o_sysseg: longint; { offset to tp system_unit_segment }π buffer : arbuf; { searching for target strings }ππ BEGINπ{d} Seek(f, o_starup + 3); { move file pointer πforward 3 bytes }π{d} BlockRead(f, o_fseg, sizeof(o_fseg)); { get far call segment πvalue }π o_sysseg := longint(o_fseg) shl 4 +hdr_size; { ofs to system obj code }π if (o_sysseg + ofs_rte <= dirfile.size) thenπ BEGINπ{d} Seek(f, o_sysseg+ofs_rte); { offset nearby tp πsignatures }π{d} BlockRead(f, buffer, sizeof(buffer), blocks_r);π for i := 0 to ar_itm doπ BEGINπ cstr[i][0] := char(strlen);π fillchar(cstr[i][1], strlen, '*');π END;π i := 1; j := 1; k := 0;π repeatπ if buffer[i] in ['n','t','i','m','e'] thenπ BEGINπ if (k > 0) and (k = i - 1) thenπ inc(j);π cstr[0][j] := buffer[i];π k := i;π END;π inc(i);π until (cstr[0] = cstr0) or (i > maxchar) or (j > strlen);π if (i+o_03 <= maxchar) thenπ BEGINπ dec(i, strlen);π move(buffer[i+o_01], cstr[1][1], strlen);π if (cstr[1] = cstr1) thenπ BEGINπ writeln(π cr, 'Offset to TP system code:', dt, '':3,π hexl(o_sysseg):9π );ππ write('Compiled by Borland TP v');ππ move(buffer[i-o_02], cstr[2][1], strlen);ππ if (cstr[2] = cstr2) thenπ BEGINπ move(buffer[i+o_03], cstr[3][1], strlen);π if (cstr[3] = cstr3) THENπ writeln('6.0')π ELSEπ writeln('5.0/5.5');π ENDπ ELSEπ writeln('4.0');π END;π END;π END;π END; {procedure}ππprocedure process_exefile;π CONSTπ ofs_whdr = $3C; { offset to MS-Window exe file id }π exwid = $454E; { MS-Window exe file id }π VARπ o_sign,π fsize :longint;π BEGINπ if (exe_size = dirfile.size) thenπ BEGINπ print_info;π if not compressed thenπ id_signature;π writeln;π ENDπ elseπ BEGINπ{d} Seek(f, ofs_whdr); { offset to 'offset to window exe πsignature' }π{d} BlockRead(f, hdr_size, sizeof(hdr_size));π{d} if (hdr_size <= dirfile.size) thenπ BEGINπ Seek(f, hdr_size); { offset to new exe signature }π{d} BlockRead(f, winhdr, sizeof(winhdr));π END;π if (winhdr.id = exwid) thenπ BEGINπ writeln('Dos/MS-Window EXE or DLL file');π print_info;π EXIT;π ENDπ elseπ BEGINπ print_info;π writeln(π cr,π 'file size (', exe_size, ') calculated from EXE header ',π '(load by DOS upon exec)', cr,π 'doesn''t match with file size (', dirfile.size, ') ',π 'recorded on file directory.', cr, cr,π '* EXE file saved with extra bytes at eof (e.g. debug info)', cr,π '* EXE file may contain overlays', cr,π '* possible a corrupted EXE file', crπ );ππ EXIT;π END;π END;π END;ππprocedure id_file;π CONSTπ exeid = $5A4D; { MS-DOS exe file id }ππ VARπ zero : str2;ππ BEGINπ if (exehdr.id = exeid) thenπ BEGINπ if (exehdr.cs = $FFF0) andπ (exehdr.ip = $0100) andπ (exehdr.ofs_rtbl = $50) orπ (exehdr.ofs_rtbl = $52) thenπ BEGINπ writeln('Compressed by PKLITE');π compressed := true;π END;π if (exehdr.size = 2) and (exehdr.chk_sum = $899D) thenπ BEGINπ writeln( 'Compressed by DIET');π compressed := true;π END;π if (exehdr.Lpage > 0) thenπ exe_size := longint(exehdr.Fpages - 1) shl 9+exehdr.Lpageπ elseπ exe_size := longint(exehdr.Fpages) shl 9;π process_exefile;π ENDπ elseπ writeln('Not EXE file');π END; {procedure}ππCONSTπ blocksize = 1; { file r/w block size in one-byte unit }ππVARπ path : dirstr;π name : namestr;π ext : extstr;π fstr : string[48];π n : byte;ππBEGINπ if paramcount < 1 thenπ n := 0π elseπ n := 1;ππ fsplit(paramstr(n), path, name, ext);π if (name+ext = '*.*') or (name+ext = '.' ) or (name+ext = '' ) thenπ fstr := path+'*.exe'π elseπ if (path+ext = '') thenπ fstr := paramstr(n)+'.exe'π elseπ if not boolean(pos('.', ext)) thenπ BEGINπ path := path+name+'\';π fstr := path+'*.exe';π ENDπ elseπ fstr := paramstr(n);ππ n := 0;π{d} findfirst(fstr, anyfile, dirfile);π while (doserror = no_error) doπ BEGINπ if (dirfile.attr and volumeid <> volumeid) andπ (dirfile.attr and directory <> directory) andπ (dirfile.attr and sysfile <> sysfile) thenπ BEGINπ compressed := false;π Assign(f, path+dirfile.name); {$I-}π{d} Reset(f, blocksize); {$I+}π if (IOResult = no_error) thenπ BEGINπ writeln(cr, dirfile.name);π{d} BlockRead(f, exehdr, sizeof(exehdr), blocks_r);π if (blocks_r = sizeof(exehdr)) thenπ id_fileπ elseπ writeln('err:main');π close(f);π inc(n);π END;π END;π{d} findnext(dirfile);π END;ππ if (n = 0) thenπ if doserror = 3 thenπ writeln('path not found')π elseπ writeln('file not found')π elseπ writeln(n,' files found');πEND.π 57 05-26-9406:20ALL HENNING FUCHS BOOT Source IMPORT 5 ┤φ t πprocedure ColdBoot; assembler;πasmπ xor ax,axπ mov ds,axπ mov ah,$40π mov es,axπ mov word ptr es:$72,0π mov ax,$FFFFπ mov es,axπ xor si,siπ push axπ push siπ retfπend;ππprocedure WarmBoot; assembler;πasmπ xor ax,axπ mov ds,axπ mov ah,$40π mov es,axπ mov word ptr es:$72,$1234π mov ax,$FFFFπ mov es,axπ xor si,siπ push axπ push siπ retfπend;ππ 58 08-24-9413:32ALL FRANK DIACHEYSN DOS Flush function SWAG9408 aⁿΓ@ 10 ┤φ {π Coded By Frank Diacheysn Of Gemini Softwareππ FUNCTION DOSFLUSHππ Input......: F = Variable File (Text Or File) To "Flush"π :π :π :π :ππ Output.....: Logicalπ : TRUE = Successfully Flushed Buffersπ : FALSE = Flush Failedπ :π :ππ Example....: IF DOSFLUSH( TextFile ) THENπ : WriteLn('DOS Buffers For TEMP.TXT Flushed To Disk.')π : ELSEπ : WriteLn('DOS Error While Trying To Flush Buffers For TEMP.TXT');π :ππ Description: Flushes DOS Buffers For A Fileπ :π :π :π :ππ}πFUNCTION DOSFLUSH( VAR F ):BOOLEAN; ASSEMBLER;πASMπ MOV AX, 3000Hπ INT 21Hπ CMP AL, 3π JL @Oldπ CMP AH, 1EHπ LES DI, Fπ MOV BX, ES:[DI]π MOV AH, 68Hπ INT 21Hπ JC @BadEndπ JMP @GoodEndππ @Old:π LES DI, Fπ MOV BX, ES:[DI]π MOV AH, 45Hπ INT 21Hπ JC @BadEndπ @Ok:π MOV BX, AXπ MOV AH, 3EHπ INT 21Hπ JC @BadEndπ @GoodEnd:π MOV AX, 0π @BadEnd:πEND;π 59 08-24-9413:34ALL ANDREW EIGUS Enhanced DOS Interface SWAG9408 nyµ 408 ┤φ {πI'm very glad to be useful and to post the enhanced DOS unit for Turbo Pascalπ7.0. It includes lots of nice routines written on inline asm, combined withπshort comments and explanations. All you have in standard DOS unit you mayπfind in EnhDOS as well except of Exec and SwapVectors. Sure, the full sourceπcode!ππWhat is good?π-----------------ππ1. Fast! (because of the asm)π2. Flexible! (less procedures, more functions, lots of parameters)π3. Good error-handling routines. (don't need to care to check errors at all)π4. _Strong_ file service. (lots of file functions)π5. Lots of additional DOS service functions that can't be found in any standardπ or non-standard Pascal, C,... library.π6. Windows (tm) compatible (means you may use these routines when developingπ Windows (tm) applications.π7. Own memory allocate/release routines. (used DOS memory allocation)π8. Free. Released to a Public Domain.ππWhat is bad?π-----------------ππ1. Requires Borland Turbo Pascal version 7.0 or later (7.01)π2. Requires DOS 3.1 or later. Sorry guys, wanna cool service - need later DOS.π3. Won't run on XT personal computers. (uses 286 instructions)π4. No more strings. (all string-type names are of PChar type)π5. Exec and SwapVectors not implemented. If you'd like this code, I willπ continue modifying this unit and will eventually add the above functionsπ too.ππWell, routines were checked on IBM PS/2 386SX, seems like work fine!ππGreetingz toπ-----------------ππ Bas van Gaalen (cool asm programmer and my PASCAL area friend ;)π Dj Murdoch (best explainer ;)π Gayle Davis (SWAG live forever) Feel free to place it into a next SWAG bundle.π Ralph Brown (brilliant idea to make the interrupt list)π Alex Grischenko (whose asm help was very appreciated)π ...and all of you, guys!ππMaterial usedπ-----------------ππBorland Pascal 7.0 Runtime Library source codeπRalph Brown's Interrupt ListπTech Help 4.0πππYou may use this source-code-software in ANY purpose. Code may be changed.πIf some of the routines won't work, please send me a message.πIf you don't mind, please leave my copyright strings as they are.}ππUnit EnhDOS;π(*π Turbo Pascal 7.0 - ENHDOS.PASππ Enhanced DOS interface unit for DOS 3.1+ *** Version 1.1 April, 1994.π Copyright (c) 1994 by Andrew Eigus Fidonet 2:5100/33ππ Runtime Library Portions Copyright (c) 1991,92 Borland International }ππ THIS UNIT SOURCE IS FREEπ*)ππinterfaceππ{$X+} { Enable extended syntax }π{$G+} { Enable 286+ instructions }ππconstππ { My copyright information }ππ Copyright : PChar = 'Portions Copyright (c) 1994 by Andrew Eigus';ππ { GetDriveType return values }ππ dtError = $00; { Bad drive }π dtFixed = $01; { Fixed drive }π dtRemovable = $02; { Removable drive }π dtRemote = $03; { Remote (network) drive }ππ { Handle file open modes (om) constants }ππ omRead = $00; { Open file for input only }π omWrite = $01; { Open file for output only }π omReadWrite = $02; { Open file for input or/and output (both modes) }π omShareCompat = $00; { Modes used when SHARE.EXE loaded }π omShareExclusive = $10;π omShareDenyWrite = $20;π omShareDenyRead = $30;π omShareDenyNone = $40;ππ { Maximum file name component string lengths }ππ fsPathName = 79;π fsDirectory = 67;π fsFileSpec = 12;π fsFileName = 8;π fsExtension = 4;ππ { FileSplit return flags }ππ fcExtension = $0001;π fcFileName = $0002;π fcDirectory = $0004;π fcWildcards = $0008;ππ { File attributes (fa) constants }ππ faNormal = $00;π faReadOnly = $01;π faHidden = $02;π faSysFile = $04;π faVolumeID = $08;π faDirectory = $10;π faArchive = $20;π faAnyFile = $3F;ππ { Seek start offset (sk) constants }ππ skStart = 0; { Seek position relative to the beginning of a file }π skPos = 1; { Seek position relative to a current file position }π skEnd = 2; { Seek position relative to the end of a file }ππ { Error handler function (fr) result codes }ππ frOk = 0; { Continue program }π frRetry = 1; { Retry function once again }ππ { Function codes (only passed to error handler routine) (fn) constants }ππ fnGetDPB = $3200;π fnGetDiskSize = $3600;π fnGetDiskFree = $3601;π fnGetCountryInfo = $3800;π fnSetDate = $2B00;π fnSetTime = $2D00;π fnIsFixedDisk = $4408;π fnIsNetworkDrive = $4409;π fnCreateDir = $3900;π fnRemoveDir = $3A00;π fnGetCurDir = $4700;π fnSetCurDir = $3B00;π fnDeleteFile = $4100;π fnRenameFile = $5600;π fnGetFileAttr = $4300;π fnSetFileAttr = $4301;π fnFindFirst = $4E00;π fnFindNext = $4F00;π fnCreateFile = $5B00;π fnCreateTempFile = $5A00;π fnOpenFile = $3D00;π fnRead = $3F00;π fnWrite = $4000;π fnSeek = $4200;π fnGetFDateTime = $5700;π fnSetFDateTime = $5701;π fnCloseFile = $3E00;π fnMemAlloc = $4800;π fnMemFree = $4900;ππ { DOS 3.x+ errors/return codes }ππ dosrOk = 0; { Success }π dosrInvalidFuncNumber = 1; { Invalid DOS function number }π dosrFileNotFound = 2; { File not found }π dosrPathNotFound = 3; { Path not found }π dosrTooManyOpenFiles = 4; { Too many open files }π dosrFileAccessDenied = 5; { File access denied }π dosrInvalidFileHandle = 6; { Invalid file handle }π dosrNotEnoughMemory = 8; { Not enough memory }π dosrInvalidEnvment = 10; { Invalid environment }π dosrInvalidFormat = 11; { Invalid format }π dosrInvalidAccessCode = 12; { Invalid file access code }π dosrInvalidDrive = 15; { Invalid drive number }π dosrCantRemoveDir = 16; { Cannot remove current directory }π dosrCantRenameDrives = 17; { Cannot rename across drives }π dosrNoMoreFiles = 18; { No more files }ππtypeππ TPathStr = array[0..fsPathName] of Char;π TDirStr = array[0..fsDirectory] of Char;π TNameStr = array[0..fsFileName] of Char;π TExtStr = array[0..fsExtension] of Char;π TFileStr = array[0..fsFileSpec] of Char;ππ { Disk information block structure }ππ PDiskParamBlock = ^TDiskParamBlock;π TDiskParamBlock = recordπ Drive : byte; { Disk drive number (0=A, 1=B, 2=C...) }π SubunitNum : byte; { Sub-unit number from driver device header }π SectSize : word; { Number of bytes per sector }π SectPerClust : byte; { Number of sectors per cluster -1π (max sector in cluster) }π ClustToSectShft : byte; { Cluster-to-sector shift }π BootSize : word; { Reserved sectors (boot secs; start of root dir}π FATCount : byte; { Number of FATs }π MaxDir : word; { Number of directory entries allowed in root }π DataSect : word; { Sector number of first data cluster }π Clusters : word; { Total number of allocation units (clusters)π +2 (number of highest cluster) }π FATSectors : byte; { Sectors needed by first FAT }π RootSect : word; { Sector number of start of root directory }π DeviceHeader : pointer; { Address of device header }π Media : byte; { Media descriptor byte }π AccessFlag : byte; { 0 if drive has been accessed }π NextPDB : pointer { Address of next DPB (0FFFFh if last) }π end;ππ { Disk allocation data structure }ππ PDiskAllocInfo = ^TDiskAllocInfo;π TDiskAllocInfo = recordπ FATId : byte; { FAT Id }π Clusters : word; { Number of allocation units (clusters) }π SectPerClust : byte; { Number of sectors per cluster }π SectSize : word { Number of bytes per sector }π end;ππ { Country information structure }ππ PCountryInfo = ^TCountryInfo;π TCountryInfo = recordπ DateFormat : word; { Date format value may be one of the following:π 0 - Month, Day, Year (USA)π 1 - Day, Month, Year (Europe)π 2 - Year, Month, Day (Japan) }ππ CurrencySymbol : array[0..4] of Char; { Currency symbol string }π ThousandsChar : byte; { Thousands separator character }π reserved1 : byte;π DecimalChar : byte; { Decimal separator character }π reserved2 : byte;π DateChar : byte; { Date separator character }π reserved3 : byte;π TimeChar : byte; { Time separator character }π reserved4 : byte;π CurrencyFormat : byte; { Currency format:π $XXX.XXπ XXX.XX$π $ XXX.XXπ XXX.XX $π XXX$XX }ππ Digits : byte; { Number of digits after decimal in currency }π TimeFormat : byte; { Time format may be one of the following:π bit 0 = 0 if 12 hour clockπ 1 if 24 hour clock }ππ MapRoutine : pointer; { Address of case map routine FAR CALL,π AL - character to map to upper case [>=80h] }ππ DataListChar : byte; { Data-list separator character }π reserved5 : byte;π reserved6 : array[1..10] of Charπ end;ππ THandle = Word; { Handle type (file handle and memory handle functions) }ππ { Error handler function }ππ TErrorFunc = function(ErrCode : integer; FuncCode : word) : byte;ππ { Search record used by FindFirst and FindNext }ππ TSearchRec = recordπ Fill : array[1..21] of Byte;π Attr : byte;π Time : longint;π Size : longint;π Name : TFileStrπ end;ππ { Date and time record used by PackTime and UnpackTime }ππ TDateTime = recordπ Year,π Month,π Day,π Hour,π Min,π Sec : wordπ end;πππvarπ DOSResult : integer; { Error status variable }π TempStr : array[0..High(String)] of Char;ππfunction SetErrorHandler(Handler : TErrorFunc) : pointer;πfunction Pas2PChar(S : string) : PChar;ππfunction GetInDOSFlag : boolean;πfunction GetDOSVersion : word;πfunction GetSwitchChar : char;πfunction SetSwitchChar(Switch : char) : byte;πfunction GetCountryInfo(var Info : TCountryInfo) : integer;πprocedure GetDate(var Year : word; var Month, Day, DayOfWeek : byte);πfunction SetDate(Year : word; Month, Day : byte) : boolean;πprocedure GetTime(var Hour, Minute, Second, Sec100 : byte);πfunction SetTime(Hour, Minute, Second, Sec100 : byte) : boolean;πfunction GetCBreak : boolean;πfunction SetCBreak(Break : boolean) : boolean;πfunction GetVerify : boolean;πfunction SetVerify(Verify : boolean) : boolean;πfunction GetArgCount : integer;πfunction GetArgStr(Dest : PChar; Index : integer; MaxLen : word) : PChar;πfunction GetEnvVar(VarName : PChar) : PChar;πfunction GetIntVec(IntNo : byte; var Vector : pointer) : pointer;πfunction SetIntVec(IntNo : byte; Vector : pointer) : pointer;ππfunction GetDTA : pointer;πfunction GetCurDisk : byte;πfunction SetCurDisk(Drive : byte) : byte;πprocedure GetDriveAllocInfo(Drive : byte; var Info : TDiskAllocInfo);πfunction GetDPB(Drive : byte; var DPB : TDiskParamBlock) : integer;πfunction DiskSize(Drive : byte) : longint;πfunction DiskFree(Drive : byte) : longint;πfunction IsFixedDisk(Drive : byte) : boolean;πfunction IsNetworkDrive(Drive : byte) : boolean;πfunction GetDriveType(Drive : byte) : byte;ππfunction CreateDir(Dir : PChar) : integer;πfunction RemoveDir(Dir : PChar) : integer;πfunction GetCurDir(Drive : byte; Dir : PChar) : integer;πfunction SetCurDir(Dir : PChar) : integer;ππfunction DeleteFile(Path : PChar) : integer;πfunction RenameFile(OldPath, NewPath : PChar) : integer;πfunction ExistsFile(Path : PChar) : boolean;πfunction GetFileAttr(Path : PChar) : integer;πfunction SetFileAttr(Path : PChar; Attr : word) : integer;πfunction FindFirst(Path : PChar; Attr: word; var F : TSearchRec) : integer;πfunction FindNext(var F : TSearchRec) : integer;πprocedure UnpackTime(P : longint; var T : TDateTime);πfunction PackTime(var T : TDateTime) : longint;ππfunction h_CreateFile(Path : PChar) : THandle;πfunction h_CreateTempFile(Path : PChar) : THandle;πfunction h_OpenFile(Path : PChar; Mode : byte) : THandle;πfunction h_Read(Handle : THandle; var Buffer; Count : word) : word;πfunction h_Write(Handle : THandle; var Buffer; Count : word) : word;πfunction h_Seek(Handle : THandle; SeekPos : longint; Start : byte) : longint;πfunction h_FilePos(Handle : THandle) : longint;πfunction h_FileSize(Handle : THandle) : longint;πfunction h_Eof(Handle : THandle) : boolean;πfunction h_GetFTime(Handle : THandle) : longint;πfunction h_SetFTime(Handle : THandle; DateTime : longint) : longint;πfunction h_CloseFile(Handle : THandle) : integer;ππfunction MemAlloc(Size : longint) : pointer;πfunction MemFree(P : pointer) : integer;ππfunction FileSearch(Dest, Name, List : PChar) : PChar;πfunction FileExpand(Dest, Name : PChar) : PChar;πfunction FileSplit(Path, Dir, Name, Ext : PChar) : word;ππimplementationππ{$IFDEF Windows}π{$DEFINE ProtectedMode}π{$ENDIF}ππ{$IFDEF DPMI}π{$DEFINE ProtectedMode}π{$ENDIF}ππ{$IFDEF Windows}ππuses WinTypes, WinProcs, Strings;ππ{$ELSE}ππuses Strings;ππ{$ENDIF}ππconst DOS = $21; { DOS interrupt number }ππvarπ ErrorHandler : TErrorFunc;ππFunction SetErrorHandler;π{ Sets the new error handler to hook all errors returned by EnhDOS functions,π and returns the pointer to an old interrupt handler routine }πBeginπ SetErrorHandler := @ErrorHandler;π ErrorHandler := HandlerπEnd; { SetErrorHandler }ππFunction Pas2PChar(S : string) : PChar;π{ Returns PChar type equivalent of the S variable. Use this functionπ to convert strings to PChars }πBeginπ Pas2PChar := StrPCopy(TempStr, S)πEnd; { Pas2PChar }ππ{$IFDEF Windows}ππprocedure AnsiDosFunc; assembler;πasmπ PUSH DSπ PUSH CXπ PUSH AXπ MOV SI,DIπ PUSH ESπ POP DSπ LEA DI,TempStrπ PUSH SSπ POP ESπ MOV CX,fsPathNameπ CLDπ@@1:π LODSBπ OR AL,ALπ JE @@2π STOSBπ LOOP @@1π@@2:π XOR AL,ALπ STOSBπ LEA DI,TempStrπ PUSH SSπ PUSH DIπ PUSH SSπ PUSH DIπ CALL AnsiToOemπ POP AXπ POP CXπ LEA DX,TempStrπ PUSH SSπ POP DSπ INT DOSπ POP DSπend; { AnsiDosFunc /Windows }ππ{$ELSE}ππprocedure AnsiDosFunc; assembler;πasmπ PUSH DSπ MOV DX,DIπ PUSH ESπ POP DSπ INT DOSπ POP DSπend; { AnsiDosFunc }ππ{$ENDIF}ππFunction GetInDOSFlag; assembler;π{ GETINDOSFLAG - DOS service functionπ Description: Returns the current state of InDOS flag; fn=34hπ Returns: True if a DOS operation is being performed, False if there isπ no DOS command that currently is running }πAsmπ MOV AH,34hπ INT DOSπ MOV AL,BYTE PTR [ES:BX]πEnd; { GetInDOSFlag }ππFunction GetDOSVersion; assembler;π{ GETDOSVERSION - DOS service functionπ Description: Retrieves DOS version number; fn=30hπ Returns: Major DOS version number in low-order byte,π minor version number in high-order byte of word }πAsmπ MOV AH,30hπ INT DOSπEnd; { GetDOSVersion }ππFunction GetSwitchChar; assembler;π{ GETSWITCHCHAR - DOS service functionπ Description: Retrieves DOS command line default switch character; fn=37hπ Returns: Switch character ('/', '-', ...) or FFh if unsupported subfunction }πAsmπ MOV AH,37hπ XOR AL,ALπ INT DOSπ CMP AL,0FFhπ JE @@1π MOV AL,DLπ@@1:πEnd; { GetSwitchChar }ππFunction SetSwitchChar; assembler;π{ SETSWITCHCHAR - DOS service functionπ Description: Sets new DOS command line switch character; fn=37hπ Returns: FFh if unsupported subfunction, any other value success }πAsmπ MOV AX,3701hπ MOV DL,Switchπ INT DOSπEnd; { SetSwitchChar }ππFunction GetCountryInfo; assembler;π{ GETCOUNTRYINFO - DOS service functionπ Description: Retrieves country information; fn=38hπ Returns: Country code if successful, negative DOS error code otherwise }πAsmπ@@1:π PUSH DSπ MOV AH,38hπ XOR AL,ALπ LDS DX,Infoπ INT DOSπ POP DSπ JC @@2π MOV AX,BXπ MOV DOSResult,dosrOkπ JMP @@3π@@2:π MOV DOSResult,AX { save error code in global variable }π PUSH AX { store error code }π PUSH fnGetCountryInfo { store function code }π CALL ErrorHandlerπ CMP AL,frRetryπ JE @@1π POP AXπ NEG AXπ@@3:πEnd; { GetCountryInfo }ππProcedure GetDate; assembler;π{ GETDATE - DOS service functionπ Description: Retrieves the current date set in the operating system.π Ranges of the values returned are: Year 1980-2099,π Month 1-12, Day 1-31 and DayOfWeek 0-6 (0 corresponds toπ Sunday) }πAsmπ MOV AH,2AHπ INT DOSπ XOR AH,AHπ LES DI,DayOfWeekπ STOSBπ MOV AL,DLπ LES DI,Dayπ STOSBπ MOV AL,DHπ LES DI,Monthπ STOSBπ XCHG AX,CXπ LES DI,Yearπ STOSWπEnd; { GetDate }ππFunction SetDate; assembler;π{ SETDATE - DOS service functionπ Description: Sets the current date in the operating system. Validπ parameter ranges are: Year 1980-2099, Month 1-12 andπ Day 1-31π Returns: True if the date was set, False if the date is not valid }πAsmπ MOV CX,Yearπ MOV DH,Monthπ MOV DL,Dayπ MOV AH,2BHπ INT DOSπ CMP AL,0π JE @@1π MOV DOSResult,AXπ PUSH AXπ PUSH fnSetDateπ CALL ErrorHandlerπ MOV AL,Trueπ@@1:π NOT ALπEnd; { SetDate }ππProcedure GetTime; assembler;π{ GETTIME - DOS service functionπ Description: Returns the current time set in the operating system.π Ranges of the values returned are: Hour 0-23, Minute 0-59,π Second 0-59 and Sec100 (hundredths of seconds) 0-99 }πAsmπ MOV AH,2CHπ INT DOSπ XOR AH,AHπ MOV AL,DLπ LES DI,Sec100π STOSBπ MOV AL,DHπ LES DI,Secondπ STOSBπ MOV AL,CLπ LES DI,Minuteπ STOSBπ MOV AL,CHπ LES DI,Hourπ STOSBπEnd; { GetTime }ππFunction SetTime; assembler;π{ SETTIME - DOS service functionπ Description: Sets the time in the operating system. Validπ parameter ranges are: Hour 0-23, Minute 0-59, Second 0-59 andπ Sec100 (hundredths of seconds) 0-99π Returns: True if the time was set, False if the time is not valid }πAsmπ MOV CH,Hourπ MOV CL,Minuteπ MOV DH,Secondπ MOV DL,Sec100π MOV AH,2DHπ INT DOSπ CMP AL,0π JE @@1π MOV DOSResult,AXπ PUSH AXπ PUSH fnSetTimeπ CALL ErrorHandlerπ MOV AL,Trueπ@@1:π NOT ALπEnd; { SetTime }ππFunction GetCBreak; assembler;π{ GETCBREAK - DOS service functionπ Description: Retrieves Control-Break state; fn=3300hπ Returns: Current Ctrl-Break state }πAsmπ MOV AX,3300hπ INT DOSπ MOV AL,DLπEnd; { GetCBreak }ππFunction SetCBreak; assembler;π{ SETCBREAK - DOS service functionπ Description: Sets new Control-Break state; fn=3300hπ Returns: Old Ctrl-Break state }πAsmπ CALL GetCBreakπ PUSH AXπ MOV AX,3301hπ MOV DL,Breakπ INT DOSπ POP AXπEnd; { SetCBreak }ππFunction GetVerify; assembler;π{ GETVERIFY - DOS service functionπ Description: Returns the state of the verify flag in DOS.π When off (False), disk writes are not verified.π When on (True), all disk writes are verified to insure properπ writing; fn=54hπ Returns: State of the verify flag }πAsmπ MOV AH,54Hπ INT DOSπEnd; { GetVerify }ππFunction SetVerify; assembler;π{ SETVERIFY - DOS service functionπ Description: Sets the state of the verify flag in DOS; fn=2Ehπ Returns: Previous state of the verify flag }πAsmπ CALL GetVerifyπ PUSH AXπ MOV AL,Verifyπ MOV AH,2EHπ INT DOSπ POP AXπEnd; { SetVerify }ππ{$IFDEF Windows}ππProcedure ArgStrCount; assembler;πAsmπ LDS SI,CmdLineπ CLDπ@@1:π LODSBπ OR AL,ALπ JE @@2π CMP AL,' 'π JBE @@1π@@2:π DEC SIπ MOV BX,SIπ@@3:π LODSBπ CMP AL,' 'π JA @@3π DEC SIπ MOV AX,SIπ SUB AX,BXπ JE @@4π LOOP @@1π@@4:πEnd; { ArgStrCount /Windows }ππFunction GetArgCount; assembler;π{ GETARGCOUNT - DOS service functionπ Description: Returns the number of parameters passed to theπ program on the command lineπ Returns: Actual number of command line parameters }ππAsmπ PUSH DSπ XOR CX,CXπ CALL ArgStrCountπ XCHG AX,CXπ NEG AXπ POP DSπEnd; { GetArgCount /Windows }ππFunction GetArgStr; assembler;π{ GETARGSTR - DOS service functionπ Description: Returns the specified parameter from the command lineπ Returns: ASCIIZ parameter, or an empty string if Index is less than zeroπ or greater than GetArgCount. If Index is zero, GetArgStr returnsπ the filename of the current module. The maximum length of theπ string returned in Dest is given by the MaxLen parameter. Theπ returned value is Dest }ππAsmπ MOV CX,Indexπ JCXZ @@2π PUSH DSπ CALL ArgStrCountπ MOV SI,BXπ LES DI,Destπ MOV CX,MaxLenπ CMP CX,AXπ JB @@1π XCHG AX,CXπ@@1:π REP MOVSBπ XCHG AX,CXπ STOSBπ POP DSπ JMP @@3π@@2:π PUSH HInstanceπ PUSH WORD PTR [Dest+2]π PUSH WORD PTR [Dest]π MOV AX,MaxLenπ INC AXπ PUSH AXπ CALL GetModuleFileNameπ@@3:π MOV AX,WORD PTR [Dest]π MOV DX,WORD PTR [Dest+2]πEnd; { GetArgStr /Windows }ππ{$ELSE}ππProcedure ArgStrCount; assembler;πAsmπ MOV DS,PrefixSegπ MOV SI,80Hπ CLDπ LODSBπ MOV DL,ALπ XOR DH,DHπ ADD DX,SIπ@@1:π CMP SI,DXπ JE @@2π LODSBπ CMP AL,' 'π JBE @@1π DEC SIπ@@2:π MOV BX,SIπ@@3:π CMP SI,DXπ JE @@4π LODSBπ CMP AL,' 'π JA @@3π DEC SIπ@@4:π MOV AX,SIπ SUB AX,BXπ JE @@5π LOOP @@1π@@5:πEnd; { ArgStrCount }ππFunction GetArgCount; assembler;π{ GETARGCOUNT - DOS service functionπ Description: Returns the number of parameters passed to theπ program on the command lineπ Returns: Actual number of command line parameters }πAsmπ PUSH DSπ XOR CX,CXπ CALL ArgStrCountπ XCHG AX,CXπ NEG AXπ POP DSπEnd; { GetArgCount }ππFunction GetArgStr; assembler;π{ GETARGSTR - DOS service functionπ Description: Returns the specified parameter from the command lineπ Returns: ASCIIZ parameter, or an empty string if Index is less than zeroπ or greater than GetArgCount. If Index is zero, GetArgStr returnsπ the filename of the current module. The maximum length of theπ string returned in Dest is given by the MaxLen parameter. Theπ returned value is Dest }πAsmπ PUSH DSπ MOV CX,Indexπ JCXZ @@1π CALL ArgStrCountπ MOV SI,BXπ JMP @@4π@@1:π MOV AH,30Hπ INT DOSπ CMP AL,3π MOV AX,0π JB @@4π MOV DS,PrefixSegπ MOV ES,DS:WORD PTR 2CHπ XOR DI,DIπ CLDπ@@2:π CMP AL,ES:[DI]π JE @@3π MOV CX,-1π REPNE SCASBπ JMP @@2π@@3:π ADD DI,3π MOV SI,DIπ PUSH ESπ POP DSπ MOV CX,256π REPNE SCASBπ XCHG AX,CXπ NOT ALπ@@4:π LES DI,Destπ MOV CX,MaxLenπ CMP CX,AXπ JB @@5π XCHG AX,CXπ@@5:π REP MOVSBπ XCHG AX,CXπ STOSBπ MOV AX,WORD PTR [Dest]π MOV DX,WORD PTR [Dest+2]π POP DSπEnd; { GetArgStr }ππ{$ENDIF}ππFunction GetEnvVar;π{ GETENVVAR - DOS service functionπ Description: Retrieves a specified DOS environment variableπ Returns: A pointer to the value of a specified variable,π i.e. a pointer to the first character after the equalsπ sign (=) in the environment entry given by VarName.π VarName is case insensitive. GetEnvVar returns NIL ifπ the specified environment variable does not exist }πvarπ L : word;π P : PChar;πBeginπ L := StrLen(VarName);π{$IFDEF Windows}π P := GetDosEnvironment;π{$ELSE}π P := Ptr(Word(Ptr(PrefixSeg, $2C)^), 0);π{$ENDIF}π while P^ <> #0 doπ beginπ if (StrLIComp(P, VarName, L) = 0) and (P[L] = '=') thenπ beginπ GetEnvVar := P + L + 1;π Exit;π end;π Inc(P, StrLen(P) + 1)π end;π GetEnvVar := nilπEnd; { GetEnvVar }ππFunction GetIntVec; assembler;π{ GETINTVEC - DOS service functionπ Description: Retrieves the address stored in the specified interrupt vectorπ Returns: A pointer to this address }πAsmπ MOV AL,IntNoπ MOV AH,35Hπ INT DOSπ MOV AX,ESπ LES DI,Vectorπ CLDπ MOV DX,BXπ XCHG AX,BXπ STOSWπ XCHG AX,BXπ STOSWπ XCHG AX,DXπEnd; { GetIntVec }ππFunction SetIntVec; assembler;π{ SETINTVEC - DOS Service functionπ Description: Sets the address in the interrupt vector table for theπ specified interruptπ Returns: The old address of the specified interrupt vector }πAsmπ LES DI,Vectorπ PUSH WORD PTR IntNoπ PUSH ESπ PUSH DIπ PUSH CSπ CALL GetIntVecπ PUSH DXπ PUSH AXπ PUSH DSπ LDS DX,Vectorπ MOV AL,IntNoπ MOV AH,25Hπ INT DOSπ POP DSπ POP AXπ POP DXπEnd; { SetIntVec }ππFunction GetDTA; assembler;π{ GETDTA - DOS service functionπ Description: Retrieves a pointer address to a DOS data exchange buffer (DTA).π By default, DTA address has the offset PSP+80h and the size ofπ 128 bytes. DTA is used to access files with the FCB method;π fn=2Fhπ Returns: A pointer address to DTA }πAsmπ MOV AH,2Fhπ INT DOSπ MOV DX,BX { store offset }π MOV AX,ES { store segment }πEnd; { GetDTA }ππFunction GetCurDisk; assembler;π{ GETCURDISK - DOS disk service functionπ Description: Retrieves number of disk currently being active; fn=19hπ Returns: Default (current, active) disk number }πAsmπ MOV AH,19hπ INT DOSπEnd; { GetCurDisk }ππFunction SetCurDisk; assembler;π{ SETCURDISK - DOS disk service functionπ Description: Sets current (default/active) drive; fn=0Ehπ Returns: Number of disks in the system }πAsmπ MOV AH,0Ehπ MOV DL,Driveπ INT DOSπEnd; { SetCurDisk }ππProcedure GetDriveAllocInfo; assembler;π{ GETDRIVEALLOCINFO - DOS disk service functionπ Description: Retrieves disk allocation information; fn=1Chπ Retrieves Info structure }πAsmπ PUSH DSπ MOV AH,1Chπ MOV DL,Driveπ INT DOSπ MOV AH,BYTE PTR [DS:BX]π LES DI,Infoπ MOV BYTE PTR ES:[DI],AH { Info.FATId }π MOV WORD PTR ES:[DI+1],DX { Info.Clusters }π MOV BYTE PTR ES:[DI+3],AL { Info.SectorsPerCluster }π MOV WORD PTR ES:[DI+4],CX { Info.BytesPerSector }π POP DSπEnd; { GetDriveAllocInfo }ππFunction GetDPB; assembler;π{ GETDPB - DOS disk service function (undocumented)π Description: Returns a block of information that is useful for applicationsπ which perform sector-level access of disk drives supported byπ device drivers; fn=32hπ Returns: 0 if successful, negative dosrInvalidDrive error code otherwiseπ Remarks: Use 0 for default drive }πAsmπ MOV DOSResult,dosrOkπ PUSH DSπ MOV AH,32hπ MOV DL,Driveπ INT DOSπ MOV WORD PTR [DPB],DSπ MOV WORD PTR [DPB+2],BXπ POP DSπ XOR AH,AHπ CMP AL,0FFhπ JNE @@1π MOV DOSResult,dosrInvalidDriveπ PUSH DOSResultπ PUSH fnGetDPBπ CALL ErrorHandlerπ MOV AX,DOSResultπ NEG AXπ@@1:πEnd; { GetDPB }ππFunction DiskSize; assembler;π{ DISKSIZE - DOS disk service functionπ Description: Retrieves total disk size; fn=36hπ Returns: Total disk size in bytes if successful, negative dosrInvalidDriveπ error code otherwiseπ Remarks: Use 0 for default drive }πAsmπ@@1:π MOV AH,36hπ MOV DL,Driveπ INT DOSπ CMP AX,0FFFFhπ JE @@2π MOV BX,DXπ IMUL CXπ IMUL BXπ JMP @@3π@@2:π MOV DOSResult,dosrInvalidDriveπ PUSH DOSResultπ PUSH fnGetDiskSizeπ CALL ErrorHandlerπ CMP AL,frRetryπ JE @@1π MOV AX,DOSResultπ NEG AXπ XOR DX,DXπ@@3:πEnd; { DiskSize }ππFunction DiskFree; assembler;π{ DISKFREE - DOS disk service functionπ Description: Retrieves amount of free disk space; fn=36hπ Returns: Amount of free disk space in bytes if successful,π negative dosrInvalidDrive error code otherwiseπ Remarks: Use 0 for default drive }πAsmπ@@1:π MOV AH,36hπ MOV DL,Driveπ INT DOSπ CMP AX,0FFFFhπ JE @@2π IMUL CXπ IMUL BXπ JMP @@3π@@2:π MOV DOSResult,dosrInvalidDriveπ PUSH DOSResultπ PUSH fnGetDiskFreeπ CALL ErrorHandlerπ CMP AL,frRetryπ JE @@1π MOV AX,DOSResultπ NEG AXπ XOR DX,DXπ@@3:πEnd; { DiskFree }ππFunction IsFixedDisk; assembler;π{ ISFIXEDDISK - DOS disk service functionπ Description: Ensures whether the specified disk is fixed or removable;π fn=4408hπ Returns: True, if the disk is fixed, False - otherwiseπ Remarks: Use 0 for default (current) drive }πAsmπ MOV AX,4408hπ MOV BL,Driveπ INT DOSπ JNC @@1π MOV DOSResult,AX { save error code in global variable }π PUSH AX { store error code }π PUSH fnIsFixedDisk { store function code }π CALL ErrorHandlerπ@@1:πEnd; { IsFixedDisk }ππFunction IsNetworkDrive; assembler;π{ ISNETWORKDRIVE - DOS disk service functionπ Description: Ensures whether the specified disk drive is a network drive;π fn=4409hπ Returns: True if drive is a network drive, False if it's a local driveπ Remarks: Use 0 for detecting the default (current) drive }πAsmπ MOV AX,4409hπ MOV BL,Driveπ INT DOSπ JNC @@1π MOV DOSResult,AX { save error code in global variable }π PUSH AX { store error code }π PUSH fnIsNetworkDrive { store function code }π CALL ErrorHandlerπ@@1:πEnd; { IsNetworkDrive }ππFunction GetDriveType(Drive : byte) : byte; assembler;π{ GETDRIVETYPE - Disk service functionπ Description: Detects the type of the specified drive. Uses IsFixedDisk andπ IsNetworkDrive functions to produce a result valueπ Returns: One of (dt) constants (see const section)π Remarks: Use 0 for detecting the default (current) drive }πAsmπ PUSH WORD PTR Driveπ CALL IsNetworkDriveπ XOR BL,BLπ CMP DOSResult,dosrOkπ JNE @@3π CMP AL,Trueπ JNE @@1π MOV BL,dtRemoteπ JMP @@3π@@1:π PUSH WORD PTR Driveπ CALL IsFixedDiskπ XOR BL,BLπ CMP DOSResult,dosrOkπ JNE @@3π CMP AL,Trueπ JNE @@2π MOV BL,dtFixedπ JMP @@3π@@2:π MOV BL,dtRemovableπ@@3:π MOV AL,BLπEnd; { GetDriveType }ππFunction CreateDir; assembler;π{ CREATEDIR - DOS directory functionπ Description: Creates a directory; fn=39hπ Returns: 0 if successful, negative DOS error code otherwise }πAsmπ@@1:π PUSH DSπ LDS DX,Dirπ MOV AH,39hπ INT DOSπ POP DSπ JC @@2π XOR AX,AXπ MOV DOSResult,dosrOkπ JMP @@3π@@2:π MOV DOSResult,AX { save error code in global variable }π PUSH AX { store error code }π PUSH fnCreateDir { store function code }π CALL ErrorHandlerπ CMP AL,frRetryπ JE @@1π POP AXπ NEG AXπ@@3:πEnd; { CreateDir }ππFunction RemoveDir; assembler;π{ REMOVEDIR - DOS directory functionπ Description: Removes (deletes) a directory; fn=3Ahπ Returns: 0 if successful, negative DOS error code otherwise }πAsmπ@@1:π PUSH DSπ LDS DX,Dirπ MOV AH,3Ahπ INT DOSπ POP DSπ JC @@2π XOR AX,AXπ MOV DOSResult,dosrOkπ JMP @@3π@@2:π MOV DOSResult,AX { save error code in global variable }π PUSH AX { store error code }π PUSH fnRemoveDir { store function code }π CALL ErrorHandlerπ CMP AL,frRetryπ JE @@1π POP AXπ NEG AXπ@@3:πEnd; { RemoveDir }ππFunction GetCurDir; assembler;π{ GETCURDIR - DOS directory functionπ Description: Retrieves current (active) directory name; fn=47hπ Returns: 0 if successful, negative DOS error code otherwise }πAsmπ@@1:π PUSH DSπ LDS SI,Dirπ MOV DL,Driveπ MOV AH,47hπ INT DOSπ POP DSπ JC @@2π XOR AX,AXπ MOV DOSResult,dosrOkπ JMP @@3π@@2:π MOV DOSResult,AX { save error code in global variable }π PUSH AX { store error code }π PUSH fnGetCurDir { store function number }π CALL ErrorHandlerπ CMP AL,frRetryπ JE @@1π POP AXπ NEG AXπ@@3:πEnd; { GetCurDir }ππFunction SetCurDir; assembler;π{ SETCURDIR - DOS directory functionπ Description: Sets current (active) directory; fn=3Bhπ Returns: 0 if successful, negative DOS error code otherwise }πAsmπ@@1:π PUSH DSπ LDS DX,Dirπ MOV AH,3Bhπ INT DOSπ POP DSπ JC @@2π XOR AX,AXπ MOV DOSResult,AXπ JMP @@3π@@2:π MOV DOSResult,AX { save error code in global variable }π PUSH AX { store error code }π PUSH fnSetCurDir { store function code }π CALL ErrorHandlerπ CMP AL,frRetryπ JE @@1π POP AXπ NEG AXπ@@3:πEnd; { SetCurDir }ππFunction DeleteFile; assembler;π{ DELETEFILE - DOS file functionπ Description: Deletes a file; fn=41hπ Returns: 0 if successful, negative DOS error code otherwise }πAsmπ@@1:π PUSH DSπ LDS DX,Pathπ MOV AH,41hπ INT DOSπ POP DSπ JC @@2π XOR AX,AXπ MOV DOSResult,dosrOkπ JMP @@3π@@2:π MOV DOSResult,AX { save error code in global variable }π PUSH AX { store error code }π PUSH fnDeleteFile { store function code }π CALL ErrorHandlerπ CMP AL,frRetryπ JE @@1π POP AXπ NEG AXπ@@3:πEnd; { DeleteFile }ππFunction RenameFile; assembler;π{ RENAMEFILE - DOS file functionπ Description: Renames/moves a file; fn=56hπ Returns: 0 if successful, negative error code otherwise }πAsmπ@@1:π PUSH DSπ LDS DX,OldPathπ LES DI,NewPathπ MOV AH,56hπ INT DOSπ POP DSπ JC @@2π XOR AX,AXπ MOV DOSResult,dosrOkπ JMP @@3π@@2:π MOV DOSResult,AX { save error code in global variable }π PUSH AX { store error code }π PUSH fnRenameFile { store function code }π CALL ErrorHandlerπ CMP AL,frRetryπ JE @@1π POP AXπ NEG AXπ@@3:πEnd; { RenameFile }ππFunction ExistsFile; assembler;π{ EXISTSFILE - DOS file functionπ Description: Determines whether the file exists; fn=4Ehπ Returns: TRUE if the file exists, FALSE - otherwise }πAsmπ PUSH DSπ LDS DX,Pathπ MOV AH,4Ehπ INT DOSπ POP DSπ JNC @@1π XOR AL,ALπ JMP @@2π@@1:π MOV AL,Trueπ@@2:πEnd; { ExistsFile }ππFunction GetFileAttr; assembler;π{ GETFILEATTR - DOS file functionπ Description: Gets file attributes; fn=43h,AL=0π Returns: File attributes if no error, negative DOS error code otherwise }πAsmπ@@1:π PUSH DSπ LDS DX,Pathπ MOV AX,4300hπ INT DOSπ POP DSπ JC @@2π MOV AX,CXπ MOV DOSResult,dosrOkπ JMP @@3π@@2:π MOV DOSResult,AX { save error code in global variable }π PUSH AX { store error code }π PUSH fnGetFileAttr { store function code }π CALL ErrorHandlerπ CMP AL,frRetryπ JE @@1π POP AXπ NEG AXπ@@3:πEnd; { GetFileAttr }ππFunction SetFileAttr; assembler;π{ SETFILEATTR - DOS file functionπ Description: Sets file attributes; fn=43h,AL=1π Returns: 0 if no error, negative DOS error code otherwise }πAsmπ@@1:π PUSH DSπ LDS DX,Pathπ MOV CX,Attrπ MOV AX,4301hπ INT DOSπ POP DSπ JC @@2π XOR AX,AXπ MOV DOSResult,dosrOkπ JMP @@3π@@2:π MOV DOSResult,AX { save error code in global variable }π PUSH AX { store error code }π PUSH fnSetFileAttr { store function code }π CALL ErrorHandlerπ CMP AL,frRetryπ JE @@1π POP AXπ NEG AXπ@@3:πEnd; { GetFileAttr }ππFunction FindFirst; assembler;π{ FINDFIRST - DOS file service functionπ Description: Searches the specified (or current) directory forπ the first entry that matches the specified filename andπ attributes; fn=4E00hπ Returns: 0 if successful, negative DOS error code otherwise }πAsmπ@@1:π PUSH DSπ LDS DX,Fπ MOV AH,1AHπ INT DOSπ POP DSπ LES DI,Pathπ MOV CX,Attrπ MOV AH,4EHπ CALL AnsiDosFuncπ MOV DOSResult,dosrOkπ JC @@2π{$IFDEF Windows}π LES DI,Fπ ADD DI,OFFSET TSearchRec.Nameπ PUSH ESπ PUSH DIπ PUSH ESπ PUSH DIπ CALL OemToAnsiπ{$ENDIF}π XOR AX,AXπ JMP @@3π@@2:π MOV DOSResult,AX { save error code in global variable }π PUSH AX { store error code }π PUSH fnFindFirst { store function code }π CALL ErrorHandlerπ CMP AL,frRetryπ JE @@1π POP AXπ@@3:π NEG AXπEnd; { FindFirst }ππFunction FindNext; assembler;π{ FINDNEXT - DOS file service functionπ Description: Returs the next entry that matches the name andπ attributes specified in a previous call to FindFirst.π The search record must be one passed to FindFirstπ Returns: 0 if successful, negative DOS error code otherwise }πAsmπ@@1:π PUSH DSπ LDS DX,Fπ MOV AH,1AHπ INT DOSπ POP DSπ MOV AH,4FHπ MOV DOSResult,dosrOkπ INT DOSπ JC @@2π{$IFDEF Windows}π LES DI,Fπ ADD DI,OFFSET TSearchRec.Nameπ PUSH ESπ PUSH DIπ PUSH ESπ PUSH DIπ CALL OemToAnsiπ{$ENDIF}π XOR AX,AXπ JMP @@3π@@2:π MOV DOSResult,AX { save error code in global variable }π PUSH AX { store error code }π PUSH fnFindNext { store function code }π CALL ErrorHandlerπ CMP AL,frRetryπ JE @@1π POP AXπ@@3:π NEG AXπEnd; { FindNext }ππProcedure UnpackTime; assembler;π{ UNPACKTIME - Service functionπ Description: Converts a 4-byte packed date/time returned byπ FindFirst, FindNext or GetFTime into a TDateTime record }πAsmπ LES DI,Tπ CLDπ MOV AX,WORD PTR [P+2]π MOV CL,9π SHR AX,CLπ ADD AX,1980π STOSWπ MOV AX,WORD PTR [P+2]π MOV CL,5π SHR AX,CLπ AND AX,15π STOSWπ MOV AX,WORD PTR [P+2]π AND AX,31π STOSWπ MOV AX,P.Word[0]π MOV CL,11π SHR AX,CLπ STOSWπ MOV AX,WORD PTR [P+2]π MOV CL,5π SHR AX,CLπ AND AX,63π STOSWπ MOV AX,WORD PTR [P]π AND AX,31π SHL AX,1π STOSWπEnd; { UnpackTime }ππFunction PackTime; assembler;π{ PACKTIME - Service functionπ Decription: Converts a TDateTime record into a 4-byte packedπ date/time used by SetFTimeπ Returns: 4-byte long integer corresponding to packed date/time }πAsmπ PUSH DSπ LDS SI,Tπ CLDπ LODSWπ SUB AX,1980π MOV CL,9π SHL AX,CLπ XCHG AX,DXπ LODSWπ MOV CL,5π SHL AX,CLπ ADD DX,AXπ LODSWπ ADD DX,AXπ LODSWπ MOV CL,11π SHL AX,CLπ XCHG AX,BXπ LODSWπ MOV CL,5π SHL AX,CLπ ADD BX,AXπ LODSWπ SHR AX,1π ADD AX,BXπ POP DSπEnd; { PackTime }ππFunction h_CreateFile; assembler;π{ H_CREATEFILE - DOS Handle file functionπ Description: Creates a file; fn=3Chπ Returns: File handle if successful, 0 if unsuccessful }πAsmπ@@1:π PUSH DSπ LDS DX,Pathπ MOV CX,0π MOV AH,5Bhπ INT DOSπ POP DSπ JC @@2π MOV DOSResult,dosrOkπ JMP @@3π@@2:π MOV DOSResult,AX { save error code in global variable }π PUSH AX { store error code }π PUSH fnCreateFile { store function code }π CALL ErrorHandlerπ CMP AL,frRetryπ JE @@1π XOR AX,AXπ@@3:πEnd; { h_CreateFile }ππFunction h_CreateTempFile; assembler;π{ H_CREATETEMPFILE - DOS Handle file functionπ Description: Creates a temporary file; fn=5Ahπ Returns: File handle if successful, 0 if unsuccessful }πAsmπ@@1:π PUSH DSπ LDS DX,Pathπ MOV CX,0 { file attribute here, 0 used for normal }π MOV AH,5Ahπ INT DOSπ POP DSπ JC @@2π MOV DOSResult,dosrOkπ JMP @@3π@@2:π MOV DOSResult,AX { save error code in global variable }π PUSH AX { store error code }π PUSH fnCreateTempFile { store function code }π CALL ErrorHandlerπ CMP AL,frRetryπ JE @@1π XOR AX,AXπ@@3:πEnd; { h_CreateTempFile }ππFunction h_OpenFile; assembler;π{ H_OPENFILE - DOS Handle file functionπ Description: Opens a file for input, output or input/output; fn=3Dhπ Returns: File handle if successful, 0 if unsuccessful }πAsmπ@@1:π PUSH DSπ LDS DX,Pathπ MOV AH,3Dhπ MOV AL,Modeπ INT DOSπ POP DSπ JC @@2π MOV DOSResult,dosrOkπ JMP @@3π@@2:π MOV DOSResult,AX { save error code in global variable }π PUSH AX { store error code }π PUSH fnOpenFile { store function code }π CALL ErrorHandlerπ CMP AL,frRetryπ JE @@1π XOR AX,AXπ@@3:πEnd; { h_OpenFile }ππFunction h_Read; assembler;π{ H_READ - DOS Handle file functionπ Description: Reads a memory block from file; fn=3Fhπ Returns: Actual number of bytes read }πAsmπ@@1:π PUSH DSπ LDS DX,Bufferπ MOV CX,Countπ MOV BX,Handleπ MOV AH,3Fhπ INT DOSπ POP DSπ MOV DOSResult,dosrOkπ JNC @@2π MOV DOSResult,AX { save error code in global variable }π PUSH AX { store error code }π PUSH fnRead { store function code }π CALL ErrorHandlerπ CMP AL,frRetryπ JE @@1π@@2:πEnd; { h_Read }ππFunction h_Write; assembler;π{ H_WRITE - DOS Handle file functionπ Description: Writes a memory block to file; fn=40hπ Returns: Actual number of bytes written }πAsmπ@@1:π PUSH DSπ LDS DX,Bufferπ MOV CX,Countπ MOV BX,Handleπ MOV AH,40hπ INT DOSπ POP DSπ MOV DOSResult,dosrOkπ JNC @@2π MOV DOSResult,AX { save error code in global variable }π PUSH AX { store error code }π PUSH fnWrite { store function code }π CALL ErrorHandlerπ CMP AL,frRetryπ JE @@1π@@2:πEnd; { h_Write }ππFunction h_Seek; assembler;π{ H_SEEK - DOS Handle file functionπ Description: Seeks to a specified file position; fn=42hπ Start is one of the (sk) constants and points to a relativeπ seek offset positionπ Returns: Current file position if successful, 0 - otherwise }πAsmπ@@1:π MOV CX,WORD PTR [SeekPos+2]π MOV DX,WORD PTR [SeekPos]π MOV BX,Handleπ MOV AL,Startπ MOV AH,42hπ MOV DOSResult,dosrOkπ INT DOSπ JNC @@2π MOV DOSResult,AX { save error code in global variable }π PUSH AX { store error code }π PUSH fnSeek { store function number }π CALL ErrorHandlerπ CMP AL,frRetryπ JE @@1π@@2:πEnd; { h_Seek }ππFunction h_FilePos;π{ H_GETPOS - DOS Handle file functionπ Description: Calls h_Seek to determine file active positionπ Returns: Current file (seek) position number in long integer }πBeginπ h_FilePos := h_Seek(Handle, 0, skPos)πEnd; { h_FilePos }ππFunction h_FileSize;π{ H_FILESIZE - DOS Handle file functionπ Description: Determines file sizeπ Returns: File size in bytes }πvar SavePos, Size : longint;πBeginπ SavePos := h_FilePos(Handle);π h_FileSize := h_Seek(Handle, 0, skEnd);π h_Seek(Handle, SavePos, skStart)πEnd; { h_FileSize }ππFunction h_Eof; assembler;π{ H_EOF - DOS Handle file functionπ Description: Checks if the current file position is equal to file sizeπ and then returns Trueπ Returns: True if end of file detected, False - otherwise }πvar Size : longint;πAsmπ PUSH Handleπ CALL h_FileSize { Get file size in AX:DX }π MOV WORD PTR [Size],AX { Store high word }π MOV WORD PTR [Size+2],DX { Store low word }π PUSH Handleπ CALL h_FilePos { Get current file position }π XOR CL,CLπ CMP AX,WORD PTR [Size]π JNE @@1π CMP DX,WORD PTR [Size+2]π JNE @@1π MOV CL,Trueπ@@1:π MOV AL,CLπEnd; { h_GetPos }ππFunction h_GetFTime; assembler;π{ H_GETFTIME - DOS Handle file functionπ Description: Returns file update date and time values; fn=5700hπ Returns: Date and time values in long integerπ or negative DOS error code if an error occured }πAsmπ@@1:π MOV BX,Handleπ MOV AX,5700h { read date and time }π MOV DOSResult,dosrOkπ INT DOSπ JNC @@2π MOV DOSResult,AX { save error code in global variable }π PUSH AX { store error code }π PUSH fnGetFDateTime { store function number }π CALL ErrorHandlerπ CMP AL,frRetryπ JE @@1π POP AXπ NEG AXπ@@2:πEnd; { h_GetFTime }ππFunction h_SetFTime; assembler;π{ H_SETFTIME - DOS Handle file functionπ Description: Sets file date and time; fn=5701hπ Returns: New date and time values in long integerπ or negative DOS error code if an error occured }πAsmπ@@1:π MOV CX,WORD PTR [DateTime]π MOV DX,WORD PTR [DateTime+2]π MOV BX,Handleπ MOV AX,5701h { read date and time }π MOV DOSResult,dosrOkπ INT DOSπ JNC @@2π MOV DOSResult,AX { save error code in global variable }π PUSH AX { store error code }π PUSH fnSetFDateTime { store function number }π CALL ErrorHandlerπ CMP AL,frRetryπ JE @@1π POP AXπ NEG AXπ@@2:πEnd; { h_SetFTime }ππFunction h_CloseFile; assembler;π{ H_CLOSEFILE - DOS Handle file functionπ Description: Closes open file; fn=3Ehπ Returns: 0 if successful, negative DOS error code otherwise }πAsmπ@@1:π MOV BX,Handleπ MOV AH,3Ehπ INT DOSπ JC @@2π XOR AX,AXπ MOV DOSResult,dosrOkπ JMP @@3π@@2:π MOV DOSResult,AX { save error code in global variable }π PUSH AX { store error code }π PUSH fnCloseFile { store function number }π CALL ErrorHandlerπ CMP AL,frRetryπ JE @@1π POP AXπ NEG AXπ@@3:πEnd; { h_CloseFile }ππFunction MemAlloc; assembler;πAsmπ@@1:π MOV DOSResult,dosrOkπ MOV AX,WORD PTR [Size]π MOV DX,WORD PTR [Size+2]π MOV CX,16π DIV CXπ INC AXπ MOV BX,AXπ MOV AH,48hπ INT DOSπ JNC @@2π MOV DOSResult,AX { save error code in global variable }π PUSH AX { store error code }π PUSH fnMemAlloc { store function number }π CALL ErrorHandlerπ CMP AL,frRetryπ JE @@1π XOR AX,AXπ@@2:π MOV DX,AXπ XOR AX,AXπEnd; { MemAlloc }ππFunction MemFree; assembler;πAsmπ MOV DOSResult,dosrOkπ MOV ES,WORD PTR [P+2]π MOV AH,49hπ INT DOSπ JNC @@1π MOV DOSResult,AXπ PUSH AXπ PUSH fnMemFreeπ CALL ErrorHandlerπ@@1:π MOV AX,DOSResultπ NEG AXπEnd; { MemFree }ππFunction FileSearch; assembler;π{ FileSearch searches for the file given by Name in the list of }π{ directories given by List. The directory paths in List must }π{ be separated by semicolons. The search always starts with the }π{ current directory of the current drive. If the file is found, }π{ FileSearch stores a concatenation of the directory path and }π{ the file name in Dest. Otherwise FileSearch stores an empty }π{ string in Dest. The maximum length of the result is defined }π{ by the fsPathName constant. The returned value is Dest. }πAsmπ PUSH DSπ CLDπ LDS SI,Listπ LES DI,Destπ MOV CX,fsPathNameπ@@1:π PUSH DSπ PUSH SIπ JCXZ @@3π LDS SI,Nameπ@@2:π LODSBπ OR AL,ALπ JE @@3π STOSBπ LOOP @@2π@@3:π XOR AL,ALπ STOSBπ LES DI,Destπ MOV AX,4300Hπ CALL AnsiDosFuncπ POP SIπ POP DSπ JC @@4π TEST CX,18Hπ JE @@9π@@4:π LES DI,Destπ MOV CX,fsPathNameπ XOR AH,AHπ LODSBπ OR AL,ALπ JE @@8π@@5:π CMP AL,';'π JE @@7π JCXZ @@6π MOV AH,ALπ STOSBπ DEC CXπ@@6:π LODSBπ OR AL,ALπ JNE @@5π DEC SIπ@@7:π JCXZ @@1π CMP AH,':'π JE @@1π MOV AL,'\'π CMP AL,AHπ JE @@1π STOSBπ DEC CXπ JMP @@1π@@8:π STOSBπ@@9:π MOV AX,WORD PTR [Dest]π MOV DX,WORD PTR [Dest+2]π POP DSπEnd; { FileSearch }ππFunction FileExpand; assembler;π{ FileExpand fully expands the file name in Name, and stores }π{ the result in Dest. The maximum length of the result is }π{ defined by the fsPathName constant. The result is an all }π{ upper case string consisting of a drive letter, a colon, a }π{ root relative directory path, and a file name. Embedded '.' }π{ and '..' directory references are removed, and all name and }π{ extension components are truncated to 8 and 3 characters. The }π{ returned value is Dest. }ππAsmπ PUSH DSπ CLDπ LDS SI,Nameπ LEA DI,TempStrπ PUSH SSπ POP ESπ LODSWπ OR AL,ALπ JE @@1π CMP AH,':'π JNE @@1π CMP AL,'a'π JB @@2π CMP AL,'z'π JA @@2π SUB AL,20Hπ JMP @@2π@@1:π DEC SIπ DEC SIπ MOV AH,19Hπ INT DOSπ ADD AL,'A'π MOV AH,':'π@@2:π STOSWπ CMP [SI].Byte,'\'π JE @@3π SUB AL,'A'-1π MOV DL,ALπ MOV AL,'\'π STOSBπ PUSH DSπ PUSH SIπ MOV AH,47Hπ MOV SI,DIπ PUSH ESπ POP DSπ INT DOSπ POP SIπ POP DSπ JC @@3π XOR AL,ALπ CMP AL,ES:[DI]π JE @@3π{$IFDEF Windows}π PUSH ESπ PUSH ESπ PUSH DIπ PUSH ESπ PUSH DIπ CALL OemToAnsiπ POP ESπ{$ENDIF}π MOV CX,0FFFFHπ XOR AL,ALπ CLDπ REPNE SCASBπ DEC DIπ MOV AL,'\'π STOSBπ@@3:π MOV CX,8π@@4:π LODSBπ OR AL,ALπ JE @@7π CMP AL,'\'π JE @@7π CMP AL,'.'π JE @@6π JCXZ @@4π DEC CXπ{$IFNDEF Windows}π CMP AL,'a'π JB @@5π CMP AL,'z'π JA @@5π SUB AL,20Hπ{$ENDIF}π@@5:π STOSBπ JMP @@4π@@6:π MOV CL,3π JMP @@5π@@7:π CMP ES:[DI-2].Word,'.\'π JNE @@8π DEC DIπ DEC DIπ JMP @@10π@@8:π CMP ES:[DI-2].Word,'..'π JNE @@10π CMP ES:[DI-3].Byte,'\'π JNE @@10π SUB DI,3π CMP ES:[DI-1].Byte,':'π JE @@10π@@9:π DEC DIπ CMP ES:[DI].Byte,'\'π JNE @@9π@@10:π MOV CL,8π OR AL,ALπ JNE @@5π CMP ES:[DI-1].Byte,':'π JNE @@11π MOV AL,'\'π STOSBπ@@11:π LEA SI,TempStrπ PUSH SSπ POP DSπ MOV CX,DIπ SUB CX,SIπ CMP CX,79π JBE @@12π MOV CX,79π@@12:π LES DI,Destπ PUSH ESπ PUSH DIπ{$IFDEF Windows}π PUSH ESπ PUSH DIπ{$ENDIF}π REP MOVSBπ XOR AL,ALπ STOSBπ{$IFDEF Windows}π CALL AnsiUpperπ{$ENDIF}π POP AXπ POP DXπ POP DSπEnd; { FileExpand }ππ{$W+}πFunction FileSplit;π{ FileSplit splits the file name specified by Path into its }π{ three components. Dir is set to the drive and directory path }π{ with any leading and trailing backslashes, Name is set to the }π{ file name, and Ext is set to the extension with a preceding }π{ period. If a component string parameter is NIL, the }π{ corresponding part of the path is not stored. If the path }π{ does not contain a given component, the returned component }π{ string is empty. The maximum lengths of the strings returned }π{ in Dir, Name, and Ext are defined by the fsDirectory, }π{ fsFileName, and fsExtension constants. The returned value is }π{ a combination of the fcDirectory, fcFileName, and fcExtension }π{ bit masks, indicating which components were present in the }π{ path. If the name or extension contains any wildcard }π{ characters (* or ?), the fcWildcards flag is set in the }π{ returned value. }πvarπ DirLen, NameLen, Flags : word;π NamePtr, ExtPtr : PChar;πbeginπ NamePtr := StrRScan(Path, '\');π if NamePtr = nil then NamePtr := StrRScan(Path, ':');π if NamePtr = nil then NamePtr := Path else Inc(NamePtr);π ExtPtr := StrScan(NamePtr, '.');π if ExtPtr = nil then ExtPtr := StrEnd(NamePtr);π DirLen := NamePtr - Path;π if DirLen > fsDirectory then DirLen := fsDirectory;π NameLen := ExtPtr - NamePtr;π if NameLen > fsFilename then NameLen := fsFilename;π Flags := 0;π if (StrScan(NamePtr, '?') <> nil) or (StrScan(NamePtr, '*') <> nil) thenπ Flags := fcWildcards;π if DirLen <> 0 then Flags := Flags or fcDirectory;π if NameLen <> 0 then Flags := Flags or fcFilename;π if ExtPtr[0] <> #0 then Flags := Flags or fcExtension;π if Dir <> nil then StrLCopy(Dir, Path, DirLen);π if Name <> nil then StrLCopy(Name, NamePtr, NameLen);π if Ext <> nil then StrLCopy(Ext, ExtPtr, fsExtension);π FileSplit := Flags;πEnd; { FileSplit }π{$W-}ππFunction StdErrorProc(ErrCode : integer; FuncCode : word) : byte; far;πassembler;π{ Default error handler procedure called from EnhDOS functions }πAsmπ MOV AL,frOk { Return zero }πEnd; { StdErrorProc }πππconst WrongDOSVersion : PChar = 'DOS 3.1 or greater required.'#13#10'$';ππBeginπ asmπ MOV AH,30h { Get DOS version }π INT DOSπ CMP AL,3π JGE @@continue { if greater than or equal to 3 then continue else exit }π PUSH DSπ LDS DX,WrongDOSVersionπ MOV AH,09hπ INT DOSπ MOV AH,4Chπ INT DOSπ @@continue:π LES DI,Copyrightπ end;π DOSResult := dosrOk;π SetErrorHandler(StdErrorProc)πEnd. { EnhDOS+ }ππ{ ------------------------------------- DEMO ------------------ }π{ ***** ENHDDEMO.PAS ***** }ππProgram DemoEnhDOS;π{ Copyright (c) 1994 by Andrew Eigus Fido Net 2:5100/33 }π{ EnhDOS+ (Int21) demo program }ππ{$M 8192,0,0}π{ no heap size, couz using own memeory allocation }ππ(* Simple copy file program *)ππuses EnhDOS, Strings;ππconst BufSize = 65535; { may be larger; you may allocate more }ππvarπ Buffer : pointer;π InputFile, OutputFile : array[0..63] of Char;π Handle1, Handle2 : THandle;π BytesRead : word;ππFunction Int21ErrorHandler(ErrCode : integer; FuncCode : word) : byte; far;πvar fn : array[0..20] of Char;πBeginπ case FuncCode ofπ fnOpenFile: StrCopy(fn, 'h_OpenFile');π fnCreateFile: StrCopy(fn, 'h_CreateFile');π fnRead: StrCopy(fn, 'h_Read');π fnWrite: StrCopy(fn, 'h_Write');π fnSeek: StrCopy(fn, 'h_Seek');π fnCloseFile: StrCopy(fn, 'h_CloseFile');π fnMemAlloc: StrCopy(fn, 'MemAlloc');π fnDeleteFile: Exit;π else fn[0] := #0π end;π WriteLn('DOS Error ', ErrCode, ' in function ', FuncCode, ' (', fn, ')');π { actually for function return code see fr consts in the EnhDOS constπ section }πEnd; { Int21ErrorHandler }ππBeginπ SetErrorHandler(Int21ErrorHandler);ππ WriteLn('EnhDOS+ demo program: copies one file to another');π repeatπ if ParamCount > 0 thenπ StrPCopy(InputFile, ParamStr(1))π elseπ beginπ Write('Enter file name to read from: ');π ReadLn(InputFile)π end;π if ParamCount > 1 thenπ StrPCopy(OutputFile, ParamStr(2))π elseπ beginπ Write('Enter file name to write to: ');π ReadLn(OutputFile)π end;π WriteLnπ until (StrLen(InputFile) > 0) and (StrLen(OutputFile) > 0);ππ if not ExistsFile(InputFile) thenπ beginπ WriteLn('File not found: ', InputFile);π Halt(1)π end;ππ Buffer := MemAlloc(BufSize);ππ Write('Copying... ');ππ Handle1 := h_OpenFile(InputFile, omRead);π if Handle1 <> 0 thenπ beginπ DeleteFile(OutputFile);π Handle2 := h_CreateFile(OutputFile);π if Handle2 <> 0 thenπ beginπ BytesRead := 1;ππ while (BytesRead > 0) and (DOSResult = dosrOk) doπ beginπ BytesRead := h_Read(Handle1, Buffer^, BufSize);ππ if DOSResult <> dosrOk thenπ { read error then }π WriteLn('Error reading from input file');ππ if h_Write(Handle2, Buffer^, BytesRead) <> BytesRead thenπ { write error then }π beginπ WriteLn('Error writing to output file');π DOSResult := $FFπ endπ end;π if DOSResult = dosrOk then WriteLn('File copied OK');π h_CloseFile(Handle2)π end;π h_CloseFile(Handle1)π end;ππ MemFree(Buffer)πEnd. { DemoEnhDOS }ππ 60 08-24-9413:35ALL JON PHIPPS Environment detection SWAG9408 ¼─╝ 37 ┤φ π{πAnswering a msg of <Thursday May 19 1994>, from Elad Nachman to Per-EricπLarsson:π}ππprogram environ;ππuses dos,crt;ππConstπ Multiplex = $2f;π std_dos = $21;πππvarπ regs : registers;π {windows information variables}π winstall : boolean;π hi_winver : integer;π lo_winver : integer;π _386enh : boolean;π Ver_mach : word;π {OS information Variables}π _4dosinst : boolean;π Hi_4d_ver : integer;π Lo_4d_ver : integer;π shell_num : integer;π Hi_dosver : integer;π Lo_dosver : integer;π {DesqView Information variables}π dv_inst : boolean;π Hi_dv_ver : integer;π Lo_dv_ver : integer;πππ procedure v_id; {return windows 3.x 386enh mode virtual machine number}ππ beginπ regs.ax:=$1638;π intr(multiplex,regs);π ver_mach := regs.bx;π end;ππ procedure winstal;{check for windows 3.x install}ππ beginπ regs.ax:=$160A;π intr(multiplex,regs);π if regs.ax = $0000 thenπ beginπ winstall := true;π Hi_winver := regs.bh;π lo_winver := regs.bl;π if regs.cx = $0003 thenπ beginπ _386enh := true;π v_id;π endπ elseπ beginπ _386enh := false;π ver_mach := 0;π end;π endπ elseπ beginπ {π this point is only reached if windows isNOTπ detected we therefore set ALL windows id varsπ to impossible numbers.π }π winstall := false;π Hi_winver := 0;π lo_winver := 0;π ver_mach := 0;π end;π end;ππ procedure dvinstall;{check for dv}ππ beginπ if winstall thenπ beginπ dv_inst := false;π exit;π end;π regs.ax := $2b00;π regs.cx := $4445;π regs.dx := $5351;π regs.ax := $0001;π intr(std_dos,regs);π if regs.al<>$ff thenπ beginπ hi_dv_ver := regs.bh;π lo_dv_ver := regs.bl;π dv_inst := true;π endπ elseπ beginπ Hi_dv_ver := 0;π Lo_dv_ver := 0;π dv_inst := false;π end;π end; { dv install check}ππ procedure I_4dos;ππ beginπ regs.ax := $d44d;π regs.bx := $0000;π intr(std_dos,regs);π if regs.ax = $44dd thenπ beginπ hi_4d_ver := regs.bh;π lo_4d_ver := regs.bl;π _4dosinst := true;π shell_num := regs.dl;π endπ elseπ begin { no 4dos }π _4dosinst := false;π hi_4d_ver := 0;π lo_4d_ver := 0;π shell_num := -1;π end;π end;ππ procedure dos_ver; {get dos version}ππ beginπ regs.ax:=$3001;π intr(std_dos,regs);π hi_dosver:=regs.al;π lo_dosver:=regs.ah;π end;ππ procedure display_info;π beginπ clrscr;π gotoxy(4,5);π writeln('Os information');π gotoxy(4,12);π writeln('Windows 3.x information');π gotoxy(4,17);π writeln('Dv information');π if _4dosinst thenπ beginπ gotoxy(6,7);π writeln('4dos version: ',hi_4d_ver,':',lo_4d_ver);π gotoxy(6,8);π writeln('4dos subshell#: ',shell_num);π gotoxy(6,9);π writeln('MSdos version: ',hi_dosver,':',lo_dosver);π endπ elseπ beginπ gotoxy(6,7);π writeln('MSdos version: ',hi_dosver,':',lo_dosver);π gotoxy(6,8);π writeln('4dos.com not detected in this window.');π end;π if winstall thenπ beginπ gotoxy(6,13);π writeln('Windows Version: ',Hi_winver,':',lo_winver);π gotoxy(6,14);π if _386enh thenπ beginπ writeln('Running in 386 enhanced mode');π gotoxy(6,15);π writeln('386Enh virtual machine ID: ',ver_mach);π endπ elseπ beginπ writeln('Running in Standard mode');π gotoxy(6,15);π writeln('386Enh Virtual Machine ID: Not applicable in standard mode');π end;π endπ elseπ beginπ gotoxy(6,13);π writeln('Microsoft windows not installed');π end;π if dv_inst thenπ beginπ gotoxy(6,18);π writeln('Desqview Version: ',hi_dv_ver,':',lo_dv_ver);π endπ elseπ beginπ gotoxy(6,18);π writeln('DesqView not installed');π end;π end;ππ beginπ winstal;π I_4dos;π dos_ver;π dvinstall;π display_info;π repeatπ until readkey = #27;π end.ππ 61 08-24-9413:35ALL JEFF WILSON Error to file SWAG9408 r ╧Ω 45 ┤φ {πHere is a unit that I've played with a bit.. I have no idea who the originalπauthor is. What it does is expand the Runtime Errors reported by TP andπoptionally logs it to a file that you supply the name to.. It works fine forπme on MSDOS 3.3 and 5.0. If you make any improvements to it I wouldπappreciate a copy of it..π}ππ{$S-}πUNIT Errors ;ππINTERFACEππUSESπ Dos ;ππVARπ ErrorFile : PathStr ; { optional name you include in the }π { main program code }πPROCEDURE CheckRTError ;ππIMPLEMENTATIONππVARπ ErrorExitProc : Pointer ;ππFUNCTION HexStr(w: Word): String ;π CONSTπ HexChars : Array [0..$F] of Char = '0123456789ABCDEF' ;π BEGINπ HexStr := HexChars[Hi(w) shr 4]π + HexChars[Hi(w) and $F]π + HexChars[Lo(w) shr 4]π + HexChars[Lo(w) and $F] ;π END ;ππFUNCTION ExtendedError: String ; { goto DOS to get the last reported error }π VARπ Regs : Registers ;π BEGINπ FillChar(Regs,Sizeof(Regs),#0) ;π Regs.AH := $59 ;π MSDos(Regs) ;π CASE Regs.AX OFπ $20 : ExtendedError := 'Share Violation' ;π $21 : ExtendedError := 'Lock Violation' ;π $23 : ExtendedError := 'FCB Unavailable' ;π $24 : ExtendedError := 'Sharing Buffer Overflow' ;π ELSE ExtendedError := 'Extended Error ' + HexStr(Regs.AX) ;π END ; { case }π END ;ππFUNCTION ErrorMsg(Err : Integer): String ;πBEGINπ CASE Err OFπ 1 : ErrorMsg := 'Invalid Function Number';π 2 : ErrorMsg := 'File Not Found';π 3 : ErrorMsg := 'Path Not Found';π 4 : ErrorMsg := 'Too Many Open Files';π 5 : ErrorMsg := 'File Access Denied';π 6 : ErrorMsg := 'Invalid File Handle';ππ 12 : ErrorMsg := 'Invalid File Access Code';ππ 15 : ErrorMsg := 'Invalid Drive Number';π 16 : ErrorMsg := 'Cannot Remove Current Directory';π 17 : ErrorMsg := 'Cannot Rename Across Drives';π 18 : ErrorMsg := 'No More Files';ππ 100 : ErrorMsg := 'Disk Read Past End Of File';π 101 : ErrorMsg := 'Disk Full';π 102 : ErrorMsg := 'File Not Assigned';π 103 : ErrorMsg := 'File Not Open';π 104 : ErrorMsg := 'File Not Open For Input';π 105 : ErrorMsg := 'File Not Open For Output';π 106 : ErrorMsg := 'Invalid Numeric Format';ππ 150 : ErrorMsg := 'Disk is write protected';π 151 : ErrorMsg := 'Unknown Unit';π 152 : ErrorMsg := 'Drive Not Ready';π 153 : ErrorMsg := 'Unknown command';π 154 : ErrorMsg := 'CRC Error in data';π 155 : ErrorMsg := 'Bad drive request structure length';π 156 : ErrorMsg := 'Disk seek error';π 157 : ErrorMsg := 'Unknown media type';π 158 : ErrorMsg := 'Sector not found';π 159 : ErrorMsg := 'Printer out of paper';π 160 : ErrorMsg := 'Device write fault';π 161 : ErrorMsg := 'Device read fault';π 162 : ErrorMsg := 'Hardware failure';ππ 163 : ErrorMsg := ExtendedError ;ππ 200 : ErrorMsg := 'Division by zero';π 201 : ErrorMsg := 'Range check error';π 202 : ErrorMsg := 'Stack overflow error';π 203 : ErrorMsg := 'Heap overflow error';π 204 : ErrorMsg := 'Invalid pointer operation';π 205 : ErrorMsg := 'Floating point overflow';π 206 : ErrorMsg := 'Floating point underflow';π 207 : ErrorMsg := 'Invalid floating point operation';π 208 : ErrorMsg := 'Overlay manager not installed';π 209 : ErrorMsg := 'Overlay file read error';π 210 : ErrorMsg := 'Object not initialized';π 211 : ErrorMsg := 'Call to abstract method';π 212 : ErrorMsg := 'Stream registration error';π 213 : ErrorMsg := 'Collection index out of range';π 214 : ErrorMsg := 'Collection overflow error';π 215 : ErrorMsg := 'Arithmetic overflow error';π 216 : ErrorMsg := 'General protection fault';π END ;πEND ;ππFUNCTION LZ(W : Word): String ;π VARπ s : String ;π BEGINπ Str(w:0,s) ;π IF Length(s) = 1 THEN s := '0' + s ;π LZ := s ;π END ;ππFUNCTION TodayDate : String ;π VARπ Year,π Month,π Day,π Dummy,π Hour,π Minute,π Second : Word ;π BEGINπ GetDate(Year, Month, Day, Dummy) ;π GetTime(Hour, Minute, Second, Dummy) ;π TodayDate := LZ(Month) + '/' + LZ(Day) + '/' + LZ(Year-1900)π + ' ' + LZ(Hour) + ':' + LZ(Minute) ;π END ;ππ{$F+}πPROCEDURE CheckRTError ;π VARπ F : Text ;π BEGINπ IF ErrorAddr <> Nil THENπ BEGINπ IF ErrorFile <> '' THENπ BEGINπ Assign(F,ErrorFile) ;π {$I-} Append(F) ; {$I+}π IF IOResult <> 0 THEN Rewrite(F) ;π Writeln(F,'Date: ' + TodayDate) ;π Write(F,'RunTime Error #',ExitCode,' at ') ;π Write(F,HexStr(Seg(ErrorAddr^)) + ':') ;π WriteLn(F,HexStr(Ofs(ErrorAddr^))) ;π Writeln(F,ErrorMsg(ExitCode)) ;π Writeln(F,'') ;π Close(F) ;π END ;π Writeln('Date: ' + TodayDate) ;π Write('RunTime Error #',ExitCode,' at ') ;π Write(HexStr(Seg(ErrorAddr^)) + ':') ;π WriteLn(HexStr(Ofs(ErrorAddr^))) ;π Writeln(ErrorMsg(ExitCode)) ;π Writeln ;π ErrorAddr := Nil ; { reset variable so TP doesn't report }π ExitProc := ErrorExitProc ; { the error and reset the Exit Pointer }π END ;π END ;π{$F-}ππBEGINπ ErrorFile := '' ; { don't log the error to a file }π ErrorExitProc := ExitProc ;π ExitProc := @CheckRTError ;πEND.ππ{============== DEMO ==============}ππPROGRAM Test ;ππUSESπ Errors ;ππVARπ TestFile : Text ;ππBEGINπ ErrorFile := 'TESTERR.TXT' ; { log errors to this file }π RunError(3) ; { test whatever you want }πEND.ππ 62 08-24-9413:35ALL MARIUS ELLEN Additions to ENHDOS SWAG9408 $ 4j 48 ┤φ πfunction PathTest(Pth:pchar):word;πassembler;πasmπ CLD; LES DI,Pthπ XOR AX,AXπ MOV CX,0FFFFHπ REPNE SCASB; NOT CX; JCXZ @NoAst; DEC DI; MOV DX,DI; STDπ MOV BX,CX; MOV SI,DI; MOV AL,'.'; REPNE SCASB; JNE @Uπ OR AH,fcExtensionπ INC DI; MOV DX,DIπ@U: MOV CX,BX; MOV DI,SI; MOV AL,'\'; REPNE SCASB; JE @Fπ MOV CX,BX; MOV DI,SI; MOV AL,':'; REPNE SCASB; JNE @Gπ@F: INC DIπ@G: INC DIπ CMP DX,DI; JE @NoNamπ OR AH,fcFileNameπ@NoNam: MOV CX,BX; MOV DI,SI; MOV AL,'\'; REPNE SCASB; JNE @NoPthπ OR AH,fcDirectoryπ@NoPth: MOV CX,BX; MOV DI,SI; MOV AL,':'; REPNE SCASB; JNE @NoDrvπ OR AH,fcDriveπ@NoDrv: MOV CX,BX; MOV DI,SI; MOV AL,'?'; REPNE SCASB; JNE @NoQstπ OR AH,fcWildcardsπ@NoQst: MOV CX,BX; MOV DI,SI; MOV AL,'*'; REPNE SCASB; JNE @NoAstπ OR AH,fcWildcardsπ@NoAst: MOV AL,AHπ XOR AH,AHπend;ππfunction PathBuild(Dst,Pth,Nam,Ext:PChar):PChar;πassembler;πasmπ CLDπ PUSH DSπ XOR AL,ALπ XOR CX,CX; LES DI,Extπ MOV DX,ES; AND DX,DX; JE @NoExtπ DEC CX; REPNE SCASB;π NOT CX; DEC CXπ@NoExt: PUSH CXπ XOR CX,CX; LES DI,Namπ MOV DX,ES; AND DX,DX; JE @NoNamπ DEC CX; REPNE SCASBπ NOT CX; DEC CXπ@NoNam: PUSH CXπ XOR CX,CX; LES DI,Pthπ MOV DX,ES; AND DX,DX; JE @NoPthπ DEC CX; REPNE SCASBπ NOT CX; DEC CXπ@NoPth:π LES DI,Dstπ MOV BX,DIπ LDS SI,Pthπ REP MOVSBπ LDS SI,Namπ POP CXπ REP MOVSBπ LDS SI,Extπ POP CXπ REP MOVSBπ STOSBπ MOV DX,ESπ MOV AX,BXπ POP DSπend;ππprocedure PathSplit(Pth,Dir,Nam,Ext:pchar);πassembler;πasmπ PUSH DSπ LES DI,Pth; CLDπ MOV CX,0FFFFHπ XOR AL,AL; REPNE SCASB; NOT CX; DEC DI; MOV BX,DI; STDπ MOV SI,CX; MOV DX,DI; MOV AL,'.'; REPNE SCASB; JNE @Uπ INC DI; MOV BX,DIπ@U: MOV CX,SI; MOV DI,DX; MOV AL,'\'; REPNE SCASB; JE @Fπ MOV CX,SI; MOV DI,DX; MOV AL,':'; REPNE SCASB; JNE @Gπ@F: INC DIπ@G: INC DIπ LDS SI,Pth; CLDπ MOV CX,fsDirectoryπ SUB DI,SI; CMP DI,CX; JA @3; XCHG DI,CXπ@3: LES DI,Dir; MOV AX,ES; AND AX,AX; JE @NoDirπ REP MOVSB; XOR AL,AL; STOSBπ@NoDir: ADD SI,CXπ MOV CX,fsFilenameπ MOV AX,BX; SUB AX,SI; CMP AX,CX; JA @4; XCHG AX,CXπ@4: LES DI,Nam; MOV AX,ES; AND AX,AX; JE @NoNamπ REP MOVSB; XOR AL,AL; STOSBπ@NoNam: ADD SI,CXπ MOV CX,fsExtensionπ MOV AX,DX; SUB AX,SI; CMP AX,CX; JA @5; XCHG AX,CXπ@5: LES DI,Ext; MOV AX,ES; AND AX,AX; JE @NoExtπ REP MOVSB; XOR AL,AL; STOSBπ@NoExt: POP DSπend;ππprocedure PathSplitName(Pth,Dir,NamExt:pchar);πassembler;πasmπ PUSH DSπ LES DI,Pth; CLDπ MOV CX,0FFFFHπ XOR AL,AL; REPNE SCASB; NOT CX; DEC DI; STDπ MOV SI,CX; MOV BX,DI; MOV AL,'\'; REPNE SCASB; JE @Fπ MOV CX,SI; MOV DI,BX; MOV AL,':'; REPNE SCASB; JNE @Gπ@F: INC DIπ@G: INC DIπ LDS SI,Pth; CLDπ MOV CX,fsDirectoryπ SUB DI,SI; CMP DI,CX; JA @3; XCHG DI,CXπ@3: LES DI,Dir; MOV AX,ES; AND AX,AX; JE @NoDirπ REP MOVSB; XOR AL,AL; STOSBπ@NoDir: ADD SI,CXπ MOV CX,fsFilename+fsExtensionπ MOV AX,BX; SUB AX,SI; CMP AX,CX; JA @4; XCHG AX,CXπ@4: LES DI,NamExt; MOV AX,ES; AND AX,AX; JE @NoNamπ REP MOVSB; XOR AL,AL; STOSBπ@NoNam: POP DSπend;ππ{πIs't a pitty you did not include some cacheable reads/writes in your unitπENHDOS. Also some functions could be included using USES windos. (Or my ownπbputils ;-) Here's some cacheable stuff (also protected mode).π}ππfunction fLargeRead(Handle:word;MemPtr:pointer;Size:longint):longint;π{read Size bytes from a file to Seg:0, return bytes read}πassembler;πvar Sg:word absolute Handle;πasmπ PUSH DSπ MOV CX,$8000π MOV BX,Handleπ MOV AX,SelectorIncπ MOV DI,Size.word[2]π MOV SI,Size.word[0]π MOV Sg,AXπ LDS DX,MemPtrπ AND DX,DX; JE @Stπ MOV AX,267π@Er: {Halt(error)}π POP DSπ PUSH AXπ CALL bpHaltNrπ@Re: AND DI,DI; JNE @Doπ CMP SI,CX; JA @Do; MOV CX,SIπ@Do: MOV AH,$3F; INT 21H; JC @Erπ SUB SI,AX; SBB DI,0π SUB AX,CX; JNE @Eoπ ADD DX,CX; JNC @Stπ MOV AX,DS; ADD AX,Sg; MOV DS,AXπ@St: MOV AX,DI; XOR AX,SI; JNE @Reπ@Eo: POP DSπ MOV AX,Size.word[0]; SUB AX,SIπ MOV DX,Size.word[2]; SBB DX,DIπ@eX:πend;πππfunction fLargeWrite(Handle:word;MemPtr:pointer;Size:longint):longint;π{write Size bytes to a file from Seg:0, return bytes written}πassembler;πvar Sg:word absolute Handle;πasmπ PUSH DSπ MOV CX,$8000π MOV BX,Handleπ MOV AX,SelectorIncπ MOV DI,Size.word[2]π MOV SI,Size.word[0]π MOV Sg,AXπ LDS DX,MemPtrπ AND DX,DX; JE @Stπ MOV AX,267π JMP @Erπ@Wr: MOV AX,101π@Er: {Halt(error)}π POP DSπ PUSH AXπ CALL bpHaltNrπ@Re: AND DI,DI; JNE @Doπ CMP SI,CX; JA @Do; MOV CX,SIπ@Do: MOV AH,$40; INT 21H; JC @Erπ SUB SI,AX; SBB DI,0π SUB AX,CX; JNE @Wrπ ADD DX,CX; JNC @Stπ MOV AX,DS; ADD AX,Sg; MOV DS,AXπ@St: MOV AX,DI; XOR AX,SI; JNE @Reπ@Eo: POP DSπ MOV AX,Size.word[0]; SUB AX,SIπ MOV DX,Size.word[2]; SBB DX,DIπ@eX:πend;π 63 08-24-9413:36ALL ANDREW EIGUS FASTEST File Exist (BASM)SWAG9408 ;V▄L 6 ┤φ πFunction FileExists(FileName : string) : boolean; assembler;π{ Determines whether the given file exists. Returns true if the file was found,π false - if there is no such file }πAsmπ PUSH DSπ LDS DX,FileNameπ INC DXπ MOV AX,4300h { get information through the GetAttr function }π INT 21hπ MOV AL,False { emulate AL=0 }π JC @@1π INC AL { emulate AL=AL+1=1 }π@@1:π POP DSπEnd; { FileExists }ππconst Found : array[Boolean] of string[10] = ('not found', 'found');πvar FileName : string;ππBeginπ Write('Enter file name to search: ');π ReadLn(FileName);π WriteLn('File "', FileName, '" ', Found[FileExists(FileName)], '.');πEnd.π 64 08-24-9413:36ALL STEVE ROGERS Extended SearchRec SWAG9408 ╠9╡Ç 12 ┤φ {π OK, here's a problem. FExpand takes Newest.Name and appends it to theπ full CURRENT path, not the path you specified on the command line. Youπ have to keep track of that path yourself. Or, here's a unit that mightπ help. It's an Expanded Searchrec that returns a full filespec.π}ππunit EXSRec;π{ Written by Steve Rogers - 1994. Released to public domain }ππinterfaceπusesπ dos;ππtypeπ EXSearchRec = record { EXtended searchrec }π name : pathstr; { fully specified filename }π dsub : searchrec; { dos.searchrec }π end;ππprocedure ffirst(path : pathstr;attr : word;var dd : EXSearchRec);πprocedure fnext(var dd : EXSearchRec);ππimplementationππprocedure ffirst(path : pathstr;attr : word;var dd : EXSearchRec);πbeginπ findfirst(path,attr,dd.dsub);π if (doserror=0) then with dd do beginπ name:= path;π while not (name[length(name)] in ['\',':',#0])π do dec(name[0]);π name:= name+dsub.name;π end else dd.name:= '';πend;ππ{----------------------}πprocedure fnext(var dd : EXSearchRec);ππbeginπ findnext(dd.dsub);π if (doserror=0) then with dd do beginπ while not (dd.name[length(dd.name)] in ['\',':',#0])π do dec(name[0]);π name:= name+dsub.name;π end else dd.name:= '';πend;ππ{----------------------}πend.π 65 08-24-9413:37ALL ANDREW EIGUS File Attribute (BASM) SWAG9408 2O~} 13 ┤φ {π EH> I am looking for a way to determine a filehandles' attributes, like isπ EH> possible in OS/2.ππ EH> The attributes I like to query (and maybe set), are the standard-fileπ EH> attribs. Still I cannot find a way to get to them except with theπ EH> filename, and a dos interrupt. What I am looking for is a dos interruptπ EH> that does exactly the same, but uses a filehandle instead of a filename.ππNo no no, file attributes can be returned/set only via DOS function 43h thatπassumes DS:DX point to a ASCIIZ file name. :(ππ { File attributes (combine these when setting) }ππ faNormal = $0000;π faReadOnly = $0001;π faHidden = $0002;π faSysFile = $0004;π faVolumeID = $0008;π faDirectory = $0010;π faArchive = $0020;π faAnyFile = $003F;ππFunction GetFileAttr(FileName : PChar) : integer; assembler;π{ Retrieves the attribute of a given file. The result is returned by DosError }πAsmπ MOV DosError,0π PUSH DSπ LDS DX,FileNameπ MOV AX,4300hπ INT 21hπ POP DSπ JNC @@noerrorπ MOV DosError,AX { save error code in DOS global variable }π@@noerror:π MOV AX,CXπEnd; { GetFileAttr }ππProcedure SetFileAttr(FileName : PChar; Attr : word); assembler;π{ Sets the new attribute to a given file. The result is returned by DosError }πAsmπ MOV DosError,0π PUSH DSπ LDS DX,FileNameπ MOV CX,Attrπ MOV AX,4301hπ INT 21hπ POP DSπ JC @@noerrorπ MOV DosError,AXπ@@noerror:πEnd; { SetFileAttr }π 66 08-24-9413:37ALL MARIUS ELLEN File There ?? SWAG9408 ⌐ué╙ 9 ┤φ π{ Try the DOS GetAttr function (Also faster than findfirst) }ππ { test to see if file exists }π function fIsFileP(SrcPath:pchar):boolean;π inline({get fattr, dos 2.0+}π $5A/ { pop dx }π $58/ { pop ax }π $1E/ { push ds }π $8E/$D8/ { mov ds,ax }π $B8/$00/$43/ { MOV AX,4300h }π $CD/$21/ { int 21h }π $1F/ { pop ds }π $72/$08/ { JC +8 }π $B8/$01/$00/ { MOV AX,1 }π $F6/$C1/$10/ { TEST CL,faDirectory }π $74/$02/ { JE +2 }π $31/$C0); { xor ax,ax }ππBEGINπ WriteLn(FisFIleP('\turbo\bp.exe'));πEND. 67 08-24-9413:48ALL HEGEL UDO Simple Multitasker SWAG9408 ╟«QF 62 ┤φ Unit Multi;π{--------------------------------------------------------------------------------}π{ }π{ Hilfsfunktionen zur quasi-Multitaskingverarbeitung unter Turbo Pascal }π{ }π{ (c) 1994 by Hegel Udo }π{ }π{--------------------------------------------------------------------------------}πInterfaceπ{--------------------------------------------------------------------------------}πTypeπ StartProc = Procedure;π{--------------------------------------------------------------------------------}πProcedure AddTask (Start : StartProc;StackSize : Word);πProcedure Transfer;π{--------------------------------------------------------------------------------}πImplementationπ{--------------------------------------------------------------------------------}πUsesπ Dos;π{--------------------------------------------------------------------------------}πTypeπ TaskPtr = ^TaskRec;π TaskRec = Recordπ StackSize : Word;π Stack : Pointer;π SPSave : Word;π SSSave : Word;π BPSave : Word;π Next : TaskPtr;π end;π{--------------------------------------------------------------------------------}πConstπ MinStack = 1024;π MaxStack = 32768;π{--------------------------------------------------------------------------------}πVarπ Tasks : TaskPtr;π AktTask : TaskPtr;π OldExit : Pointer;π{--------------------------------------------------------------------------------}πProcedure AddTask (Start : StartProc;StackSize : Word);πTypeπ OS = Recordπ O,S : Word;π end;πVarπ W : ^TaskPtr;π SS : Word;π SP : Word;πbeginπ W := @Tasks;π While Assigned (W^) do W := @W^^.Next;π New (W^);π if StackSize < MinStack then StackSize := MinStack;π if StackSize > MaxStack then StackSize := MaxStack;π W^^.StackSize := StackSize;π GetMem (W^^.Stack,StackSize);π SS := OS(W^^.Stack).S;π SP := OS(W^^.Stack).O+StackSize-4;π Move (Start,Ptr(SS,SP)^,4);π W^^.SPSave := SP;π W^^.SSSave := SS;π W^^.BPSave := W^^.SPSave;π W^^.Next := NIL;πend;π{--------------------------------------------------------------------------------}πProcedure Transfer; Assembler;πAsmπ LES SI,AktTask { Alter Status sichern }π MOV ES:[SI].TaskRec.SPSave,SPπ MOV ES:[SI].TaskRec.SSSave,SSπ MOV ES:[SI].TaskRec.BPSave,BPπ MOV AX,Word Ptr ES:[SI].TaskRec.Next { Neue Task bestimmen }π OR AX,Word Ptr ES:[SI].TaskRec.Next+2π JE @InitNewπ LES SI,ES:[SI].TaskRec.Nextπ JMP @DoJobπ@InitNew:π LES SI,Tasksπ@DoJob:π MOV Word Ptr AktTask,SI { Neue Task Sichern }π MOV Word Ptr AktTask+2,ESπ CLI { Status wieder hertstellen }π MOV SP,ES:[SI].TaskRec.SPSaveπ MOV SS,ES:[SI].TaskRec.SSSaveπ STIπ MOV BP,ES:[SI].TaskRec.BPSaveπend;π{--------------------------------------------------------------------------------}πBEGINπ New (Tasks); { Hauptprogramm als Task anmelden }π Tasks^.StackSize := 0;π Tasks^.Stack := NIL;π Tasks^.Next := NIL;π AktTask := Tasks;πEND.ππ{ -------------------------- DEMO PROGRAM ---------------------- }ππProgram Multi_Demo;ππUsesπ DOS, Crt, Multi;ππTYPEππ ScreenState = (free, used); { Is screen position free? }π WindowType = Record { Window descriptor }π X,π Y,π Xsize,π Ysize : Integer;π End;πππvar screen : Array(.0..81,0..26.) of ScreenState;π WindowTable : Array(.1..20.) of WindowType;π i,j, { Index variables }π NoWindows : Integer; { No. of windows on screen }ππProcedure MakeWindow(X, Y, Xsize, Ysize: Integer; Heading: String);ππ{ Reserves screenspace for window and draws border around it }ππ const NEcorner = #187; { Characters for double-line border }π SEcorner = #188;π SWcorner = #200;π NWcorner = #201;π Hor = #205;π Vert = #186;ππ var i,j : Integer;ππ Beginπ Window(1,1,80,25);ππ { Reserve screen space }π For i:=X to X+Xsize-1 Doπ For j:=Y to Y+Ysize-1 Do screen(.i,j.):=used;ππ { Draw border - sides }π i:=X;π For j:=Y+1 to Y+Ysize-2 Doπ Beginπ GotoXY(i,j);π Write(Vert);π End;ππ i:=X+Xsize-1;π For j:=Y+1 to Y+Ysize-2 Doπ Beginπ GotoXY(i,j);π Write(Vert);π End;ππ j:=Y;π For i:=X+1 to X+Xsize-2 Doπ Beginπ GotoXY(i,j);π Write(Hor);π End;ππ j:=Y+Ysize-1;π For i:=X+1 to X+Xsize-2 Doπ Beginπ GotoXY(i,j);π Write(Hor);π End;ππ { Draw border - corners }π GotoXY(X,Y);π Write(NWcorner);π GotoXY(X+Xsize-1,Y);π Write(NEcorner);π GotoXY(X+Xsize-1,Y+Ysize-1);π Write(SEcorner);π GotoXY(X,Y+Ysize-1);π Write(SWcorner);ππ { Make Heading }π GotoXY(X+(Xsize-Length(Heading)) div 2,Y);π Write(heading);ππ { Save in table }π NoWindows:=NoWindows+1;π WindowTable(.NoWindows.).X:=X;π WindowTable(.NoWindows.).Y:=Y;π WindowTable(.NoWindows.).Xsize:=Xsize;π WindowTable(.NoWindows.).Ysize:=Ysize;ππ End; { MakeWindow }ππProcedure SelectWindow(i : Integer);ππ { Specifies which window will receive subsequent output }ππ Beginπ With WindowTable(.i.) Doπ Beginπ Window(X+1,Y+1,X+Xsize-2,Y+Ysize-2);π End;π End; { SelectWindow }πππProcedure RemoveWindow(n: Integer);ππ { Removes window number n }ππ var i,j : Integer;ππ Beginπ SelectWindow(n);π With WindowTable(.n.) Doπ Beginπ Window(X,Y,X+Xsize,Y+Ysize);π For i:=X to X+Xsize Doπ For j:=Y to Y+Ysize Do screen(.i,j.):=free;π End; { With }π ClrScr;π End; { SelectWindow }ππProcedure Task1;Far;πVARπ SR : SearchRec;πbeginπ MakeWindow(27, 2,18,4,' Sub Task 1 ');π REPEATπ FINDFIRST('*.*',anyfile,SR);π WHILE DOSERROR = 0 DOπ BEGINπ Transfer;π SelectWindow(2);π WriteLn(SR.Name : 12);π FINDNEXT(SR);π Delay(10);π END;π UNTIL FALSE;πend;ππProcedure Task2;Far;πVARπ SR : SearchRec;πbeginπ MakeWindow(27, 7,18,4,' Sub Task 2 ');π REPEATπ FINDFIRST('\TURBO\TP\*.*',anyfile,SR);π WHILE DOSERROR = 0 DOπ BEGINπ Transfer;π SelectWindow(3);π WriteLn(SR.Name : 12);π FINDNEXT(SR);π Delay(10);π END;π UNTIL FALSE;πend;ππProcedure Task3;Far;πVARπ SR : SearchRec;πbeginπ MakeWindow(27,12,18,4,' Sub Task 3 ');π REPEATπ FINDFIRST('\TURBO\*.*',anyfile,SR);π WHILE DOSERROR = 0 DOπ BEGINπ Transfer;π SelectWindow(4);π WriteLn(SR.Name : 12);π FINDNEXT(SR);π Delay(10);π END;π UNTIL FALSE;πend;ππProcedure Task4;Far;πVARπ SR : SearchRec;πbeginπ MakeWindow(27,17,18,4,' Sub Task 4 ');π REPEATπ FINDFIRST('\*.*',anyfile,SR);π WHILE DOSERROR = 0 DOπ BEGINπ Transfer;π SelectWindow(5);π WriteLn(SR.Name : 12);π FINDNEXT(SR);π Delay(10);π END;π UNTIL FALSE;πend;ππBEGINπ ClrScr;π MakeWindow( 5,21,75,4,' Multi-Program Demo ');π SelectWindow(1);π WriteLn(' This is the MAIN task window and we will start 4 others too');π AddTask (Task1,8192);π AddTask (Task2,8192);π AddTask (Task3,8192);π AddTask (Task4,8192);π REPEATπ Transfer;π UNTIL KEYPRESSED;πEND.π 68 08-24-9413:55ALL GREG VIGNEAULT System Reboot SWAG9408 ╨º4â 17 ┤φ (*π System reset via software...ππ Using a jump to address $FFFF:0000 doesn't always work to rebootπ a system, particularly under multi-taskers. In a Windows 3.1 DOS-π session I get a dialog box, about a system violation, that tellsπ me to shut down all applications and restart the system -- but myπ PC is certainly not reset by the software reboot attempt.ππ AT-class systems ('286+) have a system controller IC which can beπ instructed to reset the system. This will force a reboot even underπ Windows. The following TP code illustrates this process.ππ Since this type of reset will interrupt all other processes, it'sπ important that an application first close all files and flush allπ buffers. It would also be a good idea to ask the user if a entireπ system reset is okay. Use this "power reset" prudently! ...π*)π(*******************************************************************)ππPROGRAM Reboot; { TP system reboot: Jul.19.94 Greg Vigneault }ππPROCEDURE SoftReset; { software reset for PC/XTs }π BEGIN { invalid for multi-taskers }π InLine( $2B/$C0/ { sub ax, ax }π $8E/$C0/ { mov es, ax }π $26/$C7/6/$72/4/$34/$12/ { mov es:[472h],1234h }π $EA/0/0/$FF/$FF); { jmp 0FFFFh:0000h }π END {SoftReset};ππPROCEDURE HardReset; { hardware reset for '286+ }π BEGIN { (uses system controller) }π InLine( $B0/$FE/ { mov al, 0FEh }π $E6/$64); { out 64h, al }π END {HardReset};πππBEGIN {Reboot}ππ WriteLn; WriteLn('POWER RESET courtesy Greg Vigneault...');π HardReset;π { if we're still running then the system is probably a PC/XT... }π SoftReset;ππEND {Reboot}.π{ Internet(Greg.Vigneault@westonia.com) Fido(1:250/636) }π(*******************************************************************)π 69 08-24-9413:55ALL JOHN HOWARD Redirection SWAG9408 ⌐«α╒ 34 ┤φ π{ I found an example of DOS redirection using TP. I think it came from eitherπ Dr. Dobb's or PC Magazine in 1992. I used this in my BinarY TExt (BYTE)π file tool which performs file splits, merges, encryption/decryption, scriptπ execution, and complete backwards and forwards byte resolution manipulation.π}πUNIT Echo;ππINTERFACEππUSES DOS;ππ FUNCTION InputRedirected : Boolean;π FUNCTION OutputRedirected : Boolean;π FUNCTION OutputNul : Boolean;π FUNCTION EchoIsOn : Boolean;π PROCEDURE EchoOn;π PROCEDURE EchoOff;ππIMPLEMENTATIONππ FUNCTION InputRedirected : Boolean;π VAR Regs : Registers; Handle : Word ABSOLUTE Input;π BEGINπ WITH Regs DOπ BEGINπ Ax := $4400;π Bx := Handle;π MsDos(Regs);π IF Dl AND $81 = $81 THEN InputRedirected := Falseπ ELSE InputRedirected := True;π END; {With Regs}π END; {Function InputRedirected}πππ FUNCTION OutputRedirected : Boolean;π VAR Regs : Registers; Handle : Word ABSOLUTE Output;π BEGINπ WITH Regs DOπ BEGINπ Ax := $4400;π Bx := Handle;π MsDos(Regs);π IF Dl AND $82 = $82 THEN OutputRedirected := Falseπ ELSE OutputRedirected := True;π END; {With Regs}π END; {Function OutputRedirected}πππ FUNCTION OutputNul : Boolean;π VAR Regs : Registers; Handle : Word ABSOLUTE Output;π BEGINπ WITH Regs DOπ BEGINπ Ax := $4400;π Bx := Handle;π MsDos(Regs);π IF Dl AND $84 <> $84 THEN OutputNul := Falseπ ELSE OutputNul := True;π END; {With Regs}π END; {Function OutputNul}πππ FUNCTION Write40h(DataBuffer : Pointer; Count, Handle : Word) : Word;π VAR Regs : Registers;π TYPE DWord = RECORD O, S : Word; END;π BEGINπ WITH Regs DOπ BEGINπ Ds := DWord(DataBuffer).S;π Dx := DWord(DataBuffer).O;π Bx := Handle;π Cx := Count;π Ah := $40;π MsDos(Regs);π IF Flags AND FCarry <> 0π THEN Write40h := 103 {- "file not open" -}π ELSE IF Ax < Cxπ THEN Write40h := 101 {- "disk write error" -}π ELSE Write40h := 0;π END; {With Regs do}π END; {Function Write40h}πππ{$F+} FUNCTION EchoOutput(VAR F : TextRec) : Integer; {$F-}π{- Replacement for Output text file FlushFunc and InOutFunc -}π BEGINπ WITH F DOπ BEGINπ EchoOutput := Write40h(BufPtr, BufPos, 2);π EchoOutput := Write40h(BufPtr, BufPos, Handle);π BufPos := 0;π END; {With F do}π END; {Function EchoOutput}πππCONST EchoStatus : Boolean = False; {- PRIVATE to unit Echo -}ππ PROCEDURE EchoOn;π BEGINπ IF OutputRedirected THENπ BEGINπ Flush(Output);π TextRec(Output).InOutFunc := @EchoOutput;π TextRec(Output).FlushFunc := @EchoOutput;π EchoStatus := True;π END; {If OutputRedirected}π END; {Procedure EchoOn}ππ PROCEDURE EchoOff;π BEGINπ IF OutputRedirected THENπ BEGINπ Rewrite(Output);π EchoStatus := False;π END; {If OutputRedirected THEN}π END; {Procedure EchoOff}ππ FUNCTION EchoIsOn : Boolean;π BEGINπ EchoIsOn := EchoStatus;π END; {Function EchoIsOn}πππBEGIN {- Unit initialization -}π EchoOn; {- Echo all redirected output -}πEND.ππ{-------------------------------------------------------------------}πPROGRAM EchoDemo;πUSES Echo;πBEGINπ IF InputRedirected THEN WriteLn('Input is being redirected');π IF OutputNul THENπ BEGINπ WriteLn('Output is being sent to the Nul device');π EchoOff;π END;π IF OutputRedirected THEN WriteLn('Output is being redirected');ππ WriteLn('--------1--------');π EchoOff;π WriteLn('--------2--------');π IF NOT OutputNul THEN EchoOn;π WriteLn('--------3--------');π EchoOff;π WriteLn('--------4--------');πEND.π 70 08-24-9413:56ALL VARIOUS Detecting Share (BASM) SWAG9408 L∩╖L 17 ┤φ { Can one one post some code to check this please.}ππ{--------------------------------------------------------- Share loaded ? ---}π{ BAS VAN GAALEN }πfunction share_loaded : boolean; assembler; asmπ mov ax,01000h; int 02fh; xor ah,ah; and al,0ffh; end;ππ{----------------------------------------------------------------------------}π{ ANDREW EIGUSπINT 2F - SHARE - INSTALLATION CHECKπ AX = 1000hπReturn: AL = 00h not installed, OK to installπ 01h not installed, not OK to installπ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ππfunction will return True here and it should not. So this one will work:π}ππFunction ShareDetected : boolean; assembler;πAsmπ MOV AX,1000hπ INT 2Fhπ CMP AL,0FFhπ JE @@1π MOV AL,Falseπ JMP @@2π@@1:π MOV AL,Trueπ@@2:πEnd; { ShareDetected }ππ{----------------------------------------------------------------------------}π{IAN LIN}ππconstπ noshareinstall=0;π nosharenoinstall=1;π shareinstalled=$ff;ππfunction shareloaded:byte;πassembler; asmπ mov ax,$1000π int $2fπend;ππINT 2F - SHARE - INSTALLATION CHECKπ AX = 1000hπReturn: AL = 00h not installed, OK to installπ 01h not installed, not OK to installπ FFh installedπBUGS: values of AL other than 00h put DOS 3.x SHARE into an infinite loopπ (08E9: OR AL,ALπ 08EB: JNZ 08EB) <- the buggy instruction (DOS 3.3)π values of AL other than described here put PC-DOS 4.00 into the sameπ loop (the buggy instructions are the same)πNotes: supported by OS/2 v1.3+ compatibility box, which always returns AL=FFhπ if DOS 4.01 SHARE was automatically loaded, file sharing is in anπ inactive state (due to the undocumented /NC flag used by the autoloadπ code) until this call is madeπ DOS 5+ chains to the previous handler if AL <> 00h on entryπ Windows Enhanced mode hooks this call and reports that SHARE isπ installed even when it is notπSeeAlso: AX=1080h,INT 21/AH=52hππ 71 08-24-9417:52ALL PETE ROCCA Time Slices SWAG9408 ⌠àφ 15 ┤φ {πDoes anyone got any unit/code on giving up time slice under DV or OS/2?πHere they are for DOS, Windows, OS/2, DV and DoubleDos. You will needπto detect the enviroment first (although none should make the systemπhang if it's the wrong enviroment, just be ignored) The key to goodπidle release is finding the right spots to put them. I have gotten myπdoor making unit that I created to about 97% idle during pauses and 93%πidle while waiting for keyboard input (with no delay in response - muchπbetter than the typical 12% idle pauses and 8% idle keyboard waits)πHere is how...π}ππProcedure Sleep(Seconds: Word);πVarπ H,M,S,T,Last: Word;πBeginπ If Seconds = 0 Then Exit;π If Seconds > 999 Then Seconds := Seconds DIV 1000;π {incase of caller is thinking milliseconds}ππ GetTime(H,M,Last,T);π Repeatπ Repeatπ GetTime(H,M,S,T);π TimerSlice;π TimerSlice;π Until S <> Last;π Last := S;π Dec(Seconds);π Until Seconds = 0;πEnd;ππFunction GetChar: Char;πVarπ Counter, Span: Byte;π Done: Boolean;πBeginπ Span := 0;π Done := False;π Repeatπ Inc(Counter);π If Counter > Span Thenπ Beginπ Counter := 0;π If IsChar Then Done := Trueπ Else If Span < 50 Then Inc(Span);π Endπ Else TimerSlice;π Until Done;π If KeyPressedExtended Then GetChar := Readkeyπ Else GetChar := RxChar;πEnd;ππProcedure TimerSlice;πBeginπ Case SystemEnviroment Ofπ DOS4:;π DOS5,π WINDOWS,π OS2: Asmπ MOV AX,$1680π INT $2Fπ End;π DV: Asmπ MOV AX,$1000π INT $15π End;π DOUBLEDOS: Asmπ MOV AX,$EE01π INT $21π End;π End;πEnd;π 72 08-24-9417:52ALL BJÖRN FELTEN TRUENAME (BASM) SWAG9408 w╟┌ì 10 ┤φ ππprogram TName; { to test the TrueName function }ππfunction TrueName(var P: string): string; assembler;π{ returns TrueName just like the DOS command does }π{ if error, returns a zero length string }π{ will probably crash for DOS versions < 3.0 }π{ donated to the Public Domain by Björn Felten @ 2:203/208 }πasmπ push dsπ lds si,Pπ@strip:π inc si { skip length byte ... }π cmp byte ptr [si],' 'π jle @strip { ... and trailing white space }ππ les di,@Resultπ inc di { leave room for byte count }π mov ah,60h { undocumented DOS call }π int 21hπ pop dsπ jc @errorππ mov cx,80 { convert ASCIZ to Pascal string }π xor ax,axπ repnz scasb { find trailing zero }π mov ax,80π sub ax,cx { get length byte }π jmp @retππ@error:π xor ax,ax { return zero length string }ππ@ret:π les di,@Resultπ stosbπend;πππvar S:string;πbeginπ S:=paramstr(1);π if paramcount<>1 thenπ writeln('Usage: tname <filename>')π elseπ writeln('TrueName of ',S,' is ',TrueName(S))πend.π 73 08-24-9417:54ALL FRANK DIACHEYSN WAIT Procedure SWAG9408 ÷ö╬ 8 ┤φ {π Coded By Frank Diacheysn Of Gemini Softwareππ PROCEDURE WAITππ Input......: Secs = Long Integer Value For The Number Of SECONDSπ : (NOT Milliseconds) To Delayπ :π :π :ππ Output.....: Noneπ :π :π :π :ππ Example....: Wait(5); (Wait 5 Seconds)π :π :π :π :ππ Description: Works Exactly Like The CRT Unit's Delay Procedure, Exceptπ : This Procedure Works With Seconds, Not Millisecondsπ :π :π :ππ}πPROCEDURE Wait( Secs:LONGINT );πVAR MS : WORD;πBEGINπ Secs := Secs * 1000;π ASMπ MOV AX, 1000;π MUL Secs;π MOV CX, DX;π MOV DX, AX;π MOV AH, $86;π INT $15;π END;πEND;π 74 08-24-9417:54ALL FRANK DIACHEYSN Where is DOS SWAG9408 ÄY&] 11 ┤φ {π Coded By Frank Diacheysn Of Gemini Softwareππ FUNCTION WHEREISDOSππ Input......: Noneπ :π :π :π :πππ Output.....: 2-Character String, Explained Further Below.π :π :π :π :ππ Example....: IF Chars[1] = 'O' THENπ : WriteLn('DOS Is Resident In ROM')π : ELSEπ : WriteLn('DOS Is Resident In RAM');π : IF Chars[2] = 'H' THENπ : WriteLn('DOS Is Loaded Into High Memory (HMA)')π : ELSEπ : WriteLn('DOS Is Loaded Into Conventional Memory');ππ Description: Returns The Status Of Where DOS Is Loaded Using The Following:π : Chars[1] = 'O' (Resident In ROM)π : Chars[1] = 'A' (Resident In RAM)π : Chars[2] = 'H' (Loaded In High Memory)π : Chars[2] = 'C' (Loaded in Conventional Memory)ππ}πFUNCTION WHEREISDOS:STRING;πVAR Chars : ARRAY [1..2] OF CHAR;πBEGINπ Regs.AH := $33;π Regs.AL := $06;π Intr( $33,Regs );π IF (Regs.DH AND $04)=$04 THEN Chars[1] := 'O' ELSE Chars[1] := 'A';π IF (Regs.DH AND $08)=$08 THEN Chars[2] := 'H' ELSE Chars[2] := 'C';π WHEREISDOS := Chars[1]+Chars[2];πEND;π 75 08-24-9417:57ALL RICK SCHAEFER Yes/No in Batch files SWAG9408 .;°≡ 9 ┤φ π{πThis is a VERY simple program to return anπerrorlevel based on whether the user pressed Y or N at a Yes/Noπprompt. Has to be simple since the wife uses it. :-) I use it in myπbatch files to branch to a different option depending on the user'sπselection.πππ{ Yes/No Errorlevel returner v.000003432ß }π{ Returns errorlevel depending on the key }π{ chosen by the end user. }π{ by Rick Schaefer }π{ Donated to the public domain }ππProgram YNExe;π Uses Dos,π Crt;πvarπ YN : char;π i : integer;ππ PROCEDURE Color(back, fore : BYTE);π BEGINπ TextAttr := (Fore + (Back SHL 4) ) MOD 128;π END;ππbeginπ color(15,0);π writeln;π writeln;π for i := 1 to paramcount do write(paramstr(i)+' ');π write(' (Y/N)? ');π YN := readkey;π YN := upcase(YN);π textcolor(14);π writeln(yn);π if (YN = 'Y') then halt(1);π if (YN = 'N') then halt(0);πend.π 76 08-25-9409:07ALL RANDALL WOODMAN Error Messages SWAG9408 º▓┘┼ 35 ┤φ Unit ExtError;π π{ Information lifted from 'Disk Operating System 3.30 Technical Reference'.π An IBM publication. USE this unit with DOS 3.0 or higher. π}π πInterfaceπ πImplementationπuses Dos;π π{$F+,R-,S-,I- }π πVarπ ExitSave : Pointer;π πProcedure GetExtendedError;π πVarπ Regs : Registers;π s : String;π πBeginπ ExitProc := ExitSave;π Regs.AH := $59;π Regs.BX := $0000;π Intr($21, Regs);π Write('Error #');π Case Regs.AX ofπ 1 : s := 'Invalid function number';π 2 : s := 'File not found';π 3 : s := 'Path not found';π 4 : s := 'Too many open files (no handles left)';π 5 : s := 'Access denied (file was opened Read Only)';π 6 : s := 'Invalid handle';π 7 : s := 'Memory control blocks destroyed';π 8 : s := 'Insufficient memory';π 9 : s := 'Invalid memory block address';π 10 : s := 'Invalid environment';π 11 : s := 'Invalid format';π 12 : s := 'Invalid access code';π 13 : s := 'Invalid data';π 15 : s := 'Invalid drive was specified';π 16 : s := 'Attempt to remove current directory';π 17 : s := 'Not same device';π 18 : s := 'No more files';π 19 : s := 'Attempt to write on write-protected diskette';π 20 : s := 'Unknown unit';π 21 : s := 'Drive not ready';π 22 : s := 'Unknown command';π 23 : s := 'Data error (CRC)';π 24 : s := 'Bad request structure length';π 25 : s := 'Seek error';π 26 : s := 'Unknown media type';π 27 : s := 'Sector not found';π 28 : s := 'Printer out of paper';π 29 : s := 'Write fault';π 30 : s := 'Read fault';π 31 : s := 'General failure';π 32 : s := 'Sharing violation';π 33 : s := 'Lock violation';π 34 : s := 'Invalid disk change';π 35 : s := 'FCB unavailable';π 36 : s := 'Sharing buffer overflow';π 50 : s := 'Network request not supported';π 51 : s := 'Remote computer not listening';π 52 : s := 'Duplicate name on network';π 53 : s := 'Network name not found';π 54 : s := 'Network busy';π 55 : s := 'Network device no longer exists';π 56 : s := 'Net BIOS command limit exceeded';π 57 : s := 'Network adapter hardware error';π 58 : s := 'Incorrect response from network';π 59 : s := 'Unexpected network error';π 60 : s := 'Incompatible remote adapter';π 61 : s := 'Print queue full';π 62 : s := 'Not enough space for print file';π 63 : s := 'Print file was deleted';π 65 : s := 'Access denied';π 66 : s := 'Network device type incorrect';π 67 : s := 'Network name not found';π 68 : s := 'Network name limit exceeded';π 69 : s := 'Net BIOS session limit exceeded';π 70 : s := 'Temporarily paused';π 71 : s := 'Network request not accepted';π 72 : s := 'Print or disk redirection is paused';π 80 : s := 'File exists';π 82 : s := 'Cannot make directory entry';π 83 : s := 'Fail on INT 24';π 84 : s := 'Too many redirections';π 85 : s := 'Duplicate redirection';π 86 : s := 'Invalid password';π 87 : s := 'Invalid parameter';π 88 : s := 'Network device fault';π end;π WriteLn(Regs.AX, ': ', s);π Write('Error class: ');π Case Regs.BH ofπ 1 : s := 'Out of resource';π 2 : s := 'Temporary situation';π 3 : s := 'Permission problem';π 4 : s := 'Internal error in system software';π 5 : s := 'Hardware failure';π 6 : s := 'Serious failure of system software';π 7 : s := 'Application program error';π 8 : s := 'File/item not found';π 9 : s := 'File/item of invalid format or type';π 10 : s := 'File/item interlocked';π 11 : s := 'Media failure: wrong disk, CRC error...';π 12 : s := 'Collision with existing item';π 13 : s := 'Classification doesn''t exist or is inappropriate';π end;π WriteLn(s);π Write('Suggested action: ');π Case Regs.BL ofπ 1 : s := 'Retry';π 2 : s := 'Retry after pause';π 3 : s := 'Ask user to re-enter input';π 4 : s := 'Abort program with cleanup';π 5 : s := 'Abort immediately, skip cleanup';π 6 : s := 'Ignore';π 7 : s := 'Retry after user intervention';π end;π WriteLn(s);π Write('Error locus: ');π Case Regs.CH ofπ 1 : s := 'Unknown or inappropriate';π 2 : s := 'Related to disk storage';π 3 : s := 'Related to the network';π 4 : s := 'Serial device';π 5 : s := 'Memory';π end;π WriteLn(s);π Halt;πend; { GetExtendedError }ππBeginπ ExitSave := ExitProc;π ExitProc := @GetExtendedError;πend. { ExtError }π
