Unit Genstr;

Interface
 uses crt,dos,io,protcomm,swapit,records;

 Function  Valu(q:string):Integer;
 procedure replaceit(var c:string;code:string;wi:string);
 Procedure ClearString(Var s:String);
 Procedure DisplayADF(Filename : String);
 Function  Uppercase(Str : String) : String;
 Function  Match(Str1, Str2 : String) : Boolean;
 Function  Strr (N : LongInt) : string;
 Function  FileExist(FileName : String) : Boolean;
 Function  DeleteFile(FileName : string) : integer;
 Procedure Make_Directory (Directory: String);
 function  Direxist(d:string): boolean;
 Procedure VGA_SetBlink(BlinkMode : Boolean);
 Function  AltKey: Boolean;
 Function  LeadingZero(W : Word) : String;
 Procedure Set8x16Font;
 Function  Time: string; (* Returns the current Time *)
 Function  Date: string; (* Returns the current Date *)
 Function  TimeTill(Time: word): word; (* Finds the amount of time until Time *)
 Function  TimeBetween(Time1, Time2: word): word;(* Finds the amount of time between Time1 and Time2 *)
 Function  Padstring(Outp : String;Number : Byte): String;
 Function  Strip (L, C: Char; Str: String): String;
 Function  StrToInt (Str: String): LongInt;
 Function  strlong(l:longint):string;
 procedure fillit(var f;x:longint);
 function  doexec(s:String):byte;
 Procedure ClrDir ( path : pathStr );
 procedure killfile(s:string);
 procedure changedir (s:String);
 function  thefilesize(s:string):longint;
 procedure beep;

Implementation

uses barinfo;

 procedure beep;
 begin
Sound(220);        { Beep }
Delay(200);        { For 200 ms }
NoSound;           { Relief! }

 end;
function  thefilesize(s:string):longint;
var f:file;
begin
assign(f,s);
{$i-} reset(F,1); {$i+}
if ioresult<>0 then thefilesize:=0;
thefilesize:=filesize(f);
close(F);
end;


procedure changedir (s:String);
begin
if s[length(s)]='\' then dec(s[0]);
if direxist(s) then chdir(s);
end;

procedure killfile(s:string);
var f:file;
begin
assign(f,s);
{$i-} reset(f,1); {$i+}
if ioresult<>0 then exit;
erase(f);
end;

Procedure ClrDir ( path : pathStr );
Var FileInfo : searchRec;
    f        : File;
    path2    : pathStr;
    s        : String;
begin
      if path[length(path)]='\' then dec(path[0]);
      FindFirst ( path + '\*.*', AnyFile, FileInfo );
      While DosError = 0 Do
      begin if (FileInfo.Name[1] <> '.') and (FileInfo.attr <> VolumeId) then
              if ( (FileInfo.Attr and Directory) = Directory ) then
                begin Path2 := Path + '\' + FileInfo.Name;
                      ClrDir ( path2 );
                end
            else
              if ((FileInfo.Attr and VolumeID) <> VolumeID) then begin
                Assign ( f, path + '\' + FileInfo.Name );
                Erase ( f );
              end;
            FindNext ( FileInfo );
      end;
      if (DosError = 18) and not ((Length(path) = 2)
                                   and ( path[2] = ':')) then
        RmDir ( path );
end;

function doexec(s:String):byte;
type screen=array[1..4000] of byte;
var error: Byte;
    path : string;
    x    : byte;
    temp : string[60];
    v    : screen;
    xx,yy: byte;
begin
xx:=wherex;
yy:=wherey;
window(1,1,80,25);
{new(v);}
fillchar(v,sizeof(v),#0);
move(mem[$b800:0000],v,4000);
textattr:=7;
CLRSCR;
fastsetback(1,$1020);
gotoxy(1,1);
temp:=s;
textcolor(15);
textbackground(1);
writeln('Executing - ',temp);
textattr:=7;
writeln;
temp:='';
x:=pos(' ',s);
path:='';
temp:=copy(s,1,x);
path:=path+temp;
delete(s,1,x);
if swap=false then
begin
swapvectors;
exec(path,s);
swapvectors;
end
else
             begin
             InitExecSwap(HeapPtr,config.lucid_dir+'LUCID.SWP');
             ExecWithSwap(Path,s);
             ShutdownExecSwap;
             end;
x:=dosexitcode;
doexec:=x;
textattr:=7;
CLRSCR;
move(v,mem[$b800:0000],4000);
{dispose(V);}
gotoxy(xx,yy);
infobar(currentbar,'');
end;

  procedure fillit(var f;x:longint);
  begin
  fillchar(f,x,#0);
  end;

procedure replaceit(var c:string;code:string;wi:string);
  var x:integer;
  begin
  x:=pos(code,c);
  if x>0 then begin
              delete(c,x,length(code));
              insert(wi,c,x);
              end;
  end;

  Function strlong(l:longint):string;
    Var q:string;
    Begin
      Str(l,q);
      strlong:=q
    End;

Function StrToInt (Str: String): LongInt;
Var
  code : Integer;
  Temp : LongInt;
Begin
  If Length (Str) = 0 Then
    StrToInt := 0
  Else
  Begin
    Val (Str, temp, code);
    If code = 0 Then
      StrToInt := temp
    Else
      StrToInt := 0;
  End;
End;

Function Padstring(Outp : String;Number : Byte): String;
Var X : Byte;
Begin
 For X := 1 to (Number - Length(Outp)) do Outp := Outp + ' ';
 Padstring := Outp;
End;

Function Strip (L, C: Char; Str: String): String;
Var
  I :  Byte;
Begin
  Case upcase (L) Of
    'L' :
          Begin       {Left}
            While (Str [1] = C) And (Str [0] <> #0) do
              Delete (Str, 1, 1);
          End;
    'R' :
          Begin       {Right}
            While (Str [Length (Str) ] = C) And (Str [0] <> #0) do
              Dec (Str [0]);
          End;
    'B' :
          Begin       {Both left and right}
            While (Str [1] = C) And (Str [0] <> #0) do
              Delete (Str, 1, 1);
            While (Str [Length (Str) ] = C) And (Str [0] <> #0)  do
              Dec (Str [0]);
          End;
    'A' :
          Begin       {All}
            I := 1;
            Repeat
              If (Str [I] = C) And (Str [0] <> #0) Then
                Delete (Str, I, 1)
              Else
                Inc (I);
            Until (I > Length (Str) ) Or (Str = '');
          End;
  End;
  Strip := Str;
End;  {Strip}

Function ShiftState: Byte;
Var Regs: Registers;
Begin
  Regs.Ah:=2;
  Intr($16, Regs);
  ShiftState:=Regs.Al;
End;

Function AltKey: Boolean;
Begin
 AltKey := (ShiftState and 8)<>0;
End;

Function LeadingZero(W : Word) : String;
Var S : String;
Begin
 Str(w:0,S);
 If Length(s) = 1 then S := '0'+S;
 LeadingZero := S;
End;

PROCEDURE VGA_SetBlink      (BlinkMode : BOOLEAN); ASSEMBLER;
ASM
 MOV    DX,$03DA
 IN     AL,DX
 MOV    DX,$03C0
 MOV    AL,10h+20h
 OUT    DX,AL
 MOV    DX,$03C1
 IN     AL,DX
 MOV    DX,$03C0
 CMP    [BlinkMode],TRUE
 JE     @SetBlinkBit
@BlinkOff:
 AND    AL,NOT 008h
 JMP    @SetBlinkBit
@BlinkOn:
 OR     AL,008h
@SetBlinkBit:
 OUT    DX,AL
END;

Procedure Set8x16Font;assembler;
Asm
 mov dx,03c4h;mov ax,0100h;out dx,ax;mov dx,03c4h;mov ax,0301h;out dx,ax
 mov dx,03c2h;mov al,063h;out dx,al;mov dx,03c4h;mov ax,0300h;out dx,ax
 mov dx,03d4h;mov ax,4f09h;out dx,ax;
end;

Procedure DisplayADF(Filename : String);
Var    X : word;
 NumRead : Integer;
       F : File;
 ADF_Version  : Char;
 ADF_Pallette : Array[0..63,1..3] of Byte;
 ADF_Font     : Array[1..4096] of Char;
 ADF_Handle   : File;
 Regs : Registers;
Begin
 VGA_Setblink(False);
 Set8x16Font;
 asm mov ah,1;mov cx,2000h; int 10h end;  { No Cursor }
 Assign(F,Filename);
 Reset(F,1);
 Seek(F,0);
 BlockRead(F,ADF_Version,1);
 BlockRead(F,ADF_Pallette,Sizeof(ADF_Pallette));
 BlockRead(F,ADF_Font[1],4096);
 For X := 0 to 63 do
  Begin
   Port[$3c8] := X;
   Port[$3c9] := ADF_Pallette[X,1];
   Port[$3c9] := ADF_Pallette[X,2];
   Port[$3c9] := ADF_Pallette[X,3];
  End;
 Seek(F,4289);
 regs.bx:= 4096;
 regs.es:= seg(ADF_Font);
 regs.bp:= ofs(ADF_Font);
 regs.ax:= 4368;
 regs.cx:= 256;
 regs.dx:= 0;
 Intr(16, Regs);
 asm mov ah,1;mov cx,2000h; int 10h end;  { No Cursor }
 BlockRead(F,Mem[$b800:0000],Filesize(F)-4289);
 Close(F);
End;


Function valu(q:string):Integer;
Var i,s,pu:Integer;
    r:Real;
Begin
 valu:=0;
 If Length(q)=0 Then exit;
 If Not(q[1] In ['0'..'9','-']) Then exit;
 If Length(q)>5 Then exit;
 Val(q,r,s);
 If s<>0 Then exit;
 If (r<=32767.0) And (r>=-32767.0) Then valu:=Round(r)
End;

Procedure ClearString(Var s:String);
Begin
 FillChar(s,sizeof(s),0);
End;

Function Uppercase(Str : String) : String;
Var X : Byte;
Begin
 For X := 1 to Length(Str) do Str[X] := Upcase(Str[X]);
 Uppercase := Str;
End;

Function match(Str1, Str2 : String) : Boolean;
begin
 uppercase(str1);
 uppercase(str2);
 match := (Str1 = Str2);{CompareStr(Str1,Str2);}
end;

function Time: string;
var H, M, S, Hund: word;
    PM: char;
    Min: string;
begin
  PM:='a';
  GetTime(h,m,s,hund);
  if h > 12 then begin h := h - 12; PM:='p'; end;
  if h = 0 then h := 12;
  if m < 10 then min := '0'+Strr(m) else min := strr(m);
  Time:=Strr(h)+':'+min+pm;
end;

function Date: string;
var Day, Month, Year, DOW: word;
    temp, temp2: string;
begin
  GetDate(Year, Month, Day, DOW);
  temp2:=Strr(year);
  temp[1]:=temp2[3];
  temp[2]:=temp2[4];
  temp[0]:=chr(2);
  Date:=Strr(month)+'/'+Strr(Day)+'/'+temp;
end;

function Timer: word; assembler;
asm
 mov ah, 2Ch
 int 21h
 mov ax, cx
 mov bx, ax
 mov cl, 8
 shr ax, cl
 mov cx, 60
 mul cx
 xor bh, bh
 add ax, bx
end;

function TimeTill(Time: word): word;
var w: word;
begin
  w := timer;
  if time < w then
    time := time + 1440;
  TimeTill := time - w;
end;

function TimeBetween(Time1, Time2: word): word;
begin
  if Time2 < Time1 then
    Time2 := Time2 + 1440;
  TimeBetween := Time2 - Time1;
end;


Function Strr (N : LongInt) : string;
Var Q : string;
Begin
  Str (N, Q);
  Strr := Q;
End;

Function DeleteFile(FileName : string) : integer; assembler;
Asm
  push ds
  lds si,FileName
  inc byte ptr [si]
  mov bl,byte ptr [si]
  xor bh,bh
  mov dx,si
  inc dx
  mov byte ptr [si+bx],0
  mov ah,41h
  int 21h
  jc  @error
  xor ax,ax
@error:
  dec byte ptr [si]
  pop ds
End; { DeleteFile }

Function FileExist(FileName : String) : Boolean; ASSEMBLER;
Asm
  PUSH DS          {Save DS                         }
  LDS  SI,Filename {DS:SI => Filename               }
  XOR  BX,BX       {Clear BX                        }
  MOV  BL,[SI]     {BX = Length(Filename)           }
  INC  SI          {DS:SI => Filename[1]            }
  MOV  DX,SI       {DS:DX => Filename[1]            }
  MOV  [SI+BX],BH  {Append Ascii 0 to Filename      }
  MOV  AX,4300h    {Get Attribute Function Code     }
  INT  21h         {Get File Attributes             }
  MOV  AL,BH       {Default Result = FALSE          }
  ADC  CL,CL       {Attribute * 2 + Carry Flag      }
  AND  CL,31h      {Directory or VolumeID or Failed }
  JNZ  @@Done      {Yes - Exit                      }
  INC  AL          {No - Change Result to TRUE      }
@@Done:
  POP  DS          {Restore DS                      }
End; {FileExists}


Procedure Make_Directory (Directory: String);
begin
if Directory[length(Directory)]='\' then dec(Directory[0]);
if direxist(Directory)=false then mkdir(Directory);
end;

function direxist(d:string): boolean;
  var
    f   : file;
    attr: word;
    len : byte;
  begin
    len:= length(d);
    if (d[len] = '\') then dec(d[0]);
    d:= d + '\.';
    assign(f,d);
    getfattr(f,attr);
    direxist := ((attr and directory)=directory);
  end;

begin
end.

