Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/VOLMOD.ZIP/LABEL.PAS

Pascal/Delphi Source File | 1989-07-11 | 7.7 KB | 272 lines

{
   Created using Turbo Pascal, Copywrite (c) Borland International
   1987, 1988.

   This is similar to the DOS 'LABEL' external command.  I modified code
   which was written for Turbo Pascal 3.0 which was written by
   David Kozinn (D.KOZINN on GEnie).  This code will delete volume
   labels, however, as well as modify and create them.  In order to
   accomplish the deletes FCBs must be used.  Although it is rumored DOS
   will soon cease to support FCBs, this program works with DOS 4.01
   running the SHARE.EXE command on my NORTHGATE 386-20Mhz PC without
   any problems.  If you enter paramters, the 1st 2 bytes must be
   the driver letter followed by a colon.

   WARNING: If you try to label a drive which doesn't exist, say Q: if
   you don't have a drive Q:, this program will attempt to label it
   anyway with unpredictable results. If you know of a way to determine
   the maximum drive letter/number please send me a note on GEnie and
   let me know.  John Gatewood Ham (J.HAM3 on GEnie)
}


PROGRAM vlabel(Input, Output);

USES DOS,CRT;

VAR
    i                 : integer;
    drivelet          : STRING[1];
    labl              : STRING[11];
    cmdline,
    whichdrive        : string[13];

  procedure Getlegal;
  begin
    writeln('Created using Turbo Pascal, Copywrite (c) Borland International 1987, 1988.');
  end;

  PROCEDURE volume(drive : Byte);
    TYPE
      extendfcb       = ARRAY[0..43] OF Char;
    VAR
      drivenam        : STRING[3];
      i               : Integer;
      reg             : registers;
      c               : string[1];
      haslabel        : Boolean;
      dta, xfcb, sfcb : extendfcb;

    {initialize an extended fcb}
    PROCEDURE initfcb(VAR x : extendfcb; namechar : Char);
      VAR
        i : Integer;
      BEGIN
        x[0] := Chr(255);     {flag for extended FCB}
        FOR i := 1 TO 5 DO
           x[i] := Chr(0);
        x[6] := Chr(8);       {specifies that we want volume label}
        x[7] := Chr(0);       {where drive number goes}
        FOR i := 8 TO 18 DO   {This is where the filename (in our }
           x[i] := namechar;  {case the volume label) goes        }
        FOR i := 19 TO 43 DO
           x[i] := Chr(0);
      END;

      { Get current drive number }
      FUNCTION Current_drive:byte;
        BEGIN
          { get current drive }
          reg.ah := $19;
          MsDos(reg);
          current_drive:=reg.al+1;
        END;

      { Set disk transfer address area to variable named DTA }
      { for use in directory search for the volume label.    }
      procedure set_dta;
      begin
        { set dta }
        with reg do
          begin
            ah := $1A;
            ds := Seg(dta[0]);
            dx := Ofs(dta[0]);
          end;
        MsDos(reg);
      end;

      { Search for label.  If found display else display    }
      { message that no label exists                        }
      procedure search_for_label;
      begin
        { find first using FCB method }
        with reg do
          begin
            ah := $11;
            dx := Ofs(sfcb[0]);
          end;
        MsDos(reg);
        { on error }
        IF (reg.al = $FF) THEN
            haslabel := False
        ELSE
            haslabel := True;
      end;

      { Display volume label  }
      procedure show_label;
      var i:integer;
      begin
        if haslabel then
          begin
            Write('Volume in drive ', whichdrive[1], ' is ');
            FOR i := 1 TO 11 DO
               Write(dta[7+i]);
            WriteLn;
          end
        else
           WriteLn('Volume in drive ', whichdrive[1], ' has no label');
      end;

      { Delete a volume label }
      PROCEDURE delete_file;
      BEGIN
        { delete a file specified by an unopened FCB }
        WITH reg DO
          begin
            ah := $13;
            ds := Seg(dta[0]);
            dx := Ofs(dta[0]);
          end;
        MsDos(reg);
        { if error }
        if (reg.al = $FF) then
          BEGIN
            WriteLn('Unable to delete volume label');
            halt;
          END;
      END;

      procedure rename_file;
      var i:integer;
      BEGIN
        {modify dta filename}
        FOR i := 1 TO 11 DO
          dta[23+i] := xfcb[7+i];
        { rename file using FCB method }
        with reg do
          begin
            ds := Seg(dta[0]);
            dx := Ofs(dta[0]);
            ah := $17;
          end;
        MsDos(reg);
        { if error }
        IF (reg.al = $FF) THEN
          begin
            WriteLn('Unable to change volume label');
            halt;
          end;
      END;

      procedure create_file;
      BEGIN
         {create a file using FCB method}
         with reg do
           begin
             ds := Seg(xfcb[0]);
             dx := Ofs(xfcb[0]);
             ah := $16;
           end;
         MsDos(reg);
         { if error }
         IF (reg.al = $FF) THEN
          begin
            WriteLn('Unable to create volume label');
            halt;
          end;
      END;

    BEGIN
      {initialize FCB buffers}
      initfcb(sfcb, '?');
      initfcb(xfcb, ' ');

      {if no drive letter entered used logged drive}
      IF drive = 0 THEN
        begin
          drive:=current_drive;
          whichdrive := chr(drive+64);
        end;

      {set drive in FCB buffers to drive selected}
      sfcb[7] := Chr(drive);
      xfcb[7] := Chr(drive);

      {set up disk transfer area for directory search, etc.}
      set_dta;
      {directory search using FCB method, directory bit set}
      search_for_label;
      show_label;

      {if they didn't enter a label name on command line get}
      {one now.                                             }
      if length(cmdline) < 3 then
        begin
          {display label (or message that there is no label) }
          Write('Enter new volume label:');
          ReadLn(labl);
        end;

      {if label is spaces}
      if (labl = '') then
        begin
          {if label is spaces and there was a volume label found}
          if haslabel then
            begin
              write('Delete current volume label (Y/N)?');
              repeat
                c:=readkey;
              until c[1] in ['y','n','Y','N'];
              writeln(c[1]);
              if c[1] in ['y','Y'] then
                  delete_file;
            end;
        end
      else {label is not spaces}
        BEGIN
          {insert label into xfcb}
          FOR i := 1 TO Length(labl) DO
             xfcb[7+i] := labl[i];
          { rename file (change label) }
          IF haslabel THEN
             rename_file
          ELSE { create file (make a new label) }
             create_file;
        END;
      {directory search using FCB method, directory bit set}
      search_for_label;
      {display label (or message that there is no label) }
      show_label;
    END;                      {volume}

begin
  getlegal;
  labl:='';
  if paramcount < 1 then
     volume(0)
  else
    begin
     cmdline:='';
     whichdrive:='';
     cmdline:=paramstr(1);
     if length(cmdline) < 2 then
       begin
         writeln('Invalid drive specification');
         halt;
       end;
     whichdrive:=copy(cmdline,1,2);
     if (whichdrive[2] <> ':') or
        (not (upcase(whichdrive[1]) in ['A'..'Z'])) then
        begin
          writeln('Invalid drive specification');
          halt;
        end;
     for i:=2 to paramcount do
       cmdline:=cmdline+' '+paramstr(i);
     labl:=copy(cmdline,3,11);
     whichdrive[1]:=upcase(whichdrive[1]);
     volume(ord(whichdrive[1])-64);
    end;
end.