home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Current Shareware 1994 January
/
SHAR194.ISO
/
modem
/
sortd211.zip
/
SORTADDR.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1993-10-10
|
14KB
|
425 lines
{
SortAddr
Version 2.12
An address book sort utility for OzCIS V2
Richard Linter [70624,414] August 1993
Further modification to allow for addresses automatically entered from
the from line of Internet message (delimited with $3B not $B3)
}
program sortAddr;
uses dos;
type
PEntry = ^address;
address = record
address_string: string;
next: PEntry;
End;
var
{File handling variables}
filename: string;
f: text ;
{Pointers to start_of_list, current_record, previous_record and new_record}
PList_start,
PCurrent,
PPrev,
PNew: PEntry;
file_line: string;
{Dos unit variables..}
path: pathStr;
dir: dirStr;
name: nameStr;
ext: extStr;
{Sort routine variable}
fSortKey,
mSortKey: string;
{====================================================================
Strings are temporarily converted to upper case before comparion by
the sort routine so that the sort is case independant }
function upperCaseStr(s: string) : string;
var
I,J : integer ;
begin
J := ord(S[0]) ;
for I := 1 to J do
s[I] := upCase(s[i]) ;
upperCaseStr := s ;
end;
{=====================================================================
Return the last word from a string (ie. from last delimiter to end of
the string) }
function lastWord(s: string) : string;
var
wordStart,
fieldEnd: byte;
field: string;
begin
fieldEnd := length(s);
while s[fieldEnd] = ' ' do dec(fieldEnd); { Strip off trailing spaces}
{ If the last word in the string is the ONLY word (ie. it is not preceded
by a space the repeat loop below will be endless - the ' ' below ensures
that the loop will always find a space and will therefore always terminate! }
field := ' '+copy(s,1,fieldEnd);
if field = '' then
LastWord := ''
else
begin
{ Find first delimiter back from end of field }
wordStart := length(field);
repeat dec(WordStart) until (field[wordStart] = ' ') or (field[wordStart] = '.');
{ The start of last word follows the delimitor found}
inc(wordStart);
lastWord := copy(field,wordStart,fieldEnd);
end
end;
{===================================================================
Gets the name field of the address book record. This field is from
start of the record string to first delimitor (#179 or ';') }
function GetName(s: string) : String;
var
p : byte;
begin
p := pos(#179,s);
if p = 0 then p := pos(';',s);
if p = 0 then
begin
writeln(#10,#13,#10,#13,#7,'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!');
writeln('SortAddr Error:',#10,#13);
writeln('Failed sorting record for: ',#10,#13,s);
write('Cannot parse record into fields i.e. delimitors (│ or ;) were not found !',#10,#13);
writeln(#10,#13,'If this is a program error please report it to Richard Linter [70624,414]');
writeln('!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!',#7);
halt;
end;
GetName := copy(s,1,p-1);
end;
{===================================================================
Look for a number in the last word third comment field
- it returns 0 if one is not found (Genuine input of 0 is trapped) }
function noFromComment3(s: string) : byte;
var
fieldStart,
fieldEnd: byte;
lword: string;
no: Longint;
code: Integer;
begin
{ Find 1st delimitor back from end of the record = start of third comment field)}
fieldEnd := length(s);
while s[fieldEnd] = #32 do dec(fieldEnd); { Strip off trailing spaces}
if (s[fieldEnd] = #179) or (s[fieldEnd] = ';') then
{ The field is empty }
noFromComment3 := 0
else
begin
fieldStart := fieldEnd;
repeat dec(fieldStart) until ((s[fieldStart] = #179) or (s[fieldStart] = ';'));
inc(fieldStart);
lword := lastword(copy(s,fieldStart,fieldEnd-fieldStart+1));
val(lword,no,code);
{ Trap out of range sort keys }
if (code = 0) and ((no = 0) or (no < 0) or (no >255)) then
begin
writeln(#10,#13,#10,#13,#7,'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!');
writeln('SortAddr Error:',#10,#13);
writeln('Failed sorting record for: ',GetName(s));
{ Zero input... }
if no = 0 then writeln('The 3rd comment field entry requires sort on word number 0 !');
{ Negative input... }
if no < 0 then writeln('The 3rd comment entry requires sort on negative word number (',no,')!');
{ Number too large (ie > 255) for the byte that its going into - the }
{ name field after all only 40 characters long! }
{ (This trap is in case someone has a phone number in comment3) }
if no > 255 then writeln('The 3rd comment entry requires sort on word number ',no,'!');
writeln(#10,#13,'If there is a program error please report it to Richard Linter [70624,414]');
writeln('!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!',#7);
halt;
end;
{Now that zero input is trapped can use 0 as flag for no number found}
if code <> 0 then
{the word is '' or not numeric}
noFromComment3 := 0
else
noFromComment3 := no;
end;
end;
{=====================================================================
Passed the name field (not the whole record), this makes a temporary copy
of the string with the nth word attached to the front of it thus ensuring
that the name is sorted on this field first
}
function customSortKey( s: string; n: byte) : string;
var
sStart,sEnd,
i,Numwords: byte;
begin
sStart := 1;
{ Strip off leading spaces}
while s[sStart] = #32 do inc(sStart);
s := copy(s,sStart,255);
i := length(s);
{ Strip off trailing spaces}
while s[i] = ' ' do dec(i);
s := copy(s,1,i);
{ Counts words by finding spaces or dots,
this line ensures last word is found }
s := s + ' ';
numWords := 0;
I := 1;
repeat
if (s[i] = ' ') or (s[i] = '.') then
begin
{ Beware of multiple delimitors between words!}
while (s[i] = ' ') or (s[i] = '.') do inc(i);
{ Beware of multiple spaces between words (or space following '.') !}
while s[i] = ' ' do inc(i);
inc(numWords);
end;
inc(i);
until i > length(s);
{ Remove that trailing space just added - its done its job }
s := copy(s,1,length(s)-1);
{ Last trap for out of range sort key }
{"Too few" words in string...}
if n > numWords then
begin
writeln(#10,#13,#10,#13,#7,'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!');
writeln('SortAddr Error:',#10,#13);
writeln('Failed sorting record for: ',s);
write('The 3rd comment field entry requires sort on word number ',n);
if n > numWords then
writeln(#10,#13,'SortAddr finds only ',numWords,' words in the name field!')
else writeln(' !');
writeln(#10,#13,'If there is a program error please report it to Richard Linter [70624,414]');
writeln('!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!',#7);
halt;
end;
{ The nth word is preceded by the (n-1)th delimitor
- find the start of nth word..}
if n = 1 then
sStart := 1
else
begin
sStart := 1;
for i := 1 to n-1 do
begin
while (s[sStart] <> ' ') and (s[sStart] <> '.') do inc(sStart);
{ Beware of multiple delimitors between words!}
while (s[sStart] = ' ') or (s[sStart] = '.') do inc(sStart);
end;
end;
{ Find the end of this word..}
sEnd := sStart;
while (s[sEnd] <> ' ') and (s[sEnd] <> '.') do inc(sEnd);
dec(sEnd);
customSortKey := copy(s,sStart,sEnd-sStart+1) + ' '+ S
end;
{=====================================================================
If the third comment field contains a number as the last word in that
field it indicates the number of the word in the name filed to sort on.
Otherwise - sort on the last word of the name field }
function getSortKey(s: string) : string;
var
lWord,
str,
name: string;
no : integer;
begin
str := upperCaseStr(s);
name := GetName(str);
no := NoFromComment3(str);
if no = 0 then
begin
lword := LastWord(name);
getSortKey := lWord + ' ' + copy(name,1,length(name)-length(lWord)-1);
end
else
getSortKey := customSortKey(name, no);
end;
{=====================================================================}
procedure help;
begin
writeln;
writeln('SortAddr V2.1 - Address book sorter for OzCIS V2.');
writeln('=================================================');
writeln('■ This utility sorts OzCIS V2 address book files into alpha order.');
writeln('■ Its "normal" sort is on the last word of the name. But since this can');
writeln(' give unhelpful results with organisation''s names or an unusually formatted');
writeln(' names - John Doe [TeamOz] etc. - an alternative sort key can be forced.');
writeln(' This is done by putting the number of the word to be sorted into the 3rd');
writeln(' comment field as the last word - in the case above adding 2 as the last word');
writeln(' acheives the desired result (assuming you want this entry filed under D).');
writeln(' For ''standard'' names (those it is useful to sort on the last word) no edit');
writeln(' of this comment field is required.');
writeln('■ An optional, parameter may be passed, giving the name of the address-book to');
writeln(' sorted. If no parameter is passed the OzCIS default book (ADDRBOOK.ADR in ');
writeln(' the OZCIS root directory) is assumed. If you keep ADDRBOOK.ADR in another');
writeln(' directory a parameter giving the both name and path must be passed.');
writeln(' Obviously, if your address book is called something else this parameter');
writeln(' be needed to pass this filename and, if necessary the path.');
writeln('■ The old, unsorted, address book is backed-up first so that data is');
writeln(' retreivable if something unexpected happens during sorting or file-saving');
writeln(' operations.');
writeln;
writeln('Thanks are due to Todd Fiske (TeamOz) for the sort customisation idea.');
writeln;
writeln('Richard Linter [70624,414], Aug 1993');
halt;
end;
{===========================================================================}
begin
{ /? as parameter requests help}
if paramStr(1) = '/?' then help;
if paramcount > 1 then
begin
writeln(#7,#10,#13,'SortAddr V2.1: ERROR -> Too many parameters passed.',#10,#13);
writeln('A single (optional) parameter is required - this gives the filename');
writeln('of the address-book to sort. (If this parameter is not used the OzCIS');
writeln('defaults - addrbook.adr in the OzCIS root directory - is assumed).',#10,#13);
halt;
end;
if paramCount = 1 then
filename := paramStr(1)
else
filename := 'ADDRBOOK.ADR';
{$i-}
assign(F, filename); { Open input file }
reset(F);
{$i+}
if IOResult <> 0 then
begin
writeln(#10,#13,'SortAddr V2.1: ERROR -> The file (',Filename, ') was not found.');
writeln('Run ''SORTADDR'' with parameter ''/?'' for help, if needed.',#10,#13);
halt;
end;
writeln(#10,#13,'SortAddr V2.1 - OzCIS V2 address book sort. Richard Linter [70624,414] 1993',#10,#13);
write (' Sorting file ',filename,': ');
{ THE DATA IS READ, ITEM BY ITEM, FROM THE FILE AND PUT, IN ALPHA ORDER,
INTO A LINKED-LIST IN MEMORY}
PList_Start := Nil;
PPrev := Nil;
{ Read first record..}
ReadLN(f,file_line);
{ Place it at start of linked-list with NEXT pointer indicating EOF}
New(PNew);
PList_Start := PNew;
PNew^.Address_string := File_line;
PNew^.Next := nil;
write('>');
{ Process rest of file}
repeat
ReadLN(F,File_line);
PCurrent := PList_Start;
fSortKey := getSortKey(File_line);
mSortKey := getSortKey(PCurrent^.address_string);
repeat
PPrev := PCurrent;
if fSortKey > mSortKey then
begin
PCurrent := PCurrent^.Next;
if PCurrent <> nil then mSortKey := getSortKey(PCurrent^.address_string);
end
until (PCurrent= nil) or (fSortKey <= mSortKey);
{ Position file_line in correct position in linked list..}
if PCurrent = nil then
{ the new entry goes at the end of the list }
begin
new(PNew);
PNew^.Address_string := File_line;
PNew^.Next := nil;
PPrev^.Next := PNew;
end
else
{ insert the new entry in the list }
begin
new(PNew);
PNew^.address_string := File_line;
PNew^.next := PCurrent;
if PCurrent = PList_Start then
{the item has been inserted at the start of the list}
PList_Start := PNew
else
{the item has been inserted at the body of the list}
PPrev^.next := PNew;
end;
write('>');
until eof(F);
writeln;
close(f);
{Get the filename and extension (in case the filename was passed as a
parameter)}
FSplit(FExpand(Filename), Dir, Name, Ext);
{$i-}
assign(F,dir+Name+'.BAK');
erase(F);
{$i+}
{For security reasons rename address book before writing sorted version }
if IOresult = 2 then {No problem, there was'nt an existing .BAK file};
assign(F,dir+name+ext);
rename(F,dir+name+'.bak');
{Save the sorted address book }
assign(F,dir+name+ext);
rewrite(F);
PCurrent := PList_Start;
repeat
writeln(F,PCurrent^.address_string);
PCurrent := PCurrent^.next;
until PCurrent^.next = nil;
writeln(F,PCurrent^.address_string);
close(F);
writeln(' Saving the now sorted file as ',dir+name+ext);
writeln(' The unsorted file was renamed ',dir+name+'.BAK',#10,#13);
reset(F);
{Dispose of dynamic variables}
PCurrent := PList_Start;
repeat
PPrev := PCurrent;
dispose(PCurrent);
PCurrent := PPrev^.Next;
until (PCurrent= nil) ;
end.