Power-Programmierung/CD1.mdf/pascal/library/dos/sampler/01/counter/counter2.pas

Pascal/Delphi Source File | 1988-09-09 | 19.2 KB | 871 lines

{
                       F i l e    I n f o r m a t i o n

* DESCRIPTION
Include source code file for COUNTER.PAS.

* ASSOCIATED FILES
COUNTER.PAS
COUNTER1.PAS
COUNTER2.PAS
COUNTER3.PAS
COUNTER.EXE

}


{------------------------------------------------ procedure EraseWarning }

{
purpose: to erase all screen output to lines 18 to 23; that is where
         all warnings are displayed.
}

procedure EraseWarning;

var
 i:byte;

begin {procedure EraseWarning}

 for i:=18 to 23 do
 begin
  gotoxy(1,i); clreol;
 end; {for .. to loop}

end; {procedure EraseWarning}

{------------------------------------------------ proceudure SetTextType }

{
purpose: to modify the text attributes of the output to the screen.
}

procedure SetTextType(TextTypeVar:TextType);

begin {procedure SetTextType}

 case TextTypeVar of
          Norm:begin
                TextColor(7);
                TextBackground(0);
               end;
       NormUnd:begin
                TextColor(1);
                TextBackground(0);
               end;
     NormBlink:begin
                TextColor(18);
                TextBackground(0);
               end;
  NormUndBlink:begin
                TextColor(17);
                TextBackground(0);
               end;
          High:begin
                TextColor(10);
                TextBackground(0);
               end;
       HighUnd:begin
                TextColor(9);
                TextBackground(0);
               end;
     HighBlink:begin
                TextColor(26);
                TextBackground(0);
               end;
  HighUndBlink:begin
                TextColor(25);
                TextBackground(0);
               end;
           Rev:begin
                TextColor(8);
                TextBackground(7);
               end;
      RevBlink:begin
                TextColor(16);
                TextBackground(7);
               end;
 end; {case TextTypeVar}

end; {procedure SetTextType}


{-------------------------------------------------- procedure CEHandler }
{$F+}
procedure CEHandler (Flags,CS,IP,AX,BX,CX,DX,SI,DI,DS,ES,BP:word);
Interrupt;

{
purpose: to handle critical errors without allowing DOS to take over.
         This procedure and its 3 related functions (below) are modified
         from those developed by Kent Porter and published in the
         February 1988 issue of Dr. Dobbs Journal of Software Tools.
}

var
 ah,al:byte;
 ch:char;

{-------------------------------------------------- function GiveReason }

{
purpose: to explain reason for critical error.
}

function GiveReason (Error:byte):Str40;

begin {function GiveReason}

 case Error of
   $00:GiveReason:=(' Write protect                          ');
   $01:GiveReason:=(' Unknown unit                           ');
   $02:GiveReason:=(' Drive not ready                        ');
   $03:GiveReason:=(' Unknown command                        ');
   $04:GiveReason:=(' CRC data error                         ');
   $05:GiveReason:=(' Bad request structure length           ');
   $06:GiveReason:=(' Seek error                             ');
   $07:GiveReason:=(' Unknown media type                     ');
   $08:GiveReason:=(' Sector not found                       ');
   $0A:GiveReason:=(' Write fault                            ');
   $0B:GiveReason:=(' Read fault                             ');
   $0C:GiveReason:=(' General failure                        ');
   $0D:GiveReason:=(' Bad file allocation table              ');
   else GiveReason:=(' Unknown                                ');
 end; {case Error}

end; {function GiveReason}

{-------------------------------------------------- function DiskError }

{
purpose: to handle critical disk errors.
}

function DiskError:word;

var
 area,why:byte;

begin {function DiskError}

 S:='';
 CriticalErrorDrive:=AL;
 S:=' Disk error on drive '+char (AL+65);
 while length(S)<40 do S:=S+' ';
 gotoxy(1,19); write (S);
 area:=(AH and 6) shr 1;
 gotoxy(1,20);
 case area of
   0:write (' Error in DOS communications area       ');
   2:write (' Error in disk directory                ');
   3:write (' Error in files area                    ');
 else write ('                                        ');
 end; {case area}
 why:=lo(DI);
 SetTextType(RevBlink);
 gotoxy(1,21); write (GiveReason(why));
 SetTextType(Rev);
 DiskError:=why;

end; {function DiskError}

{-------------------------------------------------- function NonDiskError }

{
purpose: to handle critical non-disk errors.
}

function NonDiskError:word;

var
 why:byte;
 DeviceAttr:^word;
 DeviceName:^char;
 ch:ShortInt;

begin {function NonDiskError}

 DeviceAttr:=ptr(BP,SI+4);
 if (DeviceAttr^ and $8000) <> 0 then
 begin
  gotoxy(1,19); write (' Character device error                 ');
  gotoxy(1,20); write (' Failing device is                      ');
  S:='';
  ch:=0;
  repeat
   DeviceName:=ptr(BP,SI+$0A+ch);
   S:=S+(DeviceName^);
   inc(ch);
  until (DeviceName^=chr(0)) or (ch>7);
  while length(S)<40 do S:=S+' ';
  SetTextType(RevBlink);
  gotoxy(1,21); write (S);
  SetTextType(Rev);
 end
 else
 begin
  gotoxy(1,19); write (' Disk error has occurred                ');
  gotoxy(1,20); write (' Probable cause:                        ');
  why:=$0D;
  SetTextType(RevBlink);
  gotoxy(1,21); write (GiveReason(why));
  SetTextType(Rev);
 end; {if (DeviceAttr^ and $8000) <> 0}
 NonDiskError:=why

end; {function NonDiskError}


begin {procedure CEHandler}

 SetTextType(Rev);
 CriticalErrorOccurred:=true;
 AH:=hi(AX);
 AL:=lo(AX);
 if (AH and $80) = 0 then CriticalErrorCode:=DiskError
 else CriticalErrorCode:=NonDiskError;
 gotoxy (1,22); write (' Strike any key to continue             ');
 ch:=ReadKey;
 AX:=0;
 SetTextType(Norm);
 EraseWarning;

end; {procedure CEHandler}
{$F-}

{------------------------------------------------ procedure ProcessIOError }

{
purpose: to handle IO errors from within this program.
}

procedure ProcessIOError(IOErrorCode:integer);

var
 Msg:Str40;
 Ch:char;

begin
 if IOErrorCode=0 then exit;
 case IOErrorCode of
  {DOS errors}
  2:Msg:=' File not found                          ';
  3:Msg:=' Path not found                          ';
  4:Msg:=' Too many open files                     ';
  5:Msg:=' File access denied                      ';
  6:Msg:=' Invalid file handle                     ';
  7:Msg:=' Invalid file access code                ';
  15:Msg:=' Invalid drive number                    ';
  16:Msg:=' Cannot remove current directory         ';
  17:Msg:=' Cannot rename accross drives            ';

  {Turbo Pascal IO Errors}
  100:Msg:=' Disk read error                         ';
  101:Msg:=' Disk write error                        ';
  102:Msg:=' File not assigned                       ';
  103:Msg:=' File not open                           ';
  104:Msg:=' File not open for input                 ';
  105:Msg:=' File not open for output                ';
  106:Msg:=' Invalid numeric format                  ';
 else
  Msg:=' Unknown error                          ';
 end; {case code of}

 SetTextType(Rev);
 gotoxy(1,19); write (' I/O Error encountered.                 ');
 Str(IOErrorCode:3,S);
 S:=' Decimal Error IOErrorCode # '+S;
 while length(S)<40 do S:=S+' ';
 gotoxy(1,20); write (S);
 SetTextType(RevBlink);
 gotoxy(1,21); write (Msg);
 SetTextType(Rev);
 gotoxy(1,22); write (' Strike any key to continue.            ');
 SetTextType(Norm);
 Ch:=ReadKey;
 EraseWarning;
end; {procedure ProcessIOError}

{-------------------------------------------------- procedure CheckIOError }

{
purpose: to determine if an IO error has occurred.
}

procedure CheckIOError;

begin {procedure CheckIOError}

  IOErrorCode:=IOResult;
  if IOErrorCode<>0 then ProcessIOError(IOErrorCode);

end; {procedure CheckIOError}

{-------------------------------------------------- procedure InvalidKey }

{
purpose: to warn the user of invalid input or request.
}

procedure InvalidKey;

begin {procedure InvalidKey}

  SetTextType(Rev);
  gotoxy(1,18); write (' Invalid key ');
  sound(300); delay(50);
  sound(600); delay(50);
  sound(1500); delay(50);
  NoSound;
  delay(50);
  SetTextType(Norm);
  EraseWarning;

end; {procedure InvalidKey}

{------------------------------------------------ procedure Click }

{
purpose: to make a clicking sound.  This is sound is used as feedback
         every time a counter key is pressed.  A different sound is
         made if in subtraction mode.
}

procedure click;

begin {procedure click}

  if add then
  begin
   Sound(750); delay(20);
  end
  else
  begin
   Sound(1250); delay(20);
  end;
  NoSound;

end; {procedure click}

{-------------------------------------------------- procedure CursorOff }

{
purpose: to turn the cursor off.
}
procedure CursorOff;

begin {procedure CursorOff}

 regs.cx:=$2000;
 regs.ax:=$0100;
 intr($10,regs)

end; {procedure CursorOff}

{------------------------------------------------ procedure CursorOn }

{
purpose: to turn the cursor on.
}

procedure CursorOn;

begin {procedure CursorOn}

 if mem[0:$449]=7 then regs.cx:=$0C0D else regs.cx:=$0607;
 regs.ax:=$0100;
 intr($10,regs)

end; {procedure CursorOn}

{------------------------------------------------ procedure UpdateScreen }

{
purpose: to update the screen when the status of a counter changes.
}

procedure UpdateScreen(i:byte);

begin {procedure UpDateScreen}

 {derive the screen position to update}
 if i<=10 then
 begin
  xpos:=33;
  ypos:=i+6;
 end
 else
 begin
  xpos:=72;
  ypos:=i-4;
 end; {if i<=10}
 SetTextType(High);
 gotoxy(xpos,ypos); write (CharCounterArray[i]:5);
 SetTextType(Norm);
end; {procedure UpDateScreen}

{------------------------------------------------ function time }

{
purpose: to retrieve the system's time.
}

function time:str11;

var
 hr,min,sec,hun:str2;

begin {function time:str11}

 GetTime(Hour,Minute,Second,Sec100);
 str(Hour:2,hr);
 str(Minute:2,min);
 str(Second:2,sec);
 str(Sec100:2,hun);
 if hr[1]=' ' then hr[1]:='0';
 if min[1]=' ' then min[1]:='0';
 if sec[1]=' ' then sec[1]:='0';
 if hun[1]=' ' then hun[1]:='0';
 time:=hr+':'+min+':'+sec+'.'+hun;

end; {function time:str11}

{------------------------------------------------ function date }

{
purpose: to retrieve the system's date.
}

function date:str8;

var
 Year,Month,Day,DayOfWeek:word;
 yr,mon,dy:Str2;
 yrstr:Str4;

begin {function date}

 GetDate(Year,Month,Day,DayOfWeek);
 str(Year:4,yrstr);
 yr:=copy(yrstr,3,2);
 str(Month:2,mon);
 str(Day:2,dy);
 if mon[1]=' ' then mon[1]:='0';
 if dy[1]=' ' then dy[1]:='0';
 date:=mon+'/'+dy+'/'+yr;
end; {function date}

{------------------------------------------------ procedure UpDateClock }

{
purpose: to update the screen clock every minute.
}

procedure UpDateClock;

var
 TempTime,LastTime:str5;

begin {procedure UpDateClock}

 TempTime:=time;
 if TempTime>LastTime then
 begin
  SetTextType(Rev);
  gotoxy(74,1); write (TempTime);
  SetTextType(Norm);
  LastTime:=TempTime;
 end;

end; {procedure UpDateClock}

{------------------------------------------------ function BuildStr }

{
purpose: to build a string with n characters of ch.
}

function BuildStr(c:Char; n:integer):str80;

var
  S:str80;

begin {function BuildStr}
  if n<0 then n:=0;
  S[0]:=Chr(n);
  FillChar(S[1],n,C);
  BuildStr:=S;

end; {function BuildStr}

{------------------------------------------------ procedure MakeUpCase }

{
purpose: to make a string into uppercase.
}

procedure MakeUpCase (var S:Str80);

var
  i:integer;

begin {procedure MakeUpCase}

  for i:=1 to Length(S) do
  S[i]:=UpCase(S[i]);

end;  {procedure MakeUpCase}

{------------------------------------------------ procedure InputStr }

{
purpose: to let user enter a string of length l at coordinates xpos,ypos.
}

procedure InputStr(var S:Str80; l,xpos,ypos:byte);

const
  Blank=' ';

var
  p:byte;
  ch:char;
  done:boolean;

begin {procedure InputStr}

  done:=false;
  CursorOn;
  S:='';
  SetTextType(Rev);
  gotoxy(xpos,ypos);
  write(S,BuildStr(Blank,l-length(S)));
  p:=0;
  repeat
    gotoxy(xpos+p,ypos);
    ch:=ReadKey;
    case ch of
      #0:begin  {dump extended keys}
          ch:=ReadKey;
          InvalidKey;
          SetTextType(Rev);
         end;
      #32..#126:if p<l then
                begin
                 if Length(S)=l then
                  delete(S,l,1);
                  p:=p+1;
                  insert(ch,S,p);
                  write(Copy(S,p,l));
                end
                else
                begin
                 InvalidKey;
                 SetTextType(Rev);
                end;
        ^H,#127:if p>0 then
                begin
                 delete(S,P,1);
                 write(^H,Copy(S,P,L),Blank);
                 p:=p-1;
                end
                else
                begin
                 InvalidKey;
                 SetTextType(Rev);
                end;
        #13,#27:done:=true;
    else
    begin
     InvalidKey;
     SetTextType(Rev);
    end;
    end;  {of case}
  until done;
  if ch=#27 then S:='';
  p:=Length(S);
  gotoxy(xpos+p,ypos);
  write('' :l-p);
  SetTextType(High);
  gotoxy(xpos,ypos); write (BuildStr(Blank,l));
  gotoxy(xpos,ypos); write (S);
  SetTextType(Norm);
  CursorOff;
end; {procedure InputStr}

{------------------------------------------------ procedure HitKey }

{
purpose: to determine which key has been hit.
}

procedure HitKey (KeyList:Str20; var Key1,Key2:char);

begin {procedure HitKey}

 Key2:=chr(0);
 repeat
  Key1:=ReadKey;
  if (Key1=#0) then Key2:=ReadKey;
  if length(KeyList)=0 then exit;
  if (pos(Key1,KeyList)=0) then InvalidKey;
 until pos(Key1,KeyList)>0;

end; {procedure HitKey}

{------------------------------------------------ proceure ChangePath }

{
purpose: to change the active path.
}

procedure ChangePath(var ActivePath:Str67);

var
 ch,LastChar:Char;
 TempPath:Str67;

begin {procedure ChangePath}

gotoxy(1,18); clreol; write (' Enter new active path : ');
InputStr(S,67,2,19);
MakeUpCase(S);

if Length(S)=0 then
begin
 EraseWarning;
 exit;
end;

LastChar:=S[Length(S)];
if ((length(S)>3) and (LastChar='\')) then Delete(S,length(S),1);
if ((length(S)=2) and (LastChar=':')) then S:=S+'\';

TempPath:=S;

{check for valid requested path}
ChDir(TempPath);
IOErrorCode:=IOResult;

{check for critical error}
if CriticalErrorOccurred then
begin
 {restore previous path before exiting}
 ChDir(ActivePath);
 {reset error flags}
 IOErrorCode:=IOResult;
 CriticalErrorOccurred:=false;
 exit;
end; {if CriticalErrorOccurred}

{check for IO Error}
if IOErrorCode<>0 then
begin
 ProcessIOError(IOErrorCode);
 {restore the previous ActivePath before exiting}
 ChDir(ActivePath);
 {reset error flags}
 IOErrorCode:=IOResult;
 CriticalErrorOccurred:=false;
 exit;
end
else
begin
 ActivePath:=TempPath;
 if length(ActivePath)>3 then ActivePath:=ActivePath+'\';
end; {if IOErrorCode<>0}

gotoxy(1,2); clreol; write ('Active path : ');
SetTextType(High); write (ActivePath); SetTextType(Norm);

end; {procedure ChangePath}

{-------------------------------------------------- function PrinterOk }

{
purpose: to determine if the printer is on line.
}

function PrinterOK:boolean;

var
 ch:char;

begin {function PrinterOK}

 regs.dx:=$0000;
 regs.ax:=$0200;
 intr($17,regs);
 if (odd(hi(regs.ax shr 3)) or (not(odd(hi(regs.ax shr 7))))) then
  PrinterOK:=false else PrinterOK:=true;

end; {function PrinterOK}

{------------------------------------------------ function ValidFileName }

{
purpose: to get a valid filename from the user.
}

function ValidFileName:boolean;

var
 PeriodPosition,i:integer;
 Name:Str8;
 Ext:Str3;
 ch:char;
 ValidName:boolean;

begin {function ValidFileName}

 Name:='';
 Ext:='';
 ValidName:=true;

 gotoxy(1,18); clreol; write (' Enter a file name : ');
 InputStr(S,12,22,18);
 MakeUpCase(S);
 EraseWarning;

 if length(S)=0 then ValidName:=false
 else
 begin

  {check for position of .}
  PeriodPosition:=Pos('.',S);

  if PeriodPosition<>0 then
  begin
   Name:=Copy(S,1,PeriodPosition-1);
   Ext:=Copy(S,PeriodPosition+1,(length(S)-length(Name)+1));
  end
  else Name:=S;

  {check the filename for invalid characters}
  for i:=1 to length(Name) do
  begin

   {filename cannot begin with a number}
   if ((i=1) and (ord(Name[i]) IN [48..57])) then ValidName:=false;
   {check for other forbidden characters in the filename}
   if (ord(Name[i]) IN [0..32,34,46,47,92,91,93,58,124,62,60,43,61,59,44]) then
    ValidName:=false;

  end; {for i:=1 to}

  {check the extension for ivalid characters}
  if Ext<>'' then
  begin
   for i:=1 to length(Ext) do
   begin
    {check for forbidden characters in the file extension}
    if (ord(Ext[i]) IN [0..32,34,46,47,92,91,93,58,124,62,60,43,61,59,44]) then
     ValidName:=false;

   end; {for i:=1 to length(Ext)}
  end; {if Ext<>'' then}
 end; {if length(S)=0...}

 if not ValidName then
 begin
  ValidFileName:=false;
  FileName:='';
  SetTextType(RevBlink);
  gotoxy(1,20); write (' Illegal character(s) in file name.');
  SetTextType(Rev);
  gotoxy(1,21); write (' Strike any key to continue.       ');
  SetTextType(Norm);
  ch:=ReadKey;
 end
 else
 begin
  ValidFileName:=true;

  {reconstitute the filename}
  if Ext<>'' then FileName:=Name+'.'+Ext else FileName:=Name;

 end; {if not ValidName then}

 EraseWarning;

end; {function ValidFileName}

{------------------------------------------------ procedure OpenOutPutFile }

{
purpose: to open a file for output.
}

procedure OpenOutPutFile;

var
 ch:char;

begin {procedure OpenOutPutFile}

 {prompt the user for a filename}
 if not ValidFileName then exit;

 {check if file already exists, if so overwrite?}
 ActiveFile:=FileName;
 PathFileName:=ActivePath+ActiveFile;

 Assign(OutPutFile,PathFileName);
 Reset(OutPutFile);

 {if IOResult=0 file already exists, should it be overwritten?}
 if IOResult=0 then
 begin
  SetTextType(Rev);
  gotoxy(1,18); write (' File already exists.  Overwrite? (Y/N) ');
  ch:=ReadKey;
  SetTextType(Norm);
  EraseWarning;
  if ((ch) IN ['N','n']) then
  begin
   {release the file handle and exit}
   Close(OutPutFile);
   exit;
  end; {if ((ch) IN ['N','n'])}
 end; {if IOResult=0}

 Rewrite(OutPutFile);
 IOErrorCode:=IOResult;
 if IOErrorCode<>0 then
 begin
  ProcessIOError(IOErrorCode);
  exit;
 end; {if IOErrorCode<>0}

 SetTextType(High);
 gotoxy(15,1);
 write ('             ');
 gotoxy(15,1);
 write (ActiveFile);
 SetTextType(Norm);
 OutPutFileOpen:=true;

end; {procedure OpenOutPutFile}

{------------------------------------------------ procedure PrinterDump }

{
purpose: to send output to the printer and to advance the page when
         necessary.
}

procedure PrinterDump (S:Str80);

begin {procedure PrinterDump}

  if PrinterLine>=65 then
  begin
   writeln (lst,#12);
   PrinterLine:=1;
  end; {if PrinterLine>=65}
  writeln (lst,S);
  PrinterLine:=PrinterLine+1;

end; {procedure PrinterDump}