Columbia Kermit

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

/ Columbia Kermit / kermit.zip / ibm370 / ikmutl.asm < prev next >

Wrap

Assembly Source File | 2020-01-01 | 128KB | 1,578 lines

*COPY IKMUTL 05000000 CHECKVER IKCUTL,4.3 @SC90072 05000500 TITLE 'CWDSET/DSPACE Routines - set/show working directory' 05001000 * Set new 'working directory', i.e., new code (need LSCAN or FILES) 05002000 * Entry: SCANPTR string has option 05003000 * Exit: R15=0 if ok, R15=1 if error or help needed. ERRNUM unchanged. 05004000 CWDSET ENTER @SC86164 05005000 NTOKN N=CWDRSET,H=CWDERR 05006000 C 7,F3 Length MUST be 4 05007000 BNE CWDERR 05008000 TM UPRIVS,LSCAN+FILES Need some priveleges to 05009000 BZ CWDPRV change code 05010000 MVC UCODE(4),0(6) Save as new default code 05012000 TR UCODE(4),UPCASE Upper case it @SC91033 05012500 MVI DESTL,1 Yes, new code 05013000 B RTRN0 @SC86295 05014000 CWDPRV PTEXT '&CWDPRVS' @SC92300 05015000 B SUBERR 05016000 CWDRSET MVI DESTL,0 No more code. Default to user's 05017000 MVC UCODE(4),$USRCDE Get user's code from locore 05018000 B RTRN0 05019000 CWDERR PTEXT '&CWDERRM' @SC92300 05020000 B SUBERR Go display error msg 05021000 * * * * * * * * * * * * * * * * * * * * * * 05022000 * 05023000 * 05024000 * DSPACE Routine - display available disk space @SC86164 05025000 * 05026000 * Show space available in 'working directory' or other area 05027000 * Entry: SCANPTR string has option (none => working directory) 05028000 * Exit: R15=0 if ok, R15=1 if error or help needed. ERRNUM unchanged 05029000 DSPACE ENTER ALT @SC86164 05030000 MFSET DSKST,USERCTL 05031000 MFREQ DSKST Get User Control Record 05032000 LA 15,PARMAREA Temporary output buffer 05033000 L 4,MFMAXS Calculate space in use 05034000 S 4,MFACUR 05035000 BAL 2,EDDEC Convert to printable 05036000 INITSTR '&KBYTFRE' @SC92300 05037000 LR 0,15 @SC92300 05038000 LA 1,PARMAREA 05039000 SR 0,1 05040000 WTEXT (1),(0) Display the message 05041000 B RTRN0 05042000 LOCALS , @SC86295 05043000 EXIT , @SC86295 05044000 TITLE 'FSPEC Routine - extract filespec from scan string' 05045000 * 05046000 * Entry: R1->name field, R0=flags selecting operation (see below) 05047000 * For parse operations, SCANPTR defines the input string. 05048000 * For getting foreign or display filespec, R7->output buffer 05049000 * Exit: if not FFNEW, then R15=0 if ok, 1 if ?, 2 if bad. 05050000 * For R15=1 or 2 R3,R4 give message. ERRNUM may be leftover. 05051000 * 05052000 * Flags: Notes: 05053000 * Tasks: FFRCF FFSND FFGET FFNEW 05054000 * Parse RECV X set ROVR properly 05055000 * Parse SEND 1st X 05056000 * Parse SEND 2nd X X 05057000 * Parse GET 1st X 05058000 * Parse GET 2nd X X set ROVR properly 05059000 * Parse F-packet (FFHDR) X X X 05060000 * Parse for Generic(FFUTL) X X FFWLD: allow partial 05061000 * Parse TAKE 05062000 * 05063000 * Get unique name X R15: 0=>ok, 1=>bad 05064000 * Interactive name check X X R15: 0=>ok, 1=>bad 05065000 * Get foreign name (FFENC) X X R15->end of string 05066000 * Get display form (FFDSP) X X R15->end of string 05067000 * 05068000 FSPEC ENTER @SC86295 05069000 STC 0,FSPFLG @SC86295 05070000 LR 5,0 @SC88049 05071000 SRL 5,4 Convert flags to index @SC88049 05072000 AR 5,5 @SC88049 05073000 LR 0,1 Copy ptr to filespec @SC86295 05074000 TM FSPFLG,FFNEW @SC86295 05075000 BO FSPWRN @SC86295 05076000 MVC 0(LFID,1),BLNAME Clear the filename to blanks 05077000 PTEXT '&BADFSPC' @SC92300 05078000 MVI ERRNUM,ERRFNE Assume bad file name @SC86158 05079000 LH 5,FSP0(5) Get dispatch adr @SC88049 05080000 B FSP0(5) Go to proper handler @SC88049 05081000 * 05082000 * Take Get 1st Send 1st Generic 05083000 FSP0 DC AL2(FSPTAK-FSP0,FSPSN2-FSP0,FSPSND-FSP0,FSPUTL-FSP0) 05084000 * 05085000 * Receive Get 2nd Send 2nd F-packet 05086000 DC AL2(FSPRC-FSP0,FSPRC-FSP0,FSPSN2-FSP0,FSPHD-FSP0) 05087000 SPACE 05088000 FSPUTL TM FSPFLG,FFWLD Utility: default to all files? @SC88049 05089000 BZ FSPASC No @SC86295 05090000 MVC 0(5,1),UCODE Default prefix 05091000 MVI 5(1),C'*' Yes @SC88308 05092000 FSPSND DS 0H 05093000 FSPASC TM FL2,SRV Server mode? @SC86295 05094000 BZ FSPCPY No, don't need to convert @SC86295 05095000 ICM 15,15,LEN Get length @SC86295 05096000 BZ FSPCPY @SC86295 05097000 BCTR 15,0 Correct for EX @SC86158 05098000 L 5,ADR Get string ptr @SC89215 05099000 EX 15,FSPTRAE Change to EBCDIC @SC89215 05100000 EX 15,FSPTRUP Upcase and dot to space @SC89215 05101000 B FSPCPY @SC86295 05102000 FSPTRAE TR 0(,5),ATOED @SC89301 05102300 FSPTRUP TR 0(,5),UPCASE @SC89215 05102600 FSPRC NI FL1,255-ROVR Setup for RECEIVE @SC86295 05103000 NI FL4,255-NMOK-NMCHNG Collision not checked yet @SC90033 05104000 MVI 0(1),C'$' Default fn @SC88308 05105000 B FSPCPY @SC86295 05106000 FSPHD MVI 0(1),C'$' Default fn @SC88308 05107000 L 2,ADR @SC86295 05108000 IC 7,4(2) Save possible code separator @SC88308 05109000 TR 0(256,2),FSPTAB Make valid fn chars @SC86295 05110000 CLM 7,1,=C':' Was it a separator? @SC91316 05111000 BNE *+8 @SC88308 05112000 STC 7,4(2) Yes, change char. back to colon @SC88308 05113000 B FSPCPY @SC86295 05114000 FSPSN2 MVI 0(1),0 Clear JFSPEC length !!! 05115000 CLI BRK,C',' @PG88306 05116000 BE RTRN0 Foreign name omitted @PG88306 05117000 NTOKN H=FSP2H,N=RTRN0 05118000 LA 7,1(7) Not machine length ! 05119000 LA 1,L'JFNAM Get maximum length 05120000 CLM 7,3,*-2 Does it fit? @SC86224 05121000 BNH *+6 Yes @SC86224 05122000 LR 7,1 Use what we can @SC86224 05123000 LR 3,0 @SC86295 05124000 STC 7,0(3) Save length @SC86224 05125000 LA 0,1(3) @SC86295 05126000 MVCL 0,6 Get fn, at least @SC86224 05127000 B RTRN0 @SC86295 05128000 * 05129000 FSPTAK DS 0H 05130000 FSPCPY NTOKN H=FSPH,N=FSPZ 05131000 LR 8,0 Save start 05133000 KCALL FOPSTR,LFID(,8),E=FSPINV @SC89218 05133300 LA 1,LFID Get max length 05133600 CLI 4(6),C':' Code prefix ? 05134000 BE FSPCPC 05135000 LR 2,0 05136000 MVC 0(5,2),UCODE Add the user code 05137000 LA 0,5(2) Point past code prefix 05138000 S 1,F5 Reduce receiving length 05139000 FSPCPC TM FSPFLG,FFRCF 05140000 BZ FSPCPN @SC86295 05141000 OI FL1,ROVR Overwrite received fname @SC86295 05142000 FSPCPN LA 7,1(7) 05143000 ICM 7,8,BLANK 05144000 MVCL 0,6 Copy token with padding 05145000 CLM 7,7,F0 Hope nothing left over! 05146000 BNE FSPINV Name was too long 05147000 TR 0(LFID,8),UPCASE Ok, now upcase it 05148000 B RTRN0 @SC86295 05149000 * 05150000 FSPZ LR 14,0 @SC86295 05151000 CLI 0(14),C' ' Any default given? @SC86295 05152000 BH RTRN0 Yes, use it @SC86295 05153000 FSPMIS PTEXT '&NOFSPEC' @SC92300 05154000 FSPINV LA 15,2 @SC86295 05155000 B FSPPTRS @SC86295 05156000 * 05157000 FSPH PTEXT '&FMTFSPC&FSPCPRM' @SC91224 05158000 CLI FSPFLG,FFSND SEND 1st? @SC89218 05158200 BE *+8 Yes, use whole message @SC89218 05158400 SH 4,=H'&FMTOPT' Chop off option part @SC92300 05158600 B FSP0H @SC86295 05159000 FSP2H PTEXT '&FORFSPC' @SC86295 05160000 FSP0H LA 15,1 @SC86295 05161000 FSPPTRS RETREG 3,4 Return msg ptrs @SC86295 05162000 FSPRET RET , @SC86295 05164000 * 05165000 * Non-parsing functions . . . 05166000 * 05167000 * Get unique filespec 05168000 FSPWRN LR 4,1 Save name ptr @SC86295 05169000 TM FSPFLG,FFENC @SC86295 05170000 BO FSPENC Encode name into buffer @SC86295 05171000 TM FSPFLG,FFDSP @SC86295 05172000 BO FSPDSP Copy name into buffer for display @SC86295 05173000 TM FL4,NMOK Already checked? @SC87012 05174000 BO RTRN0 Yes, ok @SC87012 05175000 MVC XFILE,0(1) Save original name @SC90033 05175500 LA 6,LFID-2(1) End of FT 05176000 BCTR 6,0 @BS86001 05177000 CLI 0(6),C' ' Find end of token @BS86001 05178000 BE *-6 @BS86001 05179000 LA 5,10+1 Allowed retries @BS86001 05180000 LA 7,C'0' Extra character @BS86001 05181000 OI FL4,NMOK Assume it checks @SC87012 05182000 FSPSTA OPENF T,(4),E=RTRN0 Does it exist already? @SC86135 05183000 OI FL4,NMCHNG Yes, remember collision occurred @SC90033 05183500 MVI 1(6),C'$' Yes, modify Fn 05184000 STC 7,2(6) Serialize @BS86001 05185000 LA 7,1(7) Bump counter @BS86001 05186000 BCT 5,FSPSTA @BS86001 05187000 PTEXT '&FILCLSN' @SC88049 05188000 B FSP0H Return error code @SC88049 05189000 * 05190000 * Encode name at (R1) into (R7) buffer (in ASCII), possibly with 05191000 * substitution from JFSPEC, but disable subsequent subst. 05192000 * Return updated ptr in R15 05193000 FSPENC LA 1,JFSPEC Complex string? @SC86224 05194000 BAL 14,PAKFOR @SC86224 05195000 LR 15,7 Save ptr 05196000 BNZ FSPFILS Yes, tokens aren't used @SC86224 05197000 MVC 0(LFID,7),BLNAME 05198000 MVC 0(17,7),5(4) Copy filename Only 05199000 CLI 4(4),C':' Is there a code prefix ??? 05200000 BE *+10 05201000 MVC 0(LFID,7),0(4) Copy token 05202000 LA 1,LFID(7) End of token if no blanks 05203000 TRT 0(LFID,7),TRTBL Find 1st blank 05204000 TR 0(LFID,7),ETOAD ASCII it @SC89301 05205000 LR 15,1 New end of string 05206000 FSPFILS MVI JFSPEC,0 Turn off string @SC86224 05207000 B FSPRET @SC86295 05208000 * 05209000 * Copy name at (R1) into (R7) buffer in display form 05210000 * Return updated ptr in R15 05211000 FSPDSP MVC 0(LFID,7),0(4) Copy token 05212000 CLI 4(4),C':' Prefix already ? 05213000 BE FSPDTK3 05214000 MVC 0(5,7),UCODE Get prefix 05215000 MVC 5(LFID-5,7),0(4) 05216000 FSPDTK3 LA 1,LFID(7) End of token if no blanks 05217000 TRT 0(LFID,7),TRTBL Find 1st blank 05218000 LR 15,1 New end of string 05219000 B FSPRET 05220000 * 05221000 * Valid MUSIC file name characters 05222000 FSPTAB DC 75C'$',C'.' dot 05223000 DC 15C'$',C'$' dollar sign 05224000 DC 31C'$',C'#@' pound sign, at sign @SC88308 05225000 DC 04C'$',C'ABCDEFGHI' a-i 05226000 DC 07C'$',C'JKLMNOPQR' j-r 05227000 DC 08C'$',C'STUVWXYZ' s-z 05228000 DC 23C'$',C'ABCDEFGHI' A-I 05229000 DC 07C'$',C'JKLMNOPQR' J-R 05230000 DC 08C'$',C'STUVWXYZ' S-Z 05231000 DC 06C'$',C'0123456789' 0-9 05232000 DC 06C'$' 05233000 LOCALS , @SC86295 05234000 FSPFLG DS X Filespec flags @SC86295 05235000 FSPEC EXIT @SC86295 05236000 TITLE 'KHELP routine - perform HELP command' 05237000 * Handle HELP command, rest of string given by SCANPTR. 05238000 KHELP ENTER , @SC86355 05239000 PTEXT 'LIST *COM:SYSTEM.KERMHELP',AREG=0,LREG=6 @SC88308 05240000 NI FL4,255-UCMD Signal ptrs in R0,R6 @SC88308 05241000 KCALL SUPFNC,3 Execute HOST command @SC88308 05242000 B RTRN @SC88308 05243000 LOCALS , 05244000 KHELP EXIT , @SC87007 05245000 TITLE 'SUPFNC Routine - various supervisor functions' @SC86158 05246000 SUPFNC ENTER @SC86295 05247000 * On entry, R1 = operation code, R0 = possible ptr @SC86158 05248000 * Exit: R15 set (0 => ok, <0 => illegal cmd, >0 => depends) 05249000 * ERRNUM set appropriately (R1=1,3,4) or unchanged (2,5-11) 05250000 * 1 -> Start typeout interception. N.B. &MAXLR >> 2048 for this 05251000 * 2 -> Clean up afterwards and stop interception 05252000 * 3 -> Execute host command with or without interception 05253000 * If UCMD set, SCANPTR gives text, else R0->text,R6=len 05254000 * 4 -> Execute CP command with or without interception 05255000 * R0->text, R6=len 05256000 * 5 -> Stop interception if going 05257000 * 6 -> Retrieve original cmd parm string into CBUF (R15=1 if null) 05258000 * 7 -> Test for stacked lines, return number in R15 05259000 * 8 -> Log off (doesn't return!) 05260000 * 9 -> Wait specified time 05261000 * 10-> Return clock time in R15 (centisec) 05262000 * 11-> Setup up new prompt string at (R0) 05263000 BCT 1,ICPFIN @SC86158 05264000 * Start interception, initialize ptrs @SC86158 05265000 MVI ERRNUM,ERRNOE OK @SC86158 05266000 L 1,WBUF Output buffer @SC90264 05267000 LA 0,2048(,1) Skip over some, to be safe @SC90264 05268000 A 1,F64KP End of buffer @SC90264 05269000 LR 15,0 @SC86158 05270000 STM 15,0,TXTPTR Save @SC86158 05271000 STM 0,1,SVCOPTR @SC86158 05272000 SR 1,0 Get length @SC86158 05273000 L 15,=X'15000000' @SC86158 05274000 MVCL 0,14 Fill with NL (X'15') @SC86158 05275000 OI SVCFLG,INTERCPT Interception in Progress 05276000 B RTRN0 @SC86295 05277000 * Clean up after interception @SC86295 05278000 ICPFIN BCT 1,ICPHST @SC86158 05279000 L 5,SVCOPTR End of text @SC86158 05280000 ST 5,TXTPTR+4 Save @SC86158 05281000 NI SVCFLG,255-INTERCPT Stop interception 05282000 B RTRN0 05283000 * Stop interception if going 05284000 ICPRST BCT 1,SFCLIN 05285000 NI SVCFLG,255-INTERCPT Stop interception 05286000 B RTRN0 05287000 * Execute host command. Save return code. @SC88308 05288000 ICPHST BCT 1,ICPCP @SC86158 05289000 TM FL4,UCMD @SC88308 05290000 BO *+12 @SC88308 05291000 ST 0,ADR Ptrs are in R0,R6 @SC88308 05292000 ST 6,LEN @SC88308 05293000 NTOKN N=SFCHBAD @SC88308 05294000 SCAN HSTCMDS,RTRN0 Dispatch to handler @SC88308 05295000 SFCHBAD MVI ERRNUM,ERRSYS Illegal system command @SC90223 05296000 HELP HSTCMDS,RTRNM1 @SC90223 05296500 * 05297000 HSTCMDS KW 'LIBRARY',SFCDIR,MIN=3 @SC88308 05298000 KW 'COPY',SFCCOP,MIN=4 @SC88308 05299000 KW 'PURGE',SFCDEL,MIN=3 @SC88308 05300000 KW 'RENAME',SFCREN,MIN=3 @SC88308 05301000 KW 'LIST',SFCTYP @SC88308 05302000 KW , @SC88308 05303000 * 05304000 SFCDIR LA 3,13 DISKIO dir function code @SC88308 05305000 B SFCUTL @SC88308 05306000 SFCDEL LA 3,14 DISKIO del function code @SC88308 05307000 B SFCUTL @SC88308 05308000 SFCREN LA 3,15 DISKIO ren function code @SC88308 05309000 B SFCUTL @SC88308 05310000 SFCCOP LA 3,16 DISKIO cop function code @SC88308 05311000 B SFCUTL @SC88308 05312000 SFCTYP LA 3,17 DISKIO typ function code @SC88308 05313000 * B SFCUTL @SC88308 05314000 SFCUTL SR 0,0 @SC88308 05315000 KCALL FSPEC,FILNAM,E=SUBERR @SC88308 05316000 CH 3,=H'14' @SC88308 05317000 BNH SFCUT1 Dir/lib or del/pur @SC88308 05318000 CH 3,=H'17' @SC88308 05319000 BE SFCUT1 Type/list @SC88308 05320000 SR 0,0 @SC88308 05321000 KCALL FSPEC,IFILE,E=SUBERR Get 2nd file name @SC88308 05322000 SFCUT1 FTOKN N=SFCUT6 See if anything else in command @SC88308 05323000 PTEXT '&NOOPERS' @SC88308 05324000 B SUBERR @SC88308 05325000 SFCUT6 LR 0,3 Get function code @SC88308 05326000 LA 2,IFILE Optional 2nd name @SC88308 05327000 KCALL DISKIO,FILNAM Do it @SC88308 05328000 * Issue return code msg if needed @SC86295 05328060 SFCRC LTR 4,15 Check RC @SC90264 05328120 BZ SFCZRC RC=0 @SC86158 05328180 TM FL4,UCMD User cmd? @SC86316 05328240 BZ RTRN No. No message, just rc in R15 @SC90264 05328300 MVC CMD(2),=C'R(' Set up message @SC86209 05328360 LA 15,CMD+2 @SC86209 05328420 BAL 2,EDDEC Edit RC into msg @SC86295 05328480 MVI 0(15),C')' Format is R(rc) @SC86209 05328540 LA 0,1(15) @SC86268 05328600 LA 1,CMD Start of edited string @SC86209 05328660 SR 0,1 Length @SC86268 05328720 WTEXT (1),(0) @SC86268 05328780 SFCZRC LR 15,6 @SC86295 05328840 MVI ERRNUM,ERRNOE No errors @SC86295 05328900 B RTRN @SC88308 05329000 * Execute CP command at (R0) with text interception @SC86158 05330000 ICPCP BCT 1,ICPRST @SC86158 05331000 WTEXT '&NOCPCMD' @SC92300 05332000 B RTRN0 05333000 * 05334000 SFCLIN BCT 1,SFCSTK @SC86295 05335000 * Retrieve original command line arguments, if any @SC86295 05336000 * Return code =0 if yes, =1 if no @SC86295 05337000 * Leave string in CBUF buffer (up to 256), length in CLEN @SC86295 05338000 L 1,ORGR1 Get original R1 05339000 L 1,0(,1) 05340000 LH 2,0(,1) Get command line parm length 05341000 LA 3,2(,1) Get address of parms 05342000 LTR 5,2 Any parms? @SC91121 05343000 BZ RTRN1 05344000 LA 3,0(2,3) Now, backscan the command line 05348000 SFCLIN3 BCTR 3,0 buffer to check if there is really 05349000 CLI 0(3),C' ' something. MUSIC should have set the 05350000 BNE SFCLIN4 length to 0, but under DEBUG, we 05351000 BCT 2,SFCLIN3 get a blank line of length 80 !!! 05352000 B RTRN1 05353000 SFCLIN4 L 6,GTPB Start of save buffer @SC91121 05353200 MVC 0(128,6),2(1) Copy maximum chunk @SC91121 05353400 STM 5,6,GTPB+4 Save new length and starting point@SC91121 05353600 B RTRN0 @SC91121 05353800 * 05354000 * Test for stacked commands @SC86295 05355000 * return code = number of stacked lines @SC86295 05356000 SFCSTK BCT 1,SFCKIL @SC86295 05357000 ICM 15,15,GTPB+4 Anything in line buffer? 05358000 BH RTRN1 There's one line, at least 05359000 B RTRN0 Nothing stacked 05360000 * 05361000 * Log out @SC86295 05362000 SFCKIL BCT 1,SFCWT @SC86295 05363000 LA 1,OFFARG Schedule a signoff to the system 05364000 SVC 237 $SETSAV 05365000 LA 15,0 And abort the job right away. 05366000 SVC $EOJ 05367000 B RTRN 05368000 * 05369000 * Wait specified time in R0 (sec) 05370000 SFCWT BCT 1,SFCCLK Tell MUSIC to delay for x seconds 05371000 SVC $DLYEXC 05372000 B RTRN0 @SC86295 05373000 * 05374000 * Return time in centisec in R15 05375000 SFCCLK BCT 1,SFCPRP @SC87351 05376000 STCK TMPDW Store TOD clock @SC86295 05377000 LM 14,15,TMPDW @SC86295 05378000 SLDL 14,8 Take mod 204 days @SC86295 05379000 SRDL 14,20 Get in microsec @SC86295 05380000 D 14,=F'10000' Get in centisec @SC86295 05381000 B RTRN @SC86295 05382000 * 05383000 SFCPRP B RTRN0 No action for prompting @SC87351 05384000 OFFARG DC CL6'/OFF**',X'A0' 05385000 LOCALS , @SC86295 05386000 SUPFNC EXIT @SC86158 05387000 TITLE 'Interception Code' 05388000 * 05389000 * Entry: R0->Length of string to write, R1->Address of string 05390000 * 05391000 * Exit: Always R15=0 05392000 * 05393000 ICPTYP ENTER 05394000 LR 2,0 Get length in R2 05395000 LM 3,4,SVCOPTR Yes, then add the line just 05396000 SR 4,3 built to the interception buffer 05397000 CR 2,4 Any room left ? 05398000 BH RTRN0 05399000 BCTR 2,0 05400000 EX 2,ICPMV Move the line to the output buffer 05401000 LA 2,1(2) 05402000 LA 3,1(2,3) Update the source pointer 05403000 ST 3,SVCOPTR Save it 05404000 B RTRN0 05405000 ICPMV MVC 0(0,3),0(1) 05406000 LOCALS , 05407000 ICPTYP EXIT , 05408000 TITLE 'SETMSG Routine - controls CP breakin' 05409000 * Entry: R1 selects operation 05410000 * Exit: R15=0 if ok 05411000 * 1-> Analyze user environment, determine if suitable. 05412000 * Save quantities needed and condition line for entering commands. 05413000 * Perform any system-dependent initialization. 05414000 * 2-> Condition line for protocol transfers. 05415000 * 3-> Decondition line at end of transfer. 05416000 * 4-> System-dependent clean-up at exit. 05417000 * 5-> Reperform system-dependent initialization after SET LINE. 05418000 SETMSG ENTER , 05419000 BCT 1,STM2 Go if R1 not 1, so no init 05420000 MFARG 0,RLAB=ZRC,ULAB=ZLU @PG90057 05421000 MFARG NAME=MFNAME,INFIN=ZINFIN,INFOUT=ZINFOUT,ARG=ZARG 05422000 MFARG PHYS=ZPHYS,UCTL=ZUCTL,UINFO=ZUINFO,TAG=MFTAG 05423000 MFARG XINFO=ZXINFO @SC92086 05423500 MFARG EOFPT=ZEOFPT,FSARG=ZFSARG 05424000 MFGEN AREA=DSKST 05425000 MVC UCODE(4),$USRCDE Get the user's code 05426000 MVI UCODE+4,C':' Set up 5-char prefix string 05427000 MVI SCODE+4,C':' Ditto @SC88308 05428000 LA 1,STMNOPR 05429000 SVC $SETOPT Disable prompting 05430000 LA 1,STMTXLC 05431000 SVC $SETOPT Allow lower case input 05432000 * 05432300 STM5X DS 0H Now set up controller type @SC90173 05432600 MVI TRMTP,C'T' 1st assume TTY @SC88203 05433000 TM $TRMTYP,X'20' Check the terminal type 05434000 BZ RTRN0 05435000 SR 1,1 Assume Query not allowed @SC91311 05436000 O 1,=A(&CONOPTS) Options @SC91311 05437000 KCALL SETCON Find out just what kind... @SC91311 05438000 B RTRN0 05456000 * Condition Line for protocol transfers 05457000 STM2 BCT 1,STM3 05458000 CLI S1HND,XON User want special one anyway ? 05461000 BNE STM2X 05462000 BAL 14,TTYCHK TTY terminals can't change hndshk @SC92030 05463000 MVI S1HND,0 System provides the handshake @SC87343 05463500 STM2X B RTRN0 05464000 * Decondition line at end of transfer 05465000 STM3 BCT 1,STM4 @SC86316 05466000 B RTRN0 05467000 * System cleanup at exit 05468000 STM4 BCT 1,STM5 Special clean-up @SC87351 05469000 LA 1,STMPRMT Turn on prompting 05470000 SVC $SETOPT 05471000 LA 1,STMTXUC Fold lower case to upper case 05472000 SVC $SETOPT 05473000 B RTRN0 Special clean-up done 05474000 * 05475000 STM5 DS 0H Re-init after SET LINE @SC87351 05476000 MVI TRMTP,C'N' Assume bad until validated @SC90173 05476100 CLI TRMLIN,C' ' External line? @SC87351 05476200 BE STM5X No, use terminal @SC90173 05476300 B RTRN1 Other lines not allowed @SC90173 05476400 * 05477000 STMNOPR DC X'A0',AL1(1,3,6) Turn off Prompting 05478000 STMPRMT DC X'A0',AL1(0,3,6) Turn on Prompting 05479000 STMTXLC DC X'A0',AL1(1,1,6) Text Lower Case Input 05480000 STMTXUC DC X'A0',AL1(0,1,6) Text Upper Case Input 05481000 * 05482000 LOCALS , 05485000 SETMSG EXIT 05486000 TITLE 'GETLIN Routine - Get a line from terminal' @SC87015 05487000 * Entry: R1->buffer of length 256 @SC87015 05488000 * Exit: Buffer filled, R0=length, R15=0 if ok. Else R15=1. @SC87015 05489000 GETLIN ENTER @SC87015 05490000 LR 8,1 Save buffer ptr @SC88095 05491000 LA 9,256 For copying @SC88095 05492000 LM 4,6,GTPB Saved ptrs: start, length, current 05493000 LTR 5,5 Already got something? @SC88095 05494000 BNZ GTL1 Yes, return it @SC87015 05495000 TGET (4),130 Read a line from the terminal 05496000 SLR 2,2 Clear length for return 05497000 LA 5,0(1,4) Point past the end 05498000 BCTR 5,0 Scan back for a non-blank 05499000 CLI 0(5),C' ' 05500000 BE *-6 05501000 LA 5,1(,5) 05502000 SR 5,4 Stripped length 05503000 BNH GTLA Null input 05504000 LR 6,4 Set current read ptr 05505000 ST 5,GTPB+4 Save new length 05506000 GTL1 LR 1,5 Length of stuff @SC88095 05507000 AR 1,4 End of buffer @SC88095 05508000 LR 0,1 Save end @SC88095 05509000 LR 2,1 @SC88095 05510000 SR 2,6 Length of text remaining @SC88095 05511000 BNP GTLA None, return length 0 @SC88095 05512000 SLR 4,4 @SC88095 05513000 IC 4,LNDLM Get delimiter @SC88095 05514000 LA 4,TRTBL(4) Ptr to delimiter char @SC88095 05515000 MVI 0(4),1 Set up to snag delims @SC88095 05516000 MVI TRTBL+C' ',0 And ignore blanks @SC88095 05517000 CR 2,9 Get shorter of 256 and string @SC88095 05518000 BNH *+6 @SC88095 05519000 LR 2,9 @SC88095 05520000 BCTR 2,0 Set up for EX @SC88095 05521000 EX 2,GTLTRT @SC88095 05522000 MVI 0(4),0 Now clear out table @SC88095 05523000 MVI TRTBL+C' ',1 And restore @SC88095 05524000 SR 1,6 Length of line @SC88095 05525000 LR 7,1 Set up MVCL @SC88095 05526000 CR 9,7 Get shorter of 256 and string @SC88095 05527000 BNH *+6 @SC88095 05528000 LR 9,7 @SC88095 05529000 LR 2,9 Length actually copied @SC88095 05530000 MVCL 8,6 @SC88095 05531000 AR 6,7 In case we couldn't use it all @SC88095 05532000 CR 6,0 Finished input? @SC88095 05533000 BNL GTLA Yes, release it @SC88095 05534000 LA 6,1(,6) Skip over linend char @SC88095 05535000 ST 6,GTPB+8 Next read ptr @SC88095 05536000 B GTLZ Return @SC88095 05537000 GTLA MVC GTPB+4,F0 Clear input indicator @SC87015 05538000 GTLZ RETREG (0,2) Return (2) as R0 @SC89218 05539000 B RTRN0 @SC87015 05541000 GTLTRT TRT 0(,6),TRTBL Find a delimiter @SC88095 05542000 LOCALS , @SC87015 05543000 GETLIN EXIT , @SC87015 05544000 TITLE 'TERMIO Routine - Handle terminal I/O' 05545000 * R1 points to a pair of (adr,len) for read or write. If I/O is 05546000 * successfull, R15 returns transferred byte count (else returns -1). 05547000 * Command code is in R0: 05548000 * 1 => Open line for I/O 4 => Write packet 05549000 * 2 => Close line 5 => Read packet 05550000 * 3 => Reset line status after ( 6 => Write message ) not used 05551000 * environment changes 05552000 * 05553000 TERMIO ENTER 05554000 STC 0,CONSOPR Save command code @SC92180 05554500 SR 15,15 OK @SC86295 05555000 BCT 0,TRMCLS @SC86295 05556000 * Open terminal line for protocol 05557000 MVI RIOC,X'80' Nothing saved @SC86295 05558000 MVI TRMFLG,X'FF' Initialize w/r flag @SC87275 05559000 CLI TRMTP,C'F' @SC92030 05559300 BE TRMSETF Full-screen stuff only @SC92030 05559600 LA 1,STMNOCR 05560000 SVC $SETOPT No CRLF added 05561000 LA 1,STMNOTR 05562000 SVC $SETOPT No translate Input 05563000 LA 1,STMNOER 05564000 SVC $SETOPT No *TRANSMISSION ERROR messages 05565000 CLI TIMOUT,0 Timeout wanted ??? 05566000 BE RTRN0 05567000 LA 1,STMTMOU 05568000 SVC $SETOPT Timeout on reads 05569000 B RTRN0 05570000 TRMSETF LA 1,STMNOEC @SC92030 05570200 SVC $SETOPT No echo of input @SC92030 05570400 B RTRN0 @SC92030 05570600 * Close terminal line after protocol transfer 05571000 TRMCLS BCT 0,TRMRSET @SC86295 05572000 LA 1,STMCRLF Reenable CRLF 05573000 SVC $SETOPT 05574000 LA 1,STMTRIN Reenable translation 05575000 SVC $SETOPT 05576000 LA 1,STMNOTM No timeouts 05577000 SVC $SETOPT 05578000 LA 1,STMTRER 05579000 SVC $SETOPT *TRANSMISSION ERROR messages allowed 05580000 LA 1,STMECHO @SC92030 05580300 SVC $SETOPT Allow echo of input @SC92030 05580600 B RTRN0 @SC86295 05581000 * (Re)set terminal characteristics to suit environment 05582000 TRMRSET BCT 0,TRMRW @SC86295 05583000 B RTRN0 @SC86295 05584000 * 05585000 * Perform I/O request 05586000 TRMRW BCT 0,TRMRD @SC87275 05587000 CLI WRRD,0 Write/read? @SC87275 05588000 BNE *+8 No, do it immediately 05589000 MVI TRMFLG,0 Indicate no action on follow-up 05590000 LM 2,3,0(1) Get buffer address + length 05591000 CLI TRMTP,C'F' Full-screen non-transparent? @SC92030 05591070 BNE TRMRWW No @SC92030 05591140 SR 0,0 Clear before every packet @SC92030 05591210 KCALL SCRNIO @SC92030 05591280 XI FL3,FCLRF Flip switch for skipping @SC92030 05591350 TM FL3,FCLRF Skipping now? @SC92030 05591420 BZ TRMRWX Not this time @SC92030 05591490 PTEXT ' ',LREG=4,AREG=5 Yes @SC92030 05591560 TPUT (5),(4) Skip two lines @SC92030 05591630 TPUT (5),(4) @SC92030 05591700 B TRMRWX Omit the special translation @SC92030 05591770 TRMRWW DS 0H @SC92030 05591840 BCTR 2,0 Backup to insert carriage control 05592000 MVI 0(2),X'41' No output translate PLEASE ! 05593000 LA 3,1(3) Fixup length for CC added 05595000 TRMRWX ST 2,TRMRBUF Set up I/O buffer for MFIO @SC92030 05595500 ST 3,TRMRLEN Set I/O length 05596000 MFREQ PRT 05597000 B TRMRWLG @SC92180 05598000 * 05599000 TRMRD TS TRMFLG @SC87275 05600000 BZ RTRN0 Just a follow-up. 0-length read @SC87275 05601000 LM 2,3,0(1) 05602000 C 3,AMAXRT Check for maximum length 05603000 BL TRMRD3 05604000 L 3,AMAXRT Not too long please... 05605000 TRMRD3 ST 2,TRMRBUF Setup I/O buffer for MFIO 05606000 ST 3,TRMRLEN Set I/O length 05607000 SLR 4,4 05608000 SLR 5,5 05609000 MVCL 2,4 Clear the input buffer 05610000 MFREQ TRM 05611000 TRMRWLG LA 1,TRMARG I/O block @SC92180 05612000 BAL 7,SCRLOGCM Log it @SC92180 05612100 L 5,TRMARSZ Get number of bytes read @SC92180 05612200 L 1,TRMRBUF Ptr to I/O buffer @SC92180 05612300 LR 2,5 I/O length @SC92180 05612400 BAL 7,SCRLOGD Log it @SC92180 05612500 TM CONSOPR,1 @SC92180 05612600 BZ RTRN0 Not a read, just say OK @SC92180 05612700 LTR 15,5 Get number of bytes read @SC92180 05612800 BNZ RTRN Ok, got a buffer 05613000 L 2,TRMRBUF 05614000 MVI 0(2),X'2B' Timeout !!! 05615000 B RTRN1 Return Length 1 05616000 * 05617000 STMNOCR DC X'A0',AL1(1,1,5) Turn off CRLF 05618000 STMCRLF DC X'A0',AL1(0,1,5) Turn on CRLF 05619000 STMNOTR DC X'A0',AL1(1,1,4) Turn off input translation 05620000 STMTRIN DC X'A0',AL1(0,1,4) Turn on input translation 05621000 STMTMOU DC X'A0',AL1(1,1,0) Turn on Timeout 05622000 STMNOTM DC X'A0',AL1(0,1,0) Turn off Timeout 05623000 STMNOER DC X'A0',AL1(0,1,7) Don't allow *TRANSMISSION ERROR msg 05624000 STMTRER DC X'A0',AL1(1,1,7) Allow *TRANSMISSION ERROR msg 05625000 STMNOEC DC X'A0',AL1(1,1,2) Don't echo input @SC92030 05625300 STMECHO DC X'A0',AL1(0,1,2) Echo input @SC92030 05625600 SPACE 05626000 *********************************************************************** 05627000 * * 05628000 * Reversing Table. Translate ASCII to reverse ASCII * 05629000 * * 05630000 *********************************************************************** 05631000 SPACE 1 05632000 * 0 1 2 3 4 5 6 7 8 9 A B C D E F 05633000 ATORA DC X'008040C020A060E0109050D030B070F0' 0 05634000 DC X'088848C828A868E8189858D838B878F8' 1 05635000 DC X'048444C424A464E4149454D434B474F4' 2 05636000 DC X'0C8C4CCC2CAC6CEC1C9C5CDC3CBC7CFC' 3 05637000 DC X'028242C222A262E2129252D232B272F2' 4 05638000 DC X'0A8A4ACA2AAA6AEA1A9A5ADA3ABA7AFA' 5 05639000 DC X'068646C626A666E6169656D636B676F6' 6 05640000 DC X'0E8E4ECE2EAE6EEE1E9E5EDE3EBE7EFE' 7 05641000 DC X'018141C121A161E1119151D131B171F1' 8 05642000 DC X'098949C929A969E9199959D939B979F9' 9 05643000 DC X'058545C525A565E5159555D535B575F5' A 05644000 DC X'0D8D4DCD2DAD6DED1D9D5DDD3DBD7DFD' B 05645000 DC X'038343C323A363E3139353D333B373F3' C 05646000 DC X'0B8B4BCB2BAB6BEB1B9B5BDB3BBB7BFB' D 05647000 DC X'078747C727A767E7179757D737B777F7' E 05648000 DC X'0F8F4FCF2FAF6FEF1F9F5FDF3FBF7FFF' F 05649000 *********************************************************************** 05650000 * * 05651000 * Reversing Table. Reverse ASCII to ASCII. Lose high order bit. * 05652000 * * 05653000 *********************************************************************** 05654000 SPACE 1 05655000 * 0 1 2 3 4 5 6 7 8 9 A B C D E F 05656000 RATOA DC X'00004040202060601010505030307070' 0 05657000 DC X'08084848282868681818585838387878' 1 05658000 DC X'04044444242464641414545434347474' 2 05659000 DC X'0C0C4C4C2C2C6C6C1C1C5C5C3C3C7C7C' 3 05660000 DC X'02024242222262621212525232327272' 4 05661000 DC X'0A0A4A4A2A2A6A6A1A1A5A5A3A3A7A7A' 5 05662000 DC X'06064646262666661616565636367676' 6 05663000 DC X'0E0E4E4E2E2E6E6E1E1E5E5E3E3E7E7E' 7 05664000 DC X'01014141212161611111515131317171' 8 05665000 DC X'09094949292969691919595939397979' 9 05666000 DC X'05054545252565651515555535357575' A 05667000 DC X'0D0D4D4D2D2D6D6D1D1D5D5D3D3D7D7D' B 05668000 DC X'03034343232363631313535333337373' C 05669000 DC X'0B0B4B4B2B2B6B6B1B1B5B5B3B3B7B7B' D 05670000 DC X'07074747272767671717575737377777' E 05671000 DC X'0F0F4F4F2F2F6F6F1F1F5F5F3F3F7F7F' F 05672000 TITLE 'SCRNIO Routine - Handle screen I/O via Series/1' 05675000 * R1 points to a pair of (adr,len) for read or write. If I/O is 05676000 * successfull, R15 returns transferred byte count (else returns -1). 05677000 * Command code is in R0: 05678000 * 0 => Clear screen on console (not comm line) @SC90045 05678500 * 1 => Open screen for I/O 4 => Write packet (gets ATTN) 05679000 * 2 => Close screen 5 => Read packet 05680000 * 3 => Reset screen status after 6 => Write message (no ATTN) 05681000 * environment changes 05682000 * 05683000 SCRNIO ENTER ALT @SC92180 05684000 XC ZFSARG(20),ZFSARG Clear FSIO Control Block 05685000 LR 6,1 Save ptr to plist @SC90222 05685100 LTR 0,0 @SC90045 05685300 BZ SCRCLR @SC90045 05685600 STC 0,CONSOPR Save command code @LP88158 05685700 BCT 0,SCRCLS @SC86295 05686000 * Set up for transparent I/O 05686020 L 1,=A(IDEFS) CSECT of initializations @SC90173 05686040 USING DEFS,1 Mapped via DSECT @SC90173 05686060 LA 2,S1DATA Series/1 introducer @SC90173 05686080 LA 3,S1ORDL+2 Length + 2 @SC90173 05686100 CLI TRMTP,C'S' @SC90173 05686120 BE SCRPRSET Do it @SC90173 05686140 LA 2,GRDATA Graphics introducer @SC90173 05686160 LA 3,GRDL+2 Length + 2 @SC90173 05686180 CLI TRMTP,C'G' @SC90173 05686200 BE SCRPRSET Do it @SC90173 05686220 LA 2,AEADAT AEA introducer @SC90173 05686240 LA 3,AEAL+2 @SC90173 05686260 DROP 1 @SC90173 05686280 SCRPRSET LR 5,3 @SC90173 05686300 LA 4,S1EOL+2 Get start of command buffer @SC90173 05686320 SR 4,5 @SC90173 05686340 STM 4,5,S1XOPL Set up prompt plist @SC90173 05686360 S 5,F2 Deduct stuff already there @SC90173 05686380 MVCL 4,2 @SC90173 05686400 MVI TRMFLG,X'FF' Initialize W/R flag @PG90058 05686500 MVI RIOPRP+4,255 Flag no interrupt pending @SC90222 05686700 SCRCLRA MVI FSFSFG,X'84' Write erase needed to setup FSIO @SC90045 05687000 MVI FSFSFG+1,X'60' No data Compression 05688000 BAL 9,SCRNEX Clear screan @SC90222 05689000 B RTRN0 @SC86295 05692000 * 05692100 SCRCLR CLI TRMTP,C'T' Is it a TTY terminal? @SC90045 05692200 BE RTRN0 Yes, can't clear screen @SC90045 05692300 CLI TRMTP,C'V' Is it a TTY terminal? @SC90045 05692400 BE RTRN0 Yes, can't clear screen @SC90045 05692500 CLI TRMTP,C'F' Is it some full-screen? @SC92030 05692530 BE *+12 Yes, must clear frequently @SC92030 05692560 TM FL2,PROTO In protocol mode? @SC90045 05692600 BO RTRN0 Yes, skip clearing screen @SC90045 05692700 B SCRCLRA Do it @SC90045 05692800 * 05693000 SCRCLS BCT 0,SCRRSET @SC86295 05694000 B RTRN0 @SC86295 05695000 * (Re)set device characteristics to suit environment 05696000 SCRRSET BCT 0,SCRRW @SC86295 05697000 B RTRN0 05698000 * 05699000 * Perform I/O request 05700000 SCRRW LR 5,0 @SC90173 05701000 AR 5,0 @SC90173 05701100 CLI TRMTP,C'A' AEA? @SC90173 05701200 BNE *+8 @SC90173 05701300 LA 5,6(,5) Yes, use 2nd table @SC90173 05701400 LH 5,SCRFGS-2(5) Get proper screen I/O flags @SC90173 05701500 STCM 5,3,FSFSFG @SC90173 05701600 BCT 0,SCRRD @SC90173 05701700 * Write @SC90173 05701800 CLI WRRD,0 Write/Read ? @PG90058 05702000 BE SCRWO @PG90058 05702200 MVC RIOPRP(8),0(1) Save Write data as Read Prmp @PG90058 05702400 B RTRN0 @PG90058 05702600 SCRWO DS 0H Write without expecting response @SC90173 05703000 MVC FSFSWL,4(1) Copy buffer length (assume Write) @SC90173 05704000 MVC FSFSWB,0(1) Copy buffer address @SC90173 05705000 MVI TRMFLG,0 Indicate no actn on followup @PG90058 05706500 BAL 9,SCRNEX Do the I/O (and log) @SC90222 05707000 LM 1,2,0(6) Get buffer,len @SC90222 05707500 BAL 7,SCRLOGD Log the data @SC90222 05708000 B RTRN0 05709000 * 05709500 SCRRD BCT 0,SCRWM 05710000 TS TRMFLG Do we have to really read? @PG90058 05711000 BZ RTRN0 Just a follow up. 0-len read @PG90058 05711300 MVC FSFSRL(4),4(1) Get buffer length Read @PG90058 05713000 MVC FSFSRB(4),0(1) Get buffer address Read @PG90058 05713500 CLI RIOPRP+4,255 Interrupt pending? @SC90222 05713600 BE SCRRDM No, just issue READ MOD @SC90222 05713700 MVC FSFSWL(4),RIOPRP+4 Get buffer length Write @PG90058 05714000 MVC FSFSWB(4),RIOPRP Get buffer address Write @PG90058 05714500 BAL 9,SCRNEX Do the I/O (and log) @SC90222 05715000 LM 1,2,RIOPRP Get buffer,len written @SC90222 05715300 BAL 7,SCRLOGD Log the data @SC90222 05715600 MVI RIOPRP+4,255 Flag no interrupt pending @SC90222 05715900 B SCRRD2 Now rejoin @SC90222 05716200 SCRRDM MVI FSFSFG,X'0C' Do immediate READ MOD @SC90222 05716500 BAL 9,SCRNEX Do the I/O (and log) @SC90222 05716800 SCRRD2 L 1,0(,6) Get input buffer @SC90222 05717100 LR 2,5 Get length read @SC90222 05717400 BAL 7,SCRLOGD Log the data @SC90222 05717700 LR 15,5 Get length of data read @SC90222 05718000 S 15,WRCMDL+4 Deduct 3 for buffer adr @SC90173 05718100 B RTRN Return @SC86299 05719000 * 05719200 * SCRLOG: Hexadecimal log of (R2) bytes at address (R1) @LP88158 05719400 * Log label is taken from R0 low order byte. @SC89166 05719600 * Return via R7. R0-R3 and R15 destroyed. @SC89166 05719800 SCRLOGD LA 0,C'd' "Data" label @SC89166 05720000 B SCRLOG @SC92180 05720020 * Enter here with (1)->control block of length 20 @SC92180 05720040 SCRLOGCM SLR 2,2 Convert op. code to log label @SC92180 05720060 IC 2,CONSOPR @SC92180 05720080 LA 2,CONSOPRS(2) @SC92180 05720100 IC 0,0(,2) @SC92180 05720120 LA 2,20 Size of plist @SC92180 05720140 SCRLOG TM FL1,DEBUG Logging in effect? @SC87286 05720200 BZR 7 No, that's all @SC89166 05720400 TM DBGFLG,DBGIO I/O stuff requested? @SC88168 05720600 BZR 7 No, skip it @SC89166 05720800 L 3,LOGBUF Ptr to buffer @LP88158 05721000 STC 0,0(,3) Set log label @SC89166 05721200 LA 3,2(,3) Start of data area @SC91172 05721400 TM DBGFLG,DBGTI Times requested? @SC91172 05721410 BZ SCRLOGA No, just do hex dump @SC91172 05721420 ST 1,SCRLR1 Save ptr to block @SC91172 05721430 BAL 14,ACCTTOD Get time of day in seconds @SC91172 05721440 MVI 0(3),C' ' Leave a space @SC91172 05721450 KCALL DUMPTOD,1(3) Format time into buffer @SC91172 05721460 LR 3,15 Get ptr to end of string @SC91172 05721470 L 1,SCRLR1 Restore R1 @SC91172 05721480 SCRLOGA LA 0,6*9(,3) End of line buffer @SC91172 05721490 TM DBGFLG,DBGLO Long buffer requested? @SC90222 05721600 BZ *+8 @SC90222 05721800 LA 0,50*9(,3) Yes, long buffer @SC91172 05722000 SCRLOGLP MVI 0(3),C' ' Add for readability @LP88158 05722400 UNPK 1(9,3),0(5,1) Unpack into buffer @SC88168 05722600 TR 1(8,3),TRHEX Convert to printable hex @SC88168 05722800 LA 3,9(3) Advance text ptr @SC88168 05723000 LA 1,4(1) and data source @LP88158 05723200 S 2,F4 Finished data? @SC88168 05723400 BNP SCRLGEND Yes, go write @LP88158 05723600 CR 3,0 Reached text limit? @LP88158 05723800 BL SCRLOGLP no, loop for more slices @LP88158 05724000 MVC 0(3,3),=C'...' Show incomplete @LP88158 05724200 LA 3,3(3) @SC88168 05724400 SCRLGEND DS 0H @LP88158 05724600 AR 2,2 Check for incomplete slice @SC88168 05724800 BNM *+6 No, ok @SC88168 05725000 AR 3,2 Yes, adjust end of text @SC88168 05725200 S 3,LOGBUF Get length of text @SC88168 05725400 WRITF LOGPTR,BSIZE=(3) Log it @LP88158 05725600 TM DBGFLG,DBGSV SAVE requested? @SC88168 05725800 BZR 7 No, skip closing log file @SC89166 05726000 SAVEF LOGPTR Update disk directory @SC88168 05726200 BR 7 @SC89166 05726400 * 05726600 * Execute (and log) screen I/O already set up @SC90222 05726800 * Return via R9 with length read in R5. @SC90222 05727000 SCRNEX MVI ZLU,9 Specify unit 9 @SC90222 05727200 MFSET DSKST,FSIO @SC90222 05727400 MFREQ DSKST Do it @SC90222 05727600 L 5,MFARSZ Fetch length of read @SC90222 05727800 MVC SCRRC,ZRC Save return code @SC90222 05728000 LA 1,ZFSARG I/O block @SC90222 05729000 BAL 7,SCRLOGCM Log it @SC92180 05729200 CLI SCRRC,0 @SC90222 05729600 BER 9 Ok, just return @SC90222 05729800 LA 1,SCRRC @SC90222 05730000 LA 2,1 @SC90222 05730200 LA 0,C'e' "Error" label @SC90222 05730400 BAL 7,SCRLOG Log the return code @SC90222 05730600 BR 9 Return @SC90222 05730800 * 05735000 SCRWM DS 0H @SC90173 05737000 MVC FSFSWL,4(1) Copy buffer length @SC90173 05738000 MVC FSFSWB,0(1) Copy buffer address @SC90173 05739000 BAL 9,SCRNEX Write it @SC90222 05740000 LM 1,2,0(6) Get buffer,len @SC90222 05740500 BAL 7,SCRLOGD Log the data @SC90222 05741000 B RTRN0 05743000 * Halfword-aligned table of I/O flags code @SC90173 05743050 SCRFGS DC X'06',X'A0' WCC, Skip read / No comp 4 @SC90173 05743100 DC X'02',X'80' WCC, Write/Read / No comp 5 @SC90173 05743150 DC X'86',X'A0' EW, WCC, Skip Read / No comp 6 @SC90173 05743200 * 2nd table for WSF I/O @SC90173 05743250 DC X'24',X'A0' Skip read / No comp 4 @SC90173 05743300 DC X'20',X'80' Write/Read / No comp 5 @SC90173 05743350 DC X'86',X'A0' EW, WCC, Skip Read / No comp 6 @SC90173 05743400 RIOPRP DC A(0,1) @PG90058 05743500 CONSOPRS DC C'?ocswrmg' Console commands labels for log @SC91150 05743600 LOCALS , 05744000 SCRRC DS F Return code from I/O @SC90222 05744300 SCRLR1 DS F Saved R1 in SCRLOG @SC91172 05744400 CONSOPR DS XL1 Current I/O operation @SC89180 05744600 SCRNIO EXIT , 05745000 TITLE 'DISKIO Routine - performs disk I/O functions' 05746000 * Function selected on entry by R0: 05747000 * 0=> unnum: R1->FAB. Return R1->buffer,R0=# and remove the sequence 05748000 * number (if any) from the buffer (used for TAKE files) 05749000 * 1=> open (in): R1->pattern FDB, R2->name. Returns R0->FAB, R1->FDB 05750000 * 2=> open (out): (same) 05751000 * 3=> test name: R2->name. Returns R1->FDB if file found and @SC91269 05752000 * writable (else R15=1) @SC91269 05752100 * 4=> close file: R1->adr(FAB). 05753000 * 5=> set up search: R1->pattern name. 05754000 * 6=> return next file in list: Returns R1->FDB + sets up FILNAM 05755000 * 7=> close search (if any). 05756000 * 8=> test CWD string: R1->string. Returns R15=0 if ok, else =1. 05757000 * 9=> read: R1->FAB. Returns R15=12 if EOF, 0 if ok; R0=# data 05758000 * 10=> write: R1->FAB. Returns R15=13 if disk full, 0 if ok. 05759000 * 11=> test space: R1->pattern FDB (has size in Kbytes), 05760000 * R2->name (used if FAB not found), R6->adr(FAB). Return R15=0 if ok. 05760500 * 12=> analyze R/W error, set ERRNUM, make EMSG: R1->FAB, TMPDW=code 05761000 * always returns R15=1 05762000 * 13=> directory info on file: R1->name. Returns R15=0 if ok. 05763000 * 14=> delete file: R1->name. Returns R15=0 if ok. 05764000 * 15=> rename file: R1->name, R2->new name. Returns R15=0 if ok. 05765000 * 16=> copy file: R1->name, R2->new name. Returns R15=0 if ok. 05766000 * 17-> type file: R1-> name. Returns R15=0 if ok. 05767000 * 21=> save file status in directory: R1->FAB. @SC88168 05768000 * 22=> open library (in): R2->DDNAME. Return R15=0 if ok. @SC89073 05768200 * 23=> point for next read, R1->adr(FDB), R2=records to skip. @SC89218 05768300 * Return R15=0 if ok. @SC89218 05768400 * 24=> test name: R2->name. Returns R1->FDB if file found and @SC91269 05768450 * readable (else R15=1) @SC91269 05768500 DISKIO ENTER 05769000 USING FABD,3 @SC86295 05770000 SR 4,4 Signal no block assigned @SC86295 05771000 STC 0,DSKCOD Save function code (for now) @SC88101 05772000 LR 5,0 @SC89073 05773000 AR 5,5 @SC89073 05773200 LH 5,DSK0(5) Get handler address @SC89073 05773400 B DSK0(5) Do the function @SC89073 05773600 DSK0 DC Y(DSKRED-DSK0,DSKOPNI-DSK0,DSKOPNO-DSK0) 0-2 @SC89073 05773800 DC Y(DSKTEST-DSK0,DSKCLOS-DSK0,DSKNSET-DSK0) 3-5 @SC89073 05774000 DC Y(DSKNXT-DSK0,DSKXSET-DSK0,DSKCWDF-DSK0) 6-8 @SC89073 05774200 DC Y(DSKRED-DSK0,DSKWRT-DSK0,DSKTSP-DSK0) 9-11 @SC89073 05774400 DC Y(DSKXXX-DSK0,DSKDIR-DSK0,DSKDEL-DSK0) 12-14 @SC89073 05774600 DC Y(DSKRNM-DSK0,DSKCPY-DSK0,DSKTYP-DSK0) 15-17 @SC89073 05774800 DC 3Y(DSKER1-DSK0) Spare utilities 18-20 @SC89073 05775000 DC 2Y(DSKER1-DSK0),Y(DSKPNT-DSK0) 21-23 @SC89218 05775200 DC Y(DSKTEST-DSK0) 24- @SC91269 05775250 DC 8Y(DSKER1-DSK0) Spares @SC89073 05775400 * 05776000 * Open for input file whose name is at (R2), FDB at (R1) 05777000 DSKOPNI DS 0H @SC89073 05777500 BAL 9,DSKALC Get FAB @SC86295 05778000 MFSET DSKST,OPEN,R=(OKOLD,RDOK) 05779000 MFREQ DSKST Try to open file 05780000 CLI ZRC,0 Errors ??? 05781000 BNZ DSKER1 Not found @SC86295 05782000 MVC FABRC,ZRC 05783000 BAL 9,DSKCHKNM Check if allowed to do I/O 05784000 B DSKER1 05785000 BAL 14,DSKVALS Go copy info to FDBD 05786000 MVC FABUNIT(1),ZLU Save file unit number 05787000 B RTRN0 @SC86295 05788000 * 05789000 * Open for output file whose name is at (R2), FDB at (R1) 05790000 DSKOPNO DS 0H @SC89073 05791000 BAL 9,DSKALC Get FAB @SC86295 05792000 MVC FABCOMM,=CL8'Open' In case of error @SC88308 05793000 MFSET DSKST,EXTRACT @SC88308 05796000 MFREQ DSKST Get file attributes @SC88308 05797000 CLI ZRC,0 Did it work? @SC88308 05798000 BNE DSKOP2 Not found, just writing new @SC87012 05799000 TM FDBFLGS,APPN+SVATT Should we keep attributes? @SC90033 05799500 BZ *+8 No @SC90033 05800000 BAL 14,DSKVALS Yes, copy old ones to FDB @SC90033 05800500 TM FDBFLGS,APPN Appending? @SC90033 05801000 BO DSKOP2 Yes, keep old file @SC90033 05801500 DSKOP1 DS 0H @SC88308 05802000 MFSET DSKST,OPEN,R=(OKOLD,RDOK) 05803000 MFREQ DSKST 05804000 MVC FABRC(1),ZRC 05805000 CLI ZRC,30 Error deleting file ? 05806000 BE DSKOP2 Yup, ignore it. 05807000 BAL 9,DSKCHKNM Check if allowed to do I/O 05808000 B DSKER1 05809000 MFSET DSKST,CLOSE,R=(DEL) 05810000 MFREQ DSKST Delete the file... 05811000 MVC FABRC(1),ZRC 05812000 DSKOP2 MVC ZINFIN(LZINFDEF),ZINFDEF Get default file attrs 05813000 SR 0,0 05814000 ICM 0,3,FDBLRC Insert logical record length 05815000 STH 0,MFIRSIZ 05816000 CLI FDBRCF,C'V' If not variable, then truncate 05817000 BNE DSKSTLR @SC88120 05818000 CLI TYPFIL,C'B' If variabel BUT binary, truncate 05819000 BE DSKSTLR 05820000 L 0,MAXLRC TEXT file, no limit @SC87012 05821000 DSKSTLR ST 0,FABLRTR Set output buffer limit 05822000 CLI FDBRCF,C'F' Fixed format ? 05823000 BNE *+8 05824000 MVI MFIRFM,X'02' Yup, set to Fixed Compressed 05825000 MFSET DSKST,OPEN,R=(OKOLD,OKNEW,WROK) 05826000 TM FDBFLGS,APPN Append to file ? 05827000 BZ *+8 05828000 OI DSKST+1,X'20' Manually specify APPOK ! 05829000 MFREQ DSKST Do the I/O 05830000 CLI ZRC,0 Any errors ? 05831000 BNZ DSKER1 05832000 MVC FABRC,ZRC Save return code 05833000 MVC ZINFOUT(LZINFDEF),ZINFIN Copy creation file parms 05834000 BAL 14,DSKVALS Copy parms to FDBD 05835000 OI FDBFLGS,FWRITE Write mode file 05836000 MVC FABUNIT(1),ZLU Save the Unit number 05837000 B RTRN0 @SC86295 05838000 * 05839000 * Test for existence of file whose name is at (R2) 05840000 DSKTEST DS 0H @SC89073 05841000 MVC MFNAME(LFID),0(2) Get filename to test 05842000 DSKTST2 LA 3,DSKSTT Get temporary FDB @SC88308 05843000 MFSET DSKST,EXTRACT @SC88308 05844000 MFREQ DSKST Get the file info... 05845000 MVI ZLU,0 Safety check... 05846000 CLI ZRC,0 Any errors ? 05847000 BNZ DSKER1 05848000 BAL 14,DSKVALS Go copy info to FDBD 05849000 B RTRN0 05850000 * 05851000 * Close file whose ticket is at (R1), release block 05852000 DSKCLOS DS 0H @SC89073 05853000 ICM 3,15,0(1) Get FAB ptr, if any @SC86295 05854000 BZ RTRN0 None, ignore @SC86295 05855000 XC 0(4,1),0(1) Yes, now clear ticket @SC86295 05856000 MVC ZLU(1),FABUNIT Copy file Unit number 05857000 LR 6,3 Save the address of the FAB 05858000 MFSET DSKST,CLOSE 05859000 TM FDBFLGS,FWRITE Write mode file ? 05860000 BZ DSKCLS2 05861000 OI DSKST+1,X'10' Yes, add RLSE option ! 05862000 DSKCLS2 MFREQ DSKST Close the file 05863000 LR 1,6 Get FAB address 05864000 LA 0,FABDWDS @SC86295 05865000 DMSFRET DWORDS=(0),LOC=(1) Free up the FAB 05866000 B RTRN0 @SC86295 05867000 * 05867080 * Point past 1st N records of file at (R1) @SC89218 05867160 DSKPNT ICM 3,15,0(1) Get ticket @SC89218 05867240 BZ RTRN1 Not open @SC89218 05867320 LR 3,1 @SC89218 05867400 LTR 2,2 Number of records to skip @SC89218 05867480 BNP RTRN0 Never mind @SC89218 05867560 DSKPNTL READF 0(,3),E=RTRN1 Skip one @SC89218 05867640 BCT 2,DSKPNTL ... until finished @SC89218 05867720 B RTRN0 Return with completion code @SC89218 05867800 * 05868000 * Read from file R1->FAB 05869000 DSKRED DS 0H @SC89073 05870000 DSKRED2 LR 3,1 Point to FAB 05871000 MVC FABCOMM(8),=CL8'Read' I/O Operation 05872000 L 0,FDBBUFF Get buffer address 05873000 ST 0,MFRBUF 05874000 L 0,FDBBSIZ Get I/O Length 05875000 ST 0,MFRLEN 05876000 MVC ZLU(1),FABUNIT Get unit number 05877000 MFSET DSKST,IO,R=(RD) 05878000 MFREQ DSKST Do the I/O 05879000 MVC FABRC(1),ZRC Save the return code 05880000 L 0,MFARSZ Get length read from Save file. 05881000 RETREG 0 Return length as R0 @SC89218 05882000 CLI ZRC,0 Any errors ??? 05884000 BE RTRN0 05885000 LA 15,12 End of file. 05886000 CLI ZRC,1 End of file maybe ??? 05887000 BE RTRN 05888000 B RTRN1 Well, just another error... 05889000 * 05890000 * Write to file R1->FAB 05891000 DSKWRT DS 0H @SC89073 05892000 LR 3,1 Point to FAB 05893000 MVC FABCOMM(8),=CL8'Write' I/O Operation 05894000 L 0,FDBBUFF Get buffer address 05895000 ST 0,MFRBUF 05896000 L 0,FDBBSIZ Get I/O Length 05897000 ST 0,MFRLEN 05898000 MVC ZLU(1),FABUNIT Get unit number 05899000 MFSET DSKST,IO,R=(WR) 05900000 MFREQ DSKST Do the I/O 05901000 MVC FABRC(1),ZRC Save the return code 05902000 CLI ZRC,0 Any errors ??? 05903000 BE RTRN0 05904000 LA 15,13 Disk full error code. 05905000 CLI ZRC,40 Well, is it full ? 05906000 BL RTRN1 05907000 CLI ZRC,42 Three possible return codes 05908000 BH RTRN1 05909000 B RTRN 05910000 * 05911000 * Analyze error: Get error code from FABRC field of FAB ! 05912000 DSKXXX DS 0H @SC89073 05913000 LR 3,1 Get address of FAB 05914000 MVI ERRNUM,ERRDIE Set Kermit DISKIO error code 05915000 L 2,EMSGP Ptr to msg buffer 05916000 MVC 0(8,2),FABCOMM Copy oprn name 05917000 MVC ZRC(1),FABRC Get the error code 05918000 LA 0,8(2) Get address of where to pad 05919000 ST 0,MFRBUF message 05920000 LA 0,70 Maximum length of message 05921000 ST 0,MFRLEN 05922000 MFSET DSKST,MSG Convert RC to real message 05923000 MFREQ DSKST 05924000 LA 0,79 Return maximum length of msg. 05925000 ST 0,EMSGL 05926000 B RTRN1 @SC87338 05927000 * 05928000 * Delete file R1->name, Return R15=0 if ok 05929000 DSKDEL DS 0H @SC89073 05930000 LA 3,DSKSTT Temporary FAB needed 05931000 MVC MFNAME(LFID),0(1) Copy file name to delete 05932000 MFSET DSKST,OPEN,R=(OKOLD,RDOK) 05933000 MFREQ DSKST Try to open the file 05934000 CLI ZRC,0 Error ? 05935000 BNE DSKER2 05936000 BAL 9,DSKCHKNM Check if allowed to do I/O 05937000 B DSKER2 05938000 MFSET DSKST,CLOSE,R=(DEL) 05939000 MFREQ DSKST Delete the file 05940000 CLI ZRC,0 Error ? 05941000 BNE DSKER2 05942000 LA 15,0 File deleted message @SC92300 05943000 * 05944000 DSKMSG LA 0,L'DSKMTAB Length of msg @SC92300 05945000 MR 14,0 Get the address of the message @SC92300 05946000 LA 1,DSKMTAB(15) @SC92300 05947000 WTEXT (1),(0) @SC88308 05948000 MVI ERRNUM,ERRNOE No Errors 05949000 B RTRN0 05950000 * 05951000 * Rename file R1->name, R2->newname, Return R15=0 if ok 05952000 DSKRNM DS 0H @SC89073 05953000 LA 3,DSKSTT Temporary FAB needed 05954000 MVC MFNAME(LFID),0(1) Copy file name to delete 05955000 MFSET DSKST,OPEN,R=(OKOLD,RDOK) 05956000 MFREQ DSKST Try to open the file 05957000 CLI ZRC,0 Error ? 05958000 BNE DSKER2 05959000 BAL 9,DSKCHKNM Check if allowed to do I/O 05960000 B DSKER2 05961000 MVC ZINFIN(LZINFDEF),ZINFDEF Get default file attrs 05962000 MVC MFNAME(LFID),0(2) Get new name 05963000 MFSET DSKST,CLOSE,R=(RENAME) 05964000 MFREQ DSKST Rename it ! 05965000 LA 15,1 File renamed message @SC92300 05966000 CLI ZRC,0 Error on rename ? 05967000 BE DSKMSG 05968000 CLI ZLU,0 Is an additional close required ? 05969000 BE DSKER2 05970000 MFSET DSKST,CLOSE Yes, close the file normally. 05971000 MFREQ DSKST Rename failed. 05972000 B DSKER2 05973000 * 05974000 * Copy file. R1->name, R2->newname. Return R15=0 if ok 05975000 DSKCPY DS 0H @SC89073 05976000 LA 3,DSKSTT Temporary FAB needed 05977000 LA 7,1 Error by default !!! 05978000 MVC MFNAME(LFID),0(1) Get file name to copy 05979000 MFSET DSKST,OPEN,R=(OKOLD,RDOK) 05980000 MFREQ DSKST Try to open the file 05981000 CLI ZRC,0 Error ? 05982000 BNE DSKER2 05983000 BAL 9,DSKCHKNM Check if allowed to do I/O 05984000 B DSKER2 05985000 SLR 8,8 05986000 ICM 8,1,ZLU Save Read Unit Number 05987000 L 9,MFEOFB Get number of blks to copy 05988000 MVC PARMAREA(2),MFORSIZ Save record size 05989000 MVC PARMAREA+2(4),MFNLRC Save Line count 05990000 MVC PARMAREA+6(4),MFEOFB Save last blk written 05991000 MVC PARMAREA+10(4),MFEOFD Save displacement 05992000 MVC CMD(64),MFTAG Save tag @SC88308 05993000 * 05994000 MVC MFNAME(LFID),0(2) Get destination 05995000 MVC ZINFIN(LZINFDEF),ZINFOUT 05996000 NI MFIGCTL,X'7F' Turn off common bit !!! 05997000 MFSET DSKST,OPEN,R=(OKNEW,WROK) 05998000 MFREQ DSKST Try to open the file 05999000 CLI ZRC,0 06000000 BNE DSKCP55 Error. New file open failed ! 06001000 ICM 8,2,ZLU Save Write Unit Number 06002000 * 06003000 LA 4,1 Starting blk number 06004000 LA 5,512 Number of blks to copy 06005000 LA 6,2048 Address of buffer 06006000 A 6,WBUF 06007000 LTR 9,9 Anything left to do ??? 06008000 BZ DSKCP50 06009000 DSKCP20 STCM 8,1,ZLU Set Unit number 06010000 STM 4,6,MFSBNU Set read args 06011000 MFSET DSKST,UIO,R=(RD) 06012000 MFREQ DSKST Read a block 06013000 CLI ZRC,0 Error reading ? 06014000 BNE DSKCP55 06015000 STCM 8,2,ZLU Set unit number 06016000 STM 4,6,MFSBNU Set read args 06017000 MFSET DSKST,UIO,R=(WR) 06018000 MFREQ DSKST Write the block back 06019000 CLI ZRC,0 Error writing? @SC88308 06020000 BNE DSKCP55 06021000 LA 4,1(4) Next block 06022000 BCT 9,DSKCP20 until all done 06023000 * 06024000 DSKCP50 SLR 7,7 Clear return code ! 06025000 DSKCP55 STCM 8,1,ZLU 06026000 CLI ZLU,0 Is the input file open ??? 06027000 BE DSKCP60 06028000 MFSET DSKST,CLOSE Yes, close the input file. 06029000 MFREQ DSKST 06030000 ICM 7,2,ZRC Save the return code 06031000 DSKCP60 STCM 8,2,ZLU 06032000 CLI ZLU,0 Is the output file open ? 06033000 BE DSKCP80 06034000 LTR 7,7 Any errors so far ? 06035000 BNZ DSKCP65 06036000 MFSET DSKST,CLOSE,R=(SETEFP) No, close and save file 06037000 MVC MFORSIZ(2),PARMAREA Set record size 06038000 MVC MFNLRC(4),PARMAREA+2 Set Line count 06039000 MVC MFEOFB(4),PARMAREA+6 Set last blk written 06040000 MVC MFEOFD(4),PARMAREA+10 Set displacement 06041000 MVC MFTAG(64),CMD Restore tag @SC88308 06042000 B DSKCP70 06043000 DSKCP65 MFSET DSKST,CLOSE,R=(DEL) Errors, delete file ! 06044000 DSKCP70 MFREQ DSKST 06045000 ICM 7,4,ZRC Get return code on Close 06046000 DSKCP80 LR 15,7 Return it to Kermit ! 06047000 B RTRN 06048000 * 06049000 * Type file. R1-> name. Returns R15=0 if ok. 06050000 DSKTYP DS 0H @SC89073 06051000 LR 4,1 Point to file name @PG88335 06052000 OPENF I,(4),FILFDB,FILPTR,E=RTRN1 @PG88335 06053000 LR 3,0 Point to FAB @PG88335 06054000 LH 1,FDBLRC @PG88335 06055000 CH 1,=H'130' Check record length !!! @PG88335 06056000 BL DSKTYP20 @PG88335 06057000 WTEXT '&ONLY130' @PG88335 06058000 DSKTYP20 L 3,RBUF Point to data buffer @PG88335 06059000 READF FILPTR,BUFFER=(3),E=DSKTYP50 @PG88335 06060000 CH 0,=H'130' Record too long ? @PG88335 06061000 BL DSKTYP30 @PG88335 06062000 LA 0,129 Yes, truncate... @PG88335 06063000 DSKTYP30 LTR 0,0 Is it null ? @PG88335 06064000 BNZ DSKTYP35 @PG88335 06065000 MVI 0(3),X'40' Then we must have at least @PG88335 06066000 LA 0,1 one character to output @PG88335 06067000 DSKTYP35 WTEXT (3) @PG88335 06068000 B DSKTYP20 @PG88335 06069000 DSKTYP50 C 15,F12 EOF code ? @PG88335 06070000 BE DSKTYP70 @PG88335 06071000 ERRF , Analyze error code @PG88335 06072000 CLOSF FILPTR @PG88335 06073000 B RTRN1 @PG88335 06074000 DSKTYP70 CLOSF FILPTR @PG88335 06075000 B RTRN0 @PG88335 06076000 * 06077000 * Return on error, release useless block, if any 06078000 DSKER1 LTR 1,4 Any block assigned? @SC86295 06079000 BZ RTRN1 No @SC86295 06080000 LA 0,FABDWDS Yes, release it @SC86295 06081000 DMSFRET DWORDS=(0),LOC=(1) @SC86295 06082000 B RTRN1 Flag error @SC86295 06083000 * Error return from disk utilities. Set ERRNUM properly. 06084000 DSKER2 CLI ZRC,12 06085000 BNE DSKER3 06086000 MVI ERRNUM,ERRFNE Invalid filename 06087000 B RTRN1 06088000 DSKER3 CLI ZRC,30 06089000 BNE DSKER4 06090000 MVI ERRNUM,ERRFNF File not found 06091000 B RTRN1 06092000 DSKER4 MVI ERRNUM,ERRDIE Disk I/O Error 06093000 B RTRN1 06094000 * Allocate FAB and copy default FDB 06095000 DSKALC LR 5,1 Save FDB ptr @SC86295 06096000 MVC MFNAME,0(2) 06097000 LA 0,FABDWDS @SC86295 06098000 DMSFREE DWORDS=(0),ERR=DSKER1 @SC86295 06099000 LR 3,1 New block ptr @SC86295 06100000 LA 4,FDBD FDB pointer @SC88120 06101000 RETREG (0,3),(1,4) Return FAB ptr in R0, FDB in R1 @SC89218 06102000 LR 4,3 Indicate we have it @SC88120 06104000 XC 0(8*FABDWDS,3),0(3) @SC86295 06105000 MVC FDBD(FDBCOP),0(5) Copy user's FDB @SC86295 06106000 MVC FABFN(LFID),0(2) Copy filename to FAB 06107000 BR 9 @SC86295 06108000 * 06109000 * Set up search through list of files, pattern at (R1) 06110000 DSKNSET DS 0H @SC89073 06111000 MVC SCODE,UCODE Get default user code 06112000 MVC NXFN(LFID),0(1) Save pattern name 06113000 CLI 4(1),C':' Code specified in filename ? 06114000 BNE DSKNS4 Nope. 06115000 MVC SCODE(4),0(1) Get the new code for search 06116000 MVC NXFN(LFID),BLNAME Clear the filename pattern 06117000 MVC NXFN(17),5(1) Copy filename part only 06118000 DSKNS4 CLC SCODE(4),=CL4'*USR' Do we really want the user's code ? 06119000 BNE DSKNS6 06120000 MVC SCODE(4),$USRCDE Yes, then put in the real thing 06121000 DSKNS6 MVI NXFLG,NFSOK Clear flag byte 06122000 LA 2,LFID Max length of filename 06123000 LA 3,NXFN+LFID 06124000 DSKNS8 BCTR 3,0 06125000 CLI 0(3),C'?' Is it a wildcard ? 06126000 BE DSKNS10 06127000 CLI 0(3),C'*' Is it a wildcard ? 06128000 BE DSKNS10 06129000 BCT 2,DSKNS8 06130000 B RTRN0 No wildcards, Grreat !!! 06131000 * 06132000 DSKNS10 CLC SCODE(4),$USRCDE Are we searching our library ? 06133000 BE DSKNS12 06134000 TM UPRIVS,FILES+LSCAN No, then we need some privs !!! 06135000 BZ DSKNS15 06136000 DSKNS12 LA 1,NXFN+LFID End of token if no blanks 06137000 TRT NXFN(LFID),TRTBL Find 1st blank 06138000 LA 2,NXFN 06139000 SR 1,2 Calc length of string 06140000 ST 1,NXFNL Save it... 06141000 OI NXFLG,NFWLD Wildcard search necessary ! 06142000 L 2,MFINDBUF 06143000 CALL MFIND1,((2),F10,SCODE,F0,ZRC),VL,MF=(E,PARMAREA) 06144000 LTR 15,15 Any errors ??? 06145000 BZ RTRN0 06146000 DSKNS15 OI NXFLG,NFERR Error on MFIND1 call 06147000 B RTRN1 06148000 * 06149000 * Flush previous file pattern 06150000 DSKXSET DS 0H @SC89073 06151000 MVI NXFLG,0 Clear flag byte 06152000 B RTRN0 06153000 * 06154000 * Check CWD string, return code in R15 06155000 DSKCWDF DS 0H @SC89073 06156000 B RTRN0 06157000 * 06158000 * Check disk space for proposed file: FDB at (R1), FAB ptr at (R6) 06159000 DSKTSP L 5,FDBSIZE-FDBD(,1) Get actual size @SC90037 06159200 ICM 3,15,0(6) Get FAB ptr @SC90037 06159400 BNZ DSKTSP0 Not open yet @SC90037 06159600 MVC MFNAME(LFID),0(2) Get filename @SC90037 06159800 LA 3,DSKSTT Get temporary FDB @SC90037 06160000 MFSET DSKST,EXTRACT @SC90037 06160200 MFREQ DSKST Get the file info @SC90037 06160400 MVI ZLU,0 For safety @SC90037 06160600 CLI ZRC,0 Found it? @SC90037 06160800 BNE DSKTSP0 Not found, nothing to erase @SC90037 06161000 L 1,MFOPRM Old file size in KBytes @SC90037 06161200 SR 5,1 Assume old file will be erased @SC90037 06161400 BNP RTRN0 Will release enough for new file @SC90037 06161600 DSKTSP0 DS 0H Check free space @SC90037 06161800 MFSET DSKST,USERCTL Get User Control Record to 06163000 MFREQ DSKST determine how much space the 06164000 MVC FABRC(1),ZRC user has left. Save return code ! 06165000 L 1,MFMAXS Get max allocation space 06166000 S 1,MFACUR Subtract amt allocated 06167000 CLR 1,5 @SC90037 06168000 BL RTRN1 No room @SC86316 06169000 B RTRN0 Ok @SC86316 06170000 * 06171000 DSKVALS LA 0,FDBD Ptr to FDB @SC86295 06172000 RETREG (1,0) Return FDB ptr as R1 @SC89218 06173000 *** GET FILE'S DATE... 06175000 SR 7,7 @SC87296 06176000 ICM 7,3,MFUIMD Mod date as (y-1970)*366+d @SC92086 06177000 BNZ *+8 @SC92086 06177100 ICM 7,3,MFUICD Try for creation date @SC92086 06177200 BZ DSKVDTZ No date available (?) @SC92086 06177300 BCTR 7,0 Keep day 366 in same year @SC92086 06177400 SR 6,6 @SC92086 06177500 D 6,=F'366' Get d and y-1970 @SC92086 06177600 LA 7,1970(,7) @SC92086 06177700 CVD 7,TMPDW @SC87296 06178000 MVO FDBDATE(3),TMPDW Copy year @SC92086 06179000 MVC DSKMNTH,=AL1(30,31,30,31,31,30,31,30,31,28,31) @SC86299 06181000 N 7,F3 See if leap year @SC92086 06182000 BNZ *+8 @SC87296 06183000 MVI DSKMNTH+9,29 Leap year, change Feb. @SC86299 06184000 LA 7,1(,6) Now get day of year @SC92086 06184500 LA 6,11 @SC86299 06185000 SR 0,0 @SC86299 06186000 DSKVMDL IC 0,DSKMNTH-1(6) @SC86299 06187000 SR 7,0 Test if passed the right month @SC86299 06188000 BNP DSKVMDM Got it @SC86299 06189000 BCT 6,DSKVMDL @SC86299 06190000 SR 0,0 Hit December @SC86299 06191000 DSKVMDM AR 7,0 Get day of month @SC86299 06192000 LCR 6,6 @SC86299 06193000 LA 6,12(6) Get month @SC86299 06194000 MH 6,=H'100' @SC86299 06195000 AR 6,7 Combine MMDD @SC86299 06196000 MH 6,=H'10' @SC86299 06197000 CVD 6,TMPDW @SC86299 06198000 MVC FDBDATE+2(2),TMPDW+5 @SC86299 06199000 ICM 7,15,MFXITD Get time of day, if any @SC92086 06200000 BZ DSKVDTZ Not specified, leave it out @SC92086 06200200 SLR 6,6 @SC92086 06200400 D 6,=F'300' Convert to seconds @SC92086 06200600 SLR 6,6 @SC92086 06200800 D 6,=F'60' Get minutes @SC92086 06201000 LR 0,6 Save remainder = seconds @SC92086 06201200 SLR 6,6 @SC92086 06201400 D 6,=F'60' Get hours in R7, minutes in R6 @SC92086 06201600 MH 7,=H'100' Put together into hhmmss form @SC92086 06201800 AR 7,6 @SC92086 06202000 MH 7,=H'100' @SC92086 06202200 AR 7,0 @SC92086 06202400 MH 7,=H'10' Shift left one digit @SC92086 06202600 CVD 7,TMPDW Convert to hhmmss0+ @SC92086 06202800 MVC FDBDATE+4(3),TMPDW+4 @SC92086 06203000 DSKVDTZ DS 0H @SC92086 06203200 L 1,MFOPRM Set file size in KBytes 06204000 ST 1,FDBSIZE 06205000 SLR 1,1 Set record format character 06206000 IC 1,MFORFM Ignore 'Compressed' modes. 06207000 SLL 1,1 06208000 LA 0,RFMTAB 06209000 AR 1,0 06210000 MVC FDBRCF,0(1) 06211000 MVC FDBLRC(2),MFORSIZ Get logical record length 06212000 NI FDBFLGS,255-FWRITE Clear the write mode flag 06213000 BR 14 06214000 * 06215000 * NXTFST Routine - searches through Save Library Index 06216000 * 06217000 DSKNXT DS 0H @SC89073 06218000 TM NXFLG,NFSOK Was a search set up ??? 06219000 BZ RTRN1 06220000 TM NXFLG,NFERR+NFEND Error or End of search ??? 06221000 BNZ RTRN1 06222000 * 06223000 TM NXFLG,NFWLD Do we need to call MFINDX ? 06224000 BO DSKSRCH 06225000 OI NXFLG,NFEND End of search... 06226000 LA 1,NXFN Source name was good. Use it! 06227000 DSKFND MVC MFNAME(5),SCODE Rebuild the complete filename @SC88308 06228000 MVC MFNAME+5(17),0(1) info on the file. 06229000 MVC FILNAM(LFID),MFNAME Setup FILNAM !!! 06230000 B DSKTST2 06231000 * 06232000 DSKSRCH CALL MFINDX,(FCODE,LCFN,NXFLTYP,NXSVFLG,NXBKNUM,NXDIRLOC),VL,+06233000 MF=(E,PARMAREA) 06234000 C 15,F4 End of library search ? 06235000 BNE NXT20 06236000 OI NXFLG,NFEND Yes, end of search 06237000 B RTRN1 06238000 NXT20 LTR 15,15 Error in search ? 06239000 BZ NXT30 06240000 OI NXFLG,NFSERRS+NFERR Yes, error in search @SC88308 06241000 B RTRN1 06242000 NXT30 CLC NXFLTYP,F0 Skip over common entries 06243000 BNE DSKSRCH 06244000 CLI LCFN,C'.' Skip over temporary files 06245000 BE DSKSRCH 06246000 CLC FCODE(4),SCODE Is this the right code ??? 06247000 BNE DSKSRCH 06248000 CALL MATCH,(LCFN,FM17,NXFN,NXFNL,ASTER,QUEST),VL, +06249000 MF=(E,PARMAREA) 06250000 LTR 0,0 Well, did they match ??? 06251000 BZ DSKSRCH 06252000 LA 1,LCFN Point to name found and go 06253000 B DSKFND copy it and set FDB 06254000 * 06255000 * Directory Info on file R1->name, return R15=0 if OK 06256000 DSKDIR DS 0H @SC89073 06257000 NXTFSET E=DSKDRERR Set up search (name at R1) @SC88308 06258000 DSKDRLP NXTF E=DSKDRZ Find next entry @SC88308 06259000 TM NXFLG,NFFND Found something already? @SC90264 06259200 BO DSKDRL1 @SC90264 06259400 WTEXT '&DIRHDNG' @SC92300 06259600 OI NXFLG,NFFND Found something, at least one @SC88308 06260000 DSKDRL1 DS 0H @SC90264 06260500 LA 1,CMD Yes, build the filename with @SC88308 06261000 LR 2,1 the attributes we want in a 06262000 LA 3,LFID Length of name buffer @SC88308 06263000 LA 4,MFNAME @SC88308 06264000 LR 5,3 @SC88308 06265000 CLC 0(4,4),$USRCDE User's code? @SC88308 06266000 BNE *+12 No @SC88308 06267000 A 4,F5 Yes, skip over it for output @SC88308 06268000 S 5,F5 @SC92301 06269000 ICM 4,8,F64+3 Get blank for padding @SC92086 06269500 MVCL 2,4 @SC88308 06270000 ICM 0,3,MFORSIZ 06271000 BAL 9,DSKNUM Add the logical record length 06272000 MVC 0(2,2),BLNAME Leave some blanks @SC88308 06273000 SLR 3,3 06274000 IC 3,MFORFM Get record format 06275000 SLL 3,1 06276000 LA 3,RFMTAB(3) Get address of printable value 06277000 MVC 2(2,2),0(3) Add to line @SC88308 06278000 LA 2,4(2) Bump the length @SC88308 06279000 ICM 0,15,MFOPRM 06280000 BAL 9,DSKNUM Add the file size in Kbytes 06281000 ICM 0,15,MFNLRC Add the number of lines 06284000 BAL 9,DSKNUM 06285000 LA 3,DSKSTT Point to temp FDB @SC92086 06285200 CLI FDBDATE,X'19' Validate century @SC92086 06285400 BL DSKDRDZ No good! @SC92086 06285600 CLI FDBDATE,X'20' @SC92086 06285800 BH DSKDRDZ @SC92086 06286000 MVC 0(DSKDRTL,2),DSKDRDT Copy whole pattern @SC92086 06286200 ED 0(DSKDRTL,2),FDBDATE and make it printable @SC92086 06286400 LA 2,DSKDRDL(,2) Length of just date portion @SC92086 06286600 CLC FDBDATE+4(3),F0 @SC92086 06286800 BE *+8 No time given @SC92086 06287000 LA 2,DSKDRTL-DSKDRDL(,2) Include time portion @SC92086 06287200 DSKDRDZ DS 0H @SC92086 06287400 * 06288000 SR 2,1 Get the output length 06289000 WTEXT (1),(2) 06290000 B DSKDRLP @SC88308 06291000 * @SC88308 06292000 DSKDRZ TM NXFLG,NFSERRS+NFERR @SC88308 06293000 BNZ DSKDRERR Report error @SC88308 06294000 TM NXFLG,NFFND Any files found? @SC88308 06295000 BO RTRN0 Yes, return gracefully @SC88308 06296000 DSKDRERR B RTRN1 Not found or invalid @SC90264 06297000 * 06299000 DSKNUM CVD 0,TMPDW Pack the binary value 06300000 OI TMPDW+7,15 Set zone 06301000 UNPK 0(8,2),TMPDW Convert to printable 06302000 LA 5,7(2) Point to end of string 06303000 DSKNUM2 CLI 0(2),C'0' Remove leading zeros 06304000 BNE DSKNUM3 except for the first one. 06305000 MVI 0(2),C' ' 06306000 LA 2,1(2) 06307000 CR 2,5 06308000 BL DSKNUM2 06309000 DSKNUM3 LA 2,1(5) Get the new ending address 06310000 BR 9 06311000 * 06312000 * Check for privs to open filename 06313000 * R3->FAB, R9->returns @SC88308 06314000 DSKCHKNM TM UPRIVS,FILES+LSCAN If FILES, never any problems 06315000 BNZ 4(9) 06316000 CLC MFUIFC(4),$USRCDE If our own code, then no problem 06317000 BE 4(9) 06318000 TM MFOACNB,X'A0' Allowed to read file ??? 06319000 BZ 4(9) 06320000 MVI FABRC,21 Not your library error. 06321000 CLI ZLU,0 Is the file still open ? 06322000 BER 9 06323000 MFSET DSKST,CLOSE Yes, close it normally... 06324000 MFREQ DSKST 06325000 BR 9 Error return 06326000 * 06327000 RFMTAB DC C'U F FCV VC' Record Format Table 06328000 DSKMTAB DC CL25'&FILDELT' @SC92300 06329000 DC CL25'&FILRENM' @SC92300 06329500 DC CL25'&FILCOPY' @SC92300 06330000 DSKDRDT DC C' ',4X'20',C'/',2X'20',C'/',2X'20' Date @SC92086 06331200 DSKDRDL EQU *-DSKDRDT Length of date portion @SC92086 06331400 DC C' ',2X'20',C':',2X'20',C':',2X'20' Time @SC92086 06331600 DSKDRTL EQU *-DSKDRDT Length of whole pattern @SC92086 06331800 LOCALS , 06332000 DSKMNTH DS XL11 Month length table @SC86299 06334000 DSKCOD DS X Saved DISKIO code @SC88308 06335000 DROP R3 06336000 EXIT 06337000 EJECT 06338000