assign_resource.pl1 07/18/86 1500.4rew 07/18/86 1235.1 278289 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-05-22,Martinson), approve(86-05-22,MCR7411), audit(86-05-22,GJohnson), install(86-05-22,MR12.0-1061): Fix assign_resource so that the -wait control argument works. 2) change(86-06-04,Hartogs), approve(86-06-04,MCR7383), audit(86-06-05,Coppola), install(86-07-18,MR12.0-1098): Changed to use version constant in rcp_device_info.incl.pl1 END HISTORY COMMENTS */ assign_resource: ar: procedure; /* This program is a command that may be called to assign a resource controled by RCP. * Created on 01/07/75 by Bill Silver. * Changed on 04/02/76 by Bill Silver for "-number" and "-wait" arguments. * Changed on 05/24/78 by Michael R. Jordan for tape_drive and disk_drive and the waring for tape and disk. * Changed on 11/17/78 by M. R. Jordan for -speed and -den 6250. * Modified 6/79 by Michael R. Jordan for 32 character resource types. * Changed 05/83 by B. Braun to add active function capability (phx14713) * and correct declarations of structures used in ipc_ calls (phx13447). * Modified 9/83 by J. A. Bush to use tape_info_version_3 tape_info structure * Modified 831010 for multiple console support... -E. A. Ranzenbach * Modified 841017 to do correct cleanup handling... -M. M. Pozzo * * In the current implementation this command can assign only devices. * Its calling sequence is: * * assign_resource resource_type -control_args- * * resource_type This argument specifies the type of resource to be * assigned. Currently only device type resources can * be assigned. Thus this argument must specify a known * device type. If no "-device" control argument is * specified RCP will attempt to assign any appropriate * device of this type. * * The following optional control arguments are also supported. They may * be used to specify the characteristics of the device to be assigned. * Most of these control arguments must be followed by a value argument. * * (-dv | -device) Specifies that a specific device is to be assigned. * Its value argument must be the name of the device. * RCP will attempt to assign only this specific device. * (-lg | -long) Specifies that the user wants all available information about * the device that is assigned. * (-com | -comment) The value argument is a comment that will be displayed * to the operator when the device is assigned. If more * than one term is required they should be in quotes. * (-model) Device model number. * (-tk | -track) For tapes, the track type. Must be 9 or 7. * (-den | -density) For tapes, the density must be one of the following * values: 6250, 1600, 800, 556, or 200. * (-vol | -volume) The name of a volume used to qualify assignment. * (-tn | -train) For printers, the print train type. * (-ll | -line_length) For printer, the line length. * (-sys | -system) Specifies that the user wants to be a system process. * (-nb | -number) The number of similar devices to assign. * (-wt | -wait) Specifies that the user wants to wait for assignments. * Optional value => minutes to wait. * (-speed) For tapes, the speed must be one of the following * values: 75, 125, or 200. * * Active Function Syntax is: * [ar resource_type {-control_args}] * * The active function returns true if an * assignment was successful and returns false if the resources are * unavailable. Other errors are reported by active_fnc_error_. * The -long control argument is not allowed. */ /* AUTOMATIC DATA */ dcl 1 info_buffer like tape_info; /* An input device info buffer big enough for tapes. */ dcl 1 alist (16) aligned, /* List of assigned devices. */ 2 rcp_id bit (36), /* RCP ID for this assignment. */ 2 info like tape_info; /* Output device info structure. */ dcl 1 event_data aligned like event_wait_info; /* Event message structure, not used. */ dcl active_fnc bit(1); /* True if called as an active function */ dcl af_return_arg_len fixed bin(21); dcl af_return_arg_ptr ptr; dcl arg_len fixed bin(21); /* Length of an argument string. */ dcl arg_ptr ptr; /* Pointer to an argument string. */ dcl argx fixed bin; /* Number of the current argument. */ dcl badx fixed bin (35); /* Index to bad character. */ dcl comment char (64); /* Comments to and from operator. */ dcl density bit (5); /* Tape density characteristic. */ dcl density_comment char (30) varying; /* Used to print density capabilities. */ dcl device_flag bit (1); /* ON => user wants specific device by name. */ dcl device_type char (32); /* Device type. */ dcl dtypex fixed bin; /* Device type index. */ dcl ecode fixed bin (35); /* error_table_ code. */ dcl fixed_arg fixed bin; /* Used to convert an argumment to fixed bin. */ dcl i fixed bin; dcl line_length fixed bin; /* Printer line length. */ dcl long_flag bit (1); /* ON => all available information. */ dcl max_num_waits fixed bin; /* Maximum number of minutes to wait. */ dcl num_args fixed bin; /* Number of command arguments. */ dcl num_assigned fixed bin; /* Number of devices assigned so far. */ dcl num_waits fixed bin; /* Number of times we have waited. */ dcl number fixed bin; /* Number of devices to assign. */ dcl option char (12); /* Command option string. */ dcl option_code fixed bin; /* 0 => none, 1 => string, 2 => binary. */ dcl print_train fixed bin; /* Printer print train characteristic. */ dcl speed bit (3); /* Tape drive speed characteristics. */ dcl speed_comment char (30) varying; /* Used to print speed capability. */ dcl statex fixed bin; /* State of device assignment. */ dcl system_flag bit (1); /* ON => user wants to be a system process. */ dcl temp_ecode fixed bin (35); dcl tracks fixed bin; /* Tape track characteristic. */ dcl volume_name char (32); /* Tape or disk volume name. */ dcl wait_flag bit (1); /* ON => waiting for assignment. */ /* BASED DATA */ dcl argument char (arg_len) based (arg_ptr); /* Used to reference argument string. */ dcl af_return_arg char(af_return_arg_len) varying based (af_return_arg_ptr); /* INTERNAL STATIC DATA */ dcl brief_options (13) char (6) /* Brief form of command options. */ internal static init ("-dv", "-lg", "-com", "-model", "-tk", "-den", "-vol", "-tn", "-ll", "-sys", "-nb", "-wt", "-speed") options(constant); dcl long_options (13) char (12) /* Long form of command options. */ internal static init ("-device", "-long", "-comment", "-model", "-track", "-density", "-volume", "-train", "-line_length", "-system", "-number", "-wait", "-speed") options(constant); dcl option_codes (13) fixed bin /* Used to describe value argument. */ internal static init (1, 0, 1, 2, 2, 2, 1, 2, 2, 0, 2, -2, 2) options(constant); dcl density_names (5) char (5) varying /* Tape density capabilities. */ internal static init ("200 ", "556 ", "800 ", "1600 ", "6250 ") options(constant); dcl density_values (5) fixed bin /* Tape density values. */ internal static init (200, 556, 800, 1600, 6250) options(constant); dcl console_models (4) char (4) /* Operator's console model names. */ internal static init ("IBM", "EMC", "SCC", "LCC") options(constant); dcl speed_values (3) fixed bin /* Tape drive speed values. */ internal static init (75, 125, 200) options(constant); dcl speed_names (3) char (4) varying /* Tape drive speed names. */ internal static init ("75 ", "125 ", "200 ") options(constant); /* EXTERNAL ENTRIES CALLED */ dcl cleanup condition; /* Used to unassign if trouble. */ dcl (addr, hbound, substr, null) builtin; dcl (error_table_$action_not_performed, error_table_$bad_arg, error_table_$badopt, error_table_$inconsistent, error_table_$noarg, error_table_$not_act_fnc, error_table_$resource_reserved, error_table_$resource_unavailable, error_table_$wrong_no_of_args) fixed bin (35) external; dcl active_fnc_err_ entry options(variable), com_err_ entry options (variable), convert_ipc_code_ entry (fixed bin (35)), cu_$af_arg_ptr entry (fixed bin, ptr, fixed bin(21), fixed bin(35)), cu_$af_return_arg entry (fixed bin, ptr, fixed bin(21), fixed bin(35)), cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)), cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)), get_argument entry (fixed bin, ptr, fixed bin(21), fixed bin(35)) variable, error_rtn_ entry() options(variable) variable, ioa_ entry options (variable), ipc_$block entry (ptr, ptr, fixed bin (35)), ipc_$create_ev_chn entry (fixed bin (71), fixed bin (35)), ipc_$delete_ev_chn entry (fixed bin (71), fixed bin (35)), rcp_$assign_device entry (char (*), ptr, fixed bin (71), char (*), bit (36) aligned, fixed bin (35)), rcp_$check_assign entry (bit (36) aligned, ptr, char (*), fixed bin, fixed bin (35)), rcp_$unassign entry (bit (36) aligned, bit (*), char (*), fixed bin (35)), resource_info_$get_dtypex entry (char (*), char (*), fixed bin, fixed bin (35)), timer_manager_$sleep entry (fixed bin (71), bit (2)); %include rcp_device_info; %include rcp_tape_info; %include rcp_disk_info; %include rcp_printer_info; %include event_wait_channel; %include event_wait_info; %page; /* * * Begin command: assign_resource, ar * */ device_flag, /* Now initialize other variables. */ long_flag, system_flag, wait_flag = "0"b; dtypex, ecode, num_assigned, event_wait_channel.channel_id(1) = 0; number = 1; comment = " "; do i = 1 to hbound (alist, 1); alist (i).rcp_id = "0"b; end; device_info_ptr = addr (info_buffer); /* All structures use the same buffer. */ device_info.version_num = DEVICE_INFO_VERSION_1; /* Set up assignment data. Assume same version. */ device_info.usage_time, /* These fields not used yet. */ device_info.wait_time = 0; device_info.device_name = " "; /* Blank => assign any device of specified type. */ device_info.model = 0; device_info.qualifiers (*) = 0; tracks = 0; /* Initialize device characteristics. */ density = "0"b; volume_name = " "; speed = "0"b; print_train, line_length = 0; /* get command arguments */ call cu_$af_return_arg (num_args, af_return_arg_ptr, af_return_arg_len, ecode); if ecode = error_table_$not_act_fnc then do; active_fnc = "0"b; get_argument = cu_$arg_ptr; error_rtn_ = com_err_; end; else do; /* active function case */ active_fnc = "1"b; get_argument = cu_$af_arg_ptr; error_rtn_ = active_fnc_err_; af_return_arg = "false"; end; call GET_RESOURCE_TYPE; /* Get required argument. */ if ecode ^= 0 then goto MAIN_RETURN; do argx = 2 to num_args; /* Process any optional control arguments. */ call PROCESS_ARG; /* Most will be processed in pairs. */ if ecode ^= 0 then goto MAIN_RETURN; /* Was there an error? */ end; call CHECK_DEVICE_INFO; /* See if device info is valid. */ if ecode ^= 0 then goto MAIN_RETURN; /* Is it valid? */ on cleanup begin; /* If user quits unassign all devices. */ call CLEANUP; end; call ipc_$create_ev_chn (event_wait_channel.channel_id(1), ecode); if ecode ^= 0 /* RCP needs an event channel. */ then do; /* But we don't have one. */ call convert_ipc_code_ (ecode); call error_rtn_ (ecode, "assign_resource", "Error creating event channel."); goto MAIN_RETURN; end; do while ((num_assigned < number) & (ecode = 0)); call ASSIGN_DEVICE; /* Try to assign one device. */ end; if ecode ^= 0 /* Was there an error. */ then goto MAIN_RETURN; /* Yes. */ /* Successful assignment of resources */ if active_fnc then af_return_arg = "true"; /* Active Function case prints no info. */ else do; if (long_flag) & (^device_flag) & (num_assigned > 1) then call ioa_ ("^d devices assigned", num_assigned); do number = 1 to num_assigned; /* Print info about each assigned device. */ device_info_ptr = addr (alist (number).info); call PRINT_DEVICE_INFO; /* Print info about one device. */ end; end; num_assigned = 0; /* Don't unassign any devices. */ MAIN_RETURN: call CLEANUP; /* Clean up event channel. */ return; /* We are finished. */ /* * * This procedure will attempt to assign one device. * If this device cannot be assigned because no appropriate device is * currently available, then all devices assigned up to that point will * be unassigned. If the user wants to wait for the assignment(s) then * we will go blocked for one minute and try again. * */ ASSIGN_DEVICE: procedure; num_assigned = num_assigned + 1; /* Up count of assigned devices. */ device_info_ptr = addr (info_buffer); /* Use input info structure. */ call rcp_$assign_device (device_type, device_info_ptr, event_wait_channel.channel_id(1), comment, alist (num_assigned).rcp_id, ecode); if ecode ^= 0 /* Was assignment started OK? */ then do; /* No. */ if (ecode ^= error_table_$resource_unavailable) & (ecode ^= error_table_$resource_reserved) then do; /* Error during assignment. */ call error_rtn_ (ecode, "assign_resource", "Error assigning ^a device ^a", device_type, device_info.device_name); return; end; end; device_info_ptr = addr (alist (num_assigned).info); /* Get pointer to output info structure. */ device_info.version_num = addr (info_buffer) -> device_info.version_num; device_info.device_name = " "; ASSIGN_LOOP: /* Loop until assignment completed. */ comment = " "; call rcp_$check_assign (alist (num_assigned).rcp_id, device_info_ptr, comment, statex, ecode); if comment ^= " " /* Did RCP send a comment? */ then if ^active_fnc then call ioa_ ("RCP comment: ^a", comment); goto STATE (statex); /* Process current state of assignment. */ STATE (0): /* Assignment completed OK. */ return; STATE (1): /* Short wait, block until wakeup comes. */ call ipc_$block (addr (event_wait_channel), addr (event_data), ecode); if ecode ^= 0 /* Error in blocking is bad. */ then do; call convert_ipc_code_ (ecode); call error_rtn_ (ecode, "assign_resource", "Error waiting for device assignment."); return; end; goto ASSIGN_LOOP; /* Waked up, check assignment again. */ STATE (2): /* Long wait, don't support this yet. */ ecode = error_table_$action_not_performed; STATE (3): /* Fatal error. */ if (ecode ^= error_table_$resource_unavailable) & (ecode ^= error_table_$resource_reserved) then do; /* Error during assignment. */ call error_rtn_ (ecode, "assign_resource", "Error assigning ^a device ^a", device_type, device_info.device_name); return; end; if ^wait_flag /* Can't get device now, should we wait? */ then do; /* No. */ if active_fnc then return; call error_rtn_ (ecode, "assign_resource", "Unable at this time to assign ^a device ^a", device_type, device_info.device_name); return; end; /* Assignment can be made if we wait. Check to see if we have already * waited too many times. */ if num_waits = max_num_waits /* Have we waited to many times? */ then do; /* Yes. */ if active_fnc then return; call error_rtn_ (ecode, "assign_resource", "Maximum wait of ^d minutes exceeded", max_num_waits); return; end; /* We will wait for the assignment(s). First unassign any device already assigned. */ alist (num_assigned).rcp_id = "0"b; /* This assignment failed. */ do i = 1 to (num_assigned -1); /* Unassign any devices already assigned. */ call rcp_$unassign (alist (i).rcp_id, "0"b, "", temp_ecode); alist (i).rcp_id = "0"b; /* Don't use this RCP ID again. */ if temp_ecode ^= 0 then do; /* Error unassigning this device. */ call error_rtn_ (temp_ecode, "assign_resource", "Error unassigning device"); if ecode = 0 then ecode = temp_ecode; end; end; if num_waits = 0 /* Is this the first wait? */ then if ^active_fnc then call error_rtn_ (0, "assign_resource", "Waiting for device assignments"); num_waits = num_waits + 1; /* Count number of times we have waited. */ num_assigned = 0; /* No devices now assigned. */ call timer_manager_$sleep (60, "11"b); /* Wait for one minute. */ ecode = 0; return; end ASSIGN_DEVICE; /* * * This procedure is called to validate the data entered for this device * assignment. The actual testing performed depends upon the type of * device being assigned. If everything is OK we will fill in the device * characteristics that go with this device type. * */ CHECK_DEVICE_INFO: procedure; if (device_flag) & (number > 1) /* Only one specific device can be assigned. */ then do; /* More than one is an error. */ ecode = error_table_$inconsistent; call error_rtn_ (ecode, "assign_resource", "Attempt to assign device ^a ^d times", device_info.device_name, number); end; device_info.system_flag = system_flag; /* Tell RCP whether or not this is a system process. */ goto DTYPE_CHECK (dtypex); /* Go check depending upon device type. */ DTYPE_CHECK (1): /* TAPE */ if (tracks = 0) & /* If no track type specified ... */ (volume_name = " ") /* and no volume specified ... */ then tracks = 9; /* then use default track type. */ if (tracks = 7) & /* Check that tracks and density are OK. */ (substr (density, 4, 2) ^= "00"b) then do; /* 7 track and 1600 is invalid. */ ecode = error_table_$inconsistent; call error_rtn_ (ecode, "assign_resource", "Inconsistent track and density values."); end; tape_info_ptr = device_info_ptr; /* Get pointer to tape_info structure. */ tape_info.version_num = tape_info_version_3; /* newer version than the others */ tape_info.tracks = tracks; /* Fill in tape characteristics. */ tape_info.density = density; tape_info.volume_name = volume_name; tape_info.write_flag = "0"b; tape_info.position_index = 0; tape_info.speed = speed; tape_info.unused_qualifier = "0"b; return; DTYPE_CHECK (2): /* DISK */ disk_info_ptr = device_info_ptr; /* Get pointer to disk_info structure. */ disk_info.volume_name = volume_name; /* Fill in disk characteristics. */ disk_info.write_flag = "0"b; return; DTYPE_CHECK (3): /* CONSOLE */ if (device_info.device_name ^= " ") & /* Does user want specific device? */ (substr (device_info.device_name, 1, 3) ^= "opc") then do; /* Yes, but not the correct name. */ ecode = error_table_$bad_arg; call error_rtn_ (ecode, "assign_resource", "Illegal console device name: ^a", device_info.device_name); end; return; DTYPE_CHECK (4): /* PRINTER */ printer_info_ptr = device_info_ptr; /* Get pointer to printer_info structure. */ printer_info.print_train = print_train; /* Fill in printer characteristics. */ printer_info.line_length = line_length; return; DTYPE_CHECK (5): /* PUNCH */ DTYPE_CHECK (6): /* READER */ return; /* Nothing to do for these device types. */ DTYPE_CHECK (7): /* SPECIAL */ if device_info.device_name = " " /* Did user specify a device name? */ then do; /* No, for this device type he must. */ ecode = error_table_$noarg; call error_rtn_ (ecode, "assign_resource", "Must specify SPECIAL device name."); end; end CHECK_DEVICE_INFO; /* * * This procedure is called when the assignment has been aborted. * If we have an RCP ID we will try to unassign the device we are assigning. * If we have created an event channel then we must delete it. * */ CLEANUP: procedure; dcl cleanup_code fixed bin (35); do i = 1 to num_assigned; /* Unassign all assigned devices. */ if alist (i).rcp_id ^= "0"b /* If we have an RCPID try to unassign. */ then call rcp_$unassign (alist (i).rcp_id, "0"b, "", cleanup_code); end; if event_wait_channel.channel_id(1) = 0 then return; /* Did we created an event channel? */ call ipc_$delete_ev_chn (event_wait_channel.channel_id(1), cleanup_code); return; end CLEANUP; /* * * This procedure is called to get the resource type to be assigned. * The resource type name must be the first argument to this command. * */ GET_RESOURCE_TYPE: procedure; if num_args < 1 /* Is there a resource type argument. */ then do; /* No. */ ecode = error_table_$noarg; call error_rtn_ (ecode, "assign_resource", "No resource type specified."); return; end; call get_argument (1, arg_ptr, arg_len, ecode); /* Get resource type argument. */ if ecode ^= 0 then do; call error_rtn_ (ecode, "assign_resource", "Error getting resource type argument"); return; end; call resource_info_$get_dtypex (argument, device_type, dtypex, ecode); if ecode ^= 0 then do; call error_rtn_ (ecode, "assign_resource", "^a", argument); return; end; else return; end GET_RESOURCE_TYPE; /* * * 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. * 2. This option argument has a binary type value argument. * (-1, -2) This option argument is optional. * */ GET_VALUE: procedure (option_num); 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 if option_code < 0 /* Must there be a value argument? */ then do; /* No. */ if option_code = -1 then arg_ptr = null (); else fixed_arg = 0; return; end; else do; /* Yes, value argument missing. */ ecode = error_table_$wrong_no_of_args; call error_rtn_ (ecode, "assign_resource", "No value argument for ^a", option); return; end; argx = argx + 1; /* Get the next argument. */ call get_argument (argx, arg_ptr, arg_len, ecode); if ecode ^= 0 then do; call error_rtn_ (ecode, "assign_resource", "Error getting argument ^d", argx); return; end; if substr (argument, 1, 1) = "-" /* Is next argument a control option? */ then if option_code < 0 /* Must there be a value argument? */ then do; /* No, two control args in a row is OK. */ argx = argx - 1; /* Process this argument over again. */ if option_code = -1 then arg_ptr = null (); else fixed_arg = 0; return; end; else do; /* Yes, value argument is missing. */ ecode = error_table_$wrong_no_of_args; call error_rtn_ (ecode, "assign_resource", "No value argument for ^a", option); return; end; if option_code = 1 /* Is argument value a string? */ then return; /* Yes, no conversion necessary. */ /* Convert argument value to binary. */ fixed_arg = cv_dec_check_ (argument, badx); if badx ^= 0 /* Argument contains non decimal characters. */ then do; ecode = error_table_$bad_arg; call error_rtn_ (ecode, "assign_resource", " ""^a"" is not a decimal number.", argument); return; end; end GET_VALUE; /* * * This procedure prints information about one assigned device. * */ PRINT_DEVICE_INFO: procedure; if (long_flag) | (^device_flag) then call ioa_ ("Device ^a assigned", device_info.device_name); if ^long_flag then return; /* Does user want all available information? */ goto DTYPE_INFO (dtypex); /* Other info depends upon device type. */ DTYPE_INFO (1): /* TAPE */ call ioa_ ("Model^-= ^d", device_info.model); tape_info_ptr = device_info_ptr; /* Use tape specific info. */ call ioa_ ("Tracks^-= ^d", tape_info.tracks); density_comment = ""; /* Clear density comment. */ do i = 1 to hbound (density_names, 1); /* Test for each possiblle density. */ if substr (tape_info.density, i, 1) then density_comment = density_comment || " " || density_names (i); end; call ioa_ ("Densities^-= ^a", density_comment); speed_comment = ""; do i = 1 to hbound (speed_names, 1); /* Test for each possible speed. */ if substr (tape_info.speed, i, 1) then speed_comment = speed_comment || " " || speed_names (i); end; call ioa_ ("Speed^-= ^a", speed_comment); return; DTYPE_INFO (3): /* CONSOLE */ call ioa_ ("Model^-= ^a", console_models (device_info.model)); return; DTYPE_INFO (4): /* PRINTER */ call ioa_ ("Model^-= ^d", device_info.model); printer_info_ptr = device_info_ptr; /* Use printer specific info. */ call ioa_ ("Train^-= ^d", printer_info.print_train); if printer_info.line_length = -1 then call ioa_ ("Line Len^-= not specified"); else call ioa_ ("Line Len^-= ^d", printer_info.line_length); return; DTYPE_INFO (2): /* DISK */ DTYPE_INFO (5): /* PUNCH */ DTYPE_INFO (6): /* READER */ DTYPE_INFO (7): /* SPECIAL */ call ioa_ ("Model^-= ^d", device_info.model); return; /* No extra information for these device types. */ end PRINT_DEVICE_INFO; /* * * This procedure is called to process one optional control argument. * Many of the control arguments have an accompanying value argument. * This value must be the next argument. In this case we will process * the value argument too. * */ PROCESS_ARG: procedure; call get_argument (argx, arg_ptr, arg_len, ecode); if ecode ^= 0 then do; call error_rtn_ (ecode, "assign_resource", "Error getting argument ^d", argx); return; end; option = argument; /* Save option argument. */ do i = 1 to hbound (long_options, 1); /* Look for valid option name. */ if (option = brief_options (i)) | /* Is it this brief name? */ (option = long_options (i)) /* Or this long name? */ then do; /* Yes, one of them. */ call GET_VALUE (i); /* Get value argument if any. */ if ecode ^= 0 then return; /* Check for errors. */ goto OPTION (i); /* Go process this option. */ end; end; ecode = error_table_$badopt; /* Option name not found. */ call error_rtn_ (ecode, "assign_resource", "^a", argument); return; OPTION (1): /* "-dv" or "-device" */ device_info.device_name = argument; /* Assign a specific device. */ device_flag = "1"b; return; OPTION (2): /* "-lg" or "-long" */ if active_fnc then do; /* -lg isn't allowed in AF case */ ecode = error_table_$bad_arg; call error_rtn_ (ecode, "assign_resource", "Control arg not allowed for the active function. ^a", argument); end; else long_flag = "1"b; /* Return all info when device assigned. */ return; OPTION (3): /* "-com" or "-comment" */ comment = argument; /* Save user's comment to operator. */ return; OPTION (4): /* "-model" */ device_info.model = fixed_arg; return; OPTION (5): /* "-tk" or "-track" */ if (fixed_arg ^= 9) & /* Validate value. */ (fixed_arg ^= 7) then goto BAD_ARG; tracks = fixed_arg; return; OPTION (6): /* "-den" or "-density" */ do i = 1 to hbound (density_values, 1); /* Look for a valid density value. */ if fixed_arg = density_values (i) then do; /* We found one. */ substr (density, i, 1) = "1"b; return; end; end; goto BAD_ARG; /* Invalid value. */ OPTION (7): /* "-vol" or "-volume" */ volume_name = argument; return; OPTION (8): /* "-tn" or "-train" */ print_train = fixed_arg; return; OPTION (9): /* "-ll" or "-line_length" */ line_length = fixed_arg; return; OPTION (10): /* "-sys" or "-system" */ system_flag = "1"b; /* User wants to be a system process. */ return; OPTION (11): /* "-nb" or "-number" */ number = fixed_arg; /* Number of similar devices to assign. */ if number > hbound (alist, 1) /* Is number too large? */ then goto BAD_ARG; /* Yes, error. */ return; OPTION (12): /* "-wt" or "-wait" */ wait_flag = "1"b; /* Remember that user wants to wait. */ if (fixed_arg = 0) | /* If no wait time specified. */ (fixed_arg > (24 * 60)) /* Or wait time greater tha allowed max? */ then max_num_waits = (24 * 60); /* Use default of 24 hours. */ else max_num_waits = fixed_arg; /* Use user's wait time. */ num_waits = 0; /* Initialize actual number of waits. */ return; OPTION (13): /* "-speed" */ do i = 1 to hbound (speed_values, 1); /* look for a valid speed value */ if fixed_arg = speed_values (i) then do; /* found one */ substr (speed, i, 1) = "1"b; return; end; end; goto BAD_ARG; BAD_ARG: ecode = error_table_$bad_arg; call error_rtn_ (ecode, "assign_resource", " ""^a"" is invalid for option ^a", argument, option); end PROCESS_ARG; end assign_resource;  attach_lv.pl1 11/04/82 1936.3rew 11/04/82 1606.5 57924 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ attach_lv: alv: procedure; /* This program is a command that may be called to attach a logical volume. * Created on 04/07/76 by Bill Silver. * * Its calling sequence is: * * attach_lv volume_name * * volume_name The name of the logical volume to be attached. */ /* Modified 6/82 by F. W. Martinson to check number of arguments */ /* AUTOMATIC DATA */ dcl 1 info_buffer like lv_info; /* An input logical volume info buffer. */ dcl 1 wait_list, /* Structure used to block. */ 2 num_chans fixed bin, /* Number of event channels to wait for. */ 2 channel fixed bin (71); /* The only channel we will use. */ dcl 1 event_data, /* Event message structure, not used. */ 2 channel_id fixed bin (71), 2 message fixed bin (71), 2 sender bit (36), 2 origin bit (36), 2 data_ptr ptr; dcl arg_len fixed bin; /* Length of an argument string. */ dcl arg_ptr ptr; /* Pointer to an argument string. */ dcl ecode fixed bin (35); /* error_table_ code. */ dcl num_args fixed bin; /* Number of command arguments. */ dcl rcp_id bit (36) aligned; /* RCP ID for this attach operation. */ dcl statex fixed bin; /* State of device assignment. */ dcl volume_name char (32); /* Volume name. */ /* BASED DATA */ dcl argument char (arg_len) based (arg_ptr); /* Used to reference argument string. */ /* EXTERNAL ENTRIES CALLED */ dcl cleanup condition; /* Used to unassign if trouble. */ dcl (addr) builtin; dcl (error_table_$noarg, error_table_$notacted, error_table_$too_many_args) fixed bin (35) external; dcl com_err_ entry options (variable); dcl convert_ipc_code_ entry (fixed bin (35)); dcl cu_$arg_count entry (fixed bin); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl ioa_ entry options (variable); dcl ipc_$block entry (ptr, ptr, fixed bin (35)); dcl ipc_$create_ev_chn entry (fixed bin (71), fixed bin (35)); dcl ipc_$delete_ev_chn entry (fixed bin (71), fixed bin (35)); dcl rcp_$attach_lv entry (ptr, fixed bin (71), bit (36) aligned, fixed bin (35)); dcl rcp_$check_attach_lv entry (bit (36) aligned, ptr, fixed bin, fixed bin (35)); dcl rcp_$detach_lv entry (bit (36) aligned, fixed bin (35)); /* */ %include rcp_lv_info; /* */ /* Begin command: attach_lv, alv */ ecode, /* Now initialize variables. */ wait_list.channel = 0; wait_list.num_chans = 1; lv_info_ptr = addr (info_buffer); /* Set up volume info structure. */ lv_info.version_num = rlvi_version_1; /* Assume version. */ lv_info.usage_time, /* These fields not used yet. */ lv_info.wait_time = 0; lv_info.system_flag = "0"b; /* System process concept not supported yet. */ call GET_VOLUME_INFO; /* Get volume name. */ if ecode ^= 0 then return; lv_info.volume_name = volume_name; rcp_id = "0"b; /* No RCP ID yet. */ on cleanup begin; /* If user quits detach logical volume. */ call CLEANUP; end; call ipc_$create_ev_chn (wait_list.channel, ecode); if ecode ^= 0 /* RCP needs an event channel. */ then do; /* But we don't have one. */ call convert_ipc_code_ (ecode); call com_err_ (ecode, "attach_lv", "Error creating event channel."); return; end; call rcp_$attach_lv (lv_info_ptr, wait_list.channel, rcp_id, ecode); if ecode ^= 0 /* Was attach started OK? */ then do; /* No. */ call com_err_ (ecode, "attach_lv", "Error attaching ^a", volume_name); call CLEANUP; return; end; ATTACH_LOOP: /* Loop until attachment completed. */ call rcp_$check_attach_lv (rcp_id, lv_info_ptr, statex, ecode); goto STATE (statex); /* Process current state of attachment. */ STATE (0): /* Attachment completed OK. */ rcp_id = "0"b; /* Don't detach now. */ call CLEANUP; /* Cleanup event channel. */ call ioa_ ("^a attached", volume_name); return; STATE (1): /* Short wait, block until wakeup comes. */ call ipc_$block (addr (wait_list), addr (event_data), ecode); if ecode ^= 0 /* Error in blocking is bad. */ then do; call convert_ipc_code_ (ecode); call com_err_ (ecode, "attach_lv", "Error waiting for attach."); call CLEANUP; return; end; goto ATTACH_LOOP; /* Waked up, check attach again. */ STATE (2): /* Long wait, don't support this yet. */ ecode = error_table_$notacted; STATE (3): /* Fatal error. */ call com_err_ (ecode, "attach_lv", "Error attaching ^a", volume_name); call CLEANUP; return; /* */ CLEANUP: procedure; /* This procedure is called when the attachment has been aborted. * If we have an RCP ID we will try to detach the volume we are attaching. * If we have created an event channel then we must delete it. */ if rcp_id ^= "0"b /* If we have an RCP ID try to detach. */ then call rcp_$detach_lv (rcp_id, ecode); if wait_list.channel = 0 then return; /* Did we created an event channel? */ call ipc_$delete_ev_chn (wait_list.channel, ecode); if ecode ^= 0 then do; call convert_ipc_code_ (ecode); call com_err_ (ecode, "attach_lv", "Deleting event channel."); end; end CLEANUP; /* */ GET_VOLUME_INFO: procedure; /* This procedure is called to get the volume name. */ call cu_$arg_count (num_args); /* Get number of arguments. */ if num_args ^= 1 then do; /* Is there a volume name argument. */ if num_args = 0 then ecode = error_table_$noarg; /* No. */ else ecode = error_table_$too_many_args; call com_err_ (ecode, "attach_lv", "One argument required"); return; end; call cu_$arg_ptr (1, arg_ptr, arg_len, ecode); /* Get volume name argument. */ if ecode ^= 0 then do; call com_err_ (ecode, "attach_lv", "Error getting volume name argument"); return; end; volume_name = argument; /* Save the volume name argument. */ end GET_VOLUME_INFO; end attach_lv;  build_resource_desc_.pl1 08/14/86 1057.2rew 08/14/86 1048.9 378828 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-07-28,Hartogs), approve(86-07-28,MCR7463), audit(86-08-06,Lippard), install(86-08-14,MR12.0-1123): Make changes to disallow specifying less than 1 resource for reservation. END HISTORY COMMENTS */ build_resource_desc_: proc (P_inargs, P_areap, P_cargp, P_rscp, P_cargidx, P_errmsg, P_code); /* Written at some point or another by R.J.C. Kissel */ /* Last modified 06/17/81 by C. D. Tavares to make "" as an acs_path not be expanded to [wd]. */ dcl P_inargs dim (*) char (*) varying; dcl error_table_$unimplemented_version fixed bin (35) external; P_rscp = null (); P_errmsg = ""; P_code = error_table_$unimplemented_version; return; /* Local Variables */ dcl DUMB_acs_path char (168); /* To pacify Tavares. */ dcl acarg_idx fixed bin; /* Index into the additional control arg array. */ dcl apply_defaults bit (1) aligned; /* True if defaults to be applied to resource_descriptions */ dcl argument char (256) varying; /* Holds arguments to be processed. */ dcl array_args bit (1); /* True if the arguments are in the array, P_inargs. */ dcl attr_type fixed bin; /* 0-absolute, 1-relative, 2-multiple. */ dcl carg_idx fixed bin; /* Index into the resource description control arg array. */ dcl cargs_given bit (1); /* True if any control arguments have been given. */ dcl code fixed bin (35); /* System status code. */ dcl resource_type char (32); /* Used to get primary resource type. */ dcl exists bit (1); /* Indicates wheter or not the argument exists. */ dcl item_idx fixed bin; /* Index into resource_descriptions items. */ dcl names_given bit (1); /* True if any names of resources are given. */ dcl number_given bit (1); /* True if the "-nb" control arg is specified. */ dcl num_of_rscs fixed bin; /* The number of resources described by the caller. */ dcl nvals fixed bin; /* Number of values to skip index. */ dcl reservation bit (1); /* True if a reservation structure is needed. */ dcl 1 rsc_info aligned like resource_descriptions.item; dcl caller_area area (261129) based (P_areap); /* Global Variables */ dcl arg_idx fixed bin; /* Get_Next_Arg..index of arg in command line. */ dcl name_stack_ptr ptr; /* Save_Name, Get_Name..storage pointer. */ dcl name_tail_ptr ptr; /* Save_Name, Get_Name..storage pointer. */ dcl nargs fixed bin; /* Get_Next_Arg..number of args in command line. */ dcl rdp_stack_ptr ptr; /* Save_Pointer, Get_Pointer..storage pointer. */ dcl rdp_tail_ptr ptr; /* Save_Pointer, Get_Pointer..storage pointer. */ /* Global Based Variables */ dcl 1 acargs aligned based (P_cargp), 2 number fixed bin, 2 arg (0b refer (acargs.number)), 3 long_name char (32), 3 short_name char (32), 3 nvals fixed bin; dcl acarg_indicies (acargs.number) based (P_cargidx); /* Global Constants */ dcl C_rd_cargs (24) char (32) internal static options (constant) initial ("-acc", /* 1 */ "-access_class", /* 2 */ "-acs_path", /* 3 */ "-alloc", /* 4 */ "-attr", /* 5 */ "-attributes", /* 6 */ "-charge_type", /* 7 */ "-com", /* 8 */ "-comment", /* 9 */ "-crgtp", /* 10 */ "-loc", /* 11 */ "-location", /* 12 */ "-lock", /* 13 */ "-nb", /* 14 */ "-number", /* 15 */ "-ow", /* 16 */ "-owner", /* 17 */ "-pacc", /* 18 */ "-pattr", /* 19 */ "-potential_access_class", /* 20 */ "-potential_attributes", /* 21 */ "-release_lock", /* 22 */ "-rll", /* 23 */ "-uid" /* 24 */); /* Include Files */ %include resource_control_desc; /* External Entries */ dcl absolute_pathname_$add_suffix entry (char (*), char (*), char (*), fixed bin (35)); dcl convert_authorization_$from_string_range entry (bit (72) aligned dim (2), char (*), fixed bin (35)); dcl cu_$arg_count_rel entry (fixed bin, 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 cv_rcp_attributes_$from_string entry (char (*), bit (72) dim (2) aligned, char (*) varying, fixed bin (35)); dcl cv_rcp_attributes_$modify_rel entry (bit (72) dim (2) aligned, bit (72) dim (4) aligned, bit (72) dim (2) aligned); dcl cv_rcp_attributes_$from_string_rel entry (char (*), bit (72) dim (4) aligned, char (*) varying, fixed bin (35)); dcl cv_rcp_attributes_$test_valid entry (char (*), bit (72) dim (2) aligned, fixed bin, fixed bin (35)); dcl get_group_id_ entry () returns (char (32)); dcl resource_info_$defaults entry (char (*), char (*), ptr, fixed bin, fixed bin (35)); dcl resource_info_$get_primary_type entry (char (*), char (*), fixed bin (35)); /* External Constants */ dcl error_table_$badcall fixed bin (35) external; dcl error_table_$bad_index fixed bin (35) external; dcl error_table_$badopt fixed bin (35) external; dcl error_table_$inconsistent fixed bin (35) external; dcl error_table_$rcp_attr_not_permitted fixed bin (35) external; dcl error_table_$rcp_bad_attributes fixed bin (35) external; dcl error_table_$bad_conversion fixed bin (35) external; dcl error_table_$noarg fixed bin (35) external; /* Builtin Functions and Conditions */ dcl (convert, bit, divide, fixed, hbound, lbound, length, maxlength, null, rtrim, substr, unspec) builtin; dcl (area, cleanup, conversion) condition; from_arglist: entry (P_clinep, P_areap, P_cargp, P_rscp, P_apply_defaults, P_cargidx, P_errmsg, P_code); dcl ( P_clinep ptr, /* Input -- to caller's command line. */ P_areap ptr, /* Input -- to caller's area. */ P_cargp ptr, /* Input -- to additional control arg descriptions. */ P_rscp ptr, /* Output -- to resource_descriptions structure. */ P_apply_defaults bit (1) aligned, /* Input -- ON if defaults wanted in resource_descriptions */ P_cargidx ptr, /* Output -- to an array of indicies for the additional cargs. */ P_errmsg char (*) varying, /* Output -- descriptive error message. */ P_code fixed bin (35) /* Output -- standard status code. */ ) parameter; /* D_E_S_C_R_I_P_T_I_O_N_ This subroutine takes a pointer to a command line and uses cu_$arg_ptr_rel to get individual arguments. It parses the command line looking first at the additional control arguments, if any are specified, and then at the control arguments for a resource description. Resource description control arguments and non-control arguments are used to fill in a resource_descriptions structure. This structure will be allocated in the caller supplied area and a pointer returned. If additional control arguments are found then the index of the argument in the command line is returned in the caller supplied array. An error is recognized if there are not enough arguments left on the command line to supply the values required by the control argument. Otherwise, these values are simply skipped and parsing continues. It is the caller's responsibility to pick up and process these control arguments when control is returned to him. A zero value for the index means that the corresponding control argument was not found. The returned error message may be used along with the error code in a call to com_err_ to output a meaningful error message. J_O_U_R_N_A_L_I_Z_A_T_I_O_N_ 1) Written 10/78 by R.J.C. Kissel. 2) Modified 3/79 by R.J.C. Kissel to get and use the defaults in the RTDT. 3) Modified 08/79 by C. D. Tavares to only apply defaults when required, not all the time. */ call Initialize (); apply_defaults = P_apply_defaults; rdp_stack_ptr = null (); /* These are only used by the Cleanup_Handler */ rdp_tail_ptr = null (); /* for this entry point. */ array_args = "0"b; reservation = "0"b; arg_idx = 0; call cu_$arg_count_rel (nargs, P_clinep); on cleanup call Cleanup_Handler (); call Process_Resource_Spec (); /* All the arguments have been successfully processed, now we will allocate the structure that the caller wants to have filled in. We can do this because now we know the number of resources it must describe. Then we will fill in the information we have found. Note that if the caller gave us a null area pointer then we are done and will just return. */ call Fill_Resource_Desc (); P_rscp = resource_desc_ptr; P_errmsg = ""; /* Everything is all right. */ P_code = 0; return; reserve: entry (P_inargs, P_areap, P_cargp, P_rscp, P_resp, P_cargidx, P_errmsg, P_code); dcl P_resp ptr parameter; /* Output -- to resource reservation structure. */ /* D_E_S_C_R_I_P_T_I_O_N_ This subroutine perfors many of the same functions as the from_arglist entry point. However, the arguments are taken from an input array rather than a command line. Also, this entry must build a resource reservation structure, and it must handle multiple resource specifications separated by the -resource_type or -rsct control argument. J_O_U_R_N_A_L_I_Z_A_T_I_O_N_ 1) Written 12/78 by R.J.C. Kissel. 2) Modified 3/79 by R.J.C. Kissel to get and use the defaults in the RTDT. */ /* Local Variables */ dcl rdp ptr; /* To the saved resource_descriptions structures. */ dcl total_rscs fixed bin; /* Total of num_of_rscs for each resource specification. */ dcl mitem_idx fixed bin; /* Item index for the master resource_description structure. */ rdp_stack_ptr = null (); rdp_tail_ptr = null (); array_args = "1"b; /* The arguments are in an array. */ reservation = "1"b; /* Multiple resource specifications are allowed. */ arg_idx = 0; total_rscs = 0; nargs = hbound (P_inargs, 1); call Initialize (); /* To close a small cleanup window. */ apply_defaults = "0"b; on cleanup call Cleanup_Handler (); /* This loop processes all of the resource specifications in the resource description. They are separated by the -resource_type or -rsct control argument which Process_Resource_Spec recognizes. The arg_idx keeps track of how far we have gotten. A pointer to the resource_descriptions structure for each specification is saved for later use. */ do while (arg_idx < nargs); /* arg_idx is controlled by Process_Resource_Spec. */ call Initialize (); call Process_Resource_Spec (); call Fill_Resource_Desc (); call Save_Pointer (resource_desc_ptr); total_rscs = total_rscs + num_of_rscs; end; /* Now that we know everything we can allocate the final structures and fill them in from the saved information. */ if P_areap ^= null () then do; /* Allocate stuff for the caller. */ Resource_count = total_rscs; on area goto ERROR_area; allocate resource_descriptions in (caller_area) set (resource_desc_ptr); allocate reservation_description in (caller_area) set (resource_res_ptr); revert area; /* Now copy the information we have gathered. */ call Get_Pointer (rdp); if rdp = null () then goto ERROR_badone; /* There must be at least one at hhis point. */ mitem_idx = 1; do while (rdp ^= null ()); /* Loop through all saved structures. */ do item_idx = 1 to rdp -> resource_descriptions.n_items; resource_descriptions.item (mitem_idx) = rdp -> resource_descriptions.item (item_idx); mitem_idx = mitem_idx + 1; end; free rdp -> resource_descriptions; call Get_Pointer (rdp); end; /* Fill in the constant information in the two structures. */ resource_descriptions.version_no = resource_desc_version_1; reservation_description.version_no = resource_res_version_1; reservation_description.reserved_for = get_group_id_ (); reservation_description.reserved_by = get_group_id_ (); reservation_description.reservation_id = 0b; reservation_description.group_starting_time = 0b; reservation_description.asap_duration = 0b; reservation_description.flags.auto_expire = "1"b; reservation_description.flags.asap = "0"b; reservation_description.flags.rel = "0"b; reservation_description.flags.sec = "0"b; reservation_description.reservation_group (*).starting_time = 0b; reservation_description.reservation_group (*).duration = 0b; end; /* Allocate stuff for the caller. */ else do; /* Caller wants nothing. */ resource_desc_ptr = null (); resource_res_ptr = null (); end; /* Caller wants nothing. */ P_rscp = resource_desc_ptr; P_resp = resource_res_ptr; /* P_errmsg has already been initialized to the null string in Initialize. We don't want to set it here because it may contain some auxillary information that is described in the comment in Process_Resource_Spec in the attribute processing section. */ P_code = 0; return; /* All error handling is done here. There is a separate label for each possible error. These are in the main program so that the subroutines can make non-local transfers out of the current environment and then return to the caller after building the error message. */ ERROR_acarg: P_errmsg = "After " || rtrim (acargs.arg (acarg_idx).long_name) || "."; P_code = error_table_$noarg; call Cleanup_Handler (); return; ERROR_allocarg: P_errmsg = argument || "not on or off."; P_code = error_table_$badopt; call Cleanup_Handler (); return; ERROR_area: P_errmsg = "Error allocating storage necessary for program operation."; P_code = error_table_$badcall; call Cleanup_Handler (); return; ERROR_attr: P_errmsg = "Bad attribute specification: " || argument || "."; P_code = code; call Cleanup_Handler (); return; ERROR_badarg: P_errmsg = argument; P_code = error_table_$badopt; call Cleanup_Handler (); return; ERROR_badnb: P_errmsg = argument; P_code = error_table_$bad_conversion; call Cleanup_Handler (); return; ERROR_badone: P_errmsg = "From build_resource_desc_."; P_code = error_table_$bad_index; call Cleanup_Handler (); return; ERROR_cagiv: P_errmsg = "resource name " || argument || " appears after a control argument."; P_code = error_table_$badcall; call Cleanup_Handler (); return; ERROR_defaults: P_errmsg = "Error obtaining defaults for " || rtrim (rsc_info.type) || "."; P_code = code; call Cleanup_Handler (); return; ERROR_exterr: P_errmsg = ""; /* Error produced by an external call, just use code. */ P_code = code; call Cleanup_Handler (); return; ERROR_lownb: P_errmsg = "Number must be 1 or greater to be valid."; P_code = error_table_$bad_conversion; call Cleanup_Handler (); return; ERROR_noarg: P_errmsg = "After " || argument; P_code = error_table_$noarg; call Cleanup_Handler (); return; ERROR_noname: P_errmsg = "After -name."; P_code = error_table_$noarg; call Cleanup_Handler (); return; ERROR_nonb: P_errmsg = "-number with explicit names."; P_code = error_table_$inconsistent; call Cleanup_Handler (); return; ERROR_notype: P_errmsg = "A resource type must always be specified."; P_code = error_table_$badcall; call Cleanup_Handler (); return; ERROR_pacc: P_errmsg = "Bad access bounds specification: " || argument || "."; P_code = code; call Cleanup_Handler (); return; ERROR_pattr: P_errmsg = argument; P_code = code; call Cleanup_Handler (); return; ERROR_prota: P_errmsg = """*"" not allowed in potential attributes."; P_code = error_table_$rcp_attr_not_permitted; call Cleanup_Handler (); return; ERROR_type: P_errmsg = "Unrecognized resource type: " || argument || "."; P_code = code; call Cleanup_Handler (); return; ERROR_uid: P_errmsg = argument; P_code = error_table_$bad_conversion; call Cleanup_Handler (); return; %page; Initialize: proc (); /* All the local and global variables are initialized here, unless they are assigned to at their first use. */ argument = ""; num_of_rscs = 0b; names_given = "0"b; number_given = "0"b; cargs_given = "0"b; name_stack_ptr = null (); name_tail_ptr = null (); resource_desc_ptr = null (); resource_res_ptr = null (); unspec (rsc_info) = "0"b; /* Now we will initialize all the cahracter strings in the structure to null string instead of zero bit strings. This will make the output easier to read. */ rsc_info.type = ""; rsc_info.name = ""; rsc_info.owner = ""; rsc_info.acs_path = ""; rsc_info.location = ""; rsc_info.comment = ""; rsc_info.charge_type = ""; end Initialize; Process_Resource_Spec: proc (); /* The resource type must be the first argument and must always be present. volume or a device. The -resource_type or -rsct control argument is optional and will be ignored. */ call Get_Next_Arg (argument, exists); /* Get the type. */ if ^exists then goto ERROR_notype; if argument = "-resource_type" | argument = "-rsct" then call Get_Next_Arg (argument, exists); call resource_info_$get_primary_type ((argument), resource_type, code); /* Check the type. */ if code ^= 0 then goto ERROR_type; rsc_info.type = resource_type; /* use primary type */ /* Now process the rest of the arguments supplied by the caller. If there are any names they must be first, before any control arguments. Anything beginning with "-" unless it is preceded by "-name" or "-nm" is assumed to be a control argument, anything else is assumed to be a name. A control argument is checked against the additional control argument array supplied by the caller first, and then against the known resource description control arguments. If this is a reservation then multiple resource types may appear separated by -resource_type or -rsct. Therefore, if "reservation" is true and one of these control arguments is found, we return to the caller because we have processed a complete resource specification. Notice that "arg_idx" points to the -resource_type or -rsct argument. */ call Get_Next_Arg (argument, exists); do while (exists); /* Loop through arguments. */ if reservation & (argument = "-resource_type" | argument = "-rsct") then goto DONE; if substr (argument, 1, 1) ^= "-" | argument = "-name" | argument = "-nm" then do; /* This is a name. */ if argument = "-name" | argument = "-nm" then do; /* Get the real name. */ call Get_Next_Arg (argument, exists); if ^exists then goto ERROR_noname; end; /* Get the real name. */ if cargs_given then goto ERROR_cagiv; /* Any names must be before control args. */ call Save_Name (argument); num_of_rscs = num_of_rscs + 1; names_given = "1"b; end; /* This is a name. */ else if Is_Acarg (argument, acarg_idx) then do; /* Look for additional cargs before cargs. */ cargs_given = "1"b; acarg_indicies (acarg_idx) = arg_idx; do nvals = 1 to acargs.arg (acarg_idx).nvals; /* Skip over values. */ call Get_Next_Arg (argument, exists); if ^exists then goto ERROR_acarg; /* Make sure they are there. */ end; /* Skip over values. */ end; /* Look for additional cargs before cargs. */ else if Is_Carg (argument, carg_idx) then do; /* This is a resource description carg. */ if carg_idx < lbound (CARG, 1) | carg_idx > hbound (CARG, 1) then goto ERROR_badone; /* Program malfunction. */ cargs_given = "1"b; goto CARG (carg_idx); /* Essentially a case statement. */ CARG (2): CARG (1): /* -access_class, -acc */ call Get_Next_Arg (argument, exists); if ^exists then goto ERROR_noarg; call convert_authorization_$from_string_range (rsc_info.aim_range, (argument), code); if code ^= 0 then goto ERROR_pacc; rsc_info.given.aim_range = "1"b; goto ESAC; CARG (3): /* -acs_path */ call Get_Next_Arg (argument, exists); if ^exists then goto ERROR_noarg; if argument = "" then rsc_info.acs_path = ""; else do; call absolute_pathname_$add_suffix ((argument), "acs", DUMB_acs_path, code); if code ^= 0 then goto ERROR_exterr; rsc_info.acs_path = DUMB_acs_path; end; rsc_info.given.acs_path = "1"b; goto ESAC; CARG (4): /* -alloc */ call Get_Next_Arg (argument, exists); if ^exists then goto ERROR_noarg; if argument = "on" then rsc_info.user_alloc = "1"b; else if argument = "off" then rsc_info.user_alloc = "0"b; else goto ERROR_allocarg; rsc_info.given.user_alloc = "1"b; goto ESAC; CARG (6): CARG (5): /* -attributes, -attr */ call Get_Next_Arg (argument, exists); if ^exists then goto ERROR_noarg; call cv_rcp_attributes_$from_string_rel ((rsc_info.type), rsc_info.desired_attributes, argument, code); if code ^= 0 then goto ERROR_attr; rsc_info.given.desired_attributes = "1"b; /* Now we will do a kludgey thing. In order that parse_resource_desc_ can know that the user specified attributes, we will set the status code for this resource to 1. This is necessary because currently either names or attributes are allowed but not both, and we will lose the information about what the user said because setting default attributes always says that attributes were given. Finally, we need to know that attributes were given in rcp_reserve_ so we can do the right thing. This code can be eliminated when both names and attributes are allowed in a resource type specification. */ rsc_info.status_code = 1; goto ESAC; CARG (7): CARG (10): /* -charge_type, -crgtp */ call Get_Next_Arg (argument, exists); if ^exists then goto ERROR_noarg; rsc_info.charge_type = argument; rsc_info.given.charge_type = "1"b; goto ESAC; CARG (9): CARG (8): /* -comment, -com */ call Get_Next_Arg (argument, exists); if ^exists then goto ERROR_noarg; rsc_info.comment = argument; rsc_info.given.comment = "1"b; goto ESAC; CARG (12): CARG (11): /* -location, -loc */ call Get_Next_Arg (argument, exists); if ^exists then goto ERROR_noarg; rsc_info.location = argument; rsc_info.given.location = "1"b; goto ESAC; CARG (13): /* -lock */ call Get_Next_Arg (argument, exists); if ^exists then goto ERROR_noarg; if argument = "on" then rsc_info.usage_lock = "1"b; else if argument = "off" then rsc_info.usage_lock = "0"b; else goto ERROR_allocarg; rsc_info.given.usage_lock = "1"b; goto ESAC; CARG (14): CARG (15): /* -number, -nb */ if names_given then goto ERROR_nonb; call Get_Next_Arg (argument, exists); if ^exists then goto ERROR_noarg; on conversion goto ERROR_badnb; if convert (num_of_rscs, argument) < 1 then goto ERROR_lownb; num_of_rscs = num_of_rscs + convert (num_of_rscs, argument); revert conversion; number_given = "1"b; /* For later use. */ goto ESAC; CARG (16): CARG (17): /* -owner, -ow */ call Get_Next_Arg (argument, exists); if ^exists then goto ERROR_noarg; rsc_info.owner = argument; rsc_info.given.owner = "1"b; goto ESAC; CARG (18): CARG (20): /* -potential_access_class, -pacc */ call Get_Next_Arg (argument, exists); if ^exists then goto ERROR_noarg; call convert_authorization_$from_string_range (rsc_info.potential_aim_range, (argument), code); if code ^= 0 then goto ERROR_pacc; rsc_info.given.potential_aim_range = "1"b; goto ESAC; CARG (19): CARG (21): /* -potential_attributes, -pattr */ call Get_Next_Arg (argument, exists); if ^exists then goto ERROR_noarg; /* Convert the caller supplied attribute string, we will use rsc_info.attributes as temporary storage since it has the right dimensionality. It will be cleaned up later. */ call cv_rcp_attributes_$from_string ((rsc_info.type), rsc_info.attributes, argument, code); if code ^= 0 then goto ERROR_pattr; /* Now test the second (protected attributes) string returned. If any "1" bits are present then the caller specified an "*" which is not allowed for potential attributes. Otherwise, we are only interested in the first (current attributes) string. */ if rsc_info.attributes (2) then goto ERROR_prota; /* Now test the attributes string to make sure it is absolute or multiple since that is what a potential attribute string must be. */ call cv_rcp_attributes_$test_valid ((rsc_info.type), rsc_info.attributes, attr_type, code); if attr_type = 1 /* 1 is a relative attribute string. */ then code = error_table_$rcp_bad_attributes; if code ^= 0 then goto ERROR_pattr; rsc_info.potential_attributes = rsc_info.attributes (1); rsc_info.attributes (*) = "0"b; /* Clean up after ourselves. */ rsc_info.given.potential_attributes = "1"b; goto ESAC; CARG (22): CARG (23): /* -release_lock, -rll */ call Get_Next_Arg (argument, exists); if ^exists then goto ERROR_noarg; if argument = "on" then rsc_info.release_lock = "1"b; else if argument = "off" then rsc_info.release_lock = "0"b; else goto ERROR_allocarg; rsc_info.given.release_lock = "1"b; goto ESAC; CARG (24): /* -uid */ call Get_Next_Arg (argument, exists); if ^exists then goto ERROR_noarg; rsc_info.uid = bit (fixed (cv_oct_check_ ((argument), code), 36)); if code ^= 0 then goto ERROR_uid; rsc_info.given.uid = "1"b; goto ESAC; ESAC: /* End of the pseudo case statement. */ end; /* This is a resource description carg. */ else goto ERROR_badarg; /* Unrecognized argument. */ call Get_Next_Arg (argument, exists); /* Keep the loop going. */ end; /* Loop through arguments. */ /* Now that everything is ok make some final checks and settings. If neither the number of resources no the names of any resources have been specified then the default number of resources is one. Also, if any names have been given then we can set the names given bit in rsc_info because it must be on for each item in the resource_descriptions structure. */ DONE: /* Only called if reservation = "1"b and a -resource_type or -rsct argument is found. */ if ^names_given & ^number_given then num_of_rscs = 1b; rsc_info.given.name = names_given; end Process_Resource_Spec; Fill_Resource_Desc: proc (); if P_areap ^= null () then do; /* Caller wants the structure. */ Resource_count = num_of_rscs; on area goto ERROR_area; allocate resource_descriptions in (caller_area) set (resource_desc_ptr); revert area; /* Now set the constant information and defaults in the structure. Do this by looping through the structure to set up each item. If desired attributes are given, they must be applied to the defaults in a special way. Potential attributes are never a relative attribute string so defaults need not be used. Note that n_items is already set by the allocation, and the type is set by setting the defaults. */ do item_idx = lbound (resource_descriptions.item, 1) to hbound (resource_descriptions.item, 1) by 1; /* Set all items to null values. */ unspec (resource_descriptions.item (item_idx)) = "0"b; resource_descriptions.item (item_idx).type = ""; resource_descriptions.item (item_idx).name = ""; resource_descriptions.item (item_idx).owner = ""; resource_descriptions.item (item_idx).acs_path = ""; resource_descriptions.item (item_idx).location = ""; resource_descriptions.item (item_idx).comment = ""; resource_descriptions.item (item_idx).charge_type = ""; end; /* Set all items to null values. */ resource_descriptions.version_no = resource_desc_version_1; do item_idx = lbound (resource_descriptions.item, 1) to hbound (resource_descriptions.item, 1) by 1; /* Fill in each item. */ resource_descriptions.item (item_idx).type = rsc_info.type; if rsc_info.given.uid then resource_descriptions.item (item_idx).uid = rsc_info.uid; if rsc_info.given.potential_attributes then resource_descriptions.item (item_idx).potential_attributes = rsc_info.potential_attributes; if rsc_info.given.desired_attributes then do; /* Apply these specially. */ /* Copy these for now to get them in the right form. */ resource_descriptions.item (item_idx).attributes (1) = resource_descriptions.item (item_idx).desired_attributes (1); resource_descriptions.item (item_idx).attributes (2) = resource_descriptions.item (item_idx).desired_attributes (2); call cv_rcp_attributes_$modify_rel (resource_descriptions.item (item_idx).attributes (*), rsc_info.desired_attributes, resource_descriptions.item (item_idx).attributes (*)); /* Now copy the results back where they belong. */ resource_descriptions.item (item_idx).desired_attributes (1) = resource_descriptions.item (item_idx).attributes (1); resource_descriptions.item (item_idx).desired_attributes (2) = resource_descriptions.item (item_idx).attributes (2); resource_descriptions.item (item_idx).desired_attributes (3) = "0"b; resource_descriptions.item (item_idx).desired_attributes (4) = "0"b; /* Now clean up our mess. */ resource_descriptions.item (item_idx).attributes (*) = "0"b; end; /* Apply these specially. */ if rsc_info.given.potential_aim_range then resource_descriptions.item (item_idx).potential_aim_range (*) = rsc_info.potential_aim_range (*); if rsc_info.given.aim_range then resource_descriptions.item (item_idx).aim_range (*) = rsc_info.aim_range (*); if rsc_info.given.owner then resource_descriptions.item (item_idx).owner = rsc_info.owner; if rsc_info.given.acs_path then resource_descriptions.item (item_idx).acs_path = rsc_info.acs_path; if rsc_info.given.location then resource_descriptions.item (item_idx).location = rsc_info.location; if rsc_info.given.comment then resource_descriptions.item (item_idx).comment = rsc_info.comment; if rsc_info.given.charge_type then resource_descriptions.item (item_idx).charge_type = rsc_info.charge_type; if rsc_info.given.usage_lock then resource_descriptions.item (item_idx).usage_lock = rsc_info.usage_lock; if rsc_info.given.release_lock then resource_descriptions.item (item_idx).release_lock = rsc_info.release_lock; if rsc_info.given.user_alloc then resource_descriptions.item (item_idx).user_alloc = rsc_info.user_alloc; /* For now we will copy the given bits, although they really should be or'ed with the ones set by the defaults. Also, we will always set the desired attributes bit on so that rcp_reserve_ can use the defaults. */ resource_descriptions.item (item_idx).given = rsc_info.given; if names_given then do; /* Fill in the name. */ call Get_Name (argument, exists); if ^exists then goto ERROR_badone; resource_descriptions.item (item_idx).name = argument; resource_descriptions.item (item_idx).given.name = "1"b; end; /* Fill in the name. */ else resource_descriptions.item (item_idx).name = ""; if apply_defaults then do; call resource_info_$defaults ((rsc_info.type), "", resource_desc_ptr, item_idx, code); if code ^= 0 then goto ERROR_defaults; end; end; /* Fill in each item. */ end; /* Caller wants the structure. */ end Fill_Resource_Desc; Get_Next_Arg: proc (P_arg, P_arg_exists); dcl ( P_arg char (*) varying, /* Output -- the argument found. */ P_arg_exists bit (1) /* Output -- there was an argument to find. */ ) parameter; /* D_E_S_C_R_I_P_T_I_O_N_ This internal procedure does everything necessary to obtain the next argument, either from the command line or an input array of character strings. Certain variables are declared globally in the main program which should be "own" variables for this procedure because of a deficiency in Multics PL1. */ /* Local Variables */ dcl based_arg char (arg_len) based (arg_ptr); dcl arg_len fixed bin; dcl arg_ptr ptr; arg_idx = arg_idx + 1; /* We want the next one. */ if arg_idx > nargs then do; /* No more args. */ arg_idx = arg_idx - 1; /* Always point at a good argument, or 0. */ P_arg_exists = "0"b; /* P_arg is left alone for error processing if necessary. */ end; /* No more args. */ else do; /* Get the next arg. */ if reservation then do; /* Argument in array. */ P_arg = P_inargs (arg_idx); P_arg_exists = "1"b; end; /* Argument in array. */ else do; /* Argument in command line. */ call cu_$arg_ptr_rel (arg_idx, arg_ptr, arg_len, code, P_clinep); if code ^= 0 then goto ERROR_exterr; if arg_len > maxlength (P_arg) then ; /* May want to log this sometime. */ P_arg = based_arg; P_arg_exists = "1"b; end; /* Argument in command line. */ end; /* Get the next arg. */ end Get_Next_Arg; Save_Name: proc (P_name); dcl P_name char (*) varying parameter; /* Input -- name to save. */ /* D_E_S_C_R_I_P_T_I_O_N_ This internal subroutine saves character string arguments which are passed to it. It does so by allocating stroage and building a LIFO list of names. Note that name_stack_ptr and name_tail_ptr are initialized in the main program to "null". */ /* Local Variables */ dcl name_len fixed bin; /* Length of the name to store. */ dcl nip ptr; /* Name item pointer. */ dcl 1 name_item aligned based, 2 len fixed bin, 2 name char (name_len refer (name_item.len)), 2 next ptr; name_len = length (P_name); on area goto ERROR_area; allocate name_item set (nip); revert area; nip -> name_item.name = P_name; nip -> name_item.next = null (); if name_stack_ptr = null () then name_stack_ptr = nip; /* Only done the first time. */ if name_tail_ptr ^= null () then name_tail_ptr -> name_item.next = nip; name_tail_ptr = nip; end Save_Name; Get_Name: proc (P_name, P_name_exists); dcl ( P_name char (*) varying, /* Output -- the next name in the list. */ P_name_exists bit (1) /* Output -- whether or not there is a name. */ ) parameter; /* D_E_S_C_R_I_P_T_I_O_N_ This internal subroutine gets the next name from the LIFO list built by Save_Name. It frees the list as it goes. It also sets a flag to indicate whether or not a name was found. */ /* Local Variables */ dcl nip ptr; /* Name item pointer. */ dcl 1 name_item aligned based, 2 len fixed bin, 2 name char (0b refer (name_item.len)), 2 next ptr; if name_stack_ptr = null () then do; P_name = ""; P_name_exists = "0"b; end; else do; nip = name_stack_ptr; P_name = nip -> name_item.name; P_name_exists = "1"b; name_stack_ptr = nip -> name_item.next; free nip -> name_item; end; end Get_Name; Save_Pointer: proc (P_ptr); dcl P_ptr ptr parameter; /* Input -- the pointer to be saved. */ /* Local Variables */ dcl rip ptr; dcl 1 rdp_item aligned based, 2 next ptr, 2 data ptr; on area goto ERROR_area; allocate rdp_item set (rip); revert area; rip -> rdp_item.data = P_ptr; rip -> rdp_item.next = null (); if rdp_stack_ptr = null () then rdp_stack_ptr = rip; /* Only done the first time. */ if rdp_tail_ptr ^= null () then rdp_tail_ptr -> rdp_item.next = rip; rdp_tail_ptr = rip; end Save_Pointer; Get_Pointer: proc (P_ptr); dcl P_ptr ptr parameter; /* Output -- the next pointer in the list. */ /* Local Variables */ dcl rip ptr; dcl 1 rdp_item aligned based, 2 next ptr, 2 data ptr; if rdp_stack_ptr = null () then P_ptr = null (); else do; rip = rdp_stack_ptr; P_ptr = rip -> rdp_item.data; rdp_stack_ptr = rip -> rdp_item.next; free rip -> rdp_item; end; end Get_Pointer; Is_Acarg: proc (P_arg, P_idx) returns (bit (1)); dcl ( P_arg char (*) varying, /* Input -- argument to check. */ P_idx fixed bin /* Output -- index in caller supplied array. */ ) parameter; /* D_E_S_C_R_I_P_T_I_O_N_ This internal subroutine checks th input argument against a caller supplied array of additional control argument names. The index in the caller supplied array is returned as well as an indication as to whether or not a match was found. At some time we may wany to require that the input array be alphabetical and do a binary search. */ /* Local Variables */ dcl idx fixed bin; dcl found bit (1); dcl num_args fixed bin; if P_cargp = null | P_cargidx = null () then do; /* No array given. */ P_idx = 0; found = "0"b; end; /* No array given. */ else do; /* Array given. */ num_args = P_cargp -> acargs.number; do idx = 1 to num_args while (P_arg ^= P_cargp -> acargs.arg (idx).long_name & P_arg ^= P_cargp -> acargs.arg (idx).short_name); end; if idx > num_args then do; /* Did not find it. */ P_idx = 0; found = "0"b; end; /* Did not find it. */ else do; /* Found it. */ P_idx = idx; found = "1"b; end; /* Found it. */ end; /* Array given. */ return (found); end Is_Acarg; Is_Carg: proc (P_arg, P_idx) returns (bit (1)); dcl ( P_arg char (*) varying, /* Input -- argument to check. */ P_idx fixed bin /* Output -- index into the known cargs. */ ) parameter; /* D_E_S_C_R_I_P_T_I_O_N_ This internal subroutine checks the input argument against the known list of resource description control arguments. The index in this list is returned as well as an indication of whether or not a match was found in the list. A binary search will be used so the list of control arguments must always be alphabetical. Notice that by definition of arrays, lbound, and hbound that the loop is executed at least once. */ /* Local Variables */ dcl lb fixed bin; /* Lower bound. */ dcl mp fixed bin; /* Midpoint. */ dcl ub fixed bin; /* Upper bound. */ lb = lbound (C_rd_cargs, 1); /* Lower bound for the search. */ ub = hbound (C_rd_cargs, 1); /* Upper bound for the search. */ do while (lb <= ub); mp = divide (lb + ub, 2, 17); /* Midpoint for the search. */ if P_arg = C_rd_cargs (mp) then do; P_idx = mp; /* Found. */ return ("1"b); end; if P_arg < C_rd_cargs (mp) then ub = mp - 1; else lb = mp + 1; end; P_idx = 0; /* Not found. */ return ("0"b); end Is_Carg; Cleanup_Handler: proc (); /* D_E_S_C_R_I_P_T_I_O_N_ This internal procedure cleans up before returning to the caller. Essentially, this just means checking for any storage which may have been allocated and freeing it if necessary. It is not called if the program terminates normally. Any error codes or conditions produced by this subroutine will either be handled immediately or ignored as appropriate. */ dcl nip ptr; /* Name item pointer. */ dcl 1 name_item aligned based, 2 len fixed bin, 2 name char (0b refer (name_item.len)), 2 next ptr; dcl rip ptr; /* Rdp item pointer. */ dcl 1 rdp_item aligned based, 2 next ptr, 2 data ptr; dcl rdp ptr; if resource_desc_ptr ^= null () then free resource_descriptions in (caller_area); if resource_res_ptr ^= null () then free reservation_description in (caller_area); do while (name_stack_ptr ^= null ()); nip = name_stack_ptr; name_stack_ptr = nip -> name_item.next; free nip -> name_item; end; do while (rdp_stack_ptr ^= null ()); rip = rdp_stack_ptr; rdp_stack_ptr = rip -> rdp_item.next; rdp = rip -> rdp_item.data; if rdp ^= null () then free rdp -> resource_descriptions in (caller_area); free rip -> rdp_item; end; /* Set the output parameters except for the error message and code. */ if reservation then P_resp = null (); P_rscp = null (); if P_cargidx ^= null () & P_cargp ^= null () then acarg_indicies = 0b; /* An array assignment. */ end Cleanup_Handler; end build_resource_desc_;  cancel_resource.pl1 11/04/82 1936.3rew 11/04/82 1619.1 32562 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ cancel_resource: cnr: proc (); /* D_E_S_C_R_I_P_T_I_O_N_ This command takes a reservation identifier and cancels the reservation to which it belongs. This command just implements the user interface. It calls resource_control_$cancel_id to do the actual work. J_O_U_R_N_A_L_I_Z_A_T_I_O_N_ 1) Written 11/78 by R.J.C. Kissel. */ /* Local Variables */ dcl code fixed bin (35); dcl nargs fixed bin; dcl arg_ptr ptr; dcl arg_len fixed bin; dcl arg char (arg_len) based (arg_ptr); dcl arg_count fixed bin; dcl res_id char (res_id_len) based (res_id_ptr); dcl res_id_len fixed bin; dcl res_id_ptr ptr; dcl system bit (1) aligned; /* External Entries */ dcl resource_control_$cancel_id_string entry (char (*), char (*), bit (1) aligned, fixed bin (35)); dcl cu_$arg_count entry (fixed bin); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl com_err_ entry options (variable); /* External Constants */ dcl error_table_$badopt fixed bin (35) external; call cu_$arg_count (nargs); if nargs > 3 | nargs < 2 then goto ERROR_usage; call cu_$arg_ptr (1, arg_ptr, arg_len, code); if code ^= 0 then goto ERROR_arg; system = "0"b; if nargs = 2 then do; /* Only "-id res_id". */ if arg = "-id" then do; call cu_$arg_ptr (2, arg_ptr, arg_len, code); if code ^= 0 then goto ERROR_arg; res_id_len = arg_len; res_id_ptr = arg_ptr; end; else goto ERROR_carg; end; /* Only "-id res_id". */ else do; /* Either "-priv -id res_id" or "-id res_id -priv". */ if arg = "-priv" then do; system = "1"b; arg_count = 2; end; else if arg = "-id" then do; call cu_$arg_ptr (2, arg_ptr, arg_len, code); if code ^= 0 then goto ERROR_arg; arg_count = 3; res_id_len = arg_len; res_id_ptr = arg_ptr; end; else goto ERROR_carg; call cu_$arg_ptr (arg_count, arg_ptr, arg_len, code); if code ^= 0 then goto ERROR_arg; if arg_count = 3 then do; /* Must be "-priv". */ if arg = "-priv" then system = "1"b; else goto ERROR_carg; end; /* Must be "-priv". */ else do; /* Must be "-id res_id". */ if arg = "-id" then do; call cu_$arg_ptr (3, arg_ptr, arg_len, code); if code ^= 0 then goto ERROR_arg; res_id_len = arg_len; res_id_ptr = arg_ptr; end; else goto ERROR_carg; end; /* Must be "-id res_id". */ end; /* Either "-priv -id res_id" or "-id res_id -priv". */ call resource_control_$cancel_id_string (res_id, "", system, code); if code ^= 0 then goto ERROR_cancel; return; /* Error handling code. */ ERROR_arg: call com_err_ (code, "cancel_resource"); return; ERROR_cancel: call com_err_ (code, "cancel_resource", "Unable to cancel reservation ^a.", res_id); return; ERROR_carg: call com_err_ (error_table_$badopt, "cancel_resource", "^a", arg); return; ERROR_usage: call com_err_ (0b, "cancel_resource", "Usage: cnr -id reservation_id {-priv}"); return; end cancel_resource;  detach_lv.pl1 11/04/82 1936.3rew 11/04/82 1606.6 46647 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ detach_lv: dlv: procedure; /* This program is a command that may be called to detach a logical volume. * Created on 04/08/76 by Bill Silver. * Modified on 12/09/78 by Michael R. Jordan for version 3 list info. * Modified on 05/03/82 by J. Bongiovanni for version 4 list info. * * demoun, dmt volume * * volume Specifies the name of the logical volume or volumes to be detached. * A user may detach all logical volumes attached for his/her * process by specifying: * "all" * A user may detach one logical volume by specifying its volume name. */ /* AUTOMATIC DATA */ dcl pointers (1) ptr; /* Pointer array for temp segment manager. */ dcl arg_len fixed bin; /* Length of an argument string. */ dcl arg_ptr ptr; /* Pointer to an argument string. */ dcl ecode fixed bin (35); /* error_table_ code. */ dcl i fixed bin; dcl num_args fixed bin; /* Number of command arguments. */ dcl num_detached fixed bin; /* Number of volumes detached. */ dcl seg_size fixed bin (19); /* Max size of temp segment. */ dcl volume_name char (32); /* Name of volume to be detached. */ /* BASED DATA */ dcl argument char (arg_len) based (arg_ptr); /* Used to reference argument string. */ /* EXTERNAL ENTRIES CALLED */ dcl cleanup condition; dcl (addr, null) builtin; dcl error_table_$noarg fixed bin (35) external; 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 get_temp_segments_ entry (char (*), (1) ptr, fixed bin (35)); dcl hcs_$get_max_length_seg entry (ptr, fixed bin (19), fixed bin (35)); dcl rcp_$copy_list entry (ptr, fixed bin (19), fixed bin (35)); dcl rcp_$detach_lv entry (bit (36) aligned, fixed bin (35)); dcl release_temp_segments_ entry (char (*), (1) ptr, fixed bin (35)); /* */ %include rcp_list_info; /* */ /* Begin command: detach_lv */ ecode, /* Initialize. */ num_detached = 0; volume_name = " "; call cu_$arg_count (num_args); /* Total number of command arguments. */ if num_args < 1 /* Was any volume specified? */ then do; /* No, no argument. */ call com_err_ (error_table_$noarg, "detach_lv", "No volume specified."); return; end; call cu_$arg_ptr (1, arg_ptr, arg_len, ecode); /* Get volume name. */ if ecode ^= 0 then do; call com_err_ (ecode, "detach_lv", "Error getting volume name argument."); return; end; volume_name = argument; /* Remember volume name. */ /* User wants to detach one or more logical volumes from her/his process. * Get temporary segment for RCP list info structure. * Set up cleanup handler to release temp segment. */ pointers (1) = null (); on cleanup begin; if pointers (1) ^= null () then call release_temp_segments_ ("detach_lv", pointers, ecode); end; call get_temp_segments_ ("detach_lv", pointers, ecode); if ecode ^= 0 /* Unable to get temporary working segment? */ then do; /* Yes. */ call com_err_ (ecode, "detach_lv", "Error getting temporary segment"); goto RETURN; end; call hcs_$get_max_length_seg (pointers (1), seg_size, ecode); if ecode ^= 0 /* We need max size of temp segment. */ then do; call com_err_ (ecode, "detach_lv", "Error getting max seg length of temp segment"); goto RETURN; end; rli_ptr = pointers (1); /* Temp segment used for RCP info. */ rli.version_num = rli_version_4; call rcp_$copy_list (rli_ptr, seg_size, ecode); if ecode ^= 0 /* Error copying process's RCP info? */ then do; /* Yes. */ call com_err_ (ecode, "detach_lv", "Error copying RCP info"); goto RETURN; end; do i = 1 to rli.head.num_lv; /* Look at each attached logical volume. */ lv_ptr = addr (rli.lvs (i)); /* Get pointer to lv attach entry. */ if (volume_name = "all") | /* Detaching all lvs? */ (volume_name = lv.volume_name) /* Or this lv? */ then do; /* Yes, detach this logical volume. */ num_detached = num_detached + 1; call rcp_$detach_lv (lv.rcp_id, ecode); if ecode ^= 0 then call com_err_ (ecode, "detach_lv", "Error detaching ^a", lv.volume_name); end; end; if num_detached = 0 /* Did we detach any volumes? */ then if volume_name = "lv" /* No. */ then call com_err_ (0, "detach_lv", "No logical volumes attached"); else call com_err_ (0, "detach_lv", "Logical volume ^a not attached", volume_name); RETURN: call release_temp_segments_ ("detach_lv", pointers, ecode); if ecode ^= 0 then call com_err_ (ecode, "detach_lv", "Error releasing temp segment"); return; end detach_lv;  interpret_resource_desc_.pl1 04/09/85 1354.6rew 04/08/85 1026.9 90954 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* Written and never journalized, God knows when (probably by Tavares). */ /* Modified April 1985 by Chris Jones to not print AIM range of free resources. */ interpret_resource_desc_: proc (resource_desc_ptr, nth, callername, rst_control, called_as_af, return_string, code); dcl nth fixed bin parameter, called_as_af bit (1) aligned parameter, return_string char (*) varying parameter, callername char (*) parameter, code fixed bin (35) parameter; dcl SYSTEM_HIGH bit (72) aligned; %include resource_control_desc; %include rst_control; dcl 1 itemx based (itemptr) aligned like resource_descriptions.item, itemptr pointer; dcl (ioa_$rsnnl, ioa_, ioa_$nnl, com_err_, active_fnc_err_) ext entry options (variable); dcl (i, j) fixed bin, (first, last) fixed bin, saved_code fixed bin (35), acc (2) char (256), (want_acc, want_pacc) bit (1) aligned, error_table_$unimplemented_version ext fixed bin (35) static, pacc (2) char (256), temp_atts (2) bit (72) aligned, attstring char (512) varying; dcl mode_strings (8) char (4) varying static options (constant) initial ("null", "w", "e", "ew", "r", "rw", "re", "rew"); dcl convert_authorization_$to_string ext entry (bit (72) aligned, char (*), fixed bin (35)), convert_authorization_$from_string ext entry (bit (72) aligned, char (*), fixed bin (35)), cv_rcp_attributes_$to_string ext entry (char (*) aligned, (2) bit (72) aligned, char (*) varying, fixed bin (35)), cv_rcp_attributes_$to_string_rel ext entry (char (*) aligned, (4) bit (72) aligned, char (*) varying, fixed bin (35)); saved_code = 0; if resource_descriptions.version_no ^= resource_desc_version_1 then do; code = error_table_$unimplemented_version; return; end; call convert_authorization_$from_string (SYSTEM_HIGH, "system_high", code); if code ^= 0 then call err (code, "converting system_high"); if nth = 0 then do; first = 1; last = resource_descriptions.n_items; end; else first, last = nth; do i = first to last; itemptr = addr (resource_descriptions.item (i)); if rst_control.name | rst_control.default | rst_control.any_given_item | (first ^= last) then call ioa_ ("Resource: ^a ^a^[^; (not by name)^]", itemx.type, itemx.name, itemx.given.name); if (rst_control.uid | (itemx.given.uid & rst_control.any_given_item)) then if called_as_af then call ioa_$rsnnl ("^w", return_string, 0, itemx.uid); else call ioa_ ("Unique ID:^-^w", itemx.uid); if (rst_control.potential_attributes | (itemx.given.potential_attributes & rst_control.any_given_item)) then do; unspec (temp_atts) = ""b; temp_atts (1) = itemx.potential_attributes; call cv_rcp_attributes_$to_string (itemx.type, temp_atts, attstring, code); if code ^= 0 then call err (code, "Potential attributes"); else if called_as_af then return_string = attstring; else call ioa_ ("Potential Attributes:^/^2-^a", attstring); end; if rst_control.attributes then do; call cv_rcp_attributes_$to_string (itemx.type, itemx.attributes (*), attstring, code); if code ^= 0 then call err (code, "Attributes"); else if called_as_af then return_string = attstring; else call ioa_ ("Attributes:^-^a", attstring); end; if (rst_control.desired_attributes | (itemx.given.desired_attributes & rst_control.any_given_item)) then do; call cv_rcp_attributes_$to_string_rel (itemx.type, itemx.desired_attributes (*), attstring, code); if code ^= 0 then call err (code, "Desired attributes"); else if called_as_af then return_string = attstring; else call ioa_ ("Desired attributes:^-^a", attstring); end; if (rst_control.owner | (itemx.given.owner & rst_control.any_given_item)) then if called_as_af then return_string = rtrim (itemx.owner, " "); else call ioa_ ("Owner:^2-^a", itemx.owner); if (rst_control.acs_path | (itemx.given.acs_path & rst_control.any_given_item)) then if called_as_af then if itemx.acs_path = "" then return_string = """"""; else return_string = rtrim (itemx.acs_path, " "); else call ioa_ ("ACS Pathname:^-^[none^;^a^]", (itemx.acs_path = ""), itemx.acs_path); want_pacc = (rst_control.potential_aim_range | (itemx.given.potential_aim_range & rst_control.any_given_item)); want_acc = (rst_control.aim_range | (itemx.given.aim_range & rst_control.any_given_item)); if want_pacc | want_acc then do; do j = 1 to 2; code = 0; if itemx.potential_aim_range (j) = ""b then pacc (j) = "system_low"; else if itemx.potential_aim_range (j) = SYSTEM_HIGH then pacc (j) = "system_high"; else call convert_authorization_$to_string (itemx.potential_aim_range (j), pacc (j), code); if want_pacc then if code ^= 0 then do; call err (code, "Potential AIM range"); want_pacc = ""b; end; code = 0; if itemx.aim_range (j) = ""b then acc (j) = "system_low"; else if itemx.aim_range (j) = SYSTEM_HIGH then acc (j) = "system_high"; else call convert_authorization_$to_string (itemx.aim_range (j), acc (j), code); if want_acc then if code ^= 0 then do; call err (code, "AIM range"); want_acc = ""b; end; end; if want_pacc then if called_as_af then if pacc (1) = pacc (2) then return_string = rtrim (pacc (1), " "); else return_string = rtrim (pacc (1), " ") || "; " || rtrim (pacc (2), " "); else call ioa_ ("Potential AIM ^[Class:^/^2-^a^;Range:^/^2-^a : ^a", (pacc (1) = pacc (2)), pacc); if want_acc then if called_as_af then if acc (1) = acc (2) then return_string = rtrim (acc (1), " "); else return_string = rtrim (acc (1), " ") || "; " || rtrim (acc (2), " "); else if itemx.owner ^= "free" then call ioa_ ("AIM ^[Class:^-^a^;Range:^-^a : ^a^]", (acc (1) = acc (2)), acc); end; if (rst_control.location | (itemx.given.location & rst_control.any_given_item)) then if called_as_af then return_string = """" || rtrim (itemx.location, " ") || """"; else call ioa_ ("Location:^2-^[""""^;^a^]", (itemx.location = ""), itemx.location); if (rst_control.comment | (itemx.given.comment & rst_control.any_given_item) | (itemx.comment ^= "" & rst_control.default)) then if called_as_af then return_string = """" || rtrim (itemx.comment, " ") || """"; else call ioa_ ("Comment:^2-^[""""^;^a^]", (itemx.comment = ""), itemx.comment); if (rst_control.charge_type | (itemx.given.charge_type & rst_control.any_given_item)) then if called_as_af then return_string = """" || rtrim (itemx.charge_type, " ") || """"; else call ioa_ ("Charge type:^-^[""""^;^a^]", (itemx.charge_type = ""), itemx.charge_type); if rst_control.mode then if called_as_af then return_string = mode_strings (binary (itemx.rew) + 1); else call ioa_ ("Mode:^2-^a", mode_strings (binary (itemx.rew) + 1)); if (rst_control.usage_lock | (itemx.given.usage_lock & rst_control.any_given_item) | (itemx.usage_lock & rst_control.default)) then if called_as_af then if itemx.usage_lock then return_string = "true"; else return_string = "false"; else call ioa_ ("Usage Lock:^-^[on^;off^]", itemx.usage_lock); if (rst_control.release_lock | (itemx.given.release_lock & rst_control.any_given_item) | (itemx.release_lock & rst_control.default)) then if called_as_af then if itemx.release_lock then return_string = "true"; else return_string = "false"; else call ioa_ ("Release Lock:^-^[on^;off^]", itemx.release_lock); if (rst_control.awaiting_clear | (itemx.awaiting_clear & rst_control.default)) then if called_as_af then if itemx.awaiting_clear then return_string = "true"; else return_string = "false"; else call ioa_ ("Awaiting Clear:^-^[yes^;no^]", itemx.awaiting_clear); if (rst_control.user_alloc | (itemx.given.user_alloc & rst_control.any_given_item) | rst_control.default) then if called_as_af then if itemx.user_alloc then return_string = "true"; else return_string = "false"; else call ioa_ ("Allocation state:^-^[allocated^;free^]", itemx.user_alloc); if rst_control.given_flags then do; call ioa_ ("Given flags:"); if itemx.given.name then call ioa_ ("^-name"); if itemx.given.uid then call ioa_ ("^-uid"); if itemx.given.potential_attributes then call ioa_ ("^-potential_attributes"); if itemx.given.desired_attributes then call ioa_ ("^-desired_attributes"); if itemx.given.potential_aim_range then call ioa_ ("^-potential_aim_range"); if itemx.given.owner then call ioa_ ("^-owner"); if itemx.given.acs_path then call ioa_ ("^-acs_path"); if itemx.given.location then call ioa_ ("^-location"); if itemx.given.comment then call ioa_ ("^-comment"); if itemx.given.charge_type then call ioa_ ("^-charge_type"); if itemx.given.usage_lock then call ioa_ ("^-usage_lock"); if itemx.given.release_lock then call ioa_ ("^-release_lock"); if itemx.given.user_alloc then call ioa_ ("^-alloc"); end; if i ^= last then call ioa_ (""); end; code = saved_code; return; err: proc (code, reason); dcl code fixed bin (35) parameter, reason char (*) parameter; if called_as_af then call active_fnc_err_ (code, callername, reason); else call com_err_ (code, callername, reason); if called_as_af then return_string = ""; saved_code = code; end err; end interpret_resource_desc_;  list_resource_types.pl1 11/04/82 1936.3rew 11/04/82 1619.2 58500 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ list_resource_types: lrt: proc; /* This command lists all known resource types in >sc1>rtdt. */ /* Written 03/28/78 by C. D. Tavares */ /* Modified 8/81 by M.R. Jordan to fix bugs in control argument processing. */ %page; /* *** CONSTANTS *** */ dcl SYSDIR char (168) static initial (">system_control_1"); dcl SYSENT char (32) static initial ("rtdt") options (constant); /* *** AUTOMATIC *** */ dcl al fixed bin; dcl alp pointer; dcl ap pointer; dcl attribute_string char (512) varying; dcl bc fixed bin (24); dcl code fixed bin (35); dcl dirname char (168); dcl ename char (32); dcl header_sw bit (1)aligned; dcl i fixed bin; dcl j fixed bin; dcl junk fixed bin; dcl long_sw bit (1) aligned; dcl n_names_to_match fixed bin; dcl nargs fixed bin; dcl syn_found bit (1) aligned; dcl temp_atts (2) bit (72) aligned; /* *** BASED *** */ dcl arg based (ap) char (al); /* *** ERROR CODES *** */ dcl error_table_$badopt fixed bin (35) ext; dcl error_table_$name_not_found fixed bin (35) ext; dcl error_table_$unimplemented_version fixed bin (35) ext; /* *** EXTERNAL ENTRIES *** */ dcl com_err_ ext entry options (variable); dcl cu_$arg_count ext entry (fixed bin); dcl cu_$arg_list_ptr ext entry (pointer); dcl cu_$arg_ptr_rel ext entry (fixed bin, pointer, fixed bin, fixed bin (35), pointer); dcl cv_rcp_attributes_$to_string_given_rtde ext entry (pointer, (2) bit (72) aligned, char (*) varying, fixed bin (35)); dcl expand_pathname_$add_suffix ext entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl hcs_$initiate_count ext entry (char (*), char (*), char (*), fixed bin (24), fixed bin, pointer, fixed bin (35)); dcl hcs_$terminate_noname ext entry (pointer, fixed bin (35)); dcl ioa_ ext entry options (variable); /* *** BUILTIN FUNCTIONS *** */ /* & */ /* *** CONDITIONS *** */ dcl index builtin; dcl length builtin; dcl null builtin; dcl pointer builtin; dcl reverse builtin; dcl substr builtin; dcl cleanup condition; %page; %include rtdt; %page; rtdtp = null (); call cu_$arg_list_ptr (alp); call cu_$arg_count (nargs); begin; dcl matchnames (nargs) char (32); dirname = SYSDIR; ename = SYSENT; header_sw = "1"b; long_sw = "0"b; n_names_to_match = 0; do i = 1 to nargs; call cu_$arg_ptr_rel (i, ap, al, code, alp); if code ^= 0 then call crump (code, "obtaining arguments"); if substr (arg, 1, 1) = "-" then do; if arg = "-lg" | arg = "-long" then long_sw = "1"b; else if arg = "-pn" | arg = "-pathname" then do; i = i + 1; call cu_$arg_ptr_rel (i, ap, al, code, alp); if code ^= 0 then call crump (code, "No pathname supplied."); call expand_pathname_$add_suffix (arg, "rtdt", dirname, ename, code); if code ^= 0 then call crump (code, arg); end; else if arg = "-nhe" | arg = "-no_header" then header_sw = "0"b; else call crump (error_table_$badopt, arg); end; else do; n_names_to_match = n_names_to_match + 1; matchnames (n_names_to_match) = arg; end; end; on cleanup call clean_up; /* ------------------------- */ clean_up: proc; if rtdtp ^= null () then call hcs_$terminate_noname (rtdtp, 0); return; end clean_up; /* ------------------------- */ call hcs_$initiate_count (dirname, ename, "", bc, 0, rtdtp, code); if rtdtp = null then if ename = "rtdt.rtdt" then do; ename = "rtdt"; call hcs_$initiate_count (dirname, ename, "", bc, 0, rtdtp, code); end; if rtdtp = null then call crump (code, "^a>^a"); if (rtdt.version ^= RTDT_version_2) & (rtdt.version ^= RTDT_version_3) then call crump (error_table_$unimplemented_version, "^a>^a"); if header_sw then call ioa_ (" Type^-Name^[^2-Attributes^]^/", long_sw); do junk = 1, 2 to 2 while (syn_found); syn_found = ""b; do rtdep = pointer (rtdt.first_resource, rtdt.rtdt_area) repeat (pointer (rtde.next_resource, rtdt.rtdt_area)) while (rtdep ^= null); if rtde.valid then do; do i = 1 to n_names_to_match while (matchnames (i) ^= rtde.name); end; if n_names_to_match = 0 | i <= n_names_to_match then do; if i > 0 then matchnames (i) = ""; call ioa_ ("^[Volume^;Device^]^-^a^[ (synonym for ^a)^;^]", rtde.is_volume, rtde.name, rtde.is_synonym, rtde.syn_to); if (long_sw & ^rtde.is_synonym) then do; temp_atts (1) = rtde.attributes_valid; temp_atts (2) = ""b; call cv_rcp_attributes_$to_string_given_rtde (rtdep, temp_atts, attribute_string, code); if code ^= 0 then call crump (code, "While getting attributes for " || rtde.name); do j = 1 by 1 while (attribute_string ^= ""); call ioa_ ("^- ^[^; ^]^a", (j = 1), knockoff_60_ch (attribute_string)); end; end; if rtde.is_synonym then if n_names_to_match > 0 then do; matchnames (i) = rtde.syn_to; syn_found = "1"b; end; end; end; end; end; do i = 1 to n_names_to_match; if matchnames (i) ^= "" then call com_err_ (error_table_$name_not_found, "list_resource_types", "^a", matchnames (i)); end; call clean_up; return; knockoff_60_ch: proc (string) returns (char (60) varying); dcl string char (512) varying parameter; dcl i fixed bin, temp char (60) varying; if length (string) <= 60 then do; temp = string; string = ""; return (temp); end; i = 61 - index (reverse (substr (string, 1, 60)), ","); temp = substr (string, 1, i); string = substr (string, i+1); return (temp); end knockoff_60_ch; crump: proc (code, reason); dcl code fixed bin (35) parameter, reason char (*) parameter; call com_err_ (code, "list_resource_types", reason, dirname, ename); call clean_up; goto return_hard; end crump; end; /* begin block */ return_hard: return; end list_resource_types;  list_resources.pl1 07/16/87 1349.5r 07/15/87 1547.4 304335 /****^ *********************************************************** * * * 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. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(87-06-02,Rauschelbach), approve(87-07-07,MCR7728), audit(87-07-08,Farley), install(87-07-15,MR12.1-1040): A seperate error message was added for -awaiting_clear without a -type argument instead of the same message as -acquisitions without -type. END HISTORY COMMENTS */ /* format: indattr,inddcls,dclind5,idind30,struclvlind5,ifthenstmt,ifthendo,^inditerdo,^indnoniterend,case,^tree,^indproc,^indend,^delnl,^insnl,comcol81,indcom,linecom,^indcomtxt */ list_resources: lr: procedure; /* This program is a command that may be called to list the resources that * have been assigned to or mounted by the calling process by RCP. * Created on 01/07/75 by Bill Silver. * Changed on 04/08/76 by Bill Silver for "-lv" option and to use temp * segments. * Changed on 05/24/78 by Michael R. Jordan for tape_drive/disk_drive * changes. * Changed on 10/31/78 by C. D. Tavares to add -acquisitions portion and * change -attachments to -mounts. * Changed on 11/18/78 by M. R. Jordan for -reservations and speed * qualifier for tapes. * Changed on 05/10/79 by CDT to add -awaiting_clear control arg. * Modified 831218 to call request_id_... BIM * Modified 831220 to correctly list console types... -E. A. Ranzenbach * * (-type | -tp) This option specifies that all of the devices of * this type are to be listed. It value argument * must be the name of the device type to be * listed. * (-dv | -device) Specifies that a specific device is to be * listed. Its value argument must be the name of * the device. RCP will list information about * only this one device. * (-lg | -long) This command option specifies that the user * wants all of the information known about the * assignment or mount. This option argument * is not followed by a value argument. * (-lv | -logical_volumes) * Specifies that only attached logical volumes are * to be listed. * (-resv | -reservations) * Specifies that only reservations are to be * listed. * (-asm | -assignments) * Specifies that only device assignments are to be * listed. * (-mts | -mounts) Specifies that only mounts are to be listed. * (-atm | -attachments) (as above, kept for compatibility.) * (-acq | -acquisitions) * Specifies that only owned resources are to be * listed. * (-user userid) Specifies that user or project's acquisitions * (-awaiting_clear) Specifies those resources awaiting manual * clearing. */ /* AUTOMATIC DATA */ dcl alp pointer; /* pointer to arg list */ dcl arg_len fixed bin; /* Length of an argument string. */ dcl arg_ptr ptr; /* Pointer to an argument string. */ dcl argx fixed bin; /* Number of the current argument. */ dcl awaiting_clear bit (1) initial (""b); /* ON if wants list of resources awaiting clear */ dcl called_as_af bit (1) aligned; /* O if called as active function */ dcl cu_arg_ptr_entry entry (fixed bin, pointer, fixed bin, fixed bin (35), pointer) variable; 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 resource_type char (32); /* Device type. */ dcl dtypex fixed bin; /* Device type index. */ dcl vtypex fixed bin; /* Volume type index */ dcl typex fixed bin; /* scratch variable */ dcl ecode fixed bin (35); /* error_table_ code. */ dcl (i, k) fixed bin; dcl is_volume bit (1) aligned; dcl list_index fixed bin; /* 0 => all, 1 => type, 2 => device. */ dcl listed_flag bit (1); /* ON => something has been listed. */ dcl long_flag bit (1); /* ON => user wants all available information. */ dcl num_args fixed bin; /* Number of command arguments. */ dcl num_listed fixed bin; /* Number of entries actually listed. */ dcl option char (32); /* Command option string. */ dcl option_code fixed bin; /* 0 => none, 1 => string, 2 => binary. */ dcl rcp_list_copied bit (1) initial (""b); /* if on, don't recopy it */ dcl request_control bit (36); /* one bit for each control arg */ dcl return_argp pointer; /* points to af return arg */ dcl return_argl fixed bin (21); /* length of same */ dcl seconds fixed bin; /* Max IOI time-out intraval. */ dcl seg_size fixed bin (19); /* Size of temp segment. */ dcl speed_comment char (30) varying; /* Used to print speed capabilities. */ dcl speed_ptr ptr; /* Pointer to speed qualifier for tape drives. */ dcl temp_seg_ptr ptr; /* for temp segment namager. */ dcl time_string char (24); /* Used to list state time. */ dcl user_id char (32); /* for acquisition section */ /* BASED DATA */ dcl argument char (arg_len) based (arg_ptr); /* Used to reference argument string. */ dcl based_density bit (5) based (density_ptr) aligned; dcl based_speed bit (3) based (speed_ptr) aligned; dcl return_arg char (return_argl) varying based (return_argp); /* INTERNAL STATIC DATA */ dcl 1 static_option_data (1:11) internal static options (constant), 2 brief_options char (16) initial /* Brief form of command options. */ ("-tp", "-dv", "-lg", "-asm", "-mts", "-lv", "-acq", "-user", "-atm", "-resv", "-awaiting_clear"), 2 long_options char (19) initial /* Long form of command options. */ ("-type", "-device", "-long", "-assignments", "-mounts", "-logical_volumes", "-acquisitions", "-user", "-attachments", "-reservations", "-awaiting_clear"), 2 option_codes fixed bin initial (1, 1, 0, 0, 0, 0, 0, 1, 0, 0, 0), 2 af_usage_allowed bit (1) aligned initial ("1"b, "0"b, "0"b, "0"b, "0"b, "0"b, "1"b, "1"b, "0"b, "0"b, "1"b); dcl (Unset initial ("000000"b), Default initial ("111101"b), Assignments initial ("010000"b), Mounts initial ("001000"b), Logical_volumes initial ("000100"b), Acquisitions initial ("000010"b), Reservations initial ("000001"b)) bit (36) static options (constant); dcl operation_states (5) char (12) /* Assignment and mounting states. */ internal static init ("assigning", "assigning", "mounting", "mounting", "mounted"); dcl density_names (5) char (5) varying /* Used to print device density characteristics. */ internal static init ("200 ", "556 ", "800 ", "1600 ", "6250 "); dcl console_model_names (3) char (4) /* Operator's console model names. */ internal static init ("EMC", "EMC", "LCC"); dcl console_models (3) fixed bin (17) internal static init (6001, 6004, 6601); dcl speed_names (3) char (4) /* Tape drive speed names. */ internal static init ("75 ", "125 ", "200 "); dcl registry_dir char (168) static initial (">system_control_1>rcp"); /* EXTERNAL ENTRIES CALLED */ dcl cleanup condition; /* Used to release temp segment. */ dcl (addr, after, before, clock, hbound, length, max, null, rtrim, substr, unspec) builtin; dcl (error_table_$badcall, error_table_$badopt, error_table_$inconsistent, error_table_$not_act_fnc, error_table_$odd_no_of_args, error_table_$resource_type_inappropriate, error_table_$wrong_no_of_args) fixed bin (35) external; dcl (com_err_, active_fnc_err_) entry options (variable); dcl cu_$af_return_arg entry (fixed bin, pointer, fixed bin (21), fixed bin (35)); dcl (cu_$arg_ptr_rel, cu_$af_arg_ptr_rel) entry (fixed bin, ptr, fixed bin, fixed bin (35), ptr); dcl cu_$arg_list_ptr ext entry (pointer); dcl date_time_ entry (fixed bin (71), char (*)); dcl ioa_ entry options (variable); dcl hcs_$get_max_length_seg entry (ptr, fixed bin (19), fixed bin (35)); dcl get_temp_segment_ entry (char (*), ptr, fixed bin (35)); dcl release_temp_segment_ entry (char (*), ptr, fixed bin (35)); dcl rcp_$copy_list entry (ptr, fixed bin (19), fixed bin (35)); dcl resource_info_$get_rtypex entry (char (*), char (*), fixed bin, bit (1) aligned, fixed bin (35)); %include rcp_list_info; /* list_resources: */ temp_seg_ptr = null; ecode, /* Initialize. */ list_index = 0; /* 0 => all devices of all types. */ dtypex, vtypex, typex = 0; request_control = Unset; user_id = ""; /* default is myself */ resource_type = ""; long_flag = "0"b; /* Default = minimum of information. */ call cu_$af_return_arg (num_args, return_argp, return_argl, ecode); /* Get total number of arguments. */ if ecode = error_table_$not_act_fnc then do; called_as_af = ""b; cu_arg_ptr_entry = cu_$arg_ptr_rel; end; else if ecode ^= 0 then do; call active_fnc_err_ (ecode, "list_resources", "Obtaining argument information."); if return_argp ^= null then return_arg = ""; return; end; else do; called_as_af = "1"b; cu_arg_ptr_entry = cu_$af_arg_ptr_rel; end; call cu_$arg_list_ptr (alp); do argx = 1 to num_args; /* Process each argument. */ call PROCESS_ARG; /* Most will be processed in pairs. */ if ecode ^= 0 then return; /* If error, abort */ end; if request_control = Unset then request_control = Default; if called_as_af then /* was more than one option specified? */ if after (request_control, "1"b) ^= ""b then do; call active_fnc_err_ (error_table_$inconsistent, "list_resources", "More than one category of information requested in active function mode."); return_arg = ""; end; /* Now that we have valid arguments, get a work segment. Then call RCP to get the information about the resources associated with this process. */ on cleanup begin; /* Cleanup handler for temp seg releasing. */ if temp_seg_ptr ^= null () then call release_temp_segment_ ("list_resources", temp_seg_ptr, ecode); end; call GET_TEMP_SEG; /* Get temporary working segment. */ if ecode ^= 0 then return; /* Now process the requests. */ listed_flag = ""b; /* List assignments. */ if (request_control & Assignments) ^= "0"b then do; call COPY_RCP_LIST; if (rli.head.num_dassign ^= 0) /* if device assignments */ | (request_control ^= Default) then do; /* or not default case */ listed_flag = "1"b; /* Something will be listed. */ call ioa_ ("Device Assignments"); call LIST_DASSIGN; /* List all device assignments. */ end; end; /* List mounts. */ if (request_control & Mounts) ^= "0"b then do; call COPY_RCP_LIST; if (rli.head.num_attach ^= 0) /* if device mounts */ | (request_control ^= Default) then do; /* or not default case */ listed_flag = "1"b; /* Something will be listed. */ call ioa_ ("Mounts"); call LIST_MOUNTS; /* List all device assignments. */ end; end; /* List logical volumes. */ if (request_control & Logical_volumes) ^= "0"b then do; call COPY_RCP_LIST; if (rli.head.num_lv ^= 0) /* if logical volumes */ | (request_control ^= Default) then do; /* or not default case */ listed_flag = "1"b; /* Something will be listed. */ call ioa_ ("Logical Volumes"); call LIST_LV; /* List all device assignments. */ end; end; /* List reservations. */ if (request_control & Reservations) ^= "0"b then do; call COPY_RCP_LIST; if (rli.head.num_device_resv + rli.head.num_vol_resv ^= 0) /* if reservations */ | (request_control ^= Default) then do; /* or not default case */ listed_flag = "1"b; /* Something will be listed. */ call ioa_ ("Resource Reservations"); call LIST_RESERVATIONS; end; end; /* List acquisitions. */ if (request_control & Acquisitions) ^= "0"b then do; if request_control ^= Acquisitions then /* other things too */ call ioa_ ("Resource Acquisitions"); listed_flag = "1"b; /* Something will be listed. */ call LIST_ACQUISITIONS; end; if ^listed_flag then /* Did we list anything? */ call ioa_ ("list_resources: No resources selected."); /* No. */ RETURN: if temp_seg_ptr ^= null then call release_temp_segment_ ("list_resources", temp_seg_ptr, ecode); return; PROCESS_ARG: procedure; /* This procedure is called to process one option argument. Many of these options have an accompanying value argument. This value must be the next argument. In this case we will process the value argument too. */ call cu_arg_ptr_entry (argx, arg_ptr, arg_len, ecode, alp); if ecode ^= 0 then call crump (ecode, "while obtaining arguments."); option = argument; /* Save option argument. */ do i = 1 to hbound (long_options, 1); /* Look for valid option name. */ if (option = brief_options (i)) | /* Is it this brief name? */ (option = long_options (i)) /* Or this long name? */ then do; /* Yes, one of them. */ if called_as_af then if ^af_usage_allowed (i) then do; call active_fnc_err_ (error_table_$badcall, "list_resources", "^a not available in active function mode.", option); return_arg = ""; return; end; call GET_VALUE (i); /* Get value argument if any. */ if ecode ^= 0 /* Check for errors. */ then return; goto OPTION (i); /* Go process this option. */ end; end; call crump (error_table_$badopt, option); /* Option name not found. */ return; OPTION (1): /* "-tp" or "-type" */ list_index = max (1, list_index); /* 1 => list all devices of this type. */ dtypex, vtypex = 0; call resource_info_$get_rtypex (argument, resource_type, typex, is_volume, ecode); if ecode ^= 0 then call crump (ecode, argument); if is_volume then vtypex = typex; else dtypex = typex; return; OPTION (2): /* "-dv" or "-device" */ list_index = 2; /* 2 => list only this one device. */ device_name = argument; /* Get device name. */ return; OPTION (3): /* "-lg" or "-long" */ long_flag = "1"b; /* User wants all available information. */ return; OPTION (4): /* "-asm" or "-assignments" */ request_control = request_control | Assignments; /* User wants device assignments. */ return; OPTION (9): /* "-atm" or "-attachments" */ call ioa_ ("list_resources: Warning-- -mounts (-mts) should be used rather than -attachments (-atm)."); OPTION (5): /* "-mts" or "-mounts" */ request_control = request_control | Mounts; return; OPTION (6): /* "-lv" or "-logical_volumes" */ request_control = request_control | Logical_volumes; /* User wants attached logical volumes. */ return; OPTION (7): /* "-acq" or "-acquisitions" */ request_control = request_control | Acquisitions; return; OPTION (8): /* "-user" */ if awaiting_clear then call crump (error_table_$inconsistent, "-awaiting_clear and -user"); user_id = argument; return; OPTION (10): /* "-reservations" or "-resv" */ request_control = request_control | Reservations; return; OPTION (11): /* "-awaiting_clear" */ request_control = request_control | Acquisitions; if user_id ^= "" then call crump (error_table_$inconsistent, "-awaiting_clear and -user."); user_id = "*.*"; awaiting_clear = "1"b; 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 then /* Is this the last argument? */ call crump (error_table_$odd_no_of_args, "No value argument for " || option); argx = argx + 1; /* Get the next argument. */ call cu_arg_ptr_entry (argx, arg_ptr, arg_len, ecode, alp); if ecode ^= 0 then call crump (ecode, "while obtaining arguments."); if substr (argument, 1, 1) = "-" then /* Is next argument a control option? */ call crump (error_table_$wrong_no_of_args, "No value argument for " || option); end GET_VALUE; COPY_RCP_LIST: proc; if rcp_list_copied then return; rli.head.version_num = rli_version_4; /* Tell RCP version we are working with. */ call rcp_$copy_list (rli_ptr, seg_size, ecode); if ecode ^= 0 then call crump (ecode, "Error copying RCP list information."); rcp_list_copied = "1"b; return; end COPY_RCP_LIST; LIST_DASSIGN: procedure; /* This procedure is called to list device assignments. The device assignments that will be listed depend upon the list_index variable. We will list the assignments of all devices, all devices of a specified type, or one specific device. */ num_listed = 0; goto DASSIGN (list_index); /* Decide which device assignments to list. */ DASSIGN (0): /* List all device assignments. */ if rli.head.num_dassign = 0 /* Any devices assigned? */ then do; /* No. */ call ioa_ ("No devices assigned."); return; end; if long_flag /* If in long mode tell how many. */ then if rli.head.num_dassign = 1 then call ioa_ ("1 device assigned"); else call ioa_ ("^d devices assigned", rli.head.num_dassign); do i = 1 to rli.head.num_dassign; /* Process each device assignment block. */ dassign_ptr = addr (rli.dassigns (i)); call LIST_DASSIGNMENT; /* List each one. */ end; return; DASSIGN (1): /* All device assignments of specified type. */ if is_volume then call crump (error_table_$resource_type_inappropriate, rtrim (resource_type) || " is not a device type."); do i = 1 to rli.head.num_dassign; /* Look at each device assignment block. */ dassign_ptr = addr (rli.dassigns (i)); if dtypex = dassign.dtypex /* Is this the device type specified? */ then call LIST_DASSIGNMENT; /* Yes, list this device assignment. */ end; if num_listed = 0 /* Did we find any for this device type? */ then call ioa_ ("^5xNo ^a type devices assigned.", resource_type); return; DASSIGN (2): /* List specific device assignment. */ if is_volume then call crump (error_table_$resource_type_inappropriate, rtrim (resource_type) || " is not a device type."); do i = 1 to rli.head.num_dassign; /* Look through all device assignments. */ dassign_ptr = addr (rli.dassigns (i)); if device_name = dassign.device_name then do; /* We found the device. */ call LIST_DASSIGNMENT; /* List its assignment info. */ return; /* No need to look further. */ end; end; call ioa_ ("^5xDevice ^a is not assigned", device_name); end LIST_DASSIGN; LIST_MOUNTS: procedure; /* This procedure is called to list mounts. The mounts that will be listed depend upon the list_index variable. We will list info on all devices, all devices of a specified type, or one specific device. */ num_listed = 0; goto MOUNTS (list_index); /* Decide which mounts to list. */ MOUNTS (0): /* List all mounts. */ if rli.head.num_attach = 0 /* Any mounts? */ then do; /* No. */ call ioa_ ("No mounts."); return; end; if long_flag then /* If in long mode tell how many. */ call ioa_ ("^d mount^[s^;^]", rli.head.num_attach, (rli.head.num_attach = 1)); do i = 1 to rli.head.num_attach; /* Process each mount. */ attach_ptr = addr (rli.attaches (i)); call LIST_SINGLE_MOUNT; /* List each one. */ end; return; MOUNTS (1): /* All mounts of specified type. */ if is_volume then call crump (error_table_$resource_type_inappropriate, rtrim (resource_type) || " is not a device type."); do i = 1 to rli.head.num_attach; /* Look at each mount block. */ attach_ptr = addr (rli.attaches (i)); if dtypex = attach.dtypex /* Is this the device type specified? */ then call LIST_SINGLE_MOUNT; end; if num_listed = 0 /* Did we find any for this device type? */ then call ioa_ ("^5xNo ^a type devices mounted.", resource_type); return; MOUNTS (2): /* List specific device mount. */ if is_volume then call crump (error_table_$resource_type_inappropriate, rtrim (resource_type) || " is not a device type."); do i = 1 to rli.head.num_attach; /* Look through all mounts. */ attach_ptr = addr (rli.attaches (i)); if device_name = dassign.device_name then do; /* We found the device. */ call LIST_SINGLE_MOUNT; /* List its mount info. */ return; end; end; call ioa_ ("^5xDevice ^a is not mounted.", device_name); end LIST_MOUNTS; LIST_LV: procedure; /* This procedure is called to list attached logical volumes. All logical volumes attached for the calling process will be listed. */ if rli.head.num_lv = 0 /* Any logical volumes attached? */ then do; /* No. */ call ioa_ ("No logical volumes"); return; end; do i = 1 to rli.num_lv; /* List all attached logical volumes. */ lv_ptr = addr (rli.lvs (i)); /* Get pointer to lv info. */ call ioa_ ("^5x^a", lv.volume_name); if long_flag /* Does user want more info? */ then do; /* Yes. */ call ioa_ ("^-State^-= attached"); call date_time_ (lv.state_time, time_string); call ioa_ ("^-Time^-= ^a", time_string); end; end; end LIST_LV; LIST_RESERVATIONS: procedure; /* This procedure is called to list information about reservations. The reservations that will be listed depend on the control arguments specified by the caller. */ do i = 1 to rli.head.num_device_resv; /* First look at the devices. */ device_resv_ptr = addr (rli.device_resvs (i)); if device_resv.reservation_id ^= 0 then /* This one looks like a good one to list. */ call LIST_RESERVATION (device_resv.reservation_id); end; do i = 1 to rli.head.num_vol_resv; /* Then make sure we haven't missed any volumes. */ vol_resv_ptr = addr (rli.vol_resvs (i)); if vol_resv.reservation_id ^= 0 then /* List this one. */ call LIST_RESERVATION (vol_resv.reservation_id); end; return; end LIST_RESERVATIONS; LIST_DASSIGNMENT: procedure; /* This procedure is called to list the assignment information for one device. If we are in long mode we will list all of the device characteristics. */ num_listed = num_listed + 1; if dassign.device_name ^= " " /* Do we know device name? */ then call ioa_ ("^5xDevice ^a", dassign.device_name); else call ioa_ ("^5xDevice not yet assigned"); if dassign.state = 0 /* State = 0 => free due to force unassign. */ then do; call ioa_ ("^-State^-= force unassigned"); return; end; if ^long_flag /* Does caller want all information? */ then return; /* No. */ if dassign.state = 5 /* State = 5 => assignment completed. */ then call ioa_ ("^-State^-= assigned"); else call ioa_ ("^-State^-= assigning"); call date_time_ (dassign.state_time, time_string); call ioa_ ("^-Time^-= ^a", time_string); if substr (dassign.disposition, 1, 1) /* ON => retain, OFF => unassign. */ then call ioa_ ("^-Disp^-= retain"); else call ioa_ ("^-Disp^-= unassign"); if dassign.flags.attached then call ioa_ ("^-Device Mounted"); call ioa_ ("^-Level^-= ^d", dassign.level); if dassign.state ^= 5 /* Is device assignment completed? */ then return; /* No, don't print device characteristics. */ call ioa_ ("^-Model^-= ^d", dassign.model); goto DTYPE (dassign.dtypex); /* Process device type specific data. */ DTYPE (1): /* TAPE */ call ioa_ ("^-Tracks^-= ^d", dassign.qualifiers (1)); density_ptr = addr (dassign.qualifiers (2)); density_comment = ""; do k = 1 to hbound (density_names, 1); /* Check for each possible density. */ if substr (based_density, k, 1) then density_comment = density_comment || density_names (k); end; call ioa_ ("^-Densities^-= ^a", density_comment); speed_ptr = addr (dassign.qualifiers (3)); speed_comment = ""; do k = 1 to hbound (speed_names, 1); /* Check for each possible speed. */ if substr (based_speed, k, 1) then speed_comment = speed_comment || speed_names (k); end; call ioa_ ("^-Speed^-= ^a", speed_comment); return; DTYPE (3): /* CONSOLE */ do k = 1 to hbound (console_models, 1); if dassign.model = console_models (k) then do; call ioa_ ("^-Type^-= ^a", console_model_names (k)); return; end; end; call crump (0, "Illegal console model number."); return; DTYPE (4): /* PRINTER */ call ioa_ ("^-Train^-= ^d", dassign.qualifiers (1)); if dassign.qualifiers (2) = -1 /* -1 => line length not given on PRPH card. */ then call ioa_ ("^-Line Len^-= not specified"); else call ioa_ ("^-Line Len^-= ^d", dassign.qualifiers (2)); return; DTYPE (2): /* DISK */ DTYPE (5): /* PUNCH */ DTYPE (6): /* READER */ DTYPE (7): /* SPECIAL */ end LIST_DASSIGNMENT; LIST_SINGLE_MOUNT: procedure; /* This procedure is called to list the information about one mount. If we are in long mode we will list all available information. */ num_listed = num_listed + 1; if attach.device_name ^= " " then call ioa_ ("^5xDevice ^a", attach.device_name); else call ioa_ ("^5xDevice not yet assigned"); if attach.volume_name ^= " " then call ioa_ ("^-Volume^-= ^a", attach.volume_name); if attach.state = 0 /* State = 0 => free due to force unassignment. */ then do; call ioa_ ("^-State^-= force unassigned"); return; end; if ^long_flag /* Does user want all available info? */ then return; /* No. */ call ioa_ ("^-State^-= ^a", operation_states (attach.state)); call date_time_ (attach.state_time, time_string); call ioa_ ("^-Time^-= ^a", time_string); if attach.flags.priv then call ioa_ ("^-Attached with privilege"); if attach.flags.writing then call ioa_ ("^-Attached for writing"); call ioa_ ("^-Level^-= ^d", attach.level); k = attach.workspace_max / 1024; call ioa_ ("^-WS Max^-= ^d K", k); seconds = attach.timeout_max / 1000000; call ioa_ ("^-TO Max^-= ^d seconds", seconds); end LIST_SINGLE_MOUNT; LIST_RESERVATION: procedure (arg_rid); dcl arg_rid fixed bin (71); dcl request_id_ entry (fixed bin (71)) returns (char (19)); 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 = request_id_ (rid); if long_flag then /* Print full reservation id. */ call ioa_ ("^/^2xReservation ^a (claimed)", rid_string); else call ioa_ ("^/^2xReservation ^a (claimed)", substr (rid_string, 7, 6)); header_printed = "0"b; do k = 1 to rli.head.num_device_resv; /* Look at all device entries. */ device_resv_ptr = addr (rli.device_resvs (k)); if device_resv.reservation_id = rid then do; /* Got one. */ if ^header_printed then do; /* Print header. */ call ioa_ ("^5xDevices"); header_printed = "1"b; end; call ioa_ ("^-^a", device_resv.device_name); device_resv.reservation_id = 0; end; end; header_printed = "0"b; do k = 1 to rli.head.num_vol_resv; /* Look at all vol entries. */ vol_resv_ptr = addr (rli.vol_resvs (k)); if vol_resv.reservation_id = rid then do; /* Got one. */ if ^header_printed then do; /* Print header. */ call ioa_ ("^5xVolumes"); header_printed = "1"b; end; call ioa_ ("^-^a", vol_resv.volume_name); vol_resv.reservation_id = 0; end; end; return; end LIST_RESERVATION; LIST_ACQUISITIONS: proc; dcl sys_info$max_seg_size ext fixed bin (35) static; dcl define_area_ ext entry (pointer, fixed bin (35)), release_area_ ext entry (pointer), get_group_id_ ext entry returns (char (32)), (rcp_$list_resources, rcp_admin_$list_resources, rcp_admin_$list_awaiting_clear) entry (char (*), char (*), char (*), pointer, fixed bin (35), pointer, fixed bin (35)); dcl group_id char (32), uname char (32), pname char (32), n_resources fixed bin (35), priv_sw bit (1) aligned; dcl 1 auto_area_info like area_info aligned automatic; %include area_info; %include resource_list; if resource_type = "" then if awaiting_clear then call crump (error_table_$wrong_no_of_args, "-type must be specified with -awaiting_clear."); else call crump (error_table_$wrong_no_of_args, "-type must be specified with -acquisitions."); unspec (auto_area_info) = ""b; auto_area_info.version = area_info_version_1; auto_area_info.extend, auto_area_info.no_freeing = "1"b; auto_area_info.owner = "list_resources"; auto_area_info.size = sys_info$max_seg_size; auto_area_info.areap = temp_seg_ptr; call define_area_ (addr (auto_area_info), ecode); if ecode ^= 0 then call crump (ecode, "defining temporary area."); on cleanup call release_area_ (temp_seg_ptr); /* no real window exists here -- */ /* this is only necessary after call to ring 1 may extend area to multi segments */ group_id = get_group_id_ (); group_id = substr (group_id, 1, length (rtrim (group_id, " ")) - 2); /* cut off tag */ if user_id = "" then user_id = group_id; if user_id = group_id then priv_sw = ""b; else do; uname = before (user_id, "."); pname = after (user_id, "."); if (uname = "*") & (pname ^= "*") then priv_sw = ""b; else priv_sw = "1"b; end; if awaiting_clear then call rcp_admin_$list_awaiting_clear (resource_type, registry_dir, user_id, temp_seg_ptr, n_resources, resource_list_ptr, ecode); else if priv_sw then call rcp_admin_$list_resources (resource_type, registry_dir, user_id, temp_seg_ptr, n_resources, resource_list_ptr, ecode); else call rcp_$list_resources (resource_type, registry_dir, user_id, temp_seg_ptr, n_resources, resource_list_ptr, ecode); if ecode ^= 0 then call crump (ecode, "Resource type " || rtrim (resource_type) || " for " || user_id); if called_as_af then return_arg = ""; else do; call date_time_ (clock (), time_string); call ioa_ ("^[No resources^2s^;^[1 resource^s^;^d resources^]^] of type ^a ^[awaiting manual clear.^;acquired by ^a^[.^; at ^a:^/^]^]", (n_resources = 0), (n_resources = 1), n_resources, resource_type, awaiting_clear, user_id, (n_resources = 0), time_string); end; do resource_list_ptr = resource_list_ptr repeat (resource_list.forward_ptr) while (resource_list_ptr ^= null); do i = 1 to resource_list.n_resources; if called_as_af then do; return_arg = return_arg || rtrim (resource_list.resource_name (i)); return_arg = return_arg || " "; end; else call ioa_ ("^a", resource_list.resource_name (i)); end; end; if called_as_af then return_arg = rtrim (return_arg); call release_area_ (temp_seg_ptr); return; end LIST_ACQUISITIONS; GET_TEMP_SEG: procedure; /* This procedure is called to get a temporary work segment for the RLI structure. */ call get_temp_segment_ ("list_resources", temp_seg_ptr, ecode); if ecode ^= 0 then call crump (ecode, "Error getting temporary segment"); call hcs_$get_max_length_seg (temp_seg_ptr, seg_size, ecode); if ecode ^= 0 then call crump (ecode, "Error getting max seg length of temp segment"); rli_ptr = temp_seg_ptr; end GET_TEMP_SEG; crump: proc (ecode, reason); dcl ecode fixed bin (35) parameter, reason char (*) parameter; dcl com_err_entry entry variable options (variable); if called_as_af then com_err_entry = active_fnc_err_; else com_err_entry = com_err_; call com_err_entry (ecode, "list_resources", "^a", reason); if called_as_af then return_arg = ""; goto RETURN; end crump; test: entry (new_sysdir); dcl new_sysdir char (*) parameter; if new_sysdir = "" then registry_dir = ">system_control_1>rcp"; else registry_dir = new_sysdir; return; end list_resources;  parse_resource_desc_.pl1 07/16/87 1349.5r 07/15/87 1548.7 317574 /****^ *********************************************************** * * * 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. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-07-28,Hartogs), approve(86-07-28,MCR7463), audit(86-08-06,Lippard), install(86-08-14,MR12.0-1123): Make changes to disallow specifying less than 1 resource for reservation. 2) change(87-06-08,Rauschelbach), approve(87-07-07,MCR7728), audit(87-07-08,Farley), install(87-07-15,MR12.1-1040): Changed to set the variable err_msg only when this segment is called throught the check entry point. END HISTORY COMMENTS */ /* format: off */ parse_resource_desc_: proc (desc_str, area_ptr, resource_desc_ptr, resource_res_ptr, code); /* This subroutine takes a reservation description string as input and returns pointers to two structures containing the necessary information to make a reservation of the described resources. It calls cv_rcp_attributes_$from_string_rel to convert the attributes character string to a bit string if necessary. */ /* Written by R.J.C. Kissel 3/78. Modified by R.J.C. Kissel 1/79 to handle the new resource description in a compatible fashion. Modified by R.J.C. Kissel 3/79 to communicate in a kludgey way with build_resource_desc_. */ /* Arguments */ dcl desc_str char (*); /* The reservation description string. */ dcl area_ptr ptr; /* Area in which to allocate structures. */ /* See the resource_control_desc.incl.pl1 for ptr declarations. */ dcl code fixed bin (35); /* Standard system status code. */ /* Local Variables */ dcl check bit (1); /* Syntax checking flag. */ dcl arg_string char (256) varying; /* To hold individual arguments. */ dcl volume bit (1); /* Resource type is device or volume. */ dcl count fixed bin; /* Count of allocations. */ dcl cur_pos fixed bin; /* Current position in desc_str. */ dcl i fixed bin; /* Index for accessing structures. */ dcl junk_bit bit (1); dcl rsc_type char (32); /* primary resource type */ dcl new ptr; /* Pointer to a new parse_info structure. */ dcl head ptr; /* Pointer to the head of the parse_info list. */ dcl tail ptr; /* Pointer to the tail of the parse_info list. */ dcl 1 parse_info based, /* Structure to save info from each resource description. */ 2 next ptr, /* Next structure in the list. */ 2 rsc_type char (32), /* The resource type. */ 2 rsc_name char (32), /* The resource name. */ 2 attr bit (72) dim (4), /* The resource attributes. */ 2 number fixed bin; /* How many of this resource to get. */ /* Local Constants */ /* Local Overlays */ dcl based_area area (261129) based; /* Area overlay. */ /* Include Files */ %include resource_control_desc; %include rcp_resource_types; /* External Entries */ dcl cv_rcp_attributes_$from_string_rel entry (char (*), bit (72) dim (4), char (*) varying, fixed bin (35)); dcl get_system_free_area_ entry returns (ptr); dcl resource_info_$get_primary_type entry (char (*), char (*), fixed bin (35)); dcl resource_info_$get_type entry (char (*), bit (1), fixed bin (35)); dcl get_group_id_ entry returns (char (32)); dcl build_resource_desc_$reserve entry ((*) char (*) varying, ptr, ptr, ptr, ptr, ptr, char (*) varying, fixed bin (35)); /* External Constants */ dcl error_table_$badcall fixed bin (35) external; dcl error_table_$noarg fixed bin (35) external; dcl error_table_$name_not_found fixed bin (35) external; dcl error_table_$bad_conversion fixed bin (35) external; dcl error_table_$bad_index fixed bin (35) external; dcl error_table_$badopt fixed bin (35) external; dcl error_table_$inconsistent fixed bin (35) external; dcl error_table_$unbalanced_quotes fixed bin (35) external; dcl error_table_$resource_type_unknown fixed bin (35) external; dcl error_table_$resource_spec_ambiguous fixed bin (35) external; dcl error_table_$area_too_small fixed bin (35) external; /* Builtin Functions and Conditions */ dcl (lbound, hbound, unspec, length, null, convert, substr, ltrim, rtrim) builtin; dcl (cleanup, conversion, area) condition; check = "0"b; if area_ptr = null then area_ptr = get_system_free_area_ (); /* Default area for this entry. */ goto START; /* This is the only reference to this label. */ check: entry (desc_str, area_ptr, resource_desc_ptr, resource_res_ptr, err_msg, code); /* * This entry takes the same inputs and returns the same outputs as parse_resource_desc_. However, more complete diagnostics are available in case an error is detected. */ /* Arguments */ dcl err_msg char (*) varying; /* A description of an error if one occurs. */ err_msg = ""; check = "1"b; START: /* There is only one reference to this label. */ dcl 1 token based aligned, 2 next ptr, 2 index fixed bin (24), 2 length fixed bin (24); dcl tp ptr; /* Token pointer. */ dcl outidx fixed bin (24); dcl inidx fixed bin (24); dcl token_head_ptr ptr; /* Start of token list. */ dcl num_of_tokens fixed bin; dcl max_token_length fixed bin (24); dcl token_array dim (num_of_tokens) char (max_token_length) varying based; dcl tap ptr; /* Token array pointer. */ dcl aidx fixed bin; /* Token array index. */ dcl token_string char (string_length) based; dcl tsp ptr; /* Token string pointer. */ dcl string_length fixed bin (24); dcl token_index fixed bin (24); dcl token_length fixed bin (24); dcl token_exists bit (1); dcl error_msg char (256) varying; dcl new_code fixed bin (35); dcl ridx fixed bin; /* Resource description index. */ num_of_tokens = 0; max_token_length = 0; token_head_ptr = null (); tap = null (); tsp = null (); tp = null (); on cleanup call Cleanup_Handler; string_length = length (desc_str); on area goto ERROR_area; allocate token_string set (tsp); revert area; inidx = 1; outidx = 1; tsp -> token_string = ""; call Get_Next_Token (desc_str, tsp -> token_string, inidx, outidx, token_index, token_length, token_exists); on area goto ERROR_area; /* Push tokens onto a LIFO stack, keeping track of how many there are and the length of the longest one. */ do while (token_exists); allocate token set (tp); tp -> token.index = token_index; tp -> token.length = token_length; tp -> token.next = token_head_ptr; token_head_ptr = tp; num_of_tokens = num_of_tokens + 1; if token_length > max_token_length then max_token_length = token_length; call Get_Next_Token (desc_str, tsp -> token_string, inidx, outidx, token_index, token_length, token_exists); end; if num_of_tokens > 0 then allocate token_array set (tap); else goto ERROR_notype; revert area; /* Now fill in the token_array from the end so that the tokens will be in their original order. */ do aidx = hbound (tap -> token_array, 1) to lbound (tap -> token_array, 1) by -1; tp = token_head_ptr; if tp = null () then goto ERROR_internal; tap -> token_array (aidx) = substr (tsp -> token_string, tp -> token.index, tp -> token.length); token_head_ptr = tp -> token.next; free tp -> token; /* Clean up as we go. */ end; free tsp -> token_string; /* This is no longer needed. */ /* Now call build_resource_desc_$reserve to do the real parsing work and error checking. Note that for now, build_resource_desc_ can return a zero error code and a non-null error message of "User speicfied attributes.". This will be used as explained in a comment below. */ call build_resource_desc_$reserve (tap -> token_array, area_ptr, null (), resource_desc_ptr, resource_res_ptr, null (), error_msg, new_code); if new_code ^= 0 then goto ERROR_rdesc; /* Now check the resource description structures to make sure they adhere to the very limited rules currently allowed. */ if resource_desc_ptr ^= null () then do; Resource_count = resource_descriptions.n_items; do ridx = 1 to Resource_count by 1; /* Check for possible old description which would be parsed correctly. */ if resource_descriptions.item (ridx).name = VOLUME_TYPE (TAPE_VOL_VTYPEX) | resource_descriptions.item (ridx).name = DEVICE_TYPE (TAPE_DRIVE_DTYPEX) | resource_descriptions.item (ridx).name = VOLUME_TYPE (DISK_VOL_VTYPEX) | resource_descriptions.item (ridx).name = DEVICE_TYPE (DISK_DRIVE_DTYPEX) then do; new_code = 0; error_msg = ""; call Cleanup_Handler (); revert cleanup; goto OLD_DESCRIPTION_PARSER; end; call resource_info_$get_primary_type ((resource_descriptions.item (ridx).type), rsc_type, code); if code ^= 0 then goto ERROR_type; if rsc_type ^= VOLUME_TYPE (TAPE_VOL_VTYPEX) & rsc_type ^= DEVICE_TYPE (TAPE_DRIVE_DTYPEX) & rsc_type ^= VOLUME_TYPE (DISK_VOL_VTYPEX) & rsc_type ^= DEVICE_TYPE (DISK_DRIVE_DTYPEX) then goto ERROR_type; if (unspec (resource_descriptions.item (ridx).given) & "337777777777"b3) ^= "0"b then goto ERROR_carg; /* The following is a kludge agreed upon by parse_resource_desc_ and build_resource_desc_. It allows build_resource_desc_ to pass back information about what the user really specified so that parse_resource_desc_ can use it here to restrict the acceptable syntax of a resource description. This must be done because when build_resource_desc_ sets defaults the attributes given bit will always be set so that rcp_reserve_ can use the defaults even if the user didn't specify any attributes. This destroys any information that build_resource_desc_ could return about what the user really said on his command line which is the information that parse_resource_desc_ currently needs. */ if resource_descriptions.item (ridx).given.name & resource_descriptions.item (ridx).status_code = 1 then goto ERROR_nmattr; if (resource_descriptions.item (ridx).type = VOLUME_TYPE (TAPE_VOL_VTYPEX) | resource_descriptions.item (ridx).type = VOLUME_TYPE (DISK_VOL_VTYPEX)) & ^resource_descriptions.item (ridx).given.name then goto ERROR_volnm; end; end; /* Done with the extra checks for MR7.0. */ free tap -> token_array; /* Finish freeing everything. */ if check then err_msg = ""; code = 0; revert cleanup; return; ERROR_type: code = error_table_$resource_type_unknown; if check then err_msg = resource_descriptions.item (ridx).type; call Cleanup_Handler (); revert cleanup; return; ERROR_carg: code = error_table_$badopt; if check then err_msg = "A control arg other than -attributes or -number was given."; call Cleanup_Handler (); revert cleanup; return; ERROR_volnm: code = error_table_$resource_spec_ambiguous; if check then err_msg = "Names must be given for volume resource types."; call Cleanup_Handler (); revert cleanup; return; ERROR_nmattr: code = error_table_$inconsistent; if check then err_msg = "If a name is given then attributes may not be given."; call Cleanup_Handler (); revert cleanup; return; ERROR_noroom: code = error_table_$bad_index; if check then err_msg = "Internal error in parse_resource_desc_."; call Cleanup_Handler (); revert cleanup; return; ERROR_noquote: code = error_table_$unbalanced_quotes; if check then err_msg = "Rest of string is: " || substr (desc_str, inidx); call Cleanup_Handler (); revert cleanup; return; ERROR_internal: code = error_table_$bad_index; if check then err_msg = "Internal indexing error in parse_resource_desc_."; call Cleanup_Handler (); revert cleanup; return; ERROR_notype: code = error_table_$resource_spec_ambiguous; if check then err_msg = "At least a resource type must be specified."; call Cleanup_Handler (); revert cleanup; return; ERROR_area: code = error_table_$area_too_small; if check then err_msg = "Not enough area storage to allocate internal structures."; call Cleanup_Handler (); revert cleanup; return; ERROR_rdesc: /* For now we have the new error code and the error message, so we will let the old parser have a chance. If it works, then we will be happy and report no errors. If it fails then we will report the code and error found here. */ call Cleanup_Handler (); revert cleanup; goto OLD_DESCRIPTION_PARSER; Get_Next_Token: proc (P_instr, P_outstr, P_inidx, P_outidx, P_tidx, P_tlen, P_texists); dcl ( P_instr char (*), /* Input -- string of tokens. */ P_outstr char (*), /* Input/Output -- string into which tokens are copied. */ P_inidx fixed bin (24), /* Input/Output -- index into P_instr. */ P_outidx fixed bin (24), /* Input/Output -- index into P_outstr. */ P_tidx fixed bin (24), /* Output -- index in P_outstr of the current token. */ P_tlen fixed bin (24), /* Output -- length of the current token. */ P_texists bit (1) /* Output -- true if the current token exists. */ ) parameter; /* D_E_S_C_R_I_P_T_I_O_N_ This subroutine takes a character string and parses it into tokens. A token is delimited by white space (space, horizontal tab, vertical tab, form feed, carrige return, or new line). Quoted tokens are handled correctly and are returned with one level of quotes stripped. The token is returned by giving its index and length in P_outstr. Notice that P_outstr need be no longer than P_instr (because quotes and white space are only removed, never added). Also, the caller should never modify the Input/Output parameters: P_inidx, P_outidx, and P_outstr. However, on the first call both P_inidx and P_outidx should be initialized to 1, and P_outstr should be initailized to the null string. P_instr is never modified by this subroutine. J_O_U_R_N_A_L_I_Z_A_T_I_O_N_ 1) Written 11/78 by R.J.C. Kissel. */ /* Local Variables */ dcl start_of_token fixed bin (24); dcl length_of_token fixed bin (24); dcl subtoken_len fixed bin (24); dcl subtoken_idx fixed bin (24); dcl outidx fixed bin (24); dcl more_string bit (1); /* Local Constants */ dcl C_true bit (1) init ("1"b); dcl C_false bit (1) init ("0"b); dcl C_quote char (1) init (""""); dcl C_white_space char (6) init (" "); /* SP, HT, VT, FF, CR, NL */ /* Builtin Fucntions and Conditions */ dcl (length, substr, search, verify) builtin; if P_inidx = length (P_instr) + 1 then do; /* The input string is already processed. */ P_tidx = 0; P_tlen = 0; P_texists = C_false; return; end; /* The input string is already processed. */ length_of_token = 0; start_of_token = verify (substr (P_instr, P_inidx), C_white_space) + P_inidx - 1; if start_of_token = P_inidx - 1 then do; /* There is no token, only white space. */ P_inidx = length (P_instr) + 1; /* Last character index + one. */ P_tidx = 0; P_tlen = 0; P_texists = C_false; end; /* There is no token, only white space. */ else do; /* There is a token to process. */ if substr (P_instr, start_of_token, 1) ^= C_quote then do; /* Process a regular token. */ length_of_token = search (substr (P_instr, start_of_token), C_white_space) - 1; if length_of_token = -1 then length_of_token = length (substr (P_instr, start_of_token)); if search (substr (P_instr, start_of_token, length_of_token), C_quote) ^= 0 then goto ERROR_noquote; /* Don't allow embedded quotes. */ if P_outidx + length_of_token - 1 > length (P_outstr) then goto ERROR_noroom; substr (P_outstr, P_outidx, length_of_token) = substr (P_instr, start_of_token, length_of_token); /* copy the token. */ P_tidx = P_outidx; P_tlen = length_of_token; P_texists = C_true; P_inidx = start_of_token + length_of_token; P_outidx = P_outidx + length_of_token; end; /* Process a regular token. */ else do; /* Process a quoted string token. */ outidx = P_outidx; subtoken_idx = start_of_token; more_string = C_true; do while (more_string); subtoken_idx = subtoken_idx + 1; /* Skip the initial quote. */ subtoken_len = search (substr (P_instr, subtoken_idx), C_quote) - 1; /* Look for the next quote. */ if subtoken_len = -1 then goto ERROR_noquote; /* Now copy the subtoken we just found without the final quote and checking for the null string. */ if subtoken_len > 0 then do; /* There is something to copy. */ if outidx + subtoken_len - 1 > length (P_outstr) then goto ERROR_noroom; substr (P_outstr, outidx, subtoken_len) = substr (P_instr, subtoken_idx, subtoken_len); /* copy the token. */ outidx = outidx + subtoken_len; /* Move the index in P_outstr to the next available position. */ end; /* There is something to copy. */ length_of_token = length_of_token + subtoken_len; /* Keep track of the total length of the token. */ subtoken_idx = subtoken_idx + subtoken_len + 1; /* Skip the final quote in the subtoken. */ if substr (P_instr, subtoken_idx, 1) = C_quote then do; /* Take care of a doubled quote. */ if outidx + 1 - 1 > length (P_outstr) then goto ERROR_noroom; substr (P_outstr, outidx, 1) = C_quote; /* Copy the quote. */ outidx = outidx + 1; /* Move the index in P_outstr to the next available position. */ length_of_token = length_of_token + 1; /* Keep track of the total length of the token. */ end; /* Take care of a doubled quote. */ else if verify (substr (P_instr, subtoken_idx, 1), C_white_space) ^= 0 then goto ERROR_noquote; else more_string = C_false; /* Done with the quoted token. */ end; P_tidx = P_outidx; P_tlen = length_of_token; P_texists = C_true; P_inidx = subtoken_idx; P_outidx = P_outidx + length_of_token; end; /* Process a quoted string token. */ end; /* There is a token to process. */ end Get_Next_Token; Cleanup_Handler: proc (); if tap ^= null () then free tap -> token_array; if tsp ^= null () then free tsp -> token_string; if tp ^= null () & tp ^= token_head_ptr then free tp -> token; /* A small window. */ do while (token_head_ptr ^= null ()); tp = token_head_ptr; token_head_ptr = tp -> token.next; free tp -> token; end; if area_ptr ^= null () then do; if resource_desc_ptr ^= null () then do; free resource_descriptions in (area_ptr -> based_area); resource_desc_ptr = null (); end; if resource_res_ptr ^= null () then do; free reservation_description in (area_ptr -> based_area); resource_res_ptr = null (); end; end; end Cleanup_Handler; OLD_DESCRIPTION_PARSER: /* Initialize pointers and local variables. */ resource_desc_ptr = null; resource_res_ptr = null; code = 0; arg_string = ""; volume = "0"b; count = 0; cur_pos = 0; new = null; head = null; tail = null; on cleanup call cleanup_handler; arg_string = get_next_arg (desc_str, cur_pos); if arg_string = "" then goto BAD_DESC; do while (arg_string ^= ""); /* Process one resource description at a time. */ /* Check the validity of the resource type argument. */ call resource_info_$get_type ((arg_string), volume, code); if code ^= 0 then goto BAD_TYPE; /* Process all the arguments for one resource description. */ allocate parse_info set (new); new -> parse_info.next = null; new -> parse_info.rsc_type = arg_string; new -> parse_info.rsc_name = ""; new -> parse_info.attr = "0"b; new -> parse_info.number = 1; /* There is at least one. */ if head = null then head = new; if tail ^= null then tail -> parse_info.next = new; tail = new; if ^volume then do; /* This is a device type resource. */ arg_string = get_next_arg (desc_str, cur_pos); if arg_string = "" then do; /* All defaults apply and we are done. */ call cv_rcp_attributes_$from_string_rel (new -> parse_info.rsc_type, new -> parse_info.attr, "", code); if code ^= 0 then goto BAD_DEFAULT; end; /* All defaults apply and we are done. */ else if arg_string = "-name" | arg_string = "-nm" then do; /* A strange name argument. */ arg_string = get_next_arg (desc_str, cur_pos); if arg_string = "" then goto BAD_NAME_ARG; new -> parse_info.rsc_name = arg_string; arg_string = get_next_arg (desc_str, cur_pos); end; /* A strange name argument. */ else if arg_string = "-attributes" | arg_string = "-attr" then do; /* Attributes argument. */ arg_string = get_next_arg (desc_str, cur_pos); if arg_string = "" then goto BAD_ATTR_ARG; call cv_rcp_attributes_$from_string_rel (new -> parse_info.rsc_type, new -> parse_info.attr, arg_string, code); if code ^= 0 then goto BAD_ATTR; arg_string = get_next_arg (desc_str, cur_pos); if arg_string = "-number" | arg_string = "-nb" then do; /* We can have a number in this case. */ arg_string = get_next_arg (desc_str, cur_pos); if arg_string = "" then goto BAD_NUM_ARG; on conversion goto BAD_NUMBER; new -> parse_info.number = convert (new -> parse_info.number, arg_string); revert conversion; if new -> parse_info.number <= 0 then goto BAD_NUMBER; arg_string = get_next_arg (desc_str, cur_pos); end; /* We can have a number in this case. */ end; /* Attributes argument. */ else if arg_string = "-number" | arg_string = "-nb" then do; /* Number argument. */ arg_string = get_next_arg (desc_str, cur_pos); if arg_string = "" then goto BAD_NUM_ARG; on conversion goto BAD_NUMBER; new -> parse_info.number = convert (new -> parse_info.number, arg_string); revert conversion; if new -> parse_info.number <= 0 then goto BAD_NUMBER; arg_string = get_next_arg (desc_str, cur_pos); if arg_string ^= "-attributes" & arg_string ^= "-attr" then do; /* Get default attributes. */ call cv_rcp_attributes_$from_string_rel (new -> parse_info.rsc_type, new -> parse_info.attr, "", code); if code ^= 0 then goto BAD_DEFAULT; end; /* Get default attributes. */ else do; /* Attributes argument. */ arg_string = get_next_arg (desc_str, cur_pos); if arg_string = "" then goto BAD_ATTR_ARG; call cv_rcp_attributes_$from_string_rel (new -> parse_info.rsc_type, new -> parse_info.attr, arg_string, code); if code ^= 0 then goto BAD_ATTR; arg_string = get_next_arg (desc_str, cur_pos); end; /* Attributes argument. */ end; /* Number argument. */ else do; /* A device name may have been given. */ call resource_info_$get_type ((arg_string), junk_bit, code); /* Just want the code. */ if code ^= 0 then do; /* A device name. */ if code = error_table_$name_not_found then do; code = 0; new -> parse_info.rsc_name = arg_string; arg_string = get_next_arg (desc_str, cur_pos); end; else goto BAD_ERROR; end; /* A device name. */ end; /* A device name may have been given. */ end; /* This is a device type resource. */ else do; /* This is a volume type resource. */ arg_string = get_next_arg (desc_str, cur_pos); if arg_string = "" then goto BAD_VOL_NAME; if arg_string = "-name" | arg_string = "-nm" then do; /* Strange name argument. */ arg_string = get_next_arg (desc_str, cur_pos); if arg_string = "" then goto BAD_NAME_ARG; new -> parse_info.rsc_name = arg_string; end; /* Strange name argument. */ else if substr (arg_string, 1, 1) = "-" then goto BAD_VOL_NAME; else new -> parse_info.rsc_name = arg_string; arg_string = get_next_arg (desc_str, cur_pos); end; /* This is a volume type resource. */ count = count + tail -> parse_info.number; end; /* Process one resource description at a time. */ /* Now build the structures to return in the appropriate area. */ if area_ptr = null then do; /* We are done. */ code = 0; call cleanup_handler; return; end; /* We are done. */ Resource_count = count; /* Need this to allocate the structures. */ on area goto BAD_AREA; allocate resource_descriptions in (area_ptr -> based_area) set (resource_desc_ptr); allocate reservation_description in (area_ptr -> based_area) set (resource_res_ptr); revert area; /* Fill in the constant parts of the structures with the given information and defaults. */ resource_descriptions.version_no = resource_desc_version_1; resource_descriptions.n_items = Resource_count; reservation_description.version_no = resource_res_version_1; reservation_description.reserved_for = get_group_id_ (); reservation_description.reserved_by = get_group_id_ (); reservation_description.group_starting_time = 0; reservation_description.asap_duration = 0; reservation_description.auto_expire = "0"b; reservation_description.asap = "0"b; reservation_description.rel = "1"b; reservation_description.sec = "0"b; reservation_description.n_items = Resource_count; /* Fill in the variable parts of the structures with the given information and defaults. */ new = head; do i = 1 to Resource_count by 1; resource_descriptions.item (i).type = new -> parse_info.rsc_type; resource_descriptions.item (i).name = new -> parse_info.rsc_name; resource_descriptions.item (i).uid = "0"b; resource_descriptions.item (i).potential_attributes = "0"b; resource_descriptions.item (i).desired_attributes (*) = new -> parse_info.attr (*); resource_descriptions.item (i).owner = ""; resource_descriptions.item (i).acs_path = ""; resource_descriptions.item (i).aim_range (*) = "0"b; resource_descriptions.item (i).potential_aim_range (*) = "0"b; resource_descriptions.item (i).location = ""; resource_descriptions.item (i).comment = ""; resource_descriptions.item (i).charge_type = ""; unspec (resource_descriptions.item (i).given) = "0"b; /* Set everything off to start. */ resource_descriptions.item (i).given.name = (resource_descriptions.item (i).name ^= ""); resource_descriptions.item (i).given.uid = (resource_descriptions.item (i).uid ^= "0"b); if (resource_descriptions.item (i).desired_attributes (1) | resource_descriptions.item (i).desired_attributes (2) | resource_descriptions.item (i).desired_attributes (3) | resource_descriptions.item (i).desired_attributes (4)) = "0"b then resource_descriptions.item (i).given.desired_attributes = "0"b; else resource_descriptions.item (i).given.desired_attributes = "1"b; resource_descriptions.item (i).given.owner = (resource_descriptions.item (i).owner ^= ""); if (resource_descriptions.item (i).aim_range (1) | resource_descriptions.item (i).aim_range (2)) = "0"b then resource_descriptions.item (i).given.aim_range = "0"b; else resource_descriptions.item (i).given.aim_range = "1"b; resource_descriptions.item (i).rew = "0"b; resource_descriptions.item (i).usage_lock = "0"b; resource_descriptions.item (i).release_lock = "0"b; resource_descriptions.item (i).awaiting_clear = "0"b; resource_descriptions.item (i).user_alloc = "0"b; resource_descriptions.item (i).pad2 = "0"b; resource_descriptions.item (i).state = "0"b; resource_descriptions.item (i).status_code = 0; reservation_description.reservation_group (i).starting_time = 0; reservation_description.reservation_group (i).duration = 0; if new -> parse_info.number = 1 then new = new -> parse_info.next; else new -> parse_info.number = new -> parse_info.number - 1; end; /* Fill in variable parts. */ if check then err_msg = "Warning: the old format resource description """ || ltrim (rtrim (desc_str)) || """ should be converted to the new format."; code = 0; return; /* Error handling section */ BAD_ERROR: if new_code = 0 then do; if check then err_msg = "An error occurred in RCP, contact a systems programmer."; end; else do; code = new_code; if check then err_msg = error_msg; end; call cleanup_handler; return; BAD_DESC: if new_code = 0 then do; code = error_table_$noarg; if check then err_msg = "At least one resource type must be given in the resource description."; end; else do; code = new_code; if check then err_msg = error_msg; end; call cleanup_handler; return; BAD_NUMBER: if new_code = 0 then do; code = error_table_$bad_conversion; if check then err_msg = "Invalid number: " || arg_string; end; else do; code = new_code; if check then err_msg = error_msg; end; call cleanup_handler; return; BAD_TYPE: if new_code = 0 then do; code = error_table_$badcall; if check then err_msg = "The specified resource type is not valid: " || arg_string; end; else do; code = new_code; if check then err_msg = error_msg; end; call cleanup_handler; return; BAD_DEFAULT: if new_code = 0 then do; if check then err_msg = "An error occurred setting default attributes for " || new -> parse_info.rsc_type; end; else do; code = new_code; if check then err_msg = error_msg; end; call cleanup_handler; return; BAD_NAME_ARG: if new_code = 0 then do; code = error_table_$noarg; if check then err_msg = "Name argument missing for resource type " || new -> parse_info.rsc_type; end; else do; code = new_code; if check then err_msg = error_msg; end; call cleanup_handler; return; BAD_ATTR_ARG: if new_code = 0 then do; code = error_table_$noarg; if check then err_msg = "Attribute argument missing for resource type " || new -> parse_info.rsc_type; end; else do; code = new_code; if check then err_msg = error_msg; end; call cleanup_handler; return; BAD_ATTR: if new_code = 0 then do; if check then err_msg = "Error converting attribute string: " || arg_string; end; else do; code = new_code; if check then err_msg = error_msg; end; call cleanup_handler; return; BAD_NUM_ARG: if new_code = 0 then do; code = error_table_$noarg; if check then err_msg = "Number argument missing for resource type " || new -> parse_info.rsc_type; end; else do; code = new_code; if check then err_msg = error_msg; end; call cleanup_handler; return; BAD_VOL_NAME: if new_code = 0 then do; code = error_table_$noarg; if check then err_msg = "The volume name must be specified for resource type " || new -> parse_info.rsc_type; end; else do; code = new_code; if check then err_msg = error_msg; end; call cleanup_handler; return; BAD_AREA: if new_code = 0 then do; code = error_table_$badcall; if check then err_msg = "The specified area is not big enough to hold the necessary structures."; end; else do; code = new_code; if check then err_msg = error_msg; end; call cleanup_handler; return; get_next_arg: proc (in_string, position) returns (char (256) varying); /* This subroutine takes a character string as input and picks out the next argument delimited by blanks. It returns the null string if there are no more arguments. */ /* Arguments */ dcl in_string char (*); /* Input string. */ dcl position fixed bin; /* An index always left pointing just after the arg */ /* returned in in_string. */ dcl arg char (256) varying; /* The returned argument. */ /* Local Variables */ dcl pos1 fixed bin; /* Start of string. */ dcl pos2 fixed bin; /* End of string. */ /* Builtin Functions and Conditions */ dcl (substr, verify, search, length) builtin; if position = length (in_string) then do; /* No more args left. */ arg = ""; return (arg); end; /* No more args left. */ if position = 0 then position = 1; /* Ready for use in substr. */ pos1 = verify (substr (in_string, position), " "); if pos1 = 0 then do; /* String is all blanks. */ arg = ""; position = length (in_string); return (arg); end; /* String is all blanks. */ pos1 = pos1 + position - 1; /* Get index in the whole string. */ pos2 = search (substr (in_string, pos1), " "); if pos2 = 0 then do; /* Last arg in string. */ arg = substr (in_string, pos1); position = length (in_string); return (arg); end; /* Last arg in string. */ else do; /* Some middle arg in the string. */ pos2 = pos2 + pos1 - 1; /* Get index in the whole string. */ arg = substr (in_string, pos1, pos2 - pos1); position = pos2; return (arg); end; /* Some middle arg in the string. */ end get_next_arg; cleanup_handler: proc; if head ^= null | tail ^= null | new ^= null then do; /* Free the parse_info list. */ if tail ^= new then do; if new ^= null then free new -> parse_info; if tail ^= null then tail -> parse_info.next = null; /* Make sure the list ends. */ end; if head ^= null then do; /* Free the list from head to tail. */ do while (head ^= null); new = head -> parse_info.next; free head -> parse_info; head = new; end; end; /* Free the list from head to tail. */ end; /* Free the parse_info list. */ if area_ptr ^= null then do; /* Free the output structures. */ if resource_desc_ptr ^= null then do; free resource_descriptions in (area_ptr -> based_area); resource_desc_ptr = null; end; if resource_res_ptr ^= null then do; free reservation_description in (area_ptr -> based_area); resource_res_ptr = null; end; end; /* Free the output structures. */ call Cleanup_Handler (); end cleanup_handler; end parse_resource_desc_;  register_resource.pl1 08/06/87 1422.1rew 08/06/87 1304.7 126747 /****^ *********************************************************** * * * 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. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(87-06-19,Rauschelbach), approve(87-06-29,MCR7736), audit(87-07-21,Farley), install(87-08-06,MR12.1-1064): Error message duplication was removed, and a call to com_err_ with a more standard version. END HISTORY COMMENTS */ /* format:style4,delnl,insnl,indattr,ifthen,dclind10 */ register_resource: rgr: proc; /* This command registers a resource or a number of resources. Written 10/09/78 by C. D. Tavares */ /* Modified 08/79 by CDT to remove warning when default attributes are supplied from RTDT on registration. The fix is not a complete solution. */ /* Modified 12/10/79 by CDT to get rid of timer sleep code which is now handled in ring 1 */ /* Last modified 06/17/81 by CDT to make error messages nicer and to reject -owner in set_resource call. */ /* Modified 841106 to query users when registering/acquiring multi-class volumes which are basically useless... - M. M. Pozzo */ /* automatic */ dcl action fixed bin, ap pointer, al fixed bin, alp pointer, arg_positions_ptr pointer, eca_ptr pointer, nargs fixed bin, position fixed bin, code fixed bin (35), i fixed bin, myname char (32), err_msg char (256) varying, resource_subtype char (32), yes_sw bit (1); /* external static */ dcl ( sys_info$max_seg_size, error_table_$noarg, error_table_$inconsistent, error_table_$lock_wait_time_exceeded, error_table_$resource_not_modified, error_table_$action_not_performed ) external fixed bin (35) static; /* entries */ dcl aim_check_$equal entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned); dcl build_resource_desc_$from_arglist ext entry (pointer, pointer, pointer, pointer, bit (1) aligned, pointer, char (*) varying, fixed bin (35)); dcl define_area_ ext entry (pointer, fixed bin (35)), release_area_ ext entry (pointer); dcl command_query_$yes_no entry options (variable), cu_$arg_count ext entry (fixed bin), cu_$arg_ptr ext entry (fixed bin, pointer, fixed bin, fixed bin (35)), cu_$arg_list_ptr ext entry (pointer); dcl ioa_ ext entry options (variable); dcl resource_info_$defaults ext entry (char (*) aligned, char (*), pointer, fixed bin, fixed bin (35)); dcl ( rcp_admin_$register, rcp_admin_$deregister, rcp_sys_$clear_resource, rcp_admin_$acquire, rcp_$acquire, rcp_admin_$release, rcp_$release, rcp_admin_$set_status, rcp_$set_status ) ext entry (pointer, char (*), fixed bin (35)); /* based */ dcl arg char (al) based (ap), temp_area area (1000) based (auto_area_info.areap), arg_positions (eca_ptr -> arg_struc_template.n_extra_args) fixed bin based (arg_positions_ptr); dcl 1 arg_struc_template aligned based (eca_ptr), 2 n_extra_args fixed bin, 2 each (0 refer (arg_struc_template.n_extra_args)), 3 long_name char (32), 3 short_name char (32), 3 n_following fixed bin; /* builtins */ dcl (addr, null, unspec, index) builtin; /* conditions */ dcl cleanup condition; /* static */ dcl sys_dir char (168) static initial (">system_control_1>rcp"); /* constants */ dcl 1 register_control_args aligned static options (constant), 2 n_extra_args fixed bin initial (1), 2 each (1), 3 long_name char (32) initial ("-type"), 3 short_name char (32) initial ("-tp"), 3 n_following fixed bin initial (1); dcl 1 no_control_args aligned static options (constant), 2 n_extra_args fixed bin initial (0); dcl 1 only_priv_control_arg aligned static options (constant), 2 n_extra_args fixed bin initial (1), 2 each (1), 3 long_name char (32) initial ("-priv"), 3 short_name char (32) initial ("-priv"), 3 n_following fixed bin initial (0); dcl ( Register initial (1), Deregister initial (2), Acquire initial (3), Release initial (4), Set initial (5), Clear initial (6) ) fixed bin static options (constant); %page; %include resource_control_desc; %page; %include area_info; dcl 1 auto_area_info aligned automatic like area_info; %page; action = Register; myname = "register_resource"; goto common; %skip (4); deregister_resource: drr: entry; action = Deregister; myname = "deregister_resource"; goto common; %skip (4); acquire_resource: aqr: entry; action = Acquire; myname = "acquire_resource"; goto common; %skip (4); release_resource: rlr: entry; action = Release; myname = "release_resource"; goto common; %skip (4); set_resource: setr: entry; action = Set; myname = "set_resource"; goto common; %skip (4); clear_resource: clr: entry; action = Clear; myname = "clear_resource"; goto common; %skip (4); common: unspec (auto_area_info) = ""b; auto_area_info.version = area_info_version_1; auto_area_info.owner = myname; auto_area_info.size = sys_info$max_seg_size; auto_area_info.areap = null; auto_area_info.extend, auto_area_info.no_freeing = "1"b; call cu_$arg_count (nargs); if nargs < 2 then noarg: call crump (error_table_$noarg, "Usage: ^a resource_type resource_names {-control_args}"); call cu_$arg_list_ptr (alp); on cleanup call clean_up; call define_area_ (addr (auto_area_info), code); if code ^= 0 then call crump (code, "Defining area."); if action = Register then eca_ptr = addr (register_control_args); else if (action = Deregister) | (action = Clear) then eca_ptr = addr (no_control_args); else eca_ptr = addr (only_priv_control_arg); allocate arg_positions in (temp_area); call build_resource_desc_$from_arglist (alp, auto_area_info.areap, eca_ptr, resource_desc_ptr, (action = Register), arg_positions_ptr, err_msg, code); if code ^= 0 then call crump (code, (err_msg)); if resource_descriptions.n_items <= 0 then goto noarg; goto process_action (action); %page; process_action (1): /* register */ if ^resource_descriptions.item (1).given.owner then do; if resource_descriptions.item (1).given.aim_range then err_msg = "-access_class"; else if resource_descriptions.item (1).given.acs_path then err_msg = "-acs_path"; else if resource_descriptions.item (1).given.comment then err_msg = "-comment"; else if resource_descriptions.item (1).given.user_alloc then err_msg = "-user_alloc"; else if resource_descriptions.item (1).given.release_lock then err_msg = "-release_lock"; else err_msg = ""; if err_msg ^= "" then do; err_msg = err_msg || " requires -owner"; call crump (error_table_$inconsistent, (err_msg)); end; end; /* See if this is an acquire as well and if so, if this is a multi-class volume if the user really wants to do this */ if ^multi_class_volume_continue () then do; err_msg = "User does not wish to acquire useless multi-class volume"; call crump (error_table_$action_not_performed, (err_msg)); end; /* We get the defaults for this type of resource and fill them into the structure that we got back from build_resource_desc_ if they aren't already provided. Notice that we only do this for ONE resource type-- because the current syntax of the registration command only provides for registering resources of one resource type at a time; plus all of the resources share common control arguments, meaning that you can't (say) provide attributes for one resource but not the others; so we assume that if the first resource in the structure doesn't have something, none of them have it. */ Resource_count = 1; /* get defaults for type */ if search_list ("-type", position) then do; call cu_$arg_ptr (position + 1, ap, al, code); if code ^= 0 then call crump (code, "after -type."); resource_subtype = arg; end; else resource_subtype = ""; call resource_info_$defaults (resource_descriptions.item (1).type, resource_subtype, resource_desc_ptr, 0, code) ; if code ^= 0 then call crump (code, "Obtaining defaults."); call rcp_admin_$register (resource_desc_ptr, sys_dir, code); if code ^= 0 then call crump_in_struc (code, "Cannot register resources."); goto process_action_end; process_action (2): /* deregister */ call rcp_admin_$deregister (resource_desc_ptr, sys_dir, code); if code ^= 0 then call crump_in_struc (code, "Cannot deregister resources."); goto process_action_end; process_action (3): /* acquire */ /* If this is a multi-class volume acquire, make sure user really wants to do this */ if ^multi_class_volume_continue () then do; err_msg = "User does not wish to acquire useless multi-class volume"; call crump (error_table_$action_not_performed, (err_msg)); end; if search_list ("-priv", 0) then call rcp_admin_$acquire (resource_desc_ptr, sys_dir, code); else call rcp_$acquire (resource_desc_ptr, sys_dir, code); if code ^= 0 then call crump_in_struc (code, "Cannot acquire resources."); do i = 1 to resource_descriptions.n_items; if ^resource_descriptions.given.name (i) then call ioa_ ("Resource ^a ^a acquired.", resource_descriptions.type (i), resource_descriptions.item.name (i)); end; goto process_action_end; process_action (4): /* release */ if release_continue () then if search_list ("-priv", 0) then call rcp_admin_$release (resource_desc_ptr, sys_dir, code); else call rcp_$release (resource_desc_ptr, sys_dir, code); if code ^= 0 then call crump_in_struc (code, "Cannot release resources."); goto process_action_end; process_action (5): /* set */ if resource_descriptions.item (1).given.owner then call crump (error_table_$resource_not_modified, "Cannot modify resource owner via set_resource."); if search_list ("-priv", 0) then call rcp_admin_$set_status (resource_desc_ptr, sys_dir, code); else call rcp_$set_status (resource_desc_ptr, sys_dir, code); if code ^= 0 then call crump_in_struc (code, "Cannot set resources."); goto process_action_end; process_action (6): /* clear */ call rcp_sys_$clear_resource (resource_desc_ptr, sys_dir, code); if code ^= 0 then call crump_in_struc (code, "Cannot clear resources."); goto process_action_end; process_action_end: call clean_up; /* ----- */ clean_up: proc; if auto_area_info.areap ^= null then call release_area_ (auto_area_info.areap); end clean_up; /* ----- */ return_hard: return; %skip (4); search_list: proc (desired_arg, position) returns (bit (1) aligned); dcl desired_arg char (*) parameter, position fixed bin parameter; dcl i fixed bin; do i = 1 to eca_ptr -> arg_struc_template.n_extra_args while (eca_ptr -> arg_struc_template.long_name (i) ^= desired_arg); end; if i ^> eca_ptr -> arg_struc_template.n_extra_args then do; position = arg_positions (i); if position > 0 then return ("1"b); else return (""b); end; position = -1; return (""b); end search_list; %skip (4); crump: proc (code, reason); dcl code fixed bin (35), reason char (*); dcl ( com_err_, com_err_$suppress_name ) ext entry options (variable), i fixed bin; call com_err_ (code, myname, reason, myname); call clean_up; goto return_hard; crump_in_struc: entry (code, reason); do i = 1 to resource_descriptions.n_items while (resource_descriptions.item (i).status_code = 0); end; if i <= resource_descriptions.n_items then call com_err_ (code, myname, reason); else call com_err_ (resource_descriptions.item (i).status_code, myname, "for ^a ^a", resource_descriptions.item (i).type, resource_descriptions.item (i).name); if code = error_table_$lock_wait_time_exceeded then call com_err_$suppress_name (code, myname, "Resource registry is busy."); call clean_up; goto return_hard; end crump; %skip (4); test: entry (new_sys_dir); dcl new_sys_dir char (*) parameter; if new_sys_dir = "" then sys_dir = ">system_control_1>rcp"; else sys_dir = new_sys_dir; return; %skip (4); multi_class_volume_continue: proc () returns (bit (1)); dcl continue bit (1); continue = "1"b; /* Are we acquiring a multi-class resource */ if (resource_descriptions.item (1).given.owner & resource_descriptions.item (1).given.aim_range) then do; /* Is it a multi-class volume? */ if index (resource_descriptions.item (1).type, "vol") ^= 0 then do; /* Is the min_access_class < max_access_class? */ if ^aim_check_$equal (resource_descriptions.item (1).aim_range (1), resource_descriptions.item (1).aim_range (2)) then do; /* Does the user wish to continue? */ call command_query_$yes_no (yes_sw, 0, myname, "", "Do you really want to acquire a multi-class volume?"); if ^yes_sw then continue = "0"b; end; end; end; return (continue); end multi_class_volume_continue; %page; release_continue: proc () returns (bit (1)); dcl continue bit (1); continue = "1"b; call command_query_$yes_no (yes_sw, 0, myname, "", "Releasing this resource may cause it to be degaussed. Do you wish to continue?"); if ^yes_sw then continue = "0"b; return (continue); end release_continue; end register_resource;  reserve_resource.pl1 11/04/82 1936.3rew 11/04/82 1619.2 30555 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ reserve_resource: rsr: proc (); /* D_E_S_C_R_I_P_T_I_O_N_ This command takes a resource description and reserves the requested resources for the calling process. This command just implements the user interface. It calls parse_resource_desc_$check to parse the resource description and resource_control_$reserve to reserve the resource. J_O_U_R_N_A_L_I_Z_A_T_I_O_N__ 1) Written 11/78 by R.J.C. Kissel. */ /* Local variables */ dcl nargs fixed bin; dcl arg_ptr ptr; dcl arg_len fixed bin; dcl arg char (arg_len) based (arg_ptr); dcl code fixed bin (35); dcl info_area ptr; dcl err_msg char (256) varying; /* Include Files */ %include resource_control_desc; /* External Entries */ dcl cu_$arg_count entry (fixed bin); dcl get_system_free_area_ entry () returns (ptr); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl parse_resource_desc_$check entry (char (*), ptr, ptr, ptr, char (*) varying, fixed bin (35)); dcl com_err_ entry options (variable); dcl resource_control_$reserve entry (ptr, ptr, bit (72) aligned, bit (1) aligned, fixed bin (35)); /* External Constants */ dcl error_table_$badopt fixed bin (35) external; /* Builtin Functions and Conditions */ dcl (null) builtin; dcl (cleanup) condition; resource_desc_ptr = null (); resource_res_ptr = null (); info_area = get_system_free_area_ (); on cleanup call Cleanup_Handler; call cu_$arg_count (nargs); if nargs ^= 2 then goto ERROR_usage; call cu_$arg_ptr (1, arg_ptr, arg_len, code); if code ^= 0 then goto ERROR_arg; if arg ^= "-resource" & arg ^= "-rsc" then goto ERROR_carg; call cu_$arg_ptr (2, arg_ptr, arg_len, code); if code ^= 0 then goto ERROR_arg; call parse_resource_desc_$check (arg, info_area, resource_desc_ptr, resource_res_ptr, err_msg, code); if code ^= 0 then goto ERROR_parse; call resource_control_$reserve (resource_desc_ptr, resource_res_ptr, "0"b, "0"b, code); if code ^= 0 then goto ERROR_res; return; /* All error handling code goes here. */ ERROR_arg: call Cleanup_Handler (); call com_err_ (code, "reserve_resource"); return; ERROR_carg: call Cleanup_Handler (); call com_err_ (error_table_$badopt, "reserve_resource", "^a", arg); return; ERROR_parse: call Cleanup_Handler (); call com_err_ (code, "reserve_resource", "^a", err_msg); return; ERROR_res: call Cleanup_Handler (); call com_err_ (code, "reserve_resource", "No reservations made."); return; ERROR_usage: call Cleanup_Handler (); call com_err_ (0b, "reserve_resource", "Usage: rsr -rsc resource_desc"); return; Cleanup_Handler: proc (); if resource_desc_ptr ^= null () then free resource_descriptions; if resource_res_ptr ^= null () then free reservation_description; end Cleanup_Handler; end reserve_resource;  resource_control_.pl1 11/04/82 1936.3rew 11/04/82 1618.9 26991 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ resource_control_: proc; /* This subroutine implements the user ring interface to the resource control package. All the work is done by the various entry points and this main procedure should never be called. */ /* Written by R.J.C. Kissel 5/78. Modified by R.J.C. Kissel 1/79 to call rcp_ gate and to add cancellation entry. */ return; /* To make this call a nop. */ reserve: entry (resource_desc_ptr, resource_res_ptr, authorization, system, code); /* This entry point implements the reservation function. It takes a description of the resources to be reserved, (a rservation group) and makes the reservation as an indivisible operation. The code returned indicates success or failure and the code returned with each resource indicates more specifically where a failure occured. */ /* Arguments */ /* See the resource_control_desc include file for pointer declarations. */ dcl authorization bit (72) aligned; /* Only used if system = "1"b. */ dcl system bit (1) aligned; /* This call wishes to do a privileged reservation. */ dcl code fixed bin (35); /* A standard system status code. */ /* Local Variables */ /* Local Constants */ /* Local Overlays */ /* Include Files */ %include resource_control_desc; /* External Entries */ dcl rcp_sys_$reserve entry (ptr, ptr, bit (72) aligned, fixed bin (35)); dcl rcp_$reserve entry (ptr, ptr, fixed bin (35)); dcl rcp_sys_$cancel_id_string entry (char (*), char (*), fixed bin (35)); dcl rcp_$cancel_id_string entry (char (*), fixed bin (35)); /* External Constants */ dcl error_table_$mdc_no_access fixed bin (35) external; /* Builtin Functions and Conditions */ dcl (linkage_error) condition; if system then do; /* Check access to rcp_sys_ gate. */ on linkage_error goto BAD_ACCESS; call rcp_sys_$reserve (resource_desc_ptr, resource_res_ptr, authorization, code); revert linkage_error; end; else call rcp_$reserve (resource_desc_ptr, resource_res_ptr, code); return; cancel_id_string: entry (P_res_id, P_grp_id, system, code); dcl P_res_id char (*) parameter; dcl P_grp_id char (*) parameter; if system then do; on linkage_error goto BAD_ACCESS; call rcp_sys_$cancel_id_string (P_res_id, P_grp_id, code); revert linkage_error; end; else call rcp_$cancel_id_string (P_res_id, code); return; BAD_ACCESS: code = error_table_$mdc_no_access; return; end resource_control_;  resource_status.pl1 08/06/87 1422.1rew 08/06/87 1304.7 106767 /****^ *********************************************************** * * * 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. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(87-06-19,Rauschelbach), approve(87-06-29,MCR7736), audit(87-07-21,Farley), install(87-08-06,MR12.1-1064): Error message duplication was removed, and a call to com_err_ with a more standard version. END HISTORY COMMENTS */ resource_status: rst: proc; /* This command prints information about selected RCP resources. Written in 1979 by C. D. Tavares. Last modified 11/19/80 by CDT to change -usage_lock to -lock and to make sure it always calls the system error routine appropriate to its calling mode (command or AF). Modified 7/82 BIM to get the arg list ptr before looking at the arg list. */ /* automatic */ dcl al fixed bin, alp pointer, ap pointer, arg_ptr entry (fixed bin, pointer, fixed bin, fixed bin (35)) variable, arg_ptr_rel entry (fixed bin, pointer, fixed bin, fixed bin (35), pointer) variable, called_as_af bit (1) aligned, code fixed bin (35), resource_type char (32), (i, j, control_arg_type) fixed bin, nargs fixed bin, priv_sw bit (1) aligned, return_ptr pointer, return_len fixed bin (24); /* static */ dcl registry_dir char (168) static initial (">system_control_1>rcp"); /* constants */ dcl Name fixed bin initial (0) static options (constant); dcl legal_control_args (44) char (24) static options (constant) initial ("-priv", "FUTURE_EXP", /* 1, 2 */ "-unique_id", "-uid", /* 3, 4 */ "-potential_attributes", "-pattr", /* 5, 6 */ "-attributes", "-attr", /* 7, 8 */ "-potential_access_class", "-pacc", /* 9, 10 */ "-access_class", "-acc", /* 11, 12 */ "-owner", "-ow", /* 13, 14 */ "-acs_path", "FUTURE_EXP", /* 15, 16 */ "-location", "-loc", /* 17, 18 */ "-comment", "-com", /* 19, 20 */ "-charge_type", "-crgtp", /* 21, 22 */ "-mode", "-md", /* 23, 24 */ "-lock", "FUTURE_EXP", /* 25, 26 */ "-release_lock", "-rll", /* 27, 28 */ "-awaiting_clear", "FUTURE_EXP", /* 29, 30 */ "-alloc", "FUTURE_EXP", /* 31, 32 */ (10) (1) "FUTURE_EXP", /* 33 thru 42 */ "-all", "-a"); /* 43, 44 */ dcl explanation char (168) static options (constant) initial ("^/^5xUsage: resource_status resource_type resource_names {control_args}"); /* external static */ dcl (error_table_$badopt, error_table_$badcall, error_table_$noarg, error_table_$not_act_fnc, error_table_$too_many_args) fixed bin (35) external static; /* based */ dcl arg char (al) based (ap), return_string char (return_len) varying based (return_ptr); %include rst_control; /* entries */ dcl (com_err_, active_fnc_err_) ext entry options (variable), cu_$af_return_arg ext entry (fixed bin, pointer, fixed bin (24), fixed bin (35)), cu_$arg_list_ptr ext entry (pointer), (cu_$arg_ptr, cu_$af_arg_ptr) ext entry (fixed bin, pointer, fixed bin, fixed bin (35)), (cu_$arg_ptr_rel, cu_$af_arg_ptr_rel) ext entry (fixed bin, pointer, fixed bin, fixed bin (35), pointer), interpret_resource_desc_ ext entry (pointer, fixed bin, char (*), bit (*) aligned, bit (1) aligned, char (*) varying, fixed bin (35)), resource_info_$get_primary_type entry (char (*), char (*), fixed bin (35)); dcl (rcp_$get_status, rcp_admin_$get_status) ext entry (pointer, char (*), fixed bin (35)); /* builtins */ dcl (empty, hbound, index, length, null, size, string, substr, unspec) builtin; %include resource_control_desc; called_as_af = ""b; unspec (rst_control) = ""b; priv_sw = ""b; call cu_$af_return_arg (nargs, return_ptr, return_len, code); if code = 0 then called_as_af = "1"b; else if code = error_table_$not_act_fnc then code = 0; if code ^= 0 then call crump (code, "Getting argument count."); if nargs < 2 then call crump (error_table_$noarg, explanation); if called_as_af then do; arg_ptr = cu_$af_arg_ptr; arg_ptr_rel = cu_$af_arg_ptr_rel; end; else do; arg_ptr = cu_$arg_ptr; arg_ptr_rel = cu_$arg_ptr_rel; return_ptr = null; return_len = 0; end; /* First get the primary resoure type. */ call cu_$arg_list_ptr (alp); call arg_ptr_rel (1, ap, al, code, alp); if code ^= 0 then call crump (code, "Getting argument."); call resource_info_$get_primary_type (arg, resource_type, code); if code ^= 0 then call crump (code, arg); /* Next loop through the arguments and decide how many resources the caller wants information about. */ Resource_count = 0; do i = 2 to nargs; call arg_ptr (i, ap, al, code); if arg = "-name" | arg = "-nm" then do; i = i + 1; Resource_count = Resource_count + 1; end; else if substr (arg, 1, 1) ^= "-" then Resource_count = Resource_count + 1; end; if Resource_count <= 0 then call crump (error_table_$noarg, explanation); begin; dcl stackarea area (size (null -> resource_descriptions) + 100) automatic; stackarea = empty (); allocate resource_descriptions in (stackarea); resource_descriptions.version_no = resource_desc_version_1; unspec (resource_descriptions.item (*)) = ""b; resource_descriptions.item (*).type = resource_type; Resource_count = 0; do i = 2 to nargs; call arg_ptr_rel (i, ap, al, code, alp); if code ^= 0 then call crump (code, "Getting argument."); control_arg_type = Name; if arg = "-name" | arg = "-nm" then do; i = i + 1; call arg_ptr_rel (i, ap, al, code, alp); if code ^= 0 then call crump (code, "After -name."); end; else if substr (arg, 1, 1) = "-" then do; do control_arg_type = 1 to hbound (legal_control_args, 1) while (legal_control_args (control_arg_type) ^= arg); end; if control_arg_type > hbound (legal_control_args, 1) then call crump (error_table_$badopt, arg); end; goto process_control_arg (control_arg_type); process_control_arg (1): process_control_arg (2): /* -priv */ priv_sw = "1"b; goto end_process_control_arg; process_control_arg (3): process_control_arg (4): /* -unique_id, -uid */ rst_control.uid = "1"b; goto end_process_control_arg; process_control_arg (5): process_control_arg (6): /* -potential_attributes, -pattr */ rst_control.potential_attributes = "1"b; goto end_process_control_arg; process_control_arg (7): process_control_arg (8): /* -attributes, -attr */ rst_control.attributes = "1"b; goto end_process_control_arg; process_control_arg (9): process_control_arg (10): /* -potential_access_class, -pacc */ rst_control.potential_aim_range = "1"b; goto end_process_control_arg; process_control_arg (11): process_control_arg (12): /* -access_class, -acc */ rst_control.aim_range = "1"b; goto end_process_control_arg; process_control_arg (13): process_control_arg (14): /* -owner, -ow */ rst_control.owner = "1"b; goto end_process_control_arg; process_control_arg (15): process_control_arg (16): /* -acs_path */ rst_control.acs_path = "1"b; goto end_process_control_arg; process_control_arg (17): process_control_arg (18): /* -location, -loc */ rst_control.location = "1"b; goto end_process_control_arg; process_control_arg (19): process_control_arg (20): /* -comment, -com */ rst_control.comment = "1"b; goto end_process_control_arg; process_control_arg (21): process_control_arg (22): /* -charge_type, -crgtp */ rst_control.charge_type = "1"b; goto end_process_control_arg; process_control_arg (23): process_control_arg (24): /* -mode */ rst_control.mode = "1"b; goto end_process_control_arg; process_control_arg (25): process_control_arg (26): /* -lock */ rst_control.usage_lock = "1"b; goto end_process_control_arg; process_control_arg (27): process_control_arg (28): /* -release_lock, -rll */ rst_control.release_lock = "1"b; goto end_process_control_arg; process_control_arg (29): process_control_arg (30): /* -awaiting_clear */ rst_control.awaiting_clear = "1"b; goto end_process_control_arg; process_control_arg (31): process_control_arg (32): /* -alloc */ rst_control.user_alloc = "1"b; goto end_process_control_arg; process_control_arg (43): process_control_arg (44): /* -all, -a */ rst_control = "1"b; rst_control.given_flags, rst_control.desired_attributes = ""b; /* this is mostly debugging garbage */ goto end_process_control_arg; process_control_arg (0): /* normal name */ Resource_count = Resource_count + 1; resource_descriptions.item (Resource_count).name = arg; resource_descriptions.given (Resource_count).name = "1"b; end_process_control_arg: end; resource_descriptions.n_items = Resource_count; if called_as_af then if resource_descriptions.n_items > 1 then call crump (error_table_$badcall, "Only one resource allowed in active function invocation."); if string (rst_control) = ""b then string (rst_control) = rst_control_defaults; /* default, name, attributes, mode, and user_free */ if called_as_af then do; j = index (string (rst_control), "1"b); if j = 0 then call crump (error_table_$noarg, "Desired return value not specified."); if j ^= length (string (rst_control)) then if substr (string (rst_control), j+1) ^= ""b then call crump (error_table_$too_many_args, "Cannot return more than one resource property in active function invocation."); end; Process (6): /* Status */ if priv_sw then call rcp_admin_$get_status (resource_desc_ptr, registry_dir, code); else call rcp_$get_status (resource_desc_ptr, registry_dir, code); if code ^= 0 then do; do i = 1 to resource_descriptions.n_items while (resource_descriptions.item (i).status_code = 0); end; if i > resource_descriptions.n_items then call crump (code, "Cannot obtain status from ring 1."); else do; if ^called_as_af then do; call com_err_ (resource_descriptions.item (i).status_code, "resource_status", "^a ^a", resource_descriptions.item (i).type, resource_descriptions.item (i).name); end; else do; call active_fnc_err_ (resource_descriptions.item (i).status_code, "resource_status", "^a ^a", resource_descriptions.item (i).type, resource_descriptions.item (i).name); return_string = ""; goto return_hard; end; end; end; else call interpret_resource_desc_ (resource_desc_ptr, 0, "resource_status", string (rst_control), called_as_af, return_string, code); /* ignore code, err msg has already been printed */ end; /* begin block */ return; crump: proc (code, message); dcl code fixed bin (35), message char (*); if called_as_af then do; call active_fnc_err_ (code, "resource_status", message, "resource_status"); return_string = ""; end; else call com_err_ (code, "resource_status", message, "resource_status"); goto return_hard; end crump; return_hard: return; test: entry (newdir); dcl newdir char (*) parameter; if newdir = "" then registry_dir = ">system_control_1>rcp"; else registry_dir = newdir; return; end resource_status;  unassign_resource.pl1 02/16/84 1523.3r 02/16/84 1522.4 94635 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ unassign_resource: ur: procedure; /* This program is a command that may be called to unassign a resource controled by RCP. * Created on 01/10/75 by Bill Silver. * Changed on 03/30/75 by Bill Silver to add "device" option. * Modified on 12/09/78 by Michael R. Jordan for version 3 list info. * Modified 2/80 by Michael R. Jordan to add -all * Modified 12/12/83 by Jim Lippard to remove "all". * * In the current implementation this command can unassign only devices. * Its calling sequence is: * * unassign_resource, ur [resource] [-control_args] * * resource Specifies the resource to be unassigned. * A user may unassign any device by specifying its name. * * The following optional control arguments are also supported: * * (-com | -comment) The value argument is a comment that will be displayed * to the operator when the device is unassigned. If more * than one term is required they should be in quotes. * (-am | -admin) Indicates that a force unassignment is to be done. * The user must have access to the gate rcp_sys_. * (-a | -all) Indicates that all resources are to be unassigned. */ /* AUTOMATIC DATA */ dcl pointers (1) ptr; /* Pointer array for temp segment manager. */ dcl admin_flag bit (1); /* ON => we must do a force unassignment. */ dcl all_sw bit (1); /* ON => unassign all resources */ dcl arg_len fixed bin; /* Length of an argument string. */ dcl arg_ptr ptr; /* Pointer to an argument string. */ dcl argx fixed bin; /* Number of the current argument. */ dcl comment char (64); /* Comments to and from operator. */ dcl device_name char (32); /* Name of device to be unassigned. */ dcl ecode fixed bin (35); /* error_table_ code. */ dcl i fixed bin; dcl num_args fixed bin; /* Number of command arguments. */ dcl num_unassigned fixed bin; /* Number of devices unassigned. */ dcl option char (12); /* Command option string. */ dcl seg_size fixed bin (19); /* Max size of temp segment. */ /* BASED DATA */ dcl argument char (arg_len) based (arg_ptr); /* Used to reference argument string. */ /* INTERNAL STATIC DATA */ dcl brief_options (3) char (4) /* Brief form of command options. */ internal static init ("-com", "-am", "-a"); dcl long_options (3) char (8) /* Long form of command options. */ internal static init ("-comment", "-admin", "-all"); dcl HAS_VALUE (3) bit (1) unal internal static options (constant) init ("1"b, "0"b, "0"b); /* EXTERNAL ENTRIES CALLED */ dcl cleanup condition; dcl (addr, hbound, null, substr) builtin; dcl (error_table_$badopt, error_table_$inconsistent, error_table_$noarg, error_table_$resource_unassigned) fixed bin (35) external; 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 get_temp_segments_ entry (char (*), (1) ptr, fixed bin (35)); dcl hcs_$get_max_length_seg entry (ptr, fixed bin (19), fixed bin (35)); dcl rcp_$copy_list entry (ptr, fixed bin (19), fixed bin (35)); dcl rcp_$unassign entry (bit (36) aligned, bit (*), char (*), fixed bin (35)); dcl rcp_sys_$unassign_device entry (char (*), fixed bin (35)); dcl release_temp_segments_ entry (char (*), (1) ptr, fixed bin (35)); %include rcp_list_info; /* Begin command: unassign_resource */ ecode, /* Initialize. */ num_unassigned = 0; comment, device_name = " "; admin_flag = "0"b; /* Assume no admin unassignment. */ all_sw = "0"b; /* not -all */ call cu_$arg_count (num_args); /* Total number of command arguments. */ if num_args < 1 /* Was any device specified? */ then do; /* No, no argument. */ NO_RESOURCE: call com_err_ (error_table_$noarg, "unassign_resource", "No resource specified."); return; end; call cu_$arg_ptr (1, arg_ptr, arg_len, ecode); /* Get resource name. */ if ecode ^= 0 then do; call com_err_ (ecode, "unassign_resource", "Error getting resource name argument."); return; end; if substr (argument, 1, 1) ^= "-" /* Make sure that it is not a control argument. */ then do; argx = 2; device_name = argument; end; else argx = 1; do argx = argx to num_args; /* Process any optional control arguments. */ call PROCESS_ARG; /* Most will be processed in pairs. */ if ecode ^= 0 /* Was there an error? */ then return; /* Yes, abort. */ end; if device_name ^= "" & all_sw then do; call com_err_ (error_table_$inconsistent, "unassign_resource", "Cannot specify resource name and -all."); return; end; if device_name = "" & ^all_sw then goto NO_RESOURCE; if admin_flag /* Does user want to force the unassignment? */ then do; /* Yes. */ if all_sw then do; call com_err_ (error_table_$inconsistent, "unassign_resource", "Cannot specify -admin and -all together."); return; end; call rcp_sys_$unassign_device (device_name, ecode); if ecode ^= 0 then call com_err_ (ecode, "unassign_resource", "Error force unassigning ^a.", device_name); return; end; /* User wants to unassign one or more devices from her/his process. * Get temporary segment for RCP list info structure. * Set up cleanup handler to release temp segment. */ pointers (1) = null (); on cleanup begin; if pointers (1) ^= null () then call release_temp_segments_ ("unassign_resource", pointers, ecode); end; call get_temp_segments_ ("unassign_resource", pointers, ecode); if ecode ^= 0 /* Unable to get temporary working segment? */ then do; /* Yes. */ call com_err_ (ecode, "unassign_resource", "Error getting temporary segment."); return; end; call hcs_$get_max_length_seg (pointers (1), seg_size, ecode); if ecode ^= 0 /* We need max size of temp segment. */ then do; call com_err_ (ecode, "unassign_resource", "Error getting maximum length of temporary segment."); goto RETURN; end; rli_ptr = pointers (1); /* Temp segment used to RCP info. */ rli.version_num = rli_version_4; call rcp_$copy_list (rli_ptr, seg_size, ecode); if ecode ^= 0 /* Error copying process's RCP info? */ then do; /* Yes. */ call com_err_ (ecode, "unassign_resource", "Error copying RCP info from lower ring."); goto RETURN; end; do i = 1 to rli.head.num_dassign; /* Look at each assigned device. */ dassign_ptr = addr (rli.dassigns (i)); /* Get pointer to assignment entry. */ if all_sw | /* Unassigning all devices? */ (device_name = dassign.device_name) /* Or this device? */ then do; /* Yes, unassign this device. */ num_unassigned = num_unassigned + 1; call rcp_$unassign (dassign.rcp_id, "0"b, comment, ecode); if ecode ^= 0 then call com_err_ (ecode, "unassign_resource", "Error unassigning ^a.", dassign.device_name); comment = " "; /* Issue comment only once. */ end; end; if num_unassigned = 0 /* Did we unassign any devices? */ then if all_sw /* No. */ then call com_err_ (error_table_$resource_unassigned, "unassign_resource", "No resources assigned."); else call com_err_ (error_table_$resource_unassigned, "unassign_resource", "^a", device_name); RETURN: /* Come here to release temp segment. */ call release_temp_segments_ ("unassign_resource", pointers, ecode); if ecode ^= 0 then call com_err_ (ecode, "unassign_resource", "Error releasing temporary segment."); return; /* */ PROCESS_ARG: procedure; /* This procedure is called to process one option argument. * All of the option arguments except "-admin" have a value argument. * This value must be the next argument. In this case we will process * the value argument too. */ call cu_$arg_ptr (argx, arg_ptr, arg_len, ecode); if ecode ^= 0 then do; call com_err_ (ecode, "unassign_resource", "Error getting argument ^d.", argx); return; end; option = argument; /* Save option argument. */ do i = 1 to hbound (brief_options, 1); /* Look for valid option name. */ if (option = brief_options (i)) | /* Is it this brief name? */ (option = long_options (i)) /* Or this long name. */ then do; /* Yes, one of them. */ if HAS_VALUE (i) then do; call GET_VALUE; /* Get accompanying value argument. */ if ecode ^= 0 /* Check for errors. */ then return; end; goto OPTION (i); /* Go process this option. */ end; end; ecode = error_table_$badopt; /* Option not found. */ call com_err_ (ecode, "uasssign_resource", "^a", option); return; OPTION (1): /* "-com" or "-comment" */ comment = argument; /* Save user's comment to operator. */ return; OPTION (2): /* "-am" or "-admin" */ admin_flag = "1"b; /* We want to unassign through privileged gate. */ return; OPTION (3): /* "-a" or "-all" */ all_sw = "1"b; return; end PROCESS_ARG; /* */ GET_VALUE: procedure; /* This procedure is called to get the value argument that is associated * with the current option argument. */ if argx = num_args /* Is this the last argument? */ then do; /* Yes, value argument missing. */ ecode = error_table_$noarg; call com_err_ (ecode, "unassign_resource", "No value argument for ^a.", option); return; end; argx = argx + 1; /* Move to the next argument. */ call cu_$arg_ptr (argx, arg_ptr, arg_len, ecode); if ecode ^= 0 then do; call com_err_ (ecode, "unassign_resource", "Error getting argument ^d.", argx); return; end; if substr (argument, 1, 1) = "-" /* Is next argument a control option? */ then do; /* Yes, value argument is missing. */ ecode = error_table_$noarg; call com_err_ (ecode, "unassign_resource", "No value argument for ^a.", option); return; end; end GET_VALUE; end unassign_resource; 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