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

Pascal/Delphi Source File | 1988-11-09 | 7.5 KB | 339 lines

procedure gettimestr

   (time_prompt:      screen_text;
    atr,atc:          byte;        {screen co-ords}
var timestr:          string;
    status:           byte);       {bit 2: use system time (hh:mm) as default}

begin
   gettimestring(time_prompt,Default_pattr,atr,atc,Default_dattr,
                 Default_cursor_attr,Default_pattr,timestr,status);
end;


procedure gettimestring

   (time_prompt:      screen_text;
    pattr,                         {prompt attribute}
    atr,atc,                       {screen co-ords}
    tattr,                         {time attribute}
    cursor_attr,                   {date and cursor attributes}
    separator_attr:   byte;        {time subfield separator attribute}
var timestr:          string;
    status:           byte);       {bit 2: use system time (hh:mm) as default}

var
    old_timestr,
    hours,mins:     string;
    code:           integer;
    H,M:            longint; {for compatibility with 'value' procedure}
    lastedit:       word;

    finished,
    OldInsLock,
    OldAutoTab,
    OldPainting,
    OldStringFieldWrap,
    OldTop_n_tail,
    SystemDefault,
    TimeOk:         boolean;


    OldTabsize,
    field:          byte;


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 get_system_time;
{
  Puts 24hr system time in timestr; sets values for hours and mins variables.
}
var
  system_hours,
  system_mins,
  system_secs,
  sec100:     word;

begin

  gettime(system_hours, system_mins, system_secs, sec100);

  str(system_hours,hours);
  if system_hours < 10 then
    hours := '0' + hours;

  str(system_mins,mins);
  if system_mins < 10 then
    mins := '0' + mins;

  timestr := hours + ':' + mins;
  val(hours,H,code);
  val(mins,M,code);
  finished := true;
end;


procedure gethours;
var GoodHours: boolean;
begin
  repeat

    if TimeZeroAsBlank and (hours = '00') and (mins = '00') then
      hours := '';

    getstring('',Default_pattr,atr,atc,tattr,cursor_attr,
              hours,'99',2,0);

    if hours = '' then
      hours := '00';

    GoodHours := escaped or PaintingFields or LegalExitCommand;

    if not GoodHours then
      begin
        value(hours,H,24,code); {24hr clock}

        GoodHours := (code = 0);

        if not GoodHours then
          begin
            error2(Enter_a_number_between +
                   brighten('0') + AndWord + brighten('24'));
            cp := 1;
          end;
      end;
  until GoodHours;
end;


procedure getmins;
var GoodMins: boolean;
begin
  repeat

    if TimeZeroAsBlank and (hours = '00') and (mins = '00') then
      mins := '';

    getstring('',Default_pattr,atr,atc + 3,tattr,cursor_attr,
              mins,'99',2,0);

    if mins = '' then
      mins := '00';

    GoodMins := escaped or PaintingFields or LegalExitCommand;

    if not GoodMins then
      begin
        value(mins,M,60,code);

        GoodMins := (code = 0);

        if not GoodMins then
          begin
            error2(Enter_a_number_between +
                   brighten('0') + AndWord + brighten('60'));
            cp := 1;
          end;
      end;
  until GoodMins;
end;


procedure get_subfield (field: byte);
begin
  case field of
    1: gethours;
    2: getmins;
  end;
end;


procedure assemble_time;
{
  Get hours, mins, H, M and turn '' into '00:00'
}
begin
  hours := copy(timestr,1,2);
  mins  := copy(timestr,4,2);

  val(hours,H,code);
  val(mins,M,code);

  if H = 0 then
    hours := '00';
  if M = 0 then
    mins := '00';

  timestr := hours + ':' + mins;
end;


procedure display_time;
var OldPainting: boolean;
    fattr:       byte;

begin
  assemble_time;

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

  OldPainting := PaintingFields;
  PaintingFields := true;

{ paint field }

  get_subfield(1);
  Qwrite(atr,atc + 2,fattr,':');
  get_subfield(2);

  PaintingFields := OldPainting;
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 time field}
                 timestr := '00:00';
                 field := 1;
                 cp := 1;
                 display_time;
               end;

    restore_block: {^U for time field}

               begin
                 timestr := old_timestr;
                 display_time;
               end;

    enter_default:

               get_system_time;

    carriage_return:

               begin
                 if SystemDefault and (timestr = '00:00') then
                   get_system_time;

                 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
                  timestr := old_timestr;           {restore timestr}
                  assemble_time;
                  escaped := (get_edit(command) = escapefrom);
                  finished := not escaped;       {1 or other is true}
                end;

  else
    error2(Invalid_key);
  end; {case}

  timestr := hours + ':' + mins;
  finished := finished or (field in [0,3]);
end;


begin {gettimestring}

  display_prompt(time_prompt,atr,atc,pattr,5); {field size = 5 (hh:mm)}

  if not PaintingFields then
    begin

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

     old_timestr := timestr;

     SystemDefault      := (status and $02) > 0;
     OldTop_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;
       TimeOk := not ((H = 24) and (M <> 0)); {No error msg if time > 24:00}
     until TimeOk or escaped;

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

  display_time; {ALWAYS (to reset separator attribute) even if unchanged}
end;