options /EXTEND_SOURCE subroutine in_char(inchr) c read character strings, BUT return SMG keys and mouse positions in c a common. c read a character at a time & return it. c Return mouse position also if we get one. Works on c decterms. Not useful on xterm... c "Drop-in" replacement for in_char.mar, so handle mouse operations c internally here. c AnalyRIM commons, etc. Include 'aparms.inc' C ***<<<< RDD COMMON START >>>*** InTeGer*4 RRWACT,RClACT C COMMON/RClACT/RRWACT,RClACT InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6, 1 IDOl7,IDOl8 C common/dollr/idol1,idol2,idol3,idol4,idol5,idol6, C 1 IDOl7,IDOl8 InTeGer*4 PROW,PCOl,DROW,DCOl,DRWV,DClV,llCMD,llDSP C COMMON/DCTl/PROW,PCOl,DROW,DCOl,DRWV,DClV InTeGer*4 IPGMAX,lPGMXF,IPGMOD,lPGMOD C COMMON/FIlEMX/IPGMAX,lPGMXF,IPGMOD,lPGMOD C lENGTHS (IN K) OF FIlES FOR VAlUES OR FORMUlAS ARE IPGMAX,lPGMXF C IPGMOD AND lPGMOD CONTROl PACKING MODE IN THE CORRESPONDING FIlES InTeGer*4 KlVl,k3dfg,kcdelt,krdelt,kpag C COMMON/KlVl/KlVl InTeGer*4 IOlVl,igold C COMMON/IOlVl/IOlVl C IOlVl IS lUN FOR XQTCMD TO USE (NORMAllY 3 FOR INDIRECT FIlES OR 5 C FOR TERMINAl. WE USE 5,6 FOR TERMINAl INPUT, OUTPUT NORMAllY. Integer*4 Idsptp,Idol9 COMMON/RDD/RRWACT,RClACT,idol1,idol2,idol3,idol4,idol5,idol6, 1 IDOl7,IDOl8,PROW,PCOl,DROW,DCOl,DRWV,DClV,llCMD,llDSP, 2 IPGMAX,lPGMXF,IPGMOD,lPGMOD,KlVl,IOlVl,IGOlD,IDSPTP,IDOl9, 3 k3dfg,kcdelt,krdelt,kpag C ***<<< RDD COMMON END >>>*** integer*4 icolsw,itchan common/icols/icolsw,itchan character*1 form(128) character*128 cform equivalence(cform,form(1)) InTeGer*4 CWIDS(JIDcl) C CWIDS IS WIDTHS IN CHARACTERS OF COlUMNS ON DISPlAY. NOTE THAT BECAUSE C OF PECUlIAR INVERSION WHICH I AM TOO lAZY TO CORRECT IT IS DIMENSIONED C AS JIDcl NOT JIDrw. c INTEGER*4 I4TMP REAl*8 DVS(JIDcl,JIDrw) COMMON/DSPCMN/DVS,CWIDS DIMENSION NRDSP(JIDcl,JIDrw),NCDSP(JIDcl,JIDrw) COMMON/D2R/NRDSP,NCDSP c 7 cols for labels and 2 rows at top. c drow,dcol are current d## location. c Compute and use D#col#row location etc. cmds. to use. c c Terminal state on call: No assumptions made other than VT200 or better. c Terminal state on completion: Will be in APPlICATION mode (=) - set to NUMERIC with > c c locator state on call: No assumptions made (any position, any number of buttons). c locator state on completion: May have a pending locator request. Cancel with 0;0'z c c Written by Bernhard Fabricius, Department of Nuclear Physics, Australian National University, September 1992 c This code may be freely copied, modified and distributed. If you have some good additions or find bugs then c please let me know via e-mail to BEAR@NUC.ANU.EDU.AU. c c c Parameter Type Access Function c ------------------------------------------------------------------------------------------------------------------------ c KEY Integer*4 Write only Key (SMG code) pressed during QIO (including l/C/R mouse buttons) c ROW Integer*4 Write only Row of cursor position if mouse was pressed c COl Integer*4 Write only Column of cursor position if mouse was pressed c CHAN Integer*4 Read/Write On call: If 0: a channel to "TT" will be assigned (first time) c If <> 0: no change (use previously assigned channel) c On return: The channel to "TT" (only done first time) include '($trmdef)' !Need the extended mode codes by name byte bbuf(1:32) character*32 sbuf equivalence (bbuf(1),sbuf(1:1)) character*2 terminal/'TT'/ integer*4 status, sys$assign, sys$dassgn, sys$qiow, iofunc integer*4 key, row, col, l, k, i, chan integer*4 nleft,nnext external io$_readvblk, io$m_noecho, io$m_extend, io$m_escape c return mouse loc in a common. common/msrwcl/row,col,key structure /itemlist/ integer*2 buffer_length integer*2 item_code integer*4 buffer integer*4 stop/0/ end structure record /itemlist/itml(1:3) integer*4 itmsize structure /statusblock/ integer*2 status integer*2 offset byte term_char byte reserved byte term_length byte cp_eol end structure record /statusblock/iosb external inchar integer*4 inchr integer*2 tilde(1:34)/34*0/ integer*2 o_low(108:121)/14*0/ save chan,tilde,mouse,nleft c Editing keys E1 E2 E3 E4 E5 E6 c [i~ keys 1 2 3 4 5 6 data (tilde(i),i=1,6)/311,312,313,314,315,316/ c Top row function keys F6 F7 F8 F9 F10 F11 F12 F13 F14 HElP DO F17 F18 F19 F20 c [i~ keys 17 18 19 20 21 - 23 24 25 26 - 28 29 - 31 32 33 34 data (tilde(i),i=17,34)/25,287,288,289,290,000,291,292,293,294,000,295,296,000,297,298,299,300/ c Keypad keys , - . 0 1 2 3 4 5 6 7 8 9 c Oi keys l m n - p q r s t u v w x y data (o_low(i),i=108,121)/272,271,273,000,260,261,262,263,264,265,266,267,268,269/ data nleft/0/ character*12 mouse !enable and request one-shot locator position in cell units using application keypad mode mouse(1:12)=char(155)//'2;2'//char(39)//'z'//char(155)//'1'//char(39)//'{'//char(27)//'=' data chan/0/ if(icolsw.ne.0)goto 1820 c call macro input routine unless in color mode (indicating DECterm or such) nleft=0 nnext=0 call inchar(bbuf,1) inchr=ichar(sbuf(1:1)) return 1820 continue if(chan.eq.0)then !No channel specified - status = sys$assign(terminal,chan,,) !get one if(.not.status) call lib$stop(%val(status)) end if c itml(1).buffer_length = 0 itml(1).item_code = trm$_modifiers !Modify to include c no echo, no filter, escape terminate itml(1).buffer = trm$m_tm_noecho.or.trm$m_tm_escape.or.trm$m_tm_nofiltr itml(2).buffer_length = 0 itml(2).item_code = trm$_esctrmovr !Allow an escape overflow buffer itml(2).buffer = 31 !of 31 characters (buffer is 32 characters in all) itml(3).buffer_length = 12 itml(3).item_code = trm$_prompt !Allow prompt of 12 characters itml(3).buffer = %loc(mouse) !use mouse request string itmsize = 36 !There are 36 bytes in the item list iofunc = %loc(io$_readvblk).or.%loc(io$m_extend) !Read virtual block in extended mode c if returning rest of an esc. seq., no qio yet. if(nleft.gt.0)goto 1500 c [efn], chan, func, iosb, [astadr], [astprm], p1, p2, [p3], [p4], p5, p6 status = sys$qiow( , %val(chan), %val(iofunc), iosb, , , 1 bbuf, %val(32), , ,itml ,%val(itmsize)) if(.not.status) call lib$stop(%val(status)) row=0 !Row is 0 col=0 !Column is 0 key=0 !Key is 0 if(iosb.offset.eq.1.or.iosb.term_length.eq.1)then !ASCII char or control char key=zext(bbuf(1)) !Use as read (but zero-extended for ISO-latin1) inchr=key nleft=0 nnext=0 return else !Some escape sequence c first char will have been the ESC, but then we need to dump the rest. l=iosb.term_length !length thereof if(iosb.term_char.eq.-101.or.iosb.term_char.eq.-113)then c ! (155) or (143): 8-bit escape do k=l,2,-1 !Shuffle along bbuf(k+1)=bbuf(k) !Move to the right end do bbuf(2)=91 !Add [ in position 2 (never mind 1) l=l+1 !Update length end if nleft=l c normal esc seq reading inits nnext to 0. nnext=0 1500 continue nleft=max0((nleft-1),0) nnext=nnext+1 c if(nnext.eq.0)inchr=27 if(nnext.ge.1)inchr=zext(bbuf(nnext)) c only compute "key" on first pass. if(nleft.le.0)return if(nnext.gt.1)return if(sbuf(l:l).eq.'~')then ![k~ read(sbuf(3:l-1),*,err=100)k !Try to read if(k.gt.34.or.k.lt.1)go to 100 !Must be 1Ok or [k (either Cursor Key Mode) k=ichar(sbuf(3:3)) !get the character if(k.ge.108.and.k.le.121)then !lowercase l to y key=o_low(k) !read back SMG code from array return end if !Deal with the UPPERCASE codes by brute force if(k.eq.65)key=274 !A: Up if(k.eq.66)key=275 !B: Down if(k.eq.67)key=277 !C: Right if(k.eq.68)key=276 !D: left if(k.eq.77)key=270 !M: Enter if(k.eq.80)key=256 !P: PF1 if(k.eq.81)key=257 !Q: PF2 if(k.eq.82)key=258 !R: PF3 if(k.eq.83)key=259 !S: PF4 return else if(sbuf(l-1:l).eq.'&w')then ![Pe;Pb;Pr;Pc;Pp&w - mouse codes do k=3,l-2 if(bbuf(k).eq.59)bbuf(k)=44 !Replace ; with , to enable read end do read(sbuf(3:l-2),*,err=200)k,i,row,col !Read 4 integers (Pb is not used, ignore Pp if given) key=320+k/2 !Pe is 2, 4 or 6 for lEFT, MIDDlE and RIGHT respectively c mouse presses just give location, no more. c Define left press as l cellname where col is the offset to the column c where we currently are and row is the row offset. Define middle press c as just cellname and right as :cellname c first get curr. loc in cells krow=max0((row-2),0) krow=min0(krow,(llcmd-1)) ktgt=1 c let first col. work anywhere ahead of its end. ketgt=7 do 1720 n=1,jidcl kk=n ketgt=ketgt+cwids(n) if(col.ge.ktgt.and.col.lt.ketgt)goto 1721 ktgt=ketgt 1720 continue 1721 continue kcol=kk c mouse hit in cell kcol,krow c compute name for this beast. kr=nrdsp(kcol,krow) kc=ncdsp(kcol,krow) c kr,kc = phys. cells. c kc used to be 0-60, kr 0-300 do 1723 n=1,128 1723 form(n)=' ' kc=kc-1 CAll IN2AS(kr,FORM) C NOTE PCOl STARTS AT 2 FOR NORMAl SHEET VARIABlES. PCOl=1 IS FOR ACCUMUlATORS do 1724 n=1,8 kk=9-n if(ichar(form(kk)).gt.33)goto 1725 1724 continue 1725 continue write(cform(kk+1:kk+6),1727)kc 1727 format(i6.6) c cform(:kk+6) now contains cell name c find start of valid name now (no use with bunch of nulls) kbg=1 do 1729 n=1,kk if(ichar(cform(n:n)).le.32)kbg=kbg+1 1729 continue if(key.ne.321)goto 1730 c left mouse c lcellname inchr=ichar('L') c "terminate" the line... cform(kk+7:kk+7)=char(13) sbuf(1:32)=cform(kbg:kk+7) nnext=0 nleft=kk+8-kbg return 1730 continue if(key.ne.322)goto 1731 c center button. Cellname only. inchr=ichar(cform(kbg:kbg)) sbuf(1:32)=cform(kbg+1:kk+6) nnext=0 c length 1 less... nleft=kk+6-kbg return 1731 continue c right mouse. Give ":cellname" inchr=ichar(':') sbuf(1:32)=cform(kbg:kk+6) nnext=0 nleft=kk+7-kbg c inchr=key c nleft=0 200 continue !The corresponding SMG codes are 321, 322 or 323. return else if(l.eq.2.and.bbuf(2).eq.27)then !Final possibility: (^[) itself is key=27 c if it's ESC then don't send 2 of them so user CAN spec just one! nleft=0 end if end if return end