{Last Modified: 14-JUN-1989 14:09:02.59, By: FLEMING } [inherit ('sys$library:starlet.pen')] module TPU$CALLUSER; const maxstring = 70; type $UWORD = [WORD] 0..65535; $UBYTE = [BYTE] 0..255; string = PACKED ARRAY [1..maxstring] of CHAR; int_pointer = ^$UWORD; string_pointer = ^string; descriptor = PACKED RECORD length: $UWORD; typed,classd: $UBYTE; str_ptr: string_pointer; END; { record } v_string = varying [256] of char; f_string = [UNSAFE] array [1..256] of char; signed_word = [word] -32767 .. 32767; itmlst = record buffer_length: [UNSAFE] signed_word; case item_code: signed_word of lnm$_chain: ( itemlist_address: ^itmlst_array ); lnm$_string: ( str_buffer_address: [UNSAFE] ^f_string; str_buffer_length: ^INTEGER ); lnm$_table: ( tbl_buffer_address: ^F_string; tbl_return_length: ^INTEGER ); end;{record} jpilst = record buffer_length: [UNSAFE] signed_word; case item_code: signed_word of jpi$_imagname,jpi$_username,jpi$_terminal: ( str_buffer_address: string_pointer; str_buffer_length: ^INTEGER; ); jpi$_master_pid,jpi$_pid,jpi$_owner,jpi$_prccnt,jpi$_mode, jpi$_state,jpi$_proc_index,jpi$_uic: ( int_buffer_address: ^INTEGER; int_buffer_length: ^INTEGER; ); end; (* jpi record *) jpilst_array = array [1..11] of jpilst; itmlst_array = array [1..3] of itmlst; VAR status: INTEGER; trnlnmlst: array [1..2] of itmlst; {translate logical itemlist} jpi_items: array [1..2] of jpilst; (******************** Procedure declarations ****************************) [ASYNCHRONOUS,EXTERNAL(SYS$SETDDIR)] function $setddir ( %stdescr new_dir_address: packed array [$l1..$u1:integer] of char; %ref length_addr: [volatile] $UWORD; %stdescr cur_dir_addr: packed array [$ll1..$uu1:integer] of char ) : integer;external; (*--------------------------------------------------------------------------*) [EXTERNAL,ASYNCHRONOUS] Function str$copy_dx ( des_str: descriptor; scr_str: descriptor ): integer;external; (*-------------------------------------------------------------------------*) [EXTERNAL,ASYNCHRONOUS] Function ots$cvt_l_tz ( var value: $UWORD; str_buffer: descriptor; %immed number_digits: integer; %immed input_size: integer ): integer;external; (*-------------------------------------------------------------------------*) [EXTERNAL, ASYNCHRONOUS] FUNCTION OTS$CVT_TZ_L ( Inp_Str : descriptor; var Value : $UWORD; %IMMED Value_Size : INTEGER := %IMMED 4; %IMMED Flags : UNSIGNED:= %IMMED 0): INTEGER; EXTERN; [EXTERNAL, ASYNCHRONOUS] FUNCTION OTS$CVT_TO_L ( Inp_Str : descriptor; var Value : $UWORD; %IMMED Value_Size : INTEGER := %IMMED 4; %IMMED Flags : UNSIGNED:= %IMMED 0): INTEGER; EXTERN; [EXTERNAL, ASYNCHRONOUS] FUNCTION OTS$CVT_TI_L ( Inp_Str : descriptor; var Value : $UWORD; %IMMED Value_Size : INTEGER := %IMMED 4; %IMMED Flags : UNSIGNED:= %IMMED 0): INTEGER; EXTERN; (*-------------------------------------------------------------------------*) [EXTERNAL(lib$get_symbol)] Function get_symbol ( symbol: descriptor; VAR value: descriptor; VAR table, retlen: INTEGER := %IMMED(0) ): INTEGER; EXTERNAL; (*-------------------------------------------------------------------------*) [EXTERNAL(str$copy_r)] Function $copy_r ( dst: descriptor; length_src: INTEGER; src: [UNSAFE] string ): INTEGER; EXTERNAL; (*-------------------------------------------------------------------------*) (* Following declaration came from DSIN *) { We provide our own definition of $TRNLNM because the one in STARLET wants the lognam to be of type PACKED ARRAY [$l3..$u3:INTEGER] OF CHAR. Since we are receiving P2 by reference to a descriptor, PASCAL type checking will not deal well with a string. THEREFORE, we have to trick the compiler by defining our own TRNLNM function where LOGNAM is of type DESCRIPTOR.} [ASYNCHRONOUS,EXTERNAL(SYS$TRNLNM)] FUNCTION TRNLNM ( %REF ATTR : UNSIGNED := %IMMED 0; TABNAM : [UNSAFE, CLASS_S] PACKED ARRAY [$l2..$u2:INTEGER] OF CHAR; LOGNAM : descriptor; %REF ACMODE : $UBYTE := %IMMED 0; %REF ITMLST : [UNSAFE] ARRAY [$l5..$u5:INTEGER] OF $UBYTE := %IMMED 0) : INTEGER; EXTERNAL; (*---------------------------------------------------------------------------*) [ASYNCHRONOUS,EXTERNAL(SYS$CRELNM)] FUNCTION CRELNM ( %REF ATTR : UNSIGNED := %IMMED 0; TABNAM : [UNSAFE, CLASS_S] PACKED ARRAY [$l2..$u2:INTEGER] OF CHAR; %stdescr lognam: packed array [$l1..$u1:integer] of char; %REF ACMODE : $UBYTE := %IMMED 0; %REF ITMLST : [UNSAFE] ARRAY [$l5..$u5:INTEGER] OF $UBYTE := %IMMED 0) : INTEGER; EXTERNAL; (*---------------------------------------------------------------------------*) [Asynchronous,External(LIB$SET_LOGICAL)] Function SET_LOGICAL( %stdescr lognam: packed array [$l1..$u1:integer] of char; %descr value_string: v_string; TABNAM : [UNSAFE, CLASS_S] PACKED ARRAY [$l2..$u2:INTEGER] OF CHAR; %REF ATTR : UNSIGNED := %IMMED 0; %REF ITMLST : [UNSAFE] ARRAY [$l5..$u5:INTEGER] OF $UBYTE := %IMMED 0) : INTEGER; EXTERNAL; (*--------------------------------------------------------------------------*) [Asynchronous,External(STR$TRIM)] Function TRIM( %descr destination: v_string; %stdescr source: packed array [$ll1..$uu1:integer] of char; %ref result_length: [volatile] $UWORD := %IMMED 0): INTEGER; EXTERNAL; (*********************** END OF PROCEDURE DECLARATIONS **********************) (*--------------------- GET_JPICODE ----------------------------------------- | Given a string lookup the corresponding itemcode value | --------------------------------------------------------------------------*) function get_jpicode(buffer:descriptor;var number:$UWORD):integer; begin if (buffer.str_ptr^ = 'IMAGNAME') then number := JPI$_IMAGNAME else if (buffer.str_ptr^ = 'MASTER_PID') then number := JPI$_MASTER_PID else if (buffer.str_ptr^ = 'MODE') then number := JPI$_MODE else if (buffer.str_ptr^ = 'OWNER') then number := JPI$_OWNER else if (buffer.str_ptr^ = 'PID') then number := JPI$_PID else if (buffer.str_ptr^ = 'PRCCNT') then number := JPI$_PRCCNT else if (buffer.str_ptr^ = 'PROC_INDEX') then number := JPI$_PROC_INDEX else if (buffer.str_ptr^ = 'STATE') then number := JPI$_STATE else if (buffer.str_ptr^ = 'TERMINAL') then number := JPI$_TERMINAL else if (buffer.str_ptr^ = 'UIC') then number := JPI$_UIC else if (buffer.str_ptr^ = 'USERNAME') then number := JPI$_USERNAME else get_jpicode := 0;(* no find it *) get_jpicode := 1; (* ah ha ... got the critter signal success *) end; (*---------------------------- JPICALL -------------------------------------- | Args are 2-dynamic string descriptors. Input descriptor contains a literal| | string specifying the itemcode to use for a $getjpi call. Itemcode string | | is the same as one would use for f$getjpi at DCL level. The string is fed | | get_jpicode which will return the numeric representation of the jpicode. | | A case statement then directs execution flow depending on whether the jpi | | code will return a string or (hex) integer from $getjpi. If integer it's | | converted to a hex string before being stuffed back into the result | | descriptor. | ---------------------------------------------------------------------------*) function jpicall(p2:[volatile,unsafe] descriptor; var result:[volatile,unsafe]descriptor):integer; var status: integer; coder,number,retlen: $UWORD; jpilist: array [1..2] of jpilst; (* list of items *) buffer: descriptor; (* "safe" scaler string descriptor*) this_string: [volatile]string; (* buffer for scaler *) begin number := 0; this_string := ' '; buffer.length := p2.length; (* setup a scaler string descr *) buffer.str_ptr := address(this_string); buffer.typed := DSC$K_DTYPE_P; buffer.classd := DSC$K_CLASS_S; (* copy it from that nasty dynamic string descr *) status := str$copy_dx(des_str :=buffer,scr_str := p2); if (status <> SS$_NORMAL) then jpicall := status; (* get out while we can *) status := get_jpicode(buffer,number);(* get numberic itemcode *) if (status <> SS$_NORMAL) then jpicall := status; (* most likely unknown itemcode *) jpilist[1].item_code := number; (* else hand it off to the itemlist*) jpilist[2].buffer_length := 0; (* zero terminate jpilist *) jpilist[2].item_code := 0; (* determine if it's a string or integer type of itemcode-jpi call *) case number of jpi$_imagname,jpi$_username,jpi$_terminal: begin (* stringy - setup appropriate lengths *) if (number = jpi$_terminal) then jpilist[1].buffer_length := 7 else if (number = jpi$_username) then jpilist[1].buffer_length := 12 else jpilist[1].buffer_length := 255; new(jpilist[1].str_buffer_address); new(jpilist[1].str_buffer_length); status := $getjpi(,,,jpilist); (* hold breath *) if (status <> SS$_NORMAL) then jpicall := status; (* "bad software" *) (* get the info from the call *) buffer.str_ptr := jpilist[1].str_buffer_address; buffer.length := jpilist[1].str_buffer_length^; (* copy it into the dynamic result string *) status := str$copy_dx(result,buffer); if (status <> SS$_NORMAL) then jpicall := status; (* string bad *) (* else dispose of memory and exit out successful *) dispose(jpilist[1].str_buffer_length); dispose(jpilist[1].str_buffer_address); jpicall := status; end; (* end string *) jpi$_master_pid,jpi$_pid,jpi$_owner,jpi$_prccnt,jpi$_mode, jpi$_state,jpi$_proc_index,jpi$_uic: begin (* itemcode is numeric in nature *) jpilist[1].buffer_length := 4;(* longword *) new(jpilist[1].int_buffer_address); jpilist[1].int_buffer_address^ := 0; (*initial*) new(jpilist[1].int_buffer_length); jpilist[1].int_buffer_length^ := 0; status := $getjpi(,,,jpilist); if (status <> SS$_NORMAL) then jpicall := status; (* another fine mess *) (* else we golden prepare to convert to hex text *) this_string := ' '; buffer.str_ptr := address(this_string); (* grab the numeric value *) number := jpilist[1].int_buffer_address^; status := ots$cvt_l_tz (value:=number, str_buffer:=buffer, number_digits:=1, input_size:=2); if (status <> SS$_NORMAL) then jpicall := status; (* darn this new math *) status := str$copy_dx(result,buffer); if (status <> SS$_NORMAL) then jpicall := status; (* they're back... *) (* put our toys away *) dispose(jpilist[1].int_buffer_length); dispose(jpilist[1].int_buffer_address); jpicall := status; (* yea we made it! *) end; (* end numeric *) end; (*case*) end; (*------------------------ HOD_INT -----------------------------------------*) (* presently not used. Would be nice if we could stuff values in P1, but apparently TPU passes copies, not the original address *) function hod_int(var p1:integer;p2:[volatile,unsafe] descriptor; var result:[volatile,unsafe] descriptor):integer; var buffer: descriptor; (* "safe" scaler string descriptor*) this_string: [volatile]string; (* buffer for scaler *) that_string : [volatile] array [1..255] of char; value : $UWORD; flags,outsize: integer; begin this_string := ' '; buffer.length := p2.length; (* setup a scaler string descr *) buffer.str_ptr := address(this_string); buffer.typed := DSC$K_DTYPE_P; buffer.classd := DSC$K_CLASS_S; status := str$copy_dx(des_str :=buffer,scr_str := p2); if (status <> SS$_NORMAL) then hod_int := status; (* get out while we can *) unpack (this_string,that_string,1); if (that_string[1] <> '%') then begin status := LIB$_INVARG; hod_int := status; end; pack(that_string,3,this_string); buffer.length := buffer.length - 2; flags := 0; outsize := 4; if (that_string[2] = 'X') then begin status := ots$cvt_tz_l(buffer,value,outsize,flags); p1 := value; hod_int := status; end else if (that_string[2] = 'O') then begin status := ots$cvt_to_l(buffer,value,outsize,flags); p1 := value; hod_int := status; end else if (that_string[2] = 'D') then begin status := ots$cvt_ti_l(buffer,value,outsize,flags); p1 := value; hod_int := status; end else begin status := LIB$_INVARG; hod_int := status; end; end; (* Let's delete a file! *) function delete_user_file(p2:[volatile,unsafe] descriptor):integer; var buffer: descriptor; (* "safe" scaler string descriptor*) filename: [volatile]string; (* buffer for scaler *) begin filename := ' '; buffer.length := p2.length; (* setup a scaler string descr *) buffer.str_ptr := address(filename); buffer.typed := DSC$K_DTYPE_P; buffer.classd := DSC$K_CLASS_S; status := str$copy_dx(des_str :=buffer,scr_str := p2); if (status <> SS$_NORMAL) then delete_user_file := status; (* run and hide *) delete_file(filename,status); delete_user_file := status; end; (*---------------------------- SET_DEFAULT -------------------------- | Set default to a directory. After setting default then change | | sys$disk logical so that disk is reset. | -------------------------------------------------------------------*) function set_default(p2:[volatile,unsafe] descriptor):integer; var new_dir: descriptor; (* "safe" scaler string descriptor*) this_string, another_string: [volatile]string; device_name : [volatile]v_string; start_pos,length_addr,index_pos: [volatile]$UWORD; begin this_string := ' '; another_string := ' '; new_dir.length := p2.length; (* setup a scaler string descr *) new_dir.str_ptr := address(this_string); new_dir.typed := DSC$K_DTYPE_P; new_dir.classd := DSC$K_CLASS_S; status := str$copy_dx(des_str :=new_dir,scr_str := p2); if (status <> SS$_NORMAL) then set_default := status; (* bad noodles *) status := $setddir(this_string,length_addr,another_string); (* set default to directory *) if (status <> RMS$_NORMAL) then set_default := status; (* Number 5 not alive *) index_pos := index(this_string,':'); if (index_pos <> 0) then begin (* if there was a device in the filespec. *) start_pos := 1; another_string := substr(this_string,start_pos,index_pos); (* trim off trailing blanks *) status := trim(device_name,another_string,length_addr); if (status <> SS$_NORMAL) then set_default := status; (* bad triming *) (* call lib$ routine to set the logical *) status := set_logical('SYS$DISK',device_name,'LNM$PROCESS',,); end; set_default := status; (* one way or another return *) end; (*------------------------------------------------------------------------*) (*--------------------------------------------------------------------------- | Original code appeared on Dsin as a pascal example for calluser. $GETJPI | | delete_file, set_default code and whatever appears in future was added. | |--------------------------------------------------------------------------*) [GLOBAL] function TPU$CALLUSER (* main routine *) ( var p1: integer; p2: [VOLATILE, UNSAFE] descriptor; VAR result: descriptor ): integer; begin (*------------------------------------------------------------------------ | case statement routines: | | 1: get_symbol | | 2: $trnlnm | | 3: $getjpi | | 4: hex, oct, dec string to decimal ! NOT CURRENTLY USED | | 5: delete file | | 6: $setdef | ----------------------------------------------------------------------*) case p1 of 1: tpu$calluser := get_symbol(symbol:= p2, value := result); 2: begin { Set up itemlist for $trnlnm } trnlnmlst[1].buffer_length := 255; trnlnmlst[1].item_code := lnm$_string; NEW(trnlnmlst[1].str_buffer_length); NEW(trnlnmlst[1].str_buffer_address); { Last longword of the itemlist must be 0.} trnlnmlst[2].buffer_length := 0; trnlnmlst[2].item_code := 0; { Translate logical. It is case sensitive and there must be no trailing blanks in the logical name or table name.} status := trnlnm ( tabnam := 'LNM$FILE_DEV', lognam := p2, itmlst := trnlnmlst ); IF odd(status) THEN tpu$calluser := $copy_r( result,trnlnmlst[1].str_buffer_length^, trnlnmlst[1].str_buffer_address^) ELSE tpu$calluser := status; dispose(trnlnmlst[1].str_buffer_length); dispose(trnlnmlst[1].str_buffer_address); end; { 2 } 3: begin tpu$calluser := jpicall(p2,result); end; 4: begin tpu$calluser := hod_int(p1,p2,result); end; 5: begin tpu$calluser := delete_user_file(p2); end; 6: begin tpu$calluser := set_default(p2); end; otherwise tpu$calluser := 0; end; { case } end; { proc tpu$calluser } end.