Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/OPBONUS.ZIP/ALARM.LZH/ALARMM.PAS

Pascal/Delphi Source File | 1990-08-15 | 20.8 KB | 673 lines

{$S-,R-,V-,I-,A-,F+}
unit AlarmM;
  {-Main unit of ALARM: A Simple PopUp Alarm Program}

interface

uses
  Dos,                       {standard DOS/BIOS routines}
  OpInline,                  {Object Professional Inline macros}
  OpRoot,                    {Object Professional classic data structures}
  OpString,                  {Object Professional string handling routines}
  OpDate,                    {Object Professional Date routines}
  OpDos,                     {Object Professional Dos routines}
  OpCrt,                     {Object Professional CRT unit}
  OpCmd,                     {Object Professional Command Processing}
  OpSEdit,                   {Object Professional Simple Line Editor}
  OpSwap1;                   {Object Professional TSR Swap Manager}

type
  {time record}
  TimeRec =
    record
      Hours, Minutes, Seconds : Byte;
    end;
  LongIntPtr = ^LongInt;

  {a type that describes our data in the code segment}
  AlarmDataType =
    record
      AlarmTicker : LongInt;         {The tick count to popup}
      DataPtr     : LongIntPtr;      {pointer to the ThisIFC.UserData field}
      Int1cOn     : Boolean;         {int 1Ch installed flag}
    end;
  AlarmDataTypePtr = ^AlarmDataType; {pointer to CS data}

var
  ShutDownProc : Procedure;
  StartUpProc  : Procedure;
  ScrBuf       : Pointer;
  AlarmData    : AlarmDataTypePtr;   {pointer to CS data set by ALARM.PAS}
  OrigInt1C    : Pointer;            {save original Int 1Ch vector}
  LE           : SimpleLineEditor;   {for prompt in hotkey popup}
  popTime      : TimeRec;            {TimeRec for when Alarm is to popup}

const
  {colors for user interface window and prompts}
  ScreenColors : ColorSet = (
    TextColor       : $1B; TextMono       : $1B;
    CtrlColor       : $1B; CtrlMono       : $1B;
    FrameColor      : $1A; FrameMono      : $1A;
    HeaderColor     : $21; HeaderMono     : $70;
    ShadowColor     : $00; ShadowMono     : $00;
    HighlightColor  : $00; HighlightMono  : $00;
    PromptColor     : $1F; PromptMono     : $0F;
    SelPromptColor  : $1F; SelPromptMono  : $0F;
    ProPromptColor  : $1F; ProPromptMono  : $0F;
    FieldColor      : $3B; FieldMono      : $70;
    SelFieldColor   : $1B; SelFieldMono   : $07;
    ProFieldColor   : $1B; ProFieldMono   : $07
  );

procedure InitAlarm;
{-Called from Alarm.Pas to initialize Alarm}

implementation

const
  {** keep the following together to allow easy patching **}
  ModuleName : string[8] = 'Alarm1.0'; {module name for standard interface}

  OurHotKey : Word = $051E;  {Ctrl + RightShift, 'A'}

  SwapPathName : String[64] = 'C:\';
  SwapPath1 : String[64] = 'ALARMSW1.$$$';
  SwapPath2 : String[64] = 'ALARMSW2.$$$';
  SwappingOn : Boolean = True;
  {******************* end of patch area ******************}

  ExtraParas : Word = (2*1024) div 16;  {2k extra on the heap}
  TimeMask   = 'hh:mmt';
  TimeLabel  = 'Current time';
  AlarmLabel = 'Alarm time';
type
  String10 = string[10];
  String80 = string[80];


const
  UIX1             = 20;
  UIY1             = 8;
  UIX2             = 60;
  UIY2             = 15;
  AlarmX           = UIX2 - 11;
  ALarmY           = UIY1 + 2;
  TimeX            = UIX1 + 2;
  TimeY            = UIY1 + 2;
  TimePromptX      = UIX1 + 2;
  TimePromptY      = UIY1 + 4;
  MsgPromptX       = TimePromptX;
  MsgPromptY       = TimePromptY + 1;

  TimePrompt       = 'Enter alarm time   : ';
  MsgPrompt        = 'Enter alarm message: ';
  MsgLen           = 15;

  BufferSize       = (UIX2 - UIX1) * (UIY2 - UIY1) * SizeOf(Word);
  MaxAlarmMsgLen   = (UIX2 - UIX1) - 2;

  {screen messages}
  ProgName  : string[36] = 'Alarm: A Simple PopUp Alarm Program';
  Copyright : string[22] = 'by TurboPower Software';
  LoadError : string[23] = 'Unable to install Alarm';
  AlarmMsg  : string[MaxAlarmMsgLen] = 'ALARM';
  DisableOurselves : Boolean = False; {if true, disable the TSR}
  AlarmAttr = $70;

var
  NormalAttr, HeaderAttr, FrameAttr : Byte;

  procedure Tone(Freq,Duration : Word);

  begin
    Sound(Freq);
    Delay(Duration);
    NoSound;
  end;

  procedure Beep;
  begin
    Tone(880,100);
    Tone(110,200);
    Tone(440,100);
  end;

  procedure GetCurrentTime(var TR : TimeRec);
  {-Mystic assembly language routine to calculate current time fast.
    Based on routine by Bob Tolz.}
  begin
    inline(
      $B8/$40/$00/           {mov  ax,$40      ;read time from BIOS data area}
      $8E/$C0/               {mov  es,ax       ;INT $1A clears midnight flag!}
      $26/$8B/$0E/>$6E/      {mov  cx,es:[$6E]}
      $26/$8B/$16/>$6C/      {mov  dx,es:[$6C]}
      $89/$C8/               {mov ax,cx        ;magically calculate the time}
      $89/$D3/               {mov bx,dx}
      $D1/$E2/               {shl dx,1}
      $D1/$D1/               {rcl cx,1}
      $D1/$E2/               {shl dx,1}
      $D1/$D1/               {rcl cx,1}
      $01/$DA/               {add dx,bx}
      $11/$C8/               {adc ax,cx}
      $92/                   {xchg dx,ax}
      $B9/$0B/$E9/           {mov cx,$E90B}
      $F7/$F1/               {div cx}
      $89/$C3/               {mov bx,ax}
      $31/$C0/               {xor ax,ax}
      $F7/$F1/               {div cx}
      $89/$DA/               {mov dx,bx}
      $B9/$C8/$00/           {mov cx,200}
      $F7/$F1/               {div cx}
      $80/$FA/$64/           {cmp dl,100}
      $72/$03/               {jb Under}
      $80/$EA/$64/           {sub dl,100}
      {Under:}
      $F5/                   {cmc}
      $88/$D3/               {mov bl,dl}
      $D1/$D0/               {rcl ax,1}
      $B2/$00/               {mov dl,0}
      $D1/$D2/               {rcl dx,1}
      $B9/$3C/$00/           {mov cx,60}
      $F7/$F1/               {div cx}
      $88/$D7/               {mov bh,dl}
      $F6/$F1/               {div cl}
      $86/$E0/               {xchg al,ah}
      $C4/$7E/<TR/           {les di,[bp+<TR]  ;ES:DI => time rec}
      $26/$88/$25/           {mov es:[di],ah   ;AH has hours}
      $26/$88/$45/$01/       {mov es:[di+1],al ;AL has minutes}
      $26/$88/$7D/$02);      {mov es:[di+2],bh ;BH has seconds (hundredths in BL)}
  end;


  function TimeToTicks(H,M,S,S100 : Byte) : LongInt;

  const
    TicsPerHr = 65543.3333;
    TicsPerMin = 1092.3889;
    TicsPerSec = 18.2065;
    TicsPerHun = 0.182065;

  begin
    TimetoTicks := Trunc((H*TicsPerHr)+(M*TicsPerMin)+
                         (S*TicsPerSec)+(S100*TicsPerHun));
  end;

  function TimeRecToTicks(TR : TimeRec) : LongInt;
  begin
    with TR do
      TimeRecToTicks := TimeToTicks(Hours, Minutes, Seconds, 0);
  end;

  procedure SetBiosClock;
    {-Set BIOS clock to match DOS's.}
  var
    BiosClock : LongInt absolute $40 : $6C;
    Regs : Registers;
  begin
    with Regs do begin
      AH := $2C;
      MsDos(Regs);
      BiosClock := TimetoTicks(CH,CL,DH,DL);
    end;
  end;

  function ParseTime(TimeS : String) : Boolean;
  var
    H, M, S : Integer;
  begin
    ParseTime := False;
    if Pos(':',TimeS) = 2 then
      TimeS := '0' + TimeS;
    if Length(TimeS) < Length(TimeMask) then begin
      if not Str2Int(Copy(TimeS, 1, 2), H) then
        Exit;
      if H > 12 then
        TimeS := TimeS + 'p'
      else
        TimeS := TimeS + 'a';
    end;
    if TimeStringToHMS(TimeMask,TimeS,H,M,S) then begin
      ParseTime := True;
      with popTime do begin
        Hours     := Byte(H);
        Minutes   := Byte(M);
        Seconds   := Byte(S);
      end;
    end;
  end;

  procedure UpdateTime;
  var
    TR : TimeRec;
    A  : Byte;
  begin
    GetCurrentTime(TR);
    with TR do
      FastWrite(TimeToTimeString(TimeMask, HMSToTime(Hours, Minutes, Seconds)),
                TimeY, TimeX, HeaderAttr);
    with popTime do
      if Hours <> $FF then
        FastWrite(TimeToTimeString(TimeMask,
                  HMSToTime(Hours, Minutes, Seconds)),
                  AlarmY, AlarmX, HeaderAttr)
      else
        FastWrite('<none>',AlarmY, AlarmX, FrameAttr);
  end;

  function GetKey : Word;
    {-Update the screen while waiting for a keystroke}
  begin
    while not KeyPressed do begin
      {make sure other TSRs can pop up}
      inline($CD/$28);
      UpdateTime;
    end;
    GetKey := ReadKeyWord;
  end;

  procedure SetAlarmTime(TR : TimeRec);
  begin
    AlarmData^.AlarmTicker := TimeRecToTicks(TR);
  end;

  procedure UserInterface;
  var
    TR : TimeRec;
    A,B  : Byte;
    UseMono : Boolean;
    S : String[MaxAlarmMsgLen];
  begin
    case CurrentMode of
      2, 7 : UseMono := True;
      else UseMono := False;
    end;
    if UseMono then begin
      FrameAttr  := ScreenColors.FrameMono;
      HeaderAttr := ScreenColors.HeaderMono;
      NormalAttr := ScreenColors.TextMono;
    end
    else begin
      FrameAttr  := ScreenColors.FrameColor;
      HeaderAttr := ScreenColors.HeaderColor;
      NormalAttr := ScreenColors.TextColor;
    end;
    ClearWindow(UIX1, UIY1, UIX2, UIY2, ' ',NormalAttr);
    FrameWindow(UIX1, UIY1, UIX2, UIY2, FrameAttr, HeaderAttr, 'ALARM');
    FastWrite(TimeLabel, TimeY-1, TimeX, NormalAttr);
    FastWrite(AlarmLabel, AlarmY-1, AlarmX, NormalAttr);

    {prompt for alarm time}
    with LE do begin
      S := '';
      ReadString(TimePrompt, TimePromptY, TimePromptX, 6, 6, S);
      if Length(S) = 0 then
        Exit;
      if (GetLastCommand <> ccQuit) then begin

        {if valid time, prompt for alarm string}
        if ParseTime(S) then begin
          S := '';
          ReadString(MsgPrompt, MsgPromptY, MsgPromptX,
                     MaxAlarmMsgLen, MsgLen, S);
          if GetLastCommand <> ccQuit then
            AlarmMsg := S;
          SetAlarmTime(popTime);
        end
        else begin
          FastWrite('Invalid time <press any key>', MsgPromptY, MsgPromptX,
                    NormalAttr);
          Tone(110, 800);
          if ReadKey = #0 then ;
        end;
      end;
    end;
  end;

  procedure PopupEntryPoint;
    {-This is the entry point for the popup}
  var
    SaveXY, SaveSL : Word;   {for saving cursor position and shape}
    ScrWidth,ScrHeight : Word;
  begin
    {reinitialize CRT}
    ReInitCrt;
    {exit if not in 80-column text mode}
    if InTextMode and (ScreenWidth >= UIX2) then begin
      {initialize screen stuff}
      GetCursorState(SaveXY, SaveSL);
      HiddenCursor;
      if not SaveWindow(UIX1,UIY1,UIX2,UIY2,False,ScrBuf) then begin
        Tone(110,500);
        Exit;
      end;

      UserInterface;

      {restore cursor and screen}
      RestoreCursorState(SaveXY, SaveSL);
      RestoreWindow(UIX1,UIY1,UIX2,UIY2,False,ScrBuf);
    end
    else
      Tone(110,800);
  end;

  procedure EntryPoint;
  var
    WindowDisplayed : Boolean;
    P : Pointer;
    CurInt1C : Pointer;                               {!!.03}
  begin
    {on entry into this popup routine, UserData will contain zero if this
    popup is being called to display the alarm, and one if it is an unload
    request}
    if LongInt(CSSwapData^.ThisIFC.UserData) <> 0 then begin
      if not CSSwapData^.SwapEnabled then begin       {!!.03}
        GetIntVec($1C, CurInt1C);                     {!!.03}
        SetIntVec($1C, OrigInt1C);                    {!!.03}
      end;                                            {!!.03}
      if DisableTSR then begin
        {the following code needs a little explaining:
         The swap system keeps a table of the entire interrupt vector table.
         When a swappable TSR goes resident, a snapshot of the vector table is
         taken, and all vectors (except those needed by the TSR manager) are
         restored. When the popup is envoked, the contents of the saved vector
         table are swapped with the current contents of the physical ISR
         table. Therefore, in order to "undo" the int 1Ch handler in use by
         this program, we need to poke the int 1Ch handler that was in use
         before we took it over into the saved table, so the original vector
         will be restored when the popup pops down. Vectors that are taken
         over by OpSWAP explicitly do not require this step. The undocumented
         routine SetVecOnReturn is used to poke the vector into the table.
        }
        SetVecOnReturn($1C, OrigInt1C);
        LongInt(CSSwapData^.ThisIFC.UserData) := 1 {inform caller we succeeded}
      end
      else begin                                   {!!.03}
        if not CSSwapData^.SwapEnabled then        {!!.03}
          SetIntVec($1C, CurInt1C);                {!!.03}
        LongInt(CSSwapData^.ThisIFC.UserData) := 0;{inform caller we failed}
      end;                                         {!!.03}
      Exit;
    end;

    ReinitCrt;
    if InTextMode then
      WindowDisplayed := SaveWindow(1, 1, ScreenWidth, 2, True, P)
    else
      WindowDisplayed := False;

    if WindowDisplayed then begin
      FastWrite(Center(AlarmMsg, ScreenWidth), 1, 1, NormalAttr);
      FastWrite(Center('<press any key to clear>', ScreenWidth),
                2, 1, NormalAttr);
    end;
    repeat
      Beep;
      Delay(500);
    until KeyPressed;
    if ReadKey = #0 then ; {clear the keyboard buffer}
    if WindowDisplayed then
      RestoreWindow(1, 1, ScreenWidth, 2, True, P);
  end;

  {$F-}

  procedure Abort(Message : string);
    {-Display Message and Halt with error code}
  begin
    WriteLn(Message);
    Halt(1);
  end;

  procedure Warning(Message : String);
    {-Display warning message, wait for keypress, if key is ESC, then Abort}
  var
    C : Char;
    X,Y : Byte;
  begin
    WriteLn('WARNING: ',Message);
    WriteLn;
    X := WhereX;
    Y := WhereY;
    Write('Press any key to continue (ESC to abort)...');
    C := ReadKey;
    GotoXY(X,Y);
    ClrEOL;
    if C = ^[ then
      Abort('Aborting at user''s request...');
  end;

  procedure DisableYourself;
    {-Unload resident copy of Alarm (if possible) and report results}
  var
    IFC : IfcPtr;
    Save : Boolean;

  begin
    ShutDownProc;
    RestoreAllVectors;
    IFC := ModulePtrByName(ModuleName);   {get the IFCPtr for this module}
    if IFC <> NIL then begin              {make sure it is already installed}
      Save := IFC^.CSDataPtr^.SwapMsgOn;  {save state of swap messages}
      IFC^.CSDataPtr^.SwapMsgOn := False; {disable swap messages}
      Write('Attempting to unload Alarm...');
      LongInt(IFC^.UserData) := 1;
      IFC^.CmdEntryPtr;                   {call the CmdEntryPtr}
      WriteLn(^M^J);
      if LongInt(IFC^.UserData) = 1 then  {check status of Unload attempt}
        WriteLn('Alarm unloaded')
      else
        WriteLn('Unable to unload Alarm');
      IFC^.CSDataPtr^.SwapMsgOn := Save;  {restore state of swap messages}
    end
    else
      WriteLn('Alarm not installed, so it can not be unloaded!');
    Halt;
  end;

  procedure ShowHelp;
    {-Displays help message with Alarm options}
  begin
    WriteLn(^M^J'Usage: Alarm [Options]'^M^J);
    WriteLn('Options are:');
    WriteLn('  /U          unload Alarm from memory');
    WriteLn('  /N          indicates not to use swapping');
    WriteLn('  /E          indicates not to use EMS');
    WriteLn('  /M          indicates to squelch swapping messages');
    WriteLn('  /Ppathname  specifies pathname to use for swapping');
    WriteLn('  /?          displays this help screen');
    Halt(0);
  end;

  procedure ParseCommandLine;
  var
    I : Word;
    Opt : String;

    procedure InvalidOption;
    begin
      WriteLn(Opt,' is an invalid option');
      ShowHelp;
    end;

  begin
    for I := 1 to ParamCount do begin
      Opt := ParamStr(I);
      if (Opt[1] in ['/','-']) and (Length(Opt) >= 2) then begin
        case UpCase(Opt[2]) of
          'U' : DisableYourself;
          'N' : SwappingOn := False;
          'E' : SwapUseEMS := False;
          'M' : SetSwapMsgOn(False);
          'P' : begin
                  SwapPathName := StUpcase(Copy(Opt,3,Length(Opt)));
                  if SwapPathName[Length(SwapPathName)] <> '\' then
                    SwapPathName := SwapPathName + '\';
                end;
          '?' : ShowHelp;
          else
            InvalidOption;
        end;
      end
      else
        if ParseTime(Opt) then begin
          SetAlarmTime(popTime);
          if ParamCount >= Succ(I) then begin
            AlarmMsg := ParamStr(Succ(I));
            Exit;
          end;
        end
        else
          Abort(Opt+' is an invalid time');
    end;
  end;

  function DriveIsFixed(Drive : Char) : Boolean;
    {-Return true if drive is not removable}
  var
    SubDrive : Char;

  begin
    case GetDiskClass(Drive,SubDrive) of
      Floppy360,Floppy720,
      Floppy12,Floppy144,
      OtherFloppy       : DriveIsFixed := False;
      else DriveIsFixed := True;
    end;
  end;

  function PathIsValidFixedDisk(Path : String) : Boolean;
    {-Return true if drive specified by Path is a valid fixed disk}
  var
    Drive : Char;
    F : File;
  begin
    Assign(F,SwapPathName+SwapPath1);
    Rewrite(F,1);
    if IoResult <> 0 then
      Abort('Cannot create swap file - Invalid path or drive not ready');
    Close(F);
    if IoResult <> 0 then
      Abort('Error closing swap file');
    if Path[2] = ':' then
      Drive := UpCase(Path[1])
    else
      Drive := DefaultDrive;
    PathIsValidFixedDisk := DriveIsFixed(Drive);
  end;

  function DriveNoFromPath(Path : String) : Byte;
    {-Return the DOS drive number from the pathname}
  begin
    if Path[2] = ':' then
      DriveNoFromPath := Ord(UpCase(Path[1])) - (Ord('A') - 1)
    else
      DriveNoFromPath := 0;
  end;

  function EnoughDiskSpaceForSwap(Paras : Word) : Boolean;
    {-Returns true if enough disk space for swap files}
  begin
    EnoughDiskSpaceForSwap := DiskFree(DriveNoFromPath(SwapPathName)) >=
                              (SwapSize(Paras) * 2);
  end;

  procedure InitAlarm;
    {-Called from Alarm.Pas to initialize Alarm}
  var
    SwapToEms : Boolean;
    Paras     : Word;

  begin
    FillChar(popTime, SizeOf(popTime), 0);
    popTime.Hours := $FF; {this value tells ALARM that no alarm time is set}

    {signon message}
    HighVideo;
    WriteLn(ProgName, ^M^J, Copyright, ^M^J);
    LowVideo;

    ParseCommandLine;

    if not GetMemCheck(ScrBuf, BufferSize) then
      Abort('Not enough heap memory for screen buffer');

    {set up alternate GetKey routine for OPSEDIT}
    SimpEditCommands.SetGetKeyProc(GetKey);
    if not LE.Init(ScreenColors) then
      Abort('Unable to initialize line editor (out of memory)');

    Paras := ParagraphsToKeep+ExtraParas;
    SwapToEms := WillSwapUseEms(Paras);

    {if not using EMS, then check for valid fixed disk and sufficient space}
    if (not SwapToEms) then begin
      {check to make sure the swap path refers to a valid FIXED disk}
      if (not PathIsValidFixedDisk(SwapPathName)) then
        Warning('The selected swap path refers to a removable drive!');
      {check for sufficient disk space for swap files}
      if not EnoughDiskSpaceForSwap(Paras) then
        Abort('Insufficient disk space for swap files on '+SwapPathName);
    end;
    {check to see if we're already installed}
    if ModuleInstalled(ModuleName) then
      Abort('Alarm is already loaded. Aborting...');

    {install the module}
    InstallModule(ModuleName, EntryPoint);

    {check to see if SideKick is loaded}
    if SideKickLoaded then
      Abort('Can''t be loaded after SideKick!');


    SetBiosClock;     {set the Bios clock = DOS Time of Day}

    {tell the CS relative ISR handler how to access the UserData field}
    AlarmData^.DataPtr := @CSSwapData^.ThisIFC.UserData;

    {save the current int 1Ch vector in case user asks to unload the TSR}
    GetIntVec($1C, OrigInt1C);

    {call the procedure to set up the int 1Ch handler (and exitproc)}
    StartUpProc;

    {go resident}
    if DefinePop(OurHotKey, PopupEntryPoint, Ptr(SSeg, SPtr)) then begin
      WriteLn('Alarm loaded. Press Ctrl-RightShift-A to activate.');

      {Enable popups}
      PopupsOn;
      if SwappingOn then begin
        if SwapToEms then begin
          WriteLn('Using EMS memory for swap');
          SetSwapMsgOn(False);
        end
        else begin
          WriteLn('Swapping to ',SwapPathName + SwapPath1);
          SetSwapMsgOn(True);
        end;
      end
      else
        WriteLn('Swapping disabled');

      case CurrentDisplay of
        MCGA,EGA,VGA : SetSwapMsgRow($FF);
      end;


      {terminate and stay resident}
      StayResSwap(ParagraphsToKeep+ExtraParas,
                  0,
                  SwapPathName + SwapPath1,
                  SwapPathName + SwapPath2,
                  SwappingOn);
    end;

    {if we get here we failed}
    Abort(LoadError);
  end;


end.