PNOTICE_mrds.alm 10/27/88 1531.2r w 10/27/88 1531.2 3555 dec 1 "version 1 structure dec 2 "no. of pnotices dec 3 "no. of STIs dec 156 "lgth of all pnotices + no. of pnotices acc "Copyright, (C) Honeywell Information Systems Inc., 1988" acc "Copyright (c) 1988 by Massachusetts Institute of Technology and Honeywell Information Systems, Inc." aci "C1RDSM0E0000" aci "C2RDSM0E0000" aci "C3RDSM0E0000" end  create_mrds_db.pl1 10/16/86 1551.9rew 10/16/86 1142.8 270567 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(85-11-17,Dupuis), approve(85-12-16,MCR7314), audit(86-02-04,Brunelle), install(86-02-05,MR12.0-1013): This entry is being made to cover the change made on 85-04-19 by Thanh Nguyen. (see mrds #136) 2) change(86-07-21,Blair), approve(86-07-21,MCR7311), audit(86-09-15,Gilcrease), install(86-10-16,MR12.0-1187): When this module is called from command level with -list the xref file from rmdb will be built and needs to be deleted. END HISTORY COMMENTS */ create_mrds_db: cmdb: mrds_rst_cmdb: procedure; /* CMDB procedure point */ entry_name = "cmdb"; goto common; %page; /* HISTORY Initially written by R. D. Lackey June, 1978 Modified by Jim Gray 3/79, to put working storage in it's own directory, using extensible areas Modified by Jim Gray - - Sept. 1979, to add suffix entries for regression test compatibility Modified by Jim Gray - - Jan. 1980, to disallow use of blocked files, foreign keys, and restructuring. Modified by Jim Gray - - Feb. 1980, to remove use of system_free_ Modified by Jim Gray - - Feb. 1980, to add entries to set up for being called as subroutine. Modified by Jim Gray - - April 1980, to correct recursion flag problem. Modified by Jim Gray - - 80-11-06, to add "-secure" option for cmdb, and have mrds_rst_create_db always create a "submodel_dir", under the database directory. The -secure option causes the mdbm_secured bit to be set in the db_model. Also the version_status structure in the db_model had it's major number changed from 7 to 8. The CMDB/RMDB "running" message output at the start of an invocation was altered to include the version number of the model being worked on. Modified by Jim Gray - - 80-11-10, to change delete_$path to hcs_$del_dir_tree and hcs_$delentry_file calls to improve performance. 81-04-28 Jim Gray : added logic for the new -force control argument. 82-05-12 Roger Lackey : changed the way temp_rsc_dir_name was determined to use expand_pathname_ to correct a stringsize condition. 82-06-09 Davids: removed code that was supposed to handle rmdb . and rmdb metering and tracing. rmdb has been . moved to a separate subsystem. 82-06-24 Roger Lackey : change display of model for listing to use . mrds_dm_display 82-07-02 Roger Lackey : changed call to mrds_dm_display to mdbm_util_$mrds_display and mu_quiesce$* to mdbm_util_$ for binding 82-07-06 Roger Lackey : changed mu_define_area to be mdbm_util_$mu_define_area 82-08-19 Davids: added code to set rsc.db_type from arg_info.db_type after the call to mrds_rst_proc_ctl_args. 82-11-23 Davids: added entries set_vfile_db_type and set_page_file_db_type which set the internal static variable default_db_type which was also added and inited to "vf". Modified the parameter list of the module mrds_rst_proc_ctl_args to include default_db_type. 12-02-82 R. Harvey: changed calls to release_area_ to release_temp_segment_ so that the temporary segment really gets freed. 83-01-18 Mike Kubicar: Added transaction processing include files. 83-02-18 Mike Kubicar : Added recognition of mode string for dm files and creation of models that reflect these strings. 83-05-18 Davids: Added the call to dsl_$create_res_copy to create the copy of the model opening resultant. Also moved the position of where the db_model.consistant bit is set to ON from the finish_cmdb internal procedure procedure (if rsc.severity_high = 0) to just before the call to create_res_copy. This was needed so that create_res_copy can open the db. 83-10-04 Benjamin: Replaced call to hcs_$initiate with initiate_file_. 83-10-05 Benjamin: Reverted change of 80-11-10. 84-07-19 Nguyen: Make cleanup handler more reliable and to diagnose non- existent cmdb source segment more quickly. */ %page; /* entries for debug and regression test purposes */ suffix: entry (); /* USE ".db" SUFFIX ON DATABASE PATH */ suffix_flag = ON; return; no_suffix: entry (); /* DON'T USE ".db" SUFFIX ON DATABASE PATH */ suffix_flag = OFF; return; set_vfile_db_type: vf: entry (); /* Default datatype will be vfile */ unspec (default_db_relation_modes) = "0"b; return; set_dm_file_db_type: dmf: entry (); /* Default datatype will be dm file */ dcl set_modes_err_code fixed bin (35); /* Error code, Possibly returned from $parse_mode_string */ dcl set_modes_err_msg char (500); /* Possibly returned from $parse_mode_string */ dcl mrds_rst_proc_ctl_args$parse_mode_string entry (char (*), 1, 2 bit (1) unal, 2 bit (1) unal, 2 bit (1) unal, 2 bit (1) unal, fixed bin (35), char (*)); entry_name = "cmdb$set_dm_file_db_type"; mstxn_txn_id = "0"b; /* Just in case we have to call error */ rsc_ptr = null (); /* Ditto */ default_db_relation_modes.dm_file_type = "1"b; default_db_relation_modes.protection_on = "1"b; default_db_relation_modes.concurrency_on = "1"b; default_db_relation_modes.rollback_on = "1"b; call cu_$arg_count (arg_num, code); if code ^= 0 then call error (code, "While trying to determine the argument count."); if arg_num > 1 then call error (error_table_$too_many_args, "Usage: create_mrds_db$set_dm_file_db_type {mode_string}"); if arg_num > 0 then do; call cu_$arg_ptr (1, arg_ptr, arg_len, code); if code ^= 0 then call error (code, "While getting the first argument."); call mrds_rst_proc_ctl_args$parse_mode_string (arg, default_db_relation_modes, set_modes_err_code, set_modes_err_msg); if set_modes_err_code ^= 0 then call error (set_modes_err_code, set_modes_err_msg); end; return; %page; /* entries for new features allowing/disallowing */ new_on: entry (); allow_new_features = ON; return; /* turn off new features */ new_off: entry (); allow_new_features = OFF; return; /* entries to set up as a command or being called as subroutine */ set_command_level: entry (); command_level_call = ON; return; set_subroutine_level: entry (); command_level_call = OFF; return; %page; common: if recurse_flag then do; /* If recursively invoked */ call com_err_ (mrds_error_$no_recursion, entry_name); return; end; else do; mstxn_txn_id = "0"b; /* No transaction started yet */ rsc_ptr = null; /* Init restructure control segment pointer */ ai_ptr = null; /* Arg_info str pointer */ wa_ptr = null (); on cleanup call tidy_up; /* Establish a cleanup handler */ recurse_flag = ON; /* remember we have been invoked */ end; call mdbm_util_$mu_define_area (wa_ptr, (sys_info$max_seg_size), "MRDS.cmdb", "0"b /* not extensible */, "1"b /* no freeing */, "0"b, "0"b /* no zeroing */, code); if code ^= 0 then call error (code, "defining temp area"); mrds_dm_display_info_ptr = null; if ^command_level_call then ; else call ioa_$ioa_switch (iox_$user_output, "CMDB Version ^d models.", mdbm_data_$current_version); call cu_$arg_list_ptr (arg_list_ptr); /* Get pointer to commandlevel arguments */ allocate arg_info in (wk_area); call mrds_rst_proc_ctl_args (arg_list_ptr, ai_ptr, suffix_flag, default_db_relation_modes, fatal_sw); if fatal_sw then do; /* Fatal error was encountered during arg processing */ call tidy_up; goto exit; end; call initiate_file_ (arg_info.source_dir, arg_info.source_entry, R_ACCESS, temp_seg_ptr, source_seg_bcnt, code); if code ^= 0 then do; temp_msg = "Source segment: " || rtrim (arg_info.source_dir); temp_msg = temp_msg || ">"; temp_msg = temp_msg || arg_info.source_entry; err_msg = temp_msg; call error (code, err_msg); end; /* Create rsc (temporary) segment and directory */ call mrds_rst_create_rsc (arg_info.temp_work_dir, rsc_ptr, code); /* Create and init rsc */ if code ^= 0 then call error (code, "Creating rsc segment "); rsc.source_seg_ptr = temp_seg_ptr; rsc.db_relation_mode_flags = arg_info.relation_mode_flags; /* Set up relation modes */ rsc.secure = arg_info.secure; /* set up cmdb -secure option */ if ^allow_new_features then ; else do; rsc.allow_foreign_keys = ON; rsc.allow_blocked_files = ON; rsc.allow_restructuring = ON; end; if command_level_call then rsc.command_level = ON; else rsc.command_level = OFF; rsc.dbp = arg_info.db_dir_path; rsc.cmdb_option = ON; if arg_info.list then call init_listing_seg; /* Attach open and init listing segent */ %page; rsc.temp_dir = rsc.dbp; /* For cmdb these are the same */ db_model_path = rtrim (rsc.temp_dir) || ">db_model"; call mrds_rst_create_db (rsc_ptr, dbm_ptr, code); /* Create the database skeleton including db_model */ if code ^= 0 then do; if code ^= error_table_$namedup then call error (code, "Creating data base " || rsc.dbp); else do; if ^arg_info.force then do; call expand_pathname_ (rsc.dbp, db_dir, db_entry, cd); call error (code, " The entry '" || rtrim (db_entry) || "' already exists under the directory " || db_dir); end; else do; /* user gave -force argument */ /* check for a database, since we will not delete plain directories, segments, links, or msf's */ call dmd_$check_path (rtrim (rsc.dbp), db_dir, db_entry, new_found, code); if code = error_table_$incorrect_access then code = 0; /* ignore access problems to the data model */ if code ^= 0 then call error (code, "Trying to delete existing database: " || rsc.dbp); else do; /* force the user to be a DBA, if possible, so we can give all needed access */ dir_acl (1).access_name = get_group_id_$tag_star (); /* get person.project.tag */ call hcs_$add_dir_acl_entries (db_dir, db_entry, addr (dir_acl), 1, code); if code ^= 0 then do; if code = error_table_$argerr then code = dir_acl (1).status_code; /* get real error for this acl setting */ call error (code, "Could not set needed access: " || rsc.dbp); end; else do; call dmd_$set_needed_access (rtrim (rsc.dbp), code); if code ^= 0 then call error (code, "Unable to give DBA needed access: " || rsc.dbp); else do; call delete_directory (); if code ^= 0 then call error (code, "Deleting existing database."); else do; call mrds_rst_create_db (rsc_ptr, dbm_ptr, code); /* try again */ if code ^= 0 then call error (code, "Creating data base after deletion " || rsc.dbp); end; end; end; end; end; end; end; rsc.delete_db_sw = ON; /* Set for tidy_up */ call mrds_rst_get_seg_ptr (rsc_ptr, rsc.h_n_seg_info_ls_ptr, DB_MODEL_SEG_NAME, /* Add the new db_model to */ INITIATE, dbm_ptr, code); /* seg_info list */ if dbm_ptr = null then call error (code, "DB MODEL"); rsc.n_dm_ptr = dbm_ptr; /* For cmdb New is used */ %page; rsc.phase = 200; /* going into parse phase */ call mrds_rst_parse (rsc_ptr, rsc.source_seg_ptr, source_seg_bcnt / 9); if rsc.severity_high >= 3 then ; else call mrds_rst_consistancy_check (rsc_ptr); /* make sure there are no loose ends */ /* Now we might be ready to create relations, set up for transactions */ mstxn_transactions_needed = rsc.db_relation_mode_flags.protection_on; if rsc.db_relation_mode_flags.dm_file_type then do; no_dms_err_code = mrds_error_$no_dms; /* If we're going to get an error, do it now */ on linkage_error call error (no_dms_err_code, "The Data Management System could not be found by the process search rules."); dms_test = transaction_manager_$begin_txn; revert linkage_error; end; on cleanup begin; call mstxn_cleanup; call tidy_up; end; on any_other call mstxn_any_other; %include mrds_start_transaction; if mstxn_code ^= 0 then call error (mstxn_code, "Starting a transaction"); if rsc.severity_high = 0 then do; /* Logical completed OK */ call model_adjust_bit_count; /* Adjust bit count for all models */ call format_files; rsc.n_dm_ptr -> db_model.consistant = ON; /* OK to open db */ call dsl_$create_res_copy (rsc.dbp, code); if code ^= 0 then do; if rsc.listing_seg_sw then call ioa_$ioa_switch (rsc.listing_iocb_ptr, "2^/Could not create the model resultant copies"); call ioa_$ioa_switch (iox_$error_output, "2^/Could not create the model resultant copies"); rsc.severity_high = 4; rsc.n_dm_ptr -> db_model.consistant = OFF; end; end; call finish_cmdb; exit: if rsc_ptr = null () then mftxn_code = code; /* Nothing happened */ else if rsc.severity_high = 0 & code = 0 /* No errors occurred */ then mftxn_code = 0; /* Everthings cool */ else if code = 0 then mftxn_code = error_table_$action_not_performed; /* Rollback! */ else mftxn_code = code; %include mrds_finish_transaction; if mftxn_code ^= 0 then call com_err_ (mftxn_code, entry_name); if entry_name ^= "cmdb$set_dm_file_db_type" then call tidy_up; return; /* This is the only return from this program */ %page; model_adjust_bit_count: proc; /* This procedure adjusts the bit count on the data model and all file models */ success = ON; /* Init loop */ if rsc.h_n_seg_info_ls_ptr ^= null then do loop_ptr = rsc.h_n_seg_info_ls_ptr /* Do all segment in new seg_info list */ repeat node_ptr while (success = ON); call mrds_rst_tree_successor (rsc.h_n_seg_info_ls_ptr, loop_ptr, node_ptr, dummy_ptr, success); if success then do; /* IF entry in list was found */ seg_info_ptr = node.data; /* Set pointer to seg_info */ call adjust_bit_count_ (seg_info.dir, seg_info.name, "1"b, (seg_info.bcnt), code); if code ^= 0 then call error (code, "model_adjust_bit_count"); end; end; end model_adjust_bit_count; %page; finish_cmdb: proc; if rsc.listing_seg_sw then do; if rsc.severity_high > 0 then call ioa_$ioa_switch (rsc.listing_iocb_ptr, "^2/An error of severity ^d occured.^/database not created.^/", rsc.severity_high); else call ioa_$ioa_switch (rsc.listing_iocb_ptr, "^/NO ERRORS^/"); end; if rsc.severity_high > 0 & rsc.command_level then call ioa_$ioa_switch (iox_$error_output, "^/cmdb: An error of severity ^d occured.^/^6xData base not created.^/", rsc.severity_high); if rsc.severity_high = 0 then do; rsc.delete_db_sw = OFF; /* We have a good data base */ if rsc.listing_seg_sw then do; /* display db in listing */ call init_display_info; /* Internal proc */ call mdbm_util_$mrds_dm_display (mrds_dm_display_info_ptr, err_msg, code); if code ^= 0 then call error (code, err_msg); end; end; end finish_cmdb; %page; format_files: proc; /* this procedure walks the global file list and formats the newly created files */ dcl error_code fixed bin (35); node_ptr = rsc.h_gfile_ptr; success = ON; do while (success); /* all the files in list */ call mrds_rst_tree_successor (rsc.h_gfile_ptr, node_ptr, successor_ptr, successor_parent_ptr, success); if success then do; /* Found a file info */ node_ptr = successor_ptr; gl_ptr = node.data; if ^gl.complete then do; /* To complete it format the file */ call mrds_rst_format_file (rsc_ptr, (gl.name), error_code); if error_code ^= 0 then call error (error_code, "Creating relation " || rtrim (gl.name)); gl.complete = ON; /* It is now complete */ end; end; end; end format_files; %page; error: proc (cd, msg); dcl cd fixed bin (35); /* (INPUT) Error code */ dcl msg char (*); /* (INPUT) error message input with code */ code = cd; /* Code is a global parameter */ call com_err_ (cd, entry_name, "^/^a", msg); goto exit; end error; %page; init_listing_seg: proc; /* Initialize listing segment */ call cu_$decode_entry_value (create_mrds_db, ref_ptr, dummy_ptr); /* Get pointer to ref procedure */ attach_desc = "vfile_ " || rtrim (get_wdir_ ()) || ">" || before (arg_info.source_entry, "." || rtrim (entry_name)) || ".list"; call iox_$attach_name (unique_chars_ ("0"b) || rtrim (entry_name) || ".listing", rsc.listing_iocb_ptr, attach_desc, ref_ptr, code); if code = 0 then call iox_$open (rsc.listing_iocb_ptr, STREAM_OUTPUT, "0"b, code); if code ^= 0 then call error (code, "listing segment"); value = "CREATE_MRDS_DB"; call ioa_$ioa_switch (rsc.listing_iocb_ptr, "^-^a LISTING FOR ^a", value, rtrim (arg_info.source_dir) || ">" || arg_info.source_entry); call ioa_$ioa_switch (rsc.listing_iocb_ptr, "^-Created by:^-^a", get_group_id_ ()); call date_time_ (clock (), long_date); call ioa_$ioa_switch (rsc.listing_iocb_ptr, "^-Created on:^-^a", long_date); call ioa_$ioa_switch (rsc.listing_iocb_ptr, "^-Data base path:^-^a", rsc.dbp); value = ""; if arg_info.list then value = value || " list"; if value = "" then value = " None"; call ioa_$ioa_switch (rsc.listing_iocb_ptr, "^-^7xOptions:^4x^a", value); call ioa_$ioa_switch (rsc.listing_iocb_ptr, "^/");/* A couple of spaces */ rsc.listing_seg_sw = ON; return; end init_listing_seg; %page; init_display_info: proc; allocate mrds_dm_display_info in (wa) set (mrds_dm_display_info_ptr); mrds_dm_display_info.version = MRDS_DM_DISPLAY_INFO_VERSION_1; mrds_dm_display_info.output_iocb_ptr = rsc.listing_iocb_ptr; mrds_dm_display_info.db_path = rsc.dbp; mrds_dm_display_info.temp_dir_path = arg_info.temp_work_dir; mrds_dm_display_info.work_area_ptr = wa_ptr; mrds_dm_display_info.dbm_ptr = dbm_ptr; mrds_dm_display_info.sw.default = "0"b; mrds_dm_display_info.sw.long = "1"b; /* This is what we are after */ mrds_dm_display_info.sw.cmdb = "0"b; mrds_dm_display_info.sw.names_only = "0"b; mrds_dm_display_info.sw.attribute = "0"b; mrds_dm_display_info.sw.relation = "1"b; /* This is what we are after */ mrds_dm_display_info.sw.index = "0"b; mrds_dm_display_info.sw.history = "0"b; mrds_dm_display_info.sw.header = "1"b; /* This is what we are after */ mrds_dm_display_info.sw.mbz = "0"b; mrds_dm_display_info.dom_name_list_ptr = null; mrds_dm_display_info.attr_name_list_ptr = null; mrds_dm_display_info.rel_name_list_ptr = null; mrds_dm_display_info.index_name_list_ptr = null; mrds_dm_display_info.xref_iocb_ptr = null; mrds_dm_display_info.xref_name = ""; end init_display_info; %page; tidy_up: proc; if rsc_ptr ^= null then do; if rsc.db_quiesced_sw then /* If database has been quiesced then un-quiesce it */ call mdbm_util_$quiesce_free (rsc.dbp, code); if mrds_dm_display_info_ptr ^= null then if mrds_dm_display_info.xref_iocb_ptr ^= null then do; call mdbm_util_$xref_destroy (mrds_dm_display_info.xref_iocb_ptr, mrds_dm_display_info.temp_dir_path, (mrds_dm_display_info.xref_name), err_msg, code); if code ^= 0 then call error (code, err_msg); mrds_dm_display_info.xref_iocb_ptr = null; end; if rsc.delete_db_sw then /* If the data base had been created but an error */ call delete_directory; /* occured then delete the data base */ else if rsc.temp_dir_sw then /* Entry point was rmdb and a temp dir was created */ call delete_directory; if rsc.listing_seg_sw then do; /* Close and detach the listing segment */ call iox_$close (rsc.listing_iocb_ptr, code); if code = 0 then call iox_$detach_iocb (rsc.listing_iocb_ptr, code); if code = 0 then call iox_$destroy_iocb (rsc.listing_iocb_ptr, code); end; call expand_pathname_ (rsc.rsc_dir, dir, temp_rsc_dir_name, code); if code = 0 then do; delete_options.force = ON; delete_options.question = OFF; delete_options.directory = ON; delete_options.segment = ON; delete_options.link = ON; delete_options.chase = ON; delete_options.library = OFF; delete_options.raw = OFF; delete_options.mbz = OFF; quit_sw = "0"b; on quit quit_sw = "1"b; /* Because the delete_$path takes a lot of cpu time, so let handle the quit condition and let it finishes then we give the quit. */ call delete_$path (arg_info.temp_work_dir, temp_rsc_dir_name, string (delete_options), MODULE_NAME, code); if code = 0 then do; rsc_ptr = null; end; if quit_sw then do; quit_sw = "0"b; revert quit; signal quit; end; end; if code ^= 0 then call com_err_ (code, entry_name, "^a", "deleting rsc_dir"); end; if wa_ptr ^= null () then do; call release_temp_segment_ ("MRDS.cmdb", wa_ptr, code); wa_ptr = null (); end; recurse_flag = OFF; /* Reset so we can be called again */ return; end tidy_up; %page; delete_directory: proc; temp_dir_name = reverse (before (reverse (before (rsc.temp_dir, BLANK)), ">")); temp_dir_directory = before (rsc.temp_dir, ">" || temp_dir_name); delete_options.force = ON; delete_options.question = OFF; delete_options.directory = ON; delete_options.segment = ON; delete_options.link = ON; delete_options.chase = ON; delete_options.library = OFF; delete_options.raw = OFF; delete_options.mbz = OFF; call delete_$path (temp_dir_directory, temp_dir_name, string (delete_options), MODULE_NAME, code); end delete_directory; %page; /* * * These routines are dummy routines required for the transaction processing * include files. They do nothing. * */ should_rollback: proc returns (bit (1)); return ("0"b); end should_rollback; restore_significant_data: proc; end restore_significant_data; %page; dcl recurse_flag bit (1) internal static init ("0"b); /* On = cmdb/rmdb has been invoked */ dcl adjust_bit_count_ entry (char (168), char (32), bit (1) aligned, fixed bin (35), fixed bin (35)); dcl cleanup condition; dcl quit condition; dcl any_other condition; dcl linkage_error condition; dcl clock builtin; dcl com_err_ entry options (variable); dcl cu_$arg_count entry (fixed bin, fixed bin (35)); dcl cu_$arg_list_ptr entry (ptr); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl cu_$decode_entry_value entry (entry, ptr, ptr); dcl date_time_ entry (fixed bin (71), char (*)); dcl delete_$path entry (char (*), char (*), bit (36) aligned, char (*), fixed bin (35)); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl get_group_id_ entry returns (char (32)); dcl get_group_id_$tag_star entry returns (char (32)); dcl get_wdir_ entry returns (char (168)); dcl initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35)); dcl ioa_$ioa_switch entry options (variable); dcl iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35)); dcl iox_$close entry (ptr, fixed bin (35)); dcl iox_$error_output ext ptr; dcl iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)); dcl iox_$user_output ext ptr; dcl unique_chars_ entry (bit (*)) returns (char (15)); dcl unspec builtin; dcl wa_ptr ptr; dcl wk_area area (sys_info$max_seg_size) based (wa_ptr); dcl (iox_$detach_iocb, iox_$destroy_iocb) entry (ptr, fixed bin (35)); dcl mrds_rst_consistancy_check entry (ptr); /* valid model checker */ %page; dcl BLANK char (1) int static options (constant) init (" "); dcl DB_MODEL_SEG_NAME char (32) aligned int static options (constant) init ("db_model"); dcl INITIATE bit (1) int static options (constant) init ("0"b); dcl MODULE_NAME char (14) int static options (constant) init ("create_mrds_db"); dcl OFF bit (1) int static options (constant) init ("0"b); dcl ON bit (1) int static options (constant) init ("1"b); dcl quit_sw bit (1) aligned; dcl RINGS (3) fixed bin (3) init static options (constant) init (7, 7, 7); /* Ring brackets */ dcl STREAM_OUTPUT fixed bin internal static options (constant) init (2); dcl mdbm_util_$mrds_dm_display entry (ptr, char (*), fixed bin (35)); dcl mdbm_util_$xref_destroy entry (ptr, char (*), char (*), char (*), fixed bin (35)); dcl mrds_rst_create_db entry (ptr, ptr, fixed bin (35)); dcl mrds_rst_create_rsc entry (char (*), ptr, fixed bin (35)); dcl mrds_rst_format_file entry (ptr, char (*), fixed bin (35)); dcl mrds_rst_get_seg_ptr entry (ptr, ptr, char (32) aligned, bit (1), ptr, fixed bin (35)); dcl mdbm_util_$quiesce_free entry (char (168), fixed bin (35)); dcl mrds_rst_parse entry (ptr, ptr, fixed bin (24)); dcl mrds_rst_proc_ctl_args entry (ptr, ptr, bit (1), 1, 2 bit (1) unal, 2 bit (1) unal, 2 bit (1) unal, 2 bit (1) unal, bit (1)); declare suffix_flag bit (1) init ("1"b) int static; /* on => use ".db" suffix on db path */ declare allow_new_features bit (1) init ("0"b) int static; /* on => allow foreign keys, blocked files, restructuring */ declare release_temp_segment_ entry (char (*), ptr, fixed bin (35)); declare mdbm_util_$mu_define_area entry (ptr, fixed bin (18), char (11), /* calls mu_define_area_ to get temp seg */ bit (1) aligned, bit (1) aligned, bit (1) aligned, bit (1) aligned, fixed bin (35)); declare command_level_call bit (1) internal static init ("1"b); /* on => set up as command, not subroutine */ declare mdbm_data_$current_version fixed bin (35) ext; /* curent model version numberr */ declare error_table_$incorrect_access fixed bin (35) ext; /* no acl to existing data model */ declare new_found bit (1); /* on => new version db arch found */ declare dmd_$check_path entry (char (*), char (168), char (32), bit (1), fixed bin (35)); /* determines if path is to db */ declare dmd_$set_needed_access entry (char (*), fixed bin (35)); /* gives a DBA all acls */ declare dsl_$create_res_copy entry (char (168), fixed bin (35)); declare hcs_$add_dir_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35)); /* set acl on a dir */ declare 1 dir_acl (1:1) aligned, /* structure for setting sma on db dir */ 2 access_name char (32), /* person.project.tag */ 2 dir_modes bit (36) init ("111000000000000000000000000000000000"b), /* sma acl */ 2 status_code fixed bin (35) init (0); /* error code for this acl setting */ declare error_table_$argerr fixed bin (35) ext;/* from hcs_$add_dir_acl_entries */ dcl mrds_rst_tree_successor entry (ptr, ptr, ptr, ptr, bit (1)); dcl sys_info$max_seg_size ext fixed bin (35); /* ERROR CODES */ dcl error_table_$action_not_performed fixed bin (35) ext static; /* Could not create db */ dcl error_table_$namedup ext fixed bin (35); dcl error_table_$too_many_args fixed bin (35) ext static; dcl mrds_error_$no_recursion ext fixed bin (35); dcl mrds_error_$no_dms ext fixed bin (35); %page; dcl arg char (arg_len) based (arg_ptr); /* To get args for set_dm_file_db_type entry point */ dcl arg_len fixed bin (21); /* To get args for set_dm_file_db_type entry point */ dcl arg_list_ptr ptr; /* Pointer to commmand level argument list */ dcl arg_num fixed bin; /* Number of args for set_dm_file_db_type entry point */ dcl arg_ptr ptr; /* To get arguments for set_dm_file_db_type entry point */ dcl source_seg_bcnt fixed bin (24); /* Bit count of source segment */ dcl temp_seg_ptr ptr; dcl err_msg char (256); dcl fatal_sw bit (1); /* ON => Fatal error occured while processing control arguments */ dcl (addr, null, fixed, rtrim, before, reverse, string) builtin; dcl cd fixed bin (35); dcl db_dir char (168); dcl db_entry char (32); dcl dir char (168); dcl dms_test entry options (variable) variable; /* See if dms software is there */ dcl code fixed bin (35); /* Error code */ dcl (dummy_ptr, loop_ptr) ptr; /* Dummy pointer */ dcl ref_ptr ptr; /* procedure reference pointer */ dcl attach_desc char (200); /* Attach descriptor */ dcl entry_name char (32); dcl db_model_path char (168); /* path name down to db_model */ dcl long_date char (24); dcl no_dms_err_code fixed bin (35); /* To avoid recursive linkage_error conditions */ dcl temp_dir_name char (32); /* Name of temp directory entry */ dcl temp_dir_directory char (168); dcl temp_rsc_dir_name char (32); /* temp for holding rsc dir name */ dcl temp_msg char (256) varying; dcl value char (64) varying; dcl 1 default_db_relation_modes int static, /* Relation modes, set by set_(vfile dm_file)_db_type entry points */ 2 dm_file_type bit (1) init ("0"b), /* Default vfile */ 2 protection_on bit (1) init ("0"b), /* No transactions */ 2 concurrency_on bit (1) init ("0"b), /* No concurrency */ 2 rollback_on bit (1) init ("0"b); /* No journalling */ %page; %include mrds_rst_struct_types; %page; %include mrds_rst_arg_info; %page; %include mrds_rst_rsc; %page; %include mrds_rst_tree; %page; %include mrds_rst_global_lists; %page; %include mrds_dm_display_info; %page; %include mdbm_db_model; %page; %include access_mode_values; %page; %include delete_options; end;  mrds_rst_.alm 10/23/86 1025.2rew 10/23/86 1008.1 13059 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1981 * " * * " *********************************************************** " HISTORY COMMENTS: " 1) change(86-06-13,Dupuis), approve(86-08-05,MCR7491), " audit(86-08-08,Blair), install(86-08-15,MR12.0-1127): " Made available so that an unbound version of mrds could be created " easily. (phx20405, mrds #157) " 2) change(86-10-21,Blair), approve(86-10-21,PBF7311), " audit(86-10-23,Dupuis), install(86-10-23,MR12.0-1199): " Add the name execute_undo so that rmdb_execute_undo can be called from " display_mrds_dm which is outside of the rmdb subsystem. " END HISTORY COMMENTS " "81-05-27 Jim Gray : created to support the bound_mrds_create_ segment "since display_mrds_dm needs access to some mrds_rst_ modules, but is in bound_mrds_ " "82-07-07 Roger Lackey : added add_rmdb_history for rmdb_add_rmdb_history " "83-02-15 Ron Harvey : deleted $create_rsc, $global_list_build, $build_seg_info_ls " as they were no longer called. name mrds_rst_ entry add_rmdb_history add_rmdb_history: tra |[add_rmdb_history] entry execute_undo execute_undo: tra |[execute_undo] end  mrds_rst_attribute_cleanup.pl1 04/18/85 1454.7r w 04/18/85 0909.0 56007 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* HISTORY: originally written by jim gray - - october 1978 */ mrds_rst_attribute_cleanup: procedure (rsc_ptr); /* DESCRIPTION: this routine is invoked to supply default attributes for domains that currently have no attribute of the same name as the domain(for RMDB), or which have had no attributes specified for them. it produces dummy attribute list structures identical to the input to mrds_rst_attribute_handler that have a attribute name equal to the domain name, and then calls the attribute handler to put the attribute models in place. */ /* PARAMETERS: rsc_ptr - - (input) pointer to the common control segment global lists - - (input) searched for domains without attributes since they contain all database entities during RMDB/CMDB parse info structures - - (output) via calls to mrds_rst_attribute_handler to build the attribute model as default for the given domain */ /* get the semantic structure pointers */ directive_ptr = rsc.directive_ptr; /* if trace is on call metering */ if ^rsc.trace_sw then ; else do; if directive.type = DEFINE then directive_mesg = "DEFINE"; else if directive.type = REDEFINE then directive_mesg = "REDEFINE"; else directive_mesg = "CMDB"; call mrds_rst_meter (rsc_ptr, "mrds_rst_attribute_cleanup", "1"b /* in */, directive_mesg); end; /* check for domains with no referencing attributes, any found get default attributes of the same name as that of the given domain */ if directive.type = REDEFINE then do; call ioa_$rs ("^a ^a", message, message_length, "The attribute cleanup handler will not implement the ""redefine""", "directive until a later release."); call mrds_rst_error (rsc_ptr, 2 /* severity */, mrds_error_$rst_undone_option, (message)); end; else do; /* initialize the successor function to get the first domain on the global list of domains in the database */ root_ptr = rsc.h_gdom_ptr; node_ptr = root_ptr; /* convention for first on list */ success = "1"b; /* do at least one loop */ do while (success); call mrds_rst_tree_successor (root_ptr, node_ptr, successor_ptr, successor_parent_ptr, success); if ^success then ; /* success off => no more in list */ else do; /* next domain found */ node_ptr = successor_ptr;/* get pointer to next on list after last one */ gl_ptr = node_ptr -> node.data; /* get element portion from tree head */ if default_attribute_present () then ; /* already default attr present */ else do; /* none found, set default attribute */ /* make believe we are the parser, and that we just found an attribute definition of domain-name domain-name */ call mrds_rst_rsc_alloc (rsc_ptr, ATTRIBUTE_DOMAIN, attdom_ptr); attribute_domain.attr = gl.name; /* set domain name as attribute's */ attribute_domain.dom = gl.name; attribute_domain.default = "1"b; /* not defined in source */ attribute_domain.unused = "0"b; attribute_domain.line_num = 0; /* define the attribute just prepared */ call mrds_rst_attribute_handler (rsc_ptr, attdom_ptr); end; end; end; end; /* call trace if metering is on */ if ^rsc.trace_sw then ; else call mrds_rst_meter (rsc_ptr, "mrds_rst_attribute_cleanup", "0"b /* out */, directive_mesg); default_attribute_present: procedure () returns (bit (1)); /* routine to return true if an attribute of the same name as the domain has been defined as referencing this domain. (this will only happen with default attributes, not source ones) else it returns false, say if no attributes are present */ call mrds_rst_tree_search (gl.name, gl.item_sub_list_ptr, node_ptr, parent_ptr, success); return (success); declare node_ptr ptr; /* local version for search */ declare parent_ptr ptr; /* unused */ declare success bit (1); /* on => default attribute of domain name found */ end; declare directive_mesg char (8); /* meter call message */ declare mrds_rst_tree_search entry (char (32) aligned, ptr, ptr, ptr, bit (1)); /* find routine */ declare mrds_rst_rsc_alloc entry (ptr, fixed bin, ptr); /* working area manager */ declare ioa_$rs entry options (variable); /* string manipulation routine */ declare mrds_rst_error entry (ptr, fixed bin, fixed bin (35), char (*)); /* general error handler */ declare message char (96) varying; /* specifics of error message */ declare message_length fixed (21); /* length of specifics message */ declare mrds_error_$rst_undone_option fixed bin (35) external; /* unimplemented feature */ declare mrds_rst_tree_successor entry (ptr, ptr, ptr, ptr, bit (1)); /* get next on list routine */ declare mrds_rst_attribute_handler entry (ptr, ptr); /* attribute semantic routine */ declare mrds_rst_meter entry (ptr, char (*), bit (1), char (*)); /* trace/meter routine */ declare sys_info$max_seg_size fixed bin (35) external; /* system largest segment allowed */ declare (fixed, addr, rel) builtin; /* functions known to pl1 */ %include mrds_rst_rsc; %include mrds_rst_struct_types; %include mrds_rst_global_lists; %include mrds_rst_tree; %include mrds_rst_parse_info; %include mrds_rst_semantics; end;  mrds_rst_attribute_handler.pl1 04/18/85 1454.7r w 04/18/85 0909.0 89091 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* HISTORY: originally written by jim gray - - october 1978 */ mrds_rst_attribute_handler: procedure (rsc_ptr, list_ptr); /* DESCRIPTION: this routine builds/alters the mrds database model attribute information and the global list of database entities maintained during CMDB/RMDB based upon the attribute data and directive that is active when it is called from the RMDB/CMDB parser. the directive may be undefine, define, redefine, or cmdb and the data is either an attribute name or a structure holding an attribute-domain name pair. */ /* PARAMETERS: rsc_ptr - - (input) pointer to the common control segment list_ptr - - (input) pointer to the single attribute name(undefine only), or to the attribute-domain name pair structure database model - - (output) updated model with altered attribute information global lists - - (output) the lists of database entities, updated according to the directive and data error_output - - (output) via calls to mrds_rst_error for error messages */ /* REMAINING ERRORS: undefine: the attribute name may be the (this may be ignored) the attribute may not be defined in the model define, cmdb: the attribute name may be the (this may be ignored) the domain name may be the (this may be ignored) the attribute may already be defined in the model the domain may not be defined in the model redefine: same as under define, except the attribute may not be defined note: "(this may be ignored)" means a previous error will prevent a database model with erroneous data fom being built */ /* call trace if metering is on */ directive_ptr = rsc_ptr -> rsc.directive_ptr; stmt_ptr = rsc_ptr -> rsc.stmt_ptr; if directive.type = UNDEFINE then do; /* input structure depends on directive */ delete_name_ptr = list_ptr; attribute_name = delete_name.overlay; end; else do; attdom_ptr = list_ptr; attribute_name = attribute_domain.attr; end; if ^rsc.trace_sw then ; else call mrds_rst_meter (rsc_ptr, "mrds_rst_attribute_handler", IN, (attribute_name)); /* check on which directive called us */ if directive.type = UNDEFINE | directive.type = REDEFINE then do; if stmt (directive.type).attribute.number > 0 then ; /* not first time */ else do; /* issue error first time only */ call ioa_$rs ("^a ^a", message, message_length, "The attribute handler will not implement ""undefine"" or ""redefine""", "directives until a later release."); call mrds_rst_error (rsc_ptr, 2 /* severity */, mrds_error_$rst_undone_option, (message)); end; end; else do; /* define or cmdb directive was caller, process newly defined attribute-domain correspondence */ call define_attribute_domain (); end; /* call the trace routine if metering is turned on */ if ^rsc.trace_sw then ; else call mrds_rst_meter (rsc_ptr, "mrds_rst_attribute_handler", OUT, (attribute_name)); define_attribute_domain: procedure (); /* routine to make the definition correspondence of an attribute to a domain */ /* make sure the attribute is not already in the database or previously defined */ call mrds_rst_list_element$add (attribute_domain.attr, MAIN_LIST, rsc_ptr, rsc.h_gattr_ptr, gl_ptr, error_code); if error_code = 0 then ; else do; call ioa_$rs ("^a^a^a ^d ^a", message, message_length, "The attribute """, attribute_domain.attr, """ given on line", attribute_domain.line_num, "is already defined in the database, the duplicate will be ignored!!"); call mrds_rst_error (rsc_ptr, 2 /* severity */, mrds_error_$attr_already_exists, (message)); call mrds_rst_rsc_alloc (rsc_ptr, GL, gl_ptr); /* make dummy global element not in list */ end; /* attribute was not found in list so it was added, link list element to list head and fill in the blanks */ gl.type = MAIN_LIST; gl.name = attribute_domain.attr; gl.item_info_ptr = null (); /* no domain sublist element yet */ gl.parse_info_ptr = attdom_ptr; gl.other_info_ptr = null (); /* no domain_info yet */ gl.item_sub_list_ptr = null (); /* no containing relations yet */ gl.file_info_ptr = null (); /* unused, this and fm_ptr obtained from corresponding */ gl.file_model_ptr = null (); /* relation's attr sublist ai_ptr via the pointer function */ gl.affected = ON; gl.undefine = OFF; gl.redefine = OFF; if directive.type = DEFINE then do; gl.define = ON; gl.cmdb = OFF; end; else do; /* CMDB directive */ gl.define = OFF; gl.cmdb = ON; end; gl.superior_assigned = OFF; /* no relation for this attribute yet */ gl.inferior_assigned = OFF; /* no domain for this attribute yet */ gl.complete = OFF; /* no attribute info yet */ gl.consistant = ON; /* assume good til errors found */ gl.reserved = OFF; /* make sure that the given domain is defined in the database */ call mrds_rst_tree_search (attribute_domain.dom, rsc.h_gdom_ptr, node_ptr, parent_ptr, success); if ^success then do; /* not found */ gl.consistant = OFF; /* no domain for this attribute */ call ioa_$rs ("^a^a^a^a^a ^d ^a", message, message_length, "The domain """, attribute_domain.dom, """ given for attribute """, attribute_domain.attr, """ on line", attribute_domain.line_num, "has not been defined in the database."); call mrds_rst_error (rsc_ptr, 2 /* severity */, mrds_error_$undefined_domain, (message)); end; else if error_code ^= 0 then ; /* previous error => attr not found, don't add to sublist */ else do; dom_gl_ptr = node_ptr -> node.data; /* get domain global element pointer */ /* domain found, add this attribute to it's referencing sublist */ call mrds_rst_list_element$add (attribute_domain.attr, SUB_LIST, rsc_ptr, dom_gl_ptr -> gl.item_sub_list_ptr, sl_ptr, error_code); if error_code ^= 0 then do; /* sub/main list disagreement */ call ioa_$rs ("^a^a^a^a^a", message, message_length, "LOGIC ERROR in mrds_rst_attribute_handler, the attribute """, attribute_domain.attr, """ was found in the sublist of domain """, attribute_domain.dom, """ but wasn't found in the global attribute list."); call mrds_rst_error (rsc_ptr, 4 /* severity */, error_code, (message)); end; else do; /* fill in the sub list element info */ sl.type = SUB_LIST; sl.name = attribute_domain.attr; sl.item_info_ptr = null (); /* no attribute_info yet */ sl.parse_info_ptr = attdom_ptr; sl.old_other_info_ptr = null (); sl.new_other_info_ptr = dom_gl_ptr; sl.global_list_ptr = gl_ptr; sl.reserved = OFF; /* set domain present for this attribute, and get the domain info and sublist pointers */ gl.item_info_ptr = sl_ptr; gl.other_info_ptr = dom_gl_ptr -> gl.item_info_ptr; /* set domain_info ptr for attr */ gl.inferior_assigned = ON; dom_gl_ptr -> gl.inferior_assigned = ON; /* attr references domain now */ end; end; end; declare sys_info$max_seg_size fixed bin (35) external; /* system constant */ declare (fixed, rel, addr, null) builtin; /* functions known to pl1 */ declare ON bit (1) internal static options (constant) init ("1"b); /* true state */ declare OFF bit (1) internal static options (constant) init ("0"b); /* false */ declare error_code fixed binary (35); /* mrds_error_ table index */ declare message char (256) varying;/* specifics of error message */ declare message_length fixed bin (21); /* length of specifics message */ declare mrds_error_$rst_undone_option fixed bin (35) external; /* option not coded yet */ declare mrds_error_$undefined_domain fixed bin (35) external; /* item not in database */ declare mrds_error_$attr_already_exists fixed bin (35) external; /* duplicate attr definition */ declare mrds_rst_tree_search entry (char (32) aligned, ptr, ptr, ptr, bit (1)); /* list searcher */ declare mrds_rst_rsc_alloc entry (ptr, fixed bin, ptr); /* work area manager */ declare mrds_rst_error entry (ptr, fixed bin, fixed bin (35), char (*)); /* general error handler */ declare ioa_$rs entry options (variable); /* string manipulator */ declare mrds_rst_list_element$add entry (char (32) aligned, fixed binary, ptr, ptr, ptr, fixed bin (35)); declare list_ptr ptr; /* pointer to parse info list */ declare IN bit (1) internal static options (constant) init ("1"b); /* input meter flag */ declare OUT bit (1) internal static options (constant) init ("0"b); /* output meter flag */ declare mrds_rst_meter entry (ptr, char (*), bit (1), char (*)); /* metering/tracing routine */ declare dom_gl_ptr ptr; /* temp storage for domain global element pointer */ declare attribute_name char (32); /* input name for metering */ %include mrds_rst_rsc; %include mrds_rst_struct_types; %include mrds_rst_semantics; %include mrds_rst_parse_info; %include mrds_rst_tree; %include mrds_rst_global_lists; end;  mrds_rst_consistancy_check.pl1 10/16/86 1551.9r w 10/16/86 1145.0 64674 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* HISTORY: originally written by jim gray - - January 1979 83-02-17 Davids: explicitly declared variables that were declared by context or implication and deleted declarations to variables that were not referenced. */ /* Known Problems: 1) RMDB code should be removed since its now done by the rmdb subsystem */ mrds_rst_consistancy_check: procedure (rsc_ptr); /* . BEGIN_DESCRIPTION This routine makes sure that creation(CMDB) or restructuring(RMDB) of a database model has resulted in a model that is guarenteed to be consistant, complete, and error free. For CMDB this means checking that some attributes or domains might never have been used or referenced, a possible oversight by the database builder. RMDB is more complicated, because an "undefine" directive can cause an inconsistancy that was later rectified by a "define" or "redefine" directive. Thus many more checks are made to ensure that attributes have domains, and are contained in some relation, all domains are referenced, and so on. . END_DESCRIPTION */ /* PARAMETERS: rsc_ptr - - (input) pointer to the restructure control segment that holds error, directives seen, and other common information (output) warning messages about detected inconsistancies in the database, and the setting of severity high in the rsc segment */ /* get the semantic structure pointers */ stmt_ptr = rsc.stmt_ptr; directive_ptr = rsc.directive_ptr; /* call metering if trace is on */ if ^rsc.trace_sw then ; else do; if directive.cmdb.seen then meter_mesg = "CMDB"; else meter_mesg = "RMDB"; call mrds_rst_meter (rsc_ptr, "mrds_rst_consistancy_check", "1"b /* input call */, meter_mesg); end; /* take action based on which command invoked us, CMDB only can have used attributes and domains */ if directive.cmdb.seen then do; /* CMDB directive */ call check_for_referencing_relation ("0"b /* for domains */); call check_for_referencing_relation ("1"b /* for attributes */); end; else do; /* RMDB directive */ /* quick and dirty version for RMDB with only "define" directive */ call check_for_referencing_relation ("0"b /* for domains */); call check_for_referencing_relation ("1"b /* for attributes */); /* call ioa_$ioa_switch (iox_$error_output, "RMDB consistancy check not implemented yet.^/") ; */ end; /* call metering if trace is on */ if ^trace_sw then ; else call mrds_rst_meter (rsc_ptr, "mrds_rst_consistancy_check", "0"b /* output call */, meter_mesg); check_for_referencing_relation: procedure (attribute_check); /* routine to check the global list elements of domains and attributes, to see whether they have been made ude of in some relation or not */ if attribute_check then root_ptr = rsc.h_gattr_ptr; else root_ptr = rsc.h_gdom_ptr; node_ptr = root_ptr; /* convention for first on list */ success = "1"b; /* to init loop */ /* go through all attributes/domains, checking that they are used in some relation */ do while (success); call mrds_rst_tree_successor (root_ptr, node_ptr, successor_ptr, successor_parent_ptr, success); if ^success then ; else do; node_ptr = successor_ptr; gl_ptr = node_ptr -> node.data; /* issue a warning if this attribute/domain is unused */ if gl.superior_assigned then ; else do; /* error message depends on which list was checked */ if attribute_check then if gl.parse_info_ptr -> attribute_domain.default then ; else call unused_attribute_error (); /* only if not default attribute */ else do; call unused_domain_error (); /* call delete_domain_info () ; */ end; end; end; end; declare attribute_check bit (1); /* ON => this is for the attribute list elements, else domains */ end; unused_attribute_error: procedure (); /* output error message warning of an attribute without a relation */ attdom_ptr = gl.parse_info_ptr; if attribute_domain.default then do; line_mesg = "h"; default_mesg = "default_"; end; else do; default_mesg = ""; line_mesg = "given on line " || ltrim (char (attribute_domain.line_num)) || " h"; end; call ioa_$rs ("^a ^a^a^a^a ^a^a", message, message_length, "The", default_mesg, "attribute """, gl.name, """", line_mesg, "as never been assigned to a relation."); call mrds_rst_error (rsc_ptr, 1 /* severity */, mrds_error_$rst_unused_attr, (message)); end; unused_domain_error: procedure (); /* output error message warning of a domain unreferenced by a relation */ call ioa_$rs ("^a^a^a ^d ^a", message, message_length, "The domain """, gl_ptr -> gl.name, """ given on line", gl_ptr -> gl.parse_info_ptr -> domain.line_num, "has only been referenced by attributes that have no assigned relation."); call mrds_rst_error (rsc_ptr, 1 /* severity */, mrds_error_$rst_unused_attr_dom, (message)); end; declare meter_mesg char (4); /* name of directive being checked */ declare mrds_rst_meter entry (ptr, char (*), bit (1), char (*)); /* restructuring metering routine */ declare default_mesg char (8) varying; declare line_mesg char (24) varying; declare mrds_rst_tree_successor entry (ptr, ptr, ptr, ptr, bit (1)); /* get next on list routine */ declare ioa_$rs entry options (variable); /* string manipulator routine */ declare message char (256); /* specifics of error */ declare message_length fixed bin (21); /* length of specifics message */ declare mrds_rst_error entry (ptr, fixed bin (2), fixed bin (35), char (*)); /* error handler */ declare mrds_error_$rst_unused_attr fixed bin (35) ext; /* unreferenced attr error */ declare mrds_error_$rst_unused_attr_dom fixed bin (35) ext; /* unreferenced attrs dom unused elsewhere */ declare sys_info$max_seg_size fixed bin (35) ext;/* largest segment size */ declare (addr, rel, fixed, char, ltrim) builtin; /* functions known to pl1 */ %include mrds_rst_rsc; %include mrds_rst_parse_info; %include mrds_rst_tree; %include mrds_rst_global_lists; %include mrds_rst_semantics; %include mdbm_db_model; end;  mrds_rst_create_db.pl1 10/16/86 1551.9rew 10/16/86 1142.8 104049 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ mrds_rst_create_db: proc (rsc_ptr, dbm_ptr, code); /****^ HISTORY COMMENTS: 1) change(85-12-03,Spitzer), approve(85-12-03,MCR7311), audit(86-09-02,Blair), install(86-10-16,MR12.0-1187): initialize unreferenced_attribute_ptr offset. END HISTORY COMMENTS */ /* BEGIN_DESCRIPTION This procedure creates the skeleton of a database, including: db_model (data base model segment) dbc (database control segment) These segments are initialized before returning. If an error occures the data base is not created (it is deleted). END_DESCRIPTION */ /* HISTORY Written by Roger D. Lackey December 1978 Modified by Jim Gray - 3/20/79 - - to handle new versions of model and working storage (rsc) Modified by Jim Gray - - 80-11-06, to 1) add initialization of mdbm_secured bit in db_model 2) always create a submodel_dir under the database dir 3) change the version_status major number from 7 to 8 4) put the version_status number in a mrds_data_ entry Modified by Jim Gray - - 80-11-07, to put the name of the submodel dir in a standard mrds_data_ entry fors users and mrds to refer to. Modified by Jim Gray - - 80-11-10, to change delete_$path to calls to hcs_$delentry_file and hcs_$del_dir_tree for performance purposes. 80-12-09 Jim Gray : mdbm_util_$init_dbc changed to call to mdbm_util_$create_control_segment as part of r-u to r-s-m-d scope mode and dbc version change. CMDB now always creates version 5 dbc structures in a segment "db.control". 82-04-09 Davids: modified the init_db_model procedure so that it uses . the new names for elements in the db_model, specifically . unused_offsets and restructuring_history_offset. 82-04-15 Davids: changed unused_offset (13) to inconsistent_message_offset 82-05-04 Davids: changed unused_offset (12) to last_restructuring_history_offset . and added the prefix first_ to restructuring_history_offset 82-08-19 Davids: changed code to set the value of db_model.db_type to either 1 (vfile db) or 2 (page_file db) based on the value of rsc.db_type instead of just always setting it to 1. 83-02-14 Davids: modified to use the new db_type_flags in the db_model structure instead of the old numeric db_type. 83-10-04 Benjamin: reverted change of 80-11-10. */ /* PARAMETERS rsc_ptr (INPUT) pointer to control segment (contains rsc.temp_dir (database path)) dbm_ptr (OUTPUT) pointer to db_model code (OUTPUT) error code */ %page; db_created_sw = OFF; on cleanup call tidy_up; /* Set a cleanup handler */ if rsc.meter_sw | rsc.trace_sw then call mrds_rst_meter (rsc_ptr, MODULE_NAME, ON, ""); call expand_pathname_ (rsc.temp_dir, dir, db_ent, code); if code ^= 0 then call error (code); call hcs_$append_branchx (dir, db_ent, 11, RINGS, /* Create the data base directory */ get_group_id_$tag_star (), 1, 0, 0, code); if code ^= 0 then call error (code); db_created_sw = ON; /* Remember database directory was created */ call hcs_$append_branchx (rtrim (dir) || ">" || rtrim (db_ent), /* create the submodel_dir */ mrds_data_$submodel_dir_name, 11, RINGS, get_group_id_$tag_star (), 1, 0, 0, code); if code ^= 0 then call error (code); call hcs_$make_seg (rsc.temp_dir, "db_model", "", 10, dbm_ptr, code); /* Create the db_model */ if dbm_ptr = null then call error (code); else call init_db_model; call mdbm_util_$create_control_segment (rsc.temp_dir, dbc_ptr, dbc_bit_count, code); if code ^= 0 then call error (code); exit: if rsc.meter_sw | rsc.trace_sw then call mrds_rst_meter (rsc_ptr, MODULE_NAME, OFF, ""); return; /* Only exit from this procedure */ %page; error: proc (cd); dcl cd fixed bin (35); call tidy_up; code = cd; /* Set return error code */ goto exit; end error; tidy_up: proc; /* Clean up procedure */ if db_created_sw /* If database created then delete it */ then do; delete_options.force = ON; delete_options.question = OFF; delete_options.directory = ON; delete_options.segment = ON; delete_options.link = ON; delete_options.chase = ON; delete_options.raw = OFF; delete_options.library = OFF; delete_options.mbz = OFF; call delete_$path (dir, db_ent, string (delete_options), MODULE_NAME, code); end; end tidy_up; %page; init_db_model: procedure; /* This procedure initializes the db_model */ db_model_path = rtrim (rsc.temp_dir) || ">db_model"; db_model.version = mdbm_data_$current_version; db_model.dbm_area = empty; db_model.version_ptr = set_version (); db_model.changer_ptr = set_change_time (); db_model.uniq_sw_name = unique_chars_ ("0"b) || ".mrds" || copy (" ", 32 - 15 - 5); /* unique switch name */ db_model.db_type_flags.vfile_type = ^rsc.db_relation_mode_flags.dm_file_type; db_model.db_type_flags.concurrency_on = rsc.db_relation_mode_flags.concurrency_on; db_model.db_type_flags.transactions_needed = rsc.db_relation_mode_flags.protection_on; db_model.db_type_flags.rollback_on = rsc.db_relation_mode_flags.rollback_on; db_model.consistant = "0"b; db_model.mdbm_secured = rsc.secure; /* on if cmdb -secure option */ db_model.copy_good = "0"b; db_model.reserved = "0"b; db_model.num_rels = 0; db_model.blk_file_id_len = 0; db_model.unblk_file_id_len = 0; db_model.num_blk_files = 0; db_model.num_unblk_files = 0; db_model.num_domains = 0; db_model.num_dyn_links = 0; db_model.max_max_tuples = 0; db_model.pad_1 = 0; db_model.pad_2 = 0; db_model.file_ptr = NULL_OFFSET; db_model.domain_ptr = NULL_OFFSET; db_model.unreferenced_attribute_ptr = NULL_OFFSET; db_model.unused_offsets (*) = NULL_OFFSET; db_model.last_restructuring_history_offset = NULL_OFFSET; db_model.inconsistent_message_offset = NULL_OFFSET; db_model.first_restructuring_history_offset = NULL_OFFSET; return; end init_db_model; %page; set_version: procedure () returns (bit (18)); /* fill in the version structure */ /* this major number was 7 for the MR8 mrds release, it was changed to 8 on 80-11-06, to signify the addition of the submodel_dir to the architecture */ call mrds_rst_model_alloc (rsc_ptr, db_model_path, VERSION_STATUS, version_status_ptr); if version_status_ptr = null () then call model_overflow ("version_status"); else do; /* CMDB/RMDB source code version */ version_status.cmdb_rmdb.major = mrds_data_$current_version_status; /* MR8.0 */ version_status.cmdb_rmdb.minor = 0; version_status.cmdb_rmdb.modification = " "; /* database model version */ version_status.model.major = mrds_data_$current_version_status; version_status.model.minor = 0; version_status.model.modification = " "; /* resultant model version */ version_status.resultant.major = mrds_data_$current_version_status; version_status.resultant.minor = 0; version_status.resultant.modification = " "; end; return (rel (version_status_ptr)); end; %page; set_change_time: procedure () returns (bit (18)); /* fill in the user_id and time for the database creator */ call mrds_rst_model_alloc (rsc_ptr, db_model_path, CHANGER, changer_ptr); if changer_ptr = null () then call model_overflow ("changer"); else do; changer.id = get_group_id_ (); changer.time = clock (); changer.next = NULL_OFFSET; /* creator = last on list */ end; return (rel (changer_ptr)); end; %page; model_overflow: procedure (struct_cause); /* report mdb_model overflow, first time only */ if rsc.model_overflow then ; else do; rsc.model_overflow = ON; call ioa_$rs ("^a^a^a^a", message, message_length, "LOGIC ERROR in mrds_rst_create_db, the db_model area overflowed", "while processing the structure """, struct_cause, """."); call mrds_rst_error (rsc_ptr, 4 /* severity */, mrds_error_$rst_logic_error, (message)); end; declare struct_cause char (*); /* either "changer", or "version_status" */ end; %page; /* External entries */ declare ioa_$rs entry options (variable); /* string manipulator */ declare mrds_error_$rst_logic_error fixed bin (35) ext; /* program error */ declare mrds_rst_error entry (ptr, fixed bin, fixed bin (35), char (*)); /* general error routine */ declare mrds_rst_model_alloc entry (ptr, char (*), fixed bin, ptr); /* model allocation routine */ declare unique_chars_ entry (bit (*)) returns (char (15)); /* unique char string routine */ dcl mdbm_util_$create_control_segment entry (char (168), ptr, fixed bin (24), fixed bin (35)); declare dbc_bit_count fixed bin (24); dcl mdbm_data_$current_version ext fixed bin (35); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl get_group_id_$tag_star entry returns (char (32)); dcl get_group_id_ entry returns (char (32)); dcl clock builtin; dcl addr builtin; dcl copy builtin; dcl fixed builtin; dcl rel builtin; dcl rtrim builtin; dcl string builtin; dcl delete_$path entry (char (*), char (*), bit (36) aligned, char (*), fixed bin (35)); dcl hcs_$append_branchx entry (char (*), char (*), fixed bin (5), (3) fixed bin (3), char (*), fixed bin (1), fixed bin (1), fixed bin (24), fixed bin (35)); dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)); dcl mrds_rst_meter entry (ptr, char (*), bit (1), char (*)); dcl MODULE_NAME char (18) int static options (constant) init ("mrds_rst_create_db"); dcl OFF bit (1) int static options (constant) init ("0"b); dcl ON bit (1) int static options (constant) init ("1"b); dcl RINGS (3) fixed bin (3) init static options (constant) init (7, 7, 7); /* Ring brackets */ declare message char (120) varying;/* specifics of error message */ declare message_length fixed bin (21); /* length of specifics string */ dcl dir char (168); /* Directory superior to data base */ declare db_model_path char (168); /* path down to db_model segment */ declare mrds_data_$current_version_status fixed bin (35) ext; /* display_mrds_dm needs to know about this */ declare mrds_data_$submodel_dir_name char (16) ext; /* common place to get name of submodel dir */ dcl db_ent char (32); /* Data base directory name */ dcl code fixed bin (35); /* error code */ dcl db_created_sw bit (1); /* ON => Db_directory was created */ dcl (empty, null) builtin; dcl NULL_OFFSET bit (18) unal int static options (constant) init ("111111111111111111"b); dcl cleanup condition; dcl sys_info$max_seg_size ext fixed bin (35); %page; %include mrds_rst_struct_types; %page; %include mdbm_db_model; %page; %include mdbm_dbc; %page; %include mrds_rst_rsc; %page; %include delete_options; end mrds_rst_create_db;  mrds_rst_create_rsc.pl1 04/18/85 1454.7r w 04/18/85 0909.0 61362 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ mrds_rst_create_rsc: create_rsc: proc (input_dir, rsc_ptr, code); /* This procedure creates and initializes the temporary rsc working storage under the given directory, as a directory containing segments allocated according to a storage classification of data functional use */ /* Initially written by R. D. Lackey August 1978 */ /* modified by Jim Gray 2/19/79, to change structure of rsc to directory with extensible area segments */ /* MODIFIED by Jim Gray - - Jan. 1980, to add initialization of foreign_key, blocked file, and restructuring allow flags. */ /* Modified by Jim Gray - - Feb. 1980, to add init of command level bit */ /* Modified by Jim Gray - - 80-11-06, to add inititalization of rsc.secure bit */ /* 81-05-18 Jim Gray : added initialization of rsc.max_attrs bit */ /* 82-07--6 Roger Lackey : changed call to mu_define_area to mdbm_util_$mu_define_area for binding*/ /* input_dir (INPUT PARAMETER) pathname where rsc directory is to be appended */ /* rsc_ptr (OUTPUT PARAMETER) pointer to rsc segment */ /* code (OUTPUT PARAMETER) error code from append_branchx or make_seg or define_area_ */ %page; /* get a new directory under the given pathname in which to put the working storage segments, 1 common, and several extensible areas */ dir_name = unique_chars_ ("0"b) || ".rsc_dir"; call hcs_$append_branchx (input_dir, dir_name, 01011b /* sma acl's */, rings, get_group_id_$tag_star (), 1 /* directory */, 0 /* copy_sw */, 0 /* bit_count */, code); if code ^= 0 then goto exit; /* Create rsc common storage data segment */ rsc_dir_name = rtrim (input_dir) || ">" || dir_name; call hcs_$make_seg (rsc_dir_name, unique_chars_ ("0"b) || ".MRDS.rsc.rst", "", 10 /* rw acl's */, rsc_ptr, code); if code ^= 0 then goto exit; /* Return with bad error code */ /* Initiallize all the elements of the rsc structure */ rsc.rsc_dir = rsc_dir_name; rsc.dbp = BLANK; rsc.temp_dir = BLANK; rsc.temp_dir_sw = OFF; rsc.db_quiesced_sw = OFF; rsc.o_db_open_sw = OFF; rsc.n_db_open_sw = OFF; rsc.listing_seg_sw = OFF; rsc.skip_scanner_conversion = OFF; rsc.cmdb_option = OFF; rsc.trace_sw = OFF; rsc.debug_sw = OFF; rsc.meter_sw = OFF; rsc.delete_db_sw = OFF; rsc.model_consistent_sw = OFF; rsc.physical_started_sw = OFF; rsc.physical_complete_sw = OFF; rsc.model_overflow = OFF; rsc.max_files = OFF; rsc.allow_foreign_keys = OFF; rsc.foreign_key_seen = OFF; rsc.allow_blocked_files = OFF; rsc.blocked_file_seen = OFF; rsc.allow_restructuring = OFF; rsc.command_level = ON; rsc.secure = OFF; rsc.max_attrs = OFF; rsc.severity_high = 0; rsc.phase = 0; rsc.h_o_seg_info_ls_ptr = null; rsc.h_n_seg_info_ls_ptr = null; rsc.h_gfile_ptr = null; rsc.h_gdom_ptr = null; rsc.h_gattr_ptr = null; rsc.h_grel_ptr = null; rsc.h_glink_ptr = null; rsc.o_dm_ptr = null; rsc.n_dm_ptr = null; rsc.o_fn_hdr_ptr = null; rsc.source_seg_ptr = null; rsc.listing_iocb_ptr = null; rsc.directive_ptr = null; rsc.stmt_ptr = null; rsc.trace_metering_iocb_ptr = null; rsc.wa = empty (); /* non-extensible common area for static storage */ /* get segments and initialize them as extensible areas */ rsc.tree_node_area_ptr = area_init ("tnode"); rsc.tree_data.seg_info_area_ptr = area_init ("seg_in"); rsc.tree_data.gl_area_ptr = area_init ("gl"); rsc.tree_data.sl_area_ptr = area_init ("sl"); rsc.parse_info_area_ptr = area_init ("parse"); rsc.static_info_area_ptr = area_init ("static"); rsc.variable_length_area_ptr = area_init ("variab"); rsc.other_area_ptr = area_init ("other"); exit: return; %page; area_init: procedure (class_word) returns (ptr); /* first get a segment to use as an area */ call hcs_$make_seg (rsc.rsc_dir, unique_chars_ ("0"b) || ".MRDS." || class_word, "", 10 /* rw acl's */, model_seg_ptr, code); if code ^= 0 then goto exit; /* set up the segment header, get the area pointer */ model_seg_ptr -> model_seg.struct_offset = NULL_OFFSET; model_seg_ptr -> model_seg.padding = 0; model_area_ptr = pointer (model_seg_ptr, size (model_seg)); /* routine to initialize the area_info for the define area call */ call mdbm_util_$mu_define_area (model_area_ptr, sys_info$max_seg_size - size (model_seg), "MRDS." || class_word, "1"b /* extensible */, "0"b /* freeing */, "0"b, "0"b /* no zeroing */, code); if code ^= 0 then goto exit; return (model_area_ptr); dcl class_word char (6) varying; /* name for class type of storage in segment */ end; %page; dcl (addr, empty, fixed, pointer, rel, rtrim) builtin; dcl rsc_dir_name char (168); /* pathname of rsc directory */ dcl dir_name char (32); /* name of rsc directory entry */ dcl input_dir char (*); dcl get_group_id_$tag_star entry returns (char (32)); dcl rings (3) fixed bin (3) init ((3) 7); dcl hcs_$append_branchx entry (char (*), char (*), fixed bin (5), (3) fixed bin (3), char (*), fixed bin (1), fixed bin (1), fixed bin (24), fixed bin (35)); dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)); dcl unique_chars_ entry (bit (*)) returns (char (15)); dcl NULL_OFFSET bit (18) init ((18)"1"b); dcl mdbm_util_$mu_define_area entry (ptr, fixed bin (18), char (11), /* does call to define_area_ */ bit (1) aligned, bit (1) aligned, bit (1) aligned, bit (1) aligned, fixed bin (35)); dcl BLANK char (1) int static options (constant) init (" "); dcl OFF bit (1) int static options (constant) init ("0"b); dcl ON bit (1) int static options (constant) init ("1"b); dcl code fixed bin (35); /* (INPUT PARAMETER) eror code */ dcl null builtin; dcl sys_info$max_seg_size fixed bin (35) ext; %page; %include mdbm_seg_area; %page; %include mrds_rst_rsc; %page; %include area_info; %page; %include area_structures; end mrds_rst_create_rsc;  mrds_rst_domain_handler.pl1 10/16/86 1551.9r w 10/16/86 1145.0 123399 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* HISTORY: originally written by jim gray - - october 1978 Modified by RDL October 1978 to add define and cmdb code Modified by Jim Gray 3/20/79 - to handle to versions of model and working storage (rsc) */ mrds_rst_domain_handler: procedure (rsc_ptr, list_ptr); /* DESCRIPTION: this routine is called by the RMDB/CMDB parser to build/alter the mrds database model based on the parse information passed to it, and which directive called it.(undefine, define, redefine, cmdb) it will be passed only domain information of one of two forms, either a single name to delete, or a structure for defining a new domain, or redefining an existing domain. */ /* PARAMETERS: rsc_ptr - - (input) pointer to the common control segment list_ptr - - (input) pointer to either a 32 character domain name, or to a parse_info domain structure describing the domain. the first only occurs with the undefine directive. mdbm_db_model - - (output) the updated model with it's domain information altered gloabl lists - - (output) the database entity list reflecting the changes to the model(used for ease of reference during RMDB/CMDB) error_output - - (output) via calls to mrds_rst_error for error messages */ /* REMAINING ERRORS: undefine: the domain name may be the (this may be ignored) the domain may not be defined in the model define, cmdb: the domain name may be the (this can be ignored) the domain may be already defined in the model. the check option stack may have bad(unconverted) constants(this can be ignored) the encode_proc, decode_proc, check_proc pathnames may be invalid (i.e. may not be able to initiate them) redefine: the domain name may be the (this can be ignored). the domain may not be defined in the model. same check and procedure errors as under define. note: where it is stated "(this may be ignored)", this is because a previous error has been issued that will prevent the bad information from ever being built into and used in a valid db_model. */ Start: directive_ptr = rsc.directive_ptr; /* So we can use directive str */ stmt_ptr = rsc.stmt_ptr; if directive.type = UNDEFINE then do; delete_name_ptr = list_ptr; domain_name = delete_name.overlay; end; else do; domain_ptr = list_ptr; domain_name = domain.name; end; if rsc.trace_sw then call mrds_rst_meter (rsc_ptr, "mrds_rst_domain_handler", ON /* entrance */, (domain_name)); if directive.type = UNDEFINE then do; /* Undefine the domain */ /* This is not implemented yet so issue an error */ if stmt (directive.type).domain.number > 0 then ; else call error (2, mrds_error_$rst_undone_option, "The domain handler will not implement the ""undefine"" directive" || " until a later release."); end; /* END of undefine */ if directive.type = DEFINE | directive.type = CMDB then do; /* Define or cmdb section */ dbm_ptr = rsc.n_dm_ptr; /* db_model pointer */ call mrds_rst_list_element$add /* Add to global domain list */ (domain.name, MAIN_LIST, rsc_ptr, rsc.h_gdom_ptr, gl_ptr, code); if code ^= 0 then do; /* Something wrong happened */ if code = mrds_error_$rst_list_duplicate then call error (2, mrds_error_$domain_already_defined, "The domain """ || rtrim (domain.name) || """ given on line " || ltrim (char (domain.line_num)) || " is already defined" || ", the duplicate will be ignored!!"); else call error (3, code, "Adding " || rtrim (domain.name) || " to gdom_list"); end; /* Domain was not found in gdom list so it was added to the gdom list */ /* Fill in list elements in gdom list entry for this domain */ gl.type = MAIN_LIST; gl.name = domain.name; gl.item_info_ptr = null (); /* no domain_info pointer yet */ gl.parse_info_ptr = domain_ptr; gl.other_info_ptr = dbm_ptr; gl.item_sub_list_ptr = null; /* No attributes attached to this domain yet */ gl.file_info_ptr = null; gl.file_model_ptr = null; gl.affected = ON; gl.undefine = OFF; gl.redefine = OFF; if directive.type = DEFINE then do; gl.define = ON; gl.cmdb = OFF; end; else do; gl.define = OFF; gl.cmdb = ON; end; gl.superior_assigned = OFF; /* no referencing relations yet */ gl.inferior_assigned = OFF; /* No attributes assigned to this domain yet */ gl.complete = ON; /* domain info assigned */ gl.consistant = ON; /* assume innocent until proven guilty */ gl.reserved = OFF; /* allocate a domain info for this domain */ db_model_path = rtrim (rsc.temp_dir) || ">db_model"; call mrds_rst_model_alloc (rsc_ptr, db_model_path, DOMAIN_INFO, di_ptr); if di_ptr = null () then call model_overflow ("domain_info"); else do; call init_domain_info; /* Set all default values */ gl.item_info_ptr = di_ptr; call assign_domain_info; /* Fill in domain_info with info from domain structure */ /* link the domain info into to the list in definition order */ if db_model.domain_ptr = NULL_OFFSET then db_model.domain_ptr = rel (di_ptr); else do; if stmt (directive.type).domain.number > 0 then ; /* not first time */ else do; /* first time, get end of current list */ last_di_ptr = pointer (dbm_ptr, db_model.domain_ptr); do while (last_di_ptr -> domain_info.fwd_thread ^= NULL_OFFSET); last_di_ptr = pointer (dbm_ptr, last_di_ptr -> domain_info.fwd_thread); end; end; last_di_ptr -> domain_info.fwd_thread = rel (di_ptr); /* set old last pointing to new last */ end; last_di_ptr = di_ptr; /* remember new last place on list */ /* count up the number of domains */ db_model.num_domains = db_model.num_domains + 1; end; end; /* define or cmdb section */ if directive.type = REDEFINE then do; /* Redefine section */ /* THis directive is not implemented yet -- so issue error msg */ if stmt (directive.type).domain.number > 0 then ; else call error (2, mrds_error_$rst_undone_option, "The domain handler will not implement the ""redefine"" directive" || " until a later release."); end; /* END of redefine section */ exit: /* Only exit from procedure */ if rsc.trace_sw then call mrds_rst_meter (rsc_ptr, "mrds_rst_domain_handler", OFF /* exit */, (domain_name)); return; assign_domain_info: proc; /* This procedure assignes the information supplied in domain (from parser) to the domain_info elements */ domain_info.name = domain.name; domain_info.changer_ptr = db_model.changer_ptr; domain_info.db_desc = domain.descriptor; domain_info.user_desc = domain.descriptor; domain_info.ave_len = domain.varying_avg_length; if domain.options then do; /* Some options were supplied */ if domain.check.flag then do; /* check option */ if domain.check.stack_ptr = null then domain_info.ck_stack_ptr = NULL_OFFSET; else domain_info.ck_stack_ptr = rel (domain.check.stack_ptr); domain_info.nck_items = domain.check.stack_size; call mrds_rst_error (rsc_ptr, 2 /* severity */, mrds_error_$rst_undone_option, "The ""-check"" option given for domain """ || rtrim (domain.name) || """ on line " || ltrim (char (domain.line_num)) || " will not be implemented until a later release."); end; if domain.check_proc.flag then do; /* check_proc option */ domain_info.check_path_ptr = set_path_entry ((domain.check_proc.path), (domain.check_proc.entry)); end; if domain.encode_proc.flag then do; /* encode_proc option */ domain_info.encd_path_ptr = set_path_entry ((domain.encode_proc.path), (domain.encode_proc.entry)); end; if domain.decode_proc.flag then do; /* decode_proc option */ domain_info.decd_path_ptr = set_path_entry ((domain.decode_proc.path), (domain.decode_proc.entry)); end; if domain.decode_dcl.flag then do; /* decode_dcl option */ domain_info.user_desc = domain.decode_dcl.descriptor; end; end; /* END if domain.options then do */ end assign_domain_info; error: proc (sev, cd, msg); dcl sev fixed bin; /* (INPUT) Severity level */ dcl cd fixed bin (35); /* (INPUT) error code */ dcl msg char (*); /* (INPUT) specific error information */ call mrds_rst_error (rsc_ptr, sev, cd, msg); goto exit; end error; init_domain_info: proc; domain_info.name = " "; domain_info.db_desc_is_ptr = OFF; domain_info.user_desc_is_ptr = OFF; domain_info.db_desc = OFF; domain_info.user_desc = OFF; domain_info.no_conversion = OFF; domain_info.procedures_present = OFF; domain_info.reserved = OFF; domain_info.nck_items = 0; domain_info.ave_len = 0; domain_info.fwd_thread = NULL_OFFSET; domain_info.ck_stack_ptr = NULL_OFFSET; domain_info.check_path_ptr = NULL_OFFSET; domain_info.encd_path_ptr = NULL_OFFSET; domain_info.decd_path_ptr = NULL_OFFSET; domain_info.str_before_path_ptr = NULL_OFFSET; domain_info.str_err_path_ptr = NULL_OFFSET; domain_info.str_after_path_ptr = NULL_OFFSET; domain_info.get_before_path_ptr = NULL_OFFSET; domain_info.get_err_path_ptr = NULL_OFFSET; domain_info.get_after_path_ptr = NULL_OFFSET; domain_info.mod_before_path_ptr = NULL_OFFSET; domain_info.mod_err_path_ptr = NULL_OFFSET; domain_info.mod_after_path_ptr = NULL_OFFSET; domain_info.unused_1 = NULL_OFFSET; domain_info.unused_2 = NULL_OFFSET; domain_info.changer_ptr = NULL_OFFSET; end init_domain_info; set_path_entry: procedure (path, entry) returns (bit (18)); /* routine to allocate and fill in the path_entry structure, and return the offset to it */ call mrds_rst_model_alloc (rsc_ptr, db_model_path, PATH_ENTRY, path_entry_ptr); if path_entry_ptr = null () then do; path_entry_ptr = pointer (null (), NULL_OFFSET); call model_overflow ("path_entry"); end; else do; /* fill in the supplied path and entry names */ path_entry_ptr -> path_entry.path = path; path_entry_ptr -> path_entry.entry = entry; end; return (rel (path_entry_ptr)); declare path char (168); /* input pathname */ declare entry char (32); /* input entryname */ end; model_overflow: procedure (struct_cause); /* report model capacity exceeded, first time only */ if rsc.model_overflow then ; else do; rsc.model_overflow = ON; call ioa_$rs ("^a^a^a ^d ^a^a^a", message, message_length, "The domain """, domain.name, """ on line", domain.line_num, "caused an overflow of the db_model while processing the structure """, struct_cause, """."); call mrds_rst_error (rsc_ptr, 2 /* severity */, mrds_error_$rst_model_limit, (message)); end; declare struct_cause char (*); /* either "domain_info", or "path_entry" */ end; dcl (null, rtrim, addr, fixed, rel) builtin; dcl NULL_OFFSET bit (18) unal int static options (constant) init ("111111111111111111"b); dcl ON bit (1) internal static options (constant) init ("1"b); /* true state */ dcl OFF bit (1) internal static options (constant) init ("0"b); /* false */ dcl list_ptr ptr; /* (INPUT PARAMETER) */ declare last_di_ptr ptr internal static; /* pointer to last domain_info in list */ declare db_model_path char (168); /* path name down to db_model */ declare message_length fixed bin (21); /* length of error specifics message */ dcl code fixed bin (35); /* Error code */ dcl sys_info$max_seg_size ext fixed bin (35);/* System constant */ declare mrds_rst_model_alloc entry (ptr, char (*), fixed bin, ptr); /* model alloc routine */ dcl char builtin; dcl ltrim builtin; dcl pointer builtin; declare message char (256) varying;/* specifics of error occurence */ declare domain_name char (32); /* input name for metering */ declare mrds_error_$rst_model_limit fixed bin (35) ext; /* model capacity exceededd */ dcl mrds_error_$rst_undone_option fixed bin (35) external; /* option not coded yet */ dcl mrds_error_$rst_list_duplicate ext fixed bin (35); /* Duplicate found in attemp to add to list */ dcl mrds_error_$domain_already_defined ext fixed bin (35); declare ioa_$rs entry options (variable); /* string manipulator */ dcl mrds_rst_list_element$add entry (char (32) aligned, fixed binary, ptr, ptr, ptr, fixed bin (35)); dcl mrds_rst_meter entry (ptr, char (*), bit (1), char (*)); /* metering/tracing routine */ dcl mrds_rst_error entry (ptr, fixed bin, fixed bin (35), char (*)); /* general error handler */ %include mrds_rst_rsc; %include mrds_rst_struct_types; %include mrds_rst_semantics; %include mrds_rst_global_lists; %include mrds_rst_parse_info; %include mdbm_db_model; end;  mrds_rst_error.pl1 04/18/85 1454.7r w 04/18/85 0908.8 62010 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* HISTORY: Originally written by roger lackey Modified by Jim Gray - - Feb. 1980, to add signaling of th condition mrds_rst_error, when rsc.command_level is off, indicating that CMDB was called from a subroutine level, and thus not to output errors to error_output. Modified by Jim Gray - - Mar. 1980, to fix formatting of specifics message, so that no blanks in a 79 char length of text are handled better. */ mrds_rst_error: proc (rsc_ptr, severity, err_code, specifics_text); /* PARAMETERS */ /* rsc_ptr ptr; / Pointer to rst (restructuring ) control segment */ dcl severity fixed bin; /* (INPUT) 1 = Warning level error detected 2 = syntax error detected 3 = 4 = Fatal error during logical phase of restructuring 5 = fatal error during physical restructuring */ dcl err_code fixed bin (35); /* (INPUT) error code for com_err_ */ dcl specifics_text char (*); /* (INPUT) associated specific message */ /* . BEGIN_DESCRIPTION this routine is a common error reporting routine for create/restructure_mrds_db it's primary purpose is to format error messages for output on the users console. The error messages include a severity level, the error table message, plus one or more lines of length <= 80, with specifics about this error. It also can return simple a condition info with the status code, instead of doing an user error output(except for the listing segment) if the call was from a subroutine level. . END_DESCRIPTION */ %page; call convert_status_code_ (err_code, shortinfo, longinfo); if severity < 2 then err_msg.type = "WARNING "; else err_msg.type = "*ERROR*"; err_msg.severity_level = severity; err_msg.msg1 = longinfo; specifics = specifics_text || NL; call format_specifics_message (); code = 0; /* init */ if rsc.command_level then do; /* called as a command, not from subroutine level */ call iox_$put_chars (iox_$error_output, addr (err_msg), length (string (err_msg)), code); call iox_$put_chars (iox_$error_output, addrel (addr (specifics), 1), length (specifics), code); end; else do; /* fill in the condition information for find_condition_info_, then signal the condition mrds_rst_error for mrds_dm_create_db to handle, since this was a call from a subroutine interface */ mrds_error_cond_info.length = size (mrds_error_cond_info); mrds_error_cond_info.version = 1; mrds_error_cond_info.cant_restart = "0"b; mrds_error_cond_info.default_restart = "1"b; mrds_error_cond_info.pad = "0"b; mrds_error_cond_info.info_string = substr (specifics, 1, min (256, length (specifics))); mrds_error_cond_info.status_code = err_code; mrds_error_cond_info.severity = severity; mrds_error_cond_info.severity_high = rsc.severity_high; call signal_ ("mrds_rst_error", null (), addr (mrds_error_cond_info)); end; if code = 0 then if rsc.listing_seg_sw then do; call iox_$put_chars (rsc.listing_iocb_ptr, addr (err_msg), length (string (err_msg)), code); call iox_$put_chars (rsc.listing_iocb_ptr, addrel (addr (specifics), 1), length (specifics), code); end; if code ^= 0 then do; if rsc.command_level then call com_err_ (code, "mrds_rst_error"); else call sub_err_ (code, "mrds_rst_error", "c", null (), 0, "Unable to output listing."); end; rsc.severity_high = max (rsc.severity_high, severity); %page; format_specifics_message: procedure (); /* routine to break long lines down to shorter ones by inserting new_lines where blanks appear, so that error messages will not be folded by the printing device. */ i, pos = 1; do while (pos + 79 < length (specifics)); /* Break into 79 char lines or less at a blank char */ i = index (reverse (substr (specifics, pos, 79)), BLANK); if i ^= 0 then do; substr (specifics, pos + 79 - i, 1) = NL; pos = pos + 79 - i; end; else do; /* no blank in 79 chars, find first blank following */ pos = pos + 79; i = index (substr (specifics, pos), BLANK); if i ^= 0 then do; substr (specifics, pos + i - 1, 1) = NL; pos = pos + i; end; else pos = length (specifics); /* no blanks left, get out */ end; end; end; %page; dcl code fixed bin (35); dcl com_err_ entry options (variable); dcl convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned); dcl iox_$error_output ext ptr; dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl longinfo char (100) aligned;/* Long msg from convert status code */ dcl shortinfo char (8) aligned; /* Short msg from convert status code */ dcl sys_info$max_seg_size ext fixed bin (35); declare signal_ entry options (variable); /* passes cond_info structure upon signaling condition */ declare 1 mrds_error_cond_info aligned, %include cond_info_structure; 2 severity fixed bin, 2 severity_high fixed bin; declare sub_err_ entry options (variable); dcl (addr, fixed, length, max, rel, size, string) builtin; dcl (addrel, index, min, null, reverse, substr) builtin; dcl BLANK char (1) int static options (constant) init (" "); dcl NL char (1) int static options (constant) init (" "); dcl (i, pos) fixed bin; dcl 1 err_msg aligned, 2 lf0 char (1) unal init (" "), /* Start with a line feed */ 2 type char (8) unal, /* Type = WARNING or *ERROR* */ 2 constant char (12) unal init ("OF SEVERITY "), 2 severity_level pic "9" unal, /* Severity numeric 1 to 5 see input parameter */ 2 lf1 char (1) unal init (" "), 2 msg1 char (100) unal, /* Error message from error table */ 2 lf2 char (1) unal init (" "); dcl specifics char (256) varying unal; /* Additional err info */ %page; %include mrds_rst_rsc; end mrds_rst_error;  mrds_rst_file_cleanup.pl1 04/18/85 1454.7r w 04/18/85 0909.1 55773 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ mrds_rst_file_cleanup: procedure (rsc_ptr); /* DESCRIPTION: This routine is invoked to supply default unblocked files for relations which have had no files specified for them. it produces dummy file list structures identical to the input to mrds_rst_file_handler that have a file name equal to the relation name, and then calls the file handler to put the file models in place. PARAMETERS: rsc_ptr - - (input) pointer to the common control segment global lists - - (input) searched for relations without files since they contain all database entities during RMDB/CMDB parse info structures - - (output) via calls to mrds_rst_file_handler to build the file model as default for the given relation HISTORY: 78-10-01 Jim Gray : Originally written. 81-09-16 Rickie E. Brinegar: changed the assignment of gl.name to file.name to be done via a rtrim to remove the substring range condition from compile. */ %page; /* get semantic structure pointers */ directive_ptr = rsc.directive_ptr; /* if trace is on call metering */ if ^rsc.trace_sw then ; else do; if directive.type = DEFINE then directive_mesg = "DEFINE"; else if directive.type = REDEFINE then directive_mesg = "REDEFINE"; else directive_mesg = "CMDB"; call mrds_rst_meter (rsc_ptr, "mrds_rst_file_cleanup", "1"b /* in */, directive_mesg); end; /* check for relations with no referencing files, any found get default files of the same name as that of the given relation, using unblocked file attributes */ if directive.type = REDEFINE then do; call ioa_$rs ("^a ^a", message, message_length, "The file cleanup handler will not implement the ""redefine""", "directive until a later release."); call mrds_rst_error (rsc_ptr, 2 /* severity */, mrds_error_$rst_undone_option, (message)); end; else do; /* initialize the successor function to get the first relation on the global list of relations in the database */ root_ptr = rsc.h_grel_ptr; node_ptr = root_ptr; /* convention for first on list */ success = "1"b; /* do at least one loop */ do while (success); call mrds_rst_tree_successor (root_ptr, node_ptr, successor_ptr, successor_parent_ptr, success); if ^success then ; /* success off => no more in list */ else do; /* next relation found */ node_ptr = successor_ptr;/* get pointer to next on list after last one */ gl_ptr = node_ptr -> node.data; /* get element portion from tree head */ if gl.superior_assigned then ; /* file present for this relation */ else do; /* none found, set default file */ /* make believe we are the parser, and that we just found an file definition of "rel_name(rel_name) -unblocked" */ call mrds_rst_rsc_alloc (rsc_ptr, FILE, file_ptr); file.name = rtrim (gl.name); /* set relation name as file's */ file.type = 1; /* default file type = unblocked */ file.ppb = 0; /* zero out blocked file parameters */ file.hbh = 0; file.block = 0; file.num_items = 1; /* one relation in file */ file.default = "1"b; /* not from source definition */ file.unused = "0"b; file.line_num = 0; /* set file relation list to one relation with this relation name */ call mrds_rst_rsc_alloc (rsc_ptr, ITEM, item_ptr); file.i_ptr = item_ptr; /* link to file header */ item.name = gl.name; /* set relation name */ item.next = null (); /* no more in list */ item.unused = "0"b; item.line_num = 0; /* dummy number */ /* define the file just prepared */ call mrds_rst_file_handler (rsc_ptr, file_ptr); end; end; end; end; /* call trace if metering is on */ if ^rsc.trace_sw then ; else call mrds_rst_meter (rsc_ptr, "mrds_rst_file_cleanup", "0"b /* out */, directive_mesg); %page; declare ioa_$rs entry options (variable); /* string manipulation routine */ declare mrds_rst_rsc_alloc entry (ptr, fixed bin, ptr); /* work area manager */ declare mrds_rst_error entry (ptr, fixed bin, fixed bin (35), char (*)); /* general error handler */ declare message char (96) varying; /* specifics of error message */ declare message_length fixed (21); /* length of specifics message */ declare mrds_error_$rst_undone_option fixed bin (35) external; /* unimplemented feature */ declare directive_mesg char (8); /* meter call message */ declare mrds_rst_tree_successor entry (ptr, ptr, ptr, ptr, bit (1)); /* get next on list routine */ declare mrds_rst_file_handler entry (ptr, ptr); /* file semantic routine */ declare mrds_rst_meter entry (ptr, char (*), bit (1), char (*)); /* trace/meter routine */ declare sys_info$max_seg_size fixed bin (35) external; /* system largest segment allowed */ declare (fixed, addr, null, rel, rtrim) builtin; /* functions known to pl1 */ %page; %include mrds_rst_rsc; %page; %include mrds_rst_struct_types; %page; %include mrds_rst_global_lists; %page; %include mrds_rst_tree; %page; %include mrds_rst_parse_info; %page; %include mrds_rst_semantics; end;  mrds_rst_file_handler.pl1 10/16/86 1551.9r w 10/16/86 1143.7 376353 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* HISTORY: originally written by jim gray - - october 1978 modified by Jim Gray - - July 1979 to add pl1 version of data alignment in tuple Modified by Jim Gray - - Dec. 1979, to add consideration of packed decimal data types to pad_to_alignment_boundary routine. Modified by Jim Gray - - Dec. 1979, to make pad_to_alignment_boundary external procedure mdbm_util_$align_data_item, so other routines could use it. Modified by Jim Gray - - Jan. 1980, to disallow file statement, only default files are now allowed. Modified by Jim Gray - - April 1980, to remove abs. path in attach desc, so databsaes can be copied. Modified by Jim Gray - - Sept. 1980, to capture the use of reserved segment names "dbc" and "db_model" for this new architecture. 81-04-30 Jim Gray : changed max number of relations creatable tobe dependent on mrds_data_$max_relations, rather than on a file_id_len that is constrained by the mdbm_tuple_id include file structure. 81-05-01 Jim Gray : changed db_model.file_id_len to be taken from mrds_data_$max_relations 81-05-18 Jim Gray : added check for max attrs per relation 81-09-16 Davids: added the rtrim so that the code would compile with . the prefix option stringsize. 81-11-25 Davids: changed rel_info.id to be "000000000001"b and file_info.file_id to be "000000000000000000000000000000000001"b, For all relations and files. This was to prepare the way for easy restructuring, i.e. adding and deleteing relations and making temp_rels permanent. 82-05-19 Davids: changed rel_info.nsec_inds to rel_info.unused_3 because it really wasn't the number of secondary indices in the relation it was always zero - it is still 0 but now it has a more descriptive name. 82-06-25 R. Harvey: changed to use mdbm_file_model_init.incl to speed up creation of databases. 82-07-02 Roger Lackey: deleted file_model.num_rels = file_model.num_rels + 1; because it is now initialized in structured and only one relation per file is allowed now. 83-02-17 Davids: explicitly declared variables that were declared by context or implication and deleted declarations to variables that were not referenced. */ mrds_rst_file_handler: procedure (rsc_ptr, list_ptr); /* . BEGIN_DESCRIPTION: this routine builds/alters the mrds database model file information and the global entity lists maintained by RMDB/CMDB, based upon the file data and directive that is active when called by the RMDB/CMDB parser. the directive may be undefine, define, redefine, or cmdb and the data is either a file name to be deleted, or a linked list of linked list of structures holding the file information and it's relation list . END_DESCRIPTION */ /* PARAMETERS: rsc_ptr - - (input) pointer to the common control segment list_ptr - - (input) pointer to the single file name to be deleted(undefine only) or to the file structure headed list of relation structures database model - - (output) updated model with altered file information global lists - - (output) the list of database entities, updated according to directive and data error_output - - (output) via mrds_rst_error calls, of error messages */ /* REMAINING ERRORS: undefine: the file name may be the (this may be ignored) the file may not be defined in the database define, cmdb: the file name may be the (this may be ignored) one of the relation names may be the (this may be ignored) the file may already be defined in the database a relation may not be defined in the database a relation may reside in a file already the file/relation max_tuples may not be set the file type may conflict with the max_tuples option values given redefine: same as define, except file name may not be defined in the database or the relation(s) may reside in other than the given file note: "(this may be ignored)" means a previous error will prevent a database model with erroneous information from being built */ /* set semantic structure pointers */ stmt_ptr = rsc_ptr -> rsc.stmt_ptr; directive_ptr = rsc_ptr -> rsc.directive_ptr; if directive.type = UNDEFINE then do; /* input structure depends on direcitve */ delete_name_ptr = list_ptr; file_name = rtrim (delete_name.overlay);/* CHANGE 81-09-16 */ end; else do; file_ptr = list_ptr; file_name = file.name; end; /* call trace if metering is on */ if ^rsc.trace_sw then ; else call mrds_rst_meter (rsc_ptr, "mrds_rst_file_handler", IN, file_name); /* check on which directive called us */ if directive.type = UNDEFINE | directive.type = REDEFINE then do; if stmt (directive.type).file.number > 0 then ; /* not first time */ else do; /* first time only, issue error */ call ioa_$rs ("^a ^a", message, message_length, "The file handler will not implement ""undefine"" or ""redefine""" , "directives until a later release."); call mrds_rst_error (rsc_ptr, 2 /* severity */, mrds_error_$rst_undone_option, (message)); end; end; else do; /* define or cmdb directive was caller, process newly defined file */ if file.default then ; /* called from file cleanup to give default file for rels */ else if rsc.allow_blocked_files then ; else if rsc.blocked_file_seen then ; else do; rsc.blocked_file_seen = ON; call ioa_$rs ("^a", message, message_length, "The file statment will not be implemented until a later release." ); call mrds_rst_error (rsc_ptr, 2 /* severity */, mrds_error_$rst_undone_option, (message)); end; call define_file (); end; /* call the trace routine if metering is turned on */ if ^rsc.trace_sw then ; else call mrds_rst_meter (rsc_ptr, "mrds_rst_file_handler", OUT, file_name); define_file: procedure (); /* routine to build the model for this file according to it's definition */ error_mode = OFF; /* check that files defined in the source do not use relation names */ if file.default then ; /* file from cleanup handler */ else do; /* from source */ call mrds_rst_tree_search ((file.name), rsc.h_grel_ptr, node_ptr, parent_ptr, success); if ^success then ; /* not a relation name */ else do; /* bad name, do a fixup */ error_mode = ON; /* set special provisions for detecting all errors */ call ioa_$rs ("^a^a^a ^d ^a", message, message_length, "The file """, file.name, """ on line", file.line_num, "has the same name as a relation, only default files may have relation names!!" ); call mrds_rst_error (rsc_ptr, 2 /* severity */, mrds_error_$rst_dup_file, (message)); call mrds_rst_rsc_alloc (rsc_ptr, GL, gl_ptr); /* get dummy version not in list */ end; end; /* make sure the file is not already in the database or previously defined(if above error did'nt occur) */ if error_mode then error_code = 0; else call mrds_rst_list_element$add ((file.name), MAIN_LIST, rsc_ptr, rsc.h_gfile_ptr, gl_ptr, error_code); if error_code = 0 then ; /* normal processing of good file */ else do; error_mode = ON; /* make special provisions so all errors are detected */ call ioa_$rs ("^a^a^a ^d ^a", message, message_length, "The file """, file.name, """ on line", file.line_num, "is already defined in the database, duplicate names are not allowed!!" ); call mrds_rst_error (rsc_ptr, 2 /* severity */, mrds_error_$rst_dup_file, (message)); call mrds_rst_rsc_alloc (rsc_ptr, GL, gl_ptr); /* make dummy version not in list */ end; /* check for reserved segment names (due to db architecture) being used for file name */ if file.name ^= "dbc" & file.name ^= "db_model" then ; else do; error_mode = ON; /* use unique name instead of reserved name */ if file.default then call ioa_$rs ("^a^a^a", message, message_length, "The relation name """, file.name, """ is a reserved name in this database architecture."); else call ioa_$rs ("^a^a^a ^d ^a", message, message_length, "The file name """, file.name, """ given on line", file.line_num, "is a reserved name in this database architecture."); call mrds_rst_error (rsc_ptr, 2 /* severity */, mrds_error_$rst_reserved_name, (message)); end; /* file was not found in list so it was added, link list element to list head and fill in the blanks */ gl.type = MAIN_LIST; gl.name = file.name; gl.item_info_ptr = null (); /* no file_info yet */ gl.parse_info_ptr = file_ptr; gl.other_info_ptr = gl_ptr; gl.item_sub_list_ptr = null (); /* no relations yet */ gl.file_info_ptr = null (); /* no file model defined to hold file yet */ gl.file_model_ptr = null (); gl.affected = ON; gl.undefine = OFF; gl.redefine = OFF; if directive.type = DEFINE then do; gl.define = ON; gl.cmdb = OFF; end; else do; /* CMDB directive */ gl.define = OFF; gl.cmdb = ON; end; gl.superior_assigned = OFF; /* no file model for this file yet */ gl.inferior_assigned = OFF; /* no relations for this file yet */ gl.complete = OFF; /* file is not formatted yet */ gl.consistant = ON; /* assume innocent until proven guilty */ gl.reserved = OFF; /* build the file model and file_info for this file */ call load_file_model (); /* process the list of relations for this file */ if ^gl.superior_assigned then ; else do; call file_relation_handler (); /* compute parameters for blocked files, now that max_tuples and tuple sizes are known */ if ^gl.inferior_assigned then gl.consistant = OFF; /* check for too many files or too many tuples */ call check_file_size_and_number (); end; end; file_relation_handler: procedure (); /* check each relation in the list for this file */ max_tuples = 0; item_ptr = file.i_ptr; /* get first on list of this file's relations */ do while (item_ptr ^= null ()); /* make sure that the given relation is defined in the database */ call mrds_rst_tree_search (item.name, rsc.h_grel_ptr, node_ptr, parent_ptr, success); if ^success then do; /* not found */ call ioa_$rs ("^a^a^a ^d ^a^a^a", message, message_length, "The relation """, item.name, """ on line", item.line_num, "given for file """, file.name, """ has not been defined in the database."); call mrds_rst_error (rsc_ptr, 2 /* severity */, mrds_error_$rst_undef_rel, (message)); end; else do; rel_gl_ptr = node_ptr -> node.data;/* get relation global element pointer */ relation_ptr = rel_gl_ptr -> gl.parse_info_ptr; /* get relation declaration */ /* check that this relation is not already in some file */ if ^rel_gl_ptr -> gl.superior_assigned then ; else do; call ioa_$rs ("^a^a^a ^d ^a^a^a^a^a", message, message_length, "The relation """, relation.name, """ on line", relation.line_num, "given in file """, file.name, """ is already defined as belonging to file """, rel_gl_ptr -> gl.other_info_ptr -> gl.name, """, moving relations is not allowed!!"); call mrds_rst_error (rsc_ptr, 2 /* severity */, mrds_error_$rst_rel_has_file, (message)); end; rel_gl_ptr -> gl.superior_assigned = ON; /* file present for this relation */ rel_gl_ptr -> gl.file_info_ptr = fi_ptr; /* set file info/model in relation global element */ rel_gl_ptr -> gl.file_model_ptr = fm_ptr; rel_gl_ptr -> gl.other_info_ptr = gl_ptr; /* file global list element for relation */ /* add this relation to the file's relation sublist */ call mrds_rst_list_element$add (relation.name, SUB_LIST, rsc_ptr, gl.item_sub_list_ptr, sl_ptr, error_code); if error_code ^= 0 then do; call ioa_$rs ("^a^a^a^a", message, message_length, "LOGIC ERROR in mrds_rst_file_handler, a duplicate relation """ , relation.name, """ was found in sublist of file """, file.name, """."); call mrds_rst_error (rsc_ptr, 4 /* severity */, error_code, (message)); num_dims = 0; /* unused variable */ end; else do; /* fill in the sublist element */ sl.type = SUB_LIST; sl.name = relation.name; sl.item_info_ptr = null (); /* no relation info yet */ sl.parse_info_ptr = relation_ptr; /* relation parse structure */ sl.old_other_info_ptr = null (); sl.new_other_info_ptr = gl_ptr; sl.global_list_ptr = rel_gl_ptr; sl.reserved = OFF; /* build the relation info for this "good" relation in this file */ call load_rel_info (); gl.inferior_assigned = ON; /* relation present for file */ /* build all the attribute infos contained in this relation, if attributes present, and rel_info obtained */ if ^rel_gl_ptr -> gl.inferior_assigned | ^rel_gl_ptr -> gl.complete then ; else do; call load_attr_infos (); call check_relation_key_length (); call align_varying_tuple_data (); end; end; end; /* go to next relation in list */ item_ptr = item.next; end; end; load_file_model: procedure (); /* routine to initialize and fill in the file model/info */ db_model_path = rtrim (rsc.temp_dir) || ">db_model"; /* update the db_model file statistics */ dbm_ptr = rsc.n_dm_ptr; db_model.num_unblk_files = db_model.num_unblk_files + 1; db_model.unblk_file_id_len = max (db_model.unblk_file_id_len, fixed (ceil (log2 (db_model.num_unblk_files)), 17)); bit_36_temp = db_model.num_unblk_files; /* add a file_info to the db_model for this file */ call mrds_rst_model_alloc (rsc_ptr, db_model_path, FILE_INFO, fi_ptr); if fi_ptr ^= null () then ; else if rsc.model_overflow then ; /* reported first time only */ else do; rsc.model_overflow = ON; call ioa_$rs ("^a^a^a^a ^a", message, message_length, "File """, file.name, """", line_number (), "caused an overflow of the db_model while processing the file_info.") ; call mrds_rst_error (rsc_ptr, 2 /* severity */, mrds_error_$rst_model_limit, (message)); end; gl.file_info_ptr = fi_ptr; gl.item_info_ptr = fi_ptr; if error_mode then name_of_file = unique_chars_ ("0"b); /* use dummy name if previous error */ else name_of_file = rtrim (file.name); file_model_path = rtrim (rsc.temp_dir) || ">" || name_of_file || ".m"; if fi_ptr = null () then ; /* due to model overflow */ else do; file_info.file_name = name_of_file; file_info.file_id = "000000000000000000000000000000000001"b; /* link into file_info list in order */ file_info.fwd_ptr, file_info.unused = NULL_OFFSET; if db_model.file_ptr = NULL_OFFSET then db_model.file_ptr = rel (fi_ptr); else do; if stmt (directive.type).file.number > 0 then ; /* not first time */ else do; /* first time, get list end */ last_fi_ptr = pointer (dbm_ptr, db_model.file_ptr); do while (last_fi_ptr -> file_info.fwd_ptr ^= NULL_OFFSET); last_fi_ptr = pointer (dbm_ptr, last_fi_ptr -> file_info.fwd_ptr); end; end; last_fi_ptr -> file_info.fwd_ptr = rel (fi_ptr); /* set list end as new file_info */ end; last_fi_ptr = fi_ptr; end; /* get a segment for a file_model for this file */ call mrds_rst_get_seg_ptr (rsc_ptr, rsc.h_n_seg_info_ls_ptr /* put in new model list */, name_of_file || ".m" /* file_model name */, ON /* create seg */, fm_ptr, error_code); if error_code ^= 0 then do; call ioa_$rs ("^a^a^a", message, message_length, "Unable to make segment for file model of file """, name_of_file, """."); call mrds_rst_error (rsc_ptr, 4 /* severity */, error_code, (message)); end; else do; /* initialize the file model */ call file_model_init (); gl.superior_assigned = ON; /* file model for file present */ gl.file_model_ptr = fm_ptr; end; end; file_model_init: procedure (); /* fill in file parameters with initial values */ like_file_model = init_file_model; /* init model */ file_model.fi_ptr = rel (fi_ptr); /* offset in db_model of file_info */ file_model.changer_ptr = db_model.changer_ptr; /* get person.project and system time */ file_model.fm_area = empty (); /* initailize file_model area */ end; load_rel_info: procedure (); /* routine to allocate and initialize the rel_info structure for the current relation in this file, using the file model area, and updating the file_model and global file element as necessary */ call mrds_rst_model_alloc (rsc_ptr, file_model_path, REL_INFO, ri_ptr); if ri_ptr ^= null then rel_gl_ptr -> gl.complete = ON; /* rel_info present now */ else if rsc.model_overflow then ; /* reported only first time */ else do; rsc.model_overflow = ON; call ioa_$rs ("^a^a^a^a ^a^a^a", message, message_length, "File """, file.name, """", line_number (), "caused an overflow of the file_model while processing the relation """ , relation.name, """."); call mrds_rst_error (rsc_ptr, 2 /* severity */, mrds_error_$rst_model_limit, (message)); end; rel_gl_ptr -> gl.item_info_ptr = ri_ptr; /* set rel_info in rel global element */ sl.item_info_ptr = ri_ptr; /* set rel_info in file's rel sublist element */ /* update the relation count */ if ri_ptr = null () then ; else do; db_model.num_rels = db_model.num_rels + 1; /* initialize relation detailed information */ rel_info = init_rel_info; /* copy template */ rel_info.name = relation.name; rel_info.changer_ptr = file_model.changer_ptr; bit_36_temp = db_model.num_rels; file_model.rel_ptr = rel (ri_ptr); end; end; load_attr_infos: procedure (); /* routine to allocate and initialize the attr_info structures for the attributes in the current relation, using the file model area, updating the file_model and rel_info and global list elements as necessary to reflect the additions */ root_ptr = rel_gl_ptr -> gl.item_sub_list_ptr; /* start of attr list for this relation */ all_attributes_used = OFF; /* not all attrs added to rel yet */ current_definition_order = 1; /* run through all attributes in this relation */ do while (^all_attributes_used); if ^definition_order_found () then all_attributes_used = ON; else do; /* get needed pointers */ di_ptr = attr_gl_ptr -> gl.other_info_ptr; /* get attribute's domain info pointer */ dom_sl_ptr = attr_gl_ptr -> gl.item_info_ptr; /* corres domain sublist for attr */ /* now get space for a new attr_info for this attribute for this relation */ call mrds_rst_model_alloc (rsc_ptr, file_model_path, ATTR_INFO, ai_ptr); if ai_ptr ^= null then attr_gl_ptr -> gl.complete = ON; /* attr_info present */ else if ^rsc.model_overflow then do; rsc.model_overflow = ON; /* so only first overflow reported */ call ioa_$rs ("^a^a^a^a ^a^a^a^a^a", message, message_length, "File """, file.name, """", line_number (), "caused an overflow of the file_model while processing attribute """ , attr_gl_ptr -> gl.name, """ in relation """, rel_gl_ptr -> gl.name, """."); call mrds_rst_error (rsc_ptr, 2 /* severity */, mrds_error_$rst_model_limit, (message)); end; /* update global list entries */ rel_sl_ptr -> sl.item_info_ptr = ai_ptr; /* set attr_info in rel's attr sublist element this can be used now to get the fm_ptr via pointer(ai_ptr,0) and the fi_ptr via pointer(fm_ptr, file_model.fi_ptr) */ if attr_sl_ptr ^= null () then do; attr_sl_ptr -> sl.item_info_ptr = ri_ptr; /* set rel_info in attr's rel sublist element */ attr_sl_ptr -> sl.old_other_info_ptr = ai_ptr; /* set attr_info ptr for this rel */ end; if dom_sl_ptr = null () then ; else dom_sl_ptr -> sl.item_info_ptr = ai_ptr; /* set attr_info in domain's attr sublist */ /* fill in the attr_info structure for this attribute */ call set_attr_info (); end; /* go to the next attribute in user defined order */ current_definition_order = current_definition_order + 1; end; end; set_attr_info: procedure (); /* routine to fill in the attr_info structure details */ /* count up number of attributes */ if ai_ptr = null () then ; else do; rel_info.num_attr = rel_info.num_attr + 1; if ^attribute.pr_key then ; else rel_info.num_key_attrs = rel_info.num_key_attrs + 1; if rel_info.num_attr > mrds_data_$max_attributes & ^rsc.max_attrs then do; rsc.max_attrs = ON; call ioa_$rs ("^a^a^a^a^a ^d^a", message, message_length, "Attribute """, attr_gl_ptr -> gl.name, """ in relation """, rel_gl_ptr -> gl.name, """ exceeded the maxmimum number of attributes allowed per relation of" , mrds_data_$max_attributes, "."); call mrds_rst_error (rsc_ptr, 2 /* severity */, mrds_error_$max_attributes, (message)); end; /* initialize attr_info structure */ attr_info.name = attribute.name; attr_info.changer_ptr = file_model.changer_ptr; attr_info.key_attr = attribute.pr_key; /* ON => primary key */ attr_info.index_attr = OFF; /* not involved in indexes or links yet */ attr_info.link_attr = OFF; attr_info.reserved = OFF; attr_info.index_id = OFF; attr_info.defn_order = attribute.defn_order; attr_info.key_order = attribute.key_order; attr_info.link_par_cnt, attr_info.link_child_cnt = 0; attr_info.rslt_ptr = NULL_OFFSET; /* off for mrds */ /* compute attribute bit offset and length, update rel_info max data length, and number/offset of varying attributes, and the average tuple size, also set the attribute and global list domain info pointers */ call compute_bit_offset_and_length (); /* sets average_tuple_length */ /* link the attr_info into the list in definition order */ current_ai_ptr = pointer (fm_ptr, rel_info.attr_ptr); last_ai_ptr = null (); place_not_found = ON; /* find the right list position according to definition order */ do while (place_not_found); if rel (current_ai_ptr) = NULL_OFFSET then place_not_found = OFF; else if current_ai_ptr -> attr_info.defn_order >= attr_info.defn_order then place_not_found = OFF; else do; last_ai_ptr = current_ai_ptr; current_ai_ptr = pointer (fm_ptr, current_ai_ptr -> attr_info.fwd_thread); end; end; /* set this attr_info's forward pointer */ if current_ai_ptr = null () then attr_info.fwd_thread = NULL_OFFSET; else attr_info.fwd_thread = rel (current_ai_ptr); /* set previous pointer to this attr_info */ if last_ai_ptr = null () then rel_info.attr_ptr = rel (ai_ptr); else last_ai_ptr -> attr_info.fwd_thread = rel (ai_ptr); end; end; definition_order_found: procedure () returns (bit (1)); /* this routine determines if the current definition order correspondes to any in the sublist of attrs for this relation */ node_ptr = root_ptr; /* convention for first on list */ found = OFF; required_order_found = OFF; do while (^found); call get_definition_order (order_was_obtained, order_obtained); if ^order_was_obtained then do; found = ON; required_order_found = OFF; end; else if current_definition_order ^= order_obtained then ; else do; found = ON; required_order_found = ON; end; end; return (required_order_found); declare required_order_found bit (1); /* on => current order is in list */ declare found bit (1); /* on => exit loop, else keep looking */ declare order_was_obtained bit (1); /* on => given order was in list */ declare order_obtained fixed bin; /* order found during get next order */ end; get_definition_order: procedure (found, order_found); /* get the definition order of the next attribute in the relation's attr sublist */ call mrds_rst_tree_successor (root_ptr, node_ptr, successor_ptr, successor_parent_ptr, found); if ^found then order_found = 0; else do; node_ptr = successor_ptr; /* make it the current one */ rel_sl_ptr = node_ptr -> node.data; /* get rel sublist pointer */ attr_gl_ptr = rel_sl_ptr -> sl.global_list_ptr; /* get global attr pointer */ call list_search (relation.name, attr_gl_ptr -> gl.item_sub_list_ptr, attr_sl_ptr, ATTR_SL); attribute_ptr = rel_sl_ptr -> sl.parse_info_ptr; /* get parse information */ order_found = attribute.defn_order; end; declare order_found fixed bin; /* definition order of next attribute */ declare found bit (1); /* on => attr found, else none left */ end; list_search: procedure (key, root_ptr, data_ptr, success); /* routine to get an element pointer from the global lists */ call mrds_rst_tree_search (key, root_ptr, node_ptr, parent_ptr, success); if success then data_ptr = node_ptr -> node.data; else do; call ioa_$rs ("^a^a^a", message, message_length, "LOGIC ERROR in mrds_rst_file_handler, the name """, key, """ was found in a global list, but not in the corresponding sublist" ); call mrds_rst_error (rsc_ptr, 4 /* severity */, mrds_error_$rst_logic_error, (message)); data_ptr = null (); end; declare key char (32) aligned; /* name to look for in list */ declare root_ptr ptr; /* head of desired list */ declare node_ptr ptr; /* pointer to head portion of list element */ declare parent_ptr ptr; /* pointer to tree parent of found node */ declare data_ptr ptr; /* pointer to data portion of list element */ declare success bit (1); /* ON => element found */ end; compute_bit_offset_and_length: procedure (); /* routine to convert the attribute's domain descriptor into the required tuple offset and space required and update the corresponding statistics for the relation information NOTE: the padding routines were introduced to make the data stored in the tuple(via bit offset/length) relect the pl1 definition of storage locations needed for unaligned and aligned data types */ attr_info.bit_length = get_domain_bit_size (); /* also sets domain_info ptr in attr_info */ /* fixed length attribute/domain handling */ if ^varying_string then do; /* fixed attributes */ padding = mdbm_util_$align_data_item (desc_ptr, rel_info.var_offset - 1); attr_info.bit_offset = rel_info.var_offset + padding; /* set to end of fixed data */ rel_info.var_offset = rel_info.var_offset + attr_info.bit_length + padding; /* set new fixed data end */ rel_info.avg_data_len = rel_info.avg_data_len + attr_info.bit_length + padding; /* average = max for fixed */ end; /* varying string handling */ else do; /* varying strings */ rel_info.nvar_atts = rel_info.nvar_atts + 1; /* count up varying attributes */ attr_info.bit_offset = rel_info.nvar_atts; /* varying array index, not offset */ rel_info.avg_data_len = rel_info.avg_data_len + average_varying_length + pad (WORD, average_varying_length); /* use average for varying */ padding = pad (WORD, attr_info.bit_length); /* varying must start/stop on word boundary */ end; /* set the maximum tuple and key bit lengths */ rel_info.max_data_len = rel_info.max_data_len + attr_info.bit_length + padding; if ^attribute.pr_key then ; else rel_info.max_key_len = rel_info.max_key_len + attr_info.bit_length; end; get_domain_bit_size: procedure () returns (fixed binary (35)); /* calculate the amount of storage that needs to be allocated(in bits) to hold a converted value that has the same type as t