$CONTROL USLINIT,CODE,MAP,SOURCE                                        00010000
<< udc -- module 82 >>                                                  00015000
<< hp32002c mpe source c.00.00 >>                                       00020000
$copyright     "(C) COPYRIGHT HEWLETT-PACKARD CO. 1980. ",            & 00025000
$     "THIS PROGRAM MAY BE USED WITH ONE COMPUTER SYSTEM AT A ",      & 00030000
$     "TIME AND SHALL NOT OTHERWISE BE RECORDED, TRANSMITTED OR ",    & 00035000
$     "STORED IN A RETRIEVAL SYSTEM.  COPYING OR OTHER REPRODUCTION ",& 00040000
$     "OF THIS PROGRAM EXCEPT FOR ARCHIVAL PURPOSES IS PROHIBITED ",  & 00045000
$     "WITHOUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY."   00050000
$control segment=udc,main=user'def'cmds                                 00055000
begin                                                                   00060000
equate                                                                  00065000
   ccg           = 0,                                                   00070000
   ccl           = 1,                                                   00075000
   cce           = 2;                                                   00080000
                                                                        00085000
integer                                                                 00090000
   status = q-1,                                                        00095000
   s0 =s-0,                                                             00100000
   x = x;                                                               00105000
                                                                        00110000
byte pointer bps0 = s-0;                                                00115000
pointer ps0 = s-0;                                                      00120000
double pointer dps0 = s-0;                                              00125000
array db2(*)=db+2;                                             <<00416>>00130000
                                                                        00135000
define                                                                  00140000
   executorhead =                                              <<00884>>00145000
      (parmsp,errnum,parmnum);                                 <<00884>>00150000
      byte array parmsp;                                       <<00884>>00155000
      integer errnum,parmnum #,                                <<00884>>00160000
   noerrors =  (errnum <= 0) #,                                <<00884>>00165000
   condcode      = status.(6:2)#,                                       00170000
   ccgretn       = begin                                                00175000
                      condcode := ccg;                                  00180000
                      go outl;                                          00185000
                   end#,                                                00190000
   cclretn            = begin                                           00195000
                      condcode := ccl;                                  00200000
                      go outl;                                          00205000
                   end#,                                                00210000
   def'movefromdseg   =                                                 00215000
      movefromdseg(target,dstn,offset,count);                           00220000
         value target,dstn,offset,count;                                00225000
         logical target,dstn,offset,count;                              00230000
      begin                                                             00235000
         x :          = tos; << save return address >>                  00240000
         assemble(mfds 0);                                              00245000
         tos :        = x; << restore return address >>                 00250000
      end #,                                                            00255000
                                                                        00260000
   def'movetodseg     =                                                 00265000
      movetodseg(dstn,offset,source,count);                             00270000
         value dstn,offset,source,count;                                00275000
         logical dstn,offset,source,count;                              00280000
      begin                                                             00285000
         x :          = tos;                                            00290000
         assemble(mtds 0);                                              00295000
         tos :        = x;                                              00300000
      end #;                                                            00305000
$include inclpxg                                               <<06601>>00310000
$include inclcap                                               <<06601>>00315000
                                                                        00320000
$include inclcis                                               <<04603>>00325000
logical udcdstno = cis'udc0;                                   <<04603>>00330000
define                                                         <<04603>>00335000
   udctype'               = (6:2)#;                            <<04603>>00340000
equate                                                         <<00416>>00345000
   dircread = 1,                                               <<00884>>00350000
   dircwrite = 2,                                              <<00884>>00355000
   udctype'user=0,                                             <<00416>>00360000
   udctype'account=1,                                          <<00416>>00365000
   udctype'system=2,                                           <<00416>>00370000
   udctype'numlevels     = 3,  << user, account, & system >>   <<04651>>00375000
   getuserentry=%630,        <<direcscan for user entry>>      <<00416>>00380000
   getacctentry=%420,        <<direcscan for acct entry>>      <<00416>>00385000
   sysglobudcflag=%1376,     <<system udc's exist flag>>       <<00416>>00390000
   userudcptr  = 18,                                           <<00884>>00395000
   acctudcptr  = 28,                                           <<00884>>00400000
   sysudcptr   = 29,                                           <<00884>>00405000
   umaxjob=17,               <<udc exist bit in user entry>>   <<00416>>00410000
   amaxjob=27;               <<udc exist bits in acct entry>>  <<00416>>00415000
                                                               <<00416>>00420000
define                                                         <<00416>>00425000
   userudcbit=umaxjob).(1:1#,<<user udc bit>>                  <<00416>>00430000
   acctudcbit=amaxjob).(1:1#,<<acct udc bit>>                  <<00416>>00435000
   sysudcbit=amaxjob).(0:1#; <<system udc bit>>                <<00416>>00440000
                                                                        00445000
                                                                        00450000
equate                                                                  00455000
   cr                    = %15,                                         00460000
   disablebreak          = 14,                                          00465000
   enablebreak           = 15,                                          00470000
   noudcglobalsm1        = 4,  << there are 5 global cells>>            00475000
                                                                        00480000
                                                                        00485000
   fsysset               = 8,                                           00490000
   ciset                 = 2,                                           00495000
   setseven              = 7,                                  << 8156>>00500000
   udcmaxparms           = 16,                                          00505000
   maxscparms            = 50,                                 <<01510>>00510000
   maxscparmsm1          = maxscparms - 1,                     <<01510>>00515000
   pinfosize             = udcmaxparms*3 -1,                            00520000
                                                                        00525000
   buffsize              = 72,                                          00530000
   buffsizew             = 36,                                          00535000
   dirsizem1             = 2047,                               <<01314>>00540000
   dirsizeb              = 4096,                               <<01314>>00545000
   dirhead               = 1,                                           00550000
   dirheadsize           = 4,                                           00555000
   dirheadsizeb          = dirheadsize*2,                               00560000
   dirmaxcmdsize         = 16,                                          00565000
   dirmaxentrysize       = dirmaxcmdsize/2 +dirheadsize,                00570000
   direntrysize          = 1,                                           00575000
   dirrecno              = 1,                                           00580000
   dirbodyrecno          = 2,                                           00585000
   dirfileno             = 6,                                           00590000
   dircmdlen             = 7,                                           00595000
   dircmd                = 8,                                           00600000
                                                                        00605000
   udcbuffsize           = 40*4,                               <<05021>>00610000
   udcrecsize            = 40,                                          00615000
   udcrecsizeb           = udcrecsize*2,                                00620000
   termsize              = 72,                                          00625000
   termsizewm1           = termsize/2 -1,                               00630000
   udcinitstacksize      = %5000, << guess at stack size >>             00635000
                                                                        00640000
   << command.pub.sys >>                                                00645000
                                                                        00650000
   comfreehead           = 0,                                           00655000
   commaxuse             = 2,                                           00660000
   comuse                = 3,                                           00665000
   comlink               = 0,                                           00670000
   comentrytype          = 1,                                           00675000
   comuname              = 4,                                           00680000
   comaname              = 12,                                          00685000
   comfname              = 4,                                           00690000
   comfreeentry          = 0,                                           00695000
   comuserentry          = 1,                                           00700000
   comfileentry          = 2,                                           00705000
   comrecsize            = 20,                                          00710000
   comrecsizem1          = comrecsize -1,                               00715000
                                                                        00720000
      << errors >>                                                      00725000
                                                                        00730000
      << 1901-1909 initudc errors                     >>                00735000
      << 1910-1929 file errors                      >>                  00740000
      << 1930-1939 setcatalog,showcatalog,help      >>                  00745000
      << 1940-1959 errors in udc head, body & image >>                  00750000
      << 1970-1977 initudc warnings              >>            <<04631>>00755000
                                                                        00760000
      << error types for error procedure >>                             00765000
                                                                        00770000
   ferr                  = 0,                                           00775000
   udcerr                = 1,                                           00780000
   synerr                = 2,                                           00785000
   synerrnol             = 3,                                           00790000
   udcferr               = 4,                                           00795000
   imagerr               = 5,                                           00800000
                                                                        00805000
      << eof indicator >>                                               00810000
                                                                        00815000
   eofound               = 5,                                  <<00884>>00820000
   nosuchcomuser         = 1904, << user not in command file >><<00884>>00825000
                                                                        00830000
      << errors in initudc (:setcatalog or logon) >>                    00835000
                                                                        00840000
   ampersanderr          = 1905, << cont. at end of file >>             00845000
   cmdnotalpha           = 1906,                                        00850000
   stackoverflow         = 1907,                                        00855000
   getdatasegerr         = 1908,                                        00860000
   toomanycmdsfordir     = 1909,                                        00865000
                                                                        00870000
      << errors in  command.pub.sys >>                                  00875000
                                                                        00880000
   comopenfail           = 1910,                                        00885000
   comeof                = 1911,                                        00890000
   comlockfail           = 1912,                                        00895000
   comunlockfail         = 1913,                                        00900000
   comreadfail           = 1914,                                        00905000
   comwritefail          = 1915,                                        00910000
                                                               <<04846>>00915000
   << errors in handling udc files in setcatalog. >>           <<04846>>00920000
 lockworderr           = 1916, << couldn't find lockword. >>   <<04846>>00925000
                                                               <<04846>>00930000
                                                                        00935000
      << errors in 'showcatalog' >>                                     00940000
                                                                        00945000
   showcatlistopenf      = 1921,                                        00950000
   showcatlistwritef     = 1922,                                        00955000
                                                                        00960000
      << errors in udc file >>                                          00965000
   udcopenfail           = 1923,                                        00970000
   udcreadfail           = 1924,                                        00975000
   udcifs'neq'endifs     = 1925,                               <<00835>>00980000
   udcempty              = 1926,                               <<01306>>00985000
                                                                        00990000
      << info messges & headers >>                                      00995000
                                                                        01000000
   udchelphead           = 1930,                                        01005000
   nocatalogs            = 1931, <<:showcatalog>>                       01010000
   usedlistfile          = 1932, <<:showcatalog>>                       01015000
                                                                        01020000
      << ci error numbers (setcatalog & showcatalog) >>                 01025000
                                                                        01030000
   expectlistfile        = 1933, <<:showcatalog>>              <<00884>>01035000
   nobackorsys           = 1934, <<:setcatalog>>               <<00884>>01040000
   uknkeyword            = 1935, <<:setcatalog>>               <<00884>>01045000
   setcat2mparms         = 1936, <<:setcatalog>>               <<00884>>01050000
   needsmcap             = 1937, <<:setcatalog>>               <<00884>>01055000
   needamcap             = 1938, <<:setcatalog>>               <<00884>>01060000
   nobothsysacc          = 1939, <<:setcatalog>>               <<00884>>01065000
                                                                        01070000
      << errors in parsing udc head & udc image >>                      01075000
                                                                        01080000
   toomanyrec            = 1940,                                        01085000
   parmnotalpha          = 1941,                                        01090000
   toomanyparms          = 1942,                                        01095000
   missingdefault        = 1943,                                        01100000
   noclosequote          = 1944,                                        01105000
   invdelim              = 1945,                                        01110000
   excessparms           = 1946,                                        01115000
   unknownparm           = 1947,                                        01120000
   missingparm           = 1948,                                        01125000
   toolong               = 1949,                                        01130000
   expectparm            = 1950,                                        01135000
   ignored               = 1952,                                        01140000
   fmlnamenotalpha       = 1953, << 1st char. not alpha >>              01145000
   invformalname         = 1954, << special char. in name >>            01150000
    cmdtoolong            = 1951, << udc name too long >>      <<01023>>01155000
   notypemix             = 1955, << no keyword and positio-  >><<01049>>01160000
                                  <<nal in same udc command  >><<01049>>01165000
   unknownoption         = 1956, << unknown option keyword >>  <<01529>>01170000
   ign'userlevel         = 1927, << user udc level ignored >>  <<06034>>01175000
   ign'acctlevel         = 1928, << account udcs ignored   >>  <<06034>>01180000
   ign'syslevel          = 1929, << system udcs ignored    >>  <<06034>>01185000
                                                                        01190000
                                                                        01195000
   initudcfailed         = 1960, <<used in setcatalog. no msg>><<00884>>01200000
   udc'flushed           = 1961, << used in feedci.  no msg. >><<01288>>01205000
                                                               <<04631>>01210000
      << initudc warnings >>                                   <<04631>>01215000
                                                               <<04631>>01220000
   listwarn              =1970,                                <<04631>>01225000
   logonwarn             =1971,                                <<04631>>01230000
   nohelpwarn            =1972,                                <<04631>>01235000
   nobreakwarn           =1973,                                <<04631>>01240000
   nolistwarn            =1974,                                <<04631>>01245000
   nologonwarn           =1975,                                <<04631>>01250000
   helpwarn              =1976,                                <<04631>>01255000
   breakwarn             =1977,                                <<04631>>01260000
                                                               << 8156>>01265000
    << errors in :setcatalog ...; user= specification. >>      << 8156>>01270000
   userwantseqs          = 1980,                               << 8156>>01275000
   exptuserspec          = 1981,                               << 8156>>01280000
   baduserspec           = 1982,                               << 8156>>01285000
   needsmcap2            = 1983,                               << 8156>>01290000
   needamcap2            = 1984,                               << 8156>>01295000
   nouserandother        = 1985,                               << 8156>>01300000
                                                               << 8156>>01305000
<< messages used by :showcatalog ;user= >>                     << 8156>>01310000
   badshowsyn            = 1990,                               << 8156>>01315000
   badshowuserspec       = 1991,                               << 8156>>01320000
   showuserdotat         = 1992,                               << 8156>>01325000
   toomanyshowparms      = 1993,                               << 8156>>01330000
   showcomopenfail       = 1994,                               << 8156>>01335000
   showneedssm           = 1995,                               << 8156>>01340000
   showneedsam           = 1996,                               << 8156>>01345000
                                                               << 8156>>01350000
   showsysudcfs          = 150,   << from $set 7. >>           << 8156>>01355000
   nosysudcfs            = 151,                                << 8156>>01360000
   showacctudcfs         = 152,                                << 8156>>01365000
   noacctudcfs           = 153,                                << 8156>>01370000
   showuserudcfs         = 154,                                << 8156>>01375000
   nouserudcfs           = 155,                                << 8156>>01380000
                                                               << 8156>>01385000
   endofequates          = 0;                                  <<00884>>01390000
                                                                        01395000
intrinsic fopen,fcheck,fread,freaddir,fpoint,read,print,debug,          01400000
   fcontrol,search,zsize,fwrite,                                        01405000
   fgetinfo,fclose,funlock,flock,fwritedir,fspace,who;                  01410000
                                                                        01415000
procedure cierr(errnum,erradr,parmask,parm);                            01420000
   value errnum,parmask,parm;                                           01425000
   integer errnum,parmask,parm;                                         01430000
   byte array erradr;                                                   01435000
   option variable,external;                                            01440000
                                                                        01445000
integer procedure deblank(buff,width);                                  01450000
   value width; integer width;                                          01455000
   byte array buff; option external;                                    01460000
                                                                        01465000
double procedure direcscan(type,linkage,aname,guname,                   01470000
      fname,recip,parms,mvtabx);                                        01475000
   value type,linkage,mvtabx;                                           01480000
   integer type,mvtabx;                                                 01485000
   double linkage;                                                      01490000
   array aname,guname,fname,parms;                                      01495000
   integer procedure recip;                                             01500000
   option external,variable;                                            01505000
                                                                        01510000
procedure ferror'(fnum,parmnum);                               <<00884>>01515000
   value fnum;  integer fnum,parmnum;                          <<00884>>01520000
   option external;                                            <<00884>>01525000
                                                               <<00884>>01530000
integer procedure findparm(string,parmptr,delptr);                      01535000
   byte array string; byte pointer parmptr,delptr;                      01540000
   option variable,external;                                            01545000
                                                                        01550000
integer procedure formname(type,target,ba1,ba2,ba3,ba4);                01555000
   value type;byte array target,ba1,ba2,ba3,ba4;                        01560000
   integer type;option external;                                        01565000
                                                                        01570000
integer procedure genmsg(a,b,c,d,e,f,g,h,i,j,k,l,m);                    01575000
   value a,b,c,d,e,f,g,h,i,j,k,l,m;                                     01580000
   logical a,b,c,d,e,f,g,h,i,j,k,l,m;                                   01585000
   option variable,external;                                            01590000
                                                                        01595000
integer procedure getdataseg(memsize,vdsize);                           01600000
   value memsize,vdsize;integer memsize,vdsize;                         01605000
   option external;                                                     01610000
                                                                        01615000
integer procedure mycommand                                    <<00884>>01620000
   (comimage,delims,maxparms,numparms,parms,dict,defn);        <<00884>>01625000
   value maxparms;                                             <<00884>>01630000
   byte array comimage,delims,dict;                            <<00884>>01635000
   integer maxparms,numparms;                                  <<00884>>01640000
   double array parms;                                         <<00884>>01645000
   byte pointer defn;                                          <<00884>>01650000
   option variable,external;                                   <<00884>>01655000
                                                               <<00884>>01660000
integer procedure nextparm(string,parmptr,delptr);                      01665000
   byte array string; byte pointer parmptr,delptr;                      01670000
   option variable,external;                                            01675000
                                                                        01680000
                                                                        01685000
   << fopen entry point >>                                              01690000
integer procedure pvopen(fd,fo,ao,r,d,fm,u,b,n,fs,ne,i,fc);             01695000
   value fo,ao,r,u,b,n,fs,ne,i,fc;                                      01700000
   byte array fd,d,fm;                                                  01705000
   logical fo,ao;                                                       01710000
   integer r,u,b,n,ne,i,fc;                                             01715000
   double fs;                                                           01720000
   option variable,external;                                            01725000
                                                                        01730000
procedure qualifyfilename(oldfname,newfname);                           01735000
   byte array oldfname,newfname;                                        01740000
   option external;                                                     01745000
                                                                        01750000
procedure reldataseg(en);value en;integer en;                           01755000
   option external;                                                     01760000
                                                                        01765000
                                                               <<04810>>01770000
logical procedure setcritical;                                 <<04810>>01775000
option external;                                               <<04810>>01780000
                                                               <<04810>>01785000
procedure resetcritical( parm );                               <<04810>>01790000
   value parm;  logical parm;                                  <<04810>>01795000
option external;                                               <<04810>>01800000
                                                               <<04810>>01805000
logical procedure requestservice; option external;                      01810000
                                                                        01815000
procedure setservice(disp); value disp;logical disp;                    01820000
   option external;                                                     01825000
procedure suddendeath(number);                                 <<00863>>01830000
   value number; integer number;                               <<00863>>01835000
   option external;                                            <<00863>>01840000
                                                               <<04846>>01845000
integer procedure fgetlockword( fnum, lockword, len );         <<04846>>01850000
   value fnum;                                                 <<04846>>01855000
   integer fnum, len;                                          <<04846>>01860000
   byte array lockword;                                        <<04846>>01865000
option external;                                               <<04846>>01870000
                                                                        01875000
   << commandinterp entry point >>                                      01880000
procedure udcci(comlen);                                                01885000
   value comlen;                                                        01890000
   integer comlen;                                                      01895000
   option external;                                                     01900000
                                                                        01905000
   << option forwards >>                                                01910000
integer procedure checkfilename'(a,b,c,d);                     <<00226>>01915000
value a;                                                       <<00226>>01920000
double a;                                                      <<00226>>01925000
logical b,c,d;                                                 <<00226>>01930000
option external;                                               <<00226>>01935000
                                                                        01940000
                                                                        01945000
                                                                        01950000
procedure error(errno,type,eptr,baseptr);                               01955000
   value errno,type,eptr,baseptr; integer errno,type;                   01960000
   byte pointer eptr,baseptr; option variable,forward;                  01965000
                                                                        01970000
integer procedure getcomrec(comfn,errno);                               01975000
   value comfn; integer comfn,errno;                                    01980000
   option forward;                                                      01985000
                                                                        01990000
procedure findcomuser(comfn,uname,aname,udcs,urec,frec,errno); <<00884>>01995000
   value comfn;  byte array uname,aname; logical udcs;         <<00884>>02000000
   integer comfn,urec,frec,errno; option forward;              <<00884>>02005000
                                                                        02010000
procedure initudcno( show, setcatcomfn );                      <<03734>>02015000
   value   show, setcatcomfn;                                  <<03734>>02020000
   logical show;                                               <<03734>>02025000
   integer setcatcomfn;                                        <<03734>>02030000
   option variable, forward;                                   <<03734>>02035000
                                                                        02040000
integer procedure optiono(string); value string;                        02045000
   byte pointer string; option forward;                                 02050000
                                                                        02055000
integer procedure recipudc(ntry,level,inx,sirs);                        02060000
   value level,inx,sirs;                                                02065000
   integer level,inx;                                                   02070000
   double sirs;array ntry; option forward;                              02075000
                                                                        02080000
procedure readfile(fn,recno,buff',errno);                               02085000
   value fn;integer fn,recno,errno;array buff';                         02090000
   option forward;                                                      02095000
                                                                        02100000
procedure relcomrec(comfn,recno,errno);                                 02105000
   value comfn,recno; integer comfn,recno,errno;                        02110000
   option forward;                                                      02115000
                                                                        02120000
procedure searchcomfile(comfn,uname,aname,urec,frec,errno);    <<00884>>02125000
   value comfn;  byte array uname,aname;                       <<00884>>02130000
   integer comfn,urec,frec,errno;                              <<00884>>02135000
   option variable,forward;                                    <<00884>>02140000
                                                               <<00884>>02145000
logical procedure searchudc(string,offset,udcfn,                        02150000
      recno,bodyrecno,options);                                         02155000
   integer offset,udcfn,recno,bodyrecno;                                02160000
   logical options;                                                     02165000
   byte array string; option forward;                                   02170000
                                                                        02175000
logical procedure udc(comimage,offset);                                 02180000
   value offset; integer offset;                                        02185000
   byte array comimage; option forward;                                 02190000
                                                                        02195000
procedure udcdircwrite(uname,aname,udcsexist,recno);           <<00884>>02200000
   logical udcsexist;                                          <<00884>>02205000
   integer recno;                                              <<00884>>02210000
   byte array uname,aname;                                     <<00884>>02215000
   option forward;                                             <<00884>>02220000
                                                               <<00884>>02225000
procedure udcdircread(uname,aname,udcsexist,recno);            <<00884>>02230000
   logical udcsexist;                                          <<00884>>02235000
   integer recno;                                              <<00884>>02240000
   byte array uname,aname;                                     <<00884>>02245000
   option forward;                                             <<00884>>02250000
                                                               <<00884>>02255000
logical procedure udchelp(comimage);                                    02260000
   value comimage;                                                      02265000
   byte pointer comimage;                                               02270000
   option forward;                                                      02275000
                                                                        02280000
procedure upshift(ptr); value ptr; byte pointer ptr;                    02285000
   option forward;                                                      02290000
                                                                        02295000
                                                                        02300000
$title "CLOSEUDC"                                                       02305000
procedure closeudc(dstno);                                     <<00884>>02310000
   value dstno;  integer dstno;                                <<00884>>02315000
   option uncallable;                                                   02320000
begin                                                                   02325000
                                                                        02330000
integer                                                                 02335000
   offset,                                                              02340000
   fileno,                                                              02345000
   prevfileno,                                                 <<00884>>02350000
   length;                                                              02355000
array dir'(0:dirheadsize); byte array dir(*) = dir';                    02360000
                                                                        02365000
subroutine def'movefromdseg;                                            02370000
                                                                        02375000
offset := prevfileno := 0;                                     <<00884>>02380000
do begin                                                                02385000
   movefromdseg(@dir',dstno,offset,dirheadsize);               <<00884>>02390000
   fileno := dir(dirfileno);                                            02395000
   length := dir(direntrysize);                                         02400000
   if fileno <> prevfileno then                                <<00884>>02405000
      begin                                                    <<00884>>02410000
      fclose(fileno,0,0);                                      <<00884>>02415000
      prevfileno := fileno;                                    <<00884>>02420000
      end;                                                     <<00884>>02425000
   offset := offset + length;                                  <<00884>>02430000
end until length = 0;                                                   02435000
                                                                        02440000
end; << closeudc >>                                                     02445000
$title "CXSETCATALOG"                                          <<00884>>02450000
procedure cxsetcatalog executorhead;                           <<00884>>02455000
   option uncallable;                                          <<00884>>02460000
comment                                                        <<00884>>02465000
   command executor for the setcatalog command.                <<00884>>02470000
   syntax:                                                     <<00884>>02475000
;                                                              <<00884>>02480000
<< the syntax for this command is as follows:              >>  << 8156>>02485000
<<                                                         >>  << 8156>>02490000
<<  :setcatalog [udcfile[,udcfile...]][;account]           >>  << 8156>>02495000
<<                                    [;system]            >>  << 8156>>02500000
<<                                    [;user=user[.acct]]  >>  << 8156>>02505000
<<                                                         >>  << 8156>>02510000
<< only one keyword can be specified in any invocation.    >>  << 8156>>02515000
                                                               <<00884>>02520000
comment                                                        <<00884>>02525000
   this command activates the user defined commands (udc's) in <<00884>>02530000
   the specified udc files. the udc's can be made to apply to t<<00884>>02535000
   user, account, or system depending on the optional paramters<<00884>>02540000
   chosen. the show parameter causes the udc file names and    <<00884>>02545000
   user defined commands to be listed as they are initialized. <<00884>>02550000
   if no udc files are specified then any existing udc's are   <<00884>>02555000
   deactivated at the specified level (user, account, or       <<00884>>02560000
   system).                                                    <<00884>>02565000
                                                               <<00884>>02570000
   execution strategy:                                         <<00884>>02575000
      1) check syntax.                                         <<00884>>02580000
            any file names are passed through checkfilename'.  <<00884>>02585000
            backreferenced and system defined files (except    <<00884>>02590000
            $null) are rejected. extra parameters are parsed   <<00884>>02595000
            and capability checks are made for the use of the  <<00884>>02600000
            account and system parameters.                     <<00884>>02605000
      2) save current udc information.                         <<00884>>02610000
            the udc dst number is saved. the udc directory     <<00884>>02615000
            command.pub.sys is searched to locate udc files    <<00884>>02620000
            for this udc level.                                <<00884>>02625000
      3) enter new udc file names into udc directory.          <<00884>>02630000
            file names are added as a linked list. a user and  <<00884>>02635000
            account entry is added pointing to the file names. <<00884>>02640000
      4) initialize new udc's.                                 <<00884>>02645000
            the location of the file names is written into the <<00884>>02650000
            system directory. initudc is called to activate    <<00884>>02655000
            the new udc's.                                     <<00884>>02660000
      5) deactivate old udc's.                                 <<00884>>02665000
            old udc files are closed. old udc extra data segmen<<00884>>02670000
            is released. old file names in command.pub.sys are <<00884>>02675000
            released.                                          <<00884>>02680000
                                                               <<03734>>02685000
                                                               <<03734>>02690000
   fix information:                                            <<03734>>02695000
                                                               <<03734>>02700000
      * it was discovered that the flocking and funlocking of  <<03734>>02705000
        command.pub.sys was not sufficient to prevent windows  <<03734>>02710000
        in which simultaneous :setcatalogs or concurrent       <<03734>>02715000
        :setcatalogs and logons from causing corruption of the <<03734>>02720000
        command.pub.sys file.  this fix keeps command.pub.sys  <<03734>>02725000
        locked as long as it is opened by either cxsetcatalog  <<03734>>02730000
        or initudc (for logon).  note, however, that the       <<03734>>02735000
        procedures relcomrec and getcomrec now expect the      <<03734>>02740000
        comfn file to be locked by the calling procedure:      <<03734>>02745000
        they no longer do any locking/unlocking.  these two    <<03734>>02750000
        procedures could be called from the ci when a          <<03734>>02755000
        :purge{user/acct} is being executed.  also note that   <<03734>>02760000
        the externals for initudc (specifically initudcno)     <<03734>>02765000
        have been changed to allow cxsetcatalog to pass the    <<03734>>02770000
        file number of the opened and locked command.pub.sys.  <<03734>>02775000
                                                               <<03734>>02780000
                                                               <<03767>>02785000
      * fix number 3734 introduced another bug.  before that   <<03767>>02790000
        fix, initudc would fclose command.pub.sys after any    <<03767>>02795000
        logon udc was executed.  fix 3734 used that fclose to  <<03767>>02800000
        also funlock command.pub.sys--the result of this was   <<03767>>02805000
        that command.pub.sys would stay locked while any job   <<03767>>02810000
        or session was executing a logon udc.  this meant that <<03767>>02815000
        other jobs would not logon.  this was fixed by moving  <<03767>>02820000
        the fclose to before the logon udc execution.          <<03767>>02825000
                                                               <<03767>>02830000
      * when a udc file has a lockword on it, a user could     <<04846>>02835000
        have rejected the use of that udc file by supplying a  <<04846>>02840000
        bad lockword when prompted for it at logon--this may   <<04846>>02845000
        not be acceptable for account or system udcs.  this    <<04846>>02850000
        fix will always append the lockword into the command   <<04846>>02855000
        entry.  note that command.pub.sys is opened with       <<04846>>02860000
        execute access, thus users can be prevented from       <<04846>>02865000
        viewing the udc lockwords in command.                  <<04846>>02870000
                                                               << 8156>>02875000
      * this change extends :setcatalog so that a user can     << 8156>>02880000
        have the ability to :setcatalog another user's udcs.   << 8156>>02885000
        this is performed by using the new :user= keyword.     << 8156>>02890000
        note the security checks:  a user with am capability   << 8156>>02895000
        can :setcatalog for any user in his/her account, and   << 8156>>02900000
        a user with sm capability can :setcatalog for any      << 8156>>02905000
        user on the system.  also note that initudc is not     << 8156>>02910000
        called if the :user= keyword is used.  this means a    << 8156>>02915000
        user can :setcatalog for himself and have the udcs     << 8156>>02920000
        take effect only when that user next logs on.          << 8156>>02925000
                                                               << 8156>>02930000
      * this change introduces the :user= keyword to           << 8156>>02935000
        :setcatalog.  this allows a more general interface     << 8156>>02940000
        for the setting up of user udcs.                       << 8156>>02945000
                                                               << 8156>>02950000
   ;                                                           <<00884>>02955000
                                                               <<00884>>02960000
begin                                                          <<00884>>02965000
define                                                         <<00884>>02970000
   parmaddr  = iparms(2*parmnum) #,                            <<00884>>02975000
   parmlen   = iparms(2*parmnum+1).(0:8) #,                    <<00884>>02980000
   nextdelim = iparms(2*parmnum+1).(11:5) #,                   <<00884>>02985000
   delimsdef = [8/",",8/";",8/"=",8/%15]d #;                   << 8156>>02990000
                                                               <<00884>>02995000
equate                                                         <<00884>>03000000
   maxparms   = maxscparms,                                    <<01510>>03005000
   comma      = 0,                                             <<00884>>03010000
   semicolon  = 1,                                             <<00884>>03015000
   equals     = 2,                                             << 8156>>03020000
   cr         = 3;                                             << 8156>>03025000
                                                               <<00884>>03030000
logical                                                        <<00884>>03035000
   dmy,                                                        <<00884>>03040000
   userspecd,     << true if user keyword used. >>             << 8156>>03045000
   show,          << true => 'show' parm specified >>          <<00884>>03050000
   account,       << true => 'account' parm specified >>       <<00884>>03055000
   system,        << true => 'system' parm specified >>        <<00884>>03060000
   newudcfiles,   << true => new udc file(s) specified >>      <<00884>>03065000
   udcsexist,     << used for updating directory >>            <<00884>>03070000
   oldudcsexist,  << true => udc's currently exist(this level)><<00884>>03075000
   oldcrit,       << from setcritical.             >>          <<04810>>03080000
   unlockok,      << able to unlock command.pub.sys.  >>       <<04810>>03085000
   olddstno;      << current udc extra dst no. >>              <<00884>>03090000
                                                               <<00884>>03095000
integer                                                        <<00884>>03100000
   i,             << index variable.                    >>     << 8156>>03105000
   nil := 0,      << used for updating directory >>            <<00884>>03110000
   numparms,      << number of parameters specified >>         <<00884>>03115000
   lastfileparm,  << parms index of last udc file >>           <<00884>>03120000
   errno,         << error return value >>                     <<00884>>03125000
   release'err,   << error return value >>                     <<00884>>03130000
   recno,         << used for entering  file names >>          <<00884>>03135000
   oldrecno,      << location in comfile of current udc files ><<00884>>03140000
   comfn;         << command file number >>                    <<00884>>03145000
                                                               <<00884>>03150000
byte pointer                                                   <<00884>>03155000
   parmptr;                                                    <<00884>>03160000
                                                               <<00884>>03165000
double                                                         <<00884>>03170000
   delims := delimsdef;                                        << 8156>>03175000
                                                               <<00884>>03180000
double array                                                   <<00884>>03185000
   parms(0:maxparms-1);                                        <<00884>>03190000
                                                               <<00884>>03195000
array                                                          <<00884>>03200000
   iparms(*) = parms,                                          <<00884>>03205000
   rec'(0:comrecsizem1);                                       <<00884>>03210000
                                                               << 8156>>03215000
<< the following declarations are used for the second      >>  << 8156>>03220000
<< call to mycommand used to parse the subparameters for   >>  << 8156>>03225000
<< the "USER=" keyword.                                    >>  << 8156>>03230000
   equate                                                      << 8156>>03235000
      maxuserspecparms   = 3;                                  << 8156>>03240000
                                                               << 8156>>03245000
   byte array                                                  << 8156>>03250000
      userdelims(0:5);                                         << 8156>>03255000
                                                               << 8156>>03260000
   integer                                                     << 8156>>03265000
      numuserspecparms   := 0;                                 << 8156>>03270000
                                                               << 8156>>03275000
   double array                                                << 8156>>03280000
      userparms(0:maxuserspecparms);                           << 8156>>03285000
                                                               << 8156>>03290000
   integer array                                               << 8156>>03295000
      iuserparms(*) = userparms;                               << 8156>>03300000
                                                               << 8156>>03305000
   define                                                      << 8156>>03310000
      userp1addr        = iuserparms #,                        << 8156>>03315000
      userp1len         = iuserparms(1).(0:8) #,               << 8156>>03320000
      specialsinp1      = ( iuserparms(1).(10:1) = 1 ) #,      << 8156>>03325000
      userp1delimdot    = ( iuserparms(1).(11:5) = 0 ) #,      << 8156>>03330000
      badp1delim        = ( ( iuserparms(1).(11:5) = 1 )       << 8156>>03335000
                            lor                                << 8156>>03340000
                            ( iuserparms(1).(11:5) = 3 ) )#,   << 8156>>03345000
      userp2addr        = iuserparms(2) #,                     << 8156>>03350000
      userp2len         = iuserparms(3).(0:8) #,               << 8156>>03355000
      specialsinp2      = ( iuserparms(3).(10:1) = 1 ) #;      << 8156>>03360000
                                                               << 8156>>03365000
byte array                                                     <<00884>>03370000
   rec(*) = rec',                                              <<00884>>03375000
   lockword(0:7),        << holds udc file lockword, if any >> <<04846>>03380000
   usname(0:7),     << user name specified by user >>          << 8156>>03385000
   asname(0:7),     << account name specified by user >>       << 8156>>03390000
   uname(0:7),                                                 <<00884>>03395000
   aname(0:7);                                                 <<00884>>03400000
                                                               <<06601>>03405000
array qarray(*) = q + 0;                                       <<06601>>03410000
integer pcbglobloc;                                            <<06601>>03415000
pointer ucapptr;                                               <<06601>>03420000
                                                               <<00884>>03425000
byte array             << add new parameters here >>           <<00884>>03430000
   pkeylist(0:1) = pb :=                                       <<00884>>03435000
      6,4,"SHOW",                                              <<00884>>03440000
      9,7,"ACCOUNT",                                           <<00884>>03445000
      8,6,"SYSTEM",                                            <<00884>>03450000
      6,4,"USER",                                              << 8156>>03455000
      0;                                                       <<00884>>03460000
equate pkeylistlen = 30;                                       << 8156>>03465000
byte array keylist(0:pkeylistlen-1);                           <<00884>>03470000
                                                               <<00884>>03475000
<<***********************************************************>><<00884>>03480000
<<  comfile'err                                              >><<00884>>03485000
<<    gets file system error number.                         >><<00884>>03490000
<<    closes command file.                                   >><<00884>>03495000
<<    calls cierr setting errnum.                            >><<00884>>03500000
<<***********************************************************>><<00884>>03505000
subroutine comfile'err(err);                                   <<00884>>03510000
value err;  integer err;                                       <<00884>>03515000
   begin                                                       <<00884>>03520000
   if noerrors then                                            <<00884>>03525000
      begin                                                    <<00884>>03530000
      ferror'(comfn,parmnum); << gets fs err #. closes file. >><<00884>>03535000
      cierr(errnum := if err = eofound then comeof else err);  <<00884>>03540000
      end;                                                     <<00884>>03545000
   end;                                                        <<00884>>03550000
<<***********************************************************>><<00884>>03555000
<<  releaserecs                                              >><<00884>>03560000
<<    returns records in command file to the free list.      >><<00884>>03565000
<<    recnum is the head of a linked list of records.        >><<00884>>03570000
<<***********************************************************>><<00884>>03575000
subroutine releaserecs(recnum);                                <<00884>>03580000
   value recnum; integer recnum;                               <<00884>>03585000
   begin                                                       <<00884>>03590000
   while (recnum <> 0) and noerrors do                         <<00884>>03595000
      begin                                                    <<00884>>03600000
      freaddir(comfn,rec',comrecsize,double(recnum));          <<00884>>03605000
      if <> then comfile'err(comreadfail)                      <<00884>>03610000
      else                                                     <<00884>>03615000
         begin                                                 <<00884>>03620000
         relcomrec(comfn,recnum,release'err);                  <<00884>>03625000
         if release'err <> 0 then comfile'err(release'err)     <<00884>>03630000
         else recnum := rec'(comlink);                         <<00884>>03635000
         end;                                                  <<00884>>03640000
      end;                                                     <<00884>>03645000
   end; << releaserecs >>                                      <<00884>>03650000
<<***********************************************************>><<00884>>03655000
<<  getrec                                                   >><<00884>>03660000
<<    locates a free record in command file.                 >><<00884>>03665000
<<***********************************************************>><<00884>>03670000
integer subroutine getrec;                                     <<00884>>03675000
   begin                                                       <<00884>>03680000
   getrec := getcomrec(comfn,errno);                           <<00884>>03685000
   if errno > 0 then                                           <<00884>>03690000
      begin                                                    <<00884>>03695000
      releaserecs(recno);                                      <<00884>>03700000
      comfile'err(errno);                                      <<00884>>03705000
      end;                                                     <<00884>>03710000
   end;  << getrec >>                                          <<00884>>03715000
                                                               <<00884>>03720000
<<***********************************************************>><<00884>>03725000
<<  parseudcfilenames                                        >><<00884>>03730000
<<     validates file names (if any).                        >><<00884>>03735000
<<     flags $null files as parms of zero length.            >><<00884>>03740000
<<***********************************************************>><<00884>>03745000
subroutine parseudcfilenames;                                  <<00884>>03750000
   begin                                                       <<00884>>03755000
   mycommand(parmsp,delims,maxparms,numparms,parms);           <<00884>>03760000
   if > then cierr(errnum := setcat2mparms,,%10000,maxparms)   <<00884>>03765000
   else                                                        <<00884>>03770000
      begin                                                    <<00884>>03775000
      newudcfiles := false;                                    <<00884>>03780000
      parmnum := -1;                                           <<00884>>03785000
      if numparms > 0 then                                     <<00884>>03790000
                                                               <<00884>>03795000
         do begin                                              <<00884>>03800000
            parmnum := parmnum + 1;                            <<00884>>03805000
            @parmptr := parmaddr;                              <<00884>>03810000
            if parmlen > 0 then                                <<00884>>03815000
               begin                                           <<00884>>03820000
               errno :=                                        <<00884>>03825000
                  checkfilename'(parms(parmnum)&lsr(8),dmy,dmy,<<00884>>03830000
                                 dmy);                         <<00884>>03835000
               if <> then                                      <<00884>>03840000
                  if > then                                    <<00884>>03845000
                       << backreferenced or system defined file<<00884>>03850000
                     if errno = 6 <<$null>> then               <<00884>>03855000
                        parmlen := 0  <<allow, but flag it >>  <<00884>>03860000
                     else                                      <<00884>>03865000
                        cierr(errnum := nobackorsys,parmptr)   <<00884>>03870000
                  else                                         <<00884>>03875000
                       << bad file syntax >>                   <<00884>>03880000
                     cierr(errnum := errno,parmptr)            <<00884>>03885000
               else                                            <<00884>>03890000
                  << appears to be good file >>                <<00884>>03895000
                  newudcfiles := true;                         <<00884>>03900000
               end;                                            <<00884>>03905000
            end                                                <<00884>>03910000
         until (nextdelim <> comma) or (errnum > 0);           <<00884>>03915000
                                                               <<00884>>03920000
      end;                                                     <<00884>>03925000
   lastfileparm := parmnum;                                    <<00884>>03930000
   parmnum := parmnum + 1;                                     <<00884>>03935000
   end; << parseudcfilenames >>                                <<00884>>03940000
                                                               <<00884>>03945000
<<***********************************************************>><<00884>>03950000
<<  parsextraparms                                           >><<00884>>03955000
<<     sets flags indicating which extra parms were chosen.  >><<00884>>03960000
<<     determines udc level (user, account, system). verfies >><<00884>>03965000
<<     user has proper capabilities to use account or system >><<00884>>03970000
<<     options.                                              >><<00884>>03975000
<<***********************************************************>><<00884>>03980000
subroutine parsextraparms;                                     <<00884>>03985000
   begin                                                       <<00884>>03990000
   move keylist := pkeylist,(pkeylistlen);                     <<00884>>03995000
   show := account := system := false;                         <<00884>>04000000
   who(,,,uname,,aname);                                       <<00884>>04005000
                                                               <<00884>>04010000
   while (parmnum < numparms) and noerrors do                  <<00884>>04015000
      begin                                                    <<00884>>04020000
      @parmptr := parmaddr;                                    <<00884>>04025000
      case search(parmptr,parmlen,keylist) of                  <<00884>>04030000
         begin                                                 <<00884>>04035000
                                                               <<00884>>04040000
         << 0: unknown keyword >>                              <<00884>>04045000
            cierr(errnum := uknkeyword,parmptr);               <<00884>>04050000
                                                               <<00884>>04055000
         << 1: show>>                                          <<00884>>04060000
            show := true;                                      <<00884>>04065000
                                                               <<00884>>04070000
         << 2: account>>                                       <<00884>>04075000
            begin                                              <<00884>>04080000
            if userspecd then                                  << 8156>>04085000
            begin                                              << 8156>>04090000
               cierr( errnum := nouserandother );              << 8156>>04095000
               goto outloop;                                   << 8156>>04100000
            end;                                               << 8156>>04105000
            pxglobal;                                          <<06601>>04110000
            @ucapptr := @pxg'userattributes;                   <<06601>>04115000
            if ucapam = 0 then                                 <<06601>>04120000
               cierr(errnum := needamcap,parmptr);             <<00884>>04125000
            account := true;                                   <<00884>>04130000
            move uname := "@       ";<< @ indicates all users>><<00884>>04135000
            end;                                               <<00884>>04140000
                                                               <<00884>>04145000
         << 3: system>>                                        <<00884>>04150000
            begin                                              <<00884>>04155000
            if userspecd then                                  << 8156>>04160000
            begin                                              << 8156>>04165000
               cierr( errnum := nouserandother );              << 8156>>04170000
               goto outloop;                                   << 8156>>04175000
            end;                                               << 8156>>04180000
            pxglobal;                                          <<06601>>04185000
            @ucapptr := @pxg'userattributes;                   <<06601>>04190000
            if ucapsm = 0 then                                 <<06601>>04195000
               cierr(errnum := needsmcap,parmptr);             <<00884>>04200000
            system := true;                                    <<00884>>04205000
            move uname := "@       ";<< @ indicates all users>><<00884>>04210000
            move aname := "@       ";<< @ indicates all accts>><<00884>>04215000
            end;                                               <<00884>>04220000
                                                               << 8156>>04225000
         << 4:  user >>                                        << 8156>>04230000
            begin                                              << 8156>>04235000
                                                               << 8156>>04240000
            userspecd := true;                                 << 8156>>04245000
                                                               << 8156>>04250000
            if (account lor system) then                       << 8156>>04255000
            begin                                              << 8156>>04260000
               cierr( errnum := nouserandother );              << 8156>>04265000
               goto outloop;                                   << 8156>>04270000
            end;                                               << 8156>>04275000
                                                               << 8156>>04280000
            if nextdelim <> equals                             << 8156>>04285000
               then cierr( errnum := userwantseqs )            << 8156>>04290000
            else                                               << 8156>>04295000
            begin                                              << 8156>>04300000
                                                               << 8156>>04305000
            << the user keyword specifies a user for whom  >>  << 8156>>04310000
            << the :setcatalog is being executed.  get the >>  << 8156>>04315000
            << specifications into the usname and asname   >>  << 8156>>04320000
            << arrays.                                     >>  << 8156>>04325000
               i := 0;                                         << 8156>>04330000
               if parmnum = numparms                           << 8156>>04335000
                  then cierr(errnum:=exptuserspec, parmptr);   << 8156>>04340000
               parmnum := parmnum + 1;                         << 8156>>04345000
               @parmptr := parmaddr;                           << 8156>>04350000
                                                               << 8156>>04355000
               move usname := "        ";                      << 8156>>04360000
               move asname := "        ";                      << 8156>>04365000
               move userdelims := ".,;=  ";                    << 8156>>04370000
               userdelims(4) := %15;  << carriage return >>    << 8156>>04375000
               mycommand(parmptr,userdelims,maxuserspecparms,  << 8156>>04380000
                         numuserspecparms,userparms );         << 8156>>04385000
               @parmptr := userp1addr;                         << 8156>>04390000
               if specialsinp1   lor                           << 8156>>04395000
                  ( not ( 1 <= userp1len <= 8 ))  then         << 8156>>04400000
               begin                                           << 8156>>04405000
                  cierr( errnum := baduserspec, parmptr );     << 8156>>04410000
                  return;                                      << 8156>>04415000
               end                                             << 8156>>04420000
               else move usname := parmptr, (userp1len);       << 8156>>04425000
                                                               << 8156>>04430000
               if userp1delimdot then                          << 8156>>04435000
               begin    << expect an account name. >>          << 8156>>04440000
                  @parmptr := userp2addr;                      << 8156>>04445000
                  if specialsinp2   lor                        << 8156>>04450000
                     ( not ( 1 <= userp2len <= 8 )) then       << 8156>>04455000
                  begin                                        << 8156>>04460000
                     cierr( errnum:=baduserspec,parmptr );     << 8156>>04465000
                     return;                                   << 8156>>04470000
                  end                                          << 8156>>04475000
                  else move asname := parmptr,(userp2len);     << 8156>>04480000
               end                                             << 8156>>04485000
               else if badp1delim then                         << 8156>>04490000
               begin                                           << 8156>>04495000
                  cierr( errnum := baduserspec, parmptr );     << 8156>>04500000
                  goto outloop;                                << 8156>>04505000
               end                                             << 8156>>04510000
               else move asname := aname, (8);                 << 8156>>04515000
                                                               << 8156>>04520000
            << check for appropriate capabilities.      >>     << 8156>>04525000
               pxglobal;                                       << 8156>>04530000
               @ucapptr := @pxg'userattributes;                << 8156>>04535000
               if (asname <> aname, (8)) land (ucapsm=0)       << 8156>>04540000
                  then cierr(errnum:=needsmcap2, parmptr)      << 8156>>04545000
                  else move aname := asname, (8);              << 8156>>04550000
               if (usname <> uname, (8)) land (ucapam=0)       << 8156>>04555000
                  then cierr(errnum:=needamcap2, parmptr)      << 8156>>04560000
                  else move uname := usname, (8);              << 8156>>04565000
                                                               << 8156>>04570000
               end;                                            << 8156>>04575000
                                                               << 8156>>04580000
               if not (noerrors) then return;                  << 8156>>04585000
                                                               << 8156>>04590000
            end;  << user case. >>                             << 8156>>04595000
                                                               << 8156>>04600000
         end; << case >>                                       <<00884>>04605000
      parmnum := parmnum + 1;                                  <<00884>>04610000
                                                               << 8156>>04615000
outloop:                                                       << 8156>>04620000
                                                               << 8156>>04625000
      end; << while >>                                         <<00884>>04630000
                                                               <<00884>>04635000
   if account and system then                                  <<00884>>04640000
      cierr(errnum := nobothsysacc);                           <<00884>>04645000
                                                               << 8156>>04650000
   if userspecd land (account lor system)                      << 8156>>04655000
      then cierr( errnum := nouserandother );                  << 8156>>04660000
                                                               << 8156>>04665000
   end; << parsextraparms >>                                   <<00884>>04670000
                                                               <<00884>>04675000
<<***********************************************************>><<03734>>04680000
<<  opencomfile                                              >><<03734>>04685000
<<     opens and locks command.pub.sys.                      >><<03734>>04690000
<<***********************************************************>><<03734>>04695000
subroutine opencomfile;                                        <<03734>>04700000
   begin                                                       <<03734>>04705000
                                                               <<03734>>04710000
   move rec := "COMMAND.PUB.SYS ";                             <<03734>>04715000
   comfn := fopen( rec, 1, %346 );  << old, share, lock, xeq >><<03734>>04720000
   if <> then comfile'err( comopenfail )                       <<03734>>04725000
   else                                                        <<03734>>04730000
   begin                                                       <<03734>>04735000
      oldcrit := setcritical;                                  <<04810>>04740000
      flock( comfn, true );                                    <<03734>>04745000
      if <> then comfile'err( comlockfail );                   <<03734>>04750000
   end;                                                        <<03734>>04755000
                                                               <<03734>>04760000
end;  << opencomfile >>                                        <<03734>>04765000
                                                               <<03734>>04770000
                                                               <<03734>>04775000
                                                               <<03734>>04780000
<<***********************************************************>><<03734>>04785000
<<  closecomfile                                             >><<03734>>04790000
<<     unlocks and closes command.pub.sys.                   >><<03734>>04795000
<<***********************************************************>><<03734>>04800000
subroutine closecomfile;                                       <<03734>>04805000
   begin                                                       <<03734>>04810000
                                                               <<03734>>04815000
   funlock( comfn );                                           <<03734>>04820000
   if = then unlockok := true                                  <<04810>>04825000
        else unlockok := false;                                <<04810>>04830000
   resetcritical( oldcrit );                                   <<04810>>04835000
   if not unlockok                                             <<04810>>04840000
      then comfile'err( comunlockfail )                        <<04810>>04845000
   else  fclose( comfn, 0, 0 );                                <<03734>>04850000
                                                               <<03734>>04855000
end;  << closecomfile >>                                       <<03734>>04860000
                                                               <<03734>>04865000
                                                               <<03734>>04870000
<<***********************************************************>><<00884>>04875000
<<  getoldudcinfo                                            >><<00884>>04880000
<<    opens and locks command.pub.sys.                       >><<03734>>04885000
<<    saves udc extra data segment number.                   >><<00884>>04890000
<<    gets record number in command file of current udc's.   >><<00884>>04895000
<<***********************************************************>><<00884>>04900000
subroutine getoldudcinfo;                                      <<00884>>04905000
   begin                                                       <<00884>>04910000
      olddstno := udcdstno;                                    <<04603>>04915000
      findcomuser(comfn,uname,aname,oldudcsexist,oldrecno,dmy, <<00884>>04920000
                  errno);                                      <<00884>>04925000
      if errno = nosuchcomuser then                            <<00884>>04930000
            << user not found in comfile, yet directory >>     <<00884>>04935000
            << indicates that udc's exist.  set exist    >>    <<00884>>04940000
            << flag so that directory will be updated.   >>    <<00884>>04945000
         oldudcsexist := false                                 <<00884>>04950000
      else                                                     <<00884>>04955000
         if errno <> 0 then  comfile'err(errno)                <<00884>>04960000
         else                                                  <<00884>>04965000
            begin  << no errors >>                             <<00884>>04970000
            if not oldudcsexist then                           <<00884>>04975000
               begin                                           <<00884>>04980000
                  << directory indicates no udc's exist.    >> <<00884>>04985000
                  << search comfile anyway since new comfile>> <<00884>>04990000
                  << may have been installed since last      >><<00884>>04995000
                  << directory update. >>                      <<00884>>05000000
               oldrecno := 1;  << begin search at beginning >> <<00884>>05005000
               searchcomfile(comfn,uname,aname,oldrecno,,      <<00884>>05010000
                                                        errno);<<00884>>05015000
               if errno <> 0 then                              <<00884>>05020000
                  if errno = eofound then oldrecno := 0        <<00884>>05025000
                  else comfile'err(errno);                     <<00884>>05030000
               end;                                            <<00884>>05035000
            end;                                               <<00884>>05040000
                                                               <<03734>>05045000
   end;                                                        <<00884>>05050000
                                                               <<00884>>05055000
<<***********************************************************>><<00884>>05060000
<<  enterfilenames                                           >><<00884>>05065000
<<    enters udc file names into command file.               >><<00884>>05070000
<<    enters user and account names with pointer to file     >><<00884>>05075000
<<    names.                                                 >><<00884>>05080000
<<    leaves 'recno' pointing to user and account names.     >><<00884>>05085000
<<***********************************************************>><<00884>>05090000
subroutine enterfilenames;                                     <<00884>>05095000
   begin                                                       <<00884>>05100000
                                                               <<00884>>05105000
   recno := 0;                                                 <<00884>>05110000
   parmnum := lastfileparm;                                    <<00884>>05115000
                                                               <<00884>>05120000
   do begin                                                    <<00884>>05125000
      if parmlen > 0 then                                      <<00884>>05130000
         begin                                                 <<00884>>05135000
         rec' := "  ";                                         <<00884>>05140000
         move rec'(1) := rec',(comrecsizem1);                  <<00884>>05145000
         @parmptr := parmaddr;                                 <<00884>>05150000
         qualifyfilename(parmptr,rec(comfname));               <<00884>>05155000
         rec'(comentrytype) := comfileentry;                   <<00884>>05160000
         rec'(comlink) := recno;                               <<00884>>05165000
         recno := getrec;                                      <<00884>>05170000
         if noerrors then                                      <<00884>>05175000
            begin                                              <<00884>>05180000
            fwritedir(comfn,rec',comrecsize,double(recno));    <<00884>>05185000
            if <> then                                         <<00884>>05190000
               begin                                           <<00884>>05195000
               releaserecs(recno);                             <<00884>>05200000
               comfile'err(comwritefail);                      <<00884>>05205000
               end;                                            <<00884>>05210000
            end;                                               <<00884>>05215000
         end;                                                  <<00884>>05220000
      parmnum := parmnum - 1;                                  <<00884>>05225000
      end                                                      <<00884>>05230000
   until (parmnum = -1) or (errnum > 0);                       <<00884>>05235000
                                                               <<00884>>05240000
   if noerrors then                                            <<00884>>05245000
      begin << add entry with user and acct pointing to files>><<00884>>05250000
      rec' := "  ";                                            <<00884>>05255000
      move rec'(1) := rec',(comrecsizem1);                     <<00884>>05260000
      rec'(comentrytype) := comuserentry;                      <<00884>>05265000
      move rec(comuname) := uname,(8);                         <<00884>>05270000
      move rec(comaname) := aname,(8);                         <<00884>>05275000
      rec'(comlink) := recno;                                  <<00884>>05280000
      recno := getrec;                                         <<00884>>05285000
      if noerrors then                                         <<00884>>05290000
         begin                                                 <<00884>>05295000
         fwritedir(comfn,rec',comrecsize,double(recno));       <<00884>>05300000
         if <> then                                            <<00884>>05305000
            begin                                              <<00884>>05310000
            releaserecs(recno);                                <<00884>>05315000
            comfile'err(comwritefail);                         <<00884>>05320000
            end;                                               <<00884>>05325000
         end;                                                  <<00884>>05330000
      end;                                                     <<00884>>05335000
                                                               <<00884>>05340000
   end; << enterfilenames >>                                   <<00884>>05345000
                                                               <<00884>>05350000
<<***********************************************************>><<00884>>05355000
<<  initnewudcs                                              >><<00884>>05360000
<<    updates directory to point to new udc's.               >><<00884>>05365000
<<    calls initudcno to process and activate new udc's.     >><<00884>>05370000
<<    restores old udc's if an error occurs.                 >><<00884>>05375000
<<***********************************************************>><<00884>>05380000
subroutine initnewudcs;                                        <<00884>>05385000
   begin                                                       <<00884>>05390000
   udcsexist := true;                                          <<00884>>05395000
   udcdircwrite(uname,aname,udcsexist,recno);                  <<00884>>05400000
   fcontrol(comfn,2,dmy);  << write out buffers >>             <<00884>>05405000
                                                               << 8156>>05410000
<< if the ;user= keyword was specified, all that needs to  >>  << 8156>>05415000
<< be done here is to update the directory for the user.   >>  << 8156>>05420000
<< since this is now done, we may return.  udcs are not    >>  << 8156>>05425000
<< set up when ;user= was specified.                       >>  << 8156>>05430000
   if userspecd then return;                                   << 8156>>05435000
                                                               << 8156>>05440000
   udcdstno := 0;                                              <<04603>>05445000
   initudcno( show, comfn );                                   <<03734>>05450000
   if integer(udcdstno) <= 0 then                              <<04846>>05455000
      begin  << error occured. restore old udc's >>            <<00884>>05460000
                                                               <<04846>>05465000
   << handle the case of problems with fgetlockword.    >>     <<04846>>05470000
      if integer(udcdstno) < 0 then                            <<04846>>05475000
      begin                                                    <<04846>>05480000
         cierr( errnum := lockworderr );                       <<04846>>05485000
      end;                                                     <<04846>>05490000
                                                               <<04846>>05495000
      udcdstno := olddstno;                                    <<04603>>05500000
      udcdircwrite(uname,aname,oldudcsexist,oldrecno);         <<00884>>05505000
      releaserecs(recno);                                      <<00884>>05510000
      errnum := initudcfailed;                                 <<00884>>05515000
      end;                                                     <<00884>>05520000
   end;  << initnewudcs >>                                     <<00884>>05525000
                                                               <<00884>>05530000
<<***********************************************************>><<00884>>05535000
<<  closeoldudcs                                             >><<00884>>05540000
<<    closes previous udc files (if any).                    >><<00884>>05545000
<<    releases udc extra data segment.                       >><<00884>>05550000
<<    updates directory command file pointer.                >><<00884>>05555000
<<    flags old udc information as invalid. (in case in udc) >><<00884>>05560000
<<    removes previous file names from command file.         >><<00884>>05565000
<<***********************************************************>><<00884>>05570000
subroutine closeoldudcs;                                       <<00884>>05575000
   begin                                                       <<00884>>05580000
                                                               << 8156>>05585000
<< if the ;user= keyword was specified, do not change the  >>  << 8156>>05590000
<< current user's udc setup.  return the old command file  >>  << 8156>>05595000
<< records to the free list.  note that if no new udcs     >>  << 8156>>05600000
<< exist, the specified user's directory entry is updated  >>  << 8156>>05605000
<< here to indicate that that user has no udcs.            >>  << 8156>>05610000
   if userspecd then                                           << 8156>>05615000
   begin                                                       << 8156>>05620000
      releaserecs( oldrecno );                                 << 8156>>05625000
      if not newudcfiles then                                  << 8156>>05630000
      begin                                                    << 8156>>05635000
         udcsexist := false;                                   << 8156>>05640000
         udcdircwrite( uname, aname, udcsexist, nil );         << 8156>>05645000
      end;                                                     << 8156>>05650000
      return;                                                  << 8156>>05655000
   end;                                                        << 8156>>05660000
                                                               << 8156>>05665000
   if olddstno > 0 then                                        <<00884>>05670000
      begin                                                    <<00884>>05675000
      closeudc(olddstno);                                      <<00884>>05680000
      reldataseg(olddstno);                                    <<00884>>05685000
      end;                                                     <<00884>>05690000
   if not newudcfiles then                                     <<00884>>05695000
      begin  << no new udc's to be activated. >>               <<00884>>05700000
      udcdstno := 0;                                           <<04603>>05705000
      udcsexist := false;                                      <<00884>>05710000
      udcdircwrite(uname,aname,udcsexist,nil);                 <<00884>>05715000
         << must reinit in case udc's exist at other levels. >><<00884>>05720000
      initudcno( false, comfn );                               <<03734>>05725000
      end;                                                     <<00884>>05730000
   cis'udcflush := true;  << flag old udc info invalid >>      <<04603>>05735000
   releaserecs(oldrecno);                                      <<00884>>05740000
                                                               <<03734>>05745000
   end; << closeoldudcs >>                                     <<00884>>05750000
                                                               <<00884>>05755000
<<*************************>>                                  <<00884>>05760000
<<  main procedure body    >>                                  <<00884>>05765000
<<*************************>>                                  <<00884>>05770000
                                                               <<00884>>05775000
userspecd := false;                                            << 8156>>05780000
parseudcfilenames;                                             <<00884>>05785000
if noerrors then                                               <<00884>>05790000
   begin                                                       <<00884>>05795000
   parsextraparms;                                             <<00884>>05800000
   if noerrors then                                            <<00884>>05805000
      begin                                                    <<00884>>05810000
      opencomfile;                                             <<03734>>05815000
      getoldudcinfo;                                           <<00884>>05820000
      if noerrors then                                         <<00884>>05825000
         if newudcfiles then                                   <<00884>>05830000
            begin                                              <<00884>>05835000
            enterfilenames;                                    <<00884>>05840000
            if noerrors then                                   <<00884>>05845000
               begin                                           <<00884>>05850000
               initnewudcs;                                    <<00884>>05855000
               if noerrors then                                <<00884>>05860000
                  closeoldudcs;                                <<00884>>05865000
               end;                                            <<00884>>05870000
            end                                                <<00884>>05875000
         else                                                  <<00884>>05880000
            closeoldudcs;                                      <<00884>>05885000
      closecomfile;                                            <<03734>>05890000
      end;                                                     <<00884>>05895000
   end;                                                        <<00884>>05900000
                                                               <<00884>>05905000
end; << cxsetcatalog >>                                        <<00884>>05910000
$page "SHOWCOMF:  Shows the UDC files for the specified user." << 8156>>05915000
logical procedure showcomf( uname, aname, comf, listf );       << 8156>>05920000
   value comf, listf;                                          << 8156>>05925000
   byte array uname, aname;                                    << 8156>>05930000
   integer comf, listf;                                        << 8156>>05935000
option privileged, uncallable;                                 << 8156>>05940000
begin                                                          << 8156>>05945000
                                                               << 8156>>05950000
<<*********************************************************>>  << 8156>>05955000
<<                                                         >>  << 8156>>05960000
<< this procedure looks in command.pub.sys (file comf) for >>  << 8156>>05965000
<< a user entry associated with uname and aname.  if an    >>  << 8156>>05970000
<< entry exists, showcomf returns true and will print the  >>  << 8156>>05975000
<< file names (stripped of lockwords) to the file listf    >>  << 8156>>05980000
<< (if listf = 0 or 2, the listing will go to $stdlist).   >>  << 8156>>05985000
<< if no associated user entry is found, showcomf will     >>  << 8156>>05990000
<< return a false.  other than the printing of the file    >>  << 8156>>05995000
<< names, this procedure will do no printing and will do   >>  << 8156>>06000000
<< no error checking.  this procedure is used primarily    >>  << 8156>>06005000
<< :showcatalog when the ;user= keyword is specified.      >>  << 8156>>06010000
<<                                                         >>  << 8156>>06015000
<< jon cohen                                    8/13/83    >>  << 8156>>06020000
<<                                                         >>  << 8156>>06025000
<<*********************************************************>>  << 8156>>06030000
                                                               << 8156>>06035000
logical array lbuf(0:36);                                      << 8156>>06040000
byte    array bbuf(*) = lbuf;                                  << 8156>>06045000
                                                               << 8156>>06050000
logical array rec'(0:19);                                      << 8156>>06055000
byte    array rec(*) = rec';                                   << 8156>>06060000
                                                               << 8156>>06065000
byte    pointer ptr,                                           << 8156>>06070000
                sptr;                                          << 8156>>06075000
                                                               << 8156>>06080000
logical       udcsexist;       << true if udcs found.      >>  << 8156>>06085000
                                                               << 8156>>06090000
integer       recno,                                           << 8156>>06095000
              dum,             << dummy variable.          >>  << 8156>>06100000
              err,             << for findcomuser call.    >>  << 8156>>06105000
              listfn;          << local listf copy.        >>  << 8156>>06110000
                                                               << 8156>>06115000
intrinsic     freaddir,                                        << 8156>>06120000
              fwrite;                                          << 8156>>06125000
                                                               << 8156>>06130000
                                                               << 8156>>06135000
                                                               << 8156>>06140000
subroutine visitentry;                                         << 8156>>06145000
begin                                                          << 8156>>06150000
                                                               << 8156>>06155000
<< this subroutine is used for the printing of the file    >>  << 8156>>06160000
<< name to the specified list file.                        >>  << 8156>>06165000
                                                               << 8156>>06170000
<< clear the buffer.                                       >>  << 8156>>06175000
   bbuf := " ";                                                << 8156>>06180000
   move bbuf(1) := bbuf, (71);                                 << 8156>>06185000
                                                               << 8156>>06190000
<< copy the file name into the buffer.  strip out a lock-  >>  << 8156>>06195000
<< word if present.                                        >>  << 8156>>06200000
   move bbuf(5) := rec(comfname), (36);                        << 8156>>06205000
   scan bbuf(5) until "/.", 1;                                 << 8156>>06210000
   if carry then   << found a "/". >>                          << 8156>>06215000
   begin                                                       << 8156>>06220000
      @ptr := tos;                                             << 8156>>06225000
      move ptr(1) := ptr(1) while an, 1;                       << 8156>>06230000
      @sptr := tos;                                            << 8156>>06235000
      move ptr := sptr, (19);                                  << 8156>>06240000
   end                                                         << 8156>>06245000
   else   del;                                                 << 8156>>06250000
                                                               << 8156>>06255000
<< print the record to the list file.                      >>  << 8156>>06260000
   fwrite( listfn, lbuf, 18, 0 );                              << 8156>>06265000
                                                               << 8156>>06270000
end;  << visitentry >>                                         << 8156>>06275000
                                                               << 8156>>06280000
                                                               << 8156>>06285000
                                                               << 8156>>06290000
<< start of main code for showcomf.                        >>  << 8156>>06295000
                                                               << 8156>>06300000
<< resolve the list file.                                  >>  << 8156>>06305000
   if listf = 0                                                << 8156>>06310000
      then listfn := 2                                         << 8156>>06315000
      else listfn := listf;                                    << 8156>>06320000
                                                               << 8156>>06325000
<< first, try to find a user entry in command.pub.sys for  >>  << 8156>>06330000
<< this user.                                              >>  << 8156>>06335000
   err := 0;                                                   << 8156>>06340000
   udcsexist := true;   << assume so, for now.  this will  >>  << 8156>>06345000
                        << be varified by the following    >>  << 8156>>06350000
                        << procedure call.                 >>  << 8156>>06355000
   findcomuser( comf,uname,aname,udcsexist,recno,dum,err );    << 8156>>06360000
   if (not udcsexist) lor (err = nosuchcomuser) then           << 8156>>06365000
   begin                                                       << 8156>>06370000
      showcomf := false;                                       << 8156>>06375000
      return;                                                  << 8156>>06380000
   end                                                         << 8156>>06385000
   else  showcomf := true;                                     << 8156>>06390000
                                                               << 8156>>06395000
<< a user entry has been found.  search down the list of   >>  << 8156>>06400000
<< udc file entries associated with this user.             >>  << 8156>>06405000
   freaddir( comf, rec', comrecsize, double(recno) );          << 8156>>06410000
   recno := rec'(comlink);  << pointer to first file entry >>  << 8156>>06415000
                                                               << 8156>>06420000
   while recno <> 0 do                                         << 8156>>06425000
   begin                                                       << 8156>>06430000
      freaddir( comf, rec', comrecsize, double(recno) );       << 8156>>06435000
      visitentry;                                              << 8156>>06440000
      recno := rec'(comlink);                                  << 8156>>06445000
   end;                                                        << 8156>>06450000
                                                               << 8156>>06455000
<< a blank line for to make it pretty.                    >>   << 8156>>06460000
   fwrite( listfn, lbuf, 0, 0 );                               << 8156>>06465000
                                                               << 8156>>06470000
end;  << showcomf >>                                           << 8156>>06475000
$title "CXSHOWCATALOG"                                                  06480000
procedure cxshowcatalog(parmsp,errnum,parmnum);                         06485000
   byte array parmsp;                                                   06490000
   integer errnum,parmnum;                                              06495000
   option uncallable;                                                   06500000
<<*********************************************************>>  << 8156>>06505000
<<                                                         >>  << 8156>>06510000
<< showcatalog was enhanced to have the following syntax:  >>  << 8156>>06515000
<<                                                         >>  << 8156>>06520000
<<     :showcatalog [[listfile] [;user=<user>[.<acct>]]]   >>  << 8156>>06525000
<<                                                         >>  << 8156>>06530000
<< where <user> and <acct> are less than eight characters  >>  << 8156>>06535000
<< long and contain only alphanumerics (first character    >>  << 8156>>06540000
<< alpha).  if present, the udc files used by the that     >>  << 8156>>06545000
<< user are listed to the listfile on all levels (i.e.     >>  << 8156>>06550000
<< user, account, and system).  if <user> = "@", then only >>  << 8156>>06555000
<< the account level udc files are listed.  if both <user> >>  << 8156>>06560000
<< and <acct> = "@", then only the system level udc files  >>  << 8156>>06565000
<< are listed.  if the user keyword is not specified, then >>  << 8156>>06570000
<< the caller's udc files are listed and formatted.        >>  << 8156>>06575000
<<                                                         >>  << 8156>>06580000
<<                                                         >>  << 8156>>06585000
<< jon cohen                                     8/13/83   >>  << 8156>>06590000
<<                                                         >>  << 8156>>06595000
<<*********************************************************>>  << 8156>>06600000
                                                               << 8156>>06605000
begin                                                                   06610000
                                                                        06615000
integer                                                                 06620000
   len,                                                                 06625000
   offset,                                                              06630000
   entrylen,                                                            06635000
   lastfn,                                                              06640000
   blen,                                                                06645000
   plen,                                                                06650000
   listfn;                                                              06655000
                                                                        06660000
byte pointer                                                            06665000
   parmptr,                                                             06670000
   endimage;                                                            06675000
                                                                        06680000
logical                                                                 06685000
   setlist;                                                             06690000
                                                                        06695000
byte array dev(0:2);                                                    06700000
                                                                        06705000
array dir'(0:dirmaxentrysize); byte array dir(*) = dir';                06710000
array buff'(0:14);byte array buff(*)=buff';                    <<00416>>06715000
                                                               << 8156>>06720000
<< the following declarations are used for command parse.  >>  << 8156>>06725000
   define                                                      << 8156>>06730000
      delimdef     = [8/";",8/"=",8/".",8/%15]d #;             << 8156>>06735000
                                                               << 8156>>06740000
   equate                                                      << 8156>>06745000
      maxshowparms      = 5,  << actually one more than    >>  << 8156>>06750000
                              << the worse case.           >>  << 8156>>06755000
      semi              = 0,  << these are the delimiter   >>  << 8156>>06760000
      equals            = 1,  << returned by mycommand.    >>  << 8156>>06765000
      dot               = 2,                                   << 8156>>06770000
      cr                = 3;                                   << 8156>>06775000
                                                               << 8156>>06780000
   double                                                      << 8156>>06785000
      delims'd := delimdef;                                    << 8156>>06790000
   byte array                                                  << 8156>>06795000
      delims(*) = delims'd;                                    << 8156>>06800000
                                                               << 8156>>06805000
   integer                                                     << 8156>>06810000
      numparms;                                                << 8156>>06815000
                                                               << 8156>>06820000
   double array                                                << 8156>>06825000
      parms(0:maxshowparms-1);                                 << 8156>>06830000
   integer array                                               << 8156>>06835000
      iparms(*) = parms;                                       << 8156>>06840000
                                                               << 8156>>06845000
   define                                                      << 8156>>06850000
      p1addr        = iparms #,                                << 8156>>06855000
      p1len         = iparms(1).(0:8) #,                       << 8156>>06860000
      p1delim       = iparms(1).(11:5) #,                      << 8156>>06865000
      p1specials    = ( iparms(1).(10:1) = 1 ) #,              << 8156>>06870000
      p2addr        = iparms(2) #,                             << 8156>>06875000
      p2len         = iparms(3).(0:8) #,                       << 8156>>06880000
      p2delim       = iparms(3).(11:5) #,                      << 8156>>06885000
      p2specials    = ( iparms(3).(10:1) = 1 ) #,              << 8156>>06890000
      p3addr        = iparms(4) #,                             << 8156>>06895000
      p3len         = iparms(5).(0:8) #,                       << 8156>>06900000
      p3delim       = iparms(5).(11:5) #,                      << 8156>>06905000
      p3specials    = ( iparms(5).(10:1) = 1 ) #,              << 8156>>06910000
      p4addr        = iparms(6) #,                             << 8156>>06915000
      p4len         = iparms(7).(0:8) #,                       << 8156>>06920000
      p4delim       = iparms(7).(11:5) #,                      << 8156>>06925000
      p4specials    = ( iparms(7).(10:1) = 1 ) #;              << 8156>>06930000
                                                               << 8156>>06935000
   byte array                                                  << 8156>>06940000
      uname(0:8),           << for user specified name.    >>  << 8156>>06945000
      aname(0:8),                                              << 8156>>06950000
      calleruser(0:8),      << from who, for comparison.   >>  << 8156>>06955000
      calleracct(0:8);                                         << 8156>>06960000
                                                               << 8156>>06965000
   intrinsic   who, mycommand;                                 << 8156>>06970000
                                                               << 8156>>06975000
   byte                                                        << 8156>>06980000
      savebyte;         << temporary storage.              >>  << 8156>>06985000
                                                               << 8156>>06990000
   logical                                                     << 8156>>06995000
      wilduser := false,   << signals which parts of the   >>  << 8156>>07000000
      wildacct := false;   << ;user parameter were "@".    >>  << 8156>>07005000
                                                               << 8156>>07010000
   byte array                                                  << 8156>>07015000
      comname(0:23);       << for opening command.pub.sys. >>  << 8156>>07020000
                                                               << 8156>>07025000
   integer                                                     << 8156>>07030000
      comf;                                                    << 8156>>07035000
                                                               << 8156>>07040000
   array qarray(*) = q+0;  << these declarations are for   >>  << 8156>>07045000
   integer pcbglobloc;     << referencing the pxglobal     >>  << 8156>>07050000
   pointer ucapptr;        << area for the capability      >>  << 8156>>07055000
                           << checks.                      >>  << 8156>>07060000
                                                               << 8156>>07065000
                                                                        07070000
subroutine def'movefromdseg;                                            07075000
                                                                        07080000
subroutine warn(errn,sptr);                                             07085000
   value errn; integer errn;                                            07090000
   byte array sptr;                                                     07095000
begin                                                                   07100000
   error( -errn, imagerr, sptr, parmsp(-11) );                 <<01360>>07105000
end; << warn >>                                                         07110000
                                                                        07115000
subroutine err(errn);                                                   07120000
   value errn; integer errn;                                            07125000
begin                                                                   07130000
   error(errn,udcferr,listfn,parmptr);                                  07135000
   go outl;                                                             07140000
end; << err >>                                                          07145000
                                                                        07150000
                                                                        07155000
   << cxshowcatalog main body >>                                        07160000
                                                                        07165000
<< initialize this procedure and parse the user specified  >>  << 8156>>07170000
<< parameters.                                             >>  << 8156>>07175000
   calleruser := " ";                                          << 8156>>07180000
   move calleruser(1) := calleruser, (8);                      << 8156>>07185000
   move calleracct := calleruser, (9);                         << 8156>>07190000
   move uname := calleruser, (9);                              << 8156>>07195000
   move aname := calleracct, (9);                              << 8156>>07200000
   who( , , , calleruser, , calleracct );                      << 8156>>07205000
   listfn := 0;                                                << 8156>>07210000
   mycommand(parmsp,delims,maxshowparms,numparms,parms);       << 8156>>07215000
                                                               << 8156>>07220000
<< first parameter, if there, is a list file.  open it.    >>  << 8156>>07225000
   if  (numparms=0)          << no parameters where there. >>  << 8156>>07230000
       lor                                                     << 8156>>07235000
       (p1len = 0 )          << first parameter ommitted.  >>  << 8156>>07240000
      then                                                     << 9087>>07245000
      begin                                                    << 9087>>07250000
      setlist := false;      << no listfile specified >>       << 9087>>07255000
      listfn := fopen(,%14,1);  <<  $stdlist          >>       << 9087>>07260000
      if <> then err (showcatlistopenf);                       << 9087>>07265000
      end                                                      << 9087>>07270000
   else                                                        << 9087>>07275000
      begin                                                    << 9087>>07280000
      setlist := true;      << listfile specified     >>       << 9087>>07285000
   @parmptr := p1addr;                                         << 8156>>07290000
   savebyte := parmptr( p1len );                               << 8156>>07295000
   parmptr( p1len ) := 0;    << delimiter for fopen.       >>  << 8156>>07300000
   move dev := "LP ";                                          << 8156>>07305000
   listfn := fopen (parmptr,%4,                                << 9087>>07310000
                    1, , dev                               );  << 8156>>07315000
   if <> then err( showcatlistopenf );                         << 8156>>07320000
   parmptr( p1len ) := savebyte;                               << 8156>>07325000
      end;                                                     << 9087>>07330000
                                                               << 8156>>07335000
<< next handle the specification of the ;user= keyword.    >>  << 8156>>07340000
<< note that this is handled and the procedure returns if  >>  << 8156>>07345000
<< "USER" is found.  otherwise, program control is         >>  << 8156>>07350000
<< resumed at the original cxshowcatalog code that formats >>  << 8156>>07355000
<< the user's udc dst.                                     >>  << 8156>>07360000
   if numparms > 1 then    << something was there.  look.  >>  << 8156>>07365000
   begin                                                       << 8156>>07370000
                                                               << 8156>>07375000
      @parmptr := p2addr;                                      << 8156>>07380000
      if ( p1delim <> semi )      lor                          << 8156>>07385000
         ( p2len <> 4 )           lor                          << 8156>>07390000
         ( parmptr <> "USER" )    lor                          << 8156>>07395000
         ( p2delim <> equals )    lor                          << 8156>>07400000
         ( not (3<=numparms<=4) ) then                         << 8156>>07405000
      begin                                                    << 8156>>07410000
         cierr( errnum := badshowsyn, parmptr );               << 8156>>07415000
         goto outl;                                            << 8156>>07420000
      end;                                                     << 8156>>07425000
                                                               << 8156>>07430000
      @parmptr := p3addr;                                      << 8156>>07435000
      if not ( 1 <= p3len <= 8 )   then                        << 8156>>07440000
      begin                                                    << 8156>>07445000
         cierr( errnum := badshowuserspec, parmptr );          << 8156>>07450000
         goto outl;                                            << 8156>>07455000
      end;                                                     << 8156>>07460000
                                                               << 8156>>07465000
      if ( p3len = 1 ) land ( parmptr = "@" )                  << 8156>>07470000
         then  wilduser := true                                << 8156>>07475000
      else if p3specials then                                  << 8156>>07480000
      begin                                                    << 8156>>07485000
         cierr( errnum := badshowuserspec, parmptr );          << 8156>>07490000
         goto outl;                                            << 8156>>07495000
      end;                                                     << 8156>>07500000
      move uname := parmptr, (p3len);                          << 8156>>07505000
                                                               << 8156>>07510000
      if numparms = 3   << acct not spec'd.  use caller's. >>  << 8156>>07515000
         then move aname := calleracct, (9)                    << 8156>>07520000
      else                                                     << 8156>>07525000
      begin                                                    << 8156>>07530000
                                                               << 8156>>07535000
      << another parameter is specified.  it should be the >>  << 8156>>07540000
      << account specification in the ;user parameter.     >>  << 8156>>07545000
         @parmptr := p4addr;                                   << 8156>>07550000
         if ( p3delim <> dot )       lor                       << 8156>>07555000
            ( not (1<=p4len<=8) )    then                      << 8156>>07560000
         begin                                                 << 8156>>07565000
            cierr( errnum := badshowuserspec, parmptr );       << 8156>>07570000
            goto outl;                                         << 8156>>07575000
         end;                                                  << 8156>>07580000
                                                               << 8156>>07585000
         if ( p4len = 1 ) land ( parmptr = "@" )               << 8156>>07590000
            then wildacct := true                              << 8156>>07595000
         else if p4specials then                               << 8156>>07600000
         begin                                                 << 8156>>07605000
            cierr( errnum := badshowuserspec, parmptr );       << 8156>>07610000
            goto outl;                                         << 8156>>07615000
         end;                                                  << 8156>>07620000
         move aname := parmptr, (p4len);                       << 8156>>07625000
                                                               << 8156>>07630000
         if wildacct land (not wilduser) then                  << 8156>>07635000
         begin                                                 << 8156>>07640000
            cierr( errnum := showuserdotat, parmptr );         << 8156>>07645000
            goto outl;                                         << 8156>>07650000
         end;                                                  << 8156>>07655000
                                                               << 8156>>07660000
         if numparms > 4                                       << 8156>>07665000
            then cierr( errnum := -toomanyshowparms,           << 8156>>07670000
                        parmptr );                             << 8156>>07675000
                                                               << 8156>>07680000
      end;  << account specification >>                        << 8156>>07685000
                                                               << 8156>>07690000
   << the caller's capability needs to be checked if       >>  << 8156>>07695000
   << account or system udcs were requested or if another  >>  << 8156>>07700000
   << user's udcs were requested.  note that a check for   >>  << 8156>>07705000
   << "<user>.@" has already been made.                    >>  << 8156>>07710000
      pxglobal;                                                << 8156>>07715000
      @ucapptr := @pxg'userattributes;                         << 8156>>07720000
      if calleracct <> aname, (8)                              << 8156>>07725000
         then if ucapsm = 0 then                               << 8156>>07730000
         begin                                                 << 8156>>07735000
            cierr( errnum := showneedssm );                    << 8156>>07740000
            goto outl;                                         << 8156>>07745000
         end;                                                  << 8156>>07750000
                                                               << 8156>>07755000
      if calleruser <> uname, (8)                              << 8156>>07760000
         then if (ucapam=0) land (ucapsm=0) then               << 8156>>07765000
         begin                                                 << 8156>>07770000
            cierr( errnum := showneedsam );                    << 8156>>07775000
            goto outl;                                         << 8156>>07780000
         end;                                                  << 8156>>07785000
                                                               << 8156>>07790000
   << having made it this far, no syntax errors have been  >>  << 8156>>07795000
   << found.  all that remains is to print out the         >>  << 8156>>07800000
   << requested information.                               >>  << 8156>>07805000
      move comname := "COMMAND.PUB.SYS  ";                     << 8156>>07810000
      comf := fopen( comname, 1, %346 );                       << 8156>>07815000
      if <> then                                               << 8156>>07820000
      begin                                                    << 8156>>07825000
         cierr( errnum := showcomopenfail );                   << 8156>>07830000
         goto outl;                                            << 8156>>07835000
      end;                                                     << 8156>>07840000
                                                               << 8156>>07845000
      if wilduser then                                         << 8156>>07850000
      begin                                                    << 8156>>07855000
                                                               << 8156>>07860000
         if wildacct then                                      << 8156>>07865000
         begin                                                 << 8156>>07870000
            genmsg( setseven, showsysudcfs,,,,,,, -listfn );   << 8156>>07875000
            if not showcomf( uname, aname, comf, listfn )      << 8156>>07880000
               then genmsg( setseven, nosysudcfs,,,,,,,        << 8156>>07885000
                            -listfn );                         << 8156>>07890000
         end                                                   << 8156>>07895000
         else                                                  << 8156>>07900000
         begin                                                 << 8156>>07905000
            genmsg( setseven, showacctudcfs,,,,,,, -listfn );  << 8156>>07910000
            if not showcomf( uname, aname, comf, listfn )      << 8156>>07915000
               then genmsg( setseven, noacctudcfs,,,,,,,       << 8156>>07920000
                            -listfn );                         << 8156>>07925000
         end;                                                  << 8156>>07930000
                                                               << 8156>>07935000
      end       << "@" specified for user.                 >>  << 8156>>07940000
      else                                                     << 8156>>07945000
      begin                                                    << 8156>>07950000
                                                               << 8156>>07955000
         genmsg( setseven, showuserudcfs,,,,,,, -listfn );     << 8156>>07960000
         if not showcomf( uname, aname, comf, listfn )         << 8156>>07965000
            then genmsg( setseven, nouserudcfs,,,,,,,          << 8156>>07970000
                         -listfn );                            << 8156>>07975000
         if requestservice then goto outl2;                    << 8156>>07980000
                                                               << 8156>>07985000
         move uname := "@       ";                             << 8156>>07990000
         genmsg( setseven, showacctudcfs,,,,,,, -listfn );     << 8156>>07995000
         if not showcomf( uname, aname, comf, listfn )         << 8156>>08000000
            then genmsg( setseven, noacctudcfs,,,,,,,          << 8156>>08005000
                         -listfn );                            << 8156>>08010000
         if requestservice then goto outl2;                    << 8156>>08015000
                                                               << 8156>>08020000
         move aname := "@       ";                             << 8156>>08025000
         genmsg( setseven, showsysudcfs,,,,,,, -listfn );      << 8156>>08030000
         if not showcomf( uname, aname, comf, listfn )         << 8156>>08035000
            then genmsg( setseven, nosysudcfs,,,,,,,           << 8156>>08040000
                         -listfn );                            << 8156>>08045000
                                                               << 8156>>08050000
      end;       << printing of the user's udc files.      >>  << 8156>>08055000
                                                               << 8156>>08060000
<< don't forget to close command.pub.sys.                  >>  << 8156>>08065000
outl2:                                                         << 8156>>08070000
   fclose( comf, 0, 0 );                                       << 8156>>08075000
                                                               << 8156>>08080000
   goto outl;                                                  << 8156>>08085000
                                                               << 8156>>08090000
   end;  << handling of the case of more than one parm.    >>  << 8156>>08095000
                                                               << 8156>>08100000
                                                               << 8156>>08105000
<< :showcatalog code, case where ;user not specified.      >>  << 8156>>08110000
                                                                        08115000
lastfn := -1;                                                           08120000
offset := 0;                                                            08125000
entrylen := dirmaxentrysize;                                            08130000
                                                                        08135000
if udcdstno = 0 then genmsg( ciset, nocatalogs )               <<04603>>08140000
else << udc's & catalogs exist >>                                       08145000
begin                                                                   08150000
   if setlist then genmsg( setseven, usedlistfile )                     08155000
   else print(buff',0,0);                                               08160000
   do begin                                                             08165000
         << get dir 1 entry at a time >>                                08170000
      movefromdseg(@dir',udcdstno,offset,entrylen +dirhead);   <<04603>>08175000
      movefromdseg(@dir',udcdstno,offset,entrylen +dirhead);   <<04603>>08180000
      len := dir(direntrysize);                                         08185000
      entrylen := dir(len*2 +direntrysize);                             08190000
      offset := offset +len;                                            08195000
      if len <> 0 then                                                  08200000
      begin                                                             08205000
         if lastfn <> integer(dir(dirfileno)) then                      08210000
         begin << print file name >>                                    08215000
            lastfn := dir(dirfileno);                                   08220000
            buff := " ";                                                08225000
            fgetinfo(lastfn,buff);                                      08230000
            scan buff until " ",1;                                      08235000
            blen := tos -@buff;                                         08240000
            fwrite(listfn,buff',-blen,0);                               08245000
            if <> then err(showcatlistwritef);                          08250000
         end;                                                           08255000
         buff:=" "; <<blank fill output buffer>>               <<00416>>08260000
         move buff(1):=buff,(29);                              <<00416>>08265000
         blen := dir(dircmdlen);                                        08270000
         move buff(3) := dir(dircmd),(blen);                            08275000
         blen:=dir'.udctype';                                  <<04603>>08280000
         if blen=udctype'user then move buff(22):=" USER   "   <<00416>>08285000
         else                                                  <<00416>>08290000
         if blen=udctype'system then move buff(22):=" SYSTEM " <<00416>>08295000
         else move buff(22):=" ACCOUNT";                       <<00416>>08300000
         fwrite(listfn,buff',-30,0);                           <<00416>>08305000
         if <> then err(showcatlistwritef);                             08310000
      end;                                                              08315000
      if requestservice then len := 0; << break hit >>                  08320000
   end until len = 0;                                                   08325000
end;                                                                    08330000
                                                                        08335000
outl:                                                                   08340000
                                                                        08345000
   << restore %15 at end for redo >>                                    08350000
fclose(listfn,0,0);                                                     08355000
                                                                        08360000
end; << cxshowcatalog >>                                                08365000
$title "UDCDIRCWRITE"                                          <<00884>>08370000
procedure udcdircwrite(uname,aname,udcsexist,recno);           <<00884>>08375000
   byte array aname,uname;                                     <<00884>>08380000
   logical udcsexist;                                          <<00884>>08385000
   integer recno;                                              <<00884>>08390000
   option uncallable;                                          <<00884>>08395000
comment                                                        <<00884>>08400000
   reads/writes command file record numbers from/to system     <<00884>>08405000
   directory. updates system level udc flag in sysglob if      <<00884>>08410000
   necessary. command file record numbers for user level udc's <<00884>>08415000
   are kept in the user entry of the system directory. record  <<00884>>08420000
   numbers for account level udc's are kept in the account     <<00884>>08425000
   entries. the record number for system level udc's is kept in<<00884>>08430000
   the account entry of the sys account. recipudc is a procedur<<00884>>08435000
   which is passed to direcscan to do the actual read/write    <<00884>>08440000
   of the directory entry.  parmarray is used by recipudc to   <<00884>>08445000
   determine what is to be done to the entry and as storage    <<00884>>08450000
   for values read/written from/to the entry.                  <<00884>>08455000
   ;                                                           <<00884>>08460000
                                                               <<00884>>08465000
begin                                                          <<00884>>08470000
entry udcdircread;                                             <<00884>>08475000
array                                                          <<00884>>08480000
   parmarray(0:3) = q,                                         <<00884>>08485000
   sys(0:3);                                                   <<00884>>08490000
pointer                                                        <<00884>>08495000
   uname',                                                     <<00884>>08500000
   aname';                                                     <<00884>>08505000
                                                               <<00884>>08510000
integer subroutine wordaddress(byteaddress);                   <<00884>>08515000
   value byteaddress;  integer byteaddress;                    <<00884>>08520000
   begin                                                       <<00884>>08525000
   tos := wordaddress := byteaddress & lsr(1);                 <<00884>>08530000
   push(z);                                                    <<00884>>08535000
   if <<wordaddress>> tos > tos <<z>> then                     <<00884>>08540000
      wordaddress.(0:1) := 1;                                  <<00884>>08545000
   end;                                                        <<00884>>08550000
                                                               <<00884>>08555000
                                                               <<00884>>08560000
parmarray := dircwrite;                                        <<00884>>08565000
go start;                                                      <<00884>>08570000
                                                               <<00884>>08575000
udcdircread:                                                   <<00884>>08580000
parmarray := dircread;                                         <<00884>>08585000
                                                               <<00884>>08590000
start:                                                         <<00884>>08595000
parmarray(2) := recno;                                         <<00884>>08600000
parmarray(3) := udcsexist;                                     <<00884>>08605000
@uname' := wordaddress(@uname);                                <<00884>>08610000
@aname' := wordaddress(@aname);                                <<00884>>08615000
if uname = "@" then                                            <<00884>>08620000
   if aname = "@" then                                         <<00884>>08625000
      begin                                                    <<00884>>08630000
      parmarray(1) := udctype'system;                          <<00884>>08635000
      move sys := "SYS     ";                                  <<00884>>08640000
      direcscan(getacctentry,0d,sys,,,recipudc,parmarray);     <<00884>>08645000
      if parmarray = dircwrite then                            <<00884>>08650000
         absolute(sysglobudcflag) := udcsexist;                <<00884>>08655000
      end                                                      <<00884>>08660000
   else                                                        <<00884>>08665000
      begin                                                    <<00884>>08670000
      parmarray(1) := udctype'account;                         <<00884>>08675000
      direcscan(getacctentry,0d,aname',,,recipudc,parmarray);  <<00884>>08680000
      end                                                      <<00884>>08685000
else                                                           <<00884>>08690000
   begin                                                       <<00884>>08695000
   parmarray(1) := udctype'user;                               <<00884>>08700000
   direcscan(getuserentry,0d,aname',uname',,recipudc,parmarray)<<00884>>08705000
   ;                                                           <<00884>>08710000
   end;                                                        <<00884>>08715000
recno := parmarray(2);                                         <<00884>>08720000
udcsexist := parmarray(3);                                     <<00884>>08725000
end;  << udcdircwrite >>                                       <<00884>>08730000
$title "ERROR"                                                          08735000
procedure error(errno,type,eptr,baseptr);                               08740000
   value errno,type,eptr,baseptr;                                       08745000
   integer errno,type;                                                  08750000
   byte pointer eptr,baseptr;                                           08755000
   option uncallable,variable;                                          08760000
comment   - universal error handler for udc's.                          08765000
                                                                        08770000
parameters:                                                             08775000
   errno    - error number. required parm.                              08780000
   type     = error type.  required parm.                               08785000
       ferr     = 0 - file error.  eptr is file number.                 08790000
                      fcheck is called to get error. genmsg             08795000
                      is called to print file sys error.                08800000
                      cierr is called to print ci error.       <<01360>>08805000
      udcerr    = 1 - cierr is called to print ci error.       <<01360>>08810000
                      (internal error.)                                 08815000
      synerr    = 2 - string is printed, caret is printed.              08820000
                      cierr is called to print ci error.       <<01360>>08825000
      synerrnol = 3 - cierr is called to print ci error.       <<01360>>08830000
      udcferr   = 4 - baseptr contains file name. fgetinfo              08835000
                      called to get file no.  fcheck called             08840000
                      to get error.  genmsg is called to print          08845000
                      file sys error.                                   08850000
      imagerr   = 5 - string printed only if udc4.imageadjust.          08855000
                      caret printed.  cierr called to print    <<01360>>08860000
                      ci error.                                <<01360>>08865000
   eptr     - point in string where caret should be printed.            08870000
              (unless type=ferr then eptr is file no.)                  08875000
   baseptr  - beginning of error string.  (unless type=udcerr           08880000
              then it is file name.)                                    08885000
;                                                                       08890000
begin                                                                   08895000
                                                                        08900000
                                                                        08905000
integer                                                                 08910000
   comlen,                                                              08915000
   len;                                                                 08920000
                                                                        08925000
byte pointer ptr;                                                       08930000
pointer ptr';                                                           08935000
pointer baseptr';                                                       08940000
                                                                        08945000
array buff'(0:udcbuffsize);                                    << 7960>>08950000
byte array buff(*) = buff';                                    << 7960>>08955000
                                                                        08960000
cis'udcnoprint := 1;  << cierr should not print line. >>       <<04603>>08965000
                                                               <<01360>>08970000
if type = synerr or type = imagerr then                                 08975000
begin                                                                   08980000
   @baseptr' := @baseptr&lsr(1);                                        08985000
   @ptr' := @baseptr';                                                  08990000
   @ptr := @baseptr;                                                    08995000
   scan ptr until 0,1;                                                  09000000
   comlen := tos -@ptr;                                                 09005000
   len := if comlen > termsize then termsize else comlen;               09010000
   do begin                                                             09015000
      if type <> imagerr or cis'udcimageadjust or comlen >     <<04603>>09020000
         termsize then print(ptr',-len,0);                              09025000
      @ptr := @ptr +termsize;                                           09030000
      @ptr' := @ptr&lsr(1);                                             09035000
      len := comlen -(@ptr -@baseptr);                                  09040000
      if len > termsize then len := termsize;                           09045000
   end until @ptr >= @eptr;                                             09050000
   len := @eptr -(@ptr -termsize);                                      09055000
   if type = imagerr and not cis'udcimageadjust and            <<04603>>09060000
      comlen <= termsize then len := len +1;                            09065000
   buff := " ";                                                         09070000
   move buff(1) := buff,(len);                                          09075000
   buff(len) := "^";                                                    09080000
   print(buff',-len -1,0);                                              09085000
end << synerr >>                                                        09090000
else                                                                    09095000
if type = ferr then                                                     09100000
begin                                                                   09105000
   fcheck(eptr(1),len); << fil # passed as byte ptr>>                   09110000
   genmsg(fsysset,len);                                                 09115000
end                                                                     09120000
else                                                                    09125000
if type = udcferr then                                                  09130000
begin                                                                   09135000
   fcheck(eptr(1),len); << file # passed as byte ptr>>                  09140000
   genmsg(fsysset,len);                                                 09145000
   if integer(eptr(1)) <> 0 then                                        09150000
   begin << get file name >>                                            09155000
      @baseptr := @buff;                                                09160000
      buff := 0;                                                        09165000
      move baseptr(1) := baseptr,(28);                         <<01522>>09170000
      fgetinfo(eptr(1),baseptr);                                        09175000
   end;                                                                 09180000
   cierr( errno, , %1, @baseptr );                             <<01360>>09185000
end;                                                                    09190000
                                                                        09195000
if type <> udcferr  then cierr( errno );                       <<01360>>09200000
                                                               <<01360>>09205000
cis'udcnoprint := 0;  << reset >>                              <<04603>>09210000
                                                                        09215000
end; << error >>                                                        09220000
$title "FEEDCI"                                                         09225000
procedure feedci(udcfn,recno,comimage,numparms,                         09230000
      parmsinfo,offset,options,errno);                                  09235000
   value udcfn,recno,numparms,options,offset;                           09240000
   integer udcfn,recno,numparms,offset,errno;                           09245000
   byte array comimage;                                                 09250000
   logical options;                                                     09255000
   array parmsinfo;                                                     09260000
   option uncallable;                                                   09265000
comment                                                                 09270000
   reads udc file, stuffs parms & calls ci                              09275000
;                                                                       09280000
begin                                                                   09285000
                                                                        09290000
integer                                                                 09295000
   count,                                                               09300000
   comlen,                                                              09305000
   plen,                                                                09310000
   udclen,                                                              09315000
   sign'len,                                                   <<01018>>09320000
   errno1;                                                              09325000
logical done;                                                           09330000
byte pointer                                                            09335000
   udcptr,                                                              09340000
   parmptr;                                                             09345000
array udcbuff'(0:udcbuffsize);                                          09350000
byte array udcbuff(*) = udcbuff';                                       09355000
                                                                        09360000
subroutine filerr(errn);                                                09365000
   value errn; integer errn;                                            09370000
      << file error >>                                                  09375000
begin                                                                   09380000
   errno := errn;                                                       09385000
   error(errno,udcferr,udcfn);                                          09390000
   go outl;                                                             09395000
end; << err >>                                                          09400000
                                                                        09405000
subroutine berr(errn,ptr);                                              09410000
   value errn; integer errn;                                            09415000
   byte array ptr;                                                      09420000
      << udc body error >>                                              09425000
begin                                                                   09430000
   errno := errn;                                                       09435000
   error(errno,if options.cis'optnohelp then synerrnol         <<04603>>09440000
                                        else synerr,           <<04603>>09445000
      ptr,udcbuff);                                                     09450000
   if cis'udcfatalcierr then go outl                           <<04603>>09455000
   else                                                        <<01360>>09460000
   begin                                                       <<01360>>09465000
      errno := -1;  << continue if returned ok.  >>            <<01360>>09470000
      go skip'this'line;                                       <<01360>>09475000
   end;                                                        <<01360>>09480000
end; << berr >>                                                         09485000
                                                                        09490000
subroutine errtoolong;                                                  09495000
      << comimage error >>                                              09500000
begin                                                                   09505000
   errno := toolong;                                           <<01288>>09510000
   error(toolong,if options.cis'optnohelp then synerrnol       <<04603>>09515000
                                          else synerr,         <<04603>>09520000
      comimage(cis'maxcomlen -1),comimage);                    <<04603>>09525000
   if cis'udcfatalcierr then go outl                           <<04603>>09530000
   else                                                        <<01360>>09535000
   begin                                                       <<01360>>09540000
      errno := -1;  << continue if returned ok.  >>            <<01360>>09545000
      go skip'this'line;                                       <<01360>>09550000
   end;                                                        <<01360>>09555000
end; << subroutine errtoolong >>                                        09560000
                                                                        09565000
                                                                        09570000
subroutine stuff;                                                       09575000
comment                                                                 09580000
   moves from udcptr into comimage. checks for overflow of              09585000
   buffer. requires:                                                    09590000
      udclen = count to place in comimage.                              09595000
      udcptr = pointing to starting place in udc image.                 09600000
   updates comlen                                                       09605000
;                                                                       09610000
begin                                                                   09615000
   move comimage(comlen) := udcptr,(udclen);                   <<05021>>09620000
   if comlen +udclen > cis'maxcomlen then                      <<04603>>09625000
      errtoolong;                                                       09630000
   comlen := comlen +udclen;                                            09635000
end; << stuff >>                                                        09640000
                                                                        09645000
                                                                        09650000
          << *************************** >>                             09655000
          <<                             >>                             09660000
          <<    feedci main body         >>                             09665000
          <<                             >>                             09670000
          << *************************** >>                             09675000
                                                                        09680000
                                                                        09685000
comimage(cis'maxcomlen +1) := 0; << stopper for errtoolong >>  <<04603>>09690000
errno := -1;                                                            09695000
do begin                                                                09700000
   comlen := 0;                                                         09705000
   readfile(udcfn,recno,udcbuff',errno1);                               09710000
   if errno1 = eofound then errno := 0                                  09715000
   else                                                                 09720000
   begin                                                                09725000
      if errno1 <> 0 then filerr(errno1);                               09730000
      if udcbuff = "*" then errno := 0                                  09735000
      else                                                              09740000
      begin                                                             09745000
         @udcptr := @udcbuff;                                           09750000
         done := false;                                                 09755000
                                                                        09760000
            << loop to parse udc body image >>                          09765000
                                                                        09770000
         do begin << whirl thru parms >>                                09775000
            scan udcptr until "!",1;                                    09780000
            @parmptr := tos;                                            09785000
            if nocarry then                                             09790000
            begin                                                       09795000
               udclen := @parmptr -@udcptr;                             09800000
               stuff; << put in comimage>>                              09805000
               findparm(parmptr(1),udcptr);                             09810000
                                                                        09815000
                  << check out formal name >>                           09820000
                    if udcptr <> alpha and udcptr <> "!" then  <<01018>>09825000
                        berr(fmlnamenotalpha,udcptr)           <<01018>>09830000
                    else if udcptr = "!" then                  <<01018>>09835000
                        begin                                  <<01018>>09840000
                           scan udcptr while "!",1;            <<01018>>09845000
                           sign'len := tos - @udcptr + 1;      <<01018>>09850000
                           udclen := sign'len/2;               <<01018>>09855000
                           stuff;                              <<01018>>09860000
                           @udcptr := @udcptr(sign'len - 1);   <<01018>>09865000
                           if sign'len mod 2 = 0 then go match;<<01018>>09870000
                        end;                                   <<01018>>09875000
                  << upshift >>                                         09880000
               move udcptr := udcptr while ans,1;                       09885000
               udclen := tos -@udcptr;                                  09890000
               count := -1;                                             09895000
               while (count := count +1) < numparms do                  09900000
               begin                                                    09905000
                                                                        09910000
                     << search for matching name pointed >>             09915000
                     << to by parmsinfo                  >>             09920000
                  @parmptr := parmsinfo(count*3 +1);                    09925000
                  if udclen = integer(parmsinfo(count*3)                09930000
                     .(0:8)) and udcptr = parmptr,(udclen)              09935000
                     then                                               09940000
                  begin                                                 09945000
                                                                        09950000
                        << found match. stuff in comimage>>             09955000
                     @parmptr := parmsinfo(count*3 +2);                 09960000
                     plen := parmsinfo(count*3).(8:8);                  09965000
                     move comimage(comlen) := parmptr,                  09970000
                                        (plen);                <<05021>>09975000
                     if comlen +plen > cis'maxcomlen then      <<04603>>09980000
                        errtoolong;                                     09985000
                     @udcptr := @udcptr(udclen +               <<00884>>09990000
                           (if udcptr(-1) = """" and           <<00884>>09995000
                              udcptr(udclen) = """" then 1     <<00884>>10000000
                                                      else 0));<<00884>>10005000
                     comlen := comlen +plen;                            10010000
                     go match;                                          10015000
                  end;                                                  10020000
               end;                                                     10025000
               berr(unknownparm,udcptr);                                10030000
match:                                                                  10035000
            end                                                         10040000
            else                                                        10045000
            begin << no parm >>                                         10050000
               udclen := @parmptr -@udcptr;                             10055000
               stuff; << in comimage >>                                 10060000
               done := true;                                            10065000
            end;                                                        10070000
         end until done; << parm loop >>                                10075000
                                                                        10080000
            << now parsed complete body image >>                        10085000
         if options.cis'optlist then                           <<04603>>10090000
         begin                                                          10095000
            tos := @comimage&lsr(1); << word address >>                 10100000
            print(*,-comlen,0);                                         10105000
         end;                                                           10110000
         comimage(comlen) := cr; << stopper for ci>>                    10115000
                                                                        10120000
            << deblank on front >>                                      10125000
         scan comimage while %6440,1; << " " >>                         10130000
         @parmptr := tos;                                               10135000
         if nocarry then move comimage:=parmptr,(comlen+1)     <<01126>>10140000
            else comlen:=0; << all blank line >>               <<01126>>10145000
                                                                        10150000
         if comlen > 0 then                                    <<01075>>10155000
            begin                                              <<01075>>10160000
            udcci(offset);                                     <<01075>>10165000
            if cis'udcfatalcierr or                            <<04603>>10170000
               cis'udcbreakdetected or cis'udcflush then       <<04603>>10175000
               errno := udc'flushed;  << flush udc's >>        <<01288>>10180000
            end;                                               <<01075>>10185000
         if (cis'udcnestlevel=0) or cis'udcexitbreak then      <<04603>>10190000
               errno := udc'flushed;  << also, flush udc's >>  <<01288>>10195000
      end;                                                              10200000
   end;                                                                 10205000
                                                               <<01360>>10210000
   skip'this'line:                                             <<01360>>10215000
                                                               <<01360>>10220000
end until errno <> -1;                                                  10225000
                                                                        10230000
outl:                                                                   10235000
end; << feedci >>                                                       10240000
$title "FINDCOMUSER"                                                    10245000
procedure findcomuser(comfn,uname,aname,udcsexist,userrec,     <<00884>>10250000
                                        filerec,errno);        <<00884>>10255000
   value comfn;                                                <<00884>>10260000
   integer comfn,userrec,filerec,errno;                        <<00884>>10265000
   logical udcsexist;                                          <<00884>>10270000
   byte array uname,aname;                                     <<00884>>10275000
   option uncallable;                                          <<00884>>10280000
comment                                                        <<00884>>10285000
   locates user & account in command file. starts by using     <<00884>>10290000
   record number kept in directory.  if this record number     <<00884>>10295000
   is not valid (i.e., the command file has changed since      <<00884>>10300000
   the record number was saved) then a linear search of the    <<00884>>10305000
   command file is performed. the record number in the         <<00884>>10310000
   directory is updated to match the current command file.     <<00884>>10315000
                                                               <<06034>>10320000
   parameters:                                                 <<06034>>10325000
      comfn:       input -- command file number                <<06034>>10330000
      uname:       input -- user name                          <<06034>>10335000
      aname:       input -- account name                       <<06034>>10340000
      udcsexist:  output -- true if udc's exist                <<06034>>10345000
      userrec:    output -- pointer to user in command file    <<06034>>10350000
      filerec:    output -- pointer to first user file entry   <<06034>>10355000
      errno:      output -- returned error code                <<06034>>10360000
;                                                              <<00884>>10365000
begin                                                          <<00884>>10370000
double                                                         <<00884>>10375000
   recno;                                                      <<00884>>10380000
array                                                          <<00884>>10385000
   rec'(0:comrecsizem1);                                       <<00884>>10390000
byte array                                                     <<00884>>10395000
   rec(*) = rec';                                              <<00884>>10400000
                                                               <<00884>>10405000
subroutine searchforuser;                                      <<00884>>10410000
   begin                                                       <<00884>>10415000
   userrec := 1;  << begin search at begining of file >>       <<00884>>10420000
   searchcomfile(comfn,uname,aname,userrec,filerec,errno);     <<00884>>10425000
   if errno = 0 then                                           <<00884>>10430000
         << found user. must update directory record number >> <<00884>>10435000
      udcdircwrite(uname,aname,udcsexist,userrec)              <<00884>>10440000
   else                                                        <<00884>>10445000
      begin                                                    <<00884>>10450000
      userrec := filerec := 0;                                 <<00884>>10455000
      if errno = eofound then errno := nosuchcomuser;          <<00884>>10460000
      end;                                                     <<00884>>10465000
   end;  << searchcomfile >>                                   <<00884>>10470000
                                                               <<00884>>10475000
errno := 0;                                                    <<00884>>10480000
udcdircread(uname,aname,udcsexist,userrec);                    <<00884>>10485000
if udcsexist then                                              <<00884>>10490000
   begin << verify that directory pointer is valid. >>         <<00884>>10495000
   freaddir(comfn,rec',comrecsize,double(userrec));            <<00884>>10500000
   if < then errno := comreadfail                              <<00884>>10505000
   else                                                        <<00884>>10510000
         << bad pointer in directory. must search. >>          <<00884>>10515000
      if > then searchforuser                                  <<00884>>10520000
      else                                                     <<00884>>10525000
         << verify this is the correct entry >>                <<00884>>10530000
         if rec'(comentrytype) = comuserentry and              <<00884>>10535000
            rec(comuname) = uname,(8) and                      <<00884>>10540000
            rec(comaname) = aname,(8) then                     <<00884>>10545000
               << found correct entry >>                       <<00884>>10550000
               filerec := rec'(comlink)                        <<00884>>10555000
         else                                                  <<00884>>10560000
               << bad pointer. must search. >>                 <<00884>>10565000
            searchforuser;                                     <<00884>>10570000
   end;                                                        <<00884>>10575000
                                                               <<00884>>10580000
end;  << findcomuser >>                                        <<00884>>10585000
$title "GETCOMREC"                                                      10590000
integer procedure getcomrec(comfn,errno);                               10595000
   value comfn;                                                         10600000
   integer comfn,errno;                                                 10605000
   option uncallable;                                                   10610000
comment returns record number of 1st free record in                     10615000
   command.pub.sys file                                                 10620000
;                                                                       10625000
                                                               <<03734>>10630000
<< assumptions:  this procedure assumes that command.pub.sys >><<03734>>10635000
<<    (file number = comfn ) was locked by the calling       >><<03734>>10640000
<<    procedure.                                             >><<03734>>10645000
                                                               <<03734>>10650000
begin                                                                   10655000
                                                                        10660000
array rec0(0:comrecsizem1);                                             10665000
array rec(0:comrecsizem1);                                              10670000
integer recno;                                                          10675000
                                                                        10680000
subroutine read(buf,rec);                                               10685000
   value rec;                                                           10690000
   array buf;                                                           10695000
   integer rec;                                                         10700000
begin                                                                   10705000
   freaddir(comfn,buf,comrecsize,double(rec));                          10710000
   if <> then                                                           10715000
   begin                                                                10720000
      errno := comreadfail;                                             10725000
      go outl;                                                          10730000
   end;                                                                 10735000
end; << read >>                                                         10740000
                                                                        10745000
subroutine write(buf,rec);                                              10750000
   value rec;                                                           10755000
   array buf;                                                           10760000
   integer rec;                                                         10765000
begin                                                                   10770000
   fwritedir(comfn,buf,comrecsize,double(rec));                         10775000
   if < then                                                            10780000
   begin                                                                10785000
      errno := comwritefail;                                            10790000
      go outl;                                                          10795000
   end                                                                  10800000
   else                                                                 10805000
   if > then                                                            10810000
   begin                                                                10815000
      errno := eofound;                                                 10820000
      go outl;                                                          10825000
   end;                                                                 10830000
end; << write >>                                                        10835000
                                                                        10840000
   errno := 0;                                                 <<03734>>10845000
   freaddir(comfn,rec0,comrecsize,0d);                                  10850000
   if < then errno := comreadfail                                       10855000
   else                                                                 10860000
   begin                                                                10865000
      if > then << unititialized file >>                                10870000
      begin                                                             10875000
         rec0 := 0;                                                     10880000
         move rec0(1) := rec0,(comrecsizem1);                           10885000
         rec0(comfreehead) := 1;                                        10890000
         write(rec0,0);                                                 10895000
      end;                                                              10900000
         << update head record >>                                       10905000
      rec0(comuse) := rec0(comuse) +1;                                  10910000
      if rec0(comuse) > rec0(commaxuse) then rec0                       10915000
         (commaxuse) := rec0(commaxuse) +1;                             10920000
      getcomrec:=recno:=rec0(comfreehead); << free rec no. >>           10925000
      freaddir(comfn,rec,comrecsize,double(rec0(comfreehead)));         10930000
      if > then << eof. expand file >>                                  10935000
      begin                                                             10940000
         rec(comlink):=0; << in case of error in setcatalog >>          10945000
         write(rec,rec0(comfreehead));                                  10950000
         rec0(comfreehead) := rec0(comfreehead) +1;                     10955000
         write(rec0,0);                                                 10960000
      end                                                               10965000
      else                                                              10970000
      if < then errno := comreadfail                                    10975000
      else                                                              10980000
      begin                                                             10985000
         << get next free rec & stuff in head>>                         10990000
         rec0(comfreehead) := rec(comlink);                             10995000
         write(rec0,0);                                                 11000000
         rec(comlink):=0; << in case of error in setcatalog >>          11005000
         write(rec,recno);                                              11010000
      end;                                                              11015000
   end;                                                                 11020000
                                                                        11025000
outl:                                                                   11030000
end; << getcomrec >>                                                    11035000
$title "INITUDC"                                                        11040000
procedure initudc( show, setcatcomfn );                        <<03734>>11045000
   value    show, setcatcomfn;                                 <<03734>>11050000
   logical  show;                                              <<03734>>11055000
   integer  setcatcomfn;                                       <<03734>>11060000
   option   uncallable, variable;                              <<03734>>11065000
comment                                                                 11070000
   opens command file & each udc file, then builds directory            11075000
   of command names & recnos in data segment. directory entry           11080000
   is as follows:                                                       11085000
   ******************************                                       11090000
   *l*o*h*b*      * entrysize   *   l = list                            11095000
   ******************************   o = logon                           11100000
   *      recno                 *   h = nohelp                          11105000
   ******************************   b = nobreak                         11110000
   *      bodyrecno             *                                       11115000
   ******************************                                       11120000
   *  file no.    * cmdlen      *                                       11125000
   ******************************                                       11130000
   * command (max. 16 bytes)    *                                       11135000
   /                            /                                       11140000
   ******************************                                       11145000
                                                                        11150000
   entrysize = 0 indicates end of directory.                            11155000
                                                                        11160000
;                                                                       11165000
                                                               <<04651>>11170000
<<                                                         >>  <<04651>>11175000
<< fix information:                                        >>  <<04651>>11180000
<<                                                         >>  <<04651>>11185000
<< * this fix causes logon udcs to execute on each level,  >>  <<04651>>11190000
<<   with the logon hierarchy of system-account-user.  at  >>  <<04651>>11195000
<<   most one logon udc will execute on each level, so the >>  <<04651>>11200000
<<   maximum number of executing logon udcs is three.  the >>  <<04651>>11205000
<<   hierarchy was chosen to allow system manager to en-   >>  <<04651>>11210000
<<   force any site-specific security check at logon       >>  <<04651>>11215000
<<   before users have a chance to perform any operations. >>  <<04651>>11220000
<<   normal udcs will continue to have the user-acct-sys   >>  <<04651>>11225000
<<   hierarchy that was designed to let system managers    >>  <<04651>>11230000
<<   remove specific commands from the ci set.             >>  <<04651>>11235000
<<                                                         >>  <<04651>>11240000
<<                                                          >> <<04631>>11245000
<< fix information:                                         >> <<04631>>11250000
<<                                                          >> <<04631>>11255000
<< * with this fix, udc's with option nohelp will not be    >> <<04631>>11260000
<<   displayed with the execution of                        >> <<04631>>11265000
<<   :setcatalog [ufiles..];show.  all option's for a udc   >> <<04631>>11270000
<<   will be displayed on one option line when ;show is     >> <<04631>>11275000
<<   specified.                                             >> <<04631>>11280000
<<   lockwords for the udc files are not displayed when     >> <<04631>>11285000
<<   ;show is specifed                                      >> <<04631>>11290000
<<                                                          >> <<04631>>11295000
<< fix information                                             <<06034>>11300000
<<                                                          >> <<06034>>11305000
<< * before this fix, if an error was found while building  >> <<06034>>11310000
<<   the udc directory upon logon no udcs would be put into >> <<06034>>11315000
<<   the directory.  this meant that if a user udc contained>> <<06034>>11320000
<<   an error (for instance, an illegal udc name) that user >> <<06034>>11325000
<<   would not get any system or account udcs as well as no >> <<06034>>11330000
<<   user udcs when he/she logged on.  this fix ignores the >> <<06034>>11335000
<<   level upon which the error occurred and tries to       >> <<06034>>11340000
<<   continue to build the directory starting at the next   >> <<06034>>11345000
<<   level (if one exists).                                 >> <<06034>>11350000
begin                                                                   11355000
                                                                        11360000
   entry initudcno; << don't do logon >>                                11365000
                                                                        11370000
                                                                        11375000
integer                                                                 11380000
   i,                                                          <<00416>>11385000
   i2,  <<  loop variable  >>                                  <<06034>>11390000
   fnx := -1,                                                  <<01510>>11395000
   fnx'level,  <<  first file number index for a level  >>     <<06034>>11400000
   udcdstn,                                                             11405000
   comfn  := 0,                                                <<03734>>11410000
   udcfn,                                                               11415000
   flen,                                                       <<04846>>11420000
   fglwdlen,          << udc file lockword length >>           <<04846>>11425000
   fglwderr,          << fgetlockword error.      >>           <<04846>>11430000
   len,                                                                 11435000
   dummy = len,                                                         11440000
   entrylen,                                                            11445000
   recno,         <<  pointer into udc file  >>                <<06034>>11450000
   recnonext,                                                           11455000
   comrecno,      <<  pointer into command file  >>            <<06034>>11460000
   errno,                                                               11465000
   offset:=0,     <<  pointer into directory as it is built  >><<06437>>11470000
   pass:=1,                                                    <<04631>>11475000
   olen:=10,                                                   <<04631>>11480000
   templen,                                                    <<04631>>11485000
   level'offset,  <<  start of a udc level in directory  >>    <<06034>>11490000
   oldoffset;                                                           11495000
                                                                        11500000
byte pointer                                                            11505000
   ptr,                                                                 11510000
   saveptr,                                                    <<01529>>11515000
   sptr;                                                                11520000
                                                                        11525000
logical                                                                 11530000
   havehelp:=false,                                            <<04631>>11535000
   havebreak:=false,                                           <<04631>>11540000
   havenologon:=false,                                         <<04631>>11545000
   havenolist:=false,                                          <<04631>>11550000
   haveoptions,                                                <<04631>>11555000
   havenohelp:=false,                                          <<04631>>11560000
   havenobreak:=false,                                         <<04631>>11565000
   havelist:=false,                                            <<04631>>11570000
   havelogon:=false,                                           <<04631>>11575000
   initialized:=false, <<  true if directory inited.  >>       <<06034>>11580000
   udcsexist,                                                  <<00884>>11585000
   oldcrit,                                                    <<04810>>11590000
   findcmd,                                                             11595000
   foundlogon,                                                          11600000
   foundanylogon := false,    << logon udc at any level. >>    <<04651>>11605000
   options,                                                             11610000
   findoption,                                                          11615000
   dologon;                                                             11620000
double num'recs,                                               <<04846>>11625000
       fentry'recno;          << file entry record number >>   <<04846>>11630000
                                                               <<04651>>11635000
integer array                                                  <<04651>>11640000
   logon'offsets(0:udctype'numlevels-1);                       <<04651>>11645000
                                                                        11650000
logical array optlinel(0:126);                                 <<04631>>11655000
byte array optline(*)=optlinel;                                <<04631>>11660000
logical array tcmd(0:500);                                     <<04631>>11665000
byte array tempcmd(*)=tcmd;                                    <<04631>>11670000
byte array udclevel(0:7);                                      <<00884>>11675000
byte array logoncmd(0:udctype'numlevels*(1+dirmaxcmdsize));    <<04651>>11680000
byte array user(0:7),account(0:7),wildcard(0:7);               <<00416>>11685000
array displaybuff'(0:udcbuffsize +2);                                   11690000
array buff'(*) = displaybuff'(2);                                       11695000
byte array buff(*) = buff';                                             11700000
array tempbuff'(0:udcrecsize);                                 <<04846>>11705000
byte array tempbuff(*) = tempbuff';                            <<04846>>11710000
byte array displaybuff(*) = displaybuff';                               11715000
integer array                                                  <<01510>>11720000
   fnums(0:maxscparmsm1);                                      <<01510>>11725000
                                                                        11730000
pointer dir'; byte pointer dir;                                         11735000
                                                                        11740000
                                                                        11745000
subroutine def'movetodseg;                                              11750000
                                                                        11755000
subroutine err(errno,fn);                                               11760000
   value errno,fn;integer errno,fn;                                     11765000
begin                                                                   11770000
   if errno > 0 then error(errno,ferr,fn);                              11775000
   go outl;                                                             11780000
end;  << err >>                                                         11785000
                                                                        11790000
subroutine uerr(errno,fn);                                              11795000
   value errno,fn;integer errno,fn;                                     11800000
begin << error on udc >>                                                11805000
   error(errno,udcferr,fn,buff(comfname));                              11810000
      << file name will be used only if fn=0>>                          11815000
   go outl;                                                             11820000
end;  << uerr >>                                                        11825000
                                                                        11830000
subroutine semerr(errno);                                               11835000
   value errno; integer errno;                                          11840000
begin << semantic error >>                                              11845000
      << stack overflow, bad udc file >>                                11850000
   error(errno,udcerr);                                                 11855000
   go outl;                                                             11860000
end; << semerr >>                                                       11865000
                                                               <<06034>>11870000
subroutine ignore'level;                                       <<06034>>11875000
comment                                                        <<06034>>11880000
  this routine is called in the event that an error is         <<06034>>11885000
  discovered while building the udc directory at logon (i.e.   <<06034>>11890000
  not if initudc is called from cxsetcatalog).  the current    <<06034>>11895000
  level of udcs in process of being built is ignored, which    <<06034>>11900000
  means resetting the current pointer into the directory       <<06034>>11905000
  back a bit and closing the files opened on that level.       <<06034>>11910000
  note that the variable i contains a value from 0 to 2        <<06919>>11915000
  indicating which level (user, account, system, respectively) <<06919>>11920000
  we are currently at.                                         <<06919>>11925000
                                                               <<06034>>11930000
  the user is issued a warning that a whole level was ignored. <<06034>>11935000
;                                                              <<06034>>11940000
                                                               <<06034>>11945000
begin                                                          <<06034>>11950000
  << offset is the directory offset, reset it to the       >>  <<06919>>11955000
  << previous level                                        >>  <<06919>>11960000
   offset := level'offset;                                     <<06919>>11965000
                                                               <<06034>>11970000
   <<  reset the logon offset, in case a logon udc found >>    <<06919>>11975000
   logon'offsets(i)  := -1;                                    <<06919>>11980000
                                                               <<06919>>11985000
   <<  close all files opened on that level  >>                <<06034>>11990000
   for i2 := fnx'level until fnx <<  for each file opened  >>  <<06034>>11995000
       do fclose(fnums(i2), 0, 0);  <<  say goodnight...  >>   <<06034>>12000000
                                                               <<06034>>12005000
<<  issue warning that a whole level of udc's is gone  >>      <<06034>>12010000
         case i of        <<  i is the level  >>               <<06034>>12015000
            begin                                              <<06034>>12020000
             errno := ign'userlevel;                           <<06034>>12025000
             errno := ign'acctlevel;                           <<06034>>12030000
             errno := ign'syslevel;                            <<06034>>12035000
            end;                                               <<06034>>12040000
         cierr(-errno);                                        <<06034>>12045000
end;  <<  ignore'level  >>                                     <<06034>>12050000
                                                                        12055000
                                                                        12060000
integer subroutine chkoption;                                           12065000
<< subroutine is called for each line of the udc body until >> <<04631>>12070000
<< findoptions goes false inside this routine.  it creates  >> <<04631>>12075000
<< a line containing the udc's user defined options.  the   >> <<04631>>12080000
<< line is printed in the calling routine after findoptions >> <<04631>>12085000
<< is false.  option lines must (and are treated as) follow >> <<04631>>12090000
<< immediately and sequentially after the udc command       >> <<04631>>12095000
<< definition.                                              >> <<04631>>12100000
<< only one of nohelp/help, nobreak/break, nolist/list      >> <<04631>>12105000
<< or nologon/logon is allowed.                             >> <<04631>>12110000
begin << returns bodyrecno >>                                           12115000
   findparm(buff,sptr,ptr);                                             12120000
   if sptr = "OPTION" then                                              12125000
   begin                                                                12130000
      @saveptr := @sptr;                                       <<01529>>12135000
      haveoptions:=true;                                       <<04631>>12140000
      chkoption := recnonext;                                           12145000
      nextparm( ptr, sptr, ptr );                              <<01529>>12150000
      while sptr <> 0 do                                                12155000
      begin                                                             12160000
                                                               <<01529>>12165000
         case optiono(sptr) of                                          12170000
         begin                                                          12175000
            <<0>> error(-unknownoption,synerr,sptr,saveptr);   <<04631>>12180000
            <<1>> if havelist=false then                       <<04631>>12185000
                     if havenolist then cierr(-listwarn)       <<04631>>12190000
                        else                                   <<04631>>12195000
                        begin                                  <<04631>>12200000
                        options.cis'optlist:=true;             <<04631>>12205000
                        move optline(olen):=" LIST,";          <<04631>>12210000
                        olen:=olen+6;                          <<04631>>12215000
                        havelist:=true;                        <<04631>>12220000
                        end;                                   <<04631>>12225000
            <<2>> if havelogon=false then                      <<04631>>12230000
                     if havenologon then cierr(-logonwarn)     <<04631>>12235000
                        else                                   <<04631>>12240000
                        begin                                  <<04631>>12245000
                        move optline(olen):=" LOGON,";         <<04631>>12250000
                        if not foundlogon<<1st logon udc,this>><<04631>>12255000
                           then logon'offsets(i)  << level >>  <<04631>>12260000
                                :=oldoffset;                   <<04631>>12265000
                        foundanylogon:=foundlogon:=true;       <<04631>>12270000
                        options.cis'optlogon:=true;            <<04631>>12275000
                        olen:=olen+7;                          <<04631>>12280000
                        havelogon:=true;                       <<04631>>12285000
                        end;                                   <<04631>>12290000
            <<3>> if havenohelp=false then                     <<04631>>12295000
                     if havehelp then cierr(-nohelpwarn)       <<04631>>12300000
                        else                                   <<04631>>12305000
                        begin                                  <<04631>>12310000
                        options.cis'optnohelp:=true;           <<04631>>12315000
                        move optline(olen):=" NOHELP,";        <<04631>>12320000
                        olen:=olen+8;                          <<04631>>12325000
                        havenohelp:=true;                      <<04631>>12330000
                        end;                                   <<04631>>12335000
            <<4>> if havenobreak=false then                    <<04631>>12340000
                     if havebreak then cierr(-nobreakwarn)     <<04631>>12345000
                        else                                   <<04631>>12350000
                        begin                                  <<04631>>12355000
                        havenobreak:=true;                     <<04631>>12360000
                        options.cis'optnobreak:=true;          <<04631>>12365000
                        move optline(olen):=" NOBREAK,";       <<04631>>12370000
                        olen:=olen+9;                          <<04631>>12375000
                        end;                                   <<04631>>12380000
            <<5>> if havenolist=false then                     <<04631>>12385000
                     if havelist then cierr(-nolistwarn)       <<04631>>12390000
                        else                                   <<04631>>12395000
                        begin                                  <<04631>>12400000
                        move optline(olen):=" NOLIST,";        <<04631>>12405000
                        olen:=olen+8;                          <<04631>>12410000
                        havenolist:=true;                      <<04631>>12415000
                        end;                                   <<04631>>12420000
            <<6>> if havenologon=false then                    <<04631>>12425000
                     if havelogon then cierr(-nologonwarn)     <<04631>>12430000
                        else                                   <<04631>>12435000
                        begin                                  <<04631>>12440000
                        move optline(olen):=" NOLOGON,";       <<04631>>12445000
                        olen:=olen+9;                          <<04631>>12450000
                        havenologon:=true;                     <<04631>>12455000
                        end;                                   <<04631>>12460000
            <<7>> if havehelp=false then                       <<04631>>12465000
                     if havenohelp then cierr(-helpwarn)       <<04631>>12470000
                        else                                   <<04631>>12475000
                        begin                                  <<04631>>12480000
                        move optline(olen):=" HELP,";          <<04631>>12485000
                        olen:=olen+6;                          <<04631>>12490000
                        havehelp:=true;                        <<04631>>12495000
                        end;                                   <<04631>>12500000
            <<8>> if havebreak = false then                    <<04631>>12505000
                     if havenobreak then cierr(-breakwarn)     <<04631>>12510000
                        else                                   <<04631>>12515000
                        begin                                  <<04631>>12520000
                        move optline(olen):=" BREAK,";         <<04631>>12525000
                        olen:=olen+7;                          <<04631>>12530000
                        havebreak:=true;                       <<04631>>12535000
                        end;                                   <<04631>>12540000
              end; << case >>                                  <<04631>>12545000
         nextparm( ptr, sptr, ptr );                           <<01529>>12550000
                                                               <<01529>>12555000
      end;                                                              12560000
   end                                                                  12565000
   else                                                                 12570000
   begin << no "OPTION">>                                               12575000
      findoption := false;                                              12580000
      chkoption := recno;                                               12585000
   end;                                                                 12590000
end; << chkoption >>                                                    12595000
                                                                        12600000
                                                                        12605000
   << initudc main body >>                                              12610000
                                                                        12615000
dologon := true;   << called from commandinterp >>                      12620000
go main;                                                                12625000
                                                                        12630000
                                                                        12635000
initudcno:  << don't do logon command while logged on>>                 12640000
            << called from :setcatalog               >>                 12645000
move optline(0):="    OPTION";                                 <<04631>>12650000
                                                                        12655000
dologon := false;                                                       12660000
comfn := setcatcomfn;  << cxsetcatalog has already opened and>><<03734>>12665000
                       << locked command.pub.sys.            >><<03734>>12670000
                                                               <<03734>>12675000
                                                                        12680000
main:                                                                   12685000
fglwderr := 0;         << initialize fgetlockword error >>     <<04846>>12690000
logoncmd := cr;     << blank out logon udc command image. >>   <<04651>>12695000
move logoncmd(1)                                               <<04651>>12700000
   := logoncmd, (udctype'numlevels*(1+dirmaxcmdsize) );        <<04651>>12705000
                                                               <<04651>>12710000
logon'offsets(udctype'user) := -1;     << this will hold the >><<04651>>12715000
logon'offsets(udctype'account) := -1;  << directory offsets  >><<04651>>12720000
logon'offsets(udctype'system) := -1;   << for logon udcs.    >><<04651>>12725000
                                                                        12730000
move wildcard:="@       ";                                     <<00416>>12735000
zsize(udcinitstacksize);                                                12740000
move displaybuff' := "    ";                                            12745000
if dologon then        << not called by cxsetcatalog.        >><<03734>>12750000
begin                                                          <<03734>>12755000
   move buff := "COMMAND.PUB.SYS ";                            <<03734>>12760000
   comfn := fopen( buff, 1, %346 );  << old; shr,lock,exec.  >><<03734>>12765000
   if <> then err( comopenfail, comfn );                       <<03734>>12770000
   oldcrit := setcritical;                                     <<04810>>12775000
   flock( comfn, true );                                       <<03734>>12780000
   if <> then err( comlockfail, comfn );                       <<03734>>12785000
end;                                                           <<03734>>12790000
who(,,,user,,account); <<get user's name & account>>           <<00416>>12795000
i:=udctype'user-1;<<init loop ctr for scan thru udc levels>>   <<00416>>12800000
                                                               <<00884>>12805000
<<*************************************>>                      <<00884>>12810000
<<    start of loop thru udc levels    >>                      <<00884>>12815000
<<*************************************>>                      <<00884>>12820000
                                                               <<00884>>12825000
while (i:=i+1)<=udctype'system do                              <<00416>>12830000
begin                                                          <<00416>>12835000
                                                               <<04651>>12840000
   foundlogon := false;  << marks logon udc, this level. >>    <<04651>>12845000
   case i of                                                   <<00416>>12850000
   begin                                                       <<00416>>12855000
      findcomuser(comfn,user,account,udcsexist,recno,          <<00884>>12860000
                                          comrecno,errno);     <<00884>>12865000
      findcomuser(comfn,wildcard,account,udcsexist,recno,      <<00884>>12870000
                                          comrecno,errno);     <<00884>>12875000
      findcomuser(comfn,wildcard,wildcard,udcsexist,recno,     <<00884>>12880000
                                        comrecno,errno);       <<00884>>12885000
   end;                                                        <<00416>>12890000
   if errno <> 0 then                                          <<00884>>12895000
      if errno = nosuchcomuser then                            <<00884>>12900000
         begin                                                 <<00884>>12905000
         case i of                                             <<00884>>12910000
            begin                                              <<00884>>12915000
            move udclevel := ("USER",0);                       <<00884>>12920000
            move udclevel := ("ACCOUNT",0);                    <<00884>>12925000
            move udclevel := ("SYSTEM",0);                     <<00884>>12930000
            end;                                               <<00884>>12935000
         cierr(-nosuchcomuser,,0,@udclevel);                   <<00884>>12940000
         go to outloop;                                        <<00884>>12945000
         end                                                   <<00884>>12950000
      else err(errno,comfn);                                   <<00884>>12955000
                                                               <<00884>>12960000
if not udcsexist then go to outloop;                           <<00884>>12965000
                                                                        12970000
if initialized then go to gotinit;                             <<06034>>12975000
initialized:=true;                                             <<06034>>12980000
   << check space for dir, get space >>                                 12985000
assemble(zero; lra s-0);                                                12990000
@dir' := tos;                                                           12995000
zsize(@dir' +dirsizem1);                                                13000000
if > then semerr(stackoverflow);                                        13005000
tos := dirsizem1;                                                       13010000
assemble(adds 0);                                                       13015000
@dir := @dir'&lsl(1);                                                   13020000
                                                                        13025000
   << zero directory >>                                                 13030000
dir' := 0;                                                              13035000
move dir'(1) := dir',(dirsizem1);                                       13040000
                                                                        13045000
<< set up for big loop >>                                               13050000
oldoffset := offset := 0;                                               13055000
gotinit:                                                       <<00416>>13060000
   <<**************************************************>>      <<00884>>13065000
   <<    start of loop thru udc files at this level    >>      <<00884>>13070000
   <<**************************************************>>      <<00884>>13075000
                                                               <<00884>>13080000
level'offset := offset; << remember where the level starts  >> <<06034>>13085000
fnx'level    := fnx + 1;<< index to first fnum for level  >>   <<06034>>13090000
do begin                                                                13095000
   freaddir(comfn,buff',comrecsize,double(comrecno));                   13100000
   if <> then err(comreadfail,comfn);                                   13105000
   fentry'recno := double(comrecno);                           <<04846>>13110000
   comrecno := buff'(comlink);                                          13115000
   udcfn := pvopen(buff(comfname),1,%200);<<old,ear>>                   13120000
   if <> then                                                           13125000
   begin                                                                13130000
      scan buff(comfname) until "/",1;                                  13135000
      @ptr := tos;                                                      13140000
      if nocarry then << get rid of password in file name >>            13145000
      begin                                                             13150000
         move ptr(1) := ptr(1) while an,1;                              13155000
         @sptr := tos;                                                  13160000
         move ptr := sptr, (19); << overlay password >>                 13165000
      end;                                                              13170000
      error(udcopenfail,udcferr,udcfn,buff(comfname));                  13175000
      if not dologon  << if we were called from setcatalog >>  <<06034>>13180000
      then goto outl << then return, all udc's are ignored >>  <<06034>>13185000
      else begin   << a logon: ignore udc's on this level  >>  <<06034>>13190000
        ignore'level;  <<  reset directory and warn user  >>   <<06034>>13195000
        goto outloop;  << go try the next (if any) level >>    <<06034>>13200000
      end;                                                     <<06034>>13205000
   end                                                                  13210000
   else                                                                 13215000
   begin                                                                13220000
      fnums( fnx := fnx + 1 ) := udcfn;  << save file num >>   <<01510>>13225000
                                                               <<04846>>13230000
   << if udcs are being initialized through cxsetcatalog,  >>  <<04846>>13235000
   << then we must ensure that udc file lockwords appear   >>  <<04846>>13240000
   << in the file entries in command.pub.sys.  this can    >>  <<04846>>13245000
   << only be done after the file is opened, so these      >>  <<04846>>13250000
   << actions are performed here as opposed to within the  >>  <<04846>>13255000
   << cxsetcatalog executor.  special handling needs to    >>  <<04846>>13260000
   << happen if the call to fgetlockword fails--in initudc >>  <<04846>>13265000
   << this is signaled by a non-zero fglwderr; in          >>  <<04846>>13270000
   << cxsetcatalog, this is signaled by a negative udcdstn.>>  <<04846>>13275000
      if not dologon then         << cxsetcatalog call.        <<04846>>13280000
      begin                                                    <<04846>>13285000
                                                               <<04846>>13290000
         scan buff(comfname) until "/.", 1;                    <<04846>>13295000
         if carry                                              <<04846>>13300000
            then del     << lockword already in entry.     >>  <<04846>>13305000
         else                                                  <<04846>>13310000
         begin                                                 <<04846>>13315000
                                                               <<04846>>13320000
         << add lockword to command.pub.sys entry.         >>  <<04846>>13325000
            flen := tos - @buff(comfname);                     <<04846>>13330000
            tempbuff := " ";                                   <<04846>>13335000
            move tempbuff(1) := tempbuff, (35);                <<04846>>13340000
            fglwdlen := 0;                                     <<04846>>13345000
            move tempbuff(comfname) := buff(comfname), (flen); <<04846>>13350000
            tempbuff( comfname+flen ) := "/";                  <<04846>>13355000
            fglwderr := fgetlockword( udcfn,                   <<04846>>13360000
                           tempbuff(comfname+flen+1),          <<04846>>13365000
                           fglwdlen                    );      <<04846>>13370000
            if fglwderr <> 0 then go outl;                     <<04846>>13375000
                                                               <<04846>>13380000
            if fglwdlen <> 0 then                              <<04846>>13385000
            begin                                              <<04846>>13390000
                                                               <<04846>>13395000
            << if the lockword length is zero, then the    >>  <<04846>>13400000
            << file has no lockword.                       >>  <<04846>>13405000
               tempbuff'(comlink) := buff'(comlink);           <<04846>>13410000
               tempbuff'(comentrytype) := buff'(comentrytype); <<04846>>13415000
               move tempbuff(comfname+flen+fglwdlen+1)         <<04846>>13420000
                    := buff(comfname+flen),                    <<04846>>13425000
                 (36-(comfname+flen));                         <<04846>>13430000
               fwritedir( comfn, tempbuff',                    <<04846>>13435000
                          comrecsize, fentry'recno );          <<04846>>13440000
               if <> then err( comwritefail, comfn );          <<04846>>13445000
                                                               <<04846>>13450000
            end;                                               <<04846>>13455000
                                                               <<04846>>13460000
         end;                                                  <<04846>>13465000
                                                               <<04846>>13470000
      end;  << adding lockwords for setcataloged files. >>     <<04846>>13475000
                                                               <<04846>>13480000
                                                               <<04631>>13485000
      if show then begin                                       <<04631>>13490000
              scan buff(comfname) until "/",1;                 <<04631>>13495000
              @ptr:=tos;                                       <<04631>>13500000
              if nocarry then begin << get rid of password >>  <<04631>>13505000
                              move ptr(1):=ptr(1) while an,1;  <<04631>>13510000
                              @sptr:=tos;                      <<04631>>13515000
                              move ptr:=sptr,(19);             <<04631>>13520000
                              end;                             <<04631>>13525000
              genmsg(-1,@buff(comfname));                      <<04631>>13530000
              end;                                             <<04631>>13535000
         << display file name >>                                        13540000
                                                                        13545000
      fgetinfo(udcfn,,,,,,,,,,num'recs);                       <<01306>>13550000
      if num'recs = 0d then semerr(udcempty);                  <<01306>>13555000
         << set up for loop >>                                          13560000
      recno := recnonext := 0;                                          13565000
      findcmd := true;                                                  13570000
      do begin << whirl thru file & build directory >>                  13575000
         readfile(udcfn,recnonext,buff',errno);                         13580000
                                                               <<04631>>13585000
         if errno = 0 and show then                            <<01532>>13590000
         begin                                                 <<01532>>13595000
            scan displaybuff until 0, 1;                       <<01532>>13600000
            len := tos - @displaybuff;                         <<01532>>13605000
             if findcmd then                                   <<04631>>13610000
                begin                                          <<04631>>13615000
                haveoptions:=false;                            <<04631>>13620000
                move tempcmd(0) :=displaybuff,(len);           <<04631>>13625000
                pass:=1;                                       <<04631>>13630000
                templen:=len;                                  <<04631>>13635000
                end;                                           <<04631>>13640000
         end;                                                  <<01532>>13645000
         if errno <> 0 and errno <> eofound then                        13650000
         begin                                                          13655000
            if errno = ampersanderr then semerr(ampersanderr)           13660000
            else uerr(errno,udcfn);                                     13665000
         end;                                                           13670000
         if errno = eofound then buff := "*" else errno:=-1;            13675000
         upshift(buff);  << upshift everything >>                       13680000
         if findcmd then                                                13685000
         begin                                                          13690000
            if errno <> eofound then                                    13695000
            begin                                                       13700000
               options := findcmd := false;                             13705000
               findoption := true;                                      13710000
                     scan buff until " ",1;                    <<01023>>13715000
                     len := tos - @buff;                       <<01023>>13720000
                     if len > dirmaxcmdsize then               <<01023>>13725000
                        begin                                  <<01023>>13730000
                            << command over 16 chars >>        <<06034>>13735000
                            error(cmdtoolong,if show then      <<01023>>13740000
                            synerrnol else synerr,buff,buff);  <<01531>>13745000
                            if not dologon  << from setcatalog <<06034>>13750000
                            then goto outl  << return >>       <<06034>>13755000
                            else begin  <<   ignore level  >>  <<06034>>13760000
                               ignore'level;  << reset dir. >> <<06034>>13765000
                               goto outloop;  << next level >> <<06034>>13770000
                             end;                              <<06034>>13775000
                        end;                                   <<01023>>13780000
               if buff <> alpha then                           <<01531>>13785000
               begin                                           <<01531>>13790000
                  << command not alpha  >>                     <<06034>>13795000
                  error(cmdnotalpha,if show then synerrnol     <<01531>>13800000
                        else synerr, buff, buff            );  <<01531>>13805000
                  if not dologon  << from setcatalog >>        <<06034>>13810000
                  then goto outl  << return, we do nothing >>  <<06034>>13815000
                  else begin  <<  logging on: ignore level >>  <<06034>>13820000
                     ignore'level;  << reset directory >>      <<06034>>13825000
                     goto outloop;  << try next level >>       <<06034>>13830000
                  end;                                         <<06034>>13835000
               end;                                            <<01531>>13840000
               move dir(offset + dircmd) := buff while an, 1;  <<01531>>13845000
               len := tos - @dir(offset + dircmd);             <<01531>>13850000
               if not foundlogon then                                   13855000
               begin                                                    13860000
                  move logoncmd( i*(1+dirmaxcmdsize) )         <<04651>>13865000
                     := dir( offset + dircmd ), (len);         <<04651>>13870000
                  logoncmd( i*(1+dirmaxcmdsize) + len )        <<04651>>13875000
                     := cr;  << stopper for the ci >>          <<04651>>13880000
               end;                                                     13885000
               entrylen := dirheadsize +(len+1)&lsr(1);                 13890000
               dir(offset):=i;<<init list area with udctype>>  <<00416>>13895000
               dir(offset +direntrysize):=entrylen;<<words>>            13900000
               dir(offset +dirfileno) := udcfn;                         13905000
               dir(offset +dircmdlen) := len;                           13910000
               dir'(offset&lsr(1) +dirrecno) := recno;                  13915000
               oldoffset := offset;                                     13920000
               offset := offset +entrylen*2;                            13925000
               if offset >= dirsizeb then err(                          13930000
                  toomanycmdsfordir,-1);                                13935000
            end;                                                        13940000
         end                                                            13945000
         else                                                           13950000
         begin                                                          13955000
            if findoption then dir'(oldoffset&lsr(1) +         <<01127>>13960000
               dirbodyrecno) := chkoption;                     <<01127>>13965000
            if findoption =false                               <<04631>>13970000
            then if((options.cis'optnohelp=false)land(show))   <<04631>>13975000
             then begin                                        <<04631>>13980000
                  if pass = 1 then                             <<04631>>13985000
                     begin                                     <<04631>>13990000
                     print(tcmd,-templen,0);                   <<04631>>13995000
                     if haveoptions=true then                  <<04631>>14000000
                     print(optlinel,-(olen-1),0);              <<04631>>14005000
                     pass:=0;                                  <<04631>>14010000
                     end;                                      <<04631>>14015000
                  print(displaybuff',-len,0);                  <<04631>>14020000
                  end;                                         <<04631>>14025000
            if buff = "*" then                                 <<01127>>14030000
            begin                                              <<01127>>14035000
               findcmd := true;                                <<01127>>14040000
               << now stuff all options >>                     <<01127>>14045000
               tos := dir'(oldoffset&lsr(1));                  <<01127>>14050000
               dir'(x) := tos lor options;                     <<01127>>14055000
                     havehelp:=false;                          <<04631>>14060000
                     havebreak:=false;                         <<04631>>14065000
                     havenologon:=false;                       <<04631>>14070000
                     havenolist:=false;                        <<04631>>14075000
                     olen:=10;                                 <<04631>>14080000
                     havenohelp:=false;                        <<04631>>14085000
                     havenobreak:=false;                       <<04631>>14090000
                     havelogon:=false;                         <<04631>>14095000
                     havelist:=false;                          <<04631>>14100000
            end;                                               <<01127>>14105000
         end;                                                           14110000
         recno := recnonext;                                            14115000
      end until errno <> -1;                                            14120000
   end;                                                                 14125000
end until comrecno = 0;                                                 14130000
                                                               <<00884>>14135000
   <<**************************************************>>      <<00884>>14140000
   <<    end of loop thru udc files at this level      >>      <<00884>>14145000
   <<**************************************************>>      <<00884>>14150000
                                                               <<00884>>14155000
outloop:                                                       <<00416>>14160000
end;                                                           <<00416>>14165000
                                                               <<00884>>14170000
<<*************************************>>                      <<00884>>14175000
<<    end of loop thru udc levels      >>                      <<00884>>14180000
<<*************************************>>                      <<00884>>14185000
                                                               <<00884>>14190000
if offset = 0 then   <<  0 offset means no directory ...  >>   <<06034>>14195000
   go to outl;       <<  and thus no udc's  >>                 <<06034>>14200000
<< create a zero filled "entry" at the end of the udc >>       <<07366>>14205000
<< dst the max. size of an entry (12 words plus one for>>      <<07366>>14210000
<< a delimiter).  this is done so that if the udc being>>      <<07366>>14215000
<< executed is the last udc in the dst we do not look  >>      <<07366>>14220000
<< any further to try and match up the command names   >>      <<07366>>14225000
<< in the body of that udc with any udc names in that dst>>    <<07366>>14230000
move dir(offset +direntrysize) := 26(0);<<dir delimiter>>      <<07366>>14235000
offset := offset +26; << for extra 0's at end of dir. >>       <<07366>>14240000
offset := offset&lsr(1) +dirhead; << in words >>               <<06920>>14245000
<< len is the # of sectors for the data segment >>             <<06920>>14250000
len := logical(offset+127) land %177600;                                14255000
udcdstn := getdataseg(len,len);                                         14260000
if udcdstn = 0 then err(getdatasegerr,-1);                              14265000
movetodseg(udcdstn,0,@dir',offset);                                     14270000
                                                                        14275000
udcdstno := udcdstn; << set udc on globally >>                 <<04603>>14280000
                                                                        14285000
   << give back directory stack space >>                                14290000
tos := dirsizem1;                                                       14295000
assemble(subs 0); << now can do udc >>                                  14300000
                                                                        14305000
<< close command.pub.sys only if it was opened in initudc.   >><<03767>>14310000
<< do not close the file if initudcno (from cxsetcatalog) was>><<03767>>14315000
<< the invoking entry point.  fclose will handle unlocking   >><<03767>>14320000
<< the file.                                                 >><<03767>>14325000
if dologon then                                                <<04810>>14330000
begin                                                          <<04810>>14335000
   fclose( comfn, 0, 0 );                                      <<04810>>14340000
   resetcritical( oldcrit );                                   <<04810>>14345000
end;                                                           <<04810>>14350000
                                                               <<03767>>14355000
if dologon and foundanylogon then                              <<04651>>14360000
begin                                                                   14365000
   comment:                                                    <<00863>>14370000
      a check is made at this point to make sure we don't      <<00863>>14375000
      execute a udc at logon that happens to have the same     <<00863>>14380000
      name as a logon udc at a lower (i.e., acct or sys) udc   <<00863>>14385000
      level;                                                   <<00863>>14390000
                                                               <<04651>>14395000
<< logon udcs are executed in the system, account, user  >>    <<04651>>14400000
<< order, with only one udc per level executed.          >>    <<04651>>14405000
i := udctype'system;                                           <<04651>>14410000
do                                                             <<04651>>14415000
begin                                                          <<04651>>14420000
   offset := logon'offsets(i);                                 <<04651>>14425000
   if offset > -1 then                      << found logon >>  <<04651>>14430000
   begin                                                       <<04651>>14435000
                                                               <<04651>>14440000
    offset := offset / 2;  << searchudc expects offset to  >>  <<04651>>14445000
    oldoffset := offset;   << be a word index into dir.    >>  <<04651>>14450000
    if searchudc( logoncmd( i*(1+dirmaxcmdsize) ), offset,     <<04651>>14455000
                  udcfn, recno, recno, options )               <<04651>>14460000
      then                                                     <<00863>>14465000
   begin                                                       <<00863>>14470000
      if options.cis'optlogon then                             <<04603>>14475000
      begin                                                    <<00863>>14480000
         move cis'bcomimage                                    <<04651>>14485000
             := logoncmd( i * (1+dirmaxcmdsize) ),             <<04651>>14490000
                (dirmaxcmdsize+1);  << include the cr. >>      <<04651>>14495000
         udc( cis'bcomimage, oldoffset );                      <<04651>>14500000
      end;                                                     <<00863>>14505000
   end                                                         <<00863>>14510000
   else                                                        <<00863>>14515000
      suddendeath(535); << couldn't find logon cmd in dir >>   <<00863>>14520000
                                                               <<04651>>14525000
   end;                                                        <<04651>>14530000
                                                               <<04651>>14535000
end until (i := i-1) < udctype'user;                           <<04651>>14540000
                                                               <<04651>>14545000
end;                                                                    14550000
                                                               <<03767>>14555000
                                                               <<03767>>14560000
return;                                                                 14565000
                                                                        14570000
   << normal exit >>                                                    14575000
                                                                        14580000
outl:                                                                   14585000
                                                               <<03767>>14590000
<< close command.pub.sys only if it was opened in initudc.   >><<03767>>14595000
<< do not close the file if initudcno (from cxsetcatalog) was>><<03767>>14600000
<< the invoking entry point.  fclose will handle unlocking   >><<03767>>14605000
<< the file.                                                 >><<03767>>14610000
if dologon then                                                <<04810>>14615000
begin                                                          <<04810>>14620000
   fclose( comfn, 0, 0 );                                      <<04810>>14625000
   resetcritical( oldcrit );                                   <<04810>>14630000
end;                                                           <<04810>>14635000
                                                               <<04846>>14640000
   << if fgetlockword failed, inform cxsetcatalog.      >>     <<04846>>14645000
      if fglwderr <> 0 then                                    <<04846>>14650000
      begin                                                    <<04846>>14655000
         udcdstno := -1;                                       <<04846>>14660000
         ferror'( udcfn, fglwderr );                           <<04846>>14665000
         << cxsetcatalog prints ci error. >>                   <<04846>>14670000
      end;                                                     <<04846>>14675000
                                                               <<04846>>14680000
for i := fnx step -1 until 0  << close udcfile if error >>     <<01510>>14685000
   do  fclose( fnums(i), 0, 0 );                               <<01510>>14690000
                                                               <<04846>>14695000
end; << initudc >>                                                      14700000
$title "OPTIONO"                                                        14705000
integer procedure optiono(string);                                      14710000
   value string;                                                        14715000
   byte pointer string;                                                 14720000
   option internal;                                                     14725000
comment                                                                 14730000
   returns an index (option no.) into the array of                      14735000
   valid names following "OPTION"                                       14740000
;                                                                       14745000
begin                                                                   14750000
                                                                        14755000
integer len;                                                            14760000
                                                                        14765000
byte array dict(*) = pb :=                                              14770000
   6,4,"LIST",    << 1 >>                                               14775000
   7,5,"LOGON",   << 2 >>                                               14780000
   8,6,"NOHELP",  << 3 >>                                               14785000
   9,7,"NOBREAK", << 4 >>                                               14790000
   8,6,"NOLIST",  << 5 >>   << default options >>              <<01529>>14795000
   9,7,"NOLOGON", << 6 >>                                      <<01529>>14800000
   6,4,"HELP",    << 7 >>                                      <<01529>>14805000
   7,5,"BREAK",   << 8 >>                                      <<01529>>14810000
   0;                                                                   14815000
                                                                        14820000
byte array endict(*) = pb := 0; << end address of dict >>               14825000
                                                                        14830000
byte pointer dictp;                                                     14835000
                                                                        14840000
tos := 0;                                                               14845000
@dictp := @s0 &lsl(1);      << byte address        >>                   14850000
tos := x := (@endict -@dict -1) &lsr(1);                                14855000
                            << word length of dict >>                   14860000
assemble( adds 0);          << allocte space       >>                   14865000
tos := @dictp &lsr(1);      << word adr target     >>                   14870000
tos := @dict &lsr(1);       << word adr source     >>                   14875000
tos := x;                   << count               >>                   14880000
assemble( move pb );        << put dict into stack >>                   14885000
                                                                        14890000
move string := string while ans,1;                                      14895000
len := tos -@string;                                                    14900000
                                                                        14905000
optiono := search(string,len,dictp);                                    14910000
                                                                        14915000
end; << optiono >>                                                      14920000
$title "PARSECOM"                                                       14925000
procedure parsecom(comptr,numheadparms,parmsinfo,errno);                14930000
   value comptr,numheadparms;                                           14935000
   byte pointer comptr;                                                 14940000
   integer numheadparms,errno;                                          14945000
   array parmsinfo;                                                     14950000
   option uncallable;                                                   14955000
comment                                                                 14960000
   parses image typed at terminal & matches parms with                  14965000
   those found in udchead.                                              14970000
;                                                                       14975000
begin                                                                   14980000
                                                                        14985000
integer                                                                 14990000
   parmcount,                                                           14995000
   plen,                                                                15000000
   count,                                                               15005000
   dlen;                                                                15010000
byte pointer                                                            15015000
   saveimage,                                                           15020000
   ptr,                                                                 15025000
   formalnameptr,                                                       15030000
   badspotptr := @formalnameptr,                                        15035000
   hptr;                                                                15040000
logical                                                                 15045000
   keyword;                                                             15050000
                                                                        15055000
subroutine err(errn,ptr);                                               15060000
   value errn; integer errn;                                            15065000
   byte array ptr;                                                      15070000
begin                                                                   15075000
   errno := errn;                                                       15080000
   error(errno,imagerr,ptr,saveimage);                                  15085000
   go outl;                                                             15090000
end; << err >>                                                          15095000
                                                                        15100000
@saveimage := @comptr;                                                  15105000
keyword := false;                                                       15110000
parmcount := errno := 0;                                                15115000
                                                                        15120000
   << find 1st non-blank after command >>                               15125000
scan comptr while " ",1;                                                15130000
assemble(dup);                                                          15135000
move * := * while ans,1;                                                15140000
scan * while " ",1;                                                     15145000
@ptr := tos;                                                            15150000
                                                                        15155000
if ptr = "," or ptr = ";" then parmcount := 1;                          15160000
   << at delimiter ?                        >>                          15165000
   << positional parms, 1st parm is omitted >>                          15170000
while ptr <> 0 do                                                       15175000
begin                                                                   15180000
   parmcount := parmcount +1;                                           15185000
   if parmcount > udcmaxparms then err(toomanyparms,ptr(1));   <<01125>>15190000
   if parmcount > numheadparms then err(excessparms,ptr(1));   <<01125>>15195000
   plen := nextparm(ptr,comptr,ptr);                                    15200000
   if < then err(noclosequote,comptr);                                  15205000
   if = then                                                            15210000
   begin                                                                15215000
      if keyword then err(expectparm,comptr);                           15220000
   end                                                                  15225000
   else                                                                 15230000
   begin                                                                15235000
         << look for "=" to ind. keyword >>                             15240000
      if parmcount = 1 and ptr = "=" then keyword := true;              15245000
            << do not allow positional and keyworded >>        <<01049>>15250000
            << at the same time.                     >>        <<01049>>15255000
        if (keyword land ptr <> "=") or                        <<01049>>15260000
           (not keyword land ptr = "=") then                   <<01049>>15265000
           err(notypemix,comptr);                              <<01049>>15270000
      if not keyword then                                               15275000
      begin << place into 'default' >>                                  15280000
         parmsinfo((parmcount -1)*3 +2) := @comptr;                     15285000
         parmsinfo((parmcount -1)*3).(8:8) := plen;                     15290000
      end                                                               15295000
      else                                                              15300000
      begin << keyword >>                                               15305000
                                                                        15310000
            << check out formal name >>                                 15315000
         if comptr <> alpha then err(fmlnamenotalpha,comptr);           15320000
                                                                        15325000
            << upshift >>                                               15330000
         move comptr := comptr while ans,1;                             15335000
         @badspotptr := tos;                                            15340000
         if @comptr +plen <> @badspotptr then err(                      15345000
            invformalname,badspotptr);                                  15350000
                                                                        15355000
         @formalnameptr := @comptr; <<formal name>>                     15360000
            << now find 2nd part of parm pair>>                         15365000
         dlen := nextparm(ptr,comptr,ptr);                              15370000
         if < then err(noclosequote,ptr);                               15375000
         if = then err(expectparm,ptr);                                 15380000
            << now look for match >>                                    15385000
         count := -1;                                                   15390000
         while (count := count +1) < numheadparms do                    15395000
         begin                                                          15400000
            @hptr := parmsinfo(count*3 +1);                             15405000
            if plen = integer(parmsinfo(count*3).(0:8)) then            15410000
               if formalnameptr = hptr,(plen) then                      15415000
            begin << match >>                                           15420000
               if dlen > 0 then                                         15425000
               begin                                                    15430000
                  parmsinfo(count*3).(8:8) := dlen;                     15435000
                  parmsinfo(count*3 +2) := @comptr;                     15440000
                  go match;                                             15445000
               end;                                                     15450000
            end;                                                        15455000
         end;                                                           15460000
            << no match >>                                              15465000
         err(unknownparm,comptr);                                       15470000
match:                                                                  15475000
      end; << keyword used >>                                           15480000
   end;                                                                 15485000
end; << loop >>                                                         15490000
outl:                                                                   15495000
                                                                        15500000
end; << parsecom >>                                                     15505000
$title "PARSEUDCHEAD"                                                   15510000
procedure parseudchead(udcptr,numparms,parms,options,errno);            15515000
   value udcptr,options;                                                15520000
   byte pointer udcptr;                                                 15525000
   integer numparms,errno;                                              15530000
   array parms;                                                         15535000
   logical options;                                                     15540000
   option uncallable;                                                   15545000
comment  parms is 3 word entry:                                         15550000
   ******************************                                       15555000
   * parm len   * default len   *                                       15560000
   ******************************                                       15565000
   *     <formalname ptr>       *                                       15570000
   ******************************                                       15575000
   *      <default ptr>         *                                       15580000
   ******************************                                       15585000
;                                                                       15590000
begin                                                                   15595000
                                                                        15600000
integer                                                                 15605000
   plen;                                                                15610000
byte pointer                                                            15615000
   ptr,                                                                 15620000
   udcbase,                                                             15625000
   badspotptr;                                                          15630000
                                                                        15635000
subroutine err(errn,ptr);                                               15640000
   value errn;                                                          15645000
   integer errn; byte array ptr;                                        15650000
begin                                                                   15655000
   error(errn,if options.cis'optnohelp then synerrnol          <<04603>>15660000
                                       else synerr,            <<04603>>15665000
      ptr,udcbase);                                                     15670000
   errno := errn;                                                       15675000
   go outl;                                                             15680000
end;                                                                    15685000
                                                                        15690000
numparms := 0;                                                          15695000
@udcbase := @udcptr;                                                    15700000
findparm(udcptr,udcptr,ptr); <<ptr at 1st delim>>                       15705000
while ptr <> 0 do                                                       15710000
begin                                                                   15715000
   numparms := numparms +1;                                             15720000
   if numparms > udcmaxparms then err(toomanyparms,udcptr);             15725000
   plen := nextparm(ptr,udcptr,ptr);                                    15730000
   if < then err(noclosequote,udcptr);                                  15735000
   if = then err(expectparm,udcptr);                                    15740000
                                                                        15745000
      << check out formal name >>                                       15750000
   if udcptr = "!" then                                                 15755000
   begin << "!" precedes formal name >>                                 15760000
      @udcptr := @udcptr +1;                                            15765000
      plen := plen -1;                                                  15770000
   end;                                                                 15775000
                                                                        15780000
   if udcptr <> alpha then err(fmlnamenotalpha,udcptr);                 15785000
      << upshift >>                                                     15790000
   move udcptr := udcptr while ans,1;                                   15795000
   @badspotptr := tos;                                                  15800000
   if @udcptr +plen <> @badspotptr then err(invformalname,              15805000
      badspotptr);                                                      15810000
                                                                        15815000
      << stuff plen & ptr into parms >>                                 15820000
   parms((numparms -1)*3) := 0;                                         15825000
   parms(x).(0:8) := plen;                                              15830000
   parms(x:=x+1) := @udcptr;                                            15835000
   if ptr = "=" then                                                    15840000
   begin << default provided >>                                         15845000
      plen := nextparm(ptr,udcptr,ptr);                                 15850000
      if < then err(noclosequote,udcptr);                               15855000
      if = then err(expectparm,udcptr);                                 15860000
         << stuff default len & ptr into parms >>                       15865000
      parms((numparms -1)*3).(8:8) := plen;                             15870000
      parms(x:=x+2) := @udcptr;                                         15875000
   end;                                                                 15880000
end; << parm loop >>                                                    15885000
                                                                        15890000
outl:                                                                   15895000
end; << parseudchead >>                                                 15900000
$title "READFILE"                                                       15905000
procedure readfile(fn,recno,buff',errno);                               15910000
   value fn;                                                            15915000
   integer fn,recno,errno;                                              15920000
   array buff';                                                         15925000
   option uncallable;                                                   15930000
comment                                                                 15935000
   used to read udc head or body records until no continuation          15940000
   record is found.                                                     15945000
   returns next record # in recno.                                      15950000
;                                                                       15955000
begin                                                                   15960000
                                                                        15965000
pointer ptr';                                                           15970000
byte pointer ptr;                                                       15975000
integer len;                                                            15980000
logical ampersand;                                                      15985000
                                                                        15990000
ampersand := false;                                                     15995000
errno := -1;                                                            16000000
@ptr' := @buff';                                                        16005000
@ptr := @buff' & lsl(1);                                                16010000
ptr := 0;                                                               16015000
do begin                                                                16020000
   freaddir(fn,ptr',udcrecsize,double(recno));                          16025000
   if < then errno := udcreadfail                                       16030000
   else                                                                 16035000
   if > then errno := if ampersand then ampersanderr                    16040000
      else eofound                                                      16045000
   else                                                                 16050000
   begin                                                                16055000
      recno := recno +1;                                                16060000
      len := deblank(ptr,udcrecsizeb -8);                               16065000
      ptr(len) := 0;                                                    16070000
      if len > 0 and ptr(len -1) = "&" then                             16075000
      begin                                                             16080000
         ampersand := true;                                             16085000
         ptr(len -1) := " ";                                            16090000
         if logical(len) then                                           16095000
         begin                                                          16100000
            ptr(len) := " ";                                            16105000
            len := len +1;                                              16110000
         end;                                                           16115000
         @ptr := @ptr(len);                                             16120000
         @ptr' := @ptr&lsr(1);                                          16125000
         if (@ptr' -@buff') +udcrecsize >= udcbuffsize then             16130000
            errno := toomanyrec                                         16135000
         else                                                           16140000
      end                                                               16145000
      else errno := 0;                                                  16150000
   end;                                                                 16155000
end until errno <> -1;                                                  16160000
                                                                        16165000
end; << readfile >>                                                     16170000
$title "RECIPUDC"                                                       16175000
integer procedure recipudc(ntry,level,inx,sirs);                        16180000
   value level,inx,sirs;                                                16185000
   integer level,inx;                                                   16190000
   double sirs;                                                         16195000
   array ntry;                                                          16200000
   option uncallable;                                                   16205000
comment                                                                 16210000
   called by direcscan of udcdircread/udcdircwrite to          <<00884>>16215000
   read/write command file record numbers from/to the system   <<00884>>16220000
   directory. ntry is the user or account entry being visited. <<00884>>16225000
   ownarray(inx) is the parmarray of udcdircread/udcdircwrite. <<00884>>16230000
                                                               <<00884>>16235000
      ownarray(inx+0) = read/write indicator                   <<00884>>16240000
      ownarray(inx+1) = udc type (user,account,system)         <<00884>>16245000
      ownarray(inx+2) = command file record number             <<00884>>16250000
      ownarray(inx+3) = udc's exist flag                       <<00884>>16255000
;                                                                       16260000
begin                                                                   16265000
                                                                        16270000
integer deltaq = q-0;                                                   16275000
array dds(*) = db +0;                                                   16280000
array ownarray(*) = q+0;                                                16285000
                                                                        16290000
equate                                                                  16295000
   dadirty = %221;                                             <<00884>>16300000
define dirtyf = (15:1) #;                                               16305000
                                                                        16310000
inx := inx -deltaq;                                                     16315000
case ownarray(inx+1) of                                        <<00416>>16320000
begin                                                          <<00416>>16325000
<< user level >>                                               <<00884>>16330000
   if ownarray(inx) = dircwrite then                           <<00884>>16335000
      begin                                                    <<00884>>16340000
      ntry(userudcptr) := ownarray(inx+2);                     <<00884>>16345000
      ntry(userudcbit) := ownarray(inx+3);                     <<00884>>16350000
      end                                                      <<00884>>16355000
   else                                                        <<00884>>16360000
      begin                                                    <<00884>>16365000
      ownarray(inx+2) := ntry(userudcptr);                     <<00884>>16370000
      ownarray(inx+3) := ntry(userudcbit);                     <<00884>>16375000
      end;                                                     <<00884>>16380000
                                                               <<00884>>16385000
<< account level >>                                            <<00884>>16390000
   if ownarray(inx) = dircwrite then                           <<00884>>16395000
      begin                                                    <<00884>>16400000
      ntry(acctudcptr) := ownarray(inx+2);                     <<00884>>16405000
      ntry(acctudcbit) := ownarray(inx+3);                     <<00884>>16410000
      end                                                      <<00884>>16415000
   else                                                        <<00884>>16420000
      begin                                                    <<00884>>16425000
      ownarray(inx+2) := ntry(acctudcptr);                     <<00884>>16430000
      ownarray(inx+3) := ntry(acctudcbit);                     <<00884>>16435000
      end;                                                     <<00884>>16440000
                                                               <<00884>>16445000
<< system level >>                                             <<00884>>16450000
   if ownarray(inx) = dircwrite then                           <<00884>>16455000
      begin                                                    <<00884>>16460000
      ntry(sysudcptr) := ownarray(inx+2);                      <<00884>>16465000
      ntry(sysudcbit) := ownarray(inx+3);                      <<00884>>16470000
      end                                                      <<00884>>16475000
   else                                                        <<00884>>16480000
      begin                                                    <<00884>>16485000
      ownarray(inx+2) := ntry(sysudcptr);                      <<00884>>16490000
      ownarray(inx+3) := ntry(sysudcbit);                      <<00884>>16495000
      end;                                                     <<00884>>16500000
end;                                                           <<00884>>16505000
if ownarray(inx) = dircwrite then                              <<00884>>16510000
   dds(dadirty).dirtyf  := 1;                                  <<00884>>16515000
recipudc := 5; <<sirs not released. stop scan >>                        16520000
                                                                        16525000
end; << recipudc >>                                                     16530000
$title "RELCOMREC"                                                      16535000
procedure relcomrec(comfn,recno,errno);                                 16540000
   value comfn,recno;                                                   16545000
   integer comfn,recno,errno;                                           16550000
   option uncallable;                                                   16555000
comment - returns record from command.pub.sys to free list              16560000
;                                                                       16565000
<< assumptions:  this procedure assumes that command.pub.sys >><<03734>>16570000
<<    (file number = comfn) has been locked by the calling   >><<03734>>16575000
<<    procedure.                                             >><<03734>>16580000
                                                               <<03734>>16585000
begin                                                                   16590000
                                                                        16595000
array rec0(0:comrecsizem1);                                             16600000
array rec(0:comrecsizem1);                                              16605000
                                                                        16610000
subroutine read(buf,rec);                                               16615000
   value rec;                                                           16620000
   array buf;                                                           16625000
   integer rec;                                                         16630000
begin                                                                   16635000
   freaddir(comfn,buf,comrecsize,double(rec));                          16640000
   if <> then                                                           16645000
   begin                                                                16650000
      errno := comreadfail;                                             16655000
      go outl;                                                          16660000
   end;                                                                 16665000
end; << read >>                                                         16670000
                                                                        16675000
subroutine write(buf,rec);                                              16680000
   value rec;                                                           16685000
   array buf;                                                           16690000
   integer rec;                                                         16695000
begin                                                                   16700000
   fwritedir(comfn,buf,comrecsize,double(rec));                         16705000
   if <> then                                                           16710000
   begin                                                                16715000
      errno := comwritefail;                                            16720000
      go outl;                                                          16725000
   end;                                                                 16730000
end; << write >>                                                        16735000
                                                                        16740000
   errno := 0;                                                 <<03734>>16745000
   read(rec0,0);                                                        16750000
      << read returned record & mark as new free head>>                 16755000
   read(rec,recno);                                                     16760000
   rec(comlink) := rec0(comfreehead);                                   16765000
   rec(comentrytype) := comfreeentry;                                   16770000
   write(rec,recno);                                                    16775000
      << update head record >>                                          16780000
   rec0(comfreehead) := recno;                                          16785000
   rec0(comuse) := rec0(comuse) -1;                                     16790000
   write(rec0,0);                                                       16795000
                                                                        16800000
outl:                                                                   16805000
end; << relcomrec >>                                                    16810000
$title "SEARCHUDC"                                                      16815000
logical procedure searchudc(string,offset,udcfn,                        16820000
      recno,bodyrecno,options);                                         16825000
   integer udcfn,offset,recno,bodyrecno;                                16830000
   byte array string;                                                   16835000
   logical options;                                                     16840000
   option uncallable;                                                   16845000
begin                                                                   16850000
                                                                        16855000
integer                                                                 16860000
   entrylen,                                                            16865000
   len,                                                                 16870000
   cmdlen;                                                              16875000
                                                                        16880000
                                                                        16885000
byte pointer ptr;                                                       16890000
                                                                        16895000
array dir'(0:dirmaxentrysize); byte array dir(*) = dir';                16900000
                                                                        16905000
subroutine def'movefromdseg;                                            16910000
                                                                        16915000
scan string while " ",1;                                                16920000
@ptr := tos;                                                            16925000
move ptr := ptr while ans,1;                                            16930000
cmdlen := tos -@ptr;                                                    16935000
entrylen := dirmaxentrysize; << largest >>                              16940000
do begin                                                                16945000
   <<get directory one entry at a time>>                                16950000
   <<get entry + length of next entry (2 more bytes>>          <<06920>>16955000
   movefromdseg(@dir',udcdstno,offset,entrylen+dirhead);       <<04603>>16960000
   len := dir(direntrysize); << size of this entry >>          <<06920>>16965000
   entrylen := dir(len*2 +direntrysize); <<next entry len>>    <<06920>>16970000
   offset := offset +len;                                               16975000
   if len <> 0 then                                                     16980000
   begin     << is not last entry >>                           <<06920>>16985000
      if cmdlen = integer(dir(dircmdlen)) and ptr = dir                 16990000
         (dircmd),(cmdlen) then                                         16995000
      begin                                                             17000000
         searchudc := true;                                             17005000
         options := dir';<<list,logon,nohelp,nobreak>>                  17010000
         recno := dir'(dirrecno);                                       17015000
         bodyrecno := dir'(dirbodyrecno);                               17020000
         udcfn := dir(dirfileno);                                       17025000
         entrylen := 0;    << so loop will end >>                       17030000
      end;                                                              17035000
   end;                                                                 17040000
end until entrylen = 0;                                        <<07178>>17045000
                                                                        17050000
end; << searchudc >>                                                    17055000
$title "UDC"                                                            17060000
logical procedure udc(comimage,offset);                                 17065000
   value offset;                                                        17070000
   integer offset;                                                      17075000
   byte array comimage;                                                 17080000
   option uncallable;                                                   17085000
comment                                                                 17090000
   this procedure does it all for user defined commands.                17095000
   comimage is command image                                            17100000
   ending in %15, offset is index in directory to allow                 17105000
   nesting but stop recursion.                                          17110000
   returns true if comimage was a udc.                                  17115000
;                                                                       17120000
begin                                                                   17125000
                                                                        17130000
integer                                                                 17135000
   save'cis'ifnesting,                                         <<04603>>17140000
   comlen,                                                              17145000
   errno,                                                               17150000
   fcontroldummy = errno,                                               17155000
   numparms,                                                            17160000
   udcfn,                                                               17165000
   recno,                                                               17170000
   bodyrecno;                                                           17175000
                                                                        17180000
logical                                                                 17185000
   save'cis'ifskip,                                            <<04603>>17190000
   save'cis'elseseen,                                          <<04603>>17195000
   options,                                                    <<00538>>17200000
   oldudc2,                                                    <<01510>>17205000
   oldstate;                                                   <<00538>>17210000
                                                                        17215000
byte pointer ptr;                                                       17220000
                                                                        17225000
array headbuff'(0:udcbuffsize);                                         17230000
byte array headbuff(*) = headbuff';                                     17235000
array parmsinfo(0:pinfosize);                                           17240000
byte array udcimage(0:cis'maxcomlen);                          <<04603>>17245000
                                                                        17250000
udc := true;                                                            17255000
scan comimage until cr,1;                                               17260000
comlen := tos -@comimage;                                               17265000
move udcimage := comimage,(comlen);                                     17270000
udcimage(comlen) := 0;                                                  17275000
                                                                        17280000
   << upshift command name >>                                           17285000
scan udcimage while " ",1;                                              17290000
assemble(dup);                                                          17295000
move * := * while ans;                                                  17300000
                                                                        17305000
   if searchudc(udcimage,offset,udcfn,recno,bodyrecno,options)          17310000
      then                                                     <<u.rao>>17315000
   begin                                                                17320000
                                                               <<00835>>17325000
      << if in the false portion of an if statement then >>    <<00835>>17330000
      << don't expand the udc.                           >>    <<00835>>17335000
      if cis'ifskip then return;                               <<04603>>17340000
                                                               <<00835>>17345000
      if cis'udcnestlevel=0 <<1 level udc, save copy for redo>><<04603>>17350000
         then move cis'blastcomimage := comimage,(comlen +1);  <<04603>>17355000
      cis'udcnestlevel := cis'udcnestlevel +1;<<now in udc>>   <<04603>>17360000
      cis'continustatestk := cis'continustatestk & dlsl(2);    <<04603>>17365000
         <<adjust continue flags for new udc nest level>>      <<01.ro>>17370000
      readfile(udcfn,recno,headbuff',errno);                            17375000
      if errno <> 0 then error(errno,udcferr,udcfn)                     17380000
      else                                                              17385000
      begin                                                             17390000
         parseudchead(headbuff,numparms,parmsinfo,options,errno);       17395000
         if errno = 0 then                                              17400000
         begin                                                          17405000
            parsecom(udcimage,numparms,parmsinfo,errno);                17410000
            if errno = 0 then                                           17415000
            begin                                                       17420000
                  << check for required parms >>                        17425000
               x := -3;                                                 17430000
               while (x := x+3) < numparms*3 do if parmsinfo            17435000
                  (x).(8:8) = 0 then                                    17440000
                  begin                                                 17445000
                     @ptr := parmsinfo(x:=x+1);                         17450000
                     errno := missingparm;                              17455000
                     error(errno,if options.cis'optnohelp then <<04603>>17460000
                        synerrnol else synerr,ptr,                      17465000
                        headbuff);                                      17470000
                     x := numparms*3; << stop looping >>                17475000
                  end;                                                  17480000
               if errno = 0 then                                        17485000
               begin                                                    17490000
                  << save previous udc options >>              <<00619>>17495000
                  oldudc2 := cis'udc2;                         <<04603>>17500000
                  oldstate := cis'udc3;                        <<04603>>17505000
                  comment:                                     <<00538>>17510000
                     set new break state.  break acts          <<00538>>17515000
                     like a blanket.;                          <<00538>>17520000
                  cis'udc3 := options;                         <<04603>>17525000
                  cis'udcnobreakopt :=                         <<04603>>17530000
                                    if oldstate.cis'optnobreak <<04603>>17535000
                                                 or            <<04603>>17540000
                                       options.cis'optnobreak  <<04603>>17545000
                                      then true else false;    <<04603>>17550000
                  if options.cis'optnobreak then fcontrol(1,   <<04603>>17555000
                     disablebreak,fcontroldummy);                       17560000
                                                               <<00835>>17565000
                  << save current if nesting info >>           <<00835>>17570000
                  save'cis'ifnesting := cis'ifnesting;         <<04603>>17575000
                  save'cis'ifskip := cis'ifskip;               <<04603>>17580000
                  save'cis'elseseen := cis'elseseen;           <<04603>>17585000
                                                               <<00835>>17590000
                  feedci(udcfn,bodyrecno,comimage,numparms,             17595000
                     parmsinfo,offset,options,errno);                   17600000
                                                               <<00835>>17605000
                  << check if exiting udc at same if level >>  <<00835>>17610000
                  << unless udc exitting abnormally.       >>  <<01288>>17615000
                  if (errno = 0) and                           <<01288>>17620000
                     (cis'ifnesting <> save'cis'ifnesting) then<<04603>>17625000
                    error(-udcifs'neq'endifs,udcerr);          <<01288>>17630000
                                                               <<00835>>17635000
                  << restore if nesting globals >>             <<00835>>17640000
                  cis'ifnesting := save'cis'ifnesting;         <<04603>>17645000
                  cis'ifskip := save'cis'ifskip;               <<04603>>17650000
                  cis'elseseen := save'cis'elseseen;           <<04603>>17655000
                                                               <<00835>>17660000
                                                               <<00835>>17665000
                  if cis'udcexitbreak then                     <<04603>>17670000
                  begin << unwind. put comimage back >>                 17675000
                     move comimage := udcimage,(comlen);                17680000
                     comimage(comlen) := cr;                            17685000
                     if cis'pendingcomlen <> 0                 <<04603>>17690000
                       then cis'pendingcomlen                  <<04603>>17695000
                        := comlen;<<adjust comlen for ci >>    <<13.eb>>17700000
                  end;                                                  17705000
                  if options.cis'optnobreak                    <<04603>>17710000
                             and not oldstate.cis'optnobreak   <<04603>>17715000
                     then fcontrol(1,enablebreak,              <<00538>>17720000
                                   fcontroldummy);             <<00538>>17725000
                  << restore previous udc options >>           <<00619>>17730000
                  cis'udc3 := oldstate;                        <<04603>>17735000
                  cis'udc2 := cis'udc2 lor oldudc2;            <<04603>>17740000
               end;                                                     17745000
            end;                                                        17750000
         end;                                                           17755000
      end;                                                              17760000
      cis'continustatestk := cis'continustatestk & dlsr(2);    <<04603>>17765000
         <<adjust continue flags to previous udc nest level>>  <<01.ro>>17770000
      if cis'udcfatalcierr and cis'contstate >= 1 then         <<04603>>17775000
         cis'udcfatalcierr := false; <<clear udc ci abort flag <<04603>>17780000
      if cis'udcnestlevel <> 0 then cis'udcnestlevel :=        <<04603>>17785000
         cis'udcnestlevel -1; << decrement level >>            <<04603>>17790000
   end                                                                  17795000
   else                                                                 17800000
   if udcimage = "HELP " and udchelp(udcimage(5)) then         <<01307>>17805000
      begin                                                    <<01307>>17810000
      if cis'udcnestlevel = 0 then                             <<04603>>17815000
         move cis'blastcomimage := comimage,(comlen + 1);      <<04603>>17820000
      end                                                      <<01307>>17825000
   else                                                        <<01307>>17830000
      udc := false;                                            <<01307>>17835000
                                                                        17840000
end; << udc >>                                                          17845000
$title "UDCHELP"                                                        17850000
logical procedure udchelp(comimage);                                    17855000
   value comimage;                                                      17860000
   byte pointer comimage;                                               17865000
   option uncallable;                                                   17870000
begin                                                                   17875000
                                                                        17880000
integer                                                                 17885000
   len,                                                        <<01532>>17890000
   errno,                                                               17895000
   errno1,                                                              17900000
   udcfn,                                                               17905000
   offset,                                                              17910000
   recno,                                                               17915000
   dummy;                                                               17920000
logical options;                                                        17925000
                                                                        17930000
byte pointer ptr;                                                       17935000
                                                                        17940000
array udcbuff'(0:udcbuffsize);                                          17945000
byte array udcbuff(*) = udcbuff';                                       17950000
                                                                        17955000
offset := 0;                                                            17960000
if searchudc(comimage,offset,udcfn,recno,dummy,options)                 17965000
   then                                                                 17970000
begin                                                                   17975000
   if not options.cis'optnohelp then                           <<04603>>17980000
   begin                                                                17985000
      udchelp := true;                                         <<00835>>17990000
                                                               <<00835>>17995000
      << if in the false part of an if statement then >>       <<00835>>18000000
      << don't execute the command.                   >>       <<00835>>18005000
      if cis'ifskip then return;                               <<04603>>18010000
                                                               <<00835>>18015000
      scan comimage while " ",1;<<deblank>>                             18020000
      assemble(dup);                                                    18025000
      move * := * while ans,1;<<skip command name>>                     18030000
      scan * while " ",1;                                               18035000
      @ptr := tos;                                                      18040000
      if nocarry then << extra parms >>                                 18045000
         error( -ignored, imagerr, ptr, comimage(-4) );        <<01360>>18050000
      genmsg(ciset,udchelphead); << header >>                           18055000
      print(errno,0,0); <<crlf>>                                        18060000
                                                                        18065000
      errno := -1;                                                      18070000
      do begin                                                          18075000
         readfile(udcfn,recno,udcbuff',errno1);                         18080000
         if errno1 = eofound then errno := 0                            18085000
         else                                                           18090000
         begin                                                          18095000
            if errno1 <> 0 then errno := errno1                         18100000
            else                                                        18105000
            begin                                                       18110000
               if udcbuff = "*" then errno := 0                         18115000
               else                                            <<01532>>18120000
               begin                                           <<01532>>18125000
                  scan udcbuff until 0, 1;                     <<01532>>18130000
                  len := tos - @udcbuff;                       <<01532>>18135000
                  print( udcbuff', -len, 0 );                  <<01532>>18140000
               end;                                            <<01532>>18145000
            end;                                                        18150000
         end;                                                           18155000
      end until errno <> -1;                                            18160000
   end;                                                                 18165000
end;                                                                    18170000
                                                                        18175000
end; << udchelp >>                                                      18180000
$title "UPSHIFT"                                                        18185000
procedure upshift(ptr);                                                 18190000
   value ptr; byte pointer ptr;                                         18195000
   option uncallable;                                                   18200000
comment upshifts until 0 if found.                                      18205000
;                                                                       18210000
begin                                                                   18215000
   tos := @ptr;                                                         18220000
   do begin                                                             18225000
      assemble(dup);                                                    18230000
      move * := * while ans,1;                                          18235000
      tos := tos +1;                                                    18240000
   end until bps0(-1) = 0;                                              18245000
end; << upshift >>                                                      18250000
$title "SEARCHCOMFILE"                                         <<00884>>18255000
procedure                                                      <<00884>>18260000
     searchcomfile(comfn,uname,aname,userrec,filerec,errno);   <<00884>>18265000
   value comfn;                                                <<00884>>18270000
   integer comfn,userrec,filerec,errno;                        <<00884>>18275000
   byte array uname,aname;                                     <<00884>>18280000
   option uncallable,variable;                                 <<00884>>18285000
begin                                                          <<00884>>18290000
comment                                                        <<00884>>18295000
   performs a linear search of the udc command file for a given<<00884>>18300000
   user & account, or any user in an account if only the accoun<<00884>>18305000
   is specified.  searching begins at the record number passed <<00884>>18310000
   in 'userrec'.  if a match is found before the end of the    <<00884>>18315000
   file, the record number of the user entry is returned in    <<00884>>18320000
   'userrec' and the record number of the first file entry is  <<00884>>18325000
   returned in 'filerec'.                                      <<00884>>18330000
   ;                                                           <<00884>>18335000
define                                                         <<00884>>18340000
   unameparm = varmask.(11:1) #,                               <<00884>>18345000
   userrecparm = varmask.(13:1) #,                             <<00884>>18350000
   filerecparm = varmask.(14:1) #;                             <<00884>>18355000
logical                                                        <<00884>>18360000
   varmask = q-4;                                              <<00884>>18365000
double                                                         <<00884>>18370000
   recno;                                                      <<00884>>18375000
array                                                          <<00884>>18380000
   rec'(0:comrecsizem1);                                       <<00884>>18385000
byte array                                                     <<00884>>18390000
   rec(*) = rec';                                              <<00884>>18395000
                                                               <<00884>>18400000
subroutine set'return'parms;                                   <<00884>>18405000
   begin                                                       <<00884>>18410000
   if userrecparm then userrec := integer(recno);              <<00884>>18415000
   if filerecparm then filerec := rec'(comlink);               <<00884>>18420000
   errno := 0;                                                 <<00884>>18425000
   end;                                                        <<00884>>18430000
                                                               <<00884>>18435000
                                                               <<00884>>18440000
errno := -1;                                                   <<00884>>18445000
recno := double(userrec);                                      <<00884>>18450000
do begin                                                       <<00884>>18455000
   freaddir(comfn,rec',comrecsize,recno);                      <<00884>>18460000
   if < then errno := comreadfail                              <<00884>>18465000
   else                                                        <<00884>>18470000
      if > then errno := eofound                               <<00884>>18475000
      else                                                     <<00884>>18480000
         if rec'(comentrytype) = comuserentry then             <<00884>>18485000
            if unameparm then                                  <<00884>>18490000
               begin                                           <<00884>>18495000
               if rec(comuname) = uname,(8) and                <<00884>>18500000
                  rec(comaname) = aname,(8) then               <<00884>>18505000
                     set'return'parms;                         <<00884>>18510000
               end                                             <<00884>>18515000
            else                                               <<00884>>18520000
               begin << look for any user in this account >>   <<00884>>18525000
               if rec(comaname) = aname,(8) then               <<00884>>18530000
                     set'return'parms;                         <<00884>>18535000
               end;                                            <<00884>>18540000
   recno := recno + 1d;                                        <<00884>>18545000
   end                                                         <<00884>>18550000
until errno <> -1;                                             <<00884>>18555000
                                                               <<00884>>18560000
end; << searchcomfile >>                                       <<00884>>18565000
$control segment = main                                        <<00884>>18570000
end. << module udc >>                                          <<00884>>18575000
