home *** CD-ROM | disk | FTP | other *** search
/ Current Shareware 1994 January / SHAR194.ISO / modem / sortd211.zip / SORTADDR.PAS < prev    next >
Pascal/Delphi Source File  |  1993-10-10  |  14KB  |  425 lines
  1. {
  2.   SortAddr
  3.   Version 2.12
  4.  
  5.   An address book sort utility for OzCIS V2
  6.   Richard Linter [70624,414] August 1993
  7.  
  8.   Further modification to allow for addresses automatically entered from
  9.   the from line of Internet message (delimited with $3B not $B3)
  10. }
  11.  
  12.  
  13. program sortAddr;
  14.  
  15. uses dos;
  16.  
  17. type
  18.   PEntry  =  ^address;
  19.   address = record
  20.               address_string:  string;
  21.               next:            PEntry;
  22.             End;
  23.  
  24. var
  25.   {File handling variables}
  26.   filename:           string;
  27.   f:                  text ;
  28.   {Pointers to start_of_list, current_record, previous_record and new_record}
  29.   PList_start,
  30.   PCurrent,
  31.   PPrev,
  32.   PNew:               PEntry;
  33.   file_line:          string;
  34.   {Dos unit variables..}
  35.   path:               pathStr;
  36.   dir:                dirStr;
  37.   name:               nameStr;
  38.   ext:                extStr;
  39.   {Sort routine variable}
  40.   fSortKey,
  41.   mSortKey:           string;
  42.  
  43. {====================================================================
  44.  Strings are temporarily converted to upper case before comparion by
  45.  the sort routine so that the sort is case independant }
  46.  
  47. function upperCaseStr(s: string) : string;
  48. var
  49.   I,J  : integer ;
  50. begin
  51.   J := ord(S[0]) ;
  52.   for I := 1 to J do
  53.     s[I] := upCase(s[i]) ;
  54.   upperCaseStr := s ;
  55. end;
  56.  
  57. {=====================================================================
  58.  Return the last word from a string (ie. from last delimiter to end of
  59.  the string) }
  60.  
  61. function lastWord(s: string) : string;
  62. var
  63.   wordStart,
  64.   fieldEnd:  byte;
  65.   field: string;
  66. begin
  67.  fieldEnd := length(s);
  68.  while s[fieldEnd] = ' ' do dec(fieldEnd); { Strip off trailing spaces}
  69.  { If the last word in the string is the ONLY word (ie. it is not preceded
  70.    by a space the repeat loop below will be endless - the ' ' below ensures
  71.    that the loop will always find a space and will therefore always terminate! }
  72.  field := ' '+copy(s,1,fieldEnd);
  73.  if field = '' then
  74.   LastWord := ''
  75.  else
  76.  begin
  77.   { Find first delimiter back from end of field }
  78.   wordStart := length(field);
  79.   repeat dec(WordStart) until (field[wordStart] = ' ') or (field[wordStart] = '.');
  80.   { The start of last word follows the delimitor found}
  81.   inc(wordStart);
  82.   lastWord := copy(field,wordStart,fieldEnd);
  83.  end
  84. end;
  85.  
  86. {===================================================================
  87.  Gets the name field of the address book record. This field is from
  88.  start of the record string to first delimitor (#179 or ';') }
  89.  
  90. function GetName(s: string) : String;
  91. var
  92.  p : byte;
  93.  
  94. begin
  95.    p := pos(#179,s);
  96.    if p = 0 then p := pos(';',s);
  97.    if p = 0 then
  98.    begin
  99.     writeln(#10,#13,#10,#13,#7,'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!');
  100.     writeln('SortAddr Error:',#10,#13);
  101.     writeln('Failed sorting record for: ',#10,#13,s);
  102.     write('Cannot parse record into fields i.e. delimitors (│ or ;) were not found !',#10,#13);
  103.     writeln(#10,#13,'If this is a program error please report it to Richard Linter [70624,414]');
  104.     writeln('!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!',#7);
  105.     halt;
  106.   end;
  107.  
  108.    GetName :=  copy(s,1,p-1);
  109. end;
  110.  
  111. {===================================================================
  112.  Look for a number in the last word third comment field
  113.  - it returns 0 if one is not found (Genuine input of 0 is trapped) }
  114.  
  115. function noFromComment3(s: string) : byte;
  116. var
  117.   fieldStart,
  118.   fieldEnd:     byte;
  119.   lword:        string;
  120.   no:           Longint;
  121.   code:         Integer;
  122. begin
  123.  { Find 1st delimitor back from end of the record = start of third comment field)}
  124.  fieldEnd := length(s);
  125.  while s[fieldEnd] = #32 do dec(fieldEnd); { Strip off trailing spaces}
  126.  if (s[fieldEnd] = #179) or (s[fieldEnd] = ';')  then
  127.    { The field is empty }
  128.    noFromComment3 := 0
  129.  else
  130.  begin
  131.    fieldStart := fieldEnd;
  132.    repeat dec(fieldStart) until ((s[fieldStart] = #179) or (s[fieldStart] = ';'));
  133.    inc(fieldStart);
  134.    lword := lastword(copy(s,fieldStart,fieldEnd-fieldStart+1));
  135.    val(lword,no,code);
  136.    { Trap out of range sort keys }
  137.    if (code = 0) and ((no = 0) or (no < 0) or (no >255)) then
  138.    begin
  139.      writeln(#10,#13,#10,#13,#7,'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!');
  140.      writeln('SortAddr Error:',#10,#13);
  141.      writeln('Failed sorting record for: ',GetName(s));
  142.     { Zero input... }
  143.     if no = 0 then writeln('The 3rd comment field entry requires sort on word number 0 !');
  144.     { Negative input... }
  145.     if no < 0 then writeln('The 3rd comment entry requires sort on negative word number (',no,')!');
  146.     { Number too large (ie > 255) for the byte that its going into - the }
  147.     { name field after all only 40 characters long!                      }
  148.     { (This trap is in case someone has a phone number in comment3)      }
  149.     if no > 255 then writeln('The 3rd comment entry requires sort on word number ',no,'!');
  150.  
  151.     writeln(#10,#13,'If there is a program error please report it to Richard Linter [70624,414]');
  152.     writeln('!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!',#7);
  153.     halt;
  154.    end;
  155.  
  156.    {Now that zero input is trapped can use 0 as flag for no number found}
  157.    if code <> 0 then
  158.      {the word is '' or not numeric}
  159.      noFromComment3 := 0
  160.    else
  161.      noFromComment3 := no;
  162.  end;
  163. end;
  164.  
  165. {=====================================================================
  166.  Passed the name field (not the whole record), this makes a temporary copy
  167.  of the string with the nth word attached to the front of it thus ensuring
  168.  that the name is sorted on this field first
  169.  }
  170.  
  171. function customSortKey( s: string; n: byte) : string;
  172. var
  173.  sStart,sEnd,
  174.  i,Numwords:        byte;
  175. begin
  176.   sStart := 1;
  177.   { Strip off leading spaces}
  178.   while s[sStart] = #32 do inc(sStart);
  179.   s := copy(s,sStart,255);
  180.  
  181.   i := length(s);
  182.   { Strip off trailing spaces}
  183.   while s[i] = ' ' do dec(i);
  184.   s := copy(s,1,i);
  185.  
  186.   { Counts words by finding spaces or dots,
  187.     this line ensures last word is found }
  188.   s := s + ' ';
  189.   numWords := 0;
  190.   I := 1;
  191.   repeat
  192.     if (s[i] = ' ') or (s[i] = '.') then
  193.     begin
  194.       { Beware of multiple delimitors between words!}
  195.       while (s[i] = ' ') or (s[i] = '.') do inc(i);
  196.  
  197.       { Beware of multiple spaces between words (or space following '.') !}
  198.       while s[i] = ' ' do inc(i);
  199.       inc(numWords);
  200.     end;
  201.     inc(i);
  202.   until i > length(s);
  203.   { Remove that trailing space just added - its done its job }
  204.    s := copy(s,1,length(s)-1);
  205.  
  206.   { Last trap for out of range sort key }
  207.   {"Too few" words in string...}
  208.   if n > numWords then
  209.   begin
  210.     writeln(#10,#13,#10,#13,#7,'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!');
  211.     writeln('SortAddr Error:',#10,#13);
  212.     writeln('Failed sorting record for: ',s);
  213.     write('The 3rd comment field entry requires sort on word number ',n);
  214.     if n > numWords then
  215.       writeln(#10,#13,'SortAddr finds only ',numWords,' words in the name field!')
  216.     else writeln(' !');
  217.     writeln(#10,#13,'If there is a program error please report it to Richard Linter [70624,414]');
  218.     writeln('!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!',#7);
  219.     halt;
  220.   end;
  221.  
  222.    { The nth word is preceded by the (n-1)th delimitor
  223.      - find the start of nth word..}
  224.    if n = 1 then
  225.      sStart := 1
  226.    else
  227.    begin
  228.      sStart := 1;
  229.      for i := 1 to n-1 do
  230.      begin
  231.       while (s[sStart] <> ' ') and (s[sStart] <> '.')  do inc(sStart);
  232.       { Beware of multiple delimitors between words!}
  233.       while (s[sStart] = ' ') or (s[sStart] = '.') do inc(sStart);
  234.      end;
  235.    end;
  236.    { Find the end of this word..}
  237.    sEnd := sStart;
  238.    while (s[sEnd] <> ' ') and (s[sEnd] <> '.') do inc(sEnd);
  239.    dec(sEnd);
  240.    customSortKey := copy(s,sStart,sEnd-sStart+1) + ' '+ S
  241. end;
  242.  
  243. {=====================================================================
  244. If the third comment field contains a number as the last word in that
  245. field it indicates the number of the word in the name filed to sort on.
  246. Otherwise - sort on the last word of the name field }
  247.  
  248. function getSortKey(s: string) : string;
  249. var
  250.  lWord,
  251.  str,
  252.  name: string;
  253.  no  : integer;
  254. begin
  255.   str    := upperCaseStr(s);
  256.   name   := GetName(str);
  257.   no     := NoFromComment3(str);
  258.   if no = 0 then
  259.   begin
  260.     lword := LastWord(name);
  261.     getSortKey := lWord + ' ' +  copy(name,1,length(name)-length(lWord)-1);
  262.   end
  263.   else
  264.     getSortKey := customSortKey(name, no);
  265. end;
  266.  
  267. {=====================================================================}
  268.  
  269. procedure help;
  270. begin
  271.   writeln;
  272.   writeln('SortAddr V2.1 - Address book sorter for OzCIS V2.');
  273.   writeln('=================================================');
  274.   writeln('■  This utility sorts OzCIS V2 address book files into alpha order.');
  275.   writeln('■  Its "normal" sort is on the last word of the name. But since this can');
  276.   writeln('   give unhelpful results with organisation''s names or an unusually formatted');
  277.   writeln('   names - John Doe [TeamOz] etc. - an alternative sort key can be forced.');
  278.   writeln('   This is done by putting the number of the word to be sorted into the 3rd');
  279.   writeln('   comment field as the last word - in the case above adding 2 as the last word');
  280.   writeln('   acheives the desired result (assuming you want this entry filed under D).');
  281.   writeln('   For ''standard'' names (those it is useful to sort on the last word) no edit');
  282.   writeln('   of this comment field is required.');
  283.   writeln('■  An optional, parameter may be passed, giving the name of the address-book to');
  284.   writeln('   sorted. If no parameter is passed the OzCIS default book (ADDRBOOK.ADR in ');
  285.   writeln('   the OZCIS root directory) is assumed. If you keep ADDRBOOK.ADR in another');
  286.   writeln('   directory  a parameter giving the both name and path must be passed.');
  287.   writeln('   Obviously, if your address book is called something else this parameter');
  288.   writeln('   be needed to pass this filename and, if necessary the path.');
  289.   writeln('■  The old, unsorted, address book is backed-up first so that data is');
  290.   writeln('   retreivable if something unexpected happens during sorting or file-saving');
  291.   writeln('   operations.');
  292.   writeln;
  293.   writeln('Thanks are due to Todd Fiske (TeamOz) for the sort customisation idea.');
  294.   writeln;
  295.   writeln('Richard Linter [70624,414], Aug 1993');
  296.   halt;
  297. end;
  298.  
  299. {===========================================================================}
  300.  
  301. begin
  302.   { /? as parameter requests help}
  303.   if paramStr(1) = '/?' then help;
  304.   if paramcount > 1 then
  305.   begin
  306.    writeln(#7,#10,#13,'SortAddr V2.1:  ERROR -> Too many parameters passed.',#10,#13);
  307.    writeln('A single (optional) parameter is required - this gives the filename');
  308.    writeln('of the address-book to sort. (If this parameter is not used the OzCIS');
  309.    writeln('defaults - addrbook.adr in the OzCIS root directory - is assumed).',#10,#13);
  310.    halt;
  311.   end;
  312.  
  313.   if paramCount = 1 then
  314.     filename := paramStr(1)
  315.   else
  316.     filename := 'ADDRBOOK.ADR';
  317.  
  318.   {$i-}
  319.    assign(F, filename); { Open input file }
  320.    reset(F);
  321.   {$i+}
  322.  
  323.   if IOResult <> 0 then
  324.   begin
  325.    writeln(#10,#13,'SortAddr V2.1:  ERROR -> The file (',Filename, ') was not found.');
  326.    writeln('Run ''SORTADDR'' with parameter ''/?'' for help, if needed.',#10,#13);
  327.    halt;
  328.   end;
  329.  
  330.   writeln(#10,#13,'SortAddr V2.1 - OzCIS V2 address book sort. Richard Linter [70624,414] 1993',#10,#13);
  331.   write  (' Sorting file ',filename,': ');
  332.  
  333.   { THE DATA IS READ, ITEM BY ITEM, FROM THE FILE AND PUT, IN ALPHA ORDER,
  334.     INTO A LINKED-LIST IN MEMORY}
  335.  
  336.   PList_Start  := Nil;
  337.   PPrev        := Nil;
  338.   { Read first record..}
  339.   ReadLN(f,file_line);
  340.   { Place it at start of linked-list with NEXT pointer indicating EOF}
  341.   New(PNew);
  342.   PList_Start  := PNew;
  343.   PNew^.Address_string := File_line;
  344.   PNew^.Next         := nil;
  345.   write('>');
  346.  
  347.   { Process rest of file}
  348.   repeat
  349.     ReadLN(F,File_line);
  350.     PCurrent := PList_Start;
  351.     fSortKey := getSortKey(File_line);
  352.     mSortKey := getSortKey(PCurrent^.address_string);
  353.     repeat
  354.       PPrev  := PCurrent;
  355.       if fSortKey > mSortKey then
  356.       begin
  357.         PCurrent := PCurrent^.Next;
  358.         if PCurrent <> nil then mSortKey := getSortKey(PCurrent^.address_string);
  359.       end
  360.     until  (PCurrent= nil) or (fSortKey <= mSortKey);
  361.  
  362.     { Position file_line in correct position in linked list..}
  363.     if PCurrent = nil then
  364.     { the new entry goes at the end of the list }
  365.     begin
  366.       new(PNew);
  367.       PNew^.Address_string := File_line;
  368.       PNew^.Next           := nil;
  369.       PPrev^.Next          := PNew;
  370.     end
  371.     else
  372.     { insert the new entry in the list }
  373.     begin
  374.       new(PNew);
  375.       PNew^.address_string := File_line;
  376.       PNew^.next           := PCurrent;
  377.       if PCurrent = PList_Start then
  378.         {the item has been inserted at the start of the list}
  379.         PList_Start := PNew
  380.       else
  381.         {the item has been inserted at the body of the list}
  382.         PPrev^.next := PNew;
  383.      end;
  384.    write('>');
  385.    until eof(F);
  386.    writeln;
  387.   close(f);
  388.  
  389.   {Get the filename and extension (in case the filename was passed as a
  390.    parameter)}
  391.   FSplit(FExpand(Filename), Dir, Name, Ext);
  392.  
  393.   {$i-}
  394.    assign(F,dir+Name+'.BAK');
  395.    erase(F);
  396.   {$i+}
  397.  
  398.   {For security reasons rename address book before writing sorted version }
  399.   if IOresult = 2 then {No problem, there was'nt an existing .BAK file};
  400.   assign(F,dir+name+ext);
  401.   rename(F,dir+name+'.bak');
  402.  
  403.   {Save the sorted address book }
  404.   assign(F,dir+name+ext);
  405.   rewrite(F);
  406.   PCurrent := PList_Start;
  407.   repeat
  408.     writeln(F,PCurrent^.address_string);
  409.     PCurrent := PCurrent^.next;
  410.   until  PCurrent^.next = nil;
  411.   writeln(F,PCurrent^.address_string);
  412.   close(F);
  413.   writeln(' Saving the now sorted file as ',dir+name+ext);
  414.   writeln(' The unsorted file was renamed ',dir+name+'.BAK',#10,#13);
  415.   reset(F);
  416.  
  417.   {Dispose of dynamic variables}
  418.   PCurrent := PList_Start;
  419.   repeat
  420.     PPrev    := PCurrent;
  421.     dispose(PCurrent);
  422.     PCurrent := PPrev^.Next;
  423.   until  (PCurrent= nil) ;
  424. end.
  425.