Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/TESS_P.ZIP/TSDAYTIM.PAS

Pascal/Delphi Source File | 1988-07-03 | 17.5 KB | 512 lines

{****************************************************************************
 * TSDAYTIM.PAS -- Turbo Pascal 4.0 demonstration program
 ***************************************************************************
 SUBTTL    TesSeRact Revision Level 1
 ;--------------------------------------------------------------------------
 ;   TesSeRact(tm) -- A Library of Routines for Creating Ram-Resident (TSR)
 ;                    programs for the IBM PC and compatible Personal
 ;                    Computers.
 ;
 ;The software, documentation and source code are:
 ;
 ;    Copyright (C) 1986, 1987, 1988 Tesseract Development Team
 ;    All Rights Reserved
 ;
 ;    c/o Chip Rabinowitz
 ;    Innovative Data Concepts
 ;    2084 Woodlawn Avenue
 ;    Glenside, PA 19038
 ;    1-215-884-3373
 ;
 ;--------------------------------------------------------------------------
 ;   This product supports the TesSeRact Standard for Ram-Resident Program
 ;   Communication.  For information about TesSeRact, contact the TesSeRact
 ;   Development Team at:
 ;       Compuserve:    70731,20
 ;       MCIMAIL:       315-5415
 ;   This MCIMAIL Account has been provided to the TesSeRact Development
 ;   Team by Borland International, Inc.  The TesSeRact Development Team
 ;   is in no way associated with Borland International, Inc.
 ;--------------------------------------------------------------------------}

PROGRAM TSDayTim;      { Copyright 1988 TesSeRact Development Team      }
{$R-,S-,I-,D+,T+,F-,V-,B-,N-,L+ }
{$M 1024,0,0 }          { this line needed to reduce stack and heap!      }
Uses DOS, CRT, TESSTP;      { program redone 02-24-88, Jim Kyle, for RDT      }
{*************************************************************************
 *  This program is a VERY simple-minded TSR that merely displays the     *
 *  time and date in the top RH corner, and which can also pop up and     *
 *  remove itself from memory.    All of the fancy frills (snow-free write *
 *  to CGA screens, full compatibility with EGA/VGA modes, file I/O, and *
 *  the like) have been left out, to concentrate on those actions which  *
 *  are REQUIRED to interface TesSeRact with Turbo Pascal 4 programs.     *
 *************************************************************************}

              { first we declare constants and such.......      }
CONST
  MAXVIDSIZE =     2000 ;         { TP4 version only uses 80x25      }
  MONONORM =     $07 ;
  MONOREV =     $70 ;

VAR
 savescreen : array [1..MAXVIDSIZE] of word ;
                    { buffer to save screen image      }
 NormAtt,                { Default Normal Attribute      }
 RevAtt,                { Default Reverse Attribute      }
 curmode,                { Current video mode          }
 oldcur,                { Old Cursor shape          }
 oldpos : word;             { Old Cursor position          }
 biosvid : pointer;            { Pointer to video buffer      }
 BackStack : array [0..1023] of char;    { Stack area for BackGround      }
 buffer : array [0..17] of byte ;    { work buffer for date/time format}
 BackFlag : word;            { Background flag to signal      }
                    {   additional processing      }
 idnum,                 { TSR Identification Number      }
 hours,                 { Current hour of day          }
 mins,                    { Current minute of hour      }
 secs,                    { Current seconds of minute      }
 yr,                    { for date report          }
 mon,
 day,
 ticks : word;                { Timer-tick counter          }
 regs  : registers;            { workspace for INTR interfaces   }

{***********************************************************
 *  Video Support Routines                   *
 *********************************************************CR}

PROCEDURE c_str( row : integer; str : string );
                    { Print a string, centered      }
  VAR
    wid : integer;            { temporary width variable      }
  BEGIN
    wid := (80 - length(str)) SHR 1;    { calculate cursor position      }
    gotoxy(wid, row);            { go there              }
    write(str);             { display the string          }
  END;

PROCEDURE getscrn;            { very primitive screen saver      }
  BEGIN                 { WILL snow with CGA...       }
    move( biosvid^, savescreen, sizeof(savescreen) );
  END;

PROCEDURE putscrn;            { very primitive screen restore   }
  BEGIN                 { WILL snow with CGA...       }
    move( savescreen, biosvid^, sizeof(savescreen) );
  END;

PROCEDURE SaveCursor;            { save current cursor size and      }
  BEGIN                 {   position              }
    Regs.AH := 3;            { Get Cursor Position          }
    Regs.BH := 0;
    Intr( $10, Regs );
    oldpos := Regs.DX;            { Save return values          }
    oldcur := Regs.CX;
                    { known bug on some monochrome      }
                    {   adapters reports the wrong      }
                    {   cursor shape when both color  }
                    {   and monochrome systems are      }
                    {   installed.              }
    IF( (curmode = MONO) AND  (oldcur = $0607) ) THEN
    oldcur := $0c0d;
    Regs.AH := 1;
    Regs.CX := $ffff;
    Intr( $10, Regs );
  END;

PROCEDURE RestoreCursor;        { restore saved cursor position   }
  BEGIN                 {   and size              }
    Regs.AH := 2;            { restore saved position      }
    Regs.BH := 0;
    Regs.DX := oldpos;
    Intr( $10, Regs );
    Regs.AH := 1;            { restore saved cursor type      }
    Regs.BH := 0;
    Regs.CX := oldcur;
    Intr( $10, Regs );
  END;

{****************************< FixRows         >******************************
*                                        *
*          Determine current video mode and set it up            *
*          ------------------------------------------            *
*                                        *
*   This function determines the current video mode at popup time, and        *
*    if it is one of the four text modes sets to 80 columns, the        *
*    default color scheme, and initializes the video RAM pointer.        *
*   Note that this program does NOT restore to 40-column mode after popping *
*    up; that, like de-snowing the video, is left for you to program.    *
*                                        *
*   Parameters:                                 *
*    None                                    *
*                                        *
*   Returns:                                    *
*    None                                    *
*                                        *
*************************************************************************CR}

PROCEDURE fixrows;            { Re-initialize current video      }
  BEGIN                 {   information for new instance  }
                    {   of video usage          }
    curmode := word( mem[$40:$49] );    { Get current mode at popup      }
    CASE (curmode) OF            { deal with text modes          }
      BW40:
    BEGIN
      textmode(BW80);        { we need 80 columns          }
      NormAtt := MONONORM;        { use Monochrome Attributes      }
      RevAtt := MONOREV;
    END;
      BW80, MONO:
    BEGIN
      NormAtt := MONONORM;        { use Monochrome Attributes      }
      RevAtt := MONOREV;
    END;
      C40:
    BEGIN
      textmode(C80);        { we need 80 columns          }
                    { use Color attributes          }
      NormAtt := (YELLOW + (BLUE SHL  4)) ;
      RevAtt := (WHITE + (RED SHL  4)) ;
    END;
      C80:
    BEGIN                { use Color attributes          }
      NormAtt := (YELLOW + (BLUE SHL  4)) ;
      RevAtt := (WHITE + (RED SHL  4)) ;
    END;
      END;

    IF(curmode = MONO) THEN        { If monochrome ....          }
      biosvid := ptr($b000,124)     { ... set pointer          }
    else                { That means color ....       }
      biosvid := ptr($b800,124);    { ... so set pointer          }
  END;

{****************************< SizeOfCode    >******************************
*                                        *
*          Determine size of program to keep resident            *
*          ------------------------------------------            *
*                                        *
*   This function is an example of a function that can be used to determine *
*    the size of the TSR that is to remain resident.  For use with TP4,  *
*    no parameters are supplied and the value is like that for ALLHEAP   *
*    with MSC 5.0 or Turbo C 1.5; the stack is below the heap and the    *
*    entire heap and stack are counted in the value.             *
*                                        *
*   Parameters:                                 *
*    None                                    *
*                                        *
*   Returns:                                    *
*    Number of 16-byte paragraphs of memory to keep when going resident. *
*                                        *
*************************************************************************CR}

FUNCTION SizeOfCode : word;
  VAR
    used : word;
  BEGIN
  used := Seg(HeapPtr^) - PrefixSeg;    { these are built-ins for TP4..   }
  SizeOfCode := used;            { return number of paragraphs      }
END;

{****************************< do_cpyrt      >******************************
*                                        *
*            Display Copyright Information                *
*            -----------------------------                *
*                                        *
*   Function to display formatted copyright information on the screen.        *
*                                        *
*   Parameters:                                 *
*    none                                    *
*                                        *
*   Returns:                                    *
*    none                                    *
*                                        *
*************************************************************************CR}

PROCEDURE do_cpyrt;
  BEGIN
    ClrScr;
    textattr := RevAtt;
    c_str(2, ' TesSeRact Date/Time Demonstration Program ');
    textattr := NormAtt;
    c_str(4, 'Copyright 1986, 1987, 1988, TesSeRact Development Team');
    c_str(5, 'All Rights Reserved');
  END;

{****************************< DisplayTime   >******************************
*                                        *
*              'Poke' current time into video RAM                    *
*              ----------------------------------            *
*                                        *
*   Converts the date and time values from binary to ASCII, then pokes        *
*    into rightmost 18 locations of the Video RAM segment for top row.   *
*                                        *
*   Parameters:                                 *
*    none                                    *
*                                        *
*   Returns:                                    *
*    none                                    *
*                                        *
*************************************************************************CR**}

PROCEDURE DisplayTime;
  VAR
     i: integer ;
     j: integer ;
     vidram : pointer;
  BEGIN
    vidram := biosvid;
    yr := yr MOD 100;
    buffer[0]  := (mon     DIV 10) + $30;
    buffer[1]  := (mon     MOD 10) + $30;
    buffer[2]  := ORD('/');
    buffer[3]  := (day     DIV 10) + $30;
    buffer[4]  := (day     MOD 10) + $30;
    buffer[5]  := ORD('/');
    buffer[6]  := (yr     DIV 10) + $30;
    buffer[7]  := (yr     MOD 10) + $30;
    buffer[8]  := ORD(' ');
    buffer[9]  := ORD(' ');
    buffer[10] := (hours DIV 10) + $30;
    buffer[11] := (hours MOD 10) + $30;
    buffer[12] := ORD(':');
    buffer[13] := (mins  DIV 10) + $30;
    buffer[14] := (mins  MOD 10) + $30;
    buffer[15] := ORD(':');
    buffer[16] := (secs  DIV 10) + $30;
    buffer[17] := (secs  MOD 10) + $30;
    FOR i := 0 TO 17 DO
      BEGIN
    j := word(vidram^) AND $FF00;
    j := j OR buffer[i];
    word(vidram^) := j;
    vidram := pointer( longint( vidram ) + 2 );
      END
  END;

{****************************< AdjustTime    >******************************
*                                        *
*              Call DOS to get the current time                *
*              --------------------------------                *
*                                        *
*     Calls DOS to get the current time into appropriate global values,     *
*   then adjusts the "ticks" value more accurately from the 1/100 sec       *
*   value returned by DOS.  Repeats to get date similarly.            *
*                                        *
*   Parameters:                                 *
*    none                                    *
*                                        *
*   Returns:                                    *
*    none                                    *
*                                        *
*************************************************************************CR**}

PROCEDURE AdjustTime;
  VAR
    WkDy,
    Sec100 : word;
  BEGIN
    gettime( hours, mins, secs, Sec100 );
    ticks := longint(91 * (100 - Sec100)) div 500;
    getdate( yr, mon, day, wkdy );
  END;

{****************************< InitTsrDemo   >******************************
*                                        *
*               Initialize variables and video                *
*               ------------------------------                *
*                                        *
*   This function just initializes everything, displays a sign-on message,  *
*    and gets the clock info for the first time.                *
*                                        *
*   Parameters:                                 *
*    none                                    *
*                                        *
*   Returns:                                    *
*    none                                    *
*                                        *
*************************************************************************CR**}

PROCEDURE InitTsrDemo;
  BEGIN
    curmode := LastMode AND $7F;    { save current mode for later      }
    fixrows;
    window(1,1,80,8);
    textattr := NormAtt;
    do_cpyrt;
    c_str(7,' Press Alt-LeftShift-T to activate the TesSeRact Demonstration Program ');
    AdjustTime;
    DisplayTime;
  END;

{*************************************************************
 *   TSR Procedures                         *
 *********************************************************CR**}

{$F+} PROCEDURE TsrMain; {$F-}
  VAR
    oldstat, ret : word;

  BEGIN
    SaveCursor;
    fixrows;                { determine video mode        }
    CASE (curmode) OF
      0..3, 7:                { if in any text mode....    }
    BEGIN
      window(1,1,80,25);
      getscrn;            { save current screen first..    }
      textattr := (NormAtt);
      clrscr;            { wipe it clean for the popup    }
      do_cpyrt;
      oldstat := TsGetStat(idnum); { get the RM status word    }

      gotoxy(5,7);
      write('This TSR is currently using the following procedures:');
      IF(oldstat AND TSRUSEPOPUP)<>0 THEN
        BEGIN
          gotoxy(10,wherey+1);
          write('User-Defined PopUp Procedure');
        END;
      IF(oldstat AND TSRUSEBACK)<>0 THEN
        BEGIN
          gotoxy(10,wherey+1);
          write('User-Defined Background Procedure');
        END;
      IF(oldstat AND TSRUSETIMER)<>0 THEN
        BEGIN
          gotoxy(10,wherey+1);
          write('User-Defined Timer Procedure');
        END;
      IF(oldstat AND TSRUSEUSER)<>0 THEN
        BEGIN
          gotoxy(10,wherey+1);
          write('User-Defined User Communication Procedure');
        END;

    c_str(24,'Press "R" to remove TSR from memory; any other key to return');

      repeat            { wait for any keypress     }
        ret := ord(ReadKey);
      until ret <> 0;
      IF(char(ret AND $5F) = 'R') THEN
        ret := TsRelease(idnum);    { release if requested to do so }
      putscrn;            { put screen back as it was    }
      RestoreCursor;
    END                {   of text mode popup        }
      ELSE                { If in graphics mode ....    }
    TessBeep;            {   Beep and exit        }
    END;    { of CASEs }

  END;

{$F+} FUNCTION TsrBackCheck : word; {$F-}
  BEGIN
    TsrBackCheck := (BackFlag);
  END;

{$F+} PROCEDURE TsrBackProc; {$F-}
  BEGIN
    AdjustTime;     { call DOS to resynchronize the display  }
    DisplayTime;
    BackFlag := 0;
  END;

{$F+} PROCEDURE TsrTimerProc; {$F-}
{   This procedure comes up at each timer tick, and sets the flag to
  request background processing once each second.
    The background procedure does the actual screen display and corrects
  the "ticks" counter to the proper value, depending on when it gains
  control.
}
  BEGIN
    DEC ( ticks );            { bump the tick counter  }
    IF (ticks < 1) OR (ticks > 20) THEN { catch any outofrange     }
      BEGIN
    ticks := 20;
    BackFlag := 1;        { ask background to upd  }
      END;    { of second counted }
  END;

{$F+} PROCEDURE TsrUserProc( UserPtr : pointer ); {$F-}
  BEGIN
    write('This is the user procedure:  Passed ptr = ');
    writeln( seg(UserPtr^), ':', ofs(UserPtr^), ' (decimal)' );
  END;

{$F+} PROCEDURE TsrCleanUp ( RemoveTSR : Boolean ); {$F-}
{ This procedure, added in version 0.70, permits a TSR to "wipe its feet"
  at release time, and MUST be used to perform the initialization code.
  It is called twice by the TesSeRact routines: once, with RemoveTSR set
  FALSE, from DoTsrInit, and again, with RemoveTSR set TRUE, from the
  ReleaseTSR function.    If a TSR has files open, it can close them.  Here,
  only a CRT message is produced.
}
  BEGIN
    IF (RemoveTSR) THEN
      BEGIN
    Writeln( 'TSR Demo has been removed from memory.' );
    ErrorAddr := NIL; { ALL: !!!THIS!!! was the bug that killed us }
      END
    ELSE
      BEGIN        { install (setup) the TSR }
    InitTsrDemo;
      END
  END;

{****************************< main         >******************************
*                                        *
*   Simple-minded main.  Calculates top of background stack region,        *
*    sets the stack points for the TSR; tests to see if we are already   *
*    resident; if so, displays ID number and exits.    If it is OK        *
*    to install, calls InitTsrDemo, and then goes resident with        *
*    DoTsrInit().                                *
*                                        *
*   Parameters:                                 *
*    none                                    *
*                                        *
*   Returns:                                    *
*    none                                    *
*                                        *
*************************************************************************CR}
VAR
    tsrname  : string[8];
    defptr,
    stackptr : pointer;         { Pointer to top of Background      }
                    {   stack area              }
BEGIN
    DirectVideo := False;        { force I/O to go through BIOS      }
    tsrname := 'TSDAYTIM';
    TsSetAdrTP4( @TsrTimerProc, 0 );     { must set runtime addresses      }
    TsSetAdrTP4( @TsrBackProc,  1 );     { to our own procedures       }
    TsSetAdrTP4( @TsrMain,      2 );
    TsSetAdrTP4( @TsrBackCheck, 3 );
    TsSetAdrTP4( @TsrUserProc,  4 );
    TsSetAdrTP4( @TsrCleanUp,   5 );
    defptr := NIL;            { necessary due to TP type checks }
    stackptr := @BackStack[(sizeof(BackStack)-3)];
                    { Calculate new stack pointer      }
                                        { See TSINTVEC.PAS for split stks }
    TsSetStack(defptr^, stackptr^);    { Set Popup Stack to defptr and   }
                    {   background stack to stackptr  }

                    { Are we already here? note [1].. }
    IF(TsCheckResident( tsrname[1], idnum ) = $ffff) THEN
      BEGIN                { Yep!                  }
    writeln('The TesSeRact Date/Time Demo TSR has already been loaded.');
    writeln('  Use ALT-LeftShift-T to PopUp the TsrMain() routine.');
    write  ('  Use ID Number ', idnum, ' to communicate through ');
    writeln( 'TesSeRact Multiplex functions.');
    halt(1);
      END;

    ClrScr;

    IF( TsDoInit(              { Try to go resident; no return    }
    TSRHOT_T,
    TSRPOPALT + TSRPOPLSHIFT,
    TSRUSEPOPUP + TSRUSEBACK + TSRUSETIMER + TSRUSEUSER,
    SizeOfCode)<>0 ) THEN          { returns only if attempt failed    }
      writeln('DoTsrInit function failed!');

END.