|
On 12/30/2021 4:45 PM Scott Klement <rpg400-l@xxxxxxxxxxxxxxxx> wrote:
Hi Jay,
On 12/30/2021 12:48 PM, Jay wrote:
I've wasted most of the morning trying to get a call to QSYLOBJA to work.
Does anyone have a working example??
I found an example from someone named Carsten, but it won't compile as it is looking for a service program QDMM.. something.
You didn't say what you needed the example to do, or what problem you
were having... so hard to know if my reply will help you.
I do know Carsten's work, though -- it is always well-written and
tested, so I'm very surprised to hear that you had problems with it.
QSYLOBJA is an OPM program, so doesn't (and can't) use service
programs. Something weird is going on...
I have an old example of QSYLOBJA laying around (it's very old, looks
like 2003, please excuse the outdated coding style). I don't remember
writing it anymore, but it looks like it was intended to illustrate the
process of sorting the output of an API...
H DFTACTGRP(*NO) ACTGRP(*NEW) BNDDIR('QC2LE')
D QSYLOBJA PR ExtPgm('QSYLOBJA')
D UsrSpc 20A const
D Format 8A const
D User 10A const
D ObjType 10A const
D RtnObjs 10A const
D ContHandle 20A const
D ErrorCode 32766A options(*varsize)
D ReqList 32766A options(*varsize: *nopass)
D QUSCRTUS PR ExtPgm('QUSCRTUS')
D UsrSpc 20A CONST
D ExtAttr 10A CONST
D InitialSize 10I 0 CONST
D InitialVal 1A CONST
D PublicAuth 10A CONST
D Text 50A CONST
D Replace 10A CONST
D ErrorCode 32766A options(*nopass: *varsize)
D QUSPTRUS PR ExtPgm('QUSPTRUS')
D UsrSpc 20A CONST
D Pointer *
D QUSDLTUS PR ExtPgm('QUSDLTUS')
D UsrSpc 20A CONST
D ErrorCode 32766A options(*varsize)
D qsort PR ExtProc('qsort')
D start_of_dta * value
D num_of_elems 10U 0 value
D size_of_elem 10U 0 value
D compare_proc * ProcPtr value
D Compare PR 10I 0
d p_Ent1 *
d p_Ent2 *
D p_UsrSpc s *
D dsLH DS BASED(p_UsrSpc)
D qualified
D Filler1 103A
D Status 1A
D Filler2 12A
D HdrOffset 10I 0
D HdrSize 10I 0
D ListOffset 10I 0
D ListSize 10I 0
D NumEntries 10I 0
D EntrySize 10I 0
D p_OO s *
D dsOO ds based(p_OO) qualified
D PathOffset 10I 0
D PathLen 10I 0
d ObjType 10A
d AuthHolder 1A
D Ownership 1A
D ASPDevice 10A
**
** FIXME: This will cause problems if a user has more than
** 32k objects, but it makes the code simpler :)
** If you need more, just allocate a block of memory
** and use pointer math.
D p_SortList s *
D SortList s * dim(32767) based(p_SortList)
D p_Path s *
D dsPath ds based(p_Path) qualified
D CCSID 10I 0
D Country 2A
D LangID 3A
D Reserved1 3A
D Flag 10I 0
D len 10I 0
D Delim 2A
D Reserved2 10A
D Name 32768A
D dsEC DS qualified
D BytesProvided 10I 0 inz(%size(dsEC))
D BytesAvail 10I 0 inz(0)
D MessageID 7A
D Reserved 1A
D MessageData 240A
D MYSPACE C CONST('OWNLIST QTEMP ')
D size s 10I 0
D msg s 52A
D x s 10I 0
/free
//
// set this to zero to let OS/400 handle errors, instead
// of handling them ourselves...
//
dsEC.BytesProvided = 0;
//
// Create a user space.. make space for (approx) 1000
// IFS objects to be listed.
//
size = %size(dsLH) + 512 + ((%size(dsOO) + 100) * 1000);
QUSCRTUS(MYSPACE: 'USRSPC': size: x'00': '*ALL':
'Temp User Space for QSYLOBJA API': '*YES': dsEC);
//
// List objects owned by current user to the user space
//
QSYLOBJA(MYSPACE: 'OBJA0110': '*CURRENT': '*ALL': '*OBJOWN':
*BLANKS: dsEC);
QUSPTRUS(MYSPACE: p_UsrSpc);
//
// Populate an array of pointers, each pointer pointing
// to a user space entry.
//
size = %size(p_OO) * dsLH.NumEntries;
p_SortList = %alloc(size);
p_OO = p_UsrSpc + dsLH.ListOffset;
for x = 1 to dsLH.NumEntries;
SortList(x) = p_OO;
p_OO = p_UsrSpc + (dsOO.PathOffset + dsOO.PathLen);
endfor;
//
// sort the array. The interesting part about this sort is
// in the COMPARE procedure below.
//
qsort(p_SortList: dsLH.NumEntries: %size(p_OO):
%paddr('COMPARE'));
//
// display the sorted array
//
for x = 1 to dsLH.NumEntries;
p_OO = SortList(x);
p_Path = p_UsrSpc + dsOO.PathOffset;
msg = %subst(dsPath.Name: 1: dsPath.Len);
dsply msg;
endfor;
dealloc p_SortList;
QUSDLTUS(MYSPACE: dsEC);
*inlr = *on;
/end-free
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
* qsort() calls this routine to tell when one entry is
* greater or less than another.
*
* FIXME: Comparison is only done on the first 32k of the
* Pathname. To work with larger pathnames, this
* could be changed to use memcmp().
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
P Compare B export
D Compare PI 10I 0
d p_Ent1 *
d p_Ent2 *
D Ent1 ds likeds(dsOO) based(p_Ent1)
D Ent2 ds likeds(dsOO) based(p_Ent2)
D p_Path1 s *
D Path1 ds likeds(dsPath) based(p_Path1)
D p_Path2 s *
D Path2 ds likeds(dsPath) based(p_Path2)
/free
p_path1 = p_UsrSpc + Ent1.PathOffset;
p_Path2 = p_UsrSpc + Ent2.PathOffset;
if %subst(Path1.Name: 1: Path1.Len)
< %subst(Path2.Name: 1: Path2.Len);
return -1;
elseif %subst(Path1.Name: 1: Path1.Len)
> %subst(Path2.Name: 1: Path2.Len);
return 1;
else;
return 0;
endif;
/end-free
P E
--
This is the RPG programming on IBM i (RPG400-L) mailing list
To post a message email: RPG400-L@xxxxxxxxxxxxxxxxxx
To subscribe, unsubscribe, or change list options,
visit: https://lists.midrange.com/mailman/listinfo/rpg400-l
or email: RPG400-L-request@xxxxxxxxxxxxxxxxxx
Before posting, please take a moment to review the archives
at https://archive.midrange.com/rpg400-l.
Please contact support@xxxxxxxxxxxxxxxxxxxx for any subscription related questions.
Help support midrange.com by shopping at amazon.com with our affiliate link: https://amazon.midrange.com
As an Amazon Associate we earn from qualifying purchases.
This mailing list archive is Copyright 1997-2024 by midrange.com and David Gibbs as a compilation work. Use of the archive is restricted to research of a business or technical nature. Any other uses are prohibited. Full details are available on our policy page. If you have questions about this, please contact [javascript protected email address].
Operating expenses for this site are earned using the Amazon Associate program and Google Adsense.
midrange.com
