home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Garbo
/
Garbo.cdr
/
pc
/
editor
/
ae.zoo
/
ae4.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-03-12
|
29KB
|
708 lines
unit AE4 ;
{$B-}
{$I-}
{$S+}
{$V-}
interface
uses Crt,Dos,Printer,AE0,AE1,AE2,AE3 ;
function CopyBlock : boolean ;
procedure DeleteBlock ;
procedure InsertBlock ;
procedure PrintBlock (Buffer:WsBufptr ; BlockStart,BlockEnd:word ) ;
procedure InsertFile (Filename:PathStr; P:Position) ;
procedure LoadFile (Filename:PathStr) ;
function GetFileFromList (Name:PathStr) : PathStr ;
procedure InsertSpaces (var P:Position ; NrOfSpaces:word) ;
procedure InsertCRLF (var P:Position) ;
procedure RedrawScreen ;
procedure AlterSetup ;
implementation
{-----------------------------------------------------------------------------}
{ Copies the block in the current workspace to the paste buffer. If no block }
{ is indicated or if the block is too large for the paste buffer, an error }
{ message is given, and the function result will be False. }
{-----------------------------------------------------------------------------}
function CopyBlock : boolean ;
var Result : boolean ;
begin
Result := False ;
with Workspace[CurrentWsnr] do
begin
if (Mark > 0)
then begin
if Mark < CurPos.Index
then begin
if (CurPos.Index - Mark) > PasteBufSize
then ErrorMessage (4)
else begin
PasteBufferSize := CurPos.Index - Mark ;
Move (Buffer^[Mark],PasteBuffer^[1],
PasteBufferSize) ;
Result := True ;
end ;
end
else begin
if (Mark - CurPos.Index) > PasteBufSize
then ErrorMessage (4)
else begin
PasteBufferSize := Mark - CurPos.Index ;
Move (Buffer^[CurPos.Index],PasteBuffer^[1],
PasteBufferSize) ;
Result := True ;
end ;
end ;
end
else ErrorMessage (5) ;
end ; { of with }
CopyBlock := Result ;
end ;
{-----------------------------------------------------------------------------}
{ Deletes the block from the current workspace. }
{-----------------------------------------------------------------------------}
procedure DeleteBlock ;
var OldCurPosIndex : word ;
begin
with Workspace[CurrentWsnr] do
begin
if Mark > 0
then begin
if Mark < CurPos.Index
then begin
{ if Mark is before CurPos: exchange positions }
OldCurPosIndex := CurPos.Index ;
SkipUp (CurPos,OldCurPosIndex-Mark) ;
Mark := OldCurPosIndex ;
end ;
Shrink (CurPos.Index,Mark-CurPos.Index) ;
Mark := 0 ;
end ;
end ;
end ;
{-----------------------------------------------------------------------------}
{ Inserts the contents of the paste buffer into the current workspace at }
{ position CurPos. If successful, Mark will be pointing to the end of the }
{ inserted block, and CurPos to the start. }
{-----------------------------------------------------------------------------}
procedure InsertBlock ;
begin
with Workspace[CurrentWsnr] do
begin
if Grow (CurPos.Index,PasteBufferSize)
then Move (PasteBuffer^[1],Buffer^[CurPos.Index],PasteBufferSize) ;
end ; { of with }
end ;
{-----------------------------------------------------------------------------}
{ Dumps a block (indicated by BlockStart and BlockEnd) to the printer. }
{ If enabled by Setup, form feeds, left and top margins and page numbers }
{ are added. }
{-----------------------------------------------------------------------------}
procedure PrintBlock (Buffer:WsBufptr ; BlockStart,BlockEnd:word ) ;
var Counter,IndexCounter,LineCounter,PageCounter,LinesPerPage : word ;
DummyKey : word ;
AbortPrint : boolean ;
begin
LineCounter := 1 ;
PageCounter := 1 ;
{ LinesPerPagecontains number of text lines on a page }
LinesPerPage := Config.Setup.PageLength ;
if Config.Setup.PrintPagenrs then Dec (LinesPerPage,2) ;
Message ('Printing. Press any key to interrupt') ;
AbortPrint := False ;
IndexCounter := BlockStart ;
{ write left margin of first line }
Write (Lst,'':Config.Setup.LeftMargin) ;
repeat if LineCounter = 1
then begin
{ skip top margin }
for Counter := 1 to Config.Setup.TopMargin do
Writeln (Lst) ;
LineCounter := Config.Setup.TopMargin + 1 ;
Write (Lst,'':Config.Setup.LeftMargin) ;
end ;
Write (Lst,Buffer^[IndexCounter]) ;
if Buffer^[IndexCounter] = CR
then begin
Inc (LineCounter) ;
{ write left margin }
Write (Lst,'':Config.Setup.LeftMargin) ;
end ;
if ((LineCounter > LinesPerPage) or (Buffer^[IndexCounter] = FF)) and
(Config.Setup.PageLength > 0)
then begin
{ end current page and start new one }
if Config.Setup.PrintPagenrs
then begin
Writeln (Lst) ; Writeln (Lst) ;
Write (Lst,'Pag ',PageCounter:2) ;
end ;
Write (Lst,FF) ;
LineCounter := 1 ;
Inc (PageCounter) ;
{ write left margin }
Write (Lst,'':Config.Setup.LeftMargin) ;
end ;
Inc (IndexCounter) ;
CheckDiskError ;
AbortPrint := (DiskError <> 0) ;
if KeyPressed
then begin
ClearKeyBuffer ;
{ ask for confirmation }
AbortPrint := Answer ('Abort printing?') ;
if not AbortPrint
then Message ('Printing. Press any key to interrupt') ;
end ;
until (IndexCounter > BlockEnd) or AbortPrint ;
if (Config.Setup.PrintPagenrs) and (not KeyPressed)
then begin
{ end last page: move to end of page and print page number }
for Counter := LineCounter to (LinesPerPage+1) do
Writeln (Lst) ;
Write (Lst,'Pag ',PageCounter:2) ;
Write (Lst,FF) ;
CheckDiskError ;
end ;
if AbortPrint
then Message ('Printing aborted')
else Message ('Printing completed') ;
end ;
{-----------------------------------------------------------------------------}
{ Inserts the file <Filename> into the current workspace at position P. }
{-----------------------------------------------------------------------------}
procedure InsertFile (Filename:PathStr ; P:Position) ;
var F : file ;
Size,BytesToRead,AvailableSpace : longint ;
Counter : word ;
begin
Assign (F,Filename) ;
Reset (F,1) ;
CheckDiskError ;
if (DiskError = 0)
then begin
Size := FileSize (F) ;
with Workspace[CurrentWsnr] do
begin
BytesToRead := Size ;
AvailableSpace := WsBufSize - BufferSize ;
if BytesToRead > AvailableSpace
then BytesToRead := AvailableSpace ;
if Grow (P.Index,BytesToRead)
then begin
{ double reset: first to measure file size (record }
{ size 1), second to read file }
Reset (F,BytesToRead) ;
Message ('Reading file '+Filename) ;
BlockRead (F,Buffer^[P.Index],1) ;
CheckDiskError ;
Mark := P.Index + BytesToRead ;
{ check for EndOfFile char }
Counter := 0 ;
while (Buffer^[P.Index+Counter] <> EF)
and (Counter < BytesToRead) do
Inc (Counter) ;
{ delete stuff after first EOF char }
Shrink (P.Index+Counter,BytesToRead-Counter) ;
Message ('') ;
end ; { of if }
if Size > BytesToRead
then { warning: file too large to load completely }
ErrorMessage (7) ;
Close (F) ;
end ; { of with }
end ; { of if }
end ; { of procedure }
{-----------------------------------------------------------------------------}
{ Loads the file <Filename> into the current workspace, resetting all }
{ variables involved. If <Filename> is empty, then no file is loaded. }
{-----------------------------------------------------------------------------}
procedure LoadFile (Filename:PathStr) ;
begin
ClearWorkspace(CurrentWsnr) ;
if Length(FileName) > 0
then with Workspace[CurrentWsnr] do
begin
Name := FExpand (Filename) ;
InsertFile (Name,CurPos) ;
Mark := Inactive ;
ChangesMade := False ;
end ;
end ;
{-----------------------------------------------------------------------------}
{ Displays a list with files, from which the user }
{ can then make a choice, using the cursor and Return keys. }
{ Cursor shape and position and screen contents are saved, and }
{ restored on exit. }
{-----------------------------------------------------------------------------}
function GetFileFromList (Name:PathStr) : PathStr ;
var OldXpos,OldYpos,OldCursorType,Counter : byte ;
OldAttr,NormAttr,SelectAttr : byte ;
OldDisplayContents : ScreenBlockPtr ;
SelectKey : word ;
FileList : array[1..MaxFileListLength] of FilenameStr ;
FirstVisibleFile,SelectedFile,FileListLength : byte ;
SR : SearchRec ;
Mask : FilenameStr ;
Dir,OldCurrentDir : DirStr ;
Fname : NameStr ;
Fext : ExtStr ;
begin
GetDir (0,OldCurrentDir) ;
{ split pathname into directory and mask }
FSplit (FExpand(Name),Dir,Fname,Fext) ;
Mask := Fname + Fext ;
if Length(Dir) > 3
then Delete (Dir,Length(Dir),1) ;
ChDir (Dir) ;
CheckDiskError ;
{ save old screen settings }
OldXpos := WhereX ;
OldYpos := WhereY ;
OldCursorType := GetCursor ;
OldAttr := TextAttr ;
{ new screen settings }
SetCursor (Inactive) ;
NormAttr := ScreenColorArray[Config.Setup.ScreenColors].NormAttr ;
SelectAttr := ScreenColorArray[Config.Setup.ScreenColors].BlockAttr ;
TextAttr := NormAttr ;
{ save old screen contents and draw frame for file list }
SaveArea (60,2,75,23,OldDisplayContents) ;
PutFrame (60,2,75,23,Quasi3DFrame) ;
ClearArea (61,3,74,22) ;
repeat Counter := 1 ;
Message ('Searching ...') ;
{ build file list }
FindFirst (Mask,ReadOnly+Archive,SR) ;
while (DosError = 0) and (Counter < (MaxFileListLength-1)) do
begin
FileList[Counter] := SR.Name ;
FindNext (SR) ;
Inc (Counter) ;
end ;
{ add directories }
FindFirst ('*.*',Directory,SR) ;
while (DosError = 0) and (Counter <= MaxFileListLength) do
begin
if ((SR.Attr and Directory) <> 0) and
(SR.Name <> '.')
then begin
FileList[Counter] := '»' + SR.Name ;
Inc (Counter) ;
end ;
FindNext (SR) ;
end ;
Message ('Select file from list with ,,PgUp PgDn or ' +
'press first letter. Enter to load') ;
FileListLength := Counter - 1 ;
FirstVisibleFile := 1 ;
SelectedFile := 1 ;
repeat if FirstVisibleFile > SelectedFile
then FirstVisibleFile := SelectedFile ;
if (SelectedFile-FirstVisibleFile) > 19
then FirstVisibleFile := SelectedFile - 19 ;
for Counter := FirstVisibleFile to (FirstVisibleFile+19) do
begin
if Counter = SelectedFile
then TextAttr := SelectAttr
else TextAttr := NormAttr ;
GotoXY (61,Counter-FirstVisibleFile+3) ;
if Counter <= FileListLength
then Write (' ',FileList[Counter],
' ':(13-Length(FileList[Counter])))
else Write (' ':14) ;
end ;
SelectKey := ReadKeyNr ;
case SelectKey of
328 : { up } if SelectedFile > 1
then Dec (SelectedFile) ;
336 : { down } if SelectedFile < FileListLength
then Inc (SelectedFile) ;
329 : { PgUp } if SelectedFile > 19
then Dec (SelectedFile,19)
else SelectedFile := 1 ;
337 : { PgDn } if SelectedFile < (FileListLength-19)
then Inc (SelectedFile,19)
else SelectedFile := FileListLength ;
388 : { ^PgUp } SelectedFile := 1 ;
374 : { ^PgDn } SelectedFile := FileListLength ;
32..127 : begin
{ select by pressing first letter of name }
Counter := SelectedFile + 1 ;
while (not ((FileList[Counter][1] =
UpCase (Chr(SelectKey))) or
((FileList[Counter][1] = '»') and
(FileList[Counter][2] =
UpCase (Chr(SelectKey))))))
and
(Counter <= FileListLength)
do Inc (Counter) ;
if Counter <= FileListLength
then SelectedFile := Counter ;
end ;
ReturnKey : ;
EscapeKey : EscPressed := true ;
else WarningBeep ; { invalid key }
end ; { of case }
until (SelectKey = ReturnKey) or EscPressed ;
if (SelectKey = ReturnKey) and (FileList[SelectedFile][1] = '»')
then ChDir (Copy(FileList[SelectedFile],2,8)) ;
until (FileList[SelectedFile][1] <> '»') or EscPressed ;
{ restore screen }
Message ('') ;
RestoreArea (60,2,75,23,OldDisplayContents) ;
TextAttr := OldAttr ;
GotoXY (OldXpos,OldYpos) ;
SetCursor (OldCursorType) ;
{ construct full pathname from filename + directory }
if EscPressed
then GetFileFromList := Name
else begin
GetDir (0,Dir) ;
if Dir[Length(Dir)] <> '\' then Dir := Dir + '\' ;
GetFileFromList := Dir + FileList[SelectedFile] ;
end ;
ChDir (OldCurrentDir) ;
end ;
{-----------------------------------------------------------------------------}
{ Insert a number of spaces into the current workspace at position P. }
{ On exit, P will point to the position right after the last space. }
{-----------------------------------------------------------------------------}
procedure InsertSpaces (var P:Position ; NrOfSpaces:word) ;
begin
with Workspace[CurrentWsnr] do
begin
if Grow (P.Index,NrOfSpaces)
then begin
FillChar (Buffer^[P.Index],NrOfSpaces,' ') ;
Inc (P.Index,NrOfSpaces) ;
Inc (P.Colnr,NrOfSpaces) ;
end
end ; { of with }
end ;
{-----------------------------------------------------------------------------}
{ Insert a carriage return - line feed pair into the current workspace at }
{ position P. If autoindent is on, the left margin of the current line is }
{ determined, and the same number of spaces inserted at the beginning of the }
{ new line. }
{-----------------------------------------------------------------------------}
procedure InsertCRLF (var P:Position) ;
var Counter,LeftMargin : word ;
begin
with Workspace[CurrentWsnr] do
begin
{ look for first non-space on current line }
LeftMargin := 1 ;
while (Buffer^[P.Index-P.Colnr+LeftMargin] = ' ') and
(LeftMargin <= P.Colnr) do
Inc (LeftMargin) ;
if LeftMargin > P.Colnr then LeftMargin := 1 ;
if Grow (P.Index,2)
then begin
Buffer^[P.Index] := CR ;
Buffer^[P.Index+1] := LF ;
Inc (P.Index,2) ;
Inc (P.Linenr) ;
P.Colnr := 1 ;
if Config.Setup.AutoIndent
then InsertSpaces (P,LeftMargin-1) ;
end ;
end ; { of with }
end ;
{-----------------------------------------------------------------------------}
{ Redraws the entire screen including the status line }
{ The new screen contents are first written to an array in memory, and then }
{ transferred to video memory by a call to MoveToScreen (line by line). }
{-----------------------------------------------------------------------------}
procedure RedrawScreen ;
var LineCounter : byte ;
IndexCounter,ColCounter : word ;
BlockStart,BlockStop : word ;
NormAttr,BlockAttr : byte ;
ScreenChar : ScreenElement ;
StatusLine : string[ColsOnScreen] ;
NewDisplayLine : array [1..ColsOnScreen] of word ;
TempStr : string[5] ;
begin
with Workspace[CurrentWsnr] do
begin
{ check if FirstVisiblePos needs to be adapted }
if (FirstVisiblePos.Linenr > CurPos.Linenr)
then
begin
{ line number of CurPos is too low }
FirstVisiblePos := CurPos ;
Home(FirstVisiblePos) ;
end ;
if ((FirstVisiblePos.Linenr+NrOfTextLines) <= CurPos.Linenr)
then
begin
{ line number of CurPos is too high }
if ((FirstVisiblePos.Linenr+2*NrOfTextLines) <= CurPos.Linenr)
then
begin
{ difference is more than 1 screen }
FirstVisiblePos := CurPos ;
repeat
LineUp (FirstVisiblePos) ;
until ((FirstVisiblePos.Linenr+NrOfTextLines) =
(CurPos.Linenr + 1)) ;
end
else
begin
{ difference is less than 1 screen }
while ((FirstVisiblePos.Linenr+NrOfTextLines) <=
CurPos.Linenr) do
begin
LineDown (FirstVisiblePos) ;
end ;
end ;
end ;
if FirstScreenCol > CurPos.Colnr
then
begin
{ colum number of CurPos is too low }
Dec (FirstVisiblePos.Index,FirstVisiblePos.Colnr - CurPos.Colnr) ;
FirstVisiblePos.Colnr := CurPos.Colnr ;
FirstScreenCol := CurPos.Colnr ;
end ;
if (FirstScreenCol+ColsOnScreen) <= CurPos.Colnr
then
begin
{ colum number of CurPos is too high }
FirstScreenCol := CurPos.Colnr - ColsOnScreen + 1 ;
while (FirstVisiblePos.Colnr < FirstScreenCol) and
(Buffer^[FirstVisiblePos.Index] <> CR) do
begin
Inc (FirstVisiblePos.Index) ;
Inc (FirstVisiblePos.Colnr) ;
end ; { of while }
end ;
{ set index of first and last characters to be displayed as block }
if (Mark <> Inactive)
then
begin
if Mark < CurPos.Index
then
begin
BlockStart := Mark ;
BlockStop := CurPos.Index ;
end
else
begin
BlockStart := CurPos.Index ;
BlockStop := Mark ;
end
end
else
begin
{ do not show a block on the screen }
BlockStart := 0 ;
BlockStop := 0 ;
end ;
{ Initialize working variables: }
{ NormAttr contains attribute of normal characters on screen }
NormAttr := ScreenColorArray[Config.Setup.ScreenColors].NormAttr ;
{ BlockAttr contains attribute of characters in block }
BlockAttr := ScreenColorArray[Config.Setup.ScreenColors].BlockAttr ;
{ IndexCounter contains index of next character to be displayed }
IndexCounter := FirstVisiblePos.Index - FirstVisiblePos.Colnr + 1 ;
{ initialise attribute of characters on screen }
if (IndexCounter > BlockStart) and (BlockStart <> 0)
then ScreenChar.Attribute := BlockAttr
else ScreenChar.Attribute := NormAttr ;
{ write text lines to NewDisplay }
for LineCounter := 1 to NrOfTextLines do
begin
{ skip to first character on line to be displayed (if there is one) }
ColCounter := 1 ;
while (ColCounter < FirstScreenCol) and
(Buffer^[IndexCounter] <> CR) and
(IndexCounter < BufferSize) do
begin
Inc (IndexCounter) ;
Inc (ColCounter) ;
end ;
{ write a full screen line to NewDisplay }
for ColCounter := 1 to ColsOnScreen do
begin
ScreenChar.contents := Buffer^[IndexCounter] ;
if Config.Setup.DotsForSpaces and (ScreenChar.contents = ' ')
then ScreenChar.contents := #250 ;
{ set attribute (NormAttr or BlockAttr) }
if IndexCounter = BlockStop
then ScreenChar.Attribute := NormAttr
else if IndexCounter = BlockStart
then ScreenChar.Attribute := BlockAttr ;
{ if end of text line or of buffer is reached: display a space }
if (ScreenChar.contents = CR) or (IndexCounter = BufferSize)
then ScreenChar.contents := ' '
else Inc (IndexCounter) ;
{ write 1 screen element to NewDisplayLine }
NewDisplayLine[ColCounter] := word(ScreenChar) ;
end ;
{ display new line on screen }
MoveToScreen (NewDisplayLine[1],DisplayPtr^[LineCounter,1],
ColsOnScreen*2) ;
{ skip to next line }
if IndexCounter < BufferSize then Inc (IndexCounter) ;
while (Buffer^[IndexCounter-1] <> CR) and
(IndexCounter < BufferSize) do
Inc (IndexCounter) ;
if Buffer^[IndexCounter] = LF then Inc (IndexCounter) ;
end ; { of for }
if MessageRead
then
begin
{ prepare status line }
StatusLine := BasicStatusLine ;
StatusLine[1] := Chr (64+CurrentWsnr) ;
TempStr := WordToString(CurPos.Linenr,0) ;
Move (TempStr[1],StatusLine[6],Length(TempStr)) ;
TempStr := WordToString(CurPos.Colnr,0) ;
Move (TempStr[1],StatusLine[14],Length(TempStr)) ;
if ChangesMade
then StatusLine[20] := '*' ;
Move (Name[1],StatusLine[22],Length(Name)) ;
StatusLine[56] := ' ' ;
if Config.Setup.WordWrapLength > Inactive
then Move (Status_Wrap[1],StatusLine[57],4) ;
if Config.Setup.Insertmode
then Move (Status_Ins[1],StatusLine[62],3) ;
if Config.Setup.AutoIndent
then Move (Status_Indent[1],StatusLine[66],6) ;
if MacroDefining <> Inactive
then Move (Status_Def[1],StatusLine[73],3) ;
TempStr := WordToString (BufferSize div OnePercent,3) ;
Move (TempStr[1],StatusLine[77],3) ;
{ show status line on screen }
SetBottomline (StatusLine) ;
end ;
{ set position of cursor }
OldCursorPosAttr := Hi (DisplayPtr^[WhereY,WhereX]) ;
CursorTo (CurPos.Colnr - FirstScreenCol + 1,
CurPos.Linenr - FirstVisiblePos.Linenr + 1) ;
end ; { of with }
end ; { of procedure }
{-----------------------------------------------------------------------------}
{ Interactive change of the setup }
{-----------------------------------------------------------------------------}
procedure AlterSetup ;
var ConfigFile : file of ConfigBlock ;
begin
SetCursor (Inactive) ;
with Config.Setup do
begin
case Choose ('Display Environment File Printer Save-setup') of
'D' : case Choose ('Colors cursorType Dots-for-spaces') of
'C' : begin
if ColorCard
then begin
if ScreenColors = NrOfColorSettings
then Screencolors := 1
else Inc (ScreenColors) ;
end
else begin
if ScreenColors = 1
then Screencolors := 2
else Screencolors := 1 ;
end ;
TextAttr := ScreenColorArray[ScreenColors].NormAttr ;
end ;
'T' : if Cursortype = NrOfCursorTypes
then Cursortype := 1
else Inc (Cursortype) ;
'D' : EnterBoolean (DotsForSpaces,'Display spaces as small dots?') ;
end ; { of case }
'E' : case Choose ('Keyclick Bell Wordwrap Tabs Autoindent Insert') of
'K' : EnterBoolean (Keyclick,'Keyclick on?') ;
'B' : EnterBoolean (SoundBell,
'Sound bell on errors and warnings?') ;
'W' : EnterWord (WordWrapLength,
'Line length for word wrap (0 = off): ',0,255) ;
'T' : Enterword (TabSpacing,'Tab spacing (0 = align): ',0,255) ;
'A' : EnterBoolean (AutoIndent,'Auto indent on?') ;
'I' : EnterBoolean (Insertmode,'Insert mode on?') ;
end ; { of case }
'F' : case Choose ('Exit-auto-save Interval-auto-save Backup-files') of
'E' : EnterBoolean (SaveOnExit,
'Save changed files on exiting AE?') ;
'I' : EnterWord (SaveInterval,
'Interval for auto-save in minutes (0 = off): ',
0,1000) ;
'B' : EnterBoolean (MakeBAKfile,'Make .BAK file when saving?') ;
end ; { of case }
'P' : case Choose ('Page-length Left-margin Top-margin page-Numbers') of
'P' : EnterWord (PageLength,
'Lines per page for paged prints (0 = off): ',
0,1000) ;
'L' : EnterWord (LeftMargin,'Left margin: ',0,240) ;
'T' : EnterWord (TopMargin,'Top margin: ',0,1000) ;
'N' : EnterBoolean (PrintPagenrs,'Print page numbers?') ;
end ; { of case }
'S' : begin
if Answer ('Save current setup?')
then
begin
Assign (ConfigFile,ConfigFilename) ;
Rewrite (ConfigFile) ;
Write (ConfigFile,Config) ;
CheckDiskerror ;
Close (ConfigFile) ;
Message ('Setup saved as ' + ConfigFileName +
' in current directory') ;
end ;
end ;
end ; { of case }
SetCursor (CursorType) ;
end ; { of with }
end ;
{-----------------------------------------------------------------------------}
end.