iSeries & System i

      Tips & Tricks - Indhold #1

Opt01 & CpyFrmStmF
New GUI debugger
Hent source's ned på din PC
QCmdExc - change librarylist
Lower & Upper Case
Overfør fil fra AS/400 til IFS
Overfør filer fra IFS til AS/400
Fixed vs Dynamic Arrays i UserSpace
Atoi vs %Dec



Opt01 & CpyFrmStmF

Læs indhold af CD på OPT01 og overfør data til AS/400

Blev kontaktet af en kunde, som havde modtaget et sæt CD'er, som de umiddelbart ikke kunne læse. CD'erne indeholdte hver en datafil, som skulle benyttes i en applikation på AS/400, og derfor skulle overføres til en datafil på AS/400.

Læste de en CD på en PC, var der ikke nogle læsbare data, det hele var volapyk.
Læste de en CD på AS/400, var resultatet det samme.

De mente derfor at data var i EBCDIC, hvilket de også fik bekræftet af afsenderen.

Kunden bad mig herefter om at udvikle en lille applikation, som kunne læse CD'erne, og aflevere dem i et bibliotek på AS/400.

Jeg startede herefter med en læsning af 'sti/filenavn' på OPT01:
    DspOpt Vol(*Mounted) Dev(Opt01) Data(*FilAtr)
        OutPut(*OutFile) Path(*All) OutFile(CdIndhold)

Nu havde jeg så de informationer, jeg skulle bruge for at kunne overføre CD'ens fil til AS/400.

Dette blev gjort med følgende kommando:
    CpyFrmStmF FromStmF(&FmMbr) ToMbr(&ToMbr)
        MbrOpt(*Replace) CvtDta(*None) EndLinFmt(*Fixed) TabExpn(*No)

Herefter kunne jeg via PDM gå ind og læse data. Dog var der et problem med ToMbr, idet modtager filen skal være bygget, og da jeg ikke kendte recordlængden på CD-filen, stod data forskudt. Herefter forsøgte jeg mig med forskellige recordlængder, indtil jeg havde fundet den korrekte længde. Blot viste det sig, at den sidste CD-fil havde en anden længde, så derfor måtte jeg igen prøve mig frem.

Da der altså var 2 forskellige recordlængder, måtte jeg desværre benytte mig af en ekstra 'hårdkodning', idet der skulle skelnes mellem disse længder.

Resultatet blev 3 CLLE programmer, samt en enkelt DDS:
    Program_1: Driverprogram der holder styr på CD-nummerrækkefølgen,
                    og som overfører CD-filens data til AS/400.
    Program_2: Windows-promt, hvor man bedes isætte CD nr. x af y.
    Program_3: Læser 'sti/filnavn' på CD nr. x.

Afvikling af applikationen foregår derfor som følger:
    Program_1: Diverse initieringer foretages.
                    Der testes om de benyttede filer findes, ellers bygges de.
                    Herefter loopes der y-antal gange (= antal CD'er).
                    Kald til Program_2, som beder om at få isat en CD.
                    Kald til Program_3, som læser 'sti/filnavn' på CD'en via DSPOPT.
                    CD filen overføres nu til QSYS/'bibliotek' via CPYFRMSTMF.
                    Der tælles +1 op i CD-tælleværket,
                    og der returneres til en label lige før næste kald til Program_2.

At Program_2 og Program_3 ikke kan slåes sammen til eet program, skyldes at de benytter DCLF og SNDRCVF hhv. DCLF og RCVF

Applikationen tester iøvrigt på, om der er isat en CD, samt at samme CD ikke isættes igen.

Back

New GUI debugger

IBM udsendte for nylig en ny GUI debugger, som virker fra og med V5R1
For V5R1's vedkommende, skal 2 PTF'er installeres: SI05799 og SI06301.

Debuggeren kan håndtere følgende programtyper:         ILE C and C++         ILE RPG         ILE COBOL         ILE CL         Java         OPM RPG         OPM COBOL         OPM CL

Debuggeren består af 2 moduler: iSeries System Debug Manager,         hvorfra de maskiner man har, initieres. Næste modul kan kaldes herfra.

iSeries System Debugger,         herfra kan man debugge de ovenstående programtyper.

Opsæt: På AS/400 skal et serverprogram initieres. Kan startes manuelt eller autostart under IPL. V5R1 - start serverjobbet med: CALL QSYS/QTESSTRSVR V5R2 - start serverjobbet med: STRTCPSVR *DBG.

Java v. 1.3.x skal som minimum være installeret på PC'en - hentes evt. her.

Tre '.jar' kræves ligeledes: TES.JAR, JT400.JAR og JHALL.JAR
TES. og JT400. kan findes på din iSeries: /QIBM/ProdData/HTTP/public/jt400/lib/
JHALL. kan findes hos Sun

CLASSPATH skal have tilføjet disse 3 filer (skal tilføjes den bestående streng).

Første modul kaldes med KØR/RUN: java utilities.DebugMgr

Andet modul kaldes med KØR/RUN: java utilities.Debug

Kaldene kan passende placeres på Desktop/Skrivebordet.

Ovenstående er blot stikpunkter, men MidrangeServer har en detailleret artikel om emnet.

Back

Hent source's ned på din PC

Jeg har til tider haft behov for at hente sourcekoder ned på min bærbar, fx. for at arbejde
med dem i en weekend, hvor der ikke var mulighed for opkobling til en AS/400.

Jeg giver sourcekoden en entydig extention, fx. .RPGLE, .CLLE, .PF osv.

Ved åbning af disse sourcekoder (første gang), fortæller jeg at de skal åbnes med NotePad, og herefter kan jeg benytte denne editor til at lave rettelser/tilføjelser. Husk at sætte font til Fixedsys/Regular.

Nedlæsning til IFS'en foretages med kommandoen CPYTOSTMF. Når programmet skal retur til AS/400 benyttes kommandoen CPYFRMSTMF.

Nedenstående et eksempel på nedlæsning af en RPGLE source til IFS'en:

CpyToStmF FromMbr('QSYS.LIB/bibliotek.LIB/qRpgSrc.FILE/program.MBR') + ToStmF('/programsource_bibliotek/program.RPGLE') + StmfOpt(*Replace) StmfCodPag(*PcAscii)

Herefter kopiere jeg sourcekoden fra IFS'en ned på egen PC med Windows Stifinder.

Når programmerne skal retur, er forløbet modsat.. fra PC til IFS og til slut kommandoen CPYFRMSTMF. Btw.... sourcekoden kan også kompileres fra IFS'en: CRTRPGMOD MODULE(LIBRARY/OBJECT) SRCSTMF('/somewhere/on/the/ifs')

Back

QCmdExc - change librarylist

Har nogle gange haft brug for at tilføje et bibliotek, og efterfølgende fjerne det igen
inde fra et RPG IV program.

I nedenstående eksempel, testes der på om biblioteket findes i forvejen, hvorfor det naturligvis ikke må fjernes igen.

Bemærk at QCmdExc ikke er et API, men et system program.

H TimFmt(*Iso.) DatFmt(*DMY.) BndDir('QC2LE') DatEdit(*YMD) * Kommandoer for tilføj og fjern D Clc S 80A Dim(2) Ctdata Perrcd(1) D SrchSign C '#' * *On, biblioteket eksisterer D LibFnd s N Inz(*off) * PSSR Informationer angående devices/filer. D WPssr SDS 528 D WPssr1 1 D WmUser 254 263 * Error msg definitioner D Ps_Proc_Name *Proc D Ps_Pgm_Status *Status D Ps_Routine *Routine D Ps_Parms *Parms D Ps_Excp_MsgId 7 Overlay(WPssr:40) D Ps_Excp_Type 3 Overlay(Ps_Excp_MsgId) D Ps_Excp_Num 4 Overlay(Ps_Excp_MsgId:4) * Protoype - Tilføjer/fjerner libraries i librarylisten. D WrkLib Pr 1N D InsRem 3A Const D LibNam 10A Const C Eval LibFnd = WrkLib('INS':'bibliotek') C Call something C If not LibFnd C Eval LibFnd = WrkLib('REM':'bibliotek') C Endif * ProcedureInterface for librarylist settings. P WrkLib B *Prototypekald til externt program: QCmdExc D CmdExec Pr Extpgm('QCMDEXC') D Cmd 512A Options(*VarSize) Const D Len 15P 5 Const D CmdStr S 512A D ScnPos S 3I 0 * SetTyp: INS=Insert lib REM=Remove lib D Pi 1N D SetTyp 3A Const D LibNam 10A Const D Exist s N D SrchSign c '#' C if SetTyp = 'INS' C Eval CmdStr = %Trim(Clc(1)) C Eval ScnPos = %Scan(SrchSign C : CmdStr C : 1) C If ScnPos > *Zeros C Eval CmdStr = %Replace(%Trim(LibNam) C : CmdStr C : ScnPos C : %Len(SrchSign)) C CallP(E) CmdExec (CmdStr : %Len(%Trim(CmdStr))) C Endif * Findes biblioteket i forvejen, sættes et flag, * da det så efterfølgende ikke må fjernes. C If %Error And C Ps_Excp_MsgId = 'CPF2103' C Eval Exist = *On C endif C endif C if SetTyp = 'REM' C Eval CmdStr = %Trim(Clc(2)) C Eval ScnPos = %Scan(SrchSign C : CmdStr C : 1) C If ScnPos > *Zeros C Eval CmdStr = %Replace(%Trim(LibNam) C : CmdStr C : ScnPos C : %Len(SrchSign)) C CallP(E) CmdExec (CmdStr : %Len(%Trim(CmdStr))) C Eval Exist = *Off C endif C endif C Return Exist P WrkLib E ** Clc AddLiblE Lib(#) Position(*Last) RmvLiblE Lib(#)

Back

Lower & Upper Case

Simpel rutine til skift mellem små og store bogstaver.

* Upper/Lower D Ucase C 'ABCDEFGHIJKLMNOPQRSTUVWXYZÆØÅ' D Lcase C 'abcdefghijklmnopqrstuvwxyzÆØÅ' C Lcase:Ucase Xlate PrdLib WrkLib *eller C Ucase:Lcase Xlate TstLib WrkLib

Back

Overfør fil fra AS/400 til IFS

Følgende programstump danner en workfil i Qtemp, overfører data fra et kartotek via
en datastruktur til workfilen, for herefter at sende den ned på IFS'en i et angivet
folder/filnavn.

Findes folderen ikke på IFS'en, bygges den først og programmet afsluttes. Herefter kan
programmet kaldes igen, og ovenstående blive eksekveret.

H BndDir('QC2LE') FOrgFilP uf e k disk FWrkFilP if a e disk rename(WrkFilP:WrkFilR) F prefix(w_) F usropn * Path på IFS'en D Path C Const('/WrkLib') D Root C Const('.') * Kommandoer D Clc S 80A Dim(7) Ctdata Perrcd(1) D SrchSign C '#' * WrkDS (den ønskede datastruktur, som udlæses i WrkFilP) D WrkDS ds 1A Felt_1 5A Felt_2 (osv., ialt 256 bytes) (iflg Clc[2]) * Datastruktur D dirent ds based(p_dirent) D d_reserv1 16A D d_reserv2 10U 0 D d_fileno 10U 0 D d_reclen 10U 0 D d_reserv3 10I 0 D d_reserv4 8A D d_nlsinfo 12A D nls_ccsid 10I 0 Overlay(d_nlsinfo:1) D nls_cntry 2A Overlay(d_nlsinfo:5) D nls_lang 3A Overlay(d_nlsinfo:7) D nls_reserv 3A Overlay(d_nlsinfo:10) D d_namelen 10U 0 D d_name 640A D p_dirent s * * Prototype: Open directory D OpenDir Pr * ExtProc('opendir') D p_open * Value * Prototype: Read directory D ReadDir Pr * ExtProc('readdir') D p_read * Value * Prototype: Write file D Write Pr * ExtProc('write') D p_write * Value * Prototype: Close directory D CloseDir Pr 10I 0 ExtProc('closedir') D p_close * Value * Prototype: QCmdExc D CmdExec Pr Extpgm('QCMDEXC') D Cmd 512A Options(*VarSize) Const D Len 15P 5 Const D CmdStr S 512A * Standalone felter/pointer D dh S * D PathName S 256A D Name S 256A D Lgth S 10 0 D ReturnInt S 10I 0 D Null s 1A Inz(X'00') D ScnPos S 10I 0 D NotEmpty S N Inz(*off) * Main routine C Exsr Housekeeping * Læser records i kartoteket C open WrkFilP C OrgKey Setll OrgFilP C OrgKeyS Reade OrgFilP 91 C dow *In91 = *off C eval NotEmpty = *on C exsr CrtRec C OrgKeyS Reade OrgFilP 91 C enddo C close WrkFilP * Læs WrkFilP ned på IFS'en C if NotEmpty C exsr WrtIfs C endif * Der lukkes C eval ReturnInt = closedir(%addr(dh)) C eval *inlr = *On * Dan de ønskede informationer, udlæs records og slet i OrgFilP C CrtRec begsr * Dan informationer til datastrukturen WrkDs * Her udlæses den dannede datastruktur C eval w_WrkFilP = WrkDS C write WrkFilR C delete OrgFilR C endsr * Filen WrkFilP sendes nu til IFS'en. C WrtIfs begsr * Sæt pointer til directory for write C eval p_dirent = write(dh) * Send filen til IFS C Eval ScnPos = 1 C Eval CmdStr = %Trim(Clc(4)) + ' ' + C %Trim(Clc(5)) + ' ' + C %Trim(Clc(6)) C Eval ScnPos = %Scan(SrchSign C : CmdStr C : 1) C If ScnPos > *Zeros C Eval CmdStr = %Replace(%Trim(Path) + C '/' + C %Trim(WrkFilP.ext) C : CmdStr C : ScnPos C : %Len(SrchSign)) C Endif C CallP(E) CmdExec (CmdStr : %Len(%Trim(CmdStr))) C If %Error = *On C Exsr ErrMngr C Endif C endsr * Housekeeping C Housekeeping begsr * Åbner folder C eval PathName = Path + Null C eval dh = opendir(%addr(PathName)) C if dh = *Null * Findes folder ikke, så bygges den på IFS'en og afslutter. C exsr BldFldr C eval *InLr = *On C Return C endif * Byg en workfil midlertidig C Eval ScnPos = 1 C Eval CmdStr = %Trim(Clc(2)) C Eval ScnPos = %Scan(SrchSign C : CmdStr C : 1) C If ScnPos > *Zeros C Eval CmdStr = %Replace('WrkFilP' C : CmdStr C : ScnPos C : %Len(SrchSign)) C Endif C CallP(E) CmdExec (CmdStr : %Len(%Trim(CmdStr))) C If %Error = *On C Exsr ErrMngr C Endif * Clear (for god ordens skyld) C Eval ScnPos = 1 C Eval CmdStr = %Trim(Clc(3)) C Eval ScnPos = %Scan(SrchSign C : CmdStr C : 1) C If ScnPos > *Zeros C Eval CmdStr = %Replace('WrkFilP' C : CmdStr C : ScnPos C : %Len(SrchSign)) C Endif C CallP(E) CmdExec (CmdStr : %Len(%Trim(CmdStr))) C If %Error = *On C Exsr ErrMngr C Endif C Endsr * Byg folderen og afslut (pgm. skal kaldes igen). C BldFldr begsr C Eval ScnPos = 1 C Eval CmdStr = %Trim(Clc(1)) C Eval ScnPos = %Scan(SrchSign C : CmdStr C : 1) C If ScnPos > *Zeros C Eval CmdStr = %Replace(%Trim(Path) C : CmdStr C : ScnPos C : %Len(SrchSign)) C Endif C CallP(E) CmdExec (CmdStr : %Len(%Trim(CmdStr))) C If %Error = *On C Exsr ErrMngr C Endif C endsr ** ** Clc MKDIR DIR('#') DTAAUT(*INDIR) OBJAUT(*INDIR) CRTOBJAUD(*SYSVAL) CRTPF FILE(QTEMP/#) RCDLEN(256) CLRPFM FILE(QTEMP/#) CPYTOSTMF TOSTMF('#') FROMMBR('QSYS.LIB/QTEMP.LIB/WRKFILP.FILE/WRKFILP.MBR') STMFOPT(*REPLACE) STMFCODPAG(819 ) DEL OBJLNK('#')

Back

Overfør filer fra IFS til AS/400

Følgende programstump danner en workfil i Qtemp, læser herefter en angivet folder
på IFS'en og overfører alle filerne en efter en til Qtemp.

Data bliver herefter overført til et angivet kartotek og filen i folderen slettes.
Herefter læses næste fil og så fremdeles, indtil folderen er tom.

Findes folderen ikke på IFS'en, bygges den først og programmet afsluttes. Herefter
kan programmet kaldes igen, og ovenstående blive eksekveret.

H BndDir('QC2LE') FWrkFilP if e disk rename(WrkFilP:WrkFilR) F prefix(w_) F usropn FOrgFilP if a e disk * Path to folder on IFS D Path C Const('/wrkfldr/') D Root C Const('.') * Commands D Clc S 80A Dim(7) Ctdata Perrcd(1) D SrchSign C '#' * Datastructure for WrkFilP D wWrkFilR ds 256 D wCustNo 1 7 0 D wCustNm 8 37 (and so on) * Datastructure D dirent ds based(p_dirent) D d_reserv1 16A D d_reserv2 10U 0 D d_fileno 10U 0 D d_reclen 10U 0 D d_reserv3 10I 0 D d_reserv4 8A D d_nlsinfo 12A D nls_ccsid 10I 0 Overlay(d_nlsinfo:1) D nls_cntry 2A Overlay(d_nlsinfo:5) D nls_lang 3A Overlay(d_nlsinfo:7) D nls_reserv 3A Overlay(d_nlsinfo:10) D d_namelen 10U 0 D d_name 640A D p_dirent s * * Prototype: Open directory D OpenDir Pr * ExtProc('opendir') D p_name * Value * Prototype: Read directory D ReadDir Pr * ExtProc('readdir') D p_read * Value * Prototype: Close directory D CloseDir Pr 10I 0 ExtProc('closedir') D p_close * Value * Prototype: QCmdExc D CmdExec Pr Extpgm('QCMDEXC') D Cmd 512A Options(*VarSize) Const D Len 15P 5 Const D CmdStr S 512A * Standalone fields/pointer D dh S * D PathName S 256A D Name S 256A D Lgth S 10 0 D ReturnInt S 10I 0 D Null s 1A Inz(X'00') D ScnPos S 10I 0 * Mainroutine C Exsr Housekeeping * Read files in IFS folder C eval p_dirent = readdir(dh) C dow p_dirent <> *Null C Null scan d_name Lgth C if Lgth < 256 and C Root <> %subst(d_name:1:1) * Get the name of the file and strip X'00' C eval Name = %subst(d_name:1:(Lgth-1)) * Upload files to the AS/400 C exsr UpLoad C endif C eval p_dirent = readdir(dh) C enddo * Close program. C eval ReturnInt = closedir(%addr(dh)) C eval *inlr = *On * Get files from IFS, og create records to OrgFilP. C UpLoad begsr * Copy the file from IFS to the temp. file on AS/400 C Eval ScnPos = 1 C Eval CmdStr = %Trim(Clc(4)) + ' ' + C %Trim(Clc(5)) + ' ' + C %Trim(Clc(6)) C Eval ScnPos = %Scan(SrchSign C : CmdStr C : 1) C If ScnPos > *Zeros C Eval CmdStr = %Replace(%Trim(Path) + C %Trim(Name) C : CmdStr C : ScnPos C : %Len(SrchSign)) C Endif C CallP(E) CmdExec (CmdStr : %Len(%Trim(CmdStr))) C If %Error = *On C Exsr ErrMng C Endif * Create data/records to OrgFilP. C Open WrkFilP 91 C Read WrkFilP 91 C Dow *In91 = *off C Eval wWrkFilR = w_WrkFilP (prepare data for OrgFilP) C Write OrgFilP C Read WrkFilP 91 C Enddo * No need for CLRPF, CPYFRMSTMF is doing a *REPLACE C Close WrkFilP 91 * Delete the object on IFS. C Eval ScnPos = 1 C Eval CmdStr = %Trim(Clc(7)) C Eval ScnPos = %Scan(SrchSign C : CmdStr C : 1) C If ScnPos > *Zeros C Eval CmdStr = %Replace(%Trim(Path) + C %Trim(Name) C : CmdStr C : ScnPos C : %Len(SrchSign)) C Endif C CallP(E) CmdExec (CmdStr : %Len(%Trim(CmdStr))) C If %Error = *On C Exsr ErrMng C Endif C endsr * Housekeeping. C Housekeeping Begsr * Open folder C eval PathName = Path + Null C eval dh = opendir(%addr(PathName)) C if dh = *Null * Folder doesn't exist, create folder and exit. Then call pgm again. C exsr BldFldr C eval *InLr = *On C Return C endif * Create a temporary file C Eval ScnPos = 1 C Eval CmdStr = %Trim(Clc(2)) C Eval ScnPos = %Scan(SrchSign C : CmdStr C : 1) C If ScnPos > *Zeros C Eval CmdStr = %Replace('WrkFilP' C : CmdStr C : ScnPos C : %Len(SrchSign)) C Endif C CallP(E) CmdExec (CmdStr : %Len(%Trim(CmdStr))) C If %Error = *On C Exsr ErrMng C Endif C Endsr * Creating a folder on IFS. C BldFldr begsr C Eval ScnPos = 1 C Eval CmdStr = %Trim(Clc(1)) C Eval ScnPos = %Scan(SrchSign C : CmdStr C : 1) C If ScnPos > *Zeros C Eval CmdStr = %Replace(%Trim(Path) C : CmdStr C : ScnPos C : %Len(SrchSign)) C Endif C CallP(E) CmdExec (CmdStr : %Len(%Trim(CmdStr))) C If %Error = *On C Exsr ErrMng C Endif C endsr ** ** Clc MKDIR DIR('#') DTAAUT(*INDIR) OBJAUT(*INDIR) CRTOBJAUD(*SYSVAL) CRTPF FILE(QTEMP/#) RCDLEN(256) CLRPF FILE(QTEMP/#) CPYFRMSTMF FROMSTMF('#') TOMBR('QSYS.LIB/QTEMP.LIB/WRKFILP.FILE/WRKFILP.MBR') MBROPT(*REPLACE) STMFCODPAG(819 ) DEL OBJLNK('#')

Back

Fixed vs Dynamic Arrays i UserSpace

Beskrivelse af forbrug ved Fixed vs Dynamic Arrays i UserSpace:

Programstørrelse ved fixed arrays:          696.320 bytes
Programstørrelse ved dynamic arrays:     200.704 bytes

Størrelse på UserSpace ved	 0 elementer start: 4096 bytes slut: 4096 bytes
		       10000 elementer start: 4096 bytes slut: 49.152 bytes
		       30000 elementer start: 4096 bytes slut: 122.880 bytes

Performance kan ikke måles, idet ovenstående test ingen tid tager,
men umiddelbart kører de lige hurtige.

Fixed arrays
	 ************************************************************
	 * Arrays til opsummering af fakturalinier                  *
	 ************************************************************
	D FakAr           S              6  0 Dim(32766)
	D BelAr           S             24  2 Dim(32766)
	D Ar              S              9  0
	D FakGm           S              6  0

	 ************************************************************
	 * Hoved rutine                                             *
	 ************************************************************
	 * Nedenstående API kald til UserSpace (dog med Fixed Arrays)
	 * er ikke medtaget her af pladshensyn. . . . .
	C                   eval      Ar           = 1
	C                   dow       ar           < 30001

	C                   eval      FakAr(Ar)    = ar
	C                   eval      Ar           = Ar + 1
	C                   enddo

	 * Luk programmet
	C     Slut          tag
	C                   Eval      *InLR        = *On

Dynamic arrays
	 ************************************************************
	 * Arrays til opsummering af fakturalinier                  *
	 ************************************************************
	D pArr            S               *
	D FakAr           S              6  0 Dim(32766) BASED(pArr)
	D BelAr           S             24  2 Dim(32766) Based(pArr)
	D Ar              S              9  0
	D FakGm           S              6  0

	 ************************************************************
	 * Datastruktur til initieringer                            *
	 ************************************************************
	D                 Ds
	D  UserSpace                    20A   Inz('US_navn10.US_bibl10.')
	D  SSize                        10I 0 Inz(64)
	D  ExtAttr                      10A   Inz('VARYING   ')
	D  AutoExtend                    1N   Inz(*on)
	D  InitVal                       1A   Inz(X'00')
	D  PubAut                       10A   Inz('*ALL      ')
	D  Replace                      10A   Inz('*YES      ')
	D  Text                         50A   Inz('Test Varying Arrays')
	D  Domain                       10A   Inz('*USER     ')

	 ************************************************************
	 * Prototypes til UserSpace                                 *
	 ************************************************************
	D UsrSpcArr       PR             1N
	D  szUserSpace                  20A
	D  nUSSize                      10I 0
	D  szExtAttr                    10A
	D  bAutoExtend                   1N
	D  InitValue                     1A
	D  szPubAut                     10A
	D  szReplace                    10A
	D  szText                       50A
	D  szDomain                     10A

	D UsrPtrArr       PR
	D  szUserSpace                  20A
	D  szPtrArr                       *

	D  RtnVal         S               N   Inz(*off)
	 ************************************************************
	 * Hoved rutine                                             *
	 ************************************************************
	C                   Exsr      Start
	C                   CallP     UsrPtrArr    (UserSpace
	C                                          :pArr)
	C                   eval      Ar           = 1
	C                   dow       ar           < 30001

	C                   CallP     UsrPtrArr    (UserSpace
	C                                          :pArr)

	C                   eval      FakAr(Ar)    = ar
	C                   eval      Ar           = Ar + 1
	C                   enddo
	C                   Goto      slut
	 * Luk programmet
	C     Slut          tag
	C                   Eval      *InLR        = *On

	 ************************************************************
	 * Start: Kun første gang                                   *
	 ************************************************************
	C     Start         Begsr

	C                   Eval      RtnVal  = UsrSpcArr(UserSpace  :
	C                                                 SSize      :
	C                                                 ExtAttr    :
	C                                                 AutoExtend :
	C                                                 InitVal    :
	C                                                 PubAut     :
	C                                                 Replace    :
	C                                                 Text       :
	C                                                 Domain)

	C                   Endsr

	 ************************************************************
	 * PI - Dan UserSpace ændre fra fixed til dynamic           *
	 ************************************************************
	P UsrSpcArr       B

	D UsrSpcArr       PI             1N
	D  szUserSpace                  20A
	D  nUSSize                      10I 0
	D  szExtAttr                    10A
	D  bAutoExtend                   1N
	D  InitValue                     1A
	D  szPubAut                     10A
	D  szReplace                    10A
	D  szText                       50A
	D  szDomain                     10A

	D QusCRTUS        PR                  ExtPgm('QUSCRTUS')
	D  UsrSpace                     20A   Const
	D  ExtAttr                      10A   Const
	D  nSize                        10I 0 Const
	D  InitValue                     1A   Const
	D  PubAuth                      10A   Const
	D  szTextDesc                   50A   Const
	D  Replace                      10A   Const
	D  api_error                          Like(apiError)
                                          OPTIONS(*NOPASS)
	D  szDomain                     10A   Const OPTIONS(*NOPASS)

	D QusCUSAT        PR                  ExtPgm('QUSCUSAT')
	D  RtnLibName                   10A
	D  UsrSpace                     20A   Const
	D  USAttr                       64A   OPTIONS(*VARSIZE)
	D  api_error                          Like(apiError)

	D apiError        DS                  Inz
	D  apiLen                       10I 0 Inz(0)
	D  apiRLen                      10I 0
	D  apiMsgID                      7A
	D  apiResv1                      1A   Inz(X'00')
	D  apiErrText                   24A

	D rtnLib          S             10A
	D RtnVal          S               N

	 ** The QUSCUSAT data structure
	 ** This one is setup up only to change the
	 ** auto-extendibility option to '1'.
	D UserSpaceAttr   DS                  ALIGN
	D  nRecdCount                   10I 0 Inz(1)
	D  nAttrKey                     10I 0 Inz(3)
	D  nAttrLen                     10I 0 Inz(%Size(bExtend))
	D  bExtend                       1A   Inz('1')

	C                   Eval      RtnVal       = *on
	C                   Callp     QusCRTUS(szUserSpace:szExtAttr:
	C                              nUSSize : InitValue : szPubAut :
	C                              szText : szReplace : apiError :
	C                              szDomain )

	C                   if        apiRLen      > 0
	C                   Eval      RtnVal       = *off
	C                   Endif

	C                   if        apiRLen      = 0 and bAutoExtend
	 ** Change the user space to AutoExtend
	C                   CallP     QusCUSAT(rtnLib : szUserspace :
	C                                   UserSpaceAttr : apiError)
	C                   if        apiRLen      > 0
	C                   Eval      RtnVal       = *off
	C                   Endif

	C                   endif
	C                   return    RtnVal
	P UsrSpcArr       E


	 ************************************************************
	 * PI - Find pointer til array.                             *
	 ************************************************************
	P UsrPtrArr       B

	D UsrPtrArr       PI
	D  szUserSpace                  20A
	D  szPtrArr                       *

	D QusPTRUS        PR                  ExtPgm('QUSPTRUS')
	D  UsrSpace                     20A   Const
	D  PtrArr                         *
	D  api_error                          Like(apiError)

	D apiError        DS                  Inz
	D  apiLen                       10I 0 Inz(0)
	D  apiRLen                      10I 0
	D  apiMsgID                      7A
	D  apiResv1                      1A   Inz(X'00')
	D  apiErrText                   24A

	C                   CallP     QusPtrUS(szUserspace :
	C                                     szPtrArr     :
	C                                     apiError)
	C                   if        apiRLen      > 0
	C                   Eval      RtnVal       = *off
	C                   Endif

	C                   return
	P UsrPtrArr       E

Thanks to Bob Cozzi
Back

Atoi vs %Dec

Bif'en %Dec blev først indført i V5R2, så hvis et chr. felt med nummeriske værdier (+/-)
skal overføres til et nummerisk felt kan det gøres med bl.a. Atoi.


	H BNDDIR('QC2LE')
	 * Convert Character String to Integer
	 *  Any minus sign must be leading, not trailing
	D prCvtCharToInt  PR            10I 0 EXTPROC('atoi')
	D                                 *   VALUE OPTIONS(*STRING)

	D char            S             10    INZ('     -2138')
	D dec             S              9  2

	C                   EVAL      dec = prCvtCharToInt(char)/100
	    eller:
	C                   EVAL      dec = prCvtCharToInt(char)
	C                   RETURN

Back

Page #1

Back