Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/MADTRB11.ZIP/PSYSTEM.PAS

Pascal/Delphi Source File | 1985-08-05 | 9.3 KB | 307 lines

program psystem;

{
This program will read files from a Diskette formatted under the
UCSD p-system and transfer them to an MS-DOS diskette.  It assumes
that the p-system diskette will be IN THE RIGHT-HAND DRIVE,
and that the default diskette is NOT THE B-DISK.  It will read
the directory, display it one file at a time, and then prompt the
user for permission to copy the file.  It copies under the
assumptions:

        1. Text files will be converted to ASCII, with the header
           page (used by the p-system editor) discarded, and the
           file converted to standard format. (see procedure pageout)

        2. Other files are copied as-is.


(c) 1983, Paul Klarreich, Brooklyn, NY

This program is licensed for non-commercial use.

Source: "PSYSTEM: Converting UCSD Source Files To Turbo", TUG Lines Volume I Issue 3
Author: Paul Klarreich
Application: IBM PC UCSD Systems (modification required for use with CP/M machines)

}

type
    direntry = packed record
                        { This is the standard UCSD directory entry --
                          same for all implementations.  The first one
                          is always the volume entry. }
        firstblok, lastblok : integer; { actually, lastblok -> beyond file }
        filtype, blank : byte;
        filname : string[15];
        fillast, { # of bytes in the last block -- need for file size }
        daterec : integer;
    end;  { takes up 26 bytes }

    sectbuffer = array[0..511] of byte;  { For direct reading }
    pagebuffer = array[0..1023] of byte; { For text files }
    short = string[40];

var
    mainbuf : sectbuffer;
    textpage : pagebuffer;
    directory : record case boolean of
        true : (dir : array[0..77] of direntry);
        false: (bufs: array[0..3] of sectbuffer);
    end;

{ ------ Get a yes-no response from user -------- }
function yes(message : short) : boolean;
var resp : char;
begin
    write(message);
    repeat read(kbd,resp);  resp := upcase(resp);
    until resp in ['Y','N',chr(27)];
    if resp = chr(27) then halt;
    yes := resp = 'Y';
end; { yes }

{ ------------------ Print a directory entry --------------- }
procedure printentry(var bb : direntry);

{ print the file name, the number of blocks, and the type }

begin
    { assume this is a live file -- test was made earlier }
    with bb do write(filname : 16,'   ',lastblok - firstblok,
        ' blocks,  ');
    case bb.filtype of

        0,1,5 : write('data');
        2     : write('code');
        3     : write('text');
        4     : write('foto');
        6     : write('graf');
        else write('????');
    end;
    writeln('-file');
end;


{ -------------- Read a p-system block from 0..639 --------- }

function get1block(blockno : integer; var buffer : sectbuffer) : integer;

{ tries to read the block.  Return code indicates the success }

var
    returncode, sectorsdone, drive, side, track, sector,
    sectorcount, bufsegment, bufoffset : integer;
type
    regset = record
        al, ah : byte;
        bx : integer;
        cl, ch, dl, dh : byte;
        bp, si, di, ds, es, flags : integer;
    end;

var
    machine : regset;
    otherbuffer : sectbuffer;

    { ----- Perform the mapping of block into side,track,sector ----}
    { -----       Clearly this part is IBM-specific             ----}
    procedure map(block : integer; var side,track,sector : integer);
    begin
        side := block div 320;
        if side = 0 then
            track := block div 8
        else
            track := 79 - block div 8;
        sector := block mod 8 + 1;
    end;
    { ------------------------------------------------------------- }

begin { prepare the machine for an interrupt call }

    map(blockno, side, track, sector);

    with machine do begin

        dl := 1;  { drive 1 = the B-disk }
        dh := side;  { which head to read from }
        ch := track;
        cl := sector;
        al := 1;   { read just one sector }
        es := seg(buffer);  { segment address of DMA operation }
        bx := ofs(buffer);  { offset  address of DMA operation }
        ah := 2;   { service code for reading sectors into memory }

    end;
    { should be all set now }
    writeln('Reading side ',side,' track ',track,' sector ',sector);
    intr(19,machine);
    { now check the result in ah }
    returncode := machine.ah;

    if returncode = 9 then begin { DMA xfer across 64K boundary -- }
                                 { can switch to auxiliary buffer  }
        with machine do begin
            al := 1;  ah := 2;
            es := seg(otherbuffer);
            bx := ofs(otherbuffer);
        end;
        intr(19,machine);
        returncode := machine.ah;
        if returncode = 0 then { OK this time } begin
            move(otherbuffer,buffer,sizeof(sectbuffer));
            get1block := 0;
        end else get1block := returncode;
    end else
        get1block := returncode;

end; { get1block }


{ ----------- Read in the disk directory here -------------------- }

procedure readdir;

{ read the four blocks that make up the directory.  They are always
  at blocks 2,3,4,5 on the disk.   }

var count, result : integer;

begin
    for count := 0 to 3 do begin

        result := get1block(count+2, directory.bufs[count]);
        if result <> 0 then begin
            writeln('Sorry -- read error in getting directory.');
            halt;
        end;

    end;
end; { readdir }

{ ---------------  Process a file here --------------------------- }

procedure getfile(var entry : direntry);

var
    outfile : file of byte;
    newname : string[16];
    result, blockno, k : integer;

    { ------- Filter a page of a text file ---------- }
    procedure pageout(var p : pagebuffer);
    const
        DLE = 16;  CR = 13;  ZERO = 0;  LF = 10;  BLANK = 32;
    var cursor, nblanks : integer;
        nextc, extra : byte;
    begin
        cursor := 0;
        while cursor <= 1023 do begin

            nextc := p[cursor];  cursor := cursor + 1;
            case nextc of
                CR : begin
                         write(outfile,nextc);
                         extra := LF; write(outfile,extra);
                     end;
              ZERO : ; { don't write the zeroes that pad the page }
               DLE : begin { blank compression -- we expand it }
                           extra := BLANK;
                           nblanks := p[cursor] - 32; cursor := cursor + 1;
                           while nblanks > 0 do begin
                               write(outfile,extra);
                               nblanks := nblanks - 1;
                           end;
                       end;
                   else write(outfile,nextc);
            end;

        end;
    end; { pageout }


begin { GETFILE here }

    write('Please give a DOS file name -->');
    readln(newname);  assign(outfile,newname);
    {$I-} rewrite(outfile); {$I+}
    result := ioresult;
    if result <> 0 then begin
        writeln('Sorry -- cannot create the new file ',newname);
        halt;
    end;
    with entry do  { use the entry to get the file }
    if (filtype = 3 {text}) then begin

        writeln('Reading starts at ',firstblok + 2,' and goes for ',
            lastblok - firstblok - 2,' blocks.');
        blockno := firstblok + 2;
        while blockno <= lastblok - 1 do begin

            result := get1block(blockno,mainbuf);
            if result <> 0 then begin
                writeln('Sorry -- error reading the file.');
                halt;
            end;
            move(mainbuf,textpage,512);

            result := get1block(blockno + 1,mainbuf);
            if result <> 0 then begin
                writeln('Sorry -- error reading the file.');
                halt;
            end;
            move(mainbuf,textpage[512],512);

            blockno := blockno + 2;
            pageout(textpage);

        end;

    end else begin { not a text file }

        writeln('Reading starts at ',firstblok,' and goes for ',
            lastblok - firstblok,' blocks.');
        for blockno := firstblok to lastblok - 1 do begin

            result := get1block(blockno,mainbuf);
            if result <> 0 then begin
                writeln('Sorry -- error reading the file.');
                halt;
            end;
            if blockno < lastblok - 1 then
                for k := 0 to 511 do write(outfile,mainbuf[k])
            else
                for k := 0 to fillast do write(outfile,mainbuf[k]);

        end;  { for blockno }

    end;  { if text file }
    close(outfile);

end; { getfile }

{ ----------------------- MAIN PROGRAM -------------------- }
var k : integer;

begin

    writeln('Place a p-system disk in the right-hand drive,');
    writeln('then press enter.');  readln(kbd);

    readdir;
    writeln('Finished reading the directory.');

    for k := 1 to 77 do begin

        { Find out if this is a live file. }

        if length(directory.dir[k].filname) in [1..15] then begin

            writeln;  printentry(directory.dir[k]);
            if yes('Copy this file? (ESC to quit) ') then getfile(directory.dir[k]);

        end
    end
end.