home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-387-Vol-3of3.iso / c / civil-ab.zip / CUVL10.ZIP / CUVL.PAS < prev   
Pascal/Delphi Source File  |  1989-06-10  |  10KB  |  439 lines
  1. { =========================================================================== }
  2. { CUVL.pas - Volume label Utility                           ver 1.0,    06-89 }
  3. { (c) 1989 Micro System Solutions  Fred C. Hill                               }
  4. { =========================================================================== }
  5. {$A+ align on word boundry}
  6. {$B- short circuit boolean evaluation}
  7. {$E+ coprocessor emulation on}
  8. {$F- force far calls off}
  9. {$I- disable io checking}
  10. {$N- do real-type calcs in software}
  11. {$O- disable overlay code generation}
  12. {$R- disable range checking}
  13. {$S- disable stack overflow checking}
  14. {$V- disable variable checking}
  15.  
  16.  
  17. {$M 51200,16384,512000 }
  18.  
  19. program CUVL;
  20.  
  21. uses
  22.     DOS,
  23.   TPDOS,
  24.   TPCRT,
  25.   TPString, TPCmd, TPWindow,
  26.   TPEdit;
  27.  
  28. const
  29.     blackBG     = $00;
  30.     blueBG        = $10;
  31.     greenBG        = $20;
  32.     cyanBG        = $30;
  33.     redBG        = $40;
  34.     magentaBG    = $50;
  35.     brownBG        = $60;
  36.     LightgrayBG    = $70;
  37.  
  38. {====================================================================}
  39. const
  40.     Wmain = red+LightGrayBG;
  41.     Bmain = red+LightGrayBG;
  42.     Hmain = red+LightGrayBG;
  43.     Pmain = red+lightgrayBG;
  44.  
  45. type
  46.     dta_type    = record
  47.         flag:        byte;
  48.         reserved:    array [1..5] of byte;
  49.         mask:        byte;
  50.         drive:        byte;
  51.         name:        array [1..8] of char;
  52.         ext:        array [1..3] of char;
  53.         attr:        byte;
  54.         filler:        array[12..21] of byte;
  55.         time:        integer;
  56.         date:        integer;
  57.         cluster:    integer;
  58.         size:        longint;
  59.     end;
  60.  
  61.     fcb_type    = record
  62.         flag:        byte;
  63.         reserved:    array [1..5] of byte;
  64.         mask:        byte;
  65.         drive:        byte;
  66.         name:        array [1..8] of char;
  67.         ext:        array [1..3] of char;
  68.         current_block:    integer;
  69.         record_size:    integer;
  70.         size:        longint;
  71.         date:        integer;
  72.         filler:        array[22..31] of byte;
  73.         record_no:    byte;
  74.         file_no:    longint;
  75.     end;
  76.  
  77.     namstr            =    string[12];
  78.     mem_ptr            = ^pointer_type;
  79.     pointer_type    = longint;
  80.  
  81. var
  82.     reg:        registers;
  83.  
  84.     SR:            searchrec;
  85.  
  86.       pointer,
  87.     dta:        dta_type;
  88.     fcb:        fcb_type;
  89.     dta_area:    array [1..130] of byte;
  90.  
  91.     dirinfo:    SearchRec;
  92.  
  93.     f:            text;         {used for output redirection}
  94.  
  95.     Ch,
  96.     _CatDsk:    char;
  97.  
  98.     ndiskettes,
  99.     nhards,
  100.     _RelDisk,
  101.     code,
  102.     startseq,
  103.     countsize:    integer;
  104.  
  105.     Labelling,
  106.     parameters,
  107.     DasMLablDone,
  108.     Funckey:    Boolean;
  109.  
  110.     volume,
  111.     cfname,
  112.     temp:        namstr;
  113.  
  114.     instring,
  115.     prefix:        string;
  116.     newvolumelabel,
  117.     volumelabel:    string[11];
  118.  
  119.     MainWndw:    windowptr;
  120. {============================================================}
  121.  
  122. {------[ key  routines ]------------------------------------------------}
  123.  
  124. PROCEDURE waitkey;
  125. begin
  126.     ch := readkey;
  127.     if ch <> #0 then FuncKey := false
  128.     else begin
  129.        Funckey := True;
  130.        ch := readkey;
  131.     end;
  132. end;
  133.  
  134. procedure errormem;
  135. begin
  136.     writeln('unable to allocate window space');
  137. end;
  138.  
  139. PROCEDURE anykey;
  140. const
  141.     Wattr = black+LightGrayBG;
  142.     Fattr = black+LightGrayBG;
  143.     Hattr = black+LightGrayBG;
  144.     Pattr = black+lightgrayBG;
  145. var
  146.     any:    windowptr;
  147. begin
  148.     if not makewindow(Any, 45,screenheight-3, 73, screenheight,
  149.                 true,true,false,Wattr,Fattr,Hattr,'') then errormem;
  150.     if not displaywindow(Any) then errormem;
  151.     ReadCharacter('Press any key to continue',46,screenheight-2,
  152.                 Pattr,[#0..#255],ch);
  153.     any := erasetopwindow;
  154.     disposewindow(any);
  155. end;
  156.  
  157. procedure GetParams;
  158. const
  159.     wattr = black+lightgrayBG;
  160.  
  161. var
  162.     i: word;
  163.     instartseq,
  164.     incountsize    :    string;
  165. begin
  166.     _CatDsk := 'A';
  167.     _RelDisk := ord(_CatDsk) - 64;
  168.     volumelabel := '';
  169.     instring := '';
  170.     for i := 1 to paramcount do
  171.         instring := instring + paramstr(i);
  172.     if paramcount > 0 then begin
  173.         parameters := true;
  174.         if pos(',', instring) > 0 then
  175.             prefix := copy(instring, 1, pos(',', instring) - 1)
  176.         else
  177.             prefix := instring;
  178.         if pos(',', instring) > 0 then
  179.             delete(instring, 1, pos(',', instring))
  180.         else
  181.             instring := '';
  182.         if pos(',', instring) > 0 then
  183.             instartseq := copy(instring, 1, pos(',', instring) - 1)
  184.         else
  185.             instartseq := instring;
  186.         val(instartseq, startseq, code);
  187.         if pos(',', instring) > 0 then
  188.             delete(instring, 1, pos(',', instring))
  189.         else
  190.             instring := '';
  191.         if instring = '' then
  192.             str(length(instartseq), incountsize)
  193.         else
  194.             incountsize := instring;
  195.         val(incountsize, countsize, code);
  196.     end;
  197.     volumelabel := '';
  198.     str(startseq:countsize, volumelabel);
  199.     while pos(' ', volumelabel) > 0 do
  200.         volumelabel[pos(' ', volumelabel)] := '0';
  201.     volumelabel := prefix + volumelabel;
  202.     if length(volumelabel) > 11 then begin
  203.         fastwrite( 'Constructed volume label is more than 11 characters',12, 21,Wattr);
  204.         DasmLablDone := true;
  205.         fastwrite('first label will be "'+volumelabel+'"',12, 22,Wattr);
  206.         anykey;
  207.     end;
  208. end;
  209.  
  210. function min(x, y: integer): integer;
  211. begin
  212.     if x < y then min := x
  213.     else min := y;
  214. end;
  215.  
  216.  
  217. procedure do_dir;
  218. const
  219.     wrqst = black+blueBG;
  220.     Brqst = black+blueBG;
  221.     Hrqst = black+blueBG;
  222.     Prqst = black+blueBG;
  223.     Srqst = black+blueBG;
  224.     Crqst = black+blueBG;
  225. var
  226.     mask:    string[11];
  227.     filerqst:    windowptr;
  228.     Escaped:    boolean;
  229. begin
  230.     Mask := '';
  231.     if not MakeWindow(filerqst, 40,8,65,11,true,true,false,
  232.         WRqst, BRqst, HRqst,
  233.         'Enter a filename mask: ') then errormem;
  234.     if not DisplayWindow(filerqst) then begin
  235.         disposewindow(erasetopwindow);
  236.         exit;
  237.     end;
  238.     windowrelative := true;
  239.     editsize := 11;
  240.     readstring('', 2, 1, 79, PRqst, SRqst, CRqst, Escaped, Mask);
  241.     editsize := 0;
  242.     disposewindow(erasetopwindow);
  243.     if Escaped then exit;
  244. end;
  245.  
  246.  
  247.  
  248. {===========================================================================}
  249. (*
  250.  
  251. Function checkdrive(drivenum: Byte): Boolean;
  252.   {-see if a drive has a disk mounted and is ready to read}
  253. Var
  254.     cf: Byte;
  255. begin
  256.     reg.dx := drivenum;           {drive drivenum, head 0}
  257.     reg.cx := 1;                       {track 0, sector 1}
  258.     reg.ax := $401;                {verify mode, 1 sector}
  259.     Intr($13, reg);
  260.     cf := reg.flags And 1;
  261.     {reset the drive}
  262.     reg.ax := 0;
  263.     Intr($13, reg);
  264.     if keypressed then waitkey;
  265.     if ch in [Esc, ^X] then checkdrive := false
  266.     else checkdrive := (cf = 0);
  267. end;                                              {checkdrive}
  268. *)
  269.  
  270. {===========================================================================}
  271.  
  272. procedure dlt_label;
  273. var
  274.     i: integer;
  275. begin
  276.     reg.AH := $13;            {delete hte old name}
  277.     reg.DS := seg(dta);
  278.     reg.DX := ofs(dta);
  279.     MSDos(reg);
  280. end;
  281.  
  282. {------[ get_vol ]------------------------------------------------------}
  283.  
  284. procedure getnewlabel;
  285.  
  286. const
  287.       Up       : boolean=True;    {upcase}
  288.       filechars: charset=[#32..#127];
  289.     term     : charset=[#27,#13,#9];
  290. var
  291.       TC        : char;
  292.       x        : integer;
  293.     fil: namstr;
  294.  
  295. var
  296.     i    : integer;
  297.     temps: string;
  298. const
  299.     wrqst = black+blueBG;
  300.     Brqst = black+blueBG;
  301.     Hrqst = black+blueBG;
  302.     Prqst = black+blueBG;
  303.     Srqst = black+blueBG;
  304.     Crqst = black+blueBG;
  305. var
  306.     mask:    string[11];
  307.     filerqst:    windowptr;
  308.     Escaped:    boolean;
  309.  
  310. begin   {getnewlabel}
  311.     fil := '';
  312.     if parameters then
  313.         fil := volumelabel;
  314.     volumelabel := '';
  315.     SetDta(@dta);
  316.     fcb.flag := $FF;
  317.     for i := 1 to 5 do fcb.reserved[i] := 0;
  318.     fcb.mask := $08;
  319.     fcb.drive := byte(Upcase(_CatDsk))-$40;
  320.     fcb.name := '????????';
  321.     fcb.ext := '???';
  322.     reg.ah := $11;
  323.     reg.DS := seg(fcb);
  324.     reg.DX := ofs(fcb);
  325.     MSDos(Reg);
  326.     ch := #0;
  327.     if (reg.AL = 0)    then begin    {found a label}
  328.         volumelabel := copy(dta.name+'        ', 1, 8)+copy(dta.ext+'   ', 1, 3);
  329.         writeln('The volume is currently "',volumelabel,'"');
  330.         writeln('Do you want to change it? (Y/N)');
  331.         while not (ch in [#27,^X, 'Y', 'y', 'N', 'n']) do
  332.             waitkey;
  333.         if ch in [#27, ^X] then begin
  334.             DasmLablDone := true;
  335.             exit;
  336.         end;
  337.         if ch in ['N', 'n'] then exit;
  338.         dlt_label;
  339.     end;
  340.     fcb.flag := $FF;            {extended fcb}
  341.     for i := 1 to 5 do fcb.reserved[i] := 0;
  342.     fcb.mask := $08;
  343.     fcb.drive := byte(_CatDsk)-$40;
  344.     fcb.name := '        ';
  345.     fcb.ext := '   ';
  346.     move(newvolumelabel[1], fcb.name,min(length(newvolumelabel),11));
  347.     reg.ds := seg(fcb);
  348.     reg.dx := ofs(fcb);
  349.     reg.ax := $1600;
  350.     msdos(reg);
  351.     reg.AX := $1000;        {close file}
  352.     msdos(reg);
  353. end; {getnewlabel}
  354.  
  355. Procedure GetALabel;
  356. const
  357.     wrqst = white+blueBG;
  358.     Brqst = white+blueBG;
  359.     Hrqst = white+blueBG;
  360.     Prqst = white+blueBG;
  361.     Srqst = white+blueBG;
  362.     Crqst = white+blueBG;
  363. var
  364.     mask:    string[11];
  365.     filerqst:    windowptr;
  366.     Escaped:    boolean;
  367.  
  368. var
  369.     diskrqst:    windowptr;
  370. begin
  371.     if not MakeWindow(diskrqst, 40,8,66,10,true,true,false,
  372.             WRqst, BRqst, HRqst,
  373.             '') then errormem;
  374.     if not DisplayWindow(diskrqst) then begin
  375.         disposewindow(erasetopwindow);
  376.         exit;
  377.     end;
  378.     windowrelative := true;
  379.     editsize := 11;
  380.     readcharacter('Place a disk in drive '+_CatDsk+':', 1, 1,
  381.         PRqst, [#0..#255], ch);
  382.     editsize := 0;
  383.     disposewindow(erasetopwindow);
  384.     if ch = #27 then begin
  385.         DasmLablDone := true;
  386.         exit;
  387.     end;
  388.       cfname := _CatDsk+':*.*';
  389.     if parameters then begin
  390.         str(startseq:countsize, newvolumelabel);
  391.         while pos(' ', newvolumelabel) > 0 do
  392.             newvolumelabel[pos(' ', newvolumelabel)] := '0';
  393.         newvolumelabel := prefix + newvolumelabel;
  394.         inc(startseq, 1);
  395.     end;
  396.     getnewlabel;
  397.     if keypressed then waitkey;
  398.     if ch in [#27, ^X] then
  399.         DasmLablDone := true;
  400.     if DasmLablDone then exit;
  401.     volume := copy(volumelabel+'           ',1,11);
  402.     if volume = '           ' then begin
  403.        writeln('No volume label..');
  404.     end else begin
  405.         writeln('volume label is ', volume,'.... label will be "'+newvolumelabel+'"');
  406.     end;
  407. end;
  408.  
  409.  
  410. {===========================================================================}
  411.  
  412. begin
  413.     clrscr;
  414.     Labelling := false;
  415.     DasmLablDone := false;
  416.     parameters := false;
  417.     GetParams;                     { get input parameters }
  418.     if not parameters then halt;
  419.     if not MakeWindow(mainwndw, 2,1,screenwidth,screenheight,
  420.             true,true,false,WMain, BMain, HMain,'') then errormem;
  421.     if not DisplayWindow(MainWndw) then begin
  422.         disposewindow(erasetopwindow);
  423.         exit;
  424.     end;
  425.     fastwrite(center('Colorado Utilities Volume Labeller - copyright 1989 Micro System Solutions',80),
  426.                 1,1,$0E);
  427.     windowrelative := true;
  428.     if not DasmLablDone then begin
  429.         Labelling := true;
  430.         Repeat
  431.             GetALabel;
  432.         until DasmLabldone;
  433.     end;
  434.     writeln('        Operation Complete - Thank you');
  435.     disposewindow(erasetopwindow);
  436. end.
  437.  
  438. {==================================================================}
  439.