.CM  SCRIPT , Version - 1.1 , last edited by barbara
.ad 8
.bm 8
.fm 4
.bt $Copyright (c) 2000-2004 SAP AG$$Page %$
.tm 12
.hm 6
.hs 3
.TT 1 $SQL$Project Distributed Database System$VIN41$
.tt 2 $$$
.TT 3 $$Output of Date and Time$03.07.95$1998-06-19$
***********************************************************
.nf
 
.nf
 
 
    ========== licence begin  GPL
    Copyright (c) 2000-2004 SAP AG
 
    This program is free software; you can redistribute it and/or
    modify it under the terms of the GNU General Public License
    as published by the Free Software Foundation; either version 2
    of the License, or (at your option) any later version.
 
    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.
 
    You should have received a copy of the GNU General Public License
    along with this program; if not, write to the Free Software
    Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
    ========== licence end
 
.fo
 
 
.fo
.nf
.sp
MODULE  : Output of Date and Time
=========
.sp
Purpose : Precompilation of masks
          and output of DATE and TIME values
          using defined and precompiled masks.
          Test, if DATE/TIME is acceptable by the DB kernel.
.CM *-END-* purpose -------------------------------------
.sp
Define  :
 
        PROCEDURE
              i41dparse (
                    VAR mask   : tin_date_mask;
                    VAR error  : integer;
                    VAR errpos : tin_natural);
 
        PROCEDURE
              i41tparse (
                    VAR mask   : tin_date_mask;
                    VAR error  : integer;
                    VAR errpos : tin_natural);
 
        PROCEDURE
              i41tsparse (
                    VAR mask   : tin_date_mask;
                    VAR error  : integer;
                    VAR errpos : tin_natural);
 
        PROCEDURE
              i41dput (
                    VAR mask        : tin_date_mask;
                    VAR date_string : tsp00_Date;
                    VAR outputfield : tin_date_mask);
 
        PROCEDURE
              i41tput (
                    VAR mask        : tin_date_mask;
                    VAR time_string : tsp00_Time;
                    VAR outputfield : tin_date_mask);
 
        PROCEDURE
              i41tsput (
                    VAR tsmask : tin_date_mask;
                    VAR source : tsp00_Timestamp;
                    VAR dest   : tin_date_mask);
 
        PROCEDURE
              i41dget (
                    VAR mask        : tin_date_mask;
                    VAR inputfield  : tsp00_Buf;
                    inputlen        : tin_natural;
                    VAR date_string : tsp00_Date;
                    VAR error       : integer);
 
        PROCEDURE
              i41tget (
                    VAR mask        : tin_date_mask;
                    VAR inputfield  : tsp00_Buf;
                    inputlen        : tin_natural;
                    VAR time_string : tsp00_Time;
                    VAR error       : integer);
 
        PROCEDURE
              i41tsget (
                    VAR tsmask : tin_date_mask;
                    VAR source : tin_date_mask_string ;
                    inputlen   : tin_natural;
                    VAR dest   : tsp00_Timestamp;
                    VAR error  : integer);
 
        FUNCTION
              i41dvalid (
                    VAR dat : tsp00_Date) : boolean;
 
        FUNCTION
              i41tvalid (
                    VAR tim : tsp00_Time) : boolean;
 
        FUNCTION
              i41dlen (
                    VAR mask : tin_date_mask) : integer;
 
        FUNCTION
              i41tlen (
                    VAR mask : tin_date_mask) : integer;
 
        FUNCTION
              i41tslen (
                    VAR mask : tin_date_mask) : integer;
 
.CM *-END-* define --------------------------------------
.CM %if %not doku
.CM %begin
.sp;.cp 3
Use     :
 
        FROM
              messages : VIN03;
 
        PROCEDURE
              i03msg (
                    msg_nr    : integer;
                    VAR parms : tin_msg_parms;
                    VAR msg   : tin_screenline;
                    VAR msgt  : tin_msg_type);
 
      ------------------------------ 
 
        FROM
              Kernel_move_and_fill : VGG101;
 
        PROCEDURE
              SAPDB_PascalForcedFill (
                    size        : tsp00_Int4;
                    m           : tsp00_MoveObjPtr;
                    pos         : tsp00_Int4;
                    len         : tsp00_Int4;
                    fillchar    : char);
 
        PROCEDURE
              SAPDB_PascalForcedMove (
                    source_upb  : tsp00_Int4;
                    destin_upb  : tsp00_Int4;
                    source      : tsp00_MoveObjPtr;
                    source_pos  : tsp00_Int4;
                    destin      : tsp00_MoveObjPtr;
                    destin_pos  : tsp00_Int4;
                    length      : tsp00_Int4);
 
        PROCEDURE
              s10mv (
                    source_upb  : tsp00_Int4;       
                    destin_upb  : tsp00_Int4;
                    source      : tsp00_MoveObjPtr;    
                    source_pos  : tsp00_Int4;
                    destin      : tsp00_MoveObjPtr;    
                    destin_pos  : tsp00_Int4;
                    length      : tsp00_Int4);
 
      ------------------------------ 
 
        FROM
              RTE-Extension-30 : VSP30 ;
 
        FUNCTION
              s30eq (VAR a : tin_date_mask_string;
                    VAR b  : tin_date_mask_string;
                    b_pos  : tsp00_Int4;
                    length : tsp00_Int4) : boolean;
 
      ------------------------------ 
 
        FROM
              Code-Translation : VIN32 ;
 
        FUNCTION
              i32islower (
                    c : char) : boolean;
 
        FUNCTION
              i32toupper (
                    c : char ) : char;
 
        FUNCTION
              i32tolower (
                    c : char ) : char;
 
        PROCEDURE
              i32upstring (
                    VAR source : tin_date_mask_string;
                    spos       : integer;
                    VAR dest   : tin_date_mask_string;
                    dpos       : integer;
                    len        : integer);
 
      ------------------------------ 
 
        FROM
              RTE-Extension-60 : VSP60;
 
        FUNCTION
              s60isnu1meric (
                    VAR str : tsp00_Date;
                    len     : tsp00_Int2) : boolean;
 
        FUNCTION
              s60isnu2meric (
                    VAR str : tsp00_Time;
                    len     : tsp00_Int2) : boolean;
 
      ------------------------------ 
 
        FROM
              RTE_driver : VEN102 ;
 
        PROCEDURE
              sqlabort;
 
        PROCEDURE
              sqlwrite (
                    VAR text : tsp00_Line);
 
        PROCEDURE
              sqldattime (
                    VAR d : tsp00_Date;
                    VAR t : tsp00_Time);
 
.CM *-END-* use -----------------------------------------
.sp;.cp 3
Synonym :
 
        PROCEDURE
              m90buf;
 
              tsp00_Buf tin_date_mask_string
 
        PROCEDURE
              m90buf1;
 
              tsp00_Buf tsp00_Date
 
        PROCEDURE
              m90buf2;
 
              tsp00_Buf tsp00_Time
 
        PROCEDURE
              s30eq;
 
              tsp00_MoveObj tin_date_mask_string
 
        PROCEDURE
              i32upstring;
 
              tsp00_MoveObj tin_date_mask_string
              tsp00_MoveObj tin_date_mask_string
 
        PROCEDURE
              s60isnu1meric;
 
              tsp00_MoveObj tsp00_Date
 
        PROCEDURE
              s60isnu2meric;
 
              tsp00_MoveObj tsp00_Time
 
        PROCEDURE
              sqlwrite;
 
              tsp00_Line tsp00_Line
 
        PROCEDURE
              sqldattime;
 
              tsp00_Date tsp00_Date
              tsp00_Time tsp00_Time
 
.CM *-END-* synonym -------------------------------------
.sp;.cp 3
Author  :
.sp
.cp 3
Created : 1985-10-01
.sp
.cp 3
.CM %end
.cp 3
Release :      Date : 1998-06-19
.sp
.cp 3
.sp
.pb '$'
.sp
***********************************************************
.sp
.cp 10
.fo
.oc _/1
Specification:
 
Dieser Modul dient zur Ausgabe von Datum und Zeit mittels
Masken.
.sp 2
Diese Masken m?ussen folgenden Aufbau haben:
.sp 2
.oc _/1;Datum:
.sp 1
.in +20;.un 20
Tagangabe: TT oder DD. Es m?ussen genau zwei Zeichen angegeben
werden.
.sp;.un 20;Monatsangabe: MM oder MMM. Bei Angabe von zwei Zeichen
wird die Monatsangabe in Ziffern (z.B. 09), bei drei Zeichen
in einer dreibuchstabigen Abk?urzung (z.B. Sep) ausgegeben. Werden
mehr als drei Zeichen angegeben, werden entsprechend viele Zeichen
des Monatsnamens ?ubernommen.
.sp;.un 20;Jahresangabe: JJ (YY) oder JJJJ (YYYY).
Bei vierstelliger Ausgabe
wird die "19" mit ausgegeben (z.B. 1985).
.sp;.in -20;Die Reihenfolge dieser Angaben ist beliebig, es
k?onnen eine oder mehrere fehlen: Z.B.
kann nur der Tag oder nur Tag und Monat ausgegeben werden;
es mu?z aber mindestens eine Angabe vorhanden sein.
.sp;F?ur diese Definitionen k?onnen Gro?z- oder Kleinbuchstaben
verwendet werden.
.sp;Zwischen zwei Datumsfeldern kann ein Trennzeichen und zus?atzlich
ein Leerzeichen eingeschoben werden. Trennzeichen zu Beginn und
am Ende sind nicht erlaubt.
.sp 2
.oc _/1;Uhrzeit
.sp 1
.in +20;.un 20
Stundenangabe: HH oder HHHH.
.sp;.un 20;Minutenangabe: MM.
.sp;.un 20;Sekundenangabe: SS.
.cp 8;.in -20;.sp;Hier m?ussen
Reihenfolge und Anzahl genau eingehalten werden;
es k?onnen jedoch auch die Sekundenangabe oder Minuten- und Sekunden-
angabe weggelassen werden. Nach der Uhrzeit kann durch die Angabe von
AM oder PM die Ausgabe in 12- oder 24- Stundendarstellung und AM bzw.
PM Angabe gesteuert werden.
.sp;F?ur Trennzeichen gelten die gleichen Regeln wie bei der
Datumsangabe.
.sp;Bei vierstelliger Stundenangabe sind bis zu 9999 Stunden erlaubt,
bei Zuweisung auf eine zweistellige Stundenangabe oder eine
vierstellige AM/PM Darstellung werden sie in eine
gueltige 24-Stundendarstellung (s.o) umgewandelt.
.pa;.oc _/1;Aufruf der Prozeduren
.nf;.sp 2
CONST
      mi_date_mask_string = 13;
 
TYPE
      ti_date_mask_string =
                 PACKED ARRAY [  1 .. mi_date_mask_string  ] OF char;
 
      date_format = RECORD
                  order : ti_natural;
                  mform : 0 .. 1;
                  yform : 0 .. 1;
      END;
 
      ti_date_mask = RECORD
                  form  : date_format;
                  mlen  : ti_natural;
                  msk   : ti_date_mask_string;
      END;
 
 (*------------------------------*)
 
.cp 6;PROCEDURE
      i41dparse (VAR mask : ti_date_mask;
                  VAR error   : integer;
                  VAR errpos  : ti_natural);
.fo;.sp 2
.oc _/1;Parsen einer Datumsmaske
.sp
Der Inhalt der Maske (mask.msk) wird auf syntaktische Richtigkeit
gepr?uft, und es werden in
.sp;.nf;           mask.format
.fo;.sp;Informationen ?uber das Ausgabeformat abgelegt.
.sp;Die Maske bleibt weiterhin
lesbar und kann ausgegeben werden.
.sp;Bei Syntaxfehlern wird error auf eine Zahl zwischen 18000
und 18999 gesetzt, errpos gibt die Fehlerposition an.
.sp 2;.nf
 (*------------------------------*)
 
.cp 6;PROCEDURE
      i41tparse (VAR mask : ti_date_mask;
                  VAR error   : integer;
                  VAR errpos  : ti_natural);
.fo;.sp 2
.oc _/1;Parsen einer Zeitmaske
.sp
Der Inhalt der Maske (mask.msk) wird auf syntaktische Richtigkeit
gepr?uft.
.sp;Bei Syntaxfehlern wird error auf eine Zahl zwischen 18000
und 18999 gesetzt, errpos gibt die Fehlerposition an.
.sp 2;.nf
 (*------------------------------*)
 
.cp 6;PROCEDURE
      i41tsparse (VAR mask : ti_date_mask;
                  VAR error   : integer;
                  VAR errpos  : ti_natural);
.fo;.sp 2
.oc _/1;Parsen einer Datums/Zeit-Maske f?ur TIMESTAMP-Operationen
.sp
Der Inhalt der Maske (mask.msk) wird auf syntaktische Richtigkeit
gepr?uft.
.sp
B.M. 30.06.95 Release 6.1.1 CL 13D: Es kann auch ein Teil der Maske
fehlen - nur Dateumsmaske oder nur Uhrzeit. In diesem Fall wird bei
der Eingabe in i41tsget der fehlende Teil dazugeneriert: 00:00:00
bei fehlender Uhrzeit bzw. das aktuelle Datum bei fehlendem Datum.
Bei der Ausgabe wird der entsprechende Teil weggelassen.
.sp 2;.nf
 (*------------------------------*)
 
.cp 8;PROCEDURE
      i41dput (VAR mask   : ti_date_mask;
                  VAR date_string   : c8;
                  VAR outputfield   : ti_date_mask);
.fo;.sp 2
.oc _/1;Maskierte Datumsausgabe
.sp
Der Inhalt von date_string wird gem?a?z der Maskendefinition
in outputfield ausgegeben.
Die Maske mu?z bereits mit i41dparse
bearbeitet worden sein.
.sp 2;.nf
 (*------------------------------*)
 
.cp 8;PROCEDURE
      i41tput (VAR mask   : ti_date_mask;
                  VAR time_string   : c8;
                  VAR outputfield   : ti_date_mask);
.fo;.sp 2
.oc _/1;Maskierte Zeitausgabe
.sp
Der Inhalt von time_string wird gem?a?z der Maskendefinition
in outputfield ausgegeben. Bei der Ausgabe von vier- auf zweistelliges
Stundenformat wird die Zeit in eine g?ultige Uhrzeit gewandelt
Die Maske mu?z bereits mit i41tparse
bearbeitet worden sein.
.sp 2;.nf
 (*------------------------------*)
 
.cp 8
FUNCTION
      i41dlen (
            VAR mask : tin_date_mask) : integer;
und
FUNCTION
      i41tlen (
            VAR mask : tin_date_mask) : integer;
.fo;.sp 2
.oc _/1;Berechnung der Ausgabel?ange
.sp
Die beiden Funktionen berechnen die L?ange der Zeichenkette,
die aufgrund des eingestellten Formates (dm_type)
aus dem Datenbank-Datums- bzw. Zeitfeld hergestellt wird.
Wird f?ur die Berechnung tabellarischer Ausgabepositionen gebraucht.
.sp 2;
.oc _/1;Vordefinierte Formate - Timestamp
.sp
Es werden folgende Masken angenommen:
.sp;.nf
      ISO : YYYY-MM-DD HH:MM:SS.MMMMMM
      USA : YYYY-MM-DD-HH.MM.SS.MMMMMM
      EUR : YYYY-MM-DD-HH.MM.SS.MMMMMM
      JIS : YYYY-MM-DD-HH.MM.SS.MMMMMM
      INT : YYYYMMDDHHMMSSNNNNNN
.fo
.CM %end
.CM *-END-* specification -------------------------------
.sp 2
.CM %if %not doku
.CM %begin
***********************************************************
.sp
.cp 10
.fo
.oc _/1
Description:
 
.CM *-END-* description ---------------------------------
.sp 2
***********************************************************
.sp
.cp 10
.nf
.oc _/1
Structure:
 
.CM *-END-* structure -----------------------------------
.sp 2
**********************************************************
.sp
.cp 10
.nf
.oc _/1
.CM -lll-
Code    :
 
 
CONST
      dmask_iso        = 'YYYY-MM-DD                                        ';
      l_dmask_iso      = 10;
      tmask_iso        = 'HH:MM:SS                                          ';
      l_tmask_iso      = 8;
      tsmask_iso       = 'YYYY-MM-DD HH:MM:SS.NNNNNN                        ';
      l_tsmask_iso     = 26;
      (* *)
      dmask_usa        = 'MM/DD/YYYY                                        ';
      l_dmask_usa      = 10;
      tmask_usa        = 'HH:MM AM                                          ';
      l_tmask_usa      = 8;
      tsmask_usa       = 'YYYY-MM-DD-HH.MM.SS.NNNNNN                        ';
      l_tsmask_usa     = 26;
      (* *)
      dmask_eur        = 'DD.MM.YYYY                                        ';
      l_dmask_eur      = 10;
      tmask_eur        = 'HH.MM.SS                                          ';
      l_tmask_eur      = 8;
      tsmask_eur       = tsmask_usa;
      l_tsmask_eur     = l_tsmask_usa;
      (* *)
      dmask_jis        = 'YYYY-MM-DD                                        ';
      l_dmask_jis      = 10;
      tmask_jis        = tmask_iso;
      l_tmask_jis      = l_tmask_iso;
      tsmask_jis       = tsmask_usa;
      l_tsmask_jis     = l_tsmask_usa;
      (* *)
      dmask_int        = 'YYYYMMDD                                          ';
      l_dmask_int      = 8;
      tmask_int        = 'HHHHMMSS                                          ';
      l_tmask_int      = 8;
      tsmask_int       = 'YYYYMMDDHHMMSSNNNNNN                              ';
      l_tsmask_int     = 20 ;
      (* *)
      abbrev_month_msgno  = 17401;
      january_june_msgno  = 17402;
      july_december_msgno = 17403;
      month_names_in_msg  = 6;
      (* *)
      sysset_tab_offset   = 17401;
      sysset_invalid_time = 12;
      sysset_invalid_date = 13;
      (*                   *)
      year_char_1       = 'J';
      year_char_2       = 'Y';
      month_char        = 'M';
      day_char_1        = 'T';
      day_char_2        = 'D';
      max_datefields = 3;
      (*                   *)
      hour_char         = 'H';
      minute_char       = 'M';
      second_char       = 'S';
      am_pm_char1       = 'A';
      am_pm_char11      = 'P';
      am_pm_char2       = 'M';
      max_timefields = 4;
      micro_char        = 'N';
      micro_char_lower  = 'n';
      max_microdigits   = 6;
      (*                   *)
      (*  for year.form    *)
      (*                   *)
      two_digits        =  2;
      four_digits       =  4;
      (*                   *)
      (*  for month.form  *)
      (*                   *)
      by_digits         =  0;
      max_monthchars    = 12;
      (*                  *)
      orig_century_pos  =  1;
      orig_year_pos     =  3;
      orig_month_pos    =  5;
      orig_day_pos      =  7;
      orig_hour_pos     =  3;
      orig_minute_pos   =  5;
      orig_partlen      =  2;
      (* *)
      date_mask_infobytes = 12;
      (* *)
      (* for timestamp: hour presentation in internal time format
      has 2 digits more
      than in internal timestamp format *)
      excess_hours = 2;
      (* Fehlercodes          *)
      mk_d_ok               = 0;
      mask_mismatch         = 2;
      wrong_fieldlength     = 3;
      invalid_symbol        = 4;
      no_delimiter_allowed  = 5;
      wrong_timefield_order = 6;
      dtmask_too_long       = 7;
      inputmask_incomplete  = 9;
      input_too_long        = 10;
      input_too_short       = 11;
      (* for internal use:    12 *)
      (* for internal use:    13 *)
      wrong_monthname       = 14;
      invalid_date_or_time  = 15;
      delimiter_after_end   = 16;
      second_delimiter      = 17;
      wrong_dtmask          = 18;
      timestamp_incomplete  = 19;
      no_date_mask          = 20;
      last_mk_d_error       = 20;
      (* lokale Typen *)
 
TYPE
      field_position = - 1 .. 4;
 
      year_record = RECORD
            pos  : field_position;
            form : two_digits .. four_digits;
      END;
 
 
      month_record = RECORD
            pos  : field_position;
            form : by_digits .. max_monthchars;
      END;
 
 
      day_record = RECORD
            pos : field_position;
      END;
 
 
      date_descriptor = RECORD
            global_pos  : field_position;
            mask_length : integer;
            year        : year_record;
            month       : month_record;
            day         : day_record;
      END;
 
      am_pm_type = ( no_am, am_upper, am_lower );
 
      time_descriptor = RECORD
            global_pos  : field_position;
            mask_length : integer;
            hform       : 2..4; (* two or 4 digits *)
            tunits      : 0..3; (* hh / hhmm / hhmmss *)
            am_pm       : am_pm_type;
      END;
 
      mask_type = ( mt_date, mt_time, mt_timestamp );
      timestamp_order = PACKED ARRAY [ 1..2 ] OF mt_date .. mt_time ;
 
      timestamp_descriptor = RECORD
            order          : timestamp_order;
            ddesc          : date_descriptor ;
            date_start     : integer ;
            tdesc          : time_descriptor ;
            time_start     : integer ;
            tsmask_length  : integer;
            micro_start    : integer;
            nr_microdigits : integer;
      END;
 
 
      runtime_timestamp_record = RECORD
            dmask          : tin_date_mask;
            date_start     : integer ;
            d_inlen        : integer;
            tmask          : tin_date_mask;
            time_start     : integer;
            t_inlen        : integer;
            micro_start    : integer;
            nr_microdigits : integer;
            default_today  : tsp00_Date;
      END;
 
 
      internal_mask = RECORD
            pos : tin_natural;
            len : 0 .. mxin_date_mask_string;
            buf : tin_date_mask_string;
      END;
 
 
      int_buffer = RECORD
            pos : tin_natural;
            len : tin_natural;
            buf : tin_screenline;
      END;
 
      symbolcount = 0 .. mxin_date_mask_string;
      countset    = PACKED SET OF symbolcount;
      charset     = SET OF char;
      mk_d_error  = mk_d_ok .. last_mk_d_error ;
      month_nr    = 0 .. 12;
 
 
(*------------------------------*) 
 
PROCEDURE
      i41dparse (
            VAR mask   : tin_date_mask;
            VAR error  : integer;
            VAR errpos : tin_natural);
 
VAR
      internal_error : mk_d_error;
      i_mask         : internal_mask;
      ddesc          : date_descriptor;
 
BEGIN
ddesc.global_pos := 0;
dparse_i41 ( mask, 1, i_mask, ddesc, internal_error, errpos );
IF  internal_error = mk_d_ok
THEN
    mask.tlen := put_ddesc (ddesc, mask.msk, mask.mlen );
(*ENDIF*) 
out_error (internal_error, mt_date, error);
END; (* i41dparse *)
 
(*------------------------------*) 
 
PROCEDURE
      dparse_i41 (
            VAR mask           : tin_date_mask;
            pos                : integer;
            VAR i_mask         : internal_mask;
            VAR ddesc          : date_descriptor;
            VAR internal_error : mk_d_error;
            VAR errpos         : tin_natural);
 
BEGIN
internal_error := mk_d_ok;
errpos         := 0;
check_standardformats ( mask, mt_date );
ddesc.mask_length := mask.mlen;
(*
      *  Special handling for free defined masks only
      *)
IF  mask.dm_type = dm_free
THEN
    BEGIN
    get_mask (mask, pos, i_mask, internal_error, errpos);
    IF  internal_error = mk_d_ok
    THEN
        BEGIN
        init_ddesc( ddesc );
        (**************************)
        parse_dmask (i_mask, ddesc, internal_error);
        (**************************)
        (* 27/09/91 R.Roedling *)
        IF  internal_error = mk_d_ok
        THEN
            BEGIN
            mask.msk  := i_mask.buf;
            mask.mlen := i_mask.len;
            END
        ELSE
            errpos := i_mask.pos;
        (*ENDIF*) 
        ddesc.mask_length := i_mask.len;
        END;
    (*ENDIF*) 
    END;
(*ENDIF*) 
IF  errpos > 0
THEN
    errpos := errpos + pos - 1;
(*ENDIF*) 
END; (* dparse_i41 *)
 
(*------------------------------*) 
 
PROCEDURE
      init_ddesc (VAR ddesc : date_descriptor);
 
BEGIN
WITH ddesc DO
    BEGIN
    year.pos   := 0;
    year.form  := two_digits;
    month.pos  := 0;
    month.form := by_digits;
    day.pos    := 0;
    END;
(*ENDWITH*) 
END; (* init_ddesc *)
 
(*------------------------------*) 
 
PROCEDURE
      i41tparse (
            VAR mask   : tin_date_mask;
            VAR error  : integer;
            VAR errpos : tin_natural);
 
VAR
      internal_error : mk_d_error;
      i_mask         : internal_mask;
      tdesc          : time_descriptor;
 
BEGIN
internal_error := mk_d_ok ;
tdesc.global_pos := 0;
tparse_i41 ( mask, 1, i_mask, tdesc, internal_error, errpos );
IF  internal_error = mk_d_ok
THEN
    mask.tlen := put_tdesc (tdesc, mask.msk, mask.mlen );
(*ENDIF*) 
out_error (internal_error, mt_time, error);
END; (* i41tparse *)
 
(*------------------------------*) 
 
PROCEDURE
      tparse_i41 (
            VAR mask           : tin_date_mask;
            pos                : integer;
            VAR i_mask         : internal_mask;
            VAR tdesc          : time_descriptor;
            VAR internal_error : mk_d_error;
            VAR errpos         : tin_natural);
 
BEGIN
errpos := 0;
check_standardformats ( mask, mt_time );
tdesc.mask_length := mask.mlen - pos + 1;
IF  mask.dm_type = dm_free
THEN
    BEGIN
    get_mask (mask, pos, i_mask, internal_error, errpos);
    IF  internal_error = mk_d_ok
    THEN
        BEGIN
        WITH tdesc DO
            BEGIN
            am_pm := no_am;
            tunits := 0;
            END;
        (*ENDWITH*) 
        (**************************)
        parse_tmask (i_mask, tdesc, internal_error);
        (**************************)
        IF  internal_error = mk_d_ok
        THEN
            WITH mask DO
                BEGIN
                msk := i_mask.buf;
                mlen := i_mask.len;
                END
            (*ENDWITH*) 
        ELSE
            errpos := i_mask.pos;
        (*ENDIF*) 
        tdesc.mask_length := i_mask.len;
        END;
    (*ENDIF*) 
    END;
(*ENDIF*) 
IF  errpos > 0
THEN
    errpos := errpos + pos - 1;
(*ENDIF*) 
END; (* tparse_i41 *)
 
(*------------------------------*) 
 
PROCEDURE
      i41tsparse (
            VAR mask   : tin_date_mask;
            VAR error  : integer;
            VAR errpos : tin_natural);
 
VAR
      result_mask    : tin_date_mask;
      internal_error : mk_d_error;
      tsdesc         : timestamp_descriptor ;
      pos            : integer;
      i              : 1..2;
      special_chars  : charset;
      delimiters     : charset;
 
BEGIN
special_chars := [hour_char, minute_char, second_char, am_pm_char1, am_pm_char11,
      year_char_1, year_char_2, month_char, day_char_1, day_char_2] ;
init_delimiterset ( delimiters, special_chars );
const_check_i41;
internal_error   := mk_d_ok ;
errpos           := 0;
result_mask.mlen := 0;
check_standardformats ( mask, mt_timestamp );
(*
      *  Special handling for free defined masks only
      *)
IF   mask.dm_type = dm_free
THEN
    BEGIN
    result_mask.dm_type := mask.dm_type ;
    check_timestamp_order( mask, tsdesc );
    pos := 1;
    FOR i := 1 TO 2 DO
        IF  internal_error = mk_d_ok
        THEN
            BEGIN
            CASE tsdesc.order[i] OF
                mt_date:
                    tsparse_date( i, mask, pos, result_mask,
                          tsdesc, internal_error, errpos );
                mt_time:
                    tsparse_time( i, mask, pos, result_mask,
                          tsdesc, internal_error, errpos );
                END;
            (*ENDCASE*) 
            IF  ( i = 1 ) AND ( internal_error = mk_d_ok )
            THEN
                BEGIN
                IF  mask.msk [ pos ] IN delimiters
                THEN
                    BEGIN
                    (* skip date / time separator if there is any *)
                    result_mask.mlen := result_mask.mlen + 1;
                    result_mask.msk [ result_mask.mlen ] := mask.msk [ pos ];
                    pos := pos + 1;
                    END;
                (*ENDIF*) 
                END;
            (*ENDIF*) 
            END;
        (*ENDIF*) 
    (*ENDFOR*) 
    IF  internal_error = timestamp_incomplete
    THEN
        internal_error := mk_d_ok;
    (*ENDIF*) 
    IF  internal_error = mk_d_ok
    THEN
        BEGIN
        result_mask.tlen := put_tsdesc (tsdesc, result_mask.msk,
              result_mask.mlen );
        mask             := result_mask;
        END;
    (*ENDIF*) 
    END;
(*ENDIF*) 
out_error ( internal_error, mt_timestamp, error ) ;
END; (* i41tsparse *)
 
(*------------------------------*) 
 
PROCEDURE
      check_timestamp_order(VAR mask   : tin_date_mask;
            VAR tsdesc : timestamp_descriptor);
 
VAR
      act_char : char;
 
BEGIN
act_char := i32toupper ( mask.msk [ 1 ] );
WITH tsdesc DO
    IF  ( act_char = hour_char )
    THEN
        BEGIN
        order [ 1 ] := mt_time;
        order [ 2 ] := mt_date;
        tdesc.global_pos := 0;
        ddesc.global_pos := -1;
        END
    ELSE
        BEGIN
        order [ 1 ] := mt_date;
        order [ 2 ] := mt_time;
        ddesc.global_pos := 0;
        tdesc.global_pos := -1;
        END;
    (*ENDIF*) 
(*ENDWITH*) 
END; (* check_timestamp_order *)
 
(*------------------------------*) 
 
PROCEDURE
      tsparse_date (
            order              : integer;
            VAR mask           : tin_date_mask;
            VAR pos            : integer;
            VAR result_mask    : tin_date_mask;
            VAR tsdesc         : timestamp_descriptor ;
            VAR internal_error : mk_d_error;
            VAR errpos         : tin_natural );
 
VAR
      i_mask : internal_mask;
 
BEGIN
tsdesc.date_start := pos;
dparse_i41( mask, pos, i_mask, tsdesc.ddesc, internal_error, errpos );
IF  ( internal_error = mk_d_ok )
THEN
    BEGIN
    IF  order = 1
    THEN
        BEGIN
        (* no character follows: timestamp mask is incomplete *)
        internal_error := timestamp_incomplete ;
        (* no time follows: *)
        WITH tsdesc.tdesc DO
            BEGIN
            global_pos  := 0;
            mask_length := 0;
            hform       := 2;
            tunits      := 0;
            am_pm       := no_am;
            END;
        (*ENDWITH*) 
        tsdesc.time_start := 0;
        tsdesc.micro_start := 0;
        tsdesc.nr_microdigits := 0;
        errpos := i_mask.len + 1;
        END
    (*ENDIF*) 
    END
ELSE
    IF  ( internal_error = delimiter_after_end ) OR
        ( internal_error = invalid_symbol )
    THEN
        BEGIN
        IF  order = 1
        THEN
            BEGIN
            (* try with time *)
            i_mask.len := errpos - 1 ;
            internal_error := mk_d_ok;
            END;
        (*ENDIF*) 
        END
    ELSE
        IF  (internal_error = no_date_mask)
        THEN
            BEGIN
            tsdesc.date_start := 0;
            internal_error    := mk_d_ok;
            END;
        (*ENDIF*) 
    (*ENDIF*) 
(*ENDIF*) 
IF  (internal_error = mk_d_ok) OR
    (internal_error = timestamp_incomplete)
THEN
    BEGIN
    append_mask ( result_mask, i_mask );
    tsdesc.ddesc.mask_length := i_mask.len ;
    pos := errpos;
    errpos := 0;
    END;
(*ENDIF*) 
END; (* tsparse_date *)
 
(*------------------------------*) 
 
PROCEDURE
      tsparse_time (
            order              : integer ;
            VAR mask           : tin_date_mask;
            VAR pos            : integer;
            VAR result_mask    : tin_date_mask;
            VAR tsdesc         : timestamp_descriptor ;
            VAR internal_error : mk_d_error;
            VAR errpos         : tin_natural );
 
VAR
      i_mask : internal_mask;
 
BEGIN
tsdesc.time_start := pos;
tparse_i41 ( mask, pos, i_mask, tsdesc.tdesc, internal_error, errpos );
IF  ( internal_error = mk_d_ok )
THEN
    BEGIN
    tsdesc.tdesc.mask_length := i_mask.len ;
    append_mask ( result_mask, i_mask );
    tsdesc.micro_start := 0;
    tsdesc.nr_microdigits := 0 ;
    IF  order = 1
    THEN
        BEGIN
        (* no character follows: timestamp mask is incomplete *)
        internal_error := timestamp_incomplete ;
        (* no date follows: *)
        init_ddesc( tsdesc.ddesc );
        tsdesc.ddesc.mask_length := 0;
        tsdesc.date_start := 0;
        errpos := i_mask.len + 1;
        END;
    (*ENDIF*) 
    END
ELSE
    IF  ( internal_error = second_delimiter )    OR
        ( internal_error = delimiter_after_end ) OR
        ( internal_error = invalid_symbol )
    THEN
        BEGIN
        (* try with microseconds *)
        IF  ( internal_error = second_delimiter )
        THEN
            errpos := errpos - 1;   (* errpos points 2 behind length *)
        (*ENDIF*) 
        IF  (i32toupper ( mask.msk [ errpos ] ) = micro_char)
        THEN
            (* MICRO_CHAR has been detected as delimiter *)
            errpos := errpos - 1
        ELSE
            IF  (order = 1) AND (internal_error = invalid_symbol)
            THEN
                (* probably DATE CHAR *)
                errpos := errpos - 1;
            (*ENDIF*) 
        (*ENDIF*) 
        internal_error := mk_d_ok;
        i_mask.len := errpos - pos + 1;
        (* i_mask already contains separator *)
        (*tsdesc.tdesc.mask_length := i_mask.len;  - 1; *)
        tsdesc.tdesc.mask_length := i_mask.len - 1;
        append_mask ( result_mask, i_mask );
        pos := errpos + 1;
        (*
              * Parse microseconds
              *)
        microseconds_parse( mask, pos, i_mask, tsdesc, internal_error, errpos );
        IF  (internal_error = delimiter_after_end) OR
            (internal_error = wrong_dtmask)
        THEN
            BEGIN
            IF  order = 1
            THEN
                BEGIN
                i_mask.len := errpos - pos ;
                IF  (internal_error = delimiter_after_end)
                THEN
                    BEGIN
                    i_mask.len := i_mask.len + 1;
                    pos := errpos + 1;
                    END;
                (*
                      *  Reset error code
                      *)
                (*ENDIF*) 
                internal_error := mk_d_ok;
                END
            ELSE
                IF  (internal_error = delimiter_after_end)
                THEN
                    internal_error := dtmask_too_long ;
                (*ENDIF*) 
            (*ENDIF*) 
            END
        ELSE
            pos := pos + tsdesc.nr_microdigits + 1;
        (*ENDIF*) 
        IF  internal_error = mk_d_ok
        THEN
            BEGIN
            (* Microdigits have successfully been parsed -
                  update mask and position *)
            append_mask( result_mask, i_mask );
            END;
        (*ENDIF*) 
        END;
    (*ENDIF*) 
(*ENDIF*) 
END; (* tsparse_time *)
 
(*------------------------------*) 
 
PROCEDURE
      append_mask (VAR dest : tin_date_mask;
            VAR src  : internal_mask );
 
BEGIN
s10mv (mxin_date_mask_string,mxin_date_mask_string,
      @src.buf,1,
      @dest.msk,dest.mlen + 1,src.len );
dest.mlen := dest.mlen + src.len ;
END; (* append_mask *)
 
(*------------------------------*) 
 
PROCEDURE
      microseconds_parse (
            VAR mask           : tin_date_mask;
            pos                : integer;
            VAR i_mask         : internal_mask;
            VAR tsdesc         : timestamp_descriptor;
            VAR internal_error : mk_d_error;
            VAR errpos         : tin_natural);
 
CONST
      undef_nr_microdigits = -1;
 
VAR
      i        : integer;
      act_char : char;
 
BEGIN
tsdesc.nr_microdigits := undef_nr_microdigits ;
internal_error := mk_d_ok;
errpos := 0;
tsdesc.micro_start := pos;
get_mask (mask, pos, i_mask, internal_error, errpos);
IF  internal_error = mk_d_ok
THEN
    BEGIN
    IF  ( i_mask.len = 0 )
    THEN
        tsdesc.nr_microdigits := 0
    ELSE
        BEGIN
        IF  (i_mask.buf[1] <> micro_char) AND
            (i_mask.buf[1] <> micro_char_lower)
        THEN
            BEGIN
            tsdesc.nr_microdigits := 0;
            (*
                  * This error may indicate that the date follows
                  without any microsecond specification
                  *)
            internal_error := wrong_dtmask;
            errpos := 1;
            END;
        (*ENDIF*)
        (*(i_mask.buf[1] <> micro_char_lower)*)
        END;
    (*ENDIF*) 
    END;
(* We come here only if there are microseconds specified *)
(*ENDIF*) 
IF  (internal_error = mk_d_ok) AND
    ( tsdesc.nr_microdigits = undef_nr_microdigits )
THEN
    BEGIN
    tsdesc.nr_microdigits := 0;
    i := 1;
    WHILE (internal_error = mk_d_ok) AND (i <= max_microdigits) AND
          (i <= i_mask.len) DO
        BEGIN
        (*act_char := i32toupper(i_mask.buf[i]);*)
        IF  (i_mask.buf[i] = micro_char_lower) OR (i_mask.buf[i] = micro_char)
        THEN
            tsdesc.nr_microdigits := tsdesc.nr_microdigits + 1
        ELSE
            BEGIN
            internal_error := invalid_symbol;
            errpos := i;
            END;
        (*ENDIF*) 
        i := i + 1;
        END;
    (*ENDWHILE*) 
    (*
          *  Pruefe, ob maske nach der max anzahl von mikrosekunden
          noch mikrosekundenzeichen hat oder ueberhaupt noch zeichen
          *)
    IF  (internal_error = mk_d_ok) AND (i <= i_mask.len) AND
        (i > max_microdigits)
    THEN
        BEGIN
        IF  (i_mask.buf[i] = micro_char_lower) OR (i_mask.buf[i] = micro_char)
        THEN
            internal_error := dtmask_too_long
        ELSE
            internal_error := delimiter_after_end;
        (*ENDIF*) 
        errpos := max_microdigits + 1;
        END;
    (*ENDIF*) 
    END;
(*ENDIF*) 
IF  errpos > 0
THEN
    errpos := errpos + pos - 1;
(*ENDIF*) 
END; (* microseconds_parse *)
 
(*------------------------------*) 
 
PROCEDURE
      check_standardformats (
            VAR mask : tin_date_mask;
            mt       : mask_type );
 
VAR
      imask : internal_mask;
 
BEGIN
set_imask_for_compare ( mask, imask );
IF  mask_equal (imask, cin_key_iso, mxin_key_iso)
THEN
    BEGIN
    mask.dm_type := dm_iso;
    mask.msk     := cin_key_iso;
    mask.mlen    := mxin_key_iso;
    END
ELSE
    IF  mask_equal (imask, cin_key_usa, mxin_key_usa)
    THEN
        BEGIN
        mask.dm_type := dm_usa;
        mask.msk     := cin_key_usa;
        mask.mlen    := mxin_key_usa;
        END
    ELSE
        IF  mask_equal (imask, cin_key_eur, mxin_key_eur)
        THEN
            BEGIN
            mask.dm_type := dm_eur;
            mask.msk     := cin_key_eur;
            mask.mlen     := mxin_key_eur;
            END
        ELSE
            IF  mask_equal (imask, cin_key_jis, mxin_key_jis)
            THEN
                BEGIN
                mask.dm_type := dm_jis;
                mask.msk     := cin_key_jis;
                mask.mlen    := mxin_key_jis;
                END
            ELSE
                IF  mask_equal (imask, cin_key_int, mxin_key_int)
                THEN
                    BEGIN
                    mask.dm_type := dm_int;
                    mask.msk     := cin_key_int;
                    mask.mlen    := mxin_key_int;
                    END
                ELSE
                    mask.dm_type := dm_free;
                (*ENDIF*) 
            (*ENDIF*) 
        (*ENDIF*) 
    (*ENDIF*) 
(*ENDIF*) 
END; (* check_standardformats *)
 
(*------------------------------*) 
 
PROCEDURE
      set_imask_for_compare (
            VAR mask  : tin_date_mask;
            VAR imask : internal_mask);
 
VAR
      i     : integer;
      stop  : boolean;
      found : boolean;
 
BEGIN
imask.buf := mask.msk;
i := 0;
found := false;
REPEAT
    i := i + 1;
    stop := (i > mask.mlen);
    IF  NOT stop
    THEN
        found := (imask.buf [i]  <> bsp_c1);
    (*ENDIF*) 
UNTIL
    stop OR found;
(*ENDREPEAT*) 
IF  found
THEN
    imask.pos := i
ELSE
    imask.pos := 1;
(*ENDIF*) 
WITH imask DO
    i32upstring ( buf, pos, buf, pos, mask.mlen - pos + 1 );
(*ENDWITH*) 
imask.len := mask.mlen - imask.pos + 1;
END; (* set_imask_for_compare *)
 
(*------------------------------*) 
 
FUNCTION
      mask_equal (
            VAR mask : internal_mask;
            keyconst : tin_date_mask_string;
            lkey     : integer) : boolean;
 
VAR
      equal : boolean;
 
BEGIN
&ifdef lngTRACE
m90sname( vin, 'Input Mask  ');
m90buf  (vin, mask.buf, mask.pos, mask.pos + mask.len - 1);
m90sname( vin, 'Compare Mask');
m90buf  (vin, keyconst, 1, lkey);
&endif
equal := (mask.len >= 3) AND ( mask.len <= lkey);
IF  equal
THEN
    equal := s30eq (keyconst, mask.buf, mask.pos, mask.len);
(*ENDIF*) 
mask_equal := equal;
END; (* mask_equal *)
 
(*------------------------------*) 
 
PROCEDURE
      get_mask (
            VAR mask   : tin_date_mask;
            pos        : integer;
            VAR i_mask : internal_mask;
            VAR error  : mk_d_error;
            VAR errpos : tin_natural);
 
VAR
      i,j : integer;
 
BEGIN
const_check_i41 ;
IF  mask.mlen - pos + 1 > mxin_date_mask_string
THEN
    BEGIN
    error := dtmask_too_long;
    errpos := mask.mlen - pos + 1 + 1;
    END
ELSE
    BEGIN
    error := mk_d_ok;
    j := 0;
    FOR i := pos TO mask.mlen DO
        BEGIN
        j := j + 1;
        i_mask.buf [ j ] := mask.msk [ i ];
        END;
    (*ENDFOR*) 
    i_mask.len := j;
    END;
(*ENDIF*) 
END; (* get_mask *)
 
(*------------------------------*) 
 
PROCEDURE
      parse_dmask(VAR i_mask : internal_mask;
            VAR ddesc  : date_descriptor;
            VAR error  : mk_d_error);
      (*
      *  This procedure is only called for free defined masks
      *)
 
VAR
      act_char      : char;
      special_chars : charset;
      delimiters    : charset;
      tmp_error_code: mk_d_error;
 
BEGIN
IF  (i_mask.len = 0)
THEN
    BEGIN
    (*
          *  No date given at all - in case of timestamp this may be ok,
          otherwise it's an error
          *)
    error      := no_date_mask;
    i_mask.pos := 1;
    END
ELSE
    BEGIN
    special_chars := [ year_char_1, year_char_2, month_char,
          day_char_1, day_char_2] ;
    init_delimiterset ( delimiters, special_chars );
    WITH i_mask DO
        BEGIN
        pos := 1;
        IF  ( ddesc.global_pos = - 1 ) AND
            NOT (i32toupper (buf [pos]) IN delimiters)
        THEN
            ddesc.global_pos := 0;
        (*ENDIF*) 
        REPEAT
            act_char := i32toupper (buf [ pos] );
            CASE act_char OF
                year_char_1, year_char_2:
                    case_year (i_mask, ddesc, error);
                month_char:
                    case_month (i_mask, ddesc, error);
                day_char_1, day_char_2:
                    case_day (i_mask, ddesc, error);
                OTHERWISE:
                    BEGIN
                    IF  act_char IN delimiters
                    THEN
                        case_delimiter (i_mask, ddesc.global_pos,
                              delimiters, max_datefields, error)
                    ELSE
                        error := invalid_symbol;
                    (*ENDIF*) 
                    END;
                END;
            (*ENDCASE*) 
        UNTIL
            (error <> mk_d_ok) OR (pos > len);
        (*ENDREPEAT*) 
        END;
    (*ENDWITH*) 
    (*
          *      Check if the mask is completely specified (year, month, day)
          * But be aware that error codes like case_delimiter and invalid_symbol
          are used in
          * caller functions for further processing (argzzz :-(( );
          * All these in here used case_<function>s return wrong_fieldlength in
          case of error,
          * so it might be good to check for this error before checking the completeness
          *)
    IF  (error <> wrong_fieldlength)
    THEN
        BEGIN
        tmp_error_code := error;
        completeness_check (ddesc, error);
        IF  (error = mk_d_ok)
        THEN
            error := tmp_error_code;    (* 'reactivate' error code *)
        (*ENDIF*) 
        END;
    (*ENDIF*) 
    END;
(*ENDIF*) 
END; (* parse_dmask *)
 
(*------------------------------*) 
 
PROCEDURE
      init_delimiterset (
            VAR delimiters    : charset ;
            VAR special_chars : charset ) ;
 
BEGIN
delimiters := [ chr(1) .. chr(255) ] - [ 'a'..'z' ] - ['A'..'Z']
      - ['0'..'9' ] - special_chars ;
END; (* init_delimiterset *)
 
(*------------------------------*) 
 
PROCEDURE
      parse_tmask (
            VAR i_mask : internal_mask;
            VAR tdesc  : time_descriptor;
            VAR error  : mk_d_error);
 
VAR
      act_char      : char;
      special_chars : charset;
      delimiters    : charset;
      is_lower      : boolean;
 
BEGIN
special_chars := [  hour_char, minute_char,
      second_char, am_pm_char1, am_pm_char11 ] ;
init_delimiterset ( delimiters, special_chars );
WITH i_mask DO
    BEGIN
    pos := 1;
    IF  ( tdesc.global_pos = - 1 )
        AND NOT (i32toupper (buf [pos]) IN delimiters)
    THEN
        tdesc.global_pos := 0;
    (*ENDIF*) 
    REPEAT
        act_char := buf [ pos] ;
        is_lower := i32islower( act_char );
        act_char := i32toupper ( act_char );
        IF  act_char IN special_chars
        THEN
            case_time_field(i_mask, act_char, is_lower, tdesc, error)
        ELSE
            IF  act_char IN delimiters
            THEN
                case_delimiter(i_mask, tdesc.global_pos, delimiters,
                      max_timefields, error)
            ELSE
                error := invalid_symbol;
            (*ENDIF*) 
        (*ENDIF*) 
    UNTIL
        (error <> mk_d_ok) OR (pos > len);
    (*ENDREPEAT*) 
    END;
(*ENDWITH*) 
END; (* parse_tmask *)
 
(*------------------------------*) 
 
PROCEDURE
      case_year (VAR i_mask : internal_mask;
            VAR ddesc  : date_descriptor;
            VAR error  : mk_d_error);
 
CONST
      yearcount1 = 2;
      yearcount2 = 4;
 
VAR
      allowed_counts  : countset;
      allowed_symbols : charset;
      count           : symbolcount;
 
BEGIN
allowed_counts := [ yearcount1, yearcount2] ;
allowed_symbols := [ year_char_1, year_char_2] ;
WITH ddesc DO
    BEGIN
    check_field(i_mask, global_pos, year.pos,
          allowed_counts, allowed_symbols,
          max_datefields, count, error);
    IF  (error = mk_d_ok)
    THEN
        IF  count = yearcount1
        THEN
            year.form := two_digits
        ELSE
            year.form := four_digits;
        (*ENDIF*) 
    (*ENDIF*) 
    END;
(*ENDWITH*) 
END; (* case_year *)
 
(*------------------------------*) 
 
PROCEDURE
      check_field (
            VAR i_mask      : internal_mask;
            VAR global_pos  : field_position;
            VAR symbol_pos  : field_position;
            allowed_counts  : countset;
            allowed_symbols : charset;
            maxfields       : integer;
            VAR count       : symbolcount;
            VAR error       : mk_d_error);
 
VAR
      act_char : char;
      is_ok    : boolean;
 
BEGIN
IF  (global_pos >= maxfields) OR (symbol_pos > 0)
THEN
    error := invalid_symbol
ELSE
    BEGIN
    global_pos := global_pos + 1;
    symbol_pos := global_pos;
    count := 1;
    WITH i_mask DO
        BEGIN
        buf [ pos ] := i32toupper (buf [ pos] );
        IF  pos = len
        THEN
            error := wrong_fieldlength
        ELSE
            BEGIN
            REPEAT
                pos := pos + 1;
                IF  pos <= len
                THEN
                    BEGIN
                    act_char := i32toupper (buf [ pos] );
                    is_ok := act_char IN allowed_symbols;
                    IF  is_ok
                    THEN
                        BEGIN
                        count := count + 1;
                        buf [ pos ] := act_char;
                        END;
                    (*ENDIF*) 
                    END;
                (*ENDIF*) 
            UNTIL
                (NOT is_ok) OR (pos > len);
            (*ENDREPEAT*) 
            IF  NOT (count IN allowed_counts)
            THEN
                error := wrong_fieldlength;
            (*ENDIF*) 
            END;
        (*ENDIF*) 
        END;
    (*ENDWITH*) 
    END;
(*ENDIF*) 
END; (* check_field *)
 
(*------------------------------*) 
 
PROCEDURE
      case_month (VAR i_mask : internal_mask;
            VAR ddesc  : date_descriptor;
            VAR error  : mk_d_error);
 
CONST
      monthcount1 = 2;
      monthcount2 = 3;
 
VAR
      allowed_counts  : countset;
      allowed_symbols : charset;
      count           : symbolcount;
 
BEGIN
allowed_counts  := [monthcount1, monthcount2..max_monthchars] ;
(*allowed_counts := [ monthcount1, monthcount2];*)
allowed_symbols := [month_char] ;
WITH ddesc DO
    BEGIN
    check_field (i_mask, global_pos, month.pos,
          allowed_counts, allowed_symbols,
          max_datefields, count, error);
    (* 26/09/91 R.Roedling *)
    IF  error = mk_d_ok
    THEN
        BEGIN
        IF  count = monthcount1
        THEN
            month.form := by_digits
        ELSE
            month.form := count;
        (*ENDIF*) 
        END;
    (*ENDIF*) 
    END;
(*ENDWITH*) 
END; (* case_month *)
 
(*------------------------------*) 
 
PROCEDURE
      case_day (
            VAR i_mask : internal_mask;
            VAR ddesc  : date_descriptor;
            VAR error  : mk_d_error);
 
CONST
      daycount = 2;
 
VAR
      allowed_counts  : countset;
      allowed_symbols : charset;
      count           : symbolcount;
 
BEGIN
allowed_counts  := [ daycount] ;
allowed_symbols := [ day_char_1, day_char_2] ;
WITH ddesc DO
    check_field (i_mask, global_pos, day.pos,
          allowed_counts, allowed_symbols, max_datefields, count, error);
(*ENDWITH*) 
END; (* case_day *)
 
(*------------------------------*) 
 
PROCEDURE
      case_time_field (
            VAR i_mask : internal_mask;
            act_char   : char;
            is_lower   : boolean;
            VAR tdesc  : time_descriptor;
            VAR error  : mk_d_error);
 
VAR
      allowed_counts  : countset;
      allowed_symbols : charset;
      count           : symbolcount;
      time_pos        : field_position;
      bufpos          : integer;
 
BEGIN
IF  act_char = hour_char
THEN
    allowed_counts := [  2, 4  ]
ELSE
    allowed_counts := [  2 ] ;
(*ENDIF*) 
time_pos := 0;
bufpos := i_mask.pos;
IF  (act_char = am_pm_char1)
    OR (act_char = am_pm_char11)
THEN
    allowed_symbols := [  am_pm_char2  ]
ELSE
    BEGIN
    allowed_symbols := [  act_char ] ;
    IF  tdesc.tunits < 3
    THEN
        tdesc.tunits := tdesc.tunits + 1
    ELSE
        error := invalid_symbol;
    (*ENDIF*) 
    END;
(*ENDIF*) 
IF  error = mk_d_ok
THEN
    check_field (i_mask, tdesc.global_pos, time_pos,
          allowed_counts, allowed_symbols, max_timefields, count, error);
(*ENDIF*) 
IF  error = mk_d_ok
THEN
    BEGIN
    IF  act_char = hour_char
    THEN
        tdesc.hform := count;
    (*ENDIF*) 
    IF  (act_char = am_pm_char1)
        OR (act_char = am_pm_char11)
    THEN
        BEGIN
        IF  is_lower
        THEN
            BEGIN
            tdesc.am_pm := am_lower;
            i_mask.buf [ bufpos  ] := i32tolower( i_mask.buf [ bufpos  ] );
            i_mask.buf [ bufpos+1 ] := i32tolower( i_mask.buf [ bufpos+1  ] );
            END
        ELSE
            tdesc.am_pm := am_upper;
        (*ENDIF*) 
        END;
    (*ENDIF*) 
    END;
(*ENDIF*) 
time_pos_check (act_char, tdesc.global_pos, error);
END; (* case_time_field *)
 
(*------------------------------*) 
 
PROCEDURE
      time_pos_check (
            act_char   : char;
            global_pos : field_position;
            VAR error  : mk_d_error);
 
VAR
      allowed_pos : field_position;
 
BEGIN
IF  error = mk_d_ok
THEN
    IF  (act_char <> am_pm_char1)
        AND (act_char <> am_pm_char11)
    THEN
        BEGIN
        CASE act_char OF
            hour_char:
                allowed_pos := 1;
            minute_char:
                allowed_pos := 2;
            second_char:
                allowed_pos := 3;
            END;
        (*ENDCASE*) 
        IF  global_pos <> allowed_pos
        THEN
            error := wrong_timefield_order;
        (*ENDIF*) 
        END;
    (*ENDIF*) 
(*ENDIF*) 
END; (* time_pos_check *)
 
(*------------------------------*) 
 
PROCEDURE
      case_delimiter (
            VAR i_mask     : internal_mask;
            VAR global_pos : field_position;
            VAR delimiters : charset;
            maxfields      : integer;
            VAR error      : mk_d_error);
 
VAR
      delimiter_found : boolean;
      blank_found     : boolean;
      is_delimiter    : boolean;
      act_char        : char;
 
BEGIN
is_delimiter := true ;
blank_found := false;
delimiter_found := false;
IF  (global_pos = 0)
THEN
    error := no_delimiter_allowed
ELSE
    IF  (global_pos = maxfields)
    THEN
        error := delimiter_after_end
    ELSE
        WITH i_mask DO
            BEGIN
            IF  ( global_pos = - 1 )
            THEN
                global_pos := 0;
            (*ENDIF*) 
            pos := pos - 1;
            REPEAT
                pos := pos + 1;
                IF  pos <= len
                THEN
                    BEGIN
                    act_char := buf [ pos] ;
                    IF  act_char = bsp_c1
                    THEN
                        (* there may be one blank before and after
                              the delimiter *)
                        IF  blank_found
                        THEN
                            error := invalid_symbol
                        ELSE
                            blank_found := true
                        (*ENDIF*) 
                    ELSE
                        BEGIN
                        act_char := i32toupper (act_char);
                        is_delimiter := act_char IN delimiters;
                        IF  is_delimiter AND delimiter_found
                        THEN
                            error := second_delimiter ;
                        (*ENDIF*) 
                        delimiter_found := is_delimiter;
                        (* there may be one blank before and after
                              the delimiter *)
                        IF  delimiter_found
                        THEN
                            blank_found := false;
                        (*ENDIF*) 
                        END;
                    (*ENDIF*) 
                    END;
                (*ENDIF*) 
            UNTIL
                (error <> mk_d_ok) OR (NOT is_delimiter) OR (pos > len);
            (*ENDREPEAT*) 
            END;
        (*ENDWITH*) 
    (*ENDIF*) 
(*ENDIF*) 
END; (* case_delimiter *)
 
(*------------------------------*) 
 
FUNCTION
      put_ddesc (
            VAR ddesc : date_descriptor;
            VAR mask  : tin_date_mask_string;
            len       : integer ) : integer;
 
VAR
      order : integer;
 
BEGIN
WITH ddesc DO
    BEGIN
    order := year.pos;
    order := 4 * order + month.pos;
    order := 4 * order + day.pos;
    len := len + 1;
    mask [ len ] := chr (order);
    len := len + 1;
    mask [ len ] := chr (year.form);
    len := len + 1;
    mask [ len ] := chr (month.form);
    END;
(*ENDWITH*) 
put_ddesc := len;
END; (* put_ddesc *)
 
(*------------------------------*) 
 
FUNCTION
      put_tdesc (
            VAR tdesc : time_descriptor;
            VAR mask  : tin_date_mask_string ;
            len       : integer ) : integer;
 
BEGIN
len := len + 1;
mask [ len ] := chr (tdesc.hform * 16 + tdesc.tunits );
len := len + 1;
mask [ len ] := chr( ord(tdesc.am_pm) );
put_tdesc := len;
END; (* put_tdesc *)
 
(*------------------------------*) 
 
FUNCTION
      put_tsdesc (
            VAR tsdesc : timestamp_descriptor;
            VAR mask   : tin_date_mask_string ;
            len        : integer ) : integer;
 
BEGIN
len := len + 1;
mask [ len ] := chr ( tsdesc.date_start );
len := len + 1;
mask [ len ] := chr ( tsdesc.ddesc.mask_length );
len := put_ddesc ( tsdesc.ddesc, mask, len );
len := len + 1;
mask [ len ] := chr ( tsdesc.time_start );
len := len + 1;
mask [ len ] := chr ( tsdesc.tdesc.mask_length );
len := put_tdesc ( tsdesc.tdesc, mask, len );
len := len + 1;
mask [ len ] := chr ( tsdesc.micro_start ) ;
len := len + 1;
mask [ len ] := chr ( tsdesc.nr_microdigits ) ;
IF  tsdesc.date_start = 0
THEN
    len := put_ts_today(mask, len + 1);
(*ENDIF*) 
put_tsdesc := len;
END; (* put_tsdesc *)
 
(*------------------------------*) 
 
FUNCTION
      put_ts_today (VAR mask : tin_date_mask_string ;
            pos      : integer ) : integer;
 
VAR
      d : tsp00_Date;
      t : tsp00_Time;
 
BEGIN
(* moves the actual date to the mask for later use during i41tsget *)
sqldattime(d,t);
s10mv (mxsp_date,mxin_date_mask_string,
      @d,1,
      @mask,pos,mxsp_date);
(* return total length of mask *)
put_ts_today := pos + mxsp_date - 1;
END; (* put_ts_today *)
 
(*------------------------------*) 
 
PROCEDURE
      i41dput (
            VAR mask        : tin_date_mask;
            VAR date_string : tsp00_Date;
            VAR outputfield : tin_date_mask);
 
VAR
      i_mask        : internal_mask;
      ddesc         : date_descriptor;
      internal_date : internal_mask;
      special_chars : charset;
      dummy         : integer;
 
BEGIN
set_dmask_string (mask, i_mask);
dummy := get_ddesc (mask, ddesc, -1 );
internal_date_pres (date_string, ddesc, internal_date);
special_chars := [ year_char_1, year_char_2, month_char,
      day_char_1, day_char_2] ;
put_date_time (internal_date, special_chars, i_mask);
WITH outputfield DO
    WITH i_mask DO
        BEGIN
        mlen := len;
        s10mv (mxin_date_mask_string,mxin_date_mask_string,
              @buf,1,
              @msk,1,mlen);
        END
    (*ENDWITH*) 
(*ENDWITH*) 
END; (* i41dput *)
 
(*------------------------------*) 
 
PROCEDURE
      i41tput (
            VAR mask        : tin_date_mask;
            VAR time_string : tsp00_Time;
            VAR outputfield : tin_date_mask);
 
VAR
      i_mask        : internal_mask;
      internal_time : internal_mask;
      special_chars : charset;
      tdesc         : time_descriptor;
      dummy         : integer;
      (* Description:
      mask         : format of the output(-field)
      time_string  : time in INTERNAL-format
      outputfield  : time in given (mask-)format *)
 
BEGIN
set_tmask (mask, i_mask);
dummy := get_tdesc (mask, tdesc, -1 );
set_ttime (time_string, internal_time, tdesc);
special_chars := [  hour_char, minute_char, second_char ] ;
IF  tdesc.am_pm <> no_am
THEN
    BEGIN
    change_to_am_pm ( internal_time, tdesc );
    add_special_am_pm_chars ( special_chars, tdesc.am_pm = am_lower );
    END;
(*ENDIF*) 
put_date_time (internal_time, special_chars, i_mask);
WITH outputfield, i_mask DO
    BEGIN
    mlen := len;
    s10mv (mxin_date_mask_string,mxin_date_mask_string,
          @buf,1,
          @msk,1,mlen);
    END;
(*ENDWITH*) 
END; (* i41tput *)
 
(*------------------------------*) 
 
PROCEDURE
      i41tsput (
            VAR tsmask : tin_date_mask;
            VAR source : tsp00_Timestamp;
            VAR dest   : tin_date_mask);
 
VAR
      rtr        : runtime_timestamp_record ;
      tdesc      : time_descriptor;
      d_in       : tsp00_Date;
      t_in       : tsp00_Time;
      d_out      : tin_date_mask;
      t_out      : tin_date_mask;
      source_pos : integer;
      dest_pos   : integer;
      length     : integer;
      i          : integer;
      error      : integer;
      dummy      : integer;
 
BEGIN
(* convert from internal to formatted timestamp *)
tsmask_to_d_t_masks ( tsmask, rtr, error );
(* process date *)
source_pos := 1;
dest_pos := 1;
length := l_dmask_int ;
IF  (rtr.date_start > 0)
THEN
    BEGIN
    s10mv (mxsp_timestamp,mxsp_date,
          @source,source_pos,
          @d_in,dest_pos,length );
    i41dput ( rtr.dmask, d_in, d_out );
    END;
(*ENDIF*) 
source_pos := source_pos + length;
(* process time *)
length := l_tmask_int - excess_hours ;
IF  (rtr.time_start > 0)
THEN
    BEGIN
    (* hours in timestamp: 2 digits;
          in time: 4 digits *)
    FOR i := 1 TO excess_hours DO
        t_in [ i ] := '0';
    (*ENDFOR*) 
    dest_pos := excess_hours + 1;
    s10mv (mxsp_timestamp,mxsp_time,
          @source,source_pos,
          @t_in,dest_pos,length );
    i41tput ( rtr.tmask, t_in, t_out );
    END;
(*ENDIF*) 
source_pos := source_pos + length;
(* Copy the timestamp mask to DEST for the delimiters,
      then copy date and time separately *)
set_tsmask_string ( tsmask, dest );
IF    rtr.date_start > 0
THEN
    s10mv (mxin_date_mask_string,mxin_date_mask_string,
          @d_out.msk,1,
          @dest.msk,rtr.date_start,d_out.mlen );
(*ENDIF*) 
IF  rtr.time_start > 0
THEN
    BEGIN
    dummy := get_tdesc (rtr.tmask, tdesc, -1 );
    IF  tdesc.hform = 4
    THEN
        s10mv (mxin_date_mask_string,mxin_date_mask_string,
              @t_out.msk,1 + excess_hours,
              @dest.msk,rtr.time_start,t_out.mlen - excess_hours )
    ELSE
        s10mv (mxin_date_mask_string,mxin_date_mask_string,
              @t_out.msk,1,
              @dest.msk,rtr.time_start,t_out.mlen);
    (*ENDIF*) 
    IF  rtr.nr_microdigits > 0
    THEN
        BEGIN
        s10mv (mxsp_timestamp,mxin_date_mask_string,
              @source,source_pos,
              @dest.msk,rtr.micro_start,rtr.nr_microdigits );
        END;
    (*ENDIF*) 
    END;
(*ENDIF*) 
END; (* i41tsput *)
 
(*------------------------------*) 
 
PROCEDURE
      set_tsmask_string (
            VAR tsmask : tin_date_mask;
            VAR dest   : tin_date_mask );
 
BEGIN
dest.dm_type := tsmask.dm_type;
CASE tsmask.dm_type OF
    dm_free:
        dest := tsmask;
    dm_iso:
        BEGIN
        dest.msk := tsmask_iso;
        dest.mlen := l_tsmask_iso;
        END;
    dm_usa:
        BEGIN
        dest.msk := tsmask_usa;
        dest.mlen := l_tsmask_usa;
        END;
    dm_eur:
        BEGIN
        dest.msk := tsmask_eur;
        dest.mlen := l_tsmask_eur;
        END;
    dm_jis:
        BEGIN
        dest.msk := tsmask_jis;
        dest.mlen := l_tsmask_jis;
        END;
    dm_int:
        BEGIN
        dest.msk := tsmask_int;
        dest.mlen := l_tsmask_int;
        END;
    END;
(*ENDCASE*) 
END; (* set_tsmask_string *)
 
(*------------------------------*) 
 
PROCEDURE
      add_special_am_pm_chars (
            VAR special_chars : charset;
            lowercase         : boolean);
 
BEGIN
IF  lowercase
THEN
    special_chars := special_chars + [  i32tolower( am_pm_char1),
          i32tolower( am_pm_char11 ), i32tolower (am_pm_char2)  ]
ELSE
    special_chars := special_chars + [  am_pm_char1, am_pm_char11,
          am_pm_char2 ] ;
(*ENDIF*) 
END; (* add_special_am_pm_chars *)
 
(*------------------------------*) 
 
FUNCTION
      i41_sub_c2 (
            VAR str : tin_date_mask_string;
            sub     : tsp00_C2;
            pos     : integer) : boolean;
 
VAR
      greater : boolean;
 
BEGIN
(* subtracts (str[pos]*10+str[pos+1]) - (sub[1]*10+sub[2]) *)
(* iff result > 0 *)
greater := str [ pos ] > sub [1] ;
IF  NOT greater
THEN
    greater := (str [ pos ] = sub [1]  )
          AND (str [ pos+1 ] > sub [2]  );
(*ENDIF*) 
IF  greater
THEN
    BEGIN
    str [ pos+1 ] := sub_char( str [ pos+1] , sub [2]  );
    IF  str  [ pos+1 ] < '0'
    THEN
        BEGIN
        str [ pos+1 ] := chr ( ord( str [ pos+1 ] ) + 10);
        str [ pos ] := chr ( ord( str [ pos ] ) - 1);
        END;
    (*ENDIF*) 
    str [ pos ] := sub_char ( str [ pos ] , sub [1]  );
    END;
(*ENDIF*) 
i41_sub_c2 := greater;
END; (* i41_sub_c2 *)
 
(*------------------------------*) 
 
PROCEDURE
      i41_add_c2 (
            VAR str : tin_date_mask_string;
            sub     : tsp00_C2;
            pos     : integer);
 
VAR
      i : integer;
 
BEGIN
i := 10 * (ord( sub[1] ) + ord( str[pos] )   - 2 * ord('0')) +
      ord( sub[2] ) + ord( str[pos+1] ) - 2 * ord('0');
str [ pos ]    := chr ( i DIV 10 + ord ('0'));
str [ pos +1 ] := chr ( i MOD 10 + ord ('0'));
END; (* i41_add_c2 *)
 
(*------------------------------*) 
 
PROCEDURE
      concat_c2 (
            VAR imask : internal_mask;
            cc        : tsp00_C2;
            to_lower  : boolean);
 
VAR
      i : integer;
 
BEGIN
FOR i := 1 TO 2 DO
    IF  to_lower
    THEN
        imask.buf [ imask.len+i ] := i32tolower( cc [i]  )
    ELSE
        imask.buf [ imask.len+i ] := cc [i] ;
    (*ENDIF*) 
(*ENDFOR*) 
imask.len := imask.len + 2;
END; (* concat_c2 *)
 
(*------------------------------*) 
 
FUNCTION
      sub_char (
            c1, c2 : char ) : char;
 
VAR
      res : char;
 
BEGIN
res := chr ( ord( c1 ) - ord( c2 ) + ord('0') );
sub_char := res;
END; (* sub_char *)
 
(*------------------------------*) 
 
FUNCTION
      add_char (
            c1, c2 : char ) : char;
 
VAR
      res : char;
 
BEGIN
res := chr ( ord( c1 ) + ord( c2 ) - ord('0') );
add_char := res;
END; (* add_char *)
 
(*------------------------------*) 
 
PROCEDURE
      set_dmask_string (
            VAR mask   : tin_date_mask;
            VAR i_mask : internal_mask);
 
BEGIN
CASE mask.dm_type OF
    dm_free:
        BEGIN
        i_mask.buf := mask.msk;
        i_mask.len := mask.mlen;
        END;
    dm_iso:
        BEGIN
        i_mask.buf := dmask_iso;
        i_mask.len := l_dmask_iso;
        END;
    dm_usa:
        BEGIN
        i_mask.buf := dmask_usa;
        i_mask.len := l_dmask_usa;
        END;
    dm_eur:
        BEGIN
        i_mask.buf := dmask_eur;
        i_mask.len := l_dmask_eur;
        END;
    dm_jis:
        BEGIN
        i_mask.buf := dmask_jis;
        i_mask.len := l_dmask_jis;
        END;
    dm_int:
        BEGIN
        i_mask.buf := dmask_int;
        i_mask.len := l_dmask_int;
        END;
    END;
(*ENDCASE*) 
i_mask.pos := 0;
END; (* set_dmask_string *)
 
(*------------------------------*) 
 
PROCEDURE
      set_tmask (
            VAR mask   : tin_date_mask;
            VAR i_mask : internal_mask);
 
BEGIN
CASE mask.dm_type OF
    dm_free:
        BEGIN
        i_mask.buf := mask.msk;
        i_mask.len := mask.mlen;
        END;
    dm_iso:
        BEGIN
        i_mask.buf := tmask_iso;
        i_mask.len := l_tmask_iso;
        END;
    dm_usa:
        BEGIN
        i_mask.buf := tmask_usa;
        i_mask.len := l_tmask_usa;
        END;
    dm_eur:
        BEGIN
        i_mask.buf := tmask_eur;
        i_mask.len := l_tmask_eur;
        END;
    dm_jis:
        BEGIN
        i_mask.buf := tmask_jis;
        i_mask.len := l_tmask_jis;
        END;
    dm_int:
        BEGIN
        i_mask.buf := tmask_int;
        i_mask.len := l_tmask_int;
        END;
    END;
(*ENDCASE*) 
i_mask.pos := 0;
END; (* set_tmask *)
 
(*------------------------------*) 
 
PROCEDURE
      set_ttime (
            time_string       : tsp00_Time;
            VAR internal_time : internal_mask;
            tdesc             : time_descriptor );
      (*    Description :
      time_string    : time in INTERNAL-format
      internal_time  : time in outputformat
      tdesc          : description of the output format
      if outputformat is 2-digit-hour-format hours are taken MOD 24. *)
 
VAR
      hours, hour_pos : integer;
 
BEGIN
WITH internal_time DO
    BEGIN
    IF  tdesc.hform = 2
    THEN
        BEGIN
        hours := c2_to_natural ( time_string [1], time_string [2] );
        hours := (hours * 100) +
              c2_to_natural ( time_string [3], time_string [4] );
        IF  hours >= 24
        THEN
            BEGIN
            hours := hours MOD 24;
            END;
        (*ENDIF*) 
        time_string [1] := '0';
        time_string [2] := '0';
        time_string [3] := chr ( hours DIV 10 + ord('0') );
        time_string [4] := chr ( hours MOD 10 + ord('0') );
        hour_pos := orig_hour_pos;
        len := 2 * tdesc.tunits;
        END
    ELSE
        BEGIN
        hour_pos := 1;
        len := 2 * tdesc.tunits + 2;
        END;
    (*ENDIF*) 
    s10mv (mxsp_time,mxin_date_mask_string,
          @time_string,hour_pos,
          @buf,1,len);
    END;
(*ENDWITH*) 
END; (* set_ttime *)
 
(*------------------------------*) 
 
FUNCTION
      get_ddesc (
            VAR mask  : tin_date_mask;
            VAR ddesc : date_descriptor;
            pos       : integer ) : integer;
 
VAR
      date_order : tin_natural;
 
BEGIN
IF  pos < 0
THEN
    pos := mask.mlen ;
(*ENDIF*) 
WITH ddesc DO
    BEGIN
    IF  mask.dm_type = dm_free
    THEN
        BEGIN
        pos := pos + 1;
        date_order := ord (mask.msk [ pos] );
        pos := pos + 1;
        year.form := ord (mask.msk [ pos] );
        pos := pos + 1;
        month.form := ord (mask.msk [ pos] );
        (* *)
        day.pos := low_bits (date_order, 4);
        month.pos := low_bits (date_order, 4);
        year.pos := date_order;
        END
    ELSE
        BEGIN
        year.form := four_digits;
        month.form := by_digits;
        CASE mask.dm_type OF
            dm_iso, dm_jis:
                BEGIN
                day.pos := 3;
                month.pos := 2;
                year.pos := 1;
                END;
            dm_usa:
                BEGIN
                day.pos := 2;
                month.pos := 1;
                year.pos := 3;
                END;
            dm_eur:
                BEGIN
                day.pos := 1;
                month.pos := 2;
                year.pos := 3;
                END;
            dm_int:
                BEGIN
                day.pos := 3;
                month.pos := 2;
                year.pos := 1;
                END;
            END;
        (*ENDCASE*) 
        END;
    (*ENDIF*) 
    END;
(*ENDWITH*) 
get_ddesc := pos;
END; (* get_ddesc *)
 
(*------------------------------*) 
 
FUNCTION
      get_tdesc (
            VAR mask  : tin_date_mask;
            VAR tdesc : time_descriptor ;
            pos       : integer ) : integer;
 
BEGIN
IF  pos < 0
THEN
    pos := mask.mlen ;
(*ENDIF*) 
WITH tdesc DO
    CASE mask.dm_type OF
        dm_free:
            BEGIN
            pos := pos + 1;
            hform := ord (mask.msk [ pos] ) DIV 16;
            tunits := ord (mask.msk [ pos] ) MOD 16;
            pos := pos + 1;
            IF  ord(mask.msk [ pos] ) = ord(no_am)
            THEN
                am_pm := no_am
            ELSE
                IF  ord(mask.msk [ pos] ) = ord(am_upper)
                THEN
                    am_pm := am_upper
                ELSE
                    IF  ord(mask.msk [ pos] ) = ord(am_lower)
                    THEN
                        am_pm := am_lower
                    ELSE
                        am_pm := no_am;
                    (*ENDIF*) 
                (*ENDIF*) 
            (*ENDIF*) 
            END;
        dm_int:
            BEGIN
            hform := 4;
            tunits := 3;
            am_pm := no_am;
            END;
        dm_usa:
            BEGIN
            hform := 2;
            am_pm := am_upper;
            tunits := 2;
            END;
        OTHERWISE:
            BEGIN
            hform := 2;
            am_pm := no_am;
            tunits := 3;
            END;
        END;
    (*ENDCASE*) 
(*ENDWITH*) 
get_tdesc := pos;
END; (* get_tdesc *)
 
(*------------------------------*) 
 
FUNCTION
      low_bits (
            VAR inbyte : tin_natural;
            bit_len    : tin_natural) : tin_natural;
 
BEGIN
low_bits := inbyte MOD bit_len;
inbyte := inbyte DIV bit_len;
END; (* low_bits *)
 
(*------------------------------*) 
 
PROCEDURE
      internal_date_pres (
            VAR date_string   : tsp00_Date;
            VAR ddesc         : date_descriptor;
            VAR internal_date : internal_mask);
 
VAR
      act_pos : field_position;
 
BEGIN
WITH ddesc DO
    BEGIN
    internal_date.len := 0;
    FOR act_pos := 1 TO 3 DO
        IF  act_pos = year.pos
        THEN
            put_year (date_string, ddesc, internal_date)
        ELSE
            IF  act_pos = month.pos
            THEN
                put_month (date_string, ddesc, internal_date)
            ELSE
                IF  act_pos = day.pos
                THEN
                    put_day (date_string, internal_date);
                (*ENDIF*) 
            (*ENDIF*) 
        (*ENDIF*) 
    (*ENDFOR*) 
    END;
(*ENDWITH*) 
END; (* internal_date_pres *)
 
(*------------------------------*) 
 
PROCEDURE
      put_day (
            VAR date_string   : tsp00_Date;
            VAR internal_date : internal_mask);
 
BEGIN
WITH internal_date DO
    BEGIN
    date_put (date_string, orig_day_pos, buf, len + 1, orig_partlen);
    len := len + orig_partlen;
    END;
(*ENDWITH*) 
END; (* put_day *)
 
(*------------------------------*) 
 
PROCEDURE
      put_month (
            VAR date_string   : tsp00_Date;
            VAR ddesc         : date_descriptor;
            VAR internal_date : internal_mask);
 
VAR
      ok : boolean;
 
BEGIN
ok := true;
WITH ddesc DO
    BEGIN
    IF  month.form <> by_digits
    THEN
        put_monthname (date_string, internal_date, month.form, ok);
    (*ENDIF*) 
    IF  (NOT ok) OR (month.form = by_digits)
    THEN
        WITH internal_date DO
            BEGIN
            IF  NOT ok
            THEN
                BEGIN
                len := len + 1;
                buf [ len ] := bsp_c1;
                END;
            (*ENDIF*) 
            date_put (date_string, orig_month_pos,
                  buf, len + 1, orig_partlen);
            len := len + orig_partlen;
            END;
        (*ENDWITH*) 
    (*ENDIF*) 
    END;
(*ENDWITH*) 
END; (* put_month *)
 
(*------------------------------*) 
 
PROCEDURE
      put_year (
            VAR date_string   : tsp00_Date;
            VAR ddesc         : date_descriptor;
            VAR internal_date : internal_mask);
 
BEGIN
WITH internal_date, ddesc DO
    BEGIN
    (* year *)
    IF  year.form = four_digits
    THEN
        BEGIN
        date_put (date_string, orig_century_pos, buf, len + 1,
              orig_partlen);
        len := len + orig_partlen;
        END;
    (*ENDIF*) 
    date_put (date_string, orig_year_pos, buf, len + 1, orig_partlen);
    len := len + orig_partlen;
    END;
(*ENDWITH*) 
END; (* put_year *)
 
(*------------------------------*) 
 
PROCEDURE
      date_put (
            VAR instring  : tsp00_Date;
            pos1          : tin_natural;
            VAR outstring : tin_date_mask_string;
            pos2          : tin_natural;
            len           : tin_natural);
 
VAR
      index : tin_natural;
 
BEGIN
FOR index := 1 TO len DO
    outstring [ pos2 + index - 1 ] :=
          instring [ pos1 + index - 1] ;
(*ENDFOR*) 
END; (* date_put *)
 
(*------------------------------*) 
 
PROCEDURE
      get_date (
            VAR instring  : tin_date_mask_string;
            pos1          : tin_natural;
            VAR outstring : tsp00_Date;
            pos2          : tin_natural;
            len           : tin_natural);
 
VAR
      index : tin_natural;
 
BEGIN
FOR index := 1 TO len DO
    outstring [ pos2 + index - 1 ] :=
          instring [ pos1 + index - 1] ;
(*ENDFOR*) 
END; (* get_date *)
 
(*------------------------------*) 
 
PROCEDURE
      put_monthname (
            VAR date_string   : tsp00_Date;
            VAR internal_date : internal_mask;
            digits            : integer;
            VAR ok            : boolean);
 
BEGIN
IF  digits = 3
THEN
    put_abbrev_monthname (date_string, internal_date, ok)
ELSE
    put_long_monthname (date_string, internal_date, digits, ok)
(*ENDIF*) 
END; (* put_monthname *)
 
(*------------------------------*) 
 
PROCEDURE
      put_abbrev_monthname (
            VAR date_string   : tsp00_Date;
            VAR internal_date : internal_mask;
            VAR ok            : boolean);
 
CONST
      partlen = 3;
 
VAR
      month_no : integer;
      msg      : tin_screenline;
      partpos  : tin_natural;
      index    : 1 .. partlen;
 
BEGIN
month_no := c2_to_natural (date_string [ orig_month_pos] ,
      date_string [ orig_month_pos + 1] );
ok := ( month_no IN [  1 .. 12  ] );
IF  ok
THEN
    BEGIN
    partpos := (month_no - 1) * partlen + 1;
    WITH internal_date DO
        BEGIN
        get_monthnames (abbrev_month_msgno, msg);
        FOR index := 1 TO partlen DO
            buf [ len + index ] := msg [  partpos + index - 1 ] ;
        (*ENDFOR*) 
        len := len + partlen;
        END;
    (*ENDWITH*) 
    END;
(*ENDIF*) 
END; (* put_abbrev_monthname *)
 
(*------------------------------*) 
 
PROCEDURE
      put_long_monthname (
            VAR date_string   : tsp00_Date;
            VAR internal_date : internal_mask;
            digits            : integer;
            VAR ok            : boolean);
 
VAR
      month_no : integer;
      msg      : tin_screenline;
      partnr   : tin_natural;
      partpos  : tin_natural;
      index    : tin_natural;
      partlen  : integer;
 
BEGIN
partlen := 12;
month_no := c2_to_natural (date_string [ orig_month_pos] ,
      date_string [ orig_month_pos + 1] );
ok := ( month_no IN [  1 .. 12  ] );
IF  ok
THEN
    WITH internal_date DO
        BEGIN
        IF  month_no <= month_names_in_msg
        THEN
            get_monthnames (january_june_msgno, msg)
        ELSE
            get_monthnames (july_december_msgno, msg);
        (*ENDIF*) 
        partnr := ( (month_no - 1) MOD month_names_in_msg) + 1;
        partpos := (partnr - 1) * partlen + 1;
        IF  partlen > digits
        THEN
            partlen := digits;
        (*ENDIF*) 
        FOR index := 1 TO partlen DO
            buf [ len + index ] := msg [ partpos + index - 1 ] ;
        (*ENDFOR*) 
        IF  partlen < digits
        THEN
            FOR index := partlen + 1 TO digits DO
                buf [ len + index ] := bsp_c1;
            (*ENDFOR*) 
        (*ENDIF*) 
        len := len + digits;
        END;
    (*ENDWITH*) 
(*ENDIF*) 
END; (* put_long_monthname *)
 
(*------------------------------*) 
 
FUNCTION
      c2_to_natural (
            c1 : char;
            c2 : char) : integer;
 
VAR
      result : integer;
 
BEGIN
result := ord (c1) - ord ('0');
result := result * 10 + ord (c2) - ord ('0');
c2_to_natural := result;
END; (* c2_to_natural *)
 
(*------------------------------*) 
 
PROCEDURE
      put_date_time (
            VAR internal_date : internal_mask;
            VAR special_chars : charset;
            VAR i_mask        : internal_mask);
 
VAR
      index : tin_natural;
 
BEGIN
internal_date.pos := 0;
WITH i_mask DO
    FOR index := 1 TO len DO
        BEGIN
        pos := index;
        IF  buf [ pos ] IN special_chars
        THEN
            put_dchar (internal_date, i_mask);
        (*ENDIF*) 
        END;
    (*ENDFOR*) 
(*ENDWITH*) 
END; (* put_date_time *)
 
(*------------------------------*) 
 
PROCEDURE
      put_dchar (
            VAR infield  : internal_mask;
            VAR outfield : internal_mask);
 
BEGIN
WITH infield DO
    BEGIN
    pos := pos + 1;
    outfield.buf [ outfield.pos ] := buf [ pos] ;
    END;
(*ENDWITH*) 
END; (* put_dchar *)
 
(*------------------------------*) 
 
PROCEDURE
      get_monthnames (
            msgno         : tin_natural;
            VAR month_msg : tin_screenline);
 
VAR
      parms : tin_msg_parms;
      msgt  : tin_msg_type;
 
BEGIN
parms.length := 0;
i03msg ( msgno, parms, month_msg, msgt);
IF  msgt <> long_msg
THEN
    SAPDB_PascalForcedFill (mxin_screenline, @month_msg, 1, mxin_screenline, '.');
(*ENDIF*) 
END; (* get_monthnames *)
 
(*------------------------------*) 
 
PROCEDURE
      i41dget (
            VAR mask        : tin_date_mask;
            VAR inputfield  : tsp00_Buf;
            inputlen        : tin_natural;
            VAR date_string : tsp00_Date;
            VAR error       : integer);
 
VAR
      i_mask               : internal_mask;
      in_field             : int_buffer; (* internal_buffer *)
      ddesc                : date_descriptor;
      internal_date        : internal_mask;
      internal_date_string : tsp00_Date;
      special_chars        : charset;
      internal_error       : mk_d_error;
      dummy                : integer;
 
BEGIN
(* put mask to i_mask *)
set_dmask_string (mask, i_mask);
store_input (inputfield, inputlen, in_field, internal_error);
IF  internal_error = mk_d_ok
THEN
    BEGIN
    dummy := get_ddesc (mask, ddesc, -1 );
    completeness_check (ddesc, internal_error);
    END;
(*ENDIF*) 
IF  internal_error = mk_d_ok
THEN
    BEGIN
    special_chars := [ year_char_1, year_char_2, month_char, day_char_1, day_char_2] ;
    internal_date.len := 0;
    get_date_time (in_field, special_chars, i_mask, internal_date, internal_error);
    END;
(*ENDIF*) 
IF  internal_error = mk_d_ok
THEN
    external_date_pres (internal_date, ddesc, internal_date_string, internal_error);
(*ENDIF*) 
IF  internal_error = mk_d_ok
THEN
    BEGIN
    date_string := internal_date_string;
    IF  NOT i41dvalid (date_string)
    THEN
        internal_error := invalid_date_or_time;
    (*ENDIF*) 
    END;
(*ENDIF*) 
IF  internal_error = mk_d_ok
THEN
    error := 0
ELSE
    out_error (internal_error, mt_date, error);
(*ENDIF*) 
END; (* i41dget *)
 
(*------------------------------*) 
 
PROCEDURE
      completeness_check (
            VAR ddesc : date_descriptor;
            VAR error : mk_d_error);
 
BEGIN
error := mk_d_ok;
WITH ddesc DO
    IF  (year.pos = 0) OR (month.pos = 0) OR (day.pos = 0)
    THEN
        error := inputmask_incomplete;
    (*ENDIF*) 
(*ENDWITH*) 
END; (* completeness_check *)
 
(*------------------------------*) 
 
PROCEDURE
      try_timerepair (
            mask              : tin_date_mask;
            VAR in_field      : int_buffer;
            VAR special_chars : charset;
            VAR i_mask        : internal_mask;
            VAR internal_time : internal_mask;
            VAR error         : mk_d_error);
      (* Try to repair certain time-Formats (INTERNAL)
      if too_short or too_long and allow to
      process 'get_date_time (...)' again. *)
 
VAR
      i, i_len  : integer;
      tmp_field : int_buffer;
 
BEGIN
(* initialize tmp_field *)
WITH tmp_field DO
    BEGIN
    pos := 0;
    len := i_mask.len;
    FOR i:= 1 TO len DO
        buf [i] := '0';
    (*ENDFOR*) 
    END;
(*ENDWITH*) 
(*analyse error*)
CASE error OF
    input_too_short :
        BEGIN
        CASE mask.dm_type OF
            dm_int : (*INTERNAL*)
                BEGIN
                (* move in_field.buf into tmp_field.buf *)
                (* observing: integers right-justified  *)
                i_len := in_field.len;
                FOR i := 1  TO i_len DO
                    tmp_field.buf [ 8 - i_len + i] := in_field.buf [i];
                (*ENDFOR*) 
                (* move buf into d observing
                      HHHHMMSS
                      1               |-> 00100000
                      12              |-> 00120000
                      123             |-> 00123000
                      1234            |-> 00123400
                      12345           |-> 00123450
                      123451          |-> 00123451
                      1234512         |-> 01234512
                      12345123        |-> 12345123
                      123451234       |-> 12345123
                      IF  in_field.len < 6
                      THEN
                      tmp_field.pos := orig_hour_pos - 1
                      ELSE
                      tmp_field.pos := tmp_field.len - in_field.len;
                      FOR i := 1 TO in_field.len DO
                      BEGIN
                      tmp_field.buf [i + tmp_field.pos] := in_field.buf [i];
                      END;
                      *)
                in_field := tmp_field;
                error := mk_d_ok;
                END;
            OTHERWISE:
                BEGIN
                END;
            END;
        (*ENDCASE*) 
        END;
    input_too_long  :
        BEGIN
        CASE mask.dm_type OF
            dm_int : (*INTERNAL*)
                BEGIN
                IF  in_field.len > tmp_field.len
                THEN
                    in_field.len := tmp_field.len;
                (*ENDIF*) 
                FOR i := 1 TO in_field.len DO
                    BEGIN
                    tmp_field.buf [i + tmp_field.pos] := in_field.buf [i];
                    END;
                (*ENDFOR*) 
                in_field := tmp_field;
                error := mk_d_ok;
                END;
            OTHERWISE:
                BEGIN
                END;
            END;
        (*ENDCASE*) 
        END;
    OTHERWISE:
        BEGIN
        END;
    END;
(*ENDCASE*) 
IF  error = mk_d_ok
THEN
    BEGIN
    (* repair could be successfull *)
    WITH internal_time DO
        BEGIN
        pos := 0;
        len := 0;
        FOR i:= 1 TO tmp_field.len DO
            buf [i] := '0';
        (*ENDFOR*) 
        END;
    (*ENDWITH*) 
    get_date_time (in_field, special_chars, i_mask, internal_time, error);
    END;
(*ENDIF*) 
END; (*try_timerepair*)
 
(*------------------------------*) 
 
PROCEDURE
      get_date_time (
            VAR input_field   : int_buffer;
            VAR special_chars : charset;
            VAR i_mask        : internal_mask;
            VAR internal_date : internal_mask;
            VAR error         : mk_d_error);
      (* Copy contents of input_field to internal_date using
      i_mask and specialchars for formatting.
      Error occurs when input_too_short or input_too_long *)
 
BEGIN
error := mk_d_ok;
input_field.pos := 0;
WITH i_mask DO
    BEGIN
    pos := 0;
    WHILE (pos < len) AND (error = mk_d_ok) DO
        BEGIN
        pos := pos + 1;
        WITH input_field DO
            IF  pos < len
            THEN
                pos := pos + 1
            ELSE
                error := input_too_short;
            (*ENDIF*) 
        (*ENDWITH*) 
        IF  error = mk_d_ok
        THEN
            IF  buf [ pos ] IN special_chars
            THEN
                get_dchar (input_field, internal_date)
            ELSE
                IF  buf [ pos ] = input_field.buf [ input_field.pos ]
                THEN
                    BEGIN
                    END
                ELSE
                    IF  input_field.buf [ input_field.pos ] = bsp_c1
                    THEN
                        (* skip input 1 pos*)
                        pos := pos - 1
                    ELSE
                        (* skip mask 1 pos*)
                        input_field.pos := input_field.pos - 1;
                    (*ENDIF*) 
                (*ENDIF*) 
            (*ENDIF*) 
        (*ENDIF*) 
        END;
    (*ENDWHILE*) 
    END;
(*ENDWITH*) 
IF  error = mk_d_ok
THEN
    WITH input_field DO
        IF  pos < len
        THEN
            error := input_too_long;
        (*ENDIF*) 
    (*ENDWITH*) 
(*ENDIF*) 
END; (* get_date_time *)
 
(*------------------------------*) 
 
PROCEDURE
      get_dchar (
            VAR input_field   : int_buffer;
            VAR internal_date : internal_mask);
 
VAR
      new_char : char;
 
BEGIN
new_char := i32toupper( input_field.buf [ input_field.pos ] );
WITH internal_date DO
    BEGIN
    len := len + 1;
    buf [ len ] := new_char;
    END;
(*ENDWITH*) 
END; (* get_dchar *)
 
(*------------------------------*) 
 
PROCEDURE
      external_date_pres (
            VAR internal_date : internal_mask;
            VAR ddesc         : date_descriptor;
            VAR date_string   : tsp00_Date;
            VAR error         : mk_d_error);
 
VAR
      act_pos : field_position;
 
BEGIN
WITH ddesc DO
    BEGIN
    internal_date.pos := 0;
    act_pos := 0;
    REPEAT
        act_pos := act_pos + 1;
        IF  act_pos = year.pos
        THEN
            get_year (internal_date, ddesc, date_string, error)
        ELSE
            IF  act_pos = month.pos
            THEN
                get_month (internal_date, ddesc, date_string, error)
            ELSE
                IF  act_pos = day.pos
                THEN
                    get_day (internal_date, date_string);
                (*ENDIF*) 
            (*ENDIF*) 
        (*ENDIF*) 
    UNTIL
        (act_pos = 3) OR (error <> mk_d_ok);
    (*ENDREPEAT*) 
    END;
(*ENDWITH*) 
END; (* external_date_pres *)
 
(*------------------------------*) 
 
PROCEDURE
      get_year (
            VAR internal_date : internal_mask;
            VAR ddesc         : date_descriptor;
            VAR date_string   : tsp00_Date;
            VAR error         : mk_d_error);
 
BEGIN
WITH internal_date, ddesc DO
    BEGIN
    (* year *)
    IF  year.form = four_digits
    THEN
        BEGIN
        get_date (buf, pos + 1, date_string, orig_century_pos,
              orig_partlen);
        pos := pos + orig_partlen;
        END
    ELSE
        BEGIN  (* 19xx *)
        date_string [ orig_century_pos ] := '2';
        date_string [ orig_century_pos+1 ] := '0';
        END;
    (*ENDIF*) 
    IF  error = mk_d_ok
    THEN
        BEGIN
        get_date (buf, pos + 1, date_string, orig_year_pos, orig_partlen);
        pos := pos + orig_partlen;
        END;
    (*ENDIF*) 
    END;
(*ENDWITH*) 
END; (* get_year *)
 
(*------------------------------*) 
 
PROCEDURE
      get_month (
            VAR internal_date : internal_mask;
            VAR ddesc         : date_descriptor;
            VAR date_string   : tsp00_Date;
            VAR error         : mk_d_error);
 
VAR
      ok : boolean;
 
BEGIN
ok := true;
WITH ddesc DO
    BEGIN
    IF  month.form <> by_digits
    THEN
        get_month_by_name (internal_date, date_string, month.form, error)
    ELSE
        WITH internal_date DO
            BEGIN
            get_date (buf, pos + 1, date_string, orig_month_pos,
                  orig_partlen);
            pos := pos + orig_partlen;
            END;
        (*ENDWITH*) 
    (*ENDIF*) 
    END;
(*ENDWITH*) 
END; (* get_month *)
 
(*------------------------------*) 
 
PROCEDURE
      get_month_by_name (
            VAR internal_date : internal_mask;
            VAR date_string   : tsp00_Date;
            digits            : integer;
            VAR error         : mk_d_error);
 
BEGIN
IF  digits = 3
THEN
    get_by_abbrev_name (internal_date, date_string, error)
ELSE
    get_by_long_name (internal_date, date_string, digits, error);
(*ENDIF*) 
END; (* get_month_by_name *)
 
(*------------------------------*) 
 
PROCEDURE
      get_by_abbrev_name (
            VAR internal_date : internal_mask;
            VAR date_string   : tsp00_Date;
            VAR error         : mk_d_error);
 
CONST
      partlen = 3;
 
VAR
      month_no     : tin_natural;
      msg          : tin_screenline;
      partpos      : tin_natural;
      index        : 0 .. partlen;
      found        : boolean;
      char1, char2 : char;
 
BEGIN
WITH internal_date DO
    BEGIN
    get_monthnames (abbrev_month_msgno, msg);
    month_no := 0;
    REPEAT
        month_no := month_no + 1;
        partpos := (month_no - 1) * partlen;
        index := 0;
        REPEAT
            index := index + 1;
            partpos := partpos + 1;
            char1 := buf [ pos + index] ;
            char2 := msg [  partpos] ;
            found := ( i32toupper (char1) = i32toupper (char2) );
        UNTIL
            (index = partlen) OR (NOT found);
        (*ENDREPEAT*) 
    UNTIL
        (month_no = 12) OR found;
    (*ENDREPEAT*) 
    IF  found
    THEN
        BEGIN
        pos := pos + partlen;
        natural_to_c2 (month_no, date_string, orig_month_pos);
        END
    ELSE
        error := wrong_monthname;
    (*ENDIF*) 
    END
(*ENDWITH*) 
END; (* get_by_abbrev_name *)
 
(*------------------------------*) 
 
PROCEDURE
      get_by_long_name (
            VAR internal_date : internal_mask;
            VAR date_string   : tsp00_Date;
            digits            : integer;
            VAR error         : mk_d_error);
 
CONST
      partlen = 12;
 
VAR
      month_no       : tin_natural;
      msg            : tin_screenline;
      partpos        : integer;
      searchpos      : integer;
      index          : 0 .. partlen;
      found          : boolean;
      char1, char2   : char;
      compare_length : integer;
 
BEGIN
IF  digits > partlen
THEN
    compare_length := partlen
ELSE
    compare_length := digits;
(*ENDIF*) 
WITH internal_date DO
    BEGIN
    get_monthnames (january_june_msgno, msg);
    month_no := 0;
    partpos := - partlen;
    REPEAT
        IF  month_no = month_names_in_msg
        THEN
            BEGIN
            get_monthnames (july_december_msgno, msg);
            partpos := - partlen;
            END;
        (*ENDIF*) 
        month_no := month_no + 1;
        partpos := partpos + partlen;
        searchpos := partpos;
        index := 0;
        REPEAT
            index := index + 1;
            searchpos := searchpos + 1;
            char1 := buf [ pos + index] ;
            char2 := msg [  searchpos] ;
            found := ( i32toupper (char1) = i32toupper (char2) );
        UNTIL
            (index = compare_length) OR (NOT found);
        (*ENDREPEAT*) 
    UNTIL
        (month_no = 12) OR found;
    (*ENDREPEAT*) 
    IF  found
    THEN
        BEGIN
        pos := pos + digits;
        natural_to_c2 (month_no, date_string, orig_month_pos);
        END
    ELSE
        error := wrong_monthname;
    (*ENDIF*) 
    END
(*ENDWITH*) 
END; (* get_by_long_name *)
 
(*------------------------------*) 
 
PROCEDURE
      natural_to_c2 (
            no              : month_nr;
            VAR date_string : tsp00_Date;
            pos             : tin_natural);
 
BEGIN
IF  no >= 10
THEN
    date_string [ pos ] := '1'
ELSE
    date_string [ pos ] := '0';
(*ENDIF*) 
pos := pos + 1;
no := no MOD 10;
date_string [ pos ] := chr ( no + ord ('0'));
END; (* natural_to_c2 *)
 
(*------------------------------*) 
 
PROCEDURE
      get_day (
            VAR internal_date : internal_mask;
            VAR date_string   : tsp00_Date);
 
BEGIN
WITH internal_date DO
    BEGIN
    get_date (buf, pos + 1, date_string, orig_day_pos, orig_partlen);
    pos := pos + orig_partlen;
    END;
(*ENDWITH*) 
END; (* get_day *)
 
(*------------------------------*) 
 
PROCEDURE
      i41tget (
            VAR mask        : tin_date_mask;
            VAR inputfield  : tsp00_Buf;
            inputlen        : tin_natural;
            VAR time_string : tsp00_Time;
            VAR error       : integer);
 
VAR
      tdesc          : time_descriptor;
      i_mask         : internal_mask;
      in_field       : int_buffer; (* internal_buffer *)
      internal_time  : internal_mask;
      special_chars  : charset;
      internal_error : mk_d_error;
      dummy          : integer;
 
BEGIN
(* put mask to i_mask *)
set_tmask (mask, i_mask);
store_input (inputfield, inputlen, in_field, internal_error);
IF  internal_error = mk_d_ok
THEN
    BEGIN
    dummy := get_tdesc (mask, tdesc, -1 );
    IF  tdesc.hform = 2
    THEN
        BEGIN
        internal_time.buf  [1]  := '0';
        internal_time.buf  [2]  := '0';
        internal_time.len := 2;
        END
    ELSE
        internal_time.len := 0;
    (*ENDIF*) 
    special_chars := [ hour_char, minute_char, second_char ] ;
    IF  tdesc.am_pm <> no_am
    THEN
        add_special_am_pm_chars ( special_chars, (tdesc.am_pm = am_lower) );
    (*ENDIF*) 
    get_date_time (in_field, special_chars,i_mask,internal_time,
          internal_error);
    IF  internal_error <> mk_d_ok
    THEN
        try_timerepair ( mask, in_field, special_chars,
              i_mask, internal_time, internal_error);
    (*ENDIF*) 
    IF   ( tdesc.am_pm <> no_am ) AND ( internal_error = mk_d_ok )
    THEN
        change_from_am_pm ( internal_time, internal_error);
    (*ENDIF*) 
    END;
(*ENDIF*) 
IF  internal_error = mk_d_ok
THEN
    BEGIN
    copytime (internal_time, time_string);
    IF  NOT i41tvalid (time_string)
    THEN
        internal_error := invalid_date_or_time;
    (*ENDIF*) 
    END;
(*ENDIF*) 
IF  internal_error = mk_d_ok
THEN
    BEGIN
    error := 0;
    END
ELSE
    out_error (internal_error, mt_time, error);
(*ENDIF*) 
END; (* i41tget *)
 
(*------------------------------*) 
 
PROCEDURE
      i41tsget (
            VAR tsmask : tin_date_mask;
            VAR source : tin_date_mask_string ;
            inputlen   : tin_natural;
            VAR dest   : tsp00_Timestamp;
            VAR error  : integer);
 
VAR
      rtr      : runtime_timestamp_record ;
      tempbuf  : tsp00_Buf ;
      d_out    : tsp00_Date;
      t_out    : tsp00_Date;
      dest_pos : integer;
      length   : integer;
      i        : integer;
      microdigit_count : integer;
 
BEGIN
(* transform formatted timestamp into internal format *)
error := 0;
tsmask_to_d_t_masks ( tsmask, rtr, error );
IF  error = 0
THEN
    ts_input_check ( tsmask, source, inputlen, rtr, error );
(*ENDIF*) 
IF  (error = 0)
THEN
    IF  (rtr.date_start > 0)
    THEN
        BEGIN
        s10mv (mxsp_exttimestamp,mxsp_buf,
              @source,rtr.date_start,
              @tempbuf,1,rtr.d_inlen );
        i41dget ( rtr.dmask, tempbuf, rtr.d_inlen, d_out, error );
        END
    ELSE
        d_out := rtr.default_today ;
    (*ENDIF*) 
(*SAPDB_PascalForcedFill (mxsp_date, @d_out, 1, l_dmask_int, '0');*)
(*ENDIF*) 
IF  (error = 0)
THEN
    IF   (rtr.time_start > 0)
    THEN
        BEGIN
        IF  rtr.tmask.dm_type = dm_int
        THEN
            BEGIN
            (* hours in timestamp: 2 digits;
                  in time: 4 digits *)
            FOR i := 1 TO excess_hours DO
                tempbuf [ i ] := '0';
            (*ENDFOR*) 
            s10mv (mxsp_exttimestamp,mxsp_buf,
                  @source,rtr.time_start,
                  @tempbuf,1 + excess_hours,l_tmask_int - excess_hours );
            END
        ELSE
            s10mv (mxsp_exttimestamp,mxsp_buf,
                  @source,rtr.time_start,
                  @tempbuf,1,rtr.t_inlen );
        (*ENDIF*) 
        i41tget ( rtr.tmask, tempbuf, rtr.t_inlen, t_out, error );
        END
    ELSE
        SAPDB_PascalForcedFill (mxsp_date, @t_out, 1, mxsp_date, '0');
    (*ENDIF*) 
(*ENDIF*) 
IF  ( error = 0 )
THEN
    BEGIN
    (* now date and time parts are decoded; copy them into DEST *)
    dest_pos := 1;
    length   := l_dmask_int ;
    s10mv (mxsp_date,mxsp_timestamp,
          @d_out,1,
          @dest,dest_pos,length );
    dest_pos := dest_pos + length ;
    (* timestamp has only two hh digits; so skip two *)
    length   := l_tmask_int - excess_hours ;
    s10mv (mxsp_date,mxsp_timestamp,
          @t_out,1 + excess_hours,
          @dest,dest_pos,length );
    dest_pos := dest_pos + length ;
    (* now the microseconds *)
    IF  rtr.nr_microdigits > 0
    THEN
        (*
              *  mask states that there should be microseconds
              *)
        BEGIN
        microdigit_count := inputlen - (rtr.micro_start - 1);
        (* compute count of microdigits in source *)
        IF  (microdigit_count > rtr.nr_microdigits)
        THEN
            (*
                  *  More microseconds in source than expected - cut them
                  *)
            microdigit_count := rtr.nr_microdigits
        ELSE
            BEGIN
            IF  (microdigit_count < 0)
                (* no microseconds in source and even no separator
                      between time and microseconds *)
            THEN
                microdigit_count := 0;
            (*ENDIF*) 
            END;
        (*ENDIF*) 
        (*
              *  Now fill dest with microseconds only if there is something to fill
              *)
        IF  (microdigit_count > 0)
        THEN
            s10mv(mxin_date_mask_string,mxsp_timestamp,
                  @source,rtr.micro_start,
                  @dest,dest_pos,microdigit_count);
        (*ENDIF*) 
        END
    ELSE
        (*
              *  mask states that we shouldn't expect microseconds at all
              *)
        microdigit_count := 0;
    (*ENDIF*) 
    (* fill with zeros if no 'enough' microseconds 'delivered' in source *)
    IF  microdigit_count < max_microdigits
    THEN
        SAPDB_PascalForcedFill(mxsp_timestamp, @dest, (dest_pos+microdigit_count),
              (max_microdigits-microdigit_count), '0');
    (*ENDIF*) 
    END ;
(*ENDIF*) 
END; (* i41tsget *)
 
(*------------------------------*) 
 
PROCEDURE
      ts_input_check (
            VAR tsmask : tin_date_mask;
            VAR source : tin_date_mask_string ;
            inputlen   : tin_natural;
            VAR rtr    : runtime_timestamp_record ;
            VAR error  : integer ) ;
 
VAR
      temp           : tin_date_mask;
      i              : integer;
      errpos         : integer;
      internal_error : mk_d_error ;
      check_begin    : integer;
      check_end      : integer;
 
BEGIN
errpos := 0;
internal_error := mk_d_ok;
set_tsmask_string ( tsmask, temp );
(*IF  rtr.date_start > 0*)
(*THEN*)
(*    SAPDB_PascalForcedFill ( mxin_date_mask_string , @temp.msk, rtr.date_start,*)
(*          rtr.dmask.mlen, chr(0) );*)
(*IF  rtr.time_start > 0*)
(*THEN*)
(*    SAPDB_PascalForcedFill ( mxin_date_mask_string , @temp.msk, rtr.time_start,*)
(*          rtr.tmask.mlen, chr(0) );*)
(*IF  rtr.micro_start > 0*)
(*THEN*)
(*    SAPDB_PascalForcedFill ( mxin_date_mask_string , @temp.msk, rtr.micro_start,*)
(*          rtr.nr_microdigits, chr(0) );*)
(* we rely on the fact that a timestamp mask must have following order:*)
(* date-time-microseconds *)
(*  or  *)
(* time-date *)
(*  or  *)
(* time-microseconds *)
IF  (rtr.date_start > 0) AND (rtr.time_start > 0)
THEN
    BEGIN
    IF  (rtr.date_start < rtr.time_start)
    THEN
        BEGIN
        check_begin := rtr.date_start + rtr.dmask.mlen;
        check_end   := rtr.time_start;
        END
    ELSE
        BEGIN
        check_begin := rtr.time_start + rtr.tmask.mlen;
        check_end   := rtr.date_start;
        IF  (rtr.micro_start > 0)
        THEN
            check_begin := check_begin + rtr.micro_start;
        (*ENDIF*) 
        END;
    (*ENDIF*) 
    END;
(* check separator between date maske and time mask *)
(*i := rtr.date_start + rtr.dmask.mlen;     next char after date mask*)
(*WHILE (i < rtr.time_start) AND (internal_error = mk_d_ok) DO*)
(*ENDIF*) 
i := check_begin;
WHILE (i < check_end) AND (i <= inputlen) AND (internal_error = mk_d_ok) DO
    BEGIN
    IF  temp.msk[i] <> source[i]
    THEN
        BEGIN
        internal_error := invalid_symbol ;
        errpos := i;
        END
    ELSE
        i := i + 1;
    (*ENDIF*) 
    END;
(*ENDWHILE*) 
IF  (internal_error = mk_d_ok) AND (rtr.time_start > 0) AND (rtr.micro_start > 0)
THEN
    BEGIN
    (* check separator between time maske and microseconds:
          if no microseconds - who cares *)
    i := rtr.time_start + rtr.tmask.mlen;       (* next char after date mask*)
    (*  IF (inputlen >= i)    we can only check for the right separator
          between time and microseconds if there is one*)
    (*  THEN*)
    (*      BEGIN*)
    WHILE (i < rtr.micro_start) AND (i <= inputlen) AND (internal_error = mk_d_ok) DO
        BEGIN
        IF  temp.msk[i] <> source[i]
        THEN
            BEGIN
            IF  ( source[i] <> chr(0) )
            THEN
                BEGIN
                internal_error := invalid_symbol ;
                errpos := i;
                END;
            (*ENDIF*) 
            END
        ELSE
            i := i + 1;
        (*ENDIF*) 
        END;
    (*ENDWHILE*) 
    (*      END;*)
    END;
(*FOR i := 1 TO temp.mlen DO*)
(*    IF  internal_error = mk_d_ok*)
(*    THEN*)
(*        IF  temp.msk [i] <> chr(0)*)
(*        THEN*)
(*            IF  temp.msk [i] <> source[i]*)
(*            THEN*)
(*                BEGIN*)
(*                internal_error := invalid_symbol ;*)
(*                errpos := i;*)
(*                END;*)
(*ENDIF*) 
out_error (internal_error, mt_timestamp, error);
END; (* ts_input_check *)
 
(*------------------------------*) 
 
PROCEDURE
      tsmask_to_d_t_masks (
            VAR mask  : tin_date_mask;
            VAR rtr   : runtime_timestamp_record ;
            VAR error : integer );
 
BEGIN
error := 0 ;
CASE mask.dm_type OF
    dm_free:
        BEGIN
        rtr.dmask.dm_type := dm_free ;
        rtr.tmask.dm_type := dm_free ;
        get_tsdesc ( mask, rtr );
        END;
    dm_iso:
        BEGIN
        rtr.dmask.dm_type  := dm_iso;
        rtr.dmask.msk      := dmask_iso;
        rtr.dmask.mlen     := l_dmask_iso;
        rtr.tmask.dm_type  := dm_iso ;
        rtr.tmask.msk      := tmask_iso;
        rtr.tmask.mlen     := l_tmask_iso;
        rtr.date_start     := 1;
        rtr.time_start     := rtr.date_start + i41dlen ( rtr.dmask ) + 1;
        rtr.micro_start    := rtr.time_start + i41tlen ( rtr.tmask ) + 1;
        rtr.nr_microdigits := 6 ;
        END;
    dm_usa,
    dm_eur,
    dm_jis:
        BEGIN
        rtr.dmask.dm_type  := dm_iso;
        rtr.dmask.msk      := dmask_iso;
        rtr.dmask.mlen     := l_dmask_iso;
        rtr.tmask.dm_type  := dm_eur ;
        rtr.tmask.msk      := tmask_eur;
        rtr.tmask.mlen     := l_tmask_eur;
        rtr.date_start     := 1;
        rtr.time_start     := rtr.date_start + i41dlen ( rtr.dmask ) + 1;
        rtr.micro_start    := rtr.time_start + i41tlen ( rtr.tmask ) + 1;
        rtr.nr_microdigits := 6 ;
        END;
    dm_int:
        BEGIN
        rtr.dmask.dm_type  := dm_int;
        rtr.dmask.msk      := dmask_int;
        rtr.dmask.mlen     := l_dmask_int;
        rtr.tmask.dm_type  := dm_int ;
        rtr.tmask.msk      := tmask_int;
        rtr.tmask.mlen     := l_tmask_int;
        rtr.date_start     := 1;
        rtr.time_start     := rtr.date_start + i41dlen ( rtr.dmask ) ;
        rtr.micro_start    := rtr.time_start + i41tlen ( rtr.tmask )
              - excess_hours ;
        rtr.nr_microdigits := 6 ;
        END;
    OTHERWISE
        out_error ( invalid_date_or_time, mt_timestamp, error);
    END;
(*ENDCASE*) 
IF  error = 0
THEN
    BEGIN
    rtr.d_inlen :=  i41dlen ( rtr.dmask );
    rtr.t_inlen :=  i41tlen ( rtr.tmask );
    (* nach i41tlen im internal format haetten
          wir nur noch eine laenge von 6 (M.RE 19943012)
          IF  mask.dm_type = dm_int
          THEN
          rtr.t_inlen := rtr.t_inlen - excess_hours;
          *)
    END;
(*ENDIF*) 
END; (* tsmask_to_d_t_masks *)
 
(*------------------------------*) 
 
PROCEDURE
      get_tsdesc (
            VAR mask : tin_date_mask;
            VAR rtr  : runtime_timestamp_record ) ;
 
VAR
      pos   : integer;
      ddesc : date_descriptor;
      tdesc : time_descriptor;
 
BEGIN
pos := mask.mlen + 1;
rtr.date_start := ord ( mask.msk [ pos ] );
pos := pos + 1;
rtr.dmask.mlen := ord ( mask.msk [ pos ] );
pos := get_ddesc ( mask, ddesc, pos );
pos := pos + 1;
rtr.time_start := ord ( mask.msk [ pos ] );
pos := pos + 1;
rtr.tmask.mlen := ord ( mask.msk [ pos ] );
pos := get_tdesc ( mask, tdesc, pos );
pos := pos + 1;
rtr.micro_start := ord ( mask.msk [ pos ] );
pos := pos + 1;
rtr.nr_microdigits := ord ( mask.msk [ pos ] );
pos := pos + 1; (* next pos *)
(* *)
IF  rtr.date_start > 0
THEN
    BEGIN
    s10mv (mxin_date_mask_string,mxin_date_mask_string,
          @mask.msk,rtr.date_start,
          @rtr.dmask.msk,1,rtr.dmask.mlen );
    rtr.dmask.tlen := put_ddesc ( ddesc, rtr.dmask.msk, rtr.dmask.mlen );
    rtr.default_today [ 1 ] := chr(0);
    END
ELSE
    BEGIN
    rtr.dmask.tlen := 0;
    rtr.dmask.mlen := 0;
    s10mv (mxin_date_mask_string,mxsp_date,
          @mask.msk,pos,
          @rtr.default_today,1,mxsp_date );
    END;
(*ENDIF*) 
IF  rtr.time_start > 0
THEN
    BEGIN
    s10mv (mxin_date_mask_string,mxin_date_mask_string,
          @mask.msk,rtr.time_start,
          @rtr.tmask.msk,1,rtr.tmask.mlen );
    rtr.tmask.tlen := put_tdesc ( tdesc, rtr.tmask.msk, rtr.tmask.mlen );
    END
ELSE
    BEGIN
    rtr.tmask.tlen := 0;
    rtr.tmask.mlen := 0;
    END;
(*ENDIF*) 
END; (* get_tsdesc *)
 
(*------------------------------*) 
 
PROCEDURE
      change_from_am_pm (
            VAR internal_time : internal_mask;
            VAR error         : mk_d_error);
      (***********************************************************
      If last two chars of internal_time.buf = 'AM' or 'PM',
      - let internal_time.len = internal_time.len - 2,
      ( While copying later, 'AM'/'PM' will not be copied
      and replaced by '00', if neccessary. )
      and, if PM, add 12 to time . MK 92.9.3
      - check for range of hours (specification : Kernel and DB2)
      ***********************************************************)
 
VAR
      new_char1, new_char2 : char;
      hours, minut         : integer;
      am_pm_ok             : boolean;
 
BEGIN
WITH internal_time DO
    BEGIN
    new_char1 := i32toupper( buf [ len-1 ] );
    new_char2 := i32toupper( buf [ len ] );
    am_pm_ok  := ( new_char2 = am_pm_char2 );
    IF  am_pm_ok
    THEN
        BEGIN
        hours := c2_to_natural ( buf [orig_hour_pos], buf [orig_hour_pos+1] );
        minut := c2_to_natural ( buf [orig_minute_pos],
              buf [orig_minute_pos+1] );
        CASE new_char1 OF
            am_pm_char1  :
                BEGIN
                (*   Last chars in internal_time.buf = AM    *)
                am_pm_ok := ( (   ( 0 < hours ) AND ( hours <= 12 ))
                      OR (( hours = 0 ) AND ( minut  =  0 )));
                (* This Timeevaluation follows DB2's Definition *)
                (*            00:00 AM  ->         00:00 Uhr *)
                (*            12:00 AM  ->         24:00 Uhr *)
                (* 12:01 AM - 12:59 AM  -> 00:01 - 00:59 Uhr *)
                (* 01:00 AM - 11:59 AM  -> 01:00 - 11:59 Uhr *)
                IF  hours = 12
                THEN
                    IF  minut = 0
                    THEN
                        i41_add_c2( buf, '12', orig_hour_pos)
                    ELSE
                        BEGIN
                        buf [ orig_hour_pos ]    := '0';
                        buf [ orig_hour_pos +1 ] := '0';
                        END;
                    (*ENDIF*) 
                (*ENDIF*) 
                END;
            am_pm_char11 :
                BEGIN
                (* Last chars in internal_time.buf = PM *)
                am_pm_ok := (( 0 <  hours ) AND ( hours <= 12 ));
                (* This Timeevaluation follows DB2's Definition *)
                (* 12:00 PM - 12:59 PM  -> 12:00 - 12:59 Uhr *)
                (* 01:00 PM - 11:59 PM  -> 13:00 - 23:59 Uhr *)
                IF  ( am_pm_ok ) AND ( hours <> 12 )
                THEN
                    BEGIN
                    i41_add_c2( buf, '12', orig_hour_pos);
                    END;
                (*ENDIF*) 
                END;
            OTHERWISE:
                am_pm_ok := FALSE;
            END;
        (*ENDCASE*) 
        END;
    (*ENDIF*) 
    IF  am_pm_ok
    THEN
        BEGIN
        len := len - 2;
        error := mk_d_ok
        END
    ELSE
        BEGIN
        len := 0;
        error := mask_mismatch;
        END;
    (*ENDIF*) 
    END;
(*ENDWITH*) 
END; (* change_from_am_pm *)
 
(*------------------------------*) 
 
PROCEDURE
      change_to_am_pm (
            VAR internal_time : internal_mask;
            VAR tdesc         : time_descriptor );
      (***********************************************************
      Analyse internal_time and change to am/pm -time following the
      specification of Kernel and DB2. Append AM/PM when applicable.
      4-digit-hour-format is evaluated output by hours MOD 24.   *)
      (*         00.00 Uhr  ->         00.00 AM *)
      (* 00.01 - 00.59 Uhr  -> 12.01 - 12.59 AM *)
      (* 01.01 - 11.59 Uhr  -> 01.01 - 11.59 AM *)
      (* 12.00 - 12.59 Uhr  -> 12.00 - 12.59 PM *)
      (* 13.00 - 23.59 Uhr  -> 01.00 - 11.59 PM *)
      (*         24.00 Uhr  ->         12.00 PM
      nver matches because hours MOD 24 *)
      (***********************************************************)
 
VAR
      hours, minut : integer;
 
BEGIN
WITH internal_time, tdesc DO
    BEGIN
    hours := c2_to_natural ( buf [1], buf [2] );
    IF  hform = 4
    THEN
        BEGIN
        hours := (hours * 100) + c2_to_natural ( buf [3], buf [4] );
        buf [1] := '0';
        buf [2] := '0';
        END;
    (*ENDIF*) 
    hours := hours MOD 24;
    minut := c2_to_natural ( buf [hform + 1], buf [hform + 2] );
    IF  hours < 12
    THEN
        BEGIN
        concat_c2(internal_time, 'AM', am_pm = am_lower);
        IF  ( hours = 0 ) AND ( minut <> 0 )
        THEN
            BEGIN
            hours := hours + 12;
            (* i41_add_c2 ( buf, '12', hform - 1 ); *)
            END;
        (*ENDIF*) 
        END
    ELSE
        BEGIN
        concat_c2 ( internal_time, 'PM', am_pm = am_lower);
        IF  hours >= 13
        THEN
            BEGIN
            hours := hours - 12;
            (* bool := i41_sub_c2 ( buf, '12', hform - 1 ); *)
            END;
        (*ENDIF*) 
        END;
    (*ENDIF*) 
    buf [hform - 1] := chr ( hours DIV 10 + ord ('0') );
    buf [hform]     := chr ( hours MOD 10 + ord ('0') );
    END;
(*ENDWITH*) 
END; (* change_to_am_pm *)
 
(*------------------------------*) 
 
PROCEDURE
      store_input (
            VAR inputfield : tsp00_Buf;
            inputlen       : tin_natural;
            VAR in_field   : int_buffer;
            VAR error      : mk_d_error);
 
BEGIN
IF  inputlen > mxin_screenline
THEN
    error := input_too_long
ELSE
    WITH in_field DO
        BEGIN
        error := mk_d_ok;
        s10mv (mxsp_buf,mxin_screenline,
              @inputfield,1,
              @buf,1,inputlen);
        len := inputlen;
        pos := 0;
        END;
    (*ENDWITH*) 
(*ENDIF*) 
END; (* store_input *)
 
(*------------------------------*) 
 
PROCEDURE
      out_error (
            internal_error : mk_d_error;
            mt             : mask_type;
            VAR error      : integer);
 
BEGIN
IF  internal_error = mk_d_ok
THEN
    error := 0
ELSE
    BEGIN
    CASE internal_error OF
        delimiter_after_end :
            internal_error := no_delimiter_allowed;
        second_delimiter :
            internal_error := invalid_symbol;
        wrong_dtmask:
            internal_error := invalid_symbol;
        no_date_mask:
            internal_error := inputmask_incomplete;
        OTHERWISE
        END;
    (*ENDCASE*) 
    CASE internal_error OF
        invalid_date_or_time:
            IF  mt = mt_date
            THEN
                error := sysset_tab_offset + sysset_invalid_date
            ELSE
                error := sysset_tab_offset + sysset_invalid_time;
            (*ENDIF*) 
        OTHERWISE:
            error := sysset_tab_offset + internal_error;
        END;
    (*ENDCASE*) 
    END;
(*ENDIF*) 
END; (* out_error *)
 
(*------------------------------*) 
 
PROCEDURE
      copytime (
            VAR internal_time : internal_mask;
            VAR time_string   : tsp00_Time);
 
BEGIN
WITH internal_time DO
    BEGIN
    s10mv (mxin_date_mask_string,mxsp_time,
          @buf,1,
          @time_string,1,len);
    IF  len < mxsp_time
    THEN
        SAPDB_PascalForcedFill (mxsp_time, @time_string, len + 1, mxsp_time - len, '0');
    (*ENDIF*) 
    END;
(*ENDWITH*) 
END; (* copytime *)
 
(* check validity of date/time. especially in case of NOLOG *)
(*------------------------------*) 
 
FUNCTION
      i41m_days_of_month (
            year : integer; month : integer): integer;
 
VAR
      days : integer;
 
BEGIN
CASE month OF
    1, 3, 5, 7, 8, 10, 12:
        days := 31;
    4, 6, 9, 11:
        days := 30;
    2:
        IF  i41is_leap_year (year)
        THEN
            days := 29
        ELSE
            days := 28;
        (*ENDIF*) 
    OTHERWISE:
        days := 0
    END;
(*ENDCASE*) 
i41m_days_of_month := days
END; (* i41m_days_of_month *)
 
(*------------------------------*) 
 
FUNCTION
      i41is_leap_year (
            year : integer) : boolean;
 
VAR
      leap_year : boolean;
 
BEGIN
leap_year := false;
IF  year MOD 4 = 0
THEN
    BEGIN
    leap_year := true;
    IF  (year MOD 100 = 0) AND (year MOD 400 <> 0)
    THEN
        leap_year := false
    (*ENDIF*) 
    END;
(*ENDIF*) 
i41is_leap_year := leap_year
END; (* i41is_leap_year *)
 
(*------------------------------*) 
 
FUNCTION
      i41dvalid (
            VAR dat : tsp00_Date) : boolean;
 
VAR
      day, month, year : integer;
 
BEGIN
IF  s60isnu1meric(dat, mxsp_date)
THEN
    BEGIN
    year := ( (ord (dat  [1] ) - ord ('0')) * 1000) +
          ( (ord (dat  [2] ) - ord ('0')) * 100) +
          ( (ord (dat  [3] ) - ord ('0')) * 10) +
          (ord (dat  [4] ) - ord ('0'));
    month := ( (ord (dat  [5] ) - ord ('0')) * 10) +
          (ord (dat  [6] ) - ord ('0'));
    day := ( (ord (dat  [7] ) - ord ('0')) * 10) +
          (ord (dat  [8] ) - ord ('0'));
    IF  (month < 1) OR (month > 12) OR (day < 1) OR
        (day > i41m_days_of_month (year, month))
    THEN
        i41dvalid := false
    ELSE
        i41dvalid := true;
    (*ENDIF*) 
    END
ELSE
    i41dvalid := false;
(*ENDIF*) 
END; (* i41dvalid *)
 
(*------------------------------*) 
 
FUNCTION
      i41tvalid (
            VAR tim : tsp00_Time) : boolean;
 
VAR
      minute, second : integer;
 
BEGIN
IF  s60isnu2meric(tim, mxsp_time)
THEN
    BEGIN
    minute := ( (ord (tim  [5] ) - ord ('0')) * 10) + (ord (tim  [6] ) - ord ('0'));
    second := ( (ord (tim  [7] ) - ord ('0')) * 10) + (ord (tim  [8] ) - ord ('0'));
    IF  (minute > 59) OR (second > 59)
    THEN
        i41tvalid := false
    ELSE
        i41tvalid := true;
    (*ENDIF*) 
    END
ELSE
    i41tvalid := false;
(*ENDIF*) 
END; (* i41tvalid *)
 
(*------------------------------*) 
 
FUNCTION
      i41dlen (
            VAR mask : tin_date_mask) : integer;
 
BEGIN
CASE mask.dm_type OF
    dm_free:
        i41dlen := mask.mlen;
    dm_iso:
        i41dlen := l_dmask_iso;
    dm_usa:
        i41dlen := l_dmask_usa;
    dm_eur:
        i41dlen := l_dmask_eur;
    dm_jis:
        i41dlen := l_dmask_jis;
    dm_int:
        i41dlen := l_dmask_int;
    END;
(*ENDCASE*) 
END; (* i41dlen *)
 
(*------------------------------*) 
 
FUNCTION
      i41tlen (
            VAR mask : tin_date_mask) : integer;
 
BEGIN
CASE mask.dm_type OF
    dm_free:
        i41tlen := mask.mlen;
    dm_iso:
        i41tlen := l_tmask_iso;
    dm_usa:
        i41tlen := l_tmask_usa;
    dm_eur:
        i41tlen := l_tmask_eur;
    dm_jis:
        i41tlen := l_tmask_jis;
    dm_int:
        i41tlen := l_tmask_int;
    END;
(*ENDCASE*) 
END; (* i41tlen *)
 
(*------------------------------*) 
 
FUNCTION
      i41tslen (
            VAR mask : tin_date_mask) : integer;
 
BEGIN
CASE mask.dm_type OF
    dm_free:
        i41tslen := mask.mlen;
    dm_iso:
        i41tslen := l_tsmask_iso;
    dm_usa:
        i41tslen := l_tsmask_usa;
    dm_eur:
        i41tslen := l_tsmask_eur;
    dm_jis:
        i41tslen := l_tsmask_jis;
    dm_int:
        i41tslen := l_tsmask_int;
    END;
(*ENDCASE*) 
END; (* i41tslen *)
 
(*------------------------------*) 
 
PROCEDURE
      const_check_i41 ;
 
VAR
      errtext : tsp00_Line;
      piece   : tsp00_C40;
 
BEGIN
IF  (mxin_date_mask_string < mxsp_exttimestamp + date_mask_infobytes )
THEN
    BEGIN
    piece := 'Error Constant mxin_date_mask_string    ';
    SAPDB_PascalForcedFill ( LINE_MXSP00, @errtext, 1, LINE_MXSP00, bsp_c1 );
    s10mv(mxsp_c40,LINE_MXSP00,
          @piece,1,
          @errtext,1,mxsp_c40 );
    sqlwrite ( errtext );
    sqlabort;
    END ;
(*ENDIF*) 
END; (* const_check_i41 *)
 
.CM *-END-* code ----------------------------------------
.SP 2 
***********************************************************
.PA 
