bft.pl1 02/24/88 0851.3rew 02/24/88 0843.5 228429 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1987 * * * *********************************************************** */ /* format: style4,indattr,ifthen,^indcomtxt,thendo,^indproc,^indblkcom,^indprocbody,initcol1,declareind8,dclind4,struclvlind3,comcol55 */ bft: background_file_transfer: proc options (main); /* PROGRAM FUNCTION This is the routine that accepts command line arguments and then calls the appropriate entrypoint in bft_. This procedure checks the number of arguments to the command and then if that is satisfactory then calls the appropriate subroutine to check the arguments themselves. This is done by checking the first argument. If it is valid, then a subroutine to handle that particular command is called. */ /* NOTES */ /****^ HISTORY COMMENTS: 1) change(86-06-06,Eichele), approve(87-07-15,MCR7580), audit(87-07-30,RBarstad), install(87-08-07,MR12.1-1075): Created. 2) change(87-10-23,Flegel), approve(87-10-23,MCR7787), audit(88-01-27,RWaters), install(88-02-24,MR12.2-1028): Added multiple entry queues, control args, and queue display. 3) change(87-12-12,Flegel), approve(87-12-12,MCR7819), audit(88-01-27,RWaters), install(88-02-24,MR12.2-1028): Added control arguments for a wider scope of request capabilities. END HISTORY COMMENTS */ /* PARAMETERS */ /* MISC VARIABLES */ dcl key_procedure entry variable; /* Actual request handler */ dcl reason char (256) var; /* Error reason */ dcl code fixed bin (35); /* GLOBAL */ dcl display_sw bit (1); /* List request */ dcl unload_sw bit (1); /* unload request */ dcl store_sw bit (1); /* store request */ dcl recover_sw bit (1); /* recover request */ dcl load_sw bit (1); /* load request */ dcl fetch_sw bit (1); /* fetch request */ dcl cancel_sw bit (1); /* cancel request */ dcl priority fixed bin; /* Queue number */ dcl long_sw bit (1); /* If queue display is long */ dcl main_arg_ptr ptr; /* Command arguments */ dcl arg_pos fixed bin; /* Argument being looked at */ dcl arg_count fixed bin; /* Number of arguments */ dcl arg_len fixed bin (21); /* Argument length */ dcl arg_ptr ptr; /* Argument */ dcl arg char (arg_len) based (arg_ptr); dcl 01 modes like bft_queue_flags auto aligned; /* Transfer modes */ /* STRUCTURES */ /* SYSTEM CALLS */ dcl cu_$arg_list_ptr entry (ptr); dcl ioa_ entry () options (variable); dcl absolute_pathname_ entry (char (*), char (*), fixed bin (35)); dcl cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr); dcl cu_$arg_count entry (fixed bin, fixed bin (35)); dcl com_err_ entry () options (variable); /* SYSTEM CALL SUPPORT */ dcl error_table_$nodescr fixed bin(35) ext static; dcl error_table_$inconsistent fixed bin (35) ext static; dcl error_table_$noarg fixed bin (35) ext static; dcl error_table_$bad_arg fixed bin (35) ext static; dcl error_table_$wrong_no_of_args fixed bin (35) ext static; /* EXTERNAL CALLS */ dcl bft_$cancel entry (fixed bin, char (*), fixed bin (35)); dcl bft_queue_$display_element entry (ptr, bit (1), fixed bin, bit (1), bit (1)); dcl bft_queue_$initiate entry (ptr, fixed bin (35)); dcl bft_$fetch entry (char (*) var, char (*) var, bit (36) aligned, fixed bin, fixed bin (35)); dcl bft_$load entry (fixed bin (35)); dcl bft_$recover_fetch entry (fixed bin (35)); dcl bft_$recover_store entry (fixed bin (35)); dcl bft_$store entry (char (*) var, char (*) var, bit (36) aligned, fixed bin, fixed bin (35)); dcl bft_$unload entry (fixed bin (35)); /* EXTERNAL CALL SUPPORT */ dcl bft_error_table_$invalid_file_type fixed bin(35) ext static; dcl bft_error_table_$invalid_keyword fixed bin (35) ext static; dcl bft_error_table_$invalid_priority fixed bin (35) ext static; dcl bft_error_table_$bft_not_loaded fixed bin (35) ext static; dcl ws_error_$invalid_capability_name fixed bin (35) ext static; /* BUILTINS */ dcl null builtin; dcl unspec builtin; dcl substr builtin; dcl rank builtin; dcl addr builtin; dcl rtrim builtin; /* CONDITIONS */ /* CONSTANTS */ dcl NAME char (3) int static options (constant) init ("bft"); dcl USAGE_CANCEL char (128) var int static options (constant) init ("^3tUsage: bft cancel request_identifier {request_identifier ...}"); dcl USAGE_UNLOAD char (128) var int static options (constant) init ("^3tUsage: bft unload"); dcl USAGE_RECOVER char (128) var int static options (constant) init ("^3tUsage: bft recover"); dcl USAGE_LOAD char (128) var int static options (constant) init ("^3tUsage: bft load"); dcl USAGE_BFT char (128) var int static options (constant) init ("^3tUsage: bft KEY {name1 {name2...name1N name2N}} {-control_args}"); dcl USAGE_KEYS char (128) var int static options (constant) init ("^6t(s)tore, (f)etch, (c)ancel, (ls) list, (l)oad, (u)nload, (r)ecover"); /* */ /* INITIALIZATION */ /* Set default transfer modes */ priority = 3; /* Queue 3 */ unspec (modes) = ""b; /* "0" are default values */ long_sw = "0"b; /* Long queue display */ /* Set request type switches */ cancel_sw = "0"b; fetch_sw = "0"b; load_sw = "0"b; recover_sw = "0"b; store_sw = "0"b; unload_sw = "0"b; display_sw = "0"b; /* MAIN */ /* Get MAIN's arg_ptr */ call cu_$arg_list_ptr (main_arg_ptr); if main_arg_ptr = null then do; call com_err_ (error_table_$nodescr, NAME, "Getting argument pointer."); return; end; /* How many args are there ? */ call cu_$arg_count (arg_count, code); if code ^= 0 then do; call com_err_ (code, NAME, "Getting argument count."); return; end; /* None, then this is a request for usage */ if arg_count <= 0 then do; call com_err_ (error_table_$wrong_no_of_args, NAME); call ioa_ (USAGE_BFT); return; end; /* Extract the keyword */ arg_pos = 0; call get_arg ("0"b, code); if code ^= 0 then do; call com_err_ (code, NAME); call ioa_ (USAGE_BFT); return; end; /* This argument MUST be a keyword, otherwise - what are we to do? */ if (arg = "cancel" | arg = "c") then do; key_procedure = bft_cancel; cancel_sw = "1"b; end; else if (arg = "fetch" | arg = "f") then do; key_procedure = bft_fetch; fetch_sw = "1"b; end; else if (arg = "load" | arg = "l" | arg = "ld") then do; key_procedure = bft_load; load_sw = "1"b; end; else if (arg = "list" | arg = "ls") then do; key_procedure = bft_display; display_sw = "1"b; end; else if (arg = "recover" | arg = "r") then do; key_procedure = bft_recover; recover_sw = "1"b; end; else if (arg = "store" | arg = "s") then do; key_procedure = bft_store; store_sw = "1"b; end; else if (arg = "unload" | arg = "u" | arg = "uld") then do; key_procedure = bft_unload; unload_sw = "1"b; end; else do; call com_err_ (bft_error_table_$invalid_keyword, NAME, arg); call ioa_ (USAGE_KEYS); return; end; /* Parse through control arguments */ call parse_control_args (code, reason); if code ^= 0 then do; call com_err_ (code, NAME, reason); return; end; /* We made it to here, so call the handler, skip the first "real" argument as it is the keyword */ arg_pos = 0; call get_arg ("0"b, (0)); call key_procedure (); return; /* */ /* INTERNAL ENTRIES */ /* */ /* INTERNAL PROCEDURES */ /* *** Procedure: cancel - Internal proc for bft *** */ bft_cancel: proc (); /* PROCEDURE FUNCTION Cancel an element from the queue, ONLY if it is not currenlty in transfer. */ /* NOTES */ /* PARAMETERS */ /* MISC VARIABLES */ dcl request_type char (32) var; /* Cancellation request type */ dcl code fixed bin (35); /* Error code */ dcl passed fixed bin; /* Number of requests cancelled */ /* STRUCTURES */ /* INITIALIZATION */ passed = 0; /* MAIN */ /* Parse through each arg in the command line */ do while (arg_pos < arg_count); call get_arg ("1"b, code); if code ^= 0 then do; if passed = 0 then call com_err_ (code, NAME, arg); else call com_err_ (code, NAME); goto CANCEL_RETURN; end; /* Determine which entry type we have, and cancel accordingly */ if substr (arg, 1, 1) ^= "-" then call bft_$cancel (BFT_PATH_ID, arg, code); else do; request_type = arg; call get_arg ("0"b, code); if code ^= 0 then do; call com_err_ (code, NAME); return; end; if request_type = "-id" then call bft_$cancel (BFT_TIME_ID, arg, code); else if request_type = "-entry" | request_type = "-et" then call bft_$cancel (BFT_ENTRY_ID, arg, code); end; /* Is there an error ? */ if code ^= 0 then do; call com_err_ (code, NAME, "Cancelling ^a.", arg); goto CANCEL_RETURN; end; /* Increment the cancellation count */ passed = passed + 1; end; CANCEL_RETURN: if passed > 0 then call ioa_ ("^a: ^d request^[s^] submitted for cancellation.", NAME, passed, (passed > 1)); end bft_cancel; /* */ /* *** Procedure: bft_display - Internal proc for bft *** */ bft_display: proc (); /* PROCEDURE FUNCTION Display the current entries in the queues. */ /* NOTES */ /* PARAMETERS */ /* MISC VARIABLES */ dcl running_count fixed bin; dcl code fixed bin (35); dcl running bit (1); /* Running element displayed */ dcl i fixed bin; dcl empty_sw bit (1); /* Queues are empty? */ dcl slot fixed bin (35); /* Queue traversal index */ dcl count fixed bin (21); /* Elements in queue */ /* STRUCTURES */ /* INITIALIZATION */ empty_sw = "1"b; /* MAIN */ call bft_queue_$initiate (queue_ptr, code); if code ^= 0 then do; call com_err_ (code, NAME, "Initiating queue."); return; end; /* Display the store queue */ running = "0"b; running_count = 1; do i = BFT_MIN_PRIORITY to BFT_MAX_PRIORITY; /* Count how many requests are pending */ count = 0; slot = queue.header.store_queue (i).first; do while (slot ^= 0); count = count + 1; slot = queue.array (slot).next; end; /* Tell user how many requests in store queue */ if count > 0 then do; empty_sw = "1"b; /* To tell display_element to print a header */ call ioa_ ("^/BFT Store Queue ^d:^20t^d request^[s^].^/", i, running_count + count, (running_count + count > 1)); running_count = 0; /* Display the running element */ if queue.header.storing.flags.initiated & ^running then do; call bft_queue_$display_element (addr (queue.header.storing), long_sw, BFT_MULTICS_to_PC, "1"b, "1"b); if long_sw then call ioa_ (); empty_sw = "0"b; running = "1"b; end; /* Display the remainder of the queue */ slot = queue.header.store_queue (i).first; do while (slot ^= 0); call bft_queue_$display_element (addr (queue.array (slot)), long_sw, BFT_MULTICS_to_PC, "0"b, empty_sw); empty_sw = "0"b; slot = queue.array (slot).next; if long_sw & slot ^= 0 then call ioa_ (); end; end; end; /* Display the running element if there are no pending elements */ if queue.header.storing.flags.initiated & ^running then do; call ioa_ ("^/BFT Store Queue:^/"); call bft_queue_$display_element (addr (queue.header.storing), long_sw, BFT_MULTICS_to_PC, "1"b, "1"b); empty_sw = "0"b; running = "1"b; end; /* Display the fetch queue */ running = "0"b; running_count = 1; do i = BFT_MIN_PRIORITY to BFT_MAX_PRIORITY; count = 0; slot = queue.header.fetch_queue (i).first; do while (slot ^= 0); count = count + 1; slot = queue.array (slot).next; end; if count > 0 then do; empty_sw = "1"b; /* To tell display_element to print a header */ call ioa_ ("^/BFT Fetch Queue ^d:^20t^d request^[s^].^/", i, running_count + count, (running_count + count > 1)); running_count = 0; if queue.header.fetching.flags.initiated & ^running then do; call bft_queue_$display_element (addr (queue.header.fetching), long_sw, BFT_PC_to_MULTICS, "1"b, "1"b); if long_sw then call ioa_ (); empty_sw = "0"b; running = "1"b; end; slot = queue.header.fetch_queue (i).first; do while (slot ^= 0); call bft_queue_$display_element (addr (queue.array (slot)), long_sw, BFT_PC_to_MULTICS, "0"b, empty_sw); empty_sw = "0"b; slot = queue.array (slot).next; if long_sw & slot ^= 0 then call ioa_ (); end; end; end; if queue.header.fetching.flags.initiated & ^running then do; call ioa_ ("^/BFT Fetch Queue:^/"); call bft_queue_$display_element (addr (queue.header.fetching), long_sw, BFT_PC_to_MULTICS, "1"b, "1"b); empty_sw = "0"b; running = "1"b; end; /* If there were no transfers, say so */ if empty_sw then call ioa_ ("There are no requests in any BFT queue."); else call ioa_ (); end bft_display; /* */ /* *** Procedure: bft_fetch - Internal proc for bft *** */ bft_fetch: proc (); /* PROCEDURE FUNCTION This routine is called if the first argument specified a fetch. If two filenames are given, both are accepted. If only one is given, then the destination will default to being the same as the supplied source name. */ /* NOTES */ /* PARAMETERS */ /* MISC VARIABLES */ dcl code fixed bin (35); /* Error code */ dcl passed fixed bin; /* Requests submitted */ dcl temp_file char (168); dcl mu_path char (168); dcl pc_path char (66); /* STRUCTURES */ /* INITIALIZATION */ passed = 0; /* MAIN */ /* Repeat until there are no more requests in the command line */ do while (arg_pos < arg_count); /* Get the pc_path */ call get_arg ("0"b, code); if code ^= 0 then do; if passed = 0 then call com_err_ (code, NAME, arg); goto FETCH_RETURN; end; pc_path = arg; mu_path = "==="; /* Look for the Multics path, if it is not specified, default to pc_path */ call get_arg ("0"b, code); if code ^= 0 & code ^= error_table_$noarg then do; call com_err_ (code, NAME, arg); goto FETCH_RETURN; end; else if code = 0 then mu_path = arg; /* Obtain the full pathname of the specified destination */ temp_file = mu_path; call absolute_pathname_ (temp_file, mu_path, code); if code ^= 0 then do; call com_err_ (code, NAME, "Expanding Multics pathname."); goto FETCH_RETURN; end; /* Call the bft_$fetch entrypoint with the valid parms */ call bft_$fetch (rtrim (pc_path), rtrim (mu_path), unspec (modes), priority, code); if code ^= 0 then do; if code = ws_error_$invalid_capability_name then code = bft_error_table_$bft_not_loaded; call com_err_ (code, NAME, "Issuing fetch request."); goto FETCH_RETURN; end; /* Increment the cancellation count */ passed = passed + 1; end; FETCH_RETURN: if passed > 0 then call ioa_ ("^a: ^d request^[s^] submitted for fetching.", NAME, passed, (passed > 1)); end bft_fetch; /* */ /* *** Procedure: bft_load - Internal proc for bft *** */ bft_load: proc (); /* PROCEDURE FUNCTION This calls the proper entrypoint to get BFT loaded into the CAT. No arguments are required. */ /* NOTES */ /* PARAMETERS */ /* MISC VARIABLES */ dcl code fixed bin (35); /* Error code */ /* STRUCTURES */ /* INITIALIZATION */ /* MAIN */ /* Print a usage message if there is an invalid number of args */ if arg_count ^= 1 then do; call com_err_ (error_table_$wrong_no_of_args, NAME); call ioa_ (USAGE_LOAD); return; end; /* Make call to proper entrypoint */ call bft_$load (code); if (code ^= 0) then do; if code = ws_error_$invalid_capability_name then code = bft_error_table_$bft_not_loaded; call com_err_ (code, NAME, "While attempting to load BFT."); return; end; end bft_load; /* */ /* *** Procedure: bft_recover - Internal proc for bft *** */ bft_recover: proc (); /* PROCEDURE FUNCTION This is the routine called if the argument was fetch_recover. The purpose of this routine is to transmit the portion of a file that was previously interrupted. */ /* NOTES */ /* PARAMETERS */ /* MISC VARIABLES */ dcl code fixed bin (35); /* Error code */ /* STRUCTURES */ /* INITIALIZATION */ /* MAIN */ /* Print a usage message if there is an invalid number of args */ if arg_count ^= 1 then do; call com_err_ (error_table_$wrong_no_of_args, NAME); call ioa_ (USAGE_RECOVER); return; end; /* Recover fetch operations */ call bft_$recover_fetch (code); if (code ^= 0) then do; if code = ws_error_$invalid_capability_name then code = bft_error_table_$bft_not_loaded; call com_err_ (code, NAME, "Attempting to recover fetch."); end; /* Recover store operations */ call bft_$recover_store (code); if (code ^= 0) then do; if code = ws_error_$invalid_capability_name then code = bft_error_table_$bft_not_loaded; call com_err_ (code, NAME, "Attempting to recover store."); end; end bft_recover; /* */ /* *** Procedure: bft_store - Internal proc for bft *** */ bft_store: proc (); /* PROCEDURE FUNCTION This routine is identical in function to the bft_fetch, except for the fact that it calls bft_$store. */ /* NOTES */ /* PARAMETERS */ /* MISC VARIABLES */ dcl code fixed bin (35); /* Error code */ dcl passed fixed bin; /* Previous request submitted */ dcl pc_path char (66); dcl mu_path char (168); /* STRUCTURES */ /* INITIALIZATION */ passed = 0; /* MAIN */ /* Repeat until there are no more requests in the command line */ do while (arg_pos < arg_count); /* Get the mu_path */ call get_arg ("0"b, code); if code ^= 0 then do; if passed = 0 then call com_err_ (code, NAME, arg); goto STORE_RETURN; end; mu_path = arg; pc_path = "==="; /* Look for the PC path, if not specified then assume mu_patjh */ call get_arg ("0"b, code); if code ^= 0 & code ^= error_table_$noarg then do; call com_err_ (code, NAME, arg); goto STORE_RETURN; end; else if code = 0 then pc_path = arg; /* Call the bft_$store entrypoint with the valid parms */ call bft_$store (rtrim (mu_path), rtrim (pc_path), unspec (modes), priority, code); if code ^= 0 then do; if code = ws_error_$invalid_capability_name then code = bft_error_table_$bft_not_loaded; call com_err_ (code, NAME, "Issuing store request."); goto STORE_RETURN; end; passed = passed + 1; end; STORE_RETURN: if passed > 0 then call ioa_ ("^a: ^d request^[s^] submitted for storing.", NAME, passed, (passed > 1)); end bft_store; /* */ /* *** Procedure: bft_unload - Internal proc for bft *** */ bft_unload: proc (); /* PROCEDURE FUNCTION If the first argument was unload then this is the routine that is called. This calls the necessary enttrypoint to have BFT deleted from the CAT. */ /* NOTES */ /* PARAMETERS */ /* MISC VARIABLES */ dcl code fixed bin (35); /* Error code */ /* STRUCTURES */ /* INITIALIZATION */ /* MAIN */ /* Print a usage message if there is an invalid number of args */ if arg_count ^= 1 then do; call com_err_ (error_table_$wrong_no_of_args, NAME); call ioa_ (USAGE_UNLOAD); return; end; /* Call the proper entrypoint with the valid parameters */ call bft_$unload (code); if (code ^= 0) then do; if code = ws_error_$invalid_capability_name then code = bft_error_table_$bft_not_loaded; call com_err_ (code, NAME, "While attempting to unload BFT."); return; end; end bft_unload; /* */ /* *** Procedure: get_arg - Internal proc for bft *** */ get_arg: proc (p_special, p_code); /* PROCEDURE FUNCTION Extract the next real argument from the argument list. If the p_special parameter is True, then accept the "-control_arg STR" as a "non-control" argument. */ /* NOTES */ /* PARAMETERS */ dcl p_special bit(1) parameter; /* Accept "-ca STR " */ dcl p_code fixed bin (35) parameter; /* Error code */ /* MISC VARIABLES */ /* STRUCTURES */ /* INITIALIZATION */ /* MAIN */ p_code = 0; /* Skip all control_args until a NON-control_arg is found */ do while ("1"b); arg_pos = arg_pos + 1; if arg_pos > arg_count then do; p_code = error_table_$noarg; return; end; call cu_$arg_ptr_rel (arg_pos, arg_ptr, arg_len, p_code, main_arg_ptr); if p_code ^= 0 then return; if substr (arg, 1, 1) = "-" then do; if arg = "-entry" | arg = "-et" /* These are special */ | arg = "-id" then do; if p_special then /* Caller wants this */ return; else /* Skip the param */ arg_pos = arg_pos + 1; end; else if arg = "-queue" | arg = "-q" /* Skip the param */ | arg = "-file_type" | arg = "-ft" then arg_pos = arg_pos + 1; else /* No params */ ; end; else return; end; end get_arg; /* */ /* *** Procedure: parse_control_args - Internal proc for bft *** */ parse_control_args: proc (p_code, p_reason); /* PROCEDURE FUNCTION Skip through the command line arguments and extract control arguments. Control arguments extracted are: -brief, -bf -notify, -nt -no_notify, -nnt -file_type TYPE, -ft TYPE -queue N, -q N Control arguments "skipped" (as they are really a "single" argument): -entry NAME, -et NAME -id ID */ /* NOTES */ /* PARAMETERS */ dcl p_reason char (*) var parameter; /* Error reason */ dcl p_code fixed bin (35) parameter; /* Error code */ /* MISC VARIABLES */ dcl temp_queue fixed bin; /* local queue value */ /* STRUCTURES */ /* INITIALIZATION */ p_code = 0; p_reason = ""; /* MAIN */ do arg_pos = 1 to arg_count; call cu_$arg_ptr_rel (arg_pos, arg_ptr, arg_len, p_code, main_arg_ptr); if p_code ^= 0 then return; if arg = "-file_type" | arg = "-ft" then do; if ^(store_sw | fetch_sw) then do; p_code = error_table_$inconsistent; return; end; arg_pos = arg_pos + 1; call cu_$arg_ptr_rel (arg_pos, arg_ptr, arg_len, p_code, main_arg_ptr); if p_code ^= 0 then return; if arg = "binary" then modes.binary_sw = "1"b; else if arg = "ascii" then modes.binary_sw = "0"b; else do; p_reason = arg; p_code = bft_error_table_$invalid_file_type; return; end; end; else if arg = "-long" | arg = "-lg" then do; if ^display_sw then do; p_code = error_table_$inconsistent; return; end; long_sw = "1"b; end; else if arg = "-brief" | arg = "-bf" then do; if ^display_sw then do; p_code = error_table_$inconsistent; return; end; long_sw = "0"b; end; else if arg = "-id" then do; if ^cancel_sw then do; p_code = error_table_$inconsistent; return; end; end; else if arg = "-entry" | arg = "-et" then do; if ^cancel_sw then do; p_code = error_table_$inconsistent; return; end; end; else if arg = "-notify" | arg = "-nt" then do; if ^(fetch_sw | store_sw) then do; p_code = error_table_$inconsistent; return; end; modes.notify_sw = "1"b; end; else if arg = "-no_notify" | arg = "-nnt" then do; if ^(fetch_sw | store_sw) then do; p_code = error_table_$inconsistent; return; end; modes.notify_sw = "0"b; end; else if arg = "-queue" | arg = "-q" then do; if ^(store_sw | fetch_sw) then do; p_code = error_table_$inconsistent; return; end; arg_pos = arg_pos + 1; call cu_$arg_ptr_rel (arg_pos, arg_ptr, arg_len, p_code, main_arg_ptr); if p_code ^= 0 then return; if arg_len ^= 1 then do; p_reason = arg; p_code = bft_error_table_$invalid_priority; return; end; temp_queue = rank (substr (arg, 1, 1)) - rank ("0"); if temp_queue < BFT_MIN_PRIORITY | temp_queue > BFT_MAX_PRIORITY then do; p_reason = arg; p_code = bft_error_table_$invalid_priority; return; end; priority = temp_queue; end; else if substr (arg, 1, 1) = "-" then do; p_code = error_table_$bad_arg; reason = arg; return; end; end; end parse_control_args; /* */ /* INCLUDE FILES */ %include bft_queue; %include bft_values; end bft;  bft_.pl1 02/24/88 0851.3rew 02/24/88 0843.5 115308 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1987 * * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * *********************************************************** */ bft_: proc (); /* format: style4,indattr,ifthen,^indcomtxt,thendo,^indproc,^indblkcom,^indprocbody,initcol1,declareind8,dclind4,struclvlind3,comcol55 */ /* PROGRAM FUNCTION This is the file that holds all of the Multics entrypoints. These entrypoints do nothing more than place the supplied arguments into a structure of the type defined in bft_values.incl.pl1. This is done so that only a pointer must be passed between the two programs (this one and the bft_main_.pl1 program, which holds all of the code for the minor capabilities). This will only work because these calls are guaranteed to be local (ie. on Multics). Once all of the necessary information is written into the structure, the pointer to the structure is converted to char and then passed to the minor capability as a character string, and it us decoded back to a pointer there. On return , each entrypoint reassigns the passed error code to its parameter error_code so the calling routine may use the information. */ /* NOTES */ /****^ HISTORY COMMENTS: 1) change(86-07-22,Eichele), approve(87-07-15,MCR7580), audit(87-07-30,RBarstad), install(87-08-07,MR12.1-1075): Created. 2) change(87-10-23,Flegel), approve(87-10-23,MCR7787), audit(88-01-27,RWaters), install(88-02-24,MR12.2-1028): Changed to work with multiple entries for queueing as well as adding a few new control arguments. END HISTORY COMMENTS */ /* PARAMETERS */ dcl p_id_sw fixed bin parameter; /* Request ID type */ dcl p_id char (*) parameter; /* Request ID */ dcl p_priority fixed bin parameter; /* Transfer priority */ dcl p_flags bit (36) aligned parameter; /* Transfer flags */ dcl p_arg_len fixed bin parameter; dcl p_arg_ptr ptr parameter; dcl p_data_block_ptr ptr parameter; dcl p_destination_filename char (*) var parameter; dcl p_major_sender fixed bin parameter; dcl p_mcb_ptr ptr parameter; dcl p_minor_cap_no fixed bin parameter; dcl p_source_filename char (*) var parameter; dcl p_code fixed bin (35) parameter; /* MISC VARIABLES */ dcl dir_name char (168); /* Pathname */ dcl message char (256); dcl bft_major fixed bin; dcl bft_mcb ptr; dcl bft_struct_ptr ptr; dcl code fixed bin (35); dcl command_id fixed bin; dcl major_num fixed bin; /* STRUCTURES */ dcl 01 bft_struct like bft_values_struct based (bft_struct_ptr); /* SYSTEM CALLS */ dcl absolute_pathname_ entry (char(*), char(*), fixed bin(35)); /* SYSTEM CALL SUPPORT */ /* EXTERNAL CALLS */ /* EXTERNAL CALL SUPPORT */ dcl bft_error_table_$invalid_request_type fixed bin(35) ext static; dcl bft_error_table_$unexpected_minor_capability fixed bin (35) ext static; /* BUILTINS */ dcl byte builtin; dcl null builtin; dcl addr builtin; dcl length builtin; dcl rtrim builtin; /* CONDITIONS */ dcl cleanup condition; /* CONSTANTS */ /* */ /* INITIALIZATION */ /* MAIN */ return; /* */ /* INTERNAL ENTRIES */ /* *** Entry: cancel - Internal entry for bft_ *** */ cancel: entry (p_id_sw, p_id, p_code); /* ENTRY FUNCTION Remove the specified request from the bft queues. */ /* NOTES */ p_code = 0; /* Fill out the message: ID_SW;ID; */ if p_id_sw = BFT_TIME_ID | p_id_sw = BFT_PATH_ID | p_id_sw = BFT_ENTRY_ID then message = byte (p_id_sw) || DELIM_CHAR; else do; p_code = bft_error_table_$invalid_request_type; return; end; if p_id_sw = BFT_PATH_ID then do; call absolute_pathname_ (p_id, dir_name, p_code); if p_code ^= 0 then return; message = rtrim (message) || rtrim (dir_name) || DELIM_CHAR; end; else message = rtrim (message) || rtrim (p_id) || DELIM_CHAR; /* Execute bft_minor_$add_to_fetch_queue */ bft_major = 0; call ws_$find_capability_number ("bft_main_", LOCAL_SYSTEM, bft_major, p_code); if p_code ^= 0 then return; call ws_$create_instance ("bft_", "process_event", BFT_INBUFFER_SIZE, BFT_OUTBUFFER_SIZE, null, bft_mcb, p_code); if p_code ^= 0 then return; call ws_$execute_capability (bft_major, bft_minor_$cancel_request, addr (message), length (rtrim (message)), bft_mcb, p_code); call ws_$destroy_instance (bft_mcb, (0)); return; /* */ /* *** Entry: process_event - Internal entry fo bft_ *** */ process_event: entry (p_minor_cap_no, p_major_sender, p_arg_ptr, p_arg_len, p_mcb_ptr, p_data_block_ptr); /* ENTRY FUNCTION This is the point where MOWSE will begin necessary execution. There are no minor capabilities defined other than those required by MOWSE. */ /* NOTES */ bft_mcb = p_mcb_ptr; if (p_minor_cap_no > MAXIMUM_SYSTEM_MINOR) | (p_minor_cap_no < MINIMUM_SYSTEM_MINOR) then do; code = bft_error_table_$unexpected_minor_capability; return; end; if p_minor_cap_no ^= EXECUTE_COMMAND_REPLY then call minor_error (p_minor_cap_no); major_num = 0; code = 0; call ws_$find_capability_number ("bft_main_", LOCAL_SYSTEM, major_num, code); if code ^= 0 then call ws_$put_background_message (bft_mcb, 0, "bft_ ", "Error in loading BFT."); code = 0; call ws_$destroy_instance (bft_mcb, code); if code ^= 0 then do; call ws_$put_background_message (bft_mcb, 0, "bft_ ", "BFT_ failed to properly destroy itself."); return; end; return; /* */ /* *** Entry: fetch - Internal entry for bft_ *** */ fetch: entry (p_source_filename, p_destination_filename, p_flags, p_priority, p_code); /* ENTRY FUNCTION This entrypoint assembles the arguments and makes the proper call to bft_minor_$add_to_fetch_queue. */ /* NOTES */ call add_to_queue (p_destination_filename, p_source_filename, p_flags, p_priority, bft_minor_$add_to_fetch_queue, p_code); return; /* */ /* *** Entry: load - Internal entry for bft_ *** */ load: entry (p_code); /* ENTRY FUNCTION This entrypoint assembles the arguments and makes the proper call to bft_minor_ (main entrypoint). */ /* NOTES */ /* Allocate a structure where the arguments will be placed */ on cleanup call clean_up (); call ws_$create_instance ("bft_", "process_event", BFT_INBUFFER_SIZE, BFT_OUTBUFFER_SIZE, null, bft_mcb, p_code); if p_code ^= 0 then return; call ws_$execute_command ("bft_main_", LOCAL_SYSTEM, command_id, bft_mcb, p_code); call ws_$destroy_instance (bft_mcb, (0)); return; /* */ /* *** Entry: recover_fetch - Internal entry for bft_ *** */ recover_fetch: entry (p_code); /* ENTRY FUNCTION This entrypoint assembles the arguments and makes the proper call to bft_minor_$recover_fetch */ /* NOTES */ /* Locate the bft_main_ capability */ bft_major = 0; call ws_$find_capability_number ("bft_main_", LOCAL_SYSTEM, bft_major, p_code); if p_code ^= 0 then return; /* Execute bft_minor_$recover_fetch */ call ws_$create_instance ("bft_", "process_event", BFT_INBUFFER_SIZE, BFT_OUTBUFFER_SIZE, null, bft_mcb, p_code); if p_code ^= 0 then return; call ws_$execute_capability (bft_major, bft_minor_$recover_fetch, null, (0), bft_mcb, p_code); call ws_$destroy_instance (bft_mcb, (0)); return; /* */ /* *** Entry: recover_store - Internal entry for bft_ *** */ recover_store: entry (p_code); /* ENTRY FUNCTION This entrypoint assembles the arguments and makes the proper call to bft_minor_$recover_store. */ /* NOTES */ /* Find the bft_main_ capability */ major_num = 0; call ws_$find_capability_number ("bft_main_", LOCAL_SYSTEM, major_num, p_code); if p_code ^= 0 then return; /* Execute bft_minor_$recover_store */ call ws_$create_instance ("bft_", "process_event", BFT_INBUFFER_SIZE, BFT_OUTBUFFER_SIZE, null, bft_mcb, p_code); if p_code ^= 0 then return; call ws_$execute_capability (major_num, bft_minor_$recover_store, null, (0), bft_mcb, p_code); call ws_$destroy_instance (bft_mcb, (0)); return; /* */ /* *** Entry: store - Internal entry for bft_ *** */ store: entry (p_source_filename, p_destination_filename, p_flags, p_priority, p_code); /* ENTRY FUNCTION This entrypoint assembles the arguments and makes the proper call to bft_minor_$add_to_store_queue. */ /* NOTES */ call add_to_queue (p_source_filename, p_destination_filename, p_flags, p_priority, bft_minor_$add_to_store_queue, p_code); return; /* */ /* *** Entry: unload - Internal entry for bft_ *** */ unload: entry (p_code); /* ENTRY FUNCTION This entrypoint assembles the arguments and makes the proper call to TERMINATE_APPLICATION. */ /* NOTES */ /* Allocate the structure where the arguments will be placed */ call ws_$create_instance ("bft_", "process_event", BFT_INBUFFER_SIZE, BFT_OUTBUFFER_SIZE, null, bft_mcb, p_code); if p_code ^= 0 then return; major_num = 0; call ws_$find_capability_number ("bft_main_", LOCAL_SYSTEM, major_num, p_code); if p_code ^= 0 then return; bft_major = major_num; call ws_$execute_capability (bft_major, bft_minor_$bft_shut_down, null, 0, bft_mcb, p_code); call ws_$destroy_instance (bft_mcb, (0)); return; /* */ /* INTERNAL PROCEDURES */ /* *** Procedure: add_to_queue - Internal proc for bft_ *** */ add_to_queue: proc (p_multics_path, p_pc_path, p_flags, p_priority, p_minor, p_code); /* PROCEDURE FUNCTION This procedure assembles the arguments for adding an element to either the store or fetch queue. */ /* NOTES */ /* PARAMETERS */ dcl p_priority fixed bin parameter; /* Transfer priority */ dcl p_flags bit (36) aligned parameter; /* Transfer modes */ dcl p_minor fixed bin parameter; /* Store or Fetch */ dcl p_pc_path char (*) var parameter; dcl p_multics_path char (*) var parameter; dcl p_code fixed bin (35) parameter; /* Error code */ /* MISC VARIABLES */ dcl flags_over char (4) aligned based (addr (p_flags)); /* Character overlay of flags */ dcl mcb_ptr ptr; /* MOWSE control block */ dcl major_num fixed bin; /* Capability number */ dcl message char (256); /* Message to be sent */ /* STRUCTURES */ /* INITIALIZATION */ /* MAIN */ p_code = 0; /* Fill out the message: MULTICS_SOURCE;PC_SOURCE;FLAGS;PRIORITY; */ message = rtrim (p_multics_path) || DELIM_CHAR; message = rtrim (message) || p_pc_path || DELIM_CHAR; message = rtrim (message) || flags_over || DELIM_CHAR; message = rtrim (message) || byte (p_priority); major_num = 0; call ws_$find_capability_number ("bft_main_", LOCAL_SYSTEM, major_num, p_code); if p_code ^= 0 then return; /* Execute bft_minor_$add_to_fetch_queue */ call ws_$create_instance ("bft_", "process_event", BFT_INBUFFER_SIZE, BFT_OUTBUFFER_SIZE, null, mcb_ptr, p_code); if p_code ^= 0 then return; call ws_$execute_capability (major_num, p_minor, addr (message), length (rtrim (message)), mcb_ptr, p_code); call ws_$destroy_instance (mcb_ptr, (0)); end add_to_queue; /* */ /* *** Procedure: minor_error - Internal proc for bft_ *** */ minor_error: proc (p_minor_number); /* PROCEDURE FUNCTION This is called when one of the predefined minor capabilities is called that is not expected. */ /* NOTES */ /* PARAMETERS */ dcl p_minor_number fixed bin parameter; /* MISC VARIABLES */ /* STRUCTURES */ /* INITIALIZATION */ /* MAIN */ call ws_$put_background_message (bft_mcb, 0, "BFT_ ", "Unexpected minor capability has been called."); end minor_error; /* */ /* *** Procedure: clean_up - Internal proc for bft_ *** */ clean_up: proc (); /* PROCEDURE FUNCTION This cleanup handler frees up the space allocated in the system_free_area. */ /* NOTES */ /* PARAMETERS */ /* MISC VARIABLES */ /* STRUCTURES */ /* INITIALIZATION */ /* MAIN */ if bft_struct_ptr ^= null then do; free bft_struct_ptr -> bft_struct; bft_struct_ptr = null; end; end clean_up; /* */ /* INCLUDE FILES */ %include bft; %include bft_values; %include mowse_lib_dcls; %include mowse; end bft_;  bft_error_table_.alm 02/24/88 0851.3rew 02/24/88 0846.4 18450 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1987 * " * * " * Copyright, (C) Honeywell Bull Inc., 1987 * " * * " *********************************************************** " HISTORY COMMENTS: " 1) change(87-07-15,Flegel), approve(87-07-15,MCR7580), " audit(87-07-30,RBarstad), install(87-08-07,MR12.1-1075): " Created. " 2) change(87-10-06,Flegel), approve(87-10-23,MCR7787), " audit(88-01-27,RWaters), install(88-02-24,MR12.2-1028): " Added codes: no_queue, invalid_priority, invalid_queue, " invalid_file_type, invalid_keyword. " Deleted codes: LS_set, LF_set, RS_set, RF_set, store_queue_full, " status_discrepancy. " END HISTORY COMMENTS include et_macros et bft_error_table_ ec bft_not_loaded,bftnotld, (The major capablility BFT has not been loaded.) ec fetch_in_progress,fetchprg, (Fetch cannot be initiated due to a current transfer in progress.) ec fetch_queue_full,fetchful, (There is already an entry in the BFT Fetch queue.) ec illegal_minor_capability,ilmincap, (An illegal minor capability was called.) ec invalid_direction,badirect, (Transfer direction is invalid.) ec invalid_file_type,badfile, (Transfer file type is invalid.) ec invalid_keyword,badkey, (Keyword is invalid.) ec invalid_priority,badprior, (Priority level is invalid.) ec invalid_queue,badq, (Pointer to BFT queue is invalid.) ec invalid_request_type,badrqst, (Request type is invalid.) ec no_entries,noentry, (No more entries in queue.) ec no_queue,noqueue, (BFT queue has been deleted.) ec store_in_progress,storeprg, (Store cannot be initiated due to a current transfer in progress.) ec unexpected_minor_capability,mnrntexp, (An unexpected minor capability number was recieved.) end  bft_main_.pl1 02/24/88 0851.3rew 02/24/88 0843.6 638523 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1987 * * * *********************************************************** */ bft_main_: proc () options (main); /* PROGRAM FUNCTION This program is the Multics side of the MOWSE application BFT. This program in conjunction with the PC portion, allows a user to transfer files to and from Multics through commands entered on either the PC or at Multics command level. Because this code is designed to run in the "background", all messages are printed out via the MOWSE put_background_message facility, and MUST be used in conjunction with MOWSE and the terminal emulator. For a description of commands see bft.info. */ /* NOTES */ /****^ HISTORY COMMENTS: 1) change(86-07-22,Eichele), approve(87-06-30,MCR7580), audit(87-07-30,RBarstad), install(87-08-07,MR12.1-1075): Created. 2) change(87-10-23,Flegel), approve(87-10-23,MCR7787), audit(88-01-27,RWaters), install(88-02-24,MR12.2-1028): Converted to use new queueing strategy which handles multiple entries. END HISTORY COMMENTS */ /* PARAMETERS */ dcl p_minor_cap fixed bin parameter; /* Minor function number */ dcl p_major_sender fixed bin parameter; /* Source of message */ dcl p_arg_ptr ptr parameter; /* Pointer to message */ dcl p_arg_len fixed bin parameter; /* Length of message */ dcl p_mcb_ptr ptr parameter; /* MOWSE control block */ dcl p_data_block_ptr ptr parameter; /* Data kept around */ /* MISC VARIABLES */ dcl command_id fixed bin; /* ID of execute command */ dcl my_major fixed bin; /* Capability number of bft_main_ */ dcl major_num fixed bin; /* Capability number */ dcl mcb_ptr ptr; /* MOWSE control block */ dcl code fixed bin (35); /* Error code */ /* STRUCTURES */ /* SYSTEM CALLS */ dcl get_equal_name_ entry (char(*), char(*), char(32), fixed bin(35)); dcl hcs_$star_ entry (char(*), char(*), fixed bin(2), ptr, fixed bin, ptr, ptr, fixed bin(35)); dcl absolute_pathname_ entry (char(*), char(*), fixed bin(35)); dcl iox_$get_chars entry (ptr, ptr, fixed bin(21), fixed bin(21), fixed bin(35)); dcl iox_$position entry (ptr, fixed bin, fixed bin(21), fixed bin(35)); dcl convert_status_code_ entry (fixed bin(35), char(8) aligned, char(100) aligned); dcl iox_$put_chars entry (ptr, ptr, fixed bin(21), fixed bin(35)); dcl iox_$open entry (ptr, fixed bin, bit(1) aligned, fixed bin(35)); dcl iox_$attach_name entry (char(*), ptr, char(*), ptr, fixed bin(35)); dcl expand_pathname_ entry (char(*), char(*), char(*), fixed bin(35)); dcl clock_ entry() returns(fixed bin(71)); dcl iox_$destroy_iocb entry (ptr, fixed bin(35)); dcl iox_$detach_iocb entry (ptr, fixed bin(35)); dcl iox_$close entry (ptr, fixed bin(35)); dcl iox_$find_iocb entry (char(*), ptr, fixed bin(35)); dcl com_err_ entry() options(variable); dcl get_system_free_area_ entry() returns(ptr); /* SYSTEM CALL SUPPORT */ dcl error_table_$bad_conversion fixed bin(35) ext static; dcl error_table_$short_record fixed bin(35) ext static; dcl error_table_$end_of_info fixed bin(35) ext static; /* EXTERNAL CALLS */ dcl bft_queue_$cancel entry (ptr, char(*), fixed bin, fixed bin(35)); dcl bft_queue_$remove entry (ptr, fixed bin, fixed bin(35)); dcl ws_$disconnect_response entry (fixed bin, fixed bin, ptr, fixed bin(35)); dcl ws_$connect_response entry (fixed bin, fixed bin, ptr, fixed bin(35)); dcl ws_$execute_capability entry (fixed bin, fixed bin, ptr, fixed bin, ptr, fixed bin(35)); dcl bft_queue_$add entry (ptr, ptr, fixed bin, fixed bin, fixed bin(35)); dcl ws_$disconnect_request entry (fixed bin, ptr, fixed bin(35)); dcl ws_$execute_command entry (char(*), fixed bin, fixed bin, ptr, fixed bin(35)); dcl ws_$destroy_instance entry (ptr, fixed bin(35)); dcl ws_$put_background_message entry() options(variable); dcl ws_$find_capability_number entry (char(*), fixed bin, fixed bin, fixed bin(35)); dcl ws_$create_instance entry (char(*), char(*), fixed bin, fixed bin, ptr, ptr, fixed bin(35)); dcl bft_queue_$initiate entry (ptr, fixed bin(35)); /* EXTERNAL CALL SUPPORT */ dcl bft_error_table_$store_in_progress fixed bin(35) ext static; dcl bft_error_table_$no_entries fixed bin(35) ext static; dcl bft_error_table_$fetch_in_progress fixed bin(35) ext static; dcl bft_error_table_$illegal_minor_capability fixed bin(35) ext static; dcl ws_error_$invalid_minor_capability fixed bin(35) ext static; dcl ws_error_$invalid_capability_name fixed bin(35) ext static; /* BUILTINS */ dcl sum builtin; dcl search builtin; dcl rtrim builtin; dcl rank builtin; dcl byte builtin; dcl addr builtin; dcl reverse builtin; dcl convert builtin; dcl ltrim builtin; dcl length builtin; dcl substr builtin; dcl index builtin; dcl unspec builtin; dcl null builtin; /* CONDITIONS */ dcl cleanup condition; /* CONSTANTS */ dcl NAME char (9) int static options (constant) init ("bft_main_"); dcl fixedbin21 fixed bin (21) based; dcl fixedbin17 fixed bin (17) based; dcl char128var char (128) var based; /* */ /* INITIALIZATION */ code = 0; queue_ptr = null; data_block_ptr = null; /* MAIN */ /* The first section of code is executed when the bft load command is used. It initializes the necessary variables and notifies MOWSE that it is to be registered as a major cability. */ /* Initialize the necessary structures and queues */ call initialize_bft (code); if code ^= 0 then do; call com_err_ (code, NAME, "Initializing."); return; end; /* : Register as a MOWSE major capability */ call ws_$create_instance (NAME, "main_entry", data_block.inbuff_len, data_block.outbuff_len, data_block_ptr, mcb_ptr, code); if code ^= 0 then do; call com_err_ (code, NAME, "Creating MOWSE instance."); return; end; /* Check to see if this is more than the first instance of BFT that MOWSE knows about. Multiple instances of BFT are not allowed */ major_num = 0; call ws_$find_capability_number (NAME, LOCAL_SYSTEM, major_num, code); if code ^= 0 then do; call ws_$put_background_message (mcb_ptr, code, "bft", "Failed to locate one instance of BFT"); call bft_shut_down (); return; end; /* If there exists more than one instance of BFT then delete the current one */ my_major = major_num; call ws_$find_capability_number (NAME, LOCAL_SYSTEM, my_major, code); if code = 0 then do; call ws_$put_background_message (mcb_ptr, code, "bft", "Already loaded."); call ws_$destroy_instance (mcb_ptr, code); call cleanup_data_block (); return; end; /* Check to see if the PC BFT is loaded */ major_num = find_pc_bft (mcb_ptr, "0"b); if major_num ^= 0 then return; /* Load PC BFT by executing the proper command */ else do; call ws_$execute_command ("bft_load", REMOTE_SYSTEM, command_id, mcb_ptr, code); if code ^= 0 then do; call ws_$put_background_message (mcb_ptr, code, "bft", "Excuting ""PC:bft_load"" command."); call bft_shut_down (); return; end; end; return; /* */ /* INTERNAL ENTRIES */ /* *** Entry: main_entry - Internal entry for bft_main_ *** */ main_entry: entry (p_minor_cap, p_major_sender, p_arg_ptr, p_arg_len, p_mcb_ptr, p_data_block_ptr); /* ENTRY FUNCTION This is the entry point where all other major capabilities access BFT via MOWSE. The minor capability number determines which of the procedures is called. */ /* NOTES */ /* Set up addressing */ data_block_ptr = p_data_block_ptr; queue_ptr = data_block.queue_ptr; mcb_ptr = p_mcb_ptr; /* If we are shutting down, ignore most messages */ if data_block.flags.shut_down_sw & p_minor_cap ^= TERMINATE_APPLICATION & p_minor_cap ^= RESPONSE_DISCONNECT & p_minor_cap ^= bft_minor_$bft_shut_down then return; /* Verify that the minor capability number is acceptable */ if ((p_minor_cap < 32 | p_minor_cap > 50) & (p_minor_cap < 64 | p_minor_cap > 81)) | p_minor_cap = 79 | p_minor_cap = 80 then do; call ws_$put_background_message (mcb_ptr, ws_error_$invalid_minor_capability, "bft", " ^d.", p_minor_cap); call bft_shut_down (); return; end; /* Handle the minor capability */ goto case (p_minor_cap); case (32): call execute_command_reply (); return; case (36): call no_handler ("execute_capability_reply", "1"b); return; case (37): call no_handler ("suspend_application", "0"b); return; case (38): call no_handler ("resume_application", "0"b); return; case (39): call terminate_application (); return; case (40): call no_handler ("reset_application", "0"b); return; case (41): call no_handler ("reset_reply", "0"b); return; case (42): call no_handler ("wake_up", "0"b); return; case (43): call no_handler ("status", "0"b); return; case (44): call no_handler ("buffer_overflow", "1"b); return; case (45): call no_handler ("fail_capability", "1"b); return; case (46): call no_handler ("query_reply", "0"b); return; case (47): call no_handler ("response_connect", "0"b); return; case (48): call response_disconnect (); return; case (49): call request_connect (p_major_sender); return; case (50): call request_disconnect (p_major_sender); return; case (64): call add_to_fetch_queue (p_arg_ptr, p_arg_len, p_major_sender); return; case (65): call add_to_store_queue (p_arg_ptr, p_arg_len, p_major_sender); return; case (66): /* CHECK_FILE_LENGTH */ return; case (67): call initiate_fetch (); return; case (68): call bft_shut_down (); return; case (69): call position_file_pointer (p_arg_ptr, p_arg_len); return; case (70): call receive_data (p_arg_ptr, p_arg_len); return; case (71): call receive_eof (); return; case (72): call recover_fetch (); return; case (73): call recover_store (); return; case (74): call read_error (p_arg_ptr, p_arg_len); return; case (75): call initiate_store (); return; case (76): call write_error (p_arg_ptr, p_arg_len); return; case (77): call send_data (); return; case (78): call cancel (p_arg_ptr, p_arg_len); return; case (79): /* unused */ return; case (80): /* EXPAND_PC_PATH */ return; case (81): call full_pc_path (p_mcb_ptr, p_arg_ptr, p_arg_len); return; /* */ /* INTERNAL PROCEDURES */ /* *** Procedure: add_to_fetch_queue - Internal proc for bft_main_ *** */ add_to_fetch_queue: proc (p_arg_ptr, p_arg_len, p_major_sender); /* PROCEDURE FUNCTION Add the request to the fetch (PC->Multics) queue. */ /* NOTES */ /* PARAMETERS */ dcl p_arg_ptr ptr parameter; /* Message */ dcl p_arg_len fixed bin parameter; /* Length of message */ dcl p_arg_data char (p_arg_len) based (p_arg_ptr); dcl p_major_sender fixed bin parameter; /* Source of message */ /* MISC VARIABLES */ dcl priority fixed bin; /* Transfer priority */ dcl flags bit(36) aligned; /* Transfer modes */ dcl pc_path char (66); /* PC path */ dcl mu_path char (168); /* Multics path */ /* STRUCTURES */ /* INITIALIZATION */ /* MAIN */ call extract_requests (p_arg_data, mu_path, pc_path, flags, priority); call add_to_queue (mu_path, pc_path, flags, priority, p_major_sender, BFT_PC_to_MULTICS); end add_to_fetch_queue; /* */ /* *** Procedure: add_to_queue - Internal proc for bft_main_ *** */ add_to_queue: proc (p_mu_path, p_pc_path, p_flags, p_priority, p_sender, p_direction); /* PROCEDURE FUNCTION This minor capability is responsible for adding elements to the fetch or store queue (PC to Multics transfers). If the request initiated from the local system (Multics), then EXPAND_PC_PATH is called on the PC:BFT to expand the provided PC pathname to an absolute value. Which then returns control to FULL_PC_PATH on MU:BFT continuing the addition of the transfer request to the queue. Otherwise, it is assumed that the remote (PC) sent the full path and the request is entered into the queue. If no fetch is in progress, then a fetch is initiated. */ /* NOTES The message data is assumed to be correct: MU_PATH;PC_PATH;FLAGS;PRIORITY; */ /* PARAMETERS */ dcl p_mu_path char (*) parameter; /* Multics path */ dcl p_pc_path char (*) parameter; /* PC path */ dcl p_priority fixed bin parameter; /* Priority of request */ dcl p_flags bit(36) aligned parameter; /* Transfer modes */ dcl p_direction fixed bin parameter; /* Direction (store / fetch) */ dcl p_sender fixed bin parameter; /* Sender of message */ /* MISC VARIABLES */ dcl code fixed bin (35); dcl pending_ptr ptr; /* Pending structure */ dcl system_free_area area based (data_block.system_free_area_ptr); /* STRUCTURES */ dcl 01 element like queue_element automatic; /* INITIALIZATION */ unspec (element) = ""b; /* MAIN */ element.multics_path = p_mu_path; element.pc_path = p_pc_path; unspec (element.flags) = p_flags; /* If the source of the request was from Multics system, then we need to expand the PC path to its fullest */ if get_system_id (p_sender) = LOCAL_SYSTEM | p_direction = BFT_PC_to_MULTICS then do; pending_ptr = null; on cleanup call cleanup_pending (pending_ptr); allocate pending set (pending_ptr) in (system_free_area); pending_ptr -> pending.next = null; /* Insert the request into the "to-be-completed" list */ pending_ptr -> pending.multics_path = rtrim (element.multics_path); pending_ptr -> pending.pc_path = rtrim (element.pc_path); pending_ptr -> pending.flags = unspec (element.flags); pending_ptr -> pending.switches.processing_sw = "0"b; pending_ptr -> pending.switches.first_sw = "1"b; pending_ptr -> pending.switches.pad = ""b; pending_ptr -> pending.priority = p_priority; pending_ptr -> pending.id = 0; call insert_pending (p_direction, pending_ptr); revert cleanup; call get_pc_path (); end; /* Otherwise, add the request to the appropriate queue */ else do; element.time_id = clock_ (); call bft_queue_$add (queue_ptr, addr (element), p_priority, p_direction, code); if code ^= 0 then do; call ws_$put_background_message (p_mcb_ptr, code, "bft", "Adding element to ^[store^;fetch^] queue ^d.", (p_direction = BFT_MULTICS_to_PC), p_priority); return; end; end; /* Let's start something going if it isn't already */ if p_direction = BFT_PC_to_MULTICS then call initiate_fetch (); else call initiate_store (); end add_to_queue; /* */ /* *** Procedure: add_to_store_queue - Internal proc for bft_main_ *** */ add_to_store_queue: proc (p_arg_ptr, p_arg_len, p_major_sender); /* PROCEDURE FUNCTION Add the element to the store queue, if it needs starname expansion for the Multics Path, go ahead and do it. But for every request, there is a high chance that each one must go to the PC for PC expansion to an absolute path of the destination. */ /* NOTES */ /* PARAMETERS */ dcl p_arg_ptr ptr parameter; /* Message */ dcl p_arg_len fixed bin parameter; /* Length of message */ dcl p_arg_data char (p_arg_len) based (p_arg_ptr); dcl p_major_sender fixed bin parameter; /* Sender of request */ /* MISC VARIABLES */ dcl pc_entry_name char (11); /* Entry component */ dcl pc_dir_name char (66); /* Directory component */ dcl pc_equal1 char (32); /* For expanding equalnames */ dcl pc_equal char (66); /* Equal name for PC entry */ dcl path_name char (168); /* Full path of request */ dcl entry_name char (32); dcl code fixed bin (35); dcl dir_name char (168); dcl priority fixed bin; /* Priority of request */ dcl flags bit(36) aligned; /* Transfer modes */ dcl pc_path char (66); dcl mu_path char (168); dcl i fixed bin; /* STRUCTURES */ /* INITIALIZATION */ /* MAIN */ call extract_requests (p_arg_data, mu_path, pc_path, flags, priority); call expand_pathname_ (mu_path, dir_name, entry_name, code); if code ^= 0 then do; call ws_$put_background_message (mcb_ptr, code, "bft", "Expanding ^a for storing.", mu_path); return; end; on cleanup begin; free star_names_ptr -> star_names; free star_entry_ptr -> star_entries; end; call hcs_$star_ (dir_name, entry_name, star_ALL_ENTRIES, data_block.system_free_area_ptr, star_entry_count, star_entry_ptr, star_names_ptr, code); if code ^= 0 then do; call ws_$put_background_message (mcb_ptr, code, "bft", "Matching starnames for ^a.", mu_path); return; end; do i = 1 to star_entry_count; pc_equal = pc_path; if star_entries (i).type = star_LINK | star_entries (i).type = star_SEGMENT then do; if index (pc_path, "=") ^= 0 then do; call expand_pc_pathname (pc_path, pc_dir_name, pc_entry_name, code); if code ^= 0 then do; call ws_$put_background_message (mcb_ptr, code, "bft", "Expanding ^a for equal name.", pc_path); return; end; call get_equal_name_ (star_names (i), pc_entry_name, pc_equal1, code); if code ^= 0 then do; call ws_$put_background_message (mcb_ptr, code, "bft", "Getting equal name for ^a.", star_names (i)); return; end; pc_equal = ""; if length (rtrim (pc_dir_name)) > 0 then pc_equal = rtrim (pc_dir_name) || "\"; pc_equal = rtrim (pc_equal) || rtrim (pc_equal1); end; path_name = rtrim (dir_name) || ">" || rtrim (star_names (i)); call add_to_queue (path_name, pc_equal, flags, priority, p_major_sender, BFT_MULTICS_to_PC); end; end; free star_names_ptr -> star_names; free star_entry_ptr -> star_entries; end add_to_store_queue; /* */ /* *** Procedure: add_token - Internal proc for bft_main_ *** */ add_token: proc (p_message, p_message_len, p_token); /* PROCEDURE FUNCTION Add the token to the message. */ /* NOTES */ /* PARAMETERS */ dcl p_message char (*) parameter; /* Message being created */ dcl p_message_len fixed bin parameter; /* Current length of message */ dcl p_token char (*) parameter; /* Token to add */ /* MISC VARIABLES */ /* STRUCTURES */ /* INITIALIZATION */ /* MAIN */ substr (p_message, p_message_len + 1) = p_token; p_message_len = p_message_len + length (p_token); substr (p_message, p_message_len + 1) = DELIM_CHAR; p_message_len = p_message_len + length (DELIM_CHAR); end add_token; /* */ /* *** Procedure: bft_shut_down - Internal proc for bft_main_ *** */ bft_shut_down: proc (); /* PROCEDURE FUNCTION This routine is called when BFT is to be shut down. A message to this effect ist printed, and then the disconnect request minor is called on the remote machine. When the disconnect_reply is called, this side of bft will shut down. */ /* NOTES */ /* PARAMETERS */ /* MISC VARIABLES */ dcl code fixed bin (35); /* Error code */ dcl major_num fixed bin; /* Capability number */ /* STRUCTURES */ /* INITIALIZATION */ /* MAIN */ data_block.flags.shut_down_sw = "1"b; /* Close and detach all opened IOCBs */ call cleanup_iocb_switches (); /* Release all of the pending transfers waiting for pc_path expansion */ call cleanup_pending_chain (); /* Generate the shutdown message */ call ws_$put_background_message (mcb_ptr, 0, "bft", "BFT is shutting down and removing itself from MOWSE."); major_num = 0; call ws_$find_capability_number ("BFT", REMOTE_SYSTEM, major_num, code); if code ^= 0 then do; call ws_$put_background_message (mcb_ptr, code, "bft", "Finding PC counterpart in bft_shut_down."); return; end; call ws_$disconnect_request (major_num, mcb_ptr, code); if code ^= 0 then do; call ws_$put_background_message (mcb_ptr, code, "bft", "Requesting disconnect in bft_shut_down."); return; end; end bft_shut_down; /* */ /* *** Procedure: cancel - Internal proc for bft_main_ *** */ cancel: proc (p_arg_ptr, p_arg_len); /* PROCEDURE FUNCTION This minor capability cancels the specified request from the queue. The provided request_id is either a path (PC or Multics) or an ID of an entry in the queue. */ /* NOTES The message data is assumed tro be correct: ID_SW;REQUEST_ID; */ /* PARAMETERS */ dcl p_arg_ptr ptr parameter; /* Message */ dcl p_arg_len fixed bin parameter; /* Message length */ dcl p_arg_data char (p_arg_len) based (p_arg_ptr); /* MISC VARIABLES */ dcl id_type fixed bin; /* Type of request_id */ dcl request_id char (168); /* Actual request id */ dcl token char (p_arg_len) var; dcl code fixed bin (35); /* STRUCTURES */ /* INITIALIZATION */ code = 0; /* MAIN */ /* Strip the request type */ call strip_token (p_arg_data, token); id_type = rank (substr (token, 1, 1)); if ^(id_type = BFT_PATH_ID | id_type = BFT_TIME_ID | id_type = BFT_ENTRY_ID) then do; call ws_$put_background_message (mcb_ptr, error_table_$bad_conversion, "bft", "Extracting request_id type."); return; end; /* Strip the request id */ call strip_token (p_arg_data, token); request_id = ltrim (token); /* Cancel the request */ call bft_queue_$cancel (queue_ptr, request_id, id_type, code); if code ^= 0 then do; call ws_$put_background_message (mcb_ptr, code, "bft", "Cancelling ^a.", request_id); return; end; end cancel; /* */ /* *** Procedure: chars_to_bits - Internal proc for bft_main_ *** */ chars_to_bits: proc (p_precision, p_string) returns (bit(*)); /* PROCEDURE FUNCTION Convert a character string to a continuous bit representation. */ /* NOTES */ /* PARAMETERS */ dcl p_precision fixed bin parameter; /* Number of bits to extract */ dcl p_string char (*) parameter; /* Chars to convert */ /* MISC VARIABLES */ dcl i fixed bin; dcl ret_string bit(p_precision); /* Return bit string */ /* STRUCTURES */ /* INITIALIZATION */ /* MAIN */ ret_string = ""b; do i = 1 to length (p_string); substr (ret_string, p_precision - (i*8)) = unspec (substr (p_string, i, 1)); end; return (ret_string); end chars_to_bits; /* */ /* *** Procedure: cleanup_data_block - Internal proc for bft_main_ *** */ cleanup_data_block: proc (); /* PROCEDURE FUNCTION Free the data block structure back to the system. */ /* NOTES */ /* PARAMETERS */ /* MISC VARIABLES */ /* STRUCTURES */ /* INITIALIZATION */ /* MAIN */ if data_block_ptr ^= null then do; free data_block_ptr -> data_block; data_block_ptr = null; end; end cleanup_data_block; /* */ /* *** Procedure: cleanup_pending_chain - Internal proc for bft_main_ *** */ cleanup_pending_chain: proc (); /* PROCEDURE FUNCTION Release all of the elements in the chain of pending requests. */ /* NOTES */ /* PARAMETERS */ /* MISC VARIABLES */ dcl temp_ptr ptr; /* STRUCTURES */ /* INITIALIZATION */ /* MAIN */ /* Release all of the pending transfers waiting for pc_path expansion */ do while (data_block.fetch_pending ^= null); temp_ptr = data_block.fetch_pending -> pending.next; call cleanup_pending (data_block.fetch_pending); data_block.fetch_pending = temp_ptr; end; do while (data_block.store_pending ^= null); temp_ptr = data_block.store_pending -> pending.next; call cleanup_pending (data_block.store_pending); data_block.store_pending = temp_ptr; end; end cleanup_pending_chain; /* */ /* *** Procedure: expand_pc_pathname - Internal proc for bft_main_ *** */ expand_pc_pathname: proc (p_source, p_dir_name, p_entry_name, p_code); /* PROCEDURE FUNCTION Parse apart the PC pathname into its directory and entry components. */ /* NOTES */ /* PARAMETERS */ dcl p_code fixed bin (35) parameter; dcl p_source char (*) parameter; /* Path to expand */ dcl p_dir_name char (*) parameter; /* Directory component */ dcl p_entry_name char (*) parameter; /* Entry component */ /* MISC VARIABLES */ dcl done bit(1); /* Loop control */ dcl i fixed bin; dcl indx fixed bin; /* STRUCTURES */ /* INITIALIZATION */ p_code = 0; /* MAIN */ indx = 1; p_dir_name = ""; p_entry_name = ""; done = "0"b; do while (^done & indx < length (rtrim (p_source))); i = index (substr (p_source, indx), "\"); if i > 0 then indx = indx + i; else done = "1"b; end; if indx > 1 then p_dir_name = substr (p_source, 1, indx - 2); p_entry_name = substr (rtrim (p_source), indx); end expand_pc_pathname; /* */ /* *** Procedure: extract_requests - Internal proc for bft_main_ *** */ extract_requests: proc (p_message, p_mu_path, p_pc_path, p_flags, p_priority); /* PROCEDURE FUNCTION Extract requests from the message. This is a STORE or FETCH request message with the format: MU_PATH;PC_PATH;FLAGS;PRIORITY; */ /* NOTES */ /* PARAMETERS */ dcl p_message char (*) parameter; /* Message to extract from */ dcl p_priority fixed bin parameter; dcl p_flags bit(36) aligned parameter; dcl p_pc_path char (*) parameter; dcl p_mu_path char (*) parameter; /* MISC VARIABLES */ dcl i fixed bin; dcl ch_flags char (4); /* Character representation of flags */ dcl code fixed bin (35); dcl dir_name char (168); /* Directory of path */ dcl token char (length (p_message)) var; /* STRUCTURES */ /* INITIALIZATION */ /* MAIN */ /* Get the Multics path, PC path, and flags, in THAT order from the message */ call strip_token (p_message, token); dir_name = ltrim (substr (token, 1, length (token))); call absolute_pathname_ (dir_name, p_mu_path, code); if code ^= 0 then do; call ws_$put_background_message (mcb_ptr, code, "bft", "Expanding ^a.", rtrim (p_mu_path)); return; end; call strip_token (p_message, token); p_pc_path = ltrim (substr (token, 1, length (token))); call strip_token (p_message, token); ch_flags = substr (token, 1, length (token)); p_flags = ""b; do i = 1 to 4; substr (p_flags, (8*(i-1))+1, 8) = substr (unspec (substr (ch_flags, i, 1)), 2, 8); end; substr (unspec (p_flags), 5, 32) = p_flags; call strip_token (p_message, token); p_priority = rank (substr (token, 1, 1)); end extract_requests; /* */ /* *** Procedure: find_pending - Internal proc for bft_main_ *** */ find_pending: proc (p_pending_ptr, p_start_ptr, p_request_id, p_remove); /* PROCEDURE FUNCTION Lovcate the element corresponding to the request ID. */ /* NOTES */ /* PARAMETERS */ dcl p_remove bit(1) parameter; /* Remove the element? */ dcl p_request_id fixed bin parameter; /* ID of element to be matched */ dcl p_start_ptr ptr parameter; /* Start of list */ dcl p_pending_ptr ptr parameter; /* Found element */ /* MISC VARIABLES */ dcl prev_ptr ptr; /* Previous element pointer */ dcl search_ptr ptr; /* Pointer to look with */ /* STRUCTURES */ /* INITIALIZATION */ /* MAIN */ p_pending_ptr = null; search_ptr = p_start_ptr; prev_ptr = null; if p_start_ptr = null then return; do while (search_ptr -> pending.id ^= p_request_id); prev_ptr = search_ptr; search_ptr = prev_ptr -> pending.next; if search_ptr = null then return; end; if search_ptr = null then do; p_pending_ptr = null; return; end; p_pending_ptr = search_ptr; if ^p_remove then return; if prev_ptr = null then p_start_ptr = search_ptr -> pending.next; else prev_ptr -> pending.next = search_ptr -> pending.next; p_pending_ptr -> pending.next = null; end find_pending; /* */ /* *** Procedure: full_pc_path - Internal proc for bft_main_ *** */ full_pc_path: proc (p_mcb_ptr, p_arg_ptr, p_arg_len); /* PROCEDURE FUNCTION The PC has expanded a path to its full name, the ID of the request is matched with a pending request and extracted to be inserted into the queue. */ /* NOTES The argument data is: PC_PATH;MAJOR_ID;DIRECTION */ /* PARAMETERS */ dcl p_arg_data char (p_arg_len) based (p_arg_ptr); dcl p_mcb_ptr ptr parameter; /* MOWSE control block */ dcl p_arg_ptr ptr parameter; /* Message */ dcl p_arg_len fixed bin parameter; /* Length of message */ /* MISC VARIABLES */ dcl equalname char (32); /* Equalname created */ dcl mu_entryname char (32); /* Multics entry component */ dcl mu_dirname char (168); /* Multics directory component */ dcl pc_entryname char (12); /* PC entry componenet */ dcl pc_dirname char (66); /* PC directory componenet */ dcl remove_sw bit(1); /* If removal required */ dcl code fixed bin (35); dcl pending_ptr ptr; /* Matching element */ dcl direction fixed bin; /* Direction of transfer */ dcl major fixed bin; /* Major request id */ dcl major_id_over fixed bin (17) unal based (addr (major_bit_id)); dcl major_bit_id bit(18) unal; dcl token char (p_arg_len) var; /* STRUCTURES */ dcl 01 element like queue_element auto; /* INITIALIZATION */ /* MAIN */ call strip_token (p_arg_data, token); element.pc_path = token; call strip_token (p_arg_data, token); major_bit_id = ""b; substr (major_bit_id, 1, 9 * length (token)) = reverse (chars_to_bits (9 * length (token), substr (token, 1))); major_bit_id = reverse (major_bit_id); major = major_id_over; call strip_token (p_arg_data, token); direction = rank (substr (token, 1, 1)); /* If the returned path length is 0, no match so remove the element */ remove_sw = (length (rtrim (element.pc_path)) = 0); /* Locate the matching element */ if direction = BFT_PC_to_MULTICS then call find_pending (pending_ptr, data_block.fetch_pending, major, remove_sw); else call find_pending (pending_ptr, data_block.store_pending, major, remove_sw); if pending_ptr = null then return; /* If this was a first request response, and there is no match, then error */ if pending_ptr -> pending.switches.first_sw & remove_sw & search (pending_ptr -> pending.pc_path, "?*") > 0 then call ws_$put_background_message (mcb_ptr, 0, "bft", "No PC match for ^a.", pending_ptr -> pending.pc_path); /* Fill out the queue element and add it to the appropriate queue */ if ^remove_sw then do; pending_ptr -> pending.switches.processing_sw = "0"b; pending_ptr ->pending.switches.first_sw = "0"b; if index (pending_ptr -> pending.multics_path, "=") > 0 then do; call expand_pc_pathname (element.pc_path, pc_dirname, pc_entryname, code); call expand_pathname_ (pending_ptr -> pending.multics_path, mu_dirname, mu_entryname, code); if code ^= 0 then do; call ws_$put_background_message (mcb_ptr, code, "bft", "Expanding ^a to add to queue.", pending_ptr -> pending.multics_path); return; end; call get_equal_name_ (pc_entryname, mu_entryname, equalname, code); if code ^= 0 then do; call ws_$put_background_message (mcb_ptr, code, "bft", "Getting equalname ^a to add to queue.",pc_entryname); return; end; element.multics_path = rtrim (mu_dirname) || ">" || equalname; end; else element.multics_path = pending_ptr -> pending.multics_path; element.next = 0; element.time_id = clock_ (); unspec (element.flags) = pending_ptr -> pending.flags; call bft_queue_$add (queue_ptr, addr (element), pending_ptr -> pending.priority, direction, code); if code ^= 0 then do; call ws_$put_background_message (p_mcb_ptr, code, "bft", "Adding element to ^[store^;fetch^] queue ^d.", (direction = BFT_MULTICS_to_PC), pending_ptr -> pending.priority); return; end; end; else call cleanup_pending (pending_ptr); /* Lets get another name expanded, if necessary */ call get_pc_path (); /* Lets try for a transfer */ if ^remove_sw then do; if direction = BFT_PC_to_MULTICS then call initiate_fetch (); else call initiate_store (); end; end full_pc_path; /* */ /* *** Procedure: bits_to_chars - Internal proc for bft_main_ *** */ bits_to_chars: proc (p_n_bytes, p_bits) returns (char (*)); /* PROCEDURE FUNCTION Convert a continuous bit string to series of characters where 8 bits are stuffed into each character. */ /* NOTES */ /* PARAMETERS */ dcl p_n_bytes fixed bin parameter; /* Number of bytes in number */ dcl p_bits bit (*); /* Conversion number */ /* MISC VARIABLES */ dcl out_string char (p_n_bytes); /* Output string */ dcl i fixed bin; /* STRUCTURES */ /* INITIALIZATION */ /* MAIN */ unspec (out_string) = ""b; do i = 1 to p_n_bytes; substr (unspec (substr (out_string, i, 1)), 2, 8) = reverse (substr (reverse (p_bits), (8*(i-1))+1, 8)); end; return (reverse (out_string)); end bits_to_chars; /* */ /* *** Procedure: cleanup_iocb_switches - Internal proc for bft_main_ *** */ cleanup_iocb_switches: proc (); /* PROCEDURE FUNCTION Close and detach all opend bft switches. This must be done by name. */ /* NOTES */ /* PARAMETERS */ /* MISC VARIABLES */ dcl code fixed bin (35); dcl iocb_ptr ptr; /* STRUCTURES */ /* INITIALIZATION */ /* MAIN */ call iox_$find_iocb ("bft_send", iocb_ptr, code); if code = 0 then call close_data_file (iocb_ptr); call iox_$find_iocb ("bft_receive", iocb_ptr, code); if code = 0 then call close_data_file (iocb_ptr); end cleanup_iocb_switches; /* */ /* *** Procedure: cleanup_pending - Internal proc for bft_main_ *** */ cleanup_pending: proc (p_pending_ptr); /* PROCEDURE FUNCTION Release the structure pointed at by the pointer. */ /* NOTES */ /* PARAMETERS */ dcl p_pending_ptr ptr parameter; /* The structure to be cleaned */ /* MISC VARIABLES */ /* STRUCTURES */ /* INITIALIZATION */ /* MAIN */ if p_pending_ptr ^= null then do; free p_pending_ptr -> pending; p_pending_ptr = null; end; end cleanup_pending; /* */ /* *** Procedure: close_data_file - Internal proc for bft_main_ *** */ close_data_file: proc (p_iocb_ptr); /* PROCEDURE FUNCTION Close the file specified by the iocb. */ /* NOTES */ /* PARAMETERS */ dcl p_iocb_ptr ptr parameter; /* IOCB to close */ /* MISC VARIABLES */ /* STRUCTURES */ /* INITIALIZATION */ /* MAIN */ call iox_$close (p_iocb_ptr, (0)); call iox_$detach_iocb (p_iocb_ptr, (0)); call iox_$destroy_iocb (p_iocb_ptr, (0)); p_iocb_ptr = null; end close_data_file; /* */ /* *** Procedure: execute_command_reply - Internal proc for bft_main_ *** */ execute_command_reply: proc (); /* PROCEDURE FUNCTION This is called by MOWSE as a reply to the excecute command call in the loading section (main) of this program. There is no code here because it is only used when MOWSE makes this reply. BFT does not require any information or perform any function upon receipt of this call. */ /* NOTES */ /* PARAMETERS */ /* MISC VARIABLES */ /* STRUCTURES */ /* INITIALIZATION */ /* MAIN */ end execute_command_reply; /* */ /* *** Procedure: execute_pc_bft - Internal proc for bft_main_ *** */ execute_pc_bft: proc (p_arg_ptr, p_arg_len, p_minor, p_mcb_ptr, p_code); /* PROCEDURE FUNCTION Execute PC counterpart of BFT. */ /* NOTES If an error occured, then here is where the shutdown is generated and the offending error code is passed back up. The code should merely be used to indicate some error occurred, nothing should be done with it. */ /* PARAMETERS */ dcl p_arg_ptr ptr parameter; /* Message */ dcl p_arg_len fixed bin parameter; /* Length of message */ dcl p_minor fixed bin parameter; /* Minor to execute */ dcl p_mcb_ptr ptr parameter; /* MOWSE control block */ dcl p_code fixed bin (35) parameter; /* MISC VARIABLES */ /* STRUCTURES */ /* INITIALIZATION */ /* MAIN */ if data_block.pc_bft_num = 0 then if find_pc_bft (p_mcb_ptr, "1"b) = 0 then return; call ws_$execute_capability (data_block.pc_bft_num, p_minor, p_arg_ptr, p_arg_len, p_mcb_ptr, p_code); if p_code ^= 0 then do; call ws_$put_background_message (p_mcb_ptr, p_code, "bft", "Executing PC:BFT, minor ^d.", p_minor); call bft_shut_down (); end; end execute_pc_bft; /* */ /* *** Procedure: find_pc_bft - Internal proc for bft_main_ *** */ find_pc_bft: proc (p_mcb_ptr, p_shut_down_sw) returns (fixed bin); /* PROCEDURE FUNCTION Locate the PC counterpart of bft. If found, return the major number and insert it into the data_block. If not found, thenn shut_down (if asked for). */ /* NOTES */ /* PARAMETERS */ dcl p_shut_down_sw bit(1) parameter; /* Shut down if true */ dcl p_mcb_ptr ptr parameter; /* MOWSE control block */ /* MISC VARIABLES */ dcl code fixed bin (35); dcl major_num fixed bin; /* STRUCTURES */ /* INITIALIZATION */ /* MAIN */ major_num = 0; call ws_$find_capability_number ("BFT", REMOTE_SYSTEM, major_num, code); if code ^= 0 & code ^= ws_error_$invalid_capability_name then do; call ws_$put_background_message (p_mcb_ptr, code, "bft", "Locating PC:BFT."); if p_shut_down_sw then call bft_shut_down (); return (0); end; data_block.pc_bft_num = major_num; return (major_num); end find_pc_bft; /* */ /* *** Procedure: get_pc_path - Internal proc for bft_main_ *** */ get_pc_path: proc (); /* PROCEDURE FUNCTION If the top element in the pending list is NOT being processed for a PC path, then submit the request for an expansion on that PC pathname. */ /* NOTES */ /* PARAMETERS */ /* MISC VARIABLES */ dcl direction fixed bin; /* Direction of transfer request */ dcl id_token char (2); /* Char conversion if ID */ dcl pending_ptr ptr; /* Pointer to element to be processed */ dcl message char (128); /* Message to transmit */ dcl message_len fixed bin; /* Length of transmitted message */ /* STRUCTURES */ /* INITIALIZATION */ /* MAIN */ /* If the top request is in process, return */ if data_block.store_pending ^= null then do; if data_block.store_pending -> pending.switches.processing_sw then return; end; else if data_block.fetch_pending ^= null then do; if data_block.fetch_pending -> pending.switches.processing_sw then return; end; else return; /* Lets give STORE expansion priority, there will probably be fewer */ pending_ptr = data_block.store_pending; direction = BFT_MULTICS_to_PC; if pending_ptr = null then do; pending_ptr = data_block.fetch_pending; direction = BFT_PC_to_MULTICS; end; pending_ptr -> pending.switches.processing_sw = "1"b; /* Send out the message */ message_len = 0; if pending_ptr -> pending.switches.first_sw then do; call add_token (message, message_len, BFT_FIRST); call add_token (message, message_len, rtrim (pending_ptr -> pending.pc_path)); end; else do; call add_token (message, message_len, BFT_NEXT); call add_token (message, message_len, ""); end; id_token = bits_to_chars (2, unspec (pending_ptr -> pending.id)); if substr (id_token, 1, 1) = "" then call add_token (message, message_len, substr (id_token, 2, 1)); else call add_token (message, message_len, id_token); call add_token (message, message_len, byte (direction)); call execute_pc_bft (addr (message), message_len, bft_minor_$expand_pc_path, mcb_ptr, (0)); end get_pc_path; /* */ /* *** Procedure: get_system_id - Internal proc for bft_main_ *** */ get_system_id: proc (p_major) returns (fixed bin); /* PROCEDURE FUNCTION Extract the system ID from the capability number. */ /* NOTES */ /* PARAMETERS */ dcl p_major fixed bin parameter; /* Capability number to extract from */ /* MISC VARIABLES */ /* STRUCTURES */ dcl 01 major_overlay unaligned based (addr (p_major)), 02 pad bit (18), 02 system fixed bin (8), 02 index fixed bin (8); /* INITIALIZATION */ /* MAIN */ return (major_overlay.system); end get_system_id; /* */ /* *** Procedure: initialize_bft - Internal proc for bft_main_ *** */ initialize_bft: proc (p_code); /* PROCEDURE FUNCTION This sets all of the variables that BFT needs to access when it is called up. */ /* NOTES */ /* PARAMETERS */ dcl p_code fixed bin (35) parameter; /* Error code */ /* MISC VARIABLES */ dcl system_free_area area based (system_free_area_ptr); dcl system_free_area_ptr ptr; /* STRUCTURES */ /* INITIALIZATION */ p_code = 0; /* MAIN */ system_free_area_ptr = get_system_free_area_ (); allocate data_block in (system_free_area) set (data_block_ptr); unspec (data_block) = ""b; data_block.version = BFT_DATA_BLOCK_VERSION_1; data_block.pc_bft_num = 0; data_block.inbuff_len = BFT_INBUFF_LENGTH; data_block.outbuff_len = BFT_OUTBUFF_LENGTH; data_block.receive_iocb_ptr = null; data_block.send_iocb_ptr = null; data_block.system_free_area_ptr = system_free_area_ptr; data_block.fetch_pending = null; data_block.store_pending = null; data_block.flags.shut_down_sw = "0"b; call bft_queue_$initiate (queue_ptr, p_code); if p_code ^= 0 then return; data_block.queue_ptr = queue_ptr; end initialize_bft; /* */ /* *** Procedure: initiate_fetch - Internal proc for bft_main_ *** */ initiate_fetch: proc (); /* PROCEDURE FUNCTION This procedure / minor capability, examines the PC_to_MULTICS (fetch) queue and determines if it is possible to begin transfer of another file. Conditions are acceptable only when a PC_to_MULTICS (fetch) is not currently in progress and there exists an element in the PC_to_MULTICS (fetch) queue. */ /* NOTES */ /* PARAMETERS */ /* MISC VARIABLES */ dcl message_len fixed bin; /* Length of message */ dcl message char (128); /* Message sent out */ dcl code fixed bin (35); /* STRUCTURES */ /* INITIALIZATION */ /* MAIN */ /* Extract the next element from the fetch queue, repeat until we got one */ do while ("1"b); call bft_queue_$remove (queue_ptr, BFT_PC_to_MULTICS, code); if code = bft_error_table_$fetch_in_progress | code = bft_error_table_$no_entries then return; else if code ^= 0 then do; call ws_$put_background_message (mcb_ptr, code, "bft", "Getting next entry from fetch queue."); call bft_shut_down (); return; end; /* Open the destination (Multics) file */ call open_receive_data_file (rtrim (queue.header.fetching.multics_path), "0"b, code); if code ^= 0 then do; queue.header.fetching.flags.initiated = "0"b; queue.header.fetch_file_pos = 0; call ws_$put_background_message (mcb_ptr, code, "bft", "Opening ^a.", rtrim (queue.header.fetching.multics_path)); end; else do; message_len = 0; call add_token (message, message_len, rtrim (queue.header.fetching.pc_path)); call add_token (message, message_len, bits_to_chars (4, unspec (queue.header.fetching.flags))); call execute_pc_bft (addr (message), message_len, bft_minor_$initiate_fetch, mcb_ptr, code); if code ^= 0 then return; end; end; end initiate_fetch; /* */ /* *** Procedure: initiate_store - Internal proc for bft_main_ *** */ initiate_store: proc (); /* PROCEDURE FUNCTION This procedure / minor capability, examines the MULTICS_to_PC (store) queue and determines if it is possible to begin transfer of another file. Conditions are acceptable only when a MULTICS_to_PC (store) is not currently in progress and there exists an element in the MULTICS_to_PC (store) queue. */ /* NOTES */ /* PARAMETERS */ /* MISC VARIABLES */ dcl message char (256); dcl message_len fixed bin; /* Length of message to send */ dcl code fixed bin (35); /* STRUCTURES */ /* INITIALIZATION */ /* MAIN */ /* Extract the next element from the store queue, repeat until we got one */ do while ("1"b); call bft_queue_$remove (queue_ptr, BFT_MULTICS_to_PC, code); if code = bft_error_table_$store_in_progress | code = bft_error_table_$no_entries then return; else if code ^= 0 then do; call ws_$put_background_message (mcb_ptr, code, "bft", "Getting next entry from store queue."); call bft_shut_down (); return; end; /* Open the source (Multics) file */ call open_send_data_file (rtrim (queue.header.storing.multics_path), code); if code ^= 0 then do; queue.header.storing.flags.initiated = "0"b; queue.header.store_file_pos = 0; call ws_$put_background_message (mcb_ptr, code, "bft", "Opening ^a.", rtrim (queue.header.storing.multics_path)); end; else do; message_len = 0; call add_token (message, message_len, rtrim (queue.header.storing.pc_path)); call add_token (message, message_len, bits_to_chars (4, unspec (queue.header.storing.flags))); call execute_pc_bft (addr (message), message_len, bft_minor_$initiate_store, mcb_ptr, code); if code ^= 0 then return; end; end; end initiate_store; /* */ /* *** Procedure: insert_pending - Internal proc for bft_main_ *** */ insert_pending: proc (p_direction, p_pending_ptr); /* PROCEDURE FUNCTION Insert the pending request into the appropriate chain. */ /* NOTES */ /* PARAMETERS */ dcl p_direction fixed bin parameter; /* Which direction */ dcl p_pending_ptr ptr parameter; /* Structure to insert */ /* MISC VARIABLES */ dcl start_ptr ptr; /* STRUCTURES */ /* INITIALIZATION */ /* MAIN */ if p_direction = BFT_PC_to_MULTICS then do; if data_block.fetch_pending = null then do; data_block.fetch_pending = p_pending_ptr; p_pending_ptr -> pending.id = 1; return; end; else start_ptr = data_block.fetch_pending; end; else do; if data_block.store_pending = null then do; data_block.store_pending = p_pending_ptr; p_pending_ptr -> pending.id = 1; return; end; else start_ptr = data_block.store_pending; end; /* Traverse the list */ do while (start_ptr -> pending.next ^= null); start_ptr = start_ptr -> pending.next; end; start_ptr -> pending.next = p_pending_ptr; p_pending_ptr -> pending.id = start_ptr -> pending.id + 1; end insert_pending; /* */ /* *** Procedure: no_handler - Internal proc for bft_main_ *** */ no_handler: proc (p_message, p_shut_down_sw); /* PROCEDURE FUNCTION This procedure displays an error message indicating that the called minor capability is NOT supported. */ /* NOTES */ /* PARAMETERS */ dcl p_shut_down_sw bit(1) parameter; /* If shut down is required */ dcl p_message char (*) parameter; /* Message to accompany error. */ /* MISC VARIABLES */ /* STRUCTURES */ /* INITIALIZATION */ /* MAIN */ call ws_$put_background_message (mcb_ptr, bft_error_table_$illegal_minor_capability, "bft", p_message); if p_shut_down_sw then call bft_shut_down (); end no_handler; /* */ /* *** Procedure: open_receive_data_file - Internal proc for bft_main_ *** */ open_receive_data_file: proc (p_path, p_append_sw, p_code); /* PROCEDURE FUNCTION Open the receive data file for writing. If the p_append flag is true, then the file is being recovered and we need to open it and set the file position to the character specified in the value segment. Otherwise the file will be destroyed if it already exists. */ /* NOTES */ /* PARAMETERS */ dcl p_path char (*) parameter; /* Path to open */ dcl p_append_sw bit(1) parameter; /* Open for append */ dcl p_code fixed bin (35) parameter; /* Error code */ /* MISC VARIABLES */ dcl iocb_ptr ptr; /* IOCB being opened */ dcl open_descrip char (256); /* Opening modes */ /* STRUCTURES */ /* INITIALIZATION */ p_code = 0; /* MAIN */ /* If the file is already open, then close it */ if data_block.receive_iocb_ptr ^= null then call close_data_file (data_block.receive_iocb_ptr); /* Close and detach the bft_receive IOCB if it exists */ call iox_$find_iocb ("bft_receive", iocb_ptr, p_code); if p_code = 0 then call close_data_file (iocb_ptr); /* Open the file and attach the iocb pointer */ open_descrip = "vfile_ " || rtrim (p_path); if p_append_sw then open_descrip = rtrim (open_descrip) || " -append"; call iox_$attach_name ("bft_receive", iocb_ptr, open_descrip, null, p_code); if p_code ^= 0 then return; call iox_$open (iocb_ptr, Stream_input_output, ("0"b), p_code); if p_code ^= 0 then return; /* Return with the new IOCB and set the data_block value to it */ data_block.receive_iocb_ptr = iocb_ptr; end open_receive_data_file; /* */ /* *** Procedure: open_send_data_file - Internal proc for bft_main_ *** */ open_send_data_file: proc (p_path, p_code); /* PROCEDURE FUNCTION Open the specified file for sending data. */ /* NOTES */ /* PARAMETERS */ dcl p_path char (*) parameter; /* Path to open */ dcl p_code fixed bin (35) parameter; /* MISC VARIABLES */ dcl open_descrip char (256); /* Opening modes */ dcl iocb_ptr ptr; /* STRUCTURES */ /* INITIALIZATION */ p_code = 0; /* MAIN */ /* If we have already opened the send file, then close it */ if data_block.send_iocb_ptr ^= null then call close_data_file (data_block.send_iocb_ptr); /* Close and detach the bft_send IOCB if it exists */ call iox_$find_iocb ("bft_send", iocb_ptr, p_code); if p_code = 0 then call close_data_file (iocb_ptr); /* Lets get ahold of it and store it in the data block */ open_descrip = "vfile_ " || rtrim (p_path); call iox_$attach_name ("bft_send", iocb_ptr, open_descrip, null, p_code); if p_code ^= 0 then return; call iox_$open (iocb_ptr, Stream_input, ("0"b), p_code); if p_code ^= 0 then return; /* Return with the new IOCB and set the data_block value to it */ data_block.send_iocb_ptr = iocb_ptr; end open_send_data_file; /* */ /* *** Procedure: position_file_pointer - Internal proc for bft_main_ *** */ position_file_pointer: proc (p_arg_ptr, p_arg_len); /* PROCEDURE FUNCTION This minor capability is called during the recovery process to set the output file pointer to correspond with the size of the file that has already been received by the remote (during a store). This value is passed via the argument list from CHECK_FILE_LENGTH. If all goes well, the transfer is continued from the position specified. */ /* NOTES The argument data is: FILE_LENGTH */ /* PARAMETERS */ dcl p_arg_ptr ptr parameter; /* Message */ dcl p_arg_len fixed bin parameter; /* Message length */ dcl p_arg_data char (p_arg_len) based (p_arg_ptr); /* MISC VARIABLES */ dcl mode fixed bin; /* Positioning mode */ dcl byte_count fixed bin (21); /* File position */ dcl token char (p_arg_len) var; /* STRUCTURES */ /* INITIALIZATION */ /* MAIN */ /* Get the file position from the argument list */ call strip_token (p_arg_data, token); byte_count = convert (byte_count, token); /* Open the file that was in transfer */ call open_send_data_file (rtrim (queue.header.storing.multics_path), code); if code ^= 0 then do; queue.header.storing.flags.initiated = "0"b; queue.header.store_file_pos = 0; call ws_$put_background_message (mcb_ptr, code, "bft", "Opening ^a for positioning.", rtrim (queue.header.storing.multics_path)); call initiate_store (); return; end; /* Position in the file to the appropriate byte / line position */ queue.header.store_file_pos = byte_count; if queue.header.storing.flags.binary_sw then mode = 2; else mode = 0; call iox_$position (data_block.send_iocb_ptr, -1, 0, code); call iox_$position (data_block.send_iocb_ptr, mode, queue.header.store_file_pos, code); if code ^= 0 then do; queue.header.storing.flags.initiated = "0"b; queue.header.store_file_pos = 0; call ws_$put_background_message (mcb_ptr, code, "bft", "Positioning file ^a.", rtrim (queue.header.storing.multics_path)); call initiate_store (); return; end; /* Begin the transfer from the new file position */ call send_data (); end position_file_pointer; /* */ /* *** Procedure: read_error - Internal proc for bft_main_ *** */ read_error: proc (p_arg_ptr, p_arg_len); /* PROCEDURE FUNCTION This procedure is called by the remote machine to signal an error occurred while the remote machine was sending a file. The proper cleanup is done and the queues are checked to see if there are any pending requests. */ /* NOTES */ /* PARAMETERS */ dcl p_arg_ptr ptr parameter; /* Message */ dcl p_arg_len fixed bin parameter; /* Message length */ dcl p_arg_data char (p_arg_len) based (p_arg_ptr); /* MISC VARIABLES */ dcl error_string char (128) var; /* STRUCTURES */ /* INITIALIZATION */ /* MAIN */ /* Extract the error message from the argument string */ call strip_token (p_arg_data, error_string); call ws_$put_background_message (mcb_ptr, 0, "bft", error_string); /* Remove the current fetch from the queue */ queue.header.fetching.flags.initiated = "0"b; queue.header.fetch_file_pos = 0; call close_data_file (data_block.receive_iocb_ptr); /* Try for another request from the fetch queue */ call initiate_fetch (); end read_error; /* */ /* *** Procedure: receive_data - Internal proc for bft_main_ *** */ receive_data: proc (p_arg_ptr, p_arg_len); /* PROCEDURE FUNCTION This is the minor capability responsible for writing the data it receives as an argument to the destination file. The name of the is kept in the value segment. The file is opened , and the data is written out. Then SEND_DATA is called on the remote machine to send the next piece of the file. */ /* NOTES */ /* PARAMETERS */ dcl p_arg_ptr ptr parameter; /* Message */ dcl p_arg_len fixed bin parameter; /* Message length */ dcl p_arg_data char (p_arg_len) based (p_arg_ptr); /* MISC VARIABLES */ dcl mu_entryname char (32); dcl mu_dirname char (168); dcl line_len fixed bin; dcl line_start fixed bin; /* Position of in data */ dcl message char (128); /* Message to send */ dcl long_info char (100) aligned; /* Long error */ dcl short_info char (8) aligned; /* Short error */ dcl code fixed bin (35); /* STRUCTURES */ /* INITIALIZATION */ /* MAIN */ /* Verify that this transfer has NOT been cancelled midestream */ if ^queue.header.fetching.flags.initiated then do; queue.header.fetch_file_pos = 0; call close_data_file (data_block.receive_iocb_ptr); call expand_pathname_ (rtrim (queue.header.fetching.multics_path), mu_dirname, mu_entryname, code); message = "Fetch request " || rtrim (mu_entryname); message = rtrim (message) || " cancelled in progress."; call execute_pc_bft (addr (message), length (rtrim (message)), bft_minor_$write_error, mcb_ptr, (0)); return; end; /* Write the bytes that were passed into the file */ call iox_$put_chars (data_block.receive_iocb_ptr, p_arg_ptr, convert (fixedbin21, p_arg_len), code); if code ^= 0 then do; queue.header.fetching.flags.initiated = "0"b; queue.header.fetch_file_pos = 0; call close_data_file (data_block.receive_iocb_ptr); call convert_status_code_ (code, short_info, long_info); message = rtrim (long_info) || ". Receiving data."; call execute_pc_bft (addr (message), length (rtrim (message)), bft_minor_$write_error, mcb_ptr, (0)); return; end; /* Increment the count of received chars/lines */ if queue.header.fetching.flags.binary_sw then queue.header.fetch_file_pos = queue.header.fetch_file_pos + convert (fixedbin21, p_arg_len); else do; line_len = index (substr (p_arg_data, 1), byte (10)); line_start = line_len; do while (line_len > 0); queue.header.fetch_file_pos = queue.header.fetch_file_pos + 1; line_len = index (substr (p_arg_data, line_start + 1), byte (10)); line_start = line_start + line_len; end; end; /* Prod PC:BFT for another chunk */ call execute_pc_bft (null, 0, bft_minor_$send_data, mcb_ptr, code); if code ^= 0 then return; end receive_data; /* */ /* *** Procedure: receive_eof - Internal proc for bft_main_ *** */ receive_eof: proc (); /* PROCEDURE FUNCTION This routine performs the proper cleanup after the local machine receives an end of file. */ /* NOTES */ /* PARAMETERS */ /* MISC VARIABLES */ /* STRUCTURES */ /* INITIALIZATION */ /* MAIN */ /* Clear the flags indicating that a fetch was in progress */ queue.header.fetching.flags.initiated = "0"b; queue.header.fetch_file_pos = 0; /* Close the IOCB and notify completion */ call close_data_file (data_block.receive_iocb_ptr); if queue.header.fetching.flags.notify_sw then call ws_$put_background_message (mcb_ptr, 0, "bft", "Completed transfer of ^a to Multics.", rtrim (queue.header.fetching.multics_path)); /* Try for another fetch */ call initiate_fetch (); end receive_eof; /* */ /* *** Procedure: recover_fetch - Internal proc for bft_main_ *** */ recover_fetch: proc (); /* PROCEDURE FUNCTION The fetch (PC_to_MULTICS) queue is examined for an interrupted request. If one exists, then it is resumed by calling POSITION_FILE_POINTER on PC:BFT to set the continuation mark of the fetch. If there is no interrupted reqest, then the rest of the queue is attempted to be started through initiateing a store. */ /* NOTES No arguments are required as it is automatic. */ /* PARAMETERS */ /* MISC VARIABLES */ dcl code fixed bin (35); dcl message char (128); dcl message_len fixed bin; /* STRUCTURES */ /* INITIALIZATION */ /* MAIN */ /* If there is no current request (ie. interrupted) then initiate a new fetch */ if ^queue.header.fetching.initiated then do; call initiate_fetch (); return; end; /* Open the file */ call open_receive_data_file (rtrim (queue.header.fetching.multics_path), "1"b, code); if code ^= 0 then do; queue.header.fetching.flags.initiated = "0"b; queue.header.fetch_file_pos = 0; call ws_$put_background_message (mcb_ptr, code, "bft", "Opening ^a.", rtrim (queue.header.fetching.multics_path)); call initiate_fetch (); return; end; /* If the file_type is "ascii", then position to the next char after last LF */ if ^queue.header.fetching.flags.binary_sw then do; call iox_$position (data_block.receive_iocb_ptr, -1, 0, code); call iox_$position (data_block.receive_iocb_ptr, 0, queue.header.fetch_file_pos, code); if code ^= 0 then do; queue.header.fetching.flags.initiated = "0"b; queue.header.fetch_file_pos = 0; call ws_$put_background_message (mcb_ptr, code, "bft", "Line positioning ^a.", rtrim (queue.header.fetching.multics_path)); call initiate_fetch (); return; end; end; /* Position the source file_pointer on the remote */ message_len = 0; call add_token (message, message_len, rtrim (queue.header.fetching.pc_path)); call add_token (message, message_len, convert (char128var, queue.header.fetch_file_pos)); call add_token (message, message_len, bits_to_chars (4, unspec (queue.header.fetching.flags))); call execute_pc_bft (addr (message), message_len, bft_minor_$position_file_pointer, mcb_ptr, code); if code ^= 0 then return; end recover_fetch; /* */ /* *** Procedure: recover_store - Internal proc for bft_main_ *** */ recover_store: proc (); /* PROCEDURE FUNCTION The store (MULTICS_to_PC) queue is examined for an interrupted request. If one exists, then it is resumed by calling CHECK_FILE_LENGTH on PC:BFT to see where it is to continue from. If there is no interrupted reqest, then the rest of the queue is attempted to be started through initiateing a store. */ /* NOTES No arguments are required as all is automatic. */ /* PARAMETERS */ /* MISC VARIABLES */ dcl code fixed bin (35); dcl message_len fixed bin; /* Length of message */ dcl message char (128); /* STRUCTURES */ /* INITIALIZATION */ /* MAIN */ /* If there is no current request (ie. interrupted) then initiate a new store */ if ^queue.header.storing.initiated then do; call initiate_store (); return; end; /* Otherwise, get the interrupted request back on track */ message_len = 0; call add_token (message, message_len, rtrim (queue.header.storing.pc_path)); call add_token (message, message_len, bits_to_chars (4, unspec (queue.header.storing.flags))); call execute_pc_bft (addr (message), message_len, bft_minor_$check_file_length, mcb_ptr, code); if code ^= 0 then return; end recover_store; /* */ /* *** Procedure: request_connect - Internal proc for bft_main_ *** */ request_connect: proc (p_sender); /* PROCEDURE FUNCTION An application is requesting connection to bft_main_, this is not to be allowed so bft will respond with a REJECT code. */ /* NOTES */ /* PARAMETERS */ dcl p_sender fixed bin parameter; /* Sender of request */ /* MISC VARIABLES */ dcl code fixed bin (35); /* STRUCTURES */ /* INITIALIZATION */ /* MAIN */ call ws_$connect_response (REJECT, p_sender, mcb_ptr, code); if code ^= 0 then do; call ws_$put_background_message (mcb_ptr, code, "bft", "Responding to connect_request from ^d.", p_sender); return; end; end request_connect; /* */ /* *** Procedure: request_disconnect - Internal proc for bft_main_ *** */ request_disconnect: proc (p_sender); /* PROCEDURE FUNCTION This minor capability is not to be called under normal circumstances. It will return and error and terminate BFT if it is called. */ /* NOTES */ /* PARAMETERS */ dcl p_sender fixed bin parameter; /* Capability disconnecting */ /* MISC VARIABLES */ dcl code fixed bin (35); /* STRUCTURES */ /* INITIALIZATION */ /* MAIN */ call cleanup_iocb_switches (); call cleanup_pending_chain (); call ws_$disconnect_response (ACCEPT, p_sender, mcb_ptr, code); if code ^= 0 then do; call ws_$put_background_message (mcb_ptr, code, "bft", "Disconnecting from ^d.", p_sender); return; end; call ws_$destroy_instance (mcb_ptr, (0)); call cleanup_data_block (); end request_disconnect; /* */ /* *** Procedure: response_disconnect - Internal proc for bft_main_ *** */ response_disconnect: proc (); /* PROCEDURE FUNCTION This minor capability is not to be called under normal circumstances. It will return and error and terminate BFT if it is called. */ /* NOTES */ /* PARAMETERS */ /* MISC VARIABLES */ /* STRUCTURES */ /* INITIALIZATION */ /* MAIN */ data_block.flags.shut_down_sw = "1"b; call cleanup_iocb_switches (); call ws_$destroy_instance (mcb_ptr, (0)); call cleanup_data_block (); end response_disconnect; /* */ /* *** Procedure: send_data - Internal proc for bft_main_ *** */ send_data: proc (); /* PROCEDURE FUNCTION This minor capability reads from the file that is specified in the value segment from the byte position that is also stored in the value segment. It updates the byte count, and then sends the data that it if any, to RECEIVE_DATA on the remote machine. If it reads the end of file, then it calls RECEIVE_EOF on the remote machine. */ /* NOTES */ /* PARAMETERS */ /* MISC VARIABLES */ dcl mu_entryname char (32); dcl mu_dirname char (168); dcl line_start fixed bin (21); /* Start position in search for LFs */ dcl line_len fixed bin (21); /* Determines lengths of lines */ dcl bytes_read fixed bin (21); /* Characters from file */ dcl inbuffer char (120) aligned; dcl message char (128); /* Message */ dcl long_info char (100) aligned; dcl code fixed bin (35); dcl short_info char (8) aligned; /* STRUCTURES */ /* INITIALIZATION */ /* MAIN */ /* Verify that this transfer has NOT been cancelled midestream */ if ^queue.header.storing.flags.initiated then do; queue.header.store_file_pos = 0; call close_data_file (data_block.send_iocb_ptr); call expand_pathname_ (rtrim (queue.header.storing.multics_path), mu_dirname, mu_entryname, code); message = "Store request " || rtrim (mu_entryname); message = rtrim (message) || " cancelled in progress."; call execute_pc_bft (addr (message), length (rtrim (message)), bft_minor_$read_error, mcb_ptr, (0)); return; end; /* Read up to the maximum number of bytes from the file*/ call iox_$get_chars (data_block.send_iocb_ptr, addr (inbuffer), BFT_BLOCK_SIZE, bytes_read, code); /* If it is the end of file, then call RECEIVE_EOF on the remote machine */ if code = error_table_$end_of_info then do; call close_data_file (data_block.send_iocb_ptr); call execute_pc_bft (null, 0, bft_minor_$receive_eof, mcb_ptr, code); if code ^= 0 then return; queue.header.storing.flags.initiated = "0"b; queue.header.store_file_pos = 0; call initiate_store (); return; end; /* If some unknown error occurred then generate a read_error */ if code ^= 0 & code ^= error_table_$short_record then do; queue.header.storing.flags.initiated = "0"b; queue.header.store_file_pos = 0; call close_data_file (data_block.send_iocb_ptr); call convert_status_code_ (code, short_info, long_info); message = rtrim (long_info) || " Sending data."; call execute_pc_bft (addr (message), length (rtrim (message)), bft_minor_$read_error, mcb_ptr, (0)); return; end; /* Update the byte / line count */ if queue.header.storing.flags.binary_sw then queue.header.store_file_pos = queue.header.store_file_pos + bytes_read; else do; line_len = index (substr (inbuffer, 1, bytes_read), byte (10)); line_start = line_len + 1; do while (line_len > 0 & line_start <= bytes_read); queue.header.store_file_pos = queue.header.store_file_pos + 1; line_len = index (substr (inbuffer, line_start, bytes_read - line_start), byte (10)); line_start = line_start + line_len; end; end; /* Put the data read into the arg_list and call RECEIVE_DATA on the remote system*/ call execute_pc_bft (addr (inbuffer), convert (fixedbin17, bytes_read), bft_minor_$receive_data, mcb_ptr, code); if code ^= 0 then return; end send_data; /* */ /* *** Procedure: strip_token - Internal proc for bft_main_ *** */ strip_token: proc (p_arg_data, p_token); /* PROCEDURE FUNCTION This is a utility routine designed to remove the first token in in a list that is separated by a delimiter. It returns the token, and the remainder of the list with up to and including the first delimiter stripped off. */ /* NOTES */ /* PARAMETERS */ dcl p_arg_data char (*) parameter; /* Data to extract from */ dcl p_token char (*) var parameter; /* Token extracted */ /* MISC VARIABLES */ dcl delim_position fixed bin; /* length of token */ /* STRUCTURES */ /* INITIALIZATION */ /* MAIN */ delim_position = index (p_arg_data, DELIM_CHAR); if delim_position = 0 then delim_position = length (p_arg_data); p_token = substr (p_arg_data, 1, delim_position - 1); p_arg_data = substr (p_arg_data, delim_position + 1); end strip_token; /* */ /* *** Procedure: terminate_application - Internal proc for bft_main_ *** */ terminate_application: proc (); /* PROCEDURE FUNCTION Terminate BFT - ie. shutdown immediately. */ /* NOTES */ /* PARAMETERS */ /* MISC VARIABLES */ /* STRUCTURES */ /* INITIALIZATION */ /* MAIN */ call bft_shut_down (); end terminate_application; /* */ /* *** Procedure: write_error - Internal proc for bft_main_ *** */ write_error: proc (p_arg_ptr, p_arg_len); /* PROCEDURE FUNCTION This procedure is called by the remote machine to signal an error occurred while the remote machine was receiving a file. The proper cleanup is done and the queues are checked to see if there are any pending requests. */ /* NOTES */ /* PARAMETERS */ dcl p_arg_ptr ptr parameter; /* Message */ dcl p_arg_len fixed bin parameter; /* Message length */ dcl p_arg_data char (p_arg_len) based (p_arg_ptr); /* MISC VARIABLES */ dcl error_string char (128) var; /* Error message sentr */ /* STRUCTURES */ /* INITIALIZATION */ /* MAIN */ /* Extract the error message from the arg_list */ call strip_token (p_arg_data, error_string); call ws_$put_background_message (mcb_ptr, 0, "bft", error_string); /* Remove the current store from the queue */ queue.header.storing.flags.initiated = "0"b; queue.header.store_file_pos = 0; call close_data_file (data_block.send_iocb_ptr); /* Try for another request from the store queue */ call initiate_store (); end write_error; /* */ /* INCLUDE FILES */ %include star_structures; %include access_mode_values; %include iox_modes; %include mowse; %include bft_queue; %include bft_values; end;  bft_queue_.pl1 02/24/88 0851.8rew 02/24/88 0845.0 257418 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1987 * * * *********************************************************** */ bft_queue_: proc (p_q_ptr, p_code); /* format: style4,indattr,ifthen,^indcomtxt,thendo,^indproc,^indblkcom,^indprocbody,initcol1,declareind8,dclind4,struclvlind3,comcol55 */ /* PROGRAM FUNCTION This is a collection of entrypoints which service the queues associated with bft. Entrypoints contained are: add initialize remove terminate Calling bft_queue_ will return a pointer to the current queue. */ /* NOTES */ /****^ HISTORY COMMENTS: 1) change(87-10-06,Flegel), approve(87-10-23,MCR7787), audit(88-01-27,RWaters), install(88-02-24,MR12.2-1028): Created. END HISTORY COMMENTS */ /* PARAMETERS */ dcl p_header bit(1) parameter; /* Display header required */ dcl p_long_sw bit(1) parameter; /* Long display requested */ dcl p_state bit(1) parameter; /* Transfer activity state */ dcl p_id_sw fixed bin parameter; /* 0 = path, 1 = ID */ dcl p_id char (*) parameter; /* Entry ID */ dcl p_direction fixed bin parameter; /* Transfer direction */ dcl p_priority fixed bin parameter; /* Element priority level */ dcl p_e_ptr ptr parameter; /* Queue element pointer */ dcl p_q_ptr ptr parameter; /* Pointer to bft queues */ dcl p_code fixed bin (35) parameter; /* Error code */ /* MISC VARIABLES */ dcl time_string char (20) var; dcl formatted_time char (250); dcl time_stamp fixed bin (71); dcl lock_sw bit(1); /* If the lock has been set */ dcl match_q fixed bin; dcl first_slot fixed bin (35); dcl match_prev_slot fixed bin (35); dcl match_slot fixed bin (35); dcl match_found (2) bit (1); dcl prev_slot fixed bin (35); dcl i fixed bin; dcl mask bit (36) aligned; dcl slot fixed bin (35); /* Array position of queue element */ dcl new_queue bit (1); /* Just created */ /* STRUCTURES */ /* SYSTEM CALLS */ dcl date_time_ entry (fixed bin(71), char(*)); dcl request_id_ entry (fixed bin(71)) returns(char(19)); dcl ioa_ entry() options(variable); dcl match_request_id_ entry (fixed bin (71), char (*)) returns (bit (1) aligned); dcl hcs_$reset_ips_mask entry (bit (36) aligned, bit (36) aligned); dcl hcs_$set_ips_mask entry (bit (36) aligned, bit (36) aligned); dcl set_lock_$unlock entry (bit (36) aligned, fixed bin (35)); dcl set_lock_$lock entry (bit (36) aligned, fixed bin, fixed bin (35)); dcl hcs_$truncate_seg entry (ptr, fixed bin (19), fixed bin (35)); dcl initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35)); dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)); dcl user_info_ entry (char (*), char (*), char (*)); dcl user_info_$homedir entry (char (*)); /* SYSTEM CALL SUPPORT */ dcl error_table_$noentry fixed bin (35) ext static; dcl error_table_$request_id_ambiguous fixed bin (35) ext static; dcl error_table_$bad_conversion fixed bin (35) ext static; dcl error_table_$noalloc fixed bin (35) ext static; dcl sys_info$max_seg_size fixed bin (35) ext static; /* EXTERNAL CALLS */ /* EXTERNAL CALL SUPPORT */ dcl bft_error_table_$store_in_progress fixed bin(35) ext static; dcl bft_error_table_$fetch_in_progress fixed bin(35) ext static; dcl bft_error_table_$invalid_direction fixed bin (35) ext static; dcl bft_error_table_$no_entries fixed bin (35) ext static; dcl bft_error_table_$invalid_queue fixed bin (35) ext static; dcl bft_error_table_$invalid_priority fixed bin (35) ext static; dcl bft_error_table_$no_queue fixed bin (35) ext static; /* BUILTINS */ dcl reverse builtin; dcl substr builtin; dcl verify builtin; dcl index builtin; dcl unspec builtin; dcl size builtin; dcl addr builtin; dcl null builtin; dcl rtrim builtin; /* CONDITIONS */ dcl cleanup condition; /* CONSTANTS */ /* */ /* INITIALIZATION */ p_q_ptr = null; lock_sw = "0"b; call initialize_entry (); on cleanup call set_lock_$unlock (queue.header.lockword, (0)); /* MAIN */ p_q_ptr = null; new_queue = find_bft_queue ("0"b, p_code); if new_queue then p_code = bft_error_table_$no_queue; p_q_ptr = queue_ptr; goto BFT_QUEUE_RETURN; /* */ /* INTERNAL ENTRIES */ /* *** Entry: add - Internal entry for bft_queue_ *** */ add: entry (p_q_ptr, p_e_ptr, p_priority, p_direction, p_code); /* ENTRY FUNCTION Add the provided element to the bft queue. */ /* NOTES */ lock_sw = "1"b; call initialize_entry (); on cleanup call set_lock_$unlock (queue.header.lockword, (0)); /* If element pointer is null, then ignore */ if p_e_ptr = null then goto BFT_QUEUE_RETURN; /* If queue pointer is null, then error */ if queue_ptr = null then do; p_code = bft_error_table_$invalid_queue; goto BFT_QUEUE_RETURN; end; /* If priority level is invalid, then error */ if p_priority < BFT_MIN_PRIORITY | p_priority > BFT_MAX_PRIORITY then do; p_code = bft_error_table_$invalid_priority; goto BFT_QUEUE_RETURN; end; /* If direction is invalid, then error */ if p_direction ^= BFT_PC_to_MULTICS & p_direction ^= BFT_MULTICS_to_PC then do; p_code = bft_error_table_$invalid_direction; goto BFT_QUEUE_RETURN; end; /* Find queue slot */ call find_new_slot (slot, p_code); if p_code ^= 0 then goto BFT_QUEUE_RETURN; /* Copy the element structure into the queue element */ queue.array (slot) = p_e_ptr -> queue_element; queue.array (slot).flags.allocated = "1"b; queue.array (slot).next = 0; /* Chain the new element into the appropriate queue */ call hcs_$set_ips_mask (""b, mask); if p_direction = BFT_PC_to_MULTICS then do; if queue.header.fetch_queue (p_priority).last = 0 then queue.header.fetch_queue (p_priority).first = slot; else queue.array (queue.header.fetch_queue (p_priority).last).next = slot; queue.header.fetch_queue (p_priority).last = slot; end; else do; if queue.header.store_queue (p_priority).last = 0 then queue.header.store_queue (p_priority).first = slot; else queue.array (queue.header.store_queue (p_priority).last).next = slot; queue.header.store_queue (p_priority).last = slot; end; call hcs_$reset_ips_mask (mask, mask); goto BFT_QUEUE_RETURN; /* */ /* *** Entry: cancel - Internal entry for bft_queue_ *** */ cancel: entry (p_q_ptr, p_id, p_id_sw, p_code); /* ENTRY FUNCTION Remove the specified entry from the transfer queue. BFT will then not find the entry and will not transfer the entry. Entries which are currently in transfer, ie. the fetching or storing field of the queue header are initiated and meet the cancellation specs, will merely have their "initiated" bit field turned off. It will then be up to the caller to check this bit field. ID's are either: PATHNAME - absolute or relative, star NOT allowed ENTRY - entryname of request. ID - time stamp ID tagged to the entry. */ /* NOTES */ p_code = 0; lock_sw = "1"b; call initialize_entry (); on cleanup call set_lock_$unlock (queue.header.lockword, (0)); match_slot = 0; match_prev_slot = 0; /* Verify the ID specifier */ if p_id_sw = BFT_TIME_ID then do; if verify (rtrim (p_id), "+-.0123456789") ^= 0 then do; p_code = error_table_$bad_conversion; goto BFT_QUEUE_RETURN; end; end; /* Check the "running" elements, these have priority */ if queue.header.storing.flags.initiated then do; if match_request_type (addr (queue.header.storing), p_id, p_id_sw) then do; queue.header.storing.flags.initiated = "0"b; return; end; end; if queue.header.fetching.flags.initiated then do; if match_request_type (addr (queue.header.fetching), p_id, p_id_sw) then do; queue.header.fetching.flags.initiated = "0"b; return; end; end; /* Hunt down the entry */ match_found (*) = "0"b; do i = BFT_MIN_PRIORITY to BFT_MAX_PRIORITY; first_slot = queue.header.store_queue (i).first; do while (match_entry (first_slot, prev_slot, slot, rtrim (p_id), p_id_sw)); if ^match_found (1) & ^match_found (2) then do; match_found (1) = "1"b; match_slot = slot; match_prev_slot = prev_slot; match_q = i; first_slot = queue.array (slot).next; end; else do; p_code = error_table_$request_id_ambiguous; goto BFT_QUEUE_RETURN; end; end; first_slot = queue.header.fetch_queue (i).first; do while (match_entry (first_slot, prev_slot, slot, rtrim (p_id), p_id_sw)); if ^match_found (1) & ^match_found (2) then do; match_found (2) = "1"b; match_slot = slot; match_prev_slot = prev_slot; match_q = i; first_slot = queue.array (slot).next; end; else do; p_code = error_table_$request_id_ambiguous; goto BFT_QUEUE_RETURN; end; end; end; /* If there was a single match, remove the entry */ if match_found (1) then call remove_entry (queue.header.store_queue (match_q).first, queue.header.store_queue (match_q).last, match_prev_slot, match_slot); else if match_found (2) then call remove_entry (queue.header.fetch_queue (match_q).first, queue.header.fetch_queue (match_q).last, match_prev_slot, match_slot); else do; p_code = error_table_$noentry; goto BFT_QUEUE_RETURN; end; goto BFT_QUEUE_RETURN; /* */ /* *** Entry: display_element - Internal entry for bft_queue_ *** */ display_element: entry (p_e_ptr, p_long_sw, p_direction, p_state, p_header); /* ENTRY FUNCTION Display a queue element. */ /* NOTES */ time_stamp = p_e_ptr -> queue_element.time_id; if ^p_long_sw then do; if p_header then call ioa_ ("Multics Path^30tDirection^40tPC Path^55tID"); call ioa_ ("^a^33t^[->^;<-^]^[*^]^40t^a^55t^a^[ (running)^]", strip_path (p_e_ptr -> queue_element.multics_path, ">"), (p_direction = BFT_MULTICS_to_PC), p_e_ptr -> queue_element.flags.binary_sw, strip_path (p_e_ptr -> queue_element.pc_path, "\"), substr (request_id_ (time_stamp), 7, 8), p_state); end; else do; time_string = request_id_ (time_stamp); call date_time_ (time_stamp, formatted_time); call ioa_ ( "Source:^21t^[^a^s^;^s^a^]^/Destination:^21t^[^a^s^;^s^a^]" || "^/Request ID:^21t^a^/Time queued:^21t^a" || "^/State:^21t^[running^;unprocessed^]^/Notify:^21t^[yes^;no^]" || "^/File type:^21t^[binary^;ascii^]", (p_direction = BFT_PC_to_MULTICS), p_e_ptr -> queue_element.pc_path, p_e_ptr -> queue_element.multics_path, (p_direction = BFT_PC_to_MULTICS), p_e_ptr -> queue_element.multics_path, p_e_ptr -> queue_element.pc_path, time_string, rtrim (formatted_time), p_state, p_e_ptr -> queue_element.flags.notify_sw, p_e_ptr -> queue_element.flags.binary_sw); end; return; /* */ /* *** Entry: initiate - Internal entry for bft_queue_ *** */ initiate: entry (p_q_ptr, p_code); /* ENTRY FUNCTION This entry will initiate the bft queue segment. If the segment does not already exist it will be created and formatted. */ /* NOTES */ p_q_ptr = null; lock_sw = "0"b; call initialize_entry (); on cleanup call set_lock_$unlock (queue.header.lockword, (0)); /* Find the queue segment */ new_queue = find_bft_queue ("1"b, p_code); if p_code ^= 0 then goto BFT_QUEUE_RETURN; /* Initialize the header field */ if new_queue then call initialize_queue_header (); p_q_ptr = queue_ptr; goto BFT_QUEUE_RETURN; /* */ /* *** Entry: remove - Internal entry for bft_queue_ *** */ remove: entry (p_q_ptr, p_direction, p_code); /* ENTRY FUNCTION Move the next element from the specified queue (PC -> Multics or Multics -> PC) to the appropriate "in progress" element in the header. The highest priority (1,2,3,4) is removed from the queue. */ /* NOTES */ lock_sw = "1"b; call initialize_entry (); on cleanup call set_lock_$unlock (queue.header.lockword, (0)); /* If the queue ptr is null, then error */ if queue_ptr = null then do; p_code = bft_error_table_$invalid_queue; goto BFT_QUEUE_RETURN; end; /* If the transfer in the specified direction is not complete, then error * Might as well verify the direction at the same time */ if p_direction = BFT_PC_to_MULTICS then do; if queue.header.fetching.flags.initiated then do; p_code = bft_error_table_$fetch_in_progress; goto BFT_QUEUE_RETURN; end; end; else if p_direction = BFT_MULTICS_to_PC then do; if queue.header.storing.flags.initiated then do; p_code = bft_error_table_$store_in_progress; goto BFT_QUEUE_RETURN; end; end; else do; p_code = bft_error_table_$invalid_direction; goto BFT_QUEUE_RETURN; end; /* Find the next element slot */ call find_old_slot (p_direction, slot, p_code); if p_code ^= 0 | slot = 0 then do; if p_code = 0 then p_code = bft_error_table_$no_entries; goto BFT_QUEUE_RETURN; end; /* Move the element out the callers structure */ queue.array (slot).flags.initiated = "1"b; if p_direction = BFT_PC_to_MULTICS then do; queue.header.fetch_file_pos = 0; queue.header.fetching = queue.array (slot); end; else do; queue.header.store_file_pos = 0; queue.header.storing = queue.array (slot); end; call free_old_slot (slot, p_code); if p_code ^= 0 then goto BFT_QUEUE_RETURN; goto BFT_QUEUE_RETURN; /* */ /* GLOBAL LABEL ENTRY */ /* *** Label: BFT_QUEUE_RETURN - Internal label for bft_queue_ *** */ /* LABEL FUNCTION This label is to be used to return from the bft_queue_ entry points to the caller of that entry. It serves to unlock the lockword that exists within the queue segment. */ BFT_QUEUE_RETURN: if lock_sw then call set_lock_$unlock (queue.header.lockword, (0)); return; /* */ /* INTERNAL PROCEDURES */ /* *** Procedure: allocate_slot - Internal proc for bft_queue_ *** */ allocate_slot: proc (p_code); /* PROCEDURE FUNCTION Allocate another element slot at the end of the segment. */ /* NOTES */ /* PARAMETERS */ dcl p_code fixed bin (35) parameter; /* Error code */ /* MISC VARIABLES */ dcl mask bit(36) aligned; dcl new_slot fixed bin (35); /* STRUCTURES */ /* INITIALIZATION */ p_code = 0; /* MAIN */ if size (queue) + size (queue_element) > sys_info$max_seg_size then do; p_code = error_table_$noalloc; return; end; /* Increase the queue size */ new_slot = queue.header.segment_size + 1; call initialize_element (addr (queue.array (new_slot))); call hcs_$set_ips_mask (""b, mask); queue.array (new_slot).next = queue.header.free_list; queue.header.free_list = new_slot; queue.header.segment_size = new_slot; call hcs_$reset_ips_mask (mask, mask); end allocate_slot; /* */ /* *** Procedure: find_bft_queue - Internal proc for bft_queue_ *** */ find_bft_queue: proc (p_create_sw, p_code) returns (bit (1)); /* PROCEDURE FUNCTION Get a pointer to the bft queue segment. */ /* NOTES */ /* PARAMETERS */ dcl p_create_sw bit (1) parameter; /* True if to be created */ dcl p_code fixed bin (35) parameter; /* Error code */ /* MISC VARIABLES */ dcl code fixed bin (35); dcl name char (168); /* Queue segment name */ dcl home_path char (64); /* Home directory */ dcl account_id char (32); dcl project_id char (9); dcl person_id char (22); /* STRUCTURES */ /* INITIALIZATION */ p_code = 0; /* MAIN */ call user_info_$homedir (home_path); call user_info_ (person_id, project_id, account_id); name = rtrim (person_id) || ".bft"; /* If the segment is to be created, create it if it doesn't exist. */ if p_create_sw then do; call hcs_$make_seg (home_path, name, "", RW_ACCESS_BIN, queue_ptr, code); return ((code = 0)); end; /* Else do not attempt to create the queue, just look for it */ else do; call initiate_file_ (home_path, name, unspec (RW_ACCESS_BIN), queue_ptr, (0), code); return ((code ^= 0)); end; end find_bft_queue; /* */ /* *** Procedure: find_old_slot - Internal proc for bft_queue_ *** */ find_old_slot: proc (p_direction, p_slot, p_code); /* PROCEDURE FUNCTION Find the next element of highest priority in the specified direction. */ /* NOTES The entry is removed from the specified queue but is not released to the free list. */ /* PARAMETERS */ dcl p_direction fixed bin parameter; /* Direction of element */ dcl p_slot fixed bin (35) parameter; /* Found slot */ dcl p_code fixed bin (35) parameter; /* Error code */ /* MISC VARIABLES */ dcl mask bit(36) aligned; dcl i fixed bin; /* STRUCTURES */ /* INITIALIZATION */ p_code = 0; p_slot = 0; /* MAIN */ do i = 1 to 4; if p_direction = BFT_PC_to_MULTICS then do; if queue.header.fetch_queue (i).first ^= 0 then do; call hcs_$set_ips_mask (""b, mask); p_slot = queue.header.fetch_queue (i).first; queue.header.fetch_queue (i).first = queue.array (p_slot).next; if queue.header.fetch_queue (i).first = 0 then queue.header.fetch_queue (i).last = 0; call hcs_$reset_ips_mask (mask, mask); return; end; end; else do; if queue.header.store_queue (i).first ^= 0 then do; call hcs_$set_ips_mask (""b, mask); p_slot = queue.header.store_queue (i).first; queue.header.store_queue (i).first = queue.array (p_slot).next; if queue.header.store_queue (i).first = 0 then queue.header.store_queue (i).last = 0; call hcs_$reset_ips_mask (mask, mask); return; end; end; end; /* Element was not found, so it's an error */ p_code = bft_error_table_$no_entries; end find_old_slot; /* */ /* *** Procedure: find_new_slot - Internal proc for bft_queue_ *** */ find_new_slot: proc (p_slot, p_code); /* PROCEDURE FUNCTION Find an empty position in the queue element array */ /* NOTES */ /* PARAMETERS */ dcl p_slot fixed bin (35) parameter; /* Found slot in array */ dcl p_code fixed bin (35) parameter; /* Error code */ /* MISC VARIABLES */ dcl mask bit(36) aligned; /* STRUCTURES */ /* INITIALIZATION */ p_code = 0; p_slot = 0; /* MAIN */ if queue.header.free_list = 0 then do; call allocate_slot (p_code); if p_code ^= 0 then return; end; call hcs_$set_ips_mask (""b, mask); p_slot = queue.header.free_list; queue.header.free_list = queue.array (queue.header.free_list).next; queue.array (p_slot).next = 0; call hcs_$reset_ips_mask (mask, mask); end find_new_slot; /* */ /* *** Procedure: free_old_slot - Internal proc for bft_queue_ *** */ free_old_slot: proc (p_slot, p_code); /* PROCEDURE FUNCTION Place the specified slot into the free list. Check if a page of the queue segment can be released. */ /* NOTES */ /* PARAMETERS */ dcl p_slot fixed bin (35) parameter; /* Slot to be freed */ dcl p_code fixed bin (35) parameter; /* Error code */ /* MISC VARIABLES */ dcl mask bit(36) aligned; /* STRUCTURES */ /* INITIALIZATION */ p_code = 0; /* MAIN */ /* Add the element to the free list */ call initialize_element (addr (queue.array (p_slot))); call hcs_$set_ips_mask (""b, mask); queue.array (p_slot).next = queue.header.free_list; queue.header.free_list = p_slot; call hcs_$reset_ips_mask (mask, mask); /* If the element is the last element in the segment, shrink the segment */ if p_slot = queue.header.segment_size then do; call free_seg (p_code); if p_code ^= 0 then return; end; end free_old_slot; /* */ /* *** Procedure: free_seg - Internal proc for bft_queue_ *** */ free_seg: proc (p_code); /* PROCEDURE FUNCTION Reduce the segment size of the queue, truncate the segment to the nearest page. */ /* NOTES */ /* PARAMETERS */ dcl p_code fixed bin (35) parameter; /* Error code */ /* MISC VARIABLES */ dcl mask bit(36) aligned; dcl word_count fixed bin (19); /* New segment length */ dcl previous_slot fixed bin (35); /* Slot before current search */ dcl free_slot fixed bin (35); /* Slot to free */ dcl slot fixed bin (35); /* Index slot */ dcl last_alloc fixed bin (35); /* Last allocated element */ dcl total_free fixed bin (35); /* Elements to free */ /* STRUCTURES */ /* INITIALIZATION */ p_code = 0; /* MAIN */ /* Find last NON-allocated element */ total_free = 0; last_alloc = queue.header.segment_size; do while (^queue.array (last_alloc).flags.allocated & last_alloc > 0); total_free = total_free + 1; last_alloc = last_alloc - 1; end; /* Remove the slots to be released from the free list */ previous_slot = 0; slot = queue.header.free_list; do while (slot ^= 0); if slot > last_alloc then do; call hcs_$set_ips_mask (""b, mask); free_slot = slot; if previous_slot = 0 then do; /* First in list */ slot = queue.array (free_slot).next; queue.header.free_list = slot; end; else do; /* Middle of list */ queue.array (previous_slot).next = queue.array (free_slot).next; previous_slot = slot; slot = queue.array (slot).next; end; call hcs_$reset_ips_mask (mask, mask); call initialize_element (addr (queue.array (free_slot))); end; else do; previous_slot = slot; slot = queue.array (slot).next; end; queue.header.segment_size = last_alloc; word_count = size (queue_header) + (last_alloc * size (queue_element)); call hcs_$truncate_seg (queue_ptr, word_count, p_code); if p_code ^= 0 then return; end; end free_seg; /* */ /* *** Procedure: initialize_element - Internal proc for bft_queue_ *** */ initialize_element: proc (p_e_ptr); /* PROCEDURE FUNCTION Initialize the element structure. */ /* NOTES */ /* PARAMETERS */ dcl p_e_ptr ptr parameter; /* Element to be initialized */ /* MISC VARIABLES */ /* STRUCTURES */ /* INITIALIZATION */ /* MAIN */ p_e_ptr -> queue_element.next = 0; p_e_ptr -> queue_element.multics_path = ""; p_e_ptr -> queue_element.pc_path = ""; p_e_ptr -> queue_element.time_id = 0; p_e_ptr -> queue_element.flags.allocated = "0"b; p_e_ptr -> queue_element.flags.binary_sw = "0"b; p_e_ptr -> queue_element.flags.pad = ""b; p_e_ptr -> queue_element.flags.mbz = ""b; end initialize_element; /* */ /* *** Procedure: initialize_entry - Internal proc for bft_queue_ *** */ initialize_entry: proc (); /* PROCEDURE FUNCTION Initialize entrypoint variables. */ /* MAIN */ p_code = 0; queue_ptr = p_q_ptr; /* Lock out other accesses to the queue segment */ if lock_sw then call set_lock_$lock (queue.header.lockword, BFT_QUEUE_WAIT_TIME, p_code); end initialize_entry; /* */ /* *** Procedure: initialize_queue_header - Internal proc for bft_queue_ *** */ initialize_queue_header: proc (); /* PROCEDURE FUNCTION Initialize the fields of the queue header to casue the queue to have 0 elements. */ /* NOTES */ /* PARAMETERS */ /* MISC VARIABLES */ /* STRUCTURES */ /* INITIALIZATION */ /* MAIN */ queue.header.version = "VERSION1"; queue.header.lockword = ""b; queue.header.store_queue (*).last = 0; queue.header.store_queue (*).first = 0; queue.header.store_queue (*).flags.pad = "0"b; queue.header.fetch_queue (*).last = 0; queue.header.fetch_queue (*).first = 0; queue.header.fetch_queue (*).flags.pad = "0"b; queue.header.storing.flags.initiated = "0"b; queue.header.store_file_pos = 0; queue.header.fetching.flags.initiated = "0"b; queue.header.fetch_file_pos = 0; queue.header.free_list = 0; queue.header.segment_size = 0; end initialize_queue_header; /* */ /* *** Procedure: match_entry - Internal proc for bft_queue_ *** */ match_entry: proc (p_start_slot, p_prev_slot, p_slot, p_id, p_id_sw) returns (bit (1)); /* PROCEDURE FUNCTION Find a match in the chain specified by start_slot. */ /* NOTES */ /* PARAMETERS */ dcl p_id_sw fixed bin parameter; /* A time ID */ dcl p_id char (*) parameter; /* Match ID */ dcl p_start_slot fixed bin (35) parameter; /* Start of queue list */ dcl p_prev_slot fixed bin (35) parameter; /* Previous slot to matched entry */ dcl p_slot fixed bin (35) parameter; /* Slot matched */ /* MISC VARIABLES */ /* STRUCTURES */ /* INITIALIZATION */ /* MAIN */ p_prev_slot = 0; p_slot = p_start_slot; do while (p_slot ^= 0); if match_request_type (addr (queue.array (p_slot)), p_id, p_id_sw) then return ("1"b); p_prev_slot = p_slot; p_slot = queue.array (p_prev_slot).next; end; return ("0"b); end match_entry; /* */ /* *** Procedure: match_request_type - Internal proc for bft_queue_ *** */ match_request_type: proc (p_e_ptr, p_id, p_id_sw) returns (bit(1)); /* PROCEDURE FUNCTION Verify the element passed against the ID and ID type provided. */ /* NOTES */ /* PARAMETERS */ dcl p_e_ptr ptr parameter; /* Element to match */ dcl p_id char (*) parameter; /* Match ID */ dcl p_id_sw fixed bin parameter; /* Type of id */ /* MISC VARIABLES */ /* STRUCTURES */ /* INITIALIZATION */ /* MAIN */ if p_id_sw = BFT_TIME_ID then do; if match_request_id_ (p_e_ptr -> queue_element.time_id, p_id) then return ("1"b); end; else if p_id_sw = BFT_PATH_ID then do; if rtrim (p_id) = rtrim (p_e_ptr -> queue_element.multics_path) | rtrim (p_id) = rtrim (p_e_ptr -> queue_element.pc_path) then return ("1"b); end; else do; if rtrim (p_id) = strip_path (rtrim (p_e_ptr -> queue_element.multics_path), ">") then return ("1"b); if rtrim (p_id) = strip_path (rtrim (p_e_ptr -> queue_element.pc_path), "\") then return ("1"b); end; return ("0"b); end match_request_type; /* */ /* *** Procedure: remove_entry - Internal proc for bft_queue_ *** */ remove_entry: proc (p_start_slot, p_last_slot, p_prev_slot, p_slot); /* PROCEDURE FUNCTION Remove slot from the queue. */ /* NOTES */ /* PARAMETERS */ dcl p_last_slot fixed bin (35) parameter; /* Last entry in list */ dcl p_start_slot fixed bin (35) parameter; /* Start of list */ dcl p_prev_slot fixed bin (35) parameter; /* Predecessor to slot */ dcl p_slot fixed bin (35) parameter; /* Slot to be removed */ /* MISC VARIABLES */ /* STRUCTURES */ /* INITIALIZATION */ /* MAIN */ if queue.array (p_slot).next = 0 then p_last_slot = p_prev_slot; if p_prev_slot = 0 then p_start_slot = queue.array (p_slot).next; else queue.array (p_prev_slot).next = queue.array (p_slot).next; call free_old_slot (p_slot, (0)); end remove_entry; /* */ /* *** Procedure: strip_path - Internal proc for bft_queue_ *** */ strip_path: proc (p_path, p_separator) returns (char (*)); /* PROCEDURE FUNCTION Strip of the entryname from the given path, given the directory spearator. */ /* NOTES */ /* PARAMETERS */ dcl p_path char (*) parameter; /* Path to be stripped */ dcl p_separator char (1) parameter; /* Directory separator */ /* MISC VARIABLES */ dcl indx fixed bin (21); /* Revers entry index */ /* STRUCTURES */ /* INITIALIZATION */ /* MAIN */ indx = index (reverse (rtrim (p_path)), p_separator) - 1; if indx < 0 then return (p_path); return (reverse (substr (reverse (rtrim (p_path)), 1, indx))); end strip_path; /* */ /* INCLUDE FILES */ %include bft_values; %include access_mode_values; %include bft_queue; end; 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