Skip to content

Instantly share code, notes, and snippets.

@Faq400Git

Faq400Git/F4GETFLDS - Get Field Description (API QUSLFLD)

Last active August 1, 2022 21:20
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save Faq400Git/f4a98b411fa52283f6e1509caadeed8f to your computer and use it in GitHub Desktop.
Save Faq400Git/f4a98b411fa52283f6e1509caadeed8f to your computer and use it in GitHub Desktop.
Download ZIP
Raw
F4GETFLDS - Get Field Description (API QUSLFLD)
//------------------------------
// F4GETFLDS Get Field Description
// If you need fields info from a DSPF o PRTF
// you can't use QSYS2.SYSCOLUMNS view ... so
// this utility will create a FAQ400.IVDDALLF0F table
// with fields info from a file (table, index,
// dspf or prtf)
// References:
// http://www.think400.dk/apier_9.htm#eks0007
// https://www.mcpressonline.com/programming/apis/
// the-api-corner-so-just-what-changed-in-this-record
//
// Create first a working table
//
// CREATE TABLE FAQ400.IVDDALLF0F (
// "ID" INTEGER GENERATED ALWAYS AS IDENTITY,
// libname CHAR(10) CCSID 280 NOT NULL DEFAULT '' ,
// filename char(10) CCSID 280 NOT NULL DEFAULT '' ,
// fmtname char(10) CCSID 280 NOT NULL DEFAULT '' ,
// filetype char(10) CCSID 280 NOT NULL DEFAULT '' ,
// fieldName char(10) CCSID 280 NOT NULL DEFAULT '',
// fieldType char(1) CCSID 280 NOT NULL DEFAULT '',
// fieldUse char(1) CCSID 280 NOT NULL DEFAULT '',
// fieldOutBufPos decimal(10) NOT NULL DEFAULT 0,
// fieldInpBufPos decimal(10) NOT NULL DEFAULT 0,
// fieldSize decimal(10) NOT NULL DEFAULT 0,
// fieldDigits decimal(10) NOT NULL DEFAULT 0,
// fieldDecPos decimal(10) NOT NULL DEFAULT 0,
// fieldText char(50) CCSID 280 NOT NULL DEFAULT '',
// fieldEdtCde char(2) CCSID 280 NOT NULL DEFAULT '',
// fieldEdtWrdLen decimal(10) NOT NULL DEFAULT 0,
// fieldEdtWrd char(64) CCSID 280 NOT NULL DEFAULT '',
// fieldColHdg1 char(20) CCSID 280 NOT NULL DEFAULT '',
// fieldColHdg2 char(20) CCSID 280 NOT NULL DEFAULT '',
// fieldColHdg3 char(20)CCSID 280 NOT NULL DEFAULT '',
// fieldintName char(10) ccsid 280 NOT NULL DEFAULT '',
// fieldAltName char(30) ccsid 280 NOT NULL DEFAULT '',
// AUD_UTENTE char(10) CCSID 280 NOT NULL DEFAULT '',
// AUD_INSERT TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP ,
// AUD_UPDATE TIMESTAMP GENERATED ALWAYS FOR EACH ROW
// ON UPDATE AS ROW CHANGE TIMESTAMP NOT NULL )
//
// ;
//
//
// create index FAQ400.IVDDALLF1L
// on FAQ400.IVDDALLF0F (libname, filename, fmtname);
//------------------------------
ctl-opt DFTACTGRP(*NO);
dcl-pr main ExtPgm('F4GETFLDS');
libname char(10);
filename char(10);
fmtname char(10);
filetype char(10);
END-PR;
dcl-pi main ;
libname char(10);
filename char(10);
fmtname char(10);
filetype char(10);
END-PI;
/copy qsysinc/qrpglesrc,qusec
/copy qsysinc/qrpglesrc,QUSLRCD
/copy qsysinc/qrpglesrc,QUSGEN
dcl-pr ListFields extpgm('QUSLFLD') ;
*n char(20) const ; // User space name
*n char(8) const ; // Format
*n char(20) const ; // File name
*n char(10) const ; // Record format
*n char(1) const ; // Use override
*n char(32767) options(*varsize:*nopass) ; // Error feedback
end-pr ;
dcl-ds ListHeader based(UserSpacePointer) qualified ;
Offset int(10) pos(125) ;
Count int(10) pos(133) ;
Size int(10) pos(137) ;
end-ds ;
dcl-ds FieldInfo based(FieldPointer) qualified ;
Name char(10);
Type char(1);
Use char(1);
OutBufPos int(10);
InpBufPos int(10);
Size int(10);
Digits int(10);
DecPos int(10);
Text char(50);
EdtCde char(2);
EdtWrdLen int(10);
EdtWrd char(64);
ColHdg1 char(20);
ColHdg2 char(20);
ColHdg3 char(20);
InternalName char(10);
AlternativeName char(30);
end-ds ;
dcl-pr LstRcdFmts extpgm('QUSLRCD') ;
UsrSpcName char(20) const ; // User space name
Format char(8) const ; // Format
QualFilNam char(20) const ; // File name
OvrPrc char(1) const ; // Use override
OvrPrc char(32767) options(*varsize:*nopass) ; // Error feedback
end-pr ;
d RcdEntryPtr s *
d RcdEntry ds likeds(QUSL010001)
d based(RcdEntryPtr)
d ErrCde ds qualified
d Hdr likeds(QUSEC)
d MsgDta 256a
d SpcPtr s *
d ListHdr ds likeds(QUSH0100)
d based(SpcPtr)
d RtvUsrSpcPtr pr extpgm('QUSPTRUS')
d QualUsrSpcN 20a const
d UsrSpcPtr *
d ErrCde likeds(QUSEC) options(*nopass)
* User Space Header DS
D USHeader ds Based(CUSPointer)
d HdrUserArea 64a
d HdrHdrSize 10i 0
d HdrStrLvl 4a
d HdrFormat 8a
d HdrAPIUsed 10a
d HdrCrtDate 13a
d HdrInfoSts 1a
d HdrSizeOfUS 10i 0
d HdrOffsetToInp 10i 0
d HdrSizeOfInp 10i 0
d HdrOffsetToHdr 10i 0
d HdrSizeOfHdr 10i 0
d HdrOffsetToDtl 10i 0
d HdrSizeOfDtl 10i 0
d HdrNumberOfDtl 10i 0
d HdrEntrySize 10i 0
d HdrCCSID 10i 0
d HdrCountry 2a
d HdrLangID 3a
d HdrSubsetInd 1a
d HdrReserved1 42a
DSaveHdrDS ds
d SavUserArea 64a
d SavHdrSize 10i 0
d SavStrLvl 4a
d SavFormat 8a
d SavAPIUsed 10a
d SavCrtDate 13a
d SavInfoSts 1a
d SavSizeOfUS 10i 0
d SavOffsetToInp 10i 0
d SavSizeOfInp 10i 0
d SavOffsetToHdr 10i 0
d SavSizeOfHdr 10i 0
d SavOffsetToDtl 10i 0
d SavSizeOfDtl 10i 0
d SavNumberOfDtl 10i 0
d SavEntrySize 10i 0
d SavCCSID 10i 0
d SavCountry 2a
d SavLangID 3a
d SavSubsetInd 1a
d SavReserved1 42a
DSav2HdrDS ds
d Sv2UserArea 64a
d Sv2HdrSize 10i 0
d Sv2StrLvl 4a
d Sv2Format 8a
d Sv2APIUsed 10a
d Sv2CrtDate 13a
d Sv2InfoSts 1a
d Sv2SizeOfUS 10i 0
d Sv2OffsetToInp 10i 0
d Sv2SizeOfInp 10i 0
d Sv2OffsetToHdr 10i 0
d Sv2SizeOfHdr 10i 0
d Sv2OffsetToDtl 10i 0
d Sv2SizeOfDtl 10i 0
d Sv2NumberOfDtl 10i 0
d Sv2EntrySize 10i 0
d Sv2CCSID 10i 0
d Sv2Country 2a
d Sv2LangID 3a
d Sv2SubsetInd 1a
d Sv2Reserved1 42a
* List Record Format Header DS
D RcdFmtHdrPtr s *
DRcdFmtHdrDS ds Based(RcdFmtHdrPtr)
D RcdPFName 10a
D RcdPFLib 10a
D RcdPFType 10a
D RcdPFText 50a
D RcdPFCCSID 10i 0
D RcdPFCrtDate 13a
'* List Record Formats DS (RCDL0100)
D RcdFmtPtr100 s *
DRcdFmtDS100 ds Based(RcdFmtPtr100)
D RcdFmtName1 10a
'* List Record Formats DS (RCDL0200)
D RcdFmtPtr200 s *
DRcdFmtDS200 ds Based(RcdFmtPtr200)
D RcdFmtName2 10a
D RcdLvlChkID2 13a
D RcdReserved2 1a
D RcdLength2 10i 0
D RcdNumFlds2 10i 0
D RcdFmtDesc2 50a
D RcdReserved12 2a
D RcdCCSID2 10i 0
'* List Record Formats DS (RCDL0300)
D RcdFmtPtr300 s *
DRcdFmtDS300 ds Based(RcdFmtPtr300)
D RcdFmtName3 10a
D RcdLowResind3 2a
D RcdBufSize3 10i 0
D RcdFmtType3 20a
D RcdStartLine3 1a
D RcdSepInd3 1a
dcl-pr qCmdExc extpgm ;
*n char(1000) options(*varsize) const ;
*n packed(15:5) const ;
end-pr ;
dcl-s cmd varchar(1000);
dcl-s i int(10) ;
dcl-s k int(10) ;
dcl-s getKeyind ind;
exec sql
set OPTION COMMIT= *NONE;
// Cancella eventuali record nella tabella di appoggio
// IVDDALLF0F
exec sql
delete from ivddallf0f
where libname=:libname
and filename=:filename
and fmtname= case when :fmtname<>''
then :fmtname
else fmtname end;
// If no fmtname passed ... scan all file's fmtnames
if fmtname<>'';
getFieldsInfo(libname:filename:fmtname);
else;
listAllRecordFormats(libname:filename);
ENDIF;
*inlr=*on;
return;
//----------------------------------------
//// getFiledsInfo (using QUSLFLD API)
////----------------------------------------
dcl-proc getFieldsInfo;
dcl-pi getFieldsInfo;
ilibname char(10) const;
ifilename char(10) const;
ifmtname char(10) const;
END-PI;
dcl-pr CrtUserSpace extpgm('QUSCRTUS') ;
*n char(20) const ; // Name
*n char(10) const ; // Attribute
*n int(10) const ; // Initial size
*n char(1) const ; // Initial value
*n char(10) const ; // Authority
*n char(50) const ; // Text
*n char(10) const options(*nopass) ; // Replace existing
*n char(32767) options(*varsize:*nopass) ; // Error feedback
end-pr ;
dcl-pr GetPointer extpgm('QUSPTRUS') ;
*n char(20) const ; // Name
*n pointer ; // Pointer to user space
*n char(32767) options(*varsize:*nopass) ; // Error feedback
end-pr ;
dcl-pr DltUserSpace extpgm('QUSDLTUS') ;
*n char(20) const ; // Name
*n char(32767) options(*varsize:*nopass) ; // Error feedback
end-pr ;
dcl-s saveFmtName char(10);
saveFmtName=ifmtName;
// Create an Temporary User Space
CrtUserSpace('IVDDALLFUSQTEMP':'':131072:x'00':
'*ALL':'List of fields in file':'*YES':QUSEC) ;
// List all fields
ListFields('IVDDALLFUSQTEMP':'FLDL0100':ifilename+ilibname:
ifmtname:'0':QUSEC) ;
// Get Pointer
GetPointer('IVDDALLFUSQTEMP':UserSpacePointer) ;
// Read all fields
for i = 1 to ListHeader.Count ;
// Get FieldPointer
FieldPointer = UserSpacePointer
+ ListHeader.Offset
+ (ListHeader.Size * (i - 1)) ;
// Add field info to IVDDALLF0F table
exec sql
insert into IVDDALLF0F
(libname, filename, fmtname, filetype,
fieldName,
fieldType,
fieldUse,
fieldOutBufPos,
fieldInpBufPos,
fieldSize,
fieldDigits,
fieldDecPos,
fieldText,
fieldEdtCde,
fieldEdtWrdLen,
fieldEdtWrd,
fieldColHdg1,
fieldColHdg2,
fieldColHdg3,
fieldIntName,
fieldAltName)
values(:ilibname, :ifilename, :savefmtname, :filetype,
:FieldInfo.Name,
:FieldInfo.Type,
:FieldInfo.Use,
:FieldInfo.OutBufPos,
:FieldInfo.InpBufPos,
:FieldInfo.Size,
:FieldInfo.Digits,
:FieldInfo.DecPos,
:FieldInfo.Text,
:FieldInfo.EdtCde,
:FieldInfo.EdtWrdLen,
:FieldInfo.EdtWrd,
:FieldInfo.ColHdg1,
:FieldInfo.ColHdg2,
:FieldInfo.ColHdg3,
:FieldInfo.InternalName,
:FieldInfo.AlternativeName);
endfor ;
DltUserSpace('IVDDALLFUSQTEMP':QUSEC) ;
END-PROC;
//----------------------------------------
// listAllRecordFormats
//----------------------------------------
dcl-proc listAllRecordFormats;
dcl-pi listAllRecordFormats;
ilibname char(10) value;
ifilename char(10) value;
END-PI;
dcl-s rcdFmt char(10);
dcl-s NrOfRecordfmt int(10);
dcl-s myUserSpace2 char(20);
dcl-s nr int(10);
dcl-s thisFormat char(10);
// Get records format using DSPFFD OUTFILE Output
cmd='DSPFFD FILE($$LIB/$$FILE) OUTPUT(*OUTFILE) '
+' OUTFILE(QTEMP/TMPDSPFFD)';
cmd=%scanrpl('$$LIB':%trim(ilibname):cmd);
cmd=%scanrpl('$$FILE':%trim(ifilename):cmd);
qCmdExc(Cmd:%len(Cmd));
// Get all formats
exec sql
declare myformats cursor for
SELECT distinct whname
FROM qtemp.TMPDSPFFD;
exec sql open myformats;
dow 1=1;
exec sql fetch myformats into :thisFormat;
if sqlcod<>0;
exec sql close myformats;
leave;
ENDIF;
getFieldsInfo(libname:filename:thisFormat);
ENDDO;
end-proc;
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment