InfoMagic Internet Tools 1993 July

home *** CD-ROM | disk | FTP | other *** search

/ InfoMagic Internet Tools 1993 July / Internet Tools.iso / RockRidge / info-service / gopher / Rice_CMS / gopher24 / gopclimb.$rexx < prev next >

Wrap

Text File | 1993-01-25 | 39.9 KB | 505 lines

/* 00010000 * Name: GOPCLIMB REXX 00020000 * VM TCP/IP Network GOPHER Client menu browser 00030000 * Author: Rick Troth, Rice University, Information Systems 00040000 * Date: 1992-Dec-23 00050000 * 00060000 * Input: one or more gopher menu lines 00070000 * Output: zero or more information or error messages 00080000 */ 00090000 00100000 /* 00110000 * Copyright 1992 Richard M. Troth. This software was developed 00120000 * with resources provided by Rice University and is intended 00130000 * to serve Rice's user community. Rice has benefitted greatly 00140000 * from the free distribution of software, therefore distribution 00150000 * of unmodified copies of this material is not restricted. 00160000 * You may change your own copy as needed. Neither Rice 00170000 * University nor any of its employees or students shall be held 00180000 * liable for damages resulting from the use of this software. 00190000 */ 00200000 00210000 Trace "OFF" 00220000 00230000 Parse Arg args '(' . ')' . 00240000 00250000 /* verify availability of input */ 00260000 'PEEKTO' 00270000 If rc ^= 0 & rc ^= 12 Then Exit rc 00280000 If rc = 12 Then Do /* empty menu */ 00290000 'CALLPIPE COMMAND XMITMSG 60 (APPLID GOP CALLER CLI ERRMSG | *:' 00300000 Exit 00310000 End /* If .. Do */ 00320000 00330000 Address "COMMAND" 'GLOBALV SELECT GOPHER GET' , 00340000 'GOPHER PROGID VIEWER ITEM' 00350000 quit = 0 00360000 00370000 Parse Var item name '05'x path '05'x host '05'x port '05'x xtra 00380000 Parse Var name 1 . 2 name /* discard type indicator byte */ 00390000 Parse Var path 1 . 2 path /* discard type indicator byte */ 00400000 If name = "" Then name = args 00410000 booklist = (item = "") 00420000 00430000 /* fetch fs. stem variable from GlobalVs */ 00440000 'CALLPIPE COMMAND GLOBALV SELECT GOPHER LIST | DROP' , 00450000 '| LOCATE 1-4 / FS./ | SPEC /=/ 1 2-* NEXT | VARLOAD' 00460000 If ^Datatype(fs.tube,'X') Then fs.tube = "" 00470000 00480000 'CALLPIPE *: | STEM MENU.' 00490000 00500000 /* is it a server error? */ 00510000 If menu.0 = 1 & Left(menu.1,1) = '-' Then Do 00520000 Parse Var menu.1 . '-' errmsg '05'x . 00530000 'OUTPUT' errmsg 00540000 Exit 00550000 End /* If .. Do */ 00560000 00570000 /* display the menu and process user's response */ 00580000 row = 0; col = 0 /* reset later */ 00590000 ki = menu.0; kl = fs.scrrows - 5; ko = 1 00600000 needle = "" /* may be re-used within this context */ 00610000 message.0 = 0 00620000 command = "" 00630000 00640000 If booklist Then 'CALLPIPE COMMAND XMITMSG 615' , 00650000 '(APPLID GOP CALLER CLI NOCOMP | SPEC WORD 2-* 1 | STEM HELP.' 00660000 Else 'CALLPIPE COMMAND XMITMSG 613' , 00670000 '(APPLID GOP CALLER CLI NOCOMP | SPEC WORD 2-* 1 | STEM HELP.' 00680000 00690000 'CALLPIPE COMMAND XMITMSG 5 (APPLID GOP NOHEADER | VAR MORE' 00700000 00710000 Do Forever 00720000 00730000 /* write the program title line */ 00740000 wscreen = sba(0,-1) || field("BLUE","PROT") || sba(0,0) || progid , 00750000 || sba(0,fs.scrcols-Length(host)-1) || host 00760000 00770000 /* no SBA for status because it follows host immediately */ 00780000 If message.0 < 1 Then Do 00790000 wscreen = wscreen || field("PROT") || Left(ko || '/' || ki, 11) 00800000 If ko + kl <= ki Then 00810000 wscreen = wscreen || field("WHITE","HIGH","PROT") || more 00820000 End /* If .. Do */ 00830000 00840000 /* don't write status or name if they'll be overlaid */ 00850000 If message.0 < 2 Then 00860000 wscreen = wscreen || sba(2,(fs.scrcols-Length(name))/2) , 00870000 || field("WHITE","PROT") || name 00880000 00890000 /* write as many message lines as needed */ 00900000 If message.0 > 0 Then Do 00910000 Do i = 1 to message.0 00920000 wscreen = wscreen || sba(i,-1) , 00930000 || field("RED","HIGH","PROT") || message.i 00940000 End /* Do For */ 00950000 message.0 = 0 00960000 End /* If .. Do */ 00970000 /* we should probably limit that count */ 00980000 00990000 /* write those PFkey settings */ 01000000 wscreen = wscreen || sba(fs.scrrows-2,-1) , 01010000 || field("BLUE","PROT") , 01020000 || help.1 , 01030000 || sba(fs.scrrows-1,-1) , 01040000 || field("BLUE","PROT") , 01050000 || help.2 01060000 01070000 i = 1; j = ko 01080000 Do While i <= kl & j <= ki 01090000 01100000 Parse Var menu.j _name '05'x . 01110000 Parse Var _name 1 _type 2 _name 01120000 'CALLPIPE VAR _NAME | XLATE OUTPUT' , 01130000 '| XLATE *-* 00-3F 40 FF 40 | VAR _NAME' 01140000 01150000 wscreen = wscreen || sba(i+2,-1) , 01160000 || field("BLUE","PROT","HIGH") 01170000 If _type = 'i' Then 01180000 wscreen = wscreen || Left(_name,fs.scrcols-1) 01190000 Else Do 01200000 wscreen = wscreen || Left(gtag(_type),11) , 01210000 || field("GREEN") , 01220000 || Left(_name,fs.scrcols-13) 01230000 If row = 0 Then Do 01240000 row = i + 2; col = 12 01250000 End /* If .. Do */ 01260000 End /* Else Do */ 01270000 01280000 i = i + 1; j = j + 1 01290000 01300000 End /* Do While */ 01310000 01320000 rscreen = write_read(wscreen || sba(row,col) || '13'x) 01330000 Parse Var rscreen 1 aid 2 offset . '11'x rscreen 01340000 offset = fix(offset) 01350000 row = offset % fs.scrcols; col = offset // fs.scrcols 01360000 01370000 /* keep the row/col values within bounds */ 01380000 If row < 3 Then row = 3 01390000 If row > kl + 3 Then row = kl + 3 01400000 If row + ko > ki + 3 Then row = ki + 3 - ko 01410000 col = 12 /* just reset it */ 01420000 01430000 i = row + ko - 3 01440000 01450000 Select /* aid */ 01460000 When aid = '7D'x /* enter */ | , 01470000 aid = 'F2'x /* PF2 */ | , 01480000 aid = 'C2'x /* PF14 */ | , 01490000 aid = '7B'x /* PF11 */ | , 01500000 aid = '4B'x /* PF23 */ Then Call OPEN 01510000 When aid = 'F3'x /* PF3 */ | , 01520000 aid = 'C3'x /* PF15 */ Then Leave 01530000 When aid = 'F4'x /* PF4 */ | , 01540000 aid = 'C4'x /* PF16 */ Then Call PRINT 01550000 When aid = 'F5'x /* PF5 */ | , 01560000 aid = 'C5'x /* PF17 */ Then Call KEEP 01570000 When aid = 'F6'x /* PF6 */ | , 01580000 aid = 'C6'x /* PF18 */ Then Call FIND 01590000 When aid = 'F7'x /* PF7 */ | , 01600000 aid = 'C7'x /* PF19 */ Then Do 01610000 ko = Max(ko-kl+1,1) 01620000 row = 3 01630000 End /* When .. Do */ 01640000 When aid = 'F8'x /* PF8 */ | , 01650000 aid = 'C8'x /* PF20 */ Then Do 01660000 ko = Min(ko+kl-1,ki) 01670000 row = 3 01680000 End /* When .. Do */ 01690000 When aid = 'F9'x /* PF9 */ | , 01700000 aid = 'C9'x /* PF21 */ Then Call MARK 01710000 When aid = '7A'x /* PF10 */ | , 01720000 aid = '4A'x /* PF22 */ Then Call BOOKLIST 01730000 When aid = '6D'x /* clear */ | , 01740000 aid = '6E'x /* PA2 */ Then Do 01750000 row = 3; col = 12; ko = 1 01760000 End /* When .. Do */ 01770000 When aid = '7C'x /* PF12 */ | , 01780000 aid = '4C'x /* PF24 */ | , 01790000 aid = 'F0'x /* sysrq */ | , 01800000 aid = '6C'x /* PA1 */ Then quit = 1 01810000 When aid = 'F1'x /* PF1 */ | , 01820000 aid = 'C1'x /* PF13 */ Then Call HELP 01830000 When aid = '00'x Then Do 01840000 /* I/O error on screen */ 01850000 'CALLPIPE COMMAND XMITMSG 925 (APPLID GOP' , 01860000 'CALLER CLI ERRMSG | STEM MESSAGE. APPEND' 01870000 Leave 01880000 End 01890000 Otherwise Do /* Undefined PFkey/PAkey */ 01900000 'CALLPIPE COMMAND XMITMSG 657 "' || c2x(aid) || '"' , 01910000 '(APPLID GOP CALLER CLI ERRMSG | STEM MESSAGE. APPEND' 01920000 End /* Otherwise Do */ 01930000 End /* Select aid */ 01940000 01950000 Address "COMMAND" 'GLOBALV SELECT GOPHER GET COMMAND' 01960000 Parse Upper Var command cmdverb . 01970000 quit = (quit | Abbrev("QUIT",cmdverb,1)) 01980000 01990000 If quit Then Leave 02000000 02010000 End /* Do Forever */ 02020000 02030000 If quit Then command = "QUIT" 02040000 02050000 'CALLPIPE STEM MESSAGE. | *:' 02060000 02070000 Parse Upper Var command cmdverb . 02080000 Address "COMMAND" 'GLOBALV SELECT GOPHER PUT' , 02090000 'COMMAND CMDVERB' 02100000 02110000 Exit 02120000 02130000 02140000 02150000 /* ---------------------------------------------------------------- OPEN02160000 */ 02170000 OPEN: 02180000 02190000 'CALLPIPE VAR MENU.' || i '| GOPCLITM OPEN | STEM MESSAGE. APPEND' 02200000 02210000 Return 02220000 02230000 02240000 02250000 /* --------------------------------------------------------------- PRINT02260000 * Print the current "menu" on the user's virtual printer. 02270000 */ 02280000 PRINT: 02290000 02300000 If fs.tube ^= "" Then Do 02310000 /* "Can't PRINT from this terminal." */ 02320000 'CALLPIPE COMMAND XMITMSG 507 (APPLID GOP CALLER CLI ERRMSG' , 02330000 '| STEM MESSAGE. APPEND' 02340000 Return 02350000 End /* If .. Do */ 02360000 02370000 'CALLPIPE STEM MENU. | XLATE *-* 05 7A' , 02380000 '| PRINT (TITLE' name '| STEM MESSAGE. APPEND' 02390000 02400000 Return 02410000 02420000 02430000 02440000 /* ---------------------------------------------------------------- KEEP02450000 */ 02460000 KEEP: 02470000 02480000 'CALLPIPE VAR MENU.' || i '| GOPCLITM KEEP | STEM MESSAGE. APPEND' 02490000 02500000 Return 02510000 02520000 02530000 02540000 /* ---------------------------------------------------------------- FIND02550000 * Find a particular string within the menu being viewed. 02560000 * Call GOPCLIUI for user input with prompt. 02570000 */ 02580000 FIND: 02590000 02600000 'CALLPIPE COMMAND XMITMSG 602 "' || needle || '" (APPLID GOP' , 02610000 'CALLER CLI NOHEADER | GOPCLIUI | VAR NEEDLE' 02620000 needle = Translate(Strip(needle)) 02630000 If needle = "" Then Return 02640000 02650000 Do i = ko + 1 to ki 02660000 If Index(Translate(menu.i),needle) > 0 Then Do 02670000 ko = i 02680000 Return 02690000 End /* If .. Do */ 02700000 End /* Do For */ 02710000 02720000 /* 'CALLPIPE COMMAND XMITMSG 546 (ERRMSG' CALLER DMS is OK */ 02730000 /* "Target not found" */ 02740000 'CALLPIPE COMMAND XMITMSG 546 (APPLID GOP CALLER CLI ERRMSG' , 02750000 '| STEM MESSAGE. APPEND' 02760000 02770000 Return 02780000 02790000 02800000 02810000 /* ---------------------------------------------------------------- MARK02820000 * Save a bookmark referencing this menu, 02830000 * or (if in "booklist" mode) delete the bookmark at the cursor. 02840000 */ 02850000 MARK: 02860000 02870000 If fs.tube ^= "" Then Do 02880000 /* "Can't set bookmarks from this screen." */ 02890000 'CALLPIPE COMMAND XMITMSG 43 (APPLID GOP CALLER CLI ERRMSG' , 02900000 '| STEM MESSAGE. APPEND' 02910000 Return 02920000 End /* If .. Do */ 02930000 02940000 If booklist Then Do 02950000 'CALLPIPE COMMAND XMITMSG 42 I (APPLID GOP NOHEADER' , 02960000 '| SPEC /i / 1 1-* NEXT | VAR BOOKMARK.' || i 02970000 If rc = 0 Then 02980000 Address "COMMAND" 'GLOBALV SELECT GOPHER PUTP BOOKMARK.' || i 02990000 If rc = 0 Then 'CALLPIPE COMMAND XMITMSG 42 I' , 03000000 '(APPLID GOP CALLER CLI ERRMSG | STEM MESSAGE. APPEND' 03010000 /* "Bookmark" i "deleted." */ 03020000 Else 'CALLPIPE COMMAND XMITMSG 514 RC "GLOBALV"' , 03030000 '(APPLID GOP CALLER CLI ERRMSG | STEM MESSAGE. APPEND' 03040000 Return 03050000 End /* If .. Do */ 03060000 03070000 Address "COMMAND" 'GLOBALV SELECT GOPHER GET BOOKMARK.0' 03080000 If ^Datatype(bookmark.0,'N') Then bookmark.0 = 0 03090000 i = bookmark.0 + 1 03100000 bookmark.i = item 03110000 Address "COMMAND" 'GLOBALV SELECT GOPHER PUTP BOOKMARK.' || i 03120000 bookmark.0 = i 03130000 Address "COMMAND" 'GLOBALV SELECT GOPHER PUTP BOOKMARK.0' 03140000 03150000 If rc = 0 Then 'CALLPIPE COMMAND XMITMSG 41 I' , 03160000 '(APPLID GOP CALLER CLI ERRMSG | STEM MESSAGE. APPEND' 03170000 /* "Bookmark" i "saved." */ 03180000 Else 'CALLPIPE COMMAND XMITMSG 514 RC "GLOBALV"' , 03190000 '(APPLID GOP CALLER CLI ERRMSG | STEM MESSAGE. APPEND' 03200000 03210000 Return 03220000 03230000 03240000 03250000 /* ------------------------------------------------------------ BOOKLIST03260000 * Call GOPCLI to show the lit of bookmarks. 03270000 */ 03280000 BOOKLIST: 03290000 03300000 Address "CMS" 'GOPCLI (BOOKLIST' 03310000 03320000 Return 03330000 03340000 03350000 03360000 /* ----------------------------------------------------------------- FIX03370000 * Takes an inbound 3270 DS screen address (two bytes) 03380000 * and returns the equivalent byte offset in decimal. 03390000 */ 03400000 FIX: 03410000 Parse Arg o,. 03420000 Parse Var o 1 o1 2 o2 3 . 03430000 o1 = c2d(o1) 03440000 o2 = c2d(o2) 03450000 If o1 < 64 Then Return o1 * 256 + o2 03460000 Else Return (o1 // 64) * 64 + (o2 // 64) 03470000 03480000 03490000 03500000 /* ---------------------------------------------------------- WRITE_READ03510000 * Display what we have, then wait for user input and return it. 03520000 */ 03530000 WRITE_READ: Procedure Expose fs. 03540000 Parse Arg ws,wcc,wrt,. 03550000 If wcc = "" Then wcc = 'C3'x 03560000 /* If wrt = "" Then wrt = 'C0'x */ 03570000 If wrt = "" Then wrt = fs.write 03580000 ws = wrt || wcc || ws 03590000 'CALLPIPE VAR WS | FULLSCR' fs.tube '| VAR RS' 03600000 If rc ^= 0 Then rs = '000000'x 03610000 Return rs 03620000 03630000 03640000 03650000 /* ----------------------------------------------------------------- SBA03660000 * (a better SBA function extracted from PIPEDEMO; thanks, Chuck!) 03670000 * Construct Set Buffer Address order from row and column. 03680000 */ 03690000 03700000 SBA: Procedure Expose fs. 03710000 03720000 arg row , col, . 03730000 row = Trunc(row) 03740000 col = Trunc(col) 03750000 03760000 /*-----------------------------------------------------------------*/ 03770000 /* Calculate binary address. */ 03780000 /*-----------------------------------------------------------------*/ 03790000 03800000 offset = row * fs.scrcols + col 03810000 Do While offset < 0; offset = offset + fs.scrrows * fs.scrcols; End 03820000 03830000 if fs.14bit then return '11'x || d2c(offset,2) 03840000 03850000 /*-----------------------------------------------------------------*/ 03860000 /* Convert to six-bit format. (xxxx111111111111 -> 0011111100111111*/ 03870000 /*-----------------------------------------------------------------*/ 03880000 03890000 'CALLPIPE var offset' , /* Start with char number. */03900000 '| spec 1-* d2c 1.2 right' , /* Convert to binary. */03910000 '| spec 1-* c2b 1' , /* Convert to bit string. */03920000 '| spec /00/ 1 5.6 3' , /* Place first six bits. */03930000 '/00/ 9 11.6 11' , /* Place second six bits. */03940000 '| spec 1-* b2c 1' , /* Convert back to binary. */03950000 '| xlate *-* 00-3F 40-7F' , /* Translate to coded */03960000 '01-09 C1-C9' , /* buffer address. */03970000 '11-19 D1-D9' , /* */03980000 '22-29 E2-E9' , /* */03990000 '30-39 F0-F9' , /* */04000000 '| spec x11 1 1.2 2' , /* Prefix with SBA order. */04010000 '| var offset' /* Put back in variable. */04020000 04030000 Return offset 04040000 04050000 04060000 04070000 /* --------------------------------------------------------------- FIELD04080000 * Generate the 3270 DS sequence for extended field attributes 04090000 * (if available). 04100000 */ 04110000 FIELD: Procedure Expose fs. 04120000 a = '00'x 04130000 b = '00'x 04140000 c = 'F1'x 04150000 i = 1 04160000 Do While Arg(i) ^= "" 04170000 Select /* at */ 04180000 When Abbrev("PROTECTED",Arg(i),2) Then a = bitor(a,'20'x) 04190000 When Abbrev("SKIP",Arg(i),1) Then a = bitor(a,'10'x) 04200000 When Abbrev("NODISPLAY",Arg(i),1) Then a = bitor(a,'0C'x) 04210000 When Abbrev("HIGH",Arg(i),1) Then a = bitor(a,'08'x) 04220000 When Abbrev("BLINK",Arg(i),3) Then b = bitor(b,'01'x) 04230000 When Abbrev("REVERSE",Arg(i),3) Then b = bitor(b,'02'x) 04240000 When Abbrev("UNDERLINE",Arg(i),1) Then b = bitor(b,'04'x) 04250000 When Abbrev("BLUE",Arg(i),3) Then c = 'F1'x 04260000 When Abbrev("RED",Arg(i),3) Then c = 'F2'x 04270000 When Abbrev("PINK",Arg(i),1) Then c = 'F3'x 04280000 When Abbrev("GREEN",Arg(i),1) Then c = 'F4'x 04290000 When Abbrev("TURQUOISE",Arg(i),1) Then c = 'F5'x 04300000 When Abbrev("YELLOW",Arg(i),1) Then c = 'F6'x 04310000 When Abbrev("WHITE",Arg(i),1) Then c = 'F7'x 04320000 Otherwise nop 04330000 End /* Select at */ 04340000 i = i + 1 04350000 End /* Do While */ 04360000 04370000 If ^fs.color | , 04380000 ^fs.exthi Then Return '1D'x || bitor(a,'40'x) 04390000 Else Return '2902'x || , 04400000 'C0'x || bitor(a,'40'x) || , 04410000 '42'x || bitor(c,'40'x) 04420000 04430000 04440000 04450000 /* ---------------------------------------------------------------- GTAG04460000 * Match the gopher data type to a national language "tag" string. 04470000 */ 04480000 GTAG: Procedure 04490000 04500000 Parse Arg type 04510000 04520000 Select /* type */ 04530000 04540000 When type = '0' Then _tag = 700 04550000 When type = '1' Then _tag = 701 04560000 When type = '2' Then _tag = 702 04570000 When type = '3' Then _tag = 703 04580000 When type = '4' Then _tag = 704 04590000 When type = '5' Then _tag = 705 04600000 When type = '6' Then _tag = 706 04610000 When type = '7' Then _tag = 707 04620000 When type = '8' Then _tag = 708 04630000 When type = '9' Then _tag = 709 04640000 When type = 's' Then _tag = 767 04650000 When type = 'r' Then _tag = 766 04660000 When type = 'v' Then _tag = 770 04670000 When type = 'i' Then _tag = 757 04680000 When type = 'I' Then _tag = 725 04690000 When type = 'g' Then _tag = 755 04700000 When type = 'M' Then _tag = 729 04710000 When type = 'T' Then _tag = 736 04720000 04730000 When type = ':' Then _tag = 710 04740000 When type = ';' Then _tag = 711 04750000 When type = '<' Then _tag = 712 04760000 04770000 Otherwise _tag = 908 04780000 04790000 End /* Select type */ 04800000 04810000 'CALLPIPE COMMAND XMITMSG' _tag 'TYPE (APPLID GOP NOHEADER | VAR TAG' 04820000 04830000 Return tag 04840000 04850000 04860000 04870000 /* ---------------------------------------------------------------- HELP04880000 * Invoke CMS HELP for GOPHER BROWSER (the menu browser). 04890000 */ 04900000 HELP: Procedure Expose fs. message. 04910000 04920000 If fs.tube ^= "" Then 04930000 'CALLPIPE COMMAND HELP GOPHER BROWSER (ALL NOSCREEN' , 04940000 '| GOPCLIFV BROWSER HELP' , 04950000 '| STEM MESSAGE. APPEND' 04960000 04970000 Else Do 04980000 Address "COMMAND" 'HELP GOPHER BROWSER' 04990000 Address "COMMAND" 'VMFCLEAR' 05000000 End /* Else Do */ 05010000 05020000 Return 05030000 05040000