CP/M/CPM_CDROM.iso/cpm/turbopas/decuf10.ark/DECUF.IF1

Text File | 1989-09-27 | 15KB | 497 lines

{* ----------------------------------------------------------------- *
 *                                                                   *
 *       U S E R   I N T E R F A C E    P R O C E D U R E S          *
 *                                                                   *
 * ----------------------------------------------------------------- *}

procedure DisplayHelpInfo ;
{*
 * DisplayHelpInfo - Display a short description of this program on
 *                   the standard output file.
 *}
begin
   WriteLn( 'DecUF (DECode_Uuencoded_File)  v 1.0' ) ;
   Write  ( 'Usage  : DecUF <InputFile> [/o<OutputPath>]' ) ;
   WriteLn( ' [/c{+,-}] [/s{+,-}] [/v{+,-}]' ) ;
   WriteLn ;
   WriteLn( 'Written by W. Nelis, [e-mail], 199106' ) ;
   WriteLn ;
end ;  { of DisplayHelpInfo }

procedure Panic( Severity : ErrorTypes ; ErrorMsg : Message ) ;  forward ;

procedure CrackParameters ;
{*
 * CrackParameters - Proces the parameters supplied to this program.
 *}
type
   Parameters = ( InputFile  ,    { Drive/user/name of input file }
                  OutputPath ,    { Drive/user for decoded files }
                  FileCount  ,    { Input file contains one encoded file }
                  CheckMode  ,    { Strict or relaxed checking }
                  Verbose    ) ;  { Progress report enabled }
var
  Specified : set of Parameters ;  { Specified parameters }
  NextParam :     KeywordString ;  { Next parameter from command line }
  ColonPos  :           Integer ;  { Position of ':' in path name }
  I         :           Integer ;  { Loop control variable }

 procedure ParameterError ;
 {*
  * ParameterError : Issue an error meesage about a parameter in error.
  *                  The parameter in question is ignored.
  *}
 begin
    Panic( Informative, 'Illegal Parameter "'+NextParam+'". It is ignored' ) ;
 end;  { of ParameterError }

 procedure SetFlag( var Variable : Boolean ;  VarType : Parameters ) ;
 {*
  * SetFlag : Set the option Variable to TRUE if the third character in the
  *           parameterstring is a '+' sign and set it to FALSE if it is a
  *           '-' sign.  The presence of the option is saved in Specified.
  *}
 begin
   if VarType in Specified then
     ParameterError
   else
     if (Length(NextParam)=3) and (NextParam[3] in ['+','-']) then
      begin
       Specified:= Specified + [VarType] ;
       Variable := NextParam[3]='+' ;
      end
     else
       ParameterError ;
 end ;  { of SetFlag }

begin
   Specified:= [] ;  { Empty set of specified parameters }
   for I:= 1 to ParamCount do
    begin
     NextParam:= ParamStr(I) ;
     if (Length(NextParam)>1) and (NextParam[1]='/') then
{*
 * The parameter on the command line has the format /KV, in which 'K' is
 * a one-character keyword and V the associated value.
 *}
      begin
       case NextParam[2] of
{*
 * Specify the path, that is the drive and the user number, to the area
 * to save the decoded file(s).
 *}
       'O' : begin
               if Outputpath in Specified then
                 ParameterError
               else  { OutputPath is not yet specified }
                begin
                 Specified     := Specified + [OutputPath] ;
                 OutputFilePath:= Copy( NextParam, 3, 255 ) ;
                 ColonPos      := Pos( ':', OutputFilePath ) ;
                 if ColonPos=0 then
                   OutputFilePath:= OutputFilePath + ':'
                 else
                   OutputFilePath:= Copy( OutputFilePath, 1, ColonPos ) ;
                end ;  { of else }
             end ;  { of case O }
{*
 * Specify whether the input file contains one (S+) or more (S-) encoded
 * files.
 *}
       'S' : SetFlag( OnlyOneFile   , FileCount ) ;
{*
 * Specify whether an error in the format is a fatal error (C+) or is to
 * be ignored (C-).  In the latter case email headers are allowed within
 * the input file.
 *}
       'C' : SetFlag( StrictChecking, CheckMode ) ;
{*
 * Specify whether a progres report, together with statistics, is to be
 * generated (V+) or not (V-).
 *}
       'V' : SetFlag( VerboseMode   , Verbose   ) ;

       else  { the parameter is not supported }
         ParameterError ;
       end ;  { of cases }
      end    { of if }
{*
 * The parameter on the command line is not of the format /KV, thus it must
 * be the name of the input file.
 *}
     else
      begin
       if InputFile in Specified then
         ParameterError
       else
        begin
         Specified    := Specified + [InputFile] ;
         InputFileName:= NextParam ;
         if Pos( '.', InputFileName )=0 then
           InputFileName:= InputFileName + DefaultExtension ;
        end ;  { of else }
      end ;  { of else }
    end ;  { of for }

{*
 * The inputfile must have been specified.
 *}
   if not (InputFile in Specified) then
     Panic( Catastrophic, 'No input file specified' ) ;
end ;  { of CrackParameters }

procedure DisplayStatistics ;
{*
 * DisplayStatistics - Display the statistics of this conversion run.
 *}
var
   ByteCount : Real ;  { Actual number of bytes written }
begin
   ByteCount:= 128.0 * BytesWritten ;
   Write  ( ^M ) ;  ClrEol ;
   WriteLn ;
   WriteLn( 'Number of lines read ....... ',         LinesRead:10 ) ;
   WriteLn( 'Number of lines written .... ',      LinesWritten:10 ) ;
   WriteLn( 'Number of characters read .. ',    CharactersRead:10 ) ;
   WriteLn( 'Number of bytes written .... ',       ByteCount:10:0 ) ;
   WriteLn( 'Number of heap flushes ..... ',       HeapFlushes:10 ) ;
   WriteLn( 'Number of lines skipped .... ',      LinesSkipped:10 ) ;
   WriteLn( 'Number of characters skipped ', CharactersSkipped:10 ) ;
end ;  { of DisplayStatistics }

procedure PresetDecodeTable ;
{*
 * PresetDecodeTable - Preset the character-to-sextet conversion table
 *                     to its default.
 *}
var
   I : Char ;  { Loop control variable }
begin
   for I:= ' ' to '_' do
     DecodeTable[I]:= Ord(I) - Ord(' ') ;
   for I:= Succ('_') to Chr(255) do
     DecodeTable[I]:= $FF ;

   DecodeTable['`']:= DecodeTable[' '] ;
end ;  { of PresetDecodeTable }

{* ----------------------------------------------------------------- *
 *                                                                   *
 *        P R O L O G U E S   A N D   E P I L O G U E S              *
 *                                                                   *
 * ----------------------------------------------------------------- *}
{*
 * Both the execution of this program and the conversion of one file
 * are encapsulated between a prologue and an epilogue.
 *}

procedure CloseOutputFile ;  forward ;

procedure FilePrologue ;
{*
 * FilePrologue - Preset the global variables prior to the decoding of
 *                the (next) file.
 *}
begin
   OutputFileName   := OutputFilePath + 'NoName.XYZ' ;
   OutputFileOpen   := False ;

   PresetDecodeTable ;
   DecodeState      := Sextet0 ;
   LineFormat       := Unknown ;

   BytesWritten     := 0 ;
   CharactersRead   := 0 ;
   CharactersSkipped:= 0 ;
   HeapFlushes      := 0 ;
   LinesRead        := 0 ;
   LinesSkipped     := 0 ;
   LinesWritten     := 0 ;

   AllocateChunk ;  { Reserve space for output data }
end ;  { of FilePrologue }

procedure FileEpilogue ;
{*
 * FileEpilogue - Finish processing of the current output file.  The
 *                global variables, except for the options, are set to
 *                their default value.
 *}
begin
{*
 * Finish processing on the current result file.
 *}
   CloseOutputFile ;
   if VerboseMode then
     DisplayStatistics ;
{*
 * (P)reset global variables.
 *}
   ReleaseChunks ;  { Reset chunklist pointers, just to be sure }
end ;  { of FileEpilogue }

procedure ProgramPrologue ;
{*
 * ProgramPrologue - Preset the global variables and interpret the command
 *                   line options.
 *}
begin
{*
 * Preset the global variables.
 *}
   HeadChunkList:= Nil ;
   TailChunkList:= Nil ;
   NextLine     := ' ' ;
   LineIndex    :=   1 ;
   ErrorsInLine := [ ] ;
{*
 * Set defaults for all the options
 *}
   OutputFilePath:= Chr( Bdos($19) + Ord('A') )  + ':' ;
   OnlyOneFile   := False ;
   StrictChecking:= False ;
   VerboseMode   := True  ;
{*
 * Now it is time to execute the file prologue: it resets the various
 * global variables, which MUST have been (re)set in case the error
 * processor is invoked!
 *}
   FilePrologue ;

{*
 * Read the command line and extract the options.
 *}
   if ParamCount=0 then
    begin
     DisplayHelpInfo ;
     UnInitFileNameUnit ;
     Halt ;
    end
   else
     CrackParameters ;
end ;  { of ProgramPrologue }

procedure ProgramEpilogue ;
{*
 * ProgramEpilogue - Clean up before termination of the program.
 *}
begin
   Close( InputFile ) ;
   CloseOutputFile ;
end ;  { of ProgramEpilogue }

procedure Panic ;
{*
 * Panic - Proces an error condition.
 *}
begin
{*
 * Exit from this routine, if the error is to be ignored.
 *}
   if (Severity=Warning) and (not StrictChecking) then
     Exit ;
{*
 * Remove the progres report line from the screen.
 *}
   if VerboseMode then
    begin
     Write( ^M ) ;  { Goto left side of screen }
     ClrEol      ;  { Remove progres report }
    end ;  { of if }
{*
 * Display the errormessage, together with more detailed messages, if
 * available.
 *}
   if LinesRead=0 then
     Write( 'Error' )
   else
     Write( 'Error at line ', LinesRead ) ;
   WriteLn( ' - ', ErrorMsg, '.' ) ;

   if IllegalCharacter in ErrorsInLine then
     WriteLn( ' - Illegal character found.' ) ;
   if Overflow         in ErrorsInLine then
     WriteLn( ' - Internal line buffer too small.' ) ;
   if IllegalFormat    in ErrorsInLine then
     WriteLn( ' - Length field cannot be decoded.' ) ;
   if WrongLength      in ErrorsInLine then
     WriteLn( ' - Length field wrong.' ) ;
   if WrongTerminator  in ErrorsInLine then
     WriteLn( ' - Line terminator is not ''M''.' ) ;
{*
 * Take further actions, den pending on the type of error.
 *}
   if Severity=Catastrophic then
    begin
     WriteLn( 'Program premature terminated.' ) ;
     ProgramEpilogue ;
     UnInitFileNameUnit ;
     Halt ;
    end
   else
     if Severity<>Informative then
      begin
       if OutputFileOpen then
        begin
         WriteLn( 'File ', OutputFileName, ' is erased.' ) ;
         ReleaseChunks ;       { Destroy any data gathered in chunks }
         CloseOutputFile ;     { Close the result file and .. }
         Erase( OutputFile ) ; { destroy the result file too }
        end ;  { of if }
       ProcessingState:= Completed ;  { Skip rest of file }
      end ;  { of if/else }
end ;  { of Panic }


{*
 * FILES : Opening and closing of both the input file and the result
 * file.
 *}

procedure OpenInputFile ;
{*
 * OpenInputFile - Open the input file.
 *}
begin
{*
 * Rebuild the input file name.
 *}
   SplitFileName( InputFileDesc, InputFileName ) ;
   InputFileName:= ExpandFileName( InputFileDesc, DUNE_Format ) ;
   RegisterFile( InputFileDesc, InputFile ) ;

   Assign( InputFile, ExpandFileName(InputFileDesc,DNE_Format) ) ;
   {$I-}  Reset(InputFile) ;  {$I+}
   if IOResult<>0 then  { the file doesn't exists }
     Panic( Catastrophic, 'Can''t find file '+InputFileName )
   else
     if Eof(InputFile) then
       Panic( Catastrophic, 'File '+InputFileName+' is empty' ) ;
end ;  { of OpenInputFile }

procedure OpenOutputFile ;
{*
 * OpenOutputfile - Open the result file.
 *}
var
   Answer : Char ;  { Answer from user }
begin
{*
 * Rebuild output file name.
 *}
   SplitFileName( OutputFileDesc, OutputFileName ) ;
   OutputFileName:= ExpandFileName( OutputFileDesc, DUNE_Format ) ;
   RegisterFile( OutputFileDesc, OutputFile ) ;

   Assign( OutputFile, ExpandFileName(OutputFileDesc,DNE_Format) ) ;
   {$I-} Reset( OutputFile ) ;  {$I+}
   if IOResult=0 then  { the file exists already }
    begin
     Close( OutputFile ) ;
     repeat
       Write( ^G^M'Warning - file ', OutputFileName, ' exists. ' ) ;
       Write( 'Overwrite (destroy) it (y/n)? ' ) ;  ClrEol ;
       Read ( Kbd, Answer ) ;
       Answer:= UpCase( Answer ) ;
     until Answer in ['N','Y'] ;
     WriteLn( Answer ) ;
     if Answer='N' then
      begin
       ProcessingState:= Completed ;  { Skip this encoded file }
       Exit ;
      end ;  { of if }
    end ;  { of if }

{$I-}  Rewrite( OutputFile ) ;  {$I+}
   if IOResult=0 then
     OutputFileOpen:= True
   else
     Panic( Catastrophic, 'Can''t write on file '+OutputFilename ) ;
end ;  { of OpenOutputFile }

procedure CloseOutputFile ;
{*
 * CloseOutputFile - Write all buffered data to the result file and
 *                   close it.
 *}
begin
   if OutputFileOpen then
    begin
     FlushChunks ;
     Close( OutputFile ) ;
     OutputFileOpen:= False ;
    end ;  { of if }
end ;  { of CloseOutputFile }


{*
 * Handling of the input from the input file.
 *}

procedure ReadNextLine ;
{*
 * ReadNextLine - Read the next line from the input file into NextLine.
 *                Non-printable characters are removed from the line
 *                image.
 *}
var
   LineLength : Integer ;  { Current length of line read }
   I          : Integer ;  { Loop control variable }
begin
   NextLine    :=    '' ;
   ErrorsInLine:=    [] ;
   if not Eof(InputFile) then
    begin
     ReadLn( InputFile, NextLine ) ;
     CharactersRead:= CharactersRead + Length(NextLine) ;
{*
 * Remove the trailing blanks from string : uuencoded files
 * are (should be) insensitive to trailing blank removal.
 *}
     LineLength:= Length(NextLine) ;
     while (LineLength>0) and (NextLine[LineLength]=' ') do
       Dec(LineLength) ;
     if LineLength<Length(NextLine) then
       NextLine:= Copy( NextLine, 1, LineLength ) ;
{*
 * See if there are any control-characters in the line read.  Optionally
 * these characters could be removed.  However, the line probably will
 * be rejected without interpretation.
 *}
     if LineLength>0 then
       for I:= LineLength downto 1 do
         if NextLine[I]<' ' then
          begin
           ErrorsInLine:= ErrorsInLine + [IllegalCharacter] ;
(*         NextLine    := Copy( NextLine,   1,        I-1 ) +
                          Copy( NextLine, I+1, LineLength ) ;  *)
           Inc( CharactersSkipped ) ;
          end ;  { of if/for/if }

    end ;  { of if Eof() }
   Inc( LinesRead ) ;
end ;  { of ReadNextLine }

function NextWord : KeyWordString ;
{*
 * NextWord - Extract the next word from NextLine starting at character
 *            offset Index.
 *}
var
   SomeWord : KeyWordString ;
begin
   SomeWord:= '' ;
   while (LineIndex<=Length(NextLine)) and
         (NextLine[LineIndex]=' ')    do
     LineIndex:= Succ(LineIndex) ;

   while (LineIndex<=Length(NextLine)) and
         (NextLine[LineIndex]<>' ')    do
    begin
     SomeWord:= SomeWord + NextLine[LineIndex] ;
     LineIndex:= Succ(LineIndex) ;
    end ;  { of while }
   NextWord:= SomeWord ;
end ;  { of NextWord }