home *** CD-ROM | disk | FTP | other *** search
/ Columbia Kermit / kermit.zip / archives / sinclairqlb.zip / ql2mai.bcp < prev    next >
Text File  |  1988-08-16  |  31KB  |  1,066 lines
  1. // This is file QL2MAI.BCP
  2. //
  3. // To be renamed FLP2_KERMAIN_BCPL for QDOS
  4. SECTION "Main"
  5.  
  6. /*********************************************************************
  7.  
  8.       KK    KK  EEEEEEEE  RRRRRRR   MM    MM  IIIIIIII  TTTTTTTT
  9.       KK   KK   EEEEEEEE  RRRRRRRR  MMM  MMM  IIIIIIII  TTTTTTTT
  10.       KK  KK    EE        RR    RR  MMMMMMMM     II        TT
  11.       KKKK      EEEEEE    RRRRRRRR  MM MM MM     II        TT
  12.       KK KK     EE        RRRRRRR   MM    MM     II        TT
  13.       KK  KK    EE        RR  RR    MM    MM     II        TT
  14.       KK   KK   EEEEEEEE  RR   RR   MM    MM  IIIIIIII     TT
  15.       KK    KK  EEEEEEEE  RR    RR  MM    MM  IIIIIIII     TT
  16.  
  17. *********************************************************************/
  18.  
  19. GET "LIBHDR"
  20. GET "FLP2_KERHDR"
  21.  
  22. /*
  23.    This is QL KERMIT
  24.    by David Harper
  25.  
  26.    Dept of Applied Maths and Theoretical Physics
  27.    University of Liverpool
  28.  
  29.  
  30.    It is based upon the BCPL implementation written for the Tripos operating
  31.    system by C.G. Selwyn at Bath University in 1984.  I have replaced the
  32.    finite-state automaton command parser by my own version which allows extra
  33.    commands/options to be added to the program quite easily.
  34.  
  35.  
  36.    S T A R T    of   QL   K E R M I T
  37.  
  38.     Initialise and call the handle routine to execute
  39.     the current command input stream
  40. */
  41.  
  42. LET start() BE
  43. $( LET rp = VEC 100/bytesperword
  44.    LET pk = VEC 100/bytesperword
  45.    LET avec = VEC argvl
  46.    LET c = VEC 80/bytesperword
  47.    LET tvec = VEC 1
  48.    LET setname = VEC 40
  49.    LET parser.buffer = VEC 40
  50.    LET main.command.table = VEC 20
  51.    LET set.command.table = VEC 40
  52.    LET set.command.functions = VEC 40
  53.    LET rs232.name = VEC 2
  54. //
  55.    sys.abort := abort            // save ABORT routine address
  56.    abort := kermit.abort         // make BCPL abort through our routine
  57.    ser.name := rs232.name
  58.    starttime := tvec
  59.    finishtime := tvec+1
  60.    cbuf := c
  61.    argv := avec
  62.    parse.buf := parser.buffer
  63.    main.com.table := main.command.table
  64.    set.com.table := set.command.table
  65.    set.function.table := set.command.functions
  66.    pakcnt := 0
  67.    reclevel := 0
  68.    erroring := FALSE
  69.    qcon.init := FALSE
  70. //
  71.    console := open("CON_480x220a26x10_128",0,0)
  72.    currentin := console
  73.    selectinput(console)
  74.    selectoutput(console)
  75.    finishtime!0 := -1
  76.    filecnt := 0
  77.    recpkt := rp
  78.    packet := pk
  79.    fd := 0        // No file open
  80.    remfd := 0     // No serial line open yet
  81.    debug.fd := console   // send debugging output to the screen initially
  82. //
  83.    escchr := brkchr
  84.    remote.delay := 5
  85.    image := FALSE
  86.    quote8ing := FALSE
  87.    quote8 := myquote8
  88.    maxpack := 92
  89.    maxtry  := 5
  90.    reporting := TRUE
  91. //
  92.    s.eol := cr
  93.    s.packet.length := maxpack
  94.    s.quote := myquote
  95.    s.pad := 0
  96.    s.padchar := null
  97.    s.sop := soh
  98.    s.timeout := 5
  99. //
  100.    r.eol := myeol
  101.    r.packet.length := maxpack
  102.    r.quote := myquote
  103.    r.pad := mypad
  104.    r.padchar := mypchar
  105.    r.sop := soh
  106.    r.timeout := 5
  107. //
  108.    local := TRUE
  109.    remote := \local
  110.    serving := FALSE
  111.    debug := FALSE
  112.    take.echo := FALSE
  113.    ser.duplex := 'F'
  114.    ser.escape := kbd.esc
  115.    ser.handshake := 'I'
  116.    ser.parity := 'E'
  117.    ser.pause := 0
  118.    ser.line := '2'
  119.    ser.baud := 4800
  120.    ser.corrupt := FALSE
  121. //
  122.    change.my.priority(64)
  123. //
  124.    screen(screen.clear)
  125.    writef("QL Kermit - Version %N.%N*N",version,update)
  126.    initialise()
  127. //
  128.    handle()
  129. //
  130.    end.kermit()
  131. $)
  132.  
  133. /*
  134.    H A N D L E
  135.  
  136.     This routine handles the parsing and actioning of the
  137.     current command input stream.
  138.     Take commands are a recursive call to handle().
  139. */
  140.  
  141. AND handle() BE
  142. $( LET nch = 0
  143.    filecnt := 0
  144.    erroring := FALSE
  145.    selectinput(currentin)
  146.    selectoutput(console)
  147.    IF currentin = console THEN
  148.       writef("*NQL-Kermit (%S) > ",remote->"Remote","Local")
  149.    command := -1
  150.    nch := readcommand(cbuf)
  151.    IF nch<=0 THEN
  152.    $(  TEST reclevel=0 THEN  LOOP           // Nothing to process
  153.                        ELSE  RETURN         // End of TAKE file
  154.    $)
  155.    IF reclevel>0 & take.echo DO $( writes(cbuf) ; newline() $)
  156.    nwords := parse.line(cbuf,argv) + 1
  157.    TEST do.parse(argv!0,main.com.table) THEN
  158.    $(
  159.       SWITCHON command INTO
  160.       $(
  161.       CASE w.set :
  162.          do.set()
  163.          ENDCASE
  164.  
  165.       CASE w.show :
  166.          do.show()
  167.          ENDCASE
  168.  
  169.       CASE w.c :
  170.          IF reclevel \= 0 THEN
  171.          $( writes("Can't connect from take file*N")
  172.             erroring := TRUE
  173.             ENDCASE
  174.          $)
  175.          IF remote THEN
  176.          $( writes("Can't connect if remote*N")
  177.             erroring := TRUE
  178.             ENDCASE
  179.          $)
  180.          connect()
  181.          ENDCASE
  182.  
  183.       CASE w.disconn :
  184.          TEST remfd \= 0 THEN
  185.          $(  erroring := \disconnect()
  186.              UNLESS erroring DO remfd := 0
  187.          $)
  188.          ELSE
  189.          $(  writes("*N No serial line open yet *N")
  190.              erroring := TRUE
  191.          $)
  192.          ENDCASE
  193.  
  194.       CASE w.s :
  195.       CASE w.r :
  196.          handle.sr()
  197.          ENDCASE
  198.  
  199.       CASE w.get :
  200.          TEST local THEN do.get()
  201.          ELSE
  202.             writes("Can't perform get if remote*N")
  203.          ENDCASE
  204.  
  205.       CASE w.close :
  206.          IF reclevel \= 0 THEN RETURN     // If executing file
  207.       CASE w.e :                          // Otherwise treat as end command
  208.          BREAK
  209.  
  210.       CASE w.help :
  211.          TEST nwords=1 THEN show.help()
  212.          ELSE IF strcomp(argv!1,"SET") THEN show.set()
  213.          ENDCASE
  214.  
  215.       CASE w.server :
  216.          TEST remfd\=0 THEN
  217.             TEST serve() THEN BREAK
  218.             ELSE ENDCASE
  219.          ELSE
  220.          $( erroring := TRUE
  221.             writes("No serial line open yet - can't serve*N") $)
  222. //       writes("Server mode not yet implemented*N")
  223.          ENDCASE
  224.  
  225.       CASE w.finish :
  226.          TEST local THEN
  227.          $(A
  228.             remote.finish()
  229.             selectinput(currentin)
  230.             selectoutput(console)
  231.          $)A
  232.          ELSE
  233.          $( erroring := TRUE
  234.             writes("Can't issue finish if remote*N") $)
  235.          ENDCASE
  236.  
  237.       CASE w.take :
  238.          $( LET newin = findinput(argv!1)
  239.             LET oldin = currentin
  240.             IF newin < 0 THEN
  241.             $( writef("Can't find file %S*N",argv!1)
  242.                erroring := TRUE
  243.                ENDCASE
  244.             $)
  245.             currentin := newin
  246.             reclevel := reclevel+1
  247.             writef(" TAKEing from file %S*N",argv!1)
  248.             handle()
  249.             reclevel := reclevel-1
  250.             selectinput(currentin)
  251.             endread()
  252.             currentin := oldin
  253.             ENDCASE
  254.          $)
  255.       $)
  256.    $)
  257.    ELSE
  258.    $( erroring := TRUE
  259.       writes("Bad command*N")
  260.    $)
  261.    IF erroring & (reclevel \= 0) THEN RETURN
  262. $) REPEAT
  263.  
  264. /*
  265.    s e r v e r
  266.  
  267.    Loop collecting commands from the other end
  268.    and executing them
  269. */
  270. AND serve() = VALOF
  271. $( LET num,len = ?,?
  272.    LET r = ?
  273.    AND local.file.name = VEC 8
  274.    AND closed.file = FALSE
  275.  
  276.    readchar := (ser.interface=interface.qconnect -> qcon.rdch,raw.rdch)
  277.    local.fname := local.file.name
  278.    n := 0
  279.    serving := TRUE
  280.  
  281.    $( numfiles := 1
  282.       filecnt := 0
  283.       SWITCHON rpack(@len,@num,recpkt) INTO
  284.       $(
  285.       CASE 'I' :
  286.          spack('Y',num,0,0)
  287.          ENDCASE
  288.  
  289.       CASE 'S' :
  290.          rpar(recpkt,len)
  291.          len := spar(packet)
  292.          report(TRUE)
  293.          spack('Y',num,len,packet)
  294.          oldtry := numtry
  295.          numtry := 0
  296.          n := (n+1) REM 64
  297.          datstamp(starttime)
  298.  
  299.          TEST recsw() THEN
  300.             datstamp(finishtime)
  301.          ELSE finishtime!0 := -1
  302.          ENDCASE
  303.  
  304.       CASE 'R' :
  305.          FOR i=0 TO len-1 DO local.fname%(i+1) := recpkt%i
  306.          local.fname%0 := len
  307.          bytes := 0
  308.  
  309.          TEST sendsw() THEN
  310.             datstamp(finishtime)
  311.          ELSE finishtime!0 := -1
  312.          ENDCASE
  313.  
  314.       CASE 'G' :                          // Generic commands
  315.          SWITCHON recpkt%0 INTO
  316.          $(
  317.          CASE 'F' :                       // Finish
  318.             FOR i = 1 TO 4 DO packet%(i-1) := "OK.*N"%i
  319.             spack('Y',num,4,packet)
  320.             r := FALSE                    // Don't exit
  321.             BREAK
  322.          CASE 'L' :                       // Logout
  323.             FOR i = 1 TO 4 DO packet%(i-1) := "OK.*N"%i
  324.             spack('Y',num,4,packet)
  325.             r := TRUE                     // Exit
  326.             BREAK
  327.          $)
  328.  
  329.       DEFAULT :
  330.       CASE FALSE :
  331.          ENDCASE
  332.       $)
  333.  
  334.       IF fd \= 0 THEN
  335.       $( closed.file := close(fd)
  336.          UNLESS closed.file=0 DO
  337.            $( selectoutput(console)
  338.               writes("*N*NFailed to close file at end of serving.*N")
  339.               writef("Error code is %N*N",closed.file)
  340.            $)
  341.          fd := 0
  342.       $)
  343.  
  344.    $) REPEAT
  345.    serving := FALSE
  346.    RESULTIS r
  347. $)
  348. AND remote.finish() = VALOF
  349. $( LET num,len = ?,?
  350.    IF remfd=0 THEN
  351.    $(1
  352.      WRITES("No serial line open yet*N")
  353.      RESULTIS FALSE
  354.    $)1
  355.  
  356.    numtry := 0
  357.    n := 0
  358.    packet%0 := 'F'
  359.    $( spack('G',0,1,packet)
  360.       SWITCHON rpack(@len,@num,recpkt) INTO
  361.       $(
  362.       CASE 'Y' :
  363.          IF len \= 0 THEN message(recpkt,len)
  364.          RESULTIS TRUE
  365.       CASE 'N' :
  366.       CASE FALSE :
  367.          numtry := numtry+1
  368.          IF numtry >= maxtry THEN RESULTIS FALSE
  369.          ENDCASE
  370.       DEFAULT :
  371.          erroring := TRUE
  372.          RESULTIS FALSE
  373.       $)
  374.    $) REPEAT
  375. $)
  376.  
  377. AND show.help() BE
  378. $( writes("CONNECT                        - Connect*N")
  379.    writes("EXIT                           - Exit*N")
  380.    writes("FINISH                         - Finish server mode on a *
  381.                                            *remote kermit*N")
  382.    writes("GET remote-fname local-fname   - Get file from a server*N")
  383.    writes("HELP                           - This message*N")
  384.    writes("RECEIVE local-fname            - Receive file*N")
  385.    writes("SEND local-fname remote-fname  - Send file*N")
  386.    writes("SET parameter value            - Set various options*N")
  387.    writes("SERVER                         - Set server mode*N")
  388.   writes("SHOW                           - Show the settable option settings*N"
  389.    writes("TAKE local-fname               - Take commands from a file*N")
  390.    writes("END                            - End of command stream*N")
  391.    writes("DISCONN                        - Forcibly close serial line*N")
  392. $)
  393.  
  394. /*
  395.    Do.show
  396.  
  397.       Show a selection of currently set parameters etc.
  398. */
  399.  
  400. AND do.show() BE $(0
  401.   LET option = 0
  402. //
  403.   screen(screen.clear)
  404.   writes("  Settable options*N*N")
  405.   writef(" DEBUGGING                   : %S*N",(debug -> "ON","OFF"))
  406.   writef(" DELAY                       : %N seconds*N",remote.delay)
  407.   writef(" DUPLEX                      : %S*N",
  408.          (ser.duplex='F' -> "FULL","HALF"))
  409.   writef(" 8BIT-PREFIX                 : %S*N",(quote8ing -> "ON","OFF"))
  410.   writef(" END-OF-LINE                 : %S*N",
  411.          (r.eol=cr -> "CR","LF"))
  412.   newline()
  413.   //
  414.   SWITCHON ser.escape INTO
  415.   $(2 // determine terminal escape character
  416.     CASE kbd.f1 : option := "F1" ; ENDCASE
  417.     CASE kbd.f2 : option := "F2" ; ENDCASE
  418.     CASE kbd.f3 : option := "F3" ; ENDCASE
  419.     CASE kbd.f4 : option := "F4" ; ENDCASE
  420.     CASE kbd.f5 : option := "F5" ; ENDCASE
  421.  
  422.     CASE kbd.esc : option := "ESC" ; ENDCASE
  423.     CASE kbd.ctrl.esc : option := "CTRL-ESC" ; ENDCASE
  424.   $)2
  425.   writef(" ESCAPE-CHAR                 : %S*N",option)
  426.   SWITCHON ser.handshake INTO
  427.   $(3 // determine handshaking mode
  428.     CASE 'H' : option := "CTS/RTS" ; ENDCASE
  429.     CASE 'X' : option := "XON/XOFF" ; ENDCASE
  430.     CASE 'I' : option := "NONE" ; ENDCASE
  431.   $)3
  432.   writef(" HANDSHAKE                   : %S*N",option)
  433.   writef(" MARKER (start of packet)    : #X%X2*N",r.sop)
  434.   writef(" PACKET-LENGTH               : %N*N",r.packet.length)
  435.   writef(" TAKE-ECHO                   : %S*N*N",
  436.           (take.echo -> "ON","OFF"))
  437.   IF reclevel=0 THEN
  438.   $(B
  439.     writes("*N*N (Hit any key for next page)")
  440.     option := rdch()
  441.     //
  442.     screen(screen.clear)
  443.   $)B
  444.   newline()
  445.   writef(" PADDING (amount)            : %N*N",r.pad)
  446.   writef(" PAD-CHAR                    : #X%X2*N",r.padchar)
  447.   SWITCHON ser.parity INTO
  448.   $(4 // determine parity
  449.     CASE 'E' : option := "EVEN" ; ENDCASE
  450.     CASE 'O' : option := "ODD"  ; ENDCASE
  451.     CASE 'M' : option := "MARK" ; ENDCASE
  452.     CASE 'S' : option := "SPACE" ; ENDCASE
  453.     CASE 'N' : option := "NONE" ; ENDCASE
  454.   $)4
  455.   writef(" PARITY                      : %S*N",option)
  456.   writef(" PAUSE                       : %N seconds*N",ser.pause)
  457.   writef(" PREFIX character            : %C*N",quote8)
  458.   writef(" RETRY limit                 : %N*N",maxtry)
  459.   newline()
  460.   writef(" TIMEOUT                     : %N seconds*N",r.timeout)
  461.   writef(" LINE                        : SER%C*N",ser.line)
  462.   writef(" BAUD                        : %N*N",ser.baud)
  463.   writef(" INTERFACE hardware          : %S*N",
  464.           (ser.interface=interface.qconnect -> "QConnect","None"))
  465.   newline()
  466.   writef(" Serial line is currently    : %S ",
  467.           (remfd=0 -> "CLOSED","OPEN"))
  468.   TEST remfd=0 THEN newline()
  469.                ELSE writef(" as %S*N",ser.name)
  470. $)0
  471. /*
  472.    Handle the get command
  473. */
  474. AND do.get() = VALOF
  475. $( LET r = ?
  476.    LET len,num = ?,?
  477.  
  478.    IF remfd=0 THEN
  479.    $( WRITES("No serial line open yet*N")
  480.       RESULTIS FALSE
  481.    $)
  482.    bytes := 0
  483.    numtry := 0
  484.  
  485.    IF nwords<3 THEN
  486.    $(1  WRITES("Command incomplete *N")
  487.         RESULTIS FALSE
  488.    $)1
  489.    local.fname := argv!2
  490.    filnam := argv!1
  491.       FOR j = 0 TO filnam%0 -1 DO  packet%j := filnam%(j+1)
  492.       spack('R',n,filnam%0,packet)
  493.       r := recsw()
  494.       UNLESS r THEN
  495.       $( finishtime!0 := -1
  496.          selectoutput(console)
  497.          writef("Unable to receive %S*N",filnam)
  498.          RESULTIS FALSE
  499.       $)
  500.    selectoutput(console)
  501.    datstamp(finishtime)
  502.    writes("*NOK.*N")
  503.    RESULTIS TRUE
  504. $)
  505.  
  506. /*
  507.    Handle a Send/Receive command
  508.  
  509. */
  510. AND handle.sr() = VALOF
  511. $( LET r = ?
  512.  
  513.    IF remfd=0 THEN
  514.    $( WRITES("No serial line open yet*N")
  515.       RESULTIS FALSE
  516.    $)
  517.  
  518.    bytes := 0
  519.  
  520.    TEST command = w.s THEN
  521.    $(
  522.       IF nwords<3 THEN $(  WRITES("Command incomplete *N")
  523.                            RESULTIS FALSE
  524.                        $)
  525.       filnam := argv!2
  526.       local.fname := argv!1
  527.       r := sendsw()
  528.    $)
  529.    ELSE
  530.    $(
  531.       IF nwords<2 THEN $(  WRITES("Command incomplete *N")
  532.                            RESULTIS FALSE
  533.                        $)
  534.       local.fname := argv!1
  535.       r := recsw()
  536.    $)
  537.  
  538.    selectoutput(console)
  539.    TEST r THEN
  540.    $( datstamp(finishtime)
  541.       IF \remote THEN writef("*NOK.*N")
  542.    $)
  543.    ELSE
  544.    $( IF \remote THEN
  545.          writef("%S failed.*N",command=w.s->"Send","Receive")
  546.       finishtime!0 := -1
  547.    $)
  548.    IF fd \= 0 THEN
  549.    $( close(fd)
  550.       fd := 0
  551.    $)
  552.    RESULTIS FALSE
  553. $)
  554.  
  555. /*       The following functions  are used in the parsing of the command
  556.          line and the identification of words therein.
  557.  
  558.   PARSE.LINE(line,words) :  separates the string 'line' into words  i.e.
  559.                             items delimited by spaces. The vector 'words'
  560.                             is set to point to the items found : words!0
  561.                             points to a string containing the first word
  562.                             in the line, words!1 to the second, etc.
  563.  
  564.                             The value returned is the highest element of
  565.                             'words' referred to, and is thus one less than
  566.                             the number of words found.
  567.  
  568.                             The routine makes use of a vector referred to via
  569.                             the global parse.buf and stores the parsed words
  570.                             in that vector.
  571. */
  572. AND parse.line(line,words) = VALOF $(0
  573. LET ch,kwords,lch,thisword = 0,-1,0,0
  574. AND linelength = 0
  575. linelength := getbyte(line,0)
  576. thisword := parse.buf
  577. FOR K=1 TO linelength DO
  578. $(1 // One character at a time
  579.   ch := getbyte(line,K)
  580.   IF ch \= SP THEN
  581.   $(2 // Copy the character
  582.     lch := lch + 1
  583.     putbyte(thisword,lch,ch)
  584.   $)2
  585.   //
  586.   // Test for the end of a word
  587.   //
  588.   IF ((ch = SP) & (lch \= 0)) | ((ch \= SP) & (K = linelength)) THEN
  589.   $(3 // Found the end of a word
  590.     putbyte(thisword,0,lch)
  591.     kwords := kwords + 1
  592.     words!kwords := thisword
  593.     thisword := thisword + 1 + lch/4
  594.     lch := 0
  595.   $)3
  596. $)1
  597. RESULTIS kwords
  598. $)0
  599. //
  600. //  strcomp compares two strings for equality
  601. //
  602. AND strcomp(string1,string2) = VALOF $(0
  603. LET length1,length2 = getbyte(string1,0),getbyte(string2,0)
  604. AND equality,nch = TRUE,0
  605. TEST length1=length2 THEN
  606. $(1 // Strings are of the same length so compare them byte by byte
  607.   nch := nch + 1
  608.   equality := (getbyte(string1,nch) = getbyte(string2,nch))
  609. $)1 REPEATUNTIL ((NOT equality) | (nch = length1))
  610. ELSE
  611. $(2 // Strings are of different lengths and so must be different
  612.   equality := FALSE
  613. $)2
  614. RESULTIS equality
  615. $)0
  616.  
  617. /*
  618.          DO.PARSE(aword,table) : locates the word 'aword' in the parse-table
  619.                                  'table'.  If the word is found, the result
  620.                                  is TRUE and the global 'command' is set to
  621.                                  the position of the word in the table ;
  622.                                  otherwise the result id FALSE and 'command'
  623.                                  set to -1.
  624. */
  625. AND do.parse(aword,wtable) = VALOF $(0
  626.   LET k,kwords = 1,0
  627.   LET found = FALSE
  628.   kwords := wtable!0          // The number of words in this table
  629.   $(1 // Compare each word in turn
  630.     found := strcomp(aword,wtable!k)
  631.     k := k + 1
  632.   $)1 REPEATUNTIL found | (k > kwords)
  633.   command := (found ->  k-1,-1)
  634.   RESULTIS found
  635. $)0
  636.  
  637. //       initialise() : sets up the command tables
  638.  
  639. AND initialise() BE $(0
  640. //
  641. // Set up the main command table first
  642. //
  643. main.com.table!0            :=  w.num.commands      // Number of commands
  644. //
  645. main.com.table!w.s          := "SEND"
  646. main.com.table!w.r          := "RECEIVE"
  647. main.com.table!w.c          := "CONNECT"
  648. main.com.table!w.e          := "EXIT"
  649. main.com.table!w.help       := "HELP"
  650. main.com.table!w.set        := "SET"
  651. main.com.table!w.show       := "SHOW"
  652. main.com.table!w.server     := "SERVER"
  653. main.com.table!w.finish     := "FINISH"
  654. main.com.table!w.get        := "GET"
  655. main.com.table!w.take       := "TAKE"
  656. main.com.table!w.close      := "END"
  657. main.com.table!w.disconn    := "DISCONN"
  658. //
  659. //  Now set up the SET command table
  660. //
  661. set.com.table!0             :=  ws.num.commands    // The number of settable
  662.                                                    //  options
  663. //
  664.    set.com.table!ws.bchk         :=  "BLOCK-CHECK"    //Not implemented yet
  665.    set.com.table!ws.debug        :=  "DEBUG"
  666.    set.com.table!ws.delay        :=  "DELAY"
  667.    set.com.table!ws.duplex       :=  "DUPLEX"
  668.    set.com.table!ws.8bitpfx      :=  "8BIT-PREFIX"
  669.    set.com.table!ws.eol          :=  "END-OF-LINE"
  670.    set.com.table!ws.escchar      :=  "ESCAPE-CHAR"
  671.    set.com.table!ws.flowcon      :=  "FLOW-CONTROL"   //Not implemented yet
  672.    set.com.table!ws.handshake    :=  "HANDSHAKE"
  673.    set.com.table!ws.log          :=  "LOG"            //Not implemented yet
  674.    set.com.table!ws.marker       :=  "MARKER"
  675.    set.com.table!ws.packetlength :=  "PACKET-LENGTH"
  676.    set.com.table!ws.padding      :=  "PADDING"
  677.    set.com.table!ws.parity       :=  "PARITY"
  678.    set.com.table!ws.pause        :=  "PAUSE"
  679.    set.com.table!ws.prefix       :=  "PREFIX"
  680.    set.com.table!ws.repeatcount  :=  "REPEAT-COUNT"   //Not implemented yet
  681.    set.com.table!ws.retry        :=  "RETRY"
  682.    set.com.table!ws.timeout      :=  "TIMEOUT"
  683.    set.com.table!ws.line         :=  "LINE"
  684.    set.com.table!ws.dir          :=  "DIR"            //Not implemented yet
  685.    set.com.table!ws.overwrite    :=  "OVERWRITE"      //Not implemented yet
  686.    set.com.table!ws.baud         :=  "BAUD"
  687.    set.com.table!ws.termtype     :=  "TERMINAL-TYPE"  //Not implemented yet
  688.    set.com.table!ws.interface    :=  "INTERFACE"
  689.    set.com.table!ws.padchar      :=  "PAD-CHAR"
  690.    set.com.table!ws.take.echo    :=  "TAKE-ECHO"
  691.  
  692. // Set up the set-function table (see "KERSET" for details)
  693.  
  694.    set.function.table!ws.bchk         :=  not.yet.implemented
  695.    set.function.table!ws.debug        :=  set.debug
  696.    set.function.table!ws.delay        :=  set.delay
  697.    set.function.table!ws.duplex       :=  set.duplex
  698.    set.function.table!ws.8bitpfx      :=  set.8bitprefixing
  699.    set.function.table!ws.eol          :=  set.eol
  700.    set.function.table!ws.escchar      :=  set.terminal.escape
  701.    set.function.table!ws.flowcon      :=  not.yet.implemented
  702.    set.function.table!ws.handshake    :=  set.handshake
  703.    set.function.table!ws.log          :=  not.yet.implemented
  704.    set.function.table!ws.marker       :=  set.marker
  705.    set.function.table!ws.packetlength :=  set.packetlength
  706.    set.function.table!ws.padding      :=  set.padding
  707.    set.function.table!ws.parity       :=  set.parity
  708.    set.function.table!ws.pause        :=  set.pause
  709.    set.function.table!ws.prefix       :=  set.prefix
  710.    set.function.table!ws.repeatcount  :=  not.yet.implemented
  711.    set.function.table!ws.retry        :=  set.retry
  712.    set.function.table!ws.timeout      :=  set.timeout
  713.    set.function.table!ws.line         :=  set.line
  714.    set.function.table!ws.dir          :=  not.yet.implemented
  715.    set.function.table!ws.overwrite    :=  not.yet.implemented
  716.    set.function.table!ws.baud         :=  set.baud
  717.    set.function.table!ws.termtype     :=  not.yet.implemented
  718.    set.function.table!ws.interface    :=  set.interface
  719.    set.function.table!ws.padchar      :=  set.pad.char
  720.    set.function.table!ws.take.echo    :=  set.take.echo
  721. //
  722. //
  723. //
  724. $)0
  725. //
  726. AND readcommand(buffer) = VALOF
  727. $(0
  728.   LET nchs = readline(buffer,72)
  729.   AND ch = 0
  730.   TEST nchs = 0 THEN
  731.     RESULTIS ENDSTREAMCH
  732.   ELSE
  733.   $(1
  734.     nchs := nchs - 1
  735.     FOR k=nchs-1 TO 0 BY -1 DO $(2 buffer%(k+1) := capitalch(buffer%k) $)2
  736.     buffer%0 := nchs
  737.     RESULTIS nchs
  738.   $)1
  739. $)0
  740. //
  741. AND open.serial.line() BE $(0
  742.   LET name = TABLE 3,'S','E','R'
  743.   AND nptr = 0
  744.   nptr := PACKSTRING(name,ser.name)
  745.   nptr := 4
  746.   ser.name%nptr := ser.line                      // Choose SER1 or SER2
  747.   nptr := nptr + 1
  748.   TEST ser.interface\=interface.qconnect THEN
  749.   $(1 // Raw communicatons, no little black boxes
  750.     UNLESS ser.parity='N' DO $(2
  751.                                  ser.name%nptr := ser.parity
  752.                                  nptr := nptr + 1
  753.                              $)2
  754.  
  755.     UNLESS ser.handshake='X' DO  $(3
  756.                                      ser.name%nptr := ser.handshake
  757.                                      nptr := nptr + 1
  758.                                  $)3
  759.  
  760.     ser.name%nptr := 'R'                         // Raw data, no EOF
  761.     ser.name%0 := nptr                           // Length of name
  762.     baud(ser.baud)                               // Set baud rate
  763.     remfd := OPEN(ser.name,0,0)                  // Open the channel
  764.  
  765.     IF remfd<0 THEN
  766.     $(4 // Whoops, we've failed to open the serial line !
  767.       WRITEF("*N Unable to open serial line %S (QDOS error code %N)*N",
  768.              ser.name,remfd)
  769.       remfd := 0
  770.       RETURN
  771.     $)4
  772.   $)1
  773.   ELSE
  774.   $(5 // Communications via a QConnect box
  775.     UNLESS qcon.init DO qcon.reset()
  776.     ser.name%nptr := 'H'                         // CTS/RTS between QL and box
  777.     nptr := nptr + 1
  778.     ser.name%nptr := 'R'                         // Raw data, no EOF
  779.     ser.name%0 := nptr
  780.     baud(9600)
  781.     remfd := OPEN(ser.name,0,0)
  782.     IF remfd<0 THEN
  783.     $(6
  784.       WRITEF("*N Unable to open serial line %S (QDOS error %N)*N",ser.name,
  785.               remfd)
  786.       remfd := 0
  787.       RETURN
  788.     $)6
  789.     qcon.initialise()
  790.   $)5
  791. $)0
  792. //
  793. AND find.new.file(name) = VALOF $(0
  794.   LET exists = FINDINPUT(name)
  795.   debug.report(writef,"*NTrying to open new file %S*N",name)
  796.   IF exists>0 THEN
  797.   $(1 // The file already exists
  798.     close(exists)
  799.     debug.report(writes,"Failed - file already exists*N")
  800.     RESULTIS -8                   // QDOS ERR.EX code
  801.   $)1
  802.   exists := findoutput(name)
  803.   TEST exists>0 THEN debug.report(writes,"File opened successfully*N")
  804.   ELSE debug.report(writef,"Failed - error code is %N*N",exists)
  805.   RESULTIS exists
  806. $)0
  807. //
  808. AND find.old.file(name) = VALOF $(0
  809.   LET exists = findinput(name)
  810.   debug.report(writef,"*NTrying to open old file %S*N",name)
  811.   TEST exists>0 THEN debug.report(writes,"File opened successfully*N")
  812.   ELSE debug.report(writef,"Failed - error code %N*N",exists)
  813.   RESULTIS exists
  814. $)0
  815. AND message(m,n) BE FOR i=0 TO n-1 DO wrch(m%i)
  816. AND end.kermit() BE $(0
  817.   screen(screen.clear)
  818.   writes("QL Kermit : exiting back to SuperBasic*N")
  819.   STOP(0)
  820. $)0
  821. AND datstamp(x) BE !x := time()
  822. //
  823. AND qcon.reset() BE $(0
  824.   IF remfd\=0 DO close(remfd)
  825.   remfd := OPEN("SER2IR",0,0)
  826.   selectoutput(remfd)
  827.   writes("%X1F%X21%X70")
  828.   close(remfd)
  829.   qcon.init := TRUE
  830.   selectoutput(console)
  831.   ink(red)
  832.   writes("*N QConnect reset OK*N")
  833.   ink(green)
  834. $)0
  835. //
  836. AND qcon.initialise() BE $(0
  837.   LET inits = TABLE #X1F164A35, #X00600E00
  838.   AND ch = 0
  839.   //
  840.   // Parity
  841.   //
  842.   IF ser.parity='E' | ser.parity='O' THEN
  843.   $(1
  844.     ch := 16 + (ser.parity='E' -> 32,0)
  845.     inits%2 := inits%2 | ch
  846.     inits%5 := inits%5 | 32
  847.   $)1
  848.   //
  849.   // Handshake
  850.   //
  851.   UNLESS ser.handshake='N' DO
  852.   $(2
  853.     ch := 2 + (ser.handshake='X' -> 64,1)
  854.    inits%5 := inits%5 | ch
  855.   $)2
  856.   //
  857.   // Baud
  858.   //
  859.   ch := 0
  860.   SWITCHON ser.baud INTO
  861.   $(3
  862.     CASE 9600 :            ENDCASE
  863.     CASE 4800 :  ch := 1 ; ENDCASE
  864.     CASE 2400 :  ch := 2 ; ENDCASE
  865.     CASE 1200 :  ch := 3 ; ENDCASE
  866.     CASE  600 :  ch := 4 ; ENDCASE
  867.     CASE  300 :  ch := 5 ; ENDCASE
  868.     CASE  150 :  ch := 6 ; ENDCASE
  869.     DEFAULT   :  catastrophe("Illegal baud rate value in qcon.init")
  870.   $)3
  871.   ch := ch + (ch << 3)
  872.   inits%4 := ch
  873.   selectoutput(remfd)
  874.   writebytes(inits,8)
  875.   selectoutput(console)
  876.   ink(red)
  877.   writef("*N QConnect initialised with string %X8 %X8*N",inits!0,inits!1)
  878.   ink(green)
  879. $)0
  880. //
  881. AND raw.rdch() = VALOF $(0
  882.   LET ch = inkey(0)
  883.   WHILE ch<0 & time()<=endtime DO ch := inkey(0)
  884.   RESULTIS (ch<0 -> rpack.timeout,ch)
  885. $)0
  886. AND qcon.rdch() = VALOF $(0
  887.   LET ch = raw.rdch()
  888.   UNLESS ch=USC THEN RESULTIS ch
  889.   ch := inkey(-1)
  890.   RESULTIS (ch=USC -> USC,rpack.timeout)
  891. $)0
  892. //
  893. AND BAUD(speed) BE $(0
  894.   LET regsin = VEC 7
  895.   AND regsout = VEC 7
  896.   regsin!0 := #X12                     // MT.BAUD
  897.   regsin!1 := speed
  898.   qtrap(1,regsin,regsout)
  899. $)0
  900. //
  901. AND beep() BE $(0
  902. /*  LET regsin = VEC 7
  903.   AND regsout = VEC 7
  904.   AND bparms = TABLE #X0A0B0000, #XAAAA0000, #X00000000, #X00000000
  905.   regsin!0 := #X11                     // MT.IPCOM
  906.   regsin!7 := bparms << 2              // MC address of parameters
  907.   qtrap(1,regsin,regsout)
  908. */
  909.   ink(red)
  910.   writes("<beep>")
  911.   ink(green)
  912. $)0
  913. //
  914. AND glasstty() BE $(0
  915.   LET ch,lastch = 0,0
  916.   selectoutput(console)
  917.   screen(screen.cursor)
  918.   $(1 // Terminal emulation loop
  919.     selectinput(console)
  920.     ch := inkey(0)
  921.     IF ch=ser.escape THEN BREAK
  922.     IF ch=kbd.left | ch=kbd.ctl.left THEN ch := kbd.del
  923.     IF ch>0 & ch<128 THEN
  924.     $(1
  925.       selectoutput(remfd)
  926.       wrch((ch=LF -> CR,ch))
  927.     $)1
  928.     selectinput(remfd)
  929.     ch := inkey(0)
  930.     IF ch<0 THEN LOOP
  931.     selectoutput(console)
  932.     ch := ch & #X7F
  933.     IF ser.interface=interface.qconnect & ch=USC THEN
  934.     $(5 // Handle USC sequence from QConnect box
  935.       ch := INKEY(-1)                  // Get this byte at all costs
  936.       IF ch\=USC DO
  937.       $(6  qcon.report(ch)
  938.            LOOP
  939.       $)6
  940.     $)5
  941.     TEST ch<SP THEN
  942.     $(2 // It's non-printing
  943.       SWITCHON ch INTO
  944.       $(3
  945.         CASE CR  : wrch(LF) ; ENDCASE
  946.  
  947.         CASE LF  : UNLESS LASTCH=CR DO wrch(LF) ; ENDCASE
  948.  
  949.         CASE BEL : beep() ; ENDCASE
  950.  
  951.         CASE BS  : screen(screen.left) ; ENDCASE
  952.  
  953.         CASE FF  : screen(screen.clear) ; ENDCASE
  954.  
  955.         DEFAULT : wrx(ch) ; ENDCASE
  956.       $)3
  957.     $)2
  958.     ELSE
  959.     $(4 // It's a valid ASCII character
  960.       wrch(ch)
  961.     $)4
  962.     lastch := ch
  963.   $)1 REPEAT
  964.   selectinput(console)
  965.   selectoutput(console)
  966. $)0
  967. AND disconnect() = VALOF $(0
  968.   IF remfd=0 THEN RESULTIS TRUE
  969.   TEST close(remfd)=0 THEN
  970.   $(1
  971.     remfd := 0
  972.     RESULTIS TRUE
  973.   $)1
  974.   ELSE
  975.   $(2
  976.     catastrophe("Failed to close serial line")
  977.     RESULTIS FALSE
  978.   $)2
  979. $)0
  980. //
  981. AND connect() BE $(0
  982.   LET disced = FALSE
  983.   IF remfd\=0 & ser.corrupt DO
  984.   $(1 // Try to drop serial line
  985.     UNLESS disconnect() DO catastrophe("Cannot disconnect")
  986.   $)1
  987.   IF remfd=0 DO open.serial.line()
  988.   UNLESS remfd\=0 DO catastrophe("Cannot connect")
  989.   ser.corrupt := FALSE
  990.   glasstty()
  991. $)0
  992. //
  993. AND catastrophe(text) BE $(0
  994.   LET new.con = FINDTERMINAL()
  995.   selectoutput(new.con)
  996.   screen(screen.clear)
  997.   beep()
  998.   writes(text)
  999.   newline()
  1000.   STOP(-1)
  1001. $)0
  1002. //
  1003. AND qcon.report(ch) BE $(0
  1004.   newline()
  1005.   beep()
  1006.   ink(red)
  1007.   writef(" QConnect USC sequence, byte %X2*N",ch)
  1008.   ink(green)
  1009. $)0
  1010. //
  1011. AND ink(colour) BE screen(screen.ink,colour)
  1012. //
  1013. AND show.set() BE $(0
  1014.   LET nopts = ws.num.commands/2
  1015.   selectoutput(console)
  1016.   writes("Settable options : *N")
  1017.   FOR k=0 TO 2*(nopts-1) BY 2 DO
  1018.   $(1
  1019.     newline()
  1020.     writes(set.com.table!(k+1))
  1021.     screen(screen.tab,40)
  1022.     writes(set.com.table!(k+2))
  1023.   $)1
  1024.   nopts := ws.num.commands REM 2
  1025.   IF nopts=1 DO $(2 newline() ; writes(set.com.table!ws.num.commands) $)2
  1026.   newline()
  1027. $)0
  1028. //
  1029. AND wrx(ch) BE $(0
  1030.   ink(red)
  1031.   writef("<#X%X2>",ch)
  1032.   ink(green)
  1033. $)0
  1034. //
  1035. // Our ABORT exit routine
  1036. //
  1037. AND kermit.abort(code) BE $(0
  1038.   selectoutput(console)
  1039.   screen(screen.clear)
  1040.   sys.abort(code)
  1041. $)0
  1042. //
  1043. // debug.report : cf. cons in kerproto.bcpl
  1044. //
  1045. AND debug.report(f,a1,a2,a3,a4,a5) BE IF debug THEN
  1046. $(0 LET co = COS
  1047.     selectoutput(debug.fd)
  1048.     f(a1,a2,a3,a4,a5)
  1049.     selectoutput(co)
  1050. $)0
  1051. //
  1052. // QDOS call to change the priority of the current job
  1053. //
  1054. AND change.my.priority(priority) BE $(0
  1055.   LET regsin = VEC 7
  1056.   AND regsout = VEc 7
  1057. //
  1058.   regsin!0 := #X0B        // MT.PRIOR
  1059.   regsin!1 := -1          // change my priority
  1060.   regsin!2 := priority & #X7F  // priority must be in range 0 to 127
  1061. //
  1062.   qtrap(1,regsin,regsout)
  1063. $)0
  1064. //
  1065. AND sendchars(buffer,nchars) BE writebytes(buffer,nchars)
  1066.