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 the domain */ varying_string = OFF; /* set attributes domain info pointer */ if di_ptr = null () then do; attr_info.domain_ptr = NULL_OFFSET; domain_bit_length = 1; /* set dummy domain size */ attr_gl_ptr -> gl.consistant = OFF; /* no domain info present for attribute */ desc_ptr = null (); end; else do; /* good domain present */ attr_info.domain_ptr = rel (di_ptr); attr_gl_ptr -> gl.other_info_ptr = di_ptr; /* set domain_info in attr global element */ rel_sl_ptr -> sl.new_other_info_ptr = di_ptr; /* set domain_info in rel sublist for attr */ desc_ptr = addr (domain_info.db_desc); /* get descriptor for this attribute */ /* set bit length according to this domain's data type, and average length of varying strings */ domain_bit_length = mdbm_util_$get_data_bit_length (desc_ptr -> descriptor_bit_36_ovrly) ; /* set varying strings average bit length */ if descriptor.type = 20 then do; /* bit varying */ varying_string = ON; average_varying_length = domain_info.ave_len + 36; end; else if descriptor.type = 22 then do; /* char varying */ varying_string = ON; average_varying_length = (domain_info.ave_len * 9) + 36; end; else ; /* not varying string */ end; return (domain_bit_length); declare domain_bit_length fixed binary (35); /* required bit length to store domain's data */ end; pad: procedure (pad_size, pad_base) returns (fixed bin); /* routine to return the number of bits necessary to pad a bit count out to an alignment boundary of 9(byte), 36(word), or 72(double word) bits as determined by the pad size input */ if mod (pad_base, pad_size) = 0 then number_of_bits = 0; else do; number_of_bits = pad_size - mod (pad_base, pad_size); end; return (number_of_bits); declare pad_size fixed bin; /* either 9 or 36 or 72 */ declare pad_base fixed bin (35); /* current bit length to be padded */ declare number_of_bits fixed bin; /* what has to be added to get to the desired boundary */ end; align_varying_tuple_data: procedure (); /* varying attributes in the tuple must start on a word boundary, this routine makes sure that the end of the fixed data portion of the tuple, which is where the varying attributes start, is on that boundary */ if rel_info.nvar_atts = 0 then ; else do; amount_to_pad = pad (WORD, rel_info.var_offset - 1); rel_info.var_offset = rel_info.var_offset + amount_to_pad; rel_info.max_data_len = rel_info.max_data_len + amount_to_pad; rel_info.avg_data_len = rel_info.avg_data_len + amount_to_pad; end; declare amount_to_pad fixed bin; /* bits needed for word alignment */ end; check_file_size_and_number: procedure (); /* routine to check that the number of files and/or the maximum number of file tuples don't exceed implementation limits based on the mdbm_tuple_id.incl.pl1 constants */ file_id_space = db_model.unblk_file_id_len; /* already set to max(file_id_len, ceil(log2(num_files))) */ db_model.max_max_tuples = max (db_model.max_max_tuples, max_tuples); /* get max across all files so far */ if db_model.max_max_tuples = 0 then tuple_id_space = 0; else tuple_id_space = ceil (log2 (db_model.max_max_tuples)); vfile_component_space = ceil (log2 (max_vfile_components)); /* try to pad the file_id_space out to mrds_data_$file_id_len_pad to make room for restructuring to add files wihtout causing the reformatting of all files in the database due to an overflow of the existing db_model.file_id_len space allotted */ /* if file_type = BLOCKED then blocked_check = ON ; else blocked_check = OFF ; first_time = ON ; space_left_to_pad = ON ; do while (space_left_to_pad) ; if (blocked_check & (file_id_space + tuple_id_space <= 34)) | (^blocked_check & (file_id_space + vfile_component_space <= 17)) then do ; /* last space usage within limits, try to get another bit for the file_id_space to occupy * / if file_id_space < mrds_data_$file_id_len_pad then file_id_space = file_id_space + 1 ; /* can add bit since within needed space guess * / else space_left_to_pad = OFF ; end ; else if ^first_time then do ; /* we padded too much, back off one bit and use that * / file_id_space = file_id_space - 1 ; space_left_to_pad = OFF ; end ; else do ; /* not enough space on the first try with minimrdsm sizes * / space_left_to_pad = OFF ; */ file_id_space = ceil (log2 (mrds_data_$max_relations)) + 1; if db_model.num_blk_files + db_model.num_unblk_files > mrds_data_$max_relations then do; if rsc.max_files then ; /* only give error first time */ else do; rsc.max_files = ON; call ioa_$rs ("^a^a^a^a ^a ^d ^a", message, message_length, "The file """, file.name, """", line_number (), "was unblocked file number", db_model.num_unblk_files, "and exceeded the maximum number of unblocked files allowed." ); call mrds_rst_error (rsc_ptr, 2 /* severity */, mrds_error_$rst_option_limit, (message)); end; end; /* save the possibly bigger file_id_space calculated */ db_model.unblk_file_id_len = file_id_space; declare file_id_space fixed binary; /* bit length of file id */ declare tuple_id_space fixed binary; /* bit length of tuple maximum */ declare vfile_component_space fixed binary; /* bit length of max vfile components */ declare max_vfile_components fixed binary init (900); /* max no of comps */ end; check_relation_key_length: procedure (); /* make sure that the data length of the attributes that make up the primary key for this relation do not exceed the implementation restriction maximum */ key_length_in_chars = ceil (rel_info.max_key_len / 9); if key_length_in_chars <= mrds_data_$max_key_len then ; else do; call ioa_$rs ("^a^a^a ^d ^a^a^a ^d ^a ^d ^a", message, message_length, "The relation """, relation.name, """ on line", relation.line_num, "given in file """, file.name, """ has a primary key data length of", key_length_in_chars, "characters, which is greater than the allowed maximum length of", mrds_data_$max_key_len, "characters."); call mrds_rst_error (rsc_ptr, 2 /* severity */, mrds_error_$long_key, (message)); end; end; line_number: procedure () returns (char (20) varying); /* return null string for default files, or the line occurence for files from the source */ if file.default then returned_line = ""; else returned_line = ", on line " || ltrim (char (file.line_num)) || ","; return (returned_line); declare returned_line char (20) varying; end; declare name_of_file char (30) varying; /* name to add .m to for model seg */ declare db_model_path char (168); /* path name to db_model */ declare file_model_path char (200); /* path name down to file_model */ declare mrds_rst_rsc_alloc entry (ptr, fixed bin, ptr); /* work area manager */ declare mrds_rst_model_alloc entry (ptr, char (*), fixed bin, ptr); /* model allocation routine */ declare unique_chars_ entry (bit (*)) returns (char (15)); /* unique character generator */ declare error_mode bit (1); /* ON => duplicate file name processing fixup */ declare mrds_rst_tree_successor entry (ptr, ptr, ptr, ptr, bit (1)); /* get next routine */ declare attr_gl_ptr ptr; /* pointer to attribute global element */ declare dom_sl_ptr ptr; /* pointer to corres attribute domain sublist element */ declare rel_sl_ptr ptr; /* pointer to relation sublist element */ declare attr_sl_ptr ptr; /* pointer to attribute sublist element */ declare ATTR_SL bit (1); /* ON => pointer found for attr_sl_ptr */ /* init path/entry value */ declare file_name char (30); /* file name for this call */ declare (addr, ceil, char, log2, empty, fixed, ltrim, max, mod, null, pointer, rel, rtrim) builtin; /* functions known to pl1 */ declare ON bit (1) internal static options (constant) init ("1"b); /* true value */ declare OFF bit (1) internal static options (constant) init ("0"b); /* false value */ declare NULL_OFFSET bit (18) internal static options (constant) init ((18)"1"b); /* db version of null offset */ declare sys_info$max_seg_size fixed bin (35) external; /* system constant */ declare mrds_rst_get_seg_ptr entry (ptr, ptr, char (32) aligned, bit (1), ptr, fixed bin (35)); /* ON => get new segment */ declare error_code fixed binary (35); /* mrds_error_ table index */ declare message char (320) varying;/* specifics of error message */ declare message_length fixed bin (21); /* length of specifics message */ declare last_fi_ptr ptr internal static; /* saved file_info pointer */ declare last_ai_ptr ptr; /* saved attr_info pointer */ declare current_ai_ptr ptr; /* pointer to present attr_info in list */ declare place_not_found bit (1); /* definition order insertion place flag */ declare mrds_error_$rst_model_limit fixed bin (35) external; /* model capacity exceeded */ declare mrds_error_$long_key fixed bin (35) external; /* max key length exceeded */ declare mrds_error_$rst_option_limit fixed bin (35) external; /* exceeded allowable for option */ declare mrds_error_$rst_undone_option fixed bin (35) external; /* option not coded yet */ declare mrds_error_$rst_undef_rel fixed bin (35) external; /* item not in database */ declare mrds_error_$rst_dup_file fixed bin (35) external; /* duplicate attr definition */ declare mrds_error_$rst_rel_has_file fixed bin (35) external; /* file assigned to relation */ declare mrds_error_$rst_logic_error fixed bin (35) ext; /* program failure */ declare max_tuples fixed binary (71); /* file's accumulated max tuples */ declare mrds_data_$max_key_len fixed bin (35) ext;/* implementation restriction on key size */ declare key_length_in_chars fixed bin (35); /* computed character length of relation key */ declare mrds_rst_tree_search entry (char (32) aligned, ptr, ptr, ptr, bit (1)); /* list searcher */ 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 rel_gl_ptr ptr; /* temp storage for relation global element pointer */ declare average_varying_length fixed bin (35); /* average varying string bit length */ declare varying_string bit (1); /* ON => varying string type attribute */ declare bit_36_temp fixed bin (35) aligned; /* 36 bit word to overlay */ declare BYTE fixed bin init (9);/* byte boundary = 9 bits */ declare WORD fixed bin init (36); /* word boundary = 36 bits */ declare DOUBLE_WORD fixed bin init (72); /* double word boundary = 72 bits */ declare padding fixed bin; /* amount needed to pad to a given boundary */ declare current_definition_order fixed bin; /* definition order for current attr */ declare all_attributes_used bit (1); /* on => all rel attrs processed */ declare mdbm_util_$get_data_bit_length entry (bit (36)) returns (fixed bin (35)); /* gets storage bits from descriptor */ declare descriptor_bit_36_ovrly bit (36) based; /* overlay for descriptor */ declare mdbm_util_$align_data_item entry (ptr, fixed bin (35)) returns (fixed bin); /* aligns to data type boundary, given current offset */ declare mrds_error_$rst_reserved_name fixed bin (35) ext; /* reserved name used */ declare mrds_data_$max_relations fixed bin (35) ext; /* most relations can create */ declare mrds_data_$max_attributes fixed bin (35) ext; /* max attrs allowed per rel */ declare mrds_error_$max_attributes fixed bin (35) ext; /* > mrds_data_$max_attrs seen */ %include mrds_rst_struct_types; %include mdbm_descriptor; %include mrds_rst_rsc; %include mrds_rst_semantics; %include mrds_rst_parse_info; %include mrds_rst_tree; %include mrds_rst_global_lists; %include mdbm_file_model; %include mdbm_file_model_init; %include mdbm_db_model; end;  mrds_rst_format_file.pl1 08/01/88 1435.5r w 08/01/88 1315.0 115758 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-11-18,Blair), approve(86-11-18,PBF7311), audit(86-12-01,Dupuis), install(86-12-09,MR12.0-1237): Change to use mrds_data_$relation_blocking_factor when creating new relations. END HISTORY COMMENTS */ /* HISTORY Originally coded by Oris Friesen -- June 1978 Modified by Jim Gray - - October 1978, to correct calculate_size Modified by Jim Gray - - November 1978, to correct handling of > 255 pages/blocked file Modified by Jim Gray - - December 1978, to put module and error handling in mrds_rst format Modified by Jim Gray - - March 1979, to correct bucket headers from 0 to 1 when bucket_density < 0 81-05-28 Jim Gray : removed blocked file code 82-09-07 D. Woodka : changed for DMS conversion to call relation_manager create relation and create index. 82-12-07 R. Harvey : fixed bug with secondary index creation - too many calls were previously being made. Also set protected bit in file_create_info. 83-01-10 Mike Kubicar : added a common error handling routine, "error" and returned on the first error. Also added "code" parameter for returning the error encountered. 83-02-17 R. Harvey : changed to support attribute naming in relation_manager interface. 83-10-04 Paul Benjamin : changed hcs_$initiate calls to initiate_file_. Changed "1"b to ON and "0"b to OFF. 84-08-21 Matthew Pierret : changed file_create_info to use version FILE_CREATE_INFO_VERSION_2, added initialization of ring_brackets in file_create_info to 0. */ mrds_rst_format_file: procedure (rsc_ptr, input_file_name, code); %page; /* BEGIN_DESCRIPTION Given a single file name, this routine creates a relation for the database and the corresponding indices according to the file_model of the name file_name.m already defined in the database. END_DESCRIPTION */ /* PARAMETERS rsc_ptr - - (input) pointer to the restructure control segment. input_file_name - - (input) equivalent to file_info.file_name, char(30) aligned, is the name of the data file. code - - (output) returned error code. */ %page; /* call metering if trace is on */ if rsc.trace_sw then call mrds_rst_meter (rsc_ptr, "mrds_rst_file_format", "1"b /* input call */, input_file_name); code = 0; /* initialize for calls to create_relation and create_index */ file_segment_name = rtrim (input_file_name); call initiate_file_ (rsc.dbp, "db_model", RW_ACCESS, dbm_ptr, bit_count, error_code); if error_code = error_table_$no_r_permission | error_code = error_table_$no_w_permission then do; call mrds_dm_authorization$set_needed_access (rtrim (rsc.dbp), error_code); /* fails if user is not a DBA */ if error_code ^= 0 then error_code = mrds_error_$no_model_access; else call initiate_file_ (dbp, "db_model", RW_ACCESS, dbm_ptr, bit_count, error_code); end; if dbm_ptr = null then call error (rsc_ptr, 4 /* severity */, mrds_error_$no_database, " The database model could not be initiated."); file_model_name = rtrim (file_segment_name) || ".m"; call initiate_file_ (rsc.dbp, file_model_name, RW_ACCESS, fm_ptr, bit_count, error_code); if fm_ptr = null then call error (rsc_ptr, 4 /* severity */, error_code, " The file model," || file_model_name || "could not be initiated."); ri_ptr = ptr (fm_ptr, file_model.rel_ptr); /* relation info ptr */ tva_number_of_vector_slots = 0; tva_number_of_dimensions = rel_info.num_attr; tva_maximum_dimension_name_length = 32; allocate typed_vector_array in (rsc.wa); il_number_of_ids = rel_info.num_attr; allocate id_list in (rsc.wa); id_list.number_of_ids = 0; id_list.version = ID_LIST_VERSION_1; typed_vector_array.version = TYPED_VECTOR_ARRAY_VERSION_2; ai_ptr = ptr (fm_ptr, rel_info.attr_ptr); /* get attribute info */ do i = 1 to tva_number_of_dimensions; if attr_info.key_attr then do; /* set up the primary key index */ id_list.number_of_ids = id_list.number_of_ids + 1; id_list.id (id_list.number_of_ids) = attr_info.defn_order; end; di_ptr = ptr (dbm_ptr, attr_info.domain_ptr);/* set up descriptor list for create relation */ typed_vector_array.dimension_table (i).name = attr_info.name; typed_vector_array.dimension_table (i).descriptor_ptr = addr (domain_info.db_desc); ai_ptr = ptr (fm_ptr, attr_info.fwd_thread); end; allocate rel_creation_info in (rsc.wa); allocate file_create_info in (rsc.wa); /* initialize values for create_relation */ rel_creation_info.version = REL_CREATION_INFO_VERSION_2; rel_creation_info.file_create_info_ptr = addr (file_create_info); esm_info_ptr = null; cism_info_ptr = null; file_create_info.version = FILE_CREATE_INFO_VERSION_2; file_create_info.ci_size_in_bytes = 4096; file_create_info.blocking_factor = mrds_data_$relation_blocking_factor; file_create_info.flags.protected = rsc.db_relation_mode_flags.protection_on; file_create_info.flags.no_concurrency = ^rsc.db_relation_mode_flags.concurrency_on; file_create_info.flags.no_rollback = ^rsc.db_relation_mode_flags.rollback_on; file_create_info.flags.mbz_1 = OFF; file_create_info.ring_brackets (*) = 0; file_create_info.mbz_2 = 0; file_create_info.mbz_3 = OFF; /* initialize values for create_index */ style = 1; relation_index_flags_ptr = addr (flag_list); relation_index_flags.relation_must_be_empty = OFF; relation_index_flags.index_is_clustering = OFF; relation_index_flags.index_is_unique = ON; /* for primary key */ /* make call to relation manager */ if rsc.db_relation_mode_flags.dm_file_type then do; /* if this is a page_file database */ call relation_manager_$create_relation (rsc.dbp, file_segment_name, rel_creation_info_ptr, typed_vector_array_ptr, rel_opening_id, rel_info.id, error_code); if error_code ^= 0 then call error (rsc_ptr, 4 /* severity */, error_code, "while creating relation" || file_segment_name); /* create the primary index for the relation */ call relation_manager_$create_index (rel_opening_id, id_list_ptr, flag_list, style, rel_info.primary_key_index_id, error_code); if error_code ^= 0 then call error (rsc_ptr, 4 /* severity */, error_code, "while creating the primary index for" || file_segment_name); end; else do; /* if this is a vfile_ database */ call vfile_relmgr_$create_MRDS_relation (rsc.dbp, file_segment_name, rel_creation_info_ptr, typed_vector_array_ptr, rel_opening_id, rel_info.id, error_code); if error_code ^= 0 then call error (rsc_ptr, 4 /* severity */, error_code, "while creating relation" || file_segment_name); /* create the primary index for the relation */ call vfile_relmgr_$create_index (rel_opening_id, id_list_ptr, flag_list, style, rel_info.primary_key_index_id, error_code); if error_code ^= 0 then call error (rsc_ptr, 4 /* severity */, error_code, "while creating the primary index for" || file_segment_name); end; /* create the secondary indexes for the relation */ relation_index_flags.index_is_unique = OFF; /* index need not be unique for secondary index */ id_list.number_of_ids = 1; /* secondary indices involve only one attribute */ do ai_ptr = ptr (fm_ptr, rel_info.attr_ptr) repeat ptr (fm_ptr, attr_info.fwd_thread) while (rel (ai_ptr) ^= NULL_OFFSET); if attr_info.index_attr then do; id_list.id (1) = attr_info.defn_order; if rsc.db_relation_mode_flags.dm_file_type then do; /* if this is a page_file database */ call relation_manager_$create_index (rel_opening_id, id_list_ptr, flag_list, style, attr_info.index_id, error_code); if error_code ^= 0 then call error (rsc_ptr, 4 /* severity */, error_code, " while creating secondary indices for " || file_segment_name); end; else do; /* if this is a vfile_ database */ call vfile_relmgr_$create_index (rel_opening_id, id_list_ptr, flag_list, style, attr_info.index_id, error_code); if error_code ^= 0 then call error (rsc_ptr, 4 /* severity */, error_code, " while creating secondary indices for " || file_segment_name); end; end; /* index_attr */ end; /* do ai_ptr */ /* close the relation */ if rsc.db_relation_mode_flags.dm_file_type then call relation_manager_$close (rel_opening_id, error_code); else call vfile_relmgr_$close (rel_opening_id, error_code); if error_code ^= 0 then call error (rsc_ptr, 4 /* severity */, error_code, " while closing relation " || file_segment_name); /* call metering if trace is on */ EXIT: if rsc.trace_sw then call mrds_rst_meter (rsc_ptr, "mrds_rst_file_format", "0"b /* output call */, input_file_name); return; %page; /********** * * This error routine provides a common action on error. It will call * mrds_rst_error to display the error and then return. * **********/ error: proc (err_rsc_ptr, err_severity, err_code, err_text); dcl err_rsc_ptr ptr; /* Pointer to rsc common structure */ dcl err_severity fixed bin; /* Cmdb severity */ dcl err_code fixed bin (35); /* Standard error code */ dcl err_text char (*); /* Expanitory text for error */ code = err_code; /* Set error code for return. Note, global parameter (Yuck) */ call mrds_rst_error (err_rsc_ptr, err_severity, err_code, err_text); goto EXIT; end error; %page; dcl bit_count fixed bin (24); /* Required in calls to initiate_file_ */ dcl code fixed bin (35); /* Returned error code */ dcl error_code fixed bin (35); /* internal status return code */ dcl error_table_$no_r_permission fixed bin (35) ext static; dcl error_table_$no_w_permission fixed bin (35) ext static; dcl file_model_name char (32); dcl flag_list bit (36) aligned; dcl i fixed bin; /* index variable */ dcl initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35)); dcl (addr, null, fixed, rel, rtrim, ptr) builtin; dcl rel_opening_id bit (36) aligned; dcl style fixed bin (17); dcl sys_info$max_seg_size fixed bin (35) ext; dcl mrds_rst_meter entry (ptr, char (*), bit (1), char (*)); /* metering routine */ dcl input_file_name char (*); /* file name to be formatted */ dcl file_segment_name char (32); /* rtrim of input_file_name */ dcl mrds_data_$relation_blocking_factor fixed bin (17) external static; dcl mrds_dm_authorization$set_needed_access entry (char (*), fixed bin (35)); dcl mrds_error_$no_database fixed bin (35) ext static; dcl mrds_error_$no_model_access fixed bin (35) ext static; dcl mrds_rst_error entry (ptr, fixed bin, fixed bin (35), char (*)); /* error output routine */ dcl NULL_OFFSET int static bit (18) unal init ((18)"1"b) options (constant); dcl OFF bit (1) aligned internal static options (constant) init ("0"b); dcl ON bit (1) aligned internal static options (constant) init ("1"b); dcl relation_manager_$close entry (bit (36) aligned, fixed bin (35)); dcl relation_manager_$create_index entry (bit (36) aligned, ptr, bit (36) aligned, fixed bin (17), bit (36) aligned, fixed bin (35)); dcl relation_manager_$create_relation entry (char (*), char (*), ptr, ptr, bit (36) aligned, bit (36) aligned, fixed bin (35)); dcl vfile_relmgr_$close entry (bit (36) aligned, fixed bin (35)); dcl vfile_relmgr_$create_MRDS_relation entry (char (*), char (*), ptr, ptr, bit (36) aligned, bit (36) aligned, fixed bin (35)); dcl vfile_relmgr_$create_index entry (bit (36) aligned, ptr, bit (36) aligned, fixed bin (17), bit (36) aligned, fixed bin (35)); %page; %include mrds_rst_rsc; %page; %include mrds_rst_struct_types; %page; %include mdbm_file_model; %page; %include mdbm_rs_info; %page; %include mrds_dbcb; %page; %include mdbm_db_model; %page; %include dm_rel_creation_info; %page; %include dm_file_create_info; %page; %include vu_typed_vector_array; %page; %include dm_id_list; %page; %include dm_relation_index_flags; %page; %include access_mode_values; end mrds_rst_format_file;  mrds_rst_get_seg_ptr.pl1 04/18/85 1454.7r w 04/18/85 0909.1 47151 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ mrds_rst_get_seg_ptr: proc (rsc_ptr, head_of_list_ptr, seg_name, create_sw, seg_ptr, code); /* This procedure searches the specified list in rsc for for the segment name If the create_sw is ON and the segment name was not found in the specified list the segment name is added to the list and the segment created. If the create_sw is ON and the segment name was found in the list the seg_ptr returned is null and code = mrds_error_$rst_list_duplicate. if create_sw = OFF then the bit count is adjusted on the segment and the segment is inititated if possible. The segment pointer and code are returned by this procedure. */ /* HISTORY Initially written by Roger D.Lackey Sept, 78 Modified by R. D. Lackey January 16, 1979 to add adjust_bit_count 81-01-31 Jim Gray : added call to set needed access for DBA types, if access violation occurred. also changed to only make call to adjust_bit_count and/or initiate, if the seg ptr or bit count unknown in order to improve performance. 82-07-02 R. Harvey : changed reference of dmd$set_needed_access to dmd_$set_needed_access */ /* PARAMETERS */ /* dcl rsc_ptr pointer; /* (INPUT) Pointer to rsc (restructuring control) segment */ dcl head_of_list_ptr ptr; /* (INPUT) Pointer to head of list to be searched */ dcl seg_name char (32) aligned; /* (INPUT) Name of segment we are searching for */ dcl create_sw bit (1); /* (INPUT) On => create segment */ dcl seg_ptr ptr; /* (OUTPUT) Pointer to segment (may be null) */ dcl code fixed bin (35); /* (OUTPUT) Error code */ Start: call mrds_rst_list_element$add (seg_name, SEG_INFO, rsc_ptr, head_of_list_ptr, seg_info_ptr, code); if code = 0 | code = mrds_error_$rst_list_duplicate then do; if code = 0 then do; /* Entry was added to list */ seg_info.name = seg_name; /* Init seg info stuff */ if head_of_list_ptr = rsc.h_n_seg_info_ls_ptr then seg_info.dir = rsc.temp_dir; else seg_info.dir = rsc.dbp; seg_info.seg_ptr = null; seg_info.bcnt = 0; end; if create_sw then do; /* create_sw = ON the want to create a seg */ if code = 0 then do; /* Entry was added to the list */ call hcs_$make_seg (seg_info.dir, seg_info.name, "", 10, seg_info.seg_ptr, code); seg_ptr = seg_info.seg_ptr; end; end; /* BEGIN CHANGE 81-01-31 ***************************************************** */ else do; /* Create_sw = OFF */ if ^(seg_info.seg_ptr = null () | seg_info.bcnt = 0) then do; /* already set */ code = 0; seg_ptr = seg_info.seg_ptr; end; else do; call adjust_bit_count_ (seg_info.dir, seg_info.name, "1"b, bit_count, code); if code = error_table_$moderr then do; call dmd_$set_needed_access (seg_info.dir, code); /* fails if caller not DBA */ if code ^= 0 then code = error_table_$moderr; else call adjust_bit_count_ (seg_info.dir, seg_info.name, "1"b, bit_count, code); end; if code = 0 then call hcs_$initiate_count (seg_info.dir, seg_info.name, "", seg_info.bcnt, 0, seg_info.seg_ptr, code); seg_ptr = seg_info.seg_ptr; end; /* END CHANGE 81-01-31 ****************************************************** */ end; end; else seg_ptr = null; /* Something was wrong */ exit: return; /* OTHERS */ dcl bit_count fixed bin (35); /* For adjust bit count */ dcl adjust_bit_count_ entry (char (168), char (32), bit (1) aligned, fixed bin (35), fixed bin (35)); dcl hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35)); dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)); dcl mrds_rst_list_element$add entry (char (32) aligned, fixed bin, ptr, ptr, ptr, fixed bin (35)); dcl mrds_error_$rst_list_duplicate ext fixed bin (35); dcl sys_info$max_seg_size ext fixed bin (35); dcl (addr, fixed, null, rel) builtin; declare error_table_$moderr fixed bin (35) ext;/* incorrect access */ declare dmd_$set_needed_access entry (char (*), fixed bin (35)); /* sets access for DBA types */ %include mrds_rst_rsc; %include mrds_rst_global_lists; %include mrds_rst_tree; end mrds_rst_get_seg_ptr;  mrds_rst_index_handler.pl1 10/16/86 1551.9rew 10/16/86 1142.6 103959 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-04-03,Spitzer), approve(86-04-03,MCR7311), audit(86-09-02,Blair), install(86-10-16,MR12.0-1187): remove unused dcls. END HISTORY COMMENTS */ /* HISTORY: originally written by jim gray - - october 1978 Modified November 1978, by Roger Lackey to add define & cmdb section. 81-05-18 Jim Gray : added check for number of indexed attributes exceeding the capabilities of the rel_id field used in the vfile key for secondary indexes. 83-01-11 Ron Harvey : changed to zero out the index_id field and to set set max_attr_index_id field to beyond the maximum. 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_index_handler: procedure (rsc_ptr, list_ptr); /* DESCRIPTION: this routine builds/alters the mrds database model index information and the global entity lists maintained by RMDB/CMDB, based upon the index 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 a linked list of structures holding the index information and its attribute list */ /* PARAMETERS: rsc_ptr - - (input) pointer to the common control segment list_ptr - - (input) pointer to the relation structure headed list of attribute structures database model - - (output) updated model with altered index 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: define, cmdb: the index name may be the (this may be ignored) one of the attribute names may be the (this may be ignored) the index may already be defined in the database one of the given attributes may not be defined as part of the given index undefine, redefine: same as define, except index name may not be defined in the database note: "(this may be ignored)" means a previous error will prevent a database model with erroneous information from being built */ Start: directive_ptr = rsc.directive_ptr; /* So we can use directive str */ stmt_ptr = rsc.stmt_ptr; index_ptr = list_ptr; index_relation_name = rel_index.rel_name; /* same for all directives */ if rsc.trace_sw then call mrds_rst_meter (rsc_ptr, "mrds_rst_index_handler", ON, (index_relation_name)); if directive.type = UNDEFINE then do; /* Undefine the index */ /* THIS IS NOT IMPLEMENTED YET SO ISSUE AN ERROR MSG */ if stmt (directive.type).index.number > 0 then ; else call error (2, mrds_error_$rst_undone_option, "The index 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 */ item_ptr = rel_index.i_ptr; /* rel_index.i_ptr points to list of indexed attributes for this relation */ /* Make sure relation is defined for data base */ call mrds_rst_tree_search (rel_index.rel_name, rsc.h_grel_ptr, node_ptr, parent_ptr, success); if ^success then do; /* Relation name was not found in db */ call mrds_rst_error (rsc_ptr, 2, mrds_error_$rst_undef_rel, "The indexed relation """ || rtrim (rel_index.rel_name) || """ on line " || ltrim (char (rel_index.line_num)) || " specified for the indexed attribute """ || rtrim (item.name) || """ has not been defined in the database."); /* check that the given attributes are at least defined in the database */ do while (item_ptr ^= null ()); call mrds_rst_tree_search (item.name, rsc.h_gattr_ptr, node_ptr, parent_ptr, success); if ^success then do; call mrds_rst_error (rsc_ptr, 2 /* severity */, mrds_error_$undef_attr, "The attribute """ || rtrim (item.name) || """ given on line " || ltrim (char (item.line_num)) || " is not defined in the database."); end; item_ptr = item.next; end; end; else do; /* Relation exists for this attribute */ rel_gl_ptr = node_ptr -> node.data; /* Set the relation global element pointer */ ri_ptr = rel_gl_ptr -> gl.item_info_ptr; /* So we can reference rel_info */ /* check for attempt to set index in a non-new file during the current release */ file_gl_ptr = rel_gl_ptr -> gl.other_info_ptr; /* get rel's file gl ptr */ if file_gl_ptr -> gl.parse_info_ptr = null () then do; /* not from source => existing file */ call ioa_$rs ("^a^a^a ^d ^a ^a", message, message_length, "The relation """, rel_index.rel_name, """ on line", rel_index.line_num, "has a secondary index statement given for it, but does not belong to a newly created file,", "this option will not be implemented until a later release."); call mrds_rst_error (rsc_ptr, 2 /* severity */, mrds_error_$rst_undone_option, (message)); end; else do; /* new file */ file_gl_ptr -> gl.affected = ON; /* file where relation resides is affected */ rel_gl_ptr -> gl.affected = ON; /* This relation is affected */ /* Find attribute in sublist of relation */ do while (item_ptr ^= null); /* Do all attributes to indexed */ call mrds_rst_tree_search (item.name, rel_gl_ptr -> gl.item_sub_list_ptr, node_ptr, parent_ptr, success); if ^success then do; /* Attribute was not found in this relation */ call mrds_rst_error (rsc_ptr, 2, mrds_error_$rst_not_rel_attr, "The attribute """ || rtrim (item.name) || """ given on line " || ltrim (char (item.line_num)) || " was not defined for the relation """ || rtrim (rel_index.rel_name) || """."); end; else do; /* Attribute was found in this relation */ attr_sl_ptr = node_ptr -> node.data; /* Attribute sub_list entry pointer */ ai_ptr = attr_sl_ptr -> sl.item_info_ptr; /* So we can reference attr_info */ fm_ptr = pointer (ai_ptr, 0); /* rel's file ptr */ if ai_ptr = null () | ri_ptr = null () | fm_ptr = null () then ; else do; if attr_info.index_attr then /* Attribute was already indexed */ call mrds_rst_error (rsc_ptr, 1, mrds_error_$previously_defined_index, "The attribute """ || rtrim (item.name) || """ on line " || ltrim (char (item.line_num)) || " in relation """ || rtrim (rel_index.rel_name) || """ was already defined as a secondary index."); else do; /* Make this attribute indexed */ /* check for the indexed attribute being within maximum key length */ if attr_info.bit_length > 9 * mrds_data_$max_key_len then call mrds_rst_error (rsc_ptr, 2, mrds_error_$long_key, "The attribute """ || rtrim (item.name) || """ on line " || ltrim (char (item.line_num)) || " in relation """ || rtrim (rel_index.rel_name) || """ has a secondary key data length of " || ltrim (char (ceil (attr_info.bit_length / 9))) || " characters, which is longer than the allowed maximum length of " || ltrim (char (mrds_data_$max_key_len)) || " characters."); else do; attr_info.index_attr = ON; /* Mark the attribute as a secondary index */ rel_info.indexed = ON; /* relation now has secondary indexes */ attr_info.index_id = OFF; /* This needs to be cleared */ attr_gl_ptr = attr_sl_ptr -> sl.global_list_ptr; attr_gl_ptr -> gl.affected = ON; /* Mark attr as affected */ end; end; end; end; item_ptr = item.next; /* Continue to next attribute to be indexed (if any) */ end; /* End of DO WHILE (item_ptr ^= null) */ end; end; /* END of relation exists do */ end; /* END of DEFINE | CMDB section */ if directive.type = REDEFINE then do; /* REDEFINE section */ /* THIS DIRECTIVE IS NOT IMPLEMENTED YET -- SO ISSUE AN ERROR MSG */ if stmt (directive.type).index.number > 0 then ; else call error (2, mrds_error_$rst_undone_option, "The index handler will not implement the ""redefine"" directive" || " until a later release."); end; /* END of REDEFINE section */ exit: if rsc.trace_sw then call mrds_rst_meter (rsc_ptr, "mrds_rst_index_handler", OFF /* EXIT */, (index_relation_name)); return; 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; declare (fixed, addr, rel, null, ceil, char, ltrim, pointer, rtrim) builtin; declare list_ptr ptr; /* pointer to parse info list */ 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 */ dcl mrds_rst_tree_search entry (char (32) aligned, ptr, ptr, ptr, bit (1)); /* list searcher */ declare ioa_$rs entry options (variable); /* string manipulator */ dcl mrds_error_$previously_defined_index fixed bin (35) external; dcl mrds_error_$rst_undef_rel fixed bin (35) external; dcl mrds_error_$rst_not_rel_attr fixed bin (35) external; declare mrds_error_$undef_attr fixed bin (35) ext; dcl mrds_error_$rst_undone_option fixed bin (35) external; /* option not coded yet */ declare attr_gl_ptr ptr; /* pointer to global attr element */ declare file_gl_ptr ptr; /* pointer to file global list element */ dcl rel_gl_ptr pointer; /* Pointer to global list structure (gl) for relation */ dcl attr_sl_ptr pointer; /* Pointer to relation sublist (list of attr's for this relation ) */ 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 */ declare message char (256) varying;/* specifics of error message */ declare message_length fixed bin (21); /* length of specifics message */ declare index_relation_name char (32); /* input name for metering */ declare mrds_data_$max_key_len fixed bin (35) ext;/* longest key allowed, in chars */ declare mrds_error_$long_key fixed bin (35) ext;/* key too long error */ declare sys_info$max_seg_size fixed bin(35) ext static; %include mrds_rst_rsc; %include mrds_rst_semantics; %include mrds_rst_parse_info; %include mdbm_file_model; %include mdbm_db_model; %include mrds_rst_global_lists; %include mrds_rst_tree; end mrds_rst_index_handler;  mrds_rst_list_element.pl1 04/18/85 1454.7r w 04/18/85 0909.2 53379 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ mrds_rst_list_element: procedure (key, structure_type, rsc_ptr, root_ptr, structure_ptr, error_code); /* HISTORY: originally written by jim gray - - july 1978 modified by Jim Gray 2/19/79, to allocate structures in areas according to type, this changed the area_ptr input to an rsc_ptr input parameter */ /* DESCRIPTION: add or delete global list header and data space the global restructuring lists are made up of elements that have two parts. the head portion is a node in a binary tree with a link to a data portion that may be one of several pl1 structures. there are two entries: entry add - inserts the head portion into the tree and links it newly allocated data space. entry delete - deletes the head portion and frees the allocated data space. */ /* PARAMETERS: key - - (input) data key used for location of head portion in search tree structure_type - - (input) the type of pl1 structure in the include file that is to be allocated or freed (see include file) rsc_ptr - - (input) pointer to the common rsc segment, that contains pointers to the areas where the different structure types are to be allocated, or freed from root_ptr - - (input/output) pointer to desired list to be manipulated, additions to empty lists, or deletions of root nodes change it error_code - - (output) value indicating either failure reason or success structure_ptr - - (output) when adding, the resultant pointer to the newly allocated structure(or to the existing structure when duplicate add attempted) */ %page; add: entry (key, structure_type, rsc_ptr, root_ptr, structure_ptr, error_code); /* entry to add element to global list first, get head portion for list element into it's proper place in the list */ call mrds_rst_tree_insert (key, rsc_ptr, root_ptr, node_ptr, success); /* no success means attempt to add duplicate to list, return error code and pointer to existing structure */ if ^success then do; error_code = mrds_error_$rst_list_duplicate; structure_ptr = node_ptr -> node.data; end; else do; /* get new data portion for list element using the given area and structure parameters */ if structure_type = MAIN_LIST then do; error_code = 0; call mrds_rst_rsc_alloc (rsc_ptr, GL, structure_ptr); end; else if structure_type = SUB_LIST then do; error_code = 0; call mrds_rst_rsc_alloc (rsc_ptr, SL, structure_ptr); end; else if structure_type = SEG_INFO then do; error_code = 0; call mrds_rst_rsc_alloc (rsc_ptr, SEGINFO, structure_ptr); end; else do; error_code = mrds_error_$rst_invalid_structure_type; structure_ptr = null (); end; /* link data portion of element to it's head part that is in the global list */ node_ptr -> node.data = structure_ptr; end; return; delete: entry (key, structure_type, rsc_ptr, root_ptr, error_code); /* entry to delete global element first delete the head portion from list, saving pointer to the data portion */ call mrds_rst_tree_delete (key, rsc_ptr, root_ptr, structure_ptr, success); /* no success means key node was not found */ if ^success then error_code = mrds_error_$rst_list_delete_fail; else /* free the data portion space with size according to structure type */ if structure_type = MAIN_LIST then do; error_code = 0; call mrds_rst_rsc_alloc$free (rsc_ptr, GL, structure_ptr); end; else if structure_type = SUB_LIST then do; error_code = 0; call mrds_rst_rsc_alloc$free (rsc_ptr, SL, structure_ptr); end; else if structure_type = SEG_INFO then do; error_code = 0; call mrds_rst_rsc_alloc$free (rsc_ptr, SEGINFO, structure_ptr); end; else error_code = mrds_error_$rst_invalid_structure_type; %page; dcl null builtin; dcl mrds_rst_rsc_alloc entry (ptr, fixed bin, ptr); /* work area manager */ dcl mrds_rst_rsc_alloc$free entry (ptr, fixed bin, ptr); /* freeing entry in work area manager */ dcl mrds_rst_tree_delete entry (char (32) aligned, ptr, ptr, ptr, bit (1)); /* tree node delete routine */ dcl mrds_rst_tree_insert entry (char (32) aligned, ptr, ptr, ptr, bit (1)); /* tree node insertion routine */ dcl structure_ptr ptr; /* pointer to data space just added or to be deleted */ dcl structure_type fixed binary; /* number 0f structure desired, see include file */ dcl error_code fixed binary (35); /* zero or failure reason code */ dcl mrds_error_$rst_list_duplicate fixed binary (35) external; /* attempt to add duplicate error */ dcl mrds_error_$rst_invalid_structure_type fixed binary (35) external; /* undefined structure type error */ dcl mrds_error_$rst_list_delete_fail fixed binary (35) external; /* attempt to delete missing key */ %page; %include mrds_rst_tree; %page; %include mrds_rst_struct_types; %page; %include mrds_rst_rsc; %page; %include mdbm_seg_area; %page; %include mrds_rst_global_lists; end;  mrds_rst_meter.pl1 04/18/85 1454.7r w 04/18/85 0909.2 21303 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ mrds_rst_meter: proc (rsc_ptr, module_name, in_out, msg); /* PARAMETERS */ /* rsc_ptr pointer pointer to rsc control segment module_name char (*) name of module making call in_out bit (1) On = entering module OFF = exiting module msg char (*) message to be associated with metering entry. */ /* HISTORY: Initially written by R. D. Lackey October, 1978 */ dcl (addr, fixed, rel) builtin; dcl module_name char (*); /* (INPUT) Name of module making metering call */ dcl in_out bit (1); /* (INPUT) On = entering OFF = exiting */ dcl msg char (*); /* (INPUT) Message to be associated with metering entry */ dcl cpu_time_and_paging_ entry (fixed bin, fixed bin (71), fixed bin); dcl ioa_$ioa_switch entry options (variable); dcl vtime fixed bin (71); dcl pf fixed bin; dcl pd_pf fixed bin; dcl enter_exit char (5); dcl sys_info$max_seg_size ext fixed bin (35); if in_out = "1"b then enter_exit = "IN:"; else enter_exit = " OUT:"; if rsc.meter_sw then do; /* Meter */ call cpu_time_and_paging_ (pf, vtime, pd_pf); call ioa_$ioa_switch (rsc.trace_metering_iocb_ptr, "^5a^2x^32a^1x^12d^2x^8d^2x^8d^2x^a", enter_exit, module_name, vtime, pf, pd_pf, msg); end; else call ioa_$ioa_switch (rsc.trace_metering_iocb_ptr, "^5a^2x^a;", enter_exit, module_name); return; %page; %include mrds_rst_rsc; end mrds_rst_meter;  mrds_rst_model_alloc.pl1 10/16/86 1551.9r w 10/16/86 1143.7 118575 /* *********************************************************** * * * * * 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 - - February 1979 82-05-11 Roger Lackey : Changed the way model_seg_path_dir and model_seg_path_entry were deterimded form model_seg_path by replacing old code (which could get a stringsize condition) with a call to expand_pathname_ 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_model_alloc: procedure (rsc_ptr, model_seg_path, struct_type, struct_ptr); /* . BEGIN_DESCRIPTION this routine handles all allocations and freeing of structures to be placed in the database model for a MRDS database, this includes either the db_model segment, or one of the file_model segments. there are a total of three entries, the normal entry is for allocation of fixed length structures, the $variable entry is for allocation of structures that are of variable length, based on one paramater, and the $free entry is used to free a given allocation of a particular structure type. . END_DESCRIPTION */ /* PARAMETERS: normal entry === rsc_ptr - - (input) pointer to the common control segment "rsc" model_seg_path - - (input) the absolute pathname of the segment in which the allocation is to take place, thus the pathname of either the db_model, or one of the file_models struct_type - - (input) fixed binary number that indicates which structure is to be allocated. the include file mrds_rst_struct_types gives the constants that are used for that purpose. struct_ptr - - (output) pointer to the newly allocated structure of the type given by struct_type. it will be null, if the model area overflowed - the user must check for this. $variable entry === struct_size - - (input) a fixed binary (35) number, in addition to those above, that gives the length for the current allocation of this structure type, that has a variable length based on one parameter. $free entry === same as the normal entry, except struct_ptr is an input parameter, and it points to the allocation instance to be freed. */ /* establish on unit to capture model overflow */ on area begin; struct_ptr = null (); /* to tell caller we failed */ goto return_label; end; /* normal allocation entry point */ FREE = OFF; goto common; /* freeing entry point */ mrds_rst_model_alloc$free: entry (rsc_ptr, model_seg_path, struct_type, struct_ptr); FREE = ON; /* determine if we are freeing a variable length allocation */ if struct_type <= hbound (case, 1) then goto common; else goto var_common; common: if ^rsc.trace_sw then ; else call trace (ON); /* input call */ call decode_model_seg_path (); /* check that the encoding for structure type is within the legal range */ if struct_type < lbound (case, 1) | struct_type > hbound (case, 1) then call bad_struct_type (); else do; /* good structure type code, go to the allocate that it indicates for the given structure to be allocated, and the area in which it will reside */ goto case (struct_type); /* db_model area structures */ case (0): if FREE then ; /* can't free till not head of segment */ else do; call hcs_$make_seg (model_seg_path_dir, model_seg_path_entry, "", 01010b /* rw mode */, struct_ptr, error_code); if error_code = 0 then ; else call unable_to_make_segment (); end; goto return_label; case (1): if FREE then free struct_ptr -> file_info in (db_model_area); else allocate file_info set (struct_ptr) in (db_model_area); goto return_label; case (2): if FREE then free struct_ptr -> domain_info in (db_model_area); else allocate domain_info set (struct_ptr) in (db_model_area); goto return_label; case (3): if FREE then free struct_ptr -> path_entry in (db_model_area); else allocate path_entry set (struct_ptr) in (db_model_area); goto return_label; case (4): if FREE then free struct_ptr -> stack_item in (db_model_area); else allocate stack_item set (struct_ptr) in (db_model_area); goto return_label; case (5): if FREE then free struct_ptr -> version_status in (db_model_area); else allocate version_status set (struct_ptr) in (db_model_area); goto return_label; case (6): if FREE then free struct_ptr -> changer in (db_model_area); else allocate changer set (struct_ptr) in (db_model_area); goto return_label; /* file_model area structures */ case (7): if FREE then ; /* can't free til not segment head */ else do; call hcs_$make_seg (model_seg_path_dir, model_seg_path_entry, "", 01010b /* rw mode */, struct_ptr, error_code); if error_code = 0 then ; else call unable_to_make_segment (); end; goto return_label; case (8): if FREE then free struct_ptr -> rel_info in (file_model_area); else allocate rel_info set (struct_ptr) in (file_model_area); goto return_label; case (9): if FREE then free struct_ptr -> attr_info in (file_model_area); else allocate attr_info set (struct_ptr) in (file_model_area); goto return_label; case (10): if FREE then free struct_ptr -> parent_link_info in (file_model_area); else allocate parent_link_info set (struct_ptr) in (file_model_area); goto return_label; case (11): if FREE then free struct_ptr -> child_link_info in (file_model_area); else allocate child_link_info set (struct_ptr) in (file_model_area); goto return_label; case (12): if FREE then free struct_ptr -> attr_list in (file_model_area); else allocate attr_list set (struct_ptr) in (file_model_area); goto return_label; case (13): if FREE then free struct_ptr -> sort_key in (file_model_area); else allocate sort_key set (struct_ptr) in (file_model_area); goto return_label; case (14): if FREE then free struct_ptr -> dup_prev in (file_model_area); else allocate dup_prev set (struct_ptr) in (file_model_area); goto return_label; case (15): if FREE then free struct_ptr -> select_chain in (file_model_area); else allocate select_chain set (struct_ptr) in (file_model_area); goto return_label; end; mrds_rst_model_alloc$variable: entry (rsc_ptr, model_seg_path, struct_type, struct_size, struct_ptr); /* entry to handle structures whose length is variable */ FREE = OFF; var_common: if ^rsc.trace_sw then ; else call trace (ON); /* input call */ /* establish on unit to capture model overflow */ on area begin; struct_ptr = null (); /* to tell caller we failed */ goto return_label; end; call decode_model_seg_path (); if struct_type < lbound (var_case, 1) | struct_type > hbound (var_case, 1) then call bad_struct_type (); else if struct_size < 1 then call bad_struct_size (); else do; /* good encoding and size given, go allocate the given structure with the specified size, and place it according to the area policy */ goto var_case (struct_type); var_case (30): if FREE then free struct_ptr -> constant in (db_model_area); else do; alloc_length = struct_size; allocate constant set (struct_ptr) in (db_model_area); end; goto return_label; var_case (31): if FREE then free struct_ptr -> atd in (file_model_area); else do; atd_len = struct_size; allocate atd set (struct_ptr) in (file_model_area); end; goto return_label; var_case (32): if FREE then free struct_ptr -> comp_no_array in (file_model_area); else do; ncomp_init = struct_size; allocate comp_no_array set (struct_ptr) in (file_model_area); end; goto return_label; end; return_label: if ^rsc.trace_sw then ; else call trace (OFF); /* output call */ return; decode_model_seg_path: procedure (); /* get the pointer, directory, and entry for either the file_model or db_model, depending on the model segment path input */ call expand_pathname_ (model_seg_path, model_seg_path_dir, model_seg_path_entry, error_code); if error_code ^= 0 then call mrds_rst_error (rsc_ptr, 4, error_code, "Bad pathname: " || model_seg_path); else do; seg_ptr = cv_ptr_ (model_seg_path, error_code); /* code ^= 0, if seg not created yet for db or file_model */ if error_code ^= 0 then do; dbm_ptr = null (); fm_ptr = null (); end; else do; if model_seg_path_entry = "db_model" then do; dbm_ptr = seg_ptr; fm_ptr = null (); end; else do; fm_ptr = seg_ptr; dbm_ptr = null (); end; end; end; end; bad_struct_type: procedure (); /* error routine for bad structure encoding value */ call ioa_$rs ("^a ^d ^a", message, message_length, "LOGIC ERROR in mrds_rst_model_alloc,", struct_type, "is an invalid code for structure type."); call mrds_rst_error (rsc_ptr, 4 /* severity */, mrds_error_$rst_logic_error, (message)); end; bad_struct_size: procedure (); /* report bad strructure allocation length */ call ioa_$rs ("^a ^d ^a", message, message_length, "LOGIC ERROR in mrds_rst_model_alloc,", struct_size, "is an illegal structure allocation size."); call mrds_rst_error (rsc_ptr, 4 /* severity */, mrds_error_$rst_logic_error, (message)); end; unable_to_make_segment: procedure (); /* report trouble in making a model segment */ call ioa_$rs ("^a^a^a^a^a", message, message_length, "Unable to make the model segment with directory """, model_seg_path_dir, """ and entry portion """, model_seg_path_entry, """ in the database model."); call mrds_rst_error (rsc_ptr, 4 /* severity */, error_code, (message)); end; trace: procedure (in_out); /* common to metering routine */ struct_type_picture = struct_type; call mrds_rst_meter (rsc_ptr, "mrds_rst_model_alloc", in_out, (struct_type_picture)); declare in_out bit (1); /* on => input, off => output call */ declare struct_type_picture picture "99"; /* character version of encoding */ end; declare cv_ptr_ entry (char (*), fixed bin (35)) returns (ptr); /* gets segments pointer from path */ declare seg_ptr ptr; /* temp store for segment pointer */ declare mrds_error_$rst_logic_error fixed bin (35) external; /* program error */ declare error_code fixed bin (35); /* 0 => no error, else coded error */ declare model_seg_path_dir char (168); /* directory portion of pathname */ declare model_seg_path_entry char (32); /* entry portion of pathname */ declare sys_info$max_seg_size fixed bin (35) external; /* system segment length */ declare (lbound, hbound, addr, fixed, rel, null) builtin; declare mrds_rst_meter entry (ptr, char (*), bit (1), char (*)); /* trace routine */ declare ioa_$rs entry options (variable); /* string manipulator */ declare message char (96) varying; /* specifics of error */ declare message_length fixed bin (21); /* length of returned message */ declare area condition; /* will occur if model space used up */ declare mrds_rst_error entry (ptr, fixed bin, fixed bin (35), char (*)); /* common error routine */ declare FREE bit (1); /* on => free, off => allocate */ declare struct_ptr ptr; /* pointer to allocated structure, or instance tobe freed */ declare struct_type fixed bin; /* encoding value for this structure to allocate or free */ declare struct_size fixed bin (35); /* length to allocate for variable size struc tures */ declare model_seg_path char (*); /* pathname of segment to allocate in */ declare ON bit (1) internal static options (constant) init ("1"b); /* true value */ declare OFF bit (1) internal static options (constant) init ("0"b); /* false value */ dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); declare hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)); /* creates segments */ declare file_model_area area based (addr (file_model.fm_area)); declare db_model_area area based (addr (db_model.dbm_area)); %include mrds_rst_struct_types; %include mdbm_file_model; %include mdbm_db_model; %include mrds_rst_rsc; end;  mrds_rst_parse.pl1 04/18/85 1454.7r w 04/18/85 0909.2 306567 /* *********************************************************** * * * * * 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 - - july 1978 */ mrds_rst_parse: procedure (rsc_ptr, source_seg_ptr, source_length); /* . BEGIN_DESCRIPTION table driven lrk parsing algorithm method is that of a no backtrack bottom up shift reduce parser the tables are built using the automated lrk tool of d. ward (see the Multics lrk MTB) an additional entry - debug_set - may be call without parameters to set a debug switch for debug output . END_DESCRIPTION */ /* PARAMETERS: rsc_ptr - - (input) pointer to restructure control segment source_seg_ptr - - (input) pointer to restructuring source segment source_length - - (input) character length of source segment (output) will come from the semantic action routines that the parser calls as well as from the scanner listing segment output which includes error messages ( the listing is in source_seg.list ) */ %page; /* normal entry */ goto PARSE; /* debug switch set entry */ debug_set: entry (); /* switch state of debug switch to regulate debug output from parser */ debug_sw = ^debug_sw; return; PARSE: /* if trace is on, call metering */ if ^rsc.trace_sw then ; else call mrds_rst_meter (rsc_ptr, "mrds_rst_parse", "1"b /* in */, ""); /* initialize the lexical analyzer, and semantic routines */ call mrds_rst_scanner$init (rsc_ptr, source_seg_ptr, source_length); call mrds_rst_semantics$init (rsc_ptr); /* go forth and parse the source */ %page; /* ________________________________________________________________________________ _____________________________________________________________ | initialize | | do while (^EOI); | | if READ_state then do; | | enter state number into parse stack | | if look-ahead stack empty | | then call scanner; /* puts to look-ahead stack * /| | look in read-table for 1st look-ahead symbol | | if not found then ERROR | | set next state from read-table | | if look-ahead transition | | then delete 1 state from parse stack | | else move symbol from look-ahead stack | | to lex stack | | end; | | else if LOOK_state then do; /* look ahead n * / | | do until n symbols in look-ahead stack; | | call scanner; /* put to look-ahead stack * / | | end; | | look in look-table for n'th look-ahead symbol | | if not found then ERROR | | set next state from look-table | | end; | | else if APPLY_state then do; | | call semantics | | delete necessary symbols from lex stack | | delete necessary states from parse stack | | look in apply-table for top stacked state | | set next state from apply-table | | end; | | end; | |_____________________________________________________________| Generalized parse procedure. */ /* get space for lexical stack */ call mrds_rst_rsc_alloc (rsc_ptr, LEX_STACK, lex_stack_ptr); call mrds_rst_rsc_alloc (rsc_ptr, P_STRUCT, p_struct_ptr); call mrds_rst_rsc_alloc (rsc_ptr, CUR_LEX_TOP, cur_lex_top_ptr); /* Parser for tables created by LRK. */ current_state = 1; nil_sym = -1; /* set nil_sym non-existant */ nil_flag = "0"b; /* Initially not in skip error recovery */ ls_top, ps_top = 0; la_put, la_get = 1; la_ct = 0; token_cnt = 0; error_mark = -1; /* The parsing loop. */ NEXT: if (current_state = 0) then goto done_parse; current_table = current_state; string (db_data) = ""; db_data.state = current_state; goto CASE (DPDA.v1 (current_table)); CASE (3): /* Shared look */ current_table = DPDA.v2 (current_table); CASE (1): /* Look. */ la_use = mod (la_get + la_need - 1, -lbound (lex_stack, 1)) + 1; if (la_need >= -lbound (lex_stack, 1) - 1) then call too_many (-lbound (lex_stack, 1), "lookahead"); la_need = la_need + 1; goto read_look; CASE (10): /* Shared read */ current_table = DPDA.v2 (current_table); CASE (9): /* Read. */ db_data.type = "READ"; la_need = 1; la_use = la_get; goto read_look; CASE (2): /* Stack and Shared read */ current_table = DPDA.v2 (current_table); CASE (0): /* Stack and Read. */ db_data.type = "READ"; db_data.flag = "*"; la_need = 1; la_use = la_get; if (ps_top >= hbound (parse_stack, 1)) then call too_many (hbound (parse_stack, 1), "parse"); ps_top = ps_top + 1; /* Top of parsing stack. */ parse_stack (ps_top) = current_state; /* Stack the current state. */ cur_lex_top (ps_top) = ls_top; /* save current lex top (for recovery) */ read_look: do while (la_ct < la_need); /* make sure enough symbols are available */ call mrds_rst_scanner (addr (lex_stack), -la_put); la_put = mod (la_put, -lbound (lex_stack, 1)) + 1; la_ct = la_ct + 1; end; test_symbol = lex_stack.symbol (-la_use); m = 0; nil = 0; /* Look current symbol up in read list. */ do i = current_table + 1 to current_table + DPDA.v2 (current_table); n = DPDA.v1 (i); dcl an fixed bin (24); if n < 0 then an = -n; else an = +n; if (an = test_symbol) then do; next_state = DPDA.v2 (i); goto got_symbol; end; if (an > test_symbol) then do; do i = i to current_table + DPDA.v2 (current_table); if abs (DPDA.v1 (i)) = nil_sym then nil = i; end; go to not_found; end; if n < 0 then m = i; /* Record a default transition. */ else if n = nil_sym then nil = i; /* Record a nil symbol transition (for skip error recovery) */ end; not_found: if (m > 0) then do; /* if marked symbol was in table, use it */ next_state = DPDA.v2 (m); goto got_symbol; end; if nil_flag & nil > 0 then do; /* If skip recovery has just occurred and there is a nil symbol transition take the transition and back up to the nil symbol in the lookahead stack. */ next_state = DPDA.v2 (nil); la_get = mod (la_get - 2, -lbound (lex_stack, 1)) + 1; la_ct = la_ct + 1; test_symbol = nil_sym; go to got_symbol; end; line_number = lex_stack (-la_use).line; if token_cnt > error_mark then if local_recovered () then goto read_look; if skip_recovered () then do; call mrds_rst_error (rsc_ptr, 3 /* severity */, mrds_error_$rst_parse_err_recover, (recov_msg)); goto NEXT; end; if debug_sw then call ioa_$ioa_switch_nnl (iox_$user_output, " ^4i ", current_state); call ioa_$rs ("^a ^d ^a ^a", message, message_length, "Line", lex_stack (-la_get).line, "symbol", getermc (test_symbol, la_get)); call mrds_rst_error (rsc_ptr, 2 /* severity */, mrds_error_$rst_parse_err_no_recover, (message)); goto done_parse; got_symbol: nil_flag = "0"b; /* If skip error recovery was in progress, it is now complete. */ if debug_sw then do; if (next_state < 0) then do; /* is this a look-ahead state? */ db_data.type = "LK01"; db_look = la_need; db_data.data = geterm (test_symbol, 0); /* display only terminal "name" on look-ahead */ db_data.flag = " "; end; else do; db_data.data = getermc (test_symbol, la_get); /* display terminal "name" and data, if available */ end; call ioa_$ioa_switch_nnl (iox_$user_output, "^a^/", string (db_data)); end; current_state = next_state; if (current_state < 0) then do; /* Transition is a look-ahead state. */ current_state = -current_state; end; else do; if (ls_top >= hbound (lex_stack, 1)) then call too_many (hbound (lex_stack, 1), "lexical"); ls_top = ls_top + 1; lex_stack (ls_top) = lex_stack (-la_get); la_get = mod (la_get, -lbound (lex_stack, 1)) + 1; la_ct = la_ct - 1; token_cnt = token_cnt + 1; end; goto NEXT; CASE (6): /* Apply Shared */ current_table = DPDA.v2 (current_state + 3); CASE (4): /* Apply state. */ CASE (5): /* Apply single */ la_need = 1; rulen = DPDA.v1 (current_state + 2); altn = DPDA.v2 (current_state + 2); if debug_sw then do; db_data.type = "APLY"; db_data.data = "("; call ioa_$ioa_switch_nnl (iox_$user_output, "^a^i ^i)", string (db_data), rulen, altn); end; if (rulen > 0) then do; if rsc_ptr -> rsc.severity_high >= 3 then ; /* forget semantics if skip recovery has occured */ else call mrds_rst_semantics (rulen, altn, lex_stack_ptr, ls_top); end; if debug_sw then do; call ioa_$ioa_switch_nnl (iox_$user_output, "^-pd=^i ld=^i(" , DPDA.v1 (current_state + 1), DPDA.v2 (current_state + 1)); do t = ps_top to ps_top - DPDA.v1 (current_state + 1) + 1 by -1; call ioa_$ioa_switch_nnl (iox_$user_output, " ^d", parse_stack (t)); end; call ioa_$ioa_switch_nnl (iox_$user_output, ")^/"); end; /* * Check for an apply of an empty production. In this case the apply state number must be pushed on the parse stack. (Reference LaLonde, W. R.: An Efficient LALR Parser Generator. Tech. Report CSRG-2, 1971, pp. 34-35.) * */ if DPDA.v1 (current_state + 1) = -1 then do; if (ps_top >= hbound (parse_stack, 1)) then call too_many (hbound (parse_stack, 1), "parse"); parse_stack (ps_top + 1) = current_state; end; ps_top = ps_top - DPDA.v1 (current_state + 1); /* Delete parse stack states. */ ls_top = ls_top - DPDA.v2 (current_state + 1); /* delete lex stack states */ if ps_top <= 0 then do; call ioa_$rs ("^a", message, message_length, "Parse stack empty"); call mrds_rst_error (rsc_ptr, 4 /* severity */, mrds_error_$rst_parse_fail, (message)); goto done_parse; end; do i = current_table + 4 to current_table + DPDA.v2 (current_table); if (DPDA.v1 (i) = parse_stack (ps_top)) then do; current_state = DPDA.v2 (i); goto NEXT; end; end; current_state = DPDA.v2 (current_table + 3); goto NEXT; done_parse: if rsc.trace_sw then call mrds_rst_meter (rsc_ptr, "mrds_rst_parse", "0"b /* out */, ""); return; /* %page; */ skip_recovered: proc returns (bit (1)); /* * Skip recovery requires that the user difine one or more recovery terminal symbols by means of the -recover st1 st2 ... control included in the lrk source. st1 st2 etc. are skip terminals. They are terminals which can end statements. They cause a table to be built for skip recovery. This table is a list of read or lookahead states which can follow the reading of a skip terminal. These states correspond to the beginnings of new statements. Skip recovery is done when an error has occurred and local recovery (if used) was not successful. Basically what it does is to skip forward in the source by calling the scanner until it encounters one of the skip terminals. It then tries to find a state which followed a previous occurrence of the found terminal. If one is found it adjusts the lexical and parse stacks and then procedes. Effectively a bad "statement" has been discarded. In this case "statement" means an input string bounded by two identical skip terminals (such as ";" for example) including the boundary terminal on the right. If the language is such that the discarded statement is optional (syntactically) the rest of the input can be checked for syntax errors. When a bad "statement" is discarded the parser is restarted in the state in which it began to process that statement. If the next input symbol encountered is not acceptable to this state, the parser makes a last attempt at error recovery by replacing the bad "statement" with the symbol defined by the -recover control if used. The symbol is one which the scanner must NEvER return. It is needed because some languages do not allow all statements to occur at every point. This means that when you back up to the last statement beginning point, you may not be allowed to have the statement you find next. As an example, take this grammar: ::= | ! ::= | ! ::= a ; ! ::= r ; | r ; ! ::= b ; ! ::= s ; | s ; ! %page; Then suppose that you intended to have an input like line (1) below, but instead you got (2): (1) a ; r ; r ; b ; s ; s ; s ; a ; r ; r ; r ; (2) a ; r ; r ; b ; s ; s ; s a ; r ; r ; r ; Suppose that the grammar had specified -recover ; and local recovery is not used. When the "s" "a" ";" is encountered, skip recovery will discard it as a bad statement. But this then means that it will miss the fact that it should be entering the rule. It will then get to the "r" but the parser will have restarted in a state which can read either an "a", "b", or "s". So it will have to skip again. In this example, skipping will occur, one statement at a time, until EOI is reached. This means that no syntax checking is done in all of the "r" s which are skipped. This is not highly desireable. However, if you add a rule like this: ::= ! then the generated from skip recovery will allow the to be correctly parsed, reducing the number of useless error messages by quite a bit, usually. These rules can help parse thru misplaced statements during error recovery, but will never accept these statements under normal circumstances. The semantics on these rules should then report an error. */ dcl (i, ii) fixed bin (24); dcl (j, jj) fixed bin (24); dcl c fixed bin (24); dcl dec4 pic "zzz9"; /* * %page; */ %page; if (hbound (skip_v1, 1) <= 0) then return ("0"b); /* no skip table */ error_mark = 0; current_table = 1; recov_msg = "Unuseable "; recov_msg = recov_msg || geterm (test_symbol, la_get); recov_msg = recov_msg || " on line "; dec4 = lex_stack (-la_get).line; recov_msg = recov_msg || ltrim (dec4); recov_msg = recov_msg || ", Skipped to "; nil_sym = skip_v1 (2); /* SKIP table */ c = 1; do while (c ^= 0); if (la_ct < 1) then do; /* if look-ahead stack is empty, get a symbol */ call mrds_rst_scanner (addr (lex_stack), -la_put); la_put = mod (la_put, -lbound (lex_stack, 1)) + 1; la_ct = 1; end; c = lex_stack.symbol (-la_get); do i = current_table + 2 to current_table + skip_v2 (current_table); /* SKIP table */ if (skip_v1 (i) = c) then do; /* SKIP table */ jj = skip_v2 (i); /* SKIP table */ do j = ps_top to 1 by -1; do ii = jj + 1 to jj + skip_v2 (jj); /* SKIP table */ if (skip_v1 (ii) = parse_stack (j)) then do; /* SKIP table */ ps_top = j - 1; ls_top = cur_lex_top (j); current_state = skip_v2 (ii); /* SKIP table */ recov_msg = recov_msg || geterm (c, 0); recov_msg = recov_msg || " on line "; dec4 = lex_stack (-la_get).line; recov_msg = recov_msg || ltrim (dec4) || " " || copy ("!*!", 26); lex_stack (-la_get).symlen = 0; /* generate a nil symbol into the look-ahead stack */ lex_stack (-la_get).symbol = nil_sym; la_get = mod (la_get, -lbound (lex_stack, 1)) + 1; /* Advance past nil symbol. It will not be used unless the next symbol cannot be read. */ la_ct = la_ct - 1; nil_flag = "1"b; return ("1"b); end; end; end; end; end; la_get = mod (la_get, -lbound (lex_stack, 1)) + 1; la_ct = la_ct - 1; end; recov_msg = recov_msg || end_of_input_msg || copy ("!*!", 26); current_state = 0; return ("1"b); end; %page; dcl (addr, mod, fixed) builtin; dcl db_look pic "99" defined (db_data.type) pos (3); dcl 1 db_data, 2 flag char (1), /* * means stacked */ 2 state pic "zzz9", 2 fil1 char (2), 2 type char (6), 2 data char (100); dcl DDop (-1:2) char (4) int static init ("LOOK", "FINI", "READ", "ERR"); dcl ioa_$ioa_switch_nnl entry options (variable); dcl iox_$user_output ptr ext static; ; dcl ls_top fixed bin (24); /* location of top of lexical stack */ dcl altn fixed bin (24); /* APPLY alternative number */ dcl current_state fixed bin (24); /* number of current state */ dcl test_symbol fixed bin (24); /* encoding of current symbol */ dcl current_table fixed bin (24); /* number of current table */ dcl i fixed bin (24); /* temp */ dcl la_ct fixed bin (24); /* number of terminals in look-ahead stack */ dcl la_get fixed bin (24); /* location in look_ahead stack to get next symbol */ dcl la_need fixed bin (24); /* number of look-ahead symbols needed */ dcl la_put fixed bin (24); /* location in look_ahead stack to put next symbol */ dcl la_use fixed bin (24); /* location in look-ahead stack to test with */ dcl (m, n) fixed bin (24); dcl next_state fixed bin (24); /* number of next state */ dcl nil_sym fixed bin (24); dcl nil fixed bin (24); dcl nil_flag bit (1); dcl ps_top fixed bin (24); /* location of top of parse stack */ dcl recov_msg char (150) var; dcl rulen fixed bin (24); /* APPLY rule number */ dcl t fixed bin (24); dcl sys_info$max_seg_size fixed binary (35) external; /* largest segment size */ dcl token_cnt fixed binary (24); /* number of tokens used */ dcl error_mark fixed binary (24); /* point to get past before another local correction allowed */ dcl line_number fixed binary (24); /* line where error detected */ /* %page; */ geterm: proc (idx, ids) returns (char (100) var); dcl (idx, ids) fixed bin (24); dcl temp char (100) var; dcl c_str char (20000) based; temp = ""; get_rest: if (ids > 0) then if (lex_stack (-ids).symlen > 0) then do; temp = temp || """"; temp = temp || substr (lex_stack (-ids).symptr -> c_str, 1, min (50, lex_stack (-ids).symlen)); temp = temp || """"; return (temp); end; if (idx = 0) then temp = end_of_input_msg; else temp = substr (string (TC), TL.fc (idx), TL.ln (idx)); return (temp); getermc: entry (idx, ids) returns (char (100) var); if (idx = 0) then temp = end_of_input_msg; else temp = substr (string (TC), TL.fc (idx), TL.ln (idx)); temp = temp || " "; goto get_rest; end; %page; local_recovered: proc returns (bit (1)); /* " this procedure implements the LRK local error recovery (using " the DPDA table). This is done by using the current (bad) " symbol and the next input symbol. All possible parses from " this state are examined. These trial parses proceed until the " next read or lookahead state is encountered. The trial parses " are true simulations of what can happen, apply states are " chosen according to the simulated top of parse stack. " Given: " B is the current symbol (bad) " N is the next input symbol " C is the current state " R is a "next" read state " These are the conditions which can exist. " C( N ) R( B N ) -kind- " 0 1 0 symbol leading to R is missing " 0 0 1 B is a wrong symbol " 1 1 0 B and N reversed in input " 1 0 x B is an extra symbol in the input " 0 0 0 recovery fails " The recovery tries to find a useable combination. If one " exists, the search does not stop. If a second one is " encountered, the search stops, a message is generated which " says the choice is not unique, and then the first combination " is used. " The local recovery shcheme was altered in Sept 1977 by Al " Kepner to allow local recovery from errors encountered by " look-ahead states. Preveously only errors encountered by " read states could be handled. The error correction scheme is " still the same heuristic described above. " " Some complexity has been added to procedure next_term. Note " the new variables la_get2 and la_use2. These are necessary " to handle the case where an error is encountered by a " look-ahead state and the next state found is not a look-ahead " state. In this case the next read state encountered will " correspond to the "bad" symbol or a symbol to the left of it " (depending on how many look-ahead states preceded the error). " The goal is to find the read or look-ahead state which " corresponds to the input symbol to the right of the "bad" " symbol. The goal is recognized by the condition "la_use2 = " la_next". Until this goal is reached look-ahead and read " states are simply passed through using the look-ahead stack " to find the appropriate next state. */ %page; if (test_symbol < 0) then do; call ioa_$rs ("^a ^d ^a", message, message_length, "Line", lex_stack (-la_get).line, "Negative terminal; cannot recover"); call mrds_rst_error (rsc_ptr, 2 /* severity */, mrds_error_$rst_parse_err_no_correct, (message)); return ("0"b); end; error_mark = token_cnt + la_need; do while (la_ct < la_need + 1); call mrds_rst_scanner (addr (lex_stack), -la_put); la_put = mod (la_put, -lbound (lex_stack, 1)) + 1; la_ct = la_ct + 1; end; if hbound (skip_v1, 1) > 0 then nil_sym = skip_v1 (2); /* SKIP table */ else nil_sym = -1; la_next = mod (la_use, -lbound (lex_stack, 1)) + 1; next_symbol = lex_stack (-la_next).symbol; dcl string builtin; string (sws) = "0"b; transit = -1; combinations = 0; depth = 0; if debug_sw then call dump_la; do i = current_table + 1 to current_table + DPDA.v2 (current_table) while (combinations < 2); alt_symbol = abs (DPDA.v1 (i)); if alt_symbol = nil_sym then go to try_again; if debug_sw then call ioa_$ioa_switch_nnl (iox_$user_output, "#^4i ^4a ^i ^a^/", current_state, DDop (sign (DPDA.v2 (i))), alt_symbol, geterm (alt_symbol, 0)); string (cycle) = "0"b; if combinations < 2 then call next_term ((ps_top), (DPDA.v2 (i))); try_again: end; recov_msg = ""; if (transit = -1) then return ("0"b); goto case (fixed (string (sws))); case (0): /* can't resolve it */ return ("0"b); case (3): case (7): /* cannot occur */ signal condition (logic_error); dcl logic_error condition; case (1): /* B is wrong symbol */ recov_msg = recov_msg || geterm (transit, 0); recov_msg = recov_msg || " used in place of erroneous "; recov_msg = recov_msg || geterm (test_symbol, la_get); goto set_symbol; case (2): /* symbol leading to R is missing */ recov_msg = recov_msg || "Missing "; recov_msg = recov_msg || geterm (transit, 0); recov_msg = recov_msg || " is assumed before "; recov_msg = recov_msg || geterm (test_symbol, la_get); la_ct = la_ct + 1; lex_stack (-la_put) = lex_stack (-la_next); lex_stack (-la_next) = lex_stack (-la_use); la_put = mod (la_put, -lbound (lex_stack, 1)) + 1; set_symbol: lex_stack (-la_use).token_num = 0; /* flag as phoney token for semantics */ la_next = la_use; lex_stack (-la_next).symptr = addr (default_symbol); lex_stack (-la_next).symlen = length (default_symbol); lex_stack (-la_next).line = lex_stack (-(mod (la_put - 2, -lbound (lex_stack, 1)) + 1)).line; lex_stack (-la_next).symbol = transit; goto done; case (4): case (5): /* B is an extra symbol */ recov_msg = recov_msg || "Extraneous "; recov_msg = recov_msg || geterm (test_symbol, la_use); recov_msg = recov_msg || " ignored before "; recov_msg = recov_msg || geterm (next_symbol, la_next); la_ct = la_ct - 1; la_put = mod (la_put - 2, -lbound (lex_stack, 1)) + 1; /* Back up one in look-ahead stack. */ lex_stack (-la_use) = lex_stack (-la_next); goto done; case (6): /* B and N reversed */ recov_msg = recov_msg || geterm (test_symbol, la_use); recov_msg = recov_msg || " and "; recov_msg = recov_msg || geterm (next_symbol, la_next); recov_msg = recov_msg || " are reversed."; lex_stack (ls_top + 1) = lex_stack (-la_use); lex_stack (-la_use) = lex_stack (-la_next); lex_stack (-la_next) = lex_stack (ls_top + 1); done: if combinations <= 1 then ; else recov_msg = recov_msg || copy (" ", 30) || "(choose first of many possibilities)"; call ioa_$rs ("^a ^d ^a", message, message_length, "Line", line_number, recov_msg); call mrds_rst_error (rsc_ptr, 1 /* severity */, mrds_error_$rst_parse_err_correct, (message)); if debug_sw then call dump_la; return ("1"b); /* recovery completed */ dcl 1 sws, 2 CNf bit (1) unal, /* current state contains next symbol */ 2 RBNf bit (2) unal; /* next read matches bad or next symbol */ dcl combinations fixed bin (24); /* useable combinations found so far */ dcl transit fixed bin (24); /* found alternate symbol to use from current state */ dcl la_next fixed bin (24); /* temporary "next" look-ahead position */ dcl alt_symbol fixed bin (24); /* current alternate symbol */ dcl cycle (4000) bit (1) unal; dcl default_symbol char (13) int static init ("ERROR_SYMBOL_"); dcl next_symbol fixed bin (24); dcl depth fixed bin (24); /* %page; */ %page; dump_la: proc; dcl ii fixed bin (24); if debug_sw then do; ii = la_get; do while (ii ^= la_put); call ioa_$ioa_switch_nnl (iox_$user_output, "#la(-^i) ^3i""^a""^/", ii, lex_stack (-ii).symbol, geterm (lex_stack (-ii).symbol, 0)); ii = mod (ii, -lbound (lex_stack, 1)) + 1; end; end; end dump_la; /* %page; */ next_term: proc (top, ns); look_ahead = (ns < 0); if look_ahead then do; la_use2 = la_use; la_get2 = la_get; end; else la_use2, la_get2 = mod (la_get, -lbound (lex_stack, 1)) + 1; depth = depth + 5; do i = 1 to ps_top; parse_stack2 (i) = parse_stack (i); end; NEXT: if (ns = 0) then do; transit = 0; depth = depth - 5; go to done; end; ns = abs (ns); cur_st = ns; if DPDA.v1 (cur_st) = 0 | DPDA.v1 (cur_st) = 2 then do; /* Stack state? */ if top >= hbound (parse_stack, 1) then call too_many (hbound (parse_stack, 1), "parse"); top = top + 1; parse_stack (top) = cur_st; end; goto CASE (DPDA.v1 (cur_st)); CASE (2): /* Stack and Shared read */ CASE (3): /* Shared look */ CASE (10): /* Shared read */ cur_st = DPDA.v2 (cur_st); CASE (0): /* Stack and Read. */ CASE (1): /* Look. */ CASE (9): /* Read. */ if DPDA.v1 (cur_st) = 1 then la_use2 = mod (la_use2, -lbound (lex_stack, 1)) + 1; else la_use2 = la_get2; if la_use2 = la_next then do; if debug_sw then call ioa_$ioa_switch_nnl (iox_$user_output, "#^vx^4i READ^/", depth, ns); rep = 0; do s = test_symbol, next_symbol while (next_symbol ^= alt_symbol); rep = rep + 1; do i = cur_st + 1 to cur_st + DPDA.v2 (cur_st) while (combinations < 2); if ((DPDA.v1 (i) < 0) & (-DPDA.v1 (i) <= s)) | (DPDA.v1 (i) = s) then do; if debug_sw then call ioa_$ioa_switch_nnl (iox_$user_output, "#^vx(^i)^i^/", depth, rep, s); if (combinations = 0) then do; combinations = 1; transit = alt_symbol; if (rep = 1) then RBNf = "10"b; else RBNf = "01"b; end; else combinations = 2; end; end; end; if (next_symbol = alt_symbol) then do; if (combinations = 0) then do; CNf = "1"b; do i = cur_st + 1 to cur_st + DPDA.v2 (cur_st); if ((DPDA.v1 (i) < 0) & (-DPDA.v1 (i) <= test_symbol)) | DPDA.v1 (i) = test_symbol then RBNf = "10"b; end; transit = alt_symbol; combinations = 1; end; else combinations = 2; end; done: depth = depth - 5; do i = 1 to ps_top; parse_stack (i) = parse_stack2 (i); end; return; end; else do; if la_use2 = la_use /* la_use points to the bad input symbol. */ then s = alt_symbol; /* We are considering an alternate symbol. */ else s = lex_stack (-la_use2).symbol; marked = 0; do i = cur_st + 1 to cur_st + DPDA.v2 (cur_st) while (abs (DPDA.v1 (i)) <= s); if abs (DPDA.v1 (i)) = s then go to found; else if DPDA.v1 (i) < 0 then marked = i; end; if marked ^= 0 then i = marked; else go to done; found: ns = DPDA.v2 (i); if ns >= 0 then la_get2 = mod (la_get2, -lbound (lex_stack, 1)) + 1; go to NEXT; end; CASE (4): /* Apply state. */ CASE (5): /* Apply single */ CASE (6): /* Apply Shared */ if debug_sw then call ioa_$ioa_switch_nnl (iox_$user_output, "#^vx^4i APLY^/", depth, ns); if DPDA.v1 (cur_st + 1) = -1 then do; if (top >= hbound (parse_stack, 1)) then call too_many (hbound (parse_stack, 1), "parse"); parse_stack (top + 1) = cur_st; end; top = top - DPDA.v1 (cur_st + 1); if (DPDA.v1 (cur_st) = 6) then cur_st = DPDA.v2 (cur_st + 3); if top > 0 then do i = cur_st + 4 to cur_st + DPDA.v2 (cur_st); if (DPDA.v1 (i) = parse_stack (top)) then do; ns = DPDA.v2 (i); goto NEXT; end; end; else return; ns = DPDA.v2 (cur_st + 3); goto NEXT; dcl top fixed bin (24), /* top of parse stack for this invocation */ ns fixed bin (24); /* branch to follow */ dcl cur_st fixed bin (24); /* current state for this recursion */ dcl rep fixed bin (24); dcl s fixed bin (24); dcl look_ahead bit (1); dcl i fixed bin (24); dcl la_get2 fixed bin (24); dcl la_use2 fixed bin (24); dcl marked fixed bin (24); end next_term; end local_recovered; /* * %page; */ too_many: proc (x, t); p6 = x; call ioa_$rs ("^a", message, message_length, "Exceeded " || p6 || " entries of lrk " || t || " stack."); call mrds_rst_error (rsc_ptr, 4 /* severity */, mrds_error_$rst_parse_fail, (message)); go to stop; /* * variables for too_many: */ dcl p6 pic "zzzzz9"; dcl t char (*) parm; dcl x fixed bin (24) parm; end too_many; stop: ; %page; dcl (abs, copy, hbound, lbound, length, ltrim, min, rel, sign, string, substr) builtin; dcl source_seg_ptr ptr; /* restructuring directives source segment pointer */ dcl source_length fixed binary (24); /* character length of source segment */ dcl mrds_rst_rsc_alloc entry (ptr, fixed bin, ptr); /* working area allocate routine */ dcl mrds_rst_scanner$init entry (ptr, ptr, fixed binary (24)); /* scanner initialization entry */ dcl mrds_rst_scanner entry (ptr, fixed bin (24)); /* lexical analyzer routine */ dcl mrds_rst_semantics entry (fixed bin (24), fixed bin (24), ptr, fixed bin (24)); /* semantic action routines */ dcl mrds_rst_semantics$init entry (ptr); /* semantic initialization entry */ dcl mrds_rst_error entry (ptr, fixed bin, fixed bin (35), char (*)); /* error handling routine */ dcl ioa_$rs entry options (variable); /* routine to return string */ dcl message char (128) varying;/* message with details of error */ dcl message_length fixed binary; /* length of returned error message */ dcl mrds_rst_meter entry (ptr, char (*), bit (1), char (*)); /* metering routine */ dcl mrds_error_$rst_parse_err_recover fixed bin (35) external; /* skip recovery error */ dcl mrds_error_$rst_parse_err_no_recover fixed bin (35) external; /* unable to skip recover */ dcl mrds_error_$rst_parse_err_correct fixed bin (35) external; /* local correction error */ dcl mrds_error_$rst_parse_err_no_correct fixed bin (35) external; /* unable to correct locally */ dcl mrds_error_$rst_parse_fail fixed bin (35) external; /* parsing cannot proceed error */ dcl end_of_input_msg char (18) init (" --END_OF_INPUT-- "); /* EOI message */ %include mrds_rst_parse_stack; %page; %include mrds_rst_parse_table; %page; %include mrds_rst_skip_table; %page; %include mrds_rst_terminals; %page; %include mrds_rst_rsc; %page; %include mrds_rst_struct_types; end;  mrds_rst_parse_table.alm 04/18/85 1454.7r w 04/18/85 0909.2 235071 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " *********************************************************** equ STRD,0 equ LOOK,1 equ STRDS,2 equ LOOKS,3 equ APLY,4 equ APLY1,5 equ APLYS,6 equ SKIP,7 equ ADJUST,8 equ NSRD,9 equ NSRDS,10 equ T0,0 equ ST0,0 " " " DPDA table DPDA: zero 0,DPDAs segdef DPDA " " STATE 1 equ ST1,*-DPDA zero STRD,LN1 zero 13,ST13 " equ LN1,*-DPDA-ST1-1 " " STATE 3 equ ST3,*-DPDA zero NSRD,LN3 zero 0,-ST582 "EOI zero 14,-ST580 " zero 15,-ST582 " zero 16,-ST582 " equ LN3,*-DPDA-ST3-1 " " STATE 8 equ ST8,*-DPDA zero STRD,LN8 zero 4,ST50 " zero -12,ST54 " equ LN8,*-DPDA-ST8-1 " " STATE 11 equ ST11,*-DPDA zero STRD,LN11 zero 0,ST0 "EOI equ LN11,*-DPDA-ST11-1 " " STATE 13 equ ST13,*-DPDA zero STRD,LN13 zero 5,ST58 " equ LN13,*-DPDA-ST13-1 " " STATE 15 equ ST15,*-DPDA zero NSRD,LN15 zero 0,-ST598 "EOI zero 15,-ST596 " zero 16,-ST598 " equ LN15,*-DPDA-ST15-1 " " STATE 19 equ ST19,*-DPDA zero STRD,LN19 zero 4,ST81 " zero -12,ST85 " equ LN19,*-DPDA-ST19-1 " " STATE 22 equ ST22,*-DPDA zero APLY1,LN22 zero 0,0 pd ld zero 65,1 rule/alt zero 31,ST15 prod/val equ LN22,*-DPDA-ST22-1 " " STATE 26 equ ST26,*-DPDA zero STRD,LN26 zero 5,ST87 " equ LN26,*-DPDA-ST26-1 " " STATE 28 equ ST28,*-DPDA zero STRD,LN28 zero 1,ST135 " zero 17,ST137 " zero 18,ST141 " zero 19,ST145 " zero 20,ST149 " zero 21,ST153 " zero 22,ST157 " zero 23,ST161 " zero 24,ST163 " zero 25,ST172 " zero 26,ST181 " zero 27,ST184 " zero 28,ST187 " zero 29,ST194 " equ LN28,*-DPDA-ST28-1 " " STATE 43 equ ST43,*-DPDA zero APLY1,LN43 zero 0,0 pd ld zero 8,1 rule/alt zero 8,ST47 prod/val equ LN43,*-DPDA-ST43-1 " " STATE 47 equ ST47,*-DPDA zero STRD,LN47 zero 3,ST198 " zero 4,ST200 " equ LN47,*-DPDA-ST47-1 " " STATE 50 equ ST50,*-DPDA zero APLY1,LN50 zero 1,1 pd ld zero 7,1 rule/alt zero 7,ST3 prod/val equ LN50,*-DPDA-ST50-1 " " STATE 54 equ ST54,*-DPDA zero APLY1,LN54 zero 0,0 pd ld zero 11,1 rule/alt zero 10,ST28 prod/val equ LN54,*-DPDA-ST54-1 " " STATE 58 equ ST58,*-DPDA zero APLY1,LN58 zero 1,1 pd ld zero 3,1 rule/alt zero 3,ST8 prod/val equ LN58,*-DPDA-ST58-1 " " STATE 62 equ ST62,*-DPDA zero NSRD,LN62 zero 0,-ST604 "EOI zero 16,-ST602 " equ LN62,*-DPDA-ST62-1 " " STATE 65 equ ST65,*-DPDA zero STRD,LN65 zero 4,ST226 " zero -12,ST230 " equ LN65,*-DPDA-ST65-1 " " STATE 68 equ ST68,*-DPDA zero APLY1,LN68 zero 0,0 pd ld zero 70,1 rule/alt zero 34,ST62 prod/val equ LN68,*-DPDA-ST68-1 " " STATE 72 equ ST72,*-DPDA zero STRD,LN72 zero 5,ST234 " equ LN72,*-DPDA-ST72-1 " " STATE 74 equ ST74,*-DPDA zero APLY1,LN74 zero 0,0 pd ld zero 66,1 rule/alt zero 32,ST78 prod/val equ LN74,*-DPDA-ST74-1 " " STATE 78 equ ST78,*-DPDA zero STRD,LN78 zero 3,ST238 " zero 4,ST240 " equ LN78,*-DPDA-ST78-1 " " STATE 81 equ ST81,*-DPDA zero APLY1,LN81 zero 1,1 pd ld zero 65,2 rule/alt zero 31,ST15 prod/val equ LN81,*-DPDA-ST81-1 " " STATE 85 equ ST85,*-DPDA zero STRD,LN85 zero -12,ST244 " equ LN85,*-DPDA-ST85-1 " " STATE 87 equ ST87,*-DPDA zero APLY1,LN87 zero 1,1 pd ld zero 4,1 rule/alt zero 4,ST19 prod/val equ LN87,*-DPDA-ST87-1 " " STATE 91 equ ST91,*-DPDA zero APLY,LN91 zero 0,0 pd ld zero 13,1 rule/alt zero 11,ST131 prod/val zero ST266,ST423 equ LN91,*-DPDA-ST91-1 " " STATE 96 equ ST96,*-DPDA zero APLYS,LN96 zero 0,0 pd ld zero 14,1 rule/alt zero 11,ST91 prod/val equ LN96,*-DPDA-ST96-1 " " STATE 100 equ ST100,*-DPDA zero APLY,LN100 zero 0,0 pd ld zero 31,1 rule/alt zero 14,ST109 prod/val zero ST608,ST249 equ LN100,*-DPDA-ST100-1 " " STATE 105 equ ST105,*-DPDA zero APLYS,LN105 zero 0,0 pd ld zero 25,1 rule/alt zero 14,ST100 prod/val equ LN105,*-DPDA-ST105-1 " " STATE 109 equ ST109,*-DPDA zero APLY1,LN109 zero 0,0 pd ld zero 16,1 rule/alt zero 13,ST113 prod/val equ LN109,*-DPDA-ST109-1 " " STATE 113 equ ST113,*-DPDA zero NSRD,LN113 zero 1,-ST608 " zero 3,-ST619 " zero 4,-ST619 " zero 6,-ST619 " zero 17,-ST608 " zero 18,-ST608 " zero 19,-ST608 " zero 20,-ST608 " zero 21,-ST608 " zero 22,-ST608 " zero 23,-ST608 " zero 28,-ST608 " zero 29,-ST608 " equ LN113,*-DPDA-ST113-1 " " STATE 127 equ ST127,*-DPDA zero APLYS,LN127 zero 0,0 pd ld zero 12,1 rule/alt zero 11,ST91 prod/val equ LN127,*-DPDA-ST127-1 " " STATE 131 equ ST131,*-DPDA zero NSRD,LN131 zero 3,-ST625 " zero 4,-ST625 " zero 6,-ST623 " equ LN131,*-DPDA-ST131-1 " " STATE 135 equ ST135,*-DPDA zero STRD,LN135 zero 11,ST293 " equ LN135,*-DPDA-ST135-1 " " STATE 137 equ ST137,*-DPDA zero APLYS,LN137 zero 0,0 pd ld zero 18,1 rule/alt zero 14,ST100 prod/val equ LN137,*-DPDA-ST137-1 " " STATE 141 equ ST141,*-DPDA zero APLYS,LN141 zero 0,0 pd ld zero 19,1 rule/alt zero 14,ST100 prod/val equ LN141,*-DPDA-ST141-1 " " STATE 145 equ ST145,*-DPDA zero APLYS,LN145 zero 0,0 pd ld zero 20,1 rule/alt zero 14,ST100 prod/val equ LN145,*-DPDA-ST145-1 " " STATE 149 equ ST149,*-DPDA zero APLYS,LN149 zero 0,0 pd ld zero 21,1 rule/alt zero 14,ST100 prod/val equ LN149,*-DPDA-ST149-1 " " STATE 153 equ ST153,*-DPDA zero APLYS,LN153 zero 0,0 pd ld zero 22,1 rule/alt zero 14,ST100 prod/val equ LN153,*-DPDA-ST153-1 " " STATE 157 equ ST157,*-DPDA zero APLYS,LN157 zero 0,0 pd ld zero 23,1 rule/alt zero 14,ST100 prod/val equ LN157,*-DPDA-ST157-1 " " STATE 161 equ ST161,*-DPDA zero STRD,LN161 zero 1,ST135 " equ LN161,*-DPDA-ST161-1 " " STATE 163 equ ST163,*-DPDA zero NSRD,LN163 zero 1,-ST629 " zero 3,-ST635 " zero 4,-ST635 " zero 6,-ST635 " zero 26,-ST629 " zero 27,-ST629 " zero 28,-ST629 " zero 29,-ST629 " equ LN163,*-DPDA-ST163-1 " " STATE 172 equ ST172,*-DPDA zero NSRD,LN172 zero 1,-ST639 " zero 3,-ST640 " zero 4,-ST640 " zero 6,-ST640 " zero 26,-ST639 " zero 27,-ST639 " zero 28,-ST639 " zero 29,-ST639 " equ LN172,*-DPDA-ST172-1 " " STATE 181 equ ST181,*-DPDA zero STRD,LN181 zero 24,ST350 " zero 25,ST359 " equ LN181,*-DPDA-ST181-1 " " STATE 184 equ ST184,*-DPDA zero STRD,LN184 zero 24,ST368 " zero 25,ST377 " equ LN184,*-DPDA-ST184-1 " " STATE 187 equ ST187,*-DPDA zero APLY,LN187 zero 0,0 pd ld zero 32,1 rule/alt zero 17,ST317 prod/val zero ST28,ST100 zero ST266,ST100 zero ST608,ST100 equ LN187,*-DPDA-ST187-1 " " STATE 194 equ ST194,*-DPDA zero APLYS,LN194 zero 0,0 pd ld zero 33,1 rule/alt zero 17,ST187 prod/val equ LN194,*-DPDA-ST194-1 " " STATE 198 equ ST198,*-DPDA zero STRD,LN198 zero -12,ST54 " equ LN198,*-DPDA-ST198-1 " " STATE 200 equ ST200,*-DPDA zero APLY1,LN200 zero 2,2 pd ld zero 7,2 rule/alt zero 7,ST3 prod/val equ LN200,*-DPDA-ST200-1 " " STATE 204 equ ST204,*-DPDA zero APLY1,LN204 zero 3,3 pd ld zero 1,1 rule/alt zero 1,ST11 prod/val equ LN204,*-DPDA-ST204-1 " " STATE 208 equ ST208,*-DPDA zero STRD,LN208 zero 4,ST399 " zero -12,ST403 " equ LN208,*-DPDA-ST208-1 " " STATE 211 equ ST211,*-DPDA zero APLY1,LN211 zero 0,0 pd ld zero 80,1 rule/alt zero 40,ST204 prod/val equ LN211,*-DPDA-ST211-1 " " STATE 215 equ ST215,*-DPDA zero STRD,LN215 zero 5,ST407 " equ LN215,*-DPDA-ST215-1 " " STATE 217 equ ST217,*-DPDA zero STRD,LN217 zero 1,ST411 " equ LN217,*-DPDA-ST217-1 " " STATE 219 equ ST219,*-DPDA zero APLY1,LN219 zero 0,0 pd ld zero 71,1 rule/alt zero 35,ST223 prod/val equ LN219,*-DPDA-ST219-1 " " STATE 223 equ ST223,*-DPDA zero STRD,LN223 zero 3,ST413 " zero 4,ST415 " equ LN223,*-DPDA-ST223-1 " " STATE 226 equ ST226,*-DPDA zero APLY1,LN226 zero 1,1 pd ld zero 70,2 rule/alt zero 34,ST62 prod/val equ LN226,*-DPDA-ST226-1 " " STATE 230 equ ST230,*-DPDA zero APLY1,LN230 zero 0,0 pd ld zero 74,1 rule/alt zero 37,ST217 prod/val equ LN230,*-DPDA-ST230-1 " " STATE 234 equ ST234,*-DPDA zero APLY1,LN234 zero 1,1 pd ld zero 5,1 rule/alt zero 5,ST65 prod/val equ LN234,*-DPDA-ST234-1 " " STATE 238 equ ST238,*-DPDA zero STRD,LN238 zero -12,ST85 " equ LN238,*-DPDA-ST238-1 " " STATE 240 equ ST240,*-DPDA zero APLY1,LN240 zero 2,2 pd ld zero 64,1 rule/alt zero 31,ST15 prod/val equ LN240,*-DPDA-ST240-1 " " STATE 244 equ ST244,*-DPDA zero APLY,LN244 zero 1,1 pd ld zero 68,1 rule/alt zero 33,ST74 prod/val zero ST238,ST419 equ LN244,*-DPDA-ST244-1 " " STATE 249 equ ST249,*-DPDA zero APLY1,LN249 zero 1,1 pd ld zero 17,1 rule/alt zero 13,ST113 prod/val equ LN249,*-DPDA-ST249-1 " " STATE 253 equ ST253,*-DPDA zero APLY,LN253 zero 0,0 pd ld zero 54,1 rule/alt zero 25,ST271 prod/val zero ST644,ST427 equ LN253,*-DPDA-ST253-1 " " STATE 258 equ ST258,*-DPDA zero APLYS,LN258 zero 0,0 pd ld zero 53,1 rule/alt zero 25,ST253 prod/val equ LN258,*-DPDA-ST258-1 " " STATE 262 equ ST262,*-DPDA zero APLYS,LN262 zero 0,0 pd ld zero 52,1 rule/alt zero 25,ST253 prod/val equ LN262,*-DPDA-ST262-1 " " STATE 266 equ ST266,*-DPDA zero STRDS,ST28 " " STATE 267 equ ST267,*-DPDA zero APLYS,LN267 zero 0,0 pd ld zero 55,1 rule/alt zero 25,ST253 prod/val equ LN267,*-DPDA-ST267-1 " " STATE 271 equ ST271,*-DPDA zero APLY1,LN271 zero 0,0 pd ld zero 51,1 rule/alt zero 24,ST275 prod/val equ LN271,*-DPDA-ST271-1 " " STATE 275 equ ST275,*-DPDA zero NSRD,LN275 zero 3,-ST646 " zero 4,-ST646 " zero 6,-ST644 " equ LN275,*-DPDA-ST275-1 " " STATE 279 equ ST279,*-DPDA zero APLY,LN279 zero 2,2 pd ld zero 10,1 rule/alt zero 9,ST43 prod/val zero ST198,ST386 equ LN279,*-DPDA-ST279-1 " " STATE 284 equ ST284,*-DPDA zero APLY1,LN284 zero 0,0 pd ld zero 49,1 rule/alt zero 23,ST279 prod/val equ LN284,*-DPDA-ST284-1 " " STATE 288 equ ST288,*-DPDA zero STRD,LN288 zero 30,ST431 " zero 31,ST433 " zero 32,ST435 " zero 33,ST437 " equ LN288,*-DPDA-ST288-1 " " STATE 293 equ ST293,*-DPDA zero STRD,LN293 zero 2,ST441 " zero 3,ST446 " equ LN293,*-DPDA-ST293-1 " " STATE 296 equ ST296,*-DPDA zero APLYS,LN296 zero 1,1 pd ld zero 24,1 rule/alt zero 14,ST100 prod/val equ LN296,*-DPDA-ST296-1 " " STATE 300 equ ST300,*-DPDA zero APLY1,LN300 zero 0,0 pd ld zero 39,1 rule/alt zero 20,ST304 prod/val equ LN300,*-DPDA-ST300-1 " " STATE 304 equ ST304,*-DPDA zero NSRD,LN304 zero 1,-ST650 " zero 3,-ST651 " zero 4,-ST651 " zero 6,-ST651 " zero 26,-ST650 " zero 27,-ST650 " zero 28,-ST650 " zero 29,-ST650 " equ LN304,*-DPDA-ST304-1 " " STATE 313 equ ST313,*-DPDA zero APLY1,LN313 zero 1,1 pd ld zero 45,1 rule/alt zero 22,ST91 prod/val equ LN313,*-DPDA-ST313-1 " " STATE 317 equ ST317,*-DPDA zero APLY,LN317 zero 0,0 pd ld zero 42,1 rule/alt zero 21,ST300 prod/val zero ST650,ST450 equ LN317,*-DPDA-ST317-1 " " STATE 322 equ ST322,*-DPDA zero APLY,LN322 zero 0,0 pd ld zero 38,1 rule/alt zero 19,ST313 prod/val zero ST639,ST346 zero ST640,ST346 zero ST655,ST456 zero ST656,ST456 zero ST660,ST460 zero ST661,ST460 zero ST665,ST464 zero ST666,ST464 zero ST670,ST468 zero ST671,ST468 equ LN322,*-DPDA-ST322-1 " " STATE 336 equ ST336,*-DPDA zero STRD,LN336 zero 11,ST454 " equ LN336,*-DPDA-ST336-1 " " STATE 338 equ ST338,*-DPDA zero APLYS,LN338 zero 0,0 pd ld zero 43,1 rule/alt zero 21,ST317 prod/val equ LN338,*-DPDA-ST338-1 " " STATE 342 equ ST342,*-DPDA zero APLYS,LN342 zero 0,0 pd ld zero 44,1 rule/alt zero 21,ST317 prod/val equ LN342,*-DPDA-ST342-1 " " STATE 346 equ ST346,*-DPDA zero APLY1,LN346 zero 1,1 pd ld zero 34,1 rule/alt zero 18,ST96 prod/val equ LN346,*-DPDA-ST346-1 " " STATE 350 equ ST350,*-DPDA zero NSRD,LN350 zero 1,-ST655 " zero 3,-ST656 " zero 4,-ST656 " zero 6,-ST656 " zero 26,-ST655 " zero 27,-ST655 " zero 28,-ST655 " zero 29,-ST655 " equ LN350,*-DPDA-ST350-1 " " STATE 359 equ ST359,*-DPDA zero NSRD,LN359 zero 1,-ST660 " zero 3,-ST661 " zero 4,-ST661 " zero 6,-ST661 " zero 26,-ST660 " zero 27,-ST660 " zero 28,-ST660 " zero 29,-ST660 " equ LN359,*-DPDA-ST359-1 " " STATE 368 equ ST368,*-DPDA zero NSRD,LN368 zero 1,-ST665 " zero 3,-ST666 " zero 4,-ST666 " zero 6,-ST666 " zero 26,-ST665 " zero 27,-ST665 " zero 28,-ST665 " zero 29,-ST665 " equ LN368,*-DPDA-ST368-1 " " STATE 377 equ ST377,*-DPDA zero NSRD,LN377 zero 1,-ST670 " zero 3,-ST671 " zero 4,-ST671 " zero 6,-ST671 " zero 26,-ST670 " zero 27,-ST670 " zero 28,-ST670 " zero 29,-ST670 " equ LN377,*-DPDA-ST377-1 " " STATE 386 equ ST386,*-DPDA zero APLY1,LN386 zero 2,2 pd ld zero 9,1 rule/alt zero 8,ST47 prod/val equ LN386,*-DPDA-ST386-1 " " STATE 390 equ ST390,*-DPDA zero STRD,LN390 zero 1,ST472 " equ LN390,*-DPDA-ST390-1 " " STATE 392 equ ST392,*-DPDA zero APLY1,LN392 zero 0,0 pd ld zero 81,1 rule/alt zero 41,ST396 prod/val equ LN392,*-DPDA-ST392-1 " " STATE 396 equ ST396,*-DPDA zero STRD,LN396 zero 3,ST474 " zero 4,ST476 " equ LN396,*-DPDA-ST396-1 " " STATE 399 equ ST399,*-DPDA zero APLY1,LN399 zero 1,1 pd ld zero 80,2 rule/alt zero 40,ST204 prod/val equ LN399,*-DPDA-ST399-1 " " STATE 403 equ ST403,*-DPDA zero APLY1,LN403 zero 0,0 pd ld zero 84,1 rule/alt zero 43,ST390 prod/val equ LN403,*-DPDA-ST403-1 " " STATE 407 equ ST407,*-DPDA zero APLY1,LN407 zero 1,1 pd ld zero 6,1 rule/alt zero 6,ST208 prod/val equ LN407,*-DPDA-ST407-1 " " STATE 411 equ ST411,*-DPDA zero STRD,LN411 zero -12,ST487 " equ LN411,*-DPDA-ST411-1 " " STATE 413 equ ST413,*-DPDA zero STRD,LN413 zero -12,ST230 " equ LN413,*-DPDA-ST413-1 " " STATE 415 equ ST415,*-DPDA zero APLY1,LN415 zero 2,2 pd ld zero 69,1 rule/alt zero 34,ST62 prod/val equ LN415,*-DPDA-ST415-1 " " STATE 419 equ ST419,*-DPDA zero APLY1,LN419 zero 2,2 pd ld zero 67,1 rule/alt zero 32,ST78 prod/val equ LN419,*-DPDA-ST419-1 " " STATE 423 equ ST423,*-DPDA zero APLY1,LN423 zero 1,1 pd ld zero 56,1 rule/alt zero 26,ST267 prod/val equ LN423,*-DPDA-ST423-1 " " STATE 427 equ ST427,*-DPDA zero APLY1,LN427 zero 1,1 pd ld zero 50,1 rule/alt zero 24,ST275 prod/val equ LN427,*-DPDA-ST427-1 " " STATE 431 equ ST431,*-DPDA zero STRD,LN431 zero 9,ST495 " equ LN431,*-DPDA-ST431-1 " " STATE 433 equ ST433,*-DPDA zero STRD,LN433 zero 9,ST500 " equ LN433,*-DPDA-ST433-1 " " STATE 435 equ ST435,*-DPDA zero STRD,LN435 zero 9,ST505 " equ LN435,*-DPDA-ST435-1 " " STATE 437 equ ST437,*-DPDA zero APLY1,LN437 zero 1,1 pd ld zero 57,1 rule/alt zero 27,ST266 prod/val equ LN437,*-DPDA-ST437-1 " " STATE 441 equ ST441,*-DPDA zero APLY,LN441 zero 2,2 pd ld zero 30,1 rule/alt zero 16,ST105 prod/val zero ST161,ST296 equ LN441,*-DPDA-ST441-1 " " STATE 446 equ ST446,*-DPDA zero NSRD,LN446 zero 6,-ST675 " zero 8,-ST675 " zero 11,-ST678 " equ LN446,*-DPDA-ST446-1 " " STATE 450 equ ST450,*-DPDA zero APLY1,LN450 zero 1,1 pd ld zero 40,1 rule/alt zero 20,ST304 prod/val equ LN450,*-DPDA-ST450-1 " " STATE 454 equ ST454,*-DPDA zero STRD,LN454 zero 2,ST524 " equ LN454,*-DPDA-ST454-1 " " STATE 456 equ ST456,*-DPDA zero APLY1,LN456 zero 2,2 pd ld zero 46,1 rule/alt zero 22,ST91 prod/val equ LN456,*-DPDA-ST456-1 " " STATE 460 equ ST460,*-DPDA zero APLY1,LN460 zero 2,2 pd ld zero 35,1 rule/alt zero 18,ST96 prod/val equ LN460,*-DPDA-ST460-1 " " STATE 464 equ ST464,*-DPDA zero APLY1,LN464 zero 2,2 pd ld zero 47,1 rule/alt zero 22,ST91 prod/val equ LN464,*-DPDA-ST464-1 " " STATE 468 equ ST468,*-DPDA zero APLY1,LN468 zero 2,2 pd ld zero 36,1 rule/alt zero 18,ST96 prod/val equ LN468,*-DPDA-ST468-1 " " STATE 472 equ ST472,*-DPDA zero STRD,LN472 zero -12,ST531 " equ LN472,*-DPDA-ST472-1 " " STATE 474 equ ST474,*-DPDA zero STRD,LN474 zero -12,ST403 " equ LN474,*-DPDA-ST474-1 " " STATE 476 equ ST476,*-DPDA zero APLY1,LN476 zero 2,2 pd ld zero 79,1 rule/alt zero 40,ST204 prod/val equ LN476,*-DPDA-ST476-1 " " STATE 480 equ ST480,*-DPDA zero APLY1,LN480 zero 0,0 pd ld zero 75,1 rule/alt zero 38,ST484 prod/val equ LN480,*-DPDA-ST480-1 " " STATE 484 equ ST484,*-DPDA zero STRD,LN484 zero 2,ST543 " zero -12,ST487 " equ LN484,*-DPDA-ST484-1 " " STATE 487 equ ST487,*-DPDA zero NSRD,LN487 zero 2,-ST684 " zero 7,-ST682 " zero -12,-ST684 " equ LN487,*-DPDA-ST487-1 " " STATE 491 equ ST491,*-DPDA zero APLY1,LN491 zero 2,2 pd ld zero 72,1 rule/alt zero 35,ST223 prod/val equ LN491,*-DPDA-ST491-1 " " STATE 495 equ ST495,*-DPDA zero NSRD,LN495 zero 3,-ST690 " zero 4,-ST690 " zero 6,-ST690 " zero 10,-ST688 " equ LN495,*-DPDA-ST495-1 " " STATE 500 equ ST500,*-DPDA zero NSRD,LN500 zero 3,-ST696 " zero 4,-ST696 " zero 6,-ST696 " zero 10,-ST694 " equ LN500,*-DPDA-ST500-1 " " STATE 505 equ ST505,*-DPDA zero NSRD,LN505 zero 3,-ST702 " zero 4,-ST702 " zero 6,-ST702 " zero 10,-ST700 " equ LN505,*-DPDA-ST505-1 " " STATE 510 equ ST510,*-DPDA zero STRD,LN510 zero 11,ST565 " equ LN510,*-DPDA-ST510-1 " " STATE 512 equ ST512,*-DPDA zero APLY1,LN512 zero 0,0 pd ld zero 28,1 rule/alt zero 15,ST510 prod/val equ LN512,*-DPDA-ST512-1 " " STATE 516 equ ST516,*-DPDA zero APLY1,LN516 zero 0,0 pd ld zero 27,1 rule/alt zero 15,ST510 prod/val equ LN516,*-DPDA-ST516-1 " " STATE 520 equ ST520,*-DPDA zero APLY1,LN520 zero 0,0 pd ld zero 26,1 rule/alt zero 15,ST510 prod/val equ LN520,*-DPDA-ST520-1 " " STATE 524 equ ST524,*-DPDA zero APLYS,LN524 zero 2,2 pd ld zero 41,1 rule/alt zero 21,ST317 prod/val equ LN524,*-DPDA-ST524-1 " " STATE 528 equ ST528,*-DPDA zero STRD,LN528 zero 2,ST567 " zero -12,ST572 " equ LN528,*-DPDA-ST528-1 " " STATE 531 equ ST531,*-DPDA zero APLY1,LN531 zero 0,0 pd ld zero 85,1 rule/alt zero 44,ST528 prod/val equ LN531,*-DPDA-ST531-1 " " STATE 535 equ ST535,*-DPDA zero APLY1,LN535 zero 2,2 pd ld zero 82,1 rule/alt zero 41,ST396 prod/val equ LN535,*-DPDA-ST535-1 " " STATE 539 equ ST539,*-DPDA zero APLY1,LN539 zero 1,1 pd ld zero 76,1 rule/alt zero 38,ST484 prod/val equ LN539,*-DPDA-ST539-1 " " STATE 543 equ ST543,*-DPDA zero APLY,LN543 zero 3,3 pd ld zero 73,1 rule/alt zero 36,ST219 prod/val zero ST413,ST491 equ LN543,*-DPDA-ST543-1 " " STATE 548 equ ST548,*-DPDA zero APLY,LN548 zero 1,1 pd ld zero 78,1 rule/alt zero 39,ST480 prod/val zero ST484,ST539 equ LN548,*-DPDA-ST548-1 " " STATE 553 equ ST553,*-DPDA zero APLY1,LN553 zero 3,3 pd ld zero 58,1 rule/alt zero 28,ST262 prod/val equ LN553,*-DPDA-ST553-1 " " STATE 557 equ ST557,*-DPDA zero APLY1,LN557 zero 3,3 pd ld zero 60,1 rule/alt zero 29,ST258 prod/val equ LN557,*-DPDA-ST557-1 " " STATE 561 equ ST561,*-DPDA zero APLY1,LN561 zero 3,3 pd ld zero 62,1 rule/alt zero 30,ST253 prod/val equ LN561,*-DPDA-ST561-1 " " STATE 565 equ ST565,*-DPDA zero STRD,LN565 zero 2,ST576 " equ LN565,*-DPDA-ST565-1 " " STATE 567 equ ST567,*-DPDA zero APLY,LN567 zero 3,3 pd ld zero 83,1 rule/alt zero 42,ST392 prod/val zero ST474,ST535 equ LN567,*-DPDA-ST567-1 " " STATE 572 equ ST572,*-DPDA zero APLY1,LN572 zero 1,1 pd ld zero 86,1 rule/alt zero 44,ST528 prod/val equ LN572,*-DPDA-ST572-1 " " STATE 576 equ ST576,*-DPDA zero APLYS,LN576 zero 5,5 pd ld zero 29,1 rule/alt zero 16,ST441 prod/val equ LN576,*-DPDA-ST576-1 " " STATE 580 equ ST580,*-DPDA zero STRD,LN580 zero 14,ST26 " equ LN580,*-DPDA-ST580-1 " " STATE 582 equ ST582,*-DPDA zero APLY,LN582 zero -1,-1 pd ld zero 2,1 rule/alt zero 2,ST322 prod/val zero ST580,ST22 zero ST582,ST22 zero ST596,ST68 zero ST598,ST68 zero ST602,ST211 zero ST604,ST211 zero ST623,ST284 zero ST625,ST284 zero ST675,ST512 zero ST678,ST512 equ LN582,*-DPDA-ST582-1 " " STATE 596 equ ST596,*-DPDA zero STRD,LN596 zero 15,ST72 " equ LN596,*-DPDA-ST596-1 " " STATE 598 equ ST598,*-DPDA zero APLYS,LN598 zero -1,-1 pd ld zero 2,1 rule/alt zero 2,ST582 prod/val equ LN598,*-DPDA-ST598-1 " " STATE 602 equ ST602,*-DPDA zero STRD,LN602 zero 16,ST215 " equ LN602,*-DPDA-ST602-1 " " STATE 604 equ ST604,*-DPDA zero APLYS,LN604 zero -1,-1 pd ld zero 2,1 rule/alt zero 2,ST582 prod/val equ LN604,*-DPDA-ST604-1 " " STATE 608 equ ST608,*-DPDA zero STRD,LN608 zero 1,ST135 " zero 17,ST137 " zero 18,ST141 " zero 19,ST145 " zero 20,ST149 " zero 21,ST153 " zero 22,ST157 " zero 23,ST161 " zero 28,ST187 " zero 29,ST194 " equ LN608,*-DPDA-ST608-1 " " STATE 619 equ ST619,*-DPDA zero APLY1,LN619 zero 0,0 pd ld zero 15,1 rule/alt zero 12,ST127 prod/val equ LN619,*-DPDA-ST619-1 " " STATE 623 equ ST623,*-DPDA zero STRD,LN623 zero 6,ST288 " equ LN623,*-DPDA-ST623-1 " " STATE 625 equ ST625,*-DPDA zero APLYS,LN625 zero -1,-1 pd ld zero 2,1 rule/alt zero 2,ST582 prod/val equ LN625,*-DPDA-ST625-1 " " STATE 629 equ ST629,*-DPDA zero STRD,LN629 zero 1,ST336 " zero 26,ST338 " zero 27,ST342 " zero 28,ST187 " zero 29,ST194 " equ LN629,*-DPDA-ST629-1 " " STATE 635 equ ST635,*-DPDA zero APLYS,LN635 zero -1,-1 pd ld zero 2,1 rule/alt zero 2,ST582 prod/val equ LN635,*-DPDA-ST635-1 " " STATE 639 equ ST639,*-DPDA zero STRDS,ST629 " " STATE 640 equ ST640,*-DPDA zero APLYS,LN640 zero -1,-1 pd ld zero 2,1 rule/alt zero 2,ST582 prod/val equ LN640,*-DPDA-ST640-1 " " STATE 644 equ ST644,*-DPDA zero STRD,LN644 zero 6,ST288 " equ LN644,*-DPDA-ST644-1 " " STATE 646 equ ST646,*-DPDA zero APLY1,LN646 zero 0,0 pd ld zero 48,1 rule/alt zero 23,ST279 prod/val equ LN646,*-DPDA-ST646-1 " " STATE 650 equ ST650,*-DPDA zero STRDS,ST629 " " STATE 651 equ ST651,*-DPDA zero APLYS,LN651 zero 0,0 pd ld zero 37,1 rule/alt zero 19,ST322 prod/val equ LN651,*-DPDA-ST651-1 " " STATE 655 equ ST655,*-DPDA zero STRDS,ST629 " " STATE 656 equ ST656,*-DPDA zero APLYS,LN656 zero -1,-1 pd ld zero 2,1 rule/alt zero 2,ST582 prod/val equ LN656,*-DPDA-ST656-1 " " STATE 660 equ ST660,*-DPDA zero STRDS,ST629 " " STATE 661 equ ST661,*-DPDA zero APLYS,LN661 zero -1,-1 pd ld zero 2,1 rule/alt zero 2,ST582 prod/val equ LN661,*-DPDA-ST661-1 " " STATE 665 equ ST665,*-DPDA zero STRDS,ST629 " " STATE 666 equ ST666,*-DPDA zero APLYS,LN666 zero -1,-1 pd ld zero 2,1 rule/alt zero 2,ST582 prod/val equ LN666,*-DPDA-ST666-1 " " STATE 670 equ ST670,*-DPDA zero STRDS,ST629 " " STATE 671 equ ST671,*-DPDA zero APLYS,LN671 zero -1,-1 pd ld zero 2,1 rule/alt zero 2,ST582 prod/val equ LN671,*-DPDA-ST671-1 " " STATE 675 equ ST675,*-DPDA zero STRD,LN675 zero 6,ST516 " zero 8,ST520 " equ LN675,*-DPDA-ST675-1 " " STATE 678 equ ST678,*-DPDA zero APLYS,LN678 zero -1,-1 pd ld zero 2,1 rule/alt zero 2,ST582 prod/val equ LN678,*-DPDA-ST678-1 " " STATE 682 equ ST682,*-DPDA zero STRD,LN682 zero 7,ST548 " equ LN682,*-DPDA-ST682-1 " " STATE 684 equ ST684,*-DPDA zero APLYS,LN684 zero 0,0 pd ld zero 77,1 rule/alt zero 39,ST548 prod/val equ LN684,*-DPDA-ST684-1 " " STATE 688 equ ST688,*-DPDA zero STRD,LN688 zero 10,ST553 " equ LN688,*-DPDA-ST688-1 " " STATE 690 equ ST690,*-DPDA zero APLY1,LN690 zero 2,2 pd ld zero 59,1 rule/alt zero 28,ST262 prod/val equ LN690,*-DPDA-ST690-1 " " STATE 694 equ ST694,*-DPDA zero STRD,LN694 zero 10,ST557 " equ LN694,*-DPDA-ST694-1 " " STATE 696 equ ST696,*-DPDA zero APLY1,LN696 zero 2,2 pd ld zero 61,1 rule/alt zero 29,ST258 prod/val equ LN696,*-DPDA-ST696-1 " " STATE 700 equ ST700,*-DPDA zero STRD,LN700 zero 10,ST561 " equ LN700,*-DPDA-ST700-1 " " STATE 702 equ ST702,*-DPDA zero APLY1,LN702 zero 2,2 pd ld zero 63,1 rule/alt zero 30,ST253 prod/val equ LN702,*-DPDA-ST702-1 equ DPDAs,*-DPDA zero 1,12 "SKIP/ADJ zero 7,2 "SKIP/ADJ zero 34,0 "SKIP/ADJ zero 4,710 "SKIP/ADJ zero 8,8 "SKIP/ADJ zero 11,3 "SKIP/ADJ zero 47,3 "SKIP/ADJ zero 510,3 "SKIP/ADJ zero 580,3 "SKIP/ADJ zero 596,3 "SKIP/ADJ zero 602,3 "SKIP/ADJ zero 623,3 "SKIP/ADJ zero 644,3 "SKIP/ADJ end  mrds_rst_proc_ctl_args.pl1 09/26/88 1255.5rew 09/26/88 1247.9 146844 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(88-09-19,Blair), approve(88-09-19,MCR7995), audit(88-09-20,Dupuis), install(88-09-26,MR12.2-1119): Make sure that arg_info.relation_mode_flags has a null value when we process -vf so that if vfile was specified after -dm it will successfully override any previously set modes. TR 21051. END HISTORY COMMENTS */ mrds_rst_proc_ctl_args: proc (arg_list_ptr, ai_ptr, suffix_flag, default_relation_mode_flags, fatal_sw); /* BEGIN_DESCRIPTION The purpose of this procedure is to process the command level control arguments for the rmdb and cmdb commands. arg_list_ptr ptr; (INPUT) Pointer to Multics command level argument list ai_ptr ptr; (INPUT) Pointer to arg_info structure suffix_flag bit(1); (input) ON => enforce ".db" suffix in database pathname default_relation_mode_flags struct (input) Defaults for creating relations fatal_sw bit (1); (OUTPUT) On = fatal error occured during argument processing (do not continue after return). All error messages will be reported from this procedure via com_err_ What to do upon return from this procedure should be decided as a result of the fatal_sw (If ON do not continue) If the fatal_sw is OFF then arg_info will reflect the argument info supplied and any defaults not supplied. END_DESCRIPTION HISTORY Written by R. D. Lackey March 1979 Modified by Jim Gray - - June 1979 to enforce MR7.0 database pathname suffix ".db" Modified by Jim Gray - - June 1980, to remove -control from usage statment to agree with documentation for this release. Modified by Jim Gray - - 80-11-06, to add "-secure" option to cmdb control arg processing. 81-04-28 Jim Gray : added -no_list, -no_secure, and -force options. 81-09-25 Davids: changed the internal procedure get_source so that it no longer determines if the source arg had a suffix and if not added it instead it just calls expand_pathname_$add_suffix. A stringrange error was occuring on source names less than 5 characters. Also changed the declaration of entry_name from char (32) varying to char (4). It is being used to hold the suffix "cmdb" or "rmdb" 82-08-19 Davids: added processing for control arguments -page_file (-pf) and -vfile (-vf) 82-11-23 Davids: added the default_db_type parameter and changed so that arg_info.db_type is set from default_db_type instead of the constant "vf". 83-02-18 Mike Kubicar : Ripped out all code relating to the obsolete restructure_mrds_db. Added the -dm_file option and its corresponding mode string to describe the properties for creating relations. 83-10-04 Paul Benjamin: to check whether or not the offending arg is a control arg before returning et$badopt and return et$bad_arg instead. 84-09-06 Paul Benjamin: to change -dm_file to -data_management_file but retain the former as undocumented form. */ %page; /* START */ fatal_sw = OFF; call init_arg_info; /* Init arg_info structure */ call cu_$arg_count_rel (nargs, arg_list_ptr); /* Get the number of arguments in list */ entry_name = "cmdb"; dm_file_mode_string = ""; if nargs < 1 then /* Got to have at least the cmdb source path */ call error (error_table_$wrong_no_of_args, "create_mrds_db Usage: cmdb source_path {database_path -control_args...}^/"); else call cu_$arg_ptr_rel (1, arg_ptr, arg_len, code, arg_list_ptr); if code ^= 0 then call error (code, "Argument number 1"); call get_source (arg, entry_name); /* Stuff absolute path name of source in arg_info */ rel_db_path = before (arg_info.source_entry, "." || entry_name); /* Init in case no data base path is */ /* use source entry name without entry_name component */ if nargs > 1 then do i = 2 to nargs; /* Set option flags if any */ call cu_$arg_ptr_rel (i, arg_ptr, arg_len, code, arg_list_ptr); if code ^= 0 then call error (code, "parameter " || arg); opt_ok = OFF; if i = 2 then do; /* See if they supplied a data base path */ if ^is_ctl_option (arg) then do; opt_ok = ON; rel_db_path = arg; end; end; if arg = "-no_list" | arg = "-nls" then do; opt_ok = ON; arg_info.list = OFF; end; else if arg = "-ls" | arg = "-list" then opt_ok, arg_info.list = ON; /* -list option */ else if arg = "-secure" then opt_ok, arg_info.secure = ON; /* set secured bit in model option */ else if arg = "-no_secure" then do; opt_ok = ON; arg_info.secure = OFF; end; else if arg = "-no_force" | arg = "-nfc" then do; opt_ok = ON; arg_info.force = OFF; end; else if arg = "-force" | arg = "-fc" then do; opt_ok = ON; arg_info.force = ON; end; else if arg = "-td" | arg = "-temp_dir" then do; /* temp directory option */ arg_info.twd = ON; opt_ok = ON; i = i + 1; /* Position to next arg (should be temp_dir path) */ if i > nargs then call error (mrds_error_$no_temp_dir, ""); else call cu_$arg_ptr_rel (i, arg_ptr, arg_len, code, arg_list_ptr); if code ^= 0 then call error (code, "Temp_directory"); if is_ctl_option (arg) then call error (mrds_error_$no_temp_dir, ""); call absolute_pathname_ (arg, arg_info.temp_work_dir, code); if code ^= 0 then call error (code, arg); end; else if arg = "-vfile" | arg = "-vf" then do; opt_ok = ON; arg_info.relation_mode_flags = "0"b; dm_file_mode_string = ""; end; else if arg = "-data_management_file" | arg = "-dmf" | /* undocumented */ arg = "-dm_file" then do; opt_ok = ON; arg_info.relation_mode_flags.dm_file_type = "1"b; arg_info.relation_mode_flags.protection_on = "1"b; arg_info.relation_mode_flags.concurrency_on = "1"b; arg_info.relation_mode_flags.rollback_on = "1"b; call cu_$arg_ptr_rel ((i + 1), arg_ptr, arg_len, code, arg_list_ptr); if (code ^= 0) & (code ^= error_table_$noarg) then call error (code, "Argument number " || ltrim (char ((i + 1), 20))); if code ^= error_table_$noarg then if ^is_ctl_option (arg) then do; if length (arg) > length (dm_file_mode_string) then call error (error_table_$bigarg, "Mode string is too long."); dm_file_mode_string = arg; i = i + 1; end; end; if ^opt_ok then do; if is_ctl_option (arg) then call error (error_table_$badopt, arg); else call error (error_table_$bad_arg, arg); end; end; /* END DO I = 2 TO NARGS */ /* Take care of the mode string */ call set_modes (dm_file_mode_string, arg_info.relation_mode_flags); /* make absolute path of data base directory */ if ^suffix_flag then call absolute_pathname_ (rel_db_path, arg_info.db_dir_path, code); else call absolute_pathname_$add_suffix (rel_db_path, db_suffix, arg_info.db_dir_path, code); if code ^= 0 then call error (code, rel_db_path); exit: return; /* Only return from this procedure */ %page; /********** * * This routine is used to parse the mode string needed by the dm_file * argument and check it for consistency. It calls mode_string_$parse * to parse the string and then goes through the mode_string_info * structure, setting bits in the "mode_bits" parameter to reflect the * state of the mode string. * **********/ set_modes: proc (mode_string, mode_bits); /* Parameters */ dcl mode_string char (*); /* The mode string in the command line */ dcl 1 mode_bits like db_relation_modes; /* Structure describing the file characteristics */ /* Local definitions */ dcl error_table_$bad_mode_value fixed bin (35) ext static; dcl error_table_$undefined_mode fixed bin (35) ext static; dcl error_table_$unimplemented_version fixed bin (35) ext static; dcl mode_string_$parse entry (char (*), ptr, ptr, fixed bin (35)); dcl code fixed bin (35); /* Error code */ dcl i fixed bin; /* Loop variable */ dcl local_area area; /* For call to mode_string_$parse */ dcl 1 mode_defined, /* The corresponding bit is set if the mode string contains the mode */ 2 protection bit (1), 2 rollback bit (1), 2 concurrency bit (1); /* Include file */ %include mode_string_info; /* Procedure */ if mode_string = "" /* No string given so there's nothing to do */ then return; unspec (mode_defined) = "0"b; call mode_string_$parse (mode_string, addr (local_area), mode_string_info_ptr, code); if code ^= 0 then call error (code, "While trying to parse the mode string."); if mode_string_info.version ^= mode_string_info_version_2 then call error (error_table_$unimplemented_version, "The mode_string_info structure is not version two."); if mode_string_info.modes (1).version ^= mode_value_version_3 then call error (error_table_$unimplemented_version, "The mode_value structure is not version three."); /* Now walk through the returned structure and examine the modes */ do i = 1 to mode_string_info.number; if mode_string_info.modes (i).mode_name = "protection" then do; if ^mode_string_info.modes (i).flags.boolean_valuep then call error (error_table_$bad_mode_value, "Protect must be a boolean mode value."); mode_defined.protection = "1"b; mode_bits.protection_on = mode_string_info.modes (i).flags.boolean_value; end; else if mode_string_info.modes (i).mode_name = "rollback" then do; if ^mode_string_info.modes (i).flags.boolean_valuep then call error (error_table_$bad_mode_value, "rollback must be a boolean mode value."); mode_defined.rollback = "1"b; mode_bits.rollback_on = mode_string_info.modes (i).flags.boolean_value; end; else if mode_string_info.modes (i).mode_name = "concurrency" then do; if ^mode_string_info.modes (i).flags.boolean_valuep then call error (error_table_$bad_mode_value, "Concurrency must be a boolean mode value."); mode_defined.concurrency = "1"b; mode_bits.concurrency_on = mode_string_info.modes (i).flags.boolean_value; end; else call error (error_table_$undefined_mode, mode_string_info.modes (i).mode_name); end; /* * * Check the file attributes for consistency. Neither concurrency or * before journalling can be specified unless the file is protected. * It is valid however, to specify ^protection and not specify either * rollback or concurrency. In that case, the latter two modes * will default to off. * */ if mode_bits.dm_file_type /* All bits are zero for vfile */ then if mode_defined.protection & ^mode_bits.protection_on then do; /* Force undefined bits to off */ if ^mode_defined.concurrency then mode_bits.concurrency_on = "0"b; if ^mode_defined.rollback then mode_bits.rollback_on = "0"b; end; if mode_bits.rollback_on & ^mode_bits.protection_on then call error (error_table_$bad_mode_value, "Rollback cannot be specified without protection."); if mode_bits.concurrency_on & ^mode_bits.protection_on then call error (error_table_$bad_mode_value, "Concurrency cannot be specified without protection."); end set_modes; %page; error: proc (cd, msg); dcl cd fixed bin (35); dcl msg char (*); /* Detailed error message (may be null) */ if entry_name = "cmdb" then do; call com_err_ (cd, entry_name, msg); fatal_sw = ON; /* Indicate that an error occured */ end; else do; sm_err_code = cd; sm_err_msg = msg; end; goto exit; end error; %page; is_ctl_option: proc (iarg) returns (bit (1)); /* This procedure checks the supplied argument to see if it is a control arg */ dcl iarg char (*); /* (INPUT) Input argument */ if length (iarg) < 1 then return ("0"b); else return (substr (iarg, 1, 1) = "-"); end is_ctl_option; %page; get_source: proc (source, en); /* This procedure given a source segment path sets the source directory path and entry in arg_info with the proper suffix if not supplied. */ dcl source char (*); /* (INPUT) source segment name */ dcl en char (*); /* (INPUT) entry name (rmdb or cmdb) */ if is_ctl_option (arg) then /* Did not give a source path */ call error (mrds_error_$bad_source_path, arg || " First argument must be a source pathname."); call expand_pathname_$add_suffix (source, en, arg_info.source_dir, arg_info.source_entry, code); if code ^= 0 then call error (code, source); end get_source; %page; init_arg_info: proc; arg_info.list = OFF; arg_info.twd = OFF; arg_info.secure = OFF; arg_info.force = OFF; arg_info.source_dir = BLANK; arg_info.source_entry = BLANK; arg_info.db_dir_path = BLANK; arg_info.temp_work_dir = get_pdir_ (); ; /* This will be changed if a twd arg is supplied */ arg_info.relation_mode_flags = default_relation_mode_flags; end init_arg_info; %page; /********** * * Entry point for parsing a dm_file mode string. * ***********/ parse_mode_string: entry (external_mode_string, external_mode_bits, sm_err_code, sm_err_msg); /* Parameters */ dcl external_mode_string char (*) parm; dcl 1 external_mode_bits like db_relation_modes; dcl sm_err_code fixed bin (35); dcl sm_err_msg char (*); sm_err_code = 0; sm_err_msg = ""; call set_modes (external_mode_string, external_mode_bits); return; %page; /* PARAMETERS */ dcl arg_list_ptr ptr; /* (INPUT) */ /* ai_ptr ptr; /* (INPUT) */ dcl 1 default_relation_mode_flags /* (INPUT) */ like db_relation_modes; dcl fatal_sw bit (1); /* (OUTPUT) */ /* OTHERS */ dcl arg char (arg_len) based (arg_ptr); dcl arg_len fixed bin (21); dcl arg_ptr ptr; dcl code fixed bin (35); dcl dm_file_mode_string char (200); dcl entry_name char (4); dcl opt_ok bit (1); dcl rel_db_path char (168); /* Relative database path */ dcl nargs fixed bin; dcl i fixed bin; dcl (addr, before, char, empty, length, ltrim, substr, unspec) builtin; /* SUBROUTINES */ dcl absolute_pathname_ entry (char (*), char (*), fixed bin (35)); declare absolute_pathname_$add_suffix entry (char (*), char (*), char (*), fixed bin (35)); /* appends suffix to path */ declare db_suffix char (3) init ("db") int static options (constant); /* MR7.0 database directory pathname suffic */ declare suffix_flag bit (1); /* on => use ".db" suffix in database path */ declare error_table_$wrong_no_of_args fixed bin (35) ext; /* incorrect args count */ dcl cu_$arg_count_rel entry (fixed bin, ptr); dcl cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr); dcl com_err_ entry options (variable); dcl expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl get_pdir_ entry returns (char (168)); /* CONSTANTS */ 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); /* ERROR CODES */ dcl error_table_$bad_arg ext fixed bin (35); dcl error_table_$badopt ext fixed bin (35); dcl error_table_$noarg fixed bin (35) ext static; dcl error_table_$bigarg fixed bin (35) ext static; dcl mrds_error_$bad_source_path ext fixed bin (35); dcl mrds_error_$no_temp_dir ext fixed bin (35); %page; %include mrds_rst_arg_info; end mrds_rst_proc_ctl_args;  mrds_rst_relation_handler.pl1 04/18/85 1454.7r w 04/18/85 0909.2 107433 /* *********************************************************** * * * * * 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_relation_handler: procedure (rsc_ptr, list_ptr); /* DESCRIPTION: this routine builds/alters the mrds database model relation information and the global entity lists maintained by RMDB/CMDB, based upon the relation 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 relation name to be deleted or a linked list of structures holding the relation information and it's attribute list */ /* PARAMETERS: rsc_ptr - - (input) pointer to the common control segment list_ptr - - (input) pointer to the single relation name(undefine only) or to the relation structure headed list of attribute structures database model - - (output) updated model with altered relation 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 */ %page; /* REMAINING ERRORS: undefine: the relation name may be the (this may be ignored) the relation may not be defined in the database define, cmdb: the relation name may be the (this may be ignored) one of the attribute names may be the (this may be ignored) the relation may already be defined in the database one of the given attributes may not be defined as part of the given relation the max_tuples will not be their final value until the file type is known for this relation redefine: same as define, except relation name may not be defined in the database note: "(this may be ignored)" means a previous error will prevent a database model with erroneous information from being built */ %page; /* 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 directive */ delete_name_ptr = list_ptr; relation_name = delete_name.overlay; end; else do; relation_ptr = list_ptr; relation_name = relation.name; end; /* call trace if metering is on */ if ^rsc.trace_sw then ; else call mrds_rst_meter (rsc_ptr, "mrds_rst_relation_handler", IN, relation_name); /* check on which directive called us */ if directive.type = UNDEFINE | directive.type = REDEFINE then do; if stmt (directive.type).relation.number > 0 then ; /* not first time */ else do; /* first time only, issue error */ call ioa_$rs ("^a ^a", message, message_length, "The relation 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 relation */ call define_relation (); end; /* call the trace routine if metering is turned on */ if ^rsc.trace_sw then ; else call mrds_rst_meter (rsc_ptr, "mrds_rst_relation_handler", OUT, relation_name); %page; define_relation: procedure (); /* using a previously unknown relation name, add this relation definition to the global lists for later use in building the new definition into the database model via the file handler */ /* make sure the relation is not already in the database or previously defined */ call mrds_rst_list_element$add (relation.name, MAIN_LIST, rsc_ptr, rsc.h_grel_ptr, gl_ptr, error_code); if error_code = 0 then error_mode = OFF; else do; call ioa_$rs ("^a^a^a ^d ^a", message, message_length, "The relation """, relation.name, """ given on line", relation.line_num, "is already defined in the database, the duplicate will be ignored!!"); call mrds_rst_error (rsc_ptr, 2 /* severity */, mrds_error_$dup_rel, (message)); call mrds_rst_rsc_alloc (rsc_ptr, GL, gl_ptr); /* make dummy global element not in list */ error_mode = ON; end; /* relation 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 = relation.name; gl.item_info_ptr = null (); /* no relation_info yet */ gl.parse_info_ptr = relation_ptr; gl.other_info_ptr = null (); /* gile global element not known yet */ gl.item_sub_list_ptr = null (); /* no attributes yet */ gl.file_info_ptr = null (); /* no file defined to hold relation 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 for this relation yet */ gl.inferior_assigned = OFF; /* no attributes for this relation yet */ gl.complete = OFF; /* no rel_info yet */ gl.consistant = ON; /* assume good till find error */ gl.reserved = OFF; /* process the list of attributes for this relation */ attribute_ptr = relation.a_ptr; do while (attribute_ptr ^= null ()); call define_relation_attribute (); attribute_ptr = attribute.next; end; if gl.inferior_assigned then ; else gl.consistant = OFF; /* no good attribute's in relation */ end; %page; define_relation_attribute: procedure (); /* make sure that the given attribute is defined in the database */ call mrds_rst_tree_search (attribute.name, rsc.h_gattr_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 attribute """, attribute.name, """ on line", attribute.line_num, "given for relation """, relation.name, """ has not been defined in the database."); call mrds_rst_error (rsc_ptr, 2 /* severity */, mrds_error_$undef_attr, (message)); end; else if error_mode then ; /* previous error => relation not found, so don't add sublists */ else do; attr_gl_ptr = node_ptr -> node.data; /* get attribute global element pointer */ if attr_gl_ptr -> gl.item_info_ptr = null () then ; /* check for assigned domain for this attribute */ else if attr_gl_ptr -> gl.item_info_ptr -> sl.new_other_info_ptr = null () then ; else do; /* get attr's domain global element pointer */ dom_gl_ptr = attr_gl_ptr -> gl.item_info_ptr -> sl.new_other_info_ptr; dom_gl_ptr -> gl.superior_assigned = ON; /* now domain referenced by relation */ end; /* ATTRIBUTE SUBLIST INSERT */ /* attribute found, add this relation to it's "used in relation" sublist */ call mrds_rst_list_element$add (relation.name, SUB_LIST, rsc_ptr, attr_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_relation_handler, the relation """, relation.name, """ was found the sublist of attribute """, attribute.name, """ but wasn't found in the global relation 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 = relation.name; sl.item_info_ptr = null (); /* no relation_info yet */ sl.parse_info_ptr = relation_ptr; sl.old_other_info_ptr = null (); /* no attr info yet */ sl.new_other_info_ptr = attr_gl_ptr; sl.global_list_ptr = gl_ptr; sl.reserved = OFF; attr_gl_ptr -> gl.superior_assigned = ON; /* relation present for this attribute */ end; /* RELATION SUBLIST INSERT */ /* add this attribute to the relation's attribute sublist */ call mrds_rst_list_element$add (attribute.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_relation_handler, a duplicate attribute """, attribute.name, """ was found in relation """, relation.name, """."); call mrds_rst_error (rsc_ptr, 4 /* severity */, error_code, (message)); end; else do; /* fill in the sublist element */ sl.type = SUB_LIST; sl.name = attribute.name; sl.item_info_ptr = attr_gl_ptr -> gl.item_info_ptr; /* attribute info pointer */ sl.parse_info_ptr = attribute_ptr; /* attr parse structure */ sl.old_other_info_ptr = attr_gl_ptr -> gl.other_info_ptr; /* domain info ptr */ sl.new_other_info_ptr = attr_gl_ptr -> gl.other_info_ptr; /* domain info ptr */ sl.global_list_ptr = attr_gl_ptr; sl.reserved = OFF; gl.inferior_assigned = ON; /* attribute(s) present */ end; end; end; %page; dcl error_mode bit (1); /* ON => error occurred, special handling in progress */ dcl relation_name char (32); /* relation name for this call */ dcl sys_info$max_seg_size fixed bin (35) external; /* system constant */ dcl (fixed, rel, addr, null) builtin; /* functions known to pl1 */ 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 error_code fixed binary (35); /* mrds_error_ table index */ dcl message char (256) varying;/* specifics of error message */ dcl message_length fixed bin (21); /* length of specifics message */ dcl mrds_error_$rst_undone_option fixed bin (35) external; /* option not coded yet */ dcl mrds_error_$undef_attr fixed bin (35) external; /* item not in database */ dcl mrds_error_$dup_rel fixed bin (35) external; /* duplicate attr definition */ dcl mrds_rst_rsc_alloc entry (ptr, fixed bin, ptr); /* working area manager */ dcl mrds_rst_tree_search entry (char (32) aligned, ptr, ptr, ptr, bit (1)); /* list searcher */ dcl mrds_rst_error entry (ptr, fixed bin, fixed bin (35), char (*)); /* general error handler */ dcl 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 list_ptr ptr; /* pointer to parse info list */ dcl IN bit (1) internal static options (constant) init ("1"b); /* input meter flag */ dcl OUT bit (1) internal static options (constant) init ("0"b); /* output meter flag */ dcl mrds_rst_meter entry (ptr, char (*), bit (1), char (*)); /* metering/tracing routine */ dcl attr_gl_ptr ptr; /* temp storage for attribute global element pointer */ dcl dom_gl_ptr ptr; /* pointer to attribute's domain global list element */ %page; %include mrds_rst_rsc; %page; %include mrds_rst_struct_types; %page; %include mrds_rst_semantics; %page; %include mrds_rst_parse_info; %page; %include mrds_rst_tree; %page; %include mrds_rst_global_lists; end;  mrds_rst_rsc_alloc.pl1 10/16/86 1551.9r w 10/16/86 1144.0 112230 /* *********************************************************** * * * * * 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 - - February 1979 82-06-28 Roger Lackey: Removed code for struct type 52 thru 58 chnaged the way type 25 was handled since no longer used. */ mrds_rst_rsc_alloc: procedure (rsc_ptr, struct_type, struct_ptr); /* . BEGIN_DESCRIPTION this routine does all allocations in working storage known as "rsc" for restructure control. modules that create, modify, or display the mrds database model all use this working storage, which is structured as a directory with a common segment, and several segments acting as extensible areas. allocations are made in the segments according to type of structure and the policy as defined by the logic of this module. two additional entries are $variable, and $free for variable length allocations, and freeing of previously allocated space. . END_DESCRIPTION */ /* PARAMETERS: normal entry === rsc_ptr - - (input) pointer to the common segment under the working storage directory created under the user specified directory struct_type - - (input) fixed binary number that indicates which structure is to be allocated, and according to the internal policy, where it will be allocated as well. the include file mrds_rst_struct_types.incl.pl1 gives the constants that are used for this purpose. struct_ptr - - (output) pointer to the newly allocated structure of the type given by struct_type. $variable entry === struct_size - - (input) a fixed binary (35) number, in addition to those above, that gives the length for the current allocation of this structure type that has a variable length. $free entry === same as the normal entry, except struct_ptr is an input parameter, and it points to the allocation instance to be freed */ %page; /* normal allocation entry point */ FREE = OFF; goto common; /* freeing entry point */ mrds_rst_rsc_alloc$free: entry (rsc_ptr, struct_type, struct_ptr); FREE = ON; /* determine if we are freeing a variable length allocation */ if struct_type <= hbound (case, 1) then goto common; else goto var_common; common: if ^rsc.trace_sw then ; else call trace (ON); /* input call */ %page; /* check that the encoding for structure type is within the legal range */ if struct_type < lbound (case, 1) | struct_type > hbound (case, 1) then call bad_struct_code (); else do; /* good structure type code, go to the allocate that it indicates for the given structure to be allocated, and the area in which it will reside */ goto case (struct_type); /* parse info structures */ case (1): if FREE then free struct_ptr -> domain in (parse_info_area); else allocate domain set (struct_ptr) in (parse_info_area); goto return_label; case (2): if FREE then free struct_ptr -> attribute_domain in (parse_info_area); else allocate attribute_domain set (struct_ptr) in (parse_info_area); goto return_label; case (3): if FREE then free struct_ptr -> relation in (parse_info_area); else allocate relation set (struct_ptr) in (parse_info_area); goto return_label; case (4): if FREE then free struct_ptr -> attribute in (parse_info_area); else allocate attribute set (struct_ptr) in (parse_info_area); goto return_label; case (5): if FREE then free struct_ptr -> file in (parse_info_area); else allocate file set (struct_ptr) in (parse_info_area); goto return_label; case (6): if FREE then free struct_ptr -> item in (parse_info_area); else allocate item set (struct_ptr) in (parse_info_area); goto return_label; case (7): if FREE then free struct_ptr -> link in (parse_info_area); else allocate link set (struct_ptr) in (parse_info_area); goto return_label; case (8): if FREE then free struct_ptr -> foreign_key in (parse_info_area); else allocate foreign_key set (struct_ptr) in (parse_info_area); goto return_label; case (9): if FREE then free struct_ptr -> children in (parse_info_area); else allocate children set (struct_ptr) in (parse_info_area); goto return_label; case (10): if FREE then free struct_ptr -> rel_index in (parse_info_area); else allocate rel_index set (struct_ptr) in (parse_info_area); goto return_label; case (11): if FREE then free struct_ptr -> delete_name in (parse_info_area); else allocate delete_name set (struct_ptr) in (parse_info_area); goto return_label; case (12): if FREE then free struct_ptr -> dom_list in (parse_info_area); else allocate dom_list set (struct_ptr) in (parse_info_area); goto return_label; %page; /* semantic structures */ case (13): if FREE then free struct_ptr -> directive in (static_info_area); else allocate directive set (struct_ptr) in (static_info_area); goto return_label; case (14): if FREE then free struct_ptr -> stmt in (static_info_area); else allocate stmt set (struct_ptr) in (static_info_area); goto return_label; /* parsing structures */ case (15): if FREE then free struct_ptr -> lex_stack in (static_info_area); else allocate lex_stack set (struct_ptr) in (static_info_area); goto return_label; case (16): if FREE then free struct_ptr -> p_struct in (static_info_area); else allocate p_struct set (struct_ptr) in (static_info_area); goto return_label; case (17): if FREE then free struct_ptr -> cur_lex_top in (static_info_area); else allocate cur_lex_top set (struct_ptr) in (static_info_area); goto return_label; case (18): if FREE then free struct_ptr -> token in (static_info_area); else allocate token set (struct_ptr) in (static_info_area); goto return_label; case (19): if FREE then free struct_ptr -> output_text in (static_info_area); else allocate output_text set (struct_ptr) in (static_info_area); goto return_label; %page; /* global list structures */ case (20): if FREE then free struct_ptr -> gl in (global_list_area); else allocate gl set (struct_ptr) in (global_list_area); goto return_label; case (21): if FREE then free struct_ptr -> sl in (sublist_area); else allocate sl set (struct_ptr) in (sublist_area); goto return_label; case (22): if FREE then free struct_ptr -> seg_info in (seg_info_area); else allocate seg_info set (struct_ptr) in (seg_info_area); goto return_label; case (23): if FREE then free struct_ptr -> node in (tree_node_area); else allocate node set (struct_ptr) in (tree_node_area); goto return_label; %page; /* other structures */ case (24): if FREE then free struct_ptr -> saved_child_count in (other_area); else allocate saved_child_count set (struct_ptr) in (other_area); goto return_label; case (25): if FREE then call bad_struct_code (); /* No longer implemented */ else call bad_struct_code (); /* No longer implemented */ goto return_label; end; %page; mrds_rst_rsc_alloc$variable: entry (rsc_ptr, struct_type, struct_size, struct_ptr); /* entry to handle structures whose length is variable */ FREE = OFF; var_common: if ^rsc.trace_sw then ; else call trace (ON); /* input call */ if struct_type < lbound (var_case, 1) | struct_type > hbound (var_case, 1) then call bad_struct_code (); else if struct_size < 1 then call bad_struct_size (); /* good encoding and size given, go allocate the given structure with the specified size, and place it according to area policy */ else do; goto var_case (struct_type); var_case (50): if FREE then free struct_ptr -> fixup_token in (variable_length_area); else do; token_length = struct_size; allocate fixup_token set (struct_ptr) in (variable_length_area); end; goto return_label; var_case (51): if FREE then free struct_ptr -> string_source in (variable_length_area); else do; source_size = struct_size; allocate string_source set (struct_ptr) in (variable_length_area); end; goto return_label; end; %page; return_label: if ^rsc.trace_sw then ; else call trace (OFF); /* output call */ return; %page; bad_struct_code: procedure (); /* report bad structure type encoding error */ call ioa_$rs ("^a ^d ^a", message, message_length, "LOGIC ERROR in mrds_rst_rsc_alloc,", struct_type, "is an invalid code for structure type."); call mrds_rst_error (rsc_ptr, 4 /* severity */, mrds_error_$rst_logic_error, (message)); end; %page; bad_struct_size: procedure (); /* report bad structure allocation size */ call ioa_$rs ("^a ^d ^a", message, message_length, "LOGIC ERROR in mrds_rst_rsc_alloc,", struct_size, "is an illegal structure allocation size."); call mrds_rst_error (rsc_ptr, 4 /* severity */, mrds_error_$rst_logic_error, (message)); end; %page; trace: procedure (in_out); /* common call to the metering routine */ struct_type_picture = struct_type; call mrds_rst_meter (rsc_ptr, "mrds_rst_rsc_alloc", in_out, (struct_type_picture)); dcl in_out bit (1); /* on => input, off => output call */ dcl struct_type_picture picture "99"; /* for integer to char conversion */ end; %page; dcl mrds_rst_meter entry (ptr, char (*), bit (1), char (*)); /* trace routine */ dcl parse_info_area area based (rsc.parse_info_area_ptr); /* location for parsing structures */ dcl seg_info_area area based (rsc.tree_data.seg_info_area_ptr); /* segment list location */ dcl global_list_area area based (rsc.tree_data.gl_area_ptr); /* global element location */ dcl sublist_area area based (rsc.tree_data.sl_area_ptr); /* sub list element location */ dcl tree_node_area area based (rsc.tree_node_area_ptr); /* location of tree head portion */ dcl static_info_area area based (rsc.static_info_area_ptr); /* static type info location */ dcl variable_length_area area based (rsc.variable_length_area_ptr); /* location for variable length allocations */ dcl other_area area based (rsc.other_area_ptr); /* all other information */ dcl struct_type fixed bin; /* number corresponding to structure to be allocated */ dcl struct_size fixed bin (35); /* number of words to allocate for varying types */ dcl struct_ptr ptr; /* pointer to allocated structure */ dcl mrds_rst_error entry (ptr, fixed bin, fixed bin (35), char (*)); /* general error routine */ dcl ioa_$rs entry options (variable); /* string manipulator routine */ dcl FREE bit (1); /* on => free structure, off => allocate */ dcl ON bit (1) internal static options (constant) init ("1"b); /* true value */ dcl OFF bit (1) internal static options (constant) init ("0"b); /* false value */ dcl mrds_error_$rst_logic_error fixed bin (35) external; /* bad program */ dcl message char (96) varying; /* returned formatted specifics of error */ dcl message_length fixed bin (21); /* length of returned message */ dcl sys_info$max_seg_size fixed bin (35) external; /* max system segment length */ dcl (addr, lbound, hbound, rel, fixed) builtin; %page; %include mrds_rst_struct_types; %page; %include mrds_rst_tree; %page; %include mrds_rst_rsc; %page; %include mrds_rst_global_lists; %page; %include mrds_rst_parse_info; %page; %include mrds_dm_display_info; %page; %include mrds_rst_semantics; %page; %include mrds_rst_scan; %page; %include mrds_rst_parse_stack; %page; %include mdbm_db_model; end;  mrds_rst_scanner.pl1 04/18/85 1454.7r w 04/18/85 0909.3 240903 /* *********************************************************** * * * * * 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 - - july 1978 Modified by Jim Gray - - 80-11-07, to have identifier_handler get legal characters from a mrds_data_ item in common with the rest of mrds (this removed "." as a legal character) 80-12-15 Jim Gray : added check for last token being "-" ahead of edit proc keywords, as part of un-reserving keywords in CMDB. 81-06-04 Jim Gray : removed token types no longer acepted by mrds_rst_semantics, such as constants for the -check option which was never implemented. 81-07-29 Jim Gray : added correct handling of a "/" by itself in the source. 83-10-01 Roger Lackey : Modified to correct multi-line comment sometimes not putting all of comment in listing. (TR phx15198) */ mrds_rst_scanner: procedure (lex_stack_ptr, stack_index); %page; /* DESCRIPTION: lexical analyzer or scanner for returning tokens from the restructuring source to the parser. a token may be an identifier, keyword, number, special character or end of file. an integer encoding value is also returned for use by the parser in identifying the token and pointers to the token in the source, and the start of the current line are returned as well as the line number and length of the token. A line numbered version of the original source can be produced. comments and white space are skipped over, and any invalid characters are detected.. there are two entries: init entry - should be called first for initialization normal entry - for returning tokens from the source */ /* PARAMETERS: === normal entry === lex_stack_ptr - - (input) pointer to the lexical stack stack_index - - (input) stack element which is hold the returned token, etc. lex_stack - - (output) the specified element contains the token pointer, length, encoding, and line number and line start pointer (output) for the line numbered listing goes to "source_segment".list === init entry === err_ptr - - (input) pointer to retructure control segment source_seg_ptr - - (input) pointer to the restructuring directives source segment source_length - - (input) length in characters of the source segment */ %page; /* normal entry */ goto state (START); /* initialization entry */ mrds_rst_scanner$init: entry (err_ptr, source_seg_ptr, source_length); /* get restructure conrol pointer, set up line number and pointer, make first character and it's type available */ static_rsc_ptr = err_ptr; call mrds_rst_rsc_alloc (static_rsc_ptr, TOKEN, accum_token_ptr); call mrds_rst_rsc_alloc (static_rsc_ptr, OUTPUT_TEXT, output_text_ptr); call get_next_char_init (source_seg_ptr, source_length, char_ptr, char_type, char); call keyword_lookup ("check_proc", CHECK_PROC); call keyword_lookup ("encode_proc", ENCODE_PROC); call keyword_lookup ("decode_proc", DECODE_PROC); return; /* START */ state (0): /* using the type code for the current character, go to the appropiate state for that class of tokens, the parser having initialized the current character before the first call, and scanner obtaining the next character to be used when called again before returning to the parser */ token = ""; token_length = 0; fixed_value = 0; float_value = 0.0; symbol_found = "0"b; token_too_long_seen = "0"b; /* continue on next page loop from start state to the recognition states, while a token is not found, and end of source is not detected */ %page; do while (^symbol_found); goto state (char_type); /* LETTER */ state (1): /* letter found, accumulate characters that are letters, numbers, underscores, hyphens into an identifier token then make checks for keywords and pathnames that may follow to provide correct parser and scanner encoding */ call identifier_handler (); call stack_put (); symbol_found = "1"b; goto state (CASE_END); /* DIGIT */ state (2): /* digit found, accumulate digits, into a number and convert from ascii to binary */ if ^number_convert () then ; else do; call stack_put (); symbol_found = "1"b; end; goto state (CASE_END); /* SPECIAL */ state (3): /* special character found, if slash, check for comment else return encoding for the character */ if comment_skip () then ; else do; /* not a comment, single character special instead, get it's encoding */ call encode_special (); call stack_put (); symbol_found = "1"b; end; goto state (CASE_END); /* A_PATH_ENTRY */ state (4): /* start of a pathname or entry name detected */ call path_entry_handler (); call stack_put (); symbol_found = "1"b; goto state (CASE_END); /* NL */ state (5): /* new line detected */ call get_next_char_new_line (char_ptr, char_type, char); symbol_found = "0"b; goto state (CASE_END); /* WHITE_SPACE */ state (6): /* white space detected, skip over it */ call get_next_char_non_white (char_ptr, char_type, char); symbol_found = "0"b; goto state (CASE_END); /* ILLEGAL */ state (7): /* illegal character detected */ call ioa_$rs ("^a^a^a ^d ^a ^d^a", message, message_length, "Character """, char, """, before token number", token_count + 1, "on line", line_number, "."); call mrds_rst_error (static_rsc_ptr, 1 /* severity */, mrds_error_$rst_illegal_char, (message)); call get_next_char (char_ptr, char_type, char); symbol_found = "0"b; goto state (CASE_END); /* EOF */ state (8): /* end of input detected */ encoding = EOI; token_ptr = char_ptr; call stack_put (); symbol_found = "1"b; goto state (CASE_END); /* CASE_END */ state (9): end; return; %page; stack_put: procedure (); /* increment the number of tokens seen in this line */ token_count = token_count + 1; /* routine to put the token info into the stack */ lex_stack (stack_index).symptr = token_ptr; lex_stack (stack_index).symlen = token_length; lex_stack (stack_index).line = line_number; lex_stack (stack_index).symbol = encoding; lex_stack (stack_index).val = fixed_value; lex_stack (stack_index).float = float_value; lex_stack (stack_index).line_strt = line_ptr; lex_stack (stack_index).line_size = line_length; lex_stack (stack_index).token_num = token_count; previous_token_type = encoding; end; %page; identifier_handler: procedure (); /* routine to assemble identifiers, make keyword encodings, and set up for path names to follow certain keywords */ token_ptr = char_ptr; do while (index (mrds_data_$valid_id_chars, char) ^= 0); call add_char_to_token (); call get_next_char (char_ptr, char_type, char); end; /* find out if this is a keyword */ call keyword_lookup (token, encoding); if encoding ^= 0 then ; else encoding = IDENTIFIER; /* if this was a path name keyword, check for absolute pathname following(i.e. ">" next), and set up char_type to get the pathname on the next call to scanner */ if encoding = CHECK_PROC | encoding = ENCODE_PROC | encoding = DECODE_PROC then do; /* do double check that the previous token was a "-", else we don't really have an edit procedure keyword */ if previous_token_type ^= index (SPECIAL_LIST, "-") then encoding = IDENTIFIER; /* not a real keyword */ else do; /* get next good character after keyword, it should be ">" */ temp_line_number = line_number; good_char = "0"b; do while (^good_char); if char_type ^= WHITE_SPACE & char_type ^= NL then good_char = "1"b; else if char_type = WHITE_SPACE then call get_next_char_non_white (char_ptr, char_type, char); else if char_type = NL then call get_next_char_new_line (char_ptr, char_type, char); end; if char = ">" then char_type = A_PATH_ENTRY; else do; call ioa_$rs ("^a ^d^a ^d^a", message, message_length, "Absolute pathname missing or not starting with "">"" after token", token_count + 1, ", a procedure path keyword in line", temp_line_number, "."); call mrds_rst_error (static_rsc_ptr, 2 /* severity */, mrds_error_$rst_missing_pathname, (message)); end; end; end; end; %page; add_char_to_token: procedure (); /* if max token size not exceeded, append current character to the accumulating token variable, else truncate it at the max size */ on stringsize /* capture max size exceeded */ begin; /* issue error message on first occurence only */ if token_too_long_seen then ; else do; token_too_long_seen = "1"b; call ioa_$rs ("^a ^d ^a ^d ^a", message, message_length, "A token on line", line_number, "exceeds the maximum string size of", mrds_data_$max_string_size, "characters, it is being truncated at that length."); call mrds_rst_error (static_rsc_ptr, 2 /* severity */, mrds_error_$rst_token_too_long, (message)); end; goto truncate_token; end; /* normal action appends character to token */ (stringsize): token = token || char; token_length = token_length + 1; truncate_token: end; %page; number_convert: procedure () returns (bit (1)); /* routine to accumulate extent of number in ascii, and convert it to the appropriate internal form and give it the required parser encoding */ fixup_done = "0"b; token_ptr = char_ptr; /* accumulate positive integer numbers as the token */ mantissa_end = "0"b; radix_found = "0"b; do while (^mantissa_end); do while (char_type = DIGIT); call add_char_to_token (); call get_next_char (char_ptr, char_type, char); end; mantissa_end = "1"b; end; /* good number found, check for possible exponent */ number_found = "1"b; /* number processed, assign the appropiate encoding value for the parser */ encoding = INTEGER; /* get the binary equivalent for this number, if semantics has not shut off converting */ if static_rsc_ptr -> rsc.skip_scanner_conversion then ; else call binary_conversion (); /* return success for good number, failure for illegal character "." by itself, and use corrected token rather than source */ if ^fixup_done then ; else call substitute_fixup_token (); return (number_found); %page; binary_conversion: procedure (); /* routine to do ascii to binary conversion of numbers */ /* use the large number fixup on conversion overflow */ on size call fixup_conversion; on fixedoverflow call fixup_conversion; on overflow call fixup_conversion; on underflow call fixup_conversion; on conversion call fixup_conversion; /* convert the accumulated ascii token to binary */ fixed_value = fixed (binary (token)); /* conversion error fixup return */ SKIP_CONVERT: return; fixup_conversion: procedure (); /* use the largest number in place of the one that is too big */ fixup_done = "1"b; temp_token = copy ("1", 71) || "b"; fixed_value = fixed (binary (temp_token)); call ioa_$rs ("^a ^a ^a ^d ^a ^d ", message, message_length, "The number", token, "in line", line_number, "is too large, using value", fixed_value); token = temp_token; call mrds_rst_error (static_rsc_ptr, 2 /* severity */, mrds_error_$rst_conversion_error, (message)); goto SKIP_CONVERT; end; end; end; %page; substitute_fixup_token: procedure (); /* save the fixup version of the token, and point to it rather than the source */ token_length = length (token); call mrds_rst_rsc_alloc$variable (static_rsc_ptr, FIXUP_TOKEN, (token_length), token_ptr); token_ptr -> fixup_token = token; end; %page; comment_skip: procedure () returns (bit (1)); /* check for presence of a comment, return failure if not found */ token_ptr = char_ptr; token = char; call get_next_char (char_ptr, char_type, char); if (token = "/" & char ^= "*") | (token ^= "/") then do; if token ^= "/" then result = "0"b; else do; result = "1"b; /* skip over illegal character */ call ioa_$rs ("^a^a^a ^d ^a ^d^a", message, message_length, "Character """, token, """, before token number", token_count + 1, "on line", line_number, "."); call mrds_rst_error (static_rsc_ptr, 1 /* severity */, mrds_error_$rst_illegal_char, (message)); end; end; else do; /* routine to bypass comments in the source */ comment_end = "0"b; char = " "; do while (^comment_end); do while (char ^= "*" & char_type ^= EOF); if char_type ^= NL then call get_next_char_non_white (char_ptr, char_type, char); if char_type = NL then call get_next_char_new_line (char_ptr, char_type, char); end; if char_type = EOF then comment_end = "1"b; else do; call get_next_char (char_ptr, char_type, char); if char ^= "/" & char_type ^= EOF then ; else comment_end = "1"b; if char_type ^= NL then ; else call get_next_char_new_line (char_ptr, char_type, char); end; end; /* check for comment error */ if char_type ^= EOF then ; else do; call ioa_$rs ("^a ^d^a", message, message_length, "Comment ends line number", line_number, "."); call mrds_rst_error (static_rsc_ptr, 2 /* severity */, mrds_error_$rst_comment_ends_source, (message)); end; token = ""; call get_next_char_non_white (char_ptr, char_type, char); symbol_found = "0"b; result = "1"b; end; return (result); end; %page; encode_special: procedure (); /* routine to produce the parser encoding of the special character just found */ token_length = 1; special_index = index (SPECIAL_LIST, token); if special_index ^= 0 then encoding = CODE (special_index); else do; encoding = EOI; call ioa_$rs ("^a ^a ^a ^d^a", message, message_length, "Special character", token, "in line", line_number, "."); call mrds_rst_error (static_rsc_ptr, 4 /* severity */, mrds_error_$rst_bad_encoding, (message)); end; end; %page; path_entry_handler: procedure (); /* routine to accumulate character strings representing either path names, or entry names into tokens and give them the proper parser encoding */ /* if path name detected by identifier handler, reset the ">" char_type to special */ if char ^= "$" then do; encoding = PATH_NAME; char_type = SPECIAL; end; /* else we have an entry name starting with "$", throw that character away */ else do; encoding = ENTRY_NAME; call get_next_char (char_ptr, char_type, char); end; /* get the length for and pointer to this path/entry name path names end in white space or "$", entry names end in white space a "," or ";" also ends them due to domain statement syntax */ token_ptr = char_ptr; do while (char_type ^= WHITE_SPACE & char_type ^= NL & char_type ^= A_PATH_ENTRY & char_type ^= EOF & char ^= "," & char ^= ";"); token_length = token_length + 1; call get_next_char (char_ptr, char_type, char); end; /* check for name ending source prematurely */ if char_type ^= EOF then ; else do; call ioa_$rs ("^a ^d^a ^d^a", message, message_length, "Pathname is token", token_count + 1, ", on line", line_number, "."); call mrds_rst_error (static_rsc_ptr, 2 /* severity */, mrds_error_$rst_pathname_ends_source, (message)); end; end; %page; get_next_character_routine: procedure (); /* dummy entry, not used */ /* This procedure has four entry points. get_next_char_init should be called first to set up things get_next_char_new_line is used to advance the current line, output it, and get the first char get_next_char_non_white skips white spaces until a valid character is found get_next_char$get_next_char returns only info about the next char in source */ /* INIT */ get_next_char_init: entry (s_seg_ptr, s_seg_len, chr_ptr, type, chr_val); /* This entry initializes internal stativ values */ seg_ptr = s_seg_ptr; /* Save source segment pointer and length */ seg_len = s_seg_len; /* in internal static variable */ pos = 1; /* Starting position is first character */ line_number = 0; /* NEW LINE */ get_next_char_new_line: entry (chr_ptr, type, chr_val); /* entry to advance to next line */ if pos > seg_len then ; else do; /* find end of next line */ line_ptr = addr (char_string (pos)); line_length = index (substr (line_ptr -> source, 1, seg_len - pos + 1), NL_CHAR); if line_length ^= 0 then ; /* next lines NL found */ else line_length = seg_len - pos + 1; /* segment doesn't end last line with NL */ line_number = line_number + 1; token_count = 0; if ^static_rsc_ptr -> rsc.listing_seg_sw then ; else do; /* listing switch on, output the current line */ line_no_pic = line_number; output_text = line_no_pic || " " || substr (line_ptr -> source, 1, line_length); call iox_$put_chars (static_rsc_ptr -> rsc.listing_iocb_ptr, addrel (addr (output_text), 1), length (output_text), code); if code = 0 then ; else do; call ioa_$rs ("^a ^d ^a", message, message_length, "Error in trying to output line number", line_number, "to listing segment rmdb.list"); call mrds_rst_error (static_rsc_ptr, 4 /* severity */, mrds_error_$rst_io_error, (message)); end; end; end; goto get_first_char; /* NEXT NON WHITE */ get_next_char_non_white: entry (chr_ptr, type, chr_val); /* This entry skips white space */ if pos <= seg_len then do; /* for positions less than segment length + 1 */ type = mrds_rst_translate (fixed (char_bits (pos), 9)); /* get character type */ do while (type = WHITE_SPACE & pos <= seg_len); /* Skip until type is not white space */ pos = pos + 1; /* Current position gets bumped */ type = mrds_rst_translate (fixed (char_bits (pos), 9)); /* Determine caracter type */ end; /* pos is the index of the next non-white-space character */ end; /* NEXT CHAR */ get_first_char: ; get_next_char: entry (chr_ptr, type, chr_val); /* return next character in source */ if pos <= seg_len then do; /* Not passed end of segment */ chr_val = char_string (pos); /* Get character */ type = mrds_rst_translate (fixed (char_bits (pos), 9)); /* Get character type from table */ chr_ptr = addr (char_string (pos)); /* Get pointer to caracter */ pos = pos + 1; /* Bump index to next char posiition */ end; else do; type = EOF; /* Position was beyond end of segment */ chr_val = " "; end; return; %page; /* PARAMETERS */ dcl s_seg_ptr ptr; /* (INPUT) Pointer to source segment */ dcl s_seg_len fixed bin (24); /* (INPUT) Length of source segment in chars */ dcl chr_val char (1); /* (OUTPUT) Current character */ dcl type fixed bin; /* (OUTPUT) Character type from map */ dcl chr_ptr ptr; /* (OUTPUT) Pointer to current character */ /* STATIC VARIABLES */ dcl pos fixed bin (24) internal static init (1); /* Index position in to character string */ dcl seg_ptr ptr int static init (null); /* Pointer to input segment (source segment) */ dcl seg_len fixed bin (24) int static init (0); /* Length of input segment (source) */ dcl NL_CHAR char (1) internal static init (" "); /* new line character */ /* OTHERS */ dcl addr builtin; /* BASED VARIABLES */ dcl char_string (seg_len) char (1) based (seg_ptr); /* Treat char string as char array */ dcl char_bits (seg_len) bit (9) unal based (seg_ptr); /* Treat char string as bit array */ %page; %include mrds_rst_translate; end get_next_character_routine; %page; keyword_lookup: procedure (token, encodement); /* routine to do binary search of keywords known to mrds restructuring against a supplied identifier and return an encoded value for the keyword if a match if found, else return zero */ /* initialize the starting range for the binary search as that of the whole array, and set the first probe point to its middle */ low = lbound (keyword, 1); high = hbound (keyword, 1); middle = (low + high) / 2; /* proceed to divide the range in half, searching the half remaining that contains the value range (in ascii sequence) of the supplied identifier */ do while (token ^= keyword.name (middle) & high > low); if token > keyword.name (middle) then low = middle + 1; else high = middle - 1; middle = (low + high) / 2; end; /* check to see if the search was successful */ if token = keyword.name (middle) then encodement = keyword.value (middle); else encodement = 0; %page; /* the following declaration that includes the encoding for keywords was generated by the keyword sorted list tool, for use with the terminal encoding as derived from use of the lrk tool on the mrds restructuring bnf - - see D. Ward's documentation */ %include mrds_rst_keywords; %page; dcl low fixed binary; /* current low search for part of array left to be searched */ dcl high fixed binary; /* current high search search */ dcl middle fixed binary; /* current probe point in array */ dcl (lbound, hbound) builtin; /* functions known to pl1 to get array bounds */ dcl token char (*) varying; /* identifier to be searched for as keyword */ dcl encodement fixed binary; /* encoding value to be given to found keyword */ end; %page; dcl stack_index fixed bin (24) aligned; /* place in lexical stack to put returned token */ dcl encoding fixed binary; /* integer value expected by parser to represent this token */ dcl token_too_long_seen bit (1); /* ON => previous error message issued */ dcl stringsize condition; /* target too small for string */ dcl good_char bit (1); /* on => character is not white space or new line char */ dcl mantissa_end bit (1); /* end of mantissa flag */ dcl radix_found bit (1); /* on => radix point found in mantissa */ dcl fixed_value fixed binary (71); /* converted binary value of a fixed number */ dcl float_value float binary (63); /* converted binary value of a float number */ dcl symbol_found bit (1); /* on => token has been found */ dcl comment_end bit (1); /* on => end of comment reached */ dcl mrds_rst_rsc_alloc$variable entry (ptr, fixed bin, fixed bin (35), ptr); /* working area alloc routine */ dcl mrds_rst_rsc_alloc entry (ptr, fixed bin, ptr); /* for non-variable allocations */ dcl ioa_$rs entry options (variable); /* string manipulation routine for error messages */ dcl message char (256) varying;/* error message with details */ dcl message_length fixed binary; /* length of error message */ dcl mrds_rst_error entry (ptr, fixed binary, fixed binary (35), char (*)); /* error handling routine */ dcl result bit (1); /* on => a comment was found and skipped */ dcl number_found bit (1); /* off => "." by itself skipped as illegal */ dcl token_ptr ptr; /* pointer to token start in source */ dcl (size, overflow, underflow, fixedoverflow, conversion) condition; /* trap for conversion overflow */ dcl mrds_error_$rst_token_too_long fixed bin (35) external; /* token exceed max string size */ dcl mrds_error_$rst_pathname_ends_source fixed binary (35) external; /* premature segment end by a name */ dcl mrds_error_$rst_missing_pathname fixed binary (35) external; /* expected pathname missing after keyword */ dcl mrds_error_$rst_conversion_error fixed binary (35) external; /* number convert onverflow error */ dcl mrds_error_$rst_io_error fixed binary (35) external; /* error during io attempt */ dcl mrds_error_$rst_comment_ends_source fixed binary (35) external; /* long comment error code */ dcl mrds_error_$rst_illegal_char fixed binary (35) external; /* bad char error code */ dcl mrds_error_$rst_bad_encoding fixed binary (35) external; /* bad integer code for special char */ dcl special_index fixed binary; /* index of special char encoding in the CODE array */ dcl index builtin; /* search function known to pl1 */ dcl source_seg_ptr ptr; /* pointer to restructuring directives source segment */ dcl err_ptr ptr; /* pointer to restructure control segment */ dcl source_length fixed binary (24); /* character length of source segment */ dcl sys_info$max_seg_size fixed binary (35) external; /* system constant for largest size segment */ dcl (fixed, rel, addr) builtin; /* functions known to pl1 */ dcl temp_line_number fixed binary (21); /* storage for error line number */ dcl line_no_pic picture "zzzzzz9"; /* number of output line, formatted */ dcl source char (sys_info$max_seg_size) based; /* overlay to extract source lines */ dcl fixup_done bit (1); /* on => change made to token to correct error */ dcl code fixed binary (35); /* error code from subroutine calls */ dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); /* listing io routine */ dcl (addrel, binary, copy, length, substr) builtin; dcl temp_token char (96) varying; /* temp storage for fixup value */ dcl ENCODE_PROC fixed binary internal static; /* encoding value for keyword encode_proc */ dcl DECODE_PROC fixed binary internal static; /* encoding value for keyword decode_proc */ dcl CHECK_PROC fixed binary internal static; /* encoding value for keyword check_proc */ dcl mrds_data_$valid_id_chars char (128) varying ext; /* common place for getting legal identifier characters */ dcl previous_token_type fixed bin int static init (0); /* last token encoding */ %page; %include mrds_rst_parse_stack; %page; %include mrds_rst_scan; %page; %include mrds_rst_rsc; %page; %include mrds_rst_struct_types; %page; %include mrds_rst_parse_info; end;  mrds_rst_semantics.pl1 10/16/86 1551.9rew 10/16/86 1142.9 587358 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-04-03,Spitzer), approve(86-04-03,MCR7311), audit(86-09-02,Blair), install(86-10-16,MR12.0-1187): remove unused dcls. remove PL/1 IO statement. END HISTORY COMMENTS */ /* -alm -ssl -ct -term -sem mrds_rst_semantics -mla 10 -table mrds_rst_parse_table -recover -mark -order -parse */ /* IMPORTANT!!! - - - HOW TO UPDATE THIS SOURCE ************************************************************** This semantic routine interface, the parser, and the scanner were all developed with the aide of the automated "lrk" parser generator tool. (see >udd>LIS>Wardd>MTB_lrk.runout for complete details) The following steps (say in an exec_com) must be done when the total parser or any part is to be modified, in order to insure proper operation. 1) make changes to the grammar and/or pl1 code representing semantics in the "lrk source" mrds_rst_parse.lrk via a text editor. This source looks like this listing, except that the BNF rules, and lrk options are not enclosed as comments, and it is not indented. DO NOT MODIFY mrds_rst_semantics.pl1 as those changes would be lost when lrk is invoked, and would not be reflected in any tables generated. 2) invoke the lrk program to generate a) the semantic routine source as pl1 code in mrds_rst_semantics.pl1 from the bnf, control arguments, and pl1 code in the lrk source in mrds_rst_parse.lrk b) parsing tables for the table driven parsing algorithm(an lrk bottom up parser) (the source is in mrds_rst_parse.pl1) from an "lrk source" of backus-naur form grammer (this is in mrds_rst_parse.lrk) via the command line: >udd>LIS>Wardd>lrk mrds_rst_parse the control arguments in the source direct lrk output as follows: "-table mrds_rst_parse_table" will build and initialize the basic lrk parsing table for the parsing algorithm "-sem mrds_rst_semantics" directs semantic output to the appropriate pl1 segment the "-order", and "-recover" control arguments affect error handling during parsing 3) generate the keyword sorted list for the scanner using the kwsl tool. this builds an include file that is a pl1 declaration for keyword encodings. the source of keyword synonyms is in mrds_rst_keywords.syn and is in the development library source directory the tool is invoked via the command line: >udd>LIS>Wardd>kwsl mrds_rst_parse mrds_rst_keywords mrds_rst_keywords where arguments 1 to 3 are the lrk source, kwsl source, and include file name 4) generate the error recovery skip table from the lrk tables by the following command line : udd>LIS>Wardd>msd mrds_rst_parse mrds_rst_skip_table where the first argument is the lrk source, the other the include file name 5) generate the error message terminal symbols file via the command line: ted -abort >udd>LIS>Wardd>lrk|hal_dcl mrds_rst_parse mrds_rst_terminals where the first argument is the lrk source, the last the include file name 6) build the ascii to decimal transliteration include file, input is is mrds_rst_translate.mad which may be found in the development library source directory. 7) add include file comment heading/trailing banners via command lines: ted -abort >udd>LIS>Wardd>Wardd|incl_cmt mrds_rst_parse_table ted -abort >udd>LIS>Wardd>Wardd|incl_cmt mrds_rst_skip_table 8) indent and compile the three affected parts of the parser on: mrds_rst_semantics.pl1 mrds_rst_parse.pl1 mrds_rst_scanner.pl1 the modification to the parser is now complete. THE FOLLOWING EXEC COM DOES THE ABOVE TASKS: & indent the lrk source & ted -abort >udd>LIS>Wardd>lrk|ind mrds_rst_parse.lrk & & generate the lrk tables from mrds_rst_parse.lrk source bnf & with control arguments inside that source output is the & mrds_rst_parse object table for the parser the source & mrds_rst_semantics.pl1, and the intermediate lrk results & mrds_rst_parse.result and several mrds_rst_parse.lrk.* segs & with a listing of mrds_rst_parseg.list & >udd>LIS>Wardd>lrk mrds_rst_parse & & generate the keyword sorted list include file from the & mrds_rst_keywords.syn source and the lrk output & mrds_rst_parse.result the output produced is & mrds_rst_keywords.incl.pl1 & >udd>LIS>Wardd>kwsl mrds_rst_parse mrds_rst_keywords mrds_rst_keywords & & generate the error skip table include the source is & mrds_rst_parse.result, output is mrds_rst_skip_table.incl.pl1 & >udd>LIS>Wardd>msd mrds_rst_parse mrds_rst_skip_table & & generate the terminal symbols include file the source is & mrds_rst_parse.result, output is mrds_rst_terminals.incl.pl1 & ted -abort >udd>LIS>Wardd>lrk|hal_dcl mrds_rst_parse mrds_rst_terminals & & build the ascii to decimal transliteration include file input & is mrds_rst_translate.mad, output is & mrds_rst_translate.incl.pl1 & ted -abort >udd>LIS>Wardd>Wardd|mad mrds_rst_translate.mad & & put include file headers/trailer comments in this adds the & BEGIN INCLUDE FILE.... and END INCLUDE FILE comments & ted -abort >udd>LIS>Wardd>Wardd|incl_cmt mrds_rst_parse_table ted -abort >udd>LIS>Wardd>Wardd|incl_cmt mrds_rst_skip_table & & compile parser, scanner, and semantics PL1 routines & pl1 mrds_rst_semantics pl1 mrds_rst_parse pl1 mrds_rst_scanner & & get rid of lrk generated segments no longer needed they were & used as intermediate results by lrk and it's tools & dl mrds_rst_parse.lrk.TL dl mrds_rst_parse.lrk.THL dl mrds_rst_parse.lrk.TC dl mrds_rst_parse.lrk.DPDA dl mrds_rst_parse.result ***************************************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* HISTORY: originally written by jim gray - - july 1978 Modified by Jim Gray - - Jan. 1980, to add packed decimal capability. 80-12-12 Jim Gray : added -mark control to LRK input file in order to be able to un-reserve keywords for CMDB. Also changed and rules to avoid case so that could run with 6.2 LRK (previously used 5.5). This means that a domain keyword must always be present, even if a define does not add new domains. 81-06-04 Jim Gray : removed unused rules and code, this included blocked file and foreign key statements, the -check option, and the restructuring directives. Also re-did scanner - parser constants according to the new -order statment. 81-10-15 Davids: added rules to allow declarations of the form: . varying char (64) . nonvarying char (64) . varying bit (64) . nonvarying bit (64) Also modified the example ec and explantion before it and justified all the text. */ mrds_rst_semantics: procedure (rule, alternate, stkp, ls_top); goto SKIP_ENTRIES; mrds_rst_semantics$rule_set: entry (); rule_sw = ^rule_sw; goto return_label; /* DESCRIPTION: semantics routines for mrds restructuring it is called by the lrk parser whenever a rule is found to aply giving the rule number, alternate number, the stack pointer, and the current top of the lexical stack a goto the appropiate semantic action is given based on the rule number, and the semantic action routine implements the "meaning" of the parse tree which the lrk parser has determined that the syntax represents. after the action, it returns to the parser. entry mrds_rst_semantics$init should be called first to initialize an alternate entry mrds_rst_semantics$rule_set - allows debug output of rule numbers processed to be switched on or off on succeeding calls, it has no parameters */ /* PARAMETERS: rule - - (input) the rule number of the bnf at which the lrk parser has found the syntax to conform to, before the reduction takes place. alternate - - (input) the alternative of this rule which is being used stkp - - (input) the lexical stack pointer ls_top - - (input) current top of the lexical stack rsc_ptr - - (input) for the init entry only, a pointer to the restructure control segment */ /* initialization entry */ mrds_rst_semantics$init: entry (rsc_ptr); static_rsc_ptr = rsc_ptr; rsc.skip_scanner_conversion = OFF; call mrds_rst_rsc_alloc (static_rsc_ptr, DIRECTIVE, directive_ptr); rsc_ptr -> rsc.directive_ptr = directive_ptr; directive.type = 0; /* no directive seen yet */ directive.undefine.active = OFF; directive.undefine.seen = OFF; directive.define.active = OFF; directive.define.seen = OFF; directive.redefine.active = OFF; directive.redefine.seen = OFF; call mrds_rst_rsc_alloc (static_rsc_ptr, STMT, stmt_ptr); rsc_ptr -> rsc.stmt_ptr = stmt_ptr; do i = 1 by 1 to hbound (stmt_ptr -> stmt, 1); stmt (i).domain.active = OFF; stmt (i).domain.number = 0; stmt (i).attribute.active = OFF; stmt (i).attribute.number = 0; stmt (i).relation.active = OFF; stmt (i).relation.number = 0; stmt (i).file.active = OFF; stmt (i).file.number = 0; stmt (i).foreign_key.active = OFF; stmt (i).foreign_key.number = 0; stmt (i).index.active = OFF; stmt (i).index.number = 0; end; max_string_size = mrds_data_$max_string_size; max_fixed_bin_17 = fixed (binary (copy ("1", 17) || "b")); max_fixed_bin_71 = fixed (binary (copy ("1", 71) || "b")); db_model_path = rtrim (rsc_ptr -> rsc.temp_dir) || ">db_model"; /* path name for the db_model must be saved */ call mrds_rst_rsc_alloc (static_rsc_ptr, TOKEN, name_ptr); /* space for token from stack */ call mrds_rst_rsc_alloc (static_rsc_ptr, TOKEN, temp_source_ptr); /* space for string to be multiplied */ goto return_label; /* ******************************************************************* normal entry for semantics case structure ****************************************************************** */ SKIP_ENTRIES: ; /* set local versions of parameters */ lex_stack_ptr = stkp; stack_top = ls_top; /* output the rule about to be executed, if debug switch is on */ if ^rule_sw then ; else call ioa_ ("rule ^d", rule); /* go do the case that this semantic rule number specifies */ goto rule_label (rule); /* ************************************************************************** definitions for statements within the directives ************************************************************************** */ /* ::= ! */ rule_label (0001): /* define and redefine directives are made up of any combination of the six statement keywords followed by the specifications for the items to be newly created or to be given a new definition */ goto return_label; /* ::= ! */ rule_label (0002): /* null statement */ goto return_label; /* ::= ! */ rule_label (0003): /* start of domain delete/define/redefine, set it active */ if directive.type = 0 then do; /* no other directive seen */ /* cmdb source, set up cmdb seen and active, check that this is a genuine cmdb command */ directive.type = CMDB; directive.cmdb.seen = ON; directive.cmdb.active = ON; end; stmt (directive.type).domain.active = ON; goto return_label; /* ::= ! */ rule_label (0004): /* start of attribute delete/define/redefine, set it active */ stmt (directive.type).attribute.active = ON; goto return_label; /* ::= ! */ rule_label (0005): /* start of relation delete/define/redefine, set it active */ stmt (directive.type).relation.active = ON; goto return_label; /* ::= ! */ rule_label (0006): /* start of index delete/define/redefine, set it active */ stmt (directive.type).index.active = ON; goto return_label; /* ************************************************************ all the following rules apply to define and redefine statement lists only ***************************************************************** */ /* ::= | ! */ rule_label (0007): /* domain processing complete, set it inactive, after defining default attributes for new domains */ call mrds_rst_attribute_cleanup (static_rsc_ptr); stmt (directive.type).domain.active = OFF; goto return_label; /* ::= ! */ rule_label (0008): goto return_label; /* ::= ! */ rule_label (0009): goto return_label; /* ::= ! */ rule_label (0010): /* call the semantic handler for domains */ call mrds_rst_domain_handler (static_rsc_ptr, domain_list_ptr); stmt (directive.type).domain.number = stmt (directive.type).domain.number + 1; goto return_label; /* ::= ! */ rule_label (0011): /* set up domain structure and get the domain name */ call mrds_rst_rsc_alloc (static_rsc_ptr, DOMAIN, domain_list_ptr); call domain_initialize (); call set_declaration_defaults (domain_list_ptr -> domain.descriptor); goto return_label; /* ::= ! */ rule_label (0012): /* build descriptor for number, set packing, precision, scale, and type */ if aligned then descr_ptr -> descriptor.packed = OFF; else descr_ptr -> descriptor.packed = ON; call set_precision_and_scale (); call set_number_type (); goto return_label; /* ::= ! */ rule_label (0013): /* build descriptor for character string, set type, packed, and size */ call set_string_size_and_packing (); if nonvarying then descr_ptr -> descriptor.type = 21; else descr_ptr -> descriptor.type = 22; goto return_label; /* ::= ! */ rule_label (0014): /* build descriptor for bit string, set type, packed, and size */ call set_string_size_and_packing (); if nonvarying then descr_ptr -> descriptor.type = 19; else descr_ptr -> descriptor.type = 20; goto return_label; domain_initialize: procedure (); /* initialize the domain structure */ domain_list_ptr -> domain.name = get_name (stack_top, 32); domain_list_ptr -> domain.descriptor = OFF; domain_list_ptr -> domain.varying_avg_length = 0; domain_list_ptr -> domain.options = OFF; domain_list_ptr -> domain.pad = OFF; domain_list_ptr -> domain.check.flag = OFF; domain_list_ptr -> domain.check.pad = OFF; domain_list_ptr -> domain.check.stack_ptr = null (); domain_list_ptr -> domain.check.stack_size = 0; domain_list_ptr -> domain.check_proc.flag = OFF; domain_list_ptr -> domain.check_proc.pad = OFF; domain_list_ptr -> domain.check_proc.path = BLANK; domain_list_ptr -> domain.check_proc.entry = BLANK; domain_list_ptr -> domain.encode_proc.flag = OFF; domain_list_ptr -> domain.encode_proc.pad = OFF; domain_list_ptr -> domain.encode_proc.path = BLANK; domain_list_ptr -> domain.encode_proc.entry = BLANK; domain_list_ptr -> domain.decode_proc.flag = OFF; domain_list_ptr -> domain.decode_proc.pad = OFF; domain_list_ptr -> domain.decode_proc.path = BLANK; domain_list_ptr -> domain.decode_proc.entry = BLANK; domain_list_ptr -> domain.decode_dcl.flag = OFF; domain_list_ptr -> domain.decode_dcl.pad = OFF; domain_list_ptr -> domain.decode_dcl.descriptor = OFF; domain_list_ptr -> domain.line_num = get_line_number (stack_top); /* set up duplicate check_list option flags */ decode_dcl_seen = OFF; decode_proc_seen = OFF; encode_proc_seen = OFF; check_seen = OFF; multiplier = 1; string_average_length = 0; avg_length_seen = OFF; decode_dcl_mesg = ""; end; set_declaration_defaults: procedure (current_descriptor); /* set up defaults */ decimal = OFF; float = OFF; real = ON; aligned = ON; nonvarying = ON; string_length = 1; scale_factor = 0; /* set up overlays and descriptor constants */ descr_ptr = addr (current_descriptor); descr_ptr -> descriptor.version = ON; descr_ptr -> descriptor.number_dims = OFF; /* dimension = 0 */ num_dims = 0; /* set up duplication and declaration flags */ size_seen = OFF; type_seen = OFF; representation_seen = OFF; base_seen = OFF; precision_seen = OFF; alignment_seen = OFF; fixed_varying_seen = OFF; scale_seen = OFF; declare current_descriptor bit (36) aligned; /* current descriptor to point to for this declaration */ end; set_number_type: procedure (); /* set data type for number based on float/short/decimal/real attributes */ /* packed decimal data types 43-46, depend on the aligned attribute as well */ if ^decimal then if real then if ^float then if short then descr_ptr -> descriptor.type = 1; else descr_ptr -> descriptor.type = 2; else if short then descr_ptr -> descriptor.type = 3; else descr_ptr -> descriptor.type = 4; else if ^float then if short then descr_ptr -> descriptor.type = 5; else descr_ptr -> descriptor.type = 6; else if short then descr_ptr -> descriptor.type = 7; else descr_ptr -> descriptor.type = 8; else if real then if ^float then do; if aligned then descr_ptr -> descriptor.type = 9; else descr_ptr -> descriptor.type = 43; end; else do; if aligned then descr_ptr -> descriptor.type = 10; else descr_ptr -> descriptor.type = 44; end; else if ^float then do; if aligned then descr_ptr -> descriptor.type = 11; else descr_ptr -> descriptor.type = 45; end; else do; if aligned then descr_ptr -> descriptor.type = 12; else descr_ptr -> descriptor.type = 46; end; end; /* ************************************************************* number precision and scale attribute processing ************************************************************ */ set_precision_and_scale: procedure (); /* set default precision or check user values against limits */ if ^precision_seen then /* no precision given, set defaults */ if ^float then if ^decimal then saved_precision = 17; else saved_precision = 7; else if ^decimal then saved_precision = 27; else saved_precision = 10; /* check user's precision */ else if ^decimal then if ^float then if saved_precision >= 1 & saved_precision <= 71 then ; else do; call ioa_$rs ("^a ^a^a^a^a ^d ^a", message, message_length, "The", decode_dcl_mesg, "declaration of domain """, domain_list_ptr -> domain.name, """ on line", domain_list_ptr -> domain.line_num, "has precision <1 or >71 for fixed binary number, using ""71"" instead."); call mrds_rst_error (static_rsc_ptr, 2 /* severity */, mrds_error_$rst_bad_declaration, (message)); saved_precision = 71; end; else if saved_precision >= 1 & saved_precision <= 63 then ; else do; call ioa_$rs ("^a ^a^a^a^a ^d ^a", message, message_length, "The", decode_dcl_mesg, "declaration of domain """, domain_list_ptr -> domain.name, """ on line", domain_list_ptr -> domain.line_num, "has precision <1 or >63 for float binary number, using ""63"" instead."); call mrds_rst_error (static_rsc_ptr, 2 /* severity */, mrds_error_$rst_bad_declaration, (message)); saved_precision = 63; end; else if saved_precision >= 1 & saved_precision <= 59 then ; else do; call ioa_$rs ("^a ^a^a^a^a ^d ^a", message, message_length, "The", decode_dcl_mesg, "declaration of domain """, domain_list_ptr -> domain.name, """ on line", domain_list_ptr -> domain.line_num, "has precision <1 or >59 for a decimal number, using ""59"" instead."); call mrds_rst_error (static_rsc_ptr, 2 /* severity */, mrds_error_$rst_bad_declaration, (message)); saved_precision = 59; end; descr_ptr -> arith_size.precision = saved_precision; /* set precision type as short or long */ if decimal then ; else if ^float then if saved_precision <= 35 then short = ON; else short = OFF; else if saved_precision <= 27 then short = ON; else short = OFF; /* check on the scale factor */ if ^(float & scale_seen) then ; else do; call ioa_$rs ("^a ^a^a^a^a ^d ^a", message, message_length, "The", decode_dcl_mesg, "declaration of domain """, domain_list_ptr -> domain.name, """ on line", domain_list_ptr -> domain.line_num, "is declared float, it can not have scale specified, --- the scale is ignored!!"); call mrds_rst_error (static_rsc_ptr, 2 /* severity */, mrds_error_$rst_bad_declaration, (message)); scale_factor = 0; end; if scale_factor >= -128 & scale_factor <= 127 then ; else do; if scale_factor < 0 then scale_factor = -128; else scale_factor = +127; call ioa_$rs ("^a ^a^a^a^a ^d ^a^d^a", message, message_length, "The", decode_dcl_mesg, "declaration of domain """, domain_list_ptr -> domain.name, """ on line", domain_list_ptr -> domain.line_num, "has a scale factor <-128 or >127, using """, scale_factor, """ instead."); call mrds_rst_error (static_rsc_ptr, 2 /* severity */, mrds_error_$rst_bad_declaration, (message)); end; descr_ptr -> arith_size.scale = scale_factor; end; set_string_size_and_packing: procedure (); /* check alignment and varying attributes to determine packing, and set size from the string length */ if nonvarying then if alignment_seen then ; else aligned = OFF; else if aligned then ; else do; aligned = ON; call ioa_$rs ("^a ^a^a^a^a ^d ^a", message, message_length, "The", decode_dcl_mesg, "declaration of domain """, domain_list_ptr -> domain.name, """ on line", domain_list_ptr -> domain.line_num, "is being corrected, since varying strings must be ""aligned""."); call mrds_rst_error (static_rsc_ptr, 1 /* severity */, mrds_error_$rst_bad_declaration, (message)); end; if aligned then descr_ptr -> descriptor.packed = OFF; else descr_ptr -> descriptor.packed = ON; descr_ptr -> string_size.length = string_length; /* for normal declarations(not decode_dcl), and varying strings, remember the average length */ if decode_dcl_mesg ^= "" then ; else if ^nonvarying then domain_list_ptr -> domain.varying_avg_length = string_average_length; else if ^avg_length_seen then ; else do; call ioa_$rs ("^a^a ^a^a^a^a ^d^a", message, message_length, "The average length attribute is not allowed with nonvarying strings", ", it is being ignored in the", decode_dcl_mesg, "declaration for domain """, domain_list_ptr -> domain.name, """ on line", domain_list_ptr -> domain.line_num, "."); call mrds_rst_error (static_rsc_ptr, 1 /* severity */, mrds_error_$rst_inconsis_option, (message)); end; end; /* ********************************************* attributes in number declarations can be in any order duplicates and contradictory attributes are checked for ***************************************** */ /* ::= ! */ rule_label (0015): goto return_label; /* ::= ! */ rule_label (0016): goto return_label; /* ::= ! */ rule_label (0017): goto return_label; /* ::= ! */ rule_label (0018): /* set real attribute */ if duplicate ("real or complex", addr (type_seen)) then ; else real = ON; goto return_label; /* ::= ! */ rule_label (0019): /* set complex attribute */ if duplicate ("real or complex", addr (type_seen)) then ; else real = OFF; goto return_label; /* ::= ! */ rule_label (0020): /* set fixed attribute */ if duplicate ("float or fixed", addr (representation_seen)) then ; else float = OFF; goto return_label; /* ::= ! */ rule_label (0021): /* set float attribute */ if duplicate ("float or fixed", addr (representation_seen)) then ; else float = ON; goto return_label; /* ::= ! */ rule_label (0022): /* set binary attribute */ if duplicate ("binary or decimal", addr (base_seen)) then ; else decimal = OFF; goto return_label; /* ::= ! */ rule_label (0023): /* set decimal attribute */ if duplicate ("binary or decimal", addr (base_seen)) then ; else decimal = ON; goto return_label; /* ::= ! */ rule_label (0024): goto return_label; /* ::= ! */ rule_label (0025): goto return_label; /* ::= ! */ rule_label (0026): /* set positive sign */ sign_flag = OFF; goto return_label; /* ::= ! */ rule_label (0027): /* set negative sign */ sign_flag = ON; goto return_label; /* ::= ! */ rule_label (0028): /* set sign positive */ sign_flag = OFF; goto return_label; /* ::= ! */ rule_label (0029): /* set precision attribute with scale factor (negative) */ if duplicate ("precision", addr (precision_seen)) then ; else do; saved_precision = get_fixed_value (stack_top - 4, max_fixed_bin_71); if sign_flag then scale_factor = -get_fixed_value (stack_top - 1, max_fixed_bin_71); else scale_factor = get_fixed_value (stack_top - 1, max_fixed_bin_71); scale_seen = ON; end; goto return_label; /* ::= ! */ rule_label (0030): /* set precision attribute */ if duplicate ("precision", addr (precision_seen)) then ; else saved_precision = get_fixed_value (stack_top - 1, max_fixed_bin_71); goto return_label; /* ::= ! */ rule_label (0031): goto return_label; /* ::= ! */ rule_label (0032): /* set aligned attribute */ if duplicate ("aligned or unaligned", addr (alignment_seen)) then ; else aligned = ON; goto return_label; /* ::= ! */ rule_label (0033): /* set unaligned attribute */ if duplicate ("aligned or unaligned", addr (alignment_seen)) then ; else aligned = OFF; goto return_label; /* ******************************************************* make sure that attributes are not repeated in a declaraion ************************************************************* */ duplicate: procedure (attribute, flag_ptr) returns (bit (1)); /* check to see if this attribute has already been used in this declaration */ if ^flag_ptr -> flag_overlay then do; /* attribute not yet seen, flag it as seen, return no duplication */ flag_ptr -> flag_overlay = ON; duplication = OFF; end; else do; /* attribute duplicate, issue error, return duplication */ duplication = ON; call ioa_$rs ("^a^a^a ^a^a^a^a ^d^a", message, message_length, "The attribute """, attribute, """ appears more than once in the", decode_dcl_mesg, "declaration of domain """, domain_list_ptr -> domain.name, """ on line", domain_list_ptr -> domain.line_num, ", the first occurence will be used."); call mrds_rst_error (static_rsc_ptr, 2 /* severity */, mrds_error_$rst_bad_declaration, (message)); end; return (duplication); declare duplication bit (1); /* ON => this is a previously seen attribute */ declare flag_ptr ptr; /* pointer to attribute flag */ declare flag_overlay bit (1) based; /* overlay structure for flag */ declare attribute char (*); /* attribute name being checked */ end; /* *********************************************************************** bit and character string declarations can have the attributes in any order but duplicates will be flagged as errors and ignored as with number precision and scale, string size is checked for a legal range **************************************************************************** */ /* ::= ! */ rule_label (0034): goto return_label; /* ::= ! */ rule_label (0035): if duplicate ("varying or nonvarying", addr (fixed_varying_seen)) then ; else nonvarying = OFF; goto return_label; /* ::= ! */ rule_label (0036): if duplicate ("varying or nonvarying", addr (fixed_varying_seen)) then ; else nonvarying = ON; goto return_label; /* ::= ! */ rule_label (0037): goto return_label; /* ::= ! */ rule_label (0038): goto return_label; /* ::= ! */ rule_label (0039): goto return_label; /* ::= ! */ rule_label (0040): goto return_label; /* ::= ! */ rule_label (0041): /* set string length attribute(and default average length for normal declarations) */ if duplicate ("string size", addr (size_seen)) then ; else do; temp_number = get_fixed_value (stack_top - 1, max_fixed_bin_71); call string_size_check (temp_number); string_length = temp_number; avg_length_seen = OFF; if decode_dcl_mesg ^= "" then ; else string_average_length = string_length; end; goto return_label; /* ::= ! */ rule_label (0042): goto return_label; /* ::= ! */ rule_label (0043): /* set varying attribute */ if duplicate ("varying or nonvarying", addr (fixed_varying_seen)) then ; else nonvarying = OFF; goto return_label; /* ::= ! */ rule_label (0044): /* set nonvarying attribute */ if duplicate ("varying or nonvarying", addr (fixed_varying_seen)) then ; else nonvarying = ON; goto return_label; /* ::= ! */ rule_label (0045): goto return_label; /* ::= ! */ rule_label (0046): if duplicate ("varying or nonvarying", addr (fixed_varying_seen)) then ; else nonvarying = OFF; goto return_label; /* ::= ! */ rule_label (0047): if duplicate ("varying or nonvarying", addr (fixed_varying_seen)) then ; else nonvarying = ON; goto return_label; string_size_check: procedure (number); /* make sure number for string length is less than maximum allowable */ if number <= max_string_size then ; else do; call ioa_$rs ("^a^d^a ^d^a ^a^a^a^a ^d^a", message, message_length, "String size """, number, """ exceeds the maximum allowable length of", max_string_size, ", using the maximum instead in the", decode_dcl_mesg, "declaration of domain """, domain_list_ptr -> domain.name, """ on line", domain_list_ptr -> domain.line_num, "."); call mrds_rst_error (static_rsc_ptr, 2 /* severity */, mrds_error_$rst_bad_declaration, (message)); number = max_string_size; end; /* fixup unwanted zero values */ if number ^= 0 then ; else do; number = 1; call ioa_$rs ("^a ^a^a^a^a ^d^a", message, message_length, "Illegal zero value is being replaced by ""1"" in size attribute of", decode_dcl_mesg, "declaration for domain """, domain_list_ptr -> domain.name, """ on line", domain_list_ptr -> domain.line_num, "."); call mrds_rst_error (static_rsc_ptr, 2 /* severity */, mrds_error_$rst_bad_declaration, (message)); end; declare number fixed binary (71); /* number under test as string length */ end; /* ***************************************************************** the check, check_proc, encode_proc, decode_proc options may be in any order however, check and check_proc are mutually exclusive options ***************************************************************** */ /* ::= ! */ rule_label (0048): /* set options present */ domain_list_ptr -> domain.options = ON; goto return_label; /* ::= ! */ rule_label (0049): /* set no options present */ domain_list_ptr -> domain.options = OFF; goto return_label; /* ::= ! */ rule_label (0050): goto return_label; /* ::= ! */ rule_label (0051): goto return_label; /* ::= ! */ rule_label (0052): goto return_label; /* ::= ! */ rule_label (0053): goto return_label; /* ::= ! */ rule_label (0054): goto return_label; /* ::= ! */ rule_label (0055): goto return_label; /* ***************************** decode declaration option ****************************** */ /* ::= ! */ rule_label (0056): /* decode declaration finished, restore normal declaration pointers */ descr_ptr = saved_descr_ptr; decode_dcl_mesg = ""; /* if a duplicate caused the descriptor to be saved, restore it */ if ^descriptor_saved then ; else domain_list_ptr -> domain.decode_dcl.descriptor = saved_decode_descriptor; goto return_label; /* ::= ! */ rule_label (0057): /* set up for handling a decode declaration, save normal declaration pointers */ saved_descr_ptr = descr_ptr; call set_declaration_defaults (domain_list_ptr -> domain.decode_dcl.descriptor); /* only set this option on if this is not a duplicate else remember the first declaration seen(via the descriptor) */ if duplicate ("decode_dcl", addr (decode_dcl_seen)) then do; descriptor_saved = ON; saved_decode_descriptor = domain_list_ptr -> domain.decode_dcl.descriptor; end; else do; domain_list_ptr -> domain.decode_dcl.flag = ON; descriptor_saved = OFF; end; /* set up error messages for decode declarations */ decode_dcl_mesg = "decode_"; goto return_label; /* ************************************************ gather pathnames and entry names for procedure options ************************************************** */ /* ::= ! */ rule_label (0058): /* set up check procedure path and entry names */ temp_index = stack_top - 1; call get_check_path_entry (); goto return_label; /* ::= ! */ rule_label (0059): /* set up check procedure pathname and missing entry name */ temp_index = stack_top; call get_check_path_entry (); goto return_label; /* ::= ! */ rule_label (0060): /* set up encode procedure path and entry names */ temp_index = stack_top - 1; call get_encode_path_entry (); goto return_label; /* ::= ! */ rule_label (0061): /* set up encode pathname and missing entryname */ temp_index = stack_top; call get_encode_path_entry (); goto return_label; /* ::= ! */ rule_label (0062): /* set up decode procedure path and entry names */ temp_index = stack_top - 1; call get_decode_path_entry (); goto return_label; /* ::= ! */ rule_label (0063): /* set up decode procedure pathname and missing entryname */ temp_index = stack_top; call get_decode_path_entry (); goto return_label; get_check_path_entry: procedure (); /* get pathname from the stack and entry name if there, else get entry name from path name. Set this option on */ if duplicate ("check_proc", addr (check_seen)) then ; else do; domain_list_ptr -> domain.check_proc.flag = ON; domain_list_ptr -> domain.check_proc.path = get_name (temp_index, 168); if temp_index = stack_top then domain_list_ptr -> domain.check_proc.entry = get_entry (domain_list_ptr -> domain.check_proc.path); else domain_list_ptr -> domain.check_proc.entry = get_name (stack_top, 32); end; end; get_encode_path_entry: procedure (); /* get pathname from the stack and entry name if there, else get entry name from path name. Set this option on */ if duplicate ("encode_proc", addr (encode_proc_seen)) then ; else do; domain_list_ptr -> domain.encode_proc.flag = ON; domain_list_ptr -> domain.encode_proc.path = get_name (temp_index, 168); if temp_index = stack_top then domain_list_ptr -> domain.encode_proc.entry = get_entry (domain_list_ptr -> domain.encode_proc.path); else domain_list_ptr -> domain.encode_proc.entry = get_name (stack_top, 32); end; end; get_decode_path_entry: procedure (); /* get pathname from the stack and entry name if there, else get entry name from path name. Set this option on */ if duplicate ("decode_proc", addr (decode_proc_seen)) then ; else do; domain_list_ptr -> domain.decode_proc.flag = ON; domain_list_ptr -> domain.decode_proc.path = get_name (temp_index, 168); if temp_index = stack_top then domain_list_ptr -> domain.decode_proc.entry = get_entry (domain_list_ptr -> domain.decode_proc.path); else domain_list_ptr -> domain.decode_proc.entry = get_name (stack_top, 32); end; end; get_entry: procedure (pathname) returns (char (32)); /* extract the entry name from the pathname */ if lex_stack_ptr -> lex_stack (stack_top).token_num ^= 0 & search (reverse (pathname), ">") ^= 0 then /* absolute pathname, extract the rightmost component */ entry_portion = substr (pathname, length (pathname) - search (reverse (pathname), ">") + 2); /* either dummy "" or relative pathname, use path as entry name */ else entry_portion = pathname; /* make sure the entry name is not too big */ entry_portion = rtrim (entry_portion); if length (entry_portion) <= 32 then ; else do; call ioa_$rs ("^a^a^a ^d^a", message, message_length, "The entry name portion exceeds 32 characters in pathname """, pathname, """ on line", domain_list_ptr -> domain.line_num, ", it is being truncated to that length!!"); call mrds_rst_error (static_rsc_ptr, 2 /* severity */, mrds_error_$rst_name_too_long, (message)); end; entryname = entry_portion; return (entryname); declare pathname char (*) aligned; /* absolute or relative pathname */ declare entryname char (32); /* final extracted entry name */ declare entry_portion char (168) varying;/* intermediate entry portion */ end; /* ************************************************* attribute specification processing ********************************************** */ /* ::= ! */ rule_label (0064): /* attribute declaration processing complete, set it inactive */ stmt (directive.type).attribute.active = OFF; goto return_label; /* ::= | ! */ rule_label (0065): goto return_label; /* ::= ! */ rule_label (0066): /* count the last attribute specification */ stmt (directive.type).attribute.number = stmt (directive.type).attribute.number + 1; goto return_label; /* ::= ! */ rule_label (0067): goto return_label; /* ::= ! */ rule_label (0068): /* get the attribute domain pair, and call the semantic routine for this declaration */ call mrds_rst_rsc_alloc (static_rsc_ptr, ATTRIBUTE_DOMAIN, attribute_list_ptr); attribute_list_ptr -> attribute_domain.attr = get_name (stack_top - 1, 32); attribute_list_ptr -> attribute_domain.dom = get_name (stack_top, 32); attribute_list_ptr -> attribute_domain.line_num = get_line_number (stack_top - 1); attribute_list_ptr -> attribute_domain.default = OFF; /* defined in source */ attribute_list_ptr -> attribute_domain.unused = OFF; call mrds_rst_attribute_handler (static_rsc_ptr, attribute_list_ptr); stmt (directive.type).attribute.number = stmt (directive.type).attribute.number + 1; goto return_label; /* *************************************************** relation specification processing *********************************************** */ /* ::= ! */ rule_label (0069): /* relation processing complete, set it inactive */ call mrds_rst_file_cleanup (static_rsc_ptr); stmt (directive.type).relation.active = OFF; goto return_label; /* ::= | ! */ rule_label (0070): /* no relation statement, set it inactive */ stmt (directive.type).relation.active = OFF; goto return_label; /* ::= ! */ rule_label (0071): goto return_label; /* ::= ! */ rule_label (0072): goto return_label; /* ::= ! */ rule_label (0073): /* relation list built, call the semantic routine for relation declarations */ if key_order ^= 0 then ; else call fixup_key_attribute (); call mrds_rst_relation_handler (static_rsc_ptr, relation_list_ptr); stmt (directive.type).relation.number = stmt (directive.type).relation.number + 1; goto return_label; /* ::= ! */ rule_label (0074): /* start relation list, get name from stack */ call get_relation_name (); goto return_label; /* ::= ! */ rule_label (0075): goto return_label; /* ::= ! */ rule_label (0076): goto return_label; /* ::= ! */ rule_label (0077): /* get non key attribute for this relation list */ temp_index = stack_top; key_attribute = OFF; call get_relation_attribute (); goto return_label; /* ::= ! */ rule_label (0078): /* get key attribute for this relation list */ temp_index = stack_top - 1; key_attribute = ON; call get_relation_attribute (); goto return_label; fixup_key_attribute: procedure (); /* assume the first attrubte defined is the key when none given */ attribute_ptr = relation_list_ptr -> relation.a_ptr; attribute_ptr -> attribute.pr_key = ON; attribute_ptr -> attribute.key_order = 1; call ioa_$rs ("^a^a^a ^d ^a^a^a", message, message_length, "Relation """, relation_list_ptr -> relation.name, """ on line", relation_list_ptr -> relation.line_num, "does not specify any key attributes, assuming """, attribute_ptr -> attribute.name, """ is a key attribute."); call mrds_rst_error (static_rsc_ptr, 2 /* severity */, mrds_error_$rst_no_key_attr, (message)); end; get_relation_name: procedure (); /* get relation name from stack and build list header */ call mrds_rst_rsc_alloc (static_rsc_ptr, RELATION, relation_list_ptr); relation_list_ptr -> relation.a_ptr = null (); relation_list_ptr -> relation.name = get_name (stack_top, 30); relation_list_ptr -> relation.max_tup = 0; relation_list_ptr -> relation.num_items = 0; relation_list_ptr -> relation.line_num = get_line_number (stack_top); relation_list_ptr -> relation.unused = OFF; key_order = 0; definition_order = 0; saved_attr_ptr = relation_list_ptr; end; get_relation_attribute: procedure (); /* get attribute name from stack and add it to the relation's list */ if list_duplicate (ATTRIBUTES, relation_list_ptr -> relation.a_ptr, temp_index, 32) then ; else do; call mrds_rst_rsc_alloc (static_rsc_ptr, ATTRIBUTE, attribute_ptr); attribute.next = null (); saved_attr_ptr -> attribute.next = attribute_ptr; attribute.name = get_name (temp_index, 32); attribute.pr_key = key_attribute; attribute.pad = OFF; definition_order = definition_order + 1; attribute.defn_order = definition_order; if ^key_attribute then attribute.key_order = 0; else do; key_order = key_order + 1; attribute.key_order = key_order; end; attribute.line_num = get_line_number (temp_index); relation_list_ptr -> relation.num_items = relation_list_ptr -> relation.num_items + 1; saved_attr_ptr = attribute_ptr; end; end; /* ****************************************************** index specification processing ****************************************************** */ /* ::= ! */ rule_label (0079): /* index processing complete, set it inactive */ stmt (directive.type).index.active = OFF; goto return_label; /* ::= | ! */ rule_label (0080): /* set index statement inactive */ stmt (directive.type).index.active = OFF; goto return_label; /* ::= ! */ rule_label (0081): goto return_label; /* ::= ! */ rule_label (0082): goto return_label; /* ::= ! */ rule_label (0083): /* index definition list complete, go process the definition */ call mrds_rst_index_handler (static_rsc_ptr, index_list_ptr); stmt (directive.type).index.number = stmt (directive.type).index.number + 1; goto return_label; /* ::= ! */ rule_label (0084): /* start a index definition list with the relation name */ call get_index_relation (); goto return_label; /* ::= ! */ rule_label (0085): /* add the last attribute to this index definition list */ call get_index_attribute (); goto return_label; /* ::= ! */ rule_label (0086): /* add the next attribute to this index definition list */ call get_index_attribute (); goto return_label; /* case statement common exit */ return_label: return; get_index_relation: procedure (); /* get the relation name and build list head for this index statment */ call mrds_rst_rsc_alloc (static_rsc_ptr, INDEX, index_list_ptr); index_list_ptr -> rel_index.i_ptr = null (); index_list_ptr -> rel_index.rel_name = get_name (stack_top, 32); index_list_ptr -> rel_index.num_items = 0; index_list_ptr -> rel_index.unused = OFF; index_list_ptr -> rel_index.line_num = get_line_number (stack_top); saved_attr_ptr = index_list_ptr; end; get_index_attribute: procedure (); /* add attribute name to the list for this index */ if list_duplicate (ATTRIBUTES, index_list_ptr -> rel_index.i_ptr, stack_top, 32) then ; else do; call mrds_rst_rsc_alloc (static_rsc_ptr, ITEM, item_ptr); item.name = get_name (stack_top, 32); item.next = null (); item.unused = OFF; item.line_num = get_line_number (stack_top); saved_attr_ptr -> item.next = item_ptr; index_list_ptr -> rel_index.num_items = index_list_ptr -> rel_index.num_items + 1; saved_attr_ptr = item_ptr; end; end; list_duplicate: procedure (list_type, list_ptr, stack_pos, size) returns (bit (1)); /* check that the given attribute/relation name appears only once in the given list. (i.e. attributes in a relation, relations in a file) */ name_duplicate = OFF; name = get_name (stack_pos, size); /* set up list start depending on list type and status */ if list_type ^= CHILD then item_ptr = list_ptr; else if list_ptr = null () then item_ptr = null (); else do; children_ptr = list_ptr; item_ptr = children_ptr -> children.child_ptr; end; /* run through linked list of names, checking for duplicates, until list end */ do while (item_ptr ^= null ()); if item_ptr -> item.name ^= name then /* not duplicate, set next list element for list type */ if list_type ^= CHILD then item_ptr = item_ptr -> item.next; else do; children_ptr = children_ptr -> children.next; if children_ptr = null () then item_ptr = null (); else item_ptr = children_ptr -> children.child_ptr; end; else do; /* duplicate found, issue error, quit search */ name_duplicate = ON; item_ptr = null (); if list_type = CHILD then duplicate_type = "child relation in a foreign key"; else if list_type = FILE_REL then duplicate_type = "relation in a file"; else duplicate_type = "attribute in a relation"; call ioa_$rs ("^a^a^a ^d ^a ^a^a", message, message_length, "The name """, name, """ given on line", get_line_number (stack_pos), "is a duplicate", duplicate_type, ", --- it will be ignored!!"); call mrds_rst_error (static_rsc_ptr, 2 /* severity */, mrds_error_$rst_name_duplicate, (message)); end; end; return (name_duplicate); declare stack_pos fixed binary; /* stack index for this item */ declare size fixed binary; /* allowable length of name */ declare duplicate_type char (36) varying; /* error list message */ declare list_ptr ptr; /* overlay list pointer */ declare name char (32); /* name that is to be checked for duplicate */ declare list_type fixed bin; /* 8 => child relation, 9 => file relation, 10 => attribute */ declare name_duplicate bit (1); /* ON => name already in list */ end; get_name: procedure (stack_pos, name_size) returns (char (*)); /* return the identifier from the given stack position, checking that it does not exceed the given size. Note that "" is used when a missing identifier has been detected and a dummy inserted for it. */ length = lex_stack_ptr -> lex_stack (stack_pos).symlen; name = substr (lex_stack_ptr -> lex_stack (stack_pos).symptr -> source, 1, length); token_pos = lex_stack_ptr -> lex_stack (stack_pos).token_num; /* check on the token size */ if length <= name_size then ; else do; length = name_size; lex_stack_ptr -> lex_stack (stack_pos).symlen = name_size; call ioa_$rs ("^a^a^a ^d ^a ^d ^a", message, message_length, "The string """, name, """ in line", get_line_number (stack_pos), "is longer than", name_size, "characters, it is being truncated at that length."); call mrds_rst_error (static_rsc_ptr, 2 /* severity */, mrds_error_$rst_name_too_long, (message)); end; /* if this is the dummy symbol(token_pos = 0), issue a warning, the first time */ if token_pos ^= 0 then ; else do; lex_stack_ptr -> lex_stack (stack_pos).token_num = -1; call ioa_$rs ("^a^a^a ^d^a", message, message_length, "The string """, name, """ is being used for a missing token in line", get_line_number (stack_pos), "."); call mrds_rst_error (static_rsc_ptr, 1 /* severity */, mrds_error_$rst_bad_semantics, (message)); end; name_overlay_ptr = addrel (addr (name), 1); /* point to data portion of varying string */ return (name_overlay); declare length fixed binary (24); /* length of token */ declare name char (mrds_data_$max_string_size) varying based (name_ptr); /* token character string */ declare name_overlay char (length) based (name_overlay_ptr); /* exact length token to return */ declare name_overlay_ptr ptr; /* points to data portion */ declare token_pos fixed binary (24); /* position of token in line */ declare stack_pos fixed binary; /* index into stack for this identifier */ declare name_size fixed binary; /* maximum legal size for this token */ end; get_fixed_value: procedure (stack_pos, max_value) returns (fixed bin (71)); /* get a fixed binary value from the stack at the given position */ if lex_stack_ptr -> lex_stack (stack_pos).token_num ^= 0 then value = lex_stack_ptr -> lex_stack (stack_pos).val; else do; /* token_num = 0 means dummy "" on stack for missing number, use a fixup value and issue error message */ value = 1; lex_stack_ptr -> lex_stack (stack_pos).val = 1; call ioa_$rs ("^a^d^a ^d^a", message, message_length, "The value """, value, """ is being used for a missing number in line", get_line_number (stack_pos), "."); call mrds_rst_error (static_rsc_ptr, 1 /* severity */, mrds_error_$rst_bad_semantics, (message)); end; /* check that the number is within the range of the option */ if value <= max_value then ; else do; call ioa_$rs ("^a^d^a ^d ^a^d^a", message, message_length, "The value """, value, """ in line", get_line_number (stack_pos), "exceeds the maximum allowable for this option, using """, max_value, """ instead."); call mrds_rst_error (static_rsc_ptr, 2 /* severity */, mrds_error_$rst_option_limit, (message)); value = max_value; lex_stack_ptr -> lex_stack (stack_pos).val = max_value; end; return (value); declare value fixed binary (71); /* value of number to be returned */ declare stack_pos fixed binary; /* index into stack for this number */ declare max_value fixed binary (71); /* largest allowed value */ end; get_line_number: procedure (stack_pos) returns (fixed binary (24)); /* routine to obtain line number from parse stack */ line_number = lex_stack_ptr -> lex_stack (stack_pos).line; return (line_number); declare line_number fixed binary (24); /* value to be returned */ declare stack_pos fixed binary; /* index into stack for this item */ end; declare rule_sw bit (1) static init ("0"b); /* switch for debug output of rule numbers */ declare saved_attr_ptr ptr internal static; /* last attr pointer */ declare saved_decode_descriptor bit (36) aligned internal static; /* first given decode_dcl descriptor */ declare descriptor_saved bit (1) internal static; /* on => the first decode descriptor was saved */ declare (fixed, addr, search, binary) builtin; /* functions known to pl1 */ declare stkp ptr; /* lexical stack pointer parameter */ declare ls_top fixed binary (24); /* parameter for top of stack */ declare sign_flag bit (1) internal static; /* on => negative value needed */ declare mrds_error_$rst_no_key_attr fixed binary (35) external; /* no attr given as key in relation */ declare mrds_error_$rst_option_limit fixed binary (35) external; /* number too large for receiving field */ declare mrds_error_$rst_name_duplicate fixed binary (35) external; /* dup name in rel/attr or file/rel list */ declare mrds_error_$rst_bad_declaration fixed binary (35) external; /* error in domain declaration */ declare mrds_error_$rst_inconsis_option fixed binary (35) external; /* contradictory option */ declare mrds_error_$rst_name_too_long fixed binary (35) external; /* oversize name error */ declare mrds_error_$rst_bad_semantics fixed binary (35) external; /* meaning of source may be lost */ declare EQUAL fixed bin internal static options (constant) init (1); /* = op code */ declare NOT_EQUAL fixed bin internal static options (constant) init (2); /* ^= op code */ declare GREATER fixed bin internal static options (constant) init (3); /* > op code */ declare LESS fixed bin internal static options (constant) init (4); /* < op code */ declare GREATER_EQUAL fixed bin internal static options (constant) init (5); /* >= op code */ declare LESS_EQUAL fixed bin internal static options (constant) init (6); /* <= op code */ declare AND fixed binary internal static options (constant) init (10); /* & op code */ declare OR fixed binary internal static options (constant) init (20); /* | op code */ declare NOT fixed binary internal static options (constant) init (30); /* ^ op code */ declare MINUS fixed binary internal static options (constant) init (40); /* - unary operator code */ declare DOMAIN_VARIABLE fixed binary internal static options (constant) init (50); /* domain id code */ declare ELEMENT fixed bin internal static options (constant) init (60); /* code for constant */ declare OFF bit (1) internal static options (constant) init ("0"b); /* flag reset value */ declare ON bit (1) internal static options (constant) init ("1"b); /* flag set value */ declare BLOCKED fixed binary internal static options (constant) init (2); /* code for blocked file type */ declare UNBLOCKED fixed binary internal static options (constant) init (1); /* code for unblocked file type */ declare BLANK char (1) internal static options (constant) init (" "); /* blank fill constant */ declare max_string_size fixed binary (35) internal static; /* descriptor string size limit */ declare descr_ptr ptr internal static; /* pointer to current descriptor */ declare saved_descr_ptr ptr internal static; /* normal desc pointer temp storage */ dcl decode_dcl_mesg char (8) var internal static; /* "" => normal, else decode_dcl declare message */ declare mrds_rst_rsc_alloc entry (ptr, fixed bin, ptr); /* working area allocation routine */ declare db_model_path char (168) internal static; /* saved db_model pathname */ declare ioa_$rs entry options (variable); /* string building routine */ declare mrds_rst_domain_handler entry (ptr, ptr); /* domain declaration semantic routine */ declare mrds_rst_attribute_handler entry (ptr, ptr); /* attribute declaration semantic routine */ declare mrds_rst_relation_handler entry (ptr, ptr); /* relation declaration semantic routine */ declare mrds_rst_index_handler entry (ptr, ptr); /* index declaration semantic routine */ declare mrds_rst_file_cleanup entry (ptr); /* undeclared file semantic routine */ declare mrds_rst_attribute_cleanup entry (ptr); /* domain default attribute routine */ declare stack_top fixed binary; /* current top of lexical stack */ declare message char (512) varying;/* error message of specifics */ declare message_length fixed binary (21); /* length of error message */ declare mrds_rst_error entry (ptr, fixed binary, fixed binary (35), char (*)); /* error handling routine */ /* note: changing the declaration of multiplier, requires changing the code for the rule (the any_to_any parameters) */ declare multiplier fixed bin (24) internal static aligned; /* string multiplier */ declare source char (sys_info$max_seg_size) based; /* string overlay for getting tokens */ declare sys_info$max_seg_size fixed binary (35) external; /* system maximum segment size */ declare rule fixed binary (24); /* current rule number returned by parser */ declare alternate fixed binary (24); /* current allternate of rule number */ declare max_fixed_bin_17 fixed binary (71) internal static; /* largest 17 bit value */ declare max_fixed_bin_71 fixed binary (71) internal static; /* largest 71 bit value */ declare static_rsc_ptr ptr internal static; /* pointer to restructure control segment */ declare index_list_ptr ptr internal static; /* pointer to list of index information */ declare relation_list_ptr ptr internal static; /* pointer to list of relation information */ declare attribute_list_ptr ptr internal static; /* pointer to list of attribute information */ declare domain_list_ptr ptr internal static; /* pointer to list of domain information */ declare definition_order fixed bin internal static; /* order of attribute definition */ declare key_order fixed bin internal static; /* order of key attribute definition */ declare string_length fixed bin (24) internal static; /* size of bit or char string declaration */ declare string_average_length fixed bin (24) internal static; /* average varying string size */ declare temp_number fixed binary (71); /* storage for number checks */ declare i fixed binary; /* index for initialization loop */ declare saved_precision fixed bin (71) internal static; /* remembered number precision */ declare scale_factor fixed bin (71) internal static; /* remembered number scale value declaration */ declare avg_length_seen bit (1) internal static; /* ON => varying average size declared */ declare size_seen bit (1) internal static; /* on => string size was declared */ declare decode_proc_seen bit (1) internal static; /* on => decode_proc option was declared */ declare encode_proc_seen bit (1) internal static; /* on => encode_proc option was declared */ declare check_seen bit (1) internal static; /* on => check or check_proc option declared */ declare type_seen bit (1) internal static; /* on => a type was declared */ declare representation_seen bit (1) internal static; /* on => representation was declared */ declare base_seen bit (1) internal static; /* on => base was declared */ declare precision_seen bit (1) internal static; /* on => precision was declared */ declare alignment_seen bit (1) internal static; /* on => alignment was declared */ declare fixed_varying_seen bit (1) internal static; /* on => fixed or varying was declared */ declare scale_seen bit (1) internal static; /* on => scale was declared */ declare decode_dcl_seen bit (1) internal static; /* on => decode declaration seen */ declare MULTIPLIER fixed bin internal static options (constant) init (1); /* any to any of multiplier */ declare A_CONSTANT fixed bin internal static options (constant) init (2); /* any to any of constant */ declare NUMBER fixed bin internal static options (constant) init (3); /* number constant to convert */ declare BIT_STRING fixed bin internal static options (constant) init (4); /* bit_string to convert */ declare CHAR_STRING fixed bin internal static options (constant) init (5); /* char_string to convert */ declare RMDB fixed bin internal static options (constant) init (5); /* rmdb fixup */ declare CHILD fixed bin internal static options (constant) init (8); /* child rel dup check */ declare FILE_REL fixed bin internal static options (constant) init (9); /* file rel dup check */ declare ATTRIBUTES fixed bin internal static options (constant) init (10); /* attr dup check */ declare decimal bit (1) internal static; /* on => decimal declared */ declare real bit (1) internal static; /* on => real declared */ declare (addrel, hbound, copy, length) builtin; declare (null, reverse, rtrim, substr) builtin; declare float bit (1) internal static; /* on => float declared */ declare aligned bit (1) internal static; /* on => aligned was declared */ declare nonvarying bit (1) internal static; /* on => nonvarying was declared */ declare temp_index fixed binary; /* storage for stack position of a token */ declare key_attribute bit (1); /* on => attribute is part of primary key */ declare short bit (1) internal static; /* on => short precision */ declare 1 arith_size unal based, /* overlay for scale and precision fields of descriptor */ 2 unused bit (12), 2 scale fixed bin (11), 2 precision fixed binary (11); /* equivalent to bit(12) */ declare 1 string_size unal based, /* overlay for size field in descriptor */ 2 unused bit (12), 2 length fixed binary (23); /* equivalent to bit(24) */ declare name_ptr ptr int static; /* pointer to token space when needed from stack */ declare temp_source_ptr ptr int static; /* pointer to temp token space when to be multiplied */ declare ioa_ entry() options(variable); %include mrds_rst_parse_stack; %include mrds_rst_semantics; %include mdbm_descriptor; %include mrds_rst_rsc; %include mrds_rst_parse_info; %include mdbm_db_model; %include mrds_rst_struct_types; end;  mrds_rst_tree_delete.pl1 04/18/85 1454.7r w 04/18/85 0909.3 64395 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ mrds_rst_tree_delete: procedure (key, rsc_ptr, root_ptr, data_ptr, success); /* HISTORY: originally written by jim gray - - july 1978 */ /* DESCRIPTION: threaded binary tree deletion routine A search is made for the key in the tree specified by the root pointer. If the key is not found, the deletion fails. Otherwise the tree node area is unlinked from the tree, and the space freed */ /* PARAMETERS: key - - (input) word in tree indicating node to be deleted rsc_ptr - - (input) pointer to common working storage root_ptr - - (input/output) pointer to root node of desired tree, may be changed if key is at root node data_ptr - - (output) pointer extracted from data field of deleted node success - - (output) bit value indicating deletion done(on), or attempt to delete node not in tree(off) */ /* basic algorithm simple case - delete node has no right subtree make delete node's left subtree the new descendent of delete node's parent complex case - delete node has a right subtree subcase 1 - delete node's successor is direct descendent replace delete node with successor, giving it the delete node's left subtree subcase 2 - delete node's successor is not a direct descendent same as subcase 1 but additionally successor's parent get's successors right subtree as it's left subtree and successor's right subtree becomes that of the delete node's */ /* get pointer to node to be deleted and to it's parent */ call mrds_rst_tree_search (key, root_ptr, node_ptr, parent_ptr, success); /* if node to be deleted is not found, deletion fails */ if ^success then ; else do; /* node found, save data pointer, and rearrange tree links to eliminate the node */ data_ptr = node_ptr -> node.data; thread = "0"b; /* fix predecessor thread since we are replacing the delete node with it's successor(if it has one), the delete node's predecessor must have its's right thread point to this new node(the delete node's successor) */ if node_ptr -> node.right.thread then ; else call mrds_rst_tree_successor (root_ptr, node_ptr, successor_ptr, successor_parent_ptr, success); if node_ptr -> node.left.thread then ; else do; call mrds_rst_tree_predecessor (root_ptr, node_ptr, predecessor_ptr, predecessor_parent_ptr, success); if node_ptr -> node.right.thread then predecessor_ptr -> node.right.link = node_ptr -> node.right.link; else do; predecessor_ptr -> node.right.link = successor_ptr; end; end; /* if simple case of no inorder successor(right link a thread) then use the left subtree of delete node as his parent's new descendent, when the left link of the delete node is not a thread, else a left thread means that the parent link will become a thread. the left thread of the delete node may be used as this thread unless it points to the parent, in which case the right thread must be used. */ if node_ptr -> node.right.thread then if ^node_ptr -> node.left.thread then successor_ptr = node_ptr -> node.left.link; else do; thread = "1"b; if parent_ptr ^= node_ptr -> node.left.link then successor_ptr = node_ptr -> node.left.link; else successor_ptr = node_ptr -> node.right.link; end; else do; /* complex case - delete node has a successor give the successor node a new left subtree(previously a thread) that is the current delete node's left subtree this is the first step in moving the successor node into the delete node's place in the tree */ successor_ptr -> node.left.link = node_ptr -> node.left.link; successor_ptr -> node.left.thread = node_ptr -> node.left.thread; /* for direct descendent successor, ignore right subtrees */ if node_ptr = successor_parent_ptr then ; else do; /* for successor not a direct descendent, the successor's new right subtree will be that of the delete node's. The successor's old right subtree becomes the left subtree of the successor's old parent */ /* fix successor's parent's threads for case of delete node's right link not a thread, and successor is not direct descendent of delete node, successor node's right link a thread means that the successor node's parent's left link must become a thread to the successor node since the successor node is being made the predecessor of the successor node's parent. also the successor's right thread must be changed to pointer since it will link to delete node's right subtree(known to be nonempty). successor node's right link not a thread means that the successor's parent node's left link will be a pointer set equal to the successor node's right link. (the successor parent gets as his left, the successor's rught subtree) */ if successor_ptr -> node.right.thread then do; successor_parent_ptr -> node.left.thread = "1"b; successor_ptr -> node.right.thread = "0"b; end; else successor_parent_ptr -> node.left.link = successor_ptr -> node.right.link; successor_ptr -> node.right.link = node_ptr -> node.right.link; end; end; /* for all cases, change parent of delete node to point to it's new successor. determine which branch of delete node parent to change. the link from the parent will be a thread only if the delete node's links were both threads */ if node_ptr = parent_ptr -> node.left.link then do; parent_ptr -> node.left.link = successor_ptr; parent_ptr -> node.left.thread = thread; end; else do; parent_ptr -> node.right.link = successor_ptr; parent_ptr -> node.right.thread = thread; end; /* release deleted nodes space */ call mrds_rst_rsc_alloc$free (rsc_ptr, NODE, node_ptr); success = "1"b; end; declare mrds_rst_tree_search entry (char (32) aligned, ptr, ptr, ptr, bit (1)); /* binary tree search */ declare mrds_rst_rsc_alloc$free entry (ptr, fixed bin, ptr); /* working area manager */ declare mrds_rst_tree_successor entry (ptr, ptr, ptr, ptr, bit (1)); declare mrds_rst_tree_predecessor entry (ptr, ptr, ptr, ptr, bit (1)); %include mrds_rst_tree; %include mrds_rst_rsc; %include mrds_rst_struct_types; end;  mrds_rst_tree_insert.pl1 04/18/85 1454.7r w 04/18/85 0909.3 41958 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ mrds_rst_tree_insert: procedure (key, rsc_ptr, root_ptr, node_ptr, success); /* HISTORY: originally written by jim gray - - july 1978 */ /* DESCRIPTION: Threaded binary tree insertion routine Given a pointer to the root of the desired list, a search is made for the key. If the key is found, the insertion fails to avoid duplicating keys. A successful insertion returns a pointer to the new tree node */ /* PARAMETERS: key - - (input) word to be inserted as key in new node rsc_ptr - - (input) pointer to common working storage root_ptr - - (input/output) pointer to root node of tree, will be modified on empty tree insert node_ptr - - (output) pointer to the node just inserted success - - (output) bit value indicating good insertion(on) or failure due to key duplication attempt(off) */ %page; /* get pointer to inorder parent in tree */ call mrds_rst_tree_search (key, root_ptr, node_ptr, parent_ptr, success); /* A search success(key was found) means a duplication of keys is being attempted, return failure */ if success then success = "0"b; /* Normal insertion, get a new list element, and fill in the blanks */ else do; success = "1"b; call mrds_rst_rsc_alloc (rsc_ptr, NODE, node_ptr); node_ptr -> node.key = key; node_ptr -> node.right.thread = "1"b; node_ptr -> node.left.thread = "1"b; node_ptr -> node.data = null (); node_ptr -> node.pad = "0"b; /* Add the new element to the tree. Change the head pointer if empty tree */ if root_ptr ^= null () then ; else do; /* no dummy node for tree head, get new node for it, then make its right link a pointer to itself, and make it's left link a thread to itself thus indicating that the tree is empty */ call mrds_rst_rsc_alloc (rsc_ptr, NODE, root_ptr); root_ptr -> node.right.link = root_ptr; root_ptr -> node.right.thread = "0"b; root_ptr -> node.left.link = root_ptr; root_ptr -> node.left.thread = "1"b; root_ptr -> node.data = null (); root_ptr -> node.pad = "0"b; end; /* dummy head node for tree exists for all cases now, but tree may still be empty(dummy node left link = thread), if so then force the dummy node to be a right parent of the new data node this is done by making the dummy node pointer serve as the new node parent and setting the dummy node key equal to the new node key so the test for descendent direction will cause a left insert to take place */ if ^root_ptr -> node.left.thread then ; else do; parent_ptr = root_ptr; root_ptr -> node.key = key; end; /* good parent within tree, determine if node is right or left descendent. right descendents have a left thread to their direct parent, and a right thread to their inorder successor. left descendents have a right thread to their direct parent, and a left thread to their inorder predecessor */ if key > parent_ptr -> node.key then do; node_ptr -> node.right.link = parent_ptr -> node.right.link; node_ptr -> node.left.link = parent_ptr; parent_ptr -> node.right.link = node_ptr; parent_ptr -> node.right.thread = "0"b; end; else do; node_ptr -> node.left.link = parent_ptr -> node.left.link; node_ptr -> node.right.link = parent_ptr; parent_ptr -> node.left.link = node_ptr; parent_ptr -> node.left.thread = "0"b; end; end; %page; dcl null builtin; dcl mrds_rst_tree_search entry (char (32) aligned, ptr, ptr, ptr, bit (1)); /* binary tree search */ dcl mrds_rst_rsc_alloc entry (ptr, fixed bin, ptr); /* working area manager */ %page; %include mrds_rst_tree; %page; %include mrds_rst_rsc; %page; %include mrds_rst_struct_types; end;  mrds_rst_tree_predecessor.pl1 04/18/85 1454.7r w 04/18/85 0909.3 27252 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ mrds_rst_tree_predecessor: procedure (root_ptr, node_ptr, predecessor_ptr, predecessor_parent_ptr, success); /* HISTORY: originally written by jim gray - - july 1978 */ /* DESCRIPTION: threaded binary tree inorder predecessor retrieval routine given a pointer to the current node in the tree ( set node_ptr = root_ptr to get last tree element ) and a pointer to the root of the tree a pointer to it's inorder predecessor and that nodes parent are returned with a success indication, or when end of tree(no more predecessors) or empty tree is detected, a failure indication is returned */ /* PARAMETERS: root_ptr - - (input) pointer to root of desired tree node_ptr - - (input) pointer to current for which the predecessor is desired predecessor_ptr - - (output) pointer to resulting inorder predecessor of current node predecessor_parent_ptr - - (output) pointer to predecessor node direct tree parent success - - (output) bit value that is on when predecessor found, and off when end of tree or empty tree is detected */ /* no current node means no predecessor */ if node_ptr = null () then success = "0"b; else do; /* current node exists, if it's left link is a thread it is either a pointer to the root meaning no more predecessors (or empty tree when node_ptr was root_ptr) or it points to the current node's inorder predecessor */ predecessor_parent_ptr = node_ptr; predecessor_ptr = node_ptr -> node.left.link; if node_ptr -> node.left.thread then if predecessor_ptr = root_ptr then success = "0"b; else success = "1"b; else do; /* current node's left link is not a thread, go left from current node's left descendent until a right thread is found and return it's owner as the inorder predecessor */ success = "1"b; do while (^predecessor_ptr -> node.right.thread); predecessor_parent_ptr = predecessor_ptr; predecessor_ptr = predecessor_ptr -> node.right.link; end; end; end; dcl null builtin; %include mrds_rst_tree; end;  mrds_rst_tree_search.pl1 04/18/85 1454.7r w 04/18/85 0909.3 27855 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ mrds_rst_tree_search: procedure (key, root_ptr, node_ptr, parent_ptr, success); /* HISTORY: originally written by jim gray - - july 1978 */ /* DESCRIPTION: Threaded binary tree search Given a pointer to the desired list, do a binary search for the key. Return either a not found indication, or a found indication with a pointer to the key node, and a pointer to it's parent */ /* PARAMETERS: key - - (input) word to be searched for as key to tree node root_ptr - - (input) pointer to root node of desired tree node_ptr - - (output) pointer to node containing key when found, else root pointer pointer parent_ptr - - (output) pointer to direct tree parent when key node found, else pointer to prospective parent for insertion of key success - - (output) bit value indicating key was found in tree(on), or that place for it's insertion was found(off) */ /* Initialize search loop note: parent_ptr is root_ptr when no dummy head exists, or when the dummy head node left link is a thread thus indicating a empty tree */ parent_ptr = root_ptr; success = "0"b; /* if dummy node at head of tree missing, we fail since tree was never built */ if root_ptr = null () then ; else do; node_ptr = root_ptr -> node.left.link; thread = root_ptr -> node.left.thread; /* Search the tree while the data key is not found, and branches remain to be searched . failure to make even one loop pass means the tree is empty, because the dummy head node left link is a thread to itself */ do while (^thread & ^success); /* Branch left for smaller or right for larger keys. If key matches, note success and remember pointers. */ if key > node_ptr -> node.key then do; thread = node_ptr -> node.right.thread; parent_ptr = node_ptr; node_ptr = node_ptr -> node.right.link; end; else if key < node_ptr -> node.key then do; thread = node_ptr -> node.left.thread; parent_ptr = node_ptr; node_ptr = node_ptr -> node.left.link; end; else success = "1"b; end; end; dcl null builtin; %include mrds_rst_tree; end;  mrds_rst_tree_successor.pl1 04/18/85 1454.7r w 04/18/85 0909.3 27981 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ mrds_rst_tree_successor: procedure (root_ptr, node_ptr, successor_ptr, successor_parent_ptr, success); /* HISTORY: originally written by jim gray - - july 1978 */ /* DESCRIPTION: threaded binary tree inorder successor retrieval routine given a pointer to the current node in the tree ( set node_ptr = root_ptr to get first tree element ) and a pointer to the root of the tree a pointer to it's inorder successor and that nodes parent are returned with a success indication, or when end of tree(no more successors) or empty tree is detected, a failure indication is returned */ /* PARAMETERS: root_ptr - - (input) pointer to root of desired tree node_ptr - - (input) pointer to current for which the successor is desired successor_ptr - - (output) pointer to resulting inorder successor of current node successor_parent_ptr - - (output) pointer to successor node direct tree parent success - - (output) bit value that is on when successor found, and off when end of tree or empty tree is detected */ /* no current node means no successor */ if node_ptr = null () then success = "0"b; else do; /* current node exists, if it's right link is a thread it is either a pointer to the root meaning no more successors or it points to the current node's inorder successor */ successor_parent_ptr = node_ptr; successor_ptr = node_ptr -> node.right.link; if node_ptr -> node.right.thread then if successor_ptr = root_ptr then success = "0"b; else success = "1"b; else do; /* current node's right link is not a thread, go left from current node's right descendent until a left thread is found and return it's owner as the inorder successor */ do while (^successor_ptr -> node.left.thread); successor_parent_ptr = successor_ptr; successor_ptr = successor_ptr -> node.left.link; end; /* if pointer is still to root, the dummy head node left link was a thread indicating an empty tree */ if successor_ptr = root_ptr then success = "0"b; else success = "1"b; end; end; dcl null builtin; %include mrds_rst_tree; end;  restructure_mrds_db.pl1 10/16/86 1551.9rew 10/16/86 1143.2 294525 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ restructure_mrds_db: rmdb: proc; /****^ HISTORY COMMENTS: 1) change(85-12-03,Spitzer), approve(85-12-03,MCR7311), audit(86-09-15,Gilcrease), install(86-10-16,MR12.0-1187): initialize added ctl_info fields, change hardcoded path to mrds_data_$rmdb_info_directory. Add -force/-no_force and -relation_type control arguments. END HISTORY COMMENTS */ /* . BEGIN_DESCRIPTION This command is used to enter the restructure_mrds_db (rmdb) subsystem. It sets up a subsystem environment as determined by control arguments and then enters the subsystem by calling ssu_$listen. . END_DESCRIPTION Known Bugs: Other Problems: . HISTORY 82-03-09 Davids: Written 82-04-27 Davids: to create a new directory under the user . supplied temp dir or the pdir and use that new . dir as the temp dir. This allows cleanups to be . very simple, safe and complete - just delete . the created temp dir. 82-05-03 Davids: modified so that the request ready_db is called . via ssu_$execute_string if a database path is . supplied on the rmdb command line. 82-06-01 Davids: modified so that abbrev is off by default 82-06-07 Davids: modified so that negative quiesce_wait_times are . handled correctly as are times larger than those . that can fit in a fixed bin variable (>131071). . Also so that -profile imples -abbrev and so that . if a wait time is supplied but a database path . is not an error is reported. 82-06-09 Harvey: modified so that iteration will always be done  . by ssu_. 82-06-22 Davids: removed some declared by never referenced . variables, declared some variables that were . being implicitly declared and changed some line . formats to prevent wrap-arround. 82-07-15 Davids: modified so that the prompt_string is not . assigned from the arg if the arg is longer than . the prompt string. instead it is assign from a . substr. This prevents a stringsize condition. 82-10-19 Harvey: modified to allow db path to be anywhere on the . rmdb command line without the -pn argument. 83-05-24 Davids: Modified call to rmdb_free_db in the internal proc clean_up to include the rmdb_control.saved_res_version_ptr argument 83-10-04 Benjamin: Added call to ssu_$add_request_table. 84-09-10 Thanh Nguyen: Modified call ssu_requests_$standard_requests to ssu_request_tables_$standard_requests. 84-10-23 Paul Benjamin: Changed to only call free_db if rmdb readied it to begin with. Added call to ssu_$add_info_dir. 85-01-23 Paul Benjamin: Fixed the bug where the temp_dir always has ring brackets of 4,4. Now uses (V,V) where V = validation level. */ /* COMMAND ARGUMENTS (based) */ dcl arg char (arg_len) based (arg_ptr); /* EXTERNAL STATIC */ dcl error_table_$bad_arg fixed bin (35) external static; dcl error_table_$badcall fixed bin (35) external static; dcl error_table_$bad_conversion fixed bin (35) external static; dcl error_table_$bigarg fixed bin (35) external static; dcl error_table_$inconsistent fixed bin (35) ext static; dcl error_table_$noarg fixed bin (35) external static; dcl error_table_$not_act_fnc fixed bin (35) external static; dcl iox_$user_input ptr external static; dcl mrds_data_$rmdb_info_directory char (168) ext static; dcl rmdb_rq_tb_$rmdb_rq_tb_ fixed bin (35) external static; dcl ssu_et_$subsystem_aborted fixed bin (35) external static; dcl ssu_info_directories_$standard_requests char (168) external; dcl ssu_request_tables_$standard_requests bit (36) aligned external static; dcl sys_info$max_seg_size fixed bin (35) external static; /* ENTRIES */ dcl absolute_pathname_ entry (char (*), char (*), fixed bin (35)); dcl active_fnc_err_ entry options (variable); dcl com_err_ entry () options (variable); dcl cu_$af_arg_count entry (fixed bin, fixed bin (35)); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl cu_$level_get entry (fixed bin); dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl delete_$path entry (char (*), char (*), bit (6), char (*), fixed bin (35)); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl get_group_id_ entry () returns (char (32)); dcl get_pdir_ entry () returns (char (168)); 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_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)); dcl mdbm_util_$cleanup_temp_dir entry (char (*), fixed bin (35)); dcl mdbm_util_$xref_destroy entry (ptr, char (*), char (*), char (*), fixed bin (35)); dcl rmdb_free_db entry (char (168), ptr, char (500), fixed bin (35)); dcl ssu_$add_info_dir entry (ptr, char (*), fixed bin, fixed bin (35)); dcl ssu_$add_request_table entry (ptr, ptr, fixed bin, fixed bin (35)); dcl ssu_$create_invocation entry (char (*), char (*), ptr, ptr, char (*), ptr, fixed bin (35)); dcl ssu_$destroy_invocation entry (ptr); dcl ssu_$execute_line entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl ssu_$execute_string entry (ptr, char (*), fixed bin (35)); dcl ssu_$listen entry (ptr, ptr, fixed bin (35)); dcl ssu_$print_blast entry (ptr, ptr, fixed bin, char(*) var, fixed bin(35)); dcl ssu_$print_message entry options (variable); dcl ssu_$set_abbrev_info entry (ptr, ptr, ptr, bit (1) aligned); dcl ssu_$set_prompt entry (ptr, char (64) varying); dcl ssu_$set_prompt_mode entry (ptr, bit (*)); dcl unique_chars_ entry (bit (*)) returns (char (15)); /* CONDITIONS */ dcl cleanup condition; dcl size condition; /* INTERNAL AUTOMATIC */ dcl abbrev_processing bit (1); /* true if abbrev processing is to be done */ dcl abbrev_profile_dname char (168); /* directory name of profile to use for abbrev processing */ dcl abbrev_profile_ename char (32); /* entry name of profile to use for abbrev processing */ dcl abbrev_profile_expected bit (1); /* true if profile path expected as the next argument */ dcl abbrev_profile_path char (168); /* profile path argument */ dcl abbrev_profile_ptr ptr; /* pointer to abbrev profile */ dcl abbrev_profile_supplied bit (1); /* true if profile path supplied */ dcl arg_len fixed bin (21); /* length of an argument */ dcl arg_ptr ptr; /* pointer to an argument */ dcl code fixed bin (35); /* standard error code */ dcl db_path char (168); /* database path supplied as an argument */ dcl db_path_expected bit (1); /* true if a database path is expected as the next argument */ dcl db_path_supplied bit (1); /* true if a database path is supllied as an argument */ dcl error_message char (500); /* error message returned from rmdb_ready_db and rmdb_free_db */ dcl force_sw bit (1) aligned; /* if create the db without the query */ dcl i fixed bin; /* loop index */ dcl nargs fixed bin; /* number of arguments the command was called with */ dcl prompt_string char (64) varying; /* prompt string argument supplied by the caller */ dcl prompt_string_expected bit (1); /* true if a prompt string is expected as the next argument */ dcl prompt_string_supplied bit (1); /* true if a prompt string has been supplied as an argument */ dcl prompting bit (1); /* true if prompting is to be done */ dcl quiesce_wait_time fixed bin; /* how many seconds the caller will wait to try to quiesce the database, supplied as an argument */ dcl quiesce_wait_time_expected bit (1); /* true if a wait time is expected as the next argument */ dcl quiesce_wait_time_supplied bit (1); /* true if a wait time has been supplied as an argument */ dcl ready_request_string char (512) varying;/* string passed to ready_db request */ dcl relation_type char (32); dcl relation_type_expected bit (1) aligned; /* true if a relation type is expected as the next argument */ dcl relation_type_supplied bit (1) aligned; /* true if a relation type has been supplied as an argument */ dcl relation_modes char (256); dcl request_string_expected bit (1); /* true if a request sring is expected as the next argument */ dcl request_string_len fixed bin (21); /* length of the request string */ dcl request_string_ptr ptr; /* pointer to the requerst string */ dcl request_string_supplied bit (1); /* true if a request string has been supplied */ dcl ring_array (3) fixed bin (3); /* ring brackets for the tem_dir_sub_dir_name dir */ dcl sci_ptr ptr; /* subsystem control info pointer */ dcl temp_dir_abs_path char (168); /* absoutute path to the user supplied temp dir or the pdir */ dcl temp_dir_path char (168); /* temp dir path - needed if process dir does not have enough quota to set up working space for very large databases */ dcl temp_dir_path_expected bit (1); /* true if a temp dir path is expected as the next argument */ dcl temp_dir_path_supplied bit (1); /* true if a temp dir path has been supplied as an argument */ dcl temp_dir_sub_dir_name char (32); /* name of the dir created under the temp_dir_abs_path which will house all the temp segments */ dcl validation_level fixed bin; /* the user's current validation level */ dcl 01 rmdb_control like rmdb_ctl; /* automatic copy of the rmdb_ctl structure */ /* CONSTANTS */ dcl BLAST_MESSAGE char (72) varying init ( "Type ""help rmdb"" to review new features in restructure_mrds_db."); dcl LAST_IN_SEQUENCE fixed bin internal static options (constant) init (9999); /* passed to ssu to put standard_requests stuff last */ dcl MAX_PROMPT_STRING_LEN fixed bin internal static options (constant) init (64); /* maximum length of the prompt string */ dcl OFF bit (1) internal static options (constant) init ("0"b); dcl ON bit (1) internal static options (constant) init ("1"b); dcl PROC_NAME char (4) internal static options (constant) init ("rmdb"); /* use the shorter of the two names to keep messages short */ /* BUILTINS */ dcl addr builtin; dcl char builtin; dcl empty builtin; dcl index builtin; dcl null builtin; dcl rtrim builtin; dcl substr builtin; dcl verify builtin; /* BASED */ dcl work_area area (sys_info$max_seg_size) based (rmdb_control.work_area_ptr); /* INCLUDE FILES */ %page; %include access_mode_values; %page; %include mrds_rmdb_ctl; %page; %include ssu_prompt_modes; /* Determine the number of arguments that this command was called with, it may be called with any number. Also determine if this command was called as a command or an active function. An active function call is an error, it should be reported and then the system exited. Since nothing has been done no cleanup is needed. */ call cu_$af_arg_count (nargs, code); if code ^= error_table_$not_act_fnc then do; if code = 0 then call active_fnc_err_ (error_table_$badcall, PROC_NAME, "^/This command cannot be called as an active function"); else call com_err_ (code, PROC_NAME, "^/An error occured while trying to determine the number of arguments"); goto exit_rmdb; end; /* Assign initial values. */ rmdb_control.version = RMDB_CTL_VERSION_1; /* set the version of rmdb_ctl structure */ rmdb_control.rmdb_version = "2.0"; /* the version of the subsystem */ rmdb_control.absolute_db_path = ""; /* no path is known yet */ rmdb_control.temp_dir_path = ""; /* no temp_dir path is known */ rmdb_control.work_area_ptr = null; /* no work area has been set up yet */ rmdb_control.db_model_ptr = null; /* since the path is not known there is no pointer */ /* the relmgr_entries will be set in rmdb_ready_db */ /* and will not be used until after they are set */ rmdb_control.crossref_file_info.iocb_ptr = null; /* iocb to keyed vfile containing th db crossreference */ rmdb_control.crossref_file_info.name = ""; /* entryname of crossreference file */ db_path_supplied = OFF; /* flags indicating what information */ prompt_string_supplied = OFF; /* the user supplied */ abbrev_profile_supplied = OFF; request_string_supplied = OFF; relation_type_supplied = OFF; quiesce_wait_time_supplied = OFF; temp_dir_path_supplied = OFF; prompting = ON; /* states that by default are on for the subsystem */ abbrev_processing = OFF; /* states that are off */ db_path_expected = OFF; /* No user arguments are expected yet */ prompt_string_expected = OFF; abbrev_profile_expected = OFF; request_string_expected = OFF; relation_type_expected = OFF; force_sw = OFF; quiesce_wait_time_expected = OFF; temp_dir_path_expected = OFF; relation_modes = ""; sci_ptr = null (); /* loop through all the user supplied arguments 1 at a time. Control arguments expecting an argument set a flag indicating that that argument is next, this is so that the call to cu_$arg_ptr and its error handling occurs in only 1 place. The first argument is special cased in that if it is not a control argument it is assumed to be the database path. There are 3 kinds of arguments: . arguments that control the state of the subsystem, i.e. . prompting on or off . arguments that set values to modify the subsystem, i.e. . set a new prompting string. these may also change the . state of the subsystem, i.e. setting a new prompt . string also turns prompting on . arguments that are the new values, i.e. "new prompt:" Arguments may occur in any order and may be over ruled by later arguments, i.e. the profile path associated with the last -profile control argument will be the profile used by the subsystem. */ do i = 1 to nargs; call cu_$arg_ptr (i, arg_ptr, arg_len, code); if code ^= 0 then do; call com_err_ (code, PROC_NAME, "Could not get argument ^i", i); goto exit_rmdb; end; if i = 1 & index (arg, "-") ^= 1 then db_path_expected = ON; if db_path_expected | prompt_string_expected | abbrev_profile_expected | request_string_expected | quiesce_wait_time_expected | temp_dir_path_expected | relation_type_expected then do; /* arguments for the control arguments */ if index (arg, "-") = 1 & ^(verify (arg, "-0123456789.") = 0 & quiesce_wait_time_expected) /* if a control argument is expecting an argument and */ /* another control argument appears it should be reported */ /* as an error, negative numbers for a wait time should */ /* not be confused as a control argument */ then call report_missing_args; /* expected flags are global */ else if db_path_expected then do; db_path_expected = OFF; db_path_supplied = ON; db_path = arg; end; else if prompt_string_expected then do; prompt_string_expected = OFF; prompt_string_supplied = ON; if arg_len <= MAX_PROMPT_STRING_LEN then prompt_string = arg; else do; prompt_string = substr (arg, 1, MAX_PROMPT_STRING_LEN); call com_err_ (error_table_$bigarg, PROC_NAME, "Prompt string ^a is longer than the maximum allowed length of ^i" || "^/Prompt will be truncated to ^a^/", arg, MAX_PROMPT_STRING_LEN, prompt_string); end; end; else if abbrev_profile_expected then do; abbrev_profile_expected = OFF; abbrev_profile_supplied = ON; abbrev_profile_path = arg; end; else if relation_type_expected then do; relation_type_expected = OFF; relation_type_supplied = ON; relation_type = arg; if i = nargs then relation_modes = ""; else do; call cu_$arg_ptr (i+1, arg_ptr, arg_len, code); if index (arg, "-") ^= 1 then do; relation_modes = arg; i = i + 1; end; end; end; else if request_string_expected then do; request_string_expected = OFF; request_string_supplied = ON; request_string_ptr = arg_ptr; request_string_len = arg_len; end; else if quiesce_wait_time_expected then do; quiesce_wait_time_expected = OFF; quiesce_wait_time_supplied = ON; on size begin; call com_err_ (error_table_$bad_conversion, PROC_NAME, "^/The size of the quiesce wait time ^a " || "is larger than the maximum of 131071.", arg); goto exit_rmdb; end; (size): quiesce_wait_time = cv_dec_check_ (arg, code); revert size; if code ^= 0 then do; call com_err_ (error_table_$bad_conversion, PROC_NAME, "Could not convert ^a into an integer representing the quiesce wait-time", arg); goto exit_rmdb; end; if quiesce_wait_time < 0 then do; call com_err_ (error_table_$bad_conversion, PROC_NAME, "^/The quiesce wait time ^a is negative, wait times must be >= 0.", arg); goto exit_rmdb; end; end; else if temp_dir_path_expected then do; temp_dir_path_expected = OFF; temp_dir_path_supplied = ON; temp_dir_path = arg; end; end; /* control arguments which expect arguments */ else if arg = "-prompt" | arg = "-pmt" then do; prompt_string_expected = ON; prompting = ON; /* for this case it also sets a state */ end; else if arg = "-profile" | arg = "-pf" then do; abbrev_profile_expected = ON; abbrev_processing = ON; /* for this case it also sets a state */ end; else if arg = "-pathname" | arg = "-pn" then db_path_expected = ON; else if arg = "-request" | arg = "-rq" then request_string_expected = ON; else if arg = "-quiesce_wait_time" | arg = "-qwt" then quiesce_wait_time_expected = ON; else if arg = "-temp_dir" | arg = "-td" then temp_dir_path_expected = ON; /* control arguments which set states */ else if arg = "-no_prompt" | arg = "-npmt" then prompting = OFF; else if arg = "-force" | arg = "-fc" then force_sw = ON; else if arg = "-no_force" | arg = "-nfc" then force_sw = OFF; else if arg = "-relation_type" | arg = "-rt" then relation_type_expected = ON; else if arg = "-abbrev" | arg = "-ab" then abbrev_processing = ON; else if arg = "-no_abbrev" | arg = "-nab" then abbrev_processing = OFF; else if index (arg, "-") ^= 1 /* database path */ then do; db_path_supplied = ON; db_path = arg; end; /* unknown control argument */ else do; call com_err_ (error_table_$bad_arg, PROC_NAME, "Argument ^i (^a) is unrecognized", i, arg); goto exit_rmdb; end; end; /* Once all the arguments have been processed a check must be made to be sure that all control argument arguments have been supplied. Note that in general it is not necessary for a database path to have been supplied unless the -path control arg was used. If report_missing_args returns then no arguments were missing and everything is ok. If an argument is missing report_missing_args will report it and goto exit_rmdb. */ call report_missing_args; /* expected flags are global */ /* If a quiesce_wait_time was supplied but a database path was not supplied it will be considered as an inconsistent set of arguments and an error will be reported. */ if quiesce_wait_time_supplied & ^db_path_supplied then do; call com_err_ (error_table_$inconsistent, PROC_NAME, "^/A wait time can be supplied only if a database to be readied is also supplied"); goto exit_rmdb; end; /* Creates a temporary directory in the user supplied temporary dir or pdir if the user did not supply a temporary dir. This makes it easy to cleanup after the invocation - just delete the entire temp dir. Creates a temporary segment in the new temporary dir to be used as a work area for the rmdb requests. The system routine get_temp_segment has not been used because it always creates the segments in the pdir and the mrds routine mu_temp_segments has not been used because it requires an open data base. Note that from this point on any errors which will cause this command to return to the user will have to first call the clean_up procedure. Likewise a cleanup condition handler must be established incase it is signaled after this point. */ on cleanup call clean_up; if ^temp_dir_path_supplied then temp_dir_abs_path = get_pdir_ (); else do; call absolute_pathname_ (temp_dir_path, temp_dir_abs_path, code); if code ^= 0 then do; call com_err_ (code, PROC_NAME, "^/Could not determine the absolute path of the given temp_dir path (^a)", temp_dir_path); goto cleanup_and_exit_rmdb; end; end; temp_dir_sub_dir_name = unique_chars_ (OFF) || ".rmdb"; call cu_$level_get (validation_level); ring_array (*) = validation_level; call hcs_$append_branchx (temp_dir_abs_path, temp_dir_sub_dir_name, SMA_ACCESS_BIN, ring_array, get_group_id_ (), 1, 0, 0, code); if code ^= 0 then do; call com_err_ (code, PROC_NAME, "^/Could not create the temp dir ^a>^a, in the temporary directory ^a", temp_dir_abs_path, temp_dir_sub_dir_name, temp_dir_abs_path); goto cleanup_and_exit_rmdb; end; rmdb_control.temp_dir_path = rtrim (temp_dir_abs_path) || ">" || temp_dir_sub_dir_name; call hcs_$make_seg (rmdb_control.temp_dir_path, unique_chars_ ("0"b) || ".rmdb", "", RW_ACCESS_BIN, rmdb_control.work_area_ptr, code); if code ^= 0 then do; call com_err_ (code, PROC_NAME, "^/Could not make a scratch segment in the dir ^a", temp_dir_abs_path); goto cleanup_and_exit_rmdb; end; work_area = empty (); /* Create the subsystem invocation. */ call ssu_$create_invocation (PROC_NAME, (rmdb_control.rmdb_version), addr (rmdb_control), addr (rmdb_rq_tb_$rmdb_rq_tb_), mrds_data_$rmdb_info_directory, sci_ptr, code); if code ^= 0 then do; call com_err_ (code, PROC_NAME, "Could not invoke the rmdb subsystem"); goto cleanup_and_exit_rmdb; end; /* Add the standard request table supplied by ssu_, to get things like do, if, answer, exec_com, etc. */ call ssu_$add_request_table (sci_ptr, addr (ssu_request_tables_$standard_requests), LAST_IN_SEQUENCE, code); if code ^= 0 then goto cleanup_and_exit_rmdb; /* And the info segs for 'em */ call ssu_$add_info_dir (sci_ptr, ssu_info_directories_$standard_requests, LAST_IN_SEQUENCE, code); if code ^= 0 then goto cleanup_and_exit_rmdb; /* If a database path has been supplied then the database must be readied for restructuring. The request level routine rmdb_rq_ready_db is called (via ssu_) instead of the subroutine level rmdb_ready_db because the subroutine level does not know about ssu_ and there exists the possiblility that ready will have to call an rmdb request in order to make an inconsistent db consistent. If the caller did not supply a maximum amount of time to wait for the data base to be quiesced a default wait time of 10 seconds is used. */ if db_path_supplied then do; ready_request_string = "ready_db " || rtrim (db_path); if quiesce_wait_time_supplied then ready_request_string = ready_request_string || " -quiesce_wait_time " || rtrim (char (quiesce_wait_time)); if relation_type_supplied then ready_request_string = ready_request_string || " -relation_type " || rtrim (relation_type) || " " || rtrim (relation_modes); if force_sw then ready_request_string = ready_request_string || " -force"; call ssu_$execute_string (sci_ptr, (ready_request_string), code); if code ^= 0 then goto cleanup_and_exit_rmdb; end; /* abbrev processing is off by default. ssu will interpret a null abbrev_profile_ptr to mean that the user's default profile should be used. If a profile path is specified a pointer to it is obtained to pass to ssu. */ if abbrev_processing then do; abbrev_profile_ptr = null (); if abbrev_profile_supplied then do; call expand_pathname_$add_suffix (abbrev_profile_path, "profile", abbrev_profile_dname, abbrev_profile_ename, code); if code ^= 0 then do; call com_err_ (code, PROC_NAME, "Could not expand the profile path ^a", abbrev_profile_path); goto cleanup_and_exit_rmdb; end; call hcs_$initiate (abbrev_profile_dname, abbrev_profile_ename, "", 0, 0, abbrev_profile_ptr, code); if abbrev_profile_ptr = null () then do; call com_err_ (code, PROC_NAME, "Could not initiate the profile at ^a>^a", abbrev_profile_dname, abbrev_profile_ename); goto cleanup_and_exit_rmdb; end; end; call ssu_$set_abbrev_info (sci_ptr, abbrev_profile_ptr, null (), "1"b); end; /* If the user supplies a prompt string than this string is given to ssu, normally ssu will use the subsystem name. Note that seting the prompt string and having prompts are independent. The user may set a prompt string and turn prompts off (perhaps to be turned on later). */ /* Set up and execute print_blast. */ call ssu_$print_blast (sci_ptr, codeptr (rmdb), 3, BLAST_MESSAGE, code); if prompt_string_supplied then call ssu_$set_prompt (sci_ptr, prompt_string); if ^prompting then call ssu_$set_prompt_mode (sci_ptr, DONT_PROMPT); /* If the user supplied a request string it is executed here. Note that most errors during the execution of the request are not considered as fatal errors for the whole subsystem. The error is merely reported. The exception is the subsystem_aborted error which does cause the subsystem to be aborted and is probably caused by a quit in the request string. */ if request_string_supplied then do; call ssu_$execute_line (sci_ptr, request_string_ptr, request_string_len, code); if code = ssu_et_$subsystem_aborted then goto cleanup_and_exit_rmdb; else if code ^= 0 then call ssu_$print_message (sci_ptr, code); end; /* the call to ssu_$listen essentially puts the user at subsystem request level. If listen returns with the subsystem aborted error it means that either the user requested to quit or some other subsystem error occured which was reported by the subsystem before it returned. If some other error occured it must be reported. Regardless of how listen returns the command must clean itself up before returning to the caller. */ call ssu_$listen (sci_ptr, iox_$user_input, code); if code ^= ssu_et_$subsystem_aborted then call com_err_ (code, PROC_NAME, "Subsystem aborted abnormally"); cleanup_and_exit_rmdb: call clean_up; exit_rmdb: return; report_missing_args: proc; /* If any of the expected flags is set it indicates that an argument to a control arg has not been supplied. Report the omission to the caller and exit the command. If this procedure does a return it means that no arguments were missing. */ /* GLOBAL db_path_expected true if the next argument should be a database path prompt_string_expected true if the next argument should be a prompt string abbrev_profile_expected true if the next argument should be a profile path relation_type_expected true if the next argument should be a relation type request_string_expected true if the next argument should be a request string quiesce_wait_time_expected true if the next argument should be a wait time temp_dir_path_expected true if the next argument should be a temp dir path */ if db_path_expected then do; call com_err_ (error_table_$noarg, PROC_NAME, "The -pathname (-pn) control arg was given but no pathname was supplied"); goto exit_rmdb; end; if prompt_string_expected then do; call com_err_ (error_table_$noarg, PROC_NAME, "The -prompt (-pmt) control arg was given but no prompt was supplied"); goto exit_rmdb; end; if abbrev_profile_expected then do; call com_err_ (error_table_$noarg, PROC_NAME, "The -profile (-pf) control arg was given but no profile was supplied"); goto exit_rmdb; end; if request_string_expected then do; call com_err_ (error_table_$noarg, PROC_NAME, "The -request (-rq) control arg was given but no request string was supplied"); goto exit_rmdb; end; if quiesce_wait_time_expected then do; call com_err_ (error_table_$noarg, PROC_NAME, "The -quiesce_wait_time (-qwt) control arg was given but no wait time was supplied"); goto exit_rmdb; end; if temp_dir_path_expected then do; call com_err_ (error_table_$noarg, PROC_NAME, "The -temp_dir (-td) control arg was given but no temp dir path was supplied"); goto exit_rmdb; end; if relation_type_expected then do; call com_err_ (error_table_$noarg, PROC_NAME, "The -relation_type (-rt) control arg was given but no relation types was supplied"); goto exit_rmdb; end; return; end report_missing_args; clean_up: proc; /* To exit this command the rmdb subsystem must be destroyed if it has been invoked, the readied database must be freed and the temp dir that was created under the users temp dir (or the pdir) must be deleted. */ /* GLOBAL code standard error code PROC_NAME the name of this command rmdb_control control info structure sci_ptr subsystem control info pointer */ /* AUTOMATIC */ dcl temp_dir_dir char (168); /* path to either the pdir or the user supplied temp dir */ dcl temp_dir_name char (32); /* name of the rmdb created temp dir undet temp_dir_dir */ if sci_ptr ^= null () then call ssu_$destroy_invocation (sci_ptr); if rmdb_control.absolute_db_path ^= "" /* this is set only if a data base has been readied */ & rmdb_control.flags.database_readied_by_rmdb/* only free it if we readied it */ then do; call rmdb_free_db (rmdb_control.absolute_db_path, rmdb_control.saved_res_version_ptr, error_message, code); if code ^= 0 then call com_err_ (code, PROC_NAME, error_message); end; if rmdb_control.crossref_file_info.iocb_ptr ^= null then call mdbm_util_$xref_destroy (rmdb_control.crossref_file_info.iocb_ptr, rmdb_control.temp_dir_path, rmdb_control.crossref_file_info.name, (""), (0)); if rmdb_control.temp_dir_path ^= "" then do; call expand_pathname_ (rmdb_control.temp_dir_path, temp_dir_dir, temp_dir_name, code); if code ^= 0 then call com_err_ (code, PROC_NAME, "^/Could not expand the temp_dir path."); else do; call mdbm_util_$cleanup_temp_dir (rmdb_control.temp_dir_path, (0)); call delete_$path (temp_dir_dir, temp_dir_name, "101000"b, "rmdb", code); if code ^= 0 then call com_err_ (code, PROC_NAME, "^/Could not delete the temporary directory ^a", rmdb_control.temp_dir_path); end; end; return; end clean_up; end restructure_mrds_db;  rmdb_add_rmdb_history.pl1 10/16/86 1551.9rew 10/16/86 1142.9 84393 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ rmdb_add_rmdb_history: add_rmdb_history: proc (db_model_ptr, type_of_object_restructured, object_name, operation, secondary_object_name, error_message, 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): Add new operations create_(attribute domain), delete_(attribute domain), rename_(attribute domain) END HISTORY COMMENTS */ /* . BEGIN_DESCRIPTION This procedure is used to record a database restructuring event in the data model by allocating a rmdb_history_entry structure in the data model and linking it to the end of a chain of such structures which record previous events. The chain is doubly linked with offsets to the first and last elements in the data model. There are three objects in a mrds database that can be restructured: domains, attributes and relations. Things like indices and edit_procs are considered part of relations and domains respectively. This code has developed it own data structures to record a restructuring event rather than using the changer structures which are already in the data and file models and were designed to be used when restructuring was implemented. The reason for this is two fold. First the changer structures are associated with each of the domain, attribute, and relation structures therefore certain types of restructuring like adding a secondary index to a relation would see two changer structures allocated, one for the relation and one for the attribute. Second the changer structures record only the date-time of the event and the person id who did it but not what was done. The changer structures where not removed from the data and file models when this code was implemented becuase one only 1 structure is actually allocated and that one contains the date-time of the creation and the creator of the database which is still very usefull. Second for compatability reasons the data base and file models must remain the same size so the 18 bits used to store the offset to the structure would still have to be in the models. quits are delayed while the datamodel is actually being updated. . END_DESCRIPTION Known Bugs: Other Problems: . HISTORY 82-04-13 Davids: written 82-05-04 Davids: modified so that the rmdb_history_entry list . is doubly linked with offsets to the first . and last entries in the data model. 82-06-22 Davids: declared some implicitly declared builtins, . changed call to clock_ to a reference to the . pl1 clock builtin, and put a quit_delay . sequence around the allocate and link code. 82-07-07 Roger Lackey: added rmdb_add_history entry point for binding. */ /* PARAMETERS */ dcl db_model_ptr ptr; /* (input) pointer to the database model */ dcl type_of_object_restructured fixed bin; /* (input) index indicating the type of . object that has been restructured */ dcl object_name char (32); /* (input) name of the object that has been restructured */ dcl operation fixed bin; /* (input) index indicating the . type of restructuring that was done */ dcl secondary_object_name char (32); /* (input) name of any secondary object involved with . the restructuring, i.e. attr name that was indexed */ dcl error_message char (500); /* (output) standard error message */ dcl code fixed bin (35); /* (output) standard error code */ /* INTERNAL AUTOMATIC */ dcl last_rmdb_history_entry_ptr ptr; /* pointer to last entry in history list */ dcl new_rmdb_history_entry_ptr ptr; /* pointer to the structure just allocated */ dcl quit_signaled bit (1); /* true if the user hit a quit during the execution of the critical region */ /* INTERNAL CONSTANTS */ dcl NULL_OFFSET bit (18) init ("111111111111111111"b) internal static options (constant); /* EXTERNAL CONSTANTS */ dcl error_table_$action_not_performed fixed bin (35) ext static; dcl error_table_$area_too_small fixed bin (35) ext static; dcl sys_info$max_seg_size fixed bin (35) ext static; /* ENTRIES */ dcl get_group_id_ entry () returns (char (32)); dcl ioa_$rs entry () options (variable); /* CONDITIONS */ dcl area condition; dcl quit condition; /* BUILTINS */ dcl addr builtin; dcl clock builtin; dcl fixed builtin; dcl length builtin; dcl pointer builtin; dcl rel builtin; /* INCLUDES */ %page; %include mdbm_db_model; %page; %include rmdb_history_entry; /* The user has not yet hit a quit */ quit_signaled = "0"b; /* Check the ranges on the object_type and operation to be sure that garbage will not be stored in the model. */ if type_of_object_restructured < 1 | type_of_object_restructured > RMDB_REL_TYPE then do; code = error_table_$action_not_performed; call ioa_$rs ("type of object restructured indicator <^i> not within range of 1 -- ^i", error_message, length (error_message), type_of_object_restructured, RMDB_REL_TYPE); goto exit_rmdb_add_rmdb_history; end; else if operation < 1 | operation > RMDB_RN_REL_OP then do; code = error_table_$action_not_performed; call ioa_$rs ("type of operation indicator <^i> not within range of 1 -- ^i", error_message, length (error_message), operation, RMDB_RN_REL_OP); goto exit_rmdb_add_rmdb_history; end; else do; error_message = ""; code = 0; end; /* In the event that the area in the data model is so small that another rmdb_history_event structure cannot be allocated, return a suitable message to the user instead of having him blow up with an area condition. */ on area begin; error_message = "Area in model is not large enough to " || "allocate another history entry - database will not be restructured"; code = error_table_$area_too_small; goto exit_rmdb_add_rmdb_history; end; /* Make sure that the caller cannot interrupt while the history entry is being added to the model. But if he hits a quit remember so it can be signaled after the model is updated. */ on quit quit_signaled = "1"b; /* allocate a new the rmdb_history_entry structure and fill it. */ allocate rmdb_history_entry set (new_rmdb_history_entry_ptr) in (db_model_ptr -> db_model.dbm_area); new_rmdb_history_entry_ptr -> rmdb_history_entry.user_id = get_group_id_ (); new_rmdb_history_entry_ptr -> rmdb_history_entry.date_time_restructured = clock; new_rmdb_history_entry_ptr -> rmdb_history_entry.type_of_object_restructured = type_of_object_restructured; new_rmdb_history_entry_ptr -> rmdb_history_entry.object_name = object_name; new_rmdb_history_entry_ptr -> rmdb_history_entry.operation = operation; new_rmdb_history_entry_ptr -> rmdb_history_entry.secondary_object_name = secondary_object_name; new_rmdb_history_entry_ptr -> rmdb_history_entry.offset_to_next_entry = NULL_OFFSET; /* Link the new structure to the end of the chain. If the first_restructuring_history_offset in the db_model is null it implies that this is the first restructuring event and that this structure will be the first in the list. If the restructuring_history_offset is not null use the last_restructuring_history_offset to find the last entry in the list. The last thing done is to update the last_restructuring_history_offset in the data model with the offset to the just created structure. */ if db_model_ptr -> db_model.first_restructuring_history_offset = NULL_OFFSET then do; db_model_ptr -> db_model.first_restructuring_history_offset = rel (new_rmdb_history_entry_ptr); new_rmdb_history_entry_ptr -> rmdb_history_entry.offset_to_previous_entry = NULL_OFFSET; end; else do; last_rmdb_history_entry_ptr = pointer (db_model_ptr, db_model_ptr -> db_model.last_restructuring_history_offset); last_rmdb_history_entry_ptr -> rmdb_history_entry.offset_to_next_entry = rel (new_rmdb_history_entry_ptr); new_rmdb_history_entry_ptr -> rmdb_history_entry.offset_to_previous_entry = db_model_ptr -> db_model.last_restructuring_history_offset; end; db_model_ptr -> db_model.last_restructuring_history_offset = rel (new_rmdb_history_entry_ptr); exit_rmdb_add_rmdb_history: /* If the user hit a quit now is the time to signal it for him */ if quit_signaled then do; revert quit; signal quit; end; return; end rmdb_add_rmdb_history;  rmdb_build_attr_info.pl1 10/16/86 1551.9r w 10/16/86 1143.7 82440 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ rmdb_build_attr_info: proc (I_dbm_ptr, I_adi_ptr, I_fm_ptr, I_di_ptr, O_err_msg, O_err_code); /* . BEGIN_DESCRIPTION The purpose of this procedure is to add the attr_info for the attribute defined in I_adi_ptr -> attr_def_info. The definition order of the attributes will be the order in which they are supplied to this procedure. The necessary rel_info structure elements are also updated. . END_DESCRIPTION */ /* HISTORY: 82-04-13 Originally written by R. Lackey. 82-06-25 Roger Lackey : Added the divide builting and the constants VARYING_CHAR_TYPE = 22 and VARYING_BIT_TYPE = 20 82-07-02 R. Harvey : changed mu_data_length reference to mdbm_util_$mu_data_length 83-01-10 R. Harvey : changed so the attribute index_id is set to all zeroes and the max_attr_index_id field is set beyond the maximum for pre-relation manager MRDS. */ /* PARAMETERS */ dcl I_dbm_ptr ptr parameter; /* Pointer to the db_model */ dcl I_adi_ptr ptr parameter; /* Pointer to attr_def_info */ dcl I_fm_ptr ptr parameter; /* Pointer to file_model */ dcl I_di_ptr ptr parameter; /* Pointer to domain_info */ dcl O_err_msg char (*) parameter;/* Error message text */ dcl O_err_code fixed bin (35) parameter; /* Error code */ %page; /* rmdb_build_attr_info: proc (I_dbm_ptr, I_adi_ptr, I_fm_ptr, I_di_ptr, O_err_msg, O_err_code); */ dbm_ptr = I_dbm_ptr; /* Pointer to db_model */ adi_ptr = I_adi_ptr; /* Pointer to atr_def_info */ fm_ptr = I_fm_ptr; /* Pointer to file_model */ di_ptr = I_di_ptr; /* pointer to domain_info for this attribute */ O_err_msg = ""; O_err_code = 0; ri_ptr = ptr (fm_ptr, file_model.rel_ptr); /* Pointer to rel_info */ /* Find end of attr_info list and check for dup attr_names count the attributes to determine attr order number. count key attributes. */ prev_ptr = null; key_attribute_count = 0; do ai_ptr = ptr (fm_ptr, rel_info.attr_ptr) /* Loop thru all attibutes getting the attr_name */ repeat ptr (fm_ptr, attr_info.fwd_thread) while (rel (ai_ptr) ^= NULL_OFFSET); if attr_def_info.name = attr_info.name then do; /* Found a duplicate name */ O_err_msg = rtrim (attr_info.name);/* so return an error */ O_err_code = mrds_error_$rst_name_duplicate; return; end; if attr_info.key_attr then key_attribute_count = key_attribute_count + 1; /* Count key attributes */ prev_ptr = ai_ptr; end; if rel_info.num_attr + 1 > mrds_data_$max_attributes then do; O_err_code = mrds_error_$max_attributes; return; end; rel_info.num_attr = rel_info.num_attr + 1; allocate attr_info in (fm_area) set (ai_ptr); %page; if prev_ptr = null then rel_info.attr_ptr = rel (ai_ptr); /* Link new attr_inof into list */ else prev_ptr -> attr_info.fwd_thread = rel (ai_ptr); attr_info.name = attr_def_info.name; if attr_def_info.primary_key then do; /* If it is part of the primary key */ attr_info.key_attr = "1"b; attr_info.key_order = key_attribute_count + 1; rel_info.num_key_attrs = rel_info.num_key_attrs + 1; /* Bump key attr count in rel_info */ end; else do; /* Not part of primary key */ attr_info.key_attr = "0"b; attr_info.key_order = 0; end; attr_info.link_attr = "0"b; attr_info.reserved = "0"b; if attr_def_info.indexed then do; /* It is an indexed attribute */ if mdbm_util_$mu_data_length ((domain_info.db_desc)) > 2277 /* 253* 9 */ then do; O_err_code = mrds_error_$long_index; O_err_msg = "The attribute has a domain that allows a values with length greater then 253 characters. " || attr_def_info.name; return; end; attr_info.index_attr = "1"b; rel_info.indexed = "1"b; /* Set rel_info stuff */ rel_info.max_attr_index_id = 257; /* set so old rmdb will not be able to add indexes */ attr_info.index_id = "0"b; end; else do; /* NOT an indexed attribute */ attr_info.index_id = "0"b; attr_info.index_attr = "0"b; end; attr_info.defn_order = rel_info.num_attr; /* Same order that they are added to the attribute_list */ call compute_bit_offset_and_length; /* Internal proc */ attr_info.link_child_cnt = 0; attr_info.link_par_cnt = 0; attr_info.domain_ptr = rel (di_ptr); attr_info.rslt_ptr = "0"b; attr_info.fwd_thread = NULL_OFFSET; attr_info.changer_ptr = db_model.changer_ptr; %page; if ceil (divide (rel_info.max_key_len, 9, 35)) > mrds_data_$max_key_len then do; O_err_msg = rtrim (rel_info.name); O_err_code = mrds_error_$long_key; end; exit: return; %page; /* * * * * * * * * * * compute_bit_offset_and_length * * * * * * * */ compute_bit_offset_and_length: proc; /* 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 */ varying_string = "0"b; desc_ptr = addr (domain_info.db_desc); /* get descriptor for this attribute */ attr_info.bit_length = mdbm_util_$get_data_bit_length (desc_ptr -> descriptor_bit_36_ovrly); if descriptor.type = VARYING_BIT_TYPE | descriptor.type = VARYING_CHAR_TYPE then varying_string = "1"b; /* 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 */ 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 */ 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 attr_def_info.primary_key then rel_info.max_key_len = rel_info.max_key_len + attr_info.bit_length; end compute_bit_offset_and_length; %page; /* * * * * * * * * * * * * * * pad * * * * * * * * * * * * */ pad: proc (pad_size, pad_base) returns (fixed bin); /* routine to return the number of bits necessary to pad a bit count out to an alignment boundary of 9(byte), 36(word), or 72(double word) bits as determined by the pad size input */ if mod (pad_base, pad_size) = 0 then number_of_bits = 0; else do; number_of_bits = pad_size - mod (pad_base, pad_size); end; return (number_of_bits); dcl pad_size fixed bin; /* either 9 or 36 or 72 */ dcl pad_base fixed bin (35); /* current bit length to be padded */ dcl number_of_bits fixed bin; /* what has to be added to get to the desired boundary */ end pad; %page; dcl NULL_OFFSET bit (18) internal static options (constant) init ((18)"1"b); /* db version of null offset */ dcl addr builtin; dcl ceil builtin; dcl WORD fixed bin int static options (constant) init (36); dcl descriptor_bit_36_ovrly bit (36) based; /* overlay for descriptor */ dcl divide builtin; dcl fixed builtin; dcl key_attribute_count fixed bin; dcl mdbm_util_$align_data_item entry (ptr, fixed bin (35)) returns (fixed bin); dcl mdbm_util_$get_data_bit_length entry (bit (36)) returns (fixed bin (35)); dcl mod builtin; dcl mrds_data_$max_attributes ext fixed bin (35); dcl mrds_data_$max_key_len fixed bin (35) ext; dcl mrds_error_$long_index fixed bin (35) ext static; dcl mrds_error_$long_key fixed bin (35) ext static; dcl mrds_error_$max_attributes fixed bin (35) ext static; dcl mrds_error_$rst_name_duplicate fixed bin (35) ext static; dcl mdbm_util_$mu_data_length entry (bit (36)) returns (fixed bin (35)); dcl null builtin; dcl padding fixed bin; dcl prev_ptr ptr; dcl ptr builtin; dcl rel builtin; dcl rtrim builtin; dcl sys_info$max_seg_size fixed bin (35) ext static; dcl VARYING_BIT_TYPE fixed bin int static options (constant) init (20); dcl VARYING_CHAR_TYPE fixed bin int static options (constant) init (22); dcl varying_string bit (1); %page; %include rmdb_create_rel_info; %page; %include mdbm_db_model; %include mdbm_file_model; %page; %include mdbm_descriptor; end rmdb_build_attr_info;  rmdb_copy_relation.pl1 12/07/87 1328.9rew 12/07/87 1319.8 220635 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1986 * * * *********************************************************** */ /* format: ^inddcls,^indattr,indnoniterend,^indnoniterdo,indend,tree,^case,insnl,comcol61,dclind5,declareind5,delnl */ /*DESCRIPTION This subroutine creates a file_model and data relation from the description of an already present relation and a list of attributes to be deleted from or added to that relation. (Note: the add is not implemented yet, it should only be used by the restructure_relation operation of rmdb. */ /****^ HISTORY COMMENTS: 1) change(86-01-27,Spitzer), approve(86-01-27,MCR7311), audit(86-09-15,Gilcrease), install(86-10-16,MR12.0-1187): written 2) change(86-11-18,Blair), approve(86-11-18,PBF7311), audit(86-12-05,Dupuis), install(86-12-09,MR12.0-1237): Rework code so that the new relation (the one without the deleted domains) is created correctly. Be sure to close it before we start putting tuples into it so that it will be up to date with index ids and all the information we collect and put into the model *after* the relation is first created and opened. 3) change(87-11-03,Blair), approve(87-11-03,MCR7792), audit(87-11-30,Dupuis), install(87-12-07,MR12.2-1008): Initialize mstxn_txn_id to 0 so that we won't get caught in the cleaner by trying to delete a txn that doesn't exist. END HISTORY COMMENTS */ rmdb_copy_relation: proc (Idbm_ptr, Idb_path, Itemp_dir_path, Irmdb_relmgr_entries_ptr, Irelation_ptr, Oerror_message, Ocode); dbm_ptr = Idbm_ptr; db_path = Idb_path; temp_dir_path = Itemp_dir_path; rmdb_relmgr_entries_ptr = Irmdb_relmgr_entries_ptr; relation_ptr = Irelation_ptr; fm_ptr = relation.file_model_ptr; delete_model_sw, delete_relation_sw = "0"b; control_area_ptr, new_file_model_ptr = null; new_file_info_ptr, last_file_info_ptr = null; new_relation_id, old_relation_id = "0"b; mstxn_txn_id = "0"b; on cleanup call cleaner; create_relation_name = unique_chars_ ("0"b); create_model_name = rtrim (create_relation_name) || ".m"; call make_area (control_area_ptr); /* Mark in file_model segment that the relation copy and file_model code are not current. */ file_model.file_model_copy_good = "0"b; file_model.relation_copy_good = "0"b; call copy_file_model; /* create and copy the file model information */ call transaction_in_progress; if mstxn_transactions_needed then do; on cleanup begin; call mstxn_cleanup; call cleaner; end; on any_other call mstxn_any_other; %include mrds_start_transaction; if mstxn_code ^= 0 then call error (mstxn_code, "Could not start a transaction."); end; call create_relation; /* create the empty data relation */ call copy_data; /* copy the data from the old relation to the new */ if mstxn_transactions_needed then do; mftxn_code = 0; %include mrds_finish_transaction; end; /* At this point we have esentially created the new relation. Mark the delete switches so that the cleanup handler doesn't get rid of them. Now we must copy the new model on the old, and the new data relation onto the old. If either the system or process crash now, we can recover by attempting this operation multiple times (rmdb_salvage_db does this when attempting the undo request). */ delete_relation_sw, delete_model_sw = "0"b; new_file_model_ptr -> file_model.relation_copy_good = "1"b; new_file_model_ptr -> file_model.file_model_copy_good = "1"b; call error (0, ""); %page; /*DESCRIPTION Create a non-freeing, non-zeroing extensible area to allocate structures in. When we return and finish using these structures, we will simply throw away the area. This subroutine is also used to reinitialize the area to empty so that we may reuse it for other purposes. */ make_area: proc (area_ptr); dcl area_ptr ptr parameter; if area_ptr = null then do; call mdbm_util_$get_temp_segment_path (temp_dir_path, myname, area_ptr, code); if code ^= 0 then call error (code, "Cannot get a temp segment in the temp dir."); unspec (ai) = "0"b; ai.version = area_info_version_1; ai.extend = "1"b; ai.dont_free = "0"b; ai.no_freeing = "0"b; ai.owner = myname; ai.size = sys_info$max_seg_size; ai.areap = area_ptr; end; else call release_area_ (area_ptr); call define_area_ (addr (ai), code); if code ^= 0 then call error (code, "Defining an area."); return; end make_area; %page; /*DESCRIPTION Create the new relation from the description of the old minus the attributes that are to be deleted. */ create_relation: proc; dcl cr_loop fixed bin; /* initialize for calls to relation manager */ tva_number_of_vector_slots = 0; tva_number_of_dimensions = rel_info.num_attr; tva_maximum_dimension_name_length = 32; allocate typed_vector_array in (control_area) set (typed_vector_array_ptr); typed_vector_array.version = TYPED_VECTOR_ARRAY_VERSION_2; typed_vector_array.number_of_dimensions = 0; il_number_of_ids = rel_info.num_attr; allocate id_list in (control_area) set (id_list_ptr); id_list.number_of_ids = 0; id_list.version = ID_LIST_VERSION_1; /* Set up the list of descriptors for the create relation operation. */ ai_ptr = ptr (new_file_model_ptr, rel_info.attr_ptr); do cr_loop= 1 to tva_number_of_dimensions; if attr_info.key_attr then do; id_list.number_of_ids = id_list.number_of_ids + 1; id_list.id (id_list.number_of_ids) = attr_info.defn_order; end; di_ptr = ptr (dbm_ptr, attr_info.domain_ptr); typed_vector_array.number_of_dimensions = typed_vector_array.number_of_dimensions + 1; typed_vector_array.dimension_table (typed_vector_array.number_of_dimensions).name = attr_info.name; typed_vector_array.dimension_table (typed_vector_array.number_of_dimensions).descriptor_ptr = addr (domain_info.db_desc); ai_ptr = ptr (new_file_model_ptr, attr_info.fwd_thread); end; if id_list.number_of_ids = 0 then call error (mrds_error_$no_primary_key, "For relation " || relation.name); allocate rel_creation_info in (control_area) set (rel_creation_info_ptr); allocate file_create_info in (control_area) set (file_create_info_ptr); /* Initialize values for the create relation operation. */ rel_creation_info.version = REL_CREATION_INFO_VERSION_2; rel_creation_info.esm_info_ptr = null; rel_creation_info.cism_info_ptr = null; rel_creation_info.file_create_info_ptr = file_create_info_ptr; file_create_info.version = FILE_CREATE_INFO_VERSION_2; file_create_info.ci_size_in_bytes = 4096; file_create_info.blocking_factor = mrds_data_$relation_blocking_factor; file_create_info.flags.protected = db_model.db_type_flags.transactions_needed; file_create_info.flags.no_concurrency = ^db_model.db_type_flags.concurrency_on; file_create_info.flags.no_rollback = ^db_model.db_type_flags.rollback_on; file_create_info.flags.mbz_1 = "0"b; file_create_info.ring_brackets (*) = 0; file_create_info.mbz_2 = 0; file_create_info.mbz_3 = "0"b; call rmdb_relmgr_entries . create_relation (db_path, create_relation_name, rel_creation_info_ptr, typed_vector_array_ptr, new_relation_id, rel_info.id, code); if code ^= 0 then call error (code, "While creating relation " || create_relation_name); delete_relation_sw = "1"b; /* initialize values for create_index */ style = 1; relation_index_flags_ptr = addr (flag_list); flag_list = "0"b; relation_index_flags.index_is_unique = "1"b; /* for primary key */ /* create the primary index for the relation */ call rmdb_relmgr_entries .create_index (new_relation_id, id_list_ptr, flag_list, style, rel_info.primary_key_index_id, code); if code ^= 0 then call error (code, "While creating the primary index for" || create_relation_name); /* create the secondary indexes for the relation */ relation_index_flags.index_is_unique = "0"b; /* index need not be unique for secondary index */ id_list.number_of_ids = 1; /* secondary indices involve only one attribute */ ai_ptr = ptr (new_file_model_ptr, rel_info.attr_ptr); do cr_loop = 1 to rel_info.num_attr; if attr_info.index_attr then do; id_list.id (1) = attr_info.defn_order; call rmdb_relmgr_entries .create_index (new_relation_id, id_list_ptr, flag_list, style, attr_info.index_id, code); if code ^= 0 then call error (code, "While creating secondary indices for " || create_relation_name); end; ai_ptr = ptr (new_file_model_ptr, attr_info.fwd_thread); end; /* do relation_idx */ return; end create_relation; %page; /*DESCRIPTION This subroutine copies the data from the relation MSF/DMF to a new file without the attributes that are to be deleted. */ copy_data: proc; dcl based_bit36a bit (36) aligned based; dcl descriptor bit (36) aligned; dcl loop fixed bin (35); dcl new_cursor_ptr ptr; dcl old_cursor_ptr ptr; dcl tuple_bit_length fixed bin (35); /* Open the relation that contains the data to copy from. */ call rmdb_relmgr_entries.close (new_relation_id,(0)); call rmdb_relmgr_entries.open (db_path, create_relation_name, new_relation_id, code); call rmdb_relmgr_entries.open (db_path, relation.name, old_relation_id, code); if code ^= 0 then call error (code, "Unable to open data relation " || relation.name); /* Create cursors for both the from and to relations. These cursors are allocated in an area that is to be released, so there is no need to clean up and get rid of them. */ call rmdb_relmgr_entries.create_cursor (old_relation_id, control_area_ptr, old_cursor_ptr, code); if code ^= 0 then call error (code, "Unable to create a cursor for relation " || relation.name); call rmdb_relmgr_entries.create_cursor (new_relation_id, control_area_ptr, new_cursor_ptr, code); if code ^= 0 then call error (code, "Unable to create a cursor for copy of relation " || relation.name); /* Create the select structure */ rss_number_of_and_groups = 0; rss_maximum_number_of_constraints = 0; allocate relation_search_specification in (control_area) set (relation_search_specification_ptr); relation_search_specification.head.version = SPECIFICATION_VERSION_4; relation_search_specification.head.type = ABSOLUTE_RELATION_SEARCH_SPECIFICATION_TYPE; relation_search_specification.head.pad = "0"b; relation_search_specification.head.subset_specification_ptr = null; unspec(relation_search_specification.flags) = "0"b; relation_search_specification.range.type = LOW_RANGE_TYPE; /* all tuples */ relation_search_specification.range.size = mrds_data_$max_tids_returned_per_call; /* Populate the retrieval id list (the list of attributes to retrieve from the old relation). Since we are omitting attributes, we only need to retrieve the ones we are actually going to store. While we are building the id_list, calculate the maximum size (in bits) of the tuple. */ il_number_of_ids = relation.attribute_count; allocate id_list in (control_area) set (id_list_ptr); id_list.version = ID_LIST_VERSION_1; id_list.number_of_ids = 0; tuple_bit_length = 0; do loop = 1 to relation.attribute_count; if ^relation.attribute (loop).flags.delete then do; id_list.number_of_ids = id_list.number_of_ids + 1; id_list.id (id_list.number_of_ids) = loop; di_ptr = ptr (dbm_ptr, relation.attribute (loop).domain_info_ptr); descriptor = domain_info.db_desc; if domain_info.db_desc_is_ptr then descriptor = ptr (dbm_ptr, descriptor) -> based_bit36a; tuple_bit_length = tuple_bit_length + mdbm_util_$get_data_bit_length (descriptor); end; end; /* do loop */ simple_typed_vector_ptr, element_id_list_ptr = null; /* create an element_id_list for the call to get_tuple_ids */ eil_number_of_elements = mrds_data_$max_tids_returned_per_call; allocate element_id_list in (control_area) set (element_id_list_ptr); element_id_list.version = ELEMENT_ID_LIST_VERSION_1; /* Read all the data from the old relation data file and store it into the new one. If we get a dup_store error, then deleting one or more of the attributes would cause the primary key to be non-unique and is not allowed. */ code = 0; do while (code = 0); element_id_list.number_of_elements = 0; element_id_list.id (*) = "0"b; call rmdb_relmgr_entries . get_tuple_id (old_cursor_ptr, relation_search_specification_ptr, control_area_ptr, element_id_list_ptr, code); if code = 0 & element_id_list.number_of_elements > 0 then do loop = 1 repeat loop + 1 while (loop <= element_id_list.number_of_elements & code = 0); /* let the relmgr create the simple_typed vector and fill the value_ptrs and then we'll use the same one after the first time */ if mstxn_transactions_needed then call manage_transaction; call rmdb_relmgr_entries . get_tuple_by_id (old_cursor_ptr, element_id_list.id (loop), id_list_ptr, control_area_ptr, simple_typed_vector_ptr, code); if code = 0 then call rmdb_relmgr_entries.put_tuple (new_cursor_ptr, simple_typed_vector_ptr, element_id_list.id (loop), code); if mstxn_transactions_needed then call manage_transaction; end; /* loop through all tuples in element_id_list */ if code = 0 then relation_search_specification.head.type = RELATIVE_RELATION_SEARCH_SPECIFICATION_TYPE; end; /* all tuples in the relation have been copied */ if code ^= dm_error_$no_tuple then if code = dm_error_$key_duplication then call error (code, "Deleting key attributes from relation " || rtrim (relation.name) || " would cause primary keys to be non-unique."); else call error (code, "Deleting attributes from relation " || relation.name); code = 0; /* Close both data files. */ call rmdb_relmgr_entries.close (new_relation_id, (0)); call rmdb_relmgr_entries.close (old_relation_id, (0)); new_relation_id, old_relation_id = "0"b; /* Mark in the file_model that the data relation is usable. */ file_model.relation_copy_good = "1"b; return; end copy_data; %page; /*DESCRIPTION This subroutine creates an empty file_model segment, and populates it with the attributes that are not deleted from the old file_model segment. */ copy_file_model: proc; dcl 1 adi like attr_def_info; dcl add_name char (32); dcl amount_to_pad fixed bin; dcl WORD fixed bin internal static options (constant) init (36); call initiate_file_$create (db_path, create_model_name, RW_ACCESS, new_file_model_ptr, ("0"b), (0), code); if code ^= 0 then call error (code, "While creating the file_model copy for relation " || relation.name); delete_model_sw = "1"b; /* the model copy must be cleaned up if we abort */ /* Add a name of .k to .m. This is the only indicator of what the name of the relation is. The salvager is going to need this to complete the copy operation. */ add_name = rtrim (relation.name) || ".k"; call hcs_$chname_file (db_path, create_model_name, "", add_name, code); if code ^= 0 then do; if code = error_table_$namedup then do; call hcs_$chname_file (db_path, add_name, add_name, "", (0)); call hcs_$chname_file (db_path, create_model_name, "", add_name, code); end; if code ^= 0 then call error (code, "Adding a name on model " || create_model_name); end; new_file_model_ptr -> like_file_model = init_file_model; new_file_model_ptr -> file_model.fm_area = empty (); new_file_model_ptr -> file_model.changer_ptr = db_model.changer_ptr; allocate rel_info in (new_file_model_ptr -> file_model.fm_area) set (ri_ptr); new_file_model_ptr -> file_model.rel_ptr = rel (ri_ptr); rel_info = init_rel_info; rel_info.name = relation.name; rel_info.changer_ptr = db_model.changer_ptr; /* Create all the attr_info structures in the new file_model segment */ do relation_idx = 1 to relation.attribute_count; if ^relation.attribute (relation_idx).flags.delete then do; ai_ptr = relation.attribute (relation_idx).attribute_info_ptr; di_ptr = ptr (dbm_ptr, relation.attribute (relation_idx).domain_info_ptr); adi.name = attr_info.name; adi.primary_key = attr_info.key_attr; adi.indexed = attr_info.index_attr; adi.mbz = "0"b; call rmdb_build_attr_info (dbm_ptr, addr (adi), new_file_model_ptr, di_ptr, error_message, code); if code ^= 0 then call error (code, error_message); end; end; /* do relation_idx */ /* we've built all the attr infos, but we still need to align varying data */ if rel_info.nvar_atts = 0 then; else do; if mod (rel_info.var_offset-1, WORD) = 0 then amount_to_pad = 0; else amount_to_pad = WORD - mod (rel_info.var_offset -1, WORD); rel_info.var_offset = rel_info.var_offset + amount_to_pad; rel_info.max_data_len = rel_info.max_data_len + amount_to_pad; end; call adjust_bit_count_ (db_path, create_model_name, "0"b, new_model_bit_count, (0)); /* Mark the fact that the file_model describing the new relation is ok to use. */ file_model.file_model_copy_good = "1"b; /* Create a file_info structure and add it to the end of the list of file_infos in db_model (if we are operating on a MSF). We don't really want to do this because we only have to undo it later, but vfile_relmgr_ requires that all these structures be there. */ do fi_ptr = ptr (dbm_ptr, db_model.file_ptr) repeat ptr (dbm_ptr, file_info.fwd_ptr) while (rel (fi_ptr) ^= NULL_OFFSET); last_file_info_ptr = fi_ptr; end; allocate file_info in (dbm_area) set (new_file_info_ptr); relation.copy_file_model_ptr = new_file_info_ptr; new_file_info_ptr -> file_info.file_name = create_relation_name; new_file_info_ptr -> file_info.file_id = "000000000000000000000000000000000001"b; new_file_info_ptr -> file_info.fwd_ptr = NULL_OFFSET; new_file_model_ptr -> file_model.fi_ptr = rel (fi_ptr); if last_file_info_ptr = null then db_model.file_ptr = rel (new_file_info_ptr); else last_file_info_ptr -> file_info.fwd_ptr = rel (new_file_info_ptr); return; end copy_file_model; %page; /*DESCRIPTION This subroutine ensures that no transaction is in progress, and sets a flag bit for use later. */ transaction_in_progress: proc; if db_model.db_type_flags.transactions_needed then do; mstxn_transactions_needed = "1"b; call transaction_manager_$get_current_txn_id (mstxn_txn_id, mstxn_code); if mstxn_code = 0 then do; mstxn_txn_id = "0"b; call error (error_table_$action_not_performed, "A transaction is in progress. Commit or abort the transaction and try the operation again."); end; end; else mstxn_transactions_needed = "0"b; return; end transaction_in_progress; /*DESCRIPTION This routine takes care of starting and stopping new transactions as needed. */ manage_transaction: proc (); call transaction_manager_$commit_txn (mstxn_txn_id, mftxn_code); if mftxn_code ^= 0 then do; call transaction_manager_$abort_txn (mstxn_txn_id, mftxn_temp_code); if mftxn_temp_code ^= 0 then call transaction_manager_$abandon_txn (mstxn_txn_id, mftxn_temp_code); call error (mftxn_temp_code, "Unable to finish a transaction."); end; mstxn_txn_id = "0"b; call transaction_manager_$begin_txn (TM_NORMAL_MODE, 0, mstxn_txn_id, mstxn_code); if mstxn_code ^= 0 then call error (mstxn_code, "Could not start a transaction."); return; end manage_transaction; %page; /*DESCRIPTION Error handler and cleanup handler. This is the only way to exit these subroutines. */ error: proc (code, msg); dcl code fixed bin (35) parameter; dcl msg char (*) parameter; Ocode = code; if code = 0 then Oerror_message = ""; else Oerror_message = msg; goto RETURN_TO_CALLER; end error; RETURN_TO_CALLER: call cleaner; return; cleaner: proc; dcl id bit (36) aligned; dcl p ptr; do p = control_area_ptr; if p ^= null then do; call release_area_ (p); call mdbm_util_$free_temp_segment (myname, p, (0)); end; end; do id = new_relation_id, old_relation_id; if id ^= "0"b then call rmdb_relmgr_entries.close (id, (0)); end; if mstxn_txn_id ^= "0"b then do; call transaction_manager_$abort_txn (mstxn_txn_id, code); if code ^= 0 then call transaction_manager_$abandon_txn (mstxn_txn_id, (0)); end; return; end cleaner; restore_significant_data: proc; return; end restore_significant_data; should_rollback: proc returns (bit (1) aligned); return ("0"b); end should_rollback; %page; %include access_mode_values; %page; %include area_info; %page; %include dm_element_id_list; %page; %include dm_file_create_info; %page; %include dm_id_list; %page; %include dm_range_constants; %page; %include dm_rel_creation_info; %page; %include dm_relation_index_flags; %page; %include dm_relation_spec; %page; %include dm_specification_head; %page; %include vu_typed_vector; %page; %include mdbm_db_model; %page; %include mdbm_file_model; %page; %include mdbm_file_model_init; %page; %include rmdb_create_rel_info; %page; %include rmdb_crossref_info; %page; %include rmdb_relmgr_entries; %page; %include vu_typed_vector_array; %page; dcl addr builtin; dcl adjust_bit_count_ entry (char (168), char (32), bit (1) aligned, fixed bin (35), fixed bin (35)); dcl 1 ai aligned like area_info; dcl any_other condition; dcl cleanup condition; dcl code fixed bin (35); dcl control_area area (sys_info$max_seg_size) based (control_area_ptr); dcl control_area_ptr ptr; dcl create_model_name char (32); dcl create_relation_name char (30); dcl db_path char (168); dcl define_area_ entry (ptr, fixed bin (35)); dcl delete_model_sw bit (1) aligned; dcl delete_relation_sw bit (1) aligned; dcl dm_error_$key_duplication fixed bin (35) ext static; dcl dm_error_$no_tuple fixed bin (35) ext static; dcl empty builtin; dcl error_message char (500); dcl error_table_$action_not_performed fixed bin (35) ext static; dcl error_table_$namedup fixed bin(35) ext static; dcl fixed builtin; dcl flag_list bit (36) aligned; dcl hcs_$chname_file entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl Idb_path char (*) parameter; dcl Idbm_ptr ptr parameter; dcl initiate_file_$create entry (char (*), char (*), bit (*), ptr, bit (1) aligned, fixed bin (24), fixed bin (35)); dcl Irelation_ptr ptr parameter; dcl Irmdb_relmgr_entries_ptr ptr parameter; dcl Itemp_dir_path char (*) parameter; dcl last_file_info_ptr ptr; dcl mdbm_util_$get_data_bit_length entry (bit (36) aligned) returns (fixed bin (35)); dcl mdbm_util_$get_temp_segment_path entry (char (*), char (*), ptr, fixed bin (35)); dcl mdbm_util_$free_temp_segment entry (char (*), ptr, fixed bin (35)); dcl mod builtin; dcl mrds_data_$max_tids_returned_per_call external static fixed bin (35); dcl mrds_data_$relation_blocking_factor external static fixed bin (17); dcl mrds_error_$no_primary_key fixed bin (35) ext static; dcl myname char (32) int static options (constant) init ("rmdb_copy_relation"); dcl new_file_info_ptr ptr; dcl new_file_model_ptr ptr; dcl new_model_bit_count fixed bin (35); dcl new_relation_id bit (36) aligned; dcl null builtin; dcl NULL_OFFSET bit (18) unaligned int static options (constant) init ((18)"1"b); dcl Ocode fixed bin (35) parameter; dcl Oerror_message char (*) parameter; dcl old_relation_id bit (36) aligned; dcl ptr builtin; dcl rel builtin; dcl relation_idx fixed bin; dcl release_area_ entry (ptr); dcl rmdb_build_attr_info entry (ptr, ptr, ptr, ptr, char (*), fixed bin (35)); dcl rtrim builtin; dcl style fixed bin; dcl sys_info$max_seg_size fixed bin (35) ext static; dcl temp_dir_path char (168); dcl unique_chars_ entry (bit (*)) returns (char (15)); dcl unspec builtin; end rmdb_copy_relation;  rmdb_create_and_pop_rel.pl1 08/01/88 1435.5rew 08/01/88 1300.0 172413 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ rmdb_create_and_pop_rel: proc (I_rmdb_ctl_ptr, I_db_path, I_temp_dir_path, I_sel_exp, I_rmdb_sel_val_info_ptr, I_index_attrs_ptr, O_err_msg, O_err_code); /* BEGIN_DESCRIPTION The purpose of this procedure is to create and populate a relation given a selection expression like that provided for define_temp_rel. The relation name is contained in the I_index_attrs structure. The attributes for the relation are defined by the selected attributes specified in the selection expression. Indexed attributes are in the index_attr_structure, and were defined outside this procedure. This procedure opens the database twice: to translate the selection expression to get the relation attributes, and after the relation has been created and is needed to store the selected tuples. . END_DESCRIPTION */ /* HISTORY 82-04-23 Written by Roger Lackey 82-06-15 Roger Lackey : added the init of db_model_ptr to rmdb_delete_rel_info in tidy_up procedure. 82-06-25 Roger Lackey : changed to use divide builtin and undo request to use -brief instead of -force 82-07-01 Roger Lackey : Modified the calls to mu_db_inconsistent to use mdbm_util_$inconsistent_* for binding. 82-07-02 R. Harvey : Modified calls to mrds_dsl_translate, mu_define_area, and mu_get_tuple for binding. 82-07-01 Roger Lackey : changed mu_database_index$get_resultant_model_pointer to mdbm_util_$get_resultant_model_pointer and mu_store$store_direct to mdbm_util_$store_direct for binding 82-08-20 D. Woodka : deleted reference to rm_rel_info.max_data_len for DMS conversion. 82-09-15 Mike Kubicar : converted to use vectors. 82-11-18 D. Woodka : changed calling sequence to include rmdb_ctl_ptr. 83-02-07 Mike Kubicar : Added transaction processing include files. 83-02-15 Davids: modified to use the new db_type_flags in the db_model structure instead of the old numeric db_type. 83-04-08 Mike Kubicar : Changed calling sequence of mdbm_util_$direct. */ /****^ HISTORY COMMENTS: 1) change(87-01-22,Hergert), approve(88-07-11,MCR7903), audit(88-07-26,Dupuis), install(88-08-01,MR12.2-1073): For new parser, changed referneces of sel_ptr to select_list_ptr. END HISTORY COMMENTS */ /* PARAMETERS */ dcl I_rmdb_ctl_ptr ptr; /* ptr to rmdb_ctl used to access relation_manager entries */ dcl I_db_path char (*) parameter;/* Database path were are working with */ dcl I_temp_dir_path char (*) parameter;/* Temporary diretory pathname */ dcl I_sel_exp char (*) parameter;/* Selection expresion like that of define_temp_rel */ dcl I_rmdb_sel_val_info_ptr ptr parameter; /* Pointer rmdb_sel_val_info structure */ dcl I_index_attrs_ptr pointer parameter; /* Pointer to the rmdb_index_attrs structure */ dcl O_err_msg char (*) parameter;/* Error message text */ dcl O_err_code fixed bin (35) parameter; /* Error code */ %page; /* rmdb_create_and_pop_rel: proc (I_rmdb_ctl_ptr, I_db_path, I_temp_dir_path, I_sel_exp, I_rmdb_sel_val_info_ptr, I_index_attrs_ptr, O_err_msg, O_err_code); */ must_delete_relation = "0"b; sel_exp_ptr = addr (I_sel_exp); sel_exp_len = length (I_sel_exp); rmdb_sel_val_info_ptr = I_rmdb_sel_val_info_ptr; rmdb_ix_attrs_ptr = I_index_attrs_ptr; rmdb_ctl_ptr = I_rmdb_ctl_ptr; O_err_msg = ""; O_err_code = 0; rel_name = rtrim (rmdb_ix_attrs.relation_name); dbi = 0; ftf = "1"b; /* first time flag */ on cleanup call tidy_up; if I_db_path = " " then call error (mrds_error_$no_db_path, ""); else db_path = I_db_path; call hcs_$initiate (db_path, "db_model", "", 0, 0, dbm_ptr, code); /* Get pointer to db_model */ if dbm_ptr = null then call error (mrds_error_$no_database, "^/" || db_path); if db_model.db_type_flags.transactions_needed then do; mstxn_transactions_needed = "1"b; call transaction_manager_$get_current_txn_id (mstxn_txn_id, mstxn_code); if mstxn_code = 0 then do; mstxn_txn_id = "0"b; call error (error_table_$action_not_performed, "Relations may not be created while a transaction " || "is in progress. Commit or abort the transaction " || "and try again."); end; end; else mstxn_transactions_needed = "0"b; mstxn_txn_id = "0"b; /* See if a relation by this name already exists in db */ call hcs_$initiate (db_path, rel_name || ".m", "", 0, 0, fm_ptr, code); if fm_ptr ^= null then call error (mrds_error_$dup_rel, "^/" || rel_name); on cleanup begin; call tidy_up; call mstxn_cleanup; end; on any_other call mstxn_any_other; %include mrds_start_transaction; if mstxn_code ^= 0 then call error (mstxn_code, "Could not start a transaction while creating relation " || rtrim (rel_name) || "."); call dsl_$open (db_path, dbi, EXCLUSIVE_UPDATE, code); if code ^= 0 then call error (code, "^/" || db_path); call mdbm_util_$get_resultant_model_pointer (dbi, dbcb_ptr); /* Get the dbcb pointer */ if dbcb_ptr = null then call error (mrds_error_$invalid_db_index, "Getting dbcb_ptr"); call mdbm_util_$define_temp_dir_area (dbcb.def_temp_rel_area_ptr, dbi, (sys_info$max_seg_size), "MRDS.def_tr", "0"b /* not extensible */, "1"b /* no freeing */, "0"b, "0"b /* no zeroing */, code); work_area_ptr = dbcb.def_temp_rel_area_ptr; if code ^= 0 then call error (code, ""); num_sel_vals = rmdb_sel_val_info.sv_num; /* Cause translate changes them */ sel_val_arg_list_ptr = rmdb_sel_val_info.data_list_ptr; sel_val_desc_list_ptr = rmdb_sel_val_info.desc_list_ptr; call mdbm_util_$mrds_dsl_translate (dbcb_ptr, work_area_ptr, 4, sel_exp_ptr, sel_exp_len, sel_val_arg_list_ptr, sel_val_desc_list_ptr, num_sel_vals, code); if code ^= 0 then call error (code, "^/""" || I_sel_exp || """"); if ^dbcb.val_dtr then call error (mrds_error_$inval_dtr_expr, "^/""" || I_sel_exp || """"); %page; if dbcb.ss_ptr ^= null then do; /* set ptrs needed later */ ss_ptr = dbcb.ss_ptr; select_list_ptr = select_sets.items.select_ptr (1); range_ptr = select_sets.items.range_ptr (1); end; else do; range_ptr = dbcb.range_ptr; /* initialize */ select_list_ptr = dbcb.select_ptr; end; rmdb_create_rel_info_alloc = select_list.num_items; allocate rmdb_create_rel_info in (work_area) set (rmdb_create_rel_info_ptr); rmdb_create_rel_info.version = RMDB_CREATE_REL_INFO_VERSION_1; rmdb_create_rel_info.db_path = I_db_path; rmdb_create_rel_info.temp_directory_path = I_temp_dir_path; rmdb_create_rel_info.db_model_ptr = dbm_ptr; rmdb_create_rel_info.relation_name = rmdb_ix_attrs.relation_name; rmdb_create_rel_info.num_attrs = select_list.num_items; do i = 1 to select_list.num_items; rai_ptr = select_list.item.ai_ptr (i); /* Get rm_attr_info_ptr */ rmdb_create_rel_info.attrs (i).name = rm_attr_info.model_name; rmdb_create_rel_info.attrs (i).primary_key = select_list.item (i).key; rmdb_create_rel_info.attrs (i).indexed = "0"b; /* Will mark those index in index_attr_mark proc */ rmdb_create_rel_info.attrs (i).mbz = "0"b; end; call index_attr_mark; /* Internal proc */ must_delete_relation = "1"b; /* In case an error occurs during creating */ /* The call to rmdb_create_relation will set the db inconsistent during the creation period but will then return the db to a consistent state prior to returning */ call rmdb_create_relation (rmdb_ctl_ptr, rmdb_create_rel_info_ptr, "0"b /* Not called from request level */, err_msg, code); if code ^= 0 then call error (code, err_msg); call dsl_$close (dbi, code); if code ^= 0 then call error (code, "First close of db"); dbi = 0; call store; /* Internal procedure */ must_delete_relation = "0"b; if ftf then /* The relation was created but no tuples stored because nothing was found that matched the selection_exp */ call error (mrds_error_$no_tuple, "^/The relation was created but was not populated because" || "^/there were no tuples that satisfied the selection expression."); call tidy_up; exit: mftxn_code = O_err_code; %include mrds_finish_transaction; if mftxn_code ^= 0 then do; O_err_code = mftxn_code; O_err_msg = "Could not finish a transaction while creating relation " || rtrim (rel_name) || "."; end; return; %page; /* * * * * * * * * * * * * index_attr_mark * * * * * * * * * * * * * * */ index_attr_mark: proc; do k = 1 to rmdb_ix_attrs.num_used; /* All indexed attrs */ attr_name = rmdb_ix_attrs.an (k); found = "0"b; do j = 1 to rmdb_create_rel_info.num_attrs while (^found); /* Search for name in list */ if attr_name = rmdb_create_rel_info.attrs (j).name then do; if rmdb_create_rel_info.attrs (j).indexed = "1"b then call error (mrds_error_$previously_defined_index, "^/" || attr_name); rmdb_create_rel_info.attrs (j).indexed = "1"b; /* Mark as indexed */ found = "1"b; end; end; if ^found then call error (mrds_error_$undef_attr, "^/" || attr_name); end; /* END All indexed attrs */ end index_attr_mark; %page; /* * * * * * * * * * * * * * * store * * * * * * * * * * * * * * * */ store: proc; /* This internal procedure opens the db for the second time so the opening includes the newly created relation and stores each tuple selected. If a tuple's primary key is found to duplicate that of a previously stored tuple the second tuple is NOT stored and no error reported. The database is set inconsistent just prior to beginning the stores */ /* Open db again this time with new relation in it */ call dsl_$open (db_path, dbi, EXCLUSIVE_UPDATE, code); if code ^= 0 then call error (code, "^/" || db_path); call mdbm_util_$get_resultant_model_pointer (dbi, dbcb_ptr); /* Get the dbcb pointer */ if dbcb_ptr = null then call error (mrds_error_$invalid_db_index, "Getting dbcb_ptr"); call mdbm_util_$define_temp_dir_area (dbcb.def_temp_rel_area_ptr, dbi, (sys_info$max_seg_size), "MRDS.def_tr", "0"b /* not extensible */, "1"b /* no freeing */, "0"b, "0"b /* no zeroing */, code); work_area_ptr = dbcb.def_temp_rel_area_ptr; if code ^= 0 then call error (code, ""); num_sel_vals = rmdb_sel_val_info.sv_num; /* Cause translate changes them */ sel_val_arg_list_ptr = rmdb_sel_val_info.data_list_ptr; sel_val_desc_list_ptr = rmdb_sel_val_info.desc_list_ptr; call mdbm_util_$mrds_dsl_translate (dbcb_ptr, work_area_ptr, 4, sel_exp_ptr, sel_exp_len, sel_val_arg_list_ptr, sel_val_desc_list_ptr, num_sel_vals, code); if code ^= 0 then call error (code, "^/""" || I_sel_exp || """"); %page; if dbcb.ss_ptr ^= null then do; /* set ptrs needed later */ ss_ptr = dbcb.ss_ptr; select_list_ptr = select_sets.items (1).select_ptr; range_ptr = select_sets.items (1).range_ptr; ti_ptr = select_sets.items (1).ti_ptr; end; else do; range_ptr = dbcb.range_ptr; /* initialize */ select_list_ptr = dbcb.select_ptr; ti_ptr = dbcb.ti_ptr; end; rdbi_ptr = dbcb.rdbi_ptr; /* Pointer to rm_db_info */ rmra_ptr = rm_db_info.ra_ptr; /* find rel info */ /* search for rel_name in rm_rel_array so we can get the rmri_ptr */ i = index (string (rm_rel_array.name), "!" || rmdb_ix_attrs.relation_name); i = (divide ((i - 1), 33, 17)) + 1; /* convert from char to array index */ rmri_ptr = rm_rel_array.rel_data.ri_ptr (i); dbcb.last_store_rel_name = "!!!!!!!... ...!!!!!"; /* Temparory store bad rel name incase this store fails */ %page; call mdbm_util_$inconsistent_set (dbm_ptr, "create_relation", /* Cause rmdb_create_relation reset it */ "Creating relation " || rel_name, "delete_relation " || rel_name || " -brief"); quit_received = "0"b; /* Not yet */ stv_number_of_dimensions = mrds_data_$max_attributes; allocate simple_typed_vector; simple_typed_vector.type = SIMPLE_TYPED_VECTOR_TYPE; call mdbm_util_$mu_get_tuple (dbcb_ptr, work_area_ptr, rmri_ptr, simple_typed_vector_ptr, code); /* get a tuple */ RESTART: on quit quit_received = "1"b; /* Hold off quits til end of loop */ do while (code = 0); /* As long as there are tuples to be retrieved */ call mdbm_util_$store_direct (dbcb_ptr, rmri_ptr, simple_typed_vector_ptr, code); /* add tuple */ if code = 0 | code = dm_error_$key_duplication then do; /* ignore duplicates */ ftf = "0"b; dbcb.another_flag = "1"b; call mdbm_util_$mu_get_tuple (dbcb_ptr, work_area_ptr, rmri_ptr, simple_typed_vector_ptr, code); end; if quit_received then do; /* If user quit during the loop so we will NOW let it go thru */ quit_received = "0"b; revert quit; signal quit; on quit quit_received = "1"b; end; end; revert quit; if quit_received then do; /* If user quit during the loop so we will NOW let it go thru */ quit_received = "0"b; signal quit; end; on cleanup call tidy_up; if code = mrds_error_$tuple_not_found then code = 0; else call error (code, ""); %page; end store; %page; /* * * * * * * * * * * * * * * error * * * * * * * * * * * * * * */ error: proc (err_code, err_message); dcl err_code fixed bin (35); dcl err_message char (*); O_err_code = err_code; O_err_msg = err_message; call tidy_up; goto exit; end error; /* * * * * * * * * * * * * * * * tidy_up * * * * * * * * * * * * * * * */ tidy_up: proc; code = 0; if dbi ^= 0 then call dsl_$close (dbi, code); if code = 0 then dbi = 0; if must_delete_relation then do; delete_rel_info.version = RMDB_DELETE_REL_INFO_VERSION_1; delete_rel_info.absolute_db_path = db_path; delete_rel_info.db_model_ptr = dbm_ptr; delete_rel_info.relation_name = rel_name; delete_rel_info.brief = "1"b; delete_rel_info.mbz = "0"b; call rmdb_delete_relation$cleanup (rmdb_ctl_ptr, addr (delete_rel_info), err_msg, code); end; if code = 0 then call mdbm_util_$inconsistent_reset (dbm_ptr); /* Make db consistnert */ end tidy_up; %page; /*********** * * These routines are used by the transaction processing include files. * Restore_significant_data is called to reinitialize variables in case * of a rollback. Should_rollback determines whether a transaction should * be rolled back or aborted on error. Currently, it is always aborted. * **********/ restore_significant_data: proc; delete_rel_info.version = RMDB_DELETE_REL_INFO_VERSION_1; delete_rel_info.absolute_db_path = db_path; delete_rel_info.db_model_ptr = dbm_ptr; delete_rel_info.relation_name = rel_name; delete_rel_info.brief = "1"b; delete_rel_info.mbz = "0"b; call rmdb_delete_relation$cleanup (rmdb_ctl_ptr, addr (delete_rel_info), err_msg, code); must_delete_relation = "0"b; ftf = "1"b; end restore_significant_data; should_rollback: proc returns (bit (1)); return ("0"b); end should_rollback; %page; dcl addr builtin; dcl any_other condition; dcl attr_name char (32); dcl cleanup condition; dcl code fixed bin (35); dcl dbi fixed bin (35); dcl db_path char (168); dcl divide builtin; dcl dsl_$close entry () options (variable); dcl dsl_$open entry () options (variable); dcl err_msg char (256); dcl error_table_$action_not_performed fixed bin (35) ext static; dcl EXCLUSIVE_UPDATE int static options (constant) init (4); dcl fixed builtin; dcl fm_ptr ptr; dcl found bit (1); dcl ftf bit (1) aligned; dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl i fixed bin; dcl index builtin; dcl j fixed bin; dcl k fixed bin; dcl length builtin; dcl dm_error_$key_duplication fixed bin (35) ext static; dcl mrds_data_$max_select_items ext fixed bin (35); dcl mdbm_util_$mrds_dsl_translate entry (ptr, ptr, fixed bin, ptr, fixed bin, ptr, ptr, fixed bin, fixed bin (35)); dcl mrds_error_$dup_rel fixed bin (35) ext static; dcl mrds_error_$invalid_db_index fixed bin (35) ext static; dcl mrds_error_$inval_dtr_expr fixed bin (35) ext static; dcl mrds_error_$no_database fixed bin (35) ext static; dcl mrds_error_$no_db_path fixed bin (35) ext static; dcl mrds_error_$no_tuple fixed bin (35) ext static; dcl mrds_error_$previously_defined_index fixed bin (35) ext static; dcl mrds_error_$tuple_not_found fixed bin (35) ext static; dcl mrds_error_$undef_attr fixed bin (35) ext static; dcl must_delete_relation bit (1); dcl mdbm_util_$get_resultant_model_pointer entry (fixed bin (35), ptr); dcl mdbm_util_$inconsistent_reset entry (ptr); dcl mdbm_util_$inconsistent_set entry (ptr, char (*), char (*), char (*)); dcl mdbm_util_$define_temp_dir_area entry (ptr, fixed bin (35), fixed bin (18), char (11), bit (1) aligned, bit (1) aligned, bit (1) aligned, bit (1) aligned, fixed bin (35)); dcl mdbm_util_$mu_get_tuple entry (ptr, ptr, ptr, ptr, fixed bin (35)); dcl mdbm_util_$store_direct entry (ptr, ptr, ptr, fixed bin (35)); dcl mrds_data_$max_attributes ext fixed bin (35); dcl null builtin; dcl num_sel_vals fixed bin; dcl quit condition; dcl quit_received bit (1); dcl range_ptr ptr; dcl rel builtin; dcl rel_name char (32) varying; dcl rmdb_create_relation entry (ptr, ptr, bit (1), char (*), fixed bin (35)); dcl rmdb_ctl_ptr ptr; dcl rmdb_delete_relation$cleanup entry (ptr, ptr, char (*), fixed bin (35)); dcl rtrim builtin; dcl sel_exp_len fixed bin; dcl sel_exp_ptr ptr; dcl sel_val_arg_list_ptr ptr; dcl sel_val_desc_list_ptr ptr; dcl string builtin; dcl sys_info$max_seg_size fixed bin (35) ext static; dcl work_area area based (work_area_ptr); dcl work_area_ptr ptr; dcl 1 delete_rel_info aligned like rmdb_delete_rel_info; %page; %include mrds_dbcb; %page; %include mdbm_rm_rel_array; %page; %include mdbm_db_model; %page; %include mrds_select_list; %page; %include mrds_select_sets; %page; %include rmdb_create_rel_info; %page; %include mdbm_rm_rel_info; %page; %include mdbm_rm_db_info; %page; %include mdbm_rm_attr_info; %page; %include mrds_tuple_info; %page; %include rmdb_delete_rel_info; %page; %include vu_typed_vector; end rmdb_create_and_pop_rel;  rmdb_create_attribute.pl1 10/16/86 1532.6rew 10/16/86 1530.3 87129 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1985 * * * *********************************************************** */ /* format: ^inddcls,^indattr,indnoniterend,^indnoniterdo,indend,tree,^case,insnl,comcol61,dclind5,declareind5,delnl */ /*DESCRIPTION This module actually creates an unreferenced attribute. First, it verifies the input structure, creates the attribute/domain file if necessary, then builds the appropriate structures in the db model segment and adds these structures to the linked list of unreferenced attributes. */ /****^ HISTORY COMMENTS: 1) change(85-12-03,Spitzer), approve(85-12-03,MCR7311), audit(86-09-15,Gilcrease), install(86-10-16,MR12.0-1187): written END HISTORY COMMENTS */ rmdb_create_attribute: proc (Irmdb_ctl_ptr, Icreate_attr_info_ptr, Oerror_message, Ocode); /* Initialization */ rmdb_ctl_ptr = Irmdb_ctl_ptr; create_attr_info_ptr = Icreate_attr_info_ptr; local_iocb = rmdb_ctl.crossref_file_info.iocb_ptr; dbm_ptr = rmdb_ctl.db_model_ptr; /* Check input arguments */ if create_attr_info.version ^= create_attr_info_version_1 then call error (error_table_$unimplemented_version, "For create_attr_info structure."); if rmdb_ctl.absolute_db_path = "" then call error (mrds_error_$no_db_path, ""); if create_attr_info.count = 0 then call error (error_table_$wrong_no_of_args, "No attributes to be created."); /* Check to see if the attributes named do not exist and the domains named do exist. */ if local_iocb = null then do; call mdbm_util_$xref_build (rmdb_ctl.temp_dir_path, rmdb_ctl.absolute_db_path, dbm_ptr, rmdb_ctl.crossref_file_info.name, local_iocb, error_message, code); if code ^= 0 then call error (code, error_message); rmdb_ctl.crossref_file_info.iocb_ptr = local_iocb; end; do loop = 1 to create_attr_info.count; call mdbm_util_$xref_find_record (local_iocb, DOMAIN_KEY_HEAD, create_attr_info.attribute (loop).domain, null, 0, error_message, code); if code = error_table_$no_record then call error (mrds_error_$undefined_domain, create_attr_info.attribute (loop).domain); call mdbm_util_$xref_find_record (local_iocb, ATTRIBUTE_KEY_HEAD, create_attr_info.attribute (loop).name, null, 0, error_message, code); if code = 0 then call error (mrds_error_$attr_already_exists, create_attr_info.attribute (loop).name); end; /* do loop */ crossref_info_record_ptr = addr (local_record_buffer); crossref_info_record.count = 0; /* Finished verifying input structure, actually create them now. */ do loop = 1 to create_attr_info.count; call create_an_attribute (loop); end; /* do loop */ /* Finish up */ call adjust_bit_count_ (rmdb_ctl.absolute_db_path, DB_MODEL_NAME, "1"b, bcnt, code); if code ^= 0 then call error (code, pathname_ (rmdb_ctl.absolute_db_path, DB_MODEL_NAME)); call error (0, ""); RETURN_TO_CALLER: return; error: proc (code, msg); dcl code fixed bin (35) parameter; dcl msg char (*) parameter; Ocode = code; Oerror_message = msg; goto RETURN_TO_CALLER; end error; %page; /* This routine creates exactly one unreferenced attribute. First it locks the db model segment, creates the necessary structure, initializes it, then links it to the linked list of unreferenced attributes. It then unlocks the model segment and adds the necessary history structure. Note: quits are noticed but deferred until after critical code is finished. */ create_an_attribute: proc (attribute_index); dcl attribute_index fixed bin (17) parameter; quit_intercept_flag = "0"b; on quit quit_intercept_flag = "1"b; new_ua_ptr = null; /* BEGINNING OF CRITICAL CODE */ on cleanup begin; call mdbm_util_$xref_destroy (rmdb_ctl.crossref_file_info.iocb_ptr, rmdb_ctl.temp_dir_path, rmdb_ctl.crossref_file_info.name, (""), (0)); if new_ua_ptr ^= null then free new_ua_ptr -> unreferenced_attribute in (dbm_area); call mdbm_util_$inconsistent_reset (dbm_ptr); end; call mdbm_util_$inconsistent_set (dbm_ptr, "create_attribute", "Creating attribute " || create_attr_info.attribute (attribute_index).name, "delete_attribute -force -inhibit_error " || rtrim (create_attr_info.attribute (attribute_index).name)); /* Trap area conditions so that we can abort with a reasonable error message */ on area call error (error_table_$area_too_small, "No room left in the db_model segment area to add the attribute " || create_attr_info.attribute (attribute_index).name); /* Create the unreferenced_attribute structure */ allocate unreferenced_attribute in (dbm_area) set (new_ua_ptr); unspec (new_ua_ptr -> unreferenced_attribute) = "0"b; revert area; /* Add domain record to the crossreference file */ call mdbm_util_$xref_reference (local_iocb, DOMAIN_KEY_HEAD, create_attr_info.attribute (attribute_index).domain, create_attr_info.attribute (attribute_index).name, crossref_info_record_ptr, 4, error_message, code); if code ^= 0 then call error (code, error_message); /* Add attribute record to crossreference file */ call mdbm_util_$xref_create_record (local_iocb, ATTRIBUTE_KEY_HEAD, create_attr_info.attribute (attribute_index).name, crossref_info_record.offset, error_message, code); if code ^= 0 then call error (code, error_message); /* Fill it the unreferenced_attribute structure. */ new_ua_ptr -> unreferenced_attribute.name = create_attr_info.attribute (attribute_index).name; new_ua_ptr -> unreferenced_attribute.domain_ptr = crossref_info_record.offset; new_ua_ptr -> unreferenced_attribute.fwd_thread = NULL_OFFSET; /* Mark the domain in db_model referenced */ di_ptr = ptr (dbm_ptr, new_ua_ptr -> unreferenced_attribute.domain_ptr); domain_info.unreferenced = "0"b; /* Add to the linked list */ if db_model.unreferenced_attribute_ptr = NULL_OFFSET then db_model.unreferenced_attribute_ptr = rel (new_ua_ptr); else do; /* chase down to end of list */ do ua_ptr = ptr (dbm_ptr, db_model.unreferenced_attribute_ptr) repeat ptr (dbm_ptr, unreferenced_attribute.fwd_thread) while (rel (ua_ptr) ^= NULL_OFFSET); prev_ua_ptr = ua_ptr; end; /* do ua_ptr */ prev_ua_ptr -> unreferenced_attribute.fwd_thread = rel (new_ua_ptr); end; call rmdb_add_rmdb_history (dbm_ptr, RMDB_ATTR_TYPE, create_attr_info.attribute (attribute_index).domain, RMDB_ADD_ATTR_OP, create_attr_info.attribute (attribute_index).name, error_message, code); call mdbm_util_$inconsistent_reset (dbm_ptr); revert quit; /* END OF CRITICAL CODE */ if quit_intercept_flag then signal quit; if code ^= 0 then call error (code, error_message); /* from rmdb_add_rmdb_history */ return; end create_an_attribute; %page; %include mdbm_db_model; %include mdbm_file_model; %include mrds_rmdb_ctl; %include rmdb_create_attr_info; %include rmdb_crossref_info; %include rmdb_history_entry; %page; dcl addr builtin; dcl adjust_bit_count_ entry (char (168), char (32), bit (1) aligned, fixed bin (35), fixed bin (35)); dcl area condition; dcl bcnt fixed bin (35); /* bit count */ dcl cleanup condition; dcl code fixed bin (35); dcl DB_MODEL_NAME char (32) int static options (constant) init ("db_model"); dcl error_message char (500); dcl error_table_$area_too_small fixed bin (35) ext static; dcl error_table_$no_record fixed bin (35) ext static; dcl error_table_$unimplemented_version fixed bin (35) ext static; dcl error_table_$wrong_no_of_args fixed bin (35) ext static; dcl fixed builtin; dcl Icreate_attr_info_ptr ptr parameter; dcl Irmdb_ctl_ptr ptr parameter; dcl local_iocb ptr; /* attribute/domain file iocb */ dcl local_record_buffer (4) fixed bin (35); /* large enough to read the header of the crossref_info_record into */ dcl loop fixed bin (17); /* loop index */ dcl mdbm_util_$inconsistent_reset entry (ptr); dcl mdbm_util_$inconsistent_set entry (ptr, char (*), char (*), char (*)); dcl mdbm_util_$xref_build entry (char (*), char (*), ptr, char (*), ptr, char (*), fixed bin (35)); dcl mdbm_util_$xref_create_record entry (ptr, char (*), char (*), bit (18), char (*), fixed bin (35)); dcl mdbm_util_$xref_destroy entry (ptr, char (*), char (*), char (*), fixed bin (35)); dcl mdbm_util_$xref_find_record entry (ptr, char (*), char (*), ptr, fixed bin (21), char (*), fixed bin (35)); dcl mdbm_util_$xref_reference entry (ptr, char (*), char (*), char (*), ptr, fixed bin (21), char (*), fixed bin (35)); dcl mrds_error_$attr_already_exists fixed bin (35) ext static; dcl mrds_error_$no_db_path fixed bin (35) ext static; dcl mrds_error_$undefined_domain fixed bin (35) ext static; dcl new_ua_ptr ptr; /* points the new create unreferenced_attribute structure in the db_model */ dcl null builtin; dcl NULL_OFFSET bit (18) unaligned int static options (constant) init ((18)"1"b); dcl Ocode fixed bin (35) parameter; dcl Oerror_message char (*) parameter; dcl pathname_ entry (char (*), char (*)) returns (char (168)); dcl prev_ua_ptr ptr; dcl ptr builtin; dcl quit condition; dcl quit_intercept_flag bit (1) aligned; /* true ::= break key was pressed */ dcl rel builtin; dcl rmdb_add_rmdb_history entry (ptr, fixed bin, char (32), fixed bin, char (32), char (500), fixed bin (35)); dcl rtrim builtin; dcl sys_info$max_seg_size fixed bin (35) ext static; dcl unspec builtin; end rmdb_create_attribute;  rmdb_create_db.pl1 10/16/86 1534.4rew 10/16/86 1144.1 90522 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: ^inddcls,^indattr,indnoniterend,^indnoniterdo,indend,tree,^case,insnl,comcol61,dclind5,declareind5,delnl */ /* 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 COMMENTS: 1) change(85-12-03,Spitzer), approve(85-12-03,MCR7311), audit(86-09-02,Blair), install(86-10-16,MR12.0-1187): This routine is really mrds_rst_create_db with some changes in order that we may call it from something else besides the cmdb parser. END HISTORY COMMENTS */ rmdb_create_db: proc (Idb_path, Irelation_type, Irelation_modes, Oabsolute_path, Odbm_ptr, Oerror_message, Ocode); relation_type = Irelation_type; relation_modes = Irelation_modes; db_created_sw = OFF; on cleanup call tidy_up; /* Set a cleanup handler */ call expand_pathname_$add_suffix (Idb_path, "db", dir, db_ent, code); if code ^= 0 then call error (code, Idb_path); absolute_path = pathname_ (dir, db_ent); 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, absolute_path); db_created_sw = ON; /* Remember database directory was created */ /* create the submodel_dir */ call hcs_$append_branchx (absolute_path, mrds_data_$submodel_dir_name, 11, RINGS, get_group_id_$tag_star (), 1, 0, 0, code); if code ^= 0 then call error (code, pathname_ (absolute_path, mrds_data_$submodel_dir_name)); call hcs_$make_seg (absolute_path, "db_model", "", 10, dbm_ptr, code); /* Create the db_model */ if dbm_ptr = null then call error (code, pathname_ (absolute_path, DB_MODEL_NAME)); else call init_db_model; call mdbm_util_$create_control_segment (absolute_path, dbc_ptr, dbc_bit_count, code); if code ^= 0 then call error (code, pathname_ (absolute_path, DB_CONTROL_NAME)); Oabsolute_path = absolute_path; /* set output parameters */ Odbm_ptr = dbm_ptr; db_created_sw = OFF; /* so cleanup won't delete it */ call error (0, ""); /* Only exit from this procedure */ exit: return; %page; error: proc (cd, msg); dcl cd fixed bin (35) parameter; dcl msg char (*) parameter; call tidy_up; Ocode = cd; /* Set return error code */ if cd = 0 then Oerror_message = ""; else Oerror_message = msg; 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, (0)); end; end tidy_up; %page; init_db_model: procedure; /* This procedure initializes the db_model */ db_model_path = rtrim (absolute_path) || DB_MODEL_NAME; 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"; if relation_type = "vfile" then do; db_model.db_type_flags.vfile_type = "1"b; db_model.db_type_flags.transactions_needed = "0"b; end; else if relation_type = "data_management_file" then do; db_model.db_type_flags.vfile_type = "0"b; mode_bits.dm_file_type = "1"b; /* default all on */ mode_bits.protection_on = "1"b; mode_bits.concurrency_on = "1"b; mode_bits.rollback_on = "1"b; call mrds_rst_proc_ctl_args$parse_mode_string (relation_modes, mode_bits, code, error_message); if code ^= 0 then call error (code, "Parsing the mode string """ || rtrim (relation_modes) || """, encountered " || rtrim (error_message)); db_model.db_type_flags.concurrency_on = mode_bits.concurrency_on; db_model.db_type_flags.transactions_needed = "1"b; db_model.db_type_flags.rollback_on = mode_bits.rollback_on; end; else call error (error_table_$bad_arg, relation_type); db_model.consistant = "1"b; db_model.mdbm_secured = "0"b; 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 */ allocate version_status in (db_model.dbm_area) set (version_status_ptr); /* 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 = " "; return (rel (version_status_ptr)); end set_version; %page; set_change_time: procedure () returns (bit (18)); /* fill in the user_id and time for the database creator */ allocate changer in (db_model.dbm_area) set (changer_ptr); changer.id = get_group_id_ (); changer.time = clock (); changer.next = NULL_OFFSET; /* creator = last on list */ return (rel (changer_ptr)); end set_change_time; %page; %include mdbm_db_model; %page; %include mdbm_dbc; %page; %include mrds_rst_arg_info; %page; %include delete_options; %page; /* External entries */ dcl empty builtin; dcl null builtin; dcl error_message char (500); dcl absolute_path char (168); dcl addr builtin; dcl cleanup condition; dcl clock builtin; dcl code fixed bin (35); /* error code */ dcl DB_CONTROL_NAME char (32) int static options (constant) init ("db.control"); dcl db_created_sw bit (1); /* ON => Db_directory was created */ dcl db_ent char (32); /* Data base directory name */ dcl DB_MODEL_NAME char (32) int static options (constant) init ("db_model"); dcl db_model_path char (168); /* path down to db_model segment */ dcl dbc_bit_count fixed bin (24); dcl delete_$path entry (char (*), char (*), bit (36) aligned, char (*), fixed bin (35)); dcl dir char (168); /* Directory superior to data base */ dcl error_table_$bad_arg fixed bin (35) ext static; dcl expand_pathname_$add_suffix entry (char(*), char(*), char(*), char(*), fixed bin(35)); dcl fixed builtin; dcl get_group_id_ entry returns (char (32)); dcl get_group_id_$tag_star entry returns (char (32)); 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 Idb_path char (*) parameter; dcl Irelation_modes char (*) parameter; dcl Irelation_type char (*) parameter; dcl mdbm_data_$current_version ext fixed bin (35); dcl mdbm_util_$create_control_segment entry (char (168), ptr, fixed bin (24), fixed bin (35)); dcl 1 mode_bits like db_relation_modes; dcl MODULE_NAME char (18) int static options (constant) init ("rmdb_create_db"); dcl mrds_data_$current_version_status fixed bin (35) ext; /* display_mrds_dm needs to know about this */ dcl mrds_data_$submodel_dir_name char (16) ext; /* common place to get name of submodel dir */ 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(*)); dcl NULL_OFFSET bit (18) unal int static options (constant) init ("111111111111111111"b); dcl Oabsolute_path char (*) parameter; dcl Ocode fixed bin (35) parameter; dcl Odbm_ptr ptr parameter; dcl Oerror_message char (*) parameter; dcl OFF bit (1) int static options (constant) init ("0"b); dcl ON bit (1) int static options (constant) init ("1"b); dcl pathname_ entry (char (*), char (*)) returns (char (168)); dcl rel builtin; dcl relation_modes char (256); dcl relation_type char (32); dcl RINGS (3) fixed bin (3) init static options (constant) init (7, 7, 7); /* Ring brackets */ dcl rtrim builtin; dcl string builtin; dcl sys_info$max_seg_size ext fixed bin (35); dcl unique_chars_ entry (bit (*)) returns (char (15)); /* unique char string routine */ end rmdb_create_db;  rmdb_create_descriptor.rd 10/16/86 1534.1rew 10/16/86 1530.3 136998 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (C) 1975 by Massachusetts Institute of * * Technology and Honeywell Information Systems Inc. * * * *********************************************************** */ /* HISTORY COMMENTS: 1) change(85-12-03,JBlair), approve(85-12-03,MCR7311), audit(86-09-24,Gilcrease), install(86-10-16,MR12.0-1187): Modified from the new_call subroutine. Added complex numbers. Enforce max string length. END HISTORY COMMENTS */ /*++ PUSH DOWN LANGUAGE \ BEGIN / / / error \ attr / dimension / DELETE LEX(2) / error \ / dim / DELETE LEX(2) / error \ / aligned / set (aligned, 1) DELETE / attr \ / unaligned / set (aligned, 0) DELETE / attr \ / unal / set (aligned, 0) DELETE / attr \ / fixed / set (type, 1) DELETE / attr \ / float / set (type, 3) DELETE / attr \ / binary / set (base, 1) DELETE / attr \ / bin / set (base, 1) DELETE / attr \ / decimal / set (base, 2) DELETE / attr \ / dec / set (base, 2) DELETE / attr \ / real / set (mode, 1) DELETE / attr \ / complex / set (mode, 2) DELETE / attr \ / cplx / set (mode, 2) DELETE / attr \ / precision / DELETE LEX(2) / prec \ / prec / DELETE LEX(2) / prec \ / ( / LEX(2) / prec \ / bit / set (type, 19) DELETE / length \ / character / set (type, 21) DELETE / length \ / char / set (type, 21) DELETE / length \ / varying / set (varying, 1) DELETE / attr \ / var / set (varying, 1) DELETE / attr \ / nonvarying / set (varying, 0) DELETE / attr \ / signed / set (signed, 1) DELETE / attr \ / uns / set (signed, 0) DELETE / attr \ / unsigned / set (signed, 0) DELETE / attr \ / / [code = mrds_error_$bad_attribute] / RETURN \ / / / RETURN \ error / ) / [code = error_table_$improper_data_format] / RETURN \ prec_err / / [code = mrds_error_$bad_precision] / RETURN \ length / ( / LEX(2) / length_ \ / / / attr \ length_ / ( ) / LEX(-1) set(LENGTH, token.Nvalue) DELETE(-1,+1) / attr \ / ( * ) / set(LENGTH, 16777215) DELETE(-2,0) / attr \ / / / error \ prec / ( ) / LEX(-1) set(SIZE, token.Nvalue) DELETE(-1,+1) / attr \ / ( , / LEX(2) / \ / ( , ) / LEX(-3) set(SIZE, token.Nvalue) LEX(+2) set(scale,token.Nvalue) DELETE(-3,+1) / attr \ / / / prec_err \ ++*/ rmdb_create_descriptor: procedure (Astring, Ptemp, Pdesc, code); /* This internal procedure converts an argument */ /* declaration (PL/I style) into an argument */ /* descriptor. */ dcl Astring char(*), /* argument declaration. (In) */ Ptemp ptr, /* ptr to a translator_temp_ segment in which */ /* allocations can be made. (In) */ /* ptr to created argument descriptor. (Out) */ Saddr bit(1) aligned, /* on if addr(declaration) was given. (Out) */ code fixed bin(35); /* error code diagnosing any errors. (Out) */ dcl 1 D aligned, 2 type fixed bin, 2 Spacked bit(1), 2 Ndims fixed bin, 2 size fixed bin(24), 2 scale fixed bin(24), Lit fixed bin, Lstr fixed bin, Ndims fixed bin, Nparens fixed bin, Pit ptr, Pstr ptr, (aligned, address, signed, varying) fixed bin(1), (base, mode) fixed bin(2), i fixed bin, (LENGTH, SIZE) fixed bin(24), scale fixed bin(8), type fixed bin(6); dcl it char(Lit) based (Pit), str char(Lstr) based (Pstr), str_array (Lstr) char(1) based (Pstr), value bit(36) aligned based (Pdesc); dcl Pdesc ptr; dcl (addr, bit, divide, length, null, search, size, string) builtin; dcl set generic ( set1 when (fixed bin(1),*), set2 when (fixed bin(2),*), set6 when (fixed bin(6),*), set8 when (fixed bin(8),*), set24 when (fixed bin(24),*)); dcl (mrds_error_$bad_array_bounds, mrds_error_$bad_attribute, mrds_error_$bad_precision, mrds_error_$inconsistent_attributes, mrds_error_$invalid_string_length, mrds_data_$max_string_size, error_table_$improper_data_format, error_table_$unbalanced_parentheses) fixed bin(35) ext static; Saddr = "0"b; code = 0; /* clear error code. */ Ptoken, Pthis_token = null; /* initialize semantic analysis variables. */ Nparens = 0; /* initialize parenthesis depth count. */ Pstr = addr(Astring); /* overlay PL/I argument declaration. */ Lstr = length(Astring); aligned = -1; type = -1; base = -1; mode = -1; signed = -1; varying = -1; address = -1; Ndims = 0; LENGTH = -1; SIZE = -1; scale = -129; do while (Lstr > 0); /* parse declaration into tokens. */ i = search (str, " _,():"); if i = 0 then i = Lstr + 1; if i > 1 then do; Pit = Pstr; Lit = i-1; call make_token (it); if i <= Lstr then do; Pstr = addr(str_array(i)); Lstr = Lstr - (i-1); end; else Lstr = 0; end; if Lstr > 0 then do; Pit = Pstr; Lit = 1; if it = "(" then Nparens = Nparens + 1; else if it = ")" then Nparens = Nparens - 1; if it = " " then; else if it = "_" then; else call make_token(it); if Lstr > 1 then Pstr = addr(str_array(2)); Lstr = Lstr - 1; end; end; if Nparens ^= 0 then do; code = error_table_$unbalanced_parentheses; return; end; call SEMANTIC_ANALYSIS(); if code = -1 then do; code = 0; return; end; if code ^= 0 then return; /* apply PL/I Lanuage Default Rules. */ if type = -1 then /* default(^(character|bit|pointer|offset|area| */ if base = -1 then /* label|entry|file|fixed|float|binary|decimal| */ if mode = -1 then do; /* real|complex)) fixed binary real; */ type = 1; base = 1; mode = 1; end; if type = -1 then do; if mode ^= -1 then /* default((real|complex)&^float) fixed; */ if type ^= 3 then type = 1; if base ^= -1 then /* default((binary|decimal)&^float) fixed; */ if type ^= 3 then type = 1; end; if (type = 1) | (type = 3) then /* default((fixed|float)&^complex) real; */ if mode ^= 2 then mode = 1; if (type = 1) | (type = 3) then /* default((fixed|float)&^decimal) binary; */ if base ^= 2 then base = 1; if type = 1 then /* default(fixed&binary&^precision) */ if base = 1 then /* precison(17,0); */ if SIZE = -1 then do; SIZE = 17; scale = 0; end; else if scale = -129 then scale = 0; if type = 1 then /* default(fixed&decimal&^precision) */ if base = 2 then /* precision(7,0); */ if SIZE = -1 then do; SIZE = 7; scale = 0; end; else if scale = -129 then scale = 0; if type = 3 then /* default(float&binary&^precision) */ if base = 1 then /* precision(27); */ if SIZE = -1 then SIZE = 27; if type = 3 then /* default(float&decimal&^precision) */ if base = 2 then /* precision(10); */ if SIZE = -1 then SIZE = 10; if type = 18 then /* default(character&^length) length(1024); */ if LENGTH = -1 then LENGTH = 1024; if (type = 19) | (type = 21) then do; /* default((character|bit)&^length) length(1); */ if LENGTH = -1 then LENGTH = 1; /* default((character|bit)&^varying) nonvarying; */ if varying ^= 1 then varying = 0; /* default((character|bit)&^aligned) unaligned; */ if aligned ^= 1 then aligned = 0; end; if aligned ^= 0 then aligned = 1; /* default(^unaligned) aligned; */ go to do(type); do(1): /* it's a fixed number. */ if base = 1 then do; /* a fixed binary number. */ if SIZE > 35 then type = type + 1; /* a fixed binary long number. */ if mode = 2 then type = type + 4; /* a complex fixed binary number. */ if SIZE > 71 then go to error_oob; if SIZE < 1 then go to error_oob; if scale > +127 then go to error_oob; if scale < -128 then go to error_oob; end; else /* if base = 2 then */ do; /* a fixed decimal number. */ type = type + 8; if mode = 2 then type = type + 2; /* a complex fixed decimal number. */ if aligned = 0 then type = type + 34; /* 4-bit byte aligned. */ if SIZE > 59 then go to error_oob; if SIZE < 1 then go to error_oob; if scale > +127 then go to error_oob; if scale < -128 then go to error_oob; end; if varying ^= -1 then go to error; if LENGTH ^= -1 then go to error; if type < 3 & signed = 0 then type = type + 32; go to join; do(3): /* it's a floating number. */ if base = 1 then do; /* a float binary number. */ if SIZE > 27 then type = type + 1; /* a float binary long number. */ if mode = 2 then type = type + 4; /* a complex float binary number. */ if SIZE > 63 then go to error_oob; if SIZE < 1 then go to error_oob; if scale = -129 then; else go to error; end; else /* if base = 2 then */ do; /* a float decimal number. */ type = type + 7; if mode = 2 then type = type + 2; /* a complex float decimal number. */ if aligned = 0 then type = type + 34; /* 4-bit byte aligned. */ if SIZE > 59 then go to error_oob; if SIZE < 1 then go to error_oob; if scale = -129 then; else go to error; end; if varying ^= -1 then go to error; if LENGTH ^= -1 then go to error; scale = 0; go to join; do(19): /* it's a bit string. */ do(21): /* it's a character string. */ if varying = 1 then do; /* a varying string. */ type = type + 1; if aligned ^= 1 then aligned = 1; end; if base ^= -1 then go to error; if mode ^= -1 then go to error; if scale ^= -129 then go to error; if SIZE ^= -1 then go to error; if LENGTH < 0 then go to error_oob; if (type = 19 & divide (LENGTH+35, 36, 24, 0) > mrds_data_$max_string_size) | (type = 21 & LENGTH > mrds_data_$max_string_size) then do; code = mrds_error_$invalid_string_length; return; end; SIZE = LENGTH; go to join; join: D.type = type; D.Spacked = ^bit(aligned,1); D.Ndims = 0; D.size = SIZE; D.scale = scale; D.Ndims = Ndims; call encode_descriptor (D.type, D.Spacked, D.Ndims, D.size, D.scale, value); if address = 1 then Saddr = "1"b; return; error: code = mrds_error_$inconsistent_attributes; return; error_array: code = mrds_error_$bad_array_bounds; return; error_oob: code = mrds_error_$bad_precision; return; %include translator_temp_alloc; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ make_token: proc (value); /* internal procedure to make a token descriptor. */ dcl value char(*); /* value of the token. */ dcl P ptr; /* ptr to newly-allocated token. */ P = allocate (Ptemp, size(token)); if Ptoken = null then do; P->token.Plast = null; Pthis_token = P; Ptoken = P; end; else do; token.Pnext = P; P->token.Plast = Ptoken; Ptoken = token.Pnext; end; token.Pnext = null; token.Pvalue = addr(value); token.Lvalue = length(value); token.Nvalue = 0; token.Pstmt = null; token.Psemant = null; string(token.S) = ""b; end make_token; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ set1: procedure (var1, value); /* if var hasn't been set1 yet, set1 it to value; */ /* else complain. */ dcl var1 fixed bin(1), var2 fixed bin(2), var6 fixed bin(6), var8 fixed bin(8), var24 fixed bin(24), value fixed bin(35) unal; if var1 ^= -1 then go to error; var1 = value; return; set2: entry (var2, value); if var2 ^= -1 then go to error; var2 = value; return; set6: entry (var6, value); if var6 ^= -1 then go to error; var6 = value; return; set8: entry (var8, value); if var8 ^= -129 then go to error; var8 = value; return; set24: entry (var24, value); if var24 ^= -1 then go to error; var24 = value; end set1; %page; encode_descriptor: procedure (type, packed, Ndims, size, scale, descriptor); dcl type fixed bin, /* data type */ packed bit(1) aligned, /* on if data packed*/ Ndims fixed bin, /* dimension (data) */ size fixed bin (24), /* size (data) */ scale fixed bin (24), /* scale (data) */ descriptor bit(36) aligned; /* descriptor (data)*/ dcl 1 D based (addr (descriptor)) aligned, (2 flag bit (1), 2 type bit (6), 2 packed bit (1), 2 Ndims bit (4), 2 size bit (24)) unaligned; dcl (addr, bit, fixed, substr) builtin; /* * * ** * * * * * * * * * * * * * * * * * * * * * * */ D.flag = "1"b; /* new type desc. */ D.type = bit (fixed (type, 6), 6); /* set type */ D.packed = packed; /* set packed bit */ go to set (type); set( 1): /* real fixed bin short */ set( 2): /* real fixed bin long */ set( 3): /* real float bin short */ set( 4): /* real float bin long */ set( 5): /* complex fixed bin short */ set( 6): /* complex fixed bin long */ set( 7): /* complex float bin short */ set( 8): /* complex float bin long */ set( 9): /* real fixed decimal */ set(10): /* real float decimal */ set(11): /* complex fixed decimal */ set(12): /* complex float decimal */ set(33): /* real fixed binary short unsigned */ set(34): /* real fixed binary long unsigned */ set(43): /* real fixed decimal 4-bit byte-aligned*/ set(44): /* real float decimal 4-bit byte_aligned*/ set(45): /* complex fixed dec 4-bit byte_aligned */ set(46): /* complex float dec 4-bit byte_aligned */ D.Ndims = bit (fixed (Ndims, 4), 4); if scale < 0 then substr (D.size, 1, 12) = bit (fixed (scale + 1000000000000b, 12), 12); else substr (D.size, 1, 12) = bit (fixed (scale, 12), 12); substr (D.size, 13, 12) = bit (fixed (size, 12), 12); return; set(19): /* bit string */ set(20): /* varying bit string */ set(21): /* character string */ set(22): /* varying character string */ D.Ndims = bit (fixed (Ndims, 4), 4); D.size = bit (fixed (size, 24), 24); return; end encode_descriptor;  rmdb_create_domain.pl1 10/16/86 1532.7rew 10/16/86 1530.3 102195 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1985 * * * *********************************************************** */ /* format: ^inddcls,^indattr,indnoniterend,^indnoniterdo,indend,tree,^case,insnl,comcol61,dclind5,declareind5,delnl */ /*DESCRIPTION This routine creates unreferenced domains in the db_model segment. The specified domains must not already exist. The crossreference is updated with the created domains. /* /****^ HISTORY COMMENTS: 1) change(85-12-03,Spitzer), approve(85-12-03,MCR7311), audit(86-09-24,Blair), install(86-10-16,MR12.0-1187): written END HISTORY COMMENTS */ rmdb_create_domain: proc (Irmdb_ctl_ptr, Icreate_domain_info_ptr, Oerror_message, Ocode); rmdb_ctl_ptr = Irmdb_ctl_ptr; if rmdb_ctl.version ^= RMDB_CTL_VERSION_1 then call error (error_table_$unimplemented_version, "Version " || ltrim (char (rmdb_ctl.version)) || " of rmdb_ctl structure."); create_domain_info_ptr = Icreate_domain_info_ptr; if create_domain_info.version ^= create_domain_info_version_1 then call error (error_table_$unimplemented_version, "Version " || create_domain_info.version || " of create_domain_info structure."); if create_domain_info.count < 1 then call error (error_table_$action_not_performed, "No domains to create."); dbm_ptr = rmdb_ctl.db_model_ptr; if rmdb_ctl.crossref_file_info.iocb_ptr = null then do; call mdbm_util_$xref_build (rmdb_ctl.temp_dir_path, rmdb_ctl.absolute_db_path, dbm_ptr, rmdb_ctl.crossref_file_info.name, rmdb_ctl.crossref_file_info.iocb_ptr, error_message, code); if code ^= 0 then call error (code, error_message); end; local_iocb = rmdb_ctl.crossref_file_info.iocb_ptr; /* Loop through all domains to be created to see if they already exist. */ do loop = 1 to create_domain_info.count; call mdbm_util_$xref_find_record (local_iocb, DOMAIN_KEY_HEAD, create_domain_info.name (loop), null, 0, error_message, code); if code = 0 then call error (mrds_error_$domain_already_defined, create_domain_info.name (loop)); else if code ^= error_table_$no_record then call error (code, error_message); end; /* do loop */ /* Find the pointer to the last domain_info structure so we can add on the end of the linked list. */ last_di_ptr = null; do di_ptr = ptr (dbm_ptr, db_model.domain_ptr) repeat ptr (dbm_ptr, domain_info.fwd_thread) while (rel (di_ptr) ^= NULL_OFFSET); last_di_ptr = di_ptr; end; /* do di_ptr */ /* Trap areas so we can return a intelligable error message. */ on area call error (error_table_$area_too_small, "Creating domain_info in the db_model segment."); /* Now go through and create each domain. */ do loop = 1 to create_domain_info.count; call create_a_domain (loop); end; /* do loop */ call error (0, ""); RETURN_TO_CALLER: return; error: proc (cd, msg); dcl cd fixed bin (35) parameter; dcl msg char (*) parameter; Ocode = cd; if cd = 0 then Oerror_message = ""; else Oerror_message = error_message; goto RETURN_TO_CALLER; end error; %page; create_a_domain: proc (idx); dcl idx fixed bin parameter; dcl new_changer_ptr ptr; dcl new_di_ptr ptr; dcl new_path_ptr (3) ptr; dcl quit_occured bit (1) aligned; quit_occured = "0"b; new_di_ptr, new_path_ptr (*), new_changer_ptr = null; on cleanup call cleaner; on quit quit_occured = "1"b; /* BEGIN CRITICAL CODE */ call mdbm_util_$inconsistent_set (dbm_ptr, "create_attribute", "Creating attribute " || create_domain_info.name (idx), "delete_domain -force -inhibit_error " || create_domain_info.name (idx)); /* Create the new domain_info structure and populate it */ allocate domain_info in (db_model.dbm_area) set (new_di_ptr); unspec (new_di_ptr -> domain_info) = "0"b; new_di_ptr -> domain_info.name = create_domain_info.name (idx); new_di_ptr -> domain_info.unreferenced = "1"b; new_di_ptr -> domain_info.db_desc = create_domain_info.descriptor (idx); new_di_ptr -> domain_info.user_desc = create_domain_info.decode_declare_data_descriptor (idx); if new_di_ptr -> domain_info.user_desc = "0"b then new_di_ptr -> domain_info.user_desc = new_di_ptr -> domain_info.db_desc; new_di_ptr -> domain_info.fwd_thread = NULL_OFFSET; call set_path (new_di_ptr -> domain_info.check_path_ptr, create_domain_info.check_proc_path (idx), 1); call set_path (new_di_ptr -> domain_info.encd_path_ptr, create_domain_info.encode_proc_path (idx), 2); call set_path (new_di_ptr -> domain_info.decd_path_ptr, create_domain_info.decode_proc_path (idx), 3); new_di_ptr -> domain_info.ck_stack_ptr = NULL_OFFSET; new_di_ptr -> domain_info.str_before_path_ptr = NULL_OFFSET; new_di_ptr -> domain_info.str_err_path_ptr = NULL_OFFSET; new_di_ptr -> domain_info.str_after_path_ptr = NULL_OFFSET; new_di_ptr -> domain_info.get_before_path_ptr = NULL_OFFSET; new_di_ptr -> domain_info.get_err_path_ptr = NULL_OFFSET; new_di_ptr -> domain_info.get_after_path_ptr = NULL_OFFSET; new_di_ptr -> domain_info.mod_before_path_ptr = NULL_OFFSET; new_di_ptr -> domain_info.mod_err_path_ptr = NULL_OFFSET; new_di_ptr -> domain_info.mod_after_path_ptr = NULL_OFFSET; new_di_ptr -> domain_info.unused_1 = NULL_OFFSET; new_di_ptr -> domain_info.unused_2 = NULL_OFFSET; /* Create the changer structure and populate it. */ allocate changer in (db_model.dbm_area) set (new_changer_ptr); new_changer_ptr -> changer.id = get_group_id_ (); new_changer_ptr -> changer.time = clock (); new_changer_ptr -> changer.next = NULL_OFFSET; new_di_ptr -> domain_info.changer_ptr = rel (new_changer_ptr); /* Add the new domain to the crossreference file */ call mdbm_util_$xref_create_record (local_iocb, DOMAIN_KEY_HEAD, create_domain_info.name (idx), rel (new_di_ptr), error_message, code); if code ^= 0 then do; call cleaner; call error (code, error_message); end; /* Add a new attribute record to the crossreference file, as all domains have an attribute with the same name be default. */ call mdbm_util_$xref_create_record (local_iocb, ATTRIBUTE_KEY_HEAD, create_domain_info.name (idx), rel (new_di_ptr), error_message, code); if code ^= 0 then do; call cleaner; call error (code, error_message); end; /* Now we mark the created domain record as referenced by the attribute with the same name */ call mdbm_util_$xref_reference (local_iocb, DOMAIN_KEY_HEAD, create_domain_info.name (idx), create_domain_info.name (idx), null, (0), error_message, code); if code ^= 0 then do; call cleaner; call error (code, error_message); end; /* Add the new domain_info to the end of the linked list. */ if last_di_ptr = null then db_model.domain_ptr = rel (new_di_ptr); else last_di_ptr -> domain_info.fwd_thread = rel (new_di_ptr); last_di_ptr = new_di_ptr; db_model.num_domains = db_model.num_domains + 1; call rmdb_add_rmdb_history (dbm_ptr, RMDB_DOMAIN_TYPE, create_domain_info.name (idx), RMDB_ADD_DMN_OP, "", error_message, code); if code ^= 0 then call error (code, error_message); call mdbm_util_$inconsistent_reset (dbm_ptr); revert quit; /* END CRITICAL CODE */ if quit_occured then signal quit; return; %page; cleaner: proc; dcl based_item fixed bin (35) based; dcl p ptr; /* Free all the created structures in db_model segment */ do p = new_changer_ptr, new_di_ptr, new_path_ptr (1), new_path_ptr (2), new_path_ptr (3); if p ^= null then free p -> based_item; end; call mdbm_util_$xref_destroy (rmdb_ctl.crossref_file_info.iocb_ptr, rmdb_ctl.temp_dir_path, rmdb_ctl.crossref_file_info.name, (""), (0)); call mdbm_util_$inconsistent_reset (dbm_ptr); return; end cleaner; set_path: proc (sp_offset, sp_path, sp_idx); dcl sp_dir char (168); dcl sp_dollar_index fixed bin; dcl sp_entry char (32); dcl sp_idx fixed bin parameter; dcl sp_name char (32); dcl sp_offset bit (18) unaligned parameter; dcl sp_path char (*) parameter; if sp_path = "" then do; sp_offset = NULL_OFFSET; new_path_ptr (idx) = null; end; else do; sp_dollar_index = index (sp_path, "$"); if sp_dollar_index ^= 0 then do; sp_entry = substr (sp_path, sp_dollar_index + 1); substr (sp_path, sp_dollar_index) = ""; end; else sp_entry = ""; call expand_pathname_ (sp_path, sp_dir, sp_name, code); if code ^= 0 then call error (code, sp_path); allocate path_entry in (db_model.dbm_area) set (new_path_ptr (idx)); new_path_ptr (idx) -> path_entry.path = pathname_ (sp_dir, sp_name); if sp_entry = "" then new_path_ptr (idx) -> path_entry.entry = sp_name; else new_path_ptr (idx) -> path_entry.entry = sp_entry; new_path_ptr (idx) -> path_entry.reserved = "0"b; sp_offset = rel (new_path_ptr (idx)); end; return; end set_path; end create_a_domain; %page; %include mdbm_db_model; %page; %include rmdb_create_domain_info; %include rmdb_crossref_info; %include rmdb_history_entry; %include mrds_rmdb_ctl; %page; dcl addr builtin; dcl area condition; dcl char builtin; dcl cleanup condition; dcl clock builtin; dcl code fixed bin (35); dcl error_message char (500); dcl error_table_$action_not_performed fixed bin (35) ext static; dcl error_table_$area_too_small fixed bin (35) ext static; dcl error_table_$no_record fixed bin (35) ext static; dcl error_table_$unimplemented_version fixed bin (35) ext static; dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl fixed builtin; dcl get_group_id_ entry () returns (char (32)); dcl Icreate_domain_info_ptr ptr parameter; dcl index builtin; dcl Irmdb_ctl_ptr ptr parameter; dcl last_di_ptr ptr; dcl local_iocb ptr; dcl loop fixed bin (17); dcl ltrim builtin; dcl mdbm_util_$inconsistent_reset entry (ptr); dcl mdbm_util_$inconsistent_set entry (ptr, char (*), char (*), char (*)); dcl mdbm_util_$xref_build entry (char (*), char (*), ptr, char (*), ptr, char (*), fixed bin (35)); dcl mdbm_util_$xref_create_record entry (ptr, char (*), char (*), bit (18), char (*), fixed bin (35)); dcl mdbm_util_$xref_destroy entry (ptr, char (*), char (*), char (*), fixed bin (35)); dcl mdbm_util_$xref_find_record entry (ptr, char (*), char (*), ptr, fixed bin (21), char (*), fixed bin (35)); dcl mdbm_util_$xref_reference entry (ptr, char (*), char (*), char (*), ptr, fixed bin (21), char (*), fixed bin (35)); dcl mrds_error_$domain_already_defined fixed bin (35) ext static; dcl null builtin; dcl NULL_OFFSET bit (18) unaligned int static options (constant) init ((18)"1"b); dcl Ocode fixed bin (35) parameter; dcl Oerror_message char (*) parameter; dcl pathname_ entry (char (*), char (*)) returns (char (168)); dcl ptr builtin; dcl quit condition; dcl rel builtin; dcl rmdb_add_rmdb_history entry (ptr, fixed bin, char (32), fixed bin, char (32), char (500), fixed bin (35)); dcl substr builtin; dcl sys_info$max_seg_size fixed bin (35) ext static; dcl unspec builtin; end rmdb_create_domain;  rmdb_create_index.pl1 10/16/86 1551.9r w 10/16/86 1143.2 242442 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /****^ 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-05-06 by Thanh Nguyen. (see mrds #136) END HISTORY COMMENTS */ rmdb_create_index: proc (rci_rmdb_ctl_ptr, rci_db_abs_path, rci_db_model_ptr, rci_rel_name, rci_attr_name, rci_error_message, rci_code); /* BEGIN_DESCRIPTION This module will change a non-indexed attribute in a relation into an indexed attribute. This process involves both updating the structures in the model and writing the new index. An attempt has been made to make certain operations uninterruptable by the user. These operations are the updates to the data model (including marking the data base as inconsistent) and the addition of a new index. To do this any quits signaled by the user are delayed until the operations are complete. NOTE: Naming convention: because of the number of internal routines and the need for descriptive names, variables declared in all routines (including the main entry) have prefixes that are the initials of the routine name. Global variables can be identified since they have a prefix different from that derived from the routine name. Variables with the same name except for the prefix mean the same thing. Variables without a prefix are external to the module, i.e. entry names, external static, builtins, conditions, etc. These variables are declared in the main routine. In order to reduce the complexity of this module, none of the internal routines have an error code parameter. Instead they set a global error code declared in the main routine, call the clean_up routine, and perform a non-local goto to leave the module. END_DESCRIPTION Known Bugs: Other Problems: HISTORY 82-04-23 Davids: Written 82-04-29 Davids: changed to use the new calling sequence of mu_db_inconsistent also changed the output messages and comments to reflect that amdb will NOT have a -consistent control arg. changed cleanup routine so that calls to iox_$detach and iox_$destroy are always made even if the call to iox_close fails, this is because the iocb could be attached but not open. 82-04-30 Davids: changed to use the $set entry in mu_db_inconsistent which is still the main entry but more discriptive also added the " -brief" control arg on the undo request and added the call to iox_$control "start" to the cleanup handler. 82-05-07 Davids: added code to signal quit after the exit_rmdb_create_index label so that if the caller hits quit and then an error occurs the quit does not get lost because the error handling code calls cleanup and then does a non-local goto to exit_rmdb_create_index. 82-05-25 Davids: added rci_db_model_ptr parameter and removed code that used toget the pointer. 82-06-24 Davids: removed declared but unreferenced variables, reformated lines to prevent wrap-around. changed -force to -brief in the undo request. 82-07-01 Roger Lackey : Modified the calls to mu_db_inconsistent to use mdbm_util_$inconsistent_* for binding. 82-07-02 R. Harvey : Modified the calls to mu_data_length, mu_data_class$*, mu_encd_key$*, mu_scan_records$* for binding 82-07-20 Davids: corrected the way that the tuple_id was built in the get_a_tuple procedure, it was taking the first 7 bits from the file_id , it was supposed to be taking the last 7. 82-08-20 D. Woodka : deleted references to mdbm_tuple_id include file for DMS conversion. 82-09-15 D. Woodka : Modified for DMS Conversion: removed references to tuples and modified the module to call rmdb_relmgr_entries.open and rmdb_relmgr_entries.create_index 83-01-06 Davids: Modified the internal procedure get_attribute_data to no longer calculate the new_index_id and to no longer check the rel_info.max_attr_index_id to be sure its < 512 which was needed to be sure that the newly calculated value would fit in the 8-bit field. The relation manager will be suppling the new index_id. Also modified the internal proc update_model to null the attr_info.index_id and set rel_info.max_attr_index_id to 512. The index_id must be nulled so that when the vfile relation manager looks at the model it knows that the field is not an index yet. The value of max_attr_index_id is set to 512 to keep MR10.1 rmdb from working since once MR10.2 rmdb is used the way that MR10.1 rmdb calcualted the index id cannot be guarenteeded to produce an index_id that MR10.2 rmdb did not already use. Added code to handle transactions. 83-01-14 Davids: Modified code to report error in transaction finishing and to correctly handle reporting errors in the clean_up procedure. 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-05-24 Davids: Added code to change the version of the saved resultant so that it will not be incorrectly used in an opening. */ %page; /* PARAMETERS */ dcl rci_db_abs_path char (168); /* (input) path to the data base to be restructured */ dcl rci_db_model_ptr ptr; /* (input) pointer to the db_model for the database */ dcl rci_rel_name char (*); /* (input) name of relation to be restructured */ dcl rci_attr_name char (*); /* (input) name of attribute to be indexed */ dcl rci_error_message char (500); /* (output) text of message in the event of an error */ dcl rci_code fixed bin (35); /* (output) standard error message */ /* AUTOMATIC */ dcl rci_attr_defn_order fixed bin; dcl rci_attr_desc bit (36); /* standard multics descriptor of the attribute to be indexed */ dcl rci_attr_ptr ptr; /* pointer to the attr_info structure */ dcl rci_backout_occured bit (1); /* true if restore_significant_data has been called */ dcl rci_caller_name char (17); /* for call to get_temp_segment_ */ dcl rci_file_id bit (36); /* id of the file as defined in the database model */ dcl rci_file_model_ptr ptr; /* pointer to the file model that contains the relation */ dcl rci_flag_list bit (36) aligned; /* flag structure for create_index */ dcl rci_max_data_length fixed bin; /* maximum number of bits of data a tuple may have, if tuple */ /* contains varying data the actual number may be less */ dcl rci_number_of_attrs fixed bin; /* number of attributes in the relation */ dcl rci_number_of_varying_attrs fixed bin; /* number of varying attributes in the relation */ dcl rci_original_rel_info_indexed bit (1); /* value of the indexed element in rel_info before the model was updated */ dcl rci_original_rel_info_max_attr_index_id fixed bin; /* ditto */ dcl rci_quit_signaled bit (1); /* true if a quit was signaled */ dcl rci_rel_id bit (36); /* id of the relation as defined in rel_info */ dcl rci_rel_opening_id bit (36) aligned; /* opening identifier of the relation */ dcl rci_rel_ptr ptr; /* pointer to the rel_info structure */ dcl rci_rmdb_ctl_ptr ptr; dcl rci_style fixed bin (17) init (1); dcl wa area; /* BUILTINS */ dcl addr builtin; dcl ceil builtin; dcl empty builtin; dcl fixed builtin; dcl length builtin; dcl null builtin; dcl pointer builtin; dcl rel builtin; dcl rtrim builtin; /* BAESED */ dcl rci_based_char8 char (8) based; /* overlay on the saved res version */ /* CONDITIONS */ dcl any_other condition; dcl cleanup condition; dcl quit condition; %page; /* ENTRIES */ dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl ioa_$rs entry () options (variable); dcl mdbm_util_$mu_data_length entry (bit (36)) returns (fixed bin (35)); dcl mdbm_util_$inconsistent_set entry (ptr, char (*), char (*), char (*)); dcl mdbm_util_$inconsistent_reset entry (ptr); dcl rmdb_add_rmdb_history entry (ptr, fixed bin, char (32), fixed bin, char (32), char (500), fixed bin (35)); /* EXTERNAL STATIC */ dcl error_table_$action_not_performed fixed bin (35) ext static; dcl sys_info$max_seg_size fixed bin (35) ext static; /* needed by include files */ /* INCLUDES */ %page; %include mdbm_db_model; %page; %include mdbm_file_model; %page; %include mdbm_index; %page; %include rmdb_history_entry; %page; %include mrds_rmdb_ctl; %page; %include dm_rel_creation_info; %page; %include dm_id_list; %page; %include dm_relation_index_flags; %page; /* Initialize variables which may be referenced before they are set somewhere else */ rci_quit_signaled = "0"b; rmdb_ctl_ptr = rci_rmdb_ctl_ptr; rci_rel_opening_id = "0"b; rci_backout_occured = "0"b; mstxn_transactions_needed = "0"b; mstxn_txn_id = "0"b; /* If the database needs transactions and one is already in progress stop right now. */ if rci_db_model_ptr -> db_model.db_type_flags.transactions_needed then do; mstxn_transactions_needed = "1"b; call transaction_manager_$get_current_txn_id (mstxn_txn_id, mstxn_code); if mstxn_code ^= dm_error_$no_current_transaction then do; rci_code = error_table_$action_not_performed; rci_error_message = "Indexes may not be created while a transaction is in progress, " || "commit or abort current transaction and try again."; goto exit_rmdb_create_index; end; end; /* Get pointers to the db_model and relation's file model, extract from the models those values needed to build the index */ call initiate_models (rci_db_abs_path, rci_rel_name, rci_file_model_ptr); call get_relation_data (rci_db_model_ptr, rci_file_model_ptr, rci_rel_name, rci_file_id, rci_rel_ptr, rci_rel_id, rci_number_of_attrs, rci_number_of_varying_attrs, rci_max_data_length); call get_attribute_data (rci_db_model_ptr, rci_file_model_ptr, rci_rel_ptr, rci_rel_name, rci_attr_name, rci_attr_ptr, rci_attr_desc, rci_attr_defn_order); on cleanup call mstxn_cleanup; on any_other call mstxn_any_other; rci_caller_name = "rmdb_create_index"; ai_ptr = rci_attr_ptr; il_number_of_ids = 1; allocate id_list in (wa); id_list.number_of_ids = 1; id_list.version = ID_LIST_VERSION_1; id_list.id (1) = rci_attr_ptr -> attr_info.defn_order; /* initialize values for create_index */ rci_style = 1; relation_index_flags_ptr = addr (rci_flag_list); relation_index_flags.relation_must_be_empty = "0"b; relation_index_flags.index_is_clustering = "0"b; relation_index_flags.index_is_unique = "0"b; relation_index_flags.pad = "0"b; %page; %include mrds_start_transaction; if mstxn_code ^= 0 then do; rci_error_message = "Could not start a transaction"; goto exit_rmdb_create_index; end; rci_backout_occured = "0"b; /* Update the model. This operation consists of marking the data base as inconsistent and updating the relation and attribute models. The version of the saved resultant is also changed so that it will not be used for opening the database. In addition a history entry is added to the data base model. This update is done before any of the data is changed so that there is enough information avaiable so that the delete_index request can work. If a quit is signaled during this time, the fact is recorded, but the quit is not processed. After the model has been completely updated the quit is signaled. */ on quit rci_quit_signaled = "1"b; rmdb_ctl_ptr -> rmdb_ctl.saved_res_version_ptr -> rci_based_char8 = "RESTRUCT"; call mdbm_util_$inconsistent_set (rci_db_model_ptr, "create_index", "Indexing attribute " || rtrim (rci_attr_name) || " in relation " || rtrim (rci_rel_name), "delete_index " || rtrim (rci_rel_name) || " " || rtrim (rci_attr_name) || " -brief"); call update_model (rci_db_model_ptr, rci_rel_ptr, rci_attr_ptr); revert quit; if rci_quit_signaled then do; rci_quit_signaled = "0"b; signal quit; end; on cleanup begin; call mstxn_cleanup; call clean_up ("0"b, "1"b); end; call rmdb_ctl.relmgr_entries.open (rci_db_abs_path, rci_rel_name, rci_rel_opening_id, rci_code); if rci_code ^= 0 then do; rci_error_message = "Could not open the relation to create the index."; call restore_significant_data; goto mftxn_exit; /* need to reset the inconsistency of db */ end; call rmdb_ctl.relmgr_entries.create_index (rci_rel_opening_id, id_list_ptr, rci_flag_list, rci_style, attr_info.index_id, rci_code); mftxn_code = rci_code; %include mrds_finish_transaction; if mftxn_code ^= 0 then do; rci_error_message = "Cound not finish the transaction."; call clean_up ("0"b, "1"b); goto exit_rmdb_create_index; end; if ^rci_backout_occured & rci_code ^= 0 /* if error occured during creation process */ then do; rci_error_message = "Could not add an index"; call clean_up ("0"b, "1"b); goto exit_rmdb_create_index; end; /* Mark the data base as consistent again don't let the user interrupt. Also cleanup attachments in this case the "1"b indicates that any non-zero error code produced in the cleanup handler should be returned to the user, since the database is not marked inconsistent the value of the second switch is "0"b. */ on quit rci_quit_signaled = "1"b; call mdbm_util_$inconsistent_reset (rci_db_model_ptr); revert quit; if rci_quit_signaled then do; rci_quit_signaled = "0"b; signal quit; end; call clean_up ("1"b, "0"b); exit_rmdb_create_index: if rci_quit_signaled then do; revert quit; rci_quit_signaled = "0"b; signal quit; end; return; %page; should_rollback: proc () returns (bit (1)); return ("0"b); end should_rollback; restore_significant_data: proc; dcl rsd_code fixed bin (35); dcl rsd_error_message char (500); rci_rel_ptr -> rel_info.indexed = rci_original_rel_info_indexed; rci_rel_ptr -> rel_info.max_attr_index_id = rci_original_rel_info_max_attr_index_id; rci_attr_ptr -> attr_info.index_attr = "0"b; call rmdb_add_rmdb_history (rci_db_model_ptr, RMDB_REL_TYPE, (rci_rel_ptr -> rel_info.name), RMDB_DEL_IDX_OP, (rci_attr_ptr -> attr_info.name), rsd_error_message, rsd_code); rci_error_message = rtrim (rci_error_message) || " Backout has occured."; if rci_rel_opening_id ^= "0"b then call rmdb_ctl.relmgr_entries.close (rci_rel_opening_id, rsd_code); rci_rel_opening_id = "0"b; rci_backout_occured = "1"b; return; end restore_significant_data; %page; initiate_models: proc (im_db_abs_path, im_rel_name, im_file_model_ptr); /* This routine initiates a pointer to the file_model segment that contains the relation model. If the file model cannot be found it indicates that the data base does not contain the relation. */ /* PARAMETERS */ dcl im_db_abs_path char (168); /* (input) path to the data base to be restructured */ dcl im_rel_name char (*); /* (input) name of relation to be restructured */ dcl im_file_model_ptr ptr; /* (output) pointer to the file model . that contains the relation */ call hcs_$initiate (im_db_abs_path, rtrim (im_rel_name) || ".m", "", 0, 0, im_file_model_ptr, rci_code); if im_file_model_ptr = null () then do; call ioa_$rs ("^/The relation ^a does not exist in the data base.", rci_error_message, length (rci_error_message), im_rel_name); goto exit_rmdb_create_index; end; else rci_code = 0; return; end initiate_models; %page; get_relation_data: proc (grd_db_model_ptr, grd_file_model_ptr, grd_rel_name, grd_file_id, grd_rel_ptr, grd_rel_id, grd_number_of_attrs, grd_number_of_varying_attrs, grd_max_data_length); /* This routine extracts information from the rel_info and file_info structures for the relation to be restructured, i.e. the relation with an attribute being indexed. */ /* PARAMETERS */ dcl grd_db_model_ptr ptr; /* (input) pointer to the database model */ dcl grd_file_model_ptr ptr; /* (input) pointer to the file model that contains the relation */ dcl grd_rel_name char (*); /* (input) name of relation to be restructured */ dcl grd_file_id bit (36); /* (output) id of the file as defined in the database model */ dcl grd_rel_ptr ptr; /* (output) pointer to the rel_info structure */ dcl grd_rel_id bit (36); /* (output) id of the relation as defined in rel_info */ dcl grd_number_of_attrs fixed bin; /* (output) number of attributes in the relation */ dcl grd_number_of_varying_attrs fixed bin; /* (output) number of varying attributes in the relation */ dcl grd_max_data_length fixed bin; /* (output) maximum number of bits of data a tuple . may have, if tuple contains varying . data the actual number may be less */ grd_file_id = pointer (grd_db_model_ptr, grd_file_model_ptr -> file_model.fi_ptr) -> file_info.file_id; grd_rel_ptr = pointer (grd_file_model_ptr, grd_file_model_ptr -> rel_ptr); if grd_rel_ptr -> rel_info.name ^= grd_rel_name then do; rci_code = error_table_$action_not_performed; call ioa_$rs ("Data model inconsistant - file ^a contains a relation named ^a", rci_error_message, length (rci_error_message), grd_rel_name, grd_rel_ptr -> rel_info.name); goto exit_rmdb_create_index; end; else do; grd_rel_id = grd_rel_ptr -> rel_info.id; grd_number_of_attrs = grd_rel_ptr -> rel_info.num_attr; grd_number_of_varying_attrs = grd_rel_ptr -> rel_info.nvar_atts; grd_max_data_length = ceil (grd_rel_ptr -> rel_info.max_data_len / 9); end; return; end get_relation_data; %page; get_attribute_data: proc (gad_db_model_ptr, gad_file_model_ptr, gad_rel_ptr, gad_rel_name, gad_attr_name, gad_attr_ptr, gad_attr_desc, gad_attr_defn_order); /* This routine extracts information out of the attribute's attr_info and rel_info structures that have to do with the attr being indexed. It also checks various attributes of the attribute and reports errors if . 1) attribute is already indexed . 2) attribute is the first attribute of the primary key and . hence does not need to be indexed . 3) attribute's domain will allow values > 253 characters . which is the maximum length of an index . 4) relation does not contain the indicated attribute */ /* PARAMETERS */ dcl gad_db_model_ptr ptr; /* (input) pointer to the database model */ dcl gad_file_model_ptr ptr; /* (input) pointer to the file model that contains the relation */ dcl gad_rel_ptr ptr; /* (input) pointer to the rel_info structure */ dcl gad_rel_name char (*); /* (input) name of relation to be restructured */ dcl gad_attr_name char (*); /* (input) name of attribute to be indexed */ dcl gad_attr_ptr ptr; /* (output) pointer to the attr_info structure */ dcl gad_attr_desc bit (36); /* (output) standard multics descriptor . of the attribute to be indexed */ dcl gad_attr_defn_order fixed bin; /* AUTOMATIC */ dcl gad_domain_ptr ptr; /* pointer to attribute's domain info */ dcl gad_found bit (1); /* true if the attribute exists in the relation */ dcl gad_i fixed bin; /* loop index */ gad_attr_ptr = pointer (gad_file_model_ptr, gad_rel_ptr -> rel_info.attr_ptr); gad_found = "0"b; do gad_i = 1 to gad_rel_ptr -> rel_info.num_attr while (^gad_found); if gad_attr_ptr -> attr_info.name = gad_attr_name then do; gad_found = "1"b; if gad_attr_ptr -> attr_info.index_attr then do; rci_code = error_table_$action_not_performed; call ioa_$rs ("^/Attribute ^a in relation ^a is already indexed", rci_error_message, length (rci_error_message), gad_attr_name, gad_rel_name); goto exit_rmdb_create_index; end; if gad_attr_ptr -> attr_info.key_attr & gad_attr_ptr -> attr_info.key_order = 1 then do; rci_code = error_table_$action_not_performed; call ioa_$rs ("^/Attribute ^a in relation ^a is the first attribute of the^/" || "relation's primary key and can already be used as an index", rci_error_message, length (rci_error_message), gad_attr_name, gad_rel_name); goto exit_rmdb_create_index; end; gad_attr_defn_order = gad_attr_ptr -> attr_info.defn_order; gad_domain_ptr = pointer (gad_db_model_ptr, gad_attr_ptr -> attr_info.domain_ptr); gad_attr_desc = gad_domain_ptr -> domain_info.db_desc; if mdbm_util_$mu_data_length (gad_attr_desc) > 2277 /* 253 * 9 */ then do; rci_code = error_table_$action_not_performed; call ioa_$rs ( "^/Attribute ^a has a domain that allows values with lengths " || "^/longer than 253 characters - the maximum allowable index length.", rci_error_message, length (rci_error_message), gad_attr_name); goto exit_rmdb_create_index; end; end; else gad_attr_ptr = pointer (gad_file_model_ptr, gad_attr_ptr -> attr_info.fwd_thread); end; if ^gad_found then do; rci_code = error_table_$action_not_performed; call ioa_$rs ("^/Relation ^a does not contain an attribute named ^a", rci_error_message, length (rci_error_message), gad_rel_name, gad_attr_name); goto exit_rmdb_create_index; end; return; end get_attribute_data; %page; update_model: proc (um_db_model_ptr, um_rel_ptr, um_attr_ptr); /* This procedure updates the model to indicate the new index and to record that restructuring has taken place. The index_id will be set by the relation_manager when it creates the index but the rel_mgr expects the id to be "0"b until it actually sets it. It also sets the max_attr_index_id to 512 so that MR10.1 rmdb will die. This is needed because the max_attr_index_id which is used by MR10.1 rmdb to calculate the new index_id can no longer be guarenteeded to be the maximum index id once MR10.2 rmdb has been used. MR10.1 rmdb had a check that refused to allow the index_id to go above 511 because it was only 8 bits long, setting max_attr_index_id (which is fixed bin) will therefore stop MR10.1 rmdb. */ /* PARAMETERS */ dcl um_db_model_ptr ptr; /* (input) pointer to the database model */ dcl um_rel_ptr ptr; /* (input) pointer to the rel_info structure */ dcl um_attr_ptr ptr; /* (input) pointer to the attr_info structure */ rci_original_rel_info_indexed = um_rel_ptr -> rel_info.indexed; um_rel_ptr -> rel_info.indexed = "1"b; rci_original_rel_info_max_attr_index_id = um_rel_ptr -> rel_info.max_attr_index_id; um_rel_ptr -> rel_info.max_attr_index_id = 512; um_attr_ptr -> attr_info.index_attr = "1"b; um_attr_ptr -> attr_info.index_id = "0"b; call rmdb_add_rmdb_history (um_db_model_ptr, RMDB_REL_TYPE, (um_rel_ptr -> rel_info.name), RMDB_ADD_IDX_OP, (um_attr_ptr -> attr_info.name), rci_error_message, rci_code); if rci_code ^= 0 then do; call clean_up ("0"b, "1"b); goto exit_rmdb_create_index; end; return; end update_model; %page; clean_up: proc (cu_set_code, cu_leave_db_inconsistent); /* This procedure is called both during normal and error termination and in the event that the cleanup condition is signaled. In the event that this procedure is called due to an error we want to be sure that the error code reported to the user is the one that caused the error. There is therefore a local error code in this procedure which is set to the global error code (the one returned to the user) only during normal (non-error, non-cleanup_condition) termination and if an error occurs in this procedure (this could occur during io attachment cleanup). A record of the error is concatinated onto the end of the global error_message so that the caller has some indication of what went wrong. */ /* PARAMETERS */ dcl cu_set_code bit (1); /* (input) true ==> if error occurs during cleanup, global error . code will be set to error */ dcl cu_leave_db_inconsistent bit (1); /* (input) true ==> the dba will not be queried if indexing is . to continue and the message giving directions for . how to make the db consistent will be concatinated . to the returned error message */ /* AUTOMATIC */ dcl cu_code fixed bin (35); /* local error code */ if cu_leave_db_inconsistent then rci_error_message = rtrim (rci_error_message) || "^/The data base is being left in an inconsistant state," || "^/to make the database consistent use the delete_index request" || "^/to delete the partially created index."; if rci_rel_opening_id ^= "0"b then call rmdb_ctl.relmgr_entries.close (rci_rel_opening_id, cu_code); if cu_set_code then do; /* set global error code, if error in cleanup occured */ if cu_code ^= 0 /* if error didn't occur don't change anything */ then do; rci_code = cu_code; if rci_code = 0 /* keep old message if there was another error */ then rci_error_message = "^/The relation could not be closed."; else rci_error_message = rtrim (rci_error_message) || "^/The relation could not be closed."; end; end; else do; if cu_code ^= 0 /* even if code is not reset, let user know error occured */ then rci_error_message = rtrim (rci_error_message) || "^/The relation could not be close."; end; return; end clean_up; end rmdb_create_index;  rmdb_create_relation.pl1 12/09/86 1247.6rew 12/09/86 1234.8 273177 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /****^ 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-05-06 by Thanh Nguyen. (see mrds #136) 2) change(85-12-18,Spitzer), approve(85-12-18,MCR7311), audit(86-09-15,Gilcrease), install(86-10-16,MR12.0-1187): Add code to use the database crossreference file. Update the unreferenced_attribute list in db_model. 3) change(86-11-18,Blair), approve(86-11-18,PBF7311), audit(86-12-05,Dupuis), install(86-12-09,MR12.0-1237): Change to use mrds_data_$relation_blocking_factor when creating new relations. END HISTORY COMMENTS */ rmdb_create_relation: proc (I_rmdb_ctl_ptr, I_rmdb_create_rel_info_ptr, I_called_from_request_level, O_err_msg, O_err_code); /* BEGIN_DESCRIPTION The purpose of this procedure is to provide the internal interface for the restructuring create_relation. It is expected that the validation of the user as a DBA and the quiescing of the database has already been done prior to calling this procedure. If successful it will create the relation data file, create the file_model segment and link the new relation into the data_model. The new relation name and attribute info is provided as input in the rmdb_create_rel_info structure. The relation name can not exist in the database. Only attributes that already exist in the data_model can be used in the relation definition. Temporary space is created and cleaned up in the directory specified by rmdb_create_rel_info.temp_directory_path. This space is used to create the keyed sequential file for attribute name that exists in the db_model. If an error occurs during the creation of the new relation all segments and files created prior to the error will be deleted. END_DESCRIPTION HISTORY: 82-03-23 Originally written by R. Lackey 82-06-25 Roger Lackey : added %include access_mode_values and changed make_seg call to use RW_ACCESS_BIN Also converted undo request to use -brief instead of -force 82-07-01 Roger Lackey : Modified the calls to mu_db_inconsistent to use mdbm_util_$inconsistent_* for binding. 82-09-22 D. Woodka : Modified for DMS conversion to call relation_manager create_relation, create_index, and close. 83-01-11 R. Harvey : Fixed create_index code so that one call is made per index to be created. 83-02-04 Mike Kubicar : Added calls to transaction processing routines. 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-02-22 Harvey: Changed calling sequence to $create_relation for attribute names. 83-02-24 Davids: Modified to set the protected, no_concurrency and no_rollback elements of the file_create_info structure from the transactions_needed, concurrency_on, and rollback_on elements of the db_model structure. 83-05-24 Davids: Added code to change the saved_res_verion so that the saved resultant will not get incorrectly used in an opening. 84-08-22 Pierret: Changed file_create_info structure to use version FILE_CREATE_INFO_VERSION_2 and to set the new file_create_info.ring_brackets (*) to 0, meaning use default value. */ /* PARAMETERS */ dcl I_rmdb_create_rel_info_ptr ptr parameter; /* Pointer to the rmdb_create_rel_info structure */ dcl I_rmdb_ctl_ptr ptr parameter; /* Pointer to the rmdb_ctl_info structure */ dcl I_called_from_request_level bit (1); /* True if rmdb_create_rel was called from the request level, false if from rmdb_create_and_pop_rel */ dcl O_err_msg char (*) parameter;/* Error message text */ dcl O_err_code fixed bin (35) parameter; /* Error code */ %page; /* rmdb_create_relation: proc (I_rmdb_ctl_ptr, I_rmdb_create_rel_info_ptr, I_called_from_request_level, O_err_msg, O_err_code); */ /* Init parameters */ rmdb_create_rel_info_ptr = I_rmdb_create_rel_info_ptr; rmdb_ctl_ptr = I_rmdb_ctl_ptr; called_from_request_level = I_called_from_request_level; O_err_msg = ""; O_err_code = 0; /* Init for cleanup */ temp_file_iocb_ptr = rmdb_ctl.crossref_file_info.iocb_ptr; file_model_ptr, temp_seg_ptr = null; must_delete_relation = "0"b; db_path = rmdb_create_rel_info.db_path; temp_dir_path = rmdb_create_rel_info.temp_directory_path; dbm_ptr = rmdb_create_rel_info.db_model_ptr; if db_model.db_type_flags.transactions_needed & called_from_request_level then do; mstxn_transactions_needed = "1"b; call transaction_manager_$get_current_txn_id (mstxn_txn_id, mstxn_code); if mstxn_code = 0 then do; mstxn_txn_id = "0"b; /* So that we don't try to commit the transaction */ call error (error_table_$action_not_performed, "Relations may not be created while a transaction is " || "in progress. Commit or abort the transaction and try " || "again."); end; end; else mstxn_transactions_needed = "0"b; mstxn_txn_id = "0"b; /* transaction_manager_ doesn't guarantee 0 after previous call */ fm_ptr = null; on cleanup call tidy_up; /* Establish a cleanup handler */ if rmdb_create_rel_info.version ^= RMDB_CREATE_REL_INFO_VERSION_1 then call error (error_table_$unimplemented_version, "For rmdb_create_rel_info.version"); if db_model.num_rels + 1 > mrds_data_$max_relations then /* Can only have so many */ call error (mrds_error_$max_rels, rmdb_create_rel_info.relation_name); %page; /* Validate the relation name supplied */ rel_name = rtrim (rmdb_create_rel_info.relation_name); first_char = substr (rel_name, 1, 1); /* Get first char of rel_name */ if first_char = "_" then call error (mrds_error_$inv_rel_name_first_char, "^/" || rel_name || "^/Relation names cannot begin with an underscore."); if first_char = "-" then call error (mrds_error_$inv_rel_name_first_char, "^/" || rel_name || "^/Relation names cannot begin with a hyphen."); if verify (first_char, "0123456789") = 0 then call error (mrds_error_$inv_rel_name_first_char, "^/" || rel_name || "^/Relation names cannot begin with a numeric."); s = verify (rel_name, mrds_data_$valid_rel_and_attr_name_chars); if s ^= 0 then call error (mrds_error_$bad_rel_name, "^/" || rel_name || "^/First bad character is: " || substr (rel_name, s, 1)); if rel_name = "db_model" then call error (mrds_error_$rst_reserved_name, "^/" || rel_name || "^/The name ""db_model"" is a reserved name for MRDS and cannot be used as a relation name."); call check_supplied_attr_list; /* Internal procedure */ /* See if a relation by this name already exists in db */ call initiate_file_ (db_path, rel_name || ".m", R_ACCESS, fm_ptr, (0), code); if fm_ptr ^= null then do; call terminate_file_ (fm_ptr, 0, TERM_FILE_TERM, (0)); call error (mrds_error_$dup_rel, "^/" || rel_name); end; %page; must_delete_relation = "1"b; /* In case of an error */ /* Changed the version on the saved resultant so it doesn't get used incorrectly and mark database as inconsistent and set undo string. This is done at this point in the procedure because until now, nothing has been added to the db that would need to be removed in case of an error. */ rmdb_ctl_ptr -> rmdb_ctl.saved_res_version_ptr -> based_char8 = "RESTRUCT"; call mdbm_util_$inconsistent_set (dbm_ptr, "create_relation", "Creating relation " || rel_name, "delete_relation " || rtrim (rel_name) || " -brief"); /* Create file_model segment */ call initiate_file_$create (db_path, rel_name || ".m", RW_ACCESS, file_model_ptr, ("0"b), (0), code); if code ^= 0 then call error (code, pathname_ (db_path, (rel_name))); call rmdb_init_file_model (dbm_ptr, file_model_ptr, err_msg, code); /* External proc That inits file_model structure and rel_info structure */ if code ^= 0 then call error (code, err_msg); call build_db_attr_list; /* Internal proc creates a list of all unique attribute names */ /* Find last file_info in db_model so we can link in the new file_info */ do fi_ptr = ptr (dbm_ptr, db_model.file_ptr) repeat ptr (dbm_ptr, file_info.fwd_ptr) while (rel (fi_ptr) ^= NULL_OFFSET); last_fi_ptr = fi_ptr; end; on area begin; /* In case there is not enough room to allocate file_info */ O_err_msg = "Area in model is not large enough to add the relation " || rel_name || "^/Relation will not be added."; O_err_code = error_table_$area_too_small; call tidy_up; goto exit; end; allocate file_info in (dbm_area) set (fi_ptr); /* New file_info */ file_model_ptr -> file_model.fi_ptr = rel(fi_ptr);/* Save the ptr in case we have to back out */ revert area; file_info.file_name = rel_name; file_info.file_id = "000000000000000000000000000000000001"b; file_info.fwd_ptr = NULL_OFFSET; %page; /* Start of critical code that links new relation in to database Errors that occur prior to this will cause the data_file and file_model to be deleted and leave that database consistent. */ quit_intercept_flag = "0"b; on quit quit_intercept_flag = "1"b; /* hold off any QUITs til finished updating db_model */ call add_supplied_attrs; /* Internal proc */ /* Add the relation name to the xref file. */ call mdbm_util_$xref_create_record (temp_file_iocb_ptr, RELATION_KEY_HEAD, rmdb_create_rel_info.relation_name, rel( fi_ptr), err_msg, code); if code ^= 0 then call error (code, err_msg); /* Link new file_info into list */ if db_model.file_ptr = NULL_OFFSET then db_model.file_ptr = rel (fi_ptr); else last_fi_ptr -> file_info.fwd_ptr = rel (fi_ptr); db_model.num_unblk_files = db_model.num_unblk_files + 1; /* Just added new file */ db_model.num_rels = db_model.num_rels + 1; /* Just added new relation */ /* Start a transaction */ on cleanup begin; call tidy_up; call mstxn_cleanup; end; on any_other call mstxn_any_other; %include mrds_start_transaction; if mstxn_code ^= 0 then call error (mstxn_code, "Could not start a transaction, while creating relation " || rtrim (rel_name) || "."); /* Create and init relations data file */ call create_relation_data_file; /* Internal proc */ must_delete_relation = "0"b; /* So tidy_up won't delete it */ /* Add the history entry to the db_model */ call rmdb_add_rmdb_history (dbm_ptr, RMDB_REL_TYPE, (rel_name), RMDB_ADD_REL_OP, "", long_err_msg, code); revert quit; if quit_intercept_flag then signal quit; /* Now signal the quit that was intecepted */ if code ^= 0 then call error (code, long_err_msg);/* Error code from rmdb_add_rmdb_history */ call adjust_bit_count_ ((db_path), rel_name || ".m", "1"b, bcnt, code); if code ^= 0 then call error (code, pathname_ (db_path, rel_name || ".m")); call adjust_bit_count_ ((db_path), "db_model", "1"b, bcnt, code); if code ^= 0 then call error (code, pathname_ (db_path, "db_model")); call tidy_up; /* Release temp file and undo openings and set database as consistent */ exit: mftxn_code = O_err_code; %include mrds_finish_transaction; if mftxn_code ^= 0 then do; O_err_code = mftxn_code; O_err_msg = "Could not commit or abort the transaction, while " || "creating relation " || rtrim (rel_name) || "."; end; return; %page; /* * * * * * * * * * * * * check_supplied_attr_list * * * * * * * * * * */ check_supplied_attr_list: proc; /* Checks attribute names supplied for this relation against themselves for duplication. It also sees if there is a primary key attribute supplied, and check for valid attribute names. */ primary_key_found = "0"b; do x = 1 to rmdb_create_rel_info.num_attrs; if rmdb_create_rel_info.attrs (x).primary_key then primary_key_found = "1"b; do j = x+1 to rmdb_create_rel_info.num_attrs; if x ^= j & /* If not itself */ rmdb_create_rel_info.attrs (x).name = rmdb_create_rel_info.attrs (j).name then call error (mrds_error_$rst_name_duplicate, "^/" || rmdb_create_rel_info.attrs (x).name); end; attr_name = rtrim (rmdb_create_rel_info.attrs (x).name); first_char = substr (attr_name, 1, 1); /* Get first char of attr_name */ if first_char = "_" then call error (mrds_error_$inv_attr_name_first_char, "^/" || attr_name || "^/Attribute names cannot begin with an underscore."); if first_char = "-" then call error (mrds_error_$inv_attr_name_first_char, "^/" || attr_name || "^/Attribute names cannot begin with a hyphen."); if verify (first_char, "0123456789") = 0 then call error (mrds_error_$inv_attr_name_first_char, "^/" || attr_name || "^/Attribute names cannot begin with a numeric."); s = verify (attr_name, mrds_data_$valid_rel_and_attr_name_chars); if s ^= 0 then call error (mrds_error_$bad_attr_name, "^/" || attr_name || "^/First bad character is: " || substr (attr_name, s, 1)); end; if ^primary_key_found then call error (mrds_error_$no_primary_key, rmdb_create_rel_info.relation_name); end check_supplied_attr_list; %page; /* * * * * * * * * * * * build_db_attr_list * * * * * * * * * * * * * * */ build_db_attr_list: proc; /* This internal subroutine calls the database crossreference package to create the crossreference file if it does not already exist. */ if temp_file_iocb_ptr ^= null then return; call mdbm_util_$xref_build (temp_dir_path, db_path, dbm_ptr, rmdb_ctl.crossref_file_info.name, rmdb_ctl.crossref_file_info.iocb_ptr, err_msg, code); if code ^= 0 then call error (code, err_msg); temp_file_iocb_ptr = rmdb_ctl.crossref_file_info.iocb_ptr; return; end build_db_attr_list; %page; /* * * * * * * * * * * add_supplied_attrs * * * * * * * * * * * */ add_supplied_attrs: proc; /* This procedure checks to see if the supplied attributes are defined in the database by looking each name up in the attribute list created by build_db_attr_list. If the attribute is valid the appropiate attr_info is added to the file_model. After all the attributes are processed, we have to adjust alignment for the varying attributes.*/ dcl WORD fixed bin internal static options (constant) init (36); dcl amount_to_pad fixed bin; dcl prev_ua_ptr ptr; dcl this_ua_ptr ptr; crossref_info_record_ptr = addr (record_buffer); do i = 1 to rmdb_create_rel_info.num_attrs; /* Check each attr name */ /* Read the first 8 bytes (2 words) of the crossreferece record. This will contain the domain_info offset and the count of relations this attribute is used in. If the attribute is unreferenced, delete the attr_info in the db_model for this one. */ call mdbm_util_$xref_find_record (temp_file_iocb_ptr, ATTRIBUTE_KEY_HEAD, rmdb_create_rel_info.attrs (i).name, crossref_info_record_ptr, 8, err_msg, code); if code ^= 0 then if code = error_table_$long_record then ; /* ignore this error */ else if code = error_table_$no_record then call error (mrds_error_$undef_attr, "^/" || rmdb_create_rel_info.attrs (i).name); else call error (code, err_msg); di_ptr = ptr (dbm_ptr, crossref_info_record.offset); /* Add the attr_info to the rel_info */ call rmdb_build_attr_info (dbm_ptr, addr (rmdb_create_rel_info.attrs (i)), file_model_ptr, di_ptr, err_msg, code); if code ^= 0 then call error (code, err_msg); /* Add this relation to the attribute crossreference list */ call mdbm_util_$xref_reference (temp_file_iocb_ptr, ATTRIBUTE_KEY_HEAD, rmdb_create_rel_info.attrs (i).name, rmdb_create_rel_info.relation_name, null, 0, err_msg, code); if code ^= 0 then call error (code, err_msg); /* Mark that the domain is used, in case this is a generated attribute for a domain. */ domain_info.unreferenced = "0"b; /* if it was an unreferenced_attribute, delete it from the db_model */ if crossref_info_record.count = 0 then do; prev_ua_ptr, this_ua_ptr = null; do ua_ptr = ptr (dbm_ptr, db_model.unreferenced_attribute_ptr) repeat ptr (dbm_ptr, unreferenced_attribute.fwd_thread) while (rel (ua_ptr) ^= NULL_OFFSET & this_ua_ptr = null); if unreferenced_attribute.name = rmdb_create_rel_info.attrs (i).name then this_ua_ptr = ua_ptr; else prev_ua_ptr = ua_ptr; end; /* do ua_ptr */ /* When we get here, if this_ua_ptr is nonnull, it will point to a matching unreferenced_attribute in the db_model and is the one that we are going to free. prev_ua_ptr will point to the previous one on the list or be null. If it is null, then we are freeing the first one in the list and must set the head of the list in the db_model. Otherwise, we change the offset of the previous unreferenced_attribute fwd_thread to point to the next one in the list. This operation only unchains it from the linked list. */ if this_ua_ptr ^= null then do; if prev_ua_ptr = null then db_model.unreferenced_attribute_ptr = this_ua_ptr -> unreferenced_attribute.fwd_thread; else prev_ua_ptr -> unreferenced_attribute.fwd_thread = this_ua_ptr -> unreferenced_attribute.fwd_thread; free this_ua_ptr -> unreferenced_attribute in (dbm_area); end; end; end; /* do i */ /* Here is where we adjust alignment for varying length attributes. */ ri_ptr = ptr (file_model_ptr, file_model_ptr -> file_model.rel_ptr); if rel_info.nvar_atts = 0 then; else do; if mod (rel_info.var_offset-1, WORD) = 0 then amount_to_pad = 0; else amount_to_pad = WORD - mod (rel_info.var_offset -1, WORD); rel_info.var_offset = rel_info.var_offset + amount_to_pad; rel_info.max_data_len = rel_info.max_data_len + amount_to_pad; end; return; end add_supplied_attrs; %page; /* * * * * * * * * * * * create_relation_data_file * * * * * * * * * */ create_relation_data_file: proc; file_model_name = rel_name || ".m"; call initiate_file_ (db_path, file_model_name, R_ACCESS, fm_ptr, (0), code); if fm_ptr = null then call error (code, " The file model," || rtrim (file_model_name) || "could not be initiated."); ri_ptr = ptr (fm_ptr, file_model.rel_ptr); /* relation info ptr */ /* set up working area */ caller_name = "rmdb_create_relation"; call mdbm_util_$get_temp_segment_path (temp_dir_path, caller_name, temp_seg_ptr, code); if code ^= 0 then call error (code, "getting temp segment."); work_area_ptr = temp_seg_ptr; wa = empty (); /* initialize for calls to relation manager */ tva_number_of_vector_slots = 0; tva_number_of_dimensions = rel_info.num_attr; tva_maximum_dimension_name_length = 32; allocate typed_vector_array in (wa); il_number_of_ids = rel_info.num_attr; allocate id_list in (wa); id_list.number_of_ids = 0; id_list.version = ID_LIST_VERSION_1; typed_vector_array.version = TYPED_VECTOR_ARRAY_VERSION_2; ai_ptr = ptr (fm_ptr, rel_info.attr_ptr); /* get attribute info */ do i = 1 to tva_number_of_dimensions; if attr_info.key_attr then do; /* set up the primary key index */ id_list.number_of_ids = id_list.number_of_ids + 1; id_list.id (id_list.number_of_ids) = attr_info.defn_order; end; di_ptr = ptr (dbm_ptr, attr_info.domain_ptr);/* set up descriptor list for create relation */ typed_vector_array.dimension_table (i).name = attr_info.name; typed_vector_array.dimension_table (i).descriptor_ptr = addr (domain_info.db_desc); ai_ptr = ptr (fm_ptr, attr_info.fwd_thread); end; allocate rel_creation_info in (wa); allocate file_create_info in (wa); /* initialize values for create_relation */ rel_creation_info.version = REL_CREATION_INFO_VERSION_2; rel_creation_info.esm_info_ptr = null; rel_creation_info.cism_info_ptr = null; rel_creation_info.file_create_info_ptr = file_create_info_ptr; file_create_info.version = FILE_CREATE_INFO_VERSION_2; file_create_info.ci_size_in_bytes = 4096; file_create_info.blocking_factor = mrds_data_$relation_blocking_factor; file_create_info.flags.protected = db_model.db_type_flags.transactions_needed; file_create_info.flags.no_concurrency = ^db_model.db_type_flags.concurrency_on; file_create_info.flags.no_rollback = ^db_model.db_type_flags.rollback_on; file_create_info.flags.mbz_1 = "0"b; file_create_info.ring_brackets (*) = 0; file_create_info.mbz_2 = 0; file_create_info.mbz_3 = "0"b; /* initialize values for create_index */ style = 1; relation_index_flags_ptr = addr (flag_list); relation_index_flags.relation_must_be_empty = "0"b; relation_index_flags.index_is_clustering = "0"b; relation_index_flags.index_is_unique = "1"b; /* for primary key */ create_rel_name = rtrim (rel_name); call rmdb_ctl.relmgr_entries.create_relation (db_path, create_rel_name, rel_creation_info_ptr, typed_vector_array_ptr, rel_opening_id, rel_info.id, code); if code ^= 0 then call error (code, "While creating relation " || rel_name); /* create the primary index for the relation */ call rmdb_ctl.relmgr_entries.create_index (rel_opening_id, id_list_ptr, flag_list, style, rel_info.primary_key_index_id, code); if code ^= 0 then call error (code, "while creating the primary index for" || rel_name); /* create the secondary indexes for the relation */ relation_index_flags.index_is_unique = "0"b; /* index need not be unique for secondary index */ id_list.number_of_ids = 1; /* secondary indices involve only one attribute */ ai_ptr = ptr (fm_ptr, rel_info.attr_ptr); do i = 1 to rel_info.num_attr; if attr_info.index_attr then do; id_list.id (1) = attr_info.defn_order; call rmdb_ctl.relmgr_entries.create_index (rel_opening_id, id_list_ptr, flag_list, style, attr_info.index_id, code); if code ^= 0 then call error (code, " while creating secondary indices for " || rel_name); end; ai_ptr = ptr (fm_ptr, attr_info.fwd_thread); end; call rmdb_ctl.relmgr_entries.close (rel_opening_id, code); if code ^= 0 then call error (code, " while closing the relation " || rel_name); end create_relation_data_file; %page; /* * * * * * * * * * * * * * * error * * * * * * * * * * * * * * */ error: proc (err_code, err_message); /* Error procedure for rmdb_create_relation.pl1 */ dcl err_code fixed bin (35); dcl err_message char (*); O_err_code = err_code; O_err_msg = err_message; call tidy_up; goto exit; end error; /* * * * * * * * * * * * * * * * tidy_up * * * * * * * * * * * * * * * */ tidy_up: proc; if must_delete_relation then do; /* Unlink relation from db_model and delete file_model and relation_data_file */ delete_rel_info.version = RMDB_DELETE_REL_INFO_VERSION_1; delete_rel_info.absolute_db_path = db_path; delete_rel_info.db_model_ptr = rmdb_create_rel_info.db_model_ptr; delete_rel_info.relation_name = rel_name; delete_rel_info.brief = "1"b; delete_rel_info.mbz = "0"b; call rmdb_delete_relation$cleanup (rmdb_ctl_ptr, addr (delete_rel_info), err_msg, code); fm_ptr = null; call mdbm_util_$xref_destroy (rmdb_ctl.crossref_file_info.iocb_ptr, rmdb_ctl.temp_dir_path, rmdb_ctl.crossref_file_info.name, (""), (0)); end; if code = 0 then call mdbm_util_$inconsistent_reset (dbm_ptr); /* Make db consistent */ if temp_seg_ptr ^= null then call mdbm_util_$free_temp_segment (caller_name, temp_seg_ptr, (0)); if fm_ptr ^= null then call terminate_file_ (fm_ptr, 0, TERM_FILE_TERM, (0)); end tidy_up; %page; /*********** * * These routines are used by the transaction processing include files. * Restore_significant_data is called to reinitialize variables in case * of a rollback. In this module, restore data must add a history section * note that the relation created has been deleted. This is just a * stopgap measure until add history is smart enough to be able to delete * history entries. Should_rollback determines whether a transaction should * be rolled back or aborted on error. Currently, it is always aborted. * **********/ restore_significant_data: proc; dcl add_history_code fixed bin (35); dcl add_history_err_msg char (500); call rmdb_add_rmdb_history (dbm_ptr, RMDB_REL_TYPE, (rel_name), RMDB_DEL_REL_OP, "", add_history_err_msg, add_history_code); must_delete_relation = "1"b; end restore_significant_data; should_rollback: proc returns (bit (1)); return ("0"b); end should_rollback; %page; dcl addr builtin; dcl adjust_bit_count_ entry (char (168) aligned, char (32) aligned, bit (1) aligned, fixed bin (35), fixed bin (35)); dcl any_other condition; dcl area condition; dcl attr_name char (32) varying; dcl based_char8 char (8) based; dcl bcnt fixed bin (35); dcl called_from_request_level bit (1); dcl caller_name char (20); dcl cleanup condition; dcl create_rel_name char (32); dcl code fixed bin (35); dcl db_path char (168); dcl empty builtin; dcl error_table_$action_not_performed fixed bin (35) ext static; dcl error_table_$area_too_small fixed bin (35) ext static; dcl error_table_$long_record fixed bin(35) ext static; dcl error_table_$no_record fixed bin (35) ext static; dcl error_table_$unimplemented_version fixed bin (35) ext static; dcl err_msg char (256); dcl file_model_name char (32); dcl file_model_ptr ptr; dcl first_char char (1); dcl fixed builtin; dcl flag_list bit (36) aligned; dcl mdbm_util_$get_temp_segment_path entry (char (*), char (*), ptr, fixed bin (35)); dcl mdbm_util_$xref_create_record entry (ptr, char (*), char (*), bit (18), char (*), fixed bin (35)); dcl mdbm_util_$xref_destroy entry (ptr, char (*), char (*), char (*), fixed bin (35)); dcl initiate_file_ entry (char(*), char(*), bit(*), ptr, fixed bin(24), fixed bin(35)); dcl initiate_file_$create entry (char(*), char(*), bit(*), ptr, bit(1) aligned, fixed bin(24), fixed bin(35)); dcl i fixed bin; dcl j fixed bin; dcl last_fi_ptr ptr; dcl long_err_msg char (500); dcl mrds_data_$max_relations ext fixed bin (35); dcl mrds_data_$relation_blocking_factor fixed bin (17) external static; dcl mrds_data_$valid_rel_and_attr_name_chars char (128) varying ext; dcl mrds_error_$bad_attr_name fixed bin (35) ext static; dcl mrds_error_$bad_rel_name fixed bin (35) ext static; dcl mrds_error_$dup_rel fixed bin (35) ext static; dcl mrds_error_$inv_attr_name_first_char fixed bin (35) ext static; dcl mrds_error_$inv_rel_name_first_char fixed bin (35) ext static; dcl mrds_error_$max_rels fixed bin (35) ext static; dcl mrds_error_$no_primary_key fixed bin (35) ext static; dcl mrds_error_$rst_name_duplicate fixed bin (35) ext static; dcl mrds_error_$rst_reserved_name fixed bin (35) ext static; dcl mrds_error_$undef_attr fixed bin (35) ext static; dcl must_delete_relation bit (1); dcl mdbm_util_$free_temp_segment entry (char(*), ptr, fixed bin(35)); dcl mdbm_util_$inconsistent_reset entry (ptr); dcl mdbm_util_$inconsistent_set entry (ptr, char (*), char (*), char (*)); dcl mdbm_util_$xref_build entry (char(*), char(*), ptr, char(*), ptr, char(*), fixed bin(35)); dcl mdbm_util_$xref_find_record entry (ptr, char(*), char(*), ptr, fixed bin(21), char(*), fixed bin(35)); dcl mdbm_util_$xref_reference entry (ptr, char(*), char(*), char(*), ptr, fixed bin(21), char(*), fixed bin(35)); dcl mod builtin; dcl null builtin; dcl NULL_OFFSET int static bit (18) unal init ((18)"1"b) options (constant); dcl pathname_ entry (char(*), char(*)) returns(char(168)); dcl primary_key_found bit (1); dcl ptr builtin; dcl quit condition; dcl quit_intercept_flag bit (1); dcl record_buffer (2) fixed bin (35); dcl rel builtin; dcl rel_opening_id bit (36) aligned; dcl rel_name char (32) varying; dcl rmdb_add_rmdb_history entry (ptr, fixed bin, char (32), fixed bin, char (32), char (500), fixed bin (35)); dcl rmdb_build_attr_info entry (ptr, ptr, ptr, ptr, char (*), fixed bin (35)); dcl rmdb_delete_relation$cleanup entry (ptr, ptr, char (*), fixed bin (35)); dcl rmdb_init_file_model entry (ptr, ptr, char (*), fixed bin (35)); dcl rtrim builtin; dcl s fixed bin; dcl style fixed bin (17); dcl substr builtin; dcl sys_info$max_seg_size fixed bin (35) ext static; dcl temp_dir_path char (168); dcl temp_file_iocb_ptr ptr; dcl temp_seg_ptr ptr; dcl terminate_file_ entry (ptr, fixed bin(24), bit(*), fixed bin(35)); dcl verify builtin; dcl wa area (sys_info$max_seg_size) based (work_area_ptr); dcl work_area_ptr ptr; dcl x fixed bin; dcl 1 delete_rel_info aligned like rmdb_delete_rel_info; %page; %include access_mode_values; %page; %include dm_file_create_info; %page; %include dm_id_list; %page; %include dm_rel_creation_info; %page; %include dm_relation_index_flags; %page; %include mdbm_db_model; %page; %include mdbm_file_model; %page; %include mdbm_rs_info; %page; %include mrds_rmdb_ctl; %page; %include rmdb_create_rel_info; %page; %include rmdb_crossref_info; %page; %include rmdb_delete_rel_info; %page; %include rmdb_history_entry; %page; %include terminate_file; %page; %include vu_typed_vector_array; end rmdb_create_relation;  rmdb_delete_all.pl1 12/07/87 1328.9rew 12/07/87 1320.2 119718 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1986 * * * *********************************************************** */ /* format: ^inddcls,^indattr,indnoniterend,^indnoniterdo,indend,tree,^case,insnl,comcol61,dclind5,declareind5,delnl */ /*DESCRIPTION This set of entry points deletes either all the 1) domains, 2) attribute, or 3) relations, depending on which entry point it is entered at. */ /****^ HISTORY COMMENTS: 1) change(85-12-03,Spitzer), approve(85-12-03,MCR7311), audit(86-09-15,Gilcrease), install(86-10-16,MR12.0-1187): written 2) change(87-11-03,Blair), approve(87-11-03,MCR7792), audit(87-11-30,Dupuis), install(87-12-07,MR12.2-1008): Initialize mstxn_txn_id to 0 before establishing the cleanup handler so that we don't get caught trying to abort a txn based on some bogus value. END HISTORY COMMENTS */ rmdb_delete_all: proc; return; /* not an entry point */ /*DESCRIPTION This entry point deletes all defined domains. This implies all existing attributes and relations must be deleted. For speed, we don't update the crossreference file (if it even exists) as we are doing the task, but delete it as everything in it becomes invalid. */ rmdb_delete_all$domains: entry (Irmdb_ctl_ptr, Oerror_message, Ocode); entry_point = DOMAINS; goto COMMON; rmdb_delete_all$attributes: entry (Irmdb_ctl_ptr, Oerror_message, Ocode); entry_point = ATTRIBUTES; goto COMMON; rmdb_delete_all$relations: entry (Irmdb_ctl_ptr, Oerror_message, Ocode); entry_point = RELATIONS; goto COMMON; COMMON: rmdb_ctl_ptr = Irmdb_ctl_ptr; dbm_ptr = rmdb_ctl.db_model_ptr; call transaction_in_progress; mstxn_txn_id = "0"b; quit_occurred = "0"b; /* BEGIN CRITICAL CODE */ on quit quit_occurred = "1"b; /* Invalidate the resultant. */ rmdb_ctl.saved_res_version_ptr -> based_char8 = "RESTRUCT"; call mdbm_util_$xref_destroy (rmdb_ctl.crossref_file_info.iocb_ptr, rmdb_ctl.temp_dir_path, rmdb_ctl.crossref_file_info.name, (""), (0)); temp_ptr = null; on cleanup begin; call mstxn_cleanup; call cleaner; end; on any_other call mstxn_any_other; if mstxn_transactions_needed then do; %include mrds_start_transaction; if mstxn_code ^= 0 then call error (mstxn_code, "Could not start a transaction."); end; if entry_point = DOMAINS then call delete_domains; /* Note that we don't have to expressly delete all the attributes if we entered through the $attributes entry point. This is because all mention of referenced attributes is in the model files, and we will later delete the unreferenced attributes. */ call delete_relations; if mstxn_transactions_needed then do; mftxn_code = 0; %include mrds_finish_transaction; end; if (entry_point = DOMAINS) | (entry_point = ATTRIBUTES) then call delete_unreferenced_attributes; if entry_point = DOMAINS then call rmdb_add_rmdb_history (dbm_ptr, RMDB_DOMAIN_TYPE, "-all", RMDB_DEL_DMN_OP, "", error_message, (0)); else if entry_point = ATTRIBUTES then call rmdb_add_rmdb_history (dbm_ptr, RMDB_ATTR_TYPE, "-all", RMDB_DEL_ATTR_OP, "", error_message, (0)); else call rmdb_add_rmdb_history (dbm_ptr, RMDB_REL_TYPE, "-all", RMDB_DEL_REL_OP, "", error_message, (0)); call mdbm_util_$inconsistent_reset (dbm_ptr); revert quit; /* END CRITICAL CODE */ if quit_occurred then signal quit; call error (0, ""); %page; delete_relations: proc; dcl last_unreferenced_attribute_ptr ptr; dcl model_name char (32); dcl relation_name char (32); local_iocb = rmdb_ctl.crossref_file_info.iocb_ptr; if entry_point = RELATIONS then do; call mdbm_util_$get_temp_segment_path (rmdb_ctl.temp_dir_path, myname, temp_ptr, code); if code ^= 0 then call error (code, "Unable to get a temp segment."); attribute_list_ptr = temp_ptr; attribute_list.count = 0; /* Find the last unreferenced_attribute structure so we can add on the end. */ last_unreferenced_attribute_ptr = null; do ua_ptr = ptr (dbm_ptr, db_model.unreferenced_attribute_ptr) repeat ptr (dbm_ptr, unreferenced_attribute.fwd_thread) while (rel (ua_ptr) ^= NULL_OFFSET); last_unreferenced_attribute_ptr = ua_ptr; end; /* do ua_ptr */ end; /* Process all the relations. */ do fi_ptr = ptr (dbm_ptr, db_model.file_ptr) repeat ptr (dbm_ptr, db_model.file_ptr) while (rel (fi_ptr) ^= NULL_OFFSET); relation_name = file_info.file_name; model_name = rtrim (relation_name) || ".m"; /* If we are deleting all the relations, we must make all attributes be unreferenced. */ if entry_point = RELATIONS then do; /* Initiate the file_model segment so we can get to the list of attributes used within this relation. We don't need to terminate the file_model as we are shortly going to delete it. */ call initiate_file_ (rmdb_ctl.absolute_db_path, model_name, R_ACCESS, fm_ptr, (0), code); if fm_ptr ^= null then do; /* Process all the attributes in this relation. */ ri_ptr = ptr (dbm_ptr, rel_ptr); do ai_ptr = ptr (fm_ptr, rel_info.attr_ptr) repeat ptr (fm_ptr, attr_info.fwd_thread) while (rel (ai_ptr) ^= NULL_OFFSET); call make_attribute_unreferenced; end; /* do ai_ptr */ end; /* initiated the file_model */ end; /* Delete the file_model segment and the relation file. */ call delete_$path (rmdb_ctl.absolute_db_path, model_name, "101111"b, myname, (0)); call rmdb_ctl.relmgr_entries.delete_relation (rmdb_ctl.absolute_db_path, relation_name, (0)); db_model.file_ptr = file_info.fwd_ptr; call free (dbm_ptr, rel (fi_ptr)); end; /* do fi_ptr */ /* If we are deleting all the attributes, we must make all domains be unreferenced. */ if entry_point = ATTRIBUTES then do di_ptr = ptr (dbm_ptr, db_model.domain_ptr) repeat ptr (dbm_ptr, domain_info.fwd_thread) while (rel (di_ptr) ^= NULL_OFFSET); domain_info.unreferenced = "1"b; end; /* do di_ptr */ /* Mark in the db_model that there aren't any type of files or relations left. */ db_model.num_blk_files, db_model.num_unblk_files, db_model.num_rels = 0; return; make_attribute_unreferenced: proc; dcl position fixed bin; dcl search_name char (33); search_name = OBJECT_HEAD || attr_info.name; position = index (attribute_list_names, search_name); if position = 0 then do; /* not in list yet */ attribute_list.count = attribute_list.count + 1; attribute_list.name (attribute_list.count) = search_name; allocate unreferenced_attribute in (dbm_area) set (ua_ptr); unreferenced_attribute.name = attr_info.name; unreferenced_attribute.domain_ptr = attr_info.domain_ptr; unreferenced_attribute.fwd_thread = NULL_OFFSET; unreferenced_attribute.unused (*) = NULL_OFFSET; if last_unreferenced_attribute_ptr = null then db_model.unreferenced_attribute_ptr = rel (ua_ptr); else last_unreferenced_attribute_ptr -> unreferenced_attribute.fwd_thread = rel (ua_ptr); last_unreferenced_attribute_ptr = ua_ptr; end; return; end make_attribute_unreferenced; end delete_relations; %page; delete_domains: proc; do di_ptr = ptr (dbm_ptr, db_model.domain_ptr) repeat ptr (dbm_ptr, db_model.domain_ptr) while (rel (di_ptr) ^= NULL_OFFSET); db_model.domain_ptr = domain_info.fwd_thread; call free (dbm_ptr, domain_info.check_path_ptr); call free (dbm_ptr, domain_info.ck_stack_ptr); call free (dbm_ptr, domain_info.encd_path_ptr); call free (dbm_ptr, domain_info.decd_path_ptr); call free (dbm_ptr, domain_info.str_before_path_ptr); call free (dbm_ptr, domain_info.str_err_path_ptr); call free (dbm_ptr, domain_info.str_after_path_ptr); call free (dbm_ptr, domain_info.get_before_path_ptr); call free (dbm_ptr, domain_info.get_err_path_ptr); call free (dbm_ptr, domain_info.get_after_path_ptr); call free (dbm_ptr, domain_info.mod_before_path_ptr); call free (dbm_ptr, domain_info.mod_err_path_ptr); call free (dbm_ptr, domain_info.mod_after_path_ptr); call free (dbm_ptr, rel (di_ptr)); end; /* do while */ db_model.num_domains = 0; return; end delete_domains; %page; delete_unreferenced_attributes: proc; do ua_ptr = ptr (dbm_ptr, db_model.unreferenced_attribute_ptr) repeat ptr (dbm_ptr, db_model.unreferenced_attribute_ptr) while (rel (ua_ptr) ^= NULL_OFFSET); db_model.unreferenced_attribute_ptr = unreferenced_attribute.fwd_thread; call free (dbm_ptr, rel (ua_ptr)); end; /* do while */ return; end delete_unreferenced_attributes; %page; transaction_in_progress: proc; if db_model.db_type_flags.transactions_needed then do; mstxn_transactions_needed = "1"b; call transaction_manager_$get_current_txn_id (mstxn_txn_id, mstxn_code); if mstxn_code = 0 then do; mstxn_txn_id = "0"b; call error (error_table_$action_not_performed, rtrim (ENTRY_POINT_NAMES (entry_point)) || " may not be deleted while a transaction is in progress. Commit or abort the transaction and try again."); end; end; else mstxn_transactions_needed = "0"b; if entry_point = DOMAINS then call mdbm_util_$inconsistent_set (dbm_ptr, "delete_domain", "Deleting all domains.", "delete_domain -all -brief"); else if entry_point = ATTRIBUTES then call mdbm_util_$inconsistent_set (dbm_ptr, "delete_attribute", "Deleting all attributes.", "delete_attribute -all -brief"); else call mdbm_util_$inconsistent_set (dbm_ptr, "delete_relation", "Deleting all relations.", "delete_relation -all -brief"); return; end transaction_in_progress; %page; free: proc (base_ptr, offset); dcl base_ptr ptr parameter; /* base of segment */ dcl based_variable fixed bin (35) based; /* used just to free structures */ dcl freeing_ptr ptr; /* -> structure to free */ dcl offset bit (18) unaligned parameter; /* offset to base_ptr of structure */ if offset ^= NULL_OFFSET then do; freeing_ptr = ptr (base_ptr, offset); free freeing_ptr -> based_variable; offset = NULL_OFFSET; end; return; end free; %page; /*DESCRIPTION Error handler and cleanup handler. This is the only way to exit these subroutines. */ error: proc (code, msg); dcl code fixed bin (35) parameter; dcl msg char (*) parameter; Ocode = code; Oerror_message = msg; goto RETURN_TO_CALLER; end error; RETURN_TO_CALLER: call cleaner; return; cleaner: proc; if temp_ptr ^= null then call mdbm_util_$free_temp_segment (myname, temp_ptr, (0)); return; end cleaner; restore_significant_data: proc; return; end restore_significant_data; should_rollback: proc returns (bit (1) aligned); return ("0"b); end should_rollback; %page; %include access_mode_values; %include mrds_rmdb_ctl; %include mdbm_db_model; %include mdbm_file_model; %include rmdb_crossref_info; %include rmdb_history_entry; %page; dcl addr builtin; dcl any_other condition; dcl ATTRIBUTES fixed bin int static options (constant) init (2); dcl based_char8 char (8) based; dcl cleanup condition; dcl code fixed bin (35); dcl delete_$path entry (char (*), char (*), bit (36) aligned, char (*), fixed bin (35)); dcl DOMAINS fixed bin int static options (constant) init (1); dcl entry_point fixed bin; dcl ENTRY_POINT_NAMES (3) char (32) int static options (constant) init ("Domains", "Attributes", "Relations"); dcl error_message char (500); dcl error_table_$action_not_performed fixed bin (35) ext static; dcl fixed builtin; dcl index builtin; dcl initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35)); dcl Irmdb_ctl_ptr ptr parameter; dcl local_iocb ptr; dcl mdbm_util_$free_temp_segment entry (char (*), ptr, fixed bin (35)); dcl mdbm_util_$get_temp_segment_path entry (char (*), char (*), ptr, fixed bin (35)); dcl mdbm_util_$inconsistent_reset entry (ptr); dcl mdbm_util_$inconsistent_set entry (ptr, char (*), char (*), char (*)); dcl mdbm_util_$xref_destroy entry (ptr, char(*), char(*), char(*), fixed bin(35)); dcl myname char (32) int static options (constant) init ("rmdb_delete_all"); dcl null builtin; dcl NULL_OFFSET bit (18) unaligned int static options (constant) init ((18)"1"b); dcl Ocode fixed bin (35) parameter; dcl Oerror_message char (*) parameter; dcl ptr builtin; dcl quit condition; dcl quit_occurred bit (1) aligned; dcl rel builtin; dcl RELATIONS fixed bin int static options (constant) init (3); dcl rmdb_add_rmdb_history entry (ptr, fixed bin, char(32), fixed bin, char(32), char(500), fixed bin(35)); dcl rtrim builtin; dcl sys_info$max_seg_size fixed bin (35) ext static; dcl temp_ptr ptr; end rmdb_delete_all;  rmdb_delete_attribute.pl1 12/07/87 1328.9rew 12/07/87 1321.2 304515 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1985 * * * *********************************************************** */ /* format: ^inddcls,^indattr,indnoniterend,^indnoniterdo,indend,tree,^case,insnl,comcol61,dclind5,declareind5,delnl */ /*DESCRIPTION This subroutine deletes one or more attributes from a MRDS database. Each of the attributes is examined, and a list of relations to be operated upon is created. This is so that if more than one referenced attribute is being deleted, each relation is only reformatted once. If an attribute is unreferenced, it is simply removed from the db_model linked list. If it is referenced, the relations that contain those attribute must be reformatted. */ /****^ HISTORY COMMENTS: 1) change(85-02-07,Spitzer), approve(85-02-07,MCR7311), audit(86-09-15,Gilcrease), install(86-10-16,MR12.0-1187): written 2) change(86-10-30,Blair), approve(86-10-30,PBF7311), audit(86-12-05,Dupuis), install(86-12-09,MR12.0-1237): Re-arrange the quit handler so that we only hold quits while we're cleaning up the model, switching relation names and updating the xref and history files. No need elsewhere because once the model is marked inconsistent the salvager will roll back the relations and model if anything goes wrong. 3) change(87-09-30,Blair), approve(87-11-03,MCR7792), audit(87-11-30,Dupuis), install(87-12-07,MR12.2-1008): Set the undo_request variable to null so that if a problem occurs during execution of this request we will not loop endlessly trying to execute the request and roll the database back. Set mstxn-txn_id to zero so we don't get caught if we have a vfile_ database, but we try to abort a txn during cleanup based on some residue value in the field, END HISTORY COMMENTS */ rmdb_delete_attribute: proc (Irmdb_ctl_ptr, Idelete_object_info_ptr, Oerror_message, Ocode); rmdb_ctl_ptr = Irmdb_ctl_ptr; delete_object_info_ptr = Idelete_object_info_ptr; user_area_ptr = null; if delete_object_info.version ^= delete_object_info_version_1 then call error (error_table_$unimplemented_version, "Version " || delete_object_info.version || " for delete_object_info structure."); db_path = rmdb_ctl.absolute_db_path; /* Create the xref file if not already created. */ if rmdb_ctl.crossref_file_info.iocb_ptr = null then do; call mdbm_util_$xref_build (rmdb_ctl.temp_dir_path, db_path, rmdb_ctl.db_model_ptr, rmdb_ctl.crossref_file_info.name, rmdb_ctl.crossref_file_info.iocb_ptr, error_message, code); if code ^= 0 then call error (code, error_message); end; local_iocb = rmdb_ctl.crossref_file_info.iocb_ptr; mstxn_txn_id = "0"b; on cleanup begin; call mdbm_util_$xref_destroy (rmdb_ctl.crossref_file_info.iocb_ptr, rmdb_ctl.temp_dir_path, rmdb_ctl.crossref_file_info.name, (""), (0)); call cleaner; end; dbm_ptr = rmdb_ctl.db_model_ptr; if delete_object_info.all then call rmdb_delete_all$attributes (rmdb_ctl_ptr, error_message, code); else do; /* Create a non-freeing, non-zeroing extensible area to allocate structures in. When we return and finish using these structures, we will simply throw away the area. */ call mdbm_util_$get_temp_segment_path (rmdb_ctl.temp_dir_path, myname, user_area_ptr, code); if code ^= 0 then call error (code, "Unable to get a temp segment in the temp dir."); unspec (ai) = "0"b; ai.version = area_info_version_1; ai.extend = "1"b; ai.dont_free = "1"b; ai.no_freeing = "1"b; ai.owner = myname; ai.size = sys_info$max_seg_size; ai.areap = user_area_ptr; call define_area_ (addr (ai), code); if code ^= 0 then call error (code, "Defining a user area."); domain_list_ptr, attribute_list_ptr, relation_list_ptr = null; if delete_object_info.unreferenced then call make_unreferenced_attribute_list; else do; call rmdb_relations_used$attributes (rmdb_ctl_ptr, delete_object_info_ptr, user_area_ptr, domain_list_ptr, attribute_list_ptr, relation_list_ptr, error_message, code); if code ^= 0 then call error (code, error_message); call check_for_deletion_of_generated_attributes; if ^delete_object_info.force then do; unspec (query_info) = "0"b; query_info.version = query_info_version_6; query_info.yes_or_no_sw = "1"b; query_info.suppress_name_sw = "1"b; query_info.question_iocbp = delete_object_info.check_iocb_ptr; query_info.answer_iocbp = delete_object_info.query_iocb_ptr; query_info.explanation_ptr = addr (QUERY_MSG); query_info.explanation_len = length (rtrim (QUERY_MSG)); end; call print_information; if (delete_object_info.long = UNSPEC & delete_object_info.check) then do; code = 0; call error (code, error_message); end; end; call check_for_deletion_of_primary_key; make_consistent_msg = ""; /* if anything goes wrong we can't retry */ call mdbm_util_$inconsistent_set (dbm_ptr, "delete_attribute", "Deleting attributes", rtrim (make_consistent_msg)); /* Invalidate the resultant. */ if ^delete_object_info.unreferenced then do; rmdb_ctl.saved_res_version_ptr -> based_char8 = "RESTRUCT"; last_unreferenced_attribute_ptr = null; relation_good_count, save_code = 0; do relation_index = 1 to relation_list.count; relation_ptr = relation_list.relation_ptr (relation_index); relation_good_count = relation_good_count + 1; call process_single_relation; if code ^= 0 then do; save_code = code; goto cleanup_directory; end; /* do relation_index */ end; /* If we get here, we have copied all the relations, so now we need to clean up by deleting the copies of the file model and the old relations. */ cleanup_directory: /* The real work starts here - hold quits till we're done */ quit_occurred = "0"b; /* BEGIN CRITICAL CODE */ on quit quit_occurred = "1"b; do relation_index = 1 to relation_good_count; relation_ptr = relation_list.relation_ptr (relation_index); fm_ptr = relation.file_model_ptr; call transaction_in_progress; if mstxn_transactions_needed then do; on cleanup begin; call mstxn_cleanup; call cleaner; end; on any_other call mstxn_any_other; %include mrds_start_transaction; if mstxn_code ^= 0 then call error (mstxn_code, "Could not start a transaction."); end; call switch_names; if mstxn_transactions_needed then do; mftxn_code = 0; %include mrds_finish_transaction; end; end; end; /* do relation_index */ if save_code ^= 0 then do; call mdbm_util_$xref_destroy (rmdb_ctl.crossref_file_info.iocb_ptr, rmdb_ctl.temp_dir_path, rmdb_ctl.crossref_file_info.name, (""), (0)); call error (save_code, error_message); end; /* Unlink the unreferenced_attribute structure in the db_model if any of the attributes being deleted are unreferenced. */ call delete_unreferenced_attribute_list; call mdbm_util_$inconsistent_reset (dbm_ptr); call process_xref_records; revert quit; /* END CRITICAL CODE */ if quit_occurred then signal quit; code = 0; end; call error (code, error_message); %page; /*DESCRIPTION Error handler and cleanup handler. This is the only way to exit these subroutines. */ error: proc (code, msg); dcl code fixed bin (35) parameter; dcl msg char (*) parameter; Ocode = code; if code = 0 then Oerror_message = ""; else Oerror_message = msg; goto RETURN_TO_CALLER; end error; RETURN_TO_CALLER: call cleaner; return; cleaner: proc; if user_area_ptr ^= null then do; call release_area_ (user_area_ptr); call mdbm_util_$free_temp_segment (myname, user_area_ptr, (0)); end; if mstxn_txn_id ^= "0"b then do; call transaction_manager_$abort_txn (mstxn_txn_id, code); if code ^= 0 then call transaction_manager_$abandon_txn (mstxn_txn_id, (0)); end; return; end cleaner; restore_significant_data: proc; return; end restore_significant_data; should_rollback: proc returns (bit (1) aligned); return ("0"b); end should_rollback; %page; make_name: proc (input_name) returns (char (33)); dcl input_name char (*) parameter; return (OBJECT_HEAD || input_name); end make_name; unmake_name: proc (input_name) returns (char (32)); dcl input_name char (*) parameter; return (substr (input_name, 2, 32)); end unmake_name; /*DESCRIPTION This subroutine ensures that no transaction is in progress, and sets a flag bit for use later. */ transaction_in_progress: proc; if db_model.db_type_flags.transactions_needed then do; mstxn_transactions_needed = "1"b; call transaction_manager_$get_current_txn_id (mstxn_txn_id, mstxn_code); if mstxn_code = 0 then do; mstxn_txn_id = "0"b; call error (error_table_$action_not_performed, "A transaction is in progress. Commit or abort the transaction and try the operation again."); end; end; else mstxn_transactions_needed = "0"b; return; end transaction_in_progress; %page; /*DESCRIPTION This subroutine checks all attributes in the attribute_list structure to ensure that none of the requested attributes are generated attributes (attributes that don't really exist, but are present because for each domain there is a generated attribute with the same name). These cannot be deleted. */ check_for_deletion_of_generated_attributes: proc; do attribute_list_idx = 1 to attribute_list.count; di_ptr = ptr (dbm_ptr, attribute_list.domain_info_ptr (attribute_list_idx)); if domain_info.name = unmake_name (attribute_list.name (attribute_list_idx)) then if delete_object_info.inhibit_errors then attribute_list.name (attribute_list_idx) = ""; else call error (error_table_$unsupported_operation, "Attempt to delete a generated attribute " || domain_info.name); end; /* do attribute_list_idx */ return; end check_for_deletion_of_generated_attributes; %page; check_for_deletion_of_primary_key: proc; dcl attr_idx fixed bin; dcl deletion_attributes char (500); dcl no_primary_key bit (1) aligned; /* Check to make sure that we wouldn't be getting rid of a primary key. */ deletion_attributes = ""; no_primary_key = "1"b; do attribute_list_idx = 1 to attribute_list.count; attribute_ptr = attribute_list.attribute_ptr (attribute_list_idx); if attribute_ptr ^= null then do attr_idx = 1 to attribute.count; relation_ptr = relation_list.relation_ptr (attribute.relation_idx (attr_idx)); do attribute_idx = 1 to relation.attribute_count; if relation.attribute(attribute_idx).flags.part_of_key & relation.attribute_names (attribute_idx) = attribute_list.name (attribute_list_idx) then do; no_primary_key = "0"b; relation.attribute(attribute_idx).flags.to_be_deleted = "1"b; end; end; end; end; if ^no_primary_key then do relation_index = 1 to relation_list.count while (^no_primary_key); relation_ptr = relation_list.relation_ptr(relation_index); do attribute_idx = 1 to relation.attribute_count while (^no_primary_key); if relation.attribute(attribute_idx).flags.part_of_key then if ^relation.attribute(attribute_idx).flags.to_be_deleted then no_primary_key = "1"b; else do; attribute_name = unmake_name (relation.attribute_names (attribute_idx)); relation.attribute(attribute_idx).flags.to_be_deleted = "0"b; deletion_attributes = rtrim(deletion_attributes) || " " || rtrim(attribute_name); end; end; if ^no_primary_key then do; code = mrds_error_$no_primary_key; call error (code, "Deletion of the attribute(s) " || rtrim(deletion_attributes) || " would result in no primary key in relation " || rtrim(relation.name) || "."); end; end; end check_for_deletion_of_primary_key; %page; /*DESCRIPTION Delete all the attribute crossreference records, and update all the domain records to indicate that the attributes in attribute_list don't exist so therefore cannot be referenced by a domain. */ process_xref_records: proc; do attribute_list_idx = 1 to attribute_list.count; if attribute_list.name (attribute_list_idx) ^= "" then do; attribute_name = unmake_name (attribute_list.name (attribute_list_idx)); call mdbm_util_$xref_delete_record (local_iocb, ATTRIBUTE_KEY_HEAD, attribute_name, error_message, code); if code ^= 0 then if (code ^= error_table_$no_record) & (^delete_object_info.inhibit_errors) then call error (code, error_message); di_ptr = ptr (dbm_ptr, attribute_list.domain_info_ptr (attribute_list_idx)); call mdbm_util_$xref_dereference (local_iocb, DOMAIN_KEY_HEAD, (domain_info.name), attribute_name, reference_count , error_message, code); if code ^= 0 then if ^delete_object_info.inhibit_errors then call error (code, error_message); if reference_count <= 1 then domain_info.unreferenced = "1"b; call rmdb_add_rmdb_history (dbm_ptr, RMDB_ATTR_TYPE, (domain_info.name), RMDB_DEL_ATTR_OP, attribute_name, (""), (0)); end; end; /* do attribute_list_idx */ end process_xref_records; %page; /*DESCRIPTION This subroutine frees the unreferenced_attribute structure in the db_model for each attribute in the attribute_list. It assumes that each of the entries in that list are unreferenced attributes. */ delete_unreferenced_attribute_list: proc; do attribute_list_idx = 1 to attribute_list.count; if (attribute_list.name (attribute_list_idx) ^= "") & (attribute_list.attribute_ptr (attribute_list_idx) = null) then do; di_ptr = ptr (dbm_ptr, attribute_list.domain_info_ptr (attribute_list_idx)); attribute_name = unmake_name (attribute_list.name (attribute_list_idx)); previous_ptr, save_ptr = null; do ua_ptr = ptr (dbm_ptr, db_model.unreferenced_attribute_ptr) repeat ptr (dbm_ptr, unreferenced_attribute.fwd_thread) while ((rel (ua_ptr) ^= NULL_OFFSET) & (save_ptr = null)); if attribute_name = unreferenced_attribute.name then save_ptr = ua_ptr; else previous_ptr = ua_ptr; end; /* do ua_ptr */ if save_ptr ^= null then do; if previous_ptr = null then db_model.unreferenced_attribute_ptr = save_ptr -> unreferenced_attribute.fwd_thread; else previous_ptr -> unreferenced_attribute.fwd_thread = save_ptr -> unreferenced_attribute.fwd_thread; free save_ptr -> unreferenced_attribute in (dbm_area); end; call rmdb_add_rmdb_history (dbm_ptr, RMDB_ATTR_TYPE, (domain_info.name), RMDB_DEL_ATTR_OP, attribute_name, (""), (0)); end; end; /* do attribute_list_idx */ return; end delete_unreferenced_attribute_list; %page; /*DESCRIPTION Create an attribute_list structure populated by all the entries in the unreferenced_attribute list in the db_model. */ make_unreferenced_attribute_list: proc; /* Count up the unreferenced attributes */ attribute_list_count = 0; do ua_ptr = ptr (dbm_ptr, db_model.unreferenced_attribute_ptr) repeat ptr (dbm_ptr, unreferenced_attribute.fwd_thread) while (rel (ua_ptr) ^= NULL_OFFSET); attribute_list_count = attribute_list_count + 1; end; /* do ua_ptr */ if attribute_list_count = 0 then if delete_object_info.inhibit_errors then call error (0, ""); else call error (mrds_error_$no_unref_attr, ""); /* Create the attribute_list structure and populate it. */ allocate attribute_list in (user_area) set (attribute_list_ptr); attribute_list_count = 0; do ua_ptr = ptr (dbm_ptr, db_model.unreferenced_attribute_ptr) repeat ptr (dbm_ptr, unreferenced_attribute.fwd_thread) while (rel (ua_ptr) ^= NULL_OFFSET); attribute_list_count = attribute_list_count + 1; attribute_list.name (attribute_list_count) = make_name ((unreferenced_attribute.name)); attribute_list.attribute_ptr (attribute_list_count) = null; attribute_list.domain_info_ptr (attribute_list_count) = unreferenced_attribute.domain_ptr; end; /* do ua_ptr */ return; end make_unreferenced_attribute_list; %page; /*DESCRIPTION Print the information for the -check option. Optionally query to check for deletion. */ print_information: proc; dcl cancel_attribute bit (attribute_list.count); dcl first_cancel_attribute fixed bin; cancel_attribute = "0"b; first_cancel_attribute = 0; do attribute_list_idx = 1 to attribute_list.count; if attribute_list.name (attribute_list_idx) ^= "" then do; attribute_ptr = attribute_list.attribute_ptr (attribute_list_idx); attribute_name = unmake_name (attribute_list.name (attribute_list_idx)); if delete_object_info.check then do; if attribute_ptr = null then call ioa_$ioa_switch (delete_object_info.check_iocb_ptr, "^/Attribute ""^a"" is unreferenced.", attribute_name); else do; call ioa_$ioa_switch_nnl (delete_object_info.check_iocb_ptr, "^/Attribute ""^a"" is used in relation^[s^]", attribute_name, attribute.count > 1); do attribute_idx = 1 to attribute.count; relation_name = unmake_name (relation_list.name (attribute.relation_idx (attribute_idx))); if attribute_idx = 1 then call ioa_$ioa_switch_nnl (delete_object_info.check_iocb_ptr, " ""^a""", relation_name); else call ioa_$ioa_switch_nnl (delete_object_info.check_iocb_ptr, "^[ and^;,^] ""^a""", (attribute.count = attribute_idx), relation_name); end; /* do attribute_idx */ call ioa_$ioa_switch_nnl (delete_object_info.check_iocb_ptr, ".^/"); end; end; if (delete_object_info.check & delete_object_info.long = UNSPEC) then; else if ^delete_object_info.force then if ^query () then do; substr (cancel_attribute, attribute_list_idx, 1) = "1"b; if first_cancel_attribute = 0 then first_cancel_attribute = attribute_list_idx; end; end; end; /* do attribute_list_idx */ if first_cancel_attribute ^= 0 then call recalculate_attributes_deleted; return; %page; query: proc returns (bit (1) aligned); dcl answer char (3); call command_query_ (addr (query_info), answer, delete_object_info.request_name, " Do you wish to delete the attribute " || rtrim(attribute_name) || " ?"); if answer = "no" then return ("0"b); else return ("1"b); end query; %page; /*DESCRIPTION If any of delete operations have been cancelled, this subroutine recalculates which attributes of which relations have to be deleted. */ recalculate_attributes_deleted: proc; dcl have_attributes_to_process bit (1) aligned; dcl position fixed bin; dcl search_name char (33); /* First mark all attributes in all referenced relations undeleted. */ do relation_index = 1 to relation_list.count; relation_ptr = relation_list.relation_ptr (relation_index); unspec (relation.attribute (*).flags) = "0"b; end; /* do relation_index */ /* Now walk through the attribute list, marking each attribute in the relation structures deleted or not. */ have_attributes_to_process = "0"b; do attribute_list_idx = 1 to attribute_list.count; if substr (cancel_attribute, attribute_list_idx, 1) then attribute_list.name (attribute_list_idx) = ""; else do; have_attributes_to_process = "1"b; attribute_ptr = attribute_list.attribute_ptr (attribute_list_idx); if attribute_ptr ^= null then do; search_name = attribute_list.name (attribute_list_idx); do attribute_idx = 1 to attribute.count; relation_ptr = relation_list.relation_ptr (attribute.relation_idx (attribute_idx)); position = index (relation_attribute_names, search_name); if position ^= 0 then do; position = divide (position, 33, 17, 0) + 1; relation.attribute (position).flags.delete = "1"b; end; end; /* do attribute_idx */ end; end; end; /* do attribute_list_idx */ if ^have_attributes_to_process then call error (0, ""); return; end recalculate_attributes_deleted; end print_information; %page; /*DESCRIPTION This subroutine either deletes all information pertaining to a relation (if all attributes are deleted) or reformats it (if only some attributes are deleted. */ process_single_relation: proc; if all_attributes_are_deleted () then call delete_relation_information; else call rmdb_copy_relation (dbm_ptr, db_path, rmdb_ctl.temp_dir_path, addr (rmdb_ctl.relmgr_entries), relation_ptr, error_message, code); return; end process_single_relation; %page; /* DESCRIPTION * This module was brought over from rmdb_copy_relation since we can't really * clean up before we have finished with ALL the relations. It performs * several steps; initiate the copy of the file_model (.k), get the name of * the associated relation, copy contents of new file_model to the old one, * move the data from the old file to the new one, delete the old relation, * rename the new relation to the old name (or physically copy to old name if * dm file), remove the copy of the file_info from the db_model and free the * space. Finally, we must update the xref file to show that the relation is * no longer in the attribute key record. */ switch_names: proc; dcl 1 local_status_branch like status_branch; dcl create_model_name char (32); dcl create_relation_name char (32); dcl data_acl_ptr ptr; dcl r_index fixed bin; dcl index builtin; dcl move_string char (move_string_length) based; dcl move_string_length fixed bin (35); dcl new_model_bit_count fixed bin (24); dcl new_file_model_ptr ptr; dcl last_file_info_ptr ptr; dcl 1 co aligned like copy_options; dcl cvds bit (1) aligned; dcl ivds bit (1) aligned; dcl to_char fixed bin; create_model_name = rtrim (relation.name) || ".k"; status_area_ptr = user_area_ptr; status_ptr = addr (local_status_branch); call hcs_$status_ (db_path, create_model_name, 0, status_ptr, status_area_ptr, code); to_char = index(status_entry_names (1), ".m"); to_char = to_char -1; create_relation_name = rtrim(substr(status_entry_names (1), 1, to_char)); call initiate_file_ (db_path, create_model_name, RW_ACCESS, new_file_model_ptr, new_model_bit_count, code); if code ^= 0 then call error (code, "While initiating the new_file_model for relation " || relation.name); rmdb_relmgr_entries_ptr = addr (rmdb_ctl.relmgr_entries); /* Move the contents of the new relation.m to old relation.m. */ if (file_model.file_model_copy_good & file_model.relation_copy_good & save_code = 0) then do; move_string_length = divide (new_model_bit_count, 9, 35, 0); fm_ptr -> move_string = new_file_model_ptr -> move_string; /* Move the contents of the data relation. First we must get the attributes of the old data file (ACL, mode switches) and move them to the new data file. */ data_acl_ptr = null; call fs_util_$list_acl (db_path, relation.name, GENERAL_ACL_VERSION_1, user_area_ptr, data_acl_ptr, code); if code ^= 0 then call error (code, "Getting the ACL to relation " || relation.name); call fs_util_$replace_acl (db_path, create_relation_name, data_acl_ptr, "1"b, code); if code ^= 0 then call error (code, "Setting the ACL on relation " || create_relation_name); cvds, ivds = "0"b; call fs_util_$get_switch (db_path, relation.name, "complete_volume_dump", cvds, (0)); call fs_util_$get_switch (db_path, relation.name, "incremental_volume_dump", ivds, (0)); call fs_util_$set_switch (db_path, create_relation_name, "complete_volume_dump", cvds, (0)); call fs_util_$set_switch (db_path, create_relation_name, "incremental_volume_dump", ivds, (0)); /* Now get rid of the old data file. */ call rmdb_relmgr_entries.delete_relation (db_path, relation.name, code); if code ^= 0 then call error (code, "Deleting relation " || relation.name); /* If we are dealing with DM files, we need to physically copy the relation file. If not, then we can simply rename the new one to the old name. */ if mstxn_transactions_needed then do; co.version = COPY_OPTIONS_VERSION_1; co.caller_name = myname; co.source_dir, co.target_dir = db_path; co.source_name = create_relation_name; co.target_name = relation.name; unspec (co.flags) = "0"b; unspec (co.copy_items) = "0"b; call fs_util_$copy (addr (co), code); if code ^= 0 then call error (code, "Copying the new data file onto the old data file for relation " || relation.name); end; else do; call hcs_$chname_file (db_path, create_relation_name, create_relation_name, relation.name, code); if code ^= 0 then call error (code, "Renaming relation file from " || rtrim (create_relation_name) || " to " || relation.name); end; end; /* file_model and relation good */ /* Since we renamed the new to the old, we can get rid of the new names. */ /* We also replaced the original file_model with the new_one. */ call rmdb_relmgr_entries.delete_relation (db_path, create_relation_name, (0)); call delete_$path (db_path, create_model_name, "101111"b, myname, (0)); /* Take the copy of the file_model out of the db_model */ if relation.copy_file_model_ptr ^= null then do; do fi_ptr = ptr (dbm_ptr, db_model.file_ptr) repeat ptr (dbm_ptr, file_info.fwd_ptr) while (rel (fi_ptr) ^= rel (copy_file_model_ptr)); last_file_info_ptr = fi_ptr; end; last_file_info_ptr -> file_info.fwd_ptr = copy_file_model_ptr -> file_info.fwd_ptr; free relation.copy_file_model_ptr -> file_info in (dbm_area); end; if (code ^= 0) then if ^delete_object_info.inhibit_errors then call error (code, error_message); else ; /* ignore the error */ else if save_code = 0 /* Now we have to update the crossreference file records for all attributes that were deleted in this relation. */ then do r_index = 1 to relation.attribute_count; if relation.attribute (r_index).flags.delete then do; attribute_name = unmake_name (relation.attribute_names (r_index)); call mdbm_util_$xref_dereference (local_iocb, ATTRIBUTE_KEY_HEAD, attribute_name, relation.name, reference_count, error_message, code); if (code ^= 0) & ^(delete_object_info.inhibit_errors) then call error (code, error_message); end; end; /* do relation_index */ return; end switch_names; %page; /*DESCRIPTION This function searches the attribute list of the current relation and returns true if all the attributes are marked for deletion. */ all_attributes_are_deleted: proc returns (bit (1) aligned); dcl attribute_idx fixed bin; do attribute_idx = 1 to relation.attribute_count; if ^relation.attribute (attribute_idx).flags.delete then return ("0"b); end; /* do relation_index */ return ("1"b); end all_attributes_are_deleted; delete_relation_information: proc; /* Unlink the file_info structure. */ save_ptr, previous_ptr = null; do fi_ptr = ptr (dbm_ptr, db_model.file_ptr) repeat ptr (dbm_ptr, file_info.fwd_ptr) while ((save_ptr = null) & (rel (fi_ptr) ^= NULL_OFFSET)); if file_info.file_name = relation.name then save_ptr = fi_ptr; else previous_ptr = fi_ptr; end; /* do fi_ptr */ if save_ptr ^= null then do; if previous_ptr = null then db_model.file_ptr = save_ptr -> file_info.fwd_ptr; else previous_ptr -> file_info.fwd_ptr = save_ptr -> file_info.fwd_ptr; free save_ptr -> file_info in (dbm_area); call mdbm_util_$xref_delete_record (local_iocb, RELATION_KEY_HEAD, relation.name, error_message, (0)); end; /* Now delete the relation and relation.m files. */ call delete_file (relation.name); call delete_file (rtrim (relation.name) || ".m"); db_model.num_blk_files = db_model.num_blk_files - 1; db_model.num_rels = db_model.num_rels - 1; call rmdb_add_rmdb_history (dbm_ptr, RMDB_REL_TYPE, relation.name, RMDB_DEL_REL_OP, "", (""), (0)); return; delete_file: proc (file_name); dcl delete_$path entry (char (*), char (*), bit (36) aligned, char (*), fixed bin (35)); dcl file_name char (*) parameter; dcl fs_util_$delentry_file entry (char (*), char (*), fixed bin (35)); call fs_util_$delentry_file (db_path, file_name, code); if code = error_table_$unsupported_operation then call delete_$path (db_path, file_name, "101111"b, myname, code); if (code ^= 0) & (^delete_object_info.inhibit_errors) then call error (code, "Deleting " || file_name); return; end delete_file; end delete_relation_information; %page; %include access_mode_values; %include acl_structures; %include area_info; %include copy_flags; %include copy_options; %include mdbm_db_model; %include mdbm_file_model; %include mrds_rmdb_ctl; %include query_info; %include rmdb_crossref_info; %include rmdb_delete_object_info; %include rmdb_history_entry; %include status_structures; %page; dcl addr builtin; dcl 1 ai like area_info aligned; dcl any_other condition; dcl attribute_idx fixed bin; dcl attribute_list_idx fixed bin; dcl attribute_name char (32); dcl based_char8 char (8) based; dcl cleanup condition; dcl code fixed bin (35); dcl command_query_ entry () options (variable); dcl db_path char (168); dcl define_area_ entry (ptr, fixed bin (35)); dcl delete_$path entry (char(*), char(*), bit(36) aligned, char(*), fixed bin(35)); dcl divide builtin; dcl error_message char (500); dcl error_table_$action_not_performed fixed bin (35) ext static; dcl error_table_$unsupported_operation fixed bin (35) ext static; dcl error_table_$no_record fixed bin (35) ext static; dcl error_table_$unimplemented_version fixed bin (35) ext static; dcl fixed builtin; dcl fs_util_$copy entry (ptr, fixed bin(35)); dcl fs_util_$get_switch entry (char(*), char(*), char(*), bit(1) aligned, fixed bin(35)); dcl fs_util_$list_acl entry (char(*), char(*), char(*), ptr, ptr, fixed bin(35)); dcl fs_util_$replace_acl entry (char(*), char(*), ptr, bit(1), fixed bin(35)); dcl fs_util_$set_switch entry (char(*), char(*), char(*), bit(1) aligned, fixed bin(35)); dcl hcs_$chname_file entry (char(*), char(*), char(*), char(*), fixed bin(35)); dcl hcs_$status_ entry (char(*), char(*), fixed bin(1), ptr, ptr, fixed bin(35)); dcl Idelete_object_info_ptr ptr parameter; dcl index builtin; dcl initiate_file_ entry (char(*), char(*), bit(*), ptr, fixed bin(24), fixed bin(35)); dcl ioa_$ioa_switch entry () options (variable); dcl ioa_$ioa_switch_nnl entry () options (variable); dcl Irmdb_ctl_ptr ptr parameter; dcl last_unreferenced_attribute_ptr ptr; dcl length builtin; dcl local_iocb ptr; dcl make_consistent_msg char (500); dcl mdbm_util_$get_temp_segment_path entry (char (*), char (*), ptr, fixed bin (35)); dcl mdbm_util_$inconsistent_reset entry (ptr); dcl mdbm_util_$inconsistent_set entry options (variable); dcl mdbm_util_$free_temp_segment entry (char (*), ptr, fixed bin (35)); dcl mdbm_util_$xref_build entry (char (*), char (*), ptr, char (*), ptr, char (*), fixed bin (35)); dcl mdbm_util_$xref_delete_record entry (ptr, char (*), char (*), char (*), fixed bin (35)); dcl mdbm_util_$xref_destroy entry (ptr, char (*), char (*), char (*), fixed bin (35)); dcl mdbm_util_$xref_dereference entry (ptr, char (*), char (*), char (*), fixed bin (21), char (*), fixed bin (35)); dcl mrds_error_$no_primary_key fixed bin (35) ext static; dcl mrds_error_$no_unref_attr fixed bin (35) ext static; dcl myname char (32) int static options (constant) init ("rmdb_delete_attribute"); dcl null builtin; dcl NULL_OFFSET bit (18) unaligned int static options (constant) init ((18)"1"b); dcl Ocode fixed bin (35) parameter; dcl Oerror_message char (*) parameter; dcl previous_ptr ptr; dcl (ptr, pointer) builtin; dcl QUERY_MSG char (256) int static options (constant) init ("Answering yes will cause the specified attribute to be deleted from the currently readied MRDS database."); dcl quit condition; dcl quit_occurred bit (1) aligned; dcl reference_count fixed bin (21); dcl rel builtin; dcl relation_good_count fixed bin; dcl relation_index fixed bin; dcl relation_name char (32); dcl release_area_ entry (ptr); dcl rmdb_add_rmdb_history entry (ptr, fixed bin, char (32), fixed bin, char (32), char (500), fixed bin (35)); dcl rmdb_copy_relation entry (ptr, char (*), char (*), ptr, ptr, char (*), fixed bin (35)); dcl rmdb_delete_all$attributes entry (ptr, char (*), fixed bin (35)); dcl rmdb_relations_used$attributes entry (ptr, ptr, ptr, ptr, ptr, ptr, char (*), fixed bin (35)); dcl rtrim builtin; dcl save_code fixed bin (35); dcl save_ptr ptr; dcl substr builtin; dcl sys_info$max_seg_size fixed bin (35) ext static; dcl unspec builtin; dcl UNSPEC bit (2) aligned int static options (constant) init ("00"b); dcl user_area area based (user_area_ptr); dcl user_area_ptr ptr; end rmdb_delete_attribute;  rmdb_delete_domain.pl1 12/07/87 1328.9rew 12/07/87 1320.5 353880 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1985 * * * *********************************************************** */ /* format: ^inddcls,^indattr,indnoniterend,^indnoniterdo,indend,tree,^case,insnl,comcol61,dclind5,declareind5,delnl */ /*DESCRIPTION This subroutine deletes one or more domains from a MRDS database. Each of the domains is examined, and a list of relations to be operated upon is created. This is so that if more than one referenced domain is being deleted, each relation is only reformatted once. If a domain is unreferenced, it is simply removed from the db_model linked list. If it is referenced, the attributes defined upon the domains must be deleted, and the relations that contain those attribute must be reformatted. */ /****^ HISTORY COMMENTS: 1) change(85-12-03,Spitzer), approve(85-12-03,MCR7311), audit(86-09-15,Gilcrease), install(86-10-16,MR12.0-1187): written 2) change(86-10-30,Blair), approve(86-10-30,PBF7311), audit(86-12-05,Dupuis), install(86-12-09,MR12.0-1237): Re-arrange the quit handler so that we only hold quits during the time we are cleaning up - rename the relations, delete old model, update history and xref files. Everywhere else, once the model is marked inconsistent, the salvager will do our cleanup if necessary so we don't need to worry about the user typing something which would make the model and relations inconsistent. 3) change(87-11-03,Blair), approve(87-11-03,MCR7792), audit(87-11-30,Dupuis), install(87-12-07,MR12.2-1008): Initialize mstxn_txn_id so that we don't get caught trying to abort a txn that doesn't exist during cleanup. This happens if there is garbage in the field and dm is not available. END HISTORY COMMENTS */ rmdb_delete_domain: proc (Irmdb_ctl_ptr, Idelete_object_info_ptr, Oerror_message, Ocode); rmdb_ctl_ptr = Irmdb_ctl_ptr; delete_object_info_ptr = Idelete_object_info_ptr; last_unreferenced_attribute_ptr, user_area_ptr = null; if delete_object_info.version ^= delete_object_info_version_1 then call error (error_table_$unimplemented_version, "Version " || delete_object_info.version || " for delete_object_info structure."); db_path = rmdb_ctl.absolute_db_path; /* Create the xref file if not already created. */ if rmdb_ctl.crossref_file_info.iocb_ptr = null then do; call mdbm_util_$xref_build (rmdb_ctl.temp_dir_path, db_path, rmdb_ctl.db_model_ptr, rmdb_ctl.crossref_file_info.name, rmdb_ctl.crossref_file_info.iocb_ptr, error_message, code); if code ^= 0 then call error (code, error_message); end; local_iocb = rmdb_ctl.crossref_file_info.iocb_ptr; mstxn_txn_id = "0"b; on cleanup call cleaner; dbm_ptr = rmdb_ctl.db_model_ptr; if delete_object_info.all then call rmdb_delete_all$domains (rmdb_ctl_ptr, error_message, code); else do; /* Create a non-freeing, non-zeroing extensible area to allocate structures in. When we return and finish using these structures, we will simply throw away the area. */ call mdbm_util_$get_temp_segment_path (rmdb_ctl.temp_dir_path, myname, user_area_ptr, code); if code ^= 0 then call error (code, "Unable to get a temp segment in the temp dir."); unspec (ai) = "0"b; ai.version = area_info_version_1; ai.extend = "1"b; ai.dont_free = "1"b; ai.no_freeing = "1"b; ai.owner = myname; ai.size = sys_info$max_seg_size; ai.areap = user_area_ptr; call define_area_ (addr (ai), code); if code ^= 0 then call error (code, "Defining a user area."); domain_list_ptr, attribute_list_ptr, relation_list_ptr = null; if delete_object_info.unreferenced then call make_unreferenced_domain_delete_list; else do; call rmdb_relations_used$domains (rmdb_ctl_ptr, delete_object_info_ptr, user_area_ptr, domain_list_ptr, attribute_list_ptr, relation_list_ptr, error_message, code); if code ^= 0 then call error (code, error_message); if ^delete_object_info.force then do; unspec (query_info) = "0"b; query_info.version = query_info_version_6; query_info.yes_or_no_sw = "1"b; query_info.suppress_name_sw = "1"b; query_info.question_iocbp = delete_object_info.check_iocb_ptr; query_info.answer_iocbp = delete_object_info.query_iocb_ptr; query_info.explanation_ptr = addr (QUERY_MSG); query_info.explanation_len = length (QUERY_MSG); end; call print_information; if (delete_object_info.long = UNSPEC & delete_object_info.check) then do; code = 0; call error (code, error_message); end; end; /* Make sure we won't be creating a relation with no primary key. */ call check_for_deletion_of_primary_key; make_consistent_msg = ""; call mdbm_util_$inconsistent_set (dbm_ptr, "delete_domain", "Deleting domains", rtrim (make_consistent_msg)); /* Invalidate the resultant. */ if ^delete_object_info.unreferenced then do; rmdb_ctl.saved_res_version_ptr -> based_char8 = "RESTRUCT"; last_unreferenced_attribute_ptr = null; relation_good_count, save_code = 0; do relation_index = 1 to relation_list.count; relation_ptr = relation_list.relation_ptr (relation_index); relation_good_count = relation_good_count + 1; call process_single_relation; if code ^= 0 then do; save_code = code; goto cleanup_directory; end; /* do code ^= 0 */ end; /* do relation_index */ end; /* do referenced objects */ /* If we get here, we have copied all the relations, so now we need to clean up by deleting the copies of the file model and the old relations. */ cleanup_directory: /* The real work starts here - hold quits till we're done */ quit_occurred = "0"b; /* BEGIN CRITICAL CODE */ on quit quit_occurred = "1"b; do relation_index = 1 to relation_good_count; relation_ptr = relation_list.relation_ptr (relation_index); fm_ptr = relation.file_model_ptr; call transaction_in_progress; if mstxn_transactions_needed then do; on cleanup begin; call mstxn_cleanup; call cleaner; end; on any_other call mstxn_any_other; %include mrds_start_transaction; if mstxn_code ^= 0 then call error (mstxn_code, "Could not start a transaction."); end; call switch_names; if mstxn_transactions_needed then do; mftxn_code = 0; %include mrds_finish_transaction; end; /* end mstxn_transactions_needed */ end; /* do relation_index */ /* Continue after cleaning up the directory and the model... */ if save_code ^= 0 then do; call mdbm_util_$xref_destroy (rmdb_ctl.crossref_file_info.iocb_ptr, rmdb_ctl.temp_dir_path, rmdb_ctl.crossref_file_info.name, (""), (0)); call error (save_code, error_message); end; call unlink_deleted_domains; call mdbm_util_$inconsistent_reset (dbm_ptr); call delete_xref_records; /* Now we're done cleaning up xref and model and history is written */ revert quit; if quit_occurred then signal quit; code = 0; end; /* end ^delete_object_info.all */ call error (code, error_message); %page; /*DESCRIPTION Error handler and cleanup handler. This is the only way to exit these subroutines. */ error: proc (code, msg); dcl code fixed bin (35) parameter; dcl msg char (*) parameter; Ocode = code; if code = 0 then Oerror_message = ""; else Oerror_message = msg; goto RETURN_TO_CALLER; end error; RETURN_TO_CALLER: call cleaner; return; cleaner: proc; if user_area_ptr ^= null then do; call release_area_ (user_area_ptr); call mdbm_util_$free_temp_segment (myname, user_area_ptr, (0)); end; if mstxn_txn_id ^= "0"b then do; call transaction_manager_$abort_txn (mstxn_txn_id, code); if code ^= 0 then call transaction_manager_$abandon_txn (mstxn_txn_id, (0)); end; return; end cleaner; restore_significant_data: proc; return; end restore_significant_data; should_rollback: proc returns (bit (1) aligned); return ("0"b); end should_rollback; %page; /*DESCRIPTION This internal subroutine displays the crossreference information that we have previously gathered. It then queries (if necessary) to see if we are allowed to delete each domain. If any domain deletion is cancelled, we have to recalculate the list of attributes deleted in each relation. */ print_information: proc; dcl cancel_domain bit (domain_list.count); /* 1 ::= we don't really want to delete this one */ dcl first_cancel_domain fixed bin; /* idx of first of deleted domains cancelled */ dcl printed_names (2) char (32); dcl relations_printed bit (relation_list.count); /* 1 ::= we already printed the name of this relation */ dcl relations_printed_count fixed bin; /* number of relation names printed */ dcl relations_to_be_printed bit (1) aligned; /* indicates there is at least one relation name to be printed */ cancel_domain = "0"b; first_cancel_domain = 0; do domain_list_idx = 1 to domain_list.count; relations_to_be_printed = "0"b; attribute_list_ptr = domain_list.attribute_list_ptr (domain_list_idx); domain_name = unmake_name (domain_list.name (domain_list_idx)); if delete_object_info.check then do; if attribute_list_ptr = null then call ioa_$ioa_switch (delete_object_info.check_iocb_ptr, "^/Domain ""^a"" is unreferenced.", domain_name); else do; do attribute_list_idx = 1 to attribute_list.count; attribute_ptr = attribute_list.attribute_ptr (attribute_list_idx); attribute_name = unmake_name (attribute_list.name (attribute_list_idx)); if attribute_list_idx = 1 then call ioa_$ioa_switch_nnl (delete_object_info.check_iocb_ptr, "^/Domain ""^a"" is used in attribute^[s^] ""^a""", domain_name, (attribute_list.count > 1), attribute_name); else call ioa_$ioa_switch_nnl (delete_object_info.check_iocb_ptr, "^[ and^;,^] ""^a""", (attribute_list.count = attribute_list_idx), attribute_name); if attribute_ptr ^= null then relations_to_be_printed = "1"b; end; /* do attribute_list_idx */ if relations_to_be_printed then do; relations_printed = "0"b; relations_printed_count = 0; do attribute_list_idx = 1 to attribute_list.count; attribute_ptr = attribute_list.attribute_ptr (attribute_list_idx); if attribute_ptr ^= null then do attribute_idx = 1 to attribute.count; relation_index = attribute.relation_idx (attribute_idx); if ^substr (relations_printed, relation_index, 1) then do; substr (relations_printed, relation_index, 1) = "1"b; relation_name = unmake_name (relation_list.name (relation_index)); relations_printed_count = relations_printed_count + 1; if relations_printed_count < 3 then printed_names (relations_printed_count) = relation_name; else do; call ioa_$ioa_switch_nnl (delete_object_info.check_iocb_ptr, "^[ which ^[is^;are^] referenced in relations^;^s,^] ""^a""", (relations_printed_count = 3), (attribute_list.count = 1), printed_names (1)); printed_names (1) = printed_names (2); printed_names (2) = relation_name; end; end; end; /* do attribute_idx */ end; /* do attribute_list_idx */ if relations_printed_count > 0 then if relations_printed_count < 3 then call ioa_$ioa_switch_nnl (delete_object_info.check_iocb_ptr, "^[ which ^[is^;are^] referenced in relation ""^a""^; which ^[is^;are^] referenced in relations ""^a"" and ""^a""", (relations_printed_count = 1), (attribute_list.count = 1), printed_names (1), printed_names (2)); else call ioa_$ioa_switch_nnl (delete_object_info.check_iocb_ptr, ", ""^a"" and ""^a""", printed_names (1), printed_names (2)); end; /* relations_to_be_printed */ call ioa_$ioa_switch_nnl (delete_object_info.check_iocb_ptr, ".^/"); end; end; /* delete_object_info.check = TRUE */ if (delete_object_info.check & (delete_object_info.long = UNSPEC)) then; else if ^delete_object_info.force then if ^query () then do; substr (cancel_domain, domain_list_idx, 1) = "1"b; if first_cancel_domain = 0 then first_cancel_domain = domain_list_idx; end; end; /* do domain_list_idx */ if first_cancel_domain ^= 0 then call recalculate_attributes_deleted; return; query: proc returns (bit (1) aligned); call command_query_ (addr (query_info), answer, delete_object_info.request_name, " Do you wish to delete the domain ^a ?", rtrim(domain_name)); if answer = "no" then return ("0"b); else return ("1"b); end query; %page; /*DESCRIPTION Take the list of canceled domain deletions in the cancel_domain bit string and process it by marking all attributes in each indicated domain in each relation to be deleted. This subroutine must be internal to print_information so we can access the cancel_domain string. */ recalculate_attributes_deleted: proc; dcl have_domains_to_process bit (1) aligned; dcl position fixed bin; dcl search_name char (33); /* First mark all attributes in all referenced relations undeleted. */ do relation_index = 1 to relation_list.count; relation_ptr = relation_list.relation_ptr (relation_index); unspec (relation.attribute (*).delete) = "0"b; end; /* do relation_index */ do domain_list_idx = 1 to first_cancel_domain - 1; domain_list.name (domain_list_idx) = ""; end; /* do domain_list_idx */ /* Now walk through the domain list -> attributes, marking each attribute in the relation structures deleted or not. */ have_domains_to_process = "0"b; do domain_list_idx = first_cancel_domain to domain_list.count; if substr (cancel_domain, domain_list_idx, 1) then domain_list.name (domain_list_idx) = ""; else do; have_domains_to_process = "1"b; attribute_list_ptr = domain_list.attribute_list_ptr (domain_list_idx); do attribute_list_idx = 1 to attribute_list.count; attribute_ptr = attribute_list.attribute_ptr (attribute_list_idx); if attribute_ptr ^= null then do; /* the attribute was referenced in at least a single relation */ search_name = attribute_list.name (attribute_list_idx); do attribute_idx = 1 to attribute.count; relation_ptr = relation_list.relation_ptr (attribute.relation_idx (attribute_idx)); position = index (relation_attribute_names, search_name); if position ^= 0 then do; /* found the place, mark the attribute to be deleted */ position = divide (position, 33, 17, 0) + 1; relation.attribute (position).flags.delete = "1"b; end; end; /* do attribute_idx */ end; end; /* do attribute_list_idx */ end; end; /* do domain_list_ptr */ if ^have_domains_to_process then call error (0, ""); /* nothing to do, return to caller */ return; end recalculate_attributes_deleted; end print_information; %page; make_unreferenced_domain_delete_list: proc; /* Allocate the new domain_list structure to be the number of domains defined in size. Unless all domains are unreferenced, some of the entries will not be used. Remember to adjust the refer extent of the structure. */ domain_list_count = db_model.num_domains; allocate domain_list in (user_area) set (domain_list_ptr); domain_list.count = 0; /* Run through all domains defined in the model. */ do di_ptr = ptr (dbm_ptr, db_model.domain_ptr) repeat ptr (dbm_ptr, domain_info.fwd_thread) while (rel (di_ptr) ^= NULL_OFFSET); if domain_info.unreferenced then do; /* found a candidate */ domain_list.count = domain_list.count + 1; domain_list.name (domain_list.count) = make_name ((domain_info.name)); end; end; /* do di_ptr */ domain_list.attribute_list_ptr (*) = null; if domain_list.count = 0 then if delete_object_info.inhibit_errors then call error (0, ""); else call error (mrds_error_$no_unref_domain, ""); return; end make_unreferenced_domain_delete_list; make_name: proc (input_name) returns (char (33)); dcl input_name char (*) parameter; return (OBJECT_HEAD || input_name); end make_name; unmake_name: proc (input_name) returns (char (32)); dcl input_name char (*) parameter; return (substr (input_name, 2, 32)); end unmake_name; /*DESCRIPTION This subroutine ensures that no transaction is in progress, and sets a flag bit for use later. */ transaction_in_progress: proc; if db_model.db_type_flags.transactions_needed then do; mstxn_transactions_needed = "1"b; call transaction_manager_$get_current_txn_id (mstxn_txn_id, mstxn_code); if mstxn_code = 0 then do; mstxn_txn_id = "0"b; call error (error_table_$action_not_performed, "A transaction is in progress. Commit or abort the transaction and try the operation again."); end; end; else mstxn_transactions_needed = "0"b; return; end transaction_in_progress; %page; check_for_deletion_of_primary_key: proc; dcl attr_idx fixed bin; dcl deletion_attributes char (500); dcl no_primary_key bit (1) aligned; deletion_attributes = ""; no_primary_key = "1"b; do domain_list_idx = 1 to domain_list.count; attribute_list_ptr = domain_list.attribute_list_ptr (domain_list_idx); domain_name = unmake_name (domain_list.name (domain_list_idx)); do attribute_list_idx = 1 to attribute_list.count; attribute_ptr = attribute_list.attribute_ptr (attribute_list_idx); if attribute_ptr ^= null then do attr_idx = 1 to attribute.count; relation_ptr = relation_list.relation_ptr (attribute.relation_idx (attr_idx)); do attribute_idx = 1 to relation.attribute_count; if relation.attribute(attribute_idx).flags.part_of_key & relation.attribute_names (attribute_idx) = attribute_list.name (attribute_list_idx) then do; no_primary_key = "0"b; relation.attribute(attribute_idx).flags.to_be_deleted = "1"b; end; end; end; end; end; if ^no_primary_key then do relation_index = 1 to relation_list.count while (^no_primary_key); relation_ptr = relation_list.relation_ptr(relation_index); do attribute_idx = 1 to relation.attribute_count while (^no_primary_key); if relation.attribute(attribute_idx).flags.part_of_key then if ^relation.attribute(attribute_idx).flags.to_be_deleted then no_primary_key = "1"b; else do; attribute_name = unmake_name (relation.attribute_names (attribute_idx)); relation.attribute(attribute_idx).flags.to_be_deleted = "0"b; deletion_attributes = rtrim(deletion_attributes) || " " || rtrim(attribute_name); end; end; if ^no_primary_key then do; code = mrds_error_$no_primary_key; call error (code, "Deletion of the domain " || rtrim(domain_name) || " would result in no primary key in relation " || rtrim(relation.name) || "."); end; end; end check_for_deletion_of_primary_key; %page; /*DESCRIPTION This subroutine either deletes all information pertaining to a relation (if all domains are deleted) or reformats it according to the list of deleted domains. */ process_single_relation: proc; if all_attributes_are_deleted () then call delete_relation_information; else call rmdb_copy_relation (dbm_ptr, db_path, rmdb_ctl.temp_dir_path, addr (rmdb_ctl.relmgr_entries), relation_ptr, error_message, code); if code ^= 0 then do; if code = mrds_error_$no_primary_key then call mdbm_util_$inconsistent_reset (dbm_ptr); if delete_object_info.inhibit_errors | code = dm_error_$key_duplication then goto skip_relation; else call error (code, error_message); end; skip_relation: return; %page; all_attributes_are_deleted: proc returns (bit (1) aligned); dcl attribute_idx fixed bin; do attribute_idx = 1 to relation.attribute_count; if ^relation.attribute (attribute_idx).flags.delete then return ("0"b); end; /* do relation_index */ return ("1"b); end all_attributes_are_deleted; delete_relation_information: proc; /* Unlink the file_info structure. */ save_ptr, previous_ptr = null; do fi_ptr = ptr (dbm_ptr, db_model.file_ptr) repeat ptr (dbm_ptr, file_info.fwd_ptr) while ((save_ptr = null) & (rel (fi_ptr) ^= NULL_OFFSET)); if file_info.file_name = relation.name then save_ptr = fi_ptr; else previous_ptr = fi_ptr; end; /* do fi_ptr */ if save_ptr ^= null then do; if previous_ptr = null then db_model.file_ptr = save_ptr -> file_info.fwd_ptr; else previous_ptr -> file_info.fwd_ptr = save_ptr -> file_info.fwd_ptr; free save_ptr -> file_info in (dbm_area); call mdbm_util_$xref_delete_record (local_iocb, RELATION_KEY_HEAD, relation.name, error_message, (0)); end; /* Now delete the relation and relation.m files. */ call delete_file (relation.name); call delete_file (rtrim (relation.name) || ".m"); db_model.num_blk_files = db_model.num_blk_files - 1; db_model.num_rels = db_model.num_rels - 1; call rmdb_add_rmdb_history (dbm_ptr, RMDB_REL_TYPE, relation.name, RMDB_DEL_REL_OP, "", (""), (0)); return; delete_file: proc (file_name); dcl delete_$path entry (char (*), char (*), bit (36) aligned, char (*), fixed bin (35)); dcl error_table_$unsupported_operation fixed bin (35) ext static; dcl file_name char (*) parameter; dcl fs_util_$delentry_file entry (char (*), char (*), fixed bin (35)); call fs_util_$delentry_file (db_path, file_name, code); if code = error_table_$unsupported_operation then call delete_$path (db_path, file_name, "101111"b, myname, code); if (code ^= 0) & (^delete_object_info.inhibit_errors) then call error (code, "Deleting " || file_name); return; end delete_file; end delete_relation_information; end process_single_relation; %page; /* DESCRIPTION * This module was brought over from rmdb_copy_relation since we can't really * clean up before we have finished with ALL the relations. It performs * several steps; initiate the copy of the file_model (.k), get the name of * the associated relation, copy contents of new file_model to the old one, * move the data from the old file to the new one, delete the old relation, * rename the new relation to the old name (or physically copy to old name if * dm file), remove the copy of the file_info from the db_model and free the * space. Finally, we must update the xref file to show that the relation is * no longer in the attribute key record. */ switch_names: proc; dcl 1 local_status_branch like status_branch; dcl create_model_name char (32); dcl create_relation_name char (32); dcl data_acl_ptr ptr; dcl index builtin; dcl move_string char (move_string_length) based; dcl move_string_length fixed bin (35); dcl new_model_bit_count fixed bin (24); dcl new_file_model_ptr ptr; dcl last_file_info_ptr ptr; dcl 1 co aligned like copy_options; dcl cvds bit (1) aligned; dcl ivds bit (1) aligned; dcl to_char fixed bin; create_model_name = rtrim (relation.name) || ".k"; status_area_ptr = user_area_ptr; status_ptr = addr (local_status_branch); call hcs_$status_ (db_path, create_model_name, 0, status_ptr, status_area_ptr, code); to_char = index(status_entry_names (1), ".m"); to_char = to_char -1; create_relation_name = rtrim(substr(status_entry_names (1), 1, to_char)); call initiate_file_ (db_path, create_model_name, RW_ACCESS, new_file_model_ptr, new_model_bit_count, code); if code ^= 0 then call error (code, "While initiating the new_file_model for relation " || relation.name); rmdb_relmgr_entries_ptr = addr (rmdb_ctl.relmgr_entries); /* Move the contents of the new relation.m to old relation.m. */ if (file_model.file_model_copy_good & file_model.relation_copy_good & save_code = 0) then do; move_string_length = divide (new_model_bit_count, 9, 35, 0); fm_ptr -> move_string = new_file_model_ptr -> move_string; /* Move the contents of the data relation. First we must get the attributes of the old data file (ACL, mode switches) and move them to the new data file. */ data_acl_ptr = null; call fs_util_$list_acl (db_path, relation.name, GENERAL_ACL_VERSION_1, user_area_ptr, data_acl_ptr, code); if code ^= 0 then call error (code, "Getting the ACL to relation " || relation.name); call fs_util_$replace_acl (db_path, create_relation_name, data_acl_ptr, "1"b, code); if code ^= 0 then call error (code, "Setting the ACL on relation " || create_relation_name); cvds, ivds = "0"b; call fs_util_$get_switch (db_path, relation.name, "complete_volume_dump", cvds, (0)); call fs_util_$get_switch (db_path, relation.name, "incremental_volume_dump", ivds, (0)); call fs_util_$set_switch (db_path, create_relation_name, "complete_volume_dump", cvds, (0)); call fs_util_$set_switch (db_path, create_relation_name, "incremental_volume_dump", ivds, (0)); /* Now get rid of the old data file. */ call rmdb_relmgr_entries.delete_relation (db_path, relation.name, code); if code ^= 0 then call error (code, "Deleting relation " || relation.name); /* If we are dealing with DM files, we need to physically copy the relation file. If not, then we can simply rename the new one to the old name. */ if mstxn_transactions_needed then do; co.version = COPY_OPTIONS_VERSION_1; co.caller_name = myname; co.source_dir, co.target_dir = db_path; co.source_name = create_relation_name; co.target_name = relation.name; unspec (co.flags) = "0"b; unspec (co.copy_items) = "0"b; call fs_util_$copy (addr (co), code); if code ^= 0 then call error (code, "Copying the new data file onto the old data file for relation " || relation.name); end; else do; call hcs_$chname_file (db_path, create_relation_name, create_relation_name, relation.name, code); if code ^= 0 then call error (code, "Renaming relation file from " || rtrim (create_relation_name) || " to " || relation.name); end; end; /* file_model and relation good */ /* Since we renamed the new to the old, we can get rid of the new names. */ /* We also replaced the original file_model with the new_one. */ call rmdb_relmgr_entries.delete_relation (db_path, create_relation_name, (0)); call delete_$path (db_path, create_model_name, "101111"b, myname, (0)); /* Take the copy of the file_model out of the db_model */ if relation.copy_file_model_ptr ^= null then do; do fi_ptr = ptr (dbm_ptr, db_model.file_ptr) repeat ptr (dbm_ptr, file_info.fwd_ptr) while (rel (fi_ptr) ^= rel (copy_file_model_ptr)); last_file_info_ptr = fi_ptr; end; last_file_info_ptr -> file_info.fwd_ptr = copy_file_model_ptr -> file_info.fwd_ptr; free relation.copy_file_model_ptr -> file_info in (dbm_area); end; if (code ^= 0) then if ^delete_object_info.inhibit_errors then call error (code, error_message); else ; /* ignore the error */ else if save_code = 0 then call modify_xref; return; %page; modify_xref: proc; dcl index fixed bin; /* Now we have to update the crossreference file records for all attributes and domains that were updated in this relation. */ do index = 1 to relation.attribute_count; if relation.attribute (index).flags.delete then do; attribute_name = unmake_name (relation.attribute_names (index)); call mdbm_util_$xref_dereference (local_iocb, ATTRIBUTE_KEY_HEAD, attribute_name, relation.name, reference_count, error_message, code); if code ^= 0 then if delete_object_info.inhibit_errors then goto finish_relation; di_ptr = ptr (dbm_ptr, relation.attribute(index).domain_info_ptr); if reference_count = 0 & attribute_name ^= domain_info.name then do; /* attribute became unreferenced */ /* Find the last unreferenced_attribute structure in the db_model. */ if last_unreferenced_attribute_ptr = null then do ua_ptr = ptr (dbm_ptr, db_model.unreferenced_attribute_ptr) repeat ptr (dbm_ptr, unreferenced_attribute.fwd_thread) while (rel (ua_ptr) ^= NULL_OFFSET); last_unreferenced_attribute_ptr = ua_ptr; end; /* do ua_ptr */ /* Make a new unreferenced_attribute structure and populate it. */ allocate unreferenced_attribute in (dbm_area) set (ua_ptr); unreferenced_attribute.name = attribute_name; unreferenced_attribute.domain_ptr = relation.attribute (index).domain_info_ptr; unreferenced_attribute.fwd_thread = NULL_OFFSET; unreferenced_attribute.unused (*) = NULL_OFFSET; /* Add it on the end of the linked list. */ if last_unreferenced_attribute_ptr = null then db_model.unreferenced_attribute_ptr = rel (ua_ptr); else last_unreferenced_attribute_ptr -> unreferenced_attribute.fwd_thread = rel (ua_ptr); last_unreferenced_attribute_ptr = ua_ptr; end; end; end; /* do index */ finish_relation: return; end modify_xref; end switch_names; %page; /*DESCRIPTION Delete the crossreference records for all deleted domains. */ delete_xref_records: proc; do domain_list_idx = 1 to domain_list.count; if domain_list.name (domain_list_idx) ^= "" then do; domain_name = unmake_name (domain_list.name (domain_list_idx)); call mdbm_util_$xref_delete_record (local_iocb, DOMAIN_KEY_HEAD, domain_name, error_message, code); if code ^= 0 then if code ^= error_table_$no_record then call error (code, error_message); /* An artifact of a domain is that there is an attribute crossreference record for each domain also, as a domain can also be used as an attribute without explicitly creating the attribute. We must also delete this record from the crossreference file. */ call mdbm_util_$xref_delete_record (local_iocb, ATTRIBUTE_KEY_HEAD, domain_name, error_message, code); if code ^= 0 then if code ^= error_table_$no_record then call error (code, error_message); /* we got rid of the "generated" attribute, now get rid of any others */ attribute_list_ptr = domain_list.attribute_list_ptr(domain_list_idx); if attribute_list_ptr ^= null then do attribute_list_idx = 1 to attribute_list.count; attribute_name = unmake_name(attribute_list.name(attribute_list_idx)); call mdbm_util_$xref_delete_record (local_iocb, ATTRIBUTE_KEY_HEAD, attribute_name, error_message, code); if code ^= 0 then if code ^= error_table_$no_record then call error (code, error_message); end; /* do attribute_list_idx */ end; /* do domain_list_idx */ end; return; end delete_xref_records; %page; /*DESCRIPTION Unlink the domain_info structures for the deleted domains in the db_model. Add a history entry for each deleted domain. */ unlink_deleted_domains: proc; do domain_list_idx = 1 to domain_list.count; if domain_list.name (domain_list_idx) ^= "" then do; domain_name = unmake_name (domain_list.name (domain_list_idx)); /* Since we just made all the attributes based on this domain unreferenced in the model, we need to unlink all the attributes on the attribute_list from the unreferenced attribute chain and free the ua structures. Skip the list entry that has the same name as the domain name, because the generated attribute has no structures in the model. */ attribute_list_ptr = domain_list.attribute_list_ptr (domain_list_idx); if attribute_list_ptr ^= null then do attribute_list_idx = 1 to attribute_list.count; if attribute_list.name (attribute_list_idx) ^= domain_list.name (domain_list_idx) then do; /* all but the generated one */ previous_ptr, save_ptr = null; attribute_name = unmake_name (attribute_list.name (attribute_list_idx)); do ua_ptr = ptr (dbm_ptr, db_model.unreferenced_attribute_ptr) repeat ptr (dbm_ptr, unreferenced_attribute.fwd_thread) while ((save_ptr = null) & (rel (ua_ptr) ^= NULL_OFFSET)); if unreferenced_attribute.name = attribute_name then save_ptr = ua_ptr; else previous_ptr = ua_ptr; end; /* do ua_ptr */ if save_ptr ^= null then do; if previous_ptr = null then db_model.unreferenced_attribute_ptr = save_ptr -> unreferenced_attribute.fwd_thread; else previous_ptr -> unreferenced_attribute.fwd_thread = save_ptr -> unreferenced_attribute.fwd_thread; free save_ptr -> unreferenced_attribute in (dbm_area); call rmdb_add_rmdb_history (dbm_ptr, RMDB_ATTR_TYPE, attribute_name, RMDB_DEL_ATTR_OP, "", (""), (0)); end; end; end; /* do attribute_list_idx */ /* Now that we have gotten rid of all the unreferenced attributes based upon this domain, we can get rid of the domain_info structure. */ previous_ptr, save_ptr = null; do di_ptr = ptr (dbm_ptr, db_model.domain_ptr) repeat ptr (dbm_ptr, domain_info.fwd_thread) while ((save_ptr = null) & (rel (di_ptr) ^= NULL_OFFSET)); if domain_info.name = domain_name then save_ptr = di_ptr; else previous_ptr = di_ptr; end; /* do di_ptr */ if save_ptr ^= null then do; if previous_ptr = null then db_model.domain_ptr = save_ptr -> domain_info.fwd_thread; else previous_ptr -> domain_info.fwd_thread = save_ptr -> domain_info.fwd_thread; free save_ptr -> domain_info in (dbm_area); db_model.num_domains = db_model.num_domains - 1; call rmdb_add_rmdb_history (dbm_ptr, RMDB_DOMAIN_TYPE, domain_name, RMDB_DEL_DMN_OP, "", (""), (0)); end; end; end; /* do domain_list_idx */ return; end unlink_deleted_domains; %page; %include access_mode_values; %include acl_structures; %include area_info; %include copy_flags; %include copy_options; %include mdbm_db_model; %include mdbm_file_model; %include mrds_rmdb_ctl; %include query_info; %include rmdb_delete_object_info; %include rmdb_crossref_info; %include rmdb_history_entry; %include status_structures; %page; dcl addr builtin; dcl 1 ai like area_info aligned; dcl answer char (3); dcl any_other condition; dcl attribute_idx fixed bin; dcl attribute_list_idx fixed bin; dcl attribute_name char (32); dcl based_char8 char (8) based; dcl cleanup condition; dcl code fixed bin (35); dcl command_query_ entry () options (variable); dcl db_path char (168); dcl define_area_ entry (ptr, fixed bin (35)); dcl delete_$path entry (char(*), char(*), bit(36) aligned, char(*), fixed bin(35)); dcl divide builtin; dcl domain_list_idx fixed bin; dcl domain_name char (32); dcl dm_error_$key_duplication fixed bin (35) ext static; dcl error_message char (500); dcl error_table_$action_not_performed fixed bin (35) ext static; dcl error_table_$no_record fixed bin (35) ext static; dcl error_table_$unimplemented_version fixed bin (35) ext static; dcl fixed builtin; dcl fs_util_$copy entry (ptr, fixed bin(35)); dcl fs_util_$get_switch entry (char(*), char(*), char(*), bit(1) aligned, fixed bin(35)); dcl fs_util_$list_acl entry (char(*), char(*), char(*), ptr, ptr, fixed bin(35)); dcl fs_util_$replace_acl entry (char(*), char(*), ptr, bit(1), fixed bin(35)); dcl fs_util_$set_switch entry (char(*), char(*), char(*), bit(1) aligned, fixed bin(35)); dcl hcs_$chname_file entry (char(*), char(*), char(*), char(*), fixed bin(35)); dcl hcs_$status_ entry (char(*), char(*), fixed bin(1), ptr, ptr, fixed bin(35)); dcl Idelete_object_info_ptr ptr parameter; dcl index builtin; dcl initiate_file_ entry (char(*), char(*), bit(*), ptr, fixed bin(24), fixed bin(35)); dcl ioa_$ioa_switch entry () options (variable); dcl ioa_$ioa_switch_nnl entry () options (variable); dcl Irmdb_ctl_ptr ptr parameter; dcl last_unreferenced_attribute_ptr ptr; dcl length builtin; dcl local_iocb ptr; dcl make_consistent_msg char (500); dcl mdbm_util_$free_temp_segment entry (char (*), ptr, fixed bin (35)); dcl mdbm_util_$get_temp_segment_path entry (char (*), char (*), ptr, fixed bin (35)); dcl mdbm_util_$inconsistent_reset entry (ptr); dcl mdbm_util_$inconsistent_set entry (ptr, char (*), char (*), char (*)); dcl mdbm_util_$xref_build entry (char (*), char (*), ptr, char (*), ptr, char (*), fixed bin (35)); dcl mdbm_util_$xref_delete_record entry (ptr, char (*), char (*), char (*), fixed bin (35)); dcl mdbm_util_$xref_dereference entry (ptr, char (*), char (*), char (*), fixed bin (21), char (*), fixed bin (35)); dcl mdbm_util_$xref_destroy entry (ptr, char (*), char (*), char (*), fixed bin (35)); dcl mrds_error_$no_primary_key fixed bin (35) ext static; dcl mrds_error_$no_unref_domain fixed bin (35) ext static; dcl myname char (32) int static options (constant) init ("rmdb_delete_domain"); dcl null builtin; dcl NULL_OFFSET bit (18) unaligned int static options (constant) init ((18)"1"b); dcl Ocode fixed bin (35) parameter; dcl Oerror_message char (*) parameter; dcl previous_ptr ptr; dcl (ptr, pointer) builtin; dcl QUERY_MSG char (110) int static options (constant) init ("Answering yes will cause the specified domain to be deleted from the currently readied MRDS database."); dcl quit condition; dcl quit_occurred bit (1) aligned; dcl reference_count fixed bin (21); dcl rel builtin; dcl relation_good_count fixed bin (21); dcl relation_index fixed bin; dcl relation_name char (32); dcl release_area_ entry (ptr); dcl rmdb_add_rmdb_history entry (ptr, fixed bin, char (32), fixed bin, char (32), char (500), fixed bin (35)); dcl rmdb_copy_relation entry (ptr, char (*), char (*), ptr, ptr, char (*), fixed bin (35)); dcl rmdb_delete_all$domains entry (ptr, char (*), fixed bin (35)); dcl rmdb_relations_used$domains entry (ptr, ptr, ptr, ptr, ptr, ptr, char (*), fixed bin (35)); dcl rtrim builtin; dcl save_code fixed bin (35); dcl save_ptr ptr; dcl substr builtin; dcl sys_info$max_seg_size fixed bin (35) ext static; dcl unspec builtin; dcl UNSPEC bit (2) aligned int static options (constant) init ("00"b); dcl user_area area based (user_area_ptr); dcl user_area_ptr ptr; end rmdb_delete_domain;  rmdb_delete_index.pl1 10/23/86 1025.2rew 10/23/86 1007.9 166158 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /****^ 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-05-06 by Thanh Nguyen. (see mrds #136) 2) change(86-10-21,Blair), approve(86-10-21,PBF7311), audit(86-10-23,Dupuis), install(86-10-23,MR12.0-1199): If the code from relmgr_entries.delete_index indicates that the index doesn't exist, reset the code so that we can continue and delete the index entry from the model. This might happen if a create_index got rolled back, but the model wasn't updated to reflect the rollback. END HISTORY COMMENTS */ rmdb_delete_index: proc (rdi_rmdb_ctl_ptr, rdi_db_abs_path, rdi_db_model_ptr, rdi_rel_name, rdi_attr_name, rdi_brief_flag, rdi_error_message, rdi_code); /* BEGIN_DESCRIPTION This module will change an indexed attribute in a relation into a non-indexed attribute. This process involves both updating the structures in the model and deleting the old indices. An attempt has been made to make data model updates uninterruptable by the user. To do this any quits signaled by the user are delayed until the updates are complete. It is not possible to recreate the deleted indices in the event that the cleanup condition is signaled. Instead the database is marked as inconsistent before the model is updated and is not marked as consistent until the last tuple has been un-indexed. END_DESCRIPTION NOTE: Naming convention: because of the number of internal routines and the need for descriptive names, variables declared in all routines (including the main entry) have prefixes that are the initials of the routine name. Global variables can be identified since they have a prefix different from that derived from the routine name. Variables with the same name except for the prefix mean the same thing. Variables without a prefix are external to the module, i.e. entry names, external static, builtins, conditions, etc. These variables are declared in the main routine. In order to reduce the complexity of this module, none of the internal routines have an error code parameter. Instead they set a global error code declared in the main routine, call the clean_up routine, and perform a non-local goto to leave the module. Known Bugs: Other Problems: HISTORY 82-05-20 Davids: Written 82-05-26 Davids: added rdi_db_model_ptr to the input parameters and removed code that initiated it. 82-06-10 Lackey: Changed RMDB_DEL_OP to RMDB_DEL_IDX_OP 82-06-23 Davids: changed all references of force to brief to reflect the control arg's name change. 82-07-01 Roger Lackey : Modified the calls to mu_db_inconsistent to use mdbm_util_$inconsistent_* for binding. 82-09-15 D. Woodka : Modified for DMS conversion. Replaced call to iox_$attach with a call to rmdb_relmgr_entries.open, and calls to iox_$control (order delete_key) with a call to rmdb_relmgr_entries.delete_index. 83-01-10 Davids: Modified to correct the sense of an if statement that was causing relmgr_entries.delete_index not to be called. Also added code dealing with transactions. 83-01-17 Davids: Code to report an error with finishing a transaction and to correctly handle errors occuring in the clean_up procedure. 83-01-20 Davids: Removed declared but unused variables. 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-05-24 Davids: Added code to set the version of the saved resultant to RESTRUCT so that the saved resultant will not be used for an opening. */ /* PARAMETERS */ dcl rdi_db_abs_path char (168); /* (input) absolute path to the database directory */ dcl rdi_db_model_ptr ptr; /* (input) pointer to the database model */ dcl rdi_rel_name char (*); /* (input) name of the relation to be restructured */ dcl rdi_attr_name char (*); /* (input) name of the attribute to be un-indexed */ dcl rdi_brief_flag bit (1); /* (input) true ==> caller used brief ctl_arg */ dcl rdi_error_message char (500); /* (output) text of message in the event of an error */ dcl rdi_code fixed bin (35); /* (output) standard error code */ /* AUTOMATIC */ dcl rdi_attr_ptr ptr; /* pointer to attr_info structure */ dcl rdi_file_model_ptr ptr; /* pointer to the file model that contains the relation */ dcl rdi_index_id bit (36) aligned; /* actual bits that identify which attr an index refers to */ dcl rdi_nsecs fixed bin; /* number of secondary indices in the relation being restructured */ dcl rdi_number_of_varying_attrs fixed bin; /* number of varying attrs in the relation being indexed */ dcl rdi_quit_signaled bit (1); /* true if the break key was hit */ dcl rdi_rel_id bit (36) aligned; /* bits that identify the relation */ dcl rdi_rel_opening_id bit (36) aligned; /* relation opening identifier */ dcl rdi_rel_ptr ptr; /* pointer to the rel_info structure */ dcl rdi_rmdb_ctl_ptr ptr; dcl 01 rdi_seek_head_info, /* used in iox_$seek_head */ 02 relation_type fixed bin init (0),/* equality */ 02 n fixed bin init (3),/* 3 characters */ 02 search_key char (256) init (""); /* BUILTINS */ dcl addr builtin; dcl fixed builtin; dcl length builtin; dcl null builtin; dcl pointer builtin; dcl rel builtin; dcl rtrim builtin; /* BASED */ dcl rdi_based_char8 char (8) based; /* overlay on the saved_res_version value */ /* CONDITIONS */ dcl any_other condition; dcl cleanup condition; dcl quit condition; /* ENTRIES */ dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl ioa_$rs entry () options (variable); dcl mdbm_util_$inconsistent_reset entry (ptr); dcl mdbm_util_$inconsistent_set entry (ptr, char (*), char (*), char (*)); dcl rmdb_add_rmdb_history entry (ptr, fixed bin, char (32), fixed bin, char (32), char (500), fixed bin (35)); /* EXTERNAL STATIC */ dcl dm_error_$collection_not_found fixed bin(35) ext static; dcl error_table_$action_not_performed fixed bin (35) ext static; dcl sys_info$max_seg_size fixed bin (35) ext static; /* INCLUDES */ %page; %include mdbm_db_model; %page; %include mdbm_file_model; %page; %include rmdb_history_entry; %page; %include mrds_rmdb_ctl; /* Initialize variables which may be referenced before they are set somewhere else, i.e. they are referenced in the cleanup handler */ rdi_code = 0; rdi_error_message = ""; rdi_quit_signaled = "0"b; rdi_rel_opening_id = "0"b; rmdb_ctl_ptr = rdi_rmdb_ctl_ptr; mstxn_txn_id = "0"b; mstxn_transactions_needed = "0"b; /* If the database needs transactions and one is already in progress stop right now. */ if rdi_db_model_ptr -> db_model.db_type_flags.transactions_needed then do; mstxn_transactions_needed = "1"b; call transaction_manager_$get_current_txn_id (mstxn_txn_id, mstxn_code); if mstxn_code ^= dm_error_$no_current_transaction then do; rdi_code = error_table_$action_not_performed; rdi_error_message = "Indexes may not be deleted while a transaction is in proggress, " || "commit or abort the current transaction and try again."; goto exit_rmdb_delete_index; end; end; /* Get pointers to the relation's file model, and extract from the model the rel_id, index_id, and the rel_ptr and attr_ptr. */ call initiate_models (rdi_db_abs_path, rdi_rel_name, rdi_file_model_ptr); call get_relation_data (rdi_file_model_ptr, rdi_rel_ptr, rdi_rel_id, rdi_number_of_varying_attrs); call get_attribute_data (rdi_file_model_ptr, rdi_rel_ptr, rdi_rel_name, rdi_attr_name, rdi_attr_ptr, rdi_index_id, rdi_nsecs); on cleanup call mstxn_cleanup; on any_other call mstxn_any_other; %include mrds_start_transaction; if mstxn_code ^= 0 then do; rdi_code = mstxn_code; rdi_error_message = "Could not start a transaction"; goto exit_rmdb_delete_index; end; /* Mark the database inconsistent, delay quit handling to prevent the database from being partially marked. */ on quit rdi_quit_signaled = "1"b; rmdb_ctl_ptr -> rmdb_ctl.saved_res_version_ptr -> rdi_based_char8 = "RESTRUCT"; call mdbm_util_$inconsistent_set (rdi_db_model_ptr, "delete_index", "Deleting the index " || rtrim (rdi_attr_name) || " from relation " || rtrim (rdi_rel_name), "delete_index " || rtrim (rdi_rel_name) || " " || rtrim (rdi_attr_name) || " -brief"); revert quit; if rdi_quit_signaled then do; rdi_quit_signaled = "0"b; signal quit; end; on cleanup begin; call mstxn_cleanup; call clean_up (""b, "1"b); end; /* Do the actual index deletion. quit handlers are not needed since vfile assures that any operation started is completed. */ call rmdb_ctl.relmgr_entries.open (rdi_db_abs_path, rdi_rel_name, rdi_rel_opening_id, rdi_code); if rdi_code ^= 0 then do; rdi_error_message = "Error while opening the relation"; call restore_significant_data; goto mftxn_exit; end; call rmdb_ctl.relmgr_entries.delete_index (rdi_rel_opening_id, rdi_index_id, rdi_code); /* no index but still need to clean up the model */ if rdi_code = dm_error_$collection_not_found then rdi_code = 0; mftxn_code = rdi_code; %include mrds_finish_transaction; if mftxn_code ^= 0 then do; rdi_error_message = "Could not finish the transaction"; call clean_up ("0"b, "1"b); goto exit_rmdb_delete_index; end; if rdi_code ^= 0 then do; rdi_error_message = "Error while deleting the index"; call clean_up ("0"b, "1"b); goto exit_rmdb_delete_index; end; /* Update the model to reflect that the attribute is no longer indexed and mark the database as consistent. */ on quit rdi_quit_signaled = "1"b; call update_model (rdi_db_model_ptr, rdi_rel_ptr, rdi_nsecs, rdi_attr_ptr); call mdbm_util_$inconsistent_reset (rdi_db_model_ptr); revert quit; if rdi_quit_signaled then do; rdi_quit_signaled = "0"b; signal quit; end; call clean_up ("1"b, "0"b); exit_rmdb_delete_index: return; should_rollback: proc () returns (bit (1)); return ("0"b); end should_rollback; restore_significant_data: proc; dcl rsd_code fixed bin (35); rdi_error_message = rtrim (rdi_error_message) || " Backout has occured."; if rdi_rel_opening_id ^= "0"b then call rmdb_ctl.relmgr_entries.close (rdi_rel_opening_id, rsd_code); rdi_rel_opening_id = "0"b; return; end restore_significant_data; initiate_models: proc (im_db_abs_path, im_rel_name, im_file_model_ptr); /* This routine initiates a pointer to the file_model segment that contains the relation model. If the file model cannot be found it indicates that the data base does not contain the relation. */ /* PARAMETERS */ dcl im_db_abs_path char (168); /* (input) absolute path to the database directory */ dcl im_rel_name char (*); /* (input) name of the relation to be restructured */ dcl im_file_model_ptr ptr; /* (output) pointer to the file model . that contains the relation */ call hcs_$initiate (im_db_abs_path, rtrim (im_rel_name) || ".m", "", 0, 0, im_file_model_ptr, rdi_code); if im_file_model_ptr = null () then do; call ioa_$rs ("^/The relation ^a does not exist in the data base.", rdi_error_message, length (rdi_error_message), im_rel_name); goto exit_rmdb_delete_index; end; else rdi_code = 0; return; end initiate_models; get_relation_data: proc (grd_file_model_ptr, grd_rel_ptr, grd_rel_id, grd_number_of_varying_attrs); /* This routine extracts information from the rel_info structure for the relation that is to be restructured. */ /* PARAMETERS */ dcl grd_file_model_ptr ptr; /* (input) pointer to the file model that contains the relation */ dcl grd_rel_ptr ptr; /* (output) pointer to the rel_info structure */ dcl grd_rel_id bit (36) aligned; /* (output) bits that identify the relation */ dcl grd_number_of_varying_attrs fixed bin; /* (output) number of varying attrs in . the relation being indexed */ grd_rel_ptr = pointer (grd_file_model_ptr, grd_file_model_ptr -> file_model.rel_ptr); grd_rel_id = grd_rel_ptr -> rel_info.id; grd_number_of_varying_attrs = grd_rel_ptr -> rel_info.nvar_atts; return; end get_relation_data; get_attribute_data: proc (gad_file_model_ptr, gad_rel_ptr, gad_rel_name, gad_attr_name, gad_attr_ptr, gad_index_id, gad_nsecs); /* This routine gets the information about the attribute that is needed, i.e. its index_id and a pointer to its info structure. It also counts the number of indexed attributes in the relation. */ /* PARAMETERS */ dcl gad_file_model_ptr ptr; /* (input) pointer to the file model that contains the relation */ dcl gad_rel_ptr ptr; /* (input) pointer to the rel_info structure */ dcl gad_rel_name char (*); /* (input) name of the relation to be restructured */ dcl gad_attr_name char (*); /* (input) name of the attribute to be un-indexed */ dcl gad_attr_ptr ptr; /* (output) pointer to attr_info structure */ dcl gad_index_id bit (36) aligned; /* (output) actual bits that identify . which attr an index refers to */ dcl gad_nsecs fixed bin; /* (output) number of secondary indices . in the relation being restructured */ /* AUTOMATIC */ dcl gad_i fixed bin; /* loop index */ dcl gad_local_attr_ptr ptr; /* pointer to attr_info structure */ gad_attr_ptr = null (); gad_nsecs = 0; gad_local_attr_ptr = pointer (gad_file_model_ptr, gad_rel_ptr -> rel_info.attr_ptr); do gad_i = 1 to gad_rel_ptr -> rel_info.num_attr; if gad_local_attr_ptr -> attr_info.name = gad_attr_name then gad_attr_ptr = gad_local_attr_ptr; if gad_local_attr_ptr -> attr_info.index_attr then gad_nsecs = gad_nsecs + 1; gad_local_attr_ptr = pointer (gad_file_model_ptr, gad_local_attr_ptr -> attr_info.fwd_thread); end; if gad_attr_ptr = null () then do; rdi_code = error_table_$action_not_performed; call ioa_$rs ("^/Relation ^a does not contain an attribute named ^a", rdi_error_message, length (rdi_error_message), gad_rel_name, gad_attr_name); goto exit_rmdb_delete_index; end; if ^gad_attr_ptr -> attr_info.index_attr then do; if rdi_brief_flag then goto exit_rmdb_delete_index; else do; rdi_code = error_table_$action_not_performed; call ioa_$rs ("^/Attribute ^a in relation ^a is not a secondary index", rdi_error_message, length (rdi_error_message), gad_attr_name, gad_rel_name); goto exit_rmdb_delete_index; end; end; gad_index_id = gad_attr_ptr -> attr_info.index_id; return; end get_attribute_data; update_model: proc (um_db_model_ptr, um_rel_ptr, um_nsecs, um_attr_ptr); /* This procedure updates the data model to reflect that the attribute is no longer indexed, and if the last index is being deleted that the relation is no longer indexed. */ /* PARAMETERS */ dcl um_db_model_ptr ptr; /* (input) pointer to the database model */ dcl um_rel_ptr ptr; /* (input) pointer to the rel_info structure */ dcl um_nsecs fixed bin; /* (input) number of secondary indices . in the relation being restructured */ dcl um_attr_ptr ptr; /* (input) pointer to attr_info structure */ if um_nsecs = 1 then um_rel_ptr -> rel_info.indexed = "0"b; um_attr_ptr -> attr_info.index_attr = "0"b; um_attr_ptr -> attr_info.index_id = "0"b; call rmdb_add_rmdb_history (um_db_model_ptr, RMDB_REL_TYPE, (um_rel_ptr -> rel_info.name), RMDB_DEL_IDX_OP, (um_attr_ptr -> attr_info.name), rdi_error_message, rdi_code); if rdi_code ^= 0 then do; call clean_up ("0"b, "1"b); goto exit_rmdb_delete_index; end; return; end update_model; clean_up: proc (cu_set_code, cu_leave_db_inconsistent); /* This procedure is called both during normal and error termination and in the event that the cleanup condition is signaled. */ /* PARAMETERS */ dcl cu_set_code bit (1); /* (input) true ==> if error occurs during cleanup, global error . code will be set to error */ dcl cu_leave_db_inconsistent bit (1); /* (input) true ==> the dba will not be queried if indexing is . to continue and the message giving directions for . how to make the db consistent will be concatinated . to the returned error message */ /* AUTOMATIC */ dcl cu_code fixed bin (35); /* internal error code */ if cu_leave_db_inconsistent then rdi_error_message = rtrim (rdi_error_message) || "^/The data base is being left in an inconsistent state," || "^/to make the database consistent use the delete_index request" || "^/to finish deleting the partially deleted index."; if rdi_rel_opening_id ^= "0"b then call rmdb_ctl.relmgr_entries.close (rdi_rel_opening_id, cu_code); if cu_set_code then do; if cu_code ^= 0 then do; rdi_code = cu_code; if rdi_code = 0 then rdi_error_message = "^/The relation could not be closed."; else rdi_error_message = rtrim (rdi_error_message) || "^/The relation could not be closed."; end; end; else do; if cu_code ^= 0 then rdi_error_message = rtrim (rdi_error_message) || "^/The relation could not be closed."; end; return; end clean_up; end rmdb_delete_index;  rmdb_delete_relation.pl1 12/09/86 1247.6rew 12/09/86 1235.2 134280 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /****^ 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-05-06 by Thanh Nguyen. (see mrds #136) 2) change(86-04-03,Spitzer), approve(86-04-03,MCR7311), audit(86-09-15,Gilcrease), install(86-10-16,MR12.0-1187): Add updating the crossreference file. 3) change(86-12-03,Blair), approve(86-12-03,PBF7311), audit(86-12-05,Dupuis), install(86-12-09,MR12.0-1237): If we're executing the delete as a cleanup operation and the rel_name is not in the model and there is no xref-file, we don't have anything to unlink. END HISTORY COMMENTS */ rmdb_delete_relation: proc (I_rmdb_ctl_ptr, I_rmdb_delete_rel_info_ptr, O_err_msg, O_err_code); /* BEGIN_DESCRIPTION This module implements the rmdb delete relation work. It unlinks any knowledge of the relation from the db_model, deletes the file_model (rel_name.m) and deletes the rel_data file (rel_name). This procedure contains two entry points: rmdb_delete_relation$rmdb_delete_relation rmdb_delete_relation$cleanup The only difference is that cleanup entry point does NOT set the inconsistent undo string. END_DESCRIPTION */ /* HISTORY 82-04-29 Written by R. Lackey 82-07-01 Roger Lackey : Modified the calls to mu_db_inconsistent to use mdbm_util_$inconsistent_* for binding. 82-09-14 D. Woodka : Modified for DMS conversion. The call to delete_$path to delete the relation's MSF was changed to a call to rmdb_relmgr_entries. delete_relation. The cleanup_intercept handler was removed. The pointer rmdb_ctl_ptr is now passed in as an argument in order to pass the relation_manager entry points. 83-02-09 Mike Kubicar : Added transaction processing include files. 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-05-24 Davids: Added code to reset the saved_res_version so the saved resultant will not get incorrectly used. */ /* PARAMETERS */ dcl I_rmdb_ctl_ptr ptr parameter; /* Pointer to rmdb_ctl structure */ dcl I_rmdb_delete_rel_info_ptr ptr parameter; /* Pointer rmdb_delete_rel_info structure */ dcl O_err_code fixed bin (35) parameter; /* Error code */ dcl O_err_msg char (*) parameter;/* Error message test */ /* main entry point */ cleanup_entry_point = "0"b; goto common; %page; /* Cleanup entry point does not set undo string in inconsistence */ cleanup: entry (I_rmdb_ctl_ptr, I_rmdb_delete_rel_info_ptr, O_err_msg, O_err_code); cleanup_entry_point = "1"b; goto common; %page; common: rmdb_delete_rel_info_ptr = I_rmdb_delete_rel_info_ptr; rmdb_ctl_ptr = I_rmdb_ctl_ptr; mstxn_txn_id = "0"b; if rmdb_delete_rel_info.version ^= RMDB_DELETE_REL_INFO_VERSION_1 then call error (error_table_$unimplemented_version, "For rmdb_delete_rel_info.version"); if rmdb_delete_rel_info.db_model_ptr -> db_model.db_type_flags.transactions_needed then do; /* Transactions needed, it's a protected dm file */ mstxn_transactions_needed = "1"b; call transaction_manager_$get_current_txn_id (mstxn_txn_id, mstxn_code); if mstxn_code = 0 then do; mstxn_txn_id = "0"b; call error (error_table_$action_not_performed, "Relations may not be deleted while a transaction " || "is in progress. Commit or abort the transaction " || "and try again."); end; end; else mstxn_transactions_needed = "0"b; mstxn_txn_id = "0"b; db_path = rmdb_delete_rel_info.absolute_db_path; dbm_ptr = rmdb_delete_rel_info.db_model_ptr; rel_name = rtrim (rmdb_delete_rel_info.relation_name); O_err_msg = ""; O_err_code = 0; if db_path = "" then call error (mrds_error_$no_db_path, ""); exists_in_db_model = "0"b; /* Don't know yet */ brief = rmdb_delete_rel_info.brief; rmdb_ctl_ptr -> rmdb_ctl.saved_res_version_ptr -> based_char8 = "RESTRUCT"; /* Critical code to unlink relation from db_model QUITs will be intercepted and held until the unlink critical code is completed */ quit_intercept_flag = "0"b; on quit quit_intercept_flag = "1"b; /* hold off any QUITs til finished updating db_model */ call unlink_relation (exists_in_db_model); /* Internal procedure */ if exists_in_db_model then do; call terminate_file_ (fm_ptr, 0, TERM_FILE_DELETE, code); if code ^= 0 then do; if code = error_table_$noentry then code = 0; /* File model not there */ else call error (code, rtrim (db_path) || ">" || rel_name || ".m"); end; end; /* delete the relation */ on cleanup call mstxn_cleanup; on any_other call mstxn_any_other; %include mrds_start_transaction; if mstxn_code ^= 0 then call error (mstxn_code, "Could not start a transaction while deleting relation " || rtrim (rel_name) || "."); call rmdb_ctl.relmgr_entries.delete_relation (db_path, rel_name, code); if code ^= 0 then do; if code = error_table_$noentry then code = 0; /* Relation data file not there */ else call error (code, rtrim (db_path) || ">" || rel_name); end; call mdbm_util_$inconsistent_reset (dbm_ptr); /* Make db consistent */ /* If not cleanup_entrypoint then add the history entry to the db_model that we deleted it */ if ^cleanup_entry_point then call rmdb_add_rmdb_history (dbm_ptr, RMDB_REL_TYPE, (rel_name), RMDB_DEL_REL_OP, "", long_err_msg, code); revert quit; if quit_intercept_flag then signal quit; /* Now signal the quit that was intercepted */ if ^exists_in_db_model & ^brief then call error (mrds_error_$no_model_rel, "^/" || rel_name); exit: if O_err_code = mrds_error_$no_model_rel /* Don't abort just for this */ then mftxn_code = 0; else mftxn_code = O_err_code; %include mrds_finish_transaction; if mftxn_code ^= 0 then do; O_err_code = mftxn_code; O_err_msg = "Could not finish a transaction while deleting relation " || rtrim (rel_name) || "."; end; return; %page; /* * * * * * * * * * * unlink_relation * * * * * * * * * * * * * */ unlink_relation: proc (exists); dcl exists bit (1) parameter; dcl last_ua_ptr ptr; dcl record_buffer bit (72); prev_fi_ptr = null; /* Indicating db_model.file_ptr */ /* Look for rel_name in file_info linked list */ exists = "0"b; if db_model.file_ptr ^= NULL_OFFSET then do fi_ptr = ptr (dbm_ptr, db_model.file_ptr) repeat ptr (dbm_ptr, file_info.fwd_ptr) while (^exists & rel (fi_ptr) ^= NULL_OFFSET); if file_info.file_name = rel_name then do; /* Found the one were looking for */ exists = "1"b; saved_fi_ptr = fi_ptr; /* Pointer to one to be unlinked */ end; else prev_fi_ptr = fi_ptr; end; if ^exists then goto not_in_model; /* Relation was not linked into db_model */ next_fi_ptr_offset = saved_fi_ptr -> file_info.fwd_ptr; if ^cleanup_entry_point then call mdbm_util_$inconsistent_set (dbm_ptr, "delete_relation", "Deleting relation " || rel_name, "delete_relation " || rel_name || " -brief"); /* Indicate in all the attributes within this relation that they aren't referenced within this relation. If any of the attributes becomes unreferenced, create an unreferenced_attribute structure and link it into the list in db_model. */ if rmdb_ctl.crossref_file_info.iocb_ptr = null then do; call mdbm_util_$xref_build (rmdb_ctl.temp_dir_path, rmdb_ctl.absolute_db_path, dbm_ptr, rmdb_ctl.crossref_file_info.name, rmdb_ctl.crossref_file_info.iocb_ptr, long_err_msg, code); if code ^= 0 then call error (code, long_err_msg); end; not_in_model: xref_iocb_ptr = rmdb_ctl.crossref_file_info.iocb_ptr; if xref_iocb_ptr = null then return; file_model_name = rtrim (rel_name) || ".m"; call initiate_file_ (db_path, file_model_name, R_ACCESS, fm_ptr, (0), code); if code ^= 0 then if brief then do; exists = "0"b; return; end; else call error (code, "Initiating " || file_model_name); last_ua_ptr = null; ri_ptr = ptr (fm_ptr, rel_ptr); do ai_ptr = ptr (fm_ptr, rel_info.attr_ptr) repeat ptr (fm_ptr, attr_info.fwd_thread) while (rel (ai_ptr) ^= NULL_OFFSET); call mdbm_util_$xref_dereference (xref_iocb_ptr, ATTRIBUTE_KEY_HEAD, (attr_info.name), rel_name, reference_count, long_err_msg, code); if code ^= 0 then call error (code, long_err_msg); if reference_count = 0 then do; last_ua_ptr = null; do ua_ptr = ptr (dbm_ptr, db_model.unreferenced_attribute_ptr) repeat ptr (dbm_ptr, unreferenced_attribute.fwd_thread) while (rel (ua_ptr) ^= NULL_OFFSET); last_ua_ptr = ua_ptr; end; /* do last_ua_ptr */ /* Check to see if the domain name and attribute name are the same. If so, then this is a generated attribute and should not be added to the unreferenced attribute list. */ di_ptr = ptr (dbm_ptr, attr_info.domain_ptr); if domain_info.name = attr_info.name then do; /* This is a generated attribute. Check the domain reference count. If it is 1, then the domain becomes unreferenced. */ crossref_info_record_ptr = addr (record_buffer); call mdbm_util_$xref_find_record (xref_iocb_ptr, DOMAIN_KEY_HEAD, (domain_info.name), crossref_info_record_ptr, 8, long_err_msg, code); if code ^= 0 then call error (code, long_err_msg); if crossref_info_record.count = 1 /* 1 for the generated attribute */ then domain_info.unreferenced = "1"b; end; else do; /* it's a real attribute */ allocate unreferenced_attribute in (dbm_area) set (ua_ptr); unreferenced_attribute.name = attr_info.name; unreferenced_attribute.domain_ptr = attr_info.domain_ptr; unreferenced_attribute.unused (*) = NULL_OFFSET; unreferenced_attribute.fwd_thread = NULL_OFFSET; /* Link it on the end of the list */ if last_ua_ptr = null then db_model.unreferenced_attribute_ptr = rel (ua_ptr); else last_ua_ptr -> unreferenced_attribute.fwd_thread = rel (ua_ptr); end; end; end; /* do ai_ptr */ /* Unlink the file_info structure in db_model */ if ^exists then do; saved_fi_ptr = ptr (dbm_ptr, file_model.fi_ptr); free saved_fi_ptr -> file_info; exists = "1"b; return; end; if prev_fi_ptr = null then /* Incase it was first in list */ db_model.file_ptr = next_fi_ptr_offset; else prev_fi_ptr -> file_info.fwd_ptr = next_fi_ptr_offset; /* Link around current file_info structure */ db_model.num_unblk_files = db_model.num_unblk_files - 1; /* Just unlinked */ db_model.num_rels = db_model.num_rels - 1; if ^brief & code ^= 0 then call error (code, long_err_msg); /* Error code from rmdb_add_rmdb_history */ call mdbm_util_$xref_delete_record (xref_iocb_ptr, RELATION_KEY_HEAD, rel_name, long_err_msg, code); if (code ^= 0) & (code ^= error_table_$no_record) & (^brief) then call error (code, long_err_msg); free saved_fi_ptr -> file_info; /* Free unlinked file_info structure */ call adjust_bit_count_ ((db_path), "db_model", "1"b, bcnt, code); end unlink_relation; %page; /*********** * * These routines are used by the transaction processing include files. * Restore_significant_data is called to reinitialize variables in case * of a rollback. Should_rollback determines whether a transaction should * be rolled back or aborted on error. Currently, it is always aborted. * **********/ restore_significant_data: proc; end restore_significant_data; should_rollback: proc returns (bit (1)); return ("0"b); end should_rollback; %page; /* * * * * * * * * * * * * * * error * * * * * * * * * * * * * * */ error: proc (err_code, err_message); dcl err_code fixed bin (35); dcl err_message char (*); O_err_code = err_code; O_err_msg = err_message; goto exit; end error; %page; %include access_mode_values; %page; %include mdbm_db_model; %page; %include mdbm_file_model; %page; %include mrds_rmdb_ctl; %page; %include rmdb_crossref_info; %page; %include rmdb_delete_rel_info; %page; %include rmdb_history_entry; %page; %include terminate_file; %page; dcl addr builtin; dcl adjust_bit_count_ entry (char (168) aligned, char (32) aligned, bit (1) aligned, fixed bin (35), fixed bin (35)); dcl any_other condition; dcl based_char8 char (8) based; dcl bcnt fixed bin (35); dcl cleanup condition; dcl cleanup_entry_point bit (1); dcl code fixed bin (35); dcl db_path char (168); dcl error_table_$action_not_performed fixed bin (35) ext static; dcl error_table_$noentry fixed bin (35) ext static; dcl error_table_$no_record fixed bin(35) ext static; dcl error_table_$unimplemented_version fixed bin (35) ext static; dcl exists_in_db_model bit (1); dcl file_model_name char (32); dcl fixed builtin; dcl initiate_file_ entry (char(*), char(*), bit(*), ptr, fixed bin(24), fixed bin(35)); dcl long_err_msg char (500); dcl mdbm_util_$inconsistent_reset entry (ptr); dcl mdbm_util_$inconsistent_set entry (ptr, char (*), char (*), char (*)); dcl mdbm_util_$xref_build entry (char(*), char(*), ptr, char(*), ptr, char(*), fixed bin(35)); dcl mdbm_util_$xref_delete_record entry (ptr, char(*), char(*), char(*), fixed bin(35)); dcl mdbm_util_$xref_dereference entry (ptr, char(*), char(*), char(*), fixed bin (21), char(*), fixed bin(35)); dcl mdbm_util_$xref_find_record entry (ptr, char(*), char(*), ptr, fixed bin(21), char(*), fixed bin(35)); dcl mrds_error_$no_db_path fixed bin (35) ext static; dcl mrds_error_$no_model_rel fixed bin (35) ext static; dcl next_fi_ptr_offset bit (18); dcl null builtin; dcl NULL_OFFSET int static bit (18) unal init ((18)"1"b) options (constant); dcl prev_fi_ptr ptr; dcl ptr builtin; dcl quit condition; dcl quit_intercept_flag bit (1); dcl reference_count fixed bin (21); dcl rel builtin; dcl rel_name char (32); dcl rmdb_add_rmdb_history entry (ptr, fixed bin, char (32), fixed bin, char (32), char (500), fixed bin (35)); dcl rtrim builtin; dcl saved_fi_ptr ptr; dcl sys_info$max_seg_size fixed bin(35) ext static; dcl terminate_file_ entry (ptr, fixed bin(24), bit(*), fixed bin(35)); dcl xref_iocb_ptr ptr; end rmdb_delete_relation;  rmdb_execute_undo.pl1 10/23/86 1025.2rew 10/23/86 1008.0 61362 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ rmdb_execute_undo: execute_undo: proc (sci_ptr, request_name, db_path, db_model_ptr, incon_name, undo_request); /****^ HISTORY COMMENTS: 1) change(86-01-27,Spitzer), approve(86-01-27,MCR7311), audit(86-09-15,Gilcrease), install(86-10-16,MR12.0-1187): added call to rmdb_salvage_db. 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 entry name execute_undo so that display_mrds_dm can call this program through mrds_rst_ to clean things up when the user is trying to display the model. END HISTORY COMMENTS */ /* . BEGIN_DESCRIPTION This routine will query the user to find out if he wants the undo_request to be executed. If the answer is yes the undo request is executed and if the execution was ok the module returns to its caller. If the execution fails the database is freed, if it cannot be freed the subsystem is aborted. If the user indicates that the undo request should not be executed then the database is just freed, if it cannot be freed the subsystem is aborted. If the execution of the undo request fails or the user does not request its execution but the database was freed then the ssu request line is aborted. Note that if the subsystem or request line is aborted this module will not return to its caller. A message indicating that the database has been freed will be printed on the users terminal. This module should only be called if the currently readied database is inconsistent. . END_DESCRIPTION Known Bugs: . 1) ssu_$execute_string does not return if the execution fails Other Problems: . HISTORY 82-05-26 Davids: Written 82-06-23 Davids: removed call to get_shortest_path and declared . some explicitly declared builtins. 82-07-01 Roger Lackey : Modified the calls to mu_db_inconsistent to use mdbm_util_$inconsistent_* for binding. */ /* PARAMETERS */ dcl sci_ptr ptr; /* (input) just passing through */ dcl request_name char (32); /* (input) request being executed */ dcl db_path char (168); /* (input) absolute path of the readied database */ dcl db_model_ptr ptr; /* (input) pointer to the db_model seg of the readied database */ dcl incon_name char (32); /* (input) request name that caused the db to be inconsistent */ dcl undo_request char (100); /* (input) request that will make the db consistent */ /* AUTOMATIC */ dcl code fixed bin (35); /* standard error code */ dcl explanation char (300); /* explanatory text to the query */ dcl question char (300); /* initial query to user */ dcl answer char (3) varying; /* user's answer to the query (yes | no) */ /* EXTERNAL STATIC */ dcl error_table_$action_not_performed fixed bin (35) ext static; dcl iox_$user_input ptr ext static; dcl iox_$user_output ptr ext static; /* ENTRIES */ dcl command_query_ entry () options (variable); dcl mdbm_util_$inconsistent_reset entry (ptr); dcl rmdb_salvage_db entry (char (*)); dcl ssu_$abort_line entry () options (variable); dcl ssu_$abort_subsystem entry () options (variable); dcl ssu_$execute_string entry (ptr, char (*), fixed bin (35)); dcl ssu_et_$null_request_line fixed bin(35) ext static; /* BUILTINS */ dcl addr builtin; dcl length builtin; dcl null builtin; dcl rtrim builtin; /* INCLUDES */ %page; %include query_info; if undo_request = "" then explanation = "^/The database is inconsistent because the operation:" || "^/^-^a^s^/was interrupted. The database must be made consistent" || "^/in order to perform additional restructuring requests. " || "^/^/Do you wish to continue ?"; else explanation = "^/The database is inconsistent because the operation:" || "^/^-^a^s^/was interrupted. In order to undo the effects of this" || "^/the request ""^a"" must be executed." || "^/Until the database is made consistent it may not be restructured." || "^/^/Do you wish to run the request ?"; query_info.version = query_info_version_5; query_info.switches.yes_or_no_sw = "1"b; query_info.switches.suppress_name_sw = "0"b; query_info.switches.cp_escape_control = "00"b; query_info.switches.suppress_spacing = "0"b; query_info.switches.padding = "0"b; query_info.status_code = 0; query_info.query_code = 0; query_info.question_iocbp = iox_$user_output; query_info.answer_iocbp = iox_$user_input; query_info.repeat_time = 0; query_info.explanation_ptr = addr (explanation); query_info.explanation_len = length (rtrim (explanation)); if undo_request = "" then question = "^/The database ^s^a is inconsistent. " || "^/In order to ready or restructure the database it must first be made consistent." || "^/^/Do you wish to continue ?"; else question = "^/The database ^s^a is inconsistent. " || "^/In order to ready or restructure the database the following " || "^/request which will make the database consistent must be run:" || "^/^-^a^/Do you wish to run it ?"; call command_query_ (addr (query_info), answer, request_name, rtrim(question), incon_name, db_path, undo_request); if answer = "yes" then do; call rmdb_salvage_db (db_path); call ssu_$execute_string (sci_ptr, rtrim (undo_request), code); if (code ^= 0 & code ^= ssu_et_$null_request_line) then do; call ssu_$execute_string (sci_ptr, "free_db", code); if code ^= 0 then call ssu_$abort_subsystem (sci_ptr, code, "Execution of the undo request failed and the db could not be freed."); call ssu_$abort_line (sci_ptr, code, "Execution of the undo request failed, the database has been freed"); end; else call mdbm_util_$inconsistent_reset (db_model_ptr); end; else do; call ssu_$execute_string (sci_ptr, "free_db", code); if code ^= 0 then call ssu_$abort_subsystem (sci_ptr, code, "Could not free the database"); call ssu_$abort_line (sci_ptr, error_table_$action_not_performed, "^/The database is inconsistent and therefore may not be restructured, it has been freed."); end; end rmdb_execute_undo;  rmdb_free_db.pl1 04/18/85 1454.7r w 04/18/85 0909.5 25623 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ rmdb_free_db: proc (absolute_db_path, saved_res_version_ptr, error_message, code); /* . BEGIN_DESCRIPTION This procedure calls mu_quiesce to unquiesce the db and create_copy_res to create an updated version of the saved resultant. It is a separate routine instead of part of the close_db_request so that there is a subroutine level interface independent of the subsystem. . END_DESCRIPTION Known Bugs: Other Problems: . HISTORY 82-03-23 Davids: Written 82-05-26 Davids: changed to be compatable with the new . mdbm_util_$quiesce_free calling sequence. 82-06-23 Davids: removed declared but unused builtins 82-07-01 Roger Lackey : Changed mu_quiesce$ to mdbm_util_$quisce_ for binding. 83-05-24 Davids: Added the saved_res_version_ptr parameter. Also it now checks the saved_res_version and if its not what it is suppose to be it creates a new saved res. /* PARAMETERS */ dcl absolute_db_path char (168); /* (input) data base path */ dcl saved_res_version_ptr ptr; /* (input) pointer to the saved_res_version */ dcl error_message char (500); /* (output) text of error message in case of problems */ dcl code fixed bin (35); /* (output) standard error code */ /* BASED */ dcl based_char8 char (8) based; /* overlay for saved_res_version */ /* ENTRIES */ dcl dsl_$create_res_copy entry options (variable); dcl ioa_$rs entry () options (variable); dcl mdbm_util_$quiesce_free entry (char (168), fixed bin (35)); /* EXTERNAL STATIC */ dcl mrds_data_$saved_res_version char (8) external static; /* BUILTINS */ dcl length builtin; /* Initialize the output parameters */ code = 0; error_message = ""; /* Create an upto date saved resultant and unquiesce the data base */ if saved_res_version_ptr -> based_char8 ^= mrds_data_$saved_res_version then do; call dsl_$create_res_copy (absolute_db_path, code); if code ^= 0 then do; call ioa_$rs ("Could not create a resultant copy for the database ^a, database not freed", error_message, length (error_message), absolute_db_path); goto exit_rmdb_free_db; end; end; call mdbm_util_$quiesce_free (absolute_db_path, code); if code ^= 0 then call ioa_$rs ("The database ^a cannot be unquiesced", error_message, length (error_message), absolute_db_path); exit_rmdb_free_db: return; end rmdb_free_db;  rmdb_init_file_model.pl1 10/16/86 1551.9r w 10/16/86 1143.8 25254 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ rmdb_init_file_model: proc (I_dbm_ptr, I_fm_ptr, O_err_msg, O_err_code); /* BEGIN_DESCRIPTION This procedure provided a pointer to the segment to be used as the file_model initializes the file_model structure and the associated rel_info structure. END_DESCRIPTION */ /* HISTORY 82-06-01 Create by Roger Lackey */ dcl I_dbm_ptr pointer parameter; /* Pointer to db_model */ dcl I_fm_ptr pointer parameter; /* Pointer to based of file_model seg */ dcl O_err_msg char (*) parameter;/* Text of returned error message */ dcl O_err_code fixed bin (35) parameter; /* Error code */ O_err_msg = ""; O_err_code = 0; dbm_ptr = I_dbm_ptr; fm_ptr = I_fm_ptr; /* Derive file_name from fm_ptr (file_model segment pointer) */ call hcs_$fs_get_path_name (fm_ptr, dir, ldn, file_name, code); if code ^= 0 then do; O_err_msg = "Getting file_model_pathname "; O_err_code = code; return; end; rel_name = before (file_name, ".m"); /* Rel_name is file name without the .m suffix */ %page; like_file_model = init_file_model; /* initialize all but file_model area */ file_model.fm_area = empty (); /* initialize file_model area */ file_model.changer_ptr = db_model.changer_ptr; call load_rel_info; exit: return; %page; /* * * * * * * * * * * * * * * * load_rel_info * * * * * * * * * * */ 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 */ allocate rel_info in (fm_area) set (ri_ptr); file_model.rel_ptr = rel (ri_ptr); /* initialize relation detailed information */ rel_info = init_rel_info; /* copy template */ rel_info.name = rel_name; rel_info.changer_ptr = db_model.changer_ptr; end load_rel_info; %page; dcl addr builtin; dcl before builtin; dcl code fixed bin (35); dcl dir char (168); dcl empty builtin; dcl file_name char (32); dcl fixed builtin; dcl hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35)); dcl ldn fixed bin; dcl rel builtin; dcl rel_name char (32); dcl sys_info$max_seg_size fixed bin (35) external; /* system constant */ %page; %include mdbm_file_model; %page; %include mdbm_file_model_init; %page; %include mdbm_db_model; end rmdb_init_file_model;  rmdb_ready_db.pl1 08/01/88 1435.5r w 08/01/88 1315.0 116496 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ rmdb_ready_db: proc (db_path, quiesce_wait_time, entries_str_ptr, absolute_db_path, db_model_ptr, saved_res_version_ptr, error_message, code); /****^ HISTORY COMMENTS: 1) change(86-01-28,Spitzer), approve(86-01-28,MCR7311), audit(86-09-15,Gilcrease), install(86-10-16,MR12.0-1187): add initialization for relmgr_entries.(put_tuple get_tuples_by_spec). 2) change(86-08-21,Blair), approve(86-08-21,MCR7311), audit(86-09-15,Gilcrease), install(86-10-16,MR12.0-1187): Back out the entry points get_tuples_by_spec and put_tuples as they haven't been sufficiently tested to be reliable. Put in get_tuple_id and get_tuple_by_id. END HISTORY COMMENTS */ /* . BEGIN_DESCRIPTION This module quiesces a data base in preparation for its being restructured and checks to be sure that the data base can be restructured by the caller. It also returns to the caller the absolute path of the data base and a pointer to the db_model for the database and a pointer the the version of the saved res. The restrictions are: . only a data base may be restructured - the path cannot . refer to a submodel. . only a version 4 or latter data base may be restructured . the caller must be a DBA for the data base . END_DESCRIPTION Known Bugs: Other Problems: . HISTORY 82-03-22 Davids: Written 82-05-25 Davids: added code to initiate a pointer to the db_model . segment and return it to the caller. 82-05-26 Davids: changed to be compatable with the new . mu_quiesce$quiesce_quiet calling sequence. 82-05-26 Roger Lackey: changed mrds_dsl_get_version$get_path_info to dsl_$get_path_info for binding and mu_quiesce$quiesce_quiet to mdbm_util_$quiesce_quiet 82-08-20 Davids: added entries_str_ptr to the parameter list, included the rmdb_relmgr_entries and mdbm_db_model include files and added code to set the values of the relmgr entries to the correct relation_manager based on the database type. 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-05-24 Davids: Added code to initiate the saved rdbi segment and return a pointer to the saved_res_version element. 83-10-04 Benjamin: Changed hcs_$initiate calls to initiate_file_. 84-10-23 Benjamin: Changed to not abort when mu_quiesce returns mrds_error_$my_quiesced_db. */ /* PARAMETERS */ dcl db_path char (168); /* (input) data base path reative or absolute */ dcl quiesce_wait_time fixed bin; /* (input) length of time to wait before giving up tring to quiesce the data base */ dcl entries_str_ptr ptr; /* (input) pointer to the relmgr_entries structure whose elements will be set by this procedure */ dcl absolute_db_path char (168); /* (output) absoulte path of the data base */ dcl db_model_ptr ptr; /* (output) pointer to the db_model segment of the database */ dcl saved_res_version_ptr ptr; /* (output) pointer the saved_res_version element of the saved rdbi segment */ dcl error_message char (500); /* (output) text of error message in case of problems */ dcl code fixed bin (35); /* (output) standard error code */ /* EXTERNAL STATIC */ dcl error_table_$action_not_performed fixed bin (35) external static; dcl error_table_$no_dir fixed bin (35) ext static; dcl mrds_error_$my_quiesced_db fixed bin (35) ext static; dcl sys_info$max_seg_size fixed bin (35) external static; /* ENTRIES */ dcl vfile_relmgr_$close entry (bit (36) aligned, fixed bin (35)); dcl vfile_relmgr_$create_index entry (bit (36) aligned, ptr, bit (36) aligned, fixed bin, bit (36) aligned, fixed bin (35)); dcl vfile_relmgr_$create_MRDS_relation entry (char (*), char (*), ptr, ptr, bit (36) aligned, bit (36) aligned, fixed bin (35)); dcl vfile_relmgr_$destroy_index entry (bit (36) aligned, bit (36) aligned, fixed bin (35)); dcl vfile_relmgr_$destroy_relation_by_path entry (char (*), char (*), fixed bin (35)); dcl vfile_relmgr_$open entry (char (*), char (*), bit (36) aligned, fixed bin (35)); dcl vfile_relmgr_$put_tuple entry (ptr, ptr, bit (36) aligned, fixed bin(35)); dcl vfile_relmgr_$create_cursor entry (bit(36) aligned, ptr, ptr, fixed bin(35)); dcl vfile_relmgr_$get_tuple_id entry (ptr, ptr, ptr, ptr, fixed bin (35)); dcl vfile_relmgr_$get_tuple_by_id entry (ptr, bit (36) aligned, ptr, ptr, ptr, fixed bin (35)); dcl relation_manager_$close entry (bit (36) aligned, fixed bin (35)); dcl relation_manager_$create_index entry (bit (36) aligned, ptr, bit (36) aligned, fixed bin, bit (36) aligned, fixed bin (35)); dcl relation_manager_$create_relation entry (char (*), char (*), ptr, ptr, bit (36) aligned, bit (36) aligned, fixed bin (35)); dcl relation_manager_$destroy_index entry (bit (36) aligned, bit (36) aligned, fixed bin (35)); dcl relation_manager_$destroy_relation_by_path entry (char (*), char (*), fixed bin (35)); dcl relation_manager_$open entry (char (*), char (*), bit (36) aligned, fixed bin (35)); dcl relation_manager_$put_tuple entry (ptr, ptr, bit (36) aligned, fixed bin(35)); dcl relation_manager_$create_cursor entry (bit(36) aligned, ptr, ptr, fixed bin(35)); dcl relation_manager_$get_tuple_id entry (ptr, ptr, ptr, ptr, fixed bin (35)); dcl relation_manager_$get_tuple_by_id entry (ptr, bit (36) aligned, ptr, ptr, ptr, fixed bin (35)); dcl ioa_$rs entry () options (variable); dcl initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35)); dcl mdbm_util_$get_user_class entry (char (*), ptr, fixed bin, ptr, fixed bin (35)); dcl dsl_$get_path_info entry (char (*), ptr, fixed bin, ptr, fixed bin (35)); dcl dsl_$create_res_copy entry options (variable); dcl mdbm_util_$quiesce_quiet entry (char (168), fixed bin, fixed bin (35)); /* INTERNAL AUTOMATIC */ dcl area area (500); /* local working area for structures to be allocated in */ dcl bit_count fixed bin (24); /* required in calls to initiate_file_ */ dcl local_db_model_ptr ptr; /* local copy of the pointer to the db_model seg */ dcl saved_rdbi_ptr ptr; /* pointer the the rm_db_info structure in the rdbi segment */ /* BUILTINS */ dcl addr builtin; dcl empty builtin; dcl fixed builtin; dcl length builtin; dcl null builtin; dcl rel builtin; dcl rtrim builtin; /* INCLUDE FILES */ %page; %include mrds_authorization; %page; %include mrds_path_info; %page; %include rmdb_relmgr_entries; %page; %include mdbm_db_model; %page; %include mdbm_rm_db_info; %page; %include access_mode_values; /* Initialize the output parameters */ absolute_db_path = ""; db_model_ptr = null (); code = 0; error_message = ""; /* use the pointer declared in with rmdb_relmgr_entries */ rmdb_relmgr_entries_ptr = entries_str_ptr; /* Determine if the input path refers to a data base model or a submodel. If a submodel return an error. Also determine the data bases's version of its version 3 or earlier return an error (restructuring can not be supported by models eariler than version 4). */ call dsl_$get_path_info (db_path, addr (area), mrds_path_info_structure_version, mrds_path_info_ptr, code); if code ^= 0 then do; call ioa_$rs ("Could not get database path info for ^a", error_message, length (error_message), db_path); goto exit_rmdb_ready_db; end; if mrds_path_info.type.submodel then do; code = error_table_$action_not_performed; error_message = "Submodels may not be restructured"; goto exit_rmdb_ready_db; end; if mrds_path_info.mrds_version <= 3 then do; code = error_table_$action_not_performed; error_message = "Version 3 and eariler data bases may not be restructured"; goto exit_rmdb_ready_db; end; /* Determine the authorization of the caller, if he is not a DBA return an error. */ call mdbm_util_$get_user_class ((mrds_path_info.absolute_path), addr (area), mrds_authorization_structure_version, mrds_authorization_ptr, code); if code ^= 0 then do; call ioa_$rs ("Unable to determine if you are a DBA for ^a", error_message, length (error_message), mrds_path_info.absolute_path); goto exit_rmdb_ready_db; end; if ^mrds_authorization.administrator then do; code = error_table_$action_not_performed; error_message = "Only a data base's DBA may restructure the data base"; goto exit_rmdb_ready_db; end; /* initiate a pointer to the db_model segment of the database so that it is available for the other requests. the output parameter will be set after the database is quiesced. */ local_db_model_ptr = null (); call initiate_file_ ((mrds_path_info.absolute_path), "db_model", RW_ACCESS, local_db_model_ptr, bit_count, code); if local_db_model_ptr = null () then do; error_message = "Could not initiate the db_model segment"; goto exit_rmdb_ready_db; end; /* Get a pointer to the saved_res_version value. If there is no saved resultant - create one */ call initiate_file_ (rtrim (mrds_path_info.absolute_path) || ">resultant_segs.dir", "rdbi", RW_ACCESS, saved_rdbi_ptr, bit_count, code); if code = error_table_$no_dir then do; /* create the saved resultant */ call dsl_$create_res_copy (mrds_path_info.absolute_path, code); if code ^= 0 then do; error_message = "Could not create and save a copy of the resultant."; goto exit_rmdb_ready_db; end; call initiate_file_ (rtrim (mrds_path_info.absolute_path) || ">resultant_segs.dir", "rdbi", RW_ACCESS, saved_rdbi_ptr, bit_count, code); end; if saved_rdbi_ptr = null () then do; error_message = "Could not initiate the saved resultant segment rdbi."; goto exit_rmdb_ready_db; end; saved_res_version_ptr = addr (saved_rdbi_ptr -> rm_db_info.saved_res_version); /* Quiesce the database. */ call mdbm_util_$quiesce_quiet ((mrds_path_info.absolute_path), quiesce_wait_time, code); if code ^= 0 & code ^= mrds_error_$my_quiesced_db then do; error_message = "The data base could not be quiesced."; goto exit_rmdb_ready_db; end; /* Setup the relation_manager entries that correspond with the type of database being opened. */ if local_db_model_ptr -> db_model.db_type_flags.vfile_type then do; rmdb_relmgr_entries.create_relation = vfile_relmgr_$create_MRDS_relation; rmdb_relmgr_entries.delete_relation = vfile_relmgr_$destroy_relation_by_path; rmdb_relmgr_entries.open = vfile_relmgr_$open; rmdb_relmgr_entries.close = vfile_relmgr_$close; rmdb_relmgr_entries.create_index = vfile_relmgr_$create_index; rmdb_relmgr_entries.delete_index = vfile_relmgr_$destroy_index; rmdb_relmgr_entries.put_tuple = vfile_relmgr_$put_tuple; rmdb_relmgr_entries.create_cursor = vfile_relmgr_$create_cursor; rmdb_relmgr_entries.get_tuple_id = vfile_relmgr_$get_tuple_id; rmdb_relmgr_entries.get_tuple_by_id = vfile_relmgr_$get_tuple_by_id; end; else do; /* dm_file database */ rmdb_relmgr_entries.create_relation = relation_manager_$create_relation; rmdb_relmgr_entries.delete_relation = relation_manager_$destroy_relation_by_path; rmdb_relmgr_entries.open = relation_manager_$open; rmdb_relmgr_entries.close = relation_manager_$close; rmdb_relmgr_entries.create_index = relation_manager_$create_index; rmdb_relmgr_entries.delete_index = relation_manager_$destroy_index; rmdb_relmgr_entries.put_tuple = relation_manager_$put_tuple; rmdb_relmgr_entries.create_cursor = relation_manager_$create_cursor; rmdb_relmgr_entries.get_tuple_id = relation_manager_$get_tuple_id; rmdb_relmgr_entries.get_tuple_by_id = relation_manager_$get_tuple_by_id; end; /* Since everything worked ok we can set the value of absolute_db_path and the db_model_ptr. */ absolute_db_path = mrds_path_info.absolute_path; db_model_ptr = local_db_model_ptr; exit_rmdb_ready_db: return; end rmdb_ready_db;  rmdb_relations_used.pl1 10/16/86 1532.8rew 10/16/86 1531.2 132255 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1986 * * * *********************************************************** */ /* format: ^inddcls,^indattr,indnoniterend,^indnoniterdo,indend,tree,^case,insnl,comcol61,dclind5,declareind5,delnl */ /*DESCRIPTION Given a list of objects to delete (domains or attributes, depending upon which entry point into this subroutine is used), this subroutine creates a list of relations that are used along with a per-relation list of attributes to be deleted in that relation. This list is then used in another subroutine to create a new copy of those relations without the specified attributes. The information to prepare these lists comes from the temporary crossreference vfile. */ /****^ HISTORY COMMENTS: 1) change(86-01-14,Spitzer), approve(86-01-14,MCR7311), audit(86-09-15,Gilcrease), install(86-10-16,MR12.0-1187): written END HISTORY COMMENTS */ rmdb_relations_used: proc; return; /* not an entry point */ rmdb_relations_used$domains: entry (Irmdb_ctl_ptr, Idelete_object_info_ptr, Iarea_ptr, Odomain_list_ptr, Oattribute_list_ptr, Orelation_list_ptr, Oerror_message, Ocode); domain_entry = "1"b; goto COMMON; rmdb_relations_used$attributes: entry (Irmdb_ctl_ptr, Idelete_object_info_ptr, Iarea_ptr, Odomain_list_ptr, Oattribute_list_ptr, Orelation_list_ptr, Oerror_message, Ocode); domain_entry = "0"b; goto COMMON; COMMON: /* copy input variables */ rmdb_ctl_ptr = Irmdb_ctl_ptr; delete_object_info_ptr = Idelete_object_info_ptr; user_area_ptr = Iarea_ptr; /* initialize output variables */ Odomain_list_ptr, Oattribute_list_ptr, Orelation_list_ptr = null; Oerror_message = ""; Ocode = 0; temp_ptrs (*) = null; max_seg_size = sys_info$max_seg_size * 4; db_path = rmdb_ctl.absolute_db_path; local_iocb = rmdb_ctl.crossref_file_info.iocb_ptr; on cleanup call cleaner; call mdbm_util_$get_temp_segments_path (rmdb_ctl.temp_dir_path, myname, temp_ptrs, code); if code ^= 0 then do; error_message = "Cannot get a temp segment in " || rtrim(rmdb_ctl.temp_dir_path) || "."; call error (code, error_message); end; /* use the 1st temp segment for reading records from the crossref file */ crossref_info_record_ptr = temp_ptrs (1); /* Since we are now going to allocate lots of structures in the user area, set up an area condition so we can return some intelligent error message if we overflow it. */ on area call error (error_table_$area_too_small, "Input user area."); if domain_entry then do; /* create and fill the domain_list structure */ domain_list_count = delete_object_info.count; allocate domain_list in (user_area) set (domain_list_ptr); do domain_idx = 1 to domain_list_count; /* Get the domain record from the crossreference file */ call mdbm_util_$xref_find_record (local_iocb, DOMAIN_KEY_HEAD, delete_object_info.name (domain_idx), crossref_info_record_ptr, max_seg_size, error_message, code); if code ^= 0 then if code = error_table_$no_record then call error (mrds_error_$no_model_dom, delete_object_info.name (domain_idx)); else call error (code, error_message); /* It's there, fill in the domain_list entry */ domain_list.name (domain_idx) = make_name (delete_object_info.name (domain_idx)); /* Create this domain's corresponding attribute_list structure (the list of attributes that are used by this domain). If the domain is unreferenced, this ptr will be set to null. */ if crossref_info_record.count = 0 then attribute_list_ptr = null; else do; attribute_list_count = crossref_info_record.count; allocate attribute_list in (user_area) set (attribute_list_ptr); /* Fill in the attribute_list structure for this domain. This will contain the list of attributes used within a single specific domain. */ do attribute_list_idx = 1 to attribute_list_count; attribute_list.name (attribute_list_idx) = make_name (crossref_info_record.object (attribute_list_idx)); end; /* do attribute_list_idx */ end; domain_list.attribute_list_ptr (domain_idx) = attribute_list_ptr; end; /* do domain_idx */ end; /* if domain_entry */ else do; /* must have entered through the attribute EP */ /* Indicate there is no domain_list structure when entered through the domain entry point. */ domain_list_ptr = null; /* Create the attribute_list structure. */ attribute_list_count = delete_object_info.count; allocate attribute_list in (user_area) set (attribute_list_ptr); /* Populate the attribute_list structure with the objects from the delete_object_info structure. */ do attribute_list_idx = 1 to attribute_list_count; attribute_list.name (attribute_list_idx) = make_name (delete_object_info.name (attribute_list_idx)); attribute_list.attribute_ptr (attribute_list_idx) = null; end; /* do attribute_list_idx */ end; /* Process the attribute_list structure, producing the list of relations used in all the specified attributes. The list of unique relations is built upon a temp segment and then copied into an allocated structure, as we don't know a priori how many relations there will be. */ relation_list_ptr = temp_ptrs (2); if domain_entry then do domain_idx = 1 to domain_list.count; attribute_list_ptr = domain_list.attribute_list_ptr (domain_idx); call get_relation_names; end; /* do domain_idx */ else call get_relation_names; /* Create the relation_list structure that is to be returned to the caller. */ relation_list_count = relation_list.count; allocate relation_list in (user_area) set (relation_list_ptr); /* Copy the contents of the temp_ptrs (2) -> relation_list.name into relation_list_ptr -> relation_list.name. */ relation_list_ptr -> relation_list.name = temp_ptrs (2) -> relation_list.name; /* Now process the relation_list structure. We have to initiate the relation.m segments and create a relation structure for each referenced relation. Note that we don't have to terminate the segments because we will 1) leave the pointer to it in the relation structure, and 2) we will shortly delete the segment anyway. */ do relation_idx = 1 to relation_list.count; relation_model_name = rtrim (unmake_name (relation_list.name (relation_idx))) || ".m"; call initiate_file_ (db_path, relation_model_name, RW_ACCESS, fm_ptr, (0), code); if code ^= 0 then call error (code, "Initiating " || pathname_ (db_path, relation_model_name)); /* Get attribute count of this relation from the relation_info structure in the file_model. */ ri_ptr = ptr (fm_ptr, file_model.rel_ptr); relation_attribute_count = rel_info.num_attr; /* Create and populate the relation structure for this relation. */ allocate relation in (user_area) set (relation_ptr); relation.name = unmake_name (relation_list.name (relation_idx)); relation.file_model_ptr = fm_ptr; relation_list.relation_ptr (relation_idx) = relation_ptr; /* Fill in the list of attributes in this relation. */ ai_ptr = ptr (fm_ptr, rel_info.attr_ptr); do attribute_idx = 1 to relation_attribute_count; unspec (relation.attribute (attribute_idx).flags) = "0"b; relation.attribute.attribute_info_ptr (attribute_idx) = ai_ptr; relation.attribute.domain_info_ptr (attribute_idx) = attr_info.domain_ptr; relation.attribute_names (attribute_idx) = make_name ((attr_info.name)); relation.attribute.flags.part_of_key (attribute_idx) = attr_info.key_attr; ai_ptr = ptr (fm_ptr, attr_info.fwd_thread); end; /* do attribute_idx */ end; /* relation_idx */ /* Finally, we need to turn on the delete flag for each attribute in each referenced relation that is to be deleted. */ if domain_entry then do domain_idx = 1 to domain_list.count; attribute_list_ptr = domain_list.attribute_list_ptr (domain_idx); call mark_deleted_attributes; end; /* do domain_idx */ else call mark_deleted_attributes; /* Return the pointers to the structures we have just generated. */ Orelation_list_ptr = relation_list_ptr; Oattribute_list_ptr = attribute_list_ptr; Odomain_list_ptr = domain_list_ptr; call error (0, ""); %page; make_name: proc (input_name) returns (char (33)); dcl input_name char (*) parameter; return (OBJECT_HEAD || input_name); end make_name; unmake_name: proc (input_name) returns (char (32)); dcl input_name char (33) parameter; return (substr (input_name, 2, 32)); end unmake_name; %page; /* Process the current attribute_list structure: retrieve the attribute crossreference record for each attribute (this contains the list of relations that the attribute is used within). Search the relation_list structure for each relation. If it is not found, add the relation to the end of the relation_list. Then place the index of that relation in the attribute structure. */ get_relation_names: proc; dcl attribute_name char (32); dcl search_name char (33); dcl position fixed bin; do attribute_list_idx = 1 to attribute_list.count; attribute_name =unmake_name (attribute_list.name (attribute_list_idx)); call mdbm_util_$xref_find_record (local_iocb, ATTRIBUTE_KEY_HEAD, attribute_name, crossref_info_record_ptr, max_seg_size, error_message, code); if code ^= 0 then if code = error_table_$no_record then call error (mrds_error_$no_model_attr, attribute_name); else call error (code, error_message); if crossref_info_record.count = 0 then attribute_list.attribute_ptr (attribute_list_idx) = null; else do; /* Create the attribute structure. */ attribute_count = crossref_info_record.count; allocate attribute in (user_area) set (attribute_ptr); /* Each relation in the current crossref_info_record contains the attribute that we are processing now. Place the index of each referenced relation (in the relation_list structure) in the attribute structure. */ do attribute_idx = 1 to attribute_count; search_name = substr (crossref_info_record_objects, 1 + (33 * (attribute_idx - 1)), 33); position = index (relation_list_names, search_name); if position = 0 then do; /* add it on the end */ position, relation_list.count = relation_list.count + 1; relation_list.name (position) = search_name; end; else position = divide (position, 33, 17, 0) + 1; attribute.relation_idx (attribute_idx) = position; end; /* do attribute_idx */ attribute_list.attribute_ptr (attribute_list_idx) = attribute_ptr; end; attribute_list.domain_info_ptr (attribute_list_idx) = crossref_info_record.offset; end; /* do attribute_list_idx */ return; end get_relation_names; %page; /*DESCRIPTION Take the list pointed to by the current attribute_list_ptr, processing it by marking all attributes in the referenced relation to be deleted. */ mark_deleted_attributes: proc; dcl position fixed bin; dcl search_name char (33); do attribute_list_idx = 1 to attribute_list.count; attribute_ptr = attribute_list.attribute_ptr (attribute_list_idx); if attribute_ptr ^= null then do; /* the attribute was referenced in at least a single relation */ search_name = attribute_list.name (attribute_list_idx); do attribute_idx = 1 to attribute.count; relation_ptr = relation_list.relation_ptr (attribute.relation_idx (attribute_idx)); position = index (relation_attribute_names, search_name); if position ^= 0 then do; /* found the place, mark the attribute to be deleted */ position = divide (position, 33, 17, 0) + 1; relation.attribute (position).flags.delete = "1"b; end; end; /* do attribute_idx */ end; end; /* do attribute_list_idx */ return; end mark_deleted_attributes; %page; /*DESCRIPTION Error handler and cleanup handler. This is the only way to exit these subroutines. */ error: proc (code, msg); dcl code fixed bin (35) parameter; dcl msg char (*) parameter; Ocode = code; Oerror_message = msg; goto RETURN_TO_CALLER; end error; RETURN_TO_CALLER: call cleaner; return; cleaner: proc; dcl cleaner_code fixed bin (35); if temp_ptrs (1) ^= null then call mdbm_util_$free_temp_segments (myname, temp_ptrs, cleaner_code); return; end cleaner; %page; %include access_mode_values; %include mdbm_db_model; %include mdbm_file_model; %include mrds_rmdb_ctl; %include rmdb_crossref_info; %include rmdb_delete_object_info; %page; dcl addr builtin; dcl area condition; dcl attribute_idx fixed bin; dcl attribute_list_idx fixed bin; dcl cleanup condition; dcl code fixed bin (35); dcl divide builtin; dcl db_path char (168); dcl domain_entry bit (1) aligned; dcl domain_idx fixed bin; dcl error_message char (500); dcl error_table_$area_too_small fixed bin (35) ext static; dcl error_table_$no_record fixed bin(35) ext static; dcl fixed builtin; dcl Iarea_ptr ptr parameter; dcl Idelete_object_info_ptr ptr parameter; dcl index builtin; dcl initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35)); dcl Irmdb_ctl_ptr ptr parameter; dcl local_iocb ptr; /* -> IOCB for crossref file */ dcl max_seg_size fixed bin (21); dcl mrds_error_$no_model_attr fixed bin(35) ext static; dcl mrds_error_$no_model_dom fixed bin(35) ext static; dcl myname char (32) int static options (constant) init ("rmdb"); dcl null builtin; dcl Oattribute_list_ptr ptr parameter; dcl Ocode fixed bin (35) parameter; dcl Odomain_list_ptr ptr parameter; dcl Oerror_message char (*) parameter; dcl Orelation_list_ptr ptr parameter; dcl pathname_ entry (char (*), char (*)) returns (char (168)); dcl ptr builtin; dcl rel builtin; dcl relation_idx fixed bin; dcl relation_model_name char (32); dcl mdbm_util_$get_temp_segments_path entry (char (*), char (*), (*) ptr, fixed bin (35)); dcl mdbm_util_$free_temp_segments entry (char (*), (*) ptr, fixed bin (35)); dcl mdbm_util_$xref_find_record entry (ptr, char (*), char (*), ptr, fixed bin (21), char (*), fixed bin (35)); dcl rtrim builtin; dcl substr builtin; dcl sys_info$max_seg_size fixed bin (35) ext static; dcl temp_ptrs (2) ptr; dcl unspec builtin; dcl user_area area based (user_area_ptr); dcl user_area_ptr ptr; end rmdb_relations_used;  rmdb_rename.pl1 10/16/86 1532.8rew 10/16/86 1531.2 258426 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1985 * * * *********************************************************** */ /* format: ^inddcls,^indattr,indnoniterend,^indnoniterdo,indend,tree,^case,insnl,comcol61,dclind5,declareind5,delnl */ /*DESCRIPTION This subroutine implements renaming of domains, attributes and relation. */ /****^ HISTORY COMMENTS: 1) change(85-12-03,Spitzer), approve(85-12-03,MCR7311), audit(86-09-15,Gilcrease), install(86-10-16,MR12.0-1187): written END HISTORY COMMENTS */ rmdb_rename: proc (Irmdb_ctl_ptr, Irename_object_info_ptr, Oerror_message, Ocode); rmdb_ctl_ptr = Irmdb_ctl_ptr; rename_object_info_ptr = Irename_object_info_ptr; local_iocb = rmdb_ctl.crossref_file_info.iocb_ptr; dbm_ptr = rmdb_ctl.db_model_ptr; if rename_object_info.version ^= rename_object_info_version_1 then call error (error_table_$unimplemented_version, "Version " || rename_object_info.version || " for the rename_object_info structure."); if /* case */ rename_object_info.type = RENAME_ATTRIBUTE then do; rename_entry = rename_attribute; key_head = ATTRIBUTE_KEY_HEAD; end; else if rename_object_info.type = RENAME_DOMAIN then do; rename_entry = rename_domain; key_head = DOMAIN_KEY_HEAD; end; else if rename_object_info.type = RENAME_RELATION then do; rename_entry = rename_relation; key_head = RELATION_KEY_HEAD; end; else call error (mrds_error_$internal_error, "Rename operation of type " || ltrim (char (rename_object_info.type))); if local_iocb = null then do; call mdbm_util_$xref_build (rmdb_ctl.temp_dir_path, rmdb_ctl.absolute_db_path, dbm_ptr, rmdb_ctl.crossref_file_info.name, local_iocb, error_message, code); if code ^= 0 then call error (code, error_message); rmdb_ctl.crossref_file_info.iocb_ptr = local_iocb; end; max_seg_size = sys_info$max_seg_size * 4; tempp, fm_ptr = null; on cleanup call cleaner; /* Verify all of the input arguments. See that all the from names are there and all the to names aren't. */ do loop = 1 to rename_object_info.count; call mdbm_util_$xref_find_record (local_iocb, rtrim (key_head), rename_object_info.from (loop), null, 0, error_message, code); if code ^= 0 then if code = error_table_$no_record then do; if rename_object_info.type = RENAME_ATTRIBUTE then code = mrds_error_$no_model_attr; else if rename_object_info.type = RENAME_DOMAIN then code = mrds_error_$no_model_dom; else code = mrds_error_$no_model_rel; call error (code, rename_object_info.from (loop)); end; else call error (code, error_message); call mdbm_util_$xref_find_record (local_iocb, rtrim (key_head), rename_object_info.to (loop), null, 0, error_message, code); if code = 0 then do; if rename_object_info.type = RENAME_ATTRIBUTE then code = mrds_error_$attr_already_exists; else if rename_object_info.type = RENAME_DOMAIN then code = mrds_error_$domain_already_defined; else code = mrds_error_$dup_rel; call error (code, rename_object_info.to (loop)); end; else if code ^= error_table_$no_record then call error (code, error_message); end; /* do loop */ call mdbm_util_$get_temp_segment_path (rmdb_ctl.temp_dir_path, myname, tempp, code); if code ^= 0 then call error (code, "Unable to get temp segments."); /* Actually rename the suckers now. */ do loop = 1 to rename_object_info.count; call rename_entry (rename_object_info.from (loop), rename_object_info.to (loop)); end; /* do loop */ call cleaner; call error (0, ""); RETURN_TO_CALLER: return; cleaner: proc; if tempp ^= null then call mdbm_util_$free_temp_segment (myname, tempp, (0)); if fm_ptr ^= null then call terminate_file_ (fm_ptr, 0, TERM_FILE_TERM, (0)); return; end cleaner; error: proc (cd, msg); dcl cd fixed bin (35) parameter; dcl msg char (*) parameter; Ocode = cd; if Ocode = 0 then Oerror_message = ""; else Oerror_message = msg; call cleaner; goto RETURN_TO_CALLER; end error; %page; /*DESCRIPTION This implements renaming a single attribute. Note that quits are trapped during critical code. Steps Are: - if the attribute is unreferenced rename the attribute in db_model - otherwise - mark the db and resultant inconsistent. - get the attribute xref record. - for each relation in the xref - initiate the file_model - find the attribute within the file_model - rename the attribute within the file_model - rename the attribute within the referenced domain xref record - mark the db consistent - rename the attribute xref record. - add a history entry */ rename_attribute: proc (ra_from, ra_to); dcl ra_attribute_xref_ptr ptr; dcl ra_from char (*) parameter; dcl ra_loop fixed bin; dcl ra_relation_name char (32); dcl ra_to char (*) parameter; dcl ra_unreferenced_domain bit (1) aligned; ra_unreferenced_domain = "0"b; goto RENAME_ATTRIBUTE_COMMON; rename_attribute$unreferenced_domain: entry (ra_from, ra_to); ra_unreferenced_domain = "1"b; goto RENAME_ATTRIBUTE_COMMON; RENAME_ATTRIBUTE_COMMON: ra_attribute_xref_ptr = tempp; /* Get the attribute crossreference record */ call mdbm_util_$xref_find_record (local_iocb, ATTRIBUTE_KEY_HEAD, ra_from, ra_attribute_xref_ptr, max_seg_size, error_message, code); if code ^= 0 then call error (code, error_message); /* BEGIN CRITICAL CODE */ quit_occurred = FALSE; on quit quit_occurred = TRUE; /* disallow renaming of generated attributes */ di_ptr = ptr (dbm_ptr, ra_attribute_xref_ptr -> crossref_info_record.offset); if domain_info.name = ra_from then call error (error_table_$unsupported_operation, "Attempt to rename a generated attribute: " || ra_from); if ra_attribute_xref_ptr -> crossref_info_record.count = 0 then if ra_unreferenced_domain /* unreferenced attribute */ then do; /* this is the generated attribute */ call mdbm_util_$xref_modify_record_name (local_iocb, ATTRIBUTE_KEY_HEAD, ra_from, ra_to, ra_attribute_xref_ptr, error_message, code); if code ^= 0 then call error (code, error_message); di_ptr = ptr (dbm_ptr, ra_attribute_xref_ptr -> crossref_info_record.offset); call mdbm_util_$xref_modify_reference_name (local_iocb, DOMAIN_KEY_HEAD, (domain_info.name), ra_from, ra_to, error_message, code); if code ^= 0 then call error (code, error_message); end; else do; continue = TRUE; do ua_ptr = ptr (dbm_ptr, db_model.unreferenced_attribute_ptr) repeat ptr (dbm_ptr, unreferenced_attribute.fwd_thread) while (rel (ua_ptr) ^= NULL_OFFSET & continue); if unreferenced_attribute.name = ra_from then do; unreferenced_attribute.name = ra_to; continue = FALSE; di_ptr = ptr (dbm_ptr, ra_attribute_xref_ptr -> crossref_info_record.offset); call mdbm_util_$xref_modify_reference_name (local_iocb, DOMAIN_KEY_HEAD, (domain_info.name), ra_from, ra_to, error_message, code); if code ^= 0 then call error (code, error_message); call mdbm_util_$xref_modify_record_name (local_iocb, ATTRIBUTE_KEY_HEAD, ra_from, ra_to, null(), error_message, code); if code ^= 0 then call error (code, error_message); end; end; /* do ua_ptr */ end; else do; /* referenced attribute */ /* Mark database inconsistent */ rmdb_ctl.saved_res_version_ptr -> based_char8 = "RESTRUCT"; if ra_unreferenced_domain then call mdbm_util_$inconsistent_set (dbm_ptr, "rename_domain", "Renaming domain " || rtrim (ra_from) || " to " || rtrim (ra_to), "undo_rename " || rtrim (ra_to) || " " || rtrim (ra_from)); else call mdbm_util_$inconsistent_set (dbm_ptr, "rename_attribute", "Renaming attribute " || rtrim (ra_from) || " to " || rtrim (ra_to), "undo_rename " || rtrim (ra_to) || " " || rtrim (ra_from)); fm_ptr = null; on cleanup call cleaner; /* Do for all relations this attribute is referenced in */ do ra_loop = 1 to ra_attribute_xref_ptr -> crossref_info_record.count; /* Try to open the file_model */ ra_relation_name = rtrim (ra_attribute_xref_ptr -> crossref_info_record.object (ra_loop)) || ".m"; call initiate_file_ (rmdb_ctl.absolute_db_path, ra_relation_name, RW_ACCESS, fm_ptr, (0), code); if code ^= 0 then call error (code, "Initiating relation " || ra_relation_name); /* rename the attr_info name in the file_model */ ri_ptr = ptr (fm_ptr, file_model.rel_ptr); continue = TRUE; do ai_ptr = ptr (fm_ptr, rel_info.attr_ptr) repeat ptr (fm_ptr, attr_info.fwd_thread) while (rel (ai_ptr) ^= NULL_OFFSET & continue); if attr_info.name = ra_from then do; attr_info.name = ra_to; continue = FALSE; end; end; /* do ai_ptr */ call terminate_file_ (fm_ptr, 0, TERM_FILE_TERM, (0)); end; /* do ra_loop */ /* Modify the attribute name in the domain reference record */ di_ptr = ptr (dbm_ptr, ra_attribute_xref_ptr -> crossref_info_record.offset); call mdbm_util_$xref_modify_reference_name (local_iocb, DOMAIN_KEY_HEAD, (domain_info.name), ra_from, ra_to, error_message, code); if code ^= 0 then call error (code, error_message); /* Modify the name on the attribute crossreference record */ call mdbm_util_$xref_modify_record_name (local_iocb, ATTRIBUTE_KEY_HEAD, ra_from, ra_to, ra_attribute_xref_ptr, error_message, code); if code ^= 0 then call error (code, error_message); call mdbm_util_$inconsistent_reset (dbm_ptr); end; /* Add history entry */ if ^ra_unreferenced_domain then call rmdb_add_rmdb_history (dbm_ptr, RMDB_ATTR_TYPE, (ra_from), RMDB_RN_ATTR_OP, (ra_to), (""), (0)); /* END CRITICAL CODE */ revert quit; if quit_occurred then signal quit; return; end rename_attribute; %page; /*DESCRIPTION This implements renaming a single domain. Note that quits are trapped during critical code. Steps are: - rename domain_info in db_model - get the domain xref record - if the domain is referenced - for each attribute in the domain xref record - change the domain name in each attribute xref record - change the name on the domain xref record - add a history entry */ rename_domain: proc (rd_from, rd_to); dcl rd_domain_xref_ptr ptr; dcl rd_from char (*) parameter; dcl rd_loop fixed bin; dcl rd_to char (*) parameter; rd_domain_xref_ptr = tempp; /* BEGIN CRITICAL CODE */ quit_occurred = FALSE; on quit quit_occurred = TRUE; /* Get the domain xref record. */ call mdbm_util_$xref_find_record (local_iocb, DOMAIN_KEY_HEAD, rd_from, rd_domain_xref_ptr, max_seg_size, error_message, code); if code ^= 0 then call error (code, error_message); /* Get a pointer to the domain_info structure in the db_model */ di_ptr = ptr (dbm_ptr, rd_domain_xref_ptr -> crossref_info_record.offset); if domain_info.name ^= rd_from then call error (mrds_error_$internal_error, "Domain " || rtrim (domain_info.name) || " should be " || rd_from); /* Make sure the new domain name isn't an attribute based on this domain */ continue = TRUE; do rd_loop = 1 to rd_domain_xref_ptr -> crossref_info_record.count while (continue); if rd_domain_xref_ptr -> crossref_info_record.object (rd_loop) = rd_to then continue = FALSE; end; if ^continue then call error (error_table_$unsupported_operation, "The new domain name has already been used for an attribute based on this domain: " || rd_to); /* Make sure the new domain name hasn't been used for an attribute already. */ call mdbm_util_$xref_find_record (local_iocb, rtrim (ATTRIBUTE_KEY_HEAD), rd_to, null, 0, error_message, code); if code = 0 then call error (error_table_$unsupported_operation, "The new domain name has already been used for an attribute in the database: " || rd_to); /* Change the name in domain_info */ domain_info.name = rd_to; /* Rename the domain xref record key. */ call mdbm_util_$xref_modify_record_name (local_iocb, DOMAIN_KEY_HEAD, rd_from, rd_to, rd_domain_xref_ptr, error_message, code); if code ^= 0 then call error (code, error_message); /* Rename the generated attribute record for this domain, along with all relation referenced for this generated attribute. */ call rename_attribute$unreferenced_domain (rd_from, rd_to); call rmdb_add_rmdb_history (dbm_ptr, RMDB_DOMAIN_TYPE, (rd_from), RMDB_RN_DMN_OP, (rd_to), (""), (0)); /* END CRITICAL CODE */ revert quit; if quit_occurred then signal quit; /* finally signal it */ return; end rename_domain; %page; /*DESCRIPTION This implements renaming a single relation. Note that quits are disabled during critical code. Steps are: - mark db and resultant inconsistent - rename file_info in db_model - if the relation is a vfile - rename the relation file -otherwise - copy the relation to the new named relation using copy_ - delete the original relation - rename the file_model segment - add a history entry - mark the db consistent */ rename_relation: proc (rr_from, rr_to); dcl rr_from char (*) parameter; dcl rr_from_model_name char (32); dcl rr_relation_xref_ptr ptr; dcl rr_to char (*) parameter; dcl rr_to_model_name char (32); rr_relation_xref_ptr = tempp; /* BEGIN CRITICAL CODE */ quit_occurred = FALSE; on quit quit_occurred = TRUE; call mdbm_util_$xref_find_record (local_iocb, RELATION_KEY_HEAD, rr_from, rr_relation_xref_ptr, max_seg_size, error_message, code); if code ^= 0 then call error (code, error_message); fi_ptr = ptr (dbm_ptr, rr_relation_xref_ptr -> crossref_info_record.offset); if file_info.file_name ^= rr_from then call error (mrds_error_$internal_error, "Relation " || rtrim (file_info.file_name) || " should be " || rr_from); rr_from_model_name = rtrim (rr_from) || ".m"; fm_ptr = null; on cleanup call cleaner; call initiate_file_ (rmdb_ctl.absolute_db_path, rr_from_model_name, RW_ACCESS, fm_ptr, (0), code); if code ^= 0 then call error (code, "Initiating file_model for relation " || rr_from); rmdb_ctl.saved_res_version_ptr -> based_char8 = "RESTRUCT"; call mdbm_util_$inconsistent_set (dbm_ptr, "rename_relation", "Renaming relation " || rtrim (rr_from) || " to " || rr_to, "undo_rename " || rtrim (rr_to) || " " || rtrim (rr_from)); file_info.file_name = rr_to; ri_ptr = ptr (fm_ptr, file_model.rel_ptr); rel_info.name = rr_to; if db_model.db_type_flags.vfile_type then call fs_util_$chname_file (rmdb_ctl.absolute_db_path, rr_from, rr_from, rr_to, code); else do; copy_options_ptr = addr (local_copy_options); copy_options.version = COPY_OPTIONS_VERSION_1; copy_options.caller_name = myname; copy_options.source_dir, copy_options.target_dir = rmdb_ctl.absolute_db_path; copy_options.source_name = rr_from; copy_options.target_name = rr_to; unspec (copy_options.flags) = "0"b; copy_options.flags.no_name_dup = TRUE; copy_options.flags.force = TRUE; copy_options.flags.delete = TRUE; copy_options.flags.mbz = "0"b; unspec (copy_options.copy_items) = "0"b; copy_options.copy_items.acl = TRUE; copy_options.copy_items.ring_brackets = FALSE; copy_options.copy_items.dumper_switches = FALSE; copy_options.copy_items.mbz = "0"b; file_model.relation_copy_good = FALSE; call fs_util_$copy (copy_options_ptr, code); /* Do this delete because file_manager_ has a bug: it doesn't get around to abiding by the flags. When/if DM is fixed the next group of statements may be removed. */ if code = 0 then do; acl_ptr = null; call fs_util_$list_acl (copy_options.source_dir, copy_options.source_name, GENERAL_ACL_VERSION_1, addr (my_area), acl_ptr, code); if code ^= 0 then call error (code, "Getting acl to relation " || copy_options.source_name); call fs_util_$replace_acl (copy_options.source_dir, copy_options.target_name, acl_ptr, "0"b, code); if code ^= 0 then call error (code, "Setting acl on relation " || copy_options.target_name); file_model.relation_copy_good = TRUE; call fs_util_$delentry_file (copy_options.source_dir, copy_options.source_name, code); if code ^= 0 then call error (code, "Deleting the old relation " || copy_options.source_name); end; end; if code ^= 0 then call error (code, "Renaming relation " || rtrim (rr_from) || " to " || rr_to); do ai_ptr = ptr (fm_ptr, rel_info.attr_ptr) repeat ptr (fm_ptr, attr_info.fwd_thread) while (rel (ai_ptr) ^= NULL_OFFSET); call mdbm_util_$xref_modify_reference_name (local_iocb, ATTRIBUTE_KEY_HEAD, (attr_info.name), rr_from, rr_to, error_message, code); if code ^= 0 then call error (code, error_message); end; call terminate_file_ (fm_ptr, 0, TERM_FILE_TERM, code); if code ^= 0 then call error (code, "Terminating file_model for relation " || rr_from); rr_to_model_name = rtrim (rr_to) || ".m"; call fs_util_$chname_file (rmdb_ctl.absolute_db_path, rr_from_model_name, rr_from_model_name, rr_to_model_name, code); if code ^= 0 then call error (code, "Renaming relation " || rtrim (rr_from_model_name) || " to " || rr_to_model_name); call mdbm_util_$xref_modify_record_name (local_iocb, RELATION_KEY_HEAD, rr_from, rr_to, rr_relation_xref_ptr, error_message, code); if code ^= 0 then call error (code, error_message); call rmdb_add_rmdb_history (dbm_ptr, RMDB_REL_TYPE, (rr_from), RMDB_RN_REL_OP, (rr_to), (""), (0)); call mdbm_util_$inconsistent_reset (dbm_ptr); /* END CRITICAL CODE */ revert quit; if quit_occurred then signal quit; return; end rename_relation; %page; /*DESCRIPTION This entry point attempts to undo the actions of the rename requests. These can only be run when the database is marked inconsistent, and attempt to recover all the information possible. They don't report any errors that may be caused by items missing, mis-named, etc as these could result from a system or process interruption during a rename request. Note that we don't have to update the crossreference file in the [pd], as we are operating in an environment that hasn't created it yet. Also note that if there is an interruption during the undo process, it may be restarted the next time the specified database is touched. Certain operations may be retried, however, if they don't complete this request will continue on trying to undo the entire operation. The database inconsistent switch doesn't get reset until the entire undo operation succeeds. */ rmdb_rename$undo_rename: entry (Isci_ptr, Iinfo_ptr); call initialize; if operation = "rename_domain" then call undo_domain; else if operation = "rename_attribute" then call undo_attribute; else if operation = "rename_relation" then call undo_relation; call mdbm_util_$inconsistent_reset (dbm_ptr); return; undo_domain: proc; continue = TRUE; /* do for all domains in the database */ do di_ptr = ptr (dbm_ptr, db_model.domain_ptr) repeat ptr (dbm_ptr, domain_info.fwd_thread) while (rel (di_ptr) ^= NULL_OFFSET & continue); if domain_info.name = from_name then do; continue = FALSE; domain_info.name = to_name; end; end; return; end undo_domain; %page; undo_relation: proc; continue = TRUE; /* do for all relations in the database */ do fi_ptr = ptr (dbm_ptr, db_model.file_ptr) repeat ptr (dbm_ptr, file_info.fwd_ptr) while (rel (fi_ptr) ^= NULL_OFFSET & continue); if file_info.file_name = from_name then do; file_info.file_name = substr (to_name, 1, length (file_info.file_name)); continue = FALSE; end; end; tempp, fm_ptr = null; on cleanup call cleaner; call initiate_file_ (rmdb_ctl.absolute_db_path, to_name, RW_ACCESS, fm_ptr, (0), code); if code ^= 0 then if code ^= error_table_$noentry then goto RETURN_TO_CALLER; else do; call initiate_file_ (rmdb_ctl.absolute_db_path, from_name, RW_ACCESS, fm_ptr, (0), code); if code ^= 0 then goto RETURN_TO_CALLER; call fs_util_$chname_file (rmdb_ctl.absolute_db_path, from_name, from_name, to_name, code); end; ri_ptr = ptr (fm_ptr, file_model.rel_ptr); rel_info.name = to_name; if db_model.db_type_flags.vfile_type then call fs_util_$chname_file (rmdb_ctl.absolute_db_path, from_name, from_name, to_name, (0)); else if file_model.relation_copy_good then do; copy_options_ptr = addr (local_copy_options); copy_options.version = COPY_OPTIONS_VERSION_1; copy_options.caller_name = "undo_rename"; copy_options.source_dir, copy_options.target_dir = rmdb_ctl.absolute_db_path; copy_options.source_name = from_name; copy_options.target_name = to_name; unspec (copy_options.flags) = "0"b; copy_options.flags.no_name_dup = TRUE; copy_options.flags.force = TRUE; copy_options.flags.delete = TRUE; copy_options.flags.mbz = "0"b; unspec (copy_options.copy_items) = "0"b; copy_options.copy_items.acl = TRUE; copy_options.copy_items.ring_brackets = FALSE; copy_options.copy_items.dumper_switches = FALSE; copy_options.copy_items.mbz = "0"b; call fs_util_$copy (copy_options_ptr, code); /* Do this delete because file_manager_ has a bug: it doesn't get around to abiding by the flags. When/if DM is fixed the next group of statements may be removed. */ if code = 0 then do; acl_ptr = null; call fs_util_$list_acl (copy_options.source_dir, copy_options.source_name, GENERAL_ACL_VERSION_1, addr (my_area), acl_ptr, code); if code = 0 then do; call fs_util_$replace_acl (copy_options.source_dir, copy_options.target_name, acl_ptr, "0"b, code); if code = 0 then call fs_util_$delentry_file (copy_options.source_dir, copy_options.source_name, (0)); end; end; file_model.relation_copy_good = FALSE; end; else call fs_util_$delentry_file (rmdb_ctl.absolute_db_path, from_name, (0)); call terminate_file_ (fm_ptr, 0, TERM_FILE_TERM, (0)); fm_ptr = null; return; end undo_relation; %page; undo_attribute: proc; continue = TRUE; /* do for all unreferenced attributes in the db model */ do ai_ptr = ptr (dbm_ptr, db_model.unreferenced_attribute_ptr) repeat ptr (dbm_ptr, attr_info.fwd_thread) while (rel (ai_ptr) ^= NULL_OFFSET & continue); if attr_info.name = from_name then do; attr_info.name = to_name; continue = FALSE; end; end; /* do ai_ptr */ if continue then do; /* the attribute is referenced somewhere */ fm_ptr, tempp = null; on cleanup call cleaner; /* Do for all relations in the database */ do fi_ptr = ptr (dbm_ptr, db_model.file_ptr) repeat ptr (dbm_ptr, file_info.fwd_ptr) while (rel (fi_ptr) ^= NULL_OFFSET); call initiate_file_ (rmdb_ctl.absolute_db_path, (file_info.file_name), R_ACCESS, fm_ptr, (0), code); if code = 0 then do; continue = TRUE; ri_ptr = ptr (fm_ptr, file_model.rel_ptr); /* Do for all attribute within a single relation */ do ai_ptr = ptr (fm_ptr, rel_info.attr_ptr) repeat ptr (fm_ptr, attr_info.fwd_thread) while (rel (ai_ptr) ^= NULL_OFFSET & continue); if attr_info.name = from_name then do; attr_info.name = to_name; continue = FALSE; end; end; /* do ai_ptr */ call terminate_file_ (fm_ptr, 0, TERM_FILE_TERM, (0)); fm_ptr = null; end; end; /* do fi_ptr */ end; return; end undo_attribute; %page; initialize: proc (); dcl i_nargs fixed bin; sci_ptr = Isci_ptr; rmdb_ctl_ptr = Iinfo_ptr; dbm_ptr = rmdb_ctl.db_model_ptr; if dbm_ptr = null then goto RETURN_TO_CALLER; /* no database opened yet */ call mdbm_util_$inconsistent_get_info (dbm_ptr, incon_value, operation, (""), ("")); if ^incon_value then call ssu_$abort_line (sci_ptr, 0, "This request can only be called when making the database consistent."); call ssu_$arg_count (sci_ptr, i_nargs); if i_nargs ^= 2 then goto RETURN_TO_CALLER; call ssu_$arg_ptr (sci_ptr, 1, argp, argl); from_name = arg; call ssu_$arg_ptr (sci_ptr, 2, argp, argl); to_name = arg; return; end initialize; %page; %include access_mode_values; %page; %include acl_structures; %page; %include copy_flags; %page; %include copy_options; %page; %include mdbm_db_model; %page; %include mdbm_file_model; %page; %include mrds_rmdb_ctl; %page; %include rmdb_crossref_info; %page; %include rmdb_history_entry; %page; %include rmdb_rename_object_info; %page; %include terminate_file; %page; dcl addr builtin; dcl arg char (argl) based (argp); dcl argl fixed bin (21); dcl argp ptr; dcl based_char8 char (8) based; dcl char builtin; dcl cleanup condition; dcl code fixed bin (35); dcl continue bit (1) aligned; dcl empty builtin; dcl error_message char (500); dcl error_table_$no_record fixed bin (35) ext static; dcl error_table_$noentry fixed bin (35) ext static; dcl error_table_$unimplemented_version fixed bin (35) ext static; dcl error_table_$unsupported_operation fixed bin (35) ext static; dcl FALSE bit (1) aligned int static options (constant) init ("0"b); dcl fixed builtin; dcl from_name char (32); dcl fs_util_$chname_file entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl fs_util_$copy entry (ptr, fixed bin (35)); dcl fs_util_$delentry_file entry (char (*), char (*), fixed bin (35)); dcl fs_util_$list_acl entry (char (*), char (*), char (*), ptr, ptr, fixed bin (35)); dcl fs_util_$replace_acl entry (char (*), char (*), ptr, bit (1), fixed bin (35)); dcl Iinfo_ptr ptr parameter; dcl incon_value bit (1); dcl initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35)); dcl Irename_object_info_ptr ptr parameter; dcl Irmdb_ctl_ptr ptr parameter; dcl Isci_ptr ptr parameter; dcl key_head char (32); dcl length builtin; dcl 1 local_copy_options aligned like copy_options; dcl local_iocb ptr; dcl loop fixed bin; dcl ltrim builtin; dcl max_seg_size fixed bin (21); dcl mdbm_util_$get_temp_segment_path entry (char (*), char (*), ptr, fixed bin (35)); dcl mdbm_util_$inconsistent_get_info entry (ptr, bit (1), char (*), char (*), char (*)); dcl mdbm_util_$inconsistent_reset entry (ptr); dcl mdbm_util_$inconsistent_set entry (ptr, char (*), char (*), char (*)); dcl mdbm_util_$free_temp_segment entry (char (*), ptr, fixed bin (35)); dcl mrds_error_$attr_already_exists fixed bin (35) ext static; dcl mrds_error_$domain_already_defined fixed bin (35) ext static; dcl mrds_error_$dup_rel fixed bin (35) ext static; dcl mrds_error_$internal_error fixed bin (35) ext static; dcl mrds_error_$no_model_attr fixed bin (35) ext static; dcl mrds_error_$no_model_dom fixed bin (35) ext static; dcl mrds_error_$no_model_rel fixed bin (35) ext static; dcl my_area area; dcl myname char (32) int static options (constant) init ("rmdb_rename"); dcl null builtin; dcl NULL_OFFSET bit (18) aligned int static options (constant) init ((18)"1"b); dcl Ocode fixed bin (35) parameter; dcl Oerror_message char (*) parameter; dcl operation char (32); dcl ptr builtin; dcl quit condition; dcl quit_occurred bit (1) aligned; dcl rel builtin; dcl rename_entry entry variable internal entry (char (*), char (*)); dcl rmdb_add_rmdb_history entry (ptr, fixed bin, char (32), fixed bin, char (32), char (500), fixed bin (35)); dcl mdbm_util_$xref_build entry (char (*), char (*), ptr, char (*), ptr, char (*), fixed bin (35)); dcl mdbm_util_$xref_find_record entry (ptr, char (*), char (*), ptr, fixed bin (21), char (*), fixed bin (35)); dcl mdbm_util_$xref_modify_record_name entry (ptr, char (*), char (*), char (*), ptr, char (*), fixed bin (35)); dcl mdbm_util_$xref_modify_reference_name entry (ptr, char (*), char (*), char (*), char (*), char (*), fixed bin (35)); dcl rtrim builtin; dcl sci_ptr ptr; dcl ssu_$abort_line entry () options (variable); dcl ssu_$arg_count entry (ptr, fixed bin); dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin (21)); dcl substr builtin; dcl sys_info$max_seg_size fixed bin (35) ext static; dcl tempp ptr; dcl terminate_file_ entry (ptr, fixed bin (24), bit (*), fixed bin (35)); dcl to_name char (32); dcl TRUE bit (1) aligned int static options (constant) init ("1"b); dcl unspec builtin; end rmdb_rename;  rmdb_rq_create_attribute.pl1 10/16/86 1541.4rew 10/16/86 1541.5 55782 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1985 * * * *********************************************************** */ /* format: ^inddcls,^indattr,indnoniterend,^indnoniterdo,indend,tree,^case,insnl,comcol61,dclind5,declareind5,delnl */ /*DESCRIPTION This routine parses command arguments for the create_attribute rmdb request. */ /****^ 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): written. END HISTORY COMMENTS */ rmdb_rq_create_attribute: proc (Isci_ptr, Iinfo_ptr); /* Initialize values */ sci_ptr = Isci_ptr; rmdb_ctl_ptr = Iinfo_ptr; /* Determine the number of arguments. There must be an even number. */ call ssu_$arg_count (sci_ptr, nargs); if (nargs = 0) | (mod (nargs, 2) ^= 0) then call ssu_$abort_line (sci_ptr, error_table_$wrong_no_of_args, "^/Usage:^/^-^a attribute1 domain1 {...attributeN domainN}", myname); /* Create the structure that contains the attributes to create */ create_attr_info_count = mod (nargs, 2); allocate create_attr_info in (my_area) set (create_attr_info_ptr); /* Check to see if we have an open database */ if rmdb_ctl.absolute_db_path = "" then call ssu_$abort_line (sci_ptr, error_table_$action_not_performed, "^/There is no currently readied database."); /* Check to see if the database is consistent. If not, we must make it consistent before we can create new attributes. Note that if for some reason the database is not made consistent rmdb_execute_undo will not return, it will either cause a request line or subsystem abort.*/ call mdbm_util_$inconsistent_get_info (rmdb_ctl.db_model_ptr, incon_value, incon_name, unused2, undo_request); if incon_value then call rmdb_execute_undo (sci_ptr, "create_attribute", rmdb_ctl.absolute_db_path, rmdb_ctl.db_model_ptr, incon_name, undo_request); /* Fill in our structure */ create_attr_info.version = create_attr_info_version_1; create_attr_info.count = divide (nargs, 2, 17, 0); attribute_index = 1; do loop = 1 to nargs by 2; call ssu_$arg_ptr (sci_ptr, loop, argp, argl); if argl > 32 then call ssu_$abort_line (sci_ptr, error_table_$bigarg, "^/The maximum length of attribute names is 32 characters. ^a", arg); if verify (arg, mrds_data_$valid_rel_and_attr_name_chars) ^= 0 then call ssu_$abort_line (sci_ptr, mrds_error_$bad_ident, "^a", arg); if search (substr (arg, 1, 1), "_-0123456789") ^= 0 then call ssu_$abort_line (sci_ptr, mrds_error_$inv_attr_name_first_char, "^a", arg); create_attr_info.attribute (attribute_index).name = arg; call ssu_$arg_ptr (sci_ptr, loop + 1, argp, argl); if argl > 32 then call ssu_$abort_line (sci_ptr, error_table_$bigarg, "^/The maximum length of domain names is 32 characters. ^a", arg); if verify (arg, mrds_data_$valid_rel_and_attr_name_chars) ^= 0 then call ssu_$abort_line (sci_ptr, mrds_error_$bad_ident, "^a", arg); if search (substr (arg, 1, 1), "_-0123456789") ^= 0 then call ssu_$abort_line (sci_ptr, mrds_error_$inv_domain_name_first_char, "^a", arg); create_attr_info.attribute (attribute_index).domain = arg; attribute_index = attribute_index + 1; end; /* do loop */ /* Check for duplicate attributes to create */ do loop = 1 to create_attr_info.count-1; do inner_loop = loop + 1 to create_attr_info.count; if create_attr_info.attribute (loop).name = create_attr_info.attribute (inner_loop).name then call ssu_$abort_line (sci_ptr, mrds_error_$attr_already_exists, "^a", create_attr_info.attribute (inner_loop).name); end; /* do inner_loop */ end; /* do loop */ /* Do the actual attribute creation */ call rmdb_create_attribute (rmdb_ctl_ptr, create_attr_info_ptr, error_message, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", error_message); return; %page; %include mrds_rmdb_ctl; %include rmdb_create_attr_info; %page; dcl arg char (argl) based (argp); /* command line argument */ dcl argl fixed bin (21); dcl argp ptr; dcl attribute_index fixed bin; /* loop index */ dcl code fixed bin (35); dcl divide builtin; dcl empty builtin; dcl error_message char (500); dcl error_table_$action_not_performed fixed bin (35) ext static; dcl error_table_$bigarg fixed bin (35) ext static; dcl error_table_$wrong_no_of_args fixed bin (35) ext static; dcl incon_name char (32); /* name of the request that caused the db to become inconsistent */ dcl incon_value bit (1); /* true ::= the db is inconsistent */ dcl Iinfo_ptr ptr; dcl inner_loop fixed bin (17); /* loop index */ dcl Isci_ptr ptr; dcl loop fixed bin; /* loop index */ dcl mdbm_util_$inconsistent_get_info entry (ptr, bit (1), char (*), char (*), char (*)); dcl mod builtin; dcl mrds_data_$valid_rel_and_attr_name_chars char (128) ext static; dcl mrds_error_$attr_already_exists fixed bin(35) ext static; dcl mrds_error_$bad_ident fixed bin(35) ext static; dcl mrds_error_$inv_attr_name_first_char fixed bin(35) ext static; dcl mrds_error_$inv_domain_name_first_char fixed bin(35) ext static; dcl my_area area; /* small area to allocate in */ dcl myname char (32) int static options (constant) init ("create_attribute"); dcl nargs fixed bin; dcl rmdb_create_attribute entry (ptr, ptr, char (*), fixed bin (35)); dcl rmdb_execute_undo entry (ptr, char (32), char (168), ptr, char (32), char (100)); dcl sci_ptr ptr; dcl search builtin; dcl ssu_$abort_line entry () options (variable); dcl ssu_$arg_count entry (ptr, fixed bin); dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin (21)); dcl substr builtin; dcl undo_request char (100); /* rmdb request that will cause the db to become consistent */ dcl unused2 char (200); /* output from mdbm_util_$inconsistent_get_info */ dcl verify builtin; end rmdb_rq_create_attribute;  rmdb_rq_create_domain.pl1 10/16/86 1534.3rew 10/16/86 1143.7 94158 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1985 * * * *********************************************************** */ /* format: ^inddcls,^indattr,indnoniterend,^indnoniterdo,indend,tree,^case,insnl,comcol61,dclind5,declareind5,delnl */ /* BEGIN_DESCRIPTION This routine parses command arguments for the create_domain rmdb request. END_DESCRIPTION */ /****^ 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): written END HISTORY COMMENTS */ rmdb_rq_create_domain: proc (I_sci_ptr, I_rmdb_ctl_ptr); sci_ptr = I_sci_ptr; rmdb_ctl_ptr = I_rmdb_ctl_ptr; /* Determine the number of arguments. There must be an even number. */ call ssu_$arg_count (sci_ptr, nargs); if (nargs = 0) | (mod (nargs, 2) ^= 0) then call ssu_$abort_line (sci_ptr, error_table_$wrong_no_of_args, "^/Usage:^/^-^a domain_name data_type {-control_args}", myname); /* Check to see if we have an open database. */ if rmdb_ctl.absolute_db_path = "" then call ssu_$abort_line (sci_ptr, error_table_$action_not_performed, "^/There is no currently readied database."); /* Check to see if the database is consistent. If not, we must make it consistent before we can create new attributes. Note that if for some reason the database is not made consistent rmdb_execute_undo will not return. It will either cause a request line or subsystem abort. */ call mdbm_util_$inconsistent_get_info (rmdb_ctl.db_model_ptr, incon_value, incon_name, unused2, undo_request); if incon_value then call rmdb_execute_undo (sci_ptr, myname, rmdb_ctl.absolute_db_path, rmdb_ctl.db_model_ptr, incon_name, undo_request); /* Create the structure that contains the info about the domain. */ create_domain_info_count = 1; allocate create_domain_info in (my_area) set (create_domain_info_ptr); /* Fill in our structure. */ create_domain_info.version = create_domain_info_version_1; create_domain_info.domain (1).check_proc_path, create_domain_info.domain (1).decode_proc_path, create_domain_info.domain (1).encode_proc_path = " "; /* The first arg must be the domain name. */ call ssu_$arg_ptr (sci_ptr, 1, argp, argl); if argl > 32 then call ssu_$abort_line (sci_ptr, mrds_error_$long_ident, "^a", arg); if argl < 1 then call ssu_$abort_line (sci_ptr, error_table_$noarg, "The domain name cannot be a null value. ^a", arg); if verify (arg, mrds_data_$valid_id_chars) ^= 0 then call ssu_$abort_line (sci_ptr, mrds_error_$bad_ident, "^a", arg); if search (substr (arg, 1, 1), "-_") ^= 0 then call ssu_$abort_line (sci_ptr, mrds_error_$inv_domain_name_first_char, "^a", arg); create_domain_info.domain (1).name = arg; /* The second arg must be the domain type */ call ssu_$arg_ptr (sci_ptr, 2, argp, argl); if argl < 1 then call ssu_$abort_line (sci_ptr, error_table_$noarg, "The domain type cannot be a null value. ^a", arg); /* Establish a cleanup handler. */ Pseg = null; on cleanup call tidy_up; call translator_temp_$get_segment ((myname), Pseg, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, error_table_$action_not_performed, "Unable to allocate space in the process for a descriptor."); the_descriptor = "0"b; call rmdb_create_descriptor (arg, Pseg, addr (the_descriptor), code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "A valid descriptor could not be produced from the supplied data type declaration. ^a", arg); create_domain_info.domain (1).descriptor, create_domain_info.domain (1).decode_declare_data_descriptor = the_descriptor; /* Initialize for the control argument loop */ args_used = 2; check_proc_exists, decode_dcl_exists, decode_proc_exists, encode_proc_exists = "0"b; /* Now get the control arguments if there are any. */ do while (args_used < nargs); call ssu_$arg_ptr (sci_ptr, args_used + 1, argp, argl); if /* case */ index (arg, "-") = 1 then if (arg = "-check_procedure") | (arg = "-check_proc") then do; call common_to_all_args (check_proc_exists, "check_proc"); create_domain_info.domain (1).check_proc_path = pathname_ (I_dirname, I_entryname); end; else if (arg = "-encode_procedure") | (arg = "-encode_proc") then do; call common_to_all_args (encode_proc_exists, "encode_proc"); create_domain_info.domain (1).encode_proc_path = pathname_ (I_dirname, I_entryname); end; else if arg = "-decode_procedure" | arg = "-decode_proc" then do; call common_to_all_args (decode_proc_exists, "decode_proc"); create_domain_info.domain (1).decode_proc_path = pathname_ (I_dirname, I_entryname); end; else if (arg = "-decode_dcl") | (arg = "-decode_declare") then do; call common_to_all_args (decode_dcl_exists, "decode_dcl"); call rmdb_create_descriptor (arg, Pseg, addr (the_descriptor), code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^/A valid descriptor could not be produced from the supplied data type. ^a", arg); create_domain_info.domain (1).decode_declare_data_descriptor = the_descriptor; end; else call ssu_$abort_line (sci_ptr, error_table_$badopt, "^a", arg); /* invalid control arg */ else call ssu_$abort_line (sci_ptr, error_table_$bad_arg, "^a", arg); /* not a control arg */ end; /* args_used = nargs */ /* Now we have all the args, so check for completeness and consistency */ if (decode_proc_exists & ^decode_dcl_exists) then create_domain_info.domain (1).decode_declare_data_descriptor = create_domain_info.domain (1).descriptor; if (decode_dcl_exists & ^decode_proc_exists) then call ssu_$abort_line (sci_ptr, error_table_$noarg, "^/A -decode_declare type has been specified, but there was no decode_procedure specified."); call rmdb_create_domain (rmdb_ctl_ptr, create_domain_info_ptr, error_message, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", error_message); call tidy_up; return; %page; /* * * * * * * * * * * * * tidy_up * * * * * * * * * * * * * * * * * * * * * */ tidy_up: proc; if Pseg ^= null then call translator_temp_$release_all_segments (Pseg, code); end tidy_up; %page; /* * * * * * * * * * * * * common_to_all_args * * * * * * * * * * * * * * * */ common_to_all_args: proc (already_exists, which_arg); dcl already_exists bit (1) aligned; dcl which_arg char (*) parameter; if already_exists then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "^/The ^a control argument was previously specified.", which_arg); args_used = args_used + 1; if args_used = nargs then call ssu_$abort_line (sci_ptr, error_table_$noarg, "^/A ^a argument is required following the -^a control argument.", which_arg, which_arg); call ssu_$arg_ptr (sci_ptr, args_used + 1, argp, argl); args_used = args_used + 1; if (argl < 1) | (index (arg, "-") = 1) then call ssu_$abort_line (sci_ptr, error_table_$noarg, "^/A ^a argument is required following the -^a control argument.", which_arg, which_arg); if (arg ^= "-decode_dcl") | (arg ^= "-decode_declare") then do; call expand_pathname_ (arg, I_dirname, I_entryname, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", arg); if (length (rtrim (I_entryname)) > 32) & (index (I_entryname, "$") = 0) then call ssu_$abort_line (sci_ptr, error_table_$entlong, "^a", arg); end; already_exists = "1"b; return; end common_to_all_args; %page; %include mrds_rmdb_ctl; %include rmdb_create_domain_info; %page; dcl addr builtin; dcl arg char (argl) based (argp); dcl argl fixed bin (21); dcl argp ptr; dcl args_used fixed bin; dcl check_proc_exists bit (1) aligned; dcl cleanup condition; dcl code fixed bin (35); dcl decode_dcl_exists bit (1) aligned; dcl decode_proc_exists bit (1) aligned; dcl empty builtin; dcl encode_proc_exists bit (1) aligned; dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl error_message char (500); dcl error_table_$action_not_performed fixed bin (35) ext static; dcl error_table_$bad_arg fixed bin(35) ext static; dcl error_table_$badopt fixed bin (35) ext static; dcl error_table_$entlong fixed bin (35) ext static; dcl error_table_$inconsistent fixed bin (35) ext static; dcl error_table_$noarg fixed bin (35) ext static; dcl error_table_$wrong_no_of_args fixed bin (35) ext static; dcl incon_name char (32); /* name of the request that caused the db to become inconsistent */ dcl incon_value bit (1); /* true ::= the db is inconsistent */ dcl I_dirname char (168); dcl I_entryname char (65); dcl I_rmdb_ctl_ptr ptr; dcl I_sci_ptr ptr; dcl index builtin; dcl length builtin; dcl mdbm_util_$inconsistent_get_info entry (ptr, bit (1), char (*), char (*), char (*)); dcl mod builtin; dcl mrds_data_$valid_id_chars char (128) varying ext static; dcl mrds_error_$bad_ident fixed bin (35) ext static; dcl mrds_error_$long_ident fixed bin (35) ext static; dcl mrds_error_$inv_domain_name_first_char fixed bin (35) ext static; dcl my_area area; dcl myname char (32) int static options (constant) init ("create_domain"); dcl nargs fixed bin; dcl null builtin; dcl pathname_ entry (char (*), char (*)) returns (char (168)); dcl Pseg ptr; dcl rtrim builtin; dcl rmdb_create_descriptor entry (char (*), ptr, ptr, fixed bin (35)); dcl rmdb_create_domain entry (ptr, ptr, char (*), fixed bin (35)); dcl rmdb_execute_undo entry (ptr, char (32), char (168), ptr, char (32), char (100)); dcl sci_ptr ptr; dcl search builtin; dcl ssu_$abort_line entry () options (variable); dcl ssu_$arg_count entry (ptr, fixed bin); dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin (21)); dcl substr builtin; dcl the_descriptor bit (36) aligned; dcl translator_temp_$get_segment entry (char (*) aligned, ptr, fixed bin (35)); dcl translator_temp_$release_all_segments entry (ptr, fixed bin (35)); dcl undo_request char (100); /* rmdb request that will cause the db to become consistent */ dcl unused2 char (200); /* output from mdbm_util_$inconsistent_get_info */ dcl verify builtin; end rmdb_rq_create_domain;  rmdb_rq_create_index.pl1 10/16/86 1551.9r w 10/16/86 1144.2 52443 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ rmdb_rq_create_index: proc (sci_ptr, info_ptr); /* . BEGIN_DESCRIPTION This procedure implements the create_index request of the restructure_mrds_db subsystem. It verifies that the correct number of arguments have been supplied and that a data base has been readied for restructuring. It does not verify that the arguments supplied are actually a relation and attribute in the database, that is left to the rmdb_create_index procedure which is called to do the actual index creation. It also checks to be sure that the database is consistent. If the database is marked as inconsistent it will query the user for execution of the undo request. If the request is ok the database will be consistent so the index creation will be done, else it won't be. . END_DESCRIPTION Known Bugs: Other Problems: . HISTORY 82-03-31 Davids: Written 82-05-26 Davids: added code to check consistency of db and call . rmdb_execute_undo its inconsistent. Also changed . calling sequence of rmdb_create_index to include . the db_model_ptr. 82-07-01 Roger Lackey : Modified the calls to mu_db_inconsistent to use mdbm_util_$inconsistent_* for binding. */ /* PARAMETERS */ dcl sci_ptr ptr; /* (input) pointer to the subsystem control info structure */ /* need to be able to pass it to the ssu routines */ dcl info_ptr ptr; /* (input) pointer to the rmdb_ctl structure which is */ /* read only */ /* EXTERNAL STATIC */ dcl error_table_$action_not_performed fixed bin (35) external static; dcl error_table_$badcall fixed bin (35) external static; /* ENTRIES */ dcl mdbm_util_$inconsistent_get_info entry (ptr, bit (1), char (*), char (*), char (*)); dcl ssu_$abort_line entry options (variable); dcl ssu_$arg_count entry (ptr, fixed bin); dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin (21)); dcl rmdb_create_index entry (ptr, char (168), ptr, char (*), char (*), char (500), fixed bin (35)); dcl rmdb_execute_undo entry (ptr, char (32), char (168), ptr, char (32), char (100)); /* INTERNAL AUTOMATIC */ dcl attr_name_len fixed bin (21); /* length of the attribute name argument */ dcl attr_name_ptr ptr; /* pointer to the attribute name argument */ dcl code fixed bin (35); /* standard error code */ dcl error_message char (500); /* error message returned from rmdb_create_index */ dcl incon_name char (32); /* name of the request that caused the database to be inconsistent */ dcl incon_value bit (1); /* true ==> the database is inconsistent */ dcl nargs fixed bin; /* number of arguments the request was called with */ dcl rel_name_len fixed bin (21); /* length of the relation name argument */ dcl rel_name_ptr ptr; /* pointer to the relation name argument */ dcl undo_request char (100); /* rmdb request that will cause the db to become consistent */ dcl unused2 char (200); /* output from mdbm_util_$inconsistent_get_info */ /* BASED */ dcl attr_name char (attr_name_len) based (attr_name_ptr); /* name of attribute to be indexed */ dcl rel_name char (rel_name_len) based (rel_name_ptr); /* name of relation which contains the attribute */ /* INCLUDES */ %page; %include mrds_rmdb_ctl; /* Assign initial values */ rmdb_ctl_ptr = info_ptr; /* Determine the number of arguments that this request was called with. Two arguments are required the relation name and the attribute name. If two arguments are not supplied issue an error. Note that abort line does not return. */ call ssu_$arg_count (sci_ptr, nargs); if nargs ^= 2 then call ssu_$abort_line (sci_ptr, error_table_$badcall, "^/Usage:^/^-create_index relation_name attribute_name^/"); /* If the absolute_db_path element of the rmdb_ctl structure is null it means that no data base is currently readied for restructuring. This is an error. */ if rmdb_ctl.absolute_db_path = "" then call ssu_$abort_line (sci_ptr, error_table_$action_not_performed, "^/There is no currently readied database"); /* If the database is inconsistent it must be made consistent before the index can be created. Note that if for some reason the database is not made consistent rmdb_execute_undo will not return it will either cause a request line or subsystem abort. */ call mdbm_util_$inconsistent_get_info (rmdb_ctl.db_model_ptr, incon_value, incon_name, unused2, undo_request); if incon_value then call rmdb_execute_undo (sci_ptr, "create_index", rmdb_ctl.absolute_db_path, rmdb_ctl.db_model_ptr, incon_name, undo_request); /* Get the relation name and attribute name arguments. */ call ssu_$arg_ptr (sci_ptr, 1, rel_name_ptr, rel_name_len); call ssu_$arg_ptr (sci_ptr, 2, attr_name_ptr, attr_name_len); /* Do the actual index creation */ call rmdb_create_index (rmdb_ctl_ptr, rmdb_ctl.absolute_db_path, rmdb_ctl.db_model_ptr, rel_name, attr_name, error_message, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, error_message); return; end rmdb_rq_create_index;  rmdb_rq_create_relation.pl1 12/09/86 1247.6rew 12/09/86 1237.8 175869 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-06-16,Blair), approve(86-06-16,MCR7311), audit(86-09-15,Gilcrease), install(86-10-16,MR12.0-1187): Initialize all the attributes we have room for. Previously the extent was set to zero and initialization wasn't happening. 2) change(86-10-28,Blair), approve(86-10-28,PBF7311), audit(86-11-26,Dupuis), install(86-12-09,MR12.0-1237): Move the initializing of rmdb_create_rel_info.num_attrs out of the attr_list_handler so that it doesn't get wiped out if we have any indices to create. END HISTORY COMMENTS */ rmdb_rq_create_relation: proc (I_sci_ptr, I_rmdb_ctl_ptr); /* . BEGIN_DESCRIPTION This procedure is called from the the rmdb ssu routine Its purpose is to process the create_relation request arguments Syntax for this request is . relation_name { } . { -index | -ix } . { -sel_exp | -se "mrds_temp_rel_type_selection_exp" } rel_attr_list ::= attr_name_1 attr_name_2 .... attr_name_n index_attr_list ::= rmdb_ix_attr_name_m .... rmdb_ix_attr_name_k mrds_temp_rel_type_selection_exp ::= temp_rel like selection expression The rel_attr_list and -sel_exp are exclusive arguments. The attributes that are to make up the relation primary key must have an astrisk appended to the attribute name in the rel_attr_list. The -index maybe used with either and specifies which attributes are to be secondary indices. The attribute names that appear in the index_attr_list must be defined in the rel_attr_list or by the selection_expression. Currently only attributes that already exist in the data_model can be used to define new relations. . END_DESCRIPTION %page; HISTORY: 82-03-11 Written by R. Lackey 82-06-09 R. Harvey: Stripped out code to handle parentheses. 82-06-28 Roger Lackey : corrected loop control and check for * on end of attribute name. other minor changes pointer out in team review. 82-07-01 Roger Lackey : Modified the calls to mu_db_inconsistent to use mdbm_util_$inconsistent_* for binding. 83-02-07 Mike Kubicar : Changed calling sequence of rmdb_create_relation so that it includes a bit which says whether the routine was called from request level. This is necessary since that routine must know whether to start transactions and that should only be done from request level. */ %page; /* rmdb_rq_create_relation: proc (I_sci_ptr, I_rmdb_ctl_ptr) */ dcl I_rmdb_ctl_ptr pointer parameter /* Pointer to restructuring control */; dcl I_sci_ptr pointer parameter /* ssu info ptr */; sci_ptr = I_sci_ptr; /* For quicker ref */ rmdb_ctl_ptr = I_rmdb_ctl_ptr; /* Pointer to rmdb control structure */ selection_exp_exists = "0"b; /* On = -sel_exp was found */ rel_attr_list_exists = "0"b; /* On = relation attr list was found */ index_attr_list_exists = "0"b; /* On = index attr_list was found */ rmdb_create_rel_info_ptr = null; /* Not allocated yet */ rmdb_ix_attrs_ptr = null; /* Not allocated yet */ rmdb_sel_val_info_ptr = null; /* Not allocated yet */ if rmdb_ctl.version ^= RMDB_CTL_VERSION_1 then call ssu_$abort_line (sci_ptr, error_table_$unimplemented_version, "rmdb_create_rel_info.incl.pl1"); if rmdb_ctl.absolute_db_path = "" then call error (error_table_$action_not_performed, "^/There is no currently readied data base."); on cleanup call tidy_up; /* Establish a cleanup handler for this procedure */ call ssu_$arg_count (sci_ptr, nargs); /* Get number of arguments supplied to me */ if nargs < 2 then /* Must have rel_name and at least one attribute or -selection_expression */ call error (error_table_$wrong_no_of_args, USAGE); /* Tell um how to use it */ call mdbm_util_$inconsistent_get_info (rmdb_ctl.db_model_ptr, /* See if db is inconsistent */ incon_flag, incon_name, unused, undo_request); if incon_flag then /* DB is inconsisten */ call rmdb_execute_undo (sci_ptr, "create_relation", rmdb_ctl.absolute_db_path, rmdb_ctl.db_model_ptr, incon_name, undo_request); call ssu_$arg_ptr (sci_ptr, 1, arg_ptr, arg_len); /* First arg must be rel name */ args_used = 1; if arg_len > 30 /* Relation names can only be 30 chars long because the relation model name must have a ".m" suffix */ then call error (mrds_error_$rel_name_too_long, arg); if arg_len < 1 then call error (mrds_error_$no_rel_name, "^/Relation name was expected for first argument."); else rel_name = arg; /* Got a good rel_name */ %page; do while (args_used < nargs); /* Process supplied arguments */ call ssu_$arg_ptr (sci_ptr, args_used + 1, arg_ptr, arg_len); /* Get next argument */ if substr (arg, 1, 1) = "-" then do; /* Control arg check */ if arg = "-ix" | arg = "-index" then do; /* Index attr list should follow */ args_used = args_used + 1; /* Just used -index */ if index_attr_list_exists then call error (error_table_$inconsistent, "^/The -index argument was previously specified."); if args_used < nargs then do; rmdb_ix_attrs_alloc = mrds_data_$max_attributes; allocate rmdb_ix_attrs in (wa) set (rmdb_ix_attrs_ptr); rmdb_ix_attrs.version = RMDB_IX_ATTRS_VERSION_1; rmdb_ix_attrs.relation_name = rel_name; rmdb_ix_attrs.num_used = 0; call attr_list_handler (args_used, INDEX_ATTR_LIST); end; else call error (mrds_error_$no_inds, "^/An index attribute list is required following the -index control argument."); index_attr_list_exists = "1"b; end; /* if arg = "-index" then do */ else if arg = "-se" | arg = "-sel_exp" then do; /* Selection expression should follow */ args_used = args_used + 1; if selection_exp_exists then call error (error_table_$inconsistent, "^/The -sel_exp argument was previously specified."); if rel_attr_list_exists then call error (error_table_$inconsistent, "^/A relation attribute list cannot be used with the control argument: " || arg); if args_used < nargs then call select_exp_handler (args_used); else do; call error (mrds_error_$no_sel_exp, "^/A selection expression is required following the -sel_exp control argument."); end; end; /* if arg = "-se" */ else call error (error_table_$badopt, arg); /* Bad control arg */ end; /* End control arg check */ else do; /* Not a control arg */ if args_used = 1 then do; /* If first argument following rel_name assume it is the relation attribute list */ /* Allocate and init rmdb_create_rel_info structure */ rmdb_create_rel_info_alloc = mrds_data_$max_attributes; /* Set max number of attrs in rmdb_create_rel_info */ allocate rmdb_create_rel_info in (wa) /* wa is rmdb_ctl.work_area) */ set (rmdb_create_rel_info_ptr); rmdb_create_rel_info.version = RMDB_CREATE_REL_INFO_VERSION_1; rmdb_create_rel_info.db_path = rmdb_ctl.absolute_db_path; rmdb_create_rel_info.db_model_ptr = rmdb_ctl.db_model_ptr; rmdb_create_rel_info.temp_directory_path = rmdb_ctl.temp_dir_path; rmdb_create_rel_info.relation_name = rel_name; rmdb_create_rel_info.num_attrs = rmdb_create_rel_info_alloc; /* we'll figure out how many actual in a minute */ do z = 1 to rmdb_create_rel_info_alloc; rmdb_create_rel_info.attrs (*).primary_key = "0"b; /* Turn off all primary_key flags */ rmdb_create_rel_info.attrs (*).indexed = "0"b; /* Turn off all indexed flags */ end; rmdb_create_rel_info.num_attrs = 0; call attr_list_handler (args_used, REL_ATTR_LIST); /* Process attribute list */ end; /* Must be rel_attr_list */ else call error (error_table_$bad_subr_arg, arg || USAGE); end; end /* Get rest of arguments */; if ^selection_exp_exists then do; /* Creation was already done for us */ if rmdb_create_rel_info_ptr = null then call error (mrds_error_$no_rel_attr, "^/" || rel_name); if rmdb_create_rel_info.num_attrs < 1 then call error (mrds_error_$no_rel_attr, rmdb_create_rel_info.relation_name); if index_attr_list_exists then call index_attr_mark; /* Mark those attrs that are to be indexed */ call rmdb_create_relation (rmdb_ctl_ptr, rmdb_create_rel_info_ptr, "1"b /* Called at request level */, err_msg, code); if code ^= 0 then call error (code, err_msg); end; call tidy_up; /* Free rmdb_create_rel_info structure */ exit: return; %page; /* * * * * * * * * * * * attr_list_handler * * * * * * * * * * * */ attr_list_handler: proc (ag_used, list_type_indicator); /* Processor for both rel and index attribute list */ dcl ag_used fixed bin parameter /* (INPUT/OUTPUT) Number of arguments used so far */; dcl list_type_indicator fixed bin parameter /* (INPUT) 1 = relation attr list 2 = index attr list */; /* This internal procedure processes the input string attr_1 attr_2 .. .. .. attr_n It isolates each attribute in an attribute list for both relation atr_list and index attr_list. */ first = "1"b; attrs_done = "0"b; %page; do while (ag_used < nargs & ^attrs_done); call ssu_$arg_ptr (sci_ptr, ag_used + 1, arg_ptr, arg_len); /* Get next argument */ if substr (arg, 1, 1) = "-" then /* argument is a control arg */ attrs_done = "1"b; else do; /* Not a control argument */ ag_used = ag_used + 1; /* Bump number of arguments used */ attr_name = arg; if length (attr_name) < 1 then call error (mrds_error_$bad_attr_name, "^/Null attribute name."); if list_type_indicator = REL_ATTR_LIST then do; call relation_attr_add; end; else do; /* Were working on an inde attr list */ if length (attr_name) > 32 then call error (mrds_error_$rst_name_too_long, "^/Attribute name is longer then 32 characters: " || attr_name); rmdb_ix_attrs.num_used = rmdb_ix_attrs.num_used + 1; rmdb_ix_attrs.an (rmdb_ix_attrs.num_used) = attr_name; end; first = "0"b; /* First token already processed */ end; /* END not a contol arg */ end /* END do while (ag_used <= nargs | ^attrs_done) */; end attr_list_handler; %page; /* * * * * * * * * * * * * relation_attr_add * * * * * * * * * * * * * */ relation_attr_add: proc; if rmdb_create_rel_info.num_attrs >= mrds_data_$max_attributes then call error (mrds_error_$max_attributes, ""); rmdb_create_rel_info.num_attrs = rmdb_create_rel_info.num_attrs + 1; /* Got another one */ if index (reverse (attr_name), "*") = 1 then do; /* If last char is * it is a primary attribute */ j = length (attr_name) - 1; /* Length attr - * */ attr_name = substr (attr_name, 1, j); /* Remove the * from name */ if j < 1 then call error (mrds_error_$bad_attr_name, "*"); rmdb_create_rel_info.attrs (rmdb_create_rel_info.num_attrs).primary_key = "1"b; end; if length (attr_name) > 32 then call error (mrds_error_$rst_name_too_long, "^/Attribute name is longer then 32 characters: " || attr_name); rmdb_create_rel_info.attrs (rmdb_create_rel_info.num_attrs).name = attr_name; rel_attr_list_exists = "1"b; /* Remember we had a rel_attr_list */ end relation_attr_add; %page; /* * * * * * * * * * * * * index_attr_mark * * * * * * * * * * * * * * */ index_attr_mark: proc; do k = 1 to rmdb_ix_attrs.num_used; /* All indexed attrs */ attr_name = rmdb_ix_attrs.an (k); found = "0"b; do j = 1 to rmdb_create_rel_info.num_attrs while (^found); /* Search for name in list */ if attr_name = rmdb_create_rel_info.attrs (j).name then do; if rmdb_create_rel_info.attrs (j).indexed = "1"b then call error (mrds_error_$previously_defined_index, (attr_name)); rmdb_create_rel_info.attrs (j).indexed = "1"b; /* Mark as indexed */ found = "1"b; end; end; if ^found then call error (mrds_error_$undef_attr, "^/" || attr_name); end; /* END All indexed attrs */ end index_attr_mark; %page; /* * * * * * * * * * * * * select_exp_handler * * * * * * * * * * * * * */ select_exp_handler: proc (args_used_count); dcl args_used_count fixed bin parameter; selection_exp_exists = "1"b; call ssu_$arg_ptr (sci_ptr, args_used_count + 1, sel_exp_ptr, sel_exp_len); /* Get selection expression */ args_used_count = args_used_count + 1; /* Check any other args for control argument (they are not allowed following the selection exp) */ do z = args_used_count + 1 to nargs; call ssu_$arg_ptr (sci_ptr, z, arg_ptr, arg_len); /* Get next arg */ if substr (arg, 1, 1) = "-" then call error (error_table_$bad_arg, "^/" || arg || "^/No control arguments are allowed after the select expression."); end; %page; /* rmdb_sel_val_info is required by rmdb_create_and_pop_rel even if no sel_vals are provided */ allocate rmdb_sel_val_info in (wa) set (rmdb_sel_val_info_ptr); rmdb_sel_val_info.version = RMDB_SEL_VAL_INFO_VERSION_1; rmdb_sel_val_info.sv_num = 0; rmdb_sel_val_info.data_list_ptr = null; rmdb_sel_val_info.desc_list_ptr = null; if nargs > args_used_count then do; /* Must have provided some sel_values */ call ssu_$arg_list_ptr (sci_ptr, al_ptr); /* Get the argument list */ rmdb_sel_val_info.data_list_ptr = addr (al_ptr -> arg_list.arg_ptrs (args_used_count + 1)); /* Pointer list of data pointers */ rmdb_sel_val_info.desc_list_ptr = addr (al_ptr -> arg_list.desc_ptrs (args_used_count + 1)); /* Pointer to list of select_value descriptors */ rmdb_sel_val_info.sv_num = nargs - args_used_count; end; if rmdb_ix_attrs_ptr = null then do; /* If no -index was supplied */ rmdb_ix_attrs_alloc = 0; /* Got to have this to pass rel_name to rmdb_create_and_pop_rel */ allocate rmdb_ix_attrs in (wa) set (rmdb_ix_attrs_ptr); rmdb_ix_attrs.version = RMDB_IX_ATTRS_VERSION_1; rmdb_ix_attrs.relation_name = rel_name; rmdb_ix_attrs.num_used = 0; end; call rmdb_create_and_pop_rel (rmdb_ctl_ptr, rmdb_ctl.absolute_db_path, rmdb_ctl.temp_dir_path, sel_exp, rmdb_sel_val_info_ptr, rmdb_ix_attrs_ptr, err_msg, code); if code ^= 0 then do; added_args = ""; do z = args_used_count + 1 to nargs; call ssu_$arg_ptr (sci_ptr, z, arg_ptr, arg_len); /* Get next arg */ added_args = added_args || " " || arg; end; err_msg = rtrim (err_msg) || added_args; call error (code, err_msg); end; /* END if code ^= 0 */ args_used_count = nargs; /* So we won't look for any more arguments */ end select_exp_handler; %page; /* * * * * * * * * * * * * error * * * * * * * * * * * * * */ error: proc (err_code, err_message); /* Error procedure for rmdb_create_relation.pl1 */ dcl err_code fixed bin (35) parameter; dcl err_message char (*) parameter; dcl ssu_$abort_line entry () options (variable); call tidy_up; call ssu_$abort_line (sci_ptr, err_code, err_message); end error; /* * * * * * * * * * * * * tidy_up * * * * * * * * * * * * * */ tidy_up: proc; if rmdb_create_rel_info_ptr ^= null then free rmdb_create_rel_info; if rmdb_ix_attrs_ptr ^= null then free rmdb_ix_attrs; if rmdb_sel_val_info_ptr ^= null then free rmdb_sel_val_info; end tidy_up; %page; dcl added_args char (100) varying; dcl addr builtin; dcl al_ptr ptr; dcl arg char (arg_len) based (arg_ptr); dcl args_used fixed bin; dcl arg_len fixed bin (21); dcl arg_ptr ptr; dcl attrs_done bit (1); dcl attr_name char (64) varying; dcl cleanup condition; dcl code fixed bin (35); dcl error_table_$action_not_performed fixed bin (35) ext static; dcl error_table_$badopt fixed bin (35) ext static; dcl error_table_$bad_arg fixed bin (35) ext static; dcl error_table_$bad_subr_arg fixed bin (35) ext static; dcl error_table_$inconsistent fixed bin (35) ext static; dcl error_table_$unimplemented_version fixed bin (35) ext static; dcl error_table_$wrong_no_of_args fixed bin (35) ext static; dcl err_msg char (256); dcl first bit (1); dcl found bit (1); dcl incon_flag bit (1); dcl incon_name char (32); dcl index builtin; dcl INDEX_ATTR_LIST fixed bin int static options (constant) init (2); dcl index_attr_list_exists bit (1); dcl j fixed bin; dcl k fixed bin; dcl length builtin; dcl mrds_data_$max_attributes fixed bin (35) init (256); dcl mrds_error_$bad_attr_name fixed bin (35) ext static; dcl mrds_error_$max_attributes fixed bin (35) ext static; dcl mrds_error_$no_inds fixed bin (35) ext static; dcl mrds_error_$no_rel_attr fixed bin (35) ext static; dcl mrds_error_$no_rel_name fixed bin (35) ext static; dcl mrds_error_$no_sel_exp fixed bin (35) ext static; dcl mrds_error_$previously_defined_index fixed bin (35) ext static; dcl mrds_error_$rel_name_too_long fixed bin (35) ext static; dcl mrds_error_$rst_name_too_long fixed bin (35) ext static; dcl mrds_error_$undef_attr fixed bin (35) ext static; dcl mdbm_util_$inconsistent_get_info entry (ptr, bit (1), char (*), char (*), char (*)); dcl nargs fixed bin; dcl null builtin; dcl REL_ATTR_LIST fixed bin int static options (constant) init (1); dcl rel_attr_list_exists bit (1); dcl rel_name char (32) varying; dcl reverse builtin; dcl rmdb_create_and_pop_rel entry (ptr, char (*), char (*), char (*), ptr, ptr, char (*), fixed bin (35)); dcl rmdb_create_relation entry (ptr, ptr, bit (1), char (*), fixed bin (35)); dcl rmdb_execute_undo entry (ptr, char (32), char (168), ptr, char (32), char (100)); dcl rtrim builtin; dcl sci_ptr ptr; dcl selection_exp_exists bit (1); dcl sel_exp char (sel_exp_len) based (sel_exp_ptr); dcl sel_exp_len fixed bin (21); dcl sel_exp_ptr ptr; dcl ssu_$abort_line entry () options (variable); dcl ssu_$arg_count entry (ptr, fixed bin); dcl ssu_$arg_list_ptr entry (ptr, ptr); dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin (21)); dcl substr builtin; dcl sys_info$max_seg_size fixed bin (35) ext static; dcl undo_request char (100); dcl unused char (32); dcl USAGE char (120) int static options (constant) init ("^/Usage: create_relation relation_name {attribute_list}^/^7x{-index attribute_list} {-sel_exp SEL_EXP}"); dcl wa area (sys_info$max_seg_size) based (rmdb_ctl.work_area_ptr); dcl z fixed bin; %page; %include mrds_rmdb_ctl; %page; %include rmdb_create_rel_info; %page; %include arg_list; end rmdb_rq_create_relation;  rmdb_rq_delete_index.pl1 10/16/86 1551.9r w 10/16/86 1144.3 88623 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ rmdb_rq_delete_index: proc (sci_ptr, info_ptr); /* . BEGIN_DESCRIPTION This procedure implements the delete_index request of the restructure_mrds_db subsystem. It verifies that the correct number of arguments have been supplied and that a data base has been readied for restructuring. It does not verify that the arguments supplied are actually a relation and attribute in the database, that is left to the rmdb_delete_index procedure which is called to do the actual index deletion. If the database is inconsistent rmdb_execute_undo is called to query the user and execute the request. . END_DESCRIPTION . BEGIN_INFO .05/20/82 delete_index, dli . .Syntax: dli relation_name attribute_name {-control_args} . . .Function: Removes the secondary index for the attribute in the . relation. . . .Arguments: . .relation_name . Name of the relation to be restructured. . .attribute_name . Name of the attribute whose secondary index is to be deleted. . . .Control Arguments: . .brief, fc . Will suppress error reporting if the attribute is not already a . secondary index. . .long, lg . Will report an error if the attribute is not already a secondary . index . . .Notes: . . This request may be run only against a consistent database. If the . database is inconsistent the user will be queried to see if he . wishes to execute the "undo request", this request will make the . database consistent. After the undo request has been executed the . requested index will be deleted. If the undo request fails the user . will be returned to rmdb request level - the index will not be . deleted, in addition the database will be freed. . END_INFO Known Bugs: Other Problems: . HISTORY 82-05-17 Davids: Written 82-05-26 Davids: Added call to rmdb_execute_undo for inconsistent . database and added rmdb_ctl.db_model.ptr to the . calling sequence of rmdb_delete_index. 82-07-01 Roger Lackey : Modified the calls to mu_db_inconsistent to use mdbm_util_$inconsistent_* for binding. */ /* PARAMETERS */ dcl sci_ptr ptr; /* (input) pointer to the subsystem control info structure */ /* need to be able to pass it to the ssu routines */ dcl info_ptr ptr; /* (input) pointer to the rmdb_ctl structure which is */ /* read only */ /* EXTERNAL STATIC */ dcl error_table_$action_not_performed fixed bin (35) external static; dcl error_table_$badcall fixed bin (35) external static; /* ENTRIES */ dcl mdbm_util_$inconsistent_get_info entry (ptr, bit (1), char (*), char (*), char (*)); dcl mdbm_util_$inconsistent_reset entry (ptr); dcl ssu_$abort_line entry options (variable); dcl ssu_$arg_count entry (ptr, fixed bin); dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin (21)); dcl ssu_$print_message entry () options (variable); dcl rmdb_delete_index entry (ptr, char (168), ptr, char (*), char (*), bit (1), char (500), fixed bin (35)); dcl rmdb_execute_undo entry (ptr, char (32), char (168), ptr, char (32), char (100)); /* INTERNAL AUTOMATIC */ dcl attr_name_len fixed bin (21); /* length of the attribute name argument */ dcl attr_name_ptr ptr; /* pointer to the attribute name argument */ dcl code fixed bin (35); /* standard error code */ dcl ctl_arg_error bit (1); /* true ==> at least one of the control arguments was in error */ dcl ctl_arg_len fixed bin (21); /* length of a control argument */ dcl ctl_arg_ptr ptr; /* pointer to a control argument */ dcl error_message char (500); /* error message returned from rmdb_delete_index */ dcl brief_flag bit (1); /* true ==> last control arg had value of -fc or -brief */ dcl i fixed bin; /* loop counter for control argument processing */ dcl incon_value bit (1); /* true ==> database is inconsistent */ dcl incon_name char (32); /* name of request that caused the db to become inconsistent */ dcl nargs fixed bin; /* number of arguments the request was called with */ dcl rel_name_len fixed bin (21); /* length of the relation name argument */ dcl rel_name_ptr ptr; /* pointer to the relation name argument */ dcl rest_of_undo_request char (100); /* copy of undo request with request, rel, attr names removed */ dcl this_is_the_undo_request bit (1); /* true ==> the user typed in the undo request */ dcl undo_attr_name char (32) varying; /* name of the attribute in the undo request */ dcl undo_rel_name char (32) varying; /* name of the relation in the undo request */ dcl undo_request char (100); /* rmdb request that will make the db consistent again */ dcl undo_request_name char (32) varying; /* name of the undo request */ dcl unused1 char (200); /* unused output parameter from mdbm_util_$inconsistent_get_info */ /* BASED */ dcl attr_name char (attr_name_len) based (attr_name_ptr); /* name of attribute to be indexed */ dcl ctl_arg char (ctl_arg_len) based (ctl_arg_ptr); /* control argument */ dcl rel_name char (rel_name_len) based (rel_name_ptr); /* name of relation which contains the attribute */ /* BUILTINS */ dcl after builtin; dcl before builtin; /* INCLUDES */ %page; %include mrds_rmdb_ctl; /* Assign initial values */ rmdb_ctl_ptr = info_ptr; brief_flag = "0"b; ctl_arg_error = "0"b; this_is_the_undo_request = "0"b; /* Determine the number of arguments that this request was called with. At least two arguments are required, the relation name and the attribute name there may also be any number of control arguments which may be either brief or long. If at least two arguments are not supplied issue an error. Note that abort line does not return. */ call ssu_$arg_count (sci_ptr, nargs); if nargs < 2 then call ssu_$abort_line (sci_ptr, error_table_$badcall, "^/Usage:^/^-delete_index relation_name attribute_name {-brief | -long}^/"); /* If the absolute_db_path element of the rmdb_ctl structure is null it means that no data base is currently readied for restructuring. This is an error. */ if rmdb_ctl.absolute_db_path = "" then call ssu_$abort_line (sci_ptr, error_table_$action_not_performed, "^/There is no currently readied database"); /* Get the relation and attribute name arguments and the control arguments. All control arguments will be looked at, any that are in error will be reported. If an incorrect control arg is found then the request will be aborted (along with any other requests on the command line) after all the control arguments have been looked at. */ call ssu_$arg_ptr (sci_ptr, 1, rel_name_ptr, rel_name_len); call ssu_$arg_ptr (sci_ptr, 2, attr_name_ptr, attr_name_len); do i = 3 to nargs; call ssu_$arg_ptr (sci_ptr, i, ctl_arg_ptr, ctl_arg_len); if ctl_arg = "-brief" | ctl_arg = "-bf" then brief_flag = "1"b; else if ctl_arg = "-long" | ctl_arg = "-lg" then brief_flag = "0"b; else do; ctl_arg_error = "1"b; call ssu_$print_message (sci_ptr, error_table_$badcall, "^/Argument ^i (^a) is not a legal control argument^/", i, ctl_arg); end; end; if ctl_arg_error then call ssu_$abort_line (sci_ptr, 0); /* If the database is inconsistent then only the undo request may be executed. Since it is possible that the user typed in the undo request himself it must be parsed and compared with what the user typed in. If the two are different rmdb_execute_undo is called to query the user and execute the request. If the user typed in the request himself it will be executed and then the database will be marked as consistent. Note that if rmdb_execute_undo returns then the database is consistent and the index deletion can take place. */ call mdbm_util_$inconsistent_get_info (rmdb_ctl.db_model_ptr, incon_value, incon_name, unused1, undo_request); if incon_value then do; undo_request_name = before (undo_request, " "); rest_of_undo_request = after (undo_request, " "); undo_rel_name = before (rest_of_undo_request, " "); rest_of_undo_request = after (rest_of_undo_request, " "); undo_attr_name = before (rest_of_undo_request, " "); if undo_request_name = "delete_index" & undo_rel_name = rel_name & undo_attr_name = attr_name then this_is_the_undo_request = "1"b; else call rmdb_execute_undo (sci_ptr, "delete_index", rmdb_ctl.absolute_db_path, rmdb_ctl.db_model_ptr, incon_name, undo_request); end; /* Do the actual index creation */ call rmdb_delete_index (rmdb_ctl_ptr, rmdb_ctl.absolute_db_path, rmdb_ctl.db_model_ptr, rel_name, attr_name, brief_flag, error_message, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, error_message); /* If we are executing the undo request directly the database must now be marked as consistent. */ if this_is_the_undo_request then call mdbm_util_$inconsistent_reset (rmdb_ctl.db_model_ptr); return; end rmdb_rq_delete_index;  rmdb_rq_delete_object.pl1 12/07/87 1328.9rew 12/07/87 1321.0 83106 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1985 * * * *********************************************************** */ /* format: ^inddcls,^indattr,indnoniterend,^indnoniterdo,indend,tree,^case,insnl,comcol61,dclind5,declareind5,delnl */ /*DESCRIPTION This routine is the argument processor for the rmdb delete_attribute and delete_domain requests. After processing the arguments and building the delete structure, it calls rmdb_delete_(domain attribute) to actually do all the work. */ /****^ HISTORY COMMENTS: 1) change(85-12-03,Spitzer), approve(85-12-03,MCR7311), audit(86-09-15,Gilcrease), install(86-10-16,MR12.0-1187): written 2) change(87-09-30,Blair), approve(87-11-03,MCR7792), audit(87-11-30,Dupuis), install(87-12-07,MR12.2-1008): Correct the request name placed in the inconsistent_message structure so it will accurately reflect the request being made consistent. END HISTORY COMMENTS */ rmdb_rq_delete_object: proc; return; /* not an entry point */ rmdb_rq_delete_object$domain: entry (Isci_ptr, Iinfo_ptr); domain_entry = "1"b; goto COMMON; rmdb_rq_delete_object$attribute: entry (Isci_ptr, Iinfo_ptr); domain_entry = "0"b; goto COMMON; COMMON: sci_ptr = Isci_ptr; rmdb_ctl_ptr = Iinfo_ptr; /* Determine if we have an open database. */ if rmdb_ctl.absolute_db_path = "" then call ssu_$abort_line (sci_ptr, error_table_$action_not_performed, "^/There is no currently readied database."); call ssu_$arg_count (sci_ptr, nargs); /* Count all the non-control arguments (this is the list of names) */ begin; dcl arg char (argl) based (argp); dcl argl fixed bin (21); dcl arglengths (nargs) fixed bin (21); dcl argp ptr; dcl argptrs (nargs) ptr; delete_object_info_count = 0; do loop = 1 to nargs; call ssu_$arg_ptr (sci_ptr, loop, argp, argl); if index (arg, "-") ^= 1 then delete_object_info_count = delete_object_info_count + 1; argptrs (loop) = argp; arglengths (loop) = argl; end; /* do loop */ allocate delete_object_info in (my_area) set (delete_object_info_ptr); unspec (delete_object_info) = "0"b; delete_object_info.version = delete_object_info_version_1; delete_object_info.count = 0; do loop = 1 to nargs; argp = argptrs (loop); argl = arglengths (loop); if /* case */ index (arg, "-") = 1 then if /* case */ arg = "-a" | arg = "-all" then delete_object_info.all = TRUE; else if arg = "-bf" | arg = "-brief" then delete_object_info.long = SHORT; else if arg = "-ck" | arg = "-check" then delete_object_info.check = TRUE; else if arg = "-fc" | arg = "-force" then delete_object_info.force = TRUE; else if arg = "-ihe" | arg = "-inhibit_error" then delete_object_info.inhibit_errors = TRUE; else if arg = "-lg" | arg = "-long" then delete_object_info.long = LONG; else if arg = "-nfc" | arg = "-no_force" then delete_object_info.force = FALSE; else if arg = "-nihe" | arg = "-no_inhibit_error" then delete_object_info.inhibit_errors = FALSE; else if arg = "-unref" | arg = "-unreferenced" then delete_object_info.unreferenced = TRUE; else call ssu_$abort_line (sci_ptr, error_table_$bad_arg, "^a", arg); else do; if argl > length (delete_object_info.name (1)) then call ssu_$abort_line (sci_ptr, mrds_error_$rst_name_too_long, "^a", arg); if argl < 1 then call ssu_$abort_line (sci_ptr, 0, "The ^[domain^;attribute^] name cannot be the null string."); if verify (arg, mrds_data_$valid_rel_and_attr_name_chars) ^= 0 then call ssu_$abort_line (sci_ptr, mrds_error_$bad_ident, "^a", arg); if domain_entry then if search (substr (arg, 1, 1), "_-") ^= 0 then call ssu_$abort_line (sci_ptr, mrds_error_$inv_domain_name_first_char, "^a", arg); else ; else if search (substr (arg, 1, 1), "_-0123456789") ^= 0 then call ssu_$abort_line (sci_ptr, mrds_error_$inv_attr_name_first_char, "^a", arg); delete_object_info.count = delete_object_info.count + 1; delete_object_info.name (delete_object_info.count) = arg; end; end; /* do loop */ end; /* begin */ if (delete_object_info.all | delete_object_info.unreferenced) & delete_object_info.count ^= 0 then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "-all or -unref and a list of ^[domains^;attributes^].", domain_entry); if delete_object_info.check & delete_object_info.all then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "-all and -check"); if (delete_object_info.long = LONG) & delete_object_info.all then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "-all and -long"); if (delete_object_info.long = LONG) & delete_object_info.unreferenced then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "-unref and -long"); if delete_object_info.check & delete_object_info.unreferenced then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "-unreferenced and -check"); if (delete_object_info.check & (delete_object_info.long ^= UNSPEC)) then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "-check and -brief or -long"); if delete_object_info.long = SHORT then delete_object_info.check = FALSE; if delete_object_info.long = LONG then delete_object_info.check = TRUE; if ^delete_object_info.all & ^delete_object_info.unreferenced & delete_object_info.count = 0 then call ssu_$abort_line (sci_ptr, 0, "No deletion arguments found.^/A list of ^[domain^;attribute^] names, -unreferenced or -all must be given.", domain_entry); /* Make sure that we don't need to cleanup from a previous operation. */ if domain_entry then delete_object_info.request_name = "rmdb (delete_domain)"; else delete_object_info.request_name = "rmdb (delete_attribute)"; call mdbm_util_$inconsistent_get_info (rmdb_ctl.db_model_ptr, incon_value, incon_name, unused2, undo_request); if incon_value then call rmdb_execute_undo (sci_ptr, rtrim (delete_object_info.request_name), rmdb_ctl.absolute_db_path, rmdb_ctl.db_model_ptr, incon_name, undo_request); delete_object_info.check_iocb_ptr = iox_$user_output; delete_object_info.query_iocb_ptr = iox_$user_input; if domain_entry then call rmdb_delete_domain (rmdb_ctl_ptr, delete_object_info_ptr, error_message, code); else call rmdb_delete_attribute (rmdb_ctl_ptr, delete_object_info_ptr, error_message, code); if code ^= 0 & ^delete_object_info.inhibit_errors then call ssu_$abort_line (sci_ptr, code, "^a", error_message); return; %page; %include mrds_rmdb_ctl; %include rmdb_delete_object_info; %page; dcl code fixed bin (35); dcl domain_entry bit (1) aligned; dcl empty builtin; dcl error_message char (500); dcl error_table_$action_not_performed fixed bin (35) ext static; dcl error_table_$bad_arg fixed bin (35) ext static; dcl error_table_$inconsistent fixed bin(35) ext static; dcl FALSE bit (1) aligned int static options (constant) init ("0"b); dcl Iinfo_ptr ptr parameter; dcl incon_name char (32); /* name of the request that caused the db to become inconsistent */ dcl incon_value bit (1); /* true ::= the db is inconsistent */ dcl index builtin; dcl iox_$user_input ptr ext static; dcl iox_$user_output ptr ext static; dcl Isci_ptr ptr parameter; dcl length builtin; dcl LONG bit (2) aligned int static options (constant) init ("10"b); dcl loop fixed bin; dcl mdbm_util_$inconsistent_get_info entry options(variable); dcl mrds_data_$valid_rel_and_attr_name_chars char (128) ext static; dcl mrds_error_$bad_ident fixed bin(35) ext static; dcl mrds_error_$inv_attr_name_first_char fixed bin(35) ext static; dcl mrds_error_$inv_domain_name_first_char fixed bin(35) ext static; dcl mrds_error_$rst_name_too_long fixed bin (35) ext static; dcl my_area area; dcl nargs fixed bin; dcl rmdb_delete_attribute entry (ptr, ptr, char (*), fixed bin (35)); dcl rmdb_delete_domain entry (ptr, ptr, char(*), fixed bin(35)); dcl rmdb_execute_undo entry (ptr, char(32), char(168), ptr, char(32), char(100)); dcl rtrim builtin; dcl sci_ptr ptr; dcl search builtin; dcl SHORT bit (2) aligned int static options (constant) init ("01"b); dcl ssu_$abort_line entry () options (variable); dcl ssu_$arg_count entry (ptr, fixed bin); dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin (21)); dcl substr builtin; dcl TRUE bit (1) aligned int static options (constant) init ("1"b); dcl UNSPEC bit (2) aligned int static options (constant) init ("00"b); dcl undo_request char (100); /* rmdb request that will cause the db to become consistent */ dcl unused2 char (200); /* output from mdbm_util_$inconsistent_get_info */ dcl unspec builtin; dcl verify builtin; end rmdb_rq_delete_object;  rmdb_rq_delete_relation.pl1 10/16/86 1551.9rew 10/16/86 1143.3 66069 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-07-24,Blair), approve(86-07-24,MCR7311), audit(86-09-15,Gilcrease), install(86-10-16,MR12.0-1187): Allow a null undo_request as an argument for rmdb_execute_undo. END HISTORY COMMENTS */ rmdb_rq_delete_relation: proc (I_sci_ptr, I_rmdb_ctl_ptr); /* . BEGIN_DESCRIPTION This procedure is called from the rmdb ssu_ routine Its purpose is to process the delete_relation rmdb request arguments Syntax for this request is : . delete_relation rel_name {-brief} {-long} . END_DESCRIPTION */ /* HISTORY 82-04-30 Written by Roger Lackey 82-06-25 Roger Lackey : changed force to brief and remove -no_force 82-07-01 Roger Lackey : Modified the calls to mu_db_inconsistent to use mdbm_util_$inconsistent_* for binding. */ %page; /* rmdb_rq_delete_relation: proc (I_sci_ptr, I_rmdb_ctl_ptr); */ /* Parameters */ dcl I_sci_ptr ptr parameter; /* Pointer to ssu info */ dcl I_rmdb_ctl_ptr ptr parameter; /* Pointer to restructuring control */ sci_ptr = I_sci_ptr; rmdb_ctl_ptr = I_rmdb_ctl_ptr; rmdb_delete_rel_info_ptr = null; if rmdb_ctl.version ^= RMDB_CTL_VERSION_1 then call error (error_table_$unimplemented_version, "rmdb_create_rel_info.incl.pl1"); on cleanup call tidy_up; /* Establish a cleanup handler for this procedure */ if rmdb_ctl.absolute_db_path = " " then call error (error_table_$action_not_performed, "^/There is no currently readied data base."); call ssu_$arg_count (sci_ptr, nargs); /* Get number of arguments supplied to me */ if nargs < 1 then call error (error_table_$wrong_no_of_args, "^/Usage: delete_relation rel_name {-brief} {-long}"); call ssu_$arg_ptr (sci_ptr, 1, arg_ptr, arg_len); /* First arg must be rel_name */ if arg_len > 30 /* Relation names can only be 30 chars long because the relation model name must have a ".m" suffix */ then call error (mrds_error_$rel_name_too_long, arg); if arg_len < 1 then call error (mrds_error_$no_rel_name, "^/Relation name was expected for first argument."); n = verify (arg, mrds_data_$valid_rel_and_attr_name_chars); if n ^= 0 then call error (mrds_error_$bad_rel_name, arg || "^/First bad character is: " || substr (arg, n, 1)); if substr (arg, 1, 1) = "_" then call error (mrds_error_$bad_rel_name, arg || "^/Relation names cannot begin with an underscore."); allocate rmdb_delete_rel_info in (wa) set (rmdb_delete_rel_info_ptr); rmdb_delete_rel_info.version = RMDB_DELETE_REL_INFO_VERSION_1; rmdb_delete_rel_info.absolute_db_path = rmdb_ctl.absolute_db_path; rmdb_delete_rel_info.db_model_ptr = rmdb_ctl.db_model_ptr; rmdb_delete_rel_info.relation_name = arg; rmdb_delete_rel_info.brief = "0"b; %page; /* Process rest of arguments */ do i = 2 to nargs; call ssu_$arg_ptr (sci_ptr, i, arg_ptr, arg_len); /* Get next arg */ if substr (arg, 1, 1) = "-" then do; /* Look for control args */ if arg = "-brief" | arg = "-bf" | arg = "-brief." then rmdb_delete_rel_info.brief = "1"b; else if arg = "-lg" | arg = "-long" then rmdb_delete_rel_info.brief = "0"b; else call error (error_table_$badopt, arg); /* Bad control arg */ end; else call error (error_table_$bad_arg, arg); end; /* END nargs > 1 */ call mdbm_util_$inconsistent_get_info (rmdb_ctl.db_model_ptr, /* See if db is inconsistent */ incon_flag, incon_name, unused, undo_request); if incon_flag then do; /* DB is inconsisten */ if undo_request = "" then call rmdb_execute_undo (sci_ptr, "delete_relation", rmdb_ctl.absolute_db_path, rmdb_ctl.db_model_ptr, incon_name, undo_request); else do; undo_rq_name = before (undo_request, BLANK); rest = after (undo_request, undo_rq_name); i = verify (rest, BLANK); rest = substr (rest, i); /* Remove leading blanks */ undo_rel_name = before (rest, BLANK); if ^(undo_rq_name = "delete_relation" & /* If not delete_rel with same relation name then */ undo_rel_name = rmdb_delete_rel_info.relation_name) then call rmdb_execute_undo (sci_ptr, "delete_relation", rmdb_ctl.absolute_db_path, rmdb_ctl.db_model_ptr, incon_name, undo_request); end; end; call rmdb_delete_relation (rmdb_ctl_ptr, rmdb_delete_rel_info_ptr, err_msg, code); if code ^= 0 then call error (code, err_msg); exit: return; %page; /* * * * * * * * * * * * * error * * * * * * * * * * * * * */ error: proc (err_code, err_message); /* Error procedure for rmdb_create_relation.pl1 */ dcl err_code fixed bin (35); dcl err_message char (*); dcl ssu_$abort_line entry () options (variable); call tidy_up; call ssu_$abort_line (sci_ptr, err_code, err_message); end error; /* * * * * * * * * * * * * tidy_up * * * * * * * * * * * * * */ tidy_up: proc; if rmdb_delete_rel_info_ptr ^= null then free rmdb_delete_rel_info; end tidy_up; %page; dcl after builtin; dcl arg char (arg_len) based (arg_ptr); dcl arg_len fixed bin (21); dcl arg_ptr ptr; dcl before builtin; dcl BLANK char (1) int static options (constant) init (" "); dcl cleanup condition; dcl code fixed bin (35); dcl error_table_$action_not_performed fixed bin (35) ext static; dcl error_table_$badopt fixed bin (35) ext static; dcl error_table_$bad_arg fixed bin (35) ext static; dcl error_table_$unimplemented_version fixed bin (35) ext static; dcl error_table_$wrong_no_of_args fixed bin (35) ext static; dcl err_msg char (256); dcl i fixed bin; dcl incon_flag bit (1); dcl incon_name char (32); dcl mrds_data_$valid_rel_and_attr_name_chars char (128) varying ext; dcl mrds_error_$bad_rel_name fixed bin (35) ext static; dcl mrds_error_$no_rel_name fixed bin (35) ext static; dcl mrds_error_$rel_name_too_long fixed bin (35) ext static; dcl mdbm_util_$inconsistent_get_info entry (ptr, bit (1), char (*), char (*), char (*)); dcl n fixed bin; dcl nargs fixed bin; dcl null builtin; dcl rest char (100) varying; dcl rmdb_delete_relation entry (ptr, ptr, char (*), fixed bin (35)); dcl rmdb_execute_undo entry (ptr, char (32), char (168), ptr, char (32), char (100)); dcl sci_ptr ptr; dcl ssu_$arg_count entry (ptr, fixed bin); dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin (21)); dcl substr builtin; dcl sys_info$max_seg_size fixed bin (35) ext static; dcl undo_rel_name char (32); dcl undo_request char (100); dcl undo_rq_name char (32) varying; dcl unused char (32); dcl verify builtin; dcl wa area (sys_info$max_seg_size) based (rmdb_ctl.work_area_ptr); %page; %include mrds_rmdb_ctl; %page; %include rmdb_delete_rel_info; end rmdb_rq_delete_relation;  rmdb_rq_dot.pl1 10/16/86 1551.9r w 10/16/86 1144.3 15435 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ rmdb_rq_dot: proc (sci_ptr, info_ptr); /* . BEGIN_DESCRIPTION This routine displays the current version of the restructure_mrds_db subsystem and the data base currently readied for restructuring in response to the "." request. . END_DESCRIPTION Known Bugs: Other Problems: . HISTORY 82-03-29 Davids: Written 82-04-08 Davids: changed the name of the subsystem that is . printed from restructure_mrds_db to rmdb to . a name change that was made a while back. 82-06-22 Davids: removed call to get_shortest_path_ 83-05-25 Davids: Added dcl for rtrim */ /* PARAMETERS */ dcl sci_ptr ptr; /* (input) pointer to the subsystem control info structure */ /* need to be able to pass it to the ssu entries */ dcl info_ptr ptr; /* (input) pointer to the rmdb_ctl structure which is both */ /* read and written */ /* BUILTINS */ dcl rtrim builtin; /* ENTRIES */ dcl ioa_ entry options (variable); /* INCLUDES */ %page; %include mrds_rmdb_ctl; rmdb_ctl_ptr = info_ptr; if rmdb_ctl.absolute_db_path = "" then call ioa_ ("rmdb: ^a^-No database is currently readied.", rmdb_ctl.rmdb_version); else call ioa_ ("rmdb: ^a^-^a", rmdb_ctl.rmdb_version, rtrim (rmdb_ctl.absolute_db_path)); return; end rmdb_rq_dot;  rmdb_rq_free_db.pl1 10/16/86 1551.9rew 10/16/86 1143.3 37359 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ rmdb_rq_free_db: proc (sci_ptr, info_ptr); /****^ HISTORY COMMENTS: 1) change(85-12-04,Spitzer), approve(85-12-04,MCR7311), audit(86-09-02,Blair), install(86-10-16,MR12.0-1187): If we have a xreference file, destroy it. Terminate the model properly. END HISTORY COMMENTS */ /* . BEGIN_DESCRIPTION This routine implements the relesae_db request within the restructure_mrds_db subsystem. It checks to be sure that the request has been called with 0 arguments and that a database has already been readied so that it makes sense to try to release it. . END_DESCRIPTION Known Bugs: Other Problems: . HISTORY 82-03-29 Davids: Written 82-05-25 Davids: modified to set rmdb_ctl.db_model_ptr to null at . the same time that the absolute_db_path is set . to "". 83-05-24 Davids: Changed the argument list to rmdb_free_db to include a pointer to the saved_res_version. */ /* PARAMETERS */ dcl sci_ptr ptr; /* (input) pointer to the subsystem control info structure */ /* need to be able to pass it to the ssu routines */ dcl info_ptr ptr; /* (input) pointer to the rmdb_ctl structure which is both */ /* read and written. */ /* EXTERNAL STATIC */ dcl error_table_$action_not_performed fixed bin (35) external static; dcl error_table_$badcall fixed bin (35) external static; /* ENTRIES */ dcl mdbm_util_$xref_destroy entry (ptr, char(*), char(*), char(*), fixed bin(35)); dcl rmdb_free_db entry (char (168), ptr, char (500), fixed bin (35)); dcl ssu_$abort_line entry options (variable); dcl ssu_$arg_count entry (ptr, fixed bin); dcl terminate_file_ entry (ptr, fixed bin(24), bit(*), fixed bin(35)); /* INTERNAL AUTOMATIC */ dcl code fixed bin (35); /* standard error code */ dcl error_message char (500); /* error message returned from rmdb_free_db */ dcl nargs fixed bin; /* number of arguments the request was called with */ /* BUILTINS */ dcl null builtin; /* INCLUDES */ %page; %include mrds_rmdb_ctl; %include terminate_file; %page; /* Init the value of the rmdb_ctl pointer */ rmdb_ctl_ptr = info_ptr; /* Get the number of arguments that the request was called with - if its not 0 its an error. Note that ssu_$abort_line does not return. */ call ssu_$arg_count (sci_ptr, nargs); if nargs ^= 0 then call ssu_$abort_line (sci_ptr, error_table_$badcall, "^/The free_db (fdb) request is called without any arguments"); /* If the absolute_db_path element of the rmdb_ctl structure is null it means that no database is currently readied - this is an error. */ if rmdb_ctl.absolute_db_path = "" then call ssu_$abort_line (sci_ptr, error_table_$action_not_performed, "^/There is no currently readied database to be freed"); /* the only errors that are now possible will occur within the call to rmdb_free_db. */ call rmdb_free_db (rmdb_ctl.absolute_db_path, rmdb_ctl.saved_res_version_ptr, error_message, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, error_message); /* Get rid of the xreference file. */ if rmdb_ctl.crossref_file_info.iocb_ptr ^= null then call mdbm_util_$xref_destroy (rmdb_ctl.crossref_file_info.iocb_ptr, rmdb_ctl.temp_dir_path, rmdb_ctl.crossref_file_info.name, (""), (0)); /* By changing rmdb_ctl.absolute_db_path to "" we indicate that there is no currently readied db. */ rmdb_ctl.absolute_db_path = ""; if rmdb_ctl.db_model_ptr ^= null then call terminate_file_ (rmdb_ctl.db_model_ptr, 0, TERM_FILE_TERM, (0)); return; end rmdb_rq_free_db;  rmdb_rq_ready_db.pl1 09/26/88 1255.5rew 09/26/88 1248.2 131310 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* format: ^inddcls,^indattr,indnoniterend,^indnoniterdo,indend,tree,^case,insnl,comcol61,dclind5,declareind5,delnl */ rmdb_rq_ready_db: proc (sci_ptr, info_ptr); /****^ 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): added the database creation code. 2) change(88-01-11,Blair), approve(88-02-25,MCR7840), audit(88-03-03,Dupuis), install(88-03-08,MR12.2-1034): Re_arrange some code so that the pathname of the database isn't expanded until after we try to fill in the mrds_pathname_info structure so that we can use search paths to locate the database. Only if the database doesn't exist do we try to create one in the working_dir. 3) change(88-09-20,Dupuis), approve(88-09-20,MCR7995), audit(88-09-20,Blair), install(88-09-26,MR12.2-1119): Changed error_table_bad_arg to error_table_$badopt (phx20666). END HISTORY COMMENTS */ /* . BEGIN_DESCRIPTION This routines implements that ready_db request within the restructure_mrds_db subsystem. It processes and checks that arguments associated with the request and then calls the rmdb_ready_db routine which actually does the work or ready-ing the db for restructuring. If the database does not exist, the user will be queried to create it. If the answer is yes, the database is created with no existing domains, attribute, or domains, and the database is quiesced. In the event that the readied database is marked inconsistent it will query the user for execution of the undo request. . END_DESCRIPTION Known Bugs: Other Problems: . HISTORY 82-03-29 Davids: Written 82-04-08 Davids: Changed the error messages for "a database is . alreadied readied" and "could not ready the . database" so that they are formated better. 82-04-30 Davids: Added code to check the consistency of the . database and to execute the undo request. 82-05-25 Davids: changed to have rmdb_ctl.db_model_ptr in calling . sequence to rmdb_ready_db. 82-05-26 Davids: changed to call rmdb_execute_undo if the database . is inconsistent. 82-06-07 Davids: changed to check size condition if user inputs a . quiesce_wait_time that is to large. Also to . recognize a negative wait time so as not to . treat it like a control argument. And changed . changed the default wait time to use . mrds_data_$quiesce_wait (= 0) instead of the . constant 10. 82-06-25 Davids: removed call to get_shortest_path_ and . reformated some lines to prevent wrap-around 82-07-01 Roger Lackey : Modified the calls to mu_db_inconsistent to use . mdbm_util_$inconsistent_* for binding. 82-08-20 Davids: modified the call to rmdb_ready_db to include . addr (rmdb_ctl.relmgr_entries). 83-05-24 Davids: Modified the parameter list of rmdb_ready_db to include the saved_res_version_ptr argument. 84-10-23 Benjamin: When returning from rmdb_ready_db, if code is mrds_error_$my_quiesced_db, will not abort, but rather set a flag that says that rmdb did not quiesce the database. */ /* PARAMETERS */ dcl sci_ptr ptr; /* (input) pointer to the subsystem control infor structure */ /* need to be able to pass it to the ssu entries */ dcl info_ptr ptr; /* (input) pointer the rmdb_ctl structure which is both */ /* read and written */ /* EXTERNAL STATIC */ dcl error_table_$badopt fixed bin (35) external static; dcl error_table_$bad_conversion fixed bin (35) external static; dcl error_table_$noarg fixed bin (35) external static; dcl mrds_data_$quiesce_wait fixed bin (35) external static; dcl mrds_error_$my_quiesced_db fixed bin (35) ext static; dcl mrds_error_$no_database fixed bin (35) ext static; /* ENTRIES */ dcl command_query_$yes_no entry () options (variable); dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl expand_pathname_$add_suffix entry (char(*), char(*), char(*), char(*), fixed bin(35)); dcl mdbm_util_$inconsistent_get_info entry (ptr, bit (1), char (*), char (*), char (*)); dcl pathname_ entry (char(*), char(*)) returns(char(168)); dcl rmdb_create_db entry (char (*), char (*), char (*), char (*), ptr, char (*), fixed bin (35)); dcl rmdb_execute_undo entry (ptr, char (32), char (168), ptr, char (32), char (100)); dcl rmdb_ready_db entry (char (168), fixed bin, ptr, char (168), ptr, ptr, char (500), fixed bin (35)); dcl ssu_$abort_line entry options (variable); dcl ssu_$arg_count entry (ptr, fixed bin); dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin (21)); /* INTERNAL AUTOMATIC */ dcl arg_len fixed bin (21); /* length of an argument */ dcl arg_ptr ptr; /* pointer to an argument */ dcl code fixed bin (35); /* standard error code */ dcl db_dir char (168); /* expanded directory of db */ dcl db_name char (32); /* db name + suffix */ dcl db_path char (168); /* database path supplied as an argument */ dcl error_message char (500); /* error message returned from rmdb_ready_db */ dcl force_sw bit (1); /* true if -force was specified */ dcl i fixed bin; /* loop index */ dcl incon_name char (32); /* name of module that marked db as inconsistent */ dcl incon_value bit (1); /* true ==> db is inconsistent */ dcl nargs fixed bin; /* number of arguments the request was called with */ dcl quiesce_wait_time fixed bin; /* how many seconds the caller is willing to wait to try to quiesce the database */ dcl quiesce_wait_time_supplied bit (1); /* true if a wait time has been supllied as an argument */ dcl relation_type char (32); /* file type command line argument */ dcl relation_modes char (256); /* mode command line argument */ dcl undo_request char (100); /* rmdb request that will make the db consistent again */ dcl unused1 char (200); /* unused output parameter from mdbm_util_$inconsistent_get_info */ /* BUILTINS */ dcl addr builtin; dcl index builtin; dcl verify builtin; /* BASED */ dcl arg char (arg_len) based (arg_ptr); /* an argument */ /* CONDITIONS */ dcl size condition; /* CONSTANTS */ dcl DATA_MANAGEMENT_FILE char (32) int static options (constant) init ("data_management_file"); dcl OFF bit (1) internal static options (constant) init ("0"b); dcl ON bit (1) internal static options (constant) init ("1"b); dcl VFILE char (32) int static options (constant) init ("vfile"); /* INCLUDES */ %page; %include mrds_rmdb_ctl; /* Assign initial values */ rmdb_ctl_ptr = info_ptr; db_path = ""; relation_type = ""; relation_modes = ""; quiesce_wait_time_supplied = OFF; force_sw = OFF; /* If the absolute_db_path is not null it indicates that a database is currently in the readied state. The caller cannot request to ready a database while one is still readied. The call to ssu_$abort_line does not return, it causes the rest of the request line to be aborted and returns control to the listener. */ if rmdb_ctl.absolute_db_path ^= "" then call ssu_$abort_line (sci_ptr, 0, "^/The database ^a^/^-is already readied, only 1 database may be readied at a time." || "^/^-Type ""free_db"" to free the currently readied database.", rmdb_ctl.absolute_db_path); /* The ready_db request takes two control args, -pathname (-pn) and -quiesce_wait_time (-qwt). These arguments may appear in any order and any number of times with the last value being the one used. If the first argument is not a control arg, i.e. does not begin with a "-" it is assumed to be the database path. */ call ssu_$arg_count (sci_ptr, nargs); i = 1; do while (i <= nargs); call ssu_$arg_ptr (sci_ptr, i, arg_ptr, arg_len); if /* case */ index (arg, "-") = 1 then if /* case */ arg = "-fc" | arg = "-force" then force_sw = "1"b; else if arg = "-nfc" | arg = "-no_force" then force_sw = "0"b; else if arg = "-pn" | arg = "-pathname" then do; if i = nargs then missing_path: call ssu_$abort_line (sci_ptr, error_table_$noarg, "^/The -pathname (-pn) control arg was given but no pathname was supplied"); call ssu_$arg_ptr (sci_ptr, i + 1, arg_ptr, arg_len); if index (arg, "-") = 1 then goto missing_path; db_path = arg; i=i+1; end; else if arg = "-qwt" | arg = "-quiesce_wait_time" then do; if i = nargs then call ssu_$abort_line (sci_ptr, error_table_$noarg, "^/The -quiesce_wait_time (-qwt) control arg was given but no quiesce wait time was supplied."); call ssu_$arg_ptr (sci_ptr, i + 1, arg_ptr, arg_len); if verify (arg, "-0123456789") ^= 0 then goto bad_conversion; quiesce_wait_time_supplied = ON; on size begin; call ssu_$abort_line (sci_ptr, error_table_$bad_conversion, "^/The size of the quiesce wait time ^a is larger " || "than the maximum of 131071.", arg); end; (size): quiesce_wait_time = cv_dec_check_ (arg, code); revert size; if code ^= 0 then bad_conversion: call ssu_$abort_line (sci_ptr, error_table_$bad_conversion, "^/Could not convert ^a into an integer representing the quiesce wait-time.", arg); if quiesce_wait_time < 0 then call ssu_$abort_line (sci_ptr, error_table_$bad_conversion, "^/The quiesce wait time ^a is negative, wait times must be >= 0.", arg); i=i+1; end; else if arg = "-rt" | arg = "-relation_type" then do; if i = nargs then missing_type: call ssu_$abort_line (sci_ptr, error_table_$noarg, "^/The -relation_type (-rt) control argument was given but no relation type was supplied."); call ssu_$arg_ptr (sci_ptr, i+1, arg_ptr, arg_len); if index (arg, "-") = 1 then goto missing_type; relation_type = arg; i = i+1; if i ^= nargs then do; call ssu_$arg_ptr (sci_ptr, i+1, arg_ptr, arg_len); if index (arg, "-") ^= 1 then do; relation_modes = arg; i = i + 1; end; end; end; else call ssu_$abort_line (sci_ptr, error_table_$badopt, "^/Argument ^i (^a) is unrecognized", i, arg); else if db_path = "" then db_path = arg; else call ssu_$abort_line (sci_ptr, 0, "Duplicate argument.^/A database_path has already been given. ^a", arg); i = i + 1; end; /* do while */ /* If the database path has not been supplied as an argument its an error */ if db_path = "" then call ssu_$abort_line (sci_ptr, error_table_$noarg, "^/The database path is required and has not been supplied"); /* If a quiesce_wait_time has not been supplied assume the default value. */ if ^quiesce_wait_time_supplied then quiesce_wait_time = mrds_data_$quiesce_wait; /* Check validity of the relation type. If no relation type specified, default to vfile types */ if relation_type = "" then relation_type = VFILE; else if relation_type = "dmf" then relation_type = DATA_MANAGEMENT_FILE; else if ^(relation_type = VFILE | relation_type = DATA_MANAGEMENT_FILE) then call ssu_$abort_line (sci_ptr, 0, "Invalid relation_type supplied. ^a^/^-Valid types are: ^a, ^a", relation_type, VFILE, DATA_MANAGEMENT_FILE); /* Make the call that will prepare the database for restructuring. */ rmdb_ctl.flags.database_readied_by_rmdb = ON; call rmdb_ready_db (db_path, quiesce_wait_time, addr (rmdb_ctl.relmgr_entries), rmdb_ctl.absolute_db_path, rmdb_ctl.db_model_ptr, rmdb_ctl.saved_res_version_ptr, error_message, code); if code = mrds_error_$my_quiesced_db then rmdb_ctl.flags.database_readied_by_rmdb = OFF; else if code = mrds_error_$no_database then do; call expand_pathname_$add_suffix (db_path, "db", db_dir, db_name, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", db_path); db_path = pathname_ (db_dir, db_name); if ^force_sw then do; call command_query_$yes_no (force_sw, mrds_error_$no_database, "restructure_mrds_db (ready_db)", "Answering yes will create an empty MRDS database.", "^/Do you wish to create ^a?", db_path); if ^force_sw then call ssu_$abort_line (sci_ptr, 0); end; call rmdb_create_db (db_path, relation_type, relation_modes, rmdb_ctl.absolute_db_path, rmdb_ctl.db_model_ptr, error_message, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^/The database ^a^/could not be created.^/^-^a", db_path, error_message); call rmdb_ready_db (db_path, quiesce_wait_time, addr (rmdb_ctl.relmgr_entries), rmdb_ctl.absolute_db_path, rmdb_ctl.db_model_ptr, rmdb_ctl.saved_res_version_ptr, error_message, code); end; else if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^/The database ^a^/^-could not be readied for restructuring^/^-^a", db_path, error_message) ; /* If the database is inconsistent it must be made consistent before the user can be told that it has been readied. Note at this point the database is really readied. rmdb_execute_undo will query the user about running the undo request. If the user chooses not to run the undo request or the undo request fails the database is freed and then the request line is aborted. If the database can't be freed the subsystem is aborted. */ call mdbm_util_$inconsistent_get_info (rmdb_ctl.db_model_ptr, incon_value, incon_name, unused1, undo_request); if incon_value then call rmdb_execute_undo (sci_ptr, "ready_db", rmdb_ctl.absolute_db_path, rmdb_ctl.db_model_ptr, incon_name, undo_request); return; end rmdb_rq_ready_db;  rmdb_rq_rename.pl1 12/09/86 1247.6rew 12/09/86 1235.4 58149 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1985 * * * *********************************************************** */ /* format: ^inddcls,^indattr,indnoniterend,^indnoniterdo,indend,tree,^case,insnl,comcol61,dclind5,declareind5,delnl */ /*DESCRIPTION This set of routines parses the command line for the rename_(attribute domain relation) requests of the restructure_mrds_db subsystem. */ /****^ HISTORY COMMENTS: 1) change(85-12-03,Spitzer), approve(85-12-03,MCR7311), audit(86-09-15,Gilcrease), install(86-10-16,MR12.0-1187): written. 2) change(86-12-05,Blair), approve(86-12-05,PBF7311), audit(86-12-05,Dupuis), install(86-12-09,MR12.0-1237): Null out the request info_structure ptr so that tidy_up works properly. END HISTORY COMMENTS */ rmdb_rq_rename: proc; return; rmdb_rq_rename$attribute: entry (Isci_ptr, Iinfo_ptr); type = RENAME_ATTRIBUTE; goto START; rmdb_rq_rename$domain: entry (Isci_ptr, Iinfo_ptr); type = RENAME_DOMAIN; goto START; rmdb_rq_rename$relation: entry (Isci_ptr, Iinfo_ptr); type = RENAME_RELATION; goto START; START: sci_ptr = Isci_ptr; rmdb_ctl_ptr = Iinfo_ptr; rename_object_info_ptr = null; on cleanup call tidy_up; /* Get number of arguments, must be an even number. */ call ssu_$arg_count (sci_ptr, nargs); if nargs = 0 | (mod (nargs, 2) = 1) then USAGE: call error (error_table_$wrong_no_of_args, "^/Usage: " || myname (type) || " from1 to1 {...fromN toN}"); rename_object_info_count = divide (nargs, 2, 17, 0); allocate rename_object_info in (my_area) set (rename_object_info_ptr); rename_object_info.version = rename_object_info_version_1; rename_object_info.type = type; idx = 1; do loop = 1 to nargs; call ssu_$arg_ptr (sci_ptr, loop, argp, argl); if argl = 0 then goto USAGE; if argl > 30 & type = RENAME_RELATION then call error (mrds_error_$rel_name_too_long, arg); if argl > 32 then call error (mrds_error_$long_ident, arg); if verify (arg, mrds_data_$valid_rel_and_attr_name_chars) ^= 0 then do; if type = RENAME_RELATION then code = mrds_error_$bad_rel_name; else if type = RENAME_ATTRIBUTE then code = mrds_error_$bad_attr_name; else code = mrds_error_$bad_ident; call error (code, arg); end; if search (substr (arg, 1, 1), "-_") ^= 0 then do; if type = RENAME_RELATION then code = mrds_error_$inv_rel_name_first_char; else if type = RENAME_ATTRIBUTE then code = mrds_error_$inv_attr_name_first_char; else code = mrds_error_$inv_domain_name_first_char; call error (code, arg); end; if mod (loop, 2) = 1 then rename_object_info.from (idx) = arg; else do; rename_object_info.to (idx) = arg; idx = idx + 1; end; end; /* do loop */ /* Make sure we have an open database. */ if rmdb_ctl.absolute_db_path = "" then call error (error_table_$action_not_performed, "^/There is no currently readied database."); /* Determine whether or not we need to clean up from a previous operation. */ call mdbm_util_$inconsistent_get_info (rmdb_ctl.db_model_ptr, incon_value, incon_name, unused2, undo_request); if incon_value then call rmdb_execute_undo (sci_ptr, "create_attribute", rmdb_ctl.absolute_db_path, rmdb_ctl.db_model_ptr, incon_name, undo_request); call rmdb_rename (rmdb_ctl_ptr, rename_object_info_ptr, error_message, code); if code ^= 0 then call error (code, error_message); return; %page; /* * * * * * * * * * * * * error * * * * * * * * * * * * * */ error: proc (err_code, err_message); /* Error procedure for rmdb_rename.pl1 */ dcl err_code fixed bin (35) parameter; dcl err_message char (*) parameter; dcl ssu_$abort_line entry () options (variable); call tidy_up; call ssu_$abort_line (sci_ptr, err_code, err_message); end error; /* * * * * * * * * * * * * tidy_up * * * * * * * * * * * * * */ tidy_up: proc; if rename_object_info_ptr ^= null then free rename_object_info; end tidy_up; %page; %include mrds_rmdb_ctl; %include rmdb_rename_object_info; %page; dcl arg char (argl) based (argp); dcl argl fixed bin (21); dcl argp ptr; dcl code fixed bin (35); dcl cleanup condition; dcl divide builtin; dcl empty builtin; dcl error_message char (500); dcl error_table_$action_not_performed fixed bin(35) ext static; dcl error_table_$wrong_no_of_args fixed bin (35) ext static; dcl idx fixed bin; dcl Iinfo_ptr ptr parameter; dcl Isci_ptr ptr parameter; dcl incon_name char (32); /* name of the request that caused the db to become inconsistent */ dcl incon_value bit (1); /* true ::= the db is inconsistent */ dcl loop fixed bin; dcl mdbm_util_$inconsistent_get_info entry options(variable); dcl mod builtin; dcl mrds_data_$valid_rel_and_attr_name_chars char (128) varying ext static; dcl mrds_error_$bad_attr_name fixed bin (35) ext static; dcl mrds_error_$bad_ident fixed bin (35) ext static; dcl mrds_error_$bad_rel_name fixed bin (35) ext static; dcl mrds_error_$inv_attr_name_first_char fixed bin (35) ext static; dcl mrds_error_$inv_domain_name_first_char fixed bin (35) ext static; dcl mrds_error_$inv_rel_name_first_char fixed bin (35) ext static; dcl mrds_error_$long_ident fixed bin (35) ext static; dcl mrds_error_$rel_name_too_long fixed bin (35) ext static; dcl my_area area; dcl myname (3) char (32) int static options (constant) init ("rename_attribute", "rename_domain", "rename_relation"); dcl nargs fixed bin; dcl null builtin; dcl rmdb_execute_undo entry (ptr, char(32), char(168), ptr, char(32), char(100)); dcl rmdb_rename entry (ptr, ptr, char (*), fixed bin (35)); dcl sci_ptr ptr; dcl search builtin; dcl ssu_$abort_line entry () options (variable); dcl ssu_$arg_count entry (ptr, fixed bin); dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin (21)); dcl substr builtin; dcl type fixed bin (17); dcl undo_request char (100); /* rmdb request that will cause the db to become consistent */ dcl unused2 char (200); /* output from mdbm_util_$inconsistent_get_info */ dcl verify builtin; end rmdb_rq_rename;  rmdb_rq_tb_.alm 11/05/86 1615.9r w 11/04/86 1038.5 32634 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " *********************************************************** " Request definitions for the restructure_mrds_db subsystem " 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): " Add create_(attribute domain), rename_(attribute domain), " delete_(attribute domain), undo_rename requests " END HISTORY COMMENTS " HISTORY " 82-03-10 Davids written " " 82-06-22 Davids: combined and alphabetized the ssu and rmdb " requests into 1 list " " 82-07-02 Roger Lackey : changed rmdb_rq_dm to call mdbm_util_$rmdb_rq_dmdm " for binding " " 82-08-11 Paul Benjamin: changed display_mrds_dm to display_data_model with " short names of ddm and dmdm. " " 83-10-04 Paul Benjamin: removed all standard ssu_ requests in favor of the " in favor of adding the standard request table. " name rmdb_rq_tb_ include ssu_request_macros begin_table rmdb_rq_tb_ " request ., rmdb_rq_dot$rmdb_rq_dot, (), (Print current status.), flags.allow_command request apply, ssu_requests_$apply_request_util, (ap), , flags.unimplemented+flags.dont_summarize+flags.dont_list request create_attribute, rmdb_rq_create_attribute$rmdb_rq_create_attribute, (cra), (Creates a new attribute.), flags.allow_command request create_domain, rmdb_rq_create_domain$rmdb_rq_create_domain, (crd), (Creates a new domain.), flags.allow_command request create_index, rmdb_rq_create_index$rmdb_rq_create_index, (cri), (Creates a new index into a relation.), flags.allow_command request create_relation, rmdb_rq_create_relation$rmdb_rq_create_relation, (crr), (Creates a new relation.), flags.allow_command request delete_attribute, rmdb_rq_delete_object$attribute, (dla), (Deletes one or more attributes.), flags.allow_command request delete_domain, rmdb_rq_delete_object$domain, (dld), (Deletes one or more domains.), flags.allow_command request delete_index, rmdb_rq_delete_index$rmdb_rq_delete_index, (dli), (Deletes an index.), flags.allow_command request delete_relation, rmdb_rq_delete_relation$rmdb_rq_delete_relation, (dlr), (Deletes a relation.), flags.allow_command request display_data_model, mdbm_util_$rmdb_rq_dmdm, (ddm,dmdm), (Displays data model info.), flags.allow_command request free_db, rmdb_rq_free_db$rmdb_rq_free_db, (fdb), (Frees a database that has previously been readied for restructuring.), flags.allow_command request ready_db, rmdb_rq_ready_db$rmdb_rq_ready_db, (rdb), (Readies a database for restructuring.), flags.allow_command request rename_attribute, rmdb_rq_rename$attribute, (rna), (Replaces the name of an attribute with another name.), flags.allow_command request rename_domain, rmdb_rq_rename$domain, (rnd), (Replaces the name of a domain with another name.), flags.allow_command request rename_relation, rmdb_rq_rename$relation, (rnr), (Replaces the name of a relation with another name.), flags.allow_command request undo_rename, rmdb_rename$undo_rename, (), (), flags.allow_command+flags.dont_summarize+flags.dont_list end_table rmdb_rq_tb_ end  rmdb_salvage_db.pl1 12/09/86 1247.6rew 12/09/86 1236.5 46935 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1986 * * * *********************************************************** */ /* format: ^inddcls,^indattr,indnoniterend,^indnoniterdo,indend,tree,^case,insnl,comcol61,dclind5,declareind5,delnl */ /*DESCRIPTION This routine attempts to clean up after certain rmdb requests. It is only called by the undo operation (when the database in marked inconsistent) after the operation is undone. The purpose is to delete all the files (relation.m or relation MSF/DMF) that have unique names. These strangely named files are created by operations that cause the relation to be copied. */ /****^ HISTORY COMMENTS: 1) change(86-01-27,Spitzer), approve(86-01-27,MCR7311), audit(86-09-02,Blair), install(86-10-16,MR12.0-1187): written 2) change(86-11-03,Blair), approve(86-11-03,PBF7311), audit(86-12-01,Dupuis), install(86-12-09,MR12.0-1237): Take out the code that lets you roll the files forward when a new relation has been created from the old during a delete or rename. We don't have enough information to update the model properly even if the relations are good, so we always have to roll back. END HISTORY COMMENTS */ rmdb_salvage_db: proc (Idb_path); db_path = Idb_path; system_areap, status_area_ptr = get_system_free_area_ (); star_names_ptr, star_entry_ptr = null; dbm_ptr = null; status_ptr = addr (sb); status_branch.names_relp = "0"b; on cleanup call cleaner; call initiate_file_ (db_path, "db_model", RW_ACCESS, dbm_ptr, (0), code); if code ^= 0 then return; last_fi_ptr = null; done = "0"b; do fi_ptr = ptr (dbm_ptr, db_model.file_ptr) repeat ptr (dbm_ptr, file_info.fwd_ptr) while ((rel (fi_ptr) ^= NULL_OFFSET) & (^done)); if substr (file_info.file_name, 1, 1) = "!" then done = "1"b; else last_fi_ptr = fi_ptr; end; /* do fi_ptr */ if last_fi_ptr = null then db_model.file_ptr = NULL_OFFSET; else last_fi_ptr -> file_info.fwd_ptr = NULL_OFFSET; call hcs_$star_ (db_path, "!*.m", star_ALL_ENTRIES, system_areap, star_entry_count, star_entry_ptr, star_names_ptr, code); if code ^= 0 then return; do loop = 1 to star_entry_count; call process_file (loop); end; /* do loop */ free star_names in (system_area); star_names_ptr = null; free star_entries in (system_area); star_entry_ptr = null; return; %page; process_file: proc (star_idx); dcl model_name char (32); dcl relation_name char (32); dcl star_idx fixed bin parameter; model_name = star_names (star_entries (star_idx).nindex); relation_name = before (model_name, "."); /* Delete the uniquely named files. */ call delete_file (relation_name); call delete_file (model_name); return; %page; delete_file: proc (file_name); dcl delete_$path entry (char (*), char (*), bit (36) aligned, char (*), fixed bin (35)); dcl error_table_$unsupported_operation fixed bin (35) ext static; dcl file_name char (*) parameter; dcl fs_util_$delentry_file entry (char (*), char (*), fixed bin (35)); call fs_util_$delentry_file (db_path, file_name, code); if code = error_table_$unsupported_operation then call delete_$path (db_path, file_name, "101111"b, myname, code); return; end delete_file; end process_file; %page; cleaner: proc; dcl p ptr; if star_names_ptr ^= null then free star_names in (system_area); if star_entry_ptr ^= null then free star_entries in (system_area); if status_branch.names_relp ^= "0"b then free status_entry_names in (system_area); do p = dbm_ptr; if p ^= null then call terminate_file_ (dbm_ptr, (0), TERM_FILE_TERM, (0)); end; return; end cleaner; %page; %include access_mode_values; %page; %include mdbm_db_model; %page; %include star_structures; %page; %include status_structures; %page; %include terminate_file; %page; dcl addr builtin; dcl before builtin; dcl cleanup condition; dcl code fixed bin (35); dcl db_path char (168); dcl done bit (1) aligned; dcl fixed builtin; dcl get_system_free_area_ entry () returns (ptr); dcl hcs_$star_ entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35)); dcl Idb_path char (*) parameter; /* absolute pathname of the database */ dcl initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35)); dcl last_fi_ptr ptr; dcl loop fixed bin; dcl myname char (32) int static options (constant) init ("rmdb_salvage_db"); dcl null builtin; dcl NULL_OFFSET bit (18) unaligned int static options (constant) init ((18)"1"b); dcl pointer builtin; dcl ptr builtin; dcl rel builtin; dcl 1 sb aligned like status_branch; dcl substr builtin; dcl sum builtin; dcl sys_info$max_seg_size fixed bin (35) ext static; dcl system_area area based (system_areap); dcl system_areap ptr; dcl terminate_file_ entry (ptr, fixed bin (24), bit (*), fixed bin (35)); end rmdb_salvage_db; bull_copyright_notice.txt 08/30/05 1008.4r 08/30/05 1007.3 00020025 ----------------------------------------------------------- Historical Background This edition of the Multics software materials and documentation is provided and donated to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. as a contribution to computer science knowledge. This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology, Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull and Bull HN Information Systems Inc. to the development of this operating system. Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970), renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for managing computer hardware properly and for executing programs. Many subsequent operating systems incorporated Multics principles. Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. . ----------------------------------------------------------- Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without fee is hereby granted,provided that the below copyright notice and historical background appear in all copies and that both the copyright notice and historical background and this permission notice appear in supporting documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining to distribution of the programs without specific prior written permission. Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc. Copyright 2006 by Bull HN Information Systems Inc. Copyright 2006 by Bull SAS All Rights Reserved