home *** CD-ROM | disk | FTP | other *** search
/ norge.freeshell.org (192.94.73.8) / 192.94.73.8.tar / 192.94.73.8 / pub / computers / cpm / alphatronic / DRIPAK.ZIP / CPM_3-0 / SOURCES / SET.PLM < prev    next >
Text File  |  1982-12-31  |  56KB  |  1,854 lines
  1. $ TITLE('CPM 3.0 --- SET 1.3')
  2.  
  3. /* MULTI FILE INPUT VERSION   11/11/82 */
  4. /* took out call passwd in readlabel */
  5. /* added test for NONBANK in password, protect and default  11/19/82 */
  6. /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  7.  
  8.  
  9.                        * * *  SET  * * *
  10.  
  11.  
  12.  * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
  13.  
  14.  
  15. set:
  16. do;
  17.  
  18. declare
  19.     mpmproduct literally '01h', /* requires mp/m */
  20.     cpmversion literally '30h'; /* requires 3.0 cp/m */
  21.  
  22.  
  23. declare
  24.     true        literally '1',
  25.     false       literally '0',
  26.     dcl         literally 'declare',
  27.     lit         literally 'literally',
  28.     proc        literally 'procedure',
  29.     addr        literally 'address',
  30.     tab         literally '9',
  31.     cr          literally '13',
  32.     lf          literally '10',
  33.     ctrlc       literally '3h',
  34.     ctrlx       literally '18h',
  35.     ctrlh       literally '8h';
  36.  
  37. declare
  38.         opt$access      literally '0',
  39.         opt$archive     literally '1',
  40.         opt$create      literally '2',
  41.         opt$default     literally '3',
  42.         opt$dir         literally '4',
  43.         opt$f1          literally '5',
  44.         opt$f2          literally '6',
  45.         opt$f3          literally '7',
  46.         opt$f4          literally '8',
  47.         opt$name        literally '9',
  48.         opt$pass        literally '10',
  49.         opt$prot        literally '11',
  50.         opt$ro          literally '12',
  51.         opt$rw          literally '13',
  52.         opt$sys         literally '14',
  53.         opt$update      literally '15',
  54.         opt$page        literally '16',
  55.         opt$nopage      literally '17',
  56.  
  57.         PERIOD          literally '02eh',
  58.         PAGE            byte initial(false);
  59.  
  60. declare plm label public;
  61.  
  62. declare copyright (*) byte data (
  63.   ' Copyright (c) 1982 Digital Research ');
  64.  
  65. /*
  66.             Digital Research
  67.             Box 579
  68.             Pacific Grove, Ca
  69.             93950
  70. */
  71. $ eject
  72. /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  73.  
  74.  
  75.                    * * *  MESSAGES  * * *
  76.  
  77.  
  78.  * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
  79.  
  80.  
  81.  
  82.         declare
  83.             not$found  (*) byte data (' File not found',0),
  84.             no$space   (*) byte data (' or no directory space',0),
  85.             invalid    (*) byte data ('Invalid file name.',0),
  86.             dirlabel   (*) byte data ('Directory Label ',0),
  87.             option$set (*) byte data (' attribute set ',0),
  88.             read$only  (*) byte data ('Read Only',0),
  89.             ro         (*) byte data (' (RO)',0),
  90.             read$write (*) byte data ('Read Write (RW)',0),
  91.             comma      (*) byte data (', ',0),
  92.             set$to     (*) byte data ('set to ',0),
  93.             error$msg  (*) byte data ('ERROR: ',0),
  94.             readmode   (*) byte data ('READ',0),
  95.             writemode  (*) byte data ('WRITE',0),
  96.             deletemode (*) byte data ('DELETE',0),
  97.             nopasswd   (*) byte data ('NONE',0),
  98.             on         (*) byte data ('    on   ',0),
  99.             off        (*) byte data ('    off  ',0),
  100.             label$name (*) byte data ('LABEL');
  101.  
  102.  
  103. /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  104.  
  105.  
  106.                    * * *  CP/M INTERFACE * * *
  107.  
  108.  
  109.  * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
  110.  
  111.  
  112.  
  113.  
  114. declare
  115.     maxb      address external,    /* addr field of jmp BDOS */
  116.     fcb (33)  byte external,       /* default file control block */
  117.     buff(128) byte external,       /* default buffer */
  118.     buffa     literally '.buff',   /* default buffer */
  119.     fcba      literally '.fcb',    /* default file control block */
  120.     user$code byte;                /* current user code */
  121.  
  122.  
  123. /*              Routines used in SET for CPM 3.0                */
  124.  
  125.     /* reset drive mask */
  126.     declare reset$mask (16) address data (
  127.       0000000000000001b,
  128.       0000000000000010b,
  129.       0000000000000100b,
  130.       0000000000001000b,
  131.       0000000000010000b,
  132.       0000000000100000b,
  133.       0000000001000000b,
  134.       0000000010000000b,
  135.       0000000100000000b,
  136.       0000001000000000b,
  137.       0000010000000000b,
  138.       0000100000000000b,
  139.       0001000000000000b,
  140.       0010000000000000b,
  141.       0100000000000000b,
  142.       1000000000000000b );
  143.  
  144.  
  145. boot: procedure external;
  146.     /* reboot */
  147.     end boot;
  148.  
  149. mon1: procedure(f,a) external;
  150.     declare f byte, a address;
  151.     end mon1;
  152.  
  153. mon2: procedure(f,a) byte external;
  154.     declare f byte, a address;
  155.     end mon2;
  156.  
  157. declare mon3 literally 'mon2a';
  158.  
  159. mon3: procedure(f,a) address external;
  160.     declare f byte, a address;
  161.     end mon3;
  162.  
  163.     /********** SYSTEM FUNCTION CALLS *********************/
  164.  
  165. printchar: procedure(char);
  166.     declare char byte;
  167.     call mon1(2,char);
  168.     end printchar;
  169.  
  170. printb: procedure;                      /* print blank character */
  171.  
  172.     call printchar(' ');
  173.  
  174. end printb;
  175.  
  176. printx: procedure(a);
  177.     declare a address;
  178.     declare s based a byte;
  179.         do while s <> 0;
  180.         call printchar(s);
  181.         a = a + 1;
  182.         end;
  183.     end printx;
  184.  
  185. check$con$stat: procedure byte;
  186.  
  187.     return mon2(11,0);                  /* console ready */
  188.  
  189. end check$con$stat;
  190.  
  191.  
  192. crlf2: procedure;
  193.  
  194.         call printchar(cr);
  195.         call printchar(lf);
  196.  
  197. end crlf2;
  198.  
  199.  
  200. terminate: procedure;
  201.     call crlf2;
  202.     call mon1 (0,0);
  203. end terminate;
  204.  
  205.  
  206. crlf: procedure;
  207.      declare charin     byte;
  208.  
  209.      if PAGE then do;
  210.         line$out = line$out + 1;                /* output > page size ? */
  211.         if line$out + 2 > line$page then do;
  212.                 call crlf2;
  213.                 call crlf2;
  214.                 call printx(.('Press RETURN to continue.',0));
  215.  
  216.                 do while not check$con$stat;
  217.                 end;
  218.  
  219.                 charin = mon2(1,0);                /* read character */
  220.                 if charin = ctrlc then call terminate;
  221.                 line$out = 1;
  222.                 call crlf2;
  223.        end;
  224.      end;
  225.  
  226.         call crlf2;
  227.  
  228. end crlf;
  229.  
  230. print: procedure(a);    /* print the string starting at address a until the
  231.                            next 0 is encountered */
  232.     declare a address;
  233.  
  234.     call crlf;
  235.     call printx(a);
  236.  
  237. end print;
  238.  
  239. get$version: procedure addr;            /* returns current cp/m version # */
  240.  
  241.     return mon3(12,0);
  242.  
  243. end get$version;
  244.  
  245.  
  246. conin: procedure byte;
  247.  
  248.     return mon2(6,0fdh);
  249.  
  250. end conin;
  251.  
  252. select: procedure(d);
  253.     declare d byte;
  254.     call mon1(14,d);
  255.     end select;
  256.  
  257. search$first: procedure(fcb) byte;
  258.     declare fcb address;
  259.     return mon2(17,fcb);
  260.     end search$first;
  261.  
  262. search$next: procedure byte;
  263.     return mon2(18,0);
  264.     end search$next;
  265.  
  266. cselect: procedure byte;
  267.     /* return current disk number */
  268.     return mon2(25,0);
  269.     end cselect;
  270.  
  271. setdma: procedure(dma);
  272.     declare dma address;
  273.     call mon1(26,dma);
  274.     end setdma;
  275.  
  276. writeprot: procedure byte;              /* write protect the current disk */
  277.  
  278.     return mon2(28,0);
  279.  
  280. end writeprot;
  281.  
  282. getuser: procedure byte;                /* return current user number */
  283.  
  284.     return mon2(32,0ffh);
  285.  
  286. end getuser;
  287.  
  288. return$errors: procedure(mode);         /* 0ff => return BDOS errors */
  289.     declare mode byte;
  290.  
  291.       call mon1 (45,mode);
  292.  
  293. end return$errors;
  294.  
  295. setind: procedure(fcb) address;             /* SFA for current fcb */
  296.     dcl fcb addr;
  297.  
  298.     call setdma(.passwd);
  299.     return mon3(30,fcb);
  300.  
  301. end setind;
  302.  
  303.     /********** DISK PARAMETER BLOCK **********************/
  304.  
  305. declare
  306.         dpba            address,
  307.         dpb             based dpba structure(
  308.          scptrk         address,
  309.          blkshf         byte,
  310.          blkmsk         byte,
  311.          extmsk         byte,
  312.          maxall         address,
  313.          dirmax         address,
  314.          dirblk         address,
  315.          chksiz         address,
  316.          offset         address,
  317.          physhf         byte,
  318.          phymsk         byte);
  319.  
  320.  
  321. set$dpb: procedure;                     /* set disk parameter block values */
  322.  
  323.     dpba = mon3(31,0);                  /* base of dpb */
  324.  
  325. end set$dpb;
  326.  
  327.     /******************************************************/
  328.  
  329. wrlbl: procedure(fcb) address;
  330.     declare fcb address;
  331.  
  332.     call setdma(.passwd);       /* set dma=password */
  333.     return mon3(100,fcb);
  334.  
  335. end wrlbl;
  336.  
  337. getlbl: procedure(d) byte;
  338.     declare d byte;
  339.  
  340.     return mon2(101,d);
  341.  
  342. end getlbl;
  343.  
  344. readxfcb: procedure(fcb) address;
  345.     declare fcb address;
  346.  
  347.     call setdma(.passwd);       /* set dma=password */
  348.     return mon3(102,fcb);
  349.  
  350. end readxfcb;
  351.  
  352. wrxfcb: procedure(fcb) address;
  353.     declare fcb address;
  354.  
  355.     call setdma(.passwd);
  356.     return mon3(103,fcb);
  357.  
  358. end wrxfcb;
  359.  
  360.  
  361. reset$drv: procedure(drv) byte;
  362.     dcl drv byte;
  363.  
  364.     return mon2(37,reset$mask(drv));
  365.     end reset$drv;
  366.  
  367. parse: procedure(pfcb) address external;
  368.         declare pfcb address;
  369.  
  370. end parse;
  371.  
  372. delete: procedure(fcb) byte;
  373.         declare fcb     address;
  374.  
  375.         return mon2(19,fcb);
  376.  
  377. end delete;
  378.  
  379. $ eject
  380.  
  381.  
  382.  
  383. /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  384.  
  385.  
  386.                  * * *  GLOBAL DATA  * * *
  387.  
  388.  
  389.  * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
  390.  
  391.  
  392.         declare
  393.             fnam     literally '11',
  394.             ftyp     literally '9',
  395.             rofile   literally '9',     /* read/only file */
  396.             sysfile  literally '10',    /* system file */
  397.             archiv   literally '11',    /* archived  file */
  398.             attrb1   literally  '1',    /* attribute F1'  */
  399.             attrb2   literally  '2',    /* attribute F2'  */
  400.             attrb3   literally  '3',    /* attribute F3'  */
  401.             attrb4   literally  '4';    /* attribute F4'  */
  402.     
  403.         declare
  404.                 pwmask$on       literally '80h',
  405.                 pwmask$off      literally '7fh',
  406.                 acmask$on       literally '40h',
  407.                 acmask$off      literally '0bfh',
  408.                 upmask$on       literally '20h',
  409.                 upmask$off      literally '0dfh',
  410.                 crmask$on       literally '10h',
  411.                 crmask$off      literally '0efh',
  412.                 dlmask$on       literally '1h',
  413.                 dlmask$off      literally '0feh';
  414.  
  415.         declare
  416.             fcbp     address,
  417.             fcbv     based fcbp (32) byte,
  418.             fext     literally 'fcbv(12)';
  419.  
  420.         declare
  421.             xfcb     (32) byte,
  422.             xfcbmode byte at (.xfcb(12));  /* password mode */
  423.  
  424.         declare                          /* command buffer */
  425.             cmd (27) byte initial(0,0,0,0,0,0,0,0,0,0,0,0,0,0,0),
  426.             passwd (17) byte;           /* password buffer */
  427.  
  428.         declare
  429.                 sfacmd   byte   initial(false), /* file attributes */
  430.                 fileref  byte   initial(false), /* file reference  */
  431.                 lblcmd   byte   initial(false), /* label attribute */
  432.                 xfcbcmd  byte   initial(false), /* xfcb  attribute */
  433.                 wild     byte   initial(false), /* file = a wildcard */
  434.                 optdel   byte   initial(false), /* delimiter = option */
  435.                 multi    byte   initial(false),
  436.                 newpass  byte   initial(false),
  437.                 passmsg  byte   initial(false),
  438.                 NONBANK  byte   initial(false),
  439.                 passmode byte,
  440.                 password byte   initial(false); /* file has password */
  441.  
  442.         declare                         /* parsing */
  443.             more  byte initial(true),   /* more to parse */
  444.             ibp        addr;            /* input buffer ptr */
  445.  
  446.         declare            
  447.             (sav$dcnt, sav$searcha)     addr,
  448.             sav$searchl  byte,
  449.             dirbuf (128) byte;          /* used for searches */
  450.  
  451.         declare
  452.             cdisk     byte,             /* current disk */
  453.             ver       addr;             /* version checking */
  454.  
  455.         declare
  456.             error$code addr;            /* for bdos returned
  457.                                            errors */
  458.         declare
  459.             parse$fn structure (
  460.                 buff$adr  addr,
  461.                 fcb$adr   addr),
  462.             last$buff$adr addr;         /* used for parsing */
  463.  
  464.         declare
  465.                 err$nofile(*)   byte data('Option requires a file reference',0),
  466.  
  467.                 err$driveonly(*) byte data('Option only for drives.',0),
  468.                 errWASSPASS(*)  byte data('Assign passwords to input files.',0),
  469.  
  470.                 errASSPASS(*)   byte data('Assign a password to this file.',0),
  471.                 errFORMAT(*)    byte data(
  472.                 'Directory needs to be re-formatted for time/date stamps.',cr,
  473.                 lf,'       Please see INITDIR.',0),
  474.                 errNOPROT(*)    byte data('Protection not enabled for disk.',0),
  475.  
  476.                 errUNREC(*)     byte data('Unrecognized option.',0),
  477.                 errNOMOD(*)     byte data
  478.                                 ('There are no modifiers for this option.',0),
  479.                 errUNRECM(*)    byte data
  480.                                 ('Modifier missing or unrecognizable.',0),
  481.                 errVALM(*)      byte data
  482.                                 ('Not a valid modifier for this option.',0),
  483.                 errOPTMOD(*)    byte data('This option needs a modifier.',0),
  484.                 errBIGDEF(*)    byte data
  485.                 ('Only first 8 characters of default password used.',0),
  486.                 errBIGNAME(*)   byte data
  487.                 ('Only first 11 characters of label name used.',0),
  488.                 errBIGPASS(*)   byte data
  489.                 ('Only first 8 characters of password used.',0),
  490.                 errCRAC(*)      byte data
  491.                         ('Cannot have both create and access time stamps.',0),
  492.                 errSYSDIR(*)    byte data('Cannot set both sys and dir.',0),
  493.                 errRORW(*)      byte data('Cannot set RO and RW.',0),
  494.                 errNOPT(*)      byte data('No options specified.',0),
  495.                 errPAGE(*)      byte data('Page and nopage option selected.',
  496.                                 '   Nopage in effect.',0),
  497.                 errGLOBAL(*)    byte data
  498.                                 ('Cannot set local options for file.',0),
  499.                 errDrvProt(*)   byte data
  500.                 ('Protection modifier is only ON/OFF for drives.',0),
  501.                 errNBANK(*)     byte data
  502.                 ('Password protection is not supported in NON-BANKED SYS.',0),
  503.                 errVERS(*)      byte data('Requires CP/M 3 or higher.',0);
  504.  
  505. $include (sopt.dcl)
  506.  
  507.         declare 
  508.                 scbpd   structure(
  509.                  offs           byte,
  510.                  set            byte,
  511.                  value          address);
  512.  
  513.         declare
  514.                 line$page       byte,
  515.                 line$out        byte,
  516.                 savefcb(16)     byte,
  517.                 save$dcnt       address,
  518.                 save$searcha    address,
  519.                 save$searchl    address,
  520.                 save$hash1      address,
  521.                 save$hash2      address,
  522.                 save$hash3      address,
  523.  
  524.                 COMbase         literally       '05dh',
  525.                 page$off        literally       '01ch',
  526.                 searcha$off     literally       '47h',
  527.                 searchl$off     literally       '49h',
  528.                 dcnt$off        literally       '45h',
  529.                 hash1$off       literally       '00h',
  530.                 hash2$off       literally       '02h',
  531.                 hash3$off       literally       '04h';
  532.  
  533.                                 /* get the scb word */
  534. getscbword: procedure(off) address;
  535.         declare off     byte;
  536.  
  537.         scbpd.offs = off;
  538.         scbpd.set = 0;
  539.         return mon3(49,.scbpd);
  540.  
  541. end getscbword;
  542.  
  543. setscb: procedure(off,value);
  544.         declare off     byte,
  545.                 value   address;
  546.  
  547.         scbpd.offs = off;
  548.         scbpd.set = 0feh;
  549.         scbpd.value = value;
  550.         call mon1(49,.scbpd);
  551.  
  552. end setscb;
  553.  
  554. getpage: procedure byte;
  555.  
  556.         scbpd.offs = page$off;
  557.         scbpd.set = 0;
  558.         return mon2(49,.scbpd);
  559.  
  560. end getpage;
  561.  
  562. $eject
  563.  
  564. /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  565.  
  566.  
  567.                  * * *  BASIC ROUTINES  * * *
  568.  
  569.  
  570.  * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
  571.  
  572.  
  573.                          /* invalid command error */
  574. perror: proc;
  575.  
  576.     call print(.error$msg);
  577.     if ibp = 0 then call printx(parse$fn.buff$adr);
  578.     else call printx(last$buff$adr);
  579.  
  580.     call printx(.(' ?',0));
  581.     call print(.invalid);
  582.     call terminate;
  583. end perror;
  584.  
  585. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  586.  
  587.         /* parse the next lexical item in the command line 
  588.            parse$fn must filled in with input parameters */
  589. parser: procedure address;
  590.     declare p address;
  591.     declare c based p byte;
  592.  
  593.         p = parse(.parse$fn);
  594.         if p = 0FFFFh then call perror;
  595.         else if p <> 0 then do;
  596.                 if c = '[' then optdel = true;
  597.                 else if c = ']' then optdel = false;
  598.                 p = p + 1;
  599.         end;
  600.         else optdel = false;
  601.  
  602.         return p;
  603.  
  604. end parser;
  605.  
  606. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  607.  
  608. fill:   proc(s,f,c);            /* fill string @ s for c bytes with f */
  609.     dcl s addr,
  610.         (f,c) byte,
  611.         a based s byte;
  612.  
  613.         do while (c:=c-1)<>255;
  614.         a = f;
  615.         s = s+1;
  616.         end;
  617.     end fill;
  618. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  619.  
  620.  
  621. copy:   proc(s,d,c);            /* copy c bytes from s to d */
  622.     dcl (s,d) addr, c byte;
  623.     dcl a based s byte, b based d byte;
  624.  
  625.         do while (c:=c-1)<>255;
  626.            b=a; s=s+1; d=d+1;
  627.         end;
  628. end copy;
  629. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  630.  
  631.  
  632. ucase:   proc byte;             /* upper case character from console */
  633.     dcl c byte;
  634.  
  635.     if (c:=conin) >= 'a' then
  636.        if c < '{' then
  637.           return(c-20h);
  638.     return c;
  639. end ucase;
  640.  
  641. errprint: procedure(msg);
  642.         declare msg     address;
  643.  
  644.         call print(.errormsg);
  645.         call printx(msg);
  646.         call crlf;
  647.  
  648. end errprint;
  649.  
  650.  
  651. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  652.  
  653.  
  654.                   /* get password and place in passwd */
  655. getpasswd:   proc;
  656.     dcl (i,c) byte;
  657.  
  658.         call print(.('Password ? ',0));
  659.  
  660. retry:
  661.         call fill(.passwd,' ',8);
  662.         do i = 0 to 7;
  663.  
  664. nxtchr:
  665.                 if (c:=ucase) >= ' ' then passwd(i)=c;
  666.                 else
  667.                 if c = cr then go to exit;
  668.  
  669.                 if c = ctrlx then goto retry;
  670.                 if c = ctrlh then do;
  671.  
  672.                         if i<1 then goto retry;
  673.                         else do;
  674.                                 passwd(i:=i-1)=' ';
  675.                                 goto nxtchr;
  676.                         end;
  677.                 end;
  678.  
  679.                 if c = ctrlc then call terminate;       /* end of program */
  680.         end;
  681.  
  682. exit:
  683.         c = check$con$stat;             /* clear raw I/O mode */
  684.  
  685. end getpasswd;
  686.  
  687. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  688.  
  689.  
  690.                                         /* print drive name */
  691. printdrv: procedure;
  692.  
  693.         call printchar(cdisk+'A');
  694.         call printchar(':');
  695.  
  696. end printdrv;
  697.  
  698. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  699.  
  700.  
  701.                                          /* print file name */
  702. printfn: procedure;
  703.         declare k byte;
  704.  
  705.         call printdrv;
  706.  
  707.         do k = 1 to fnam;
  708.                 if k = ftyp then call printchar('.');
  709.                 call printchar(fcbv(k) and 7fh);
  710.         end;
  711.  
  712. end printfn;
  713.  
  714. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  715.  
  716.  
  717. bdos$error:   procedure;                /* error message routine */
  718.    declare
  719.       code byte;
  720.  
  721.         call print(.error$msg);
  722.         if (code:=high(error$code)) < 3 then do;
  723.                 call print(.error$msg);
  724.                 call printdrv;
  725.                 call printb;
  726.  
  727.                 if code = 1 then call printx(.('Disk I/O',0));
  728.                 if code=2 then do;
  729.                     call printx(.('Drive ',0));
  730.                     call printx(.read$only);
  731.                 end;
  732.                 call terminate;
  733.     end;
  734.  
  735.         if code = 3 then call printx(.read$only);
  736.         if code = 4 then call printx(.('Invalid Drive.',0));
  737.         if code = 7 then call printx(.('Wrong Password',0));
  738.         if code = 9 then call printx(.('? in filespec.',0));
  739.  
  740. end bdos$error;
  741.  
  742. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  743.  
  744.  
  745. set$search: procedure(dcnt);
  746.         declare dcnt    byte;
  747.  
  748.         call setdma(.dirbuf);
  749.         dcnt = search$first(.('?'));
  750.  
  751. end set$search;
  752.  
  753.  
  754.                                  /* get address of FCB in dirbuf */
  755. set$up$file: procedure(dir$index);
  756.     dcl dir$index byte;
  757.  
  758.     if dir$index <> 0ffh then do;
  759.         fcbp = shl(dir$index,5) + .dirbuf;
  760.         fcbv(0) = fcb(0);                 /* set drive byte */
  761.     end;
  762.  
  763. end set$up$file;
  764.  
  765. getnext: procedure byte;
  766.                                         /* get the next fcb that matches fcb */
  767.  
  768.         declare (dcnt,i)        byte;
  769.  
  770.         xfcbcmd,sfacmd = false;
  771.  
  772.  
  773.         call setdma(.dirbuf);
  774.  
  775.                                         /* restore saved search parameters */
  776.         call setscb(dcnt$off,save$dcnt);
  777.         call setscb(searcha$off,save$searcha);
  778.         call setscb(searchl$off,save$searchl);
  779.         call setscb(hash1$off,save$hash1);
  780.         call setscb(hash2$off,save$hash2);
  781.         call setscb(hash3$off,save$hash3);
  782.         call copy(.savefcb,save$searcha,16);
  783.  
  784.         if (dcnt := search$next) = 0ffh then return(false);
  785.         call set$up$file(dcnt);
  786.         return(true);
  787.  
  788. end getnext;
  789.  
  790.  
  791. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  792.  
  793.                  /* print boolean option value */
  794. pbool: procedure(value);
  795.         declare
  796.            value byte;
  797.  
  798.         call printx(.option$set);
  799.         if value then call printx(.('ON',0));
  800.         else call printx(.('OFF',0));
  801.  
  802. end pbool;
  803.  
  804. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  805.  
  806.  
  807. /*******************************************************
  808.  
  809.               F I L E   A T T R I B U T E S
  810.  
  811. ********************************************************/
  812.  
  813.  
  814.  
  815. printatt: procedure;            /* print attribute set */
  816.  
  817.   attribute: procedure(i) byte; /* test if attribute fcbv(i) is on */
  818.        declare i byte;
  819.  
  820.        if rol(fcbv(i),1) then return true;
  821.        return false;
  822.   end attribute;
  823.  
  824.                                 /* display attributes: sys,ro,a,f1-f4 */
  825.  
  826.         call printx(.set$to);
  827.         if attribute(sysfile) then call printx(.('system (SYS)',0));
  828.         else call printx(.('directory (DIR)',0));
  829.  
  830.         call printx(.(', ',0));
  831.         if attribute(rofile) then do;
  832.                 call printx(.read$only);
  833.                 call printx(.ro);
  834.         end;
  835.         else call printx(.read$write);
  836.  
  837.         call printchar(tab);
  838.         if attribute(archiv) then call printchar('A');
  839.         if attribute( attrb1 ) then call printchar('1');
  840.         if attribute( attrb2 ) then call printchar('2');
  841.         if attribute( attrb3 ) then call printchar('3');
  842.         if attribute( attrb4 ) then call printchar('4');
  843.  
  844. end print$att;
  845.  
  846. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  847.  
  848.  
  849.                                         /* read current file attributes */
  850. rd$attributes: procedure;
  851.  
  852.     if not sfacmd then                  /* have read the FCB yet? */
  853.         if not wild then do;
  854.             call setdma(.dirbuf);
  855.             call set$up$file(search$first(.fcb));
  856.         end;
  857.  
  858. end rd$attributes;
  859.  
  860. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  861.  
  862.  
  863. /*******************************************************
  864.  
  865.              D R I V E   A T T R I B U T E S
  866.  
  867. ********************************************************/
  868.  
  869.  
  870. setdrvstatus: procedure(func);          /* set drive attributes */
  871.  
  872.         declare
  873.                 code    byte,
  874.                 func    byte;
  875.  
  876.                                                         /* set the drive */
  877.     if func = opt$ro then code = writeprot;             /* read only */ 
  878.     else
  879.         code = reset$drv(cdisk);                /* read/write */
  880.  
  881.                                                 /* display */
  882.     if code <> 0ffh then do;
  883.         call print(.('Drive ',0));
  884.         call printdrv;
  885.         call printb;
  886.         call printx(.set$to);
  887.         if func = opt$ro then do;
  888.             call printx(.read$only);
  889.             call printx(.ro);
  890.         end;
  891.         else
  892.             call printx(.read$write);
  893.     end;
  894.  
  895. end setdrvstatus;
  896.  
  897. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  898.  
  899. /*******************************************************
  900.  
  901.              L A B E L   A T T R I B U T E S
  902.  
  903. ********************************************************/
  904.  
  905.  
  906.                                  /* read the directory label before
  907.                                     writing the label to preserve the
  908.                                     name, type, and stamps */
  909. readlabel: procedure;
  910.     dcl (mode, dcnt) byte;
  911.         
  912. /*--------------------------------------------------------------*/
  913. readlbl: proc;
  914.     dcl d byte data('?');
  915.     
  916.     call setdma(.dirbuf);
  917.     dcnt = search$first(.d);            /* position to first dcnt in dir */
  918.     do while dcnt <> 0ffh;              /* read entire directory */
  919.                                         /* is the user# a label = 20h */
  920.         if dirbuf(ror(dcnt,3) and 110$0000b)=20H then return;
  921.         dcnt = search$next;
  922.     end;
  923.  
  924. end readlbl;
  925.  
  926. /*---------------------------------------------------------------*/
  927.  
  928.     if lblcmd then return;  
  929.  
  930.     mode = getlbl(cdisk);               /* get the dir label data byte */
  931.     password = false;
  932.     if mode > 0 then do;                /* if ok then ...*/
  933.         call readlbl;                   /* get label */
  934.         fcbp = shl(dcnt,5) + .dirbuf;
  935.         fext = fext and 11110000b;      /* turn off set passwd */
  936.         if fcbv(16) <> ' ' then
  937.             if fcbv(16) <> 0 then
  938.                 password = true;
  939.     end;
  940.  
  941.     else do;                            /* no dir label */
  942.         fcbp = .fcb;
  943.         call copy(.label$name,.fcb(1),length(label$name));
  944.     end;
  945.  
  946. /*    if password then call getpasswd;*/   /* does the user have the password*/
  947.     lblcmd = true;
  948.  
  949. end readlabel;
  950.  
  951.  
  952. /**************************************************************************/
  953.  
  954.  
  955. put$file: procedure;                    /* display the file or xfcb */
  956.  
  957.     call crlf;
  958.     call printfn;
  959.     call printb;
  960.     call printb;
  961.  
  962. end put$file;
  963.  
  964.  
  965. /*******************************************************
  966.  
  967.              S F C B     A T T R I B U T E S
  968.  
  969. ********************************************************/
  970.  
  971.  
  972.  
  973. set$up$xfcb: procedure;                 /* read xfcb into xfcb buffer */
  974.  
  975.         if not xfcbcmd then do;
  976.                 xfcbcmd = true;
  977.                 call copy(.fcbv,.xfcb,12);
  978.                 password,passmode = 0;
  979.  
  980.                 if low(errorcode := readxfcb(.xfcb)) = 0ffh then do;
  981.                         if high(errorcode) <> 0 then call bdos$error;
  982.                         else do;
  983.                                 call errprint(.not$found);
  984.                                 call put$file;
  985.                         end;
  986.                         return;
  987.                 end;
  988.  
  989.                 passmode = xfcb(12);
  990.                 if passmode <> 0 then password = true;  /* must have a pass if
  991.                                                            mode ~= NONE */
  992.         end;
  993.  
  994. end set$up$xfcb;
  995. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  996.  
  997.  
  998. /*******************************************************
  999.  
  1000.          PASSWORD  AND  PASSWORD  MODE  ROUTINES
  1001.  
  1002. ********************************************************/
  1003.  
  1004.  
  1005. defaultpass: procedure;
  1006.  
  1007.         if NONBANK then do;
  1008.                 call errprint(.errNBANK);
  1009.                 return;
  1010.         end;
  1011.  
  1012.         call fill(.passwd(0),' ',8);
  1013.         call copy(defpass,.passwd(0),lendef);
  1014.         call mon1(106,.passwd);
  1015.         call print(.('Default password = ',0));
  1016.         passwd(8) = 0;
  1017.         call printx(.passwd);
  1018.  
  1019. end defaultpass;
  1020.  
  1021.  
  1022. set$password: procedure;
  1023.  
  1024.         if fileref then do;
  1025.  
  1026.                 if NONBANK then do;
  1027.                         call errprint(.errNBANK);
  1028.                         return;
  1029.                 end;
  1030.  
  1031.                 call set$up$xfcb;
  1032.                 passmode = passmode or 1;       /* turn on password bit */
  1033.         end;
  1034.         else do;
  1035.                 call readlabel;
  1036.                 fext = fext or 1;
  1037.         end;
  1038.  
  1039.         call fill(.passwd(8),' ',8);            /* clear passwd */
  1040.  
  1041.         if lenpass = 0 then do;
  1042.                 passmode = 1;
  1043.                 return;
  1044.         end;
  1045.  
  1046.         newpass = true;
  1047.         call copy(passname,.passwd(8),lenpass);  /* copy it to fcb */
  1048.  
  1049. end set$password;
  1050.  
  1051. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1052.  
  1053.  
  1054. /*******************************************************
  1055.  
  1056.                 LABEL  ATTRIBUTE  ROUTINES
  1057.  
  1058. ********************************************************/
  1059.  
  1060. lname: procedure;                       /* sets the label name */
  1061.         declare i       byte,
  1062.                 ln      based labname (1) byte;
  1063.  
  1064.         if drvmsg then return;
  1065.  
  1066.         if fileref then do;
  1067.            call errprint(.err$driveonly);
  1068.            drvmsg = true;
  1069.            return;
  1070.         end;
  1071.  
  1072.         call readlabel;
  1073.  
  1074.         call fill(.fcbv(1),' ',11);             /* clear name */
  1075.  
  1076.         if lenlab > 0 then do;
  1077.            do i = 0 to lenlab-1;
  1078.                 if ln(i) = PERIOD then do;
  1079.                         call copy(labname,.fcbv(1),i);
  1080.                         call copy(labname+i+1,.fcbv(9),3);
  1081.                         return;
  1082.                 end;
  1083.            end;
  1084.  
  1085.            call copy(labname,.fcbv(1),lenlab);   /* copy label name */
  1086.  
  1087.         end;
  1088.  
  1089. end lname;
  1090.  
  1091. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1092.  
  1093.  
  1094. set$extent: procedure(function,maskon,maskoff);
  1095.         declare
  1096.                 function        byte,
  1097.                 maskon          byte,
  1098.                 maskoff         byte;
  1099.  
  1100.         if drvmsg then return;
  1101.  
  1102.         if fileref then do;
  1103.                 drvmsg = true;
  1104.                 call errprint(.err$driveonly);
  1105.                 return;
  1106.         end;
  1107.  
  1108.         call readlabel;
  1109.         if mods$map(function) then fext = fext or maskon;   /* turn stamp on */
  1110.         else fext = fext and maskoff;                      /* turn stamp off */
  1111.  
  1112.         return;
  1113.  
  1114. end set$extent;
  1115.  
  1116.  
  1117. protect: procedure;                     /* set drive protection mode */
  1118.         declare pmode   byte;
  1119.  
  1120.         if fileref then  do;
  1121.                 call set$up$xfcb;
  1122.                 pmode = mods$map(opt$prot);
  1123.  
  1124.                 if pmode = 2 then passmode = 80h;       /* read only */
  1125.                 else
  1126.                 if pmode = 3 then passmode = 40h;       /* write,read */
  1127.                 else
  1128.                 if pmode = 4 then passmode = 20h;       /* r,w,delete */
  1129.                 else do ;
  1130.                         passmode = 1;                   /* turn off protection*/
  1131.  
  1132.                         call fill(.passwd(8),' ',8);
  1133.                 end;
  1134.                 if newpass then passmode = passmode or 1;
  1135.         end;
  1136.         else do;
  1137.  
  1138.                 if NONBANK then do;
  1139.                         call errprint(.errNBANK);
  1140.                         return;
  1141.                 end;
  1142.  
  1143.                 pmode = mods$map(opt$prot);
  1144.                 if pmode > 1 then do;
  1145.                         call errprint(.errDrvProt);
  1146.                         return;
  1147.                 end;
  1148.  
  1149.                 call set$extent(opt$prot,pwmask$on,pwmask$off);
  1150.                 call fill(.fcbv(16),' ',8);             /* erase password */
  1151.         end;
  1152.  
  1153. end protect;
  1154.  
  1155. /*------------------------------------------------------------*/
  1156.  
  1157.                                         /* set attribute bits:
  1158.                                                 f1 --> f4 flags 
  1159.                                                 t1 --> t3 flags or
  1160.                                                    RO
  1161.                                                    SYS
  1162.                                                    Archive      */
  1163.  
  1164. setatt: procedure(func,bytes);
  1165.         declare func    byte,
  1166.                 bytes   byte;
  1167.  
  1168.  
  1169.         if sfamsg then return;                  /* printed msg before? */
  1170.         if not fileref then do;
  1171.                 sfamsg = true;
  1172.                 call errprint(.err$nofile);
  1173.                 return;
  1174.         end;
  1175.  
  1176.         if mods$map(func) then fcbv(bytes) = fcbv(bytes) or 80h;
  1177.         else fcbv(bytes) = fcbv(bytes) and 7fh;
  1178.  
  1179.         sfacmd = true;
  1180. end setatt;
  1181.  
  1182. /*******************************************************
  1183.  
  1184.            S H O W   L A B E L   &   X F C B 
  1185.  
  1186. ********************************************************/
  1187.  
  1188.  
  1189. show$passwd: procedure;                 /* display the new password */
  1190.  
  1191.     call printx(.('Password = ',0));
  1192.     passwd(16) = 0;
  1193.     call printx(.passwd(8));
  1194.  
  1195. end show$passwd;
  1196.  
  1197. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1198.  
  1199.  
  1200. dcl label1 (*) byte data (
  1201. 'Directory       Passwds  Stamp    Stamp    Stamp',cr,lf,
  1202. 'Label           Reqd     Create   Access   Update',cr,lf,
  1203. '--------------  -------  -------  -------  -------',cr,lf,0);
  1204.  
  1205. showlbl: procedure;                     /* show the label options */
  1206.     declare (make,access) byte;
  1207.  
  1208.     call print(.('Label for drive ',0));
  1209.     call printdrv;
  1210.     call crlf;
  1211.     call print(.label1);
  1212.     call printfn;
  1213.  
  1214.     if (fext and 80h) = 80h then        /* PASSWORDS REQUIRED */
  1215.         call printx(.on);
  1216.     else
  1217.         call printx(.off);
  1218.  
  1219.     access = (fext and 40h) = 40h;      /* STAMP CREATE */
  1220.     if (fext and 10h) = 10h then 
  1221.         call printx(.on);
  1222.     else
  1223.         call printx(.off);
  1224.  
  1225.     if access then                      /* STAMP ACCESS */
  1226.         call printx(.on);
  1227.     else
  1228.         call printx(.off);
  1229.  
  1230.     if (fext and 20h) = 20h then        /* STAMP UPDATE */
  1231.         call printx(.on);
  1232.     else
  1233.         call printx(.off);
  1234.  
  1235.     call crlf;
  1236.     if fext then do;
  1237.         call crlf;
  1238.         call show$passwd;
  1239.     end;
  1240.  
  1241. end showlbl;
  1242.  
  1243. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1244.  
  1245.  
  1246. show$xfcb: procedure;                   /* display xfcb attributes */
  1247.  
  1248.         call printx(.('Protection = ',0));
  1249.  
  1250.         if (passmode and 80h) = 80h then call printx(.readmode);
  1251.         else
  1252.         if (passmode and 40h) = 40h then call printx(.writemode);
  1253.         else
  1254.         if (passmode and 20h) = 20h then call printx(.deletemode);
  1255.         else
  1256.         if (not passmode) or (passwd(8) = ' ') then call printx(.nopasswd);
  1257.         else
  1258.             call printx(.readmode);
  1259.  
  1260.         if passmode then do;                /* lsb on */
  1261.                 call printx(.comma);
  1262.                 call show$passwd;
  1263.         end;
  1264.  
  1265. end show$xfcb;
  1266.  
  1267.  
  1268. /*******************************************************
  1269.  
  1270.         WRITE  XFCB, LABEL  AND  FILE  ATTRIBUTES
  1271.  
  1272. ********************************************************/
  1273.  
  1274. pass$check: procedure(which) byte;
  1275.         declare which   byte;
  1276.                                         /* did we fail because of password?
  1277.                                            if so, then get it and re-try.
  1278.                                                 which = 1 <-- put$attribute
  1279.                                                         2 <-- write$label
  1280.                                                         3 <-- write$xfcb */
  1281.         if high(error$code) = 7 then do;
  1282.                 call crlf;
  1283.                 if which <> 2 then call put$file;
  1284.                 else call print(.dirlabel);
  1285.                 call getpasswd;
  1286.                 if fileref then call crlf;
  1287.                                         /* put attributes ? */
  1288.                 if which = 1 then error$code = setind(fcbp);
  1289.                 else                    /* write label ? */
  1290.                 if which = 2 then error$code = wrlbl(fcbp);
  1291.                 else                    /* update xfcb */
  1292.                         error$code = wrxfcb(.xfcb);
  1293.  
  1294.                 if high(error$code) <> 0 then do;
  1295.                         call bdos$error;
  1296.                         if which = 2 then call print(.dirlabel);
  1297.                         else call put$file;
  1298.                         return(false);
  1299.                 end;
  1300.         end;
  1301.  
  1302.         return(true);
  1303.  
  1304. end pass$check;
  1305.  
  1306. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1307.  
  1308.  
  1309. put$attributes: procedure;              /* write file attributes */
  1310.  
  1311.     error$code = setind(fcbp);
  1312.  
  1313.     if low(error$code) = 0ffh then 
  1314.         if high(error$code) <> 0 then do;
  1315.                 if not pass$check(1) then return;
  1316.                 if high(error$code) <> 0 then do;
  1317.                         call bdos$error;
  1318.                         call put$file;
  1319.                         return;
  1320.                 end;
  1321.         end;
  1322.         else do;
  1323.                 call errprint(.not$found);
  1324.                 call put$file;
  1325.         end;
  1326.  
  1327.     if low(error$code) <> 0ffh then
  1328.         if fext <= dpb.extmsk then do;
  1329.             call put$file;
  1330.             call print$att;
  1331.         end;
  1332.  
  1333. end put$attributes;
  1334.  
  1335. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1336.  
  1337.  
  1338. write$label: procedure;                 /* write new label */
  1339.  
  1340.     error$code = wrlbl(fcbp);
  1341.  
  1342.     if low(error$code) = 0ffh then 
  1343.         if high(error$code) <> 0 then do;
  1344.                 if not pass$check(2) then return;
  1345.                 if high(error$code) <> 0 then do;
  1346.                         call bdos$error;
  1347.                         call print(.dirlabel);
  1348.                         return;
  1349.                 end;
  1350.                 call crlf;
  1351.         end;
  1352.         else do;
  1353.                 call errprint(.errFORMAT);
  1354.                 return;
  1355.         end;
  1356.  
  1357.         call showlbl;
  1358.  
  1359. end write$label;
  1360.  
  1361. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1362.  
  1363.  
  1364. write$xfcb: procedure;                  /* write out new xfcb */
  1365.  
  1366.         if passmode > 1 then do;
  1367.                 if password then go to wr0;
  1368.                 if newpass then go to wr0;
  1369.  
  1370.                         if passmsg then return;
  1371.  
  1372.                         if wild then 
  1373.                            call errprint(.errWASSPASS);
  1374.                         else do;
  1375.                          call errprint(.errASSPASS);
  1376.                          call put$file;
  1377.                         end;
  1378.  
  1379.                         passmsg = true;
  1380.                         return;
  1381.         end;
  1382.  
  1383. wr0:    if passmode = 1 then
  1384.            if newpass then passmode = passmode or 80h;  /* read mode = def */
  1385.  
  1386.         xfcbmode = passmode;
  1387.         error$code = wrxfcb(.xfcb);
  1388.  
  1389.         if low(error$code) = 0ffh then 
  1390.            if high(error$code) <> 0 then do;
  1391.                 if not pass$check(3) then return;
  1392.                 if high(error$code) <> 0 then do;
  1393.                         call bdos$error;
  1394.                         call put$file;
  1395.                         return;
  1396.                 end;
  1397.            end;
  1398.            else do;
  1399.                 call errprint(.not$found);
  1400.                 call print(.('       or protection not enabled for disk.',0));
  1401.                 return;
  1402.            end;
  1403.  
  1404.         if passmode = 1 then do;                /* delete xfcb */
  1405. wr1:            xfcb(5) = xfcb(5) or 80h;
  1406.                 error$code = delete(.xfcb);     /* no need to check for error*/
  1407.         end;                                    /* previous write-> failed!*/
  1408.  
  1409.  
  1410.         call put$file;
  1411.         call show$xfcb;                 /* errcode is good if we are here */
  1412.  
  1413. end write$xfcb;
  1414.  
  1415.  
  1416.  
  1417.  
  1418. /*******************************************************
  1419.  
  1420.            C O M M A N D   P R O C E S S I N G
  1421.  
  1422. ********************************************************/
  1423.  
  1424.  
  1425.  
  1426. setdisk: procedure;             /* select the disk specified in cmd line */
  1427.  
  1428.     if cmd(0) <> 0 then do;
  1429.         cdisk = cmd(0)-1;
  1430.         call select(cdisk);
  1431.         call set$dpb;
  1432.         end;
  1433.  
  1434. end setdisk;
  1435.  
  1436. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1437.  
  1438.  
  1439. wildcard: procedure byte;               /* test if the file is a wildcard */
  1440.     declare
  1441.         i byte;
  1442.  
  1443.         do i=1 to fnam;
  1444.                 if fcb(i) = '?' then return true;
  1445.         end;
  1446.         return false;
  1447. end wildcard;
  1448.  
  1449. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1450.  
  1451.  
  1452. setup$fcb: procedure;           /* set up the next file or drive reference */
  1453.         declare dcnt    byte;
  1454.  
  1455.         call setdisk;
  1456.         call copy(.cmd,.fcb,12);       /* name */
  1457.         call copy(.cmd(16),.passwd,8); /* password */
  1458.  
  1459.         if fcb(1) <> ' ' or fcb(ftyp) <> ' ' then do;
  1460.                 fileref = true;
  1461.                 call setdma(.dirbuf);
  1462.                 if (dcnt := search$first(.fcb)) = 0ffh then do;
  1463.                         fcbp = .fcb;
  1464.                         call errprint(.not$found);
  1465.                         call put$file;
  1466.                         call terminate;
  1467.                 end;
  1468.                 call set$up$file(dcnt);
  1469.         end;
  1470.         else fileref = false;
  1471.  
  1472. end setup$fcb;
  1473.  
  1474. $include (sopt.inc)
  1475.  
  1476. parse$options:  procedure;
  1477.  
  1478.         declare
  1479.                 charac          based buf$ptr byte,
  1480.                 l               byte;
  1481.  
  1482.         delimiter = 1;
  1483.         index = 0;
  1484.         mindex = 0;
  1485.  
  1486. loop:
  1487.         if delimiter = 0 then return;
  1488.         if delimiter = RBRACKET then return;
  1489.         if delimiter = ENDFF then return;
  1490.  
  1491.                                         /* get the index into list */
  1492.         if (index := opt$scanner(.options,.off$opt)) = 0 then go to error1;
  1493.  
  1494.                                         /* if we have more to parse,
  1495.                                            check for valid modifiers */
  1496.         if (delimiter <> RBRACKET and delimiter <> ENDFF) then do;
  1497.  
  1498.                                         /* is this a mod delimiter?
  1499.                                            test for equal sign. */
  1500.                 if delimiter = EQUAL then do;
  1501.                                         /* does option have a modifier?*/
  1502.  
  1503.                        if not opt$mod(index-1).modifier(0) then go to error2;
  1504.  
  1505.                                         /* is this a string modifier, ie.,
  1506.                                            password,default,name option */
  1507.  
  1508.                        if not opt$mod(index-1).modifier(7) then do;
  1509.  
  1510.                                if (mindex := opt$scanner(.mods,.off$mods)) = 0 
  1511.                                    then go to error3;
  1512.  
  1513.                                         /* invalid option-modifier pair */
  1514.  
  1515.                                 if not opt$mod(index-1).modifier(mindex) then 
  1516.                                         go to error4;
  1517.  
  1518.                        end;             /* ends getting non-string mod */
  1519.                         
  1520.                        else do;
  1521.                                         /* get string */
  1522.                                 string$ptr = buf$ptr;
  1523.                                 mindex = 8;
  1524.                                 delimiter = 0;
  1525.                                 l = 0;
  1526.                                 do while delimiter = 0;
  1527.                                         delimiter = separator(charac);
  1528.                                         buf$ptr = buf$ptr + 1;
  1529.                                         l = l + 1;
  1530.                                 end;
  1531.  
  1532.                                 if delimiter = SPACE then do;
  1533.                                         delimiter = separator(charac);
  1534.                                         buf$ptr = buf$ptr + 1;
  1535.                                 end;
  1536.  
  1537.                                 l = l - 1;
  1538.                                 if l > 0 then do;
  1539.                                    if (index -1) = opt$default then do;
  1540.                                         defpass = string$ptr;
  1541.                                         if (lendef := l) > 8 then do;
  1542.                                            call errprint(.errBIGDEF);
  1543.                                            lendef = 8;
  1544.                                         end;
  1545.                                    end;
  1546.                                    else
  1547.                                    if (index -1) = opt$name then do;
  1548.                                         labname = string$ptr;
  1549.                                         if (lenlab := l) > 11 then do;
  1550.                                            lenlab = 11;
  1551.                                            call errprint(.errBIGNAME);
  1552.                                         end;
  1553.                                    end;
  1554.                                    else do;
  1555.                                         passname = string$ptr;
  1556.                                         if (lenpass := l) > 8 then do;
  1557.                                            call errprint(.errBIGPASS);
  1558.                                            lenpass= 8;
  1559.                                         end;
  1560.                                    end;
  1561.                                 end;
  1562.                          end;
  1563.                 end;            /* ends mod delimiter? */
  1564.         end;                    /* ends last delimiter */
  1565.  
  1566.                                         /* option without modifier...
  1567.                                            index must be > 0 */
  1568.        if mindex = 0 and opt$mod(index-1).modifier(0) then go to error5;
  1569.  
  1570.        option$map(index - 1) = true;
  1571.        if mindex > 0 then mods$map(index - 1) = mindex - 1;
  1572.  
  1573.        go to loop;                      /* skip error routine */
  1574.  
  1575. error1: call errprint(.errUNREC);
  1576.         go to optprt;
  1577. error2: call errprint(.errNOMOD);
  1578.         go to optprt;
  1579. error3: call errprint(.errUNRECM);
  1580.         go to modprt;
  1581. error4: call errprint(.errVALM);
  1582.         go to modprt;
  1583. error5: call errprint(.errOPTMOD);
  1584.         go to optprt;
  1585. modprt: call print(.('Modifier: ',0));
  1586.         go to errprt;
  1587. optprt: call print(.('Option: ',0));
  1588. errprt: call error$prt;
  1589.  
  1590.         go to loop;
  1591.  
  1592. end parse$options;
  1593.  
  1594. do$options:     procedure;
  1595.         declare dump    byte;
  1596.  
  1597.         if option$map(opt$archive) then
  1598.                 call setatt(opt$archive,archiv);
  1599.  
  1600.         if option$map(opt$f1) then call setatt(opt$f1,attrb1);
  1601.         if option$map(opt$f2) then call setatt(opt$f2,attrb2);
  1602.         if option$map(opt$f3) then call setatt(opt$f3,attrb3);
  1603.         if option$map(opt$f4) then call setatt(opt$f4,attrb4);
  1604.  
  1605.         if option$map(opt$name) then call lname;        /*Dir name*/
  1606.         if option$map(opt$pass) then call set$password;
  1607.         if option$map(opt$prot) then call protect;
  1608.         if option$map(opt$default) then call defaultpass;
  1609.  
  1610.         if option$map(opt$access) and option$map(opt$create) then do;
  1611.                 if mods$map(opt$access) and mods$map(opt$create) then do;
  1612.                         if fileref then call errprint(.err$driveonly);
  1613.                         call errprint(.errCRAC);
  1614.                         call crlf;
  1615.                         go to do1;
  1616.                 end;
  1617.         end;
  1618.  
  1619.         if option$map(opt$access) then do;
  1620.                 if mods$map(opt$access) then do;        /* turn off create */
  1621.                         mods$map(opt$create) = 0;
  1622.                         call set$extent(opt$create,crmask$on,crmask$off);
  1623.                 end;
  1624.                 call set$extent(opt$access,acmask$on,acmask$off);
  1625.         end;
  1626.         if option$map(opt$create) then do;
  1627.                 if mods$map(opt$create) then do;        /* turn off access */
  1628.                         mods$map(opt$access) = 0;
  1629.                         call set$extent(opt$access,acmask$on,acmask$off);
  1630.                 end;
  1631.                 call set$extent(opt$create,crmask$on,crmask$off);
  1632.         end;
  1633.  
  1634.                                         /* Note that sys and dir do NOT have
  1635.                                            modifiers; thus the option scanner
  1636.                                            did not fill in the modifier map,
  1637.                                            which setatt looks at to turn things
  1638.                                            on/off.  So we have to set the mod
  1639.                                            map here.  applies to archive too */
  1640.  
  1641. do1:    if option$map(opt$dir) and option$map(opt$sys) then do;
  1642.                 if not fileref then call errprint(.err$nofile);
  1643.                 call errprint(.errSYSDIR);
  1644.                 call crlf;
  1645.         end;
  1646.         else do;
  1647.                 if option$map(opt$dir) then
  1648.                                                 /* do not turn sys on */
  1649.                         call setatt(opt$sys,sysfile);
  1650.  
  1651.                 else if option$map(opt$sys) then do;
  1652.                         mods$map(opt$sys) = true;
  1653.                         call setatt(opt$sys,sysfile);
  1654.                 end;
  1655.         end;
  1656.  
  1657.         if option$map(opt$update) then
  1658.                 call set$extent(opt$update,upmask$on,upmask$off);
  1659.  
  1660.         if option$map(opt$ro) and option$map(opt$rw) then do;
  1661.                 call errprint(.errRORW);
  1662.                 call crlf;
  1663.         end;
  1664.         else do;
  1665.                 if option$map(opt$ro) then 
  1666.                    if fileref then do;
  1667.                         mods$map(opt$ro) = 1;
  1668.                         call setatt(opt$ro,rofile);
  1669.                    end;
  1670.                    else call setdrvstatus(opt$ro);
  1671.                 else
  1672.                 if option$map(opt$rw) then 
  1673.                    if fileref then do;
  1674.                                         /* turn ro off */
  1675.                         mods$map(opt$ro) = 0;
  1676.                         call setatt(opt$ro,rofile);
  1677.                    end;
  1678.                    else call setdrvstatus(opt$rw);
  1679.         end;
  1680. end do$options;
  1681.  
  1682. save: procedure;
  1683.  
  1684.                                 /* save search parameters for later wild
  1685.                                    card processing */
  1686.  
  1687.         save$dcnt = getscbword(dcnt$off);
  1688.         save$searcha = getscbword(searcha$off);
  1689.         save$searchl = getscbword(searchl$off);
  1690.         save$hash1 = getscbword(hash1$off);
  1691.         save$hash2 = getscbword(hash2$off);
  1692.         save$hash3 = getscbword(hash3$off);
  1693.  
  1694. end save;
  1695.  
  1696.  
  1697. savewild: procedure;
  1698.  
  1699.                                 /* save wildcard name for later processing */
  1700.         if (wild := wildcard) then call copy(.cmd,.savefcb,12);
  1701.         call setup$fcb;
  1702.  
  1703. end savewild;
  1704.  
  1705.  
  1706. getfilename: procedure(buffadd);
  1707.         declare buffadd         address;
  1708.  
  1709.         parse$fn.buff$adr = buffadd;
  1710.         last$buff$adr = buffadd;       /* used by perror routine */
  1711.         parse$fn.fcb$adr = .cmd;
  1712.         ibp = parser;                   /* parse file name */
  1713.  
  1714. end getfilename;
  1715.  
  1716. getfname: procedure;
  1717.  
  1718.         call getfilename(bufptr);
  1719.  
  1720.         if optdel then do;                      /* no local options */
  1721.                 call errprint(.errGLOBAL);
  1722.                 cmd(12) = 0;
  1723.                 call print(.('FILE: ',0));
  1724.                 call printx(.cmd(1));
  1725.                 call terminate;
  1726.         end;
  1727.                                                 /* F152 returns ~= 0 if
  1728.                                                    another file name
  1729.                                                    follows in buffer */
  1730.         if ibp <> 0 then multi = true;
  1731.         else multi = false;
  1732.  
  1733.         call copy(.cmd,.fcb,16);                /* copy file name to 
  1734.                                                    default buffer..*/
  1735.         call savewild;
  1736.  
  1737. end getfname;
  1738.  
  1739. $eject
  1740. /*******************************************************
  1741.  
  1742.                 M A I N  P R O G R A M
  1743.  
  1744. ********************************************************/
  1745.  
  1746. declare 
  1747.         i              byte   initial (1),
  1748.         last$dseg$byte byte   initial (0),
  1749.         (vlow,vhigh)   byte;
  1750.  
  1751. /*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/
  1752.  
  1753. exec: procedure;
  1754.  
  1755.  
  1756.         do while more;
  1757.  
  1758.                 if wild then call save;
  1759.  
  1760.                 call do$options;        /* perform options specified */
  1761.  
  1762.                 call return$errors(0FFh);  /* Return mode */
  1763.  
  1764.                 if lblcmd then             /* label options */
  1765.                    call write$label;
  1766.                 else do;
  1767.                         if sfacmd then        /* file attributes*/
  1768.                                 call put$attributes;
  1769.                         if xfcbcmd then            /* xfcb attributes*/
  1770.                                 call write$xfcb;
  1771.                 end;
  1772.  
  1773.                 call return$errors(0);  
  1774.  
  1775.                 if not wild then more = false;
  1776.                                         /*wild card expansion */
  1777.                 else 
  1778.                    if not getnext then more = false;
  1779.  
  1780.         end;
  1781.  
  1782. end exec;
  1783.  
  1784. /*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/
  1785.  
  1786. plm:
  1787.         ver = get$version;
  1788.         vlow = low(ver);
  1789.         vhigh = high(ver);
  1790.  
  1791.         line$page = getpage;                    /* #lines per page */
  1792.         line$out = 0;
  1793.  
  1794.         if vlow < cpmversion then go to errver;
  1795.  
  1796.         user$code = getuser;
  1797.         call set$dpb;                           /* get disk parameter blk */
  1798.         cdisk=cselect;                          /* get current disk */
  1799.  
  1800.         do while buff(i)=' ';
  1801.                 i = i + 1;
  1802.         end;
  1803.         buf$ptr = .buff(i);
  1804.         
  1805.         if buff(i) = '[' then do;               /* first, options */
  1806.                 buf$ptr = buf$ptr + 1;
  1807.                 call parse$options;             /* delimiter = ] or
  1808.                                                     null if end of cmd tail */
  1809.  
  1810.                 if delimiter = RBRACKET then call getfname;
  1811.                 else do;
  1812.                   call fill(.cmd(1),' ',26);      /* blank out command line */
  1813.                   cmd(0) = 0;
  1814.                 end;
  1815.         end;
  1816.         else do;                                /* filename ? */
  1817.                 call getfilename(.buff(1));     /* will set multi */
  1818.  
  1819.                 if optdel then do;
  1820.                         buf$ptr = ibp;
  1821.                         call parseoptions;
  1822.                 end;
  1823.                 else do;
  1824.                         call errprint(.errNOPT);
  1825.                         call terminate;
  1826.                 end;
  1827.                 call savewild;
  1828.         end;
  1829.  
  1830.         if option$map(opt$page) and option$map(opt$nopage) then do;
  1831.                 call errprint(.errPAGE);
  1832.                 call crlf;
  1833.                 PAGE = false;
  1834.         end;
  1835.         else if option$map(opt$nopage) then PAGE = false;
  1836.              else if option$map(opt$page) then PAGE = true;
  1837.  
  1838.         if high(getscbword(COMbase)) = 0 then NONBANK = true;
  1839.  
  1840.         call exec;
  1841.         do while multi;
  1842.                 buf$ptr = ibp;
  1843.                 more = true;
  1844.                 call getfname;
  1845.                 call exec;
  1846.         end;
  1847.  
  1848.         call terminate;
  1849.  
  1850. errver: call errprint(.errVERS);
  1851.         call terminate;
  1852. end;
  1853.  
  1854.