home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
C!T ROM 2
/
ctrom_ii_b.zip
/
ctrom_ii_b
/
PROGRAM
/
PASCAL
/
TCSEL002
/
CHGE.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1992-10-16
|
14KB
|
336 lines
program chge;
{ Copyright 1990 Trevor J Carlsen Version 1.06 24-07-90 }
{ This program may be used and distributed as if it was in the Public Domain}
{ with the following exceptions: }
{ 1. If you alter it in any way, the copyright notice must not be }
{ changed. }
{ 2. If you use code excerpts in your own programs, due credit must be }
{ given, along with a copyright notice - }
{ "Parts Copyright 1990 Trevor J Carlsen" }
{ 3. No charge may be made for any program using code from this program.}
{ Changes (or deletes) a string in any file. If an .EXE or .COM file then }
{ the change must be of a similar length inorder to retain the executable }
{ integrity. }
{ If you find this program useful here is the author's contact address - }
{ Trevor J Carlsen }
{ PO Box 568 }
{ Port Hedland Western Australia 6721 }
{ Voice 61 [0]91 72 2026 }
{ Data 61 [0]91 72 2569 }
uses
tpstring, { from Turbo Power's Turbo Professional Toolbox }
dos;
const
space = #32;
quote = #34;
comma = #44;
copyright1 = 'CHGE - version 1.06 Copyright 1989,1990 Trevor Carlsen';
copyright2 = 'All rights reserved.';
var
dirinfo : SearchRec; { dos }
f : file;
FDir : DirStr; { dos }
mask,
fname,
oldstr,
newstr : string;
oldlen : byte absolute oldstr;
newlen : byte absolute newstr;
changes : word;
time : longint absolute $0000:$046C;
start : longint;
function ElapsedTime(start : longint): real;
begin
ElapsedTime := (time - start) / 18.2;
end; { ElapsedTime }
procedure ReportError(e : byte);
begin
writeln('CHGE [path]filename searchstr replacementstr|NUL');
writeln(' eg: CHGE c:\autoexec.bat "color" "colour"');
writeln(' CHGE c:\autoexec.bat 12 13,10,13,10,13,10,13,10');
writeln(' CHGE c:\wp\test.txt "Trevor" NUL');
writeln;
writeln('The first example will change every occurrence of the word "color" to "colour"');
writeln('The second will replace every formfeed character (ascii 12) with 4 sets of');
writeln('carriage return/linefeed combinations and the third will delete every');
writeln('occurrence of "Trevor"');
writeln('The prime requirements are:');
writeln(' There MUST always be exactly three space delimiters on the command line -');
writeln(' one between the program name and the filename, one between the filename and');
writeln(' the search string and another between the search string and the replacement');
writeln(' string. Any other spaces may ONLY occur between quote characters.');
writeln(' The program will not permit you to change the length of an .EXE or .COM file,');
writeln(' therefore the replacement string MUST be the same length as the string');
writeln(' that it is replacing in these cases.');
writeln;
writeln(' If using ascii codes, each ascii character must be separated from another');
writeln(' by a comma. The same rule applies to spaces as above - three required - no');
writeln(' more - no less. If just deleting the NUL must not be in quotes.');
halt(e);
end; { ReportError }
procedure ParseCommandLine;
var
parstr, { contains the command line }
temp : string;
len : byte absolute parstr; { the length byte for parstr }
tlen : byte absolute temp; { the length byte for temp }
CommaPos,
QuotePos,
SpacePos,
chval : byte;
error : integer;
DName : NameStr;
DExt : ExtStr;
function right(var s; n : byte): string;{ Returns the n right portion of s }
var
st : string absolute s;
len: byte absolute s;
begin
if n >= len then
right := st
else
right := copy(st,succ(len)-n,n);
end; { right }
begin
parstr := string(ptr(PrefixSeg,$80)^); { Get the command line }
if parstr[1] = space then
delete(parstr,1,1); { First character is usually a space }
SpacePos := pos(space,parstr);
if SpacePos = 0 then { No spaces }
ReportError(1);
mask := StUpCase(copy(parstr,1,pred(SpacePos)));
FSplit(mask,Fdir,DName,DExt); { To enable the directory to be kept }
delete(parstr,1,SpacePos);
QuotePos := pos(quote,parstr);
if QuotePos <> 0 then begin { quotes - so must be quoted text }
if parstr[1] <> quote then { so first char must be quote }
ReportError(2);
delete(parstr,1,1); { get rid of the first quote }
QuotePos := pos(quote,parstr); { and find the next quote }
if QuotePos = 0 then { no more - so it is an error }
ReportError(3);
oldstr := copy(parstr,1,pred(QuotePos));{ search string now defined }
if parstr[QuotePos+1] <> space then { must be space between }
ReportError(1);
delete(parstr,1,succ(QuotePos)); { the quotes - else error }
if parstr[1] <> quote then begin { may be a delete }
tlen := 3;
move(parstr[1],temp[1],3);
if temp <> 'NUL' then { is not a delete }
ReportError(4) { must be quote after space or NUL }
else
newlen := 0; { is a delete - so nul the replacement }
end
else begin
delete(parstr,1,1); { get rid of the quote }
QuotePos := pos(quote,parstr); { find next quote for end of string }
if QuotePos = 0 then { None? - then error }
ReportError(5);
newstr := copy(parstr,1,pred(QuotePos));{ Replacement string defined }
end;
end
else begin { must be using ascii codes }
oldlen := 0;
SpacePos := pos(space,parstr); { Find end of search characters }
if SpacePos = 0 then { No space - so error }
ReportError(6);
temp := copy(parstr,1,SpacePos-1);
delete(parstr,1,SpacePos); { get rid of the search characters }
CommaPos := pos(comma,temp); { find first comma }
if CommaPos = 0 then { No comma - so only one ascii code }
CommaPos := succ(tlen);
repeat { create the search string }
val(copy(temp,1,CommaPos-1),chval,error); { convert to a numeral and }
if error <> 0 then { if there is an error bomb out }
ReportError(7);
inc(oldlen);
oldstr[oldlen] := char(chval);{ add latest char to the search string }
delete(temp,1,CommaPos);
CommaPos := pos(comma,temp);
if CommaPos = 0 then
CommaPos := succ(tlen);
until tlen = 0;
newlen := 0;
CommaPos := pos(comma,parstr);
if CommaPos = 0 then
CommaPos := succ(len);
repeat { create the replacement string }
val(copy(parstr,1,pred(CommaPos)),chval,error);
if error <> 0 then { must be ascii code }
ReportError(8);
inc(newlen);
newstr[newlen] := char(chval);
delete(parstr,1,CommaPos);
CommaPos := pos(comma,parstr);
if CommaPos = 0 then CommaPos := len+1;
until len = 0;
end; { else }
if ((right(mask,3) = 'COM') or (right(mask,3) = 'EXE')) and
(newlen <> oldlen) then
ReportError(16);
end; { ParseCommandLine }
function OpenFile(fn : string): boolean;
begin
assign(f,fn);
{$I-} reset(f,1); {$I+}
OpenFile := IOResult = 0;
end; { OpenFile }
procedure CloseFile;
begin
{$I-}
truncate(f);
Close(f);
if IOResult <> 0 then; { dummy call to IOResult }
{$I+}
end; { CloseFile }
procedure ChangeFile(var chge : word);
const
bufflen = 65000; { This is the limit for BMSearch }
searchlen = bufflen - 1000; { Allow space for extra characters in }
type { the replacement string }
buffer = array[0..pred(bufflen)] of byte;
buffptr = ^buffer;
var
table : BTable; { Boyer-Moore search table }
old, { pointer to old buffer }
nu : buffptr; { pointer to new buffer }
count,
result,
oldpos,
newpos : word;
oldfpos,
newfpos : longint;
finished : boolean;
procedure AllocateMemory(var p; size : word);
var
buff : pointer absolute p;
begin
if MaxAvail >= size then
GetMem(buff,size)
else begin
writeln('Insufficient memory available.');
halt(10);
end;
end; { AllocateMemory }
begin
oldfpos := 0; newfpos := 0;
chge := 0;
AllocateMemory(old,searchlen);
AllocateMemory(nu,bufflen); { make room on the heap for the buffers }
BMMakeTable(oldstr,table); { Create a Boyer-Moore search table }
{$I-}
BlockRead(f,old^,searchlen,result); { Fill old buffer }
oldfpos := FilePos(f);
{$I+}
if IOResult <> 0 then begin
CloseFile; ReportError(11);
end;
repeat
oldpos := 0; newpos := 0; count := 0;
finished := (result < searchlen); { if buffer<>full then no more reads }
repeat { Do a BM search for search string }
count := BMSearch(old^[oldpos],result-oldpos,table,oldstr);
if count = $FFFF then begin { search string not found so copy rest }
move(old^[oldpos],nu^[newpos],result-oldpos); { of buffer to new }
inc(newpos,result-oldpos); { buffer and update the buffer markers }
inc(oldpos,result-oldpos);
end
else begin { search string found }
if count <> 0 then begin { not at position one in the buffer }
move(old^[oldpos],nu^[newpos],count);{ transfer everything prior }
inc(oldpos,count); { to the search string to new buffer }
inc(newpos,count); { and update the buffer markers }
end;
move(newstr[1],nu^[newpos],newlen); { copy the replacement string }
inc(oldpos,oldl { to the new buffer and update the buffer }
inc(newpos,newlen); { markers }
inc(chge);
end;
until oldpos >= result; { keep going until end of buffer }
if not finished then begin { Fill 'er up again for another round }
{$I-}
seek(f,oldfpos);
BlockRead(f,old^,searchlen,result);
oldfpos := FilePos(f);
{$I+}
if IOResult <> 0 then begin
CloseFile; ReportError(13);
end; { if IOResult }
end; { if not finished }
{$I-}
seek(f,newfpos);
BlockWrite(f,nu^,newpos); { write new buffer to file }
newfpos := FilePos(f);
{$I+}
if IOResult <> 0 then begin
CloseFile; ReportError(12);
end;
until finished;
FreeMem(old, searchlen); FreeMem(nu,bufflen);
end; { ChangeFiles }
procedure Find_and_change_all_files;
var
filefound : boolean;
function padstr(ch : char; len : byte): string;
var
temp : string;
begin
FillChar(temp[1],len,ch);
temp[0] := chr(len);
padstr := temp;
end; { padstr }
begin
filefound := false;
FindFirst(mask,AnyFile,dirinfo);
while DosError = 0 do begin
filefound := true;
start := time;
fname := FDir + dirinfo.name;
if OpenFile(fname) then begin
write(fname,PadStr(space,30-length(fname)),FileSize(f):7,' ');
ChangeFile(changes);
CloseFile;
if changes = 0 then
writeln
else
writeln('Made ',changes,' changes in ',ElapsedTime(start):4:2,' seconds.')
end
else
writeln('Unable to process ',fname);
FindNext(dirinfo);
end; { while DosError = 0 }
if not filefound then
writeln('No files found.');
end; { Find_and_change_all_files }
begin { main }
writeln(copyright1);
writeln(copyright2);
ParseCommandLine;
Find_and_change_all_files;
end.