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
Wrap
Pascal/Delphi Source File
|
1989-06-10
|
10KB
|
439 lines
{ =========================================================================== }
{ CUVL.pas - Volume label Utility ver 1.0, 06-89 }
{ (c) 1989 Micro System Solutions Fred C. Hill }
{ =========================================================================== }
{$A+ align on word boundry}
{$B- short circuit boolean evaluation}
{$E+ coprocessor emulation on}
{$F- force far calls off}
{$I- disable io checking}
{$N- do real-type calcs in software}
{$O- disable overlay code generation}
{$R- disable range checking}
{$S- disable stack overflow checking}
{$V- disable variable checking}
{$M 51200,16384,512000 }
program CUVL;
uses
DOS,
TPDOS,
TPCRT,
TPString, TPCmd, TPWindow,
TPEdit;
const
blackBG = $00;
blueBG = $10;
greenBG = $20;
cyanBG = $30;
redBG = $40;
magentaBG = $50;
brownBG = $60;
LightgrayBG = $70;
{====================================================================}
const
Wmain = red+LightGrayBG;
Bmain = red+LightGrayBG;
Hmain = red+LightGrayBG;
Pmain = red+lightgrayBG;
type
dta_type = record
flag: byte;
reserved: array [1..5] of byte;
mask: byte;
drive: byte;
name: array [1..8] of char;
ext: array [1..3] of char;
attr: byte;
filler: array[12..21] of byte;
time: integer;
date: integer;
cluster: integer;
size: longint;
end;
fcb_type = record
flag: byte;
reserved: array [1..5] of byte;
mask: byte;
drive: byte;
name: array [1..8] of char;
ext: array [1..3] of char;
current_block: integer;
record_size: integer;
size: longint;
date: integer;
filler: array[22..31] of byte;
record_no: byte;
file_no: longint;
end;
namstr = string[12];
mem_ptr = ^pointer_type;
pointer_type = longint;
var
reg: registers;
SR: searchrec;
pointer,
dta: dta_type;
fcb: fcb_type;
dta_area: array [1..130] of byte;
dirinfo: SearchRec;
f: text; {used for output redirection}
Ch,
_CatDsk: char;
ndiskettes,
nhards,
_RelDisk,
code,
startseq,
countsize: integer;
Labelling,
parameters,
DasMLablDone,
Funckey: Boolean;
volume,
cfname,
temp: namstr;
instring,
prefix: string;
newvolumelabel,
volumelabel: string[11];
MainWndw: windowptr;
{============================================================}
{------[ key routines ]------------------------------------------------}
PROCEDURE waitkey;
begin
ch := readkey;
if ch <> #0 then FuncKey := false
else begin
Funckey := True;
ch := readkey;
end;
end;
procedure errormem;
begin
writeln('unable to allocate window space');
end;
PROCEDURE anykey;
const
Wattr = black+LightGrayBG;
Fattr = black+LightGrayBG;
Hattr = black+LightGrayBG;
Pattr = black+lightgrayBG;
var
any: windowptr;
begin
if not makewindow(Any, 45,screenheight-3, 73, screenheight,
true,true,false,Wattr,Fattr,Hattr,'') then errormem;
if not displaywindow(Any) then errormem;
ReadCharacter('Press any key to continue',46,screenheight-2,
Pattr,[#0..#255],ch);
any := erasetopwindow;
disposewindow(any);
end;
procedure GetParams;
const
wattr = black+lightgrayBG;
var
i: word;
instartseq,
incountsize : string;
begin
_CatDsk := 'A';
_RelDisk := ord(_CatDsk) - 64;
volumelabel := '';
instring := '';
for i := 1 to paramcount do
instring := instring + paramstr(i);
if paramcount > 0 then begin
parameters := true;
if pos(',', instring) > 0 then
prefix := copy(instring, 1, pos(',', instring) - 1)
else
prefix := instring;
if pos(',', instring) > 0 then
delete(instring, 1, pos(',', instring))
else
instring := '';
if pos(',', instring) > 0 then
instartseq := copy(instring, 1, pos(',', instring) - 1)
else
instartseq := instring;
val(instartseq, startseq, code);
if pos(',', instring) > 0 then
delete(instring, 1, pos(',', instring))
else
instring := '';
if instring = '' then
str(length(instartseq), incountsize)
else
incountsize := instring;
val(incountsize, countsize, code);
end;
volumelabel := '';
str(startseq:countsize, volumelabel);
while pos(' ', volumelabel) > 0 do
volumelabel[pos(' ', volumelabel)] := '0';
volumelabel := prefix + volumelabel;
if length(volumelabel) > 11 then begin
fastwrite( 'Constructed volume label is more than 11 characters',12, 21,Wattr);
DasmLablDone := true;
fastwrite('first label will be "'+volumelabel+'"',12, 22,Wattr);
anykey;
end;
end;
function min(x, y: integer): integer;
begin
if x < y then min := x
else min := y;
end;
procedure do_dir;
const
wrqst = black+blueBG;
Brqst = black+blueBG;
Hrqst = black+blueBG;
Prqst = black+blueBG;
Srqst = black+blueBG;
Crqst = black+blueBG;
var
mask: string[11];
filerqst: windowptr;
Escaped: boolean;
begin
Mask := '';
if not MakeWindow(filerqst, 40,8,65,11,true,true,false,
WRqst, BRqst, HRqst,
'Enter a filename mask: ') then errormem;
if not DisplayWindow(filerqst) then begin
disposewindow(erasetopwindow);
exit;
end;
windowrelative := true;
editsize := 11;
readstring('', 2, 1, 79, PRqst, SRqst, CRqst, Escaped, Mask);
editsize := 0;
disposewindow(erasetopwindow);
if Escaped then exit;
end;
{===========================================================================}
(*
Function checkdrive(drivenum: Byte): Boolean;
{-see if a drive has a disk mounted and is ready to read}
Var
cf: Byte;
begin
reg.dx := drivenum; {drive drivenum, head 0}
reg.cx := 1; {track 0, sector 1}
reg.ax := $401; {verify mode, 1 sector}
Intr($13, reg);
cf := reg.flags And 1;
{reset the drive}
reg.ax := 0;
Intr($13, reg);
if keypressed then waitkey;
if ch in [Esc, ^X] then checkdrive := false
else checkdrive := (cf = 0);
end; {checkdrive}
*)
{===========================================================================}
procedure dlt_label;
var
i: integer;
begin
reg.AH := $13; {delete hte old name}
reg.DS := seg(dta);
reg.DX := ofs(dta);
MSDos(reg);
end;
{------[ get_vol ]------------------------------------------------------}
procedure getnewlabel;
const
Up : boolean=True; {upcase}
filechars: charset=[#32..#127];
term : charset=[#27,#13,#9];
var
TC : char;
x : integer;
fil: namstr;
var
i : integer;
temps: string;
const
wrqst = black+blueBG;
Brqst = black+blueBG;
Hrqst = black+blueBG;
Prqst = black+blueBG;
Srqst = black+blueBG;
Crqst = black+blueBG;
var
mask: string[11];
filerqst: windowptr;
Escaped: boolean;
begin {getnewlabel}
fil := '';
if parameters then
fil := volumelabel;
volumelabel := '';
SetDta(@dta);
fcb.flag := $FF;
for i := 1 to 5 do fcb.reserved[i] := 0;
fcb.mask := $08;
fcb.drive := byte(Upcase(_CatDsk))-$40;
fcb.name := '????????';
fcb.ext := '???';
reg.ah := $11;
reg.DS := seg(fcb);
reg.DX := ofs(fcb);
MSDos(Reg);
ch := #0;
if (reg.AL = 0) then begin {found a label}
volumelabel := copy(dta.name+' ', 1, 8)+copy(dta.ext+' ', 1, 3);
writeln('The volume is currently "',volumelabel,'"');
writeln('Do you want to change it? (Y/N)');
while not (ch in [#27,^X, 'Y', 'y', 'N', 'n']) do
waitkey;
if ch in [#27, ^X] then begin
DasmLablDone := true;
exit;
end;
if ch in ['N', 'n'] then exit;
dlt_label;
end;
fcb.flag := $FF; {extended fcb}
for i := 1 to 5 do fcb.reserved[i] := 0;
fcb.mask := $08;
fcb.drive := byte(_CatDsk)-$40;
fcb.name := ' ';
fcb.ext := ' ';
move(newvolumelabel[1], fcb.name,min(length(newvolumelabel),11));
reg.ds := seg(fcb);
reg.dx := ofs(fcb);
reg.ax := $1600;
msdos(reg);
reg.AX := $1000; {close file}
msdos(reg);
end; {getnewlabel}
Procedure GetALabel;
const
wrqst = white+blueBG;
Brqst = white+blueBG;
Hrqst = white+blueBG;
Prqst = white+blueBG;
Srqst = white+blueBG;
Crqst = white+blueBG;
var
mask: string[11];
filerqst: windowptr;
Escaped: boolean;
var
diskrqst: windowptr;
begin
if not MakeWindow(diskrqst, 40,8,66,10,true,true,false,
WRqst, BRqst, HRqst,
'') then errormem;
if not DisplayWindow(diskrqst) then begin
disposewindow(erasetopwindow);
exit;
end;
windowrelative := true;
editsize := 11;
readcharacter('Place a disk in drive '+_CatDsk+':', 1, 1,
PRqst, [#0..#255], ch);
editsize := 0;
disposewindow(erasetopwindow);
if ch = #27 then begin
DasmLablDone := true;
exit;
end;
cfname := _CatDsk+':*.*';
if parameters then begin
str(startseq:countsize, newvolumelabel);
while pos(' ', newvolumelabel) > 0 do
newvolumelabel[pos(' ', newvolumelabel)] := '0';
newvolumelabel := prefix + newvolumelabel;
inc(startseq, 1);
end;
getnewlabel;
if keypressed then waitkey;
if ch in [#27, ^X] then
DasmLablDone := true;
if DasmLablDone then exit;
volume := copy(volumelabel+' ',1,11);
if volume = ' ' then begin
writeln('No volume label..');
end else begin
writeln('volume label is ', volume,'.... label will be "'+newvolumelabel+'"');
end;
end;
{===========================================================================}
begin
clrscr;
Labelling := false;
DasmLablDone := false;
parameters := false;
GetParams; { get input parameters }
if not parameters then halt;
if not MakeWindow(mainwndw, 2,1,screenwidth,screenheight,
true,true,false,WMain, BMain, HMain,'') then errormem;
if not DisplayWindow(MainWndw) then begin
disposewindow(erasetopwindow);
exit;
end;
fastwrite(center('Colorado Utilities Volume Labeller - copyright 1989 Micro System Solutions',80),
1,1,$0E);
windowrelative := true;
if not DasmLablDone then begin
Labelling := true;
Repeat
GetALabel;
until DasmLabldone;
end;
writeln(' Operation Complete - Thank you');
disposewindow(erasetopwindow);
end.
{==================================================================}