//******************************************************************************
//*                                                                            *
//*    WRULTAPE              Write unlabelled tape, in a format to be sent to  *
//*                          other installations.  Text and binary files are   *
//*                          supported, and all data is written in FB (fixed   *
//*                          block) format, with the default LRECL being 80,   *
//*                          and the default BLKSIZE being (10*LRECL).         *
//*                                                                            *
//******************************************************************************
//*    I. D. Wilson          Last Modified   -   IDW   -   19/08/83            *
//******************************************************************************


SECTION "WRULTAPE"


GET "LIBHDR"
GET "IOHDR"
GET "MANHDR"
GET ":sys.tapeserver.bcpl.tapehdr-globals"
GET ":sys.tapeserver.bcpl.tapehdr-manifests"


GLOBAL
$(
    veclist      :  ug + 0
    filesstream  :  ug + 1
    sysout       :  ug + 2
    interactive  :  ug + 3
    mounted      :  ug + 4
    discstream   :  ug + 5
    writeco      :  ug + 6
    verstream    :  ug + 7
    binary       :  ug + 8
$)


MANIFEST
$(
    a.files      =  0
    a.lrecl      =  1
    a.blksize    =  2
    a.ver        =  3
    a.binary     =  4

    d.lrecl      =  80
    d.ratio      =  10

    c.eof        =  -1
    c.eot        =  -2
    
    NUL          =  0
$)


LET start()  BE
$(
//  Main routine of WRULTAPE.  It takes a file (by default the console),
//  from which it reads a list of files to be put on the tape.  It puts the
//  files on the tape sequentially, with a double tape mark at the end.

    LET args     =  "FILES,LRECL/K,BLKSIZE/K,VER/K,BINARY/S"
    LET argv     =  VEC 50
    LET files    =  0
    LET lrecl    =  0
    LET blksize  =  0
    LET ver      =  0
    LET recbuff  =  0
    LET seq      =  0

    veclist      :=  0
    filesstream  :=  0
    discstream   :=  0
    verstream    :=  0
    writeco      :=  0
    sysout       :=  output()
    mounted      :=  FALSE
    binary       :=  FALSE

    UNLESS  rdargs( args, argv, 50 )  DO
        error( "Bad arguments for string *"%S*"", args )

    files        :=  argv!a.files = 0  ->  "**", argv!a.files
    filesstream  :=  findinput( files )

    IF  filesstream = 0  THEN
        error( "Cannot open *"%S*"", files )

    ver          :=  argv!a.ver = 0  ->  "**", argv!a.ver
    verstream    :=  findoutput( ver )

    IF  verstream = 0  THEN
        error( "Cannot open *"%S*"", ver )

    lrecl    :=  argv!a.lrecl
    blksize  :=  argv!a.blksize
    binary   :=  argv!a.binary

    UNLESS  lrecl = 0    DO  lrecl    :=  convertnumber( lrecl )
    UNLESS  blksize = 0  DO  blksize  :=  convertnumber( blksize )

    //  If the default were taken, then we must fill in some numbers...

    IF  lrecl = 0    THEN  lrecl    :=  d.lrecl
    IF  blksize = 0  THEN  blksize  :=  lrecl * d.ratio

    //  BLKSIZE  must be >= than LRECL, and also a multiple of it.
    //  It must also be less than the maximum block size that can be
    //  written to tape.  It must also be even.

    IF  lrecl > blksize  THEN
        error( "LRECL is greater than BLKSIZE" )

    UNLESS  (blksize REM lrecl) = 0  DO
        error( "BLKSIZE is not a multiple of LRECL" )

    UNLESS  (blksize REM 2) = 0  DO
        error( "BLKSIZE is not even" )

    UNLESS  blksize < max.byte.blocksize  DO
        error( "BLKSIZE is too large" )

    //  We are now ready to start to read the files.  First try to mount the
    //  tape.  If the tape is not mountable, stay in a loop, waiting for it.

    selectoutput( verstream )

    writef( "WRULTAPE  Version 2.16*N*N*
            *Unlabelled tape written at 800 BPI, BLKSIZE=%N, LRECL=%N*N*N",
             blksize, lrecl )

    selectoutput( sysout )

    mounttape()

    rewindtape()

    //  Now, start taking input from the "files" stream.  If it is interactive,
    //  we must put out a prompt.

    recbuff  :=  gvec( lrecl / bytesperword )

    writeco  :=  createco( writeblocks, 500 )

    IF  writeco = 0  THEN
        error( "Cannot create the WRITE coroutine" )

    callco( writeco, blksize )
    callco( writeco, lrecl )

    interactive  :=  compstring( files, "**" )  =  0

    selectinput( filesstream )

    $(  //  Loop to start writing the tape.

        LET t.args  =  "FILE/A"
        LET t.argv  =  VEC 20
        LET file    =  0
        LET ch      =  0
        LET records =  0

        IF  interactive  THEN  writes( "# *E" )

        ch  :=  rdch()  REPEATWHILE  ch = '*S'  |  ch = '*T'

        IF  ch = endstreamch  THEN  BREAK
        IF  ch = '*N'         THEN  LOOP

        unrdch()

        UNLESS  rdargs( t.args, t.argv, 20 )  DO
        $(
            writef( "****** Bad arguments for *"%S*"*N", t.args )

            LOOP
        $)

        file        :=  t.argv!0
        discstream  :=  findinput( file )

        IF  discstream = 0  THEN
        $(
            writef( "****** Cannot open *"%S*"*N", file )

            LOOP
        $)

        //  Now read the file from disc, and record it onto tape.

        selectinput( discstream )
        selectoutput( verstream )

        seq  :=  seq + 1

        WHILE  readrec( recbuff, lrecl )  DO
        $(
            records  :=  records + 1

            callco( writeco, recbuff )
        $)

        endread()

        discstream  :=  0

        callco( writeco, c.eof )

        writef( "%I3  %TZ  (Records: %N)*N", seq, file, records )
        selectoutput( sysout )

        selectinput( filesstream )
    $)
    REPEAT

    callco( writeco, c.eot )

    //  Now tidy up after us.

    deleteco( writeco )
    writeco  :=  0

    endstream( filesstream )
    endstream( verstream )

    filesstream  :=  0
    verstream    :=  0

    fvec( recbuff )

    rewindtape()
    dismounttape()

    mounted  :=  FALSE

    writes( "*N****** Dismount tape from drive*N" )

    fvectors()
$)



AND writeblocks( blksize )  BE
$(
//  Coroutine to handle the writing of tape blocks.

    LET lrecl         =  cowait()
    LET tape.blksize  =  blksize / bytespertapeword
    LET word.blksize  =  blksize / bytesperword
    LET block         =  gvec( word.blksize )
    LET offset        =  0

    $(  //  Loop to read take records from the input file, and write them to
        //  tape.  When an EOF indicator comes, write a tape mark.

        LET command  =  cowait()

        TEST  command = c.eot  THEN  BREAK
        ELSE

        TEST  command = c.eof  THEN
        $(
            //  Is there anything in the block buffer to write out ?

            UNLESS  offset = 0  DO
                writetapeblock( block, offset / bytespertapeword )

            writetapemark()

            offset  :=  0
        $)
        ELSE
        $(
            FOR  i = 0  TO  lrecl-1  DO
                block % (offset + i)  :=  command % i

            offset  :=  (offset + lrecl) REM blksize

            IF  offset = 0  THEN  writetapeblock( block, tape.blksize )
        $)
    $)
    REPEAT

    //  At end of tape, we write a double tape mark.

    writetapemark()
    writetapemark()

    fvec( block )
$)



AND readrec( buffer, size )  =  binary  ->  binreadrec( buffer, size ),  VALOF
$(
//  Read a text record from disc into the buffer, and pad the rest with
//  spaces.  If we come across binary, then we complain, and return end
//  of file.  Overlong records are split.

    LET length  = 0
    LET ch      =  rdch()

    IF  ch = endstreamch  THEN  RESULTIS  FALSE

    UNTIL  ch = '*N'  |  ch = endstreamch  |  length = size  DO
    $(
        //  Check to see whether the character is a bona-fide bog-standard
        //  ASCII character.

        IF  badch( ch )  THEN
        $(
            writef( "****** Illegal non-text character #X%X2  -  file abandoned*N", ch )

            RESULTIS  FALSE
        $)

        buffer % length  :=  ch
        length           :=  length + 1
        ch               :=  rdch()
    $)

    IF  length = size  &  ch \= '*N'  THEN
    $(
        //  This character is not a terminator, and should not be ingored.

        unrdch()

        writes( "****** Overlong input record  -  split*N" )
    $)

    FOR  i = length  TO  size-1  DO  buffer % i  :=  '*S'

    RESULTIS  TRUE
$)




AND badch( ch )  =  VALOF
$(
//  Returns true if the character is not a printable  member of the ascii
//  character set.

    LET c  =  ch & #X7F
    LET w  =  ch >> 4
    LET b  =  ch & #X0F

    LET t  =  TABLE   #B0011111110000000,  // SI  to NUL
                      #B0000100000000000,  // DLE to US
                      #B1111111111111111,  // /   to SP
                      #B1111111111111111,  // ?   to 0
                      #B1111111111111111,  // O   to @
                      #B1111111111111111,  // _   to P
                      #B1111111111111111,  // o   to `
                      #B0111111111111111   // DEL to p

    RESULTIS  (((t!w >> b) & 1) = 0)   |   (ch \= c)
$)



AND binreadrec( buffer, size )  =  VALOF
$(
//  Read a record in binary from the input stream, and return it to the
//  caller.  If we have to return a partial record, then pad with NULs.

    LET ch      =  rdch()
    LET length  =  0

    IF  ch = endstreamch  THEN  RESULTIS  FALSE

    UNTIL  ch = endstreamch  |  length = size  DO
    $(
        buffer % length  :=  ch
        length           :=  length + 1
        ch               :=  rdch()
    $)

    //  We have now read one too many characters, and so we should stuff the
    //  extra one back up the input stream.

    unrdch()

    UNTIL  length = size  DO
    $(
        buffer % length  :=  NUL
        length           :=  length + 1
    $)
    
    RESULTIS  TRUE
$)



AND convertnumber( string )  =  VALOF
$(
    LET number  =  0

    FOR  i = 1  TO  string % 0  DO
    $(
        LET ch  =  string % i

        UNLESS  '0' <= ch <= '9'  DO
            error( "Bad numeric character *"%C*" in *"%S*"", ch, string )

        number  :=  number * 10  +  ch  -  '0'
    $)

    RESULTIS  number
$)



AND error( format, arg1, arg2, arg3 )  BE
$(
    writes( "****** WRULTAPE Error:  " )
    writef( format, arg1, arg2, arg3 )
    newline()

    UNLESS  filesstream = 0  DO  endstream( filesstream )
    UNLESS  discstream  = 0  DO  endstream( discstream )
    UNLESS  verstream   = 0  DO  endstream( verstream )
    UNLESS  writeco     = 0  DO  deleteco( writeco )

    IF  mounted  THEN  tape.dismount()

    fvectors()

    stop( 20 )
$)



AND mounttape()  BE
$(
    LET tape.error  =  error.noerror
    LET ready       =  FALSE

    UNTIL  tape.mount()  DO
    $(
        LET mount.error  =  result2

        UNLESS  mount.error = tape.error  DO
        $(
            tape.error  :=  mount.error
            writes( "****** Waiting for tape drive:  " )
            fault( tape.error )
        $)

        delay( tickspersecond )

        IF  testflags( #B0001 )  THEN  error( "BREAK" )
    $)

    mounted  :=  TRUE

    UNLESS  tape.error = error.noerror DO
        writes( "****** Tape drive claimed*N*N" )

    //  Now wait for the drive to be ready.

    ready  :=  (tape.status()  &  status.ready) \= 0

    UNLESS  ready  DO
    $(
        writes( "****** Waiting  -  drive is not ready*N" )

        UNTIL  ready  DO
        $(
            ready  :=  (tape.status()  &  status.ready) \= 0

            IF  testflags( #B0001 )  THEN  error( "BREAK" )

            delay( tickspersecond )
        $)

        writes( "****** Drive now ready*N*N" )
    $)

    //  Check to see that the tape is not write protected...

    IF  (tape.status() & status.wrprotect) \= 0  THEN
        error( "Tape is write protected" )
$)



AND rewindtape()  BE
    UNLESS  tape.rewind()  DO
        writef( "****** Failed to rewind tape (Rc %N)*N", result2 )



AND dismounttape()  BE
    UNLESS  tape.dismount()  DO
        writef( "****** Failed to dismount tape (Rc %N)*N", result2 )



AND writetapeblock( buffer, size )  BE
    UNLESS  tape.write( buffer, size )  DO
        writef( "****** Failed to write block to tape (Rc %N)*N", result2 )



AND writetapemark()  BE
    UNLESS  tape.writeeof()  DO
        writef( "****** Failed to write tape mark (Rc %N)*N", result2 )



AND gvec( vecsize )  =  VALOF
$(
//  Add a new vector to the list of those "got" already.

    LET node   =  getvec( 2 )
    LET space  =  getvec( vecsize )

    TEST  node = 0  |  space = 0  THEN
    $(
        //  Cannot get either the main space, or the node space.
        //  Free whichever one was successful, and flag an error.

        UNLESS  node   = 0  DO  freevec( node )
        UNLESS  space  = 0  DO  freevec( space )

        error( "Cannot get vector of size %U5", vecsize )
    $)
    ELSE
    $(
        //  We have got the vector successfully, so add it to the
        //  chain of allocated vectors.

        node!0  :=  veclist
        node!1  :=  space
        veclist :=  node

        RESULTIS  space
    $)
$)



AND fvec( vector )  BE
$(
//  Free the vector pointed to by "vector".  Look in the allocated space chain
//  to find this vector, and when found, de-allocate the space.

    LET node  =  veclist
    LET ptr   =  @veclist

    UNTIL  node = 0  DO
    $(
        IF  node!1 = vector  THEN
        $(
            //  We have found the vector to deallocate.  Remove this node from
            //  the list, and deallocate the space involved.

            !ptr   :=  node!0

             freevec( vector )
             freevec( node )

             RETURN
        $)

        ptr   :=  node
        node  :=  node!0
    $)

    error( "Cannot free vector %N", vector )
$)



AND fvectors()  BE
$(
//  Free all the vectors pointed to by the list "veclist".

    UNTIL veclist = 0  DO
    $(
        LET nlist  =  veclist!0
        LET space  =  veclist!1

        freevec( space )
        freevec( veclist  )

        veclist  :=  nlist
    $)
$)


