home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / VL.ZIP / VL.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1988-02-28  |  8.2 KB  |  294 lines
  1. unit vl;
  2. {
  3.  A volume labeling unit for Turbo Pascal 4.0
  4.  Author places no restrictions on code usage and accepts no responsibility
  5.  for performance or problems arising from usage.
  6.  Version 01.00.00, 28-Feb-88, Stuart Johnson, CompuServe 71331,1716
  7.           ^  ^  ^
  8.           |  |  |
  9.           |  |  correction, zeroed after modification
  10.           |  modification, zeroed after rewrite to new base
  11.           Base version
  12.  
  13. Note: Some of the code in these routines is duplicated DELIBERATELY because
  14.       it sets up a xfcb for supsequent operations... these routines do not
  15.       call each other.
  16. }
  17.  
  18. interface
  19.  
  20. uses dos;
  21.  
  22. const vl_success = 0;
  23.       vl_disk    = 1;
  24.       vl_label   = 2;
  25.       vl_create  = 3;
  26.       vl_rename  = 4;
  27.       vl_delete  = 5;
  28.       vl_nolabel = 6;
  29.  
  30. type  label_type = array[1..11] of char;
  31.  
  32. type
  33.     xfcb = record            { not necessarily the definitive format for xfcb }
  34.      flag     : byte;
  35.      fill1    : array[1..5] of byte;
  36.      attr     : byte;
  37.      drive    : byte;
  38.      old_name : label_type;
  39.      fill2    : array[1..5] of byte;
  40.      new_name : label_type;
  41.      fill3    :    array[1..8] of char;
  42.     end;
  43.  
  44.  
  45.  
  46. {==============================================================}
  47. function put_volume_label(disk : byte; in_vlabel : string):byte;
  48. {
  49.  Procedure to add or change the volume label on a specified drive.
  50.  Many thanks to the author of LABEL.PAS, a Turbo 3 volume label program,
  51.  and to Borland for SEG and OFS, which made this easy..
  52.  
  53.  
  54.  Input : byte specifying disk drive. 1 = A, 2 = B...
  55.          string containing new label. Only uses left 11 characters, pads
  56.          with spaces if input less than 11.
  57.  
  58.  Output: vl_success = success
  59.          vl_disk    = invalid drive number
  60.          vl_label   = invalid volume label
  61.          vl_create  = create failure
  62.          vl_rename  = rename failure
  63.  
  64.  
  65.  Notes:
  66.         vl_disk, invalid drive number is asserted if drive < 1 or > 26.
  67.  
  68.         vl_label, invalid volume label can be caused by a blank or non-left
  69.         justified label. Volume labels, like filenames, cannot begin with
  70.         spaces.
  71.  
  72.         An error reading the disk in the wildcard search will cause error
  73.         vl_create to be returned because the code assumes wildcard lookup
  74.         failures are ALL due to the file (volume label) not being found.
  75.         If the disk is write protected, the file creation will also fail,
  76.         causing error vl_create.
  77.  
  78.         An error vl_rename, renaming the volume, is almost certainly due the
  79.         the disk being write-protected.
  80. }
  81.  
  82.  
  83.  
  84. {==============================================}
  85. function delete_volume_label(disk : byte): byte;
  86. {
  87.  Function to delete a volume label.
  88.  
  89.  Input:   drive number 1..26
  90.  Output:  vl_success = success
  91.           vl_delete  = delete failed
  92.           vl_nolabel = could not delete.. no label on volume
  93.  
  94. Notes:    vl_delete may be caused by
  95.           1) volume label read-only
  96.           2) disk write protected
  97.  
  98.           vl_nolabel may be caused by
  99.           1) no label on disk
  100.           2) no disk in drive
  101. }
  102.  
  103.  
  104.  
  105. {=============================================================}
  106. function get_volume_label(disk : byte; var str : string): byte;
  107. {
  108.  Function to get a volume label
  109.  
  110.  Input:   drive number 1..26
  111.  Output:  vl_success = success
  112.           vl_nolabel  = no label
  113.  
  114. Notes:    vl_nolabel may be caused by
  115.           1) no volume label on disk
  116.           2) no disk in drive
  117. }
  118.  
  119.  
  120.  
  121. implementation
  122.  
  123.  
  124.  
  125. {==============================================================}
  126. function put_volume_label(disk : byte; in_vlabel : string):byte;
  127.  
  128.  
  129. var  xfcb1,                  { for file lookup }
  130.      xfcb2    : xfcb;        { dummy returned by file lookup }
  131.      regs     : registers;
  132.      new_label : label_type;
  133.      vlabel    : string[11]; { input may not be large enough to pad to 11 }
  134.  
  135.  
  136. begin
  137.  put_volume_label := vl_success;      { assume success }
  138.  
  139.  if (disk < 1) or (disk > 26) then
  140.  begin
  141.   put_volume_label := vl_disk;
  142.   exit;
  143.  end;
  144.  
  145.  vlabel := in_vlabel;
  146.  while length(vlabel) < 11 do vlabel := vlabel + ' '; { pad to 11 }
  147.  move(vlabel[1],new_label,11);
  148.  if new_label[1] = ' ' then  { cannot be blank! }
  149.  begin
  150.   put_volume_label := vl_label;
  151.   exit;
  152.  end;
  153.  
  154.  with xfcb1 do
  155.  begin
  156.   flag := $ff;               { fcb type is extended }
  157.   attr := $8;                { attribute = volume label }
  158.   fillchar(fill1,5,0);
  159.   drive := disk;
  160.   fillchar(old_name,11,'?');
  161.   fillchar(new_name,11,0);
  162.   fillchar(fill2,4,0);
  163.   fillchar(fill3,9,0);
  164.  end;
  165.  
  166.  with regs do
  167.  begin
  168.  
  169.   ds := seg(xfcb2);          { xfcb2 will recieve a psuedo xfcb from dos }
  170.   dx := ofs(xfcb2);          { containing info from wildcard dir lookup }
  171.   ax := $1A shl 8;           { ah = $1A, al = 0 }
  172.   msdos(regs);               { set disk transfer area }
  173.  
  174.   ds := seg(xfcb1);          { point to xfcb specifying files to look for }
  175.   dx := ofs(xfcb1);
  176.   ax := $11 shl 8;           { ah = $11, al = 0 }
  177.   msdos(regs);               { search for first }
  178.  
  179.   if al = $ff then           { no label found, create volume label }
  180.   begin
  181.    xfcb1.old_name := new_label;
  182.    ds := seg(xfcb1);         { point to xfcb specifying file to create }
  183.    dx := ofs(xfcb1);
  184.    ax := $16 shl 8;          { ah = $16, al = 0 }
  185.    msdos(regs);              { create file }
  186.    if al = $ff then put_volume_label := vl_create;
  187.   end
  188.   else                       { has a label, rename it }
  189.   begin
  190.    xfcb2.new_name := new_label;
  191.    ds := seg(xfcb2);         { point at xfcb recieved during wildcard lookup }
  192.    dx := ofs(xfcb2);
  193.    ax := $17 shl 8;          { ah = $17, al = 0 }
  194.    msdos(regs);              { rename file }
  195.    if al = $ff then put_volume_label := vl_rename;
  196.   end;
  197.  end;
  198. end;
  199.  
  200.  
  201.  
  202. {=============================================}
  203. function delete_volume_label(disk : byte):byte;
  204.  
  205. var  xfcb1,
  206.      xfcb2 : xfcb;
  207.      regs  : registers;
  208.  
  209. begin
  210.  delete_volume_label := vl_success;
  211.  with xfcb1 do
  212.  begin
  213.   flag := $ff;               { fcb type is extended }
  214.   attr := $8;                { attribute = volume label }
  215.   fillchar(fill1,5,0);
  216.   drive := disk;
  217.   fillchar(old_name,11,'?');
  218.   fillchar(new_name,11,0);
  219.   fillchar(fill2,4,0);
  220.   fillchar(fill3,9,0);
  221.  end;
  222.  
  223.  with regs do
  224.  begin
  225.  
  226.   ds := seg(xfcb2);          { xfcb2 will recieve a psuedo xfcb from dos }
  227.   dx := ofs(xfcb2);          { containing info from wildcard dir lookup }
  228.   ax := $1A shl 8;           { ah = $1A, al = 0 }
  229.   msdos(regs);               { set disk transfer area }
  230.  
  231.   ds := seg(xfcb1);          { point to xfcb specifying files to look for }
  232.   dx := ofs(xfcb1);
  233.   ax := $11 shl 8;           { ah = $11, al = 0 }
  234.   msdos(regs);               { search for first }
  235.   if al = $ff then
  236.   begin
  237.    delete_volume_label := vl_nolabel;
  238.    exit;
  239.   end
  240.   else
  241.   begin
  242.    ds := seg(xfcb1);         { point to xfcb specifying file to delete }
  243.    dx := ofs(xfcb1);
  244.    ax := $13 shl 8;          { ah = $13, al = 0 }
  245.    msdos(regs);              { delete file }
  246.    if al = $ff then delete_volume_label := vl_delete;
  247.   end;
  248.  end;
  249. end;
  250.  
  251.  
  252.  
  253. {==================================================}
  254. function get_volume_label(disk : byte; var str : string);
  255.  
  256. var  xfcb1,
  257.      xfcb2 : xfcb;
  258.      regs  : registers;
  259.  
  260. begin
  261.  with xfcb1 do
  262.  begin
  263.   flag := $ff;               { fcb type is extended }
  264.   attr := $8;                { attribute = volume label }
  265.   fillchar(fill1,5,0);
  266.   drive := disk;
  267.   fillchar(old_name,11,'?');
  268.   fillchar(new_name,11,0);
  269.   fillchar(fill2,4,0);
  270.   fillchar(fill3,9,0);
  271.  end;
  272.  
  273.  with regs do
  274.  begin
  275.  
  276.   ds := seg(xfcb2);          { xfcb2 will recieve a psuedo xfcb from dos }
  277.   dx := ofs(xfcb2);          { containing info from wildcard dir lookup }
  278.   ax := $1A shl 8;           { ah = $1A, al = 0 }
  279.   msdos(regs);               { set disk transfer area }
  280.  
  281.   ds := seg(xfcb1);          { point to xfcb specifying files to look for }
  282.   dx := ofs(xfcb1);
  283.   ax := $11 shl 8;           { ah = $11, al = 0 }
  284.   msdos(regs);               { search for first }
  285.   if al = $ff then get_volume_label := vl_nolabel
  286.   else
  287.   begin
  288.    get_volume_label := vl_success;
  289.    str := xfcb2.old_name;
  290.   end;
  291.  end;
  292. end;
  293.  
  294. end. { unit }