cv_bcd_to_ascii_.alm 11/19/82 1409.3rew 11/19/82 0949.6 25272 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** " Modified by RH Morrison 6/22/76 name cv_bcd_to_ascii_ entry cv_bcd_to_ascii_ cv_bcd_to_ascii_: push eppbp ap|2,* bp -> input data eppbp bp|0,* eppap ap|4,* ap -> output data eppap ap|0,* eax7 80 init total character count eax4 0 init ascii word offset eax3 0 init bcd word offset eax2 4 init ascii char count eax1 6 init bcd char count ldq bp|0 init btemp stq btemp continue: cmpx2 =0,du check for full ascii word tnz moreascii need more ascii characters sta ap|0,4 store full ascii word in output string adx4 =1,du increment ascii word count eax2 4 re-init ascii character count cmpx7 =0,du check for completion tze fin moreascii: cmpx1 =0,du check for used bcd word tnz morebcd need more bcd characters adx3 =1,du increment bcd word count eax1 6 re-init bcd character count ldq bp|0,3 get next full bcd word stq btemp save it morebcd: ldq btemp load current bcd word qlr 6 make next bcd char leftmost stq btemp save for next time anq =o000077,dl isolate current character ldq btable,ql load ascii character into q lls 9 concatenate in a sbx2 =1,du decrement ascii char count sbx1 =1,du decrement bcd char count sbx7 =1,du decrement total character count tra continue convert another character fin: return btable: vfd a9/0,27/0 vfd a9/1,27/0 vfd a9/2,27/0 vfd a9/3,27/0 vfd a9/4,27/0 vfd a9/5,27/0 vfd a9/6,27/0 vfd a9/7,27/0 vfd a9/8,27/0 vfd a9/9,27/0 vfd a9/[,27/0 vfd a9/#,27/0 vfd a9/@,27/0 vfd a9/:,27/0 vfd a9/>,27/0 vfd a9/?,27/0 vfd a9/ ,27/0 vfd a9/a,27/0 vfd a9/b,27/0 vfd a9/c,27/0 vfd a9/d,27/0 vfd a9/e,27/0 vfd a9/f,27/0 vfd a9/g,27/0 vfd a9/h,27/0 vfd a9/i,27/0 vfd a9/&,27/0 vfd a9/.,27/0 vfd a9/],27/0 vfd a9/(,27/0 vfd a9/<,27/0 vfd a9/\,27/0 vfd a9/^,27/0 vfd a9/j,27/0 vfd a9/k,27/0 vfd a9/l,27/0 vfd a9/m,27/0 vfd a9/n,27/0 vfd a9/o,27/0 vfd a9/p,27/0 vfd a9/q,27/0 vfd a9/r,27/0 vfd a9/-,27/0 vfd a9/$,27/0 vfd a9/*,27/0 vfd a9/),27/0 vfd o9/073,27/0 "; vfd a9/',27/0 vfd a9/+,27/0 vfd a9//,27/0 vfd a9/s,27/0 vfd a9/t,27/0 vfd a9/u,27/0 vfd a9/v,27/0 vfd a9/w,27/0 vfd a9/x,27/0 vfd a9/y,27/0 vfd a9/z,27/0 vfd a9/_,27/0 "<- vfd o9/054,27/0 ", vfd a9/%,27/0 vfd a9/=,27/0 vfd a9/",27/0 vfd a9/!,27/0 temp btemp end  cv_bin_to_ascii_.pl1 11/19/82 1409.3rew 11/19/82 0929.1 51192 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* ***************************************************************************** * * * Modified by RH Morrison 6/22/76 * * * ***************************************************************************** */ cv_bin_to_ascii_: proc (a_input_ptr, a_output_ptr, a_code); /* DECLARATIONS */ /* ------------ */ /* fixed bin */ dcl ( direction, /* direction of 1/2 interval search */ i, /* loop index */ interval, /* interval of 1/2 interval search */ j, /* loop index */ search_index /* index from search into binary table */ ) fixed bin aligned; dcl ( a_code /* error code */ ) fixed bin (35) aligned; /* pointers */ dcl ( a_input_ptr, /* pointer to input bit string (argument) */ a_output_ptr, /* pointer to output character string (argument) */ bit_ptr, /* pointer to input bit string (internal) */ letter_ptr /* pointer to output bit string (argument) */ ) ptr aligned; /* bit strings */ dcl ( bin_char_not_found /* ON until a binary table match is found */ ) bit (1) aligned; dcl bin_table (0: 63) bit (12) aligned init ( "000000000000"b, "000000000001"b, "000000000010"b, "000000000100"b, "000000000110"b, "000000001000"b, "000000001010"b, "000000010000"b, "000000010010"b, "000000100000"b, "000000100010"b, "000001000000"b, "000001000010"b, "000010000000"b, "000010000010"b, "000100000000"b, "001000000000"b, "001000000001"b, "001000000010"b, "001000000100"b, "001000000110"b, "001000001000"b, "001000001010"b, "001000010000"b, "001000010010"b, "001000100000"b, "001000100010"b, "001001000000"b, "001001000010"b, "001010000000"b, "001010000010"b, "001100000000"b, "010000000000"b, "010000000001"b, "010000000010"b, "010000000100"b, "010000000110"b, "010000001000"b, "010000001010"b, "010000010000"b, "010000010010"b, "010000100000"b, "010000100010"b, "010001000000"b, "010001000010"b, "010010000000"b, "010100000000"b, "011000000000"b, "100000000000"b, "100000000001"b, "100000000010"b, "100000000100"b, "100000000110"b, "100000001000"b, "100000001010"b, "100000010000"b, "100000010010"b, "100000100000"b, "100000100010"b, "100001000000"b, "100001000010"b, "100010000000"b, "100100000000"b, "101000000000"b ); /* character strings */ dcl letter_table (0: 63) char (1) aligned init ( " ", "9", "8", "7", "?", "6", ">", "5", ":", "4", "@", "3", "#", "2", "[", "1", "0", "z", "y", "x", "!", "w", """", "v", "=", "u", "%", "t", ",", "s", "_", /* left arrow */ "/", "-", "r", "q", "p", "'", "o", ";", "n", ")", "m", "*", "l", "$", "k", "j", "^", /* up arrow */ "&", "i", "h", "g", "\", "f", "<", "e", "(", "d", "]", "c", ".", "b", "a", "+" ); /* built in functions */ dcl ( divide ) builtin; /* masks */ dcl 1 columns aligned based (bit_ptr), /* card columns */ 2 bin_char (0:79) bit (12) unaligned; /* binary characters on card */ dcl 1 output aligned based (letter_ptr), /* output character string */ 2 letter (0:79) char (1) unaligned; /* each output character */ dcl output_letters char (80) aligned based (letter_ptr); /* for zapping characters in case of error */ /* */ a_code = 0; /* initialize returned error code */ bit_ptr = a_input_ptr; /* copy in 2 pointer arguments */ letter_ptr = a_output_ptr; do i = 0 to 79; /* perform conversion */ if bin_char (i) = "0"b /* make quick check for blank */ then letter (i) = " "; else /* binary character is not a blank */ do; direction = 1; /* initialize 1/2 interval search variables */ interval = 32; search_index = 0; bin_char_not_found = "1"b; do j = 1 to 6 while (bin_char_not_found); /* perform search */ search_index = search_index + direction * interval; /* set index */ if bin_char (i) = bin_table (search_index) /* match found */ then do; letter (i) = letter_table (search_index); /* set output letter */ bin_char_not_found = "0"b; /* turn off search flag */ end; else /* match not found */ do; /* increment 1/2 interval search variables */ if bin_char (i) > bin_table (search_index) then direction = 1; else direction = -1; interval = divide (interval, 2, 17, 0); end; end; if bin_char_not_found /* illegal binary character */ then go to ERROR; end; end; return; ERROR: a_code = 1; /* return error code */ output_letters = " "; /* zap output string */ return; end cv_bin_to_ascii_;  cv_bin_to_bcd_.pl1 11/19/82 1409.3rew 11/19/82 0929.2 63072 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* ****************************************************************************** * * * Modified by RH Morrison 6/28/76 * * * ****************************************************************************** */ cv_bin_to_bcd_: proc (a_input_ptr, a_output_ptr, a_code); /* DECLARATIONS */ /* ------------ */ /* fixed bin */ dcl ( direction, /* direction of half-interval search */ i, /* loop index */ interval, /* increment for half-interval search */ j, /* loop index */ search_index /* index into binary table */ ) fixed bin aligned; dcl ( a_code /* error code (argument) */ ) fixed bin (35) aligned; /* pointers */ dcl ( a_input_ptr, /* pointer to binary data (argument) */ a_output_ptr, /* pointer to bcd output (argument) */ bcd_ptr, /* pointer to internal bcd */ input_ptr, /* pointer to binary data (internal) */ output_ptr /* pointer to bcd output (internal) */ ) ptr aligned; /* bit strings */ dcl ( bin_char_not_found /* ON until bin_table search is successful */ ) bit (1) aligned; /* built in functions */ dcl ( addr, divide ) builtin; /* structures */ dcl 1 bcd_chars aligned, /* bcd output structure */ 2 bcd_char (0:79) bit (6) unaligned; dcl bcd_table (0:63) bit (6) aligned internal static init ( "010000"b, /* " " */ "001001"b, /* "9" */ "001000"b, /* "8" */ "000111"b, /* "7" */ "001111"b, /* "?" */ "000110"b, /* "6" */ "001110"b, /* ">" */ "000101"b, /* "5" */ "001101"b, /* ":" */ "000100"b, /* "4" */ "001100"b, /* "@" */ "000011"b, /* "3" */ "001011"b, /* "#" */ "000010"b, /* "2" */ "001010"b, /* "[" */ "000001"b, /* "1" */ "000000"b, /* "0" */ "111001"b, /* "z" */ "111000"b, /* "y" */ "110111"b, /* "x" */ "111111"b, /* "!" */ "110110"b, /* "w" */ "111110"b, /* """ */ "110101"b, /* "v" */ "111101"b, /* "=" */ "110100"b, /* "u" */ "111100"b, /* "%" */ "110011"b, /* "t" */ "111011"b, /* "," */ "110010"b, /* "s" */ "111010"b, /* "<-" */ "110001"b, /* "/" */ "101010"b, /* "-" */ "101001"b, /* "r" */ "101000"b, /* "q" */ "100111"b, /* "p" */ "101111"b, /* "'" */ "100110"b, /* "o" */ "101110"b, /* ";" */ "100101"b, /* "n" */ "101101"b, /* ")" */ "100100"b, /* "m" */ "101100"b, /* "*" */ "100011"b, /* "l" */ "101011"b, /* "$" */ "100010"b, /* "k" */ "100001"b, /* "j" */ "100000"b, /* "^" */ "011010"b, /* "&" */ "011001"b, /* "i" */ "011000"b, /* "h" */ "010111"b, /* "g" */ "011111"b, /* "\" */ "010110"b, /* "f" */ "011110"b, /* "<" */ "010101"b, /* "e" */ "011101"b, /* "(" */ "010100"b, /* "d" */ "011100"b, /* "]" */ "010011"b, /* "c" */ "011011"b, /* "." */ "010010"b, /* "b" */ "010001"b, /* "a" */ "110000"b /* "+" */ ); dcl bin_table (0: 63) bit (12) aligned internal static init ( "000000000000"b, "000000000001"b, "000000000010"b, "000000000100"b, "000000000110"b, "000000001000"b, "000000001010"b, "000000010000"b, "000000010010"b, "000000100000"b, "000000100010"b, "000001000000"b, "000001000010"b, "000010000000"b, "000010000010"b, "000100000000"b, "001000000000"b, "001000000001"b, "001000000010"b, "001000000100"b, "001000000110"b, "001000001000"b, "001000001010"b, "001000010000"b, "001000010010"b, "001000100000"b, "001000100010"b, "001001000000"b, "001001000010"b, "001010000000"b, "001010000010"b, "001100000000"b, "010000000000"b, "010000000001"b, "010000000010"b, "010000000100"b, "010000000110"b, "010000001000"b, "010000001010"b, "010000010000"b, "010000010010"b, "010000100000"b, "010000100010"b, "010001000000"b, "010001000010"b, "010010000000"b, "010100000000"b, "011000000000"b, "100000000000"b, "100000000001"b, "100000000010"b, "100000000100"b, "100000000110"b, "100000001000"b, "100000001010"b, "100000010000"b, "100000010010"b, "100000100000"b, "100000100010"b, "100001000000"b, "100001000010"b, "100010000000"b, "100100000000"b, "101000000000"b ); /* masks */ dcl bcd_output bit (480) unaligned based (bcd_ptr); /* mask for copying bcd as a whole */ dcl bin_char (0:79) bit (12) unaligned based (input_ptr); /* mask for looking at binary input */ /* */ /* copy in arguments */ input_ptr = a_input_ptr; output_ptr = a_output_ptr; bcd_ptr = addr (bcd_chars); /* pointer to internal bcd */ /* perform conversion */ do i = 0 to 79; /* convert 80 characters */ if bin_char (i) = "0"b /* make quick check for blank */ then bcd_char (i) = "010000"b; else /* not binary blank */ do; direction = 1; /* set up half-interval search */ interval = 32; search_index = 0; bin_char_not_found = "1"b; do j = 1 to 6 while (bin_char_not_found); search_index = search_index + direction*interval; /* compute index into binary table */ if bin_char (i) = bin_table (search_index) /* match found */ then do; bcd_char (i) = bcd_table (search_index); /* set bcd character */ bin_char_not_found = "0"b; end; else /* not a match */ do; if bin_char (i) > bin_table (search_index) /* set direction of search increment */ then direction = 1; else direction = -1; interval = divide (interval, 2, 17, 0); /* set search increment magnitude */ end; end; if bin_char_not_found /* no match found */ then go to ERROR; /* illegal binary character */ end; end; output_ptr -> bcd_output = bcd_output; /* return output string */ a_code = 0; /* and "successful" code */ return; /* and your own self */ ERROR: a_code = 1; /* return "unsuccessful" code */ return; end cv_bin_to_bcd_;  gcos_convert_time_.pl1 11/19/82 1409.3rew 11/19/82 0929.3 39213 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ gcos_convert_time_: proc (a_gcos_time, a_deferral, a_code); /* DECLARATIONS */ /* ------------ */ /* fixed bin */ /* ----- --- */ dcl ( hundredth_length, /* length of string representing converted hundredths */ minutes, seconds ) fixed bin aligned; dcl ( a_code, /* error code (argument) */ code, /* error code (internal) */ fixed_bin_hundredths /* converted hundredths of a second */ ) fixed bin (35) aligned; dcl ( a_deferral, /* multics deferral time (argument) */ deferral /* multics deferral time (internal) */ ) fixed bin (71) aligned; /* character strings */ /* --------- ------- */ dcl ( ascii_hundredths /* 100ths of an hr in ascii */ ) char (4) aligned; dcl ( converted_hundredths /* ascii 100ths converted to hh:mm */ ) char (8) aligned; dcl ( a_gcos_time, /* gcos date-time to be converted (argument) */ gcos_time /* gcos date-time to be converted (internal) */ ) char (16) aligned; dcl ( multics_time /* ascii multics time */ ) char (32) aligned; /* built in */ /* ----- -- */ dcl ( divide, fixed, substr ) builtin; /* external entries */ /* -------- ------- */ dcl convert_date_to_binary_ ext entry (char (*) aligned, fixed bin (71) aligned, fixed bin (35) aligned); dcl cv_dec_check_ ext entry (char (*) aligned, fixed bin (35) aligned) returns (fixed bin (35) aligned); dcl ioa_$rsnnl ext entry options (variable); /* */ gcos_time = a_gcos_time; /* copy in argument */ code = 0; /* initialize error code */ deferral = 0; /* initialize deferral field */ /* convert MMDDYY to MM/DD/YY */ multics_time = ""; /* blank out time field */ substr (multics_time, 1, 2) = substr (gcos_time, 1, 2); /* month */ substr (multics_time, 4, 2) = substr (gcos_time, 3, 2); /* day */ substr (multics_time, 7, 2) = substr (gcos_time, 5, 2); /* year */ substr (multics_time, 3, 1), substr (multics_time, 6, 1) = "/"; /* put slashes between fields */ /* pick up HH */ substr (multics_time, 10, 2) = substr (gcos_time, 8, 2); substr (multics_time, 12, 1) = ":"; /* pick up MM or convert XX to MM */ if substr (gcos_time, 10, 1) = ":" /* gcos time given in minutes */ then do; substr (multics_time, 13, 2) = substr (gcos_time, 11, 2); /* just copy */ substr (multics_time, 15, 3) = ":00"; /* no seconds */ end; else /* gcos time in 100ths of an hour */ do; if substr (gcos_time, 10, 1) = "." /* field is HH.XX */ then ascii_hundredths = substr (gcos_time, 11, 2); else /* field is HHXX */ ascii_hundredths = substr (gcos_time, 10, 2); call convert_hundredths; /* convert hundredths to ascii MM:SS */ if code ^= 0 /* error converting */ then go to RETURN; substr (multics_time, 13, hundredth_length) = substr (converted_hundredths, 1, hundredth_length); end; call convert_date_to_binary_ (multics_time, deferral, code); /* convert date */ RETURN: if code ^= 0 /* an error occurred */ then code = 1 ; /* return non-fatal error */ a_deferral = deferral; /* return deferred time */ a_code = code; /* return error code */ return; /* */ convert_hundredths: proc; /* internal procedure */ fixed_bin_hundredths = cv_dec_check_ (ascii_hundredths, code); /* convert to fixed bin */ if code ^= 0 /* error converting */ then return; seconds = fixed (fixed_bin_hundredths*36, 17); /* convert to seconds */ minutes = divide (seconds, 60, 17, 0); /* convert to minutes and seconds */ seconds = seconds - minutes*60; call ioa_$rsnnl ("^d:^d", converted_hundredths, hundredth_length, minutes, seconds); return; end convert_hundredths; end gcos_convert_time_;  gcos_daemon.pl1 11/19/82 1409.3rew 11/19/82 0853.2 184203 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ %page; /* Modified: Scott C. Akers FEB 82 Add 'help' request, change action of 'return' request to just quit out of Daemon instead of NEW_PROCing the user. */ %page; gcos_daemon: proc; /* MAIN ENTRY */ call init_pointers; test_entry = "0"b; call default_handler_$set (standard_default_handler_); /* use standard fault handler */ call gcos_daemon_init_ (fatal_error); go to COMMON; %page; /* TEST ENTRY */ test: entry; /* " N__a_m_e: test " " The test entry point to gcos_daemon " allows testing of the daemon from a private user process. It " allows the user to specify a private directory (instead of " >ddd>GCOS) to be used as the root directory during testing. " " U__s_a_g_e " gcos_daemon$test path " or " gcos_daemon$test control_arg " " where: " 1. path is the pathname of a root directory to be used in " the test. " " 2. control_arg is -wd or -working_dir if the working " directory is to be used as the root directory. " " N__o_t_e " Prior to calling this entry point the following setup must be " done for the root directory. The gcos_user_table_ must be copied " from >ddd>GCOS into the root directory. Table entries must exist " for the gcos_account_id, Multics Person_id and Multics Project_id " which will be used in testing the gcos daemon. See Appendix B of " the GCOS Environment Simulator manual AN05 for information on " setting up the gcos_user_table_. " " Next four subdirectories should be created in the root directory. " They are "input_dir", "pool_dir", "Anonymous", and "gdd". The " Access Control List for the subdirectories must include: " " sma Anonymous.GCOS.* " " and the Initial Access Control List for the subdirectories must " include: " " rw Anonymous.GCOS.* " " Under gdd a subdirectory must be created and named with the " Multics Project_id as specified in the gcos_user_table_. Under " this project directory a subdirectory must be created and named " with the Multics Person_id as specified in the gcos_user_table_. " This person directory must have an Access Control List which " includes: " " sma Anonymous.GCOS.* " " and an Initial Access Control List which includes: " " rw Anonymous.GCOS.* " */ call init_pointers; test_entry = "1"b; call cu_$arg_count (arg_count); if arg_count = 0 then do; code = error_table_$noarg; call com_err_ (code, "gcos_daemon$test", "^/Usage: gcos_daemon$test directory_name"); return; end; if arg_count > 1 then do; code = error_table_$too_many_args; call com_err_ (code, "gcos_daemon$test", "^/Usage: gcos_daemon$test directory_name"); return; end; call cu_$arg_ptr (1, arg_ptr, arg_len, code); if code ^= 0 then do; call com_err_ (code, "gcos_daemon$test"); return; end; if arg = "-wd" | arg = "-working_dir" then abspath = get_wdir_ (); else if substr (arg, 1, 1) = "-" then do; code = error_table_$badopt; call com_err_ (code, "gcos_daemon$test", "^a", arg); return; end; else do; call absolute_pathname_ (arg, abspath, code); if code ^= 0 then do; call com_err_ (code, "gcos_daemon$test", "/^a", arg); return; end; end; path_len = length (rtrim (abspath)); gcos_daemon_stat_$default_home_dir = rtrim (abspath)||">Anonymous"; gcos_daemon_stat_$home_root_dir = rtrim (abspath)||">gdd"; gcos_daemon_stat_$input_dir = rtrim (abspath)||">input_dir"; gcos_daemon_stat_$pool_dir = rtrim (abspath)||">pool_dir"; gcos_daemon_stat_$root_dir = abspath; gcos_daemon_stat_$default_home_dir_len = path_len + length (">Anonymous"); gcos_daemon_stat_$home_root_dir_len = path_len + length (">gdd"); gcos_daemon_stat_$input_dir_len = path_len + length (">input_dir"); gcos_daemon_stat_$pool_dir_len = path_len + length (">pool_dir"); gcos_daemon_stat_$root_dir_len = path_len; call gcos_daemon_init_$gd_test (fatal_error); go to COMMON; /* QUIT ENTRY */ quit_entry: entry; call init_pointers; call ios_$resetread ("user_i/o", status_stuff); code = status.code; if code ^= 0 then do; call com_err_ (code, "gcos_daemon", "Error resetting user_i/o"); go to GET_REQUEST; end; invocation_level = invocation_level + 1; /* bump count of times called */ go to SET_QUIT; /* OVERFLOW ENTRIES */ overflow_handler: entry; call init_pointers; call ioa_ ("Record quota overflow: Input for snumb ^a deleted", gcos_daemon_stat_$snumb); signal condition (goback); abs_overflow_handler: entry; call init_pointers; call ioa_ ("******ATTENTION******^/Record quota overflow from absentee gcos job in^/^a", gcos_daemon_stat2_$overflow_dir); return; %page; COMMON: ; if (fatal_error) then do; call com_err_ (0, "gcos_daemon", "Fatal error encountered during initialization"); return; end; if (^init) /* first time called */ then do; init = "1"b; /* remember */ cleanup_return = CLEANUP_RETURN; /* set internal static label */ end; reader_is_attached = "0"b; input_dir = substr (gcos_daemon_stat_$input_dir, 1, gcos_daemon_stat_$input_dir_len); /* run date deleter */ if ^test_entry then do; call hcs_$make_ptr (myp, "date_deleter", "date_deleter", ddp, code); /* get pointer to date_deleter */ if ddp = null /* error getting pointer */ then call com_err_ (code, "gcos_daemon", "Error finding date deleter"); else /* got pointer */ do dir_name = input_dir, substr (gcos_daemon_stat_$pool_dir, 1, gcos_daemon_stat_$pool_dir_len), substr (gcos_daemon_stat_$default_home_dir, 1, gcos_daemon_stat_$default_home_dir_len); call ioa_$rsnnl ("^d", delete_interval, i, gcos_daemon_stat_$delete_interval); /* get time interval */ call cu_$ptr_call (ddp, dir_name, delete_interval); end; end; /* set up condition handlers */ CLEANUP_RETURN: ; on condition (goback) begin; invocation_level = 0; /* will bring daemon back to lowest invocation level */ call ioa_ ("Cleanup invoked"); go to cleanup_return; /* pop stack back to first invocation level */ end; SET_QUIT: ; on condition (record_quota_overflow) call gcos_daemon$overflow_handler; on condition (quit) call gcos_daemon$quit_entry; GET_REQUEST: ; request = " "; /* blank out request line */ call ioa_ ("ENTER REQUEST"); /* ask for a request */ NULL_REQUEST: ; call ios_$read_ptr (addr (request), 120, request_len); /* read the request */ if request_len = 1 /* null request */ then go to NULL_REQUEST; %page; if substr (request, 1, 4) = "imcv" /* request to read tape */ then do; call gcos_read_tape_ (request, request_len - 1, test_entry); go to GET_REQUEST; end; %page; else if substr (request, 1, 6) = "attach" /* request to attach card reader */ then do; if (reader_is_attached) /* card reader already attached */ then call com_err_ (0, "gcos_daemon", "Card reader already attached"); else /* card reader not yet attached */ do; call ios_$attach ("card_input", gcos_daemon_stat_$card_dim, "rdra", "", status_stuff); code = status.code; if code ^= 0 then do; call com_err_ (code, "gcos_daemon", "Error attaching card reader"); go to GET_REQUEST; end; else reader_is_attached = "1"b; end; end; %page; else if substr (request, 1, 4) = "read" /* request to block on card reader */ then do; if (^reader_is_attached) /* card reader isn't attached yet */ then do; call com_err_ (0, "gcos_daemon", "Card reader is not attached"); go to GET_REQUEST; end; else do; /* reader is attached, prepare to read */ code = 0; eof_found = "0"b; do while (code = 0 & ^eof_found); call gcos_read_cards_ ("card_input", test_entry, eof_found, code); /* pass request on */ end; end; end; %page; else if substr (request, 1, 5) = "abort" /* request to abort current job */ then do; if invocation_level = 0 /* at lowest invocation level */ then do; call ioa_ ("You are at command level"); go to GET_REQUEST; end; signal condition (goback); end; %page; else if substr (request, 1, 6) = "detach" /* request to detach card reader */ then do; if (^reader_is_attached) /* reader is not attached */ then do; call com_err_ (0, "gcos_daemon", "Card reader is not attached"); go to GET_REQUEST; end; call detach; /* detach card reader */ if code = 0 /* successful detach */ then reader_is_attached = "0"b; end; %page; else if substr (request, 1, 7) = "re_init" /* request to re-initialize process */ then do; RE_INIT: ; if (reader_is_attached) /* card reader is attached */ then call detach; call new_proc; /* create a new process */ end; %page; else if substr (request, 1, 6) = "logout" /* request to log process out */ then do; if (reader_is_attached) /* card reader is attached */ then call detach; call logout; /* log daemon out */ end; %page; else if substr (request, 1, 5) = "admin" /* request to enter admin mode */ then do; on quit system; /* take away control of quits */ revert condition (record_quota_overflow); /* and record quota overflows */ call user_info_ (name, project, account); if project = "SysDaemon" then do; call hcs_$initiate ( substr (gcos_daemon_stat_$sysdir, 1, gcos_daemon_stat_$sysdir_len), "communications", "", 0, 1, com_p, code); if com_p ^= null then do; if communications.admin_word = "*" then go to enter_admin; call ioa_ ("Password:"); call iox_$control (iox_$user_io, "printer_off", null, ioxcode); call iox_$get_line (iox_$user_io, addr (request), 120, i, ioxcode); call iox_$control (iox_$user_io, "printer_on", null, ioxcode); w_password = substr (request, 1, i-1); /* Get password. */ if w_password = communications.admin_word then go to enter_admin; call com_err_ (0, "gcos_daemon", "password incorrect"); go to xadmin; end; else call com_err_ (code, "gcos_daemon", "Error in initiating communications segment"); end; enter_admin: ; call enter_admin_mode_ (); /* Call Multics listener. */ xadmin: ; /* Get here on "ame" command. */ call change_wdir_ (input_dir, code); /* make sure in proper dir */ if code ^= 0 /* can't do it */ then call com_err_ (code, "gcos_daemon", "Error changing to ^a", input_dir); go to SET_QUIT; end; %page; else if substr (request, 1, 3) = "smq" /* request to reset maximum queue priority */ then do; code = 0; /* prevents spurious message printing */ i = index (request, " "); /* find first blank in request */ if i > request_len /* no blank: no second argument */ then do; NO_QUEUE: ; call com_err_ (0, "gcos_daemon", "Missing or invalid queue number in smq request"); go to GET_REQUEST; end; do j = i to request_len while /* find beginning of argument */ (substr (request, j, 1) = " "); end; if j > request_len /* no second argument */ then go to NO_QUEUE; max_queue = cv_dec_check_ (substr (request, j, request_len-j), code); if code ^= 0 /* invalid queue specification */ then go to NO_QUEUE; call gcos_queue_job_$set_priority (max_queue); end; %page; else if substr (request, 1, 5) = "start" /* request to return from quit */ then do; if invocation_level = 0 /* at lowest level */ then do; call ioa_ ("You are at command level"); go to GET_REQUEST; end; invocation_level = invocation_level - 1; /* decrement count of stacked invocations */ return; /* and return */ end; %page; else if substr (request, 1, 6) = "return" /* request to return to command level */ then do; if (^test_entry) /* not allowed for daemon itself */ then go to NOT_RECOGNIZED; goto ALL_DONE; end; %page; else if substr (request, 1, 1) = "." /* user wants to know who he is */ then call ioa_ ("gcos_daemon"); %page; else if substr (request, 1, 1) = "?" | substr (request, 1, 4) = "help" then call ioa_ ( "^/REQUEST^-DESCRIPTION" ||"^2/abort^-Abort current job" ||"^/admin^-Enter 'admin' mode" ||"^/attach^-Attach the card reader" ||"^/detach^-Detach the card reader" ||"^/help^-Print this list" ||"^/imcv^-Read from tape" ||"^/logout^-Log out the Daemon" ||"^/read^-Read from the card reader" ||"^/return^-Return to command level" ||"^/^-(test entry only)" ||"^/re_init^-Reinitialize the Daemon" ||"^/smq N^-Set max priority abs queue for Daemon to N" ||"^/^-(Default is 1)" ||"^/start^-Restart from QUIT" ||"^/.^-Tell Daemon to identify itself" ||"^/?^-Print this list" ||"^/"); %page; else /* request not recognized */ NOT_RECOGNIZED: call com_err_ (0, "gcos_daemon", "Unrecognized request:^-^a", request); go to GET_REQUEST; %page; /* INTERNAL PROCEDURES */ detach: proc; /* procedure to detach devices */ call ios_$detach ("card_input", "rdra", "", status_stuff); code = status.code; if code ^= 0 then call com_err_ (code, "gcos_daemon", "Error detaching card reader"); return; end detach; init_pointers: proc; myp = addr (gcos_daemon$); /* pointer to this proc */ sp = addr (status_stuff); /* overlay pointer for ios_ status */ return; end init_pointers; %page; ALL_DONE: ; return; /* Bail out from the Daemon. */ %page; /* fixed bin */ /* ----- --- */ dcl ( gcos_daemon_stat_$default_home_dir_len ext, /* length of default home dir name */ gcos_daemon_stat_$delete_interval ext, /* days afted which to delete segment */ gcos_daemon_stat_$input_dir_len ext, /* length of input directory name */ gcos_daemon_stat_$pool_dir_len ext, /* length of pool dir name */ gcos_daemon_stat_$sysdir_len ext, /* length of sysdir name */ gcos_daemon_stat_$home_root_dir_len ext, /* length of home root dir name */ gcos_daemon_stat_$root_dir_len ext, /* length of root dir name */ i, /* random variable */ invocation_level int static init (0), /* number of stacked calls to quit entry */ j, /* random variable */ max_queue, /* maximum priority queue for absentee, output */ arg_count, /* total number of args in cmd line */ arg_len, /* size in chars of last arg retrieved with cu_$arg_ptr */ path_len, /* length of root dir name specified by gcos_test entry */ request_len /* length of request typed by operator */ ) fixed bin aligned; dcl ( ioxcode, /* error code from iox */ code, /* error code */ error_table_$noarg ext, error_table_$too_many_args ext, error_table_$badopt ext ) fixed bin (35) aligned; %page; /* bit strings */ /* --- ------- */ dcl ( fatal_error, /* ON when fatal error occurs during initialization */ eof_found, /* ON when eof is found reading cards */ init int static init ("0"b), /* internal static initialization switch */ reader_is_attached int static, /* ON when card reader is attached */ test_entry int static /* ON when called by user */ ) bit (1) aligned; dcl ( status_stuff /* return location for ios_ status */ ) bit (72) aligned; %page; /* character strings */ /* --------- ------- */ dcl ( gcos_daemon_stat_$snumb ext ) char (6) aligned; dcl ( w_password, /* Password for entering admin mode. */ delete_interval init (""), /* days after which to delete segment */ gcos_daemon_stat_$card_dim ext /* variable dim name for debugging */ ) char (8) aligned; dcl ( name, /* name returned by user_info_ */ project, /* project returned by user_info_ */ account /* account returned by user_info_ */ ) char (32) aligned; dcl ( request /* request from operator */ ) char (120) aligned; dcl ( dir_name, /* loop dir name */ gcos_daemon_stat2_$overflow_dir ext, gcos_daemon_stat_$default_home_dir ext, /* default home dir for absentee jobs */ gcos_daemon_stat_$input_dir ext, /* input directory name */ gcos_daemon_stat_$pool_dir ext, /* pool directory name */ gcos_daemon_stat_$sysdir ext, /* sysdir directory name */ gcos_daemon_stat_$home_root_dir ext, /* home root dir name */ gcos_daemon_stat_$root_dir ext, /* root dir name */ input_dir internal static /* input directory name (internal) */ ) char (168) aligned; dcl abspath char (168); /* absolute path for root dir given by gcos_test entry */ %page; /* pointers */ /* -------- */ dcl ( arg_ptr, /* returned by cu_$arg_ptr */ com_p, /* pointer to sc1>communications */ iox_$user_io ext, ddp, /* pointer to date_deleter proc */ myp, /* pointer to this proc */ sp /* overlay pointer for ios_ status */ ) pointer aligned; %page; /* built in functions */ /* ----- -- --------- */ dcl ( addr, index, null, substr ) builtin; %page; /* masks */ /* ----- */ dcl arg char (arg_len) based (arg_ptr); dcl 1 status aligned based (sp), /* return status from ios_ */ 2 code fixed bin (35); /* error code portion */ /* labels */ /* ------ */ dcl ( cleanup_return ) label int static; /* conditions */ /* ---------- */ dcl ( goback, quit, record_quota_overflow ) condition; %page; /* entries */ /* ------- */ dcl change_wdir_ ext entry (char (168) aligned, fixed bin (35) aligned); dcl com_err_ ext entry options (variable); dcl cu_$ptr_call ext entry options (variable); dcl cv_dec_check_ ext entry (char (*), fixed bin (35) aligned) returns (fixed bin aligned); dcl default_handler_$set ext entry (entry); dcl enter_admin_mode_ ext entry; dcl gcos_daemon$ entry; dcl gcos_daemon$overflow_handler ext entry; dcl gcos_daemon$quit_entry ext entry; dcl gcos_daemon_init_ ext entry (bit (1) aligned); dcl gcos_daemon_init_$gd_test ext entry (bit (1) aligned); dcl gcos_queue_job_$set_priority ext entry (fixed bin aligned); dcl gcos_read_cards_ ext entry (char (12) aligned, bit (1) aligned, bit (1) aligned, fixed bin (35) aligned); dcl gcos_read_tape_ ext entry (char (120) aligned, fixed bin aligned, bit (1) aligned); dcl hcs_$make_ptr ext entry (ptr aligned, char (*), char (*), ptr aligned, fixed bin (35) aligned); dcl ioa_ ext entry options (variable); dcl ioa_$rsnnl ext entry options (variable); dcl ios_$attach ext entry (char (*) aligned, char (*) aligned, char (*) aligned, char (*) aligned, bit (72) aligned); dcl ios_$detach ext entry (char (*) aligned, char (*) aligned, char (*) aligned, bit (72) aligned); dcl ios_$read_ptr ext entry (ptr aligned, fixed bin aligned, fixed bin aligned); dcl ios_$resetread ext entry (char (*) aligned, bit (72) aligned); dcl logout ext entry; dcl new_proc ext entry; dcl standard_default_handler_ ext entry; dcl user_info_ ext entry (char (*) aligned, char (*) aligned, char (*) aligned); dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35)); dcl iox_$get_line entry (ptr, ptr, fixed bin, fixed bin, fixed bin (35)); dcl hcs_$initiate entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl cu_$arg_count entry (fixed bin); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl absolute_pathname_ entry (char (*), char (*), fixed bin (35)); dcl get_wdir_ entry returns (char (168)); %page; %include communications; end gcos_daemon;  gcos_daemon_init_.pl1 11/19/82 1409.3rew 11/19/82 0929.5 78768 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* ****************************************************************************** * * * Written by P. Haber * * Modified by R.H. Morrison March,1975 * * * ****************************************************************************** */ gcos_daemon_init_: proc (fatal_error); /* DECLARATIONS */ /* ------------ */ dcl ( gcos_daemon$abs_overflow_handler ext /* bypass compiler problem */ ) fixed; /* fixed bin */ /* ----- --- */ dcl ( mode /* access to directory */ ) fixed bin (5) aligned; dcl ( rbs (3) init (5, 5, 5) /* ring brackets for append call */ ) fixed bin (6) aligned; dcl ( gcos_daemon_stat_$anonymous_user_len ext, gcos_daemon_stat_$default_home_dir_len ext, gcos_daemon_stat_$input_dir_len ext, gcos_daemon_stat_$max_priority ext, gcos_daemon_stat_$pool_dir_len ext, gcos_daemon_stat_$root_dir_len ext, i /* loop index */ ) fixed bin aligned; dcl ( code, /* error code */ error_table_$namedup ext ) fixed bin (35) aligned; dcl ( channel_name, /* name of created event channel */ gcos_daemon_stat_$overflow_channel ext ) fixed bin (71) aligned; /* pointers */ /* -------- */ dcl ( aclp, /* pointer to acl data */ sp /* pointer to return status from ios_ calls */ ) ptr aligned; /* bit strings */ /* --- ------- */ dcl ( fatal_error /* ON if fatal error encountered during initialization */ ) bit (1) aligned; dcl ( gcos_daemon_stat_$process_id ext /* process id of gcos daemon */ ) bit (36) aligned; dcl ( status_stuff /* returned status from ios_ calls */ ) bit (72) aligned; /* character strings */ /* --------- ------- */ dcl ( gcos_daemon_stat_$snumb ext ) char (6) aligned; dcl ( account, /* user's account */ en, /* entry portion of dir name */ gcos_daemon_stat_$anonymous_user ext, /* name of anonymous user */ group_id, /* from get_group_id */ name, /* user's name */ project /* user's project */ ) char (32) aligned; dcl ( dn, /* dir portion of directory */ gcos_daemon_stat_$default_home_dir ext, gcos_daemon_stat_$input_dir ext, gcos_daemon_stat_$pool_dir ext, gcos_daemon_stat_$root_dir ext, dir_name ) char (168) aligned; /* masks */ /* ----- */ dcl 1 status aligned based (sp), /* mask for ios_ status */ 2 code fixed bin (35); /* code portion */ /* structures */ /* ---------- */ dcl 1 dir_acl (2) aligned, /* for possible call to add_dir_acl */ 2 access_name char (32) aligned, 2 dir_modes bit (36) aligned, 2 a_code fixed bin (35) aligned; /* built-in */ /* -------- */ dcl ( addr, null, substr ) builtin; /* conditions */ dcl ( quit ) condition; /* external entries */ /* -------- ------- */ dcl change_wdir_ ext entry (char (168) aligned, fixed bin (35) aligned); dcl com_err_ ext entry options (variable); dcl expand_path_ ext entry (ptr aligned, fixed bin aligned, ptr aligned, ptr aligned, fixed bin (35) aligned); dcl gcos_daemon_init_$early_quit ext entry; dcl get_group_id_$tag_star ext entry returns (char (32) aligned); dcl get_process_id_ ext entry returns (bit (36) aligned); dcl hcs_$add_dir_acl_entries ext entry (char (*) aligned, char (*) aligned, ptr aligned, fixed bin aligned, fixed bin (35) aligned); dcl hcs_$append_branchx ext entry (char (*) aligned, char (*) aligned, fixed bin (5) aligned, (3) fixed bin (6) aligned, char (*) aligned, fixed bin (1) aligned, fixed bin (1) aligned, fixed bin (24) aligned, fixed bin (35) aligned); dcl hcs_$get_user_effmode ext entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin aligned, fixed bin (5) aligned, fixed bin (35) aligned); dcl ioa_ ext entry options (variable); dcl ios_$resetread ext entry (char (*) aligned, bit (72) aligned); dcl ios_$order ext entry (char (*) aligned, char (*) aligned, ptr aligned, bit (72) aligned); dcl ipc_$create_ev_chn ext entry (fixed bin (71) aligned, fixed bin (35) aligned); dcl ipc_$decl_ev_call_chn ext entry (fixed bin (71) aligned, ptr aligned, ptr aligned, fixed bin aligned, fixed bin (35) aligned); dcl user_info_ ext entry (char (*) aligned, char (*) aligned, char (*) aligned); /* */ call user_info_ (name, project, account); /* determine callers' project */ if name ^= "GCOS"| project ^= "SysDaemon" /* not being called by init_admin_ */ then do; /* caller should use test entry */ call com_err_ (0, "gcos_daemon_init_", "Use test entry"); fatal_error = "1"b; return; end; gd_test: entry (fatal_error); /* entry for testing from user process */ call init_pointers; on condition (quit) call gcos_daemon_init_$early_quit; call ios_$order ("user_i/o", "quit_enable", null, status_stuff); if status.code ^= 0 then do; call com_err_ (status.code, "gcos_daemon_init_", "Order call to enable quits"); fatal_error = "1"b; return; end; fatal_error = "0"b; /* initialize argument */ group_id = get_group_id_$tag_star (); /* get user name */ dir_acl (1).access_name = group_id; /* fill in acl structure for calls */ dir_acl (2).access_name = substr (gcos_daemon_stat_$anonymous_user, 1, gcos_daemon_stat_$anonymous_user_len); do i = 1 to 2; dir_acl (i).dir_modes = "111000000000000000000000000000000000"b; end; do dir_name = substr (gcos_daemon_stat_$root_dir, 1, gcos_daemon_stat_$root_dir_len), substr (gcos_daemon_stat_$pool_dir, 1, gcos_daemon_stat_$pool_dir_len), substr (gcos_daemon_stat_$default_home_dir, 1, gcos_daemon_stat_$default_home_dir_len), substr (gcos_daemon_stat_$input_dir, 1, gcos_daemon_stat_$input_dir_len); do i = 168 to 1 by -1 while (substr (dir_name, i, 1) = " "); end; call expand_path_ (addr (dir_name), i, addr (dn), addr (en), code); if code ^= 0 then go to END_LOOP; call hcs_$append_branchx (dn, en, 01011b, rbs, group_id, 1, 0, 0, code); if code ^= 0 then if code ^= error_table_$namedup /* returned if dir already exists */ then go to END_LOOP; do i = 1 to 2; /* init return code */ dir_acl (i).a_code = 0; end; call hcs_$add_dir_acl_entries (dn, en, aclp, 2, code); /* set minimum acl */ if code ^= 0 /* error setting acl */ then if code ^= error_table_$namedup /* returned if all names are on acl */ then go to END_LOOP; end; END_LOOP: if code = 0 /* access on dirs okay */ then call change_wdir_ (dir_name, code); /* switch to input dir */ if code ^= 0 /* an error occurred in checking or switching to dir */ then do; call com_err_ (code, "gcos_daemon_init_", dir_name); fatal_error = "1"b; end; gcos_daemon_stat_$snumb = ""; /* initialize current snumb */ call ipc_$create_ev_chn (channel_name, code); /* create channel to signal quota overflows */ if code ^= 0 then do; call com_err_ (code, "gcos_daemon_init_", "Error creating event channel"); fatal_error = "1"b; return; end; call ipc_$decl_ev_call_chn (channel_name, addr (gcos_daemon$abs_overflow_handler), null, 0, code); if code ^= 0 then do; call com_err_ (code, "gcos_daemon_init_", "Error converting event channel to call channel"); fatal_error = "1"b; return; end; gcos_daemon_stat_$overflow_channel = channel_name; gcos_daemon_stat_$process_id = get_process_id_ (); gcos_daemon_stat_$max_priority = 1; return; /* */ early_quit: entry; call init_pointers; call ios_$resetread ("user_i/o", status_stuff); code = status.code; if code ^= 0 then do; call com_err_ (code, "gcos_daemon_init_", "Error resetting user_i/o"); fatal_error = "1"b; return; end; call ioa_ ("QUIT^/START"); return; /* */ /* INTERNAL PROCEDURES */ init_pointers: proc; aclp = addr (dir_acl (1).access_name); /* pointer to acl data */ sp = addr (status_stuff); /* pointer to return status from ios_ calls */ return; end init_pointers; end gcos_daemon_init_;  gcos_daemon_temp_.pl1 11/19/82 1409.3rew 11/19/82 0929.6 41193 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ gcos_daemon_temp_: proc; /* DECLARATIONS */ /* ------------ */ /* fixed bin */ dcl ( fixed_bin2 /* variable from callers' star_ call passed on */ ) fixed bin (2) aligned; dcl ( a_ecount, /* number of entries corresponding to segment_name (argument) */ ecount /* number of entries corresponding to segment_name (internal) */ ) fixed bin aligned; dcl ( a_code, /* error code (argument) */ code, /* error code (internal) */ error_table_$nomatch ext ) fixed bin (35) aligned; /* pointers */ dcl ( freep int static, /* pointer to system free area */ ptr1, /* dummy arguments */ ptr2, ptr3, ptr4, ptr5, sp /* mask pointer for status from ios_ */ ) ptr aligned; /* bit strings */ dcl ( init int static init ("0"b) /* ON once system free area is called */ ) bit (1) aligned; dcl ( a_status_stuff, /* returned status from ios_ (argument) */ status_stuff /* returned status from ios_ (internal) */ ) bit (72) aligned; /* character strings */ dcl ( a_stream_name, /* stream name (argument) */ stream_name /* stream name (internal) */ ) char (12) aligned; dcl ( a_segment_name, /* star name (argument) */ segment_name /* star name (internal) */ ) char (32) aligned; dcl ( a_dir_name, /* directory being searched for names (argument) */ dir_name /* directory being searched for names (internal) */ ) char (168) aligned; /* built in */ dcl ( addr, null ) builtin; /* masks */ dcl 1 status aligned based (sp), /* for interpreting status from ios_ */ 2 code fixed bin aligned; /* external entries */ dcl freen_ ext entry (ptr aligned); dcl get_system_free_area_ ext entry returns (ptr aligned); dcl hcs_$star_ ext entry (char (*) aligned, char (*) aligned, fixed bin (2) aligned, ptr aligned, fixed bin aligned, ptr aligned, ptr aligned, fixed bin (35) aligned); dcl ios_$attach ext entry (char (*) aligned, char (*) aligned, char (*) aligned, char (*) aligned, bit (72) aligned); dcl ios_$detach ext entry (char (*) aligned, char (*) aligned, char (*) aligned, bit (72) aligned); /* */ star_: entry (a_dir_name, a_segment_name, fixed_bin2, ptr1, a_ecount, ptr2, ptr3, a_code); /* This entry simulates a star handler which returns a count of the entries corresponding to only the star name if ptr1 is null. The current star handler returns a count of all the entries in the directory */ sp = addr (status_stuff); /* mask pointer for status from ios_ */ if ^init /* first time proc called */ then do; freep = get_system_free_area_ (); /* get pointer to system free area */ init = "1"b; /* remember you've been called */ end; dir_name = a_dir_name; /* copy in arguments */ segment_name = a_segment_name; call hcs_$star_ (dir_name, segment_name, fixed_bin2, freep, ecount, ptr4, ptr5, code); /* make a call to current star_ */ if ptr4 ^= null /* free any allocation */ then call freen_ (ptr4); if ptr5 ^= null then call freen_ (ptr5); if code = error_table_$nomatch /* no entries with star name */ then do; code = 0; /* return sensible variables */ ecount = 0; end; a_code = code; /* return arguments */ a_ecount = ecount; return; /* */ resetread: entry (a_stream_name, a_status_stuff); /* This function simulates a currently missing function in the card reader dim: resetread. It does this by first detaching, then reattaching the card reader */ sp = addr (status_stuff); /* mask pointer for status from ios_ */ stream_name = a_stream_name; /* copy in argument */ call ios_$detach (stream_name, "rdra", "", status_stuff); /* detach the card reader */ if status.code = 0 /* detach o.k. */ then call ios_$attach (stream_name, "rdr21", "rdra", "", status_stuff); /* reattach it */ a_status_stuff = status_stuff; /* return status */ return; end gcos_daemon_temp_;  gcos_queue_job_.pl1 08/01/88 1051.0r w 08/01/88 1029.5 169938 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* **************************************************************************************** This procedure maps data from the gcos daemon absentee data structure (currently gcos_abs_data) into the absentee structure used as the absentee message format (currently abs_message_format) and then queues a gcos job by calling a message segment primitive (currently message_segment_$add_file) Arguments are 1) -- a_data_ptr A pointer to the gcos daemon created absentee data (Input). 2) -- a_code An error code (Output). WRITTEN BY: P. Haber March 21, 1974 MODIFIED BY: R.H. Morrison August 19, 1974 March 1975 July 21, 1975 Modified by T. Casey, May 1978, To use version 4 absentee request structure. Modified by S. Akers, Mar 1982, To make a neater absin seg and check for duplicate SNUMBs. Also to use gcos_daemon_stat_$snumb instead of passing the SNUMB as an argument to all and sundry. Modified by R. Barstad August 1982 Fixed gcos job absin where last line of absin deleted itself. **************************************************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-03-01,Gilcrease), approve(86-03-17,MCR7370), audit(86-06-25,Lippard), install(86-06-30,MR12.0-1082): Update version to 5 in abs_message_format. SCP6297. 2) change(87-07-27,GDixon), approve(87-07-27,MCR7741), audit(87-07-28,Hartogs), install(87-08-04,MR12.1-1055): A) Include user_abs_attributes.incl.pl1 to accommodate change made to abs_message_format.incl.pl1 3) change(88-02-12,Parisek), approve(88-02-12,MCR7849), audit(88-03-23,Lippard), install(88-07-13,MR12.2-1047): Reference version 6 abs_message_format structure. END HISTORY COMMENTS */ %page; gcos_queue_job_: proc (a_data_ptr, a_test_entry, a_code); /* PER PROCESS INITIALIZATION */ call setup; /* initialize automatics */ if ^init /* first time called */ then do; call hcs_$make_seg ("", "gcos_abs_temp_", "", 01011b, temp_ptr, code); /* create temporary in pdir */ if temp_ptr = null /* error creating temporary */ then do; call com_err_ (code, "gcos_queue_job_", "Error creating temporary segment"); go to RETURN; end; input_dir = substr (gcos_daemon_stat_$input_dir, 1, gcos_daemon_stat_$input_dir_len); /* set input_dir name */ sysdir = substr (gcos_daemon_stat_$sysdir, 1, gcos_daemon_stat_$sysdir_len); /* and sysdir name */ call hcs_$initiate (sysdir, "whotab", "", 0, 0, stat_whoptr, code); /* initiate who table */ if stat_whoptr = null /* error initiating table */ then do; call com_err_ (code, "gcos_queue_job_", "Error initiating who_table"); go to RETURN; end; init = "1"b; /* initialization finished */ end; %page; on condition (cleanup) /* establish cleanup handler */ call error_wrap_up; call hcs_$truncate_seg (temp_ptr, 0, code); /* make sure it's empty for this call */ if code ^= 0 /* error truncating */ then do; call com_err_ (code, "gcos_queue_job_", "Error truncating temporary"); go to RETURN; end; /* initializations */ code = 0; abs_data_ptr = a_data_ptr; whoptr = stat_whoptr; reqp = temp_ptr; %page; /* MAP ABSENTEE DATA */ request.request_version = abs_message_version_6; /* version number */ request.hdr_version = queue_msg_hdr_version_1; char32 = get_group_id_ (); /* submitters' name (gcos daemon) & length */ group_id_len = length (rtrim (char32)); request.len_name = group_id_len; request.name = substr (char32, 1, group_id_len); absentee_dir_len = length (rtrim (abs_data.absentee_dir)); request.dirname = substr (abs_data.absentee_dir, 1, absentee_dir_len); request.ename = rtrim (gcos_daemon_stat_$snumb)||".absin"; request.arg_count = 0; /* argument count */ request.arg_lengths = 0; /* argument length */ request.len_args = 0; /* argument string lengths */ request.len_resource = 0; /* resource length */ request.len_sender = 0; /* sender userid length */ request.len_comment = 0; /* comment string length */ request.len_vpad = 0; /* spare variable length */ unique_snumb = rtrim (gcos_daemon_stat_$snumb) ||"_" ||unique_chars_ (unique_bits_ ()); /* make SNUMB unique */ unique_snumb_len = length (rtrim (unique_snumb)); /* compute its length */ if unique_snumb_len > 18 then /* if unique SNUMB too long, shorten it */ do; /* retain low order characters /* of unique_chars_ & the "!" */ snumb_len = length (rtrim (gcos_daemon_stat_$snumb)); unique_snumb = substr (unique_snumb, 1, snumb_len+2) ||substr (unique_snumb, snumb_len+3 + unique_snumb_len-18); unique_snumb_len = 18; end; request.len_output = absentee_dir_len + unique_snumb_len + 8; /* output path-name and length */ request.output_file = substr (abs_data.absentee_dir, 1, absentee_dir_len)||">"||rtrim (unique_snumb)||".absout"; request.abs_attributes.user_deferred_until_time = abs_data.absentee_options.deferral_switch; /* deferral time */ if abs_data.absentee_options.deferral_switch /* one has been specified */ then request.deferred_time = abs_data.absentee_data.deferral; else /* no deferred time specified */ request.deferred_time = 0; user_name_len = length (rtrim (abs_data.user_name)); request.len_proxy = user_name_len; request.proxy_name = substr (abs_data.user_name, 1, user_name_len); request.abs_attributes.proxy = "1"b; request.max_cpu_time = gcos_daemon_stat_$max_cpu_time; /* max cpu time */ request.set_bit_cnt = "0"b; /* don't set bit count after every write */ request.abs_attributes.restartable = "1"b; /* gcos jobs are restartable */ /* Defaults for version 6 stuff */ request.initial_ring = -1; request.len_homedir = 0; request.len_initproc = 0; call user_info_$authorization_range (authrng); request.requested_authorization = authrng (1); /* use the low range */ request.std_length = currentsize (request); /* store request's word length in its header */ message_bit_count = request.std_length * 36; /* remember its bitcount for later */ %page; /* CREATE ABSIN FILE */ call hcs_$make_seg (abs_data.absentee_dir, rtrim (gcos_daemon_stat_$snumb)||".absin", "", 01011b, absin_ptr, code); /* make segment "snumb.absin" */ if absin_ptr = null /* error creating "snumb.absin" */ then do; call com_err_ (code, "gcos_queue_job_", "Error creating ^a>^a.absin", abs_data.absentee_dir, gcos_daemon_stat_$snumb); go to RETURN; end; call hcs_$set_ring_brackets (abs_data.absentee_dir, rtrim (gcos_daemon_stat_$snumb)||".absin", rb, code); /* set ring brackets */ if code ^= 0 then do; call com_err_ (code, "gcos_queue_job_", "Error setting ring brackets for ^a>^a.absin", abs_data.absentee_dir, gcos_daemon_stat_$snumb); go to RETURN; end; call ioa_$rsnnl ("^d", char1, j, abs_data.priority_queue); if ^a_test_entry /* regular daemon */ then heading = gcos_daemon_stat_$snumb; /* set heading */ else /* test user */ do; /* query him for a heading */ call ioa_$nnl ("Output heading for ^a = :", gcos_daemon_stat_$snumb); call ios_$read_ptr (addr (heading), 24, j); heading = substr (heading, 1, min (j-1, 24)); call ioa_$nnl ("Destination for ^a = :", gcos_daemon_stat_$snumb); call ios_$read_ptr (addr (destination), 24, j); destination = substr (destination, 1, min (j-1, 24)); end; call ioa_$rsnnl ( /* fill in "snumb.absin" */ ".q" ||"^/set_epilogue_command ""dl [user absin]""" ||"^/cdwd ^a" ||"^/cwd ^a" ||"^/gcos_abs_control gcos ^a>^a.gcos -id ^a -dpo ""-he """"^a"""" -ds """"^a"""" -dl -q ^a"" -dpno ""-he """"^a"""" -ds """"^a"""" -dl -q ^a"" dp -q ^a -he ""^a"" -ds ""^a"" -dl [user absout]" ||"^/dl ^a>^a.gcos" ||"^/logout -bf^/", absin_mask, absin_char_count, abs_data.home_dir, abs_data.absentee_dir, input_dir, gcos_daemon_stat_$snumb, unique_snumb, heading, destination, char1, heading, destination, char1, char1, heading, destination, input_dir, gcos_daemon_stat_$snumb ); absin_name = rtrim (gcos_daemon_stat_$snumb)||".absin"; /* make absin file name */ segment_acl.access_name = abs_data.user_name; /* prepare for acl call */ segment_acl.modes = "111"b; segment_acl.zero_pad = "0"b; call hcs_$add_acl_entries (abs_data.absentee_dir, absin_name, addr (segment_acl), 1, code); /* set user's access */ if code ^= 0 /* error setting access */ then do; call com_err_ (code, "gcos_queue_job_", "Error setting access on ^a>^a.absin", abs_data.absentee_dir, gcos_daemon_stat_$snumb); call error_wrap_up; go to RETURN; end; call adjust_bit_count_ (abs_data.absentee_dir, absin_name, "1"b, bit_count, code); /* set its bit count */ if code ^= 0 /* error setting bit count on snumb.absin */ then do; call com_err_ (code, "gcos_queue_job_", "Error setting bit count on ^a>^a.absin", abs_data.absentee_dir, gcos_daemon_stat_$snumb); call error_wrap_up; go to RETURN; end; /* QUEUE UP ABSENTEE JOB */ if a_test_entry then do; call command_query_ (addr (query_info), answer, "gcos_queue_job_", "Do you want to submit ^a?", gcos_daemon_stat_$snumb); if substr (answer, 1, 2) = "no" then go to RETURN; end; priority = max (abs_data.priority_queue, gcos_daemon_stat_$max_priority); /* get effective max queue */ if priority > abs_data.priority_queue /* requester's queue too high in priority */ then call ioa_ ("Request for queue ^d placed in queue ^d", /* tell operator */ abs_data.priority_queue, priority); call ioa_$rsnnl ("absentee_^d.ms", char32, j, priority); /* construct message segment name */ call message_segment_$get_message_count_file /* get present message count */ (sysdir, char32, ms_count, code); if code ^= 0 /* error getting count */ then do; call com_err_ (code, "gcos_queue_job_", "Error getting message count from absentee queue ^d", abs_data.priority_queue); call error_wrap_up; go to RETURN; end; call message_segment_$add_file (sysdir, char32, temp_ptr, message_bit_count, message_id, code); /* submit message */ if code ^= 0 /* error submitting message */ then do; call com_err_ (code, "gcos_queue_job_", "error queueing job: queue = ^d, SNUMB = ^a", abs_data.priority_queue, gcos_daemon_stat_$snumb); call error_wrap_up; go to RETURN; end; call hcs_$wakeup (whotab.abs_procid, whotab.abs_event, ev_message, code); /* signal absentee */ if code = 1 /* signal didn't make it */ then do; call com_err_ (0, "gcos_queue_job_", "Signal to absentee for SNUMB #^a failed. Request will be processed later", gcos_daemon_stat_$snumb); code = 0; /* no actual error returned */ end; else /* absentee was signalled, print message */ call ioa_ ("1 request signalled: ^d already queued", ms_count); go to RETURN; set_priority: entry (a_priority); if a_priority gcos_daemon_stat_$high_priority then call com_err_ (0, "gcos_queue_job_", "Attempt to set invalid priority: ^d", a_priority); else gcos_daemon_stat_$max_priority = a_priority; /* set maximum queue priority */ return; RETURN: a_code = code; return; error_wrap_up: proc; call hcs_$delentry_seg (absin_ptr, code); /* delete possible created absin file */ call message_segment_$delete_file /* delete message if sent */ (sysdir, char32, message_id, code); code = 2; return; end error_wrap_up; setup: proc; rb (*) = 5; destination = ""; message_id = "0"b; query_info.version = 2; query_info.yes_or_no_sw = "1"b; query_info.suppress_name_sw = "1"b; end setup; %page; /* DECLARATIONS */ /* ------------ */ /* fixed bin */ dcl ( a_priority, /* maximum allowable queue priority */ absentee_dir_len, /* character count of absentee dir name */ absin_char_count, /* character count of absin file */ gcos_daemon_stat_$high_priority ext, /* highest numerical legal priority */ gcos_daemon_stat_$input_dir_len ext, /* length of input directory name */ gcos_daemon_stat_$low_priority ext, /* lowest numerical legal priority */ gcos_daemon_stat_$max_cpu_time ext, /* maximum cpu time for job */ gcos_daemon_stat_$max_priority ext, gcos_daemon_stat_$sysdir_len ext, /* length of "sysdir" directory name */ group_id_len, /* character count of group id */ j, /* random variable */ message_bit_count, /* bit count of absentee message */ ms_count, /* number of messages in absentee queue */ priority, /* priority for which job will be queued */ snumb_len, /* character count of snumb */ unique_snumb_len, /* character count of snumb||"_"||unique_chars_ */ user_name_len /* character count of user name */ ) fixed bin aligned; dcl ( bit_count ) fixed bin (24) aligned; dcl ( a_code, /* error code (argument) */ code /* error code (internal) */ ) fixed bin (35) aligned; dcl rb (3) fixed bin (3) aligned; /* ring brackets */ /* bit strings */ dcl ( a_test_entry, /* ON if daemon was brought up by user */ init internal static init ("0"b) /* ON once per-process initialization is accomplished */ ) bit (1) aligned; dcl ( message_id /* returned from adding message */ ) bit (72) aligned; dcl authrng (2) bit (72) aligned; /* character strings */ dcl char1 char (1) aligned; dcl ( answer /* answer from command query question */ ) char (4) aligned; dcl ipc_message int static init ("login ") char (8); dcl ( destination, /* destination for dprinting and dpunching output */ heading, /* heading for dprinting and dpunching output */ unique_snumb ) char (24) aligned; dcl gcos_daemon_stat_$snumb ext char (6) aligned; dcl ( absin_name, /* ent name of absentee file */ char32 /* random string */ ) char (32) aligned; dcl ( gcos_daemon_stat_$input_dir ext, /* input directory name */ gcos_daemon_stat_$sysdir ext, /* "sysdir" directory name */ input_dir int static, sysdir internal static /* "sysdir" directory name (internal) */ ) char (168) aligned; /* pointers */ dcl ( a_data_ptr, /* pointer to daemons' absentee data structure (argument) */ absin_ptr, /* pointer to created "snumb.absin" segment */ reqp ptr, /* pointer to absentee request structure */ stat_whoptr internal static, /* static pointer to who table */ temp_ptr internal static, /* pointer to temp segment in process dir */ whoptr /* pointer to who-table */ ) ptr aligned; /* masks */ dcl absin_mask char (1000) aligned based (absin_ptr); dcl ev_message fixed bin (71) aligned based (addr (ipc_message)); /* for sending ascii */ /* structures */ dcl 1 segment_acl aligned, /* for setting user's access */ 2 access_name char (32) aligned, 2 modes bit (36) aligned, 2 zero_pad bit (36) aligned, 2 status_code fixed bin (35) aligned; dcl 1 query_info aligned, /* for command query call */ 2 version fixed bin, 2 yes_or_no_sw bit (1) unaligned, /* answer must be yes or no */ 2 suppress_name_sw bit (1) unaligned, /* don't print prog name with "Please answer ... */ 2 codes (2) fixed bin (35); /* built in functions */ dcl ( addr, currentsize, length, max, min, null, rtrim, substr ) builtin; /* conditions */ dcl ( cleanup ) condition; /* include files */ % include abs_message_format; % include gcos_abs_data; % include queue_msg_hdr; % include user_abs_attributes; % include whotab; /* external entries */ dcl adjust_bit_count_ ext entry (char (168) aligned, char (32) aligned, bit (1) aligned, fixed bin (24) aligned, fixed bin (35) aligned); dcl com_err_ ext entry options (variable); dcl command_query_ ext entry options (variable); dcl get_group_id_ ext entry returns (char (32) aligned); dcl hcs_$add_acl_entries ext entry (char (*) aligned, char (*) aligned, ptr aligned, fixed bin aligned, fixed bin (35) aligned); dcl hcs_$delentry_seg ext entry (ptr aligned, fixed bin (35) aligned); dcl hcs_$initiate ext entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin aligned, fixed bin aligned, ptr aligned, fixed bin (35) aligned); dcl hcs_$make_seg ext entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (5) aligned, ptr aligned, fixed bin (35) aligned); dcl hcs_$set_ring_brackets ext entry (char (*) aligned, char (*) aligned, (3) fixed bin (3) aligned, fixed bin (35) aligned); dcl hcs_$truncate_seg ext entry (ptr aligned, fixed bin aligned, fixed bin (35) aligned); dcl hcs_$wakeup ext entry (bit (*) aligned, fixed bin (71), fixed bin (71), fixed bin (35) aligned); dcl ioa_ ext entry options (variable); dcl ioa_$nnl ext entry options (variable); dcl ioa_$rsnnl ext entry options (variable); dcl ios_$read_ptr ext entry (ptr aligned, fixed bin aligned, fixed bin aligned); dcl message_segment_$add_file ext entry (char (*) aligned, char (*) aligned, ptr, fixed bin aligned, bit (*) aligned, fixed bin (35) aligned); dcl message_segment_$delete_file ext entry (char (*) aligned, char (*) aligned, bit (72) aligned, fixed bin (35) aligned); dcl message_segment_$get_message_count_file ext entry (char (*) aligned, char (*) aligned, fixed bin aligned, fixed bin (35) aligned); dcl unique_chars_ entry (bit(*)) returns(char(15)); dcl unique_bits_ entry() returns(bit(70)); dcl user_info_$authorization_range entry ((2) bit (72) aligned); end gcos_queue_job_;  gcos_read_.pl1 11/19/82 1409.3rew 11/19/82 0853.2 244656 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ %page; /* WRITTEN BY: P. Haber MAR 21 74 MODIFIED BY: R.H. Morrison MAY 22 74 MAR 75 MODIFIED BY: Bob May JUL 18 78 To allow IMCV tapes to use ***EOF cards instead of $ENDJOB cards (see GEIN PLM). A dummy $ENDJOB card is written to the JCL instead of the ***EOF card. Also to allow placement of the $IDENT card anywhere in the job deck. This change eliminated the use of the "first_read" switch and replaced it with an "ident_found" switch. MODIFIED BY: Scott C. Akers MAR 30 82 To give operator the option of resolving duplicate SNUMBs. MODIFIED BY: Scott C. Akers MAR 31 82 To use gcos_daemon_stat_$snumb */ %page; gcos_read_: proc; cards: entry (a_urgency, a_input_ptr, a_abs_data_ptr, a_eof_found, a_code); reading_cards = "1"b; stream_name = "card_input"; card_no = 1; /* First card is snumb */ go to COMMON; tape: entry (a_urgency, a_input_ptr, a_abs_data_ptr, a_eof_found, a_code); reading_cards = "0"b; stream_name = "tape_input"; COMMON: ; rh_ptr = addr (record_header); /* pointer for looking at record header */ sp = addr (status_stuff); /* pointer to returned status from ios_ calls */ on condition (cleanup) /* establish cleanup condition handler */ call end_work; if ^initialized /* first call */ then do; /* initialize internal directory info */ input_dir = substr (gcos_daemon_stat_$input_dir, 1, gcos_daemon_stat_$input_dir_len); pool_dir = substr (gcos_daemon_stat_$pool_dir, 1, gcos_daemon_stat_$pool_dir_len); root_dir_len = gcos_daemon_stat_$root_dir_len; root_dir = substr (gcos_daemon_stat_$root_dir, 1, root_dir_len); default_home_dir = substr (gcos_daemon_stat_$default_home_dir, 1, gcos_daemon_stat_$default_home_dir_len); user_ring = fixed (get_ring_ (), 17); /* set for effmode calls later */ abs_data_len = (fixed (rel (addr (a_abs_data_ptr -> abs_data.end_abs_data)), 17) - fixed (rel (addr (a_abs_data_ptr -> abs_data)), 17)) * 36; /* set abs data length */ my_name = get_group_id_$tag_star (); /* remember proc id */ initialized = "1"b; end; abs_data_ptr = a_abs_data_ptr; data_blank = "0"b; /* initialize absentee data */ code = 0; /* initialize internal error code */ segment_name = ""; /* initialize internal variables */ input_ptr = addr (input); ascii_ptr = addr (ascii); priority_queue = a_urgency; write_ptr = a_input_ptr; /* first write is of bcd snumb card argument */ write_size = 14; /* = 14 36 bit words */ segment_name = rtrim (gcos_daemon_stat_$snumb)||".*"; /* make star name */ report_code = "0"b; /* set record header for first write */ media_code = "0010"b; /* bcd image */ do dir_name = input_dir, pool_dir; /* check directories for similarly named segment */ call check_entry; /* see if SNUMB is already on system */ if code ^= 0 /* error or SNUMB already exists */ then go to RETURN; end; segment_name = rtrim (gcos_daemon_stat_$snumb) || ".gcos"; /* set default segment name */ call ios_$attach ("segment_output", "file_", segment_name, "w", status_stuff); /* attach segment */ code = status.code; /* check error code */ if code ^= 0 /* error attaching segment */ then do; call com_err_ (code, "gcos_read_", "Error attaching to segment_output stream"); go to RETURN; end; else /* no error */ output_is_attached = "1"b; /* for condition handler */ call ios_$setsize ("segment_output", 36, status_stuff); /* set element size for writing */ code = status.code; /* check code */ if code ^= 0 /* error setting size */ then do; call com_err_ (code, "gcos_read_", "Error setting element size on segment_output stream"); go to DETACH; end; call gcos_gsr_write_$gsr_write_init ("segment_output", code); /* initialize write package */ if code ^= 0 /* error initializing write routine */ then do; call com_err_ (code, "gcos_read_", "Error in call to gsr_write_init: SNUMB = ^a", gcos_daemon_stat_$snumb); go to DETACH; end; else /* no error */ gsr_write_init_called = "1"b; /* remember it was called */ %page; WRITE: call gcos_gsr_write_ ("segment_output", write_ptr, write_size, record_header, ejb_found, code); /* write the binary or bcd image */ if code ^= 0 /* error writing */ then do; call com_err_ (code, "gcos_read_", "Error from gsr_write: SNUMB = ^a", gcos_daemon_stat_$snumb); go to DETACH; end; if ejb_found /* end of job found */ then do; gsr_write_init_called = "0"b; /* ejb switch closed out file */ go to DETACH; end; dollar_card = "0"b; if reading_cards then do; card_no = card_no + 1; /* Keep count of cards read */ call ios_$read (stream_name, input_ptr, 0, 1, elements_read, status_stuff); code = status.code; /* check code */ if code ^= 0 /* error reading */ then do; call com_err_ (code, "gcos_read_", "Error reading from ^a: SNUMB = ^a", stream_name, gcos_daemon_stat_$snumb); go to DETACH; end; if status.eof /* last card and "last batch" button */ then do; call com_err_ (0, "gcos_read_", "Unexpected end of card input: SNUMB = ^a", gcos_daemon_stat_$snumb); code = 2; /* fatal error */ go to DETACH; end; write_ptr = input_ptr; /* set pointer for writing */ if substr (input, 10, 3) ^= "101"b /* check for non-binary card */ then do; call cv_bin_to_bcd_ (input_ptr, input_ptr, code); /* convert to bcd */ if code ^= 0 then do; call com_err_ (0, "gcos_read_", "Error converting card ^i to bcd: SNUMB = ^a", card_no, gcos_daemon_stat_$snumb); go to DETACH; end; write_size = 14; media_code = "0010"b; /* bcd image */ if substr (input, 1, 6) = "101011"b /* "$" */ then dollar_card = "1"b; end; else /* binary image */ do; media_code = "0001"b; write_size = 27; end; report_code = "0"b; end; else /* reading from tape */ do; if eof_found /* error, attempt to read past eof */ then do; call com_err_ (0, "gcos_read_", "Unexpected eof on tape: SNUMB = ^a", gcos_daemon_stat_$snumb); code = 2; /* return fatal error */ go to DETACH; end; call gcos_gsr_read_ (stream_name, write_ptr, write_size, record_header, eof_found, code); if code ^= 0 /* error reading from tape */ then do; call com_err_ (code, "gcos_read_", "Error from gcos_gsr_read_, SNUMB = ^a", gcos_daemon_stat_$snumb); go to DETACH; end; /* BCD */ if media_code = "0010"b /* bcd card */ /* $ */ then if first_bcd_char = "101011"b /* = $ */ then dollar_card = "1"b; /* ***EOF */ else if substr (tape_input_record, 1, 36) = "545454254626"b3 then do; substr (tape_input_record, 1, 252) = (42) "20"b3; /* init bcd string to blanks, in two parts, */ substr (tape_input_record, 253, 252) = (42) "20"b3; /* to get around PL/I restriction */ substr (tape_input_record, 1, 126) = "532020202020202545244146222020545454254626"b3; /* "$ ENDJOB ***EOF" */ ejb_found = "1"b; /* same as for $ENDJOB */ go to WRITE; end; end; if dollar_card /* image is a $ card image */ then do; call cv_bcd_to_ascii_ (write_ptr, ascii_ptr); /* convert card image to ascii */ /* SNUMB */ if substr (ascii, 8, 5) = "snumb" /* error, SNUMB card in job stream */ then do; call com_err_ (0, "gcos_read_", "SNUMB card found in job stream"); code = 2; /* return fatal error */ go to DETACH; end; /* ENDCOPY */ if substr (ascii, 8, 7) = "endcopy" /* endcopy card */ then do; card_is_data = "0"b; /* following cards are not data */ go to WRITE; end; /* DATA CHECK */ if card_is_data /* in between data and endcopy card */ then go to WRITE; /* ignore card */ /* ENDJOB */ if substr (ascii, 8, 6) = "endjob" /* end of job card */ then do; ejb_found = "1"b; go to WRITE; end; /* DATA */ if substr (ascii, 8, 4) = "data" /* data card */ then do; if substr (ascii, 20, 1) = "," /* there is a second field on the card image */ then do; do i = 17 to 70 while (substr (ascii, i, 1) ^= ","); /* check for third field */ end; if i < 70 /* third field exists */ then if substr (ascii, i+1, 4) = "copy" /* it contains the copy option */ then card_is_data = "1"b; /* following cards are data */ end; go to WRITE; end; /* IDENT */ if substr (ascii, 8, 5) = "ident" /* ident card */ then if ^ident_found /* use first $IDENT card only */ then do; ident_found = "1"b; /* checked at end of current job stream */ do j = 16 to 80 while (substr (ascii, j, 1) ^= ","); /* look for end of epa number */ end; if (j = 16)| (j>79) /* format error */ then do; code = 1; /* return non-fatal error */ call com_err_ (0, "gcos_read_", "Format error on ident card: SNUMB = ^a", gcos_daemon_stat_$snumb); go to DETACH; end; epa_num = substr (ascii, 16, j-16); /* pick off epa number */ call gcos_user_$validate (epa_num, gutep, code); if code ^= 0 /* some error from validate procedure */ then do; if code < 3 /* password or missing entry error */ then do; call com_err_ (0, "gcos_read_", "Error in epa number: SNUMB = ^a", gcos_daemon_stat_$snumb); code = 1; /* non-fatal error */ go to DETACH; end; else /* some problem with gcos_user table */ do; call com_err_ (code, "gcos_read_", "***ATTENTION***^/Error in gcos user table: code = ^d", code); code = 2; /* return fatal error */ go to DETACH; end; end; if ^epa_found /* an epa was not yet encountered */ then do; do j = 22 to 1 by -1 while /* find last char in multics user name */ (substr (gutep -> gute_multics_person, j, 1) = " "); end; do k = 9 to 1 by -1 while /* find end of multics project name */ (substr (gutep -> gute_multics_project, k, 1) = " "); end; user_name = substr (gcos_daemon_stat_$anonymous_user, 1, gcos_daemon_stat_$anonymous_user_len); /* set absentee user name */ absentee_dir, home_dir = substr (gcos_daemon_stat_$home_root_dir, 1, gcos_daemon_stat_$home_root_dir_len) ||">"||substr (gutep -> gute_multics_project, 1, k)||">" ||substr (gutep -> gute_multics_person, 1, j); /* make up new home dir path name */ dir_name = absentee_dir; /* prepare for entry check call */ call check_entry; /* see if job already exists */ if code ^= 0 /* job already exists or fatal error */ then go to DETACH; do ac_name = absentee_dir, home_dir; /* check daemon's access to these dirs */ call check_access (ac_name, my_name); if code ^= 0 /* error checking access */ then go to DETACH; end; epa_found = "1"b; /* remember a epa number was found */ end; go to WRITE; end; /* MSG3 */ if substr (ascii, 8, 4) = "msg3" /* deferral card */ then if ^deferral_switch /* one was not yet found */ then do; call gcos_convert_time_ (substr (ascii, 16, 12), deferral, code); /* convert to Multics time */ if code ^= 0 /* error converting time */ then do; call com_err_ (0, "gcos_read_", "Invalid time field on msg3 card: SNUMB = ^a", gcos_daemon_stat_$snumb); go to DETACH; end; deferral_switch = "1"b; /* fill in absentee information */ go to WRITE; end; end; go to WRITE; %page; DETACH: if ^ident_found then do; NO_IDENT: call com_err_ (0, "gcos_read_", "Missing or invalid ident card: SNUMB = ^a", gcos_daemon_stat_$snumb); code = 1; end; call end_work; /* finish processing */ if code = 0 /* no error occurred */ then do; input_segment_name = segment_name; if ^epa_found /* no epa image was encountered */ then do; absentee_dir = pool_dir; home_dir = default_home_dir; user_name = "Anonymous.GCOS.*"; end; do dir_name = input_dir, absentee_dir, home_dir; /* check users access to these dirs */ call check_access (dir_name, user_name); end; call hcs_$set_ring_brackets (input_dir, segment_name, rb, code); /* set ring brackets */ if code ^= 0 then do; call com_err_ (code, "gcos_read_", "Error setting ring brackets for ^a>^a", input_dir, segment_name); go to RETURN; end; call hcs_$acl_add1 (input_dir, segment_name, user_name, 01111b, ringbrackets, code); /* set users access */ if code ^= 0 /* error setting access */ then call com_err_ (code, "gcos_read_", "Error setting access on ^a>^a", input_dir, segment_name); end; RETURN: if code ^= 0 /* some error occurred */ then data_blank = "0"b; /* zero out absentee data structure */ a_eof_found = eof_found; /* return flag */ a_code = code; /* return error code */ return; %page; check_access: proc (c_dir_name, c_user_name); dcl ( c_user_name ) char (32) aligned; dcl ( c_dir_name ) char (168) aligned; i = index (c_dir_name, " ") - 1; if i = -1 then i = 168; call expand_path_ (addr (c_dir_name), i, addr (run_dn), addr (run_en), code); if code ^= 0 then do; call com_err_ (code, "gcos_read_", "Error expanding ^a", c_dir_name); code = 2; /* fatal error */ go to RETURN; end; call hcs_$get_user_effmode (run_dn, run_en, c_user_name, user_ring, dir_mode, code); /* check access */ if code ^= 0 then do; call com_err_ (code, "gcos_read", "Error getting access to ^a", c_dir_name); go to RETURN; end; if (bit (dir_mode, 5) & "01011"b) ^= "01011"b /* user doesn't have access */ then do; call com_err_ (error_table_$moderr, "gcos_read_", "^a to ^a", c_user_name, c_dir_name); code = 1; /* error is not fatal */ go to RETURN; end; return; end check_access; %page; check_entry: proc; call gcos_daemon_temp_$star_ (dir_name, segment_name, 3, null, ecount, null, null, code); if code ^= 0 /* error from gcos_daemon_temp_$star_ */ then do; call com_err_ (code, "gcos_read_", "Error searching ^a for ^a", dir_name, segment_name); if code = error_table_$noentry /* not fatal error */ then code = 1; /* return non-fatal error */ return; end; if ecount ^= 0 /* SNUMB already on system. */ then if ^dup_resolved () /* Try to resolve the duplication. */ then do; code = 1; /* Set code to non-fatal. */ call end_work; end; return; end check_entry; %page; dup_resolved: proc () returns (bit (1)); start_snumb = rtrim (gcos_daemon_stat_$snumb); query_info.version = query_info_version_4; query_info.switches = "0"b; /* Standard format. */ query_info.switches.cp_escape_control = "10"b; /* No command escape. */ query_info.status_code = 0; query_info.query_code = 0; query_info.question_iocbp = null (); /* Normal I/O switches. */ query_info.answer_iocbp = null (); query_info.repeat_time = 45; /* Wait 45 seconds to repeat question. */ call command_query_ (addr (query_info), query_response, "gcos_daemon", "Duplicate SNUMB - ^a. Abort or resolve (a/r)?", start_snumb); bail_out = "0"b; if substr (query_response, 1, 1) = "r" then do; start_snumb, temp_snumb = substr (rtrim (start_snumb) || "00000", 1, 5); do while (^bail_out); temp_snumb = next_snumb (temp_snumb); temp_segname = rtrim (temp_snumb) || ".*"; if temp_snumb = start_snumb /* If we've come full circle and have */ /* yet to resolve the duplication. */ then do; bail_out = "1"b; resolved = "0"b; end; else do temp_dir_name = input_dir, pool_dir while (^bail_out); call gcos_daemon_temp_$star_ (temp_dir_name, temp_segname, 3, null, ecount, null, null, code); if code ^= 0 then do; call com_err_ (code, "gcos_read_", "^/Error while attempting to resolve duplicate SNUMB ^a", gcos_daemon_stat_$snumb); resolved = "0"b; bail_out = "1"b; end; else if ecount = 0 then do; call ioa_ ("gcos_daemon: SNUMB #^a entered as #^a", gcos_daemon_stat_$snumb, temp_snumb); snumb_length1 = 5; /* Gotta set the values so caller /* doesn't get all confoozed. */ gcos_daemon_stat_$snumb = temp_snumb; bail_out = "1"b; resolved = "1"b; end; end; end; end; else resolved = "0"b; return (resolved); dcl bail_out bit (1); dcl query_response char (80) varying; dcl resolved bit (1); dcl (start_snumb, temp_snumb) char (5); dcl temp_segname char (32) aligned; dcl temp_dir_name char (168) aligned; end dup_resolved; %page; end_work: proc; if gsr_write_init_called then do; call gcos_gsr_write_$gsr_write_close ("segment_output", code2); if code2 ^= 0 then do; call com_err_ (code2, "gcos_read_", "Error from gsr_write_close"); if code < 2 /* no fatal error yet */ then code = code2; /* return this one */ end; end; if output_is_attached /* output stream is attached */ then do; call ios_$detach ("segment_output", "file_", "", status_stuff); /* detach the output stream */ code2 = status.code; /* check error code */ if code2 ^= 0 /* error detaching output stream */ then do; call com_err_ (code2, "gcos_read_", "Unable to detach ^a", segment_name); if code <= 1 /* no previous fatal error */ then code = code2; /* return this one */ end; else output_is_attached = "0"b; end; end end_work; %page; next_snumb: proc (in_string) returns (char (5)); dcl in_string char (5) parm; dcl in_length fixed bin; conv_block = in_string; /* Put it where we can work on it. */ in_length = length (rtrim (conv_block)); if in_length ^= 0 then do; if conv_ovrl (in_length) = 57 then conv_ovrl (in_length) = 97; else if conv_ovrl (in_length) = 122 then conv_block = rtrim (next_snumb (substr (in_string, 1, in_length-1))) || "0"; else conv_ovrl (in_length) = conv_ovrl (in_length) + 1; end; return (conv_block); dcl conv_block char (5) aligned; dcl conv_ovrl (5) fixed bin (9) unsigned unaligned based (addr (conv_block)); dcl conv_ptr pointer; dcl ret_string char (5); end next_snumb; %page; /* DECLARATIONS */ /* ------------ */ /* fixed bin */ /* ----- --- */ dcl ( a_root_dir_len, /* length of root directory path-name (argument) */ a_urgency, /* urgency field from SNUMB card (argument) */ ecount, /* number of segments from gcos_daemon_temp_$star_ call */ elements_read, /* elements read from ios_$read call */ elements_written, /* elements written from ios_$write call */ gcos_daemon_stat_$default_home_dir_len ext, /* length of pn */ gcos_daemon_stat_$home_root_dir_len ext, /* length of pn */ gcos_daemon_stat_$input_dir_len ext, /* character count of input directory */ gcos_daemon_stat_$pool_dir_len ext, /* character count of pool directory */ gcos_daemon_stat_$root_dir_len ext, /* character count of root directory */ gcos_daemon_stat_$anonymous_user_len ext, /* character count of anonymous user */ i, /* random variable */ j, /* random variable */ k, /* random variable */ root_dir_len int static, /* length of root directory path-name (internal) */ snumb_length1, /* length of SNUMB + 1 */ user_ring int static, /* for effmode call */ card_no, /* sequence number for reading cards */ write_size /* number of elements to write into segment */ ) fixed bin aligned; dcl ( dir_mode /* access of user to dir_name */ ) fixed bin (5) aligned; dcl ringbrackets (0:2) fixed bin (6) aligned int static init (5, 5, 5); dcl rb (3) fixed bin (3) init (5, 5, 5) aligned; /* ringbrackets for set_ring_brackets call */ dcl ( a_code, /* error code (argument) */ code, /* error code (internal) */ code2, /* error code (internal) */ error_table_$namedup ext, error_table_$moderr ext, error_table_$noentry ext ) fixed bin (35) aligned; /* bit strings */ /* --- ------- */ dcl ( a_eof_found /* ON if end of read input encountered (argument) */ ) bit (1) aligned; dcl ( record_header /* record header from tape returned from gsr_read_ */ ) bit (12) aligned; dcl ( card_is_data, /* ON between data and endcopy cards */ dollar_card, /* ON when a $ card is being processed */ ejb_found, /* ON when end of job card found */ eof_found, /* ON if end of read input encountered (internal) */ ident_found, /* ON when at least one IDENT card found in job stream */ epa_found, /* ON once epa number is found */ gsr_write_init_called, /* ON once gsr_write_init is called */ initialized int static, /* ON once this procedure has been called */ output_is_attached, /* ON once output has been attached */ reading_cards /* ON when cards are being read */ ) bit (1) aligned init ("0"b); dcl ( status_stuff /* returned from ios_ calls */ ) bit (72) aligned; dcl ( input /* binary card image */ ) bit (972) aligned; /* pointer */ /* ------- */ dcl ( a_abs_data_ptr, /* pointer to absentee job info (argument) */ a_input_ptr, /* pointer to bcd SNUMB card (argument) */ ascii_ptr, /* pointer to ascii card image */ input_ptr, /* pointer to binary card image */ rh_ptr, /* pointer for looking at record header */ sp, /* pointer to returned status from ios_ calls */ write_ptr /* points to data to be written */ ) ptr aligned; /* character strings */ /* --------- ------- */ dcl ( gcos_daemon_stat_$snumb ext ) char (6) aligned; dcl (snumb /* SNUMB (internal) */ ) char (8) aligned; dcl ( epa_num, /* epa number from ident card */ stream_name /* device from which to read (internal) */ ) char (12) aligned; dcl ( my_name int static, /* id of caller of this proc */ run_en, /* for checking dir access */ segment_name /* old segment name */ ) char (32) aligned; dcl ( ascii init ("") /* ascii card image */ ) char (80) aligned; dcl ( ac_name, /* used in loop call */ default_home_dir int static, /* default Anonymous home dir */ dir_name, /* for do loop */ gcos_daemon_stat_$default_home_dir ext, /* default Anonymous home dir */ gcos_daemon_stat_$home_root_dir ext, /* root portion of all GCOS home dirs */ gcos_daemon_stat_$input_dir ext, /* input directory */ gcos_daemon_stat_$pool_dir ext, /* pool directory */ gcos_daemon_stat_$root_dir ext, /* root directory */ gcos_daemon_stat_$anonymous_user ext, /* name of default anonymous user */ input_dir int static, /* input directory (internal) */ pool_dir int static, /* pool directory (internal) */ root_dir int static, /* root directory (internal) */ run_dn /* for checking dir access */ ) char (168) aligned; /* built in */ /* ----- -- */ dcl ( addr, bit, fixed, index, null, rel, substr ) builtin; /* masks */ /* ----- */ dcl first_bcd_char bit (6) unaligned based (write_ptr); dcl tape_input_record bit (504) aligned based (write_ptr); dcl 1 record_header_mask aligned based (rh_ptr), 2 pad bit (2) unaligned, 2 media_code bit (4) unaligned, 2 report_code bit (6) unaligned; dcl 1 status based (sp) aligned, /* for examining status from ios_ */ 2 code fixed bin (35) aligned, 2 pad bit (9) unaligned, 2 eof bit (1) unaligned; /* conditions */ /* ---------- */ dcl ( cleanup ) condition; /* external entries */ /* -------- ------- */ dcl com_err_ entry() options(variable); dcl command_query_ entry() options(variable); dcl ioa_ entry() options(variable); dcl cv_bcd_to_ascii_ ext entry (ptr aligned, ptr aligned); dcl cv_bin_to_bcd_ ext entry (ptr aligned, ptr aligned, fixed bin (35) aligned); dcl expand_path_ ext entry (ptr aligned, fixed bin aligned, ptr aligned, ptr aligned, fixed bin (35) aligned); dcl gcos_convert_time_ ext entry (char (16) aligned, fixed bin (71) aligned, fixed bin (35) aligned); dcl gcos_daemon_temp_$star_ ext entry (char (*) aligned, char (*) aligned, fixed bin (2) aligned, ptr aligned, fixed bin aligned, ptr aligned, ptr aligned, fixed bin (35) aligned); dcl gcos_user_$validate ext entry (char (12) aligned, ptr aligned, fixed bin (35) aligned); dcl gcos_gsr_read_ ext entry (char (*) aligned, ptr aligned, fixed bin aligned, bit (12) aligned, bit (1) aligned, fixed bin (35) aligned); dcl gcos_gsr_write_ ext entry (char (*) aligned, ptr aligned, fixed bin aligned, bit (12) aligned, bit (1) aligned, fixed bin (35) aligned); dcl gcos_gsr_write_$gsr_write_close ext entry (char (*) aligned, fixed bin (35) aligned); dcl gcos_gsr_write_$gsr_write_init ext entry (char (*) aligned, fixed bin (35) aligned); dcl get_ring_ ext entry returns (fixed bin (6) aligned); dcl get_group_id_$tag_star ext entry returns (char (32) aligned); dcl hcs_$acl_add1 ext entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (5) aligned, (0:2) fixed bin (6) aligned, fixed bin (35) aligned); dcl hcs_$set_ring_brackets ext entry (char (*) aligned, char (*) aligned, (3) fixed bin (3) aligned, fixed bin (35) aligned); dcl hcs_$get_user_effmode ext entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin aligned, fixed bin (5) aligned, fixed bin (35) aligned); dcl ios_$attach ext entry (char (*) aligned, char (*) aligned, char (*) aligned, char (*) aligned, bit (72) aligned); dcl ios_$detach ext entry (char (*) aligned, char (*) aligned, char (*) aligned, bit (72) aligned); dcl ios_$read ext entry (char (*) aligned, ptr aligned, fixed bin aligned, fixed bin aligned, fixed bin aligned, bit (72) aligned); dcl ios_$setsize ext entry (char (*) aligned, fixed bin aligned, bit (72) aligned); %page; % include gcos_abs_data; %page; % include gcos_user_table_entry_; %page; %include query_info; end gcos_read_;  gcos_read_cards_.pl1 11/19/82 1409.3rew 11/19/82 0853.2 87444 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ gcos_read_cards_: proc (a_stream_name, a_test, a_eof_found, a_code); /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ %page; /* MODIFIED: Scott C. Akers 31 MAR 82 To make use of the snumb variable in gcos_daemon_stat_, rather than pass it as a parameter 'twixt all and sundry. */ %page; input_ptr = addr (input); /* pointer to card image */ output_ptr = addr (ascii); /* pointer to ascii card image */ sp = addr (status_stuff); /* pointer to returned status */ on condition (cleanup) /* establish cleanup condition handler */ call wrap_up ("1"b); stream_name = a_stream_name; /* copy argument */ code = 0; /* initialize error code */ READ: call get_snumb; /* read first card and check for "SNUMB" */ if code > 1 /* fatal error */ then go to RETURN; if eof_found /* end of deck found */ then go to RETURN; if code = 0 /* no error occurred */ then if ^snumb_found /* the card was not a SNUMB card */ then call com_err_ (0, "gcos_read_cards_", "Expected SNUMB card not found"); if (^snumb_found)| (code = 1) /* no SNUMB or error in input */ then do while (^status.eof & ^eof_found); /* search for another SNUMB card */ call get_snumb; if code > 1 then go to RETURN; if code = 0 then if (snumb_found) then go to RETURN; end; RETURN: if (code>1)| (eof_found) /* fatal error or ***eof */ then call wrap_up ("0"b); if ^eof_found /* no eof card yet */ then go to READ; /* try again */ a_eof_found = eof_found; /* return argument */ a_code = code; /* return error code */ return; %page; /* INTERNAL PROCEDURES */ get_snumb: proc; eof_found, /* initialize flags */ eoc_found, snumb_found = "0"b; READ: call ios_$read (stream_name, input_ptr, 0, 1, elements_read, status_stuff); /* read in a card */ code = status.code; /* extract code from status bit string */ if code ^= 0 /* error reading */ then do; call com_err_ (code, "gcos_read_cards_", "Error reading from card reader"); return; end; if status.eof /* "last batch button" and eof */ then do; code = 2; /* cause return to command level */ return; end; if substr (input, 10, 2) = "101"b /* this is a binary card */ then return; /* it can't be a SNUMB card */ call cv_bin_to_bcd_ (input_ptr, input_ptr, code); /* convert card image to bcd */ if code ^= 0 /* error converting card */ then do; code = 0; /* prevents return from external procedure */ return; end; call cv_bcd_to_ascii_ (input_ptr, output_ptr); if substr (ascii, 1, 1) = "$" /* check for SNUMB card */ then do; if substr (ascii, 8, 5) = "snumb" then do; snumb_found = "1"b; /* got it */ do i = 16 to 80 while /* find end of SNUMB */ ((substr (ascii, i, 1) ^= " ")& (substr (ascii, i, 1) ^= ",")); end; if i = 17 /* error, no SNUMB argument */ then do; code = 1; /* return non-fatal error */ call com_err_ (0, "gcos_read_cards_", "Missing argument on SNUMB card"); return; end; gcos_daemon_stat_$snumb = substr (ascii, 16, i-16); if substr (ascii, i, 1) = "," /* card contains urgency field */ then do; do j = i + 1 to 80 while /* find end of urgency field */ (substr (ascii, j, 1) ^= " "); end; urgency = cv_dec_check_ (substr (ascii, i+1, j-i-1), code); /* pick off urgency field */ if code ^= 0 /* error converting urgency field */ then do; call com_err_ (0, "gcos_read_cards_", "Invalid urgency field: SNUMB = ^a", gcos_daemon_stat_$snumb); return; end; if (urgency < 1)| (urgency > 63) /* urgency field out of bounds */ then do; call com_err_ (0, "gcos_read_cards_", "Urgency field out of bounds: SNUMB = ^a", gcos_daemon_stat_$snumb); return; end; urgency = divide (63-urgency, 21, 17, 0)+1; /* convert to queue number */ end; else /* no urgency field on card */ urgency = 3; /* set default urgency */ if ^eoc_found /* more input to come */ then do; /* read the job */ call gcos_read_$cards (urgency, input_ptr, addr (gcos_abs_data), eoc_found, code); if code ^= 0 /* error reading job */ then return; call gcos_queue_job_ (addr (gcos_abs_data), a_test, code); /* queue the job */ if code ^= 0 /* error queueing job */ then return; end; end; end; else /* not SNUMB card */ if substr (ascii, 1, 6) = "***eof" /* eof card */ then eof_found = "1"b; if eoc_found /* end of input occurred */ then do; if ^eof_found /* ***eof card not found */ then do; call com_err_ (0, "gcos_read_cards_", "Unexpected eof: SNUMB = ^a", gcos_daemon_stat_$snumb); code = 2; end; else /* ***eof card found */ call ioa_ ("Normal Termination"); end; return; end get_snumb; %page; wrap_up: proc (cleanup_was_signalled); dcl cleanup_was_signalled bit (1) aligned; if cleanup_was_signalled | code > 1 /* abort or fatal error */ then do; call ios_$resetread (stream_name, status_stuff); /* delete any read-ahead */ code2 = status.code; if code2 ^= 0 /* error deleting read-ahead */ then do; call com_err_ (code2, "gcos_read_cards_", "Error resetting ^a", stream_name); if code <= 1 /* no fatal error occurred yet */ then code = code2; /* return this one */ end; end; if (code ^= 0)| (cleanup_was_signalled) /* error occurred or job was aborted */ then do; if gcos_daemon_stat_$snumb = "" then return; call hcs_$delentry_file (get_wdir_ (), rtrim (gcos_daemon_stat_$snumb)||".gcos", code2); end; a_eof_found = eof_found; /* return argument */ return; end wrap_up; %page; /* DECLARATIONS */ /* ------------ */ /* fixed bin */ /* ----- --- */ dcl ( elements_read, /* elements read from ios_ call */ i, /* random variable */ j, /* ditto */ urgency /* priority queues to be used */ ) fixed bin aligned; dcl ( a_code, /* error code (argument) */ code, /* error code (internal) */ code2 /* secondary internal error code */ ) fixed bin (35) aligned; /* bit strings */ /* --- ------- */ dcl ( a_eof_found, /* ON when last job card is read */ a_test, /* ON when user brings up daemon */ eoc_found, /* ON when end of read input encountered */ eof_found, /* ON when last card is read */ snumb_found /* ON when a SNUMB card is found */ ) bit (1) aligned; dcl ( status_stuff /* returned status from ios_ calls */ ) bit (72) aligned; dcl ( input /* card image */ ) bit (972) aligned; /* pointers */ /* -------- */ dcl ( input_ptr, /* pointer to card image */ output_ptr, /* pointer to ascii card image */ sp /* pointer to returned status */ ) pointer aligned; /* character strings */ /* --------- ------- */ dcl gcos_daemon_stat_$snumb ext char (6) aligned; /* dcl snumb char (8) aligned; */ dcl ( a_stream_name, /* stream name on which to read (argument) */ stream_name /* same (internal) */ ) char (12) aligned; dcl ( ascii /* ascii card image */ ) char (80) aligned; /* built in */ /* ----- -- */ dcl ( addr, divide, index, substr ) builtin; /* masks */ /* ----- */ dcl 1 status based (sp) aligned, /* mask for checking status from ios_ */ 2 code fixed bin aligned, 2 pad bit (9) unaligned, 2 eof bit (1) unaligned; /* include files */ /* ------- ----- */ % include gcos_abs_data; % include gcos_abs_data_storage; /* conditions */ /* ---------- */ dcl ( cleanup )condition; /* external entries */ /* -------- ------- */ dcl com_err_ ext entry options (variable); dcl cv_bcd_to_ascii_ ext entry (ptr aligned, ptr aligned); dcl cv_bin_to_bcd_ ext entry (ptr aligned, ptr aligned, fixed bin (35) aligned); dcl cv_dec_check_ ext entry (char (*) aligned, fixed bin (35) aligned) returns (fixed bin aligned); dcl gcos_queue_job_ ext entry (ptr aligned, bit (1) aligned, fixed bin (35) aligned); dcl gcos_read_$cards ext entry (fixed bin aligned, ptr aligned, ptr aligned, bit (1) aligned, fixed bin (35) aligned); dcl get_wdir_ ext entry returns (char (168) aligned); dcl hcs_$delentry_file ext entry (char (*) aligned, char (*) aligned, fixed bin (35) aligned); dcl ioa_ ext entry options (variable); dcl ios_$read ext entry (char (*) aligned, ptr aligned, fixed bin aligned, fixed bin aligned, fixed bin aligned, bit (72) aligned); dcl ios_$resetread ext entry (char (*) aligned, bit (72) aligned); end gcos_read_cards_;  gcos_read_tape_.pl1 11/19/82 1409.3rew 11/19/82 0853.2 217836 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* ******************************************************************** * * * WRITTEN BY: P. Haber March 21, 1974 * * MODIFIED BY: R.H. Morrison September 19, 1974 * * MODIFIED BY: R.H. Morrison September 12, 1975 * * * ******************************************************************** */ gcos_read_tape_: proc (a_request, a_request_len, a_test); %page; ap = addr (request); /* argument pointer */ ascii_ptr = addr (ascii); /* pointer to ascii version of card image */ bcd_ptr = addr (b972); /* pointer to bcd version of card image */ rh_ptr = addr (record_header); /* pointer to returned status from gcos_gsr_read_ */ request_p = addr (request); /* pointer to request line */ sp = addr (status_bits); /* pointer to status returned from ios calls */ on condition (cleanup) /* set up condition handler */ call wrap_up ("1"b); /* check request line */ request = a_request; /* copy in arguments */ request_len = a_request_len; call get_arg; /* fetch the first argument */ if arg = "imcv7" /* request to read 7 track tape */ then do; tape_type = ",7track"; i = 6; /* have parsed 6 characters */ end; else if arg = "imcv" /* 9 track request */ then do; tape_type = ",9track"; i = 5; /* have parsed 5 characters */ end; else /* error, unrecognized request */ do; call com_err_ (0, "gcos_read_tape_", "Invalid tape read command^/^a", request); go to RETURN; end; call get_arg; if code = error_table_$noarg /* missing argument .. tape label */ then do; call com_err_ (code, "gcos_read_tape_", "Error in request ^/^a", request); go to RETURN; end; tape_label = arg||tape_type; call get_arg; /* get argument from command line */ if code = error_table_$noarg /* error, missing argument ... keyword */ then do; call com_err_ (code, "gcos_read_tape_", "Error in request^/^a", request); go to RETURN; end; else /* found argument */ if arg = "all" | arg = "-all" /* wants to execute all jobs */ then all_snumbs_wanted = "1"b; else if arg = "take" | arg = "-take" /* wants to execute specified SNUMBs */ then taking_given_snumbs = "1"b; else if arg = "start" | arg = "-start" /* wants to execute all SNUMBs after given one */ then starting_from_given_snumb = "1"b; else if arg ^= "delete" & arg ^= "-delete" /* unrecognized request */ then do; call com_err_ (0, "gcos_read_tape_", "invalid argument ^a", arg); go to RETURN; end; call get_arg; /* get next argument */ if code = 0 /* there is another argument */ then do; if all_snumbs_wanted /* error, shouldn't be another argument */ then do; call com_err_ (0, "gcos_read_tape_", "Too many arguments in ^/^a", request); go to RETURN; end; end; else /* no more arguments */ if ^all_snumbs_wanted /* error, need at least 1 more argument */ then do; call com_err_ (code, "gcos_read_tape_", "Error in request ^/^a", request); go to RETURN; end; do while (code = 0); /* get remaining arguments */ if al > 5 /* SNUMB too long */ then do; call com_err_ (0, "gcos_read_tape_", "SNUMB ^a too long", arg); go to RETURN; end; snumb_count = snumb_count + 1; /* increment SNUMB count */ if (snumb_count>5)| (snumb_count>2 & starting_from_given_snumb) /* error, too many SNUMBs */ then do; call com_err_ (0, "gcos_read_tape_", "Too many SNUMBs specified in ^/^a", request); go to RETURN; end; do i = 1 to snumb_count -1; /* check for SNUMB duplication */ if snumb_data (i).snumb = arg /* got one */ then do; call com_err_ (error_table_$namedup, "gcos_read_tape_", "in ^/^a", request); go to RETURN; end; end; snumb_data (snumb_count).snumb = arg; /* save snumb_data */ call get_arg; end; %page; /* set up gcos_gsr_read_ */ if ^test_attach /* tape needs to be attached */ then do; call ios_$attach ("tape_input", gcos_daemon_stat_$tape_dim, tape_label, "r", status_bits); code = status.code; if code ^= 0 /* error attaching tape */ then do; call com_err_ (code, "gcos_read_tape_", "Error attaching tape ^a", tape_label); go to RETURN; end; tape_is_attached = "1"b; /* remember tape is attached */ end; call gcos_gsr_read_$gsr_read_init ("tape_input", code); /* initialize read call */ if code ^= 0 /* error in init call */ then do; call com_err_ (code, "gcos_read_tape_", "Error in call to gsr_read_init"); call wrap_up ("0"b); go to RETURN; end; else /* no error */ gsr_read_init_called = "1"b; /* remember it was called */ do i = 1 to 2; /* skip over tape label, tape mark */ call ios_$read ("tape_input", bcd_ptr, 0, 27, elements_read, status_bits); if substr (status_bits, 1, 3) = "100"b /* hardware status returned */ then do; if substr (status_bits, 27, 4) ^= "0100"b /* not "tape mark" status */ then do; call com_err_ (0, "gcos_read_tape_", "Unexpected hardware status from nstd_: ^w^w", substr (status_bits, 1, 36), substr (status_bits, 37, 36)); call wrap_up ("0"b); go to RETURN; end; end; else /* no status returned */ if status.code ^= 0 /* error code returned */ then do; call com_err_ (status.code, "gcos_read_tape_", "Error reading tape ^a", tape_label); call wrap_up ("0"b); go to RETURN; end; end; %page; READ: /* read the tape */ if fin /* all needed SNUMBs were found */ then do; call wrap_up ("0"b); go to RETURN; end; call read; if code ^= 0 /* error in read call */ then do; call com_err_ (code, "gcos_read_tape_", "Error reading from tape"); call wrap_up ("0"b); go to RETURN; end; if eot_was_found /* end of tape */ then do; if ^all_snumbs_wanted /* specified SNUMBs were being searched for */ then call check_snumbs; /* inform as to SNUMBs not found */ call wrap_up ("0"b); go to RETURN; end; call cv_bcd_to_ascii_ (buf_ptr, ascii_ptr); /* convert card to ascii */ if substr (ascii, 1, 6) = "***eof" /* tapes sometimes have eofs */ then do; if last_image_was_eof /* error, 2 eof images in a row */ then do; call com_err_ (0, "gcos_read_tape_", "Unexpected eof image on tape ^a", tape_label); call wrap_up ("0"b); go to RETURN; end; last_image_was_eof = "1"b; /* remember for next read */ go to READ; /* and read another card */ end; else /* card not "***eof" */ last_image_was_eof = "0"b; /* remember */ if (substr (ascii, 1, 1) ^= "$") /* not a SNUMB card image */ | (substr (ascii, 8, 5) ^= "snumb") then do; call com_err_ (0, "gcos_read_tape_", "Expected SNUMB not found on tape ^a", tape_label); call find_ejb; if (eot_was_found)| (code ^= 0) /* error or end of tape */ then do; if code = 0 then call check_snumbs; call wrap_up ("0"b); go to RETURN; end; go to READ; end; if all_snumbs_wanted /* all jobs are to be executed */ then do; call parse_and_check_snumb; /* parse the SNUMB (no check for "all") */ if code ^= 0 /* error parsing SNUMB */ then do; call find_ejb; if code ^= 0 /* error finding eof image */ then do; call wrap_up ("0"b); go to RETURN; end; go to READ; end; call read_and_queue; /* queue up current job */ if (code > 1)| (eot_was_found) /* error or end of tape */ then do; call wrap_up ("0"b); go to RETURN; end; go to READ; /* get another job */ end; if (taking_given_snumbs)| (starting_from_given_snumb) then do; call parse_and_check_snumb; /* check to see if this is needed SNUMB */ if (^snumb_found)| (code ^= 0) /* SNUMB not in array or already found */ then do; if ^starting_snumb_found /* not a start request with first SNUMB found */ then do; call find_ejb; if (eot_was_found)| (code ^= 0) /* error or end of tape */ then do; if code = 0 then call check_snumbs; call wrap_up ("0"b); go to RETURN; end; if ^snumb_found /* no data to update */ then go to READ; /* get another job */ end; end; if starting_from_given_snumb then do; if snumb_count = 1 /* found the only specified SNUMB */ then do; all_snumbs_wanted = "1"b; /* execute remaining jobs on tape */ starting_from_given_snumb = "0"b; end; else /* start and finish SNUMB supplied */ do; if ^snumb_data (1).found /* error found finish before start */ then do; call com_err_ (0, "gcos_read_tape_", "Error in ^/^a^/^a found before ^a", request, snumb_data (2).snumb, snumb_data (1).snumb); call wrap_up ("0"b); go to RETURN; end; else do; if found_count = 2 /* found second */ then fin = "1"b; /* finished after processing this one */ else /* first of 2 SNUMBs found */ starting_snumb_found = "1"b; /* remember */ end; end; end; else /* taking specified SNUMBs */ if found_count = snumb_count /* all needed SNUMBs found */ then fin = "1"b; /* done */ if code ^= 0 /* some error has occurred */ then go to READ; /* don't queue up job */ call read_and_queue; /* queue up current job */ if (code > 1)| (eot_was_found) /* fatal error or end of tape */ then do; if code < 2 /* not fatal error */ then call check_snumbs; call wrap_up ("0"b); go to RETURN; end; go to READ; /* get another job */ end; else /* deleting specified SNUMBs */ do; call parse_and_check_snumb; if (snumb_found)| (code ^= 0) then do; call find_ejb; if (code ^= 0)| (eot_was_found) /* error or end of tape */ then do; if code = 0 then call check_snumbs; call wrap_up ("0"b); go to RETURN; end; go to READ; end; else /* job to be executed */ do; call read_and_queue; if (code > 1)| (eot_was_found) /* fatal error or end of tape */ then do; if code < 2 /* not fatal error */ then call check_snumbs; call wrap_up ("0"b); go to RETURN; end; go to READ; end; end; RETURN: return; %page; /* internal procedures */ check_snumbs: proc; do i = 1 to snumb_count; if ^snumb_data (i).found /* SNUMB was not found on tape */ then call com_err_ (0, "gcos_read_tape_", "SNUMB ^a not found on tape ^a" , snumb_data (i).snumb, tape_label); end; return; end check_snumbs; find_ejb: proc; dcl ejb_was_found bit (1) aligned init ("0"b); do while (^ejb_was_found); call read; if eot_was_found /* end of tape */ then return; if code ^= 0 then do; call com_err_ (code, "gcos_read_tape_", "Error searching for $ endjob"); return; end; if media_code = "0010"b /* bcd image */ then if first_bcd_char = "101011"b /* "$" */ then do; call cv_bcd_to_ascii_ (buf_ptr, ascii_ptr); if substr (ascii, 8, 6) = "endjob" /* end of job card image found */ then ejb_was_found = "1"b; end; end; return; end find_ejb; get_arg: proc; do j = j to request_len while /* find beginning of next argument */ ((substr (request, j, 1) = " ")| (substr (request, j, 1) = " ")); end; do k = j to request_len while /* find end of argument */ ((substr (request, k, 1) ^= " ")& (substr (request, k, 1) ^= " ")); end; if k ^= request_len /* not last argument */ then k = k - 1; /* move index back to last char in arg */ if k < j /* no next argument */ then do; code = error_table_$noarg; return; end; code = 0; /* there is another argument */ ap = addr (request_p -> request_mask.char (j)); /* set argument pointer */ al = k - j + 1; /* set argument length */ j = k + 1; /* set beginning of next possible arg */ return; end get_arg; parse_and_check_snumb: proc; dcl (jj, kk, xb, xc, search_val) fixed bin aligned; dcl comma_found bit (1) aligned init ("0"b); comma_found, snumb_found = "0"b; /* initialize return argument */ xb = index (substr (ascii, 16), " "); /* locate first blank in variable field */ xc = index (substr (ascii, 16), ","); /* locate first comma in variable f eld */ if xb = 1 then do; code = 1; /* return error */ call com_err_ (0, "gcos_read_tape_", "A SNUMB is zero length on tape ^a", tape_label); return; end; if (xc = 0 | xc>xb) then xc = xb; /* either no comma or not in SNUMB number field */ /* set comma index to blank index */ else comma_found = "1"b; /* remember */ if (xb<10 & xc<7) then snumb = substr (ascii, 16, xc-1); /* put SNUMB in fixed location */ else do; snumb = substr (ascii, 16, 8); /* report first 8 characters of SNUMB */ code = 1; /* return error */ call com_err_ (0, "gcos_read_tape_", "SNUMB ^a too long on tape ^a", snumb, tape_label); return; end; search_val = search (substr (ascii, 16, xc-1), ",$/:."); /* search for invalid characters */ if (search_val ^= 0) | (substr (ascii, 16, xc-1) = substr ("00000", 1, xc-1)) then do; code = 1; /* return error */ call com_err_ (0, "gcos_read_tape_", "Invalid characters in SNUMB ^a on tape ^a", snumb, tape_label); return; end; if comma_found then do; urgency = cv_dec_check_ (substr (ascii, xc+16, xb-xc-1), code); /* convert to integer */ if code ^= 0 /* conversion error */ then do; call com_err_ (0, "gcos_read_tape_", "Invalid urgency field: SNUMB = ^a, tape ^a", snumb, tape_label); code = 1; return; end; if (urgency < 1)| (urgency > 63) /* invalid urgency field */ then do; urgency = 5; /* set to real gcos default value */ call com_err_ (0, "gcos_read_tape_", "Out of bounds urgency set to default value: SNUMB = ^a, tape ^a", substr (ascii, 16, xb-1), tape_label); end; urgency = divide (63-urgency, 21, 17, 0) + 1; /* convert to Multics priority */ end; else /* no urgency field */ urgency = 3; /* set default */ if ^all_snumbs_wanted /* specified SNUMBs wanted, check this one */ then do jj = 1 to snumb_count while (^snumb_found); if snumb = snumb_data (jj).snumb /* match found */ then do; snumb_found = "1"b; /* remember */ if snumb_data (jj).found /* SNUMB was already found */ then do; call com_err_ (0, "gcos_read_tape_", "SNUMB ^a duplicated on tape ^a", snumb, tape_label); code = 2; /* fatal error */ end; else do; snumb_data (jj).found = "1"b; found_count = found_count + 1; /* increment count of found SNUMBs */ end; end; end; return; end parse_and_check_snumb; read: proc; call gcos_gsr_read_ ("tape_input", buf_ptr, elements_read, record_header, eot_was_found, code); return; end read; read_and_queue: proc; gcos_daemon_stat_$snumb = rtrim (snumb); call gcos_read_$tape (urgency, buf_ptr, addr (gcos_abs_data), eot_was_found, code); if code ^= 0 /* error reading rest of job */ then do; if code ^= 1 /* error was fatal */ then return; if ^eot_was_found /* not end of tape */ then do; call find_ejb; /* find end of current job */ if code = 0 /* no error finding ejb */ then code = 1; /* return non-fatal error */ end; return; end; call gcos_queue_job_ (addr (gcos_abs_data), a_test, code); if code = 0 then snumb = " "; return; end read_and_queue; %page; wrap_up: proc (cleanup_was_signalled); dcl cleanup_was_signalled bit (1) aligned; if (tape_is_attached|test_attach) then do; if a_test /* test entry was called */ then do; /* check to see if tape should be dismounted */ call command_query_ (addr (query_data), answer, "gcos_read_tape_", "Should tape ^a be dismounted? ", tape_label); if substr (answer, 1, 2) = "no" /* don't dismount */ then do; call ios_$order ("tape_input", "rewind", null, status_bits); if status.code ^= 0 then call com_err_ (status.code, "gcos_read_tape_", "Error in order call to rewind ^a", tape_label); test_attach = "1"b; /* remember tape was only rewound */ go to NO_DETACH; end; end; call ios_$detach ("tape_input", tape_label, "", status_bits); /* detach the tape */ tape_is_attached = "0"b; test_attach = "0"b; /* allows another attach */ if status.code ^= 0 then do; if code < 2 /* no fatal error yet */ then code = status.code; call com_err_ (status.code, "gcos_read_tape_", "Error detaching tape ^a", tape_label); end; end; NO_DETACH: if gsr_read_init_called then do; call gcos_gsr_read_$gsr_read_close ("tape_input", code); gsr_read_init_called = "0"b; end; if (code ^= 0)| (cleanup_was_signalled) /* an error occurred or job was aborted */ then do; i = index (snumb, " ") - 1; if i < 1 then return; call hcs_$delentry_file (get_wdir_ (), substr (snumb, 1, i)||".gcos", code); end; return; end wrap_up; %page; /* DECLARATIONS */ /* ------------ */ /* fixed bin */ dcl ( a_request_len, /* length of tape command (argument) */ al, /* argument length */ arg_num init (0), /* argument count from command line */ elements_read, /* number of elements read in ios call */ found_count init (0), /* count of SNUMBs found on tape */ i, /* loop index */ j init (1), /* loop index */ k init (0), /* loop index */ request_len, /* length of tape command (internal) */ snumb_count init (0), /* number of SNUMBs in tape command */ urgency /* computed urgency from SNUMB image */ ) fixed bin aligned; dcl ( code, /* error code */ error_table_$namedup ext, error_table_$noarg ext ) fixed bin (35) aligned; /* pointers */ dcl ( ap, /* argument pointer */ ascii_ptr, /* pointer to ascii version of card image */ bcd_ptr, /* pointer to bcd version of card image */ buf_ptr, /* pointer to tape record read by gcos_gsr_read_ */ rh_ptr, /* pointer to returned status from gcos_gsr_read_ */ request_p, /* pointer to request line */ sp /* pointer to status returned from ios calls */ ) pointer aligned; /* bit strings */ dcl ( a_test /* ON when deamon brought up by user */ ) bit (1) aligned; dcl ( all_snumbs_wanted, /* ON when every job found will be queued */ eot_was_found, /* ON when end of tape is encountered */ fin, /* ON when all given SNUMBs are found */ gsr_read_init_called, /* ON once gcos_gsr_read_$gsr_read_init has been called */ last_image_was_eof, /* ON when last card image was "***eof" */ snumb_found, /* ON when a SNUMB is found on tape */ starting_from_given_snumb, /* ON when start imcv request is made */ starting_snumb_found, /* ON when 1st of 2 SNUMBs in "start" found */ taking_given_snumbs, /* ON when take imcv request is made */ tape_is_attached, /* ON when tape is attached */ test_attach int static /* ON when tape is rewound, not detached */ ) bit (1) aligned init ("0"b); dcl ( record_header /* returned status from gcos_gsr_read_ */ ) bit (12) aligned; dcl ( normal_termination /* ON until tape terminates abnormally */ ) bit (1) aligned init ("1"b); dcl ( status_bits /* status returned from ios calls */ ) bit (72) aligned; dcl ( b972 /* image read from tape */ ) bit (972) aligned; /* character strings */ dcl ( answer /* answer to command_query_ call */ ) char (4) aligned; dcl gcos_daemon_stat_$snumb ext char (6) aligned; dcl ( gcos_daemon_stat_$tape_dim ext, /* variable dim name for easy testing */ snumb init (""), /* SNUMB on current card */ tape_type /* = ",7track" or ",9track" */ ) char (8) aligned; dcl ( tape_label init ("") /* name of tape */ ) char (32) aligned; dcl ( ascii /* ascii version of card */ ) char (80) aligned; dcl ( a_request, /* imcv command (argument) */ request /* imcv command (internal) */ ) char (120) aligned; /* built in functions */ dcl ( addr, divide, index, null, substr ) builtin; /* structures */ dcl 1 query_data aligned, /* structure for command_query_ call */ 2 version fixed bin aligned init (2), 2 yes_or_no_switch bit (1) aligned init ("1"b), 2 suppress_name_switch bit (1) aligned init ("1"b), 2 status_code fixed bin (35) aligned, 2 query_code fixed bin (35) aligned; dcl 1 snumb_data (5) aligned, /* snumb data taken from command */ 2 snumb char (8) aligned, /* given SNUMB */ 2 found bit (1) aligned init ((5) (1) "0"b); /* ON once SNUMB is found on tape */ /* masks */ dcl arg char (al) based (ap) unaligned; /* argument taken from command line or console */ dcl first_bcd_char bit (6) unaligned based (buf_ptr); /* first bcd character on card image */ dcl input bit (612) unaligned based (buf_ptr); /* pointer to bcd image */ dcl 1 record_header_mask aligned based (rh_ptr), 2 pad bit (2) unaligned, 2 media_code bit (4) unaligned, 2 report_code bit (6) unaligned; dcl 1 request_mask aligned based, /* for looking at request character by character */ 2 char (request_len) char (1) unaligned; dcl 1 status based (sp) aligned, /* returned status from ios calls */ 2 code fixed bin (35) aligned, /* error code */ 2 pad bit (9) unaligned, 2 eof bit (1) unaligned; /* conditions */ dcl ( cleanup ) condition; /* external entries */ dcl com_err_ ext entry options (variable); dcl command_query_ ext entry options (variable); dcl cv_bcd_to_ascii_ ext entry (ptr aligned, ptr aligned); dcl cv_dec_check_ ext entry (char (*) aligned, fixed bin (35) aligned) returns (fixed bin aligned); dcl gcos_queue_job_ ext entry (ptr aligned, bit (1) aligned, fixed bin (35) aligned); dcl gcos_read_$tape ext entry (fixed bin aligned, ptr aligned, ptr aligned, bit (1)aligned, fixed bin (35)aligned); dcl get_wdir_ ext entry returns (char (168) aligned); dcl gcos_gsr_read_ ext entry (char (*) aligned, ptr aligned, fixed bin aligned, bit (12) aligned, bit (1) aligned, fixed bin (35) aligned); dcl gcos_gsr_read_$gsr_read_close ext entry (char (*) aligned, fixed bin (35) aligned); dcl gcos_gsr_read_$gsr_read_init ext entry (char (*) aligned, fixed bin (35) aligned); dcl hcs_$delentry_file ext entry (char (*) aligned, char (*) aligned, fixed bin (35) aligned); dcl ios_$attach ext entry (char (*) aligned, char (*) aligned, char (*) aligned, char (*) aligned, bit (72) aligned); dcl ios_$detach ext entry (char (*) aligned, char (*) aligned, char (*) aligned, bit (72) aligned); dcl ios_$order ext entry (char (*) aligned, char (*) aligned, ptr aligned, bit (72) aligned); dcl ios_$read ext entry (char (*) aligned, ptr aligned, fixed bin aligned, fixed bin aligned, fixed bin aligned, bit (72) aligned); %page; % include gcos_abs_data; %page; % include gcos_abs_data_storage; end gcos_read_tape_;  gcos_verify_user_.pl1 11/19/82 1409.3rew 11/19/82 0930.1 20214 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ gcos_verify_user_: proc (a_project, a_password, a_multics_person, a_multics_project, a_code); /* DECLARATIONS */ /* ------------ */ /* fixed bin */ dcl ( a_code, /* error code (argument) */ code /* error code (internal) */ ) fixed bin (35) aligned; /* character strings */ dcl ( a_multics_project /* multics equivalent of gcos project (argument) */ ) char (9) aligned; dcl ( a_password, /* GCOS password (argument) */ a_project, /* GCOS project (argument) */ password, /* GCOS password (internal) */ project /* gcos project (internal) */ ) char (12) aligned; dcl ( a_multics_person /* multics equivalent of gcos user (argument) */ ) char (22) aligned; /* include files */ % include gcos_user_table_entry_; /* external entries */ dcl gcos_user_$validate ext entry (char (12) aligned, char (12) aligned, ptr aligned, fixed bin (35) aligned); /* */ a_code = 0; /* initialize returned code */ project = a_project; /* copy in input arguments */ password = a_password; call gcos_user_$validate (project, password, gutep, code); /* validate password */ if code = 0 /* password is valid */ then do; a_multics_person = gutep -> gcos_user_table_entry_.gute_multics_person; a_multics_project = gutep -> gcos_user_table_entry_.gute_multics_project; end; else /* some error occurred */ do; a_multics_person, a_multics_project = ""; if code < 3 /* error is in project-password combination */ then a_code = 1; /* return non-fatal error */ else /* error is elsewhere */ a_code = 2; /* return fatal error */ end; return; end gcos_verify_user_; 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