|
DataMuseum.dkPresents historical artifacts from the history of: DANOSI |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about DANOSI Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - download
Length: 19309 (0x4b6d)
Types: TextFile
Names: »DOSUTIL.PAS«
└─⟦e2123b2a1⟧ Bits:30010498 DVBS1.SW2103.src.1.8-1 Pascal TOOLS JTAS 1989-04-26 LEIF NIELSEN E.d.
└─⟦this⟧ »UNITS\DOSUTIL.PAS«
{$R-} {Range checking off}\r
{$B+} {Boolean complete evaluation on}\r
{$S+} {Stack checking on}\r
{$I+} {I/O checking on}\r
{$N-} {No numeric coprocessor}\r
\r
UNIT DosUtil;\r
\r
INTERFACE\r
\r
USES\r
Crt,\r
Dos;\r
\r
TYPE\r
CompareResult = (LT, EQ, GT);\r
\r
FUNCTION CompStr(VAR St1, St2 : STRING; KeyPos, KeyLng : byte) : CompareResult;\r
\r
PROCEDURE SetCollateSeq(Col : STRING);\r
\r
FUNCTION GetCollateSeq(Ch : char) : char;\r
\r
FUNCTION BinByte(V : shortint) : STRING;\r
{ The function BinByte converts an byte value (8 bit) to a text }\r
{ string (type string), which contains the text representation }\r
{ of the byte value to be displayed as a bit string (8 digits) }\r
\r
FUNCTION BinWord(V : integer) : STRING;\r
{ The function BinWord converts an word value (16 bit) to a text }\r
{ string (type string), which contains the text representation }\r
{ of the word value to be displayed as a bit string (16 digits) }\r
\r
FUNCTION HexByte(V : byte) : STRING;\r
{ The function HexByte converts an byte value (8 bit) to a text }\r
{ string (type string), which contains the text representation }\r
{ of the byte value to be displayed as a hexadecimal (2 digits) }\r
\r
FUNCTION HexWord(V : word) : STRING;\r
{ The function HexWord converts an word value (16 bit) to a text }\r
{ string (type string), which contains the text representation }\r
{ of the word value to be displayed as a hexadecimal (4 digits) }\r
\r
FUNCTION FileExist(FileName : STRING): boolean;\r
{ function FileExist returns a boolean value indicating the existence }\r
{ of a file whose name is passed as a paramater. }\r
\r
FUNCTION UpCase( Ch : char) : char;\r
{ The function UpCase converts the input character to upper case according }\r
{ to the rules applying to the danish/norwegian IBM character set }\r
\r
FUNCTION LoCase( Ch : char) : char;\r
{ The function UpCase converts the input character to lower case according }\r
{ to the rules applying to the danish/norwegian IBM character set }\r
\r
FUNCTION UpperStr( St : STRING) : STRING;\r
{ The function UpperStr converts all the characters in the input string to }\r
{ upper case according to the rules applying to the danish/norwegian IBM }\r
{ character set (codepage 850) }\r
\r
FUNCTION LowerStr( St : STRING) : STRING;\r
{ The function UpperStr converts all the characters in the input string to }\r
{ lower case according to the rules applying to the danish/norwegian IBM }\r
{ character set (codepage 850) }\r
\r
FUNCTION StripBlanks( St : STRING) : STRING;\r
{ The function StripBlanks returns the input string with all blanks removed }\r
\r
FUNCTION DateTimeText (DT : DateTime) : STRING;\r
{ DateTimeText converts a date and time value in the form of a }\r
{ variable of type DateTime (defined in the Dos unit) to text }\r
{ form, as defined by DOS national date format: }\r
{ INPUT: }\r
{ DT : DateTime the value to be converted }\r
{ OUTPUT: }\r
{ Result : string the resulting text }\r
\r
FUNCTION EnvStrCount : integer;\r
{ function EnvStrCount returns the number of environment strings }\r
{ defined in the DOS environment }\r
\r
FUNCTION EnvStr(No : integer) : STRING;\r
{ function EnvStr returns the value of the environment string defined as }\r
{ the "No"th environment string in the DOS environment. if "No" is greater }\r
{ than "EnvStrCount" an empty string is returned }\r
\r
FUNCTION ProgFileName : STRING;\r
{ function ProgFileName returns the name of the current running program }\r
{ in the form <drive>:[<path>]\<filename>.<extension> }\r
{ where <path> is <path>\<subdir> or \<subdir> }\r
\r
FUNCTION EnvStrVal( EnvStrName : STRING) : STRING;\r
{ function EnvStrVal returns the value of the environment string with the }\r
{ name given by "EnvStrName", as set in the DOS environment by the DOS }\r
{ command SET: }\r
{ SET <EnvStrName>=<EnvStrVal> }\r
{ if no environment string is found with the specified name an empty }\r
{ string is returned }\r
\r
PROCEDURE GetSysDate(VAR SysDate : DateTime);\r
{ the procedure GetSysDate retrieves the DOS system date and time and }\r
{ returns it in a variable of type DateTime as defined in the Dos unit }\r
\r
{===========================================================================}\r
\r
IMPLEMENTATION\r
\r
TYPE\r
CharTableType = ARRAY[char] OF char;\r
CharTablePtr = ^CharTableType;\r
CollateTableType = RECORD\r
Size : word;\r
Table : CharTableType;\r
END;\r
CollateTablePtr = ^CollateTableType;\r
ExtCountryRecordType = RECORD\r
Kind : byte;\r
Ptr : CollateTablePtr;\r
END;\r
ExtCountryRecordPtr = ^ExtCountryRecordType;\r
CountryRecordType = RECORD\r
DtF : word; { date format }\r
CSm : ARRAY[1..5] OF char; { currency symbol }\r
ThS : char; { thousand separator }\r
D01 : byte; { dummy }\r
DeS : char; { decimal separator }\r
D02 : byte; { dummy }\r
DtS : char; { date separator }\r
D03 : byte; { dummy }\r
TmS : char; { time separator }\r
D04 : byte; { dummy }\r
CFt : byte; { currency format }\r
CSd : byte; { currency significant digits }\r
TmF : byte; { time format }\r
Adr : pointer; { upper case routine }\r
DlS : char; { data list separator }\r
D05 : byte; { dummy }\r
Res : ARRAY[1..5] OF word; { reserved by DOS }\r
END;\r
VAR\r
CR : CountryRecordType;\r
Reg : Registers;\r
P : pointer;\r
Ch : char;\r
UCPtr, LCPtr, ColTabPtr : CharTablePtr;\r
ExtCR : ExtCountryRecordType;\r
MajorVersion, MinorVersion : byte;\r
OutF : text;\r
\r
\r
FUNCTION UC128(ch : char) : char; INLINE ($58/$FF/$1E/P);\r
\r
\r
FUNCTION UC(ch : char) : char;\r
BEGIN\r
IF ch > #127 THEN UC := UC128(ch)\r
ELSE\r
BEGIN\r
IF ch IN ['a'..'z'] THEN UC := Chr(Ord(ch)-Ord('a')+Ord('A'))\r
ELSE UC := ch;\r
END;\r
END;\r
\r
\r
FUNCTION BinByte(V : shortint) : STRING;\r
{ The function BinByte converts an byte value (8 bit) to a text }\r
{ string (type string), which contains the text representation }\r
{ of the byte value to be displayed as a bit string (8 digits) }\r
VAR\r
I : integer;\r
S : STRING;\r
BEGIN\r
S := '';\r
FOR I := 1 TO 8 DO\r
BEGIN\r
IF V < 0 THEN { the sign bit is the first bit in the value }\r
S := S+'1'\r
ELSE\r
S := S+'0';\r
V := V SHL 1; { shift to process the next bit }\r
END;\r
BinByte := S;\r
END; { BinByte }\r
\r
FUNCTION BinWord(V : integer) : STRING;\r
{ The function BinWord converts an word value (16 bit) to a text }\r
{ string (type string), which contains the text representation }\r
{ of the word value to be displayed as a bit string (16 digits) }\r
VAR\r
I : integer;\r
S : STRING;\r
BEGIN\r
S := '';\r
FOR I := 1 TO 16 DO\r
BEGIN\r
IF V < 0 THEN { the sign bit is the first bit in the value }\r
S := S+'1'\r
ELSE\r
S := S+'0';\r
V := V SHL 1; { shift to process the next bit }\r
END;\r
BinWord := S;\r
END; { BinWord }\r
\r
FUNCTION HexByte(V : byte) : STRING;\r
{ The function HexByte converts an byte value (8 bit) to a text }\r
{ string (type string), which contains the text representation }\r
{ of the byte value to be displayed as a hexadecimal (2 digits) }\r
CONST\r
T:ARRAY[0..15] OF char = ('0','1','2','3','4','5','6','7',\r
'8','9','A','B','C','D','E','F');\r
{ Table of hexadecimal digits }\r
VAR\r
I : integer;\r
S : STRING;\r
BEGIN\r
S := '';\r
FOR I := 1 TO 2 DO\r
BEGIN\r
S := S + T[V SHR 4]; { the four leftmost bits (one hex digit) }\r
V := V SHL 4; { shift next four bits up front }\r
END;\r
HexByte := S;\r
END; { HexByte }\r
\r
FUNCTION HexWord(V : word) : STRING;\r
{ The function HexWord converts an word value (16 bit) to a text }\r
{ string (type string), which contains the text representation }\r
{ of the word value to be displayed as a hexadecimal (4 digits) }\r
CONST\r
T:ARRAY[0..15] OF char = ('0','1','2','3','4','5','6','7',\r
'8','9','A','B','C','D','E','F');\r
{ Table of hexadecimal digits }\r
VAR\r
I : integer;\r
S : STRING;\r
BEGIN\r
S := '';\r
FOR I := 1 TO 4 DO\r
BEGIN\r
S := S + T[V SHR 12]; { the four leftmost bits (one hex digit) }\r
V := V SHL 4; { shift next four bits up front }\r
END;\r
HexWord := S;\r
END; { HexWord }\r
\r
FUNCTION FileExist(FileName : STRING): boolean;\r
{ function Exist returns a boolean value indicating the existence of }\r
{ a file whose name is passed as a paramater. }\r
VAR\r
F : FILE;\r
BEGIN\r
{$I-}\r
Assign(F,FileName);\r
Reset(F);\r
{$I+}\r
IF IOResult <> 0 THEN\r
FileExist := false\r
ELSE\r
BEGIN\r
FileExist := true;\r
Close(F);\r
END;\r
END; { end function FileExist }\r
\r
{$L DosUtil.OBJ }\r
FUNCTION CompStr(VAR St1, St2 : STRING; KeyPos, KeyLng : byte) : CompareResult;\r
EXTERNAL;\r
\r
FUNCTION UpCase( Ch : char) : char; EXTERNAL;\r
\r
FUNCTION LoCase( Ch : char) : char; EXTERNAL;\r
\r
FUNCTION UpperStr( St : STRING) : STRING; EXTERNAL;\r
\r
FUNCTION LowerStr( St : STRING) : STRING; EXTERNAL;\r
\r
FUNCTION StripBlanks( St : STRING) : STRING;\r
{ The function StripBlanks returns the input string with all blanks removed }\r
VAR\r
i : integer;\r
Tmp : STRING;\r
BEGIN\r
Tmp := '';\r
FOR i := 1 TO Length(St) DO\r
IF St[i] <> ' ' THEN Tmp := Tmp + St[i];\r
StripBlanks := Tmp;\r
END; { StripBlanks }\r
\r
FUNCTION DateTimeText (DT : DateTime) : STRING;\r
{ DateTimeText converts a date and time value in the form of a }\r
{ variable of type DateTime (defined in the Dos unit) to text }\r
{ form, as defined by DOS national date format: }\r
{ INPUT: }\r
{ DT : DateTime the value to be converted }\r
{ OUTPUT: }\r
{ Result : string the resulting text }\r
CONST\r
Order : ARRAY[0..2,1..3] OF integer = ((2,1,3),(1,2,3),(3,2,1));\r
VAR\r
K : integer;\r
S : STRING[2];\r
Txt : STRING;\r
BEGIN\r
WITH DT DO\r
BEGIN\r
Txt := '';\r
FOR K := 1 TO 3 DO\r
BEGIN\r
CASE Order[CR.DtF,K] OF\r
1: Str(Day:2,S);\r
2: Str(Month:2,S);\r
3: Str((Year MOD 100):2,S);\r
END; { case }\r
IF K < 3 THEN Txt := Txt + S + CR.Dts ELSE Txt := Txt + S + ' ';\r
END;\r
IF CR.TmF = 0 THEN\r
BEGIN\r
K := Hour MOD 12;\r
IF K = 0 THEN K := 12;\r
END\r
ELSE\r
K := Hour;\r
Str(K:2,S); Insert(S + CR.TmS,Txt,10);\r
Str(Min:2,S); Insert(S + CR.TmS,Txt,13);\r
Str(Sec:2,S); Insert(S,Txt,16);\r
FOR K := 0 TO 5 DO\r
IF Txt[ 3*K+1 ] = ' ' THEN Txt[ 3*K+1 ] := '0';\r
IF CR.TmF = 0 THEN\r
BEGIN\r
IF Hour < 12 THEN Txt := Txt + ' AM'\r
ELSE Txt := Txt + ' PM';\r
END;\r
END;\r
DateTimeText := Txt;\r
END; { DateTimeText }\r
\r
FUNCTION EnvStrCount : integer;\r
{ function EnvStr returns the value of the environment string defined as }\r
{ the "No"th environment string in the DOS environment. if "No" is greater }\r
{ than "EnvStrCount" an empty string is returned }\r
TYPE\r
EnvPtr = ^Envir;\r
Envir = ARRAY [1..MaxInt] OF char;\r
VAR\r
P : EnvPtr;\r
Count, I : integer;\r
BEGIN\r
I := MemW[PrefixSeg:$2c];\r
Count := 0;\r
P := Ptr(I,0);\r
I := 0;\r
REPEAT\r
I := I+1;\r
WHILE P^[I] <> Chr(0) DO I := I+1;\r
Count := Count + 1;\r
UNTIL P^[I+1] = Chr(0);\r
EnvStrCount := Count;\r
END; { EnvStrCount }\r
\r
FUNCTION EnvStr(No : integer) : STRING;\r
{ function EnvStr returns the value of the environment string defined as }\r
{ the "No"th environment string in the DOS environment }\r
TYPE\r
EnvPtr = ^Envir;\r
Envir = ARRAY [1..MaxInt] OF char;\r
VAR\r
P : EnvPtr;\r
Count, I : integer;\r
LocalStr : STRING;\r
BEGIN\r
LocalStr := '';\r
IF (No > 0) AND (No <= EnvStrCount) THEN\r
BEGIN\r
I := MemW[PrefixSeg:$2c];\r
Count := 0;\r
P := Ptr(I,0);\r
I := 0;\r
REPEAT\r
I := I+1;\r
LocalStr := '';\r
WHILE P^[I] <> Chr(0) DO\r
BEGIN\r
LocalStr := LocalStr + P^[I];\r
I := I+1;\r
END;\r
Count := Count + 1;\r
UNTIL Count = No;\r
END;\r
EnvStr := LocalStr;\r
END; { EnvStr }\r
\r
FUNCTION ProgFileName : STRING;\r
{ function ProgFileName returns the name of the current running program }\r
{ in the form <drive>:[<path>]\<filename>.<extension> }\r
{ where <path> is <path>\<subdir> or \<subdir> }\r
TYPE\r
EnvPtr = ^Envir;\r
Envir = ARRAY [1..MaxInt] OF char;\r
VAR\r
P : EnvPtr;\r
I : integer;\r
LocalStr : STRING;\r
BEGIN\r
LocalStr := '';\r
I := MemW[PrefixSeg:$2c];\r
P := Ptr(I,0);\r
I := 0;\r
REPEAT\r
I := I+1;\r
WHILE P^[I] <> Chr(0) DO I := I + 1;\r
UNTIL P^[I+1] = Chr(0);\r
I := I+4;\r
WHILE P^[I]<>Chr(0) DO\r
BEGIN\r
LocalStr := LocalStr + P^[I];\r
I := I + 1;\r
END;\r
ProgFileName := LocalStr;\r
END;\r
\r
FUNCTION EnvStrVal( EnvStrName : STRING) : STRING;\r
{ function EnvStrVal returns the value of the environment string with the }\r
{ name given by "EnvStrName", as set in the DOS environment by the DOS }\r
{ command SET: }\r
{ SET <EnvStrName>=<EnvStrVal> }\r
{ if no environment string is found with the specified name an empty }\r
{ string is returned }\r
VAR\r
I, MaxTry : integer;\r
Found : boolean;\r
LocalStr : STRING;\r
BEGIN\r
MaxTry := EnvStrCount;\r
I := 0;\r
Found := false;\r
EnvStrName := UpperStr(EnvStrName);\r
WHILE NOT Found AND (I < MaxTry) DO\r
BEGIN\r
I := I + 1;\r
LocalStr := EnvStr(I);\r
Found := (Pos(EnvStrName,LocalStr) = 1);\r
END;\r
IF Found THEN\r
BEGIN\r
I := Pos('=',LocalStr);\r
EnvStrVal := Copy(LocalStr,I+1,255);\r
END\r
ELSE\r
EnvStrVal := '';\r
END; { EnvStrVal }\r
\r
PROCEDURE GetSysDate(VAR SysDate : DateTime);\r
{ the procedure GetSysDate retrieves the DOS system date and time and }\r
{ returns it in a variable of type DateTime as defined in the Dos unit }\r
VAR\r
Dummy : word;\r
BEGIN\r
WITH SysDate DO\r
BEGIN\r
GetDate(Year, Month, Day, Dummy);\r
GetTime(Hour, Min, Sec, Dummy);\r
END;\r
END; { GetSysDate }\r
\r
PROCEDURE LCTab; EXTERNAL;\r
\r
PROCEDURE UCTab; EXTERNAL;\r
\r
PROCEDURE ColTab; EXTERNAL;\r
\r
PROCEDURE SetCollateSeq(Col : STRING);\r
VAR\r
Ptr : CharTablePtr;\r
Ch, C : char;\r
I : integer;\r
BEGIN\r
Ptr := @ColTab;\r
FOR C := #0 TO #255 DO Ptr^[Ch] := #255;\r
Ch := #0;\r
FOR I := 1 TO Length(Col) DO\r
BEGIN\r
Ptr^[Col[I]] := Ch;\r
Ch := Succ(Ch);\r
END;\r
FOR C := #0 TO #255 DO\r
IF Ptr^[C] = #255 THEN\r
BEGIN\r
Ptr^[C] := Ch;\r
Ch := Succ(Ch);\r
END;\r
END;\r
\r
FUNCTION GetCollateSeq(Ch : char) : char;\r
VAR\r
Ptr : CharTablePtr;\r
BEGIN\r
Ptr := @ColTab;\r
GetCollateSeq := Ptr^[Ch];\r
END;\r
\r
BEGIN { Initialization part }\r
Reg.AX := $3000;\r
{ Get DOS version number }\r
MsDos(Reg);\r
MajorVersion := Reg.AL;\r
MinorVersion := Reg.AH;\r
{ only support for DOS version 3 or later }\r
IF MajorVersion >= 3 THEN\r
BEGIN\r
WITH Reg DO\r
BEGIN\r
AX := $3800;\r
DS := Seg(CR);\r
DX := Ofs(CR);\r
END;\r
MsDos(Reg);\r
P := CR.Adr;\r
UCPtr := @UCTab;\r
LCPtr := @LCTab;\r
FOR Ch := #32 TO #255 DO\r
BEGIN\r
UCPtr^[Ch] := Ch;\r
LCPtr^[Ch] := Ch;\r
END;\r
FOR Ch := #255 DOWNTO #32 DO\r
IF Ch <> UC(Ch) THEN\r
BEGIN\r
UCPtr^[Ch] := UC(Ch);\r
LCPtr^[UC(Ch)] := Ch;\r
END;\r
IF (MajorVersion > 3) OR (MinorVersion > 29) THEN\r
BEGIN\r
WITH Reg DO\r
BEGIN\r
AX := $6506;\r
BX := $FFFF;\r
DX := $FFFF;\r
CX := 5;\r
ES := Seg(ExtCR);\r
DI := Ofs(ExtCR);\r
END;\r
MsDos(Reg);\r
ColTabPtr := @ColTab;\r
FOR Ch := #0 TO #255 DO\r
WITH ExtCR.Ptr^ DO\r
BEGIN\r
ColTabPtr^[Ch] := Table[Ch];\r
END;\r
END;\r
END;\r
END.\r
«eof»