in_edi.rexxincl 29.11.2002 16:06:28
/**********************************************************************/
/* in EDIFACT definition & EDIFACT parsing */
/* in_EDI: in EDIFACT definition file */
/* : for example CREMUL.DEF */
/* (c) Th. Schneider, February 2002 */
/**********************************************************************/
/* 19.02.2002: implement escape character and variable delimiters */
/* 19.03.2002: can only hold CURRENT Segment in core, otherwise we get*/
/* : memory exhausted problems. */
/**********************************************************************/
in_EDI_definition:
parse arg def
call open def
line_no=0
do while lines(def)>0
line=strip(linein(def));line_no=line_no+1
if char(line,1)='*' then iterate /* skip comments */
if line='' then iterate /* skip blank lines */
do while lastchar(line)='-' /* continuation line follows*/
linelen=length(line)
line=substr(line,1,linelen-1)!!strip(linein(def))
line_no=line_no+1
end
/* say line_no':'line */
linelen=length(line)
call parse_EDI_definition_line
end
call close def
return
init_EDI: /* init EDI definitions */
/* set default delimiters */
escape_char='?'
Field_delim=':'
Data_delim='+'
Segment_delim="'"
edi_type.=''
edi_id.=''
edi_name.=''
edi_req.='' /* M=mandatory, C=Conditional, N= ??, R= ?? */
edi_freq.=0 /* no freq given */
edi_members.=''
edi_codes.='' /* list of permitted codes, points to 'C' elements*/
editypes='S D F T E C R LV SG *'
editypes1='S D F T E C'
editables='' /* list of all tables used */
/* S=Segment, D=Data, F=Field, T=Table, E=Table Element, C= Code*/
edi_Segment.=0 /* Segment lookup table */
edi_Groups.='' /* Groups of Segment */
nn=0
n_Segment_types=0
level=0
n_Groups=0
Group_List.='' /* Segment list of Group-Number */
Group_Level.=0 /* Group Level of Group-Number */
Group_Nest.=0 /* Start of Groups by Level */
trace_defs=0 /* 1 = trace definitions */
return
parse_EDI_definition_line:
parse var line type':'id':'name':'req':'form':'note
if type='R' then do /* number of repetitions */
if ii <> ii_Field then do
call error 'invalid position of Repetion record,',
'Repetition ignored'
return
end
parse var line .':'freq':'.
edi_freq.ii_Field=freq
return
end
freq=0 /* no freq given 1 */
if wordpos(type,editypes1)>0 then do
nn=nn+1
ii=nn
edi_type.ii =type
edi_id.ii =id
edi_name.ii =name
edi_form.ii =form
edi_req.ii =req /* M=mandatory, C=Conditional, N= ??, R= ?? */
edi_freq.ii =freq /* initial no freq! */
edi_note.ii =note
end
if wordpos(type,editypes)= 0 then do
call error 'illegal line-type:' type 'expected:' editypes
return
end
select
when type='S' then do /* new Segment */
if lookup(id)<>0 then
call warning 'Duplicate defined Segment:' id
edi_Segment.id=ii
ii_Segment=ii
ii_Data=0;ii_Field=0;ii_Table=0;ii_Elem=0;ii_Cond=0
n_Segment_types=n_Segment_types+1
end
when type='D' then do /* new Data (composite Field) */
ii_Data=ii
if ii_Segment=0 then do
call error 'Segment definition missing, line ignored'
end
edi_members.ii_Segment=edi_members.ii_Segment' 'ii_Data
ii_Field=ii_Data;ii_Table=0;ii_Elem=0;ii_Cond=0
end
when type='F' then do /* new Field (elementary Field)*/
ii_Field=ii
if ii_Data=0 then do
call error 'parent Data definition missing, line ignored'
return
end
edi_members.ii_Data=edi_members.ii_Data' 'ii_Field
end
when type='T' then do
ii_Table=ii
edi_tables=edi_tables' 'ii_Table
end
when type='E' then do
ii_Elem=ii
edi_members.ii_Table=edi_members.ii_Table' 'ii_Elem
end
when type='C' then do
if ii_Field=0 then ii_Field=ii_Data
ii_Code=ii
edi_codes.ii_Field=edi_codes.ii_Field' 'ii
end
when type='LV' then do
level=id
stack_level=level /* infos :indent following Segment Groups */
if trace_defs then do
call info ''
call infos 'Level' level':'
call infos '========'
end
end
when type='SG' then do /* Segment Group */
Group_No=id; list=name
if trace_defs then call infos 'Segment Group:' Group_No '=' list
/* id contains Segment group number */
n_Groups=max(Group_No,n_Groups)
Group_List.n_Groups=list
Group_Level.n_Groups=level
do iw=1 to words(list)
seg1=word(list,iw)
ii_Seg=edi_Segment.seg1
if ii_Seg=0 then call warning 'Segment:' seg1,
'of Segment-Group:' Group_No 'Level:' level 'not defined!'
edi_Groups.seg1=strip(edi_Groups.seg1' 'Group_No)
end
end
otherwise do
call error 'invalid type: 'type 'ignored'
end
end /* select type */
return
lookup:
arg id1
return edi_Segment.id1
init_EDI_parser:
seg_no=0 /* running Segment number */
seg_Def.=0 /* item numbor of Segment definition */
/* linearized Format */
Field_Level.=0 /* Segment Group Level */
Field_Group.=0 /* Segment Group of Field */
Field_Segment_No.=0 /* running Segment number */
Field_Data.=0 /* pointer to Data definition */
Field_No.=0 /* pointer to Field definition */
Field_Value.='' /* the actual Data/Field Value */
iv=0 /* current Field index (within current Segment) */
nv=0 /* number of Fields (within current segment) */
nv=0 /* total number of Fields */
debug=0 /* force debug */
opt_short=0 /* 1= short trace, only Fields with values */
opt_verbose=0 /* > 0: verbose information */
opt_all=0
opt_trace=0 /* 1 = trace EDIFACT Segements */
opt_group=0 /* 1 = display Groups and Segments by level */
opt_display=0 /* 1 = display V2 output */
opt_detail=0 /* 1 = show details of Segment-Verarbeitung */
opt_show = 0 /* 1 = show (display) EDI fields */
Current_Group_No=-1 /* Current Segment Group Number */
/* Note that the Service Segments UNA UNB etc */
/* belong to Segment Group 0 ! */
Current_Level=0 /* current Segment Group Level */
Current_List='' /* current Segment List */
Current_Seq_No=0 /* Current Seqence No of current Segment in List*/
return
parse_EDI_Segment:
seg_no=seg_no+1 /* running Segment number */
Segment_No=seg_no /* external name used */
call split Segment,Data_delim /* cannot use parse, as delimiter */
/* may be preceeded by escape char */
seg_tag=head;seg_data=tail
call split seg_tag,Field_delim
seg_type=head;seg_tag_data=tail
ii_Segment=lookup(seg_type)
if ii_Segment=0 then do
call error 'unknown Segment type:' seg_type 'ignored'
return
end
if seg_tag_data<>'' then call error 'Segment tag data:'seg_tag_data,
'currently ignored!'
/* parse of seg_tag_data still missing !! */
SegmentId=edi_id.ii_Segment
SegmentName=edi_name.ii_Segment
if opt_short ! opt_all then do
call info ' '
call info'Segment: 'SegmentId SegmentName':'
call info ' (#'seg_no'::'Segment')'
end
else if opt_trace then call info '#'seg_no'::'Segment
call fetch_Segment_group
if opt_group ! opt_short then do
stack_level=Current_level
call infos ' LV:' Current_Level,
'SG:' Current_Group_No 'I:' Current_Seq_no 'Seg:' Segment
end
DataList=edi_members.ii_Segment
if debug then call info 'DataList:' DataList
nv=0; iv=0 /* Fields now numbered within Segment only */
iv1=1 /* First index (for repetitions of same Segment */
do jj=1 to words(DataList)
ii_Data=word(DataList,jj)
DataId=edi_id.ii_Data
DataName=edi_name.ii_Data
call split seg_data,Data_delim
Data=head;seg_data=tail
if opt_all ! opt_short & Data <> ''
then call info ' Data: 'DataId DataName':' Data
FieldList=edi_members.ii_Data
if debug then call info ' FieldList:' FieldList
n_Fields=words(FieldList)
if n_Fields>0 then do
do kk=1 to n_Fields
ii_Field=word(FieldList,kk)
FieldId=edi_id.ii_Field
FieldName=edi_name.ii_Field
FieldFreq=edi_freq.ii_field
if opt_all ! opt_short & FieldVal <> ''
then call info ' Field:' FieldId FieldName':' FieldVal
iv=iv+1
Field_Level.iv=Current_Level
Field_Group.iv=Current_Group_No
Field_Segment_No.iv=seg_no /* running Segment number */
Field_Data.iv=ii_Data
Field_No.iv=ii_Field
if FieldFreq=0 then do
call split Data,Field_delim
FieldVal=head;Data=tail
Field_Value.iv=FieldVal
call check_Field ii_Field,FieldVal
end
else do
Field_Value.iv=Data
do ifreq= 1 to FieldFreq
call split Data,Field_delim
FieldVal=head;Data=tail
if opt_short ! opt_all then
call info ' index:' ifreq 'value:' FieldVal
Field_Value.iv.ifreq=FieldVal /* indexed Field! */
Data=tail
end
end
end
end
else do /* no Fields, Data is Elementary */
iv=iv+1
Field_Level.iv=Current_Level
Field_Group.iv=Current_Group_No
Field_Segment_No.iv=seg_no /* running Segment number */
Field_Data.iv=ii_Data
Field_No.iv=0 /* Data already contains Value */
Field_Value.iv=Data
call check_Field ii_Data,Data
Data=''
end
if Data <> '' then call error 'superfluos Data:' Data 'ignored.'
end
nv=iv /* nv is number of values */
return
start_EDI_parser:
parse arg datafile,def_file,options
options=upper(options)
/* input file in EDIFACT format */
call init_EDI
call in_EDI_definition def_file
call init_EDI_parser
/* set options */
call set_opts options
if n_errors > 0 then do
call info0 n_errors 'errors in EDIFACT definition:' def_file
call info 'please correct errors and try again!'
exit 98
end
call open datafile
fx=parsefid(datafile)
parse var fx fn ft fm
buffer='';
seg_no=0 /* running Segment number */
n_Segments=0 /* number of Segments read */
time11=time('R') /* reset timer */
trace_Segments=0 /* 1 = display Segments */
EOF=0
used_Segments='' /* wordlist of used Segment-types*/
line_no=0
return
set_opts:
arg opt_string /* converts to uppercase! */
if wordpos('DEBUG',opt_string)>0 then debug=1
if wordpos('SHORT',opt_string)>0 then opt_short=1
if wordpos('ALL',opt_string)>0 then opt_all=1
if wordpos('TRACE',opt_string)>0 then opt_trace=1
if wordpos('DISPLAY',opt_string)>0 then opt_display=1
if wordpos('DETAIL',opt_string)>0 then opt_detail=1
if wordpos('SHOW',opt_string)>0 then opt_show=1
if wordpos('GROUP',opt_string)>0 then opt_group=1
if wordpos('VERBOSE',opt_string)>0 then opt_verbose=1
return
finish_EDI_parser:
call close datafile
time12=time('E') /* elapsed time */
elapsed=time12-time11
e_elapsed=format(elapsed,,2)
if opt_verbose then do
call info0 n_Segments 'Segments read'
call info0 nv 'Fields parsed'
call info 'EDIFACT parser used:' e_elapsed 'seconds'
end
used_Segments=strip(used_Segments)
if opt_show then call display_EDI_Fields
return
next_Segment:
do while pos("'",buffer)=0
if EOF then leave
if lines(datafile) > 0 then buffer=buffer!!linein(datafile)
else EOF=1
end
call split buffer,Segment_delim
Segment=head;buffer=tail
line=Segment;line_no=line_no+1 /* for messages */
if Segment='' then return
n_Segments=n_Segments+1
if trace_Segments
then call info line_no'. Segment:' Segment
if wordpos(Segment_type,used_Segments)=0
then used_Segments=used_Segments' 'Segment_type
if EOF then return
call split Segment,Data_delim
Segment_Type=head;Segment_Data=tail
data.=''; etc=Segment_Data; nd=0
Field_val.=''; Field_id.=''; Field_ix.=0
ij=0; /* component data elements (fields) of Segment */
do while etc<>''
nd=nd+1; parse var etc data.nd'+'etc
do id=1 to nd
dx=data.id
ix=0
do while dx <> ''
ij=ij+1; ix=ix+1
parse var dx Field_val.ix':'dx
/* the data for this field */
Field_id.ij=id /* the fields id number */
Field_ix.ij=ix /* the ix.th subfield of the data element*/
end /* do while dx <> '' */
nj=ij /* save total number of fields */
end /* next id */
end /* do while etc <> '' */
n_fields=ij
call parse_EDI_Segment
return
check_Field: /* check Format and codes */
parse arg ii1,val1
codes=edi_codes.ii1
/*** check unterdrückt. stimmt so offensichtlich nicht in Testdaten!!!
if edi_req.ii1='M' & val1='' then do
call warning 'required Field:' edi_id.ii1 edi_name.ii1 'missing!'
end
***/
if val1 <> '' & codes <> '' then do
found=0
do jjc=1 to words(codes)
ii_code=word(codes,jjc)
if val1=edi_id.ii_code then do
found=1
leave jjc
end
end
if found=0 then do
call error 'invalid Value: 'val1 'of:' edi_id.ii1 edi_name.ii1
call info 'expected: 'code_list(codes)
return
end
if opt_all ! opt_short
then call info ' Code:' edi_id.ii_code,
'meaning:' edi_name.ii_code
end
return
code_list:
parse arg list1 /* blank delimited list of ii_codes */
list2=''
do il = 1 to words(list1)
iic=word(list1,il)
if il=1 then list2=edi_id.iic
else list2=list2', 'edi_id.iic
end
return list2
fetch_Segment_group:
/* returns Segment_groupd and Group_Level */
group_list=edi_Groups.seg_type
/*****************************************************************/
/* if it's a UNIQUE Segment type, it's easy (it does only belong */
/* to ONE GROUP */
/*****************************************************************/
if words(group_list)=1 then do /* unique group found anyway */
Current_Group_No=group_list
Current_Level=Group_Level.Current_Group_No
Current_List=Group_List.Current_Group_No /* Segment list */
Current_Seq_No=wordpos(seg_type,Current_List)
Current_Seq_End=words(Current_list)
Group_Nest.Current_Level=Current_Group_No
Segment_Group=Current_Group_No
Group_Level=Current_Level
return
end
/* check optional Segments of SAME group */
do ix=Current_Seq_No to Current_Seq_End
expected_Segment=word(Current_List,ix)
if seg_type=expected_Segment then do
Current_Seq_No=ix
return
end
end
/* check possible repetitons by Group Level */
do iz=Current_Level to 1 by -1
iy=Group_Nest.iz
expected_Segment=word(Group_List.iy,1)
if seg_type=expected_Segment then do
Current_Group_No=iy
Current_Level=Group_Level.Current_Group_No
Current_List=Group_List.Current_Group_No /* Segment list */
Current_Seq_No=1
Current_Seq_End=words(Current_list)
Group_Nest.Current_Level=Current_Group_No
Segment_Group=Current_Group_no
Group_level=Current_level
return
end
end
/* Check Next Segment Group(s), First Segment of Group is always */
/* mandatory !! */
do iy=Current_Group_No+1 to n_Groups
list=Group_List.iy
expected_Segment=word(list,1) /* first Segment of group */
/* is always mandatory */
if seg_type=expected_Segment then do
Current_Group_No=iy
Current_Level=Group_Level.Current_Group_No
Current_List=Group_List.Current_Group_No /* Segment list */
Current_Seq_No=1
Current_Seq_End=words(Current_list)
Group_Nest.Current_Level=Current_Group_No
Segment_Group=Current_Group_No
Group_level=Current_Level
return
end
end
call error 'unable to determine Segment-Group of Segment:',
seg_type
call info 'possible Segment Groups are:' edi_Groups.seg_type
call abort 'please correct definition file:' definition_file
return
split: /* split string into head and tail */
/* returns head and tail */
parse arg string, delim
pos1=1
do until c1 <> escape_char
pos1=pos(delim,string,pos1)
if pos1=0 then do
pos1=length(string)+1
leave
end
c1=char(string,pos1-1)
if c1=escape_char then do
string=substr(string,1,pos1-2)!!substr(string,pos1)
iterate
end
else leave
end
head=substr(string,1,pos1-1)
tail=substr(string,pos1+1)
return
display_EDI_Fields:
header= ' ## LV GRP SEG IND DATA FIELD VALUE'
call info1 header
do iv=1 to nv
no=right(iv,5)
lev=right(Field_Level.iv,2)
grp=left(Segment_Group,3)
seg=left(Segment_Type,3)
ind=right(Field_Segment_No.iv,3)
ii_Data=Field_Data.iv
dat=left(edi_id.ii_Data,4)
ii_Field=Field_No.iv
fld=left(edi_id.ii_Field,5)
val=Field_Value.iv
call info no lev grp seg ind dat fld val
end
call info ''
return
EDI_Val: /* return EDI Value (Segment known) */
parse arg vid
parse var vid Data_Id'.'Field_Id'.'index1
vv=''; found=0
do iv=iv1 to nv
if Field_Segment_No.iv <> Segment_No then leave
ii_Data=Field_Data.iv
ii_Field=Field_No.iv
if edi_id.ii_Data=Data_Id then do
if Field_Id = '' then do
vv=Field_Value.iv
found=1
leave iv
end
if edi_id.ii_Field=Field_Id then do
freq=edi_freq.ii_Field
if freq=0 then do
if index1 <> '' then
call error 'Data:' Data_id 'Field:' Field_id,
'is NOT indexed, index:' index1 'ignored'
vv=Field_Value.iv
end
else do
if index1='' then do
call error 'Data:' Data_id 'Field:' Field_id,
'missing index, index 1 assumed'
index1=1
end
if index1 < 1 ! index1 > freq then do
call error 'Data:' Data_id 'Field:' Field_id,
'index:' index1 'out of bounds!'
return ''
end
vv=Field_Value.iv.index1
if opt_all then
call info ' index:' index1 'Value:' vv
end
found=1
leave iv
end /* Field_Id given */
end /* Data_Id given */
end
if found=0 then do
call error 'Cannot find field: 'vid 'of segment:' Segment_Type,
'in Group:' Segment_Group
end
return vv