home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / TURBOPAS / MISC.ZIP / LABEL.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1985-03-01  |  7.8 KB  |  245 lines
  1. PROGRAM vlabel(Input, Output);
  2.     {display, add or modify volume labels}
  3.  
  4.   CONST
  5.     toklen = 63;              {max length of a token}
  6.     maxtok = 10;              {max number of tokens on command line}
  7.   TYPE
  8.     token = STRING[toklen];
  9.     argarray = ARRAY[1..maxtok] OF token;
  10.     message = STRING[79];
  11.   VAR
  12.     argc : Integer;           {argument count (number of tokens)}
  13.     argv : argarray;          {elements are the tokens found on the command line}
  14.     errmess : message;        {error message, if any, returned from getcom}
  15.     i : Integer;
  16.     drive : Byte;
  17.     drivelet : STRING[1];
  18.     labl : STRING[11];
  19.     inter, gotlabel : Boolean;
  20.  
  21.   FUNCTION getcom(VAR errstring : message) : Boolean;
  22.       {parse command line passed from DOS to Turbo Pascal}
  23.       {return false if error encountered}
  24.       {errstring will contain a text error message if getcom is false}
  25.     CONST
  26.       delim : SET OF Char = [' ', ^I];
  27.       comm = $80;             {offset of command tail in program segment prefix}
  28.     VAR
  29.       bufpos : Byte;          {position in command line buffer}
  30.       tokpos : Byte;          {position in current token}
  31.       nchars : Byte;          {one more than the characters in the command tail}
  32.       c : Char;
  33.       m1, m2 : message;
  34.  
  35.     FUNCTION comchar : Char;
  36.         {return the command character at current buffer position}
  37.       BEGIN
  38.         comchar := Chr(Mem[CSeg : (comm+bufpos)]);
  39.         bufpos := bufpos+1;
  40.       END;                    {comchar}
  41.  
  42.     BEGIN                     {getcom}
  43.       getcom := True;
  44.       bufpos := 0;
  45.       nchars := 1+Ord(comchar); {define buffer stopping point}
  46.       argc := 0;
  47.       IF nchars > 1 THEN BEGIN
  48.         c := comchar;
  49.         WHILE (c IN delim) DO c := comchar; {skip leading blanks}
  50.         WHILE bufpos <= nchars DO BEGIN
  51.           IF argc < maxtok THEN BEGIN {get the next argument}
  52.             argc := argc+1;
  53.             tokpos := 0;
  54.             WHILE ((bufpos <= nchars) AND (NOT(c IN delim))) DO BEGIN
  55.               IF tokpos < toklen THEN BEGIN {read the argument}
  56.                 tokpos := tokpos+1;
  57.                 argv[argc][tokpos] := c;
  58.                 c := comchar;
  59.               END ELSE BEGIN  {set error and skip the rest}
  60.                 getcom := False;
  61.                 Str(argc, m1);
  62.                 Str(toklen, m2);
  63.                 errstring := 'ERROR: argument# '+m1+' truncated to '+m2+' characters';
  64.                 WHILE (NOT(c IN delim)) DO c := comchar;
  65.               END;
  66.             END;
  67.             argv[argc][0] := Chr(tokpos); {store the arg length}
  68.             WHILE (c IN delim) DO c := comchar; {skip blanks}
  69.           END ELSE BEGIN
  70.             getcom := False;
  71.             Str(maxtok, m1);
  72.             errstring := 'ERROR: number of arguments truncated to '+m1;
  73.             bufpos := nchars+1;
  74.           END;
  75.         END;
  76.       END;
  77.     END;                      {getcom}
  78.  
  79.   PROCEDURE volume(drive : Byte);
  80.       {DOS calls to access volume labels}
  81.     TYPE
  82.       regpack = RECORD
  83.                   ax, bx, cx, dx, bp, si, di, ds, es, flags : Integer;
  84.                 END;
  85.       extendfcb = ARRAY[0..43] OF Char;
  86.     VAR
  87.  
  88.       drivenam : STRING[3];
  89.       i : Integer;
  90.       reg : regpack;
  91.       c : Char;
  92.       haslabel : Boolean;
  93.       dta, xfcb, sfcb : extendfcb;
  94.  
  95.     PROCEDURE initfcb(VAR x : extendfcb; namechar : Char);
  96.         {initialize an extended fcb}
  97.       VAR
  98.         i : Integer;
  99.       BEGIN
  100.         x[0] := Chr(255);     {flag for extended FCB}
  101.         FOR i := 1 TO 5 DO x[i] := Chr(0);
  102.         x[6] := Chr(8);       {specifies that we want volume label}
  103.         x[7] := Chr(0);       {where drive number goes}
  104.         FOR i := 8 TO 18 DO x[i] := namechar;
  105.         FOR i := 19 TO 43 DO x[i] := Chr(0);
  106.       END;                    {initfcb}
  107.  
  108.     BEGIN
  109.       initfcb(sfcb, '?');     {initialize buffers}
  110.       initfcb(xfcb, ' ');
  111.  
  112.       IF drive = 0 THEN BEGIN {GET DRIVE NUMBER}
  113.         reg.ax := $19 SHL 8;
  114.         MsDos(reg);
  115.         Mem[Seg(drive) : Ofs(drive)] := Lo(reg.ax)+1;
  116.       END;
  117.       sfcb[7] := Chr(drive);
  118.       xfcb[7] := Chr(drive);
  119.       CASE drive OF
  120.         1 : drivenam := 'A: ';
  121.         2 : drivenam := 'B: ';
  122.         3 : drivenam := 'C: ';
  123.         4 : drivenam := 'D: ';
  124.         5 : drivenam := 'E: ';
  125.         6 : drivenam := 'F: ';
  126.         7 : drivenam := 'G: ';
  127.         8 : drivenam := 'H: ';
  128.       END;
  129.  
  130.       reg.ax := $1a SHL 8; reg.ds := Seg(dta[0]); reg.dx := Ofs(dta[0]);
  131.       MsDos(reg);             {SET UP DISK TRANSFER AREA FOR FILENAMES}
  132.  
  133.  
  134.       reg.dx := Ofs(sfcb[0]); reg.ax := $11 SHL 8;
  135.       MsDos(reg);             {search for volume entry}
  136.  
  137.       IF Lo(reg.ax) = $FF THEN BEGIN
  138.         haslabel := False;
  139.         IF NOT(gotlabel) THEN
  140.           WriteLn('volume in drive ', drivenam, ' has no label')
  141.       END ELSE BEGIN
  142.         haslabel := True;
  143.         IF NOT(gotlabel) THEN BEGIN
  144.           Write('volume in drive ', drivenam, ' is ');
  145.           FOR i := 1 TO 11 DO Write(dta[7+i]);
  146.           WriteLn;
  147.         END;
  148.       END;
  149.  
  150.       {go on to change the label}
  151.       IF inter THEN BEGIN
  152.         Write('enter new volume label (<cr> for no change): ');
  153.         ReadLn(labl);
  154.       END;
  155.       IF Length(labl) > 0 THEN BEGIN
  156.         FOR i := 1 TO Length(labl) DO xfcb[7+i] := labl[i]; {insert label into xfcb}
  157.         IF haslabel THEN BEGIN
  158.           FOR i := 1 TO 11 DO dta[23+i] := xfcb[7+i]; {modify dta}
  159.           reg.ds := Seg(dta[0]); reg.dx := Ofs(dta[0]); reg.ax := $17 SHL 8;
  160.           MsDos(reg);
  161.         END ELSE BEGIN
  162.           reg.ds := Seg(xfcb[0]); reg.dx := Ofs(xfcb[0]); reg.ax := $16 SHL 8;
  163.           MsDos(reg);
  164.         END;
  165.         IF Lo(reg.ax) = $FF THEN
  166.           WriteLn('error in modifying label')
  167.         ELSE BEGIN
  168.           Write('new volume label in drive ', drivenam, ' is ');
  169.           FOR i := 1 TO 11 DO BEGIN
  170.             c := xfcb[7+i];
  171.             Write(UpCase(c));
  172.           END;
  173.           WriteLn;
  174.         END;
  175.       END;
  176.     END;                      {volume}
  177.  
  178.   BEGIN
  179.     writeln;
  180.     IF getcom(errmess) THEN BEGIN
  181.       gotlabel := False;
  182.       drive := 0; labl:='';
  183.       IF argc > 0 THEN BEGIN
  184.         inter:=false;
  185.         i := 1;
  186.         WHILE i <= argc DO BEGIN
  187.           IF (Length(argv[i]) = 2) AND (argv[i][2] = ':') THEN BEGIN
  188.             {a drive letter}
  189.             drivelet := argv[i];
  190.             CASE UpCase(drivelet[1]) OF
  191.               'A' : drive := 1;
  192.               'B' : drive := 2;
  193.               'C' : drive := 3;
  194.               'D' : drive := 4;
  195.               'E' : drive := 5;
  196.               'F' : drive := 6;
  197.               'G' : drive := 7;
  198.               'H' : drive := 8;
  199.             ELSE
  200.               WriteLn('unknown drive designator');
  201.               Halt;
  202.             END;
  203.           END ELSE BEGIN
  204.             {a new volume label}
  205.             gotlabel := True;
  206.             labl := argv[i];
  207.           END;
  208.           i := i+1;
  209.         END;
  210.         volume(drive);
  211.       END ELSE BEGIN
  212.         inter:=true;
  213.         WHILE True DO BEGIN
  214.           WriteLn;
  215.           Write('enter drive (<cr> for default, Q to quit): ');
  216.           drivelet := '';
  217.           ReadLn(drivelet);
  218.           IF UpCase(drivelet[1]) = 'Q' THEN Halt;
  219.           IF Length(drivelet) = 0 THEN
  220.             drive := 0
  221.           ELSE BEGIN
  222.             CASE UpCase(drivelet[1]) OF
  223.               'A' : drive := 1;
  224.               'B' : drive := 2;
  225.               'C' : drive := 3;
  226.               'D' : drive := 4;
  227.               'E' : drive := 5;
  228.               'F' : drive := 6;
  229.               'G' : drive := 7;
  230.               'H' : drive := 8;
  231.             ELSE
  232.               WriteLn('unknown drive designator');
  233.               Halt;
  234.             END;
  235.           END;
  236.           volume(drive);
  237.         END;
  238.       END;
  239.     END ELSE BEGIN
  240.       WriteLn(errmess);
  241.     END;
  242.   END.
  243.  
  244.  
  245.