TPU$CALLUSER 22-Jun-1989 13:52:51 VAX Pascal V3.9-289 Page 1 01 Source Listing 14-Jun-1989 14:09:03 CALLUSER.PAS;1 (1) -LINE-IDC-PL-SL- 00001 C 0 0 {Last Modified: 14-JUN-1989 14:09:02.59, By: FLEMING } 00002 0 0 [inherit ('sys$library:starlet.pen')] module TPU$CALLUSER; 00003 0 0 const 00004 0 0 maxstring = 70; 00005 0 0 type 00006 0 0 $UWORD = [WORD] 0..65535; 00007 0 0 $UBYTE = [BYTE] 0..255; 00008 0 0 string = PACKED ARRAY [1..maxstring] of CHAR; 00009 0 0 int_pointer = ^$UWORD; 00010 0 0 string_pointer = ^string; 00011 0 0 descriptor = PACKED RECORD 00012 0 0 length: $UWORD; 00013 0 0 typed,classd: $UBYTE; 00014 0 0 str_ptr: string_pointer; 00015 0 0 END; { record } 00016 0 0 v_string = varying [256] of char; 00017 0 0 f_string = [UNSAFE] array [1..256] of char; 00018 0 0 signed_word = [word] -32767 .. 32767; 00019 0 0 itmlst = record 00020 0 0 buffer_length: [UNSAFE] signed_word; 00021 0 0 case item_code: signed_word of 00022 0 0 lnm$_chain: 00023 0 0 ( 00024 0 0 itemlist_address: ^itmlst_array 00025 0 0 ); 00026 0 0 lnm$_string: 00027 0 0 ( 00028 0 0 str_buffer_address: [UNSAFE] ^f_string; 00029 0 0 str_buffer_length: ^INTEGER 00030 0 0 ); 00031 0 0 lnm$_table: 00032 0 0 ( 00033 0 0 tbl_buffer_address: ^F_string; 00034 0 0 tbl_return_length: ^INTEGER 00035 0 0 ); 00036 0 0 end;{record} 00037 0 0 jpilst = record 00038 0 0 buffer_length: [UNSAFE] signed_word; 00039 0 0 case item_code: signed_word of 00040 0 0 jpi$_imagname,jpi$_username,jpi$_terminal: 00041 0 0 00042 0 0 ( 00043 0 0 str_buffer_address: string_pointer; 00044 0 0 str_buffer_length: ^INTEGER; 00045 0 0 ); 00046 0 0 jpi$_master_pid,jpi$_pid,jpi$_owner,jpi$_prccnt,jpi$_mode, 00047 0 0 jpi$_state,jpi$_proc_index,jpi$_uic: 00048 0 0 ( 00049 0 0 int_buffer_address: ^INTEGER; 00050 0 0 int_buffer_length: ^INTEGER; 00051 0 0 ); 00052 0 0 00053 0 0 end; (* jpi record *) 00054 0 0 jpilst_array = array [1..11] of jpilst; 00055 0 0 itmlst_array = array [1..3] of itmlst; TPU$CALLUSER 22-Jun-1989 13:52:51 VAX Pascal V3.9-289 Page 2 01 Source Listing 14-Jun-1989 14:09:03 CALLUSER.PAS;1 (1) -LINE-IDC-PL-SL- 00056 0 0 VAR 00057 0 0 status: INTEGER; 00058 0 0 trnlnmlst: array [1..2] of itmlst; {translate logical itemlist} 00059 0 0 jpi_items: array [1..2] of jpilst; 00060 0 0 00061 C 0 0 (******************** Procedure declarations ****************************) 00062 1 0 [ASYNCHRONOUS,EXTERNAL(SYS$SETDDIR)] function $setddir 00063 1 0 ( 00064 1 0 %stdescr new_dir_address: packed array [$l1..$u1:integer] 00065 1 0 of char; 00066 1 0 %ref length_addr: [volatile] $UWORD; 00067 1 0 %stdescr cur_dir_addr: packed array [$ll1..$uu1:integer] 00068 0 0 of char ) : integer;external; 00069 C 0 0 (*--------------------------------------------------------------------------*) 00070 1 0 [EXTERNAL,ASYNCHRONOUS] Function str$copy_dx 00071 1 0 ( 00072 1 0 des_str: descriptor; 00073 1 0 scr_str: descriptor 00074 0 0 ): integer;external; 00075 C 0 0 (*-------------------------------------------------------------------------*) 00076 1 0 [EXTERNAL,ASYNCHRONOUS] Function ots$cvt_l_tz 00077 1 0 ( 00078 1 0 var value: $UWORD; 00079 1 0 str_buffer: descriptor; 00080 1 0 %immed number_digits: integer; 00081 1 0 %immed input_size: integer 00082 0 0 ): integer;external; 00083 C 0 0 (*-------------------------------------------------------------------------*) 00084 1 0 [EXTERNAL, ASYNCHRONOUS] FUNCTION OTS$CVT_TZ_L 00085 1 0 ( Inp_Str : descriptor; 00086 1 0 var Value : $UWORD; 00087 1 0 %IMMED Value_Size : INTEGER := %IMMED 4; 00088 1 0 %IMMED Flags : UNSIGNED:= %IMMED 0): 00089 0 0 INTEGER; EXTERN; 00090 1 0 [EXTERNAL, ASYNCHRONOUS] FUNCTION OTS$CVT_TO_L 00091 1 0 ( Inp_Str : descriptor; 00092 1 0 var Value : $UWORD; 00093 1 0 %IMMED Value_Size : INTEGER := %IMMED 4; 00094 1 0 %IMMED Flags : UNSIGNED:= %IMMED 0): 00095 0 0 INTEGER; EXTERN; 00096 1 0 [EXTERNAL, ASYNCHRONOUS] FUNCTION OTS$CVT_TI_L 00097 1 0 ( Inp_Str : descriptor; 00098 1 0 var Value : $UWORD; 00099 1 0 %IMMED Value_Size : INTEGER := %IMMED 4; 00100 1 0 %IMMED Flags : UNSIGNED:= %IMMED 0): 00101 0 0 INTEGER; EXTERN; 00102 0 0 00103 0 0 00104 0 0 00105 C 0 0 (*-------------------------------------------------------------------------*) 00106 1 0 [EXTERNAL(lib$get_symbol)] Function get_symbol 00107 1 0 ( 00108 1 0 symbol: descriptor; 00109 1 0 VAR value: descriptor; 00110 1 0 VAR table, retlen: INTEGER := %IMMED(0) TPU$CALLUSER 22-Jun-1989 13:52:51 VAX Pascal V3.9-289 Page 3 01 Source Listing 14-Jun-1989 14:09:03 CALLUSER.PAS;1 (1) -LINE-IDC-PL-SL- 00111 0 0 ): INTEGER; EXTERNAL; 00112 0 0 00113 C 0 0 (*-------------------------------------------------------------------------*) 00114 1 0 [EXTERNAL(str$copy_r)] Function $copy_r 00115 1 0 ( 00116 1 0 dst: descriptor; 00117 1 0 length_src: INTEGER; 00118 1 0 src: [UNSAFE] string 00119 0 0 ): INTEGER; EXTERNAL; 00120 C 0 0 (*-------------------------------------------------------------------------*) 00121 C 0 0 (* Following declaration came from DSIN *) 00122 C 0 0 { We provide our own definition of $TRNLNM because the one in STARLET wants 00123 C 0 0 the lognam to be of type PACKED ARRAY [$l3..$u3:INTEGER] OF CHAR. Since we 00124 C 0 0 are receiving P2 by reference to a descriptor, PASCAL type checking will not 00125 C 0 0 deal well with a string. THEREFORE, we have to trick the compiler by defining 00126 C 0 0 our own TRNLNM function where LOGNAM is of type DESCRIPTOR.} 00127 0 0 00128 1 0 [ASYNCHRONOUS,EXTERNAL(SYS$TRNLNM)] FUNCTION TRNLNM ( 00129 1 0 %REF ATTR : UNSIGNED := %IMMED 0; 00130 1 0 TABNAM : [UNSAFE, CLASS_S] PACKED ARRAY [$l2..$u2:INTEGER] OF CHAR; 00131 1 0 LOGNAM : descriptor; 00132 1 0 %REF ACMODE : $UBYTE := %IMMED 0; 00133 0 0 %REF ITMLST : [UNSAFE] ARRAY [$l5..$u5:INTEGER] OF $UBYTE := %IMMED 0) : INTEGER; EXTERNAL; 00134 C 0 0 (*---------------------------------------------------------------------------*) 00135 1 0 [ASYNCHRONOUS,EXTERNAL(SYS$CRELNM)] FUNCTION CRELNM ( 00136 1 0 %REF ATTR : UNSIGNED := %IMMED 0; 00137 1 0 TABNAM : [UNSAFE, CLASS_S] PACKED ARRAY [$l2..$u2:INTEGER] OF CHAR; 00138 1 0 %stdescr lognam: packed array [$l1..$u1:integer] of char; 00139 1 0 %REF ACMODE : $UBYTE := %IMMED 0; 00140 0 0 %REF ITMLST : [UNSAFE] ARRAY [$l5..$u5:INTEGER] OF $UBYTE := %IMMED 0) : INTEGER; EXTERNAL; 00141 C 0 0 (*---------------------------------------------------------------------------*) 00142 1 0 [Asynchronous,External(LIB$SET_LOGICAL)] Function SET_LOGICAL( 00143 1 0 %stdescr lognam: packed array [$l1..$u1:integer] of char; 00144 1 0 %descr value_string: v_string; 00145 1 0 TABNAM : [UNSAFE, CLASS_S] PACKED ARRAY [$l2..$u2:INTEGER] OF CHAR; 00146 1 0 %REF ATTR : UNSIGNED := %IMMED 0; 00147 0 0 %REF ITMLST : [UNSAFE] ARRAY [$l5..$u5:INTEGER] OF $UBYTE := %IMMED 0) : INTEGER; EXTERNAL; 00148 C 0 0 (*--------------------------------------------------------------------------*) 00149 1 0 [Asynchronous,External(STR$TRIM)] Function TRIM( 00150 1 0 %descr destination: v_string; 00151 1 0 %stdescr source: packed array [$ll1..$uu1:integer] of char; 00152 0 0 %ref result_length: [volatile] $UWORD := %IMMED 0): INTEGER; EXTERNAL; 00153 C 0 0 (*********************** END OF PROCEDURE DECLARATIONS **********************) 00154 C 0 0 (*--------------------- GET_JPICODE ----------------------------------------- 00155 C 0 0 | Given a string lookup the corresponding itemcode value | 00156 C 0 0 --------------------------------------------------------------------------*) 00157 1 0 function get_jpicode(buffer:descriptor;var number:$UWORD):integer; 00158 1 1 begin 00159 1 1 if (buffer.str_ptr^ = 'IMAGNAME') 00160 1 1 then 00161 1 1 number := JPI$_IMAGNAME 00162 1 1 else if (buffer.str_ptr^ = 'MASTER_PID') 00163 1 1 then 00164 1 1 number := JPI$_MASTER_PID 00165 1 1 else if (buffer.str_ptr^ = 'MODE') TPU$CALLUSER 22-Jun-1989 13:52:51 VAX Pascal V3.9-289 Page 4 01 Source Listing 14-Jun-1989 14:09:03 CALLUSER.PAS;1 (1) -LINE-IDC-PL-SL- 00166 1 1 then 00167 1 1 number := JPI$_MODE 00168 1 1 else if (buffer.str_ptr^ = 'OWNER') 00169 1 1 then 00170 1 1 number := JPI$_OWNER 00171 1 1 else if (buffer.str_ptr^ = 'PID') 00172 1 1 then 00173 1 1 number := JPI$_PID 00174 1 1 else if (buffer.str_ptr^ = 'PRCCNT') 00175 1 1 then 00176 1 1 number := JPI$_PRCCNT 00177 1 1 else if (buffer.str_ptr^ = 'PROC_INDEX') 00178 1 1 then 00179 1 1 number := JPI$_PROC_INDEX 00180 1 1 else if (buffer.str_ptr^ = 'STATE') 00181 1 1 then 00182 1 1 number := JPI$_STATE 00183 1 1 else if (buffer.str_ptr^ = 'TERMINAL') 00184 1 1 then 00185 1 1 number := JPI$_TERMINAL 00186 1 1 else if (buffer.str_ptr^ = 'UIC') 00187 1 1 then 00188 1 1 number := JPI$_UIC 00189 1 1 else if (buffer.str_ptr^ = 'USERNAME') 00190 1 1 then 00191 1 1 number := JPI$_USERNAME 00192 1 1 else 00193 1 1 get_jpicode := 0;(* no find it *) 00194 1 1 get_jpicode := 1; (* ah ha ... got the critter signal success *) 00195 0 0 end; 00196 C 0 0 (*---------------------------- JPICALL -------------------------------------- 00197 C 0 0 | Args are 2-dynamic string descriptors. Input descriptor contains a literal| 00198 C 0 0 | string specifying the itemcode to use for a $getjpi call. Itemcode string | 00199 C 0 0 | is the same as one would use for f$getjpi at DCL level. The string is fed | 00200 C 0 0 | get_jpicode which will return the numeric representation of the jpicode. | 00201 C 0 0 | A case statement then directs execution flow depending on whether the jpi | 00202 C 0 0 | code will return a string or (hex) integer from $getjpi. If integer it's | 00203 C 0 0 | converted to a hex string before being stuffed back into the result | 00204 C 0 0 | descriptor. | 00205 C 0 0 ---------------------------------------------------------------------------*) 00206 0 0 00207 1 0 function jpicall(p2:[volatile,unsafe] descriptor; 00208 1 0 var result:[volatile,unsafe]descriptor):integer; 00209 1 0 var 00210 1 0 status: integer; 00211 1 0 coder,number,retlen: $UWORD; 00212 1 0 jpilist: array [1..2] of jpilst; (* list of items *) 00213 1 0 buffer: descriptor; (* "safe" scaler string descriptor*) 00214 1 0 this_string: [volatile]string; (* buffer for scaler *) 00215 1 1 begin 00216 1 1 number := 0; 00217 1 1 this_string := ' '; 00218 1 1 buffer.length := p2.length; (* setup a scaler string descr *) 00219 1 1 buffer.str_ptr := address(this_string); 00220 1 1 buffer.typed := DSC$K_DTYPE_P; TPU$CALLUSER 22-Jun-1989 13:52:51 VAX Pascal V3.9-289 Page 5 01 Source Listing 14-Jun-1989 14:09:03 CALLUSER.PAS;1 (1) -LINE-IDC-PL-SL- 00221 1 1 buffer.classd := DSC$K_CLASS_S; 00222 C 1 1 (* copy it from that nasty dynamic string descr *) 00223 1 1 status := str$copy_dx(des_str :=buffer,scr_str := p2); 00224 1 1 if (status <> SS$_NORMAL) then 00225 1 1 jpicall := status; (* get out while we can *) 00226 1 1 status := get_jpicode(buffer,number);(* get numberic itemcode *) 00227 1 1 if (status <> SS$_NORMAL) then 00228 1 1 jpicall := status; (* most likely unknown itemcode *) 00229 1 1 jpilist[1].item_code := number; (* else hand it off to the itemlist*) 00230 1 1 jpilist[2].buffer_length := 0; (* zero terminate jpilist *) 00231 1 1 jpilist[2].item_code := 0; 00232 C 1 1 (* determine if it's a string or integer type of itemcode-jpi call *) 00233 1 2 case number of 00234 1 2 jpi$_imagname,jpi$_username,jpi$_terminal: 00235 1 3 begin (* stringy - setup appropriate lengths *) 00236 1 3 if (number = jpi$_terminal) then 00237 1 3 jpilist[1].buffer_length := 7 00238 1 3 else if (number = jpi$_username) then 00239 1 3 jpilist[1].buffer_length := 12 00240 1 3 else 00241 1 3 jpilist[1].buffer_length := 255; 00242 1 3 new(jpilist[1].str_buffer_address); 00243 1 3 new(jpilist[1].str_buffer_length); 00244 1 3 status := $getjpi(,,,jpilist); (* hold breath *) 00245 1 3 00246 1 3 if (status <> SS$_NORMAL) then 00247 1 3 jpicall := status; (* "bad software" *) 00248 C 1 3 (* get the info from the call *) 00249 1 3 buffer.str_ptr := jpilist[1].str_buffer_address; 00250 1 3 buffer.length := jpilist[1].str_buffer_length^; 00251 C 1 3 (* copy it into the dynamic result string *) 00252 1 3 status := str$copy_dx(result,buffer); 00253 1 3 if (status <> SS$_NORMAL) then 00254 1 3 jpicall := status; (* string bad *) 00255 C 1 3 (* else dispose of memory and exit out successful *) 00256 1 3 dispose(jpilist[1].str_buffer_length); 00257 1 3 dispose(jpilist[1].str_buffer_address); 00258 1 3 jpicall := status; 00259 1 2 end; (* end string *) 00260 1 2 jpi$_master_pid,jpi$_pid,jpi$_owner,jpi$_prccnt,jpi$_mode, 00261 1 2 jpi$_state,jpi$_proc_index,jpi$_uic: 00262 1 3 begin (* itemcode is numeric in nature *) 00263 1 3 jpilist[1].buffer_length := 4;(* longword *) 00264 1 3 new(jpilist[1].int_buffer_address); 00265 1 3 jpilist[1].int_buffer_address^ := 0; (*initial*) 00266 1 3 new(jpilist[1].int_buffer_length); 00267 1 3 jpilist[1].int_buffer_length^ := 0; 00268 1 3 status := $getjpi(,,,jpilist); 00269 1 3 if (status <> SS$_NORMAL) then 00270 1 3 jpicall := status; (* another fine mess *) 00271 C 1 3 (* else we golden prepare to convert to hex text *) 00272 1 3 this_string := ' '; 00273 1 3 buffer.str_ptr := address(this_string); 00274 C 1 3 (* grab the numeric value *) 00275 1 3 number := jpilist[1].int_buffer_address^; TPU$CALLUSER 22-Jun-1989 13:52:51 VAX Pascal V3.9-289 Page 6 01 Source Listing 14-Jun-1989 14:09:03 CALLUSER.PAS;1 (1) -LINE-IDC-PL-SL- 00276 1 3 status := ots$cvt_l_tz 00277 1 3 (value:=number, 00278 1 3 str_buffer:=buffer, 00279 1 3 number_digits:=1, 00280 1 3 input_size:=2); 00281 1 3 if (status <> SS$_NORMAL) then 00282 1 3 jpicall := status; (* darn this new math *) 00283 1 3 status := str$copy_dx(result,buffer); 00284 1 3 if (status <> SS$_NORMAL) then 00285 1 3 jpicall := status; (* they're back... *) 00286 C 1 3 (* put our toys away *) 00287 1 3 dispose(jpilist[1].int_buffer_length); 00288 1 3 dispose(jpilist[1].int_buffer_address); 00289 1 3 jpicall := status; (* yea we made it! *) 00290 1 2 end; (* end numeric *) 00291 1 1 end; (*case*) 00292 0 0 end; 00293 C 0 0 (*------------------------ HOD_INT -----------------------------------------*) 00294 C 0 0 (* presently not used. Would be nice if we could stuff values in P1, but 00295 C 0 0 apparently TPU passes copies, not the original address *) 00296 1 0 function hod_int(var p1:integer;p2:[volatile,unsafe] descriptor; 00297 1 0 var result:[volatile,unsafe] descriptor):integer; 00298 1 0 00299 1 0 var 00300 1 0 buffer: descriptor; (* "safe" scaler string descriptor*) 00301 1 0 this_string: [volatile]string; (* buffer for scaler *) 00302 1 0 that_string : [volatile] array [1..255] of char; 00303 1 0 value : $UWORD; 00304 1 0 flags,outsize: integer; 00305 1 1 begin 00306 1 1 this_string := ' '; 00307 1 1 buffer.length := p2.length; (* setup a scaler string descr *) 00308 1 1 buffer.str_ptr := address(this_string); 00309 1 1 buffer.typed := DSC$K_DTYPE_P; 00310 1 1 buffer.classd := DSC$K_CLASS_S; 00311 1 1 status := str$copy_dx(des_str :=buffer,scr_str := p2); 00312 1 1 if (status <> SS$_NORMAL) then 00313 1 1 hod_int := status; (* get out while we can *) 00314 1 1 unpack (this_string,that_string,1); 00315 1 1 if (that_string[1] <> '%') then 00316 1 2 begin 00317 1 2 status := LIB$_INVARG; 00318 1 2 hod_int := status; 00319 1 1 end; 00320 1 1 pack(that_string,3,this_string); 00321 1 1 buffer.length := buffer.length - 2; 00322 1 1 flags := 0; 00323 1 1 outsize := 4; 00324 1 1 if (that_string[2] = 'X') then 00325 1 2 begin 00326 1 2 status := ots$cvt_tz_l(buffer,value,outsize,flags); 00327 1 2 p1 := value; 00328 1 2 hod_int := status; 00329 1 2 end 00330 1 1 else if (that_string[2] = 'O') then TPU$CALLUSER 22-Jun-1989 13:52:51 VAX Pascal V3.9-289 Page 7 01 Source Listing 14-Jun-1989 14:09:03 CALLUSER.PAS;1 (1) -LINE-IDC-PL-SL- 00331 1 2 begin 00332 1 2 status := ots$cvt_to_l(buffer,value,outsize,flags); 00333 1 2 p1 := value; 00334 1 2 hod_int := status; 00335 1 2 end 00336 1 1 else if (that_string[2] = 'D') then 00337 1 2 begin 00338 1 2 status := ots$cvt_ti_l(buffer,value,outsize,flags); 00339 1 2 p1 := value; 00340 1 2 hod_int := status; 00341 1 2 end 00342 1 1 else 00343 1 2 begin 00344 1 2 status := LIB$_INVARG; 00345 1 2 hod_int := status; 00346 1 1 end; 00347 1 1 00348 0 0 end; 00349 C 0 0 (* Let's delete a file! *) 00350 1 0 function delete_user_file(p2:[volatile,unsafe] descriptor):integer; 00351 1 0 00352 1 0 var 00353 1 0 buffer: descriptor; (* "safe" scaler string descriptor*) 00354 1 0 filename: [volatile]string; (* buffer for scaler *) 00355 1 1 begin 00356 1 1 filename := ' '; 00357 1 1 buffer.length := p2.length; (* setup a scaler string descr *) 00358 1 1 buffer.str_ptr := address(filename); 00359 1 1 buffer.typed := DSC$K_DTYPE_P; 00360 1 1 buffer.classd := DSC$K_CLASS_S; 00361 1 1 status := str$copy_dx(des_str :=buffer,scr_str := p2); 00362 1 1 if (status <> SS$_NORMAL) then 00363 1 1 delete_user_file := status; (* run and hide *) 00364 1 1 delete_file(filename,status); 00365 1 1 delete_user_file := status; 00366 0 0 end; 00367 C 0 0 (*---------------------------- SET_DEFAULT -------------------------- 00368 C 0 0 | Set default to a directory. After setting default then change | 00369 C 0 0 | sys$disk logical so that disk is reset. | 00370 C 0 0 -------------------------------------------------------------------*) 00371 1 0 function set_default(p2:[volatile,unsafe] descriptor):integer; 00372 1 0 00373 1 0 var 00374 1 0 new_dir: descriptor; (* "safe" scaler string descriptor*) 00375 1 0 this_string, 00376 1 0 another_string: [volatile]string; 00377 1 0 device_name : [volatile]v_string; 00378 1 0 start_pos,length_addr,index_pos: [volatile]$UWORD; 00379 1 0 00380 1 1 begin 00381 1 1 this_string := ' '; 00382 1 1 another_string := ' '; 00383 1 1 new_dir.length := p2.length; (* setup a scaler string descr *) 00384 1 1 new_dir.str_ptr := address(this_string); 00385 1 1 new_dir.typed := DSC$K_DTYPE_P; TPU$CALLUSER 22-Jun-1989 13:52:51 VAX Pascal V3.9-289 Page 8 01 Source Listing 14-Jun-1989 14:09:03 CALLUSER.PAS;1 (1) -LINE-IDC-PL-SL- 00386 1 1 new_dir.classd := DSC$K_CLASS_S; 00387 1 1 status := str$copy_dx(des_str :=new_dir,scr_str := p2); 00388 1 1 if (status <> SS$_NORMAL) then 00389 1 1 set_default := status; (* bad noodles *) 00390 1 1 status := $setddir(this_string,length_addr,another_string); (* set default to directory *) 00391 1 1 if (status <> RMS$_NORMAL) then 00392 1 1 set_default := status; (* Number 5 not alive *) 00393 1 1 index_pos := index(this_string,':'); 00394 1 1 if (index_pos <> 0) then 00395 1 2 begin (* if there was a device in the filespec. *) 00396 1 2 start_pos := 1; 00397 1 2 another_string := substr(this_string,start_pos,index_pos); 00398 C 1 2 (* trim off trailing blanks *) 00399 1 2 status := trim(device_name,another_string,length_addr); 00400 1 2 if (status <> SS$_NORMAL) then 00401 1 2 set_default := status; (* bad triming *) 00402 C 1 2 (* call lib$ routine to set the logical *) 00403 1 2 status := set_logical('SYS$DISK',device_name,'LNM$PROCESS',,); 00404 1 1 end; 00405 1 1 set_default := status; (* one way or another return *) 00406 0 0 end; 00407 C 0 0 (*------------------------------------------------------------------------*) 00408 C 0 0 (*--------------------------------------------------------------------------- 00409 C 0 0 | Original code appeared on Dsin as a pascal example for calluser. $GETJPI | 00410 C 0 0 | delete_file, set_default code and whatever appears in future was added. | 00411 C 0 0 |--------------------------------------------------------------------------*) 00412 1 0 [GLOBAL] function TPU$CALLUSER (* main routine *) 00413 1 0 ( 00414 1 0 var p1: integer; 00415 1 0 p2: [VOLATILE, UNSAFE] descriptor; 00416 1 0 VAR result: descriptor 00417 1 0 ): integer; 00418 1 1 begin 00419 C 1 1 (*------------------------------------------------------------------------ 00420 C 1 1 | case statement routines: | 00421 C 1 1 | 1: get_symbol | 00422 C 1 1 | 2: $trnlnm | 00423 C 1 1 | 3: $getjpi | 00424 C 1 1 | 4: hex, oct, dec string to decimal ! NOT CURRENTLY USED | 00425 C 1 1 | 5: delete file | 00426 C 1 1 | 6: $setdef | 00427 C 1 1 ----------------------------------------------------------------------*) 00428 1 2 case p1 of 00429 1 2 1: 00430 1 2 tpu$calluser := get_symbol(symbol:= p2, value := result); 00431 1 2 2: 00432 1 3 begin 00433 C 1 3 { Set up itemlist for $trnlnm } 00434 1 3 trnlnmlst[1].buffer_length := 255; 00435 1 3 trnlnmlst[1].item_code := lnm$_string; 00436 1 3 NEW(trnlnmlst[1].str_buffer_length); 00437 1 3 NEW(trnlnmlst[1].str_buffer_address); 00438 C 1 3 { Last longword of the itemlist must be 0.} 00439 1 3 trnlnmlst[2].buffer_length := 0; 00440 1 3 trnlnmlst[2].item_code := 0; TPU$CALLUSER 22-Jun-1989 13:52:51 VAX Pascal V3.9-289 Page 9 01 Source Listing 14-Jun-1989 14:09:03 CALLUSER.PAS;1 (1) -LINE-IDC-PL-SL- 00441 1 3 00442 C 1 3 { Translate logical. It is case sensitive and there must be 00443 C 1 3 no trailing blanks in the logical name or table name.} 00444 1 3 00445 1 3 status := trnlnm 00446 1 3 ( 00447 1 3 tabnam := 'LNM$FILE_DEV', 00448 1 3 lognam := p2, 00449 1 3 itmlst := trnlnmlst 00450 1 3 ); 00451 1 3 IF odd(status) THEN 00452 1 3 tpu$calluser := $copy_r( 00453 1 3 result,trnlnmlst[1].str_buffer_length^, 00454 1 3 trnlnmlst[1].str_buffer_address^) 00455 1 3 ELSE tpu$calluser := status; 00456 1 3 dispose(trnlnmlst[1].str_buffer_length); 00457 1 3 dispose(trnlnmlst[1].str_buffer_address); 00458 1 2 end; { 2 } 00459 1 3 3: begin 00460 1 3 tpu$calluser := jpicall(p2,result); 00461 1 2 end; 00462 1 3 4: begin 00463 1 3 tpu$calluser := hod_int(p1,p2,result); 00464 1 2 end; 00465 1 3 5: begin 00466 1 3 tpu$calluser := delete_user_file(p2); 00467 1 2 end; 00468 1 3 6: begin 00469 1 3 tpu$calluser := set_default(p2); 00470 1 2 end; 00471 1 2 otherwise tpu$calluser := 0; 00472 1 1 end; { case } 00473 0 0 end; { proc tpu$calluser } 00474 0 0 end. 00475 0 0 00476 0 0 TPU$CALLUSER 22-Jun-1989 13:52:51 VAX Pascal V3.9-289 Page 10 01 Pascal Compilation Statistics 14-Jun-1989 14:09:03 CALLUSER.PAS;1 (1) PSECT SUMMARY Name Bytes Attributes $CODE 3526 NOVEC,NOWRT, RD, EXE, SHR, LCL, REL, CON, PIC,ALIGN(2) $LOCAL 52 NOVEC, WRT, RD,NOEXE,NOSHR, LCL, REL, CON, PIC,ALIGN(2) ENVIRONMENT STATISTICS -------- Symbols -------- File Total Loaded Percent SYS$COMMON:[SYSLIB]STARLET.PEN;3 24017 60 0 COMMAND QUALIFIERS PAS CALLUSER/NOOPT/LIS/CHECK/DEB/NOSTANDARD /CHECK=(BOUNDS,CASE_SELECTORS,OVERFLOW,POINTERS,SUBRANGE) /DEBUG=(SYMBOLS,TRACEBACK) /SHOW=(DICTIONARY,INCLUDE,NOINLINE,HEADER,SOURCE,STATISTICS,TABLE_OF_CONTENTS) /NOOPTIMIZE /STANDARD=NONE /TERMINAL=(NOFILE_NAME,NOROUTINE_NAME,NOSTATISTICS) /USAGE=(NOUNUSED,UNINITIALIZED,NOUNCERTAIN) /NOANALYSIS_DATA /NOENVIRONMENT /LIST=RTP$USER26:[VAXEVE.EVEPLUS.REFERENCE_COPIES]CALLUSER.LIS;1 /OBJECT=RTP$USER26:[VAXEVE.EVEPLUS.REFERENCE_COPIES]CALLUSER.OBJ;2 /NOCROSS_REFERENCE /ERROR_LIMIT=30 /NOG_FLOATING /NOMACHINE_CODE /NOOLD_VERSION /WARNINGS COMPILER INTERNAL TIMING Phase Faults CPU Time Elapsed Time Initialization 147 00:00.2 00:01.0 Source Analysis 964 00:01.4 00:05.1 Source Listing 14 00:00.2 00:00.7 Tree Construction 127 00:00.1 00:00.1 Flow Analysis 0 00:00.0 00:00.0 Value Propagation 0 00:00.0 00:00.0 Profit Analysis 0 00:00.0 00:00.0 Context Analysis 279 00:00.7 00:00.8 Name Packing 7 00:00.0 00:00.1 Code Selection 128 00:00.2 00:00.2 Final 108 00:00.3 00:00.5 TOTAL 1781 00:03.1 00:08.5 COMPILATION STATISTICS CPU Time: 00:03.1 (9243 Lines/Minute) Elapsed Time: 00:08.5 Page Faults: 1781 Pages Used: 2091 TPU$CALLUSER 22-Jun-1989 13:52:51 VAX Pascal V3.9-289 Page 11 01 Pascal Compilation Statistics 14-Jun-1989 14:09:03 CALLUSER.PAS;1 (1) Compilation Complete