Category : Pascal Source Code
Archive   : CRUNCH10.ZIP
Filename : STRPROCS.PAS

Unit StrProcs;

{ ***** Misc. String Functions ******************************************** }

Interface

Uses Dos;

Function Upper(StrIn : String) : String;
{ Convert a string to upper case }

Function PathOnly(FileName : String) : String;
{ Strip any filename information from a file specification }

Function NameOnly(FileName : String) : String;
{ Strip any path information from a file specification }

Function BaseNameOnly(FileName : String) : String;
{ Strip any path and extension information from a file specification }

Function ExtOnly(FileName : String) : String;
{ Return only the extension portion of a filename }

Function IntStr(Int : LongInt; Form : Integer) : String;
{ Convert an Integer variable to a string }

Function SameFile(File1, File2 : String) : Boolean;
{ Call to find out if File1 has a name equivalent to File2. Both filespecs }
{ may contain wildcards. }

{ ************************************************************************** }

Implementation

Function Upper(StrIn : String) : String;
Begin
Inline( { Thanks to Phil Burns for this routine }

$1E/ { PUSH DS ; Save DS}
$C5/$76/$06/ { LDS SI,[BP+6] ; Get source string address}
$C4/$7E/$0A/ { LES DI,[BP+10] ; Get result string address}
$FC/ { CLD ; Forward direction for strings}
$AC/ { LODSB ; Get length of source string}
$AA/ { STOSB ; Copy to result string}
$30/$ED/ { XOR CH,CH}
$88/$C1/ { MOV CL,AL ; Move string length to CL}
$E3/$0E/ { JCXZ Exit ; Skip if null string}
{;}
$AC/ {UpCase1: LODSB ; Get next source character}
$3C/$61/ { CMP AL,'a' ; Check if lower-case letter}
$72/$06/ { JB UpCase2}
$3C/$7A/ { CMP AL,'z'}
$77/$02/ { JA UpCase2}
$2C/$20/ { SUB AL,'a'-'A' ; Convert to uppercase}
{;}
$AA/ {UpCase2: STOSB ; Store in result}
$E2/$F2/ { LOOP UpCase1}
{;}
$1F); {Exit: POP DS ; Restore DS}

end {Upper};

{ -------------------------------------------------------------------------- }

Function PathOnly(FileName : String) : String;
Var
Dir : DirStr;
Name : NameStr;
Ext : ExtStr;
Begin
FSplit(FileName, Dir, Name, Ext);
PathOnly := Dir;
End {PathOnly};

{ --------------------------------------------------------------------------- }

Function NameOnly(FileName : String) : String;
{ Strip any path information from a file specification }
Var
Dir : DirStr;
Name : NameStr;
Ext : ExtStr;
Begin
FSplit(FileName, Dir, Name, Ext);
NameOnly := Name + Ext;
End {NameOnly};

{ --------------------------------------------------------------------------- }

Function BaseNameOnly(FileName : String) : String;
{ Strip any path and extension from a file specification }
Var
Dir : DirStr;
Name : NameStr;
Ext : ExtStr;
Begin
FSplit(FileName, Dir, Name, Ext);
BaseNameOnly := Name;
End {BaseNameOnly};

{ --------------------------------------------------------------------------- }

Function ExtOnly(FileName : String) : String;
{ Strip the path and name from a file specification. Return only the }
{ filename extension. }
Var
Dir : DirStr;
Name : NameStr;
Ext : ExtStr;
Begin
FSplit(FileName, Dir, Name, Ext);
If Pos('.', Ext) <> 0 then
Delete(Ext, 1, 1);
ExtOnly := Ext;
End {ExtOnly};

{ --------------------------------------------------------------------------- }

Function IntStr(Int : LongInt; Form : Integer) : String;
Var
S : String;
Begin
If Form = 0 then
Str(Int, S)
else
Str(Int:Form, S);
IntStr := S;
End {IntStr};

{ --------------------------------------------------------------------------- }

Function SameName(N1, N2 : String) : Boolean;
{
Function to compare filespecs.

Wildcards allowed in either name.
Filenames should be compared seperately from filename extensions by using
seperate calls to this function
e.g. FName1.Ex1
FName2.Ex2
are they the same?
they are if SameName(FName1, FName2) AND SameName(Ex1, Ex2)

Wildcards work the way DOS should've let them work (eg. *XX.DAT doesn't
match just any file...only those with 'XX' as the last two characters of
the name portion and 'DAT' as the extension).

This routine calls itself recursively to resolve wildcard matches.

}
Var
P1, P2 : Integer;
Match : Boolean;
Begin
P1 := 1;
P2 := 1;
Match := TRUE;

If (Length(N1) = 0) and (Length(N2) = 0) then
Match := True
else
If Length(N1) = 0 then
If N2[1] = '*' then
Match := TRUE
else
Match := FALSE
else
If Length(N2) = 0 then
If N1[1] = '*' then
Match := TRUE
else
Match := FALSE;

While (Match = TRUE) and (P1 <= Length(N1)) and (P2 <= Length(N2)) do
If (N1[P1] = '?') or (N2[P2] = '?') then begin
Inc(P1);
Inc(P2);
end {then}
else
If N1[P1] = '*' then begin
Inc(P1);
If P1 <= Length(N1) then begin
While (P2 <= Length(N2)) and Not SameName(Copy(N1,P1,Length(N1)-P1+1), Copy(N2,P2,Length(N2)-P2+1)) do
Inc(P2);
If P2 > Length(N2) then
Match := FALSE
else begin
P1 := Succ(Length(N1));
P2 := Succ(Length(N2));
end {if};
end {then}
else
P2 := Succ(Length(N2));
end {then}
else
If N2[P2] = '*' then begin
Inc(P2);
If P2 <= Length(N2) then begin
While (P1 <= Length(N1)) and Not SameName(Copy(N1,P1,Length(N1)-P1+1), Copy(N2,P2,Length(N2)-P2+1)) do
Inc(P1);
If P1 > Length(N1) then
Match := FALSE
else begin
P1 := Succ(Length(N1));
P2 := Succ(Length(N2));
end {if};
end {then}
else
P1 := Succ(Length(N1));
end {then}
else
If UpCase(N1[P1]) = UpCase(N2[P2]) then begin
Inc(P1);
Inc(P2);
end {then}
else
Match := FALSE;

If P1 > Length(N1) then begin
While (P2 <= Length(N2)) and (N2[P2] = '*') do
Inc(P2);
If P2 <= Length(N2) then
Match := FALSE;
end {if};

If P2 > Length(N2) then begin
While (P1 <= Length(N1)) and (N1[P1] = '*') do
Inc(P1);
If P1 <= Length(N1) then
Match := FALSE;
end {if};

SameName := Match;

End {SameName};

{ ---------------------------------------------------------------------------- }

Function SameFile(File1, File2 : String) : Boolean;
Var
Path1, Path2 : String;
Begin

File1 := FExpand(File1);
File2 := FExpand(File2);
Path1 := PathOnly(File1);
Path2 := PathOnly(File2);

SameFile := SameName(BaseNameOnly(File1), BaseNameOnly(File2)) AND
SameName(ExtOnly(File1), ExtOnly(File2)) AND
(Path1 = Path2);

End {SameFile};

{ ---------------------------------------------------------------------------- }

End {Unit StrProcs}.