Media Share 9/MEDIASHARE_09.ISO/pascal/tplib21.zip/INSTALL.EXE/TIME.PAS

Pascal/Delphi Source File | 1993-06-24 | 22KB | 727 lines

(*
    TURBO PASCAL LIBRARY 2.1
    TIME unit: Extended date and time routines
*)

UNIT TIME;

{$V-}

{$L DATE}
{$L TIME}


INTERFACE

USES
    DOS;

TYPE
    DateString =    STRING[9];
    TimeString =    STRING[13];

    DateRec =       RECORD
                        M,D:    BYTE;
                        Y:      WORD;
                    END;

    TimeRec =       RECORD
                        H,M,S:  BYTE;
                    END;



CONST
    DateFormNumeric      = 0;       { Values for DateFormat }
    DateFormAlpha        = 1;
    DateFormMDY          = 2;
    DateFormDMY          = 3;
    DateFormLower        = 4;
    DateFormZeroFill     = 8;

    FullDateFormMDY      = 0;       { Values for FullDateFormat }
    FullDateFormDMY      = 1;

    TimeFormNormal       = 0;       { TimeFormat values }
    TimeFormNormalSec    = 1;
    TimeFormShort        = 2;
    TimeFormShortSec     = 3;
    TimeFormMilitary     = 4;
    TimeFormMilitarySec  = 5;
    TimeFormMilitaryHHMM = 6;

    TimeFormat:         BYTE        = TimeFormNormal;
    DateFormat:         BYTE        = DateFormNumeric;
    FullDateFormat:     BYTE        = FullDateFormMDY;
    TimeDelimiter:      CHAR        = ':';
    DateDelimiter:      CHAR        = '/';
    TimeParseDelims:    TimeString  = ':., '+#9;
    DateParseDelims:    DateString  = '/-., '+#9;
    TimeParseNow:       BOOLEAN     = FALSE;
    DateParseToDay:     BOOLEAN     = FALSE;
    DateParseCurYear:   BOOLEAN     = FALSE;
    DateParseCent21:    BYTE        = 0;




PROCEDURE CombineDateTime(VAR DtTm: DateTime; Dt: DateRec; Tm: TimeRec);
PROCEDURE SplitDateTime(DtTm: DateTime; VAR Dt: DateRec; VAR Tm: TimeRec);
PROCEDURE GetToDay(VAR Dt: DateRec);
PROCEDURE GetTimeNow(VAR Tm: TimeRec);
PROCEDURE GetDateTime(VAR DtTm: DateTime);
FUNCTION  DateValid(Dt: DateRec): BOOLEAN;
FUNCTION  TimeValid(Tm: TimeRec): BOOLEAN;
FUNCTION  DateTimeValid(DtTm: DateTime): BOOLEAN;
PROCEDURE WordToDate(w: WORD; VAR Dt: DateRec);
FUNCTION  DateToWord(Dt: DateRec): WORD;
FUNCTION  LeapYear(Y: WORD): BOOLEAN;
FUNCTION  TimeAP(Tm: TimeRec): TimeString;
PROCEDURE AdjustDate(VAR Dt: DateRec; n: INTEGER);
PROCEDURE AdjustTime(VAR Tm: TimeRec; n: LongInt);
PROCEDURE AdjustDateTime(VAR DtTm: DateTime; n: LongInt);
PROCEDURE SetLastDay(VAR Dt: DateRec);
FUNCTION  DayOfWeek(w: WORD): BYTE;
FUNCTION  DayOfWeekStr(d: BYTE): DateString;
FUNCTION  MonthStr(M: BYTE): DateString;
FUNCTION  DayOfMonthStr(D: BYTE): DateString;
FUNCTION  DateStr(Dt: DateRec): DateString;
FUNCTION  FullDateStr(Dt: DateRec): STRING;
FUNCTION  TimeStr(Tm: TimeRec): TimeString;
FUNCTION  DateParse(s: STRING; VAR Dt: DateRec): BOOLEAN;
FUNCTION  TimeParse(s: STRING; VAR Tm: TimeRec): BOOLEAN;



IMPLEMENTATION

USES
    STRINGS;

VAR
    BritishFormat:  BOOLEAN;    { Set from country-dependent information }


PROCEDURE SetCountry; EXTERNAL;


PROCEDURE CombineDateTime(VAR DtTm: DateTime; Dt: DateRec; Tm: TimeRec);

    BEGIN
        WITH DtTm DO
            BEGIN
                Year:=Dt.Y;
                Month:=Dt.M;
                Day:=Dt.D;
                Hour:=Tm.H;
                Min:=Tm.M;
                Sec:=Tm.S;
            END;
    END;


PROCEDURE SplitDateTime(DtTm: DateTime; VAR Dt: DateRec; VAR Tm: TimeRec);

    BEGIN
        WITH DtTm DO
            BEGIN
                Dt.M:=Month;
                Dt.D:=Day;
                Dt.Y:=Year;
                Tm.H:=Hour;
                Tm.M:=Min;
                Tm.S:=Sec;
            END;
    END;


PROCEDURE GetToDay(VAR Dt: DateRec); EXTERNAL;
PROCEDURE GetTimeNow(VAR Tm: TimeRec); EXTERNAL;

PROCEDURE GetDateTime(VAR DtTm: DateTime);

    VAR
        x:  WORD;

    BEGIN
        WITH DtTm DO
            BEGIN
                GetDate(Year,Month,Day,x);
                GetTime(Hour,Min,Sec,x);
            END;
    END;


FUNCTION  DateValid(Dt: DateRec): BOOLEAN;

    VAR
        v:  BOOLEAN;

    BEGIN
        WITH Dt DO
            BEGIN
                CASE M OF                           { Check upper day limit }
                    1,3,5,7,8,10,12:  v:=D<=31;
                    4,6,9,11:         v:=D<=30;
                    2:                IF LeapYear(Y) THEN
                                          v:=D<=29
                                      ELSE
                                          v:=D<=28;
                    ELSE              v:=FALSE;     { Check month range }
                END;                                { Check lower day/year }
                DateValid:=v AND (D>0) AND (Y>=1900) AND (Y<=2079);
                IF (Y=2079) AND ((M>6) OR ((M=6) AND (D>6))) THEN
                    DateValid:=FALSE;               { Limit of 6/6/2079 }
            END;
    END;


FUNCTION  TimeValid(Tm: TimeRec): BOOLEAN;

    BEGIN
        WITH Tm DO
            TimeValid:=(H<24) AND (M<60) AND (S<60);
    END;



FUNCTION DateTimeValid(DtTm: DateTime): BOOLEAN;

    VAR
        d:  DateRec;
        t:  TimeRec;
        v:  BOOLEAN;

    BEGIN
        WITH DtTm DO
            v:=((Month OR Day OR Hour OR Min OR Sec) AND $FF00)=0;
        SplitDateTime(DtTm,d,t);
        DateTimeValid:=v AND DateValid(d) AND TimeValid(t);
    END;


PROCEDURE WordToDate(w: WORD; VAR Dt: DateRec);

    VAR
        i:  INTEGER;
        j:  LONGINT;

    BEGIN
        WITH Dt DO
            BEGIN
                IF w<=58 THEN
                    BEGIN
                        Y:=1900;
                        IF w<=30 THEN
                            BEGIN
                                M:=1;
                                D:=SUCC(w);
                            END
                        ELSE
                            BEGIN
                                M:=2;
                                D:=w-30;
                            END;
                    END
                ELSE
                    BEGIN
                        j:=4*LONGINT(w)-233;
                        Y:=J DIV 1461+1900;
                        i:=J MOD 1461 DIV 4*5+2;
                        M:=i DIV 153;
                        D:=i MOD 153 DIV 5+1;
                        IF M<10 THEN
                            INC(M,3)
                        ELSE
                            BEGIN
                                DEC(M,9);
                                INC(Y);
                            END;
                    END;
            END;  { WITH Dt }
    END;  { WordToDate }


FUNCTION  DateToWord(Dt: DateRec): WORD;

    BEGIN
        WITH Dt DO
            BEGIN
                IF (Y=1900) AND (M<3) THEN
                    IF M=1 THEN
                        DateToWord:=PRED(D)
                    ELSE
                        DateToWord:=D+30
                ELSE
                    BEGIN
                        IF M>2 THEN
                            DEC(M,3)
                        ELSE
                            BEGIN
                                INC(M,9);
                                DEC(Y);
                            END;
                        DEC(Y,1900);
                        DateToWord:=
                            (1461*LONGINT(Y) DIV 4)+((153*M+2) DIV 5)+D+58;
                    END;
            END;  { WITH Dt }
    END;  { DateToWord }


FUNCTION  LeapYear(Y: WORD): BOOLEAN;

    BEGIN
        IF (Y MOD 4)<>0 THEN        { If Y not divisible by 4, not leap year }
            LeapYear:=FALSE
        ELSE
            IF (Y MOD 100)<>0 THEN  { If divisible by 4 but not 100, is leap }
                LeapYear:=TRUE
            ELSE
                LeapYear:=(Y MOD 400)=0;    { If div. by 100, only leap year }
    END;                                    { if also div. by 400 }


FUNCTION  TimeAP(Tm: TimeRec): TimeString;

    BEGIN
        IF Tm.H<12 THEN
            TimeAP:='a.m.'
        ELSE
            TimeAP:='p.m.';
    END;



PROCEDURE AdjustDate(VAR Dt: DateRec; n: INTEGER);

    VAR
        w:  WORD;

    BEGIN
        w:=DateToWord(Dt)+n;
        WordToDate(w,Dt);
    END;



{ Adjust Tm by number of seconds specified.  Returns value indicating number
  of days to adjust date by, or zero if adjustment did not pass midnight. }

FUNCTION AddSecsToTime(VAR Tm: TimeRec; n: LongInt): INTEGER;

    VAR
        sc:     LongInt;
        days:   INTEGER;

    BEGIN
        days:=0;
        WITH Tm DO
            BEGIN
                sc:=S+n;                    { Adjust seconds }
                WHILE sc<0 DO               { If moving backward past zero }
                    BEGIN                   { adjust mins/hrs back }
                        sc:=sc+60;
                        IF M>0 THEN
                            DEC(M)
                        ELSE
                            BEGIN
                                M:=59;
                                IF H=0 THEN
                                    BEGIN
                                        H:=23;
                                        DEC(days);
                                    END
                                ELSE
                                    DEC(H);
                            END;
                    END;
                WHILE sc>59 DO              { If moving forward past 59 secs }
                    BEGIN                   { adjust mins/hrs forward }
                        sc:=sc-60;
                        IF M=59 THEN
                            BEGIN
                                M:=0;
                                IF H=23 THEN
                                    BEGIN
                                        H:=0;
                                        INC(days);
                                    END
                                ELSE
                                    INC(H);
                            END
                        ELSE
                            INC(M);
                    END;
                S:=sc;                      { Restore seconds field }
            END;  { WITH Tm }
        AddSecsToTime:=days;                { Return day adjustment figure }
    END;


PROCEDURE AdjustTime(VAR Tm: TimeRec; n: LongInt);

    VAR
        x:  INTEGER;

    BEGIN
        x:=AddSecsToTime(Tm,n);
    END;


PROCEDURE AdjustDateTime(VAR DtTm: DateTime; n: LongInt);

    VAR
        d:  DateRec;
        t:  TimeRec;

    BEGIN
        SplitDateTime(DtTm,d,t);
        AdjustDate(d,AddSecsToTime(t,n));
        CombineDateTime(DtTm,d,t);
    END;


PROCEDURE SetLastDay(VAR Dt: DateRec);

    BEGIN
        WITH Dt DO
            CASE M OF
                2:        IF LeapYear(Y) THEN
                              D:=29
                          ELSE
                              D:=28;
                4,6,9,11: D:=30;
                ELSE      D:=31;
            END;
    END;


FUNCTION  DayOfWeek(w: WORD): BYTE;

    BEGIN
        DayOfWeek:=SUCC(w) MOD 7;       { 0=Sunday thru 6=Saturday }
    END;


FUNCTION DayOfWeekStr(d: BYTE): DateString;

    CONST
        days: ARRAY[0..6] OF DateString = ('Sunday','Monday','Tuesday',
                            'Wednesday','Thursday','Friday','Saturday');

    BEGIN
        IF (d>6) THEN
            DayOfWeekStr:=''            { Return null if d out of range }
        ELSE
            DayOfWeekStr:=days[d];
    END;


FUNCTION  MonthStr(M: BYTE): DateString;

    CONST
        months: ARRAY[1..12] OF DateString =
            ('January','February','March','April','May','June','July',
             'August','September','October','November','December');

    BEGIN
        IF M IN [1..12] THEN
            MonthStr:=months[M]
        ELSE
            MonthStr:='';           { Return null if M out of range }
    END;


FUNCTION  DayOfMonthStr(D: BYTE): DateString;

    VAR
        s:  STRING[2];

    BEGIN
        IF D IN [1..31] THEN
            BEGIN
                STR(D,s);       { Convert to string, add appropriate suffix }
                CASE D OF
                    1,21,31:  DayOfMonthStr:=CONCAT(s,'st');
                    2,22:     DayOfMonthStr:=CONCAT(s,'nd');
                    3,23:     DayOfMonthStr:=CONCAT(s,'rd');
                    ELSE      DayOfMonthStr:=CONCAT(s,'th');
                END;
            END
        ELSE
            DayOfMonthStr:='';  { Return null if D out of range }
    END;


FUNCTION  DateStr(Dt: DateRec): DateString;

    VAR
        s:      DateString;
        mm,dd:  STRING[2];
        yy:     STRING[4];

    BEGIN
        WITH Dt DO                  { Convert each field to a string }
            BEGIN
                STR(M:2,mm);
                STR(D:2,dd);
                STR(Y:4,yy);
            END;
        CASE (DateFormat AND 3) OF
            0:  IF BritishFormat THEN
                    s:=CONCAT(dd,DateDelimiter,mm,DateDelimiter,COPY(yy,3,2))
                ELSE
                    s:=CONCAT(mm,DateDelimiter,dd,DateDelimiter,COPY(yy,3,2));
            1:  BEGIN
                    s:=CONCAT(dd,DateDelimiter,COPY(MonthStr(Dt.M),1,3),
                              DateDelimiter,COPY(yy,3,2));
                    IF (DateFormat AND DateFormLower)=0 THEN
                        s:=UpperCase(s);
                END;
            2:  s:=CONCAT(mm,DateDelimiter,dd,DateDelimiter,COPY(yy,3,2));
            3:  s:=CONCAT(dd,DateDelimiter,mm,DateDelimiter,COPY(yy,3,2));
        END;  { CASE }
        IF s[4]=#32 THEN
            s[4]:='0';
        IF ((DateFormat AND DateFormZeroFill)<>0) AND (s[1]=#32) THEN
            s[1]:='0';
        DateStr:=s;
    END;


FUNCTION  FullDateStr(Dt: DateRec): STRING;

    VAR
        yy: STRING[4];
        dd: STRING[2];

    BEGIN
        WITH Dt DO
            BEGIN
                STR(Y:4,yy);
                IF (FullDateFormat AND 1)<>0 THEN
                    FullDateStr:=CONCAT(DayOfMonthStr(D),#32,
                                        MonthStr(M),#32,yy)
                ELSE
                    BEGIN
                        STR(D,dd);
                        FullDateStr:=CONCAT(MonthStr(M),#32,dd,', ',yy);
                    END;
            END;  { WITH Dt }
    END;  { FullDateStr }


FUNCTION  TimeStr(Tm: TimeRec): TimeString;

    VAR
        hh,mm,ss:   STRING[2];
        t:          TimeString;

    BEGIN
        WITH Tm DO
            IF TimeFormat>=TimeFormMilitary THEN    { Set hours 00 thru 23 }
                BEGIN
                    STR(H:2,hh);
                    IF hh[1]=#32 THEN
                        hh[1]:='0';
                END
            ELSE                        { If standard, set hours to 1 thru 12 }
                IF H>12 THEN
                    STR((H-12):2,hh)
                ELSE
                    BEGIN
                        STR(H:2,hh);
                        IF H=0 THEN
                            hh:='12';
                    END;
        STR(Tm.M:2,mm);                 { Convert minutes field }
        IF mm[1]=#32 THEN
            mm[1]:='0';
        IF TimeFormat=TimeFormMilitaryHHMM THEN
            t:=CONCAT(hh,mm)            { Concatenate hours and minutes }
        ELSE
            t:=CONCAT(hh,TimeDelimiter,mm);
        IF (TimeFormat AND 1)<>0 THEN   { Convert seconds if required }
            BEGIN
                STR(Tm.S:2,ss);
                IF ss[1]=#32 THEN
                    ss[1]:='0';
                t:=CONCAT(t,TimeDelimiter,ss);
            END;
        IF TimeFormat<TimeFormShort THEN            { Add a.m./p.m. suffix }
            TimeStr:=CONCAT(t,#32,TimeAP(Tm))
        ELSE
            TimeStr:=t;
    END;  { TimeStr }



FUNCTION  DateParse(s: STRING; VAR Dt: DateRec): BOOLEAN;

    CONST
        blanks = #32+#9;

    VAR
        s1:     STRING;
        f1,f2:  BOOLEAN;
        b:      BYTE;
        x:      INTEGER;
        td:     DateRec;


    { Parse string s.  If it holds numeric characters only, return
      converted value in v and set f to false.  If non-numeric characters
      found, match string against month abbreviations and return month number
      with f set to true.  Returns v=zero if conversion/match failed. }

    PROCEDURE GetVal(s: STRING; VAR v: BYTE; VAR f: BOOLEAN);

        CONST
            months: ARRAY[1..12] OF STRING[3] =
                        ('JAN','FEB','MAR','APR','MAY','JUN',
                         'JUL','AUG','SEP','OCT','NOV','DEC');

        BEGIN
            f:=LENGTH(Remove(s,DecDigits))<>0;  { Clear flag if nums. only }
            IF f THEN
                BEGIN               { If not numeric, check month abbrevs. }
                    v:=1;
                    WHILE (v<=12) AND (TruncR(s,3)<>months[v]) DO
                        INC(v);
                    IF v>12 THEN
                        v:=0;       { Return zero if no match found }
                END
            ELSE
                BEGIN                       { If numeric, convert }
                    VAL (TrimR(s),v,x);
                    IF x<>0 THEN          { Return zero if unsuccessful }
                        v:=0;
                END;
        END;  { GetVal }


    BEGIN  { DateParse }
        s:=UpperCase(TrimL(TrimR(s)));  { Remove blanks, make upper case }
        IF DateParseToDay AND (LENGTH(s)=0) THEN
            BEGIN
                GetToDay(Dt);           { Return current date if null }
                DateParse:=TRUE;        { input and allowed }
                EXIT;
            END;
        s1:=Break(s,DateParseDelims);   { Extract first part of date }
        GetVal(s1,Dt.M,f1);             { Assume it is month }
        Delete(s,1,1);                  { Remove delimiter from input }
        s1:=Span(s,blanks);             { Remove extra blanks }
        s1:=Break(s,DateParseDelims);   { Extract second part of date }
        GetVal(s1,Dt.D,f2);             { Assume it is day number }
        Delete(s,1,1);                  { Remove delimiter and extra blanks }
        s1:=Span(s,blanks);
        WITH Dt DO
            IF DateParseCurYear AND (LENGTH(s)=0) THEN
                BEGIN
                    GetToDay(td);       { If no year, assume current year }
                    Y:=td.Y;
                END
            ELSE
                BEGIN
                    VAL(s,Y,x);         { Assume remaining input is year }
                    IF x<>0 THEN        { Set year=zero if convert failed }
                        Y:=0
                    ELSE
                        IF Y<100 THEN   { Convert years xx to 19xx or 20xx }
                            IF Y<DateParseCent21 THEN
                                Y:=Y+2000
                            ELSE
                                Y:=Y+1900;
                END;
        IF f1 THEN                  { Check month and day fields }
            BEGIN
                IF f2 THEN          { If both alphabetic, force error }
                      Dt.M:=0;
            END
        ELSE
            IF f2 OR ((DateFormat AND 3)=DateFormDMY) OR
            (((DateFormat AND 3)=DateFormNumeric) AND BritishFormat) THEN
                BEGIN               { Swap fields if necessary }
                    b:=Dt.M;
                    Dt.M:=Dt.D;
                    Dt.D:=b;
                END;
        DateParse:=DateValid(Dt);       { Return success/failure flag }
    END;  { DateParse }



FUNCTION  TimeParse(s: STRING; VAR Tm: TimeRec): BOOLEAN;

    CONST
        blanks = #32+#9;

    VAR
        s1: STRING;
        x:  INTEGER;
        i:  (none,am,pm);

    BEGIN
        s:=LowerCase(TrimL(TrimR(s)));      { Tidy up input string }
        IF TimeParseNow AND (LENGTH(s)=0) THEN
            BEGIN
                GetTimeNow(Tm);             { Return current time if }
                TimeParse:=TRUE;            { null input and allowed }
                EXIT;
            END;
        s1:=Break(s,'ap');                  { Remove all up to a.m./p.m. }
        IF LENGTH(s)=0 THEN
            i:=none                         { Set a.m./p.m. indicator }
        ELSE
            CASE s[1] OF
                'a':    i:=am;
                'p':    i:=pm;
            END;
        s:=Break(s1,TimeParseDelims);       { Strip hours field from string }
        VAL(s,Tm.H,x);
        IF x<>0 THEN                        { If failed, force an error }
            Tm.H:=24;
        DELETE(s1,1,1);                     { Remove hh/mm delim. from input }
        s:=Span(s1,blanks);                 { Remove any extra blanks }
        s:=Break(s1,TimeParseDelims);       { Strip minutes field }
        VAL(s,Tm.M,x);
        IF x<>0 THEN                        { Force error if conv. failed }
            Tm.M:=60;
        DELETE(s1,1,1);             { Remove delim from input, strip blanks }
        s:=Span(s1,blanks);
        IF LENGTH(s1)=0 THEN        { If no other field, assume seconds=0 }
            Tm.S:=0
        ELSE
            BEGIN
                VAL(TrimR(s1),Tm.S,x);  { Otherwise convert last field }
                IF x<>0 THEN
                    Tm.S:=60;           { Force error if conversion failed }
            END;
        IF TimeValid(Tm) AND (i<>none) THEN
            WITH Tm DO                  { If successful & a.m./p.m. specified }
                IF (H<1) OR (H>12) THEN { Force error if hours out of range }
                    H:=24
                ELSE                    { Otherwise, adjust hours field }
                    CASE i OF
                        am: IF H=12 THEN
                                H:=0;
                        pm: IF H<12 THEN
                                H:=H+12;
                    END;
        TimeParse:=TimeValid(Tm);       { Do final validation }
    END;  { TimeParse }



BEGIN   { Initialization code }
    SetCountry;
    IF BritishFormat THEN
        BEGIN
            DateDelimiter:='-';
            TimeDelimiter:='.';
        END;
END.