C!T ROM 2/ctrom_ii_b.zip/ctrom_ii_b/PROGRAM/PASCAL/DAVEY/DAVEYLIB.PAS

Pascal/Delphi Source File | 1993-11-15 | 69KB | 1,996 lines

UK Copyright (c) Peter Davey, November 1993

This file contains three concatenated Borland Pascal units in source form.

Use a standard text editor to separate them.

SYS.PAS  adds some definitions and improvements that I use a great deal.
TIMEPACK.PAS  has lots of goodies for date manipulation.
NOVELL.PAS  has a number of useful routines that access the Netware API.

--------------------------------------------------------------------------------

{ Save the first section as SYS.PAS }

Unit Sys;

Interface

USES Dos;

CONST
  ValidFileChars  = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890';
  PathLength      = 65;  { This includes the drive designation. }
  MaxStringLength = 255;
  Escape          = #27;
  MaxByte         = $FF;
  ReadOnly        = $01;
  Hidden          = $02;
  SysFile         = $04;
  VolumeID        = $08;
  Directory       = $10;
  Archive         = $20;
  Bell            = #7;


TYPE
  PathName      = DirStr;

  { Cleans up, IMHO, Borland's way of accessing DOS registers and flags. }
  FlagBits      = (CarryFlag, f1, ParityFlag, f3, AuxCarryFlag, f5, ZeroFlag, SignFlag,
                   TrapFlag, InterruptFlag, DirectionFlag, OverflowFlag, f12, f13, f14, f15);
  registers     = record
                    case INTEGER of
                      1 : (ax,bx,cx,dx,bp,si,di,ds,es : WORD;
                          flags : set of FlagBits);
                      2 : (al,ah,bl,bh,cl,ch,dl,dh : BYTE);
                      3 : (Reg : Dos.registers)
                    end;

  GenStr        = String[MaxStringLength];
  DOSFileName   = DirStr;
  ShortFileName = String[12];
  { Use the following to get at the keyboard flags. }
  LockFlagSet   = SET OF (RightShift,
                          LeftShift,
                          ControlShift,
                          AltShift,
                          ScrollLock,
                          NumLock,
                          CapsLock,
                          InsertMode);
  DTArecord     = RECORD
                    Reserved  : ARRAY [0 .. 20] OF BYTE;
                    Attribute : BYTE;
                    Time, Date,
                    LowSize,
                    HighSize  : INTEGER;
                    Name      : ARRAY [1 .. 13] OF CHAR
                  END;
  DTAptr        = ^DTArecord;
  CommandStr    = ComStr;

VAR
  Locks         : LockFlagSet ABSOLUTE $0000:$0417;
  CommandTail   : ComStr;
  Successful    : BOOLEAN;

PROCEDURE Shell(Tail : STRING);

PROCEDURE ChMod(Attributes, FileName : DirStr);

(****************************************************************************)

Implementation

(****************************************************************************)

PROCEDURE Shell(Tail : STRING);

{ e.g. Shell('DIR > TEMP'); }

  BEGIN
    IF Tail > ' ' THEN Insert(' /C', Tail, 1);
    Exec(GetEnv('COMSPEC'), Tail)
  END;

(****************************************************************************)

PROCEDURE ChMod(Attributes, FileName : DirStr);

{ After the Unix call of the same name.  Sets or clears attribute bits. }

VAR Current : WORD;
    Count   : BYTE;
    State   : (On, Off);
    F       : FILE;

  PROCEDURE SetFlag(Flag : Word);

    BEGIN
      IF State=On
        THEN Current := Current OR Flag
        ELSE Current := Current AND NOT Flag
    END;

  BEGIN
    Assign(F, FileName);
    GetFattr(F, Current);
    IF DosError = 0 THEN
      BEGIN
        State := On;
        FOR Count := 1 TO length(Attributes) DO
          CASE UpCase(Attributes[Count]) OF

            '+' : State := On;
            '-' : State := Off;
            'R' : SetFlag(ReadOnly);
            'H' : SetFlag(Hidden);
            'S' : SetFlag(SysFile);
            'A' : SetFlag(Archive);

            ELSE
              BEGIN
                write('Illegal argument, "');
                IF State = On
                  THEN Write('+')
                  ELSE Write('-');
                WriteLn(Attributes[Count], '", to ChMod')
              END
          END;
        SetFattr(F, Current)
      END
  END;

(****************************************************************************)

{ Initialisation part - reads Command Tail before it is zapped! }

VAR  Ptr : BYTE;

  BEGIN
    Ptr := $80;
    REPEAT
      CommandTail[Ptr AND $7F] := chr(Mem[PrefixSeg:Ptr]);
      inc(Ptr)
    UNTIL Mem[PrefixSeg:Ptr] = 13
  END.

--------------------------------------------------------------------------------

{ Save the next section file as TIMEPACK.PAS }

{ This is my date and time library.  The formats are UK biased.  It
  would be easily americanised.  Check out StrToDate - accepts most valid
  date formats. }

Unit TimePack;

InterFace

USES   Dos, Sys;

{ Sorry to give you yet another standard for storing date/time info . . . }

TYPE   Date       = RECORD CASE BOOLEAN OF
                      TRUE  : (Year  : BYTE;
                               Month : 1 .. 12;
                               Day   : 1 .. 31);
                      FALSE : (Compare : ARRAY[1 .. 3] OF CHAR)
                    END;
       TimeRec    = RECORD CASE BOOLEAN OF
                      TRUE  : (Hour   : 0 .. 23;
                               Minute,
                               Second : 0 .. 59);
                      FALSE : (Compare : ARRAY[1 .. 3] OF CHAR)
                    END;
       TimeStr    = STRING[8];
       JulianDate = LongInt;

FUNCTION DayNum(Dt : Date) : BYTE; { Convert date to day-of-week number.  }

FUNCTION DayOfYear(Dt : Date) : WORD; { Ditto to day of year number. }

FUNCTION WeekNo(Dt : Date) : BYTE;  { Returns the business week number. }

PROCEDURE WeekToDate(Week : WORD; VAR Dt : Date);  { Returns the Monday of given week. }

FUNCTION DayOfWeek(Dt : Date) : String;  { Returns the day name of given date. }

FUNCTION JulianDay(Dt : Date) : JulianDate;  { Returns a modified serial date number.
                                               Not Julian date as officially defined. }

PROCEDURE JulToDate(Jdate : JulianDate; VAR Dt : Date);  { Converts "Julian" number to date }

FUNCTION DateDiff(First, Last : Date) : INTEGER;  { The difference in days between two dates. }

PROCEDURE DateAdd(Days : INTEGER; VAR Dt : Date);  { Adds so many days to the date. }

FUNCTION CompDate(Dt1, Dt2 : Date) : INTEGER;  { -1, 0 or +1 depending on camparison of two dates. }

FUNCTION LongDate(Dt : Date) : String;  { Date to full descriptive string. }

FUNCTION D__MMM__YY(Dt : Date) : String;  { e.g.  9 Mar 93 }

FUNCTION DD_MM_YYYY(Dt : Date) : String;  { e.g.  09-03-1993 }

FUNCTION D_M_Y(Dt : Date) : String;  { e.g.  9-3-93 }

FUNCTION DD_MMM_YY(Dt : Date) : String;  { 09-Mar-93 }

PROCEDURE GetDate(VAR Dt : Date);  { Gets DOS date into date variable }

PROCEDURE SetDate(Dt : Date);  { Sets DOS date from date variable }

FUNCTION LongTime : LongInt;  {  Returns DOS time since midnight in seconds }

FUNCTION Time : TimeStr;  { Returns DOS time as a string HH:MM:SS }

PROCEDURE GetTime(VAR Tm : TimeRec);  { Gets DOS time }

FUNCTION StrToTime(InputLine : String) : TimeStr;  { Converts a string to a time variable }

PROCEDURE SetTime(Tm : TimeStr);  { Sets DOS time }

FUNCTION StrToDayOfWeek(St : String) : INTEGER;  { Converts a day name to a day number from 0 - 6 }

FUNCTION StrToMonth(St : String) : INTEGER;  { Converts a month name to a number from 1 - 12 }

PROCEDURE StrToDate(InputLine : String; VAR Dt : Date; Default : Date);
{ Converts a valid date string (any format) to a date variable }

(****************************************************************************)

Implementation

CONST  Months     : ARRAY [1 .. 13] OF INTEGER = ( { March     }   0,
                                                   { April     }  31,
                                                   { May       }  61,
                                                   { June      }  92,
                                                   { July      } 122,
                                                   { August    } 153,
                                                   { September } 184,
                                                   { October   } 214,
                                                   { November  } 245,
                                                   { December  } 275,
                                                   { January   } 306,
                                                   { February  } 337,
                                                   { Dummy     } 366
                                                 );
       MonthName  : ARRAY [1 .. 12] OF STRING [9]
                  = ('January', 'February', 'March', 'April', 'May', 'June',
                     'July', 'August', 'September', 'October', 'November', 'December');

       DayName    : ARRAY [0 .. 6] OF STRING [6]
                  = ('Sun', 'Mon', 'Tues', 'Wednes', 'Thurs', 'Fri', 'Satur');

       DOSDefaultDate : Date = (Year : 80; Month : 1; Day : 1);

(****************************************************************************)

FUNCTION DayNum(Dt : Date) : BYTE;     { Convert date to day-of-week number.  }
                                       { This routine uses an arithmetical    }
VAR  Year  : INTEGER;                  { trick very similar to Zeller's       }
     Month : 1 .. 12;                  { congruence algorithm.                }

  BEGIN
    Year := Dt.Year + 1900;            { The Date structure works 1900 - 2155 }
    IF Dt.Month > 2                    { We offset the months so that the     }
      THEN Month := Dt.Month - 2       { year begins with March.              }
      ELSE
        BEGIN
          Month := Dt.Month + 10;      { If we are in January or February     }
          Year := pred(Year)           { then we assume the previous year.    }
        END;
    DayNum := (Year                    { Each year advances one day of week.  }
             + Year DIV 4              { Every fourth year is a leap year.    }
             - Year DIV 100            { Except when it is divisible by 100   }
             + Year DIV 400            { unless it is also divisible by 400.  }
             + Month * 16 MOD 27       { This is my answer to Zeller!!        }
             + Dt.Day                  { And of course then we add the day... }
             ) MOD 7                   { ... finally giving the day number.   }
  END;

(****************************************************************************)

FUNCTION DayOfYear(Dt : Date) : WORD;

VAR Temp : WORD;
    LY   : BYTE;

  BEGIN
    WITH Dt DO
      BEGIN
        IF Month < 3 THEN
          BEGIN
            Month := Month + 12;
            Year := Year - 1
          END;
        IF Year MOD 4 = 0
          THEN LY := 1
          ELSE LY := 0;
        Temp := 28 * (Month - 3)
              + 13 * (Month + 1) DIV 5
              + Day + 49 + LY;
        IF Temp > (365 + LY) THEN Temp := Temp - 365 - LY;
        DayOfYear := Temp
      END
  END;

(****************************************************************************)

FUNCTION WeekNo(Dt : Date) : BYTE;

VAR JD : WORD;
    LY,
    DN : BYTE;

  BEGIN
    DN := DayNum(Dt);
    WITH Dt DO
      BEGIN
        IF Month < 3 THEN
          BEGIN
            Month := Month + 12;
            Year := Year - 1
          END;
        IF Year MOD 4 = 0
          THEN LY := 1
          ELSE LY := 0;
        JD := 28 * (Month - 3)
            + 13 * (Month + 1) DIV 5
            + Day + 49 + LY - DN + 4;
        IF JD > (365 + LY)
          THEN JD := JD - 365 - LY;
        WeekNo := (JD + 6) DIV 7
      END
  END;

(****************************************************************************)

PROCEDURE WeekToDate(Week : WORD; VAR Dt : Date);  { Returns the Monday of given week. }

  BEGIN
    IF Week > 99
      THEN
        BEGIN
          Dt.Year := Week DIV 100;
          IF Dt.Year < 56 THEN Dt.Year := Dt.Year + 100
        END
      ELSE GetDate(Dt);
    Dt.Day := 3;
    Dt.Month := 1;
    JulToDate(JulianDay(Dt) - DayNum(Dt) - 6 + 7 * (Week MOD 100), Dt)
  END;

(****************************************************************************)

FUNCTION DayOfWeek(Dt : Date) : String;

  BEGIN
    DayOfWeek := DayName[DayNum(Dt)] + 'day'
  END;

(****************************************************************************)

FUNCTION JulianDay(Dt : Date) : JulianDate;

  BEGIN
    WITH Dt DO
      BEGIN
        IF Month > 2                   { We offset the months so that the... }
          THEN
            BEGIN
              Month := Month - 2;      { ...  year begins with March.        }
              Year := Year + 4         { The year is offset by 4.            }
            END
          ELSE
            BEGIN
              Month := Month + 10;     { If we are in January or February    }
              Year := Year + 3         { then we assume the previous year.   }
            END;
        JulianDay := JulianDate(Year) * 365
                   + Year DIV 4        { Every fourth year is a leap year    }
                   + Months[Month]     { This adds the necessary constant    }
                   + Day               { And of course then we add the day,  }
                   - 1401              { and subtract the offset value.      }
      END
  END;

(****************************************************************************)

PROCEDURE JulToDate(Jdate : JulianDate; VAR Dt : Date);

VAR  Year  : BYTE;
     Month : 1 .. 12;

  BEGIN
    IF Jdate < 1 THEN Jdate := 1;
    Jdate := Jdate + 1401;
    Year := trunc(Jdate / 365.25);         { Extract the year                }
    Jdate := Jdate - Trunc(Year * 365.25); { Reduce Jdate to day of year     }
    IF Jdate < 1                           { Integer multiples of 365.25 are }
      THEN                                 { always 29th February            }
        BEGIN
          Dt.Day := 29;
          Dt.Month := 2;
          Dt.Year := Year - 4
        END
      ELSE
        BEGIN
          Month := 1;                       { Starting from March...         }
          WHILE Months[succ(Month)] < Jdate { Count through the months until }
            DO Month := succ(Month);        { we find the right one, then    }
          Dt.Day := trunc(Jdate - int(Months[Month]));  { subtract to get day of month.  }
          IF Month > 10                     { Since we are beginning our     }
            THEN                            { year with March, we have to    }
              BEGIN                         { correct the offset now.        }
                Dt.Year := Year - 3;
                Dt.Month := Month - 10
              END
            ELSE
              BEGIN
                Dt.Year  := Year - 4;
                Dt.Month := Month + 2
              END
        END
  END;

(****************************************************************************)

FUNCTION DateDiff(First, Last : Date) : INTEGER;

  BEGIN
    DateDiff := trunc(JulianDay(Last) - JulianDay(First))
  END;

(****************************************************************************)

PROCEDURE DateAdd(Days : INTEGER; VAR Dt : Date);

  BEGIN
    JulToDate(JulianDay(Dt) + Days , Dt)
  END;

(****************************************************************************)

FUNCTION CompDate(Dt1, Dt2 : Date) : INTEGER;

  BEGIN
    IF Dt1.Compare = Dt2.Compare THEN CompDate := 0
      ELSE IF Dt1.Compare > Dt2.Compare
        THEN CompDate := 1
        Else CompDate := -1
  END;

(****************************************************************************)

FUNCTION LongDate(Dt : Date) : String;

VAR  Day    : STRING [2];
     Suffix : STRING [3];
     Year   : STRING [4];

begin
  str(Dt.Day, Day);
  str(Dt.Year + 1900, Year);
  IF (Dt.Day MOD 10) = 1
    THEN Suffix := 'st '
    ELSE IF (Dt.Day MOD 10) = 2
      THEN Suffix := 'nd '
      ELSE IF (Dt.Day MOD 10) = 3
        THEN Suffix := 'rd '
        ELSE Suffix := 'th ';
  IF Dt.Day > 10
    THEN IF Dt.Day < 14
      THEN Suffix := 'th ';
  LongDate := DayOfWeek(Dt) + ', '
            + Day + Suffix
            + MonthName[Dt.Month] + ' '
            + Year
end;

(****************************************************************************)

FUNCTION D__MMM__YY(Dt : Date) : String;

var   Day : string[2];

begin
  str(Dt.Day, Day);
  D__MMM__YY := day + ' '
              + copy(MonthName[Dt.Month], 1, 3) + ' '
              + chr(Dt.Year MOD 100 DIV 10 + 48) + chr(Dt.Year MOD 10 + 48)
end;

(****************************************************************************)

FUNCTION DD_MM_YYYY(Dt : Date) : String;

VAR Century : STRING[2];

begin
  IF Dt.Year > 100 THEN Century := '20'
                   ELSE Century := '19';
  DD_MM_YYYY := chr(Dt.Day DIV 10 + 48) + chr(Dt.Day MOD 10 + 48) + '-'
              + chr(Dt.Month DIV 10 + 48) + chr(Dt.Month MOD 10 + 48) + '-'
              + Century
              + chr(Dt.Year MOD 100 DIV 10 + 48) + chr(Dt.Year MOD 10 + 48)
end;

(****************************************************************************)

FUNCTION D_M_Y(Dt : Date) : String;

VAR  Year, Month, Day : STRING[3];

begin
  Str(Dt.Year MOD 100, Year);
  Str(Dt.Month, Month);
  Str(Dt.Day, Day);
  D_M_Y := Day + '-' + Month + '-' + Year
end;

(****************************************************************************)

FUNCTION DD_MMM_YY(Dt : Date) : String;

begin
  DD_MMM_YY := chr(Dt.Day DIV 10 + 48) + chr(Dt.Day MOD 10 + 48) + '-'
             + copy(MonthName[Dt.Month], 1, 3) + '-'
             + chr(Dt.Year MOD 100 DIV 10 + 48) + chr(Dt.Year MOD 10 + 48)
end;

(****************************************************************************)

PROCEDURE GetDate(VAR Dt : Date);

var
  recpack:       registers;              {record for MsDos call}

begin
  recpack.Reg.ah := $2a;
  MsDos(recpack.Reg);                        { call function }
  with recpack.Reg do
  begin
    Dt.Year  := cx - 1900;
    Dt.Month := dh;
    Dt.Day   := dl
  end
end;

(****************************************************************************)

PROCEDURE SetDate(Dt : Date);

var
  recpack:       registers;              {record for MsDos call}

begin
  with recpack do
  begin
    AH := $2B;
    CX := Dt.Year + 1900;
    DH := Dt.Month;
    DL := Dt.Day
  end;
  MsDos(recpack.Reg)                      { call function }
end;

(*****************************************************************************)

function LongTime : LongInt;

var recpack : registers;                {assign record}

begin
  recpack.ah := $2c;
  intr($21,recpack.Reg);                {call interrupt}
  with recpack do
    LongTime := LongInt(ch * 60 + cl) * 60 + dh
end;

(****************************************************************************)

FUNCTION Time : TimeStr;

var
  recpack:          registers;           {assign record}

begin
  recpack.ah := $2c;
  MsDOS(recpack.Reg);                    {call interrupt}
  with recpack do
    begin
      time := chr(ch div 10 + 48) + chr(ch mod 10 + 48) + ':'
            + chr(cl div 10 + 48) + chr(cl mod 10 + 48) + ':'
            + chr(dh div 10 + 48) + chr(dh mod 10 + 48)
    end
end;

(****************************************************************************)

PROCEDURE GetTime(VAR Tm : TimeRec);

var
  recpack:          registers;           {assign record}

  BEGIN
  recpack.ah := $2c;
  MsDOS(recpack.Reg);                    {call interrupt}
  with recpack do
    begin
      Tm.Hour := CH;
      Tm.Minute := CL;
      Tm.Second := DH
    end
  END;

(****************************************************************************)

FUNCTION StrToTime(InputLine : String) : TimeStr;

(*   Format -  18:16:22
     Node   - 0112334556  *)

VAR  Ptr,
     Digits,
     Node,
     Hour,
     Minute,
     Second   : BYTE;
     Ch       : CHAR;

  BEGIN
    Node := 0;                              { Initial node is always zero.                  }
    Ptr := 0;
    Hour := 0;
    Minute := 0;
    Second := 0;
    Digits := 0;
    WHILE Ptr < length(InputLine) DO                                      { For each character input . . .  }
      BEGIN
        Ptr := succ(Ptr);
        Ch := InputLine[Ptr];
        CASE Ch OF
          '0' .. '9' : BEGIN
                         Digits := succ(Digits);                          { Count the number of digits read }
                         IF Digits > 2 THEN Node := succ(Node);           { and if necessary go to next node}
                         CASE Node OF
                   0, 2, 4 : BEGIN                                        { Found start of the next number. }
                               Digits := 0;                               { Reset the digit count.          }
                               Node := succ(Node);
                               Ptr := pred(Ptr)                           { Step back over this character.  }
                             END;
                         1 : Hour := Hour * 10 + ord(Ch) - ord('0');      { Accumulate HOUR value.          }
                         3 : Minute := Minute * 10 + ord(Ch) - ord('0');  { Accumulate MINUTE value.        }
                         5 : Second := Second * 10 + ord(Ch) - ord('0');  { Accumulate SECOND value.        }
                         6 : Ptr := length(InputLine)                     { Set final condition.                    }
                         END { CASE }
                       END
          Else CASE Node OF                                               { We get here when we find a separator.   }
            1, 3 : BEGIN
                     Digits := 0;                                         { Reset the digit count.                  }
                     Node := succ(Node)                                   { If in a number, move to separator node. }
                   END;
               5 : Ptr := length(InputLine)                               { Set final condition.                    }
               END { CASE }
        END { CASE }
      END; { WHILE }
    IF Node > 0
      THEN StrToTime := chr(Hour div 10 + 48) + chr(Hour mod 10 + 48) + ':'
                      + chr(Minute div 10 + 48) + chr(Minute mod 10 + 48) + ':'
                      + chr(Second div 10 + 48) + chr(Second mod 10 + 48)
      ELSE StrToTime := Time
  END;

(****************************************************************************)

PROCEDURE SetTime(Tm : TimeStr);

VAR  recpack : registers;
     OK,
     Hour,
     Minute,
     Second  : INTEGER;

  BEGIN
    with recpack do
      begin
        AH := $2D;
        Val(copy(Tm, 1, 2), Hour, OK);
        IF OK = 0 THEN
          BEGIN
            Val(copy(Tm, 4, 2), Minute, OK);
            IF OK = 0 THEN
              BEGIN
                Val(copy(Tm, 7, 2), Second, OK);
                IF OK = 0 THEN
                  BEGIN
                    CH := Hour;
                    CL := Minute;
                    DH := Second;
                    DL := 5;
                    MsDOS(recpack.Reg)
                  END
              END
          END
      END
  END;

(****************************************************************************)

FUNCTION StrToDayOfWeek(St : String) : INTEGER;

VAR Ptr : INTEGER;                     { Sunday = 0,  Saturday = 6 }

  BEGIN
    StrToDayOfWeek := -1;
    FOR Ptr := 6 DOWNTO 0 DO
      IF Pos(St, DayName[Ptr] + 'day') > 0 THEN StrToDayOfWeek := Ptr
  END;

(****************************************************************************)

FUNCTION StrToMonth(St : String) : INTEGER;

VAR Ptr : INTEGER;

  BEGIN
    StrToMonth := 0;
    FOR Ptr := 12 DOWNTO 1 DO
      IF Pos(St, MonthName[Ptr]) > 0 THEN StrToMonth := Ptr
  END;

(****************************************************************************)

PROCEDURE StrToDate(InputLine : String; VAR Dt : Date; Default : Date);

(*         13 10 1987       -  format A
    Node: 01123345555

           13 October 1987  -  format B
    Node: 0112666666645555

           October 13 1987  -  format C
    Node: 0777777789945555

           10 13 1987       -  format A (American) - this is assumed by the
                               program ONLY IF day < 13

    The separators may be any number of spaces or non-alphanumeric
    characters, and the month name, if used, may be abbreviated to three
    characters.  The routine will in fact extract a valid date, if
    present, from virtually any sentence.  If 100 > year > 80
    then 20th century is assumed.  If year < 80 then 21st century is assumed. *)

VAR  Swap,
     Ptr,
     Node,
     WeekDay,
     Day,
     Month,
     Year  : INTEGER;
     Ch    : CHAR;
     MonthStr : String;

  BEGIN
    Dt := Default;
    Node := 0;                              { Initial node is always zero.                                                }
    Ptr := 0;
    WeekDay := -1;
    Day := 0;
    Month := 0;
    Year := -1;
    InputLine[0] := succ(InputLine[0]);     { Add a trailing space to the input string.                                   }
    InputLine[length(InputLine)] := ' ';
    WHILE Ptr < length(InputLine) DO        { For each character input . . .                                              }
      BEGIN
        Ptr := succ(Ptr);
        Ch := InputLine[Ptr];
        CASE Ch OF
          '0' .. '9' : CASE Node OF
                      0, 8 : BEGIN                                      { Found start of Day.                             }
                               Node := succ(Node);
                               Day := ord(Ch) - ord('0')
                             END;
                      1, 9 : Day := Day * 10 + ord(Ch) - ord('0');      { Accumulate DAY value, format A or B. }
                         2 : BEGIN                                      { Found while looking for month - Must be format A }
                               Node := 3;
                               Month := ord(Ch) - ord('0')
                             END;
                         3 : Month := Month * 10 + ord(Ch) - ord('0');  { Accumulate MONTH value.                         }
                         4 : BEGIN                                      { Day and month are complete - starting the year. }
                               Node := 5;
                               Year := ord(Ch) - ord('0')
                             END;
                         5 : Year := Year * 10 + ord(Ch) - ord('0');    { Accumulate Year value.                          }
                         6 : BEGIN
                               Month := StrToMonth(MonthStr);           { Found while scanning a month name in format B.  }
                               Ptr := pred(Ptr);                        { Step back over this digit . . .                 }
                               IF Month > 0 THEN Node := 4              { IF month name is OK, assume year comes next.    }
                                            ELSE Node := 2              { otherwise, assume month coming up, in format A. }
                             END;
                         7 : BEGIN
                               Month := StrToMonth(MonthStr);           { Found while scanning a month name in format C.  }
                               Ptr := pred(Ptr);                        { Step back over this digit.                      }
                               IF Month > 0
                                 THEN Node := 8                         { IF month name is OK, assume day comes next.     }
                                 ELSE
                                   BEGIN
                                     WeekDay := StrToDayOfWeek(MonthStr);
                                     IF WeekDay >= 0
                                       THEN Ptr := length(InputLine)
                                       ELSE Node := 0       { otherwise, assume day coming up, in format A.   }
                                   END
                             END;
                         Else writeln('Internal error in StrToDate');
                       END; { CASE }
          'A' .. 'Z',
          'a' .. 'z' : CASE Node OF
                         0 : BEGIN                                      { First valid character . . .                     }
                               Node := 7;                               { . . . must be start of month name, format C.    }
                               MonthStr := UpCase(Ch)
                             END;
                      1, 2 : BEGIN                                      { Found after day.  Must be format B.             }
                               Node := 6;
                               MonthStr := UpCase(Ch)
                             END;
                      3, 9 : Node := 4;                                 { Start looking for the year value.               }
                         5 : Ptr := length(InputLine);                  { Indicates job finished.                         }
                      6, 7 : BEGIN
                               IF Ch < 'a' THEN Ch := chr(ord(Ch) + 32);  { Convert to lower case . . .                   }
                               inc(MonthStr[0]);
                               MonthStr[length(MonthStr)] := Ch         { Then accumulate the month name.                 }
                             END;
                         Else
                       END; { CASE }
          Else CASE Node OF                                             { We get here when we find a separator.           }
                 1 : Node := 2;                                         { Indicates end of DAY, format A or B.            }
              3, 9 : Node := 4;                                         { Ditto end of MONTH, format A, or day, format C. }
                 5 : Ptr := length(InputLine);                          { Indicates job finished.                         }
                 6 : BEGIN
                       Month := StrToMonth(MonthStr);                   { Found while scanning a month name in format B.  }
                       IF Month > 0 THEN Node := 4                      { IF month name is OK, assume year comes next.    }
                                    ELSE Node := 2                      { otherwise, assume month coming up, in format A. }
                     END;
                 7 : BEGIN
                       Month := StrToMonth(MonthStr);                   { Found while scanning a month name in format C.  }
                       IF Month > 0
                         THEN Node := 8                                 { IF month name is OK, assume day comes next.     }
                         ELSE
                           BEGIN
                             WeekDay := StrToDayOfWeek(MonthStr);       { otherwise, check for a day name.                }
                             Node := 0                                  { then, assume day coming up, in format A.        }
                           END
                     END;
                 Else
               END { CASE }
        END { CASE }
      END; { WHILE }
    IF (Day + Month + Year) >= 0
      THEN
        BEGIN
          IF (Month > 12) AND (Day < 13) THEN                           { Fudge factor for "American" dates.              }
            BEGIN                                                       { Not really very clever, but fun.                }
              Swap := Day;
              Day := Month;
              Month := Swap
            END;
          IF (Day > 0) AND (Day < 32) THEN Dt.Day := Day;
          IF (Month > 0) AND (Month < 13) THEN Dt.Month := Month;
          IF Year > 199 THEN Year := (Year - 100) MOD 200;
          IF Year > -1 THEN Dt.Year := Year;
          JulToDate(JulianDay(Dt), Dt)
        END
      ELSE IF WeekDay >= 0
        THEN JulToDate(JulianDay(Dt) + (WeekDay + 7 - DayNum(Dt)) MOD 7, Dt)
  END;

(****************************************************************************)

END.

--------------------------------------------------------------------------------

{ Save the next section as NOVELL.PAS }

{ UK Copyright (c) Peter Davey, November 1993 }

Unit Novell;

{$X+}

Interface

Uses Dos;

TYPE  LockType   = (Temporary, LongTerm);
      String8    = STRING[8];
      String12   = STRING[12];
      String21   = STRING[21];
      String24   = STRING[24];
      String48   = STRING[48];
      CArray48   = ARRAY [1 .. 48] OF CHAR;
      String55   = STRING[55];
      String100  = STRING[100];

FUNCTION NetwareInstalled : BOOLEAN;

FUNCTION NetwareVersion : WORD;

FUNCTION ServerName(Drive : CHAR) : String48;

FUNCTION GetConnectionNumber : BYTE;

FUNCTION GetUserConnectionNumbers(UserName : String48) : String100;

FUNCTION GetUserObjectHexID(UserName : String48) : String8;

FUNCTION WorkStationHexID : String12;

PROCEDURE SetBroadcastMode(Mode : BYTE);
                                    { Mode 0 - Normal.  Receive all messages }
                                    {      1 - No user messages              }
                                    {      2 - Server stores system messages }
                                    {      3 - Server stores all messages    }

PROCEDURE SendBroadcastMessage(Target : String100; Message : String55);

FUNCTION GetBroadcastMessage : String55;

PROCEDURE SendMessageToUser(Addressee : String48;  Message : String55);

PROCEDURE SendMessageToAll(Message : String55);

FUNCTION GetUserName : String48;

PROCEDURE Lock(FileName : PathStr; TypeOfLock : LockType);

PROCEDURE UnLock(FileName : PathStr);

PROCEDURE IncrementUserCount(MeterName : STRING);

PROCEDURE DecrementUserCount(MeterName : STRING);

PROCEDURE Log(LogComment : STRING);

PROCEDURE SetServerDateAndTime;

PROCEDURE DownServer(Name : String48);

(****************************************************************************)

Implementation

Uses Sys, TimePack;

{ Timepack is another Peter Davey unit }

CONST HexChars : ARRAY [0 .. 15] OF CHAR = '0123456789ABCDEF';

TYPE NameList  = ^NameEntry;
     NameEntry = RECORD
                   Name : String21;
                   Next : NameList
                 END;
     RWord     = RECORD
                   H, L : BYTE
                 END;
     RLong     = RECORD Case BOOLEAN OF
                   TRUE  : (B1, B2, B3, B4 : BYTE);
                   FALSE : (L : LongInt)
                 END;

VAR  UserList,
     User      : NameList;
     NetError  : INTEGER;
     LockMode  : BYTE;
     GRegs     : Registers;       { Global set of registers for calls to DOS }
     ServName  : CArray48;

(****************************************************************************)

FUNCTION NetwareInstalled : BOOLEAN;

{ Returns TRUE if Netware is installed. }

  BEGIN
    NetwareInstalled := LockMode = 1
  END;

(****************************************************************************)

PROCEDURE Netware(Call : BYTE;  Request, Reply : POINTER);

{ The standard call procedure for many of the Novell API calls }

  BEGIN
    GRegs.AH := Call;
    GRegs.DS := Seg(Request^);
    GRegs.SI := Ofs(Request^);
    GRegs.ES := Seg(Reply^);
    GRegs.DI := Ofs(Reply^);
    MsDOS(GRegs.Reg)
  END;

(****************************************************************************)

FUNCTION FileServerInformation(Offset : BYTE) : WORD;

{ Various different data can be returned by the Get File Server Information call.
  A side-effect of this function is to set ServName to the server name. }

TYPE Request = RECORD
                 Len  : WORD;
                 Func : BYTE
               END;
     Reply   = RECORD CASE BOOLEAN OF
                 TRUE  : ( Len        : WORD;
                           ServerName : CArray48;      { Offset -  2 }
                           Version,                    {          50 }
                           SubVersion : BYTE;          {          51 }
                           ConnsSupp,                  {          52 }
                           ConnsInUse,                 {          54 }
                           MaxVolumes : Rword;         {          56 }
                           Revision,                   {          58 }
                           SFTlevel,                   {          59 }
                           TTSlevel   : BYTE;          {          60 }
                           PeakConns  : Rword;         {          61 }
                           { Various version numbers }
                           Accounting,                 {          63 }
                           VAP,                        {          64 }
                           Queueing,                   {          65 }
                           PrintServer,                {          66 }
                           Console,                    {          67 }
                           Security,                   {          68 }
                           Bridge     : BYTE;          {          69 }
                           Reserved   : ARRAY [1 .. 60] OF BYTE );
                 FALSE : ( Linear : ARRAY [0 .. 69] OF BYTE )
               END;

VAR  ReqBuf  : Request;
     RepBuf  : Reply;

  BEGIN
    IF LockMode = 1 THEN
      BEGIN
        ReqBuf.Len := 1;
        ReqBuf.Func := $11;
        RepBuf.Len := 128;
        Netware($E3, Addr(ReqBuf), Addr(RepBuf));
        ServName := RepBuf.ServerName;
        { Some data are words, and others are bytes.
          The CASE statment sorts them out. }
        CASE Offset OF
          50 .. 56, 61 : FileServerInformation := (RepBuf.Linear[Offset] SHL 8) + RepBuf.Linear[Succ(Offset)];
          Else FileServerInformation := RepBuf.Linear[Offset]
        End { Case }
      END
  END;

(****************************************************************************)

FUNCTION NetwareVersion : WORD;

{ Returns both major and minor parts as the high and low order bytes
  Use: Hi(NetwareVersion)
       Lo(Netwareversion) }


  BEGIN
    NetwareVersion := FileServerInformation(50)
  END;

(****************************************************************************)

FUNCTION ServerName(Drive : CHAR) : String48;

{ Returns the name of the server mapped to the drive given.  If you are on
  a network with more than one server, this could be relevant to you.  If
  the drive passed is a local drive, then the name of the DEFAULT server
  will be returned.  This is USUALLY the server you first logged in to
  but not always.  See the Novell API documentation. }

VAR S : PathStr;

  BEGIN
    { Note the current logged drive }
    GetDir(0, S);
    {$I-}
    { If a legal drive letter was passed, change to that drive }
    IF (Drive <> S[1])
    AND (UpCase(Drive) IN ['A' .. 'Z'])
      THEN Chdir(Drive + ':');
    {$I+}
    Drive := S[1];
    { If the change drive produced an error, IOresult will be non-zero
      and a null server name is returned. }
    IF IOresult = 0
      THEN
        BEGIN
          FileServerInformation(50);            { Ignore the returned value }
          S := ServName;
          WHILE S[Length(S)] <= ' ' DO Delete(S, Length(S), 1);
          ServerName := S
        END
      ELSE ServerName := '';
    { Change back to the original drive }
    Chdir(Drive + ':')
  END;

(****************************************************************************)

FUNCTION GetConnectionNumber : BYTE;

{ Returns the connection number of this workstation }

  BEGIN
    IF LockMode = 1
      THEN
        BEGIN
          Gregs.AX := $DC00;
          MsDos(Gregs.Reg);
          GetConnectionNumber := Gregs.AL
        END
      ELSE GetConnectionNumber := 0
  END;

(****************************************************************************)

FUNCTION GetUserConnectionNumbers(UserName : String48) : String100;

{ Returns a character string of BYTES which are the connection numbers of
  the given named user.  The reason for the string is that a Novell user
  can be logged on at many stations.  We think 100 is a reasonable max!! }

TYPE Request = RECORD
                 Len        : WORD;
                 Func       : BYTE;
                 ObjectType : RWord;
                 ObjectName : String48
               END;
     Reply   = RECORD
                 Len  : WORD;
                 List : String100
               END;

VAR  ReqBuf  : Request;
     RepBuf  : Reply;

  BEGIN
    IF LockMode = 1
      THEN
        BEGIN
          ReqBuf.Len          := 52;
          ReqBuf.Func         := $15;
          ReqBuf.ObjectType.H := 0;
          ReqBuf.ObjectType.L := 1;
          ReqBuf.ObjectName   := UserName;
          RepBuf.Len          := 101;
          RepBuf.List         := '';
          Netware($E3, Addr(ReqBuf), Addr(RepBuf));
          GetUserConnectionNumbers := RepBuf.List
        END
      ELSE GetUserConnectionNumbers := ''
  END;

(****************************************************************************)

FUNCTION GetUserObjectHexID(UserName : String48) : String8;

{ Every user has a HEX identity.  This is stored in the bindery. }

TYPE Request = RECORD
                 Len        : WORD;
                 Func       : BYTE;
                 ObjectType : RWord;
                 ObjectName : String48
               END;
     Reply   = RECORD
                 Len        : WORD;
                 ObjectID   : RLong;
                 ObjectType : RWord;
                 ObjectName : Array [1 .. 48] OF Char;
               END;

VAR  ReqBuf  : Request;
     RepBuf  : Reply;

  BEGIN
    IF LockMode = 1
      THEN
        BEGIN
          ReqBuf.Len          := 52;
          ReqBuf.Func         := $35;
          ReqBuf.ObjectType.H := 0;
          ReqBuf.ObjectType.L := 1;
          ReqBuf.ObjectName   := UserName;
          RepBuf.Len          := 54;
          RepBuf.ObjectID.B1  := 0;
          RepBuf.ObjectID.B2  := 0;
          RepBuf.ObjectID.B3  := 0;
          RepBuf.ObjectID.B4  := 0;
          Netware($E3, Addr(ReqBuf), Addr(RepBuf));
          GetUserObjectHexID := HexChars[RepBuf.ObjectID.B1 DIV $10]
                              + HexChars[RepBuf.ObjectID.B1 MOD $10]
                              + HexChars[RepBuf.ObjectID.B2 DIV $10]
                              + HexChars[RepBuf.ObjectID.B2 MOD $10]
                              + HexChars[RepBuf.ObjectID.B3 DIV $10]
                              + HexChars[RepBuf.ObjectID.B3 MOD $10]
                              + HexChars[RepBuf.ObjectID.B4 DIV $10]
                              + HexChars[RepBuf.ObjectID.B4 MOD $10]
        END
      ELSE GetUserObjectHexID := '0';
  END;

(****************************************************************************)

FUNCTION WorkStationHexID : String12;

{ Every workstation has a HEX ID.  This call returns the ID of the workstation. }

TYPE Reply   = ARRAY [0 .. 9] OF BYTE;

VAR  RepBuf  : ^Reply;

  BEGIN
    IF LockMode = 1
      THEN
        BEGIN
          WITH GRegs DO
            BEGIN
              BX := 9;               { Don't know why, but this call     }
              Intr($7A, GRegs.Reg);  { doesn't always succeed first time. }
              BX := 9;
              Intr($7A, GRegs.Reg);
              RepBuf := Ptr(ES, SI)
            END;
          WorkStationHexID := HexChars[RepBuf^[4] DIV $10]                            + HexChars[RepBuf^[4] MOD $10]
                            + HexChars[RepBuf^[5] DIV $10]
                            + HexChars[RepBuf^[5] MOD $10]
                            + HexChars[RepBuf^[6] DIV $10]
                            + HexChars[RepBuf^[6] MOD $10]
                            + HexChars[RepBuf^[7] DIV $10]
                            + HexChars[RepBuf^[7] MOD $10]
                            + HexChars[RepBuf^[8] DIV $10]
                            + HexChars[RepBuf^[8] MOD $10]
                            + HexChars[RepBuf^[9] DIV $10]
                            + HexChars[RepBuf^[9] MOD $10]
        END
      ELSE WorkStationHexID := ''
  END;

(****************************************************************************)

PROCEDURE SetBroadcastMode(Mode : BYTE);

{ This is the API call used by CASTOFF and CASTON }

{ Mode 0 - Normal.  Receive all messages }
{      1 - No user messages              }
{      2 - Server stores system messages }
{      3 - Server stores all messages    }

  BEGIN
    Gregs.AX := $DEFF;
    Gregs.DL := Mode;
    MsDos(Gregs.Reg);
    Successful := Gregs.AL = Mode
  END;

(****************************************************************************)

PROCEDURE SendBroadcastMessage(Target : String100; Message : String55);

{ Send to a list of station numbers }

TYPE Request = RECORD
                 Len     : WORD;
                 Func    : BYTE;
                 List    : String100;
                 Message : String55
               END;
     Reply   = RECORD
                 Len     : WORD;
                 List    : String100
               END;

VAR  ReqBuf  : Request;
     RepBuf  : Reply;
     Station : CHAR;

  BEGIN
    Successful := FALSE;
    IF LockMode = 1 THEN
      Station := Chr(GetConnectionNumber);
      WHILE Pos(Station, Target) > 0 DO Delete(Target, Pos(Station, Target), 1);
      IF Target > '' THEN
        IF Message > '' THEN
          BEGIN
            ReqBuf.Len     := 158;
            ReqBuf.Func    := 0;
            ReqBuf.List    := Target;
            ReqBuf.Message := Message;
            Move(ReqBuf.Message,
                 ReqBuf.List[Succ(Length(ReqBuf.List))],
                 Succ(Length(ReqBuf.Message)));
            RepBuf.Len     := 101;
            Netware($E1, Addr(ReqBuf), Addr(RepBuf));
            Successful := GRegs.AL = 0
          END
  END;

(****************************************************************************)

FUNCTION GetBroadcastMessage : String55;

{ You can retrieve stored messages from the server any time if you have set
  broadcast mode to 2 or 3 using SetBroadcastMode.  If there is no messge a
  null string is returned. }

TYPE Request = RECORD
                 Len     : WORD;
                 Func    : BYTE
               END;
     Reply   = RECORD
                 Len     : WORD;
                 Message : String55
               END;

VAR  ReqBuf  : Request;
     RepBuf  : Reply;

  BEGIN
    ReqBuf.Len     := 1;
    ReqBuf.Func    := 1;
    RepBuf.Len     := 56;
    Netware($E1, Addr(ReqBuf), Addr(RepBuf));
    IF Gregs.AL = 0
      THEN GetBroadcastMessage := RepBuf.Message
      ELSE GetBroadcastMessage := ''
  END;

(****************************************************************************)

PROCEDURE SendMessageToUser(Addressee : String48;  Message : String55);

{ Send message to a single user.  The message goes to all stations where
  the named user is logged on. }

  BEGIN
    Successful := FALSE;
    IF LockMode = 1 THEN
      BEGIN
        IF Addressee = 'SUPERVIS' THEN Addressee := 'SUPERVISOR';
        SendBroadcastMessage(GetUserConnectionNumbers(Addressee), Message)
      END
  END;

(****************************************************************************)

PROCEDURE SendMessageToAll(Message : String55);

{ Send a message to all logged on.  This is NOT the same as the EVERYONE
  group, because it is possible to remove people from EVERYONE.  This code
  assumes 100 user Netware.  For the 250 user version I assume you would
  need to change the loop, and rewrite SendBroadcastMessage.  My API
  documentation does not make it clear. }

VAR FullList : String100;

  BEGIN
    Successful := FALSE;
    IF LockMode = 1 THEN
      BEGIN
        { Generate a string of the bytes from 1 to 100 }
        FOR FullList[0] := #1 TO #100 DO
          FullList[Length(FullList)] := FullList[0];
        FullList[0] := #100;
        SendBroadcastMessage(FullList, Message)
      END
  END;

(****************************************************************************)

FUNCTION GetUserName : String48;

{ Return the user's logon name.  This will return the value of the
  environment variable ID if Netware is not running. }

TYPE  Type1    = RECORD
                   BufLen : WORD;
                   Func   : BYTE
                 END;
      Type2    = RECORD
                   BufLen : WORD;
                   Mask   : BYTE;
                   ID     : RLong
                 END;
      Type3    = RECORD
                   BufLen : WORD;
                   ID     : RLong;
                   ObjTyp : RWord;
                   Name   : String48
                 END;

VAR   CallBuf  : Type1;
      GenBuf   : Type2;
      NameBuf  : Type3;

  BEGIN
    IF LockMode = 1
      THEN
        BEGIN
          CallBuf.BufLen   := 1;
          CallBuf.Func     := 70;             { Get bindery access. }

          GenBuf.BufLen    := 5;
          GenBuf.Mask      := 0;
          GenBuf.ID.B4     := 0;
          GenBuf.ID.B3     := 0;
          GenBuf.ID.B2     := 0;
          GenBuf.ID.B1     := 0;

          Netware($E3, Addr(CallBuf), Addr(GenBuf));

          IF (GenBuf.ID.B1 OR GenBuf.ID.B2 OR GenBuf.ID.B3 OR GenBuf.ID.B4) <> 0
            THEN
              BEGIN
                GenBuf.BufLen    := 5;
                GenBuf.Mask      := 54;       { Get name from bindery. }

                NameBuf.BufLen   := 54;

                Netware($E3, Addr(GenBuf), Addr(NameBuf));

                IF GRegs.AL <> 0
                  THEN GetUserName := GetEnv('ID')
                  ELSE
                    BEGIN
                      Move(NameBuf.Name[0], NameBuf.Name[1], 48);
                      NameBuf.Name[0] := Chr(48);
                      NameBuf.Name[0] := Chr(Pred(Pos(#0, NameBuf.Name)));
                      GetUserName := NameBuf.Name
                    END
              END
            ELSE GetUserName := GetEnv('ID')
        END
      ELSE GetUserName := GetEnv('ID')
  END;

(****************************************************************************)

FUNCTION Minute(St : STRING) : INTEGER;

  FUNCTION Digit (Ch : CHAR) : BYTE;

    BEGIN
      Digit := Ord(Ch) - 48
    END;

  BEGIN
    IF Length(St) > 4
      THEN Minute := (Digit(St[1]) * 10 + Digit(St[2])) * 60
                    + Digit(St[4]) * 10 + Digit(St[5])
      ELSE Minute := 0
  END;

(****************************************************************************)

{ Generates a suitable name for a lock file.  This is only used if
  Netware locking is not available. }

FUNCTION LockName(Name : PathStr) : PathStr;

VAR Ptr : BYTE;

  BEGIN
    Ptr := length(Name);
    WHILE Ptr > 0 DO
      BEGIN
        CASE Name[Ptr] OF
          '\' : Ptr := 1;
          '.' : BEGIN
                  Name[0] := chr(pred(Ptr));
                  Ptr := 1
                END;
          ' ' : Delete(Name, Ptr, 1)
        END;
        Ptr := pred(Ptr)
      END;
    LockName := Name + '.LOK'
  END;

(****************************************************************************)

PROCEDURE Lock(FileName : PathStr; TypeOfLock : LockType);

{ Attempts to lock a file.  The global BOOLEAN variable Successful contains
  the result.  If Netware is not loaded, a generic method using semaphore
  files is attempted.  The semaphores have the extension .LOK

  The TypeOfLock is ignored if Netware locking is used.  With the generic
  locking it controls behaviour if a lock is found.  If you pass
  TypeOfLock := Temporary then the procedure will ignore a lock file and
  return successfully if the lock is more than five minutes old.  If you
  pass TypeOfLock := LongTerm then the procedure will always fail if an
  existing lock, however old, is found. }

VAR   Count    : INTEGER;
      Message,
      LockFile : PathStr;
      Now      : STRING[8];
      Handle   : INTEGER;

  (************************************)

  PROCEDURE WriteMessage;

    BEGIN
      WITH GRegs DO
        BEGIN
          AX := $4200;           { Move file pointer ref start    }
          BX := Handle;          { of file with this handle.      }
          CX := 0;               { With offset ...                }
          DX := 0;               {                 at first byte. }
          MsDos(GRegs.Reg);
          Message := Time + '  Locked by ' + GetUserName + #0;
          AH := $40;             { Write to sequential file       }
          CX := length(message); { Length of string to write.     }
          DS := seg(Message[1]);
          DX := ofs(Message[1]);
          MsDOS(GRegs.Reg);
          Successful := TRUE
        END
    END;

  (************************************)

  BEGIN
    WITH Gregs DO
      IF LockMode = 1
        THEN
          { If Netware is loaded, the Netware locking call is used.  The
            procedure will set Successful = TRUE if the lock is placed
            within five seconds. }
          BEGIN
            Insert(#0, FileName, Succ(Length(FileName)));
            AX := $EB01;
            DS := Seg(FileName[1]);
            DX := Ofs(FileName[1]);
            BP := 90;  { Five second wait time }
            MsDos(Gregs.Reg);
            Successful := AL = 0
          END
        ELSE
          BEGIN
            Successful := FALSE;
            LockFile := LockName(FileName);
            LockFile[Succ(Length(LockFile))] := #0;
            Count := 240;                  { Make 240 attempts to lock }
            DS := seg(LockFile[1]);
            DX := ofs(LockFile[1]);
            CX := 0;                       { Open file with normal attributes. }
            REPEAT
              Count := pred(Count);
              AH := $5B;                   { Create new file (semaphore) }
              MsDOS(GRegs.Reg);            { Call DOS }
              IF (CarryFlag IN Flags)
                THEN
                  IF AX < 5                { Path does not exist, or no }
                    THEN Count := -1       { handles are available. }
                    ELSE { Nothing }
                ELSE
                  BEGIN
                    Handle := AX;          { Handle of opened file }
                    WriteMessage;          { Note who locked it }
                    AH := $3E;
                    MsDOS(GRegs.Reg);      { Close the file again!! }
                    Count := -1            { Indicate success }
                  END
            UNTIL Count < 1;
            IF Count = 0 THEN              { Existing lock still in place }
              BEGIN
                AX := $3D12;               { Open file for read/write.  Deny access. }
                MsDOS(GRegs.Reg);
                IF NOT (CarryFlag IN Flags) THEN
                  BEGIN
                    Handle := AX;          { Handle of opened file. }
                    BX := Handle;
                    AH := $3F;             { Read file. }
                    CX := pred(sizeof(message));
                    DS := seg(Message[1]);
                    DX := ofs(Message[1]);
                    MsDOS(GRegs.Reg);      { Find out who owns the lock.  If this
                                             fails, take the lock anyway. }
                    IF (NOT (CarryFlag IN Flags)) AND (AX > 18)
                      THEN
                        BEGIN
                          Message[0] := Chr(AX);
                          Message[0] := Chr(Pos(#0, Message))
                        END
                      ELSE Message := '  ' + GetUserName + #0;
                    IF pos(' ' + GetUserName + #0, Message) > 1
                      THEN WriteMessage
                      ELSE
                        BEGIN
                          write(Message);  { Display lock owner's ID }
                          IF (Message[3] = ':') AND (TypeOfLock = Temporary)
                          { This is a bit of a kludge to make generic locking
                            work.  If you state in the call that the lock is
                            a temporary one, the following code will ignore
                            an existing lock if its time is not within five
                            minutes of current time.  If someone else has
                            crashed and left a lock in place this clears it. }
                            THEN
                              BEGIN
                                IF (Minute(Time) < (Minute(Message) - 5))
                                OR (Minute(Time) > (Minute(Message) + 5))
                                  THEN
                                    BEGIN
                                      Write('- Old lock cleared');
                                      WriteMessage
                                    END
                              END
                        END;
                      AH := $3E;
                      MsDOS(GRegs.Reg)       { Close the file again!! }
                  END
              END
          END
  END;

(****************************************************************************)

PROCEDURE UnLock(FileName : PathStr);

{ Unlocks a file, or if Netware is not loaded, deletes the semaphore file }

VAR LockFile : FILE;

  BEGIN
    IF LockMode = 1
      THEN WITH Gregs DO
        BEGIN
          { The Novell file locking method }
          Insert(#0, FileName, Succ(Length(FileName)));
          AX := $EDFF;
          DS := Seg(FileName[1]);
          DX := Ofs(FileName[1]);
          MsDos(Gregs.Reg)
        END
      ELSE
        BEGIN
          { The semaphore file method }
          Assign(LockFile, LockName(FileName));
          {$I-} Erase(LockFile); {$I+}
          IF IOresult = 0 THEN { Ignore the result of the action }
        END
  END;

(****************************************************************************)

FUNCTION ReadUsers(VAR MeterFile : TEXT;  VAR User : NameList) : INTEGER;

{ Read the users' names from a licence metering file }

VAR Count  : INTEGER;
    Check1 : String21;
    Check2 : String[9];
    Today  : Date;

  BEGIN
    Count := 0;
    Check1 := ' ' + GetUserName + ' ';
    GetDate(Today);
    Check2 := D__MMM__YY(Today);
    WHILE NOT SeekEOF(MeterFile) DO
      BEGIN
        ReadLn(MeterFile, User^.Name);
        IF (Pos(Check1, User^.Name) < 8)
        AND (Pos(Check2, User^.Name) > 0) THEN
          BEGIN
            Inc(Count);
            NEW(User^.Next);
            User^.Next^.Next := NIL;
            User := User^.Next
          END
      END;
    ReadUsers := Count
  END;

(****************************************************************************)

PROCEDURE IncrementUserCount(MeterName : STRING);

{ Adds the current user's name to a licence metering file.  The global
  BOOLEAN variable Successful holds the result.  The maximum number of
  users allowed to be added is in the first line of the meter file.  The
  routine will never add the same user twice.  Use this call to limit the
  number of users allowed to acces a function simultaneously.

  If the procedure fails because the maximum number of users are already
  listed in the meter file, then a Netware broadcast is sent to all of
  them to warn that somebody else requires access.

  If the file does not exist, it is created with a user limit of 1.

  Create your meter files in the first place by hand, e.g.:
  ECHO 15 > MYFILE.MTR

  The system will maintain a "High water mark" as the second line of the
  file.  This shows the maximum number of users who have been in there
  concurrently. }

VAR  MeterFile  : TEXT;
     Count,
     HighWater,
     Limit     : INTEGER;
     Ptr       : BYTE;
     Today     : Date;
     Directory : DirStr;
     FileName  : NameStr;
     Ext       : ExtStr;

  BEGIN
    Lock(MeterName, Temporary);
    IF Successful THEN
      BEGIN
        Assign(MeterFile, MeterName);
        {$I-} Reset(MeterFile);
        IF IOresult <> 0 THEN
          BEGIN
            Rewrite(MeterFile);
            Reset(MeterFile)
          END;
        Successful := IOresult = 0;
        IF Successful THEN
          BEGIN
            ReadLn(MeterFile, Limit);
            IF (IOresult <> 0) OR (Limit < 1) THEN Limit := 1;
            ReadLn(MeterFile, HighWater);
            IF (IOresult <> 0) OR (HighWater < 1) THEN HighWater := 0;
            NEW(UserList);
            UserList^.Next := NIL;
            User := UserList;
            Count := ReadUsers(MeterFile, User);
            GetDate(Today);
            User^.Name := D__MMM__YY(Today) + ' ' + GetUserName + ' ';
            User := UserList;
            IF Count < Limit
              THEN
                BEGIN
                  Rewrite(MeterFile);
                  WriteLn(MeterFile, Limit);
                  IF Count >= HighWater THEN HighWater := Succ(Count);
                  WriteLn(MeterFile, HighWater);
                  REPEAT
                    WriteLn(MeterFile, User^.Name);
                    User := User^.Next
                  UNTIL User = NIL;
                  Close(MeterFile)
                END
              ELSE
                BEGIN
                  Close(MeterFile);
                  WriteLn('Too many users are using this function:', #10);
                  FSplit(MeterName, Directory, FileName, Ext);
                  REPEAT
                    Write(User^.Name:30, '':10);
                    FOR Ptr := 1 TO 3 DO
                      Delete(User^.Name, 1, Pos(' ', User^.Name));
                    Delete(User^.Name, Pos(' ', User^.Name), 255);
                    SendMessageToUser(User^.Name, GetUserName + ' is waiting to use ' + FileName);
                    User := User^.Next;
                    Count := Pred(Count)
                  UNTIL Count < 1;
                  Successful := FALSE
                END;
            REPEAT
              User := UserList^.Next;
              DISPOSE(UserList);
              UserList := User
            UNTIL UserList = NIL
          END;
        Unlock(MeterName);
      END;
    IF NOT Successful THEN
      Write(#10, #13, 'Please try again later.  ')
  END;

(****************************************************************************)

PROCEDURE DecrementUserCount(MeterName : STRING);

{ Removes the current user's name from a licence metering file. }

VAR  MeterFile  : TEXT;
     Count,
     HighWater,
     Limit     : INTEGER;

  BEGIN
    Lock(MeterName, Temporary);
    IF Successful THEN
      BEGIN
        Assign(MeterFile, MeterName);
        {$I-} Reset(MeterFile);
        IF IOresult = 0 THEN
          BEGIN
            ReadLn(MeterFile, Limit);
            IF IOresult <> 0 THEN Limit := 1;
            ReadLn(MeterFile, HighWater);
            IF IOresult <> 0 THEN HighWater := 0;
            NEW(UserList);
            UserList^.Next := NIL;
            User := UserList;
            Count := ReadUsers(MeterFile, User);
            User := UserList;
            Rewrite(MeterFile);
            WriteLn(MeterFile, Limit);
            WriteLn(MeterFile, HighWater);
            REPEAT
              IF User^.Next <> NIL THEN WriteLn(MeterFile, User^.Name);
              User := User^.Next
            UNTIL User = NIL;
            Close(MeterFile);
            REPEAT
              User := UserList^.Next;
              DISPOSE(UserList);
              UserList := User
            UNTIL UserList = NIL
          END;
        Unlock(MeterName)
      END
  END;

(****************************************************************************)

PROCEDURE Log(LogComment : STRING);

{ Adds a line to a hidden log file.  The name of the file should be
  set into the environment variable LOG.  This procedure is generic -
  it does not require Netware to be loaded, }

VAR  LogFileName : DirStr;
     LogFile     : TEXT;
     Today       : Date;

  BEGIN
    LogFileName := getenv('LOG');
    IF LogFileName > ' '
      THEN Lock(LogFileName, Temporary)
      ELSE Successful := FALSE;
    IF Successful THEN
      BEGIN
        ChMod('-rs', LogFileName);
        Assign(LogFile, LogFileName);
        {$I-}
        Append(LogFile);
        IF IOresult <> 0 THEN ReWrite(LogFile);
        {$I+}
        IF IOresult <> 0
          THEN Successful := FALSE
          ELSE
            BEGIN
              GetDate(Today);
              WriteLn(LogFile, D__MMM__YY(Today):9, '│', time, ' ───────────── ', LogComment);
              Close(LogFile);
              ChMod('+rh', LogFileName)
            END;
        UnLock(LogFileName)
      END
  END;

(****************************************************************************)

PROCEDURE SetServerDateAndTime;

{ This is of course Novell-specific, and it requires that the current
  user has Supervisor equivalence.  It sets the server time to the same
  as the DOS time at the current workstation.  It's up to you to alter
  the DOS time first.  Remember that the Novell login program sets DOS
  time the same as server time at each logon. }

TYPE Request = RECORD
                 Len     : WORD;
                 Func,
                 Year,
                 Month,
                 Day,
                 Hour,
                 Minute,
                 Second  : BYTE
               END;
     Reply   = RECORD
                 Len     : WORD
               END;

VAR  ReqBuf  : Request;
     RepBuf  : Reply;
     Today   : Date;
     Now     : TimeRec;

  BEGIN
    IF LockMode = 1 THEN
      BEGIN
        GetDate(Today);
        GetTime(Now);
        ReqBuf.Len    := 7;
        ReqBuf.Func   := $CA;
        ReqBuf.Year   := Today.Year;
        ReqBuf.Month  := Today.Month;
        ReqBuf.Day    := Today.Day;
        ReqBuf.Hour   := Now.Hour;
        ReqBuf.Minute := Now.Minute;
        ReqBuf.Second := Now.Second;
        RepBuf.Len    := 0;
        Netware($E3, Addr(ReqBuf), Addr(RepBuf))
      END
  END;

(****************************************************************************)

PROCEDURE DownServer(Name : String48);

{ This downs the named server.  Use with care.  Supervisor equivalence
  required!!  Global BOOLEAN variable Successful holds the result. }

TYPE Request = RECORD
                 Len   : WORD;
                 Func,
                 Force : BYTE
               END;

VAR  ReqBuf       : Request;
     RepBuf       : WORD;
     CurrentPath  : PathStr;
     TempDrive    : CHAR;

  BEGIN
    Successful := FALSE;
    IF LockMode = 1
      THEN
        BEGIN
          GetDir(0, CurrentPath);
          TempDrive := 'D';
          { Loop through all drive letters to find one
            that is mapped to the required server. }
          WHILE (TempDrive <= 'Z')
          AND (ServerName(TempDrive) <> Name)
            DO Inc(TempDrive);
          IF TempDrive <= 'Z' THEN
            BEGIN
              {$I-}
              ChDir(TempDrive + ':');
              {$I+}
              IF IOresult = 0 THEN
                BEGIN
                  ReqBuf.Len := 2;
                  ReqBuf.Func := $D3;
                  ReqBuf.Force := 1;
                  RepBuf := 0;
                  Netware($E3, Addr(ReqBuf), Addr(RepBuf));
                  ChDir(CurrentPath[1] + ':');
                  Successful := TRUE
                END
            END
        END
  END;

(****************************************************************************)

BEGIN
  { This code checks whether Novell Netware is loaded, by attempting
    to change the lock mode.  The result is stored in LockMode. }
  Asm
    MOV AX, 0C601H  { Set lock mode to 1 }
    INT 21H
    MOV AX, 0C602H  { Get lock mode      }
    INT 21H
    MOV LockMode, AL
  End { Asm }
END.