-
Ermittlung des SFLPAG-Values zur Laufzeit des Programms
Hallo, liebe AS/400-Gemeinde!
Ihr kennt das Problem:
Im RPG wird der SFLPAG-Value durch eine Konstante oder ein nummerisches Literal abgefragt:
C 1 DO 15 I 3 0
C* Schreibe irgendetwas in die Subfile
C ENDDO
Jetzt kommen im Kopf (Subdateikontrollsatzformat) Informationen hinzu. Die Subfile muss um eine Zeile reduziert werden.
Wenn der Programmierer vergisst, die Konstante bzw. das nummerische Literal zu ändern, "verzieht" sich die Subfile: Es wird eine Seite und ein Satz geladen, der dann mutterseelenalleine auf der nächsten Seite herumsteht - besonders, wenn man die Subfilenummer in die durch das Schlüsselwort SFLRCDNBR definierte Variable hineinschreibt.
Daher habe ich die Prozedur pr_sflval entwickelt, die zur Laufzeit des Programms mit Hilfe des Retrieve-Display-File-Description-APIs QDFRTVFD den SFLPAG-Value und andere nützliche Werte ermittelt.
Das stelle ich mir so vor:
Die Display File sei MYDSPF, der Subdateikontrollsatz CTL01.
di s 20 i 0 inz
dsflpag s 4 0 inz
/free
monitor;
sflpag=%int(pr_sflval('MYDSPF *LIBL':'CTL01':'SFLPAG'));
on-error *all;
clear sflpag;
endmon;
for i=1 to sflpag;
// Schreibe irgendetwas in die Subfile
endfor;
/end-free
Code:
h/title PR_SFLVAL - Procedure Retrieve Subfile Values
h copyright('(C) Copyright APL Services 2010-04-23')
/if defined(*crtbndrpg)
h dftactgrp(*no) actgrp(*caller) bnddir('QC2LE') option(*srcstmt)
h aut(*all)
/endif
/if defined(*crtrpgmod)
h nomain option(*srcstmt) aut(*all)
/endif
//‚Include Global Header Files
/include qrpglesrc,prototypes
/include qsysinc/qrpglesrc,qdfrtvfd
/include qsysinc/qrpglesrc,qusec
//‚Required Prototypes
//‚Procedure Reset qusec
d*pr_reset_qusec pr
//‚Procedure Retrieve Subfile Values
d*pr_sflval pr 10a
d* 20a const Qual. DSPF Name
d* 10a const Record Format
d* 10a const Receiver Type
//‚Convert Hex to Char
d*cvthextochar pr extproc('cvthc')
d* * value Receiver
d* * value Source
d* 10i 0 value Receiver Size
//‚Copy Memory
d*memcpy pr extproc('memcpy')
d* * value Target
d* * value Source
d* 10i 0 value Size of Source
//‚Retrieve Display File Description
d*rtvdspfd pr extpgm('QDFRTVFD')
d* 65535a options(*varsize) Receiver
d* 10i 0 const Length of Receiver
d* 8a const DSPF0100
d* 20a const Qual. DSPF Name
d* 16a qusec
//‚Test Bits
d*tstbts pr 10i 0 extproc('tstbts')
d* * value String to be tested
d* 10u 0 value Offset of bit
/*-------------------------------------------------------------------*/
//‚Procedure Retrieve Subfile Values
ppr_sflval b export
d pi 10a
d pi_qualnam 20a const Qual. DSPF Name
d pi_rcdfmt 10a const Record Format
d pi_rcvtyp 10a const Receiver Type
//‚Receiver Types
// DROPFOLD - Returnes, if the initial status of the Subfile is
// folded or truncated (*DROP/*FOLD)
// RCDTYP - Record Type will be returned (SFLCTL)
// SFLBEGROW - Beginning Row of Subfile will be returned
// SFLDROP - Returnes, if the SFLDROP keyword is used (*YES/*NO)
// SFLDROPCMD - Command Key associated with the SFLDROP/SFLFOLD
// Keyword will be returned
// SFLENDROW - Ending Row of Subfile will be returned
// SFLLIN - Subfile Line Value will be returned
// SFLPAG - Subfile Page Value will be returned
// SFLSIZ - Subfile Size Value will be returned
//‚Local Variables
dchar1 s 1a inz
dchar2 s 2a inz
dchar4 s 4a inz
di s 20i 0 inz
dlv_qualnam s inz like(pi_qualnam)
dlv_rcdfmt s inz like(pi_rcdfmt)
dlv_rcvtyp s inz like(pi_rcvtyp)
dp_qdfarfte s * inz(*null)
dp_qdffinfo s * inz(*null)
dp_qdffrinf s * inz(*null)
dp_qdffsfcr s * inz(*null)
dp_qdffsfhr s * inz(*null)
drcvvar s 65535a based(p_rcvvar)
//‚Local Constants
dapircvsiz c 65535
dlo c x'8182838485868788899192939495969798-
d 99A2A3A4A5A6A7A8A943CCDC'
dup c x'C1C2C3C4C5C6C7C8C9D1D2D3D4D5D6D7D8-
d D9E2E3E4E5E6E7E8E936ECFC'
/free
lv_qualnam=%triml(%xlate(lo:up:pi_qualnam));
lv_rcdfmt=%triml(%xlate(lo:up:pi_rcdfmt));
lv_rcvtyp=%triml(%xlate(lo:up:pi_rcvtyp));
lv_qualnam=pi_qualnam;
lv_rcdfmt=pi_rcdfmt;
if lv_qualnam<>' ' and lv_rcdfmt<>' ' and lv_rcvtyp<>' ';
p_rcvvar=%alloc(apircvsiz);
pr_reset_qusec();
rtvdspfd(rcvvar:apircvsiz:'DSPF0100':pi_qualnam:qusec);
if qusbavl=0;
// Base File Section QDFFBASE
clear qdffbase;
memcpy(%addr(qdffbase):%addr(rcvvar):%size(qdffbase));
if qdffretn>0 and qdffinof>0;
p_rcvvar+=qdffinof;
// File Header Section QDFFINFO
clear qdffinfo;
memcpy(%addr(qdffinfo):p_rcvvar:%size(qdffinfo));
// Record Header Section QDFFRINF
clear qdffrinf;
p_qdffinfo=p_rcvvar;
if qdffdflo>0 and qdfffrcs>0;
p_rcvvar+=qdffdflo;
// Record Format Table QDFARFTE
clear qdfarfte;
p_qdfarfte=%addr(qdfarfte);
if qdfffrcs>0;
for i=1 to qdfffrcs;
if i>1;
p_rcvvar+=%size(qdfarfte);
endif;
// Record Format Table QDFARFTE
memcpy(p_qdfarfte:p_rcvvar:%size(qdfarfte));
if pi_rcdfmt=qdfarfnm;
if qdfarfof>0;
// Displacement to the record header section (see structure
// QDFFRINF) from structure QDFFINFO
memcpy(%addr(qdffrinf):p_qdffinfo+qdfarfof:%size(qdffrinf));
char1=qdfbits09;
// Check, if SFLCTL
if tstbts(%addr(char1):2)=1;
if lv_rcvtyp='RCDTYP';
return 'SFLCTL';
endif;
// Displacements to display-record-level device-dependent
// section and subfile control record from structure
// QDFFRINF (see structures QDFFRDPD and QDFFSFCR)
// Display-Record-Level Device-Dependent Section
// (QDFFRDPD) Display device-dependent section for
// nonsubfile records
p_qdffrinf=p_qdffinfo+qdfarfof+qdffraof;
clear qdffsfcr;
memcpy(%addr(qdffsfcr):p_qdffrinf:%size(qdffsfcr));
// Command key associated with dspsfl or SFLFOLD keyword.
// X'00' indicates neither keyword is specified (see
// QDFFSFFD in this table)
p_qdffsfhr=p_qdffrinf+%size(qdffsfcr);
clear qdffsfhr;
memcpy(%addr(qdffsfhr):p_qdffsfhr:%size(qdffsfcr));
// Subfile Page Value
if lv_rcvtyp='SFLPAG';
return %char(qdffsfpg);
endif;
// Subfile Size
if lv_rcvtyp='SFLSIZ';
return %char(QDFFSFSZ);
endif;
// Subfile Start Row
if lv_rcvtyp='SFLBEGROW';
return %char(QDFFSFR1);
endif;
// Subfile End Row
if lv_rcvtyp='SFLENDROW';
return %char(QDFFSFR2-1);
endif;
// SFLLIN
if lv_rcvtyp='SFLLIN' and QDFFSFLN<>x'00000000';
cvthextochar(%addr(char4):%addr(qdffsfln):%len(char4));
if char4>*zeros;
return char4;
endif;
endif;
// SFLDROP specified
if qdffsfdr<>x'00';
if lv_rcvtyp='SFLDROPCMD';
cvthextochar(%addr(char2):%addr(qdffsfdr):%len(char2));
if char2>'00';
return char2;
endif;
endif;
if lv_rcvtyp='SFLDROP';
if tstbts(%addr(qdfbits20):5)=1;
return '*YES';
else;
return '*NO';
endif;
endif;
if lv_rcvtyp='DROPFOLD';
if tstbts(%addr(qdfbits20):4)=0;
return '*DROP';
else;
return '*FOLD';
endif;
endif;
endif;
endif;
endif;
leave;
endif;
endfor;
endif;
endif;
endif;
endif;
endif;
p_rcvvar=*null;
return *blanks;
/end-free
ppr_sflval e
/*-------------------------------------------------------------------*/
Similar Threads
-
By MarcusGebbeken in forum NEWSboard Programmierung
Antworten: 1
Letzter Beitrag: 10-07-08, 07:53
-
By GreatEMU in forum NEWSboard Programmierung
Antworten: 10
Letzter Beitrag: 29-03-07, 10:39
-
By CrazyJoe in forum NEWSboard Programmierung
Antworten: 4
Letzter Beitrag: 02-10-06, 10:01
-
By intelinside in forum NEWSboard Server Software
Antworten: 4
Letzter Beitrag: 28-07-06, 09:00
-
By timeless in forum NEWSboard Programmierung
Antworten: 2
Letzter Beitrag: 24-05-06, 06:37
Berechtigungen
- Neue Themen erstellen: Nein
- Themen beantworten: Nein
- You may not post attachments
- You may not edit your posts
-
Foren-Regeln
|
Erweiterte Foren Suche
Google Foren Suche
Forum & Artikel
Update eMail
AS/400 / IBM i
Server Expert Gruppen
Unternehmens IT
|
Kategorien online Artikel
- Big Data, Analytics, BI, MIS
- Cloud, Social Media, Devices
- DMS, Archivierung, Druck
- ERP + Add-ons, Business Software
- Hochverfügbarkeit
- Human Resources, Personal
- IBM Announcements
- IT-Karikaturen
- Leitartikel
- Load`n`go
- Messen, Veranstaltungen
- NEWSolutions Dossiers
- Programmierung
- Security
- Software Development + Change Mgmt.
- Solutions & Provider
- Speicher – Storage
- Strategische Berichte
- Systemmanagement
- Tools, Hot-Tips
Auf dem Laufenden bleiben
|
![[NEWSboard IBMi Forum]](images/duke/nblogo.gif)
[User]
Mit Zitat antworten
Bookmarks