Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/GET10.ZIP/GETDATE.PAS

Pascal/Delphi Source File | 1988-11-09 | 15.7 KB | 646 lines

procedure getdatestr

   (date_prompt:      screen_text;
    atr,atc:          byte;        {screen co-ords}
var datestr:          string;
    status:           byte);       {use SystemDefault: bit 2; mandatory: bit 1}

begin
  getdatestring(date_prompt,Default_pattr,atr,atc,Default_dattr,
                Default_cursor_attr,Default_pattr,datestr,status);
end;

procedure getdatestring

   (date_prompt:      screen_text;
    pattr:            byte;        {prompt attribute}
    atr,atc,                       {screen co-ords}
    dattr,                         {date attribute}
    cursor_attr,                   {cursor attribute}
    separator_attr:   byte;        {date subfield separator attribute}
var datestr:          string;
    status:           byte);       {use SystemDefault: bit 2; mandatory: bit 1}

{
  It is expected that the format of the date entered e.g. dd/mm/yy will
  match that indicated by the global variables DateFormat and YearFormat.
  No validation is performed to assure this.

  Expected        DateFormat

  mm/dd/[yy]yy    American
  dd/mm/[yy]yy    European
  [yy]yy/mm/dd    Japanese

  [19]yy or yyyy controlled by value of YearFormat: YY, NY, YYYY

  YearFormat = NY means 19yy (N for Nineteen)

  datestr is expected to be 10 characters long if YearFormat is YYYY
  otherwise (YearFormat = NY or YY) it is expected to be 8 characters
  long.

  Dates are expected with and are returned with separators between
  component subfields.

  In a blank date field enter_default (^J) is acceptable in the first
  subfield ONLY.
}
var
    old_datestr,
    year_picture,
    month,day,year: string;
    code:           integer;
    M,D:            longint; {for compatibility with 'value' procedure}
    Y:              word;    {used for determining leap years}
    lastedit:       word;

    SystemDefault,           {use system date as default}
    finished,
    mandatory,               {date field as a whole}
    MandatoryDay,
    MandatoryMonth,
    MandatoryYear,
    OldInsLock,
    OldAutoTab,
    OldPainting,
    OldStringFieldWrap,
    Old_Top_n_tail,
    DateOk:         boolean;


    sf1,sf2:        char;    {subfield separators}

    OldTabsize,
    field,
    fm1,fm2,
    jybias,
    field_size,
    year_picture_size,
    year_field_size,
    yxpos,
    dpos,mpos,ypos: byte;    {screen positions}


function IsLeapYear (Y: word): boolean;
{
  To be recast in assembler.

  Years divisible 4, except centuries not divisible by 400 and millenia
  divisible by 4000, are leap years.

  'and $03' is equivalent to 'mod 4'
}
begin
  IsLeapYear := (Y and $03 = 0) and
    (Y mod 4000 <> 0) and ((Y mod 100 <> 0) or (Y mod 400 = 0));
end;


function no_date_entered: boolean;
begin
  val(day,D,code);
  val(month,M,code);
  val(year,Y,code);

  no_date_entered :=  (D + M + Y = 0) or
                     ((D + M + Y = 1900) and (YearFormat = NY));
end;


function LegalExitCommand: boolean;
{
  This function is used to take out of line some code used for determining
  when a subfield can be exited, to keep code readable. Modify as needed.
}
var LocalAction: edit;
begin
  LocalAction := get_edit(command);
  LegalExitCommand :=
    LocalAction in [del_block, restore_block, exit_screen];
end;


procedure assemble_date;
begin
  case DateFormat of
    American: datestr := month + sf1 + day + sf2 + year;
    European: datestr := day + sf1 + month + sf2 + year;
    Japanese: datestr := year + sf1 + month + sf2 + day;
  end;
end;


procedure getday;
var GoodDay: boolean;
begin
  repeat

    if DateZeroAsBlank and (day = '00') then
      day := '';

    getstring('',Default_pattr,atr,atc + pred(dpos),dattr,cursor_attr,
              day,'99',2,2 + ord(MandatoryDay)); {status}

    if day = '' then
      day := '00';

    GoodDay := escaped or PaintingFields or LegalExitCommand;

    if not GoodDay then

      if day = '00' then

        if MandatoryDay then
          error2(Null_input_not_allowed)
        else
           begin
             GoodDay := true;
             finished := DateFormat = European;
           end

      else {day != '00'}

        begin
          value(day,D,31,code);

          GoodDay := (code = 0) and (D > 0);

          if not GoodDay then
            begin
              error2(Enter_a_number_between +
                     brighten('1') + AndWord + brighten('31'));
              cp := 1;
            end;
        end;

  until GoodDay;
end;


procedure getmonth;
var GoodMonth: boolean;
begin
  repeat

   if DateZeroAsBlank and (month = '00') then
      month := '';

    getstring('',Default_pattr,atr,atc + pred(mpos),dattr,cursor_attr,
              month,'99',2,2 + ord(MandatoryMonth));

    if month = '' then
      month := '00';

    GoodMonth := escaped or PaintingFields or LegalExitCommand;

    if not Goodmonth then

      if month = '00' then

        if MandatoryMonth then
          error2(Null_input_not_allowed)
        else
          begin
            GoodMonth := true;
            finished := DateFormat = American;
          end

      else {month != '00'}

        begin
          value(month,M,12,code);

          GoodMonth := (code = 0) and (M > 0);

          if not GoodMonth then
            begin
              error2(Enter_a_number_between +
                     brighten('1') + AndWord + brighten('12'));
              cp := 1;
            end;
        end;

  until GoodMonth;
end;


procedure getyear;
var GoodYear: boolean;
begin
  repeat

    if DateZeroAsBlank and ((year = '00') or (year = '0000')) then
      year := '';

    getstring('',Default_pattr,atr,atc + pred(ypos),dattr,cursor_attr,year,
              year_picture,year_field_size,2 + ord(MandatoryYear));

    if year = '' then
      repeat
        year := '00' + year;
      until length(year) = year_picture_size;

    val(year,Y,code);

    GoodYear := escaped or PaintingFields or (Y <> 0) or LegalExitCommand;

    if not GoodYear then {year is 00 or 0000, is it legal?}

      if MandatoryYear then
        error2(Null_input_not_allowed)
      else
         begin
           GoodYear := true;
           finished := DateFormat = Japanese;
         end;

  until GoodYear;

  if YearFormat = NY then
    Y := Y + 1900; {used in calculating leap years}
end;


procedure get_subfield (field: byte);
begin
  case field of
    1: case DateFormat of
         American: getmonth;
         European: getday;
         Japanese: getyear;
       end; {case}

    2: if DateFormat = American then
         getday
       else getmonth;

    3: if DateFormat = Japanese then
         getday
       else getyear;
  end;
end;


procedure validate_date
;
{
  Validates month and day (M & D). Not executed if PaintingFields.
}
var monthOk,
    BlankdateOk: boolean;

function daysOk: boolean;
begin
  if D in [1..28] then {valid for all months: 12 * 28 = 336 days or 92%}
    daysOk := true
  else
    case D of
           0: daysOk := M = 0;
      29..31: case M of
                2       : daysOk := D < 29 + ord(IsLeapYear(Y));
                4,6,9,11: daysOk := D < 31;
              else
                daysOk := true;
              end; {case}
    else
      daysOk := false;
    end; {case}
end;


procedure day_error (subfield: byte);
begin
  error2(Invalid_no_of_days_in_month);
  field := subfield;
end;


procedure month_error (subfield: byte);
begin
  error2(Invalid_month_number);
  field := subfield;
end;

begin
  BlankdateOk := (not mandatory) and no_date_entered;
  monthOk := (M in [1..12])       or BlankdateOk;
  DateOk  := (daysOk and monthOk) or BlankdateOk;

  if not DateOk then
    if mandatory and no_date_entered then
      begin
        error2(Null_input_not_allowed);
        field := 1;
        cp := 1;
      end
    else

      if DateFormat = European then
        if not daysOk then
          day_error(1)
        else if not monthOk then
               month_error(2)
             else {;}
      else
        begin
          if not monthOk then
            month_error(1 + ord(DateFormat = Japanese))
          else if not daysOk then
            day_error(2 + ord(DateFormat = Japanese))
        end;
end;


procedure display_date;
var OldPainting: boolean;
    fattr:       byte;
begin
  assemble_date;

  if PaintingFields or finished then
    fattr := dattr
  else fattr := separator_attr;

  OldPainting := PaintingFields;
  PaintingFields := true;

{ paint field }

    get_subfield(1);
    Qwrite(atr,atc + pred(fm1),fattr,sf1);
    get_subfield(2);
    Qwrite(atr,atc + pred(fm2),fattr,sf2);
    get_subfield(3);

  PaintingFields := OldPainting;
end;


procedure setup_date (strdate: string);
{
  Get day, month and year string variables from the input string: strdate
  Reconstruct an 8 or 10 character datestr. This procedure used to reset
  datestr and dependent variables after reset_block command.
}
var I: byte; a:char; {delete a}
begin

  datestr := strdate;
  field_size := 8;

  case YearFormat of
      NY: year_picture := '~19~99';
      YY: year_picture := '99';
    YYYY: begin
            year_picture := '9999';
            field_size := 10;
          end;
  end; {case}

  year_field_size   := field_size - 6;
  year_picture_size := length_without_tears(year_picture,'~');

  fm1 := 3;    {position of field marker between dd/mm or mm/dd}
  fm2 := 6;    {position of field marker between mm/[yy]yy}
  ypos := 7;   {same for American and European date formats}
  jybias := 0; {to help locate month and day subfields in Japanese (ymd) date}

  MandatoryDay   := true;
  MandatoryMonth := true;
  MandatoryYear  := true;
{
  SystemDefault controls whether or not the enter_default command enters
  the system date into the date field. If SystemDefault is true the first
  field may be blank on return from the appropriate call to GETSTRING (this
  is to enable use of enter_default command).
}
  case DateFormat of
    American: begin
                mpos := 1;
                dpos := 4;
                MandatoryMonth := mandatory and not SystemDefault;
              end;
    European: begin
                dpos := 1;
                mpos := 4;
                MandatoryDay := mandatory and not SystemDefault;
              end;
    Japanese: begin
                jybias := year_picture_size - year_field_size;

                ypos := 1;
                mpos := year_picture_size + 2;
                dpos := mpos + 3;

                fm1 := pred(mpos); {fm1 & 2 are offset positions on screen}
                fm2 := pred(dpos);
                MandatoryYear := mandatory and not SystemDefault;
              end;
  end; {case}

  if (year_field_size = 2) and (length(datestr) = 10) then       {yyyy passed}
    yxpos := ypos + 2                           {skip over first two Y digits}
  else yxpos := ypos;         {yxpos = position to start extracting year from}

  if ord(datestr[0]) > 0 then        {convert any spaces in date string to 0s}
    for I := 1 to length(datestr) do
      if datestr[I] = ' ' then
        datestr[I] := '0';

  if length(datestr) = field_size then {assume good date}
    begin
      sf1 := datestr[fm1 - jybias];
      sf2 := datestr[fm2 - jybias];
    end
  else {ensure we don't get nonsense subfield separators}
    begin
      sf1 := DefaultDateSeparator;
      sf2 := sf1;
    end;
{
  short date strings are prefaced with zeros
}
  while length(datestr) < field_size do
    datestr := '0' + datestr;

  day   := copy(datestr,dpos - jybias,2);
  month := copy(datestr,mpos - jybias,2);
  year  := copy(datestr,yxpos,year_field_size);

  val(day,D,code);
  val(month,M,code);
  val(year,Y,code);
end;


procedure get_system_date;
{
  Sets month, day and year strings using current system date.
  Leading zeros inserted if necessary.
}
var
  system_year,
  system_month,
  system_day,
  weekday:     word;

begin
  getdate(system_year, system_month, system_day, weekday);

  str(system_month,month);
  if system_month < 10 then
    month := '0' + month;

  str(system_day,day);
  if system_day < 10 then
    day := '0' + day;

  str(system_year,year);
  if YearFormat <> YYYY then
    delete(year,1,2);

  assemble_date; {turn day, month and year strings into datestr}
  setup_date(datestr);
  finished := true;
end;


procedure get_input;
begin
  finished := false;
  get_subfield(field); {getstring takes care of clearerror}

  action := get_edit(command);
  case action of

    leftchar : if (field > 1) or OldStringFieldWrap then
                 begin
                   dec(field);
                   cp := 255; {move cursor to end of previous field}
                 end;

    rightchar: if (field < 3) or OldStringFieldWrap then
                 begin
                   inc(field);
                   cp := 1;
                 end;


    del_block: begin {^Y for date field}
                 setup_date('');
                 field := 1;
                 cp := 1;
                 display_date;
               end;

    restore_block: {^U for date field}

               begin
                 setup_date(old_datestr);
                 display_date;
               end;

    enter_default:

               get_system_date;

    carriage_return:

               begin
                 if SystemDefault and no_date_entered then
                   get_system_date;

                 finished := true;
               end;

    tabback:   begin
                 dec(field);
                 cp := 255;
               end;

    tabover,
    post_letter: begin
                   inc(field);
                   cp := 1;
                 end;

    escapefrom,
    help,
    upchar,
    downchar,
    pageup,
    pagedown,
    scrollup,
    scrolldown,
    goto_top,
    goto_bottom,
    abort,
    exit_screen,
    quit:
                begin
                  setup_date(old_datestr);
                  escaped := (get_edit(command) = escapefrom);
                  finished := not escaped;       {1 or other is true}
                end;

  else
    error2(Invalid_key);
  end; {case}

  finished := finished or (field in [0,4]);
end;


begin {getdatestring}

  setup_date(datestr); {set up field_size, used in display_prompt}
  display_prompt(date_prompt,atr,atc,pattr,field_size);

  if not PaintingFields then
    begin

      finished           := false; {tested in display_date}
      display_date;

      old_datestr := datestr;

      mandatory          := (status and $01) > 0;
      SystemDefault      := (status and $02) > 0;
      Old_Top_n_tail     := Top_n_tail;
      Top_n_tail         := false;   {don't turn '00' into '' in getday etc}
      OldInsLock         := Inslock;
      InsLock            := true;    {disable}
      OldAutoTab         := AutoTab;
      AutoTab            := true;
      OldStringFieldWrap := StringFieldWrap;
      StringFieldWrap    := true;
      OldTabsize         := tabsize; {disable <tab> within date field}
      tabsize            := 0;

      escaped := false;
      field   := 1;

      repeat
        cp := 1;

        repeat
          get_input
        until escaped or finished;

        if not escaped then
          validate_date;

      until DateOk or escaped;

      InsLock         := OldInslock;
      Top_n_tail      := Old_Top_n_tail;
      AutoTab         := OldAutoTab;
      StringFieldWrap := OldStringFieldWrap;
      Tabsize         := OldTabsize;
    end;

  display_date; {ALWAYS (even if unchanged) to reset attributes}

end;