disk_queue.pl1 08/08/88 1129.7r w 08/08/88 1115.1 133479 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * * Copyright, (C) Honeywell Information Systems Inc., 1987 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-11-10,Fawcett), approve(86-11-10,MCR7125), audit(87-01-08,Farley), install(87-01-09,MR12.0-1266): Changed / Rewritten by Tom Oke. Modified by RAF to use copy_erf_seg_ instead of copy_out_. copy_out_ was never installed in the system libraries. This version calls get_vol_list_ for device and pv names. 2) change(88-02-22,Parisek), approve(88-02-22,MCR7753), audit(88-02-23,Fawcett), install(88-03-01,MR12.2-1031): Remove the "-interpret" and "-no_interpret" control arguments and remove all references to interpret_sw which is set by these control arguments. END HISTORY COMMENTS */ disk_queue: dq: proc () options (variable); /* coded 12/17/70 by Noel I. Morris revised 4/16/71 by Noel I. Morris revised 7/25/72 by Lee J. Scheffler to handle new DSU_170 DIM and DSU-181 version I DIM Re-coded 04/02/80 W. Olin Sibert, to add FDUMP support, pathname interpretation, many features. Modified for new adaptive disk dim modifications and to remove paging device support, T. Oke 84-09-24. 84-12-10 by T. Oke, modified to use get_vol_list_ for volume names and release database segments on erf or -rl. */ dcl areas area based; dcl (argno, nargs) fixed bin; dcl ap ptr; dcl al fixed bin (21); dcl arg char (al) based (ap); dcl code fixed bin (35); dcl cmpp ptr; dcl subsystem_name char (4) aligned; dcl subsystem_found bit (1) aligned; dcl erf_name char (32); dcl erf_sw bit (1); dcl seg_len fixed bin (19) uns; dcl (long_sw, all_sw, live_sw) bit (1) aligned; dcl (sector_sw, record_sw, read_sw, write_sw) bit (1) aligned; dcl entry_count fixed bin; dcl idx fixed bin; dcl com_err_ entry options (variable); dcl copy_erf_seg_$name entry (char (*), char (*), ptr, uns fixed bin (19), fixed bin (35)); dcl cu_$arg_count entry (fixed bin); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl date_time_ entry (fixed bin (71), char (*)); dcl get_vol_list_ entry (ptr, ptr, ptr, char (8), fixed bin (35)); dcl ioa_ entry options (variable); dcl (get_temp_segment_, release_temp_segment_) entry (char (*), ptr, fixed bin (35)); dcl request_id_ entry (fixed bin (71)) returns (char (19)); dcl (error_table_$badopt, error_table_$bad_conversion, error_table_$inconsistent, error_table_$noarg) fixed bin (35) external static; dcl WHOAMI char (32) internal static options (constant) init ("disk_queue"); dcl cleanup condition; dcl (addr, binary, hbound, lbound, null, ptr, substr) builtin; /* */ disksp, cmpp, sstp, pv_list_ptr, lv_list_ptr = null (); all_sw, live_sw, long_sw = "0"b; sector_sw, record_sw, read_sw, write_sw = "0"b; entry_count = -1; erf_name = "-1"; erf_sw = "0"b; subsystem_name = ""; code = 0; on cleanup call clean_up_segs; call cu_$arg_count (nargs); do argno = 1 to nargs; call cu_$arg_ptr (argno, ap, al, (0)); if substr (arg, 1, 1) ^= "-" then do; /* the subsystem name */ if subsystem_name ^= "" then do; call com_err_ (0, WHOAMI, "Only one subsystem name may be supplied. ^a", arg); goto MAIN_RETURN; end; subsystem_name = arg; end; else if arg = "-all" | arg = "-a" then all_sw = "1"b; else if arg = "-live" then live_sw = "1"b; else if arg = "-brief" | arg = "-bf" then long_sw = "0"b; else if arg = "-long" | arg = "-lg" then long_sw = "1"b; else if arg = "-page" | arg = "-pg" | arg = "-record" | arg = "-rec" then record_sw = "1"b; else if arg = "-vtoc" | arg = "-sector" | arg = "-sec" then sector_sw = "1"b; else if arg = "-read" then read_sw = "1"b; else if arg = "-write" then write_sw = "1"b; else if arg = "-erf" then do; /* pick up ERF number */ if argno = nargs then do; ARG_MISSING: call com_err_ (error_table_$noarg, WHOAMI, "After ^a", arg); goto MAIN_RETURN; end; argno = argno + 1; call cu_$arg_ptr (argno, ap, al, (0)); if erf_sw then do; call com_err_ (0, WHOAMI, "Only one FDUMP name may be supplied. ^a", arg); goto MAIN_RETURN; end; erf_name = arg; erf_sw = "1"b; end; else if arg = "-last" | arg = "-lt" then do; /* last N finished queue entries */ if argno = nargs then goto ARG_MISSING; argno = argno + 1; call cu_$arg_ptr (argno, ap, al, (0)); entry_count = cv_dec_check_ (arg, code); if code ^= 0 then do; code = error_table_$bad_conversion; BAD_ENTRY_COUNT: call com_err_ (code, WHOAMI, "-last must be followed by a positive, nonzero number, not ^a.", arg); goto MAIN_RETURN; end; end; /* of processing for -last */ else do; call com_err_ (error_table_$badopt, WHOAMI, "^a", arg); goto MAIN_RETURN; end; end; /* argument loop */ if all_sw & (entry_count > 0) then do; call com_err_ (error_table_$inconsistent, WHOAMI, "-all and -last"); goto MAIN_RETURN; end; if all_sw & live_sw then do; call com_err_ (error_table_$inconsistent, WHOAMI, "-all and -live"); goto MAIN_RETURN; end; if (entry_count <= 0) & (^all_sw) & (^live_sw) then /* apply defaults */ live_sw = "1"b; if all_sw then /* translate into both */ live_sw = "1"b; /* and all the new ones besides */ if (sector_sw = "0"b) & (record_sw = "0"b) then sector_sw, record_sw = "1"b; if (read_sw = "0"b) & (write_sw = "0"b) then read_sw, write_sw = "1"b; /* */ call init_segs; if code ^= 0 then do; call com_err_ (code, WHOAMI); goto MAIN_RETURN; end; call copy_erf_seg_$name (erf_name, "disk_seg", disksp, seg_len, code); if code ^= 0 then do; call com_err_ (code, WHOAMI, "disk_seg"); goto MAIN_RETURN; end; call get_vol_list_ (pv_list_ptr, lv_list_ptr, null (), get_vol_list_version, code); if code ^= 0 then do; call com_err_ (code, WHOAMI, "Cannot get volume data."); goto MAIN_RETURN; end; %page; if all_sw then entry_count = disk_data.free_q_size; subsystem_found = "0"b; do idx = 1 to disk_data.subsystems; /* Loop through all subsystems */ diskp = ptr (disksp, disk_data.array (idx).offset); /* get pointer to disktab for this subsystem */ if (subsystem_name = "") | (subsystem_name = disk_data.array (idx).name) then do; /* print it */ call process_subsystem (disk_data.array (idx).name); /* if no name specified, process them all */ subsystem_found = "1"b; /* remember, so not to print error message */ end; end; /* of loop through subsystems */ call process_free_queue; if ^subsystem_found then call com_err_ (0, WHOAMI, "Subsystem ^a not found^[ in ERF ^a^].", subsystem_name, erf_sw, erf_name); MAIN_RETURN: call clean_up_segs; /* turf the space */ return; /* all done */ init_segs: proc; if disksp = null () then call get_temp_segment_ (WHOAMI, disksp, code); if code ^= 0 then return; if sstp = null () then call get_temp_segment_ (WHOAMI, sstp, code); if code ^= 0 then return; if cmpp = null () then call get_temp_segment_ (WHOAMI, cmpp, code); if code ^= 0 then return; end init_segs; clean_up_segs: proc; if disksp ^= null () then call release_temp_segment_ (WHOAMI, disksp, code); if sstp ^= null () then call release_temp_segment_ (WHOAMI, sstp, code); if cmpp ^= null () then call release_temp_segment_ (WHOAMI, cmpp, code); if pv_list_ptr ^= null () then free pv_list in (pv_list.area_ptr -> areas); if lv_list_ptr ^= null () then free lv_list in (lv_list.area_ptr -> areas); disksp, sstp, cmpp, lv_list_ptr, pv_list_ptr = null (); return; end clean_up_segs; /* */ process_subsystem: proc (p_subsystem_name) options (non_quick); /* This procedure processes a single subsystems worth of data. It expects diskp to point to the disktab for the subsystem. */ dcl p_subsystem_name char (*) parameter; dcl P_subsystem_name char (32); dcl last_time fixed bin (71); dcl first_sw bit (1) aligned; dcl dev fixed bin (17); dcl qrp bit (18) aligned; dcl qrp_count fixed bin; dcl matching_entries fixed bin; P_subsystem_name = p_subsystem_name; first_sw = "1"b; /* first time around, print header -- do this only once, */ matching_entries = 0; /* for both live and dead queue entries */ if live_sw then do; /* print info about pending requests */ last_time = 0; /* appear to cross a minute boundary on first time thru */ do dev = lbound (disktab.devtab, 1) to hbound (disktab.devtab, 1); dp = addr (disktab.devtab (dev)); qrp = devtab.wq.head; /* Get rel ptr to head of queue. */ do while (qrp ^= ""b); /* Search through the queue. */ qp = ptr (disksp, qrp); /* and print all the live ones */ call print_queue_entry (); /* print this one */ if quentry.used ^= "1"b then do; /* prospect for anomalies */ call ioa_ ("^4xLast queue entry at ^o is threaded, but not marked in-use.", qrp); qrp = "0"b; /* kill chain */ end; else qrp = quentry.next; /* Get index of next queue entry. */ end; end; if first_sw then /* if nothing was outstanding, say so */ call ioa_ ("^/^a: Live queue empty.", P_subsystem_name); end; /* of printing live queue entries & stuff */ if matching_entries = 0 then call ioa_ ("^a: No^[^s^s^;^[ read^]^[ write^]^] requests^[^s^s^; for^[ VTOC^]^[ page^] I/O^].", P_subsystem_name, (read_sw & write_sw), read_sw, write_sw, (record_sw & sector_sw), sector_sw, record_sw); return; %page; process_free_queue: entry; P_subsystem_name = "Free"; if entry_count > 0 then do; /* print most recent queue entries, too */ qrp = disk_data.free_q.tail; qrp_count = 0; last_time = 0; first_sw = "1"b; matching_entries = 0; do while (qrp ^= ""b); /* walk back through the queue, to reverse its order */ qrp_count = qrp_count + 1; if qrp_count > disk_data.free_q_size then do; /* can't happen */ call ioa_ ("Anomalous threading indicates more than ^d. entries in free queue.", disk_data.free_q_size); qrp = ""b; /* make sure we don't go through again */ end; else do; qp = ptr (disksp, qrp); call print_queue_entry (); if quentry.used ^= "0"b then /* prospect for anomalies */ call ioa_ ("^4xLast queue entry at ^o is free, but marked in-use.", qrp); if matching_entries = entry_count then qrp = ""b; /* check if enough printed */ else qrp = ptr (disksp, qrp) -> quentry.prev; end; /* of printing dead queue entries */ end; if matching_entries = 0 then call ioa_ ("Free: No^[^s^s^;^[ read^]^[ write^]^] requests^[^s^s^; for^[ VTOC^]^[ page^] I/O^].", (read_sw & write_sw), read_sw, write_sw, (record_sw & sector_sw), sector_sw, record_sw); end; return; /* */ print_queue_entry: proc (); /* This procedure (internal to process_subsystem) prints out a single queue entry. It prints the header, as well, the first time it is called. It expects to be called with qp pointing to the desired entry. */ dcl cyladd fixed bin (11); dcl devadd fixed bin (20); dcl coreadd fixed bin (24); dcl queued_time fixed bin (71); dcl (time_str_1, time_str_2) char (24); /* If we are not a read, and we want reads, or are not a write, and we want write, then skip the entry. Similarily for sector and record IO. */ if ^((read_sw & ^write_map (quentry.type)) | (write_sw & write_map (quentry.type))) then return; /* not desired */ if ^((sector_sw & sector_map (quentry.type)) | (record_sw & ^sector_map (quentry.type))) then return; /* not desired */ cyladd = binary (quentry.cylinder, 11); /* extract some addresses from the queue entry */ devadd = binary (quentry.sector, 20); coreadd = binary (quentry.coreadd, 24); queued_time = binary (quentry.time, 71); if first_sw then do; if long_sw then call ioa_ ("^/^4a:^2xTime^5xIO Type^5xDev PV^vx ^3xCyl^3xSector^2xMem Addr^2x(Flags)^/", P_subsystem_name, pv_list.pv_name_max_length - 4); else call ioa_ ("^a:^/^2xIO Type^6xDV ^3xSector^7xMem^3x(Flags)^/", P_subsystem_name); /* Print header. */ first_sw = "0"b; end; matching_entries = matching_entries + 1; if long_sw then do; /* include the time, among other things */ time_str_1 = request_id_ (last_time); /* see if we cross a minute boundary here */ time_str_2 = request_id_ (queued_time); if substr (time_str_1, 1, 10) ^= substr (time_str_2, 1, 10) then do; /* if MM/DD/YY HH:MM not same */ call date_time_ (queued_time, time_str_1); call ioa_ ("Queued at ^8a ^2a:^2a:^8a --", /* print substrings from date_time */ substr (time_str_1, 1, 8), substr (time_str_1, 11, 2), substr (time_str_1, 13, 2), substr (time_str_2, 11, 9)); end; /* of special processing for crossing a minute boundary */ call ioa_ ("^2x^9a^2x^10a^1x^8a ^va^2x^4o^2x^7o^2x^8o^[ intrpt^]^[ used^]", substr (time_str_2, 11, 9), /* SS.mmmmmm -- time queued */ io_name (quentry.type), pv_list.pv_info (quentry.pvtx).drive_name, pv_list.pv_name_max_length, pv_list.pv_info (quentry.pvtx).pvname, cyladd, devadd, coreadd, quentry.intrpt, quentry.used); last_time = queued_time; /* remember for next time through */ end; else do; /* otherwise, just print brief stuff */ call ioa_ ("^10a^1x^8a ^7o ^8o^[ intrpt^]^[ used^]", io_name (quentry.type), pv_list.pv_info (quentry.pvtx).drive_name, devadd, coreadd, quentry.intrpt, quentry.used); end; return; end print_queue_entry; /* internal procedure print_queue_entry */ end process_subsystem; /* internal procedure process_subsystem */ %page; %include dskdcl; %include disk_tune; %include get_vol_list_; %page; %include cmp; %page; %include sst; end; /* external procedure Disk_queue */  display_aste.pl1 07/18/86 1504.5r w 07/18/86 1234.9 192312 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style2,indcomtxt,idind25 */ display_aste: procedure; /* NSS VERSION, with get_temp_segments_, detailed AST printout, disk_table, phcs_, -at, address interpretation, BSG 05-06/76 */ /* Modified August 1982, E. N. Kittlitz. move the core_map out of sst. */ /* Modified 84-01-21 BIM for rename, new features */ /* Modified January 1985 by Keith Loepere to display multi_class. */ /* Modified 1985-03-29, BIM: silly bug in CME flag display. */ dcl arg char (argl) based (argp); dcl argl fixed bin (21); dcl argp ptr; dcl argx fixed bin; dcl n_args fixed bin; dcl (user_seg_count, first_user_seg) fixed bin; declare ptp pointer; declare ptwp pointer; declare pt (0:255) bit (36) aligned based; declare last_pte bit (36) aligned; declare skipping bit (1) aligned; declare time_string char (32); declare octal bit (1) aligned; dcl (i, aste_offset, segno) fixed bin; dcl pvname char (32); dcl diskname char (8); dcl code fixed bin (35); dcl fdevadd fixed bin (18); dcl cdevadd char (16); dcl ptwaddr fixed bin (18); dcl ll fixed bin; dcl 1 sdw1 like sdw aligned; dcl wpl fixed bin; dcl ptwbase fixed bin (24); dcl iox_$user_output ptr ext static; dcl check_gate_access_ entry (character (*), pointer, fixed binary (35)); dcl dump_segment_ entry (pointer, pointer, fixed binary, fixed binary (18), fixed binary (18), bit (*)); dcl expand_pathname_ entry (character (*), character (*), character (*), fixed binary (35)); dcl (dsp0, segptr, sstp0, cmp0, cmp) ptr; dcl sptp ptr; dcl cmap_length fixed bin (19); dcl pathname char (168); dcl dirname char (168); dcl myname char (20) static init ("display_aste") options (constant); dcl ename char (32); dcl pts fixed bin (3); dcl ptsizes (0:3) fixed bin init ((4) 0); dcl q (3) ptr init ((3) null ()); dcl core_add fixed bin (18); dcl devadd bit (22); dcl devadd_add_type bit (4) defined (devadd) pos (19); dcl devadd_nulled_flag bit (1) defined (devadd); dcl devadd_record_no bit (18) defined (devadd); dcl last_ptw bit (36); dcl file_map_sw bit (1) aligned; dcl (force_slt, force_offset) bit (1) aligned; dcl rastap fixed bin; dcl sys_info$page_size fixed bin (35) external static; dcl ( com_err_, com_err_$suppress_name, ioa_, ioa_$nnl, ioa_$rsnnl ) ext entry options (variable); dcl mdc_$read_disk_table entry (ptr, fixed bin (35)); dcl (get_temp_segments_, release_temp_segments_) entry (char (*), (*) ptr, fixed bin (35)); dcl pathname_ entry (char (*), char (*)) returns (char (168)); dcl get_line_length_$switch entry (ptr, fixed bin (35)) returns (fixed bin); dcl hcs_$high_low_seg_count entry (fixed bin, fixed bin); dcl hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35)); dcl ( hcs_$initiate, phcs_$initiate ) entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl ring_zero_peek_ entry (ptr, ptr, fixed bin (19), fixed bin (35)); dcl ring_zero_peek_$get_max_length_ptr entry (ptr, fixed bin (19), fixed bin (35)); dcl ring0_get_$segptr ext entry (char (*), char (*), ptr, fixed bin (35)); dcl ring0_get_$name entry (char (*), char (*), ptr, fixed bin (35)); dcl cu_$arg_count entry (fixed bin, fixed bin (35)); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl cv_oct_check_ ext entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl cv_oct_ entry (char (*)) returns (fixed bin (35)); dcl date_time_$format entry (character (*), fixed binary (71), character (*), character (*)) returns (character (250) var); dcl error_table_$invalidsegno fixed bin (35) ext static; dcl error_table_$too_many_args fixed bin (35) ext static; dcl error_table_$noarg fixed bin (35) ext static; dcl error_table_$bad_conversion fixed bin (35) ext static; dcl error_table_$badopt fixed bin (35) ext static; dcl (addr, addrel, baseno, baseptr, fixed, length, ptr, rel, size, addwordno, bin, byte, copy, index, rtrim, search, string, substr, unspec, verify) builtin; dcl (cleanup, linkage_error) condition; octal = "0"b; q = null (); on cleanup call release_temp_segments_ (myname, q, (0)); call cu_$arg_count (n_args, code); if code ^= 0 then do; call com_err_ (code, myname); return; end; if n_args = 0 then USAGE: do; call com_err_$suppress_name (0, myname, "Usage: display_aste {pathname | -hardcore R0 segment name/number | -at sst_seg offset"); return; end; pathname = ""; file_map_sw = "0"b; force_slt = "0"b; force_offset = "0"b; aste_offset = 0; do argx = 1 to n_args; call cu_$arg_ptr (argx, argp, argl, (0)); if index (arg, "-") ^= 1 then do; /* positional path */ if pathname ^= "" /* true even for -off */ then TOO_MANY: do; call com_err_ (error_table_$too_many_args, myname, "Only one segment specifier is permitted. ^a is the second.", arg); return; end; pathname = arg; end; else if arg = "-octal" | arg = "-oc" then octal = "1"b; else if arg = "-no_octal" | arg = "-noc" then octal = "0"b; else if arg = "-hardcore" | arg = "-hc" then do; if pathname ^= "" then go to TOO_MANY; if argx = n_args then call MISSING ("hardcore segment name/number following -hardcore"); force_slt = "1"b; argx = argx + 1; call cu_$arg_ptr (argx, argp, argl, (0)); pathname = arg; end; else if arg = "-at" | arg = "-offset" | arg = "-off" then do; if pathname ^= "" then go to TOO_MANY; if argx = n_args then call MISSING ("offset following -at."); argx = argx + 1; call cu_$arg_ptr (argx, argp, argl, (0)); force_offset = "1"b; pathname = "at offset " || arg; aste_offset = cv_oct_check_ (arg, code); if code ^= 0 then do; call com_err_ (error_table_$bad_conversion, myname, "^a is not an octal offset.", arg); return; end; end; else if arg = "-file_map" | arg = "-fm" then file_map_sw = "1"b; else if arg = "-no_file_map" | arg = "-nfm" then file_map_sw = "0"b; else do; call com_err_ (error_table_$badopt, myname, "^a", arg); return; end; end; /* the loop */ if pathname = "" then go to USAGE; /* not likely ... */ if ^force_offset & ^force_slt then do; call expand_pathname_ (pathname, dirname, ename, code); if code ^= 0 then do; call com_err_ (code, myname, "^a", pathname); return; end; end; /**** We have checked as best we can before fetching from ring 0 */ go to PARSED; RETURN: return; MISSING: procedure (w); declare w char (*); call com_err_ (error_table_$noarg, myname, "^a", w); go to RETURN; end; PARSED: /**** Fish things out of ring 0 */ call get_temp_segments_ (myname, q, code); if code ^= 0 then do; call com_err_ (code, myname, "Getting temp segs"); return; end; sstp = q (1); dtp = q (2); cmp = q (3); call mdc_$read_disk_table (dtp, code); if code ^= 0 then do; dtp = null (); call com_err_ (code, myname, "Reading disk table. "); end; call ring0_get_$segptr ("", "sst", sstp0, code); /* get pointer to sst */ call ring0_get_$segptr ("", "dseg", dsp0, code); /* and pointer to dseg */ call ring_zero_peek_ (sstp0, sstp, size (sst), code); /* get header of sst */ if code ^= 0 then do; call com_err_ (code, myname, "Getting header of SST"); call rts; return; end; ptwbase = fixed (sst.ptwbase, 24); do i = 0 to 3; ptsizes (i) = sst.pts (i); end; rastap = fixed (rel (sst.astap), 18); /* get offset to start of ASTE's */ astep = addrel (sstp, rastap); /* space for ASTE copy at end of SST copy */ sptp = addrel (astep, size (aste)); /* including the page table */ cmp0 = sst.cmp; /* core map */ call ring_zero_peek_$get_max_length_ptr (cmp0, cmap_length, code); cmap_length = cmap_length - fixed (rel (cmp0), 18); /* ignore -1's at front of core_map */ if code ^= 0 then do; call com_err_ (code, myname, "Getting length of core-map"); call rts; return; end; /* ASCERTAIN THE SEGMENT'S IDENTITY AND AST OFFSET */ if ^force_slt & ^force_offset then do; /* try to initiate as pathname */ call hcs_$initiate (dirname, ename, "", 0, 0, segptr, code); if segptr = null then do; /* segment can't be made known */ call check_gate_access_ ("phcs_", codeptr (display_aste), code); if code ^= 0 then go to no_phcs; call phcs_$initiate (dirname, ename, "", 0, 0, segptr, code); end; no_phcs: if segptr = null () then do; if search (pathname, "><") > 0 then do; /* cannot possibly be SLT name */ call com_err_ (code, myname, "^a.", pathname_ (dirname, ename)); call rts; return; end; force_slt = "1"b; /* assume hardcore */ end; end; if force_slt then do; /* segptr must be null */ if verify (rtrim (pathname), "01234567") = 0 /* octal it is */ then do; segno = cv_oct_ (pathname); segptr = baseptr (segno); call hcs_$high_low_seg_count (user_seg_count, first_user_seg); if segno < first_user_seg then do; call ring0_get_$name (dirname, ename, segptr, code); if code ^= 0 then do; call com_err_ (code, myname, "Segment ^o not found in hardcore address space.", segno); call rts; return; end; if dirname ^= "" then pathname = pathname_ (dirname, ename); else pathname = ename; end; else if segno < first_user_seg + user_seg_count then do; dirname, ename = ""; call hcs_$fs_get_path_name (segptr, dirname, (0), ename, code); if code ^= 0 then do; /* cannot possibly have an SDW */ call com_err_ (code, myname, "segment number ^o.", segno); call rts; return; end; pathname = pathname_ (dirname, ename); end; else do; /* invalid segno */ call com_err_ (error_table_$invalidsegno, myname, "^o.", segno); call rts; return; end; end; else do; call ring0_get_$segptr ("", pathname, segptr, code); if segptr = null then do; call com_err_ (code, myname, pathname); /* Give up */ call rts; return; end; end; end; if ^force_offset then do; /* we have a segptr by now, or have punted */ segno = fixed (baseno (segptr)); /* get segment number of segment */ call ring_zero_peek_ (addr (dsp0 -> sdwa (segno)), addr (sdw1), size (sdw1), code); /* Get sdw */ if sdw1.unpaged then do; /* If segment is not paged.. */ call com_err_ (0, myname, "^a is not paged.", pathname); /* tell user */ call rts; return; end; ptwaddr = fixed (sdw1.add, 24); if ^sdw1.df then do; /* make sure segment is active */ call com_err_ (0, myname, "^a not connected.", pathname); call rts; return; end; aste_offset = ptwaddr - ptwbase - size (aste); /* get offset of ast entry */ if aste_offset < 0 then do; call com_err_ (0, myname, "^a does not have an aste.", pathname); call rts; return; end; end; /* WHEW! got here means we have the aste offset, definitely */ /* DISPLAY THE AST ENTRY */ call ring_zero_peek_ (ptr (sstp0, aste_offset), astep, 256 + size (aste), code); /* copy the AST entry */ call ring_zero_peek_ (cmp0, cmp, cmap_length, code); /* copy the whole core map */ ll = get_line_length_$switch (null (), code); if ll > 109 /* dump segment needs this much space */ then wpl = 8; else wpl = 4; if force_offset then do; /* try for a name */ if aste.hc then do; segptr = baseptr (aste.strp); call ring0_get_$name (dirname, ename, segptr, code); if code = 0 then do; if dirname = "" then pathname = ename; else pathname = pathname_ (dirname, ename); end; end; end; if substr (pathname, 1, 2) = "at" then call ioa_ ("ASTE at ^o in sst_seg", aste_offset); call ioa_ ("ASTE for ^a at ^o in sst_seg", pathname, aste_offset); /* indicate location of AST */ call ioa_ (" fp: ^6o, bp: ^6o, infl: ^6o, infp: ^6o", aste.fp, aste.bp, aste.infl, aste.infp); call ioa_ (" strp: ^6o, par_astep: ^6o, UID: ^w", aste.strp, aste.par_astep, aste.uid); call ioa_ (" msl: ^d, csl: ^d, records: ^d, np: ^d", fixed (aste.msl), fixed (aste.csl), fixed (aste.records), fixed (aste.np)); call flag$$init; call flag (aste.usedf, "usedf"); call flag (aste.init, "init"); call flag (aste.gtus, "gtus"); call flag (aste.gtms, "gtms"); call flag (aste.hc, "hc"); call flag (aste.hc_sdw, "hc_sdw"); call flag (aste.any_access_on, "any_access_on"); call flag (aste.write_access_on, "write_access_on"); call flag (aste.inhibit_cache, "inhibit_cache"); call flag (aste.explicit_deact_ok, "explicit_deact_ok"); call flag (aste.deact_error, "deact_error"); call flag (aste.hc_part, "hc_part"); call flag (aste.fm_damaged, "fm_damaged"); call flag (aste.dius, "dius"); call flag (aste.nid, "nid"); call flag (aste.ehs, "ehs"); call flag (aste.nqsw, "nqsw"); call flag (aste.volmap_seg, "volmap_seg"); call flag (aste.dirsw, "dirsw"); call flag (aste.master_dir, "master_dir"); call flag (aste.multi_class, "multi_class"); call flag (aste.tqsw (0), "tqsw(S)"); call flag (aste.tqsw (1), "tqsw(D)"); call flag (aste.npfs, "npfs"); call flag (aste.dnzp, "dnzp"); call flag (aste.ddnp, "ddnp"); call flag (aste.synchronized, "synchronized"); call flag (aste.fmchanged, "fmchanged"); call flag (aste.fmchanged1, "fmchanged1"); call flag (aste.fms, "fms"); call flag (aste.damaged, "damaged"); call flag (aste.pack_ovfl, "pack_ovfl"); call fs_date_time (aste.dtu, time_string); if aste.dtu ^= ""b then call ioa_ (" DTU: ^a", time_string); call fs_date_time (aste.dtm, time_string); if aste.dtm ^= ""b then call ioa_ (" DTM: ^a", time_string); call flag$$display; if aste.dirsw /* Quota */ then call ioa_ (" quota: (^d, ^d), used: (^d, ^d)", aste.quota (0), aste.quota (1), aste.used (0), aste.used (1)); else call ioa_ (" usage count: ^d", seg_aste.usage); if dtp ^= null () then if aste.pvtx > 0 & aste.pvtx <= dt.n_entries then do; diskname = dt.array (aste.pvtx).drive_name; pvname = dt.array (aste.pvtx).pvname; call ioa_ (" vtocx ^o on pvtx ^d (""^a""), disk ^a", aste.vtocx, aste.pvtx, pvname, diskname); end; else go to NO_NAME; else NO_NAME: call ioa_ (" vtocx ^o on pvtx ^d", aste.vtocx, aste.pvtx); pts = ptsizes (fixed (astep -> aste.ptsi, 3)); /* get page table size */ if file_map_sw then call file_map; if octal then call octal_dump; call rts; return; /* DISPLAY THE PAGE TABLE */ file_map: procedure; call ioa_$nnl ("^/File map:^/"); skipping = "0"b; last_pte = ""b; ptp = addwordno (astep, size (aste)); do i = 0 to pts - 1; if ptp -> pt (i) = last_pte & i < (pts - 1) then skipping = "1"b; else if skipping then do; skipping = "0"b; call ioa_ ("======"); end; if ^skipping | i = pts - 1 then do; ptwp = addr (ptp -> pt (i)); call ioa_$nnl ("^3d ", i); call display_ptw (ptwp); last_pte = ptp -> pt (i); end; end; return; end file_map; octal_dump: procedure; call ioa_ ("^/Octal dump:^/"); call ioa_ ("ASTE:"); call dump_segment_ (iox_$user_output, addr (aste), -1, 0, size (aste), "01000"b); call ioa_ ("^/File map:"); call dump_segment_ (iox_$user_output, addwordno (astep, size (aste)), -1, 0, (pts), "01000"b); return; end octal_dump; rts: proc; call release_temp_segments_ (myname, q, (0)); end rts; fs_date_time: procedure (dt, cdt); declare dt bit (36); declare cdt char (*); declare 1 clock_ aligned like clock_value; declare time fixed bin (71); declare code fixed bin (35); declare sub_error_ condition; clock_ = ""b; clock_.fs_time = dt; unspec (time) = string (clock_); if time = 0 then ZERO: do; cdt = "ZERO"; return; end; on sub_error_ go to ZERO; cdt = date_time_$format ("iso_long_date_time", time, "", ""); return; end fs_date_time; display_ptw: procedure (p); declare p ptr; declare 1 ptw aligned like l68_ptw based (p); declare 1 core_ptw aligned like l68_core_ptw based (p); if ptw.add_type & add_type.core ^= ""b then do; call ioa_ ("^a ^[^^^]er,^[^^^]phu,^[^^^]phu1,^[^^^]phm,^[^^^]phm1,^[^^^]wired,^[^^^]os,^[^^^]valid", display_devadd (substr (unspec (ptw), 1, 22)), ^core_ptw.er, ^core_ptw.phu, ^core_ptw.phu1, ^core_ptw.phm, ^core_ptw.phm1, ^core_ptw.wired, ^core_ptw.os, ^core_ptw.valid); cmep = ptr (cmp, core_ptw.frame * 4); call ioa_ (" Disk address: ^a", display_devadd (cme.devadd)); call ioa_ ( " CME flags: ^[^^^]synch_held,io=^[output^;input^],^[^^^]er,^[^^^]removing,^[^^^]abs_w,^[^^^]abs_usable,^/ ^[^^^]notify_requested,^[^^^]phm_hedge,pin_counter=^d" , ^cme.synch_held, cme.io, ^cme.er, ^cme.removing, ^cme.abs_w, ^cme.abs_usable, ^cme.notify_requested, ^cme.phm_hedge, cme.pin_counter); end; else call ioa_ ("^a", display_devadd (substr (unspec (ptw), 1, 22))); return; end display_ptw; display_devadd: procedure (D) returns (char (*)); declare D bit (22) unaligned; declare 1 devadd_b unaligned, 2 add bit (18), 2 type bit (4); declare 1 devadd unaligned, 2 null bit (1), 2 add fixed bin (17) unsigned, 2 type bit (4); declare null builtin; declare RS char (1000) varying; declare ptp pointer; declare nulled bit (1); RS = ""; string (devadd_b) = D; unspec (devadd) = D; ptp = addr (devadd); nulled = "0"b; if (devadd.type & add_type.non_null) ^= ""b then do; if (devadd.type & add_type.core) ^= ""b then call ioa_$rsnnl ("Memory address ^8o", RS, (0), ptp -> l68_core_ptw.frame * sys_info$page_size); else if (devadd.type & add_type.disk) ^= ""b then do; if devadd.null then do; nulled = "1"b; devadd.null = "0"b; end; call ioa_$rsnnl ("Disk page ^8o ^[(nulled)^]", RS, (0), devadd.add, nulled); end; else call ioa_$rsnnl ("Invalid type ^4b add ^o", RS, (0), devadd.type, devadd.add); end; else do; /* null address */ declare 1 null_address unaligned, 2 three_7_7_0 bit (12) unaligned, 2 key bit (6), 2 type bit (4); string (null_address) = D; /* so far, so good */ call ioa_$rsnnl ("Null address from ^a", RS, (0), pc_null_address_names (bin (null_address.key, 6))); end; return (RS); end display_devadd; declare flags (0:1) char (1000) varying; /* off, on */ declare line_used (0:1) fixed bin; /* line length used up on cur line */ declare line_length fixed bin; flag$$init: procedure; declare get_line_length_$switch entry (pointer, fixed binary (35)) returns (fixed binary); declare iox_$user_output ptr ext static; line_length = get_line_length_$switch (iox_$user_output, code); if code ^= 0 then line_length = 72; flags (0) = "OFF: "; flags (1) = "ON: "; /* these are eight characters long */ line_used (*) = 9; /* always prepend space */ return; flag: entry (flag_bit, flag_name); declare flag_bit bit (1) unaligned; declare flag_name char (*); declare flag_bin fixed bin (1); flag_bin = bin (flag_bit, 1); if line_used (flag_bin) + length (flag_name) + 1 > line_length then do; flags (flag_bin) = flags (flag_bin) || byte (10) || copy (" ", 9); /* NL */ line_used (flag_bin) = 9; end; flags (flag_bin) = flags (flag_bin) || " " || flag_name; /* assume trimmed */ line_used (flag_bin) = line_used (flag_bin) + 1 + length (flag_name); return; flag$$display: entry; call ioa_ ("^/^a^/^a^/", flags (1), flags (0)); return; end flag$$init; %page; %include sst; %include disk_table; %include "ptw.l68"; %include pc_null_address_names; %include aste; %include cmp; %include sdw; %include system_clock_value_; %include add_type; end;  display_branch.pl1 11/23/84 1301.4rew 11/23/84 1245.0 103032 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ display_branch: procedure options (variable); /* DISPLAY_BRANCH A hardcore debugging tool by Bernard Greenberg 05/21/76 */ /* Modified 10/76 by S. Barr for new hash table format */ /* Modified 1984-07-24 BIM to really, truly, not copy out the entire dir. */ /* usage: display_branch branchpathname */ /* OR display_branch segno-of-seg-whose-branch-is-to-be-displayed */ /* OR display_branch dirsegno|offset (location of branch) */ /* OR display_branch -name branchpathname if it looks like octal # or ptr */ dcl (adir, pdir) char (168); dcl (ent, pent) char (32); dcl (verify, null, addr, ptr, baseptr, baseno, fixed, size, divide, index, length, rel, reverse, substr, unspec) builtin; dcl q (1) ptr; dcl (error_table_$root, error_table_$noentry) fixed bin (35) ext; dcl ring0_get_$segptr entry (char (*), char (*), ptr, fixed bin (35)); dcl hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35)); dcl (dsn, dnl, ero, esn) fixed bin; dcl ofgotten bit (1) init ("0"b); dcl cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin); dcl vs char (80) varying; dcl (rzdp, rzdsp) ptr; dcl 1 tsdw like sdw aligned; dcl (lvname, pvname) char (32); dcl ppname char (168); dcl sname char (32); dcl epname char (168); dcl mdc_$find_volname entry (bit (36) aligned, char (*), char (*), fixed bin (35)); dcl mdc_$find_lvname entry (bit (36) aligned, char (*), fixed bin (35)); dcl date_time_ entry (fixed bin (71), char (*)); dcl (dirsegno, failct) fixed bin; dcl hash_index_ entry (ptr, fixed bin, fixed bin, fixed bin) returns (fixed bin); dcl dirlen fixed bin (17); dcl hsi fixed bin; dcl phcs_$initiate entry (char (*), char (*), char (*), fixed bin, fixed bin, ptr, fixed bin (35)); dcl phcs_$terminate_noname entry (ptr, fixed bin (35)); dcl phcs_$ring_0_peek entry (ptr, ptr, fixed bin); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl (get_temp_segments_, release_temp_segments_) entry (char (*), (*) ptr, fixed bin (35)); dcl (cleanup, out_of_bounds) condition; dcl (ioa_, com_err_) entry options (variable); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl arg char (argl) based (argp); dcl argp ptr, argl fixed bin; dcl myname char (19) init ("display_branch") static options (constant); dcl code fixed bin (35); %include sdw; %include dir_header; %include dir_ht; %include dir_entry; %include dir_link; %include dir_name; call ring0_get_$segptr ("", "dseg", rzdsp, code); if code ^= 0 then do; call com_err_ (0, myname, "Cannot get dseg ptr"); return; end; call cu_$arg_ptr (1, argp, argl, code); if code ^= 0 then do; noarg: call com_err_ (code, myname); return; end; if arg = "-name" | arg = "-nm" | arg = "-path" | arg = "-pn" then do; call cu_$arg_ptr (2, argp, argl, code); if code ^= 0 then go to noarg; go to nooct; end; esn = cv_oct_check_ (arg, code); if code = 0 then do; /* legit octal */ call hcs_$fs_get_path_name (baseptr (esn), adir, dnl, ent, code); if code ^= 0 then do; call com_err_ (code, myname, "^o", esn); return; end; if dnl = 0 then adir = ">"; /* Multix cant even act consist. */ go to got_adir_ent; end; /* try for x|y */ dnl = index (arg, "|"); if dnl = 0 then go to nooct; if dnl = 1 | dnl = length (arg) then go to nooct; ero = cv_oct_check_ (substr (arg, dnl + 1), code); if code = 0 then dsn = cv_oct_check_ (substr (arg, 1, dnl - 1), code); if code = 0 then do; /* Got a branch ptr */ rzdp = baseptr (dsn); call hcs_$fs_get_path_name (rzdp, pdir, dnl, pent, code); if code ^= 0 then do; call com_err_ (code, myname, "^o", dsn); return; end; ofgotten = "1"b; if dnl = 0 then pdir = ">"; if pdir = ">" then ppname = ">" || pent; else ppname = substr (pdir, 1, trim (pdir)) || ">" || pent; go to ext; end; nooct: call expand_pathname_ (arg, adir, ent, code); if code ^= 0 then do; call com_err_ (code, myname, arg); return; end; got_adir_ent: if adir = ">" then if ent = "" then do; call com_err_ (error_table_$root, myname); return; end; call expand_pathname_ (adir, pdir, pent, (0)); /* Cannot fail */ if pdir = ">" then ppname = ">" || pent; else ppname = substr (pdir, 1, trim (pdir)) || ">" || pent; if pent = "" then epname = ">" || ent; else epname = substr (adir, 1, trim (adir)) || ">" || ent; ext: on cleanup call release_temp_segments_ (myname, q, (0)); call get_temp_segments_ (myname, q, code); if code ^= 0 then do; call com_err_ (code, myname, "Getting temp segment."); return; end; dp = q (1); call phcs_$initiate (pdir, pent, "", 0, 0, rzdp, code); if rzdp = null then do; call com_err_ (code, myname, ppname); call release_temp_segments_ (myname, q, (0)); return; end; if ofgotten then do; ep = ptr (dp, ero); call m_a (ep, size (entry)); go to dsplay; end; dirsegno = fixed (baseno (rzdp), 18); call phcs_$ring_0_peek (rzdp, dp, 1); /* Cause fault */ failct = 0; ftsdw: call phcs_$ring_0_peek (addr (rzdsp -> sdwa (dirsegno)), addr (tsdw), 2); if tsdw.bound = "0"b then go to ftsdw; dirlen = fixed (tsdw.bound, 15) * 16 + 16; on out_of_bounds go to refetch_dir; refetch_dir: failct = failct + 1; if failct > 10 then do; call com_err_ (0, myname, "Cannot get consistent copy of ^a after 10 tries", ppname); call phcs_$terminate_noname (rzdp, (0)); call release_temp_segments_ (myname, q, (0)); return; end; call m_a (dp, size (dir)); hsi = hash_index_ (addr (ent), trim (ent), 0, (dir.htsize)); htp = ptr (dp, dp -> dir.hash_table_rp); call m_a (htp, (dir.htsize)); do np = ptr (dp, htp -> hash_table.name_rp (hsi)) repeat ptr (dp, np -> names.hash_thread) while (rel (np)); call m_a (np, size (names)); if fixed (rel (np), 18) >= dirlen then go to refetch_dir; if np -> names.ht_index ^= hsi then go to refetch_dir; if ent = np -> names.name then do; ep = ptr (dp, np -> names.entry_rp); call m_a (ep, size (entry)); go to dsplay; end; end; /* Name not found. Cleanup and return. */ call com_err_ (error_table_$noentry, myname, epname); call release_temp_segments_ (myname, q, (0)); call phcs_$terminate_noname (rzdp, (0)); return; dsplay: sname = addr (entry.primary_name) -> names.name; call ioa_ ("^/^-Branch for ^a in ^a at ^p^/", sname, ppname, ptr (rzdp, rel (ep))); if ^entry.bs then do; call m_a (ep, divide (length (unspec (link)), 36, 17, 0)); call ioa_ ("^a (uid ^w) is a link to ^a", sname, link.uid, link.pathname); end; else do; call mdc_$find_volname ((entry.pvid), pvname, lvname, code); if code ^= 0 then do; call com_err_ (code, myname, "^/ Cannot determine vol name for pvid ^w", entry.pvid); lvname, pvname = "-NOT-CLEAR-"; end; call ioa_ ("UID ^w, is vtocx ^o on ^a (of log vol. ^a)", entry.uid, entry.vtocx, pvname, lvname); if entry.dirsw then call ioa_ ("^a is a directory.", sname); if entry.master_dir then do; call mdc_$find_lvname (entry.sons_lvid, lvname, code); if code ^= 0 then do; lvname = "-NOT-CLEAR-"; call com_err_ (code, myname, "Cannot get LV name for lvid ^w", entry.sons_lvid); end; call ioa_ ("^a is a master dir for LV ^a", sname, lvname); end; vs = ""; if entry.oosw then call putsw (" oosw"); if entry.per_process_sw then call putsw (" per-process"); if entry.copysw then call putsw (" copysw"); if entry.multiple_class then call putsw (" multi-class"); if entry.safety_sw then call putsw (" safety_sw"); if entry.audit_flag then call putsw (" audit"); if entry.security_oosw then call putsw (" sec-oosw"); if entry.tpd then call putsw (" tpd"); call putsw ("OOP"); if entry.entrypt_sw then call ioa_ ("Call limiter at ^o .", fixed (entry.entrypt_bound, 14)); call ioa_ ("Ring brackets (^o ^o ^o)", fixed (entry.ring_brackets (1), 3), fixed (entry.ring_brackets (2), 3), fixed (entry.ring_brackets (3), 3)); end; if entry.dtem then call ioa_ ("Entry modified ^a", dtc (entry.dtem)); else call ioa_ ("DTEM not set."); if entry.dtd then call ioa_ ("Dumped ^a", dtc ((entry.dtd))); else call ioa_ ("Never dumped."); if entry.nnames > 1 then call ioa_ ("^d names.", entry.nnames); if entry.bs then do; call get_access_class (entry.access_class, code); if code ^= 0 then call ioa_ ("Unable to convert access class information."); end; call release_temp_segments_ (myname, q, (0)); call phcs_$terminate_noname (rzdp, (0)); return; trim: proc (ch) returns (fixed bin); dcl ch char (*); dcl x fixed bin; x = verify (reverse (ch), " "); if x ^= 0 then x = length (ch) - x + 1; return (x); end; m_a: proc (cp, sz); /* This proc is needed to avoid copying a whole directory out, which can, and did one May morning in Phoenix, withdraw a large number of pages against the RLV. Writers of similar programs beware. */ dcl (cp, rgp) ptr, sz fixed bin; rgp = ptr (rzdp, rel (cp)); call phcs_$ring_0_peek (rgp, cp, sz); end; dtc: proc (d) returns (char (24)); /* Proc to convert date_times */ dcl fbuf fixed bin (71); dcl d bit (36) aligned, cd char (24); fbuf = 0; substr (unspec (fbuf), 21) = d; call date_time_ (fbuf, cd); return (cd); end dtc; putsw: proc (swn); dcl swn char (*); if length (vs) + length (swn) > 70 | swn = "OOP" then do; if vs = "" then ; else call ioa_ ("Switches:^a", vs); vs = ""; end; vs = vs || swn; end putsw; get_access_class: proc (access_class, code); dcl access_class bit (72) aligned, (class, temp_string) char (336), (class_len, k, kk) fixed bin, first bit (1), code fixed bin (35); dcl convert_authorization_$to_string_short entry (bit (72) aligned, char (*), fixed bin (35)); code = 0; call convert_authorization_$to_string_short (access_class, class, code); if code ^= 0 then return; if class = "" then call ioa_ ("Access Class: system_low"); else do; /* format access class in lines of 50 chars */ class_len = index (class, " ") - 1; if class_len = -1 then class_len = 336; k = 1; first = "1"b; do while ((class_len - k + 1) > 50); temp_string = substr (class, k, 50); kk = length (temp_string) + 1 - index (reverse (temp_string), ","); call ioa_ ("^[Access Class:^; ^] ^a", (first), substr (class, k, kk)); first = "0"b; k = k + kk; end; call ioa_ ("^[Access Class: ^; ^]^a", (first), substr (class, k)); end; end get_access_class; end;  display_disk_label.pl1 07/20/88 1300.2rew 07/19/88 1523.2 187965 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4,initcol1,indattr,declareind8,dclind4,idind33,ifthenstmt,ifthen,^indproc,delnl,insnl */ display_disk_label: ddl: proc; /* display_disk_label (or ddl), display_pvte Commands to display the label and/or PVTE of a mounted Storage System volume. Calling sequence: {display_disk_label|display_pvte} {dskX_NN | PVNAME | PVID} {-control_args} If display_disk_label is called, the default is to display information from the volume label only. If display_pvte is called, the default is to display information from the PVTE only. Control Arguments: -pvid PVID selects the volume with Physical Volume ID PVID -long, -lg for display_disk_label, also displays information from the PVTE for display_pvte, also displays information form the label Written November 1981 by J. Bongiovanni Modified March 1982, J. Bongiovanni, for record stocks Modified August 1982, J. Bongiovannni, for usage message, print more flags, the scavenger, and ALT partition Modified August 1984, Allen Ball, to make compatiable with bce_display_disk_label by using new subroutine display_disk_label_. */ /****^ HISTORY COMMENTS: 1) change(86-01-16,Fawcett), approve(86-04-10,MCR7383), audit(86-06-30,Coppola), install(86-07-18,MR12.0-1098): Add support for subvolumes, and 512_WORD_IO, 3380 and 3390. 2) change(86-11-20,Lippard), approve(86-12-08,MCR7591), audit(87-01-21,Beattie), install(87-03-23,MR12.1-1009): Fix bug: stop losing a bit when converting pvid. 3) change(88-03-30,GWMay), approve(88-04-12,MCR7867), audit(88-06-14,Beattie), install(88-07-19,MR12.2-1061): Changed to display octal numbers with "o". 4) change(88-05-27,GWMay), approve(88-05-27,MCR7883), audit(88-06-14,Beattie), install(88-07-19,MR12.2-1061): Changed to display the status of volume dumper bit maps. END HISTORY COMMENTS */ label_call = "1"b; do_label = "1"b; do_pvte = "0"b; myname = "display_disk_label"; goto COMMON; display_pvte: entry; label_call = "0"b; do_label = "0"b; do_pvte = "1"b; myname = "display_pvte"; /* Romp through arguments, validating them */ COMMON: have_sv, have_subsys_unit, have_pvname, have_pvid = "0"b; unit, subvol_num = 0; call cu_$arg_count (nargs, code); if code ^= 0 then do; call com_err_ (code, myname); return; end; if nargs = 0 then do; USAGE: call com_err_ (error_table_$noarg, myname, " Usage: ^a {-long, -lg}", myname); return; end; do arg_no = 1 to nargs; call cu_$arg_ptr (arg_no, argp, argl, code); if code ^= 0 then do; call com_err_ (code, myname, "Argument ^d", arg_no); return; end; if substr (arg, 1, 1) ^= "-" then do; /* dskX_NN or pvname or pvid */ if arg_no ^= 1 then do; /* Which must be 1st argument */ BAD_OPT: call com_err_ (error_table_$badopt, myname, arg); return; end; if substr (arg, 1, 3) = "dsk" & (argl = 7 | argl = 8) then if substr (arg, 5, 1) = "_" then do; /* dskX_NN */ subsys_name = substr (arg, 1, 4); unit = cv_dec_check_ (substr (arg, 6, 2), code); if code ^= 0 then do; BAD_DISK: call com_err_ (0, myname, "Invalid disk unit ^a", arg); return; end; if argl = 8 then do; subvol_num = index (valid_sv_string, substr (arg, 8, 1)) - 1; if subvol_num < 0 then goto BAD_DISK; have_sv = "1"b; end; have_subsys_unit = "1"b; end; if ^have_subsys_unit then do; /* pvname or pvid */ pvid_bin = cv_oct_check_ (arg, code); if code = 0 then do; pvid = unspec (pvid_bin); have_pvid = "1"b; end; else do; pvname = arg; have_pvname = "1"b; end; end; end; else if arg = "-pvid" then do; arg_no = arg_no + 1; call cu_$arg_ptr (arg_no, argp, argl, code); if code ^= 0 then do; call com_err_ (code, myname, "PVID"); return; end; pvid_bin = cv_oct_check_ (arg, code); if code ^= 0 then do; call com_err_ (0, myname, "Invalid PVID ^a", arg); return; end; pvid = unspec (pvid_bin); have_pvid = "1"b; end; else if arg = "-long" | arg = "-lg" then do; if label_call then do_pvte = "1"b; else do_label = "1"b; end; else goto BAD_OPT; end; if ^have_pvname & ^have_subsys_unit & ^have_pvid then go to USAGE; if (have_pvname | have_subsys_unit) & have_pvid then do; call com_err_ (error_table_$inconsistent, myname, "^[^a^;^1s^]^[^a_^a^;^2s^] and -pvid", have_pvname, pvname, have_subsys_unit, subsys_name, convert (unit_pic, unit)); return; end; %page; /* Copy the PVT and stock_seg from ring-0 */ temp_segp (1) = null (); on cleanup call clean_me_out; call get_temp_segments_ (myname, temp_segp, code); if code ^= 0 then do; call com_err_ (code, myname, "Getting temp segments"); return; end; pvtp = temp_segp (1); labelp = temp_segp (2); stock_segp = temp_segp (3); call copy_ring0_seg ("pvt", pvtp, r0_pvtp); call copy_ring0_seg ("stock_seg", stock_segp, r0_stock_segp); call ring0_get_$segptr ("", "scavenger_data", r0_scav_datap, code); if code ^= 0 then do; call com_err_ (code, myname, "scavenger_data"); call clean_me_out; return; end; pvt_arrayp = addr (pvt.array); %page; /* Find pvtx and pvid (possibly pvname, too) for unit */ if have_subsys_unit then do; /* Given dskX_NN */ found_pvte = "0"b; do pvtx = 1 repeat pvtx + 1 while (^found_pvte & pvtx <= pvt.n_entries); pvtep = addr (my_pvt_array (pvtx)); if pvte.devname = subsys_name & pvte.logical_area_number = unit & pvte.used then do; found_pvte = "1"b; if have_sv & pvte.sv_num ^= subvol_num then found_pvte = "0"b; /* wrong Subvolume */ if pvte.is_sv & ^have_sv then do; /* must specify Subvolume to display */ call com_err_ (error_table_$subvol_needed, myname, "^a_^a", subsys_name, convert (unit_pic, unit)); call clean_me_out; return; end; if have_sv & ^pvte.is_sv then do; /* must NOT specify Subvolume */ call com_err_ (error_table_$subvol_invalid, myname, "^a_^a", subsys_name, convert (unit_pic, unit)); call clean_me_out; return; end; end; end; if ^found_pvte then do; call com_err_ (0, myname, "^a_^a^[^a^;^1s^] not found in PVT", subsys_name, convert (unit_pic, unit), have_sv, substr (valid_sv_string, subvol_num + 1, 1)); call clean_me_out; return; end; pvid = pvte.pvid; call pvname_to_pvtx_$pvid (pvid, pvtx, pvname, code); if code ^= 0 then do; call com_err_ (code, myname, "PVID ^wo", pvid); call clean_me_out; return; end; end; else if have_pvname then do; /* pvname given */ call pvname_to_pvtx_ (pvname, pvtx, pvid, code); if code ^= 0 then do; call com_err_ (code, myname, pvname); call clean_me_out; return; end; pvtep = addr (my_pvt_array (pvtx)); end; else do; call pvname_to_pvtx_$pvid (pvid, pvtx, pvname, code); if code ^= 0 then do; call com_err_ (code, myname, "PVID ^wo", pvid); call clean_me_out; return; end; pvtep = addr (my_pvt_array (pvtx)); end; if pvte.is_sv then do; if have_subsys_unit & ^have_sv then max_pvtx = pvtx + (pvte.num_of_svs - 1); max_pvtx = pvtx; end; else max_pvtx = pvtx; %page; do pvtx = pvtx to max_pvtx; pvtep = addr (my_pvt_array (pvtx)); if do_label then do; /* Read the disk label, printing an error message on no access */ on linkage_error goto LINKAGE_ERROR; call phcs_$read_disk_label (pvid, labelp, code); revert linkage_error; if code ^= 0 then do; call com_err_ (code, myname, pvname); call clean_me_out; return; end; /* Print the label in reasonable form */ call ioa_ ("^/Label for Multics Storage System Volume ^a on ^a_^a^[^a^;^1s^] ^a ^[(Private)^;^1s^]^/", pvname, pvte.devname, convert (unit_pic, pvte.logical_area_number), pvte.is_sv, pvte.sv_name, device_names (pvte.device_type), label.private); call display_disk_label_ (labelp); end; if do_pvte then do; call ioa_ ("^/PVTE for Multics Storage System Volume ^a on ^a_^a^[^a^;^1s^] ^a at pvt|^o^/", pvname, pvte.devname, convert (unit_pic, pvte.logical_area_number), pvte.is_sv, pvte.sv_name, device_names (pvte.device_type), rel (pvtep)); call ioa_ ("PVID^-^-^wo^/LVID^-^-^wo^/", pvte.pvid, pvte.lvid); call ioa_ ("VTOCEs^/ Number^-^-^8d (^oo)^/ Left^-^-^8d (^oo)", pvte.n_vtoce, pvte.n_vtoce, pvte.n_free_vtoce, pvte.n_free_vtoce); call ioa_ ("^/Records^/ Number^-^-^8d (^oo)^/ Left^-^-^8d (^oo)", pvte.totrec, pvte.totrec, pvte.nleft, pvte.nleft); if pvte.is_sv then call ioa_ ( "^/Subvolume Info^/ sv_num^-^-^8d^/ num_of_svs^-^8d^/ record_factor^-^8d^/ records_per_cyl^-^8d", pvte.sv_num, pvte.num_of_svs, pvte.record_factor, pvte.records_per_cyl); call ioa_ ("^/Inconsistencies^-^8d", pvte.vol_trouble_count); call ioa_ (" The volume dumper bit maps located at dbm_seg|^o and dbm_seg|^o are ^[NOT ^]consistent.", pvte.dbmrp (1), pvte.dbmrp (2), pvte.inconsistent_dbm); if unspec (pvte.volmap_astep) ^= ""b & pvte.volmap_astep ^= null () then do; call ioa_ ("^/Volume Map^/ volmap_seg ASTE^-^a", convert_ptr (pvte.volmap_astep)); if unspec (pvte.volmap_stock_ptr) ^= ""b & pvte.volmap_stock_ptr ^= null () then do; record_stockp = ptr (stock_segp, rel (pvte.volmap_stock_ptr)); if pvte.volmap_stock_ptr = ptr (r0_stock_segp, rel (record_stockp)) & record_stock.pvtep = ptr (r0_pvtp, rel (pvtep)) then do; call ioa_ (" record stock^-^a", convert_ptr (pvte.volmap_stock_ptr)); bias = 64 * 32; /* Old volume map kludge */ do volmap_pagex = 1 to record_stock.n_volmap_pages; call ioa_ (" Page ^1d - Base^-^8o^/^11xFree^-^8o", volmap_pagex - 1, record_stock.volmap_page (volmap_pagex).baseadd + bias, record_stock.volmap_page (volmap_pagex).n_free); bias = 0; end; call ioa_ (" vtoce stock^-^a", convert_ptr (pvte.vtoc_map_stock_ptr)); end; end; end; if pvte.scavenger_block_rel ^= ""b then call ioa_ ("^/Scavenge in progress^/ scavenger block^-^a", convert_ptr ((ptr (r0_scav_datap, pvte.scavenger_block_rel)))); on_string = "^/ON:^-"; off_string = "^/OFF:^-"; on_line_l = 0; off_line_l = 0; call set_on_off (pvte.used, "used"); call set_on_off (pvte.is_sv, "is_sv"); call set_on_off (pvte.storage_system, "storage_system"); call set_on_off (pvte.root_lv, "root_lv"); call set_on_off (pvte.rpv, "rpv"); call set_on_off (pvte.permanent, "permanent"); call set_on_off (pvte.testing, "testing"); call set_on_off (pvte.being_mounted, "being_mounted"); call set_on_off (pvte.being_demounted, "being_demounted"); call set_on_off (pvte.removable_pack, "removable_pack"); call set_on_off (pvte.check_read_incomplete, "check_read_incomplete"); call set_on_off (pvte.device_inoperative, "device_inoperative"); call set_on_off (pvte.scav_check_address, "scav_check_address"); call set_on_off (pvte.deposit_to_volmap, "deposit_to_volmap"); call set_on_off (pvte.being_demounted2, "being_demounted2"); call set_on_off (pvte.pc_vacating, "pc_vacating"); call set_on_off (pvte.vacating, "vacating"); call set_on_off (pvte.hc_part_used, "hc_part_used"); call set_on_off (pvte.volmap_lock_notify, "volmap_lock_notify"); call set_on_off (pvte.volmap_idle_notify, "volmap_idle_notify"); call set_on_off (pvte.vtoc_map_lock_notify, "vtoc_map_lock_notify"); call set_on_off (pvte.dmpr_in_use (incr), "dmpr_in_use(incr)"); call set_on_off (pvte.dmpr_in_use (cons), "dmpr_in_use(cons)"); call set_on_off (pvte.dmpr_in_use (comp), "dmpr_in_use(comp)"); call ioa_ (rtrim (on_string)); call ioa_ (rtrim (off_string)); call ioa_ ("^/Volume Map from PVTE"); call ioa_ (" First Record Size"); call ioa_ (MAP_IOA_STRING, LABEL_ADDR, LABEL_ADDR, VTOC_ORIGIN - LABEL_ADDR, VTOC_ORIGIN - LABEL_ADDR, "Label Region"); call ioa_ (MAP_IOA_STRING, VTOC_ORIGIN, VTOC_ORIGIN, pvte.vtoc_size - VTOC_ORIGIN, pvte.vtoc_size - VTOC_ORIGIN, "VTOC Region"); if pvte.baseadd - pvte.vtoc_size > 0 then call ioa_ (MAP_IOA_STRING, pvte.vtoc_size, pvte.vtoc_size, pvte.baseadd - pvte.vtoc_size, pvte.baseadd - pvte.vtoc_size, "Partitions"); call ioa_ (MAP_IOA_STRING, pvte.baseadd, pvte.baseadd, pvte.totrec, pvte.totrec, "Paging Region"); if last_rec_num (pvte.device_type) - (pvte.baseadd + pvte.totrec) > 0 then call ioa_ (MAP_IOA_STRING, pvte.baseadd + pvte.totrec, pvte.baseadd + pvte.totrec, last_rec_num (pvte.device_type) - (pvte.baseadd + pvte.totrec), last_rec_num (pvte.device_type) - (pvte.baseadd + pvte.totrec), "Partitions"); call ioa_ ("^22t^8d (^oo)^51tTotal Size^/", rec_per_sv (pvte.device_type), rec_per_sv (pvte.device_type)); end; end; %page; GLOBAL_RETURN: call clean_me_out; return; LINKAGE_ERROR: call com_err_ (error_table_$not_privileged, myname, "phcs_"); call clean_me_out; return; %page; /* Internal procedure for cleanup */ clean_me_out: proc; if temp_segp (1) ^= null () then call release_temp_segments_ (myname, temp_segp, code); temp_segp (1) = null (); end clean_me_out; /* Internal procedure to convert a pointer to a fixed size character string */ convert_ptr: proc (p) returns (char (8)); dcl p ptr unaligned; dcl p_char char (8); dcl p_char_ret char (8); dcl p_char_len fixed bin (21); call ioa_$rsnnl ("^p", p_char, p_char_len, p); p_char_ret = ""; substr (p_char_ret, 9 - p_char_len, p_char_len) = substr (p_char, 1, p_char_len); return (p_char_ret); end convert_ptr; /* Internal procedure to copy a named segment from ring-0 */ copy_ring0_seg: proc (name, copy_ptr, ring0_ptr); dcl name char (*); dcl copy_ptr ptr; dcl ring0_ptr ptr; dcl code fixed bin (35); dcl nwords fixed bin (19); call ring0_get_$segptr ("", name, ring0_ptr, code); if code ^= 0 then do; RING0_SEG_ERR: call com_err_ (code, myname, name); goto GLOBAL_RETURN; end; call ring_zero_peek_$get_max_length (name, nwords, code); if code ^= 0 then goto RING0_SEG_ERR; call ring_zero_peek_$by_name (name, 0, copy_ptr, nwords, code); if code ^= 0 then goto RING0_SEG_ERR; end copy_ring0_seg; /* Internal procedure to maintain ioa control strings for On and Off */ set_on_off: proc (this_bit, this_name); dcl this_bit bit (1); dcl this_name char (*); if this_bit then call set (on_string, this_name, on_line_l); else call set (off_string, this_name, off_line_l); return; set: proc (ioa_string, name, line_l); dcl ioa_string char (*); dcl name char (*); dcl line_l fixed bin; dcl name_l fixed bin; name_l = length (name); if name_l > MAX_LINE_L then return; if name_l + line_l > MAX_LINE_L then do; ioa_string = rtrim (ioa_string) || "^/^- " || name || " "; line_l = name_l + 1; end; else do; ioa_string = rtrim (ioa_string) || " " || name || " "; line_l = line_l + name_l + 1; end; end set; end set_on_off; %page; /* Automatic */ dcl arg_no fixed bin; /* Current argument number */ dcl argl fixed bin (21); /* Current argument length */ dcl argp ptr; /* Pointer to current argument */ dcl bias fixed bin; dcl code fixed bin (35); /* Standard error code */ dcl do_label bit (1); /* ON => display information from label */ dcl do_pvte bit (1); /* ON => display information from PVTE */ dcl found_pvte bit (1); /* ON => found pvte in pvt */ dcl have_pvid bit (1); /* ON => PVID given */ dcl have_pvname bit (1); /* ON => PVNAME given */ dcl have_subsys_unit bit (1); /* ON => dskX_NN given */ dcl have_sv bit (1); /* ON => dskX_NNA given to indicate subvolume */ dcl label_call bit (1); /* ON => display_disk_label called */ dcl max_pvtx fixed bin (17); /* max number of pvte's to look at for subvol */ dcl myname char (32); /* Name of command called */ dcl nargs fixed bin; /* Number of arguments */ dcl off_line_l fixed bin; /* Working line length for OFF flags */ dcl off_string char (1024); /* OFF ioa_ control string */ dcl on_line_l fixed bin; /* Working line length for ON flags */ dcl on_string char (1024); dcl pvid bit (36) aligned; /* PVID */ dcl pvid_bin fixed bin (35); /* Temp for conversion */ dcl pvtx fixed bin; /* Index into pvte array */ dcl pvname char (32); /* Physical volume name */ dcl r0_pvtp ptr; /* Pointer to PVT in ring-0 */ dcl r0_scav_datap ptr; /* Pointer to scavenger_data in ring-0 */ dcl r0_stock_segp ptr; /* Pointer to stock_seg in ring-0 */ dcl subsys_name char (4); /* Name of disk subsystem */ dcl subvol_num fixed bin (17); /* Number of subvolume user requested (0, 1 or 2) */ dcl temp_segp (N_TEMP_SEGS) ptr; /* Temporary segments used by command */ dcl unit fixed bin (35); /* Unit number given */ dcl unit_pic pic "99"; /* For printing unit number */ dcl volmap_pagex fixed bin; /* Static */ dcl MAP_IOA_STRING char (29) static options (constant) init ("^8d (^oo)^22t^8d (^oo)^51t^4a"); dcl MAX_LINE_L fixed bin int static options (constant) init (60); dcl N_TEMP_SEGS fixed bin int static options (constant) init (3); /* Number temp segments used */ /* Based */ dcl arg char (argl) based (argp); /* Current argument */ dcl 1 my_pvt_array (pvt.max_n_entries) aligned like pvte based (pvt_arrayp); /* Entry */ dcl com_err_ entry options (variable); dcl cu_$arg_count entry (fixed bin, fixed bin (35)); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl display_disk_label_ entry (ptr); dcl ioa_ entry options (variable); dcl ioa_$rsnnl entry options (variable); dcl get_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); dcl release_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); dcl ring_zero_peek_$by_name entry (char (*), fixed bin (18), ptr, fixed bin (19), fixed bin (35)); dcl ring_zero_peek_$get_max_length entry (char (*), fixed bin (19), fixed bin (35)); dcl ring0_get_$segptr entry (char (*), char (*), ptr, fixed bin (35)); dcl phcs_$read_disk_label entry (bit (36) aligned, ptr, fixed bin (35)); dcl pvname_to_pvtx_ entry (char (*), fixed bin, bit (36) aligned, fixed bin (35)); dcl pvname_to_pvtx_$pvid entry (bit (36) aligned, fixed bin, char (*), fixed bin (35)); /* External */ dcl error_table_$badopt fixed bin (35) external; dcl error_table_$inconsistent fixed bin (35) external; dcl error_table_$noarg fixed bin (35) external; dcl error_table_$not_privileged fixed bin (35) external; dcl error_table_$subvol_invalid fixed bin (35) external; dcl error_table_$subvol_needed fixed bin (35) external; /* Condition */ dcl cleanup condition; dcl linkage_error condition; /* Builtin */ dcl addr builtin; dcl convert builtin; dcl index builtin; dcl length builtin; dcl null builtin; dcl ptr builtin; dcl rel builtin; dcl rtrim builtin; dcl substr builtin; dcl unspec builtin; %page; %include backup_static_variables; %page; %include disk_pack; %page; %include fs_dev_types; %page; %include fs_vol_label; %page; %include pvt; %include pvte; %include stock_seg; end display_disk_label;  display_ioi_data.pl1 08/19/86 2037.1r w 08/19/86 2035.7 224550 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(85-09-11,Farley), approve(85-09-11,MCR6979), audit(85-11-26,CLJones), install(86-03-21,MR12.0-1033): IPC and FIPS END HISTORY COMMENTS */ /* DISPLAY_IOI_DATA - Command to dump ioi data bases */ /* Written November 1979 by Larry Johnson */ /* Modified 13 June 1983 by Chris Jones for IOI rewrite. */ /* Modified 1984-08-10 BIM for dte.direct */ /* Modified Jan 1985 by Paul Farley for IPC and FIPS flags. */ /* Modified Sept 1985 by Paul Farley for dte.controller. */ /* format: style4,delnl,insnl,indattr,ifthen,dclind10 */ display_ioi_data: procedure options (variable); /* Automatic */ dcl argl fixed bin; dcl arg_list_ptr ptr; dcl arg_no fixed bin; dcl argp ptr; dcl code fixed bin (35); dcl i fixed bin; dcl more_args bit (1); dcl n_args fixed bin; dcl dir char (168); dcl ename char (32); dcl ( source_given, /* Various flags for scanning args */ path_sw, erf_sw, block_given, gte_sw, cte_sw, dte_sw, group_sw, channel_sw, device_sw, user_sw, header_sw, no_header_sw, force_sw, all_sw, brief_sw ) bit (1) init ("0"b); dcl erf_name char (16); dcl (gte_offset, cte_offset, dte_offset) fixed bin; dcl group_name char (4); dcl device_no fixed bin; dcl device_name char (7) var; dcl channel_id char (8) aligned; dcl found bit (1); dcl (person, person_req) char (22); dcl (project, project_req) char (9); /* Based */ dcl arg char (argl) based (argp); /* Constants */ dcl name char (16) int static options (constant) init ("display_ioi_data"); /* External */ dcl analyze_device_stat_$rsnnl entry (char (*) var, ptr, bit (72), bit (18)); dcl com_err_ entry options (variable); dcl cu_$af_arg_count_rel entry (fixed bin, fixed bin (35), ptr); dcl cu_$arg_list_ptr entry (ptr); dcl cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin, fixed bin (35), ptr); dcl cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl date_time_ entry (fixed bin (71), char (*)); dcl delete_$ptr entry (ptr, bit (6), char (*), fixed bin (35)); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl extract entry options (variable); dcl get_temp_segment_ entry (char (*), pointer, fixed bin (35)); dcl get_userid_ entry (bit (36), char (*), char (*), fixed bin, fixed bin, fixed bin (35)); dcl get_wdir_ entry () returns (char (168)); dcl initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35)); dcl ( ioa_, ioa_$nnl, ioa_$rsnnl ) entry options (variable); dcl pathname_ entry (char (*), char (*)) returns (char (168)); dcl release_temp_segment_ entry (char (*), pointer, fixed bin (35)); dcl ring0_get_$segptr entry (char (*), char (*), ptr, fixed bin (35)); dcl ring_zero_peek_ entry (ptr, ptr, fixed bin (19), fixed bin (35)); dcl terminate_file_ entry (ptr, fixed bin (24), bit (*), fixed bin (35)); dcl user_info_ entry (char (*)); dcl error_table_$active_function fixed bin (35) ext static; dcl error_table_$badopt fixed bin (35) ext static; dcl error_table_$noarg fixed bin (35) ext static; dcl error_table_$not_act_fnc fixed bin (35) ext static; dcl cpz_status_table_$cpz_status_table_ ext; dcl crz_status_table_$crz_status_table_ ext; dcl disk_status_table_$disk_status_table_ ext; dcl imp_status_table_$imp_status_table_ ext; dcl prt_status_table_$prt_status_table_ ext; dcl tape_status_table_$tape_status_table_ ext; dcl cleanup condition; dcl (abs, addr, addrel, before, bin, clock, currentsize, divide, index, length, low, null, rel, rtrim, substr, unspec, verify) builtin; idp = null (); on cleanup call clean_up; /* Check arguments */ call cu_$arg_list_ptr (arg_list_ptr); call scan_args; /* Get ioi_data from wherever appropriate */ if path_sw then call initiate_ioi_data; else if erf_sw then call extract_ioi_data; else call fetch_ioi_data; /* Print results */ if user_sw then do; if header_sw then call dump_header; found = "0"b; do i = 1 to ioi_data.ndt; dtep = addr (ioi_data.dt (i)); if dte.in_use & (dte.process_id ^= "0"b) then do; call get_userid_ ((dte.process_id), person, project, (0), (0), code); if code = 0 then do; if (person_req = "*" | person_req = person) & (project_req = "*" | project_req = project) then do; call dump_dte; found = "1"b; end; end; end; end; if ^found then call com_err_ (0, name, "No devices found for user ^a.^a.", person_req, project_req); end; else if block_given then do; if header_sw then call dump_header; call dump_block; end; else call dump_header; call ioa_ (""); done: call clean_up; return; /* Process the argument list */ scan_args: proc; dcl i fixed bin; call cu_$af_arg_count_rel (n_args, code, arg_list_ptr); if code = 0 then code = error_table_$active_function; else if code = error_table_$not_act_fnc then code = 0; if code ^= 0 then do; call com_err_ (code, name); goto done; end; arg_no = 1; more_args = (arg_no <= n_args); do while (more_args); call get_arg; if arg = "-segment" | arg = "-sm" then do; if source_given then do; conflict: call com_err_ (0, name, "^a conflicts with an earlier argument", arg); go to done; end; source_given = "1"b; path_sw = "1"b; if ^more_args then do; use_wdir: dir = get_wdir_ (); ename = "ioi_data"; end; else do; call get_arg; if substr (arg, 1, 1) = "-" then do; /* No path, just another arg */ call put_arg; go to use_wdir; end; call expand_pathname_ (arg, dir, ename, code); if code ^= 0 then do; call com_err_ (code, name, "^a", arg); go to done; end; end; end; else if arg = "-erf" then do; if source_given then go to conflict; if ^more_args then do; missing: call com_err_ (error_table_$noarg, name, "After ^a", arg); go to done; end; erf_sw = "1"b; call get_arg; erf_name = arg; end; else if arg = "-gte" then do; if block_given then go to conflict; block_given, gte_sw = "1"b; gte_offset = get_offset_arg (); end; else if arg = "-cte" then do; if block_given then go to conflict; block_given, cte_sw = "1"b; cte_offset = get_offset_arg (); end; else if arg = "-dte" then do; if block_given then go to conflict; block_given, dte_sw = "1"b; dte_offset = get_offset_arg (); end; else if arg = "-group" | arg = "-gp" then do; if block_given then go to conflict; block_given, group_sw = "1"b; if ^more_args then do; all_groups: group_sw = "0"b; gte_sw = "1"b; gte_offset = -1; end; else do; call get_arg; if substr (arg, 1, 1) = "-" then do; call put_arg; go to all_groups; end; group_name = arg; end; end; else if arg = "-channel" | arg = "-ch" | arg = "-chn" | arg = "-chan" then do; if block_given then go to conflict; block_given, channel_sw = "1"b; if ^more_args then do; all_channels: channel_sw = "0"b; cte_sw = "1"b; cte_offset = -1; end; else do; call get_arg; if substr (arg, 1, 1) = "-" then do; call put_arg; go to all_channels; end; channel_id = arg; end; end; else if arg = "-device" | arg = "-dv" then do; if block_given then go to conflict; block_given, device_sw = "1"b; if ^more_args then do; all_devices: device_sw = "0"b; dte_sw = "1"b; dte_offset = -1; end; else do; call get_arg; if substr (arg, 1, 1) = "-" then do; call put_arg; go to all_devices; end; if length (arg) = 4 then device_name = arg; else if length (arg) = 7 then do; if substr (arg, 5, 1) ^= "_" then do; bad_device: call com_err_ (0, name, "Invalid device name: ^a", arg); go to done; end; if verify (substr (arg, 6, 2), "0123456789") ^= 0 then go to bad_device; device_name = arg; device_no = bin (substr (arg, 6, 2)); end; else go to bad_device; end; end; else if arg = "-user" then do; if block_given then go to conflict; block_given, user_sw = "1"b; if ^more_args then do; user_is_me: call user_info_ (person_req); project_req = "*"; end; else do; call get_arg; if substr (arg, 1, 1) = "-" then do; call put_arg; go to user_is_me; end; i = index (arg, "."); if i = 0 then do; person_req = arg; project_req = "*"; end; else if i = 1 then do; person_req = "*"; if length (arg) > 1 then project_req = before (substr (arg, 2), "."); else project_req = "*"; end; else do; person_req = substr (arg, 1, i - 1); if length (arg) = i then project_req = "*"; else project_req = substr (arg, i + 1); i = index (project_req, "."); /* In case tag */ if i > 0 then substr (project_req, i) = ""; end; end; end; else if arg = "-header" | arg = "-he" then do; header_sw = "1"b; no_header_sw = "0"b; end; else if arg = "-no_header" | arg = "-nhe" then do; header_sw = "0"b; no_header_sw = "1"b; end; else if arg = "-force" | arg = "-fc" then force_sw = "1"b; else if arg = "-all" | arg = "-a" then all_sw = "1"b; else if arg = "-brief" | arg = "-bf" then brief_sw = "1"b; else if arg = "-long" | arg = "-lg" then brief_sw = "0"b; else do; call com_err_ (error_table_$badopt, name, "^a", arg); go to done; end; end; if ^block_given & ^header_sw then do; /* Setup defaults if no arguments */ block_given = "1"b; gte_sw = "1"b; /* Default is -gte -a */ gte_offset = -1; all_sw = "1"b; header_sw = ^no_header_sw; end; if user_sw & erf_sw then do; call com_err_ (0, name, "-user and -erf are incompatable."); go to done; end; return; end scan_args; get_arg: proc; call cu_$arg_ptr_rel (arg_no, argp, argl, code, arg_list_ptr); if code ^= 0 then do; call com_err_ (code, name, "Can't happen."); go to done; end; arg_no = arg_no + 1; more_args = (arg_no <= n_args); return; put_arg: entry; arg_no = arg_no - 1; more_args = (arg_no <= n_args); return; end get_arg; get_offset_arg: proc returns (fixed bin); dcl temp fixed bin; if ^more_args then return (-1); call get_arg; if substr (arg, 1, 1) = "-" then do; call put_arg; return (-1); end; temp = cv_oct_check_ (arg, code); if code = 0 then return (temp); call com_err_ (0, name, "Invalid octal number: ^a", arg); go to done; end get_offset_arg; /* Fetch ioi_data segment from ring-0 */ fetch_ioi_data: proc; dcl r0p ptr; dcl i fixed bin (19); dcl based_words (i) bit (36) aligned based; call get_temp_segment_ (name, idp, code); if code ^= 0 then do; call com_err_ (code, name, "Unable to get temp segment."); go to done; end; call ring0_get_$segptr ("", "ioi_data", r0p, code); if code ^= 0 then do; call com_err_ (code, name, "Unable to get pointer to ioi_data"); go to done; end; i = bin (rel (addr (ioi_data.gt))); /* Length of header */ call ring_zero_peek_ ((r0p), idp, i, code); if code ^= 0 then do; call com_err_ (code, name, "Unable to read first ^a words of ioi_data.", edit_dec ((i))); go to done; end; i = currentsize (ioi_data); /* Now can calculate the entire length */ unspec (idp -> based_words) = "0"b; /* Touch all pages to minimize chance of page fault during copy of data. This should reduce chance of inconsistent data */ call ring_zero_peek_ ((r0p), idp, i, code); if code ^= 0 then do; call com_err_ (code, name, "Unable to read the ^a words of ioi_data.", edit_dec ((i))); go to done; end; return; end fetch_ioi_data; initiate_ioi_data: proc; call initiate_file_ (dir, ename, R_ACCESS, idp, (0), code); if code ^= 0 then do; call com_err_ (code, name, "^a", pathname_ (dir, ename)); go to done; end; return; end initiate_ioi_data; extract_ioi_data: proc; call extract (rtrim (erf_name), "ioi_data"); dir = get_wdir_ (); ename = "ioi_data." || erf_name; call initiate_ioi_data; return; end extract_ioi_data; clean_up: proc; if idp ^= null () then do; if path_sw then call terminate_file_ (idp, 0, TERM_FILE_TERM, code); else if erf_sw then call delete_$ptr (idp, "010100"b, name, code); else call release_temp_segment_ (name, idp, code); end; return; end clean_up; dump_block: proc; dcl i fixed bin; dcl sw bit (1); dcl found bit (1); dcl temp_gtep ptr; if gte_sw | group_sw then do; /* Asked for group */ found = "0"b; do i = 1 to ioi_data.ngt; gtep = addr (ioi_data.gt (i)); if gte_sw then if gte_offset = -1 then sw = "1"b; else sw = bin (rel (gtep)) = gte_offset; else sw = (gte.name = group_name); if sw then do; call dump_gte; found = "1"b; end; end; if found then return; if gte_sw then if gte_offset = -1 then call com_err_ (0, name, "No allocated group entries."); else call com_err_ (0, name, "^o is not a valid gte offset.", gte_offset); else call com_err_ (0, name, "No group entry found for ^a", group_name); go to done; end; if cte_sw | channel_sw then do; found = "0"b; do i = 1 to ioi_data.nct; ctep = addr (ioi_data.ct (i)); if cte_sw then if cte_offset = -1 then sw = force_sw; else sw = (bin (rel (ctep)) = cte_offset); else sw = (cte.chanid = channel_id); if sw then do; call dump_cte; found = "1"b; end; end; if found then return; if cte_sw then if cte_offset = -1 then call com_err_ (0, name, "No allocated channel entries."); else call com_err_ (0, name, "^o is not a valid cte offset.", cte_offset); else call com_err_ (0, name, "No channel entry found for channel ^a.", channel_id); go to done; end; if dte_sw | device_sw then do; found = "0"b; do i = 1 to ioi_data.ndt; dtep = addr (ioi_data.dt (i)); if dte_sw then if dte_offset = -1 then sw = force_sw; else sw = (bin (rel (dtep)) = dte_offset); else if dte.gtep = "0"b then sw = "0"b; else do; temp_gtep = addrel (idp, dte.gtep); sw = (temp_gtep -> gte.name = substr (device_name, 1, 4)); if length (device_name) = 7 then sw = sw & (bin (dte.device) = device_no); end; if sw then do; call dump_dte; found = "1"b; end; end; if found then return; if dte_sw then if dte_offset = -1 then call com_err_ (0, name, "No allocated device entries."); else call com_err_ (0, name, "^o is not a valid dte offset.", dte_offset); else call com_err_ (0, name, "No device entry found for device ^a.", device_name); go to done; end; return; end dump_block; /* Dump an individual group table entry */ dump_gte: proc; dcl i fixed bin; dcl temp_name char (4); temp_name = gte.name; if temp_name = low (4) then temp_name = ""; if temp_name = "" then temp_name = "?"; call ioa_ ("^/Group entry at ^o for ^a.", bin (rel (gtep)), temp_name); if brief_sw then go to process_all; if gte.lock ^= ""b then call ioa_ (" Locked by process ^w.", gte.lock); call ioa_ (" Flags:^[ mplex^]^[ psia^]^[ suspend_devices^]^[ dual_controller^]^[ ascii_dtst^]^[ fips^]^[ ipc^]", gte.mplex, gte.psia, gte.suspend_devices, gte.dual_controller, gte.ascii_dtst, gte.fips, gte.ipc); if substr (temp_name, 1, 3) = "dsk" then call ioa_ (" Disk subsystem index: ^a", edit_dec ((gte.disk_data_subsystem_idx))); call ioa_ (" ^a device^[s^], ^a with connect pending.", edit_dec ((gte.n_devices)), (gte.n_devices ^= 1), edit_dec ((gte.pending_connects))); call ioa_ (" Last device entry at ^o, first channel at ^o", bin (gte.dtep), bin (gte.ctep)); call ioa_ (" Detailed status command: ^.3b, log_info index ^a", gte.detailed_status_cmd, edit_dec ((gte.io_log_info_index))); process_all: if all_sw then do; do i = 1 to ioi_data.nct; /* Get all channels */ ctep = addr (ioi_data.ct (i)); if cte.gtep = rel (gtep) then call dump_cte; end; do i = 1 to ioi_data.ndt; dtep = addr (ioi_data.dt (i)); if dte.gtep = rel (gtep) then call dump_dte; end; end; return; end dump_gte; /* Procedure to dump a channel table entry */ dump_cte: proc; dcl temp_gtep ptr; dcl group_name char (4); group_name = ""; if cte.gtep ^= "0"b then do; temp_gtep = addrel (idp, cte.gtep); group_name = temp_gtep -> gte.name; end; call ioa_ ("^/Channel entry at ^o for channel ^a^[ (^a)^;^s^].", bin (rel (ctep)), cte.chanid, (group_name ^= ""), group_name); if brief_sw then return; call ioa_ (" Flags:^[ ioi_use^]^[ connected^]^[ deleting^]^[ deleted^]^[ toss_status^]^[ quiescing^]", cte.ioi_use, cte.connected, cte.deleting, cte.deleted, cte.toss_status, cte.quiescing); call ioa_ (" Current device ^o, iom channel index ^o^[, disk channel index ^o^;^s^], iocd idx ^d", bin (cte.cur_dtep), cte.chx, (cte.disktab_ctx ^= 0), cte.disktab_ctx, cte.channel_table_idx); if cte.time_limit ^= 0 then do; call ioa_ (" Time limit^[ was^] at ^a", (clock () > cte.time_limit), time_string (cte.time_limit)); end; if unspec (cte.saved_status) ^= "0"b then do; call ioa_ (" Saved status during detailed status read:"); call ioa_ (" cmd ^.3b, offset ^o, lpw ^w", cte.saved_status.command, cte.saved_status.next_lpw_offset, cte.saved_status.word2); call ioa_ (" iom_status ^.3b.", cte.saved_status.word1 || cte.saved_status.word4); end; return; end dump_cte; /* Procedure to dump a device entry */ dump_dte: proc; dcl temp_gtep ptr; dcl device_name char (7); dcl device_type char (3); dcl dev_pic picture "99"; dcl person char (22); dcl project char (9); dcl status_msg char (72) var; dcl status_tablep ptr; dcl pack_sw bit (1); /* "1"b = detailed status in ascii, not binary */ pack_sw = "0"b; if dte.gtep = "0"b then temp_gtep = null (); else temp_gtep = addrel (idp, dte.gtep); if temp_gtep = null () then device_name, device_type = "?"; else do; device_name = temp_gtep -> gte.name; device_type = substr (device_name, 1, 3); if temp_gtep -> gte.mplex then do; dev_pic = bin (dte.device); device_name = rtrim (device_name) || "_" || dev_pic; end; if temp_gtep -> gte.ipc & (device_type = "prt" | device_type = "rdr" | device_type = "pun") then pack_sw = "1"b; end; call ioa_ ("^/Device entry at ^o for ^a", bin (rel (dtep)), device_name); if brief_sw then return; call ioa_ ( " Flags:^[ priv^]^[ in_use^]^[ suspended^]^[ active^]^[ connected^]^[ workspace_wired^]^[ special_interrupt^]^[ log_status_cnt^]^[ deleting^]^[ deleted^]^[ reading_detailed_status^]^[ detailed_status_valid^]^[ direct^]^[ controller^]", dte.priv, dte.in_use, dte.suspended, dte.active, dte.connected, dte.workspace_wired, dte.special_interrupt, dte.log_status_cnt, dte.deleting, dte.deleted, dte.reading_detailed_status, dte.detailed_status_valid, dte.direct, dte.controller); if dte.cur_ctep ^= ""b then call ioa_ (" Current channel ^o", dte.cur_ctep); person, project = ""; if dte.process_id ^= "0"b & ^erf_sw then do; call get_userid_ ((dte.process_id), person, project, (0), (0), code); if code ^= 0 then person, project = ""; end; call ioa_ (" Process ^.3b^[ (^a.^a)^;^2s^], event ^.3b, ring ^o", dte.process_id, (person ^= ""), person, project, unspec (dte.ev_chn), dte.ring); call ioa_ (" Workspace bound ^o, max bound ^o", dte.bound, dte.max_bound); call ioa_ (" Workspace ptr ^p, astep ^p, sdw ^.3b, iopt idx ^o", dte.workspace_ptr, dte.workspace_astep, unspec (dte.workspace_sdw), dte.ptx); if dte.channel_required ^= "" then call ioa_ (" Channel required: ^a.", dte.channel_required); call ioa_ (" listx ^o, pcw ^.3b, idcw ^.3b, tdcw ^.3b, iocd idx ^d", bin (dte.listx), dte.pcw, dte.idcw, dte.tdcw, dte.device_table_idx); call ioa_ (" Time limit: ^a second^[s^], max limit ^a second^[s^].", edit_dec (divide (dte.timeout, 1000000, 17)), (dte.timeout ^= 1000000), edit_dec (divide (dte.max_timeout, 1000000, 17)), (dte.max_timeout ^= 1000000)); if dte.unwire_time ^= 0 then call ioa_ (" Workspace ^[scheduled for unwiring^;unwired^] at ^a.", dte.workspace_wired, time_string (dte.unwire_time)); if dte.last_log_time ^= 0 then call ioa_ (" Status last logged at ^a.", time_string (dte.last_log_time)); if dte.special_status ^= "0"b then call ioa_ (" Special status: ^.3b", dte.special_status); if unspec (dte.log_status) ^= ""b then do; if device_type = "tap" then status_tablep = addr (tape_status_table_$tape_status_table_); else if device_type = "dsk" then status_tablep = addr (disk_status_table_$disk_status_table_); else if device_type = "prt" then status_tablep = addr (prt_status_table_$prt_status_table_); else if device_type = "pun" then status_tablep = addr (cpz_status_table_$cpz_status_table_); else if device_type = "rdr" then status_tablep = addr (crz_status_table_$crz_status_table_); else if device_type = "imp" then status_tablep = addr (imp_status_table_$imp_status_table_); else status_tablep = null (); call analyze_device_stat_$rsnnl (status_msg, status_tablep, (dte.log_status.status), ("0"b)); call ioa_ (" Last logged status: level-^d status-^.3b^[ ^;^/^21x^]""^a""", dte.log_status.level, dte.log_status.status, (length (status_msg) < 28), status_msg); end; if unspec (dte.detailed_status) ^= "0"b then do; call ioa_$nnl (" Detailed status:"); call dump_detail (addr (dte.detailed_status), pack_sw); end; if unspec (dte.status_control) ^= ""b then do; call ioa_ (" Status queue at ^o, length ^o, tally ^o", dte.status_offset, dte.status_entries, dte.status_entry_idx); end; return; end dump_dte; dump_detail: proc (p, pack); dcl p ptr; dcl pack bit (1); dcl dtstat (27) bit (8) unal based (p); dcl 1 ascii_dtstat (24) unal based (p), 2 pad bit (1), 2 data bit (8); dcl packed_dtstat (24) bit (8) unal; dcl i fixed bin; if pack then do; do i = 1 to 24; packed_dtstat (i) = ascii_dtstat (i).data; end; do i = 24 to 1 by -1 while (packed_dtstat (i) = "0"b); end; call ioa_ ("^v( ^.4b^)", i, packed_dtstat); return; end; do i = 27 to 1 by -1 while (dtstat (i) = "0"b); end; call ioa_ ("^v( ^.4b^)", i, dtstat); return; end dump_detail; /* Dump ioi_data header info */ dump_header: proc; call ioa_ ("^/Segment ioi_data: ^o words long.", currentsize (ioi_data)); if brief_sw then return; call ioa_ (" ^a group entries, ^a channel entries, ^a device entries", edit_dec ((ioi_data.ngt)), edit_dec ((ioi_data.nct)), edit_dec ((ioi_data.ndt))); return; end dump_header; time_string: proc (time) returns (char (24)); dcl time fixed bin (71); dcl time_temp char (24); dcl cur_date_time char (24); call date_time_ (time, time_temp); substr (time_temp, 17) = ""; call date_time_ (clock (), cur_date_time); if substr (time_temp, 1, 8) = substr (cur_date_time, 1, 8) then time_temp = substr (time_temp, 11); return (time_temp); end time_string; edit_dec: proc (n) returns (char (32) var); dcl n fixed bin (71); dcl dec_sw bit (1); dcl result char (32); dec_sw = (abs (n) > 7); call ioa_$rsnnl ("^d^[d^]", result, (0), n, dec_sw); return (rtrim (result)); end edit_dec; %include ioi_data; %page; %include terminate_file; %page; %include access_mode_values; end display_ioi_data;  display_kst_entry.pl1 01/26/85 1311.6r w 01/22/85 1301.6 46746 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ display_kst_entry: dke: proc; /* Written 04/22/76 by Richard Bratt Fixed to compile properly, May 1981, W. Olin Sibert Modified to remove hdr, Keith Loepere, November 1984. */ dcl ap ptr, al fixed bin, flags char (168) varying init (""), phcs_initiate bit (1) aligned init ("0"b), linkage_error condition, segno fixed bin (17), segptr ptr, terminate bit (1) aligned, dsegp ptr, arg char (al) based (ap), dname char (168), ename char (32), code fixed bin (35); dcl kst_copy_buffer (50) fixed bin; dcl p ptr; dcl sdw_copy_buffer (2) fixed bin; dcl s ptr; dcl error_table_$invalidsegno ext fixed bin (35); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)), (ioa_, com_err_) entry options (variable), cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin), expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin (35)), (hcs_$terminate_noname, phcs_$terminate_noname) entry (ptr, fixed bin (35)), (hcs_$initiate, phcs_$initiate) entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)), ring_zero_peek_ entry (ptr, ptr, fixed bin, fixed bin (35)), ring0_get_$segptr entry (char (*), char (*), ptr, fixed bin (35)); dcl (addr, baseno, binary, null, pointer, rel, size, unspec) builtin; /* */ terminate = "0"b; p = addr (kst_copy_buffer); /* Used to use init (addr (...)) */ s = addr (sdw_copy_buffer); call cu_$arg_ptr (1, ap, al, code); if code ^= 0 then do; complain: call ioa_ ("USAGE: display_kst_entry |"); return; end; segno = cv_oct_check_ (arg, code); if code ^= 0 then do; if arg = "-name" | arg = "-nm" then do; call cu_$arg_ptr (2, ap, al, code); if code ^= 0 then go to complain; end; call expand_path_ (ap, al, addr (dname), addr (ename), code); if code ^= 0 then call abort (code); call hcs_$initiate (dname, ename, "", 0, 1, segptr, code); if segptr = null () then do; on linkage_error call abort (code); call phcs_$initiate (dname, ename, "", 0, 1, segptr, code); revert linkage_error; phcs_initiate = "1"b; end; if segptr = null () then call abort (code); terminate = "1"b; segno = binary (baseno (segptr), 18); end; call ring0_get_$segptr ("", "kst_seg", kstp, code); call ring0_get_$segptr ("", "dseg", dsegp, code); call ring_zero_peek_ (kstp, p, 8, code); if code ^= 0 then call abort (code); if segno < p -> kst.lowseg | segno > p -> kst.highest_used_segno then call abort (error_table_$invalidsegno); kstep = ptr (kstp, bin (bin (rel (addr (p -> kst.kst_entry (segno))), 18) - bin (rel (p), 18), 18)); call ring_zero_peek_ (kstep, p, size (kste), code); if code ^= 0 then call abort (code); call ring_zero_peek_ (addr (dsegp -> sdwa (segno)), s, size (sdw), code); if code ^= 0 then unspec (sdw_copy_buffer) = "0"b; call ioa_ ("^/segno:^-^o at ^p", segno, kstep); call ioa_ ("usage:^-^7(^d, ^)^d", p -> kste.usage_count); call ioa_ ("entryp:^-^p", p -> kste.entryp); call ioa_ ("uid:^-^w", p -> kste.uid); call ioa_ ("dtbm:^-^w", p -> kste.dtbm); call ioa_ ("mode:^-^o (^d, ^d, ^d)", bin (p -> kste.access, 3), bin (s -> sdw.r1, 3), bin (s -> sdw.r2, 3), bin (s -> sdw.r3, 3)); if p -> kste.extended_access = "0"b then call ioa_ ("ex mode:^-00000000000 (^d, ^d, ^d)", bin (p -> kste.ex_rb (1), 3), bin (p -> kste.ex_rb (2), 3), bin (p -> kste.ex_rb (3), 3)); else call ioa_ ("ex mode:^-^11o (^d, ^d, ^d)", bin (p -> kste.extended_access, 33), bin (p -> kste.ex_rb (1), 3), bin (p -> kste.ex_rb (2), 3), bin (p -> kste.ex_rb (3), 3)); if p -> kste.dirsw then call ioa_ ("infcount:^-^d", p -> kste.infcount); else call ioa_ ("lv index:^-^o", p -> kste.infcount); if p -> kste.dirsw then flags = flags || "dirsw "; if p -> kste.allow_write then flags = flags || "write "; if p -> kste.priv_init then flags = flags || "priv "; if p -> kste.tms then flags = flags || "tms "; if p -> kste.tus then flags = flags || "tus "; if p -> kste.tpd then flags = flags || "tpd "; if p -> kste.audit then flags = flags || "audit "; if p -> kste.explicit_deact_ok then flags = flags || "deactivate "; call ioa_ ("flags:^-^a", flags); if terminate then if phcs_initiate then call phcs_$terminate_noname (segptr, code); else call hcs_$terminate_noname (segptr, code); return; abort: proc (code); dcl code fixed bin (35); call com_err_ (code, "display_kst_entry"); go to return_to_caller; end abort; return_to_caller: return; /* */ % include kst; /* */ % include sdw; end display_kst_entry;  display_vtoce.pl1 07/18/86 1504.5r w 07/18/86 1234.9 234603 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style2,indcomtxt */ display_vtoce: procedure options (variable); /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* dump_vtoce Bernard Greenberg 4/21/76 */ /* */ /* Modified: Joe Stansbury 1/82 */ /* 1) made "brief" the default behavior */ /* 2) fixed bug to allow dumping of ncd switch */ /* 3) implemented better error msg when pathname is given as an arg */ /* 4) allowed octal dumping by activation info, file map, and permanent info. */ /* */ /* Modified: J. Bongiovanni, 9/82, synchronized switch, fm_damaged, fm_checksum_valid */ /* Modified: 2/10/83 by GA Texada to add access class to output. */ /* Modified: 2/22/83 by GA Texada to allow pathnames */ /* Modified: 84-01-21 by BIM. Flush octal printing, save with -dump. Display devadds in useful (if more verbose) format. add -he/-nhe -fm/-nfm -octal/-no_octal add -long as for obscure stuff. -octal just dumps the whole thing in dump_segment format. */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* EXTERNAL ENTRIES */ dcl com_err_ entry () options (variable); dcl com_err_$suppress_name entry () options (variable); dcl cu_$arg_count entry (fixed bin, fixed bin (35)); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin); dcl date_time_$format entry (character (*), fixed binary (71), character (*), character (*)) returns (character (250) var); dcl dump_segment_ entry (pointer, pointer, fixed binary, fixed binary (18), fixed binary (18), bit (*)); dcl get_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); dcl ioa_ entry () options (variable); dcl ioa_$nnl entry () options (variable); dcl ioa_$rsnnl entry options (variable); dcl mdc_$read_disk_table entry (ptr, fixed bin (35)); dcl mdc_$find_volname entry (bit (36) aligned, char (*), char (*), fixed bin (35)); dcl phcs_$get_vtoce entry (fixed bin, fixed bin, ptr, fixed bin (35)); dcl release_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); dcl requote_string_ entry (char (*)) returns (char (*)); dcl vpn_cv_uid_path_$ent entry (ptr, char (*), bit (36) aligned, fixed bin (35)); /* BASED */ dcl arg char (argl) based (argp); /* BUILTIN */ dcl (addr, divide, fixed, index, lbound, length, hbound, null, reverse, substr, unspec, verify, addwordno, bin, byte, copy, decimal, rtrim, string) builtin; /* AUTOMATIC */ dcl Nargs fixed bin; dcl argl fixed bin; dcl argp ptr; dcl code fixed bin (35); dcl fx fixed bin; dcl free bit (1); /* is it a free VTOCE? */ dcl (i, non_ctl_args) fixed bin; dcl (file_map_sw, header_sw, octal_sw, long_sw) bit (1) aligned; dcl last_fme bit (18); dcl skipping bit (1) aligned; dcl args (2) char (168); dcl pname char (168); dcl pvname char (24); dcl lvname char (32); dcl pvtx fixed bin; dcl q (1) ptr init (null ()); dcl sname char (32); dcl vtocx fixed bin; dcl vpn char (168); /* STATIC */ dcl goodstuff char (182) varying init ( "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789.!""#$%&'()=-^~|\{}[]_/?.,<>:*;+@` " ) static internal options (constant); dcl myname char (32) int static options (constant) init ("display_vtoce"); dcl error_table_$pvid_not_found fixed bin (35) ext static; dcl error_table_$bad_conversion fixed bin (35) ext static; dcl error_table_$badopt fixed bin (35) ext static; dcl error_table_$wrong_no_of_args fixed bin (35) ext static; dcl iox_$user_output ptr ext static; /* STRUCTURES */ dcl 1 local_vtoce like vtoce aligned; /* CONDITIONS */ dcl cleanup condition; free = "0"b; header_sw = "1"b; long_sw, octal_sw, file_map_sw = "0"b; pname, pvname = ""; non_ctl_args, vtocx, pvtx = 0; call cu_$arg_count (Nargs, code); if code ^= 0 then do; call com_err_ (code, myname); return; end; if Nargs < 1 then USAGE: do; call com_err_$suppress_name (0, myname, "Usage: display_vtoce {Pathname|pvname vtocx(octal)} -he/-nhe -fm/-nfm -octal/-no_octal"); return; end; do i = 1 to Nargs; call cu_$arg_ptr (i, argp, argl, (0)); if arg = "-long" | arg = "-lg" then header_sw, long_sw = "1"b; else if arg = "-brief" | arg = "-bf" then do; header_sw = "1"b; long_sw = "0"b; end; else if arg = "-octal" | arg = "-oc" then octal_sw = "1"b; else if arg = "-no_octal" | arg = "-noc" then octal_sw = "0"b; else if arg = "-file_map" | arg = "-fm" then file_map_sw = "1"b; else if arg = "-no_file_map" | arg = "-nfm" then file_map_sw = "0"b; else if arg = "-header" | arg = "-he" then header_sw = "1"b; else if arg = "-no_header" | arg = "-nhe" then header_sw = "0"b; else if index (arg, "-") = 1 then do; call com_err_ (error_table_$badopt, myname, "^a", arg); return; end; else do; non_ctl_args = non_ctl_args + 1; /* count these to prevent ambiguity */ if non_ctl_args > 2 then do; code = error_table_$wrong_no_of_args; goto USAGE; end; args (non_ctl_args) = arg; end; end; if non_ctl_args = 1 then do; /* MUST be a pathname */ pname = args (1); /* path given, we need to determine everything */ call get_vtocx (pname, vtocx, pvname, code); /* get the vtocx and pvname */ if code ^= 0 then return; /* errors already given */ call get_pvtx ((pvname)); /* use pvname from above to get pvtx */ if code ^= 0 then return; end; else do; /* if we have 2 non-ctl args */ pvtx = cv_oct_check_ (args (1), code); /* it's either a pvtx (in octal) */ if code ^= 0 then do; call get_pvtx (args (1)); /* or a pvname */ if code ^= 0 then return; end; else do; /* now, got a pvtx, get pvname */ call get_pvname (pvtx, code); if code ^= 0 then return; end; vtocx = cv_oct_check_ (args (2), code); /* with either a pvtx or pvname need this */ if code ^= 0 then do; call com_err_ (error_table_$bad_conversion, myname, "Invalid vtocx: ^a. Vtocx must be given in octal.", args (2)); return; end; end; vtocep = addr (local_vtoce); /* set up for get_vtoce */ call phcs_$get_vtoce (pvtx, vtocx, vtocep, code); /* get it */ if code ^= 0 then do; call com_err_ (code, myname, "Getting vtoce ^o on pvtx ^o.", vtocx, pvtx); return; end; /* Get reasonable printing of name */ if vtoce.uid = ""b /* FREE */ then do; free = "1"b; sname = "in a free state"; end; else do; if verify (vtoce.primary_name, goodstuff) = 0 then sname = requote_string_ (rtrim (vtoce.primary_name)); else begin; declare pname_bits (32) bit (9) unaligned; unspec (pname_bits) = unspec (vtoce.primary_name); sname = ""; call ioa_$rsnnl ("nonASCII name ^(^.3b^)", sname, (0), pname_bits); end; end; call ioa_ ("^/VTOCE ^a ^[(Directory)^], vtocx ^o on pvtx ^o (^a)^/", sname, vtoce.dirsw, vtocx, pvtx, pvname); if header_sw & ^free then do; call ioa_ ("UID: ^w, msl: ^3d, csl: ^3d, records: ^3d", vtoce.uid, fixed (vtoce.msl, 9), fixed (vtoce.csl, 9), fixed (vtoce.records, 9)); if vtoce.dirsw then do; if vtoce.quota (0) ^= 0 | vtoce.quota (1) ^= 0 then call ioa_ (" Quota (S D)^30t(^6d ^6d)", vtoce.quota (0), vtoce.quota (1)); if vtoce.used (0) ^= 0 | vtoce.used (1) ^= 0 then call ioa_ (" Quota used (S D)^30t(^6d ^6d)", vtoce.used (0), vtoce.used (1)); if vtoce.received (0) ^= 0 | vtoce.received (1) ^= 0 then call ioa_ (" Quota received (S D)^30t(^6d ^6d)", vtoce.received (0), vtoce.received (1)); if vtoce.trp (0) ^= 0 then do; call ioa_ ( " Time-record product (S) ^6e page-seconds^/ updated at ^a.", divide (decimal (vtoce.trp (0), 30), 1000000, 30, 6), fs_date_time (vtoce.trp_time (0))); end; if vtoce.trp (1) ^= 0 then do; call ioa_ ( " Time-record product (D) ^6e page-seconds^/ updated at ^a.", divide (decimal (vtoce.trp (1), 30), 1000000, 30, 6), fs_date_time (vtoce.trp_time (1))); end; end; else call ioa_ ("Usage count = ^d", seg_vtoce.usage); call ioa_ ("Created ^12t^a", fs_date_time (vtoce.time_created)); if vtoce.dtd then call ioa_ ("Dumped ^12t^a", fs_date_time (vtoce.dtd)); else call ioa_ ("Never dumped"); if vtoce.dtu then call ioa_ ("Used ^12t^a", fs_date_time (vtoce.dtu)); else call ioa_ ("Never used"); if vtoce.dtm then call ioa_ ("Modified ^12t^a", fs_date_time (vtoce.dtm)); else call ioa_ ("Never modified"); call flag$$init; call flag (vtoce.deciduous, "deciduous"); call flag (vtoce.per_process, "per_process"); call flag (vtoce.nqsw, "nqsw"); call flag (vtoce.master_dir, "master_dir"); call flag (vtoce.nid, "nid"); call flag (vtoce.ncd, "ncd"); call flag (vtoce.dnzp, "dnzp"); call flag (vtoce.damaged, "damaged"); call flag (vtoce.synchronized, "synchronized"); call flag (vtoce.fm_damaged, "fm_damaged"); call flag (vtoce.fm_checksum_valid, "fm_checksum_valid"); call flag$$display; call get_access_class (vtoce.access_class, code); if code ^= 0 then call ioa_ ("Unable to convert access class information."); end; if long_sw then do; call vpn_cv_uid_path_$ent (addr (vtoce.uid_path), vpn, (vtoce.uid), code); if code = 0 then call ioa_ ("UID path: ^a", vpn); else call com_err_$suppress_name (code, myname, "UID path ^(^w^).", vtoce.uid_path); call mdc_$find_volname ((vtoce.par_pvid), pvname, lvname, code); if code = 0 then call ioa_ ("Parent vtocx ^o of ^a of LV ^a", vtoce.par_vtocx, pvname, lvname); else call com_err_$suppress_name (code, myname, "Parent vtocx ^0 of pvid ^w.", vtoce.par_vtocx, vtoce.par_pvid); if vtoce.cn_salv_time then call ioa_ ("Check-vtoce salvage at ^a.", fs_date_time ((vtoce.cn_salv_time))); if vtoce.volid (1) then call VOLID (vtoce.volid (1), "incremental"); if vtoce.volid (2) then call VOLID (vtoce.volid (2), "consolidated"); if vtoce.volid (3) then call VOLID (vtoce.volid (3), "complete"); end; if file_map_sw then do; last_fme = ""b; /* unlikely */ skipping = "0"b; call ioa_ ("File map:"); do fx = 0 to hbound (vtoce.fm, 1); if vtoce.fm (fx) = last_fme & fx < hbound (vtoce.fm, 1) then skipping = "1"b; /* skip it */ else if skipping then do; skipping = "0"b; call ioa_ (" ======"); end; if ^skipping | fx = hbound (vtoce.fm, 1) then do; last_fme = vtoce.fm (fx); call ioa_$nnl ("^3d ", fx); if vtoce.fm (fx) = create_vtoce_null_addr then call ioa_ ("Null address from create_vtoce"); else if vtoce.fm (fx) = update_vtoce_null_addr then call ioa_ ("Null address from update_vtoce"); else if vtoce.fm (fx) = truncate_vtoce_null_addr then call ioa_ ("Null address from truncate_vtoce"); else if vtoce.fm (fx) = truncate_vtoce_fill_null_addr then call ioa_ ("Null address from truncate_vtoce_fill_vtoce"); else if vtoce.fm (fx) = pv_salv_null_addr then call ioa_ ("Null address from pv_salv"); else if vtoce.fm (fx) = pv_scav_null_addr then call ioa_ ("Null address from pv_scav"); else if vtoce.fm (fx) = volume_reloader_null_addr then call ioa_ ("Null address from volume_reloader"); else if vtoce.fm (fx) = salv_truncate_null_addr then call ioa_ ("Null address from salv_truncate"); else if substr (vtoce.fm (fx), 1, 1) then call ioa_ ("^a", page_control_null_address (vtoce.fm (fx))); else call ioa_ ("Record ^6o", vtoce.fm (fx)); end; end; end; if octal_sw then do; call ioa_ ("Octal dump:^/"); call ioa_ (" Part 1:"); call dump_segment_ (iox_$user_output, addr (local_vtoce), -1, 0, 64, "01000"b); call ioa_ ("^/Part 2:"); call dump_segment_ (iox_$user_output, addwordno (addr (local_vtoce), 64), -1, 0, 64, "01000"b); call ioa_ ("^/Part 3:"); call dump_segment_ (iox_$user_output, addwordno (addr (local_vtoce), 128), -1, 0, 64, "01000"b); end; return; %page; fs_date_time: procedure (dt) returns (char (30)); declare dt bit (36); declare 1 clock_ aligned like clock_value; declare time fixed bin (71); declare sub_error_ condition; clock_ = ""b; clock_.fs_time = dt; unspec (time) = string (clock_); go to COMMON; date_time: entry (full_clock) returns (char (30)); declare full_clock fixed bin (71); unspec (time) = unspec (full_clock); COMMON: if time = 0 then ZERO: return ("ZERO"); on sub_error_ go to ZERO; return (date_time_$format ("iso_long_date_time", time, "", "")); end fs_date_time; get_pvtx: proc (in_pvname); dcl in_pvname char (*); on cleanup call release_temp_segments_ (myname, q, (0)); call get_temp_segments_ (myname, q, code); if code ^= 0 then do; call com_err_ (code, myname, "Getting temp disk table."); return; end; dtp = q (1); /* set up pointer for disk table */ call mdc_$read_disk_table (dtp, code); /* get it */ if code ^= 0 then do; call com_err_ (code, myname, "Getting disk table."); call release_temp_segments_ (myname, q, (0)); return; end; do pvtx = 1 to dt.n_entries; /* look for given PV */ dtep = addr (dt.array (pvtx)); /* set pointer just in case, */ if dte.used & dte.storage_system & dte.pvname = in_pvname then go to got_pvtx; /* found it, continue. */ end; code = error_table_$pvid_not_found; call com_err_ (code, myname, "^a", in_pvname); call release_temp_segments_ (myname, q, (0)); return; got_pvtx: pvname = dte.pvname; call release_temp_segments_ (myname, q, (0)); end get_pvtx; get_pvname: proc (in_pvtx, ec); dcl in_pvtx fixed bin, ec fixed bin (35); on cleanup call release_temp_segments_ (myname, q, (0)); call get_temp_segments_ (myname, q, ec); if ec ^= 0 then do; call com_err_ (ec, myname, "Getting temp disk table."); return; end; dtp = q (1); /* set up pointer for disk table */ call mdc_$read_disk_table (dtp, ec); /* get it */ if ec ^= 0 then do; call com_err_ (ec, myname, "Getting disk table."); call release_temp_segments_ (myname, q, (0)); return; end; if (in_pvtx <= hbound (dt.array, 1) & in_pvtx >= lbound (dt.array, 1)) then ; /* check bounds to be sure */ else goto no_pvtx; /* out-of-bounds pvtx */ dtep = addr (dt.array (in_pvtx)); /* set pointer just in case, */ if dte.used & dte.storage_system then pvname = dte.pvname; else do; no_pvtx: ec = error_table_$pvid_not_found; call com_err_ (ec, myname, "Pvtx = ^d", in_pvtx); end; call release_temp_segments_ (myname, q, (0)); return; end get_pvname; get_vtocx: proc (pin, vtocxo, pvname, ec); /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* This procedure was cribbed from display_branch in its entirety. Very minor changes */ /* have been made to fit it in here. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ dcl pin char (*), pvname char (*), vtocxo fixed bin, ec fixed bin (35), LINK bit (18) unal init ("000000000000000101"b) int static options (constant), (adir, pdir) char (168), (ent, pent) char (32), (verify, null, addr, ptr, baseno, fixed, size, length, rel, reverse, substr) builtin, q ptr, error_table_$noentry fixed bin (35) ext, ring0_get_$segptr entry (char (*), char (*), ptr, fixed bin (35)), (rzdp, rzdsp) ptr, 1 tsdw like sdw aligned, lvname char (32), ppname char (168), epname char (168), (dirsegno, failct) fixed bin, hash_index_ entry (ptr, fixed bin, fixed bin, fixed bin) returns (fixed bin), dirlen fixed bin (17), hsi fixed bin, phcs_$initiate entry (char (*), char (*), char (*), fixed bin, fixed bin, ptr, fixed bin (35)), phcs_$terminate_noname entry (ptr, fixed bin (35)), phcs_$ring_0_peek entry (ptr, ptr, fixed bin), expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)), get_temp_segment_ entry (char (*), ptr, fixed bin (35)), release_temp_segment_ entry (char (*), ptr, fixed bin (35)), (cleanup, out_of_bounds) condition; %include sdw; %include dir_header; %include dir_ht; %include dir_entry; %include dir_link; %include dir_name; rzdsp, q = null (); ec = 0; call ring0_get_$segptr ("", "dseg", rzdsp, ec); if ec ^= 0 then do; call com_err_ (0, myname, "Cannot get dseg ptr"); return; end; got_ent: call expand_pathname_ (pin, adir, ent, ec); if ec ^= 0 then do; call com_err_ (ec, myname, pin); goto RETURN; end; if adir = ">" then if ent = "" then do; pvname = "rpv"; vtocxo = 0; goto RETURN; end; call expand_pathname_ (adir, pdir, pent, (0)); /* Cannot fail */ if pdir = ">" then ppname = ">" || pent; else ppname = substr (pdir, 1, trim (pdir)) || ">" || pent; if pent = "" then epname = ">" || ent; else epname = substr (adir, 1, trim (adir)) || ">" || ent; on cleanup goto RETURN; call get_temp_segment_ (myname, q, ec); if ec ^= 0 then do; call com_err_ (ec, myname, "Getting temp segment."); goto RETURN; end; dp = q; call phcs_$initiate (pdir, pent, "", 0, 0, rzdp, ec); if rzdp = null then do; call com_err_ (ec, myname, ppname); goto RETURN; end; dirsegno = fixed (baseno (rzdp), 18); call phcs_$ring_0_peek (rzdp, dp, 1); /* Cause fault */ failct = 0; ftsdw: call phcs_$ring_0_peek (addr (rzdsp -> sdwa (dirsegno)), addr (tsdw), 2); if tsdw.bound = "0"b then go to ftsdw; dirlen = fixed (tsdw.bound, 15) * 16 + 16; on out_of_bounds go to refetch_dir; refetch_dir: failct = failct + 1; if failct > 10 then do; call com_err_ (0, myname, "Cannot get consistent copy of ^a after 10 tries", ppname); goto RETURN; end; call m_a (dp, size (dir)); hsi = hash_index_ (addr (ent), trim (ent), 0, (dir.htsize)); htp = ptr (dp, dp -> dir.hash_table_rp); call m_a (htp, (dir.htsize)); do np = ptr (dp, htp -> hash_table.name_rp (hsi)) repeat ptr (dp, np -> names.hash_thread) while (rel (np)); call m_a (np, size (names)); if fixed (rel (np), 18) >= dirlen then go to refetch_dir; if np -> names.ht_index ^= hsi then go to refetch_dir; if ent = np -> names.name then do; ep = ptr (dp, np -> names.entry_rp); call m_a (ep, size (entry)); if entry.type = LINK then do; pin = link.pathname; call release_temp_segment_ (myname, q, (0)); call phcs_$terminate_noname (rzdp, (0)); goto got_ent; end; vtocxo = entry.vtocx; call mdc_$find_volname ((entry.pvid), pvname, lvname, ec); if ec ^= 0 then do; call com_err_ (ec, myname, "^/ Cannot determine vol name for pvid ^w", entry.pvid); lvname, pvname = "-NOT-CLEAR-"; end; goto RETURN; end; end; /* Name not found. Cleanup and return. */ call com_err_ (error_table_$noentry, myname, epname); RETURN: if q ^= null () then call release_temp_segment_ (myname, q, (0)); if rzdp ^= null () then call phcs_$terminate_noname (rzdp, (0)); return; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ trim: proc (ch) returns (fixed bin); dcl ch char (*); dcl x fixed bin; x = verify (reverse (ch), " "); if x ^= 0 then x = length (ch) - x + 1; return (x); end trim; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ m_a: proc (cp, sz); /* This proc is needed to avoid copying a whole directory out, which can, and did one May morning in Phoenix, withdraw a large number of pages against the RLV. Writers of similar programs beware. */ dcl (cp, rgp) ptr, sz fixed bin; rgp = ptr (rzdp, rel (cp)); call phcs_$ring_0_peek (rgp, cp, sz); end m_a; end get_vtocx; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ get_access_class: proc (access_class, code); dcl access_class bit (72) aligned, (class, temp_string) char (336), (class_len, k, kk) fixed bin, short_class char (32), first bit (1), code fixed bin (35); dcl convert_authorization_$to_string_short entry (bit (72) aligned, char (*), fixed bin (35)); dcl convert_aim_attributes_ entry (bit (72) aligned, char (32)); code = 0; call convert_authorization_$to_string_short (access_class, class, code); if code ^= 0 then do; call convert_aim_attributes_ (access_class, short_class); class = rtrim (short_class) || " (invalid)"; end; if class = "" then call ioa_ ("Access Class: system_low"); else do; /* format access class in lines of 50 chars */ class_len = index (class, " ") - 1; if class_len = -1 then class_len = 336; k = 1; first = "1"b; do while ((class_len - k + 1) > 50); temp_string = substr (class, k, 50); kk = length (temp_string) + 1 - index (reverse (temp_string), ","); call ioa_ ("^[Access Class:^; ^] ^a", (first), substr (class, k, kk)); first = "0"b; k = k + kk; end; call ioa_ ("^[Access Class: ^; ^]^a", (first), substr (class, k)); end; end get_access_class; VOLID: procedure (encoded_volid, type); declare encoded_volid bit (36); declare type char (*); declare 1 volid unaligned, 2 name char (2), 2 number fixed bin (18) unsigned; unspec (volid) = encoded_volid; call ioa_ ("Last ^a volume dumped on volume ^a^d", type, volid.name, volid.number); return; end VOLID; page_control_null_address: procedure (fme) returns (char (80) varying); declare fme bit (18) unaligned; declare 1 null_address unaligned, 2 seven_7_7_0 bit (12) unaligned,/* or 377 */ 2 key bit (6); declare kx fixed bin; declare cv_bin_$oct entry (fixed binary (18) uns) returns (character (12) aligned); string (null_address) = fme; kx = bin (null_address.key, 6); if kx < lbound (NULLS, 1) | kx > hbound (NULLS, 1) then return ("Undocumented null address " || rtrim (cv_bin_$oct (bin (fme)))); else return ("Page control null address from " || rtrim (NULLS (kx))); declare NULLS (0:58) char (60) int static options (constant) varying init ("zeros", /* 0 */ (6) (1)"invalid source", /* 1 -> 6 */ "pc$move_page_table_1", /* 7 */ "pc$move_page_table_2", /* 10 */ "get_aste", /* 11 */ "make_sdw", /* 12 */ "put_aste", /* 13 */ (2) (1)"invalid source", /* 15 */ "list_deposit", /* 16 */ "get_file_map", /* 17 */ "fill_page_table", /* 20 */ "init_sst", /* 21 */ "get_file_map_vt", /* 22 */ "unprotected", /* 23 */ "page_bad", /* 24 */ "page_problem", /* 25 */ "page_parity", /* 26 */ "page_devparity", /* 27 */ (34) (1)"invalid source", /* 28 - 53 */ "get_file_map_dumper" /* 72, sort of */); end page_control_null_address; declare flags (0:1) char (1000) varying; /* off, on */ declare line_used (0:1) fixed bin; /* line length used up on cur line */ declare line_length fixed bin; flag$$init: procedure; declare get_line_length_$switch entry (pointer, fixed binary (35)) returns (fixed binary); declare iox_$user_output ptr ext static; line_length = get_line_length_$switch (iox_$user_output, code); if code ^= 0 then line_length = 72; flags (0) = "OFF: "; flags (1) = "ON: "; line_used (*) = 10; /* always prepend space */ return; flag: entry (flag_bit, flag_name); declare flag_bit bit (1) unaligned; declare flag_name char (*); declare flag_bin fixed bin (1); flag_bin = bin (flag_bit, 1); if line_used (flag_bin) + length (flag_name) + 1 > line_length then do; flags (flag_bin) = flags (flag_bin) || byte (10) || copy (" ", 10); /* NL */ line_used (flag_bin) = 10; end; flags (flag_bin) = flags (flag_bin) || " " || flag_name; /* assume trimmed */ line_used (flag_bin) = line_used (flag_bin) + 1 + length (flag_name); return; flag$$display: entry; call ioa_ ("^/^a^/^a^/", flags (1), flags (0)); return; end flag$$init; %page; %include vtoce; %page; %include disk_table; %include null_addresses; %include system_clock_value_; end display_vtoce;  get_astep.alm 01/26/85 1311.6r w 01/22/85 1302.0 7857 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** name get_astep segdef get_astep equ astsize,8 include sst get_astep: epplp ap|2,* get pointer to PTP epbplp lp|0,* and make it into sstp sprilp ap|4,* ldx1 1,du ldx0 ap|2,*1 get relative page table pointer lda =o2,dl eax0 -(astsize-1),0 initialize scan counter eax0 -1,0 cana lp|astsize-1,0 are we at the marker? tze *-2 stx0 ap|4,*1 short_return end  list_vols.pl1 07/20/88 1300.2rew 07/19/88 1523.2 165123 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4,^inddcls */ list_vols: proc; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Initial coding by T. H. VanVleck, 1975. */ /* Modified August 1977 by T. Casey */ /* to add -records, -records_left, and active function processing. */ /* Modified January 1978 by T. Casey */ /* to print short lines to accomodate narrow-carriage terminals. */ /* Modified March 1979 by T. Casey */ /* to fix arg processing bug in -records and -records_left. */ /* Modified February 1982 by JM Stansbury */ /* 1. to output information within 80 columns, */ /* 2. to add "I" flag to indicate PVs inhibited for segment creation, */ /* 3. to add Records/VTOCEs Used reporting capability, */ /* 4. to add percentage used/left figures for Records and VTOCEs, */ /* 5. to add average segment size per PV, */ /* 6. to remove printing of "P" flag indicating partitions. */ /* 7. to allow processing of multiple LVs via the -lv control arg */ /* 8. to add -grand_total, -gtt control arg for command processing. */ /* Modified June 1983 by Art Beattie */ /* 1. to maintain column alignment in displays */ /* 2. fix bug which nulled -lv argument in command line */ /* */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /****^ HISTORY COMMENTS: 1) change(88-03-30,GWMay), approve(88-04-12,MCR7867), audit(88-06-14,Beattie), install(88-07-19,MR12.2-1061): Changed ioa_ call controls to properly align output. END HISTORY COMMENTS */ %page; Ilv = 0; Ptemp (1) = null; Ptemp (2) = null; af_sw = "0"b; entry_name = "list_vols"; given_lvnm (*) = ""; given_pvnm = ""; left_sw = "0"b; used_sw = "0"b; gtt_sw = "0"b; lvsw = "0"b; max_pvname_ln = 7; /* column heading width for PV Name */ nprt = 0; prev_lvnm = ""; pvsw = "0"b; record_sw = "0"b; totfreevtoc = 0; totleft = 0; totrec = 0; totsw = "0"b; totvtoc = 0; error_proc = active_fnc_err_; af_sw = "1"b; /* assume we were called as an active function */ call cu_$af_return_arg (nargs, retp, retl, code); /* but check to be sure */ if code ^= 0 then do; if code = error_table_$not_act_fnc then do; /* if not */ af_sw = ""b; /* we will print the value instead */ error_proc = com_err_; goto get_arg_count; /* go get arg count for command args */ end; else do; /* should never happen, but ... */ call error_proc (code, entry_name); return; end; end; goto get_args; /* go get arguments */ get_arg_count: call cu_$arg_count (nargs); get_args: do an = 1 to nargs; call cu_$arg_ptr (an, argp, argl, code); if code = 0 then do; if bchr = "-lv" then do; pvsw = "0"b; lvsw = "1"b; NEXT_LV: an = an + 1; call cu_$arg_ptr (an, argp, argl, code); if code = error_table_$noarg then do; if given_lvnm (1) = "" then do; /* -lv given with no names */ call error_proc (code, entry_name, "^/-lv must be followed by at least one LV name."); return; end; else goto work; end; if code ^= 0 then goto gape1; if char (bchr, 1) = "-" then goto CHECK_NEXT_ARG; else do; Ilv = Ilv + 1; if Ilv > dim (given_lvnm, 1) then do; call ioa_ (" Number of LVs given is greater than currently supported by this procedure."); return; end; given_lvnm (Ilv) = bchr; if an = nargs then goto work; /* be sure we don't skip any */ end; goto NEXT_LV; end; CHECK_NEXT_ARG: if bchr = "-pv" then do; an = an + 1; call cu_$arg_ptr (an, argp, argl, code); if code ^= 0 then go to gape1; given_pvnm = bchr; pvsw = "1"b; lvsw = "0"b; end; else if bchr = "-tt" | bchr = "-total" | bchr = "-totals" then totsw = "1"b; else if bchr = "-records" | bchr = "-record" | bchr = "-rec" then record_sw = "1"b; else if bchr = "-records_left" | bchr = "-rec_left" | bchr = "-left" then do; used_sw = "0"b; if af_sw then gtt_sw, record_sw, left_sw = "1"b; else left_sw = "1"b; end; else if bchr = "-records_used" | bchr = "-rec_used" | bchr = "-used" then do; left_sw = "0"b; if af_sw then record_sw, used_sw = "1"b; else used_sw = "1"b; end; else if bchr = "-grand_total" | bchr = "-gtt" then if af_sw then do; call error_proc (error_table_$badopt, entry_name, "^a", bchr); return; end; else record_sw, gtt_sw = "1"b; else if char (bchr, 1) ^= "-" then do; lvsw = "1"b; Ilv = 1; /* check for >1 LV name */ if given_lvnm (Ilv) ^= "" then do; if given_lvnm (Ilv) ^= bchr then call error_proc (error_table_$bad_arg, entry_name, "^/Multiple LVs must be preceded by the -lv control argument."); return; end; given_lvnm (Ilv) = bchr; /* default to this lv */ end; else do; /* bad arg */ code = error_table_$badopt; gape: call error_proc (code, entry_name, bchr); return; end; end; else do; gape1: call error_proc (code, entry_name); /* code was ^= 0 */ return; end; end; work: if ^used_sw then left_sw = "1"b; /* default */ if ^af_sw then if record_sw & ^gtt_sw then left_sw = "0"b; if record_sw & (^pvsw | ^lvsw) then do; totsw = "1"b; if af_sw & record_sw then left_sw = "0"b; end; if gtt_sw & record_sw & ^used_sw then left_sw = "1"b; if af_sw & ^record_sw then do; call error_proc (0, entry_name, "^/The -records, -records_left or -records_used argument is required when used as an active function."); goto common_exit; end; on cleanup call clean_out; call get_temp_segments_ (entry_name, Ptemp, code); if Ptemp (1) = null () then do; call error_proc (code, entry_name, "^/Cannot get ptr to temp seg."); return; end; pvtp = Ptemp (1); /* ptr to the PVT */ dtp = Ptemp (2); /* ptr to the disk table */ call ring_zero_peek_$get_max_length ("pvt", pvt_size, code); /* get max number of words */ if code ^= 0 then do; CANNOT_GET_PVT: call error_proc (code, entry_name, "pvt"); call clean_out; return; end; call ring_zero_peek_$by_name ("pvt", 0, pvtp, pvt_size, code); /* obtain pvt contents in user ring */ if code ^= 0 then goto CANNOT_GET_PVT; pvt_arrayp = addr (pvt.array); call mdc_$read_disk_table (dtp, code); /* obtain disk table contents in user ring */ if code ^= 0 then do; call error_proc (code, entry_name, "^/Error from read_disk_table."); return; end; n = dt.n_entries; begin; dcl sindex (n) fixed bin; dcl sname (n) char (32) aligned; sname (*) = ""; if lvsw then do; do Ilv = 1 to dim (given_lvnm, 1) while (given_lvnm (Ilv) ^= ""); do i = 1 to n; if dt.array (i).used then if (given_lvnm (Ilv) = dt.lv_array (dt.array (i).lvx).lvname) then go to end_lvsw_loop; if i = n then do; call error_proc (error_table_$logical_volume_not_defined, entry_name, given_lvnm (Ilv)); goto common_exit; end; end; /* do loop on i */ end_lvsw_loop: end; end; do i = 1 to n; sindex (i) = i; if dt.array (i).lvx > 0 then call ioa_$rsnnl ("^a^a", sname (i), argl, dt.lv_array (dt.array (i).lvx).lvname, dt.drive_name (i)); end; if ^(lvsw | pvsw) | totsw then /* dont sort if only one required */ call idsort_ (sname, sindex, n); Ilv = 1; if ^totsw & ^record_sw then /* if printing both lv and pv names */ do i = 1 to n; /* be nice to users with narrow-carriage terminals */ /* and compute how wide to make the pvname column */ dtep = addr (dt.array (sindex (i))); if dte.used then if (^lvsw | dt.lv_array (dte.lvx).lvname = given_lvnm (Ilv)) & (^pvsw | dte.pvname = given_pvnm) then do; if length (rtrim (dte.pvname)) > max_pvname_ln then max_pvname_ln = length (rtrim (dte.pvname)); if lvsw then Ilv = Ilv + 1; end; end; if ^record_sw then if totsw then call ioa_ (" Records^3x^[Used^;Left^] %^4xVTOCEs^3x^[Used^;Left^] %^3xPB/PD LV Name^/", used_sw, used_sw); else if ^(pvsw | lvsw) | (^totsw & lvsw) then call ioa_ (" ^44xAvg ^va Drive Records^2x^[Used^;Left^] % VTOCEs ^[Used^;Left^] % Size^1x^va^2xPB/PD LV Name^/", max_pvname_ln, "PV", used_sw, used_sw, max_pvname_ln, "Name"); Ilv = 1; loop_thru_pvs: do i = 1 to n; /* go through all physical volumes (pv) */ pvtep = addr (my_pvt_array (sindex (i))); dtep = addr (dt.array (sindex (i))); if dte.used then /* if this entry is used */ if (^lvsw | dt.lv_array (dte.lvx).lvname = given_lvnm (Ilv)) /* and it pertains to a lv that we want */ & (^pvsw | dte.pvname = given_pvnm) then do; /* and it pertains to a pv that we want */ n_vtoce = pvte.n_vtoce; /* obtain number of vtoces */ nprt = nprt + 1; /* remember that we found at least one pv */ if totsw then do; /* if -total (-tt) */ if dt.lv_array (dte.lvx).lvname ^= prev_lvnm then do; /* if current lv ^= previous lv */ /* following 2 lines needed for rounding */ half_totrec = divide (totrec, 2, 35, 0); half_vtoce = divide (totvtoc, 2, 35, 0); if prev_lvnm ^= "" then /* if there was a previous lv, we have totals for it */ if record_sw then goto display_records; /* either display its records */ else do; if used_sw then call ioa_ ("^6d ^6d ^3d ^6d ^6d ^3d ^5a ^a", totrec, totrec - totleft, divide ((totrec - totleft) * 100 + half_totrec, totrec, 35, 0), totvtoc, totvtoc - totfreevtoc, divide ((totvtoc - totfreevtoc) * 100 + half_vtoce, totvtoc, 35, 0), lvflags (prev_lvx), prev_lvnm); else if left_sw then call ioa_ ("^6d ^6d ^3d ^6d ^6d ^3d ^5a ^a", totrec, totleft, divide ((totleft) * 100 + half_totrec, totrec, 35, 0), totvtoc, totfreevtoc, divide ((totfreevtoc) * 100 + half_vtoce, totvtoc, 35, 0), lvflags (prev_lvx), prev_lvnm); end; if ^record_sw then do; /* if we get here with record_sw on, we are totaling all vols */ prev_lvx = dte.lvx; /* remember lvx of new lv */ prev_lvnm = dt.lv_array (prev_lvx).lvname; /* remember name of new lv */ totrec, totleft, totvtoc, totfreevtoc = 0; /* zero the lv totals */ end; end; totrec = totrec + pvte.totrec; /* add pv figures to lv totals */ totleft = totleft + pvte.nleft; totvtoc = totvtoc + n_vtoce; totfreevtoc = totfreevtoc + pvte.n_free_vtoce; end; else do; /* not -tt, so print for each pv */ if record_sw then do; /* or, if entered at records entry, just one pv */ totleft = pvte.nleft; goto display_records; end; if pvte.device_inoperative then flag = "X"; else flag = " "; if pvte.vacating then flag1 = "I"; else flag1 = " "; half_totrec = divide (pvte.totrec, 2, 35, 0); half_vtoce = divide (n_vtoce, 2, 35, 0); /* will need this for rounding */ if used_sw then do; call ioa_ ("^8a^1a^1a^5d ^5d ^3d ^6d ^5d ^3d ^4d ^va ^5a ^a", dte.drive_name, flag, flag1, pvte.totrec, pvte.totrec - pvte.nleft, /* following is for rounded record percentage */ divide ((pvte.totrec - pvte.nleft) * 100 + half_totrec, pvte.totrec, 35, 0), n_vtoce, n_vtoce - pvte.n_free_vtoce, /* following is for rounded vtoce percentage */ divide ((n_vtoce - pvte.n_free_vtoce) * 100 + half_vtoce, n_vtoce, 35, 0), (pvte.totrec - pvte.nleft) / max (1, (n_vtoce - pvte.n_free_vtoce)), max_pvname_ln, dte.pvname, lvflags ((dte.lvx)), dt.lv_array (dte.lvx).lvname); end; /* end rec_used */ if left_sw then do; call ioa_ ("^8a^1a^1a^5d ^5d ^3d ^6d ^5d ^3d ^4d ^va ^5a ^a", dte.drive_name, flag, flag1, pvte.totrec, pvte.nleft, divide ((pvte.nleft) * 100 + half_totrec, pvte.totrec, 35, 0), n_vtoce, pvte.n_free_vtoce, divide ((pvte.n_free_vtoce) * 100 + half_vtoce, n_vtoce, 35, 0), (pvte.totrec - pvte.nleft) / max (1, (n_vtoce - pvte.n_free_vtoce)), max_pvname_ln, dte.pvname, lvflags ((dte.lvx)), dt.lv_array (dte.lvx).lvname); end; /* end rec_left */ end; /* end not -tt */ end; /* end pv is of interest */ end; /* end loop thru all pv's */ /* see if there are more lv's to do */ if lvsw then do; Ilv = Ilv + 1; if given_lvnm (Ilv) ^= "" then /* there are more... */ goto loop_thru_pvs; end; end; /* end begin block */ if nprt = 0 then do; if lvsw then call error_proc (error_table_$logical_volume_not_defined, entry_name, given_lvnm (Ilv - 1)); else if pvsw then call error_proc (error_table_$pvid_not_found, entry_name, given_pvnm); end; else if record_sw then goto display_records; else if totsw then do; half_totrec = divide (totrec, 2, 35, 0); half_vtoce = divide (totvtoc, 2, 35, 0); if used_sw then call ioa_ ("^6d ^6d ^3d ^6d ^6d ^3d ^5a ^a^/", totrec, totrec - totleft, divide ((totrec - totleft) * 100 + half_totrec, totrec, 35, 0), totvtoc, totvtoc - totfreevtoc, divide ((totvtoc - totfreevtoc) * 100 + half_vtoce, totvtoc, 35, 0), lvflags (prev_lvx), prev_lvnm); else if left_sw then call ioa_ ("^6d ^6d ^3d ^6d ^6d ^3d ^5a ^a^/", totrec, totleft, divide ((totleft) * 100 + half_totrec, totrec, 35, 0), totvtoc, totfreevtoc, divide ((totfreevtoc) * 100 + half_vtoce, totvtoc, 35, 0), lvflags (prev_lvx), prev_lvnm); /* print totals accumulated for last lv */ end; else call ioa_ (""); common_exit: call clean_out; return; /* Come back here to print or return a single records left figure */ display_records: if left_sw then totrec = totleft; /* display records left if that's what user wants */ if used_sw then totrec = totrec - totleft; /* display records used if that's what uer wants */ if af_sw then do; call ioa_$rsnnl ("^d", char7, i, totrec); ret = substr (char7, 1, i); end; else call ioa_ ("^d", totrec); goto common_exit; lvflags: proc (lvx) returns (char (5)); dcl lvx fixed bin; dcl retstr char (5) init (""); if dt.lv_array (lvx).public then substr (retstr, 1, 2) = "pb"; if dt.lv_array (lvx).pdirs_ok then substr (retstr, 4, 2) = "pd"; return (retstr); end lvflags; %page; clean_out: proc; if Ptemp (1) ^= null () then call release_temp_segments_ (entry_name, Ptemp, code); Ptemp (1) = null (); end clean_out; %page; /* A U T O M A T I C */ dcl Ilv fixed bin, Ptemp (2) ptr, /* ptrs for temp segs */ af_sw bit (1), an fixed bin, argl fixed bin, argp ptr, char7 char (7), code fixed bin (35), entry_name char (12), flag char (1), flag1 char (1), given_lvnm (10) char (32), /* array of LV names, to allow >1 */ given_pvnm char (32), gtt_sw bit (1), half_totrec fixed bin (35), half_vtoce fixed bin (35), i fixed bin, left_sw bit (1), lvsw bit (1), max_pvname_ln fixed bin, n fixed bin, n_vtoce fixed bin, nargs fixed bin, nprt fixed bin, prev_lvnm char (32), prev_lvx fixed bin, pvsw bit (1), pvt_size fixed bin (19), record_sw bit (1), retl fixed bin, retp ptr, totfreevtoc fixed bin (35), totleft fixed bin (35), totrec fixed bin (35), totsw bit (1), totvtoc fixed bin (35), used_sw bit (1); /* E N T R Y V A R I A B L E */ dcl error_proc entry variable automatic options (variable); /* C O N D I T I O N */ dcl cleanup condition; /* B A S E D */ dcl bchr char (argl) based (argp), 1 my_pvt_array (pvt.max_n_entries) aligned like pvte based (pvt_arrayp), ret char (retl) varying based (retp); /* active function return arg */ /* E X T E R N A L E N T R I E S */ dcl active_fnc_err_ entry options (variable), com_err_ entry options (variable), cu_$af_return_arg entry (fixed bin, ptr, fixed bin, fixed bin (35)), cu_$arg_count entry (fixed bin), cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)), get_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)), idsort_ entry ((*) char (32) aligned, (*) fixed bin, fixed bin), ioa_ entry options (variable), ioa_$rsnnl entry options (variable), mdc_$read_disk_table entry (ptr, fixed bin (35)), release_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)), ring_zero_peek_$by_name entry (char (*), fixed bin (18), ptr, fixed bin (19), fixed bin (35)), ring_zero_peek_$get_max_length entry (char (*), fixed bin (19), fixed bin (35)); /* E X T E R N A L S T A T I C */ dcl (error_table_$bad_arg, error_table_$badopt, error_table_$logical_volume_not_defined, error_table_$noarg, error_table_$not_act_fnc, error_table_$pvid_not_found) fixed bin (35) ext static; /* B U I L T I N */ dcl (addr, char, dim, divide, length, max, null, rtrim, substr) builtin; %page; %include disk_table; %page; %include pvt; %page; %include pvte; end list_vols;  print_apt_entry.pl1 08/22/88 1303.4rew 08/22/88 1301.8 309024 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* DESCRIPTION: Prints the apt entry. */ /****^ HISTORY: Written by unknown, sometime. Modified: 06/01/78 by T. Casey: to add several new control args, print more info for -brief, and always print channel and person. 06/01/81 by T. Casey: to fix it up for installation, and add process_id active function. 11/01/81 by E. N. Kittlitz: user_table_entry conversion. 06/30/83 by E. A. Ranzenbach: for processor subset changes. 07/30/84 by R. Michael Tague: IPS name lengths were changed from 4 chars to 32. Added dm_shutdown_warning_ and dm_user_shutdown_ signals. 08/22/84 by R. Michael Tague: Removed dm_shutdown_warning_ and dm_user_shutdown_ IPS signals. Added system_shutdown_scheduled_ and dm_shutdown_scheduled_ IPS signals. Modified November 1984 by M. Pandolf to include hc_lock. 12/10/84 by E. Swenson for new IPC variables. */ /****^ HISTORY COMMENTS: 1) change(87-04-26,GDixon), approve(87-07-13,MCR7741), audit(87-07-24,Brunelle), install(87-08-04,MR12.1-1055): Upgraded for change to answer_table.incl.pl1 and user_table_entry.incl.pl1 2) change(87-07-24,GDixon), approve(87-07-24,MCR7741), audit(87-07-24,Brunelle), install(87-08-04,MR12.1-1055): A) Correct stringsize errors. 3) change(87-11-03,GDixon), approve(88-08-08,MCR7960), audit(88-08-09,Lippard), install(88-08-22,MR12.2-1088): A) Add process lock-id to normal pae output, to aid in debugging locking problems. (phx13768) B) Avoid referencing apte elements via the f array; reference them by name instead. Use the f array only to display the apte in octal. C) Split lengthy output lines to avoid breaking across line boundary. 4) change(88-07-26,Lippard), approve(88-08-08,MCR7960), audit(88-08-16,Farley), install(88-08-22,MR12.2-1088): Use user's default time zone instead of system default. (Hardcore 1014, 1026). Make pae -absentee print APTEs for the user's absentee processes (instead of the user's own APTE). (Hardcore 1061) END HISTORY COMMENTS */ /* format: style4 */ print_apt_entry: pae: proc; /* DECLARATIONS */ /* Automatic and based variables */ /* based, and pointers, lengths, and things they're based on */ dcl ap ptr; dcl al fixed bin; dcl bchr char (al) based (ap); dcl f (0:size (apte) - 1) fixed bin (35) based (aptep); dcl proc_id bit (36) aligned; dcl procid fixed bin (35) aligned based (addr (proc_id)); dcl temp_date_time char (16); /* mm/dd/yy HHMM.M */ dcl temp_date char (8) based (addr (temp_date_time)); /* mm/dd/yy */ dcl first_17_flags (17) bit (1) unaligned based (addr (apte.flags)); dcl flag18 bit (1) unaligned based (addr (apte.flags.firstsw)); dcl return_ptr ptr; dcl return_len fixed bin; dcl return_string char (return_len) varying based (return_ptr); /* active function return string */ /* switches */ dcl display_mode fixed bin init (2); /* 0= -no_display, 1= -brief_display, 2= -display */ dcl (af_sw, apte_offset_sw, as_sw, chn_sw, dmn_sw, dump_sw, ia_sw, id_sw, multiple_sw, pae_sw, pdir_sw, pid_sw, process_id_sw, short_sw, term_channel_sw, user_sw) bit (1) aligned init (""b); /* fixed bin */ dcl (total_matched, this_id_matched) fixed bin; dcl argno fixed bin; dcl nargs fixed bin; dcl ids fixed bin init (0); dcl code fixed bin (35); dcl i fixed bin; dcl apte_offset fixed bin (18); dcl alrm fixed bin (71); dcl now fixed bin (71); dcl cpu_mon fixed bin (71) init (0); /* character strings */ dcl pers char (24); dcl proj char (12); dcl tag char (1); dcl channel char (32); dcl pers_arg char (23) varying; dcl proj_arg char (10) varying; dcl tag_arg char (2) varying; dcl today char (8); dcl c32 char (32); dcl (flags, ips_pending) char (256) varying init (""); dcl segname char (32); dcl me char (16); /* structures */ dcl 1 tc_data like apte aligned; /* place in stack to put one APTE */ /* Internal static constants */ dcl state_names (0:6) char (8) int static options (constant) init ("Empty", "Running", "Ready", "Waiting", "Blocked", "Stopped", "Ptl_wait"); dcl flag_names (17) char (16) int static options (constant) init ("mbz1", "wakeup_waiting", "stop_pending", "pre-empted", "hproc", "loaded", "eligible", "idle", "interaction", "pre-empt_pending", "default_proc_set", "realtime_burst", "always_loaded", "dbr_loaded", "being_loaded", "shared_stack_0", "page_wait"); dcl sysdir char (168) int static options (constant) init (">system_control_1"); dcl CAPS char (26) int static options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"); /* Internal static variables */ dcl apte1_offset fixed bin int static init (0); dcl (static_ansp, static_dutp, tcdp0, static_autp) ptr static; dcl (tables_initiated, tcd_initiated) bit (1) aligned int static init (""b); /* External static variables */ dcl error_table_$badopt ext fixed bin (35); dcl error_table_$inconsistent ext fixed bin (35); dcl error_table_$not_act_fnc ext fixed bin (35); /* Entries, external constant, and variable */ dcl err_proc variable entry options (variable); /* com_err_ or active_fnc_err_ */ dcl active_fnc_err_ entry options (variable); dcl com_err_ entry options (variable); dcl cu_$af_return_arg entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl date_time_ entry (fixed bin (71), char (*)); dcl date_time_$format entry (char (*), fixed bin (71), char (*), char (*)) returns (char (250) var); dcl get_group_id_ entry returns (char (32)); dcl get_line_length_$switch entry (ptr, fixed bin (35)) returns (fixed bin); dcl get_process_id_ entry returns (bit (36)); dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl ioa_ entry options (variable); dcl ioa_$rsnnl entry options (variable); dcl match_star_name_ entry (char (*), char (*), fixed bin (35)); dcl ring0_get_$segptr entry (char (*) aligned, char (*) aligned, ptr, fixed bin (35)); dcl ring_zero_peek_ entry (ptr, ptr, fixed bin, fixed bin (35)); dcl unique_chars_ entry (bit (*) aligned) returns (char (15)); dcl user_info_$terminal_data entry (char (*), char (*), char (*)); /* Builtin */ dcl (addr, after, before, bin, clock, divide, fixed, hbound, index, lbound, length, log10, ltrim, max, mod, null, ptr, rel, rtrim, search, size, string, substr, unspec) builtin; /* This is the pae entry point */ pae_sw = "1"b; me = "print_apt_entry"; goto af_common; /* go see if we're a command or an active function */ process_id: entry; process_id_sw = "1"b; me = "process_id"; af_common: call cu_$af_return_arg (nargs, return_ptr, return_len, code); if code = 0 then do; /* active function */ af_sw = "1"b; err_proc = active_fnc_err_; end; else if code = error_table_$not_act_fnc then do; /* command */ af_sw = ""b; err_proc = com_err_; end; else do; /* some other code - something is wrong */ call com_err_ (code, me); return; end; /* Initialize entry-point-dependent defaults before looking at control args */ if process_id_sw | af_sw then multiple_sw = ""b; /* default for process_id and [pae] is one process */ else multiple_sw = "1"b; /* default for pae is multiple processes */ /* Initialize offset of Initializer's APTE */ if apte1_offset = 0 then apte1_offset = size (tcm) - 1; /* Look at control arguments */ do argno = 1 to nargs; call cu_$arg_ptr (argno, ap, al, code); /* this works for both commands and active functions */ if code ^= 0 then do; call err_proc (code, me); return; end; if substr (bchr, 1, 1) ^= "-" then /* if this is an ID */ ids = ids + 1; /* count it, and skip it until next pass thru arg list */ /* Check for control arguments common to both entry points */ else if bchr = "-ia" | bchr = "-interactive" then ia_sw = "1"b; else if bchr = "-as" | bchr = "-abs" | bchr = "-absentee" then as_sw = "1"b; else if bchr = "-dmn" | bchr = "-daemon" then dmn_sw = "1"b; else if bchr = "-only" then ia_sw, as_sw, dmn_sw = ""b; else if bchr = "-all" | bchr = "-a" then ia_sw, as_sw, dmn_sw = "1"b; else if bchr = "-single" then multiple_sw = ""b; else if bchr = "-multiple" then multiple_sw = "1"b; else if bchr = "-user" | bchr = "-chn" | bchr = "-channel" | bchr = "-pid" | bchr = "-process_id" then do; /* if next argument is an ID */ argno = argno + 1; /* skip over it this time thru arglist */ ids = ids + 1; /* count ID args */ end; /* Check for control arguments accepted only by pae */ else if pae_sw then do; if bchr = "-dump" then dump_sw = "1"b; else if bchr = "-no_dump" then dump_sw = ""b; else if bchr = "-sh" | bchr = "-short" then short_sw = "1"b; else if bchr = "-lg" | bchr = "-long" then short_sw = ""b; else if bchr = "-dpy" | bchr = "-display" then display_mode = 2; else if bchr = "-bfdpy" | bchr = "-brief_display" then display_mode = 1; else if bchr = "-ndpy" | bchr = "-no_display" then display_mode = 0; else if bchr = "-pd" | bchr = "-pdir" | bchr = "-process_dir" | bchr = "-process_directory" then pdir_sw = "1"b; else if bchr = "-tchn" | bchr = "-term" | bchr = "-term_chn" | bchr = "-term_channel" then term_channel_sw = "1"b; else goto badopt; end; /* end pae args */ else do; badopt: call err_proc (error_table_$badopt, me, "^a", bchr); return; end; end; /* end first pass thru argument list */ /* Now, see what args were given, check legality, and apply defaults */ if pdir_sw | term_channel_sw /* if returning pdir or term channel */ then pae_sw = ""b; /* then we're not going to print the APTE */ if pae_sw & af_sw then do; /* can't return a whole APTE */ call err_proc (0, me, "No APTE item specified."); return; end; if pdir_sw & term_channel_sw then do; /* if both given, complain */ call err_proc (error_table_$inconsistent, me, "-process_dir and -term_channel"); return; end; if ids > 1 then multiple_sw = "1"b; /* single only makes sense with one ID */ /* Initialize only what is needed for what we've been asked to do */ if pae_sw then do; /* if printing APTE, get date and time */ now = clock (); call date_time_ (now, temp_date_time); /* format current date and time */ today = temp_date; /* copy mm/dd/yy */ end; if ids > 0 then /* if no IDs given, we're doing it for this process */ call table_init; /* otherwise we need pointers to the user tables */ /* (all users do not have access, so only try if needed) */ if pae_sw | term_channel_sw then /* if printing APTE or returning term channel */ call tcd_init; /* we'll need to look in tc_data */ aptep = addr (tc_data); /* get pointer to temporary storage */ id_sw = ""b; total_matched, this_id_matched = 0; /* If no ID arguments given, do it for the current process */ if ids = 0 then do; id_sw = valid_id (rtrim (get_group_id_ ())); /* get User_ID */ pers = pers_arg; /* copy components of user_ID */ proj = proj_arg; tag = tag_arg; if ia_sw | as_sw | dmn_sw then do; tag_arg = "*"; call table_init; call print_matching_processes (rtrim (pers_arg) || "." || rtrim (proj_arg) || "." || tag_arg); return; end; call user_info_$terminal_data ((""), (""), channel); /* and channel */ proc_id = get_process_id_ (); call print_it; /* either print APTE, or return something */ return; end; if ^(ia_sw | as_sw | dmn_sw) then /* if none of -ia -as -dmn given */ ia_sw, as_sw, dmn_sw = "1"b; /* default is all three */ /* There were IDs given. Go back thru the argument list and look for them. */ do argno = 1 to nargs; /* go thru args again to process user and channel names */ call cu_$arg_ptr (argno, ap, al, code); /* ignore code this time around */ if ^id_sw /* if previous arg wasn't -user, -chn, or -pid, */ & substr (bchr, 1, 1) = "-" then do; /* and this is a control arg, see if it's one of those */ if bchr = "-user" then user_sw, id_sw = "1"b; else if bchr = "-chn" | bchr = "-channel" then chn_sw, id_sw = "1"b; else if bchr = "-pid" | bchr = "-process_id" then pid_sw, id_sw = "1"b; else user_sw, chn_sw, pid_sw, id_sw, apte_offset_sw = ""b; /* if not_sw,clear all the switches */ end; /* end previous arg not -user, -chn or -pid */ else if id_sw /* if previous arg was one of the above */ | substr (bchr, 1, 1) ^= "-" then do; /* or if this one is not a control arg */ /* treat it as an ID arg */ this_id_matched = 0; /* we'll count processes that match this ID */ if valid_id (bchr) then do; /* if ID is legal, search user tbales for match */ /* (if it's not legal, valid_id prints an error message) */ call print_matching_processes ((bchr)); end; /* end valid ID */ id_sw = ""b; /* clear this, in case it was on for this ID argument */ end; /* end ID argument */ total_matched = total_matched + this_id_matched; /* count total matches */ end; /* end second pass thru argument list */ /* If we're a command, or an active function with just one ID argument, we already reported on failure of any process to match the ID(s), But if we're an active function with multiple IDs, we could get here without matching any processes or putting anything in the return string. We'll complain about that, rather then quietly returning a null string. */ if af_sw & ids > 1 & total_matched = 0 then call err_proc (0, me, "The given identifiers did not match any processes."); MAIN_RETURN: return; /* Come here from internal procedures if unable to get pointers to user tables or tc_data */ init_error: call err_proc (code, me, "Cannot get ptr to ^a", segname); return; match_ute: proc returns (bit (1) aligned); dcl ec fixed bin (35); if chn_sw then do; /* -chn ID or ID with no uppercase letters * */ call match_star_name_ ((ute.tty_name), (bchr), ec); if ec = 0 then goto matched; end; else if user_sw then do; /* -user ID or ID containing uppercase letters */ call match_star_name_ ((ute.person), (pers_arg), ec); if ec = 0 then do; /* person matched; check project */ call match_star_name_ ((ute.project), (proj_arg), ec); if ec = 0 then do; /* project matched; check tag */ if tag_arg ^= "m" & tag_arg ^= "p" /* only for two kinds of absentee tags */ then goto matched; /* since main loop does process type checking */ if ute.proxy then /* if this process is proxy */ if tag_arg = "p" then goto matched; else ; /* it wasn't "p" so don't goto matched */ else /* this process is not proxy */ if tag_arg = "m" then goto matched; end; /* end project matched */ end; /* end person matched */ end; else if pid_sw then do; /* -pid ID, or octal ID */ if ute.proc_id = proc_id then goto matched; if apte_offset_sw then if substr (ute.proc_id, 1, 18) = substr (proc_id, 1, 18) then goto matched; end; return (""b); matched: /* Copy stuff out of the answer table entry */ proc_id = ute.proc_id; proj = ute.project; pers = ute.person; channel = ute.tty_name; if ute.queue = -1 then /* daemon */ tag = "z"; else if ute.queue = 0 & ^ute.adjust_abs_q_no then /* interactive */ tag = "a"; else /* absentee */ if ute.proxy then /* proxy absentee */ tag = "p"; else tag = "m"; /* normal absentee */ return ("1"b); end match_ute; print_it: proc; /* We call this procedure either to print the whole APTE, or to print or return one value from it. */ dcl fxl fixed bin; /* length of dump lines, either 4 or 8 words */ dcl fxp ptr; /* pointer to first word in line */ dcl fx (fxl) fixed bin (35) based (fxp); /* array of 4 or 8 words in dump line */ dcl i fixed bin; dcl integer_len fixed bin; /* length of integer part of float nums */ dcl l fixed bin; /* for octal dump, index of first APTE word in dump line */ dcl line_len fixed bin; /* terminal line length */ this_id_matched = this_id_matched + 1; /* count processes matching the ID */ if this_id_matched > 1 then /* if this is the 2nd (or more) match for this ID */ if ^multiple_sw /* and the user only wanted one */ then return; /* don't print or return any more */ if pae_sw | term_channel_sw | apte_offset_sw then do; /* if we need to look in the APTE */ tcdp0 = ptr (tcdp0, substr (proc_id, 1, 18));/* generate pointer to APTE in ring 0 */ call ring_zero_peek_ (tcdp0, aptep, size (apte), code); /* copy the data out */ if code ^= 0 then do; call err_proc (code, me, "from ring_zero_peek_"); return; end; if apte_offset_sw then /* if just apt offset given */ unspec (procid) = apte.processid; /* copy full procid out of apt entry */ end; /* end we need to look in the APTE */ if pae_sw | pdir_sw then do; /* if we need the process directory name, get it */ apte_offset = divide (procid, 2 ** 18, 18, 0); if apte_offset = apte1_offset then /* special case the Initializer's pdir name */ c32 = ">pdd>!zzzzzzzbBBBBBB"; /* it is unique_chars_ (777777777777) */ else c32 = ">pdd>" || unique_chars_ (proc_id); /* all other pdir names come from process id */ end; /* end we need pdir name */ /* If we didn't need the pdir name, the user must have asked for either process_id or term_channel */ else if process_id_sw then /* if process id wanted */ call ioa_$rsnnl ("^w", c32, (0), procid); /* format it */ else if term_channel_sw then /* if process termination event channel wanted */ call ioa_$rsnnl ("^24.3b", c32, (0), unspec (apte.term_channel)); /* format it */ /* Now, if we're not the pae command, we either return or print an active function value */ if af_sw then do; /* active function */ if length (return_string) > 0 then /* if there's anything in the return string */ return_string = return_string || " "; /* put a blank after it */ return_string = return_string || rtrim (c32);/* put the return value in it */ return; /* return to the main loop */ end; else if ^pae_sw then do; /* if not pae, print what the A/F would have returned */ call ioa_ ("^a", c32); return; end; /* If it was pae, fall thru and print the APTE */ /* First, the heading */ line_len = get_line_length_$switch (null, code); call ioa_ ("^/^a.^a.^a ^a at ^o in tc_data, ^a", pers, proj, tag, channel, fixed (rel (tcdp0), 18), c32); /* Print line 1 unless -no_display */ if display_mode > 0 then call ioa_ ("^[FLAGS: ^w^2x^;^s^]^[EVENT: ^w^2x^;^s^]PID: ^w^2xLOCK_ID: ^w^[^2x^; ^]TRM CHN: ^w ^w", (display_mode < 2), unspec (apte.flags), (apte.wait_event ^= ""b), apte.wait_event, apte.processid, apte.lock_id, bin (display_mode < 2) * length ("FLAGS: oooooooooooo ") + bin (apte.wait_event ^= ""b) * length ("EVENT: oooooooooooo ") + length ("PID: oooooooooooo LOCK_ID: oooooooooooo ") + length ("TRM CHN: oooooooooooo oooooooooooo") <= line_len, substr (unspec (apte.term_channel), 1, 36), substr (unspec (apte.term_channel), 37, 36)); if display_mode = 2 then do; /* -display */ /* -display: print the following three lines (stuff in [] only if interesting): 2) for (since ]). Usage: cpu ; vcpu ; pf . 3) te/s/i/x: E S I X.[ pending.][ Flags: .] 4) [Alarm in (at