cABIECRR ;Import - Load routines from a file ;cABIE; [ 12/09/2001 - 09:02:01 - 58694,32521 ] ; I $G(%ABIE("BLIND")) G ^cABIECRRB ; VJ 12.09.01 ; GO N POP,SELF,V,V2,%R,MWHENCE,EXTS,DESC,DAT,HEAD,A,L,I,Y,EXT,DATE N BACKUP,OVLAY,WANTCOM,SHOWDOT,NS,SEL,R,NAM,OK2COMP,LIST,endian N ROU,DATIM,OK,SHOWIT,J,X,S,R1,R2,RR,EXTDEF,ZA,VBUF,STVBUF,MCODE N %A,%E,%X,%ANS,IO,IOF,IOM,IOST,IOT,IOBS,IOPAR,IOSL,RMSDF,OPEN63 N WANTSYN N ROOLD N DSMRS,LANG N SETLANG S SETLANG=0 S DSMRS=0,LANG=0 B 1 N IOP ;used by %IS to determine automatic selection IN S IO=TRFIL,OIBS="*8",OIF="#",OIM=132,IOPAR="(""R"")",IOSL=66,IOST="RMS",IOT="RMS",MSYS="M/WNT" O IO:"R":0 S OK=$T I 'OK W !,"Could not open file",! S QUIT=2 Q S SELF=($I=IO) ; S V="ZREMOVE F ii=0:0 X V2 ZSAVE @ROU Q:L=""""" S V2="F J=1:1:20 R L S L=$P(L,$C(13)) Q:L="""" S:$P(L,"" "")[$C(9) $E(L,$F(L,$C(9))-1)="" "" ZINSERT:L'=""."" L" ; S POP=0,%R=0,EXTDEF="INT" S:$G(MDEBUG)'=1 $ZT="ERR^"_$ZN D Q:POP=1 . S $ZT="etRDHDR" . U IO R HEAD,DAT . I $ZEOF s $ZE="" g @$ZT S MWHENCE=$P(HEAD,"^"),EXTS=$P(HEAD,"^",2),DESC=$P($P(HEAD,"^",3,999),"^~Format=",1) I EXTS["OBJ" C IO U 0 W "Cannot restore object code. Use %RIMF please.",! Q ;HYY099 ; I $$UC(HEAD)?1"TRANSFER".E ;possibly a %GOGEN file E I HEAD["S @A=B" ;a %GO self-loader tape E I DAT'["%RO",'DSMRS ;not a %RO file! I D CHECK I POP G OPTQ ; D EXTDEF D OPT I POP G ENDFIL ;returns OVLAY,BACKUP,WANTCOM,WANTSYN,LIST,POP ; W !! I LIST W "Routines available:",! ;header only for 'list' option F ii=0:0 D RNAM Q:ROU="" I '$G(MCODE),ROU'="*" X SETOK D OK2SAV:OK,SAVE,SHOW,RDIR Q:POP G ENDFIL CHECK ;ask if OK to use this tape U 0 W !!," ***** W A R N I N G *****",! W !,"File Header: "_DAT,!,"Date Stamp: "_HEAD,! W !,"This file may not be a %RO output file." I $$YN("Override and use this File with %RI","N")="N" S POP=1 Q s LANG=$$ASKLANG(9) Q SELECT ;ask about saving this specific routine (OK= 1 if OK to save it) I 'OK Q ;this subroutine called via the SETOK execute I 'OVLAY,$$EXIST(ROU,EXT) S OK=0 Q ;not allowed to overlay U 0 S OK=($$YN("Save "_ROU_"."_EXT,"N")="Y") Q ENDFIL S R=0 U 0 W !!,%R_" routine"_$S(%R=1:"",1:"s")_" saved." I $G(POP) U 0 W !,"(%RI stopped)",! G OPTQ D SKIP:'$G(ROOLD) I IOT="MT" U IO W *-2 I IOPAR["L" F ii=1:1:3 W *-2 G OPTQ LOADERR S:$G(MDEBUG)'=1 $ZT="ERR^"_$ZN U 0 W !!,"[Error loading routine "_ROU_".]" U IO G ERR ERR U IO S ZA=$ZA U 0 W !!,$ZE,!,"$ZA = "_ZA OPTQ ;leave the utility, closing all the open devices... U 0 C:'SELF IO C:$G(OPEN63) 63 S POP=1,OK=0 Q RNAM S:DSMRS $ZT="NAMERR^"_$ZN S OK=1 ;read in next routine name, assume it is OK to start ; U IO R ROU I $ZEOF s $ZE="" g @$ZT S ROU=$P(ROU,$C(13)) S EXT=$P(ROU,".",2),OK2COMP=$P(ROU,".",3),DATIM=$P(ROU,".",4) I 'DSMRS,'SETLANG S LANG=$P(ROU,".",5) Q:ROU="" S:EXT="" EXT=EXTDEF,DATIM="",OK2COMP=1 S ROU=$P(ROU,"."),SHOWIT=ROU_"."_EXT Q NAMERR U IO S ZA=$ZA N MARK S MARK=ZA\16384#2 I IOT="RMS",$ZE["" S ROU="" Q ;flat file end I (IOT="MT")!(IOT="BT"),MARK S ROU="" Q ;tape mark at end ZQ 1 G @$ZT SHOW I 'OK S SHOWIT=ROU_"."_EXT_"-" ;standard display for NOT FILED U 0 W:$X+$L(SHOWIT)>79 ! W SHOWIT,@$S($X>63:"!",1:"?$X\16+1*16") Q OK2SAV I $G(MCODE) Q S SHOWDOT=$$EXIST(ROU,EXT) I 'OK S SHOWIT=SHOWIT_"-" Q ;not filing the routine I SHOWDOT,'OVLAY S SHOWIT=SHOWIT_"-",OK=0 Q ;not overlaying S:SHOWDOT SHOWIT=SHOWIT_"^" Q ;overlaying RDIR S:OK %R=%R+1 Q EXIST(R,E) ;return whether routine already exists or not I E="INT" Q $D(^ROUTINE(R,0)) ;intermediate I E="OBJ" Q $D(^mtemp1("ROU",R)) ;object code I E="MAC" Q $D(^rMAC(R,0)) ;MAC files I E="INC" Q $D(^rINC(R,0)) ;INC files SAVE G SKIP:'OK G SAVE^%RI2 ;handle saving separately SKIP S:DSMRS $ZT="SKERR^"_$ZN I $G(MCODE) Q ;can't skip if already read U IO N I,X F ii=0:0 d q:X="" . R X . i $ZEOF s $ZE="" g @$ZT . S X=$P(X,$C(13)) Q SKERR U IO S ZA=$ZA N MARK S MARK=ZA\16384#2 I IOT="RMS",$ZE["" S X="" Q ;flat file end I (IOT="MT")!(IOT="BT"),MARK S X="" Q ;tape mark at end ZQ 1 G @$ZT READYMT U IO S ZA=$ZA U 0 Q:(ZA\64#2) C IO W !,"Tape Status word: "_ZA R !,"Enter when tape is ready or STOP: ",X I $$STOP(X) S POP=1 W " stopping" Q O @(IO_":"_IOPAR) G READYMT EXTDEF S EXTDEF="INT",EXTS=EXTDEF Q ;default extensions in file PARCHK N IP,IR,IB ;check if the parameters are OK S IP=$$UC($P(IOPAR,":")),IR=$P(IOPAR,":",2),IB=$P(IOPAR,":",3) I IP["U",IP["S",IP["A",'IR,+IB=2048 Q ;is in USA:0:2048 format, so OK U 0 W !,"Warning: Object code requires format '""USA"":0:2048'" W !,"Information on this tape might not read properly.",! Q etRDHDR ; S $ZT="" U 0 W !!,"Error: ",$ZE," perhaps this is not a %RO file",! C IO S POP=1 Q ASKLANG(LANG) N ans,io,unknown,i s unknown=$L($T(LANGNAM),";")-3 i (LANG<0)!(LANG>unknown) s LANG=unknown s io=$IO U 0 W !,"%RI has detected a routine written with ",$P($T(LANGNAM),";",LANG+3)," mode." redo f i=0:1:unknown-1 w !,$j(i,4),") ",$P($T(LANGNAM),";",i+3) w ! I LANG=unknown D . w !,"Please enter a number from the above list: <0> " . r ans,! . i ans="" s ans=0 E D . w !,"To change the language mode please enter a number from the above list: <"_LANG_"> " . r ans,! . i ans="" s ans=LANG i (ans'?1.N)!(ans' ","Nn"[D:"No => ",1:"") ;Yes, No or no default F W !,P_"? "_D Read:t R:t Read:'t R DO I "^YN"[R Q ;timed or non-timed read . S X=R,R=$TR($E(R_D_"?"),"yn","YN") I "^YN"'[R W " enter Yes or No, please" S POP=(R="^") W $E($S(R="N":"No",R="Y":"Yes",1:""),$L(X)+1,3) Q R UC(x) q $zcvt(x,"u") STOP(x) S x=$$UC($E(x,1,4)) Q (x["EXIT")!(x["STOP")!(x["QUIT")!(x["HALT")!($E(x)="^") ; -------------------- OPT ;select the mode for loading/viewing routines ;returns: SETOK,POP,OVLAY,BACKUP,WANTCOM,WANTSYN,LIST,SEL() N R,L,I,Y,OP,GO S OP=5,(POP,OVLAY,BACKUP,WANTCOM,LIST,WANTSYN)=0 S GO(1)="OPTA",OP(1)="All Routines" S GO(2)="OPTS",OP(2)="Select routines one at a time" S GO(3)="OPTE",OP(3)="Enter now the names of routines to be selected" S GO(4)="OPTL",OP(4)="List names of routines within the file." S GO(5)="ERROR",OP(5)="Quit %RI" ; U 0 W !!,"( " F I=1:1:OP W $P(OP(I)," ")_" " I I=OP W ")" S $ZT="PICKERR^"_$ZN ;errors should return to the option choice PICK U 0 R !!,"Routine Input Option: ",R:600 S POP=0 I R="" W " Enter 'Q' to quit, ? for more help" G PICK S R=$$UC(R),L=$L(R) I R["?" I W !!?4,"Select one of the available options:" I F I=1:1:OP W !?8,OP(I) I G PICK F I=1:1:OP S Y=OP(I) I $E($$UC(Y),1,L)=R W $E(Y,L+1,99) G @GO(I) W " ??? enter ? for help." G PICK PICKERR U 0 W !,$ZE,! G PICK OPTA ;Save all routines from the COS-code file D OVLQ,BACKUP,COM,SYN,REFQ I POP G PICK S SETOK="" Q OPTS ;Select COS-code routines one at a time D OVLQ,BACKUP,COM,SYN,REFQ I POP G PICK S SETOK="G SELECT" Q OPTE ;enter the routine names to include or exclude N ANS,NS,S,IF W !!,"Enter routine name(s). ? for help",! K SEL F NS=1:1 D GETROU Q:$G(ANS(NS))="" ;select routine patterns S SEL=NS-1 I 'SEL W !,"No selections made -- rechoose option." G PICK D GETLST(SEL) G PICK:$$YN("OK","Y")="N" W !! D OVLQ,BACKUP,COM,SYN,REFQ I POP G PICK S SETOK="N II S OK=0 F II=1:1:SEL X SEL(II)" Q GETROU ;select one routine pattern to allow groups determine if selected R !,"Routine: ",R Q:R="" I R="?" D GETHLP G GETROU I $E(R)="?" D GETLST(NS-1) G GETROU ;list the selections made S X=R,S=1 I "'-"[$E(R) S S=0,R=$E(R,2,$L(R)),X="'"_R ;handle exclusion I '$$OKCHR(R) W *7," invalid character in routine name" G GETROU I (R["*")!(R["?")!(R["&")!(R["#") G GETPAT ;handle as a pattern I R["-" G GETRNG ;handle as a range I R'?1"%".30AN,R'?1A.30AN I W *7," '"_R_"' not a valid routine name" G GETROU S ANS(NS)=X,SEL(NS)="I ROU="""_R_""" S OK="_S Q ;specific routine OKCHR(R) S R=$$UC(R),R=$TR(R,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","") ;no alpha S R=$TR(R,"*?#&-%","AAAAAA") Q (R=$$DP(R)) ;extra punctuation? GETPAT S IF=$$PATRN(R),ANS(NS)=X,SEL(NS)="I ROU?"_IF_" S OK="_S Q GETRNG N F,T S F=$P(R,"-"),T=$P(R,"-",2) I F'?1"%".30AN,F'?1A.30AN W *7," FROM not a valid routine name" G GETROU I T'?1"%".30AN,T'?1A.30AN W *7," UPTO not a valid routine name" G GETROU I T=F W *7," FROM same as UPTO?" G GETROU I F]T W *7," FROM comes after UPTO?" G GETROU S ANS(NS)=X,SEL(NS)="I """_F_"""']ROU,ROU']"""_T_""" S OK="_S Q GETLST(SEL) N II,S,MODE S MODE(1)="Include",MODE(0)="Exclude" W !!,"Selections: (starting with the empty set)" F II=1:1:SEL D DOsel W ! Q DOsel S S=($E(ANS(II))'="'") ;adding or subtracting? from selections W !,$J(II,2)_". "_$$LJ(MODE(S),12),$E(ANS(II),2-S,255) Q GETHLP W !,"Choose routines as in these examples:" W !," RNAM",?18,"One routine" W !," RNAM1-RNAM2",?18,"Range of routines" W !," CD*",?18,"All beginning with CD" W !," 'RNAM",?18,"Exclude these routines from a range or" W !," 'RNAM1-RNAM2",?18,"""*"" group named previously." W !," 'CDG*",! Q OPTL ;List routines in file. S LIST=1,OVLAY=1,BACKUP=0,WANTCOM=0 D SYN,REFQ I POP G PICK S SETOK="S OK=0" Q OVLQ I POP Q ;ask if OK to overwrite existing routines W !!,"If a selected routine has the same name as one already on file," S OVLAY=($$YN("shall it replace the one on file","N")="Y") Q BACKUP I POP Q ;ask if version cascade should occur I (","_EXTS_",")'[(",MAC,"),(","_EXTS_",")'[(",INC,") S BACKUP=0 Q S BACKUP=($$YN("Generate backups","N")="Y") Q COM I POP Q ;ask if MAC/INTs should be compiled to mcode I (","_EXTS_",")'[(",MAC,"),(","_EXTS_",")'[(",INT,") S WANTCOM=0 Q S WANTCOM=($$YN("Recompile","Y")="Y") Q SYN I POP Q ;ask if syntax checking should be show I (","_EXTS_",")'[(",MAC,"),(","_EXTS_",")'[(",INT,") S WANTSYN=0 Q I '$$CHKOK() S WANTSYN=0 Q ;syntax checker is NOT available S WANTSYN=($$YN("Display Syntax Errors","Y")="Y") Q CHKOK() S $ZT="CHKERR" N X X ("ZR ZI "" ;"" S X=$ZU(62,0)") Q 1 ;available! CHKERR Q 0 ;syntax error checking is NOT available REFQ I POP Q ;describe what the symbols will mean, compile object list W !!,"^ indicates routines which will replace those now on file." W !,"@ indicates routines which have been [re]compiled." W !,"- indicates routines which have not been filed.",! I 'LIST,(","_EXTS)[(",OBJ") W !,"Building Object list",! D ^%ROUN Q ERROR S POP=1,DONE=1 Q LJ(x,n) Q ($E(x_$J("",n),1,n)_$E(x,n+1,$L(x))) ;left justify text to n chars DP(x) Q $TR(x," !@#$%^&*()_-+={[}]:;,.?/|\'""~`") PATRN(X) N q,i,x,c S q=0,x="" F i=1:1:$L(X) S c=$E(X,i) S:c="""" c=c_c DO . I "*?&#"'[c S x=x_$S(q:c,1:"1"""_c),q=1 Q ;simple text -- no pattern . S x=x_$E("""",q)_$S(c="&":"1A",c="#":"1N",c="*":".E",1:"1E"),q=0 Q S:q x=x_"""" S X=$P($P($P($P(X,"?"),"#"),"&"),"*") Q x ;return ?@x