home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Black Box 4
/
BlackBox.cdr
/
editors
/
ae.arj
/
AE1.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-03-08
|
22KB
|
611 lines
unit AE1 ;
{$B-}
{$I-}
{$S+}
{$V-}
{-----------------------------------------------------------------------------}
{ This unit contains all basic procedures }
{-----------------------------------------------------------------------------}
interface
uses Crt,Dos,AE0 ;
function UpperCase (S:string) : string ;
function WordToString (Num:word ; Len:integer) : string ;
function Wildcarded (Name : PathStr) : boolean ;
function Exists (FileName : PathStr) : boolean ;
procedure MoveToScreen (var Source,Dest ; Len : word) ;
procedure MoveFromScreen (var Source,Dest ; Len : word) ;
procedure SaveArea (X1,Y1,X2,Y2:word ; var MemPtr:ScreenBlockPtr) ;
procedure RestoreArea (X1,Y1,X2,Y2:word ; var MemPtr:ScreenBlockPtr) ;
function Grow (Index:word ; Chars:word) : boolean ;
procedure Shrink (Index:word ; Chars:word) ;
function GetCursor : byte ;
procedure SetCursor (Cursor : byte) ;
procedure CursorTo (X,Y : byte) ;
procedure WarningBeep ;
function ReadKeyNr : word ;
procedure SetBottomLine (LineText:string) ;
procedure Message (Contents:string) ;
procedure ErrorMessage (ErrorNr:byte) ;
procedure Pause ;
procedure CheckDiskError ;
procedure PutFrame (X1,Y1,X2,Y2 : byte ; Border : string) ;
procedure ClearArea (X1,Y1,X2,Y2 : byte) ;
procedure ClearWorkspace (Wsnr:byte) ;
procedure ClearKeyBuffer ;
implementation
{-----------------------------------------------------------------------------}
{ Converts all lower case letters in a string to upper case. }
{-----------------------------------------------------------------------------}
function UpperCase (S : string) : string ;
var Counter : word ;
begin
for Counter := 1 to Length(S) do S[Counter] := UpCase (S[Counter]) ;
UpperCase := S ;
end ;
{-----------------------------------------------------------------------------}
{ Converts an expression of type word to a string }
{ if Len < 0 then string is adjusted to the left; string length is <Len> }
{ if Len > 0 then string is adjusted to the right; string length is <-Len> }
{ if Len = 0 then string is not adjusted; string has minimum length }
{-----------------------------------------------------------------------------}
function WordToString (Num:word ; Len:integer) : string ;
var S : string[5] ;
begin
if Len > 0
then Str (Num:Len,S)
else begin
Str (Num,S) ;
Len := - Len ;
if (Len > 0) and (Length(S) < Len)
then begin
FillChar (S[Length(S)+1],Len-Length(S),' ') ;
S[0] := Chr(Len) ;
end ;
end ;
WordToString := S ;
end ;
{-----------------------------------------------------------------------------}
{ Deletes all spaces on the left of a string. }
{-----------------------------------------------------------------------------}
function TrimLeft (S:string) : string ;
begin
while (Length(S) >0) and (S[1] = ' ') do Delete (S,1,1) ;
TrimLeft := S ;
end ;
{-----------------------------------------------------------------------------}
{ Indicates whether a filename contains wildcard characters }
{-----------------------------------------------------------------------------}
function Wildcarded (Name : PathStr) : boolean ;
begin
Wildcarded := (Pos('*',Name) <> 0) or (Pos('?',Name) <> 0) ;
end ;
{-----------------------------------------------------------------------------}
{ Returns True if the file <FileName> exists, False otherwise. }
{-----------------------------------------------------------------------------}
function Exists (FileName : PathStr) : boolean ;
var SR : SearchRec ;
begin
FindFirst (FileName,ReadOnly + Hidden + SysFile,SR) ;
Exists := (DosError = 0) and (not Wildcarded(Filename)) ;
end ;
{-----------------------------------------------------------------------------}
{ Moves <Len> bytes of memory to screen memory. }
{ From the TCALC spreadsheet program delivered with every copy of Turbo }
{ Pascal 5.5 }
{-----------------------------------------------------------------------------}
procedure MoveToScreen (var Source,Dest ; Len : word) ;
external ;
{-----------------------------------------------------------------------------}
{ Moves <Len> bytes of screen memory to memory. }
{ From the TCALC spreadsheet program delivered with every copy of Turbo }
{ Pascal 5.5 }
{-----------------------------------------------------------------------------}
procedure MoveFromScreen (var Source,Dest ; Len : word) ;
external ;
{$L TCMVSMEM.OBJ }
{-----------------------------------------------------------------------------}
{ Saves the contents of a rectangular part of the screen to memory. }
{ Upper left corner is (X1,Y1), lower right is (X2,Y2) }
{ Also claims the amount of memory needed. }
{-----------------------------------------------------------------------------}
procedure SaveArea (X1,Y1,X2,Y2:word ; var MemPtr:ScreenBlockPtr) ;
var LineLen : byte;
Index : word;
Counter : byte;
begin
LineLen := X2 - X1 + 1;
GetMem (MemPtr,LineLen*(Y2-Y1+1)*2) ;
Index := 1 ;
for Counter := Y1 to Y2 do
begin
MoveFromScreen (DisplayPtr^[Counter,X1],MemPtr^[Index],LineLen*2);
Inc (Index,LineLen)
end;
{$IFDEF DEVELOP }
if MemAvail < MinMemAvail
then MinMemAvail := MemAvail ;
{$ENDIF }
end;
{-----------------------------------------------------------------------------}
{ Reverse of SaveArea }
{-----------------------------------------------------------------------------}
procedure RestoreArea (X1,Y1,X2,Y2:word ; var MemPtr:ScreenBlockPtr) ;
var LineLen : byte;
Index : word;
Counter : byte;
begin
LineLen := X2 - X1 + 1;
Index := 1;
for Counter := Y1 to Y2 do
begin
MoveToScreen (MemPtr^[Index],DisplayPtr^[Counter,X1],LineLen*2);
Inc (Index,LineLen)
end;
FreeMem (MemPtr,LineLen*(Y2-Y1+1)*2) ;
end;
{-----------------------------------------------------------------------------}
{ Expands the text in the buffer of the current workspace at position }
{ <Index> by <Chars> characters. Function result is False if there is not }
{ enough space left, True otherwise. }
{ Index values of Mark and in position stack are adapted }
{-----------------------------------------------------------------------------}
function Grow (Index:word ; Chars:word) : boolean ;
var Counter : byte ;
begin
with Workspace[CurrentWsnr] do
if Chars > (WsBufSize - BufferSize)
then begin
{ not enough space }
ErrorMessage (1) ;
Grow := False ;
end
else begin
{ move rest of text forward }
Move (Buffer^[Index],Buffer^[Index+Chars],BufferSize-Index+1) ;
Inc (BufferSize,Chars) ;
{ adapt Mark and position stack }
if Mark >= Index then Inc (Mark,Chars) ;
for Counter := 1 to PosStackpointer do
begin
if PosStack[Counter] >= Index
then Inc (PosStack[Counter],Chars) ;
end ;
ChangesMade := True ;
Grow := True ;
end ;
end ;
{-----------------------------------------------------------------------------}
{ Deletes <Chars> characters from the buffer in the current workspace, }
{ starting on position <Index>. }
{ Index values of Mark and in position stack are adapted }
{-----------------------------------------------------------------------------}
procedure Shrink (Index:word ; Chars:word) ;
var Counter : word ;
begin
with Workspace[CurrentWsnr] do
begin
{ move rest of text backward }
Move (Buffer^[Index+Chars],Buffer^[Index],BufferSize-(Index+Chars)+1) ;
Dec (BufferSize,Chars) ;
{ adapt Mark }
if (Mark >= Index)
then begin
if (Mark < (Index+Chars))
then Mark := Inactive
else Dec (Mark,Chars) ;
end ;
{ adapt position stack }
for Counter := 1 to PosStackpointer do
if (PosStack[Counter] >= Index)
then begin
if (PosStack[Counter] < (Index+Chars))
then PosStack[Counter] := Index
else Dec (PosStack[Counter],Chars) ;
end ;
ChangesMade := True ;
end ;
end ;
{-----------------------------------------------------------------------------}
{ Returns the current cursor type }
{-----------------------------------------------------------------------------}
function GetCursor : byte ;
var Reg : registers ;
begin
with Reg do
begin
AH := 3 ;
BH := 0 ;
{ call BIOS interrupt }
Intr ($10,Reg) ;
case CX of
$0607,$0B0C : GetCursor := UnderLineCursor ;
$0507,$090C : GetCursor := HalfBlockCursor ;
$0807,$0D0C : GetCursor := BlockCursor ;
$2000 : GetCursor := Inactive ;
$2001 : GetCursor := NoBlinkCursor ;
else GetCursor := UnderLineCursor ;
end ; { of case }
end ; { of with }
end ;
{-----------------------------------------------------------------------------}
{ Sets a new cursor }
{-----------------------------------------------------------------------------}
procedure SetCursor (Cursor : byte) ;
var Reg : registers ;
ScrEl : ScreenElement ;
begin
if Config.Setup.CursorType = NoBlinkCursor
then begin
{ remove NoBlinkCursor from old position: reset attribute }
ScrEl := ScreenElement (DisplayPtr^[WhereY,WhereX]) ;
ScrEl.attribute := OldCursorPosAttr ;
DisplayPtr^[WhereY,WhereX] := word (ScrEl) ;
end ;
with Reg do
begin
AH := 1 ;
BH := 0 ;
{ monochrome and color cards require different settings for cursor shape }
case Cursor of
Inactive : CX := $2000 ;
UnderLineCursor : if Colorcard then CX := $0607 else CX := $0B0C ;
HalfBlockCursor : if Colorcard then CX := $0507 else CX := $090C;
BlockCursor : if Colorcard then CX := $0807 else CX := $0D0C ;
NoBlinkCursor : CX := $2001 ;
end ; { of case }
{ call BIOS interrupt }
Intr ($10,Reg) ;
end ; { with }
if Cursor = NoBlinkCursor
then begin
{ put NoBlinkCursor on new position }
ScrEl := ScreenElement (DisplayPtr^[WhereY,WhereX]) ;
{ save original attribute }
OldCursorPosAttr := ScrEl.attribute ;
{ set cursor attribute }
with ScreenColorArray[Config.Setup.ScreenColors] do
ScrEl.Attribute := CursorAttr ;
DisplayPtr^[WhereY,WhereX] := word (ScrEl) ;
end ;
end ;
{-----------------------------------------------------------------------------}
{ Positions the cursor at (X,Y) }
{-----------------------------------------------------------------------------}
procedure CursorTo (X,Y : byte) ;
var ScrEl : ScreenElement ;
begin
if Config.Setup.CursorType = NoBlinkCursor
then begin
{ remove NoBlinkCursor from old position: reset attribute }
ScrEl := ScreenElement (DisplayPtr^[WhereY,WhereX]) ;
ScrEl.attribute := OldCursorPosAttr ;
DisplayPtr^[WhereY,WhereX] := word (ScrEl) ;
end ;
GotoXY (X,Y) ;
if Config.Setup.CursorType = NoBlinkCursor
then begin
{ put NoBlinkCursor on new position }
ScrEl := ScreenElement (DisplayPtr^[Y,X]) ;
{ save original attribute }
OldCursorPosAttr := ScrEl.attribute ;
{ set cursor attribute }
with ScreenColorArray[Config.Setup.ScreenColors] do
ScrEl.Attribute := CursorAttr ;
DisplayPtr^[Y,X] := word (ScrEl) ;
end ;
end ;
{-----------------------------------------------------------------------------}
{ Produces a low beep trough the speaker, unless inhibited by Setup }
{-----------------------------------------------------------------------------}
procedure WarningBeep ;
begin
if Config.Setup.SoundBell
then begin
Sound (110) ;
Delay (100) ;
NoSound ;
end ;
end ;
{-----------------------------------------------------------------------------}
{ Waits until a key on the keyboard is pressed and returns its key number. }
{ Control keys (cursor keys, function keys etc.) are translated to numbers }
{ above 255. }
{-----------------------------------------------------------------------------}
function ReadKeyNr : word ;
var Regs : registers ;
begin
with Regs do
begin
AH := 0 ;
Intr ($16,Regs) ;
{ AL now contains the ASCII value of the key, AH the scan code }
case AL of
0 : if AH = 3 then ReadKeyNr := 0 { ^@ }
else ReadKeyNr := 256 + AH ;
8 : if AH = 14 then ReadKeyNr := BkspKey
else ReadKeyNr := 8 ; { ^H }
9 : if AH = 15 then ReadKeyNr := TabKey
else ReadKeyNr := 9 ; { ^I }
10 : if AH = 28 then ReadKeyNr := CtrlReturnKey
else ReadKeyNr := 10 ; { ^J }
13 : if AH = 28 then ReadKeyNr := ReturnKey
else ReadKeyNr := 13 ; { ^M }
27 : if AH = 1 then ReadKeyNr := EscapeKey
else ReadKeyNr := 27 ; { ^[ }
else ReadKeyNr := AL ;
end ; { of case }
end ; { of with }
end ;
{-----------------------------------------------------------------------------}
{ Puts a line of text on the last line of the screen. }
{ Writes directly into video memory. }
{-----------------------------------------------------------------------------}
procedure SetBottomLine (LineText:string) ;
var ScrEl : ScreenElement ;
Col : byte ;
NewBottomLine : array[1..ColsOnScreen] of ScreenElement ;
begin
{ fill rest of LineText with spaces until length = ColsOnScreen }
for Col := (Length(LineText)+1) to ColsOnScreen do
LineText[Col] := ' ' ;
LineText[0] := char(ColsOnScreen) ;
{ set attribute }
ScrEl.Attribute := ScreenColorArray[Config.Setup.ScreenColors].StatusAttr ;
{ fill bottom line of screen }
for Col := 1 to ColsOnScreen do
begin
ScrEl.Contents := LineText[Col] ;
NewBottomLine[Col] := ScrEl ;
end ;
MoveToScreen (NewBottomLine[1],DisplayPtr^[LinesOnScreen,1],2*ColsOnScreen) ;
end ;
{-----------------------------------------------------------------------------}
{ Produces a message on the last line of the screen and sets MessageRead }
{-----------------------------------------------------------------------------}
procedure Message (Contents:string) ;
begin
SetBottomLine (Contents) ;
MessageRead := (Length(Contents) = 0) ;
end ;
{-----------------------------------------------------------------------------}
{ Produces an error beep (if allowed by Setup), writes an error message }
{ corresponding to the error number, on the last screen line and waits }
{ until the Escape key is pressed. }
{ If any macros are running, they are canceled. }
{-----------------------------------------------------------------------------}
procedure ErrorMessage (ErrorNr:byte) ;
var ErrorText : string[ColsOnScreen] ;
begin
if Config.Setup.SoundBell
then begin
Sound(880) ;
Delay(100) ;
NoSound ;
end ;
case ErrorNr of
1 : ErrorText := 'Not enough memory' ;
4 : ErrorText := 'Block too large for paste buffer' ;
5 : ErrorText := 'No block defined' ;
6 : ErrorText := 'Maximum macro length reached. End of define mode' ;
7 : ErrorText := 'File too large. Only partially read' ;
8 : ErrorText := 'File not found' ;
9 : ErrorText := 'Cyclic macro definition. Key ignored' ;
10 : ErrorText := 'Too many macros nested. Execution canceled' ;
11 : ErrorText := 'Not in word wrap mode' ;
12 : ErrorText := 'Position stack full' ;
13 : ErrorText := 'Position stack empty' ;
14 : case DosError of
2 : ErrorText := 'Can not find COMMAND.COM ' ;
8 : ErrorText := 'Not enough memory to execute DOS command' ;
else ErrorText := 'DOS error '+WordToString(DosError,2) ;
end ; { of case }
15 : ErrorText := 'String not found' ;
16 : ErrorText := 'Illegal file name' ;
17 : case DiskError of
2 : ErrorText := 'File not found' ;
3 : ErrorText := 'Path not found' ;
5 : ErrorText := 'File acces denied' ;
101 : ErrorText := 'Disk write error' ;
150 : ErrorText := 'Disk is write-protected' ;
152 : ErrorText := 'Drive not ready' ;
159 : ErrorText := 'Printer out of paper' ;
160 : ErrorText := 'Device write fault' ;
else ErrorText := 'I/O error ' + WordToString (DiskError,0) ;
end ; { of case }
end ; { of case }
SetBottomLine (ErrorText+' (press Esc)') ;
repeat until ReadKeyNr = EscapeKey ;
if MacroStackpointer <> Inactive
then begin
MacroStackpointer := Inactive ;
Message ('Macro execution canceled') ;
end
else Message ('') ;
end ;
{-----------------------------------------------------------------------------}
{ Like the DOS batch command, Pause displays the message 'Press any key to }
{ continue' and then waits until a key is pressed. }
{-----------------------------------------------------------------------------}
procedure Pause ;
var DummyKey : word ;
begin
SetBottomLine ('Press any key to continue') ;
DummyKey := ReadKeyNr ;
EscPressed := (DummyKey = EscapeKey) ;
SetBottomLine ('') ;
end ;
{-----------------------------------------------------------------------------}
{ Reads the result of the last I/O operation into the DiskError variable }
{ and produces an error message if an error has occurred. }
{-----------------------------------------------------------------------------}
procedure CheckDiskError ;
begin
DiskError := IOResult ;
if DiskError <> 0 then ErrorMessage (17) ;
end ;
{-----------------------------------------------------------------------------}
{ Draws a frame on the text screen between (X1,Y1) and (X2,Y2) }
{-----------------------------------------------------------------------------}
procedure PutFrame (X1,Y1,X2,Y2 : byte ; Border : string) ;
var i : byte ;
begin
CursorTo (X1,Y1) ; Write (Border[1]) ; { upper left corner }
for i := Succ(X1) to Pred(X2) do Write (Border[2]) ; { upper side }
Write (Border[3]) ; { upper right corner }
for i := Succ(Y1) to Pred(Y2) do
begin
CursorTo (X1,i) ; Write (Border[8]) ; { left side }
CursorTo (X2,i) ; Write (Border[4]) ; { right side }
end ;
CursorTo (X1,Y2) ; Write (Border[7]) ; { lower right corner }
for i := Succ(X1) to Pred(X2) do Write (Border[6]) ; { lower side }
Write (Border[5]) ; { lower left corner }
end ;
{-----------------------------------------------------------------------------}
{ Clears a rectangular screen area between (X1,Y1) and (X2,Y2). }
{-----------------------------------------------------------------------------}
procedure ClearArea (X1,Y1,X2,Y2 : byte) ;
var OldWindMax,OldWindMin : word ;
begin
OldWindMax := WindMax ;
OldWindMin := WindMin ;
Window (X1,Y1,X2,Y2) ;
ClrScr ;
Window (Lo(OldWindMin)+1,Hi(OldWindMin)+1,
Lo(OldWindMax)+1,Hi(OldWindMax)+1) ;
end ;
{-----------------------------------------------------------------------------}
{ Clears the workspace indicated by <Wsnr>, resetting all variables. }
{-----------------------------------------------------------------------------}
procedure ClearWorkspace (Wsnr:byte) ;
begin
with Workspace[Wsnr] do
begin
Name := '' ;
ChangesMade := False ;
GetTime (LastTimeSaved[1],LastTimeSaved[2],
LastTimeSaved[3],LastTimeSaved[4]) ;
CurPos.Index := 1 ;
CurPos.Linenr := 1 ;
CurPos.Colnr := 1 ;
Mark := Inactive ;
FirstVisiblePos := CurPos ;
FirstScreenCol := 1 ;
VirtualColnr := 1 ;
Buffer^[1] := EF ;
Buffersize := 1 ;
PosStackPointer := Inactive ;
end ;
end ;
{-----------------------------------------------------------------------------}
{ Clears the keys in the keyboard buffer. }
{-----------------------------------------------------------------------------}
procedure ClearKeyBuffer ;
var DummyKey : char ;
begin
while KeyPressed do DummyKey := ReadKey ;
end ;
{-----------------------------------------------------------------------------}
end.