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 / RENAME.PLM < prev    next >
Text File  |  1982-12-31  |  18KB  |  609 lines
  1. $ TITLE('CP/M 3.0 --- REN ')
  2. ren:
  3. do;
  4.  
  5. /*
  6.   Copyright (C) 1982
  7.   Digital Research
  8.   P.O. Box 579
  9.   Pacific Grove, CA 93950
  10. */
  11.  
  12. /*
  13.   Revised:
  14.     19 Jan  80  by Thomas Rolander
  15.     14 Sept 81  by Doug Huskey
  16.     23 June 82  by John Knight
  17.     29 Sept 82  by Thomas J. Mason
  18.     03 Dec  82  by Bruce Skidmore
  19. */
  20.  
  21. declare
  22.     mpmproduct literally '01h', /* requires mp/m */
  23.     cpmversion literally '30h'; /* requires 3.0 cp/m */
  24.  
  25.  
  26. declare
  27.     true    literally '0FFh',
  28.     false   literally '0',
  29.     forever literally 'while true',
  30.     lit     literally 'literally',
  31.     proc    literally 'procedure',
  32.     dcl     literally 'declare',
  33.     addr    literally 'address',
  34.     cr      literally '13',
  35.     lf      literally '10',
  36.     ctrlc   literally '3',
  37.     ctrlx   literally '18h',
  38.     bksp    literally '8',
  39.     dcnt$offset    literally '45h',
  40.     searcha$offset literally '47h',
  41.     searchl$offset literally '49h',
  42.     hash1$offset   literally '00h',
  43.     hash2$offset   literally '02h',
  44.     hash3$offset   literally '04h';
  45.  
  46.         
  47.   declare plm label public;
  48.  
  49.   /**************************************
  50.    *                                    *
  51.    *       B D O S   INTERFACE          *
  52.    *                                    *
  53.    **************************************/
  54.  
  55.  
  56.   mon1:
  57.     procedure (func,info) external;
  58.       declare func byte;
  59.       declare info address;
  60.     end mon1;
  61.  
  62.   mon2:
  63.     procedure (func,info) byte external;
  64.       declare func byte;
  65.       declare info address;
  66.     end mon2;
  67.  
  68.   mon3:
  69.     procedure (func,info) address external;
  70.       declare func byte;
  71.       declare info address;
  72.     end mon3;
  73.  
  74.   declare cmdrv     byte    external;    /* command drive      */
  75.   declare fcb (1)   byte    external;    /* 1st default fcb    */
  76.   declare fcb16 (1) byte    external;    /* 2nd default fcb    */
  77.   declare pass0     address external;    /* 1st password ptr   */
  78.   declare len0      byte    external;    /* 1st passwd length  */
  79.   declare pass1     address external;    /* 2nd password ptr   */
  80.   declare len1      byte    external;    /* 2nd passwd length  */
  81.   declare tbuff (1) byte    external;    /* default dma buffer */
  82.  
  83.  
  84.   /**************************************
  85.    *                                    *
  86.    *       B D O S   Externals          *
  87.    *                                    *
  88.    **************************************/
  89.  
  90.   read$console:
  91.     procedure byte;
  92.       return mon2 (1,0);
  93.     end read$console;
  94.  
  95.   conin: 
  96.     procedure byte;
  97.     return mon2(6,0ffh);
  98.     end conin;
  99.  
  100.   printchar:
  101.     procedure (char);
  102.       declare char byte;
  103.       call mon1 (2,char);
  104.     end printchar;
  105.  
  106.   print$buf:
  107.     procedure (buffer$address);
  108.       declare buffer$address address;
  109.       call mon1 (9,buffer$address);
  110.     end print$buf;
  111.  
  112.   read$console$buf:
  113.     procedure (buffer$address,max) byte;
  114.       declare buffer$address address;
  115.       declare new$max based buffer$address byte;
  116.       declare max byte;
  117.       new$max = max;
  118.       call mon1 (10,buffer$address);
  119.       buffer$address = buffer$address + 1;
  120.       return new$max;    /* actually number of chars input */
  121. end read$console$buf;
  122.  
  123.   check$con$stat:
  124.     procedure byte;
  125.       return mon2 (11,0);
  126.     end check$con$stat;
  127.  
  128.   version: procedure address;
  129.     /* returns current cp/m version # */
  130.     return mon3(12,0);
  131.     end version;
  132.  
  133.   search$first:
  134.     procedure (fcb$address) byte;
  135.       declare fcb$address address;
  136.       return mon2 (17,fcb$address);
  137.     end search$first;
  138.  
  139.   search$next:
  140.     procedure byte;
  141.       return mon2 (18,0);
  142.     end search$next;
  143.  
  144.   delete$file:
  145.     procedure (fcb$address);
  146.       declare fcb$address address;
  147.       call mon1 (19,fcb$address);
  148.     end delete$file;
  149.  
  150.   rename$file:
  151.     procedure (fcb$address) address;
  152.       declare fcb$address address;
  153.       return mon3 (23,fcb$address);
  154.     end rename$file;
  155.  
  156.   setdma: procedure(dma);
  157.     declare dma address;
  158.     call mon1(26,dma);
  159.     end setdma;
  160.  
  161.   /* 0ff => return BDOS errors */
  162.   return$errors:
  163.     procedure(mode);
  164.     declare mode byte;
  165.       call mon1 (45,mode);    
  166.     end return$errors;
  167.  
  168.   declare
  169.     parse$fn structure (
  170.       buff$adr  address,
  171.       fcb$adr   address);
  172.  
  173.   parse: procedure (pfcb) address external;
  174.     declare pfcb address;
  175.     end parse;
  176.  
  177.   declare scbpd structure
  178.     (offset byte,
  179.      set    byte,
  180.      value  address);
  181.  
  182.   getscbbyte:
  183.     procedure (offset) byte;
  184.       declare offset byte;
  185.       scbpd.offset = offset;
  186.       scbpd.set = 0;
  187.       return mon2(49,.scbpd);
  188.   end getscbbyte;
  189.  
  190.   getscbword:
  191.     procedure (offset) address;
  192.     declare offset byte;
  193.     scbpd.offset = offset;
  194.     scbpd.set = 0;
  195.     return mon3(49,.scbpd);
  196.   end getscbword;
  197.  
  198.   setscbword:
  199.     procedure (offset,value);
  200.       declare offset byte;
  201.       declare value address;
  202.       scbpd.offset = offset;
  203.       scbpd.set = 0FEh;
  204.       scbpd.value = value;
  205.       call mon1(49,.scbpd);
  206.   end setscbword;
  207.  
  208.  
  209.   /**************************************
  210.    *                                    *
  211.    *         GLOBAL VARIABLES           *
  212.    *                                    *
  213.    **************************************/
  214.  
  215.   /* Note: there are three fcbs used by
  216.      this program:
  217.  
  218.          1) new$fcb: the new file name
  219.             (this can be a wildcard if it
  220.             has the same pattern of question
  221.             marks as the old file name)
  222.             Any question marks are replaced
  223.             with the corresponding filename
  224.             character in the old$fcb before
  225.             doing the rename function.
  226.  
  227.          2) cur$fcb: the file to be renamed
  228.             specified in the rename command.
  229.             (any question marks must correspond
  230.             to question marks in new$fcb).
  231.  
  232.          3) old$fcb: a fcb in the directory
  233.             matching the cur$fcb and used in
  234.             the bdos rename function.  This
  235.             cannot contain any question marks.
  236.   */         
  237.  
  238.   declare successful lit '0FFh';
  239.   declare failed       (*) byte data(cr,lf,'ERROR: Not renamed, $'),
  240.           read$only    (*) byte data(cr,lf,'ERROR: Drive read only.$'),
  241.           bad$wildcard (*) byte data('Invalid wildcard.$');
  242.   declare passwd (8) byte;
  243.   declare 
  244.       new$fcb$adr address,       /* new name */
  245.       new$fcb based  new$fcb$adr (32) byte;
  246.   declare cur$fcb (33) byte;      /* current fcb (old name) */
  247.  
  248.   /**************************************
  249.    *                                    *
  250.    *       S U B R O U T I N E S        *
  251.    *                                    *
  252.    **************************************/
  253.  
  254.  
  255.                   /* upper case character from console */
  256. crlf:   proc;
  257.     call printchar(cr);
  258.     call printchar(lf);
  259.     end crlf;
  260.  
  261. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  262.  
  263.                   /* fill string @ s for c bytes with f */
  264. fill:   proc(s,f,c);
  265.     dcl s addr,
  266.         (f,c) byte,
  267.         a based s byte;
  268.  
  269.         do while (c:=c-1)<>255;
  270.         a = f;
  271.         s = s+1;
  272.         end;
  273.     end fill;
  274.  
  275. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  276.  
  277.                   /* error message routine */
  278. error:   proc(code);
  279.    declare
  280.       code byte;
  281.  
  282.     if code = 0 then do;  
  283.         call print$buf(.('ERROR:  No such file to rename.$'));
  284.         call mon1(0,0);
  285.         end;
  286.     if code=1 then do;
  287.         call print$buf(.(cr,lf,'Disk I/O.$'));
  288.         call mon1(0,0);
  289.         end;
  290.     if code=2 then do;
  291.         call print$buf(.read$only);
  292.         call mon1(0,0);
  293.         end;
  294.     if code = 3 then
  295.         call print$buf(.read$only(15));
  296.     if code = 5 then      
  297.         call print$buf(.('Currently Opened.$'));
  298.     if code = 7 then
  299.         call print$buf(.('Bad password.$'));
  300.     if code = 8 then      
  301.         call print$buf(.('file already exists$'));
  302.     if code = 9 then do;
  303.         call print$buf(.bad$wildcard);
  304.         call mon1(0,0);
  305.         end;
  306.     end error;
  307.  
  308. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  309.  
  310.                  /* print file name */
  311. print$file: procedure(fcbp);
  312.         declare k byte;
  313.         declare typ lit '9';        /* file type */
  314.         declare fnam lit '11';        /* file type */
  315.         declare
  316.             fcbp   addr,
  317.             fcbv   based fcbp (32) byte;
  318.  
  319.             do k = 1 to fnam;
  320.             if k = typ then 
  321.            call printchar('.');
  322.             call printchar(fcbv(k) and 7fh);
  323.             end;
  324.         end print$file;
  325.  
  326. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  327.  
  328.   /* try to rename fcb at old$fcb$adr to name at new$fcb$adr 
  329.             return error code if unsuccessful */
  330.   rename:
  331.     procedure(old$fcb$adr) byte;
  332.     declare
  333.        old$fcb$adr address,
  334.        old$fcb based  old$fcb$adr (32) byte,
  335.        error$code  address,
  336.        code        byte;
  337.        
  338.     call move (16,new$fcb$adr,old$fcb$adr+16);
  339.     call setdma(.passwd);                   /* password    */
  340.     call return$errors(0FFh);        /* return bdos errors */
  341.     error$code = rename$file (old$fcb$adr);
  342.     call return$errors(0);           /* normal error mode  */
  343.     if low(error$code) = 0FFh then do;
  344.         code = high(error$code);
  345.         if code < 3 then 
  346.             call error(code);
  347.         return code;
  348.         end;
  349.     return successful;      
  350.     end rename;
  351.  
  352. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  353.  
  354.                   /* upper case character from console */
  355. ucase:   proc(c) byte;
  356.     dcl c byte;
  357.  
  358.     if c >= 'a' then
  359.        if c < '{' then
  360.           return(c-20h);
  361.     return c;
  362.     end ucase;
  363.  
  364. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  365.  
  366.                   /* get password and place at fcb + 16 */
  367. getpasswd:   proc;
  368.     dcl (i,c) byte;
  369.  
  370.     call crlf;
  371.     call print$buf(.('Enter password: ','$'));
  372. retry:
  373.     call fill(.passwd,' ',8);
  374.         do i = 0 to 7;
  375. nxtchr:
  376.         if (c:=ucase(conin)) >= ' ' then 
  377.             passwd(i)=c;
  378.         if c = cr then do;
  379.             call crlf;
  380.             go to exit;
  381.             end;
  382.         if c = ctrlx then
  383.             goto retry;
  384.         if c = bksp then do;
  385.             if i<1 then
  386.                 goto retry;
  387.             else do;
  388.                 passwd(i:=i-1)=' ';
  389.                 goto nxtchr;
  390.                 end;
  391.             end;
  392.         if c = ctrlc then
  393.             call mon1(0,0);
  394.         end;
  395. exit:
  396.     c = check$con$stat;             /* clear raw I/O mode */
  397.     end getpasswd;
  398.  
  399. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  400.  
  401.                   /* check for wildcard in rename command */
  402. wildcard:   proc byte;
  403.     dcl (i,wild) byte;
  404.  
  405.     wild = false;
  406.         do i=1 to 11;
  407.         if cur$fcb(i) = '?' then
  408.             if new$fcb(i) <> '?' then do;
  409.                 call print$buf(.failed);
  410.                 call print$buf(.bad$wildcard);
  411.                 call mon1(0,0);
  412.                 end;
  413.             else
  414.                 wild = true;
  415.         end;
  416.     return wild;
  417.     end wildcard;
  418.  
  419. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  420.  
  421.                   /* set up new name for rename function */
  422. set$new$fcb:   proc(old$fcb$adr);
  423.     dcl old$fcb$adr address,
  424.         old$fcb based old$fcb$adr (32) byte;
  425.     dcl i byte;
  426.  
  427.     old$fcb(0) = cur$fcb(0);    /* set up drive */
  428.         do i=1 to 11;
  429.         if cur$fcb(i) = '?' then 
  430.             new$fcb(i) = old$fcb(i);
  431.         end;
  432.     end set$new$fcb;
  433.  
  434. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  435.  
  436.                   /* try deleting files one at a time */
  437.   single$file:
  438.     procedure;
  439.     declare (code,dcnt) byte;
  440.     declare (old$fcb$adr,savdcnt,savsearcha,savsearchl) addr;
  441.     declare old$fcb based old$fcb$adr (32) byte;
  442.     declare (hash1,hash2,hash3) address;
  443.  
  444.     file$err: procedure(fcba);
  445.         dcl fcba address;
  446.         call print$buf(.failed);
  447.         call print$file(fcba);
  448.         call printchar(' ');
  449.         call error(code);
  450.         end file$err;
  451.  
  452.     call setdma(.tbuff);
  453.     if (dcnt:=search$first(.cur$fcb)) = 0ffh then
  454.         call error(0);
  455.  
  456.         do while dcnt <> 0ffh;
  457.         old$fcb$adr = shl(dcnt,5) + .tbuff;
  458.         savdcnt = getscbword(dcnt$offset);
  459.         savsearcha = getscbword(searcha$offset);
  460.         savsearchl = getscbword(searchl$offset);
  461.         /* save searched fcb's hash code (5 bytes) */
  462.         hash1 = getscbword(hash1$offset);
  463.         hash2 = getscbword(hash2$offset);
  464.         hash3 = getscbword(hash3$offset);    /* saved one extra byte */
  465.         call set$new$fcb(old$fcb$adr);
  466.         if (code:=rename(old$fcb$adr)) = 8 then do;
  467.             call file$err(new$fcb$adr);
  468.             call print$buf(.(', delete (Y/N)?$'));
  469.             if ucase(read$console) = 'Y' then do;
  470.                 call delete$file(new$fcb$adr);
  471.                 code = rename(old$fcb$adr);
  472.                 end;
  473.             else
  474.                 go to next;
  475.             end;
  476.         if code = 7 then do;
  477.             call file$err(old$fcb$adr);
  478.             call getpasswd;
  479.             code = rename(old$fcb$adr);
  480.             end;
  481.         if code <> successful then 
  482.             call file$err(old$fcb$adr);
  483.         else do;
  484.             call crlf;
  485.             call print$file(new$fcb$adr);
  486.             call printchar('=');
  487.             call print$file(old$fcb$adr);
  488.             end;
  489. next:
  490.         call setdma(.tbuff);
  491.         call setscbword(dcnt$offset,savdcnt);
  492.         call setscbword(searcha$offset,savsearcha);
  493.         call setscbword(searchl$offset,savsearchl);
  494.         /* restore hash code */
  495.         call setscbword(hash1$offset,hash1);
  496.         call setscbword(hash2$offset,hash2);
  497.         call setscbword(hash3$offset,hash3);
  498.         if .cur$fcb <> savsearcha then  /*restore orig fcb if destroyed*/
  499.           call move(16,.cur$fcb,savsearcha);
  500.         dcnt = search$next;
  501.         end;
  502.     end single$file;
  503.  
  504. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  505.  
  506.                   /* invalid rename command */
  507. bad$entry:   proc;
  508.  
  509.     call print$buf(.failed);
  510.     call print$buf(.('ERROR:  Invalid File.',cr,lf,'$'));
  511.     call mon1(0,0);
  512.     end bad$entry;
  513.  
  514.  
  515. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  516.  
  517. finish$parse: procedure;
  518.   parse$fn.buff$adr = parse$fn.fcb$adr+1;     /* skip delimiter */
  519.   parse$fn.fcb$adr = .cur$fcb;
  520.   parse$fn.fcb$adr = parse(.parse$fn);
  521.   call move(8,.cur$fcb+16,.passwd);
  522. end finish$parse;
  523.  
  524. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  525.  
  526. input$found: procedure (buffer$adr) byte;
  527.   declare buffer$adr address;
  528.   declare char based buffer$adr byte;
  529.   do while (char = ' ') or (char = 9); /* tabs & spaces */
  530.     buffer$adr = buffer$adr + 1;
  531.   end;
  532.   if char = 0 then    /* eoln */
  533.     return false;    /* input not found */
  534.   else
  535.     return true;    /* input found */
  536. end input$found;
  537.  
  538. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  539.  
  540.   /**************************************
  541.    *                                    *
  542.    *       M A I N  P R O G R A M       *
  543.    *                                    *
  544.    **************************************/
  545.  
  546. declare ver address;
  547. declare i byte;
  548. declare no$chars byte;    /* number characters input */
  549. declare second$string$ptr address;    /* points to second filename input */
  550. declare ptr based second$string$ptr byte;
  551. declare last$dseg$byte byte
  552.   initial (0);
  553.  
  554. plm:
  555.   ver = version;
  556.   if (low(ver) < cpmversion) or (high(ver) = mpmproduct) then do;
  557.     call print$buf(.('Requires CP/M 3.0','$'));
  558.     call mon1(0,0);
  559.   end;
  560.  
  561.   parse$fn.buff$adr = .tbuff(1);
  562.   new$fcb$adr, parse$fn.fcb$adr = .fcb;
  563.   if input$found(.tbuff(1)) then do;
  564.     if (parse$fn.fcb$adr:=parse(.parse$fn)) <> 0FFFFh then
  565.       call finish$parse;
  566.   end;
  567.   else do;
  568.  
  569.     /* prompt for files */
  570.     call print$buf(.('Enter New Name: $'));
  571.     no$chars = read$console$buf(.tbuff(0),40);
  572.     if no$chars <= 0 then do;
  573.        call print$buf(.(cr,lf,'ERROR: Incorrect file specification.',cr,lf,'$'));
  574.        call mon1(0,0);
  575.        end;  /* no$char check */
  576.  
  577.     tbuff(1)= ' ';    /* blank out nc field for file 1 */
  578.     second$string$ptr = .tbuff(no$chars + 2);
  579.     call crlf;
  580.  
  581.     call print$buf(.('Enter Old Name: $'));
  582.     no$chars = read$console$buf(second$string$ptr,40);
  583.     call crlf;
  584.     ptr = ' ';    /* blank out mx field */
  585.     second$string$ptr = second$string$ptr + 1;
  586.     ptr = '=';    /* insert delimiter for parse */
  587.     second$string$ptr = second$string$ptr + no$chars + 1;     /* eoln */
  588.     ptr = cr;    /* put eoln delimeter in string */
  589.     parse$fn.buff$adr = .tbuff(1);
  590.     new$fcb$adr, parse$fn.fcb$adr = .fcb;
  591.     if (parse$fn.fcb$adr := parse(.parse$fn)) <> 0FFFFh then
  592.       call finish$parse;
  593.   end;
  594.   if parse$fn.fcb$adr = 0FFFFh then
  595.     call bad$entry;
  596.   if fcb(0) <> 0 then
  597.     if cur$fcb(0) <> 0 then do;
  598.       if fcb(0) <> cur$fcb(0) then
  599.         call bad$entry;
  600.       end;
  601.     else
  602.       cur$fcb(0) = new$fcb(0);    /* set drive */
  603.   if wildcard then
  604.     call singlefile;
  605.   else if rename(.cur$fcb) <> successful then 
  606.     call singlefile;
  607.   call mon1(0,0);
  608. end ren;
  609.