Beijing Paradise BBS Backup/PARADISE.ISO/software/BBSDOORW/RADOOR30.ZIP/LOWLEVEL.PAS

Pascal/Delphi Source File | 1994-04-10 | 15.2 KB | 546 lines

{╔═════════════════════════════════════════════════════════════════════════╗
 ║                                                                         ║
 ║                   (c) CopyRight LiveSystems 1990, 1994                  ║
 ║                                                                         ║
 ║ Author    : Gerhard Hoogterp                                            ║
 ║ FidoNet   : 2:282/100.5   2:283/7.33                                    ║
 ║ BitNet    : [e-mail]                                     ║
 ║                                                                         ║
 ║ SnailMail : Kremersmaten 108                                            ║
 ║             7511 LC Enschede                                            ║
 ║             The Netherlands                                             ║
 ║                                                                         ║
 ║        This module is part of the RADoor BBS doorwriters toolbox.       ║
 ║                                                                         ║
 ╚═════════════════════════════════════════════════════════════════════════╝}
{---------------------------------------------------------------------------|

Description:

 This unit contains all the lowlevel stuff used while writing doors. Lots of
 it is used by the ToolBox itself too. The procedures and functions cover
 FileName handling, timer routines, String routines, conversion and the
 commandline.

CompilerDirectives:

 BBSAwear  Some procedures can make usage of the information inside the
           GlobalInfo record. F.e. MakeString uses the graphical abilities
           of the user to use AVATARS simple RLE compression. If you want
           to use this unit outside the scope of the toolbox, you can turn
           this off by disabling the BBSAwear directive.

|--------------------------------------------------------------------------}
{Define BBSAwear}

Unit LowLevel;
Interface
Uses Dos;

{---------------------------------------------------------------------------|
  The commandline routines.

  GrabParameter looks for a commandline parameter indentified by the
  KEY string preceded by an '-' It returns the value of the parameter.
  f.e. GrabParameter('T:') looks for the indentifier -T: and returns the
  part behind the semicolumn a result.

  ExistParameter works the same, but only returns true or false. True
  when the parameter is found, false if it isn't.
|--------------------------------------------------------------------------}

Type IndentString  = String[10];

Function GrabParameter(Key : IndentString):ComStr;
Function ExistParameter(Key : IndentString):Boolean;


{---------------------------------------------------------------------------|
  The basic char and string procedures.

 Function MlUpCase(C : Char):Char;    Same as TP's Upcase function, but also
                                      for foreighn characters.
 Function MlDownCase(C : Char):Char;  Returns the lowercase char. Also for
                                      foreighn characters.
 FormatLine  Formats a string in the RA/QBBS/SBBS way, with all lowercase
             except for the beginning of words.
 UpStr       Converts a string to all uppercase
 DownStr     Converts a string to all lowercase
 Center      Centers a string on the screen. Thisone uses the MakeString
             function and thereby the information in the GlobalInfo record.
 MakeString  Returns a string of the given character and the given length.
             Uses AVATARS RLE compression when the BBSawear compiler directive
             is enabled.
 FindToken   Returnes the everything before a given delimiter.

 SimplifyDelimiters   Simplify double delimiters
 SkipLeadingSpaces    Deletes leading spaces
 DeleteTrailingSpaces Deletes trailing spaces.
 DeleteNoise          Delete certain characters from a string
 ReplaceToken         Replace a token with an other
 TimeStamp            Returns a fullfeatured TimeStamp string

|--------------------------------------------------------------------------}

Function FormatLine(Line : String):String;
Function UpStr(St : String):String;
Function DownStr(Line : String):String;
Function Center(CL:String):String;
Function MakeString(Len : Byte; InpChar : Char):String;

Type Str40       = String[40];
     TimeString  = String[20];

Function FindToken(Var Line : String;Delimiters : Str40):String;
Procedure SimplifyDelimiters(Var Line : String;Delimiters : Str40);
Procedure SkipLeadingSpaces(Var Line : String);
Procedure DeleteTrailingSpaces(Var Line : String);
Procedure DeleteNoise(Var Line : String;Noise : Str40);
Procedure ReplaceToken(Var Line : String;Tok1,Tok2 : String);

Function TimeStamp:TimeString;

{---------------------------------------------------------------------------|
  The conversion procedures

  S          Converts a Word to a string of the given length. Note, that if
             you set the length to short, the result will be as long a needed!
  SL         Same as S for longints.
  SF         same as S, but leading spaces are converted to zero's
  I          Same as S, but for integer
  Str2Nr     Converts a string to a word. Returns Zero if illegal characters
             are found or the string is empty.
|--------------------------------------------------------------------------}

Type NrString = String[15];
     HexStr   = String[4];

Function S(Num : Word;Len : Byte):NrString;
Function SL(Num : LongInt; Len : Byte):NrString;
Function SF(Num : Word;Len : Byte):NrString;

Function I(Num : Integer; Len : Byte):NrString;
Function Str2Nr(S : NrString):Word;
Function HexWord(number : Word):HexStr;

{---------------------------------------------------------------------------|
 FileName and path functions:

 CompletePath     Makes sure that the given path is a full-featured dos path
                  including the drive and a terminating backslash.
 CompleteFilename Returns the first matching FileName of a given name
                  specification in the PATH directory.
 ExistPath        Returns true if the given path exists.
 ExistFile        Returns true if the given file exists.
 DeleteFile       Deletes one or more files specified by the FileSpec.
                  Use with care!
 StripPath        Strips the path and returns the FileName and extention
                  only.
|--------------------------------------------------------------------------}

Type Str12 = String[12];
     Str8  = String[8];
     Str4  = String[4];


Procedure CompletePath(Var Path : ComStr);
Procedure CompleteFileName(Path : ComStr;Var FileName : Str12);
Function ExistPath(Path : ComStr):Boolean;
Function ExistFile(FilePath : ComStr):Boolean;
Function DeleteFile(FileSpec : ComStr): Boolean;
Procedure StripPath(Var FileSpec : ComStr);


Implementation

{$IfDef BBSAwear}
 Uses GlobInfo;
{$EndIf}

{---- Conversion procedures -----------------------------------------------}

Function HexWord(number : Word):HexStr;
Const HexNum : Array[0..15] Of Char = '0123456789ABCDEF';
Begin
HexWord:=HexNum[(Hi(Number) And $F0) Shr 4] + HexNum[(Hi(Number) And $0F)]+
         HexNum[(Lo(Number) And $F0) Shr 4] + HexNum[(Lo(Number) And $0F)];
End;


Function S(Num : Word; Len : Byte):NrString;
Var Temp : String[20];
Begin
Str(Num:Len,Temp);
S:=Temp;
End;

Function SL(Num : LongInt; Len : Byte):NrString;
Var Temp : NrString;
Begin
Str(Num:Len,Temp);
SL:=Temp;
End;


Function SF(Num : Word; Len : Byte):NrString;
Var Temp : String[20];
Begin
Str(Num:Len,Temp);
For Len:=1 To Length(Temp) Do
 If Temp[Len]=' '
    Then Temp[Len]:='0';
SF:=Temp;
End;

Function I(Num : Integer; Len : Byte):NRString;
Var Temp : String[20];
Begin
Str(Num:Len,Temp);
I:=Temp;
End;



Function Str2Nr(S : NrString):Word;
Var Temp : Word;
    Err  : Word;
Begin
Val(S,Temp,Err);
If Err<>0
   Then Str2Nr:=0
   Else Str2Nr:=Temp;
End;


{---- String procedures ----------------------------------------------------}

Function MlUpCase(C : Char):Char;
Const HiUpChars : String[9] ='ÜÉâÄÅÇÆÖÑ';
Begin
If (Ord(C)>127) And
   (Pos(C,'üéâäåçæöñ')>0)
   then MlUpCase:=HiUpChars[Pos(C,'üéâäåçæöñ')]
   Else MlUpCase:=UpCase(C);
End;

Function MlDownCase(C : Char):Char;
Const HiLowChars : String[9] = 'üéâäåçæöñ';
Begin
If (Ord(C)>127) And
   (Pos(C,'ÜÉâÄÅÇÆÖÑ')>0)
   then MlDownCase:=HiLowChars[Pos(C,'ÜÉâÄÅÇÆÖÑ')]
   Else Begin
        If C In ['A'..'Z']
           Then MlDownCase:=Chr(Ord(C)+$20)
           Else MlDownCase:=C;
        End;
End;


Function MakeString(Len : Byte; InpChar : Char):String;
Var HStr : String;
Begin
{$IfDef BBSAwear}
  If (GlobalInfo.UseGraphics And GlobalInfo.UseAVATAR)
     Then MakeString:=^Y+InpChar+Char(Len)
     Else Begin
          FillChar(HStr,255,InpChar);
          HStr[0]:=Char(Len);
          MakeString:=HStr;
          End;
{$Else}
  FillChar(HStr,255,InpChar);
  HStr[0]:=Char(Len);
  MakeString:=HStr;
{$EndIf}
End;

Function FormatLine(Line : String):String;
Var C : Byte;
Begin
Line:=DownStr(Line);
Line[1]:=MlUpcase(Line[1]);
For C:=2 To Length(Line) Do
 Begin
 If Not (MlUpcase(Line[C-1]) In ['A'..'Z',#128..#154,#160..#165])
    Then Line[C]:=MlUpcase(Line[C]);
 If Line[C]='_'
    Then Line[C]:=' ';
 End;
FormatLine:=Line;
End;

Function DownStr(Line : String):String;
Var Tel : Byte;
Begin
For Tel:=1 to Length(Line) Do
 Line[Tel]:=MlDownCase(Line[Tel]);
DownStr:=Line;
End;

Function UpStr(St : String):String;
Var Count : Byte;
Begin
For Count:=1 To Length(ST) Do
 ST[Count]:=MlUpcase(St[Count]);
UpStr:=St;
End;

Function Center(CL:String):String;
Var Temp : String;
    Count: Byte;
    Len  : Byte;
Begin
{$IfDef BBSAwear}
  If Not (GlobalInfo.UseGraphics And GlobalInfo.UseAVATAR)
     Then Len:=Length(CL)
     Else Begin
          Len:=0;
          Count:=1;
          While Count<=Length(CL) Do
           Begin
           If CL[Count]=^Y
              Then Begin
                   Inc(Len,Ord(CL[Count+2]));
                   Inc(Count,2);
                   End
              Else Inc(Len);
           Inc(Count);
           End
          End;
  Temp:=MakeString((GlobalInfo.ScreenWidth-Len) Div 2,' ');
  Center:=Temp+CL;
{$Else}
  Temp:=MakeString((80-Length(CL)) Div 2,' ');
  Center:=Temp+CL;
{$EndIf}
End;

Function FindToken(Var Line : String;Delimiters : Str40):String;
Var HStr : String;
    Tel  : Byte;
Begin
HStr:='';
Tel:=1;
While (Tel<=Length(Line)) And
      Not Boolean(Pos(UpCase(Line[Tel]),Delimiters)) Do
 Begin
 HStr:=HStr+Line[Tel];
 Inc(Tel);
 End;
FindToken:=HStr;
Delete(Line,1,Tel);
End;

Procedure SimplifyDelimiters(Var Line : String;Delimiters : Str40);
Var DelTel  : Byte;
Begin
DelTel:=1;
Repeat
If Boolean(Pos(Line[DelTel],Delimiters))
   And Boolean(Pos(Line[DelTel+1],Delimiters))
   Then Delete(Line,DelTel,1)
   Else Inc(DelTel);
Until DelTel>=(Length(Line)-1);
End;

Procedure SkipLeadingSpaces(Var Line : String);
Var Tel : Byte;
Begin
Tel:=1;
While (Tel<=Byte(Line[0])) And (Line[Tel]=' ') Do
 Inc(Tel);
Delete(Line,1,Tel-1);
End;

Procedure DeleteTrailingSpaces(Var Line : String);
Var Tel : Byte;
Begin
Tel:=Byte(Line[0]);
While (Tel>0) And (Line[Tel]=' ') Do
 Dec(Tel);
Delete(Line,Tel+1,255);
End;

Procedure DeleteNoise(Var Line : String;Noise : Str40);
Var NoiseTel : Byte;
    PosNoise : Byte;
Begin
For NoiseTel:=1 To Length(Noise) Do
 Begin
 Repeat
 PosNoise:=Pos(Noise[NoiseTel],Line);
 If PosNoise>0
    Then Delete(Line,PosNoise,1);
 Until PosNoise=0;
 End;
End;

Procedure ReplaceToken(Var Line : String;Tok1,Tok2 : String);
Var Tok1Pos : Byte;
    HStr    : String;
Begin
HStr:=Line;
HStr:=UpStr(HStr);
Tok1:=UpStr(Tok1);
Repeat
 Tok1Pos:=Pos(Tok1,HStr);
 If Tok1Pos>0
    Then Begin
         Delete(Line,Tok1Pos,Length(Tok1));
         Insert(Tok2,Line,Tok1Pos);
         HStr:=Line;
         HStr:=UpStr(HStr);
         End;
Until Tok1Pos=0;
End;


{---- Commandline procedures -----------------------------------------------}

Function GrabParameter(Key : IndentString):ComStr;
Var PCount : Byte;
    PKey   : Char;
    PStr   : ComStr;
Begin
Key:=UpStr(Key);
Pcount:=0;
PKey:='-';
PStr:='';
Repeat
 Inc(PCount);
 PStr:=UpStr(ParamStr(PCount));
Until (PCount>ParamCount) Or (Pos(Key,PStr)=2);

If Pcount>ParamCount
   Then GrabParameter:=''
   Else GrabParameter:=Copy( PStr,Length(Key)+2,Length(PStr)-Length(Key));
End;

Function ExistParameter(Key : IndentString):Boolean;
Var PCount : Byte;
    PKey   : Char;
    PStr   : ComStr;
Begin
Key:=UpStr(Key);
Pcount:=0;
PKey:='-';
PStr:='';
Repeat
 Inc(PCount);
 PStr:=UpStr(ParamStr(PCount));
Until (PCount>ParamCount) Or (Pos(Key,PStr)=2);
ExistParameter:=PCount<=ParamCount;
End;



{---- Timing procedures ---------------------------------------------------}


Const MonthList : Array[1..12] Of String[3] =
       ('Jan','Feb','Mar','Apr','May','Jun',
        'Jul','Aug','Sep','Oct','Nov','Dec');

      DayList   : Array[0..6] Of String[10] =
       ('Sunday','Monday','Tuesday','Wednesday',
       'Thursday','Friday','Saturday');



Function TimeStamp:TimeString;
Var Year,Month,Day,
    Hour,Minute,Seconds     : Word;
    Dof                     : Word;
    Dum                     : Word;
    OutStr                  : TimeString;
    Step                    : Byte;
Begin
GetTime(Hour,Minute,Seconds,Dum);
GetDate(Year,Month,Day,DOF);

OutStr:= DayList[DOF]+', '+
         SF(Day,2)          +' '+
         MonthList[Month] +' '+
         S(Year,4)         +'  '+
         SF(Hour,2)         +':'+
         SF(Minute,2)       +':'+
         SF(Seconds,2);

TimeStamp:=OutStr;
End;


{---- Filename/path functions --------------------------------------------}

Procedure CompletePath(Var Path : ComStr);
Begin
Path:=FExpand(Path);
If (Path[Length(Path)]<>'\') And
   (Path[Length(Path)]<>':')
   Then Path:=Path+'\';
End;

Procedure CompleteFileName(Path : ComStr;Var FileName : Str12);
Var SR : SearchRec;
Begin
FindFirst(Path+FileName,Archive,SR);
If DosError=0
   Then FileName:=Sr.Name
   Else FileName:='';
End;

Function ExistPath(Path : ComStr):Boolean;
Var Zoek : SearchRec;
Begin
FindFirst(Path+'*.*',AnyFile,Zoek);
ExistPath:=(DosError<>3) And (Path<>'');
End;

Function ExistFile(FilePath : ComStr):Boolean;
Var Zoek: SearchRec;
Begin
If FilePath<>''
   Then Begin
        FindFirst(FilePath,AnyFile,Zoek);
        ExistFile:=(DosError=0);
        End
   Else ExistFile:=False;
End;

Function DeleteFile(FileSpec : ComStr): Boolean;
Var Search : SearchRec;
    Path   : ComStr;
    Tel    : Byte;
    Inp    : File;
Begin
DeleteFile:=True;
Tel:=Length(FileSpec);
While (Tel>0) And Not (FileSpec[Tel] In ['\',':']) Do
 Dec(Tel);
Path:=Copy(FileSpec,1,Tel);
FindFirst(FileSpec,Archive,Search);
While DosError=0 Do
 Begin
 Assign(Inp,Path+Search.Name);
 Erase(Inp);
 If IoResult<>0
    Then Begin
         DeleteFile:=False;
         Exit;
         End;
 FindNext(Search);
 End;
End;

Procedure StripPath(Var FileSpec : ComStr);
Var Dum  : String;
    Name : Str8;
    Ext  : Str4;
Begin
FSplit(FileSpec,Dum,Name,Ext);
FileSpec:=Name+Ext;
End;

End.