Programmer 7500/MAX_PROGRAMMERS.iso/INFO/TURBOPAS/FILEUT20.ZIP/FILEUTIL.PAS

Pascal/Delphi Source File | 1985-05-31 | 10.5 KB | 393 lines

program fileutil(input, output);

{  This program will add linefeeds, convert to all upper-case, convert
   to all-lowercase or convert all non-quoted characters (those in either
   " or ').  A quote is terminated by either the same as the start or an
   end of line.
   The file is invoked this way:

        fileutil [params] filename [outfile]

          available params are:
             ? - List parameters
             A - add linefeeds
             L - convert lower
             U - convert upper
             W - convert from WordStar to ASCII
             R - remove extraneous carriage return
             Q - don't modify inside quotes

           any combination except L and U is allowed                     }

type
  name = string[80];
  line = string[255];
  regpack = record
              ax,bx,cx,dx,bp,si,di,ds,es,flags : integer;
            end;

var
  i: integer;
  linefeeds, wstar, lower, upper, crs, quotes, ok: boolean;
  filen: text;
  filename, outfile, backfile: name;
  qu, sq : boolean;

procedure outchar(ch: char);
var
  regs : regpack;
begin
  with regs do
    begin
      ax := $0600;
      dx := ord(ch);
      msdos(regs);
    end;
end;

procedure outstring(ln: line);
var
  i : integer;
begin
  for i := 1 to length(ln) do
    outchar(ln[i]);
end;

procedure help;
begin
  outstring('The format for FILEUTIL is:'+#13#10);
  outstring(#13#10);
  outstring('FILEUTIL param [param..] [dr:][\path\]filename [[dr:][\path\]outfile]'+#13#10);
  outstring('  where'+#13#10);
  outstring('    param is'+#13#10);
  outstring('      A - add linefeeds'+#13#10);
  outstring('      L - convert lower'+#13#10);
  outstring('      U - convert upper'+#13#10);
  outstring('      W - convert from WordStar to ASCII'+#13#10);
  outstring('      R - remove extraneous carriage returns'+#13#10);
  outstring('      Q - don''t modify inside quotes'+#13#10);
  outstring('    [param..] are subsequent parameters seperated'+#13#10);
  outstring('      by spaces.  Any combination of parameters'+#13#10);
  outstring('      except L and U or A and W are allowed'+#13#10);
  outstring('    [dr:] is the optional drive with colon'+#13#10);
  outstring('    [\path\] is the optional path'+#13#10);
  outstring('    filename is the filename to make the changes to'+#13#10);
  outstring('      (the program with tell you the options you'+#13#10);
  outstring('      requested).'+#13#10);
  outstring('    [outfile] is the file to output the results to'+#13#10);
  outstring('      (the program will rename filename to filename.BAK'+#13#10);
  outstring('      if no outfile is specified).'+#13#10);
end;

function lowcase(ch: char): char;
begin
  if (ord(ch) > 64) and (ord(ch) < 91)
    then
      lowcase := chr(ord(ch)+32)
    else
      lowcase := ch;
end;

function exist(filename: name): boolean;
begin
  {$I-}
  assign(filen, filename);
  reset(filen);
  {$I+}
  exist := (IOresult = 0);
end;

procedure switch_it(var st: char; w1, w2: boolean);
begin
  if w1
    then
      begin
        if (st = chr(34)) and (not qu) and (not sq)
          then
            qu := true
           else
             if (st = chr(34)) and (qu) and (not sq)
               then
                 qu := false
                else
                  if (st = chr(39)) and (sq) and (not qu)
                    then
                      sq := false
                    else
                      if (st = chr(39)) and (not sq) and (not qu)
                        then
                          sq := true;
          if not (qu or sq)
            then
              if w2
                then
                  st := upcase(st)
                else
                  st := lowcase(st);
      end
    else
      if w2
        then
          st := upcase(st)
        else
          st := lowcase(st);
end;

procedure parameters(var ok: boolean);
var
  i,j : integer;
begin
  ok := true;
  if outfile=''
    then
      j := paramcount-1
    else
      j := paramcount-2;
  for i:=1 to j do
    case upcase(paramstr(i)) of
      'A': linefeeds := true;
      'L': lower     := true;
      'U': upper     := true;
      'W': wstar     := true;
      'R': crs       := true;
      'Q': quotes    := true;
    end;
  if (lower and upper)
    then
      ok := false;
  if (linefeeds and wstar)
    then
      ok := false;
end;

procedure backup(var fn: name);
var
  f1 : text;
  filename : name;
begin
  filename := fn;
  outstring('  Backing up...');
  if pos('.',filename)>0
    then
      delete(filename,pos('.',filename),4);
  filename := filename+'.bak';
  if exist(filename)
    then
      begin
        assign(f1,filename);
        erase(f1);
        close(f1);
      end;
  assign(f1,fn);
  rename(f1,filename);
  close(f1);
  fn := filename;
end;

procedure remove_extraneous(var f1, f2: text);
var
  t : char;
begin
  write(f2,' ');
  readln(f1);
  read(f1,t);
  if (eoln(f1)) or (t=#9)
    then
      writeln(f2);
  if (eoln(f1))
    then
      readln(f1)
    else
      write(f2,t);
end;

procedure strip(oldn, newn: name);
var
  f1, f2 : text;
  t1 : char;
  t2 : byte;
begin
  outstring(' reading...');
  assign(f1,oldn);
  reset(f1);
  assign(f2,newn);
  rewrite(f2);
  outstring(' modifying...');
  while not eof(f1)
    begin
      while not eoln(f1)
        begin
          read(f1,t1);
          t2 := ord(t1);
          if t2 > 127
            then
              t2 := t2-128;
          t1 := chr(t2);
          if not (upper or lower)
            then
              write(f2,t1)
            else
              begin
                if (t1=chr(34)) and (not qu) and (not sq)
                  then
                    qu := true
                  else
                    if (t1=chr(34)) and (qu) and (not sq)
                      then
                        qu := false
                      else
                        if (t1=chr(39)) and (sq) and (not qu)
                          then
                            sq := false
                          else
                            if (t1=chr(39)) and (not sq) and (not qu)
                              then
                                sq := true
                              else
                                if (t1=chr(13))
                                  then
                                    begin
                                      qu := false;
                                      sq := false;
                                    end;
                if not (qu or sq)
                  then
                    if upper
                      then
                        t1:=upcase(t1)
                      else
                        if lower
                          then
                            t1:=lowcase(t1);
               write(f2,t1);
             end;
           if crs
             then
               remove_extraneous(f1,f2)
             else
               begin
                 readln(f1);
                 writeln(f2);
               end;
           end;
    end;
  close(f1);
  close(f2);
  outstring(' done.'+#13#10);
end;

procedure modify(oldn, newn: name);
var
  f1, f2 : text;
  temp : char;
begin
  outstring(' reading...');
  assign(f1,oldn);
  reset(f1);
  assign(f2,newn);
  rewrite(f2);
  outstring(' modifying...');
  while not eof(f1)
    begin
      while not eoln(f1)
        begin
          read(f1,temp);
          qu := false;
          sq := false;
          if upper
            then
              if quotes
                then
                  switch_it(temp,true,true)
                else
                  switch_it(temp,false,true);
          if lower
            then
              if quotes
                then
                  switch_it(temp,true,false)
                else
                  switch_it(temp,false,false);
          write(f2,temp);
        end;
      if crs
        then
          remove_extraneous(f1,f2)
        else
          begin
            readln(f1);
            writeln(f2);
          end;
    end;
  close(f1);
  close(f2);
  outstring(' done.'+#13#10);
end;

begin
  linefeeds := false;
  wstar     := false;
  upper     := false;
  lower     := false;
  crs       := false;
  quotes    := false;
  qu        := false;
  sq        := false;
  if (paramcount < 2)
    then
      help
    else
      begin
        filename := paramstr(paramcount-1);
        outfile  := paramstr(paramcount);
        if length(filename)=1
          then
            begin
              filename := outfile;
              outfile  := '';
            end;
          outstring('FILEUTIL ver 2.0 (C)1985 Sarcastic Software  (Use ? for help)'+#13#10);
          outstring(#13#10);
          if exist(filename)
            then
              begin
                parameters(ok);
                if not ok
                  then
                    outstring('Invalid parameters.  Use UTIL ? for help'+#13#10)
                  else
                    begin
                      if linefeeds then outstring('Adding linefeeds.'+#13#10);
                      if wstar then outstring('Converting from WordStar to ASCII.'+#13#10);
                      if crs then outstring('Removing extraneous carriage returns.'+#13#10);
                      if upper then outstring('Converting to UPPER case');
                      if lower then outstring('Converying to lower case');
                      if quotes and (upper or lower) then outstring(' except within quotes.'+#13#10);
                      if (upper or lower) and not (quotes) then outstring('.'+#13#10);
                      if outfile=''
                        then
                          begin
                            backfile := filename;
                            backup(backfile);
                          end;
                      if outfile>''
                        then
                          begin
                            outstring('  '+filename+' --> '+outfile+' ... ');
                            backfile := filename;
                            filename := outfile;
                          end;
                      if wstar
                        then
                          strip(backfile, filename)
                        else
                          modify(backfile, filename);
                    end;
              end
            else
              outstring(filename+' not found!'+#13#10);
      end;
end.