Columbia Kermit/kermit.zip/norskdata/ndkfil.pas

Pascal/Delphi Source File | 2020-01-01 | 14KB | 368 lines

(*  tab  p;
 *
 *        File open/close routines (machine dependent)
 *
 *)
    procedure ParseFile (   VAR FileName    :   NameType;
                            VAR NamePart    :   StringType;
                            VAR TypePart    :   Char4Array;
                                QuoteName   :   boolean    );

    var i, j, parlvl : integer;
        ch           : char;
        NotThru      : boolean;
    begin
        with FileName do begin
            i       := 1;
            j       := MinString;
            parlvl  := 0;
            if QuoteName then begin
                NamePart(.j.) := '"';
                j := j + 1;
            end;

            ch := String(.i.);
            while ( i<=valid )
          and not ( (ch=':') and (parlvl=0) ) do begin
                if ch='(' then
                    parlvl := parlvl + 1
                else if ch=')' then
                    parlvl := parlvl - 1;
                NamePart(.j.) := ch;
                i  := i + 1 ;
                j  := j + 1 ;
                ch := String(.i.);
            end;
            if QuoteName then begin
                NamePart(.j.) := '"';
                j := j + 1;
            end;
            NamePart(.j.) := '''';

            if i>valid then (* no colon - use default type *)
                TypePart := DefFtype
            else
            begin
                j       := 1;
                NotThru := TRUE;
                for i := i + 1 to i + MaxFType do begin
                    if (i<=valid) and NotThru then begin
                        ch := String(.i.);
                        if (ch=';') then begin
                            NotThru := FALSE;  (* watch out for version delimiter *)
                            ch := ' ';
                        end;
                        TypePart(.j.) := ch
                    end
                    else
                        TypePart(.j.) := ' ';
                    j := j + 1;
                end;
            end;
        end;
    end;

    function OpenRead (     VAR ReadFile    :   ByteFile ;
                            VAR FileName    :   NameType ) : integer;
    (* Abstract : Opens ReadFile for Read
                  Does a RESET of the file

                  Returns 0 if Open was successful,
                       i.e. file existed and read access of file was granted. *)

    var     ostat    : integer;
            NamePart : StringType;
            TypePart : Char4Array;
    begin
        ParseFile ( FileName, NamePart, TypePart, OldFile );
        Connect ( ReadFile, NamePart, TypePart, 'R', Ostat );
        if Ostat=0 then
            reset( ReadFile );
        OpenRead := Ostat;
    end;


    function OpenWrite (    VAR WriteFile   :   ByteFile ;
                            VAR FileName    :   NameType ) : integer;
    (* Abstract:  Opens WriteFile for Write
                  Does a REWRITE of the file
                  Returns -1 If Open was NOT successful.
                           0 If Open was immediately successful, i.e.
                             new file or write access granted to existing
                             file, provided FileWarning OFF.
                           1 If Open was successful after renaming file, i.e.
                             Kermit was able to create the new file       *)

    CONST   Existing = 62;

    var     ostat    : integer;
            original : NameType;
            NamePart : StringType;
            TypePart : Char4Array;
            Exit     : Boolean;
    begin
            (* First: Possible to create new file? *)
        ParseFile ( FileName, NamePart, TypePart, NewFile );
        OpenWrite := 0;     (* Assume no trouble at all! *)
        Connect ( WriteFile, NamePart, TypePart, 'W', Ostat );
        if Ostat=0 then begin
            rewrite( WriteFile );
        end
        else begin   (* Not possible, go try something else .. *)
            if Ostat<>Existing then
                OpenWrite := -1     (* No hope if other than "File already exists" *)
            else if FileWarning then begin
                 (*   Exit := false;
                    Original := FileName;
                    repeat (* modify file name systematically
                              until able to create new file
                    until Exit;  *)
                    OpenWrite := -1;  (* Do it simply - so far! *)
                end
                else begin  (* FileWarning is off - overwriting is permitted *)
                    ParseFile ( FileName, NamePart, TypePart, OldFile );
                    Connect ( WriteFile, NamePart, TypePart, 'W', Ostat );
                    if Ostat=0 then
                    begin
                        OpenWrite := 0;
                        rewrite( WriteFile );
                    end
                    else
                        OpenWrite := -1;
                end;
        end;
    end;

    function CloseFile( VAR FileToClose     : ByteFile ):integer;
    (*  Abstract:   Do any actions necessary when closing file *)
    begin
        DisConnect ( FileToClose );
        CloseFile := 0;
    end;

    procedure PutFileName(  VAR FileN   :   NameType;
                            VAR Pack    :   Packet;
                            Translate   :   Boolean );
    (*  Abstract:   Puts a file name corresponding to internal format
                    in FileN into a FileHeader packet (Pack).
                    Does any necessary transformations of file name *)
    VAR NamePart            : StringType;
        TypePart            : Char4Array;
        i, j                : integer;
        ch                  : char;
    begin
        if Translate then begin
            ParseFile( FileN, NamePart, TypePart, OldFile );
            i := MinString;
            (* skip ( <directory> : <username> ) ! *)
            if NamePart(.i.)='(' then begin
                while NamePart(.i.) <> ')' do i := i + 1;
                i := i + 1;
            end;
            j := MinString;
            ch := NamePart(.i.);
            with Pack do begin
                while ch<>'''' do begin
                    data(.j.) := ch;
                    i := i + 1;
                    j := j + 1;
                    ch := NamePart(.i.);
                end;
                data(.j.) := '.';
                for i := 1 to MaxFType do begin
                    j := j + 1;
                    data(.j.) := TypePart(.i.);
                end;
            end;
        end else with Pack do begin
            j := MinString;
            for i := MinName to FileN.Valid do begin
                data(.j.) := FileN.String(.i.);
                j := j + 1;
            end;
            j := j - 1;
        end;
        Pack.count := ToChar ( chr ( j + 4 - MinString ) );
        Pack.seq   := ToChar ( chr ( n ) );
        Pack.ptype := PackToCh ( FHeadPack );
    end;

    procedure GetFileName(  VAR FileN   :   NameType;
                            VAR Pack    :   Packet );
    (*  Abstract:   Gets a file name from a FileHeader packet and converts
                    to internal format in FileN, including
                    any necessary transformations of file name *)
    VAR i : integer;
    begin
        with Pack do begin
            if ( Ptype<>PackToCh( FHeadPack ) ) and Debug then begin
                DbgWrite(' Attempts GetFileName from non-FileHeader packet!');
                DbgNL;
            end;
            FileN.valid := ord ( UnChar ( count ) ) - 3;
                 (* Expecting DEC-10/20, CP/M / MP/M style filenames <nam>.<typ>,
                    convert to Sintran simply by changing '.' to ':' *)
            for i := 1 to FileN.valid do begin
                    ch := data(.i - 1 + MinString.);
                    if ch='.' then ch := ':';
                    FileN.String(.i.) := ch;
            end;
        end;
    end;

    function        BuildList(  Parameter : NameType;
                             VAR NameList : NListPtr ): boolean;
    (*
     * From given Parameter - construct list of files to send.
     * Possible forms of parameter:
     *  @filename   -   Indicating indirect-file - default type :SYMB.
     *      Indirect-file consists of a list of files (one per line)
     *      to send. If the filename is followed by another string
     *      separated from the filename with whitespace, this string
     *      is put into file-header packet instead. This enables you
     *      to specify filename on the remote machine.
     *  filename    -   Sent without deabbreviation. ("." instead of ":")
     *  filespec    -   * - 0 or more chars or digits
     *                  % - 1 char or digit.
     *      Only filename or type may contain wildcard characters.
     * Return: success/error.
     *)
    var     IndFile :   text;
            Status  :   integer;
            RetVal  :   boolean;
            p       :   NListPtr;
            i       :   integer;

        procedure   ReadString( VAR FromFile : text;
                                VAR StrToRead: NameType );
        var ch  :   char;
        begin
            with StrToRead do begin
                Valid := 0;
                while ( StripParity( FromFile^ ) <> ' ' )
                    and not eof( FromFile )
                    and not eoln( FromFile )
                    and ( Valid < MaxName )
                do begin
                    Valid := Valid + 1;
                    read( FromFile, ch );
                    String(.Valid.) := StripParity( ch );
                end;
                while not eof(FromFile)
                    and not eoln(FromFile)
                    and ( StripParity( FromFile^ ) <> ' ' )
                do
                    read( FromFile, ch );  (* skip until space or eoln *)
            end;
        end;

        procedure   EatSpace( VAR FromFile : text );
        var     ch  :   char;
        begin
            while not eof( FromFile )
                and not eoln( FromFile )
                and ( StripParity( FromFile^ ) = ' ' )
            do read( FromFile, ch );
        end;

        function    PosOf( ch : char; Par : NameType ): integer;
        var i : integer;
            Found : boolean;
        begin
            i := MinString;
            Found := false;
            while not Found and ( i < Par.Valid ) do begin
                i := i + 1;
                Found := Par.String(.i.) = ch;
            end;
            if not Found then i := 0;
            PosOf := i;
        end;

        procedure   ReverseList( VAR ThisList : NListPtr );
        var     p, ToList : NListPtr;
        begin
            p := NIL; ToList := NIL;
            while ThisList <> NIL do begin
                p := ThisList;
                ThisList := ThisList^.Next;
                p^.Next := ToList;
                ToList := p;
            end;
            ThisList := ToList;
        end;

    begin
        NameList := NIL;
        RetVal := Failure;
        if Parameter.String(.MinName.) = '@' then begin
            with Parameter do begin
                for i := MinName to Valid - 1 do
                    String(.i.) := String(.i+1.);
                Valid := Valid - 1;
                String(.Valid+1.) := '''';
                connect(IndFile,String,'SYMB','R',Status);
                if Status <> 0 then
                    writeln('Could not open indirect-file')
                else begin
                    reset( IndFile );
                    while not eof( IndFile ) do begin
                        new(p);
                        EatSpace( IndFile );
                        while StripParity( IndFile^ ) = '!' do begin
                            readln( IndFile );
                            EatSpace( IndFile );
                        end;
                        ReadString( IndFile, p^.Name );
                        EatSpace( IndFile );
                        if not eoln( IndFile ) then begin
                            ReadString( IndFile,p^.AltName );
                            p^.AltUsed := true;
                        end else
                            p^.AltUsed := false;
                        readln( IndFile );
                        p^.Next := NameList;
                        NameList := p;
                    end;
                    disconnect( IndFile );
                    ReverseList( NameList );
                    RetVal := Success;
                end;
            end;
        end else if ( PosOf('%',Parameter) > 0)
                 or ( PosOf('*',Parameter) > 0 ) then begin
            writeln('Wildcards not yet implemented');
        end else begin
            new( NameList );
            NameList^.Name := Parameter;
            NameList^.AltUsed := False;
            NameList^.Next := NIL;
            RetVal := Success;
        end;
        BuildList := RetVal;
    end;

    procedure       ShowList( FileList : NListPtr );
    var     p   :   NListPtr;

        procedure   PrName( VAR f : text; Name : NameType );
        var i : integer;
        begin
            for i := 1 to Name.Valid do
                write( f, Name.String(.i.) );
        end;

    begin
        p := FileList;
        while p <> NIL do begin
            PrName( output, p^.Name );
            if p^.AltUsed then begin
                write( output, ' - ' );
                PrName( output, p^.AltName );
            end;
            writeln( output );
            p := p^.Next;
        end;
    end;