rcp_cancel.pl1                  11/15/82  1857.3rew 11/15/82  1521.9       26856



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


rcp_cancel:
     proc ();

/*
   D_E_S_C_R_I_P_T_I_O_N_

   This command should only be used by the operator or somebody
   with access to rcp_sys_.  It takes two arguments, a reservation id
   and the group id of the user owning the reservation and cancels
   the reservation.  Only one reservation for one user may be cancelled
   per call.


   J_O_U_R_N_A_L_I_Z_A_T_I_O_N_

   1) Written 2/79 by R.J.C. Kissel.
*/
	
dcl  res_id char (19);				/* The reservation id to cancel. */
dcl  group_id char (32);				/* Group id of the user owning the reservation. */
dcl  code fixed bin (35);

dcl  num_args fixed bin;				/* Nunber of arguments. */
dcl  arg_num fixed bin;				/* Argument loop index. */

dcl  arg_len fixed bin;
dcl  arg_ptr ptr;
dcl  arg char (arg_len) based (arg_ptr);

dcl  com_err_ entry options (variable);
dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  rcp_sys_$cancel_id_string
     entry (char (*), char (*), fixed bin (35));
	
dcl  error_table_$wrong_no_of_args
     fixed bin (35) external;
dcl  error_table_$bad_arg
     fixed bin (35) external;

	call cu_$arg_count (num_args);

	if num_args < 4 | num_args > 5
	then goto ERROR_usage;

	res_id = "";
	group_id = "";

	do arg_num = 1 to num_args;
	     call cu_$arg_ptr (arg_num, arg_ptr, arg_len, code);
	     if code ^= 0
	     then goto ERROR_arg;

	     if arg = "cancel"
	     then ;				/* Ignore this. */

	     else if arg = "-id"
	     then do;
		arg_num = arg_num + 1;
		call cu_$arg_ptr (arg_num, arg_ptr, arg_len, code);
		if code ^= 0
		then goto ERROR_arg;

		res_id = arg;
	     end;

	     else if arg = "-user"
	     then do;
		arg_num = arg_num + 1;
		call cu_$arg_ptr (arg_num, arg_ptr, arg_len, code);
		if code ^= 0
		then goto ERROR_arg;

		group_id = arg;
	     end;

	     else goto ERROR_badarg;
	end;

	if res_id = "" | group_id = ""
	then goto ERROR_usage;

	call rcp_sys_$cancel_id_string (res_id, group_id, code);
	if code ^= 0
	then goto ERROR_cancel;

	return;

ERROR_usage:
	call com_err_ (error_table_$wrong_no_of_args, "rcp_cancel", "Usage is: rcp cancel -id STR -user STR");
	return;

ERROR_arg:
	call com_err_ (code, "rcp_cancel", "Argument number ^d.", arg_num);
	return;

ERROR_badarg:
	call com_err_ (error_table_$bad_arg, "rcp_cancel", "^a", arg);
	return;

ERROR_cancel:
	call com_err_ (code, "rcp_cancel", "Cancellation not performed.");
	return;

     end rcp_cancel;




		    rcp_list.pl1                    03/25/86  1206.6rew 03/25/86  1206.4      189243



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */



/****^  HISTORY COMMENTS:
  1) change(85-09-09,Fawcett), approve(85-09-09,MCR6979),
     audit(85-12-19,CLJones):
     Support for MCA.
                                                   END HISTORY COMMENTS */
rcp_list: procedure;

/*	This program is a command that lists data copied from RCP.
   *	Created on 12/26/74 by Bill Silver.
   *	Modified on 04/10/78 by Michael R. Jordan to add -unattached as part of preloaded volume effort.
   *	Modified on 12/09/78 by Michael R. Jordan to add -reserved and speed qualifier for tapes.
   *	Modified 3/79 by Michael R. Jordan for MR7.0R.
   *      Modified 1984-09-19 stop using decimal_date_time_. JAFalksen
   *	Modified 1985-02-07 add support or the MCA (the 8th device)
   *	In order to use this command one must have access to the gate rcp_sys_.
   *	If this command is called with no arguments it will type out information
   *	obtained from RCP for all devices of all types.  Note, the formline_ control
   *	"^-" is not used since this command will usually be executed via system_control_
   *	and the message coordinator.
   *	The following arguments are valid:
   *
   *	(list)		Ignored.  Needed by system control when called by operator.
   *	(-long)   (-lg)	Type all info known about device or device type.
   *	(-type)   (-tp)	Type info about all devices of this one type.
   *	(-device) (-dv)	Type info about this one ddevice.
   *	(-mounts) (-mnt)	List pending mount requests.
   *	(-unattached) (-unat) List unattached, but loaded volumes.
   *	(-reserved) (-resv)	List information about reservations.
*/

/*		AUTOMATIC  DATA		*/

	dcl     arg_len		 fixed bin;	/* Length of argument. */
	dcl     arg_ptr		 ptr;		/* Pointer to current argument. */
	dcl     argx		 fixed bin;	/* Number  of current argument. */
	dcl     density_comment	 char (30) varying; /* Used to print density capabilities. */
	dcl     density_ptr		 ptr;		/* Pointer to density characteristics. */
	dcl     device_name		 char (32);	/* Device name. */
	dcl     device_type		 char (32);	/* Device type name. */
	dcl     dtypex		 fixed bin;	/* Device type index. */
	dcl     ecode		 fixed bin (35);	/* error_table_ code. */
	dcl     (i, j)		 fixed bin;	/* Work variables. */
	dcl     list_index		 fixed bin;	/* Used to decide what to type. */
	dcl     long_flag		 bit (1);		/* ON => type everything we can. */
	dcl     max_copy_size	 fixed bin (19);	/* Max size of copy buffer. */
	dcl     num_args		 fixed bin;	/* Number of command arguments. */
	dcl     num_mounts		 fixed bin;	/* Number of pending mount requests */
	dcl     num_reserved	 fixed bin;	/* Number of resources reserved. */
	dcl     num_unattached	 fixed bin;	/* Number of unattached, loaded volumes. */
	dcl     option		 char (12);	/* Command option name. */
	dcl     option_code		 fixed bin;	/* Used to describe option's value argument. */
	dcl     speed_comment	 char (30) varying; /* Used to print speed capabilities. */
	dcl     speed_ptr		 ptr;		/* Pointer to speed qualifier for tape drives. */
	dcl     time_string		 char (24);	/* used to print out state time. */
	dcl     volume_name		 char (32);

/*		BASED  DATA		*/

	dcl     argument		 char (arg_len) based (arg_ptr); /* Used to reference command argument. */

	dcl     based_density	 bit (5) based (density_ptr) aligned;

	dcl     based_speed		 bit (3) based (speed_ptr) aligned;


/*		INTERNAL STATIC DATA	*/

	dcl     temp_seg_ptr	 ptr /* Pointer to rcp_list_seg. */
				 internal static init (null ());

	dcl     brief_options	 (7) char (5) /* Brief form of command options. */
				 internal static init ("ls", "-lg", "-tp", "-dv", "-mnt", "-unat", "-resv");

	dcl     long_options	 (7) char (12) /* Long form of command options. */
				 internal static init ("list", "-long", "-type", "-device", "-mounts", "-unattached", "-reserved");

	dcl     option_codes	 (7) fixed bin /* 0 => no value arg,  1 => value arg. */
				 internal static init (0, 0, 1, 1, 0, 0, 0);

	dcl     device_states	 (0:4) char (15) /* States of an RCPD device entry. */
				 internal static init ("free", "assigned", "deleted", "storage system", "reserved");

	dcl     density_names	 (5) char (5) varying /* Descriptions of tape densities. */
				 internal static init ("200 ", "556 ", "800 ", "1600 ", "6250 ");

	dcl     speed_names		 (3) char (4) varying /* Tape drive speed names. */
				 internal static init ("75 ", "125 ", "200 ");


/*		EXTERNAL ENTRIES CALLED	*/

	dcl     (addr, hbound, index, null, substr) builtin;

	dcl     (error_table_$badopt,
	        error_table_$name_not_found,
	        error_table_$odd_no_of_args,
	        error_table_$wrong_no_of_args) fixed bin (35) external;

	dcl     sys_info$time_correction_constant fixed bin (71) ext;

	dcl     com_err_		 entry options (variable);
	dcl     cu_$arg_count	 entry (fixed bin);
	dcl     cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin, 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     hcs_$make_seg	 entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
	dcl     ioa_		 entry options (variable);
	dcl     rcp_sys_$copy_data	 entry (ptr, fixed bin (19), fixed bin (35));
	dcl     resource_info_$get_dtypex entry (char (*), char (*), fixed bin, fixed bin (35));
%page;
%include rcp_data_info;
%page;
%include console_device_specs;
%page;
/*	Beginning of the rcp_list command.
*/
	ecode,					/* Initialize. */
	     list_index = 0;
	long_flag = "0"b;
	max_copy_size = 64 * 1024;			/* For now just some big number. */

	call cu_$arg_count (num_args);		/* Get number of command arguments. */

	do argx = 1 to num_args;			/* Look at each one of them. */
	     call PROCESS_ARG;			/* Go process this argument. */
	     if ecode ^= 0				/* Was there an error with this argument? */
	     then return;				/* Yes, abort the command. */
	end;

	if temp_seg_ptr = null ()			/* Do we have a temp seg yet? */
	then do;					/* No, get one now. */
		call hcs_$make_seg ("", "rcp_list_seg", "", 01010b, temp_seg_ptr, ecode);
		if temp_seg_ptr = null ()		/* Segment should be there */
		then do;				/* But it wasn't. */
			call com_err_ (ecode, "rcp_list", "Error making rcp_list_seg.");
			return;
		     end;
	     end;

/*	We will call RCP to copy data from RCP into our buffer segment.
   *	What we output depends upon the long_flag and the list_index.
   *	The following values are used.
   *	     0.	Output header and all devices of all types.
   *	     1.	All devices of specified type.
   *	     2.	The specified ddevice.
*/
	rdi_ptr = temp_seg_ptr;			/* RDI structure goes at base of temp seg. */
	rdi.version_num = rdi_version_3;		/* Fill in version number. */

	call rcp_sys_$copy_data (rdi_ptr, max_copy_size, ecode);
	if ecode ^= 0
	then do;
		call com_err_ (ecode, "rcp_list", "Error getting data from RCP.");
		return;
	     end;
	goto RCPD (list_index);			/* Go to correct routine based on list_index. */

RCPD (0):						/* Header and all device types. */
	call ioa_ ("^/List of RCP data:");
	if long_flag
	then call ioa_ ("Number of devices   =  ^d", rdi.tot_ddevices);
	do dtypex = 1 to rdi.tot_ddtypes;		/* Output info about all device types. */
	     ddtype_ptr = addr (rdi.ddtypes (dtypex));
	     call LIST_DTYPE;			/* Output info about this device type. */
	end;
	return;

RCPD (1):						/* Output info about specified device type. */
	do dtypex = 1 to rdi.tot_ddtypes;		/* Look for specified device type. */
	     ddtype_ptr = addr (rdi.ddtypes (dtypex));
	     if ddtype.device_type = device_type	/* Is this the specified device type */
	     then do;				/* Yes. */
		     call LIST_DTYPE;
		     return;
		end;
	end;
	ecode = error_table_$name_not_found;
	call com_err_ (ecode, "rcp_list", "Device type = ^a", device_type);
	return;

RCPD (2):						/* Output info about specified ddevice. */
	do i = 1 to rdi.tot_ddevices;			/* Look for specified ddevice. */
	     ddevice_ptr = addr (rdi.ddevices (i));
	     if ddevice.device_name = device_name	/* Is this the specified device? */
	     then do;				/* Yes. */
		     ddtype_ptr = addr (rdi.ddtypes (ddevice.dtypex));
		     call LIST_DEVICE;
		     return;
		end;
	end;
	ecode = error_table_$name_not_found;
	call com_err_ (ecode, "rcp_list", "Device name = ^a", device_name);
	return;

RCPD (3):						/* List pending mount requests. */
	if long_flag				/* If -long, get number of mounts first. */
	then do;
		num_mounts = 0;
		do i = 1 to rdi.tot_ddevices;		/* Test each device. */
		     ddevice_ptr = addr (rdi.ddevices (i));
		     if ddevice.flags.mounting
		     then num_mounts = num_mounts + 1;
		end;
		if num_mounts = 0
		then do;
			call ioa_ ("No pending mounts");
			return;
		     end;
		if num_mounts = 1
		then call ioa_ ("1 pending mount");
		else call ioa_ ("^d pending mounts", num_mounts);
	     end;

	num_mounts = 0;				/* Reset number of mounts. */
	do i = 1 to rdi.tot_ddevices;			/* Test devices again. */
	     ddevice_ptr = addr (rdi.ddevices (i));
	     if ddevice.flags.mounting		/* Is there a mount pending for this device? */
	     then do;				/* Yes, list it. */
		     num_mounts = num_mounts + 1;	/* Count mounts. */
		     if ^long_flag
		     then call ioa_ ("^a on ^a", ddevice.volume_name, ddevice.device_name);
		     else call ioa_ ("Mount of ^a with^[out^] ^[ring^;protect^] pending on ^a for ^a",
			     ddevice.volume_name,
			     ((ddevice.dtypex = 1) & (^ddevice.flags.writing)) | ((ddevice.dtypex = 2) & (ddevice.flags.writing)),
			     ddevice.dtypex, ddevice.device_name, ddevice.group_id);
		end;
	end;
	if num_mounts = 0
	then call ioa_ ("No pending mounts");
	return;

RCPD (4):						/* List unattached, loaded volume names. */
	num_unattached = 0;				/* Reset number of volumes in this state. */

	do i = 1 to rdi.head.tot_ddevices;
	     ddevice_ptr = addr (rdi.ddevices (i));
	     if ddevice.flags.loaded then /* If there is a volume loaded here ... */
		if ^ddevice.flags.attached then do;	/* and it is unattached, report this one. */
			if num_unattached = 0 then
			     call ioa_ ("DEVICE^-VOLUME^-USER^/");
			call ioa_ ("^a^-^a^-^a", ddevice.device_name, ddevice.volume_name, ddevice.group_id);
			num_unattached = num_unattached + 1;
		     end;
	end;

	if num_unattached = 0
	then call ioa_ ("No unattached, loaded volumes present.");
	return;

RCPD (5):						/* List reservation information. */
	num_reserved = 0;				/* Reset number of resources in this state. */

	do i = 1 to rdi.head.tot_ddevices;		/* First look at the devices. */
	     ddevice_ptr = addr (rdi.ddevices (i));
	     if ddevice.reservation_id ^= 0 then do;	/* This one looks like a good one to list. */
		     call LIST_RESERVATION (ddevice.reservation_id, ddevice.group_id, ddevice.reserved_by);
		     num_reserved = num_reserved + 1;
		end;
	end;

	do i = 1 to rdi.head.tot_dvolumes;		/* Then make sure we haven't missed any volumes. */
	     dvolume_ptr = addr (rdi.dvolumes (i));
	     if dvolume.reservation_id ^= 0 then do;	/* List this one. */
		     call LIST_RESERVATION (dvolume.reservation_id, dvolume.group_id, dvolume.reserved_by);
		     num_reserved = num_reserved + 1;
		end;
	end;

	if num_reserved = 0
	then call ioa_ ("No reservations.");
	return;

LIST_DTYPE: procedure;

/*	This procedure is called to output data from RCP about a device type.
   *	It will output data about every device of this type.
*/
	if ^long_flag				/* Are we in long mode? */
	then if ddtype.num_devices > 0		/* No, print only if device type has devices. */
	     then call ioa_ ("^/Device type: ""^a"" ", ddtype.device_type);
	     else ;
	else do;					/* Long mode. */
		call ioa_ ("^/Device type: ""^a"" ", ddtype.device_type);
		call ioa_ ("Number of devices   =  ^d", ddtype.num_devices);
		call ioa_ ("Max concurrent      =  ^d", ddtype.max_concurrent);
		call ioa_ ("System reserved     =  ^d", ddtype.num_reserved);
	     end;

/* Process every device entry of this type. */
	do i = ddtype.first_devicex to (ddtype.first_devicex + ddtype.num_devices - 1);
	     ddevice_ptr = addr (rdi.ddevices (i));
	     call LIST_DEVICE;
	end;

     end LIST_DTYPE;

LIST_DEVICE: procedure;

/*	This procedure is called to output data from RCP about one device.
   *	Some of the information it will type is dependent upon the type of the device.
*/
	call ioa_ ("^5x^a device: ^a", ddtype.device_type, ddevice.device_name);

	call ioa_ ("^10xState     =  ^a", device_states (ddevice.state));
	call date_time_ (ddevice.state_time, time_string);
	call ioa_ ("^10xTime      =  ^a", time_string);

	if ddevice.state = 1			/* Is device assigned? */
	then call ioa_ ("^10xUser      =  ^a", ddevice.group_id);

	volume_name = ddevice.volume_name;		/* Save volume name. */
	if ddevice.flags.mounting			/* Is volume being mounted? */
	then do;					/* Yes. */
		if volume_name = " "		/* No volume name implies svratch volume. */
		then volume_name = "scratch";
		call ioa_ ("^10xMount pending for volume: ^a", volume_name);
	     end;
	else if volume_name ^= " "
	then call ioa_ ("^10xVolume    =  ^a", volume_name);

	if ^long_flag				/* Does user want extra information? */
	then return;				/* No. */

	if ddevice.flags.reservable
	then call ioa_ ("^10xDevice reservable to system processes");
	if ddevice.flags.reserved
	then call ioa_ ("^10xDevice assigned to a system process");

	call ioa_ ("^10xIOM #     =  ^d", ddevice.iom_num);
	call ioa_ ("^10xChannel   =  ^d (10)", ddevice.chan_num);

	goto DTYPE (ddevice.dtypex);			/* Other data depends upon device type. */

DTYPE (1):					/* TAPE */
	call ioa_ ("^10xModel     =  ^d", ddevice.model);
	call ioa_ ("^10xChannels  =  ^d", ddevice.num_channels);
	call ioa_ ("^10xTracks    =  ^d", ddevice.qualifiers (1));
	density_ptr = addr (ddevice.qualifiers (2));
	density_comment = "";
	do j = 1 to hbound (density_names, 1);		/* Test for each possible density setting. */
	     if substr (based_density, j, 1)		/* If capable of this density add to the list. */
	     then density_comment = density_comment || density_names (j);
	end;
	call ioa_ ("^10xDensities =  ^a", density_comment);
	speed_ptr = addr (ddevice.qualifiers (3));
	speed_comment = "";
	do j = 1 to hbound (speed_names, 1);		/* Test for each possible speed setting. */
	     if substr (based_speed, j, 1)		/* If capable of this speed add to the list. */
	     then speed_comment = speed_comment || speed_names (j);
	end;
	call ioa_ ("^10xSpeed     =  ^a", speed_comment);
	return;

DTYPE (2):					/* DISK */
	call ioa_ ("^10xModel     =  ^d", ddevice.model);
	call ioa_ ("^10xChannels  =  ^d", ddevice.num_channels);
	return;

DTYPE (4):					/* PRINTER */
	call ioa_ ("^10xModel     =  ^d", ddevice.model);
	call ioa_ ("^10xTrain     =  ^d", ddevice.qualifiers (1));
	if ddevice.qualifiers (2) = -1		/* -1 => no line length specified on PRPH card. */
	then call ioa_ ("^10xLine Len  =  not specified");
	else call ioa_ ("^10xLine Len  =  ^d", ddevice.qualifiers (2));
	return;

DTYPE (3): DTYPE (5): DTYPE (6): DTYPE (7): DTYPE (8):	/* CONSOLE, PUNCH, READER, SPECIAL, MCA */
	call ioa_ ("^10xModel     =  ^d", ddevice.model);

     end LIST_DEVICE;

LIST_RESERVATION: procedure (arg_rid, for, by);


	dcl     arg_rid		 fixed bin (71);
	dcl     by		 char (32) aligned; /* User who made the reservation. */
	dcl     for		 char (32) aligned; /* User for whom the reservation was made. */
	dcl     header_printed	 bit (1);		/* Bit to tell whether we have printed resource class. */
	dcl     k			 fixed bin;
	dcl     rid		 fixed bin (71);	/* Reservation to list. */
	dcl     rid_string		 char (32);	/* String representation of reservation id. */


	rid = arg_rid;				/* copy reservation id */


	rid_string = date_time_$format ("request_id", rid + sys_info$time_correction_constant, "", "");
	if long_flag then /* Print full reservation id. */
	     call ioa_ ("Reservation ^a (claimed) for ^a^[ by ^a^]", rid_string, for, (by ^= for), by);
	else call ioa_ ("Reservation ^a (claimed) for ^a^[ by ^a^]", substr (rid_string, 7, 6), for, (by ^= for), by);


	header_printed = "0"b;
	do k = 1 to rdi.head.tot_ddevices;		/* Look at all device entries. */
	     ddevice_ptr = addr (rdi.ddevices (k));
	     if ddevice.reservation_id = rid then do;	/* Got one. */
		     if ^header_printed then do;	/* Print header. */
			     call ioa_ ("^5xDevices");
			     header_printed = "1"b;
			end;
		     call ioa_ ("^10x^a", ddevice.device_name);
		     ddevice.reservation_id = 0;	/* Make sure we don't see this one again. */
		end;
	end;


	header_printed = "0"b;
	do k = 1 to rdi.head.tot_dvolumes;		/* Look at all vol entries. */
	     dvolume_ptr = addr (rdi.dvolumes (k));
	     if dvolume.reservation_id = rid then do;	/* Got one. */
		     if ^header_printed then do;	/* Print header. */
			     call ioa_ ("^5xVolumes");
			     header_printed = "1"b;
			end;
		     call ioa_ ("^10x^a", dvolume.volume_name);
		     dvolume.reservation_id = 0;	/* So we don't see this one again. */
		end;
	end;


	return;


     end LIST_RESERVATION;

PROCESS_ARG: procedure;

/*	This procedure is called to process one command option argument.  If this option
   *	argument is followed by a value argument then we process that argument also.
*/
	call cu_$arg_ptr (argx, arg_ptr, arg_len, ecode);
	if ecode ^= 0				/* Did we get a pointer to this argument? */
	then do;					/* No. */
		call com_err_ (ecode, "rcp_list", "Error getting argument ^d", argx);
		return;
	     end;
	option = argument;				/* Save command option argument. */
	do i = 1 to hbound (long_options, 1);		/* See if command option is valid. */
	     if (option = brief_options (i)) | /* Is it this brief option name? */
		(option = long_options (i))		/* Or this long option name? */
	     then do;				/* Yes, one of them. */
		     call GET_VALUE (i);		/* Get any accompanying value argument. */
		     if ecode ^= 0			/* Check for errors. */
		     then return;
		     goto OPTION (i);		/* Go process this option. */
		end;
	end;
	ecode = error_table_$badopt;			/* Option is not known. */
	call com_err_ (ecode, "rcp_list", "Control argument: ^a", option);
	return;

OPTION (1):					/* "list" */
	return;					/* Ignore. */

OPTION (2):					/* "-lg" or "-long" */
	long_flag = "1"b;				/* User wants long output format. */
	return;

OPTION (3):					/* "-tp" or "-type" */
	list_index = 1;				/* 1 => list one device type. */
	call resource_info_$get_dtypex (argument, device_type, dtypex, ecode);
	if ecode ^= 0 then do;
		call com_err_ (ecode, "rcp_list", "^a", argument);
		return;
	     end;

	return;

OPTION (4):					/* "-dv" or "-device" */
	list_index = 2;				/* 2 => list one device. */
	device_name = argument;			/* Get specified device name. */
	return;

OPTION (5):					/* "-mnt" or "-mounts" */
	list_index = 3;				/* 3 => list mounts pending. */
	return;

OPTION (6):					/* "-unat" or "-unattached" */
	list_index = 4;				/* 4 => list unattached, loaded volume names. */
	return;

OPTION (7):					/* "-reserved" or "-resv" */
	list_index = 5;				/* 5 => list resreved resources. */
	return;

     end PROCESS_ARG;

GET_VALUE: procedure (option_num);

/*	This procedure is called to get any value argument associated with this option.
   *	Processing of the value argument depends upon the option code value associated
   *	with this option.  The option code values are:
   *	     0.	This option argument has no accompanying value argument.
   *	     1.	This option argument has a string type value argument.
*/
	dcl     option_num		 fixed bin;	/* Number that identifies this option. */

	option_code = option_codes (option_num);	/* Get code value for this option. */

	if option_code = 0				/* Is there an accompanying argument value? */
	then return;				/* No, nothing else to do. */

/* Get accompanying argument value. */
	if argx = num_args				/* Is this the last argument? */
	then do;					/* Yes, value argument missing. */
		ecode = error_table_$odd_no_of_args;
		call com_err_ (ecode, "rcp_list", "No value argument for ^a", option);
		return;
	     end;

	argx = argx + 1;				/* Get the next argument. */
	call cu_$arg_ptr (argx, arg_ptr, arg_len, ecode);
	if ecode ^= 0
	then do;
		call com_err_ (ecode, "rcp_list", "Error getting argument ^d", argx);
		return;
	     end;

	if index (argument, "-") = 1			/* Is next argument a control option? */
	then do;					/* Yes, value argument is missing. */
		ecode = error_table_$wrong_no_of_args;
		call com_err_ (ecode, "rcp_list", "No value argument for ^a", option);
		return;
	     end;

     end GET_VALUE;

     end rcp_list;




		    rcp_op_cmnd_.pl1                06/08/83  1339.1rew 06/08/83  1338.7       78876



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


rcp_op_cmnd_: proc ();


/*
   * This subroutine implements the following operator commands:
   *
   *	preload <device> <volume> {-user <user>}
   *	unload <volume-type> {<volume> | -all}
   *
   *
   *	Created on 04/28/78 by Michael R. Jordan.
   *	Modified on 12/09/78 by Michael R. Jordan for version 2 rcp_data info.
   *	Modified 6/79 by Michael R. Jordan for MR7.0R.
   *      Modified May 1983 by Art Beattie to fix unload usage message.
   *
   *
*/

dcl  addr builtin;
dcl  arg char (arg_len) based (arg_ptr);		/* value of command argument */
dcl  arg_len fixed bin;				/* length of command argument */
dcl  arg_num fixed bin;				/* index for argument processing */
dcl  arg_ptr ptr;					/* pointer to command argument */
dcl  code fixed bin (35);				/* status code */
dcl  com_err_ entry options (variable);
dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  device_name char (32);				/* the device on which to operate */
dcl  error_table_$badopt fixed bin (35) ext;
dcl  error_table_$bigarg fixed bin (35) ext;
dcl  error_table_$device_busy fixed bin (35) ext;
dcl  error_table_$incorrect_device_type fixed bin (35) ext;
dcl  error_table_$incorrect_volume_type fixed bin (35) ext;
dcl  error_table_$media_not_removable fixed bin (35) ext;
dcl  error_table_$noarg fixed bin (35) ext;
dcl  error_table_$resource_unknown fixed bin (35) ext;
dcl  error_table_$volume_busy fixed bin (35) ext;
dcl  error_table_$volume_not_loaded fixed bin (35) ext;
dcl  error_table_$wrong_no_of_args fixed bin (35) ext static;
dcl  hbound builtin;
dcl  hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl  i fixed bin;
dcl  length builtin;
dcl  me char (16);
dcl  mess char (32);
dcl  nargs fixed bin;				/* number of command arguments */
dcl  null builtin;
dcl  rcp_sys_$copy_data entry (ptr, fixed bin (19), fixed bin (35));
dcl  rcp_sys_$preload entry (char (32), char (32), char (32), fixed bin (35));
dcl  rcp_sys_$unload entry (char (32), char (32), fixed bin (35));
dcl  resource_info_$get_vtypex entry (char (*), char (*), fixed bin, fixed bin (35));
dcl  temp_seg_ptr ptr static init (null ());
dcl  user_id char (32);				/* the user for whom we are preloading */
dcl  volume_name char (32);				/* the volume to be preloaded */
dcl  volume_type char (32);				/* type of volume being preloaded */
dcl  vtypex fixed bin;				/* volume type index */

/*

   This entry implements the operator preload command.  The command syntax is:

   preload device_name volume_name {-user XX}

   The user name is required if Resource Management is not enabled.  It serves
   to identify the user for whom the volume is being preloaded.

*/


preload:	entry ();

	me = "preload";


/*

   See how many arguments there are.  If not enough, then complain.

*/


	call cu_$arg_count (nargs);
	if nargs < 2 then do;
NO_ARG:	     call com_err_ (error_table_$noarg, me,
		"^/Usage: preload DEVICE VOLUME -user USERID");
	     return;
	end;


/*

   Now get the volume and device names and save them away.

*/


	call cu_$arg_ptr (1, arg_ptr, arg_len, code);
	if code ^= 0 then do;
BAD_ARG:	     call com_err_ (code, me);
	     return;
	end;
	if length (arg) > length (device_name) then do;
LONG_ARG:	     call com_err_ (error_table_$bigarg, me, "^a", arg);
	     return;
	end;
	device_name = arg;


	call cu_$arg_ptr (2, arg_ptr, arg_len, code);
	if code ^= 0 then goto BAD_ARG;
	if length (arg) > length (volume_name) then goto LONG_ARG;
	volume_name = arg;


/*

   Now process any control arguments.

*/


	user_id = "";				/* no user_id yet */
	arg_num = 3;				/* first control argument */


	do while (arg_num <= nargs);

	     call GET_ARG ();

	     if arg = "-user" then do;
		if arg_num > nargs then goto NO_ARG;
		call GET_ARG ();
		if length (arg) > length (user_id) then goto LONG_ARG;
		user_id = arg;
	     end;

	     else do;
		call com_err_ (error_table_$badopt, me, "^a", arg);
		return;
	     end;

	end;


/*

   Do the preload!

*/


	call rcp_sys_$preload (device_name, volume_name, user_id, code);
	if code ^= 0 then do;
	     if code = error_table_$incorrect_device_type |
	     code = error_table_$device_busy |
	     code = error_table_$resource_unknown then
		mess = device_name;
	     else if code = error_table_$volume_busy then
		mess = volume_name;
	     else if code = error_table_$noarg then
		mess = "-user NAME required.";
	     else mess = "";
	     call com_err_ (code, me, "^a", mess);
	end;

	return;

/*

   This entry implements the operator unload command.  The command syntax is:

   unload volume_type {volume_name | -all}

*/


unload:	entry ();

	me = "unload";


/*

   See how many arguments there are.  If not enough, then complain.

*/


	call cu_$arg_count (nargs);
	if nargs ^= 2 then do;
	     call com_err_ (error_table_$wrong_no_of_args, me,
		"^/Usage: unload VOLUME_TYPE <VOLUME_NAME | -all>");
	     return;
	end;


/*

   Now get the type of volume to be unloaded.

*/


	call cu_$arg_ptr (1, arg_ptr, arg_len, code);
	if code ^= 0 then goto BAD_ARG;
	if length (arg) > length (volume_type) then goto LONG_ARG;
	volume_type = arg;


/*

   Now see if this is an unload -all or an unload volume-name.

*/


GOT_VTYPEX:

	call cu_$arg_ptr (2, arg_ptr, arg_len, code);
	if code ^= 0 then goto BAD_ARG;


	if arg = "-all" | arg = "-a"
	then call UNLOAD_ALL ();
	else do;					/* Just do this one volume. */
	     if length (arg) > length (volume_name) then goto LONG_ARG;
	     volume_name = arg;
	     call UNLOAD_VOLUME ();
	end;


	return;

GET_ARG:	proc ();


	     if arg_num > nargs then do;
		arg_ptr = null ();
		return;
	     end;


	     call cu_$arg_ptr (arg_num, arg_ptr, arg_len, code);
	     if code ^= 0 then goto BAD_ARG;


	     arg_num = arg_num+1;


	     return;


	end GET_ARG;

/*

   This internal procedure attempts to unload all unattached, loaded volumes.
   It does so by getting the names of these volumes from the info returned
   by rcp_sys_$copy_data and calling UNLOAD_VOLUME for each one.

*/


UNLOAD_ALL: proc ();


/*

   First we must get the rdi structure from RCP.

*/


	     if temp_seg_ptr = null () then do;		/* If we don't have a temp seg then get one. */
		call hcs_$make_seg ("", "rcp_unload_seg", "", 01010b, temp_seg_ptr, code);
		if temp_seg_ptr = null () then do;
		     call com_err_ (code, me, "Error making rcp_unload_seg.");
		     return;
		end;
	     end;

	     rdi_ptr = temp_seg_ptr;			/* Put RCP data in temp seg. */
	     rdi.version_num = rdi_version_3;		/* Specify version number of the structure. */

	     call rcp_sys_$copy_data (rdi_ptr, 64*1024, code); /* Get the data. */
	     if code ^= 0 then do;
		call com_err_ (code, me, "Error getting data from RCP.");
		return;
	     end;


/*

   Now get the device type ptr for this volume type.

*/


	     call resource_info_$get_vtypex (volume_type, volume_type, vtypex, code);
	     if code ^= 0 then do;
		call com_err_ (code, me, "^a", volume_type);
		return;
	     end;

	     ddtype_ptr = addr (rdi.ddtypes (vtypex));


/*

   Now process each unattached device entry of this type.

*/


	     do i = ddtype.first_devicex to (ddtype.first_devicex+ddtype.num_devices-1);
		ddevice_ptr = addr (rdi.ddevices (i));
		if ^ddevice.flags.attached then do;	/* This one is not attached ... */
		     volume_name = ddevice.volume_name; /* ... so get the volume name and ... */
		     if volume_name ^= "" then	/* ... if its not blank then ... */
			call UNLOAD_VOLUME ();	/* ... unload it. */
		end;
	     end;


	     return;


	end UNLOAD_ALL;

/*

   This internal procedure attempts to unload the volume specified by
   volume_name.  If an error occurs, a message will be printed also.

*/


UNLOAD_VOLUME: proc ();


	     call rcp_sys_$unload (volume_type, volume_name, code);
	     if code ^= 0 then do;
		if code = error_table_$incorrect_volume_type then
		     mess = volume_type;
		else if code = error_table_$volume_not_loaded |
		code = error_table_$media_not_removable |
		code = error_table_$volume_busy then
		     mess = volume_name;
		else mess = "";
		call com_err_ (code, me, "^a", mess);
	     end;

	     return;


	end UNLOAD_VOLUME;

%include rcp_data_info;


     end rcp_op_cmnd_;




		    bull_copyright_notice.txt       08/30/05  1008.4r   08/30/05  1007.3    00020025

                                          -----------------------------------------------------------


Historical Background

This edition of the Multics software materials and documentation is provided and donated
to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. 
as a contribution to computer science knowledge.  
This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology,
Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull
and Bull HN Information Systems Inc. to the development of this operating system. 
Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970),
renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership
of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for 
managing computer hardware properly and for executing programs. Many subsequent operating systems
incorporated Multics principles.
Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., 
as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. .

                                          -----------------------------------------------------------

Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without
fee is hereby granted,provided that the below copyright notice and historical background appear in all copies
and that both the copyright notice and historical background and this permission notice appear in supporting
documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining
to distribution of the programs without specific prior written permission.
    Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc.
    Copyright 2006 by Bull HN Information Systems Inc.
    Copyright 2006 by Bull SAS
    All Rights Reserved