SWAGOLX.EXE (c) 1993 GDSOFT ALL RIGHTS RESERVED 00057 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;ππ
